From b65feec3bdcc661b7110892deb6fc92f2f20cc77 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 17 Sep 2008 19:35:30 +1000 Subject: [PATCH 002/772] Add http-put, and make any return code between 200 and 299 success. --- basis/http/client/client.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 8dc1924a12..46bee405d1 100755 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -141,7 +141,7 @@ PRIVATE> do-redirect ] with-variable ; -: success? ( code -- ? ) 200 = ; +: success? ( code -- ? ) 200 299 between? ; ERROR: download-failed response body ; @@ -183,3 +183,9 @@ M: download-failed error. : http-post ( post-data url -- response data ) http-request ; + +: ( data url -- request ) + "PUT" >>method ; + +: http-put ( data url -- response data ) + http-request ; From d7df5b22d20102a45e1010c203e0a04d299d15b4 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 1 Oct 2008 10:38:54 +1000 Subject: [PATCH 003/772] adding initial couchdb --- extra/couchdb/authors.txt | 1 + extra/couchdb/couchdb-tests.factor | 4 +++ extra/couchdb/couchdb.factor | 43 ++++++++++++++++++++++++++++++ 3 files changed, 48 insertions(+) create mode 100644 extra/couchdb/authors.txt create mode 100644 extra/couchdb/couchdb-tests.factor create mode 100644 extra/couchdb/couchdb.factor diff --git a/extra/couchdb/authors.txt b/extra/couchdb/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/couchdb/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/couchdb/couchdb-tests.factor b/extra/couchdb/couchdb-tests.factor new file mode 100644 index 0000000000..8907c0b811 --- /dev/null +++ b/extra/couchdb/couchdb-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test couchdb ; +IN: couchdb.tests diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor new file mode 100644 index 0000000000..7e1d97e786 --- /dev/null +++ b/extra/couchdb/couchdb.factor @@ -0,0 +1,43 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs continuations debugger http.client io json.reader json.writer kernel sequences strings ; +IN: couchdb + +TUPLE: server { base string initial: "http://localhost:5984" } ; + +TUPLE: db { server server } { name string } ; + +: db-path ( db -- path ) + [ server>> base>> ] [ name>> ] bi "/" swap 3array concat ; + +TUPLE: couchdb-error { data assoc } ; +C: couchdb-error + +M: couchdb-error error. ( error -- ) + "CouchDB Error: " write data>> + "error" over at [ print ] when* + "reason" swap at [ print ] when* ; + +PREDICATE: db-exists-error < couchdb-error + data>> "error" swap at [ + "database_already_exists" = + ] [ f ] if* ; + +: check-request ( response-data success? -- ) + [ drop ] [ throw ] if ; + +: couchdb-put ( request-data url -- json-response success? ) + (http-request) json> swap code>> success? ; + +USE: prettyprint + +: (create-db) ( db -- db json success? ) + f over db-path couchdb-put ; + +: create-db ( db -- db ) + (create-db) check-request ; + +: ensure-db ( db -- db ) + (create-db) [ drop ] [ + dup db-exists-error? [ drop ] [ throw ] if + ] if ; From 629289b46fe72f4c2b4dfa07c3e72221b4f8be29 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 13 Oct 2008 17:01:29 +1100 Subject: [PATCH 004/772] Work on couchdb in progress. Added http-delete, http-trace, refactored some of http.client. --- basis/http/client/client.factor | 29 +++++++++++++++++++++-------- extra/couchdb/couchdb.factor | 13 +++++++++---- 2 files changed, 30 insertions(+), 12 deletions(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index ef53e138ac..675258c79d 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -175,10 +175,14 @@ M: download-failed error. [ [ % ] with-http-request ] B{ } make over content-charset>> decode ; +: ( url -- request ) + swap >url ensure-port >>url ; + +: ( data url -- request ) + swap >>post-data ; + : ( url -- request ) - - "GET" >>method - swap >url ensure-port >>url ; + "GET" >>method ; : http-get ( url -- response data ) http-request ; @@ -186,6 +190,18 @@ M: download-failed error. : with-http-get ( url quot -- response ) [ ] dip with-http-request ; inline +: ( url -- request ) + "DELETE" >>method ; + +: http-delete ( url -- response data ) + http-request ; + +: ( url -- request ) + "TRACE" >>method ; + +: http-trace ( url -- response data ) + http-request ; + : download-name ( url -- name ) present file-name "?" split1 drop "/" ?tail drop ; @@ -196,16 +212,13 @@ M: download-failed error. dup download-name download-to ; : ( post-data url -- request ) - - "POST" >>method - swap >url ensure-port >>url - swap >>post-data ; + "POST" >>method ; : http-post ( post-data url -- response data ) http-request ; : ( data url -- request ) - "PUT" >>method ; + "PUT" >>method ; : http-put ( data url -- response data ) http-request ; diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor index 7e1d97e786..7c656e175e 100644 --- a/extra/couchdb/couchdb.factor +++ b/extra/couchdb/couchdb.factor @@ -1,14 +1,16 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs continuations debugger http.client io json.reader json.writer kernel sequences strings ; +USING: accessors arrays assocs continuations debugger http.client io json.reader json.writer kernel sequences strings urls ; IN: couchdb -TUPLE: server { base string initial: "http://localhost:5984" } ; +TUPLE: db < url { url url initial: URL" http://localhost:5984" } ; +C: db -TUPLE: db { server server } { name string } ; +! : +: set-db-name ( db name : db-path ( db -- path ) - [ server>> base>> ] [ name>> ] bi "/" swap 3array concat ; + [ url>> ] [ name>> ] bi "/" swap 3array concat ; TUPLE: couchdb-error { data assoc } ; C: couchdb-error @@ -41,3 +43,6 @@ USE: prettyprint (create-db) [ drop ] [ dup db-exists-error? [ drop ] [ throw ] if ] if ; + +: delete-db ( db -- ) + From 868ad064261efec4a197c4a2ff1df4dc56ddbccb Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Tue, 14 Oct 2008 15:05:05 +1100 Subject: [PATCH 005/772] Adding hats --- extra/hats/authors.txt | 1 + extra/hats/hats-tests.factor | 87 ++++++++++++++++++++++++++++++++++++ extra/hats/hats.factor | 57 +++++++++++++++++++++++ extra/hats/summary.txt | 1 + 4 files changed, 146 insertions(+) create mode 100644 extra/hats/authors.txt create mode 100644 extra/hats/hats-tests.factor create mode 100644 extra/hats/hats.factor create mode 100644 extra/hats/summary.txt diff --git a/extra/hats/authors.txt b/extra/hats/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/hats/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/hats/hats-tests.factor b/extra/hats/hats-tests.factor new file mode 100644 index 0000000000..ebb61a0830 --- /dev/null +++ b/extra/hats/hats-tests.factor @@ -0,0 +1,87 @@ +! Copyright (C) 2008 Alex Chapman. +! See http://factorcode.org/license.txt for BSD license. +USING: boxes hats kernel namespaces symbols tools.test ; +IN: hats.tests + +SYMBOLS: lion giraffe elephant rabbit ; + +! caps +[ rabbit ] [ rabbit out ] unit-test +[ rabbit ] [ f rabbit in out ] unit-test +[ rabbit ] [ rabbit take ] unit-test +[ f ] [ rabbit empty-hat out ] unit-test +[ rabbit f ] [ rabbit [ take ] keep out ] unit-test +[ rabbit t ] [ rabbit [ take ] keep empty-hat? ] unit-test +[ lion ] [ rabbit [ drop lion ] change-hat out ] unit-test + +! bowlers +[ giraffe ] [ [ giraffe rabbit set rabbit out ] with-scope ] unit-test + +[ rabbit ] +[ + [ + lion rabbit set [ + rabbit rabbit set rabbit out + ] with-scope + ] with-scope +] unit-test + +[ rabbit ] [ + rabbit + [ + lion rabbit set [ + rabbit rabbit set out + ] with-scope + ] with-scope +] unit-test + +[ elephant ] [ + rabbit + [ + elephant rabbit set [ + rabbit rabbit set + ] with-scope + out + ] with-scope +] unit-test + +[ rabbit ] [ + rabbit + [ + elephant in [ + rabbit in out + ] with-scope + ] with-scope +] unit-test + +[ elephant ] [ + rabbit + [ + elephant in [ + rabbit in + ] with-scope + out + ] with-scope +] unit-test + +! Top Hats +[ lion ] [ lion rabbit set-global rabbit out ] unit-test +[ giraffe ] [ rabbit giraffe in out ] unit-test + +! Tuple hats +TUPLE: foo bar ; +C: foo + +: test-tuple ( -- tuple ) + rabbit ; + +: test-slot-hat ( -- slot-hat ) + test-tuple 2 ; ! hack! + +[ rabbit ] [ test-slot-hat out ] unit-test +[ lion ] [ test-slot-hat lion in out ] unit-test + +! Boxes as hats +[ rabbit ] [ rabbit in out ] unit-test +[ rabbit in lion in ] must-fail +[ out ] must-fail diff --git a/extra/hats/hats.factor b/extra/hats/hats.factor new file mode 100644 index 0000000000..113705bd11 --- /dev/null +++ b/extra/hats/hats.factor @@ -0,0 +1,57 @@ +! Copyright (C) 2008 Alex Chapman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors boxes kernel namespaces ; +IN: hats + +! Bullwinkle: Hey Rocky, watch me pull a rabbit out of my hat! +! Rocky: But that trick never works! +! Bullwinkle: This time for sure! + +! hat protocol +MIXIN: hat + +GENERIC: out ( hat -- object ) +GENERIC: (in) ( object hat -- ) + +: in ( hat object -- hat ) over (in) ; inline +: empty-hat? ( hat -- ? ) out not ; inline +: empty-hat ( hat -- hat ) f in ; inline +: take ( hat -- object ) dup out f rot (in) ; inline +: change-hat ( hat quot -- hat ) + over >r >r out r> call r> swap in ; inline + +! caps (the simplest of hats) +TUPLE: cap object ; +C: cap +M: cap out ( cap -- object ) object>> ; +M: cap (in) ( object cap -- ) (>>object) ; +INSTANCE: cap hat + +! bowlers (dynamic variable hats) +TUPLE: bowler variable ; +C: bowler +M: bowler out ( bowler -- object ) variable>> get ; +M: bowler (in) ( object bowler -- ) variable>> set ; +INSTANCE: bowler hat + +! Top Hats (global variable hats) +TUPLE: top-hat variable ; +C: top-hat +M: top-hat out ( top-hat -- object ) variable>> get-global ; +M: top-hat (in) ( object top-hat -- ) variable>> set-global ; +INSTANCE: top-hat hat + +USE: slots.private +! Slot hats +TUPLE: slot-hat tuple slot ; +C: slot-hat +: >slot-hat< ( slot-hat -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline +M: slot-hat out ( slot-hat -- object ) >slot-hat< slot ; +M: slot-hat (in) ( object slot-hat -- ) >slot-hat< set-slot ; +INSTANCE: slot-hat hat + +! Put a box on your head +M: box out ( box -- object ) box> ; +M: box (in) ( object box -- ) >box ; +INSTANCE: box hat + diff --git a/extra/hats/summary.txt b/extra/hats/summary.txt new file mode 100644 index 0000000000..9590639922 --- /dev/null +++ b/extra/hats/summary.txt @@ -0,0 +1 @@ +A protocol for getting and setting From 59e76f4d13b99e38fdb776437a9613651678a3a0 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 1 Nov 2008 15:35:23 +1100 Subject: [PATCH 006/772] Changes to http.client for couchdb I made the download-failed error contain the data returned by the server. --- basis/http/client/client.factor | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 675258c79d..6d8d97e040 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -52,7 +52,8 @@ M: f >post-data ; [ >post-data ] change-post-data ; : write-post-data ( request -- request ) - dup method>> "POST" = [ dup post-data>> raw>> write ] when ; + dup method>> [ "POST" = ] [ "PUT" = ] bi or + [ dup post-data>> [ raw>> write ] when* ] when ; : write-request ( request -- ) unparse-post-data @@ -90,7 +91,7 @@ M: too-many-redirects summary >method swap (with-http-request) + "GET" >>method swap with-http-request ] [ too-many-redirects ] if ; inline recursive : read-chunk-size ( -- n ) @@ -133,7 +134,7 @@ SYMBOL: redirects request get url>> url-addr ascii drop 1 minutes over set-timeout ; -: (with-http-request) ( request quot: ( chunk -- ) -- response ) +: with-http-request ( request quot: ( chunk -- ) -- response ) swap request [ [ @@ -159,21 +160,21 @@ PRIVATE> : success? ( code -- ? ) 200 299 between? ; -ERROR: download-failed response ; +ERROR: download-failed response data ; M: download-failed error. "HTTP request failed:" print nl - response>> . ; + [ response>> . ] [ data>> . ] bi ; + +: check-response* ( response data -- response data ) + over code>> success? [ download-failed ] unless ; : check-response ( response -- response ) - dup code>> success? [ download-failed ] unless ; - -: with-http-request ( request quot -- response ) - (with-http-request) check-response ; inline + f check-response* drop ; : http-request ( request -- response data ) [ [ % ] with-http-request ] B{ } make - over content-charset>> decode ; + over content-charset>> decode check-response* ; : ( url -- request ) swap >url ensure-port >>url ; @@ -188,7 +189,7 @@ M: download-failed error. http-request ; : with-http-get ( url quot -- response ) - [ ] dip with-http-request ; inline + [ ] dip with-http-request check-response ; inline : ( url -- request ) "DELETE" >>method ; From e05db8fc44f0c3303cbede967dfaccb828e14df4 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 1 Nov 2008 15:36:56 +1100 Subject: [PATCH 007/772] CouchDB working and able to create/load/save/delete docs --- extra/couchdb/couchdb.factor | 187 ++++++++++++++++++++++++++++++----- 1 file changed, 161 insertions(+), 26 deletions(-) diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor index 7c656e175e..8829a59779 100644 --- a/extra/couchdb/couchdb.factor +++ b/extra/couchdb/couchdb.factor @@ -1,17 +1,17 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs continuations debugger http.client io json.reader json.writer kernel sequences strings urls ; +USING: accessors arrays assocs continuations debugger hashtables http http.client io json.reader json.writer kernel make math math.parser namespaces sequences strings urls vectors ; IN: couchdb -TUPLE: db < url { url url initial: URL" http://localhost:5984" } ; -C: db +! NOTE: This code only works with the latest couchdb (0.9.*), because old +! versions didn't provide the /_uuids feature which this code relies on when +! creating new documents. -! : - -: set-db-name ( db name -: db-path ( db -- path ) - [ url>> ] [ name>> ] bi "/" swap 3array concat ; +SYMBOL: couch +: with-couch ( db quot -- ) + couch swap with-variable ; inline +! errors TUPLE: couchdb-error { data assoc } ; C: couchdb-error @@ -20,29 +20,164 @@ M: couchdb-error error. ( error -- ) "error" over at [ print ] when* "reason" swap at [ print ] when* ; -PREDICATE: db-exists-error < couchdb-error - data>> "error" swap at [ - "database_already_exists" = - ] [ f ] if* ; +PREDICATE: file-exists-error < couchdb-error + data>> "error" swap at "file_exists" = ; -: check-request ( response-data success? -- ) - [ drop ] [ throw ] if ; +! http tools +: couch-http-request ( request -- data ) + [ http-request ] [ + dup download-failed? [ + data>> json> throw + ] [ + rethrow + ] if + ] recover nip ; -: couchdb-put ( request-data url -- json-response success? ) - (http-request) json> swap code>> success? ; +: couch-request ( request -- assoc ) + couch-http-request json> ; -USE: prettyprint +: couch-get ( url -- assoc ) + couch-request ; -: (create-db) ( db -- db json success? ) - f over db-path couchdb-put ; +: couch-put ( post-data url -- assoc ) + couch-request ; -: create-db ( db -- db ) - (create-db) check-request ; +: couch-post ( post-data url -- assoc ) + couch-request ; -: ensure-db ( db -- db ) - (create-db) [ drop ] [ - dup db-exists-error? [ drop ] [ throw ] if - ] if ; +: couch-delete ( url -- assoc ) + couch-request ; + +: response-ok ( assoc -- assoc ) + "ok" over delete-at* and t assert= ; + +: response-ok* ( assoc -- ) + response-ok drop ; + +! server +TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache integer } ; + +: default-couch-host "localhost" ; +: default-couch-port 5984 ; +: default-uuids-to-cache 100 ; + +: ( host port -- server ) + V{ } clone default-uuids-to-cache server boa ; + +: ( -- server ) + default-couch-host default-couch-port ; + +: (server-url) ( server -- ) + "http://" % [ host>> % ] [ CHAR: : , port>> number>string % ] bi CHAR: / , ; inline + +: server-url ( server -- url ) + [ (server-url) ] "" make ; + +: all-dbs ( server -- dbs ) + server-url "_all_dbs" append couch-get ; + +: uuids-url ( server -- url ) + [ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ; + +: uuids-post ( server -- uuids ) + uuids-url f swap couch-post "uuids" swap at >vector ; + +: get-uuids ( server -- server ) + dup uuids-post [ nip ] curry change-uuids ; + +: ensure-uuids ( server -- server ) + dup uuids>> empty? [ get-uuids ] when ; + +: next-uuid ( server -- uuid ) + ensure-uuids uuids>> pop ; + +! db +TUPLE: db { server server } { name string } ; +C: db + +: (db-url) ( db -- ) + [ server>> server-url % ] [ name>> % ] bi CHAR: / , ; inline + +: db-url ( db -- url ) + [ (db-url) ] "" make ; + +: create-db ( db -- ) + f swap db-url couch-put response-ok* ; + +: ensure-db ( db -- ) + [ create-db ] [ + dup file-exists-error? [ 2drop ] [ rethrow ] if + ] recover ; : delete-db ( db -- ) - + db-url couch-delete drop ; + +: db-info ( db -- info ) + db-url couch-get ; + +: compact-db ( db -- ) + f swap db-url "_compact" append couch-post response-ok* ; + +: all-docs ( db -- docs ) + ! TODO: queries. Maybe pass in a hashtable with options + db-url "_all_docs" append couch-get ; + +: ( assoc -- post-data ) + >json "application/json" ; + +! documents +: id> ( assoc -- id ) "_id" swap at ; +: >id ( assoc id -- assoc ) "_id" pick set-at ; +: rev> ( assoc -- rev ) "_rev" swap at ; +: >rev ( assoc rev -- assoc ) "_rev" pick set-at ; + +: copy-key ( to from to-key from-key -- ) + rot at spin set-at ; + +: copy-id ( to from -- ) + "_id" "id" copy-key ; + +: copy-rev ( to from -- ) + "_rev" "rev" copy-key ; + +: id-url ( id -- url ) + couch get db-url swap append ; + +: doc-url ( assoc -- url ) + id> id-url ; + +: new-doc-url ( -- url ) + couch get [ db-url ] [ server>> next-uuid ] bi append ; + +: save-new ( assoc -- ) + dup new-doc-url couch-put response-ok + [ copy-id ] [ copy-rev ] 2bi ; + +: save-existing ( assoc id -- ) + [ dup ] dip id-url couch-put response-ok copy-rev ; + +: save ( assoc -- ) + dup id> [ save-existing ] [ save-new ] if* ; + +: load ( id -- assoc ) + id-url couch-get ; + +: delete ( assoc -- ) + [ + [ doc-url % ] + [ "?rev=" % "_rev" swap at % ] bi + ] "" make couch-delete response-ok* ; + +: remove-keys ( assoc keys -- ) + swap [ delete-at ] curry each ; + +: remove-couch-info ( assoc -- ) + { "_id" "_rev" "_attachments" } remove-keys ; + +! TODO: +! - startkey, count, descending, etc. +! - loading specific revisions +! - views +! - attachments +! - bulk insert/update +! - ...? From eb36537e99c4779c0dee3c4b9033f786aa77ac62 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 1 Nov 2008 20:38:50 +1100 Subject: [PATCH 008/772] Added some unit tests to couchdb --- extra/couchdb/couchdb-tests.factor | 43 +++++++++++++++++++++++++++++- extra/couchdb/couchdb.factor | 40 ++++++++++++++++++--------- 2 files changed, 69 insertions(+), 14 deletions(-) diff --git a/extra/couchdb/couchdb-tests.factor b/extra/couchdb/couchdb-tests.factor index 8907c0b811..7e38f5c2ee 100644 --- a/extra/couchdb/couchdb-tests.factor +++ b/extra/couchdb/couchdb-tests.factor @@ -1,4 +1,45 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test couchdb ; +USING: assocs couchdb kernel namespaces sequences strings tools.test ; IN: couchdb.tests + +! You must have a CouchDB server (currently only the version from svn will +! work) running on localhost and listening on the default port for these tests +! to work. + + "factor-test" [ + [ ] [ couch get create-db ] unit-test + [ couch get create-db ] must-fail + [ ] [ couch get delete-db ] unit-test + [ couch get delete-db ] must-fail + [ ] [ couch get ensure-db ] unit-test + [ ] [ couch get ensure-db ] unit-test + [ 0 ] [ couch get db-info "doc_count" swap at ] unit-test + [ ] [ couch get compact-db ] unit-test + [ ] [ H{ + { "Subject" "I like Planktion" } + { "Tags" { "plankton" "baseball" "decisions" } } + { "Body" + "I decided today that I don't like baseball. I like plankton." } + { "Author" "Rusty" } + { "PostedDate" "2006-08-15T17:30:12Z-04:00" } + } save-doc ] unit-test + [ t ] [ couch get all-docs "rows" swap at first "id" swap at dup "id" set string? ] unit-test + [ t ] [ "id" get dup load-doc id> = ] unit-test + [ ] [ "id" get load-doc save-doc ] unit-test + [ "Rusty" ] [ "id" get load-doc "Author" swap at ] unit-test + [ ] [ "id" get load-doc "Alex" "Author" pick set-at save-doc ] unit-test + [ "Alex" ] [ "id" get load-doc "Author" swap at ] unit-test + [ 1 ] [ "function(doc) { emit(null, doc) }" temp-view-map "total_rows" swap at ] unit-test + [ ] [ H{ + { "_id" "_design/posts" } + { "language" "javascript" } + { "views" H{ + { "all" H{ { "map" "function(doc) { emit(null, doc) }" } } } + } + } + } save-doc ] unit-test + [ t ] [ "id" get load-doc delete-doc string? ] unit-test + [ "id" get load-doc ] must-fail + [ ] [ couch get delete-db ] unit-test +] with-couch diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor index 8829a59779..3419244d72 100644 --- a/extra/couchdb/couchdb.factor +++ b/extra/couchdb/couchdb.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs continuations debugger hashtables http http.client io json.reader json.writer kernel make math math.parser namespaces sequences strings urls vectors ; +USING: accessors arrays assocs continuations debugger hashtables http http.client io json.reader json.writer kernel make math math.parser namespaces sequences strings urls urls.encoding vectors ; IN: couchdb ! NOTE: This code only works with the latest couchdb (0.9.*), because old @@ -130,6 +130,8 @@ C: db : >id ( assoc id -- assoc ) "_id" pick set-at ; : rev> ( assoc -- rev ) "_rev" swap at ; : >rev ( assoc rev -- assoc ) "_rev" pick set-at ; +: attachments> ( assoc -- attachments ) "_attachments" swap at ; +: >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ; : copy-key ( to from to-key from-key -- ) rot at spin set-at ; @@ -141,32 +143,35 @@ C: db "_rev" "rev" copy-key ; : id-url ( id -- url ) - couch get db-url swap append ; + couch get db-url swap url-encode-full append ; : doc-url ( assoc -- url ) id> id-url ; -: new-doc-url ( -- url ) - couch get [ db-url ] [ server>> next-uuid ] bi append ; +: temp-view ( view -- results ) + couch get db-url "_temp_view" append couch-post ; -: save-new ( assoc -- ) - dup new-doc-url couch-put response-ok +: temp-view-map ( map -- results ) + "map" H{ } clone [ set-at ] keep temp-view ; + +: save-doc-as ( assoc id -- ) + [ dup ] dip id-url couch-put response-ok [ copy-id ] [ copy-rev ] 2bi ; -: save-existing ( assoc id -- ) - [ dup ] dip id-url couch-put response-ok copy-rev ; +: save-new-doc ( assoc -- ) + couch get server>> next-uuid save-doc-as ; -: save ( assoc -- ) - dup id> [ save-existing ] [ save-new ] if* ; +: save-doc ( assoc -- ) + dup id> [ save-doc-as ] [ save-new-doc ] if* ; -: load ( id -- assoc ) +: load-doc ( id -- assoc ) id-url couch-get ; -: delete ( assoc -- ) +: delete-doc ( assoc -- deletion-revision ) [ [ doc-url % ] [ "?rev=" % "_rev" swap at % ] bi - ] "" make couch-delete response-ok* ; + ] "" make couch-delete response-ok "rev" swap at ; : remove-keys ( assoc keys -- ) swap [ delete-at ] curry each ; @@ -174,6 +179,15 @@ C: db : remove-couch-info ( assoc -- ) { "_id" "_rev" "_attachments" } remove-keys ; +! : construct-attachment ( content-type data -- assoc ) +! H{ } clone "name" pick set-at "content-type" pick set-at ; +! +! : add-attachment ( assoc name attachment -- ) +! pick attachments> [ H{ } clone ] unless* +! +! : attach ( assoc name content-type data -- ) +! construct-attachment H{ } clone + ! TODO: ! - startkey, count, descending, etc. ! - loading specific revisions From 030619114f1bae1fb5a3b59fa7b79f4653057720 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 1 Nov 2008 20:39:18 +1100 Subject: [PATCH 009/772] Un-privatising a word in http.client --- basis/http/client/client.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 6d8d97e040..e6435ee12b 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -89,10 +89,10 @@ M: too-many-redirects summary drop [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ; -> url-addr ascii drop 1 minutes over set-timeout ; +PRIVATE> + : with-http-request ( request quot: ( chunk -- ) -- response ) swap request [ @@ -156,8 +158,6 @@ SYMBOL: redirects [ do-redirect ] [ nip ] if ] with-variable ; inline recursive -PRIVATE> - : success? ( code -- ? ) 200 299 between? ; ERROR: download-failed response data ; From 4e268ea5670a6d9f3a7886a1e47ea39b608eecf5 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Sat, 1 Nov 2008 20:40:07 +1100 Subject: [PATCH 010/772] Adding url-encode-full to urls.encoding to do url encoding properly --- basis/urls/encoding/encoding-docs.factor | 6 +++++- basis/urls/encoding/encoding.factor | 24 ++++++++++++++++++++++++ 2 files changed, 29 insertions(+), 1 deletion(-) diff --git a/basis/urls/encoding/encoding-docs.factor b/basis/urls/encoding/encoding-docs.factor index f8b435441f..82ab3d1f69 100644 --- a/basis/urls/encoding/encoding-docs.factor +++ b/basis/urls/encoding/encoding-docs.factor @@ -7,7 +7,11 @@ HELP: url-decode HELP: url-encode { $values { "str" string } { "encoded" string } } -{ $description "URL-encodes a string." } ; +{ $description "URL-encodes a string, excluding certain characters, such as \"/\"." } ; + +HELP: url-encode-full +{ $values { "str" string } { "encoded" string } } +{ $description "URL-encodes a string, including all reserved characters, such as \"/\"." } ; HELP: url-quotable? { $values { "ch" "a character" } { "?" "a boolean" } } diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor index fa882609a5..ce5bd044ac 100644 --- a/basis/urls/encoding/encoding.factor +++ b/basis/urls/encoding/encoding.factor @@ -14,6 +14,25 @@ IN: urls.encoding [ "/_-.:" member? ] } 1|| ; foldable +! see http://tools.ietf.org/html/rfc3986#section-2.2 +: gen-delim? ( ch -- ? ) + ":/?#[]@" member? ; foldable + +: sub-delim? ( ch -- ? ) + "!$&'()*+,;=" member? ; foldable + +: reserved? ( ch -- ? ) + [ gen-delim? ] [ sub-delim? ] bi or ; foldable + +! see http://tools.ietf.org/html/rfc3986#section-2.3 +: unreserved? ( ch -- ? ) + { + [ letter? ] + [ LETTER? ] + [ digit? ] + [ "-._~" member? ] + } 1|| ; foldable + [ dup url-quotable? [ , ] [ push-utf8 ] if ] each ] "" make ; +: url-encode-full ( str -- encoded ) + [ + [ dup unreserved? [ , ] [ push-utf8 ] if ] each + ] "" make ; + Date: Tue, 16 Dec 2008 14:17:00 +0100 Subject: [PATCH 011/772] working round-trip bson (tuples - strings, numbers, other tuples as members ) >bson/bson> --- mongodb/bson/bson.factor | 7 ++ mongodb/bson/constants/constants.factor | 53 ++++++++++++ mongodb/bson/reader/reader.factor | 104 ++++++++++++++++++++++++ mongodb/bson/writer/writer.factor | 100 +++++++++++++++++++++++ 4 files changed, 264 insertions(+) create mode 100644 mongodb/bson/bson.factor create mode 100644 mongodb/bson/constants/constants.factor create mode 100644 mongodb/bson/reader/reader.factor create mode 100644 mongodb/bson/writer/writer.factor diff --git a/mongodb/bson/bson.factor b/mongodb/bson/bson.factor new file mode 100644 index 0000000000..f6cd002b48 --- /dev/null +++ b/mongodb/bson/bson.factor @@ -0,0 +1,7 @@ +IN: mongodb.bson +USE: vocabs.loader + +SINGLETON: bson-null + +"mongodb.bson.reader" require +"mongodb.bson.writer" require diff --git a/mongodb/bson/constants/constants.factor b/mongodb/bson/constants/constants.factor new file mode 100644 index 0000000000..9163d06ba4 --- /dev/null +++ b/mongodb/bson/constants/constants.factor @@ -0,0 +1,53 @@ +USING: alien.c-types ; + +IN: mongodb.bson.constants + + +: T_EOO ( -- type ) 0 ; inline +: T_Double ( -- type ) 1 ; inline +: T_Integer ( -- type ) 16 ; inline +: T_Boolean ( -- type ) 8 ; inline +: T_String ( -- type ) 2 ; inline +: T_Object ( -- type ) 3 ; inline +: T_Array ( -- type ) 4 ; inline +: T_Binary ( -- type ) 5 ; inline +: T_Undefined ( -- type ) 6 ; inline +: T_OID ( -- type ) 7 ; inline +: T_Date ( -- type ) 9 ; inline +: T_NULL ( -- type ) 10 ; inline +: T_Regexp ( -- type ) 11 ; inline +: T_DBRef ( -- type ) 12 ; inline +: T_Code ( -- type ) 13 ; inline +: T_ScopedCode ( -- type ) 17 ; inline +: T_Symbol ( -- type ) 14 ; inline +: T_JSTypeMax ( -- type ) 16 ; inline +: T_MaxKey ( -- type ) 127 ; inline + + + +! todo Move to mongo vocab + +: OP_Reply ( -- const ) + 1 ; inline + +: OP_Message ( -- const ) + 1000 ; inline + +: OP_Update ( -- const ) + 2001 ; inline + +: OP_Insert ( -- const ) + 2002 ; inline + +: OP_Query ( -- const ) + 2004 ; inline + +: OP_GetMore ( -- const ) + 2005 ; inline + +: OP_Delete ( -- const ) + 2006 ; inline + +: OP_KillCursors ( -- const ) + 2007 ; inline + \ No newline at end of file diff --git a/mongodb/bson/reader/reader.factor b/mongodb/bson/reader/reader.factor new file mode 100644 index 0000000000..abbb1a2c12 --- /dev/null +++ b/mongodb/bson/reader/reader.factor @@ -0,0 +1,104 @@ +USING: io io.encodings.utf8 io.encodings.binary math match kernel sequences + splitting accessors io.streams.byte-array namespaces prettyprint + mongodb.bson.constants assocs alien.c-types alien.strings fry ; + +IN: mongodb.bson.reader + +ERROR: size-mismatch actual declared ; + + ( -- state ) + state new H{ } clone [ >>result ] [ >>scope ] bi ; + +PREDICATE: bson-eoo < integer T_EOO = ; +PREDICATE: bson-not-eoo < integer T_EOO > ; +PREDICATE: bson-double < integer T_Double = ; +PREDICATE: bson-integer < integer T_Integer = ; +PREDICATE: bson-string < integer T_String = ; +PREDICATE: bson-object < integer T_Object = ; +PREDICATE: bson-array < integer T_Array = ; +PREDICATE: bson-binary < integer T_Binary = ; +PREDICATE: bson-oid < integer T_OID = ; +PREDICATE: bson-boolean < integer T_Boolean = ; +PREDICATE: bson-date < integer T_Date = ; +PREDICATE: bson-null < integer T_NULL = ; +PREDICATE: bson-ref < integer T_DBRef = ; + +GENERIC: element-read ( type -- cont? ) + +GENERIC: element-data-read ( type -- object ) + +: get-state ( -- state ) + state get ; + +: count-bytes ( count -- ) + [ get-state ] dip '[ _ + ] change-read drop ; + +: read-int32 ( -- int32 ) + 4 [ read *int ] [ count-bytes ] bi ; + +: read-byte-raw ( -- byte-raw ) + 1 [ read ] [ count-bytes ] bi ; + +: read-byte ( -- byte ) + read-byte-raw *char ; + +: (read-cstring) ( acc -- acc ) + read-byte-raw dup + B{ 0 } = + [ append ] + [ append (read-cstring) ] if ; + +: read-cstring ( -- string ) + B{ } clone + (read-cstring) utf8 alien>string ; + + +: object-size ( -- size ) + read-int32 ; + + +: read-element-type ( -- type ) + read-byte ; + +: element-name ( -- name ) + read-cstring ; + +: read-elements ( -- ) + read-element-type + element-read + [ read-elements ] when ; + + +M: bson-eoo element-read ( type -- cont? ) + drop + f ; + +M: bson-not-eoo element-read ( type -- cont? ) + [ element-name ] dip + element-data-read + swap + get-state scope>> + set-at + t ; + + +M: bson-string element-data-read ( type -- object ) + drop + read-int32 drop + read-cstring ; + +M: bson-integer element-data-read ( type -- object ) + drop + read-int32 ; + +PRIVATE> + +: bson> ( arr -- ht ) + binary + [ dup state + [ object-size >>size read-elements ] with-variable + ] with-byte-reader ; diff --git a/mongodb/bson/writer/writer.factor b/mongodb/bson/writer/writer.factor new file mode 100644 index 0000000000..8550a720fe --- /dev/null +++ b/mongodb/bson/writer/writer.factor @@ -0,0 +1,100 @@ +! Copyright (C) 2008 Sascha Matzke. +! See http://factorcode.org/license.txt for BSD license. +USING: mongodb.bson mongodb.bson.constants accessors kernel io.streams.string io.encodings.binary + io.encodings.utf8 strings splitting math.parser + sequences math assocs classes words make fry + prettyprint hashtables mirrors bson alien.strings alien.c-types + io.streams.byte-array io ; + +IN: mongodb.bson.writer + + write ] keep ; + +: write-cstring ( string -- ) + utf8 string>alien write ; + +PRIVATE> + +#! Writes the object out to a stream in BSON format +GENERIC: bson-print ( obj -- ) + +: (>bson) ( obj -- byte-array ) + '[ _ bson-print ] binary swap with-byte-writer ; + +GENERIC: >bson ( obj -- byte-aray ) + +M: tuple >bson ( tuble -- byte-array ) + (>bson) ; + +M: hashtable >bson ( hashmap -- byte-array ) + (>bson) ; + +M: f bson-print ( f -- ) + drop 0 write ; + +M: t bson-print ( t -- ) + drop 1 write ; + +M: bson-null bson-print ( null -- ) + drop ; + +M: string bson-print ( obj -- ) + utf8 string>alien + [ length write ] keep + write ; + +M: integer bson-print ( num -- ) + write ; + +M: real bson-print ( num -- ) + >float write ; + +M: sequence bson-print ( array -- ) + '[ _ [ [ write-type ] dip number>string write-cstring bson-print ] + each-index ] + binary swap with-byte-writer + [ length 5 + bson-print ] keep + write + T_EOO write ; + + +M: tuple bson-print ( tuple -- ) + '[ _ [ write-type [ write-cstring ] dip bson-print ] assoc-each ] + binary swap with-byte-writer + [ length 5 + bson-print ] keep write + T_EOO bson-print ; + +M: hashtable bson-print ( hashtable -- ) + '[ _ [ write-type [ write-cstring ] dip bson-print ] assoc-each ] + binary swap with-byte-writer + [ length 5 + bson-print ] keep write + T_EOO bson-print ; + +M: word bson-print name>> bson-print ; From f67441f4931cdf89740fa0bc77691b028ee0f361 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 19 Dec 2008 13:47:46 +0100 Subject: [PATCH 012/772] started working on transparent persistence for tuples (using dynamic subclassing) *** state: broken *** --- mongodb/mongodb.factor | 15 ++++++++++ mongodb/persistent/persistent.factor | 42 ++++++++++++++++++++++++++++ 2 files changed, 57 insertions(+) create mode 100644 mongodb/mongodb.factor create mode 100644 mongodb/persistent/persistent.factor diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor new file mode 100644 index 0000000000..b706dcffa6 --- /dev/null +++ b/mongodb/mongodb.factor @@ -0,0 +1,15 @@ +USING: mongodb.persistent ; + +IN: mongodb + + + +GENERIC: store ( tuple/ht -- tuple/ht ) +GENERIC: load ( example -- tuple/ht ) + +M: tuple store ( tuple -- tuple ) + [ check-persistent-tuple ] keep ; + +M: persistent-tuple store ( ptuple -- ptuple ) + ; + diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor new file mode 100644 index 0000000000..08837ed237 --- /dev/null +++ b/mongodb/persistent/persistent.factor @@ -0,0 +1,42 @@ +USING: formatting words classes.mixin kernel fry compiler.units + accessors classes classes.tuple ; + +IN: mongodb.persistent + +MIXIN: persistent-tuple + +SLOT: _p_oid +SLOT: _p_info + +TUPLE: oid { a initial: 0 } { b initial: 0 } ; + +TUPLE: persistent-info type vocab collection dirty? mt ; + + + +GENERIC: persistent-tuple-class ( tuple -- class ) + +M: tuple persistent-tuple-class ( tuple -- class ) + class persistent-tuple-class ; + +M: tuple-class persistent-tuple-class ( class -- class' ) + [ [ vocabulary>> ] [ name>> ] bi ] keep ! name vocab class + [ "%s_%s" sprintf ] dip swap dup ! class new_name new_name + P_VOCAB lookup dup ! class new_name vo/f vo/f + [ [ drop drop ] dip ] [ drop define-persistent-tuple ] if ; From 752c637cb8e34a33deb0dd074f79a6df005a120a Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 19 Dec 2008 14:57:01 +0100 Subject: [PATCH 013/772] some work --- mongodb/bson/bson.factor | 2 + mongodb/bson/constants/constants.factor | 4 + mongodb/bson/reader/reader.factor | 147 ++++++++++++++----- mongodb/bson/writer/writer.factor | 185 ++++++++++++++---------- 4 files changed, 225 insertions(+), 113 deletions(-) diff --git a/mongodb/bson/bson.factor b/mongodb/bson/bson.factor index f6cd002b48..27033094de 100644 --- a/mongodb/bson/bson.factor +++ b/mongodb/bson/bson.factor @@ -1,4 +1,6 @@ + IN: mongodb.bson + USE: vocabs.loader SINGLETON: bson-null diff --git a/mongodb/bson/constants/constants.factor b/mongodb/bson/constants/constants.factor index 9163d06ba4..80e9933740 100644 --- a/mongodb/bson/constants/constants.factor +++ b/mongodb/bson/constants/constants.factor @@ -23,7 +23,11 @@ IN: mongodb.bson.constants : T_JSTypeMax ( -- type ) 16 ; inline : T_MaxKey ( -- type ) 127 ; inline +: T_Binary_Bytes ( -- subtype ) 2 ; inline +: T_Binary_Function ( -- subtype ) 1 ; inline +: S_Name ( -- name ) "__t_name" ; inline +: S_Vocab ( -- name ) "__t_vocab" ; inline ! todo Move to mongo vocab diff --git a/mongodb/bson/reader/reader.factor b/mongodb/bson/reader/reader.factor index abbb1a2c12..dcfabfb947 100644 --- a/mongodb/bson/reader/reader.factor +++ b/mongodb/bson/reader/reader.factor @@ -1,6 +1,7 @@ -USING: io io.encodings.utf8 io.encodings.binary math match kernel sequences +USING: mirrors io io.encodings.utf8 io.encodings.binary math match kernel sequences splitting accessors io.streams.byte-array namespaces prettyprint - mongodb.bson.constants assocs alien.c-types alien.strings fry ; + mongodb.bson.constants assocs alien.c-types alien.strings fry words + tools.walker serialize ; IN: mongodb.bson.reader @@ -8,97 +9,171 @@ ERROR: size-mismatch actual declared ; ( -- state ) - state new H{ } clone [ >>result ] [ >>scope ] bi ; + state new H{ } clone + [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi + V{ } clone [ T_Object "" element boa swap push ] keep >>element ; -PREDICATE: bson-eoo < integer T_EOO = ; +PREDICATE: bson-eoo < integer T_EOO = ; PREDICATE: bson-not-eoo < integer T_EOO > ; -PREDICATE: bson-double < integer T_Double = ; + +PREDICATE: bson-double < integer T_Double = ; PREDICATE: bson-integer < integer T_Integer = ; -PREDICATE: bson-string < integer T_String = ; -PREDICATE: bson-object < integer T_Object = ; -PREDICATE: bson-array < integer T_Array = ; -PREDICATE: bson-binary < integer T_Binary = ; -PREDICATE: bson-oid < integer T_OID = ; +PREDICATE: bson-string < integer T_String = ; +PREDICATE: bson-object < integer T_Object = ; +PREDICATE: bson-array < integer T_Array = ; +PREDICATE: bson-binary < integer T_Binary = ; +PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ; +PREDICATE: bson-binary-function < integer T_Binary_Function = ; +PREDICATE: bson-oid < integer T_OID = ; PREDICATE: bson-boolean < integer T_Boolean = ; -PREDICATE: bson-date < integer T_Date = ; -PREDICATE: bson-null < integer T_NULL = ; -PREDICATE: bson-ref < integer T_DBRef = ; +PREDICATE: bson-date < integer T_Date = ; +PREDICATE: bson-null < integer T_NULL = ; +PREDICATE: bson-ref < integer T_DBRef = ; GENERIC: element-read ( type -- cont? ) - GENERIC: element-data-read ( type -- object ) +GENERIC: element-binary-read ( length type -- object ) : get-state ( -- state ) - state get ; + state get ; inline : count-bytes ( count -- ) - [ get-state ] dip '[ _ + ] change-read drop ; + [ get-state ] dip '[ _ + ] change-read drop ; inline : read-int32 ( -- int32 ) - 4 [ read *int ] [ count-bytes ] bi ; + 4 [ read *int ] [ count-bytes ] bi ; inline + +: read-double ( -- double ) + 8 [ read *double ] [ count-bytes ] bi ; inline : read-byte-raw ( -- byte-raw ) - 1 [ read ] [ count-bytes ] bi ; + 1 [ read ] [ count-bytes ] bi ; inline : read-byte ( -- byte ) - read-byte-raw *char ; + read-byte-raw *char ; inline : (read-cstring) ( acc -- acc ) read-byte-raw dup B{ 0 } = [ append ] - [ append (read-cstring) ] if ; + [ append (read-cstring) ] if ; : read-cstring ( -- string ) B{ } clone (read-cstring) utf8 alien>string ; - -: object-size ( -- size ) - read-int32 ; - +: read-sized-string ( length -- string ) + [ read ] [ count-bytes ] bi + utf8 alien>string ; : read-element-type ( -- type ) read-byte ; -: element-name ( -- name ) - read-cstring ; +: push-element ( type name -- element ) + element boa + [ get-state element>> push ] keep ; + +: pop-element ( -- element ) + get-state element>> pop ; + +: peek-scope ( -- ht ) + get-state scope>> peek ; : read-elements ( -- ) read-element-type element-read [ read-elements ] when ; +: make-tuple ( assoc -- tuple ) + [ [ S_Name swap at ] [ S_Vocab swap at ] bi ] keep ! name vocab assoc + [ lookup new ] dip ! instance assoc + [ dup [ keys ] keep ] dip ! instance array mirror assoc + '[ dup _ [ _ at ] dip [ swap ] dip set-at ] each ; + +GENERIC: fix-result ( assoc type -- result ) + +M: bson-object fix-result ( assoc type -- result ) + drop + [ ] [ S_Name swap key? ] bi + [ make-tuple ] [ ] if ; + +M: bson-array fix-result ( assoc type -- result ) + drop + values ; M: bson-eoo element-read ( type -- cont? ) drop - f ; + get-state scope>> [ pop ] keep swap ! vec assoc + pop-element [ type>> ] keep ! vec assoc type element + [ fix-result ] dip ! vec result element + rot length 0 > ! result element + [ name>> peek-scope set-at t ] + [ drop [ get-state ] dip >>result drop f ] if ; M: bson-not-eoo element-read ( type -- cont? ) - [ element-name ] dip - element-data-read - swap - get-state scope>> + [ peek-scope ] dip ! scope type + '[ _ + read-cstring push-element [ name>> ] [ type>> ] bi + element-data-read + swap + ] dip set-at t ; +M: bson-object element-data-read ( type -- object ) + drop + read-int32 drop + get-state + [ [ [ H{ } clone ] dip push ] keep ] change-scope + scope>> peek ; +M: bson-array element-data-read ( type -- object ) + drop + read-int32 drop + get-state + [ [ [ H{ } clone ] dip push ] keep ] change-scope + scope>> peek ; + M: bson-string element-data-read ( type -- object ) drop - read-int32 drop - read-cstring ; + read-int32 read-sized-string + pop-element drop ; M: bson-integer element-data-read ( type -- object ) drop - read-int32 ; + read-int32 + pop-element drop ; + +M: bson-double element-data-read ( type -- double ) + drop + read-double + pop-element drop ; + +M: bson-boolean element-data-read ( type -- boolean ) + drop + read-byte t = + pop-element drop ; + +M: bson-binary element-data-read ( type -- binary ) + drop + read-int32 read-byte element-binary-read + pop-element drop ; + +M: bson-binary-bytes element-binary-read ( size type -- bytes ) + drop read ; + +M: bson-binary-function element-binary-read ( size type -- quot ) + drop read bytes>object ; PRIVATE> : bson> ( arr -- ht ) binary [ dup state - [ object-size >>size read-elements ] with-variable + [ read-int32 >>size read-elements ] with-variable + result>> ] with-byte-reader ; diff --git a/mongodb/bson/writer/writer.factor b/mongodb/bson/writer/writer.factor index 8550a720fe..7cb1cc4cdb 100644 --- a/mongodb/bson/writer/writer.factor +++ b/mongodb/bson/writer/writer.factor @@ -1,100 +1,131 @@ ! Copyright (C) 2008 Sascha Matzke. ! See http://factorcode.org/license.txt for BSD license. -USING: mongodb.bson mongodb.bson.constants accessors kernel io.streams.string io.encodings.binary +USING: mongodb.bson mongodb.bson.constants accessors kernel io.streams.string + io.encodings.binary classes byte-arrays quotations serialize io.encodings.utf8 strings splitting math.parser - sequences math assocs classes words make fry - prettyprint hashtables mirrors bson alien.strings alien.c-types + sequences math assocs classes words make fry mongodb.persistent + prettyprint hashtables mirrors alien.strings alien.c-types io.streams.byte-array io ; IN: mongodb.bson.writer +#! Writes the object out to a stream in BSON format + write ] keep ; +M: oid bson-type? ( word -- type ) drop T_OID ; +M: real bson-type? ( real -- type ) drop T_Double ; +M: word bson-type? ( word -- type ) drop T_String ; +M: tuple bson-type? ( tuple -- type ) drop T_Object ; +M: assoc bson-type? ( hashtable -- type ) drop T_Object ; +M: string bson-type? ( string -- type ) drop T_String ; +M: integer bson-type? ( integer -- type ) drop T_Integer ; +M: sequence bson-type? ( seq -- type ) drop T_Array ; +M: quotation bson-type? ( quotation -- type ) drop T_Binary ; +M: bson-null bson-type? ( null -- type ) drop T_NULL ; +M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; -: write-cstring ( string -- ) - utf8 string>alien write ; +: write-byte ( byte -- ) write ; +: write-int32 ( int -- ) write ; +: write-double ( real -- ) write ; +: write-cstring ( string -- ) utf8 string>alien write ; +: write-longlong ( object -- ) write ; + +: write-eoo ( -- ) T_EOO write-byte ; +: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; +: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; + +: write-tuple-info ( object -- ) + class + [ [ S_Name ] dip name>> write-pair ] + [ [ S_Vocab ] dip vocabulary>> write-pair ] bi ; + +M: f bson-write ( f -- ) + drop 0 write-byte ; + +M: t bson-write ( t -- ) + drop 1 write-byte ; + +M: bson-null bson-write ( null -- ) + drop ; + +M: string bson-write ( obj -- ) + utf8 string>alien + [ length write-int32 ] keep + write ; + +M: integer bson-write ( num -- ) + write-int32 ; + +M: real bson-write ( num -- ) + >float write-double ; + +M: byte-array bson-write ( binary -- ) + [ length write-int32 ] keep + T_Binary_Bytes write-byte + write ; + +M: quotation bson-write ( quotation -- ) + object>bytes [ length write-int32 ] keep + T_Binary_Function write-byte + write ; + +M: oid bson-write ( oid -- ) + [ a>> write-longlong ] [ b>> write-int32 ] bi ; + +M: sequence bson-write ( array -- ) + '[ _ [ [ write-type ] dip number>string write-cstring bson-write ] + each-index ] + binary swap with-byte-writer + [ length 5 + bson-write ] keep + write + write-eoo ; + +M: persistent-tuple bson-write ( persistent-tuple -- ) + dup + '[ + _ write-tuple-info + _ [ write-pair ] assoc-each + ] + binary swap with-byte-writer + [ length 5 + bson-write ] keep + write + write-eoo ; + +M: tuple bson-write ( tuple -- ) + dup + '[ + _ write-tuple-info + _ [ write-pair ] assoc-each + ] + binary swap with-byte-writer + [ length 5 + bson-write ] keep + write + write-eoo ; + +M: assoc bson-write ( hashtable -- ) + '[ _ [ write-pair ] assoc-each ] + binary swap with-byte-writer + [ length 5 + bson-write ] keep + write + write-eoo ; + +M: word bson-write name>> bson-write ; PRIVATE> -#! Writes the object out to a stream in BSON format -GENERIC: bson-print ( obj -- ) - -: (>bson) ( obj -- byte-array ) - '[ _ bson-print ] binary swap with-byte-writer ; - GENERIC: >bson ( obj -- byte-aray ) M: tuple >bson ( tuble -- byte-array ) - (>bson) ; + '[ _ bson-write ] binary swap with-byte-writer ; M: hashtable >bson ( hashmap -- byte-array ) - (>bson) ; - -M: f bson-print ( f -- ) - drop 0 write ; - -M: t bson-print ( t -- ) - drop 1 write ; - -M: bson-null bson-print ( null -- ) - drop ; - -M: string bson-print ( obj -- ) - utf8 string>alien - [ length write ] keep - write ; - -M: integer bson-print ( num -- ) - write ; - -M: real bson-print ( num -- ) - >float write ; - -M: sequence bson-print ( array -- ) - '[ _ [ [ write-type ] dip number>string write-cstring bson-print ] - each-index ] - binary swap with-byte-writer - [ length 5 + bson-print ] keep - write - T_EOO write ; + '[ _ bson-write ] binary swap with-byte-writer ; -M: tuple bson-print ( tuple -- ) - '[ _ [ write-type [ write-cstring ] dip bson-print ] assoc-each ] - binary swap with-byte-writer - [ length 5 + bson-print ] keep write - T_EOO bson-print ; - -M: hashtable bson-print ( hashtable -- ) - '[ _ [ write-type [ write-cstring ] dip bson-print ] assoc-each ] - binary swap with-byte-writer - [ length 5 + bson-print ] keep write - T_EOO bson-print ; - -M: word bson-print name>> bson-print ; From 88d337a001ef475c0f3640115c4ed27b6314aa15 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 27 Dec 2008 12:03:30 +0100 Subject: [PATCH 014/772] added _p_info hashtable constant keys commented make-persistent cause it's not working, yet --- mongodb/persistent/persistent.factor | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor index 08837ed237..2e76a3f85b 100644 --- a/mongodb/persistent/persistent.factor +++ b/mongodb/persistent/persistent.factor @@ -10,7 +10,10 @@ SLOT: _p_info TUPLE: oid { a initial: 0 } { b initial: 0 } ; -TUPLE: persistent-info type vocab collection dirty? mt ; +: MDB_CLASS ( -- string ) "p_class" ; inline +: MDB_VOCAB ( -- string ) "p_vocab" ; inline +: MDB_MODIF ( -- string ) "p_mt" ; inline +: MDB_CREAT ( -- string ) "p_ct" ; inline Date: Sat, 27 Dec 2008 12:11:15 +0100 Subject: [PATCH 015/772] modified version --- mongodb/persistent/persistent.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor index 08837ed237..c3b18b027e 100644 --- a/mongodb/persistent/persistent.factor +++ b/mongodb/persistent/persistent.factor @@ -40,3 +40,13 @@ M: tuple-class persistent-tuple-class ( class -- class' ) [ "%s_%s" sprintf ] dip swap dup ! class new_name new_name P_VOCAB lookup dup ! class new_name vo/f vo/f [ [ drop drop ] dip ] [ drop define-persistent-tuple ] if ; + + +GENERIC: make-persistent ( tuple -- 'tuple ) + +M: tuple make-persistent ( tuple -- 'tuple ) + [let* | tuple [ ] + class [ tuple class ] + 'tuple [ class persistent-tuple-class new ] | + + ] ; \ No newline at end of file From 3a03cadef68bc6602a08166914636bbbd97bfcaf Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 27 Dec 2008 16:57:54 +0100 Subject: [PATCH 016/772] some further persistent tuple work; not sure if the whole tuple persistence behavior should bleed into the bson reader/writer, of if to keep them "pure" --- mongodb/bson/reader/reader.factor | 17 +++++-- mongodb/bson/writer/writer.factor | 29 +++++------- mongodb/persistent/persistent.factor | 66 +++++++++++++++++++--------- 3 files changed, 69 insertions(+), 43 deletions(-) diff --git a/mongodb/bson/reader/reader.factor b/mongodb/bson/reader/reader.factor index dcfabfb947..276acc1263 100644 --- a/mongodb/bson/reader/reader.factor +++ b/mongodb/bson/reader/reader.factor @@ -1,7 +1,7 @@ USING: mirrors io io.encodings.utf8 io.encodings.binary math match kernel sequences splitting accessors io.streams.byte-array namespaces prettyprint mongodb.bson.constants assocs alien.c-types alien.strings fry words - tools.walker serialize ; + tools.walker serialize mongodb.persistent ; IN: mongodb.bson.reader @@ -47,6 +47,9 @@ GENERIC: element-binary-read ( length type -- object ) : read-int32 ( -- int32 ) 4 [ read *int ] [ count-bytes ] bi ; inline +: read-longlong ( -- longlong ) + 8 [ read *longlong ] [ count-bytes ] bi ; inline + : read-double ( -- double ) 8 [ read *double ] [ count-bytes ] bi ; inline @@ -89,8 +92,7 @@ GENERIC: element-binary-read ( length type -- object ) [ read-elements ] when ; : make-tuple ( assoc -- tuple ) - [ [ S_Name swap at ] [ S_Vocab swap at ] bi ] keep ! name vocab assoc - [ lookup new ] dip ! instance assoc + [ P_INFO swap at persistent-tuple-class new ] keep ! instance assoc [ dup [ keys ] keep ] dip ! instance array mirror assoc '[ dup _ [ _ at ] dip [ swap ] dip set-at ] each ; @@ -98,7 +100,7 @@ GENERIC: fix-result ( assoc type -- result ) M: bson-object fix-result ( assoc type -- result ) drop - [ ] [ S_Name swap key? ] bi + [ ] [ P_INFO swap key? ] bi [ make-tuple ] [ ] if ; M: bson-array fix-result ( assoc type -- result ) @@ -124,6 +126,13 @@ M: bson-not-eoo element-read ( type -- cont? ) set-at t ; +M: bson-oid element-data-read ( type -- object ) + drop + read-longlong + read-int32 + oid boa + pop-element drop ; + M: bson-object element-data-read ( type -- object ) drop read-int32 drop diff --git a/mongodb/bson/writer/writer.factor b/mongodb/bson/writer/writer.factor index 7cb1cc4cdb..44dca02991 100644 --- a/mongodb/bson/writer/writer.factor +++ b/mongodb/bson/writer/writer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: mongodb.bson mongodb.bson.constants accessors kernel io.streams.string io.encodings.binary classes byte-arrays quotations serialize - io.encodings.utf8 strings splitting math.parser + io.encodings.utf8 strings splitting math.parser locals sequences math assocs classes words make fry mongodb.persistent prettyprint hashtables mirrors alien.strings alien.c-types io.streams.byte-array io ; @@ -41,10 +41,8 @@ M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; : write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; : write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; -: write-tuple-info ( object -- ) - class - [ [ S_Name ] dip name>> write-pair ] - [ [ S_Vocab ] dip vocabulary>> write-pair ] bi ; +:: write-tuple-info ( object -- ) + P_SLOTS [ [ ] [ object at ] bi write-pair ] each ; M: f bson-write ( f -- ) drop 0 write-byte ; @@ -87,27 +85,20 @@ M: sequence bson-write ( array -- ) write write-eoo ; +: check-p-field ( key value -- key value boolean ) + [ [ "_p_" swap start 0 = ] keep ] dip rot ; + M: persistent-tuple bson-write ( persistent-tuple -- ) - dup - '[ - _ write-tuple-info - _ [ write-pair ] assoc-each - ] + + '[ _ [ write-tuple-info ] + [ [ check-p-field [ 2drop ] [ write-pair ] if ] assoc-each ] bi ] binary swap with-byte-writer [ length 5 + bson-write ] keep write write-eoo ; M: tuple bson-write ( tuple -- ) - dup - '[ - _ write-tuple-info - _ [ write-pair ] assoc-each - ] - binary swap with-byte-writer - [ length 5 + bson-write ] keep - write - write-eoo ; + make-persistent bson-write ; M: assoc bson-write ( hashtable -- ) '[ _ [ write-pair ] assoc-each ] diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor index fff9778a94..d438fbf978 100644 --- a/mongodb/persistent/persistent.factor +++ b/mongodb/persistent/persistent.factor @@ -1,5 +1,5 @@ -USING: formatting words classes.mixin kernel fry compiler.units - accessors classes classes.tuple ; +USING: accessors classes classes.mixin classes.tuple compiler.units +fry kernel words locals mirrors formatting assocs hashtables ; IN: mongodb.persistent @@ -12,24 +12,35 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ; : MDB_CLASS ( -- string ) "p_class" ; inline : MDB_VOCAB ( -- string ) "p_vocab" ; inline -: MDB_MODIF ( -- string ) "p_mt" ; inline -: MDB_CREAT ( -- string ) "p_ct" ; inline +: MDB_MT ( -- string ) "p_mt" ; inline +: MDB_CT ( -- string ) "p_ct" ; inline +: MDB_COL ( -- string ) "p_col" ; inline + +PREDICATE: pinfo-hashtable < hashtable [ MDB_CLASS swap key? ] [ MDB_VOCAB swap key? ] bi and ; + +: P_OID ( -- name ) "_p_oid" ; inline +: P_INFO ( -- name ) "_p_info" ; inline + +: P_SLOTS ( -- array ) + { "_p_oid" "_p_info" } ; ] + tm2 [ 'tuple ] | + tm1 [ swap tm2 set-at ] assoc-each + tm2 object>> ] ; PRIVATE> @@ -38,6 +49,10 @@ GENERIC: persistent-tuple-class ( tuple -- class ) M: tuple persistent-tuple-class ( tuple -- class ) class persistent-tuple-class ; +M: pinfo-hashtable persistent-tuple-class ( tuple -- class ) + [ MDB_CLASS swap at ] [ MDB_VOCAB swap at ] bi lookup + persistent-tuple-class ; + M: tuple-class persistent-tuple-class ( class -- class' ) [ [ vocabulary>> ] [ name>> ] bi ] keep ! name vocab class [ "%s_%s" sprintf ] dip swap dup ! class new_name new_name @@ -47,9 +62,20 @@ M: tuple-class persistent-tuple-class ( class -- class' ) GENERIC: make-persistent ( tuple -- 'tuple ) -! M: tuple make-persistent ( tuple -- 'tuple ) -! [let* | tuple [ ] -! class [ tuple class ] -! 'tuple [ class persistent-tuple-class new ] | -! -! ] ; +M: tuple make-persistent ( tuple -- 'tuple ) + [let* | tuple [ ] + tclass [ tuple class ] + 'tuple [ tclass persistent-tuple-class new ] + pinfo [ H{ } clone ] | + tuple 'tuple copy-slots + oid new >>_p_oid + tclass name>> MDB_CLASS pinfo set-at + tclass vocabulary>> MDB_VOCAB pinfo set-at + 0 MDB_MT pinfo set-at + 0 MDB_CT pinfo set-at + "" MDB_COL pinfo set-at + pinfo >>_p_info + ] ; + +M: persistent-tuple make-persistent ( tuple -- tuple ) + ; From 28809b0ec0ddec5478ffc89742d22e3ea2b3a3f4 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 3 Jan 2009 12:48:11 +0100 Subject: [PATCH 017/772] made bson a toplevel vocab --- bson/bson.factor | 9 ++ .../bson => bson}/constants/constants.factor | 32 +---- {mongodb/bson => bson}/reader/reader.factor | 90 +++++++------ bson/writer/writer.factor | 102 +++++++++++++++ mongodb/bson/bson.factor | 9 -- mongodb/bson/writer/writer.factor | 122 ------------------ 6 files changed, 161 insertions(+), 203 deletions(-) create mode 100644 bson/bson.factor rename {mongodb/bson => bson}/constants/constants.factor (58%) rename {mongodb/bson => bson}/reader/reader.factor (71%) create mode 100644 bson/writer/writer.factor delete mode 100644 mongodb/bson/bson.factor delete mode 100644 mongodb/bson/writer/writer.factor diff --git a/bson/bson.factor b/bson/bson.factor new file mode 100644 index 0000000000..4be8e2d3ed --- /dev/null +++ b/bson/bson.factor @@ -0,0 +1,9 @@ + +IN: bson + +USE: vocabs.loader + +SINGLETON: bson-null + +"bson.reader" require +"bson.writer" require diff --git a/mongodb/bson/constants/constants.factor b/bson/constants/constants.factor similarity index 58% rename from mongodb/bson/constants/constants.factor rename to bson/constants/constants.factor index 80e9933740..f519c0f998 100644 --- a/mongodb/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -1,6 +1,8 @@ USING: alien.c-types ; -IN: mongodb.bson.constants +IN: bson.constants + +TUPLE: oid { a initial: 0 } { b initial: 0 } ; : T_EOO ( -- type ) 0 ; inline @@ -26,32 +28,4 @@ IN: mongodb.bson.constants : T_Binary_Bytes ( -- subtype ) 2 ; inline : T_Binary_Function ( -- subtype ) 1 ; inline -: S_Name ( -- name ) "__t_name" ; inline -: S_Vocab ( -- name ) "__t_vocab" ; inline -! todo Move to mongo vocab - -: OP_Reply ( -- const ) - 1 ; inline - -: OP_Message ( -- const ) - 1000 ; inline - -: OP_Update ( -- const ) - 2001 ; inline - -: OP_Insert ( -- const ) - 2002 ; inline - -: OP_Query ( -- const ) - 2004 ; inline - -: OP_GetMore ( -- const ) - 2005 ; inline - -: OP_Delete ( -- const ) - 2006 ; inline - -: OP_KillCursors ( -- const ) - 2007 ; inline - \ No newline at end of file diff --git a/mongodb/bson/reader/reader.factor b/bson/reader/reader.factor similarity index 71% rename from mongodb/bson/reader/reader.factor rename to bson/reader/reader.factor index 276acc1263..b7ef83d80e 100644 --- a/mongodb/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -1,21 +1,22 @@ USING: mirrors io io.encodings.utf8 io.encodings.binary math match kernel sequences splitting accessors io.streams.byte-array namespaces prettyprint - mongodb.bson.constants assocs alien.c-types alien.strings fry words - tools.walker serialize mongodb.persistent ; + bson.constants assocs alien.c-types alien.strings fry words + tools.walker serialize locals byte-arrays ; -IN: mongodb.bson.reader +IN: bson.reader ERROR: size-mismatch actual declared ; ( -- state ) - state new H{ } clone - [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi - V{ } clone [ T_Object "" element boa swap push ] keep >>element ; +:: ( exemplar -- state ) + state new + exemplar clone >>exemplar + exemplar clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi + V{ } clone [ T_Object "" element boa swap push ] keep >>element ; inline PREDICATE: bson-eoo < integer T_EOO = ; PREDICATE: bson-not-eoo < integer T_EOO > ; @@ -63,45 +64,38 @@ GENERIC: element-binary-read ( length type -- object ) read-byte-raw dup B{ 0 } = [ append ] - [ append (read-cstring) ] if ; + [ append (read-cstring) ] if ; inline recursive : read-cstring ( -- string ) B{ } clone - (read-cstring) utf8 alien>string ; + (read-cstring) utf8 alien>string ; inline : read-sized-string ( length -- string ) [ read ] [ count-bytes ] bi - utf8 alien>string ; + utf8 alien>string ; inline : read-element-type ( -- type ) - read-byte ; + read-byte ; inline : push-element ( type name -- element ) element boa - [ get-state element>> push ] keep ; + [ get-state element>> push ] keep ; inline : pop-element ( -- element ) - get-state element>> pop ; + get-state element>> pop ; inline : peek-scope ( -- ht ) - get-state scope>> peek ; + get-state scope>> peek ; inline : read-elements ( -- ) read-element-type element-read - [ read-elements ] when ; - -: make-tuple ( assoc -- tuple ) - [ P_INFO swap at persistent-tuple-class new ] keep ! instance assoc - [ dup [ keys ] keep ] dip ! instance array mirror assoc - '[ dup _ [ _ at ] dip [ swap ] dip set-at ] each ; + [ read-elements ] when ; inline recursive GENERIC: fix-result ( assoc type -- result ) M: bson-object fix-result ( assoc type -- result ) - drop - [ ] [ P_INFO swap key? ] bi - [ make-tuple ] [ ] if ; + drop ; M: bson-array fix-result ( assoc type -- result ) drop @@ -109,10 +103,10 @@ M: bson-array fix-result ( assoc type -- result ) M: bson-eoo element-read ( type -- cont? ) drop - get-state scope>> [ pop ] keep swap ! vec assoc - pop-element [ type>> ] keep ! vec assoc type element - [ fix-result ] dip ! vec result element - rot length 0 > ! result element + get-state scope>> [ pop ] keep swap ! vec assoc + pop-element [ type>> ] keep ! vec assoc element + [ fix-result ] dip + rot length 0 > ! assoc element [ name>> peek-scope set-at t ] [ drop [ get-state ] dip >>result drop f ] if ; @@ -133,19 +127,21 @@ M: bson-oid element-data-read ( type -- object ) oid boa pop-element drop ; -M: bson-object element-data-read ( type -- object ) - drop - read-int32 drop - get-state - [ [ [ H{ } clone ] dip push ] keep ] change-scope - scope>> peek ; +: [scope-changer] ( state -- state quot ) + dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline -M: bson-array element-data-read ( type -- object ) +: (object-data-read) ( type -- object ) drop read-int32 drop get-state - [ [ [ H{ } clone ] dip push ] keep ] change-scope - scope>> peek ; + [scope-changer] change-scope + scope>> peek ; inline + +M: bson-object element-data-read ( type -- object ) + (object-data-read) ; + +M: bson-array element-data-read ( type -- object ) + (object-data-read) ; M: bson-string element-data-read ( type -- object ) drop @@ -179,10 +175,18 @@ M: bson-binary-function element-binary-read ( size type -- quot ) drop read bytes>object ; PRIVATE> - -: bson> ( arr -- ht ) - binary - [ dup state + +GENERIC: stream>assoc ( exemplar -- assoc ) + +M: assoc stream>assoc ( exemplar -- assoc ) + dup state [ read-int32 >>size read-elements ] with-variable - result>> - ] with-byte-reader ; + result>> ; + +USING: multi-methods ; + +GENERIC: array>assoc ( array exemplar -- assoc ) + +METHOD: array>assoc { byte-array assoc } ( array exemplar -- assoc ) + [ binary ] dip '[ _ stream>assoc ] with-byte-reader ; + diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor new file mode 100644 index 0000000000..a85a9867c5 --- /dev/null +++ b/bson/writer/writer.factor @@ -0,0 +1,102 @@ +! Copyright (C) 2008 Sascha Matzke. +! See http://factorcode.org/license.txt for BSD license. +USING: bson bson.constants accessors kernel io.streams.string + io.encodings.binary classes byte-arrays quotations serialize + io.encodings.utf8 strings splitting math.parser locals + sequences math assocs classes words make fry + prettyprint hashtables mirrors alien.strings alien.c-types + io.streams.byte-array io ; + +IN: bson.writer + +#! Writes the object out to a stream in BSON format + + write ; inline +: write-int32 ( int -- ) write ; inline +: write-double ( real -- ) write ; inline +: write-cstring ( string -- ) utf8 string>alien write ; inline +: write-longlong ( object -- ) write ; inline + +: write-eoo ( -- ) T_EOO write-byte ; inline +: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline +: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline + + +M: f bson-write ( f -- ) + drop 0 write-byte ; + +M: t bson-write ( t -- ) + drop 1 write-byte ; + +M: bson-null bson-write ( null -- ) + drop ; + +M: string bson-write ( obj -- ) + utf8 string>alien + [ length write-int32 ] keep + write ; + +M: integer bson-write ( num -- ) + write-int32 ; + +M: real bson-write ( num -- ) + >float write-double ; + +M: byte-array bson-write ( binary -- ) + [ length write-int32 ] keep + T_Binary_Bytes write-byte + write ; + +M: quotation bson-write ( quotation -- ) + object>bytes [ length write-int32 ] keep + T_Binary_Function write-byte + write ; + +M: oid bson-write ( oid -- ) + [ a>> write-longlong ] [ b>> write-int32 ] bi ; + +M: sequence bson-write ( array -- ) + '[ _ [ [ write-type ] dip number>string write-cstring bson-write ] + each-index ] + binary swap with-byte-writer + [ length 5 + bson-write ] keep + write + write-eoo ; + +M: assoc bson-write ( hashtable -- ) + '[ _ [ write-pair ] assoc-each ] + binary swap with-byte-writer + [ length 5 + bson-write ] keep + write + write-eoo ; + +M: word bson-write name>> bson-write ; + +PRIVATE> + +: assoc>array ( assoc -- byte-array ) + '[ _ bson-write ] binary swap with-byte-writer ; inline + +: assoc>stream ( assoc -- ) + bson-write ; inline + diff --git a/mongodb/bson/bson.factor b/mongodb/bson/bson.factor deleted file mode 100644 index 27033094de..0000000000 --- a/mongodb/bson/bson.factor +++ /dev/null @@ -1,9 +0,0 @@ - -IN: mongodb.bson - -USE: vocabs.loader - -SINGLETON: bson-null - -"mongodb.bson.reader" require -"mongodb.bson.writer" require diff --git a/mongodb/bson/writer/writer.factor b/mongodb/bson/writer/writer.factor deleted file mode 100644 index 44dca02991..0000000000 --- a/mongodb/bson/writer/writer.factor +++ /dev/null @@ -1,122 +0,0 @@ -! Copyright (C) 2008 Sascha Matzke. -! See http://factorcode.org/license.txt for BSD license. -USING: mongodb.bson mongodb.bson.constants accessors kernel io.streams.string - io.encodings.binary classes byte-arrays quotations serialize - io.encodings.utf8 strings splitting math.parser locals - sequences math assocs classes words make fry mongodb.persistent - prettyprint hashtables mirrors alien.strings alien.c-types - io.streams.byte-array io ; - -IN: mongodb.bson.writer - -#! Writes the object out to a stream in BSON format - - write ; -: write-int32 ( int -- ) write ; -: write-double ( real -- ) write ; -: write-cstring ( string -- ) utf8 string>alien write ; -: write-longlong ( object -- ) write ; - -: write-eoo ( -- ) T_EOO write-byte ; -: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; -: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; - -:: write-tuple-info ( object -- ) - P_SLOTS [ [ ] [ object at ] bi write-pair ] each ; - -M: f bson-write ( f -- ) - drop 0 write-byte ; - -M: t bson-write ( t -- ) - drop 1 write-byte ; - -M: bson-null bson-write ( null -- ) - drop ; - -M: string bson-write ( obj -- ) - utf8 string>alien - [ length write-int32 ] keep - write ; - -M: integer bson-write ( num -- ) - write-int32 ; - -M: real bson-write ( num -- ) - >float write-double ; - -M: byte-array bson-write ( binary -- ) - [ length write-int32 ] keep - T_Binary_Bytes write-byte - write ; - -M: quotation bson-write ( quotation -- ) - object>bytes [ length write-int32 ] keep - T_Binary_Function write-byte - write ; - -M: oid bson-write ( oid -- ) - [ a>> write-longlong ] [ b>> write-int32 ] bi ; - -M: sequence bson-write ( array -- ) - '[ _ [ [ write-type ] dip number>string write-cstring bson-write ] - each-index ] - binary swap with-byte-writer - [ length 5 + bson-write ] keep - write - write-eoo ; - -: check-p-field ( key value -- key value boolean ) - [ [ "_p_" swap start 0 = ] keep ] dip rot ; - -M: persistent-tuple bson-write ( persistent-tuple -- ) - - '[ _ [ write-tuple-info ] - [ [ check-p-field [ 2drop ] [ write-pair ] if ] assoc-each ] bi ] - binary swap with-byte-writer - [ length 5 + bson-write ] keep - write - write-eoo ; - -M: tuple bson-write ( tuple -- ) - make-persistent bson-write ; - -M: assoc bson-write ( hashtable -- ) - '[ _ [ write-pair ] assoc-each ] - binary swap with-byte-writer - [ length 5 + bson-write ] keep - write - write-eoo ; - -M: word bson-write name>> bson-write ; - -PRIVATE> - -GENERIC: >bson ( obj -- byte-aray ) - -M: tuple >bson ( tuble -- byte-array ) - '[ _ bson-write ] binary swap with-byte-writer ; - -M: hashtable >bson ( hashmap -- byte-array ) - '[ _ bson-write ] binary swap with-byte-writer ; - - From 3e433f52a20581866ad921f9106c9e0d1653d6fd Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 23 Jan 2009 06:53:08 +0100 Subject: [PATCH 018/772] various changes --- bson/bson.factor | 5 +- bson/constants/constants.factor | 55 +++++---- bson/reader/reader.factor | 78 ++++++++----- bson/writer/writer.factor | 15 ++- mongodb/mongodb.factor | 48 ++++++-- mongodb/persistent/persistent.factor | 168 +++++++++++++++++---------- 6 files changed, 237 insertions(+), 132 deletions(-) diff --git a/bson/bson.factor b/bson/bson.factor index 4be8e2d3ed..a97b5029b0 100644 --- a/bson/bson.factor +++ b/bson/bson.factor @@ -1,9 +1,6 @@ +USING: vocabs.loader ; IN: bson -USE: vocabs.loader - -SINGLETON: bson-null - "bson.reader" require "bson.writer" require diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index f519c0f998..8f5b61a671 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -1,31 +1,40 @@ -USING: alien.c-types ; +USING: alien.c-types accessors kernel calendar random math.bitwise math unix ; IN: bson.constants TUPLE: oid { a initial: 0 } { b initial: 0 } ; +: ( -- oid ) + oid new + now timestamp>micros >>a + 8 random-bits 16 shift HEX: FF0000 mask + getpid HEX: FFFF mask + bitor >>b ; -: T_EOO ( -- type ) 0 ; inline -: T_Double ( -- type ) 1 ; inline -: T_Integer ( -- type ) 16 ; inline -: T_Boolean ( -- type ) 8 ; inline -: T_String ( -- type ) 2 ; inline -: T_Object ( -- type ) 3 ; inline -: T_Array ( -- type ) 4 ; inline -: T_Binary ( -- type ) 5 ; inline -: T_Undefined ( -- type ) 6 ; inline -: T_OID ( -- type ) 7 ; inline -: T_Date ( -- type ) 9 ; inline -: T_NULL ( -- type ) 10 ; inline -: T_Regexp ( -- type ) 11 ; inline -: T_DBRef ( -- type ) 12 ; inline -: T_Code ( -- type ) 13 ; inline -: T_ScopedCode ( -- type ) 17 ; inline -: T_Symbol ( -- type ) 14 ; inline -: T_JSTypeMax ( -- type ) 16 ; inline -: T_MaxKey ( -- type ) 127 ; inline - -: T_Binary_Bytes ( -- subtype ) 2 ; inline -: T_Binary_Function ( -- subtype ) 1 ; inline +TUPLE: dbref ns oid ; + + +CONSTANT: T_EOO 0 +CONSTANT: T_Double 1 +CONSTANT: T_Integer 16 +CONSTANT: T_Boolean 8 +CONSTANT: T_String 2 +CONSTANT: T_Object 3 +CONSTANT: T_Array 4 +CONSTANT: T_Binary 5 +CONSTANT: T_Undefined 6 +CONSTANT: T_OID 7 +CONSTANT: T_Date 9 +CONSTANT: T_NULL 10 +CONSTANT: T_Regexp 11 +CONSTANT: T_DBRef 12 +CONSTANT: T_Code 13 +CONSTANT: T_ScopedCode 17 +CONSTANT: T_Symbol 14 +CONSTANT: T_JSTypeMax 16 +CONSTANT: T_MaxKey 127 + +CONSTANT: T_Binary_Bytes 2 +CONSTANT: T_Binary_Function 1 diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index b7ef83d80e..5aebb4bcee 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -1,21 +1,21 @@ USING: mirrors io io.encodings.utf8 io.encodings.binary math match kernel sequences splitting accessors io.streams.byte-array namespaces prettyprint bson.constants assocs alien.c-types alien.strings fry words - tools.walker serialize locals byte-arrays ; + serialize byte-arrays ; IN: bson.reader -ERROR: size-mismatch actual declared ; - ( exemplar -- state ) - state new - exemplar clone >>exemplar - exemplar clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi +: ( exemplar -- state ) + [ state new ] dip + [ clone >>exemplar ] keep + clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi V{ } clone [ T_Object "" element boa swap push ] keep >>element ; inline PREDICATE: bson-eoo < integer T_EOO = ; @@ -101,6 +101,18 @@ M: bson-array fix-result ( assoc type -- result ) drop values ; +GENERIC: end-element ( type -- ) + +M: bson-object end-element ( type -- ) + drop ; + +M: bson-array end-element ( type -- ) + drop ; + +M: object end-element ( type -- ) + drop + pop-element drop ; + M: bson-eoo element-read ( type -- cont? ) drop get-state scope>> [ pop ] keep swap ! vec assoc @@ -113,9 +125,10 @@ M: bson-eoo element-read ( type -- cont? ) M: bson-not-eoo element-read ( type -- cont? ) [ peek-scope ] dip ! scope type '[ _ - read-cstring push-element [ name>> ] [ type>> ] bi - element-data-read - swap + read-cstring push-element [ name>> ] [ type>> ] bi + [ element-data-read ] keep + end-element + swap ] dip set-at t ; @@ -124,8 +137,7 @@ M: bson-oid element-data-read ( type -- object ) drop read-longlong read-int32 - oid boa - pop-element drop ; + oid boa ; : [scope-changer] ( state -- state quot ) dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline @@ -145,28 +157,34 @@ M: bson-array element-data-read ( type -- object ) M: bson-string element-data-read ( type -- object ) drop - read-int32 read-sized-string - pop-element drop ; + read-int32 read-sized-string ; M: bson-integer element-data-read ( type -- object ) drop - read-int32 - pop-element drop ; + read-int32 ; M: bson-double element-data-read ( type -- double ) drop - read-double - pop-element drop ; + read-double ; M: bson-boolean element-data-read ( type -- boolean ) drop - read-byte t = - pop-element drop ; + read-byte t = ; + +M: bson-ref element-data-read ( type -- dbref ) + drop + read-int32 + read-sized-string + T_OID element-data-read + dbref boa ; M: bson-binary element-data-read ( type -- binary ) drop - read-int32 read-byte element-binary-read - pop-element drop ; + read-int32 read-byte element-binary-read ; + +M: bson-null element-data-read ( type -- bf ) + drop + f ; M: bson-binary-bytes element-binary-read ( size type -- bytes ) drop read ; @@ -176,17 +194,13 @@ M: bson-binary-function element-binary-read ( size type -- quot ) PRIVATE> -GENERIC: stream>assoc ( exemplar -- assoc ) - -M: assoc stream>assoc ( exemplar -- assoc ) +: stream>assoc ( exemplar -- assoc ) dup state [ read-int32 >>size read-elements ] with-variable result>> ; - -USING: multi-methods ; - -GENERIC: array>assoc ( array exemplar -- assoc ) - -METHOD: array>assoc { byte-array assoc } ( array exemplar -- assoc ) + +: array>assoc ( array exemplar -- assoc ) [ binary ] dip '[ _ stream>assoc ] with-byte-reader ; +: array>hashtable ( array -- assoc ) + H{ } array>assoc ; diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index a85a9867c5..c5e9b02ef8 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: bson bson.constants accessors kernel io.streams.string io.encodings.binary classes byte-arrays quotations serialize - io.encodings.utf8 strings splitting math.parser locals + io.encodings.utf8 strings splitting math.parser sequences math assocs classes words make fry prettyprint hashtables mirrors alien.strings alien.c-types io.streams.byte-array io ; @@ -19,7 +19,8 @@ GENERIC: bson-write ( obj -- ) M: t bson-type? ( boolean -- type ) drop T_Boolean ; M: f bson-type? ( boolean -- type ) drop T_Boolean ; -M: oid bson-type? ( word -- type ) drop T_OID ; +M: oid bson-type? ( word -- type ) drop T_OID ; +M: dbref bson-type? ( dbref -- type ) drop T_DBRef ; M: real bson-type? ( real -- type ) drop T_Double ; M: word bson-type? ( word -- type ) drop T_String ; M: tuple bson-type? ( tuple -- type ) drop T_Object ; @@ -28,7 +29,6 @@ M: string bson-type? ( string -- type ) drop T_String ; M: integer bson-type? ( integer -- type ) drop T_Integer ; M: sequence bson-type? ( seq -- type ) drop T_Array ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ; -M: bson-null bson-type? ( null -- type ) drop T_NULL ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; : write-byte ( byte -- ) write ; inline @@ -48,9 +48,6 @@ M: f bson-write ( f -- ) M: t bson-write ( t -- ) drop 1 write-byte ; -M: bson-null bson-write ( null -- ) - drop ; - M: string bson-write ( obj -- ) utf8 string>alien [ length write-int32 ] keep @@ -74,6 +71,12 @@ M: quotation bson-write ( quotation -- ) M: oid bson-write ( oid -- ) [ a>> write-longlong ] [ b>> write-int32 ] bi ; + +M: dbref bson-write ( dbref -- ) + [ ns>> utf8 string>alien + [ length write-int32 ] keep write + ] + [ oid>> bson-write ] bi ; M: sequence bson-write ( array -- ) '[ _ [ [ write-type ] dip number>string write-cstring bson-write ] diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor index b706dcffa6..b9c15c0317 100644 --- a/mongodb/mongodb.factor +++ b/mongodb/mongodb.factor @@ -1,15 +1,49 @@ -USING: mongodb.persistent ; +USING: accessors assocs fry io.encodings.binary io.sockets kernel math +math.parser mongodb.msg mongodb.persistent mongodb.query mongodb.tuple +namespaces sequences splitting ; IN: mongodb +INTERSECTION: storable mdb-persistent ; + +> get-collection-fqn ] keep + H{ } tuple>query ; inline -M: tuple store ( tuple -- tuple ) - [ check-persistent-tuple ] keep ; +PRIVATE> -M: persistent-tuple store ( ptuple -- ptuple ) - ; + +: ( db host port -- mdb ) + () ; + + +GENERIC: store ( tuple/ht -- ) + +GENERIC: find ( example -- tuple/ht ) + +GENERIC: findOne ( exampe -- tuple/ht ) + +GENERIC: load ( object -- object ) + + +M: storable store ( tuple -- ) + prepare-store ! H { collection { ... values ... } + [ [ ] 2dip + [ get-collection-fqn >>collection ] dip + objects>> + [ mdb>> master>> binary ] dip '[ _ write-request ] with-client + ] assoc-each ; + +M: storable find ( example -- result ) + prepare-find (find) + build-result ; + +M: storable findOne ( example -- result ) + prepare-find (find-one) + dup returned#>> 1 = + [ objects>> first ] + [ drop f ] if ; diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor index d438fbf978..c7c3fcf134 100644 --- a/mongodb/persistent/persistent.factor +++ b/mongodb/persistent/persistent.factor @@ -1,81 +1,129 @@ -USING: accessors classes classes.mixin classes.tuple compiler.units -fry kernel words locals mirrors formatting assocs hashtables ; +USING: accessors assocs classes fry kernel linked-assocs math mirrors +namespaces sequences strings vectors words bson.constants +continuations ; IN: mongodb.persistent -MIXIN: persistent-tuple +MIXIN: mdb-persistent -SLOT: _p_oid -SLOT: _p_info +SLOT: _id -TUPLE: oid { a initial: 0 } { b initial: 0 } ; +CONSTANT: MDB_P_SLOTS { "_id" } +CONSTANT: MDB_OID "_id" -: MDB_CLASS ( -- string ) "p_class" ; inline -: MDB_VOCAB ( -- string ) "p_vocab" ; inline -: MDB_MT ( -- string ) "p_mt" ; inline -: MDB_CT ( -- string ) "p_ct" ; inline -: MDB_COL ( -- string ) "p_col" ; inline +SYMBOL: mdb-op-seq -PREDICATE: pinfo-hashtable < hashtable [ MDB_CLASS swap key? ] [ MDB_VOCAB swap key? ] bi and ; +GENERIC# tuple>assoc 1 ( tuple exemplar -- assoc ) -: P_OID ( -- name ) "_p_oid" ; inline -: P_INFO ( -- name ) "_p_info" ; inline +: tuple>linked-assoc ( tuple -- linked-assoc ) + tuple>assoc ; inline -: P_SLOTS ( -- array ) - { "_p_oid" "_p_info" } ; +GENERIC# tuple>query 1 ( tuple examplar -- query-assoc ) + +GENERIC: mdb-collection>> ( tuple -- string ) + +GENERIC: mdb-slot-definitions>> ( tuple -- string ) + + +DEFER: assoc>tuple +DEFER: create-mdb-command ] - tm2 [ 'tuple ] | - tm1 [ swap tm2 set-at ] assoc-each - tm2 object>> ] ; +: ( tuple -- dbref ) + [ mdb-collection>> ] [ _id>> ] bi dbref boa ; inline + +: mdbinfo>tuple-class ( mdbinfo -- class ) + [ first ] keep second lookup ; inline + +: make-tuple ( assoc -- tuple ) + [ MDB_INFO swap at mdbinfo>tuple-class new ] keep ! instance assoc + [ dup [ keys ] keep ] dip ! instance array mirror assoc + '[ dup _ [ _ at assoc>tuple ] dip [ swap ] dip set-at ] each ; + +: persistent-info ( tuple -- pinfo ) + class V{ } clone tuck + [ [ name>> ] dip push ] + [ [ vocabulary>> ] dip push ] 2bi ; inline + +: id-or-f? ( key value -- key value boolean ) + over "_id" = + [ dup f = ] dip or ; inline + +: write-persistent-info ( mirror exemplar assoc -- ) + [ drop ] dip + 2dup [ "_id" ] 2dip [ over [ at ] dip ] dip set-at + [ object>> persistent-info MDB_INFO ] dip set-at ; + +: persistent-tuple? ( object -- object boolean ) + dup mdb-persistent? ; inline + +: ensure-value-ht ( key ht -- vht ) + 2dup key? + [ at ] + [ [ H{ } clone dup ] 2dip set-at ] if ; inline + +: data-tuple? ( tuple -- ? ) + dup tuple? [ assoc? [ f ] [ t ] if ] [ drop f ] if ; + +: write-tuple-fields ( mirror exemplar assoc -- ) + [ dup ] dip ! m e e a + '[ id-or-f? + [ 2drop ] + [ persistent-tuple? + [ _ keep + [ mdb-collection>> ] keep + [ create-mdb-command ] dip + ] + [ dup data-tuple? _ [ ] if ] if + swap _ set-at + ] if + ] assoc-each ; + +: prepare-assoc ( tuple exemplar -- assoc mirror exemplar assoc ) + [ ] dip dup clone swap [ tuck ] dip swap ; inline +: ensure-mdb-info ( tuple -- tuple ) + dup _id>> [ >>_id ] unless ; inline + +: with-op-seq ( quot -- op-seq ) + [ + [ H{ } clone mdb-op-seq set ] dip call mdb-op-seq get + ] with-scope ; inline + PRIVATE> -GENERIC: persistent-tuple-class ( tuple -- class ) +: create-mdb-command ( assoc ns -- ) + mdb-op-seq get + ensure-value-ht + [ dup [ MDB_OID ] dip at ] dip + set-at ; inline -M: tuple persistent-tuple-class ( tuple -- class ) - class persistent-tuple-class ; +: prepare-store ( mdb-persistent -- op-seq ) + '[ _ [ tuple>linked-assoc ] keep mdb-collection>> create-mdb-command ] + with-op-seq ; inline -M: pinfo-hashtable persistent-tuple-class ( tuple -- class ) - [ MDB_CLASS swap at ] [ MDB_VOCAB swap at ] bi lookup - persistent-tuple-class ; +M: mdb-persistent tuple>assoc ( tuple exemplar -- assoc ) + [ ensure-mdb-info ] dip ! tuple exemplar + prepare-assoc + [ write-persistent-info ] + [ [ '[ _ tuple>assoc ] ] dip write-tuple-fields ] 3bi ; -M: tuple-class persistent-tuple-class ( class -- class' ) - [ [ vocabulary>> ] [ name>> ] bi ] keep ! name vocab class - [ "%s_%s" sprintf ] dip swap dup ! class new_name new_name - P_VOCAB lookup dup ! class new_name vo/f vo/f - [ [ drop drop ] dip ] [ drop define-persistent-tuple ] if ; +M: tuple tuple>assoc ( tuple exemplar -- assoc ) + [ drop persistent-info MDB_INFO ] 2keep + prepare-assoc [ '[ _ tuple>assoc ] ] write-tuple-fields + [ set-at ] keep ; + +M: tuple tuple>query ( tuple examplar -- assoc ) + prepare-assoc [ '[ _ tuple>query ] ] dip write-tuple-fields ; + +: assoc>tuple ( assoc -- tuple ) + dup assoc? + [ [ dup MDB_INFO swap key? + [ make-tuple ] + [ ] if ] [ drop ] recover + ] [ ] if ; inline -GENERIC: make-persistent ( tuple -- 'tuple ) - -M: tuple make-persistent ( tuple -- 'tuple ) - [let* | tuple [ ] - tclass [ tuple class ] - 'tuple [ tclass persistent-tuple-class new ] - pinfo [ H{ } clone ] | - tuple 'tuple copy-slots - oid new >>_p_oid - tclass name>> MDB_CLASS pinfo set-at - tclass vocabulary>> MDB_VOCAB pinfo set-at - 0 MDB_MT pinfo set-at - 0 MDB_CT pinfo set-at - "" MDB_COL pinfo set-at - pinfo >>_p_info - ] ; - -M: persistent-tuple make-persistent ( tuple -- tuple ) - ; From 3c8402dbca37b947d9bda2fbcebfedae4905d581 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sun, 25 Jan 2009 11:19:07 +0100 Subject: [PATCH 019/772] added README.txt --- README.txt | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 README.txt diff --git a/README.txt b/README.txt new file mode 100644 index 0000000000..bb91f56c33 --- /dev/null +++ b/README.txt @@ -0,0 +1,2 @@ +This is the attempt to implement a driver for MongoDB +(http://www.mongodb.org) in Factor (http://www.factorcode.org). From c0f2c3a95f1c5d50ddd9f9a66352b614f9ec0142 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Tue, 27 Jan 2009 09:21:04 +0100 Subject: [PATCH 020/772] recovered files lost by my own stupidity... --- mongodb/collection/collection.factor | 105 +++++++++++++++++++ mongodb/connection/connection.factor | 61 ++++++++++++ mongodb/index/index.factor | 99 ++++++++++++++++++ mongodb/mongodb.factor | 27 +++-- mongodb/msg/msg.factor | 144 +++++++++++++++++++++++++++ mongodb/persistent/persistent.factor | 6 +- mongodb/query/query.factor | 64 ++++++++++++ mongodb/tuple/tuple.factor | 66 ++++++++++++ 8 files changed, 552 insertions(+), 20 deletions(-) create mode 100644 mongodb/collection/collection.factor create mode 100644 mongodb/connection/connection.factor create mode 100644 mongodb/index/index.factor create mode 100644 mongodb/msg/msg.factor create mode 100644 mongodb/query/query.factor create mode 100644 mongodb/tuple/tuple.factor diff --git a/mongodb/collection/collection.factor b/mongodb/collection/collection.factor new file mode 100644 index 0000000000..c7c72d8fad --- /dev/null +++ b/mongodb/collection/collection.factor @@ -0,0 +1,105 @@ +USING: accessors assocs formatting kernel math classes sequences splitting strings + words classes.tuple vectors ; + +IN: mongodb.collection + +GENERIC: mdb-slot-definitions>> ( tuple -- string ) +GENERIC: mdb-collection>> ( object -- mdb-collection ) + +CONSTANT: MDB_COLLECTIONS "mdb_collections" + +SYMBOLS: +transient+ +load+ ; + +UNION: boolean t POSTPONE: f ; + +TUPLE: mdb-collection + { name string } + { capped boolean initial: f } + { size integer initial: -1 } + { max integer initial: -1 } + { classes sequence } ; + +USING: mongodb.persistent mongodb.msg mongodb.tuple +mongodb.connection mongodb.query mongodb.index ; + +>) ( class -- mdb-collection ) + dup props>> [ MDB_COL_PROP ] dip at + [ [ drop ] dip ] + [ superclass [ (mdb-collection>>) ] [ f ] if* ] if* ; inline recursive + +: (mdb-slot-definitions>>) ( class -- slot-defs ) + superclasses [ MDB_SLOTOPT_PROP word-prop ] map assoc-combine ; inline + +: link-class ( class collection -- ) + tuck classes>> ! col class v{} + [ 2dup member? [ 2drop ] [ push ] if ] + [ 1vector >>classes ] if* drop ; + + +PRIVATE> + +M: tuple-class mdb-collection>> ( tuple -- mdb-collection ) + (mdb-collection>>) ; + +M: mdb-persistent mdb-collection>> ( tuple -- mdb-collection ) + class (mdb-collection>>) ; + +M: mdb-persistent mdb-slot-definitions>> ( tuple -- string ) + class (mdb-slot-definitions>>) ; + +M: tuple-class mdb-slot-definitions>> ( class -- assoc ) + (mdb-slot-definitions>>) ; + +M: mdb-collection mdb-slot-definitions>> ( collection -- assoc ) + classes>> [ mdb-slot-definitions>> ] map assoc-combine ; + +: link-collection ( class collection -- ) + 2dup link-class + swap [ MDB_COL_PROP ] dip props>> set-at ; inline + +: declared-collections> ( -- assoc ) + MDB_COLLECTIONS mdb-persistent props>> at + [ H{ } clone + [ MDB_COLLECTIONS mdb-persistent props>> set-at ] keep + ] unless* ; + +: ( name -- mdb-collection ) + declared-collections> 2dup key? + [ at ] + [ [ mdb-collection new ] 2dip + [ [ >>name dup ] keep ] dip set-at ] if ; + +: load-collections ( -- collections ) + namespaces-ns + H{ } clone (find) + objects>> [ [ "name" ] dip at "." split second ] map + dup [ ensure-indices ] each + [ mdb>> ] dip >>collections collections>> ; + +: check-ok ( result -- ? ) + [ "ok" ] dip key? ; inline + +: create-collection ( mdb-collection -- ) + dup name>> "create" H{ } clone [ set-at ] keep + [ + mdb>> [ master>> ] keep name>> "%s.$cmd" sprintf + ] dip (find-one) + check-ok + [ [ ensure-indices ] keep dup name>> mdb>> collections>> set-at ] + [ "could not create collection" throw ] if ; + +: get-collection-fqn ( mdb-collection -- fqdn ) + mdb>> collections>> + dup keys length 0 = + [ drop load-collections ] + [ ] if + [ dup name>> ] dip + key? + [ ] + [ dup create-collection ] if + name>> [ mdb>> name>> ] dip "%s.%s" sprintf ; diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor new file mode 100644 index 0000000000..c870ed7875 --- /dev/null +++ b/mongodb/connection/connection.factor @@ -0,0 +1,61 @@ +USING: accessors assocs fry io.sockets kernel math mongodb.msg +mongodb.query namespaces sequences splitting math.parser ; + +IN: mongodb.connection + +TUPLE: mdb-node master? inet ; + +TUPLE: mdb name nodes collections ; + +: mdb>> ( -- mdb ) + mdb get ; inline + +: with-db ( mdb quot -- ... ) + '[ _ mdb set _ call ] with-scope ; + +: master>> ( mdb -- inet ) + nodes>> [ t ] dip at inet>> ; + +: slave>> ( mdb -- inet ) + nodes>> [ f ] dip at inet>> ; + + + (find-one-raw) ; inline + +: -push ( seq elt -- ) + swap push ; inline + +: split-host-str ( hoststr -- host port ) + ":" split [ first ] keep + second string>number ; inline + +: check-nodes ( node -- nodelist ) + [ V{ } clone ] dip + [ -push ] 2keep + dup inet>> ismaster-cmd ! vec node result + dup [ "ismaster" ] dip at + >fixnum 1 = ! vec node result + [ [ t >>master? drop ] dip f ] + [ [ f >>master? drop ] dip t ] if + [ "remote" ] 2dip [ at split-host-str ] dip + swap mdb-node boa swap + [ push ] keep ; + +: verify-nodes ( -- ) + mdb>> nodes>> [ t ] dip at + check-nodes + H{ } clone tuck + '[ dup master?>> _ set-at ] each + [ mdb>> ] dip >>nodes drop ; + +PRIVATE> + +: () ( db host port -- mdb ) + [ f ] 2dip mdb-node boa + check-nodes + H{ } clone tuck + '[ dup master?>> _ set-at ] each + V{ } mdb boa ; diff --git a/mongodb/index/index.factor b/mongodb/index/index.factor new file mode 100644 index 0000000000..407abe5b48 --- /dev/null +++ b/mongodb/index/index.factor @@ -0,0 +1,99 @@ +USING: accessors assocs combinators formatting fry kernel memoize +linked-assocs mongodb.persistent mongodb.msg +sequences sequences.deep io.encodings.binary +io.sockets prettyprint sets ; + +IN: mongodb.index + +DEFER: mdb-slot-definitions>> + +TUPLE: index name ns key ; + +SYMBOLS: +fieldindex+ +compoundindex+ +deepindex+ ; + + ] 2dip + [ rest ] keep first ! assoc slot options itype + { { +fieldindex+ [ drop [ 1 ] dip pick set-at ] } + { +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] } + { +compoundindex+ [ + 2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options + over '[ _ [ 1 ] 2dip set-at ] each ] } + } case ; + +: build-index-seq ( slot optlist ns -- index-seq ) + [ V{ } clone ] 3dip ! v{} slot optl ns + [ index new ] dip ! v{} slot optl index ns + >>ns + [ pick ] dip swap ! v{} slot optl index v{} + [ swap ] 2dip ! v{} optl slot index v{ } + '[ _ _ ! element slot exemplar + clone 2over swap index-name >>name ! element slot clone + [ build-index ] dip swap >>key _ push + ] each ; + +: is-index-declaration? ( entry -- ? ) + first + { { +fieldindex+ [ t ] } + { +compoundindex+ [ t ] } + { +deepindex+ [ t ] } + [ drop f ] } case ; + +: index-assoc ( seq -- assoc ) + H{ } clone tuck '[ dup name>> _ set-at ] each ; + +: delete-index ( name ns -- ) + "Drop index %s - %s" sprintf . ; + +: clean-indices ( existing defined -- ) + [ index-assoc ] bi@ assoc-diff values + [ [ name>> ] [ ns>> ] bi delete-index ] each ; + +PRIVATE> + +USE: mongodb.query + +: load-indices ( mdb-collection -- indexlist ) + [ mdb>> name>> ] dip name>> "%s.%s" sprintf + "ns" H{ } clone [ set-at ] keep [ index-ns ] dip + '[ _ write-request read-reply ] + [ mdb>> master>> binary ] dip with-client + objects>> [ [ index new ] dip + [ [ "ns" ] dip at >>ns ] + [ [ "name" ] dip at >>name ] + [ [ "key" ] dip at >>key ] tri + ] map ; + +: build-indices ( mdb-collection mdb -- seq ) + name>> + [ [ mdb-slot-definitions>> ] keep name>> ] dip + swap "%s.%s" sprintf + [ V{ } clone ] 2dip pick + '[ _ + [ [ is-index-declaration? ] filter ] dip + build-index-seq _ push + ] assoc-each flatten ; + +: ensure-indices ( mdb-collection -- ) + [ load-indices ] keep mdb>> build-indices + [ clean-indices ] keep + V{ } clone tuck + '[ _ [ tuple>query ] dip push ] each + mdb>> name>> "%s.system.indexes" sprintf >>collection + [ mdb>> master>> binary ] dip '[ _ write-request ] with-client ; + + +: show-indices ( mdb-collection -- ) + load-indices . ; diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor index b9c15c0317..4c258eeb98 100644 --- a/mongodb/mongodb.factor +++ b/mongodb/mongodb.factor @@ -1,14 +1,19 @@ USING: accessors assocs fry io.encodings.binary io.sockets kernel math -math.parser mongodb.msg mongodb.persistent mongodb.query mongodb.tuple -namespaces sequences splitting ; +math.parser namespaces sequences splitting ; IN: mongodb -INTERSECTION: storable mdb-persistent ; +! generic methods +GENERIC: store ( tuple/ht -- ) +GENERIC: find ( example -- tuple/ht ) +GENERIC: findOne ( exampe -- tuple/ht ) +GENERIC: load ( object -- object ) + +USING: mongodb.msg mongodb.persistent mongodb.query mongodb.tuple +mongodb.collection mongodb.connection ; > get-collection-fqn ] keep H{ } tuple>query ; inline @@ -20,16 +25,8 @@ PRIVATE> () ; -GENERIC: store ( tuple/ht -- ) -GENERIC: find ( example -- tuple/ht ) - -GENERIC: findOne ( exampe -- tuple/ht ) - -GENERIC: load ( object -- object ) - - -M: storable store ( tuple -- ) +M: mdb-persistent store ( tuple -- ) prepare-store ! H { collection { ... values ... } [ [ ] 2dip [ get-collection-fqn >>collection ] dip @@ -37,11 +34,11 @@ M: storable store ( tuple -- ) [ mdb>> master>> binary ] dip '[ _ write-request ] with-client ] assoc-each ; -M: storable find ( example -- result ) +M: mdb-persistent find ( example -- result ) prepare-find (find) build-result ; -M: storable findOne ( example -- result ) +M: mdb-persistent findOne ( example -- result ) prepare-find (find-one) dup returned#>> 1 = [ objects>> first ] diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor new file mode 100644 index 0000000000..faafaf4b7b --- /dev/null +++ b/mongodb/msg/msg.factor @@ -0,0 +1,144 @@ +USING: io io.encodings.utf8 io.encodings.binary alien.c-types alien.strings math +bson.writer sequences kernel accessors io.streams.byte-array fry generalizations +combinators bson.reader sequences tools.walker assocs strings mongodb.persistent ; + +IN: mongodb.msg + +DEFER: tuple>linked-assoc + + + +TUPLE: mdb-msg + { opcode integer } + { req-id integer initial: 0 } + { resp-id integer initial: 0 } + { length integer initial: 0 } ; + +TUPLE: mdb-insert-msg < mdb-msg + { collection string } + { objects sequence } ; + +TUPLE: mdb-query-msg < mdb-msg + { collection string } + { skip# integer initial: 0 } + { return# integer initial: 0 } + { query assoc } + { returnfields assoc } + { orderby sequence } ; + +TUPLE: mdb-reply-msg < mdb-msg + { flags integer initial: 0 } + { cursor integer initial: 0 } + { start# integer initial: 0 } + { returned# integer initial: 0 } + { objects sequence } ; + + +: ( collection assoc -- mdb-query-msg ) + [ mdb-query-msg new ] 2dip + [ >>collection ] dip + >>query OP_Query >>opcode ; inline + +: ( collection assoc -- mdb-query-msg ) + 1 >>return# ; inline + +GENERIC: ( sequence -- mdb-insert-msg ) + +M: tuple ( tuple -- mdb-insert-msg ) + [ mdb-insert-msg new ] dip + tuple>linked-assoc V{ } clone tuck push + >>objects OP_Insert >>opcode ; + +M: sequence ( sequence -- mdb-insert-msg ) + [ mdb-insert-msg new ] dip >>objects OP_Insert >>opcode ; + + +: ( -- mdb-reply-msg ) + mdb-reply-msg new ; inline + + +GENERIC: write-request ( message -- ) + + write ; inline +: write-int32 ( int -- ) write ; inline +: write-double ( real -- ) write ; inline +: write-cstring ( string -- ) utf8 string>alien write ; inline +: write-longlong ( object -- ) write ; inline + +: read-int32 ( -- int32 ) 4 read *int ; inline +: read-longlong ( -- longlong ) 8 read *longlong ; inline +: read-byte-raw ( -- byte-raw ) 1 read ; inline +: read-byte ( -- byte ) read-byte-raw *char ; inline + +: (read-cstring) ( acc -- acc ) + read-byte-raw dup + B{ 0 } = + [ append ] + [ append (read-cstring) ] if ; recursive inline + +: read-cstring ( -- string ) + B{ } clone + (read-cstring) utf8 alien>string ; inline + +PRIVATE> + +: read-reply-header ( message -- message ) + read-int32 >>length + read-int32 >>req-id + read-int32 >>resp-id + read-int32 >>opcode ; inline + +: read-reply-message ( message -- message ) + read-int32 >>flags read-longlong >>cursor + read-int32 >>start# read-int32 tuck >>returned# swap + [ H{ } stream>assoc ] accumulator [ times ] dip >>objects ; inline + +: read-reply ( -- message ) + + read-reply-header + read-reply-message ; inline + +: write-request-header ( message length -- ) + MSG-HEADER-SIZE + write-int32 + [ req-id>> write-int32 ] keep + [ resp-id>> write-int32 ] keep + opcode>> write-int32 ; inline + +: (write-message) ( message quot -- ) + [ binary ] dip with-byte-writer dup + [ length write-request-header ] dip + write flush ; inline + +M: mdb-query-msg write-request ( message -- ) + dup + '[ _ + [ 4 write-int32 ] dip + [ collection>> write-cstring ] keep + [ skip#>> write-int32 ] keep + [ return#>> write-int32 ] keep + query>> assoc>array write + ] (write-message) ; + +M: mdb-insert-msg write-request ( message -- ) + dup + '[ _ + [ 0 write-int32 ] dip + [ collection>> write-cstring ] keep + objects>> [ assoc>array write ] each + ] (write-message) ; + diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor index c7c3fcf134..7967fd129c 100644 --- a/mongodb/persistent/persistent.factor +++ b/mongodb/persistent/persistent.factor @@ -20,13 +20,9 @@ GENERIC# tuple>assoc 1 ( tuple exemplar -- assoc ) GENERIC# tuple>query 1 ( tuple examplar -- query-assoc ) -GENERIC: mdb-collection>> ( tuple -- string ) - -GENERIC: mdb-slot-definitions>> ( tuple -- string ) - - DEFER: assoc>tuple DEFER: create-mdb-command +DEFER: mdb-collection>> > ( -- mdb ) + mdb get ; inline + +: with-db ( mdb quot -- * ) + '[ _ mdb set _ call ] with-scope ; inline + +: master>> ( mdb -- inet ) + nodes>> [ t ] dip at ; + +: slave>> ( mdb -- inet ) + nodes>> [ f ] dip at ; + +TUPLE: mdb-result { cursor integer } +{ start# integer } +{ returned# integer } +{ objects sequence } ; + +: index-ns ( -- ns ) + mdb>> name>> "%s.system.indexes" sprintf ; inline + +: namespaces-ns ( -- ns ) + mdb>> name>> "%s.system.namespaces" sprintf ; inline + + + +: (find-raw) ( inet query -- result ) + '[ _ write-request read-reply ] (execute-query) ; inline + +: (find-one-raw) ( inet query -- result ) + (find-raw) objects>> first ; inline + +: (find) ( query -- result ) + [ mdb>> master>> ] dip (find-raw) ; + +: (find-one) ( query -- result ) + [ mdb>> master>> ] dip (find-one-raw) ; + +: build-result ( resultmsg -- mdb-result ) + [ mdb-result new ] dip + { + [ cursor>> >>cursor ] + [ start#>> >>start# ] + [ returned#>> >>returned# ] + [ objects>> [ assoc>tuple ] map >>objects ] + } cleave ; + +: query-collections ( -- result ) + namespaces-ns H{ } clone (find) ; + diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor new file mode 100644 index 0000000000..3a8cb09292 --- /dev/null +++ b/mongodb/tuple/tuple.factor @@ -0,0 +1,66 @@ +USING: accessors assocs classes classes.mixin classes.tuple vectors math +classes.tuple.parser formatting generalizations kernel sequences fry +prettyprint strings compiler.units slots tools.walker words arrays +mongodb.collection mongodb.persistent ; + +IN: mongodb.tuple + +> ] map [ MDB_OID ] dip memq? + [ ] + [ MDB_P_SLOTS prepend ] if ; inline + +PRIVATE> + +: show-persistence-info ( class -- ) + H{ } clone + [ [ dup mdb-collection>> "collection" ] dip set-at ] keep + [ [ mdb-slot-definitions>> "slots" ] dip set-at ] keep . ; + +GENERIC: mdb-persisted? ( tuple -- ? ) + +M: mdb-persistent mdb-persisted? ( tuple -- ? ) + _id>> f = not ; + +M: assoc mdb-persisted? ( assoc -- ? ) + [ MDB_OID ] dip key? ; inline + +: MDBTUPLE: + parse-tuple-definition + mdb-check-id-slot + define-tuple-class ; parsing + +> ! col class v{} + [ 2dup member? [ 2drop ] [ push ] if ] + [ 1vector >>classes ] if* drop ; + +: optl>assoc ( seq -- assoc ) + [ dup assoc? + [ 1array { "" } append ] unless + ] map ; + +PRIVATE> + +: set-slot-options ( class options -- ) + H{ } clone tuck '[ _ [ split-olist optl>assoc swap ] dip set-at ] each + over [ MDB_SLOTOPT_PROP ] dip props>> set-at + dup mdb-collection>> link-collection ; + +: define-collection ( class collection options -- ) + [ [ dup ] dip link-collection ] dip ! cl options + [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip + set-slot-options ; + From ef9971840d8ebbeefc9085562c1110678a0a70bd Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Tue, 27 Jan 2009 19:42:29 +0100 Subject: [PATCH 021/772] some more cleaning up --- mongodb/collection/collection.factor | 105 --------------------------- mongodb/connection/connection.factor | 9 ++- mongodb/index/index.factor | 26 +++++-- mongodb/mongodb.factor | 20 ++--- mongodb/msg/msg.factor | 19 ++--- mongodb/persistent/persistent.factor | 12 +-- mongodb/query/query.factor | 75 ++++++++++--------- mongodb/tuple/tuple.factor | 79 ++++++++++++++++++-- 8 files changed, 155 insertions(+), 190 deletions(-) delete mode 100644 mongodb/collection/collection.factor diff --git a/mongodb/collection/collection.factor b/mongodb/collection/collection.factor deleted file mode 100644 index c7c72d8fad..0000000000 --- a/mongodb/collection/collection.factor +++ /dev/null @@ -1,105 +0,0 @@ -USING: accessors assocs formatting kernel math classes sequences splitting strings - words classes.tuple vectors ; - -IN: mongodb.collection - -GENERIC: mdb-slot-definitions>> ( tuple -- string ) -GENERIC: mdb-collection>> ( object -- mdb-collection ) - -CONSTANT: MDB_COLLECTIONS "mdb_collections" - -SYMBOLS: +transient+ +load+ ; - -UNION: boolean t POSTPONE: f ; - -TUPLE: mdb-collection - { name string } - { capped boolean initial: f } - { size integer initial: -1 } - { max integer initial: -1 } - { classes sequence } ; - -USING: mongodb.persistent mongodb.msg mongodb.tuple -mongodb.connection mongodb.query mongodb.index ; - ->) ( class -- mdb-collection ) - dup props>> [ MDB_COL_PROP ] dip at - [ [ drop ] dip ] - [ superclass [ (mdb-collection>>) ] [ f ] if* ] if* ; inline recursive - -: (mdb-slot-definitions>>) ( class -- slot-defs ) - superclasses [ MDB_SLOTOPT_PROP word-prop ] map assoc-combine ; inline - -: link-class ( class collection -- ) - tuck classes>> ! col class v{} - [ 2dup member? [ 2drop ] [ push ] if ] - [ 1vector >>classes ] if* drop ; - - -PRIVATE> - -M: tuple-class mdb-collection>> ( tuple -- mdb-collection ) - (mdb-collection>>) ; - -M: mdb-persistent mdb-collection>> ( tuple -- mdb-collection ) - class (mdb-collection>>) ; - -M: mdb-persistent mdb-slot-definitions>> ( tuple -- string ) - class (mdb-slot-definitions>>) ; - -M: tuple-class mdb-slot-definitions>> ( class -- assoc ) - (mdb-slot-definitions>>) ; - -M: mdb-collection mdb-slot-definitions>> ( collection -- assoc ) - classes>> [ mdb-slot-definitions>> ] map assoc-combine ; - -: link-collection ( class collection -- ) - 2dup link-class - swap [ MDB_COL_PROP ] dip props>> set-at ; inline - -: declared-collections> ( -- assoc ) - MDB_COLLECTIONS mdb-persistent props>> at - [ H{ } clone - [ MDB_COLLECTIONS mdb-persistent props>> set-at ] keep - ] unless* ; - -: ( name -- mdb-collection ) - declared-collections> 2dup key? - [ at ] - [ [ mdb-collection new ] 2dip - [ [ >>name dup ] keep ] dip set-at ] if ; - -: load-collections ( -- collections ) - namespaces-ns - H{ } clone (find) - objects>> [ [ "name" ] dip at "." split second ] map - dup [ ensure-indices ] each - [ mdb>> ] dip >>collections collections>> ; - -: check-ok ( result -- ? ) - [ "ok" ] dip key? ; inline - -: create-collection ( mdb-collection -- ) - dup name>> "create" H{ } clone [ set-at ] keep - [ - mdb>> [ master>> ] keep name>> "%s.$cmd" sprintf - ] dip (find-one) - check-ok - [ [ ensure-indices ] keep dup name>> mdb>> collections>> set-at ] - [ "could not create collection" throw ] if ; - -: get-collection-fqn ( mdb-collection -- fqdn ) - mdb>> collections>> - dup keys length 0 = - [ drop load-collections ] - [ ] if - [ dup name>> ] dip - key? - [ ] - [ dup create-collection ] if - name>> [ mdb>> name>> ] dip "%s.%s" sprintf ; diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor index c870ed7875..2a7e04f504 100644 --- a/mongodb/connection/connection.factor +++ b/mongodb/connection/connection.factor @@ -1,5 +1,5 @@ USING: accessors assocs fry io.sockets kernel math mongodb.msg -mongodb.query namespaces sequences splitting math.parser ; +namespaces sequences splitting math.parser io.encodings.binary ; IN: mongodb.connection @@ -22,8 +22,9 @@ TUPLE: mdb name nodes collections ; - (find-one-raw) ; inline + binary "admin.$cmd" H{ { "ismaster" 1 } } + '[ _ write-request read-reply ] with-client + objects>> first ; : -push ( seq elt -- ) swap push ; inline @@ -58,4 +59,4 @@ PRIVATE> check-nodes H{ } clone tuck '[ dup master?>> _ set-at ] each - V{ } mdb boa ; + H{ } clone mdb boa ; diff --git a/mongodb/index/index.factor b/mongodb/index/index.factor index 407abe5b48..bb930e02d2 100644 --- a/mongodb/index/index.factor +++ b/mongodb/index/index.factor @@ -1,11 +1,12 @@ USING: accessors assocs combinators formatting fry kernel memoize -linked-assocs mongodb.persistent mongodb.msg -sequences sequences.deep io.encodings.binary -io.sockets prettyprint sets ; +linked-assocs mongodb.persistent mongodb.msg mongodb.connection +sequences sequences.deep io.encodings.binary mongodb.tuple +io.sockets prettyprint sets tools.walker math ; IN: mongodb.index -DEFER: mdb-slot-definitions>> +: index-ns ( name -- ns ) + "%s.system.indexes" sprintf ; inline TUPLE: index name ns key ; @@ -24,6 +25,7 @@ SYMBOLS: +fieldindex+ +compoundindex+ +deepindex+ ; "%s-%s-%s-Idx" sprintf ; : build-index ( element slot -- assoc ) + break swap [ ] 2dip [ rest ] keep first ! assoc slot options itype { { +fieldindex+ [ drop [ 1 ] dip pick set-at ] } @@ -67,7 +69,7 @@ USE: mongodb.query : load-indices ( mdb-collection -- indexlist ) [ mdb>> name>> ] dip name>> "%s.%s" sprintf - "ns" H{ } clone [ set-at ] keep [ index-ns ] dip + "ns" H{ } clone [ set-at ] keep [ mdb>> name>> index-ns ] dip '[ _ write-request read-reply ] [ mdb>> master>> binary ] dip with-client objects>> [ [ index new ] dip @@ -91,9 +93,17 @@ USE: mongodb.query [ clean-indices ] keep V{ } clone tuck '[ _ [ tuple>query ] dip push ] each - mdb>> name>> "%s.system.indexes" sprintf >>collection - [ mdb>> master>> binary ] dip '[ _ write-request ] with-client ; - + dup length 0 > + [ [ mdb>> name>> "%s.system.indexes" sprintf ] dip + + [ mdb>> master>> binary ] dip '[ _ write-request ] with-client + ] + [ drop ] if ; : show-indices ( mdb-collection -- ) load-indices . ; + +: show-all-indices ( -- ) + mdb>> collections>> values + V{ } clone tuck + '[ load-indices _ push ] each flatten . ; \ No newline at end of file diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor index 4c258eeb98..a1cd3d7aff 100644 --- a/mongodb/mongodb.factor +++ b/mongodb/mongodb.factor @@ -1,5 +1,7 @@ USING: accessors assocs fry io.encodings.binary io.sockets kernel math -math.parser namespaces sequences splitting ; +math.parser namespaces sequences splitting +mongodb.connection mongodb.persistent mongodb.msg mongodb.query +mongodb.tuple ; IN: mongodb @@ -9,9 +11,6 @@ GENERIC: find ( example -- tuple/ht ) GENERIC: findOne ( exampe -- tuple/ht ) GENERIC: load ( object -- object ) -USING: mongodb.msg mongodb.persistent mongodb.query mongodb.tuple -mongodb.collection mongodb.connection ; - : ( db host port -- mdb ) () ; - - M: mdb-persistent store ( tuple -- ) prepare-store ! H { collection { ... values ... } - [ [ ] 2dip - [ get-collection-fqn >>collection ] dip - objects>> - [ mdb>> master>> binary ] dip '[ _ write-request ] with-client + [ [ get-collection-fqn ] dip + values + [ mdb>> master>> binary ] dip '[ _ write-request ] with-client ] assoc-each ; M: mdb-persistent find ( example -- result ) - prepare-find (find) + prepare-find [ mdb>> master>> ] dip (find) build-result ; M: mdb-persistent findOne ( example -- result ) - prepare-find (find-one) + prepare-find [ mdb>> master>> ] dip (find-one) dup returned#>> 1 = [ objects>> first ] [ drop f ] if ; diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index faafaf4b7b..e61006e01b 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -1,11 +1,9 @@ USING: io io.encodings.utf8 io.encodings.binary alien.c-types alien.strings math bson.writer sequences kernel accessors io.streams.byte-array fry generalizations -combinators bson.reader sequences tools.walker assocs strings mongodb.persistent ; +combinators bson.reader sequences tools.walker assocs strings linked-assocs ; IN: mongodb.msg -DEFER: tuple>linked-assoc - ( collection assoc -- mdb-query-msg ) 1 >>return# ; inline -GENERIC: ( sequence -- mdb-insert-msg ) +GENERIC# 1 ( collection objects -- mdb-insert-msg ) -M: tuple ( tuple -- mdb-insert-msg ) - [ mdb-insert-msg new ] dip - tuple>linked-assoc V{ } clone tuck push +M: linked-assoc ( collection linked-assoc -- mdb-insert-msg ) + [ mdb-insert-msg new ] 2dip + [ >>collection ] dip + V{ } clone tuck push >>objects OP_Insert >>opcode ; -M: sequence ( sequence -- mdb-insert-msg ) - [ mdb-insert-msg new ] dip >>objects OP_Insert >>opcode ; +M: sequence ( collection sequence -- mdb-insert-msg ) + [ mdb-insert-msg new ] 2dip + [ >>collection ] dip + >>objects OP_Insert >>opcode ; : ( -- mdb-reply-msg ) diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor index 7967fd129c..249a9d60af 100644 --- a/mongodb/persistent/persistent.factor +++ b/mongodb/persistent/persistent.factor @@ -1,16 +1,9 @@ USING: accessors assocs classes fry kernel linked-assocs math mirrors namespaces sequences strings vectors words bson.constants -continuations ; +continuations mongodb.tuple ; IN: mongodb.persistent -MIXIN: mdb-persistent - -SLOT: _id - -CONSTANT: MDB_P_SLOTS { "_id" } -CONSTANT: MDB_OID "_id" - SYMBOL: mdb-op-seq GENERIC# tuple>assoc 1 ( tuple exemplar -- assoc ) @@ -22,12 +15,13 @@ GENERIC# tuple>query 1 ( tuple examplar -- query-assoc ) DEFER: assoc>tuple DEFER: create-mdb-command -DEFER: mdb-collection>> ( tuple -- dbref ) [ mdb-collection>> ] [ _id>> ] bi dbref boa ; inline diff --git a/mongodb/query/query.factor b/mongodb/query/query.factor index 92c483bf2b..aede6a267f 100644 --- a/mongodb/query/query.factor +++ b/mongodb/query/query.factor @@ -1,54 +1,29 @@ USING: accessors combinators fry io.encodings.binary io.sockets kernel -mongodb.msg mongodb.persistent sequences math namespaces assocs -formatting ; +mongodb.msg mongodb.persistent mongodb.connection sequences math namespaces assocs +formatting splitting mongodb.tuple mongodb.index ; IN: mongodb.query -TUPLE: mdb-node master? inet ; - -TUPLE: mdb name nodes collections ; - -: mdb>> ( -- mdb ) - mdb get ; inline - -: with-db ( mdb quot -- * ) - '[ _ mdb set _ call ] with-scope ; inline - -: master>> ( mdb -- inet ) - nodes>> [ t ] dip at ; - -: slave>> ( mdb -- inet ) - nodes>> [ f ] dip at ; - TUPLE: mdb-result { cursor integer } { start# integer } { returned# integer } { objects sequence } ; -: index-ns ( -- ns ) - mdb>> name>> "%s.system.indexes" sprintf ; inline +: namespaces-ns ( name -- ns ) + "%s.system.namespaces" sprintf ; inline -: namespaces-ns ( -- ns ) - mdb>> name>> "%s.system.namespaces" sprintf ; inline - -: (find-raw) ( inet query -- result ) - '[ _ write-request read-reply ] (execute-query) ; inline +: (find) ( inet query -- result ) + '[ _ write-request read-reply ] (execute-query) ; inline -: (find-one-raw) ( inet query -- result ) - (find-raw) objects>> first ; inline - -: (find) ( query -- result ) - [ mdb>> master>> ] dip (find-raw) ; - -: (find-one) ( query -- result ) - [ mdb>> master>> ] dip (find-one-raw) ; +: (find-one) ( inet query -- result ) + (find) objects>> first ; inline : build-result ( resultmsg -- mdb-result ) [ mdb-result new ] dip @@ -59,6 +34,34 @@ PRIVATE> [ objects>> [ assoc>tuple ] map >>objects ] } cleave ; -: query-collections ( -- result ) - namespaces-ns H{ } clone (find) ; +: load-collections ( -- collections ) + mdb>> [ master>> ] [ name>> namespaces-ns ] bi + H{ } clone (find) + objects>> [ [ "name" ] dip at "." split second ] map + H{ } clone tuck + '[ [ ensure-indices ] [ ] [ name>> ] tri _ set-at ] each + [ mdb>> ] dip >>collections collections>> ; + +: check-ok ( result -- ? ) + [ "ok" ] dip key? ; inline +: create-collection ( mdb-collection -- ) + dup name>> "create" H{ } clone [ set-at ] keep + [ mdb>> [ master>> ] [ name>> ] bi "%s.$cmd" sprintf ] dip + (find-one) + check-ok + [ [ ensure-indices ] keep dup name>> mdb>> collections>> set-at ] + [ "could not create collection" throw ] if ; + +: get-collection-fqn ( mdb-collection -- fqdn ) + mdb>> collections>> + dup keys length 0 = + [ drop load-collections ] + [ ] if + [ dup name>> ] dip + key? + [ ] + [ dup create-collection ] if + name>> [ mdb>> name>> ] dip "%s.%s" sprintf ; + + \ No newline at end of file diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor index 3a8cb09292..16e408d78e 100644 --- a/mongodb/tuple/tuple.factor +++ b/mongodb/tuple/tuple.factor @@ -1,16 +1,85 @@ USING: accessors assocs classes classes.mixin classes.tuple vectors math classes.tuple.parser formatting generalizations kernel sequences fry -prettyprint strings compiler.units slots tools.walker words arrays -mongodb.collection mongodb.persistent ; +prettyprint strings compiler.units slots tools.walker words arrays mongodb.persistent ; IN: mongodb.tuple -> ( tuple -- string ) +GENERIC: mdb-collection>> ( object -- mdb-collection ) + +CONSTANT: MDB_COLLECTIONS "mdb_collections" +CONSTANT: MDB_COL_PROP "mdb_collection" CONSTANT: MDB_SLOTOPT_PROP "mdb_slot_options" + +SLOT: _id CONSTANT: MDB_P_SLOTS { "_id" } CONSTANT: MDB_OID "_id" +SYMBOLS: +transient+ +load+ ; + +UNION: boolean t POSTPONE: f ; + +TUPLE: mdb-collection + { name string } + { capped boolean initial: f } + { size integer initial: -1 } + { max integer initial: -1 } + { classes sequence } ; + +>) ( class -- mdb-collection ) + dup props>> [ MDB_COL_PROP ] dip at + [ [ drop ] dip ] + [ superclass [ (mdb-collection>>) ] [ f ] if* ] if* ; inline recursive + +: (mdb-slot-definitions>>) ( class -- slot-defs ) + superclasses [ MDB_SLOTOPT_PROP word-prop ] map assoc-combine ; inline + +: link-class ( class collection -- ) + tuck classes>> ! col class v{} + [ 2dup member? [ 2drop ] [ push ] if ] + [ 1vector >>classes ] if* drop ; + +PRIVATE> + +M: tuple-class mdb-collection>> ( tuple -- mdb-collection ) + (mdb-collection>>) ; + +M: mdb-persistent mdb-collection>> ( tuple -- mdb-collection ) + class (mdb-collection>>) ; + +M: mdb-persistent mdb-slot-definitions>> ( tuple -- string ) + class (mdb-slot-definitions>>) ; + +M: tuple-class mdb-slot-definitions>> ( class -- assoc ) + (mdb-slot-definitions>>) ; + +M: mdb-collection mdb-slot-definitions>> ( collection -- assoc ) + classes>> [ mdb-slot-definitions>> ] map assoc-combine ; + +: link-collection ( class collection -- ) + 2dup link-class + swap [ MDB_COL_PROP ] dip props>> set-at ; inline + +: declared-collections> ( -- assoc ) + MDB_COLLECTIONS mdb-persistent props>> at + [ H{ } clone + [ MDB_COLLECTIONS mdb-persistent props>> set-at ] keep + ] unless* ; + +: ( name -- mdb-collection ) + declared-collections> 2dup key? + [ at ] + [ [ mdb-collection new ] 2dip + [ [ >>name dup ] keep ] dip set-at ] if ; + +> ] map [ MDB_OID ] dip memq? @@ -42,10 +111,6 @@ M: assoc mdb-persisted? ( assoc -- ? ) : split-olist ( seq -- key options ) [ first ] [ rest ] bi ; inline -: link-class ( class collection -- ) - tuck classes>> ! col class v{} - [ 2dup member? [ 2drop ] [ push ] if ] - [ 1vector >>classes ] if* drop ; : optl>assoc ( seq -- assoc ) [ dup assoc? From fa8aa747b9b49b1bdaddb336ced35cc743c22c4d Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 28 Jan 2009 21:11:45 +0100 Subject: [PATCH 022/772] added mongo message monitor in factor... fixed some things, unified read/write message --- mongodb/connection/connection.factor | 2 +- mongodb/index/index.factor | 5 +- mongodb/mmm/mmm.factor | 90 ++++++++++++++++++++++ mongodb/mongodb.factor | 2 +- mongodb/msg/msg.factor | 111 ++++++++++++++++++--------- mongodb/query/query.factor | 2 +- 6 files changed, 169 insertions(+), 43 deletions(-) create mode 100644 mongodb/mmm/mmm.factor diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor index 2a7e04f504..569a68aa3b 100644 --- a/mongodb/connection/connection.factor +++ b/mongodb/connection/connection.factor @@ -23,7 +23,7 @@ TUPLE: mdb name nodes collections ; : ismaster-cmd ( node -- result ) binary "admin.$cmd" H{ { "ismaster" 1 } } - '[ _ write-request read-reply ] with-client + '[ _ write-message read-message ] with-client objects>> first ; : -push ( seq elt -- ) diff --git a/mongodb/index/index.factor b/mongodb/index/index.factor index bb930e02d2..487251c27f 100644 --- a/mongodb/index/index.factor +++ b/mongodb/index/index.factor @@ -25,7 +25,6 @@ SYMBOLS: +fieldindex+ +compoundindex+ +deepindex+ ; "%s-%s-%s-Idx" sprintf ; : build-index ( element slot -- assoc ) - break swap [ ] 2dip [ rest ] keep first ! assoc slot options itype { { +fieldindex+ [ drop [ 1 ] dip pick set-at ] } @@ -70,7 +69,7 @@ USE: mongodb.query : load-indices ( mdb-collection -- indexlist ) [ mdb>> name>> ] dip name>> "%s.%s" sprintf "ns" H{ } clone [ set-at ] keep [ mdb>> name>> index-ns ] dip - '[ _ write-request read-reply ] + '[ _ write-message read-message ] [ mdb>> master>> binary ] dip with-client objects>> [ [ index new ] dip [ [ "ns" ] dip at >>ns ] @@ -96,7 +95,7 @@ USE: mongodb.query dup length 0 > [ [ mdb>> name>> "%s.system.indexes" sprintf ] dip - [ mdb>> master>> binary ] dip '[ _ write-request ] with-client + [ mdb>> master>> binary ] dip '[ _ write-message ] with-client ] [ drop ] if ; diff --git a/mongodb/mmm/mmm.factor b/mongodb/mmm/mmm.factor new file mode 100644 index 0000000000..93281f4134 --- /dev/null +++ b/mongodb/mmm/mmm.factor @@ -0,0 +1,90 @@ +USING: accessors fry io io.encodings.binary io.servers.connection +io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting +mongodb.msg.private namespaces prettyprint tools.walker calendar calendar.format ; + +IN: mongodb.mmm + +SYMBOLS: mmm-port mmm-server-ip mmm-server-port mmm-server mmm-dump-output mmm-t-srv ; + +GENERIC: dump-message ( message -- ) + +: check-options ( -- ) + mmm-port get [ 27040 mmm-port set ] unless + mmm-server-ip get [ "127.0.0.1" mmm-server-ip set ] unless + mmm-server-port get [ 27017 mmm-server-port set ] unless + mmm-server-ip get mmm-server-port get mmm-server set ; + +: read-msg-binary ( -- ) + read-int32 + [ write-int32 ] keep + 4 - read write ; + +: read-request-header ( -- msg-stub ) + mdb-msg new + read-int32 MSG-HEADER-SIZE - >>length + read-int32 >>req-id + read-int32 >>resp-id + read-int32 >>opcode ; + +: read-request ( -- msg-stub binary ) + binary [ read-msg-binary ] with-byte-writer + [ binary [ read-request-header ] with-byte-reader ] keep ; ! msg-stub binary + +: dump-request ( msg-stub binary -- ) + [ mmm-dump-output get ] 2dip + '[ _ drop _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ; + +: read-reply ( -- binary ) + binary [ read-msg-binary ] with-byte-writer ; + +: forward-request-read-reply ( msg-stub binary -- binary ) + [ mmm-server get binary ] 2dip + '[ _ opcode>> _ write flush + OP_Query = + [ read-reply ] + [ f ] if ] with-client ; + +: dump-reply ( binary -- ) + [ mmm-dump-output get ] dip + '[ _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ; + +: message-prefix ( message -- tst name message ) + [ now timestamp>http-string ] dip + [ class name>> ] keep ; inline + +M: mdb-query-msg dump-message ( message -- ) + message-prefix + collection>> + "%s: %s -> %s \n" printf ; + +M: mdb-insert-msg dump-message ( message -- ) + message-prefix + collection>> + "%s: %s -> %s \n" printf ; + +M: mdb-msg dump-message ( message -- ) + message-prefix drop "%s: %s \n" printf ; + +: forward-reply ( binary -- ) + write flush ; + +: handle-mmm-connection ( -- ) + read-request + [ dump-request ] 2keep + forward-request-read-reply + [ dump-reply ] keep + forward-reply ; + +: start-mmm-server ( -- ) + output-stream get mmm-dump-output set + [ mmm-t-srv set ] keep + "127.0.0.1" mmm-port get >>insecure + binary >>encoding + [ handle-mmm-connection ] >>handler + start-server* ; + +: run-mmm ( -- ) + check-options + start-mmm-server ; + +MAIN: run-mmm \ No newline at end of file diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor index a1cd3d7aff..96800d3d87 100644 --- a/mongodb/mongodb.factor +++ b/mongodb/mongodb.factor @@ -27,7 +27,7 @@ M: mdb-persistent store ( tuple -- ) prepare-store ! H { collection { ... values ... } [ [ get-collection-fqn ] dip values - [ mdb>> master>> binary ] dip '[ _ write-request ] with-client + [ mdb>> master>> binary ] dip '[ _ write-message ] with-client ] assoc-each ; M: mdb-persistent find ( example -- result ) diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index e61006e01b..88d2421ce3 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -15,32 +15,39 @@ CONSTANT: OP_GetMore 2005 CONSTANT: OP_Delete 2006 CONSTANT: OP_KillCursors 2007 +PREDICATE: mdb-reply-op < integer OP_Reply = ; +PREDICATE: mdb-query-op < integer OP_Query = ; +PREDICATE: mdb-insert-op < integer OP_Insert = ; +PREDICATE: mdb-delete-op < integer OP_Delete = ; +PREDICATE: mdb-getmore-op < integer OP_GetMore = ; +PREDICATE: mdb-killcursors-op < integer OP_KillCursors = ; + PRIVATE> TUPLE: mdb-msg - { opcode integer } - { req-id integer initial: 0 } - { resp-id integer initial: 0 } - { length integer initial: 0 } ; +{ opcode integer } +{ req-id integer initial: 0 } +{ resp-id integer initial: 0 } +{ length integer initial: 0 } +{ flags integer initial: 0 } ; TUPLE: mdb-insert-msg < mdb-msg - { collection string } - { objects sequence } ; +{ collection string } +{ objects sequence } ; TUPLE: mdb-query-msg < mdb-msg - { collection string } - { skip# integer initial: 0 } - { return# integer initial: 0 } - { query assoc } - { returnfields assoc } - { orderby sequence } ; +{ collection string } +{ skip# integer initial: 0 } +{ return# integer initial: 0 } +{ query assoc } +{ returnfields assoc } +{ orderby sequence } ; TUPLE: mdb-reply-msg < mdb-msg - { flags integer initial: 0 } - { cursor integer initial: 0 } - { start# integer initial: 0 } - { returned# integer initial: 0 } - { objects sequence } ; +{ cursor integer initial: 0 } +{ start# integer initial: 0 } +{ returned# integer initial: 0 } +{ objects sequence } ; : ( collection assoc -- mdb-query-msg ) @@ -68,8 +75,7 @@ M: sequence ( collection sequence -- mdb-insert-msg ) : ( -- mdb-reply-msg ) mdb-reply-msg new ; inline - -GENERIC: write-request ( message -- ) +GENERIC: write-message ( message -- ) string ; inline -PRIVATE> +GENERIC: (read-message) ( message opcode -- message ) -: read-reply-header ( message -- message ) +: copy-header ( message msg-stub -- message ) + [ length>> ] keep [ >>length ] dip + [ req-id>> ] keep [ >>req-id ] dip + [ resp-id>> ] keep [ >>resp-id ] dip + [ opcode>> ] keep [ >>opcode ] dip + flags>> >>flags ; + +M: mdb-query-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-query-msg new ] dip copy-header + read-cstring >>collection + read-int32 >>skip# + read-int32 >>return# + H{ } stream>assoc >>query ; + +M: mdb-insert-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-insert-msg new ] dip copy-header + read-cstring >>collection + H{ } stream>assoc >>objects ; + +M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) + drop + [ ] dip copy-header + read-longlong >>cursor + read-int32 >>start# + read-int32 [ >>returned# ] keep + [ H{ } stream>assoc ] accumulator [ times ] dip >>objects ; + +: read-header ( message -- message ) read-int32 >>length read-int32 >>req-id read-int32 >>resp-id - read-int32 >>opcode ; inline + read-int32 >>opcode + read-int32 >>flags ; inline -: read-reply-message ( message -- message ) - read-int32 >>flags read-longlong >>cursor - read-int32 >>start# read-int32 tuck >>returned# swap - [ H{ } stream>assoc ] accumulator [ times ] dip >>objects ; inline - -: read-reply ( -- message ) - - read-reply-header - read-reply-message ; inline - -: write-request-header ( message length -- ) +: write-header ( message length -- ) MSG-HEADER-SIZE + write-int32 [ req-id>> write-int32 ] keep [ resp-id>> write-int32 ] keep opcode>> write-int32 ; inline +PRIVATE> + +: read-message ( -- message ) + mdb-msg new + read-header + [ ] [ opcode>> ] bi (read-message) ; + + + +M: mdb-query-msg write-message ( message -- ) dup '[ _ [ 4 write-int32 ] dip @@ -134,8 +171,8 @@ M: mdb-query-msg write-request ( message -- ) [ return#>> write-int32 ] keep query>> assoc>array write ] (write-message) ; - -M: mdb-insert-msg write-request ( message -- ) + +M: mdb-insert-msg write-message ( message -- ) dup '[ _ [ 0 write-int32 ] dip diff --git a/mongodb/query/query.factor b/mongodb/query/query.factor index aede6a267f..c3477d2678 100644 --- a/mongodb/query/query.factor +++ b/mongodb/query/query.factor @@ -20,7 +20,7 @@ TUPLE: mdb-result { cursor integer } PRIVATE> : (find) ( inet query -- result ) - '[ _ write-request read-reply ] (execute-query) ; inline + '[ _ write-message read-message ] (execute-query) ; inline : (find-one) ( inet query -- result ) (find) objects>> first ; inline From f588143082c2dac93320647291bf51c9f6d277e5 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 29 Jan 2009 13:47:33 +0100 Subject: [PATCH 023/772] changed stream>assoc to return the amount of bytes read from the stream --- bson/reader/reader.factor | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index 5aebb4bcee..348a25b732 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -194,13 +194,7 @@ M: bson-binary-function element-binary-read ( size type -- quot ) PRIVATE> -: stream>assoc ( exemplar -- assoc ) +: stream>assoc ( exemplar -- assoc bytes-read ) dup state - [ read-int32 >>size read-elements ] with-variable - result>> ; - -: array>assoc ( array exemplar -- assoc ) - [ binary ] dip '[ _ stream>assoc ] with-byte-reader ; - -: array>hashtable ( array -- assoc ) - H{ } array>assoc ; + [ read-int32 >>size read-elements ] with-variable + [ result>> ] [ read>> ] bi ; From 0cbd1ed207aef7d795e8c45887af593033775fa6 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 29 Jan 2009 13:48:22 +0100 Subject: [PATCH 024/772] rewrote check-nodes --- mongodb/connection/connection.factor | 29 +++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor index 569a68aa3b..c32a183c40 100644 --- a/mongodb/connection/connection.factor +++ b/mongodb/connection/connection.factor @@ -26,24 +26,27 @@ TUPLE: mdb name nodes collections ; '[ _ write-message read-message ] with-client objects>> first ; -: -push ( seq elt -- ) - swap push ; inline - : split-host-str ( hoststr -- host port ) ":" split [ first ] keep second string>number ; inline +: eval-ismaster-result ( node result -- node result ) + [ [ "ismaster" ] dip at + >fixnum 1 = + [ t >>master? ] [ f >>master? ] if ] keep ; + +: check-node ( node -- node remote ) + dup inet>> ismaster-cmd + eval-ismaster-result + [ "remote" ] dip at ; + : check-nodes ( node -- nodelist ) - [ V{ } clone ] dip - [ -push ] 2keep - dup inet>> ismaster-cmd ! vec node result - dup [ "ismaster" ] dip at - >fixnum 1 = ! vec node result - [ [ t >>master? drop ] dip f ] - [ [ f >>master? drop ] dip t ] if - [ "remote" ] 2dip [ at split-host-str ] dip - swap mdb-node boa swap - [ push ] keep ; + check-node + [ V{ } clone [ push ] keep ] dip + [ split-host-str [ f ] dip + mdb-node boa check-node drop + swap tuck push + ] when* ; : verify-nodes ( -- ) mdb>> nodes>> [ t ] dip at From eb00f33fa8a034c74e113b712f01071b400ad5df Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 29 Jan 2009 13:49:18 +0100 Subject: [PATCH 025/772] removed findOne words, added new word nfind ( example n -- result ) which limits the number of results returned to n --- mongodb/mongodb.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor index 96800d3d87..1d5d7f3693 100644 --- a/mongodb/mongodb.factor +++ b/mongodb/mongodb.factor @@ -8,7 +8,7 @@ IN: mongodb ! generic methods GENERIC: store ( tuple/ht -- ) GENERIC: find ( example -- tuple/ht ) -GENERIC: findOne ( exampe -- tuple/ht ) +GENERIC# nfind 1 ( example n -- tuple/ht ) GENERIC: load ( object -- object ) > master>> ] dip (find) build-result ; -M: mdb-persistent findOne ( example -- result ) - prepare-find [ mdb>> master>> ] dip (find-one) - dup returned#>> 1 = - [ objects>> first ] - [ drop f ] if ; +M: mdb-persistent nfind ( example n -- result ) + [ prepare-find ] dip >>return# + [ mdb>> master>> ] dip (find) + build-result ; + From 399838b960fcf51219e242802163d0cba98e04dd Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 29 Jan 2009 13:50:42 +0100 Subject: [PATCH 026/772] rewrote low-level (find-one) word as wrapper around (find) --- mongodb/query/query.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/mongodb/query/query.factor b/mongodb/query/query.factor index c3477d2678..ca3b059537 100644 --- a/mongodb/query/query.factor +++ b/mongodb/query/query.factor @@ -23,7 +23,8 @@ PRIVATE> '[ _ write-message read-message ] (execute-query) ; inline : (find-one) ( inet query -- result ) - (find) objects>> first ; inline + 1 >>return# + (find) ; inline : build-result ( resultmsg -- mdb-result ) [ mdb-result new ] dip @@ -48,7 +49,7 @@ PRIVATE> : create-collection ( mdb-collection -- ) dup name>> "create" H{ } clone [ set-at ] keep [ mdb>> [ master>> ] [ name>> ] bi "%s.$cmd" sprintf ] dip - (find-one) + (find-one) objects>> first check-ok [ [ ensure-indices ] keep dup name>> mdb>> collections>> set-at ] [ "could not create collection" throw ] if ; From e5ba1d2509ded297a85a682cc794b061730ea7e6 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 29 Jan 2009 13:51:51 +0100 Subject: [PATCH 027/772] fixed reading of multiple bson objects in one message (tracking bytes read and comparing with overall message size) --- mongodb/msg/msg.factor | 46 ++++++++++++++++++++++++++++++------------ 1 file changed, 33 insertions(+), 13 deletions(-) diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index 88d2421ce3..f99e4cad2b 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -1,6 +1,6 @@ USING: io io.encodings.utf8 io.encodings.binary alien.c-types alien.strings math bson.writer sequences kernel accessors io.streams.byte-array fry generalizations -combinators bson.reader sequences tools.walker assocs strings linked-assocs ; +combinators bson.reader sequences tools.walker assocs strings linked-assocs namespaces ; IN: mongodb.msg @@ -81,15 +81,26 @@ GENERIC: write-message ( message -- ) CONSTANT: MSG-HEADER-SIZE 16 +SYMBOL: msg-bytes-read + +: bytes-read> ( -- integer ) + msg-bytes-read get ; inline + +: >bytes-read ( integer -- ) + msg-bytes-read set ; inline + +: change-bytes-read ( integer -- ) + bytes-read> [ 0 ] unless* + >bytes-read ; inline + : write-byte ( byte -- ) write ; inline : write-int32 ( int -- ) write ; inline : write-double ( real -- ) write ; inline : write-cstring ( string -- ) utf8 string>alien write ; inline : write-longlong ( object -- ) write ; inline -: read-int32 ( -- int32 ) 4 read *int ; inline -: read-longlong ( -- longlong ) 8 read *longlong ; inline -: read-byte-raw ( -- byte-raw ) 1 read ; inline +: read-int32 ( -- int32 ) 4 [ read *int ] [ change-bytes-read ] bi ; inline +: read-longlong ( -- longlong ) 8 [ read *longlong ] [ change-bytes-read ] bi ; inline +: read-byte-raw ( -- byte-raw ) 1 [ read ] [ change-bytes-read ] bi ; inline : read-byte ( -- byte ) read-byte-raw *char ; inline : (read-cstring) ( acc -- acc ) @@ -117,13 +128,21 @@ M: mdb-query-op (read-message) ( msg-stub opcode -- message ) read-cstring >>collection read-int32 >>skip# read-int32 >>return# - H{ } stream>assoc >>query ; + H{ } stream>assoc change-bytes-read >>query ! message length + dup length>> bytes-read> > + [ H{ } stream>assoc change-bytes-read >>returnfields + dup length>> bytes-read> > + [ H{ } stream>assoc drop >>orderby ] when + ] when ; M: mdb-insert-op (read-message) ( msg-stub opcode -- message ) drop [ mdb-insert-msg new ] dip copy-header read-cstring >>collection - H{ } stream>assoc >>objects ; + V{ } clone >>objects + [ '[ _ length>> bytes-read> > ] ] keep tuck + '[ H{ } stream>assoc change-bytes-read _ objects>> push ] + [ ] while ; M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) drop @@ -131,7 +150,7 @@ M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) read-longlong >>cursor read-int32 >>start# read-int32 [ >>returned# ] keep - [ H{ } stream>assoc ] accumulator [ times ] dip >>objects ; + [ H{ } stream>assoc drop ] accumulator [ times ] dip >>objects ; : read-header ( message -- message ) read-int32 >>length @@ -150,6 +169,7 @@ PRIVATE> : read-message ( -- message ) mdb-msg new + 0 >bytes-read read-header [ ] [ opcode>> ] bi (read-message) ; @@ -173,10 +193,10 @@ M: mdb-query-msg write-message ( message -- ) ] (write-message) ; M: mdb-insert-msg write-message ( message -- ) - dup - '[ _ - [ 0 write-int32 ] dip - [ collection>> write-cstring ] keep - objects>> [ assoc>array write ] each - ] (write-message) ; + dup + '[ _ + [ 0 write-int32 ] dip + [ collection>> write-cstring ] keep + objects>> [ assoc>array write ] each + ] (write-message) ; From 050b77d44c6d79ad9dec045753a854142491518e Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 29 Jan 2009 13:52:37 +0100 Subject: [PATCH 028/772] nicer output --- mongodb/mmm/mmm.factor | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/mongodb/mmm/mmm.factor b/mongodb/mmm/mmm.factor index 93281f4134..ce942ce67b 100644 --- a/mongodb/mmm/mmm.factor +++ b/mongodb/mmm/mmm.factor @@ -1,6 +1,7 @@ USING: accessors fry io io.encodings.binary io.servers.connection io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting -mongodb.msg.private namespaces prettyprint tools.walker calendar calendar.format ; +mongodb.msg.private namespaces prettyprint tools.walker calendar calendar.format +json.writer ; IN: mongodb.mmm @@ -48,22 +49,33 @@ GENERIC: dump-message ( message -- ) [ mmm-dump-output get ] dip '[ _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ; -: message-prefix ( message -- tst name message ) +: message-prefix ( message -- prefix message ) [ now timestamp>http-string ] dip - [ class name>> ] keep ; inline + [ class name>> ] keep + [ "%s: %s" sprintf ] dip ; inline M: mdb-query-msg dump-message ( message -- ) message-prefix - collection>> - "%s: %s -> %s \n" printf ; + [ collection>> ] keep + query>> >json + "%s -> %s: %s \n" printf ; M: mdb-insert-msg dump-message ( message -- ) message-prefix - collection>> - "%s: %s -> %s \n" printf ; + [ collection>> ] keep + objects>> >json + "%s -> %s : %s \n" printf ; + +M: mdb-reply-msg dump-message ( message -- ) + message-prefix + [ cursor>> ] keep + [ start#>> ] keep + [ returned#>> ] keep + objects>> >json + "%s -> cursor: %d, start: %d, returned#: %d, -> %s \n" printf ; M: mdb-msg dump-message ( message -- ) - message-prefix drop "%s: %s \n" printf ; + message-prefix drop "%s \n" printf ; : forward-reply ( binary -- ) write flush ; From aa77fdd4e514d37f543d9df300012ecbad20089f Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 30 Jan 2009 12:23:05 +0100 Subject: [PATCH 029/772] removed unused vocab --- bson/reader/reader.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index 348a25b732..d7b6bfef74 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -1,4 +1,4 @@ -USING: mirrors io io.encodings.utf8 io.encodings.binary math match kernel sequences +USING: mirrors io io.encodings.utf8 io.encodings.binary math kernel sequences splitting accessors io.streams.byte-array namespaces prettyprint bson.constants assocs alien.c-types alien.strings fry words serialize byte-arrays ; From 7179e2f84b89e93c8a52a9e4801be04d42a5d714 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 30 Jan 2009 12:23:35 +0100 Subject: [PATCH 030/772] added missing messages: killcursors, getmore, delete --- mongodb/msg/msg.factor | 86 ++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 82 insertions(+), 4 deletions(-) diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index f99e4cad2b..a13b6bdea2 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -35,6 +35,19 @@ TUPLE: mdb-insert-msg < mdb-msg { collection string } { objects sequence } ; +TUPLE: mdb-delete-msg < mdb-msg +{ collection string } +{ selector assoc } ; + +TUPLE: mdb-getmore-msg < mdb-msg +{ collection string } +{ return# integer initial: 0 } +{ cursor integer initial: 0 } ; + +TUPLE: mdb-killcursors-msg < mdb-msg +{ cursors# integer initial: 0 } +{ cursors sequence } ; + TUPLE: mdb-query-msg < mdb-msg { collection string } { skip# integer initial: 0 } @@ -50,11 +63,31 @@ TUPLE: mdb-reply-msg < mdb-msg { objects sequence } ; +: ( collection return# -- mdb-getmore-msg ) + [ mdb-getmore-msg new ] 2dip + [ >>collection ] dip + >>return# OP_GetMore >>opcode ; inline + +: ( collection assoc -- mdb-delete-msg ) + [ mdb-delete-msg new ] 2dip + [ >>collection ] dip + >>selector OP_Delete >>opcode ; inline + : ( collection assoc -- mdb-query-msg ) [ mdb-query-msg new ] 2dip [ >>collection ] dip >>query OP_Query >>opcode ; inline +GENERIC: ( object -- mdb-killcursors-msg ) + +M: sequence ( sequences -- mdb-killcursors-msg ) + [ mdb-killcursors-msg new ] dip + [ length >>cursors# ] keep + >>cursors OP_KillCursors >>opcode ; inline + +M: integer ( integer -- mdb-killcursors-msg ) + V{ } clone [ push ] keep ; + : ( collection assoc -- mdb-query-msg ) 1 >>return# ; inline @@ -71,7 +104,6 @@ M: sequence ( collection sequence -- mdb-insert-msg ) [ >>collection ] dip >>objects OP_Insert >>opcode ; - : ( -- mdb-reply-msg ) mdb-reply-msg new ; inline @@ -128,7 +160,7 @@ M: mdb-query-op (read-message) ( msg-stub opcode -- message ) read-cstring >>collection read-int32 >>skip# read-int32 >>return# - H{ } stream>assoc change-bytes-read >>query ! message length + H{ } stream>assoc change-bytes-read >>query dup length>> bytes-read> > [ H{ } stream>assoc change-bytes-read >>returnfields dup length>> bytes-read> > @@ -144,6 +176,27 @@ M: mdb-insert-op (read-message) ( msg-stub opcode -- message ) '[ H{ } stream>assoc change-bytes-read _ objects>> push ] [ ] while ; +M: mdb-delete-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-delete-msg new ] dip copy-header + read-cstring >>collection + H{ } stream>assoc change-bytes-read >>selector ; + +M: mdb-getmore-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-getmore-msg new ] dip copy-header + read-cstring >>collection + read-int32 >>return# + read-longlong >>cursor ; + +M: mdb-killcursors-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-killcursors-msg new ] dip copy-header + read-int32 >>cursors# + V{ } clone >>cursors + [ [ cursors#>> ] keep + '[ read-longlong _ cursors>> push ] times ] keep ; + M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) drop [ ] dip copy-header @@ -185,7 +238,7 @@ PRIVATE> M: mdb-query-msg write-message ( message -- ) dup '[ _ - [ 4 write-int32 ] dip + [ flags>> write-int32 ] keep [ collection>> write-cstring ] keep [ skip#>> write-int32 ] keep [ return#>> write-int32 ] keep @@ -195,8 +248,33 @@ M: mdb-query-msg write-message ( message -- ) M: mdb-insert-msg write-message ( message -- ) dup '[ _ - [ 0 write-int32 ] dip + [ flags>> write-int32 ] keep [ collection>> write-cstring ] keep objects>> [ assoc>array write ] each ] (write-message) ; +M: mdb-delete-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ collection>> write-cstring ] keep + 0 write-int32 + selector>> assoc>array write + ] (write-message) ; + +M: mdb-getmore-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ collection>> write-cstring ] keep + [ return#>> write-int32 ] keep + cursor>> write-longlong + ] (write-message) ; + +M: mdb-killcursors-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ cursors#>> write-int32 ] keep + cursors>> [ write-longlong ] each + ] (write-message) ; \ No newline at end of file From af9f0f32df0f1f5e0cad95b85d9c4982308c9819 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 30 Jan 2009 12:51:46 +0100 Subject: [PATCH 031/772] added update message --- mongodb/msg/msg.factor | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index a13b6bdea2..6610b15893 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -18,6 +18,7 @@ CONSTANT: OP_KillCursors 2007 PREDICATE: mdb-reply-op < integer OP_Reply = ; PREDICATE: mdb-query-op < integer OP_Query = ; PREDICATE: mdb-insert-op < integer OP_Insert = ; +PREDICATE: mdb-update-op < integer OP_Update = ; PREDICATE: mdb-delete-op < integer OP_Delete = ; PREDICATE: mdb-getmore-op < integer OP_GetMore = ; PREDICATE: mdb-killcursors-op < integer OP_KillCursors = ; @@ -35,6 +36,12 @@ TUPLE: mdb-insert-msg < mdb-msg { collection string } { objects sequence } ; +TUPLE: mdb-update-msg < mdb-msg +{ collection string } +{ upsert? integer initial: 1 } +{ selector assoc } +{ object assoc } ; + TUPLE: mdb-delete-msg < mdb-msg { collection string } { selector assoc } ; @@ -104,6 +111,12 @@ M: sequence ( collection sequence -- mdb-insert-msg ) [ >>collection ] dip >>objects OP_Insert >>opcode ; +: ( collection object -- mdb-update-msg ) + [ mdb-update-msg new ] 2dip + [ >>collection ] dip + [ [ "_id" ] dip at "_id" H{ } clone [ set-at ] keep >>selector ] keep + >>object OP_Update >>opcode ; + : ( -- mdb-reply-msg ) mdb-reply-msg new ; inline @@ -197,6 +210,14 @@ M: mdb-killcursors-op (read-message) ( msg-stub opcode -- message ) [ [ cursors#>> ] keep '[ read-longlong _ cursors>> push ] times ] keep ; +M: mdb-update-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-update-msg new ] dip copy-header + read-cstring >>collection + read-int32 >>upsert? + H{ } stream>assoc change-bytes-read >>selector + H{ } stream>assoc change-bytes-read >>object ; + M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) drop [ ] dip copy-header @@ -253,6 +274,16 @@ M: mdb-insert-msg write-message ( message -- ) objects>> [ assoc>array write ] each ] (write-message) ; +M: mdb-update-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ collection>> write-cstring ] keep + [ upsert?>> write-int32 ] keep + [ selector>> assoc>array write ] keep + object>> assoc>array write + ] (write-message) ; + M: mdb-delete-msg write-message ( message -- ) dup '[ _ From 9838b6fee1411eff4d28768dcd01105c0f97079d Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 31 Jan 2009 11:51:30 +0100 Subject: [PATCH 032/772] reworked reading of cstrings (using BV{ } now) - not sure about using read-until --- bson/reader/reader.factor | 17 +++++++++-------- mongodb/msg/msg.factor | 20 +++++++++++--------- 2 files changed, 20 insertions(+), 17 deletions(-) diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index d7b6bfef74..d8b5e2b44a 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -1,7 +1,7 @@ USING: mirrors io io.encodings.utf8 io.encodings.binary math kernel sequences splitting accessors io.streams.byte-array namespaces prettyprint bson.constants assocs alien.c-types alien.strings fry words - serialize byte-arrays ; + serialize byte-arrays byte-vectors ; IN: bson.reader @@ -60,15 +60,16 @@ GENERIC: element-binary-read ( length type -- object ) : read-byte ( -- byte ) read-byte-raw *char ; inline -: (read-cstring) ( acc -- acc ) - read-byte-raw dup - B{ 0 } = - [ append ] - [ append (read-cstring) ] if ; inline recursive +: (read-cstring) ( acc -- ) + [ read-byte-raw first ] dip ! b acc + 2dup push ! b acc + [ 0 = ] dip ! bool acc + '[ _ (read-cstring) ] unless ; inline recursive : read-cstring ( -- string ) - B{ } clone - (read-cstring) utf8 alien>string ; inline + BV{ } clone + [ (read-cstring) ] keep + >byte-array utf8 alien>string ; inline : read-sized-string ( length -- string ) [ read ] [ count-bytes ] bi diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index 6610b15893..666250b45e 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -1,6 +1,7 @@ USING: io io.encodings.utf8 io.encodings.binary alien.c-types alien.strings math bson.writer sequences kernel accessors io.streams.byte-array fry generalizations -combinators bson.reader sequences tools.walker assocs strings linked-assocs namespaces ; +combinators bson.reader sequences tools.walker assocs strings linked-assocs namespaces +byte-vectors byte-arrays ; IN: mongodb.msg @@ -146,17 +147,18 @@ SYMBOL: msg-bytes-read : read-int32 ( -- int32 ) 4 [ read *int ] [ change-bytes-read ] bi ; inline : read-longlong ( -- longlong ) 8 [ read *longlong ] [ change-bytes-read ] bi ; inline : read-byte-raw ( -- byte-raw ) 1 [ read ] [ change-bytes-read ] bi ; inline -: read-byte ( -- byte ) read-byte-raw *char ; inline +: read-byte ( -- byte ) read-byte-raw first ; inline -: (read-cstring) ( acc -- acc ) - read-byte-raw dup - B{ 0 } = - [ append ] - [ append (read-cstring) ] if ; recursive inline +: (read-cstring) ( acc -- ) + [ read-byte ] dip ! b acc + 2dup push ! b acc + [ 0 = ] dip ! bool acc + '[ _ (read-cstring) ] unless ; inline recursive : read-cstring ( -- string ) - B{ } clone - (read-cstring) utf8 alien>string ; inline + BV{ } clone + [ (read-cstring) ] keep + >byte-array utf8 alien>string ; inline GENERIC: (read-message) ( message opcode -- message ) From 5dacbdaace2803a2712de70598e27ac62f139b8f Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 31 Jan 2009 16:04:19 +0100 Subject: [PATCH 033/772] rewrote (write-message) --- mongodb/msg/msg.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index 666250b45e..c3b124568d 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -252,8 +252,8 @@ PRIVATE> From bd6be4fe27a14ce9cef841c78553d68746ffc255 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 31 Jan 2009 16:05:21 +0100 Subject: [PATCH 034/772] using CONSTRUCTOR: for non-generic tuple constructors --- mongodb/msg/msg.factor | 40 ++++++++++++++-------------------------- 1 file changed, 14 insertions(+), 26 deletions(-) diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index c3b124568d..3b0db0a08f 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -1,7 +1,7 @@ -USING: io io.encodings.utf8 io.encodings.binary alien.c-types alien.strings math -bson.writer sequences kernel accessors io.streams.byte-array fry generalizations -combinators bson.reader sequences tools.walker assocs strings linked-assocs namespaces -byte-vectors byte-arrays ; +USING: accessors alien.c-types alien.strings assocs bson.reader +bson.writer byte-arrays byte-vectors constructors fry io +io.encodings.binary io.encodings.utf8 io.streams.byte-array kernel +linked-assocs math namespaces sequences strings ; IN: mongodb.msg @@ -71,20 +71,14 @@ TUPLE: mdb-reply-msg < mdb-msg { objects sequence } ; -: ( collection return# -- mdb-getmore-msg ) - [ mdb-getmore-msg new ] 2dip - [ >>collection ] dip - >>return# OP_GetMore >>opcode ; inline +CONSTRUCTOR: mdb-getmore-msg ( collection return# -- mdb-getmore-msg ) + OP_GetMore >>opcode ; inline -: ( collection assoc -- mdb-delete-msg ) - [ mdb-delete-msg new ] 2dip - [ >>collection ] dip - >>selector OP_Delete >>opcode ; inline +CONSTRUCTOR: mdb-delete-msg ( collection selector -- mdb-delete-msg ) + OP_Delete >>opcode ; inline -: ( collection assoc -- mdb-query-msg ) - [ mdb-query-msg new ] 2dip - [ >>collection ] dip - >>query OP_Query >>opcode ; inline +CONSTRUCTOR: mdb-query-msg ( collection query -- mdb-query-msg ) + OP_Query >>opcode ; inline GENERIC: ( object -- mdb-killcursors-msg ) @@ -96,9 +90,6 @@ M: sequence ( sequences -- mdb-killcursors-msg ) M: integer ( integer -- mdb-killcursors-msg ) V{ } clone [ push ] keep ; -: ( collection assoc -- mdb-query-msg ) - 1 >>return# ; inline - GENERIC# 1 ( collection objects -- mdb-insert-msg ) M: linked-assoc ( collection linked-assoc -- mdb-insert-msg ) @@ -112,14 +103,11 @@ M: sequence ( collection sequence -- mdb-insert-msg ) [ >>collection ] dip >>objects OP_Insert >>opcode ; -: ( collection object -- mdb-update-msg ) - [ mdb-update-msg new ] 2dip - [ >>collection ] dip - [ [ "_id" ] dip at "_id" H{ } clone [ set-at ] keep >>selector ] keep - >>object OP_Update >>opcode ; +CONSTRUCTOR: mdb-update-msg ( collection object -- mdb-update-msg ) + dup object>> [ "_id" ] dip at "_id" H{ } clone [ set-at ] keep >>selector + OP_Update >>opcode ; -: ( -- mdb-reply-msg ) - mdb-reply-msg new ; inline +CONSTRUCTOR: mdb-reply-msg ( -- mdb-reply-msg ) ; inline GENERIC: write-message ( message -- ) From 0e2b60bf89c7936845028d9bc585b7c1ccb426bd Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 31 Jan 2009 16:06:49 +0100 Subject: [PATCH 035/772] fixed ismastercmd --- mongodb/connection/connection.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor index c32a183c40..6e608dcb63 100644 --- a/mongodb/connection/connection.factor +++ b/mongodb/connection/connection.factor @@ -22,8 +22,8 @@ TUPLE: mdb name nodes collections ; - '[ _ write-message read-message ] with-client + binary "admin.$cmd" H{ { "ismaster" 1 } } + 1 >>return# '[ _ write-message read-message ] with-client objects>> first ; : split-host-str ( hoststr -- host port ) From 16965933bc2b1207f2efbd19d7348e9180ad3758 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sun, 1 Feb 2009 17:40:52 +0100 Subject: [PATCH 036/772] dropped oid and dbref support from bson; now using uuid (v1) for objid (Binary, Subtype: UUID) and custom binary format for objrefs (ns, objid - Binary, Subtype: Custom) --- bson/constants/constants.factor | 21 ++++++++++----------- bson/reader/reader.factor | 26 +++++++++++++------------- bson/writer/writer.factor | 28 +++++++++++++++++----------- mongodb/persistent/persistent.factor | 10 ++++------ 4 files changed, 44 insertions(+), 41 deletions(-) diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index 8f5b61a671..fc54f62927 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -1,18 +1,14 @@ -USING: alien.c-types accessors kernel calendar random math.bitwise math unix ; +USING: alien.c-types accessors kernel calendar random math.bitwise math unix +constructors uuid ; IN: bson.constants -TUPLE: oid { a initial: 0 } { b initial: 0 } ; +TUPLE: objid id ; -: ( -- oid ) - oid new - now timestamp>micros >>a - 8 random-bits 16 shift HEX: FF0000 mask - getpid HEX: FFFF mask - bitor >>b ; - -TUPLE: dbref ns oid ; +CONSTRUCTOR: objid ( -- objid ) + uuid1 >>id ; inline +TUPLE: objref ns objid ; CONSTANT: T_EOO 0 CONSTANT: T_Double 1 @@ -34,7 +30,10 @@ CONSTANT: T_Symbol 14 CONSTANT: T_JSTypeMax 16 CONSTANT: T_MaxKey 127 -CONSTANT: T_Binary_Bytes 2 CONSTANT: T_Binary_Function 1 +CONSTANT: T_Binary_Bytes 2 +CONSTANT: T_Binary_UUID 3 +CONSTANT: T_Binary_MD5 5 +CONSTANT: T_Binary_Custom 128 diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index d8b5e2b44a..f697f16691 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -29,6 +29,8 @@ PREDICATE: bson-array < integer T_Array = ; PREDICATE: bson-binary < integer T_Binary = ; PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ; PREDICATE: bson-binary-function < integer T_Binary_Function = ; +PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ; +PREDICATE: bson-binary-custom < integer T_Binary_Custom = ; PREDICATE: bson-oid < integer T_OID = ; PREDICATE: bson-boolean < integer T_Boolean = ; PREDICATE: bson-date < integer T_Date = ; @@ -134,12 +136,6 @@ M: bson-not-eoo element-read ( type -- cont? ) set-at t ; -M: bson-oid element-data-read ( type -- object ) - drop - read-longlong - read-int32 - oid boa ; - : [scope-changer] ( state -- state quot ) dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline @@ -172,13 +168,6 @@ M: bson-boolean element-data-read ( type -- boolean ) drop read-byte t = ; -M: bson-ref element-data-read ( type -- dbref ) - drop - read-int32 - read-sized-string - T_OID element-data-read - dbref boa ; - M: bson-binary element-data-read ( type -- binary ) drop read-int32 read-byte element-binary-read ; @@ -187,6 +176,17 @@ M: bson-null element-data-read ( type -- bf ) drop f ; +M: bson-binary-custom element-binary-read ( size type -- dbref ) + 2drop + read-cstring + read-cstring objid boa + objref boa ; + +M: bson-binary-uuid element-binary-read ( size type -- object ) + drop + read-sized-string + objid boa ; + M: bson-binary-bytes element-binary-read ( size type -- bytes ) drop read ; diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index c5e9b02ef8..4e07e3ab2f 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -5,7 +5,7 @@ USING: bson bson.constants accessors kernel io.streams.string io.encodings.utf8 strings splitting math.parser sequences math assocs classes words make fry prettyprint hashtables mirrors alien.strings alien.c-types - io.streams.byte-array io ; + io.streams.byte-array io alien.strings ; IN: bson.writer @@ -19,15 +19,16 @@ GENERIC: bson-write ( obj -- ) M: t bson-type? ( boolean -- type ) drop T_Boolean ; M: f bson-type? ( boolean -- type ) drop T_Boolean ; -M: oid bson-type? ( word -- type ) drop T_OID ; -M: dbref bson-type? ( dbref -- type ) drop T_DBRef ; M: real bson-type? ( real -- type ) drop T_Double ; M: word bson-type? ( word -- type ) drop T_String ; M: tuple bson-type? ( tuple -- type ) drop T_Object ; M: assoc bson-type? ( hashtable -- type ) drop T_Object ; M: string bson-type? ( string -- type ) drop T_String ; M: integer bson-type? ( integer -- type ) drop T_Integer ; -M: sequence bson-type? ( seq -- type ) drop T_Array ; +M: sequence bson-type? ( seq -- type ) drop T_Array ; + +M: objid bson-type? ( objid -- type ) drop T_Binary ; +M: objref bson-type? ( objref -- type ) drop T_Binary ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; @@ -69,14 +70,19 @@ M: quotation bson-write ( quotation -- ) T_Binary_Function write-byte write ; -M: oid bson-write ( oid -- ) - [ a>> write-longlong ] [ b>> write-int32 ] bi ; +M: objid bson-write ( oid -- ) + id>> utf8 string>alien + [ length write-int32 ] keep + T_Binary_UUID write-byte + write ; -M: dbref bson-write ( dbref -- ) - [ ns>> utf8 string>alien - [ length write-int32 ] keep write - ] - [ oid>> bson-write ] bi ; +M: objref bson-write ( objref -- ) + [ ns>> utf8 string>alien ] + [ objid>> id>> utf8 string>alien ] bi + append + [ length write-int32 ] keep + T_Binary_Custom write-byte + write ; M: sequence bson-write ( array -- ) '[ _ [ [ write-type ] dip number>string write-cstring bson-write ] diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor index 249a9d60af..f83d06905c 100644 --- a/mongodb/persistent/persistent.factor +++ b/mongodb/persistent/persistent.factor @@ -20,10 +20,8 @@ DEFER: create-mdb-command CONSTANT: MDB_INFO "_mdb_info" - - -: ( tuple -- dbref ) - [ mdb-collection>> ] [ _id>> ] bi dbref boa ; inline +: ( tuple -- objref ) + [ mdb-collection>> ] [ _id>> ] bi objref boa ; inline : mdbinfo>tuple-class ( mdbinfo -- class ) [ first ] keep second lookup ; inline @@ -66,7 +64,7 @@ CONSTANT: MDB_INFO "_mdb_info" [ _ keep [ mdb-collection>> ] keep [ create-mdb-command ] dip - ] + ] [ dup data-tuple? _ [ ] if ] if swap _ set-at ] if @@ -76,7 +74,7 @@ CONSTANT: MDB_INFO "_mdb_info" [ ] dip dup clone swap [ tuck ] dip swap ; inline : ensure-mdb-info ( tuple -- tuple ) - dup _id>> [ >>_id ] unless ; inline + dup _id>> [ >>_id ] unless ; inline : with-op-seq ( quot -- op-seq ) [ From 2e641216f3dd088b02dc3464504e16a87cc4b664 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 9 Feb 2009 08:31:47 +0100 Subject: [PATCH 037/772] changed type > byte-array conversion; now using io.binary (>le, le>) updated USING:s --- bson/constants/constants.factor | 3 +-- bson/reader/reader.factor | 20 ++++++++++---------- bson/writer/writer.factor | 28 +++++++++++++--------------- mongodb/mongodb.factor | 8 ++++++-- mongodb/msg/msg.factor | 23 ++++++++++++----------- 5 files changed, 42 insertions(+), 40 deletions(-) diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index fc54f62927..29144ded86 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -1,5 +1,4 @@ -USING: alien.c-types accessors kernel calendar random math.bitwise math unix -constructors uuid ; +USING: accessors constructors uuid ; IN: bson.constants diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index f697f16691..0f699ca499 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -1,7 +1,6 @@ -USING: mirrors io io.encodings.utf8 io.encodings.binary math kernel sequences - splitting accessors io.streams.byte-array namespaces prettyprint - bson.constants assocs alien.c-types alien.strings fry words - serialize byte-arrays byte-vectors ; +USING: accessors assocs bson.constants byte-arrays byte-vectors fry io +io.binary io.encodings.string io.encodings.utf8 kernel math namespaces +sequences serialize ; IN: bson.reader @@ -48,19 +47,19 @@ GENERIC: element-binary-read ( length type -- object ) [ get-state ] dip '[ _ + ] change-read drop ; inline : read-int32 ( -- int32 ) - 4 [ read *int ] [ count-bytes ] bi ; inline + 4 [ read le> ] [ count-bytes ] bi ; inline : read-longlong ( -- longlong ) - 8 [ read *longlong ] [ count-bytes ] bi ; inline + 8 [ read le> ] [ count-bytes ] bi ; inline : read-double ( -- double ) - 8 [ read *double ] [ count-bytes ] bi ; inline + 8 [ read le> bits>double ] [ count-bytes ] bi ; inline : read-byte-raw ( -- byte-raw ) 1 [ read ] [ count-bytes ] bi ; inline : read-byte ( -- byte ) - read-byte-raw *char ; inline + read-byte-raw first ; inline : (read-cstring) ( acc -- ) [ read-byte-raw first ] dip ! b acc @@ -71,11 +70,12 @@ GENERIC: element-binary-read ( length type -- object ) : read-cstring ( -- string ) BV{ } clone [ (read-cstring) ] keep - >byte-array utf8 alien>string ; inline + [ zero? ] trim-tail + >byte-array utf8 decode ; inline : read-sized-string ( length -- string ) [ read ] [ count-bytes ] bi - utf8 alien>string ; inline + [ zero? ] trim-tail utf8 decode ; inline : read-element-type ( -- type ) read-byte ; inline diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 4e07e3ab2f..a850c86e32 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -1,11 +1,9 @@ ! Copyright (C) 2008 Sascha Matzke. ! See http://factorcode.org/license.txt for BSD license. -USING: bson bson.constants accessors kernel io.streams.string - io.encodings.binary classes byte-arrays quotations serialize - io.encodings.utf8 strings splitting math.parser - sequences math assocs classes words make fry - prettyprint hashtables mirrors alien.strings alien.c-types - io.streams.byte-array io alien.strings ; +USING: accessors assocs bson.constants byte-arrays fry io io.binary +io.encodings.binary io.encodings.string io.encodings.utf8 +io.streams.byte-array kernel math math.parser quotations sequences +serialize strings words ; IN: bson.writer @@ -32,11 +30,11 @@ M: objref bson-type? ( objref -- type ) drop T_Binary ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; -: write-byte ( byte -- ) write ; inline -: write-int32 ( int -- ) write ; inline -: write-double ( real -- ) write ; inline -: write-cstring ( string -- ) utf8 string>alien write ; inline -: write-longlong ( object -- ) write ; inline +: write-byte ( byte -- ) 1 >le write ; inline +: write-int32 ( int -- ) 4 >le write ; inline +: write-double ( real -- ) double>bits 8 >le write ; inline +: write-cstring ( string -- ) utf8 encode B{ 0 } append write ; inline +: write-longlong ( object -- ) 8 >le write ; inline : write-eoo ( -- ) T_EOO write-byte ; inline : write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline @@ -50,7 +48,7 @@ M: t bson-write ( t -- ) drop 1 write-byte ; M: string bson-write ( obj -- ) - utf8 string>alien + utf8 encode B{ 0 } append [ length write-int32 ] keep write ; @@ -71,14 +69,14 @@ M: quotation bson-write ( quotation -- ) write ; M: objid bson-write ( oid -- ) - id>> utf8 string>alien + id>> utf8 encode [ length write-int32 ] keep T_Binary_UUID write-byte write ; M: objref bson-write ( objref -- ) - [ ns>> utf8 string>alien ] - [ objid>> id>> utf8 string>alien ] bi + [ ns>> utf8 encode ] + [ objid>> id>> utf8 encode ] bi append [ length write-int32 ] keep T_Binary_Custom write-byte diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor index 1d5d7f3693..69c2809a1e 100644 --- a/mongodb/mongodb.factor +++ b/mongodb/mongodb.factor @@ -9,7 +9,8 @@ IN: mongodb GENERIC: store ( tuple/ht -- ) GENERIC: find ( example -- tuple/ht ) GENERIC# nfind 1 ( example n -- tuple/ht ) -GENERIC: load ( object -- object ) +GENERIC: load ( object -- object ) +GENERIC: explain ( object -- object ) > master>> ] dip (find) build-result ; - +M: mdb-persistent explain ( example -- result ) + prepare-find [ query>> [ t "$explain" ] dip set-at ] keep + [ mdb>> master>> ] dip (find-one) + build-result ; diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index 3b0db0a08f..1df971b229 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -1,5 +1,5 @@ -USING: accessors alien.c-types alien.strings assocs bson.reader -bson.writer byte-arrays byte-vectors constructors fry io +USING: accessors io.encodings.string assocs bson.reader +bson.writer byte-arrays byte-vectors constructors fry io io.binary io.encodings.binary io.encodings.utf8 io.streams.byte-array kernel linked-assocs math namespaces sequences strings ; @@ -126,15 +126,15 @@ SYMBOL: msg-bytes-read : change-bytes-read ( integer -- ) bytes-read> [ 0 ] unless* + >bytes-read ; inline -: write-byte ( byte -- ) write ; inline -: write-int32 ( int -- ) write ; inline -: write-double ( real -- ) write ; inline -: write-cstring ( string -- ) utf8 string>alien write ; inline -: write-longlong ( object -- ) write ; inline +: write-byte ( byte -- ) 1 >le write ; inline +: write-int32 ( int -- ) 4 >le write ; inline +: write-double ( real -- ) double>bits 8 >le write ; inline +: write-cstring ( string -- ) utf8 encode B{ 0 } append write ; inline +: write-longlong ( object -- ) 8 >le write ; inline -: read-int32 ( -- int32 ) 4 [ read *int ] [ change-bytes-read ] bi ; inline -: read-longlong ( -- longlong ) 8 [ read *longlong ] [ change-bytes-read ] bi ; inline -: read-byte-raw ( -- byte-raw ) 1 [ read ] [ change-bytes-read ] bi ; inline +: read-int32 ( -- int32 ) 4 [ read le> ] [ change-bytes-read ] bi ; inline +: read-longlong ( -- longlong ) 8 [ read le> ] [ change-bytes-read ] bi ; inline +: read-byte-raw ( -- byte-raw ) 1 [ read le> ] [ change-bytes-read ] bi ; inline : read-byte ( -- byte ) read-byte-raw first ; inline : (read-cstring) ( acc -- ) @@ -146,7 +146,8 @@ SYMBOL: msg-bytes-read : read-cstring ( -- string ) BV{ } clone [ (read-cstring) ] keep - >byte-array utf8 alien>string ; inline + [ zero? ] trim-tail + >byte-array utf8 decode ; inline GENERIC: (read-message) ( message opcode -- message ) From 02a76d0a3e0be7d8ba97b1c6a60dfb3542feb0c4 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sun, 1 Mar 2009 22:45:38 +0100 Subject: [PATCH 038/772] started complete rewrite... Now there's a low-level driver (mongodb.driver) implementation. Tuple integration will follow soon. --- bson/constants/constants.factor | 8 +- bson/reader/reader.factor | 7 +- bson/writer/writer.factor | 4 + mongodb/connection/connection.factor | 65 ------ mongodb/driver/driver.factor | 282 +++++++++++++++++++++++++++ mongodb/index/index.factor | 108 ---------- mongodb/mongodb.factor | 40 ++-- mongodb/msg/msg.factor | 240 ++--------------------- mongodb/operations/operations.factor | 219 +++++++++++++++++++++ mongodb/persistent/persistent.factor | 6 +- mongodb/query/query.factor | 68 ------- mongodb/tuple/tuple.factor | 203 +++++++++++-------- 12 files changed, 681 insertions(+), 569 deletions(-) delete mode 100644 mongodb/connection/connection.factor create mode 100644 mongodb/driver/driver.factor delete mode 100644 mongodb/index/index.factor create mode 100644 mongodb/operations/operations.factor delete mode 100644 mongodb/query/query.factor diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index 29144ded86..039ea18089 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -1,11 +1,13 @@ -USING: accessors constructors uuid ; +USING: accessors kernel uuid ; IN: bson.constants TUPLE: objid id ; -CONSTRUCTOR: objid ( -- objid ) - uuid1 >>id ; inline +: ( -- objid ) + objid new uuid1 >>id ; inline + +TUPLE: oid { a initial: 0 } { b initial: 0 } ; TUPLE: objref ns objid ; diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index 0f699ca499..44eadef973 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -1,6 +1,6 @@ USING: accessors assocs bson.constants byte-arrays byte-vectors fry io io.binary io.encodings.string io.encodings.utf8 kernel math namespaces -sequences serialize ; +sequences serialize arrays ; IN: bson.reader @@ -176,6 +176,11 @@ M: bson-null element-data-read ( type -- bf ) drop f ; +M: bson-oid element-data-read ( type -- oid ) + drop + read-longlong + read-int32 oid boa ; + M: bson-binary-custom element-binary-read ( size type -- dbref ) 2drop read-cstring diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index a850c86e32..439cfb7372 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -25,6 +25,7 @@ M: string bson-type? ( string -- type ) drop T_String ; M: integer bson-type? ( integer -- type ) drop T_Integer ; M: sequence bson-type? ( seq -- type ) drop T_Array ; +M: oid bson-type? ( word -- type ) drop T_OID ; M: objid bson-type? ( objid -- type ) drop T_Binary ; M: objref bson-type? ( objref -- type ) drop T_Binary ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ; @@ -68,6 +69,9 @@ M: quotation bson-write ( quotation -- ) T_Binary_Function write-byte write ; +M: oid bson-write ( oid -- ) + [ a>> write-longlong ] [ b>> write-int32 ] bi ; + M: objid bson-write ( oid -- ) id>> utf8 encode [ length write-int32 ] keep diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor deleted file mode 100644 index 6e608dcb63..0000000000 --- a/mongodb/connection/connection.factor +++ /dev/null @@ -1,65 +0,0 @@ -USING: accessors assocs fry io.sockets kernel math mongodb.msg -namespaces sequences splitting math.parser io.encodings.binary ; - -IN: mongodb.connection - -TUPLE: mdb-node master? inet ; - -TUPLE: mdb name nodes collections ; - -: mdb>> ( -- mdb ) - mdb get ; inline - -: with-db ( mdb quot -- ... ) - '[ _ mdb set _ call ] with-scope ; - -: master>> ( mdb -- inet ) - nodes>> [ t ] dip at inet>> ; - -: slave>> ( mdb -- inet ) - nodes>> [ f ] dip at inet>> ; - - - 1 >>return# '[ _ write-message read-message ] with-client - objects>> first ; - -: split-host-str ( hoststr -- host port ) - ":" split [ first ] keep - second string>number ; inline - -: eval-ismaster-result ( node result -- node result ) - [ [ "ismaster" ] dip at - >fixnum 1 = - [ t >>master? ] [ f >>master? ] if ] keep ; - -: check-node ( node -- node remote ) - dup inet>> ismaster-cmd - eval-ismaster-result - [ "remote" ] dip at ; - -: check-nodes ( node -- nodelist ) - check-node - [ V{ } clone [ push ] keep ] dip - [ split-host-str [ f ] dip - mdb-node boa check-node drop - swap tuck push - ] when* ; - -: verify-nodes ( -- ) - mdb>> nodes>> [ t ] dip at - check-nodes - H{ } clone tuck - '[ dup master?>> _ set-at ] each - [ mdb>> ] dip >>nodes drop ; - -PRIVATE> - -: () ( db host port -- mdb ) - [ f ] 2dip mdb-node boa - check-nodes - H{ } clone tuck - '[ dup master?>> _ set-at ] each - H{ } clone mdb boa ; diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor new file mode 100644 index 0000000000..6337452174 --- /dev/null +++ b/mongodb/driver/driver.factor @@ -0,0 +1,282 @@ +USING: accessors assocs fry io.sockets kernel math mongodb.msg formatting linked-assocs destructors continuations +mongodb.operations namespaces sequences splitting math.parser io.encodings.binary combinators io.streams.duplex +arrays io memoize constructors sets strings ; + +IN: mongodb.driver + +TUPLE: mdb-node master? inet ; + +TUPLE: mdb name nodes collections ; + +TUPLE: mdb-cursor collection id return# ; + +UNION: boolean t POSTPONE: f ; + +TUPLE: mdb-collection +{ name string } +{ capped boolean initial: f } +{ size integer initial: -1 } +{ max integer initial: -1 } ; + +CONSTRUCTOR: mdb-cursor ( id collection return# -- cursor ) ; +CONSTRUCTOR: mdb-collection ( name -- collection ) ; + +CONSTANT: MDB-GENERAL-ERROR 1 + +CONSTANT: MDB_OID "_id" +CONSTANT: MDB_PROPERTIES "_mdb_" + +CONSTANT: PARTIAL? "partial?" +CONSTANT: DIRTY? "dirty?" + +ERROR: mdb-error id msg ; + +> ( -- stream ) + mdb-socket-stream get ; inline + +: check-ok ( result -- ? ) + [ "ok" ] dip key? ; inline + +PRIVATE> + +: mdb>> ( -- mdb ) + mdb get ; inline + +: master>> ( mdb -- inet ) + nodes>> [ t ] dip at inet>> ; + +: slave>> ( mdb -- inet ) + nodes>> [ f ] dip at inet>> ; + +: with-db ( mdb quot -- ... ) + [ [ '[ _ [ mdb set ] keep master>> + [ remote-address set ] keep + binary + local-address set + mdb-socket-stream set ] ] dip compose + [ mdb-stream>> [ dispose ] when* ] [ ] cleanup + ] with-scope ; + +> name>> "%s.system.indexes" sprintf ; inline + +: namespaces-collection ( -- ns ) + mdb>> name>> "%s.system.namespaces" sprintf ; inline + +: cmd-collection ( -- ns ) + mdb>> name>> "%s.$cmd" sprintf ; inline + +: index-ns ( colname -- index-ns ) + [ mdb>> name>> ] dip "%s.%s" sprintf ; inline + +: ismaster-cmd ( node -- result ) + binary "admin.$cmd" H{ { "ismaster" 1 } } + 1 >>return# '[ _ write-message read-message ] with-client + objects>> first ; + +: split-host-str ( hoststr -- host port ) + ":" split [ first ] keep + second string>number ; inline + +: eval-ismaster-result ( node result -- node result ) + [ [ "ismaster" ] dip at + >fixnum 1 = + [ t >>master? ] [ f >>master? ] if ] keep ; + +: check-node ( node -- node remote ) + dup inet>> ismaster-cmd + eval-ismaster-result + [ "remote" ] dip at ; + +: check-nodes ( node -- nodelist ) + check-node + [ V{ } clone [ push ] keep ] dip + [ split-host-str [ f ] dip + mdb-node boa check-node drop + swap tuck push + ] when* ; + +: verify-nodes ( -- ) + mdb>> nodes>> [ t ] dip at + check-nodes + H{ } clone tuck + '[ dup master?>> _ set-at ] each + [ mdb>> ] dip >>nodes drop ; + +: send-message ( message -- ) + [ mdb-stream>> ] dip '[ _ write-message ] with-stream* ; + +: send-query-plain ( query-message -- result ) + [ mdb-stream>> ] dip + '[ _ write-message read-message ] with-stream* ; + +: send-query ( query-message -- cursor result ) + [ send-query-plain ] keep + { [ collection>> >>collection drop ] + [ return#>> >>requested# ] + } 2cleave + [ [ cursor>> 0 > ] keep + '[ _ [ cursor>> ] [ collection>> ] [ requested#>> ] tri ] + [ f ] if + ] [ objects>> ] bi ; + +PRIVATE> + +: ( db host port -- mdb ) + [ f ] 2dip mdb-node boa + check-nodes + H{ } clone tuck + '[ dup master?>> _ set-at ] each + H{ } clone mdb boa ; + +: create-collection ( name -- ) + [ cmd-collection ] dip + "create" H{ } clone [ set-at ] keep + 1 >>return# send-query-plain objects>> first check-ok + [ "could not create collection" throw ] unless ; + +: load-collection-list ( -- collection-list ) + namespaces-collection + H{ } clone send-query-plain objects>> ; + + ] keep + '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline + +: (ensure-collection) ( collection -- ) + mdb>> collections>> dup keys length 0 = + [ load-collection-list + [ [ "options" ] dip key? ] filter + [ [ "name" ] dip at "." split second ] map + over '[ [ ] [ name>> ] bi _ set-at ] each ] [ ] if + [ dup ] dip key? [ drop ] + [ [ ensure-valid-collection-name ] keep create-collection ] if ; inline + +MEMO: reserved-namespace? ( name -- ? ) + [ "$cmd" = ] [ "system" head? ] bi or ; + +PRIVATE> + +MEMO: ensure-collection ( collection -- fq-collection ) + "." split1 over mdb>> name>> = + [ [ drop ] dip ] [ drop ] if + [ ] [ reserved-namespace? ] bi + [ [ (ensure-collection) ] keep ] unless + [ mdb>> name>> ] dip "%s.%s" sprintf ; inline + +: ( collection query -- mdb-query ) + [ ensure-collection ] dip + ; inline + +GENERIC# limit 1 ( mdb-query limit# -- mdb-query ) +M: mdb-query-msg limit ( query limit# -- mdb-query ) + >>return# ; inline + +GENERIC# skip 1 ( mdb-query skip# -- mdb-query ) +M: mdb-query-msg skip ( query skip# -- mdb-query ) + >>skip# ; inline + +: asc ( key -- spec ) [ 1 ] dip H{ } clone [ set-at ] keep ; inline +: desc ( key -- spec ) [ -1 ] dip H{ } clone [ set-at ] keep ; inline + +GENERIC# sort 1 ( mdb-query quot -- mdb-query ) +M: mdb-query-msg sort ( query qout -- mdb-query ) + [ { } ] dip with-datastack >>orderby ; + +GENERIC# hint 1 ( mdb-query index-hint -- mdb-query ) +M: mdb-query-msg hint ( mdb-query index-hint -- mdb-query ) + >>hint ; + +: find ( mdb-query -- cursor result ) + send-query ; + +: explain ( mdb-query -- result ) + t >>explain find [ drop ] dip ; + +GENERIC: get-more ( mdb-cursor -- mdb-cursor objects ) +M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects ) + [ [ collection>> ] [ return#>> ] [ id>> ] tri send-query ] + [ f f ] if* ; + +: find-one ( mdb-query -- result ) + 1 >>return# send-query-plain ; + +: count ( collection query -- result ) + [ "count" H{ } clone [ set-at ] keep ] dip + [ over [ "query" ] dip set-at ] when* + [ cmd-collection ] dip find-one objects>> first + [ check-ok ] keep '[ "n" _ at >fixnum ] [ f ] if ; + +: lasterror ( -- error ) + cmd-collection H{ { "getlasterror" 1 } } + find-one objects>> [ "err" ] at ; + +: validate ( collection -- ) + [ cmd-collection ] dip + "validate" H{ } clone [ set-at ] keep + find-one objects>> first [ check-ok ] keep + '[ "result" _ at print ] when ; + + + +: save ( collection object -- ) + [ ensure-collection ] dip + send-message-check-error ; + +: save-unsafe ( collection object -- ) + [ ensure-collection ] dip + send-message ; + +: ensure-index ( collection name spec -- ) + H{ } clone + [ [ "key" ] dip set-at ] keep + [ [ "name" ] dip set-at ] keep + [ [ index-ns "ns" ] dip set-at ] keep + [ index-collection ] dip + save ; + +: drop-index ( collection name -- ) + H{ } clone + [ [ "index" ] dip set-at ] keep + [ [ "deleteIndexes" ] dip set-at ] keep + [ cmd-collection ] dip find-one objects>> first + check-ok [ "could not drop index" throw ] unless ; + +: update ( collection selector object -- ) + [ ensure-collection ] dip + send-message-check-error ; + +: update-unsafe ( collection selector object -- ) + [ ensure-collection ] dip + send-message ; + +: delete ( collection selector -- ) + [ ensure-collection ] dip + send-message-check-error ; + +: delete-unsafe ( collection selector -- ) + [ ensure-collection ] dip + send-message ; + +: load-index-list ( -- index-list ) + index-collection + H{ } clone find [ drop ] dip ; + +: drop-collection ( name -- ) + [ cmd-collection ] dip + "drop" H{ } clone [ set-at ] keep + find-one objects>> first check-ok + [ "could not drop collection" throw ] unless ; diff --git a/mongodb/index/index.factor b/mongodb/index/index.factor deleted file mode 100644 index 487251c27f..0000000000 --- a/mongodb/index/index.factor +++ /dev/null @@ -1,108 +0,0 @@ -USING: accessors assocs combinators formatting fry kernel memoize -linked-assocs mongodb.persistent mongodb.msg mongodb.connection -sequences sequences.deep io.encodings.binary mongodb.tuple -io.sockets prettyprint sets tools.walker math ; - -IN: mongodb.index - -: index-ns ( name -- ns ) - "%s.system.indexes" sprintf ; inline - -TUPLE: index name ns key ; - -SYMBOLS: +fieldindex+ +compoundindex+ +deepindex+ ; - - ] 2dip - [ rest ] keep first ! assoc slot options itype - { { +fieldindex+ [ drop [ 1 ] dip pick set-at ] } - { +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] } - { +compoundindex+ [ - 2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options - over '[ _ [ 1 ] 2dip set-at ] each ] } - } case ; - -: build-index-seq ( slot optlist ns -- index-seq ) - [ V{ } clone ] 3dip ! v{} slot optl ns - [ index new ] dip ! v{} slot optl index ns - >>ns - [ pick ] dip swap ! v{} slot optl index v{} - [ swap ] 2dip ! v{} optl slot index v{ } - '[ _ _ ! element slot exemplar - clone 2over swap index-name >>name ! element slot clone - [ build-index ] dip swap >>key _ push - ] each ; - -: is-index-declaration? ( entry -- ? ) - first - { { +fieldindex+ [ t ] } - { +compoundindex+ [ t ] } - { +deepindex+ [ t ] } - [ drop f ] } case ; - -: index-assoc ( seq -- assoc ) - H{ } clone tuck '[ dup name>> _ set-at ] each ; - -: delete-index ( name ns -- ) - "Drop index %s - %s" sprintf . ; - -: clean-indices ( existing defined -- ) - [ index-assoc ] bi@ assoc-diff values - [ [ name>> ] [ ns>> ] bi delete-index ] each ; - -PRIVATE> - -USE: mongodb.query - -: load-indices ( mdb-collection -- indexlist ) - [ mdb>> name>> ] dip name>> "%s.%s" sprintf - "ns" H{ } clone [ set-at ] keep [ mdb>> name>> index-ns ] dip - '[ _ write-message read-message ] - [ mdb>> master>> binary ] dip with-client - objects>> [ [ index new ] dip - [ [ "ns" ] dip at >>ns ] - [ [ "name" ] dip at >>name ] - [ [ "key" ] dip at >>key ] tri - ] map ; - -: build-indices ( mdb-collection mdb -- seq ) - name>> - [ [ mdb-slot-definitions>> ] keep name>> ] dip - swap "%s.%s" sprintf - [ V{ } clone ] 2dip pick - '[ _ - [ [ is-index-declaration? ] filter ] dip - build-index-seq _ push - ] assoc-each flatten ; - -: ensure-indices ( mdb-collection -- ) - [ load-indices ] keep mdb>> build-indices - [ clean-indices ] keep - V{ } clone tuck - '[ _ [ tuple>query ] dip push ] each - dup length 0 > - [ [ mdb>> name>> "%s.system.indexes" sprintf ] dip - - [ mdb>> master>> binary ] dip '[ _ write-message ] with-client - ] - [ drop ] if ; - -: show-indices ( mdb-collection -- ) - load-indices . ; - -: show-all-indices ( -- ) - mdb>> collections>> values - V{ } clone tuck - '[ load-indices _ push ] each flatten . ; \ No newline at end of file diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor index 69c2809a1e..28ca6acc25 100644 --- a/mongodb/mongodb.factor +++ b/mongodb/mongodb.factor @@ -1,7 +1,8 @@ -USING: accessors assocs fry io.encodings.binary io.sockets kernel math -math.parser namespaces sequences splitting -mongodb.connection mongodb.persistent mongodb.msg mongodb.query -mongodb.tuple ; +USING: accessors assocs combinators fry io.encodings.binary +io.sockets kernel math math.parser mongodb.driver +mongodb.msg mongodb.operations mongodb.persistent +mongodb.tuple namespaces +sequences splitting ; IN: mongodb @@ -18,29 +19,32 @@ GENERIC: explain ( object -- object ) [ mdb-collection>> get-collection-fqn ] keep H{ } tuple>query ; inline +TUPLE: mdb-result { cursor integer } +{ start# integer } +{ returned# integer } +{ objects sequence } ; + +: build-result ( resultmsg -- mdb-result ) + [ mdb-result new ] dip + { + [ cursor>> >>cursor ] + [ start#>> >>start# ] + [ returned#>> >>returned# ] + [ objects>> [ assoc>tuple ] map >>objects ] + } cleave ; + PRIVATE> - -: ( db host port -- mdb ) - () ; - M: mdb-persistent store ( tuple -- ) prepare-store ! H { collection { ... values ... } [ [ get-collection-fqn ] dip - values - [ mdb>> master>> binary ] dip '[ _ write-message ] with-client + values send-message ] assoc-each ; M: mdb-persistent find ( example -- result ) - prepare-find [ mdb>> master>> ] dip (find) + prepare-find [ mdb>> master>> ] dip send-query build-result ; M: mdb-persistent nfind ( example n -- result ) [ prepare-find ] dip >>return# - [ mdb>> master>> ] dip (find) - build-result ; - -M: mdb-persistent explain ( example -- result ) - prepare-find [ query>> [ t "$explain" ] dip set-at ] keep - [ mdb>> master>> ] dip (find-one) - build-result ; + send-query build-result ; diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index 1df971b229..636e5e6755 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -1,12 +1,8 @@ -USING: accessors io.encodings.string assocs bson.reader -bson.writer byte-arrays byte-vectors constructors fry io io.binary -io.encodings.binary io.encodings.utf8 io.streams.byte-array kernel -linked-assocs math namespaces sequences strings ; +USING: accessors assocs constructors kernel linked-assocs math +sequences strings ; IN: mongodb.msg - +CONSTANT: OP_KillCursors 2007 TUPLE: mdb-msg { opcode integer } @@ -39,7 +25,7 @@ TUPLE: mdb-insert-msg < mdb-msg TUPLE: mdb-update-msg < mdb-msg { collection string } -{ upsert? integer initial: 1 } +{ upsert? integer initial: 0 } { selector assoc } { object assoc } ; @@ -62,16 +48,19 @@ TUPLE: mdb-query-msg < mdb-msg { return# integer initial: 0 } { query assoc } { returnfields assoc } -{ orderby sequence } ; +{ orderby sequence } +explain hint ; TUPLE: mdb-reply-msg < mdb-msg +{ collection string } { cursor integer initial: 0 } { start# integer initial: 0 } +{ requested# integer initial: 0 } { returned# integer initial: 0 } { objects sequence } ; -CONSTRUCTOR: mdb-getmore-msg ( collection return# -- mdb-getmore-msg ) +CONSTRUCTOR: mdb-getmore-msg ( collection return# cursor -- mdb-getmore-msg ) OP_GetMore >>opcode ; inline CONSTRUCTOR: mdb-delete-msg ( collection selector -- mdb-delete-msg ) @@ -90,213 +79,22 @@ M: sequence ( sequences -- mdb-killcursors-msg ) M: integer ( integer -- mdb-killcursors-msg ) V{ } clone [ push ] keep ; -GENERIC# 1 ( collection objects -- mdb-insert-msg ) - -M: linked-assoc ( collection linked-assoc -- mdb-insert-msg ) - [ mdb-insert-msg new ] 2dip - [ >>collection ] dip - V{ } clone tuck push - >>objects OP_Insert >>opcode ; +GENERIC: ( collection objects -- mdb-insert-msg ) M: sequence ( collection sequence -- mdb-insert-msg ) [ mdb-insert-msg new ] 2dip [ >>collection ] dip >>objects OP_Insert >>opcode ; -CONSTRUCTOR: mdb-update-msg ( collection object -- mdb-update-msg ) - dup object>> [ "_id" ] dip at "_id" H{ } clone [ set-at ] keep >>selector - OP_Update >>opcode ; +M: assoc ( collection assoc -- mdb-insert-msg ) + [ mdb-insert-msg new ] 2dip + [ >>collection ] dip + V{ } clone tuck push + >>objects OP_Insert >>opcode ; + + +CONSTRUCTOR: mdb-update-msg ( collection selector object -- mdb-update-msg ) + OP_Update >>opcode ; inline CONSTRUCTOR: mdb-reply-msg ( -- mdb-reply-msg ) ; inline -GENERIC: write-message ( message -- ) - - ( -- integer ) - msg-bytes-read get ; inline - -: >bytes-read ( integer -- ) - msg-bytes-read set ; inline - -: change-bytes-read ( integer -- ) - bytes-read> [ 0 ] unless* + >bytes-read ; inline - -: write-byte ( byte -- ) 1 >le write ; inline -: write-int32 ( int -- ) 4 >le write ; inline -: write-double ( real -- ) double>bits 8 >le write ; inline -: write-cstring ( string -- ) utf8 encode B{ 0 } append write ; inline -: write-longlong ( object -- ) 8 >le write ; inline - -: read-int32 ( -- int32 ) 4 [ read le> ] [ change-bytes-read ] bi ; inline -: read-longlong ( -- longlong ) 8 [ read le> ] [ change-bytes-read ] bi ; inline -: read-byte-raw ( -- byte-raw ) 1 [ read le> ] [ change-bytes-read ] bi ; inline -: read-byte ( -- byte ) read-byte-raw first ; inline - -: (read-cstring) ( acc -- ) - [ read-byte ] dip ! b acc - 2dup push ! b acc - [ 0 = ] dip ! bool acc - '[ _ (read-cstring) ] unless ; inline recursive - -: read-cstring ( -- string ) - BV{ } clone - [ (read-cstring) ] keep - [ zero? ] trim-tail - >byte-array utf8 decode ; inline - -GENERIC: (read-message) ( message opcode -- message ) - -: copy-header ( message msg-stub -- message ) - [ length>> ] keep [ >>length ] dip - [ req-id>> ] keep [ >>req-id ] dip - [ resp-id>> ] keep [ >>resp-id ] dip - [ opcode>> ] keep [ >>opcode ] dip - flags>> >>flags ; - -M: mdb-query-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-query-msg new ] dip copy-header - read-cstring >>collection - read-int32 >>skip# - read-int32 >>return# - H{ } stream>assoc change-bytes-read >>query - dup length>> bytes-read> > - [ H{ } stream>assoc change-bytes-read >>returnfields - dup length>> bytes-read> > - [ H{ } stream>assoc drop >>orderby ] when - ] when ; - -M: mdb-insert-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-insert-msg new ] dip copy-header - read-cstring >>collection - V{ } clone >>objects - [ '[ _ length>> bytes-read> > ] ] keep tuck - '[ H{ } stream>assoc change-bytes-read _ objects>> push ] - [ ] while ; - -M: mdb-delete-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-delete-msg new ] dip copy-header - read-cstring >>collection - H{ } stream>assoc change-bytes-read >>selector ; - -M: mdb-getmore-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-getmore-msg new ] dip copy-header - read-cstring >>collection - read-int32 >>return# - read-longlong >>cursor ; - -M: mdb-killcursors-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-killcursors-msg new ] dip copy-header - read-int32 >>cursors# - V{ } clone >>cursors - [ [ cursors#>> ] keep - '[ read-longlong _ cursors>> push ] times ] keep ; - -M: mdb-update-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-update-msg new ] dip copy-header - read-cstring >>collection - read-int32 >>upsert? - H{ } stream>assoc change-bytes-read >>selector - H{ } stream>assoc change-bytes-read >>object ; - -M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) - drop - [ ] dip copy-header - read-longlong >>cursor - read-int32 >>start# - read-int32 [ >>returned# ] keep - [ H{ } stream>assoc drop ] accumulator [ times ] dip >>objects ; - -: read-header ( message -- message ) - read-int32 >>length - read-int32 >>req-id - read-int32 >>resp-id - read-int32 >>opcode - read-int32 >>flags ; inline - -: write-header ( message length -- ) - MSG-HEADER-SIZE + write-int32 - [ req-id>> write-int32 ] keep - [ resp-id>> write-int32 ] keep - opcode>> write-int32 ; inline - -PRIVATE> - -: read-message ( -- message ) - mdb-msg new - 0 >bytes-read - read-header - [ ] [ opcode>> ] bi (read-message) ; - - - -M: mdb-query-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ collection>> write-cstring ] keep - [ skip#>> write-int32 ] keep - [ return#>> write-int32 ] keep - query>> assoc>array write - ] (write-message) ; - -M: mdb-insert-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ collection>> write-cstring ] keep - objects>> [ assoc>array write ] each - ] (write-message) ; - -M: mdb-update-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ collection>> write-cstring ] keep - [ upsert?>> write-int32 ] keep - [ selector>> assoc>array write ] keep - object>> assoc>array write - ] (write-message) ; - -M: mdb-delete-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ collection>> write-cstring ] keep - 0 write-int32 - selector>> assoc>array write - ] (write-message) ; - -M: mdb-getmore-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ collection>> write-cstring ] keep - [ return#>> write-int32 ] keep - cursor>> write-longlong - ] (write-message) ; - -M: mdb-killcursors-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ cursors#>> write-int32 ] keep - cursors>> [ write-longlong ] each - ] (write-message) ; \ No newline at end of file diff --git a/mongodb/operations/operations.factor b/mongodb/operations/operations.factor new file mode 100644 index 0000000000..e628251103 --- /dev/null +++ b/mongodb/operations/operations.factor @@ -0,0 +1,219 @@ +USING: accessors bson.reader bson.writer byte-arrays byte-vectors fry +io io.binary io.encodings.binary io.encodings.string io.encodings.utf8 +io.streams.byte-array kernel math mongodb.msg namespaces sequences +locals assocs combinators linked-assocs ; + +IN: mongodb.operations + + + +GENERIC: write-message ( message -- ) + + ( -- integer ) + msg-bytes-read get ; inline + +: >bytes-read ( integer -- ) + msg-bytes-read set ; inline + +: change-bytes-read ( integer -- ) + bytes-read> [ 0 ] unless* + >bytes-read ; inline + +: write-byte ( byte -- ) 1 >le write ; inline +: write-int32 ( int -- ) 4 >le write ; inline +: write-double ( real -- ) double>bits 8 >le write ; inline +: write-cstring ( string -- ) utf8 encode B{ 0 } append write ; inline +: write-longlong ( object -- ) 8 >le write ; inline + +: read-int32 ( -- int32 ) 4 [ read le> ] [ change-bytes-read ] bi ; inline +: read-longlong ( -- longlong ) 8 [ read le> ] [ change-bytes-read ] bi ; inline +: read-byte-raw ( -- byte-raw ) 1 [ read le> ] [ change-bytes-read ] bi ; inline +: read-byte ( -- byte ) read-byte-raw first ; inline + +: (read-cstring) ( acc -- ) + [ read-byte ] dip ! b acc + 2dup push ! b acc + [ 0 = ] dip ! bool acc + '[ _ (read-cstring) ] unless ; inline recursive + +: read-cstring ( -- string ) + BV{ } clone + [ (read-cstring) ] keep + [ zero? ] trim-tail + >byte-array utf8 decode ; inline + +GENERIC: (read-message) ( message opcode -- message ) + +: copy-header ( message msg-stub -- message ) + [ length>> ] keep [ >>length ] dip + [ req-id>> ] keep [ >>req-id ] dip + [ resp-id>> ] keep [ >>resp-id ] dip + [ opcode>> ] keep [ >>opcode ] dip + flags>> >>flags ; + +M: mdb-query-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-query-msg new ] dip copy-header + read-cstring >>collection + read-int32 >>skip# + read-int32 >>return# + H{ } stream>assoc change-bytes-read >>query + dup length>> bytes-read> > + [ H{ } stream>assoc change-bytes-read >>returnfields ] when ; + +M: mdb-insert-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-insert-msg new ] dip copy-header + read-cstring >>collection + V{ } clone >>objects + [ '[ _ length>> bytes-read> > ] ] keep tuck + '[ H{ } stream>assoc change-bytes-read _ objects>> push ] + while ; + +M: mdb-delete-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-delete-msg new ] dip copy-header + read-cstring >>collection + H{ } stream>assoc change-bytes-read >>selector ; + +M: mdb-getmore-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-getmore-msg new ] dip copy-header + read-cstring >>collection + read-int32 >>return# + read-longlong >>cursor ; + +M: mdb-killcursors-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-killcursors-msg new ] dip copy-header + read-int32 >>cursors# + V{ } clone >>cursors + [ [ cursors#>> ] keep + '[ read-longlong _ cursors>> push ] times ] keep ; + +M: mdb-update-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-update-msg new ] dip copy-header + read-cstring >>collection + read-int32 >>upsert? + H{ } stream>assoc change-bytes-read >>selector + H{ } stream>assoc change-bytes-read >>object ; + +M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) + drop + [ ] dip copy-header + read-longlong >>cursor + read-int32 >>start# + read-int32 [ >>returned# ] keep + [ stream>assoc drop ] accumulator [ times ] dip >>objects ; + +: read-header ( message -- message ) + read-int32 >>length + read-int32 >>req-id + read-int32 >>resp-id + read-int32 >>opcode + read-int32 >>flags ; inline + +: write-header ( message length -- ) + MSG-HEADER-SIZE + write-int32 + [ req-id>> write-int32 ] keep + [ resp-id>> write-int32 ] keep + opcode>> write-int32 ; inline + +PRIVATE> + +: read-message ( -- message ) + mdb-msg new + 0 >bytes-read + read-header + [ ] [ opcode>> ] bi (read-message) ; + + ] | + { [ orderby>> [ "orderby" selector set-at ] when* ] + [ explain>> [ "$explain" selector set-at ] when* ] + [ hint>> [ "$hint" selector set-at ] when* ] + [ query>> "query" selector set-at ] + } cleave + selector + ] ; + +PRIVATE> + +M: mdb-query-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ collection>> write-cstring ] keep + [ skip#>> write-int32 ] keep + [ return#>> write-int32 ] keep + [ build-query-object assoc>array write ] keep + returnfields>> [ assoc>array write ] when* + ] (write-message) ; + +M: mdb-insert-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ collection>> write-cstring ] keep + objects>> [ assoc>array write ] each + ] (write-message) ; + +M: mdb-update-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ collection>> write-cstring ] keep + [ upsert?>> write-int32 ] keep + [ selector>> assoc>array write ] keep + object>> assoc>array write + ] (write-message) ; + +M: mdb-delete-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ collection>> write-cstring ] keep + 0 write-int32 + selector>> assoc>array write + ] (write-message) ; + +M: mdb-getmore-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ collection>> write-cstring ] keep + [ return#>> write-int32 ] keep + cursor>> write-longlong + ] (write-message) ; + +M: mdb-killcursors-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ cursors#>> write-int32 ] keep + cursors>> [ write-longlong ] each + ] (write-message) ; + diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor index f83d06905c..dc5ddb614b 100644 --- a/mongodb/persistent/persistent.factor +++ b/mongodb/persistent/persistent.factor @@ -1,6 +1,6 @@ USING: accessors assocs classes fry kernel linked-assocs math mirrors namespaces sequences strings vectors words bson.constants -continuations mongodb.tuple ; +continuations mongodb.driver mongodb.tuple ; IN: mongodb.persistent @@ -18,10 +18,10 @@ DEFER: create-mdb-command ( tuple -- objref ) - [ mdb-collection>> ] [ _id>> ] bi objref boa ; inline + [ mdb-collection-prop ] [ _id>> ] bi objref boa ; inline : mdbinfo>tuple-class ( mdbinfo -- class ) [ first ] keep second lookup ; inline diff --git a/mongodb/query/query.factor b/mongodb/query/query.factor deleted file mode 100644 index ca3b059537..0000000000 --- a/mongodb/query/query.factor +++ /dev/null @@ -1,68 +0,0 @@ -USING: accessors combinators fry io.encodings.binary io.sockets kernel -mongodb.msg mongodb.persistent mongodb.connection sequences math namespaces assocs -formatting splitting mongodb.tuple mongodb.index ; - -IN: mongodb.query - -TUPLE: mdb-result { cursor integer } -{ start# integer } -{ returned# integer } -{ objects sequence } ; - -: namespaces-ns ( name -- ns ) - "%s.system.namespaces" sprintf ; inline - - - -: (find) ( inet query -- result ) - '[ _ write-message read-message ] (execute-query) ; inline - -: (find-one) ( inet query -- result ) - 1 >>return# - (find) ; inline - -: build-result ( resultmsg -- mdb-result ) - [ mdb-result new ] dip - { - [ cursor>> >>cursor ] - [ start#>> >>start# ] - [ returned#>> >>returned# ] - [ objects>> [ assoc>tuple ] map >>objects ] - } cleave ; - -: load-collections ( -- collections ) - mdb>> [ master>> ] [ name>> namespaces-ns ] bi - H{ } clone (find) - objects>> [ [ "name" ] dip at "." split second ] map - H{ } clone tuck - '[ [ ensure-indices ] [ ] [ name>> ] tri _ set-at ] each - [ mdb>> ] dip >>collections collections>> ; - -: check-ok ( result -- ? ) - [ "ok" ] dip key? ; inline - -: create-collection ( mdb-collection -- ) - dup name>> "create" H{ } clone [ set-at ] keep - [ mdb>> [ master>> ] [ name>> ] bi "%s.$cmd" sprintf ] dip - (find-one) objects>> first - check-ok - [ [ ensure-indices ] keep dup name>> mdb>> collections>> set-at ] - [ "could not create collection" throw ] if ; - -: get-collection-fqn ( mdb-collection -- fqdn ) - mdb>> collections>> - dup keys length 0 = - [ drop load-collections ] - [ ] if - [ dup name>> ] dip - key? - [ ] - [ dup create-collection ] if - name>> [ mdb>> name>> ] dip "%s.%s" sprintf ; - - \ No newline at end of file diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor index 16e408d78e..34591a5d4a 100644 --- a/mongodb/tuple/tuple.factor +++ b/mongodb/tuple/tuple.factor @@ -1,131 +1,170 @@ USING: accessors assocs classes classes.mixin classes.tuple vectors math -classes.tuple.parser formatting generalizations kernel sequences fry -prettyprint strings compiler.units slots tools.walker words arrays mongodb.persistent ; +classes.tuple.parser formatting generalizations kernel sequences fry combinators +linked-assocs sequences.deep mongodb.driver continuations memoize +prettyprint strings compiler.units slots tools.walker words arrays ; IN: mongodb.tuple MIXIN: mdb-persistent - -GENERIC: mdb-slot-definitions>> ( tuple -- string ) -GENERIC: mdb-collection>> ( object -- mdb-collection ) - -CONSTANT: MDB_COLLECTIONS "mdb_collections" -CONSTANT: MDB_COL_PROP "mdb_collection" -CONSTANT: MDB_SLOTOPT_PROP "mdb_slot_options" - SLOT: _id -CONSTANT: MDB_P_SLOTS { "_id" } -CONSTANT: MDB_OID "_id" +SLOT: _mdb_ -SYMBOLS: +transient+ +load+ ; +GENERIC: mdb-collection-prop ( object -- mdb-collection ) +GENERIC: mdb-slot-list ( tuple -- string ) -UNION: boolean t POSTPONE: f ; +CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map" +CONSTANT: MDB_COLLECTION "_mdb_col" +CONSTANT: MDB_SLOTDEF_LIST "_mdb_slot_list" -TUPLE: mdb-collection - { name string } - { capped boolean initial: f } - { size integer initial: -1 } - { max integer initial: -1 } - { classes sequence } ; +SYMBOLS: +transient+ +load+ +fieldindex+ +compoundindex+ +deepindex+ ; + +TUPLE: mdb-tuple-collection < mdb-collection { classes sequence } ; +TUPLE: mdb-tuple-index name key ; + +USE: mongodb.persistent >) ( class -- mdb-collection ) - dup props>> [ MDB_COL_PROP ] dip at - [ [ drop ] dip ] - [ superclass [ (mdb-collection>>) ] [ f ] if* ] if* ; inline recursive +: MDB_ADDON_SLOTS ( -- slots ) + { } [ MDB_OID MDB_PROPERTIES ] with-datastack ; inline -: (mdb-slot-definitions>>) ( class -- slot-defs ) - superclasses [ MDB_SLOTOPT_PROP word-prop ] map assoc-combine ; inline +: (mdb-collection) ( class -- mdb-collection ) + dup MDB_COLLECTION word-prop + [ [ drop ] dip ] + [ superclass [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive + +: (mdb-slot-list) ( class -- slot-defs ) + superclasses [ MDB_SLOTDEF_LIST word-prop ] map assoc-combine ; inline : link-class ( class collection -- ) - tuck classes>> ! col class v{} + over classes>> [ 2dup member? [ 2drop ] [ push ] if ] - [ 1vector >>classes ] if* drop ; + [ 1vector >>classes ] if* drop ; inline + +: link-collection ( class collection -- ) + [ swap link-class ] [ MDB_COLLECTION set-word-prop ] 2bi ; inline PRIVATE> -M: tuple-class mdb-collection>> ( tuple -- mdb-collection ) - (mdb-collection>>) ; +M: tuple-class mdb-collection-prop ( tuple -- mdb-collection ) + (mdb-collection) ; -M: mdb-persistent mdb-collection>> ( tuple -- mdb-collection ) - class (mdb-collection>>) ; +M: mdb-persistent mdb-collection-prop ( tuple -- mdb-collection ) + class (mdb-collection) ; -M: mdb-persistent mdb-slot-definitions>> ( tuple -- string ) - class (mdb-slot-definitions>>) ; +M: mdb-persistent mdb-slot-list ( tuple -- string ) + class (mdb-slot-list) ; -M: tuple-class mdb-slot-definitions>> ( class -- assoc ) - (mdb-slot-definitions>>) ; +M: tuple-class mdb-slot-list ( class -- assoc ) + (mdb-slot-list) ; -M: mdb-collection mdb-slot-definitions>> ( collection -- assoc ) - classes>> [ mdb-slot-definitions>> ] map assoc-combine ; - -: link-collection ( class collection -- ) - 2dup link-class - swap [ MDB_COL_PROP ] dip props>> set-at ; inline - -: declared-collections> ( -- assoc ) - MDB_COLLECTIONS mdb-persistent props>> at - [ H{ } clone - [ MDB_COLLECTIONS mdb-persistent props>> set-at ] keep - ] unless* ; - -: ( name -- mdb-collection ) - declared-collections> 2dup key? - [ at ] - [ [ mdb-collection new ] 2dip - [ [ >>name dup ] keep ] dip set-at ] if ; +M: mdb-collection mdb-slot-list ( collection -- assoc ) + classes>> [ mdb-slot-list ] map assoc-combine ; +: collection-map ( -- assoc ) + MDB_COLLECTION_MAP mdb-persistent word-prop + [ mdb-persistent MDB_COLLECTION_MAP H{ } clone + [ set-word-prop ] keep ] unless* ; inline + +: ( name -- mdb-tuple-collection ) + collection-map [ ] [ key? ] 2bi + [ at ] [ [ mdb-tuple-collection new dup ] 2dip + [ [ >>name ] keep ] dip set-at ] if ; + > ] map [ MDB_OID ] dip memq? - [ ] - [ MDB_P_SLOTS prepend ] if ; inline +: mdb-check-slots ( superclass slots -- superclass slots ) + over all-slots [ name>> ] map [ MDB_OID ] dip member? + [ ] [ MDB_ADDON_SLOTS prepend ] if ; inline PRIVATE> : show-persistence-info ( class -- ) H{ } clone - [ [ dup mdb-collection>> "collection" ] dip set-at ] keep - [ [ mdb-slot-definitions>> "slots" ] dip set-at ] keep . ; - -GENERIC: mdb-persisted? ( tuple -- ? ) - -M: mdb-persistent mdb-persisted? ( tuple -- ? ) - _id>> f = not ; - -M: assoc mdb-persisted? ( assoc -- ? ) - [ MDB_OID ] dip key? ; inline + [ [ mdb-collection-prop "collection" ] dip set-at ] 2keep + [ [ mdb-slot-list "slots" ] dip set-at ] keep . ; : MDBTUPLE: parse-tuple-definition - mdb-check-id-slot + mdb-check-slots define-tuple-class ; parsing assoc ( seq -- assoc ) +: opt>assoc ( seq -- assoc ) [ dup assoc? - [ 1array { "" } append ] unless - ] map ; + [ 1array { "" } append ] unless ] map ; + +: optl>map ( seq -- map ) + H{ } clone tuck + '[ split-optl opt>assoc swap _ set-at ] each ; inline + +: set-slot-options ( class options -- ) + '[ MDB_SLOTDEF_LIST _ optl>map set-word-prop ] keep + dup mdb-collection-prop link-collection ; inline PRIVATE> -: set-slot-options ( class options -- ) - H{ } clone tuck '[ _ [ split-olist optl>assoc swap ] dip set-at ] each - over [ MDB_SLOTOPT_PROP ] dip props>> set-at - dup mdb-collection>> link-collection ; - -: define-collection ( class collection options -- ) +: set-collection ( class collection options -- ) [ [ dup ] dip link-collection ] dip ! cl options [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip set-slot-options ; + ] 2dip + [ rest ] keep first ! assoc slot options itype + { { +fieldindex+ [ drop [ 1 ] dip pick set-at ] } + { +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] } + { +compoundindex+ [ + 2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options + over '[ _ [ 1 ] 2dip set-at ] each ] } + } case ; + +: build-index-seq ( slot optlist -- index-seq ) + [ V{ } clone ] 2dip pick ! v{} slot optl v{} + [ swap ] dip ! v{} optl slot v{ } + '[ _ mdb-tuple-index new ! element slot exemplar + 2over swap index-name >>name ! element slot clone + [ build-index ] dip swap >>key _ push + ] each ; + +MEMO: is-index-declaration? ( entry -- ? ) + first + { { +fieldindex+ [ t ] } + { +compoundindex+ [ t ] } + { +deepindex+ [ t ] } + [ drop f ] } case ; + +: build-tuple-index-list ( mdb-collection -- seq ) + mdb-slot-list V{ } clone tuck + '[ [ is-index-declaration? ] filter + build-index-seq _ push + ] assoc-each flatten ; + +PRIVATE> + +: clean-indices ( list list2 -- ) 2drop ; + +: load-tuple-index-list ( mdb-collection -- indexlist ) + [ load-index-list ] dip + '[ [ "ns" ] dip at _ name>> ensure-collection = ] filter ; + +: ensure-tuple-index-list ( mdb-collection -- ) + [ build-tuple-index-list ] keep + '[ [ _ name>> ] dip [ name>> ] [ key>> ] bi ensure-index ] each ; From 83b251feee9677d888bd541eb4e6876696bcdc3d Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 2 Mar 2009 06:44:35 +0100 Subject: [PATCH 039/772] removed tuple integration from main branch --- mongodb/persistent/persistent.factor | 117 ------------------ mongodb/tuple/tuple.factor | 170 --------------------------- 2 files changed, 287 deletions(-) delete mode 100644 mongodb/persistent/persistent.factor delete mode 100644 mongodb/tuple/tuple.factor diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor deleted file mode 100644 index dc5ddb614b..0000000000 --- a/mongodb/persistent/persistent.factor +++ /dev/null @@ -1,117 +0,0 @@ -USING: accessors assocs classes fry kernel linked-assocs math mirrors -namespaces sequences strings vectors words bson.constants -continuations mongodb.driver mongodb.tuple ; - -IN: mongodb.persistent - -SYMBOL: mdb-op-seq - -GENERIC# tuple>assoc 1 ( tuple exemplar -- assoc ) - -: tuple>linked-assoc ( tuple -- linked-assoc ) - tuple>assoc ; inline - -GENERIC# tuple>query 1 ( tuple examplar -- query-assoc ) - -DEFER: assoc>tuple -DEFER: create-mdb-command - - ( tuple -- objref ) - [ mdb-collection-prop ] [ _id>> ] bi objref boa ; inline - -: mdbinfo>tuple-class ( mdbinfo -- class ) - [ first ] keep second lookup ; inline - -: make-tuple ( assoc -- tuple ) - [ MDB_INFO swap at mdbinfo>tuple-class new ] keep ! instance assoc - [ dup [ keys ] keep ] dip ! instance array mirror assoc - '[ dup _ [ _ at assoc>tuple ] dip [ swap ] dip set-at ] each ; - -: persistent-info ( tuple -- pinfo ) - class V{ } clone tuck - [ [ name>> ] dip push ] - [ [ vocabulary>> ] dip push ] 2bi ; inline - -: id-or-f? ( key value -- key value boolean ) - over "_id" = - [ dup f = ] dip or ; inline - -: write-persistent-info ( mirror exemplar assoc -- ) - [ drop ] dip - 2dup [ "_id" ] 2dip [ over [ at ] dip ] dip set-at - [ object>> persistent-info MDB_INFO ] dip set-at ; - -: persistent-tuple? ( object -- object boolean ) - dup mdb-persistent? ; inline - -: ensure-value-ht ( key ht -- vht ) - 2dup key? - [ at ] - [ [ H{ } clone dup ] 2dip set-at ] if ; inline - -: data-tuple? ( tuple -- ? ) - dup tuple? [ assoc? [ f ] [ t ] if ] [ drop f ] if ; - -: write-tuple-fields ( mirror exemplar assoc -- ) - [ dup ] dip ! m e e a - '[ id-or-f? - [ 2drop ] - [ persistent-tuple? - [ _ keep - [ mdb-collection>> ] keep - [ create-mdb-command ] dip - ] - [ dup data-tuple? _ [ ] if ] if - swap _ set-at - ] if - ] assoc-each ; - -: prepare-assoc ( tuple exemplar -- assoc mirror exemplar assoc ) - [ ] dip dup clone swap [ tuck ] dip swap ; inline - -: ensure-mdb-info ( tuple -- tuple ) - dup _id>> [ >>_id ] unless ; inline - -: with-op-seq ( quot -- op-seq ) - [ - [ H{ } clone mdb-op-seq set ] dip call mdb-op-seq get - ] with-scope ; inline - -PRIVATE> - -: create-mdb-command ( assoc ns -- ) - mdb-op-seq get - ensure-value-ht - [ dup [ MDB_OID ] dip at ] dip - set-at ; inline - -: prepare-store ( mdb-persistent -- op-seq ) - '[ _ [ tuple>linked-assoc ] keep mdb-collection>> create-mdb-command ] - with-op-seq ; inline - -M: mdb-persistent tuple>assoc ( tuple exemplar -- assoc ) - [ ensure-mdb-info ] dip ! tuple exemplar - prepare-assoc - [ write-persistent-info ] - [ [ '[ _ tuple>assoc ] ] dip write-tuple-fields ] 3bi ; - -M: tuple tuple>assoc ( tuple exemplar -- assoc ) - [ drop persistent-info MDB_INFO ] 2keep - prepare-assoc [ '[ _ tuple>assoc ] ] write-tuple-fields - [ set-at ] keep ; - -M: tuple tuple>query ( tuple examplar -- assoc ) - prepare-assoc [ '[ _ tuple>query ] ] dip write-tuple-fields ; - -: assoc>tuple ( assoc -- tuple ) - dup assoc? - [ [ dup MDB_INFO swap key? - [ make-tuple ] - [ ] if ] [ drop ] recover - ] [ ] if ; inline - - diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor deleted file mode 100644 index 34591a5d4a..0000000000 --- a/mongodb/tuple/tuple.factor +++ /dev/null @@ -1,170 +0,0 @@ -USING: accessors assocs classes classes.mixin classes.tuple vectors math -classes.tuple.parser formatting generalizations kernel sequences fry combinators -linked-assocs sequences.deep mongodb.driver continuations memoize -prettyprint strings compiler.units slots tools.walker words arrays ; - -IN: mongodb.tuple - -MIXIN: mdb-persistent - -SLOT: _id -SLOT: _mdb_ - -GENERIC: mdb-collection-prop ( object -- mdb-collection ) -GENERIC: mdb-slot-list ( tuple -- string ) - -CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map" -CONSTANT: MDB_COLLECTION "_mdb_col" -CONSTANT: MDB_SLOTDEF_LIST "_mdb_slot_list" - -SYMBOLS: +transient+ +load+ +fieldindex+ +compoundindex+ +deepindex+ ; - -TUPLE: mdb-tuple-collection < mdb-collection { classes sequence } ; -TUPLE: mdb-tuple-index name key ; - -USE: mongodb.persistent - -> - [ 2dup member? [ 2drop ] [ push ] if ] - [ 1vector >>classes ] if* drop ; inline - -: link-collection ( class collection -- ) - [ swap link-class ] [ MDB_COLLECTION set-word-prop ] 2bi ; inline - -PRIVATE> - -M: tuple-class mdb-collection-prop ( tuple -- mdb-collection ) - (mdb-collection) ; - -M: mdb-persistent mdb-collection-prop ( tuple -- mdb-collection ) - class (mdb-collection) ; - -M: mdb-persistent mdb-slot-list ( tuple -- string ) - class (mdb-slot-list) ; - -M: tuple-class mdb-slot-list ( class -- assoc ) - (mdb-slot-list) ; - -M: mdb-collection mdb-slot-list ( collection -- assoc ) - classes>> [ mdb-slot-list ] map assoc-combine ; - -: collection-map ( -- assoc ) - MDB_COLLECTION_MAP mdb-persistent word-prop - [ mdb-persistent MDB_COLLECTION_MAP H{ } clone - [ set-word-prop ] keep ] unless* ; inline - -: ( name -- mdb-tuple-collection ) - collection-map [ ] [ key? ] 2bi - [ at ] [ [ mdb-tuple-collection new dup ] 2dip - [ [ >>name ] keep ] dip set-at ] if ; - -> ] map [ MDB_OID ] dip member? - [ ] [ MDB_ADDON_SLOTS prepend ] if ; inline - -PRIVATE> - -: show-persistence-info ( class -- ) - H{ } clone - [ [ mdb-collection-prop "collection" ] dip set-at ] 2keep - [ [ mdb-slot-list "slots" ] dip set-at ] keep . ; - -: MDBTUPLE: - parse-tuple-definition - mdb-check-slots - define-tuple-class ; parsing - -assoc ( seq -- assoc ) - [ dup assoc? - [ 1array { "" } append ] unless ] map ; - -: optl>map ( seq -- map ) - H{ } clone tuck - '[ split-optl opt>assoc swap _ set-at ] each ; inline - -: set-slot-options ( class options -- ) - '[ MDB_SLOTDEF_LIST _ optl>map set-word-prop ] keep - dup mdb-collection-prop link-collection ; inline - -PRIVATE> - -: set-collection ( class collection options -- ) - [ [ dup ] dip link-collection ] dip ! cl options - [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip - set-slot-options ; - - ] 2dip - [ rest ] keep first ! assoc slot options itype - { { +fieldindex+ [ drop [ 1 ] dip pick set-at ] } - { +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] } - { +compoundindex+ [ - 2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options - over '[ _ [ 1 ] 2dip set-at ] each ] } - } case ; - -: build-index-seq ( slot optlist -- index-seq ) - [ V{ } clone ] 2dip pick ! v{} slot optl v{} - [ swap ] dip ! v{} optl slot v{ } - '[ _ mdb-tuple-index new ! element slot exemplar - 2over swap index-name >>name ! element slot clone - [ build-index ] dip swap >>key _ push - ] each ; - -MEMO: is-index-declaration? ( entry -- ? ) - first - { { +fieldindex+ [ t ] } - { +compoundindex+ [ t ] } - { +deepindex+ [ t ] } - [ drop f ] } case ; - -: build-tuple-index-list ( mdb-collection -- seq ) - mdb-slot-list V{ } clone tuck - '[ [ is-index-declaration? ] filter - build-index-seq _ push - ] assoc-each flatten ; - -PRIVATE> - -: clean-indices ( list list2 -- ) 2drop ; - -: load-tuple-index-list ( mdb-collection -- indexlist ) - [ load-index-list ] dip - '[ [ "ns" ] dip at _ name>> ensure-collection = ] filter ; - -: ensure-tuple-index-list ( mdb-collection -- ) - [ build-tuple-index-list ] keep - '[ [ _ name>> ] dip [ name>> ] [ key>> ] bi ensure-index ] each ; From e21f36769119b58cc20f1e64df6bce49bcfa5a44 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 2 Mar 2009 06:53:32 +0100 Subject: [PATCH 040/772] removed mongodb.factor isn't needed until tuple integration really works --- mongodb/mongodb.factor | 50 ------------------------------------------ 1 file changed, 50 deletions(-) delete mode 100644 mongodb/mongodb.factor diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor deleted file mode 100644 index 28ca6acc25..0000000000 --- a/mongodb/mongodb.factor +++ /dev/null @@ -1,50 +0,0 @@ -USING: accessors assocs combinators fry io.encodings.binary -io.sockets kernel math math.parser mongodb.driver -mongodb.msg mongodb.operations mongodb.persistent -mongodb.tuple namespaces -sequences splitting ; - -IN: mongodb - -! generic methods -GENERIC: store ( tuple/ht -- ) -GENERIC: find ( example -- tuple/ht ) -GENERIC# nfind 1 ( example n -- tuple/ht ) -GENERIC: load ( object -- object ) -GENERIC: explain ( object -- object ) - -> get-collection-fqn ] keep - H{ } tuple>query ; inline - -TUPLE: mdb-result { cursor integer } -{ start# integer } -{ returned# integer } -{ objects sequence } ; - -: build-result ( resultmsg -- mdb-result ) - [ mdb-result new ] dip - { - [ cursor>> >>cursor ] - [ start#>> >>start# ] - [ returned#>> >>returned# ] - [ objects>> [ assoc>tuple ] map >>objects ] - } cleave ; - -PRIVATE> - -M: mdb-persistent store ( tuple -- ) - prepare-store ! H { collection { ... values ... } - [ [ get-collection-fqn ] dip - values send-message - ] assoc-each ; - -M: mdb-persistent find ( example -- result ) - prepare-find [ mdb>> master>> ] dip send-query - build-result ; - -M: mdb-persistent nfind ( example n -- result ) - [ prepare-find ] dip >>return# - send-query build-result ; From 22a891b4832ea34f905298ba4700370f267bd72a Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 2 Mar 2009 18:44:24 +0100 Subject: [PATCH 041/772] added _id handling; the _id field must always be the first field in a bson document. Handling it at this "low" level makes things easier in the layers above --- bson/constants/constants.factor | 2 ++ bson/writer/writer.factor | 11 +++++++++-- mongodb/operations/operations.factor | 4 ++-- 3 files changed, 13 insertions(+), 4 deletions(-) diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index 039ea18089..368374fb30 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -11,6 +11,8 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ; TUPLE: objref ns objid ; +CONSTANT: MDB_OID_FIELD "_id" + CONSTANT: T_EOO 0 CONSTANT: T_Double 1 CONSTANT: T_Integer 16 diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 439cfb7372..55adb95b11 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -93,9 +93,16 @@ M: sequence bson-write ( array -- ) [ length 5 + bson-write ] keep write write-eoo ; - + +: write-oid ( hashtable -- ) + [ MDB_OID_FIELD ] dip at* + [ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline + +: oid-field? ( name -- boolean ) + MDB_OID_FIELD = ; inline + M: assoc bson-write ( hashtable -- ) - '[ _ [ write-pair ] assoc-each ] + '[ _ [ write-oid ] [ [ over oid-field? [ 2drop ] [ write-pair ] if ] assoc-each ] bi ] binary swap with-byte-writer [ length 5 + bson-write ] keep write diff --git a/mongodb/operations/operations.factor b/mongodb/operations/operations.factor index e628251103..75207cf30b 100644 --- a/mongodb/operations/operations.factor +++ b/mongodb/operations/operations.factor @@ -120,7 +120,7 @@ M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) read-longlong >>cursor read-int32 >>start# read-int32 [ >>returned# ] keep - [ stream>assoc drop ] accumulator [ times ] dip >>objects ; + [ H{ } stream>assoc drop ] accumulator [ times ] dip >>objects ; : read-header ( message -- message ) read-int32 >>length @@ -151,7 +151,7 @@ PRIVATE> write flush ; inline : build-query-object ( query -- selector ) - [let | selector [ ] | + [let | selector [ H{ } clone ] | { [ orderby>> [ "orderby" selector set-at ] when* ] [ explain>> [ "$explain" selector set-at ] when* ] [ hint>> [ "$hint" selector set-at ] when* ] From 75c28ee62f0f9c0b3be372b0c41ddbcbf6921d35 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Tue, 3 Mar 2009 16:26:54 +0100 Subject: [PATCH 042/772] renamed some things moved _id and _mdb_ constants to bson vocab --- bson/constants/constants.factor | 1 + bson/writer/writer.factor | 14 +++++++------- mongodb/driver/driver.factor | 33 ++++++++++++++++----------------- mongodb/msg/msg.factor | 4 ++-- 4 files changed, 26 insertions(+), 26 deletions(-) diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index 368374fb30..be9f9466b5 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -12,6 +12,7 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ; TUPLE: objref ns objid ; CONSTANT: MDB_OID_FIELD "_id" +CONSTANT: MDB_INTERNAL_FIELD "_mdb_" CONSTANT: T_EOO 0 CONSTANT: T_Double 1 diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 55adb95b11..de764220be 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -3,7 +3,7 @@ USING: accessors assocs bson.constants byte-arrays fry io io.binary io.encodings.binary io.encodings.string io.encodings.utf8 io.streams.byte-array kernel math math.parser quotations sequences -serialize strings words ; +serialize strings words hashtables ; IN: bson.writer @@ -20,10 +20,10 @@ M: f bson-type? ( boolean -- type ) drop T_Boolean ; M: real bson-type? ( real -- type ) drop T_Double ; M: word bson-type? ( word -- type ) drop T_String ; M: tuple bson-type? ( tuple -- type ) drop T_Object ; -M: assoc bson-type? ( hashtable -- type ) drop T_Object ; +M: sequence bson-type? ( seq -- type ) drop T_Array ; M: string bson-type? ( string -- type ) drop T_String ; M: integer bson-type? ( integer -- type ) drop T_Integer ; -M: sequence bson-type? ( seq -- type ) drop T_Array ; +M: hashtable bson-type? ( hashtable -- type ) drop T_Object ; M: oid bson-type? ( word -- type ) drop T_OID ; M: objid bson-type? ( objid -- type ) drop T_Binary ; @@ -98,11 +98,11 @@ M: sequence bson-write ( array -- ) [ MDB_OID_FIELD ] dip at* [ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline -: oid-field? ( name -- boolean ) - MDB_OID_FIELD = ; inline +: skip-field? ( name -- boolean ) + { MDB_OID_FIELD MDB_INTERNAL_FIELD } member? ; inline -M: assoc bson-write ( hashtable -- ) - '[ _ [ write-oid ] [ [ over oid-field? [ 2drop ] [ write-pair ] if ] assoc-each ] bi ] +M: hashtable bson-write ( hashtable -- ) + '[ _ [ write-oid ] [ [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each ] bi ] binary swap with-byte-writer [ length 5 + bson-write ] keep write diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 6337452174..e9557a49ca 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -6,7 +6,7 @@ IN: mongodb.driver TUPLE: mdb-node master? inet ; -TUPLE: mdb name nodes collections ; +TUPLE: mdb-db name nodes collections ; TUPLE: mdb-cursor collection id return# ; @@ -23,9 +23,6 @@ CONSTRUCTOR: mdb-collection ( name -- collection ) ; CONSTANT: MDB-GENERAL-ERROR 1 -CONSTANT: MDB_OID "_id" -CONSTANT: MDB_PROPERTIES "_mdb_" - CONSTANT: PARTIAL? "partial?" CONSTANT: DIRTY? "dirty?" @@ -43,8 +40,10 @@ SYMBOL: mdb-socket-stream PRIVATE> -: mdb>> ( -- mdb ) - mdb get ; inline +SYMBOL: mdb-instance + +: mdb ( -- mdb ) + mdb-instance get ; inline : master>> ( mdb -- inet ) nodes>> [ t ] dip at inet>> ; @@ -53,7 +52,7 @@ PRIVATE> nodes>> [ f ] dip at inet>> ; : with-db ( mdb quot -- ... ) - [ [ '[ _ [ mdb set ] keep master>> + [ [ '[ _ [ mdb-instance set ] keep master>> [ remote-address set ] keep binary local-address set @@ -64,16 +63,16 @@ PRIVATE> > name>> "%s.system.indexes" sprintf ; inline + mdb name>> "%s.system.indexes" sprintf ; inline : namespaces-collection ( -- ns ) - mdb>> name>> "%s.system.namespaces" sprintf ; inline + mdb name>> "%s.system.namespaces" sprintf ; inline : cmd-collection ( -- ns ) - mdb>> name>> "%s.$cmd" sprintf ; inline + mdb name>> "%s.$cmd" sprintf ; inline : index-ns ( colname -- index-ns ) - [ mdb>> name>> ] dip "%s.%s" sprintf ; inline + [ mdb name>> ] dip "%s.%s" sprintf ; inline : ismaster-cmd ( node -- result ) binary "admin.$cmd" H{ { "ismaster" 1 } } @@ -103,11 +102,11 @@ PRIVATE> ] when* ; : verify-nodes ( -- ) - mdb>> nodes>> [ t ] dip at + mdb nodes>> [ t ] dip at check-nodes H{ } clone tuck '[ dup master?>> _ set-at ] each - [ mdb>> ] dip >>nodes drop ; + [ mdb ] dip >>nodes drop ; : send-message ( message -- ) [ mdb-stream>> ] dip '[ _ write-message ] with-stream* ; @@ -133,7 +132,7 @@ PRIVATE> check-nodes H{ } clone tuck '[ dup master?>> _ set-at ] each - H{ } clone mdb boa ; + H{ } clone mdb-db boa ; : create-collection ( name -- ) [ cmd-collection ] dip @@ -152,7 +151,7 @@ PRIVATE> '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline : (ensure-collection) ( collection -- ) - mdb>> collections>> dup keys length 0 = + mdb collections>> dup keys length 0 = [ load-collection-list [ [ "options" ] dip key? ] filter [ [ "name" ] dip at "." split second ] map @@ -166,11 +165,11 @@ MEMO: reserved-namespace? ( name -- ? ) PRIVATE> MEMO: ensure-collection ( collection -- fq-collection ) - "." split1 over mdb>> name>> = + "." split1 over mdb name>> = [ [ drop ] dip ] [ drop ] if [ ] [ reserved-namespace? ] bi [ [ (ensure-collection) ] keep ] unless - [ mdb>> name>> ] dip "%s.%s" sprintf ; inline + [ mdb name>> ] dip "%s.%s" sprintf ; inline : ( collection query -- mdb-query ) [ ensure-collection ] dip diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index 636e5e6755..7d1a8058b0 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -1,4 +1,4 @@ -USING: accessors assocs constructors kernel linked-assocs math +USING: accessors assocs hashtables constructors kernel linked-assocs math sequences strings ; IN: mongodb.msg @@ -86,7 +86,7 @@ M: sequence ( collection sequence -- mdb-insert-msg ) [ >>collection ] dip >>objects OP_Insert >>opcode ; -M: assoc ( collection assoc -- mdb-insert-msg ) +M: hashtable ( collection assoc -- mdb-insert-msg ) [ mdb-insert-msg new ] 2dip [ >>collection ] dip V{ } clone tuck push From 66cf30ac1c3982ab597c9fdd994689982305bc04 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Tue, 3 Mar 2009 22:44:24 +0100 Subject: [PATCH 043/772] made most "front" methods generic switched back to assoc generic type --- bson/writer/writer.factor | 8 +++--- mongodb/driver/driver.factor | 55 ++++++++++++++++++++++++++---------- 2 files changed, 44 insertions(+), 19 deletions(-) diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index de764220be..3859f314e2 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -3,7 +3,7 @@ USING: accessors assocs bson.constants byte-arrays fry io io.binary io.encodings.binary io.encodings.string io.encodings.utf8 io.streams.byte-array kernel math math.parser quotations sequences -serialize strings words hashtables ; +serialize strings words ; IN: bson.writer @@ -23,7 +23,7 @@ M: tuple bson-type? ( tuple -- type ) drop T_Object ; M: sequence bson-type? ( seq -- type ) drop T_Array ; M: string bson-type? ( string -- type ) drop T_String ; M: integer bson-type? ( integer -- type ) drop T_Integer ; -M: hashtable bson-type? ( hashtable -- type ) drop T_Object ; +M: assoc bson-type? ( assoc -- type ) drop T_Object ; M: oid bson-type? ( word -- type ) drop T_OID ; M: objid bson-type? ( objid -- type ) drop T_Binary ; @@ -94,14 +94,14 @@ M: sequence bson-write ( array -- ) write write-eoo ; -: write-oid ( hashtable -- ) +: write-oid ( assoc -- ) [ MDB_OID_FIELD ] dip at* [ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline : skip-field? ( name -- boolean ) { MDB_OID_FIELD MDB_INTERNAL_FIELD } member? ; inline -M: hashtable bson-write ( hashtable -- ) +M: assoc bson-write ( assoc -- ) '[ _ [ write-oid ] [ [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each ] bi ] binary swap with-byte-writer [ length 5 + bson-write ] keep diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index e9557a49ca..d8e90052d0 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -134,10 +134,21 @@ PRIVATE> '[ dup master?>> _ set-at ] each H{ } clone mdb-db boa ; -: create-collection ( name -- ) +GENERIC: create-collection ( name -- ) +M: string create-collection + create-collection ; + +M: mdb-collection create-collection ( mdb-collection -- ) [ cmd-collection ] dip - "create" H{ } clone [ set-at ] keep - 1 >>return# send-query-plain objects>> first check-ok + [ + [ [ name>> "create" ] dip set-at ] + [ [ [ capped>> ] keep ] dip + '[ _ _ + [ [ drop t "capped" ] dip set-at ] + [ [ size>> "size" ] dip set-at ] + [ [ max>> "max" ] dip set-at ] 2tri ] when + ] 2bi + ] keep 1 >>return# send-query-plain objects>> first check-ok [ "could not create collection" throw ] unless ; : load-collection-list ( -- collection-list ) @@ -194,10 +205,12 @@ GENERIC# hint 1 ( mdb-query index-hint -- mdb-query ) M: mdb-query-msg hint ( mdb-query index-hint -- mdb-query ) >>hint ; -: find ( mdb-query -- cursor result ) +GENERIC: find ( mdb-query -- cursor result ) +M: mdb-query-msg find send-query ; -: explain ( mdb-query -- result ) +GENERIC: explain ( mdb-query -- result ) +M: mdb-query-msg explain t >>explain find [ drop ] dip ; GENERIC: get-more ( mdb-cursor -- mdb-cursor objects ) @@ -205,10 +218,12 @@ M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects ) [ [ collection>> ] [ return#>> ] [ id>> ] tri send-query ] [ f f ] if* ; -: find-one ( mdb-query -- result ) +GENERIC: find-one ( mdb-query -- result ) +M: mdb-query-msg find-one 1 >>return# send-query-plain ; -: count ( collection query -- result ) +GENERIC: count ( collection query -- result ) +M: assoc count [ "count" H{ } clone [ set-at ] keep ] dip [ over [ "query" ] dip set-at ] when* [ cmd-collection ] dip find-one objects>> first @@ -218,11 +233,14 @@ M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects ) cmd-collection H{ { "getlasterror" 1 } } find-one objects>> [ "err" ] at ; -: validate ( collection -- ) +GENERIC: validate ( collection -- ) +M: string validate [ cmd-collection ] dip "validate" H{ } clone [ set-at ] keep find-one objects>> first [ check-ok ] keep '[ "result" _ at print ] when ; +M: mdb-collection validate + name>> validate ; -: save ( collection object -- ) +GENERIC: save ( collection assoc -- ) +M: assoc save [ ensure-collection ] dip send-message-check-error ; -: save-unsafe ( collection object -- ) +GENERIC: save-unsafe ( collection object -- ) +M: assoc save-unsafe [ ensure-collection ] dip send-message ; -: ensure-index ( collection name spec -- ) +GENERIC: ensure-index ( collection name spec -- ) +M: assoc ensure-index H{ } clone [ [ "key" ] dip set-at ] keep [ [ "name" ] dip set-at ] keep @@ -254,19 +275,23 @@ PRIVATE> [ cmd-collection ] dip find-one objects>> first check-ok [ "could not drop index" throw ] unless ; -: update ( collection selector object -- ) +GENERIC: update ( collection selector object -- ) +M: assoc update [ ensure-collection ] dip send-message-check-error ; -: update-unsafe ( collection selector object -- ) +GENERIC: update-unsafe ( collection selector object -- ) +M: assoc update-unsafe [ ensure-collection ] dip send-message ; -: delete ( collection selector -- ) +GENERIC: delete ( collection selector -- ) +M: assoc delete [ ensure-collection ] dip send-message-check-error ; -: delete-unsafe ( collection selector -- ) +GENERIC: delete-unsafe ( collection selector -- ) +M: assoc delete-unsafe [ ensure-collection ] dip send-message ; From 208620336f58d93c3e5fbf00e565c4db9f7e9564 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 4 Mar 2009 06:59:40 +0100 Subject: [PATCH 044/772] added a short example to README.txt --- README.txt | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/README.txt b/README.txt index bb91f56c33..467e8581fc 100644 --- a/README.txt +++ b/README.txt @@ -1,2 +1,27 @@ This is the attempt to implement a driver for MongoDB (http://www.mongodb.org) in Factor (http://www.factorcode.org). + +Usage example (for a quick overview): + +USE: mongodb.driver + +! 1. initialize mdb +! database host port +"db" "127.0.0.1" 27017 + +! 2. create an index +! [ collection name spec ensure-index ] with-db +dup [ "test" "idIdx" H{ { "_id" 1 } } ensure-index ] with-db + +! 3. insert an object +! [ collection object save ] with-db +dup [ "test" H{ { "_id" "12345" } { "name" "myobject" } } save ] with-db + +! 4. find the object +! [ collection example ..options.. find ] with-db +dup [ "test" H{ { "_id" "12345" } } find ] with-db + +! a find with options would look like this + +dup [ "test" H{ { "name" "myobject" } } 10 limit + [ "_id" asc "name" desc ] sort find ] with-db From 87f0eeb282e8fcaa9262d610bc34944586461c1e Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 5 Mar 2009 07:01:12 +0100 Subject: [PATCH 045/772] fixed bug in bson.writer which caused any field name "_id" to be written twice, fixed lasterror in mongodb.driver --- bson/writer/writer.factor | 10 ++++++---- mongodb/driver/driver.factor | 5 +++-- mongodb/mmm/mmm.factor | 4 ++-- 3 files changed, 11 insertions(+), 8 deletions(-) diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 3859f314e2..db452f4029 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -3,7 +3,7 @@ USING: accessors assocs bson.constants byte-arrays fry io io.binary io.encodings.binary io.encodings.string io.encodings.utf8 io.streams.byte-array kernel math math.parser quotations sequences -serialize strings words ; +serialize strings words tools.hexdump ; IN: bson.writer @@ -99,11 +99,13 @@ M: sequence bson-write ( array -- ) [ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline : skip-field? ( name -- boolean ) - { MDB_OID_FIELD MDB_INTERNAL_FIELD } member? ; inline + { "_id" "_mdb" } member? ; inline M: assoc bson-write ( assoc -- ) - '[ _ [ write-oid ] [ [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each ] bi ] - binary swap with-byte-writer + [ binary ] dip + '[ _ [ write-oid ] keep + [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each + ] with-byte-writer [ length 5 + bson-write ] keep write write-eoo ; diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index d8e90052d0..ee899522cc 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -1,6 +1,6 @@ USING: accessors assocs fry io.sockets kernel math mongodb.msg formatting linked-assocs destructors continuations mongodb.operations namespaces sequences splitting math.parser io.encodings.binary combinators io.streams.duplex -arrays io memoize constructors sets strings ; +arrays io memoize constructors sets strings uuid ; IN: mongodb.driver @@ -231,7 +231,7 @@ M: assoc count : lasterror ( -- error ) cmd-collection H{ { "getlasterror" 1 } } - find-one objects>> [ "err" ] at ; + find-one objects>> first [ "err" ] dip at ; GENERIC: validate ( collection -- ) M: string validate @@ -262,6 +262,7 @@ M: assoc save-unsafe GENERIC: ensure-index ( collection name spec -- ) M: assoc ensure-index H{ } clone + [ [ uuid1 "_id" ] dip set-at ] keep [ [ "key" ] dip set-at ] keep [ [ "name" ] dip set-at ] keep [ [ index-ns "ns" ] dip set-at ] keep diff --git a/mongodb/mmm/mmm.factor b/mongodb/mmm/mmm.factor index ce942ce67b..467070859e 100644 --- a/mongodb/mmm/mmm.factor +++ b/mongodb/mmm/mmm.factor @@ -1,7 +1,7 @@ USING: accessors fry io io.encodings.binary io.servers.connection io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting -mongodb.msg.private namespaces prettyprint tools.walker calendar calendar.format -json.writer ; +namespaces prettyprint tools.walker calendar calendar.format +json.writer mongodb.operations.private mongodb.operations ; IN: mongodb.mmm From fbae728a2ee771dbcd3694b808fa2f46d71a705a Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 6 Mar 2009 14:37:11 +0100 Subject: [PATCH 046/772] added support (write/read) for timestamps --- bson/reader/reader.factor | 6 +++++- bson/writer/writer.factor | 6 +++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index 44eadef973..ca2d5a5bb3 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -1,6 +1,6 @@ USING: accessors assocs bson.constants byte-arrays byte-vectors fry io io.binary io.encodings.string io.encodings.utf8 kernel math namespaces -sequences serialize arrays ; +sequences serialize arrays calendar ; IN: bson.reader @@ -168,6 +168,10 @@ M: bson-boolean element-data-read ( type -- boolean ) drop read-byte t = ; +M: bson-date element-data-read ( type -- timestamp ) + drop + read-longlong millis>timestamp ; + M: bson-binary element-data-read ( type -- binary ) drop read-int32 read-byte element-binary-read ; diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index db452f4029..6db25b7d1c 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -3,7 +3,7 @@ USING: accessors assocs bson.constants byte-arrays fry io io.binary io.encodings.binary io.encodings.string io.encodings.utf8 io.streams.byte-array kernel math math.parser quotations sequences -serialize strings words tools.hexdump ; +serialize strings words calendar ; IN: bson.writer @@ -24,6 +24,7 @@ M: sequence bson-type? ( seq -- type ) drop T_Array ; M: string bson-type? ( string -- type ) drop T_String ; M: integer bson-type? ( integer -- type ) drop T_Integer ; M: assoc bson-type? ( assoc -- type ) drop T_Object ; +M: timestamp bson-type? ( timestamp -- type ) drop T_Date ; M: oid bson-type? ( word -- type ) drop T_OID ; M: objid bson-type? ( objid -- type ) drop T_Binary ; @@ -59,6 +60,9 @@ M: integer bson-write ( num -- ) M: real bson-write ( num -- ) >float write-double ; +M: timestamp bson-write ( timestamp -- ) + timestamp>millis write-longlong ; + M: byte-array bson-write ( binary -- ) [ length write-int32 ] keep T_Binary_Bytes write-byte From cdb2e6e565f1019e0092b522674c9daa05c87b37 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 6 Mar 2009 22:56:02 +0100 Subject: [PATCH 047/772] added doc skeletons --- bson/reader/reader-docs.factor | 17 ++ bson/writer/writer-docs.factor | 23 ++ mongodb/driver/driver-docs.factor | 306 ++++++++++++++++++++++ mongodb/operations/operations-docs.factor | 23 ++ 4 files changed, 369 insertions(+) create mode 100644 bson/reader/reader-docs.factor create mode 100644 bson/writer/writer-docs.factor create mode 100644 mongodb/driver/driver-docs.factor create mode 100644 mongodb/operations/operations-docs.factor diff --git a/bson/reader/reader-docs.factor b/bson/reader/reader-docs.factor new file mode 100644 index 0000000000..be300f4be6 --- /dev/null +++ b/bson/reader/reader-docs.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2009 Your name. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs help.markup help.syntax kernel ; +IN: bson.reader + +HELP: stream>assoc +{ $values + { "exemplar" null } + { "assoc" assoc } { "bytes-read" null } +} +{ $description "" } ; + +ARTICLE: "bson.reader" "bson.reader" +{ $vocab-link "bson.reader" } +; + +ABOUT: "bson.reader" diff --git a/bson/writer/writer-docs.factor b/bson/writer/writer-docs.factor new file mode 100644 index 0000000000..cbcf1d2659 --- /dev/null +++ b/bson/writer/writer-docs.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2009 Your name. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs help.markup help.syntax kernel ; +IN: bson.writer + +HELP: assoc>array +{ $values + { "assoc" assoc } + { "byte-array" null } +} +{ $description "" } ; + +HELP: assoc>stream +{ $values + { "assoc" assoc } +} +{ $description "" } ; + +ARTICLE: "bson.writer" "bson.writer" +{ $vocab-link "bson.writer" } +; + +ABOUT: "bson.writer" diff --git a/mongodb/driver/driver-docs.factor b/mongodb/driver/driver-docs.factor new file mode 100644 index 0000000000..d06bbe4ed4 --- /dev/null +++ b/mongodb/driver/driver-docs.factor @@ -0,0 +1,306 @@ +! Copyright (C) 2009 Your name. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs help.markup help.syntax kernel quotations ; +IN: mongodb.driver + +HELP: +{ $values + { "name" null } + { "collection" null } +} +{ $description "" } ; + +HELP: +{ $values + { "id" null } { "collection" null } { "return#" null } + { "cursor" null } +} +{ $description "" } ; + +HELP: +{ $values + { "db" null } { "host" null } { "port" null } + { "mdb" null } +} +{ $description "" } ; + +HELP: +{ $values + { "collection" "the collection to be queried" } { "query" "query" } + { "mdb-query" "mdb-query-msg tuple instance" } +} +{ $description "create a new query instance" } ; + +HELP: DIRTY? +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: MDB-GENERAL-ERROR +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: PARTIAL? +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: asc +{ $values + { "key" null } + { "spec" null } +} +{ $description "" } ; + +HELP: boolean +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: count +{ $values + { "collection" null } { "query" null } + { "result" null } +} +{ $description "" } ; + +HELP: create-collection +{ $values + { "name" null } +} +{ $description "" } ; + +HELP: delete +{ $values + { "collection" null } { "selector" null } +} +{ $description "" } ; + +HELP: delete-unsafe +{ $values + { "collection" null } { "selector" null } +} +{ $description "" } ; + +HELP: desc +{ $values + { "key" null } + { "spec" null } +} +{ $description "" } ; + +HELP: drop-collection +{ $values + { "name" null } +} +{ $description "" } ; + +HELP: drop-index +{ $values + { "collection" null } { "name" null } +} +{ $description "" } ; + +HELP: ensure-collection +{ $values + { "collection" null } + { "fq-collection" null } +} +{ $description "" } ; + +HELP: ensure-index +{ $values + { "collection" null } { "name" null } { "spec" null } +} +{ $description "" } ; + +HELP: explain +{ $values + { "mdb-query" null } + { "result" null } +} +{ $description "" } ; + +HELP: find +{ $values + { "mdb-query" null } + { "cursor" null } { "result" null } +} +{ $description "" } ; + +HELP: find-one +{ $values + { "mdb-query" null } + { "result" null } +} +{ $description "" } ; + +HELP: get-more +{ $values + { "mdb-cursor" null } + { "mdb-cursor" null } { "objects" null } +} +{ $description "" } ; + +HELP: hint +{ $values + { "mdb-query" null } { "index-hint" null } + { "mdb-query" null } +} +{ $description "" } ; + +HELP: lasterror +{ $values + + { "error" null } +} +{ $description "" } ; + +HELP: limit +{ $values + { "mdb-query" null } { "limit#" null } + { "mdb-query" null } +} +{ $description "" } ; + +HELP: load-collection-list +{ $values + + { "collection-list" null } +} +{ $description "" } ; + +HELP: load-index-list +{ $values + + { "index-list" null } +} +{ $description "" } ; + +HELP: master>> +{ $values + { "mdb" null } + { "inet" null } +} +{ $description "" } ; + +HELP: mdb +{ $values + + { "mdb" null } +} +{ $description "" } ; + +HELP: mdb-collection +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: mdb-cursor +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: mdb-db +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: mdb-error +{ $values + { "id" null } { "msg" null } +} +{ $description "" } ; + +HELP: mdb-instance +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: mdb-node +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: save +{ $values + { "collection" null } { "assoc" assoc } +} +{ $description "" } ; + +HELP: save-unsafe +{ $values + { "collection" null } { "object" object } +} +{ $description "" } ; + +HELP: skip +{ $values + { "mdb-query" null } { "skip#" null } + { "mdb-query" null } +} +{ $description "" } ; + +HELP: slave>> +{ $values + { "mdb" null } + { "inet" null } +} +{ $description "" } ; + +HELP: sort +{ $values + { "mdb-query" null } { "quot" quotation } + { "mdb-query" null } +} +{ $description "" } ; + +HELP: update +{ $values + { "collection" null } { "selector" null } { "object" object } +} +{ $description "" } ; + +HELP: update-unsafe +{ $values + { "collection" null } { "selector" null } { "object" object } +} +{ $description "" } ; + +HELP: validate +{ $values + { "collection" null } +} +{ $description "" } ; + +HELP: with-db +{ $values + { "mdb" null } { "quot" quotation } + { "..." null } +} +{ $description "" } ; + +ARTICLE: "mongodb.driver" "mongodb.driver" +{ $vocab-link "mongodb.driver" } +; + +ABOUT: "mongodb.driver" diff --git a/mongodb/operations/operations-docs.factor b/mongodb/operations/operations-docs.factor new file mode 100644 index 0000000000..c6d00db1e8 --- /dev/null +++ b/mongodb/operations/operations-docs.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2009 Your name. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel ; +IN: mongodb.operations + +HELP: read-message +{ $values + + { "message" null } +} +{ $description "" } ; + +HELP: write-message +{ $values + { "message" null } +} +{ $description "" } ; + +ARTICLE: "mongodb.operations" "mongodb.operations" +{ $vocab-link "mongodb.operations" } +; + +ABOUT: "mongodb.operations" From f56df9e96547e7f5ce086bafee384d957abcb636 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 6 Mar 2009 22:56:24 +0100 Subject: [PATCH 048/772] added benchmark vocab - @see http://www.mongodb.org/display/DOCS/Performance+Testing --- mongodb/benchmark/benchmark.factor | 192 +++++++++++++++++++++++++++++ 1 file changed, 192 insertions(+) create mode 100644 mongodb/benchmark/benchmark.factor diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor new file mode 100644 index 0000000000..39b6995034 --- /dev/null +++ b/mongodb/benchmark/benchmark.factor @@ -0,0 +1,192 @@ +USING: mongodb.driver calendar math fry kernel assocs math.ranges +sequences formatting combinators namespaces io tools.time prettyprint +accessors words ; + +IN: mongodb.benchmark + +SYMBOLS: per-trial batch-size collection host db port ; + +: get* ( symbol default -- value ) + [ get ] dip or ; inline + +TUPLE: result doc index batch lasterror ; + +: ( -- ) result new result set ; inline + +CONSTANT: DOC-SMALL H{ } + +CONSTANT: DOC-MEDIUM H{ { "integer" 5 } + { "number" 5.05 } + { "boolean" f } + { "array" + { "test" "benchmark" } } } + +CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } + { "total_word_count" 6743 } + { "access_time" f } + { "meta_tags" H{ { "description" "i am a long description string" } + { "author" "Holly Man" } + { "dynamically_created_meta_tag" "who know\n what" } } } + { "page_structure" H{ { "counted_tags" 3450 } + { "no_of_js_attached" 10 } + { "no_of_images" 6 } } } + { "harvested_words" { "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" } } } + +: small-doc ( -- quot: ( i -- doc ) ) + result [ "small" >>doc ] change + DOC-SMALL clone + '[ "x" _ [ set-at ] keep ] ; inline + +: medium-doc ( -- quot: ( i -- doc ) ) + result [ "medium" >>doc ] change + DOC-MEDIUM clone + '[ "x" _ [ set-at ] keep ] ; inline + +: large-doc ( -- quot: ( i -- doc ) ) + result [ "large" >>doc ] change + DOC-LARGE clone + '[ "x" _ [ set-at ] keep + [ now "access-time" ] dip + [ set-at ] keep ] ; + +: (insert) ( quot: ( i -- doc ) collection -- ) + [ per-trial get ] 2dip + '[ _ call [ _ ] dip + result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ; inline + +: (prepare-batch) ( i b quot: ( i -- doc ) -- ) + [ [ * ] keep 1 range boa ] dip + '[ _ call ] map ; inline + +: (insert-batch) ( quot: ( i -- doc ) collection -- ) + [ per-trial get batch-size get [ / ] keep ] 2dip + '[ _ _ (prepare-batch) [ _ ] dip + result get lasterror>> [ save ] [ save-unsafe ] if + ] each-integer ; inline + +: prepare-collection ( -- collection ) + collection "benchmark" get* + [ "_x_idx" drop-index ] keep + [ drop-collection ] keep + [ create-collection ] keep ; inline + +: prepare-index ( collection -- ) + "_x_idx" H{ { "x" 1 } } ensure-index ; inline + +: insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) + prepare-collection + result get index>> [ [ prepare-index ] keep ] when + result get batch>> + [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ; + +: batch ( -- ) + result [ t >>batch ] change ; inline + +: index ( -- ) + result [ t >>index ] change ; inline + +: errcheck ( -- ) + result [ t >>lasterror ] change ; inline + +: bchar ( boolean -- char ) + [ "t" ] [ "f" ] if ; inline + +: print-result ( time -- ) + [ result get [ doc>> ] keep + [ batch>> bchar ] keep + [ index>> bchar ] keep + lasterror>> bchar + per-trial get ] dip + 1000000 / /i + "%-6s: {batch:%s,index:%s;errchk:%s} %7s op/s" + sprintf print flush ; inline + +: print-separator ( -- ) + "-----------------------------------------------" print flush ; inline + +: print-header ( -- ) + per-trial get + batch-size get + "MongoDB Factor Driver Benchmark\n%d ops per Trial, Batch-Size: %d\n" + sprintf print flush + print-separator ; + +: with-result ( quot: ( -- ) -- ) + [ ] prepose + [ print-result ] compose with-scope ; inline + +: run-insert-bench ( doc-word-seq feat-seq -- ) + '[ _ swap + '[ [ [ _ execute ] dip + [ execute ] each insert benchmark ] with-result ] each + print-separator ] each ; + +: run-benchmarks ( -- ) + db "db" get* host "127.0.0.1" get* port 27020 get* + [ + print-header + { small-doc medium-doc large-doc } + { { } { errcheck } { batch } { batch errcheck } + { index } { index errcheck } { batch index errcheck } } run-insert-bench + ] with-db ; + + From ca2459f7291ea5275456ca5af49de2709e8a83d6 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 7 Mar 2009 13:54:53 +0100 Subject: [PATCH 049/772] made some performance improvements by using a shared byte-vector buffer for serialization --- bson/writer/writer-docs.factor | 2 +- bson/writer/writer.factor | 67 ++++++++---- mongodb/benchmark/benchmark.factor | 151 ++++++++++++++++++++------- mongodb/driver/driver.factor | 4 +- mongodb/operations/operations.factor | 28 ++--- 5 files changed, 181 insertions(+), 71 deletions(-) diff --git a/bson/writer/writer-docs.factor b/bson/writer/writer-docs.factor index cbcf1d2659..a4b393b5d9 100644 --- a/bson/writer/writer-docs.factor +++ b/bson/writer/writer-docs.factor @@ -3,7 +3,7 @@ USING: assocs help.markup help.syntax kernel ; IN: bson.writer -HELP: assoc>array +HELP: assoc>bv { $values { "assoc" assoc } { "byte-array" null } diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 6db25b7d1c..299b6faee7 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -1,17 +1,51 @@ ! Copyright (C) 2008 Sascha Matzke. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs bson.constants byte-arrays fry io io.binary +USING: accessors assocs bson.constants +byte-arrays byte-vectors calendar fry io io.binary io.encodings io.encodings.binary io.encodings.string io.encodings.utf8 -io.streams.byte-array kernel math math.parser quotations sequences -serialize strings words calendar ; +io.streams.byte-array kernel math math.parser namespaces +quotations sequences serialize strings words ; + IN: bson.writer -#! Writes the object out to a stream in BSON format +#! Writes the object out to a byte-vector in BSON format [ shared-buffer set ] keep ] unless* ; inline + +PRIVATE> + +: ensure-buffer ( -- ) + (buffer) drop ; + +: reset-buffer ( -- ) + (buffer) 0 >>length drop ; + +: with-buffer ( quot -- byte-vector ) + [ (buffer) ] dip [ output-stream get ] compose + with-output-stream* dup encoder? [ stream>> ] when ; inline + +: with-length ( quot: ( -- ) -- bytes-written start-index ) + [ (buffer) [ length ] keep ] dip call + length swap [ - ] keep ; inline + +: with-length-prefix ( quot: ( -- ) -- ) + [ B{ 0 0 0 0 } write ] prepose with-length + [ INT32-SIZE >le ] dip (buffer) + '[ _ over [ nth ] dip _ + _ set-nth ] + [ INT32-SIZE ] dip each-integer ; inline + +string write-cstring bson-write ] - each-index ] - binary swap with-byte-writer - [ length 5 + bson-write ] keep - write - write-eoo ; + '[ _ [ [ write-type ] dip number>string + write-cstring bson-write ] each-index + write-eoo + ] with-length-prefix ; : write-oid ( assoc -- ) [ MDB_OID_FIELD ] dip at* @@ -106,20 +137,16 @@ M: sequence bson-write ( array -- ) { "_id" "_mdb" } member? ; inline M: assoc bson-write ( assoc -- ) - [ binary ] dip '[ _ [ write-oid ] keep [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each - ] with-byte-writer - [ length 5 + bson-write ] keep - write - write-eoo ; + write-eoo ] with-length-prefix ; M: word bson-write name>> bson-write ; PRIVATE> - -: assoc>array ( assoc -- byte-array ) - '[ _ bson-write ] binary swap with-byte-writer ; inline + +: assoc>bv ( assoc -- byte-vector ) + [ '[ _ bson-write ] with-buffer ] with-scope ; inline : assoc>stream ( assoc -- ) bson-write ; inline diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index 39b6995034..757d7864a3 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -1,15 +1,21 @@ -USING: mongodb.driver calendar math fry kernel assocs math.ranges +USING: calendar math fry kernel assocs math.ranges sequences formatting combinators namespaces io tools.time prettyprint -accessors words ; +accessors words mongodb.driver ; IN: mongodb.benchmark -SYMBOLS: per-trial batch-size collection host db port ; +SYMBOLS: per-trial collection host db port ; : get* ( symbol default -- value ) [ get ] dip or ; inline -TUPLE: result doc index batch lasterror ; +: trial-size ( -- size ) + per-trial 10000 get* ; inline flushable + +: batch-size ( -- size ) + \ batch-size 100 get* ; inline flushable + +TUPLE: result doc collection index batch lasterror ; : ( -- ) result new result set ; inline @@ -91,25 +97,34 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } "platform-as-a-service" "technology" "helps" "developers" "focus" "building" "mongodb" "mongo" } } } -: small-doc ( -- quot: ( i -- doc ) ) - result [ "small" >>doc ] change - DOC-SMALL clone - '[ "x" _ [ set-at ] keep ] ; inline +: set-doc ( name -- ) + [ result ] dip '[ _ >>doc ] change ; inline -: medium-doc ( -- quot: ( i -- doc ) ) - result [ "medium" >>doc ] change - DOC-MEDIUM clone - '[ "x" _ [ set-at ] keep ] ; inline +: small-doc ( -- ) + "small" set-doc ; inline -: large-doc ( -- quot: ( i -- doc ) ) - result [ "large" >>doc ] change - DOC-LARGE clone - '[ "x" _ [ set-at ] keep +: medium-doc ( -- ) + "medium" set-doc ; inline + +: large-doc ( -- ) + "large" set-doc ; inline + +: small-doc-prepare ( -- quot: ( i -- doc ) ) + small-doc + '[ "x" DOC-SMALL clone [ set-at ] keep ] ; inline + +: medium-doc-prepare ( -- quot: ( i -- doc ) ) + medium-doc + '[ "x" DOC-MEDIUM clone [ set-at ] keep ] ; inline + +: large-doc-prepare ( -- quot: ( i -- doc ) ) + large-doc + [ "x" DOC-LARGE clone [ set-at ] keep [ now "access-time" ] dip [ set-at ] keep ] ; : (insert) ( quot: ( i -- doc ) collection -- ) - [ per-trial get ] 2dip + [ trial-size ] 2dip '[ _ call [ _ ] dip result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ; inline @@ -118,13 +133,23 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } '[ _ call ] map ; inline : (insert-batch) ( quot: ( i -- doc ) collection -- ) - [ per-trial get batch-size get [ / ] keep ] 2dip + [ trial-size batch-size [ / ] keep ] 2dip '[ _ _ (prepare-batch) [ _ ] dip result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ; inline -: prepare-collection ( -- collection ) +: bchar ( boolean -- char ) + [ "t" ] [ "f" ] if ; inline + +: collection-name ( -- collection ) collection "benchmark" get* + result get doc>> + result get index>> bchar + "%s-%s-%s" sprintf + [ [ result get ] dip >>collection drop ] keep ; inline + +: prepare-collection ( -- collection ) + collection-name [ "_x_idx" drop-index ] keep [ drop-collection ] keep [ create-collection ] keep ; inline @@ -138,6 +163,26 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } result get batch>> [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ; +: check-for-key ( assoc key -- ) + swap key? [ "ups... where's the key" throw ] unless ; inline + +: find-one ( -- quot: ( -- ) ) + collection-name + trial-size 2 / "x" H{ } clone [ set-at ] keep + '[ _ _ 1 limit find [ drop ] dip first "x" check-for-key ] ; + +: find-all ( -- quot: ( -- ) ) + collection-name + H{ } clone + '[ _ _ find [ "x" check-for-key ] each drop ] ; + +: find-range ( -- quot: ( -- ) ) + collection-name + trial-size 2 / "$gt" H{ } clone [ set-at ] keep + [ trial-size 2 / batch-size + "$lt" ] dip [ set-at ] keep + "x" H{ } clone [ set-at ] keep + '[ _ _ find [ "x" check-for-key ] each drop ] ; + : batch ( -- ) result [ t >>batch ] change ; inline @@ -147,46 +192,80 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : errcheck ( -- ) result [ t >>lasterror ] change ; inline -: bchar ( boolean -- char ) - [ "t" ] [ "f" ] if ; inline - : print-result ( time -- ) - [ result get [ doc>> ] keep + [ result get [ collection>> ] keep [ batch>> bchar ] keep [ index>> bchar ] keep lasterror>> bchar - per-trial get ] dip + trial-size ] dip 1000000 / /i - "%-6s: {batch:%s,index:%s;errchk:%s} %7s op/s" + "%-18s: {batch:%s,index:%s;errchk:%s} %10s op/s" sprintf print flush ; inline : print-separator ( -- ) - "-----------------------------------------------" print flush ; inline + "--------------------------------------------------------------" print flush ; inline + +: print-separator-bold ( -- ) + "==============================================================" print flush ; inline : print-header ( -- ) - per-trial get - batch-size get - "MongoDB Factor Driver Benchmark\n%d ops per Trial, Batch-Size: %d\n" + trial-size + batch-size + "MongoDB Factor Driver Benchmark\n%d ops per Trial, Batch-Size: %d" sprintf print flush - print-separator ; + print-separator-bold ; : with-result ( quot: ( -- ) -- ) [ ] prepose [ print-result ] compose with-scope ; inline -: run-insert-bench ( doc-word-seq feat-seq -- ) - '[ _ swap +: bench-quot ( feat-seq op-word -- quot: ( elt -- ) ) + '[ _ swap _ '[ [ [ _ execute ] dip - [ execute ] each insert benchmark ] with-result ] each - print-separator ] each ; + [ execute ] each _ execute benchmark ] with-result ] each + print-separator ] ; + +: run-insert-bench ( doc-word-seq feat-seq -- ) + "Insert Tests" print + print-separator-bold + \ insert bench-quot each ; + +: run-find-one-bench ( doc-word-seq feat-seq -- ) + "Query Tests - Find-One" print + print-separator-bold + \ find-one bench-quot each ; + +: run-find-all-bench ( doc-word-seq feat-seq -- ) + "Query Tests - Find-All" print + print-separator-bold + \ find-all bench-quot each ; + +: run-find-range-bench ( doc-word-seq feat-seq -- ) + "Query Tests - Find-Range" print + print-separator-bold + \ find-range bench-quot each ; + : run-benchmarks ( -- ) db "db" get* host "127.0.0.1" get* port 27020 get* [ print-header + ! insert + { small-doc-prepare medium-doc-prepare large-doc-prepare } + { { } { index } { errcheck } { index errcheck } + { batch } { batch errcheck } + { batch index errcheck } } + run-insert-bench + ! find-one { small-doc medium-doc large-doc } - { { } { errcheck } { batch } { batch errcheck } - { index } { index errcheck } { batch index errcheck } } run-insert-bench + { { } { index } } run-find-one-bench + ! find-all + { small-doc medium-doc large-doc } + { { } { index } } run-find-all-bench + ! find-range + { small-doc medium-doc large-doc } + { { } { index } } run-find-range-bench + ] with-db ; diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index ee899522cc..118a503213 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -1,6 +1,6 @@ USING: accessors assocs fry io.sockets kernel math mongodb.msg formatting linked-assocs destructors continuations mongodb.operations namespaces sequences splitting math.parser io.encodings.binary combinators io.streams.duplex -arrays io memoize constructors sets strings uuid ; +arrays io memoize constructors sets strings uuid bson.writer ; IN: mongodb.driver @@ -52,7 +52,7 @@ SYMBOL: mdb-instance nodes>> [ f ] dip at inet>> ; : with-db ( mdb quot -- ... ) - [ [ '[ _ [ mdb-instance set ] keep master>> + [ [ '[ _ [ mdb-instance set ensure-buffer ] keep master>> [ remote-address set ] keep binary local-address set diff --git a/mongodb/operations/operations.factor b/mongodb/operations/operations.factor index 75207cf30b..cc496b81c6 100644 --- a/mongodb/operations/operations.factor +++ b/mongodb/operations/operations.factor @@ -3,6 +3,10 @@ io io.binary io.encodings.binary io.encodings.string io.encodings.utf8 io.streams.byte-array kernel math mongodb.msg namespaces sequences locals assocs combinators linked-assocs ; +IN: alien.c-types + +M: byte-vector byte-length length ; + IN: mongodb.operations >opcode read-int32 >>flags ; inline -: write-header ( message length -- ) - MSG-HEADER-SIZE + write-int32 +: write-header ( message -- ) [ req-id>> write-int32 ] keep [ resp-id>> write-int32 ] keep opcode>> write-int32 ; inline @@ -145,10 +148,11 @@ PRIVATE> [ query>> "query" selector set-at ] } cleave selector - ] ; + ] ; inline flushable PRIVATE> @@ -169,8 +173,8 @@ M: mdb-query-msg write-message ( message -- ) [ collection>> write-cstring ] keep [ skip#>> write-int32 ] keep [ return#>> write-int32 ] keep - [ build-query-object assoc>array write ] keep - returnfields>> [ assoc>array write ] when* + [ build-query-object assoc>stream ] keep + returnfields>> [ assoc>stream ] when* ] (write-message) ; M: mdb-insert-msg write-message ( message -- ) @@ -178,7 +182,7 @@ M: mdb-insert-msg write-message ( message -- ) '[ _ [ flags>> write-int32 ] keep [ collection>> write-cstring ] keep - objects>> [ assoc>array write ] each + objects>> [ assoc>stream ] each ] (write-message) ; M: mdb-update-msg write-message ( message -- ) @@ -187,8 +191,8 @@ M: mdb-update-msg write-message ( message -- ) [ flags>> write-int32 ] keep [ collection>> write-cstring ] keep [ upsert?>> write-int32 ] keep - [ selector>> assoc>array write ] keep - object>> assoc>array write + [ selector>> assoc>stream ] keep + object>> assoc>stream ] (write-message) ; M: mdb-delete-msg write-message ( message -- ) @@ -197,7 +201,7 @@ M: mdb-delete-msg write-message ( message -- ) [ flags>> write-int32 ] keep [ collection>> write-cstring ] keep 0 write-int32 - selector>> assoc>array write + selector>> assoc>stream ] (write-message) ; M: mdb-getmore-msg write-message ( message -- ) From aaf887ab1d4417921be26a9e4f58dccfde5b1ba5 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 7 Mar 2009 14:06:53 +0100 Subject: [PATCH 050/772] added stack effect to quot argument to with-db made key check in query benchmarks optional --- mongodb/benchmark/benchmark.factor | 4 +++- mongodb/driver/driver.factor | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index 757d7864a3..17ea69f5e3 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -19,6 +19,8 @@ TUPLE: result doc collection index batch lasterror ; : ( -- ) result new result set ; inline +CONSTANT: CHECK-KEY f + CONSTANT: DOC-SMALL H{ } CONSTANT: DOC-MEDIUM H{ { "integer" 5 } @@ -164,7 +166,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ; : check-for-key ( assoc key -- ) - swap key? [ "ups... where's the key" throw ] unless ; inline + CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ; inline : find-one ( -- quot: ( -- ) ) collection-name diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 118a503213..38199bedaf 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -51,7 +51,7 @@ SYMBOL: mdb-instance : slave>> ( mdb -- inet ) nodes>> [ f ] dip at inet>> ; -: with-db ( mdb quot -- ... ) +: with-db ( mdb quot: ( -- * ) -- * ) [ [ '[ _ [ mdb-instance set ensure-buffer ] keep master>> [ remote-address set ] keep binary From 4b7c4a3564bf63e306cc5d7c5f26d0d5011a23f2 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 7 Mar 2009 14:24:38 +0100 Subject: [PATCH 051/772] made variables strings so that they can be set from the commandline --- mongodb/benchmark/benchmark.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index 17ea69f5e3..d5f7efe052 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -1,19 +1,19 @@ USING: calendar math fry kernel assocs math.ranges sequences formatting combinators namespaces io tools.time prettyprint -accessors words mongodb.driver ; +accessors words mongodb.driver strings math.parser ; IN: mongodb.benchmark -SYMBOLS: per-trial collection host db port ; +SYMBOL: collection : get* ( symbol default -- value ) [ get ] dip or ; inline : trial-size ( -- size ) - per-trial 10000 get* ; inline flushable + "per-trial" 10000 get* ; inline flushable : batch-size ( -- size ) - \ batch-size 100 get* ; inline flushable + "batch-size" 100 get* ; inline flushable TUPLE: result doc collection index batch lasterror ; @@ -249,7 +249,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : run-benchmarks ( -- ) - db "db" get* host "127.0.0.1" get* port 27020 get* + "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* dup string? [ string>number ] when [ print-header ! insert @@ -270,4 +270,5 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } ] with-db ; +MAIN: run-benchmarks From 26c4aae74b900fdbfe3539c2d251c4c734bfbb88 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 7 Mar 2009 14:52:28 +0100 Subject: [PATCH 052/772] fixed per-trial and batch-size variables to ensure the value is a number --- mongodb/benchmark/benchmark.factor | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index d5f7efe052..c2935231d1 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -9,16 +9,20 @@ SYMBOL: collection : get* ( symbol default -- value ) [ get ] dip or ; inline +: ensure-number ( v -- n ) + dup string? [ string>number ] when ; inline + : trial-size ( -- size ) - "per-trial" 10000 get* ; inline flushable + "per-trial" 10000 get* ensure-number ; inline flushable : batch-size ( -- size ) - "batch-size" 100 get* ; inline flushable + "batch-size" 100 get* ensure-number ; inline flushable TUPLE: result doc collection index batch lasterror ; : ( -- ) result new result set ; inline + CONSTANT: CHECK-KEY f CONSTANT: DOC-SMALL H{ } @@ -249,7 +253,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : run-benchmarks ( -- ) - "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* dup string? [ string>number ] when + "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number [ print-header ! insert From a041fb06dc23528f7195b3716dd982c555bf89d6 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 7 Mar 2009 19:08:40 +0100 Subject: [PATCH 053/772] added some more inlines to make words infer --- mongodb/benchmark/benchmark.factor | 10 +++++----- mongodb/driver/driver.factor | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index c2935231d1..4f7fc644d6 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -229,27 +229,27 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } '[ _ swap _ '[ [ [ _ execute ] dip [ execute ] each _ execute benchmark ] with-result ] each - print-separator ] ; + print-separator ] ; inline : run-insert-bench ( doc-word-seq feat-seq -- ) "Insert Tests" print print-separator-bold - \ insert bench-quot each ; + \ insert bench-quot each ; inline : run-find-one-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-One" print print-separator-bold - \ find-one bench-quot each ; + \ find-one bench-quot each ; inline : run-find-all-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-All" print print-separator-bold - \ find-all bench-quot each ; + \ find-all bench-quot each ; inline : run-find-range-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-Range" print print-separator-bold - \ find-range bench-quot each ; + \ find-range bench-quot each ; inline : run-benchmarks ( -- ) diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 38199bedaf..cf0bf8ac06 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -58,7 +58,7 @@ SYMBOL: mdb-instance local-address set mdb-socket-stream set ] ] dip compose [ mdb-stream>> [ dispose ] when* ] [ ] cleanup - ] with-scope ; + ] with-scope ; inline Date: Mon, 9 Mar 2009 22:58:19 +0100 Subject: [PATCH 054/772] some formatting --- mongodb/driver/driver.factor | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index cf0bf8ac06..f1dc204d1c 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -52,13 +52,12 @@ SYMBOL: mdb-instance nodes>> [ f ] dip at inet>> ; : with-db ( mdb quot: ( -- * ) -- * ) - [ [ '[ _ [ mdb-instance set ensure-buffer ] keep master>> - [ remote-address set ] keep - binary - local-address set + [ [ '[ ensure-buffer _ [ mdb-instance set ] keep + master>> [ remote-address set ] keep + binary local-address set mdb-socket-stream set ] ] dip compose - [ mdb-stream>> [ dispose ] when* ] [ ] cleanup - ] with-scope ; inline + [ mdb-stream>> [ dispose ] when* ] + [ ] cleanup ] with-scope ; inline >return# ; inline - + GENERIC# skip 1 ( mdb-query skip# -- mdb-query ) M: mdb-query-msg skip ( query skip# -- mdb-query ) >>skip# ; inline From 2a29d7fed42e2976273e0e41db40cbf62a6f825b Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 11 Mar 2009 14:40:07 +0100 Subject: [PATCH 055/772] changed find, update and get-more --- .gitignore | 1 + mongodb/driver/driver.factor | 33 ++++++++++++++++++++------------- 2 files changed, 21 insertions(+), 13 deletions(-) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000000..b25c15b81f --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +*~ diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index f1dc204d1c..53dd4ee427 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -204,18 +204,21 @@ GENERIC# hint 1 ( mdb-query index-hint -- mdb-query ) M: mdb-query-msg hint ( mdb-query index-hint -- mdb-query ) >>hint ; +GENERIC: get-more ( mdb-cursor -- mdb-cursor objects ) +M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects ) + [ [ collection>> ] [ return#>> ] [ id>> ] tri send-query ] + [ f f ] if* ; + GENERIC: find ( mdb-query -- cursor result ) M: mdb-query-msg find - send-query ; + send-query ; +M: mdb-cursor find + get-more ; GENERIC: explain ( mdb-query -- result ) M: mdb-query-msg explain t >>explain find [ drop ] dip ; -GENERIC: get-more ( mdb-cursor -- mdb-cursor objects ) -M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects ) - [ [ collection>> ] [ return#>> ] [ id>> ] tri send-query ] - [ f f ] if* ; GENERIC: find-one ( mdb-query -- result ) M: mdb-query-msg find-one @@ -275,15 +278,19 @@ M: assoc ensure-index [ cmd-collection ] dip find-one objects>> first check-ok [ "could not drop index" throw ] unless ; -GENERIC: update ( collection selector object -- ) -M: assoc update - [ ensure-collection ] dip - send-message-check-error ; +: ( collection selector object -- update-msg ) + [ ensure-collection ] 2dip ; -GENERIC: update-unsafe ( collection selector object -- ) -M: assoc update-unsafe - [ ensure-collection ] dip - send-message ; +: >upsert ( mdb-update-msg -- mdb-update-msg ) + 1 >>upsert? ; + +GENERIC: update ( mdb-update-msg -- ) +M: mdb-update-msg update + send-message-check-error ; + +GENERIC: update-unsafe ( mdb-update-msg -- ) +M: mdb-update-msg update-unsafe + send-message ; GENERIC: delete ( collection selector -- ) M: assoc delete From cd90702e39269aa3e03b6d4aaf658d889c517079 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Tue, 17 Mar 2009 17:50:46 +0100 Subject: [PATCH 056/772] added regexp queries --- bson/constants/constants.factor | 8 +++++++- bson/reader/reader.factor | 17 +++++++++++------ bson/writer/writer.factor | 8 ++++++-- mongodb/driver/driver.factor | 7 ++++++- 4 files changed, 30 insertions(+), 10 deletions(-) diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index be9f9466b5..0da3cc0bb5 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -1,4 +1,4 @@ -USING: accessors kernel uuid ; +USING: accessors kernel math parser sequences strings uuid ; IN: bson.constants @@ -11,6 +11,12 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ; TUPLE: objref ns objid ; +TUPLE: mdbregexp { regexp string } { options string } ; + +: ( string -- mdbregexp ) + [ mdbregexp new ] dip >>regexp ; + + CONSTANT: MDB_OID_FIELD "_id" CONSTANT: MDB_INTERNAL_FIELD "_mdb_" diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index ca2d5a5bb3..f39d4a21d6 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -26,6 +26,7 @@ PREDICATE: bson-string < integer T_String = ; PREDICATE: bson-object < integer T_Object = ; PREDICATE: bson-array < integer T_Array = ; PREDICATE: bson-binary < integer T_Binary = ; +PREDICATE: bson-regexp < integer T_Regexp = ; PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ; PREDICATE: bson-binary-function < integer T_Binary_Function = ; PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ; @@ -165,17 +166,21 @@ M: bson-double element-data-read ( type -- double ) read-double ; M: bson-boolean element-data-read ( type -- boolean ) - drop - read-byte t = ; + drop + read-byte t = ; M: bson-date element-data-read ( type -- timestamp ) - drop - read-longlong millis>timestamp ; + drop + read-longlong millis>timestamp ; M: bson-binary element-data-read ( type -- binary ) - drop - read-int32 read-byte element-binary-read ; + drop + read-int32 read-byte element-binary-read ; +M: bson-regexp element-data-read ( type -- mdbregexp ) + drop mdbregexp new + read-cstring >>regexp read-cstring >>options ; + M: bson-null element-data-read ( type -- bf ) drop f ; diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 299b6faee7..086ff2af7f 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -59,6 +59,7 @@ M: string bson-type? ( string -- type ) drop T_String ; M: integer bson-type? ( integer -- type ) drop T_Integer ; M: assoc bson-type? ( assoc -- type ) drop T_Object ; M: timestamp bson-type? ( timestamp -- type ) drop T_Date ; +M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ; M: oid bson-type? ( word -- type ) drop T_OID ; M: objid bson-type? ( objid -- type ) drop T_Binary ; @@ -122,12 +123,15 @@ M: objref bson-write ( objref -- ) [ length write-int32 ] keep T_Binary_Custom write-byte write ; + +M: mdbregexp bson-write ( regexp -- ) + [ regexp>> utf8 encode write-cstring ] + [ options>> utf8 encode write-cstring ] bi ; M: sequence bson-write ( array -- ) '[ _ [ [ write-type ] dip number>string write-cstring bson-write ] each-index - write-eoo - ] with-length-prefix ; + write-eoo ] with-length-prefix ; : write-oid ( assoc -- ) [ MDB_OID_FIELD ] dip at* diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 53dd4ee427..2015ff8ecf 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -1,6 +1,6 @@ USING: accessors assocs fry io.sockets kernel math mongodb.msg formatting linked-assocs destructors continuations mongodb.operations namespaces sequences splitting math.parser io.encodings.binary combinators io.streams.duplex -arrays io memoize constructors sets strings uuid bson.writer ; +arrays io memoize constructors sets strings uuid bson.writer bson.constants parser ; IN: mongodb.driver @@ -38,8 +38,13 @@ SYMBOL: mdb-socket-stream : check-ok ( result -- ? ) [ "ok" ] dip key? ; inline +: >mdbregexp ( value -- regexp ) + first ; + PRIVATE> +: r/ \ / [ >mdbregexp ] parse-literal ; parsing + SYMBOL: mdb-instance : mdb ( -- mdb ) From 76824c3bc7de4e8cf61710db6f28f7a0808bd586 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 23 Mar 2009 08:55:07 +0100 Subject: [PATCH 057/772] changed "; parsing" to new "SYNTAX:" notation --- mongodb/driver/driver.factor | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 2015ff8ecf..93554b20bc 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -1,6 +1,8 @@ -USING: accessors assocs fry io.sockets kernel math mongodb.msg formatting linked-assocs destructors continuations -mongodb.operations namespaces sequences splitting math.parser io.encodings.binary combinators io.streams.duplex -arrays io memoize constructors sets strings uuid bson.writer bson.constants parser ; +USING: accessors assocs bson.constants bson.writer combinators +constructors continuations destructors formatting fry io +io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs +math math.parser memoize mongodb.msg mongodb.operations namespaces +parser sequences sets splitting strings uuid syntax ; IN: mongodb.driver @@ -43,7 +45,8 @@ SYMBOL: mdb-socket-stream PRIVATE> -: r/ \ / [ >mdbregexp ] parse-literal ; parsing +SYNTAX: r/ ( token -- mdbregexp ) + \ / [ >mdbregexp ] parse-literal ; SYMBOL: mdb-instance From 0378dda9b1b3a0793427f716516ab6acddeedc1d Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 23 Mar 2009 08:55:40 +0100 Subject: [PATCH 058/772] added constants for byte-lengths (INT32-SIZE, CHAR-SIZE, INT64-SIZE) --- bson/writer/writer.factor | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 086ff2af7f..22a278e1fb 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2008 Sascha Matzke. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs bson.constants -byte-arrays byte-vectors calendar fry io io.binary io.encodings -io.encodings.binary io.encodings.string io.encodings.utf8 -io.streams.byte-array kernel math math.parser namespaces -quotations sequences serialize strings words ; +USING: accessors assocs bson.constants byte-arrays byte-vectors +calendar fry io io.binary io.encodings io.encodings.string +io.encodings.utf8 kernel math math.parser namespaces quotations +sequences serialize strings tools.walker words ; IN: bson.writer @@ -16,6 +15,8 @@ IN: bson.writer SYMBOL: shared-buffer CONSTANT: INT32-SIZE 4 +CONSTANT: CHAR-SIZE 1 +CONSTANT: INT64-SIZE 8 : (buffer) ( -- buffer ) shared-buffer get @@ -24,10 +25,10 @@ CONSTANT: INT32-SIZE 4 PRIVATE> : ensure-buffer ( -- ) - (buffer) drop ; + (buffer) drop ; inline : reset-buffer ( -- ) - (buffer) 0 >>length drop ; + (buffer) 0 >>length drop ; inline : with-buffer ( quot -- byte-vector ) [ (buffer) ] dip [ output-stream get ] compose @@ -67,11 +68,11 @@ M: objref bson-type? ( objref -- type ) drop T_Binary ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; -: write-byte ( byte -- ) 1 >le write ; inline -: write-int32 ( int -- ) 4 >le write ; inline -: write-double ( real -- ) double>bits 8 >le write ; inline +: write-byte ( byte -- ) CHAR-SIZE >le write ; inline +: write-int32 ( int -- ) INT32-SIZE >le write ; inline +: write-double ( real -- ) double>bits INT64-SIZE >le write ; inline : write-cstring ( string -- ) utf8 encode B{ 0 } append write ; inline -: write-longlong ( object -- ) 8 >le write ; inline +: write-longlong ( object -- ) INT64-SIZE >le write ; inline : write-eoo ( -- ) T_EOO write-byte ; inline : write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline From b57cdefde0f53f751d84bcfc7e938e3b728dbe21 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 25 Mar 2009 18:22:28 +0100 Subject: [PATCH 059/772] added doc files optimized string write performance --- bson/reader/reader-docs.factor | 17 -- bson/writer/writer-docs.factor | 23 --- bson/writer/writer.factor | 47 ++--- mongodb/benchmark/benchmark.factor | 29 ++- mongodb/driver/driver-docs.factor | 221 ++++++++++++---------- mongodb/driver/driver.factor | 78 ++++---- mongodb/operations/operations-docs.factor | 23 --- mongodb/operations/operations.factor | 19 +- 8 files changed, 212 insertions(+), 245 deletions(-) delete mode 100644 bson/reader/reader-docs.factor delete mode 100644 bson/writer/writer-docs.factor delete mode 100644 mongodb/operations/operations-docs.factor diff --git a/bson/reader/reader-docs.factor b/bson/reader/reader-docs.factor deleted file mode 100644 index be300f4be6..0000000000 --- a/bson/reader/reader-docs.factor +++ /dev/null @@ -1,17 +0,0 @@ -! Copyright (C) 2009 Your name. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs help.markup help.syntax kernel ; -IN: bson.reader - -HELP: stream>assoc -{ $values - { "exemplar" null } - { "assoc" assoc } { "bytes-read" null } -} -{ $description "" } ; - -ARTICLE: "bson.reader" "bson.reader" -{ $vocab-link "bson.reader" } -; - -ABOUT: "bson.reader" diff --git a/bson/writer/writer-docs.factor b/bson/writer/writer-docs.factor deleted file mode 100644 index a4b393b5d9..0000000000 --- a/bson/writer/writer-docs.factor +++ /dev/null @@ -1,23 +0,0 @@ -! Copyright (C) 2009 Your name. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs help.markup help.syntax kernel ; -IN: bson.writer - -HELP: assoc>bv -{ $values - { "assoc" assoc } - { "byte-array" null } -} -{ $description "" } ; - -HELP: assoc>stream -{ $values - { "assoc" assoc } -} -{ $description "" } ; - -ARTICLE: "bson.writer" "bson.writer" -{ $vocab-link "bson.writer" } -; - -ABOUT: "bson.writer" diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 22a278e1fb..6e3d7badea 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Sascha Matzke. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs bson.constants byte-arrays byte-vectors -calendar fry io io.binary io.encodings io.encodings.string +calendar fry io io.binary io.encodings io.encodings.string io.encodings.private io.encodings.utf8 kernel math math.parser namespaces quotations -sequences serialize strings tools.walker words ; +sequences sequences.private serialize strings tools.walker words ; IN: bson.writer @@ -20,18 +20,18 @@ CONSTANT: INT64-SIZE 8 : (buffer) ( -- buffer ) shared-buffer get - [ 4096 [ shared-buffer set ] keep ] unless* ; inline + [ 8192 [ shared-buffer set ] keep ] unless* ; inline PRIVATE> +: reset-buffer ( buffer -- ) + 0 >>length drop ; inline + : ensure-buffer ( -- ) (buffer) drop ; inline -: reset-buffer ( -- ) - (buffer) 0 >>length drop ; inline - : with-buffer ( quot -- byte-vector ) - [ (buffer) ] dip [ output-stream get ] compose + [ (buffer) [ reset-buffer ] keep dup ] dip with-output-stream* dup encoder? [ stream>> ] when ; inline : with-length ( quot: ( -- ) -- bytes-written start-index ) @@ -41,9 +41,15 @@ PRIVATE> : with-length-prefix ( quot: ( -- ) -- ) [ B{ 0 0 0 0 } write ] prepose with-length [ INT32-SIZE >le ] dip (buffer) - '[ _ over [ nth ] dip _ + _ set-nth ] + '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ] [ INT32-SIZE ] dip each-integer ; inline +: with-length-prefix-excl ( quot: ( -- ) -- ) + [ B{ 0 0 0 0 } write ] prepose with-length + [ INT32-SIZE - INT32-SIZE >le ] dip (buffer) + '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ] + [ INT32-SIZE ] dip each-integer ; inline + le write ; inline : write-int32 ( int -- ) INT32-SIZE >le write ; inline : write-double ( real -- ) double>bits INT64-SIZE >le write ; inline -: write-cstring ( string -- ) utf8 encode B{ 0 } append write ; inline +: write-cstring ( string -- ) write-utf8-string B{ 0 } write ; inline : write-longlong ( object -- ) INT64-SIZE >le write ; inline : write-eoo ( -- ) T_EOO write-byte ; inline @@ -85,9 +92,7 @@ M: t bson-write ( t -- ) drop 1 write-byte ; M: string bson-write ( obj -- ) - utf8 encode B{ 0 } append - [ length write-int32 ] keep - write ; + '[ _ write-cstring ] with-length-prefix-excl ; M: integer bson-write ( num -- ) write-int32 ; @@ -112,22 +117,18 @@ M: oid bson-write ( oid -- ) [ a>> write-longlong ] [ b>> write-int32 ] bi ; M: objid bson-write ( oid -- ) - id>> utf8 encode - [ length write-int32 ] keep T_Binary_UUID write-byte - write ; + id>> '[ _ write-utf8-string ] with-length-prefix ; M: objref bson-write ( objref -- ) - [ ns>> utf8 encode ] - [ objid>> id>> utf8 encode ] bi - append - [ length write-int32 ] keep T_Binary_Custom write-byte - write ; - + '[ _ + [ ns>> write-cstring ] + [ objid>> id>> write-cstring ] bi ] with-length-prefix ; + M: mdbregexp bson-write ( regexp -- ) - [ regexp>> utf8 encode write-cstring ] - [ options>> utf8 encode write-cstring ] bi ; + [ regexp>> write-cstring ] + [ options>> write-cstring ] bi ; M: sequence bson-write ( array -- ) '[ _ [ [ write-type ] dip number>string diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index 4f7fc644d6..c9c04dfab1 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -1,6 +1,6 @@ USING: calendar math fry kernel assocs math.ranges sequences formatting combinators namespaces io tools.time prettyprint -accessors words mongodb.driver strings math.parser ; +accessors words mongodb.driver strings math.parser tools.walker bson.writer ; IN: mongodb.benchmark @@ -164,7 +164,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } "_x_idx" H{ { "x" 1 } } ensure-index ; inline : insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) - prepare-collection + prepare-collection result get index>> [ [ prepare-index ] keep ] when result get batch>> [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ; @@ -233,7 +233,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : run-insert-bench ( doc-word-seq feat-seq -- ) "Insert Tests" print - print-separator-bold + print-separator-bold \ insert bench-quot each ; inline : run-find-one-bench ( doc-word-seq feat-seq -- ) @@ -254,24 +254,23 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : run-benchmarks ( -- ) "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number - [ + [ ensure-buffer print-header ! insert - { small-doc-prepare medium-doc-prepare large-doc-prepare } + ! { small-doc-prepare medium-doc-prepare + { large-doc-prepare } { { } { index } { errcheck } { index errcheck } - { batch } { batch errcheck } - { batch index errcheck } } - run-insert-bench + { batch } { batch errcheck } { batch index errcheck } + } run-insert-bench ! find-one - { small-doc medium-doc large-doc } - { { } { index } } run-find-one-bench + ! { small-doc medium-doc large-doc } + ! { { } { index } } run-find-one-bench ! find-all - { small-doc medium-doc large-doc } - { { } { index } } run-find-all-bench + ! { small-doc medium-doc large-doc } + ! { { } { index } } run-find-all-bench ! find-range - { small-doc medium-doc large-doc } - { { } { index } } run-find-range-bench - + ! { small-doc medium-doc large-doc } + ! { { } { index } } run-find-range-bench ] with-db ; MAIN: run-benchmarks diff --git a/mongodb/driver/driver-docs.factor b/mongodb/driver/driver-docs.factor index d06bbe4ed4..591a84a528 100644 --- a/mongodb/driver/driver-docs.factor +++ b/mongodb/driver/driver-docs.factor @@ -5,297 +5,315 @@ IN: mongodb.driver HELP: { $values - { "name" null } - { "collection" null } + { "name" "name of the collection" } + { "collection" "mdb-collection instance" } } -{ $description "" } ; - -HELP: -{ $values - { "id" null } { "collection" null } { "return#" null } - { "cursor" null } -} -{ $description "" } ; +{ $description "Creates a new mdb-collection instance. Use this to create capped/limited collections. See also: " { $link mdb-collection } } +{ $examples + { $example "\"mycollection\" t >>capped" } } ; HELP: { $values - { "db" null } { "host" null } { "port" null } - { "mdb" null } + { "db" "name of the database to use" } + { "host" "host name or IP address" } + { "port" "port number" } + { "mdb" "mdb-db instance" } } -{ $description "" } ; +{ $description "Create a new mdb-db instance and automatically resolves master/slave information in a paired MongoDB setup." } +{ $examples + { $example "\"db\" \"127.0.0.1\" 27017 " } } ; HELP: { $values - { "collection" "the collection to be queried" } { "query" "query" } - { "mdb-query" "mdb-query-msg tuple instance" } + { "collection" "collection to query" } + { "query" "query assoc" } + { "mdb-query" "mdb-query-msg instance" } } -{ $description "create a new query instance" } ; +{ $description "Creates a new mdb-query-msg instance. " + "This word must be called from within a with-db scope." + "For more see: " + { $link with-db } } +{ $examples + { $example "\"mycollection\" H{ } " } } ; + +HELP: +{ $values + { "collection" "collection to update" } + { "selector" "selector assoc (selects which object(s) to update" } + { "object" "updated object or update instruction" } + { "update-msg" "mdb-update-msg instance" } +} +{ $description "" } ; + +HELP: >upsert +{ $values + { "mdb-update-msg" null } + { "mdb-update-msg" null } +} +{ $description "" } ; HELP: DIRTY? { $values - - { "value" null } + + { "value" null } } { $description "" } ; HELP: MDB-GENERAL-ERROR { $values - - { "value" null } + + { "value" null } } { $description "" } ; HELP: PARTIAL? { $values - - { "value" null } + + { "value" null } } { $description "" } ; HELP: asc { $values - { "key" null } - { "spec" null } + { "key" null } + { "spec" null } } { $description "" } ; HELP: boolean -{ $values - - { "value" null } -} -{ $description "" } ; +{ $var-description "" } ; HELP: count { $values - { "collection" null } { "query" null } - { "result" null } + { "collection" null } + { "query" null } + { "result" null } } { $description "" } ; HELP: create-collection { $values - { "name" null } + { "name" null } } { $description "" } ; HELP: delete { $values - { "collection" null } { "selector" null } + { "collection" null } + { "selector" null } } { $description "" } ; HELP: delete-unsafe { $values - { "collection" null } { "selector" null } + { "collection" null } + { "selector" null } } { $description "" } ; HELP: desc { $values - { "key" null } - { "spec" null } + { "key" null } + { "spec" null } } { $description "" } ; HELP: drop-collection { $values - { "name" null } + { "name" null } } { $description "" } ; HELP: drop-index { $values - { "collection" null } { "name" null } + { "collection" null } + { "name" null } } { $description "" } ; HELP: ensure-collection { $values - { "collection" null } - { "fq-collection" null } + { "collection" null } + { "fq-collection" null } } { $description "" } ; HELP: ensure-index { $values - { "collection" null } { "name" null } { "spec" null } + { "collection" null } + { "name" null } + { "spec" null } } { $description "" } ; -HELP: explain +HELP: explain. { $values - { "mdb-query" null } - { "result" null } + { "mdb-query" null } } { $description "" } ; HELP: find { $values - { "mdb-query" null } - { "cursor" null } { "result" null } + { "mdb-query" null } + { "cursor" null } + { "result" null } } { $description "" } ; HELP: find-one { $values - { "mdb-query" null } - { "result" null } + { "mdb-query" null } + { "result" null } } { $description "" } ; HELP: get-more { $values - { "mdb-cursor" null } - { "mdb-cursor" null } { "objects" null } + { "mdb-cursor" null } + { "mdb-cursor" null } + { "objects" null } } { $description "" } ; HELP: hint { $values - { "mdb-query" null } { "index-hint" null } - { "mdb-query" null } + { "mdb-query" null } + { "index-hint" null } + { "mdb-query" null } } { $description "" } ; HELP: lasterror { $values - - { "error" null } + + { "error" null } } { $description "" } ; HELP: limit { $values - { "mdb-query" null } { "limit#" null } - { "mdb-query" null } + { "mdb-query" null } + { "limit#" null } + { "mdb-query" null } } { $description "" } ; HELP: load-collection-list { $values - - { "collection-list" null } + + { "collection-list" null } } { $description "" } ; HELP: load-index-list { $values - - { "index-list" null } + + { "index-list" null } } { $description "" } ; HELP: master>> { $values - { "mdb" null } - { "inet" null } + { "mdb" null } + { "inet" null } } { $description "" } ; HELP: mdb { $values - - { "mdb" null } + + { "mdb" null } } { $description "" } ; HELP: mdb-collection -{ $values - - { "value" null } -} -{ $description "" } ; +{ $var-description "" } ; HELP: mdb-cursor -{ $values - - { "value" null } -} -{ $description "" } ; +{ $var-description "" } ; HELP: mdb-db -{ $values - - { "value" null } -} -{ $description "" } ; +{ $var-description "" } ; HELP: mdb-error { $values - { "id" null } { "msg" null } + { "id" null } + { "msg" null } } { $description "" } ; HELP: mdb-instance -{ $values - - { "value" null } -} -{ $description "" } ; +{ $var-description "" } ; HELP: mdb-node +{ $var-description "" } ; + +HELP: r/ { $values - - { "value" null } + { "token" null } + { "mdbregexp" null } } { $description "" } ; HELP: save { $values - { "collection" null } { "assoc" assoc } + { "collection" null } + { "assoc" assoc } } { $description "" } ; HELP: save-unsafe { $values - { "collection" null } { "object" object } + { "collection" null } + { "object" object } } { $description "" } ; HELP: skip { $values - { "mdb-query" null } { "skip#" null } - { "mdb-query" null } + { "mdb-query" null } + { "skip#" null } + { "mdb-query" null } } { $description "" } ; HELP: slave>> { $values - { "mdb" null } - { "inet" null } + { "mdb" null } + { "inet" null } } { $description "" } ; HELP: sort { $values - { "mdb-query" null } { "quot" quotation } - { "mdb-query" null } + { "mdb-query" null } + { "quot" quotation } + { "mdb-query" null } } { $description "" } ; HELP: update { $values - { "collection" null } { "selector" null } { "object" object } + { "mdb-update-msg" null } } { $description "" } ; HELP: update-unsafe { $values - { "collection" null } { "selector" null } { "object" object } + { "mdb-update-msg" null } } { $description "" } ; -HELP: validate +HELP: validate. { $values - { "collection" null } + { "collection" null } } { $description "" } ; HELP: with-db { $values - { "mdb" null } { "quot" quotation } - { "..." null } + { "mdb" null } + { "quot" quotation } } { $description "" } ; @@ -304,3 +322,4 @@ ARTICLE: "mongodb.driver" "mongodb.driver" ; ABOUT: "mongodb.driver" + diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 93554b20bc..7e94f6d035 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -2,7 +2,7 @@ USING: accessors assocs bson.constants bson.writer combinators constructors continuations destructors formatting fry io io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs math math.parser memoize mongodb.msg mongodb.operations namespaces -parser sequences sets splitting strings uuid syntax ; +parser prettyprint sequences sets splitting strings uuid ; IN: mongodb.driver @@ -20,7 +20,6 @@ TUPLE: mdb-collection { size integer initial: -1 } { max integer initial: -1 } ; -CONSTRUCTOR: mdb-cursor ( id collection return# -- cursor ) ; CONSTRUCTOR: mdb-collection ( name -- collection ) ; CONSTANT: MDB-GENERAL-ERROR 1 @@ -30,24 +29,6 @@ CONSTANT: DIRTY? "dirty?" ERROR: mdb-error id msg ; -> ( -- stream ) - mdb-socket-stream get ; inline - -: check-ok ( result -- ? ) - [ "ok" ] dip key? ; inline - -: >mdbregexp ( value -- regexp ) - first ; - -PRIVATE> - -SYNTAX: r/ ( token -- mdbregexp ) - \ / [ >mdbregexp ] parse-literal ; - SYMBOL: mdb-instance : mdb ( -- mdb ) @@ -59,14 +40,39 @@ SYMBOL: mdb-instance : slave>> ( mdb -- inet ) nodes>> [ f ] dip at inet>> ; -: with-db ( mdb quot: ( -- * ) -- * ) - [ [ '[ ensure-buffer _ [ mdb-instance set ] keep - master>> [ remote-address set ] keep - binary local-address set - mdb-socket-stream set ] ] dip compose - [ mdb-stream>> [ dispose ] when* ] - [ ] cleanup ] with-scope ; inline +>mdb-stream ( stream -- ) + mdb-socket-stream set ; inline + +: mdb-stream>> ( -- stream ) + mdb-socket-stream get ; inline + +: check-ok ( result -- ? ) + [ "ok" ] dip key? ; inline + +: >mdbregexp ( value -- regexp ) + first ; inline + +: prepare-mdb-session ( mdb -- stream ) + [ mdb-instance set ] keep + master>> [ remote-address set ] keep + binary local-address set ; inline + +PRIVATE> + +SYNTAX: r/ ( token -- mdbregexp ) + \ / [ >mdbregexp ] parse-literal ; + +: with-db ( mdb quot -- ... ) + [ [ prepare-mdb-session ] dip + [ [ >>mdb-stream ] keep ] prepose + with-disposal ] with-scope ; inline + MEMO: ensure-collection ( collection -- fq-collection ) "." split1 over mdb name>> = - [ [ drop ] dip ] [ drop ] if + [ nip ] [ drop ] if [ ] [ reserved-namespace? ] bi [ [ (ensure-collection) ] keep ] unless [ mdb name>> ] dip "%s.%s" sprintf ; inline @@ -223,9 +229,9 @@ M: mdb-query-msg find M: mdb-cursor find get-more ; -GENERIC: explain ( mdb-query -- result ) -M: mdb-query-msg explain - t >>explain find [ drop ] dip ; +GENERIC: explain. ( mdb-query -- ) +M: mdb-query-msg explain. + t >>explain find nip . ; GENERIC: find-one ( mdb-query -- result ) @@ -243,14 +249,14 @@ M: assoc count cmd-collection H{ { "getlasterror" 1 } } find-one objects>> first [ "err" ] dip at ; -GENERIC: validate ( collection -- ) -M: string validate +GENERIC: validate. ( collection -- ) +M: string validate. [ cmd-collection ] dip "validate" H{ } clone [ set-at ] keep find-one objects>> first [ check-ok ] keep '[ "result" _ at print ] when ; -M: mdb-collection validate - name>> validate ; +M: mdb-collection validate. + name>> validate. ; find [ drop ] dip ; + H{ } clone find nip ; : drop-collection ( name -- ) [ cmd-collection ] dip diff --git a/mongodb/operations/operations-docs.factor b/mongodb/operations/operations-docs.factor deleted file mode 100644 index c6d00db1e8..0000000000 --- a/mongodb/operations/operations-docs.factor +++ /dev/null @@ -1,23 +0,0 @@ -! Copyright (C) 2009 Your name. -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel ; -IN: mongodb.operations - -HELP: read-message -{ $values - - { "message" null } -} -{ $description "" } ; - -HELP: write-message -{ $values - { "message" null } -} -{ $description "" } ; - -ARTICLE: "mongodb.operations" "mongodb.operations" -{ $vocab-link "mongodb.operations" } -; - -ABOUT: "mongodb.operations" diff --git a/mongodb/operations/operations.factor b/mongodb/operations/operations.factor index cc496b81c6..0b7f027500 100644 --- a/mongodb/operations/operations.factor +++ b/mongodb/operations/operations.factor @@ -1,7 +1,7 @@ -USING: accessors bson.reader bson.writer byte-arrays byte-vectors fry -io io.binary io.encodings.binary io.encodings.string io.encodings.utf8 -io.streams.byte-array kernel math mongodb.msg namespaces sequences -locals assocs combinators linked-assocs ; +USING: accessors assocs bson.reader bson.writer byte-arrays +byte-vectors combinators formatting fry io io.binary io.encodings.private +io.encodings.binary io.encodings.string io.encodings.utf8 io.files +kernel locals math mongodb.msg namespaces sequences uuid ; IN: alien.c-types @@ -41,7 +41,7 @@ SYMBOL: msg-bytes-read : write-byte ( byte -- ) 1 >le write ; inline : write-int32 ( int -- ) 4 >le write ; inline : write-double ( real -- ) double>bits 8 >le write ; inline -: write-cstring ( string -- ) utf8 encode B{ 0 } append write ; inline +: write-cstring ( string -- ) output-stream get utf8 encoder-write 0 write-byte ; inline : write-longlong ( object -- ) 8 >le write ; inline : read-int32 ( -- int32 ) 4 [ read le> ] [ change-bytes-read ] bi ; inline @@ -150,9 +150,14 @@ PRIVATE> USE: tools.walker -: (write-message) ( message quot -- ) +: dump-to-file ( array -- ) + [ uuid1 "/tmp/mfb/%s.dump" sprintf binary ] dip + '[ _ write ] with-file-writer ; + +: (write-message) ( message quot -- ) '[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer - write flush reset-buffer ; inline + ! [ dump-to-file ] keep + write flush ; inline : build-query-object ( query -- selector ) [let | selector [ H{ } clone ] | From a050578c3b6946e593c33039d4a5dc9447e37cde Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 25 Mar 2009 21:33:39 +0100 Subject: [PATCH 060/772] some further optimizations --- bson/writer/writer.factor | 23 +++++++++++++------ mongodb/benchmark/benchmark.factor | 34 ++++++++++++++-------------- mongodb/operations/operations.factor | 12 +++------- 3 files changed, 36 insertions(+), 33 deletions(-) diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 6e3d7badea..6684888ad0 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs bson.constants byte-arrays byte-vectors calendar fry io io.binary io.encodings io.encodings.string io.encodings.private -io.encodings.utf8 kernel math math.parser namespaces quotations +io.encodings.utf8.private io.encodings.utf8 kernel math math.parser namespaces quotations sequences sequences.private serialize strings tools.walker words ; @@ -22,6 +22,13 @@ CONSTANT: INT64-SIZE 8 shared-buffer get [ 8192 [ shared-buffer set ] keep ] unless* ; inline +: >le-stream ( x n -- ) + ! >le write + swap '[ _ swap nth-byte 0 B{ 0 } + [ set-nth-unsafe ] keep write ] each + ; inline + + PRIVATE> : reset-buffer ( buffer -- ) @@ -74,12 +81,14 @@ M: objref bson-type? ( objref -- type ) drop T_Binary ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; -: write-utf8-string ( string -- ) output-stream get utf8 encoder-write ; inline -: write-byte ( byte -- ) CHAR-SIZE >le write ; inline -: write-int32 ( int -- ) INT32-SIZE >le write ; inline -: write-double ( real -- ) double>bits INT64-SIZE >le write ; inline -: write-cstring ( string -- ) write-utf8-string B{ 0 } write ; inline -: write-longlong ( object -- ) INT64-SIZE >le write ; inline +: write-utf8-string ( string -- ) + output-stream get '[ _ swap char>utf8 ] each ; inline + +: write-byte ( byte -- ) CHAR-SIZE >le-stream ; inline +: write-int32 ( int -- ) INT32-SIZE >le-stream ; inline +: write-double ( real -- ) double>bits INT64-SIZE >le-stream ; inline +: write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline +: write-longlong ( object -- ) INT64-SIZE >le-stream ; inline : write-eoo ( -- ) T_EOO write-byte ; inline : write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index c9c04dfab1..b8a0a7a8fe 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -254,23 +254,23 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : run-benchmarks ( -- ) "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number - [ ensure-buffer - print-header - ! insert - ! { small-doc-prepare medium-doc-prepare - { large-doc-prepare } - { { } { index } { errcheck } { index errcheck } - { batch } { batch errcheck } { batch index errcheck } - } run-insert-bench - ! find-one - ! { small-doc medium-doc large-doc } - ! { { } { index } } run-find-one-bench - ! find-all - ! { small-doc medium-doc large-doc } - ! { { } { index } } run-find-all-bench - ! find-range - ! { small-doc medium-doc large-doc } - ! { { } { index } } run-find-range-bench + [ ensure-buffer + print-header + ! insert + { small-doc-prepare medium-doc-prepare + large-doc-prepare } + { { } { index } { errcheck } { index errcheck } + { batch } { batch errcheck } { batch index errcheck } + } run-insert-bench + ! find-one + { small-doc medium-doc large-doc } + { { } { index } } run-find-one-bench + ! find-all + { small-doc medium-doc large-doc } + { { } { index } } run-find-all-bench + ! find-range + { small-doc medium-doc large-doc } + { { } { index } } run-find-range-bench ] with-db ; MAIN: run-benchmarks diff --git a/mongodb/operations/operations.factor b/mongodb/operations/operations.factor index 0b7f027500..ef74bce7e9 100644 --- a/mongodb/operations/operations.factor +++ b/mongodb/operations/operations.factor @@ -1,7 +1,7 @@ USING: accessors assocs bson.reader bson.writer byte-arrays byte-vectors combinators formatting fry io io.binary io.encodings.private -io.encodings.binary io.encodings.string io.encodings.utf8 io.files -kernel locals math mongodb.msg namespaces sequences uuid ; +io.encodings.binary io.encodings.string io.encodings.utf8 io.encodings.utf8.private io.files +kernel locals math mongodb.msg namespaces sequences uuid bson.writer.private ; IN: alien.c-types @@ -38,12 +38,6 @@ SYMBOL: msg-bytes-read : change-bytes-read ( integer -- ) bytes-read> [ 0 ] unless* + >bytes-read ; inline -: write-byte ( byte -- ) 1 >le write ; inline -: write-int32 ( int -- ) 4 >le write ; inline -: write-double ( real -- ) double>bits 8 >le write ; inline -: write-cstring ( string -- ) output-stream get utf8 encoder-write 0 write-byte ; inline -: write-longlong ( object -- ) 8 >le write ; inline - : read-int32 ( -- int32 ) 4 [ read le> ] [ change-bytes-read ] bi ; inline : read-longlong ( -- longlong ) 8 [ read le> ] [ change-bytes-read ] bi ; inline : read-byte-raw ( -- byte-raw ) 1 [ read le> ] [ change-bytes-read ] bi ; inline @@ -156,7 +150,7 @@ USE: tools.walker : (write-message) ( message quot -- ) '[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer - ! [ dump-to-file ] keep + [ dump-to-file ] keep write flush ; inline : build-query-object ( query -- selector ) From fbf406b93efeef95ac9760ad2234437312028997 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 25 Mar 2009 21:51:21 +0100 Subject: [PATCH 061/772] removed debug output --- mongodb/operations/operations.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mongodb/operations/operations.factor b/mongodb/operations/operations.factor index ef74bce7e9..6d4300fa50 100644 --- a/mongodb/operations/operations.factor +++ b/mongodb/operations/operations.factor @@ -150,7 +150,7 @@ USE: tools.walker : (write-message) ( message quot -- ) '[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer - [ dump-to-file ] keep + ! [ dump-to-file ] keep write flush ; inline : build-query-object ( query -- selector ) From 088e59ed34737b538c3b8117897664c2663a82eb Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 26 Mar 2009 12:00:08 +0100 Subject: [PATCH 062/772] fixed query benchmark --- mongodb/benchmark/benchmark.factor | 34 ++++++++++++++++++------------ 1 file changed, 21 insertions(+), 13 deletions(-) diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index b8a0a7a8fe..effac96b2c 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -172,22 +172,30 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : check-for-key ( assoc key -- ) CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ; inline +: (check-find-result) ( result -- ) + "x" check-for-key ; inline + +: (find) ( cursor -- ) + [ find [ (check-find-result) ] each (find) ] when* ; inline recursive + : find-one ( -- quot: ( -- ) ) - collection-name - trial-size 2 / "x" H{ } clone [ set-at ] keep - '[ _ _ 1 limit find [ drop ] dip first "x" check-for-key ] ; - + [ trial-size + collection-name + trial-size 2 / "x" H{ } clone [ set-at ] keep + '[ _ _ 1 limit (find) ] times ] ; + : find-all ( -- quot: ( -- ) ) - collection-name - H{ } clone - '[ _ _ find [ "x" check-for-key ] each drop ] ; - + collection-name + H{ } clone + '[ _ _ (find) ] ; + : find-range ( -- quot: ( -- ) ) - collection-name - trial-size 2 / "$gt" H{ } clone [ set-at ] keep - [ trial-size 2 / batch-size + "$lt" ] dip [ set-at ] keep - "x" H{ } clone [ set-at ] keep - '[ _ _ find [ "x" check-for-key ] each drop ] ; + [ trial-size batch-size /i + collection-name + trial-size 2 / "$gt" H{ } clone [ set-at ] keep + [ trial-size 2 / batch-size + "$lt" ] dip [ set-at ] keep + "x" H{ } clone [ set-at ] keep + '[ _ _ find [ "x" check-for-key ] each drop ] times ] ; : batch ( -- ) result [ t >>batch ] change ; inline From 5da056642665f5bb3f5ab3901333164a6504b1ca Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 27 Mar 2009 16:33:49 +0100 Subject: [PATCH 063/772] performance improvements --- bson/reader/reader.factor | 35 +++++++++---------------- bson/writer/writer.factor | 2 +- mongodb/benchmark/benchmark.factor | 42 +++++++++++++++++++++++------- mongodb/driver/driver.factor | 2 +- 4 files changed, 48 insertions(+), 33 deletions(-) diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index f39d4a21d6..7e81fd5e25 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -1,6 +1,6 @@ USING: accessors assocs bson.constants byte-arrays byte-vectors fry io io.binary io.encodings.string io.encodings.utf8 kernel math namespaces -sequences serialize arrays calendar ; +sequences serialize arrays calendar io.encodings ; IN: bson.reader @@ -41,6 +41,9 @@ GENERIC: element-read ( type -- cont? ) GENERIC: element-data-read ( type -- object ) GENERIC: element-binary-read ( length type -- object ) +: byte-arrary>number ( seq -- number ) + byte-array>bignum >integer ; inline + : get-state ( -- state ) state get ; inline @@ -48,13 +51,13 @@ GENERIC: element-binary-read ( length type -- object ) [ get-state ] dip '[ _ + ] change-read drop ; inline : read-int32 ( -- int32 ) - 4 [ read le> ] [ count-bytes ] bi ; inline + 4 [ read byte-array>number ] [ count-bytes ] bi ; inline : read-longlong ( -- longlong ) - 8 [ read le> ] [ count-bytes ] bi ; inline + 8 [ read byte-array>number ] [ count-bytes ] bi ; inline : read-double ( -- double ) - 8 [ read le> bits>double ] [ count-bytes ] bi ; inline + 8 [ read byte-array>number bits>double ] [ count-bytes ] bi ; inline : read-byte-raw ( -- byte-raw ) 1 [ read ] [ count-bytes ] bi ; inline @@ -62,21 +65,12 @@ GENERIC: element-binary-read ( length type -- object ) : read-byte ( -- byte ) read-byte-raw first ; inline -: (read-cstring) ( acc -- ) - [ read-byte-raw first ] dip ! b acc - 2dup push ! b acc - [ 0 = ] dip ! bool acc - '[ _ (read-cstring) ] unless ; inline recursive - : read-cstring ( -- string ) - BV{ } clone - [ (read-cstring) ] keep - [ zero? ] trim-tail - >byte-array utf8 decode ; inline + input-stream get utf8 + "\0" swap stream-read-until drop ; inline : read-sized-string ( length -- string ) - [ read ] [ count-bytes ] bi - [ zero? ] trim-tail utf8 decode ; inline + drop read-cstring ; inline : read-element-type ( -- type ) read-byte ; inline @@ -128,14 +122,11 @@ M: bson-eoo element-read ( type -- cont? ) M: bson-not-eoo element-read ( type -- cont? ) [ peek-scope ] dip ! scope type - '[ _ - read-cstring push-element [ name>> ] [ type>> ] bi + '[ _ read-cstring push-element [ name>> ] [ type>> ] bi [ element-data-read ] keep end-element swap - ] dip - set-at - t ; + ] dip set-at t ; : [scope-changer] ( state -- state quot ) dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline @@ -212,4 +203,4 @@ PRIVATE> : stream>assoc ( exemplar -- assoc bytes-read ) dup state [ read-int32 >>size read-elements ] with-variable - [ result>> ] [ read>> ] bi ; + [ result>> ] [ read>> ] bi ; inline diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 6684888ad0..4c94840888 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -82,7 +82,7 @@ M: quotation bson-type? ( quotation -- type ) drop T_Binary ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; : write-utf8-string ( string -- ) - output-stream get '[ _ swap char>utf8 ] each ; inline + output-stream get utf8 stream-write ; inline : write-byte ( byte -- ) CHAR-SIZE >le-stream ; inline : write-int32 ( int -- ) INT32-SIZE >le-stream ; inline diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index effac96b2c..424aa7732c 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -1,5 +1,5 @@ -USING: calendar math fry kernel assocs math.ranges -sequences formatting combinators namespaces io tools.time prettyprint +USING: calendar math fry kernel assocs math.ranges bson.reader io.streams.byte-array +sequences formatting combinators namespaces io tools.time prettyprint io.encodings.binary accessors words mongodb.driver strings math.parser tools.walker bson.writer ; IN: mongodb.benchmark @@ -13,7 +13,7 @@ SYMBOL: collection dup string? [ string>number ] when ; inline : trial-size ( -- size ) - "per-trial" 10000 get* ensure-number ; inline flushable + "per-trial" 5000 get* ensure-number ; inline flushable : batch-size ( -- size ) "batch-size" 100 get* ensure-number ; inline flushable @@ -169,6 +169,13 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } result get batch>> [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ; +: serialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) + '[ trial-size [ _ call assoc>bv drop ] each-integer ] ; inline + +: deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) + [ 0 ] dip call assoc>bv + '[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ; inline + : check-for-key ( assoc key -- ) CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ; inline @@ -213,14 +220,14 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } lasterror>> bchar trial-size ] dip 1000000 / /i - "%-18s: {batch:%s,index:%s;errchk:%s} %10s op/s" + "%-18s: {batch:%s,index:%s;errchk:%s} %10s docs/s" sprintf print flush ; inline : print-separator ( -- ) - "--------------------------------------------------------------" print flush ; inline + "----------------------------------------------------------------" print flush ; inline : print-separator-bold ( -- ) - "==============================================================" print flush ; inline + "================================================================" print flush ; inline : print-header ( -- ) trial-size @@ -238,7 +245,17 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } '[ [ [ _ execute ] dip [ execute ] each _ execute benchmark ] with-result ] each print-separator ] ; inline - + +: run-serialization-bench ( doc-word-seq feat-seq -- ) + "Serialization Tests" print + print-separator-bold + \ serialize bench-quot each ; inline + +: run-deserialization-bench ( doc-word-seq feat-seq -- ) + "Deserialization Tests" print + print-separator-bold + \ deserialize bench-quot each ; inline + : run-insert-bench ( doc-word-seq feat-seq -- ) "Insert Tests" print print-separator-bold @@ -262,8 +279,15 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : run-benchmarks ( -- ) "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number - [ ensure-buffer - print-header + [ print-header + ! serialization + { small-doc-prepare medium-doc-prepare + large-doc-prepare } + { { } } run-serialization-bench + ! deserialization + { small-doc-prepare medium-doc-prepare + large-doc-prepare } + { { } } run-deserialization-bench ! insert { small-doc-prepare medium-doc-prepare large-doc-prepare } diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 7e94f6d035..430f94f0cd 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -70,7 +70,7 @@ SYNTAX: r/ ( token -- mdbregexp ) : with-db ( mdb quot -- ... ) [ [ prepare-mdb-session ] dip - [ [ >>mdb-stream ] keep ] prepose + [ >>mdb-stream ] prepose with-disposal ] with-scope ; inline Date: Fri, 27 Mar 2009 16:38:29 +0100 Subject: [PATCH 064/772] fixed typo --- bson/reader/reader.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index 7e81fd5e25..ad0f8fdff8 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -41,7 +41,7 @@ GENERIC: element-read ( type -- cont? ) GENERIC: element-data-read ( type -- object ) GENERIC: element-binary-read ( length type -- object ) -: byte-arrary>number ( seq -- number ) +: byte-array>number ( seq -- number ) byte-array>bignum >integer ; inline : get-state ( -- state ) @@ -203,4 +203,4 @@ PRIVATE> : stream>assoc ( exemplar -- assoc bytes-read ) dup state [ read-int32 >>size read-elements ] with-variable - [ result>> ] [ read>> ] bi ; inline + [ result>> ] [ read>> ] bi ; From b5c5991747049f74845c7bbfdb83943353e45903 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 28 Mar 2009 04:19:02 -0500 Subject: [PATCH 065/772] Working on UI compile error viewer tool --- basis/debugger/debugger.factor | 21 +++-- basis/ui/tools/compiler-errors/authors.txt | 1 + .../compiler-errors/compiler-errors.factor | 77 +++++++++++++++++++ basis/ui/tools/operations/operations.factor | 20 ++++- core/compiler/errors/errors.factor | 37 ++++++--- core/compiler/units/units-tests.factor | 19 ++++- core/compiler/units/units.factor | 4 +- 7 files changed, 158 insertions(+), 21 deletions(-) create mode 100644 basis/ui/tools/compiler-errors/authors.txt create mode 100644 basis/ui/tools/compiler-errors/compiler-errors.factor diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index efd35ab280..fd7696576b 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -9,7 +9,7 @@ combinators generic.math classes.builtin classes compiler.units generic.standard vocabs init kernel.private io.encodings accessors math.order destructors source-files parser classes.tuple.parser effects.parser lexer compiler.errors -generic.parser strings.parser vocabs.loader vocabs.parser ; +generic.parser strings.parser vocabs.loader vocabs.parser see ; IN: debugger GENERIC: error. ( error -- ) @@ -309,11 +309,20 @@ M: lexer-error compute-restarts M: lexer-error error-help error>> error-help ; -M: object compiler-error. ( error word -- ) - nl - "While compiling " write pprint ": " print - nl - print-error ; +M: object compiler-error. ( error -- ) + [ + [ + [ + [ line#>> # ": " % ] + [ word>> synopsis % ] bi + ] "" make + ] [ + [ + presented set + bold font-style set + ] H{ } make-assoc + ] bi format nl + ] [ error>> error. ] bi ; M: bad-effect summary drop "Bad stack effect declaration" ; diff --git a/basis/ui/tools/compiler-errors/authors.txt b/basis/ui/tools/compiler-errors/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/ui/tools/compiler-errors/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/ui/tools/compiler-errors/compiler-errors.factor b/basis/ui/tools/compiler-errors/compiler-errors.factor new file mode 100644 index 0000000000..e574aa077a --- /dev/null +++ b/basis/ui/tools/compiler-errors/compiler-errors.factor @@ -0,0 +1,77 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays sorting assocs colors.constants combinators +combinators.smart compiler.errors compiler.units fonts kernel +math.parser math.order models models.arrow namespaces summary ui +ui.commands ui.gadgets ui.gadgets.tables ui.gadgets.tracks +ui.gestures ui.operations ui.tools.browser ui.tools.common +ui.gadgets.scrollers ; +IN: ui.tools.compiler-errors + +TUPLE: error-list-gadget < tool table ; + +SINGLETON: error-renderer + +M: error-renderer row-columns + drop [ + { + [ file>> ] + [ line#>> number>string ] + [ word>> name>> ] + [ error>> summary ] + } cleave + ] output>array ; + +M: error-renderer row-value + drop ; + +M: error-renderer column-titles + drop { "File" "Line" "Word" "Error" } ; + +: ( model -- table ) + [ [ [ [ file>> ] [ line#>> ] bi 2array ] compare ] sort ] + error-renderer + [ invoke-primary-operation ] >>action + monospace-font >>font + COLOR: dark-gray >>column-line-color + 6 >>gap + 30 >>min-rows + 30 >>max-rows + 80 >>min-cols + 80 >>max-cols ; + +: ( model -- gadget ) + [ values ] vertical error-list-gadget new-track + { 3 3 } >>gap + swap >>table + dup table>> 1 track-add ; + +M: error-list-gadget focusable-child* + table>> ; + +: error-list-help ( -- ) "ui-error-list" com-browse ; + +\ error-list-help H{ { +nullary+ t } } define-command + +error-list-gadget "toolbar" f { + { T{ key-down f f "F1" } error-list-help } +} define-command-map + +SYMBOL: compiler-error-model + +compiler-error-model [ f ] initialize + +SINGLETON: updater + +M: updater definitions-changed + 2drop + compiler-errors get-global + compiler-error-model get-global + set-model ; + +updater remove-definition-observer +updater add-definition-observer + +: error-list-window ( obj -- ) + compiler-error-model get-global + "Compiler errors" open-window ; \ No newline at end of file diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor index c6371ac8aa..881808ea03 100644 --- a/basis/ui/tools/operations/operations.factor +++ b/basis/ui/tools/operations/operations.factor @@ -5,7 +5,7 @@ stack-checker summary io.pathnames io.styles kernel namespaces parser prettyprint quotations tools.crossref tools.annotations editors tools.profiler tools.test tools.time tools.walker vocabs vocabs.loader words sequences tools.vocabs classes -compiler.units accessors vocabs.parser macros.expander ui +compiler.errors compiler.units accessors vocabs.parser macros.expander ui ui.tools.browser ui.tools.listener ui.tools.listener.completion ui.tools.profiler ui.tools.inspector ui.tools.traceback ui.commands ui.gadgets.editors ui.gestures ui.operations @@ -86,6 +86,24 @@ IN: ui.tools.operations { +listener+ t } } define-operation +! Compiler errors +: edit-error ( error -- ) + [ file>> ] [ line#>> ] bi edit-location ; + +[ compiler-error? ] \ edit-error H{ + { +primary+ t } + { +secondary+ t } + { +listener+ t } +} define-operation + +: com-reload ( error -- ) + file>> run-file ; + +[ compiler-error? ] \ com-reload H{ + { +listener+ t } +} define-operation + +! Definitions : com-forget ( defspec -- ) [ forget ] with-compilation-unit ; diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor index 1ea497c3fc..f5e6fda646 100644 --- a/core/compiler/errors/errors.factor +++ b/core/compiler/errors/errors.factor @@ -1,21 +1,28 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces make assocs io sequences -sorting continuations math math.parser ; +sorting continuations math math.order math.parser accessors +definitions ; IN: compiler.errors SYMBOL: +error+ SYMBOL: +warning+ SYMBOL: +linkage+ +TUPLE: compiler-error error word file line# ; + GENERIC: compiler-error-type ( error -- ? ) M: object compiler-error-type drop +error+ ; -GENERIC# compiler-error. 1 ( error word -- ) +M: compiler-error compiler-error-type error>> compiler-error-type ; + +GENERIC: compiler-error. ( error -- ) SYMBOL: compiler-errors +compiler-errors [ H{ } clone ] initialize + SYMBOL: with-compiler-errors? : errors-of-type ( type -- assoc ) @@ -23,9 +30,19 @@ SYMBOL: with-compiler-errors? swap [ [ nip compiler-error-type ] dip eq? ] curry assoc-filter ; +: sort-compile-errors ( assoc -- alist ) + [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ; + +: group-by-source-file ( errors -- assoc ) + H{ } clone [ [ push-at ] curry [ nip dup file>> ] prepose assoc-each ] keep ; + : compiler-errors. ( type -- ) - errors-of-type >alist sort-keys - [ swap compiler-error. ] assoc-each ; + errors-of-type group-by-source-file sort-compile-errors + [ + [ nl "==== " write print nl ] + [ [ nl ] [ compiler-error. ] interleave ] + bi* + ] assoc-each ; : (compiler-report) ( what type word -- ) over errors-of-type assoc-empty? [ 3drop ] [ @@ -51,17 +68,17 @@ SYMBOL: with-compiler-errors? : :linkage ( -- ) +linkage+ compiler-errors. ; +: ( error word -- compiler-error ) + dup where [ first2 ] [ "" 0 ] if* \ compiler-error boa ; + : compiler-error ( error word -- ) - with-compiler-errors? get [ - compiler-errors get pick - [ set-at ] [ delete-at drop ] if - ] [ 2drop ] if ; + compiler-errors get-global pick + [ [ [ ] keep ] dip set-at ] [ delete-at drop ] if ; : with-compiler-errors ( quot -- ) with-compiler-errors? get "quiet" get or [ call ] [ [ with-compiler-errors? on - V{ } clone compiler-errors set-global [ compiler-report ] [ ] cleanup ] with-scope ] if ; inline diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index d84b377f36..6545a45604 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -1,6 +1,6 @@ -IN: compiler.units.tests USING: definitions compiler.units tools.test arrays sequences words kernel accessors namespaces fry ; +IN: compiler.units.tests [ [ [ ] define-temp ] with-compilation-unit ] must-infer [ [ [ ] define-temp ] with-nested-compilation-unit ] must-infer @@ -30,4 +30,19 @@ accessors namespaces fry ; "a" get [ "B" ] define ] with-compilation-unit "b" get execute -] unit-test \ No newline at end of file +] unit-test + +! Notify observers even if compilation unit did nothing +SINGLETON: observer + +observer add-definition-observer + +SYMBOL: counter + +0 counter set-global + +M: observer definitions-changed 2drop global [ counter inc ] bind ; + +[ ] with-compilation-unit + +[ 1 ] [ counter get-global ] unit-test \ No newline at end of file diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index afa05f9442..e8b5b4647d 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -3,7 +3,7 @@ USING: accessors arrays kernel continuations assocs namespaces sequences words vocabs definitions hashtables init sets math math.order classes classes.algebra classes.tuple -classes.tuple.private generic ; +classes.tuple.private generic compiler.errors ; IN: compiler.units SYMBOL: old-definitions @@ -41,7 +41,7 @@ SYMBOL: compiler-impl HOOK: recompile compiler-impl ( words -- alist ) ! Non-optimizing compiler -M: f recompile [ f ] { } map>assoc ; +M: f recompile [ [ f swap compiler-error ] each ] [ [ f ] { } map>assoc ] bi ; ! Trivial compiler. We don't want to touch the code heap ! during stage1 bootstrap, it would just waste time. From 9be60e36afa38cf33daa9f658ff7ec75e0331a95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 28 Mar 2009 04:19:33 -0500 Subject: [PATCH 066/772] Add models.arrow.smart: abstracts out common / pattern --- basis/models/arrow/smart/authors.txt | 1 + basis/models/arrow/smart/smart-tests.factor | 4 ++++ basis/models/arrow/smart/smart.factor | 9 +++++++++ basis/models/search/search.factor | 8 +++----- basis/models/sort/sort.factor | 7 +++---- basis/tools/profiler/profiler.factor | 2 +- basis/ui/gadgets/panes/panes-tests.factor | 7 ++++--- basis/ui/gadgets/search-tables/search-tables.factor | 2 +- basis/ui/tools/profiler/profiler-tests.factor | 3 +++ basis/ui/tools/profiler/profiler.factor | 7 ++++--- 10 files changed, 33 insertions(+), 17 deletions(-) create mode 100644 basis/models/arrow/smart/authors.txt create mode 100644 basis/models/arrow/smart/smart-tests.factor create mode 100644 basis/models/arrow/smart/smart.factor create mode 100644 basis/ui/tools/profiler/profiler-tests.factor diff --git a/basis/models/arrow/smart/authors.txt b/basis/models/arrow/smart/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/models/arrow/smart/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/models/arrow/smart/smart-tests.factor b/basis/models/arrow/smart/smart-tests.factor new file mode 100644 index 0000000000..3e8375e512 --- /dev/null +++ b/basis/models/arrow/smart/smart-tests.factor @@ -0,0 +1,4 @@ +IN: models.arrows.smart.tests +USING: models.arrow.smart tools.test accessors models math kernel ; + +[ 7 ] [ 3 4 [ + ] [ activate-model ] [ value>> ] bi ] unit-test \ No newline at end of file diff --git a/basis/models/arrow/smart/smart.factor b/basis/models/arrow/smart/smart.factor new file mode 100644 index 0000000000..257a2bb1ea --- /dev/null +++ b/basis/models/arrow/smart/smart.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: models.arrow models.product stack-checker accessors fry +generalizations macros kernel ; +IN: models.arrow.smart + +MACRO: ( quot -- quot' ) + [ infer in>> dup ] keep + '[ _ narray [ _ firstn @ ] ] ; \ No newline at end of file diff --git a/basis/models/search/search.factor b/basis/models/search/search.factor index 4bf74b3b92..5ecb0fa34a 100644 --- a/basis/models/search/search.factor +++ b/basis/models/search/search.factor @@ -1,12 +1,10 @@ ! Copyright (C) 2008, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: arrays fry kernel models.product models.arrow -sequences unicode.case ; +USING: fry kernel models.arrow.smart sequences unicode.case ; IN: models.search : ( values search quot -- model ) - [ 2array ] dip - '[ first2 _ curry filter ] ; + '[ _ curry filter ] ; inline : ( values search quot -- model ) - '[ swap @ [ >case-fold ] bi@ subseq? ] ; + '[ swap @ [ >case-fold ] bi@ subseq? ] ; inline diff --git a/basis/models/sort/sort.factor b/basis/models/sort/sort.factor index 23c150796f..efd2e4927b 100644 --- a/basis/models/sort/sort.factor +++ b/basis/models/sort/sort.factor @@ -1,8 +1,7 @@ -! Copyright (C) 2008 Slava Pestov +! Copyright (C) 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: arrays fry kernel models.product models.arrow -sequences sorting ; +USING: sorting models.arrow.smart fry ; IN: models.sort : ( values sort -- model ) - 2array [ first2 sort ] ; \ No newline at end of file + [ '[ _ call( obj1 obj2 -- <=> ) ] sort ] ; inline \ No newline at end of file diff --git a/basis/tools/profiler/profiler.factor b/basis/tools/profiler/profiler.factor index 864a637096..f4488136b2 100644 --- a/basis/tools/profiler/profiler.factor +++ b/basis/tools/profiler/profiler.factor @@ -7,7 +7,7 @@ continuations generic compiler.units sets classes fry ; IN: tools.profiler : profile ( quot -- ) - [ t profiling call ] [ f profiling ] [ ] cleanup ; + [ t profiling call ] [ f profiling ] [ ] cleanup ; inline : filter-counts ( alist -- alist' ) [ second 0 > ] filter ; diff --git a/basis/ui/gadgets/panes/panes-tests.factor b/basis/ui/gadgets/panes/panes-tests.factor index 0529437a76..01abe8b3d9 100644 --- a/basis/ui/gadgets/panes/panes-tests.factor +++ b/basis/ui/gadgets/panes/panes-tests.factor @@ -2,7 +2,7 @@ USING: alien ui.gadgets.panes ui.gadgets namespaces kernel sequences io io.styles io.streams.string tools.test prettyprint definitions help help.syntax help.markup help.stylesheet splitting ui.gadgets.debug models math summary -inspector accessors help.topics see ; +inspector accessors help.topics see fry ; IN: ui.gadgets.panes.tests : #children ( -- n ) "pane" get children>> length ; @@ -18,8 +18,9 @@ IN: ui.gadgets.panes.tests [ t ] [ #children "num-children" get = ] unit-test : test-gadget-text ( quot -- ? ) - dup make-pane gadget-text dup print "======" print - swap with-string-writer dup print = ; + '[ _ call( -- ) ] + [ make-pane gadget-text dup print "======" print ] + [ with-string-writer dup print ] bi = ; [ t ] [ [ "hello" write ] test-gadget-text ] unit-test [ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test diff --git a/basis/ui/gadgets/search-tables/search-tables.factor b/basis/ui/gadgets/search-tables/search-tables.factor index 4a2983bfe0..9947facedb 100644 --- a/basis/ui/gadgets/search-tables/search-tables.factor +++ b/basis/ui/gadgets/search-tables/search-tables.factor @@ -73,7 +73,7 @@ CONSULT: table-protocol search-table table>> ; dup field>> { 2 2 } f track-add values search 500 milliseconds quot renderer
f >>takes-focus? >>table - dup table>> 1 track-add ; + dup table>> 1 track-add ; inline M: search-table model-changed nip field>> clear-search-field ; diff --git a/basis/ui/tools/profiler/profiler-tests.factor b/basis/ui/tools/profiler/profiler-tests.factor new file mode 100644 index 0000000000..86bebddbc9 --- /dev/null +++ b/basis/ui/tools/profiler/profiler-tests.factor @@ -0,0 +1,3 @@ +USING: ui.tools.profiler tools.test ; + +\ profiler-window must-infer diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor index 1c2318a35e..5fef64ea88 100644 --- a/basis/ui/tools/profiler/profiler.factor +++ b/basis/ui/tools/profiler/profiler.factor @@ -11,6 +11,7 @@ ui.gadgets.tabbed ui.gadgets.status-bar ui.gadgets.borders ui.tools.browser ui.tools.common ui.baseline-alignment ui.operations ui.images ; FROM: models.arrow => ; +FROM: models.arrow.smart => ; FROM: models.product => ; IN: ui.tools.profiler @@ -112,8 +113,8 @@ M: method-renderer column-titles drop { "" "Method" "Count" } ; : ( profiler -- model ) [ [ method-counters ] dip - [ generic>> ] [ class>> ] bi 3array - [ first3 '[ _ _ method-matches? ] filter ] + [ generic>> ] [ class>> ] bi + [ '[ _ _ method-matches? ] filter ] ] keep ; : sort-by-name ( obj1 obj2 -- <=> ) @@ -208,6 +209,6 @@ profiler-gadget "toolbar" f { : profiler-window ( -- ) "Profiling results" open-status-window ; -: com-profile ( quot -- ) profile profiler-window ; +: com-profile ( quot -- ) profile profiler-window ; inline MAIN: profiler-window From 1c1f9f46c6c0d48b8b30f98224cf50c6e113461d Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 28 Mar 2009 16:40:57 +0100 Subject: [PATCH 067/772] fixed find-one - now returns a result or f --- mongodb/driver/driver.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 430f94f0cd..2f3f8406a3 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -234,9 +234,9 @@ M: mdb-query-msg explain. t >>explain find nip . ; -GENERIC: find-one ( mdb-query -- result ) +GENERIC: find-one ( mdb-query -- result/f ) M: mdb-query-msg find-one - 1 >>return# send-query-plain ; + 1 >>return# send-query-plain objects>> [ first ] [ f ] if* ; GENERIC: count ( collection query -- result ) M: assoc count From f3a7f9d6be9638cdf4fb2bbeffcb1c8bfb9e5f9a Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 30 Mar 2009 11:01:15 +0200 Subject: [PATCH 068/772] fixed find-one --- mongodb/driver/driver.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 2f3f8406a3..a70dfb25c4 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -242,18 +242,18 @@ GENERIC: count ( collection query -- result ) M: assoc count [ "count" H{ } clone [ set-at ] keep ] dip [ over [ "query" ] dip set-at ] when* - [ cmd-collection ] dip find-one objects>> first + [ cmd-collection ] dip find-one [ check-ok ] keep '[ "n" _ at >fixnum ] [ f ] if ; : lasterror ( -- error ) cmd-collection H{ { "getlasterror" 1 } } - find-one objects>> first [ "err" ] dip at ; + find-one [ "err" ] dip at ; GENERIC: validate. ( collection -- ) M: string validate. [ cmd-collection ] dip "validate" H{ } clone [ set-at ] keep - find-one objects>> first [ check-ok ] keep + find-one [ check-ok ] keep '[ "result" _ at print ] when ; M: mdb-collection validate. name>> validate. ; @@ -289,7 +289,7 @@ M: assoc ensure-index H{ } clone [ [ "index" ] dip set-at ] keep [ [ "deleteIndexes" ] dip set-at ] keep - [ cmd-collection ] dip find-one objects>> first + [ cmd-collection ] dip find-one check-ok [ "could not drop index" throw ] unless ; : ( collection selector object -- update-msg ) @@ -323,5 +323,5 @@ M: assoc delete-unsafe : drop-collection ( name -- ) [ cmd-collection ] dip "drop" H{ } clone [ set-at ] keep - find-one objects>> first check-ok + find-one check-ok [ "could not drop collection" throw ] unless ; From 509399b620e7046abac9bb67a84ce1a90c6b3b04 Mon Sep 17 00:00:00 2001 From: Maxim Savchenko Date: Wed, 1 Apr 2009 19:11:08 -0400 Subject: [PATCH 069/772] Basic sandboxing --- extra/sandbox/authors.txt | 1 + extra/sandbox/sandbox-tests.factor | 57 ++++++++++++++++++++++++++++++ extra/sandbox/sandbox.factor | 23 ++++++++++++ extra/sandbox/summary.txt | 1 + extra/sandbox/syntax/syntax.factor | 26 ++++++++++++++ 5 files changed, 108 insertions(+) create mode 100644 extra/sandbox/authors.txt create mode 100644 extra/sandbox/sandbox-tests.factor create mode 100644 extra/sandbox/sandbox.factor create mode 100644 extra/sandbox/summary.txt create mode 100644 extra/sandbox/syntax/syntax.factor diff --git a/extra/sandbox/authors.txt b/extra/sandbox/authors.txt new file mode 100644 index 0000000000..f97e1bfbf9 --- /dev/null +++ b/extra/sandbox/authors.txt @@ -0,0 +1 @@ +Maxim Savchenko diff --git a/extra/sandbox/sandbox-tests.factor b/extra/sandbox/sandbox-tests.factor new file mode 100644 index 0000000000..5d0496e77b --- /dev/null +++ b/extra/sandbox/sandbox-tests.factor @@ -0,0 +1,57 @@ +! Copyright (C) 2009 Maxim Savchenko +! See http://factorcode.org/license.txt for BSD license. + +USING: kernel accessors continuations lexer vocabs vocabs.parser + combinators.short-circuit sandbox tools.test ; + +IN: sandbox.tests + +<< "sandbox.syntax" load-vocab drop >> +USE: sandbox.syntax.private + +: run-script ( x lines -- y ) + H{ { "kernel" "kernel" } { "math" "math" } { "sequences" "sequences" } } + parse-sandbox call( x -- x! ) ; + +[ 120 ] +[ + 5 + { + "! Simple factorial example" + "APPLYING: kernel math sequences ;" + "1 swap [ 1+ * ] each" + } run-script +] unit-test + +[ + 5 + { + "! Jailbreak attempt with USE:" + "USE: io" + "\"Hello world!\" print" + } run-script +] +[ + { + [ lexer-error? ] + [ error>> condition? ] + [ error>> error>> no-word-error? ] + [ error>> error>> name>> "USE:" = ] + } 1&& +] must-fail-with + +[ + 5 + { + "! Jailbreak attempt with unauthorized APPLY:" + "APPLY: io" + "\"Hello world!\" print" + } run-script +] +[ + { + [ lexer-error? ] + [ error>> sandbox-error? ] + [ error>> vocab>> "io" = ] + } 1&& +] must-fail-with diff --git a/extra/sandbox/sandbox.factor b/extra/sandbox/sandbox.factor new file mode 100644 index 0000000000..a9d65ee5ab --- /dev/null +++ b/extra/sandbox/sandbox.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2009 Maxim Savchenko. +! See http://factorcode.org/license.txt for BSD license. + +USING: kernel sequences vectors assocs namespaces parser lexer vocabs + combinators.short-circuit vocabs.parser ; + +IN: sandbox + +SYMBOL: whitelist + +: with-sandbox-vocabs ( quot -- ) + "sandbox.syntax" load-vocab vocab-words 1vector + use [ call ] with-variable ; inline + +: parse-sandbox ( lines assoc -- quot ) + whitelist [ [ parse-lines ] with-sandbox-vocabs ] with-variable ; + +: reveal-in ( name -- ) + [ { [ search ] [ no-word ] } 1|| ] keep current-vocab vocab-words set-at ; + +SYNTAX: REVEAL: scan reveal-in ; + +SYNTAX: REVEALING: ";" parse-tokens [ reveal-in ] each ; diff --git a/extra/sandbox/summary.txt b/extra/sandbox/summary.txt new file mode 100644 index 0000000000..3ca1e25684 --- /dev/null +++ b/extra/sandbox/summary.txt @@ -0,0 +1 @@ +Basic sandboxing diff --git a/extra/sandbox/syntax/syntax.factor b/extra/sandbox/syntax/syntax.factor new file mode 100644 index 0000000000..2ff5f070c7 --- /dev/null +++ b/extra/sandbox/syntax/syntax.factor @@ -0,0 +1,26 @@ +! Copyright (C) 2009 Maxim Savchenko. +! See http://factorcode.org/license.txt for BSD license. + +USING: kernel sequences assocs namespaces lexer vocabs.parser sandbox ; +IN: sandbox.syntax + + + +SYNTAX: APPLY: scan sandbox-use+ ; + +SYNTAX: APPLYING: ";" parse-tokens [ sandbox-use+ ] each ; + +REVEALING: + ! #! + HEX: OCT: BIN: f t CHAR: " + [ { T{ + ] } ; + +REVEAL: ; From 33d99b607653fbce0f34bc31678dcc070bbf0b63 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 4 Apr 2009 11:10:13 +0200 Subject: [PATCH 070/772] checkpoint tuple integration --- bson/constants/constants.factor | 6 +- bson/writer/writer.factor | 2 +- mongodb/driver/driver.factor | 12 ++- mongodb/tuple/collection/collection.factor | 90 +++++++++++++++++++++ mongodb/tuple/index/index.factor | 54 +++++++++++++ mongodb/tuple/persistent/persistent.factor | 92 ++++++++++++++++++++++ mongodb/tuple/state/state.factor | 44 +++++++++++ mongodb/tuple/tuple.factor | 83 +++++++++++++++++++ 8 files changed, 377 insertions(+), 6 deletions(-) create mode 100644 mongodb/tuple/collection/collection.factor create mode 100644 mongodb/tuple/index/index.factor create mode 100644 mongodb/tuple/persistent/persistent.factor create mode 100644 mongodb/tuple/state/state.factor create mode 100644 mongodb/tuple/tuple.factor diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index 0da3cc0bb5..aa852bbff8 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -1,4 +1,4 @@ -USING: accessors kernel math parser sequences strings uuid ; +USING: accessors constructors kernel strings uuid ; IN: bson.constants @@ -11,6 +11,8 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ; TUPLE: objref ns objid ; +CONSTRUCTOR: objref ( ns objid -- objref ) ; + TUPLE: mdbregexp { regexp string } { options string } ; : ( string -- mdbregexp ) @@ -18,7 +20,7 @@ TUPLE: mdbregexp { regexp string } { options string } ; CONSTANT: MDB_OID_FIELD "_id" -CONSTANT: MDB_INTERNAL_FIELD "_mdb_" +CONSTANT: MDB_META_FIELD "_mfd" CONSTANT: T_EOO 0 CONSTANT: T_Double 1 diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 4c94840888..3684a644d5 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -149,7 +149,7 @@ M: sequence bson-write ( array -- ) [ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline : skip-field? ( name -- boolean ) - { "_id" "_mdb" } member? ; inline + { "_id" "_mfd" } member? ; inline M: assoc bson-write ( assoc -- ) '[ _ [ write-oid ] keep diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index a70dfb25c4..1853beb81f 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -20,7 +20,8 @@ TUPLE: mdb-collection { size integer initial: -1 } { max integer initial: -1 } ; -CONSTRUCTOR: mdb-collection ( name -- collection ) ; +: ( name -- collection ) + [ mdb-collection new ] dip >>name ; inline CONSTANT: MDB-GENERAL-ERROR 1 @@ -73,6 +74,10 @@ SYNTAX: r/ ( token -- mdbregexp ) [ >>mdb-stream ] prepose with-disposal ] with-scope ; inline +: build-id-selector ( assoc -- selector ) + [ MDB_OID_FIELD swap at ] keep + H{ } clone [ set-at ] keep ; + > "size" ] dip set-at ] [ [ max>> "max" ] dip set-at ] 2tri ] when ] 2bi - ] keep 1 >>return# send-query-plain objects>> first check-ok + ] keep 1 >>return# send-query-plain + objects>> first check-ok [ "could not create collection" throw ] unless ; : load-collection-list ( -- collection-list ) @@ -238,7 +244,7 @@ GENERIC: find-one ( mdb-query -- result/f ) M: mdb-query-msg find-one 1 >>return# send-query-plain objects>> [ first ] [ f ] if* ; -GENERIC: count ( collection query -- result ) +GENERIC: count ( collection selector -- result ) M: assoc count [ "count" H{ } clone [ set-at ] keep ] dip [ over [ "query" ] dip set-at ] when* diff --git a/mongodb/tuple/collection/collection.factor b/mongodb/tuple/collection/collection.factor new file mode 100644 index 0000000000..e5dedf1967 --- /dev/null +++ b/mongodb/tuple/collection/collection.factor @@ -0,0 +1,90 @@ + +USING: accessors arrays assocs bson.constants classes classes.tuple +continuations fry kernel mongodb.driver sequences +vectors words ; + +IN: mongodb.tuple.collection + +MIXIN: mdb-persistent + +SLOT: _id +SLOT: _mfd + +TUPLE: mdb-tuple-collection < mdb-collection { classes } ; + +GENERIC: tuple-collection ( object -- mdb-collection ) + +GENERIC: mdb-slot-list ( tuple -- string ) + +assoc ( seq -- assoc ) + [ dup assoc? + [ 1array { "" } append ] unless ] map ; + +: optl>map ( seq -- map ) + H{ } clone tuck + '[ split-optl opt>assoc swap _ set-at ] each ; inline + +PRIVATE> + +: MDB_ADDON_SLOTS ( -- slots ) + { } [ MDB_OID_FIELD MDB_META_FIELD ] with-datastack ; inline + +: link-class ( collection class -- ) + over classes>> + [ 2dup member? [ 2drop ] [ push ] if ] + [ 1vector >>classes ] if* drop ; inline + +: link-collection ( class collection -- ) + [ swap link-class ] + [ MDB_COLLECTION set-word-prop ] 2bi ; inline + +: mdb-check-slots ( superclass slots -- superclass slots ) + over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member? + [ ] [ MDB_ADDON_SLOTS prepend ] if ; inline + +: set-slot-options ( class options -- ) + '[ MDB_SLOTDEF_LIST _ optl>map set-word-prop ] keep + dup tuple-collection link-collection ; inline + +M: tuple-class tuple-collection ( tuple -- mdb-collection ) + (mdb-collection) ; + +M: mdb-persistent tuple-collection ( tuple -- mdb-collection ) + class (mdb-collection) ; + +M: mdb-persistent mdb-slot-list ( tuple -- string ) + class (mdb-slot-list) ; + +M: tuple-class mdb-slot-list ( class -- assoc ) + (mdb-slot-list) ; + +M: mdb-collection mdb-slot-list ( collection -- assoc ) + classes>> [ mdb-slot-list ] map assoc-combine ; + +: collection-map ( -- assoc ) + MDB_COLLECTION_MAP mdb-persistent word-prop + [ mdb-persistent MDB_COLLECTION_MAP H{ } clone + [ set-word-prop ] keep ] unless* ; inline + +: ( name -- mdb-tuple-collection ) + collection-map [ ] [ key? ] 2bi + [ at ] [ [ mdb-tuple-collection new dup ] 2dip + [ [ >>name ] keep ] dip set-at ] if ; inline + diff --git a/mongodb/tuple/index/index.factor b/mongodb/tuple/index/index.factor new file mode 100644 index 0000000000..466c36f719 --- /dev/null +++ b/mongodb/tuple/index/index.factor @@ -0,0 +1,54 @@ +USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep +mongodb.tuple.collection combinators mongodb.tuple.collection ; + +IN: mongodb.tuple.index + +TUPLE: tuple-index name spec ; + +SYMBOLS: +transient+ +load+ +fieldindex+ +compoundindex+ +deepindex+ ; + + ] 2dip + [ rest ] keep first ! assoc slot options itype + { { +fieldindex+ [ drop [ 1 ] dip pick set-at ] } + { +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] } + { +compoundindex+ [ + 2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options + over '[ _ [ 1 ] 2dip set-at ] each ] } + } case ; + +: build-index-seq ( slot optlist -- index-seq ) + [ V{ } clone ] 2dip pick ! v{} slot optl v{} + [ swap ] dip ! v{} optl slot v{ } + '[ _ tuple-index new ! element slot exemplar + 2over swap index-name >>name ! element slot clone + [ build-index ] dip swap >>spec _ push + ] each ; + +: is-index-declaration? ( entry -- ? ) + first + { { +fieldindex+ [ t ] } + { +compoundindex+ [ t ] } + { +deepindex+ [ t ] } + [ drop f ] } case ; + +PRIVATE> + +: tuple-index-list ( mdb-collection/class -- seq ) + mdb-slot-list V{ } clone tuck + '[ [ is-index-declaration? ] filter + build-index-seq _ push + ] assoc-each flatten ; + diff --git a/mongodb/tuple/persistent/persistent.factor b/mongodb/tuple/persistent/persistent.factor new file mode 100644 index 0000000000..9b6b8e646e --- /dev/null +++ b/mongodb/tuple/persistent/persistent.factor @@ -0,0 +1,92 @@ +USING: accessors assocs classes fry kernel linked-assocs math mirrors +namespaces sequences strings vectors words bson.constants +continuations mongodb.driver mongodb.tuple.collection mongodb.tuple.state ; + +IN: mongodb.tuple.persistent + +SYMBOL: mdb-store-list + +GENERIC: tuple>assoc ( tuple -- assoc ) + +GENERIC: tuple>selector ( tuple -- selector ) + +DEFER: assoc>tuple +DEFER: mdb-persistent? + +tuple-class ( tuple-info -- class ) + [ first ] keep second lookup ; inline + +: tuple-instance ( tuple-info -- instance ) + mdbinfo>tuple-class new ; inline + +: [keys>tuple] ( mirror assoc -- quot: ( elt -- ) ) + '[ dup _ at assoc>tuple swap _ set-at ] ; + +: prepare-assoc>tuple ( assoc -- tuple keylist mirror assoc ) + [ tuple-info tuple-instance dup + [ keys ] keep ] keep swap ; inline + +: make-tuple ( assoc -- tuple ) + prepare-assoc>tuple [keys>tuple] each + [ set-persistent ] keep ; inline + +: at+ ( value key assoc -- value ) + 2dup key? + [ at nip ] [ [ dup ] 2dip set-at ] if ; inline + +: data-tuple? ( tuple -- ? ) + dup tuple? + [ assoc? not ] [ drop f ] if ; inline + +: add-storable ( assoc ns -- ) + [ H{ } clone ] dip mdb-store-list get at+ + [ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline + +: write-tuple-fields ( mirror assoc conv-quot -- ) + swap [ dup ] dip ! m a a q + '[ [ dup mdb-persistent? + [ _ keep + [ tuple-collection ] keep + [ add-storable ] dip + [ tuple-collection ] [ _id>> ] bi ] + [ dup data-tuple? _ [ ] if ] if _ set-at ] [ drop ] if* + ] assoc-each ; + +: prepare-assoc ( tuple -- assoc mirror assoc ) + H{ } clone tuck ; inline + +: ensure-mdb-info ( tuple -- tuple ) + dup _id>> [ >>_id ] unless + [ set-persistent ] keep ; inline + +: with-store-list ( quot: ( -- ) -- store-assoc ) + [ H{ } clone dup mdb-store-list ] dip with-variable ; inline + +: (tuple>assoc) ( tuple -- assoc ) + [ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep + over set-tuple-info ; + +PRIVATE> + +GENERIC: tuple>storable ( tuple -- storable ) +M: mdb-persistent tuple>storable ( mdb-persistent -- store-list ) + '[ _ [ tuple>assoc ] keep tuple-collection add-storable ] with-store-list ; inline + +M: mdb-persistent tuple>assoc ( tuple -- assoc ) + ensure-mdb-info (tuple>assoc) ; + +M: tuple tuple>assoc ( tuple -- assoc ) + (tuple>assoc) ; + +M: tuple tuple>selector ( tuple -- assoc ) + prepare-assoc [ tuple>selector ] write-tuple-fields ; + +: assoc>tuple ( assoc -- tuple ) + dup assoc? + [ [ dup tuple-info? + [ make-tuple ] + [ ] if ] [ drop ] recover + ] [ ] if ; inline + diff --git a/mongodb/tuple/state/state.factor b/mongodb/tuple/state/state.factor new file mode 100644 index 0000000000..1d6dde3654 --- /dev/null +++ b/mongodb/tuple/state/state.factor @@ -0,0 +1,44 @@ +USING: classes kernel accessors sequences assocs mongodb.tuple.collection ; + +IN: mongodb.tuple.state + + + +: ( tuple -- tuple-info ) + class V{ } clone tuck + [ [ name>> ] dip push ] + [ [ vocabulary>> ] dip push ] 2bi ; inline + +: tuple-info ( assoc -- tuple-info ) + [ MDB_TUPLE_INFO ] dip at ; inline + +: set-tuple-info ( tuple assoc -- ) + [ MDB_TUPLE_INFO ] dip set-at ; inline + +: tuple-info? ( assoc -- ? ) + [ MDB_TUPLE_INFO ] dip key? ; + +: tuple-meta ( tuple -- assoc ) + dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline + +: dirty? ( tuple -- ? ) + MDB_DIRTY_FLAG tuple-meta at ; + +: set-dirty ( tuple -- ) + t MDB_DIRTY_FLAG tuple-meta set-at ; + +: persistent? ( tuple -- ? ) + MDB_PERSISTENT_FLAG tuple-meta at ; + +: set-persistent ( tuple -- ) + t MDB_PERSISTENT_FLAG tuple-meta set-at ; + +: needs-store? ( tuple -- ? ) + [ persistent? not ] [ dirty? ] bi or ; + diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor new file mode 100644 index 0000000000..9b4f462f2e --- /dev/null +++ b/mongodb/tuple/tuple.factor @@ -0,0 +1,83 @@ +USING: accessors assocs classes classes.mixin classes.tuple vectors math +classes.tuple.parser formatting generalizations kernel sequences fry combinators +linked-assocs sequences.deep mongodb.driver continuations memoize bson.constants +prettyprint strings compiler.units slots tools.walker words arrays ; + +IN: mongodb.tuple + +USING: mongodb.tuple.state mongodb.tuple.persistent mongodb.tuple.collection +mongodb.tuple.index mongodb.msg ; + +SYNTAX: MDBTUPLE: + parse-tuple-definition + mdb-check-slots + define-tuple-class ; + +: define-persistent ( class collection options -- ) + [ [ dup ] dip link-collection ] dip ! cl options + [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip + set-slot-options ; + +: ensure-table ( class -- ) + tuple-collection + [ create-collection ] + [ [ tuple-index-list ] keep + '[ _ swap [ name>> ] [ spec>> ] bi ensure-index ] each + ] bi ; + +: ensure-tables ( classes -- ) + [ ensure-table ] each ; + +: drop-table ( class -- ) + tuple-collection + [ [ tuple-index-list ] keep + '[ _ swap name>> drop-index ] each ] + [ name>> drop-collection ] bi ; + +: recreate-table ( class -- ) + [ drop-table ] + [ ensure-table ] bi ; + +> id-selector ; + +: (save-tuples) ( collection assoc -- ) + swap '[ [ _ ] 2dip + [ id-selector ] dip + update ] assoc-each ; inline +PRIVATE> + +: save-tuple ( tuple -- ) + tuple>assoc [ (save-tuples) ] assoc-each ; + +: update-tuple ( tuple -- ) + save-tuple ; + +: insert-tuple ( tuple -- ) + save-tuple ; + +: delete-tuple ( tuple -- ) + dup persistent? + [ [ tuple-collection name>> ] keep + id-selector delete ] [ drop ] if ; + +: tuple>query ( tuple -- query ) + [ tuple-collection name>> ] keep + tuple>selector ; + +: select-tuple ( tuple/query -- tuple/f ) + dup mdb-query-msg? [ ] [ tuple>query ] if + find-one [ assoc>tuple ] [ f ] if* ; + +: select-tuples ( tuple/query -- cursor tuples/f ) + dup mdb-query-msg? [ ] [ tuple>query ] if + find [ assoc>tuple ] map ; + +: count-tuples ( tuple/query -- n ) + dup mdb-query-msg? [ tuple>query ] unless + [ collection>> ] [ query>> ] bi count ; From 3ef4784a631688624e1f7924446149c6ee7814d3 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 4 Apr 2009 11:25:38 +0200 Subject: [PATCH 071/772] fixed recursive compiler errors --- mongodb/tuple/persistent/persistent.factor | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/mongodb/tuple/persistent/persistent.factor b/mongodb/tuple/persistent/persistent.factor index 9b6b8e646e..5dfb418c0d 100644 --- a/mongodb/tuple/persistent/persistent.factor +++ b/mongodb/tuple/persistent/persistent.factor @@ -21,16 +21,14 @@ DEFER: mdb-persistent? : tuple-instance ( tuple-info -- instance ) mdbinfo>tuple-class new ; inline -: [keys>tuple] ( mirror assoc -- quot: ( elt -- ) ) - '[ dup _ at assoc>tuple swap _ set-at ] ; - : prepare-assoc>tuple ( assoc -- tuple keylist mirror assoc ) [ tuple-info tuple-instance dup [ keys ] keep ] keep swap ; inline : make-tuple ( assoc -- tuple ) - prepare-assoc>tuple [keys>tuple] each - [ set-persistent ] keep ; inline + prepare-assoc>tuple + '[ dup _ at assoc>tuple swap _ set-at ] each + [ set-persistent ] keep ; inline recursive : at+ ( value key assoc -- value ) 2dup key? @@ -88,5 +86,5 @@ M: tuple tuple>selector ( tuple -- assoc ) [ [ dup tuple-info? [ make-tuple ] [ ] if ] [ drop ] recover - ] [ ] if ; inline + ] [ ] if ; inline recursive From c80084d606e5312fe61173bb80ebffd6eea69829 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 4 Apr 2009 14:11:27 +0200 Subject: [PATCH 072/772] fixed objid / objref write and read --- bson/reader/reader.factor | 7 +++---- bson/writer/writer.factor | 22 +++++++++++++--------- 2 files changed, 16 insertions(+), 13 deletions(-) diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index ad0f8fdff8..595ca59544 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -184,12 +184,11 @@ M: bson-oid element-data-read ( type -- oid ) M: bson-binary-custom element-binary-read ( size type -- dbref ) 2drop read-cstring - read-cstring objid boa - objref boa ; + read-cstring objref boa ; M: bson-binary-uuid element-binary-read ( size type -- object ) - drop - read-sized-string + 2drop + read-cstring objid boa ; M: bson-binary-bytes element-binary-read ( size type -- bytes ) diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 3684a644d5..441bc182de 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Sascha Matzke. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs bson.constants byte-arrays byte-vectors -calendar fry io io.binary io.encodings io.encodings.string io.encodings.private -io.encodings.utf8.private io.encodings.utf8 kernel math math.parser namespaces quotations -sequences sequences.private serialize strings tools.walker words ; +calendar fry io io.binary io.encodings io.encodings.binary +io.encodings.utf8 io.streams.byte-array kernel math math.parser +namespaces quotations sequences sequences.private serialize strings +words ; IN: bson.writer @@ -126,14 +127,17 @@ M: oid bson-write ( oid -- ) [ a>> write-longlong ] [ b>> write-int32 ] bi ; M: objid bson-write ( oid -- ) - T_Binary_UUID write-byte - id>> '[ _ write-utf8-string ] with-length-prefix ; + id>> [ binary ] dip '[ _ write-cstring ] with-byte-writer + [ length write-int32 ] keep + T_Binary_UUID write-byte write ; M: objref bson-write ( objref -- ) - T_Binary_Custom write-byte + [ binary ] dip '[ _ [ ns>> write-cstring ] - [ objid>> id>> write-cstring ] bi ] with-length-prefix ; + [ objid>> id>> write-cstring ] bi ] with-byte-writer + [ length write-int32 ] keep + T_Binary_Custom write-byte write ; M: mdbregexp bson-write ( regexp -- ) [ regexp>> write-cstring ] @@ -145,8 +149,8 @@ M: sequence bson-write ( array -- ) write-eoo ] with-length-prefix ; : write-oid ( assoc -- ) - [ MDB_OID_FIELD ] dip at* - [ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline + [ MDB_OID_FIELD ] dip at + [ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline : skip-field? ( name -- boolean ) { "_id" "_mfd" } member? ; inline From a61796fe7634eaa62e530c7025db3587d3b99b87 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 4 Apr 2009 16:13:56 +0200 Subject: [PATCH 073/772] another checkpoint - tuple integration seems to work --- bson/constants/constants.factor | 4 +- bson/reader/reader.factor | 5 -- bson/writer/writer.factor | 8 +--- mongodb/driver/driver.factor | 1 + mongodb/tuple/collection/collection.factor | 54 ++++++++++++++++------ mongodb/tuple/index/index.factor | 10 ++-- mongodb/tuple/persistent/persistent.factor | 19 ++++---- mongodb/tuple/state/state.factor | 10 ++-- mongodb/tuple/tuple.factor | 26 +++++------ 9 files changed, 79 insertions(+), 58 deletions(-) diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index aa852bbff8..5148413b61 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -2,10 +2,8 @@ USING: accessors constructors kernel strings uuid ; IN: bson.constants -TUPLE: objid id ; - : ( -- objid ) - objid new uuid1 >>id ; inline + uuid1 ; inline TUPLE: oid { a initial: 0 } { b initial: 0 } ; diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index 595ca59544..94728b2622 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -186,11 +186,6 @@ M: bson-binary-custom element-binary-read ( size type -- dbref ) read-cstring read-cstring objref boa ; -M: bson-binary-uuid element-binary-read ( size type -- object ) - 2drop - read-cstring - objid boa ; - M: bson-binary-bytes element-binary-read ( size type -- bytes ) drop read ; diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 441bc182de..2b1fc54537 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -77,7 +77,6 @@ M: timestamp bson-type? ( timestamp -- type ) drop T_Date ; M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ; M: oid bson-type? ( word -- type ) drop T_OID ; -M: objid bson-type? ( objid -- type ) drop T_Binary ; M: objref bson-type? ( objref -- type ) drop T_Binary ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; @@ -126,16 +125,11 @@ M: quotation bson-write ( quotation -- ) M: oid bson-write ( oid -- ) [ a>> write-longlong ] [ b>> write-int32 ] bi ; -M: objid bson-write ( oid -- ) - id>> [ binary ] dip '[ _ write-cstring ] with-byte-writer - [ length write-int32 ] keep - T_Binary_UUID write-byte write ; - M: objref bson-write ( objref -- ) [ binary ] dip '[ _ [ ns>> write-cstring ] - [ objid>> id>> write-cstring ] bi ] with-byte-writer + [ objid>> write-cstring ] bi ] with-byte-writer [ length write-int32 ] keep T_Binary_Custom write-byte write ; diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 1853beb81f..e15fe9b679 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -195,6 +195,7 @@ MEMO: reserved-namespace? ( name -- ? ) PRIVATE> MEMO: ensure-collection ( collection -- fq-collection ) + dup mdb-collection? [ name>> ] when "." split1 over mdb name>> = [ nip ] [ drop ] if [ ] [ reserved-namespace? ] bi diff --git a/mongodb/tuple/collection/collection.factor b/mongodb/tuple/collection/collection.factor index e5dedf1967..d75e143b7b 100644 --- a/mongodb/tuple/collection/collection.factor +++ b/mongodb/tuple/collection/collection.factor @@ -1,10 +1,16 @@ USING: accessors arrays assocs bson.constants classes classes.tuple -continuations fry kernel mongodb.driver sequences +combinators continuations fry kernel mongodb.driver sequences strings vectors words ; +IN: mongodb.tuple + +SINGLETONS: +transient+ +load+ ; + IN: mongodb.tuple.collection +FROM: mongodb.tuple => +transient+ +load+ ; + MIXIN: mdb-persistent SLOT: _id @@ -14,7 +20,7 @@ TUPLE: mdb-tuple-collection < mdb-collection { classes } ; GENERIC: tuple-collection ( object -- mdb-collection ) -GENERIC: mdb-slot-list ( tuple -- string ) +GENERIC: mdb-slot-map ( tuple -- string ) over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member? [ ] [ MDB_ADDON_SLOTS prepend ] if ; inline -: set-slot-options ( class options -- ) - '[ MDB_SLOTDEF_LIST _ optl>map set-word-prop ] keep +: set-slot-map ( class options -- ) + '[ _ optl>map MDB_SLOTDEF_LIST set-word-prop ] keep dup tuple-collection link-collection ; inline M: tuple-class tuple-collection ( tuple -- mdb-collection ) @@ -69,22 +75,44 @@ M: tuple-class tuple-collection ( tuple -- mdb-collection ) M: mdb-persistent tuple-collection ( tuple -- mdb-collection ) class (mdb-collection) ; -M: mdb-persistent mdb-slot-list ( tuple -- string ) - class (mdb-slot-list) ; +M: mdb-persistent mdb-slot-map ( tuple -- string ) + class (mdb-slot-map) ; -M: tuple-class mdb-slot-list ( class -- assoc ) - (mdb-slot-list) ; +M: tuple-class mdb-slot-map ( class -- assoc ) + (mdb-slot-map) ; -M: mdb-collection mdb-slot-list ( collection -- assoc ) - classes>> [ mdb-slot-list ] map assoc-combine ; +M: mdb-collection mdb-slot-map ( collection -- assoc ) + classes>> [ mdb-slot-map ] map assoc-combine ; + + ( name -- mdb-tuple-collection ) +PRIVATE> + +GENERIC: ( name -- mdb-tuple-collection ) +M: string ( name -- mdb-tuple-collection ) collection-map [ ] [ key? ] 2bi [ at ] [ [ mdb-tuple-collection new dup ] 2dip [ [ >>name ] keep ] dip set-at ] if ; inline +M: mdb-tuple-collection ( mdb-tuple-collection -- mdb-tuple-collection ) ; +M: mdb-collection ( mdb-collection -- mdb-tuple-collection ) + [ name>> ] keep + { + [ capped>> >>capped ] + [ size>> >>size ] + [ max>> >>max ] + } cleave ; +: transient-slot? ( tuple slot -- ? ) + +transient+ slot-option? ; + +: load-slot? ( tuple slot -- ? ) + +load+ slot-option? ; diff --git a/mongodb/tuple/index/index.factor b/mongodb/tuple/index/index.factor index 466c36f719..270fecfd38 100644 --- a/mongodb/tuple/index/index.factor +++ b/mongodb/tuple/index/index.factor @@ -1,11 +1,15 @@ USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep mongodb.tuple.collection combinators mongodb.tuple.collection ; +IN: mongodb.tuple + +SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ ; + IN: mongodb.tuple.index -TUPLE: tuple-index name spec ; +FROM: mongodb.tuple => +fieldindex+ +compoundindex+ +deepindex+ ; -SYMBOLS: +transient+ +load+ +fieldindex+ +compoundindex+ +deepindex+ ; +TUPLE: tuple-index name spec ; : tuple-index-list ( mdb-collection/class -- seq ) - mdb-slot-list V{ } clone tuck + mdb-slot-map V{ } clone tuck '[ [ is-index-declaration? ] filter build-index-seq _ push ] assoc-each flatten ; diff --git a/mongodb/tuple/persistent/persistent.factor b/mongodb/tuple/persistent/persistent.factor index 5dfb418c0d..6d5e1837a7 100644 --- a/mongodb/tuple/persistent/persistent.factor +++ b/mongodb/tuple/persistent/persistent.factor @@ -11,7 +11,6 @@ GENERIC: tuple>assoc ( tuple -- assoc ) GENERIC: tuple>selector ( tuple -- selector ) DEFER: assoc>tuple -DEFER: mdb-persistent? > ] bi ] - [ dup data-tuple? _ [ ] if ] if _ set-at ] [ drop ] if* + [ dup data-tuple? _ [ ] if ] if swap _ set-at ] [ 2drop ] if ] assoc-each ; -: prepare-assoc ( tuple -- assoc mirror assoc ) - H{ } clone tuck ; inline +: prepare-assoc ( tuple -- assoc mirror tuple assoc ) + H{ } clone swap [ ] keep pick ; inline : ensure-mdb-info ( tuple -- tuple ) dup _id>> [ >>_id ] unless diff --git a/mongodb/tuple/state/state.factor b/mongodb/tuple/state/state.factor index 1d6dde3654..e0e045e31d 100644 --- a/mongodb/tuple/state/state.factor +++ b/mongodb/tuple/state/state.factor @@ -28,17 +28,17 @@ PRIVATE> dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline : dirty? ( tuple -- ? ) - MDB_DIRTY_FLAG tuple-meta at ; + MDB_DIRTY_FLAG tuple-meta at ; : set-dirty ( tuple -- ) - t MDB_DIRTY_FLAG tuple-meta set-at ; + [ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ; : persistent? ( tuple -- ? ) - MDB_PERSISTENT_FLAG tuple-meta at ; + MDB_PERSISTENT_FLAG tuple-meta at ; : set-persistent ( tuple -- ) - t MDB_PERSISTENT_FLAG tuple-meta set-at ; + [ t MDB_PERSISTENT_FLAG ] dip tuple-meta set-at ; : needs-store? ( tuple -- ? ) - [ persistent? not ] [ dirty? ] bi or ; + [ persistent? not ] [ dirty? ] bi or ; diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor index 9b4f462f2e..089a3ec121 100644 --- a/mongodb/tuple/tuple.factor +++ b/mongodb/tuple/tuple.factor @@ -1,28 +1,26 @@ -USING: accessors assocs classes classes.mixin classes.tuple vectors math -classes.tuple.parser formatting generalizations kernel sequences fry combinators -linked-assocs sequences.deep mongodb.driver continuations memoize bson.constants -prettyprint strings compiler.units slots tools.walker words arrays ; +USING: accessors assocs classes.mixin classes.tuple +classes.tuple.parser compiler.units fry kernel mongodb.driver +mongodb.msg mongodb.tuple.collection mongodb.tuple.index +mongodb.tuple.persistent mongodb.tuple.state sequences strings ; IN: mongodb.tuple -USING: mongodb.tuple.state mongodb.tuple.persistent mongodb.tuple.collection -mongodb.tuple.index mongodb.msg ; - SYNTAX: MDBTUPLE: parse-tuple-definition mdb-check-slots define-tuple-class ; : define-persistent ( class collection options -- ) + [ ] dip [ [ dup ] dip link-collection ] dip ! cl options [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip - set-slot-options ; + set-slot-map ; : ensure-table ( class -- ) tuple-collection [ create-collection ] [ [ tuple-index-list ] keep - '[ _ swap [ name>> ] [ spec>> ] bi ensure-index ] each + '[ _ name>> swap [ name>> ] [ spec>> ] bi ensure-index ] each ] bi ; : ensure-tables ( classes -- ) @@ -31,7 +29,7 @@ SYNTAX: MDBTUPLE: : drop-table ( class -- ) tuple-collection [ [ tuple-index-list ] keep - '[ _ swap name>> drop-index ] each ] + '[ _ name>> swap name>> drop-index ] each ] [ name>> drop-collection ] bi ; : recreate-table ( class -- ) @@ -41,19 +39,19 @@ SYNTAX: MDBTUPLE: > id-selector ; + _id>> id-selector ; : (save-tuples) ( collection assoc -- ) swap '[ [ _ ] 2dip [ id-selector ] dip - update ] assoc-each ; inline + >upsert update ] assoc-each ; inline PRIVATE> : save-tuple ( tuple -- ) - tuple>assoc [ (save-tuples) ] assoc-each ; + tuple>storable [ (save-tuples) ] assoc-each ; : update-tuple ( tuple -- ) save-tuple ; From b4a74f55a3506a5abe083f99f259edfdb8497495 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 4 Apr 2009 19:57:48 -0500 Subject: [PATCH 074/772] Add hashcode method for simple-alien; improves performance of malloc and free --- core/alien/alien.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/core/alien/alien.factor b/core/alien/alien.factor index ea0cb9208e..05f5223548 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -49,6 +49,8 @@ M: alien equal? 2drop f ] if ; +M: simple-alien hashcode* nip alien-address ; + ERROR: alien-callback-error ; : alien-callback ( return parameters abi quot -- alien ) From e84cc5f82d47a3c6d1db369bf0f8334b3598f548 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 4 Apr 2009 20:03:30 -0500 Subject: [PATCH 075/772] Simplify do-matrix --- basis/opengl/opengl-docs.factor | 4 ++-- basis/opengl/opengl.factor | 8 ++++---- basis/ui/text/text.factor | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/basis/opengl/opengl-docs.factor b/basis/opengl/opengl-docs.factor index f474c97b73..b773833280 100644 --- a/basis/opengl/opengl-docs.factor +++ b/basis/opengl/opengl-docs.factor @@ -15,8 +15,8 @@ HELP: do-enabled { $description "Wraps a quotation in " { $link glEnable } "/" { $link glDisable } " calls." } ; HELP: do-matrix -{ $values { "mode" { $link GL_MODELVIEW } " or " { $link GL_PROJECTION } } { "quot" quotation } } -{ $description "Saves and restores the matrix specified by " { $snippet "mode" } " before and after calling the quotation." } ; +{ $values { "quot" quotation } } +{ $description "Saves and restores the current matrix before and after calling the quotation." } ; HELP: gl-line { $values { "a" "a pair of integers" } { "b" "a pair of integers" } } diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index 0a21f67376..c60917b42a 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -44,9 +44,8 @@ MACRO: all-enabled ( seq quot -- ) MACRO: all-enabled-client-state ( seq quot -- ) [ words>values ] dip '[ _ _ (all-enabled-client-state) ] ; -: do-matrix ( mode quot -- ) - swap [ glMatrixMode glPushMatrix call ] keep - glMatrixMode glPopMatrix ; inline +: do-matrix ( quot -- ) + glPushMatrix call glPopMatrix ; inline : gl-material ( face pname params -- ) float-array{ } like glMaterialfv ; @@ -165,7 +164,7 @@ MACRO: set-draw-buffers ( buffers -- ) : delete-dlist ( id -- ) 1 glDeleteLists ; : with-translation ( loc quot -- ) - GL_MODELVIEW [ [ gl-translate ] dip call ] do-matrix ; inline + [ [ gl-translate ] dip call ] do-matrix ; inline : fix-coordinates ( point1 point2 -- x1 y2 x2 y2 ) [ first2 [ >fixnum ] bi@ ] bi@ ; @@ -177,6 +176,7 @@ MACRO: set-draw-buffers ( buffers -- ) fix-coordinates glViewport ; : init-matrices ( -- ) + #! Leaves with matrix mode GL_MODELVIEW GL_PROJECTION glMatrixMode glLoadIdentity GL_MODELVIEW glMatrixMode diff --git a/basis/ui/text/text.factor b/basis/ui/text/text.factor index d787fe8ea9..2edb20fc22 100755 --- a/basis/ui/text/text.factor +++ b/basis/ui/text/text.factor @@ -66,7 +66,7 @@ M: string draw-text draw-string ; M: selection draw-text draw-string ; M: array draw-text - GL_MODELVIEW [ + [ [ [ draw-string ] [ [ 0.0 ] 2dip string-height 0.0 glTranslated ] 2bi From 1a4f2724e40e7ee16e71fea20d4866e16cd32212 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 4 Apr 2009 20:03:44 -0500 Subject: [PATCH 076/772] Don't call glFlush, it's useless --- basis/ui/backend/backend.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor index 76fbc7286b..d72ef13b44 100755 --- a/basis/ui/backend/backend.factor +++ b/basis/ui/backend/backend.factor @@ -29,6 +29,6 @@ HOOK: offscreen-pixels ui-backend ( world -- alien w h ) : with-gl-context ( handle quot -- ) swap [ select-gl-context call ] keep - glFlush flush-gl-context gl-error ; inline + flush-gl-context gl-error ; inline HOOK: (with-ui) ui-backend ( quot -- ) \ No newline at end of file From 0affe96d959c414e99b350e4aff92067ef6a433b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 4 Apr 2009 20:04:35 -0500 Subject: [PATCH 077/772] opengl.textures: pad image up to a power of 2 using glTexSubImage2D instead of doing it in Factor code --- basis/opengl/textures/textures.factor | 89 +++++++++--------------- basis/ui/images/images.factor | 2 +- basis/ui/text/core-text/core-text.factor | 4 +- basis/ui/text/pango/pango.factor | 4 +- basis/ui/text/uniscribe/uniscribe.factor | 2 +- basis/windows/uniscribe/uniscribe.factor | 5 +- 6 files changed, 36 insertions(+), 70 deletions(-) diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index 3efe924fb5..cdd421ddde 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs cache colors.constants destructors fry kernel opengl opengl.gl combinators images images.tesselation grouping -specialized-arrays.float locals sequences math math.vectors -math.matrices generalizations fry columns arrays ; +specialized-arrays.float sequences math math.vectors +math.matrices generalizations fry arrays ; IN: opengl.textures : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ; @@ -19,61 +19,42 @@ M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ; M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; -GENERIC: draw-texture ( texture -- ) +SLOT: display-list + +: draw-texture ( texture -- ) display-list>> [ glCallList ] when* ; GENERIC: draw-scaled-texture ( dim texture -- ) > first2 [ next-power-of-2 ] bi@ 0 ] + [ component-order>> component-order>format f ] bi + glTexImage2D ; -: power-of-2-bitmap ( rows dim size -- bitmap dim ) - '[ - first2 - [ [ _ ] dip '[ _ group _ repeat-last ] map ] - [ repeat-last ] - bi* - ] keep ; +: (tex-sub-image) ( image -- ) + [ GL_TEXTURE_2D 0 0 0 ] dip + [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri + glTexSubImage2D ; -: image-rows ( image -- rows ) - [ bitmap>> ] - [ dim>> first ] - [ component-order>> bytes-per-pixel ] - tri * group ; inline - -: power-of-2-image ( image -- image ) - dup dim>> [ [ 0 = ] [ power-of-2? ] bi or ] all? [ - clone dup - [ image-rows ] - [ dim>> [ next-power-of-2 ] map ] - [ component-order>> bytes-per-pixel ] tri - power-of-2-bitmap - [ >>bitmap ] [ >>dim ] bi* - ] unless ; - -:: make-texture ( image -- id ) +: make-texture ( image -- id ) + #! We use glTexSubImage2D to work around the power of 2 texture size + #! limitation gen-texture [ GL_TEXTURE_BIT [ GL_TEXTURE_2D swap glBindTexture - GL_TEXTURE_2D - 0 - GL_RGBA - image dim>> first2 - 0 - image component-order>> component-order>format - image bitmap>> - glTexImage2D + [ (tex-image) ] [ (tex-sub-image) ] bi ] do-attribs ] keep ; : init-texture ( -- ) - GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ; + GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ; : with-texturing ( quot -- ) GL_TEXTURE_2D [ @@ -101,7 +82,7 @@ TUPLE: single-texture image loc dim texture-coords texture display-list disposed : texture-coords ( texture -- coords ) [ - [ dim>> ] [ image>> dim>> ] bi v/ + [ dim>> ] [ image>> dim>> [ next-power-of-2 ] map ] bi v/ { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } [ v* ] with map ] keep @@ -111,9 +92,8 @@ TUPLE: single-texture image loc dim texture-coords texture display-list disposed : make-texture-display-list ( texture -- dlist ) GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ; -: ( image loc dim -- texture ) - [ power-of-2-image ] 2dip - single-texture new swap >>dim swap >>loc swap >>image +: ( image loc -- texture ) + single-texture new swap >>loc swap [ >>image ] [ dim>> >>dim ] bi dup image>> dim>> product 0 = [ dup texture-coords >>texture-coords dup image>> make-texture >>texture @@ -124,21 +104,19 @@ M: single-texture dispose* [ texture>> [ delete-texture ] when* ] [ display-list>> [ delete-dlist ] when* ] bi ; -M: single-texture draw-texture display-list>> [ glCallList ] when* ; - M: single-texture draw-scaled-texture dup texture>> [ draw-textured-rect ] [ 2drop ] if ; TUPLE: multi-texture grid display-list loc disposed ; : image-locs ( image-grid -- loc-grid ) - [ first [ dim>> first ] map ] [ 0 [ dim>> second ] map ] bi + [ first [ dim>> first ] map ] [ [ first dim>> second ] map ] bi [ 0 [ + ] accumulate nip ] bi@ cross-zip flip ; : ( image-grid loc -- grid ) [ dup image-locs ] dip - '[ [ _ v+ over dim>> |dispose ] 2map ] 2map ; + '[ [ _ v+ |dispose ] 2map ] 2map ; : draw-textured-grid ( grid -- ) [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ; @@ -165,18 +143,13 @@ TUPLE: multi-texture grid display-list loc disposed ; f multi-texture boa ] with-destructors ; -M: multi-texture draw-texture display-list>> [ glCallList ] when* ; - M: multi-texture dispose* grid>> [ [ dispose ] each ] each ; CONSTANT: max-texture-size { 512 512 } PRIVATE> -: small-texture? ( dim -- ? ) - max-texture-size [ <= ] 2all? ; - -: ( image loc dim -- texture ) - pick dim>> small-texture? +: ( image loc -- texture ) + over dim>> max-texture-size [ <= ] 2all? [ ] - [ drop [ max-texture-size tesselate ] dip ] if ; \ No newline at end of file + [ [ max-texture-size tesselate ] dip ] if ; \ No newline at end of file diff --git a/basis/ui/images/images.factor b/basis/ui/images/images.factor index 8e36f2a3b1..2b1caa8ab9 100755 --- a/basis/ui/images/images.factor +++ b/basis/ui/images/images.factor @@ -20,7 +20,7 @@ PRIVATE> : rendered-image ( path -- texture ) world get image-texture-cache - [ cached-image [ { 0 0 } ] keep dim>> ] cache ; + [ cached-image { 0 0 } ] cache ; : draw-image ( image-name -- ) rendered-image draw-texture ; diff --git a/basis/ui/text/core-text/core-text.factor b/basis/ui/text/core-text/core-text.factor index 404624da95..0d720ac0b1 100755 --- a/basis/ui/text/core-text/core-text.factor +++ b/basis/ui/text/core-text/core-text.factor @@ -20,9 +20,7 @@ M: core-text-renderer flush-layout-cache : rendered-line ( font string -- texture ) world get world-text-handle [ - cached-line - [ image>> ] [ loc>> ] [ image>> dim>> ] tri - + cached-line [ image>> ] [ loc>> ] bi ] 2cache ; M: core-text-renderer draw-string ( font string -- ) diff --git a/basis/ui/text/pango/pango.factor b/basis/ui/text/pango/pango.factor index 46328d11d5..92c4fe5c75 100755 --- a/basis/ui/text/pango/pango.factor +++ b/basis/ui/text/pango/pango.factor @@ -16,9 +16,7 @@ M: pango-renderer flush-layout-cache : rendered-layout ( font string -- texture ) world get world-text-handle [ - cached-layout - [ image>> ] [ text-position vneg ] [ image>> dim>> ] tri - + cached-layout [ image>> ] [ text-position vneg ] bi ] 2cache ; M: pango-renderer draw-string ( font string -- ) diff --git a/basis/ui/text/uniscribe/uniscribe.factor b/basis/ui/text/uniscribe/uniscribe.factor index dcec4ab17e..d56da86b86 100755 --- a/basis/ui/text/uniscribe/uniscribe.factor +++ b/basis/ui/text/uniscribe/uniscribe.factor @@ -16,7 +16,7 @@ M: uniscribe-renderer flush-layout-cache : rendered-script-string ( font string -- texture ) world get world-text-handle - [ cached-script-string [ image>> { 0 0 } ] [ size>> ] bi ] + [ cached-script-string image>> { 0 0 } ] 2cache ; M: uniscribe-renderer draw-string ( font string -- ) diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index 53d2d9918f..7cfda41dc9 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -71,11 +71,8 @@ TUPLE: script-string font string metrics ssa size image disposed ; : draw-script-string ( dc script-string -- ) [ font>> set-dc-colors ] keep (draw-script-string) ; -: script-string-bitmap-size ( script-string -- dim ) - size>> dup small-texture? [ [ next-power-of-2 ] map ] when ; - :: make-script-string-image ( dc script-string -- image ) - script-string script-string-bitmap-size dc + script-string size>> dc [ dc script-string draw-script-string ] make-bitmap-image ; : set-dc-font ( dc font -- ) From 10404265654959fb18586d3c2d07150ed64841fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 4 Apr 2009 20:21:41 -0500 Subject: [PATCH 078/772] Fix alien hashcode for expired aliens --- core/alien/alien-tests.factor | 4 +++- core/alien/alien.factor | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index 57dc298c00..aa65a3e2d8 100644 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -1,6 +1,6 @@ USING: accessors alien alien.accessors alien.syntax byte-arrays arrays kernel kernel.private namespaces tools.test sequences libc math -system prettyprint layouts alien.libraries ; +system prettyprint layouts alien.libraries sets ; IN: alien.tests [ t ] [ -1 alien-address 0 > ] unit-test @@ -86,3 +86,5 @@ f initialize-test set-global [ ] [ initialize-test get BAD-ALIEN >>alien drop ] unit-test [ 7575 ] [ initialize-test [ 7575 ] initialize-alien ] unit-test + +[ { BAD-ALIEN } ] [ { BAD-ALIEN BAD-ALIEN BAD-ALIEN } prune ] unit-test \ No newline at end of file diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 05f5223548..ec38e3be5b 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -49,7 +49,7 @@ M: alien equal? 2drop f ] if ; -M: simple-alien hashcode* nip alien-address ; +M: simple-alien hashcode* nip dup expired>> [ drop 1234 ] [ alien-address ] if ; ERROR: alien-callback-error ; From d707292d8488f5d41f7c4a7d5cecff3aaaf19b68 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 4 Apr 2009 20:22:49 -0500 Subject: [PATCH 079/772] Fix documentation for map-index --- core/sequences/sequences-docs.factor | 2 +- core/sequences/sequences.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index c171555737..e2badc2031 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -311,7 +311,7 @@ HELP: each-index HELP: map-index { $values - { "seq" sequence } { "quot" quotation } } + { "seq" sequence } { "quot" quotation } { "newseq" sequence } } { $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack. Collects the outputs of the quotation and outputs them in a sequence of the same type as the input sequence." } { $examples { $example "USING: sequences prettyprint math ;" "{ 10 20 30 } [ + ] map-index ." diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index f352705e85..564309a6fb 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -506,7 +506,7 @@ PRIVATE> [ [ 0 = ] 2dip if ] 2curry each-index ; inline -: map-index ( seq quot -- ) +: map-index ( seq quot -- newseq ) prepare-index 2map ; inline : reduce-index ( seq identity quot -- ) From f44c67e5c307103abd550e49d2cd05f1c26bb8fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 4 Apr 2009 20:34:09 -0500 Subject: [PATCH 080/772] mason.test: check if boot image is out of date, and refuse to build if so --- extra/mason/test/test.factor | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index a15a96c63e..bc00f659fa 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -4,7 +4,7 @@ USING: accessors assocs benchmark bootstrap.stage2 compiler.errors generic help.html help.lint io.directories io.encodings.utf8 io.files kernel mason.common math namespaces prettyprint sequences sets sorting tools.test tools.time -tools.vocabs words ; +tools.vocabs words system io ; IN: mason.test : do-load ( -- ) @@ -44,9 +44,19 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; : benchmark-ms ( quot -- ms ) benchmark 1000 /i ; inline +: check-boot-image ( -- ) + "" to-refresh drop 2dup [ empty? not ] either? + [ + "Boot image is out of date. Changed vocabs:" print + append prune [ print ] each + flush + 1 exit + ] [ 2drop ] if ; + : do-all ( -- ) ".." [ bootstrap-time get boot-time-file to-file + check-boot-image [ do-load do-compile-errors ] benchmark-ms load-time-file to-file [ generate-help ] benchmark-ms html-help-time-file to-file [ do-tests ] benchmark-ms test-time-file to-file From fb6c5141ecfc0876169146a30f0630d33986fa01 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sat, 4 Apr 2009 22:38:49 -0500 Subject: [PATCH 081/772] Fixing this for Windows --- basis/opengl/textures/textures.factor | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index cdd421ddde..bb22b4351c 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -53,8 +53,8 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed : init-texture ( -- ) GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ; + GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ; : with-texturing ( quot -- ) GL_TEXTURE_2D [ @@ -82,11 +82,15 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed : texture-coords ( texture -- coords ) [ - [ dim>> ] [ image>> dim>> [ next-power-of-2 ] map ] bi v/ - { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } + [ [ dim>> ] [ image>> dim>> [ next-power-of-2 ] map ] bi v/ ] + [ + image>> upside-down?>> + { { 0 1 } { 1 1 } { 1 0 } { 0 0 } } + { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } ? + ] bi [ v* ] with map ] keep - image>> upside-down?>> [ [ first2 1 swap - 2array ] map ] when + drop ! image>> upside-down?>> [ [ first2 1 swap - 2array ] map ] when float-array{ } join ; : make-texture-display-list ( texture -- dlist ) From 52060e625396b4ce6b98cba6779044ad09813144 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sat, 4 Apr 2009 22:45:02 -0500 Subject: [PATCH 082/772] Oops dead code --- basis/opengl/textures/textures.factor | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index bb22b4351c..bb232affa4 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -81,17 +81,13 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed ] with-texturing ; : texture-coords ( texture -- coords ) + [ [ dim>> ] [ image>> dim>> [ next-power-of-2 ] map ] bi v/ ] [ - [ [ dim>> ] [ image>> dim>> [ next-power-of-2 ] map ] bi v/ ] - [ - image>> upside-down?>> - { { 0 1 } { 1 1 } { 1 0 } { 0 0 } } - { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } ? - ] bi - [ v* ] with map - ] keep - drop ! image>> upside-down?>> [ [ first2 1 swap - 2array ] map ] when - float-array{ } join ; + image>> upside-down?>> + { { 0 1 } { 1 1 } { 1 0 } { 0 0 } } + { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } ? + ] bi + [ v* ] with map float-array{ } join ; : make-texture-display-list ( texture -- dlist ) GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ; From aa7e03d0134afadef313476f354f12eb89c74de6 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 5 Apr 2009 00:04:31 -0400 Subject: [PATCH 083/772] Add poker hand evaluation vocab --- extra/poker/arrays/arrays.factor | 1261 ++++++++++++++++++++++++++++++ extra/poker/authors.txt | 1 + extra/poker/poker-tests.factor | 16 + extra/poker/poker.factor | 179 +++++ extra/poker/summary.txt | 1 + 5 files changed, 1458 insertions(+) create mode 100644 extra/poker/arrays/arrays.factor create mode 100644 extra/poker/authors.txt create mode 100644 extra/poker/poker-tests.factor create mode 100644 extra/poker/poker.factor create mode 100644 extra/poker/summary.txt diff --git a/extra/poker/arrays/arrays.factor b/extra/poker/arrays/arrays.factor new file mode 100644 index 0000000000..b415265348 --- /dev/null +++ b/extra/poker/arrays/arrays.factor @@ -0,0 +1,1261 @@ +! Copyright (c) 2009 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +IN: poker.arrays + +! This is a lookup table for all flush hands. A zero means that specific +! combination is not possible with this type of hand. +CONSTANT: flushes-table +{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 9 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 1599 0 0 0 0 0 0 0 1598 0 0 0 1597 0 1596 8 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 1595 0 0 0 0 0 0 0 1594 0 0 0 1593 0 1592 1591 0 0 0 0 0 0 0 0 1590 +0 0 0 1589 0 1588 1587 0 0 0 0 1586 0 1585 1584 0 0 1583 1582 0 7 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 1581 0 0 0 0 0 0 0 1580 0 0 0 1579 0 1578 1577 0 0 0 0 0 +0 0 0 1576 0 0 0 1575 0 1574 1573 0 0 0 0 1572 0 1571 1570 0 0 1569 1568 0 1567 +0 0 0 0 0 0 0 0 0 0 1566 0 0 0 1565 0 1564 1563 0 0 0 0 1562 0 1561 1560 0 0 +1559 1558 0 1557 0 0 0 0 0 0 1556 0 1555 1554 0 0 1553 1552 0 1551 0 0 0 0 1550 +1549 0 1548 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1547 0 0 0 0 0 +0 0 1546 0 0 0 1545 0 1544 1543 0 0 0 0 0 0 0 0 1542 0 0 0 1541 0 1540 1539 0 0 +0 0 1538 0 1537 1536 0 0 1535 1534 0 1533 0 0 0 0 0 0 0 0 0 0 1532 0 0 0 1531 0 +1530 1529 0 0 0 0 1528 0 1527 1526 0 0 1525 1524 0 1523 0 0 0 0 0 0 1522 0 1521 +1520 0 0 1519 1518 0 1517 0 0 0 0 1516 1515 0 1514 0 0 0 1513 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 1512 0 0 0 1511 0 1510 1509 0 0 0 0 1508 0 1507 1506 0 0 1505 1504 0 +1503 0 0 0 0 0 0 1502 0 1501 1500 0 0 1499 1498 0 1497 0 0 0 0 1496 1495 0 1494 +0 0 0 1493 0 0 0 0 0 0 0 0 0 0 1492 0 1491 1490 0 0 1489 1488 0 1487 0 0 0 0 +1486 1485 0 1484 0 0 0 1483 0 0 0 0 0 0 0 0 1482 1481 0 1480 0 0 0 1479 0 0 0 0 +0 0 0 5 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1478 0 0 0 +0 0 0 0 1477 0 0 0 1476 0 1475 1474 0 0 0 0 0 0 0 0 1473 0 0 0 1472 0 1471 1470 +0 0 0 0 1469 0 1468 1467 0 0 1466 1465 0 1464 0 0 0 0 0 0 0 0 0 0 1463 0 0 0 +1462 0 1461 1460 0 0 0 0 1459 0 1458 1457 0 0 1456 1455 0 1454 0 0 0 0 0 0 1453 +0 1452 1451 0 0 1450 1449 0 1448 0 0 0 0 1447 1446 0 1445 0 0 0 1444 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 1443 0 0 0 1442 0 1441 1440 0 0 0 0 1439 0 1438 1437 0 0 1436 +1435 0 1434 0 0 0 0 0 0 1433 0 1432 1431 0 0 1430 1429 0 1428 0 0 0 0 1427 1426 +0 1425 0 0 0 1424 0 0 0 0 0 0 0 0 0 0 1423 0 1422 1421 0 0 1420 1419 0 1418 0 0 +0 0 1417 1416 0 1415 0 0 0 1414 0 0 0 0 0 0 0 0 1413 1412 0 1411 0 0 0 1410 0 0 +0 0 0 0 0 1409 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1408 0 0 0 1407 0 +1406 1405 0 0 0 0 1404 0 1403 1402 0 0 1401 1400 0 1399 0 0 0 0 0 0 1398 0 1397 +1396 0 0 1395 1394 0 1393 0 0 0 0 1392 1391 0 1390 0 0 0 1389 0 0 0 0 0 0 0 0 0 +0 1388 0 1387 1386 0 0 1385 1384 0 1383 0 0 0 0 1382 1381 0 1380 0 0 0 1379 0 0 +0 0 0 0 0 0 1378 1377 0 1376 0 0 0 1375 0 0 0 0 0 0 0 1374 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 1373 0 1372 1371 0 0 1370 1369 0 1368 0 0 0 0 1367 1366 0 1365 +0 0 0 1364 0 0 0 0 0 0 0 0 1363 1362 0 1361 0 0 0 1360 0 0 0 0 0 0 0 1359 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 1358 1357 0 1356 0 0 0 1355 0 0 0 0 0 0 0 1354 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1353 0 0 0 0 0 0 0 1352 0 0 0 1351 0 1350 +1349 0 0 0 0 0 0 0 0 1348 0 0 0 1347 0 1346 1345 0 0 0 0 1344 0 1343 1342 0 0 +1341 1340 0 1339 0 0 0 0 0 0 0 0 0 0 1338 0 0 0 1337 0 1336 1335 0 0 0 0 1334 0 +1333 1332 0 0 1331 1330 0 1329 0 0 0 0 0 0 1328 0 1327 1326 0 0 1325 1324 0 +1323 0 0 0 0 1322 1321 0 1320 0 0 0 1319 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1318 0 0 0 +1317 0 1316 1315 0 0 0 0 1314 0 1313 1312 0 0 1311 1310 0 1309 0 0 0 0 0 0 1308 +0 1307 1306 0 0 1305 1304 0 1303 0 0 0 0 1302 1301 0 1300 0 0 0 1299 0 0 0 0 0 +0 0 0 0 0 1298 0 1297 1296 0 0 1295 1294 0 1293 0 0 0 0 1292 1291 0 1290 0 0 0 +1289 0 0 0 0 0 0 0 0 1288 1287 0 1286 0 0 0 1285 0 0 0 0 0 0 0 1284 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1283 0 0 0 1282 0 1281 1280 0 0 0 0 1279 0 1278 +1277 0 0 1276 1275 0 1274 0 0 0 0 0 0 1273 0 1272 1271 0 0 1270 1269 0 1268 0 0 +0 0 1267 1266 0 1265 0 0 0 1264 0 0 0 0 0 0 0 0 0 0 1263 0 1262 1261 0 0 1260 +1259 0 1258 0 0 0 0 1257 1256 0 1255 0 0 0 1254 0 0 0 0 0 0 0 0 1253 1252 0 +1251 0 0 0 1250 0 0 0 0 0 0 0 1249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1248 0 +1247 1246 0 0 1245 1244 0 1243 0 0 0 0 1242 1241 0 1240 0 0 0 1239 0 0 0 0 0 0 +0 0 1238 1237 0 1236 0 0 0 1235 0 0 0 0 0 0 0 1234 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 1233 1232 0 1231 0 0 0 1230 0 0 0 0 0 0 0 1229 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 1228 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 1227 0 0 0 1226 0 1225 1224 0 0 0 0 1223 0 1222 1221 0 0 1220 1219 0 1218 0 +0 0 0 0 0 1217 0 1216 1215 0 0 1214 1213 0 1212 0 0 0 0 1211 1210 0 1209 0 0 0 +1208 0 0 0 0 0 0 0 0 0 0 1207 0 1206 1205 0 0 1204 1203 0 1202 0 0 0 0 1201 +1200 0 1199 0 0 0 1198 0 0 0 0 0 0 0 0 1197 1196 0 1195 0 0 0 1194 0 0 0 0 0 0 +0 1193 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1192 0 1191 1190 0 0 1189 1188 0 +1187 0 0 0 0 1186 1185 0 1184 0 0 0 1183 0 0 0 0 0 0 0 0 1182 1181 0 1180 0 0 0 +1179 0 0 0 0 0 0 0 1178 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1177 1176 0 1175 0 0 0 +1174 0 0 0 0 0 0 0 1173 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1172 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1171 0 1170 1169 0 0 1168 1167 +0 1166 0 0 0 0 1165 1164 0 1163 0 0 0 1162 0 0 0 0 0 0 0 0 1161 1160 0 1159 0 0 +0 1158 0 0 0 0 0 0 0 1157 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1156 1155 0 1154 0 0 +0 1153 0 0 0 0 0 0 0 1152 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1151 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1150 1149 0 1148 0 0 0 1147 0 0 0 +0 0 0 0 1146 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1145 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 1144 0 0 0 0 0 0 0 1143 0 0 0 1142 0 1141 1140 0 0 +0 0 0 0 0 0 1139 0 0 0 1138 0 1137 1136 0 0 0 0 1135 0 1134 1133 0 0 1132 1131 +0 1130 0 0 0 0 0 0 0 0 0 0 1129 0 0 0 1128 0 1127 1126 0 0 0 0 1125 0 1124 1123 +0 0 1122 1121 0 1120 0 0 0 0 0 0 1119 0 1118 1117 0 0 1116 1115 0 1114 0 0 0 0 +1113 1112 0 1111 0 0 0 1110 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1109 0 0 0 1108 0 1107 +1106 0 0 0 0 1105 0 1104 1103 0 0 1102 1101 0 1100 0 0 0 0 0 0 1099 0 1098 1097 +0 0 1096 1095 0 1094 0 0 0 0 1093 1092 0 1091 0 0 0 1090 0 0 0 0 0 0 0 0 0 0 +1089 0 1088 1087 0 0 1086 1085 0 1084 0 0 0 0 1083 1082 0 1081 0 0 0 1080 0 0 0 +0 0 0 0 0 1079 1078 0 1077 0 0 0 1076 0 0 0 0 0 0 0 1075 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 1074 0 0 0 1073 0 1072 1071 0 0 0 0 1070 0 1069 1068 0 0 +1067 1066 0 1065 0 0 0 0 0 0 1064 0 1063 1062 0 0 1061 1060 0 1059 0 0 0 0 1058 +1057 0 1056 0 0 0 1055 0 0 0 0 0 0 0 0 0 0 1054 0 1053 1052 0 0 1051 1050 0 +1049 0 0 0 0 1048 1047 0 1046 0 0 0 1045 0 0 0 0 0 0 0 0 1044 1043 0 1042 0 0 0 +1041 0 0 0 0 0 0 0 1040 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1039 0 1038 1037 0 +0 1036 1035 0 1034 0 0 0 0 1033 1032 0 1031 0 0 0 1030 0 0 0 0 0 0 0 0 1029 +1028 0 1027 0 0 0 1026 0 0 0 0 0 0 0 1025 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1024 +1023 0 1022 0 0 0 1021 0 0 0 0 0 0 0 1020 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1019 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1018 +0 0 0 1017 0 1016 1015 0 0 0 0 1014 0 1013 1012 0 0 1011 1010 0 1009 0 0 0 0 0 +0 1008 0 1007 1006 0 0 1005 1004 0 1003 0 0 0 0 1002 1001 0 1000 0 0 0 999 0 0 +0 0 0 0 0 0 0 0 998 0 997 996 0 0 995 994 0 993 0 0 0 0 992 991 0 990 0 0 0 989 +0 0 0 0 0 0 0 0 988 987 0 986 0 0 0 985 0 0 0 0 0 0 0 984 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 983 0 982 981 0 0 980 979 0 978 0 0 0 0 977 976 0 975 0 0 0 974 0 +0 0 0 0 0 0 0 973 972 0 971 0 0 0 970 0 0 0 0 0 0 0 969 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 968 967 0 966 0 0 0 965 0 0 0 0 0 0 0 964 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +963 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 962 0 +961 960 0 0 959 958 0 957 0 0 0 0 956 955 0 954 0 0 0 953 0 0 0 0 0 0 0 0 952 +951 0 950 0 0 0 949 0 0 0 0 0 0 0 948 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 947 946 0 +945 0 0 0 944 0 0 0 0 0 0 0 943 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 942 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 941 940 0 939 0 0 0 938 0 0 0 +0 0 0 0 937 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 936 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 935 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 934 0 0 0 933 0 932 931 0 0 0 0 930 0 929 928 0 0 927 926 0 925 0 0 +0 0 0 0 924 0 923 922 0 0 921 920 0 919 0 0 0 0 918 917 0 916 0 0 0 915 0 0 0 0 +0 0 0 0 0 0 914 0 913 912 0 0 911 910 0 909 0 0 0 0 908 907 0 906 0 0 0 905 0 0 +0 0 0 0 0 0 904 903 0 902 0 0 0 901 0 0 0 0 0 0 0 900 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 899 0 898 897 0 0 896 895 0 894 0 0 0 0 893 892 0 891 0 0 0 890 0 0 0 +0 0 0 0 0 889 888 0 887 0 0 0 886 0 0 0 0 0 0 0 885 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 884 883 0 882 0 0 0 881 0 0 0 0 0 0 0 880 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 879 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 878 0 877 +876 0 0 875 874 0 873 0 0 0 0 872 871 0 870 0 0 0 869 0 0 0 0 0 0 0 0 868 867 0 +866 0 0 0 865 0 0 0 0 0 0 0 864 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 863 862 0 861 0 +0 0 860 0 0 0 0 0 0 0 859 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 858 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 857 856 0 855 0 0 0 854 0 0 0 0 0 0 +0 853 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 852 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 851 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +850 0 849 848 0 0 847 846 0 845 0 0 0 0 844 843 0 842 0 0 0 841 0 0 0 0 0 0 0 0 +840 839 0 838 0 0 0 837 0 0 0 0 0 0 0 836 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 835 +834 0 833 0 0 0 832 0 0 0 0 0 0 0 831 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 830 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 829 828 0 827 0 0 0 826 +0 0 0 0 0 0 0 825 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 824 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 823 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 822 821 0 820 0 0 0 819 0 0 0 0 0 0 0 818 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +817 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 816 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 10 0 0 0 0 0 0 0 815 0 0 0 814 0 813 812 0 0 0 0 0 0 0 0 811 0 0 0 810 0 809 +808 0 0 0 0 807 0 806 805 0 0 804 803 0 802 0 0 0 0 0 0 0 0 0 0 801 0 0 0 800 0 +799 798 0 0 0 0 797 0 796 795 0 0 794 793 0 792 0 0 0 0 0 0 791 0 790 789 0 0 +788 787 0 786 0 0 0 0 785 784 0 783 0 0 0 782 0 0 0 0 0 0 0 0 0 0 0 0 0 0 781 0 +0 0 780 0 779 778 0 0 0 0 777 0 776 775 0 0 774 773 0 772 0 0 0 0 0 0 771 0 770 +769 0 0 768 767 0 766 0 0 0 0 765 764 0 763 0 0 0 762 0 0 0 0 0 0 0 0 0 0 761 0 +760 759 0 0 758 757 0 756 0 0 0 0 755 754 0 753 0 0 0 752 0 0 0 0 0 0 0 0 751 +750 0 749 0 0 0 748 0 0 0 0 0 0 0 747 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 746 0 0 0 745 0 744 743 0 0 0 0 742 0 741 740 0 0 739 738 0 737 0 0 0 0 0 0 +736 0 735 734 0 0 733 732 0 731 0 0 0 0 730 729 0 728 0 0 0 727 0 0 0 0 0 0 0 0 +0 0 726 0 725 724 0 0 723 722 0 721 0 0 0 0 720 719 0 718 0 0 0 717 0 0 0 0 0 0 +0 0 716 715 0 714 0 0 0 713 0 0 0 0 0 0 0 712 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 711 0 710 709 0 0 708 707 0 706 0 0 0 0 705 704 0 703 0 0 0 702 0 0 0 0 0 0 0 +0 701 700 0 699 0 0 0 698 0 0 0 0 0 0 0 697 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 696 +695 0 694 0 0 0 693 0 0 0 0 0 0 0 692 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 691 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 690 0 0 0 +689 0 688 687 0 0 0 0 686 0 685 684 0 0 683 682 0 681 0 0 0 0 0 0 680 0 679 678 +0 0 677 676 0 675 0 0 0 0 674 673 0 672 0 0 0 671 0 0 0 0 0 0 0 0 0 0 670 0 669 +668 0 0 667 666 0 665 0 0 0 0 664 663 0 662 0 0 0 661 0 0 0 0 0 0 0 0 660 659 0 +658 0 0 0 657 0 0 0 0 0 0 0 656 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 655 0 654 +653 0 0 652 651 0 650 0 0 0 0 649 648 0 647 0 0 0 646 0 0 0 0 0 0 0 0 645 644 0 +643 0 0 0 642 0 0 0 0 0 0 0 641 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 640 639 0 638 0 +0 0 637 0 0 0 0 0 0 0 636 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 635 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 634 0 633 632 0 0 631 630 0 629 +0 0 0 0 628 627 0 626 0 0 0 625 0 0 0 0 0 0 0 0 624 623 0 622 0 0 0 621 0 0 0 0 +0 0 0 620 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 619 618 0 617 0 0 0 616 0 0 0 0 0 0 0 +615 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 614 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 613 612 0 611 0 0 0 610 0 0 0 0 0 0 0 609 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 608 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +607 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 606 0 0 0 605 0 +604 603 0 0 0 0 602 0 601 600 0 0 599 598 0 597 0 0 0 0 0 0 596 0 595 594 0 0 +593 592 0 591 0 0 0 0 590 589 0 588 0 0 0 587 0 0 0 0 0 0 0 0 0 0 586 0 585 584 +0 0 583 582 0 581 0 0 0 0 580 579 0 578 0 0 0 577 0 0 0 0 0 0 0 0 576 575 0 574 +0 0 0 573 0 0 0 0 0 0 0 572 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 571 0 570 569 0 +0 568 567 0 566 0 0 0 0 565 564 0 563 0 0 0 562 0 0 0 0 0 0 0 0 561 560 0 559 0 +0 0 558 0 0 0 0 0 0 0 557 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 556 555 0 554 0 0 0 +553 0 0 0 0 0 0 0 552 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 551 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 550 0 549 548 0 0 547 546 0 545 0 0 +0 0 544 543 0 542 0 0 0 541 0 0 0 0 0 0 0 0 540 539 0 538 0 0 0 537 0 0 0 0 0 0 +0 536 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 535 534 0 533 0 0 0 532 0 0 0 0 0 0 0 531 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 530 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 529 528 0 527 0 0 0 526 0 0 0 0 0 0 0 525 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 524 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 523 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 522 0 521 520 0 0 519 518 0 +517 0 0 0 0 516 515 0 514 0 0 0 513 0 0 0 0 0 0 0 0 512 511 0 510 0 0 0 509 0 0 +0 0 0 0 0 508 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 507 506 0 505 0 0 0 504 0 0 0 0 0 +0 0 503 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 502 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 501 500 0 499 0 0 0 498 0 0 0 0 0 0 0 497 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 496 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 495 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 494 493 0 492 0 0 0 491 +0 0 0 0 0 0 0 490 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 489 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 488 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 487 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 486 0 0 0 485 0 484 483 0 0 0 0 482 0 481 +480 0 0 479 478 0 477 0 0 0 0 0 0 476 0 475 474 0 0 473 472 0 471 0 0 0 0 470 +469 0 468 0 0 0 467 0 0 0 0 0 0 0 0 0 0 466 0 465 464 0 0 463 462 0 461 0 0 0 0 +460 459 0 458 0 0 0 457 0 0 0 0 0 0 0 0 456 455 0 454 0 0 0 453 0 0 0 0 0 0 0 +452 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 451 0 450 449 0 0 448 447 0 446 0 0 0 0 +445 444 0 443 0 0 0 442 0 0 0 0 0 0 0 0 441 440 0 439 0 0 0 438 0 0 0 0 0 0 0 +437 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 436 435 0 434 0 0 0 433 0 0 0 0 0 0 0 432 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 431 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 430 0 429 428 0 0 427 426 0 425 0 0 0 0 424 423 0 422 0 0 0 +421 0 0 0 0 0 0 0 0 420 419 0 418 0 0 0 417 0 0 0 0 0 0 0 416 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 415 414 0 413 0 0 0 412 0 0 0 0 0 0 0 411 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 410 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 409 +408 0 407 0 0 0 406 0 0 0 0 0 0 0 405 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 404 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 403 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 402 0 401 400 0 0 399 398 0 397 0 0 0 0 396 395 0 +394 0 0 0 393 0 0 0 0 0 0 0 0 392 391 0 390 0 0 0 389 0 0 0 0 0 0 0 388 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 387 386 0 385 0 0 0 384 0 0 0 0 0 0 0 383 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 382 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 381 380 0 379 0 0 0 378 0 0 0 0 0 0 0 377 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 376 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 375 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 374 373 0 372 0 0 0 371 0 0 0 0 0 0 0 370 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 369 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 368 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 367 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 366 0 365 364 0 0 363 362 0 361 0 0 0 0 360 359 0 358 0 0 0 357 0 0 0 0 0 +0 0 0 356 355 0 354 0 0 0 353 0 0 0 0 0 0 0 352 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +351 350 0 349 0 0 0 348 0 0 0 0 0 0 0 347 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 346 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 345 344 0 343 0 0 0 +342 0 0 0 0 0 0 0 341 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 340 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 339 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 338 337 0 336 0 0 0 335 0 0 0 0 0 0 0 334 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 333 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 332 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 331 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 330 329 0 328 0 0 0 +327 0 0 0 0 0 0 0 326 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 325 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 324 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 323 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 1 } + +! This is a lookup table for all non-flush hands consisting of five unique +! ranks (i.e. either Straights or High Card hands). A zero means that specific +! combination is not possible with this type of hand. +CONSTANT: unique5-table +{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1608 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 7462 0 0 0 0 0 0 0 7461 0 0 0 7460 0 7459 1607 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 7458 0 0 0 0 0 0 0 7457 0 0 0 7456 0 7455 7454 0 0 0 0 0 0 +0 0 7453 0 0 0 7452 0 7451 7450 0 0 0 0 7449 0 7448 7447 0 0 7446 7445 0 1606 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7444 0 0 0 0 0 0 0 7443 0 0 0 7442 0 7441 +7440 0 0 0 0 0 0 0 0 7439 0 0 0 7438 0 7437 7436 0 0 0 0 7435 0 7434 7433 0 0 +7432 7431 0 7430 0 0 0 0 0 0 0 0 0 0 7429 0 0 0 7428 0 7427 7426 0 0 0 0 7425 0 +7424 7423 0 0 7422 7421 0 7420 0 0 0 0 0 0 7419 0 7418 7417 0 0 7416 7415 0 +7414 0 0 0 0 7413 7412 0 7411 0 0 0 1605 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 7410 0 0 0 0 0 0 0 7409 0 0 0 7408 0 7407 7406 0 0 0 0 0 0 0 0 7405 0 0 0 +7404 0 7403 7402 0 0 0 0 7401 0 7400 7399 0 0 7398 7397 0 7396 0 0 0 0 0 0 0 0 +0 0 7395 0 0 0 7394 0 7393 7392 0 0 0 0 7391 0 7390 7389 0 0 7388 7387 0 7386 0 +0 0 0 0 0 7385 0 7384 7383 0 0 7382 7381 0 7380 0 0 0 0 7379 7378 0 7377 0 0 0 +7376 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7375 0 0 0 7374 0 7373 7372 0 0 0 0 7371 0 +7370 7369 0 0 7368 7367 0 7366 0 0 0 0 0 0 7365 0 7364 7363 0 0 7362 7361 0 +7360 0 0 0 0 7359 7358 0 7357 0 0 0 7356 0 0 0 0 0 0 0 0 0 0 7355 0 7354 7353 0 +0 7352 7351 0 7350 0 0 0 0 7349 7348 0 7347 0 0 0 7346 0 0 0 0 0 0 0 0 7345 +7344 0 7343 0 0 0 7342 0 0 0 0 0 0 0 1604 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 7341 0 0 0 0 0 0 0 7340 0 0 0 7339 0 7338 7337 0 0 0 0 0 +0 0 0 7336 0 0 0 7335 0 7334 7333 0 0 0 0 7332 0 7331 7330 0 0 7329 7328 0 7327 +0 0 0 0 0 0 0 0 0 0 7326 0 0 0 7325 0 7324 7323 0 0 0 0 7322 0 7321 7320 0 0 +7319 7318 0 7317 0 0 0 0 0 0 7316 0 7315 7314 0 0 7313 7312 0 7311 0 0 0 0 7310 +7309 0 7308 0 0 0 7307 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7306 0 0 0 7305 0 7304 7303 +0 0 0 0 7302 0 7301 7300 0 0 7299 7298 0 7297 0 0 0 0 0 0 7296 0 7295 7294 0 0 +7293 7292 0 7291 0 0 0 0 7290 7289 0 7288 0 0 0 7287 0 0 0 0 0 0 0 0 0 0 7286 0 +7285 7284 0 0 7283 7282 0 7281 0 0 0 0 7280 7279 0 7278 0 0 0 7277 0 0 0 0 0 0 +0 0 7276 7275 0 7274 0 0 0 7273 0 0 0 0 0 0 0 7272 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 7271 0 0 0 7270 0 7269 7268 0 0 0 0 7267 0 7266 7265 0 0 7264 +7263 0 7262 0 0 0 0 0 0 7261 0 7260 7259 0 0 7258 7257 0 7256 0 0 0 0 7255 7254 +0 7253 0 0 0 7252 0 0 0 0 0 0 0 0 0 0 7251 0 7250 7249 0 0 7248 7247 0 7246 0 0 +0 0 7245 7244 0 7243 0 0 0 7242 0 0 0 0 0 0 0 0 7241 7240 0 7239 0 0 0 7238 0 0 +0 0 0 0 0 7237 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7236 0 7235 7234 0 0 7233 +7232 0 7231 0 0 0 0 7230 7229 0 7228 0 0 0 7227 0 0 0 0 0 0 0 0 7226 7225 0 +7224 0 0 0 7223 0 0 0 0 0 0 0 7222 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7221 7220 0 +7219 0 0 0 7218 0 0 0 0 0 0 0 7217 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1603 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 7216 0 0 0 0 0 0 0 7215 0 0 0 7214 0 7213 7212 0 0 0 0 0 0 0 0 7211 0 0 0 +7210 0 7209 7208 0 0 0 0 7207 0 7206 7205 0 0 7204 7203 0 7202 0 0 0 0 0 0 0 0 +0 0 7201 0 0 0 7200 0 7199 7198 0 0 0 0 7197 0 7196 7195 0 0 7194 7193 0 7192 0 +0 0 0 0 0 7191 0 7190 7189 0 0 7188 7187 0 7186 0 0 0 0 7185 7184 0 7183 0 0 0 +7182 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7181 0 0 0 7180 0 7179 7178 0 0 0 0 7177 0 +7176 7175 0 0 7174 7173 0 7172 0 0 0 0 0 0 7171 0 7170 7169 0 0 7168 7167 0 +7166 0 0 0 0 7165 7164 0 7163 0 0 0 7162 0 0 0 0 0 0 0 0 0 0 7161 0 7160 7159 0 +0 7158 7157 0 7156 0 0 0 0 7155 7154 0 7153 0 0 0 7152 0 0 0 0 0 0 0 0 7151 +7150 0 7149 0 0 0 7148 0 0 0 0 0 0 0 7147 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 7146 0 0 0 7145 0 7144 7143 0 0 0 0 7142 0 7141 7140 0 0 7139 7138 0 7137 +0 0 0 0 0 0 7136 0 7135 7134 0 0 7133 7132 0 7131 0 0 0 0 7130 7129 0 7128 0 0 +0 7127 0 0 0 0 0 0 0 0 0 0 7126 0 7125 7124 0 0 7123 7122 0 7121 0 0 0 0 7120 +7119 0 7118 0 0 0 7117 0 0 0 0 0 0 0 0 7116 7115 0 7114 0 0 0 7113 0 0 0 0 0 0 +0 7112 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7111 0 7110 7109 0 0 7108 7107 0 +7106 0 0 0 0 7105 7104 0 7103 0 0 0 7102 0 0 0 0 0 0 0 0 7101 7100 0 7099 0 0 0 +7098 0 0 0 0 0 0 0 7097 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7096 7095 0 7094 0 0 0 +7093 0 0 0 0 0 0 0 7092 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7091 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7090 0 0 0 7089 0 7088 +7087 0 0 0 0 7086 0 7085 7084 0 0 7083 7082 0 7081 0 0 0 0 0 0 7080 0 7079 7078 +0 0 7077 7076 0 7075 0 0 0 0 7074 7073 0 7072 0 0 0 7071 0 0 0 0 0 0 0 0 0 0 +7070 0 7069 7068 0 0 7067 7066 0 7065 0 0 0 0 7064 7063 0 7062 0 0 0 7061 0 0 0 +0 0 0 0 0 7060 7059 0 7058 0 0 0 7057 0 0 0 0 0 0 0 7056 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 7055 0 7054 7053 0 0 7052 7051 0 7050 0 0 0 0 7049 7048 0 7047 0 +0 0 7046 0 0 0 0 0 0 0 0 7045 7044 0 7043 0 0 0 7042 0 0 0 0 0 0 0 7041 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 7040 7039 0 7038 0 0 0 7037 0 0 0 0 0 0 0 7036 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 7035 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 7034 0 7033 7032 0 0 7031 7030 0 7029 0 0 0 0 7028 7027 0 7026 +0 0 0 7025 0 0 0 0 0 0 0 0 7024 7023 0 7022 0 0 0 7021 0 0 0 0 0 0 0 7020 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 7019 7018 0 7017 0 0 0 7016 0 0 0 0 0 0 0 7015 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 7014 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 7013 7012 0 7011 0 0 0 7010 0 0 0 0 0 0 0 7009 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 7008 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +1602 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 7007 0 0 0 0 0 0 0 7006 0 0 0 7005 0 7004 7003 0 0 0 0 0 0 0 0 7002 0 0 0 +7001 0 7000 6999 0 0 0 0 6998 0 6997 6996 0 0 6995 6994 0 6993 0 0 0 0 0 0 0 0 +0 0 6992 0 0 0 6991 0 6990 6989 0 0 0 0 6988 0 6987 6986 0 0 6985 6984 0 6983 0 +0 0 0 0 0 6982 0 6981 6980 0 0 6979 6978 0 6977 0 0 0 0 6976 6975 0 6974 0 0 0 +6973 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6972 0 0 0 6971 0 6970 6969 0 0 0 0 6968 0 +6967 6966 0 0 6965 6964 0 6963 0 0 0 0 0 0 6962 0 6961 6960 0 0 6959 6958 0 +6957 0 0 0 0 6956 6955 0 6954 0 0 0 6953 0 0 0 0 0 0 0 0 0 0 6952 0 6951 6950 0 +0 6949 6948 0 6947 0 0 0 0 6946 6945 0 6944 0 0 0 6943 0 0 0 0 0 0 0 0 6942 +6941 0 6940 0 0 0 6939 0 0 0 0 0 0 0 6938 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 6937 0 0 0 6936 0 6935 6934 0 0 0 0 6933 0 6932 6931 0 0 6930 6929 0 6928 +0 0 0 0 0 0 6927 0 6926 6925 0 0 6924 6923 0 6922 0 0 0 0 6921 6920 0 6919 0 0 +0 6918 0 0 0 0 0 0 0 0 0 0 6917 0 6916 6915 0 0 6914 6913 0 6912 0 0 0 0 6911 +6910 0 6909 0 0 0 6908 0 0 0 0 0 0 0 0 6907 6906 0 6905 0 0 0 6904 0 0 0 0 0 0 +0 6903 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6902 0 6901 6900 0 0 6899 6898 0 +6897 0 0 0 0 6896 6895 0 6894 0 0 0 6893 0 0 0 0 0 0 0 0 6892 6891 0 6890 0 0 0 +6889 0 0 0 0 0 0 0 6888 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6887 6886 0 6885 0 0 0 +6884 0 0 0 0 0 0 0 6883 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6882 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6881 0 0 0 6880 0 6879 +6878 0 0 0 0 6877 0 6876 6875 0 0 6874 6873 0 6872 0 0 0 0 0 0 6871 0 6870 6869 +0 0 6868 6867 0 6866 0 0 0 0 6865 6864 0 6863 0 0 0 6862 0 0 0 0 0 0 0 0 0 0 +6861 0 6860 6859 0 0 6858 6857 0 6856 0 0 0 0 6855 6854 0 6853 0 0 0 6852 0 0 0 +0 0 0 0 0 6851 6850 0 6849 0 0 0 6848 0 0 0 0 0 0 0 6847 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 6846 0 6845 6844 0 0 6843 6842 0 6841 0 0 0 0 6840 6839 0 6838 0 +0 0 6837 0 0 0 0 0 0 0 0 6836 6835 0 6834 0 0 0 6833 0 0 0 0 0 0 0 6832 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 6831 6830 0 6829 0 0 0 6828 0 0 0 0 0 0 0 6827 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 6826 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 6825 0 6824 6823 0 0 6822 6821 0 6820 0 0 0 0 6819 6818 0 6817 +0 0 0 6816 0 0 0 0 0 0 0 0 6815 6814 0 6813 0 0 0 6812 0 0 0 0 0 0 0 6811 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 6810 6809 0 6808 0 0 0 6807 0 0 0 0 0 0 0 6806 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 6805 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 6804 6803 0 6802 0 0 0 6801 0 0 0 0 0 0 0 6800 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 6799 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +6798 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6797 0 0 0 +6796 0 6795 6794 0 0 0 0 6793 0 6792 6791 0 0 6790 6789 0 6788 0 0 0 0 0 0 6787 +0 6786 6785 0 0 6784 6783 0 6782 0 0 0 0 6781 6780 0 6779 0 0 0 6778 0 0 0 0 0 +0 0 0 0 0 6777 0 6776 6775 0 0 6774 6773 0 6772 0 0 0 0 6771 6770 0 6769 0 0 0 +6768 0 0 0 0 0 0 0 0 6767 6766 0 6765 0 0 0 6764 0 0 0 0 0 0 0 6763 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 6762 0 6761 6760 0 0 6759 6758 0 6757 0 0 0 0 6756 6755 +0 6754 0 0 0 6753 0 0 0 0 0 0 0 0 6752 6751 0 6750 0 0 0 6749 0 0 0 0 0 0 0 +6748 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6747 6746 0 6745 0 0 0 6744 0 0 0 0 0 0 0 +6743 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6742 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 6741 0 6740 6739 0 0 6738 6737 0 6736 0 0 0 0 6735 +6734 0 6733 0 0 0 6732 0 0 0 0 0 0 0 0 6731 6730 0 6729 0 0 0 6728 0 0 0 0 0 0 +0 6727 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6726 6725 0 6724 0 0 0 6723 0 0 0 0 0 0 +0 6722 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6721 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 6720 6719 0 6718 0 0 0 6717 0 0 0 0 0 0 0 6716 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 6715 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 6714 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6713 0 +6712 6711 0 0 6710 6709 0 6708 0 0 0 0 6707 6706 0 6705 0 0 0 6704 0 0 0 0 0 0 +0 0 6703 6702 0 6701 0 0 0 6700 0 0 0 0 0 0 0 6699 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 6698 6697 0 6696 0 0 0 6695 0 0 0 0 0 0 0 6694 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 6693 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6692 +6691 0 6690 0 0 0 6689 0 0 0 0 0 0 0 6688 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6687 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6686 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6685 6684 0 6683 0 0 0 6682 0 0 0 0 0 0 0 +6681 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6680 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 6679 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1601 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1609 0 0 0 0 0 0 0 6678 0 0 0 6677 +0 6676 6675 0 0 0 0 0 0 0 0 6674 0 0 0 6673 0 6672 6671 0 0 0 0 6670 0 6669 +6668 0 0 6667 6666 0 6665 0 0 0 0 0 0 0 0 0 0 6664 0 0 0 6663 0 6662 6661 0 0 0 +0 6660 0 6659 6658 0 0 6657 6656 0 6655 0 0 0 0 0 0 6654 0 6653 6652 0 0 6651 +6650 0 6649 0 0 0 0 6648 6647 0 6646 0 0 0 6645 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +6644 0 0 0 6643 0 6642 6641 0 0 0 0 6640 0 6639 6638 0 0 6637 6636 0 6635 0 0 0 +0 0 0 6634 0 6633 6632 0 0 6631 6630 0 6629 0 0 0 0 6628 6627 0 6626 0 0 0 6625 +0 0 0 0 0 0 0 0 0 0 6624 0 6623 6622 0 0 6621 6620 0 6619 0 0 0 0 6618 6617 0 +6616 0 0 0 6615 0 0 0 0 0 0 0 0 6614 6613 0 6612 0 0 0 6611 0 0 0 0 0 0 0 6610 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6609 0 0 0 6608 0 6607 6606 0 0 0 0 +6605 0 6604 6603 0 0 6602 6601 0 6600 0 0 0 0 0 0 6599 0 6598 6597 0 0 6596 +6595 0 6594 0 0 0 0 6593 6592 0 6591 0 0 0 6590 0 0 0 0 0 0 0 0 0 0 6589 0 6588 +6587 0 0 6586 6585 0 6584 0 0 0 0 6583 6582 0 6581 0 0 0 6580 0 0 0 0 0 0 0 0 +6579 6578 0 6577 0 0 0 6576 0 0 0 0 0 0 0 6575 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 6574 0 6573 6572 0 0 6571 6570 0 6569 0 0 0 0 6568 6567 0 6566 0 0 0 6565 0 +0 0 0 0 0 0 0 6564 6563 0 6562 0 0 0 6561 0 0 0 0 0 0 0 6560 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 6559 6558 0 6557 0 0 0 6556 0 0 0 0 0 0 0 6555 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 6554 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 6553 0 0 0 6552 0 6551 6550 0 0 0 0 6549 0 6548 6547 0 0 6546 +6545 0 6544 0 0 0 0 0 0 6543 0 6542 6541 0 0 6540 6539 0 6538 0 0 0 0 6537 6536 +0 6535 0 0 0 6534 0 0 0 0 0 0 0 0 0 0 6533 0 6532 6531 0 0 6530 6529 0 6528 0 0 +0 0 6527 6526 0 6525 0 0 0 6524 0 0 0 0 0 0 0 0 6523 6522 0 6521 0 0 0 6520 0 0 +0 0 0 0 0 6519 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6518 0 6517 6516 0 0 6515 +6514 0 6513 0 0 0 0 6512 6511 0 6510 0 0 0 6509 0 0 0 0 0 0 0 0 6508 6507 0 +6506 0 0 0 6505 0 0 0 0 0 0 0 6504 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6503 6502 0 +6501 0 0 0 6500 0 0 0 0 0 0 0 6499 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6498 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6497 0 6496 6495 0 0 +6494 6493 0 6492 0 0 0 0 6491 6490 0 6489 0 0 0 6488 0 0 0 0 0 0 0 0 6487 6486 +0 6485 0 0 0 6484 0 0 0 0 0 0 0 6483 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6482 6481 +0 6480 0 0 0 6479 0 0 0 0 0 0 0 6478 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6477 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6476 6475 0 6474 0 0 0 +6473 0 0 0 0 0 0 0 6472 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6471 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6470 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 6469 0 0 0 6468 0 6467 6466 0 0 0 0 6465 0 6464 +6463 0 0 6462 6461 0 6460 0 0 0 0 0 0 6459 0 6458 6457 0 0 6456 6455 0 6454 0 0 +0 0 6453 6452 0 6451 0 0 0 6450 0 0 0 0 0 0 0 0 0 0 6449 0 6448 6447 0 0 6446 +6445 0 6444 0 0 0 0 6443 6442 0 6441 0 0 0 6440 0 0 0 0 0 0 0 0 6439 6438 0 +6437 0 0 0 6436 0 0 0 0 0 0 0 6435 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6434 0 +6433 6432 0 0 6431 6430 0 6429 0 0 0 0 6428 6427 0 6426 0 0 0 6425 0 0 0 0 0 0 +0 0 6424 6423 0 6422 0 0 0 6421 0 0 0 0 0 0 0 6420 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 6419 6418 0 6417 0 0 0 6416 0 0 0 0 0 0 0 6415 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 6414 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6413 +0 6412 6411 0 0 6410 6409 0 6408 0 0 0 0 6407 6406 0 6405 0 0 0 6404 0 0 0 0 0 +0 0 0 6403 6402 0 6401 0 0 0 6400 0 0 0 0 0 0 0 6399 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 6398 6397 0 6396 0 0 0 6395 0 0 0 0 0 0 0 6394 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 6393 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6392 +6391 0 6390 0 0 0 6389 0 0 0 0 0 0 0 6388 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6387 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6386 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6385 0 6384 6383 0 0 6382 6381 0 6380 0 0 +0 0 6379 6378 0 6377 0 0 0 6376 0 0 0 0 0 0 0 0 6375 6374 0 6373 0 0 0 6372 0 0 +0 0 0 0 0 6371 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6370 6369 0 6368 0 0 0 6367 0 0 +0 0 0 0 0 6366 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6365 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6364 6363 0 6362 0 0 0 6361 0 0 0 0 0 0 0 +6360 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6359 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 6358 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +6357 6356 0 6355 0 0 0 6354 0 0 0 0 0 0 0 6353 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +6352 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6351 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6350 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6349 0 +0 0 6348 0 6347 6346 0 0 0 0 6345 0 6344 6343 0 0 6342 6341 0 6340 0 0 0 0 0 0 +6339 0 6338 6337 0 0 6336 6335 0 6334 0 0 0 0 6333 6332 0 6331 0 0 0 6330 0 0 0 +0 0 0 0 0 0 0 6329 0 6328 6327 0 0 6326 6325 0 6324 0 0 0 0 6323 6322 0 6321 0 +0 0 6320 0 0 0 0 0 0 0 0 6319 6318 0 6317 0 0 0 6316 0 0 0 0 0 0 0 6315 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 6314 0 6313 6312 0 0 6311 6310 0 6309 0 0 0 0 6308 +6307 0 6306 0 0 0 6305 0 0 0 0 0 0 0 0 6304 6303 0 6302 0 0 0 6301 0 0 0 0 0 0 +0 6300 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6299 6298 0 6297 0 0 0 6296 0 0 0 0 0 0 +0 6295 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6294 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6293 0 6292 6291 0 0 6290 6289 0 6288 0 0 0 0 +6287 6286 0 6285 0 0 0 6284 0 0 0 0 0 0 0 0 6283 6282 0 6281 0 0 0 6280 0 0 0 0 +0 0 0 6279 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6278 6277 0 6276 0 0 0 6275 0 0 0 0 +0 0 0 6274 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6273 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6272 6271 0 6270 0 0 0 6269 0 0 0 0 0 0 0 6268 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 6267 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 6266 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6265 +0 6264 6263 0 0 6262 6261 0 6260 0 0 0 0 6259 6258 0 6257 0 0 0 6256 0 0 0 0 0 +0 0 0 6255 6254 0 6253 0 0 0 6252 0 0 0 0 0 0 0 6251 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 6250 6249 0 6248 0 0 0 6247 0 0 0 0 0 0 0 6246 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 6245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6244 +6243 0 6242 0 0 0 6241 0 0 0 0 0 0 0 6240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6239 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6238 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6237 6236 0 6235 0 0 0 6234 0 0 0 0 0 0 0 +6233 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 6231 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6230 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 6229 0 6228 6227 0 0 6226 6225 0 6224 0 0 0 0 6223 6222 0 +6221 0 0 0 6220 0 0 0 0 0 0 0 0 6219 6218 0 6217 0 0 0 6216 0 0 0 0 0 0 0 6215 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6214 6213 0 6212 0 0 0 6211 0 0 0 0 0 0 0 6210 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6209 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 6208 6207 0 6206 0 0 0 6205 0 0 0 0 0 0 0 6204 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 6203 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 6202 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6201 6200 0 6199 0 +0 0 6198 0 0 0 0 0 0 0 6197 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6196 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6195 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 6194 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6193 6192 0 6191 0 0 0 6190 0 0 0 0 0 0 +0 6189 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6188 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 6187 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +6186 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +0 0 0 0 0 0 0 0 0 0 1600 } + +! This is a lookup table for the product of prime values associated with the +! cards in a hand. +CONSTANT: products-table +{ 48 72 80 108 112 120 162 168 176 180 200 208 252 264 270 272 280 300 304 312 +368 378 392 396 405 408 420 440 450 456 464 468 496 500 520 552 567 588 592 594 +612 616 630 656 660 675 680 684 696 700 702 728 744 750 760 780 828 882 888 891 +918 920 924 945 952 968 980 984 990 1020 1026 1044 1050 1053 1064 1092 1100 +1116 1125 1140 1144 1160 1170 1240 1242 1250 1288 1300 1323 1332 1352 1372 1377 +1380 1386 1428 1452 1470 1476 1480 1485 1496 1530 1539 1540 1566 1575 1596 1624 +1638 1640 1650 1672 1674 1700 1710 1716 1736 1740 1750 1755 1768 1820 1860 1863 +1875 1900 1932 1950 1976 1998 2024 2028 2058 2070 2072 2079 2142 2156 2178 2205 +2214 2220 2244 2295 2296 2300 2312 2349 2380 2392 2394 2420 2436 2450 2457 2460 +2475 2508 2511 2548 2550 2552 2565 2574 2584 2604 2610 2625 2652 2660 2728 2750 +2790 2850 2860 2888 2898 2900 2925 2964 2997 3016 3036 3042 3087 3100 3105 3108 +3128 3213 3220 3224 3234 3250 3256 3267 3321 3330 3332 3366 3380 3388 3430 3444 +3450 3465 3468 3496 3588 3591 3608 3630 3654 3675 3690 3700 3724 3740 3762 3822 +3825 3828 3848 3850 3861 3876 3906 3915 3944 3978 4004 4060 4092 4095 4100 4125 +4180 4185 4216 4232 4250 4264 4275 4332 4340 4347 4350 4375 4408 4420 4446 4508 +4524 4550 4554 4563 4650 4662 4692 4712 4732 4750 4802 4836 4851 4875 4884 4940 +4995 4998 5032 5049 5060 5070 5082 5145 5166 5175 5180 5202 5236 5244 5324 5336 +5355 5382 5390 5412 5445 5481 5535 5550 5576 5586 5624 5643 5684 5704 5733 5740 +5742 5750 5772 5775 5780 5814 5852 5859 5916 5950 5967 5980 5985 6050 6076 6125 +6138 6150 6188 6232 6292 6324 6348 6370 6375 6380 6396 6435 6460 6498 6525 6612 +6650 6669 6728 6762 6786 6808 6820 6825 6831 6875 6916 6975 6993 7038 7068 7084 +7098 7125 7150 7192 7203 7220 7245 7250 7252 7254 7326 7436 7497 7540 7544 7546 +7548 7605 7623 7688 7749 7750 7803 7820 7866 7986 8004 8036 8050 8060 8073 8085 +8092 8118 8125 8140 8228 8325 8330 8364 8372 8379 8415 8436 8450 8470 8526 8556 +8575 8584 8613 8625 8658 8670 8721 8740 8788 8874 8918 8925 8932 9009 9020 9044 +9075 9114 9135 9176 9196 9207 9225 9250 9310 9348 9350 9405 9438 9486 9512 9522 +9548 9555 9594 9620 9625 9724 9747 9765 9860 9918 9945 9975 10092 10108 10143 +10150 10168 10179 10212 10250 10450 10540 10556 10557 10580 10602 10625 10647 +10660 10725 10788 10830 10850 10868 10875 10878 10881 10948 10952 10989 11020 +11050 11115 11132 11154 11270 11284 11316 11319 11322 11375 11385 11396 11492 +11532 11625 11655 11662 11780 11781 11799 11830 11858 11875 11979 12005 12006 +12054 12075 12136 12138 12177 12236 12342 12350 12495 12546 12580 12628 12650 +12654 12675 12705 12716 12789 12834 12844 12876 12915 12950 12987 13005 13034 +13156 13167 13182 13310 13311 13340 13377 13448 13455 13468 13475 13671 13764 +13794 13804 13875 13923 13940 13965 14014 14022 14025 14036 14060 14157 14210 +14212 14229 14260 14268 14283 14350 14355 14375 14391 14450 14535 14756 14812 +14875 14877 14924 14950 15004 15028 15125 15138 15162 15190 15225 15252 15318 +15345 15375 15428 15548 15561 15580 15675 15730 15778 15870 15884 15903 15925 +15939 15950 16150 16182 16245 16275 16317 16428 16492 16562 16575 16588 16625 +16698 16731 16796 16820 16905 16965 16974 16983 17020 17050 17204 17238 17298 +17493 17595 17612 17732 17745 17787 17875 17908 17980 18009 18050 18081 18125 +18130 18135 18204 18207 18315 18326 18513 18525 18590 18634 18676 18772 18819 +18837 18850 18860 18865 18975 18981 19074 19220 19228 19251 19266 19314 19375 +19425 19516 19550 19551 19604 19652 19665 19684 19773 19844 19894 19964 19965 +20090 20097 20125 20150 20172 20230 20295 20332 20349 20350 20482 20570 20646 +20691 20825 20956 21021 21033 21054 21125 21164 21175 21266 21315 21402 21460 +21483 21525 21645 21658 21675 21692 21812 21850 21879 21964 21970 22022 22185 +22218 22295 22425 22506 22542 22550 22707 22724 22743 22785 22878 22940 22977 +22990 23125 23188 23275 23276 23322 23375 23452 23548 23595 23667 23715 23751 +23780 23805 23826 23828 23925 23985 24050 24206 24225 24244 24273 24453 24548 +24633 24642 24650 24794 24795 24843 25012 25025 25047 25172 25230 25270 25375 +25382 25389 25420 25461 25575 25625 25636 25641 25857 25916 25947 26026 26125 +26350 26404 26411 26450 26505 26588 26650 26862 26908 27075 27125 27195 27306 +27380 27404 27436 27489 27508 27531 27550 27625 27676 27716 27830 27885 27951 +28126 28158 28175 28275 28305 28322 28413 28611 28652 28730 28798 28830 28899 +28971 29155 29282 29302 29325 29348 29406 29450 29478 29575 29601 29645 29716 +29766 29841 30015 30044 30135 30225 30258 30303 30340 30345 30525 30628 30668 +30723 30758 30855 30875 30932 30969 31059 31213 31262 31365 31372 31434 31450 +31581 31625 31635 31654 31790 31899 31977 32085 32103 32110 32116 32186 32375 +32487 32585 32708 32725 32775 32946 32955 33033 33201 33212 33275 33292 33327 +33350 33418 33524 33579 33620 33759 33813 33825 34276 34317 34485 34606 34684 +34713 34850 34914 34983 35035 35055 35090 35150 35322 35378 35525 35588 35650 +35739 35836 35875 35972 36075 36125 36244 36309 36556 36575 36822 36946 36963 +36975 37004 37030 37076 37107 37191 37323 37375 37444 37468 37510 37518 37570 +37791 37845 37905 37975 38073 38295 38318 38332 38675 38709 38870 38950 38962 +39039 39325 39445 39494 39525 39556 39627 39675 39710 39875 39882 39886 39897 +39975 40052 40204 40222 40293 40362 40375 40455 40508 40817 40898 40959 41070 +41154 41262 41325 41405 41492 41503 41574 41745 41876 42021 42050 42189 42237 +42284 42435 42476 42483 42550 42625 42772 42826 43095 43197 43225 43245 43263 +43732 43911 43923 43953 44109 44175 44198 44217 44252 44275 44289 44506 44649 +44764 44770 44919 44950 44954 45125 45254 45325 45356 45387 45619 45747 45815 +46137 46475 46585 46748 46893 46930 47068 47125 47138 47150 47151 47175 47212 +47396 47481 47619 47685 47804 48050 48165 48279 48285 48314 48334 48484 48668 +48807 48875 49010 49036 49049 49077 49126 49130 49419 49610 49735 49818 49972 +50025 50127 50225 50286 50375 50430 50468 50575 50578 50692 50875 51129 51205 +51425 51615 51646 51842 51909 52173 52234 52275 52316 52325 52371 52390 52514 +52598 52635 52725 52767 52972 52983 53067 53165 53428 53475 53482 53505 53613 +53650 53754 53958 53998 54145 54188 54418 54549 54625 54910 54925 55055 55223 +55233 55419 55506 55545 55594 55796 55825 55924 56265 56277 56355 56375 56525 +56637 57122 57188 57195 57350 57475 57477 57498 57681 57722 57868 57967 58190 +58305 58311 58425 58443 58870 59204 59241 59409 59450 59565 59644 59675 59774 +59823 59829 60125 60236 60306 60333 60515 60543 60775 61132 61226 61347 61364 +61370 61605 61625 61642 61659 61731 61828 61893 61985 62271 62361 62530 62678 +62814 63075 63175 63206 63426 63455 63550 63825 63916 64124 64141 64158 64239 +64467 64676 65065 65219 65348 65366 65596 65598 65702 65875 65975 66033 66092 +66125 66297 66470 66625 66748 66759 66861 67146 67155 67270 67425 67431 67599 +67881 67925 68265 68306 68324 68425 68450 68590 68614 68770 68782 68875 68894 +68913 69003 69290 69454 69575 69597 69629 69874 69938 70315 70395 70525 70587 +70602 70642 70707 70725 70805 71094 71188 71225 71668 71687 71825 71995 72075 +72261 72358 72471 72501 72964 73002 73036 73205 73255 73346 73515 73593 73625 +73689 73695 73964 74415 74431 74698 74727 74907 74958 75429 75645 75803 75850 +75867 76342 76475 76874 76895 77077 77121 77198 77372 77469 77763 77996 78039 +78155 78166 78292 78351 78585 78625 78771 78884 78897 78925 79135 79475 80073 +80142 80223 80275 80465 80475 80631 80852 80937 80997 81466 81548 81549 81627 +82225 82251 82365 82418 82522 82654 82708 83030 83259 83375 83391 83398 83421 +83486 83545 83810 84050 84175 84249 84303 84721 85514 85683 85782 85918 86025 +86247 86275 86428 86515 86583 86756 86779 87125 87172 87285 87362 87412 87542 +87725 87875 88102 88305 88412 88445 88806 88825 88837 89001 89125 89175 89590 +89661 89930 90117 90354 90364 90459 91091 91143 91234 91839 92046 92055 92225 +92365 92414 92463 92510 92575 93058 93092 93275 93357 93775 93795 93925 94017 +94178 94221 94622 94809 95139 95325 95571 95795 95830 95874 96026 96237 96278 +96425 96596 97006 97175 97375 97405 97526 97556 97682 98022 98049 98394 98397 +98441 98494 98553 98716 98735 99127 99275 99567 99705 99715 100510 100555 +100719 100793 100905 101062 102051 102245 102459 102487 102557 102675 102885 +102921 103075 103155 103156 103173 103246 103341 103675 103935 104044 104181 +104284 104690 104811 104907 104975 105125 105154 105183 105524 105710 105754 +105903 105963 106227 106375 106641 106782 106930 107065 107525 107559 107653 +107822 108086 108537 109089 109142 109174 109330 109388 109417 109503 109554 +110019 110075 110331 110495 110789 110825 110946 111265 111476 111910 111925 +112047 112375 112385 112406 112437 112651 113135 113553 113775 114057 114308 +114513 115258 115292 115311 115797 116058 116242 116402 116522 116725 116932 +116963 117249 117325 117334 117438 117670 117711 117845 117875 118490 119119 +119164 119187 119306 120125 120175 120213 120785 120802 120835 121121 121670 +121923 121975 122018 122199 122525 122815 122825 123025 123627 123783 123823 +123981 124025 124468 124545 124558 124775 124930 125097 125229 125426 125541 +125715 125829 125902 125948 126075 126445 127075 127426 127534 127738 127756 +128018 128271 128673 128877 128986 129115 129311 129514 129605 130134 130203 +130585 130975 131043 131118 131285 131313 131495 132153 132158 132275 132618 +133052 133133 133209 133342 133570 133705 134113 134125 134162 134199 134385 +134895 134995 135014 135531 135575 136045 136214 136325 136367 136851 137275 +137547 137566 137924 138069 138229 138621 138765 138985 139113 139564 139587 +139601 139638 140714 140777 141267 141933 142025 142228 142538 142766 142805 +142970 143143 143375 143745 143811 144039 144279 144305 144417 144925 145475 +145509 145521 146234 146289 146334 146523 146566 146575 147033 147175 147436 +147591 147706 147741 147994 148010 148625 148666 148707 148925 149435 149702 +149891 150183 150590 150765 150898 151294 151525 151593 152218 152438 153062 +153065 153410 153425 153729 154105 154652 154693 154869 155771 156066 156325 +156426 156674 156695 157035 157325 157339 157604 157731 158015 158389 158565 +158631 158804 158875 159562 159790 160173 160225 160395 161161 161253 161414 +161733 161975 162129 162578 163370 163415 163713 163761 163990 163995 164169 +164255 164331 164738 164983 165025 165886 166175 166419 166634 167042 167214 +167865 168175 168609 168674 169099 169169 169756 170126 170338 170765 171125 +171275 171462 171475 171535 171925 171941 171955 172235 172546 172822 172887 +172975 173225 173635 174087 174097 174363 174603 174685 174783 174845 174902 +175491 175972 176001 176157 176505 176605 177023 177489 177735 177970 178126 +178334 178746 178802 178959 179075 180154 180761 180895 181203 181447 181917 +182505 182590 182666 182819 183027 183365 183425 183483 183799 184093 184382 +184910 185725 186093 186238 186694 186702 186745 186837 186998 187187 187395 +187775 188108 188139 188518 188853 188922 188993 189625 190333 190463 190855 +191139 191301 191425 191607 191634 191675 192027 192185 192995 193325 193430 +193479 194271 194463 194579 194996 195201 195415 195730 196075 196137 196677 +197098 197846 198237 198927 199082 199927 200013 200158 200355 200725 201243 +202027 202521 202612 203203 203319 203522 203665 204321 204425 205751 205942 +206045 206305 206349 206635 206886 207214 207575 208075 208444 208495 208658 +208715 209209 209457 209525 210125 210749 210826 211071 212602 213342 213785 +213807 214149 214225 214291 214455 214774 214795 215747 215878 216775 216890 +217217 217341 217558 217906 218405 218530 218855 219351 219373 219501 219849 +220255 221030 221122 221221 221559 221991 222015 222111 222425 222999 223706 +223975 224516 224553 224825 224939 225446 225885 225998 226347 226525 226941 +228085 228206 228327 228475 228657 228718 228781 229586 229593 229957 230115 +230318 231035 231275 231725 231978 232101 232562 232645 232730 232934 233206 +233818 234025 234099 234175 234639 235011 235246 235445 235543 235586 236406 +236555 237429 237614 238206 239071 239343 239575 239685 240065 240149 240526 +240695 240737 240994 241129 242121 242515 243089 243815 243867 243890 244205 +244559 244783 245055 245985 246123 246202 246235 247107 247225 247247 248788 +248829 248897 249067 249158 249951 250325 250563 250821 251275 252586 252655 +253011 253175 253253 254634 255189 255507 255626 256711 257193 258115 258819 +258874 259233 259259 259325 259407 259666 260110 260642 260678 260710 261326 +261443 261725 262353 262885 263097 263302 264275 264385 265475 265727 265837 +266955 267189 267197 267325 267501 267674 268119 268203 269059 269555 270193 +270215 270231 270802 272194 272855 272935 273325 273581 273885 273999 274022 +274846 275684 276573 276575 277365 277574 278018 278179 278369 278690 279357 +279775 280041 280053 280497 281015 282302 282777 283383 283475 284053 284258 +284954 285131 285770 287287 287451 287638 287738 288145 288463 288827 289289 +290145 290605 290966 291005 291305 291893 292175 292201 292494 293335 293595 +293854 294151 294175 295075 295647 296225 296769 296989 297910 298265 298623 +298775 299299 299367 300237 300713 302005 303025 303646 303862 303918 304175 +304606 305045 305283 305762 305767 305942 306397 306475 307582 308074 308357 +308913 309442 310329 310821 311170 311395 312325 312666 312987 313565 314019 +314041 314171 314534 314755 314870 315425 315514 316239 316342 316825 317471 +318478 318565 318734 318835 318903 319319 319345 319390 320013 320045 322161 +322465 323449 323785 323817 324818 325335 325622 325703 325822 326337 326859 +326975 327795 328757 329623 330395 331075 331177 331298 331545 331683 331731 +333355 333925 335405 335559 335699 336091 336743 336774 336973 337502 337535 +338169 338675 338997 339031 339521 340442 340535 341341 341446 341734 341887 +342309 343077 343915 344379 344729 344810 345477 347282 347633 347967 348725 +348843 349095 349401 349525 349809 350727 350987 351538 351785 352869 353379 +353717 354609 355570 355946 356345 356421 356915 357309 357425 359414 359513 +360778 360789 361361 361491 361675 362674 363562 364021 364154 364994 365585 +365835 366415 367114 368039 369265 369303 369985 370025 370139 371665 371722 +372775 373182 373737 374255 375193 375683 376475 377245 377377 378235 378301 +378879 378917 380494 380545 381095 381938 381951 381997 382075 382109 382655 +383439 383525 384307 384659 384826 385526 386425 386630 387686 388311 388531 +389499 390165 390166 390963 391017 391065 391534 391685 391989 393421 394010 +394953 395937 397010 397822 397969 398866 398905 399475 400078 400673 400775 +401511 401698 401882 402866 403403 403535 404225 406203 406334 406445 406802 +406847 407407 407827 408291 408425 409975 410669 410839 411033 411845 412114 +412269 413075 413526 413678 414715 415454 416361 416585 417027 417074 417175 +417571 417605 418035 419881 421685 422807 423243 423453 424390 424589 424762 +424879 425258 425315 425546 425845 426374 426387 427025 427063 427431 428655 +429598 429913 430606 431365 431457 431607 432055 435638 435953 436449 437255 +438741 438991 440657 440781 440818 443989 444925 445315 445835 445991 446369 +446865 447005 447083 447146 447811 447925 448063 450262 450385 451451 453299 +453871 454138 454181 454597 455469 455793 455877 456025 456475 456665 456909 +458643 458689 458913 458983 459173 460955 461373 462111 462275 462346 462553 +462722 464163 465595 466697 466735 466755 467495 468999 469567 470327 471295 +471801 472305 472549 473271 474513 474734 476749 477158 477717 478101 479085 +480491 480766 481481 481574 482734 483575 484561 485537 486098 486266 487227 +487475 487490 488433 488733 489325 490637 491878 492499 492745 493025 494615 +496223 496947 497705 497798 498883 499681 500395 501787 502918 503234 505161 +505325 506253 506530 507566 508079 508277 508805 508898 509675 510663 511819 +512006 512169 512601 512746 512981 514786 514855 516925 516971 517215 517979 +518035 519622 520331 520421 520923 521110 521594 521645 523957 527065 527307 +528143 529529 531505 532763 533355 533533 533919 535717 536393 536558 536935 +537251 539121 539695 540175 541167 541282 541717 542087 542225 542659 543286 +543895 544011 544765 544825 545054 545343 546231 546325 547491 548359 550671 +551614 552575 552805 555458 555611 555814 555841 557566 557583 558467 559265 +559682 559773 561290 562438 563615 563914 564775 564949 564995 567853 568178 +569023 570515 570741 571795 572242 572663 572907 573562 573965 574678 575795 +576583 577239 578289 578347 579945 580601 581405 581529 581647 581825 582335 +582958 583015 583219 584545 584647 585249 585599 587301 588115 588965 590359 +591015 593021 593929 594035 594146 594473 595441 595515 596183 596733 598299 +600117 600281 600457 600691 601315 602485 602547 602823 603725 603911 604299 +604877 605098 607202 609501 609725 610203 612157 613118 614422 615043 615505 +616975 618171 618233 620194 620289 620517 620806 620977 621970 622895 623162 +623181 623441 624169 625611 625807 628694 630539 631465 633919 634114 634933 +636585 637143 637887 638319 639065 639331 639561 640211 640871 644397 644725 +645337 645909 647185 648907 649078 649165 650275 651605 651695 651775 651833 +653315 653429 653457 654493 655402 656183 656903 657662 658255 659525 659813 +661227 662966 663803 664411 665482 669185 670719 671099 675393 676286 677005 +677846 680485 680846 681207 682486 683501 683675 684574 685055 685069 687115 +687242 687401 689210 689843 692461 692714 693519 693842 693935 694083 695045 +696725 696787 700553 700843 701437 702559 702658 704099 705686 705755 708883 +709142 709423 709631 710645 712101 712327 712385 714425 715737 719095 719345 +720575 720797 721149 722361 724101 724594 725249 726869 727415 729147 729399 +729554 730303 730639 730825 731235 733381 734635 734638 735034 737426 737817 +737891 742577 743002 743774 744107 744775 746697 748867 749177 751502 751709 +754354 754377 754851 755573 756613 757393 758582 759115 759655 759795 761349 +761453 761515 762671 763347 764405 764855 768009 768955 769119 770185 772179 +773605 773927 774566 774706 775489 777925 779433 781665 782254 782391 782971 +783959 785213 785519 785806 786335 787175 788785 789061 790855 790993 791282 +792281 793117 796195 796835 798475 798721 800513 803551 804287 804837 806113 +809042 809627 811923 812045 812383 813967 814055 814555 814929 815269 816221 +817581 817663 818363 818662 823361 824182 824551 827421 828134 828245 828269 +828971 829226 829939 830297 830414 831575 831649 832117 833187 833721 836349 +836969 837199 838409 839523 839914 841841 841935 843479 843657 843755 845871 +850586 851105 852267 853615 854335 858363 858458 859027 860343 861707 862017 +862025 866723 866822 868205 870758 872053 872275 873422 874437 876826 877591 +877933 878845 884051 884374 885391 886414 887777 888925 889778 889865 891219 +893809 894179 894691 896506 898535 898909 900358 901945 906059 906685 907647 +908831 908905 910385 910803 912247 912373 912485 914641 916487 917662 917785 +918731 919677 921475 921557 921633 924482 926497 926782 927707 927979 929305 +930291 931209 932955 933658 934743 935693 936859 943041 947546 947807 949003 +950521 951142 951171 951235 952679 954845 955451 959077 960089 961961 962065 +963815 964894 966329 966575 969215 971509 971618 973063 973617 975415 978835 +979693 980837 983103 983411 985025 986493 988057 988418 989417 990437 990698 +990847 992525 994449 994555 994903 997165 997339 997694 998223 998963 1000195 +1004245 1004663 1004705 1005238 1006733 1007083 1007165 1012894 1013173 1014101 +1014429 1015835 1016738 1016769 1017005 1018381 1021269 1023729 1024309 1024426 +1026817 1026861 1028489 1030285 1030863 1032226 1033815 1034195 1036849 1037153 +1038635 1039071 1040763 1042685 1049191 1053987 1056757 1057978 1058529 1058743 +1059022 1060975 1061905 1062761 1063145 1063517 1063713 1063865 1065935 1066121 +1067857 1070167 1070558 1070797 1072478 1073995 1076515 1076537 1078259 1083047 +1083121 1084039 1085773 1085926 1086891 1088153 1089095 1094331 1094951 1095274 +1096381 1099825 1100869 1101957 1102045 1102551 1103414 1104299 1105819 1106139 +1106959 1107197 1114366 1114503 1114673 1115569 1115661 1117865 1119371 1121549 +1121894 1123343 1125655 1127253 1131531 1132058 1132681 1133407 1135234 1135345 +1136863 1137873 1139677 1140377 1146442 1147619 1155865 1156805 1157819 1159171 +1159543 1161849 1162059 1162213 1169311 1171001 1172354 1173381 1175675 1178709 +1181257 1182446 1183301 1186835 1186923 1187329 1191547 1192895 1195061 1196069 +1196506 1196569 1198483 1199266 1201915 1203935 1206835 1208938 1209271 1210547 +1211573 1213511 1213526 1213563 1213682 1215245 1215487 1215665 1216171 1218725 +1225367 1227993 1229695 1230383 1234838 1236273 1239953 1242201 1242989 1243839 +1244495 1245621 1245811 1255133 1255501 1257295 1257949 1257962 1258085 1259871 +1262723 1263661 1266325 1266749 1267474 1268915 1269359 1272245 1272467 1274539 +1275879 1277479 1279091 1280015 1281137 1281865 1281974 1282633 1284899 1285999 +1286965 1287687 1292669 1293853 1294033 1295723 1299055 1300233 1301027 1302775 +1303985 1306137 1306877 1310133 1310278 1314542 1315239 1316978 1322893 1325467 +1326561 1329621 1331729 1334667 1336783 1338623 1339634 1340003 1341395 1344718 +1344759 1346891 1349341 1349834 1350537 1351166 1353205 1354111 1354886 1356277 +1356901 1358215 1362635 1365581 1368334 1370369 1370386 1372019 1376493 1379035 +1381913 1386723 1388645 1389223 1389535 1390173 1392377 1393915 1396031 1399205 +1400273 1400487 1403207 1403225 1405943 1406095 1406587 1409785 1410031 1412327 +1414127 1414562 1416389 1420445 1421319 1422169 1423807 1426713 1428163 1430605 +1431382 1432417 1433531 1433729 1433905 1436695 1437293 1442399 1442926 1446071 +1447341 1447873 1448161 1448402 1454089 1457395 1457427 1459354 1459759 1465399 +1466641 1468987 1469194 1472207 1482627 1483339 1485365 1486047 1486667 1488403 +1489411 1492309 1496541 1497067 1497238 1503593 1507121 1507857 1508638 1511653 +1512118 1512745 1514071 1515839 1516262 1518005 1519341 1519817 1524733 1525107 +1526657 1529099 1531309 1532795 1533433 1536055 1536639 1542863 1544491 1548339 +1550485 1552015 1552661 1554925 1557905 1563419 1565011 1566461 1567247 1571735 +1575917 1582009 1582559 1583023 1585285 1586126 1586899 1586967 1588533 1589483 +1600313 1602403 1604986 1605837 1608717 1612682 1616197 1616402 1617122 1618211 +1619527 1622695 1628889 1629887 1635622 1638505 1639187 1641809 1642911 1644155 +1655121 1657415 1657466 1661569 1663705 1670053 1671241 1671549 1675333 1681691 +1682681 1682841 1685509 1687829 1689569 1690715 1691701 1692197 1694173 1694407 +1694615 1698087 1698619 1701343 1701931 1702115 1702851 1706215 1709659 1711435 +1711463 1718105 1719663 1721573 1722202 1723025 1727878 1729937 1731785 1734605 +1735327 1739881 1742293 1750507 1751629 1753037 1756645 1758531 1760213 1761319 +1764215 1769261 1771774 1772855 1773593 1773669 1776481 1778498 1781143 1786499 +1790921 1791946 1792021 1794611 1794759 1798899 1801751 1804231 1804786 1806091 +1807117 1811485 1812446 1813407 1818677 1820289 1820523 1822139 1823885 1825579 +1826246 1834963 1836595 1837585 1843565 1847042 1847677 1849243 1852201 1852257 +1852462 1856261 1857505 1859435 1869647 1870297 1872431 1877953 1878755 1879537 +1885885 1886943 1891279 1894487 1896455 1901211 1901501 1907689 1908386 1910051 +1916291 1920983 1922961 1924814 1929254 1930649 1933459 1936415 1936765 1939751 +1944103 1945349 1951481 1952194 1955635 1956449 1957703 1958887 1964515 1965417 +1968533 1971813 1973699 1975103 1975467 1976777 1978205 1979939 1980218 1982251 +1984279 1987453 1988623 1994707 1999283 1999591 1999898 2002481 2002847 2007467 +2009451 2011373 2017077 2019127 2019719 2022605 2024751 2026749 2032329 2040353 +2044471 2046655 2048449 2050841 2052501 2055579 2056223 2060455 2062306 2066801 +2070107 2070335 2071771 2073065 2076035 2079511 2092717 2099785 2100659 2111317 +2114698 2116543 2117843 2120393 2121843 2125207 2126465 2132273 2132902 2137822 +2141737 2145913 2146145 2146981 2147073 2150477 2153437 2155657 2164389 2167055 +2167957 2170679 2172603 2172821 2176895 2181067 2183555 2188021 2189031 2192065 +2193763 2200429 2203791 2204534 2207161 2209339 2210351 2210935 2212873 2215457 +2215763 2216035 2219399 2221271 2224445 2234837 2237411 2238067 2241265 2242454 +2245857 2250895 2257333 2262957 2266627 2268177 2271773 2274393 2275229 2284997 +2285258 2289443 2293907 2294155 2301817 2302658 2304323 2311205 2313649 2316955 +2320381 2329187 2330038 2334145 2336191 2338919 2340503 2343314 2345057 2357381 +2359379 2362789 2363153 2363486 2367001 2368333 2368865 2372461 2377855 2379189 +2382961 2386241 2388701 2396009 2397106 2399567 2405347 2407479 2412235 2416193 +2419023 2422109 2424499 2424603 2425683 2428447 2429045 2442862 2444923 2445773 +2453433 2459303 2461462 2466827 2469901 2471045 2473211 2476441 2476745 2481997 +2482597 2486199 2494235 2497759 2501369 2501917 2505919 2513095 2519959 2532235 +2536079 2541845 2542903 2544971 2551594 2553439 2561065 2571233 2572619 2580565 +2580991 2581934 2582827 2583303 2585843 2589151 2591817 2592629 2598977 2600507 +2603209 2611037 2612233 2614447 2618629 2618998 2624369 2630257 2631218 2636953 +2640239 2641171 2644213 2644945 2647555 2648657 2655037 2657661 2667747 2673539 +2674463 2676395 2678741 2681195 2681869 2687919 2688907 2700451 2705329 2707063 +2707179 2709239 2710981 2711471 2714815 2718669 2732561 2733511 2737889 2738185 +2739369 2750321 2758535 2760953 2764177 2766049 2767787 2769487 2770563 2771431 +2778693 2785915 2791613 2792387 2798939 2804735 2816033 2820103 2827442 2830145 +2831323 2831647 2838085 2857921 2861062 2862579 2865317 2866105 2868767 2884637 +2886689 2887221 2893757 2893881 2898469 2902291 2904739 2906449 2915674 2922029 +2926703 2928291 2930885 2937874 2939699 2951069 2951897 2956115 2970327 2977051 +2986159 2988073 2991265 2997383 2997797 2998165 2999847 3004603 3005249 3007693 +3022345 3022438 3025541 3027973 3033815 3033877 3034205 3047653 3055019 3056977 +3066613 3068891 3078251 3082729 3085771 3087095 3090277 3093409 3093459 3095309 +3101527 3102449 3114223 3120469 3124979 3130231 3137771 3140486 3144905 3147331 +3151253 3154591 3159637 3160729 3168685 3170366 3172047 3192101 3197207 3199353 +3204935 3206269 3206733 3211817 3230882 3234199 3235687 3243737 3246473 3255482 +3267803 3268967 3271021 3275695 3276971 3286355 3292445 3295331 3299179 3306801 +3307837 3308987 3316411 3328039 3328997 3332849 3339611 3346109 3349085 3361795 +3363681 3372149 3374585 3377129 3377543 3377915 3379321 3381487 3387215 3390361 +3400663 3411067 3414433 3415997 3420835 3424361 3425965 3427391 3427887 3445403 +3453839 3453987 3457817 3459463 3467443 3479998 3487583 3487627 3491929 3494413 +3495057 3502969 3514971 3516263 3518333 3531359 3536405 3537193 3542851 3545129 +3545229 3558583 3569929 3578455 3585491 3595659 3604711 3607315 3607426 3610477 +3612791 3614693 3617141 3621005 3624179 3628411 3637933 3646313 3648385 3651583 +3655847 3660151 3662497 3664293 3665441 3672985 3683017 3692193 3693157 3702923 +3706577 3719573 3728153 3735407 3743095 3744653 3746953 3748322 3753673 3765157 +3771595 3779309 3779831 3780295 3789227 3790655 3800741 3809927 3816131 3817879 +3827227 3827391 3833459 3856214 3860173 3861949 3864619 3872901 3881273 3900281 +3915083 3926629 3928497 3929941 3933137 3946813 3946827 3962203 3965315 3973319 +3985267 3993743 3997418 4012465 4012547 4024823 4031261 4031705 4035239 4039951 +4040509 4041005 4042687 4042805 4050553 4055843 4081181 4086511 4089055 4090757 +4093379 4103239 4121741 4131833 4133261 4138561 4143665 4148947 4153546 4170751 +4172201 4180963 4187771 4197431 4219007 4221811 4231283 4241163 4247341 4247887 +4260113 4260883 4273102 4274803 4277489 4291593 4302397 4305505 4309279 4314311 +4319695 4321933 4325633 4352051 4358341 4373511 4375681 4392287 4395859 4402867 +4405999 4406811 4416787 4425499 4429435 4433549 4436159 4446245 4449731 4458389 +4459939 4467073 4479865 4486909 4502641 4509973 4511965 4531115 4533001 4533657 +4554737 4560743 4565615 4567277 4574953 4585973 4586959 4600897 4602578 4609423 +4617605 4617931 4619527 4621643 4631155 4632959 4672841 4678223 4688719 4706513 +4709861 4710729 4721393 4721519 4724419 4729081 4739311 4742101 4755549 4757297 +4767521 4770965 4775147 4777721 4780723 4789169 4793269 4796351 4803821 4812035 +4821877 4822543 4823135 4829513 4834531 4846323 4864057 4871087 4875277 4880485 +4883223 4884763 4890467 4893779 4903301 4930783 4936409 4940377 4950545 4950967 +4951969 4955143 4999745 5009837 5034679 5035589 5047141 5050241 5069407 5084651 +5097301 5100154 5107739 5135119 5142179 5143333 5155765 5161217 5178013 5211503 +5219997 5222587 5231281 5240333 5258773 5271649 5276851 5280233 5286745 5292413 +5296877 5306917 5316979 5321303 5323153 5332255 5343161 5343899 5344555 5357183 +5382871 5389969 5397691 5411139 5436299 5448839 5459441 5487317 5511335 5517163 +5528809 5538101 5551441 5570917 5579977 5590127 5592059 5606135 5617451 5621447 +5622483 5634343 5635211 5644387 5651522 5656597 5657407 5659927 5677243 5690267 +5699369 5713145 5724677 5748431 5756645 5761691 5768419 5783557 5784321 5787191 +5801131 5818879 5824621 5825095 5827289 5837009 5841557 5852327 5858285 5888069 +5891843 5896579 5897657 5898629 5908715 5920039 5964803 5972593 5975653 5992765 +5996127 5998331 6009133 6024007 6024083 6027707 6047573 6068777 6107155 6129013 +6153655 6159049 6166241 6170417 6182423 6201209 6224743 6226319 6229171 6230319 +6243787 6244423 6247789 6268121 6271811 6298177 6305431 6315517 6316751 6322079 +6343561 6378985 6387767 6391861 6409653 6412009 6424717 6439537 6447947 6454835 +6464647 6468037 6483617 6485011 6503453 6528799 6534047 6547495 6578045 6580783 +6583811 6585001 6591499 6595963 6608797 6649159 6658769 6674393 6675251 6679351 +6704017 6709469 6725897 6736849 6752389 6791609 6832679 6876857 6883643 6903867 +6918791 6930763 6958627 6971107 6979061 6982823 6999643 7005547 7039139 7048421 +7050857 7058519 7065853 7068605 7119281 7132231 7139269 7152655 7166363 7172191 +7206529 7218071 7229981 7243379 7289185 7292311 7296893 7344685 7358377 7359707 +7367987 7379021 7395949 7401443 7424087 7431413 7434817 7451873 7453021 7464397 +7465157 7482377 7517179 7525837 7534519 7537123 7556095 7563113 7620301 7624109 +7650231 7653043 7685899 7715869 7777289 7780091 7795229 7800127 7829729 7848589 +7851215 7858097 7867273 7872601 7877647 7887919 7888933 7903283 7925915 7936093 +7947563 7966211 7979183 7998403 8026447 8054141 8059303 8077205 8080567 8084707 +8115389 8138705 8155133 8155351 8176753 8201599 8234809 8238581 8258753 8272201 +8297509 8316649 8329847 8332831 8339441 8389871 8401553 8420933 8448337 8452891 +8477283 8480399 8516807 8544523 8550017 8553401 8560357 8609599 8615117 8642273 +8675071 8699995 8707621 8717789 8723693 8740667 8773921 8782579 8804429 8806759 +8827423 8869751 8890211 8894171 8907509 8909119 8930579 8992813 8995921 9001687 +9018565 9035849 9036769 9099743 9116063 9166493 9194653 9209263 9230371 9303983 +9309829 9370805 9379019 9389971 9411631 9414613 9472111 9478093 9485801 9503329 +9523541 9536099 9549761 9613007 9622493 9640535 9649489 9659011 9732047 9744757 +9781739 9806147 9828767 9855703 9872267 9896047 9926323 9965009 9968453 9993545 +10013717 10044353 10050791 10060709 10083499 10158731 10170301 10188541 +10193761 10204859 10232447 10275973 10282559 10309819 10314971 10316297 +10354117 10383865 10405103 10432409 10482433 10496123 10506613 10511293 +10553113 10578533 10586477 10610897 10631543 10652251 10657993 10682755 +10692677 10737067 10754551 10773529 10784723 10891199 10896779 10938133 +10991701 10999439 11096281 11137363 11173607 11194313 11231207 11233237 +11308087 11342683 11366807 11386889 11393027 11394187 11430103 11473481 +11473589 11484911 11506445 11516531 11528497 11529979 11560237 11630839 +11647649 11648281 11692487 11730961 11731109 11758021 11780899 11870599 +11950639 12005773 12007943 12023777 12041003 12124937 12166747 12178753 +12179993 12264871 12311417 12333497 12404509 12447641 12488149 12511291 +12540151 12568919 12595651 12625991 12664619 12689261 12713977 12726523 +12750385 12774821 12815209 12823423 12836077 12853003 12871417 12888227 +12901781 12999173 12999337 13018667 13055191 13119127 13184083 13306099 +13404989 13435741 13438339 13482071 13496749 13538041 13590803 13598129 +13642381 13707797 13739417 13745537 13759819 13791559 13863863 13895843 +13902787 13955549 13957343 13990963 14033767 14088461 14128805 14200637 +14223761 14329471 14332061 14365121 14404489 14466563 14471699 14537411 +14575951 14638717 14686963 14742701 14854177 14955857 14967277 15060079 +15068197 15117233 15145247 15231541 15247367 15320479 15340681 15355819 +15362659 15405791 15464257 15523091 15538409 15550931 15581189 15699857 +15735841 15745927 15759439 15878603 15881473 15999503 16036207 16109023 +16158307 16221281 16267463 16360919 16398659 16414841 16460893 16585361 +16593649 16623409 16656623 16782571 16831853 16895731 16976747 16999133 +17023487 17102917 17145467 17218237 17272673 17349337 17389357 17437013 +17529601 17546899 17596127 17598389 17769851 17850539 17905151 17974933 +18129667 18171487 18240449 18285733 18327913 18378373 18457339 18545843 +18588623 18596903 18738539 18809653 18812071 18951881 18999031 19060859 +19096181 19139989 19424693 19498411 19572593 19591907 19645847 19780327 +19805323 19840843 19870597 19918169 20089631 20262569 20309309 20375401 +20413159 20452727 20607379 20615771 20755039 20764327 20843129 20922427 +20943073 21000733 21001829 21160633 21209177 21240983 21303313 21688549 +21709951 21875251 21925711 21946439 21985799 22135361 22186421 22261483 +22365353 22450231 22453117 22619987 22772507 22844503 22998827 23207189 +23272297 23383889 23437829 23448269 23502061 23716519 24033257 24240143 +24319027 24364093 24528373 24584953 24783229 24877283 24880481 24971929 +24996571 25054231 25065391 25314179 25352141 25690723 25788221 25983217 +26169397 26280467 26480567 26694131 26782109 26795437 26860699 26948111 +26998049 27180089 27462497 27566719 27671597 27698903 27775163 27909803 +27974183 28050847 28092913 28306813 28713161 28998521 29343331 29579983 +29692241 29834617 29903437 29916757 30118477 30259007 30663121 30693379 +30927079 30998419 31083371 31860737 31965743 32515583 32777819 32902213 +33059981 33136241 33151001 33388541 33530251 33785551 33978053 34170277 +34270547 34758037 35305141 35421499 35609059 35691199 36115589 36321367 +36459209 36634033 36734893 36998113 37155143 37438043 37864361 37975471 +38152661 39121913 39458687 39549707 40019977 40594469 40783879 40997909 +41485399 42277273 42599173 43105703 43351309 43724491 43825351 44346461 +45192947 45537047 45970307 46847789 47204489 47765779 48037937 48451463 +48677533 49140673 50078671 50459971 52307677 52929647 53689459 53939969 +54350669 55915103 57962561 58098991 58651771 59771317 60226417 61959979 +64379963 64992503 66233081 66737381 71339959 73952233 76840601 79052387 +81947069 85147693 87598591 94352849 104553157 } + +! This is a lookup table for the final hand values of all hands not covered in +! the flushes and unique5 tables above. +CONSTANT: values-table +{ 166 322 165 310 164 2467 154 2466 163 3325 321 162 3324 2464 2401 161 2465 +3314 160 2461 159 2400 320 3323 153 2457 6185 2463 3303 2452 158 3322 157 298 +2460 2446 152 3292 156 2398 3321 2462 5965 155 6184 309 2456 3320 2439 3313 +2395 2459 2431 2335 2451 6181 3319 3281 2422 151 2391 2445 6183 2399 2455 319 +3291 2412 5964 6175 2386 3318 5745 150 2450 6180 3312 3317 297 6165 2458 2438 +5961 2430 2380 142 2444 3311 308 3316 318 286 149 6150 5963 6174 3259 5525 3315 +2421 2397 2454 5955 148 6182 2373 3302 6164 2437 5960 2411 5744 2449 2365 3310 +5945 6178 2429 6129 2334 2394 2453 6179 6101 147 141 3309 6149 5741 2448 2356 +2443 3215 2269 5930 2420 2396 5954 3290 3248 3280 2346 6065 6172 2390 2410 3308 +317 146 6173 2442 5944 3258 6128 3270 2393 6020 3301 6162 145 3289 5735 2436 +2385 5958 2447 6100 5909 2333 6169 6163 2428 2332 5881 5725 6177 316 5929 3307 +3300 6159 144 2435 6147 3204 285 3306 2379 6064 2441 2389 6148 2427 5524 2329 +2419 307 143 5845 3288 5952 3214 3257 2268 6019 5710 5962 3160 2440 6144 2384 +2409 5305 5908 3269 5800 3305 3287 6171 5942 5521 3299 6126 2418 5743 2392 6155 +5880 2372 2434 5949 6176 6127 6098 5959 3304 2331 6161 2364 2426 315 2325 2408 +3298 3094 6099 2378 5689 140 2433 6168 5939 3286 6123 5740 5927 306 5661 5844 +6140 2425 3213 2320 130 6095 3279 2328 6062 6158 2355 5515 2417 2388 6146 5085 +5304 2267 5799 3297 6063 3149 6170 6135 274 2432 5953 5924 5523 6017 3247 2371 +2345 5625 2407 5505 2416 2383 3285 2424 3278 6018 5906 2314 6059 5742 3159 5935 +6160 2363 6119 5734 2387 6143 5943 3237 3284 296 5878 5580 6167 2406 3256 6091 +3017 5520 2324 6125 6014 5957 6154 3083 3296 6114 5724 2382 314 5490 5903 2415 +6097 5739 2377 139 6157 3295 2354 5920 6086 6145 5084 2319 5738 2423 129 3093 +5928 2307 3283 5875 5842 3212 3277 6122 2405 2266 6055 3203 3246 313 2344 2299 +305 6139 5915 2203 6108 3282 5709 6094 2376 5522 3158 5797 138 6061 3255 3294 +5514 6010 6142 3276 5951 6050 3193 5303 5469 6080 284 2414 2370 2313 5839 4865 +2381 6134 262 5899 2263 5733 6124 5956 6016 6153 3236 5441 5907 2413 3254 2362 +3293 2290 5504 6005 5732 5941 5301 5871 2404 3006 6096 5519 5794 6058 2330 6166 +304 5879 6118 5894 5948 5723 2929 3092 3275 5688 2403 2369 6044 2280 5722 6090 +6121 2375 3016 5866 137 3202 6013 5737 6073 4645 5660 6156 2306 5405 2361 6138 +312 2353 6113 5729 5938 3253 5081 5489 6093 5999 2265 5835 2327 5926 6060 3211 +2830 2298 5843 2259 6085 5950 2374 5083 3226 136 273 128 5888 5360 5708 2402 +4864 2343 6133 5295 5719 5513 5790 6054 6015 5707 5830 3192 5302 3157 3274 5860 +3210 6037 5798 5624 2352 3148 2254 6141 5940 2137 2202 2368 6107 2262 311 5923 +6057 3268 3273 6029 5285 6117 2289 5947 6009 5503 5518 5785 5731 3252 6049 3245 +5468 6152 2360 6079 5992 303 5579 5905 135 2342 3138 5934 6089 3015 2323 2367 +6012 5704 3251 3156 295 2918 4644 5440 5687 5984 5824 5877 2279 6112 3209 5937 +6004 5721 5300 2248 4425 3091 2359 3267 5925 5686 5715 5853 3082 5659 3272 2720 +6084 3182 5728 6120 2318 5270 3201 6151 2928 5488 5902 5779 2351 6043 5658 6137 +5075 2819 2258 5919 6053 6092 5082 3225 2326 3250 6072 2366 3072 3271 134 5404 +5874 5975 3147 5841 5512 3244 5718 5080 2200 6106 3090 2341 5922 5683 5998 2264 +5706 2350 4861 2829 6132 2358 5065 5817 133 5623 6008 5700 2253 3208 250 5914 +6048 261 3249 2241 6078 2201 5359 5904 2312 5655 2599 4863 5796 6136 5933 5622 +5502 5294 5809 3243 3266 3207 5517 2340 5249 294 6056 3235 2233 5467 5772 6036 +5876 5578 5838 5509 3137 6116 6003 5695 5946 3155 2136 5298 5898 4424 2261 5703 +5221 4855 5577 302 6131 3081 5439 5764 6028 2349 5284 132 6088 3265 3014 5050 +2322 6011 2927 5299 2247 5870 5901 5991 3005 4641 6042 5685 5793 5619 5499 5714 +6111 2357 5936 3089 5918 2709 5679 5487 5893 3181 3206 5736 3242 6071 4205 4643 +2305 2224 5873 5983 2339 5657 131 6115 5840 3200 6083 301 5078 2317 5651 5997 +127 2995 5865 3154 5574 5185 2828 3071 2297 5403 5755 2719 6087 238 5511 3013 +5913 5674 2321 6052 3205 5269 5079 2199 2214 4635 3264 5682 5834 3127 5795 3146 +6110 5074 5292 3985 3199 2348 2257 118 5484 5699 6105 5029 5646 2071 3191 5921 +3224 6130 5140 2240 5887 6035 5358 5654 2588 5837 5974 4862 5621 6082 6007 5501 +2134 5293 2316 6047 2347 5897 126 5466 5789 6077 5001 5615 3241 2311 5829 5495 +4860 2232 5932 5859 2338 5064 6027 5282 2288 5508 2252 6051 5730 5694 4845 2135 +5297 5869 3088 272 5990 3004 5668 5438 3153 5792 2598 3240 3145 5576 6002 2337 +5283 2197 6104 5892 5570 4421 3198 5516 5784 5248 5610 4204 3061 3263 5982 5640 +3080 3152 2278 3012 5618 293 6006 5498 6046 5720 4625 5463 300 5678 2926 4423 +6076 5864 5486 5900 2310 6041 6109 5220 4965 4854 5931 2917 4642 3262 2223 5823 +5480 2718 5727 5917 5049 5565 5267 5077 3234 2246 5435 5650 6070 5833 2994 4640 +2304 4830 5402 5872 5573 6081 3011 5072 3239 3984 2315 5852 6001 125 3171 2336 +3765 2005 4415 5673 3180 5996 283 4920 5268 3087 5886 2907 2213 3079 2827 5778 +5973 3126 5604 2296 3151 5475 5073 5291 5717 2818 5912 2925 5788 117 5483 3197 +5645 5357 249 6040 5705 5828 4858 3238 3086 5184 5858 5633 5062 292 2193 3261 +6103 299 124 5916 5510 2133 3190 2198 6069 5465 4634 2597 2303 5399 5559 3196 +5614 6034 3150 5494 5836 4859 6045 2808 5063 5281 5816 5459 2131 6075 226 5896 +2309 5028 5995 2260 5783 5246 2070 3144 5139 2239 4610 2826 5667 5437 3260 4809 +2295 3545 6026 3136 2188 6102 2287 5911 5500 3233 5808 5431 2984 2196 5868 5354 +5569 5989 5702 3003 5000 5218 4852 5247 5609 5791 6000 2916 3060 2231 3085 5639 +5289 5771 5822 5597 4781 4405 5454 5507 6074 5047 5891 2308 4844 260 5296 123 +3078 5462 4201 4422 4638 6033 5684 5981 5219 3195 4853 2277 5713 5851 106 2924 +5763 5589 3232 5479 3764 5895 5426 6039 282 4420 5048 5863 5564 5266 4203 3084 +5434 5777 5552 4639 6025 5656 5279 3143 5401 2286 2717 4390 5071 5497 2817 5726 +6068 2182 3170 3010 4624 2708 2302 5395 5867 237 5988 3002 5485 5832 3194 4964 +5182 4589 2906 3070 5069 3981 2222 5544 5603 2923 5994 2256 4745 5474 5890 6038 +5076 271 2825 5448 3009 4195 4632 2294 5681 5885 5980 291 5356 4829 2276 5972 +4857 5910 4561 5183 3983 5632 5061 5815 2192 5716 5754 5350 6067 5698 2698 2004 +5026 4414 2068 2301 5390 5862 5787 4919 5137 3231 5827 122 5420 3116 2212 4633 +5653 5857 3544 5059 5398 5558 3125 4700 2716 5620 5993 2251 3189 5290 2807 5807 +5264 5458 2130 6032 1939 2824 116 5482 4998 5027 5831 2293 5245 2069 2596 5138 +121 2127 3077 5770 3975 3142 2587 2255 5535 2187 5345 5693 4842 2132 3223 5782 +2175 2922 5430 2983 6024 5884 5464 5275 3008 5353 4999 2285 5217 5971 4851 5575 +5493 3135 5762 4525 5288 3188 5280 5596 3141 5987 3001 5453 4418 6031 5786 5046 +5701 5826 4843 2896 2167 4849 6066 4609 2915 2300 4637 5384 5856 2122 5436 4808 +2577 5617 5821 5889 2250 5044 105 4185 4622 5588 2707 5677 5979 2195 5425 3007 +2245 2275 6023 4419 3050 2595 4962 3230 2284 5413 4202 2823 3059 4480 5712 120 +5850 2292 5551 4780 5278 4404 5861 3761 5986 3000 3179 5781 5243 2181 4369 4623 +5649 5461 5339 5394 4200 2993 4827 2715 5572 5776 3229 4963 3134 5181 2797 3076 +5260 5068 2816 5543 5753 5478 3763 4170 2002 3140 4412 5672 5978 4917 3187 2274 +5265 5215 214 3105 3965 5447 4341 2914 119 2158 4631 6030 5433 281 3069 5820 +4828 5400 4389 5070 3075 3222 3982 2116 5883 3169 5349 115 2244 2697 2003 5025 +5644 4413 5970 2067 4629 5389 5680 4918 2714 5136 2921 4588 5419 3115 5711 290 +5377 5849 6022 3980 5255 2586 5058 5814 2283 3139 3755 4744 5473 5697 5825 259 +5023 2065 5263 5855 2148 5055 4194 5985 2238 225 3950 4997 5613 5775 5355 2249 +5652 3541 4856 2822 4560 3228 2126 2291 5060 5369 2815 3221 2191 5806 5534 5882 +2594 5344 4995 5969 4841 2174 4149 4607 5179 5332 5666 5977 2230 5274 3068 4806 +4305 3543 5769 5397 2273 4699 5506 202 5780 5239 289 5692 3074 5457 4839 2129 +2194 1938 5854 5568 3039 4417 3186 5244 248 5608 2895 2166 280 4848 3227 2920 +4608 5324 5638 3974 5383 2121 4778 5813 4807 5761 4402 2713 2576 2186 5696 2109 +5211 2061 2593 2973 5043 2913 4621 5134 5429 2237 4198 2982 4260 5819 5352 3185 +3049 3535 5216 4961 4850 5412 5040 5616 3929 6021 5496 3073 5234 4524 5287 2243 +2282 2687 5805 4779 4403 5452 4619 2706 5676 5045 2101 5563 3220 5242 3133 5848 +4959 2919 2999 2229 5338 4199 4636 5768 5968 4826 2221 3745 4387 3178 2796 5259 +5691 2821 5206 4835 104 4184 3168 2281 3762 2912 2001 5774 5424 4411 5648 2992 +4916 5818 4824 5214 1873 3104 4586 5571 2814 2905 5976 2998 5035 2157 3978 4479 +2272 5315 5760 5602 5277 4742 2242 5752 3760 4388 1999 4409 5671 2115 5175 4914 +4192 2180 4368 3067 5847 5393 2592 2211 4628 3124 3730 3184 4121 4558 5180 4587 +5631 3177 2820 5376 5067 2190 3979 5254 2712 2271 4615 4169 2705 5675 4743 5481 +5773 5228 5022 5643 2064 2092 3964 5446 2147 5054 4340 4193 5812 4630 2813 2566 +2220 5557 4697 3132 2585 5019 94 3901 4559 2806 5368 5130 2236 2128 2711 5170 +1936 5348 288 5647 3525 236 5024 2991 3219 2066 5388 5200 4820 4994 5612 3183 +5135 2911 5492 4606 5178 5418 5331 3114 3972 5804 5967 4805 2997 3542 5057 2185 +5751 4698 3754 4991 1995 1807 2962 5238 5670 2082 2228 5262 4838 279 5767 1937 +3949 4604 2210 3038 4996 5665 5811 3218 3123 4803 3540 5690 5846 5014 2056 4085 +2125 5323 4522 5286 3973 5595 5966 4777 5125 4401 3709 2235 2270 114 3176 5343 +2108 5210 5642 2060 3510 5567 2972 4840 2173 5607 4148 5133 4197 5759 3058 2591 +2996 5273 4304 5637 5803 2584 4775 4399 5039 2812 4986 103 5233 4182 4523 5587 +2686 2227 4618 190 5460 5766 2885 4416 2100 5611 5491 5164 2894 2165 4958 4847 +4040 4477 3066 5550 2590 5382 3028 2120 5276 2704 3131 287 5477 3758 4386 4955 +3865 5042 5205 4834 5562 2179 4183 4366 4620 2219 4600 5664 4259 5432 5758 5193 +4799 3048 3534 4960 4823 3217 213 4585 5411 3928 4384 5066 5034 3977 4478 5810 +5542 5314 4167 3130 2710 4741 2990 270 5008 3759 2050 1998 5566 4408 5241 5119 +5174 5606 4913 3962 2234 4338 4191 3057 4367 4583 5337 2904 5636 3489 5750 2786 +4825 3744 4771 1990 4395 5601 2703 5669 2910 4557 4739 2795 5472 4910 3820 5258 +5802 4950 3681 2209 4614 2696 4168 2000 3175 4189 4410 247 4980 2218 5227 4915 +3216 5213 2091 1872 3103 2226 3113 3963 4339 5765 4555 2156 2565 5630 5056 2589 +4696 113 5476 3752 5018 5641 93 2811 2989 4815 2114 5129 5561 5261 3645 5169 +1935 3947 3174 2583 4627 5199 3538 4819 5396 5556 5749 5157 3729 82 4694 4120 +4380 2124 3065 3971 5375 5757 4905 2805 5253 5533 5456 258 3753 4990 2208 3129 +1994 1933 201 2961 3122 5021 2172 2063 2081 4146 4579 2146 5053 2903 5272 3948 +4603 4302 3969 178 4802 5600 3539 5149 4735 112 5471 3900 5013 3064 2055 2909 +4521 5367 4595 5124 2702 5663 5428 2874 2043 2981 3524 5351 2582 4944 5112 4993 +278 2164 4846 4147 4605 4551 5177 5330 2217 5629 2119 3461 4804 4303 4519 2189 +2575 5594 4774 3128 4398 5451 1806 5237 4985 5605 5041 5801 4181 3056 4837 5635 +4257 4973 1741 224 2035 3037 2884 2951 3047 3532 3173 5555 5104 4690 2225 5163 +3926 2908 4476 4084 5322 2804 3425 3027 4776 5748 5455 102 4179 4400 3708 5586 +1984 3757 1929 5662 5423 4794 2107 4899 5209 4954 5240 2059 3509 2810 2971 4365 +5132 2207 4196 4599 2775 4258 4474 3121 3742 5192 4798 5549 3533 2184 277 5038 +5560 5257 2676 3927 4383 5756 5232 3063 2685 4166 5427 235 111 3600 2980 4363 +4617 5007 5634 2049 5392 3172 4766 2099 5212 1870 4375 3102 5118 3961 4957 4337 +2155 4039 4582 4515 3167 2581 5593 2785 3743 4770 5541 1989 4394 5450 4164 4385 +4738 4909 2113 2809 3864 4574 5204 4949 4833 2701 2902 3959 5445 4335 4188 4626 +4979 5599 4937 2026 5470 3727 4118 4822 1871 4584 5095 2216 5033 4554 3976 3062 +5252 5313 4175 5585 3380 3751 4740 5422 5347 2695 1997 5020 4407 2062 4814 5387 +4546 5173 4912 2940 2700 2145 5628 5052 4190 3946 2988 5417 269 4470 4788 5548 +3488 4929 3537 3166 5156 3728 3898 81 4693 4119 3749 4556 4379 2215 3819 4904 +5747 3680 1977 2178 4359 4613 2901 3522 5391 5554 1932 3944 4892 2016 4992 5226 +5598 4145 4730 2090 2555 3055 5176 2206 4578 2803 2987 3120 2123 4301 2564 4760 +3968 5540 1675 1924 4695 4160 5148 5017 4734 1804 5532 5236 92 3899 5342 5128 +4836 5746 4594 3644 110 3955 5444 1969 5168 4143 1934 4331 2873 5627 3036 2042 +3523 4884 2183 4299 5198 4943 5111 4818 4082 2205 4550 3970 2580 3119 2979 4518 +3706 5346 2694 4989 1993 2106 5208 1805 2960 2058 3507 5386 5553 2970 4685 2080 +5131 2893 109 4510 5416 3112 4256 4972 189 5592 2802 4602 2034 2950 5381 3531 +5449 2118 4801 5103 4689 2574 1918 5037 2665 3925 5012 5231 2054 4083 4520 2579 +276 3165 5123 4178 3707 4616 1983 1928 3940 2098 4254 4793 4898 3508 268 3529 +4956 4568 4037 2900 5410 101 2863 3923 2774 5584 3460 4473 3741 2986 5421 4724 +2978 4773 5531 4397 5341 2675 4984 3862 5203 4832 4180 2171 4139 4465 2699 5547 +4362 1740 1960 5271 5336 2883 4295 5591 4765 4821 3739 1869 4374 4875 3054 4540 +5162 5626 5032 4038 2794 4475 4753 2204 2177 4514 3424 4354 3026 3118 3756 4163 +1996 4406 4953 5172 3863 4911 4573 2892 2163 1867 4364 3101 3958 4598 5539 4334 +3486 108 5380 2985 100 4155 5191 4936 4797 5583 4679 2025 3726 2573 4117 3053 +5094 3817 2801 4382 2764 5443 3678 2112 4326 4174 4612 4165 70 2578 3599 1950 +5006 4250 5546 5225 2048 3046 2544 2089 5117 4545 3960 3724 5409 2939 4115 4336 +3919 4581 275 4469 4787 5374 3487 3117 2784 4928 2176 2693 4769 4348 1988 5016 +4393 91 3897 5385 3748 4737 4908 5127 3818 3164 5415 4948 3642 246 5167 3679 +223 1976 4358 3521 107 5051 5335 4187 4978 3943 4891 5538 5197 2015 4817 3735 +2852 4729 212 2554 2793 3895 4504 5256 4553 5590 4759 5366 4717 177 1923 3935 +5442 3379 3750 4320 4159 4988 1992 1803 2959 3519 2079 4813 3163 1863 257 3643 +3954 1968 4142 3945 4601 4330 2154 5329 4883 5530 4800 4298 3536 5340 4533 5155 +2692 80 4692 2899 5011 4378 2053 4081 3052 1801 2170 99 4134 4903 5582 5122 +3705 4709 5414 3111 4290 1931 3506 3035 4684 3720 4144 4111 4577 4459 4509 3458 +5373 5545 4079 4300 5321 3967 4672 5251 1674 4772 4396 3703 1917 2753 5147 2664 +4733 2800 4983 2891 2105 2162 2057 3504 267 1911 4593 5379 1738 2144 2117 2872 +3939 2882 2041 2572 4253 4942 5110 5529 5161 3528 4567 4036 3891 3051 5036 4549 +2862 3922 3422 3025 5365 5537 3459 2169 4517 4664 4128 4245 4723 2684 3045 3515 +4284 4952 200 3861 5408 2097 3914 2977 1903 4138 4464 4597 3162 5328 4034 4255 +4971 1739 1959 5190 2033 4796 4294 2949 3530 3738 5102 4874 4688 4539 3924 4381 +1797 4497 5235 2898 4752 3423 3859 4353 2890 2161 4831 5334 3597 4177 2691 1982 +5005 1927 2047 2654 5378 256 4792 4897 2571 5116 2792 2976 3110 1866 4580 4075 +5320 3485 2773 5031 2783 4472 3740 4154 4768 1987 4678 5312 4392 3699 4736 4239 +4907 3816 4489 2674 98 5207 1858 234 245 3500 5581 4947 2969 2763 3677 4325 +5407 2153 3161 69 3908 4186 3598 4977 1949 4361 4249 3483 4764 2543 1868 4373 +3723 4452 2111 4114 4552 3918 2897 5230 3814 4513 3377 2683 5528 3675 4347 4655 +4611 5333 4162 4812 3715 97 4106 2168 2799 2841 4572 3641 5372 2088 2791 4030 +3957 5250 1894 4333 2563 4935 3734 5154 2024 3725 2851 79 4691 4116 4377 5015 +4444 5093 90 3894 5536 4902 4503 3855 5202 1852 2143 3100 4173 4716 3934 3378 +3639 4319 2152 1930 3518 3886 2889 2160 4816 4313 1862 4544 4576 2938 5364 2975 +2110 3966 4468 4786 1672 5311 2570 4927 5146 2533 4732 4532 3896 3747 4987 1991 +1800 2958 2798 4133 4592 2643 5171 5327 4100 2078 2690 4708 1975 2871 4357 2040 +1884 4289 5371 3520 3942 3044 4890 3479 4941 5109 2014 1792 5406 3109 3719 4728 +2742 4110 2553 4548 4458 3457 5010 3810 2052 4078 4516 4758 4671 3671 1673 1922 +2142 3034 4158 3702 2752 1802 5224 3503 96 4070 1910 5319 3880 2689 3953 2974 +1967 4970 1737 4141 4329 2032 5363 2948 3694 2562 3455 4882 4297 5101 4687 2790 +2104 3108 89 3495 3890 2968 4080 3421 4982 4435 5126 5527 4176 4663 3704 4127 +3635 1981 5166 4244 5326 1926 1735 3514 4791 4896 4283 3505 266 5196 1845 3099 +4683 3913 1902 1786 2151 5229 4277 4508 2772 4033 4471 2682 3419 3024 1916 2663 +2096 233 2673 1796 4496 255 4951 95 4025 3858 5526 3596 4360 4064 5318 3938 +2653 4596 4763 4252 211 4372 3688 2159 4795 4093 3527 4566 4035 3850 5370 2103 +5201 2051 4269 4074 2522 2861 4512 3921 2967 2569 5121 3698 4722 4161 3594 4238 +5004 4488 2046 1857 3860 3499 4571 2141 5030 4137 3956 4232 4463 3907 4332 5310 +188 3043 3451 1958 4934 4293 2023 2681 3482 2888 265 3737 4767 4873 3873 1986 +5092 4391 4538 4451 5362 3107 2095 4906 4751 3813 4172 2568 4352 3376 4946 3674 +4019 3474 4654 1731 2881 4976 3714 4105 4543 2840 2937 5160 3805 5325 1865 4224 +4029 4467 4785 3666 1893 3844 3484 3042 3415 3023 4926 4153 4677 2789 3374 3746 +1779 5223 4443 3815 2087 3854 2762 4811 3676 1851 1974 4324 4356 68 2561 3638 +3033 2688 3941 1948 4889 4248 2013 5309 5189 58 3098 2542 3885 4727 2552 4312 +2150 3722 4057 5317 78 3106 4113 3917 4376 4757 3630 5165 1671 1921 4901 2632 +4157 4346 2532 3590 199 2102 5195 2045 3468 222 2642 5115 3640 4099 3952 1966 +4140 4328 1883 4575 3799 4881 4296 3478 3660 2782 1837 3733 3097 1985 1669 2850 +1791 2957 2887 2741 2149 4731 2077 3893 5222 4502 3809 2680 2086 3670 4715 3933 +4591 2567 4318 2870 2560 2094 2039 3517 4682 4940 2140 5009 1861 4012 88 4069 +3879 4507 4547 5120 4215 3693 3454 3624 3041 2731 3370 1915 2662 4531 3494 5361 +3837 1799 5194 4810 4434 4132 3634 4707 3446 3937 4288 4251 4969 1734 2031 2947 +3526 1844 4565 5153 2886 3718 2139 4981 77 4686 4109 1785 2956 2860 3920 4457 +4276 3456 5308 4077 2076 4670 3418 4721 1726 176 1771 2880 3701 2751 1980 1925 +2788 5159 4790 4895 3502 4024 4136 4462 1909 3032 3410 1736 244 4063 1957 2511 +4292 2771 3040 1665 3736 4872 3687 4092 4537 5145 1828 5316 3096 3889 3792 3849 +4750 4268 2521 264 3420 4351 3653 4590 4662 4126 4243 46 254 5188 2038 3593 +3440 2966 3513 4282 2085 5108 4762 1864 3912 4371 1901 4231 3031 2559 4032 3450 +4152 4676 3585 4511 5003 87 3872 1720 4049 2787 2879 1795 4495 5114 2761 2679 +4323 3617 3857 5158 4570 67 3595 4018 1947 3473 4247 2093 1730 2781 2652 2030 +3404 232 2965 2946 2541 4933 5100 2022 1818 3095 3721 4112 3804 3916 4223 2138 +4945 4073 3665 3843 3414 4345 4171 3697 4975 1979 3373 1778 221 4237 3829 5187 +4789 4487 2075 1856 3498 2678 4542 3906 2936 253 3365 4466 3732 4784 57 2849 +3481 4925 3579 4004 5002 3892 4450 2044 4056 4501 2672 5307 3629 3812 5113 4714 +2631 3932 3375 4317 3673 1973 3589 4653 4355 3516 3467 1762 5152 2780 4888 3713 +4761 76 2012 4104 1860 4370 2839 4726 263 4900 4028 3433 3798 1892 3030 3659 +4756 1836 4530 1668 1920 4156 3784 4974 1798 4442 4131 2621 5306 3853 4569 1850 +4706 4287 1713 3637 3951 1965 2878 1660 4327 2084 5144 4880 2021 3359 3717 2964 +3884 4108 4311 4011 4456 5091 2558 4076 3397 3022 4669 4214 1670 2869 3623 86 +3700 2730 3369 2750 2531 1752 4939 5107 3836 3501 3609 5151 1908 2641 4541 4681 +4098 187 2935 3445 1882 4506 3029 5186 4783 3477 2083 1790 3888 2740 1914 2661 +3995 2557 3808 4661 4125 3669 4242 3572 4968 1725 1972 85 1770 2955 243 3512 +4281 3936 2074 5099 2011 1654 2963 3911 2610 5143 1900 4725 2551 4068 3878 4564 +4031 3409 2510 2859 2779 3692 4755 3453 1978 1664 1919 2868 4720 2037 1827 4894 +1794 4494 3493 3791 4938 5106 3856 4433 3652 2677 3633 2770 1964 4135 4461 2651 +45 2954 3439 1733 1956 2073 4291 1843 2671 4871 2500 1784 4536 4072 4275 4749 +3352 3584 3696 3417 4350 4236 4967 1719 2029 4048 4486 1855 2945 3497 3775 5098 +4680 3616 4023 1705 3905 210 4505 4062 3403 3480 5150 4151 3686 75 4675 4091 +1817 4449 1913 252 3848 3389 3021 4893 4267 3811 2520 2556 2760 3672 4322 4652 +66 4932 2769 3592 84 1946 3828 3712 4246 4103 2838 5090 2540 4563 4027 1696 +4230 2670 1891 2877 2858 3915 3449 1647 3364 5142 4719 3578 3871 4344 4003 4441 +2489 3020 3852 1849 2934 3564 3636 2867 4460 4017 2036 3472 1729 4924 1955 1761 +2953 5105 3883 3731 4310 2072 2848 4535 3803 4222 3432 2778 3664 175 4748 3842 +4500 1971 3413 4349 2530 4713 3931 4887 3372 83 1777 4316 3783 4931 2020 2620 +2550 2640 4097 3555 5089 1859 1881 4966 1712 2028 1659 220 3476 4150 56 5097 +4674 1789 3358 2739 4529 4055 3807 3396 198 3628 3344 2759 3668 1963 4130 2630 +4321 231 65 4705 3588 4879 1945 4286 4782 1751 2952 3466 4923 3608 251 4067 +3877 3716 4107 2768 3797 4455 3691 34 3452 2876 3658 74 4668 1835 4343 1667 +3492 2669 2749 4886 2010 3994 4432 3335 3019 3632 2549 3571 1907 1732 4754 1842 +1653 1912 2660 2847 2609 1783 4010 4274 3887 4499 1639 4213 3416 5141 4712 3622 +3930 73 4660 2729 4124 3368 4315 4241 4878 3511 3835 4280 4562 4022 209 242 +3910 4061 3444 1899 1686 4930 2875 2019 3685 4090 4528 5088 3847 2499 4266 2519 +1793 4493 1630 4129 3018 3351 2777 1724 4704 1954 1769 3591 4285 2650 4870 3774 +4534 219 2659 4229 2866 1704 2027 4454 3408 2944 3448 2509 4071 4922 5096 4667 +1663 3870 3695 2748 1826 3790 4235 3388 4485 1854 3651 3496 1970 4016 1906 3471 +2478 1728 44 2857 3904 4885 3438 2009 4718 2548 3802 4221 2767 1695 241 4448 +3663 3841 2943 3412 1646 64 2776 3583 4659 4123 1944 3371 4240 1776 2668 1718 +72 4651 4047 2539 4279 2488 3711 4869 4102 3615 3563 3909 1962 2837 1898 4026 +4747 4877 3402 55 1890 4342 1816 4054 197 4492 4440 3627 2629 3851 1848 1620 +3587 2667 3465 2649 3827 2846 4673 3882 3554 4498 4309 3796 2865 2018 2758 3657 +3363 1834 4314 1666 63 2658 5087 3577 71 2529 4002 4234 4484 1853 2538 3343 +2639 4096 3903 1880 1760 4527 3475 2933 4009 1788 4447 2856 2738 3431 4212 4921 +33 3806 2017 3621 22 2942 2728 3367 3667 5086 4650 3782 3834 3710 2619 4101 230 +2836 3334 4453 3443 4066 3876 1711 2864 1953 2008 1889 1658 3690 4711 4868 2747 +2547 3357 2932 4439 3491 4746 3395 1638 1905 2766 4431 1847 1723 1768 3631 1750 +186 3607 3881 1961 1841 4308 3407 2508 1782 4876 1685 4273 2007 4122 2941 1662 +4703 2546 2528 1825 4278 3789 3993 2757 3650 1629 1897 2638 4095 4021 3570 43 +1943 3437 1879 4060 4666 2537 1652 2608 3684 1787 4491 229 4089 2737 3846 2765 +4265 2518 3582 1904 2657 240 1717 4046 2666 3614 4065 3875 2477 4228 3401 3689 +3447 4658 2845 1815 4233 4483 208 3869 3490 2931 2498 4430 4710 3902 3350 1896 +2656 4015 3826 3470 1727 3773 1840 4446 1703 1781 1952 3801 4272 4220 3362 3662 +3840 4867 3411 2006 4526 3576 4001 2648 2545 2855 1775 3387 2835 4020 4702 1619 +1888 4059 1759 3683 54 4088 4438 2930 3430 1694 3845 1951 4053 1846 4264 2517 +4665 1645 3626 4866 2628 2746 3781 3586 2756 2618 2487 3464 4307 62 3562 1710 +1942 4227 1657 3795 2536 239 3356 3656 1833 4649 3868 174 3394 2637 4094 4657 +2834 21 1878 4014 3469 1749 1887 185 196 3606 2736 61 3553 3800 1941 4008 4219 +3661 3839 207 2535 4211 3620 2727 3366 1774 4490 3992 2854 3833 3874 3342 4306 +3569 2647 3442 1651 53 2607 2527 4052 4429 32 3625 228 2844 2627 1722 1877 2655 +1767 4482 1839 3463 4701 1780 3333 4271 2735 3794 3406 2507 3655 1832 1661 4445 +2497 1824 2853 3788 1637 3349 3649 4058 2745 4648 42 3682 3436 4087 3772 218 +2755 1702 4007 4263 2516 60 1684 1940 4210 3619 3581 2726 2534 4437 3386 1716 +4045 3832 4656 1838 1628 4226 3613 195 3441 4270 3400 3867 1895 1693 1814 1644 +4013 2526 1721 1766 2843 2486 3825 2636 2754 4086 3561 4218 59 2646 3838 2476 +3405 4262 227 2506 3361 173 1773 217 3575 1823 4000 3787 3648 4225 41 4481 52 +3435 1758 4051 3866 3552 2645 2626 3429 3580 2842 3462 1715 4044 3780 4428 3341 +2617 3612 4647 3793 1618 4217 1709 3654 2744 1831 3399 1656 206 3355 1813 1772 +1886 31 3393 4436 3824 1748 51 4006 3332 3605 4646 4050 4209 3618 2725 3360 +2625 2833 3574 3999 3831 1885 2515 1636 3991 2525 20 3568 2743 1757 2635 1830 +1650 1876 2606 1683 3428 184 1765 2734 3779 1627 2616 2524 4005 2505 1708 1655 +4208 2634 1822 2724 3354 3786 1875 3647 3830 2496 3392 40 3348 3434 194 1747 +4427 3604 3771 2475 1701 2644 50 1714 4043 1764 2832 3990 3611 3385 216 3567 +3398 2504 4426 1812 1649 2605 1821 3785 1692 3646 1829 1643 3823 39 4261 2514 +2485 1617 3560 2523 3573 3998 2831 183 4042 2495 1874 3610 2723 3347 1756 2733 +2513 3770 1811 3427 1700 3551 3778 4216 2615 3822 3384 19 1707 3340 1763 172 +3353 2633 3997 3391 1691 215 1642 30 1820 1746 2732 3603 1755 2484 2624 3559 +3331 38 3426 3989 3777 2614 49 3566 1635 1706 4041 1648 2604 2623 2512 3550 +3390 1682 1810 1745 4207 3602 205 3339 1626 3821 2494 3988 3346 29 3565 3996 +3769 4206 171 1699 2603 193 3330 2474 1754 3383 2503 1634 48 3776 2613 1690 37 +182 2493 1641 1681 3345 2483 2502 3558 3768 1625 1698 1819 1616 1744 3601 3382 +47 3987 3549 2622 1689 2722 2473 1640 2602 3338 2482 3557 1809 18 28 1753 2492 +3329 2501 3548 2721 1615 204 3767 1697 1633 36 3337 3381 1680 1743 27 2612 1688 +1624 170 3328 17 1808 2481 3556 35 1632 2601 2472 1679 3986 3547 1623 192 203 +3336 3766 181 26 1614 2471 2491 3327 1742 1687 1631 2480 2611 1678 16 1613 180 +1622 191 3546 2490 2470 15 2600 25 3326 169 24 1612 2479 1677 1621 1676 14 168 +2469 2468 1611 23 1610 13 179 12 167 11 } diff --git a/extra/poker/authors.txt b/extra/poker/authors.txt new file mode 100644 index 0000000000..fbbb745b7d --- /dev/null +++ b/extra/poker/authors.txt @@ -0,0 +1 @@ +Aaron Schaefer \ No newline at end of file diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor new file mode 100644 index 0000000000..29bd3ce6b8 --- /dev/null +++ b/extra/poker/poker-tests.factor @@ -0,0 +1,16 @@ +USING: accessors poker poker.private tools.test ; +IN: poker.tests + +[ 134236965 ] [ "KD" >ckf ] unit-test +[ 529159 ] [ "5s" >ckf ] unit-test +[ 33589533 ] [ "jc" >ckf ] unit-test + + +[ 7462 ] [ "7C 5D 4H 3S 2C" value>> ] unit-test +[ 1601 ] [ "KD QS JC TH 9S" value>> ] unit-test +[ 9 ] [ "6C 5C 4C 3C 2C" value>> ] unit-test +[ 1 ] [ "AC KC QC JC TC" value>> ] unit-test + +[ "High Card" ] [ "7C 5D 4H 3S 2C" >value ] unit-test +[ "Straight" ] [ "KD QS JC TH 9S" >value ] unit-test +[ "Straight Flush" ] [ "6C 5C 4C 3C 2C" >value ] unit-test diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor new file mode 100644 index 0000000000..c903bcfcb3 --- /dev/null +++ b/extra/poker/poker.factor @@ -0,0 +1,179 @@ +! Copyright (c) 2009 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors ascii binary-search combinators kernel locals math + math.bitwise math.order poker.arrays sequences splitting ; +IN: poker + +! The algorithm used is based on Cactus Kev's Poker Hand Evaluator: +! http://www.suffecool.net/poker/evaluator.html + +ckf) ( rank suit -- n ) + rank rank suit rank card-bitfield ; + +: >ckf ( str -- n ) + #! Cactus Kev Format + >upper 1 cut (>ckf) ; + +: flush? ( cards -- ? ) + HEX: F000 [ bitand ] reduce 0 = not ; + +: rank-bits ( cards -- q ) + 0 [ bitor ] reduce -16 shift ; + +! Needs MEMO: to prevent unique5 lookup twice? +: lookup ( cards table -- value ) + [ rank-bits ] dip nth ; + +: unique5? ( cards -- ? ) + unique5-table lookup 0 > ; + +: prime-bits ( cards -- q ) + [ HEX: FF bitand ] map product ; + +: hand-value ( cards -- value ) + { + { [ dup flush? ] [ flushes-table lookup ] } + { [ dup unique5? ] [ unique5-table lookup ] } + [ + prime-bits products-table sorted-index + values-table nth + ] + } cond ; + +: >card-rank ( card -- str ) + -8 shift HEX: F bitand RANK_STR nth ; + +: >card-suit ( card -- str ) + { + { [ dup 15 bit? ] [ drop "C" ] } + { [ dup 14 bit? ] [ drop "D" ] } + { [ dup 13 bit? ] [ drop "H" ] } + [ drop "S" ] + } cond ; + +PRIVATE> + +TUPLE: hand + { cards sequence } + { value integer } ; + +M: hand <=> [ value>> ] compare ; +M: hand equal? + over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ; + +: ( str -- hand ) + " " split [ >ckf ] map + dup hand-value hand boa ; + +: hand-rank ( hand -- rank ) + value>> { + { [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card + { [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair + { [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair + { [ dup 1609 > ] [ drop THREE_OF_A_KIND ] } ! 858 three-kind + { [ dup 1599 > ] [ drop STRAIGHT ] } ! 10 straights + { [ dup 322 > ] [ drop FLUSH ] } ! 1277 flushes + { [ dup 166 > ] [ drop FULL_HOUSE ] } ! 156 full house + { [ dup 10 > ] [ drop FOUR_OF_A_KIND ] } ! 156 four-kind + [ drop STRAIGHT_FLUSH ] ! 10 straight-flushes + } cond ; + +: >value ( hand -- str ) + hand-rank VALUE_STR nth ; + +: >cards ( hand -- str ) + cards>> [ + [ >card-rank ] [ >card-suit ] bi append + ] map " " join ; diff --git a/extra/poker/summary.txt b/extra/poker/summary.txt new file mode 100644 index 0000000000..c8efe851c8 --- /dev/null +++ b/extra/poker/summary.txt @@ -0,0 +1 @@ +5-card poker hand evaluator From 1023fa51f4427c6a89b45fbeb87863939b9da703 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 4 Apr 2009 23:04:53 -0500 Subject: [PATCH 084/772] Fix mailbox-get-all, and make mailbox timeouts throw a wait-timeout error instead of a string --- basis/concurrency/conditions/conditions.factor | 4 +++- .../concurrency/mailboxes/mailboxes-tests.factor | 16 ++++++++++++++-- basis/concurrency/mailboxes/mailboxes.factor | 2 +- 3 files changed, 18 insertions(+), 4 deletions(-) diff --git a/basis/concurrency/conditions/conditions.factor b/basis/concurrency/conditions/conditions.factor index 11e624110c..ad00bbdfa9 100644 --- a/basis/concurrency/conditions/conditions.factor +++ b/basis/concurrency/conditions/conditions.factor @@ -20,10 +20,12 @@ IN: concurrency.conditions ] ] dip later ; +ERROR: wait-timeout ; + : wait ( queue timeout status -- ) over [ [ queue-timeout [ drop ] ] dip suspend - [ "Timeout" throw ] [ cancel-alarm ] if + [ wait-timeout ] [ cancel-alarm ] if ] [ [ drop '[ _ push-front ] ] dip suspend drop ] if ; diff --git a/basis/concurrency/mailboxes/mailboxes-tests.factor b/basis/concurrency/mailboxes/mailboxes-tests.factor index 64971eeb77..81e54f1807 100644 --- a/basis/concurrency/mailboxes/mailboxes-tests.factor +++ b/basis/concurrency/mailboxes/mailboxes-tests.factor @@ -1,6 +1,6 @@ IN: concurrency.mailboxes.tests -USING: concurrency.mailboxes concurrency.count-downs vectors -sequences threads tools.test math kernel strings namespaces +USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions +vectors sequences threads tools.test math kernel strings namespaces continuations calendar destructors ; { 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as @@ -75,3 +75,15 @@ continuations calendar destructors ; [ ] [ "d" get 5 seconds await-timeout ] unit-test [ ] [ "m" get dispose ] unit-test + +[ { "foo" "bar" } ] [ + + "foo" over mailbox-put + "bar" over mailbox-put + mailbox-get-all +] unit-test + +[ + 1 seconds mailbox-get-timeout +] [ wait-timeout? ] must-fail-with + \ No newline at end of file diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor index f6aec94b41..200adb14ae 100755 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -49,7 +49,7 @@ M: mailbox dispose* threads>> notify-all ; : mailbox-get-all-timeout ( mailbox timeout -- array ) block-if-empty - [ dup mailbox-empty? ] + [ dup mailbox-empty? not ] [ dup data>> pop-back ] produce nip ; From 52c74da3b79b9a79cc022d42bd29ebd96e116221 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 5 Apr 2009 00:07:48 -0400 Subject: [PATCH 085/772] Fix documentation typo for search-index word --- basis/binary-search/binary-search-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/binary-search/binary-search-docs.factor b/basis/binary-search/binary-search-docs.factor index cf7915159a..20b33a0bcb 100644 --- a/basis/binary-search/binary-search-docs.factor +++ b/basis/binary-search/binary-search-docs.factor @@ -14,7 +14,7 @@ $nl HELP: sorted-index { $values { "obj" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } } -{ $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." } +{ $description "Outputs the index of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." } { $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ; { index index-from last-index last-index-from sorted-index } related-words From 9a8270a43a22d2cb1fab51ac27492abda4cd45fb Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sun, 5 Apr 2009 20:11:35 +0200 Subject: [PATCH 086/772] some renaming now adding an advice for marking a tuple dirty --- bson/writer/writer.factor | 5 +- mongodb/tuple/persistent/persistent.factor | 68 +++++++++++++++------- mongodb/tuple/state/state.factor | 39 ++++++++++--- mongodb/tuple/tuple.factor | 9 ++- 4 files changed, 87 insertions(+), 34 deletions(-) diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 2b1fc54537..4ad1d7fdcc 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -4,7 +4,7 @@ USING: accessors assocs bson.constants byte-arrays byte-vectors calendar fry io io.binary io.encodings io.encodings.binary io.encodings.utf8 io.streams.byte-array kernel math math.parser namespaces quotations sequences sequences.private serialize strings -words ; +words combinators.short-circuit ; IN: bson.writer @@ -164,3 +164,6 @@ PRIVATE> : assoc>stream ( assoc -- ) bson-write ; inline +: mdb-special-value? ( value -- ? ) + { [ timestamp? ] [ quotation? ] [ mdbregexp? ] + [ oid? ] [ byte-array? ] } 1|| ; \ No newline at end of file diff --git a/mongodb/tuple/persistent/persistent.factor b/mongodb/tuple/persistent/persistent.factor index 6d5e1837a7..329d9cb0c7 100644 --- a/mongodb/tuple/persistent/persistent.factor +++ b/mongodb/tuple/persistent/persistent.factor @@ -1,10 +1,11 @@ -USING: accessors assocs classes fry kernel linked-assocs math mirrors -namespaces sequences strings vectors words bson.constants -continuations mongodb.driver mongodb.tuple.collection mongodb.tuple.state ; +USING: accessors assocs bson.constants combinators.short-circuit +constructors continuations fry kernel mirrors mongodb.tuple.collection +mongodb.tuple.state namespaces sequences words bson.writer combinators +hashtables linked-assocs ; IN: mongodb.tuple.persistent -SYMBOL: mdb-store-list +SYMBOLS: object-map ; GENERIC: tuple>assoc ( tuple -- assoc ) @@ -15,7 +16,7 @@ DEFER: assoc>tuple tuple-class ( tuple-info -- class ) - [ first ] keep second lookup ; inline + [ first ] keep second lookup ; inline : tuple-instance ( tuple-info -- instance ) mdbinfo>tuple-class new ; inline @@ -27,7 +28,7 @@ DEFER: assoc>tuple : make-tuple ( assoc -- tuple ) prepare-assoc>tuple '[ dup _ at assoc>tuple swap _ set-at ] each - [ set-persistent ] keep ; inline recursive + [ mark-persistent ] keep ; inline recursive : at+ ( value key assoc -- value ) 2dup key? @@ -38,21 +39,43 @@ DEFER: assoc>tuple [ assoc? not ] [ drop f ] if ; inline : add-storable ( assoc ns -- ) - [ H{ } clone ] dip mdb-store-list get at+ + [ H{ } clone ] dip object-map get at+ [ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline : write-field? ( tuple key value -- ? ) - [ [ 2drop ] dip not ] [ drop transient-slot? ] 3bi or not ; inline + pick mdb-persistent? [ + { [ [ 2drop ] dip not ] + [ drop transient-slot? ] } 3|| not ] [ 3drop t ] if ; inline + +TUPLE: cond-value value quot ; + +CONSTRUCTOR: cond-value ( value quot -- cond-value ) ; + +: write-mdb-persistent ( value quot: ( tuple -- assoc ) -- value' ) + over needs-store? + [ over [ (( tuple -- assoc )) call-effect ] dip + [ tuple-collection name>> ] keep + [ add-storable ] dip + ] [ drop ] if + [ tuple-collection name>> ] [ _id>> ] bi ; inline + +: write-field ( value quot: ( tuple -- assoc ) -- value' ) + { + { [ dup value>> mdb-special-value? ] [ value>> ] } + { [ dup value>> mdb-persistent? ] + [ [ value>> ] [ quot>> ] bi write-mdb-persistent ] } + { [ dup value>> data-tuple? ] + [ [ value>> ] [ quot>> ] bi (( tuple -- assoc )) call-effect ] } + { [ dup value>> [ hashtable? ] [ linked-assoc? ] bi or ] + [ [ value>> ] [ quot>> ] bi '[ _ write-field ] assoc-map ] } + [ value>> ] + } cond ; inline recursive : write-tuple-fields ( mirror tuple assoc quot: ( tuple -- assoc ) -- ) - swap dupd ! m t q q a + swap ! m t q q a '[ _ 2over write-field? - [ dup mdb-persistent? - [ _ keep - [ tuple-collection ] keep - [ add-storable ] dip - [ tuple-collection ] [ _id>> ] bi ] - [ dup data-tuple? _ [ ] if ] if swap _ set-at ] [ 2drop ] if + [ _ write-field swap _ set-at ] + [ 2drop ] if ] assoc-each ; : prepare-assoc ( tuple -- assoc mirror tuple assoc ) @@ -60,20 +83,21 @@ DEFER: assoc>tuple : ensure-mdb-info ( tuple -- tuple ) dup _id>> [ >>_id ] unless - [ set-persistent ] keep ; inline + [ mark-persistent ] keep ; inline -: with-store-list ( quot: ( -- ) -- store-assoc ) - [ H{ } clone dup mdb-store-list ] dip with-variable ; inline +: with-object-map ( quot: ( -- ) -- store-assoc ) + [ H{ } clone dup object-map ] dip with-variable ; inline : (tuple>assoc) ( tuple -- assoc ) [ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep - over set-tuple-info ; + over set-tuple-info ; inline PRIVATE> -GENERIC: tuple>storable ( tuple -- storable ) -M: mdb-persistent tuple>storable ( mdb-persistent -- store-list ) - '[ _ [ tuple>assoc ] keep tuple-collection add-storable ] with-store-list ; inline +GENERIC: tuple>storable ( tuple -- storable ) + +M: mdb-persistent tuple>storable ( mdb-persistent -- object-map ) + '[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; inline M: mdb-persistent tuple>assoc ( tuple -- assoc ) ensure-mdb-info (tuple>assoc) ; diff --git a/mongodb/tuple/state/state.factor b/mongodb/tuple/state/state.factor index e0e045e31d..ace7b16c8f 100644 --- a/mongodb/tuple/state/state.factor +++ b/mongodb/tuple/state/state.factor @@ -1,4 +1,5 @@ -USING: classes kernel accessors sequences assocs mongodb.tuple.collection ; +USING: classes kernel accessors sequences fry assocs mongodb.tuple.collection +advice words classes.tuple slots ; IN: mongodb.tuple.state @@ -7,9 +8,13 @@ IN: mongodb.tuple.state CONSTANT: MDB_TUPLE_INFO "_mfd_t_info" CONSTANT: MDB_DIRTY_FLAG "d?" CONSTANT: MDB_PERSISTENT_FLAG "p?" +CONSTANT: MDB_DIRTY_ADVICE "mdb-dirty-set" PRIVATE> +: advised-with? ( name word loc -- ? ) + word-prop key? ; inline + : ( tuple -- tuple-info ) class V{ } clone tuck [ [ name>> ] dip push ] @@ -28,17 +33,35 @@ PRIVATE> dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline : dirty? ( tuple -- ? ) - MDB_DIRTY_FLAG tuple-meta at ; + [ MDB_DIRTY_FLAG ] dip tuple-meta at ; -: set-dirty ( tuple -- ) - [ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ; +: mark-dirty ( tuple -- ) + [ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ; : persistent? ( tuple -- ? ) - MDB_PERSISTENT_FLAG tuple-meta at ; + [ MDB_PERSISTENT_FLAG ] dip tuple-meta at ; -: set-persistent ( tuple -- ) - [ t MDB_PERSISTENT_FLAG ] dip tuple-meta set-at ; +: mark-persistent ( tuple -- ) + [ t MDB_PERSISTENT_FLAG ] dip tuple-meta [ set-at ] keep + [ f MDB_DIRTY_FLAG ] dip set-at ; : needs-store? ( tuple -- ? ) - [ persistent? not ] [ dirty? ] bi or ; + [ persistent? not ] [ dirty? ] bi or ; + + +: annotate-writers ( class -- ) + dup all-slots [ name>> ] map + MDB_ADDON_SLOTS '[ _ memq? not ] filter + [ (annotate-writer) ] with each ; \ No newline at end of file diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor index 089a3ec121..f99e32aaf1 100644 --- a/mongodb/tuple/tuple.factor +++ b/mongodb/tuple/tuple.factor @@ -1,7 +1,7 @@ USING: accessors assocs classes.mixin classes.tuple -classes.tuple.parser compiler.units fry kernel mongodb.driver +classes.tuple.parser compiler.units fry kernel sequences mongodb.driver mongodb.msg mongodb.tuple.collection mongodb.tuple.index -mongodb.tuple.persistent mongodb.tuple.state sequences strings ; +mongodb.tuple.persistent mongodb.tuple.state strings ; IN: mongodb.tuple @@ -13,7 +13,8 @@ SYNTAX: MDBTUPLE: : define-persistent ( class collection options -- ) [ ] dip [ [ dup ] dip link-collection ] dip ! cl options - [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip + [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip + [ dup annotate-writers ] dip set-slot-map ; : ensure-table ( class -- ) @@ -39,8 +40,10 @@ SYNTAX: MDBTUPLE: > id-selector ; From 469c3c05ec1703363b6fab3180200f92ed2941ce Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 5 Apr 2009 15:32:36 -0400 Subject: [PATCH 087/772] Speed up map product in poker vocab --- extra/poker/poker.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index c903bcfcb3..172bb49506 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -112,15 +112,17 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" : rank-bits ( cards -- q ) 0 [ bitor ] reduce -16 shift ; -! Needs MEMO: to prevent unique5 lookup twice? : lookup ( cards table -- value ) [ rank-bits ] dip nth ; : unique5? ( cards -- ? ) unique5-table lookup 0 > ; +: map-product ( seq quot -- n ) + [ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline + : prime-bits ( cards -- q ) - [ HEX: FF bitand ] map product ; + [ HEX: FF bitand ] map-product ; : hand-value ( cards -- value ) { From 8fdc852038bb1aa6631197e2b8dbdf0f53619c56 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 5 Apr 2009 15:37:03 -0400 Subject: [PATCH 088/772] Solution to Project Euler problem 54 --- extra/project-euler/054/054-tests.factor | 4 + extra/project-euler/054/054.factor | 87 ++ extra/project-euler/054/poker.txt | 1000 ++++++++++++++++++++++ extra/project-euler/project-euler.factor | 18 +- 4 files changed, 1100 insertions(+), 9 deletions(-) create mode 100644 extra/project-euler/054/054-tests.factor create mode 100644 extra/project-euler/054/054.factor create mode 100644 extra/project-euler/054/poker.txt diff --git a/extra/project-euler/054/054-tests.factor b/extra/project-euler/054/054-tests.factor new file mode 100644 index 0000000000..31e915c70c --- /dev/null +++ b/extra/project-euler/054/054-tests.factor @@ -0,0 +1,4 @@ +USING: project-euler.054 tools.test ; +IN: project-euler.054.tests + +[ 376 ] [ euler054 ] unit-test diff --git a/extra/project-euler/054/054.factor b/extra/project-euler/054/054.factor new file mode 100644 index 0000000000..2e7eaa4cd3 --- /dev/null +++ b/extra/project-euler/054/054.factor @@ -0,0 +1,87 @@ +! Copyright (c) 2009 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays io.encodings.ascii io.files kernel math.order poker + project-euler.common sequences ; +IN: project-euler.054 + +! http://projecteuler.net/index.php?section=problems&id=54 + +! DESCRIPTION +! ----------- + +! In the card game poker, a hand consists of five cards and are ranked, from +! lowest to highest, in the following way: + +! * High Card: Highest value card. +! * One Pair: Two cards of the same value. +! * Two Pairs: Two different pairs. +! * Three of a Kind: Three cards of the same value. +! * Straight: All cards are consecutive values. +! * Flush: All cards of the same suit. +! * Full House: Three of a kind and a pair. +! * Four of a Kind: Four cards of the same value. +! * Straight Flush: All cards are consecutive values of same suit. +! * Royal Flush: Ten, Jack, Queen, King, Ace, in same suit. + +! The cards are valued in the order: +! 2, 3, 4, 5, 6, 7, 8, 9, 10, Jack, Queen, King, Ace. + +! If two players have the same ranked hands then the rank made up of the +! highest value wins; for example, a pair of eights beats a pair of fives (see +! example 1 below). But if two ranks tie, for example, both players have a pair +! of queens, then highest cards in each hand are compared (see example 4 +! below); if the highest cards tie then the next highest cards are compared, +! and so on. + +! Consider the following five hands dealt to two players: + +! Hand Player 1 Player 2 Winner +! --------------------------------------------------------- +! 1 5H 5C 6S 7S KD 2C 3S 8S 8D TD +! Pair of Fives Pair of Eights Player 2 + +! 2 5D 8C 9S JS AC 2C 5C 7D 8S QH +! Highest card Ace Highest card Queen Player 1 + +! 3 2D 9C AS AH AC 3D 6D 7D TD QD +! Three Aces Flush with Diamonds Player 2 + +! 4 4D 6S 9H QH QC 3D 6D 7H QD QS +! Pair of Queens Pair of Queens +! Highest card Nine Highest card Seven Player 1 + +! 5 2H 2D 4C 4D 4S 3C 3D 3S 9S 9D +! Full House Full House +! With Three Fours With Three Threes Player 1 + +! The file, poker.txt, contains one-thousand random hands dealt to two players. +! Each line of the file contains ten cards (separated by a single space): the +! first five are Player 1's cards and the last five are Player 2's cards. You +! can assume that all hands are valid (no invalid characters or repeated +! cards), each player's hand is in no specific order, and in each hand there is +! a clear winner. + +! How many hands does Player 1 win? + + +! SOLUTION +! -------- + + + +: euler054 ( -- answer ) + source-054 [ [ ] map first2 player1-win? ] count ; + +! [ euler054 ] 100 ave-time +! 36 ms ave run time - 2.71 SD (100 trials) + +SOLUTION: euler054 diff --git a/extra/project-euler/054/poker.txt b/extra/project-euler/054/poker.txt new file mode 100644 index 0000000000..231e249533 --- /dev/null +++ b/extra/project-euler/054/poker.txt @@ -0,0 +1,1000 @@ +8C TS KC 9H 4S 7D 2S 5D 3S AC +5C AD 5D AC 9C 7C 5H 8D TD KS +3H 7H 6S KC JS QH TD JC 2D 8S +TH 8H 5C QS TC 9H 4D JC KS JS +7C 5H KC QH JD AS KH 4C AD 4S +5H KS 9C 7D 9H 8D 3S 5D 5C AH +6H 4H 5C 3H 2H 3S QH 5S 6S AS +TD 8C 4H 7C TC KC 4C 3H 7S KS +7C 9C 6D KD 3H 4C QS QC AC KH +JC 6S 5H 2H 2D KD 9D 7C AS JS +AD QH TH 9D 8H TS 6D 3S AS AC +2H 4S 5C 5S TC KC JD 6C TS 3C +QD AS 6H JS 2C 3D 9H KC 4H 8S +KD 8S 9S 7C 2S 3S 6D 6S 4H KC +3C 8C 2D 7D 4D 9S 4S QH 4H JD +8C KC 7S TC 2D TS 8H QD AC 5C +3D KH QD 6C 6S AD AS 8H 2H QS +6S 8D 4C 8S 6C QH TC 6D 7D 9D +2S 8D 8C 4C TS 9S 9D 9C AC 3D +3C QS 2S 4H JH 3D 2D TD 8S 9H +5H QS 8S 6D 3C 8C JD AS 7H 7D +6H TD 9D AS JH 6C QC 9S KD JC +AH 8S QS 4D TH AC TS 3C 3D 5C +5S 4D JS 3D 8H 6C TS 3S AD 8C +6D 7C 5D 5H 3S 5C JC 2H 5S 3D +5H 6H 2S KS 3D 5D JD 7H JS 8H +KH 4H AS JS QS QC TC 6D 7C KS +3D QS TS 2H JS 4D AS 9S JC KD +QD 5H 4D 5D KH 7H 3D JS KD 4H +2C 9H 6H 5C 9D 6C JC 2D TH 9S +7D 6D AS QD JH 4D JS 7C QS 5C +3H KH QD AD 8C 8H 3S TH 9D 5S +AH 9S 4D 9D 8S 4H JS 3C TC 8D +2C KS 5H QD 3S TS 9H AH AD 8S +5C 7H 5D KD 9H 4D 3D 2D KS AD +KS KC 9S 6D 2C QH 9D 9H TS TC +9C 6H 5D QH 4D AD 6D QC JS KH +9S 3H 9D JD 5C 4D 9H AS TC QH +2C 6D JC 9C 3C AD 9S KH 9D 7D +KC 9C 7C JC JS KD 3H AS 3C 7D +QD KH QS 2C 3S 8S 8H 9H 9C JC +QH 8D 3C KC 4C 4H 6D AD 9H 9D +3S KS QS 7H KH 7D 5H 5D JD AD +2H 2C 6H TH TC 7D 8D 4H 8C AS +4S 2H AC QC 3S 6D TH 4D 4C KH +4D TC KS AS 7C 3C 6D 2D 9H 6C +8C TD 5D QS 2C 7H 4C 9C 3H 9H +5H JH TS 7S TD 6H AD QD 8H 8S +5S AD 9C 8C 7C 8D 5H 9D 8S 2S +4H KH KS 9S 2S KC 5S AD 4S 7D +QS 9C QD 6H JS 5D AC 8D 2S AS +KH AC JC 3S 9D 9S 3C 9C 5S JS +AD 3C 3D KS 3S 5C 9C 8C TS 4S +JH 8D 5D 6H KD QS QD 3D 6C KC +8S JD 6C 3S 8C TC QC 3C QH JS +KC JC 8H 2S 9H 9C JH 8S 8C 9S +8S 2H QH 4D QC 9D KC AS TH 3C +8S 6H TH 7C 2H 6S 3C 3H AS 7S +QH 5S JS 4H 5H TS 8H AH AC JC +9D 8H 2S 4S TC JC 3C 7H 3H 5C +3D AD 3C 3S 4C QC AS 5D TH 8C +6S 9D 4C JS KH AH TS JD 8H AD +4C 6S 9D 7S AC 4D 3D 3S TC JD +AD 7H 6H 4H JH KC TD TS 7D 6S +8H JH TC 3S 8D 8C 9S 2C 5C 4D +2C 9D KC QH TH QS JC 9C 4H TS +QS 3C QD 8H KH 4H 8D TD 8S AC +7C 3C TH 5S 8H 8C 9C JD TC KD +QC TC JD TS 8C 3H 6H KD 7C TD +JH QS KS 9C 6D 6S AS 9H KH 6H +2H 4D AH 2D JH 6H TD 5D 4H JD +KD 8C 9S JH QD JS 2C QS 5C 7C +4S TC 7H 8D 2S 6H 7S 9C 7C KC +8C 5D 7H 4S TD QC 8S JS 4H KS +AD 8S JH 6D TD KD 7C 6C 2D 7D +JC 6H 6S JS 4H QH 9H AH 4C 3C +6H 5H AS 7C 7S 3D KH KC 5D 5C +JC 3D TD AS 4D 6D 6S QH JD KS +8C 7S 8S QH 2S JD 5C 7H AH QD +8S 3C 6H 6C 2C 8D TD 7D 4C 4D +5D QH KH 7C 2S 7H JS 6D QC QD +AD 6C 6S 7D TH 6H 2H 8H KH 4H +KS JS KD 5D 2D KH 7D 9C 8C 3D +9C 6D QD 3C KS 3S 7S AH JD 2D +AH QH AS JC 8S 8H 4C KC TH 7D +JC 5H TD 7C 5D KD 4C AD 8H JS +KC 2H AC AH 7D JH KH 5D 7S 6D +9S 5S 9C 6H 8S TD JD 9H 6C AC +7D 8S 6D TS KD 7H AC 5S 7C 5D +AH QC JC 4C TC 8C 2H TS 2C 7D +KD KC 6S 3D 7D 2S 8S 3H 5S 5C +8S 5D 8H 4C 6H KC 3H 7C 5S KD +JH 8C 3D 3C 6C KC TD 7H 7C 4C +JC KC 6H TS QS TD KS 8H 8C 9S +6C 5S 9C QH 7D AH KS KC 9S 2C +4D 4S 8H TD 9C 3S 7D 9D AS TH +6S 7D 3C 6H 5D KD 2C 5C 9D 9C +2H KC 3D AD 3H QD QS 8D JC 4S +8C 3H 9C 7C AD 5D JC 9D JS AS +5D 9H 5C 7H 6S 6C QC JC QD 9S +JC QS JH 2C 6S 9C QC 3D 4S TC +4H 5S 8D 3D 4D 2S KC 2H JS 2C +TD 3S TH KD 4D 7H JH JS KS AC +7S 8C 9S 2D 8S 7D 5C AD 9D AS +8C 7H 2S 6C TH 3H 4C 3S 8H AC +KD 5H JC 8H JD 2D 4H TD JH 5C +3D AS QH KS 7H JD 8S 5S 6D 5H +9S 6S TC QS JC 5C 5D 9C TH 8C +5H 3S JH 9H 2S 2C 6S 7S AS KS +8C QD JC QS TC QC 4H AC KH 6C +TC 5H 7D JH 4H 2H 8D JC KS 4D +5S 9C KH KD 9H 5C TS 3D 7D 2D +5H AS TC 4D 8C 2C TS 9D 3H 8D +6H 8D 2D 9H JD 6C 4S 5H 5S 6D +AD 9C JC 7D 6H 9S 6D JS 9H 3C +AD JH TC QS 4C 5D 9S 7C 9C AH +KD 6H 2H TH 8S QD KS 9D 9H AS +4H 8H 8D 5H 6C AH 5S AS AD 8S +QS 5D 4S 2H TD KS 5H AC 3H JC +9C 7D QD KD AC 6D 5H QH 6H 5S +KC AH QH 2H 7D QS 3H KS 7S JD +6C 8S 3H 6D KS QD 5D 5C 8H TC +9H 4D 4S 6S 9D KH QC 4H 6C JD +TD 2D QH 4S 6H JH KD 3C QD 8C +4S 6H 7C QD 9D AS AH 6S AD 3C +2C KC TH 6H 8D AH 5C 6D 8S 5D +TD TS 7C AD JC QD 9H 3C KC 7H +5D 4D 5S 8H 4H 7D 3H JD KD 2D +JH TD 6H QS 4S KD 5C 8S 7D 8H +AC 3D AS 8C TD 7H KH 5D 6C JD +9D KS 7C 6D QH TC JD KD AS KC +JH 8S 5S 7S 7D AS 2D 3D AD 2H +2H 5D AS 3C QD KC 6H 9H 9S 2C +9D 5D TH 4C JH 3H 8D TC 8H 9H +6H KD 2C TD 2H 6C 9D 2D JS 8C +KD 7S 3C 7C AS QH TS AD 8C 2S +QS 8H 6C JS 4C 9S QC AD TD TS +2H 7C TS TC 8C 3C 9H 2D 6D JC +TC 2H 8D JH KS 6D 3H TD TH 8H +9D TD 9H QC 5D 6C 8H 8C KC TS +2H 8C 3D AH 4D TH TC 7D 8H KC +TS 5C 2D 8C 6S KH AH 5H 6H KC +5S 5D AH TC 4C JD 8D 6H 8C 6C +KC QD 3D 8H 2D JC 9H 4H AD 2S +TD 6S 7D JS KD 4H QS 2S 3S 8C +4C 9H JH TS 3S 4H QC 5S 9S 9C +2C KD 9H JS 9S 3H JC TS 5D AC +AS 2H 5D AD 5H JC 7S TD JS 4C +2D 4S 8H 3D 7D 2C AD KD 9C TS +7H QD JH 5H JS AC 3D TH 4C 8H +6D KH KC QD 5C AD 7C 2D 4H AC +3D 9D TC 8S QD 2C JC 4H JD AH +6C TD 5S TC 8S AH 2C 5D AS AC +TH 7S 3D AS 6C 4C 7H 7D 4H AH +5C 2H KS 6H 7S 4H 5H 3D 3C 7H +3C 9S AC 7S QH 2H 3D 6S 3S 3H +2D 3H AS 2C 6H TC JS 6S 9C 6C +QH KD QD 6D AC 6H KH 2C TS 8C +8H 7D 3S 9H 5D 3H 4S QC 9S 5H +2D 9D 7H 6H 3C 8S 5H 4D 3S 4S +KD 9S 4S TC 7S QC 3S 8S 2H 7H +TC 3D 8C 3H 6C 2H 6H KS KD 4D +KC 3D 9S 3H JS 4S 8H 2D 6C 8S +6H QS 6C TC QD 9H 7D 7C 5H 4D +TD 9D 8D 6S 6C TC 5D TS JS 8H +4H KC JD 9H TC 2C 6S 5H 8H AS +JS 9C 5C 6S 9D JD 8H KC 4C 6D +4D 8D 8S 6C 7C 6H 7H 8H 5C KC +TC 3D JC 6D KS 9S 6H 7S 9C 2C +6C 3S KD 5H TS 7D 9H 9S 6H KH +3D QD 4C 6H TS AC 3S 5C 2H KD +4C AS JS 9S 7C TS 7H 9H JC KS +4H 8C JD 3H 6H AD 9S 4S 5S KS +4C 2C 7D 3D AS 9C 2S QS KC 6C +8S 5H 3D 2S AC 9D 6S 3S 4D TD +QD TH 7S TS 3D AC 7H 6C 5D QC +TC QD AD 9C QS 5C 8D KD 3D 3C +9D 8H AS 3S 7C 8S JD 2D 8D KC +4C TH AC QH JS 8D 7D 7S 9C KH +9D 8D 4C JH 2C 2S QD KD TS 4H +4D 6D 5D 2D JH 3S 8S 3H TC KH +AD 4D 2C QS 8C KD JH JD AH 5C +5C 6C 5H 2H JH 4H KS 7C TC 3H +3C 4C QC 5D JH 9C QD KH 8D TC +3H 9C JS 7H QH AS 7C 9H 5H JC +2D 5S QD 4S 3C KC 6S 6C 5C 4C +5D KH 2D TS 8S 9C AS 9S 7C 4C +7C AH 8C 8D 5S KD QH QS JH 2C +8C 9D AH 2H AC QC 5S 8H 7H 2C +QD 9H 5S QS QC 9C 5H JC TH 4H +6C 6S 3H 5H 3S 6H KS 8D AC 7S +AC QH 7H 8C 4S KC 6C 3D 3S TC +9D 3D JS TH AC 5H 3H 8S 3S TC +QD KH JS KS 9S QC 8D AH 3C AC +5H 6C KH 3S 9S JH 2D QD AS 8C +6C 4D 7S 7H 5S JC 6S 9H 4H JH +AH 5S 6H 9S AD 3S TH 2H 9D 8C +4C 8D 9H 7C QC AD 4S 9C KC 5S +9D 6H 4D TC 4C JH 2S 5D 3S AS +2H 6C 7C KH 5C AD QS TH JD 8S +3S 4S 7S AH AS KC JS 2S AD TH +JS KC 2S 7D 8C 5C 9C TS 5H 9D +7S 9S 4D TD JH JS KH 6H 5D 2C +JD JS JC TH 2D 3D QD 8C AC 5H +7S KH 5S 9D 5D TD 4S 6H 3C 2D +4S 5D AC 8D 4D 7C AD AS AH 9C +6S TH TS KS 2C QC AH AS 3C 4S +2H 8C 3S JC 5C 7C 3H 3C KH JH +7S 3H JC 5S 6H 4C 2S 4D KC 7H +4D 7C 4H 9S 8S 6S AD TC 6C JC +KH QS 3S TC 4C 8H 8S AC 3C TS +QD QS TH 3C TS 7H 7D AH TD JC +TD JD QC 4D 9S 7S TS AD 7D AC +AH 7H 4S 6D 7C 2H 9D KS JC TD +7C AH JD 4H 6D QS TS 2H 2C 5C +TC KC 8C 9S 4C JS 3C JC 6S AH +AS 7D QC 3D 5S JC JD 9D TD KH +TH 3C 2S 6H AH AC 5H 5C 7S 8H +QC 2D AC QD 2S 3S JD QS 6S 8H +KC 4H 3C 9D JS 6H 3S 8S AS 8C +7H KC 7D JD 2H JC QH 5S 3H QS +9H TD 3S 8H 7S AC 5C 6C AH 7C +8D 9H AH JD TD QS 7D 3S 9C 8S +AH QH 3C JD KC 4S 5S 5D TD KS +9H 7H 6S JH TH 4C 7C AD 5C 2D +7C KD 5S TC 9D 6S 6C 5D 2S TH +KC 9H 8D 5H 7H 4H QC 3D 7C AS +6S 8S QC TD 4S 5C TH QS QD 2S +8S 5H TH QC 9H 6S KC 7D 7C 5C +7H KD AH 4D KH 5C 4S 2D KC QH +6S 2C TD JC AS 4D 6C 8C 4H 5S +JC TC JD 5S 6S 8D AS 9D AD 3S +6D 6H 5D 5S TC 3D 7D QS 9D QD +4S 6C 8S 3S 7S AD KS 2D 7D 7C +KC QH JC AC QD 5D 8D QS 7H 7D +JS AH 8S 5H 3D TD 3H 4S 6C JH +4S QS 7D AS 9H JS KS 6D TC 5C +2D 5C 6H TC 4D QH 3D 9H 8S 6C +6D 7H TC TH 5S JD 5C 9C KS KD +8D TD QH 6S 4S 6C 8S KC 5C TC +5S 3D KS AC 4S 7D QD 4C TH 2S +TS 8H 9S 6S 7S QH 3C AH 7H 8C +4C 8C TS JS QC 3D 7D 5D 7S JH +8S 7S 9D QC AC 7C 6D 2H JH KC +JS KD 3C 6S 4S 7C AH QC KS 5H +KS 6S 4H JD QS TC 8H KC 6H AS +KH 7C TC 6S TD JC 5C 7D AH 3S +3H 4C 4H TC TH 6S 7H 6D 9C QH +7D 5H 4S 8C JS 4D 3D 8S QH KC +3H 6S AD 7H 3S QC 8S 4S 7S JS +3S JD KH TH 6H QS 9C 6C 2D QD +4S QH 4D 5H KC 7D 6D 8D TH 5S +TD AD 6S 7H KD KH 9H 5S KC JC +3H QC AS TS 4S QD KS 9C 7S KC +TS 6S QC 6C TH TC 9D 5C 5D KD +JS 3S 4H KD 4C QD 6D 9S JC 9D +8S JS 6D 4H JH 6H 6S 6C KS KH +AC 7D 5D TC 9S KH 6S QD 6H AS +AS 7H 6D QH 8D TH 2S KH 5C 5H +4C 7C 3D QC TC 4S KH 8C 2D JS +6H 5D 7S 5H 9C 9H JH 8S TH 7H +AS JS 2S QD KH 8H 4S AC 8D 8S +3H 4C TD KD 8C JC 5C QS 2D JD +TS 7D 5D 6C 2C QS 2H 3C AH KS +4S 7C 9C 7D JH 6C 5C 8H 9D QD +2S TD 7S 6D 9C 9S QS KH QH 5C +JC 6S 9C QH JH 8D 7S JS KH 2H +8D 5H TH KC 4D 4S 3S 6S 3D QS +2D JD 4C TD 7C 6D TH 7S JC AH +QS 7S 4C TH 9D TS AD 4D 3H 6H +2D 3H 7D JD 3D AS 2S 9C QC 8S +4H 9H 9C 2C 7S JH KD 5C 5D 6H +TC 9H 8H JC 3C 9S 8D KS AD KC +TS 5H JD QS QH QC 8D 5D KH AH +5D AS 8S 6S 4C AH QC QD TH 7H +3H 4H 7D 6S 4S 9H AS 8H JS 9D +JD 8C 2C 9D 7D 5H 5S 9S JC KD +KD 9C 4S QD AH 7C AD 9D AC TD +6S 4H 4S 9C 8D KS TC 9D JH 7C +5S JC 5H 4S QH AC 2C JS 2S 9S +8C 5H AS QD AD 5C 7D 8S QC TD +JC 4C 8D 5C KH QS 4D 6H 2H 2C +TH 4S 2D KC 3H QD AC 7H AD 9D +KH QD AS 8H TH KC 8D 7S QH 8C +JC 6C 7D 8C KH AD QS 2H 6S 2D +JC KH 2D 7D JS QC 5H 4C 5D AD +TS 3S AD 4S TD 2D TH 6S 9H JH +9H 2D QS 2C 4S 3D KH AS AC 9D +KH 6S 8H 4S KD 7D 9D TS QD QC +JH 5H AH KS AS AD JC QC 5S KH +5D 7D 6D KS KD 3D 7C 4D JD 3S +AC JS 8D 5H 9C 3H 4H 4D TS 2C +6H KS KH 9D 7C 2S 6S 8S 2H 3D +6H AC JS 7S 3S TD 8H 3H 4H TH +9H TC QC KC 5C KS 6H 4H AC 8S +TC 7D QH 4S JC TS 6D 6C AC KH +QH 7D 7C JH QS QD TH 3H 5D KS +3D 5S 8D JS 4C 2C KS 7H 9C 4H +5H 8S 4H TD 2C 3S QD QC 3H KC +QC JS KD 9C AD 5S 9D 7D 7H TS +8C JC KH 7C 7S 6C TS 2C QD TH +5S 9D TH 3C 7S QH 8S 9C 2H 5H +5D 9H 6H 2S JS KH 3H 7C 2H 5S +JD 5D 5S 2C TC 2S 6S 6C 3C 8S +4D KH 8H 4H 2D KS 3H 5C 2S 9H +3S 2D TD 7H 8S 6H JD KC 9C 8D +6S QD JH 7C 9H 5H 8S 8H TH TD +QS 7S TD 7D TS JC KD 7C 3C 2C +3C JD 8S 4H 2D 2S TD AS 4D AC +AH KS 6C 4C 4S 7D 8C 9H 6H AS +5S 3C 9S 2C QS KD 4D 4S AC 5D +2D TS 2C JS KH QH 5D 8C AS KC +KD 3H 6C TH 8S 7S KH 6H 9S AC +6H 7S 6C QS AH 2S 2H 4H 5D 5H +5H JC QD 2C 2S JD AS QC 6S 7D +6C TC AS KD 8H 9D 2C 7D JH 9S +2H 4C 6C AH 8S TD 3H TH 7C TS +KD 4S TS 6C QH 8D 9D 9C AH 7D +6D JS 5C QD QC 9C 5D 8C 2H KD +3C QH JH AD 6S AH KC 8S 6D 6H +3D 7C 4C 7S 5S 3S 6S 5H JC 3C +QH 7C 5H 3C 3S 8C TS 4C KD 9C +QD 3S 7S 5H 7H QH JC 7C 8C KD +3C KD KH 2S 4C TS AC 6S 2C 7C +2C KH 3C 4C 6H 4D 5H 5S 7S QD +4D 7C 8S QD TS 9D KS 6H KD 3C +QS 4D TS 7S 4C 3H QD 8D 9S TC +TS QH AC 6S 3C 9H 9D QS 8S 6H +3S 7S 5D 4S JS 2D 6C QH 6S TH +4C 4H AS JS 5D 3D TS 9C AC 8S +6S 9C 7C 3S 5C QS AD AS 6H 3C +9S 8C 7H 3H 6S 7C AS 9H JD KH +3D 3H 7S 4D 6C 7C AC 2H 9C TH +4H 5S 3H AC TC TH 9C 9H 9S 8D +8D 9H 5H 4D 6C 2H QD 6S 5D 3S +4C 5C JD QS 4D 3H TH AC QH 8C +QC 5S 3C 7H AD 4C KS 4H JD 6D +QS AH 3H KS 9H 2S JS JH 5H 2H +2H 5S TH 6S TS 3S KS 3C 5H JS +2D 9S 7H 3D KC JH 6D 7D JS TD +AC JS 8H 2C 8C JH JC 2D TH 7S +5D 9S 8H 2H 3D TC AH JC KD 9C +9D QD JC 2H 6D KH TS 9S QH TH +2C 8D 4S JD 5H 3H TH TC 9C KC +AS 3D 9H 7D 4D TH KH 2H 7S 3H +4H 7S KS 2S JS TS 8S 2H QD 8D +5S 6H JH KS 8H 2S QC AC 6S 3S +JC AS AD QS 8H 6C KH 4C 4D QD +2S 3D TS TD 9S KS 6S QS 5C 8D +3C 6D 4S QC KC JH QD TH KH AD +9H AH 4D KS 2S 8D JH JC 7C QS +2D 6C TH 3C 8H QD QH 2S 3S KS +6H 5D 9S 4C TS TD JS QD 9D JD +5H 8H KH 8S KS 7C TD AD 4S KD +2C 7C JC 5S AS 6C 7D 8S 5H 9C +6S QD 9S TS KH QS 5S QH 3C KC +7D 3H 3C KD 5C AS JH 7H 6H JD +9D 5C 9H KC 8H KS 4S AD 4D 2S +3S JD QD 8D 2S 7C 5S 6S 5H TS +6D 9S KC TD 3S 6H QD JD 5C 8D +5H 9D TS KD 8D 6H TD QC 4C 7D +6D 4S JD 9D AH 9S AS TD 9H QD +2D 5S 2H 9C 6H 9S TD QC 7D TC +3S 2H KS TS 2C 9C 8S JS 9D 7D +3C KC 6D 5D 6C 6H 8S AS 7S QS +JH 9S 2H 8D 4C 8H 9H AD TH KH +QC AS 2S JS 5C 6H KD 3H 7H 2C +QD 8H 2S 8D 3S 6D AH 2C TC 5C +JD JS TS 8S 3H 5D TD KC JC 6H +6S QS TC 3H 5D AH JC 7C 7D 4H +7C 5D 8H 9C 2H 9H JH KH 5S 2C +9C 7H 6S TH 3S QC QD 4C AC JD +2H 5D 9S 7D KC 3S QS 2D AS KH +2S 4S 2H 7D 5C TD TH QH 9S 4D +6D 3S TS 6H 4H KS 9D 8H 5S 2D +9H KS 4H 3S 5C 5D KH 6H 6S JS +KC AS 8C 4C JC KH QC TH QD AH +6S KH 9S 2C 5H TC 3C 7H JC 4D +JD 4S 6S 5S 8D 7H 7S 4D 4C 2H +7H 9H 5D KH 9C 7C TS TC 7S 5H +4C 8D QC TS 4S 9H 3D AD JS 7C +8C QS 5C 5D 3H JS AH KC 4S 9D +TS JD 8S QS TH JH KH 2D QD JS +JD QC 5D 6S 9H 3S 2C 8H 9S TS +2S 4C AD 7H JC 5C 2D 6D 4H 3D +7S JS 2C 4H 8C AD QD 9C 3S TD +JD TS 4C 6H 9H 7D QD 6D 3C AS +AS 7C 4C 6S 5D 5S 5C JS QC 4S +KD 6S 9S 7C 3C 5S 7D JH QD JS +4S 7S JH 2C 8S 5D 7H 3D QH AD +TD 6H 2H 8D 4H 2D 7C AD KH 5D +TS 3S 5H 2C QD AH 2S 5C KH TD +KC 4D 8C 5D AS 6C 2H 2S 9H 7C +KD JS QC TS QS KH JH 2C 5D AD +3S 5H KC 6C 9H 3H 2H AD 7D 7S +7S JS JH KD 8S 7D 2S 9H 7C 2H +9H 2D 8D QC 6S AD AS 8H 5H 6C +2S 7H 6C 6D 7D 8C 5D 9D JC 3C +7C 9C 7H JD 2H KD 3S KH AD 4S +QH AS 9H 4D JD KS KD TS KH 5H +4C 8H 5S 3S 3D 7D TD AD 7S KC +JS 8S 5S JC 8H TH 9C 4D 5D KC +7C 5S 9C QD 2C QH JS 5H 8D KH +TD 2S KS 3D AD KC 7S TC 3C 5D +4C 2S AD QS 6C 9S QD TH QH 5C +8C AD QS 2D 2S KC JD KS 6C JC +8D 4D JS 2H 5D QD 7S 7D QH TS +6S 7H 3S 8C 8S 9D QS 8H 6C 9S +4S TC 2S 5C QD 4D QS 6D TH 6S +3S 5C 9D 6H 8D 4C 7D TC 7C TD +AH 6S AS 7H 5S KD 3H 5H AC 4C +8D 8S AH KS QS 2C AD 6H 7D 5D +6H 9H 9S 2H QS 8S 9C 5D 2D KD +TS QC 5S JH 7D 7S TH 9S 9H AC +7H 3H 6S KC 4D 6D 5C 4S QD TS +TD 2S 7C QD 3H JH 9D 4H 7S 7H +KS 3D 4H 5H TC 2S AS 2D 6D 7D +8H 3C 7H TD 3H AD KC TH 9C KH +TC 4C 2C 9S 9D 9C 5C 2H JD 3C +3H AC TS 5D AD 8D 6H QC 6S 8C +2S TS 3S JD 7H 8S QH 4C 5S 8D +AC 4S 6C 3C KH 3D 7C 2D 8S 2H +4H 6C 8S TH 2H 4S 8H 9S 3H 7S +7C 4C 9C 2C 5C AS 5D KD 4D QH +9H 4H TS AS 7D 8D 5D 9S 8C 2H +QC KD AC AD 2H 7S AS 3S 2D 9S +2H QC 8H TC 6D QD QS 5D KH 3C +TH JD QS 4C 2S 5S AD 7H 3S AS +7H JS 3D 6C 3S 6D AS 9S AC QS +9C TS AS 8C TC 8S 6H 9D 8D 6C +4D JD 9C KC 7C 6D KS 3S 8C AS +3H 6S TC 8D TS 3S KC 9S 7C AS +8C QC 4H 4S 8S 6C 3S TC AH AC +4D 7D 5C AS 2H 6S TS QC AD TC +QD QC 8S 4S TH 3D AH TS JH 4H +5C 2D 9S 2C 3H 3C 9D QD QH 7D +KC 9H 6C KD 7S 3C 4D AS TC 2D +3D JS 4D 9D KS 7D TH QC 3H 3C +8D 5S 2H 9D 3H 8C 4C 4H 3C TH +JC TH 4S 6S JD 2D 4D 6C 3D 4C +TS 3S 2D 4H AC 2C 6S 2H JH 6H +TD 8S AD TC AH AC JH 9S 6S 7S +6C KC 4S JD 8D 9H 5S 7H QH AH +KD 8D TS JH 5C 5H 3H AD AS JS +2D 4H 3D 6C 8C 7S AD 5D 5C 8S +TD 5D 7S 9C 4S 5H 6C 8C 4C 8S +JS QH 9C AS 5C QS JC 3D QC 7C +JC 9C KH JH QS QC 2C TS 3D AD +5D JH AC 5C 9S TS 4C JD 8C KS +KC AS 2D KH 9H 2C 5S 4D 3D 6H +TH AH 2D 8S JC 3D 8C QH 7S 3S +8H QD 4H JC AS KH KS 3C 9S 6D +9S QH 7D 9C 4S AC 7H KH 4D KD +AH AD TH 6D 9C 9S KD KS QH 4H +QD 6H 9C 7C QS 6D 6S 9D 5S JH +AH 8D 5H QD 2H JC KS 4H KH 5S +5C 2S JS 8D 9C 8C 3D AS KC AH +JD 9S 2H QS 8H 5S 8C TH 5C 4C +QC QS 8C 2S 2C 3S 9C 4C KS KH +2D 5D 8S AH AD TD 2C JS KS 8C +TC 5S 5H 8H QC 9H 6H JD 4H 9S +3C JH 4H 9H AH 4S 2H 4C 8D AC +8S TH 4D 7D 6D QD QS 7S TC 7C +KH 6D 2D JD 5H JS QD JH 4H 4S +9C 7S JH 4S 3S TS QC 8C TC 4H +QH 9D 4D JH QS 3S 2C 7C 6C 2D +4H 9S JD 5C 5H AH 9D TS 2D 4C +KS JH TS 5D 2D AH JS 7H AS 8D +JS AH 8C AD KS 5S 8H 2C 6C TH +2H 5D AD AC KS 3D 8H TS 6H QC +6D 4H TS 9C 5H JS JH 6S JD 4C +JH QH 4H 2C 6D 3C 5D 4C QS KC +6H 4H 6C 7H 6S 2S 8S KH QC 8C +3H 3D 5D KS 4H TD AD 3S 4D TS +5S 7C 8S 7D 2C KS 7S 6C 8C JS +5D 2H 3S 7C 5C QD 5H 6D 9C 9H +JS 2S KD 9S 8D TD TS AC 8C 9D +5H QD 2S AC 8C 9H KS 7C 4S 3C +KH AS 3H 8S 9C JS QS 4S AD 4D +AS 2S TD AD 4D 9H JC 4C 5H QS +5D 7C 4H TC 2D 6C JS 4S KC 3S +4C 2C 5D AC 9H 3D JD 8S QS QH +2C 8S 6H 3C QH 6D TC KD AC AH +QC 6C 3S QS 4S AC 8D 5C AD KH +5S 4C AC KH AS QC 2C 5C 8D 9C +8H JD 3C KH 8D 5C 9C QD QH 9D +7H TS 2C 8C 4S TD JC 9C 5H QH +JS 4S 2C 7C TH 6C AS KS 7S JD +JH 7C 9H 7H TC 5H 3D 6D 5D 4D +2C QD JH 2H 9D 5S 3D TD AD KS +JD QH 3S 4D TH 7D 6S QS KS 4H +TC KS 5S 8D 8H AD 2S 2D 4C JH +5S JH TC 3S 2D QS 9D 4C KD 9S +AC KH 3H AS 9D KC 9H QD 6C 6S +9H 7S 3D 5C 7D KC TD 8H 4H 6S +3C 7H 8H TC QD 4D 7S 6S QH 6C +6D AD 4C QD 6C 5D 7D 9D KS TS +JH 2H JD 9S 7S TS KH 8D 5D 8H +2D 9S 4C 7D 9D 5H QD 6D AC 6S +7S 6D JC QD JH 4C 6S QS 2H 7D +8C TD JH KD 2H 5C QS 2C JS 7S +TC 5H 4H JH QD 3S 5S 5D 8S KH +KS KH 7C 2C 5D JH 6S 9C 6D JC +5H AH JD 9C JS KC 2H 6H 4D 5S +AS 3C TH QC 6H 9C 8S 8C TD 7C +KC 2C QD 9C KH 4D 7S 3C TS 9H +9C QC 2S TS 8C TD 9S QD 3S 3C +4D 9D TH JH AH 6S 2S JD QH JS +QD 9H 6C KD 7D 7H 5D 6S 8H AH +8H 3C 4S 2H 5H QS QH 7S 4H AC +QS 3C 7S 9S 4H 3S AH KS 9D 7C +AD 5S 6S 2H 2D 5H TC 4S 3C 8C +QH TS 6S 4D JS KS JH AS 8S 6D +2C 8S 2S TD 5H AS TC TS 6C KC +KC TS 8H 2H 3H 7C 4C 5S TH TD +KD AD KH 7H 7S 5D 5H 5S 2D 9C +AD 9S 3D 7S 8C QC 7C 9C KD KS +3C QC 9S 8C 4D 5C AS QD 6C 2C +2H KC 8S JD 7S AC 8D 5C 2S 4D +9D QH 3D 2S TC 3S KS 3C 9H TD +KD 6S AC 2C 7H 5H 3S 6C 6H 8C +QH TC 8S 6S KH TH 4H 5D TS 4D +8C JS 4H 6H 2C 2H 7D AC QD 3D +QS KC 6S 2D 5S 4H TD 3H JH 4C +7S 5H 7H 8H KH 6H QS TH KD 7D +5H AD KD 7C KH 5S TD 6D 3C 6C +8C 9C 5H JD 7C KC KH 7H 2H 3S +7S 4H AD 4D 8S QS TH 3D 7H 5S +8D TC KS KD 9S 6D AD JD 5C 2S +7H 8H 6C QD 2H 6H 9D TC 9S 7C +8D 6D 4C 7C 6C 3C TH KH JS JH +5S 3S 8S JS 9H AS AD 8H 7S KD +JH 7C 2C KC 5H AS AD 9C 9S JS +AD AC 2C 6S QD 7C 3H TH KS KD +9D JD 4H 8H 4C KH 7S TS 8C KC +3S 5S 2H 7S 6H 7D KS 5C 6D AD +5S 8C 9H QS 7H 7S 2H 6C 7D TD +QS 5S TD AC 9D KC 3D TC 2D 4D +TD 2H 7D JD QD 4C 7H 5D KC 3D +4C 3H 8S KD QH 5S QC 9H TC 5H +9C QD TH 5H TS 5C 9H AH QH 2C +4D 6S 3C AC 6C 3D 2C 2H TD TH +AC 9C 5D QC 4D AD 8D 6D 8C KC +AD 3C 4H AC 8D 8H 7S 9S TD JC +4H 9H QH JS 2D TH TD TC KD KS +5S 6S 9S 8D TH AS KH 5H 5C 8S +JD 2S 9S 6S 5S 8S 5D 7S 7H 9D +5D 8C 4C 9D AD TS 2C 7D KD TC +8S QS 4D KC 5C 8D 4S KH JD KD +AS 5C AD QH 7D 2H 9S 7H 7C TC +2S 8S JD KH 7S 6C 6D AD 5D QC +9H 6H 3S 8C 8H AH TC 4H JS TD +2C TS 4D 7H 2D QC 9C 5D TH 7C +6C 8H QC 5D TS JH 5C 5H 9H 4S +2D QC 7H AS JS 8S 2H 4C 4H 8D +JS 6S AC KD 3D 3C 4S 7H TH KC +QH KH 6S QS 5S 4H 3C QD 3S 3H +7H AS KH 8C 4H 9C 5S 3D 6S TS +9C 7C 3H 5S QD 2C 3D AD AC 5H +JH TD 2D 4C TS 3H KH AD 3S 7S +AS 4C 5H 4D 6S KD JC 3C 6H 2D +3H 6S 8C 2D TH 4S AH QH AD 5H +7C 2S 9H 7H KC 5C 6D 5S 3H JC +3C TC 9C 4H QD TD JH 6D 9H 5S +7C 6S 5C 5D 6C 4S 7H 9H 6H AH +AD 2H 7D KC 2C 4C 2S 9S 7H 3S +TH 4C 8S 6S 3S AD KS AS JH TD +5C TD 4S 4D AD 6S 5D TC 9C 7D +8H 3S 4D 4S 5S 6H 5C AC 3H 3D +9H 3C AC 4S QS 8S 9D QH 5H 4D +JC 6C 5H TS AC 9C JD 8C 7C QD +8S 8H 9C JD 2D QC QH 6H 3C 8D +KS JS 2H 6H 5H QH QS 3H 7C 6D +TC 3H 4S 7H QC 2H 3S 8C JS KH +AH 8H 5S 4C 9H JD 3H 7S JC AC +3C 2D 4C 5S 6C 4S QS 3S JD 3D +5H 2D TC AH KS 6D 7H AD 8C 6H +6C 7S 3C JD 7C 8H KS KH AH 6D +AH 7D 3H 8H 8S 7H QS 5H 9D 2D +JD AC 4H 7S 8S 9S KS AS 9D QH +7S 2C 8S 5S JH QS JC AH KD 4C +AH 2S 9H 4H 8D TS TD 6H QH JD +4H JC 3H QS 6D 7S 9C 8S 9D 8D +5H TD 4S 9S 4C 8C 8D 7H 3H 3D +QS KH 3S 2C 2S 3C 7S TD 4S QD +7C TD 4D 5S KH AC AS 7H 4C 6C +2S 5H 6D JD 9H QS 8S 2C 2H TD +2S TS 6H 9H 7S 4H JC 4C 5D 5S +2C 5H 7D 4H 3S QH JC JS 6D 8H +4C QH 7C QD 3S AD TH 8S 5S TS +9H TC 2S TD JC 7D 3S 3D TH QH +7D 4C 8S 5C JH 8H 6S 3S KC 3H +JC 3H KH TC QH TH 6H 2C AC 5H +QS 2H 9D 2C AS 6S 6C 2S 8C 8S +9H 7D QC TH 4H KD QS AC 7S 3C +4D JH 6S 5S 8H KS 9S QC 3S AS +JD 2D 6S 7S TC 9H KC 3H 7D KD +2H KH 7C 4D 4S 3H JS QD 7D KC +4C JC AS 9D 3C JS 6C 8H QD 4D +AH JS 3S 6C 4C 3D JH 6D 9C 9H +9H 2D 8C 7H 5S KS 6H 9C 2S TC +6C 8C AD 7H 6H 3D KH AS 5D TH +KS 8C 3S TS 8S 4D 5S 9S 6C 4H +9H 4S 4H 5C 7D KC 2D 2H 9D JH +5C JS TC 9D 9H 5H 7S KH JC 6S +7C 9H 8H 4D JC KH JD 2H TD TC +8H 6C 2H 2C KH 6H 9D QS QH 5H +AC 7D 2S 3D QD JC 2D 8D JD JH +2H JC 2D 7H 2C 3C 8D KD TD 4H +3S 4H 6D 8D TS 3H TD 3D 6H TH +JH JC 3S AC QH 9H 7H 8S QC 2C +7H TD QS 4S 8S 9C 2S 5D 4D 2H +3D TS 3H 2S QC 8H 6H KC JC KS +5D JD 7D TC 8C 6C 9S 3D 8D AC +8H 6H JH 6C 5D 8D 8S 4H AD 2C +9D 4H 2D 2C 3S TS AS TC 3C 5D +4D TH 5H KS QS 6C 4S 2H 3D AD +5C KC 6H 2C 5S 3C 4D 2D 9H 9S +JD 4C 3H TH QH 9H 5S AH 8S AC +7D 9S 6S 2H TD 9C 4H 8H QS 4C +3C 6H 5D 4H 8C 9C KC 6S QD QS +3S 9H KD TC 2D JS 8C 6S 4H 4S +2S 4C 8S QS 6H KH 3H TH 8C 5D +2C KH 5S 3S 7S 7H 6C 9D QD 8D +8H KS AC 2D KH TS 6C JS KC 7H +9C KS 5C TD QC AH 6C 5H 9S 7C +5D 4D 3H 4H 6S 7C 7S AH QD TD +2H 7D QC 6S TC TS AH 7S 9D 3H +TH 5H QD 9S KS 7S 7C 6H 8C TD +TH 2D 4D QC 5C 7D JD AH 9C 4H +4H 3H AH 8D 6H QC QH 9H 2H 2C +2D AD 4C TS 6H 7S TH 4H QS TD +3C KD 2H 3H QS JD TC QC 5D 8H +KS JC QD TH 9S KD 8D 8C 2D 9C +3C QD KD 6D 4D 8D AH AD QC 8S +8H 3S 9D 2S 3H KS 6H 4C 7C KC +TH 9S 5C 3D 7D 6H AC 7S 4D 2C +5C 3D JD 4D 2D 6D 5H 9H 4C KH +AS 7H TD 6C 2H 3D QD KS 4C 4S +JC 3C AC 7C JD JS 8H 9S QC 5D +JD 6S 5S 2H AS 8C 7D 5H JH 3D +8D TC 5S 9S 8S 3H JC 5H 7S AS +5C TD 3D 7D 4H 8D 7H 4D 5D JS +QS 9C KS TD 2S 8S 5C 2H 4H AS +TH 7S 4H 7D 3H JD KD 5D 2S KC +JD 7H 4S 8H 4C JS 6H QH 5S 4H +2C QS 8C 5S 3H QC 2S 6C QD AD +8C 3D JD TC 4H 2H AD 5S AC 2S +5D 2C JS 2D AD 9D 3D 4C 4S JH +8D 5H 5D 6H 7S 4D KS 9D TD JD +3D 6D 9C 2S AS 7D 5S 5C 8H JD +7C 8S 3S 6S 5H JD TC AD 7H 7S +2S 9D TS 4D AC 8D 6C QD JD 3H +9S KH 2C 3C AC 3D 5H 6H 8D 5D +KS 3D 2D 6S AS 4C 2S 7C 7H KH +AC 2H 3S JC 5C QH 4D 2D 5H 7S +TS AS JD 8C 6H JC 8S 5S 2C 5D +7S QH 7H 6C QC 8H 2D 7C JD 2S +2C QD 2S 2H JC 9C 5D 2D JD JH +7C 5C 9C 8S 7D 6D 8D 6C 9S JH +2C AD 6S 5H 3S KS 7S 9D KH 4C +7H 6C 2C 5C TH 9D 8D 3S QC AH +5S KC 6H TC 5H 8S TH 6D 3C AH +9C KD 4H AD TD 9S 4S 7D 6H 5D +7H 5C 5H 6D AS 4C KD KH 4H 9D +3C 2S 5C 6C JD QS 2H 9D 7D 3H +AC 2S 6S 7S JS QD 5C QS 6H AD +5H TH QC 7H TC 3S 7C 6D KC 3D +4H 3D QC 9S 8H 2C 3S JC KS 5C +4S 6S 2C 6H 8S 3S 3D 9H 3H JS +4S 8C 4D 2D 8H 9H 7D 9D AH TS +9S 2C 9H 4C 8D AS 7D 3D 6D 5S +6S 4C 7H 8C 3H 5H JC AH 9D 9C +2S 7C 5S JD 8C 3S 3D 4D 7D 6S +3C KC 4S 5D 7D 3D JD 7H 3H 4H +9C 9H 4H 4D TH 6D QD 8S 9S 7S +2H AC 8S 4S AD 8C 2C AH 7D TC +TS 9H 3C AD KS TC 3D 8C 8H JD +QC 8D 2C 3C 7D 7C JD 9H 9C 6C +AH 6S JS JH 5D AS QC 2C JD TD +9H KD 2H 5D 2D 3S 7D TC AH TS +TD 8H AS 5D AH QC AC 6S TC 5H +KS 4S 7H 4D 8D 9C TC 2H 6H 3H +3H KD 4S QD QH 3D 8H 8C TD 7S +8S JD TC AH JS QS 2D KH KS 4D +3C AD JC KD JS KH 4S TH 9H 2C +QC 5S JS 9S KS AS 7C QD 2S JD +KC 5S QS 3S 2D AC 5D 9H 8H KS +6H 9C TC AD 2C 6D 5S JD 6C 7C +QS KH TD QD 2C 3H 8S 2S QC AH +9D 9H JH TC QH 3C 2S JS 5C 7H +6C 3S 3D 2S 4S QD 2D TH 5D 2C +2D 6H 6D 2S JC QH AS 7H 4H KH +5H 6S KS AD TC TS 7C AC 4S 4H +AD 3C 4H QS 8C 9D KS 2H 2D 4D +4S 9D 6C 6D 9C AC 8D 3H 7H KD +JC AH 6C TS JD 6D AD 3S 5D QD +JC JH JD 3S 7S 8S JS QC 3H 4S +JD TH 5C 2C AD JS 7H 9S 2H 7S +8D 3S JH 4D QC AS JD 2C KC 6H +2C AC 5H KD 5S 7H QD JH AH 2D +JC QH 8D 8S TC 5H 5C AH 8C 6C +3H JS 8S QD JH 3C 4H 6D 5C 3S +6D 4S 4C AH 5H 5S 3H JD 7C 8D +8H AH 2H 3H JS 3C 7D QC 4H KD +6S 2H KD 5H 8H 2D 3C 8S 7S QD +2S 7S KC QC AH TC QS 6D 4C 8D +5S 9H 2C 3S QD 7S 6C 2H 7C 9D +3C 6C 5C 5S JD JC KS 3S 5D TS +7C KS 6S 5S 2S 2D TC 2H 5H QS +AS 7H 6S TS 5H 9S 9D 3C KD 2H +4S JS QS 3S 4H 7C 2S AC 6S 9D +8C JH 2H 5H 7C 5D QH QS KH QC +3S TD 3H 7C KC 8D 5H 8S KH 8C +4H KH JD TS 3C 7H AS QC JS 5S +AH 9D 2C 8D 4D 2D 6H 6C KC 6S +2S 6H 9D 3S 7H 4D KH 8H KD 3D +9C TC AC JH KH 4D JD 5H TD 3S +7S 4H 9D AS 4C 7D QS 9S 2S KH +3S 8D 8S KS 8C JC 5C KH 2H 5D +8S QH 2C 4D KC JS QC 9D AC 6H +8S 8C 7C JS JD 6S 4C 9C AC 4S +QH 5D 2C 7D JC 8S 2D JS JH 4C +JS 4C 7S TS JH KC KH 5H QD 4S +QD 8C 8D 2D 6S TD 9D AC QH 5S +QH QC JS 3D 3C 5C 4H KH 8S 7H +7C 2C 5S JC 8S 3H QC 5D 2H KC +5S 8D KD 6H 4H QD QH 6D AH 3D +7S KS 6C 2S 4D AC QS 5H TS JD +7C 2D TC 5D QS AC JS QC 6C KC +2C KS 4D 3H TS 8S AD 4H 7S 9S +QD 9H QH 5H 4H 4D KH 3S JC AD +4D AC KC 8D 6D 4C 2D KH 2C JD +2C 9H 2D AH 3H 6D 9C 7D TC KS +8C 3H KD 7C 5C 2S 4S 5H AS AH +TH JD 4H KD 3H TC 5C 3S AC KH +6D 7H AH 7S QC 6H 2D TD JD AS +JH 5D 7H TC 9S 7D JC AS 5S KH +2H 8C AD TH 6H QD KD 9H 6S 6C +QH KC 9D 4D 3S JS JH 4H 2C 9H +TC 7H KH 4H JC 7D 9S 3H QS 7S +AD 7D JH 6C 7H 4H 3S 3H 4D QH +JD 2H 5C AS 6C QC 4D 3C TC JH +AC JD 3H 6H 4C JC AD 7D 7H 9H +4H TC TS 2C 8C 6S KS 2H JD 9S +4C 3H QS QC 9S 9H 6D KC 9D 9C +5C AD 8C 2C QH TH QD JC 8D 8H +QC 2C 2S QD 9C 4D 3S 8D JH QS +9D 3S 2C 7S 7C JC TD 3C TC 9H +3C TS 8H 5C 4C 2C 6S 8D 7C 4H +KS 7H 2H TC 4H 2C 3S AS AH QS +8C 2D 2H 2C 4S 4C 6S 7D 5S 3S +TH QC 5D TD 3C QS KD KC KS AS +4D AH KD 9H KS 5C 4C 6H JC 7S +KC 4H 5C QS TC 2H JC 9S AH QH +4S 9H 3H 5H 3C QD 2H QC JH 8H +5D AS 7H 2C 3D JH 6H 4C 6S 7D +9C JD 9H AH JS 8S QH 3H KS 8H +3S AC QC TS 4D AD 3D AH 8S 9H +7H 3H QS 9C 9S 5H JH JS AH AC +8D 3C JD 2H AC 9C 7H 5S 4D 8H +7C JH 9H 6C JS 9S 7H 8C 9D 4H +2D AS 9S 6H 4D JS JH 9H AD QD +6H 7S JH KH AH 7H TD 5S 6S 2C +8H JH 6S 5H 5S 9D TC 4C QC 9S +7D 2C KD 3H 5H AS QD 7H JS 4D +TS QH 6C 8H TH 5H 3C 3H 9C 9D +AD KH JS 5D 3H AS AC 9S 5C KC +2C KH 8C JC QS 6D AH 2D KC TC +9D 3H 2S 7C 4D 6D KH KS 8D 7D +9H 2S TC JH AC QC 3H 5S 3S 8H +3S AS KD 8H 4C 3H 7C JH QH TS +7S 6D 7H 9D JH 4C 3D 3S 6C AS +4S 2H 2C 4C 8S 5H KC 8C QC QD +3H 3S 6C QS QC 2D 6S 5D 2C 9D +2H 8D JH 2S 3H 2D 6C 5C 7S AD +9H JS 5D QH 8S TS 2H 7S 6S AD +6D QC 9S 7H 5H 5C 7D KC JD 4H +QC 5S 9H 9C 4D 6S KS 2S 4C 7C +9H 7C 4H 8D 3S 6H 5C 8H JS 7S +2D 6H JS TD 4H 4D JC TH 5H KC +AC 7C 8D TH 3H 9S 2D 4C KC 4D +KD QS 9C 7S 3D KS AD TS 4C 4H +QH 9C 8H 2S 7D KS 7H 5D KD 4C +9C 2S 2H JC 6S 6C TC QC JH 5C +7S AC 8H KC 8S 6H QS JC 3D 6S +JS 2D JH 8C 4S 6H 8H 6D 5D AD +6H 7D 2S 4H 9H 7C AS AC 8H 5S +3C JS 4S 6D 5H 2S QH 6S 9C 2C +3D 5S 6S 9S 4C QS 8D QD 8S TC +9C 3D AH 9H 5S 2C 7D AD JC 3S +7H TC AS 3C 6S 6D 7S KH KC 9H +3S TC 8H 6S 5H JH 8C 7D AC 2S +QD 9D 9C 3S JC 8C KS 8H 5D 4D +JS AH JD 6D 9D 8C 9H 9S 8H 3H +2D 6S 4C 4D 8S AD 4S TC AH 9H +TS AC QC TH KC 6D 4H 7S 8C 2H +3C QD JS 9D 5S JC AH 2H TS 9H +3H 4D QH 5D 9C 5H 7D 4S JC 3S +8S TH 3H 7C 2H JD JS TS AC 8D +9C 2H TD KC JD 2S 8C 5S AD 2C +3D KD 7C 5H 4D QH QD TC 6H 7D +7H 2C KC 5S KD 6H AH QC 7S QH +6H 5C AC 5H 2C 9C 2D 7C TD 2S +4D 9D AH 3D 7C JD 4H 8C 4C KS +TH 3C JS QH 8H 4C AS 3D QS QC +4D 7S 5H JH 6D 7D 6H JS KH 3C +QD 8S 7D 2H 2C 7C JC 2S 5H 8C +QH 8S 9D TC 2H AD 7C 8D QD 6S +3S 7C AD 9H 2H 9S JD TS 4C 2D +3S AS 4H QC 2C 8H 8S 7S TD TC +JH TH TD 3S 4D 4H 5S 5D QS 2C +8C QD QH TC 6D 4S 9S 9D 4H QC +8C JS 9D 6H JD 3H AD 6S TD QC +KC 8S 3D 7C TD 7D 8D 9H 4S 3S +6C 4S 3D 9D KD TC KC KS AC 5S +7C 6S QH 3D JS KD 6H 6D 2D 8C +JD 2S 5S 4H 8S AC 2D 6S TS 5C +5H 8C 5S 3C 4S 3D 7C 8D AS 3H +AS TS 7C 3H AD 7D JC QS 6C 6H +3S 9S 4C AC QH 5H 5D 9H TS 4H +6C 5C 7H 7S TD AD JD 5S 2H 2S +7D 6C KC 3S JD 8D 8S TS QS KH +8S QS 8D 6C TH AC AH 2C 8H 9S +7H TD KH QH 8S 3D 4D AH JD AS +TS 3D 2H JC 2S JH KH 6C QC JS +KC TH 2D 6H 7S 2S TC 8C 9D QS +3C 9D 6S KH 8H 6D 5D TH 2C 2H +6H TC 7D AD 4D 8S TS 9H TD 7S +JS 6D JD JC 2H AC 6C 3D KH 8D +KH JD 9S 5D 4H 4C 3H 7S QS 5C +4H JD 5D 3S 3C 4D KH QH QS 7S +JD TS 8S QD AH 4C 6H 3S 5S 2C +QS 3D JD AS 8D TH 7C 6S QC KS +7S 2H 8C QC 7H AC 6D 2D TH KH +5S 6C 7H KH 7D AH 8C 5C 7S 3D +3C KD AD 7D 6C 4D KS 2D 8C 4S +7C 8D 5S 2D 2S AH AD 2C 9D TD +3C AD 4S KS JH 7C 5C 8C 9C TH +AS TD 4D 7C JD 8C QH 3C 5H 9S +3H 9C 8S 9S 6S QD KS AH 5H JH +QC 9C 5S 4H 2H TD 7D AS 8C 9D +8C 2C 9D KD TC 7S 3D KH QC 3C +4D AS 4C QS 5S 9D 6S JD QH KS +6D AH 6C 4C 5H TS 9H 7D 3D 5S +QS JD 7C 8D 9C AC 3S 6S 6C KH +8H JH 5D 9S 6D AS 6S 3S QC 7H +QD AD 5C JH 2H AH 4H AS KC 2C +JH 9C 2C 6H 2D JS 5D 9H KC 6D +7D 9D KD TH 3H AS 6S QC 6H AD +JD 4H 7D KC 3H JS 3C TH 3D QS +4C 3H 8C QD 5H 6H AS 8H AD JD +TH 8S KD 5D QC 7D JS 5S 5H TS +7D KC 9D QS 3H 3C 6D TS 7S AH +7C 4H 7H AH QC AC 4D 5D 6D TH +3C 4H 2S KD 8H 5H JH TC 6C JD +4S 8C 3D 4H JS TD 7S JH QS KD +7C QC KD 4D 7H 6S AD TD TC KH +5H 9H KC 3H 4D 3D AD 6S QD 6H +TH 7C 6H TS QH 5S 2C KC TD 6S +7C 4D 5S JD JH 7D AC KD KH 4H +7D 6C 8D 8H 5C JH 8S QD TH JD +8D 7D 6C 7C 9D KD AS 5C QH JH +9S 2C 8C 3C 4C KS JH 2D 8D 4H +7S 6C JH KH 8H 3H 9D 2D AH 6D +4D TC 9C 8D 7H TD KS TH KD 3C +JD 9H 8D QD AS KD 9D 2C 2S 9C +8D 3H 5C 7H KS 5H QH 2D 8C 9H +2D TH 6D QD 6C KC 3H 3S AD 4C +4H 3H JS 9D 3C TC 5H QH QC JC +3D 5C 6H 3S 3C JC 5S 7S 2S QH +AC 5C 8C 4D 5D 4H 2S QD 3C 3H +2C TD AH 9C KD JS 6S QD 4C QC +QS 8C 3S 4H TC JS 3H 7C JC AD +5H 4D 9C KS JC TD 9S TS 8S 9H +QD TS 7D AS AC 2C TD 6H 8H AH +6S AD 8C 4S 9H 8D 9D KH 8S 3C +QS 4D 2D 7S KH JS JC AD 4C 3C +QS 9S 7H KC TD TH 5H JS AC JH +6D AC 2S QS 7C AS KS 6S KH 5S +6D 8H KH 3C QS 2H 5C 9C 9D 6C +JS 2C 4C 6H 7D JC AC QD TD 3H +4H QC 8H JD 4C KD KS 5C KC 7S +6D 2D 3H 2S QD 5S 7H AS TH 6S +AS 6D 8D 2C 8S TD 8H QD JC AH +9C 9H 2D TD QH 2H 5C TC 3D 8H +KC 8S 3D KH 2S TS TC 6S 4D JH +9H 9D QS AC KC 6H 5D 4D 8D AH +9S 5C QS 4H 7C 7D 2H 8S AD JS +3D AC 9S AS 2C 2D 2H 3H JC KH +7H QH KH JD TC KS 5S 8H 4C 8D +2H 7H 3S 2S 5H QS 3C AS 9H KD +AD 3D JD 6H 5S 9C 6D AC 9S 3S +3D 5D 9C 2D AC 4S 2S AD 6C 6S +QC 4C 2D 3H 6S KC QH QD 2H JH +QC 3C 8S 4D 9S 2H 5C 8H QS QD +6D KD 6S 7H 3S KH 2H 5C JC 6C +3S 9S TC 6S 8H 2D AD 7S 8S TS +3C 6H 9C 3H 5C JC 8H QH TD QD +3C JS QD 5D TD 2C KH 9H TH AS +9S TC JD 3D 5C 5H AD QH 9H KC +TC 7H 4H 8H 3H TD 6S AC 7C 2S +QS 9D 5D 3C JC KS 4D 6C JH 2S +9S 6S 3C 7H TS 4C KD 6D 3D 9C +2D 9H AH AC 7H 2S JH 3S 7C QC +QD 9H 3C 2H AC AS 8S KD 8C KH +2D 7S TD TH 6D JD 8D 4D 2H 5S +8S QH KD JD QS JH 4D KC 5H 3S +3C KH QC 6D 8H 3S AH 7D TD 2D +5S 9H QH 4S 6S 6C 6D TS TH 7S +6C 4C 6D QS JS 9C TS 3H 8D 8S +JS 5C 7S AS 2C AH 2H AD 5S TC +KD 6C 9C 9D TS 2S JC 4H 2C QD +QS 9H TC 3H KC KS 4H 3C AD TH +KH 9C 2H KD 9D TC 7S KC JH 2D +7C 3S KC AS 8C 5D 9C 9S QH 3H +2D 8C TD 4C 2H QC 5D TC 2C 7D +KS 4D 6C QH TD KH 5D 7C AD 8D +2S 9S 8S 4C 8C 3D 6H QD 7C 7H +6C 8S QH 5H TS 5C 3C 4S 2S 2H +8S 6S 2H JC 3S 3H 9D 8C 2S 7H +QC 2C 8H 9C AC JD 4C 4H 6S 3S +3H 3S 7D 4C 9S 5H 8H JC 3D TC +QH 2S 2D 9S KD QD 9H AD 6D 9C +8D 2D KS 9S JC 4C JD KC 4S TH +KH TS 6D 4D 5C KD 5H AS 9H AD +QD JS 7C 6D 5D 5C TH 5H QH QS +9D QH KH 5H JH 4C 4D TC TH 6C +KH AS TS 9D KD 9C 7S 4D 8H 5S +KH AS 2S 7D 9D 4C TS TH AH 7C +KS 4D AC 8S 9S 8D TH QH 9D 5C +5D 5C 8C QS TC 4C 3D 3S 2C 8D +9D KS 2D 3C KC 4S 8C KH 6C JC +8H AH 6H 7D 7S QD 3C 4C 6C KC +3H 2C QH 8H AS 7D 4C 8C 4H KC +QD 5S 4H 2C TD AH JH QH 4C 8S +3H QS 5S JS 8H 2S 9H 9C 3S 2C +6H TS 7S JC QD AC TD KC 5S 3H +QH AS QS 7D JC KC 2C 4C 5C 5S +QH 3D AS JS 4H 8D 7H JC 2S 9C +5D 4D 2S 4S 9D 9C 2D QS 8H 7H +6D 7H 3H JS TS AC 2D JH 7C 8S +JH 5H KC 3C TC 5S 9H 4C 8H 9D +8S KC 5H 9H AD KS 9D KH 8D AH +JC 2H 9H KS 6S 3H QC 5H AH 9C +5C KH 5S AD 6C JC 9H QC 9C TD +5S 5D JC QH 2D KS 8H QS 2H TS +JH 5H 5S AH 7H 3C 8S AS TD KH +6H 3D JD 2C 4C KC 7S AH 6C JH +4C KS 9D AD 7S KC 7D 8H 3S 9C +7H 5C 5H 3C 8H QC 3D KH 6D JC +2D 4H 5D 7D QC AD AH 9H QH 8H +KD 8C JS 9D 3S 3C 2H 5D 6D 2S +8S 6S TS 3C 6H 8D 5S 3H TD 6C +KS 3D JH 9C 7C 9S QS 5S 4H 6H +7S 6S TH 4S KC KD 3S JC JH KS +7C 3C 2S 6D QH 2C 7S 5H 8H AH +KC 8D QD 6D KH 5C 7H 9D 3D 9C +6H 2D 8S JS 9S 2S 6D KC 7C TC +KD 9C JH 7H KC 8S 2S 7S 3D 6H +4H 9H 2D 4C 8H 7H 5S 8S 2H 8D +AD 7C 3C 7S 5S 4D 9H 3D JC KH +5D AS 7D 6D 9C JC 4C QH QS KH +KD JD 7D 3D QS QC 8S 6D JS QD +6S 8C 5S QH TH 9H AS AC 2C JD +QC KS QH 7S 3C 4C 5C KC 5D AH +6C 4H 9D AH 2C 3H KD 3D TS 5C +TD 8S QS AS JS 3H KD AC 4H KS +7D 5D TS 9H 4H 4C 9C 2H 8C QC +2C 7D 9H 4D KS 4C QH AD KD JS +QD AD AH KH 9D JS 9H JC KD JD +8S 3C 4S TS 7S 4D 5C 2S 6H 7C +JS 7S 5C KD 6D QH 8S TD 2H 6S +QH 6C TC 6H TD 4C 9D 2H QC 8H +3D TS 4D 2H 6H 6S 2C 7H 8S 6C +9H 9D JD JH 3S AH 2C 6S 3H 8S +2C QS 8C 5S 3H 2S 7D 3C AD 4S +5C QC QH AS TS 4S 6S 4C 5H JS +JH 5C TD 4C 6H JS KD KH QS 4H +TC KH JC 4D 9H 9D 8D KC 3C 8H +2H TC 8S AD 9S 4H TS 7H 2C 5C +4H 2S 6C 5S KS AH 9C 7C 8H KD +TS QH TD QS 3C JH AH 2C 8D 7D +5D KC 3H 5S AC 4S 7H QS 4C 2H +3D 7D QC KH JH 6D 6C TD TH KD +5S 8D TH 6C 9D 7D KH 8C 9S 6D +JD QS 7S QC 2S QH JC 4S KS 8D +7S 5S 9S JD KD 9C JC AD 2D 7C +4S 5H AH JH 9C 5D TD 7C 2D 6S +KC 6C 7H 6S 9C QD 5S 4H KS TD +6S 8D KS 2D TH TD 9H JD TS 3S +KH JS 4H 5D 9D TC TD QC JD TS +QS QD AC AD 4C 6S 2D AS 3H KC +4C 7C 3C TD QS 9C KC AS 8D AD +KC 7H QC 6D 8H 6S 5S AH 7S 8C +3S AD 9H JC 6D JD AS KH 6S JH +AD 3D TS KS 7H JH 2D JS QD AC +9C JD 7C 6D TC 6H 6C JC 3D 3S +QC KC 3S JC KD 2C 8D AH QS TS +AS KD 3D JD 8H 7C 8C 5C QD 6C diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 1e1da38a3f..62f6a56c65 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu. +! Copyright (c) 2007, 2008, 2009 Aaron Schaefer, Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. USING: definitions io io.files io.pathnames kernel math math.parser prettyprint project-euler.ave-time sequences vocabs vocabs.loader @@ -14,14 +14,14 @@ USING: definitions io io.files io.pathnames kernel math math.parser project-euler.037 project-euler.038 project-euler.039 project-euler.040 project-euler.041 project-euler.042 project-euler.043 project-euler.044 project-euler.045 project-euler.046 project-euler.047 project-euler.048 - project-euler.049 project-euler.052 project-euler.053 project-euler.055 - project-euler.056 project-euler.057 project-euler.059 project-euler.067 - project-euler.071 project-euler.073 project-euler.075 project-euler.076 - project-euler.079 project-euler.092 project-euler.097 project-euler.099 - project-euler.100 project-euler.116 project-euler.117 project-euler.134 - project-euler.148 project-euler.150 project-euler.151 project-euler.164 - project-euler.169 project-euler.173 project-euler.175 project-euler.186 - project-euler.190 project-euler.203 project-euler.215 ; + project-euler.049 project-euler.052 project-euler.053 project-euler.054 + project-euler.055 project-euler.056 project-euler.057 project-euler.059 + project-euler.067 project-euler.071 project-euler.073 project-euler.075 + project-euler.076 project-euler.079 project-euler.092 project-euler.097 + project-euler.099 project-euler.100 project-euler.116 project-euler.117 + project-euler.134 project-euler.148 project-euler.150 project-euler.151 + project-euler.164 project-euler.169 project-euler.173 project-euler.175 + project-euler.186 project-euler.190 project-euler.203 project-euler.215 ; IN: project-euler Date: Sun, 5 Apr 2009 17:32:53 -0500 Subject: [PATCH 089/772] Fixes for recent changes --- basis/opengl/textures/textures-tests.factor | 50 --------------------- extra/tetris/gl/gl.factor | 2 +- 2 files changed, 1 insertion(+), 51 deletions(-) diff --git a/basis/opengl/textures/textures-tests.factor b/basis/opengl/textures/textures-tests.factor index 163871028d..3efdb43cd8 100644 --- a/basis/opengl/textures/textures-tests.factor +++ b/basis/opengl/textures/textures-tests.factor @@ -5,56 +5,6 @@ opengl.textures.private images kernel namespaces accessors sequences ; IN: opengl.textures.tests -[ ] [ - T{ image - { dim { 3 5 } } - { component-order RGB } - { bitmap - B{ - 1 2 3 4 5 6 7 8 9 - 10 11 12 13 14 15 16 17 18 - 19 20 21 22 23 24 25 26 27 - 28 29 30 31 32 33 34 35 36 - 37 38 39 40 41 42 43 44 45 - } - } - } "image" set -] unit-test - -[ - T{ image - { dim { 4 8 } } - { component-order RGB } - { bitmap - B{ - 1 2 3 4 5 6 7 8 9 7 8 9 - 10 11 12 13 14 15 16 17 18 16 17 18 - 19 20 21 22 23 24 25 26 27 25 26 27 - 28 29 30 31 32 33 34 35 36 34 35 36 - 37 38 39 40 41 42 43 44 45 43 44 45 - 37 38 39 40 41 42 43 44 45 43 44 45 - 37 38 39 40 41 42 43 44 45 43 44 45 - 37 38 39 40 41 42 43 44 45 43 44 45 - } - } - } -] [ - "image" get power-of-2-image -] unit-test - -[ - T{ image - { dim { 0 0 } } - { component-order R32G32B32 } - { bitmap B{ } } } -] [ - T{ image - { dim { 0 0 } } - { component-order R32G32B32 } - { bitmap B{ } } - } power-of-2-image -] unit-test - [ { { { 0 0 } { 10 0 } } diff --git a/extra/tetris/gl/gl.factor b/extra/tetris/gl/gl.factor index d1f398994e..0169249e81 100644 --- a/extra/tetris/gl/gl.factor +++ b/extra/tetris/gl/gl.factor @@ -37,7 +37,7 @@ IN: tetris.gl : draw-tetris ( width height tetris -- ) #! width and height are in pixels - GL_MODELVIEW [ + [ { [ board>> scale-board ] [ board>> draw-board ] From 75dd35179b48290b2725912404c725407d7f0a59 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 17:34:02 -0500 Subject: [PATCH 090/772] Fix alien unit tests --- core/alien/alien-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index aa65a3e2d8..d3265f31bb 100644 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -87,4 +87,4 @@ f initialize-test set-global [ 7575 ] [ initialize-test [ 7575 ] initialize-alien ] unit-test -[ { BAD-ALIEN } ] [ { BAD-ALIEN BAD-ALIEN BAD-ALIEN } prune ] unit-test \ No newline at end of file +[ V{ BAD-ALIEN } ] [ { BAD-ALIEN BAD-ALIEN BAD-ALIEN } prune ] unit-test \ No newline at end of file From 4a229e5205932455d8256deb8a348382503a9a00 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 5 Apr 2009 21:16:20 -0400 Subject: [PATCH 091/772] Slight cleanup of PE problem 54 solution --- extra/project-euler/054/054.factor | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/extra/project-euler/054/054.factor b/extra/project-euler/054/054.factor index 2e7eaa4cd3..5cf42737fb 100644 --- a/extra/project-euler/054/054.factor +++ b/extra/project-euler/054/054.factor @@ -73,15 +73,12 @@ IN: project-euler.054 "resource:extra/project-euler/054/poker.txt" ascii file-lines [ [ 14 head-slice ] [ 14 tail-slice* ] bi 2array ] map ; -: player1-win? ( hand1 hand2 -- ? ) - before? ; inline - PRIVATE> : euler054 ( -- answer ) - source-054 [ [ ] map first2 player1-win? ] count ; + source-054 [ [ ] map first2 before? ] count ; ! [ euler054 ] 100 ave-time -! 36 ms ave run time - 2.71 SD (100 trials) +! 34 ms ave run time - 2.65 SD (100 trials) SOLUTION: euler054 From fda3f6d3f0fa707281c869f25fef1e146b04dd17 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 5 Apr 2009 21:16:57 -0400 Subject: [PATCH 092/772] Add perfect hash optimization for poker vocab --- extra/poker/arrays/arrays.factor | 1267 ++++++++++++------------------ extra/poker/poker-tests.factor | 2 + extra/poker/poker.factor | 20 +- 3 files changed, 529 insertions(+), 760 deletions(-) diff --git a/extra/poker/arrays/arrays.factor b/extra/poker/arrays/arrays.factor index b415265348..bf758f166a 100644 --- a/extra/poker/arrays/arrays.factor +++ b/extra/poker/arrays/arrays.factor @@ -502,760 +502,517 @@ CONSTANT: unique5-table 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1600 } -! This is a lookup table for the product of prime values associated with the -! cards in a hand. -CONSTANT: products-table -{ 48 72 80 108 112 120 162 168 176 180 200 208 252 264 270 272 280 300 304 312 -368 378 392 396 405 408 420 440 450 456 464 468 496 500 520 552 567 588 592 594 -612 616 630 656 660 675 680 684 696 700 702 728 744 750 760 780 828 882 888 891 -918 920 924 945 952 968 980 984 990 1020 1026 1044 1050 1053 1064 1092 1100 -1116 1125 1140 1144 1160 1170 1240 1242 1250 1288 1300 1323 1332 1352 1372 1377 -1380 1386 1428 1452 1470 1476 1480 1485 1496 1530 1539 1540 1566 1575 1596 1624 -1638 1640 1650 1672 1674 1700 1710 1716 1736 1740 1750 1755 1768 1820 1860 1863 -1875 1900 1932 1950 1976 1998 2024 2028 2058 2070 2072 2079 2142 2156 2178 2205 -2214 2220 2244 2295 2296 2300 2312 2349 2380 2392 2394 2420 2436 2450 2457 2460 -2475 2508 2511 2548 2550 2552 2565 2574 2584 2604 2610 2625 2652 2660 2728 2750 -2790 2850 2860 2888 2898 2900 2925 2964 2997 3016 3036 3042 3087 3100 3105 3108 -3128 3213 3220 3224 3234 3250 3256 3267 3321 3330 3332 3366 3380 3388 3430 3444 -3450 3465 3468 3496 3588 3591 3608 3630 3654 3675 3690 3700 3724 3740 3762 3822 -3825 3828 3848 3850 3861 3876 3906 3915 3944 3978 4004 4060 4092 4095 4100 4125 -4180 4185 4216 4232 4250 4264 4275 4332 4340 4347 4350 4375 4408 4420 4446 4508 -4524 4550 4554 4563 4650 4662 4692 4712 4732 4750 4802 4836 4851 4875 4884 4940 -4995 4998 5032 5049 5060 5070 5082 5145 5166 5175 5180 5202 5236 5244 5324 5336 -5355 5382 5390 5412 5445 5481 5535 5550 5576 5586 5624 5643 5684 5704 5733 5740 -5742 5750 5772 5775 5780 5814 5852 5859 5916 5950 5967 5980 5985 6050 6076 6125 -6138 6150 6188 6232 6292 6324 6348 6370 6375 6380 6396 6435 6460 6498 6525 6612 -6650 6669 6728 6762 6786 6808 6820 6825 6831 6875 6916 6975 6993 7038 7068 7084 -7098 7125 7150 7192 7203 7220 7245 7250 7252 7254 7326 7436 7497 7540 7544 7546 -7548 7605 7623 7688 7749 7750 7803 7820 7866 7986 8004 8036 8050 8060 8073 8085 -8092 8118 8125 8140 8228 8325 8330 8364 8372 8379 8415 8436 8450 8470 8526 8556 -8575 8584 8613 8625 8658 8670 8721 8740 8788 8874 8918 8925 8932 9009 9020 9044 -9075 9114 9135 9176 9196 9207 9225 9250 9310 9348 9350 9405 9438 9486 9512 9522 -9548 9555 9594 9620 9625 9724 9747 9765 9860 9918 9945 9975 10092 10108 10143 -10150 10168 10179 10212 10250 10450 10540 10556 10557 10580 10602 10625 10647 -10660 10725 10788 10830 10850 10868 10875 10878 10881 10948 10952 10989 11020 -11050 11115 11132 11154 11270 11284 11316 11319 11322 11375 11385 11396 11492 -11532 11625 11655 11662 11780 11781 11799 11830 11858 11875 11979 12005 12006 -12054 12075 12136 12138 12177 12236 12342 12350 12495 12546 12580 12628 12650 -12654 12675 12705 12716 12789 12834 12844 12876 12915 12950 12987 13005 13034 -13156 13167 13182 13310 13311 13340 13377 13448 13455 13468 13475 13671 13764 -13794 13804 13875 13923 13940 13965 14014 14022 14025 14036 14060 14157 14210 -14212 14229 14260 14268 14283 14350 14355 14375 14391 14450 14535 14756 14812 -14875 14877 14924 14950 15004 15028 15125 15138 15162 15190 15225 15252 15318 -15345 15375 15428 15548 15561 15580 15675 15730 15778 15870 15884 15903 15925 -15939 15950 16150 16182 16245 16275 16317 16428 16492 16562 16575 16588 16625 -16698 16731 16796 16820 16905 16965 16974 16983 17020 17050 17204 17238 17298 -17493 17595 17612 17732 17745 17787 17875 17908 17980 18009 18050 18081 18125 -18130 18135 18204 18207 18315 18326 18513 18525 18590 18634 18676 18772 18819 -18837 18850 18860 18865 18975 18981 19074 19220 19228 19251 19266 19314 19375 -19425 19516 19550 19551 19604 19652 19665 19684 19773 19844 19894 19964 19965 -20090 20097 20125 20150 20172 20230 20295 20332 20349 20350 20482 20570 20646 -20691 20825 20956 21021 21033 21054 21125 21164 21175 21266 21315 21402 21460 -21483 21525 21645 21658 21675 21692 21812 21850 21879 21964 21970 22022 22185 -22218 22295 22425 22506 22542 22550 22707 22724 22743 22785 22878 22940 22977 -22990 23125 23188 23275 23276 23322 23375 23452 23548 23595 23667 23715 23751 -23780 23805 23826 23828 23925 23985 24050 24206 24225 24244 24273 24453 24548 -24633 24642 24650 24794 24795 24843 25012 25025 25047 25172 25230 25270 25375 -25382 25389 25420 25461 25575 25625 25636 25641 25857 25916 25947 26026 26125 -26350 26404 26411 26450 26505 26588 26650 26862 26908 27075 27125 27195 27306 -27380 27404 27436 27489 27508 27531 27550 27625 27676 27716 27830 27885 27951 -28126 28158 28175 28275 28305 28322 28413 28611 28652 28730 28798 28830 28899 -28971 29155 29282 29302 29325 29348 29406 29450 29478 29575 29601 29645 29716 -29766 29841 30015 30044 30135 30225 30258 30303 30340 30345 30525 30628 30668 -30723 30758 30855 30875 30932 30969 31059 31213 31262 31365 31372 31434 31450 -31581 31625 31635 31654 31790 31899 31977 32085 32103 32110 32116 32186 32375 -32487 32585 32708 32725 32775 32946 32955 33033 33201 33212 33275 33292 33327 -33350 33418 33524 33579 33620 33759 33813 33825 34276 34317 34485 34606 34684 -34713 34850 34914 34983 35035 35055 35090 35150 35322 35378 35525 35588 35650 -35739 35836 35875 35972 36075 36125 36244 36309 36556 36575 36822 36946 36963 -36975 37004 37030 37076 37107 37191 37323 37375 37444 37468 37510 37518 37570 -37791 37845 37905 37975 38073 38295 38318 38332 38675 38709 38870 38950 38962 -39039 39325 39445 39494 39525 39556 39627 39675 39710 39875 39882 39886 39897 -39975 40052 40204 40222 40293 40362 40375 40455 40508 40817 40898 40959 41070 -41154 41262 41325 41405 41492 41503 41574 41745 41876 42021 42050 42189 42237 -42284 42435 42476 42483 42550 42625 42772 42826 43095 43197 43225 43245 43263 -43732 43911 43923 43953 44109 44175 44198 44217 44252 44275 44289 44506 44649 -44764 44770 44919 44950 44954 45125 45254 45325 45356 45387 45619 45747 45815 -46137 46475 46585 46748 46893 46930 47068 47125 47138 47150 47151 47175 47212 -47396 47481 47619 47685 47804 48050 48165 48279 48285 48314 48334 48484 48668 -48807 48875 49010 49036 49049 49077 49126 49130 49419 49610 49735 49818 49972 -50025 50127 50225 50286 50375 50430 50468 50575 50578 50692 50875 51129 51205 -51425 51615 51646 51842 51909 52173 52234 52275 52316 52325 52371 52390 52514 -52598 52635 52725 52767 52972 52983 53067 53165 53428 53475 53482 53505 53613 -53650 53754 53958 53998 54145 54188 54418 54549 54625 54910 54925 55055 55223 -55233 55419 55506 55545 55594 55796 55825 55924 56265 56277 56355 56375 56525 -56637 57122 57188 57195 57350 57475 57477 57498 57681 57722 57868 57967 58190 -58305 58311 58425 58443 58870 59204 59241 59409 59450 59565 59644 59675 59774 -59823 59829 60125 60236 60306 60333 60515 60543 60775 61132 61226 61347 61364 -61370 61605 61625 61642 61659 61731 61828 61893 61985 62271 62361 62530 62678 -62814 63075 63175 63206 63426 63455 63550 63825 63916 64124 64141 64158 64239 -64467 64676 65065 65219 65348 65366 65596 65598 65702 65875 65975 66033 66092 -66125 66297 66470 66625 66748 66759 66861 67146 67155 67270 67425 67431 67599 -67881 67925 68265 68306 68324 68425 68450 68590 68614 68770 68782 68875 68894 -68913 69003 69290 69454 69575 69597 69629 69874 69938 70315 70395 70525 70587 -70602 70642 70707 70725 70805 71094 71188 71225 71668 71687 71825 71995 72075 -72261 72358 72471 72501 72964 73002 73036 73205 73255 73346 73515 73593 73625 -73689 73695 73964 74415 74431 74698 74727 74907 74958 75429 75645 75803 75850 -75867 76342 76475 76874 76895 77077 77121 77198 77372 77469 77763 77996 78039 -78155 78166 78292 78351 78585 78625 78771 78884 78897 78925 79135 79475 80073 -80142 80223 80275 80465 80475 80631 80852 80937 80997 81466 81548 81549 81627 -82225 82251 82365 82418 82522 82654 82708 83030 83259 83375 83391 83398 83421 -83486 83545 83810 84050 84175 84249 84303 84721 85514 85683 85782 85918 86025 -86247 86275 86428 86515 86583 86756 86779 87125 87172 87285 87362 87412 87542 -87725 87875 88102 88305 88412 88445 88806 88825 88837 89001 89125 89175 89590 -89661 89930 90117 90354 90364 90459 91091 91143 91234 91839 92046 92055 92225 -92365 92414 92463 92510 92575 93058 93092 93275 93357 93775 93795 93925 94017 -94178 94221 94622 94809 95139 95325 95571 95795 95830 95874 96026 96237 96278 -96425 96596 97006 97175 97375 97405 97526 97556 97682 98022 98049 98394 98397 -98441 98494 98553 98716 98735 99127 99275 99567 99705 99715 100510 100555 -100719 100793 100905 101062 102051 102245 102459 102487 102557 102675 102885 -102921 103075 103155 103156 103173 103246 103341 103675 103935 104044 104181 -104284 104690 104811 104907 104975 105125 105154 105183 105524 105710 105754 -105903 105963 106227 106375 106641 106782 106930 107065 107525 107559 107653 -107822 108086 108537 109089 109142 109174 109330 109388 109417 109503 109554 -110019 110075 110331 110495 110789 110825 110946 111265 111476 111910 111925 -112047 112375 112385 112406 112437 112651 113135 113553 113775 114057 114308 -114513 115258 115292 115311 115797 116058 116242 116402 116522 116725 116932 -116963 117249 117325 117334 117438 117670 117711 117845 117875 118490 119119 -119164 119187 119306 120125 120175 120213 120785 120802 120835 121121 121670 -121923 121975 122018 122199 122525 122815 122825 123025 123627 123783 123823 -123981 124025 124468 124545 124558 124775 124930 125097 125229 125426 125541 -125715 125829 125902 125948 126075 126445 127075 127426 127534 127738 127756 -128018 128271 128673 128877 128986 129115 129311 129514 129605 130134 130203 -130585 130975 131043 131118 131285 131313 131495 132153 132158 132275 132618 -133052 133133 133209 133342 133570 133705 134113 134125 134162 134199 134385 -134895 134995 135014 135531 135575 136045 136214 136325 136367 136851 137275 -137547 137566 137924 138069 138229 138621 138765 138985 139113 139564 139587 -139601 139638 140714 140777 141267 141933 142025 142228 142538 142766 142805 -142970 143143 143375 143745 143811 144039 144279 144305 144417 144925 145475 -145509 145521 146234 146289 146334 146523 146566 146575 147033 147175 147436 -147591 147706 147741 147994 148010 148625 148666 148707 148925 149435 149702 -149891 150183 150590 150765 150898 151294 151525 151593 152218 152438 153062 -153065 153410 153425 153729 154105 154652 154693 154869 155771 156066 156325 -156426 156674 156695 157035 157325 157339 157604 157731 158015 158389 158565 -158631 158804 158875 159562 159790 160173 160225 160395 161161 161253 161414 -161733 161975 162129 162578 163370 163415 163713 163761 163990 163995 164169 -164255 164331 164738 164983 165025 165886 166175 166419 166634 167042 167214 -167865 168175 168609 168674 169099 169169 169756 170126 170338 170765 171125 -171275 171462 171475 171535 171925 171941 171955 172235 172546 172822 172887 -172975 173225 173635 174087 174097 174363 174603 174685 174783 174845 174902 -175491 175972 176001 176157 176505 176605 177023 177489 177735 177970 178126 -178334 178746 178802 178959 179075 180154 180761 180895 181203 181447 181917 -182505 182590 182666 182819 183027 183365 183425 183483 183799 184093 184382 -184910 185725 186093 186238 186694 186702 186745 186837 186998 187187 187395 -187775 188108 188139 188518 188853 188922 188993 189625 190333 190463 190855 -191139 191301 191425 191607 191634 191675 192027 192185 192995 193325 193430 -193479 194271 194463 194579 194996 195201 195415 195730 196075 196137 196677 -197098 197846 198237 198927 199082 199927 200013 200158 200355 200725 201243 -202027 202521 202612 203203 203319 203522 203665 204321 204425 205751 205942 -206045 206305 206349 206635 206886 207214 207575 208075 208444 208495 208658 -208715 209209 209457 209525 210125 210749 210826 211071 212602 213342 213785 -213807 214149 214225 214291 214455 214774 214795 215747 215878 216775 216890 -217217 217341 217558 217906 218405 218530 218855 219351 219373 219501 219849 -220255 221030 221122 221221 221559 221991 222015 222111 222425 222999 223706 -223975 224516 224553 224825 224939 225446 225885 225998 226347 226525 226941 -228085 228206 228327 228475 228657 228718 228781 229586 229593 229957 230115 -230318 231035 231275 231725 231978 232101 232562 232645 232730 232934 233206 -233818 234025 234099 234175 234639 235011 235246 235445 235543 235586 236406 -236555 237429 237614 238206 239071 239343 239575 239685 240065 240149 240526 -240695 240737 240994 241129 242121 242515 243089 243815 243867 243890 244205 -244559 244783 245055 245985 246123 246202 246235 247107 247225 247247 248788 -248829 248897 249067 249158 249951 250325 250563 250821 251275 252586 252655 -253011 253175 253253 254634 255189 255507 255626 256711 257193 258115 258819 -258874 259233 259259 259325 259407 259666 260110 260642 260678 260710 261326 -261443 261725 262353 262885 263097 263302 264275 264385 265475 265727 265837 -266955 267189 267197 267325 267501 267674 268119 268203 269059 269555 270193 -270215 270231 270802 272194 272855 272935 273325 273581 273885 273999 274022 -274846 275684 276573 276575 277365 277574 278018 278179 278369 278690 279357 -279775 280041 280053 280497 281015 282302 282777 283383 283475 284053 284258 -284954 285131 285770 287287 287451 287638 287738 288145 288463 288827 289289 -290145 290605 290966 291005 291305 291893 292175 292201 292494 293335 293595 -293854 294151 294175 295075 295647 296225 296769 296989 297910 298265 298623 -298775 299299 299367 300237 300713 302005 303025 303646 303862 303918 304175 -304606 305045 305283 305762 305767 305942 306397 306475 307582 308074 308357 -308913 309442 310329 310821 311170 311395 312325 312666 312987 313565 314019 -314041 314171 314534 314755 314870 315425 315514 316239 316342 316825 317471 -318478 318565 318734 318835 318903 319319 319345 319390 320013 320045 322161 -322465 323449 323785 323817 324818 325335 325622 325703 325822 326337 326859 -326975 327795 328757 329623 330395 331075 331177 331298 331545 331683 331731 -333355 333925 335405 335559 335699 336091 336743 336774 336973 337502 337535 -338169 338675 338997 339031 339521 340442 340535 341341 341446 341734 341887 -342309 343077 343915 344379 344729 344810 345477 347282 347633 347967 348725 -348843 349095 349401 349525 349809 350727 350987 351538 351785 352869 353379 -353717 354609 355570 355946 356345 356421 356915 357309 357425 359414 359513 -360778 360789 361361 361491 361675 362674 363562 364021 364154 364994 365585 -365835 366415 367114 368039 369265 369303 369985 370025 370139 371665 371722 -372775 373182 373737 374255 375193 375683 376475 377245 377377 378235 378301 -378879 378917 380494 380545 381095 381938 381951 381997 382075 382109 382655 -383439 383525 384307 384659 384826 385526 386425 386630 387686 388311 388531 -389499 390165 390166 390963 391017 391065 391534 391685 391989 393421 394010 -394953 395937 397010 397822 397969 398866 398905 399475 400078 400673 400775 -401511 401698 401882 402866 403403 403535 404225 406203 406334 406445 406802 -406847 407407 407827 408291 408425 409975 410669 410839 411033 411845 412114 -412269 413075 413526 413678 414715 415454 416361 416585 417027 417074 417175 -417571 417605 418035 419881 421685 422807 423243 423453 424390 424589 424762 -424879 425258 425315 425546 425845 426374 426387 427025 427063 427431 428655 -429598 429913 430606 431365 431457 431607 432055 435638 435953 436449 437255 -438741 438991 440657 440781 440818 443989 444925 445315 445835 445991 446369 -446865 447005 447083 447146 447811 447925 448063 450262 450385 451451 453299 -453871 454138 454181 454597 455469 455793 455877 456025 456475 456665 456909 -458643 458689 458913 458983 459173 460955 461373 462111 462275 462346 462553 -462722 464163 465595 466697 466735 466755 467495 468999 469567 470327 471295 -471801 472305 472549 473271 474513 474734 476749 477158 477717 478101 479085 -480491 480766 481481 481574 482734 483575 484561 485537 486098 486266 487227 -487475 487490 488433 488733 489325 490637 491878 492499 492745 493025 494615 -496223 496947 497705 497798 498883 499681 500395 501787 502918 503234 505161 -505325 506253 506530 507566 508079 508277 508805 508898 509675 510663 511819 -512006 512169 512601 512746 512981 514786 514855 516925 516971 517215 517979 -518035 519622 520331 520421 520923 521110 521594 521645 523957 527065 527307 -528143 529529 531505 532763 533355 533533 533919 535717 536393 536558 536935 -537251 539121 539695 540175 541167 541282 541717 542087 542225 542659 543286 -543895 544011 544765 544825 545054 545343 546231 546325 547491 548359 550671 -551614 552575 552805 555458 555611 555814 555841 557566 557583 558467 559265 -559682 559773 561290 562438 563615 563914 564775 564949 564995 567853 568178 -569023 570515 570741 571795 572242 572663 572907 573562 573965 574678 575795 -576583 577239 578289 578347 579945 580601 581405 581529 581647 581825 582335 -582958 583015 583219 584545 584647 585249 585599 587301 588115 588965 590359 -591015 593021 593929 594035 594146 594473 595441 595515 596183 596733 598299 -600117 600281 600457 600691 601315 602485 602547 602823 603725 603911 604299 -604877 605098 607202 609501 609725 610203 612157 613118 614422 615043 615505 -616975 618171 618233 620194 620289 620517 620806 620977 621970 622895 623162 -623181 623441 624169 625611 625807 628694 630539 631465 633919 634114 634933 -636585 637143 637887 638319 639065 639331 639561 640211 640871 644397 644725 -645337 645909 647185 648907 649078 649165 650275 651605 651695 651775 651833 -653315 653429 653457 654493 655402 656183 656903 657662 658255 659525 659813 -661227 662966 663803 664411 665482 669185 670719 671099 675393 676286 677005 -677846 680485 680846 681207 682486 683501 683675 684574 685055 685069 687115 -687242 687401 689210 689843 692461 692714 693519 693842 693935 694083 695045 -696725 696787 700553 700843 701437 702559 702658 704099 705686 705755 708883 -709142 709423 709631 710645 712101 712327 712385 714425 715737 719095 719345 -720575 720797 721149 722361 724101 724594 725249 726869 727415 729147 729399 -729554 730303 730639 730825 731235 733381 734635 734638 735034 737426 737817 -737891 742577 743002 743774 744107 744775 746697 748867 749177 751502 751709 -754354 754377 754851 755573 756613 757393 758582 759115 759655 759795 761349 -761453 761515 762671 763347 764405 764855 768009 768955 769119 770185 772179 -773605 773927 774566 774706 775489 777925 779433 781665 782254 782391 782971 -783959 785213 785519 785806 786335 787175 788785 789061 790855 790993 791282 -792281 793117 796195 796835 798475 798721 800513 803551 804287 804837 806113 -809042 809627 811923 812045 812383 813967 814055 814555 814929 815269 816221 -817581 817663 818363 818662 823361 824182 824551 827421 828134 828245 828269 -828971 829226 829939 830297 830414 831575 831649 832117 833187 833721 836349 -836969 837199 838409 839523 839914 841841 841935 843479 843657 843755 845871 -850586 851105 852267 853615 854335 858363 858458 859027 860343 861707 862017 -862025 866723 866822 868205 870758 872053 872275 873422 874437 876826 877591 -877933 878845 884051 884374 885391 886414 887777 888925 889778 889865 891219 -893809 894179 894691 896506 898535 898909 900358 901945 906059 906685 907647 -908831 908905 910385 910803 912247 912373 912485 914641 916487 917662 917785 -918731 919677 921475 921557 921633 924482 926497 926782 927707 927979 929305 -930291 931209 932955 933658 934743 935693 936859 943041 947546 947807 949003 -950521 951142 951171 951235 952679 954845 955451 959077 960089 961961 962065 -963815 964894 966329 966575 969215 971509 971618 973063 973617 975415 978835 -979693 980837 983103 983411 985025 986493 988057 988418 989417 990437 990698 -990847 992525 994449 994555 994903 997165 997339 997694 998223 998963 1000195 -1004245 1004663 1004705 1005238 1006733 1007083 1007165 1012894 1013173 1014101 -1014429 1015835 1016738 1016769 1017005 1018381 1021269 1023729 1024309 1024426 -1026817 1026861 1028489 1030285 1030863 1032226 1033815 1034195 1036849 1037153 -1038635 1039071 1040763 1042685 1049191 1053987 1056757 1057978 1058529 1058743 -1059022 1060975 1061905 1062761 1063145 1063517 1063713 1063865 1065935 1066121 -1067857 1070167 1070558 1070797 1072478 1073995 1076515 1076537 1078259 1083047 -1083121 1084039 1085773 1085926 1086891 1088153 1089095 1094331 1094951 1095274 -1096381 1099825 1100869 1101957 1102045 1102551 1103414 1104299 1105819 1106139 -1106959 1107197 1114366 1114503 1114673 1115569 1115661 1117865 1119371 1121549 -1121894 1123343 1125655 1127253 1131531 1132058 1132681 1133407 1135234 1135345 -1136863 1137873 1139677 1140377 1146442 1147619 1155865 1156805 1157819 1159171 -1159543 1161849 1162059 1162213 1169311 1171001 1172354 1173381 1175675 1178709 -1181257 1182446 1183301 1186835 1186923 1187329 1191547 1192895 1195061 1196069 -1196506 1196569 1198483 1199266 1201915 1203935 1206835 1208938 1209271 1210547 -1211573 1213511 1213526 1213563 1213682 1215245 1215487 1215665 1216171 1218725 -1225367 1227993 1229695 1230383 1234838 1236273 1239953 1242201 1242989 1243839 -1244495 1245621 1245811 1255133 1255501 1257295 1257949 1257962 1258085 1259871 -1262723 1263661 1266325 1266749 1267474 1268915 1269359 1272245 1272467 1274539 -1275879 1277479 1279091 1280015 1281137 1281865 1281974 1282633 1284899 1285999 -1286965 1287687 1292669 1293853 1294033 1295723 1299055 1300233 1301027 1302775 -1303985 1306137 1306877 1310133 1310278 1314542 1315239 1316978 1322893 1325467 -1326561 1329621 1331729 1334667 1336783 1338623 1339634 1340003 1341395 1344718 -1344759 1346891 1349341 1349834 1350537 1351166 1353205 1354111 1354886 1356277 -1356901 1358215 1362635 1365581 1368334 1370369 1370386 1372019 1376493 1379035 -1381913 1386723 1388645 1389223 1389535 1390173 1392377 1393915 1396031 1399205 -1400273 1400487 1403207 1403225 1405943 1406095 1406587 1409785 1410031 1412327 -1414127 1414562 1416389 1420445 1421319 1422169 1423807 1426713 1428163 1430605 -1431382 1432417 1433531 1433729 1433905 1436695 1437293 1442399 1442926 1446071 -1447341 1447873 1448161 1448402 1454089 1457395 1457427 1459354 1459759 1465399 -1466641 1468987 1469194 1472207 1482627 1483339 1485365 1486047 1486667 1488403 -1489411 1492309 1496541 1497067 1497238 1503593 1507121 1507857 1508638 1511653 -1512118 1512745 1514071 1515839 1516262 1518005 1519341 1519817 1524733 1525107 -1526657 1529099 1531309 1532795 1533433 1536055 1536639 1542863 1544491 1548339 -1550485 1552015 1552661 1554925 1557905 1563419 1565011 1566461 1567247 1571735 -1575917 1582009 1582559 1583023 1585285 1586126 1586899 1586967 1588533 1589483 -1600313 1602403 1604986 1605837 1608717 1612682 1616197 1616402 1617122 1618211 -1619527 1622695 1628889 1629887 1635622 1638505 1639187 1641809 1642911 1644155 -1655121 1657415 1657466 1661569 1663705 1670053 1671241 1671549 1675333 1681691 -1682681 1682841 1685509 1687829 1689569 1690715 1691701 1692197 1694173 1694407 -1694615 1698087 1698619 1701343 1701931 1702115 1702851 1706215 1709659 1711435 -1711463 1718105 1719663 1721573 1722202 1723025 1727878 1729937 1731785 1734605 -1735327 1739881 1742293 1750507 1751629 1753037 1756645 1758531 1760213 1761319 -1764215 1769261 1771774 1772855 1773593 1773669 1776481 1778498 1781143 1786499 -1790921 1791946 1792021 1794611 1794759 1798899 1801751 1804231 1804786 1806091 -1807117 1811485 1812446 1813407 1818677 1820289 1820523 1822139 1823885 1825579 -1826246 1834963 1836595 1837585 1843565 1847042 1847677 1849243 1852201 1852257 -1852462 1856261 1857505 1859435 1869647 1870297 1872431 1877953 1878755 1879537 -1885885 1886943 1891279 1894487 1896455 1901211 1901501 1907689 1908386 1910051 -1916291 1920983 1922961 1924814 1929254 1930649 1933459 1936415 1936765 1939751 -1944103 1945349 1951481 1952194 1955635 1956449 1957703 1958887 1964515 1965417 -1968533 1971813 1973699 1975103 1975467 1976777 1978205 1979939 1980218 1982251 -1984279 1987453 1988623 1994707 1999283 1999591 1999898 2002481 2002847 2007467 -2009451 2011373 2017077 2019127 2019719 2022605 2024751 2026749 2032329 2040353 -2044471 2046655 2048449 2050841 2052501 2055579 2056223 2060455 2062306 2066801 -2070107 2070335 2071771 2073065 2076035 2079511 2092717 2099785 2100659 2111317 -2114698 2116543 2117843 2120393 2121843 2125207 2126465 2132273 2132902 2137822 -2141737 2145913 2146145 2146981 2147073 2150477 2153437 2155657 2164389 2167055 -2167957 2170679 2172603 2172821 2176895 2181067 2183555 2188021 2189031 2192065 -2193763 2200429 2203791 2204534 2207161 2209339 2210351 2210935 2212873 2215457 -2215763 2216035 2219399 2221271 2224445 2234837 2237411 2238067 2241265 2242454 -2245857 2250895 2257333 2262957 2266627 2268177 2271773 2274393 2275229 2284997 -2285258 2289443 2293907 2294155 2301817 2302658 2304323 2311205 2313649 2316955 -2320381 2329187 2330038 2334145 2336191 2338919 2340503 2343314 2345057 2357381 -2359379 2362789 2363153 2363486 2367001 2368333 2368865 2372461 2377855 2379189 -2382961 2386241 2388701 2396009 2397106 2399567 2405347 2407479 2412235 2416193 -2419023 2422109 2424499 2424603 2425683 2428447 2429045 2442862 2444923 2445773 -2453433 2459303 2461462 2466827 2469901 2471045 2473211 2476441 2476745 2481997 -2482597 2486199 2494235 2497759 2501369 2501917 2505919 2513095 2519959 2532235 -2536079 2541845 2542903 2544971 2551594 2553439 2561065 2571233 2572619 2580565 -2580991 2581934 2582827 2583303 2585843 2589151 2591817 2592629 2598977 2600507 -2603209 2611037 2612233 2614447 2618629 2618998 2624369 2630257 2631218 2636953 -2640239 2641171 2644213 2644945 2647555 2648657 2655037 2657661 2667747 2673539 -2674463 2676395 2678741 2681195 2681869 2687919 2688907 2700451 2705329 2707063 -2707179 2709239 2710981 2711471 2714815 2718669 2732561 2733511 2737889 2738185 -2739369 2750321 2758535 2760953 2764177 2766049 2767787 2769487 2770563 2771431 -2778693 2785915 2791613 2792387 2798939 2804735 2816033 2820103 2827442 2830145 -2831323 2831647 2838085 2857921 2861062 2862579 2865317 2866105 2868767 2884637 -2886689 2887221 2893757 2893881 2898469 2902291 2904739 2906449 2915674 2922029 -2926703 2928291 2930885 2937874 2939699 2951069 2951897 2956115 2970327 2977051 -2986159 2988073 2991265 2997383 2997797 2998165 2999847 3004603 3005249 3007693 -3022345 3022438 3025541 3027973 3033815 3033877 3034205 3047653 3055019 3056977 -3066613 3068891 3078251 3082729 3085771 3087095 3090277 3093409 3093459 3095309 -3101527 3102449 3114223 3120469 3124979 3130231 3137771 3140486 3144905 3147331 -3151253 3154591 3159637 3160729 3168685 3170366 3172047 3192101 3197207 3199353 -3204935 3206269 3206733 3211817 3230882 3234199 3235687 3243737 3246473 3255482 -3267803 3268967 3271021 3275695 3276971 3286355 3292445 3295331 3299179 3306801 -3307837 3308987 3316411 3328039 3328997 3332849 3339611 3346109 3349085 3361795 -3363681 3372149 3374585 3377129 3377543 3377915 3379321 3381487 3387215 3390361 -3400663 3411067 3414433 3415997 3420835 3424361 3425965 3427391 3427887 3445403 -3453839 3453987 3457817 3459463 3467443 3479998 3487583 3487627 3491929 3494413 -3495057 3502969 3514971 3516263 3518333 3531359 3536405 3537193 3542851 3545129 -3545229 3558583 3569929 3578455 3585491 3595659 3604711 3607315 3607426 3610477 -3612791 3614693 3617141 3621005 3624179 3628411 3637933 3646313 3648385 3651583 -3655847 3660151 3662497 3664293 3665441 3672985 3683017 3692193 3693157 3702923 -3706577 3719573 3728153 3735407 3743095 3744653 3746953 3748322 3753673 3765157 -3771595 3779309 3779831 3780295 3789227 3790655 3800741 3809927 3816131 3817879 -3827227 3827391 3833459 3856214 3860173 3861949 3864619 3872901 3881273 3900281 -3915083 3926629 3928497 3929941 3933137 3946813 3946827 3962203 3965315 3973319 -3985267 3993743 3997418 4012465 4012547 4024823 4031261 4031705 4035239 4039951 -4040509 4041005 4042687 4042805 4050553 4055843 4081181 4086511 4089055 4090757 -4093379 4103239 4121741 4131833 4133261 4138561 4143665 4148947 4153546 4170751 -4172201 4180963 4187771 4197431 4219007 4221811 4231283 4241163 4247341 4247887 -4260113 4260883 4273102 4274803 4277489 4291593 4302397 4305505 4309279 4314311 -4319695 4321933 4325633 4352051 4358341 4373511 4375681 4392287 4395859 4402867 -4405999 4406811 4416787 4425499 4429435 4433549 4436159 4446245 4449731 4458389 -4459939 4467073 4479865 4486909 4502641 4509973 4511965 4531115 4533001 4533657 -4554737 4560743 4565615 4567277 4574953 4585973 4586959 4600897 4602578 4609423 -4617605 4617931 4619527 4621643 4631155 4632959 4672841 4678223 4688719 4706513 -4709861 4710729 4721393 4721519 4724419 4729081 4739311 4742101 4755549 4757297 -4767521 4770965 4775147 4777721 4780723 4789169 4793269 4796351 4803821 4812035 -4821877 4822543 4823135 4829513 4834531 4846323 4864057 4871087 4875277 4880485 -4883223 4884763 4890467 4893779 4903301 4930783 4936409 4940377 4950545 4950967 -4951969 4955143 4999745 5009837 5034679 5035589 5047141 5050241 5069407 5084651 -5097301 5100154 5107739 5135119 5142179 5143333 5155765 5161217 5178013 5211503 -5219997 5222587 5231281 5240333 5258773 5271649 5276851 5280233 5286745 5292413 -5296877 5306917 5316979 5321303 5323153 5332255 5343161 5343899 5344555 5357183 -5382871 5389969 5397691 5411139 5436299 5448839 5459441 5487317 5511335 5517163 -5528809 5538101 5551441 5570917 5579977 5590127 5592059 5606135 5617451 5621447 -5622483 5634343 5635211 5644387 5651522 5656597 5657407 5659927 5677243 5690267 -5699369 5713145 5724677 5748431 5756645 5761691 5768419 5783557 5784321 5787191 -5801131 5818879 5824621 5825095 5827289 5837009 5841557 5852327 5858285 5888069 -5891843 5896579 5897657 5898629 5908715 5920039 5964803 5972593 5975653 5992765 -5996127 5998331 6009133 6024007 6024083 6027707 6047573 6068777 6107155 6129013 -6153655 6159049 6166241 6170417 6182423 6201209 6224743 6226319 6229171 6230319 -6243787 6244423 6247789 6268121 6271811 6298177 6305431 6315517 6316751 6322079 -6343561 6378985 6387767 6391861 6409653 6412009 6424717 6439537 6447947 6454835 -6464647 6468037 6483617 6485011 6503453 6528799 6534047 6547495 6578045 6580783 -6583811 6585001 6591499 6595963 6608797 6649159 6658769 6674393 6675251 6679351 -6704017 6709469 6725897 6736849 6752389 6791609 6832679 6876857 6883643 6903867 -6918791 6930763 6958627 6971107 6979061 6982823 6999643 7005547 7039139 7048421 -7050857 7058519 7065853 7068605 7119281 7132231 7139269 7152655 7166363 7172191 -7206529 7218071 7229981 7243379 7289185 7292311 7296893 7344685 7358377 7359707 -7367987 7379021 7395949 7401443 7424087 7431413 7434817 7451873 7453021 7464397 -7465157 7482377 7517179 7525837 7534519 7537123 7556095 7563113 7620301 7624109 -7650231 7653043 7685899 7715869 7777289 7780091 7795229 7800127 7829729 7848589 -7851215 7858097 7867273 7872601 7877647 7887919 7888933 7903283 7925915 7936093 -7947563 7966211 7979183 7998403 8026447 8054141 8059303 8077205 8080567 8084707 -8115389 8138705 8155133 8155351 8176753 8201599 8234809 8238581 8258753 8272201 -8297509 8316649 8329847 8332831 8339441 8389871 8401553 8420933 8448337 8452891 -8477283 8480399 8516807 8544523 8550017 8553401 8560357 8609599 8615117 8642273 -8675071 8699995 8707621 8717789 8723693 8740667 8773921 8782579 8804429 8806759 -8827423 8869751 8890211 8894171 8907509 8909119 8930579 8992813 8995921 9001687 -9018565 9035849 9036769 9099743 9116063 9166493 9194653 9209263 9230371 9303983 -9309829 9370805 9379019 9389971 9411631 9414613 9472111 9478093 9485801 9503329 -9523541 9536099 9549761 9613007 9622493 9640535 9649489 9659011 9732047 9744757 -9781739 9806147 9828767 9855703 9872267 9896047 9926323 9965009 9968453 9993545 -10013717 10044353 10050791 10060709 10083499 10158731 10170301 10188541 -10193761 10204859 10232447 10275973 10282559 10309819 10314971 10316297 -10354117 10383865 10405103 10432409 10482433 10496123 10506613 10511293 -10553113 10578533 10586477 10610897 10631543 10652251 10657993 10682755 -10692677 10737067 10754551 10773529 10784723 10891199 10896779 10938133 -10991701 10999439 11096281 11137363 11173607 11194313 11231207 11233237 -11308087 11342683 11366807 11386889 11393027 11394187 11430103 11473481 -11473589 11484911 11506445 11516531 11528497 11529979 11560237 11630839 -11647649 11648281 11692487 11730961 11731109 11758021 11780899 11870599 -11950639 12005773 12007943 12023777 12041003 12124937 12166747 12178753 -12179993 12264871 12311417 12333497 12404509 12447641 12488149 12511291 -12540151 12568919 12595651 12625991 12664619 12689261 12713977 12726523 -12750385 12774821 12815209 12823423 12836077 12853003 12871417 12888227 -12901781 12999173 12999337 13018667 13055191 13119127 13184083 13306099 -13404989 13435741 13438339 13482071 13496749 13538041 13590803 13598129 -13642381 13707797 13739417 13745537 13759819 13791559 13863863 13895843 -13902787 13955549 13957343 13990963 14033767 14088461 14128805 14200637 -14223761 14329471 14332061 14365121 14404489 14466563 14471699 14537411 -14575951 14638717 14686963 14742701 14854177 14955857 14967277 15060079 -15068197 15117233 15145247 15231541 15247367 15320479 15340681 15355819 -15362659 15405791 15464257 15523091 15538409 15550931 15581189 15699857 -15735841 15745927 15759439 15878603 15881473 15999503 16036207 16109023 -16158307 16221281 16267463 16360919 16398659 16414841 16460893 16585361 -16593649 16623409 16656623 16782571 16831853 16895731 16976747 16999133 -17023487 17102917 17145467 17218237 17272673 17349337 17389357 17437013 -17529601 17546899 17596127 17598389 17769851 17850539 17905151 17974933 -18129667 18171487 18240449 18285733 18327913 18378373 18457339 18545843 -18588623 18596903 18738539 18809653 18812071 18951881 18999031 19060859 -19096181 19139989 19424693 19498411 19572593 19591907 19645847 19780327 -19805323 19840843 19870597 19918169 20089631 20262569 20309309 20375401 -20413159 20452727 20607379 20615771 20755039 20764327 20843129 20922427 -20943073 21000733 21001829 21160633 21209177 21240983 21303313 21688549 -21709951 21875251 21925711 21946439 21985799 22135361 22186421 22261483 -22365353 22450231 22453117 22619987 22772507 22844503 22998827 23207189 -23272297 23383889 23437829 23448269 23502061 23716519 24033257 24240143 -24319027 24364093 24528373 24584953 24783229 24877283 24880481 24971929 -24996571 25054231 25065391 25314179 25352141 25690723 25788221 25983217 -26169397 26280467 26480567 26694131 26782109 26795437 26860699 26948111 -26998049 27180089 27462497 27566719 27671597 27698903 27775163 27909803 -27974183 28050847 28092913 28306813 28713161 28998521 29343331 29579983 -29692241 29834617 29903437 29916757 30118477 30259007 30663121 30693379 -30927079 30998419 31083371 31860737 31965743 32515583 32777819 32902213 -33059981 33136241 33151001 33388541 33530251 33785551 33978053 34170277 -34270547 34758037 35305141 35421499 35609059 35691199 36115589 36321367 -36459209 36634033 36734893 36998113 37155143 37438043 37864361 37975471 -38152661 39121913 39458687 39549707 40019977 40594469 40783879 40997909 -41485399 42277273 42599173 43105703 43351309 43724491 43825351 44346461 -45192947 45537047 45970307 46847789 47204489 47765779 48037937 48451463 -48677533 49140673 50078671 50459971 52307677 52929647 53689459 53939969 -54350669 55915103 57962561 58098991 58651771 59771317 60226417 61959979 -64379963 64992503 66233081 66737381 71339959 73952233 76840601 79052387 -81947069 85147693 87598591 94352849 104553157 } +! This is a lookup table for the perfect hash adjustment values. +CONSTANT: adjustments-table +{ 0 5628 7017 1298 2918 2442 8070 6383 6383 7425 2442 5628 8044 7425 3155 6383 +2918 7452 1533 6849 5586 7452 7452 1533 2209 6029 2794 3509 7992 7733 7452 131 +6029 4491 1814 7452 6110 3155 7077 6675 532 1334 7555 5325 3056 1403 1403 3969 +4491 1403 7592 522 8070 1403 0 1905 3584 2918 922 3304 6675 0 7622 7017 3210 +2139 1403 5225 0 3969 7992 5743 5499 5499 5345 7452 522 305 3056 7017 7017 2139 +1338 3056 7452 1403 6799 3204 3290 4099 1814 2191 4099 5743 1570 1334 7363 1905 +0 6799 4400 1480 6029 1905 0 7525 2028 2794 131 7646 3155 4986 1858 2442 7992 +1607 3584 4986 706 6029 5345 7622 6322 5196 1905 6847 218 1785 0 4099 2981 6849 +4751 3950 7733 3056 5499 4055 6849 1533 131 5196 2918 3879 5325 2794 6029 0 0 +322 7452 6178 2918 2320 6675 3056 6675 1533 6029 1428 2280 2171 6788 7452 3325 +107 4262 311 5562 7857 6110 2139 4942 4600 1905 0 3083 5345 7452 6675 0 6112 +4099 7017 1338 6799 2918 1232 3584 522 6029 5325 1403 6759 6849 508 6675 2987 +7745 6870 896 7452 1232 4400 12 2981 3850 4491 6849 0 6675 747 4491 7525 6675 +7452 7992 6921 7323 6849 3056 1199 2139 6029 6029 190 4351 7891 4400 7134 1533 +1194 3950 6675 5345 6383 7622 131 1905 2883 6383 1533 5345 2794 4303 1403 0 +1338 2794 992 4871 6383 4099 2794 3889 6184 3304 1905 6383 3950 3056 522 1810 +3975 7622 7452 522 6799 5866 7084 7622 6528 2798 7452 1810 7907 642 5345 1905 +6849 6675 7745 2918 4751 3229 2139 6029 5207 6601 2139 7452 5890 1428 5628 7622 +2139 3146 2400 578 941 7672 1814 3210 1533 4491 12 2918 1900 7425 2794 2987 +3465 1377 3822 3969 3210 859 5499 6878 1377 3056 4027 8065 8065 5207 4400 4303 +3210 3210 0 6675 357 5628 5512 1905 3452 1403 7646 859 6788 3210 2139 378 5663 +7733 870 0 4491 4813 2110 578 2139 3056 4099 1905 1298 4672 2191 3950 5499 3969 +4974 6323 6029 7414 6383 0 4974 3210 795 4099 131 5345 5345 6576 1810 1621 4400 +2918 1905 2442 2679 6322 7452 2110 1403 6383 2653 5132 6856 7841 2794 6110 2028 +6675 7425 6999 7441 6029 183 6675 4400 859 1403 2794 5985 5345 1533 322 4400 +1227 5890 4474 4491 3574 8166 6849 7086 5345 5345 5459 3584 6675 3969 7579 8044 +2295 2577 1480 5743 3304 5499 330 4303 6863 3822 4600 4751 5628 3822 2918 6675 +2400 6663 1403 6849 6029 3145 6110 3210 747 3229 3056 2918 7733 330 4055 7322 +5628 2987 3056 1905 2903 669 5325 2845 4099 5225 6283 4099 5000 642 4055 5345 +8034 2918 1041 5769 7051 1538 2918 3366 608 4303 3921 0 2918 1905 218 6687 5963 +859 3083 2987 896 5056 1905 2918 4415 7966 7646 2883 5628 7017 8029 6528 4474 +6322 5562 6669 4610 7006 } -! This is a lookup table for the final hand values of all hands not covered in -! the flushes and unique5 tables above. +! This is a lookup table for the perfect hash final hand values. CONSTANT: values-table -{ 166 322 165 310 164 2467 154 2466 163 3325 321 162 3324 2464 2401 161 2465 -3314 160 2461 159 2400 320 3323 153 2457 6185 2463 3303 2452 158 3322 157 298 -2460 2446 152 3292 156 2398 3321 2462 5965 155 6184 309 2456 3320 2439 3313 -2395 2459 2431 2335 2451 6181 3319 3281 2422 151 2391 2445 6183 2399 2455 319 -3291 2412 5964 6175 2386 3318 5745 150 2450 6180 3312 3317 297 6165 2458 2438 -5961 2430 2380 142 2444 3311 308 3316 318 286 149 6150 5963 6174 3259 5525 3315 -2421 2397 2454 5955 148 6182 2373 3302 6164 2437 5960 2411 5744 2449 2365 3310 -5945 6178 2429 6129 2334 2394 2453 6179 6101 147 141 3309 6149 5741 2448 2356 -2443 3215 2269 5930 2420 2396 5954 3290 3248 3280 2346 6065 6172 2390 2410 3308 -317 146 6173 2442 5944 3258 6128 3270 2393 6020 3301 6162 145 3289 5735 2436 -2385 5958 2447 6100 5909 2333 6169 6163 2428 2332 5881 5725 6177 316 5929 3307 -3300 6159 144 2435 6147 3204 285 3306 2379 6064 2441 2389 6148 2427 5524 2329 -2419 307 143 5845 3288 5952 3214 3257 2268 6019 5710 5962 3160 2440 6144 2384 -2409 5305 5908 3269 5800 3305 3287 6171 5942 5521 3299 6126 2418 5743 2392 6155 -5880 2372 2434 5949 6176 6127 6098 5959 3304 2331 6161 2364 2426 315 2325 2408 -3298 3094 6099 2378 5689 140 2433 6168 5939 3286 6123 5740 5927 306 5661 5844 -6140 2425 3213 2320 130 6095 3279 2328 6062 6158 2355 5515 2417 2388 6146 5085 -5304 2267 5799 3297 6063 3149 6170 6135 274 2432 5953 5924 5523 6017 3247 2371 -2345 5625 2407 5505 2416 2383 3285 2424 3278 6018 5906 2314 6059 5742 3159 5935 -6160 2363 6119 5734 2387 6143 5943 3237 3284 296 5878 5580 6167 2406 3256 6091 -3017 5520 2324 6125 6014 5957 6154 3083 3296 6114 5724 2382 314 5490 5903 2415 -6097 5739 2377 139 6157 3295 2354 5920 6086 6145 5084 2319 5738 2423 129 3093 -5928 2307 3283 5875 5842 3212 3277 6122 2405 2266 6055 3203 3246 313 2344 2299 -305 6139 5915 2203 6108 3282 5709 6094 2376 5522 3158 5797 138 6061 3255 3294 -5514 6010 6142 3276 5951 6050 3193 5303 5469 6080 284 2414 2370 2313 5839 4865 -2381 6134 262 5899 2263 5733 6124 5956 6016 6153 3236 5441 5907 2413 3254 2362 -3293 2290 5504 6005 5732 5941 5301 5871 2404 3006 6096 5519 5794 6058 2330 6166 -304 5879 6118 5894 5948 5723 2929 3092 3275 5688 2403 2369 6044 2280 5722 6090 -6121 2375 3016 5866 137 3202 6013 5737 6073 4645 5660 6156 2306 5405 2361 6138 -312 2353 6113 5729 5938 3253 5081 5489 6093 5999 2265 5835 2327 5926 6060 3211 -2830 2298 5843 2259 6085 5950 2374 5083 3226 136 273 128 5888 5360 5708 2402 -4864 2343 6133 5295 5719 5513 5790 6054 6015 5707 5830 3192 5302 3157 3274 5860 -3210 6037 5798 5624 2352 3148 2254 6141 5940 2137 2202 2368 6107 2262 311 5923 -6057 3268 3273 6029 5285 6117 2289 5947 6009 5503 5518 5785 5731 3252 6049 3245 -5468 6152 2360 6079 5992 303 5579 5905 135 2342 3138 5934 6089 3015 2323 2367 -6012 5704 3251 3156 295 2918 4644 5440 5687 5984 5824 5877 2279 6112 3209 5937 -6004 5721 5300 2248 4425 3091 2359 3267 5925 5686 5715 5853 3082 5659 3272 2720 -6084 3182 5728 6120 2318 5270 3201 6151 2928 5488 5902 5779 2351 6043 5658 6137 -5075 2819 2258 5919 6053 6092 5082 3225 2326 3250 6072 2366 3072 3271 134 5404 -5874 5975 3147 5841 5512 3244 5718 5080 2200 6106 3090 2341 5922 5683 5998 2264 -5706 2350 4861 2829 6132 2358 5065 5817 133 5623 6008 5700 2253 3208 250 5914 -6048 261 3249 2241 6078 2201 5359 5904 2312 5655 2599 4863 5796 6136 5933 5622 -5502 5294 5809 3243 3266 3207 5517 2340 5249 294 6056 3235 2233 5467 5772 6036 -5876 5578 5838 5509 3137 6116 6003 5695 5946 3155 2136 5298 5898 4424 2261 5703 -5221 4855 5577 302 6131 3081 5439 5764 6028 2349 5284 132 6088 3265 3014 5050 -2322 6011 2927 5299 2247 5870 5901 5991 3005 4641 6042 5685 5793 5619 5499 5714 -6111 2357 5936 3089 5918 2709 5679 5487 5893 3181 3206 5736 3242 6071 4205 4643 -2305 2224 5873 5983 2339 5657 131 6115 5840 3200 6083 301 5078 2317 5651 5997 -127 2995 5865 3154 5574 5185 2828 3071 2297 5403 5755 2719 6087 238 5511 3013 -5913 5674 2321 6052 3205 5269 5079 2199 2214 4635 3264 5682 5834 3127 5795 3146 -6110 5074 5292 3985 3199 2348 2257 118 5484 5699 6105 5029 5646 2071 3191 5921 -3224 6130 5140 2240 5887 6035 5358 5654 2588 5837 5974 4862 5621 6082 6007 5501 -2134 5293 2316 6047 2347 5897 126 5466 5789 6077 5001 5615 3241 2311 5829 5495 -4860 2232 5932 5859 2338 5064 6027 5282 2288 5508 2252 6051 5730 5694 4845 2135 -5297 5869 3088 272 5990 3004 5668 5438 3153 5792 2598 3240 3145 5576 6002 2337 -5283 2197 6104 5892 5570 4421 3198 5516 5784 5248 5610 4204 3061 3263 5982 5640 -3080 3152 2278 3012 5618 293 6006 5498 6046 5720 4625 5463 300 5678 2926 4423 -6076 5864 5486 5900 2310 6041 6109 5220 4965 4854 5931 2917 4642 3262 2223 5823 -5480 2718 5727 5917 5049 5565 5267 5077 3234 2246 5435 5650 6070 5833 2994 4640 -2304 4830 5402 5872 5573 6081 3011 5072 3239 3984 2315 5852 6001 125 3171 2336 -3765 2005 4415 5673 3180 5996 283 4920 5268 3087 5886 2907 2213 3079 2827 5778 -5973 3126 5604 2296 3151 5475 5073 5291 5717 2818 5912 2925 5788 117 5483 3197 -5645 5357 249 6040 5705 5828 4858 3238 3086 5184 5858 5633 5062 292 2193 3261 -6103 299 124 5916 5510 2133 3190 2198 6069 5465 4634 2597 2303 5399 5559 3196 -5614 6034 3150 5494 5836 4859 6045 2808 5063 5281 5816 5459 2131 6075 226 5896 -2309 5028 5995 2260 5783 5246 2070 3144 5139 2239 4610 2826 5667 5437 3260 4809 -2295 3545 6026 3136 2188 6102 2287 5911 5500 3233 5808 5431 2984 2196 5868 5354 -5569 5989 5702 3003 5000 5218 4852 5247 5609 5791 6000 2916 3060 2231 3085 5639 -5289 5771 5822 5597 4781 4405 5454 5507 6074 5047 5891 2308 4844 260 5296 123 -3078 5462 4201 4422 4638 6033 5684 5981 5219 3195 4853 2277 5713 5851 106 2924 -5763 5589 3232 5479 3764 5895 5426 6039 282 4420 5048 5863 5564 5266 4203 3084 -5434 5777 5552 4639 6025 5656 5279 3143 5401 2286 2717 4390 5071 5497 2817 5726 -6068 2182 3170 3010 4624 2708 2302 5395 5867 237 5988 3002 5485 5832 3194 4964 -5182 4589 2906 3070 5069 3981 2222 5544 5603 2923 5994 2256 4745 5474 5890 6038 -5076 271 2825 5448 3009 4195 4632 2294 5681 5885 5980 291 5356 4829 2276 5972 -4857 5910 4561 5183 3983 5632 5061 5815 2192 5716 5754 5350 6067 5698 2698 2004 -5026 4414 2068 2301 5390 5862 5787 4919 5137 3231 5827 122 5420 3116 2212 4633 -5653 5857 3544 5059 5398 5558 3125 4700 2716 5620 5993 2251 3189 5290 2807 5807 -5264 5458 2130 6032 1939 2824 116 5482 4998 5027 5831 2293 5245 2069 2596 5138 -121 2127 3077 5770 3975 3142 2587 2255 5535 2187 5345 5693 4842 2132 3223 5782 -2175 2922 5430 2983 6024 5884 5464 5275 3008 5353 4999 2285 5217 5971 4851 5575 -5493 3135 5762 4525 5288 3188 5280 5596 3141 5987 3001 5453 4418 6031 5786 5046 -5701 5826 4843 2896 2167 4849 6066 4609 2915 2300 4637 5384 5856 2122 5436 4808 -2577 5617 5821 5889 2250 5044 105 4185 4622 5588 2707 5677 5979 2195 5425 3007 -2245 2275 6023 4419 3050 2595 4962 3230 2284 5413 4202 2823 3059 4480 5712 120 -5850 2292 5551 4780 5278 4404 5861 3761 5986 3000 3179 5781 5243 2181 4369 4623 -5649 5461 5339 5394 4200 2993 4827 2715 5572 5776 3229 4963 3134 5181 2797 3076 -5260 5068 2816 5543 5753 5478 3763 4170 2002 3140 4412 5672 5978 4917 3187 2274 -5265 5215 214 3105 3965 5447 4341 2914 119 2158 4631 6030 5433 281 3069 5820 -4828 5400 4389 5070 3075 3222 3982 2116 5883 3169 5349 115 2244 2697 2003 5025 -5644 4413 5970 2067 4629 5389 5680 4918 2714 5136 2921 4588 5419 3115 5711 290 -5377 5849 6022 3980 5255 2586 5058 5814 2283 3139 3755 4744 5473 5697 5825 259 -5023 2065 5263 5855 2148 5055 4194 5985 2238 225 3950 4997 5613 5775 5355 2249 -5652 3541 4856 2822 4560 3228 2126 2291 5060 5369 2815 3221 2191 5806 5534 5882 -2594 5344 4995 5969 4841 2174 4149 4607 5179 5332 5666 5977 2230 5274 3068 4806 -4305 3543 5769 5397 2273 4699 5506 202 5780 5239 289 5692 3074 5457 4839 2129 -2194 1938 5854 5568 3039 4417 3186 5244 248 5608 2895 2166 280 4848 3227 2920 -4608 5324 5638 3974 5383 2121 4778 5813 4807 5761 4402 2713 2576 2186 5696 2109 -5211 2061 2593 2973 5043 2913 4621 5134 5429 2237 4198 2982 4260 5819 5352 3185 -3049 3535 5216 4961 4850 5412 5040 5616 3929 6021 5496 3073 5234 4524 5287 2243 -2282 2687 5805 4779 4403 5452 4619 2706 5676 5045 2101 5563 3220 5242 3133 5848 -4959 2919 2999 2229 5338 4199 4636 5768 5968 4826 2221 3745 4387 3178 2796 5259 -5691 2821 5206 4835 104 4184 3168 2281 3762 2912 2001 5774 5424 4411 5648 2992 -4916 5818 4824 5214 1873 3104 4586 5571 2814 2905 5976 2998 5035 2157 3978 4479 -2272 5315 5760 5602 5277 4742 2242 5752 3760 4388 1999 4409 5671 2115 5175 4914 -4192 2180 4368 3067 5847 5393 2592 2211 4628 3124 3730 3184 4121 4558 5180 4587 -5631 3177 2820 5376 5067 2190 3979 5254 2712 2271 4615 4169 2705 5675 4743 5481 -5773 5228 5022 5643 2064 2092 3964 5446 2147 5054 4340 4193 5812 4630 2813 2566 -2220 5557 4697 3132 2585 5019 94 3901 4559 2806 5368 5130 2236 2128 2711 5170 -1936 5348 288 5647 3525 236 5024 2991 3219 2066 5388 5200 4820 4994 5612 3183 -5135 2911 5492 4606 5178 5418 5331 3114 3972 5804 5967 4805 2997 3542 5057 2185 -5751 4698 3754 4991 1995 1807 2962 5238 5670 2082 2228 5262 4838 279 5767 1937 -3949 4604 2210 3038 4996 5665 5811 3218 3123 4803 3540 5690 5846 5014 2056 4085 -2125 5323 4522 5286 3973 5595 5966 4777 5125 4401 3709 2235 2270 114 3176 5343 -2108 5210 5642 2060 3510 5567 2972 4840 2173 5607 4148 5133 4197 5759 3058 2591 -2996 5273 4304 5637 5803 2584 4775 4399 5039 2812 4986 103 5233 4182 4523 5587 -2686 2227 4618 190 5460 5766 2885 4416 2100 5611 5491 5164 2894 2165 4958 4847 -4040 4477 3066 5550 2590 5382 3028 2120 5276 2704 3131 287 5477 3758 4386 4955 -3865 5042 5205 4834 5562 2179 4183 4366 4620 2219 4600 5664 4259 5432 5758 5193 -4799 3048 3534 4960 4823 3217 213 4585 5411 3928 4384 5066 5034 3977 4478 5810 -5542 5314 4167 3130 2710 4741 2990 270 5008 3759 2050 1998 5566 4408 5241 5119 -5174 5606 4913 3962 2234 4338 4191 3057 4367 4583 5337 2904 5636 3489 5750 2786 -4825 3744 4771 1990 4395 5601 2703 5669 2910 4557 4739 2795 5472 4910 3820 5258 -5802 4950 3681 2209 4614 2696 4168 2000 3175 4189 4410 247 4980 2218 5227 4915 -3216 5213 2091 1872 3103 2226 3113 3963 4339 5765 4555 2156 2565 5630 5056 2589 -4696 113 5476 3752 5018 5641 93 2811 2989 4815 2114 5129 5561 5261 3645 5169 -1935 3947 3174 2583 4627 5199 3538 4819 5396 5556 5749 5157 3729 82 4694 4120 -4380 2124 3065 3971 5375 5757 4905 2805 5253 5533 5456 258 3753 4990 2208 3129 -1994 1933 201 2961 3122 5021 2172 2063 2081 4146 4579 2146 5053 2903 5272 3948 -4603 4302 3969 178 4802 5600 3539 5149 4735 112 5471 3900 5013 3064 2055 2909 -4521 5367 4595 5124 2702 5663 5428 2874 2043 2981 3524 5351 2582 4944 5112 4993 -278 2164 4846 4147 4605 4551 5177 5330 2217 5629 2119 3461 4804 4303 4519 2189 -2575 5594 4774 3128 4398 5451 1806 5237 4985 5605 5041 5801 4181 3056 4837 5635 -4257 4973 1741 224 2035 3037 2884 2951 3047 3532 3173 5555 5104 4690 2225 5163 -3926 2908 4476 4084 5322 2804 3425 3027 4776 5748 5455 102 4179 4400 3708 5586 -1984 3757 1929 5662 5423 4794 2107 4899 5209 4954 5240 2059 3509 2810 2971 4365 -5132 2207 4196 4599 2775 4258 4474 3121 3742 5192 4798 5549 3533 2184 277 5038 -5560 5257 2676 3927 4383 5756 5232 3063 2685 4166 5427 235 111 3600 2980 4363 -4617 5007 5634 2049 5392 3172 4766 2099 5212 1870 4375 3102 5118 3961 4957 4337 -2155 4039 4582 4515 3167 2581 5593 2785 3743 4770 5541 1989 4394 5450 4164 4385 -4738 4909 2113 2809 3864 4574 5204 4949 4833 2701 2902 3959 5445 4335 4188 4626 -4979 5599 4937 2026 5470 3727 4118 4822 1871 4584 5095 2216 5033 4554 3976 3062 -5252 5313 4175 5585 3380 3751 4740 5422 5347 2695 1997 5020 4407 2062 4814 5387 -4546 5173 4912 2940 2700 2145 5628 5052 4190 3946 2988 5417 269 4470 4788 5548 -3488 4929 3537 3166 5156 3728 3898 81 4693 4119 3749 4556 4379 2215 3819 4904 -5747 3680 1977 2178 4359 4613 2901 3522 5391 5554 1932 3944 4892 2016 4992 5226 -5598 4145 4730 2090 2555 3055 5176 2206 4578 2803 2987 3120 2123 4301 2564 4760 -3968 5540 1675 1924 4695 4160 5148 5017 4734 1804 5532 5236 92 3899 5342 5128 -4836 5746 4594 3644 110 3955 5444 1969 5168 4143 1934 4331 2873 5627 3036 2042 -3523 4884 2183 4299 5198 4943 5111 4818 4082 2205 4550 3970 2580 3119 2979 4518 -3706 5346 2694 4989 1993 2106 5208 1805 2960 2058 3507 5386 5553 2970 4685 2080 -5131 2893 109 4510 5416 3112 4256 4972 189 5592 2802 4602 2034 2950 5381 3531 -5449 2118 4801 5103 4689 2574 1918 5037 2665 3925 5012 5231 2054 4083 4520 2579 -276 3165 5123 4178 3707 4616 1983 1928 3940 2098 4254 4793 4898 3508 268 3529 -4956 4568 4037 2900 5410 101 2863 3923 2774 5584 3460 4473 3741 2986 5421 4724 -2978 4773 5531 4397 5341 2675 4984 3862 5203 4832 4180 2171 4139 4465 2699 5547 -4362 1740 1960 5271 5336 2883 4295 5591 4765 4821 3739 1869 4374 4875 3054 4540 -5162 5626 5032 4038 2794 4475 4753 2204 2177 4514 3424 4354 3026 3118 3756 4163 -1996 4406 4953 5172 3863 4911 4573 2892 2163 1867 4364 3101 3958 4598 5539 4334 -3486 108 5380 2985 100 4155 5191 4936 4797 5583 4679 2025 3726 2573 4117 3053 -5094 3817 2801 4382 2764 5443 3678 2112 4326 4174 4612 4165 70 2578 3599 1950 -5006 4250 5546 5225 2048 3046 2544 2089 5117 4545 3960 3724 5409 2939 4115 4336 -3919 4581 275 4469 4787 5374 3487 3117 2784 4928 2176 2693 4769 4348 1988 5016 -4393 91 3897 5385 3748 4737 4908 5127 3818 3164 5415 4948 3642 246 5167 3679 -223 1976 4358 3521 107 5051 5335 4187 4978 3943 4891 5538 5197 2015 4817 3735 -2852 4729 212 2554 2793 3895 4504 5256 4553 5590 4759 5366 4717 177 1923 3935 -5442 3379 3750 4320 4159 4988 1992 1803 2959 3519 2079 4813 3163 1863 257 3643 -3954 1968 4142 3945 4601 4330 2154 5329 4883 5530 4800 4298 3536 5340 4533 5155 -2692 80 4692 2899 5011 4378 2053 4081 3052 1801 2170 99 4134 4903 5582 5122 -3705 4709 5414 3111 4290 1931 3506 3035 4684 3720 4144 4111 4577 4459 4509 3458 -5373 5545 4079 4300 5321 3967 4672 5251 1674 4772 4396 3703 1917 2753 5147 2664 -4733 2800 4983 2891 2105 2162 2057 3504 267 1911 4593 5379 1738 2144 2117 2872 -3939 2882 2041 2572 4253 4942 5110 5529 5161 3528 4567 4036 3891 3051 5036 4549 -2862 3922 3422 3025 5365 5537 3459 2169 4517 4664 4128 4245 4723 2684 3045 3515 -4284 4952 200 3861 5408 2097 3914 2977 1903 4138 4464 4597 3162 5328 4034 4255 -4971 1739 1959 5190 2033 4796 4294 2949 3530 3738 5102 4874 4688 4539 3924 4381 -1797 4497 5235 2898 4752 3423 3859 4353 2890 2161 4831 5334 3597 4177 2691 1982 -5005 1927 2047 2654 5378 256 4792 4897 2571 5116 2792 2976 3110 1866 4580 4075 -5320 3485 2773 5031 2783 4472 3740 4154 4768 1987 4678 5312 4392 3699 4736 4239 -4907 3816 4489 2674 98 5207 1858 234 245 3500 5581 4947 2969 2763 3677 4325 -5407 2153 3161 69 3908 4186 3598 4977 1949 4361 4249 3483 4764 2543 1868 4373 -3723 4452 2111 4114 4552 3918 2897 5230 3814 4513 3377 2683 5528 3675 4347 4655 -4611 5333 4162 4812 3715 97 4106 2168 2799 2841 4572 3641 5372 2088 2791 4030 -3957 5250 1894 4333 2563 4935 3734 5154 2024 3725 2851 79 4691 4116 4377 5015 -4444 5093 90 3894 5536 4902 4503 3855 5202 1852 2143 3100 4173 4716 3934 3378 -3639 4319 2152 1930 3518 3886 2889 2160 4816 4313 1862 4544 4576 2938 5364 2975 -2110 3966 4468 4786 1672 5311 2570 4927 5146 2533 4732 4532 3896 3747 4987 1991 -1800 2958 2798 4133 4592 2643 5171 5327 4100 2078 2690 4708 1975 2871 4357 2040 -1884 4289 5371 3520 3942 3044 4890 3479 4941 5109 2014 1792 5406 3109 3719 4728 -2742 4110 2553 4548 4458 3457 5010 3810 2052 4078 4516 4758 4671 3671 1673 1922 -2142 3034 4158 3702 2752 1802 5224 3503 96 4070 1910 5319 3880 2689 3953 2974 -1967 4970 1737 4141 4329 2032 5363 2948 3694 2562 3455 4882 4297 5101 4687 2790 -2104 3108 89 3495 3890 2968 4080 3421 4982 4435 5126 5527 4176 4663 3704 4127 -3635 1981 5166 4244 5326 1926 1735 3514 4791 4896 4283 3505 266 5196 1845 3099 -4683 3913 1902 1786 2151 5229 4277 4508 2772 4033 4471 2682 3419 3024 1916 2663 -2096 233 2673 1796 4496 255 4951 95 4025 3858 5526 3596 4360 4064 5318 3938 -2653 4596 4763 4252 211 4372 3688 2159 4795 4093 3527 4566 4035 3850 5370 2103 -5201 2051 4269 4074 2522 2861 4512 3921 2967 2569 5121 3698 4722 4161 3594 4238 -5004 4488 2046 1857 3860 3499 4571 2141 5030 4137 3956 4232 4463 3907 4332 5310 -188 3043 3451 1958 4934 4293 2023 2681 3482 2888 265 3737 4767 4873 3873 1986 -5092 4391 4538 4451 5362 3107 2095 4906 4751 3813 4172 2568 4352 3376 4946 3674 -4019 3474 4654 1731 2881 4976 3714 4105 4543 2840 2937 5160 3805 5325 1865 4224 -4029 4467 4785 3666 1893 3844 3484 3042 3415 3023 4926 4153 4677 2789 3374 3746 -1779 5223 4443 3815 2087 3854 2762 4811 3676 1851 1974 4324 4356 68 2561 3638 -3033 2688 3941 1948 4889 4248 2013 5309 5189 58 3098 2542 3885 4727 2552 4312 -2150 3722 4057 5317 78 3106 4113 3917 4376 4757 3630 5165 1671 1921 4901 2632 -4157 4346 2532 3590 199 2102 5195 2045 3468 222 2642 5115 3640 4099 3952 1966 -4140 4328 1883 4575 3799 4881 4296 3478 3660 2782 1837 3733 3097 1985 1669 2850 -1791 2957 2887 2741 2149 4731 2077 3893 5222 4502 3809 2680 2086 3670 4715 3933 -4591 2567 4318 2870 2560 2094 2039 3517 4682 4940 2140 5009 1861 4012 88 4069 -3879 4507 4547 5120 4215 3693 3454 3624 3041 2731 3370 1915 2662 4531 3494 5361 -3837 1799 5194 4810 4434 4132 3634 4707 3446 3937 4288 4251 4969 1734 2031 2947 -3526 1844 4565 5153 2886 3718 2139 4981 77 4686 4109 1785 2956 2860 3920 4457 -4276 3456 5308 4077 2076 4670 3418 4721 1726 176 1771 2880 3701 2751 1980 1925 -2788 5159 4790 4895 3502 4024 4136 4462 1909 3032 3410 1736 244 4063 1957 2511 -4292 2771 3040 1665 3736 4872 3687 4092 4537 5145 1828 5316 3096 3889 3792 3849 -4750 4268 2521 264 3420 4351 3653 4590 4662 4126 4243 46 254 5188 2038 3593 -3440 2966 3513 4282 2085 5108 4762 1864 3912 4371 1901 4231 3031 2559 4032 3450 -4152 4676 3585 4511 5003 87 3872 1720 4049 2787 2879 1795 4495 5114 2761 2679 -4323 3617 3857 5158 4570 67 3595 4018 1947 3473 4247 2093 1730 2781 2652 2030 -3404 232 2965 2946 2541 4933 5100 2022 1818 3095 3721 4112 3804 3916 4223 2138 -4945 4073 3665 3843 3414 4345 4171 3697 4975 1979 3373 1778 221 4237 3829 5187 -4789 4487 2075 1856 3498 2678 4542 3906 2936 253 3365 4466 3732 4784 57 2849 -3481 4925 3579 4004 5002 3892 4450 2044 4056 4501 2672 5307 3629 3812 5113 4714 -2631 3932 3375 4317 3673 1973 3589 4653 4355 3516 3467 1762 5152 2780 4888 3713 -4761 76 2012 4104 1860 4370 2839 4726 263 4900 4028 3433 3798 1892 3030 3659 -4756 1836 4530 1668 1920 4156 3784 4974 1798 4442 4131 2621 5306 3853 4569 1850 -4706 4287 1713 3637 3951 1965 2878 1660 4327 2084 5144 4880 2021 3359 3717 2964 -3884 4108 4311 4011 4456 5091 2558 4076 3397 3022 4669 4214 1670 2869 3623 86 -3700 2730 3369 2750 2531 1752 4939 5107 3836 3501 3609 5151 1908 2641 4541 4681 -4098 187 2935 3445 1882 4506 3029 5186 4783 3477 2083 1790 3888 2740 1914 2661 -3995 2557 3808 4661 4125 3669 4242 3572 4968 1725 1972 85 1770 2955 243 3512 -4281 3936 2074 5099 2011 1654 2963 3911 2610 5143 1900 4725 2551 4068 3878 4564 -4031 3409 2510 2859 2779 3692 4755 3453 1978 1664 1919 2868 4720 2037 1827 4894 -1794 4494 3493 3791 4938 5106 3856 4433 3652 2677 3633 2770 1964 4135 4461 2651 -45 2954 3439 1733 1956 2073 4291 1843 2671 4871 2500 1784 4536 4072 4275 4749 -3352 3584 3696 3417 4350 4236 4967 1719 2029 4048 4486 1855 2945 3497 3775 5098 -4680 3616 4023 1705 3905 210 4505 4062 3403 3480 5150 4151 3686 75 4675 4091 -1817 4449 1913 252 3848 3389 3021 4893 4267 3811 2520 2556 2760 3672 4322 4652 -66 4932 2769 3592 84 1946 3828 3712 4246 4103 2838 5090 2540 4563 4027 1696 -4230 2670 1891 2877 2858 3915 3449 1647 3364 5142 4719 3578 3871 4344 4003 4441 -2489 3020 3852 1849 2934 3564 3636 2867 4460 4017 2036 3472 1729 4924 1955 1761 -2953 5105 3883 3731 4310 2072 2848 4535 3803 4222 3432 2778 3664 175 4748 3842 -4500 1971 3413 4349 2530 4713 3931 4887 3372 83 1777 4316 3783 4931 2020 2620 -2550 2640 4097 3555 5089 1859 1881 4966 1712 2028 1659 220 3476 4150 56 5097 -4674 1789 3358 2739 4529 4055 3807 3396 198 3628 3344 2759 3668 1963 4130 2630 -4321 231 65 4705 3588 4879 1945 4286 4782 1751 2952 3466 4923 3608 251 4067 -3877 3716 4107 2768 3797 4455 3691 34 3452 2876 3658 74 4668 1835 4343 1667 -3492 2669 2749 4886 2010 3994 4432 3335 3019 3632 2549 3571 1907 1732 4754 1842 -1653 1912 2660 2847 2609 1783 4010 4274 3887 4499 1639 4213 3416 5141 4712 3622 -3930 73 4660 2729 4124 3368 4315 4241 4878 3511 3835 4280 4562 4022 209 242 -3910 4061 3444 1899 1686 4930 2875 2019 3685 4090 4528 5088 3847 2499 4266 2519 -1793 4493 1630 4129 3018 3351 2777 1724 4704 1954 1769 3591 4285 2650 4870 3774 -4534 219 2659 4229 2866 1704 2027 4454 3408 2944 3448 2509 4071 4922 5096 4667 -1663 3870 3695 2748 1826 3790 4235 3388 4485 1854 3651 3496 1970 4016 1906 3471 -2478 1728 44 2857 3904 4885 3438 2009 4718 2548 3802 4221 2767 1695 241 4448 -3663 3841 2943 3412 1646 64 2776 3583 4659 4123 1944 3371 4240 1776 2668 1718 -72 4651 4047 2539 4279 2488 3711 4869 4102 3615 3563 3909 1962 2837 1898 4026 -4747 4877 3402 55 1890 4342 1816 4054 197 4492 4440 3627 2629 3851 1848 1620 -3587 2667 3465 2649 3827 2846 4673 3882 3554 4498 4309 3796 2865 2018 2758 3657 -3363 1834 4314 1666 63 2658 5087 3577 71 2529 4002 4234 4484 1853 2538 3343 -2639 4096 3903 1880 1760 4527 3475 2933 4009 1788 4447 2856 2738 3431 4212 4921 -33 3806 2017 3621 22 2942 2728 3367 3667 5086 4650 3782 3834 3710 2619 4101 230 -2836 3334 4453 3443 4066 3876 1711 2864 1953 2008 1889 1658 3690 4711 4868 2747 -2547 3357 2932 4439 3491 4746 3395 1638 1905 2766 4431 1847 1723 1768 3631 1750 -186 3607 3881 1961 1841 4308 3407 2508 1782 4876 1685 4273 2007 4122 2941 1662 -4703 2546 2528 1825 4278 3789 3993 2757 3650 1629 1897 2638 4095 4021 3570 43 -1943 3437 1879 4060 4666 2537 1652 2608 3684 1787 4491 229 4089 2737 3846 2765 -4265 2518 3582 1904 2657 240 1717 4046 2666 3614 4065 3875 2477 4228 3401 3689 -3447 4658 2845 1815 4233 4483 208 3869 3490 2931 2498 4430 4710 3902 3350 1896 -2656 4015 3826 3470 1727 3773 1840 4446 1703 1781 1952 3801 4272 4220 3362 3662 -3840 4867 3411 2006 4526 3576 4001 2648 2545 2855 1775 3387 2835 4020 4702 1619 -1888 4059 1759 3683 54 4088 4438 2930 3430 1694 3845 1951 4053 1846 4264 2517 -4665 1645 3626 4866 2628 2746 3781 3586 2756 2618 2487 3464 4307 62 3562 1710 -1942 4227 1657 3795 2536 239 3356 3656 1833 4649 3868 174 3394 2637 4094 4657 -2834 21 1878 4014 3469 1749 1887 185 196 3606 2736 61 3553 3800 1941 4008 4219 -3661 3839 207 2535 4211 3620 2727 3366 1774 4490 3992 2854 3833 3874 3342 4306 -3569 2647 3442 1651 53 2607 2527 4052 4429 32 3625 228 2844 2627 1722 1877 2655 -1767 4482 1839 3463 4701 1780 3333 4271 2735 3794 3406 2507 3655 1832 1661 4445 -2497 1824 2853 3788 1637 3349 3649 4058 2745 4648 42 3682 3436 4087 3772 218 -2755 1702 4007 4263 2516 60 1684 1940 4210 3619 3581 2726 2534 4437 3386 1716 -4045 3832 4656 1838 1628 4226 3613 195 3441 4270 3400 3867 1895 1693 1814 1644 -4013 2526 1721 1766 2843 2486 3825 2636 2754 4086 3561 4218 59 2646 3838 2476 -3405 4262 227 2506 3361 173 1773 217 3575 1823 4000 3787 3648 4225 41 4481 52 -3435 1758 4051 3866 3552 2645 2626 3429 3580 2842 3462 1715 4044 3780 4428 3341 -2617 3612 4647 3793 1618 4217 1709 3654 2744 1831 3399 1656 206 3355 1813 1772 -1886 31 3393 4436 3824 1748 51 4006 3332 3605 4646 4050 4209 3618 2725 3360 -2625 2833 3574 3999 3831 1885 2515 1636 3991 2525 20 3568 2743 1757 2635 1830 -1650 1876 2606 1683 3428 184 1765 2734 3779 1627 2616 2524 4005 2505 1708 1655 -4208 2634 1822 2724 3354 3786 1875 3647 3830 2496 3392 40 3348 3434 194 1747 -4427 3604 3771 2475 1701 2644 50 1714 4043 1764 2832 3990 3611 3385 216 3567 -3398 2504 4426 1812 1649 2605 1821 3785 1692 3646 1829 1643 3823 39 4261 2514 -2485 1617 3560 2523 3573 3998 2831 183 4042 2495 1874 3610 2723 3347 1756 2733 -2513 3770 1811 3427 1700 3551 3778 4216 2615 3822 3384 19 1707 3340 1763 172 -3353 2633 3997 3391 1691 215 1642 30 1820 1746 2732 3603 1755 2484 2624 3559 -3331 38 3426 3989 3777 2614 49 3566 1635 1706 4041 1648 2604 2623 2512 3550 -3390 1682 1810 1745 4207 3602 205 3339 1626 3821 2494 3988 3346 29 3565 3996 -3769 4206 171 1699 2603 193 3330 2474 1754 3383 2503 1634 48 3776 2613 1690 37 -182 2493 1641 1681 3345 2483 2502 3558 3768 1625 1698 1819 1616 1744 3601 3382 -47 3987 3549 2622 1689 2722 2473 1640 2602 3338 2482 3557 1809 18 28 1753 2492 -3329 2501 3548 2721 1615 204 3767 1697 1633 36 3337 3381 1680 1743 27 2612 1688 -1624 170 3328 17 1808 2481 3556 35 1632 2601 2472 1679 3986 3547 1623 192 203 -3336 3766 181 26 1614 2471 2491 3327 1742 1687 1631 2480 2611 1678 16 1613 180 -1622 191 3546 2490 2470 15 2600 25 3326 169 24 1612 2479 1677 1621 1676 14 168 -2469 2468 1611 23 1610 13 179 12 167 11 } +{ 148 2934 166 5107 4628 166 166 166 166 3033 166 4692 166 5571 2225 166 5340 +3423 166 3191 1752 166 5212 166 166 3520 166 166 166 1867 166 3313 166 3461 166 +166 3174 1737 5010 5008 166 4344 2868 3877 166 4089 166 5041 4748 4073 4066 +5298 3502 1812 166 5309 166 233 3493 166 166 3728 5236 4252 4010 2149 166 164 +4580 3039 4804 3874 166 6170 2812 166 4334 166 166 166 166 166 166 1862 224 +2131 6081 166 2710 166 166 166 4765 166 1964 5060 166 1897 166 3987 166 166 +5566 2021 166 45 166 166 3283 3932 166 166 3519 166 166 291 166 166 5132 2800 +166 166 166 5531 4054 166 3509 166 166 4908 3028 1756 1910 4671 2729 5224 166 +121 3327 3317 166 181 2371 5541 166 1787 2666 5134 5698 166 5480 3870 166 3823 +166 3165 5343 5123 5089 166 2422 3724 166 2735 1953 5724 4444 4871 166 166 5001 +5512 3133 5171 166 2216 166 4877 4542 166 166 166 5270 166 166 166 1922 69 3547 +166 166 166 166 166 231 4547 5155 3357 3464 166 72 3332 166 4392 5971 3896 4451 +3173 2569 166 4466 2518 1698 2850 5349 166 166 4457 5062 166 2202 1650 2191 166 +1950 2583 166 5293 2032 5893 166 3994 5392 3878 96 166 166 3195 166 4001 1900 +2513 6027 166 166 166 166 5407 166 166 2332 5125 5891 3096 3172 166 166 3065 +166 166 4535 166 166 166 4553 3131 3693 166 2255 2613 166 166 166 166 2866 166 +166 166 2940 5333 3199 166 2628 4312 166 166 1794 4681 2058 3606 166 166 3542 +2166 4696 2520 166 4739 166 2563 166 166 3681 166 166 166 4127 1967 2972 166 +5227 166 166 5551 4255 56 166 5553 3219 4367 166 3218 4749 2886 3695 3711 2228 +166 166 166 2268 5054 3749 4825 166 4933 4992 4530 166 4892 3400 166 197 166 +6078 166 166 3971 166 166 5357 1852 3377 166 5196 3740 5320 166 166 3099 166 +4562 6061 3294 166 166 166 166 3266 3627 2567 166 228 2773 166 166 53 1833 2401 +124 166 4272 3922 5959 2903 3923 166 6155 166 166 166 166 216 166 5247 166 5591 +166 166 82 87 4526 166 166 5439 166 4935 166 3187 1869 166 1764 5500 6023 3356 +166 3350 2457 2455 166 1637 166 3342 166 166 3355 5154 166 276 166 166 166 3371 +5969 166 1665 166 166 166 166 166 166 166 4092 1712 3122 5086 166 166 4906 166 +2591 166 166 166 1894 2997 166 4476 4384 166 4747 4109 2655 166 5978 1636 4898 +166 166 166 166 166 166 166 5207 166 166 3712 3876 91 5876 3786 5998 166 166 +166 4391 166 166 2832 2220 4435 166 166 5796 3156 6112 166 1643 1821 3129 166 +4200 166 5857 166 166 2351 5902 1855 5043 166 3167 5191 3996 5718 4876 3071 +2965 5735 5930 6149 2345 3297 3822 166 166 307 6019 1859 2981 4914 3320 6165 +2328 140 2372 308 166 2280 5081 166 3275 166 159 2399 2327 5489 4690 6059 4492 +4269 6058 166 19 166 3323 5708 128 4812 2949 166 166 2890 2630 5237 166 256 +3673 4621 5380 166 3353 166 1651 2573 1635 4011 3429 3370 3720 166 166 6108 +3848 5104 2851 1998 166 166 5106 20 166 2633 166 166 166 166 5662 125 3651 1731 +4702 166 3197 166 2947 3046 4196 2185 6100 166 2602 2908 2487 166 5232 166 4028 +5919 166 2680 3608 3252 166 4899 166 166 166 166 2529 166 166 166 166 166 2534 +166 2299 4076 166 3643 166 3921 166 166 166 1939 2124 1829 2436 3892 166 3481 +271 5307 1697 166 166 5098 2906 5545 166 5980 3203 166 1903 4626 4674 6118 6097 +5926 4136 1677 3232 4720 166 166 166 229 2012 3620 166 3798 166 166 2609 3489 +3809 166 166 166 166 166 166 166 5826 166 166 166 4903 166 166 166 166 6168 166 +5052 5044 5644 2375 2677 4012 3062 5831 4752 166 4125 2610 2062 3238 292 2533 +5872 51 166 1947 4225 166 2288 4845 166 5788 166 5717 166 166 5549 5619 166 +4165 166 2721 2311 5501 4416 4383 166 166 3068 5499 5936 166 4204 4766 4688 +1870 5220 166 166 166 166 237 2523 6039 3061 2793 3998 166 2545 2309 3144 3679 +3969 166 166 166 4379 3574 205 2808 5822 166 166 2188 4823 4990 5561 5711 166 +5627 6034 5253 3783 5047 4405 166 59 1755 3178 318 166 4710 2933 3409 6062 2821 +166 6099 166 4178 166 166 4122 36 4779 166 166 4323 3073 5410 2101 166 166 44 +5690 166 3265 166 5222 5909 1838 166 4755 2215 166 4082 166 166 3210 5140 3124 +5238 166 5913 2321 166 2416 5976 3918 5078 4218 5703 4897 6011 5685 2214 166 +166 6180 5175 1715 166 166 3760 4497 1808 4826 166 2540 166 166 5513 4971 5915 +166 166 2525 166 4480 42 232 2412 2797 3229 5263 2852 5543 2126 3562 166 2872 +4695 5985 5136 2714 4262 5473 166 4160 4347 166 166 166 166 5271 166 166 5108 +166 166 166 166 5437 4875 3963 4362 5820 5559 4890 4728 166 166 2692 166 4870 +3591 5472 166 2690 166 5854 3817 166 280 166 166 113 4128 3396 166 4264 5058 +2283 166 2281 4916 5671 166 2708 166 166 4589 166 166 4689 166 1686 166 166 166 +166 166 1774 166 166 166 5651 3777 2234 166 3864 18 3589 4592 4777 166 166 5254 +4245 166 166 166 4368 5172 3522 166 4306 153 5230 166 5598 5420 311 2414 4159 +2985 5137 166 2179 1801 166 4595 2083 2020 166 3602 2170 4259 3048 166 166 4193 +2350 166 166 2702 166 4521 166 166 2496 166 4593 2006 166 166 2292 4135 166 +6069 4623 166 166 4827 3995 4291 3243 166 166 166 5622 166 3539 166 166 4915 +4373 2479 3775 6008 5838 4321 1612 5530 166 3773 4267 4086 3081 2261 166 166 +4785 4641 5292 166 4820 5612 5556 166 166 166 4396 6084 3414 166 3331 2380 5921 +4315 2340 166 5511 166 4713 3754 2912 2553 166 3468 5388 166 1932 3540 5834 166 +166 3186 5258 166 4107 166 166 166 166 166 166 166 166 2108 12 2368 2789 166 +166 4148 1878 166 166 2324 4179 2945 2531 166 166 166 4485 3765 2308 166 2754 +166 6102 166 1921 260 2241 166 2592 166 166 166 4964 166 3055 5261 4943 2916 +166 201 5728 166 5759 4314 4730 6024 166 4926 4762 1834 2055 166 40 166 5416 +166 3722 2360 1928 166 4889 4590 5550 3498 166 6003 2029 4106 4346 3758 166 +2753 103 1891 5067 166 3398 2079 5784 3074 3787 166 166 3936 166 5766 166 4847 +3928 5119 166 5181 4602 2605 5712 4523 166 166 4717 166 2227 2181 166 4678 166 +166 4901 166 4980 166 166 166 166 5806 2894 5631 4995 2608 166 166 166 3917 166 +3417 166 2795 1655 3189 3364 166 4839 3510 4212 5641 6091 138 166 166 3343 4620 +2722 4566 166 3518 3424 166 166 1653 166 5057 166 5375 4833 166 4273 4348 166 +166 166 4912 166 3662 166 4281 166 5169 166 5883 2737 2572 4685 4068 166 4214 +166 166 2409 166 166 4571 166 5624 5722 5949 166 3675 166 166 5109 3428 166 166 +5446 166 3290 166 3309 166 166 4776 166 166 166 166 166 166 5617 2860 166 166 +166 166 3629 1741 166 166 183 4973 3047 2854 75 2035 3652 2159 166 4150 6037 +3225 4519 1902 2678 2413 1961 166 166 166 166 4972 1847 166 5636 4017 166 3345 +166 4520 166 2861 166 3092 6060 157 2542 2298 4496 166 2607 6110 5707 2314 166 +166 273 166 5952 166 4957 322 6065 2272 6140 2438 3458 3287 166 166 166 166 +2684 288 3354 166 166 3983 1702 166 166 166 2393 2435 4202 3308 5805 5085 166 +166 1938 166 166 2171 5892 2337 166 4648 3116 2486 4363 3567 166 166 2822 2041 +166 4703 3956 5192 166 3975 5720 3647 2134 5932 166 166 5160 263 166 166 166 +4549 166 166 1701 3086 166 166 4737 166 2252 166 170 166 166 166 2301 5478 166 +166 5979 3007 166 166 166 4104 166 2469 2700 166 4998 3376 166 1840 166 166 +4470 166 5235 3930 166 166 166 6031 166 166 166 3827 4700 166 166 166 166 166 +166 4103 3976 166 166 166 166 5027 4322 5130 166 4741 2132 4118 3080 4137 166 +6179 166 166 166 166 166 6120 4188 166 2251 166 3253 166 4887 166 4293 5241 166 +166 166 166 166 166 5076 166 166 4177 166 221 166 2757 5377 166 43 166 166 3180 +5540 166 213 4541 166 166 166 166 166 1641 166 4578 4639 166 166 1683 2139 1689 +5249 5773 5226 166 2820 166 5516 5045 166 4896 5657 5189 166 5770 2725 5148 166 +166 166 2929 166 3479 166 166 4564 3752 4305 4232 166 5906 1779 166 2709 4941 +4342 166 4882 166 4277 2322 166 4879 1610 3038 166 3762 2054 5652 166 4524 3820 +4806 166 166 104 3416 4869 4243 4854 166 4114 166 2121 166 3463 3556 166 4795 +166 2118 3920 166 166 4667 5046 166 166 2088 4360 5787 2198 4233 5552 3970 3523 +2037 5791 166 166 4299 2336 166 166 166 4173 4588 3626 5187 166 3363 4611 294 +4962 5243 2719 6022 4976 3559 166 2662 5779 6151 166 3527 166 5404 6132 1839 +166 3090 166 2253 166 5441 5518 6049 166 166 6136 3026 3474 5960 166 3937 4105 +166 2348 2039 4738 166 5233 3882 3840 166 278 190 166 5751 4313 166 3855 166 +166 6171 166 166 5381 3941 166 166 166 166 3334 166 2038 6088 166 1918 5037 +2325 2378 4894 3514 3715 5168 166 166 4083 2873 166 166 166 2693 166 3543 166 +2577 3013 166 166 4594 2622 166 166 166 3401 166 166 5447 5328 5547 6133 2335 +3739 166 166 166 166 5614 3492 3610 3466 166 5336 4354 166 4662 166 166 4283 +166 166 303 5904 166 2717 166 166 2276 5564 2386 5661 2040 166 1630 4652 166 +4840 166 110 5329 3979 5734 2550 166 166 6007 5999 2978 4771 5360 166 4023 166 +166 5920 4065 166 3880 166 5422 1813 166 6166 73 166 166 3669 5762 5077 166 +2953 85 166 3517 166 116 166 2738 3710 166 1634 166 166 166 2290 3001 166 166 +3037 2400 3410 166 1791 4231 166 3546 5009 5299 2807 166 166 1675 1619 2374 +3093 5302 3278 2330 5301 2343 2307 3274 5017 2265 3700 2465 166 139 4292 166 +5056 3952 166 4528 2388 1886 166 166 3016 3698 5881 166 2379 3223 166 166 3847 +2407 5493 3183 3307 166 265 166 2421 6161 2057 5363 3863 2474 166 166 5427 166 +2140 2955 166 3070 4237 5018 5988 5570 275 4862 2357 166 195 166 2593 6047 166 +2878 166 166 2781 3004 4180 166 5593 166 5973 2544 5064 166 4324 4701 166 3084 +166 166 5372 4725 166 5650 166 166 2786 166 3781 3583 3682 1850 4420 3296 5173 +4461 166 166 166 2984 166 93 166 166 4336 5943 2922 3300 166 4843 166 166 166 +166 2094 166 2939 166 4656 166 5146 166 166 166 166 2104 3977 4660 5312 166 +1865 166 5487 5558 3380 166 1957 3162 3281 166 3588 3268 2099 166 166 2319 4913 +4187 5503 5782 150 166 52 5450 166 166 166 2941 5877 166 4031 5393 166 3931 +4166 3135 3445 166 5053 5430 4836 166 5315 3389 4636 166 166 3441 166 166 3767 +2961 166 4761 4604 3179 166 166 4751 2148 2015 166 123 5013 166 2936 166 2063 +166 5823 166 5096 166 166 4198 166 166 166 3845 166 166 238 166 2703 3541 166 +4813 166 4477 2349 4197 5996 3324 4789 3063 166 166 5504 5273 2805 13 166 5601 +5402 4119 5206 166 166 4251 3704 4176 1963 2882 166 202 3125 3318 112 166 3362 +4835 3420 3974 5099 166 4433 166 166 166 1766 2663 166 166 4683 166 166 5485 47 +5101 5341 5765 3390 1648 4341 3945 6045 1645 166 5578 2594 166 166 3772 166 166 +3196 3603 166 5399 166 5075 166 5911 4632 4781 5313 270 166 2346 166 166 166 +1986 166 166 4958 166 166 166 4048 166 3076 166 166 4891 166 166 57 166 220 166 +166 166 4117 166 166 166 166 5194 2658 166 166 2942 6071 4182 166 2976 5816 166 +166 166 166 3985 4211 2514 166 166 166 2504 3446 1711 166 166 2107 5190 166 34 +166 3912 5382 3003 166 166 166 2999 2404 4734 4455 2087 166 2405 156 166 2830 +3303 296 3295 2067 4268 166 166 5642 166 166 1901 166 5133 166 166 166 166 3176 +2973 4677 166 166 6164 3000 2396 2734 5697 5989 166 2823 5265 5852 166 166 2623 +2625 2287 4844 1758 166 166 166 166 166 6073 166 5379 2389 5279 2444 5515 166 +4038 166 4948 5640 166 166 3572 4258 166 166 166 5204 166 4603 5797 166 166 166 +1725 4600 166 166 5498 166 4152 166 172 4758 166 2598 2489 2076 4366 2568 166 +4352 3782 166 166 3059 3946 5138 5727 4484 5694 166 3796 166 166 166 166 5334 +1778 2245 166 4517 4419 2250 182 5856 166 2835 4495 1858 2033 6014 6086 3211 +166 166 154 2145 166 129 3661 2661 5860 6143 2640 3890 6160 166 166 2747 166 +166 2291 282 2476 166 166 3825 166 1925 166 4489 166 166 166 4034 166 166 166 +166 166 166 122 4708 4919 2373 2453 5419 5954 297 5290 166 1978 166 4932 3501 +166 3085 3386 166 5405 4512 166 3209 5740 4020 5495 5815 314 166 3190 4824 166 +166 3448 207 1623 6096 5878 166 1836 166 166 2728 166 5278 3419 3012 5618 5266 +3078 166 166 2244 166 4569 6068 166 3336 166 5677 6052 5079 166 5453 5245 5799 +166 1982 166 5958 4619 5821 166 5285 284 1631 5710 6070 5365 2189 3242 166 2752 +5483 5297 6150 5522 166 1815 166 166 166 5801 166 166 5398 166 166 166 2967 +2515 3169 166 166 2562 166 1617 2069 166 166 6154 166 3721 166 5327 166 166 166 +5592 166 166 2286 1716 3903 166 2395 286 3587 6146 3286 4186 5882 5894 5737 +6032 5879 2761 4829 3788 166 166 3233 5356 5693 166 2429 2449 141 3444 5186 166 +166 3477 4080 4584 166 166 3670 1851 3824 4337 3886 2792 166 5867 166 166 3557 +3147 166 166 2200 166 2505 166 4310 4865 5656 5992 5672 166 5199 135 3023 2994 +4472 166 166 166 2019 4319 3472 166 166 166 29 206 3944 3027 5804 4731 5449 166 +2825 3310 166 6172 5202 166 2516 3644 4557 166 166 166 166 2671 4427 3432 3276 +5584 5536 4645 3202 166 2612 166 4249 2425 3259 4622 166 2411 4303 4206 166 166 +166 3734 6063 118 166 166 3641 166 166 166 4937 1871 3421 2208 166 166 166 166 +4881 166 166 166 166 3298 166 61 166 166 166 3293 6145 71 3619 166 166 3383 +1624 320 2187 4113 166 166 166 166 166 5080 2344 5625 2358 1621 4230 5579 5359 +295 4248 5267 3883 6124 187 5112 2122 166 166 166 5142 6004 166 5322 6175 3639 +3182 4425 166 175 166 166 166 5778 3939 3484 166 166 5832 5248 5935 4467 5858 +166 5038 166 166 3102 166 4880 166 166 166 166 3418 1666 5338 3680 5291 4441 +3385 166 5733 4503 2774 166 2631 4153 166 2000 166 166 5345 166 166 4298 1804 +4707 166 1613 1952 2111 166 166 166 166 166 2897 166 166 4044 166 166 166 166 +2863 5475 166 166 166 1704 166 3609 2782 2018 166 5361 166 3694 3733 166 2785 +1969 166 166 2834 1868 3779 1877 60 166 4143 3902 166 4361 3188 2498 6009 166 +115 166 3138 166 4575 6080 133 2030 166 166 166 2306 2136 3043 3447 2142 166 +3799 1646 5269 3640 166 2674 5502 166 5467 166 5069 166 166 4654 4581 5274 5036 +4364 166 3115 166 2128 4544 5433 2086 2584 4413 166 166 5385 166 234 166 1625 +166 166 166 5139 2511 4974 2766 166 166 166 2095 3990 217 166 2988 4061 166 209 +4883 166 166 166 166 166 4326 166 5465 2859 166 2887 166 2231 166 1658 166 2246 +166 1844 166 166 3087 2871 3872 1660 48 166 166 3622 166 1709 166 166 6177 6173 +166 3569 166 166 166 241 3660 3631 166 166 5319 5141 174 166 166 4412 166 5145 +166 1919 166 5276 166 2385 166 1618 166 166 2501 166 166 1734 5966 3145 166 +1690 4025 1664 4559 2433 2392 3552 4006 1896 166 166 2546 4450 5396 4221 4046 +166 166 2642 166 4448 166 2784 3480 4807 166 166 3534 166 166 5272 166 166 2831 +4263 166 166 166 166 4414 5628 3486 166 3748 166 4598 3719 3598 3611 166 4792 +5059 4110 166 2656 166 166 84 5429 166 166 166 281 1955 166 166 166 3616 4997 +166 166 166 166 3230 166 166 166 166 166 166 77 166 166 166 1800 166 4236 166 +166 166 166 166 5757 2530 1662 166 4607 1659 166 1685 3341 166 1699 4058 3407 +1854 4417 3034 166 166 166 166 5568 166 3206 166 5529 166 166 166 2116 3487 144 +166 166 166 5523 5373 5321 166 6064 2921 166 1696 2473 166 166 3716 5689 166 +4608 3879 166 166 166 2156 166 4358 2446 166 3958 166 5520 4340 4848 166 3285 +166 2665 166 3459 1905 5115 68 5730 166 3127 5029 4370 166 3753 166 3674 6025 +4490 166 4183 166 94 166 166 4051 3766 3140 4907 3857 166 166 4596 166 3888 +3040 2507 5643 166 166 4311 2618 5582 166 166 3678 166 1988 166 166 4464 166 +166 166 166 4278 3677 2173 5256 166 166 5162 166 5178 1644 5094 166 2557 5506 +166 166 166 4927 5348 1797 166 166 39 166 3866 3655 236 5403 2175 3361 166 1976 +5993 226 166 4643 166 5339 4098 2653 4969 166 3346 4984 4635 166 166 166 166 +4981 188 166 166 28 4088 166 166 166 25 3663 2696 166 4679 5114 5802 166 166 +166 166 166 3810 5749 166 1673 4276 166 3756 4184 166 5630 166 166 166 4531 212 +5663 166 166 2746 166 5386 3618 3594 1887 166 166 5443 166 1726 4094 5065 4756 +166 166 5308 5225 2081 166 166 3064 166 166 1981 3637 4355 1626 166 166 4686 +166 5793 180 5066 2938 3819 4904 3601 166 166 2495 5025 5768 2621 4650 3041 166 +5897 3633 166 166 4375 166 5714 1667 3273 3950 1668 166 5855 166 2364 166 1881 +166 2646 5460 166 2770 4951 5414 166 4442 2113 5726 298 5934 2053 166 166 4053 +166 166 4514 4697 166 166 5198 2707 166 5605 166 166 5218 2596 166 2110 166 +1806 2160 166 166 2212 166 3636 166 166 4377 4021 3707 4502 166 4195 166 166 +166 4108 3725 3676 166 2084 166 166 166 166 4216 166 166 6156 166 2896 166 166 +166 166 166 166 3826 2870 3793 166 166 5927 166 2759 166 4613 2297 5638 166 +2842 5031 4793 5184 166 166 2008 166 257 2881 117 6051 3044 4079 2833 166 6117 +166 3236 5469 166 166 2874 6076 166 1799 80 41 166 1864 166 5709 1611 5026 5176 +168 3269 4081 166 166 1970 4550 166 4250 4101 4565 5950 5845 97 4064 166 5394 +4374 4343 166 166 4658 3248 166 208 1735 4047 2843 166 166 166 166 2794 166 166 +5844 166 166 3094 2177 5436 3646 166 3564 4682 166 5948 5835 162 2059 5151 2034 +1926 5941 5903 5177 166 166 166 4801 3439 1780 166 166 3280 3434 166 166 4498 +5565 4043 166 4432 4722 3959 166 3746 166 166 177 166 166 2748 166 4483 166 166 +4144 166 166 166 166 2066 2915 166 2049 2130 4684 166 49 3506 5391 166 2590 +6103 1714 2410 3053 3837 4301 166 3255 2644 166 166 4014 166 2475 4788 2876 166 +166 166 166 166 166 4140 166 166 321 166 1966 166 166 2855 3111 3800 166 4446 +2551 166 166 166 2824 166 166 166 2164 3010 2226 166 4857 166 2582 5118 4582 +5917 166 166 3338 3482 3328 166 4817 166 5371 3830 166 3009 1633 3329 4052 166 +3701 4983 4500 4487 4878 166 166 5482 3544 166 3057 2026 4398 2847 3532 3262 +3399 166 166 166 4478 4167 166 3411 2599 5362 166 2711 166 166 166 166 3452 +2522 5586 5548 3279 2538 166 166 166 4161 166 2123 166 166 2660 166 166 1706 +166 15 3537 5051 5869 166 3025 166 4447 3744 120 166 166 166 204 2810 166 5124 +2376 5306 166 166 4493 166 166 166 5289 6046 166 2762 2541 1857 2467 5163 166 +166 166 166 5830 166 2172 3359 166 2928 166 166 166 6129 166 5445 166 166 5924 +6144 166 102 166 166 1678 166 4491 5705 166 1753 166 3873 5725 4145 1909 166 +2155 166 166 1848 3315 1874 166 4945 2524 166 3263 2362 1785 166 166 166 152 +2102 5723 5131 5754 4032 4029 166 4295 3391 166 166 166 5282 1747 3159 2235 +5583 1786 3630 6111 2974 4797 3623 166 2071 4929 166 2603 3964 3378 166 166 +2654 151 3940 4527 4518 166 2430 1884 3812 166 2867 166 166 166 2756 5418 166 +2354 4606 166 2153 166 4855 166 166 1720 166 3213 3926 166 5158 4349 166 4828 +166 166 2031 166 2300 166 166 166 2211 4954 3121 4754 2485 166 166 166 3593 166 +2718 5317 2765 5120 166 2527 166 1994 5947 166 166 166 6085 2302 100 79 2982 +3705 2180 2043 166 1872 1671 166 3729 166 4944 3665 2217 2119 166 5615 166 1620 +166 166 166 166 35 3913 2760 166 3688 3672 4042 166 166 5117 4227 166 4445 2458 +3803 4554 4988 166 166 3141 3491 166 166 166 166 5095 4668 5567 166 166 2885 +1790 2996 166 166 166 166 3737 166 2470 166 166 4339 166 166 166 4920 166 166 +3697 5471 166 166 3538 4558 3467 5262 5609 3858 166 166 5007 2780 2791 2236 +5668 3134 166 166 5776 3470 3291 166 2532 166 166 166 3805 264 166 3227 166 166 +166 2334 166 5087 101 166 3634 58 2813 166 166 166 3222 4704 4488 4508 5459 +2117 5873 166 1828 166 166 166 166 166 2105 166 5613 5761 2920 3098 166 166 +3277 166 166 166 166 83 166 166 166 3967 166 5574 166 4985 30 3426 166 179 3014 +4015 246 2556 4449 3723 5611 3436 166 4240 3642 166 4536 2048 5810 166 1971 166 +5557 5323 5022 191 5492 166 4837 4426 2537 2271 3177 5674 166 2796 1995 166 +3906 166 4403 3862 4716 2406 3948 4670 4309 166 2575 5358 2951 166 3666 3612 +5577 4579 4743 166 6072 6036 4563 2586 166 5836 166 166 5752 166 3563 166 2909 +3251 92 166 4711 4149 166 166 3052 5122 2904 2635 1990 166 166 166 166 166 166 +166 166 4213 166 3103 3142 2683 6105 2209 3175 4215 166 166 166 166 166 166 166 +5303 4075 5374 166 4174 4154 1895 4538 2764 166 5817 6113 4033 166 6090 166 +2990 166 3164 166 166 166 247 166 6083 3412 166 5738 166 3599 166 1904 2162 +2547 3960 166 166 3154 55 166 5991 4921 2879 166 166 5347 166 166 166 2712 4787 +166 1908 166 166 166 3184 166 166 166 4572 3846 3657 166 166 5481 166 166 3397 +1856 4978 166 3900 3570 3802 166 166 2075 4408 166 6079 2313 166 166 5756 166 +166 2070 166 166 3137 166 166 3686 166 166 166 166 67 5019 166 1742 166 5354 +166 5149 166 2931 4946 6006 166 166 2865 4902 3029 1722 3449 166 1987 166 62 +5626 166 166 166 2670 1657 5599 3056 166 3791 5020 166 1979 4437 1899 166 166 +196 2636 166 143 3475 4317 2512 2415 5033 5024 2112 2864 3551 166 1688 33 4585 +3648 4399 166 166 166 166 166 1824 166 166 166 166 166 166 4513 166 2478 4407 +166 166 2492 4130 4318 2980 5746 166 2606 4063 4123 166 255 166 166 4680 166 +3586 5975 3935 166 5528 166 3158 166 166 2614 5035 166 3488 3214 166 166 166 +5413 3713 166 5875 4329 5250 166 166 3741 166 54 1885 3839 166 4924 166 166 166 +4158 166 166 2152 1661 166 166 4327 166 3933 166 5666 166 166 2580 166 3404 +4111 2862 4438 166 166 4072 166 166 3938 2958 4302 166 3851 166 268 166 166 +1975 222 3204 3438 4616 166 4275 3101 2648 3989 5215 166 4229 166 5440 166 5093 +2639 166 166 4439 166 2316 4239 166 166 166 166 166 1817 4486 166 3272 166 166 +4085 2078 2902 166 166 166 4381 1853 3054 166 166 5005 2669 166 2856 2706 166 +166 166 4185 166 1748 166 166 166 5771 166 166 3915 166 166 2205 6122 166 166 +1632 5400 166 2477 4740 166 166 166 1802 166 2472 3953 166 1849 2604 3780 2560 +4786 2566 3576 166 4768 166 1951 251 5068 166 166 166 2619 166 166 166 5432 166 +166 5260 5758 3908 166 4141 166 5777 166 166 166 166 166 3961 5143 166 3889 +3747 3743 166 2818 166 166 166 3867 166 166 3742 4763 2948 5533 166 3966 3555 +3843 3503 6005 166 4687 2790 4479 5828 3769 5688 166 166 166 166 3109 166 166 +166 166 4574 81 166 166 4576 3369 166 166 166 4207 166 5072 2210 166 184 166 +4673 166 166 166 166 166 166 1628 3590 1916 4784 4970 166 1832 166 166 3584 +3384 166 166 2880 1783 166 166 166 166 6115 6121 2157 5428 5859 4861 5635 4331 +5839 4223 313 166 166 6152 2168 166 4112 6089 6012 166 5294 3207 166 166 4884 +166 4655 166 166 166 1743 166 4077 166 4631 166 166 2957 1945 4936 166 166 5389 +166 166 5955 166 166 1639 2207 4129 166 3582 5560 6147 3088 166 166 4529 5259 +3118 166 3106 2853 166 1845 5660 166 3325 3973 2461 2163 166 3083 4190 166 166 +5505 166 166 3226 5507 109 6141 3991 166 4939 166 166 5889 3986 166 3664 4353 +2056 166 5071 166 166 4376 166 1958 2028 166 166 1793 166 5252 3536 166 166 +3525 3580 166 166 166 1782 5174 2011 1826 3352 3231 166 166 4986 2068 2801 166 +2500 166 5061 166 2263 2632 1993 166 2715 4424 166 166 6042 4661 166 5074 5479 +4822 166 166 166 166 5600 5853 166 1907 166 166 166 3808 166 5997 5032 4605 166 +1732 166 166 166 3015 5454 166 166 166 3806 5444 2238 1946 166 166 3221 4922 +166 6092 166 166 4007 166 3425 4282 2571 166 1749 166 166 38 4744 4900 4257 214 +5687 166 2490 2979 2924 166 4714 219 5344 3836 3302 78 1984 2986 2960 166 2869 +3507 3335 4967 2892 2723 4849 5070 166 166 4629 3815 166 4453 4760 166 3224 130 +166 166 166 166 166 3408 2494 2691 166 4325 2932 5165 5573 166 4769 166 5411 +5637 2050 166 166 2305 166 166 4834 24 4693 3554 2491 1738 166 166 166 23 2758 +3072 2564 4800 5537 3545 4133 166 166 166 5982 166 203 166 166 290 185 166 3774 +1929 3379 166 166 166 166 3002 166 3738 166 166 3344 4942 5353 2777 2839 4712 +1830 2664 166 5884 3516 166 5494 4169 2391 3319 166 166 5918 2597 166 4821 2787 +5719 166 166 166 1687 6148 3257 254 166 5180 6153 5964 306 166 6123 166 5208 +166 3163 5938 1736 166 2502 4910 166 166 2549 166 2900 3632 3270 166 2082 5953 +166 107 5750 166 166 166 5527 1751 4168 2950 166 2659 166 4189 1943 2595 166 +4191 166 166 166 166 2998 2296 5221 3617 166 5435 2451 2009 3005 2242 3768 3658 +166 166 166 166 166 2481 2256 166 166 4074 166 3120 166 4409 1759 166 166 1679 +3659 3499 5219 4501 3082 2047 166 166 166 4560 2768 5251 166 166 166 2437 3993 +3215 2447 166 166 166 2993 4963 166 3045 166 166 166 166 166 166 166 5521 166 +166 4868 166 3895 166 6131 3949 3306 3785 166 166 4895 4831 166 1772 166 166 +5928 166 2137 4805 2462 310 2667 3561 166 166 2312 4931 5255 166 166 166 5670 +166 2285 166 4672 5310 166 2103 2174 166 166 166 166 5417 166 4726 4203 166 166 +166 5581 166 5665 166 166 5747 166 166 2509 1973 2749 5463 166 166 4567 5014 +166 3322 3051 166 4090 166 3709 3887 3478 166 166 166 166 3565 3934 166 32 166 +166 166 2239 166 3947 3849 166 2022 166 2169 166 4691 98 166 3804 4155 1640 +4002 166 2138 1739 3730 5970 2274 4873 3119 166 4925 3577 3699 4049 3982 166 +5161 1744 166 166 166 5704 4979 2686 5383 5744 2289 166 166 166 3927 2539 166 +166 166 2585 166 4723 3755 4509 166 4961 2194 2535 166 176 166 4494 166 4171 +166 266 166 3454 5369 166 166 5899 5284 166 3607 3566 5514 166 1843 166 3997 +4599 2743 166 2857 2497 2751 166 166 166 3511 5742 166 166 166 4504 166 166 166 +5082 4401 166 166 5431 166 166 1949 4539 166 166 4852 166 166 3457 166 3433 +4669 166 1692 2454 3258 6159 166 166 166 166 166 2788 4350 3249 3816 4893 166 +4846 166 4993 1708 4138 166 2895 2891 166 1860 166 2480 1927 3853 166 166 166 +5100 166 3143 5159 166 4286 5182 5246 4975 166 2905 166 4917 5102 2044 6016 +5673 2005 5090 166 4634 3333 166 5702 3413 1762 6094 4284 4431 2641 166 4463 +5691 166 166 3442 3473 4192 2046 166 3838 166 3217 3349 166 2243 166 3490 166 +166 166 5922 166 166 166 4885 1798 2884 2750 5004 2741 166 166 5649 166 4410 +166 166 3382 166 166 1913 1703 5532 3770 166 5116 2645 2634 4357 5901 166 166 +5538 166 166 166 6028 166 166 5840 4102 2704 2091 5287 166 4757 2282 166 2650 +3528 64 253 3732 166 166 166 166 166 3465 166 166 166 5848 3110 111 166 166 +3403 2926 6030 3366 1948 4430 5509 3250 3972 2587 3579 166 6048 250 5275 4242 +2615 3112 3558 166 166 2342 166 5157 1917 2733 5647 1934 5675 166 3981 2923 +5213 5326 37 166 5288 3069 166 1923 5755 166 166 166 1888 166 6041 5895 5376 +3727 3901 166 5589 166 166 4609 166 166 166 4706 166 4482 1622 166 171 166 166 +4646 4151 2755 4614 166 2072 5409 4469 1647 4434 4633 1915 166 3615 4808 166 +3388 166 5280 2731 166 166 2417 166 14 166 4533 5126 166 2778 3022 166 166 166 +4830 4764 166 166 166 4982 166 4265 166 2466 5678 147 1883 166 166 166 114 4000 +2427 3597 166 4853 5981 166 2023 2519 166 1937 2221 4676 166 4522 5716 166 2432 +5731 166 6020 6163 4351 2442 4380 166 4390 1882 6139 4246 262 166 1676 5781 +2352 1956 200 166 166 5800 6184 166 2355 149 5962 5524 4238 166 5150 166 5888 +2423 166 5739 3192 4142 166 166 166 3201 161 4460 2459 158 166 166 166 166 2689 +166 166 166 166 1889 166 166 3374 166 70 166 2772 166 2995 166 2384 4989 166 +3299 166 166 166 166 3614 3645 3415 3160 1727 3735 5201 1693 3531 166 166 1776 +3871 166 166 166 166 86 3553 166 166 166 3392 166 166 2232 166 4977 2333 3394 +2875 2027 5736 166 1719 166 4952 2061 2150 5526 166 4637 166 4333 166 166 4733 +4809 3911 166 3460 166 5355 3126 4181 4436 300 166 3841 166 4770 126 5654 166 +166 166 1730 166 166 166 5610 166 6002 2197 3807 6109 166 166 166 166 166 5395 +4004 166 46 166 166 2570 4736 5318 4247 166 166 166 2293 3031 4591 166 245 166 +5510 1616 3117 4163 166 166 4759 3462 4819 4947 166 3128 5946 2278 2969 166 166 +5183 166 166 1729 173 2448 166 230 2971 166 166 5397 166 4093 3348 1866 4280 +166 6067 3794 166 166 166 4729 166 3456 166 2394 166 4953 166 166 2258 4863 166 +166 4060 166 5468 305 166 6134 166 166 2326 166 3453 2167 2845 166 166 166 5597 +166 166 166 166 5462 2809 5994 2899 166 166 166 5153 166 166 1638 166 166 4938 +3795 166 3842 166 166 166 2769 3194 166 4745 5508 5604 3910 166 166 4147 3239 +166 166 3548 3859 2092 166 2705 166 166 3625 4131 166 3513 166 166 2987 4555 +3107 166 166 166 166 5713 4698 3079 166 5342 166 166 2673 2517 2745 1795 166 +166 166 166 166 166 2463 166 166 2445 5425 6138 166 2687 3254 5871 166 2387 +4300 166 166 3529 1996 166 2369 3818 6126 1615 2643 65 4297 166 5324 3311 3852 +166 3868 4199 3978 166 166 166 5466 166 166 244 166 5929 6157 2390 5639 2267 +2073 4610 5774 2521 4556 166 4545 4307 2426 2450 166 5783 4968 6176 4156 166 +166 4126 3549 166 3581 5701 3234 166 4013 1879 166 6104 5874 166 166 3485 4279 +2528 5576 166 3992 166 3980 4934 166 2176 4228 5164 3784 1933 4120 5055 166 166 +5015 166 166 166 2310 1754 166 6087 166 166 4548 5268 2930 166 3656 166 3042 +5229 166 4016 2195 166 166 166 199 1745 3717 166 166 74 2668 252 4124 4657 5223 +166 2186 3628 166 166 166 4222 3114 2841 5103 3171 5135 166 166 2273 166 3899 +5332 5842 3575 2579 2431 2464 2229 3604 4561 2977 2815 166 3916 166 5825 166 +1694 166 4030 166 5841 166 3881 1831 166 5525 3011 166 5535 5217 316 4116 166 +166 2204 166 3136 3650 166 5813 1875 4511 4475 166 1999 166 2277 166 3024 5484 +5546 166 3988 5676 166 2213 2264 5214 166 4940 5974 166 4750 6077 166 1652 3148 +166 166 166 166 2554 166 6167 5257 5300 166 166 166 166 5408 166 166 3402 2141 +166 4663 5633 3312 166 2814 4930 1959 166 166 166 3861 166 166 302 2624 166 166 +166 1629 1724 166 3909 5281 166 2001 4395 5352 4428 2694 4850 166 166 5242 5910 +166 166 166 166 166 3212 166 2045 166 166 166 166 166 166 3017 4960 4456 166 +5616 6093 2151 166 166 166 315 3381 166 166 166 4330 166 6158 4721 6075 166 166 +166 4543 2303 166 166 3301 166 5000 3929 2543 3437 166 166 166 3422 166 5987 +5729 2428 166 4035 5588 3714 3834 5264 5743 166 3305 4886 6107 5156 166 166 166 +166 166 1672 5849 5827 5049 6101 2178 2420 3289 166 166 4274 6017 2257 166 4172 +3451 2367 2382 166 2964 4918 3241 2347 6082 99 2383 166 4454 163 2460 165 304 +1818 5580 166 312 5790 293 5794 5519 5083 3360 5748 166 3750 5034 166 166 166 +1863 3168 166 166 166 5111 166 166 166 166 2183 4510 166 166 3495 4382 4235 +4462 166 4056 5885 17 5028 1614 6038 166 2488 5632 3089 166 1940 66 4039 3999 +235 166 166 3829 3954 166 2365 269 166 166 166 166 166 166 4418 1796 4709 2004 +166 3596 5786 166 2819 4624 3152 2968 2838 166 5575 1767 5603 166 4386 5890 166 +1768 4201 3560 166 166 166 2184 2262 2966 2716 1765 2611 2983 166 4164 4084 142 +5314 166 166 4071 166 2578 2849 3600 166 166 166 166 5401 4814 3431 166 5088 +5084 198 166 3578 3764 166 2097 166 166 5390 4443 166 3166 166 4816 166 166 166 +166 3130 5963 1788 2129 1837 4100 6128 166 4586 5945 4772 166 5741 3151 3247 +5645 4507 5833 3904 6013 2506 3050 4175 1705 3019 166 5942 166 2418 3430 2230 +5745 166 2093 166 166 166 166 4666 3246 192 2010 4003 3533 5851 166 3621 3684 +3066 166 166 166 5073 3856 166 166 2224 166 2637 4270 166 166 5679 166 5792 +5850 166 2589 3060 2196 3476 3150 2025 166 166 166 2657 166 3685 3790 5587 2817 +3692 166 166 166 2359 2260 5896 2158 119 2816 5753 166 2739 5772 166 2919 2147 +1985 4271 4838 4991 166 166 166 5244 166 319 166 166 2779 4732 4994 5424 166 +166 3968 3049 3393 4473 4959 5967 5864 5170 4209 166 4810 4815 4205 2339 5023 +2279 5050 166 5837 132 166 166 166 2247 21 4775 166 166 5286 166 4170 4099 4803 +5767 166 166 166 5811 2240 5699 2499 166 4802 166 5785 166 166 166 3181 3435 +166 3339 166 5669 3865 2249 5002 166 4694 5461 4753 166 3157 166 1960 166 166 +166 2440 166 5818 5534 2439 1717 166 3789 2959 166 2943 166 2576 166 2002 2007 +1819 3256 4402 5311 3832 160 166 166 2803 166 3264 166 5863 166 2017 166 2798 +166 166 166 166 5607 4965 166 166 166 4537 4378 5944 3494 5457 5602 1942 5900 +5780 4411 5147 166 4966 2115 155 2827 1980 5063 166 285 5912 3304 2963 5179 +3220 166 166 166 2190 3708 5476 1944 2366 3893 166 166 166 3759 166 5434 2740 +1707 4244 5426 166 166 166 3155 166 4285 166 166 166 166 5721 166 3833 6001 301 +166 166 2574 186 2724 166 1873 3667 166 5216 166 2935 2100 4987 166 2284 166 +166 2911 3828 4009 166 2065 166 5496 6130 5563 4387 166 3771 3469 2989 2222 +4577 3965 4296 2975 3813 3240 166 4780 4481 3387 2338 166 6183 166 166 166 166 +166 2675 1761 2600 5167 3170 4773 2165 5166 166 2223 4642 166 166 4540 166 166 +166 3897 166 2483 1809 5477 3844 4067 2508 2275 166 166 166 166 166 3497 5458 +166 249 2956 166 4651 166 283 166 166 4955 4062 2315 2304 3261 2361 4791 4389 +1997 166 3455 166 166 166 166 166 166 4746 5695 5296 105 1841 3368 166 166 166 +5228 166 3496 4423 2024 3907 4774 166 166 166 166 166 2294 2193 166 166 166 166 +166 166 166 166 4393 166 166 2127 166 4573 166 5350 166 5016 3372 166 5653 166 +5972 4719 166 166 166 166 166 5370 166 6142 166 166 3691 2828 166 2601 166 2937 +2060 3654 3097 2341 5325 4568 4096 2776 166 2946 166 166 166 5843 1777 5295 +2837 4261 4397 5006 5808 4866 166 1713 5732 2954 166 166 27 166 4308 5629 2652 +2434 4474 166 4928 166 4727 3811 166 166 5234 166 6010 166 4911 166 4570 166 +6000 3450 5304 3919 166 166 4008 3942 166 272 2363 2064 3595 3505 166 166 3957 +1695 2452 4659 166 1792 166 131 5968 166 3731 3905 4115 166 166 2468 166 2727 +166 3526 4724 166 4388 3149 5539 5092 4440 6162 166 166 193 4429 2493 166 166 +3683 166 6029 166 277 166 166 166 5240 2408 166 309 2561 210 166 5200 166 166 +166 1930 5692 2697 166 166 166 3330 5331 3860 166 166 4335 166 50 3605 4289 +1763 166 166 166 166 3521 166 166 166 3668 166 166 166 166 166 3271 1656 166 +166 4782 166 2962 166 5907 166 3245 3375 2944 5933 166 166 5406 5655 3139 5423 +166 4359 5231 2548 166 3831 2858 5488 166 5824 166 166 166 3885 4372 166 166 +4024 166 4811 2970 166 4219 211 166 3471 166 166 166 166 3854 166 3358 2877 166 +166 5205 2804 166 166 166 4452 166 166 166 166 3776 166 166 3075 4208 166 5623 +1974 166 2647 166 3235 166 166 166 5211 166 166 4304 2206 166 4157 2182 166 +1816 2626 166 2893 2248 166 166 166 166 1983 5648 166 194 166 2106 4328 166 +4742 166 166 5572 2329 3314 166 6181 166 166 26 166 6026 166 166 2114 1669 4735 +166 166 4256 166 1861 166 5470 2317 166 4404 2482 166 5305 4415 5986 4949 5412 +166 1728 166 1898 166 166 4909 1989 166 166 166 2836 2051 274 166 2799 166 5865 +1663 4705 5121 2555 166 4316 4287 1880 1825 166 3689 166 1733 5012 166 166 2237 +4471 1682 2910 166 5366 166 166 166 166 4532 166 2802 166 166 166 4057 2471 166 +2889 166 166 4026 5682 3091 166 1977 166 2901 6137 5658 88 2318 1965 166 5914 +166 166 4468 1822 166 6050 5956 2201 166 4644 2918 166 3703 166 166 3524 4220 +2913 4210 166 166 2090 166 1906 1911 166 166 3671 2370 166 2552 166 3763 2259 +1924 166 5940 166 166 166 3185 3821 4069 261 2381 3244 166 166 5715 166 2052 +5905 166 2403 166 3030 2199 166 3550 166 166 1846 166 166 95 166 289 3208 2559 +5195 5091 1654 166 1781 1892 166 4516 2629 166 1700 3067 166 166 166 2080 1680 +166 166 166 5700 166 1820 5491 166 4226 166 166 166 166 4653 166 3508 227 5364 +166 2098 166 299 166 5795 166 166 166 166 3690 4134 5517 4534 5042 4874 5798 +4234 166 166 166 166 3702 166 166 3638 3108 3850 166 166 166 16 166 1775 166 +4022 166 223 4095 166 5127 4266 166 189 166 166 5203 166 1805 3884 3778 166 166 +2146 4818 166 2848 3440 4506 5886 3006 218 166 2377 166 4091 5925 166 4320 166 +2701 3036 166 166 166 4715 166 3801 166 3161 166 2077 166 4254 3032 243 1814 +166 166 166 166 166 166 166 166 1835 166 4394 166 5769 4923 166 2917 166 166 +178 166 166 1723 166 5887 166 4956 2952 166 4665 3925 3443 3123 166 166 166 166 +166 166 5144 166 4288 2074 2192 5442 6043 1746 2016 5995 2203 166 5686 5659 +3193 166 4055 166 166 2233 3571 5809 5984 2323 166 166 1740 89 4356 6053 6106 +3282 4796 166 6116 6056 2353 2829 166 5807 2042 166 166 166 1670 5937 4465 5646 +166 5562 3008 166 2419 3736 166 4132 169 166 166 166 2402 166 166 1968 2398 166 +1684 1827 4551 2679 3875 166 5585 3835 2295 166 1991 1803 2992 166 166 5847 +2649 166 76 5415 166 2269 2397 5387 5337 4422 166 2672 4832 4617 166 166 166 +166 4552 166 4612 1750 166 1931 166 1691 2424 4194 6018 166 166 4458 4856 166 +2089 3814 166 2844 166 3592 166 4867 5128 166 2685 166 166 2616 1972 2617 3943 +4664 166 4999 166 166 145 3635 166 166 4851 166 3483 5039 166 3649 3924 166 166 +166 3105 4260 166 6098 166 3568 267 2456 3653 2096 166 166 166 3512 166 3405 +166 3504 166 166 166 4005 2144 1769 166 5474 1920 5554 215 2443 3351 166 5961 +166 166 166 166 242 2331 166 166 5931 166 166 5862 166 1710 166 166 166 3321 +166 4139 166 166 3515 2732 2510 5544 166 166 2783 166 166 166 4018 4649 5789 +166 166 166 166 166 2726 6074 166 166 166 5684 166 166 3395 166 3100 166 5763 +3757 1992 166 3198 2003 166 166 4675 166 1893 5621 166 2270 166 166 166 5421 +5590 5664 4045 166 3687 4406 2699 1811 167 4036 5384 166 166 4601 1823 4041 239 +1954 166 146 166 166 3077 5152 5814 1649 5681 166 5868 166 166 3792 4860 166 +5335 5110 1718 166 166 166 166 3718 3365 2826 166 166 5021 4783 166 5569 5812 +166 166 1876 166 3260 166 1789 5667 4224 166 166 4385 166 166 2620 166 4162 +2883 2143 5497 166 166 5316 5680 166 166 248 4050 166 6021 166 2898 4618 166 +166 166 166 166 5368 166 5378 1842 1914 3696 3962 166 4345 2581 1773 2109 166 +4371 166 166 3761 5277 5870 3146 166 166 166 5764 127 3058 4059 4718 166 5097 +5040 5351 3205 166 166 4996 2991 2014 166 5846 2558 2688 5595 4027 3347 2125 +5696 5608 166 166 3228 3745 5775 166 1757 4647 166 5977 3020 166 240 2565 166 +4459 166 3367 166 166 166 3104 166 166 166 166 166 166 259 5486 2846 166 166 +166 4778 2713 166 3955 5683 2682 2914 5898 166 166 166 4400 317 166 5185 3021 +5983 4332 3891 166 3095 5003 166 166 166 5367 166 279 1784 4019 2736 4905 2651 +5346 166 4841 166 5606 166 166 2806 166 5239 166 166 3237 5490 166 225 166 166 +2254 166 2742 4587 22 166 166 166 5555 166 108 2927 2218 166 2120 166 5452 4087 +4369 166 166 166 166 166 4583 4338 6035 2840 4365 3624 11 1770 166 4630 166 +3216 166 166 166 4638 4699 3535 2536 4627 166 166 5760 1935 166 166 5210 166 +2219 2484 4597 5193 4799 3706 166 166 166 166 3337 3113 5951 4294 166 4040 3200 +4217 5861 2767 3530 4499 2775 4121 134 5939 5880 5908 3869 166 166 3316 6095 +2441 3288 166 3751 4794 166 166 5803 6169 2356 6182 6135 6127 166 3018 166 1674 +166 166 4097 166 5923 287 5965 5129 166 4078 166 166 6114 6015 5990 3573 166 +4146 2681 90 6055 4864 166 166 6119 3284 6054 5456 5113 6125 166 6057 166 3292 +166 166 166 166 166 6185 5105 1760 166 166 166 2720 166 2695 5448 166 1936 166 +1807 3406 166 166 2161 1642 166 5030 166 2036 5451 3427 166 166 166 166 3797 +166 1627 166 4515 166 166 166 4241 166 166 166 2771 166 31 5197 2638 3035 166 +166 3914 166 166 4546 166 166 166 4253 3500 166 166 2526 166 2698 166 3726 2744 +137 166 166 2676 166 5594 166 166 166 4842 166 63 2888 3585 4798 166 5011 166 +5634 5464 166 166 5620 3894 4070 166 2730 166 166 1810 2503 5957 1721 6066 5188 +166 166 1890 4505 1771 5455 166 3132 3984 166 166 2811 1962 166 166 4872 106 +3898 3267 166 2085 166 4950 6040 4525 6044 5866 3613 2907 4615 2135 258 166 +1681 1941 4888 166 4859 6178 6174 4858 5209 1912 3340 166 4640 5706 166 2763 +3153 3951 166 5542 5596 5819 5330 5048 4037 166 6033 4625 3326 2013 5283 136 +3373 2154 166 166 166 4421 166 5438 2627 2266 2320 166 2588 4790 4290 166 4767 +5829 2925 5916 2133 166 } diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor index 29bd3ce6b8..9b7e99d3ea 100644 --- a/extra/poker/poker-tests.factor +++ b/extra/poker/poker-tests.factor @@ -8,9 +8,11 @@ IN: poker.tests [ 7462 ] [ "7C 5D 4H 3S 2C" value>> ] unit-test [ 1601 ] [ "KD QS JC TH 9S" value>> ] unit-test +[ 11 ] [ "AC AD AH AS KC" value>> ] unit-test [ 9 ] [ "6C 5C 4C 3C 2C" value>> ] unit-test [ 1 ] [ "AC KC QC JC TC" value>> ] unit-test [ "High Card" ] [ "7C 5D 4H 3S 2C" >value ] unit-test [ "Straight" ] [ "KD QS JC TH 9S" >value ] unit-test +[ "Four of a Kind" ] [ "AC AD AH AS KC" >value ] unit-test [ "Straight Flush" ] [ "6C 5C 4C 3C 2C" >value ] unit-test diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index 172bb49506..ca999dbf6e 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -4,8 +4,10 @@ USING: accessors ascii binary-search combinators kernel locals math math.bitwise math.order poker.arrays sequences splitting ; IN: poker -! The algorithm used is based on Cactus Kev's Poker Hand Evaluator: +! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with +! the Senzee Perfect Hash Optimization: ! http://www.suffecool.net/poker/evaluator.html +! http://www.senzee5.com/2006/06/some-perfect-hash.html card-rank ( card -- str ) From 87121c1468063196b3a210369ecc1fe1f8798dc6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 20:44:12 -0500 Subject: [PATCH 093/772] Fix prettyprinting of URLs --- basis/urls/prettyprint/prettyprint.factor | 7 +++++-- basis/urls/urls-tests.factor | 4 +++- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/basis/urls/prettyprint/prettyprint.factor b/basis/urls/prettyprint/prettyprint.factor index 59fb79e8d3..35e428c8fa 100644 --- a/basis/urls/prettyprint/prettyprint.factor +++ b/basis/urls/prettyprint/prettyprint.factor @@ -1,6 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel present prettyprint.custom prettyprint.backend urls ; +USING: kernel present prettyprint.custom prettyprint.sections +prettyprint.backend urls ; IN: urls.prettyprint -M: url pprint* dup present "URL\" " "\"" pprint-string ; +M: url pprint* + \ URL" record-vocab + dup present "URL\" " "\"" pprint-string ; diff --git a/basis/urls/urls-tests.factor b/basis/urls/urls-tests.factor index 74eea9506c..f45ad6449e 100644 --- a/basis/urls/urls-tests.factor +++ b/basis/urls/urls-tests.factor @@ -1,5 +1,5 @@ IN: urls.tests -USING: urls urls.private tools.test +USING: urls urls.private tools.test prettyprint arrays kernel assocs present accessors ; CONSTANT: urls @@ -227,3 +227,5 @@ urls [ [ "http://localhost/?foo=bar" >url ] unit-test [ "/" ] [ "http://www.jedit.org" >url path>> ] unit-test + +[ "USING: urls ;\nURL\" foo\"" ] [ URL" foo" unparse-use ] unit-test \ No newline at end of file From 68728d1cc4d82d688ff7c46990efd96b27b90c84 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 20:44:34 -0500 Subject: [PATCH 094/772] Fix prettyprint of CONSTANT: and ALIAS: --- basis/see/see-tests.factor | 11 +++++++++++ basis/see/see.factor | 12 ++++++++++-- core/words/alias/alias.factor | 7 ++++--- core/words/constant/constant-tests.factor | 14 ++++++++++++++ core/words/constant/constant.factor | 8 ++++++-- 5 files changed, 45 insertions(+), 7 deletions(-) create mode 100644 basis/see/see-tests.factor create mode 100644 core/words/constant/constant-tests.factor diff --git a/basis/see/see-tests.factor b/basis/see/see-tests.factor new file mode 100644 index 0000000000..3f11ec987e --- /dev/null +++ b/basis/see/see-tests.factor @@ -0,0 +1,11 @@ +IN: see.tests +USING: see tools.test io.streams.string math ; + +CONSTANT: test-const 10 +[ "IN: see.tests\nCONSTANT: test-const 10 inline\n" ] +[ [ \ test-const see ] with-string-writer ] unit-test + +ALIAS: test-alias + + +[ "USING: math ;\nIN: see.tests\nALIAS: test-alias + inline\n" ] +[ [ \ test-alias see ] with-string-writer ] unit-test diff --git a/basis/see/see.factor b/basis/see/see.factor index 32f49499db..9fc14ff581 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -7,7 +7,7 @@ definitions effects generic generic.standard io io.pathnames io.streams.string io.styles kernel make namespaces prettyprint prettyprint.backend prettyprint.config prettyprint.custom prettyprint.sections sequences sets sorting strings summary -words words.symbol ; +words words.symbol words.constant words.alias ; IN: see GENERIC: synopsis* ( defspec -- ) @@ -29,8 +29,16 @@ GENERIC: see* ( defspec -- ) : comment. ( text -- ) H{ { font-style italic } } styled-text ; +GENERIC: print-stack-effect? ( word -- ? ) + +M: parsing-word print-stack-effect? drop f ; +M: symbol print-stack-effect? drop f ; +M: constant print-stack-effect? drop f ; +M: alias print-stack-effect? drop f ; +M: word print-stack-effect? drop t ; + : stack-effect. ( word -- ) - [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and + [ print-stack-effect? ] [ stack-effect ] bi and [ effect>string comment. ] when* ; > first stack-effect ; +M: alias definer drop \ ALIAS: f ; + +M: alias definition def>> first 1quotation ; \ No newline at end of file diff --git a/core/words/constant/constant-tests.factor b/core/words/constant/constant-tests.factor new file mode 100644 index 0000000000..2755039af6 --- /dev/null +++ b/core/words/constant/constant-tests.factor @@ -0,0 +1,14 @@ +IN: words.constant.tests +USING: tools.test math ; + +CONSTANT: a + + +[ + ] [ a ] unit-test + +CONSTANT: b \ + + +[ \ + ] [ b ] unit-test + +CONSTANT: c { 1 2 3 } + +[ { 1 2 3 } ] [ c ] unit-test diff --git a/core/words/constant/constant.factor b/core/words/constant/constant.factor index 43b7f37599..00302df98a 100644 --- a/core/words/constant/constant.factor +++ b/core/words/constant/constant.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences words ; +USING: accessors kernel sequences words definitions quotations ; IN: words.constant PREDICATE: constant < word ( obj -- ? ) @@ -8,3 +8,7 @@ PREDICATE: constant < word ( obj -- ? ) : define-constant ( word value -- ) [ ] curry (( -- value )) define-inline ; + +M: constant definer drop \ CONSTANT: f ; + +M: constant definition def>> first literalize 1quotation ; \ No newline at end of file From 880f4097adf08767d96f014cd2476fa835e54b38 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 20:50:45 -0500 Subject: [PATCH 095/772] Clear button in search field is now positioned correctly --- basis/ui/gadgets/search-tables/search-tables-tests.factor | 3 +++ basis/ui/gadgets/search-tables/search-tables.factor | 1 + 2 files changed, 4 insertions(+) create mode 100644 basis/ui/gadgets/search-tables/search-tables-tests.factor diff --git a/basis/ui/gadgets/search-tables/search-tables-tests.factor b/basis/ui/gadgets/search-tables/search-tables-tests.factor new file mode 100644 index 0000000000..5a627286f9 --- /dev/null +++ b/basis/ui/gadgets/search-tables/search-tables-tests.factor @@ -0,0 +1,3 @@ +IN: ui.gadgets.search-tables.tests +USING: ui.gadgets.search-tables sequences tools.test ; +[ [ second ] ] must-infer diff --git a/basis/ui/gadgets/search-tables/search-tables.factor b/basis/ui/gadgets/search-tables/search-tables.factor index 4a2983bfe0..17570a8714 100644 --- a/basis/ui/gadgets/search-tables/search-tables.factor +++ b/basis/ui/gadgets/search-tables/search-tables.factor @@ -28,6 +28,7 @@ TUPLE: search-field < track field ; : ( model -- gadget ) horizontal search-field new-track + 0 >>fill { 5 5 } >>gap +baseline+ >>align swap 10 >>min-cols >>field From cbc63b49690aed45efa74c06fc46712e04c7e84f Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 5 Apr 2009 23:28:13 -0400 Subject: [PATCH 096/772] Add more unit test coverage for poker vocab --- extra/poker/poker-tests.factor | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor index 9b7e99d3ea..f7d9e4f6c3 100644 --- a/extra/poker/poker-tests.factor +++ b/extra/poker/poker-tests.factor @@ -5,7 +5,6 @@ IN: poker.tests [ 529159 ] [ "5s" >ckf ] unit-test [ 33589533 ] [ "jc" >ckf ] unit-test - [ 7462 ] [ "7C 5D 4H 3S 2C" value>> ] unit-test [ 1601 ] [ "KD QS JC TH 9S" value>> ] unit-test [ 11 ] [ "AC AD AH AS KC" value>> ] unit-test @@ -16,3 +15,12 @@ IN: poker.tests [ "Straight" ] [ "KD QS JC TH 9S" >value ] unit-test [ "Four of a Kind" ] [ "AC AD AH AS KC" >value ] unit-test [ "Straight Flush" ] [ "6C 5C 4C 3C 2C" >value ] unit-test + +[ +gt+ ] [ "7C 5D 4H 3S 2C" "KD QS JC TH 9S" [ ] bi@ <=> ] unit-test +[ +lt+ ] [ "AC AD AH AS KC" "KD QS JC TH 9S" [ ] bi@ <=> ] unit-test +[ +eq+ ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ <=> ] unit-test + +[ t ] [ "7C 5D 4H 3S 2C" "2C 3S 4H 5D 7C" [ ] bi@ = ] unit-test + +[ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ = ] unit-test +[ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ eq? ] unit-test From 687e9f90fe70c5e0491995fa911d797b9eaf07d3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 23:16:48 -0500 Subject: [PATCH 097/772] Move models.history to extra --- basis/models/models-docs.factor | 1 - {basis => extra}/models/history/history-docs.factor | 0 {basis => extra}/models/history/history-tests.factor | 0 {basis => extra}/models/history/history.factor | 0 {basis => extra}/models/history/summary.txt | 0 5 files changed, 1 deletion(-) rename {basis => extra}/models/history/history-docs.factor (100%) rename {basis => extra}/models/history/history-tests.factor (100%) rename {basis => extra}/models/history/history.factor (100%) rename {basis => extra}/models/history/summary.txt (100%) diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor index 2b90bdb0d5..8f40a8adbe 100644 --- a/basis/models/models-docs.factor +++ b/basis/models/models-docs.factor @@ -133,7 +133,6 @@ $nl { $subsection "models-impl" } { $subsection "models.arrow" } { $subsection "models.product" } -{ $subsection "models-history" } { $subsection "models-range" } { $subsection "models-delay" } ; diff --git a/basis/models/history/history-docs.factor b/extra/models/history/history-docs.factor similarity index 100% rename from basis/models/history/history-docs.factor rename to extra/models/history/history-docs.factor diff --git a/basis/models/history/history-tests.factor b/extra/models/history/history-tests.factor similarity index 100% rename from basis/models/history/history-tests.factor rename to extra/models/history/history-tests.factor diff --git a/basis/models/history/history.factor b/extra/models/history/history.factor similarity index 100% rename from basis/models/history/history.factor rename to extra/models/history/history.factor diff --git a/basis/models/history/summary.txt b/extra/models/history/summary.txt similarity index 100% rename from basis/models/history/summary.txt rename to extra/models/history/summary.txt From 8bf5fde791b992a73761614e6024982a804317df Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 23:18:25 -0500 Subject: [PATCH 098/772] Rename scroll word to set-scroll-position and make it public --- .../gadgets/scrollers/scrollers-docs.factor | 8 +++--- .../gadgets/scrollers/scrollers-tests.factor | 2 +- basis/ui/gadgets/scrollers/scrollers.factor | 25 ++++++++++--------- basis/ui/gadgets/viewports/viewports.factor | 4 +-- 4 files changed, 20 insertions(+), 19 deletions(-) diff --git a/basis/ui/gadgets/scrollers/scrollers-docs.factor b/basis/ui/gadgets/scrollers/scrollers-docs.factor index 8e0131ec31..92831bea00 100644 --- a/basis/ui/gadgets/scrollers/scrollers-docs.factor +++ b/basis/ui/gadgets/scrollers/scrollers-docs.factor @@ -11,11 +11,11 @@ HELP: find-scroller { $values { "gadget" gadget } { "scroller/f" { $maybe scroller } } } { $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link scroller } ". Outputs " { $link f } " if the gadget is not contained in a " { $link scroller } "." } ; -HELP: scroller-value +HELP: scroll-position { $values { "scroller" scroller } { "loc" "a pair of integers" } } { $description "Outputs the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ; -{ scroller-value scroll scroll>bottom scroll>top scroll>rect } related-words +{ scroll-position scroll scroll>bottom scroll>top scroll>rect } related-words HELP: { $values { "gadget" gadget } { "scroller" "a new " { $link scroller } } } @@ -48,8 +48,8 @@ ARTICLE: "ui.gadgets.scrollers" "Scroller gadgets" { $subsection scroller } { $subsection } "Getting and setting the scroll position:" -{ $subsection scroller-value } -{ $subsection scroll } +{ $subsection scroll-position } +{ $subsection set-scroll-position } "Writing scrolling-aware gadgets:" { $subsection scroll>bottom } { $subsection scroll>top } diff --git a/basis/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor index d4cdc95daf..cf63d616be 100644 --- a/basis/ui/gadgets/scrollers/scrollers-tests.factor +++ b/basis/ui/gadgets/scrollers/scrollers-tests.factor @@ -74,7 +74,7 @@ dup layout drop "g2" get scroll>gadget "s" get layout - "s" get scroller-value + "s" get scroll-position ] map [ { 0 0 } = ] all? ] unit-test diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor index a526cc618b..0852a6fe5d 100644 --- a/basis/ui/gadgets/scrollers/scrollers.factor +++ b/basis/ui/gadgets/scrollers/scrollers.factor @@ -29,6 +29,13 @@ M: gadget viewport-column-header drop f ; : scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ; +: set-scroll-position ( value scroller -- ) + [ + viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi + 4array flip + ] keep + 2dup control-value = [ 2drop ] [ set-control-value ] if ; + > [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi - 4array flip - ] keep - 2dup control-value = [ 2drop ] [ set-control-value ] if ; - : (scroll>rect) ( rect scroller -- ) { - [ scroller-value vneg offset-rect ] + [ scroll-position vneg offset-rect ] [ viewport>> dim>> rect-min ] [ viewport>> loc>> offset-rect ] [ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ] - [ scroller-value v+ ] - [ scroll ] + [ scroll-position v+ ] + [ set-scroll-position ] } cleave ; : relative-scroll-rect ( rect gadget scroller -- newrect ) @@ -72,7 +72,7 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ; 2&& ; : (update-scroller) ( scroller -- ) - [ scroller-value ] keep scroll ; + [ scroll-position ] keep set-scroll-position ; : (scroll>gadget) ( gadget scroller -- ) 2dup swap child? [ @@ -82,7 +82,8 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ; ] [ f >>follows (update-scroller) drop ] if ; : (scroll>bottom) ( scroller -- ) - [ viewport>> gadget-child pref-dim { 0 1 } v* ] keep scroll ; + [ viewport>> gadget-child pref-dim { 0 1 } v* ] keep + set-scroll-position ; GENERIC: update-scroller ( scroller follows -- ) diff --git a/basis/ui/gadgets/viewports/viewports.factor b/basis/ui/gadgets/viewports/viewports.factor index c14c7f01fb..b154ef2322 100644 --- a/basis/ui/gadgets/viewports/viewports.factor +++ b/basis/ui/gadgets/viewports/viewports.factor @@ -23,7 +23,7 @@ M: viewport layout* M: viewport focusable-child* gadget-child ; -: scroller-value ( scroller -- loc ) +: scroll-position ( scroller -- loc ) model>> range-value [ >integer ] map ; M: viewport model-changed @@ -31,7 +31,7 @@ M: viewport model-changed [ relayout-1 ] [ [ gadget-child ] - [ scroller-value vneg ] + [ scroll-position vneg ] [ constraint>> ] tri v* >>loc drop ] bi ; From 78013c2bdffc9f579bbe1d8c137c265f32b7e77e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 23:19:18 -0500 Subject: [PATCH 099/772] Rename scroll word to set-scroll-position and make it public --- basis/ui/gadgets/scrollers/scrollers-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/ui/gadgets/scrollers/scrollers-docs.factor b/basis/ui/gadgets/scrollers/scrollers-docs.factor index 92831bea00..011afa5c97 100644 --- a/basis/ui/gadgets/scrollers/scrollers-docs.factor +++ b/basis/ui/gadgets/scrollers/scrollers-docs.factor @@ -15,7 +15,7 @@ HELP: scroll-position { $values { "scroller" scroller } { "loc" "a pair of integers" } } { $description "Outputs the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ; -{ scroll-position scroll scroll>bottom scroll>top scroll>rect } related-words +{ scroll-position set-scroll-position scroll>bottom scroll>top scroll>rect } related-words HELP: { $values { "gadget" gadget } { "scroller" "a new " { $link scroller } } } @@ -23,7 +23,7 @@ HELP: { } related-words -HELP: scroll +HELP: set-scroll-position { $values { "scroller" scroller } { "value" "a pair of integers" } } { $description "Sets the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ; From 88bbb47bfa31afb37513628286b4146198da93f0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 23:19:35 -0500 Subject: [PATCH 100/772] Browser tool now saves scroll bar position in history --- basis/ui/tools/browser/browser.factor | 41 ++++++++++++------- basis/ui/tools/browser/history/authors.txt | 1 + .../browser/history/history-tests.factor | 36 ++++++++++++++++ basis/ui/tools/browser/history/history.factor | 32 +++++++++++++++ 4 files changed, 95 insertions(+), 15 deletions(-) create mode 100644 basis/ui/tools/browser/history/authors.txt create mode 100644 basis/ui/tools/browser/history/history-tests.factor create mode 100644 basis/ui/tools/browser/history/history.factor diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index e242b743f8..0c6e1fe05a 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -1,23 +1,33 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: debugger help help.topics help.crossref help.home kernel -models compiler.units assocs words vocabs accessors fry -combinators.short-circuit namespaces sequences models -models.history help.apropos combinators ui.commands ui.gadgets -ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks -ui.gestures ui.gadgets.buttons ui.gadgets.packs -ui.gadgets.editors ui.gadgets.labels ui.gadgets.status-bar -ui.gadgets.glass ui.gadgets.borders ui.tools.common -ui.tools.browser.popups ui ; +USING: debugger help help.topics help.crossref help.home kernel models +compiler.units assocs words vocabs accessors fry arrays +combinators.short-circuit namespaces sequences models help.apropos +combinators ui ui.commands ui.gadgets ui.gadgets.panes +ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons +ui.gadgets.packs ui.gadgets.editors ui.gadgets.labels +ui.gadgets.status-bar ui.gadgets.glass ui.gadgets.borders ui.gadgets.viewports +ui.tools.common ui.tools.browser.popups ui.tools.browser.history ; IN: ui.tools.browser -TUPLE: browser-gadget < tool pane scroller search-field popup ; +TUPLE: browser-gadget < tool history pane scroller search-field popup ; { 650 400 } browser-gadget set-tool-dim +M: browser-gadget history-value + [ control-value ] [ scroller>> scroll-position ] + bi 2array ; + +M: browser-gadget set-history-value + [ first2 ] dip + [ set-control-value ] [ scroller>> set-scroll-position ] + bi-curry bi* ; + : show-help ( link browser-gadget -- ) - [ >link ] [ model>> ] bi* - [ [ add-recent ] [ add-history ] bi* ] [ set-model ] 2bi ; + [ >link ] dip + [ [ add-recent ] [ history>> add-history ] bi* ] + [ model>> set-model ] + 2bi ; : ( browser-gadget -- gadget ) model>> [ '[ _ print-topic ] try ] ; @@ -41,7 +51,8 @@ TUPLE: browser-gadget < tool pane scroller search-field popup ; : ( link -- gadget ) vertical browser-gadget new-track 1 >>fill - swap >link >>model + swap >link >>model + dup >>history dup >>search-field dup { 3 3 } { 1 0 } >>fill f track-add dup >>pane @@ -93,9 +104,9 @@ M: browser-gadget focusable-child* search-field>> ; \ show-browser H{ { +nullary+ t } } define-command -: com-back ( browser -- ) model>> go-back ; +: com-back ( browser -- ) history>> go-back ; -: com-forward ( browser -- ) model>> go-forward ; +: com-forward ( browser -- ) history>> go-forward ; : com-home ( browser -- ) "help.home" swap show-help ; diff --git a/basis/ui/tools/browser/history/authors.txt b/basis/ui/tools/browser/history/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/ui/tools/browser/history/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/ui/tools/browser/history/history-tests.factor b/basis/ui/tools/browser/history/history-tests.factor new file mode 100644 index 0000000000..20b16f450a --- /dev/null +++ b/basis/ui/tools/browser/history/history-tests.factor @@ -0,0 +1,36 @@ +USING: namespaces ui.tools.browser.history sequences tools.test ; +IN: ui.tools.browser.history.tests + +f "history" set + +"history" get add-history + +[ t ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test + +"history" get add-history +"history" get 3 >>value drop + +[ t ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test + +"history" get add-history +"history" get 4 >>value drop + +[ f ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test + +"history" get go-back + +[ 3 ] [ "history" get value>> ] unit-test + +[ t ] [ "history" get back>> empty? ] unit-test +[ f ] [ "history" get forward>> empty? ] unit-test + +"history" get go-forward + +[ 4 ] [ "history" get value>> ] unit-test + +[ f ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test + diff --git a/basis/ui/tools/browser/history/history.factor b/basis/ui/tools/browser/history/history.factor new file mode 100644 index 0000000000..f80189c783 --- /dev/null +++ b/basis/ui/tools/browser/history/history.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences locals ; +IN: ui.tools.browser.history + +TUPLE: history owner back forward ; + +: ( owner -- history ) + V{ } clone V{ } clone history boa ; + +GENERIC: history-value ( object -- value ) + +GENERIC: set-history-value ( value object -- ) + +: (add-history) ( history to -- ) + swap owner>> history-value dup [ swap push ] [ 2drop ] if ; + +:: go-back/forward ( history to from -- ) + from empty? [ + history to (add-history) + from pop history owner>> set-history-value + ] unless ; + +: go-back ( history -- ) + dup [ forward>> ] [ back>> ] bi go-back/forward ; + +: go-forward ( history -- ) + dup [ back>> ] [ forward>> ] bi go-back/forward ; + +: add-history ( history -- ) + dup forward>> delete-all + dup back>> (add-history) ; \ No newline at end of file From 8201139dc7669ca7c79ef0b1d6db6ad39711cafc Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 6 Apr 2009 00:30:21 -0400 Subject: [PATCH 101/772] One more poker unit test dealing with equality --- extra/poker/poker-tests.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor index f7d9e4f6c3..1862974084 100644 --- a/extra/poker/poker-tests.factor +++ b/extra/poker/poker-tests.factor @@ -16,6 +16,8 @@ IN: poker.tests [ "Four of a Kind" ] [ "AC AD AH AS KC" >value ] unit-test [ "Straight Flush" ] [ "6C 5C 4C 3C 2C" >value ] unit-test +[ "6C 5C 4C 3C 2C" ] [ "6C 5C 4C 3C 2C" >cards ] unit-test + [ +gt+ ] [ "7C 5D 4H 3S 2C" "KD QS JC TH 9S" [ ] bi@ <=> ] unit-test [ +lt+ ] [ "AC AD AH AS KC" "KD QS JC TH 9S" [ ] bi@ <=> ] unit-test [ +eq+ ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ <=> ] unit-test From cb6030778f78d75ec1bcb2a28873cd9ab05bbc2f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 23:38:47 -0500 Subject: [PATCH 102/772] Fix ui.gadgets.scrollers unit tests --- basis/ui/gadgets/scrollers/scrollers-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor index cf63d616be..22df1f328b 100644 --- a/basis/ui/gadgets/scrollers/scrollers-tests.factor +++ b/basis/ui/gadgets/scrollers/scrollers-tests.factor @@ -45,13 +45,13 @@ IN: ui.gadgets.scrollers.tests [ { 100 100 } ] [ "s" get viewport>> gadget-child pref-dim ] unit-test - [ ] [ { 0 0 } "s" get scroll ] unit-test + [ ] [ { 0 0 } "s" get set-scroll-position ] unit-test [ { 0 0 } ] [ "s" get model>> range-min-value ] unit-test [ { 100 100 } ] [ "s" get model>> range-max-value ] unit-test - [ ] [ { 10 20 } "s" get scroll ] unit-test + [ ] [ { 10 20 } "s" get set-scroll-position ] unit-test [ { 10 20 } ] [ "s" get model>> range-value ] unit-test From 42f3b0e16e8d327c048053663788fe096986ca89 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 01:10:34 -0500 Subject: [PATCH 103/772] Fix bootstrap errors --- basis/bootstrap/stage2.factor | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 6c824b6155..12741f2170 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -45,11 +45,18 @@ SYMBOL: bootstrap-time [ optimized>> ] count-words " compiled words" print [ symbol? ] count-words " symbol words" print [ ] count-words " words total" print - + "Bootstrapping is complete." print "Now, you can run Factor:" print vm write " -i=" write "output-image" get print flush ; +: save/restore-error ( quot -- ) + error get-global + error-continuation get-global + [ call ] 2dip + error-continuation set-global + error set-global ; inline + [ ! We time bootstrap millis @@ -104,6 +111,7 @@ SYMBOL: bootstrap-time drop [ load-help? off - "vocab:bootstrap/bootstrap-error.factor" run-file + [ "vocab:bootstrap/bootstrap-error.factor" parse-file ] save/restore-error + call ] with-scope ] recover From 3752c706da151d168dbddf903c6ca4a91e41b5a9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 02:57:39 -0500 Subject: [PATCH 104/772] Add M\ syntax for method literals --- basis/prettyprint/backend/backend.factor | 32 +++++++++++----------- basis/prettyprint/prettyprint-tests.factor | 22 --------------- core/bootstrap/syntax.factor | 1 + core/syntax/syntax-docs.factor | 4 +++ core/syntax/syntax.factor | 1 + 5 files changed, 22 insertions(+), 38 deletions(-) diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index bcd91a4d94..8004c1141f 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -41,18 +41,18 @@ M: effect pprint* effect>string "(" ")" surround text ; : pprint-prefix ( word quot -- ) ; inline +M: parsing-word pprint* + \ POSTPONE: [ pprint-word ] pprint-prefix ; + M: word pprint* - dup parsing-word? [ - \ POSTPONE: [ pprint-word ] pprint-prefix - ] [ - { - [ "break-before" word-prop line-break ] - [ pprint-word ] - [ ?start-group ] - [ ?end-group ] - [ "break-after" word-prop line-break ] - } cleave - ] if ; + [ pprint-word ] [ ?start-group ] [ ?end-group ] tri ; + +M: method-body pprint* + ; M: real pprint* number>string text ; @@ -206,8 +206,8 @@ M: curry pprint* pprint-object ; M: compose pprint* pprint-object ; M: wrapper pprint* - dup wrapped>> word? [ - > pprint-word block> - ] [ - pprint-object - ] if ; + { + { [ dup wrapped>> method-body? ] [ wrapped>> pprint* ] } + { [ dup wrapped>> word? ] [ > pprint-word block> ] } + [ pprint-object ] + } cond ; diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index 7e37aa0da5..3350ae6c7b 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -180,28 +180,6 @@ DEFER: parse-error-file "string-layout-test" string-layout check-see ] unit-test -! Define dummy words for the below... -: ( a b c d -- e ) ; -: ( -- fmt ) ; -: send ( obj -- ) ; - -\ send soft "break-after" set-word-prop - -: final-soft-break-test ( -- str ) - { - "USING: kernel sequences ;" - "IN: prettyprint.tests" - ": final-soft-break-layout ( class dim -- view )" - " [ \"alloc\" send 0 0 ] dip first2 " - " \"initWithFrame:pixelFormat:\" send" - " dup 1 \"setPostsBoundsChangedNotifications:\" send" - " dup 1 \"setPostsFrameChangedNotifications:\" send ;" - } ; - -[ t ] [ - "final-soft-break-layout" final-soft-break-test check-see -] unit-test - : narrow-test ( -- str ) { "USING: arrays combinators continuations kernel sequences ;" diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 6e6812e25c..a0b349be51 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -62,6 +62,7 @@ IN: bootstrap.syntax "W{" "[" "\\" + "M\\" "]" "delimiter" "f" diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index df9eb568f6..bb8791df97 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -167,6 +167,8 @@ $nl ARTICLE: "syntax" "Syntax" "Factor has two main forms of syntax: " { $emphasis "definition" } " syntax and " { $emphasis "literal" } " syntax. Code is data, so the syntax for code is a special case of object literal syntax. This section documents literal syntax. Definition syntax is covered in " { $link "words" } ". Extending the parser is the main topic of " { $link "parser" } "." { $subsection "parser-algorithm" } +{ $subsection "vocabulary-search" } +{ $subsection "top-level-forms" } { $subsection "syntax-comments" } { $subsection "syntax-literals" } { $subsection "syntax-immediate" } ; @@ -762,7 +764,9 @@ HELP: >> { $description "Marks the end of a parse time code block." } ; HELP: call-next-method +{ $syntax "call-next-method" } { $description "Calls the next applicable method. Only valid inside a method definition. The values at the top of the stack are passed on to the next method, and they must be compatible with that method's class specializer." } +{ $notes "This word looks like an ordinary word but it is a parsing word. It cannot be factored out of a method definition, since the code expansion references the current method object directly." } { $errors "Throws a " { $link no-next-method } " error if this is the least specific method, and throws an " { $link inconsistent-next-method } " error if the values at the top of the stack are not compatible with the current method's specializer." } ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index cb5cdfd5ac..2e072f72d8 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -104,6 +104,7 @@ IN: bootstrap.syntax "POSTPONE:" [ scan-word parsed ] define-core-syntax "\\" [ scan-word parsed ] define-core-syntax + "M\\" [ scan-word scan-word method parsed ] define-core-syntax "inline" [ word make-inline ] define-core-syntax "recursive" [ word make-recursive ] define-core-syntax "foldable" [ word make-foldable ] define-core-syntax From 268abfcf2a389104a47e4f2174af4482de94b50f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 02:59:59 -0500 Subject: [PATCH 105/772] Remove method-specs in favor of M\ --- basis/compiler/tree/debugger/debugger.factor | 2 -- basis/editors/editors-docs.factor | 2 +- basis/hints/hints.factor | 5 ++-- basis/see/see-docs.factor | 7 +++++- basis/see/see.factor | 6 ----- basis/tools/annotations/annotations.factor | 11 +-------- basis/tools/deploy/shaker/shaker.factor | 2 -- basis/tools/disassembler/disassembler.factor | 2 -- core/generic/generic.factor | 26 -------------------- 9 files changed, 10 insertions(+), 53 deletions(-) diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 430424291e..8e102e0ea3 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -130,8 +130,6 @@ M: node node>quot drop ; GENERIC: optimized. ( quot/word -- ) -M: method-spec optimized. first2 method optimized. ; - M: word optimized. specialized-def optimized. ; M: callable optimized. build-tree optimize-tree nodes>quot . ; diff --git a/basis/editors/editors-docs.factor b/basis/editors/editors-docs.factor index 0f50e40eb4..e3961aef80 100644 --- a/basis/editors/editors-docs.factor +++ b/basis/editors/editors-docs.factor @@ -22,7 +22,7 @@ HELP: edit "A word's documentation:" { $code "\\ foo >link edit" } "A method definition:" - { $code "{ editor draw-gadget* } edit" } + { $code "M\\ fixnum + edit" } "A help article:" { $code "\"handbook\" >link edit" } } ; diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 804ef035f4..6fece31d88 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -65,7 +65,6 @@ M: object specializer-declaration class ; SYNTAX: HINTS: scan-object - dup method-spec? [ first2 method ] when [ redefined ] [ parse-definition "specializer" set-word-prop ] bi ; @@ -119,6 +118,6 @@ SYNTAX: HINTS: \ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop -\ hashtable \ at* method { { fixnum object } { word object } } "specializer" set-word-prop +M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop -\ hashtable \ set-at method { { object fixnum object } { object word object } } "specializer" set-word-prop +M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop diff --git a/basis/see/see-docs.factor b/basis/see/see-docs.factor index 6d51b42a86..b2e99843c7 100644 --- a/basis/see/see-docs.factor +++ b/basis/see/see-docs.factor @@ -13,7 +13,12 @@ HELP: synopsis* HELP: see { $values { "defspec" "a definition specifier" } } -{ $contract "Prettyprints a definition." } ; +{ $contract "Prettyprints a definition." } +{ $examples + "A word:" { $code "\\ append see" } + "A method:" { $code "USE: arrays" "M\\ array length see" } + "A help article:" { $code "USE: help.topics" "\"help\" >link see" } +} ; HELP: see-methods { $values { "word" "a " { $link generic } " or a " { $link class } } } diff --git a/basis/see/see.factor b/basis/see/see.factor index 9fc14ff581..2494c72fa4 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -76,9 +76,6 @@ M: hook-generic synopsis* [ stack-effect. ] } cleave ; -M: method-spec synopsis* - first2 method synopsis* ; - M: method-body synopsis* [ definer. ] [ "method-class" word-prop pprint-word ] @@ -122,9 +119,6 @@ M: object see* block> ] with-use ; -M: method-spec see* - first2 method see* ; - GENERIC: see-class* ( word -- ) M: union-class see-class* diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index 8c3d95f2b8..64e6508ab6 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -20,9 +20,6 @@ M: word reset f "unannotated-def" set-word-prop ] [ drop ] if ; -M: method-spec reset - first2 method reset ; - ERROR: cannot-annotate-twice word ; word ( obj -- word ) - dup method-spec? [ first2 method ] when ; - : save-unannotated-def ( word -- ) dup def>> "unannotated-def" set-word-prop ; @@ -44,7 +38,7 @@ ERROR: cannot-annotate-twice word ; PRIVATE> : annotate ( word quot -- ) - [ method-spec>word check-annotate-twice ] dip + [ check-annotate-twice ] dip [ over save-unannotated-def (annotate) ] with-compilation-unit ; spaces print ] each ; M: word disassemble word-xt 2array disassemble ; -M: method-spec disassemble first2 method disassemble ; - cpu x86? "tools.disassembler.udis" "tools.disassembler.gdb" ? diff --git a/core/generic/generic.factor b/core/generic/generic.factor index c22641d439..ab0685f1d6 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -24,11 +24,6 @@ M: generic definition drop f ; : method ( class generic -- method/f ) "methods" word-prop at ; -PREDICATE: method-spec < pair - first2 generic? swap class? and ; - -INSTANCE: method-spec definition - : order ( generic -- seq ) "methods" word-prop keys sort-classes ; @@ -90,9 +85,6 @@ TUPLE: check-method class generic ; PREDICATE: method-body < word "method-generic" word-prop >boolean ; -M: method-spec stack-effect - first2 method stack-effect ; - M: method-body stack-effect "method-generic" word-prop stack-effect ; @@ -139,24 +131,6 @@ M: default-method irrelevant? drop t ; dupd "default-method" set-word-prop ; ! Definition protocol -M: method-spec where - dup first2 method [ ] [ second ] ?if where ; - -M: method-spec set-where - first2 method set-where ; - -M: method-spec definer - first2 method definer ; - -M: method-spec definition - first2 method definition ; - -M: method-spec forget* - first2 method [ forgotten-definition ] [ forget* ] bi ; - -M: method-spec smart-usage - second smart-usage ; - M: method-body definer drop \ M: \ ; ; From 99b8400e56e23584db5544e3b3cb64357721ec31 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 03:00:46 -0500 Subject: [PATCH 106/772] Documentation updates --- basis/alien/syntax/tags.txt | 1 + .../combinators/short-circuit/smart/tags.txt | 1 + basis/combinators/short-circuit/tags.txt | 1 + basis/combinators/smart/smart-docs.factor | 14 +- basis/combinators/smart/tags.txt | 1 + basis/help/cookbook/cookbook.factor | 2 +- basis/help/handbook/handbook.factor | 89 +++-- basis/help/home/home-docs.factor | 1 - basis/help/syntax/tags.txt | 1 + basis/interpolate/tags.txt | 1 + basis/locals/locals-docs.factor | 11 +- basis/math/ranges/ranges-docs.factor | 4 +- basis/peg/ebnf/tags.txt | 1 + basis/ui/tools/tools-docs.factor | 4 +- basis/unicode/unicode-docs.factor | 2 +- basis/values/values-docs.factor | 2 +- basis/xml/syntax/tags.txt | 1 + core/combinators/combinators-docs.factor | 315 ++++++++++++++++-- core/definitions/definitions-docs.factor | 15 +- core/effects/effects-docs.factor | 15 +- core/generic/generic-docs.factor | 13 +- core/generic/generic-tests.factor | 3 - core/generic/math/math-docs.factor | 2 +- core/kernel/kernel-docs.factor | 285 ---------------- core/math/math-docs.factor | 5 +- core/math/order/order-docs.factor | 11 +- core/namespaces/namespaces-docs.factor | 3 +- core/parser/parser-docs.factor | 2 - core/quotations/quotations-docs.factor | 2 +- core/sequences/sequences-docs.factor | 11 +- core/slots/slots-docs.factor | 5 +- extra/peg-lexer/tags.txt | 3 +- 32 files changed, 440 insertions(+), 387 deletions(-) create mode 100644 basis/alien/syntax/tags.txt create mode 100644 basis/combinators/short-circuit/smart/tags.txt create mode 100644 basis/combinators/short-circuit/tags.txt create mode 100644 basis/combinators/smart/tags.txt create mode 100644 basis/help/syntax/tags.txt create mode 100644 basis/interpolate/tags.txt diff --git a/basis/alien/syntax/tags.txt b/basis/alien/syntax/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/basis/alien/syntax/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/basis/combinators/short-circuit/smart/tags.txt b/basis/combinators/short-circuit/smart/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/basis/combinators/short-circuit/smart/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/basis/combinators/short-circuit/tags.txt b/basis/combinators/short-circuit/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/basis/combinators/short-circuit/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor index 75f83c1a55..679b587759 100644 --- a/basis/combinators/smart/smart-docs.factor +++ b/basis/combinators/smart/smart-docs.factor @@ -108,17 +108,19 @@ HELP: append-outputs-as ARTICLE: "combinators.smart" "Smart combinators" -"The " { $vocab-link "combinators.smart" } " vocabulary implements " { $emphasis "smart combinators" } ". A smart combinator is one whose behavior depends on the static stack effect of an input quotation." $nl -"Smart inputs from a sequence:" +"The macros in the " { $vocab-link "combinators.smart" } " vocabulary look at the static stack effects of input quotations and generate code which produces or consumes the relevant number of stack values." $nl +"Call a quotation and discard all output values:" +{ $subsection drop-outputs } +"Take all input values from a sequence:" { $subsection inputsequence } { $subsection output>array } -"Reducing the output of a quotation:" +"Reducing the set of output values:" { $subsection reduce-outputs } -"Summing the output of a quotation:" +"Summing output values:" { $subsection sum-outputs } -"Appending the results of a quotation:" +"Concatenating output values:" { $subsection append-outputs } { $subsection append-outputs-as } ; diff --git a/basis/combinators/smart/tags.txt b/basis/combinators/smart/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/basis/combinators/smart/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index 2cc19f87dd..867f373209 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -117,7 +117,7 @@ $nl } { $references { "Since quotations are objects, they can be constructed and taken apart at will. You can write code that writes code. Arrays are just one of the various types of sequences, and the sequence operations such as " { $link each } " and " { $link map } " operate on all types of sequences. There are many more sequence iteration operations than the ones above, too." } - "dataflow" + "combinators" "sequences" } ; diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index ed2a14a2f2..b2a0e56c0a 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -5,7 +5,7 @@ math system strings sbufs vectors byte-arrays quotations io.streams.byte-array classes.builtin parser lexer classes.predicate classes.union classes.intersection classes.singleton classes.tuple help.vocabs math.parser -accessors ; +accessors definitions ; IN: help.handbook ARTICLE: "conventions" "Conventions" @@ -49,7 +49,7 @@ $nl { "associative mapping" { "an object whose class implements the " { $link "assocs-protocol" } } } { "boolean" { { $link t } " or " { $link f } } } { "class" { "a set of objects identified by a " { $emphasis "class word" } " together with a discriminating predicate. See " { $link "classes" } } } - { "definition specifier" { "a " { $link word } ", " { $link method-spec } ", " { $link link } ", vocabulary specifier, or any other object whose class implements the " { $link "definition-protocol" } } } + { "definition specifier" { "an instance of " { $link definition } " which implements the " { $link "definition-protocol" } } } { "generalized boolean" { "an object interpreted as a boolean; a value of " { $link f } " denotes false and anything else denotes true" } } { "generic word" { "a word whose behavior depends can be specialized on the class of one of its inputs. See " { $link "generic" } } } { "method" { "a specialized behavior of a generic word on a class. See " { $link "generic" } } } @@ -70,7 +70,7 @@ ARTICLE: "tail-call-opt" "Tail-call optimization" $nl "Tail-call optimization allows iterative algorithms to be implemented in an efficient manner using recursion, without the need for any kind of primitive looping construct in the language. However, in practice, most iteration is performed via combinators such as " { $link while } ", " { $link each } ", " { $link map } ", " { $link assoc-each } ", and so on. The definitions of these combinators do bottom-out in recursive words, however." ; -ARTICLE: "evaluator" "Evaluation semantics" +ARTICLE: "evaluator" "Stack machine model" { $link "quotations" } " are evaluated sequentially from beginning to end. When the end is reached, the quotation returns to its caller. As each object in the quotation is evaluated in turn, an action is taken based on its type:" { $list { "a " { $link word } " - the word's definition quotation is called. See " { $link "words" } } @@ -84,12 +84,13 @@ ARTICLE: "objects" "Objects" "An " { $emphasis "object" } " is any datum which may be identified. All values are objects in Factor. Each object carries type information, and types are checked at runtime; Factor is dynamically typed." { $subsection "equality" } { $subsection "math.order" } -{ $subsection "destructors" } { $subsection "classes" } { $subsection "tuples" } { $subsection "generic" } -{ $subsection "slots" } -{ $subsection "mirrors" } ; +"Advanced features:" +{ $subsection "delegate" } +{ $subsection "mirrors" } +{ $subsection "slots" } ; ARTICLE: "numbers" "Numbers" { $subsection "arithmetic" } @@ -118,9 +119,9 @@ ARTICLE: "collections" "Collections" "Fixed-length sequences:" { $subsection "arrays" } { $subsection "quotations" } -"Fixed-length specialized sequences:" { $subsection "strings" } { $subsection "byte-arrays" } +{ $subsection "specialized-arrays" } "Resizable sequences:" { $subsection "vectors" } { $subsection "byte-vectors" } @@ -128,7 +129,8 @@ ARTICLE: "collections" "Collections" { $subsection "growable" } { $heading "Associative mappings" } { $subsection "assocs" } -{ $subsection "namespaces" } +{ $subsection "linked-assocs" } +{ $subsection "biassocs" } { $subsection "refs" } "Implementations:" { $subsection "hashtables" } @@ -140,26 +142,29 @@ ARTICLE: "collections" "Collections" { $subsection "dlists" } { $subsection "search-deques" } { $heading "Other collections" } -{ $subsection "boxes" } +{ $subsection "lists" } +{ $subsection "disjoint-sets" } +{ $subsection "interval-maps" } { $subsection "heaps" } +{ $subsection "boxes" } { $subsection "graphs" } { $subsection "buffers" } "There are also many other vocabularies tagged " { $link T{ vocab-tag { name "collections" } } } " in the library." ; -USING: io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ; +USING: io.encodings.utf8 io.encodings.binary io.files ; ARTICLE: "encodings-introduction" "An introduction to encodings" "In order to express text in terms of binary, some sort of encoding has to be used. In a modern context, this is understood as a two-way mapping between Unicode code points (characters) and some amount of binary. Since English isn't the only language in the world, ASCII is not sufficient as a mapping from binary to Unicode; it can't even express em-dashes or curly quotes. Unicode was designed as a universal character set that could potentially represent everything." $nl "Not all encodings can represent all Unicode code points, but Unicode can represent basically everything that exists in modern encodings. Some encodings are language-specific, and some can represent everything in Unicode. Though the world is moving toward Unicode and UTF-8, the reality today is that there are several encodings which must be taken into account." $nl -"Factor uses a system of encoding descriptors to denote encodings. Encoding descriptors are objects which describe encodings. Examples are " { $link utf8 } ", " { $link ascii } " and " { $link binary } ". Encoding descriptors can be passed around independently. Each encoding descriptor has some method for constructing an encoded or decoded stream, and the resulting stream has an encoding descriptor stored which has methods for reading or writing characters." $nl +"Factor uses a system of encoding descriptors to denote encodings. Encoding descriptors are objects which describe encodings. Examples are " { $link utf8 } " and " { $link binary } ". Encoding descriptors can be passed around independently. Each encoding descriptor has some method for constructing an encoded or decoded stream, and the resulting stream has an encoding descriptor stored which has methods for reading or writing characters." $nl "Constructors for streams which deal with bytes usually take an encoding as an explicit parameter. For example, to open a text file for reading whose contents are in UTF-8, use the following" { $code "\"file.txt\" utf8 " } "If there is an error in the encoded stream, a replacement character (0xFFFD) will be inserted. To throw an exception upon error, use a strict encoding as follows" { $code "\"file.txt\" utf8 strict " } "In a similar way, encodings can be specified when opening a file for writing." -{ $code "\"file.txt\" ascii " } +{ $code "USE: io.encodings.ascii" "\"file.txt\" ascii " } "An encoding is also needed for some words that don't return streams, such as " { $link file-contents } ", for example" -{ $code "\"file.txt\" utf16 file-contents" } +{ $code "USE: io.encodings.utf16" "\"file.txt\" utf16 file-contents" } "Encoding descriptors are also used by " { $link "io.streams.byte-array" } " and taken by combinators like " { $link with-file-writer } " and " { $link with-byte-reader } " which deal with streams. It is " { $emphasis "not" } " used with " { $link "io.streams.string" } " because these deal with abstract text." $nl "When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text." ; @@ -239,40 +244,57 @@ ARTICLE: "class-index" "Class index" { $heading "Predicate classes" } { $index [ classes [ predicate-class? ] filter ] } ; -ARTICLE: "program-org" "Program organization" -{ $subsection "definitions" } -{ $subsection "vocabularies" } -{ $subsection "parser" } -{ $subsection "vocabs.loader" } -{ $subsection "source-files" } ; - USING: help.cookbook help.tutorial ; ARTICLE: "handbook-language-reference" "Language reference" +"Fundamentals:" { $subsection "conventions" } { $subsection "syntax" } -{ $subsection "dataflow" } -{ $subsection "objects" } -{ $subsection "program-org" } +{ $subsection "effects" } +"Data types:" +{ $subsection "booleans" } { $subsection "numbers" } { $subsection "collections" } -{ $subsection "io" } +"Evaluation semantics:" +{ $subsection "evaluator" } +{ $subsection "words" } +{ $subsection "shuffle-words" } +{ $subsection "combinators" } +{ $subsection "errors" } +{ $subsection "continuations" } +"Named values:" +{ $subsection "locals" } +{ $subsection "namespaces" } +{ $subsection "namespaces-global" } +{ $subsection "values" } +"Abstractions:" +{ $subsection "objects" } +{ $subsection "destructors" } +{ $subsection "macros" } +{ $subsection "fry" } +"Program organization:" +{ $subsection "vocabs.loader" } "Vocabularies tagged " { $link T{ vocab-tag { name "extensions" } } } " implement various additional language abstractions." ; ARTICLE: "handbook-environment-reference" "Environment reference" +"Parse time and compile time:" +{ $subsection "parser" } +{ $subsection "definitions" } +{ $subsection "vocabularies" } +{ $subsection "source-files" } +{ $subsection "compiler" } +"Tools:" { $subsection "prettyprint" } { $subsection "tools" } -{ $subsection "cli" } -{ $subsection "rc-files" } { $subsection "help" } { $subsection "inference" } -{ $subsection "compiler" } -{ $subsection "system" } { $subsection "images" } -{ $subsection "alien" } +"VM:" +{ $subsection "cli" } +{ $subsection "rc-files" } { $subsection "init" } -{ $subsection "layouts" } -{ $see-also "program-org" } ; +{ $subsection "system" } +{ $subsection "layouts" } ; ARTICLE: "handbook-library-reference" "Library reference" "This index only includes articles from loaded vocabularies. To explore more vocabularies, see " { $link "vocab-index" } "." @@ -282,9 +304,14 @@ ARTICLE: "handbook" "Factor handbook" "Learn the language:" { $subsection "cookbook" } { $subsection "first-program" } +"Reference material:" { $subsection "handbook-language-reference" } { $subsection "handbook-environment-reference" } +{ $subsection "io" } { $subsection "ui" } +{ $subsection "ui-tools" } +{ $subsection "unicode" } +{ $subsection "alien" } { $subsection "handbook-library-reference" } "Explore loaded libraries:" { $subsection "article-index" } diff --git a/basis/help/home/home-docs.factor b/basis/help/home/home-docs.factor index 6608a6e9c0..e6db2d3b9c 100644 --- a/basis/help/home/home-docs.factor +++ b/basis/help/home/home-docs.factor @@ -8,7 +8,6 @@ ARTICLE: "help.home" "Factor documentation" { $link "handbook" } { $link "vocab-index" } { $link "ui-tools" } - { $link "handbook-library-reference" } } { $heading "Recently visited" } { $table diff --git a/basis/help/syntax/tags.txt b/basis/help/syntax/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/basis/help/syntax/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/basis/interpolate/tags.txt b/basis/interpolate/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/basis/interpolate/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index 18dabed4b0..b1f0b6ca17 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -112,7 +112,15 @@ HELP: MEMO:: { $description "Defines a memoized word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." } ; { POSTPONE: MEMO: POSTPONE: MEMO:: } related-words + +HELP: M:: +{ $syntax "M:: class generic ( bindings... -- outputs... ) body... ;" } +{ $description "Defines a method with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." } +{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } ; +{ POSTPONE: M: POSTPONE: M:: } related-words + + ARTICLE: "locals-literals" "Locals in literals" "Certain data type literals are permitted to contain free variables. Any such literals are written into code which constructs an instance of the type with the free variable values spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables." $nl @@ -237,13 +245,14 @@ $nl } "The reason is that locals are rewritten into stack code at parse time, whereas macro expansion is performed later during compile time. To circumvent this problem, the " { $vocab-link "macros.expander" } " vocabulary is used to rewrite simple macro usages prior to local transformation, however "{ $vocab-link "macros.expander" } " does not deal with more complicated cases where the literal inputs to the macro do not immediately precede the macro call in the source." ; -ARTICLE: "locals" "Local variables and lexical closures" +ARTICLE: "locals" "Lexical variables and closures" "The " { $vocab-link "locals" } " vocabulary implements lexical scope with full closures, both downward and upward. Mutable bindings are supported, including assignment to bindings in outer scope." $nl "Compile-time transformation is used to compile local variables to efficient code; prettyprinter extensions are defined so that " { $link see } " can display original word definitions with local variables and not the closure-converted concatenative code which results." $nl "Applicative word definitions where the inputs are named local variables:" { $subsection POSTPONE: :: } +{ $subsection POSTPONE: M:: } { $subsection POSTPONE: MEMO:: } { $subsection POSTPONE: MACRO:: } "Lexical binding forms:" diff --git a/basis/math/ranges/ranges-docs.factor b/basis/math/ranges/ranges-docs.factor index 8987def80b..e35adb10e5 100644 --- a/basis/math/ranges/ranges-docs.factor +++ b/basis/math/ranges/ranges-docs.factor @@ -2,7 +2,7 @@ USING: help.syntax help.markup arrays sequences ; IN: math.ranges -ARTICLE: "ranges" "Ranges" +ARTICLE: "math.ranges" "Numeric ranges" "A " { $emphasis "range" } " is a virtual sequence with real number elements " "ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } ". Ascending as well as descending ranges are supported." $nl @@ -24,4 +24,4 @@ $nl { $code "100 1 [a,b] product" } "A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ; -ABOUT: "ranges" \ No newline at end of file +ABOUT: "math.ranges" \ No newline at end of file diff --git a/basis/peg/ebnf/tags.txt b/basis/peg/ebnf/tags.txt index 5af5dba748..1ccdafb2bb 100644 --- a/basis/peg/ebnf/tags.txt +++ b/basis/peg/ebnf/tags.txt @@ -1,2 +1,3 @@ +extensions text parsing diff --git a/basis/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor index 93f45591a5..52cd77d726 100644 --- a/basis/ui/tools/tools-docs.factor +++ b/basis/ui/tools/tools-docs.factor @@ -55,7 +55,7 @@ $nl ARTICLE: "ui-tools" "UI developer tools" "The " { $vocab-link "ui.tools" } " vocabulary hierarchy implements a collection of simple developer tools." -$nl +{ $subsection "starting-ui-tools" } "To take full advantage of the UI tools, you should be using a supported text editor. See " { $link "editor" } "." $nl "Common functionality:" @@ -66,7 +66,7 @@ $nl { $subsection "ui-listener" } { $subsection "ui-browser" } { $subsection "ui-inspector" } -{ $subsection "ui-profiler" } +{ $subsection "ui.tools.profiler" } { $subsection "ui-walker" } { $subsection "ui.tools.deploy" } "Platform-specific features:" diff --git a/basis/unicode/unicode-docs.factor b/basis/unicode/unicode-docs.factor index 9450b49f0b..56432585c0 100644 --- a/basis/unicode/unicode-docs.factor +++ b/basis/unicode/unicode-docs.factor @@ -1,7 +1,7 @@ USING: help.markup help.syntax strings ; IN: unicode -ARTICLE: "unicode" "Unicode" +ARTICLE: "unicode" "Unicode support" "The " { $vocab-link "unicode" } " vocabulary and its sub-vocabularies implement support for the Unicode 5.1 character set." $nl "The Unicode character set contains most of the world's writing systems. Unicode is intended as a replacement for, and is a superset of, such legacy character sets as ASCII, Latin1, MacRoman, and so on. Unicode characters are called " { $emphasis "code points" } "; Factor's " { $link "strings" } " are sequences of code points." diff --git a/basis/values/values-docs.factor b/basis/values/values-docs.factor index df38869fbf..7c96f19ac9 100644 --- a/basis/values/values-docs.factor +++ b/basis/values/values-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax ; IN: values ARTICLE: "values" "Global values" -"Usually, dynamically scoped variables are sufficient for holding data which is not literal. But occasionally, for global information that's calculated just once, it's useful to use the word mechanism instead, and set the word to the appropriate value just once. The " { $vocab-link "values" } " vocabulary implements " { $emphasis "values" } ", which abstract over this concept. To create a new word as a value, use the following syntax:" +"Usually, dynamically-scoped variables subsume global variables and are sufficient for holding global data. But occasionally, for global information that's calculated just once and must be accessed more rapidly than a dynamic variable lookup can provide, it's useful to use the word mechanism instead, and set a word to the appropriate value just once. The " { $vocab-link "values" } " vocabulary implements " { $emphasis "values" } ", which abstract over this concept. To create a new word as a value, use the following syntax:" { $subsection POSTPONE: VALUE: } "To get the value, just call the word. The following words manipulate values:" { $subsection get-value } diff --git a/basis/xml/syntax/tags.txt b/basis/xml/syntax/tags.txt index 71c0ff7282..4f4a20b1cb 100644 --- a/basis/xml/syntax/tags.txt +++ b/basis/xml/syntax/tags.txt @@ -1 +1,2 @@ +extensions syntax diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index cc502140ad..9c96fe34c9 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -4,46 +4,313 @@ math assocs sequences sequences.private combinators.private effects words ; IN: combinators +ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators" +"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "." +$nl +"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:" +{ $code + ": keep [ ] bi ;" + ": 2keep [ ] 2bi ;" + ": 3keep [ ] 3bi ;" + "" + ": dup [ ] [ ] bi ;" + ": 2dup [ ] [ ] 2bi ;" + ": 3dup [ ] [ ] 3bi ;" + "" + ": tuck [ nip ] [ ] 2bi ;" + ": swap [ nip ] [ drop ] 2bi ;" + "" + ": over [ ] [ drop ] 2bi ;" + ": pick [ ] [ 2drop ] 3bi ;" + ": 2over [ ] [ drop ] 3bi ;" +} ; + +ARTICLE: "cleave-combinators" "Cleave combinators" +"The cleave combinators apply multiple quotations to a single value." +$nl +"Two quotations:" +{ $subsection bi } +{ $subsection 2bi } +{ $subsection 3bi } +"Three quotations:" +{ $subsection tri } +{ $subsection 2tri } +{ $subsection 3tri } +"An array of quotations:" +{ $subsection cleave } +{ $subsection 2cleave } +{ $subsection 3cleave } +"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:" +{ $code + "! First alternative; uses keep" + "[ 1 + ] keep" + "[ 1 - ] keep" + "2 *" + "! Second alternative: uses tri" + "[ 1 + ]" + "[ 1 - ]" + "[ 2 * ] tri" +} +"The latter is more aesthetically pleasing than the former." +{ $subsection "cleave-shuffle-equivalence" } ; + +ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators" +"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", " { $link tri* } ", and " { $link 2tri* } "." +$nl +"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:" +{ $code + ": dip [ ] bi* ;" + ": 2dip [ ] [ ] tri* ;" + "" + ": slip [ call ] [ ] bi* ;" + ": 2slip [ call ] [ ] [ ] tri* ;" + "" + ": nip [ drop ] [ ] bi* ;" + ": 2nip [ drop ] [ drop ] [ ] tri* ;" + "" + ": rot" + " [ [ drop ] [ ] [ drop ] tri* ]" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " 3tri ;" + "" + ": -rot" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " [ [ drop ] [ ] [ drop ] tri* ]" + " 3tri ;" + "" + ": spin" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ drop ] [ ] [ drop ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " 3tri ;" +} ; + +ARTICLE: "spread-combinators" "Spread combinators" +"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading." +$nl +"Two quotations:" +{ $subsection bi* } +{ $subsection 2bi* } +"Three quotations:" +{ $subsection tri* } +{ $subsection 2tri* } +"An array of quotations:" +{ $subsection spread } +"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:" +{ $code + "! First alternative; uses dip" + "[ [ 1 + ] dip 1 - ] dip 2 *" + "! Second alternative: uses tri*" + "[ 1 + ] [ 1 - ] [ 2 * ] tri*" +} +"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." +{ $subsection "spread-shuffle-equivalence" } ; + +ARTICLE: "apply-combinators" "Apply combinators" +"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application." +$nl +"Two quotations:" +{ $subsection bi@ } +{ $subsection 2bi@ } +"Three quotations:" +{ $subsection tri@ } +{ $subsection 2tri@ } +"A pair of utility words built from " { $link bi@ } ":" +{ $subsection both? } +{ $subsection either? } ; + +ARTICLE: "slip-keep-combinators" "Retain stack combinators" +"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators." +$nl +"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:" +{ $subsection dip } +{ $subsection 2dip } +{ $subsection 3dip } +{ $subsection 4dip } +"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:" +{ $subsection slip } +{ $subsection 2slip } +{ $subsection 3slip } +"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:" +{ $subsection keep } +{ $subsection 2keep } +{ $subsection 3keep } ; + +ARTICLE: "curried-dataflow" "Curried dataflow combinators" +"Curried cleave combinators:" +{ $subsection bi-curry } +{ $subsection tri-curry } +"Curried spread combinators:" +{ $subsection bi-curry* } +{ $subsection tri-curry* } +"Curried apply combinators:" +{ $subsection bi-curry@ } +{ $subsection tri-curry@ } +{ $see-also "dataflow-combinators" } ; + +ARTICLE: "compositional-examples" "Examples of compositional combinator usage" +"Consider printing the same message ten times:" +{ $code ": print-10 ( -- ) 10 [ \"Hello, world.\" print ] times ;" } +"if we wanted to abstract out the message into a parameter, we could keep it on the stack between iterations:" +{ $code ": print-10 ( message -- ) 10 [ dup print ] times drop ;" } +"However, keeping loop-invariant values on the stack doesn't always work out nicely. For example, a word to subtract a value from each element of a sequence:" +{ $code ": subtract-n ( seq n -- seq' ) swap [ over - ] map nip ;" } +"Three shuffle words are required to pass the value around. Instead, the loop-invariant value can be partially applied to a quotation using " { $link curry } ", yielding a new quotation that is passed to " { $link map } ":" +{ $example + "USING: kernel math prettyprint sequences ;" + ": subtract-n ( seq n -- seq' ) [ - ] curry map ;" + "{ 10 20 30 } 5 subtract-n ." + "{ 5 15 25 }" +} +"Now consider the word that is dual to the one above; instead of subtracting " { $snippet "n" } " from each stack element, it subtracts each element from " { $snippet "n" } "." +$nl +"One way to write this is with a pair of " { $link swap } "s:" +{ $code ": n-subtract ( n seq -- seq' ) swap [ swap - ] curry map ;" } +"Since this pattern comes up often, " { $link with } " encapsulates it:" +{ $example + "USING: kernel math prettyprint sequences ;" + ": n-subtract ( n seq -- seq' ) [ - ] with map ;" + "30 { 10 20 30 } n-subtract ." + "{ 20 10 0 }" +} +{ $see-also "fry.examples" } ; + +ARTICLE: "compositional-combinators" "Compositional combinators" +"Certain combinators transform quotations to produce a new quotation." +{ $subsection "compositional-examples" } +"Fundamental operations:" +{ $subsection curry } +{ $subsection compose } +"Derived operations:" +{ $subsection 2curry } +{ $subsection 3curry } +{ $subsection with } +{ $subsection prepose } +"These operations run in constant time, and in many cases are optimized out altogether by the " { $link "compiler" } ". " { $link "fry" } " are an abstraction built on top of these operations, and code that uses this abstraction is often clearer than direct calls to the below words." +$nl +"Curried dataflow combinators can be used to build more complex dataflow by combining cleave, spread and apply patterns in various ways." +{ $subsection "curried-dataflow" } +"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } ". However, such runtime quotation manipulation will not be optimized by the optimizing compiler." ; + +ARTICLE: "booleans" "Booleans" +"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value." +{ $subsection f } +{ $subsection t } +"There are some logical operations on booleans:" +{ $subsection >boolean } +{ $subsection not } +{ $subsection and } +{ $subsection or } +{ $subsection xor } +"Boolean values are most frequently used for " { $link "conditionals" } "." +{ $heading "The f object and f class" } +"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing." +$nl +"Here is the " { $link f } " object:" +{ $example "f ." "f" } +"Here is the " { $link f } " class:" +{ $example "\\ f ." "POSTPONE: f" } +"They are not equal:" +{ $example "f \\ f = ." "f" } +"Here is an array containing the " { $link f } " object:" +{ $example "{ f } ." "{ f }" } +"Here is an array containing the " { $link f } " class:" +{ $example "{ POSTPONE: f } ." "{ POSTPONE: f }" } +"The " { $link f } " object is an instance of the " { $link f } " class:" +{ $example "USE: classes" "f class ." "POSTPONE: f" } +"The " { $link f } " class is an instance of " { $link word } ":" +{ $example "USE: classes" "\\ f class ." "word" } +"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of." +{ $example "t \\ t eq? ." "t" } +"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ; + +ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic" +"Certain simple conditional forms can be expressed in a simpler manner using boolean logic." +$nl +"The following two lines are equivalent:" +{ $code "[ drop f ] unless" "swap and" } +"The following two lines are equivalent:" +{ $code "[ ] [ ] ?if" "swap or" } +"The following two lines are equivalent, where " { $snippet "L" } " is a literal:" +{ $code "[ L ] unless*" "L or" } ; + +ARTICLE: "conditionals" "Conditional combinators" +"The basic conditionals:" +{ $subsection if } +{ $subsection when } +{ $subsection unless } +"Forms abstracting a common stack shuffle pattern:" +{ $subsection if* } +{ $subsection when* } +{ $subsection unless* } +"Another form abstracting a common stack shuffle pattern:" +{ $subsection ?if } +"Sometimes instead of branching, you just need to pick one of two values:" +{ $subsection ? } +"Two combinators which abstract out nested chains of " { $link if } ":" +{ $subsection cond } +{ $subsection case } +{ $subsection "conditionals-boolean-equivalence" } +{ $see-also "booleans" "bitwise-arithmetic" both? either? } ; + +ARTICLE: "dataflow-combinators" "Data flow combinators" +"Data flow combinators pass values between quotations:" +{ $subsection "slip-keep-combinators" } +{ $subsection "cleave-combinators" } +{ $subsection "spread-combinators" } +{ $subsection "apply-combinators" } +{ $see-also "curried-dataflow" } ; + ARTICLE: "combinators-quot" "Quotation construction utilities" "Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:" { $subsection cond>quot } { $subsection case>quot } { $subsection alist>quot } ; -ARTICLE: "call" "Calling code with known stack effects" -"Arbitrary quotations and words can be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate." +ARTICLE: "call" "Fundamental combinators" +"The most basic combinators are those that take either a quotation or word, and invoke it immediately. There are two sets of combinators; they differe in whether or not the stack effect of the expected code is declared." $nl -"Quotations:" -{ $subsection POSTPONE: call( } +"The simplest combinators do not take an effect declaration:" +{ $subsection call } +{ $subsection execute } +"These combinators only get optimized by the compiler if the quotation or word parameter is a literal; otherwise a compiler warning will result. Definitions of combinators which require literal parameters must be followed by the " { $link POSTPONE: inline } " declaration. For example:" +{ $code + ": keep ( x quot -- x )" + " over [ call ] dip ; inline" +} +"See " { $link "declarations" } " and " { $link "compiler-errors" } " for details." +$nl +"The other set of combinators allow arbitrary quotations and words to be called from optimized code. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate." { $subsection call-effect } -"Words:" -{ $subsection POSTPONE: execute( } { $subsection execute-effect } -"Unsafe calls:" +"A simple layer of syntax sugar is defined on top:" +{ $subsection POSTPONE: call( } +{ $subsection POSTPONE: execute( } +"Unsafe calls declare an effect statically without any runtime checking:" { $subsection call-effect-unsafe } -{ $subsection execute-effect-unsafe } ; +{ $subsection execute-effect-unsafe } +{ $see-also "effects" "inference" } ; -ARTICLE: "combinators" "Additional combinators" -"The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators." +ARTICLE: "combinators" "Combinators" +"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input." +{ $subsection "call" } +{ $subsection "dataflow-combinators" } +{ $subsection "conditionals" } +{ $subsection "looping-combinators" } +{ $subsection "compositional-combinators" } +{ $subsection "combinators.short-circuit" } +{ $subsection "combinators.smart" } +"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "." $nl -"Generalization of " { $link bi } " and " { $link tri } ":" -{ $subsection cleave } -"Generalization of " { $link 2bi } " and " { $link 2tri } ":" -{ $subsection 2cleave } -"Generalization of " { $link 3bi } " and " { $link 3tri } ":" -{ $subsection 3cleave } -"Generalization of " { $link bi* } " and " { $link tri* } ":" -{ $subsection spread } -"Two combinators which abstract out nested chains of " { $link if } ":" -{ $subsection cond } -{ $subsection case } -"The " { $vocab-link "combinators" } " also provides some less frequently-used features." +"The " { $vocab-link "combinators" } " provides some less frequently-used features." $nl "A combinator which can help with implementing methods on " { $link hashcode* } ":" { $subsection recursive-hashcode } -{ $subsection "call" } { $subsection "combinators-quot" } -{ $see-also "quotations" "dataflow" } ; +"Advanced topics:" +{ $see-also "quotations" } ; ABOUT: "combinators" diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index b53ab28cbc..9d49cf62c6 100644 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -56,11 +56,24 @@ $nl { $subsection redefine-error } ; ARTICLE: "definitions" "Definitions" -"A " { $emphasis "definition" } " is an artifact read from a source file. This includes words, methods, help articles, and path names (which represent the source file at that location). Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary." +"A " { $emphasis "definition" } " is an artifact read from a source file. Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary." +$nl +"Definitions are defined using parsing words. Examples of definitions together with their defining parsing words are words (" { $link POSTPONE: : } "), methods (" { $link POSTPONE: M: } "), and vocabularies (" { $link POSTPONE: IN: } ")." +$nl +"All definitions share some common traits:" +{ $list + "There is a word to list all definitions of a given type" + "There is a parsing word for creating new definitions" + "There is an ordinary word which is the runtime equivalent of the parsing word, for introspection" + "Instances of the definition may be introspected and modified with the definition protocol" +} +"For every source file loaded into the system, a list of definitions is maintained. Pathname objects implement the definition protocol, acting over the definitions their source files contain. See " { $link "source-files" } " for details." { $subsection "definition-protocol" } { $subsection "definition-crossref" } { $subsection "definition-checking" } { $subsection "compilation-units" } +"A parsing word to remove definitions:" +{ $subsection POSTPONE: FORGET: } { $see-also "see" "parser" "source-files" "words" "generic" "help-impl" } ; ABOUT: "definitions" diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor index b209dcf259..20709ca807 100644 --- a/core/effects/effects-docs.factor +++ b/core/effects/effects-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax math strings words kernel ; +USING: help.markup help.syntax math strings words kernel combinators ; IN: effects ARTICLE: "effect-declaration" "Stack effect declaration" @@ -29,14 +29,11 @@ $nl "The stack effect inferencer verifies stack effect comments to ensure the correct number of inputs and outputs is listed. Value names are ignored; only their number matters. An error is thrown if a word's declared stack effect does not match its inferred stack effect. See " { $link "inference" } "." ; ARTICLE: "effects" "Stack effects" -"A " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that an operation takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output." +"A " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that an operation takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effects are first-class, and words for working with them are found in the " { $vocab-link "effects" } " vocabulary." $nl -"Stack effects of words can be declared." +"Stack effects of words must be declared, and the " { $link "compiler" } " checks that these declarations are correct. Invalid declarations are reported as " { $link "compiler-errors" } ". The " { $link "inference" } " tool can be used to check stack effects interactively." { $subsection "effect-declaration" } -"Stack effects are first-class, and words for working with them are found in the " { $vocab-link "effects" } " vocabulary." -{ $subsection effect } -{ $subsection effect? } -"There is a literal syntax for stack objects. It is most often used with " { $link define-declared } "." +"There is a literal syntax for stack objects. It is most often used with " { $link define-declared } ", " { $link call-effect } " and " { $link execute-effect } "." { $subsection POSTPONE: (( } "Getting a word's declared stack effect:" { $subsection stack-effect } @@ -45,7 +42,9 @@ $nl "Comparing effects:" { $subsection effect-height } { $subsection effect<= } -{ $see-also "inference" } ; +"The class of stack effects:" +{ $subsection effect } +{ $subsection effect? } ; ABOUT: "effects" diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 06a8fa87a3..7017ef8a08 100644 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -45,8 +45,8 @@ $nl { $subsection make-generic } "Low-level method constructor:" { $subsection } -"A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":" -{ $subsection method-spec } +"Methods may be pushed on the stack with a literal syntax:" +{ $subsection POSTPONE: M\ } { $see-also "see" } ; ARTICLE: "method-combination" "Custom method combination" @@ -98,8 +98,8 @@ $nl "Generic words must declare their stack effect in order to compile. See " { $link "effect-declaration" } "." { $subsection "method-order" } { $subsection "call-next-method" } -{ $subsection "generic-introspection" } { $subsection "method-combination" } +{ $subsection "generic-introspection" } "Generic words specialize behavior based on the class of an object; sometimes behavior needs to be specialized on the object's " { $emphasis "structure" } "; this is known as " { $emphasis "pattern matching" } " and is implemented in the " { $vocab-link "match" } " vocabulary." ; ABOUT: "generic" @@ -119,9 +119,10 @@ HELP: define-generic { $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." } { $contract "The method combination quotation is called each time the generic word has to be updated (for example, when a method is added), and thus must be side-effect free." } ; -HELP: method-spec -{ $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." } -{ $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ; +HELP: M\ +{ $syntax "M\\ class generic" } +{ $class-description "Pushes a method on the stack." } +{ $examples { $code "M\\ fixnum + see" } { $code "USING: ui.gadgets ui.gadgets.editors ;" "M\\ editor draw-gadget* edit" } } ; HELP: method-body { $class-description "The class of method bodies, which are words with special word properties set." } ; diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index aadc44833f..151c2f52fa 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -105,9 +105,6 @@ M: shit big-generic-test "shit" ; [ float ] [ \ real \ float math-class-max ] unit-test [ fixnum ] [ \ fixnum \ null math-class-max ] unit-test -[ t ] [ { hashtable equal? } method-spec? ] unit-test -[ f ] [ { word = } method-spec? ] unit-test - ! Regression TUPLE: first-one ; TUPLE: second-one ; diff --git a/core/generic/math/math-docs.factor b/core/generic/math/math-docs.factor index 4323f91bc3..60fa745339 100644 --- a/core/generic/math/math-docs.factor +++ b/core/generic/math/math-docs.factor @@ -15,7 +15,7 @@ HELP: no-math-method HELP: math-method { $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } } { $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." } -{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ { fixnum float } declare [ >float ] dip float=>+ ]" } } ; +{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ { fixnum float } declare [ >float ] dip M\\ float + ]" } } ; HELP: math-class { $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index c178573a0a..36d04f1437 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -841,260 +841,6 @@ $nl { $subsection roll } { $subsection -roll } ; -ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators" -"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "." -$nl -"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:" -{ $code - ": keep [ ] bi ;" - ": 2keep [ ] 2bi ;" - ": 3keep [ ] 3bi ;" - "" - ": dup [ ] [ ] bi ;" - ": 2dup [ ] [ ] 2bi ;" - ": 3dup [ ] [ ] 3bi ;" - "" - ": tuck [ nip ] [ ] 2bi ;" - ": swap [ nip ] [ drop ] 2bi ;" - "" - ": over [ ] [ drop ] 2bi ;" - ": pick [ ] [ 2drop ] 3bi ;" - ": 2over [ ] [ drop ] 3bi ;" -} ; - -ARTICLE: "cleave-combinators" "Cleave combinators" -"The cleave combinators apply multiple quotations to a single value." -$nl -"Two quotations:" -{ $subsection bi } -{ $subsection 2bi } -{ $subsection 3bi } -"Three quotations:" -{ $subsection tri } -{ $subsection 2tri } -{ $subsection 3tri } -"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:" -{ $code - "! First alternative; uses keep" - "[ 1 + ] keep" - "[ 1 - ] keep" - "2 *" - "! Second alternative: uses tri" - "[ 1 + ]" - "[ 1 - ]" - "[ 2 * ] tri" -} -"The latter is more aesthetically pleasing than the former." -$nl -"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." -{ $subsection "cleave-shuffle-equivalence" } ; - -ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators" -"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", " { $link tri* } ", and " { $link 2tri* } "." -$nl -"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:" -{ $code - ": dip [ ] bi* ;" - ": 2dip [ ] [ ] tri* ;" - "" - ": slip [ call ] [ ] bi* ;" - ": 2slip [ call ] [ ] [ ] tri* ;" - "" - ": nip [ drop ] [ ] bi* ;" - ": 2nip [ drop ] [ drop ] [ ] tri* ;" - "" - ": rot" - " [ [ drop ] [ ] [ drop ] tri* ]" - " [ [ drop ] [ drop ] [ ] tri* ]" - " [ [ ] [ drop ] [ drop ] tri* ]" - " 3tri ;" - "" - ": -rot" - " [ [ drop ] [ drop ] [ ] tri* ]" - " [ [ ] [ drop ] [ drop ] tri* ]" - " [ [ drop ] [ ] [ drop ] tri* ]" - " 3tri ;" - "" - ": spin" - " [ [ drop ] [ drop ] [ ] tri* ]" - " [ [ drop ] [ ] [ drop ] tri* ]" - " [ [ ] [ drop ] [ drop ] tri* ]" - " 3tri ;" -} ; - -ARTICLE: "spread-combinators" "Spread combinators" -"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading." -$nl -"Two quotations:" -{ $subsection bi* } -{ $subsection 2bi* } -"Three quotations:" -{ $subsection tri* } -{ $subsection 2tri* } -"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:" -{ $code - "! First alternative; uses dip" - "[ [ 1 + ] dip 1 - ] dip 2 *" - "! Second alternative: uses tri*" - "[ 1 + ] [ 1 - ] [ 2 * ] tri*" -} -"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." -{ $subsection "spread-shuffle-equivalence" } ; - -ARTICLE: "apply-combinators" "Apply combinators" -"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application." -$nl -"Two quotations:" -{ $subsection bi@ } -{ $subsection 2bi@ } -"Three quotations:" -{ $subsection tri@ } -{ $subsection 2tri@ } -"A pair of utility words built from " { $link bi@ } ":" -{ $subsection both? } -{ $subsection either? } ; - -ARTICLE: "slip-keep-combinators" "Retain stack combinators" -"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators." -$nl -"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:" -{ $subsection dip } -{ $subsection 2dip } -{ $subsection 3dip } -{ $subsection 4dip } -"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:" -{ $subsection slip } -{ $subsection 2slip } -{ $subsection 3slip } -"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:" -{ $subsection keep } -{ $subsection 2keep } -{ $subsection 3keep } ; - -ARTICLE: "curried-dataflow" "Curried dataflow combinators" -"Curried cleave combinators:" -{ $subsection bi-curry } -{ $subsection tri-curry } -"Curried spread combinators:" -{ $subsection bi-curry* } -{ $subsection tri-curry* } -"Curried apply combinators:" -{ $subsection bi-curry@ } -{ $subsection tri-curry@ } -{ $see-also "dataflow-combinators" } ; - -ARTICLE: "compositional-examples" "Examples of compositional combinator usage" -"Consider printing the same message ten times:" -{ $code ": print-10 ( -- ) 10 [ \"Hello, world.\" print ] times ;" } -"if we wanted to abstract out the message into a parameter, we could keep it on the stack between iterations:" -{ $code ": print-10 ( message -- ) 10 [ dup print ] times drop ;" } -"However, keeping loop-invariant values on the stack doesn't always work out nicely. For example, a word to subtract a value from each element of a sequence:" -{ $code ": subtract-n ( seq n -- seq' ) swap [ over - ] map nip ;" } -"Three shuffle words are required to pass the value around. Instead, the loop-invariant value can be partially applied to a quotation using " { $link curry } ", yielding a new quotation that is passed to " { $link map } ":" -{ $example - "USING: kernel math prettyprint sequences ;" - ": subtract-n ( seq n -- seq' ) [ - ] curry map ;" - "{ 10 20 30 } 5 subtract-n ." - "{ 5 15 25 }" -} -"Now consider the word that is dual to the one above; instead of subtracting " { $snippet "n" } " from each stack element, it subtracts each element from " { $snippet "n" } "." -$nl -"One way to write this is with a pair of " { $link swap } "s:" -{ $code ": n-subtract ( n seq -- seq' ) swap [ swap - ] curry map ;" } -"Since this pattern comes up often, " { $link with } " encapsulates it:" -{ $example - "USING: kernel math prettyprint sequences ;" - ": n-subtract ( n seq -- seq' ) [ - ] with map ;" - "30 { 10 20 30 } n-subtract ." - "{ 20 10 0 }" -} -{ $see-also "fry.examples" } ; - -ARTICLE: "compositional-combinators" "Compositional combinators" -"Certain combinators transform quotations to produce a new quotation." -{ $subsection "compositional-examples" } -"Fundamental operations:" -{ $subsection curry } -{ $subsection compose } -"Derived operations:" -{ $subsection 2curry } -{ $subsection 3curry } -{ $subsection with } -{ $subsection prepose } -"These operations run in constant time, and in many cases are optimized out altogether by the " { $link "compiler" } ". " { $link "fry" } " are an abstraction built on top of these operations, and code that uses this abstraction is often clearer than direct calls to the below words." -$nl -"Curried dataflow combinators can be used to build more complex dataflow by combining cleave, spread and apply patterns in various ways." -{ $subsection "curried-dataflow" } -"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } ". However, such runtime quotation manipulation will not be optimized by the optimizing compiler." ; - -ARTICLE: "implementing-combinators" "Implementing combinators" -"The following pair of words invoke words and quotations reflectively:" -{ $subsection call } -{ $subsection execute } -"These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:" -{ $code - ": keep ( x quot -- x )" - " over [ call ] dip ; inline" -} -"Word inlining is documented in " { $link "declarations" } "." ; - -ARTICLE: "booleans" "Booleans" -"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value." -{ $subsection f } -{ $subsection t } -"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing." -$nl -"Here is the " { $link f } " object:" -{ $example "f ." "f" } -"Here is the " { $link f } " class:" -{ $example "\\ f ." "POSTPONE: f" } -"They are not equal:" -{ $example "f \\ f = ." "f" } -"Here is an array containing the " { $link f } " object:" -{ $example "{ f } ." "{ f }" } -"Here is an array containing the " { $link f } " class:" -{ $example "{ POSTPONE: f } ." "{ POSTPONE: f }" } -"The " { $link f } " object is an instance of the " { $link f } " class:" -{ $example "USE: classes" "f class ." "POSTPONE: f" } -"The " { $link f } " class is an instance of " { $link word } ":" -{ $example "USE: classes" "\\ f class ." "word" } -"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of." -{ $example "t \\ t eq? ." "t" } -"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ; - -ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic" -"Certain simple conditional forms can be expressed in a simpler manner using boolean logic." -$nl -"The following two lines are equivalent:" -{ $code "[ drop f ] unless" "swap and" } -"The following two lines are equivalent:" -{ $code "[ ] [ ] ?if" "swap or" } -"The following two lines are equivalent, where " { $snippet "L" } " is a literal:" -{ $code "[ L ] unless*" "L or" } ; - -ARTICLE: "conditionals" "Conditionals and logic" -"The basic conditionals:" -{ $subsection if } -{ $subsection when } -{ $subsection unless } -"Forms abstracting a common stack shuffle pattern:" -{ $subsection if* } -{ $subsection when* } -{ $subsection unless* } -"Another form abstracting a common stack shuffle pattern:" -{ $subsection ?if } -"Sometimes instead of branching, you just need to pick one of two values:" -{ $subsection ? } -"There are some logical operations on booleans:" -{ $subsection >boolean } -{ $subsection not } -{ $subsection and } -{ $subsection or } -{ $subsection xor } -{ $subsection "conditionals-boolean-equivalence" } -"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches." -{ $see-also "booleans" "bitwise-arithmetic" both? either? } ; - ARTICLE: "equality" "Equality" "There are two distinct notions of “sameness” when it comes to objects." $nl @@ -1116,34 +862,3 @@ ARTICLE: "assertions" "Assertions" { $subsection assert } { $subsection assert= } ; -ARTICLE: "dataflow-combinators" "Data flow combinators" -"Data flow combinators pass values between quotations:" -{ $subsection "slip-keep-combinators" } -{ $subsection "cleave-combinators" } -{ $subsection "spread-combinators" } -{ $subsection "apply-combinators" } -{ $see-also "curried-dataflow" } ; - -ARTICLE: "dataflow" "Data and control flow" -{ $subsection "evaluator" } -{ $subsection "words" } -{ $subsection "effects" } -{ $subsection "booleans" } -{ $subsection "shuffle-words" } -"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input." -{ $subsection "dataflow-combinators" } -{ $subsection "conditionals" } -{ $subsection "looping-combinators" } -{ $subsection "compositional-combinators" } -{ $subsection "combinators" } -"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "." -$nl -"Advanced topics:" -{ $subsection "assertions" } -{ $subsection "implementing-combinators" } -{ $subsection "macros" } -{ $subsection "errors" } -{ $subsection "continuations" } ; - -ABOUT: "dataflow" - diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index f79dcb5481..c28bf062c1 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -355,8 +355,9 @@ ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic" { $subsection 2/ } { $subsection 2^ } { $subsection bit? } -"The " { $vocab-link "math.bitwise" } " vocabulary implements additional bitwise integer operations." -{ $see-also "conditionals" } ; +{ $subsection "math.bitwise" } +{ $subsection "math.bits" } +{ $see-also "booleans" } ; ARTICLE: "arithmetic" "Arithmetic" "Factor attempts to preserve natural mathematical semantics for numbers. Multiplying two large integers never results in overflow, and dividing two integers yields an exact ratio. Floating point numbers are also supported, along with complex numbers." diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor index 1bdd1009e9..8b2200aa67 100644 --- a/core/math/order/order-docs.factor +++ b/core/math/order/order-docs.factor @@ -87,7 +87,14 @@ ARTICLE: "order-specifiers" "Ordering specifiers" { $subsection +lt+ } { $subsection +eq+ } { $subsection +gt+ } ; - + +ARTICLE: "math.order.example" "Linear order example" +"A tuple class which defines an ordering among instances by comparing the values of the " { $snippet "id" } " slot:" +{ $code + "TUPLE: sprite id name bitmap ;" + "M: sprite <=> [ id>> ] compare ;" +} ; + ARTICLE: "math.order" "Linear order protocol" "Some classes have an intrinsic order amongst instances:" { $subsection <=> } @@ -101,6 +108,8 @@ ARTICLE: "math.order" "Linear order protocol" { $subsection before? } { $subsection after=? } { $subsection before=? } +"Out of the above generic words, it suffices to implement " { $link <=> } " alone. The others may be provided as an optimization." +{ $subsection "math.order.example" } { $see-also "sequences-sorting" } ; ABOUT: "math.order" diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor index ff0542a7b8..74d7c58963 100644 --- a/core/namespaces/namespaces-docs.factor +++ b/core/namespaces/namespaces-docs.factor @@ -32,7 +32,7 @@ ARTICLE: "namespaces.private" "Namespace implementation details" { $subsection >n } { $subsection ndrop } ; -ARTICLE: "namespaces" "Variables and namespaces" +ARTICLE: "namespaces" "Dynamic variables and namespaces" "The " { $vocab-link "namespaces" } " vocabulary implements simple dynamically-scoped variables." $nl "A variable is an entry in an assoc of bindings, where the assoc is implicit rather than passed on the stack. These assocs are termed " { $emphasis "namespaces" } ". Nesting of scopes is implemented with a search order on namespaces, defined by a " { $emphasis "namestack" } ". Since namespaces are just assoc, any object can be used as a variable, however by convention, variables are keyed by symbols (see " { $link "words.symbol" } ")." @@ -43,7 +43,6 @@ $nl "Various utility words abstract away common variable access patterns:" { $subsection "namespaces-change" } { $subsection "namespaces-combinators" } -{ $subsection "namespaces-global" } "Implementation details your code probably does not care about:" { $subsection "namespaces.private" } "An alternative to dynamic scope is lexical scope. Lexically-scoped values and closures are implemented in the " { $vocab-link "locals" } " vocabulary." ; diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 547f7c0490..be4b345f4f 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -92,9 +92,7 @@ ARTICLE: "parser" "The parser" "This parser is a general facility for reading textual representations of objects and definitions. The parser is implemented in the " { $vocab-link "parser" } " and " { $vocab-link "syntax" } " vocabularies." $nl "This section concerns itself with usage and extension of the parser. Standard syntax is described in " { $link "syntax" } "." -{ $subsection "vocabulary-search" } { $subsection "parser-files" } -{ $subsection "top-level-forms" } "The parser can be extended." { $subsection "parsing-words" } { $subsection "parser-lexer" } diff --git a/core/quotations/quotations-docs.factor b/core/quotations/quotations-docs.factor index 2a03b7c74f..a72f4adf88 100644 --- a/core/quotations/quotations-docs.factor +++ b/core/quotations/quotations-docs.factor @@ -24,7 +24,7 @@ ARTICLE: "wrappers" "Wrappers" "Wrappers are used to push words on the data stack; they evaluate to the object being wrapped:" { $subsection wrapper } { $subsection literalize } -{ $see-also "dataflow" "combinators" } ; +{ $see-also "combinators" } ; ABOUT: "quotations" diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index e2badc2031..4103950005 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1354,14 +1354,16 @@ ARTICLE: "virtual-sequences" "Virtual sequences" "Virtual sequences allow different ways of accessing a sequence without having to create a new sequence or a new data structure altogether. To do this, they translate the virtual index into a normal index into an underlying sequence using the " { $link "virtual-sequences-protocol" } "." { $subsection "virtual-sequences-protocol" } ; -ARTICLE: "sequences-integers" "Integer sequences and counted loops" +ARTICLE: "sequences-integers" "Counted loops" "Integers support the sequence protocol in a trivial fashion; a non-negative integer presents its non-negative predecessors as elements. For example, the integer 3, when viewed as a sequence, contains the elements 0, 1, and 2. This is very useful for performing counted loops." $nl "For example, the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:" { $example "3 [ . ] each" "0\n1\n2" } "A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "." $nl -"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer." ; +"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer." +$nl +"More elaborate counted loops can be performed with " { $link "math.ranges" } "." ; ARTICLE: "sequences-access" "Accessing sequence elements" { $subsection ?nth } @@ -1593,7 +1595,6 @@ $nl "Sequences implement a protocol:" { $subsection "sequence-protocol" } { $subsection "sequences-f" } -{ $subsection "sequences-integers" } "Sequence utility words can operate on any object whose class implements the sequence protocol. Most implementations are backed by storage. Some implementations obtain their elements from an underlying sequence, or compute them on the fly. These are known as " { $link "virtual-sequences" } "." { $subsection "sequences-access" } { $subsection "sequences-combinators" } @@ -1612,6 +1613,10 @@ $nl { $subsection "binary-search" } { $subsection "sets" } { $subsection "sequences-trimming" } +{ $subsection "sequences.deep" } +"Using sequences for looping:" +{ $subsection "sequences-integers" } +{ $subsection "ranges" } "For inner loops:" { $subsection "sequences-unsafe" } ; diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 840fe628e0..1e5f9bf1dd 100644 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -83,7 +83,7 @@ $nl "A word can be used to check if a class has an initial value or not:" { $subsection initial-value } ; -ARTICLE: "slots" "Slots" +ARTICLE: "slots" "Low-level slot operations" "The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object. A " { $emphasis "slot" } " is a component of an object which can store a value." $nl { $link "tuples" } " are composed entirely of slots, and instances of " { $link "builtin-classes" } " consist of slots together with intrinsic data." @@ -104,6 +104,9 @@ $nl { $subsection define-changer } { $subsection define-slot-methods } { $subsection define-accessors } +"Unsafe slot access:" +{ $subsection slot } +{ $subsection set-slot } { $see-also "accessors" "mirrors" } ; ABOUT: "slots" diff --git a/extra/peg-lexer/tags.txt b/extra/peg-lexer/tags.txt index 47619a17f8..44385cf3b7 100644 --- a/extra/peg-lexer/tags.txt +++ b/extra/peg-lexer/tags.txt @@ -1 +1,2 @@ -reflection \ No newline at end of file +extensions +reflection From 1071a3c5644534127ec33551501e29b6d5ede673 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 03:03:46 -0500 Subject: [PATCH 107/772] Fix ui.tools.browser.history tests --- .../tools/browser/history/history-tests.factor | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/basis/ui/tools/browser/history/history-tests.factor b/basis/ui/tools/browser/history/history-tests.factor index 20b16f450a..454e4700a0 100644 --- a/basis/ui/tools/browser/history/history-tests.factor +++ b/basis/ui/tools/browser/history/history-tests.factor @@ -1,7 +1,13 @@ -USING: namespaces ui.tools.browser.history sequences tools.test ; +USING: namespaces ui.tools.browser.history sequences tools.test +accessors kernel ; IN: ui.tools.browser.history.tests -f "history" set +TUPLE: dummy obj ; + +M: dummy history-value obj>> ; +M: dummy set-history-value (>>obj) ; + +dummy new "history" set "history" get add-history @@ -9,27 +15,27 @@ f "history" set [ t ] [ "history" get forward>> empty? ] unit-test "history" get add-history -"history" get 3 >>value drop +3 "history" get owner>> set-history-value [ t ] [ "history" get back>> empty? ] unit-test [ t ] [ "history" get forward>> empty? ] unit-test "history" get add-history -"history" get 4 >>value drop +4 "history" get owner>> set-history-value [ f ] [ "history" get back>> empty? ] unit-test [ t ] [ "history" get forward>> empty? ] unit-test "history" get go-back -[ 3 ] [ "history" get value>> ] unit-test +[ 3 ] [ "history" get owner>> history-value ] unit-test [ t ] [ "history" get back>> empty? ] unit-test [ f ] [ "history" get forward>> empty? ] unit-test "history" get go-forward -[ 4 ] [ "history" get value>> ] unit-test +[ 4 ] [ "history" get owner>> history-value ] unit-test [ f ] [ "history" get back>> empty? ] unit-test [ t ] [ "history" get forward>> empty? ] unit-test From 3af8643c309ef5ea0b1ad067b1378f02c6a18048 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 03:03:58 -0500 Subject: [PATCH 108/772] More tags --- extra/descriptive/tags.txt | 1 + extra/multi-methods/tags.txt | 1 + 2 files changed, 2 insertions(+) create mode 100644 extra/descriptive/tags.txt create mode 100644 extra/multi-methods/tags.txt diff --git a/extra/descriptive/tags.txt b/extra/descriptive/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/extra/descriptive/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/extra/multi-methods/tags.txt b/extra/multi-methods/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/extra/multi-methods/tags.txt @@ -0,0 +1 @@ +extensions From 0f04061079a8b6fbc157aa873a982d2c9a635693 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 03:30:23 -0500 Subject: [PATCH 109/772] Fixing some unit test failures --- basis/prettyprint/prettyprint-tests.factor | 8 ++------ core/words/constant/constant-tests.factor | 8 +++++++- core/words/constant/constant.factor | 11 +++++++---- core/words/symbol/symbol.factor | 7 +++---- 4 files changed, 19 insertions(+), 15 deletions(-) diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index 3350ae6c7b..799d500c18 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -278,11 +278,7 @@ GENERIC: generic-see-test-with-f ( obj -- obj ) M: f generic-see-test-with-f ; [ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [ - [ { POSTPONE: f generic-see-test-with-f } see ] with-string-writer -] unit-test - -[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [ - [ \ f \ generic-see-test-with-f method see ] with-string-writer + [ M\ f generic-see-test-with-f see ] with-string-writer ] unit-test PREDICATE: predicate-see-test < integer even? ; @@ -309,5 +305,5 @@ GENERIC: ended-up-ballin' ( a -- b ) M: started-out-hustlin' ended-up-ballin' ; inline [ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [ - [ { started-out-hustlin' ended-up-ballin' } see ] with-string-writer + [ M\ started-out-hustlin' ended-up-ballin' see ] with-string-writer ] unit-test diff --git a/core/words/constant/constant-tests.factor b/core/words/constant/constant-tests.factor index 2755039af6..721846b2d1 100644 --- a/core/words/constant/constant-tests.factor +++ b/core/words/constant/constant-tests.factor @@ -1,10 +1,12 @@ IN: words.constant.tests -USING: tools.test math ; +USING: tools.test math words.constant ; CONSTANT: a + [ + ] [ a ] unit-test +[ t ] [ \ a constant? ] unit-test + CONSTANT: b \ + [ \ + ] [ b ] unit-test @@ -12,3 +14,7 @@ CONSTANT: b \ + CONSTANT: c { 1 2 3 } [ { 1 2 3 } ] [ c ] unit-test + +SYMBOL: foo + +[ f ] [ \ foo constant? ] unit-test \ No newline at end of file diff --git a/core/words/constant/constant.factor b/core/words/constant/constant.factor index 00302df98a..b518760bf9 100644 --- a/core/words/constant/constant.factor +++ b/core/words/constant/constant.factor @@ -3,12 +3,15 @@ USING: accessors kernel sequences words definitions quotations ; IN: words.constant -PREDICATE: constant < word ( obj -- ? ) - def>> dup length 1 = [ first word? not ] [ drop f ] if ; +PREDICATE: constant < word "constant" word-prop >boolean ; : define-constant ( word value -- ) - [ ] curry (( -- value )) define-inline ; + [ "constant" set-word-prop ] + [ [ ] curry (( -- value )) define-inline ] 2bi ; + +M: constant reset-word + [ call-next-method ] [ f "constant" set-word-prop ] bi ; M: constant definer drop \ CONSTANT: f ; -M: constant definition def>> first literalize 1quotation ; \ No newline at end of file +M: constant definition "constant" word-prop literalize 1quotation ; \ No newline at end of file diff --git a/core/words/symbol/symbol.factor b/core/words/symbol/symbol.factor index a107808eec..34ec6b9174 100644 --- a/core/words/symbol/symbol.factor +++ b/core/words/symbol/symbol.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors definitions -words words.constant ; +USING: kernel sequences accessors definitions words ; IN: words.symbol -PREDICATE: symbol < constant ( obj -- ? ) +PREDICATE: symbol < word ( obj -- ? ) [ def>> ] [ [ ] curry ] bi sequence= ; M: symbol definer drop \ SYMBOL: f ; @@ -12,4 +11,4 @@ M: symbol definer drop \ SYMBOL: f ; M: symbol definition drop f ; : define-symbol ( word -- ) - dup define-constant ; + dup [ ] curry (( -- value )) define-inline ; From fb246e2c85497940576a8b08565e37acce8a177e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 04:15:58 -0500 Subject: [PATCH 110/772] Documentation fixes --- core/io/encodings/encodings-docs.factor | 4 ++-- core/sequences/sequences-docs.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index 204441c19a..d0f968a791 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -80,12 +80,12 @@ ARTICLE: "encodings-descriptors" "Encoding descriptors" "An encoding descriptor is something which can be used with binary input or output streams to encode or decode bytes stored in a certain representation. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:" { $subsection "io.encodings.binary" } { $subsection "io.encodings.utf8" } -{ $subsection "io.encodings.utf16" } +{ $vocab-subsection "UTF-16 encoding" "io.encodings.utf16" } { $vocab-subsection "UTF-32 encoding" "io.encodings.utf32" } { $vocab-subsection "Strict encodings" "io.encodings.strict" } "Legacy encodings:" { $vocab-subsection "8-bit encodings" "io.encodings.8-bit" } -{ $vocab-subsection "ASCII" "io.encodings.ascii" } +{ $vocab-subsection "ASCII encoding" "io.encodings.ascii" } { $see-also "encodings-introduction" } ; ARTICLE: "encodings-protocol" "Encoding protocol" diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 4103950005..556e41249e 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1616,7 +1616,7 @@ $nl { $subsection "sequences.deep" } "Using sequences for looping:" { $subsection "sequences-integers" } -{ $subsection "ranges" } +{ $subsection "math.ranges" } "For inner loops:" { $subsection "sequences-unsafe" } ; From 7bf0a46d3d02efa1aaa3dff0c5117f31d9134ec2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 04:16:39 -0500 Subject: [PATCH 111/772] Updating tests for method-spec removal --- core/classes/classes.factor | 3 +-- core/classes/tuple/tuple-tests.factor | 2 +- core/generic/generic.factor | 3 +++ 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/core/classes/classes.factor b/core/classes/classes.factor index eded33beed..ab8ba398cd 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -174,8 +174,7 @@ GENERIC: update-methods ( class seq -- ) [ forget ] [ drop ] if ] [ 2drop ] if ; -: forget-methods ( class -- ) - [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ; +GENERIC: forget-methods ( class -- ) GENERIC: class-forgotten ( use class -- ) diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index fa2df4e312..6de1810a51 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -133,7 +133,7 @@ M: integer forget-robustness-generic ; [ [ ] [ \ forget-robustness-generic forget ] unit-test [ ] [ \ forget-robustness forget ] unit-test - [ ] [ { forget-robustness forget-robustness-generic } forget ] unit-test + [ ] [ M\ forget-robustness forget-robustness-generic forget ] unit-test ] with-compilation-unit ! rapido found this one diff --git a/core/generic/generic.factor b/core/generic/generic.factor index ab0685f1d6..65a802dc2d 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -188,5 +188,8 @@ M: generic subwords M: generic forget* [ subwords forget-all ] [ call-next-method ] bi ; +M: class forget-methods + [ implementors ] [ [ swap method ] curry ] bi map forget-all ; + : xref-generics ( -- ) all-words [ subwords [ xref ] each ] each ; From 890553b776009278dea4884cb5945f7b3ab56210 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 05:22:28 -0500 Subject: [PATCH 112/772] Fixing tests for method-sec removal --- basis/locals/locals-tests.factor | 2 +- basis/models/arrow/smart/smart-docs.factor | 21 +++++++++++++++++++ .../annotations/annotations-tests.factor | 2 +- basis/tools/deploy/test/14/14.factor | 17 +++++++++++++++ basis/tools/deploy/test/14/authors.txt | 1 + basis/tools/deploy/test/14/deploy.factor | 15 +++++++++++++ basis/ui/traverse/traverse-docs.factor | 0 basis/ui/traverse/traverse-tests.factor | 2 +- core/classes/tuple/tuple-tests.factor | 2 +- core/definitions/definitions-tests.factor | 11 ++++------ core/generic/generic-tests.factor | 4 ++-- 11 files changed, 64 insertions(+), 13 deletions(-) create mode 100644 basis/models/arrow/smart/smart-docs.factor create mode 100644 basis/tools/deploy/test/14/14.factor create mode 100644 basis/tools/deploy/test/14/authors.txt create mode 100644 basis/tools/deploy/test/14/deploy.factor create mode 100644 basis/ui/traverse/traverse-docs.factor diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 8e61e39faf..5e61c1ddfd 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -455,7 +455,7 @@ GENERIC: lambda-method-forget-test ( a -- b ) M:: integer lambda-method-forget-test ( a -- b ) ; -[ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test +[ ] [ [ M\ integer lambda-method-forget-test forget ] with-compilation-unit ] unit-test [ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test diff --git a/basis/models/arrow/smart/smart-docs.factor b/basis/models/arrow/smart/smart-docs.factor new file mode 100644 index 0000000000..45faf52b97 --- /dev/null +++ b/basis/models/arrow/smart/smart-docs.factor @@ -0,0 +1,21 @@ +IN: models.arrow.smart +USING: help.syntax help.markup models.product ; + +HELP: +{ $values { "quot" { $quotation "( ... -- output )" } } } +{ $description "A macro that expands into a form with the stack effect of the quotation. The form constructs a model which applies the quotation to values from an underlying " { $link product } " model having as many components as the quotation has inputs." } +{ $examples + "A model which adds the values of two existing models:" + { $example + "USING: models models.arrows.smart accessors math prettyprint ;" + "1 2 [ + ] " + "[ activate-model ] [ value>> ] bi ." + "3" + } +} ; + +ARTICLE: "models.arrows.smart" "Smart arrow models" +"The " { $vocab-link "models.arrows.smart" } " vocabulary generalizes arrows to arbitrary input arity. They're called “smart” because they resemble " { $link "combinators.smart" } "." +{ $subsection } ; + +ABOUT: "models.arrows.smart" \ No newline at end of file diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor index f47852aca7..9fa9d1e2aa 100644 --- a/basis/tools/annotations/annotations-tests.factor +++ b/basis/tools/annotations/annotations-tests.factor @@ -43,6 +43,6 @@ GENERIC: blah-generic ( a -- b ) M: string blah-generic ; -{ string blah-generic } watch +[ ] [ M\ string blah-generic watch ] unit-test [ "hi" ] [ "hi" blah-generic ] unit-test diff --git a/basis/tools/deploy/test/14/14.factor b/basis/tools/deploy/test/14/14.factor new file mode 100644 index 0000000000..f21afc13d6 --- /dev/null +++ b/basis/tools/deploy/test/14/14.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien threads ; +IN: tools.deploy.test.14 + +: (callback-yield-test) ( -- ) + "void" { } "cdecl" [ yield ] alien-callback + "void" { } "cdecl" alien-indirect ; + +: callback-yield-test ( -- ) + + "void" { } "cdecl" [ + (callback-yield-test) + ] alien-callback + "void" { } "cdecl" alien-indirect ; + +MAIN: callback-yield-test \ No newline at end of file diff --git a/basis/tools/deploy/test/14/authors.txt b/basis/tools/deploy/test/14/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/tools/deploy/test/14/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/deploy/test/14/deploy.factor b/basis/tools/deploy/test/14/deploy.factor new file mode 100644 index 0000000000..0fe268822c --- /dev/null +++ b/basis/tools/deploy/test/14/deploy.factor @@ -0,0 +1,15 @@ +USING: tools.deploy.config ; +H{ + { deploy-name "tools.deploy.test.14" } + { deploy-threads? t } + { deploy-math? f } + { deploy-word-props? f } + { deploy-ui? f } + { deploy-io 1 } + { deploy-compiler? t } + { deploy-reflection 1 } + { "stop-after-last-window?" t } + { deploy-unicode? f } + { deploy-word-defs? f } + { deploy-c-types? f } +} diff --git a/basis/ui/traverse/traverse-docs.factor b/basis/ui/traverse/traverse-docs.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/basis/ui/traverse/traverse-tests.factor b/basis/ui/traverse/traverse-tests.factor index e18637a652..4d2072db1c 100644 --- a/basis/ui/traverse/traverse-tests.factor +++ b/basis/ui/traverse/traverse-tests.factor @@ -62,4 +62,4 @@ M: object (flatten-tree) , ; { 0 1 } { 2 0 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } { { "h" "i" } "j" } } gadgets-in-range ] unit-test -[ { array children>> } forget ] with-compilation-unit +[ M\ array children>> forget ] with-compilation-unit diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 6de1810a51..75d733b213 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -559,7 +559,7 @@ DEFER: subclass-reset-test-3 GENERIC: break-me ( obj -- ) -[ ] [ [ { integer break-me } forget ] with-compilation-unit ] unit-test +[ ] [ [ M\ integer break-me forget ] with-compilation-unit ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" "subclass-reset-test" parse-stream drop ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval ] unit-test diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index b2d265a2e3..558b259103 100644 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -20,14 +20,11 @@ TUPLE: some-class ; M: some-class some-generic ; -TUPLE: another-class some-generic ; - [ ] [ [ - { - some-generic - some-class - { another-class some-generic } - } forget-all + \ some-generic + \ some-class + 2array + forget-all ] with-compilation-unit ] unit-test diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 151c2f52fa..f28332353e 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -161,7 +161,7 @@ M: sequence generic-forget-test-2 = ; ] unit-test [ ] [ - [ { sequence generic-forget-test-2 } forget ] with-compilation-unit + [ M\ sequence generic-forget-test-2 forget ] with-compilation-unit ] unit-test [ f ] [ @@ -231,7 +231,7 @@ M: number c-n-m-cache ; [ 3 ] [ 2 c-n-m-cache ] unit-test -[ ] [ [ { integer c-n-m-cache } forget ] with-compilation-unit ] unit-test +[ ] [ [ M\ integer c-n-m-cache forget ] with-compilation-unit ] unit-test [ 2 ] [ 2 c-n-m-cache ] unit-test From cb9e4a40692fdd55c6e9616be903510c3276d3a5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 05:22:43 -0500 Subject: [PATCH 113/772] Oops --- basis/tools/deploy/test/14/14.factor | 17 ----------------- basis/tools/deploy/test/14/authors.txt | 1 - basis/tools/deploy/test/14/deploy.factor | 15 --------------- 3 files changed, 33 deletions(-) delete mode 100644 basis/tools/deploy/test/14/14.factor delete mode 100644 basis/tools/deploy/test/14/authors.txt delete mode 100644 basis/tools/deploy/test/14/deploy.factor diff --git a/basis/tools/deploy/test/14/14.factor b/basis/tools/deploy/test/14/14.factor deleted file mode 100644 index f21afc13d6..0000000000 --- a/basis/tools/deploy/test/14/14.factor +++ /dev/null @@ -1,17 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien threads ; -IN: tools.deploy.test.14 - -: (callback-yield-test) ( -- ) - "void" { } "cdecl" [ yield ] alien-callback - "void" { } "cdecl" alien-indirect ; - -: callback-yield-test ( -- ) - - "void" { } "cdecl" [ - (callback-yield-test) - ] alien-callback - "void" { } "cdecl" alien-indirect ; - -MAIN: callback-yield-test \ No newline at end of file diff --git a/basis/tools/deploy/test/14/authors.txt b/basis/tools/deploy/test/14/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/basis/tools/deploy/test/14/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ No newline at end of file diff --git a/basis/tools/deploy/test/14/deploy.factor b/basis/tools/deploy/test/14/deploy.factor deleted file mode 100644 index 0fe268822c..0000000000 --- a/basis/tools/deploy/test/14/deploy.factor +++ /dev/null @@ -1,15 +0,0 @@ -USING: tools.deploy.config ; -H{ - { deploy-name "tools.deploy.test.14" } - { deploy-threads? t } - { deploy-math? f } - { deploy-word-props? f } - { deploy-ui? f } - { deploy-io 1 } - { deploy-compiler? t } - { deploy-reflection 1 } - { "stop-after-last-window?" t } - { deploy-unicode? f } - { deploy-word-defs? f } - { deploy-c-types? f } -} From dd43df655f6707b693b5cccc85e3c8d5ad951cb5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Apr 2009 10:45:39 -0500 Subject: [PATCH 114/772] fix unit test for new method syntax --- basis/tools/disassembler/disassembler-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/disassembler/disassembler-tests.factor b/basis/tools/disassembler/disassembler-tests.factor index 96f5a04378..49cfb054a1 100644 --- a/basis/tools/disassembler/disassembler-tests.factor +++ b/basis/tools/disassembler/disassembler-tests.factor @@ -3,4 +3,4 @@ USING: math classes.tuple prettyprint.custom tools.disassembler tools.test strings ; [ ] [ \ + disassemble ] unit-test -[ ] [ { string pprint* } disassemble ] unit-test +[ ] [ M\ string pprint* disassemble ] unit-test From adc764efa3238b8a75b1f3715a631bdbea8e8baa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 13:26:07 -0500 Subject: [PATCH 115/772] Cleanup --- core/definitions/definitions.factor | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index c95c5816ac..636067e04b 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -3,8 +3,6 @@ USING: kernel sequences namespaces assocs graphs math math.order ; IN: definitions -MIXIN: definition - ERROR: no-compilation-unit definition ; SYMBOLS: inlined-dependency flushed-dependency called-dependency ; @@ -42,7 +40,7 @@ GENERIC: set-where ( loc defspec -- ) GENERIC: forget* ( defspec -- ) -M: object forget* drop ; +M: f forget* drop ; SYMBOL: forgotten-definitions @@ -53,8 +51,6 @@ SYMBOL: forgotten-definitions : forget-all ( definitions -- ) [ forget ] each ; -GENERIC: synopsis* ( defspec -- ) - GENERIC: definer ( defspec -- start end ) GENERIC: definition ( defspec -- seq ) From 1d563edcd90495e5bbb174a9396fb79c5c449852 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 13:34:38 -0500 Subject: [PATCH 116/772] Oops --- core/definitions/definitions.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 636067e04b..7463a863e5 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -3,6 +3,8 @@ USING: kernel sequences namespaces assocs graphs math math.order ; IN: definitions +MIXIN: definition + ERROR: no-compilation-unit definition ; SYMBOLS: inlined-dependency flushed-dependency called-dependency ; From 37e5d502f1869d18ccb8ea06a925d1f88bfebedd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 13:39:55 -0500 Subject: [PATCH 117/772] Fix shift-drag losing focus in listener --- basis/ui/gadgets/editors/editors.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 3eb40a5135..9461b2348f 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -452,6 +452,7 @@ editor "caret-motion" f { editor "selection" f { { T{ button-down f { S+ } 1 } extend-selection } + { T{ button-up f { S+ } 1 } com-copy-selection } { T{ drag } drag-selection } { gain-focus focus-editor } { lose-focus unfocus-editor } From cbd6b0ed3b11f427a59416802e5655637bf8b075 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 6 Apr 2009 15:18:35 -0400 Subject: [PATCH 118/772] fix documentation typo --- basis/ui/gadgets/buttons/buttons-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/gadgets/buttons/buttons-docs.factor b/basis/ui/gadgets/buttons/buttons-docs.factor index 6042a39886..a28a6aef84 100644 --- a/basis/ui/gadgets/buttons/buttons-docs.factor +++ b/basis/ui/gadgets/buttons/buttons-docs.factor @@ -26,7 +26,7 @@ HELP: { $description "Creates a new " { $link button } " derived from a " { $link } " which calls the quotation every 100 milliseconds as long as the mouse button is held down." } ; HELP: button-pen -{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " gneeric words by delegating to an object in one of four slots which depend on the state of the button being drawn:" +{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words by delegating to an object in one of four slots which depend on the state of the button being drawn:" { $list { { $snippet "plain" } " - the button is inactive" } { { $snippet "rollover" } " - the button is under the mouse" } From 07f585a81d266d7fc470417441c6f38fbed3d676 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 15:24:21 -0500 Subject: [PATCH 119/772] Error list tool work in progress --- .../errors/prettyprint/prettyprint.factor | 2 ++ basis/ui/tools/browser/popups/popups.factor | 2 +- .../compiler-errors/compiler-errors.factor | 36 +++++++++++++++---- 3 files changed, 32 insertions(+), 8 deletions(-) diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index 9dc82339b5..a71af74871 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -4,6 +4,8 @@ USING: accessors kernel prettyprint io debugger sequences assocs stack-checker.errors summary effects ; IN: stack-checker.errors.prettyprint +M: inference-error summary error>> summary ; + M: inference-error error-help error>> error-help ; M: inference-error error. diff --git a/basis/ui/tools/browser/popups/popups.factor b/basis/ui/tools/browser/popups/popups.factor index 05d7779305..91ac96e0f9 100644 --- a/basis/ui/tools/browser/popups/popups.factor +++ b/basis/ui/tools/browser/popups/popups.factor @@ -46,7 +46,7 @@ SLOT: model : show-links-popup ( browser-gadget quot title -- ) [ dup model>> ] 2dip - [ hand-loc get { 0 0 } show-glass ] [ request-focus ] bi ; + [ hand-loc get { 0 0 } show-glass ] [ request-focus ] bi ; inline : com-show-outgoing-links ( browser-gadget -- ) [ uses ] "Outgoing links" show-links-popup ; diff --git a/basis/ui/tools/compiler-errors/compiler-errors.factor b/basis/ui/tools/compiler-errors/compiler-errors.factor index e574aa077a..6efb5586ba 100644 --- a/basis/ui/tools/compiler-errors/compiler-errors.factor +++ b/basis/ui/tools/compiler-errors/compiler-errors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays sorting assocs colors.constants combinators -combinators.smart compiler.errors compiler.units fonts kernel +USING: accessors arrays sequences sorting assocs colors.constants combinators +combinators.smart compiler.errors compiler.units fonts kernel io.pathnames math.parser math.order models models.arrow namespaces summary ui ui.commands ui.gadgets ui.gadgets.tables ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser ui.tools.common @@ -10,6 +10,29 @@ IN: ui.tools.compiler-errors TUPLE: error-list-gadget < tool table ; +SINGLETON: source-file-renderer + +M: source-file-renderer row-columns + drop [ first2 length number>string 2array ] [ { "All" "" } ] if* ; + +M: source-file-renderer row-value + drop first ; + +M: source-file-renderer column-titles + drop { "File" "Errors" } ; + +: ( model -- table ) + [ group-by-source-file >alist sort-keys f prefix ] + source-file-renderer
+ [ invoke-primary-operation ] >>action + COLOR: dark-gray >>column-line-color + { 1 f } >>column-widths + 6 >>gap + 30 >>min-rows + 30 >>max-rows + 80 >>min-cols + 80 >>max-cols ; + SINGLETON: error-renderer M: error-renderer row-columns @@ -32,7 +55,6 @@ M: error-renderer column-titles [ [ [ [ file>> ] [ line#>> ] bi 2array ] compare ] sort ] error-renderer
[ invoke-primary-operation ] >>action - monospace-font >>font COLOR: dark-gray >>column-line-color 6 >>gap 30 >>min-rows @@ -41,10 +63,10 @@ M: error-renderer column-titles 80 >>max-cols ; : ( model -- gadget ) - [ values ] vertical error-list-gadget new-track + vertical error-list-gadget new-track { 3 3 } >>gap - swap >>table - dup table>> 1 track-add ; + swap >>table + dup table>> 1/2 track-add ; M: error-list-gadget focusable-child* table>> ; @@ -72,6 +94,6 @@ M: updater definitions-changed updater remove-definition-observer updater add-definition-observer -: error-list-window ( obj -- ) +: error-list-window ( -- ) compiler-error-model get-global "Compiler errors" open-window ; \ No newline at end of file From 57b3801992dd1aabb3c1ed11e865b21c404b058f Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 6 Apr 2009 22:43:25 +0200 Subject: [PATCH 120/772] using method word to lookup up method --- mongodb/tuple/state/state.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/mongodb/tuple/state/state.factor b/mongodb/tuple/state/state.factor index ace7b16c8f..b358cd8e38 100644 --- a/mongodb/tuple/state/state.factor +++ b/mongodb/tuple/state/state.factor @@ -1,5 +1,5 @@ USING: classes kernel accessors sequences fry assocs mongodb.tuple.collection -advice words classes.tuple slots ; +advice words classes.tuple slots generic ; IN: mongodb.tuple.state @@ -56,8 +56,7 @@ PRIVATE> [ [ [ dup mark-dirty ] MDB_DIRTY_ADVICE ] dip advise-after ] if ; : (annotate-writer) ( class name -- ) - writer-word "methods" word-prop at - [ create-advice ] when* ; + writer-word method [ create-advice ] when* ; PRIVATE> From 77f99eb70cda805feb463f1e77c0eb34fb25cc7a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Apr 2009 17:32:20 -0500 Subject: [PATCH 121/772] use map-reduce instead of unclip reduce, "Why do we need this?" --> we don't --- basis/regexp/ast/ast.factor | 4 ++-- basis/regexp/transition-tables/transition-tables.factor | 6 ------ 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/basis/regexp/ast/ast.factor b/basis/regexp/ast/ast.factor index be657227e5..2916ef7c32 100644 --- a/basis/regexp/ast/ast.factor +++ b/basis/regexp/ast/ast.factor @@ -21,12 +21,12 @@ CONSTANT: epsilon T{ tagged-epsilon { tag t } } TUPLE: concatenation first second ; : ( seq -- concatenation ) - [ epsilon ] [ unclip [ concatenation boa ] reduce ] if-empty ; + [ epsilon ] [ [ ] [ concatenation boa ] map-reduce ] if-empty ; TUPLE: alternation first second ; : ( seq -- alternation ) - unclip [ alternation boa ] reduce ; + [ ] [ alternation boa ] map-reduce ; TUPLE: star term ; C: star diff --git a/basis/regexp/transition-tables/transition-tables.factor b/basis/regexp/transition-tables/transition-tables.factor index 3c33ae8846..f452e3d24a 100644 --- a/basis/regexp/transition-tables/transition-tables.factor +++ b/basis/regexp/transition-tables/transition-tables.factor @@ -11,12 +11,7 @@ TUPLE: transition-table transitions start-state final-states ; H{ } clone >>transitions H{ } clone >>final-states ; -: maybe-initialize-key ( key hashtable -- ) - ! Why do we have to do this? - 2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ; - :: (set-transition) ( from to obj hash -- ) - to condition? [ to hash maybe-initialize-key ] unless from hash at [ [ to obj ] dip set-at ] [ to obj associate from hash set-at ] if* ; @@ -25,7 +20,6 @@ TUPLE: transition-table transitions start-state final-states ; transitions>> (set-transition) ; :: (add-transition) ( from to obj hash -- ) - to hash maybe-initialize-key from hash at [ [ to obj ] dip push-at ] [ to 1vector obj associate from hash set-at ] if* ; From b6064813c92acb6ad64985258995dd2479356248 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Apr 2009 17:39:44 -0500 Subject: [PATCH 122/772] construct a glob-matching quote for robots.txt files --- extra/robots/robots.factor | 36 ++++++++++++++++++++++++++++++------ 1 file changed, 30 insertions(+), 6 deletions(-) diff --git a/extra/robots/robots.factor b/extra/robots/robots.factor index 1b2422f06e..242aa1dea2 100644 --- a/extra/robots/robots.factor +++ b/extra/robots/robots.factor @@ -3,11 +3,21 @@ USING: accessors http.client kernel unicode.categories sequences urls splitting combinators splitting.monotonic combinators.short-circuit assocs unicode.case arrays -math.parser calendar.format make ; +math.parser calendar.format make fry present globs +multiline regexp.combinators regexp ; IN: robots ! visit-time is GMT, request-rate is pages/second ! crawl-rate is seconds + +TUPLE: robots site sitemap rules rules-quot ; + +: ( site sitemap rules -- robots ) + \ robots new + swap >>rules + swap >>sitemap + swap >>site ; + TUPLE: rules user-agents allows disallows visit-time request-rate crawl-delay unknowns ; @@ -40,8 +50,8 @@ visit-time request-rate crawl-delay unknowns ; H{ } clone >>unknowns ; : add-user-agent ( rules agent -- rules ) over user-agents>> push ; -: add-allow ( rules allow -- rules ) over allows>> push ; -: add-disallow ( rules disallow -- rules ) over disallows>> push ; +: add-allow ( rules allow -- rules ) >url over allows>> push ; +: add-disallow ( rules disallow -- rules ) >url over disallows>> push ; : parse-robots.txt-line ( rules seq -- rules ) first2 swap { @@ -57,12 +67,26 @@ visit-time request-rate crawl-delay unknowns ; [ pick unknowns>> push-at ] } case ; +: derive-urls ( url seq -- seq' ) + [ derive-url present ] with { } map-as ; + +: robot-rules-quot ( robots -- quot ) + [ + [ site>> ] [ rules>> allows>> ] bi + derive-urls [ ] map + + ] [ + [ site>> ] [ rules>> disallows>> ] bi + derive-urls [ ] map + ] bi 2array '[ _ matches? ] ; + PRIVATE> : parse-robots.txt ( string -- sitemaps rules-seq ) normalize-robots.txt [ [ dup ] dip [ parse-robots.txt-line drop ] with each - ] map ; + ] map first ; -: robots ( url -- sitemaps rules-seq ) - get-robots.txt nip parse-robots.txt ; +: robots ( url -- robots ) + >url + dup get-robots.txt nip parse-robots.txt ; From e9b9907ef9a1217dd58d9be430fd9054ea74e24a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 17:49:34 -0500 Subject: [PATCH 123/772] Factor out site-watcher.email, start work on site-watcher.spider --- extra/benchmark/fib6/deploy.factor | 15 +++++++++++++++ extra/site-watcher/db/db.factor | 23 +++++++++++++++++++---- extra/site-watcher/email/authors.txt | 1 + extra/site-watcher/email/email.factor | 14 ++++++++++++++ extra/site-watcher/site-watcher.factor | 23 ++++++++--------------- extra/site-watcher/spider/authors.txt | 1 + extra/site-watcher/spider/spider.factor | 22 ++++++++++++++++++++++ extra/spider/report/report.factor | 24 +++++++++++++++++------- 8 files changed, 97 insertions(+), 26 deletions(-) create mode 100644 extra/benchmark/fib6/deploy.factor create mode 100644 extra/site-watcher/email/authors.txt create mode 100644 extra/site-watcher/email/email.factor create mode 100644 extra/site-watcher/spider/authors.txt create mode 100644 extra/site-watcher/spider/spider.factor diff --git a/extra/benchmark/fib6/deploy.factor b/extra/benchmark/fib6/deploy.factor new file mode 100644 index 0000000000..3a367dcd51 --- /dev/null +++ b/extra/benchmark/fib6/deploy.factor @@ -0,0 +1,15 @@ +USING: tools.deploy.config ; +H{ + { deploy-name "benchmark.fib6" } + { deploy-threads? f } + { deploy-math? f } + { deploy-word-props? f } + { deploy-ui? f } + { deploy-io 1 } + { deploy-compiler? t } + { deploy-reflection 1 } + { "stop-after-last-window?" t } + { deploy-unicode? f } + { deploy-word-defs? f } + { deploy-c-types? f } +} diff --git a/extra/site-watcher/db/db.factor b/extra/site-watcher/db/db.factor index 148e5b96f9..26d05441f3 100644 --- a/extra/site-watcher/db/db.factor +++ b/extra/site-watcher/db/db.factor @@ -47,9 +47,26 @@ watching-site "WATCHING_SITE" { { "site-id" "SITE_ID" INTEGER +user-assigned-id+ } } define-persistent -TUPLE: reporting-site email url up? changed? last-up? error last-error ; +TUPLE: spidering-site < watching-site max-depth max-count ; -> + site-id>> site new swap >>site-id select-tuple ; + +SLOT: account + +M: watching-site account>> + account-name>> account new swap >>account-name select-tuple ; + +spidering-site "SPIDERING_SITE" { + { "account-name" "ACCOUNT_NAME" VARCHAR +user-assigned-id+ } + { "site-id" "SITE_ID" INTEGER +user-assigned-id+ } + { "max-depth" "MAX_DEPTH" INTEGER } + { "max-count" "MAX_COUNT" INTEGER } +} define-persistent + +TUPLE: reporting-site site-id email url up? changed? last-up? error last-error ; : set-notify-site-watchers ( site new-up? -- site ) [ over up?>> = [ t >>changed? ] unless ] keep >>up? ; @@ -82,8 +99,6 @@ TUPLE: reporting-site email url up? changed? last-up? error last-error ; : select-account/site ( username url -- account site ) insert-site site-id>> ; -PRIVATE> - : watch-site ( username url -- ) select-account/site insert-tuple ; diff --git a/extra/site-watcher/email/authors.txt b/extra/site-watcher/email/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/site-watcher/email/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/site-watcher/email/email.factor b/extra/site-watcher/email/email.factor new file mode 100644 index 0000000000..d028788e26 --- /dev/null +++ b/extra/site-watcher/email/email.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: smtp namespaces accessors kernel arrays ; +IN: site-watcher.email + +SYMBOL: site-watcher-from +site-watcher-from [ "factor-site-watcher@gmail.com" ] initialize + +: send-site-email ( watching-site body subject -- ) + [ account>> email>> ] 2dip + pick [ + [ site-watcher-from get >>from ] 3dip + [ 1array >>to ] [ >>body ] [ >>subject ] tri* send-email + ] [ 3drop ] if ; \ No newline at end of file diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index 114cdf3259..c2ec2ada79 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -3,13 +3,9 @@ USING: accessors alarms arrays calendar combinators combinators.smart continuations debugger http.client fry init io.streams.string kernel locals math math.parser db -namespaces sequences site-watcher.db site-watcher.db.private -smtp ; +namespaces sequences site-watcher.db site-watcher.email ; IN: site-watcher -SYMBOL: site-watcher-from -"factor-site-watcher@gmail.com" site-watcher-from set-global - SYMBOL: site-watcher-frequency 5 minutes site-watcher-frequency set-global @@ -23,22 +19,19 @@ SYMBOL: running-site-watcher [ dup url>> http-get 2drop site-good ] [ site-bad ] recover ] each ; -: site-up-email ( email site -- email ) +: site-up-email ( site -- body ) last-up>> now swap time- duration>minutes 60 /mod [ >integer number>string ] bi@ [ " hours, " append ] [ " minutes" append ] bi* append - "Site was down for (at least): " prepend >>body ; + "Site was down for (at least): " prepend ; -: site-down-email ( email site -- email ) error>> >>body ; +: site-down-email ( site -- body ) error>> ; : send-report ( site -- ) - [ ] dip - { - [ email>> 1array >>to ] - [ drop site-watcher-from get "factor.site.watcher@gmail.com" or >>from ] - [ dup up?>> [ site-up-email ] [ site-down-email ] if ] - [ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue >>subject ] - } cleave send-email ; + [ ] + [ dup up?>> [ site-up-email ] [ site-down-email ] if ] + [ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue ] tri + send-site-email ; : send-reports ( seq -- ) [ ] [ [ send-report ] each ] if-empty ; diff --git a/extra/site-watcher/spider/authors.txt b/extra/site-watcher/spider/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/site-watcher/spider/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/site-watcher/spider/spider.factor b/extra/site-watcher/spider/spider.factor new file mode 100644 index 0000000000..1b3a96a018 --- /dev/null +++ b/extra/site-watcher/spider/spider.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: site-watcher.db site-watcher.email +spider spider.report +accessors kernel sequences +xml.writer ; +IN: site-watcher.spider + +: ( spidering-site -- spider ) + [ max-depth>> ] + [ max-count>> ] + [ site>> url>> ] + tri + + swap >>max-count + swap >>max-depth ; + +: spider-and-email ( spidering-site -- ) + [ ] + [ run-spider spider-report xml>string ] + [ site>> url>> "Spidered " prefix ] tri + send-site-email ; diff --git a/extra/spider/report/report.factor b/extra/spider/report/report.factor index 43952701d5..48620cac55 100644 --- a/extra/spider/report/report.factor +++ b/extra/spider/report/report.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators kernel math math.statistics namespaces sequences sorting xml.syntax -spider ; +spider urls html ; IN: spider.report SYMBOL: network-failures @@ -87,27 +87,37 @@ SYMBOL: time-std slowest-pages-table timing-summary-table [XML -

Slowest pages

+

Slowest pages

<-> -

Summary

+

Summary

<-> XML] ; : generate-report ( -- html ) + url get dup report-broken-pages report-network-failures report-timings [XML -

Broken pages

+

Spider report

+ URL: ><-> + +

Broken pages

<-> -

Network failures

+

Network failures

<-> -

Load times

+

Load times

<-> XML] ; : spider-report ( spider -- html ) - [ spidered>> process-results generate-report ] with-scope ; + [ "Spider report" f ] dip + [ + [ base>> url set ] + [ spidered>> process-results ] bi + generate-report + ] with-scope + simple-page ; From 37e278ed02d020451869af91e77fd48849381293 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 17:50:54 -0500 Subject: [PATCH 124/772] Use [ ] [ ] map-reduce instead of unclip [ ] reduce --- basis/compiler/cfg/linear-scan/allocation/allocation.factor | 2 +- basis/compiler/tree/propagation/info/info.factor | 2 +- basis/hints/hints.factor | 2 +- core/classes/builtin/builtin.factor | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 8d00a14ea2..908bf2475b 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -99,7 +99,7 @@ SYMBOL: spill-counts : interval-to-spill ( active-intervals current -- live-interval ) #! We spill the interval with the most distant use location. start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc - unclip-slice [ [ [ second ] bi@ > ] most ] reduce first ; + [ ] [ [ [ second ] bi@ > ] most ] map-reduce first ; : assign-spill ( before after -- before after ) #! If it has been spilled already, reuse spill location. diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index c56db570b2..a22b7aa172 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -238,7 +238,7 @@ DEFER: (value-info-union) : value-infos-union ( infos -- info ) [ null-info ] - [ unclip-slice [ value-info-union ] reduce ] if-empty ; + [ [ ] [ value-info-union ] map-reduce ] if-empty ; : literals<= ( info1 info2 -- ? ) { diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 6fece31d88..2534e0121f 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -25,7 +25,7 @@ M: object specializer-declaration class ; [ drop object eq? not ] assoc-filter [ [ t ] ] [ [ swap specializer-predicate append ] { } assoc>map - unclip [ swap [ f ] \ if 3array append [ ] like ] reduce + [ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce ] if-empty ; : specializer-cases ( quot word -- default alist ) diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index 0e4a3b56fd..f95d66fd05 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -55,7 +55,7 @@ M: anonymous-intersection (flatten-class) [ builtins get sift [ (flatten-class) ] each ] [ - unclip [ assoc-intersect ] reduce [ swap set ] assoc-each + [ ] [ assoc-intersect ] map-reduce [ swap set ] assoc-each ] if-empty ; M: anonymous-complement (flatten-class) From 2c08376cd53058a81e589a9a229210fbcd5515d4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 17:52:14 -0500 Subject: [PATCH 125/772] Minor doc updates --- basis/colors/colors-docs.factor | 2 +- basis/help/home/home.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/colors/colors-docs.factor b/basis/colors/colors-docs.factor index 8881d89711..5e2b09380d 100644 --- a/basis/colors/colors-docs.factor +++ b/basis/colors/colors-docs.factor @@ -23,7 +23,7 @@ $nl ARTICLE: "colors" "Colors" "The " { $vocab-link "colors" } " vocabulary defines a protocol for colors, with a concrete implementation for RGBA colors. This vocabulary is used by " { $vocab-link "io.styles" } ", " { $vocab-link "ui" } " and other vocabularies, but it is independent of them." $nl -"RGBA colors:" +"RGBA colors with floating point components in the range " { $snippet "[0,1]" } ":" { $subsection rgba } { $subsection } "Converting a color to RGBA:" diff --git a/basis/help/home/home.factor b/basis/help/home/home.factor index f32c0db30d..9cb3c6f1bb 100644 --- a/basis/help/home/home.factor +++ b/basis/help/home/home.factor @@ -21,7 +21,7 @@ M: apropos add-recent-where recent-searches ; M: object add-recent-where f ; : $recent ( element -- ) - first get [ nl ] [ 1array $pretty-link ] interleave ; + first get reverse [ nl ] [ 1array $pretty-link ] interleave ; : $recent-searches ( element -- ) drop recent-searches get [ <$link> ] map $list ; From c91712bea0d28c158a47222816553e919edd069f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Apr 2009 18:10:49 -0500 Subject: [PATCH 126/772] clean up a combinator in id3 parser --- extra/id3/id3.factor | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 8e824d689f..5076a4a8ab 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -163,17 +163,13 @@ TUPLE: id3v1-info title artist album year comment genre ; } cond ] with-mapped-uchar-file ; -: (find-id3-frame) ( id3 name quot: ( obj -- obj' ) -- obj' ) - [ swap frames>> at* ] dip - [ data>> ] prepose [ drop f ] if ; inline - PRIVATE> : mp3>id3 ( path -- id3v2-info/f ) dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; inline : find-id3-frame ( id3 name -- obj/f ) - [ ] (find-id3-frame) ; inline + swap frames>> at* [ data>> ] when ; inline : title ( id3 -- title/f ) "TIT2" find-id3-frame ; inline @@ -186,7 +182,7 @@ PRIVATE> : comment ( id3 -- comment/f ) "COMM" find-id3-frame ; inline : genre ( id3 -- genre/f ) - "TCON" [ parse-genre ] (find-id3-frame) ; inline + "TCON" find-id3-frame parse-genre ; inline : find-mp3s ( path -- seq ) [ >lower ".mp3" tail? ] find-all-files ; inline From a380ae223985d74b9570b8498f52c8c48e42c6c1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Apr 2009 18:47:46 -0500 Subject: [PATCH 127/772] refactor spider --- extra/spider/spider.factor | 45 ++++++++++++++++++++++++-------------- 1 file changed, 28 insertions(+), 17 deletions(-) diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index 49d6c33f8f..17e91473c3 100644 --- a/extra/spider/spider.factor +++ b/extra/spider/spider.factor @@ -5,12 +5,12 @@ http.client kernel tools.time sets assocs sequences concurrency.combinators io threads namespaces math multiline math.parser inspector urls logging combinators.short-circuit continuations calendar prettyprint dlists deques locals -spider.unique-deque ; +spider.unique-deque combinators concurrency.semaphores ; IN: spider TUPLE: spider base count max-count sleep max-depth initial-links filters spidered todo nonmatching quiet currently-spidering -#threads follow-robots? robots ; +#threads semaphore follow-robots? robots ; TUPLE: spider-result url depth headers fetched-in parsed-html links processed-in fetched-at ; @@ -26,7 +26,12 @@ fetched-in parsed-html links processed-in fetched-at ; 0 >>count 1/0. >>max-count H{ } clone >>spidered - 1 >>#threads ; + 1 [ >>#threads ] [ >>semaphore ] bi ; + +: ( url depth -- spider-result ) + spider-result new + swap >>depth + swap >>url ; > ] [ depth>> ] bi "depth: " write number>string write ", spidering: " write . yield ; -:: new-spidered-result ( spider url depth -- spider-result ) - f url spider spidered>> set-at - [ url http-get ] benchmark :> fetched-at :> html :> headers +:: fill-spidered-result ( spider spider-result -- ) + f spider-result url>> spider spidered>> set-at + [ spider-result url>> http-get ] benchmark :> fetched-in :> html :> headers [ html parse-html spider currently-spidering>> over find-all-links normalize-hrefs - ] benchmark :> processing-time :> links :> parsed-html - url depth headers fetched-at parsed-html links processing-time - now spider-result boa ; + ] benchmark :> processed-in :> links :> parsed-html + spider-result + headers >>headers + fetched-in >>fetched-in + parsed-html >>parsed-html + links >>links + processed-in >>processed-in + now >>fetched-at drop ; -:: spider-page ( spider url depth -- ) - spider quiet>> [ url depth print-spidering ] unless - spider url depth new-spidered-result :> spidered-result - spider quiet>> [ spidered-result describe ] unless - spider spidered-result add-spidered ; +:: spider-page ( spider spider-result -- ) + spider quiet>> [ spider-result print-spidering ] unless + spider spider-result fill-spidered-result + spider quiet>> [ spider-result describe ] unless + spider spider-result add-spidered ; \ spider-page ERROR add-error-logging @@ -94,9 +105,9 @@ fetched-in parsed-html links processed-in fetched-at ; [ [ count>> ] [ max-count>> ] bi < ] } 1&& ; -: setup-next-url ( spider -- spider url depth ) +: setup-next-url ( spider -- spider spider-result ) dup todo>> peek-url url>> >>currently-spidering - dup todo>> pop-url [ url>> ] [ depth>> ] bi ; + dup todo>> pop-url [ url>> ] [ depth>> ] bi ; : spider-next-page ( spider -- ) setup-next-url spider-page ; From fb37e0eacae2f365aa8cb99da133318554f858ff Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Apr 2009 19:43:50 -0500 Subject: [PATCH 128/772] unbreak regexp --- basis/regexp/dfa/dfa.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/regexp/dfa/dfa.factor b/basis/regexp/dfa/dfa.factor index d137ee3e4f..2de4e8b0e0 100644 --- a/basis/regexp/dfa/dfa.factor +++ b/basis/regexp/dfa/dfa.factor @@ -51,10 +51,13 @@ IN: regexp.dfa [ condition-states ] 2dip '[ _ _ add-todo-state ] each ; +: ensure-state ( key table -- ) + 2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ; inline + :: new-transitions ( nfa dfa new-states visited-states -- nfa dfa ) new-states [ nfa dfa ] [ pop :> state - state dfa transitions>> maybe-initialize-key + state dfa transitions>> ensure-state state nfa find-transitions [| trans | state trans nfa find-closure :> new-state From 9f08e3a6bf57a87e4c4ca5bdbcd5e76e6c99dfec Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 21:59:27 -0500 Subject: [PATCH 129/772] Working on site-watcher --- extra/site-watcher/db/db.factor | 37 +++++++--- extra/site-watcher/site-watcher.factor | 6 +- extra/site-watcher/spider/spider.factor | 7 +- extra/spider/report/report.factor | 9 +-- extra/webapps/site-watcher/common/authors.txt | 1 + .../webapps/site-watcher/common/common.factor | 6 ++ extra/webapps/site-watcher/common/main.xml | 13 ++++ .../webapps/site-watcher/common/site-list.xml | 28 ++++++++ .../{ => common}/site-watcher.xml | 0 .../site-watcher/common/spider-list.xml | 28 ++++++++ .../{ => common}/update-notify.xml | 0 extra/webapps/site-watcher/main.xml | 7 -- extra/webapps/site-watcher/site-list.xml | 32 --------- .../webapps/site-watcher/site-watcher.factor | 72 ++++--------------- .../site-watcher/spidering/authors.txt | 1 + .../site-watcher/spidering/spidering.factor | 52 ++++++++++++++ .../webapps/site-watcher/watching/authors.txt | 1 + .../site-watcher/watching/watching.factor | 52 ++++++++++++++ 18 files changed, 234 insertions(+), 118 deletions(-) create mode 100644 extra/webapps/site-watcher/common/authors.txt create mode 100644 extra/webapps/site-watcher/common/common.factor create mode 100644 extra/webapps/site-watcher/common/main.xml create mode 100644 extra/webapps/site-watcher/common/site-list.xml rename extra/webapps/site-watcher/{ => common}/site-watcher.xml (100%) create mode 100644 extra/webapps/site-watcher/common/spider-list.xml rename extra/webapps/site-watcher/{ => common}/update-notify.xml (100%) delete mode 100644 extra/webapps/site-watcher/main.xml delete mode 100644 extra/webapps/site-watcher/site-list.xml create mode 100644 extra/webapps/site-watcher/spidering/authors.txt create mode 100644 extra/webapps/site-watcher/spidering/spidering.factor create mode 100644 extra/webapps/site-watcher/watching/authors.txt create mode 100644 extra/webapps/site-watcher/watching/watching.factor diff --git a/extra/site-watcher/db/db.factor b/extra/site-watcher/db/db.factor index 26d05441f3..003b6bb58b 100644 --- a/extra/site-watcher/db/db.factor +++ b/extra/site-watcher/db/db.factor @@ -2,10 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors continuations db db.sqlite db.tuples db.types io.directories io.files.temp kernel io.streams.string calendar -debugger combinators.smart sequences ; +debugger combinators.smart sequences arrays ; IN: site-watcher.db -TUPLE: account account-id account-name email twitter sms ; +TUPLE: account account-name email twitter sms ; : ( account-name email -- account ) account new @@ -25,6 +25,12 @@ TUPLE: site site-id url up? changed? last-up error last-error ; site new swap >>url ; +: site-with-url ( url -- site ) + select-tuple ; + +: site-with-id ( id -- site ) + site new swap >>site-id select-tuple ; + site "SITE" { { "site-id" "SITE_ID" INTEGER +db-assigned-id+ } { "url" "URL" VARCHAR } @@ -49,10 +55,12 @@ watching-site "WATCHING_SITE" { TUPLE: spidering-site < watching-site max-depth max-count ; +C: spidering-site + SLOT: site M: watching-site site>> - site-id>> site new swap >>site-id select-tuple ; + site-id>> site-with-id ; SLOT: account @@ -60,12 +68,25 @@ M: watching-site account>> account-name>> account new swap >>account-name select-tuple ; spidering-site "SPIDERING_SITE" { - { "account-name" "ACCOUNT_NAME" VARCHAR +user-assigned-id+ } - { "site-id" "SITE_ID" INTEGER +user-assigned-id+ } { "max-depth" "MAX_DEPTH" INTEGER } { "max-count" "MAX_COUNT" INTEGER } } define-persistent +: spidering-sites ( username -- sites ) + spidering-site new swap >>account-name select-tuples ; + +: insert-site ( url -- site ) + dup select-tuple [ ] [ dup t >>up? insert-tuple ] ?if ; + +: select-account/site ( username url -- account site ) + insert-site site-id>> ; + +: add-spidered-site ( username url -- ) + select-account/site 10 10 insert-tuple ; + +: remove-spidered-site ( username url -- ) + select-account/site 10 10 delete-tuples ; + TUPLE: reporting-site site-id email url up? changed? last-up? error last-error ; : set-notify-site-watchers ( site new-up? -- site ) @@ -89,16 +110,10 @@ TUPLE: reporting-site site-id email url up? changed? last-up? error last-error ; [ [ reporting-site boa ] input dup select-tuple [ ] [ dup t >>up? insert-tuple ] ?if ; - : insert-account ( account-name email -- ) insert-tuple ; : find-sites ( -- seq ) f select-tuples ; -: select-account/site ( username url -- account site ) - insert-site site-id>> ; - : watch-site ( username url -- ) select-account/site insert-tuple ; diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index c2ec2ada79..535c8cd626 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -38,12 +38,12 @@ SYMBOL: running-site-watcher PRIVATE> -: watch-sites ( db -- ) - [ find-sites check-sites sites-to-report send-reports ] with-db ; +: watch-sites ( -- ) + find-sites check-sites sites-to-report send-reports ; : run-site-watcher ( db -- ) [ running-site-watcher get ] dip '[ - [ _ watch-sites ] site-watcher-frequency get every + [ _ [ watch-sites ] with-db ] site-watcher-frequency get every running-site-watcher set ] unless ; diff --git a/extra/site-watcher/spider/spider.factor b/extra/site-watcher/spider/spider.factor index 1b3a96a018..335f1f11f9 100644 --- a/extra/site-watcher/spider/spider.factor +++ b/extra/site-watcher/spider/spider.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: site-watcher.db site-watcher.email +USING: site-watcher.db site-watcher.email site-watcher.spider spider spider.report accessors kernel sequences -xml.writer ; +xml.writer concurrency.combinators ; IN: site-watcher.spider : ( spidering-site -- spider ) @@ -20,3 +20,6 @@ IN: site-watcher.spider [ run-spider spider-report xml>string ] [ site>> url>> "Spidered " prefix ] tri send-site-email ; + +: spider-sites ( -- ) + f spidering-sites [ spider-and-email ] parallel-each ; \ No newline at end of file diff --git a/extra/spider/report/report.factor b/extra/spider/report/report.factor index 48620cac55..7779b233f9 100644 --- a/extra/spider/report/report.factor +++ b/extra/spider/report/report.factor @@ -39,10 +39,11 @@ SYMBOL: time-std timings get sort-values [ slowest short tail* reverse slowest-pages set ] [ - values - [ mean 1000000 /f mean-time set ] - [ median 1000000 /f median-time set ] - [ std 1000000 /f time-std set ] tri + values [ + [ mean 1000000 /f mean-time set ] + [ median 1000000 /f median-time set ] + [ std 1000000 /f time-std set ] tri + ] unless-empty ] bi ; : process-results ( results -- ) diff --git a/extra/webapps/site-watcher/common/authors.txt b/extra/webapps/site-watcher/common/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/webapps/site-watcher/common/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/webapps/site-watcher/common/common.factor b/extra/webapps/site-watcher/common/common.factor new file mode 100644 index 0000000000..b27cbf3f7f --- /dev/null +++ b/extra/webapps/site-watcher/common/common.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: http.server.dispatchers ; +IN: webapps.site-watcher.common + +TUPLE: site-watcher-app < dispatcher ; diff --git a/extra/webapps/site-watcher/common/main.xml b/extra/webapps/site-watcher/common/main.xml new file mode 100644 index 0000000000..35a0ccb6d1 --- /dev/null +++ b/extra/webapps/site-watcher/common/main.xml @@ -0,0 +1,13 @@ + + + + +

SiteWatcher is a free service for web masters. It periodically tries fetching your web site via HTTP, and sends you an e-mail, SMS or Tweet if this fails. Sign up now!

+ +
    +
  • Your contact info
    • +
  • Watched sites
    • +
  • Spidered sites
    • +
+ + diff --git a/extra/webapps/site-watcher/common/site-list.xml b/extra/webapps/site-watcher/common/site-list.xml new file mode 100644 index 0000000000..765381a4c4 --- /dev/null +++ b/extra/webapps/site-watcher/common/site-list.xml @@ -0,0 +1,28 @@ + + + + +

Add some sites to watch

+ + +
+ +
URL:
+ + +

Keep track of your sites

+ + + + + + + + + +
URL
Remove
+

+ Check now +

+ + diff --git a/extra/webapps/site-watcher/site-watcher.xml b/extra/webapps/site-watcher/common/site-watcher.xml similarity index 100% rename from extra/webapps/site-watcher/site-watcher.xml rename to extra/webapps/site-watcher/common/site-watcher.xml diff --git a/extra/webapps/site-watcher/common/spider-list.xml b/extra/webapps/site-watcher/common/spider-list.xml new file mode 100644 index 0000000000..89d191ab41 --- /dev/null +++ b/extra/webapps/site-watcher/common/spider-list.xml @@ -0,0 +1,28 @@ + + + + +

Add a site to spider

+ + + + +
URL:
+ + +

Spidered sites

+ + + + + + + + + +
URL
Remove
+

+ Spider now +

+ + diff --git a/extra/webapps/site-watcher/update-notify.xml b/extra/webapps/site-watcher/common/update-notify.xml similarity index 100% rename from extra/webapps/site-watcher/update-notify.xml rename to extra/webapps/site-watcher/common/update-notify.xml diff --git a/extra/webapps/site-watcher/main.xml b/extra/webapps/site-watcher/main.xml deleted file mode 100644 index 938ff09825..0000000000 --- a/extra/webapps/site-watcher/main.xml +++ /dev/null @@ -1,7 +0,0 @@ - - - - -

SiteWatcher is a free service for web masters. It periodically tries fetching your web site via HTTP, and sends you an e-mail, SMS or Tweet if this fails. Sign up now!

- - diff --git a/extra/webapps/site-watcher/site-list.xml b/extra/webapps/site-watcher/site-list.xml deleted file mode 100644 index c96a25f443..0000000000 --- a/extra/webapps/site-watcher/site-list.xml +++ /dev/null @@ -1,32 +0,0 @@ - - - - -

Don't you hate it when your web site goes down, and all your users go buy that slanket from your competitor instead. Now using SiteWatcher, you can ensure this will never happen again!

- -Contact info - -

Step 2: add some sites to watch

- - - - -
URL:
- - -

Step 3: keep track of your sites

- - - - - - - - - -
URL
Remove
-

- Check now -

- - diff --git a/extra/webapps/site-watcher/site-watcher.factor b/extra/webapps/site-watcher/site-watcher.factor index f173edb814..7651afa4e6 100644 --- a/extra/webapps/site-watcher/site-watcher.factor +++ b/extra/webapps/site-watcher/site-watcher.factor @@ -8,65 +8,14 @@ furnace.auth.features.registration furnace.auth.login furnace.boilerplate furnace.redirection html.forms http.server http.server.dispatchers kernel namespaces site-watcher site-watcher.db site-watcher.private urls validators io.sockets.secure.unix.debug -io.servers.connection db db.tuples sequences ; +io.servers.connection db db.tuples sequences webapps.site-watcher.common +webapps.site-watcher.watching webapps.site-watcher.spidering ; QUALIFIED: assocs IN: webapps.site-watcher -TUPLE: site-watcher-app < dispatcher ; - -CONSTANT: site-list-url URL" $site-watcher-app/" - : ( -- action ) - [ - logged-in? - [ URL" $site-watcher-app/list" ] - [ { site-watcher-app "main" } ] if - ] >>display ; - -: ( -- action ) - - { site-watcher-app "site-list" } >>template - [ - ! Silly query - username watching-sites - "sites" set-value - ] >>init - - "list watched sites" >>description ; - -: ( -- action ) - - [ - { { "url" [ v-url ] } } validate-params - ] >>validate - [ - username "url" value watch-site - site-list-url - ] >>submit - - "add a watched site" >>description ; - -: ( -- action ) - - [ - { { "url" [ v-url ] } } validate-params - ] >>validate - [ - username "url" value unwatch-site - site-list-url - ] >>submit - - "remove a watched site" >>description ; - -: ( -- action ) - - [ - watch-sites - site-list-url - ] >>submit - - "check watched sites" >>description ; + { site-watcher-app "main" } >>template ; : ( -- action ) @@ -95,10 +44,14 @@ CONSTANT: site-list-url URL" $site-watcher-app/" : ( -- dispatcher ) site-watcher-app new-dispatcher "" add-responder - "list" add-responder - "add" add-responder - "remove" add-responder + "watch-list" add-responder + "add-watch" add-responder + "remove-watch" add-responder "check" add-responder + "spider-list" add-responder + "add-spider" add-responder + "remove-spider" add-responder + "spider" add-responder "update-notify" add-responder ; : ( responder -- responder' ) @@ -125,12 +78,13 @@ site-watcher-db main-responder set-global M: site-watcher-app init-user-profile - drop + drop B "username" value "email" value insert-tuple ; : init-db ( -- ) site-watcher-db [ - { site account watching-site } [ ensure-table ] each + { site account watching-site spidering-site } + [ ensure-table ] each ] with-db ; : start-site-watcher ( -- ) diff --git a/extra/webapps/site-watcher/spidering/authors.txt b/extra/webapps/site-watcher/spidering/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/webapps/site-watcher/spidering/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/webapps/site-watcher/spidering/spidering.factor b/extra/webapps/site-watcher/spidering/spidering.factor new file mode 100644 index 0000000000..d0116a7f2d --- /dev/null +++ b/extra/webapps/site-watcher/spidering/spidering.factor @@ -0,0 +1,52 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors furnace.actions furnace.auth +furnace.redirection html.forms validators webapps.site-watcher.common +site-watcher.db site-watcher.spider kernel urls sequences ; +IN: webapps.site-watcher.spidering + +CONSTANT: site-list-url URL" $site-watcher-app/spider-list" + +: ( -- action ) + + { site-watcher-app "spider-list" } >>template + [ + ! Silly query + username B spidering-sites [ site>> ] map + "sites" set-value + ] >>init + + "list spidered sites" >>description ; + +: ( -- action ) + + [ + { { "url" [ v-url ] } } validate-params + ] >>validate + [ + username "url" value add-spidered-site + site-list-url + ] >>submit + + "add a spidered site" >>description ; + +: ( -- action ) + + [ + { { "url" [ v-url ] } } validate-params + ] >>validate + [ + username "url" value remove-spidered-site + site-list-url + ] >>submit + + "remove a spidered site" >>description ; + +: ( -- action ) + + [ + spider-sites + site-list-url + ] >>submit + + "spider sites" >>description ; \ No newline at end of file diff --git a/extra/webapps/site-watcher/watching/authors.txt b/extra/webapps/site-watcher/watching/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/webapps/site-watcher/watching/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/webapps/site-watcher/watching/watching.factor b/extra/webapps/site-watcher/watching/watching.factor new file mode 100644 index 0000000000..414595a12a --- /dev/null +++ b/extra/webapps/site-watcher/watching/watching.factor @@ -0,0 +1,52 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors furnace.actions furnace.auth +furnace.redirection html.forms site-watcher site-watcher.db +validators webapps.site-watcher.common urls ; +IN: webapps.site-watcher.watching + +CONSTANT: site-list-url URL" $site-watcher-app/watch-list" + +: ( -- action ) + + { site-watcher-app "site-list" } >>template + [ + ! Silly query + username watching-sites + "sites" set-value + ] >>init + + "list watched sites" >>description ; + +: ( -- action ) + + [ + { { "url" [ v-url ] } } validate-params + ] >>validate + [ + username "url" value watch-site + site-list-url + ] >>submit + + "add a watched site" >>description ; + +: ( -- action ) + + [ + { { "url" [ v-url ] } } validate-params + ] >>validate + [ + username "url" value unwatch-site + site-list-url + ] >>submit + + "remove a watched site" >>description ; + +: ( -- action ) + + [ + watch-sites + site-list-url + ] >>submit + + "check watched sites" >>description ; \ No newline at end of file From 959e659cdc67daff6b64e53bc2a94873c5b90e76 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 21:59:52 -0500 Subject: [PATCH 130/772] Makefile: clean target should delete libfactor.dylib too --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 5e63017218..35a5ba58bf 100644 --- a/Makefile +++ b/Makefile @@ -166,7 +166,7 @@ factor-ffi-test: vm/ffi_test.o clean: rm -f vm/*.o - rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} + rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib vm/resources.o: $(WINDRES) vm/factor.rs vm/resources.o From 2e03bd5cc0d7ef52fc8ff5aa93e1bbac8c1651bd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 22:00:08 -0500 Subject: [PATCH 131/772] db.errors.sqlite: don't give up on bad inputs --- basis/db/errors/sqlite/sqlite.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/db/errors/sqlite/sqlite.factor b/basis/db/errors/sqlite/sqlite.factor index c247a36257..c73409b850 100644 --- a/basis/db/errors/sqlite/sqlite.factor +++ b/basis/db/errors/sqlite/sqlite.factor @@ -4,7 +4,8 @@ USING: accessors combinators db kernel sequences peg.ebnf strings db.errors ; IN: db.errors.sqlite -ERROR: unparsed-sqlite-error error ; +TUPLE: unparsed-sqlite-error error ; +C: unparsed-sqlite-error SINGLETONS: table-exists table-missing ; @@ -22,4 +23,6 @@ SqliteError = => [[ table >string message sqlite-table-error ]] | "no such table: " .+:table => [[ table >string ]] + | .*:error + => [[ error >string ]] ;EBNF From 6f53db568fcf0b25d40e97c0d332eea927084e5a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 22:00:18 -0500 Subject: [PATCH 132/772] furnace.redirection: load urls.secure --- basis/furnace/redirection/redirection.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/furnace/redirection/redirection.factor b/basis/furnace/redirection/redirection.factor index 01297288dc..ff81d73f7f 100644 --- a/basis/furnace/redirection/redirection.factor +++ b/basis/furnace/redirection/redirection.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors combinators namespaces fry urls http -http.server http.server.redirection http.server.responses +USING: kernel accessors combinators namespaces fry urls urls.secure +http http.server http.server.redirection http.server.responses http.server.remapping http.server.filters furnace.utilities ; IN: furnace.redirection From cb675cfe477c456d5bac689dd0f0c43204f69629 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 22:05:17 -0500 Subject: [PATCH 133/772] furnace.actions: load chloe tags --- basis/furnace/actions/actions.factor | 1 + basis/furnace/furnace.factor | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index a582755dc4..c7893117d1 100644 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -9,6 +9,7 @@ http.server.responses furnace.utilities furnace.redirection furnace.conversations +furnace.chloe-tags html.forms html.components html.components diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor index adafb21524..37b2f40e82 100644 --- a/basis/furnace/furnace.factor +++ b/basis/furnace/furnace.factor @@ -17,7 +17,6 @@ USE: vocabs.loader "furnace.auth.providers.db" require "furnace.auth.providers.null" require "furnace.boilerplate" require -"furnace.chloe-tags" require "furnace.conversations" require "furnace.db" require "furnace.json" require From 1032e57e8e79781d97de4634f7a7bad0b3574fda Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 23:32:21 -0500 Subject: [PATCH 134/772] Fix bootstrap --- basis/delegate/protocols/protocols.factor | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/basis/delegate/protocols/protocols.factor b/basis/delegate/protocols/protocols.factor index f568a3e388..40054bc4b0 100644 --- a/basis/delegate/protocols/protocols.factor +++ b/basis/delegate/protocols/protocols.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: delegate sequences.private sequences assocs -io definitions kernel continuations ; +USING: delegate sequences.private sequences assocs io ; IN: delegate.protocols PROTOCOL: sequence-protocol @@ -19,7 +18,3 @@ stream-read-until ; PROTOCOL: output-stream-protocol stream-flush stream-write1 stream-write stream-nl ; - -PROTOCOL: definition-protocol -where set-where forget uses -synopsis* definer definition ; From 5b5acf165cf65c1e7964472c51abff01aa0bc611 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Apr 2009 03:04:25 -0500 Subject: [PATCH 135/772] Fix site-watcher tests --- extra/site-watcher/site-watcher-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/site-watcher/site-watcher-tests.factor b/extra/site-watcher/site-watcher-tests.factor index b067504e2e..e58d5a79d5 100644 --- a/extra/site-watcher/site-watcher-tests.factor +++ b/extra/site-watcher/site-watcher-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: db.tuples locals site-watcher site-watcher.db site-watcher.private kernel db io.directories io.files.temp -continuations site-watcher.db.private db.sqlite +continuations db.sqlite sequences tools.test ; IN: site-watcher.tests From 2c1f7b9293ade5d1c16ebe8b3534238bfe026f43 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Apr 2009 03:37:29 -0500 Subject: [PATCH 136/772] Static responder now works when the root is a file rather than a directory --- basis/http/http-tests.factor | 23 ++++++++++++++++++----- basis/http/server/static/static.factor | 4 ++-- 2 files changed, 20 insertions(+), 7 deletions(-) diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index bc906fad44..52763c4f18 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -1,8 +1,8 @@ -USING: http http.server http.client http.client.private tools.test multiline -io.streams.string io.encodings.utf8 io.encodings.8-bit -io.encodings.binary io.encodings.string kernel arrays splitting -sequences assocs io.sockets db db.sqlite continuations urls -hashtables accessors namespaces xml.data ; +USING: http http.server http.client http.client.private tools.test +multiline io.streams.string io.encodings.utf8 io.encodings.8-bit +io.encodings.binary io.encodings.string io.encodings.ascii kernel +arrays splitting sequences assocs io.sockets db db.sqlite +continuations urls hashtables accessors namespaces xml.data ; IN: http.tests [ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test @@ -359,4 +359,17 @@ SYMBOL: a ! Test basic auth [ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test +! Test a corner case with static responder +[ ] [ + + add-quit-action + "vocab:http/test/foo.html" >>default + test-httpd +] unit-test +[ t ] [ + "http://localhost/" add-port http-get nip + "vocab:http/test/foo.html" ascii file-contents = +] unit-test + +[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test \ No newline at end of file diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index bbca70d845..f80a3cc7cd 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -47,8 +47,8 @@ TUPLE: file-responder root hook special allow-listings ; if ; : serving-path ( filename -- filename ) - [ file-responder get root>> trim-tail-separators "/" ] dip - "" or trim-head-separators 3append ; + [ file-responder get root>> trim-tail-separators ] dip + [ "/" swap trim-head-separators 3append ] unless-empty ; : serve-file ( filename -- response ) dup mime-type From e12f0f22807b7ee7df0575b41655834d5574be05 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Apr 2009 04:11:56 -0500 Subject: [PATCH 137/772] Treat a limit of f as unlimited instead of throwing an error --- basis/io/streams/limited/limited-tests.factor | 6 ++++++ basis/io/streams/limited/limited.factor | 8 +++++--- 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/basis/io/streams/limited/limited-tests.factor b/basis/io/streams/limited/limited-tests.factor index 36c257fb5e..86d652d17c 100644 --- a/basis/io/streams/limited/limited-tests.factor +++ b/basis/io/streams/limited/limited-tests.factor @@ -76,3 +76,9 @@ IN: io.streams.limited.tests [ decoder? ] both? ] with-destructors ] unit-test + +[ "HELL" ] [ + "HELLO" + [ f stream-throws limit-input 4 read ] + with-string-reader +] unit-test \ No newline at end of file diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index fe3dd9ad93..b1b07a08c0 100755 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -22,7 +22,7 @@ M: decoder limit ( stream limit mode -- stream' ) [ clone ] 2dip '[ _ _ limit ] change-stream ; M: object limit ( stream limit mode -- stream' ) - ; + over [ ] [ 2drop ] if ; GENERIC: unlimited ( stream -- stream' ) @@ -32,9 +32,11 @@ M: decoder unlimited ( stream -- stream' ) M: object unlimited ( stream -- stream' ) stream>> stream>> ; -: limit-input ( limit mode -- ) input-stream [ -rot limit ] change ; +: limit-input ( limit mode -- ) + [ input-stream ] 2dip '[ _ _ limit ] change ; -: unlimited-input ( -- ) input-stream [ unlimited ] change ; +: unlimited-input ( -- ) + input-stream [ unlimited ] change ; : with-unlimited-stream ( stream quot -- ) [ clone unlimited ] dip call ; inline From 63cf5b04e13570737f8e92e8b5a732bedd41831e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Apr 2009 04:19:21 -0500 Subject: [PATCH 138/772] http.client: fix 307 redirect behavior (reported by Chris Double) --- basis/http/client/client.factor | 9 +++++---- basis/http/http-tests.factor | 20 ++++++++++++++++++++ 2 files changed, 25 insertions(+), 4 deletions(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 4099e3d84c..805929d27b 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -6,7 +6,7 @@ math.order hashtables byte-arrays destructors io io.sockets io.streams.string io.files io.timeouts io.pathnames io.encodings io.encodings.string io.encodings.ascii io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.crlf -io.streams.duplex fry ascii urls urls.encoding present +io.streams.duplex fry ascii urls urls.encoding present locals http http.parsers http.client.post-data ; IN: http.client @@ -77,12 +77,13 @@ SYMBOL: redirects : redirect? ( response -- ? ) code>> 300 399 between? ; -: do-redirect ( quot: ( chunk -- ) response -- response ) +:: do-redirect ( quot: ( chunk -- ) response -- response ) redirects inc redirects get max-redirects < [ request get clone - swap "location" header redirect-url - "GET" >>method swap (with-http-request) + response "location" header redirect-url + response code>> 307 = [ "GET" >>method ] unless + quot (with-http-request) ] [ too-many-redirects ] if ; inline recursive : read-chunk-size ( -- n ) diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 52763c4f18..da50a6f85f 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -372,4 +372,24 @@ SYMBOL: a "vocab:http/test/foo.html" ascii file-contents = ] unit-test +[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test + +! Check behavior of 307 redirect (reported by Chris Double) +[ ] [ + + add-quit-action + + [ "b" ] >>submit + "a" add-responder + + [ + request get post-data>> data>> "data" = + [ "OK" "text/plain" ] [ "OOPS" throw ] if + ] >>submit + "b" add-responder + test-httpd +] unit-test + +[ "OK" ] [ "data" "http://localhost/a" add-port http-post nip ] unit-test + [ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test \ No newline at end of file From 65802b6aaa7e9a1e251e0f363958bbe410af2c73 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 7 Apr 2009 10:08:01 -0500 Subject: [PATCH 139/772] fix unit test in robots --- extra/robots/robots-tests.factor | 645 ++++++++++++++++--------------- extra/robots/robots.factor | 2 +- 2 files changed, 324 insertions(+), 323 deletions(-) diff --git a/extra/robots/robots-tests.factor b/extra/robots/robots-tests.factor index a590d9eee0..54b4892680 100644 --- a/extra/robots/robots-tests.factor +++ b/extra/robots/robots-tests.factor @@ -1,334 +1,335 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: calendar io.encodings.utf8 io.files robots tools.test ; +USING: calendar io.encodings.utf8 io.files robots tools.test +urls ; IN: robots.tests [ -{ "http://www.chiplist.com/sitemap.txt" } -{ - T{ rules - { user-agents V{ "*" } } - { allows V{ } } - { disallows - V{ - "/cgi-bin/" - "/scripts/" - "/ChipList2/scripts/" - "/ChipList2/styles/" - "/ads/" - "/ChipList2/ads/" - "/advertisements/" - "/ChipList2/advertisements/" - "/graphics/" - "/ChipList2/graphics/" + { "http://www.chiplist.com/sitemap.txt" } + { + T{ rules + { user-agents V{ "*" } } + { allows V{ } } + { disallows + V{ + URL" /cgi-bin/" + URL" /scripts/" + URL" /ChipList2/scripts/" + URL" /ChipList2/styles/" + URL" /ads/" + URL" /ChipList2/ads/" + URL" /advertisements/" + URL" /ChipList2/advertisements/" + URL" /graphics/" + URL" /ChipList2/graphics/" + } } - } - { visit-time - { - T{ timestamp { hour 2 } } - T{ timestamp { hour 5 } } + { visit-time + { + T{ timestamp { hour 2 } } + T{ timestamp { hour 5 } } + } } + { request-rate 1 } + { crawl-delay 1 } + { unknowns H{ } } } - { request-rate 1 } - { crawl-delay 1 } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "UbiCrawler" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "DOC" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "Zao" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "sitecheck.internetseer.com" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "Zealbot" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "MSIECrawler" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "SiteSnagger" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "WebStripper" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "WebCopier" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "Fetch" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "Offline Explorer" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "Teleport" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "TeleportPro" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "WebZIP" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "linko" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "HTTrack" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "Microsoft.URL.Control" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "Xenu" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "larbin" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "libwww" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "ZyBORG" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "Download Ninja" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "wget" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "grub-client" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "k2spider" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "NPBot" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents V{ "WebReaper" } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } - } - T{ rules - { user-agents - V{ - "abot" - "ALeadSoftbot" - "BeijingCrawler" - "BilgiBot" - "bot" - "botlist" - "BOTW Spider" - "bumblebee" - "Bumblebee" - "BuzzRankingBot" - "Charlotte" - "Clushbot" - "Crawler" - "CydralSpider" - "DataFountains" - "DiamondBot" - "Dulance bot" - "DYNAMIC" - "EARTHCOM.info" - "EDI" - "envolk" - "Exabot" - "Exabot-Images" - "Exabot-Test" - "exactseek-pagereaper" - "Exalead NG" - "FANGCrawl" - "Feed::Find" - "flatlandbot" - "Gigabot" - "GigabotSiteSearch" - "GurujiBot" - "Hatena Antenna" - "Hatena Bookmark" - "Hatena RSS" - "HatenaScreenshot" - "Helix" - "HiddenMarket" - "HyperEstraier" - "iaskspider" - "IIITBOT" - "InfociousBot" - "iVia" - "iVia Page Fetcher" - "Jetbot" - "Kolinka Forum Search" - "KRetrieve" - "LetsCrawl.com" - "Lincoln State Web Browser" - "Links4US-Crawler" - "LOOQ" - "Lsearch/sondeur" - "MapoftheInternet.com" - "NationalDirectory" - "NetCarta_WebMapper" - "NewsGator" - "NextGenSearchBot" - "ng" - "nicebot" - "NP" - "NPBot" - "Nudelsalat" - "Nutch" - "OmniExplorer_Bot" - "OpenIntelligenceData" - "Oracle Enterprise Search" - "Pajaczek" - "panscient.com" - "PeerFactor 404 crawler" - "PeerFactor Crawler" - "PlantyNet" - "PlantyNet_WebRobot" - "plinki" - "PMAFind" - "Pogodak!" - "QuickFinder Crawler" - "Radiation Retriever" - "Reaper" - "RedCarpet" - "ScorpionBot" - "Scrubby" - "Scumbot" - "searchbot" - "Seeker.lookseek.com" - "SeznamBot" - "ShowXML" - "snap.com" - "snap.com beta crawler" - "Snapbot" - "SnapPreviewBot" - "sohu" - "SpankBot" - "Speedy Spider" - "Speedy_Spider" - "SpeedySpider" - "spider" - "SquigglebotBot" - "SurveyBot" - "SynapticSearch" - "T-H-U-N-D-E-R-S-T-O-N-E" - "Talkro Web-Shot" - "Tarantula" - "TerrawizBot" - "TheInformant" - "TMCrawler" - "TridentSpider" - "Tutorial Crawler" - "Twiceler" - "unwrapbot" - "URI::Fetch" - "VengaBot" - "Vonna.com b o t" - "Vortex" - "Votay bot" - "WebAlta Crawler" - "Webbot" - "Webclipping.com" - "WebCorp" - "Webinator" - "WIRE" - "WISEbot" - "Xerka WebBot" - "XSpider" - "YodaoBot" - "Yoono" - "yoono" + T{ rules + { user-agents V{ "UbiCrawler" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "DOC" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "Zao" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "sitecheck.internetseer.com" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "Zealbot" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "MSIECrawler" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "SiteSnagger" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "WebStripper" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "WebCopier" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "Fetch" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "Offline Explorer" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "Teleport" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "TeleportPro" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "WebZIP" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "linko" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "HTTrack" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "Microsoft.URL.Control" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "Xenu" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "larbin" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "libwww" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "ZyBORG" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "Download Ninja" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "wget" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "grub-client" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "k2spider" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "NPBot" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents V{ "WebReaper" } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } + } + T{ rules + { user-agents + V{ + "abot" + "ALeadSoftbot" + "BeijingCrawler" + "BilgiBot" + "bot" + "botlist" + "BOTW Spider" + "bumblebee" + "Bumblebee" + "BuzzRankingBot" + "Charlotte" + "Clushbot" + "Crawler" + "CydralSpider" + "DataFountains" + "DiamondBot" + "Dulance bot" + "DYNAMIC" + "EARTHCOM.info" + "EDI" + "envolk" + "Exabot" + "Exabot-Images" + "Exabot-Test" + "exactseek-pagereaper" + "Exalead NG" + "FANGCrawl" + "Feed::Find" + "flatlandbot" + "Gigabot" + "GigabotSiteSearch" + "GurujiBot" + "Hatena Antenna" + "Hatena Bookmark" + "Hatena RSS" + "HatenaScreenshot" + "Helix" + "HiddenMarket" + "HyperEstraier" + "iaskspider" + "IIITBOT" + "InfociousBot" + "iVia" + "iVia Page Fetcher" + "Jetbot" + "Kolinka Forum Search" + "KRetrieve" + "LetsCrawl.com" + "Lincoln State Web Browser" + "Links4US-Crawler" + "LOOQ" + "Lsearch/sondeur" + "MapoftheInternet.com" + "NationalDirectory" + "NetCarta_WebMapper" + "NewsGator" + "NextGenSearchBot" + "ng" + "nicebot" + "NP" + "NPBot" + "Nudelsalat" + "Nutch" + "OmniExplorer_Bot" + "OpenIntelligenceData" + "Oracle Enterprise Search" + "Pajaczek" + "panscient.com" + "PeerFactor 404 crawler" + "PeerFactor Crawler" + "PlantyNet" + "PlantyNet_WebRobot" + "plinki" + "PMAFind" + "Pogodak!" + "QuickFinder Crawler" + "Radiation Retriever" + "Reaper" + "RedCarpet" + "ScorpionBot" + "Scrubby" + "Scumbot" + "searchbot" + "Seeker.lookseek.com" + "SeznamBot" + "ShowXML" + "snap.com" + "snap.com beta crawler" + "Snapbot" + "SnapPreviewBot" + "sohu" + "SpankBot" + "Speedy Spider" + "Speedy_Spider" + "SpeedySpider" + "spider" + "SquigglebotBot" + "SurveyBot" + "SynapticSearch" + "T-H-U-N-D-E-R-S-T-O-N-E" + "Talkro Web-Shot" + "Tarantula" + "TerrawizBot" + "TheInformant" + "TMCrawler" + "TridentSpider" + "Tutorial Crawler" + "Twiceler" + "unwrapbot" + "URI::Fetch" + "VengaBot" + "Vonna.com b o t" + "Vortex" + "Votay bot" + "WebAlta Crawler" + "Webbot" + "Webclipping.com" + "WebCorp" + "Webinator" + "WIRE" + "WISEbot" + "Xerka WebBot" + "XSpider" + "YodaoBot" + "Yoono" + "yoono" + } } + { allows V{ } } + { disallows V{ URL" /" } } + { unknowns H{ } } } - { allows V{ } } - { disallows V{ "/" } } - { unknowns H{ } } } -} ] [ "vocab:robots/robots.txt" utf8 file-contents parse-robots.txt ] unit-test diff --git a/extra/robots/robots.factor b/extra/robots/robots.factor index 242aa1dea2..3c0eb045f7 100644 --- a/extra/robots/robots.factor +++ b/extra/robots/robots.factor @@ -85,7 +85,7 @@ PRIVATE> : parse-robots.txt ( string -- sitemaps rules-seq ) normalize-robots.txt [ [ dup ] dip [ parse-robots.txt-line drop ] with each - ] map first ; + ] map ; : robots ( url -- robots ) >url From 7a9c0ce069a8d6a53fe81d52907cc838679e2550 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 7 Apr 2009 16:55:00 -0400 Subject: [PATCH 140/772] Solution to Project Euler problem 58 --- extra/project-euler/058/058-tests.factor | 3 ++ extra/project-euler/058/058.factor | 68 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 15 +++--- 3 files changed, 79 insertions(+), 7 deletions(-) create mode 100644 extra/project-euler/058/058-tests.factor create mode 100644 extra/project-euler/058/058.factor diff --git a/extra/project-euler/058/058-tests.factor b/extra/project-euler/058/058-tests.factor new file mode 100644 index 0000000000..13a2aafa94 --- /dev/null +++ b/extra/project-euler/058/058-tests.factor @@ -0,0 +1,3 @@ +USING: project-euler.058 tools.test ; + +{ 26241 } [ euler058 ] unit-test diff --git a/extra/project-euler/058/058.factor b/extra/project-euler/058/058.factor new file mode 100644 index 0000000000..133175f2a8 --- /dev/null +++ b/extra/project-euler/058/058.factor @@ -0,0 +1,68 @@ +! Copyright (c) 2009 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: fry kernel math math.primes math.ranges project-euler.common sequences ; +IN: project-euler.058 + +! http://projecteuler.net/index.php?section=problems&id=58 + +! DESCRIPTION +! ----------- + +! Starting with 1 and solveling anticlockwise in the following way, a square +! solve with side length 7 is formed. + +! 37 36 35 34 33 32 31 +! 38 17 16 15 14 13 30 +! 39 18 5 4 3 12 29 +! 40 19 6 1 2 11 28 +! 41 20 7 8 9 10 27 +! 42 21 22 23 24 25 26 +! 43 44 45 46 47 48 49 + +! It is interesting to note that the odd squares lie along the bottom right +! diagonal, but what is more interesting is that 8 out of the 13 numbers lying +! along both diagonals are prime; that is, a ratio of 8/13 ≈ 62%. + +! If one complete new layer is wrapped around the solve above, a square solve +! with side length 9 will be formed. If this process is continued, what is the +! side length of the square solve for which the ratio of primes along both +! diagonals first falls below 10%? + + +! SOLUTION +! -------- + + + +: euler058 ( -- answer ) + 8 7 solve ; + +! [ euler058 ] 10 ave-time +! 12974 ms ave run time - 284.46 SD (10 trials) + +SOLUTION: euler058 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 62f6a56c65..d60ae60126 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -15,13 +15,14 @@ USING: definitions io io.files io.pathnames kernel math math.parser project-euler.041 project-euler.042 project-euler.043 project-euler.044 project-euler.045 project-euler.046 project-euler.047 project-euler.048 project-euler.049 project-euler.052 project-euler.053 project-euler.054 - project-euler.055 project-euler.056 project-euler.057 project-euler.059 - project-euler.067 project-euler.071 project-euler.073 project-euler.075 - project-euler.076 project-euler.079 project-euler.092 project-euler.097 - project-euler.099 project-euler.100 project-euler.116 project-euler.117 - project-euler.134 project-euler.148 project-euler.150 project-euler.151 - project-euler.164 project-euler.169 project-euler.173 project-euler.175 - project-euler.186 project-euler.190 project-euler.203 project-euler.215 ; + project-euler.055 project-euler.056 project-euler.057 project-euler.058 + project-euler.059 project-euler.067 project-euler.071 project-euler.073 + project-euler.075 project-euler.076 project-euler.079 project-euler.092 + project-euler.097 project-euler.099 project-euler.100 project-euler.116 + project-euler.117 project-euler.134 project-euler.148 project-euler.150 + project-euler.151 project-euler.164 project-euler.169 project-euler.173 + project-euler.175 project-euler.186 project-euler.190 project-euler.203 + project-euler.215 ; IN: project-euler Date: Tue, 7 Apr 2009 18:34:20 -0400 Subject: [PATCH 141/772] Add documentation for poker vocab --- extra/poker/poker-docs.factor | 30 ++++++++++++++++++++++++++++++ extra/poker/poker.factor | 32 ++++++++++++++++---------------- 2 files changed, 46 insertions(+), 16 deletions(-) create mode 100644 extra/poker/poker-docs.factor diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor new file mode 100644 index 0000000000..09019a29d7 --- /dev/null +++ b/extra/poker/poker-docs.factor @@ -0,0 +1,30 @@ +USING: help.markup help.syntax strings ; +IN: poker + +HELP: +{ $values { "str" string } { "hand" "a new hand" } } +{ $description "Creates a new poker hand containing the cards specified in " { $snippet "str" } "." } +{ $examples + { $example "USING: kernel math.order poker prettyprint ;" + "\"AC KC QC JC TC\" \"7C 6D 5H 4S 2C\" [ ] bi@ <=> ." "+lt+" } + { $example "USING: kernel poker prettyprint ;" + "\"TC 9C 8C 7C 6C\" \"TH 9H 8H 7H 6H\" [ ] bi@ = ." "t" } +} +{ $notes "Cards may be specified in any order. Hands are directly comparable to each other on the basis of their computed value. Two hands are considered equal when they would tie in a game (despite being composed of different cards)." } ; + +HELP: >cards +{ $values { "hand" "a hand" } { "str" string } } +{ $description "Outputs a string representation of a hand's cards." } +{ $examples + { $example "USING: poker prettyprint ;" + "\"AC KC QC JC TC\" >cards ." "\"AC KC QC JC TC\"" } +} ; + +HELP: >value +{ $values { "hand" "a hand" } { "str" string } } +{ $description "Outputs a string representation of a hand's value." } +{ $examples + { $example "USING: poker prettyprint ;" + "\"AC KC QC JC TC\" >value ." "\"Straight Flush\"" } +} +{ $notes "This should not be used as a basis for hand comparison." } ; diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index ca999dbf6e..2a7fe73762 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -155,6 +155,19 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" [ drop "S" ] } cond ; +: hand-rank ( hand -- rank ) + value>> { + { [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card + { [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair + { [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair + { [ dup 1609 > ] [ drop THREE_OF_A_KIND ] } ! 858 three-kind + { [ dup 1599 > ] [ drop STRAIGHT ] } ! 10 straights + { [ dup 322 > ] [ drop FLUSH ] } ! 1277 flushes + { [ dup 166 > ] [ drop FULL_HOUSE ] } ! 156 full house + { [ dup 10 > ] [ drop FOUR_OF_A_KIND ] } ! 156 four-kind + [ drop STRAIGHT_FLUSH ] ! 10 straight-flushes + } cond ; + PRIVATE> TUPLE: hand @@ -169,23 +182,10 @@ M: hand equal? " " split [ >ckf ] map dup hand-value hand boa ; -: hand-rank ( hand -- rank ) - value>> { - { [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card - { [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair - { [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair - { [ dup 1609 > ] [ drop THREE_OF_A_KIND ] } ! 858 three-kind - { [ dup 1599 > ] [ drop STRAIGHT ] } ! 10 straights - { [ dup 322 > ] [ drop FLUSH ] } ! 1277 flushes - { [ dup 166 > ] [ drop FULL_HOUSE ] } ! 156 full house - { [ dup 10 > ] [ drop FOUR_OF_A_KIND ] } ! 156 four-kind - [ drop STRAIGHT_FLUSH ] ! 10 straight-flushes - } cond ; - -: >value ( hand -- str ) - hand-rank VALUE_STR nth ; - : >cards ( hand -- str ) cards>> [ [ >card-rank ] [ >card-suit ] bi append ] map " " join ; + +: >value ( hand -- str ) + hand-rank VALUE_STR nth ; From 41e3e0acb4ab113be54fef6ec46593064cc99a22 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Apr 2009 18:49:54 -0500 Subject: [PATCH 142/772] Fix alien.fortran for NetBSD x86.64 --- basis/alien/fortran/fortran.factor | 7 ++++++- basis/math/blas/config/config.factor | 1 + 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 71efa1aa24..c617efc26c 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -8,7 +8,7 @@ io.encodings.ascii io.encodings.string shuffle effects math.ranges math.order sorting strings system alien.libraries ; IN: alien.fortran -SINGLETONS: f2c-abi gfortran-abi intel-unix-abi intel-windows-abi ; +SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ; << : add-f2c-libraries ( -- ) @@ -42,30 +42,35 @@ library-fortran-abis [ H{ } clone ] initialize HOOK: fortran-c-abi fortran-abi ( -- abi ) M: f2c-abi fortran-c-abi "cdecl" ; +M: g95-abi fortran-c-abi "cdecl" ; M: gfortran-abi fortran-c-abi "cdecl" ; M: intel-unix-abi fortran-c-abi "cdecl" ; M: intel-windows-abi fortran-c-abi "cdecl" ; HOOK: real-functions-return-double? fortran-abi ( -- ? ) M: f2c-abi real-functions-return-double? t ; +M: g95-abi real-functions-return-double? f ; M: gfortran-abi real-functions-return-double? f ; M: intel-unix-abi real-functions-return-double? f ; M: intel-windows-abi real-functions-return-double? f ; HOOK: complex-functions-return-by-value? fortran-abi ( -- ? ) M: f2c-abi complex-functions-return-by-value? f ; +M: g95-abi complex-functions-return-by-value? f ; M: gfortran-abi complex-functions-return-by-value? t ; M: intel-unix-abi complex-functions-return-by-value? f ; M: intel-windows-abi complex-functions-return-by-value? f ; HOOK: character(1)-maps-to-char? fortran-abi ( -- ? ) M: f2c-abi character(1)-maps-to-char? f ; +M: g95-abi character(1)-maps-to-char? f ; M: gfortran-abi character(1)-maps-to-char? f ; M: intel-unix-abi character(1)-maps-to-char? t ; M: intel-windows-abi character(1)-maps-to-char? t ; HOOK: mangle-name fortran-abi ( name -- name' ) M: f2c-abi mangle-name lowercase-name-with-extra-underscore ; +M: f95-abi mangle-name lowercase-name-with-extra-underscore ; M: gfortran-abi mangle-name lowercase-name-with-underscore ; M: intel-unix-abi mangle-name lowercase-name-with-underscore ; M: intel-windows-abi mangle-name >upper ; diff --git a/basis/math/blas/config/config.factor b/basis/math/blas/config/config.factor index 8ed515625d..327c546963 100644 --- a/basis/math/blas/config/config.factor +++ b/basis/math/blas/config/config.factor @@ -15,6 +15,7 @@ blas-fortran-abi [ { { [ os macosx? ] [ intel-unix-abi ] } { [ os windows? cpu x86.32? and ] [ f2c-abi ] } + { [ os netbsd? cpu x86.64? and ] [ g95-abi ] } { [ os windows? cpu x86.64? and ] [ gfortran-abi ] } { [ os freebsd? ] [ gfortran-abi ] } { [ os linux? cpu x86.32? and ] [ gfortran-abi ] } From 409b3317161159fe34e0a8e2f612d881bcd1e599 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Apr 2009 20:06:28 -0500 Subject: [PATCH 143/772] Fix typo --- basis/alien/fortran/fortran.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index c617efc26c..b27c62b9a1 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -70,7 +70,7 @@ M: intel-windows-abi character(1)-maps-to-char? t ; HOOK: mangle-name fortran-abi ( name -- name' ) M: f2c-abi mangle-name lowercase-name-with-extra-underscore ; -M: f95-abi mangle-name lowercase-name-with-extra-underscore ; +M: g95-abi mangle-name lowercase-name-with-extra-underscore ; M: gfortran-abi mangle-name lowercase-name-with-underscore ; M: intel-unix-abi mangle-name lowercase-name-with-underscore ; M: intel-windows-abi mangle-name >upper ; From e78476a51eeb95edad2ceeaadd62b07a4a872cc9 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 7 Apr 2009 21:36:38 -0400 Subject: [PATCH 144/772] Solution to Project Euler problem 63 --- extra/project-euler/063/063-tests.factor | 3 ++ extra/project-euler/063/063.factor | 37 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 14 ++++----- 3 files changed, 47 insertions(+), 7 deletions(-) create mode 100644 extra/project-euler/063/063-tests.factor create mode 100644 extra/project-euler/063/063.factor diff --git a/extra/project-euler/063/063-tests.factor b/extra/project-euler/063/063-tests.factor new file mode 100644 index 0000000000..0cff44db5e --- /dev/null +++ b/extra/project-euler/063/063-tests.factor @@ -0,0 +1,3 @@ +USING: project-euler.063 tools.test ; + +{ 49 } [ euler063 ] unit-test diff --git a/extra/project-euler/063/063.factor b/extra/project-euler/063/063.factor new file mode 100644 index 0000000000..80e3990a24 --- /dev/null +++ b/extra/project-euler/063/063.factor @@ -0,0 +1,37 @@ +! Copyright (c) 2009 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions math.ranges project-euler.common sequences ; +IN: project-euler.063 + +! http://projecteuler.net/index.php?section=problems&id=63 + +! DESCRIPTION +! ----------- + +! The 5-digit number, 16807 = 7^5, is also a fifth power. Similarly, the +! 9-digit number, 134217728 = 8^9, is a ninth power. + +! How many n-digit positive integers exist which are also an nth power? + + +! SOLUTION +! -------- + +! Only have to check from 1 to 9 because 10^n already has too many digits. +! In general, x^n has n digits when: + +! 10^(n-1) <= x^n < 10^n + +! ...take the left side of that equation, solve for n to see where they meet: + +! n = log(10) / [ log(10) - log(x) ] + +! Round down since we already know that particular value of n is no good. + +: euler063 ( -- answer ) + 9 [1,b] [ log [ 10 log dup ] dip - /i ] sigma ; + +! [ euler063 ] 100 ave-time +! 0 ms ave run time - 0.0 SD (100 trials) + +SOLUTION: euler063 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index d60ae60126..5d46d7f1fd 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -16,13 +16,13 @@ USING: definitions io io.files io.pathnames kernel math math.parser project-euler.045 project-euler.046 project-euler.047 project-euler.048 project-euler.049 project-euler.052 project-euler.053 project-euler.054 project-euler.055 project-euler.056 project-euler.057 project-euler.058 - project-euler.059 project-euler.067 project-euler.071 project-euler.073 - project-euler.075 project-euler.076 project-euler.079 project-euler.092 - project-euler.097 project-euler.099 project-euler.100 project-euler.116 - project-euler.117 project-euler.134 project-euler.148 project-euler.150 - project-euler.151 project-euler.164 project-euler.169 project-euler.173 - project-euler.175 project-euler.186 project-euler.190 project-euler.203 - project-euler.215 ; + project-euler.059 project-euler.063 project-euler.067 project-euler.071 + project-euler.073 project-euler.075 project-euler.076 project-euler.079 + project-euler.092 project-euler.097 project-euler.099 project-euler.100 + project-euler.116 project-euler.117 project-euler.134 project-euler.148 + project-euler.150 project-euler.151 project-euler.164 project-euler.169 + project-euler.173 project-euler.175 project-euler.186 project-euler.190 + project-euler.203 project-euler.215 ; IN: project-euler Date: Tue, 7 Apr 2009 21:32:45 -0500 Subject: [PATCH 145/772] opengl.textures: use GL_ARB_texture_non_power_of_two if available --- basis/opengl/textures/textures.factor | 13 ++++++++++--- basis/ui/backend/backend.factor | 8 ++++---- basis/ui/gadgets/worlds/worlds.factor | 12 +++++++++--- 3 files changed, 23 insertions(+), 10 deletions(-) diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index bb232affa4..e13e99e10f 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -3,9 +3,11 @@ USING: accessors assocs cache colors.constants destructors fry kernel opengl opengl.gl combinators images images.tesselation grouping specialized-arrays.float sequences math math.vectors -math.matrices generalizations fry arrays ; +math.matrices generalizations fry arrays namespaces ; IN: opengl.textures +SYMBOL: non-power-of-2-textures? + : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ; : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ; @@ -29,9 +31,14 @@ GENERIC: draw-scaled-texture ( dim texture -- ) TUPLE: single-texture image dim loc texture-coords texture display-list disposed ; +: adjust-texture-dim ( dim -- dim' ) + non-power-of-2-textures? get [ + [ next-power-of-2 ] map + ] unless ; + : (tex-image) ( image -- ) [ GL_TEXTURE_2D 0 GL_RGBA ] dip - [ dim>> first2 [ next-power-of-2 ] bi@ 0 ] + [ dim>> adjust-texture-dim first2 0 ] [ component-order>> component-order>format f ] bi glTexImage2D ; @@ -81,7 +88,7 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed ] with-texturing ; : texture-coords ( texture -- coords ) - [ [ dim>> ] [ image>> dim>> [ next-power-of-2 ] map ] bi v/ ] + [ [ dim>> ] [ image>> dim>> adjust-texture-dim ] bi v/ ] [ image>> upside-down?>> { { 0 1 } { 1 1 } { 1 0 } { 0 0 } } diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor index d72ef13b44..9c844d3663 100755 --- a/basis/ui/backend/backend.factor +++ b/basis/ui/backend/backend.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces opengl opengl.gl ; +USING: kernel namespaces opengl opengl.gl fry ; IN: ui.backend SYMBOL: ui-backend @@ -28,7 +28,7 @@ GENERIC: flush-gl-context ( handle -- ) HOOK: offscreen-pixels ui-backend ( world -- alien w h ) : with-gl-context ( handle quot -- ) - swap [ select-gl-context call ] keep - flush-gl-context gl-error ; inline + '[ select-gl-context @ ] + [ flush-gl-context gl-error ] bi ; inline HOOK: (with-ui) ui-backend ( quot -- ) \ No newline at end of file diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 655c9ba49d..f671add531 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs continuations kernel math models -namespaces opengl sequences io combinators combinators.short-circuit -fry math.vectors math.rectangles cache ui.gadgets ui.gestures -ui.render ui.backend ui.gadgets.tracks ui.commands ; +namespaces opengl opengl.capabilities opengl.textures sequences io +combinators combinators.short-circuit fry math.vectors math.rectangles +cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks +ui.commands ; IN: ui.gadgets.worlds TUPLE: world < track @@ -76,8 +77,13 @@ SYMBOL: flush-layout-cache-hook flush-layout-cache-hook [ [ ] ] initialize +: check-extensions ( -- ) + "2.0" { "GL_ARB_texture_non_power_of_two" } has-gl-version-or-extensions? + non-power-of-2-textures? set ; + : (draw-world) ( world -- ) dup handle>> [ + check-extensions { [ init-gl ] [ draw-gadget ] From ba61b8215275bb6ea605169d291f133b8d5db711 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Apr 2009 21:47:57 -0500 Subject: [PATCH 146/772] Pass vocab roots onto deployed app. Fixes deployment of apps outside the built-in roots. Reported by Alec Berryman --- basis/command-line/command-line.factor | 1 - basis/tools/deploy/backend/backend.factor | 4 ++-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor index 73a01aa352..56d7fbd207 100644 --- a/basis/command-line/command-line.factor +++ b/basis/command-line/command-line.factor @@ -60,7 +60,6 @@ SYMBOL: main-vocab-hook : default-cli-args ( -- ) global [ "quiet" off - "script" off "e" off "user-init" on embedded? "quiet" set diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index 28a32790dc..6ca54ca36b 100755 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -8,7 +8,7 @@ debugger io.streams.c io.files io.files.temp io.pathnames io.directories io.directories.hierarchy io.backend quotations io.launcher words.private tools.deploy.config tools.deploy.config.editor bootstrap.image io.encodings.utf8 -destructors accessors ; +destructors accessors hashtables ; IN: tools.deploy.backend : copy-vm ( executable bundle-name -- vm ) @@ -88,7 +88,7 @@ DEFER: ?make-staging-image [ drop ] [ make-staging-image ] if ; : make-deploy-config ( vocab -- file ) - [ deploy-config unparse-use ] + [ deploy-config vocab-roots get vocab-roots associate assoc-union unparse-use ] [ "deploy-config-" prepend temp-file ] bi [ utf8 set-file-contents ] keep ; From 6082a98c7c075dbfc03d9a3c720e0fcccfda4eb5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Apr 2009 22:30:13 -0500 Subject: [PATCH 147/772] If (open-window) or similar fails, don't enter an infinite loop of opening error windows, just try to open one and then give up --- basis/ui/ui.factor | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index bf17e455f8..dff7726d08 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs io kernel math models namespaces make dlists deques sequences threads sequences words continuations init -combinators hashtables concurrency.flags sets accessors calendar fry -destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds -ui.gadgets.tracks ui.gestures ui.backend ui.render ; +combinators combinators.short-circuit hashtables concurrency.flags +sets accessors calendar fry destructors ui.gadgets ui.gadgets.private +ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render ; IN: ui : find-window ( quot -- world ) - windows get values - [ gadget-child swap call ] with find-last nip ; inline + [ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline : ui-running? ( -- ? ) \ ui-running get-global ; @@ -142,9 +139,15 @@ PRIVATE> Date: Wed, 8 Apr 2009 02:41:02 -0400 Subject: [PATCH 148/772] Solutions to Project Euler problem 69 --- extra/project-euler/007/007.factor | 3 - extra/project-euler/069/069-tests.factor | 4 ++ extra/project-euler/069/069.factor | 87 ++++++++++++++++++++++++ extra/project-euler/071/071.factor | 7 -- extra/project-euler/common/common.factor | 19 ++++-- extra/project-euler/project-euler.factor | 16 ++--- 6 files changed, 113 insertions(+), 23 deletions(-) create mode 100644 extra/project-euler/069/069-tests.factor create mode 100644 extra/project-euler/069/069.factor diff --git a/extra/project-euler/007/007.factor b/extra/project-euler/007/007.factor index f9208e11b3..1827d0fa06 100644 --- a/extra/project-euler/007/007.factor +++ b/extra/project-euler/007/007.factor @@ -17,9 +17,6 @@ IN: project-euler.007 ! SOLUTION ! -------- -: nth-prime ( n -- n ) - 1- lprimes lnth ; - : euler007 ( -- answer ) 10001 nth-prime ; diff --git a/extra/project-euler/069/069-tests.factor b/extra/project-euler/069/069-tests.factor new file mode 100644 index 0000000000..97741c0ee3 --- /dev/null +++ b/extra/project-euler/069/069-tests.factor @@ -0,0 +1,4 @@ +USING: project-euler.069 tools.test ; + +{ 510510 } [ euler069 ] unit-test +{ 510510 } [ euler069a ] unit-test diff --git a/extra/project-euler/069/069.factor b/extra/project-euler/069/069.factor new file mode 100644 index 0000000000..eae1d82ece --- /dev/null +++ b/extra/project-euler/069/069.factor @@ -0,0 +1,87 @@ +! Copyright (c) 2009 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators fry kernel math math.primes math.primes.factors math.ranges + project-euler.common sequences ; +IN: project-euler.069 + +! http://projecteuler.net/index.php?section=problems&id=69 + +! DESCRIPTION +! ----------- + +! Euler's Totient function, φ(n) [sometimes called the phi function], is used +! to determine the number of numbers less than n which are relatively prime to +! n. For example, as 1, 2, 4, 5, 7, and 8, are all less than nine and +! relatively prime to nine, φ(9)=6. + +! +----+------------------+------+-----------+ +! | n | Relatively Prime | φ(n) | n / φ(n) | +! +----+------------------+------+-----------+ +! | 2 | 1 | 1 | 2 | +! | 3 | 1,2 | 2 | 1.5 | +! | 4 | 1,3 | 2 | 2 | +! | 5 | 1,2,3,4 | 4 | 1.25 | +! | 6 | 1,5 | 2 | 3 | +! | 7 | 1,2,3,4,5,6 | 6 | 1.1666... | +! | 8 | 1,3,5,7 | 4 | 2 | +! | 9 | 1,2,4,5,7,8 | 6 | 1.5 | +! | 10 | 1,3,7,9 | 4 | 2.5 | +! +----+------------------+------+-----------+ + +! It can be seen that n = 6 produces a maximum n / φ(n) for n ≤ 10. + +! Find the value of n ≤ 1,000,000 for which n / φ(n) is a maximum. + + +! SOLUTION +! -------- + +! Brute force + + + +: euler069 ( -- answer ) + 2 1000000 [a,b] [ totient-ratio ] map + [ supremum ] keep index 2 + ; + +! [ euler069 ] 10 ave-time +! 25210 ms ave run time - 115.37 SD (10 trials) + + +! ALTERNATE SOLUTIONS +! ------------------- + +! In order to obtain maximum n / φ(n), φ(n) needs to be low and n needs to be +! high. Hence we need a number that has the most factors. A number with the +! most unique factors would have fewer relatively prime. + + + +: euler069a ( -- answer ) + 1000000 primorial-upto ; + +! [ euler069a ] 100 ave-time +! 0 ms ave run time - 0.01 SD (100 trials) + +SOLUTION: euler069a diff --git a/extra/project-euler/071/071.factor b/extra/project-euler/071/071.factor index cccf6bf708..0fd93a8f2d 100644 --- a/extra/project-euler/071/071.factor +++ b/extra/project-euler/071/071.factor @@ -32,13 +32,6 @@ IN: project-euler.071 ! repeatedly until the denominator is as close to 1000000 as possible without ! going over. - - : euler071 ( -- answer ) 2/5 [ dup denominator 1000000 <= ] [ 3/7 mediant dup ] produce nip penultimate numerator ; diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index ba8c81fbf4..c2ffe26d94 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -1,9 +1,10 @@ -! Copyright (c) 2007-2008 Aaron Schaefer. +! Copyright (c) 2007-2009 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel make math math.functions math.matrices math.miller-rabin - math.order math.parser math.primes.factors math.ranges math.ratios - sequences sorting strings unicode.case parser accessors vocabs.parser - namespaces vocabs words quotations prettyprint ; +USING: accessors arrays kernel lists make math math.functions math.matrices + math.miller-rabin math.order math.parser math.primes.factors + math.primes.lists math.ranges math.ratios namespaces parser prettyprint + quotations sequences sorting strings unicode.case vocabs vocabs.parser + words ; IN: project-euler.common ! A collection of words used by more than one Project Euler solution @@ -16,11 +17,13 @@ IN: project-euler.common ! log10 - #25, #134 ! max-path - #18, #67 ! mediant - #71, #73 +! nth-prime - #7, #69 ! nth-triangle - #12, #42 ! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92 ! palindrome? - #4, #36, #55 ! pandigital? - #32, #38 ! pentagonal? - #44, #45 +! penultimate - #69, #71 ! propagate-all - #18, #67 ! sum-proper-divisors - #21 ! tau* - #12 @@ -78,6 +81,9 @@ PRIVATE> : number-length ( n -- m ) log10 floor 1+ >integer ; +: nth-prime ( n -- n ) + 1- lprimes lnth ; + : nth-triangle ( n -- n ) dup 1+ * 2 / ; @@ -90,6 +96,9 @@ PRIVATE> : pentagonal? ( n -- ? ) dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ; +: penultimate ( seq -- elt ) + dup length 2 - swap nth ; + ! Not strictly needed, but it is nice to be able to dump the triangle after the ! propagation : propagate-all ( triangle -- new-triangle ) diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 5d46d7f1fd..95d3644215 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007, 2008, 2009 Aaron Schaefer, Samuel Tardieu. +! Copyright (c) 2007-2009 Aaron Schaefer, Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. USING: definitions io io.files io.pathnames kernel math math.parser prettyprint project-euler.ave-time sequences vocabs vocabs.loader @@ -16,13 +16,13 @@ USING: definitions io io.files io.pathnames kernel math math.parser project-euler.045 project-euler.046 project-euler.047 project-euler.048 project-euler.049 project-euler.052 project-euler.053 project-euler.054 project-euler.055 project-euler.056 project-euler.057 project-euler.058 - project-euler.059 project-euler.063 project-euler.067 project-euler.071 - project-euler.073 project-euler.075 project-euler.076 project-euler.079 - project-euler.092 project-euler.097 project-euler.099 project-euler.100 - project-euler.116 project-euler.117 project-euler.134 project-euler.148 - project-euler.150 project-euler.151 project-euler.164 project-euler.169 - project-euler.173 project-euler.175 project-euler.186 project-euler.190 - project-euler.203 project-euler.215 ; + project-euler.059 project-euler.063 project-euler.067 project-euler.069 + project-euler.071 project-euler.073 project-euler.075 project-euler.076 + project-euler.079 project-euler.092 project-euler.097 project-euler.099 + project-euler.100 project-euler.116 project-euler.117 project-euler.134 + project-euler.148 project-euler.150 project-euler.151 project-euler.164 + project-euler.169 project-euler.173 project-euler.175 project-euler.186 + project-euler.190 project-euler.203 project-euler.215 ; IN: project-euler Date: Wed, 8 Apr 2009 05:04:58 -0500 Subject: [PATCH 149/772] Fix poker tests --- extra/poker/poker-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor index 1862974084..ad371a6bff 100644 --- a/extra/poker/poker-tests.factor +++ b/extra/poker/poker-tests.factor @@ -1,4 +1,4 @@ -USING: accessors poker poker.private tools.test ; +USING: accessors poker poker.private tools.test math.order kernel ; IN: poker.tests [ 134236965 ] [ "KD" >ckf ] unit-test From 30191f87e5d06749a4c8c0c317a5ad09ad8381cc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 8 Apr 2009 05:13:06 -0500 Subject: [PATCH 150/772] descriptive: add make-descriptive word to enable this functionality to be used as an annotation; improve docs --- extra/descriptive/descriptive-docs.factor | 22 +++++++++++++++------- extra/descriptive/descriptive.factor | 11 +++++++++-- 2 files changed, 24 insertions(+), 9 deletions(-) diff --git a/extra/descriptive/descriptive-docs.factor b/extra/descriptive/descriptive-docs.factor index dc02f8bd9d..6ced201c13 100755 --- a/extra/descriptive/descriptive-docs.factor +++ b/extra/descriptive/descriptive-docs.factor @@ -1,20 +1,28 @@ -USING: help.syntax help.markup ; +USING: help.syntax help.markup words ; IN: descriptive HELP: DESCRIPTIVE: { $syntax "DESCRIPTIVE: word ( inputs -- outputs ) definition ;" } -{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ; +{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ; HELP: DESCRIPTIVE:: { $syntax "DESCRIPTIVE:: word ( inputs -- outputs ) definition ;" } -{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ; +{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ; -HELP: descriptive -{ $class-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ; +HELP: descriptive-error +{ $error-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ; + +HELP: make-descriptive +{ $values { "word" word } } +{ $description "Makes the word wrap errors in " { $link descriptive-error } " instances." } ; ARTICLE: "descriptive" "Descriptive errors" -"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in a special descriptor declaring that an error was thrown from inside that word, and including the arguments given to that word. The error is of the following class:" -{ $subsection descriptive } +"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in an instance of a class:" +{ $subsection descriptive-error } +"The wrapper contains the word itself, the input parameters, as well as the original error." +$nl +"To annotate an existing word with descriptive error checking:" +{ $subsection make-descriptive } "To define words which throw descriptive errors, use the following words:" { $subsection POSTPONE: DESCRIPTIVE: } { $subsection POSTPONE: DESCRIPTIVE:: } ; diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor index ceadc9fe6e..9af94aa4ed 100755 --- a/extra/descriptive/descriptive.factor +++ b/extra/descriptive/descriptive.factor @@ -1,6 +1,9 @@ -USING: words kernel sequences locals locals.parser +! Copyright (c) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: words kernel sequences locals locals.parser fry locals.definitions accessors parser namespaces continuations -summary definitions generalizations arrays prettyprint debugger io ; +summary definitions generalizations arrays prettyprint debugger io +effects tools.annotations ; IN: descriptive ERROR: descriptive-error args underlying word ; @@ -23,6 +26,10 @@ M: descriptive-error error. PRIVATE> +: make-descriptive ( word -- ) + dup [ ] [ def>> ] [ stack-effect ] tri [descriptive] + '[ drop _ ] annotate-methods ; + : define-descriptive ( word def effect -- ) [ drop "descriptive-definition" set-word-prop ] [ [ [ dup ] 2dip [descriptive] ] keep define-declared ] From 59e0434815dbb5a32a79389568ed0ad934ee40b7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 8 Apr 2009 06:23:07 -0500 Subject: [PATCH 151/772] Trace tool work in progress --- basis/tools/continuations/authors.txt | 1 + .../tools/continuations/continuations.factor | 146 +++++++++++++++++ basis/tools/trace/authors.txt | 1 + basis/tools/trace/trace.factor | 66 ++++++++ basis/tools/walker/walker.factor | 151 ++---------------- 5 files changed, 231 insertions(+), 134 deletions(-) create mode 100644 basis/tools/continuations/authors.txt create mode 100644 basis/tools/continuations/continuations.factor create mode 100644 basis/tools/trace/authors.txt create mode 100644 basis/tools/trace/trace.factor diff --git a/basis/tools/continuations/authors.txt b/basis/tools/continuations/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/tools/continuations/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/continuations/continuations.factor b/basis/tools/continuations/continuations.factor new file mode 100644 index 0000000000..70ebff90d9 --- /dev/null +++ b/basis/tools/continuations/continuations.factor @@ -0,0 +1,146 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: threads kernel namespaces continuations combinators +sequences math namespaces.private continuations.private +concurrency.messaging quotations kernel.private words +sequences.private assocs models models.arrow arrays accessors +generic generic.standard definitions make sbufs ; +IN: tools.continuations + + + +SYMBOL: break-hook + +: break ( -- ) + continuation callstack >>call + break-hook get call + after-break ; + +\ break t "break?" set-word-prop + +> (step-into-quot) ] + } cond ; + +\ (step-into-execute) t "step-into?" set-word-prop + +: (step-into-continuation) ( -- ) + continuation callstack >>call break ; + +: (step-into-call-next-method) ( method -- ) + next-method-quot (step-into-quot) ; + +: change-frame ( continuation quot -- continuation' ) + #! Applies quot to innermost call frame of the + #! continuation. + [ clone ] dip [ + [ clone ] dip + [ + [ + [ innermost-frame-scan 1+ ] + [ innermost-frame-quot ] bi + ] dip call + ] + [ drop set-innermost-frame-quot ] + [ drop ] + 2tri + ] curry change-call ; inline + +PRIVATE> + +: continuation-step ( continuation -- continuation' ) + [ + 2dup length = [ nip [ break ] append ] [ + 2dup nth \ break = [ nip ] [ + swap 1+ cut [ break ] glue + ] if + ] if + ] change-frame ; + +: continuation-step-out ( continuation -- continuation' ) + [ nip \ break suffix ] change-frame ; + + +{ + { call [ (step-into-quot) ] } + { dip [ (step-into-dip) ] } + { 2dip [ (step-into-2dip) ] } + { 3dip [ (step-into-3dip) ] } + { execute [ (step-into-execute) ] } + { if [ (step-into-if) ] } + { dispatch [ (step-into-dispatch) ] } + { continuation [ (step-into-continuation) ] } + { (call-next-method) [ (step-into-call-next-method) ] } +} [ "step-into" set-word-prop ] assoc-each + +! Never step into these words +{ + >n ndrop >c c> + continue continue-with + stop suspend (spawn) +} [ + dup [ execute break ] curry + "step-into" set-word-prop +] each + +\ break [ break ] "step-into" set-word-prop + +: continuation-step-into ( continuation -- continuation' ) + [ + swap cut [ + swap % + [ \ break , ] [ + unclip { + { [ dup \ break eq? ] [ , ] } + { [ dup quotation? ] [ add-breakpoint , \ break , ] } + { [ dup array? ] [ add-breakpoint , \ break , ] } + { [ dup word? ] [ literalize , \ (step-into-execute) , ] } + [ , \ break , ] + } cond % + ] if-empty + ] [ ] make + ] change-frame ; + +: continuation-current ( continuation -- obj ) + call>> + [ innermost-frame-scan 1+ ] + [ innermost-frame-quot ] bi ?nth ; diff --git a/basis/tools/trace/authors.txt b/basis/tools/trace/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/tools/trace/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/trace/trace.factor b/basis/tools/trace/trace.factor new file mode 100644 index 0000000000..42d4a00ce1 --- /dev/null +++ b/basis/tools/trace/trace.factor @@ -0,0 +1,66 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.promises models tools.continuations kernel +sequences concurrency.messaging locals continuations +threads namespaces namespaces.private make assocs accessors +io strings prettyprint math words effects summary io.styles +classes ; +IN: tools.trace + +: callstack-depth ( callstack -- n ) + callstack>array length ; + +SYMBOL: end + +SYMBOL: exclude-vocabs +SYMBOL: include-vocabs + +exclude-vocabs { "kernel" "math" "accessors" } swap set-global + +: include? ( vocab -- ? ) + include-vocabs get dup [ member? ] [ 2drop t ] if ; + +: exclude? ( vocab -- ? ) + exclude-vocabs get dup [ member? ] [ 2drop f ] if ; + +: into? ( obj -- ? ) + dup word? [ + dup predicate? [ drop f ] [ + vocabulary>> [ include? ] [ exclude? not ] bi and + ] if + ] [ drop t ] if ; + +TUPLE: trace-step word inputs ; + +M: trace-step summary + [ + [ "Word: " % word>> name>> % ] + [ " -- inputs: " % inputs>> unparse-short % ] bi + ] "" make ; + +: ( continuation word -- trace-step ) + [ nip ] [ [ data>> ] [ stack-effect in>> length ] bi* short tail* ] 2bi + \ trace-step boa ; + +: print-step ( continuation -- ) + dup continuation-current dup word? [ + [ nip name>> ] [ ] 2bi write-object nl + ] [ + nip short. + ] if ; + +: trace-step ( continuation -- continuation' ) + dup continuation-current end eq? [ + [ call>> callstack-depth 2/ CHAR: \s write ] + [ print-step ] + [ + dup continuation-current into? + [ continuation-step-into ] [ continuation-step ] if + ] + tri + ] unless ; + +: trace ( quot -- data ) + [ [ trace-step ] break-hook ] dip + [ break ] [ end drop ] surround + with-variable ; diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index b4ace6b770..a1f18df57a 100644 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -1,10 +1,11 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words sequences.private assocs models models.arrow arrays accessors -generic generic.standard definitions make sbufs ; +generic generic.standard definitions make sbufs +tools.continuations ; IN: tools.walker SYMBOL: show-walker-hook ! ( status continuation thread -- ) @@ -31,66 +32,16 @@ DEFER: start-walker-thread 2dup start-walker-thread ] if* ; -: show-walker ( -- thread ) - get-walker-thread - [ show-walker-hook get call ] keep ; - -: after-break ( object -- ) - { - { [ dup continuation? ] [ (continue) ] } - { [ dup quotation? ] [ call ] } - { [ dup not ] [ "Single stepping abandoned" rethrow ] } - } cond ; - -: break ( -- ) - continuation callstack >>call - show-walker send-synchronous - after-break ; - -\ break t "break?" set-word-prop - : walk ( quot -- quot' ) \ break prefix [ break rethrow ] recover ; -GENERIC: add-breakpoint ( quot -- quot' ) - -M: callable add-breakpoint - dup [ break ] head? [ \ break prefix ] unless ; - -M: array add-breakpoint - [ add-breakpoint ] map ; - -M: object add-breakpoint ; - -: (step-into-quot) ( quot -- ) add-breakpoint call ; - -: (step-into-dip) ( quot -- ) add-breakpoint dip ; - -: (step-into-2dip) ( quot -- ) add-breakpoint 2dip ; - -: (step-into-3dip) ( quot -- ) add-breakpoint 3dip ; - -: (step-into-if) ( true false ? -- ) ? (step-into-quot) ; - -: (step-into-dispatch) ( array n -- ) nth (step-into-quot) ; - -: (step-into-execute) ( word -- ) - { - { [ 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 uses \ suspend swap member? ] [ execute break ] } - { [ dup primitive? ] [ execute break ] } - [ def>> (step-into-quot) ] - } cond ; - -\ (step-into-execute) t "step-into?" set-word-prop - -: (step-into-continuation) ( -- ) - continuation callstack >>call break ; - -: (step-into-call-next-method) ( method -- ) - next-method-quot (step-into-quot) ; +break-hook [ + [ + get-walker-thread + [ show-walker-hook get call ] keep + send-synchronous + ] +] initialize ! Messages sent to walker thread SYMBOL: step @@ -106,74 +57,6 @@ SYMBOL: +running+ SYMBOL: +suspended+ SYMBOL: +stopped+ -: change-frame ( continuation quot -- continuation' ) - #! Applies quot to innermost call frame of the - #! continuation. - [ clone ] dip [ - [ clone ] dip - [ - [ - [ innermost-frame-scan 1+ ] - [ innermost-frame-quot ] bi - ] dip call - ] - [ drop set-innermost-frame-quot ] - [ drop ] - 2tri - ] curry change-call ; inline - -: step-msg ( continuation -- continuation' ) USE: io - [ - 2dup length = [ nip [ break ] append ] [ - 2dup nth \ break = [ nip ] [ - swap 1+ cut [ break ] glue - ] if - ] if - ] change-frame ; - -: step-out-msg ( continuation -- continuation' ) - [ nip \ break suffix ] change-frame ; - -{ - { call [ (step-into-quot) ] } - { dip [ (step-into-dip) ] } - { 2dip [ (step-into-2dip) ] } - { 3dip [ (step-into-3dip) ] } - { execute [ (step-into-execute) ] } - { if [ (step-into-if) ] } - { dispatch [ (step-into-dispatch) ] } - { continuation [ (step-into-continuation) ] } - { (call-next-method) [ (step-into-call-next-method) ] } -} [ "step-into" set-word-prop ] assoc-each - -! Never step into these words -{ - >n ndrop >c c> - continue continue-with - stop suspend (spawn) -} [ - dup [ execute break ] curry - "step-into" set-word-prop -] each - -\ break [ break ] "step-into" set-word-prop - -: step-into-msg ( continuation -- continuation' ) - [ - swap cut [ - swap % - [ \ break , ] [ - unclip { - { [ dup \ break eq? ] [ , ] } - { [ dup quotation? ] [ add-breakpoint , \ break , ] } - { [ dup array? ] [ add-breakpoint , \ break , ] } - { [ dup word? ] [ literalize , \ (step-into-execute) , ] } - [ , \ break , ] - } cond % - ] if-empty - ] [ ] make - ] change-frame ; - : status ( -- symbol ) walker-status tget value>> ; @@ -200,13 +83,13 @@ SYMBOL: +stopped+ { f [ +stopped+ set-status f ] } [ [ walker-continuation tget set-model ] - [ step-into-msg ] bi + [ continuation-step-into ] bi ] } case ] handle-synchronous ] while ; -: step-back-msg ( continuation -- continuation' ) +: continuation-step-back ( continuation -- continuation' ) walker-history tget [ pop* ] [ [ nip pop ] unless-empty ] bi ; @@ -220,20 +103,20 @@ SYMBOL: +stopped+ { ! These are sent by the walker tool. We reply ! and keep cycling. - { step [ step-msg keep-running ] } - { step-out [ step-out-msg keep-running ] } - { step-into [ step-into-msg keep-running ] } + { step [ continuation-step keep-running ] } + { step-out [ continuation-step-out keep-running ] } + { step-into [ continuation-step-into keep-running ] } { step-all [ keep-running ] } { step-into-all [ step-into-all-loop ] } { abandon [ drop f keep-running ] } ! Pass quotation to debugged thread { call-in [ keep-running ] } ! Pass previous continuation to debugged thread - { step-back [ step-back-msg ] } + { step-back [ continuation-step-back ] } } case f ] handle-synchronous ] while ; - + : walker-loop ( -- ) +running+ set-status [ status +stopped+ eq? ] [ From 7c898bd553146f67a585d9df603454a5575d2a08 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 8 Apr 2009 12:30:11 -0400 Subject: [PATCH 152/772] Eliminate redundant unique5 lookup for poker hands --- extra/poker/poker.factor | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index 2a7fe73762..e8e9fa23c5 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -117,9 +117,6 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" : lookup ( cards table -- value ) [ rank-bits ] dip nth ; -: unique5? ( cards -- ? ) - unique5-table lookup 0 > ; - : map-product ( seq quot -- n ) [ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline @@ -138,11 +135,11 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" bitxor values-table nth ; : hand-value ( cards -- value ) - { - { [ dup flush? ] [ flushes-table lookup ] } - { [ dup unique5? ] [ unique5-table lookup ] } - [ prime-bits perfect-hash-find ] - } cond ; + dup flush? [ flushes-table lookup ] [ + dup unique5-table lookup dup 0 > [ nip ] [ + drop prime-bits perfect-hash-find + ] if + ] if ; : >card-rank ( card -- str ) -8 shift HEX: F bitand RANK_STR nth ; From 01677ada51c65d392df4ab61cb011644eaa08acc Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 8 Apr 2009 18:15:24 -0400 Subject: [PATCH 153/772] Remove unnecessary helper word after refactoring --- extra/project-euler/069/069.factor | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/extra/project-euler/069/069.factor b/extra/project-euler/069/069.factor index eae1d82ece..3a59d66522 100644 --- a/extra/project-euler/069/069.factor +++ b/extra/project-euler/069/069.factor @@ -69,12 +69,9 @@ PRIVATE> [ nth-prime primes-upto ] } cond product ; -: (primorial-upto) ( count limit -- m ) - '[ dup primorial _ <= ] [ 1+ dup primorial ] produce - nip penultimate ; - : primorial-upto ( limit -- m ) - 1 swap (primorial-upto) ; + 1 swap '[ dup primorial _ <= ] [ 1+ dup primorial ] produce + nip penultimate ; PRIVATE> From 94baa7d7fa084ffed47aa1e2240b268c9e6ef8f7 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 8 Apr 2009 18:12:27 -0500 Subject: [PATCH 154/772] Call ScriptStringOut with ETO_OPAQUE --- basis/windows/uniscribe/uniscribe.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index 7cfda41dc9..f6cacfb683 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -59,10 +59,10 @@ TUPLE: script-string font string metrics ssa size image disposed ; ssa>> ! ssa 0 ! iX 0 ! iY - 0 ! uOptions - f ! prc + ETO_OPAQUE ! uOptions ] - [ selection-start/end ] bi + [ [ { 0 0 } ] dip size>> ] + [ selection-start/end ] tri ! iMinSel ! iMaxSel FALSE ! fDisabled @@ -108,7 +108,7 @@ M: script-string dispose* SYMBOL: cached-script-strings -: cached-script-string ( string font -- script-string ) +: cached-script-string ( font string -- script-string ) cached-script-strings get-global [ ] 2cache ; [ cached-script-strings set-global ] From 49852f57153cd24e23912d8b4efd7c00a4e86f3a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Apr 2009 18:42:01 -0500 Subject: [PATCH 155/772] fix saving bitmaps --- basis/images/bitmap/bitmap-tests.factor | 28 +++++++++++- basis/images/bitmap/bitmap.factor | 60 +++++++++++++++---------- 2 files changed, 62 insertions(+), 26 deletions(-) diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor index e154df26a1..c7012cfd42 100644 --- a/basis/images/bitmap/bitmap-tests.factor +++ b/basis/images/bitmap/bitmap-tests.factor @@ -1,6 +1,6 @@ USING: images.bitmap images.viewer io.encodings.binary io.files io.files.unique kernel tools.test images.loader -literals sequences ; +literals sequences checksums.md5 checksums ; IN: images.bitmap.tests CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp" @@ -11,6 +11,11 @@ CONSTANT: test-bitmap4 "vocab:images/test-images/rgb4bit.bmp" CONSTANT: test-bitmap1 "vocab:images/test-images/1bit.bmp" +CONSTANT: test-40 "vocab:images/test-images/40red24bit.bmp" +CONSTANT: test-41 "vocab:images/test-images/41red24bit.bmp" +CONSTANT: test-42 "vocab:images/test-images/42red24bit.bmp" +CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp" + [ t ] [ test-bitmap24 @@ -24,4 +29,23 @@ CONSTANT: test-bitmap1 "vocab:images/test-images/1bit.bmp" $ test-bitmap8 $ test-bitmap24 "vocab:ui/render/test/reference.bmp" -} [ [ ] swap [ load-image drop ] curry unit-test ] each \ No newline at end of file +} [ [ ] swap [ load-image drop ] curry unit-test ] each + + +: test-bitmap-save ( path -- ? ) + [ md5 checksum-file ] + [ load-image ] bi + "bitmap-save-test" unique-file + [ save-bitmap ] + [ md5 checksum-file ] bi = ; + +[ + t +] [ + { + $ test-40 + $ test-41 + $ test-42 + $ test-43 + } [ test-bitmap-save ] all? +] unit-test diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 8209159a8e..48095bb26b 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -37,14 +37,14 @@ M: bitmap-magic summary ERROR: bmp-not-supported n ; : reverse-lines ( byte-array width -- byte-array ) - 3 * concat ; inline + concat ; inline : raw-bitmap>seq ( loading-bitmap -- array ) dup bit-count>> { { 32 [ color-index>> ] } - { 24 [ [ color-index>> ] [ width>> ] bi reverse-lines ] } - { 8 [ [ 8bit>buffer ] [ width>> ] bi reverse-lines ] } + { 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] } + { 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] } [ bmp-not-supported ] } case >byte-array ; @@ -81,30 +81,31 @@ ERROR: bmp-not-supported n ; : image-size ( loading-bitmap -- n ) [ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ; +: bitmap-padding ( width -- n ) + 3 * 4 mod 4 swap - 4 mod ; inline + :: fixup-color-index ( loading-bitmap -- loading-bitmap ) loading-bitmap width>> :> width width 3 * :> width*3 - loading-bitmap height>> abs :> height - loading-bitmap color-index>> length :> color-index-length - color-index-length height /i :> stride - color-index-length width*3 height * - height /i :> padding + loading-bitmap width>> bitmap-padding :> padding + loading-bitmap [ color-index>> length ] [ height>> abs ] bi /i :> stride + loading-bitmap padding 0 > [ - loading-bitmap [ + [ stride [ width*3 head-slice ] map concat ] change-color-index - ] [ - loading-bitmap - ] if ; + ] when ; : parse-bitmap ( loading-bitmap -- loading-bitmap ) dup rgb-quads-length read >>rgb-quads dup color-index-length read >>color-index fixup-color-index ; -: load-bitmap-data ( path loading-bitmap -- loading-bitmap ) - [ binary ] dip '[ - _ parse-file-header parse-bitmap-header parse-bitmap +: load-bitmap-data ( path -- loading-bitmap ) + binary [ + loading-bitmap new + parse-file-header parse-bitmap-header parse-bitmap ] with-file-reader ; ERROR: unknown-component-order bitmap ; @@ -117,8 +118,7 @@ ERROR: unknown-component-order bitmap ; [ unknown-component-order ] } case ; -: loading-bitmap>bitmap-image ( loading-bitmap -- bitmap-image ) - [ bitmap-image new ] dip +: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image ) { [ raw-bitmap>seq >>bitmap ] [ [ width>> ] [ height>> abs ] bi 2array >>dim ] @@ -127,20 +127,30 @@ ERROR: unknown-component-order bitmap ; } cleave ; M: bitmap-image load-image* ( path loading-bitmap -- bitmap ) - drop loading-bitmap new - load-bitmap-data - loading-bitmap>bitmap-image ; + swap load-bitmap-data loading-bitmap>bitmap-image ; PRIVATE> -: bitmap>color-index ( bitmap-array -- byte-array ) - 4 [ 3 head-slice ] map B{ } join ; inline +: bitmap>color-index ( bitmap -- byte-array ) + [ + bitmap>> + 4 + [ 3 head-slice ] map + B{ } join + ] [ + dim>> first dup bitmap-padding dup 0 > [ + [ 3 * group ] dip '[ _ append ] map + B{ } join + ] [ + 2drop + ] if + ] bi ; : save-bitmap ( image path -- ) binary [ B{ CHAR: B CHAR: M } write [ - bitmap>> bitmap>color-index length 14 + 40 + write4 + bitmap>color-index length 14 + 40 + write4 0 write4 54 write4 40 write4 @@ -159,7 +169,7 @@ PRIVATE> [ drop 0 write4 ] ! size-image - [ bitmap>> bitmap>color-index length write4 ] + [ bitmap>color-index length write4 ] ! x-pels [ drop 0 write4 ] @@ -175,7 +185,9 @@ PRIVATE> ! rgb-quads [ - [ bitmap>> bitmap>color-index ] [ dim>> first ] bi + [ bitmap>color-index ] + [ dim>> first 3 * ] + [ dim>> first bitmap-padding + ] tri reverse-lines write ] } cleave From 07cf80f0a8b1c1c105e4a7eb89263bfb3fb48e4b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Apr 2009 18:42:26 -0500 Subject: [PATCH 156/772] fix stack effect for unique-file --- basis/io/files/unique/unique-docs.factor | 2 +- basis/io/files/unique/unique.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/files/unique/unique-docs.factor b/basis/io/files/unique/unique-docs.factor index 74fc045032..6a7be47813 100644 --- a/basis/io/files/unique/unique-docs.factor +++ b/basis/io/files/unique/unique-docs.factor @@ -62,8 +62,8 @@ HELP: current-temporary-directory HELP: unique-file { $values + { "prefix" string } { "path" "a pathname string" } - { "path'" "a pathname string" } } { $description "Creates a temporary file in the directory stored in " { $link current-temporary-directory } " and outputs the path name." } ; diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor index 7bd96aa63b..0e4338e3e0 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -64,7 +64,7 @@ PRIVATE> [ unique-directory ] dip '[ _ with-temporary-directory ] [ delete-tree ] bi ; inline -: unique-file ( path -- path' ) +: unique-file ( prefix -- path ) "" make-unique-file ; { From 1c70bf833f105d4628c99f261290a92b7a9f592f Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 5 Mar 2009 23:11:46 -0200 Subject: [PATCH 157/772] irc: IRC messages reimplemented --- extra/irc/client/client-docs.factor | 8 +- extra/irc/client/client-tests.factor | 14 +- extra/irc/client/client.factor | 57 +++--- extra/irc/messages/base/authors.txt | 1 + extra/irc/messages/base/base.factor | 115 ++++++++++++ extra/irc/messages/base/summary.txt | 1 + extra/irc/messages/messages-tests.factor | 30 ++- extra/irc/messages/messages.factor | 230 ++++++----------------- extra/irc/messages/parser/authors.txt | 1 + extra/irc/messages/parser/parser.factor | 35 ++++ extra/irc/messages/parser/summary.txt | 1 + extra/irc/messages/summary.txt | 1 + 12 files changed, 262 insertions(+), 232 deletions(-) create mode 100644 extra/irc/messages/base/authors.txt create mode 100644 extra/irc/messages/base/base.factor create mode 100644 extra/irc/messages/base/summary.txt create mode 100644 extra/irc/messages/parser/authors.txt create mode 100644 extra/irc/messages/parser/parser.factor create mode 100644 extra/irc/messages/parser/summary.txt create mode 100644 extra/irc/messages/summary.txt diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor index 6d4fae9b83..d95d2bc2c6 100644 --- a/extra/irc/client/client-docs.factor +++ b/extra/irc/client/client-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax quotations kernel irc.messages ; +USING: help.markup help.syntax quotations kernel irc.messages irc.messages.base irc.messages.parser ; IN: irc.client HELP: irc-client "IRC Client object" ; @@ -56,15 +56,15 @@ ARTICLE: "irc.client" "IRC Client" "Some of the RFC defined irc messages as objects:" { $table { { $link irc-message } "base of all irc messages" } - { { $link logged-in } "logged in to server" } + { { $link rpl-welcome } "logged in to server" } { { $link ping } "ping message" } { { $link join } "channel join" } { { $link part } "channel part" } { { $link quit } "quit from irc" } { { $link privmsg } "private message (to client or channel)" } { { $link kick } "kick from channel" } - { { $link roomlist } "list of participants in channel" } - { { $link nick-in-use } "chosen nick is in use by another client" } + { { $link rpl-names } "list of participants in channel" } + { { $link rpl-nickname-in-use } "chosen nick is in use by another client" } { { $link notice } "notice message" } { { $link mode } "mode change" } { { $link unhandled } "uninmplemented/unhandled message" } diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index c1cbdcf8b8..4f25531eee 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -1,7 +1,7 @@ USING: kernel tools.test accessors arrays sequences io io.streams.duplex namespaces threads destructors - calendar irc.client.private irc.client irc.messages.private - concurrency.mailboxes classes assocs combinators ; + calendar irc.client.private irc.client irc.messages + concurrency.mailboxes classes assocs combinators irc.messages.parser ; EXCLUDE: irc.messages => join ; RENAME: join irc.messages => join_ IN: irc.client.tests @@ -49,13 +49,13 @@ M: mb-writer dispose drop ; { "factorbot" } [ irc> nick>> ] unit-test - { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test +! { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - parse-irc-line forward-name ] unit-test + string>irc-message forward-name ] unit-test { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" - parse-irc-line forward-name ] unit-test + string>irc-message forward-name ] unit-test ] with-irc ! Test login and nickname set @@ -102,7 +102,7 @@ M: mb-writer dispose drop ; "#factortest" [ %add-named-chat ] keep ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line [ privmsg? ] read-matching-message - [ class ] [ name>> ] [ trailing>> ] tri + [ class ] [ target>> ] [ trailing>> ] tri ] unit-test ] with-irc @@ -110,7 +110,7 @@ M: mb-writer dispose drop ; "ircuser" [ %add-named-chat ] keep ":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line [ privmsg? ] read-matching-message - [ class ] [ name>> ] [ trailing>> ] tri + [ class ] [ target>> ] [ trailing>> ] tri ] unit-test ] with-irc diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 97fa659209..7986a726ba 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -3,7 +3,7 @@ USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar accessors destructors namespaces io assocs arrays fry continuations threads strings classes combinators splitting hashtables - ascii irc.messages ; + ascii irc.messages irc.messages.base irc.messages.parser call ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.client @@ -74,12 +74,12 @@ SINGLETON: irc-disconnected ! sent when connection is lost SINGLETON: irc-connected ! sent when connection is established : terminate-irc ( irc-client -- ) - [ is-running>> ] keep and [ + dup is-running>> [ f >>is-running [ stream>> dispose ] keep [ in-messages>> ] [ out-messages>> ] bi 2array [ irc-end swap mailbox-put ] each - ] when* ; + ] [ drop ] if ; > mailbox-put ; : chats-with-participant ( nick -- seq ) irc> chats>> values - [ [ irc-channel-chat? ] keep and [ participants>> key? ] [ drop f ] if* ] + [ dup irc-channel-chat? [ participants>> key? ] [ 2drop f ] if ] with filter ; : to-chats-with-participant ( message nickname -- ) @@ -165,11 +165,10 @@ M: irc-chat to-chat in-messages>> mailbox-put ; " hostname servername :irc.factor" irc-print ; : /CONNECT ( server port -- stream ) - irc> connect>> call drop ; inline + irc> connect>> call( host port -- stream local ) drop ; : /JOIN ( channel password -- ) - "JOIN " irc-write - [ [ " :" ] dip 3append ] when* irc-print ; + "JOIN " irc-write [ " :" swap 3append ] when* irc-print ; : /PONG ( text -- ) "PONG " irc-write irc-print ; @@ -187,7 +186,7 @@ M: join forward-name trailing>> ; M: part forward-name channel>> ; M: kick forward-name channel>> ; M: mode forward-name name>> ; -M: privmsg forward-name dup name>> me? [ irc-message-sender ] [ name>> ] if ; +M: privmsg forward-name dup target>> me? [ sender>> ] [ target>> ] if ; UNION: single-forward join part kick mode privmsg ; UNION: multiple-forward nick quit ; @@ -200,48 +199,48 @@ M: irc-message forward-message M: single-forward forward-message dup forward-name to-chat ; M: multiple-forward forward-message - dup irc-message-sender to-chats-with-participant ; + dup sender>> to-chats-with-participant ; M: broadcast-forward forward-message irc> chats>> values [ to-chat ] with each ; GENERIC: process-message ( irc-message -- ) M: object process-message drop ; -M: logged-in process-message - name>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri +M: rpl-welcome process-message + nickname>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri values [ initialize-chat ] each ; M: ping process-message trailing>> /PONG ; -M: nick-in-use process-message name>> "_" append /NICK ; +M: rpl-nickname-in-use process-message name>> "_" append /NICK ; M: join process-message - [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri + [ drop +normal+ ] [ sender>> ] [ trailing>> ] tri dup chat> [ add-participant ] [ 3drop ] if ; M: part process-message - [ irc-message-sender ] [ channel>> ] bi remove-participant ; + [ sender>> ] [ channel>> ] bi remove-participant ; M: kick process-message - [ [ who>> ] [ channel>> ] bi remove-participant ] - [ dup who>> me? [ unregister-chat ] [ drop ] if ] + [ [ user>> ] [ channel>> ] bi remove-participant ] + [ dup user>> me? [ unregister-chat ] [ drop ] if ] bi ; M: quit process-message - irc-message-sender remove-participant-from-all ; + sender>> remove-participant-from-all ; M: nick process-message - [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ; + [ sender>> ] [ trailing>> ] bi rename-participant-in-all ; M: mode process-message ( mode -- ) - [ channel-mode? ] keep and [ + dup channel-mode? [ [ name>> ] [ mode>> ] [ parameter>> ] tri [ change-participant-mode ] [ 2drop ] if* - ] when* ; + ] [ drop ] if ; : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; : names-reply>participants ( names-reply -- participants ) - trailing>> [ blank? ] trim " " split + nicks>> [ blank? ] trim " " split [ >nick/mode 2array ] map >hashtable ; : maybe-clean-participants ( channel-chat -- ) @@ -249,14 +248,14 @@ M: mode process-message ( mode -- ) H{ } clone >>participants f >>clean-participants ] when drop ; -M: names-reply process-message +M: rpl-names process-message [ names-reply>participants ] [ channel>> chat> ] bi [ [ maybe-clean-participants ] [ participants>> 2array assoc-combine ] [ (>>participants) ] tri ] [ drop ] if* ; -M: end-of-names process-message +M: rpl-names-end process-message channel>> chat> [ t >>clean-participants [ f f f ] dip name>> to-chat @@ -268,7 +267,7 @@ M: end-of-names process-message GENERIC: handle-outgoing-irc ( irc-message -- ? ) M: irc-end handle-outgoing-irc drop f ; -M: irc-message handle-outgoing-irc irc-message>client-line irc-print t ; +M: irc-message handle-outgoing-irc irc-message>string irc-print t ; ! ====================================== ! Reader/Writer @@ -293,9 +292,9 @@ DEFER: (connect-irc) : (reader-loop) ( -- ? ) irc> stream>> [ |dispose stream-readln [ - parse-irc-line handle-reader-message t + string>irc-message handle-reader-message t ] [ - handle-disconnect + f handle-disconnect ] if* ] with-destructors ; @@ -314,7 +313,7 @@ DEFER: (connect-irc) [ forward-message ] [ process-message ] [ irc-end? not ] tri ; : strings>privmsg ( name string -- privmsg ) - privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; + privmsg new [ (>>trailing) ] keep [ (>>target) ] keep ; : maybe-annotate-with-name ( name obj -- obj ) { { [ dup string? ] [ strings>privmsg ] } @@ -325,7 +324,7 @@ DEFER: (connect-irc) GENERIC: annotate-message ( chat object -- object ) M: object annotate-message nip ; M: part annotate-message swap name>> >>channel ; -M: privmsg annotate-message swap name>> >>name ; +M: privmsg annotate-message swap name>> >>target ; M: string annotate-message [ name>> ] dip strings>privmsg ; : spawn-irc ( -- ) @@ -335,7 +334,7 @@ M: string annotate-message [ name>> ] dip strings>privmsg ; 3drop ; GENERIC: (attach-chat) ( irc-chat -- ) -USE: prettyprint + M: irc-chat (attach-chat) [ [ irc> >>client ] [ name>> ] bi irc> chats>> set-at ] [ [ irc> is-ready>> ] dip and [ initialize-chat ] when* ] diff --git a/extra/irc/messages/base/authors.txt b/extra/irc/messages/base/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/irc/messages/base/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/irc/messages/base/base.factor b/extra/irc/messages/base/base.factor new file mode 100644 index 0000000000..7350ef9320 --- /dev/null +++ b/extra/irc/messages/base/base.factor @@ -0,0 +1,115 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs classes.parser classes.tuple + combinators fry generic.parser kernel lexer + mirrors namespaces parser sequences splitting strings words ; +IN: irc.messages.base + +TUPLE: irc-message line prefix command parameters trailing timestamp sender ; +TUPLE: unhandled < irc-message ; + +SYMBOL: string-irc-type-mapping +string-irc-type-mapping [ H{ } clone ] initialize + +: register-irc-message-type ( type string -- ) + string-irc-type-mapping get set-at ; + +: irc>type ( string -- irc-message-class ) + string-irc-type-mapping get at unhandled or ; + +GENERIC: irc-trailing-slot ( irc-message -- string/f ) +M: irc-message irc-trailing-slot + drop f ; + +GENERIC: irc-parameter-slots ( irc-message -- seq ) +M: irc-message irc-parameter-slots + drop f ; + +GENERIC: process-irc-trailing ( irc-message -- ) +M: irc-message process-irc-trailing + dup irc-trailing-slot [ + swap [ trailing>> swap ] [ ] bi set-at + ] [ drop ] if* ; + +GENERIC: process-irc-prefix ( irc-message -- ) +M: irc-message process-irc-prefix + drop ; + + + +GENERIC: process-irc-parameters ( irc-message -- ) +M: irc-message process-irc-parameters + dup irc-parameter-slots [ + swap [ parameters>> swap ] [ [slot-setter] ] bi 2each + ] [ drop ] if* ; + +GENERIC: post-process-irc-message ( irc-message -- ) +M: irc-message post-process-irc-message drop ; + +GENERIC: fill-irc-message-slots ( irc-message -- ) +M: irc-message fill-irc-message-slots + { + [ process-irc-trailing ] + [ process-irc-prefix ] + [ process-irc-parameters ] + [ post-process-irc-message ] + } cleave ; + +GENERIC: irc-command-string ( irc-message -- string ) +M: irc-message irc-command-string drop f ; + +! FIXME: inverse of post-process is missing +GENERIC: set-irc-parameters ( irc-message -- ) +M: irc-message set-irc-parameters + dup irc-parameter-slots + [ over '[ _ at ] map >>parameters ] when* drop ; + +GENERIC: set-irc-trailing ( irc-message -- ) +M: irc-message set-irc-trailing + dup irc-trailing-slot [ over at >>trailing ] when* drop ; + +GENERIC: set-irc-command ( irc-message -- ) +M: irc-message set-irc-command + [ irc-command-string ] [ (>>command) ] bi ; + +: irc-message>string ( irc-message -- string ) + { + [ prefix>> ] + [ command>> ] + [ parameters>> " " join ] + [ trailing>> dup [ CHAR: : prefix ] when ] + } cleave 4array sift " " join ; + + + +#! SYNTAX: +#! IRC: type "COMMAND" slot1 ...; +#! IRC: type "COMMAND" slot1 ... : trailing-slot; +: IRC: ( name string parameters -- ) + CREATE-CLASS + [ scan-object register-irc-message-type ] keep + ";" parse-tokens + [ define-irc-class ] [ define-irc-parameter-slots ] 2bi ; parsing diff --git a/extra/irc/messages/base/summary.txt b/extra/irc/messages/base/summary.txt new file mode 100644 index 0000000000..1a05067707 --- /dev/null +++ b/extra/irc/messages/base/summary.txt @@ -0,0 +1 @@ +IRC messages base implementation diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index ac1d003b1b..abe94de8ef 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -1,19 +1,10 @@ USING: kernel tools.test accessors arrays - irc.messages irc.messages.private ; + irc.messages.parser irc.messages ; EXCLUDE: sequences => join ; IN: irc.messages.tests -{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test - -{ T{ irc-message - { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" } - { prefix "someuser!n=user@some.where" } - { command "PRIVMSG" } - { parameters { "#factortest" } } - { trailing "hi" } } } -[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - string>irc-message f >>timestamp ] unit-test +! { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test { T{ privmsg { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" } @@ -21,9 +12,10 @@ IN: irc.messages.tests { command "PRIVMSG" } { parameters { "#factortest" } } { trailing "hi" } - { name "#factortest" } } } + { target "#factortest" } + { text "hi" } } } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - parse-irc-line f >>timestamp ] unit-test + string>irc-message f >>timestamp ] unit-test { T{ join { line ":someuser!n=user@some.where JOIN :#factortest" } @@ -32,7 +24,7 @@ IN: irc.messages.tests { parameters { } } { trailing "#factortest" } } } [ ":someuser!n=user@some.where JOIN :#factortest" - parse-irc-line f >>timestamp ] unit-test + string>irc-message f >>timestamp ] unit-test { T{ mode { line ":ircserver.net MODE #factortest +ns" } @@ -42,7 +34,7 @@ IN: irc.messages.tests { name "#factortest" } { mode "+ns" } } } [ ":ircserver.net MODE #factortest +ns" - parse-irc-line f >>timestamp ] unit-test + string>irc-message f >>timestamp ] unit-test { T{ mode { line ":ircserver.net MODE #factortest +o someuser" } @@ -53,7 +45,7 @@ IN: irc.messages.tests { mode "+o" } { parameter "someuser" } } } [ ":ircserver.net MODE #factortest +o someuser" - parse-irc-line f >>timestamp ] unit-test + string>irc-message f >>timestamp ] unit-test { T{ nick { line ":someuser!n=user@some.where NICK :someuser2" } @@ -62,9 +54,9 @@ IN: irc.messages.tests { parameters { } } { trailing "someuser2" } } } [ ":someuser!n=user@some.where NICK :someuser2" - parse-irc-line f >>timestamp ] unit-test + string>irc-message f >>timestamp ] unit-test -{ T{ nick-in-use +{ T{ rpl-nickname-in-use { line ":ircserver.net 433 * nickname :Nickname is already in use" } { prefix "ircserver.net" } { command "433" } @@ -72,4 +64,4 @@ IN: irc.messages.tests { name "nickname" } { trailing "Nickname is already in use" } } } [ ":ircserver.net 433 * nickname :Nickname is already in use" - parse-irc-line f >>timestamp ] unit-test \ No newline at end of file + string>irc-message f >>timestamp ] unit-test \ No newline at end of file diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index c88bbc072a..e0f9a15eff 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,179 +1,63 @@ ! Copyright (C) 2008 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry splitting ascii calendar accessors combinators - arrays classes.tuple math.order ; -RENAME: join sequences => sjoin + arrays classes.tuple math.order words assocs strings + irc.messages.base ; EXCLUDE: sequences => join ; IN: irc.messages -TUPLE: irc-message line prefix command parameters trailing timestamp ; -TUPLE: logged-in < irc-message name ; -TUPLE: ping < irc-message ; -TUPLE: join < irc-message ; -TUPLE: part < irc-message channel ; -TUPLE: quit < irc-message ; -TUPLE: nick < irc-message ; -TUPLE: privmsg < irc-message name ; -TUPLE: kick < irc-message channel who ; -TUPLE: roomlist < irc-message channel names ; -TUPLE: nick-in-use < irc-message name ; -TUPLE: notice < irc-message type ; -TUPLE: mode < irc-message name mode parameter ; -TUPLE: names-reply < irc-message who channel ; -TUPLE: end-of-names < irc-message who channel ; -TUPLE: unhandled < irc-message ; - -: ( command parameters trailing -- irc-message ) - irc-message new - now >>timestamp - swap >>trailing - swap >>parameters - swap >>command ; - -> ( irc-message -- string ) - -M: irc-message command-string>> ( irc-message -- string ) command>> ; -M: ping command-string>> ( ping -- string ) drop "PING" ; -M: join command-string>> ( join -- string ) drop "JOIN" ; -M: part command-string>> ( part -- string ) drop "PART" ; -M: quit command-string>> ( quit -- string ) drop "QUIT" ; -M: nick command-string>> ( nick -- string ) drop "NICK" ; -M: privmsg command-string>> ( privmsg -- string ) drop "PRIVMSG" ; -M: notice command-string>> ( notice -- string ) drop "NOTICE" ; -M: mode command-string>> ( mode -- string ) drop "MODE" ; -M: kick command-string>> ( kick -- string ) drop "KICK" ; - -GENERIC: command-parameters>> ( irc-message -- seq ) - -M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ; -M: ping command-parameters>> ( ping -- seq ) drop { } ; -M: join command-parameters>> ( join -- seq ) drop { } ; -M: part command-parameters>> ( part -- seq ) channel>> 1array ; -M: quit command-parameters>> ( quit -- seq ) drop { } ; -M: nick command-parameters>> ( nick -- seq ) drop { } ; -M: privmsg command-parameters>> ( privmsg -- seq ) name>> 1array ; -M: notice command-parameters>> ( norice -- seq ) type>> 1array ; -M: kick command-parameters>> ( kick -- seq ) - [ channel>> ] [ who>> ] bi 2array ; -M: mode command-parameters>> ( mode -- seq ) - [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; - -GENERIC# >>command-parameters 1 ( irc-message params -- irc-message ) - -M: irc-message >>command-parameters ( irc-message params -- irc-message ) - drop ; - -M: logged-in >>command-parameters ( part params -- part ) - first >>name ; - -M: privmsg >>command-parameters ( privmsg params -- privmsg ) - first >>name ; - -M: notice >>command-parameters ( notice params -- notice ) - first >>type ; - -M: part >>command-parameters ( part params -- part ) - first >>channel ; - -M: kick >>command-parameters ( kick params -- kick ) - first2 [ >>channel ] [ >>who ] bi* ; - -M: nick-in-use >>command-parameters ( nick-in-use params -- nick-in-use ) - second >>name ; - -M: names-reply >>command-parameters ( names-reply params -- names-reply ) - first3 nip [ >>who ] [ >>channel ] bi* ; - -M: end-of-names >>command-parameters ( names-reply params -- names-reply ) - first2 [ >>who ] [ >>channel ] bi* ; - -M: mode >>command-parameters ( mode params -- mode ) - dup length { - { 3 [ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* ] } - { 2 [ first2 [ >>name ] [ >>mode ] bi* ] } - [ drop first >>name dup trailing>> >>mode ] - } case ; - -PRIVATE> - -GENERIC: irc-message>client-line ( irc-message -- string ) - -M: irc-message irc-message>client-line ( irc-message -- string ) - [ command-string>> ] - [ command-parameters>> " " sjoin ] - [ trailing>> [ CHAR: : prefix ] [ "" ] if* ] - tri 3array " " sjoin ; - -GENERIC: irc-message>server-line ( irc-message -- string ) - -M: irc-message irc-message>server-line ( irc-message -- string ) - drop "not implemented yet" ; - -> >>line ] - [ prefix>> >>prefix ] - [ command>> >>command ] - [ trailing>> >>trailing ] - [ timestamp>> >>timestamp ] - [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ] - } cleave ; - -PRIVATE> - -UNION: sender-in-prefix privmsg join part quit kick mode nick ; -GENERIC: irc-message-sender ( irc-message -- sender ) -M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) - prefix>> parse-name ; - -: string>irc-message ( string -- object ) - dup split-prefix split-trailing - [ [ blank? ] trim " " split unclip swap ] dip - now irc-message boa ; - -: irc-message>command ( irc-message -- command ) - [ - command>> { - { "PING" [ ping ] } - { "NOTICE" [ notice ] } - { "001" [ logged-in ] } - { "433" [ nick-in-use ] } - { "353" [ names-reply ] } - { "366" [ end-of-names ] } - { "JOIN" [ join ] } - { "PART" [ part ] } - { "NICK" [ nick ] } - { "PRIVMSG" [ privmsg ] } - { "QUIT" [ quit ] } - { "MODE" [ mode ] } - { "KICK" [ kick ] } - [ drop unhandled ] - } case new - ] keep copy-message-in ; - -: parse-irc-line ( string -- message ) - string>irc-message irc-message>command ; +! connection +IRC: pass "PASS" password ; +IRC: nick "NICK" nickname ; +IRC: user "USER" user mode _ : realname ; +IRC: oper "OPER" name password ; +IRC: mode "MODE" name mode parameter ; +IRC: service "SERVICE" nickname _ distribution type _ : info ; +IRC: quit "QUIT" : comment ; +IRC: squit "SQUIT" server : comment ; +! channel operations +IRC: join "JOIN" channel ; +IRC: part "PART" channel : comment ; +IRC: topic "TOPIC" channel : topic ; +IRC: names "NAMES" channel ; +IRC: list "LIST" channel ; +IRC: invite "INVITE" nickname channel ; +IRC: kick "KICK" channel user : comment ; +! chating +IRC: privmsg "PRIVMSG" target : text ; +IRC: notice "NOTICE" target : text ; +! server queries +IRC: motd "MOTD" target ; +IRC: lusers "LUSERS" mask target ; +IRC: version "VERSION" target ; +IRC: stats "STATS" query target ; +IRC: links "LINKS" server mask ; +IRC: time "TIME" target ; +IRC: connect "CONNECT" server port remote-server ; +IRC: trace "TRACE" target ; +IRC: admin "ADMIN" target ; +IRC: info "INFO" target ; +! service queries +IRC: servlist "SERVLIST" mask type ; +IRC: squery "SQUERY" service-name : text ; +! user queries +IRC: who "WHO" mask operator ; +IRC: whois "WHOIS" target mask ; +IRC: whowas "WHOWAS" nickname count target ; +! misc +IRC: kill "KILL" nickname : comment ; +IRC: ping "PING" server1 server2 ; +IRC: pong "PONG" server1 server2 ; +IRC: error "ERROR" : message ; +! numeric replies +IRC: rpl-welcome "001" nickname : comment ; +IRC: rpl-whois-user "311" nicnamek user host _ : real-name ; +IRC: rpl-channel-modes "324" channel mode params ; +IRC: rpl-notopic "331" channel : topic ; +IRC: rpl-topic "332" channel : topic ; +IRC: rpl-inviting "341" channel nickname ; +IRC: rpl-names "353" nickname _ channel : nicks ; +IRC: rpl-names-end "366" nickname channel : comment ; +! error replies +IRC: rpl-nickname-in-use "433" _ name ; +IRC: rpl-nick-collision "436" nickname : comment ; diff --git a/extra/irc/messages/parser/authors.txt b/extra/irc/messages/parser/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/irc/messages/parser/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/irc/messages/parser/parser.factor b/extra/irc/messages/parser/parser.factor new file mode 100644 index 0000000000..1fa07fc772 --- /dev/null +++ b/extra/irc/messages/parser/parser.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: kernel fry splitting ascii calendar accessors combinators + arrays classes.tuple math.order words assocs + irc.messages.base sequences ; +IN: irc.messages.parser + +> [ remove-heading-: "!" split-at-first drop ] [ f ] if* ; +PRIVATE> + +: string>irc-message ( string -- irc-message ) + dup split-message + [ [ irc>type new ] [ >>command ] bi ] + [ >>parameters ] + [ >>trailing ] + tri* + [ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri + now >>timestamp dup sender >>sender ; diff --git a/extra/irc/messages/parser/summary.txt b/extra/irc/messages/parser/summary.txt new file mode 100644 index 0000000000..7ec732aae1 --- /dev/null +++ b/extra/irc/messages/parser/summary.txt @@ -0,0 +1 @@ +Basic parser for irc messages diff --git a/extra/irc/messages/summary.txt b/extra/irc/messages/summary.txt new file mode 100644 index 0000000000..cf3a8ae07a --- /dev/null +++ b/extra/irc/messages/summary.txt @@ -0,0 +1 @@ +IRC message definitions From 5bfe50018e0d918944bc05c7b2dea4cc2c59e741 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 7 Mar 2009 16:14:49 -0200 Subject: [PATCH 158/772] irc.messages: Update tests --- extra/irc/messages/messages-tests.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index abe94de8ef..d88eeabc73 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -13,7 +13,8 @@ IN: irc.messages.tests { parameters { "#factortest" } } { trailing "hi" } { target "#factortest" } - { text "hi" } } } + { text "hi" } + { sender "someuser" } } } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" string>irc-message f >>timestamp ] unit-test @@ -22,7 +23,8 @@ IN: irc.messages.tests { prefix "someuser!n=user@some.where" } { command "JOIN" } { parameters { } } - { trailing "#factortest" } } } + { trailing "#factortest" } + { sender "someuser" } } } [ ":someuser!n=user@some.where JOIN :#factortest" string>irc-message f >>timestamp ] unit-test @@ -52,7 +54,8 @@ IN: irc.messages.tests { prefix "someuser!n=user@some.where" } { command "NICK" } { parameters { } } - { trailing "someuser2" } } } + { trailing "someuser2" } + { sender "someuser" } } } [ ":someuser!n=user@some.where NICK :someuser2" string>irc-message f >>timestamp ] unit-test From 527b50fa5691601997284c2b9d082e0e4d43b01b Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 7 Mar 2009 20:43:25 -0200 Subject: [PATCH 159/772] irc.client: Fix strings>privmsg, add test --- extra/irc/client/client-tests.factor | 5 +++++ extra/irc/client/client.factor | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 4f25531eee..07b9df2ab7 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -58,6 +58,11 @@ M: mb-writer dispose drop ; string>irc-message forward-name ] unit-test ] with-irc +{ privmsg "#channel" "hello" } [ + "#channel" "hello" strings>privmsg + [ class ] [ target>> ] [ trailing>> ] tri +] unit-test + ! Test login and nickname set [ { "factorbot2" } [ ":some.where 001 factorbot2 :Welcome factorbot2" %push-line diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 7986a726ba..c7e90eb802 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -313,7 +313,7 @@ DEFER: (connect-irc) [ forward-message ] [ process-message ] [ irc-end? not ] tri ; : strings>privmsg ( name string -- privmsg ) - privmsg new [ (>>trailing) ] keep [ (>>target) ] keep ; + " :" prepend append "PRIVMSG " prepend string>irc-message ; : maybe-annotate-with-name ( name obj -- obj ) { { [ dup string? ] [ strings>privmsg ] } From f3577572ec75ccd4703881233663f505edbf84ad Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 7 Mar 2009 20:54:28 -0200 Subject: [PATCH 160/772] irc.client: add test --- extra/irc/client/client-tests.factor | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 07b9df2ab7..9e96cc249b 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -34,6 +34,7 @@ M: mb-writer dispose drop ; : %add-named-chat ( chat -- ) irc> attach-chat ; : %push-line ( line -- ) irc> stream>> in>> push-line yield ; : %join ( channel -- ) irc> attach-chat ; +: %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ; : read-matching-message ( chat quot: ( msg -- ? ) -- irc-message ) [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; @@ -79,8 +80,7 @@ M: mb-writer dispose drop ; ! Test join [ { "JOIN #factortest" } [ - "#factortest" %join - irc> stream>> out>> lines>> pop + "#factortest" %join %pop-output-line ] unit-test ] with-irc @@ -221,3 +221,10 @@ M: mb-writer dispose drop ; [ participant-changed? ] read-matching-message ] unit-test ] with-irc + +! Send privmsg +[ { "PRIVMSG #factortest :hello" } [ + "#factortest" [ %add-named-chat ] keep + "hello" swap speak %pop-output-line + ] unit-test +] with-irc From 93a3c18c59b99ec86be5f5d52e9e853eaed4e6eb Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Fri, 20 Mar 2009 10:15:13 -0300 Subject: [PATCH 161/772] irc.client: Make to-chat work with sequences --- extra/irc/client/client.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index c7e90eb802..ee46cd954a 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -104,6 +104,7 @@ M: string to-chat [ to-chat ] [ drop ] if* ; M: irc-chat to-chat in-messages>> mailbox-put ; +M: sequence to-chat [ to-chat ] with each ; : unregister-chat ( name -- ) irc> chats>> @@ -123,9 +124,6 @@ M: irc-chat to-chat in-messages>> mailbox-put ; [ dup irc-channel-chat? [ participants>> key? ] [ 2drop f ] if ] with filter ; -: to-chats-with-participant ( message nickname -- ) - chats-with-participant [ to-chat ] with each ; - : remove-participant-from-all ( nick -- ) dup chats-with-participant [ (remove-participant) ] with each ; @@ -199,7 +197,7 @@ M: irc-message forward-message M: single-forward forward-message dup forward-name to-chat ; M: multiple-forward forward-message - dup sender>> to-chats-with-participant ; + dup sender>> chats-with-participant to-chat ; M: broadcast-forward forward-message irc> chats>> values [ to-chat ] with each ; From 4cc3dfb3c5e8662708937cd9f01b411946aff72b Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 21 Mar 2009 19:45:18 -0300 Subject: [PATCH 162/772] irc.client: Fix, don't try to USE 'call' --- extra/irc/client/client.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index ee46cd954a..f2d671e30d 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -3,7 +3,7 @@ USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar accessors destructors namespaces io assocs arrays fry continuations threads strings classes combinators splitting hashtables - ascii irc.messages irc.messages.base irc.messages.parser call ; + ascii irc.messages irc.messages.base irc.messages.parser ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.client From 4d722001e9a4e2c2010731b91bc6577f91bd4841 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Wed, 8 Apr 2009 23:26:58 -0300 Subject: [PATCH 163/772] irc.messages: use SYNTAX: instead of parsing --- extra/irc/messages/base/base.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/irc/messages/base/base.factor b/extra/irc/messages/base/base.factor index 7350ef9320..d67d226d9b 100644 --- a/extra/irc/messages/base/base.factor +++ b/extra/irc/messages/base/base.factor @@ -108,8 +108,8 @@ PRIVATE> #! SYNTAX: #! IRC: type "COMMAND" slot1 ...; #! IRC: type "COMMAND" slot1 ... : trailing-slot; -: IRC: ( name string parameters -- ) +SYNTAX: IRC: ( name string parameters -- ) CREATE-CLASS [ scan-object register-irc-message-type ] keep ";" parse-tokens - [ define-irc-class ] [ define-irc-parameter-slots ] 2bi ; parsing + [ define-irc-class ] [ define-irc-parameter-slots ] 2bi ; From 2b384a7742b55ccaf59bde905798fb7cba15c5b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 8 Apr 2009 23:05:45 -0500 Subject: [PATCH 164/772] Re-organize some error-related code, three-pane look for compiler errors tool, add Joe's icons --- basis/debugger/debugger.factor | 4 +- basis/editors/editors.factor | 3 + .../errors/prettyprint/prettyprint.factor | 84 ++++++----- basis/ui/tools/browser/browser.factor | 6 +- .../compiler-errors/compiler-errors.factor | 131 ++++++++++++++---- basis/ui/tools/debugger/debugger.factor | 4 +- .../error-list/icons/compiler-error.tiff | Bin 0 -> 1298 bytes .../error-list/icons/compiler-warning.tiff | Bin 0 -> 1194 bytes .../error-list/icons/help-lint-error.tiff | Bin 0 -> 1060 bytes basis/ui/tools/error-list/icons/note.tiff | Bin 0 -> 784 bytes .../tools/error-list/icons/syntax-error.tiff | Bin 0 -> 1260 bytes .../error-list/icons/unit-test-error.tiff | Bin 0 -> 1258 bytes basis/ui/tools/operations/operations.factor | 5 +- 13 files changed, 165 insertions(+), 72 deletions(-) create mode 100644 basis/ui/tools/error-list/icons/compiler-error.tiff create mode 100644 basis/ui/tools/error-list/icons/compiler-warning.tiff create mode 100644 basis/ui/tools/error-list/icons/help-lint-error.tiff create mode 100644 basis/ui/tools/error-list/icons/note.tiff create mode 100644 basis/ui/tools/error-list/icons/syntax-error.tiff create mode 100644 basis/ui/tools/error-list/icons/unit-test-error.tiff diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index fd7696576b..04f43043b5 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -309,7 +309,7 @@ M: lexer-error compute-restarts M: lexer-error error-help error>> error-help ; -M: object compiler-error. ( error -- ) +M: compiler-error compiler-error. ( error -- ) [ [ [ @@ -324,6 +324,8 @@ M: object compiler-error. ( error -- ) ] bi format nl ] [ error>> error. ] bi ; +M: compiler-error error. compiler-error. ; + M: bad-effect summary drop "Bad stack effect declaration" ; diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index 0003b508fb..327cdea3c1 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -81,6 +81,9 @@ M: object error-line : :edit ( -- ) error get (:edit) ; +: edit-error ( error -- ) + [ file>> ] [ line#>> ] bi edit-location ; + : edit-each ( seq -- ) [ [ "Editing " write . ] diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index a71af74871..c111f3bb9f 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel prettyprint io debugger -sequences assocs stack-checker.errors summary effects ; +sequences assocs stack-checker.errors summary effects make ; IN: stack-checker.errors.prettyprint M: inference-error summary error>> summary ; @@ -11,11 +11,16 @@ M: inference-error error-help error>> error-help ; M: inference-error error. [ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ; -M: literal-expected error. - "Got a computed value where a " write what>> write " was expected" print ; +M: literal-expected summary + [ "Got a computed value where a " % what>> % " was expected" % ] "" make ; + +M: literal-expected error. summary print ; + +M: unbalanced-branches-error summary + drop "Unbalanced branches" ; M: unbalanced-branches-error error. - "Unbalanced branches:" print + dup summary print [ quots>> ] [ branches>> [ length ] { } assoc>map ] bi zip [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ; @@ -27,16 +32,18 @@ M: too-many-r> summary drop "Quotation pops retain stack elements which it did not push" ; -M: missing-effect error. - "The word " write - word>> pprint - " must declare a stack effect" print ; +M: missing-effect summary + [ + "The word " % + word>> name>> % + " must declare a stack effect" % + ] "" make ; -M: effect-error error. - "Stack effects of the word " write - [ word>> pprint " do not match." print ] - [ "Inferred: " write inferred>> . ] - [ "Declared: " write declared>> . ] tri ; +M: effect-error summary + [ + "Stack effect declaration of the word " % + word>> name>> % " is wrong" % + ] "" make ; M: recursive-quotation-error error. "The quotation " write @@ -44,26 +51,31 @@ M: recursive-quotation-error error. " calls itself." print "Stack effect inference is undecidable when quotation-level recursion is permitted." print ; -M: undeclared-recursion-error error. - "The inline recursive word " write - word>> pprint - " must be declared recursive" print ; - -M: diverging-recursion-error error. - "The recursive word " write - word>> pprint - " digs arbitrarily deep into the stack" print ; - -M: unbalanced-recursion-error error. - "The recursive word " write - word>> pprint - " leaves with the stack having the wrong height" print ; - -M: inconsistent-recursive-call-error error. - "The recursive word " write - word>> pprint - " calls itself with a different set of quotation parameters than were input" print ; - -M: unknown-primitive-error error. +M: undeclared-recursion-error summary drop - "Cannot determine stack effect statically" print ; + "Inline recursive words must be declared recursive" ; + +M: diverging-recursion-error summary + [ + "The recursive word " % + word>> name>> % + " digs arbitrarily deep into the stack" % + ] "" make ; + +M: unbalanced-recursion-error summary + [ + "The recursive word " % + word>> name>> % + " leaves with the stack having the wrong height" % + ] "" make ; + +M: inconsistent-recursive-call-error summary + [ + "The recursive word " % + word>> name>> % + " calls itself with a different set of quotation parameters than were input" % + ] "" make ; + +M: unknown-primitive-error summary + drop + "Cannot determine stack effect statically" ; diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index 0c6e1fe05a..a493d5d7d2 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: debugger help help.topics help.crossref help.home kernel models +USING: debugger classes help help.topics help.crossref help.home kernel models compiler.units assocs words vocabs accessors fry arrays combinators.short-circuit namespaces sequences models help.apropos combinators ui ui.commands ui.gadgets ui.gadgets.panes @@ -91,6 +91,10 @@ M: browser-gadget focusable-child* search-field>> ; : browser-window ( -- ) "help.home" (browser-window) ; +: error-help-window ( error -- ) + [ error-help ] + [ dup tuple? [ class ] [ drop "errors" ] if ] bi or (browser-window) ; + \ browser-window H{ { +nullary+ t } } define-command : com-browse ( link -- ) diff --git a/basis/ui/tools/compiler-errors/compiler-errors.factor b/basis/ui/tools/compiler-errors/compiler-errors.factor index 6efb5586ba..45eb3dee5b 100644 --- a/basis/ui/tools/compiler-errors/compiler-errors.factor +++ b/basis/ui/tools/compiler-errors/compiler-errors.factor @@ -1,14 +1,18 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays sequences sorting assocs colors.constants combinators -combinators.smart compiler.errors compiler.units fonts kernel io.pathnames -math.parser math.order models models.arrow namespaces summary ui -ui.commands ui.gadgets ui.gadgets.tables ui.gadgets.tracks -ui.gestures ui.operations ui.tools.browser ui.tools.common -ui.gadgets.scrollers ; +USING: accessors arrays sequences sorting assocs colors.constants +combinators combinators.smart combinators.short-circuit editors +compiler.errors compiler.units fonts kernel io.pathnames +stack-checker.errors math.parser math.order models models.arrow +models.search debugger namespaces summary locals ui ui.commands +ui.gadgets ui.gadgets.panes ui.gadgets.tables ui.gadgets.labeled +ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser +ui.tools.common ui.gadgets.scrollers ui.tools.inspector +ui.gadgets.status-bar ui.operations ui.gadgets.buttons +ui.gadgets.borders ui.images ; IN: ui.tools.compiler-errors -TUPLE: error-list-gadget < tool table ; +TUPLE: error-list-gadget < tool source-file error source-file-table error-table error-display ; SINGLETON: source-file-renderer @@ -16,60 +20,133 @@ M: source-file-renderer row-columns drop [ first2 length number>string 2array ] [ { "All" "" } ] if* ; M: source-file-renderer row-value - drop first ; + drop dup [ first ] when ; M: source-file-renderer column-titles drop { "File" "Errors" } ; -: ( model -- table ) - [ group-by-source-file >alist sort-keys f prefix ] - source-file-renderer +M: source-file-renderer column-alignment drop { 0 1 } ; + +M: source-file-renderer filled-column drop 0 ; + +: ( model -- model' ) + [ group-by-source-file >alist sort-keys f prefix ] ; + +:: ( error-list -- table ) + error-list model>> + source-file-renderer +
[ invoke-primary-operation ] >>action COLOR: dark-gray >>column-line-color - { 1 f } >>column-widths 6 >>gap 30 >>min-rows 30 >>max-rows - 80 >>min-cols - 80 >>max-cols ; + 60 >>min-cols + 60 >>max-cols + t >>selection-required? + error-list source-file>> >>selected-value ; SINGLETON: error-renderer +GENERIC: error-icon ( error -- icon ) + +: ( name -- image-name ) + "vocab:ui/tools/error-list/icons/" ".tiff" surround ; + +M: inference-error error-icon + type>> { + { +error+ [ "compiler-error" ] } + { +warning+ [ "compiler-warning" ] } + } case ; + +M: object error-icon drop "HAI" ; + +M: compiler-error error-icon error>> error-icon ; + M: error-renderer row-columns drop [ { - [ file>> ] + [ error-icon ] [ line#>> number>string ] [ word>> name>> ] [ error>> summary ] } cleave ] output>array ; +M: error-renderer prototype-row + drop [ "compiler-error" "" "" "" ] output>array ; + M: error-renderer row-value drop ; M: error-renderer column-titles - drop { "File" "Line" "Word" "Error" } ; + drop { "" "Line" "Word" "Error" } ; -: ( model -- table ) - [ [ [ [ file>> ] [ line#>> ] bi 2array ] compare ] sort ] - error-renderer
+M: error-renderer column-alignment drop { 0 1 0 0 } ; + +: sort-errors ( seq -- seq' ) + [ [ [ file>> ] [ line#>> ] bi 2array ] compare ] sort ; + +: ( error-list -- model ) + [ model>> [ values ] ] [ source-file>> ] bi + [ swap { [ drop not ] [ [ string>> ] [ file>> ] bi* = ] } 2|| ] + [ sort-errors ] ; + +:: ( error-list -- table ) + error-list + error-renderer +
[ invoke-primary-operation ] >>action COLOR: dark-gray >>column-line-color 6 >>gap 30 >>min-rows 30 >>max-rows - 80 >>min-cols - 80 >>max-cols ; + 60 >>min-cols + 60 >>max-cols + t >>selection-required? + error-list error>> >>selected-value ; -: ( model -- gadget ) +TUPLE: error-display < track ; + +: ( error-list -- gadget ) + vertical error-display new-track + add-toolbar + swap error>> >>model + dup model>> [ print-error ] 1 track-add ; + +: com-inspect ( error-display -- ) + model>> value>> inspector ; + +: com-help ( error-display -- ) + model>> value>> error>> error-help-window ; + +: com-edit ( error-display -- ) + model>> value>> edit-error ; + +error-display "toolbar" f { + { f com-inspect } + { f com-help } + { f com-edit } +} define-command-map + +:: ( model -- gadget ) vertical error-list-gadget new-track - { 3 3 } >>gap - swap >>table - dup table>> 1/2 track-add ; + model >>model + f >>source-file + f >>error + dup >>source-file-table + dup >>error-table + dup >>error-display + :> error-list + error-list vertical + { 5 5 } >>gap + error-list source-file-table>> "Source files" 1/4 track-add + error-list error-table>> "Errors" 1/2 track-add + error-list error-display>> "Details" 1/4 track-add + { 5 5 } 1 track-add ; M: error-list-gadget focusable-child* - table>> ; + source-file-table>> ; : error-list-help ( -- ) "ui-error-list" com-browse ; @@ -96,4 +173,4 @@ updater add-definition-observer : error-list-window ( -- ) compiler-error-model get-global - "Compiler errors" open-window ; \ No newline at end of file + "Compiler errors" open-status-window ; \ No newline at end of file diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor index c3ead4e3f5..e1e176a8c4 100644 --- a/basis/ui/tools/debugger/debugger.factor +++ b/basis/ui/tools/debugger/debugger.factor @@ -86,9 +86,7 @@ debugger "gestures" f { : com-traceback ( debugger -- ) continuation>> traceback-window ; -: com-help ( debugger -- ) error>> (:help) ; - -\ com-help H{ { +listener+ t } } define-command +: com-help ( debugger -- ) error>> error-help-window ; : com-edit ( debugger -- ) error>> (:edit) ; diff --git a/basis/ui/tools/error-list/icons/compiler-error.tiff b/basis/ui/tools/error-list/icons/compiler-error.tiff new file mode 100644 index 0000000000000000000000000000000000000000..1d6b1575ee480a2672e42742026ad473cd40343d GIT binary patch literal 1298 zcmebD)MD7i%)roK|GzyZaF7QQ^q3ddY$&wcT#%3hGa{qaw3)dlWPLZnpW{57YZj&yV6Ffi0< z-leX4x~r!y`4>2d*v{Z|W2XZIG%vmCzjF=X}K#rj+)Zf^)(Jx$rz z@$9`d-|zfgwS3a{mqu4&ZJL97%53K^U|YQM^V%lo1uc#OIt;=r4X>>JiUo5z-a7Q{ z=dI?Kzy34GPk*<8Nw?<>gZ*xifaxj>Gu7A}SRDhbV{>j~eA?vKGb=FpT-L{nSAIJ_ zVBm4>JTs|r#RP^lo`V7m!b}N9VzYJIIUm$6c(6lkOZ!vK12^{N7_qflYz$3eMq&Yy$0~JOFYc;Rc=BSdIH#jl%8#9AwVe4k>hJn=%=naI zQqEDQk8wo}>=QrLD?eOe!qUL%v5Jp@kwbxL!NWsq7=%3=7?>FnxcCH{0t&boea~{M z9XxS>$yH$ED$Px0^Bouxe54mJReW5bxMUlHBv%5X*@DT2`xr!-mK+f9$<%qvXZf+h zioIdUoEg`&7cC4aVqnc&S84QAVi9ix(}NiH29c?n-V7o~PVBer+Ig&EesY!)qYP`t z8b0Pn25vJA9~_j(WnlMwwaxIcMH)u~;{_{L29}M}%EP|wHQISR@WJxnIcBom$v4fS z-pt$05XqCnz_(T4P?w^E6ob_A=sNxo29{d!1kqauiyFi&PZTUz%xWKSCI8kgY2lKY z(~9NZ?Br5pI>7KnuBne%F>c<}zs0zvv$g!D^cKe=CbPjJ|dYkrrgUGYH{Bf`Og8np4aT7EzopXx!x`hLK;&p}1 zDR*o3US1@4WSf_|RR71HLbmsuSACgq=!cyU=cC}&+v^rpT7J8^+Cr}C;ENS<>2BwL z-E;T5>c3BZ`O!)b`(3AhOG-a@_GiA9@aG-8UU4&)Wv+KU`uCE(_n(Cw1xzj+6Gar3 zMDz$QviQ&Okx_(!fsvVkk%56h0f-rq*i1k+3s7tgkYI+2vjX{SP&N~g%>`wH^z$+@ zF#t_t*aB29$jAaVlLN>XLQ*3NWrNHWgR&ifY;maib-?mNijftp_XJRpG?aY-$d*Ae zM+3?RDrYbR+G_=*ZvfTULd8LD^MaZQWHJOHiG%nYP?(&bTacNPTBMs=RFq$&SCW~Q z#?Wx+YXwk=1B~{}O-xVqO-#>B&Q>tfGto0pFfi9QG}1S)PzW?MQ^+VODX`MlFE20G Q%LJ(eVxUUB{GxOQ0AD@BApigX literal 0 HcmV?d00001 diff --git a/basis/ui/tools/error-list/icons/compiler-warning.tiff b/basis/ui/tools/error-list/icons/compiler-warning.tiff new file mode 100644 index 0000000000000000000000000000000000000000..b50afa45f963269d4343eac280be291b90c33f2d GIT binary patch literal 1194 zcmebD)MD^qW?*Qrf8fBOBF4+!;*=P$BY;gNfsL7ggTwgZOW{WQD*`8;l-Y9h9DfpI zVW1$uXxrL!fca3N1w*H!Pn!et#VfBEl;ru_e~Ee8_j_cBSlG-8)S6~AGnnB(lE8}+ zN4CS6Ywi_W&%3DYz$KdJ?l$Grd68AAR<;2vL)9*KUinlTH!(af~J5eTMp`Q zb9`B_AzN&%m}(b?KKBX5CzZ+%S7bGbs(NtelA*xGw4h(v zUQ}TvPs~}3w3C~f*ch8Q=B{>JkkKT`=ET9+kfGAnB+BZS*V4afD4>bJHzwLDPesrXCF}x6RLKDWBwPV9ruvkP%^E;O{tOY<5;w-P_E#=Y>Lv ztU}91T{GVUEDv@b;ZRtn*}%@L?sdWBsL2lb_D3A7jTy@G&UPtvab(R}pGUz!`P}`;>a{URuulEsE)LPw48;>g%8yQL zY7#kWCR(^-`kAo$#W$M7YUdZ~_%VpLKHB0c=%Mh+YJDY3&|}3uC(+5aCT5oXdb}4H z0;Xsv?9$s)x%sq~^3O|_;fEd{)9iX-PSCs)>+`teo*aC;d$((QjP;$TOY_d=9^SK|Mo4_$hugDu9w=oURtP8z|^7Sv52c%nM26@ied)`Fr*oo z85kKD7!-h*5sA$NWU~OpoPY!~RGbyaXM?htfNU-(8>F9?k%>VJNP7X*3o^2R&Ex>` zg^<*ULfIg5#h`2lAX^-&-UXPer5IVkdJ}+(q@nB#AX^5>91SQNsGPwNXs;EJE&!^r zg^GjR<^?qq$YcmY5(n`)pfEW0n$lHkbJslhw1sEyz0kf9cWYfb{Hb9ETH+A7$!Ld-pwX-}4QUT5S7Xs&9B^@?n#s635P%6cigzAkB3dbt=oO+6^8ryzOtlr_BBHkIm|_ z&ABMIueSX~HZQlYeZZj8t)Zm!+n#}W$9oH&>R*pk_?5UBHfCMnV6a_ZBh=*B;UdRi z_x_B=maX~R8jXj0XKm*{qVb_mc|prZnY{8V*uy3tBprnwT7>ggrRA{u74* z^MV%)p4^!&4&l%78z~J{KirdzI@~4Lm0U?TqnobE#S@C&uNv;e- z5ChAv`$yZCTsB=|*t2F)@Rd^M!2JcQTdoPL(GBIdEo9jo?q4dZ(zm})I%=J>hil#> zHpfXE=`+9lsg!46DU@l8FkQ@}ILT?`BlES6sj$}wo& zaU!%oUAt^e%#Pb!zbEYW+P*lrY>!Y;eZ`XSxqq7DZU}WYssAt)Z@K&Go5Z5T(`|~0 z8*a?jt-W0!)Y!czc%8|?M{Axjaz7R+b36NJCmX-`{GYW?`&2uN5}MV@%YtX7mKDh` zEaI4Yp-Jh)A(q}}9#Kpp3=E9S42%p63<^NZh{R?BvRQy)dzcv*n4#jVKt3Ck4NUqB zTu?ShKQAK_gD8+b0#q-^$O1N#1IQObQX>jwgUl6!vK@eIaj5!zKtrV%S;2a50nL$y zvL6B2GDzlVK-oZH21B5|RzUg{kYfuK2f57)Y9^4$5QHQS;&VV@MruxhZcb)iiEe69 zQGStLNoHCaFh?KyS^-q#0HZx~6Vp?D6Vo%3vlYzrO!N#C49xWnjr0vH6ao#+6f#Om Y3as??%gf94GC?YV7^qS&zbKsn087SP5&!@I literal 0 HcmV?d00001 diff --git a/basis/ui/tools/error-list/icons/note.tiff b/basis/ui/tools/error-list/icons/note.tiff new file mode 100644 index 0000000000000000000000000000000000000000..01c328f09ed1292af787a28dc3639182ad2c8c0a GIT binary patch literal 784 zcmebD)M7Zs$iUEGe?Y)OMU0od#VIjhhYyz|e}_xrhZj@AbOpLx9|!JGN#kG?X%^}a zV*bM_)4>pbU>oy=8~?KpKE7a(_2rnOU4!GKj^+yt&GpNtzgLnuCBRg->wu%>lh9iX zT>IxAuriTh`d{6^C~{-+0|rh8`vayCrg592yZ0U7{J?6kTwr~KPMC-8tgTW33_J=9 z7L3mrm=5ciNy|v3G3<^~I=O&x4ud^|fu86e)l2pfyN}&!V02*MoV+tJVMmQ`k#h6S zhYO`5R&QYFXE0&lmigAKy=rxuVZc`lhC2+`9qutO)ZGqVeD&SJ{yQ0ruNZO~Bp)!E zJMEtG_;{sRMY9WoJ_Dx%?*YaY3{zjfD7s*q;&_dL+fnoYQ~&b(6L-EVX&W$F3p`+8 znEd9=f?VY(9sLfBeDAkuY!0|+?SI;+gFS(yIHXVO!BrfNf zp*3Nt=AIFD!plz$3pFOba+s*nX>wrG(#)*58K;b64jew`_2i}1 z^2vKX^eHGXh%hiPGBW_9kwF278IjmbKsFOli~|Unq2jDSJ{yz`(!+(s=4E7J-~x*6 z0csLtWC5GW0ptrIsS$;;LFS4<*$qIpI8^;!prKNXtYE#zfQqD{>~lc243aq-P&PAA zuOZN0DB w&Q>tfGto0pFfi9QG}1S)PzW?MQ^+VODX`MlFE20G%LJ(eVxUUB{GxOQ0ECd++W-In literal 0 HcmV?d00001 diff --git a/basis/ui/tools/error-list/icons/syntax-error.tiff b/basis/ui/tools/error-list/icons/syntax-error.tiff new file mode 100644 index 0000000000000000000000000000000000000000..869cfe7ffa30e5eee03e272d717734cf26c33970 GIT binary patch literal 1260 zcmebD)MA*#%)roK|GzyZaF7QQ^q3ddY$&wcT#%3hGa{qaw3)dlWPLZnpW{57YZj&yV6Ffi0< z-leX4x~r!y`4>2d*v{Z|W2XZIG%vmCzjF=X}K#rj+)Zf^)(Jx$rz z@$9`d-|zfgwS3a{mqu4&ZJL97&Ku0pPhj5p?r(Gd5rzc}E&|MxR^R3~VCk5l#@4`a zz<|#=e$lB!4eN-w`_^lk_=4AdU{*Zwy?NuABmss87MznNgy;z{GamTLz}LLTO|!#c z#jZEA*)A>Nd*m}kC+Bh4aYcRM6Z@w=+F`}Oa$p7z1EYfm%cObiha0p-(-j!vX1_mp z!0jQaIVJ;8L zO+_D@v|~#)ZYg-+Uiezh;Y0%?qXL7F$wXDpjxTd=9OKY()!ckaWv$Fxfb6$M61H%En#s`{ecWk(H?(4Ys?378KyMW=I zVgD{ySXA`y;XL=GA0@NNK%< zc_A_hj3HXh4GgP98Bgh)_r1J1Mqtl{={BoA9{b#S<938|M^XW8_d=A!@#WLA>dK zlb4NndjO;3+ye|+td{Hy50@$2X!Dwsb?#khLj&{9N{`vy0I%(*0Ii1wF67{0p z@Yy!r#0@G8918`+UZ)h*Tw0K?@oi&cl;nKlmCsJ8TTT4@m+$qgB;8rhFRzgGmf!8g zo1d`gn-_oP*)O)cP4_;!Y#zD$YveBWNAJDdw53XG<+86=3WxWB+J>pfpo zb(q&aT6lmT&fZdGW;yMVhehXr3g&$Xp-v>aOiNGAGq)N21)H6KC2s> zb&|LgIXo2ip zRw#09?_TtZgQ;QF#hhq`<{j^v~D_3ZJSbO{EtMW)4@^*Roj>|^lJQ1l2= zXc1&-Vo$uq5j16mqJoD)^M}7q7ap)!G%+!>wl#~pUgFT~N?<%3H%Ih`eZuV*zHv=# z4|j2>bDmIi3tZ4TF{LSXdX{*>opQ}XO_zF~>NDIwVHp&%pjqNr6VGBT4)=*aye-Xi zL(i65>^!~Iuw{;g1cLwzhf-|Y!ylVCJ+`)Jb6W-*{g7i{(8^@SU{m22DWR}&n$?kq zLO(i`6q+phZf`gGSFWL`m*hQvm(Xf8YrYeTOEMK&4;Gw#SzIN)T+y=WIrBa72@GnS z9ST3}6j}{^ns}R2cjhZry^dON%Jbim9a3st9CrOH6nL1e`7SUN&Dr>-uKC@$AomSs zQq8_A4Xy_7`_LfpC+g49U&*n1)=A&mQ$6p6;+=AZh8yNnAIrSkv%ZK+-R0oNP3%dh ziz0q?-n#vFH~Y<#d$T8=kH7ob`~idPvrvl?xtQfAQ(ks)%=~(L|J-Nt|8_~VGiWra zbSbRZWYC!Q?~*`61A_`wH z^z$+@F^B@`E}(irMi#J{96-Jhk{VGc8)U8+l6z#mC>WUQ8ye{wSSSPz9|8>t%ve0x?jfUVc$J0|2f{ucrV2 literal 0 HcmV?d00001 diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor index 881808ea03..5da6402c8e 100644 --- a/basis/ui/tools/operations/operations.factor +++ b/basis/ui/tools/operations/operations.factor @@ -87,9 +87,6 @@ IN: ui.tools.operations } define-operation ! Compiler errors -: edit-error ( error -- ) - [ file>> ] [ line#>> ] bi edit-location ; - [ compiler-error? ] \ edit-error H{ { +primary+ t } { +secondary+ t } @@ -191,4 +188,4 @@ interactor "These commands operate on the entire contents of the input area." [ ] [ quot-action ] -define-operation-map +define-operation-map \ No newline at end of file From bc6dfeea17ff7a649fa2692ab7af38d8dc477f45 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Apr 2009 04:49:54 -0500 Subject: [PATCH 165/772] Move assert-sequence= from mime.multipart to sequences --- basis/mime/multipart/multipart.factor | 3 --- core/sequences/sequences.factor | 3 +++ 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor index 0edfb05a30..0cf7556bcd 100755 --- a/basis/mime/multipart/multipart.factor +++ b/basis/mime/multipart/multipart.factor @@ -137,9 +137,6 @@ ERROR: no-content-disposition multipart ; [ no-content-disposition ] } case ; -: assert-sequence= ( a b -- ) - 2dup sequence= [ 2drop ] [ assert ] if ; - : read-assert-sequence= ( sequence -- ) [ length read ] keep assert-sequence= ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 564309a6fb..b614c15150 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -568,6 +568,9 @@ M: sequence <=> 2dup [ length ] bi@ = [ mismatch not ] [ 2drop f ] if ; inline +: assert-sequence= ( a b -- ) + 2dup sequence= [ 2drop ] [ assert ] if ; + : sequence-hashcode-step ( oldhash newpart -- newhash ) >fixnum swap [ [ -2 fixnum-shift-fast ] [ 5 fixnum-shift-fast ] bi From 7adb76aaf4e5fee1985df1b09e6ad39b37aa69d0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Apr 2009 04:50:38 -0500 Subject: [PATCH 166/772] Factor out some compiler error code into source-files.errors --- basis/debugger/debugger.factor | 17 ++++----- .../errors/prettyprint/prettyprint.factor | 2 +- basis/tools/errors/authors.txt | 1 + basis/tools/errors/errors.factor | 25 ++++++++++++ core/compiler/errors/errors.factor | 38 +++++-------------- core/parser/parser-tests.factor | 2 +- core/parser/parser.factor | 1 + core/source-files/errors/authors.txt | 1 + core/source-files/errors/errors.factor | 12 ++++++ core/source-files/source-files.factor | 23 ++++++----- 10 files changed, 69 insertions(+), 53 deletions(-) create mode 100644 basis/tools/errors/authors.txt create mode 100644 basis/tools/errors/errors.factor create mode 100644 core/source-files/errors/authors.txt create mode 100644 core/source-files/errors/errors.factor diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 04f43043b5..202cf7eb5e 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -9,7 +9,8 @@ combinators generic.math classes.builtin classes compiler.units generic.standard vocabs init kernel.private io.encodings accessors math.order destructors source-files parser classes.tuple.parser effects.parser lexer compiler.errors -generic.parser strings.parser vocabs.loader vocabs.parser see ; +generic.parser strings.parser vocabs.loader vocabs.parser see +source-files.errors ; IN: debugger GENERIC: error. ( error -- ) @@ -268,11 +269,6 @@ M: duplicate-slot-names summary M: invalid-slot-name summary drop "Invalid slot name" ; -: file. ( file -- ) path>> . ; - -M: source-file-error error. - [ file>> file. ] [ error>> error. ] bi ; - M: source-file-error summary error>> summary ; @@ -309,12 +305,13 @@ M: lexer-error compute-restarts M: lexer-error error-help error>> error-help ; -M: compiler-error compiler-error. ( error -- ) +M: source-file-error error. [ [ [ - [ line#>> # ": " % ] - [ word>> synopsis % ] bi + [ file>> [ % ": " % ] when* ] + [ line#>> [ # ": " % ] when* ] + [ summary % ] tri ] "" make ] [ [ @@ -324,7 +321,7 @@ M: compiler-error compiler-error. ( error -- ) ] bi format nl ] [ error>> error. ] bi ; -M: compiler-error error. compiler-error. ; +M: compiler-error summary word>> synopsis ; M: bad-effect summary drop "Bad stack effect declaration" ; diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index c111f3bb9f..de73a3e731 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -41,7 +41,7 @@ M: missing-effect summary M: effect-error summary [ - "Stack effect declaration of the word " % + "Stack effect declaration of the word " % word>> name>> % " is wrong" % ] "" make ; diff --git a/basis/tools/errors/authors.txt b/basis/tools/errors/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/tools/errors/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor new file mode 100644 index 0000000000..a11b60d833 --- /dev/null +++ b/basis/tools/errors/errors.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs compiler.errors debugger io kernel sequences +source-files.errors ; +IN: tools.errors + +#! Tools for source-files.errors. Used by tools.tests and others +#! for error reporting + +: errors. ( errors -- ) + group-by-source-file sort-errors + [ + [ nl "==== " write print nl ] + [ [ nl ] [ error. ] interleave ] + bi* + ] assoc-each ; + +: compiler-errors. ( type -- ) + errors-of-type errors. ; + +: :errors ( -- ) +error+ compiler-errors. ; + +: :warnings ( -- ) +warning+ compiler-errors. ; + +: :linkage ( -- ) +linkage+ compiler-errors. ; diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor index f5e6fda646..9d8ab3deab 100644 --- a/core/compiler/errors/errors.factor +++ b/core/compiler/errors/errors.factor @@ -1,15 +1,13 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces make assocs io sequences -sorting continuations math math.order math.parser accessors -definitions ; +continuations math math.parser accessors definitions +source-files.errors ; IN: compiler.errors -SYMBOL: +error+ -SYMBOL: +warning+ -SYMBOL: +linkage+ +SYMBOLS: +error+ +warning+ +linkage+ ; -TUPLE: compiler-error error word file line# ; +TUPLE: compiler-error < source-file-error word ; GENERIC: compiler-error-type ( error -- ? ) @@ -17,8 +15,6 @@ M: object compiler-error-type drop +error+ ; M: compiler-error compiler-error-type error>> compiler-error-type ; -GENERIC: compiler-error. ( error -- ) - SYMBOL: compiler-errors compiler-errors [ H{ } clone ] initialize @@ -30,20 +26,6 @@ SYMBOL: with-compiler-errors? swap [ [ nip compiler-error-type ] dip eq? ] curry assoc-filter ; -: sort-compile-errors ( assoc -- alist ) - [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ; - -: group-by-source-file ( errors -- assoc ) - H{ } clone [ [ push-at ] curry [ nip dup file>> ] prepose assoc-each ] keep ; - -: compiler-errors. ( type -- ) - errors-of-type group-by-source-file sort-compile-errors - [ - [ nl "==== " write print nl ] - [ [ nl ] [ compiler-error. ] interleave ] - bi* - ] assoc-each ; - : (compiler-report) ( what type word -- ) over errors-of-type assoc-empty? [ 3drop ] [ [ @@ -62,14 +44,12 @@ SYMBOL: with-compiler-errors? "semantic warnings" +warning+ "warnings" (compiler-report) "linkage errors" +linkage+ "linkage" (compiler-report) ; -: :errors ( -- ) +error+ compiler-errors. ; - -: :warnings ( -- ) +warning+ compiler-errors. ; - -: :linkage ( -- ) +linkage+ compiler-errors. ; - : ( error word -- compiler-error ) - dup where [ first2 ] [ "" 0 ] if* \ compiler-error boa ; + \ compiler-error new + swap + [ >>word ] + [ where [ first2 ] [ "" 0 ] if* [ >>file ] [ >>line# ] bi* ] bi + swap >>error ; : compiler-error ( error word -- ) compiler-errors get-global pick diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 3ba414fe6b..9e1fcb95bd 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -3,7 +3,7 @@ io.streams.string namespaces classes effects source-files assocs sequences strings io.files io.pathnames definitions continuations sorting classes.tuple compiler.units debugger vocabs vocabs.loader accessors eval combinators lexer -vocabs.parser words.symbol multiline ; +vocabs.parser words.symbol multiline source-files.errors ; IN: parser.tests \ run-file must-infer diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 6d613a8b24..04fa7fa03f 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -190,6 +190,7 @@ SYMBOL: interactive-vocabs "tools.annotations" "tools.crossref" "tools.disassembler" + "tools.errors" "tools.memory" "tools.profiler" "tools.test" diff --git a/core/source-files/errors/authors.txt b/core/source-files/errors/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/core/source-files/errors/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/core/source-files/errors/errors.factor b/core/source-files/errors/errors.factor new file mode 100644 index 0000000000..9972a68446 --- /dev/null +++ b/core/source-files/errors/errors.factor @@ -0,0 +1,12 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel math.order sorting ; +IN: source-files.errors + +TUPLE: source-file-error error file line# ; + +: sort-errors ( assoc -- alist ) + [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ; + +: group-by-source-file ( errors -- assoc ) + H{ } clone [ [ push-at ] curry [ nip dup file>> ] prepose assoc-each ] keep ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index c8441ba3b0..8edd62260a 100644 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -4,7 +4,7 @@ USING: arrays definitions generic assocs kernel math namespaces sequences strings vectors words quotations io io.files io.pathnames combinators sorting splitting math.parser effects continuations checksums checksums.crc32 vocabs hashtables graphs -compiler.units io.encodings.utf8 accessors ; +compiler.units io.encodings.utf8 accessors source-files.errors ; IN: source-files SYMBOL: source-files @@ -77,21 +77,20 @@ M: pathname forget* SYMBOL: file -TUPLE: source-file-error error file ; - -: ( msg -- error ) +: wrap-source-file-error ( error -- * ) + file get rollback-source-file \ source-file-error new - file get >>file - swap >>error ; + f >>line# + file get path>> >>file + swap >>error rethrow ; : with-source-file ( name quot -- ) #! Should be called from inside with-compilation-unit. [ - swap source-file - dup file set - definitions>> old-definitions set [ - file get rollback-source-file - rethrow - ] recover + source-file + [ file set ] + [ definitions>> old-definitions set ] bi + ] dip + [ wrap-source-file-error ] recover ] with-scope ; inline From e5c28dfa95b850fea9b1f56ce6156ea0a4aaa6fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Apr 2009 04:50:47 -0500 Subject: [PATCH 167/772] tools.test: use source-files.errors --- basis/tools/test/test.factor | 179 ++++++++++++++++++++++------------- 1 file changed, 115 insertions(+), 64 deletions(-) diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index c6dea08d18..e45f76d7df 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -1,95 +1,146 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors namespaces arrays prettyprint sequences kernel -vectors quotations words parser assocs combinators continuations -debugger io io.styles io.files vocabs vocabs.loader source-files -compiler.units summary stack-checker effects tools.vocabs fry ; +USING: accessors arrays assocs combinators compiler.units +continuations debugger effects fry generalizations io io.files +io.styles kernel lexer locals macros math.parser namespaces +parser prettyprint quotations sequences source-files splitting +stack-checker summary unicode.case vectors vocabs vocabs.loader words +tools.vocabs tools.errors source-files.errors io.streams.string make ; IN: tools.test -SYMBOL: failures +TUPLE: test-failure < source-file-error experiment continuation ; -: ( error what -- triple ) - error-continuation get 3array ; +SYMBOL: passed-tests +SYMBOL: failed-tests -: failure ( error what -- ) + ( error experiment file line# -- triple ) + test-failure new + swap >>line# + swap >>file + swap >>experiment + swap >>error + error-continuation get >>continuation ; + +: failure ( error experiment file line# -- ) "--> test failed!" print - failures get push ; + failed-tests get push ; -SYMBOL: this-test +: success ( experiment -- ) passed-tests get push ; -: (unit-test) ( what quot -- ) - swap dup . flush this-test set - failures get [ - [ this-test get failure ] recover - ] [ - call - ] if ; inline +: file-failure ( error file -- ) + [ f ] [ f ] bi* failure ; -: unit-test ( output input -- ) - [ 2array ] 2keep '[ - _ { } _ with-datastack swap >array assert= - ] (unit-test) ; +:: (unit-test) ( output input -- error ? ) + [ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; inline : short-effect ( effect -- pair ) [ in>> length ] [ out>> length ] bi 2array ; -: must-infer-as ( effect quot -- ) - [ 1quotation ] dip '[ _ infer short-effect ] unit-test ; +:: (must-infer-as) ( effect quot -- error ? ) + [ quot infer short-effect effect assert= f f ] [ t ] recover ; inline -: must-infer ( word/quot -- ) - dup word? [ 1quotation ] when - '[ _ infer drop ] [ ] swap unit-test ; +:: (must-infer) ( word/quot -- error ? ) + word/quot dup word? [ '[ _ execute ] ] when :> quot + [ quot infer drop f f ] [ t ] recover ; inline -: must-fail-with ( quot pred -- ) - [ '[ @ f ] ] dip '[ _ _ recover ] [ t ] swap unit-test ; +SINGLETON: did-not-fail -: must-fail ( quot -- ) - [ drop t ] must-fail-with ; +M: did-not-fail summary drop "Did not fail" ; -: (run-test) ( vocab -- ) +:: (must-fail-with) ( quot pred -- error ? ) + [ quot call did-not-fail t ] + [ dup pred call [ drop f f ] [ t ] if ] recover ; inline + +:: (must-fail) ( quot -- error ? ) + [ quot call did-not-fail t ] [ drop f f ] recover ; inline + +: experiment-title ( word -- string ) + "(" ?head drop ")" ?tail drop { { CHAR: - CHAR: \s } } substitute >title ; + +MACRO: ( word -- ) + [ stack-effect in>> length dup ] + [ name>> experiment-title ] bi + '[ _ ndup _ narray _ prefix ] ; + +: experiment. ( seq -- ) + [ first write ": " write ] [ rest . ] bi ; + +:: experiment ( word: ( -- error ? ) file line# -- ) + word :> e + e experiment. + word execute [ e file line# failure ] [ drop e success ] if ; inline + +: parse-test ( accum word -- accum ) + literalize parsed + file get dup [ path>> ] when parsed + lexer get line>> parsed + \ experiment parsed ; inline + +<< + +SYNTAX: TEST: + scan + [ create-in ] + [ "(" ")" surround search '[ _ parse-test ] ] bi + define-syntax ; + +>> + +: run-test-file ( path -- ) + [ run-file ] [ swap file-failure ] recover ; + +: collect-results ( quot -- failed passed ) + [ + V{ } clone failed-tests set + V{ } clone passed-tests set + call + failed-tests get + passed-tests get + ] with-scope ; inline + +: run-vocab-tests ( vocab -- ) dup vocab source-loaded?>> [ - vocab-tests [ run-file ] each + vocab-tests [ run-test-file ] each ] [ drop ] if ; -: run-test ( vocab -- failures ) - V{ } clone [ - failures [ - [ (run-test) ] [ swap failure ] recover - ] with-variable - ] keep ; +: traceback-button. ( failure -- ) + "[" write [ "Traceback" ] dip continuation>> write-object "]" print ; -: failure. ( triple -- ) - dup second . - dup first print-error - "Traceback" swap third write-object ; +PRIVATE> -: test-failures. ( assoc -- ) +TEST: unit-test +TEST: must-infer-as +TEST: must-infer +TEST: must-fail-with +TEST: must-fail + +M: test-failure summary + [ experiment>> experiment. ] with-string-writer ; + +M: test-failure error. ( error -- ) + [ call-next-method ] + [ traceback-button. ] + bi ; + +: results. ( failed passed -- ) [ - nl [ - "==== ALL TESTS PASSED" print - ] [ - "==== FAILING TESTS:" print - [ - swap vocab-heading. - [ failure. nl ] each - ] assoc-each - ] if-empty - ] [ - "==== NOTHING TO TEST" print - ] if* ; + [ length # " tests failed, " % ] + [ length # " tests passed." % ] + bi* + ] "" make print nl + ] [ drop errors. ] 2bi ; -: run-tests ( prefix -- failures ) - child-vocabs [ f ] [ - [ dup run-test ] { } map>assoc - [ second empty? not ] filter - ] if-empty ; +: run-tests ( prefix -- failed passed ) + [ child-vocabs [ run-vocab-tests ] each ] collect-results ; : test ( prefix -- ) - run-tests test-failures. ; + run-tests results. ; -: run-all-tests ( -- failures ) +: run-all-tests ( -- failed passed ) "" run-tests ; : test-all ( -- ) - run-all-tests test-failures. ; + run-all-tests results. ; From af8f98495deaa097e57b8976422c70002cdebecf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Apr 2009 08:11:38 -0500 Subject: [PATCH 168/772] Latest icons from Joe --- .../error-list/icons/compiler-error.tiff | Bin 1298 -> 1110 bytes .../error-list/icons/compiler-warning.tiff | Bin 1194 -> 1036 bytes .../error-list/icons/help-lint-error.tiff | Bin 1060 -> 944 bytes .../tools/error-list/icons/linkage-error.tiff | Bin 0 -> 1054 bytes basis/ui/tools/error-list/icons/note.tiff | Bin 784 -> 628 bytes .../tools/error-list/icons/syntax-error.tiff | Bin 1260 -> 1054 bytes .../error-list/icons/unit-test-error.tiff | Bin 1258 -> 1040 bytes 7 files changed, 0 insertions(+), 0 deletions(-) create mode 100644 basis/ui/tools/error-list/icons/linkage-error.tiff diff --git a/basis/ui/tools/error-list/icons/compiler-error.tiff b/basis/ui/tools/error-list/icons/compiler-error.tiff index 1d6b1575ee480a2672e42742026ad473cd40343d..7a53d578fa5b5723e153da87da009d51126bd7ce 100644 GIT binary patch delta 884 zcmV-)1B?8U3f2gJNl7XI`T_s|fIr|s2qYE_2ZTalKmcGE21W=1KuL%*!S4PvJs(fi z)Gj?Agg~G22_z^N4kd{KKxF#(z8?y~h)Nd=t+?)e7+$fptd@NRkx%53a2%#qpJ5n8 z0Z@1x1qXP(U%&zKeZe-IPN$S8{RX)RqEV%knq4-ZAgI)T>a}^i=63y_*WlIa{f1Rz zrBf-_AO)tWR;*jAb^D~2?MJd+toO)8`qzQ2TqpQgULNsFTQ=Tc2FtPad!A5f zmM3cpjmXA-NtW;ds_T5g;lL0BP}Cy;31wghl}G@TWjlZfRvWMZsDd_4qEG=DMw+#b zispg3t)ljj6(*_V01M@L$^aiH>PCeQA;2a85yChw038RR_y7;)0oDKyA>b$g0E;*{ z2LP+<+{eHv;1<*f!5UUlI?y^kaGodF02LCZ>ulVAC`BNo4S)g|LIr>X1VjK60$?(d zImcPLoC|>190D80h|m#)Aea&Xs6@${cYp&yXx=VDfKUd211MzDmPX4rD9UO1+Iyd% z0A5TRru?-oOVb3!GAHC&jCOznv37K?f)thj2Y~Pt00SUk2{g2d6!$*Q^bBSJMzOqd z#iPc5F~)lU0ogooFN5%Yn2;g@V!2APx%4h5Fe=L(Bf}wNa{vVCo_HjIU@YPp10X^G zRB9Bf7_JVYP`kEu{ZNCPhm?IkyQg&cgS?0#R4Rjj0H_rK)|6h=x(pf!*dVp@6aXFv z#QGkp&neXKqyR_=@)v^eJ^%+m?Jk8{cZ(!{gx-qQBn0TCqBwPplGJ{mvO; zq}ged>V*>5ZL7{M6}z-{>xF{eES78Krw{N@=vQwc%Z!uI*v zgX#MJ03Vls?yv$ajO+kEyA)8DBmkKv20#TtP&-|0*l6;yPK=sSW6o;v(bW4v-~bFo ziOiCLsE`0=48afp69Ql|7Mm@H3E+L8;J6mFhvf;t*uHEs28B9r(uyY(=NJH4n@5^H zPl@2r05Apsf)+9sP#MN~Errp#dLZQJofio~DrES7xy>p=53w)0^2RgDA!2OBLh)X5 zfCrKCeFh-d%;K3Me z00&9xwlU*4W(a@*&^iSG1hJNPR`k6xxyMo9r&F9Z9gAbxHd^eSy8u}XYyb|m5WIP}FbQx*HR8nU-@N?70dd0>A+D9)gYo zAzq%9{ewNpOk1gmB&5-rcYp&qXmhT>T;>28V^Bvh+-yZQ`73NZ`6j3$ky8^D=EPKz zQWHR%7Ysp+WXI?7D`x2Ebs|42O95FeLY#+`D31#vWoT0hb%v>uXcNi|`pGIrRS_Y7 zN87{z2}LQy02hYw>Y|ZCC@ugFq0lCx>a)XUg>DE&vb50x;aw^e#+l-~O~@fbSAYWT zX7{iZ=G_lo>kd-c}PFH%ljD{;O6|FDiia# z4N6{^rfIK5#r@JhOZ=gTZ~{aKkrW`LSd0;(IR6Oo0TciL0RsR50000W000010RsR5 z0000W000020RsR8000221d|>EE&{X!lTHIJB|rcG02cuS009610ImZ702%=W00961 r0LTOY02=`X009610ML`610w<0lf?r_3&Qny0000$fWq~7lNba(KbNuX diff --git a/basis/ui/tools/error-list/icons/compiler-warning.tiff b/basis/ui/tools/error-list/icons/compiler-warning.tiff index b50afa45f963269d4343eac280be291b90c33f2d..405cfd4761c00b17a9be353006e56125a91d639c 100644 GIT binary patch delta 809 zcmV+^1J?Yi35*DTNl7XIt^xo6fIr|s2qYE_2ZTalKmcGc0!9b~011dQ!QcQiJsyws z)Gj?Agg~G22_z^M3jmVDf4mM7^{%5;*UQmRdV=QFwN{<{XQS8Mc(6)Y=F zx4|sn3Y}KhShrTLGFzR7$9J;cVK=+&s;_OJ;Nf^$P1$U=f;L+?plCJ-X*9tBK&#b8 z`Dv?LD>b+rno(fN*&vT+v=GW=f+>{JQCO}BvROd{LMZk#QGduna#>5R$`<;4K?Xx8 zBUP&i0|B6ajYgypN+p6ko=`-hQV4}Y!2qCK&TIfiBVV!lxFrvnhrCG@DwrXBzJebo z$~-uZC?On2AcsNFf)C^R2t1D{AP52=fZ#aNtq+q_TBPrIMiGDoBk;td=Ly1s1wm70 z+NgygNP-Ar8VEoT2q7?vEX^|-ZkwP0xDA6~0la8`njio|34&_TGEAU@K+wes0)uSa z01gCg94IGg+JXh)cmQw65)_FeNea;xMWBPQ?8PRCAb1`ifXFi@$?7DvE=$JzIwM2z z3`UZe#xe*Uhip*%KOlq&0>wDVw0R#s&3frSq=O*Hf)k|bN)`o(A&_Jskm`v>vC!L> zNifTQv+{);ha~WV9mjGI0DveVR8=5?ps1}>jY|NyHKxI$Y5-ifMbC81pa9x7+|a{M4Oi`AMxfYk za}=lA*Q1h>+iC^!#8H>+OM0+Y3l)LYX#ILu;QUU-J000340096102lxO009950096102lxO z00IF600aO40Hgzxa04y^tOJvv11=_20000N0R#X60001`0ssIS0R;d70002O0{{RU n0R;d70002W1C#UvA_CF_lNba^3vfMJ0000$fN(uplWYV&J2p3u delta 977 zcmeC-SjAcI>8Zuw!_2_YVE@2@Lq&|2y~QapU`GI(OadD-0|$rk#h1d3_E!W>JSnr~ z=sEr*$ihHDfYG+K=>YSgLJNjYN1rwa=8IQeF(}FNxBn9JwD0%G5V5eC6{t1MXl5|O zfh2(!C5~)|GuPZJww`xU+ks0o&)sdxsq-SMQmt$QR)*HAUGBW{sWxt6c%Hy+R;A>8HQht8Z_(kfU2I=(#6uQ^A_jRcmwCJovPQ zXYak!vnM{!|0&Cx?Jj@m(cHch%7H6aG#y^h;-n&=CcOMg{?0dSUXAN_dA_miwP5`6 zt4Y59f=iSh$G`fprg}#WrBq`UEm7rPYucJw9UG6ASRBG_Ji?){OtXQVSKaG^$x)LX^6if}SQ|5x=bi0R>f*?n zwL-y$UtywbZ;GC124na&4V||({{BhN_A{_WPCGkcb;TE3bD{2*O&DFVyj45O007#Z}Nl;g!|;N|vCx2JORX)WcSmn_9?&B|IAD%_gE)Rc9?Wl~dwh5`$tg`wN@ zIV!V?6H5%uwjSzxSe4YdS!Jf#^}?L`pm`_O=W)qBIrw(>ZrAo0>pM@E=AF$wyk|p= zkodk2w`c7$=1S=g%;GehCRz2nC|_bgYuv{0jfsYA(Q5m&b| zhmiRd#SRW&U^6l^FfuSOC;%}d5}OIgW&w&h0SRV^_~hG6s!U!ilbM+H)Et0P;*2a{ vtuDYUDaFVNW+woZOGDWiER(~Sm6!@xCRZ_gav%Cy0o3Er0Hi0MW3~eT>P&4J diff --git a/basis/ui/tools/error-list/icons/help-lint-error.tiff b/basis/ui/tools/error-list/icons/help-lint-error.tiff index 86dcc0afc29d9bea9d5381bf41d0a62ba0ba62d4..464728a70c23770da723e85115f8d06da3bde05d 100644 GIT binary patch delta 718 zcmZ3&v4Oqb(^HEfh>3xr!Tx~*hl&_4dy7+|14DuVlN$#M180Zv!3PW`wsQSnujtvz zw>ZrI#Hpeo#?3J4NRtCoZOuLg)`TNU0*u%0#eeQw>4=bX4Z+&3M-S(jCYEH#8?~M)gob{x3 zz-;MdFBtTg6K*i%OR04*2s9%$6${G*03 z(c;GpXD{d2rxV0+deJ4GHU^JPHvBAG3X*l%RW>eJtm)OU>&)Yg8+H7?nsG0YHaPil z%@PKm4Z>1a4ft|y9rk|l;emxhOQ*8sf`%VydMq@Vz0gVdYdy<{r;D#D*#;YmI`M{D`a5}sYiz!q8nNDVsm%84 zT)YY2u9~E99PlgSdKzo_^=W!?h?#3@s-a);rXm-dH+`FqFaE!4=8>sXYrO0Q>e z#@hoe3JMG&3=E9S42%p63=%-hh{R?BvRQy)9?T33%#6&F-!o}4227S@)>jP$ii$I` ufOUBSQ=}9lE0~=IR4EN*=S|LKR%R@lJdxRpyTCRIsKcQFNKbyoYzF`W{|Zq6 delta 846 zcmdnMzJ#OR(^HG#7!w0SgZ%>s4izz8_7+NB7heiD+Fubk@ubX_ zqv!aOAPWNp0Y=-_rUT4}3N08q9evsym@i&=#h@h5-~LO?)4ty$L&U;nR-o22qnW`B z2a*I{lsK{-&Rlb^*m~YYZ3iyVJa@M#r_PJ4O0}{LSQ%QccDeJ)r`ouQ;duhPS(T1^ zvjt~|HL&`v&RG-vu3+^vKF-pOk@{virl0<1ufDzELXK{=py!^rO$BR8SFO!m^Wf7K zp1t=@&z|@^|EDZ(w!8eLN1FrEv$t^^PCR~;sYC7E_rQJ6H%Mx+?R%-d;hD*YO^!+& zJ7bQYfBr+^N;V67^Mm^4gHQg4PPmY;!ocF)apRso9yS5DZug~E81fs~f^`J*w!i(J zGWX9vHmk=r=c3%c+V&UOyxhL_0fSDrhLX~6dj{qm?=5($e?3y+SK?;an01AN!FGL( zP?KYaiyVX9`!gC_w&rtdG#>7qwVnTn#)m%T1uY+Kn)sBvIBMo=I7qS8FKFphYGQJj z687Ne`cE7N%nM#Hcy9A|dM@Q~QsRc0LbJn#CWZtlNtFd%P95*(q)RZE9emCh71qG; zqet14LuaGaLgtElO+qY9&tkboJnB*9bOkT>Quj&945NBio8?XIqsc#+lo?-5mSy(h SKJ>K$sKcQFNKYqP%2lL};(h0RZtaA6FnkYQ!7 z*cX3*@l)+VvpIgtr)d0T+sUygaOsp;v1aoXR$O_twQ|q1vcL1LKe+npZ(C^c(qPT& z3arakhOLQSUHW^;w72e?;?{gW;ri=(?R5<%s;eKO+28%LFW~9d>{bb9G zpX~2uFzB+bzvNIppZ!f(*qj9nCnTB}7#%X^DKP93xA)7AYnIMDz)&i;q0mmf*@1Z> zuk^|TJ9rxpDDKJVWt4E@Y}CEPqd3K#gTb>?;Q)gu(}qP3*5c_N3_?x$TXx))aOZr( zAjITyW`fk)00x`s?EwrC++~H$9puu3l&M--= zUL}EHPVgKDhRtFPtez|0PQH}Dz{ME!sYXiJ?E^y^&p{!6m%xz3{d|W%a_|anIeqi8 zN&}Ondr+Ih=|3zCy%SfInkF{?`oEx2Ks8i6JQd#Aj;3cuK1+3fvGaEsNLc93Tfs94+fT77Ih5F4Y?DS zm6|@aT=sUtBLy7>wuWmm$2Xt--7-b*t?rY3AqtE=h3B3Ho@SoU{>Z(`YTXV7F{bk$ z8U(Bw{1_*hpONCYsIa|Tvy#EfPBji5(1P18rgv1DXeP2?TmT3}=ARK%2l20J61YjQ{`u literal 0 HcmV?d00001 diff --git a/basis/ui/tools/error-list/icons/note.tiff b/basis/ui/tools/error-list/icons/note.tiff index 01c328f09ed1292af787a28dc3639182ad2c8c0a..834dea6b8248f748c21f53cf27fccecbbf4d4eca 100644 GIT binary patch delta 402 zcmbQh_JyV1(^HElRBC&Ff`XMpZ;D+=9Bvjlf56H_hUtHG1Ea`|$qyJf8SD?3MwrHJj_%%9e}MA?tHE-C^$|K@9=fx( zN(C_RC@@$sK4V}ytY;=IBbCOmJ4)%~0>(KE_6!DkqJLB`*+=X?cB_HWfq`@K&cuWr zHNHj4%{w11l!{orfuWzlgn?V;TeJ46)oF$SUo9B!FkE-I$G}i`J9zQccMJRPWH7#B z$Z3##z-aEYd&=YEmGx#7%`Oc344e+U2N+i{Onv>L=z?vE<243uN6`aJ{mb)D-1)Ag zZNO+P@PL6~@|!mca+Rla^gA%}z2By>IpCtT|7oKR_5{Wr2HppZitN?`EnII8WkhXy zwASSS12Y5Xhg*-GPxCn3UFddzL1aPaO}6_CoL2Jedvjd)+Ty rR4B#B3T7W;VqlPlvd>Mv$f(SCZSq$}GwwrQD}Xv28i4d(^HG#2onQCgZ%>s4izz8_79@X=KBfPU)LMg#;E^@h?D#1oo{{LftB0w0RubZ zfdm#owq%81lY0tmo7a9~Fz;hZ;3#1GpR?xnJHt0iq;);^+-%^Qw)zA^YNTZYJMXl~ zzACZX=Ph7nI(Uk~;T@hXj)#7*~BSI4Q7*^jz{jA!`*O0hDrKZ#|6O_g&9H@mw%MLDO7*3>!(Mi zX>wvtaRZyg5rGEA3?1er?V0cD8W<}L@@9YBQYh;_@k_&ekAM)Lozm>dak7(-Gcd$- zH+*1_Vs`LZt$o_)=6+u1311wJF21bOv5)8Jk{Px0S4!HbHwQNVI({tu!j1(8vUQwV z0s^9bvO6)zsQgtd>^^YUrqk)&gP<$*%x#Yj3dx%6=rE;}=@cyw`FJe;63NpiX62L^7|#1jlWjT01E*b^50cHjN=vP#SK)vP{8^wnlw zPM_Fjc#DC_@CSqc#ZE`2{k?1QD(9rNiz1xqAM?p5@xE+ zWZggA!Qxy&tKy0(rOrhwb{X|9-g!%?p@Bh!fq{{kfsuiMK>~;wk=RT?HVaT}7c&C` zGgO=v$Y%qxC!b)JVLHS-`5CjGS}0IVoRI}=#%^GikYZ#7v#$X4NkiFpm?vAYC^0=@ Xo*c*G%3WX^1=Qov0Hi0cW3dAOHh)gX delta 1039 zcmV+q1n~Qw2QBn0TCqBwPplGJ{mvO; zq}ged>V*>5ZL7{M6}z-{>xF{eES78Krw{gTEDV0Yd!%x&T9ZOTP^;F{4 zfC4#4aR3GMO5Tp~NE(SKwgrV^Sja5@K+tad7_QmXV-Q&zE?}Ni9AE)dDuaLksucms zEYD5Tvs@6o(3d=_@y7Fo)WXhk^uaMt6Dmi4J-aFNrGK$^HU{!a^<1>XVKc15JIsxA zTI@h=oMnnZQldR{<9I~7k71b$K}^q(A`b&GIYU*ILAWL}XR!l8XmfxB$(nb72N>cK zfB@he0>z93(LSMh!Vxx5v9X+U)&U41s1-M$02hMbLP|Urhfo1QoxlJp1vv)*;ie#e z*oI1yYR>L;fPe$Jc}SZlVf2HMLMSf^Ldhu9TIh!{=C%!Cup|Hop%519WO97cpl>Ml zv4L6{pEIfE$|pLJ^ZgF%nqn=Q=hLViOCP&R4R2tg_DT_dP06>7k J^>~xu13pb}r>+11 diff --git a/basis/ui/tools/error-list/icons/unit-test-error.tiff b/basis/ui/tools/error-list/icons/unit-test-error.tiff index 4f46ffa5789229d1128e4bcf44680d929f61a599..b6ea439f5ae218a19715691ccb679e3e5ef9ffdd 100644 GIT binary patch delta 813 zcmaFGIf0|z(^HFK6B7eNgZ%>s4izz8_7y2rv5VIRLP`;L92Z0pBwLd^KUoXy725T-J&|$ zzS|G#Jm8uec0FQy*gB)=xoyYGH{DA#-~D#g`rHK%9#%y8-ul2$X|tfO+(vNU{U#w! z0r%il92YYVYBDf#w9OCP7nODG)Y&|CwJ8xsn*{>2I8u!cO7e6lZn(+P>&VaEp`5yz zB~oWWck8jqJ`4dG3iZu~b6+R+-h7}Ksk8LjNtTE;30C2t(rt#gE*KNdO`%6ggF*4L{7{2EOAr+b(S9k$3Y1< z29XKcLM`);f8sFjeWCoSiLZGPhi-R<0vFRlUMCJ0K@P<&xeBdzX(0IyAYv~VvoCS}p+2Ze}(9ogO zWUZkvPyI57&4kjEK`Cr^)=jK8b&_uTEOLT@o$;u1;2!PllOYCIHjCKtcPK=NDKs6} za5QYf8zu%L4-?K5s23PlS)g@y+f zU-vFxv15qX_Q)}R@pW#2wXPb9Qf>>HSG;;}f2KGy?_Tb%r!nT`yFOPu$gX`6y(sR2 zk$sy@@H@Hfk4*MH%(efK>ztBs;}_Sbr7yeEW<7{l=gOF38O77K@I{we*P<7v%=(_5 zuwoKnU|?isU}RumkN{#vBsLR}%>oo#!8~~bvmVn1=E)D3_0&RvBI1lJU>&P~$z6(( p70f=y%)lTGWuIf7Y{H_%bd7m(1dAtkfo&8}k3$2Hp1g*|4gl2!F;oBm delta 1033 zcmV+k1or!o2jK}0sI4~d(0X>C+zyrc@H~@)3Ool)M(bVbyA|DTj`W8t)k4R_~I6RtBDwZ;t zQvkqX5a@J42E%Er-g7&i(JMd-6>djHl*-Q(s%1JoP^ndaCew-3@_k;BS8foy1tP~w z22*QRfCWygY^+=EaI2OM33ahqFE(s7^8IV8+py4VEqf73yk4?!taYlbZLHw(v<$u8 z%bStsZ}}Y!Yeyf_;a~I>7^>*g?GC1Ua1Gf#CFiRglnNq?-Grp2L{afFEzT zB1IzvR;yrtnWnQ^2#7>M3MCjo91jF77NCsAWDt-@f*y}hK!`@4QNHJ}87qtqI@q%; zVhSM$NFly&po5_3f(OC!2wE11Ad)1Yfq-Cy4Ff_5HH~N?plBe3(KLb^hT;fs8^|CM z1itG_R^+3uWB}-(#-XVS!r%eKaUg)uG}Iuc@%(~+1K|1yLy+hoxGo`%J3hd$kMau{ zv1nvUf(0Q=NfQ7PEP#R^N7RWU00dzef(v5XjQlb3d-#GRGNWdZ3WA~tVwk8Q3b%`* z>IedWs?ls)AcMH>f*&W!2x*#VBg~)4&)ZrsH(&uK*+5DA{ShF983uwO&I5!14I@n) z^PuH_K~W>gAOXN|AdRcy`G65x=Hr}a7yve+HFL8rh{80!08A($NKzn#5d?w-1UP~M0ELEw7e&$tDT-hL!(N;f_&;FV=uKXN2I0C0Cke0yY3VcurXuAhDJ@#NiV7h$0|@IF8%5GX8fc zAueJ|pSlvOCOZzuA*5*_g~4#m>2rD)ry)6l=L6mskN_qLh#>erAcZkZf(?UZxo;tV zdh1%C%1QpjxEdyk2tJRfAPfUL4$uH{oU!bFgYM2!N3b>;gH5S0)l58Tf+UI{sIoADX8zI;fPerL0003400961 z03ZMW009950096103ZMW00IF600aO40D=UQ)&ed9iUgAe11=^&0000N0R#X60001k z0{{RT0R;d70001>1ONaV0R;d70001}1e00=A_A}klYRq93&Qny0000$fWq~7lhOk| D-wvLu From e467f4eea3f389ea6fbe996184e064bc601013be Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Apr 2009 08:17:41 -0500 Subject: [PATCH 169/772] More work on unit test tool --- basis/tools/errors/errors.factor | 2 +- basis/tools/test/test-docs.factor | 14 +++++------ basis/tools/test/test.factor | 5 ++-- .../compiler-errors/compiler-errors.factor | 25 ++++++++----------- core/source-files/errors/errors.factor | 6 ++--- 5 files changed, 25 insertions(+), 27 deletions(-) diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor index a11b60d833..85a29986a6 100644 --- a/basis/tools/errors/errors.factor +++ b/basis/tools/errors/errors.factor @@ -16,7 +16,7 @@ IN: tools.errors ] assoc-each ; : compiler-errors. ( type -- ) - errors-of-type errors. ; + errors-of-type values errors. ; : :errors ( -- ) +error+ compiler-errors. ; diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor index 3cabff457f..7889897c92 100644 --- a/basis/tools/test/test-docs.factor +++ b/basis/tools/test/test-docs.factor @@ -3,13 +3,13 @@ IN: tools.test ARTICLE: "tools.test.write" "Writing unit tests" "Assert that a quotation outputs a specific set of values:" -{ $subsection unit-test } +{ $subsection POSTPONE: unit-test } "Assert that a quotation throws an error:" -{ $subsection must-fail } -{ $subsection must-fail-with } +{ $subsection POSTPONE: must-fail } +{ $subsection POSTPONE: must-fail-with } "Assert that a quotation or word has a specific static stack effect (see " { $link "inference" } "):" -{ $subsection must-infer } -{ $subsection must-infer-as } ; +{ $subsection POSTPONE: must-infer } +{ $subsection POSTPONE: must-infer-as } ; ARTICLE: "tools.test.run" "Running unit tests" "The following words run test harness files; any test failures are collected and printed at the end:" @@ -29,7 +29,7 @@ $nl { $subsection run-tests } { $subsection run-all-tests } "The following word prints failures:" -{ $subsection test-failures. } ; +{ $subsection results. } ; ARTICLE: "tools.test" "Unit testing" "A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract." @@ -89,6 +89,6 @@ HELP: run-all-tests { $values { "failures" "an association list of unit test failures" } } { $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ; -HELP: test-failures. +HELP: results. { $values { "assoc" "an association list of unit test failures" } } { $description "Prints unit test failures output by " { $link run-tests } " or " { $link run-all-tests } " to " { $link output-stream } "." } ; diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index e45f76d7df..cce3279732 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -45,7 +45,8 @@ SYMBOL: failed-tests word/quot dup word? [ '[ _ execute ] ] when :> quot [ quot infer drop f f ] [ t ] recover ; inline -SINGLETON: did-not-fail +TUPLE: did-not-fail ; +CONSTANT: did-not-fail T{ did-not-fail } M: did-not-fail summary drop "Did not fail" ; @@ -130,7 +131,7 @@ M: test-failure error. ( error -- ) [ length # " tests failed, " % ] [ length # " tests passed." % ] bi* - ] "" make print nl + ] "" make nl print nl ] [ drop errors. ] 2bi ; : run-tests ( prefix -- failed passed ) diff --git a/basis/ui/tools/compiler-errors/compiler-errors.factor b/basis/ui/tools/compiler-errors/compiler-errors.factor index 45eb3dee5b..44c17a00f4 100644 --- a/basis/ui/tools/compiler-errors/compiler-errors.factor +++ b/basis/ui/tools/compiler-errors/compiler-errors.factor @@ -3,13 +3,13 @@ USING: accessors arrays sequences sorting assocs colors.constants combinators combinators.smart combinators.short-circuit editors compiler.errors compiler.units fonts kernel io.pathnames -stack-checker.errors math.parser math.order models models.arrow -models.search debugger namespaces summary locals ui ui.commands -ui.gadgets ui.gadgets.panes ui.gadgets.tables ui.gadgets.labeled -ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser -ui.tools.common ui.gadgets.scrollers ui.tools.inspector -ui.gadgets.status-bar ui.operations ui.gadgets.buttons -ui.gadgets.borders ui.images ; +stack-checker.errors source-files.errors math.parser math.order models +models.arrow models.search debugger namespaces summary locals ui +ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.tables +ui.gadgets.labeled ui.gadgets.tracks ui.gestures ui.operations +ui.tools.browser ui.tools.common ui.gadgets.scrollers +ui.tools.inspector ui.gadgets.status-bar ui.operations +ui.gadgets.buttons ui.gadgets.borders ui.images ; IN: ui.tools.compiler-errors TUPLE: error-list-gadget < tool source-file error source-file-table error-table error-display ; @@ -30,7 +30,7 @@ M: source-file-renderer column-alignment drop { 0 1 } ; M: source-file-renderer filled-column drop 0 ; : ( model -- model' ) - [ group-by-source-file >alist sort-keys f prefix ] ; + [ values group-by-source-file >alist sort-keys f prefix ] ; :: ( error-list -- table ) error-list model>> @@ -53,16 +53,13 @@ GENERIC: error-icon ( error -- icon ) : ( name -- image-name ) "vocab:ui/tools/error-list/icons/" ".tiff" surround ; -M: inference-error error-icon - type>> { +M: compiler-error error-icon + compiler-error-type { { +error+ [ "compiler-error" ] } { +warning+ [ "compiler-warning" ] } + { +linkage+ [ "linkage-error" ] } } case ; -M: object error-icon drop "HAI" ; - -M: compiler-error error-icon error>> error-icon ; - M: error-renderer row-columns drop [ { diff --git a/core/source-files/errors/errors.factor b/core/source-files/errors/errors.factor index 9972a68446..ca7c403609 100644 --- a/core/source-files/errors/errors.factor +++ b/core/source-files/errors/errors.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel math.order sorting ; +USING: accessors assocs kernel math.order sorting sequences ; IN: source-files.errors TUPLE: source-file-error error file line# ; -: sort-errors ( assoc -- alist ) +: sort-errors ( errors -- alerrors'ist ) [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ; : group-by-source-file ( errors -- assoc ) - H{ } clone [ [ push-at ] curry [ nip dup file>> ] prepose assoc-each ] keep ; + H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ; From 694652590f22787357e3c6c71c453a5b0643b257 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Apr 2009 08:18:26 -0500 Subject: [PATCH 170/772] download word throneeds to ws an error if the request did not return a success code (reported by Chris Double) --- basis/http/client/client.factor | 2 +- basis/http/http-tests.factor | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 805929d27b..307fdd5031 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -165,7 +165,7 @@ ERROR: download-failed response ; present file-name "?" split1 drop "/" ?tail drop ; : download-to ( url file -- ) - binary [ [ write ] with-http-get drop ] with-file-writer ; + binary [ [ write ] with-http-get check-response drop ] with-file-writer ; : download ( url -- ) dup download-name download-to ; diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index da50a6f85f..45ad132677 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -392,4 +392,7 @@ SYMBOL: a [ "OK" ] [ "data" "http://localhost/a" add-port http-post nip ] unit-test -[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test \ No newline at end of file +! Check that download throws errors (reported by Chris Double) +[ "http://localhost/tweet_my_twat" add-port download ] must-fail + +[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test From 9efa1e0c3126a4faca3748743407d8dc3de3fc5d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Apr 2009 08:23:05 -0500 Subject: [PATCH 171/772] Don't use glTexSubImage2D unless we really have to --- basis/opengl/textures/textures.factor | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index e13e99e10f..1900deb5b8 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -36,10 +36,12 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed [ next-power-of-2 ] map ] unless ; -: (tex-image) ( image -- ) - [ GL_TEXTURE_2D 0 GL_RGBA ] dip - [ dim>> adjust-texture-dim first2 0 ] - [ component-order>> component-order>format f ] bi +: (tex-image) ( image bitmap -- ) + [ + [ GL_TEXTURE_2D 0 GL_RGBA ] dip + [ dim>> adjust-texture-dim first2 0 ] + [ component-order>> component-order>format ] bi + ] dip glTexImage2D ; : (tex-sub-image) ( image -- ) @@ -53,7 +55,9 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed gen-texture [ GL_TEXTURE_BIT [ GL_TEXTURE_2D swap glBindTexture - [ (tex-image) ] [ (tex-sub-image) ] bi + non-power-of-2-textures? get + [ dup bitmap>> (tex-image) ] + [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if ] do-attribs ] keep ; From 1551eacfa2cd47972bbe5e084a82ded6a2b92fbd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 10:44:50 -0500 Subject: [PATCH 172/772] add support for tiff grayscale images --- basis/images/bitmap/bitmap-tests.factor | 15 ++++----------- basis/images/images.factor | 5 +++-- basis/images/loader/loader.factor | 5 ++--- basis/images/tiff/tiff.factor | 3 ++- basis/opengl/textures/textures.factor | 4 +++- basis/windows/uniscribe/uniscribe.factor | 10 +++++----- 6 files changed, 19 insertions(+), 23 deletions(-) diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor index c7012cfd42..29ba3b9b80 100644 --- a/basis/images/bitmap/bitmap-tests.factor +++ b/basis/images/bitmap/bitmap-tests.factor @@ -1,6 +1,7 @@ USING: images.bitmap images.viewer io.encodings.binary io.files io.files.unique kernel tools.test images.loader -literals sequences checksums.md5 checksums ; +literals sequences checksums.md5 checksums +images.normalization ; IN: images.bitmap.tests CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp" @@ -16,15 +17,6 @@ CONSTANT: test-41 "vocab:images/test-images/41red24bit.bmp" CONSTANT: test-42 "vocab:images/test-images/42red24bit.bmp" CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp" -[ t ] -[ - test-bitmap24 - [ binary file-contents ] [ load-image ] bi - - "test-bitmap24" unique-file - [ save-bitmap ] [ binary file-contents ] bi = -] unit-test - { $ test-bitmap8 $ test-bitmap24 @@ -34,7 +26,7 @@ CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp" : test-bitmap-save ( path -- ? ) [ md5 checksum-file ] - [ load-image ] bi + [ load-image normalize-image ] bi "bitmap-save-test" unique-file [ save-bitmap ] [ md5 checksum-file ] bi = ; @@ -47,5 +39,6 @@ CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp" $ test-41 $ test-42 $ test-43 + $ test-bitmap24 } [ test-bitmap-save ] all? ] unit-test diff --git a/basis/images/images.factor b/basis/images/images.factor index b32953f67c..178b91ab52 100755 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -3,7 +3,7 @@ USING: combinators kernel accessors ; IN: images -SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR +SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ; UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ; @@ -11,6 +11,7 @@ UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ; : bytes-per-pixel ( component-order -- n ) { { L [ 1 ] } + { LA [ 2 ] } { BGR [ 3 ] } { RGB [ 3 ] } { BGRA [ 4 ] } @@ -33,4 +34,4 @@ TUPLE: image dim component-order upside-down? bitmap ; : has-alpha? ( image -- ? ) component-order>> alpha-channel? ; -GENERIC: load-image* ( path tuple -- image ) \ No newline at end of file +GENERIC: load-image* ( path tuple -- image ) diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index b8bafc021f..fe33cc8f00 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: constructors kernel splitting unicode.case combinators -accessors images.bitmap images.tiff images images.normalization -io.pathnames ; +accessors images.bitmap images.tiff images io.pathnames ; IN: images.loader ERROR: unknown-image-extension extension ; @@ -16,4 +15,4 @@ ERROR: unknown-image-extension extension ; } case ; : load-image ( path -- image ) - dup image-class new load-image* normalize-image ; + dup image-class new load-image* ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 80eaff8140..381cd70d22 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -463,6 +463,7 @@ ERROR: unknown-component-order ifd ; { { 16 16 16 } [ 2 seq>native-endianness ] } { { 8 8 8 8 } [ ] } { { 8 8 8 } [ ] } + { 8 [ ] } [ unknown-component-order ] } case >>bitmap ; @@ -474,11 +475,11 @@ ERROR: unknown-component-order ifd ; { { 16 16 16 } [ R16G16B16 ] } { { 8 8 8 8 } [ RGBA ] } { { 8 8 8 } [ RGB ] } + { 8 [ L ] } [ unknown-component-order ] } case ; : normalize-alpha-data ( seq -- byte-array ) - ! [ normalize-alpha-data ] change-bitmap B{ } like dup byte-array>float-array 4 diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index e13e99e10f..fdf21c32c2 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -20,6 +20,8 @@ M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ; M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ; M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; +M: LA component-order>format drop GL_LUMINANCE_ALPHA GL_UNSIGNED_BYTE ; +M: L component-order>format drop GL_LUMINANCE GL_UNSIGNED_BYTE ; SLOT: display-list @@ -159,4 +161,4 @@ PRIVATE> : ( image loc -- texture ) over dim>> max-texture-size [ <= ] 2all? [ ] - [ [ max-texture-size tesselate ] dip ] if ; \ No newline at end of file + [ [ max-texture-size tesselate ] dip ] if ; diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index f6cacfb683..fb0c134b9a 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel assocs math sequences fry io.encodings.string -io.encodings.utf16n accessors arrays combinators destructors locals -cache namespaces init images.normalization fonts alien.c-types -windows windows.usp10 windows.offscreen windows.gdi32 -windows.ole32 windows.types windows.fonts opengl.textures ; +io.encodings.utf16n accessors arrays combinators destructors +cache namespaces init fonts alien.c-types windows windows.usp10 +windows.offscreen windows.gdi32 windows.ole32 windows.types +windows.fonts opengl.textures locals ; IN: windows.uniscribe TUPLE: script-string font string metrics ssa size image disposed ; @@ -112,4 +112,4 @@ SYMBOL: cached-script-strings cached-script-strings get-global [ ] 2cache ; [ cached-script-strings set-global ] -"windows.uniscribe" add-init-hook \ No newline at end of file +"windows.uniscribe" add-init-hook From 5279bb0efc67e22ebba3b2e8b09ac713e504b0f1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 10:46:43 -0500 Subject: [PATCH 173/772] change L to LA for grayscale tiffs --- basis/images/tiff/tiff.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 381cd70d22..6bf1ea2ff1 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -475,7 +475,7 @@ ERROR: unknown-component-order ifd ; { { 16 16 16 } [ R16G16B16 ] } { { 8 8 8 8 } [ RGBA ] } { { 8 8 8 } [ RGB ] } - { 8 [ L ] } + { 8 [ LA ] } [ unknown-component-order ] } case ; From cdc3d1b643053a17c16e7b177ada4a242c2db179 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 15:03:34 -0500 Subject: [PATCH 174/772] more id3 refactoring, support TAG+ --- extra/id3/id3-docs.factor | 28 +++---- extra/id3/id3.factor | 166 ++++++++++++++++++++++++-------------- 2 files changed, 121 insertions(+), 73 deletions(-) diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor index feb110fab8..c43559a630 100644 --- a/extra/id3/id3-docs.factor +++ b/extra/id3/id3-docs.factor @@ -7,7 +7,7 @@ IN: id3 HELP: mp3>id3 { $values { "path" "a path string" } - { "id3v2-info/f" "a tuple storing ID3v2 metadata or f" } } + { "id3/f" "a tuple storing ID3v2 metadata or f" } } { $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Words to access the ID3v1 information are here:" { $list { $link title } @@ -22,49 +22,49 @@ HELP: mp3>id3 HELP: album { $values - { "id3" id3v2-info } - { "album/f" "string or f" } + { "id3" id3 } + { "string/f" "string or f" } } { $description "Returns the album, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; HELP: artist { $values - { "id3" id3v2-info } - { "artist/f" "string or f" } + { "id3" id3 } + { "string/f" "string or f" } } { $description "Returns the artist, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; HELP: comment { $values - { "id3" id3v2-info } - { "comment/f" "string or f" } + { "id3" id3 } + { "string/f" "string or f" } } { $description "Returns the comment, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; HELP: genre { $values - { "id3" id3v2-info } - { "genre/f" "string or f" } + { "id3" id3 } + { "string/f" "string or f" } } { $description "Returns the genre, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; HELP: title { $values - { "id3" id3v2-info } - { "title/f" "string or f" } + { "id3" id3 } + { "string/f" "string or f" } } { $description "Returns the title, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; HELP: year { $values - { "id3" id3v2-info } - { "year/f" "string or f" } + { "id3" id3 } + { "string/f" "string or f" } } { $description "Returns the year, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; HELP: find-id3-frame { $values - { "id3" id3v2-info } { "name" string } + { "id3" id3 } { "name" string } { "obj/f" "object or f" } } { $description "Returns the " { $slot "data" } " slot of the ID3 frame with the given name, or " { $link f } "." } ; diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 5076a4a8ab..8a235d305d 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -6,7 +6,7 @@ combinators math.ranges unicode.categories byte-arrays io.encodings.string io.encodings.utf16 assocs math.parser combinators.short-circuit fry namespaces combinators.smart splitting io.encodings.ascii arrays io.files.info unicode.case -io.directories.search ; +io.directories.search literals ; IN: id3 ( -- object ) id3v1-info new ; inline - -: ( header frames -- object ) - [ [ frame-id>> ] keep ] H{ } map>assoc id3v2-info boa ; +: ( -- id3 ) + id3 new + H{ } clone >>frames ; inline :
( -- object ) header new ; inline : ( -- object ) frame new ; inline -: id3v2? ( mmap -- ? ) "ID3" head? ; inline +: id3v2? ( seq -- ? ) "ID3" head? ; inline -: id3v1? ( mmap -- ? ) - { [ length 128 >= ] [ 128 tail-slice* "TAG" head? ] } 1&& ; inline +CONSTANT: id3v1-length 128 +CONSTANT: id3v1-offset 128 +CONSTANT: id3v1+-length 227 +CONSTANT: id3v1+-offset $[ 128 227 + ] -: id3v1-frame ( string key -- frame ) - - swap >>frame-id - swap >>data ; inline +: id3v1? ( seq -- ? ) + { + [ length id3v1-offset >= ] + [ id3v1-length tail-slice* "TAG" head? ] + } 1&& ; inline -: id3v1>id3v2 ( id3v1 -- id3v2 ) +: id3v1+? ( seq -- ? ) + { + [ length id3v1+-offset >= ] + [ id3v1+-length tail-slice* "TAG+" head? ] + } 1&& ; inline + +: pair>frame ( string key -- frame/f ) + over [ + + swap >>tag + swap >>data + ] [ + 2drop f + ] if ; inline + +: id3v1>frames ( id3v1 -- seq ) [ { - [ title>> "TIT2" id3v1-frame ] - [ artist>> "TPE1" id3v1-frame ] - [ album>> "TALB" id3v1-frame ] - [ year>> "TYER" id3v1-frame ] - [ comment>> "COMM" id3v1-frame ] - [ genre>> "TCON" id3v1-frame ] + [ title>> "TIT2" pair>frame ] + [ artist>> "TPE1" pair>frame ] + [ album>> "TALB" pair>frame ] + [ year>> "TYER" pair>frame ] + [ comment>> "COMM" pair>frame ] + [ genre>> "TCON" pair>frame ] } cleave - ] output>array f swap ; inline + ] output>array sift ; : >28bitword ( seq -- int ) 0 [ [ 7 shift ] dip bitor ] reduce ; inline @@ -85,10 +106,10 @@ TUPLE: id3v1-info title artist album year comment genre ; : filter-text-data ( data -- filtered ) [ printable? ] filter ; inline -: valid-frame-id? ( id -- ? ) +: valid-tag? ( id -- ? ) [ { [ digit? ] [ LETTER? ] } 1|| ] all? ; inline -: read-frame-data ( frame mmap -- frame data ) +: read-frame-data ( frame seq -- frame data ) [ 10 over size>> 10 + ] dip filter-text-data ; inline : decode-text ( string -- string' ) @@ -96,28 +117,29 @@ TUPLE: id3v1-info title artist album year comment genre ; { { HEX: ff HEX: fe } { HEX: fe HEX: ff } } member? utf16 ascii ? decode ; inline -: (read-frame) ( mmap -- frame ) +: (read-frame) ( seq -- frame ) [ ] dip { - [ 4 head-slice decode-text >>frame-id ] + [ 4 head-slice decode-text >>tag ] [ [ 4 8 ] dip subseq >28bitword >>size ] [ [ 8 10 ] dip subseq >byte-array >>flags ] [ read-frame-data decode-text >>data ] } cleave ; inline -: read-frame ( mmap -- frame/f ) - dup 4 head-slice valid-frame-id? +: read-frame ( seq -- frame/f ) + dup 4 head-slice valid-tag? [ (read-frame) ] [ drop f ] if ; inline -: remove-frame ( mmap frame -- mmap ) +: remove-frame ( seq frame -- seq ) size>> 10 + tail-slice ; inline -: read-frames ( mmap -- frames ) - [ dup read-frame dup ] - [ [ remove-frame ] keep ] - produce 2nip ; inline +: frames>assoc ( seq -- assoc ) + [ [ tag>> ] keep ] H{ } map>assoc ; inline + +: read-frames ( seq -- assoc ) + [ dup read-frame dup ] [ [ remove-frame ] keep ] produce 2nip ; inline -: read-v2-header ( seq -- id3header ) +: read-v2-header ( seq -- header ) [
] dip { [ [ 3 5 ] dip >array >>version ] @@ -125,15 +147,18 @@ TUPLE: id3v1-info title artist album year comment genre ; [ [ 6 10 ] dip >28bitword >>size ] } cleave ; inline -: read-v2-tag-data ( seq -- id3v2-info ) - 10 cut-slice - [ read-v2-header ] - [ read-frames ] bi* ; inline - -: skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline +: merge-frames ( id3 assoc -- id3 ) + [ dup frames>> ] dip update ; inline -: (read-v1-tag-data) ( seq -- mp3-file ) - [ ] dip +: merge-id3v1 ( id3 -- id3 ) + dup id3v1>frames frames>assoc merge-frames ; inline + +: read-v2-tags ( id3 seq -- id3 ) + 10 cut-slice + [ read-v2-header >>header ] + [ read-frames frames>assoc merge-frames ] bi* ; inline + +: extract-v1-tags ( id3 seq -- id3 ) { [ 30 head-slice decode-text filter-text-data >>title ] [ [ 30 60 ] dip subseq decode-text filter-text-data >>artist ] @@ -143,8 +168,30 @@ TUPLE: id3v1-info title artist album year comment genre ; [ [ 124 ] dip nth number>string >>genre ] } cleave ; inline -: read-v1-tag-data ( seq -- mp3-file ) - skip-to-v1-data (read-v1-tag-data) ; inline +: read-v1-tags ( id3 seq -- id3 ) + id3v1-offset tail-slice* 3 tail-slice + extract-v1-tags ; inline + +: extract-v1+-tags ( id3 seq -- id3 ) + { + [ 60 head-slice decode-text filter-text-data [ append ] change-title ] + [ + [ 60 120 ] dip subseq decode-text filter-text-data + [ append ] change-artist + ] + [ + [ 120 180 ] dip subseq decode-text filter-text-data + [ append ] change-album + ] + [ [ 180 ] dip nth >>speed ] + [ [ 181 211 ] dip subseq decode-text >>genre-name ] + [ [ 211 217 ] dip subseq decode-text >>start-time ] + [ [ 217 223 ] dip subseq decode-text >>end-time ] + } cleave ; inline + +: read-v1+-tags ( id3 seq -- id3 ) + id3v1+-offset tail-slice* 4 tail-slice + extract-v1+-tags ; inline : parse-genre ( string -- n/f ) dup "(" ?head-slice drop ")" ?tail-slice drop @@ -154,34 +201,35 @@ TUPLE: id3v1-info title artist album year comment genre ; drop ] if ; inline -: (mp3>id3) ( path -- id3v2-info/f ) +: (mp3>id3) ( path -- id3v2/f ) [ + [ ] dip { - { [ dup id3v2? ] [ read-v2-tag-data ] } - { [ dup id3v1? ] [ read-v1-tag-data id3v1>id3v2 ] } - [ drop f ] - } cond + [ dup id3v1? [ read-v1-tags merge-id3v1 ] [ drop ] if ] + [ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ] + [ dup id3v2? [ read-v2-tags ] [ drop ] if ] + } cleave ] with-mapped-uchar-file ; PRIVATE> -: mp3>id3 ( path -- id3v2-info/f ) +: mp3>id3 ( path -- id3/f ) dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; inline : find-id3-frame ( id3 name -- obj/f ) swap frames>> at* [ data>> ] when ; inline -: title ( id3 -- title/f ) "TIT2" find-id3-frame ; inline +: title ( id3 -- string/f ) "TIT2" find-id3-frame ; inline -: artist ( id3 -- artist/f ) "TPE1" find-id3-frame ; inline +: artist ( id3 -- string/f ) "TPE1" find-id3-frame ; inline -: album ( id3 -- album/f ) "TALB" find-id3-frame ; inline +: album ( id3 -- string/f ) "TALB" find-id3-frame ; inline -: year ( id3 -- year/f ) "TYER" find-id3-frame ; inline +: year ( id3 -- string/f ) "TYER" find-id3-frame ; inline -: comment ( id3 -- comment/f ) "COMM" find-id3-frame ; inline +: comment ( id3 -- string/f ) "COMM" find-id3-frame ; inline -: genre ( id3 -- genre/f ) +: genre ( id3 -- string/f ) "TCON" find-id3-frame parse-genre ; inline : find-mp3s ( path -- seq ) From 6583b4d38e1c82baa1742fdd931b1e90b64a78a4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 15:28:48 -0500 Subject: [PATCH 175/772] rename html.parser.state to sequence-parser --- extra/c/preprocessor/preprocessor.factor | 2 +- extra/html/parser/parser.factor | 2 +- extra/html/parser/state/state-tests.factor | 104 -------------- extra/html/parser/state/state.factor | 127 ------------------ extra/html/parser/utils/utils.factor | 4 +- .../sequence-parser-tests.factor | 104 ++++++++++++++ extra/sequence-parser/sequence-parser.factor | 126 +++++++++++++++++ 7 files changed, 234 insertions(+), 235 deletions(-) delete mode 100644 extra/html/parser/state/state-tests.factor delete mode 100644 extra/html/parser/state/state.factor create mode 100644 extra/sequence-parser/sequence-parser-tests.factor create mode 100644 extra/sequence-parser/sequence-parser.factor diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor index f7cd10a0e9..e5029ca683 100644 --- a/extra/c/preprocessor/preprocessor.factor +++ b/extra/c/preprocessor/preprocessor.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: html.parser.state io io.encodings.utf8 io.files +USING: sequence-parser io io.encodings.utf8 io.files io.streams.string kernel combinators accessors io.pathnames fry sequences arrays locals namespaces io.directories assocs math splitting make unicode.categories diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 61315a4925..b1dc4de4df 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays hashtables html.parser.state +USING: accessors arrays hashtables sequence-parser html.parser.utils kernel namespaces sequences unicode.case unicode.categories combinators.short-circuit quoting fry ; diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor deleted file mode 100644 index c8a8a95892..0000000000 --- a/extra/html/parser/state/state-tests.factor +++ /dev/null @@ -1,104 +0,0 @@ -USING: tools.test html.parser.state ascii kernel accessors ; -IN: html.parser.state.tests - -[ "hello" ] -[ "hello" [ take-rest ] state-parse ] unit-test - -[ "hi" " how are you?" ] -[ - "hi how are you?" - [ [ [ current blank? ] take-until ] [ take-rest ] bi ] state-parse -] unit-test - -[ "foo" ";bar" ] -[ - "foo;bar" [ - [ CHAR: ; take-until-object ] [ take-rest ] bi - ] state-parse -] unit-test - -[ "foo " " bar" ] -[ - "foo and bar" [ - [ "and" take-until-sequence ] [ take-rest ] bi - ] state-parse -] unit-test - -[ 6 ] -[ - " foo " [ skip-whitespace n>> ] state-parse -] unit-test - -[ { 1 2 } ] -[ { 1 2 3 } [ current 3 = ] take-until ] unit-test - -[ { 1 2 } ] -[ { 1 2 3 4 } { 3 4 } take-until-sequence ] unit-test - -[ "ab" ] -[ "abcd" "ab" take-sequence ] unit-test - -[ f ] -[ "abcd" "lol" take-sequence ] unit-test - -[ "ab" ] -[ - "abcd" - [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi -] unit-test - -[ "" ] -[ "abcd" "" take-sequence ] unit-test - -[ "cd" ] -[ "abcd" [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test - -[ f ] -[ - "\"abc\" asdf" - [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi -] unit-test - -[ "abc\\\"def" ] -[ - "\"abc\\\"def\" asdf" - CHAR: \ CHAR: " take-quoted-string -] unit-test - -[ "asdf" ] -[ - "\"abc\" asdf" - [ CHAR: \ CHAR: " take-quoted-string drop ] - [ skip-whitespace "asdf" take-sequence ] bi -] unit-test - -[ f ] -[ - "\"abc asdf" - CHAR: \ CHAR: " take-quoted-string -] unit-test - -[ "\"abc" ] -[ - "\"abc asdf" - [ CHAR: \ CHAR: " take-quoted-string drop ] - [ "\"abc" take-sequence ] bi -] unit-test - -[ "c" ] -[ "c" take-token ] unit-test - -[ f ] -[ "" take-token ] unit-test - -[ "abcd e \\\"f g" ] -[ "\"abcd e \\\"f g\"" CHAR: \ CHAR: " take-token* ] unit-test - -[ "" ] -[ "" take-rest ] unit-test - -[ "" ] -[ "abc" dup "abc" take-sequence drop take-rest ] unit-test - -[ f ] -[ "abc" "abcdefg" take-sequence ] unit-test diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor deleted file mode 100644 index 2bcd08be5f..0000000000 --- a/extra/html/parser/state/state.factor +++ /dev/null @@ -1,127 +0,0 @@ -! Copyright (C) 2005, 2009 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces math kernel sequences accessors fry circular -unicode.case unicode.categories locals combinators.short-circuit -make combinators io splitting ; - -IN: html.parser.state - -TUPLE: state-parser sequence n ; - -: ( sequence -- state-parser ) - state-parser new - swap >>sequence - 0 >>n ; - -: offset ( state-parser offset -- char/f ) - swap - [ n>> + ] [ sequence>> ?nth ] bi ; inline - -: current ( state-parser -- char/f ) 0 offset ; inline - -: previous ( state-parser -- char/f ) -1 offset ; inline - -: peek-next ( state-parser -- char/f ) 1 offset ; inline - -: advance ( state-parser -- state-parser ) - [ 1 + ] change-n ; inline - -: advance* ( state-parser -- ) - advance drop ; inline - -: get+increment ( state-parser -- char/f ) - [ current ] [ advance drop ] bi ; inline - -:: skip-until ( state-parser quot: ( obj -- ? ) -- ) - state-parser current [ - state-parser quot call [ state-parser advance quot skip-until ] unless - ] when ; inline recursive - -: state-parse-end? ( state-parser -- ? ) current not ; - -: take-until ( state-parser quot: ( obj -- ? ) -- sequence/f ) - over state-parse-end? [ - 2drop f - ] [ - [ drop n>> ] - [ skip-until ] - [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq - ] if ; inline - -: take-while ( state-parser quot: ( obj -- ? ) -- sequence/f ) - [ not ] compose take-until ; inline - -: ( from to seq -- slice/f ) - 3dup { - [ 2drop 0 < ] - [ [ drop ] 2dip length > ] - [ drop > ] - } 3|| [ 3drop f ] [ slice boa ] if ; inline - -:: take-sequence ( state-parser sequence -- obj/f ) - state-parser [ n>> dup sequence length + ] [ sequence>> ] bi - sequence sequence= [ - sequence - state-parser [ sequence length + ] change-n drop - ] [ - f - ] if ; - -:: take-until-sequence ( state-parser sequence -- sequence' ) - sequence length :> growing - state-parser - [ - current growing push-growing-circular - sequence growing sequence= - ] take-until :> found - found dup length - growing length 1- - head - state-parser advance drop ; - -: skip-whitespace ( state-parser -- state-parser ) - [ [ current blank? not ] take-until drop ] keep ; - -: take-rest-slice ( state-parser -- sequence/f ) - [ sequence>> ] [ n>> ] bi - 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline - -: take-rest ( state-parser -- sequence ) - [ take-rest-slice ] [ sequence>> like ] bi ; - -: take-until-object ( state-parser obj -- sequence ) - '[ current _ = ] take-until ; - -: state-parse ( sequence quot -- ) - [ ] dip call ; inline - -:: take-quoted-string ( state-parser escape-char quote-char -- string ) - state-parser n>> :> start-n - state-parser advance - [ - { - [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ] - [ current quote-char = not ] - } 1|| - ] take-while :> string - state-parser current quote-char = [ - state-parser advance* string - ] [ - start-n state-parser (>>n) f - ] if ; - -: (take-token) ( state-parser -- string ) - skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ; - -:: take-token* ( state-parser escape-char quote-char -- string/f ) - state-parser skip-whitespace - dup current { - { quote-char [ escape-char quote-char take-quoted-string ] } - { f [ drop f ] } - [ drop (take-token) ] - } case ; - -: take-token ( state-parser -- string/f ) - CHAR: \ CHAR: " take-token* ; - -: write-full ( state-parser -- ) sequence>> write ; -: write-rest ( state-parser -- ) take-rest write ; diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor index 7abd2fcdf7..afd63daf6b 100644 --- a/extra/html/parser/utils/utils.factor +++ b/extra/html/parser/utils/utils.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs circular combinators continuations hashtables hashtables.private io kernel math namespaces prettyprint -quotations sequences splitting html.parser.state strings -combinators.short-circuit quoting ; +quotations sequences splitting strings quoting +combinators.short-circuit ; IN: html.parser.utils : trim1 ( seq ch -- newseq ) diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor new file mode 100644 index 0000000000..915d119abe --- /dev/null +++ b/extra/sequence-parser/sequence-parser-tests.factor @@ -0,0 +1,104 @@ +USING: tools.test sequence-parser ascii kernel accessors ; +IN: sequence-parser.tests + +[ "hello" ] +[ "hello" [ take-rest ] parse-sequence ] unit-test + +[ "hi" " how are you?" ] +[ + "hi how are you?" + [ [ [ current blank? ] take-until ] [ take-rest ] bi ] parse-sequence +] unit-test + +[ "foo" ";bar" ] +[ + "foo;bar" [ + [ CHAR: ; take-until-object ] [ take-rest ] bi + ] parse-sequence +] unit-test + +[ "foo " " bar" ] +[ + "foo and bar" [ + [ "and" take-until-sequence ] [ take-rest ] bi + ] parse-sequence +] unit-test + +[ 6 ] +[ + " foo " [ skip-whitespace n>> ] parse-sequence +] unit-test + +[ { 1 2 } ] +[ { 1 2 3 } [ current 3 = ] take-until ] unit-test + +[ { 1 2 } ] +[ { 1 2 3 4 } { 3 4 } take-until-sequence ] unit-test + +[ "ab" ] +[ "abcd" "ab" take-sequence ] unit-test + +[ f ] +[ "abcd" "lol" take-sequence ] unit-test + +[ "ab" ] +[ + "abcd" + [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi +] unit-test + +[ "" ] +[ "abcd" "" take-sequence ] unit-test + +[ "cd" ] +[ "abcd" [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test + +[ f ] +[ + "\"abc\" asdf" + [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi +] unit-test + +[ "abc\\\"def" ] +[ + "\"abc\\\"def\" asdf" + CHAR: \ CHAR: " take-quoted-string +] unit-test + +[ "asdf" ] +[ + "\"abc\" asdf" + [ CHAR: \ CHAR: " take-quoted-string drop ] + [ skip-whitespace "asdf" take-sequence ] bi +] unit-test + +[ f ] +[ + "\"abc asdf" + CHAR: \ CHAR: " take-quoted-string +] unit-test + +[ "\"abc" ] +[ + "\"abc asdf" + [ CHAR: \ CHAR: " take-quoted-string drop ] + [ "\"abc" take-sequence ] bi +] unit-test + +[ "c" ] +[ "c" take-token ] unit-test + +[ f ] +[ "" take-token ] unit-test + +[ "abcd e \\\"f g" ] +[ "\"abcd e \\\"f g\"" CHAR: \ CHAR: " take-token* ] unit-test + +[ "" ] +[ "" take-rest ] unit-test + +[ "" ] +[ "abc" dup "abc" take-sequence drop take-rest ] unit-test + +[ f ] +[ "abc" "abcdefg" take-sequence ] unit-test diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor new file mode 100644 index 0000000000..ad49982d88 --- /dev/null +++ b/extra/sequence-parser/sequence-parser.factor @@ -0,0 +1,126 @@ +! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces math kernel sequences accessors fry circular +unicode.case unicode.categories locals combinators.short-circuit +make combinators io splitting ; +IN: sequence-parser + +TUPLE: sequence-parser sequence n ; + +: ( sequence -- sequence-parser ) + sequence-parser new + swap >>sequence + 0 >>n ; + +: offset ( sequence-parser offset -- char/f ) + swap + [ n>> + ] [ sequence>> ?nth ] bi ; inline + +: current ( sequence-parser -- char/f ) 0 offset ; inline + +: previous ( sequence-parser -- char/f ) -1 offset ; inline + +: peek-next ( sequence-parser -- char/f ) 1 offset ; inline + +: advance ( sequence-parser -- sequence-parser ) + [ 1 + ] change-n ; inline + +: advance* ( sequence-parser -- ) + advance drop ; inline + +: get+increment ( sequence-parser -- char/f ) + [ current ] [ advance drop ] bi ; inline + +:: skip-until ( sequence-parser quot: ( obj -- ? ) -- ) + sequence-parser current [ + sequence-parser quot call [ sequence-parser advance quot skip-until ] unless + ] when ; inline recursive + +: sequence-parse-end? ( sequence-parser -- ? ) current not ; + +: take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f ) + over sequence-parse-end? [ + 2drop f + ] [ + [ drop n>> ] + [ skip-until ] + [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq + ] if ; inline + +: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f ) + [ not ] compose take-until ; inline + +: ( from to seq -- slice/f ) + 3dup { + [ 2drop 0 < ] + [ [ drop ] 2dip length > ] + [ drop > ] + } 3|| [ 3drop f ] [ slice boa ] if ; inline + +:: take-sequence ( sequence-parser sequence -- obj/f ) + sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi + sequence sequence= [ + sequence + sequence-parser [ sequence length + ] change-n drop + ] [ + f + ] if ; + +:: take-until-sequence ( sequence-parser sequence -- sequence' ) + sequence length :> growing + sequence-parser + [ + current growing push-growing-circular + sequence growing sequence= + ] take-until :> found + found dup length + growing length 1- - head + sequence-parser advance drop ; + +: skip-whitespace ( sequence-parser -- sequence-parser ) + [ [ current blank? not ] take-until drop ] keep ; + +: take-rest-slice ( sequence-parser -- sequence/f ) + [ sequence>> ] [ n>> ] bi + 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline + +: take-rest ( sequence-parser -- sequence ) + [ take-rest-slice ] [ sequence>> like ] bi ; + +: take-until-object ( sequence-parser obj -- sequence ) + '[ current _ = ] take-until ; + +: parse-sequence ( sequence quot -- ) + [ ] dip call ; inline + +:: take-quoted-string ( sequence-parser escape-char quote-char -- string ) + sequence-parser n>> :> start-n + sequence-parser advance + [ + { + [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ] + [ current quote-char = not ] + } 1|| + ] take-while :> string + sequence-parser current quote-char = [ + sequence-parser advance* string + ] [ + start-n sequence-parser (>>n) f + ] if ; + +: (take-token) ( sequence-parser -- string ) + skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ; + +:: take-token* ( sequence-parser escape-char quote-char -- string/f ) + sequence-parser skip-whitespace + dup current { + { quote-char [ escape-char quote-char take-quoted-string ] } + { f [ drop f ] } + [ drop (take-token) ] + } case ; + +: take-token ( sequence-parser -- string/f ) + CHAR: \ CHAR: " take-token* ; + +: write-full ( sequence-parser -- ) sequence>> write ; +: write-rest ( sequence-parser -- ) take-rest write ; From 47369e927c740bc6481b6da24b611965f7647b69 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 15:29:38 -0500 Subject: [PATCH 176/772] add a combinator to spider --- extra/spider/unique-deque/unique-deque.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/extra/spider/unique-deque/unique-deque.factor b/extra/spider/unique-deque/unique-deque.factor index ad46abdad3..b26797f8d5 100644 --- a/extra/spider/unique-deque/unique-deque.factor +++ b/extra/spider/unique-deque/unique-deque.factor @@ -29,3 +29,9 @@ TUPLE: unique-deque assoc deque ; : pop-url ( unique-deque -- todo-url ) deque>> pop-front ; : peek-url ( unique-deque -- todo-url ) deque>> peek-front ; + +: slurp-deque-when ( deque quot1 quot2: ( value -- ) -- ) + pick deque-empty? [ 3drop ] [ + [ [ pop-front dup ] 2dip slip [ t ] compose [ drop f ] if ] + [ roll [ slurp-deque-when ] [ 3drop ] if ] 3bi + ] if ; inline recursive From d44c08bf68a7d31eab30e7981fdec483a280f3f6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 18:23:05 -0500 Subject: [PATCH 177/772] write synchsafe numbers to sequences --- extra/id3/id3-tests.factor | 6 +++++- extra/id3/id3.factor | 12 ++++++++---- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor index a8f35e582c..9bb7558077 100644 --- a/extra/id3/id3-tests.factor +++ b/extra/id3/id3-tests.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Tim Wawrzynczak ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test id3 combinators ; +USING: tools.test id3 combinators grouping id3.private +sequences math ; IN: id3.tests : id3-params ( id3 -- title artist album year comment genre ) @@ -40,3 +41,6 @@ IN: id3.tests "Big Band" ] [ "vocab:id3/tests/blah3.mp3" mp3>id3 id3-params ] unit-test + +[ t ] +[ 10000 [ synchsafe>seq seq>synchsafe ] map [ < ] monotonic? ] unit-test diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 8a235d305d..a742a1f08d 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -6,7 +6,7 @@ combinators math.ranges unicode.categories byte-arrays io.encodings.string io.encodings.utf16 assocs math.parser combinators.short-circuit fry namespaces combinators.smart splitting io.encodings.ascii arrays io.files.info unicode.case -io.directories.search literals ; +io.directories.search literals math.functions ; IN: id3 array sift ; -: >28bitword ( seq -- int ) +: seq>synchsafe ( seq -- n ) 0 [ [ 7 shift ] dip bitor ] reduce ; inline +: synchsafe>seq ( n -- seq ) + dup 1+ log2 1+ 7 / ceiling + [ [ -7 shift ] keep HEX: 7f bitand ] replicate nip reverse ; inline + : filter-text-data ( data -- filtered ) [ printable? ] filter ; inline @@ -121,7 +125,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] [ ] dip { [ 4 head-slice decode-text >>tag ] - [ [ 4 8 ] dip subseq >28bitword >>size ] + [ [ 4 8 ] dip subseq seq>synchsafe >>size ] [ [ 8 10 ] dip subseq >byte-array >>flags ] [ read-frame-data decode-text >>data ] } cleave ; inline @@ -144,7 +148,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] { [ [ 3 5 ] dip >array >>version ] [ [ 5 ] dip nth >>flags ] - [ [ 6 10 ] dip >28bitword >>size ] + [ [ 6 10 ] dip seq>synchsafe >>size ] } cleave ; inline : merge-frames ( id3 assoc -- id3 ) From a6989d3087c849d8b8d9488b2710937ce17d48c7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 19:50:25 -0500 Subject: [PATCH 178/772] fix bug in base64 -- would fail with bitor trying to OR f with an integer --- basis/base64/base64-tests.factor | 3 +++ basis/base64/base64.factor | 6 +++--- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/basis/base64/base64-tests.factor b/basis/base64/base64-tests.factor index ddefff35bb..572d8a5227 100644 --- a/basis/base64/base64-tests.factor +++ b/basis/base64/base64-tests.factor @@ -23,5 +23,8 @@ IN: base64.tests ascii encode >base64-lines >string ] unit-test +[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ] +[ malformed-base64? ] must-fail-with + \ >base64 must-infer \ base64> must-infer diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index c51d871bb5..111fe49f95 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -18,6 +18,8 @@ IN: base64 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ; inline +ERROR: malformed-base64 ; + : base64>ch ( ch -- ch ) { f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f @@ -25,7 +27,7 @@ IN: base64 f 0 f f f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 - } nth ; inline + } nth [ malformed-base64 ] unless* ; inline SYMBOL: column @@ -48,8 +50,6 @@ SYMBOL: column [ 3 0 pad-tail binary [ encode3 ] with-byte-writer ] [ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline -ERROR: malformed-base64 ; - : decode4 ( seq -- ) [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ] [ [ CHAR: = = ] count ] bi head-slice* From a761d570198db662a0f0705a920d44d9c79dc8ba Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 21:03:18 -0500 Subject: [PATCH 179/772] improve sequence-parser --- .../sequence-parser-tests.factor | 44 +++++++++++++++++-- extra/sequence-parser/sequence-parser.factor | 39 +++++++++++++--- 2 files changed, 73 insertions(+), 10 deletions(-) diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor index 915d119abe..715beae5da 100644 --- a/extra/sequence-parser/sequence-parser-tests.factor +++ b/extra/sequence-parser/sequence-parser-tests.factor @@ -17,13 +17,39 @@ IN: sequence-parser.tests ] parse-sequence ] unit-test -[ "foo " " bar" ] +[ "foo " "and bar" ] [ "foo and bar" [ [ "and" take-until-sequence ] [ take-rest ] bi ] parse-sequence ] unit-test +[ "foo " " bar" ] +[ + "foo and bar" [ + [ "and" take-until-sequence ] + [ "and" take-sequence drop ] + [ take-rest ] tri + ] parse-sequence +] unit-test + +[ "foo " " bar" ] +[ + "foo and bar" [ + [ "and" take-until-sequence* ] + [ take-rest ] bi + ] parse-sequence +] unit-test + +[ { 1 2 } ] +[ { 1 2 3 4 } { 3 4 } take-until-sequence ] unit-test + +[ f "aaaa" ] +[ + "aaaa" + [ "b" take-until-sequence ] [ take-rest ] bi +] unit-test + [ 6 ] [ " foo " [ skip-whitespace n>> ] parse-sequence @@ -32,9 +58,6 @@ IN: sequence-parser.tests [ { 1 2 } ] [ { 1 2 3 } [ current 3 = ] take-until ] unit-test -[ { 1 2 } ] -[ { 1 2 3 4 } { 3 4 } take-until-sequence ] unit-test - [ "ab" ] [ "abcd" "ab" take-sequence ] unit-test @@ -102,3 +125,16 @@ IN: sequence-parser.tests [ f ] [ "abc" "abcdefg" take-sequence ] unit-test + +[ 1234 ] +[ "1234f" take-integer ] unit-test + +[ "yes" ] +[ + "yes1234f" + [ take-integer drop ] [ "yes" take-sequence ] bi +] unit-test + +[ f ] [ "" 4 take-n ] unit-test +[ "abcd" ] [ "abcd" 4 take-n ] unit-test +[ "abcd" "efg" ] [ "abcdefg" [ 4 take-n ] [ take-rest ] bi ] unit-test diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor index ad49982d88..22f133bf70 100644 --- a/extra/sequence-parser/sequence-parser.factor +++ b/extra/sequence-parser/sequence-parser.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math kernel sequences accessors fry circular unicode.case unicode.categories locals combinators.short-circuit -make combinators io splitting ; +make combinators io splitting math.parser ; IN: sequence-parser TUPLE: sequence-parser sequence n ; @@ -66,17 +66,33 @@ TUPLE: sequence-parser sequence n ; f ] if ; -:: take-until-sequence ( sequence-parser sequence -- sequence' ) +: take-sequence* ( sequence-parser sequence -- ) + take-sequence drop ; + +:: take-until-sequence ( sequence-parser sequence -- sequence'/f ) + sequence-parser n>> :> saved sequence length :> growing sequence-parser [ current growing push-growing-circular sequence growing sequence= ] take-until :> found - found dup length - growing length 1- - head - sequence-parser advance drop ; - + growing sequence sequence= [ + found dup length + growing length 1- - head + sequence-parser [ growing length - 1 + ] change-n drop + ! sequence-parser advance drop + ] [ + saved sequence-parser (>>n) + f + ] if ; + +:: take-until-sequence* ( sequence-parser sequence -- sequence'/f ) + sequence-parser sequence take-until-sequence :> out + out [ + sequence-parser [ sequence length + ] change-n drop + ] when out ; + : skip-whitespace ( sequence-parser -- sequence-parser ) [ [ current blank? not ] take-until drop ] keep ; @@ -122,5 +138,16 @@ TUPLE: sequence-parser sequence n ; : take-token ( sequence-parser -- string/f ) CHAR: \ CHAR: " take-token* ; +: take-integer ( sequence-parser -- n/f ) + [ current digit? ] take-while string>number ; + +:: take-n ( sequence-parser n -- seq/f ) + n sequence-parser [ n>> + ] [ sequence>> length ] bi > [ + f + ] [ + sequence-parser n>> dup n + sequence-parser sequence>> subseq + sequence-parser [ n + ] change-n drop + ] if ; + : write-full ( sequence-parser -- ) sequence>> write ; : write-rest ( sequence-parser -- ) take-rest write ; From 2179b4bca13f794be09b7ab1345106d01dc44560 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 21:03:42 -0500 Subject: [PATCH 180/772] minor cleanup --- basis/tools/hexdump/hexdump.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor index 63b55729fb..666e051088 100644 --- a/basis/tools/hexdump/hexdump.factor +++ b/basis/tools/hexdump/hexdump.factor @@ -16,10 +16,11 @@ IN: tools.hexdump 16 * >hex 8 CHAR: 0 pad-head write "h: " write ; : >hex-digit ( digit -- str ) - >hex 2 CHAR: 0 pad-head " " append ; + >hex 2 CHAR: 0 pad-head ; : >hex-digits ( bytes -- str ) - [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-tail ; + [ >hex-digit " " append ] { } map-as concat + 48 CHAR: \s pad-tail ; : >ascii ( bytes -- str ) [ [ printable? ] keep CHAR: . ? ] "" map-as ; From 732065d7759d5b5368948808a48d4185540c91c7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Apr 2009 21:32:57 -0500 Subject: [PATCH 181/772] more work on sequence-parser --- .../sequence-parser-tests.factor | 12 ++++++++++++ extra/sequence-parser/sequence-parser.factor | 18 +++++++++++++++++- 2 files changed, 29 insertions(+), 1 deletion(-) diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor index 715beae5da..f6339b7127 100644 --- a/extra/sequence-parser/sequence-parser-tests.factor +++ b/extra/sequence-parser/sequence-parser-tests.factor @@ -138,3 +138,15 @@ IN: sequence-parser.tests [ f ] [ "" 4 take-n ] unit-test [ "abcd" ] [ "abcd" 4 take-n ] unit-test [ "abcd" "efg" ] [ "abcdefg" [ 4 take-n ] [ take-rest ] bi ] unit-test + +[ "asdfasdf" ] [ + "/*asdfasdf*/" take-c-comment +] unit-test + +[ "k" ] [ + "/*asdfasdf*/k" [ take-c-comment drop ] [ take-rest ] bi +] unit-test + +[ "/*asdfasdf" ] [ + "/*asdfasdf" [ take-c-comment drop ] [ take-rest ] bi +] unit-test diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor index 22f133bf70..d5adc56800 100644 --- a/extra/sequence-parser/sequence-parser.factor +++ b/extra/sequence-parser/sequence-parser.factor @@ -12,6 +12,12 @@ TUPLE: sequence-parser sequence n ; swap >>sequence 0 >>n ; +:: with-sequence-parser ( sequence-parser quot -- seq/f ) + sequence-parser n>> :> n + sequence-parser quot call [ + n sequence-parser (>>n) f + ] unless* ; inline + : offset ( sequence-parser offset -- char/f ) swap [ n>> + ] [ sequence>> ?nth ] bi ; inline @@ -33,7 +39,8 @@ TUPLE: sequence-parser sequence n ; :: skip-until ( sequence-parser quot: ( obj -- ? ) -- ) sequence-parser current [ - sequence-parser quot call [ sequence-parser advance quot skip-until ] unless + sequence-parser quot call + [ sequence-parser advance quot skip-until ] unless ] when ; inline recursive : sequence-parse-end? ( sequence-parser -- ? ) current not ; @@ -149,5 +156,14 @@ TUPLE: sequence-parser sequence n ; sequence-parser [ n + ] change-n drop ] if ; +: take-c-comment ( sequence-parser -- seq/f ) + [ + dup "/*" take-sequence [ + "*/" take-until-sequence* + ] [ + drop f + ] if + ] with-sequence-parser ; + : write-full ( sequence-parser -- ) sequence>> write ; : write-rest ( sequence-parser -- ) take-rest write ; From 0a7485190bb88a87f6138efe4e63b065f0b47c95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 03:52:12 -0500 Subject: [PATCH 182/772] compile-error-type => source-error-type; make test failures global --- basis/bootstrap/stage2.factor | 1 - basis/compiler/codegen/codegen.factor | 7 +-- basis/compiler/compiler.factor | 4 +- basis/debugger/debugger.factor | 2 +- basis/editors/editors.factor | 6 +- basis/stack-checker/errors/errors.factor | 9 +-- basis/tools/errors/errors-docs.factor | 40 +++++++++++++ basis/tools/errors/errors.factor | 6 +- basis/tools/test/test-docs.factor | 36 +++--------- basis/tools/test/test.factor | 58 +++++++------------ .../compiler-errors/compiler-errors.factor | 40 ++++++------- basis/ui/tools/debugger/debugger.factor | 2 +- core/compiler/errors/errors-docs.factor | 44 -------------- core/compiler/errors/errors.factor | 20 +++---- core/source-files/errors/errors.factor | 4 +- 15 files changed, 117 insertions(+), 162 deletions(-) create mode 100644 basis/tools/errors/errors-docs.factor diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 12741f2170..fd21c9646c 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -88,7 +88,6 @@ SYMBOL: bootstrap-time run-bootstrap-init ] with-compiler-errors - :errors f error set-global f error-continuation set-global diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 65e70bd042..cf1d81fbc2 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -5,6 +5,7 @@ kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs alien.strings alien.arrays alien.complex sets libc alien.libraries continuations.private fry cpu.architecture +source-files.errors compiler.errors compiler.alien compiler.cfg @@ -379,8 +380,7 @@ TUPLE: no-such-library name ; M: no-such-library summary drop "Library not found" ; -M: no-such-library compiler-error-type - drop +linkage+ ; +M: no-such-library source-file-error-type drop +linkage-error+ ; : no-such-library ( name -- ) \ no-such-library boa @@ -391,8 +391,7 @@ TUPLE: no-such-symbol name ; M: no-such-symbol summary drop "Symbol not found" ; -M: no-such-symbol compiler-error-type - drop +linkage+ ; +M: no-such-symbol source-file-error-type drop +linkage-error+ ; : no-such-symbol ( name -- ) \ no-such-symbol boa diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 04c1a9c55f..2492b6cc23 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io words fry continuations vocabs assocs dlists definitions math graphs generic -combinators deques search-deques macros io stack-checker +combinators deques search-deques macros io source-files.errors stack-checker stack-checker.state stack-checker.inlining combinators.short-circuit compiler.errors compiler.units compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer @@ -54,7 +54,7 @@ SYMBOLS: +optimized+ +unoptimized+ ; : ignore-error? ( word error -- ? ) [ [ inline? ] [ macro? ] bi or ] - [ compiler-error-type +warning+ eq? ] bi* and ; + [ source-file-error-type +compiler-warning+ eq? ] bi* and ; : fail ( word error -- * ) [ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ] diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 202cf7eb5e..c088b86c31 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -321,7 +321,7 @@ M: source-file-error error. ] bi format nl ] [ error>> error. ] bi ; -M: compiler-error summary word>> synopsis ; +M: compiler-error summary asset>> summary ; M: bad-effect summary drop "Bad stack effect declaration" ; diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index 327cdea3c1..b494b52c68 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser lexer kernel namespaces sequences definitions -io.files io.backend io.pathnames io summary continuations -tools.crossref tools.vocabs prettyprint source-files assocs +USING: parser lexer kernel namespaces sequences definitions io.files +io.backend io.pathnames io summary continuations tools.crossref +tools.vocabs prettyprint source-files source-files.errors assocs vocabs vocabs.loader splitting accessors debugger prettyprint help.topics ; IN: editors diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index 07c26ad100..a4d22f8a5b 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel generic sequences io words arrays summary effects continuations assocs accessors namespaces compiler.errors -stack-checker.values stack-checker.recursive-state ; +stack-checker.values stack-checker.recursive-state +source-files.errors compiler.errors ; IN: stack-checker.errors : pretty-word ( word -- word' ) @@ -10,7 +11,7 @@ IN: stack-checker.errors TUPLE: inference-error error type word ; -M: inference-error compiler-error-type type>> ; +M: inference-error source-file-error-type type>> ; : (inference-error) ( ... class type -- * ) [ boa ] dip @@ -18,10 +19,10 @@ M: inference-error compiler-error-type type>> ; \ inference-error boa rethrow ; inline : inference-error ( ... class -- * ) - +error+ (inference-error) ; inline + +compiler-error+ (inference-error) ; inline : inference-warning ( ... class -- * ) - +warning+ (inference-error) ; inline + +compiler-warning+ (inference-error) ; inline TUPLE: literal-expected what ; diff --git a/basis/tools/errors/errors-docs.factor b/basis/tools/errors/errors-docs.factor new file mode 100644 index 0000000000..b66b557a81 --- /dev/null +++ b/basis/tools/errors/errors-docs.factor @@ -0,0 +1,40 @@ +IN: tools.errors +USING: compiler.errors tools.errors help.markup help.syntax vocabs.loader +words quotations io ; + +ARTICLE: "compiler-errors" "Compiler warnings and errors" +"After loading a vocabulary, you might see messages like:" +{ $code + ":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 erroneous stack effect declarations." +$nl +"The precise warning and error conditions are documented in " { $link "inference-errors" } "." +$nl +"Words to view warnings and errors:" +{ $subsection :errors } +{ $subsection :warnings } +{ $subsection :linkage } +"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:" +{ $subsection with-compiler-errors } ; + +HELP: compiler-error +{ $values { "error" "an error" } { "word" word } } +{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ; + +HELP: with-compiler-errors +{ $values { "quot" quotation } } +{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." } +{ $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ; + +HELP: :errors +{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ; + +HELP: :warnings +{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ; + +HELP: :linkage +{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ; + +{ :errors :warnings } related-words diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor index 85a29986a6..4b717a8bdd 100644 --- a/basis/tools/errors/errors.factor +++ b/basis/tools/errors/errors.factor @@ -18,8 +18,8 @@ IN: tools.errors : compiler-errors. ( type -- ) errors-of-type values errors. ; -: :errors ( -- ) +error+ compiler-errors. ; +: :errors ( -- ) +compiler-error+ compiler-errors. ; -: :warnings ( -- ) +warning+ compiler-errors. ; +: :warnings ( -- ) +compiler-warning+ compiler-errors. ; -: :linkage ( -- ) +linkage+ compiler-errors. ; +: :linkage ( -- ) +linkage-error+ compiler-errors. ; diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor index 7889897c92..06a54f0868 100644 --- a/basis/tools/test/test-docs.factor +++ b/basis/tools/test/test-docs.factor @@ -14,22 +14,12 @@ ARTICLE: "tools.test.write" "Writing unit tests" ARTICLE: "tools.test.run" "Running unit tests" "The following words run test harness files; any test failures are collected and printed at the end:" { $subsection test } -{ $subsection test-all } ; - -ARTICLE: "tools.test.failure" "Handling test failures" -"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Some tools inspect the test failures and takes some kind of action instead, for example, " { $vocab-link "mason" } "." -$nl -"The following words output an association list mapping vocabulary names to sequences of failures; a failure is an array having the shape " { $snippet "{ error test continuation }" } ", and the elements are as follows:" -{ $list - { { $snippet "error" } " - the error thrown by the unit test" } - { { $snippet "test" } " - a pair " { $snippet "{ output input }" } " containing expected output and a unit test quotation which didn't produce this output" } - { { $snippet "continuation" } " - the traceback at the point of the error" } -} -"The following words run test harness files and output failures:" -{ $subsection run-tests } -{ $subsection run-all-tests } +{ $subsection test-all } "The following word prints failures:" -{ $subsection results. } ; +{ $subsection :failures } +"Unit test failurs are instances of a class, and are stored in a global variable:" +{ $subsection test-failure } +{ $subsection test-failures } ; ARTICLE: "tools.test" "Unit testing" "A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract." @@ -45,8 +35,7 @@ $nl $nl "If the test harness needs to define words, they should be placed in a vocabulary named " { $snippet { $emphasis "vocab" } ".tests" } " where " { $emphasis "vocab" } " is the vocab being tested." { $subsection "tools.test.write" } -{ $subsection "tools.test.run" } -{ $subsection "tools.test.failure" } ; +{ $subsection "tools.test.run" } ; ABOUT: "tools.test" @@ -78,17 +67,8 @@ HELP: test { $values { "prefix" "a vocabulary name" } } { $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies." } ; -HELP: run-tests -{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } } -{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies. Outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ; - HELP: test-all { $description "Runs unit tests for all loaded vocabularies." } ; -HELP: run-all-tests -{ $values { "failures" "an association list of unit test failures" } } -{ $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ; - -HELP: results. -{ $values { "assoc" "an association list of unit test failures" } } -{ $description "Prints unit test failures output by " { $link run-tests } " or " { $link run-all-tests } " to " { $link output-stream } "." } ; +HELP: :failures +{ $description "Prints all pending unit test failures." } ; diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index cce3279732..01b6bdbf69 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -5,13 +5,18 @@ continuations debugger effects fry generalizations io io.files io.styles kernel lexer locals macros math.parser namespaces parser prettyprint quotations sequences source-files splitting stack-checker summary unicode.case vectors vocabs vocabs.loader words -tools.vocabs tools.errors source-files.errors io.streams.string make ; +tools.vocabs tools.errors source-files.errors io.streams.string make +compiler.errors ; IN: tools.test -TUPLE: test-failure < source-file-error experiment continuation ; +TUPLE: test-failure < source-file-error continuation ; -SYMBOL: passed-tests -SYMBOL: failed-tests +SYMBOL: +test-failure+ + +M: test-failure source-file-error-type drop +test-failure+ ; + +SYMBOL: test-failures +test-failures [ V{ } clone ] initialize >line# swap >>file - swap >>experiment + swap >>asset swap >>error error-continuation get >>continuation ; : failure ( error experiment file line# -- ) "--> test failed!" print - failed-tests get push ; - -: success ( experiment -- ) passed-tests get push ; + test-failures get push ; : file-failure ( error file -- ) [ f ] [ f ] bi* failure ; @@ -71,7 +74,7 @@ MACRO: ( word -- ) :: experiment ( word: ( -- error ? ) file line# -- ) word :> e e experiment. - word execute [ e file line# failure ] [ drop e success ] if ; inline + word execute [ e file line# failure ] [ drop ] if ; inline : parse-test ( accum word -- accum ) literalize parsed @@ -90,16 +93,8 @@ SYNTAX: TEST: >> : run-test-file ( path -- ) - [ run-file ] [ swap file-failure ] recover ; - -: collect-results ( quot -- failed passed ) - [ - V{ } clone failed-tests set - V{ } clone passed-tests set - call - failed-tests get - passed-tests get - ] with-scope ; inline + [ [ test-failures get ] dip '[ file>> _ = not ] filter-here ] + [ [ run-file ] [ swap file-failure ] recover ] bi ; : run-vocab-tests ( vocab -- ) dup vocab source-loaded?>> [ @@ -118,30 +113,19 @@ TEST: must-fail-with TEST: must-fail M: test-failure summary - [ experiment>> experiment. ] with-string-writer ; + [ asset>> experiment. ] with-string-writer ; M: test-failure error. ( error -- ) [ call-next-method ] [ traceback-button. ] bi ; -: results. ( failed passed -- ) - [ - [ - [ length # " tests failed, " % ] - [ length # " tests passed." % ] - bi* - ] "" make nl print nl - ] [ drop errors. ] 2bi ; - -: run-tests ( prefix -- failed passed ) - [ child-vocabs [ run-vocab-tests ] each ] collect-results ; +: :failures ( -- ) test-failures get errors. ; : test ( prefix -- ) - run-tests results. ; + [ child-vocabs [ run-vocab-tests ] each ] with-compiler-errors + test-failures get [ + ":failures - show " write length pprint " failing tests." print + ] unless-empty ; -: run-all-tests ( -- failed passed ) - "" run-tests ; - -: test-all ( -- ) - run-all-tests results. ; +: test-all ( -- ) "" test ; diff --git a/basis/ui/tools/compiler-errors/compiler-errors.factor b/basis/ui/tools/compiler-errors/compiler-errors.factor index 44c17a00f4..91fad98633 100644 --- a/basis/ui/tools/compiler-errors/compiler-errors.factor +++ b/basis/ui/tools/compiler-errors/compiler-errors.factor @@ -2,14 +2,14 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays sequences sorting assocs colors.constants combinators combinators.smart combinators.short-circuit editors -compiler.errors compiler.units fonts kernel io.pathnames +compiler.errors compiler.units fonts kernel io.pathnames prettyprint stack-checker.errors source-files.errors math.parser math.order models models.arrow models.search debugger namespaces summary locals ui ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers ui.tools.inspector ui.gadgets.status-bar ui.operations -ui.gadgets.buttons ui.gadgets.borders ui.images ; +ui.gadgets.buttons ui.gadgets.borders ui.images tools.test ; IN: ui.tools.compiler-errors TUPLE: error-list-gadget < tool source-file error source-file-table error-table error-display ; @@ -17,7 +17,7 @@ TUPLE: error-list-gadget < tool source-file error source-file-table error-table SINGLETON: source-file-renderer M: source-file-renderer row-columns - drop [ first2 length number>string 2array ] [ { "All" "" } ] if* ; + drop first2 length number>string 2array ; M: source-file-renderer row-value drop dup [ first ] when ; @@ -30,7 +30,7 @@ M: source-file-renderer column-alignment drop { 0 1 } ; M: source-file-renderer filled-column drop 0 ; : ( model -- model' ) - [ values group-by-source-file >alist sort-keys f prefix ] ; + [ group-by-source-file >alist sort-keys ] ; :: ( error-list -- table ) error-list model>> @@ -48,36 +48,33 @@ M: source-file-renderer filled-column drop 0 ; SINGLETON: error-renderer -GENERIC: error-icon ( error -- icon ) - -: ( name -- image-name ) +: error-icon ( type -- icon ) + { + { +compiler-error+ [ "compiler-error" ] } + { +compiler-warning+ [ "compiler-warning" ] } + { +linkage-error+ [ "linkage-error" ] } + { +test-failure+ [ "unit-test-error" ] } + } case "vocab:ui/tools/error-list/icons/" ".tiff" surround ; -M: compiler-error error-icon - compiler-error-type { - { +error+ [ "compiler-error" ] } - { +warning+ [ "compiler-warning" ] } - { +linkage+ [ "linkage-error" ] } - } case ; - M: error-renderer row-columns drop [ { - [ error-icon ] + [ source-file-error-type error-icon ] [ line#>> number>string ] - [ word>> name>> ] + [ asset>> unparse-short ] [ error>> summary ] } cleave ] output>array ; M: error-renderer prototype-row - drop [ "compiler-error" "" "" "" ] output>array ; + drop [ +compiler-error+ error-icon "" "" "" ] output>array ; M: error-renderer row-value drop ; M: error-renderer column-titles - drop { "" "Line" "Word" "Error" } ; + drop { "" "Line" "Asset" "Error" } ; M: error-renderer column-alignment drop { 0 1 0 0 } ; @@ -85,8 +82,8 @@ M: error-renderer column-alignment drop { 0 1 0 0 } ; [ [ [ file>> ] [ line#>> ] bi 2array ] compare ] sort ; : ( error-list -- model ) - [ model>> [ values ] ] [ source-file>> ] bi - [ swap { [ drop not ] [ [ string>> ] [ file>> ] bi* = ] } 2|| ] + [ model>> ] [ source-file>> ] bi + [ [ file>> ] [ string>> ] bi* = ] [ sort-errors ] ; :: ( error-list -- table ) @@ -161,7 +158,8 @@ SINGLETON: updater M: updater definitions-changed 2drop - compiler-errors get-global + compiler-errors get-global values + test-failures get-global append compiler-error-model get-global set-model ; diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor index e1e176a8c4..42666ab064 100644 --- a/basis/ui/tools/debugger/debugger.factor +++ b/basis/ui/tools/debugger/debugger.factor @@ -8,7 +8,7 @@ ui.gadgets.buttons ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.tables ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback -ui.tools.inspector ; +ui.tools.inspector ui.tools.browser ; IN: ui.tools.debugger TUPLE: debugger < track error restarts restart-hook restart-list continuation ; diff --git a/core/compiler/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor index 8368afeb19..987db582b4 100644 --- a/core/compiler/errors/errors-docs.factor +++ b/core/compiler/errors/errors-docs.factor @@ -2,51 +2,7 @@ IN: compiler.errors USING: help.markup help.syntax vocabs.loader words io quotations words.symbol ; -ARTICLE: "compiler-errors" "Compiler warnings and errors" -"After loading a vocabulary, you might see messages like:" -{ $code - ":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 erroneous stack effect declarations." -$nl -"The precise warning and error conditions are documented in " { $link "inference-errors" } "." -$nl -"Words to view warnings and errors:" -{ $subsection :errors } -{ $subsection :warnings } -{ $subsection :linkage } -"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:" -{ $subsection with-compiler-errors } ; - HELP: compiler-errors { $var-description "Global variable holding an assoc mapping words to compiler errors. This variable is set by " { $link with-compiler-errors } "." } ; ABOUT: "compiler-errors" - -HELP: compiler-error -{ $values { "error" "an error" } { "word" word } } -{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ; - -HELP: compiler-error. -{ $values { "error" "an error" } { "word" word } } -{ $description "Prints a compiler error to " { $link output-stream } "." } ; - -HELP: compiler-errors. -{ $values { "type" symbol } } -{ $description "Prints compiler errors to " { $link output-stream } ". The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ; -HELP: :errors -{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ; - -HELP: :warnings -{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ; - -HELP: :linkage -{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ; - -{ :errors :warnings } related-words - -HELP: with-compiler-errors -{ $values { "quot" quotation } } -{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." } -{ $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ; diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor index 9d8ab3deab..1f02aaf341 100644 --- a/core/compiler/errors/errors.factor +++ b/core/compiler/errors/errors.factor @@ -5,15 +5,11 @@ continuations math math.parser accessors definitions source-files.errors ; IN: compiler.errors -SYMBOLS: +error+ +warning+ +linkage+ ; +SYMBOLS: +compiler-error+ +compiler-warning+ +linkage-error+ ; -TUPLE: compiler-error < source-file-error word ; +TUPLE: compiler-error < source-file-error ; -GENERIC: compiler-error-type ( error -- ? ) - -M: object compiler-error-type drop +error+ ; - -M: compiler-error compiler-error-type error>> compiler-error-type ; +M: compiler-error source-file-error-type error>> source-file-error-type ; SYMBOL: compiler-errors @@ -23,7 +19,7 @@ SYMBOL: with-compiler-errors? : errors-of-type ( type -- assoc ) compiler-errors get-global - swap [ [ nip compiler-error-type ] dip eq? ] curry + swap [ [ nip source-file-error-type ] dip eq? ] curry assoc-filter ; : (compiler-report) ( what type word -- ) @@ -40,14 +36,14 @@ SYMBOL: with-compiler-errors? ] if ; : compiler-report ( -- ) - "semantic errors" +error+ "errors" (compiler-report) - "semantic warnings" +warning+ "warnings" (compiler-report) - "linkage errors" +linkage+ "linkage" (compiler-report) ; + "compiler errors" +compiler-error+ "errors" (compiler-report) + "compiler warnings" +compiler-warning+ "warnings" (compiler-report) + "linkage errors" +linkage-error+ "linkage" (compiler-report) ; : ( error word -- compiler-error ) \ compiler-error new swap - [ >>word ] + [ >>asset ] [ where [ first2 ] [ "" 0 ] if* [ >>file ] [ >>line# ] bi* ] bi swap >>error ; diff --git a/core/source-files/errors/errors.factor b/core/source-files/errors/errors.factor index ca7c403609..7f19d04f84 100644 --- a/core/source-files/errors/errors.factor +++ b/core/source-files/errors/errors.factor @@ -3,10 +3,12 @@ USING: accessors assocs kernel math.order sorting sequences ; IN: source-files.errors -TUPLE: source-file-error error file line# ; +TUPLE: source-file-error error asset file line# ; : sort-errors ( errors -- alerrors'ist ) [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ; : group-by-source-file ( errors -- assoc ) H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ; + +GENERIC: source-file-error-type ( error -- type ) From a0ba66080d86a9aa624bdabd8c617d9337d2e9d4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 03:52:53 -0500 Subject: [PATCH 183/772] Documentation updates suggested by dmpk2k --- basis/help/handbook/handbook.factor | 2 ++ core/classes/tuple/tuple-docs.factor | 10 +++++----- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index b2a0e56c0a..0845264d61 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -49,6 +49,7 @@ $nl { "associative mapping" { "an object whose class implements the " { $link "assocs-protocol" } } } { "boolean" { { $link t } " or " { $link f } } } { "class" { "a set of objects identified by a " { $emphasis "class word" } " together with a discriminating predicate. See " { $link "classes" } } } + { "combinator" { "a word taking a quotation or another word as input; a higher-order function. See " { $link "combinators" } } } { "definition specifier" { "an instance of " { $link definition } " which implements the " { $link "definition-protocol" } } } { "generalized boolean" { "an object interpreted as a boolean; a value of " { $link f } " denotes false and anything else denotes true" } } { "generic word" { "a word whose behavior depends can be specialized on the class of one of its inputs. See " { $link "generic" } } } @@ -56,6 +57,7 @@ $nl { "object" { "any datum which can be identified" } } { "ordering specifier" { "see " { $link "order-specifiers" } } } { "pathname string" { "an OS-specific pathname which identifies a file" } } + { "quotation" { "an anonymous function; an instance of the " { $link quotation } " class. More generally, instances of the " { $link callable } " class can be used in many places documented to expect quotations" } } { "sequence" { "a sequence; see " { $link "sequence-protocol" } } } { "slot" { "a component of an object which can store a value" } } { "stack effect" { "a pictorial representation of a word's inputs and outputs, for example " { $snippet "+ ( x y -- z )" } ". See " { $link "effects" } } } diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 32cab65904..d76faddf15 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -92,7 +92,7 @@ ARTICLE: "tuple-constructors" "Tuple constructors" $nl "Constructors play a part in enforcing the invariant that slot values must always match slot declarations. The " { $link new } " word fills in the tuple with initial values, and " { $link boa } " ensures that the values on the stack match the corresponding slot declarations. See " { $link "tuple-declarations" } "." $nl -"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers." +"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construct a different class, without breaking callers." $nl "Examples of constructors:" { $code @@ -220,13 +220,13 @@ ARTICLE: "tuple-examples" "Tuple examples" " \"project manager\" >>position ;" } "An alternative strategy is to define the most general BOA constructor first:" { $code - ": ( name position -- person )" + ": ( name position -- employee )" " 40000 employee boa ;" } "Now we can define more specific constructors:" { $code - ": ( name -- person )" - " \"manager\" ;" } + ": ( name -- employee )" + " \"manager\" ;" } "An example using reader words:" { $code "TUPLE: check to amount number ;" @@ -256,7 +256,7 @@ ARTICLE: "tuple-examples" "Tuple examples" ": next-position ( role -- newrole )" " positions [ index 1+ ] keep nth ;" "" - ": promote ( person -- person )" + ": promote ( employee -- employee )" " [ 1.2 * ] change-salary" " [ next-position ] change-position ;" } From b11e0f60372ae13f7eea4f904d4781025fe644ca Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 04:01:59 -0500 Subject: [PATCH 184/772] assoc>query should not insert = if value is f. Reported by Chris Double --- basis/urls/encoding/encoding-tests.factor | 4 ++++ basis/urls/encoding/encoding.factor | 16 +++++++++++----- basis/urls/urls-tests.factor | 9 +++++++++ 3 files changed, 24 insertions(+), 5 deletions(-) diff --git a/basis/urls/encoding/encoding-tests.factor b/basis/urls/encoding/encoding-tests.factor index 87b1812ef8..78e31a764d 100644 --- a/basis/urls/encoding/encoding-tests.factor +++ b/basis/urls/encoding/encoding-tests.factor @@ -26,3 +26,7 @@ USING: urls.encoding tools.test arrays kernel assocs present accessors ; [ H{ { "text" "hello world" } } ] [ "text=hello+world" query>assoc ] unit-test [ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test + +[ "a" ] [ { { "a" f } } assoc>query ] unit-test + +[ H{ { "a" f } } ] [ "a" query>assoc ] unit-test \ No newline at end of file diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor index 7fed4b5f58..15b71ac0db 100644 --- a/basis/urls/encoding/encoding.factor +++ b/basis/urls/encoding/encoding.factor @@ -72,6 +72,15 @@ PRIVATE> ] when* ] 2keep set-at ; +: assoc-strings ( assoc -- assoc' ) + [ + { + { [ dup not ] [ ] } + { [ dup array? ] [ [ present ] map ] } + [ present 1array ] + } cond + ] assoc-map ; + PRIVATE> : query>assoc ( query -- assoc ) @@ -86,11 +95,8 @@ PRIVATE> : assoc>query ( assoc -- str ) [ - dup array? [ [ present ] map ] [ present 1array ] if - ] assoc-map - [ - [ + assoc-strings [ [ url-encode ] dip - [ url-encode "=" glue , ] with each + [ [ url-encode "=" glue , ] with each ] [ , ] if* ] assoc-each ] { } make "&" join ; diff --git a/basis/urls/urls-tests.factor b/basis/urls/urls-tests.factor index f45ad6449e..f2ecd6ec69 100644 --- a/basis/urls/urls-tests.factor +++ b/basis/urls/urls-tests.factor @@ -80,6 +80,15 @@ CONSTANT: urls } "ftp://slava:secret@ftp.kernel.org/" } + { + T{ url + { protocol "http" } + { host "foo.com" } + { path "/" } + { query H{ { "a" f } } } + } + "http://foo.com/?a" + } } urls [ From 2b26da1ad23f73c47f2182c846337677386d5674 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 04:03:06 -0500 Subject: [PATCH 185/772] Move images.normalization to extra since its not used for anything anymore --- {basis => extra}/images/normalization/authors.txt | 0 {basis => extra}/images/normalization/normalization.factor | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename {basis => extra}/images/normalization/authors.txt (100%) rename {basis => extra}/images/normalization/normalization.factor (100%) diff --git a/basis/images/normalization/authors.txt b/extra/images/normalization/authors.txt similarity index 100% rename from basis/images/normalization/authors.txt rename to extra/images/normalization/authors.txt diff --git a/basis/images/normalization/normalization.factor b/extra/images/normalization/normalization.factor similarity index 100% rename from basis/images/normalization/normalization.factor rename to extra/images/normalization/normalization.factor From 4f41e07147f2ae26404e353f86b4c17cd1e53f00 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 04:41:12 -0500 Subject: [PATCH 186/772] ui.tools.compiler-errors => ui.tools.error-list --- basis/ui/tools/{compiler-errors => error-list}/authors.txt | 0 .../compiler-errors.factor => error-list/error-list.factor} | 2 +- 2 files changed, 1 insertion(+), 1 deletion(-) rename basis/ui/tools/{compiler-errors => error-list}/authors.txt (100%) rename basis/ui/tools/{compiler-errors/compiler-errors.factor => error-list/error-list.factor} (98%) diff --git a/basis/ui/tools/compiler-errors/authors.txt b/basis/ui/tools/error-list/authors.txt similarity index 100% rename from basis/ui/tools/compiler-errors/authors.txt rename to basis/ui/tools/error-list/authors.txt diff --git a/basis/ui/tools/compiler-errors/compiler-errors.factor b/basis/ui/tools/error-list/error-list.factor similarity index 98% rename from basis/ui/tools/compiler-errors/compiler-errors.factor rename to basis/ui/tools/error-list/error-list.factor index 91fad98633..b1f3c725d4 100644 --- a/basis/ui/tools/compiler-errors/compiler-errors.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -10,7 +10,7 @@ ui.gadgets.labeled ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers ui.tools.inspector ui.gadgets.status-bar ui.operations ui.gadgets.buttons ui.gadgets.borders ui.images tools.test ; -IN: ui.tools.compiler-errors +IN: ui.tools.error-list TUPLE: error-list-gadget < tool source-file error source-file-table error-table error-display ; From deae1d7bbb55818f039922308689b1413c364ca3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 04:41:26 -0500 Subject: [PATCH 187/772] Fix bootstrap --- basis/bootstrap/tools/tools.factor | 1 + basis/compiler/tree/builder/builder.factor | 4 +++- basis/editors/editors-docs.factor | 3 ++- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/basis/bootstrap/tools/tools.factor b/basis/bootstrap/tools/tools.factor index b0afe4a1d9..cb0792ee1e 100644 --- a/basis/bootstrap/tools/tools.factor +++ b/basis/bootstrap/tools/tools.factor @@ -6,6 +6,7 @@ IN: bootstrap.tools "bootstrap.image" "tools.annotations" "tools.crossref" + "tools.errors" "tools.deploy" "tools.disassembler" "tools.memory" diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 4cb7650b1d..dc87d596aa 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -42,8 +42,10 @@ IN: compiler.tree.builder : check-cannot-infer ( word -- ) dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ; +TUPLE: do-not-compile word ; + : check-no-compile ( word -- ) - dup "no-compile" word-prop [ cannot-infer-effect ] [ drop ] if ; + dup "no-compile" word-prop [ do-not-compile inference-warning ] [ drop ] if ; : build-tree-from-word ( word -- nodes ) [ diff --git a/basis/editors/editors-docs.factor b/basis/editors/editors-docs.factor index e3961aef80..646582beb0 100644 --- a/basis/editors/editors-docs.factor +++ b/basis/editors/editors-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax parser source-files vocabs.loader ; +USING: help.markup help.syntax parser source-files +source-files.errors vocabs.loader ; IN: editors ARTICLE: "editor" "Editor integration" From 713ab023379ab4b4cb229c97e10cd1d38e2cf73d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 06:18:29 -0500 Subject: [PATCH 188/772] Don't use GL_ARB_texture_non_power_of_two on ATI hardware to fix bug reported by Andy Turner and Caesar Hu --- basis/opengl/capabilities/capabilities.factor | 2 ++ basis/opengl/textures/textures.factor | 16 +++++++++++++--- basis/ui/gadgets/worlds/worlds.factor | 10 +++------- 3 files changed, 18 insertions(+), 10 deletions(-) diff --git a/basis/opengl/capabilities/capabilities.factor b/basis/opengl/capabilities/capabilities.factor index 09d49b33c2..ad04ce7fa5 100755 --- a/basis/opengl/capabilities/capabilities.factor +++ b/basis/opengl/capabilities/capabilities.factor @@ -32,6 +32,8 @@ IN: opengl.capabilities (gl-version) drop ; : gl-vendor-version ( -- version ) (gl-version) nip ; +: gl-vendor ( -- name ) + GL_VENDOR glGetString ; : has-gl-version? ( version -- ? ) gl-version version-before? ; : (make-gl-version-error) ( required-version -- ) diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index a565a14597..76e0c473b9 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -1,13 +1,23 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs cache colors.constants destructors fry kernel -opengl opengl.gl combinators images images.tesselation grouping -specialized-arrays.float sequences math math.vectors -math.matrices generalizations fry arrays namespaces ; +opengl opengl.gl opengl.capabilities combinators images +images.tesselation grouping specialized-arrays.float sequences math +math.vectors math.matrices generalizations fry arrays namespaces +system ; IN: opengl.textures SYMBOL: non-power-of-2-textures? +: check-extensions ( -- ) + #! ATI frglx driver doesn't implement GL_ARB_texture_non_power_of_two properly. + #! See thread 'Linux font display problem' April 2009 on Factor-talk + gl-vendor "ATI Technologies Inc." = not os macosx? or [ + "2.0" { "GL_ARB_texture_non_power_of_two" } + has-gl-version-or-extensions? + non-power-of-2-textures? set + ] when ; + : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ; : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ; diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index f671add531..a186de7670 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs continuations kernel math models -namespaces opengl opengl.capabilities opengl.textures sequences io -combinators combinators.short-circuit fry math.vectors math.rectangles -cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks +namespaces opengl opengl.textures sequences io combinators +combinators.short-circuit fry math.vectors math.rectangles cache +ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks ui.commands ; IN: ui.gadgets.worlds @@ -77,10 +77,6 @@ SYMBOL: flush-layout-cache-hook flush-layout-cache-hook [ [ ] ] initialize -: check-extensions ( -- ) - "2.0" { "GL_ARB_texture_non_power_of_two" } has-gl-version-or-extensions? - non-power-of-2-textures? set ; - : (draw-world) ( world -- ) dup handle>> [ check-extensions From 370e90f57bc535a950d28091b41ff5197ecf7038 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 06:19:46 -0500 Subject: [PATCH 189/772] Fix odd race condition in ui.backend.cocoa --- basis/ui/backend/cocoa/cocoa.factor | 2 +- basis/ui/backend/cocoa/views/views.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index fc392c595d..1bbf46c69e 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -70,8 +70,8 @@ M:: cocoa-ui-backend (open-window) ( world -- ) world dim>> :> view view world world>NSRect :> window view -> release - window world window-loc>> auto-position world view register-window + window world window-loc>> auto-position world window save-position window install-window-delegate view window world (>>handle) diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index b59848260d..602c9bec73 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -336,7 +336,7 @@ CLASS: { ! Initialization { "updateFactorGadgetSize:" "void" { "id" "SEL" "id" } - [ 2drop dup view-dim swap window (>>dim) yield ] + [ 2drop [ window ] [ view-dim ] bi >>dim drop yield ] } { "doCommandBySelector:" "void" { "id" "SEL" "SEL" } From e2c858da3481213f7fd74ddfc9ed393bd47f608d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 06:20:23 -0500 Subject: [PATCH 190/772] Add better error check for 'window' word --- basis/ui/ui.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index dff7726d08..1de3912f28 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -12,7 +12,10 @@ IN: ui ! Assoc mapping aliens to gadgets SYMBOL: windows -: window ( handle -- world ) windows get-global at ; +ERROR: no-window handle ; + +: window ( handle -- world ) + windows get-global ?at [ no-window ] unless ; : window-focus ( handle -- gadget ) window world-focus ; From 8290624733f6f4df5c0ca5d6e87c8b374e95c706 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 07:08:16 -0500 Subject: [PATCH 191/772] Macro expansion errors are now wrapped --- basis/stack-checker/errors/errors.factor | 5 +++++ .../errors/prettyprint/prettyprint.factor | 9 +++++++++ .../stack-checker/transforms/transforms-tests.factor | 11 +++++++++-- basis/stack-checker/transforms/transforms.factor | 7 ++++++- 4 files changed, 29 insertions(+), 3 deletions(-) diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index a4d22f8a5b..799e3f73e3 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -82,3 +82,8 @@ TUPLE: unknown-primitive-error ; : unknown-primitive-error ( -- * ) \ unknown-primitive-error inference-warning ; + +TUPLE: transform-expansion-error word error ; + +: transform-expansion-error ( word error -- * ) + \ transform-expansion-error inference-error ; \ No newline at end of file diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index de73a3e731..d6cee8e08f 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -79,3 +79,12 @@ M: inconsistent-recursive-call-error summary M: unknown-primitive-error summary drop "Cannot determine stack effect statically" ; + +M: transform-expansion-error summary + drop + "Compiler transform threw an error" ; + +M: transform-expansion-error error. + [ summary print ] + [ "Word: " write word>> . nl ] + [ error>> error. ] tri ; \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index 0aa3876907..abb1f2abdb 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -1,6 +1,6 @@ IN: stack-checker.transforms.tests USING: sequences stack-checker.transforms tools.test math kernel -quotations stack-checker accessors combinators words arrays +quotations stack-checker stack-checker.errors accessors combinators words arrays classes classes.tuple ; : compose-n-quot ( word n -- quot' ) >quotation ; @@ -70,4 +70,11 @@ DEFER: curry-folding-test ( quot -- ) : member?-test ( a -- ? ) { 1 2 3 10 7 58 } member? ; [ f ] [ 1.0 member?-test ] unit-test -[ t ] [ \ member?-test def>> first [ member?-test ] all? ] unit-test \ No newline at end of file +[ t ] [ \ member?-test def>> first [ member?-test ] all? ] unit-test + +! Macro expansion should throw its own type of error +: bad-macro ( -- ) ; + +\ bad-macro [ "OOPS" throw ] 0 define-transform + +[ [ bad-macro ] infer ] [ inference-error? ] must-fail-with \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index c2b348f5f1..541d74bdeb 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -17,9 +17,14 @@ IN: stack-checker.transforms [ dup infer-word apply-word/effect ] } cond ; +: call-transformer ( word stack quot -- newquot ) + '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ] + [ transform-expansion-error ] + recover ; + :: ((apply-transform)) ( word quot values stack rstate -- ) rstate recursive-state - [ stack quot with-datastack first ] with-variable + [ word stack quot call-transformer ] with-variable [ word inlined-dependency depends-on values [ length meta-d shorten-by ] [ #drop, ] bi From a0ad6bda39a3d62900bf68036931bfd281ce0222 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 08:11:46 -0500 Subject: [PATCH 192/772] tools.test: store file in a variable while tests are running --- basis/tools/test/test.factor | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 01b6bdbf69..8c308e6406 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -32,8 +32,10 @@ test-failures [ V{ } clone ] initialize "--> test failed!" print test-failures get push ; -: file-failure ( error file -- ) - [ f ] [ f ] bi* failure ; +SYMBOL: file + +: file-failure ( error -- ) + f file get f failure ; :: (unit-test) ( output input -- error ? ) [ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; inline @@ -71,14 +73,17 @@ MACRO: ( word -- ) : experiment. ( seq -- ) [ first write ": " write ] [ rest . ] bi ; -:: experiment ( word: ( -- error ? ) file line# -- ) +:: experiment ( word: ( -- error ? ) line# -- ) word :> e e experiment. - word execute [ e file line# failure ] [ drop ] if ; inline + word execute [ + file get [ + e file get line# failure + ] [ rethrow ] if + ] [ drop ] if ; inline : parse-test ( accum word -- accum ) literalize parsed - file get dup [ path>> ] when parsed lexer get line>> parsed \ experiment parsed ; inline @@ -93,8 +98,10 @@ SYNTAX: TEST: >> : run-test-file ( path -- ) - [ [ test-failures get ] dip '[ file>> _ = not ] filter-here ] - [ [ run-file ] [ swap file-failure ] recover ] bi ; + dup file [ + test-failures get [ file>> file get = not ] filter-here + '[ _ run-file ] [ file-failure ] recover + ] with-variable ; : run-vocab-tests ( vocab -- ) dup vocab source-loaded?>> [ @@ -113,7 +120,7 @@ TEST: must-fail-with TEST: must-fail M: test-failure summary - [ asset>> experiment. ] with-string-writer ; + asset>> [ [ experiment. ] with-string-writer ] [ "Top-level form" ] if* ; M: test-failure error. ( error -- ) [ call-next-method ] From 8480034d6e9179ed1096e61219110a3210f4a44f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 08:13:20 -0500 Subject: [PATCH 193/772] image-name instances can now be passed to
+ + + +
Build machine:<->
Build directory:<->
GIT ID:<->
+ XML] ; : with-report ( quot -- ) - [ "report" utf8 ] dip '[ common-report @ ] with-file-writer ; inline + [ "report" utf8 ] dip + '[ + common-report + _ call( -- xml ) + [XML <-><-> XML] + pprint-xml + ] with-file-writer ; inline + +:: failed-report ( error file what -- ) + [ + error [ error. ] with-string-writer :> error + file utf8 file-contents 400 short tail* :> output + + [XML +

<-what->

+ Build output: + 
<-output->
+ Launcher error: + 
<-error->
+ XML] + ] with-report ; : compile-failed-report ( error -- ) - [ - "VM compile failed:" print nl - "compile-log" cat nl - error. - ] with-report ; + "compile-log" "VM compilation failed" failed-report ; : boot-failed-report ( error -- ) - [ - "Bootstrap failed:" print nl - "boot-log" 100 cat-n nl - error. - ] with-report ; + "boot-log" "Bootstrap failed" failed-report ; : test-failed-report ( error -- ) + "test-log" "Tests failed" failed-report ; + +: timings-table ( -- xml ) + { + boot-time-file + load-time-file + test-time-file + help-lint-time-file + benchmark-time-file + html-help-time-file + } [ + dup utf8 file-contents milli-seconds>time + [XML <-><-> XML] + ] map [XML

Timings

<->
XML] ; + +: fail-dump ( heading vocabs-file messages-file -- xml ) + [ eval-file ] dip over empty? [ 3drop f ] [ + [ ] + [ [ [XML
  • <->
    • XML] ] map [XML
      <->
    XML] ] + [ utf8 file-contents ] + tri* + [XML

    <->

    <-> Details: 
    <->
    XML] + ] if ; + +: benchmarks-table ( assoc -- xml ) [ - "Tests failed:" print nl - "test-log" 100 cat-n nl - error. - ] with-report ; + 1000000 /f + [XML <-><-> XML] + ] { } assoc>map [XML

    Benchmarks

    <->
    XML] ; : successful-report ( -- ) [ - boot-time-file time. - load-time-file time. - test-time-file time. - help-lint-time-file time. - benchmark-time-file time. - html-help-time-file time. + [ + timings-table - nl + "Load failures" + load-everything-vocabs-file + load-everything-errors-file + fail-dump - load-everything-vocabs-file eval-file [ - "== Did not pass load-everything:" print . - load-everything-errors-file cat - ] unless-empty + "Compiler warnings and errors" + compiler-errors-file + compiler-error-messages-file + fail-dump - compiler-errors-file eval-file [ - "== Vocabularies with compiler errors:" print . - ] unless-empty + "Unit test failures" + test-all-vocabs-file + test-all-errors-file + fail-dump + + "Help lint failures" + help-lint-vocabs-file + help-lint-errors-file + fail-dump - test-all-vocabs-file eval-file [ - "== Did not pass test-all:" print . - test-all-errors-file cat - ] unless-empty - - help-lint-vocabs-file eval-file [ - "== Did not pass help-lint:" print . - help-lint-errors-file cat - ] unless-empty - - "== Benchmarks:" print - benchmarks-file eval-file benchmarks. + "Benchmark errors" + benchmark-error-vocabs-file + benchmark-error-messages-file + fail-dump + + "Benchmark timings" + benchmarks-file eval-file benchmarks-table + ] output>array ] with-report ; \ No newline at end of file diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 4c212b07fb..11a15328fb 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs benchmark bootstrap.stage2 compiler.errors generic help.html help.lint io.directories @@ -42,7 +42,11 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; do-step ; : do-benchmarks ( -- ) - run-benchmarks benchmarks-file to-file ; + run-benchmarks + [ + [ keys benchmark-error-vocabs-file to-file ] + [ benchmark-error-messages-file utf8 [ benchmark-errors. ] with-file-writer ] bi + ] [ benchmarks-file to-file ] bi* ; : benchmark-ms ( quot -- ms ) benchmark 1000 /i ; inline From 7eaa20a4c5cc2d376112bdc5c0ef921c588594dd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 18:04:41 -0500 Subject: [PATCH 341/772] fix stack effect of n*quot, use iota in core/slots --- basis/generalizations/generalizations-docs.factor | 4 ++-- basis/generalizations/generalizations.factor | 4 ++-- core/slots/slots.factor | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 2088e468c6..3671511194 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -272,8 +272,8 @@ HELP: nweave HELP: n*quot { $values - { "n" integer } { "seq" sequence } - { "seq'" sequence } + { "n" integer } { "quot" quotation } + { "quot'" quotation } } { $examples { $example "USING: generalizations prettyprint math ;" diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 0aa042d4f2..637f958eb5 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -7,7 +7,7 @@ IN: generalizations << -: n*quot ( n seq -- seq' ) concat >quotation ; +: n*quot ( n quot -- seq' ) concat >quotation ; : repeat ( n obj quot -- ) swapd times ; inline @@ -94,4 +94,4 @@ MACRO: nweave ( n -- ) : nappend-as ( n exemplar -- seq ) [ narray concat ] dip like ; inline -: nappend ( n -- seq ) narray concat ; inline \ No newline at end of file +: nappend ( n -- seq ) narray concat ; inline diff --git a/core/slots/slots.factor b/core/slots/slots.factor index a353f50947..63c0319c1c 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -222,7 +222,7 @@ M: slot-spec make-slot [ make-slot ] map ; : finalize-slots ( specs base -- specs ) - over length [ + ] with map [ >>offset ] 2map ; + over length iota [ + ] with map [ >>offset ] 2map ; : slot-named ( name specs -- spec/f ) [ name>> = ] with find nip ; From a6ea915e09ee6be408207a71ed302927fff503e7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:21:51 -0500 Subject: [PATCH 342/772] mason: filter out linakge errors from build reports --- extra/mason/test/test.factor | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 11a15328fb..88ccf93942 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs benchmark bootstrap.stage2 -compiler.errors generic help.html help.lint io.directories +USING: accessors assocs benchmark bootstrap.stage2 compiler.errors +source-files.errors generic help.html help.lint io.directories io.encodings.utf8 io.files kernel mason.common math namespaces -prettyprint sequences sets sorting tools.test tools.time -tools.vocabs words system io tools.errors locals ; +prettyprint sequences sets sorting tools.test tools.time tools.vocabs +words system io tools.errors locals ; IN: mason.test : do-load ( -- ) @@ -20,7 +20,9 @@ M: word word-vocabulary vocabulary>> ; M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; :: do-step ( errors summary-file details-file -- ) - errors [ file>> ] map prune natural-sort summary-file to-file + errors + [ error-type +linkage-error+ eq? not ] filter + [ file>> ] map prune natural-sort summary-file to-file errors details-file utf8 [ errors. ] with-file-writer ; : do-compile-errors ( -- ) From f4cdcaa1ce3ef2c86f26e833c91fd68ccea39eb4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:38:55 -0500 Subject: [PATCH 343/772] Fix compiler warnings in tools.deploy.shaker --- basis/tools/deploy/shaker/shaker.factor | 6 +++--- vm/data_gc.c | 3 ++- vm/data_gc.h | 1 + vm/image.c | 2 ++ 4 files changed, 8 insertions(+), 4 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 2fc1ada108..37eec5eae2 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -357,7 +357,7 @@ IN: tools.deploy.shaker V{ } set-namestack V{ } set-catchstack "Saving final image" show - [ save-image-and-exit ] call-clear ; + save-image-and-exit ; SYMBOL: deploy-vocab @@ -421,10 +421,10 @@ SYMBOL: deploy-vocab : deploy-error-handler ( quot -- ) [ strip-debugger? - [ error-continuation get call>> callstack>array die ] + [ error-continuation get call>> callstack>array die 1 exit ] ! Don't reference these words literally, if we're stripping the ! debugger out we don't want to load the prettyprinter at all - [ [:c] execute nl [print-error] execute flush ] if + [ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if 1 exit ] recover ; inline diff --git a/vm/data_gc.c b/vm/data_gc.c index a91eff6783..11c1639fea 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -160,7 +160,8 @@ void copy_roots(void) copy_handle(&stacks->catchstack_save); copy_handle(&stacks->current_callback_save); - mark_active_blocks(stacks); + if(!performing_compaction) + mark_active_blocks(stacks); stacks = stacks->next; } diff --git a/vm/data_gc.h b/vm/data_gc.h index 354c9398a5..feae26706d 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -5,6 +5,7 @@ DLLEXPORT void minor_gc(void); F_ZONE *newspace; bool performing_gc; +bool performing_compaction; CELL collecting_gen; /* if true, we collecting AGING space for the second time, so if it is still diff --git a/vm/image.c b/vm/image.c index a1987180d0..9cc97df0d9 100755 --- a/vm/image.c +++ b/vm/image.c @@ -187,7 +187,9 @@ void primitive_save_image_and_exit(void) userenv[i] = F; /* do a full GC + code heap compaction */ + performing_compaction = true; compact_code_heap(); + performing_compaction = false; UNREGISTER_C_STRING(path); From bbd496e3043fb7cbff9d2a58706054b4db277bfd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:42:51 -0500 Subject: [PATCH 344/772] 4DNav.file-chooser: fix compiler warning --- extra/4DNav/file-chooser/file-chooser.factor | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/extra/4DNav/file-chooser/file-chooser.factor b/extra/4DNav/file-chooser/file-chooser.factor index ad799f75c9..51bebc3877 100755 --- a/extra/4DNav/file-chooser/file-chooser.factor +++ b/extra/4DNav/file-chooser/file-chooser.factor @@ -92,11 +92,9 @@ file-chooser H{ ; : fc-load-file ( file-chooser file -- ) - dupd [ selected-file>> ] [ name>> ] bi* swap set-model - [ path>> value>> ] - [ selected-file>> value>> append ] - [ hook>> ] tri - call + over [ name>> ] [ selected-file>> ] bi* set-model + [ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi + call( path -- ) ; inline ! : fc-ok-action ( file-chooser -- quot ) From 7db33912a0419a74a85f9962e4134f7d894c50b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:42:58 -0500 Subject: [PATCH 345/772] bank: fix compiler warning --- extra/bank/bank.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor index f06bc2fb81..31a4b75eb2 100644 --- a/extra/bank/bank.factor +++ b/extra/bank/bank.factor @@ -54,7 +54,7 @@ C: transaction : process-day ( account date -- ) 2dup accumulate-interest ?pay-interest ; -: each-day ( quot start end -- ) +: each-day ( quot: ( -- ) start end -- ) 2dup before? [ [ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day ] [ @@ -63,7 +63,7 @@ C: transaction : process-to-date ( account date -- account ) over interest-last-paid>> 1 days time+ - [ dupd process-day ] spin each-day ; inline + [ dupd process-day ] spin each-day ; : inserting-transactions ( account transactions -- account ) [ [ date>> process-to-date ] keep >>transaction ] each ; From f36a3c47133798232a5d55ccec45c7a3349ccbb6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:49:36 -0500 Subject: [PATCH 346/772] fuel: Fix compiler warnings --- extra/fuel/eval/eval.factor | 15 +++++++-------- extra/fuel/fuel.factor | 2 +- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/extra/fuel/eval/eval.factor b/extra/fuel/eval/eval.factor index c3b1a8a3f2..b4a138459f 100644 --- a/extra/fuel/eval/eval.factor +++ b/extra/fuel/eval/eval.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays compiler.units continuations debugger fuel.pprint io io.streams.string kernel namespaces parser sequences -vectors vocabs.parser ; +vectors vocabs.parser eval fry ; IN: fuel.eval @@ -55,21 +55,20 @@ t fuel-eval-res-flag set-global : (fuel-end-eval) ( output -- ) fuel-eval-output set-global fuel-send-retort fuel-pop-status ; inline -: (fuel-eval) ( lines -- ) - [ [ parse-lines ] with-compilation-unit call ] curry - [ print-error ] recover ; inline +: (fuel-eval) ( string -- ) + '[ _ eval( -- ) ] try ; : (fuel-eval-each) ( lines -- ) - [ 1vector (fuel-eval) ] each ; inline + [ (fuel-eval) ] each ; : (fuel-eval-usings) ( usings -- ) - [ "USING: " prepend " ;" append ] map + [ "USE: " prepend ] map (fuel-eval-each) fuel-forget-error fuel-forget-output ; : (fuel-eval-in) ( in -- ) - [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline + [ dup "IN: " prepend (fuel-eval) in set ] when* ; : (fuel-eval-in-context) ( lines in usings -- ) (fuel-begin-eval) - [ (fuel-eval-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer + [ (fuel-eval-usings) (fuel-eval-in) "\n" join (fuel-eval) ] with-string-writer (fuel-end-eval) ; diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 403708e880..413aefdc76 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -104,7 +104,7 @@ PRIVATE> : fuel-vocab-summary ( name -- ) (fuel-vocab-summary) fuel-eval-set-result ; -: fuel-index ( quot -- ) call format-index fuel-eval-set-result ; +: fuel-index ( quot -- ) call( -- seq ) format-index fuel-eval-set-result ; : fuel-get-vocabs/tag ( tag -- ) (fuel-get-vocabs/tag) fuel-eval-set-result ; From d929134ad712736b4f0506a04787edd04e43f08e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:49:46 -0500 Subject: [PATCH 347/772] dns: Fix compiler warning --- extra/dns/util/util.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/dns/util/util.factor b/extra/dns/util/util.factor index 5b2e63838a..f47eb7010c 100644 --- a/extra/dns/util/util.factor +++ b/extra/dns/util/util.factor @@ -28,4 +28,4 @@ TUPLE: packet data addr socket ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: forever ( quot -- ) [ call ] [ forever ] bi ; inline recursive \ No newline at end of file +: forever ( quot: ( -- ) -- ) [ call ] [ forever ] bi ; inline recursive \ No newline at end of file From aff996a58fdb4edde75b1ff894aaa86dbd33ec45 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:49:59 -0500 Subject: [PATCH 348/772] math.function-tools: Fix compiler warning --- extra/math/function-tools/function-tools.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/math/function-tools/function-tools.factor b/extra/math/function-tools/function-tools.factor index 11e57d2639..78c726d370 100644 --- a/extra/math/function-tools/function-tools.factor +++ b/extra/math/function-tools/function-tools.factor @@ -9,10 +9,10 @@ IN: math.function-tools [ bi - ] 2curry ; inline : eval ( x func -- pt ) - dupd call 2array ; inline + dupd call( x -- y ) 2array ; inline : eval-inverse ( y func -- pt ) - dupd call swap 2array ; inline + dupd call( y -- x ) swap 2array ; inline : eval3d ( x y func -- pt ) - [ 2dup ] dip call 3array ; inline + [ 2dup ] dip call( x y -- z ) 3array ; inline From 1b4e778102c68fd05213cb35ca7a36f2bed247fc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:50:14 -0500 Subject: [PATCH 349/772] advice: move to unmaintained --- {extra => unmaintained}/advice/advice-docs.factor | 0 {extra => unmaintained}/advice/advice-tests.factor | 0 {extra => unmaintained}/advice/advice.factor | 0 {extra => unmaintained}/advice/authors.txt | 0 {extra => unmaintained}/advice/summary.txt | 0 {extra => unmaintained}/advice/tags.txt | 0 6 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/advice/advice-docs.factor (100%) rename {extra => unmaintained}/advice/advice-tests.factor (100%) rename {extra => unmaintained}/advice/advice.factor (100%) rename {extra => unmaintained}/advice/authors.txt (100%) rename {extra => unmaintained}/advice/summary.txt (100%) rename {extra => unmaintained}/advice/tags.txt (100%) diff --git a/extra/advice/advice-docs.factor b/unmaintained/advice/advice-docs.factor similarity index 100% rename from extra/advice/advice-docs.factor rename to unmaintained/advice/advice-docs.factor diff --git a/extra/advice/advice-tests.factor b/unmaintained/advice/advice-tests.factor similarity index 100% rename from extra/advice/advice-tests.factor rename to unmaintained/advice/advice-tests.factor diff --git a/extra/advice/advice.factor b/unmaintained/advice/advice.factor similarity index 100% rename from extra/advice/advice.factor rename to unmaintained/advice/advice.factor diff --git a/extra/advice/authors.txt b/unmaintained/advice/authors.txt similarity index 100% rename from extra/advice/authors.txt rename to unmaintained/advice/authors.txt diff --git a/extra/advice/summary.txt b/unmaintained/advice/summary.txt similarity index 100% rename from extra/advice/summary.txt rename to unmaintained/advice/summary.txt diff --git a/extra/advice/tags.txt b/unmaintained/advice/tags.txt similarity index 100% rename from extra/advice/tags.txt rename to unmaintained/advice/tags.txt From c6072d7b4b24a585fb28a26d1eced500ff4922e8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:55:59 -0500 Subject: [PATCH 350/772] fuel.eval: fix --- extra/fuel/eval/eval.factor | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/extra/fuel/eval/eval.factor b/extra/fuel/eval/eval.factor index b4a138459f..ae1c5863a8 100644 --- a/extra/fuel/eval/eval.factor +++ b/extra/fuel/eval/eval.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays compiler.units continuations debugger fuel.pprint io io.streams.string kernel namespaces parser sequences -vectors vocabs.parser eval fry ; +vectors vocabs.parser ; IN: fuel.eval @@ -21,7 +21,7 @@ SYMBOL: fuel-eval-res-flag t fuel-eval-res-flag set-global : fuel-eval-restartable? ( -- ? ) - fuel-eval-res-flag get-global ; inline + fuel-eval-res-flag get-global ; : fuel-push-status ( -- ) in get use get clone restarts get-global clone @@ -29,7 +29,7 @@ t fuel-eval-res-flag set-global fuel-status-stack get push ; : fuel-pop-restarts ( restarts -- ) - fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ; inline + fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ; : fuel-pop-status ( -- ) fuel-status-stack get empty? [ @@ -39,24 +39,25 @@ t fuel-eval-res-flag set-global [ restarts>> fuel-pop-restarts ] tri ] unless ; -: fuel-forget-error ( -- ) f error set-global ; inline -: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline -: fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline +: fuel-forget-error ( -- ) f error set-global ; +: fuel-forget-result ( -- ) f fuel-eval-result set-global ; +: fuel-forget-output ( -- ) f fuel-eval-output set-global ; : fuel-forget-status ( -- ) - fuel-forget-error fuel-forget-result fuel-forget-output ; inline + fuel-forget-error fuel-forget-result fuel-forget-output ; : fuel-send-retort ( -- ) error get fuel-eval-result get-global fuel-eval-output get-global 3array fuel-pprint flush nl "<~FUEL~>" write nl flush ; : (fuel-begin-eval) ( -- ) - fuel-push-status fuel-forget-status ; inline + fuel-push-status fuel-forget-status ; : (fuel-end-eval) ( output -- ) - fuel-eval-output set-global fuel-send-retort fuel-pop-status ; inline + fuel-eval-output set-global fuel-send-retort fuel-pop-status ; -: (fuel-eval) ( string -- ) - '[ _ eval( -- ) ] try ; +: (fuel-eval) ( lines -- ) + [ [ parse-lines ] with-compilation-unit call( -- ) ] curry + [ print-error ] recover ; : (fuel-eval-each) ( lines -- ) [ (fuel-eval) ] each ; From 394a4ec315df0dc7b0567f90a1d61b929f6e4000 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:58:58 -0500 Subject: [PATCH 351/772] io.launcher.windows.nt: update for eval( --- basis/io/launcher/windows/nt/nt-tests.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor index 04202365fd..53b3d3ce7e 100755 --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -98,7 +98,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) os-envs = ] unit-test @@ -110,7 +110,7 @@ IN: io.launcher.windows.nt.tests +replace-environment+ >>environment-mode os-envs >>environment ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) os-envs = ] unit-test @@ -121,7 +121,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command { { "A" "B" } } >>environment ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) "A" swap at ] unit-test @@ -133,7 +133,7 @@ IN: io.launcher.windows.nt.tests { { "USERPROFILE" "XXX" } } >>environment +prepend-environment+ >>environment-mode ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) "USERPROFILE" swap at "XXX" = ] unit-test From 3586736b34181ecb09e1e157e268c0cd69fbe9eb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:59:11 -0500 Subject: [PATCH 352/772] mason.test: benchmark files were read in wrong order --- extra/mason/test/test.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 88ccf93942..912fbaa17a 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -45,10 +45,10 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; : do-benchmarks ( -- ) run-benchmarks - [ + [ benchmarks-file to-file ] [ [ keys benchmark-error-vocabs-file to-file ] [ benchmark-error-messages-file utf8 [ benchmark-errors. ] with-file-writer ] bi - ] [ benchmarks-file to-file ] bi* ; + ] bi* ; : benchmark-ms ( quot -- ms ) benchmark 1000 /i ; inline From af600d5aacbb32dd6de7eb680f41ad02fdd65317 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:59:59 -0500 Subject: [PATCH 353/772] mason: working on a big overhaul of mason. Status updates sent to a web service, binary upload notification via Twitter --- extra/mason/build/build.factor | 20 +++++---- extra/mason/child/child-tests.factor | 20 +++++++++ extra/mason/child/child.factor | 43 ++++++++----------- extra/mason/cleanup/cleanup.factor | 9 ++-- extra/mason/common/common.factor | 22 +++++++--- extra/mason/config/config.factor | 15 ++++++- extra/mason/email/email.factor | 10 ++--- extra/mason/help/help.factor | 11 ++--- extra/mason/mason.factor | 3 +- extra/mason/notify/authors.txt | 1 + extra/mason/notify/notify.factor | 48 ++++++++++++++++++++++ extra/mason/release/archive/archive.factor | 22 +++++----- extra/mason/release/release.factor | 19 +++++---- extra/mason/release/upload/upload.factor | 11 +++-- extra/mason/report/report.factor | 39 ++++++++++++------ extra/mason/twitter/authors.txt | 1 + extra/mason/twitter/twitter.factor | 14 +++++++ 17 files changed, 208 insertions(+), 100 deletions(-) create mode 100644 extra/mason/notify/authors.txt create mode 100644 extra/mason/notify/notify.factor create mode 100644 extra/mason/twitter/authors.txt create mode 100644 extra/mason/twitter/twitter.factor diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor index 90ca1d31ff..199d48dec0 100644 --- a/extra/mason/build/build.factor +++ b/extra/mason/build/build.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays calendar io.directories io.encodings.utf8 +USING: arrays kernel calendar io.directories io.encodings.utf8 io.files io.launcher mason.child mason.cleanup mason.common -mason.help mason.release mason.report namespaces prettyprint ; +mason.help mason.release mason.report mason.email mason.notify +namespaces prettyprint ; IN: mason.build QUALIFIED: continuations @@ -14,20 +15,21 @@ QUALIFIED: continuations : enter-build-dir ( -- ) build-dir set-current-directory ; : clone-builds-factor ( -- ) - "git" "clone" builds/factor 3array try-process ; + "git" "clone" builds/factor 3array try-output-process ; -: record-id ( -- ) - "factor" [ git-id ] with-directory "git-id" to-file ; +: begin-build ( -- ) + "factor" [ git-id ] with-directory + [ "git-id" to-file ] [ notify-begin-build ] bi ; : build ( -- ) create-build-dir enter-build-dir clone-builds-factor [ - record-id + begin-build build-child - upload-help - release + [ notify-report ] + [ status-clean eq? [ upload-help release ] when ] bi ] [ cleanup ] [ ] continuations:cleanup ; MAIN: build diff --git a/extra/mason/child/child-tests.factor b/extra/mason/child/child-tests.factor index 27bb42ed07..a83e7282da 100644 --- a/extra/mason/child/child-tests.factor +++ b/extra/mason/child/child-tests.factor @@ -40,3 +40,23 @@ USING: mason.child mason.config tools.test namespaces ; boot-cmd ] with-scope ] unit-test + +[ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] must-infer + +[ 4 ] [ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] unit-test + +[ 3 ] [ [ "Hi" throw ] [ drop 3 ] [ 4 ] recover-else ] unit-test + +[ "A" ] [ + { + { [ 3 throw ] [ { "X" "Y" "Z" "A" } nth ] } + [ "B" ] + } recover-cond +] unit-test + +[ "B" ] [ + { + { [ ] [ ] } + [ "B" ] + } recover-cond +] unit-test \ No newline at end of file diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor index aa44088c2d..8132e62078 100755 --- a/extra/mason/child/child.factor +++ b/extra/mason/child/child.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays calendar combinators.short-circuit +USING: accessors arrays calendar combinators.short-circuit fry continuations debugger io.directories io.files io.launcher io.pathnames io.encodings.ascii kernel make mason.common mason.config -mason.platform mason.report mason.email namespaces sequences ; +mason.platform mason.report mason.notify namespaces sequences +quotations macros ; IN: mason.child : make-cmd ( -- args ) @@ -58,30 +59,18 @@ IN: mason.child try-process ] with-directory ; -: return-with ( obj -- * ) return-continuation get continue-with ; +: recover-else ( try catch else -- ) + [ [ '[ @ f t ] ] [ '[ @ f ] ] bi* recover ] dip '[ drop @ ] when ; inline -: build-clean? ( -- ? ) +MACRO: recover-cond ( alist -- ) + dup { [ length 1 = ] [ first callable? ] } 1&& + [ first ] [ [ first first2 ] [ rest ] bi '[ _ _ [ _ recover-cond ] recover-else ] ] if ; + +: build-child ( -- status ) + copy-image { - [ load-everything-vocabs-file eval-file empty? ] - [ test-all-vocabs-file eval-file empty? ] - [ help-lint-vocabs-file eval-file empty? ] - [ compiler-errors-file eval-file empty? ] - [ benchmark-error-vocabs-file eval-file empty? ] - } 0&& ; - -: build-child ( -- ) - [ - return-continuation set - - copy-image - - [ make-vm ] [ compile-failed-report status-error return-with ] recover - [ boot ] [ boot-failed-report status-error return-with ] recover - [ test ] [ test-failed-report status-error return-with ] recover - - successful-report - - build-clean? status-clean status-dirty ? return-with - ] callcc1 - status set - email-report ; \ No newline at end of file + { [ notify-make-vm make-vm ] [ compile-failed ] } + { [ notify-boot boot ] [ boot-failed ] } + { [ notify-test test ] [ test-failed ] } + [ success ] + } recover-cond ; \ No newline at end of file diff --git a/extra/mason/cleanup/cleanup.factor b/extra/mason/cleanup/cleanup.factor index a273696f51..3e6209fed0 100755 --- a/extra/mason/cleanup/cleanup.factor +++ b/extra/mason/cleanup/cleanup.factor @@ -5,13 +5,14 @@ io.directories.hierarchy io.files io.launcher kernel mason.common mason.config mason.platform namespaces ; IN: mason.cleanup +: compress ( filename -- ) + dup exists? [ "bzip2" swap 2array try-output-process ] [ drop ] if ; + : compress-image ( -- ) - "bzip2" boot-image-name 2array try-process ; + boot-image-name compress ; : compress-test-log ( -- ) - "test-log" exists? [ - { "bzip2" "test-log" } try-process - ] when ; + "test-log" compress ; : cleanup ( -- ) builder-debug get [ diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index a3ff1a8ff5..285a684f06 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -4,15 +4,27 @@ USING: kernel namespaces sequences splitting system accessors math.functions make io io.files io.pathnames io.directories io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint combinators.short-circuit parser combinators calendar -calendar.format arrays mason.config locals system ; +calendar.format arrays mason.config locals system debugger ; IN: mason.common +ERROR: output-process-error output process ; + +M: output-process-error error. + [ "Process:" print process>> . nl ] + [ "Output:" print output>> print ] + bi ; + +: try-output-process ( command -- ) + >process +stdout+ >>stderr utf8 + [ contents ] [ dup wait-for-process ] bi* + 0 = [ 2drop ] [ output-process-error ] if ; + HOOK: really-delete-tree os ( path -- ) M: windows really-delete-tree #! Workaround: Cygwin GIT creates read-only files for #! some reason. - [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-process ] + [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-output-process ] [ delete-tree ] bi ; @@ -23,7 +35,7 @@ M: unix really-delete-tree delete-tree ; swap >>command 15 minutes >>timeout - try-process ; + try-output-process ; :: upload-safely ( local username host remote -- ) [let* | temp [ remote ".incomplete" append ] @@ -68,7 +80,7 @@ SYMBOL: stamp : prepare-build-machine ( -- ) builds-dir get make-directories builds-dir get - [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ] + [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-output-process ] with-directory ; : git-id ( -- id ) @@ -101,8 +113,6 @@ CONSTANT: benchmarks-file "benchmarks" CONSTANT: benchmark-error-messages-file "benchmark-error-messages" CONSTANT: benchmark-error-vocabs-file "benchmark-error-vocabs" -SYMBOL: status - SYMBOL: status-error ! didn't bootstrap, or crashed SYMBOL: status-dirty ! bootstrapped but not all tests passed SYMBOL: status-clean ! everything good diff --git a/extra/mason/config/config.factor b/extra/mason/config/config.factor index 51b09543f4..5ec44df0a9 100644 --- a/extra/mason/config/config.factor +++ b/extra/mason/config/config.factor @@ -11,12 +11,17 @@ builds-dir get-global [ home "builds" append-path builds-dir set-global ] unless -! Who sends build reports. +! Who sends build report e-mails. SYMBOL: builder-from -! Who receives build reports. +! Who receives build report e-mails. SYMBOL: builder-recipients +! (Optional) twitter credentials for status updates. +SYMBOL: builder-twitter-username + +SYMBOL: builder-twitter-password + ! (Optional) CPU architecture to build for. SYMBOL: target-cpu @@ -34,6 +39,12 @@ target-os get-global [ ! Keep test-log around? SYMBOL: builder-debug +! Host to send status notifications to. +SYMBOL: status-host + +! Username to log in. +SYMBOL: status-username + SYMBOL: upload-help? ! The below are only needed if upload-help is true. diff --git a/extra/mason/email/email.factor b/extra/mason/email/email.factor index 55edfcb30b..23203e5222 100644 --- a/extra/mason/email/email.factor +++ b/extra/mason/email/email.factor @@ -12,20 +12,20 @@ IN: mason.email builder-from get >>from builder-recipients get >>to - swap >>content-type swap prefix-subject >>subject + swap >>content-type swap >>body send-email ; -: subject ( -- str ) - status get { +: subject ( status -- str ) + { { status-clean [ "clean" ] } { status-dirty [ "dirty" ] } { status-error [ "error" ] } } case ; -: email-report ( -- ) - "report" utf8 file-contents "text/html" subject email-status ; +: email-report ( report status -- ) + [ "text/html" ] dip subject email-status ; : email-error ( error callstack -- ) [ diff --git a/extra/mason/help/help.factor b/extra/mason/help/help.factor index 9a4e2be996..9ed9653a08 100644 --- a/extra/mason/help/help.factor +++ b/extra/mason/help/help.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays help.html io.directories io.files io.launcher kernel make mason.common mason.config namespaces sequences ; @@ -6,7 +6,7 @@ IN: mason.help : make-help-archive ( -- ) "factor/temp" [ - { "tar" "cfz" "docs.tar.gz" "docs" } try-process + { "tar" "cfz" "docs.tar.gz" "docs" } try-output-process ] with-directory ; : upload-help-archive ( -- ) @@ -16,11 +16,8 @@ IN: mason.help help-directory get "/docs.tar.gz" append upload-safely ; -: (upload-help) ( -- ) +: upload-help ( -- ) upload-help? get [ make-help-archive upload-help-archive - ] when ; - -: upload-help ( -- ) - status get status-clean eq? [ (upload-help) ] when ; + ] when ; \ No newline at end of file diff --git a/extra/mason/mason.factor b/extra/mason/mason.factor index 299a2f4e1f..d425985e76 100644 --- a/extra/mason/mason.factor +++ b/extra/mason/mason.factor @@ -6,7 +6,8 @@ mason.email mason.updates namespaces threads ; IN: mason : build-loop-error ( error -- ) - error-continuation get call>> email-error ; + [ "Build loop error:" print flush error. flush ] + [ error-continuation get call>> email-error ] bi ; : build-loop-fatal ( error -- ) "FATAL BUILDER ERROR:" print diff --git a/extra/mason/notify/authors.txt b/extra/mason/notify/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/mason/notify/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor new file mode 100644 index 0000000000..6bf4ae090d --- /dev/null +++ b/extra/mason/notify/notify.factor @@ -0,0 +1,48 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays accessors io io.sockets io.encodings.utf8 io.files +io.launcher kernel make mason.config mason.common mason.email +mason.twitter namespaces sequences ; +IN: mason.notify + +: status-notify ( input-file args -- ) + status-host get [ + [ + "ssh" , status-host get , "-l" , status-username get , + "./mason-notify" , + host-name , + target-cpu get , + target-os get , + ] { } make prepend + + swap >>command + swap [ +closed+ ] unless* >>stdin + try-output-process + ] [ 2drop ] if ; + +: notify-begin-build ( git-id -- ) + [ "Starting build of GIT ID " write print flush ] + [ f swap "git-id" swap 2array status-notify ] + bi ; + +: notify-make-vm ( -- ) + "Compiling VM" print flush + f { "make-vm" } status-notify ; + +: notify-boot ( -- ) + "Bootstrapping" print flush + f { "boot" } status-notify ; + +: notify-test ( -- ) + "Running tests" print flush + f { "test" } status-notify ; + +: notify-report ( status -- ) + [ "Build finished with status: " write print flush ] + [ + [ "report" utf8 file-contents ] dip email-report + "report" { "report" } status-notify + ] bi ; + +: notify-release ( archive-name -- ) + "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ; \ No newline at end of file diff --git a/extra/mason/release/archive/archive.factor b/extra/mason/release/archive/archive.factor index fff8b83c23..79d6993a91 100755 --- a/extra/mason/release/archive/archive.factor +++ b/extra/mason/release/archive/archive.factor @@ -18,23 +18,23 @@ IN: mason.release.archive : archive-name ( -- string ) base-name extension append ; -: make-windows-archive ( -- ) - [ "zip" , "-r" , archive-name , "factor" , ] { } make try-process ; +: make-windows-archive ( archive-name -- ) + [ "zip" , "-r" , , "factor" , ] { } make try-output-process ; -: make-macosx-archive ( -- ) - { "mkdir" "dmg-root" } try-process - { "cp" "-R" "factor" "dmg-root" } try-process +: make-macosx-archive ( archive-name -- ) + { "mkdir" "dmg-root" } try-output-process + { "cp" "-R" "factor" "dmg-root" } try-output-process { "hdiutil" "create" "-srcfolder" "dmg-root" "-fs" "HFS+" "-volname" "factor" } - archive-name suffix try-process + swap suffix try-output-process "dmg-root" really-delete-tree ; -: make-unix-archive ( -- ) - [ "tar" , "-cvzf" , archive-name , "factor" , ] { } make try-process ; +: make-unix-archive ( archive-name -- ) + [ "tar" , "-cvzf" , , "factor" , ] { } make try-output-process ; -: make-archive ( -- ) +: make-archive ( archive-name -- ) target-os get { { "winnt" [ make-windows-archive ] } { "macosx" [ make-macosx-archive ] } @@ -44,5 +44,5 @@ IN: mason.release.archive : releases ( -- path ) builds-dir get "releases" append-path dup make-directories ; -: save-archive ( -- ) - archive-name releases move-file-into ; \ No newline at end of file +: save-archive ( archive-name -- ) + releases move-file-into ; \ No newline at end of file diff --git a/extra/mason/release/release.factor b/extra/mason/release/release.factor index bbb47ba0d3..fc4ad0b08a 100644 --- a/extra/mason/release/release.factor +++ b/extra/mason/release/release.factor @@ -1,16 +1,17 @@ -! Copyright (C) 2008 Eduardo Cavazos. +! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel debugger namespaces sequences splitting +USING: kernel debugger namespaces sequences splitting combinators combinators io io.files io.launcher prettyprint bootstrap.image mason.common mason.release.branch mason.release.tidy -mason.release.archive mason.release.upload ; +mason.release.archive mason.release.upload mason.notify ; IN: mason.release -: (release) ( -- ) +: release ( -- ) update-clean-branch tidy - make-archive - upload - save-archive ; - -: release ( -- ) status get status-clean eq? [ (release) ] when ; \ No newline at end of file + archive-name { + [ make-archive ] + [ upload ] + [ save-archive ] + [ notify-release ] + } cleave ; \ No newline at end of file diff --git a/extra/mason/release/upload/upload.factor b/extra/mason/release/upload/upload.factor index 68f2ffcdb5..d3e11c3fc3 100644 --- a/extra/mason/release/upload/upload.factor +++ b/extra/mason/release/upload/upload.factor @@ -8,14 +8,13 @@ IN: mason.release.upload : remote-location ( -- dest ) upload-directory get "/" platform 3append ; -: remote-archive-name ( -- dest ) - remote-location "/" archive-name 3append ; +: remote-archive-name ( archive-name -- dest ) + [ remote-location "/" ] dip 3append ; -: upload ( -- ) +: upload ( archive-name -- ) upload-to-factorcode? get [ - archive-name upload-username get upload-host get - remote-archive-name + pick remote-archive-name upload-safely - ] when ; + ] [ drop ] if ; diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 79ec15651d..d6732adb1d 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -3,7 +3,7 @@ USING: benchmark combinators.smart debugger fry io assocs io.encodings.utf8 io.files io.sockets io.streams.string kernel locals mason.common mason.config mason.platform math namespaces -prettyprint sequences xml.syntax xml.writer ; +prettyprint sequences xml.syntax xml.writer combinators.short-circuit ; IN: mason.report : common-report ( -- xml ) @@ -30,7 +30,7 @@ IN: mason.report pprint-xml ] with-file-writer ; inline -:: failed-report ( error file what -- ) +:: failed-report ( error file what -- status ) [ error [ error. ] with-string-writer :> error file utf8 file-contents 400 short tail* :> output @@ -42,15 +42,16 @@ IN: mason.report Launcher error: 
    <-error->
    XML] - ] with-report ; + ] with-report + status-error ; -: compile-failed-report ( error -- ) +: compile-failed ( error -- status ) "compile-log" "VM compilation failed" failed-report ; -: boot-failed-report ( error -- ) +: boot-failed ( error -- status ) "boot-log" "Bootstrap failed" failed-report ; -: test-failed-report ( error -- ) +: test-failed ( error -- status ) "test-log" "Tests failed" failed-report ; : timings-table ( -- xml ) @@ -66,7 +67,7 @@ IN: mason.report [XML <-><-> XML] ] map [XML

    Timings

    <->
    XML] ; -: fail-dump ( heading vocabs-file messages-file -- xml ) +: error-dump ( heading vocabs-file messages-file -- xml ) [ eval-file ] dip over empty? [ 3drop f ] [ [ ] [ [ [XML
  • <->
    • XML] ] map [XML
      <->
    XML] ] @@ -89,29 +90,41 @@ IN: mason.report "Load failures" load-everything-vocabs-file load-everything-errors-file - fail-dump + error-dump "Compiler warnings and errors" compiler-errors-file compiler-error-messages-file - fail-dump + error-dump "Unit test failures" test-all-vocabs-file test-all-errors-file - fail-dump + error-dump "Help lint failures" help-lint-vocabs-file help-lint-errors-file - fail-dump + error-dump "Benchmark errors" benchmark-error-vocabs-file benchmark-error-messages-file - fail-dump + error-dump "Benchmark timings" benchmarks-file eval-file benchmarks-table ] output>array - ] with-report ; \ No newline at end of file + ] with-report ; + +: build-clean? ( -- ? ) + { + [ load-everything-vocabs-file eval-file empty? ] + [ test-all-vocabs-file eval-file empty? ] + [ help-lint-vocabs-file eval-file empty? ] + [ compiler-errors-file eval-file empty? ] + [ benchmark-error-vocabs-file eval-file empty? ] + } 0&& ; + +: success ( -- status ) + successful-report build-clean? status-clean status-dirty ? ; \ No newline at end of file diff --git a/extra/mason/twitter/authors.txt b/extra/mason/twitter/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/mason/twitter/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/mason/twitter/twitter.factor b/extra/mason/twitter/twitter.factor new file mode 100644 index 0000000000..21f1bcabc3 --- /dev/null +++ b/extra/mason/twitter/twitter.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: debugger fry kernel mason.config namespaces twitter ; +IN: mason.twitter + +: mason-tweet ( message -- ) + builder-twitter-username get builder-twitter-password get and + [ + [ + builder-twitter-username get twitter-username set + builder-twitter-password get twitter-password set + '[ _ tweet ] try + ] with-scope + ] [ drop ] if ; \ No newline at end of file From 549ddcd2dff1907115d72274f4af01644f3a150c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 21:24:36 -0500 Subject: [PATCH 354/772] make some words not macros --- basis/sorting/slots/slots-docs.factor | 4 ++-- basis/sorting/slots/slots-tests.factor | 12 ++++++++++++ basis/sorting/slots/slots.factor | 20 +++++++++++--------- 3 files changed, 25 insertions(+), 11 deletions(-) diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor index cc89d497e7..b427cf2956 100644 --- a/basis/sorting/slots/slots-docs.factor +++ b/basis/sorting/slots/slots-docs.factor @@ -14,7 +14,7 @@ HELP: compare-slots HELP: sort-by-slots { $values { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" } - { "sortedseq" sequence } + { "seq'" sequence } } { $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." } { $examples @@ -42,7 +42,7 @@ HELP: split-by-slots HELP: sort-by { $values { "seq" sequence } { "sort-seq" "a sequence of comparators" } - { "sortedseq" sequence } + { "seq'" sequence } } { $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ; diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor index 83900461c3..e31b9be359 100644 --- a/basis/sorting/slots/slots-tests.factor +++ b/basis/sorting/slots/slots-tests.factor @@ -159,3 +159,15 @@ TUPLE: tuple2 d ; { { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } } { length-test<=> <=> } sort-by ] unit-test + +[ { { 0 1 } { 1 2 } { 1 1 } { 3 2 } } ] +[ + { { 3 2 } { 1 2 } { 0 1 } { 1 1 } } + { length-test<=> <=> } sort-keys-by +] unit-test + +[ { { 0 1 } { 1 1 } { 3 2 } { 1 2 } } ] +[ + { { 3 2 } { 1 2 } { 0 1 } { 1 1 } } + { length-test<=> <=> } sort-values-by +] unit-test diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index efec960c27..9a0455c3a7 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -8,12 +8,13 @@ IN: sorting.slots ) #! sort-spec: { accessors comparator } [ slot-comparator ] map '[ _ 2|| +eq+ or ] ; -MACRO: sort-by-slots ( sort-specs -- quot ) - '[ [ _ compare-slots ] sort ] ; +: sort-by-slots ( seq sort-specs -- seq' ) + '[ _ compare-slots ] sort ; MACRO: compare-seq ( seq -- quot ) [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ; -MACRO: sort-by ( sort-seq -- quot ) - '[ [ _ compare-seq ] sort ] ; +: sort-by ( seq sort-seq -- seq' ) + '[ _ compare-seq ] sort ; -MACRO: sort-keys-by ( sort-seq -- quot ) +: sort-keys-by ( seq sort-seq -- seq' ) '[ [ first ] bi@ _ compare-seq ] sort ; -MACRO: sort-values-by ( sort-seq -- quot ) +: sort-values-by ( seq sort-seq -- seq' ) '[ [ second ] bi@ _ compare-seq ] sort ; MACRO: split-by-slots ( accessor-seqs -- quot ) - [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map + [ [ '[ [ _ execute( tuple -- value ) ] bi@ ] ] map concat + [ = ] compose ] map '[ [ _ 2&& ] slice monotonic-slice ] ; From 5e6cc3bf46a1177a697e5c73808da31e5a61faf9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 21:37:20 -0500 Subject: [PATCH 355/772] more api work for windows --- basis/windows/advapi32/advapi32.factor | 243 +++++++++++++++++++++++-- basis/windows/gdi32/gdi32.factor | 1 - basis/windows/kernel32/kernel32.factor | 2 +- basis/windows/user32/user32.factor | 2 +- 4 files changed, 227 insertions(+), 21 deletions(-) diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor index f76e389dce..5b62f54795 100644 --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -1,5 +1,6 @@ USING: alien.syntax kernel math windows.types math.bitwise ; IN: windows.advapi32 + LIBRARY: advapi32 CONSTANT: PROV_RSA_FULL 1 @@ -122,6 +123,34 @@ C-STRUCT: ACCESS_ALLOWED_CALLBACK_ACE TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE +C-STRUCT: SECURITY_DESCRIPTOR + { "UCHAR" "Revision" } + { "UCHAR" "Sbz1" } + { "WORD" "Control" } + { "PVOID" "Owner" } + { "PVOID" "Group" } + { "PACL" "Sacl" } + { "PACL" "Dacl" } ; + +TYPEDEF: SECURITY_DESCRIPTOR* PSECURITY_DESCRIPTOR + +CONSTANT: SE_OWNER_DEFAULTED 1 +CONSTANT: SE_GROUP_DEFAULTED 2 +CONSTANT: SE_DACL_PRESENT 4 +CONSTANT: SE_DACL_DEFAULTED 8 +CONSTANT: SE_SACL_PRESENT 16 +CONSTANT: SE_SACL_DEFAULTED 32 +CONSTANT: SE_DACL_AUTO_INHERIT_REQ 256 +CONSTANT: SE_SACL_AUTO_INHERIT_REQ 512 +CONSTANT: SE_DACL_AUTO_INHERITED 1024 +CONSTANT: SE_SACL_AUTO_INHERITED 2048 +CONSTANT: SE_DACL_PROTECTED 4096 +CONSTANT: SE_SACL_PROTECTED 8192 +CONSTANT: SE_SELF_RELATIVE 32768 + +TYPEDEF: DWORD SECURITY_DESCRIPTOR_CONTROL +TYPEDEF: SECURITY_DESCRIPTOR_CONTROL* PSECURITY_DESCRIPTOR_CONTROL + ! typedef enum _TOKEN_INFORMATION_CLASS { CONSTANT: TokenUser 1 @@ -141,6 +170,140 @@ CONSTANT: TokenSessionReference 14 CONSTANT: TokenSandBoxInert 15 ! } TOKEN_INFORMATION_CLASS; +TYPEDEF: DWORD ACCESS_MODE +C-ENUM: + NOT_USED_ACCESS + GRANT_ACCESS + SET_ACCESS + DENY_ACCESS + REVOKE_ACCESS + SET_AUDIT_SUCCESS + SET_AUDIT_FAILURE ; + +TYPEDEF: DWORD MULTIPLE_TRUSTEE_OPERATION +C-ENUM: + NO_MULTIPLE_TRUSTEE + TRUSTEE_IS_IMPERSONATE ; + +TYPEDEF: DWORD TRUSTEE_FORM +C-ENUM: + TRUSTEE_IS_SID + TRUSTEE_IS_NAME + TRUSTEE_BAD_FORM + TRUSTEE_IS_OBJECTS_AND_SID + TRUSTEE_IS_OBJECTS_AND_NAME ; + +TYPEDEF: DWORD TRUSTEE_TYPE +C-ENUM: + TRUSTEE_IS_UNKNOWN + TRUSTEE_IS_USER + TRUSTEE_IS_GROUP + TRUSTEE_IS_DOMAIN + TRUSTEE_IS_ALIAS + TRUSTEE_IS_WELL_KNOWN_GROUP + TRUSTEE_IS_DELETED + TRUSTEE_IS_INVALID + TRUSTEE_IS_COMPUTER ; + +TYPEDEF: DWORD SE_OBJECT_TYPE +C-ENUM: + SE_UNKNOWN_OBJECT_TYPE + SE_FILE_OBJECT + SE_SERVICE + SE_PRINTER + SE_REGISTRY_KEY + SE_LMSHARE + SE_KERNEL_OBJECT + SE_WINDOW_OBJECT + SE_DS_OBJECT + SE_DS_OBJECT_ALL + SE_PROVIDER_DEFINED_OBJECT + SE_WMIGUID_OBJECT + SE_REGISTRY_WOW64_32KEY ; + +TYPEDEF: TRUSTEE* PTRUSTEE + +C-STRUCT: TRUSTEE + { "PTRUSTEE" "pMultipleTrustee" } + { "MULTIPLE_TRUSTEE_OPERATION" "MultipleTrusteeOperation" } + { "TRUSTEE_FORM" "TrusteeForm" } + { "TRUSTEE_TYPE" "TrusteeType" } + { "LPTSTR" "ptstrName" } ; + +C-STRUCT: EXPLICIT_ACCESS + { "DWORD" "grfAccessPermissions" } + { "ACCESS_MODE" "grfAccessMode" } + { "DWORD" "grfInheritance" } + { "TRUSTEE" "Trustee" } ; + +C-STRUCT: SID_IDENTIFIER_AUTHORITY + { { "BYTE" 6 } "Value" } ; + +TYPEDEF: SID_IDENTIFIER_AUTHORITY* PSID_IDENTIFIER_AUTHORITY + +CONSTANT: SECURITY_NULL_SID_AUTHORITY 0 +CONSTANT: SECURITY_WORLD_SID_AUTHORITY 1 +CONSTANT: SECURITY_LOCAL_SID_AUTHORITY 2 +CONSTANT: SECURITY_CREATOR_SID_AUTHORITY 3 +CONSTANT: SECURITY_NON_UNIQUE_AUTHORITY 4 +CONSTANT: SECURITY_NT_AUTHORITY 5 +CONSTANT: SECURITY_RESOURCE_MANAGER_AUTHORITY 6 + +CONSTANT: SECURITY_NULL_RID 0 +CONSTANT: SECURITY_WORLD_RID 0 +CONSTANT: SECURITY_LOCAL_RID 0 +CONSTANT: SECURITY_CREATOR_OWNER_RID 0 +CONSTANT: SECURITY_CREATOR_GROUP_RID 1 +CONSTANT: SECURITY_CREATOR_OWNER_SERVER_RID 2 +CONSTANT: SECURITY_CREATOR_GROUP_SERVER_RID 3 +CONSTANT: SECURITY_DIALUP_RID 1 +CONSTANT: SECURITY_NETWORK_RID 2 +CONSTANT: SECURITY_BATCH_RID 3 +CONSTANT: SECURITY_INTERACTIVE_RID 4 +CONSTANT: SECURITY_SERVICE_RID 6 +CONSTANT: SECURITY_ANONYMOUS_LOGON_RID 7 +CONSTANT: SECURITY_PROXY_RID 8 +CONSTANT: SECURITY_SERVER_LOGON_RID 9 +CONSTANT: SECURITY_PRINCIPAL_SELF_RID 10 +CONSTANT: SECURITY_AUTHENTICATED_USER_RID 11 +CONSTANT: SECURITY_LOGON_IDS_RID 5 +CONSTANT: SECURITY_LOGON_IDS_RID_COUNT 3 +CONSTANT: SECURITY_LOCAL_SYSTEM_RID 18 +CONSTANT: SECURITY_NT_NON_UNIQUE 21 +CONSTANT: SECURITY_BUILTIN_DOMAIN_RID 32 +CONSTANT: DOMAIN_USER_RID_ADMIN 500 +CONSTANT: DOMAIN_USER_RID_GUEST 501 +CONSTANT: DOMAIN_GROUP_RID_ADMINS 512 +CONSTANT: DOMAIN_GROUP_RID_USERS 513 +CONSTANT: DOMAIN_GROUP_RID_GUESTS 514 +CONSTANT: DOMAIN_ALIAS_RID_ADMINS 544 +CONSTANT: DOMAIN_ALIAS_RID_USERS 545 +CONSTANT: DOMAIN_ALIAS_RID_GUESTS 546 +CONSTANT: DOMAIN_ALIAS_RID_POWER_USERS 547 +CONSTANT: DOMAIN_ALIAS_RID_ACCOUNT_OPS 548 +CONSTANT: DOMAIN_ALIAS_RID_SYSTEM_OPS 549 +CONSTANT: DOMAIN_ALIAS_RID_PRINT_OPS 550 +CONSTANT: DOMAIN_ALIAS_RID_BACKUP_OPS 551 +CONSTANT: DOMAIN_ALIAS_RID_REPLICATOR 552 +CONSTANT: SE_GROUP_MANDATORY 1 +CONSTANT: SE_GROUP_ENABLED_BY_DEFAULT 2 +CONSTANT: SE_GROUP_ENABLED 4 +CONSTANT: SE_GROUP_OWNER 8 +CONSTANT: SE_GROUP_LOGON_ID -1073741824 + +! SID is a variable length structure +TYPEDEF: void* PSID + +TYPEDEF: EXPLICIT_ACCESS* PEXPLICIT_ACCESS + +TYPEDEF: DWORD SECURITY_INFORMATION +TYPEDEF: SECURITY_INFORMATION* PSECURITY_INFORMATION + +CONSTANT: OWNER_SECURITY_INFORMATION 1 +CONSTANT: GROUP_SECURITY_INFORMATION 2 +CONSTANT: DACL_SECURITY_INFORMATION 4 +CONSTANT: SACL_SECURITY_INFORMATION 8 + CONSTANT: DELETE HEX: 00010000 CONSTANT: READ_CONTROL HEX: 00020000 CONSTANT: WRITE_DAC HEX: 00040000 @@ -187,6 +350,34 @@ CONSTANT: TOKEN_ADJUST_DEFAULT HEX: 0080 TOKEN_ADJUST_DEFAULT } flags ; foldable +CONSTANT: HKEY_CLASSES_ROOT 1 +CONSTANT: HKEY_CURRENT_CONFIG 2 +CONSTANT: HKEY_CURRENT_USER 3 +CONSTANT: HKEY_LOCAL_MACHINE 4 +CONSTANT: HKEY_USERS 5 + +CONSTANT: KEY_ALL_ACCESS HEX: 0001 +CONSTANT: KEY_CREATE_LINK HEX: 0002 +CONSTANT: KEY_CREATE_SUB_KEY HEX: 0004 +CONSTANT: KEY_ENUMERATE_SUB_KEYS HEX: 0008 +CONSTANT: KEY_EXECUTE HEX: 0010 +CONSTANT: KEY_NOTIFY HEX: 0020 +CONSTANT: KEY_QUERY_VALUE HEX: 0040 +CONSTANT: KEY_READ HEX: 0080 +CONSTANT: KEY_SET_VALUE HEX: 0100 +CONSTANT: KEY_WOW64_64KEY HEX: 0200 +CONSTANT: KEY_WOW64_32KEY HEX: 0400 +CONSTANT: KEY_WRITE HEX: 0800 + +CONSTANT: REG_BINARY 1 +CONSTANT: REG_DWORD 2 +CONSTANT: REG_EXPAND_SZ 3 +CONSTANT: REG_MULTI_SZ 4 +CONSTANT: REG_QWORD 5 +CONSTANT: REG_SZ 6 + +TYPEDEF: DWORD REGSAM + ! : I_ScGetCurrentGroupStateW ; ! : A_SHAFinal ; @@ -224,7 +415,19 @@ FUNCTION: BOOL AdjustTokenPrivileges ( HANDLE TokenHandle, PTOKEN_PRIVILEGES PreviousState, PDWORD ReturnLength ) ; -! : AllocateAndInitializeSid ; +FUNCTION: BOOL AllocateAndInitializeSid ( + PSID_IDENTIFIER_AUTHORITY pIdentifierAuthority, + BYTE nSubAuthorityCount, + DWORD dwSubAuthority0, + DWORD dwSubAuthority1, + DWORD dwSubAuthority2, + DWORD dwSubAuthority3, + DWORD dwSubAuthority4, + DWORD dwSubAuthority5, + DWORD dwSubAuthority6, + DWORD dwSubAuthority7, + PSID* pSid ) ; + ! : AllocateLocallyUniqueId ; ! : AreAllAccessesGranted ; ! : AreAnyAccessesGranted ; @@ -442,7 +645,8 @@ FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ; ! : GetExplicitEntriesFromAclA ; ! : GetExplicitEntriesFromAclW ; ! : GetFileSecurityA ; -! : GetFileSecurityW ; +FUNCTION: BOOL GetFileSecurityW ( LPCTSTR lpFileName, SECURITY_INFORMATION RequestedInformation, PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD nLength, LPDWORD lpnLengthNeeded ) ; +ALIAS: GetFileSecurity GetFileSecurityW ! : GetInformationCodeAuthzLevelW ; ! : GetInformationCodeAuthzPolicyW ; ! : GetInheritanceSourceA ; @@ -459,19 +663,20 @@ FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ; ! : GetMultipleTrusteeW ; ! : GetNamedSecurityInfoA ; ! : GetNamedSecurityInfoExA ; -! : GetNamedSecurityInfoExW ; -! : GetNamedSecurityInfoW ; +! FUNCTION: DWORD GetNamedSecurityInfoExW +FUNCTION: DWORD GetNamedSecurityInfoW ( LPTSTR pObjectName, SE_OBJECT_TYPE ObjectType, SECURITY_INFORMATION SecurityInfo, PSID* ppsidOwner, PSID* ppsidGroup, PACL* ppDacl, PACL* ppSacl, PSECURITY_DESCRIPTOR* ppSecurityDescriptor ) ; +ALIAS: GetNamedSecurityInfo GetNamedSecurityInfoW ! : GetNumberOfEventLogRecords ; ! : GetOldestEventLogRecord ; ! : GetOverlappedAccessResults ; ! : GetPrivateObjectSecurity ; -! : GetSecurityDescriptorControl ; -! : GetSecurityDescriptorDacl ; -! : GetSecurityDescriptorGroup ; -! : GetSecurityDescriptorLength ; -! : GetSecurityDescriptorOwner ; -! : GetSecurityDescriptorRMControl ; -! : GetSecurityDescriptorSacl ; +FUNCTION: BOOL GetSecurityDescriptorControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSECURITY_DESCRIPTOR_CONTROL pControl, LPDWORD lpdwRevision ) ; +FUNCTION: BOOL GetSecurityDescriptorDacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbDaclPresent, PACL* pDacl, LPBOOL lpDaclDefaulted ) ; +FUNCTION: BOOL GetSecurityDescriptorGroup ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pGroup, LPBOOL lpGroupDefaulted ) ; +FUNCTION: BOOL GetSecurityDescriptorLength ( PSECURITY_DESCRIPTOR pSecurityDescriptor ) ; +FUNCTION: BOOL GetSecurityDescriptorOwner ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pOwner, LPBOOL lpOwnerDefaulted ) ; +FUNCTION: BOOL GetSecurityDescriptorRMControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PUCHAR RMControl ) ; +FUNCTION: BOOL GetSecurityDescriptorSacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbSaclPresent, PACL* pSacl, LPBOOL lpSaclDefaulted ) ; ! : GetSecurityInfo ; ! : GetSecurityInfoExA ; ! : GetSecurityInfoExW ; @@ -510,7 +715,7 @@ ALIAS: GetUserName GetUserNameW ! : ImpersonateNamedPipeClient ; ! : ImpersonateSelf ; FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ; -! : InitializeSecurityDescriptor ; +FUNCTION: BOOL InitializeSecurityDescriptor ( PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD dwRevision ) ; ! : InitializeSid ; ! : InitiateSystemShutdownA ; ! : InitiateSystemShutdownExA ; @@ -674,8 +879,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL ! : RegConnectRegistryW ; ! : RegCreateKeyA ; ! : RegCreateKeyExA ; -! : RegCreateKeyExW ; -! : RegCreateKeyW ; +FUNCTION: LONG RegCreateKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD Reserved, LPTSTR lpClass, DWORD dwOptions, REGSAM samDesired, LPSECURITY_ATTRIBUTES lpSecurityAttributes, PHKEY phkResult, LPDWORD lpdwDisposition ) ; +! : RegCreateKeyW ! : RegDeleteKeyA ; ! : RegDeleteKeyW ; ! : RegDeleteValueA ; @@ -692,7 +897,7 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL ! : RegLoadKeyA ; ! : RegLoadKeyW ; ! : RegNotifyChangeKeyValue ; -! : RegOpenCurrentUser ; +FUNCTION: LONG RegOpenCurrentUser ( REGSAM samDesired, PHKEY phkResult ) ; ! : RegOpenKeyA ; ! : RegOpenKeyExA ; ! : RegOpenKeyExW ; @@ -705,7 +910,7 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL ! : RegQueryMultipleValuesW ; ! : RegQueryValueA ; ! : RegQueryValueExA ; -! : RegQueryValueExW ; +FUNCTION: LONG RegQueryValueExW ( HKEY hKey, LPCTSTR lpValueName, LPWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData ) ; ! : RegQueryValueW ; ! : RegReplaceKeyA ; ! : RegReplaceKeyW ; @@ -756,7 +961,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL ! : SetEntriesInAccessListA ; ! : SetEntriesInAccessListW ; ! : SetEntriesInAclA ; -! : SetEntriesInAclW ; +FUNCTION: DWORD SetEntriesInAclW ( ULONG cCountOfExplicitEntries, PEXPLICIT_ACCESS pListOfExplicitEntries, PACL OldAcl, PACL* NewAcl ) ; +ALIAS: SetEntriesInAcl SetEntriesInAclW ! : SetEntriesInAuditListA ; ! : SetEntriesInAuditListW ; ! : SetFileSecurityA ; @@ -767,7 +973,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL ! : SetNamedSecurityInfoA ; ! : SetNamedSecurityInfoExA ; ! : SetNamedSecurityInfoExW ; -! : SetNamedSecurityInfoW ; +FUNCTION: DWORD SetNamedSecurityInfoW ( LPTSTR pObjectName, SE_OBJECT_TYPE ObjectType, SECURITY_INFORMATION SecurityInfo, PSID psidOwner, PSID psidGroup, PACL pDacl, PACL pSacl ) ; +ALIAS: SetNamedSecurityInfo SetNamedSecurityInfoW ! : SetPrivateObjectSecurity ; ! : SetPrivateObjectSecurityEx ; ! : SetSecurityDescriptorControl ; diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor index 794aa0e32e..9b7cd2e35e 100755 --- a/basis/windows/gdi32/gdi32.factor +++ b/basis/windows/gdi32/gdi32.factor @@ -1501,7 +1501,6 @@ DESTRUCTOR: DeleteObject FUNCTION: BOOL ExtTextOutW ( HDC hdc, int X, int Y, UINT fuOptions, RECT* lprc, LPCTSTR lpString, UINT cbCount, INT* lpDx ) ; ALIAS: ExtTextOut ExtTextOutW ! FUNCTION: FillPath -FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ; ! FUNCTION: FillRgn ! FUNCTION: FixBrushOrgEx ! FUNCTION: FlattenPath diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 36acc5e346..4d3dd81a0e 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -1477,7 +1477,7 @@ ALIAS: LoadLibraryEx LoadLibraryExW ! FUNCTION: LoadLibraryW ! FUNCTION: LoadModule ! FUNCTION: LoadResource -! FUNCTION: LocalAlloc +FUNCTION: HLOCAL LocalAlloc ( UINT uFlags, SIZE_T uBytes ) ; ! FUNCTION: LocalCompact ! FUNCTION: LocalFileTimeToFileTime ! FUNCTION: LocalFlags diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index 9daac21697..f3bc1becb2 100644 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -807,7 +807,7 @@ FUNCTION: UINT EnumClipboardFormats ( UINT format ) ; ! FUNCTION: EqualRect ! FUNCTION: ExcludeUpdateRgn ! FUNCTION: ExitWindowsEx -! FUNCTION: FillRect +FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ; FUNCTION: HWND FindWindowA ( char* lpClassName, char* lpWindowName ) ; FUNCTION: HWND FindWindowExA ( HWND hwndParent, HWND childAfter, char* lpClassName, char* lpWindowName ) ; ! FUNCTION: FindWindowExW From e59f69ba6fe1a585357a4e88d1efecd642395e17 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 22:24:36 -0500 Subject: [PATCH 356/772] ignore .so and a.out --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 22dda8efb4..b52c593b49 100644 --- a/.gitignore +++ b/.gitignore @@ -25,3 +25,5 @@ build-support/wordsize .#* *.swo checksums.txt +*.so +a.out From d22ae36ca5e82cb4410b137312ec44104d1f7e39 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 22:49:42 -0500 Subject: [PATCH 357/772] Revert part of 509869ca70e08504045cf1cc0d0e2558d00eaa6a --- basis/x11/windows/windows.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index 8085907bef..98ec2728fa 100644 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -29,6 +29,8 @@ IN: x11.windows : window-attributes ( visinfo -- attributes ) "XSetWindowAttributes" + 0 over set-XSetWindowAttributes-background_pixel + 0 over set-XSetWindowAttributes-border_pixel [ [ create-colormap ] dip set-XSetWindowAttributes-colormap ] keep event-mask over set-XSetWindowAttributes-event_mask ; From df9c48c58645e22bde9eed341f56e11f15a7fc1e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 23:24:41 -0500 Subject: [PATCH 358/772] dont allow tests of help scaffolding unless the vocabulary exists --- basis/tools/scaffold/scaffold.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 73e896d5ff..d02faae3a8 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -24,6 +24,9 @@ ERROR: no-vocab vocab ; : contains-separator? ( string -- ? ) [ path-separator? ] any? ; +: ensure-vocab-exists ( string -- string ) + dup vocabs member? [ no-vocab ] unless ; + : check-vocab-name ( string -- string ) [ ] [ contains-dot? [ vocab-name-contains-dot ] when ] @@ -234,6 +237,7 @@ PRIVATE> [ (help.) ] [ nl vocabulary>> link-vocab ] bi ; : scaffold-help ( vocab -- ) + ensure-vocab-exists [ dup "-docs.factor" vocab/suffix>path scaffolding? [ set-scaffold-docs-file @@ -268,6 +272,7 @@ PRIVATE> PRIVATE> : scaffold-tests ( vocab -- ) + ensure-vocab-exists dup "-tests.factor" vocab/suffix>path scaffolding? [ set-scaffold-tests-file From 9503efa9a8585de40f35c9634c43a1e0142aa6aa Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Apr 2009 01:38:39 -0500 Subject: [PATCH 359/772] working on sorting.slots --- basis/sorting/slots/slots.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index 9a0455c3a7..5b910cb621 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -9,7 +9,7 @@ IN: sorting.slots : short-circuit-comparator ( obj1 obj2 word -- comparator/? ) execute( obj1 obj2 -- obj3 ) - dup +eq+ eq? [ drop f ] when ; inline + dup +eq+ eq? [ drop f ] when ; : slot-comparator ( seq -- quot ) [ @@ -17,12 +17,12 @@ IN: sorting.slots [ '[ [ _ execute( tuple -- value ) ] bi@ ] ] map concat ] [ peek - '[ @ _ short-circuit-comparator ] + '[ _ call( obj1 obj2 -- obj3 obj4 ) _ short-circuit-comparator ] ] bi ; PRIVATE> -MACRO: compare-slots ( sort-specs -- <=> ) +MACRO: compare-slots ( sort-specs -- quot ) #! sort-spec: { accessors comparator } [ slot-comparator ] map '[ _ 2|| +eq+ or ] ; From d3e24a7b7ee48f5c6aef06b5c125e42fc09fd0bd Mon Sep 17 00:00:00 2001 From: erg Date: Sat, 18 Apr 2009 01:43:40 -0500 Subject: [PATCH 360/772] add editors.gedit --- basis/editors/gedit/authors.txt | 1 + basis/editors/gedit/gedit.factor | 17 +++++++++++++++++ basis/editors/gedit/summary.txt | 1 + basis/editors/gedit/tags.txt | 1 + 4 files changed, 20 insertions(+) create mode 100644 basis/editors/gedit/authors.txt create mode 100644 basis/editors/gedit/gedit.factor create mode 100644 basis/editors/gedit/summary.txt create mode 100644 basis/editors/gedit/tags.txt diff --git a/basis/editors/gedit/authors.txt b/basis/editors/gedit/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/editors/gedit/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/editors/gedit/gedit.factor b/basis/editors/gedit/gedit.factor new file mode 100644 index 0000000000..97ea0e1cb3 --- /dev/null +++ b/basis/editors/gedit/gedit.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: editors io.launcher kernel make math.parser namespaces +sequences ; +IN: editors.gedit + +: gedit-path ( -- path ) + \ gedit-path get-global [ + "gedit" + ] unless* ; + +: gedit ( file line -- ) + [ + gedit-path , number>string "+" prepend , , + ] { } make run-detached drop ; + +[ gedit ] edit-hook set-global diff --git a/basis/editors/gedit/summary.txt b/basis/editors/gedit/summary.txt new file mode 100644 index 0000000000..ebb7189c9f --- /dev/null +++ b/basis/editors/gedit/summary.txt @@ -0,0 +1 @@ +gedit integration diff --git a/basis/editors/gedit/tags.txt b/basis/editors/gedit/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/gedit/tags.txt @@ -0,0 +1 @@ +unportable From 4f74810c154758d2039e08e039612db46db39ef6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 01:56:29 -0500 Subject: [PATCH 361/772] Split off x11 vocab from x11.xlib, and add x11.unix for event loop integration --- basis/ui/backend/x11/x11.factor | 4 +-- basis/x11/authors.txt | 2 ++ basis/x11/clipboard/clipboard.factor | 2 +- basis/x11/events/events.factor | 2 +- basis/x11/glx/glx.factor | 2 +- basis/x11/unix/authors.txt | 1 + basis/x11/unix/unix.factor | 10 +++++++ basis/x11/windows/windows.factor | 2 +- basis/x11/x11.factor | 44 ++++++++++++++++++++++++++++ basis/x11/xim/xim.factor | 2 +- basis/x11/xlib/xlib.factor | 29 ------------------ 11 files changed, 64 insertions(+), 36 deletions(-) create mode 100644 basis/x11/authors.txt create mode 100644 basis/x11/unix/authors.txt create mode 100644 basis/x11/unix/unix.factor create mode 100644 basis/x11/x11.factor diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index d4b2959297..bb35936c6c 100755 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -3,7 +3,7 @@ USING: accessors alien alien.c-types arrays ui ui.private ui.gadgets ui.gadgets.private ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render ui.event-loop assocs kernel math -namespaces opengl sequences strings x11.xlib x11.events x11.xim +namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim x11.glx x11.clipboard x11.constants x11.windows io.encodings.string io.encodings.ascii io.encodings.utf8 combinators command-line math.vectors classes.tuple opengl.gl threads math.rectangles @@ -196,7 +196,7 @@ M: world client-event QueuedAfterFlush events-queued 0 > [ next-event dup None XFilterEvent 0 = [ drop wait-event ] unless - ] [ ui-wait wait-event ] if ; + ] [ wait-for-display wait-event ] if ; M: x11-ui-backend do-events wait-event dup XAnyEvent-window window dup diff --git a/basis/x11/authors.txt b/basis/x11/authors.txt new file mode 100644 index 0000000000..db8d84451d --- /dev/null +++ b/basis/x11/authors.txt @@ -0,0 +1,2 @@ +Eduardo Cavazos +Slava Pestov diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor index 87b91624af..20bf66c704 100644 --- a/basis/x11/clipboard/clipboard.factor +++ b/basis/x11/clipboard/clipboard.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax arrays kernel math namespaces sequences io.encodings.string -io.encodings.utf8 io.encodings.ascii x11.xlib x11.constants +io.encodings.utf8 io.encodings.ascii x11 x11.xlib x11.constants specialized-arrays.int accessors ; IN: x11.clipboard diff --git a/basis/x11/events/events.factor b/basis/x11/events/events.factor index 07650a9da7..5673dd7f76 100644 --- a/basis/x11/events/events.factor +++ b/basis/x11/events/events.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays hashtables io kernel math math.order namespaces prettyprint sequences strings combinators -x11.xlib ; +x11 x11.xlib ; IN: x11.events GENERIC: expose-event ( event window -- ) diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor index e6001d3e59..c6c10385df 100644 --- a/basis/x11/glx/glx.factor +++ b/basis/x11/glx/glx.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! based on glx.h from xfree86, and some of glxtokens.h -USING: alien alien.c-types alien.syntax x11.xlib namespaces make +USING: alien alien.c-types alien.syntax x11 x11.xlib namespaces make kernel sequences parser words specialized-arrays.int accessors ; IN: x11.glx diff --git a/basis/x11/unix/authors.txt b/basis/x11/unix/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/x11/unix/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/x11/unix/unix.factor b/basis/x11/unix/unix.factor new file mode 100644 index 0000000000..6084b83a9c --- /dev/null +++ b/basis/x11/unix/unix.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.backend.unix namespaces system x11 x11.xlib ; +IN: x11.unix + +SYMBOL: dpy-fd + +M: unix init-x-io dpy get XConnectionNumber dpy-fd set-global ; + +M: unix wait-for-display dpy-fd get +input+ wait-for-fd ; \ No newline at end of file diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index 98ec2728fa..87a212bd8e 100644 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types hashtables kernel math math.vectors -math.bitwise namespaces sequences x11.xlib x11.constants x11.glx +math.bitwise namespaces sequences x11 x11.xlib x11.constants x11.glx arrays fry ; IN: x11.windows diff --git a/basis/x11/x11.factor b/basis/x11/x11.factor new file mode 100644 index 0000000000..e6e70c4cc1 --- /dev/null +++ b/basis/x11/x11.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2005, 2009 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.strings continuations io io.backend +io.encodings.ascii kernel namespaces x11.xlib +vocabs vocabs.loader calendar threads ; +IN: x11 + +SYMBOL: dpy +SYMBOL: scr +SYMBOL: root + +: init-locale ( -- ) + LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless + XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ; + +: flush-dpy ( -- ) dpy get XFlush drop ; + +: x-atom ( string -- atom ) [ dpy get ] dip 0 XInternAtom ; + +: check-display ( alien -- alien' ) + [ "Cannot connect to X server - check $DISPLAY" throw ] unless* ; + +HOOK: init-x-io io-backend ( -- ) + +M: object init-x-io ; + +HOOK: wait-for-display io-backend ( -- ) + +M: object wait-for-display 10 milliseconds sleep ; + +: init-x ( display-string -- ) + init-locale + dup [ ascii string>alien ] when + XOpenDisplay check-display dpy set-global + dpy get XDefaultScreen scr set-global + dpy get scr get XRootWindow root set-global + init-x-io ; + +: close-x ( -- ) dpy get XCloseDisplay drop ; + +: with-x ( display-string quot -- ) + [ init-x ] dip [ close-x ] [ ] cleanup ; inline + +"io.backend.unix" vocab [ "x11.unix" require ] when \ No newline at end of file diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor index e4aaef9bbd..54f20a28dd 100644 --- a/basis/x11/xim/xim.factor +++ b/basis/x11/xim/xim.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings arrays byte-arrays hashtables io io.encodings.string kernel math namespaces -sequences strings continuations x11.xlib specialized-arrays.uint +sequences strings continuations x11 x11.xlib specialized-arrays.uint accessors io.encodings.utf16n ; IN: x11.xim diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index 1a2cf09129..be7e6b4b10 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -1412,32 +1412,3 @@ FUNCTION: char* setlocale ( int category, char* name ) ; FUNCTION: Bool XSupportsLocale ( ) ; FUNCTION: char* XSetLocaleModifiers ( char* modifier_list ) ; - -SYMBOL: dpy -SYMBOL: scr -SYMBOL: root - -: init-locale ( -- ) - LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless - XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ; - -: flush-dpy ( -- ) dpy get XFlush drop ; - -: x-atom ( string -- atom ) dpy get swap 0 XInternAtom ; - -: check-display ( alien -- alien' ) - [ - "Cannot connect to X server - check $DISPLAY" throw - ] unless* ; - -: initialize-x ( display-string -- ) - init-locale - dup [ ascii string>alien ] when - XOpenDisplay check-display dpy set-global - dpy get XDefaultScreen scr set-global - dpy get scr get XRootWindow root set-global ; - -: close-x ( -- ) dpy get XCloseDisplay drop ; - -: with-x ( display-string quot -- ) - [ initialize-x ] dip [ close-x ] [ ] cleanup ; inline From 7e5ab38ed10e93ce855b8ba06f0198d2649a4731 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Apr 2009 02:04:58 -0500 Subject: [PATCH 362/772] use unclip-last-slice --- basis/sorting/slots/slots.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index 5b910cb621..5fbf3d7af9 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -12,13 +12,13 @@ IN: sorting.slots dup +eq+ eq? [ drop f ] when ; : slot-comparator ( seq -- quot ) - [ - but-last-slice - [ '[ [ _ execute( tuple -- value ) ] bi@ ] ] map concat + unclip-last-slice [ + [ + '[ [ _ execute( tuple -- value ) ] bi@ ] + ] map concat ] [ - peek '[ _ call( obj1 obj2 -- obj3 obj4 ) _ short-circuit-comparator ] - ] bi ; + ] bi* ; PRIVATE> From 0a22476cd3760b3d3331ed7bf40a31dce45591de Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 02:19:49 -0500 Subject: [PATCH 363/772] Add awaken-event-loop word --- basis/x11/unix/unix.factor | 8 ++++++-- basis/x11/x11.factor | 4 ++++ 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/basis/x11/unix/unix.factor b/basis/x11/unix/unix.factor index 6084b83a9c..88a66a6c37 100644 --- a/basis/x11/unix/unix.factor +++ b/basis/x11/unix/unix.factor @@ -1,10 +1,14 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.backend.unix namespaces system x11 x11.xlib ; +USING: io.backend.unix io.backend.unix.multiplexers +namespaces system x11 x11.xlib accessors threads sequences ; IN: x11.unix SYMBOL: dpy-fd M: unix init-x-io dpy get XConnectionNumber dpy-fd set-global ; -M: unix wait-for-display dpy-fd get +input+ wait-for-fd ; \ No newline at end of file +M: unix wait-for-display dpy-fd get +input+ wait-for-fd ; + +M: unix awaken-event-loop + dpy-fd get fd>> mx get remove-input-callbacks [ resume ] each ; \ No newline at end of file diff --git a/basis/x11/x11.factor b/basis/x11/x11.factor index e6e70c4cc1..c546c8368f 100644 --- a/basis/x11/x11.factor +++ b/basis/x11/x11.factor @@ -28,6 +28,10 @@ HOOK: wait-for-display io-backend ( -- ) M: object wait-for-display 10 milliseconds sleep ; +HOOK: awaken-event-loop io-backend ( -- ) + +M: object awaken-event-loop ; + : init-x ( display-string -- ) init-locale dup [ ascii string>alien ] when From c3e7db3852c38ecf290a73be4dbdffde2a4c9654 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 02:37:35 -0500 Subject: [PATCH 364/772] Refactor FUNCTION: to make it more extensible --- basis/alien/parser/parser.factor | 17 ++++++++++++----- basis/alien/syntax/syntax.factor | 4 +--- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 193893fabc..df1dd15bfb 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays assocs effects grouping kernel -parser sequences splitting words fry locals ; +parser sequences splitting words fry locals lexer namespaces ; IN: alien.parser : parse-arglist ( parameters return -- types effect ) @@ -12,8 +12,15 @@ IN: alien.parser : function-quot ( return library function types -- quot ) '[ _ _ _ _ alien-invoke ] ; -:: define-function ( return library function parameters -- ) +:: make-function ( return library function parameters -- word quot effect ) function create-in dup reset-generic return library function - parameters return parse-arglist [ function-quot ] dip - define-declared ; + parameters return parse-arglist [ function-quot ] dip ; + +: (FUNCTION:) ( -- word quot effect ) + scan "c-library" get scan ";" parse-tokens + [ "()" subseq? not ] filter + make-function ; + +: define-function ( return library function parameters -- ) + make-function define-declared ; diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 6a1bf7f635..0cc6d51446 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -16,9 +16,7 @@ SYNTAX: BAD-ALIEN parsed ; SYNTAX: LIBRARY: scan "c-library" set ; SYNTAX: FUNCTION: - scan "c-library" get scan ";" parse-tokens - [ "()" subseq? not ] filter - define-function ; + (FUNCTION:) define-declared ; SYNTAX: TYPEDEF: scan scan typedef ; From 616c293d867e5b362276420922c69191495defd9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 02:39:55 -0500 Subject: [PATCH 365/772] X-FUNCTION: calls awaken-event-loop --- basis/x11/glx/glx.factor | 85 ++++++------ basis/x11/io/authors.txt | 1 + basis/x11/io/io.factor | 16 +++ basis/x11/syntax/authors.txt | 1 + basis/x11/syntax/syntax.factor | 9 ++ basis/x11/unix/unix.factor | 3 +- basis/x11/x11.factor | 18 +-- basis/x11/xlib/xlib.factor | 238 ++++++++++++++++----------------- 8 files changed, 194 insertions(+), 177 deletions(-) create mode 100644 basis/x11/io/authors.txt create mode 100644 basis/x11/io/io.factor create mode 100644 basis/x11/syntax/authors.txt create mode 100644 basis/x11/syntax/syntax.factor diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor index c6c10385df..dc6157b87f 100644 --- a/basis/x11/glx/glx.factor +++ b/basis/x11/glx/glx.factor @@ -2,8 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! based on glx.h from xfree86, and some of glxtokens.h -USING: alien alien.c-types alien.syntax x11 x11.xlib namespaces make -kernel sequences parser words specialized-arrays.int accessors ; +USING: alien alien.c-types alien.syntax x11 x11.xlib x11.syntax +namespaces make kernel sequences parser words specialized-arrays.int +accessors ; IN: x11.glx LIBRARY: glx @@ -36,52 +37,52 @@ TYPEDEF: XID GLXFBConfigID TYPEDEF: void* GLXContext ! typedef struct __GLXcontextRec *GLXContext; TYPEDEF: void* GLXFBConfig ! typedef struct __GLXFBConfigRec *GLXFBConfig; -FUNCTION: XVisualInfo* glXChooseVisual ( Display* dpy, int screen, int* attribList ) ; -FUNCTION: void glXCopyContext ( Display* dpy, GLXContext src, GLXContext dst, ulong mask ) ; -FUNCTION: GLXContext glXCreateContext ( Display* dpy, XVisualInfo* vis, GLXContext shareList, bool direct ) ; -FUNCTION: GLXPixmap glXCreateGLXPixmap ( Display* dpy, XVisualInfo* vis, Pixmap pixmap ) ; -FUNCTION: void glXDestroyContext ( Display* dpy, GLXContext ctx ) ; -FUNCTION: void glXDestroyGLXPixmap ( Display* dpy, GLXPixmap pix ) ; -FUNCTION: int glXGetConfig ( Display* dpy, XVisualInfo* vis, int attrib, int* value ) ; -FUNCTION: GLXContext glXGetCurrentContext ( ) ; -FUNCTION: GLXDrawable glXGetCurrentDrawable ( ) ; -FUNCTION: bool glXIsDirect ( Display* dpy, GLXContext ctx ) ; -FUNCTION: bool glXMakeCurrent ( Display* dpy, GLXDrawable drawable, GLXContext ctx ) ; -FUNCTION: bool glXQueryExtension ( Display* dpy, int* errorBase, int* eventBase ) ; -FUNCTION: bool glXQueryVersion ( Display* dpy, int* major, int* minor ) ; -FUNCTION: void glXSwapBuffers ( Display* dpy, GLXDrawable drawable ) ; -FUNCTION: void glXUseXFont ( Font font, int first, int count, int listBase ) ; -FUNCTION: void glXWaitGL ( ) ; -FUNCTION: void glXWaitX ( ) ; -FUNCTION: char* glXGetClientString ( Display* dpy, int name ) ; -FUNCTION: char* glXQueryServerString ( Display* dpy, int screen, int name ) ; -FUNCTION: char* glXQueryExtensionsString ( Display* dpy, int screen ) ; +X-FUNCTION: XVisualInfo* glXChooseVisual ( Display* dpy, int screen, int* attribList ) ; +X-FUNCTION: void glXCopyContext ( Display* dpy, GLXContext src, GLXContext dst, ulong mask ) ; +X-FUNCTION: GLXContext glXCreateContext ( Display* dpy, XVisualInfo* vis, GLXContext shareList, bool direct ) ; +X-FUNCTION: GLXPixmap glXCreateGLXPixmap ( Display* dpy, XVisualInfo* vis, Pixmap pixmap ) ; +X-FUNCTION: void glXDestroyContext ( Display* dpy, GLXContext ctx ) ; +X-FUNCTION: void glXDestroyGLXPixmap ( Display* dpy, GLXPixmap pix ) ; +X-FUNCTION: int glXGetConfig ( Display* dpy, XVisualInfo* vis, int attrib, int* value ) ; +X-FUNCTION: GLXContext glXGetCurrentContext ( ) ; +X-FUNCTION: GLXDrawable glXGetCurrentDrawable ( ) ; +X-FUNCTION: bool glXIsDirect ( Display* dpy, GLXContext ctx ) ; +X-FUNCTION: bool glXMakeCurrent ( Display* dpy, GLXDrawable drawable, GLXContext ctx ) ; +X-FUNCTION: bool glXQueryExtension ( Display* dpy, int* errorBase, int* eventBase ) ; +X-FUNCTION: bool glXQueryVersion ( Display* dpy, int* major, int* minor ) ; +X-FUNCTION: void glXSwapBuffers ( Display* dpy, GLXDrawable drawable ) ; +X-FUNCTION: void glXUseXFont ( Font font, int first, int count, int listBase ) ; +X-FUNCTION: void glXWaitGL ( ) ; +X-FUNCTION: void glXWaitX ( ) ; +X-FUNCTION: char* glXGetClientString ( Display* dpy, int name ) ; +X-FUNCTION: char* glXQueryServerString ( Display* dpy, int screen, int name ) ; +X-FUNCTION: char* glXQueryExtensionsString ( Display* dpy, int screen ) ; ! New for GLX 1.3 -FUNCTION: GLXFBConfig* glXGetFBConfigs ( Display* dpy, int screen, int* nelements ) ; -FUNCTION: GLXFBConfig* glXChooseFBConfig ( Display* dpy, int screen, int* attrib_list, int* nelements ) ; -FUNCTION: int glXGetFBConfigAttrib ( Display* dpy, GLXFBConfig config, int attribute, int* value ) ; -FUNCTION: XVisualInfo* glXGetVisualFromFBConfig ( Display* dpy, GLXFBConfig config ) ; -FUNCTION: GLXWindow glXCreateWindow ( Display* dpy, GLXFBConfig config, Window win, int* attrib_list ) ; -FUNCTION: void glXDestroyWindow ( Display* dpy, GLXWindow win ) ; -FUNCTION: GLXPixmap glXCreatePixmap ( Display* dpy, GLXFBConfig config, Pixmap pixmap, int* attrib_list ) ; -FUNCTION: void glXDestroyPixmap ( Display* dpy, GLXPixmap pixmap ) ; -FUNCTION: GLXPbuffer glXCreatePbuffer ( Display* dpy, GLXFBConfig config, int* attrib_list ) ; -FUNCTION: void glXDestroyPbuffer ( Display* dpy, GLXPbuffer pbuf ) ; -FUNCTION: void glXQueryDrawable ( Display* dpy, GLXDrawable draw, int attribute, uint* value ) ; -FUNCTION: GLXContext glXCreateNewContext ( Display* dpy, GLXFBConfig config, int render_type, GLXContext share_list, bool direct ) ; -FUNCTION: bool glXMakeContextCurrent ( Display* display, GLXDrawable draw, GLXDrawable read, GLXContext ctx ) ; -FUNCTION: GLXDrawable glXGetCurrentReadDrawable ( ) ; -FUNCTION: Display* glXGetCurrentDisplay ( ) ; -FUNCTION: int glXQueryContext ( Display* dpy, GLXContext ctx, int attribute, int* value ) ; -FUNCTION: void glXSelectEvent ( Display* dpy, GLXDrawable draw, ulong event_mask ) ; -FUNCTION: void glXGetSelectedEvent ( Display* dpy, GLXDrawable draw, ulong* event_mask ) ; +X-FUNCTION: GLXFBConfig* glXGetFBConfigs ( Display* dpy, int screen, int* nelements ) ; +X-FUNCTION: GLXFBConfig* glXChooseFBConfig ( Display* dpy, int screen, int* attrib_list, int* nelements ) ; +X-FUNCTION: int glXGetFBConfigAttrib ( Display* dpy, GLXFBConfig config, int attribute, int* value ) ; +X-FUNCTION: XVisualInfo* glXGetVisualFromFBConfig ( Display* dpy, GLXFBConfig config ) ; +X-FUNCTION: GLXWindow glXCreateWindow ( Display* dpy, GLXFBConfig config, Window win, int* attrib_list ) ; +X-FUNCTION: void glXDestroyWindow ( Display* dpy, GLXWindow win ) ; +X-FUNCTION: GLXPixmap glXCreatePixmap ( Display* dpy, GLXFBConfig config, Pixmap pixmap, int* attrib_list ) ; +X-FUNCTION: void glXDestroyPixmap ( Display* dpy, GLXPixmap pixmap ) ; +X-FUNCTION: GLXPbuffer glXCreatePbuffer ( Display* dpy, GLXFBConfig config, int* attrib_list ) ; +X-FUNCTION: void glXDestroyPbuffer ( Display* dpy, GLXPbuffer pbuf ) ; +X-FUNCTION: void glXQueryDrawable ( Display* dpy, GLXDrawable draw, int attribute, uint* value ) ; +X-FUNCTION: GLXContext glXCreateNewContext ( Display* dpy, GLXFBConfig config, int render_type, GLXContext share_list, bool direct ) ; +X-FUNCTION: bool glXMakeContextCurrent ( Display* display, GLXDrawable draw, GLXDrawable read, GLXContext ctx ) ; +X-FUNCTION: GLXDrawable glXGetCurrentReadDrawable ( ) ; +X-FUNCTION: Display* glXGetCurrentDisplay ( ) ; +X-FUNCTION: int glXQueryContext ( Display* dpy, GLXContext ctx, int attribute, int* value ) ; +X-FUNCTION: void glXSelectEvent ( Display* dpy, GLXDrawable draw, ulong event_mask ) ; +X-FUNCTION: void glXGetSelectedEvent ( Display* dpy, GLXDrawable draw, ulong* event_mask ) ; ! GLX 1.4 and later -FUNCTION: void* glXGetProcAddress ( char* procname ) ; +X-FUNCTION: void* glXGetProcAddress ( char* procname ) ; ! GLX_ARB_get_proc_address extension -FUNCTION: void* glXGetProcAddressARB ( char* procname ) ; +X-FUNCTION: void* glXGetProcAddressARB ( char* procname ) ; ! GLX Events ! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks) diff --git a/basis/x11/io/authors.txt b/basis/x11/io/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/x11/io/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/x11/io/io.factor b/basis/x11/io/io.factor new file mode 100644 index 0000000000..0e618cd323 --- /dev/null +++ b/basis/x11/io/io.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.backend calendar threads kernel ; +IN: x11.io + +HOOK: init-x-io io-backend ( -- ) + +M: object init-x-io ; + +HOOK: wait-for-display io-backend ( -- ) + +M: object wait-for-display 10 milliseconds sleep ; + +HOOK: awaken-event-loop io-backend ( -- ) + +M: object awaken-event-loop ; \ No newline at end of file diff --git a/basis/x11/syntax/authors.txt b/basis/x11/syntax/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/x11/syntax/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/x11/syntax/syntax.factor b/basis/x11/syntax/syntax.factor new file mode 100644 index 0000000000..db2adab5dc --- /dev/null +++ b/basis/x11/syntax/syntax.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax alien.parser words x11.io sequences kernel ; +IN: x11.syntax + +SYNTAX: X-FUNCTION: + (FUNCTION:) + [ \ awaken-event-loop suffix ] dip + define-declared ; \ No newline at end of file diff --git a/basis/x11/unix/unix.factor b/basis/x11/unix/unix.factor index 88a66a6c37..8e3fc347a6 100644 --- a/basis/x11/unix/unix.factor +++ b/basis/x11/unix/unix.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend.unix io.backend.unix.multiplexers -namespaces system x11 x11.xlib accessors threads sequences ; +namespaces system x11 x11.xlib x11.io +accessors threads sequences ; IN: x11.unix SYMBOL: dpy-fd diff --git a/basis/x11/x11.factor b/basis/x11/x11.factor index c546c8368f..bbda90aa3e 100644 --- a/basis/x11/x11.factor +++ b/basis/x11/x11.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.strings continuations io io.backend -io.encodings.ascii kernel namespaces x11.xlib -vocabs vocabs.loader calendar threads ; +USING: alien.strings continuations io +io.encodings.ascii kernel namespaces x11.xlib x11.io +vocabs vocabs.loader ; IN: x11 SYMBOL: dpy @@ -20,18 +20,6 @@ SYMBOL: root : check-display ( alien -- alien' ) [ "Cannot connect to X server - check $DISPLAY" throw ] unless* ; -HOOK: init-x-io io-backend ( -- ) - -M: object init-x-io ; - -HOOK: wait-for-display io-backend ( -- ) - -M: object wait-for-display 10 milliseconds sleep ; - -HOOK: awaken-event-loop io-backend ( -- ) - -M: object awaken-event-loop ; - : init-x ( display-string -- ) init-locale dup [ ascii string>alien ] when diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index be7e6b4b10..638f5c8d56 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -13,7 +13,7 @@ USING: kernel arrays alien alien.c-types alien.strings alien.syntax math math.bitwise words sequences namespaces -continuations io io.encodings.ascii ; +continuations io io.encodings.ascii x11.syntax ; IN: x11.xlib LIBRARY: xlib @@ -71,26 +71,26 @@ C-STRUCT: Display { "void*" "free_funcs" } { "int" "fd" } ; -FUNCTION: Display* XOpenDisplay ( void* display_name ) ; +X-FUNCTION: Display* XOpenDisplay ( void* display_name ) ; ! 2.2 Obtaining Information about the Display, Image Formats, or Screens -FUNCTION: ulong XBlackPixel ( Display* display, int screen_number ) ; -FUNCTION: ulong XWhitePixel ( Display* display, int screen_number ) ; -FUNCTION: Colormap XDefaultColormap ( Display* display, int screen_number ) ; -FUNCTION: int XDefaultDepth ( Display* display, int screen_number ) ; -FUNCTION: GC XDefaultGC ( Display* display, int screen_number ) ; -FUNCTION: int XDefaultScreen ( Display* display ) ; -FUNCTION: Window XRootWindow ( Display* display, int screen_number ) ; -FUNCTION: Window XDefaultRootWindow ( Display* display ) ; -FUNCTION: int XProtocolVersion ( Display* display ) ; -FUNCTION: int XProtocolRevision ( Display* display ) ; -FUNCTION: int XQLength ( Display* display ) ; -FUNCTION: int XScreenCount ( Display* display ) ; -FUNCTION: int XConnectionNumber ( Display* display ) ; +X-FUNCTION: ulong XBlackPixel ( Display* display, int screen_number ) ; +X-FUNCTION: ulong XWhitePixel ( Display* display, int screen_number ) ; +X-FUNCTION: Colormap XDefaultColormap ( Display* display, int screen_number ) ; +X-FUNCTION: int XDefaultDepth ( Display* display, int screen_number ) ; +X-FUNCTION: GC XDefaultGC ( Display* display, int screen_number ) ; +X-FUNCTION: int XDefaultScreen ( Display* display ) ; +X-FUNCTION: Window XRootWindow ( Display* display, int screen_number ) ; +X-FUNCTION: Window XDefaultRootWindow ( Display* display ) ; +X-FUNCTION: int XProtocolVersion ( Display* display ) ; +X-FUNCTION: int XProtocolRevision ( Display* display ) ; +X-FUNCTION: int XQLength ( Display* display ) ; +X-FUNCTION: int XScreenCount ( Display* display ) ; +X-FUNCTION: int XConnectionNumber ( Display* display ) ; ! 2.5 Closing the Display -FUNCTION: int XCloseDisplay ( Display* display ) ; +X-FUNCTION: int XCloseDisplay ( Display* display ) ; ! ! 3 - Window Functions @@ -147,17 +147,17 @@ CONSTANT: StaticGravity 10 ! 3.3 - Creating Windows -FUNCTION: Window XCreateWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, int depth, uint class, Visual* visual, ulong valuemask, XSetWindowAttributes* attributes ) ; -FUNCTION: Window XCreateSimpleWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, ulong border, ulong background ) ; -FUNCTION: Status XDestroyWindow ( Display* display, Window w ) ; -FUNCTION: Status XMapWindow ( Display* display, Window window ) ; -FUNCTION: Status XMapSubwindows ( Display* display, Window window ) ; -FUNCTION: Status XUnmapWindow ( Display* display, Window w ) ; -FUNCTION: Status XUnmapSubwindows ( Display* display, Window w ) ; +X-FUNCTION: Window XCreateWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, int depth, uint class, Visual* visual, ulong valuemask, XSetWindowAttributes* attributes ) ; +X-FUNCTION: Window XCreateSimpleWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, ulong border, ulong background ) ; +X-FUNCTION: Status XDestroyWindow ( Display* display, Window w ) ; +X-FUNCTION: Status XMapWindow ( Display* display, Window window ) ; +X-FUNCTION: Status XMapSubwindows ( Display* display, Window window ) ; +X-FUNCTION: Status XUnmapWindow ( Display* display, Window w ) ; +X-FUNCTION: Status XUnmapSubwindows ( Display* display, Window w ) ; ! 3.5 Mapping Windows -FUNCTION: int XMapRaised ( Display* display, Window w ) ; +X-FUNCTION: int XMapRaised ( Display* display, Window w ) ; ! 3.7 - Configuring Windows @@ -178,25 +178,25 @@ C-STRUCT: XWindowChanges { "Window" "sibling" } { "int" "stack_mode" } ; -FUNCTION: Status XConfigureWindow ( Display* display, Window w, uint value_mask, XWindowChanges* values ) ; -FUNCTION: Status XMoveWindow ( Display* display, Window w, int x, int y ) ; -FUNCTION: Status XResizeWindow ( Display* display, Window w, uint width, uint height ) ; -FUNCTION: Status XSetWindowBorderWidth ( Display* display, ulong w, uint width ) ; +X-FUNCTION: Status XConfigureWindow ( Display* display, Window w, uint value_mask, XWindowChanges* values ) ; +X-FUNCTION: Status XMoveWindow ( Display* display, Window w, int x, int y ) ; +X-FUNCTION: Status XResizeWindow ( Display* display, Window w, uint width, uint height ) ; +X-FUNCTION: Status XSetWindowBorderWidth ( Display* display, ulong w, uint width ) ; ! 3.8 Changing Window Stacking Order -FUNCTION: Status XRaiseWindow ( Display* display, Window w ) ; -FUNCTION: Status XLowerWindow ( Display* display, Window w ) ; +X-FUNCTION: Status XRaiseWindow ( Display* display, Window w ) ; +X-FUNCTION: Status XLowerWindow ( Display* display, Window w ) ; ! 3.9 - Changing Window Attributes -FUNCTION: Status XChangeWindowAttributes ( +X-FUNCTION: Status XChangeWindowAttributes ( Display* display, Window w, ulong valuemask, XSetWindowAttributes* attr ) ; -FUNCTION: Status XSetWindowBackground ( +X-FUNCTION: Status XSetWindowBackground ( Display* display, Window w, ulong background_pixel ) ; -FUNCTION: Status XDefineCursor ( Display* display, Window w, Cursor cursor ) ; -FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ; +X-FUNCTION: Status XDefineCursor ( Display* display, Window w, Cursor cursor ) ; +X-FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 4 - Window Information Functions @@ -204,7 +204,7 @@ FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ; ! 4.1 - Obtaining Window Information -FUNCTION: Status XQueryTree ( +X-FUNCTION: Status XQueryTree ( Display* display, Window w, Window* root_return, @@ -236,13 +236,13 @@ C-STRUCT: XWindowAttributes { "Bool" "override_redirect" } { "Screen*" "screen" } ; -FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ; +X-FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ; CONSTANT: IsUnmapped 0 CONSTANT: IsUnviewable 1 CONSTANT: IsViewable 2 -FUNCTION: Status XGetGeometry ( +X-FUNCTION: Status XGetGeometry ( Display* display, Drawable d, Window* root_return, @@ -255,27 +255,27 @@ FUNCTION: Status XGetGeometry ( ! 4.2 - Translating Screen Coordinates -FUNCTION: Bool XQueryPointer ( Display* display, Window w, Window* root_return, Window* child_return, int* root_x_return, int* root_y_return, int* win_x_return, int* win_y_return, uint* mask_return ) ; +X-FUNCTION: Bool XQueryPointer ( Display* display, Window w, Window* root_return, Window* child_return, int* root_x_return, int* root_y_return, int* win_x_return, int* win_y_return, uint* mask_return ) ; ! 4.3 - Properties and Atoms -FUNCTION: Atom XInternAtom ( Display* display, char* atom_name, Bool only_if_exists ) ; +X-FUNCTION: Atom XInternAtom ( Display* display, char* atom_name, Bool only_if_exists ) ; -FUNCTION: char* XGetAtomName ( Display* display, Atom atom ) ; +X-FUNCTION: char* XGetAtomName ( Display* display, Atom atom ) ; ! 4.4 - Obtaining and Changing Window Properties -FUNCTION: int XGetWindowProperty ( Display* display, Window w, Atom property, long long_offset, long long_length, Bool delete, Atom req_type, Atom* actual_type_return, int* actual_format_return, ulong* nitems_return, ulong* bytes_after_return, char** prop_return ) ; +X-FUNCTION: int XGetWindowProperty ( Display* display, Window w, Atom property, long long_offset, long long_length, Bool delete, Atom req_type, Atom* actual_type_return, int* actual_format_return, ulong* nitems_return, ulong* bytes_after_return, char** prop_return ) ; -FUNCTION: int XChangeProperty ( Display* display, Window w, Atom property, Atom type, int format, int mode, void* data, int nelements ) ; +X-FUNCTION: int XChangeProperty ( Display* display, Window w, Atom property, Atom type, int format, int mode, void* data, int nelements ) ; ! 4.5 Selections -FUNCTION: int XSetSelectionOwner ( Display* display, Atom selection, Window owner, Time time ) ; +X-FUNCTION: int XSetSelectionOwner ( Display* display, Atom selection, Window owner, Time time ) ; -FUNCTION: Window XGetSelectionOwner ( Display* display, Atom selection ) ; +X-FUNCTION: Window XGetSelectionOwner ( Display* display, Atom selection ) ; -FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, Atom property, Window requestor, Time time ) ; +X-FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, Atom property, Window requestor, Time time ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -284,8 +284,8 @@ FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, ! 5.1 - Creating and Freeing Pixmaps -FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ; -FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ; +X-FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ; +X-FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -300,13 +300,13 @@ C-STRUCT: XColor { "char" "flags" } { "char" "pad" } ; -FUNCTION: Status XLookupColor ( Display* display, Colormap colormap, char* color_name, XColor* exact_def_return, XColor* screen_def_return ) ; -FUNCTION: Status XAllocColor ( Display* display, Colormap colormap, XColor* screen_in_out ) ; -FUNCTION: Status XQueryColor ( Display* display, Colormap colormap, XColor* def_in_out ) ; +X-FUNCTION: Status XLookupColor ( Display* display, Colormap colormap, char* color_name, XColor* exact_def_return, XColor* screen_def_return ) ; +X-FUNCTION: Status XAllocColor ( Display* display, Colormap colormap, XColor* screen_in_out ) ; +X-FUNCTION: Status XQueryColor ( Display* display, Colormap colormap, XColor* def_in_out ) ; ! 6.4 Creating, Copying, and Destroying Colormaps -FUNCTION: Colormap XCreateColormap ( Display* display, Window w, Visual* visual, int alloc ) ; +X-FUNCTION: Colormap XCreateColormap ( Display* display, Window w, Visual* visual, int alloc ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 7 - Graphics Context Functions @@ -378,27 +378,27 @@ C-STRUCT: XGCValues { "int" "dash_offset" } { "char" "dashes" } ; -FUNCTION: GC XCreateGC ( Display* display, Window d, ulong valuemask, XGCValues* values ) ; -FUNCTION: int XChangeGC ( Display* display, GC gc, ulong valuemask, XGCValues* values ) ; -FUNCTION: Status XGetGCValues ( Display* display, GC gc, ulong valuemask, XGCValues* values_return ) ; -FUNCTION: Status XSetForeground ( Display* display, GC gc, ulong foreground ) ; -FUNCTION: Status XSetBackground ( Display* display, GC gc, ulong background ) ; -FUNCTION: Status XSetFunction ( Display* display, GC gc, int function ) ; -FUNCTION: Status XSetSubwindowMode ( Display* display, GC gc, int subwindow_mode ) ; +X-FUNCTION: GC XCreateGC ( Display* display, Window d, ulong valuemask, XGCValues* values ) ; +X-FUNCTION: int XChangeGC ( Display* display, GC gc, ulong valuemask, XGCValues* values ) ; +X-FUNCTION: Status XGetGCValues ( Display* display, GC gc, ulong valuemask, XGCValues* values_return ) ; +X-FUNCTION: Status XSetForeground ( Display* display, GC gc, ulong foreground ) ; +X-FUNCTION: Status XSetBackground ( Display* display, GC gc, ulong background ) ; +X-FUNCTION: Status XSetFunction ( Display* display, GC gc, int function ) ; +X-FUNCTION: Status XSetSubwindowMode ( Display* display, GC gc, int subwindow_mode ) ; -FUNCTION: GContext XGContextFromGC ( GC gc ) ; +X-FUNCTION: GContext XGContextFromGC ( GC gc ) ; -FUNCTION: Status XSetFont ( Display* display, GC gc, Font font ) ; +X-FUNCTION: Status XSetFont ( Display* display, GC gc, Font font ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 8 - Graphics Functions ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -FUNCTION: Status XClearWindow ( Display* display, Window w ) ; -FUNCTION: Status XDrawPoint ( Display* display, Drawable d, GC gc, int x, int y ) ; -FUNCTION: Status XDrawLine ( Display* display, Drawable d, GC gc, int x1, int y1, int x2, int y2 ) ; -FUNCTION: Status XDrawArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ; -FUNCTION: Status XFillArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ; +X-FUNCTION: Status XClearWindow ( Display* display, Window w ) ; +X-FUNCTION: Status XDrawPoint ( Display* display, Drawable d, GC gc, int x, int y ) ; +X-FUNCTION: Status XDrawLine ( Display* display, Drawable d, GC gc, int x1, int y1, int x2, int y2 ) ; +X-FUNCTION: Status XDrawArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ; +X-FUNCTION: Status XFillArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ; ! 8.5 - Font Metrics @@ -410,9 +410,9 @@ C-STRUCT: XCharStruct { "short" "descent" } { "ushort" "attributes" } ; -FUNCTION: Font XLoadFont ( Display* display, char* name ) ; -FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ; -FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ; +X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ; +X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ; +X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ; C-STRUCT: XFontStruct { "XExtData*" "ext_data" } @@ -432,11 +432,11 @@ C-STRUCT: XFontStruct { "int" "ascent" } { "int" "descent" } ; -FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ; +X-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ; ! 8.6 - Drawing Text -FUNCTION: Status XDrawString ( +X-FUNCTION: Status XDrawString ( Display* display, Drawable d, GC gc, @@ -479,8 +479,8 @@ C-STRUCT: XImage { "XPointer" "obdata" } { "XImage-funcs" "f" } ; -FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ; -FUNCTION: int XDestroyImage ( XImage *ximage ) ; +X-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ; +X-FUNCTION: int XDestroyImage ( XImage *ximage ) ; : XImage-size ( ximage -- size ) [ XImage-height ] [ XImage-bytes_per_line ] bi * ; @@ -492,12 +492,12 @@ FUNCTION: int XDestroyImage ( XImage *ximage ) ; ! 9 - Window and Session Manager Functions ! -FUNCTION: Status XReparentWindow ( Display* display, Window w, Window parent, int x, int y ) ; -FUNCTION: Status XAddToSaveSet ( Display* display, Window w ) ; -FUNCTION: Status XRemoveFromSaveSet ( Display* display, Window w ) ; -FUNCTION: Status XGrabServer ( Display* display ) ; -FUNCTION: Status XUngrabServer ( Display* display ) ; -FUNCTION: Status XKillClient ( Display* display, XID resource ) ; +X-FUNCTION: Status XReparentWindow ( Display* display, Window w, Window parent, int x, int y ) ; +X-FUNCTION: Status XAddToSaveSet ( Display* display, Window w ) ; +X-FUNCTION: Status XRemoveFromSaveSet ( Display* display, Window w ) ; +X-FUNCTION: Status XGrabServer ( Display* display ) ; +X-FUNCTION: Status XUngrabServer ( Display* display ) ; +X-FUNCTION: Status XKillClient ( Display* display, XID resource ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 10 - Events @@ -1066,11 +1066,11 @@ C-UNION: XEvent ! 11 - Event Handling Functions ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -FUNCTION: Status XSelectInput ( Display* display, Window w, long event_mask ) ; -FUNCTION: Status XFlush ( Display* display ) ; -FUNCTION: Status XSync ( Display* display, int discard ) ; -FUNCTION: Status XNextEvent ( Display* display, XEvent* event ) ; -FUNCTION: Status XMaskEvent ( Display* display, long event_mask, XEvent* event_return ) ; +X-FUNCTION: Status XSelectInput ( Display* display, Window w, long event_mask ) ; +X-FUNCTION: Status XFlush ( Display* display ) ; +X-FUNCTION: Status XSync ( Display* display, int discard ) ; +X-FUNCTION: Status XNextEvent ( Display* display, XEvent* event ) ; +X-FUNCTION: Status XMaskEvent ( Display* display, long event_mask, XEvent* event_return ) ; ! 11.3 - Event Queue Management @@ -1078,16 +1078,16 @@ CONSTANT: QueuedAlready 0 CONSTANT: QueuedAfterReading 1 CONSTANT: QueuedAfterFlush 2 -FUNCTION: int XEventsQueued ( Display* display, int mode ) ; -FUNCTION: int XPending ( Display* display ) ; +X-FUNCTION: int XEventsQueued ( Display* display, int mode ) ; +X-FUNCTION: int XPending ( Display* display ) ; ! 11.6 - Sending Events to Other Applications -FUNCTION: Status XSendEvent ( Display* display, Window w, Bool propagate, long event_mask, XEvent* event_send ) ; +X-FUNCTION: Status XSendEvent ( Display* display, Window w, Bool propagate, long event_mask, XEvent* event_send ) ; ! 11.8 - Handling Protocol Errors -FUNCTION: int XSetErrorHandler ( void* handler ) ; +X-FUNCTION: int XSetErrorHandler ( void* handler ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 12 - Input Device Functions @@ -1095,7 +1095,7 @@ FUNCTION: int XSetErrorHandler ( void* handler ) ; CONSTANT: None 0 -FUNCTION: int XGrabPointer ( +X-FUNCTION: int XGrabPointer ( Display* display, Window grab_window, Bool owner_events, @@ -1106,16 +1106,16 @@ FUNCTION: int XGrabPointer ( Cursor cursor, Time time ) ; -FUNCTION: Status XUngrabPointer ( Display* display, Time time ) ; -FUNCTION: Status XChangeActivePointerGrab ( Display* display, uint event_mask, Cursor cursor, Time time ) ; -FUNCTION: Status XGrabKey ( Display* display, int keycode, uint modifiers, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode ) ; -FUNCTION: Status XSetInputFocus ( Display* display, Window focus, int revert_to, Time time ) ; +X-FUNCTION: Status XUngrabPointer ( Display* display, Time time ) ; +X-FUNCTION: Status XChangeActivePointerGrab ( Display* display, uint event_mask, Cursor cursor, Time time ) ; +X-FUNCTION: Status XGrabKey ( Display* display, int keycode, uint modifiers, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode ) ; +X-FUNCTION: Status XSetInputFocus ( Display* display, Window focus, int revert_to, Time time ) ; -FUNCTION: Status XGetInputFocus ( Display* display, +X-FUNCTION: Status XGetInputFocus ( Display* display, Window* focus_return, int* revert_to_return ) ; -FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, int src_x, int src_y, uint src_width, uint src_height, int dest_x, int dest_y ) ; +X-FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, int src_x, int src_y, uint src_width, uint src_height, int dest_x, int dest_y ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 14 - Inter-Client Communication Functions @@ -1123,15 +1123,15 @@ FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, i ! 14.1 Client to Window Manager Communication -FUNCTION: Status XFetchName ( Display* display, Window w, char** window_name_return ) ; -FUNCTION: Status XGetTransientForHint ( Display* display, Window w, Window* prop_window_return ) ; +X-FUNCTION: Status XFetchName ( Display* display, Window w, char** window_name_return ) ; +X-FUNCTION: Status XGetTransientForHint ( Display* display, Window w, Window* prop_window_return ) ; ! 14.1.1. Manipulating Top-Level Windows -FUNCTION: Status XIconifyWindow ( +X-FUNCTION: Status XIconifyWindow ( Display* display, Window w, int screen_number ) ; -FUNCTION: Status XWithdrawWindow ( +X-FUNCTION: Status XWithdrawWindow ( Display* display, Window w, int screen_number ) ; ! 14.1.6 - Setting and Reading the WM_HINTS Property @@ -1173,10 +1173,10 @@ C-STRUCT: XSizeHints ! 14.1.10. Setting and Reading the WM_PROTOCOLS Property -FUNCTION: Status XSetWMProtocols ( +X-FUNCTION: Status XSetWMProtocols ( Display* display, Window w, Atom* protocols, int count ) ; -FUNCTION: Status XGetWMProtocols ( +X-FUNCTION: Status XGetWMProtocols ( Display* display, Window w, Atom** protocols_return, @@ -1188,9 +1188,9 @@ FUNCTION: Status XGetWMProtocols ( ! 16.1 Keyboard Utility Functions -FUNCTION: KeySym XLookupKeysym ( XKeyEvent* key_event, int index ) ; +X-FUNCTION: KeySym XLookupKeysym ( XKeyEvent* key_event, int index ) ; -FUNCTION: int XLookupString ( +X-FUNCTION: int XLookupString ( XKeyEvent* event_struct, void* buffer_return, int bytes_buffer, @@ -1227,7 +1227,7 @@ C-STRUCT: XVisualInfo ! Appendix D - Compatibility Functions ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -FUNCTION: Status XSetStandardProperties ( +X-FUNCTION: Status XSetStandardProperties ( Display* display, Window w, char* window_name, @@ -1314,10 +1314,10 @@ CONSTANT: XA_LAST_PREDEFINED 68 ! The rest of the stuff is not from the book. ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -FUNCTION: void XFree ( void* data ) ; -FUNCTION: int XStoreName ( Display* display, Window w, char* window_name ) ; -FUNCTION: void XSetWMNormalHints ( Display* display, Window w, XSizeHints* hints ) ; -FUNCTION: int XBell ( Display* display, int percent ) ; +X-FUNCTION: void XFree ( void* data ) ; +X-FUNCTION: int XStoreName ( Display* display, Window w, char* window_name ) ; +X-FUNCTION: void XSetWMNormalHints ( Display* display, Window w, XSizeHints* hints ) ; +X-FUNCTION: int XBell ( Display* display, int percent ) ; ! !!! INPUT METHODS @@ -1381,23 +1381,23 @@ CONSTANT: XLookupChars 2 CONSTANT: XLookupKeySym 3 CONSTANT: XLookupBoth 4 -FUNCTION: Bool XFilterEvent ( XEvent* event, Window w ) ; +X-FUNCTION: Bool XFilterEvent ( XEvent* event, Window w ) ; -FUNCTION: XIM XOpenIM ( Display* dpy, void* rdb, char* res_name, char* res_class ) ; +X-FUNCTION: XIM XOpenIM ( Display* dpy, void* rdb, char* res_name, char* res_class ) ; -FUNCTION: Status XCloseIM ( XIM im ) ; +X-FUNCTION: Status XCloseIM ( XIM im ) ; -FUNCTION: XIC XCreateIC ( XIM im, char* key1, Window value1, char* key2, Window value2, char* key3, int value3, char* key4, char* value4, char* key5, char* value5, int key6 ) ; +X-FUNCTION: XIC XCreateIC ( XIM im, char* key1, Window value1, char* key2, Window value2, char* key3, int value3, char* key4, char* value4, char* key5, char* value5, int key6 ) ; -FUNCTION: void XDestroyIC ( XIC ic ) ; +X-FUNCTION: void XDestroyIC ( XIC ic ) ; -FUNCTION: void XSetICFocus ( XIC ic ) ; +X-FUNCTION: void XSetICFocus ( XIC ic ) ; -FUNCTION: void XUnsetICFocus ( XIC ic ) ; +X-FUNCTION: void XUnsetICFocus ( XIC ic ) ; -FUNCTION: int XwcLookupString ( XIC ic, XKeyPressedEvent* event, ulong* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ; +X-FUNCTION: int XwcLookupString ( XIC ic, XKeyPressedEvent* event, ulong* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ; -FUNCTION: int Xutf8LookupString ( XIC ic, XKeyPressedEvent* event, char* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ; +X-FUNCTION: int Xutf8LookupString ( XIC ic, XKeyPressedEvent* event, char* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ; ! !!! category of setlocale CONSTANT: LC_ALL 0 @@ -1407,8 +1407,8 @@ CONSTANT: LC_MONETARY 3 CONSTANT: LC_NUMERIC 4 CONSTANT: LC_TIME 5 -FUNCTION: char* setlocale ( int category, char* name ) ; +X-FUNCTION: char* setlocale ( int category, char* name ) ; -FUNCTION: Bool XSupportsLocale ( ) ; +X-FUNCTION: Bool XSupportsLocale ( ) ; -FUNCTION: char* XSetLocaleModifiers ( char* modifier_list ) ; +X-FUNCTION: char* XSetLocaleModifiers ( char* modifier_list ) ; From 5579842d7a23c5fd24d765bb3d681687637dc6ab Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 02:52:29 -0500 Subject: [PATCH 366/772] Fix USING: --- basis/ui/backend/x11/x11.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index bb35936c6c..fb78abe917 100755 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -4,10 +4,10 @@ USING: accessors alien alien.c-types arrays ui ui.private ui.gadgets ui.gadgets.private ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render ui.event-loop assocs kernel math namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim -x11.glx x11.clipboard x11.constants x11.windows io.encodings.string -io.encodings.ascii io.encodings.utf8 combinators command-line -math.vectors classes.tuple opengl.gl threads math.rectangles -environment ascii ; +x11.glx x11.clipboard x11.constants x11.windows x11.io +io.encodings.string io.encodings.ascii io.encodings.utf8 combinators +command-line math.vectors classes.tuple opengl.gl threads +math.rectangles environment ascii ; IN: ui.backend.x11 SINGLETON: x11-ui-backend From 427710427ce17ac8edbb02889ab60cc046f4591c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 02:54:34 -0500 Subject: [PATCH 367/772] awaken-event-loop does nothing if dpy-fd not set; move x11.unix to x11.io.unix --- basis/x11/{ => io}/unix/authors.txt | 0 basis/x11/{ => io}/unix/unix.factor | 6 +++--- basis/x11/x11.factor | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) rename basis/x11/{ => io}/unix/authors.txt (100%) rename basis/x11/{ => io}/unix/unix.factor (73%) diff --git a/basis/x11/unix/authors.txt b/basis/x11/io/unix/authors.txt similarity index 100% rename from basis/x11/unix/authors.txt rename to basis/x11/io/unix/authors.txt diff --git a/basis/x11/unix/unix.factor b/basis/x11/io/unix/unix.factor similarity index 73% rename from basis/x11/unix/unix.factor rename to basis/x11/io/unix/unix.factor index 8e3fc347a6..821beb91a5 100644 --- a/basis/x11/unix/unix.factor +++ b/basis/x11/io/unix/unix.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.backend.unix io.backend.unix.multiplexers namespaces system x11 x11.xlib x11.io -accessors threads sequences ; -IN: x11.unix +accessors threads sequences kernel ; +IN: x11.io.unix SYMBOL: dpy-fd @@ -12,4 +12,4 @@ M: unix init-x-io dpy get XConnectionNumber dpy-fd set-global ; M: unix wait-for-display dpy-fd get +input+ wait-for-fd ; M: unix awaken-event-loop - dpy-fd get fd>> mx get remove-input-callbacks [ resume ] each ; \ No newline at end of file + dpy-fd get [ fd>> mx get remove-input-callbacks [ resume ] each ] when* ; \ No newline at end of file diff --git a/basis/x11/x11.factor b/basis/x11/x11.factor index bbda90aa3e..09328c6f6e 100644 --- a/basis/x11/x11.factor +++ b/basis/x11/x11.factor @@ -33,4 +33,4 @@ SYMBOL: root : with-x ( display-string quot -- ) [ init-x ] dip [ close-x ] [ ] cleanup ; inline -"io.backend.unix" vocab [ "x11.unix" require ] when \ No newline at end of file +"io.backend.unix" vocab [ "x11.io.unix" require ] when \ No newline at end of file From b5acfdcd6495f9b54a039c9ab35d54ed8c73c6a5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 03:04:03 -0500 Subject: [PATCH 368/772] mason: fix some bugs --- extra/mason/build/build-tests.factor | 3 --- extra/mason/email/email-tests.factor | 3 +-- extra/mason/report/report.factor | 1 + 3 files changed, 2 insertions(+), 5 deletions(-) diff --git a/extra/mason/build/build-tests.factor b/extra/mason/build/build-tests.factor index 1e3705629f..4f5825e4dd 100644 --- a/extra/mason/build/build-tests.factor +++ b/extra/mason/build/build-tests.factor @@ -1,5 +1,2 @@ USING: mason.build tools.test sequences ; IN: mason.build.tests - -{ create-build-dir enter-build-dir clone-builds-factor record-id } -[ must-infer ] each diff --git a/extra/mason/email/email-tests.factor b/extra/mason/email/email-tests.factor index 5bde9a9cfe..e2afe01a56 100644 --- a/extra/mason/email/email-tests.factor +++ b/extra/mason/email/email-tests.factor @@ -5,7 +5,6 @@ USING: mason.email mason.common mason.config namespaces tools.test ; [ "linux" target-os set "x86.64" target-cpu set - status-error status set - subject prefix-subject + status-error subject prefix-subject ] with-scope ] unit-test diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index d6732adb1d..0839652d55 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -63,6 +63,7 @@ IN: mason.report benchmark-time-file html-help-time-file } [ + execute( -- string ) dup utf8 file-contents milli-seconds>time [XML <-><-> XML] ] map [XML

    Timings

    <->
    XML] ; From 7417a8741e2efa09e99d0a5d3a3e01234cdb1cdf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 03:09:50 -0500 Subject: [PATCH 369/772] generalizations: fix help lint --- basis/generalizations/generalizations.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 637f958eb5..edee44acc6 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -7,7 +7,7 @@ IN: generalizations << -: n*quot ( n quot -- seq' ) concat >quotation ; +: n*quot ( n quot -- quot' ) concat >quotation ; : repeat ( n obj quot -- ) swapd times ; inline From e811dd6192fd21713c4ee3344723c9917a3d4b89 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 03:21:31 -0500 Subject: [PATCH 370/772] Reverse compiler.errors => tools.errrs dependency to reduce deploy image size --- basis/compiler/errors/errors-docs.factor | 29 --------------------- basis/compiler/errors/errors.factor | 12 +-------- basis/tools/errors/errors-docs.factor | 32 +++++++++++++++++++++++- basis/tools/errors/errors.factor | 12 ++++++++- core/parser/parser.factor | 2 ++ 5 files changed, 45 insertions(+), 42 deletions(-) diff --git a/basis/compiler/errors/errors-docs.factor b/basis/compiler/errors/errors-docs.factor index c10e33b745..6dbe5193aa 100644 --- a/basis/compiler/errors/errors-docs.factor +++ b/basis/compiler/errors/errors-docs.factor @@ -2,33 +2,4 @@ IN: compiler.errors USING: help.markup help.syntax vocabs.loader words io quotations words.symbol ; -ARTICLE: "compiler-errors" "Compiler warnings and errors" -"After loading a vocabulary, you might see messages like:" -{ $code - ":errors - print 2 compiler errors" - ":warnings - print 50 compiler warnings" -} -"These messages arise from the compiler's stack effect checker. Production code should not have any warnings and errors in it. Warning and error conditions are documented in " { $link "inference-errors" } "." -$nl -"Words to view warnings and errors:" -{ $subsection :warnings } -{ $subsection :errors } -{ $subsection :linkage } -"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "." ; - -HELP: compiler-error -{ $values { "error" "an error" } { "word" word } } -{ $description "Saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } "." } ; - -HELP: :errors -{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ; - -HELP: :warnings -{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ; - -HELP: :linkage -{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ; - -{ :errors :warnings } related-words - ABOUT: "compiler-errors" diff --git a/basis/compiler/errors/errors.factor b/basis/compiler/errors/errors.factor index d9e2a27560..22ae8d97ff 100644 --- a/basis/compiler/errors/errors.factor +++ b/basis/compiler/errors/errors.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors source-files.errors kernel namespaces assocs -tools.errors ; +USING: accessors source-files.errors kernel namespaces assocs ; IN: compiler.errors TUPLE: compiler-error < source-file-error ; @@ -53,12 +52,3 @@ T{ error-type : compiler-error ( error word -- ) compiler-errors get-global pick [ [ [ ] keep ] dip set-at ] [ delete-at drop ] if ; - -: compiler-errors. ( type -- ) - errors-of-type values errors. ; - -: :errors ( -- ) +compiler-error+ compiler-errors. ; - -: :warnings ( -- ) +compiler-warning+ compiler-errors. ; - -: :linkage ( -- ) +linkage-error+ compiler-errors. ; diff --git a/basis/tools/errors/errors-docs.factor b/basis/tools/errors/errors-docs.factor index 9fc324b231..96b13b69b6 100644 --- a/basis/tools/errors/errors-docs.factor +++ b/basis/tools/errors/errors-docs.factor @@ -1,5 +1,35 @@ IN: tools.errors -USING: help.markup help.syntax source-files.errors ; +USING: help.markup help.syntax source-files.errors words io +compiler.errors ; + +ARTICLE: "compiler-errors" "Compiler warnings and errors" +"After loading a vocabulary, you might see messages like:" +{ $code + ":errors - print 2 compiler errors" + ":warnings - print 50 compiler warnings" +} +"These messages arise from the compiler's stack effect checker. Production code should not have any warnings and errors in it. Warning and error conditions are documented in " { $link "inference-errors" } "." +$nl +"Words to view warnings and errors:" +{ $subsection :warnings } +{ $subsection :errors } +{ $subsection :linkage } +"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "." ; + +HELP: compiler-error +{ $values { "error" "an error" } { "word" word } } +{ $description "Saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } "." } ; + +HELP: :errors +{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ; + +HELP: :warnings +{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ; + +HELP: :linkage +{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ; + +{ :errors :warnings :linkage } related-words HELP: errors. { $values { "errors" "a sequence of " { $link source-file-error } " instances" } } diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor index b4b6a3ec1e..0a28bdec08 100644 --- a/basis/tools/errors/errors.factor +++ b/basis/tools/errors/errors.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs debugger io kernel sequences source-files.errors -summary accessors continuations make math.parser io.styles namespaces ; +summary accessors continuations make math.parser io.styles namespaces +compiler.errors ; IN: tools.errors #! Tools for source-files.errors. Used by tools.tests and others @@ -30,3 +31,12 @@ M: source-file-error error. [ [ nl ] [ error. ] interleave ] bi* ] assoc-each ; + +: compiler-errors. ( type -- ) + errors-of-type values errors. ; + +: :errors ( -- ) +compiler-error+ compiler-errors. ; + +: :warnings ( -- ) +compiler-warning+ compiler-errors. ; + +: :linkage ( -- ) +linkage-error+ compiler-errors. ; \ No newline at end of file diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 38cb4869ab..9876818d26 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -180,6 +180,7 @@ SYMBOL: interactive-vocabs "math.order" "memory" "namespaces" + "parser" "prettyprint" "see" "sequences" @@ -191,6 +192,7 @@ SYMBOL: interactive-vocabs "tools.annotations" "tools.crossref" "tools.disassembler" + "tools.errors" "tools.memory" "tools.profiler" "tools.test" From 8baaf04ac5138d4a66b958919fbb687835ccca89 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 03:25:51 -0500 Subject: [PATCH 371/772] When doing code heap compaction, don't scan stacks as roots since we're going to exit anyway --- vm/data_gc.c | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/vm/data_gc.c b/vm/data_gc.c index 11c1639fea..2252d07541 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -149,21 +149,23 @@ void copy_roots(void) copy_registered_locals(); copy_stack_elements(extra_roots_region,extra_roots); - save_stacks(); - F_CONTEXT *stacks = stack_chain; - - while(stacks) + if(!performing_compaction) { - copy_stack_elements(stacks->datastack_region,stacks->datastack); - copy_stack_elements(stacks->retainstack_region,stacks->retainstack); + save_stacks(); + F_CONTEXT *stacks = stack_chain; - copy_handle(&stacks->catchstack_save); - copy_handle(&stacks->current_callback_save); + while(stacks) + { + copy_stack_elements(stacks->datastack_region,stacks->datastack); + copy_stack_elements(stacks->retainstack_region,stacks->retainstack); + + copy_handle(&stacks->catchstack_save); + copy_handle(&stacks->current_callback_save); - if(!performing_compaction) mark_active_blocks(stacks); - stacks = stacks->next; + stacks = stacks->next; + } } int i; From 51c6390cfa67fbe55f368a25ca8528b5551fcd2e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 04:08:09 -0500 Subject: [PATCH 372/772] mason.child: fix tests --- extra/mason/child/child-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/mason/child/child-tests.factor b/extra/mason/child/child-tests.factor index a83e7282da..2d5a7c6635 100644 --- a/extra/mason/child/child-tests.factor +++ b/extra/mason/child/child-tests.factor @@ -1,5 +1,5 @@ IN: mason.child.tests -USING: mason.child mason.config tools.test namespaces ; +USING: mason.child mason.config tools.test namespaces io kernel sequences ; [ { "make" "winnt-x86-32" } ] [ [ From 9add08c2008ab0b81dfa3862902ec8310b233cd2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 04:09:16 -0500 Subject: [PATCH 373/772] Move math.matrices to basis --- {extra => basis}/math/matrices/authors.txt | 0 {extra => basis}/math/matrices/elimination/authors.txt | 0 .../math/matrices/elimination/elimination-tests.factor | 0 {extra => basis}/math/matrices/elimination/elimination.factor | 0 {extra => basis}/math/matrices/elimination/summary.txt | 0 {extra => basis}/math/matrices/matrices-tests.factor | 0 {extra => basis}/math/matrices/matrices.factor | 0 {extra => basis}/math/matrices/summary.txt | 0 8 files changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/math/matrices/authors.txt (100%) rename {extra => basis}/math/matrices/elimination/authors.txt (100%) rename {extra => basis}/math/matrices/elimination/elimination-tests.factor (100%) rename {extra => basis}/math/matrices/elimination/elimination.factor (100%) rename {extra => basis}/math/matrices/elimination/summary.txt (100%) rename {extra => basis}/math/matrices/matrices-tests.factor (100%) rename {extra => basis}/math/matrices/matrices.factor (100%) rename {extra => basis}/math/matrices/summary.txt (100%) diff --git a/extra/math/matrices/authors.txt b/basis/math/matrices/authors.txt similarity index 100% rename from extra/math/matrices/authors.txt rename to basis/math/matrices/authors.txt diff --git a/extra/math/matrices/elimination/authors.txt b/basis/math/matrices/elimination/authors.txt similarity index 100% rename from extra/math/matrices/elimination/authors.txt rename to basis/math/matrices/elimination/authors.txt diff --git a/extra/math/matrices/elimination/elimination-tests.factor b/basis/math/matrices/elimination/elimination-tests.factor similarity index 100% rename from extra/math/matrices/elimination/elimination-tests.factor rename to basis/math/matrices/elimination/elimination-tests.factor diff --git a/extra/math/matrices/elimination/elimination.factor b/basis/math/matrices/elimination/elimination.factor similarity index 100% rename from extra/math/matrices/elimination/elimination.factor rename to basis/math/matrices/elimination/elimination.factor diff --git a/extra/math/matrices/elimination/summary.txt b/basis/math/matrices/elimination/summary.txt similarity index 100% rename from extra/math/matrices/elimination/summary.txt rename to basis/math/matrices/elimination/summary.txt diff --git a/extra/math/matrices/matrices-tests.factor b/basis/math/matrices/matrices-tests.factor similarity index 100% rename from extra/math/matrices/matrices-tests.factor rename to basis/math/matrices/matrices-tests.factor diff --git a/extra/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor similarity index 100% rename from extra/math/matrices/matrices.factor rename to basis/math/matrices/matrices.factor diff --git a/extra/math/matrices/summary.txt b/basis/math/matrices/summary.txt similarity index 100% rename from extra/math/matrices/summary.txt rename to basis/math/matrices/summary.txt From 567bd334a00077948d94d06dee672dc4cb26896e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Apr 2009 11:42:53 -0500 Subject: [PATCH 374/772] modernize openal.other --- extra/openal/other/other.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/openal/other/other.factor b/extra/openal/other/other.factor index d0429fb3c3..0936c94150 100644 --- a/extra/openal/other/other.factor +++ b/extra/openal/other/other.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: openal.backend alien.c-types kernel alien alien.syntax -shuffle combinators.lib ; +USING: alien.c-types alien.syntax combinators generalizations +kernel openal.backend ; IN: openal.other LIBRARY: alut @@ -9,6 +9,6 @@ LIBRARY: alut FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ; M: object load-wav-file ( filename -- format data size frequency ) - 0 f 0 0 - [ 0 alutLoadWAVFile ] 4keep - >r >r >r *int r> *void* r> *int r> *int ; + 0 f 0 0 + [ 0 alutLoadWAVFile ] 4 nkeep + { [ *int ] [ *void* ] [ *int ] [ *int ] } spread ; From c1d1fe9b2079c1033f40b869699477eef273dbcc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Apr 2009 13:44:20 -0500 Subject: [PATCH 375/772] minor fixes in sorting --- basis/sorting/slots/slots-docs.factor | 2 +- basis/sorting/slots/slots.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor index b427cf2956..24c27eb00c 100644 --- a/basis/sorting/slots/slots-docs.factor +++ b/basis/sorting/slots/slots-docs.factor @@ -18,7 +18,7 @@ HELP: sort-by-slots } { $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." } { $examples - "Sort by slot c, then b descending:" + "Sort by slot a, then b descending:" { $example "USING: accessors math.order prettyprint sorting.slots ;" "IN: scratchpad" diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index 5fbf3d7af9..d3d7f47f99 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -7,7 +7,7 @@ IN: sorting.slots Date: Sat, 18 Apr 2009 13:48:15 -0500 Subject: [PATCH 376/772] make openal.example load, it's still broken.. --- extra/openal/example/example.factor | 45 ++++++++++++++--------------- 1 file changed, 22 insertions(+), 23 deletions(-) diff --git a/extra/openal/example/example.factor b/extra/openal/example/example.factor index ae0b50afff..4d979a8fa7 100644 --- a/extra/openal/example/example.factor +++ b/extra/openal/example/example.factor @@ -1,34 +1,33 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -! +USING: calendar kernel openal sequences threads ; IN: openal.example -USING: openal kernel alien threads sequences calendar ; : play-hello ( -- ) - init-openal - 1 gen-sources - first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param - source-play - 1000 milliseconds sleep ; + init-openal + 1 gen-sources + first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param + source-play + 1000 milliseconds sleep ; : (play-file) ( source -- ) - 100 milliseconds sleep - dup source-playing? [ (play-file) ] [ drop ] if ; + 100 milliseconds sleep + dup source-playing? [ (play-file) ] [ drop ] if ; : play-file ( filename -- ) - init-openal - create-buffer-from-file - 1 gen-sources - first dup >r AL_BUFFER rot set-source-param r> - dup source-play - check-error - (play-file) ; + init-openal + create-buffer-from-file + 1 gen-sources + first dup [ AL_BUFFER rot set-source-param ] dip + dup source-play + check-error + (play-file) ; : play-wav ( filename -- ) - init-openal - create-buffer-from-wav - 1 gen-sources - first dup >r AL_BUFFER rot set-source-param r> - dup source-play - check-error - (play-file) ; \ No newline at end of file + init-openal + create-buffer-from-wav + 1 gen-sources + first dup [ AL_BUFFER rot set-source-param ] dip + dup source-play + check-error + (play-file) ; From 8820c95964463ac393a138d19011fc69a9344abc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Apr 2009 15:21:12 -0500 Subject: [PATCH 377/772] make x11.io.unix unportable --- basis/x11/io/unix/tags.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 basis/x11/io/unix/tags.txt diff --git a/basis/x11/io/unix/tags.txt b/basis/x11/io/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/x11/io/unix/tags.txt @@ -0,0 +1 @@ +unportable From 0ca924124a44b5abac4e4c7cf469140d141b8154 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 16:44:24 -0500 Subject: [PATCH 378/772] Rewrite sorting.slots --- basis/sorting/slots/slots-docs.factor | 22 ++----- basis/sorting/slots/slots-tests.factor | 89 ++------------------------ basis/sorting/slots/slots.factor | 53 +++++---------- 3 files changed, 27 insertions(+), 137 deletions(-) diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor index 24c27eb00c..5960c451fe 100644 --- a/basis/sorting/slots/slots-docs.factor +++ b/basis/sorting/slots/slots-docs.factor @@ -11,7 +11,7 @@ HELP: compare-slots } { $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ; -HELP: sort-by-slots +HELP: sort-by { $values { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" } { "seq'" sequence } @@ -32,27 +32,13 @@ HELP: sort-by-slots } } ; -HELP: split-by-slots -{ $values - { "accessor-seqs" "a sequence of sequences of tuple accessors" } - { "quot" quotation } -} -{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ; - -HELP: sort-by -{ $values - { "seq" sequence } { "sort-seq" "a sequence of comparators" } - { "seq'" sequence } -} -{ $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ; - ARTICLE: "sorting.slots" "Sorting by slots" "The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl "Comparing two objects by a sequence of slots:" { $subsection compare-slots } "Sorting a sequence of tuples by a slot/comparator pairs:" -{ $subsection sort-by-slots } -"Sorting a sequence by a sequence of comparators:" -{ $subsection sort-by } ; +{ $subsection sort-by } +{ $subsection sort-keys-by } +{ $subsection sort-values-by } ; ABOUT: "sorting.slots" diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor index e31b9be359..5ebd4438fe 100644 --- a/basis/sorting/slots/slots-tests.factor +++ b/basis/sorting/slots/slots-tests.factor @@ -24,7 +24,7 @@ TUPLE: tuple2 d ; T{ sort-test f 1 1 11 } T{ sort-test f 2 5 3 } T{ sort-test f 2 5 2 } - } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots + } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by ] unit-test [ @@ -42,43 +42,14 @@ TUPLE: tuple2 d ; T{ sort-test f 1 1 11 } T{ sort-test f 2 5 3 } T{ sort-test f 2 5 2 } - } { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by-slots + } { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by ] unit-test -[ - { - { - T{ sort-test { a 1 } { b 1 } { c 10 } } - T{ sort-test { a 1 } { b 1 } { c 11 } } - } - { T{ sort-test { a 1 } { b 3 } { c 9 } } } - { - T{ sort-test { a 2 } { b 5 } { c 3 } } - T{ sort-test { a 2 } { b 5 } { c 2 } } - } - } -] [ - { - T{ sort-test f 1 3 9 } - T{ sort-test f 1 1 10 } - T{ sort-test f 1 1 11 } - T{ sort-test f 2 5 3 } - T{ sort-test f 2 5 2 } - } - { { a>> human<=> } { b>> <=> } } [ sort-by-slots ] keep - [ but-last-slice ] map split-by-slots [ >array ] map -] unit-test - -: split-test ( seq -- seq' ) - { { a>> } { b>> } } split-by-slots ; - -[ split-test ] must-infer +[ { } ] +[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by ] unit-test [ { } ] -[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test - -[ { } ] -[ { } { } sort-by-slots ] unit-test +[ { } { } sort-by ] unit-test [ { @@ -97,55 +68,7 @@ TUPLE: tuple2 d ; T{ sort-test f 6 f f T{ tuple2 f 3 } } T{ sort-test f 5 f f T{ tuple2 f 3 } } T{ sort-test f 6 f f T{ tuple2 f 2 } } - } { { tuple2>> d>> <=> } { a>> <=> } } sort-by-slots -] unit-test - -[ - { - { - T{ sort-test - { a 6 } - { tuple2 T{ tuple2 { d 1 } } } - } - } - { - T{ sort-test - { a 6 } - { tuple2 T{ tuple2 { d 2 } } } - } - } - { - T{ sort-test - { a 5 } - { tuple2 T{ tuple2 { d 3 } } } - } - } - { - T{ sort-test - { a 6 } - { tuple2 T{ tuple2 { d 3 } } } - } - T{ sort-test - { a 6 } - { tuple2 T{ tuple2 { d 3 } } } - } - } - { - T{ sort-test - { a 5 } - { tuple2 T{ tuple2 { d 4 } } } - } - } - } -] [ - { - T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } } - T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } } - T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } } - T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } } - T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } } - T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } } - } { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map + } { { tuple2>> d>> <=> } { a>> <=> } } sort-by ] unit-test diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index d3d7f47f99..e3b4bc88ca 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -1,47 +1,28 @@ ! Copyright (C) 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.short-circuit fry kernel macros math.order -sequences words sorting sequences.deep assocs splitting.monotonic -math ; +USING: arrays fry kernel math.order sequences sorting ; IN: sorting.slots -/f ) + execute( obj1 obj2 -- <=> ) dup +eq+ eq? [ drop f ] when ; -: short-circuit-comparator ( obj1 obj2 word -- comparator/? ) - execute( obj1 obj2 -- obj3 ) - dup +eq+ eq? [ drop f ] when ; +: execute-accessor ( obj1 obj2 word -- obj1' obj2' ) + '[ _ execute( tuple -- value ) ] bi@ ; -: slot-comparator ( seq -- quot ) - unclip-last-slice [ - [ - '[ [ _ execute( tuple -- value ) ] bi@ ] - ] map concat - ] [ - '[ _ call( obj1 obj2 -- obj3 obj4 ) _ short-circuit-comparator ] - ] bi* ; - -PRIVATE> - -MACRO: compare-slots ( sort-specs -- quot ) +: compare-slots ( obj1 obj2 sort-specs -- <=> ) #! sort-spec: { accessors comparator } - [ slot-comparator ] map '[ _ 2|| +eq+ or ] ; + [ + dup array? [ + unclip-last-slice + [ [ execute-accessor ] each ] dip + ] when execute-comparator + ] with with map-find drop +eq+ or ; -: sort-by-slots ( seq sort-specs -- seq' ) - '[ _ compare-slots ] sort ; +: sort-by-with ( seq sort-specs quot -- seq' ) + swap '[ _ bi@ _ compare-slots ] sort ; inline -MACRO: compare-seq ( seq -- quot ) - [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ; +: sort-by ( seq sort-specs -- seq' ) [ ] sort-by-with ; -: sort-by ( seq sort-seq -- seq' ) - '[ _ compare-seq ] sort ; +: sort-keys-by ( seq sort-seq -- seq' ) [ first ] sort-by-with ; -: sort-keys-by ( seq sort-seq -- seq' ) - '[ [ first ] bi@ _ compare-seq ] sort ; - -: sort-values-by ( seq sort-seq -- seq' ) - '[ [ second ] bi@ _ compare-seq ] sort ; - -MACRO: split-by-slots ( accessor-seqs -- quot ) - [ [ '[ [ _ execute( tuple -- value ) ] bi@ ] ] map concat - [ = ] compose ] map - '[ [ _ 2&& ] slice monotonic-slice ] ; +: sort-values-by ( seq sort-seq -- seq' ) [ second ] sort-by-with ; From 2d8d7f120fef12acec7251a155f7a37c7b176a11 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 16:44:34 -0500 Subject: [PATCH 379/772] sort-by-slots => sort-by --- basis/tools/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 8d882099de..146a119a63 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -75,7 +75,7 @@ M: object file-spec>string ( file-listing spec -- string ) : list-files-slow ( listing-tool -- array ) [ path>> ] [ sort>> ] [ specs>> ] tri '[ [ dup name>> file-info file-listing boa ] map - _ [ sort-by-slots ] when* + _ [ sort-by ] when* [ _ [ file-spec>string ] with map ] map ] with-directory-entries ; inline From bb06e98dfb304797b518e74594c309aa57ec43bf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 16:44:42 -0500 Subject: [PATCH 380/772] Fix compiler warning in jamshred.log --- extra/jamshred/log/log.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/jamshred/log/log.factor b/extra/jamshred/log/log.factor index 33498d8a2e..f2517d1ec3 100644 --- a/extra/jamshred/log/log.factor +++ b/extra/jamshred/log/log.factor @@ -4,7 +4,7 @@ IN: jamshred.log LOG: (jamshred-log) DEBUG : with-jamshred-log ( quot -- ) - "jamshred" swap with-logging ; + "jamshred" swap with-logging ; inline : jamshred-log ( message -- ) [ (jamshred-log) ] with-jamshred-log ; ! ugly... From 49eec252d2f1be2873fc2d541d7b6e4820dc0edf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Apr 2009 18:28:09 -0500 Subject: [PATCH 381/772] scaffold factor-boot-rc on windows instead of .factor-boot-rc --- basis/tools/scaffold/scaffold.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index d02faae3a8..d6414284b4 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -301,8 +301,10 @@ SYMBOL: examples-flag [ home ] dip append-path [ touch-file ] [ "Click to edit: " write . ] bi ; -: scaffold-factor-boot-rc ( -- ) ".factor-boot-rc" scaffold-rc ; +: scaffold-factor-boot-rc ( -- ) + windows? "factor-boot-rc" ".factor-boot-rc" ? scaffold-rc ; -: scaffold-factor-rc ( -- ) ".factor-rc" scaffold-rc ; +: scaffold-factor-rc ( -- ) + windows? "factor-rc" ".factor-rc" ? scaffold-rc ; : scaffold-emacs ( -- ) ".emacs" scaffold-rc ; From b15cf5f7ea612ec39231977ebff592aa3128d3df Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Apr 2009 19:05:57 -0500 Subject: [PATCH 382/772] fix load error --- basis/tools/scaffold/scaffold.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index d6414284b4..8bd06f48fb 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -5,7 +5,8 @@ io.encodings.utf8 hashtables kernel namespaces sequences vocabs.loader io combinators calendar accessors math.parser io.streams.string ui.tools.operations quotations strings arrays prettyprint words vocabs sorting sets classes math alien urls -splitting ascii combinators.short-circuit alarms words.symbol ; +splitting ascii combinators.short-circuit alarms words.symbol +system ; IN: tools.scaffold SYMBOL: developer-name From f22ee5ad8d936b7665c6374afe1aa7128a3106f0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Apr 2009 19:18:41 -0500 Subject: [PATCH 383/772] fix one more bug with scaffold.. --- basis/tools/scaffold/scaffold.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 8bd06f48fb..f35da24266 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -303,9 +303,9 @@ SYMBOL: examples-flag [ touch-file ] [ "Click to edit: " write . ] bi ; : scaffold-factor-boot-rc ( -- ) - windows? "factor-boot-rc" ".factor-boot-rc" ? scaffold-rc ; + os windows? "factor-boot-rc" ".factor-boot-rc" ? scaffold-rc ; : scaffold-factor-rc ( -- ) - windows? "factor-rc" ".factor-rc" ? scaffold-rc ; + os windows? "factor-rc" ".factor-rc" ? scaffold-rc ; : scaffold-emacs ( -- ) ".emacs" scaffold-rc ; From 2979360d48c2db62c3e51cecbb74f5ad07140876 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 19:52:12 -0500 Subject: [PATCH 384/772] sorting.slots: help lint --- basis/sorting/slots/slots-docs.factor | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor index 5960c451fe..beb378d4bd 100644 --- a/basis/sorting/slots/slots-docs.factor +++ b/basis/sorting/slots/slots-docs.factor @@ -6,8 +6,10 @@ IN: sorting.slots HELP: compare-slots { $values - { "sort-specs" "a sequence of accessors ending with a comparator" } - { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } } + { "obj1" object } + { "obj2" object } + { "sort-specs" "a sequence of accessors ending with a comparator" } + { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } } } { $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ; @@ -27,7 +29,7 @@ HELP: sort-by " T{ sort-me f 2 3 } T{ sort-me f 3 2 }" " T{ sort-me f 4 3 } T{ sort-me f 2 1 }" "}" - "{ { a>> <=> } { b>> >=< } } sort-by-slots ." + "{ { a>> <=> } { b>> >=< } } sort-by ." "{\n T{ sort-me { a 2 } { b 3 } }\n T{ sort-me { a 2 } { b 1 } }\n T{ sort-me { a 3 } { b 2 } }\n T{ sort-me { a 4 } { b 3 } }\n}" } } ; From 8891573a77a260c4bb4773c069e97465b478dd2f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 19:52:29 -0500 Subject: [PATCH 385/772] windows.dinput.constants: fix warnings --- .../dinput/constants/constants-tests.factor | 5 ++ .../windows/dinput/constants/constants.factor | 56 ++++++++++--------- 2 files changed, 36 insertions(+), 25 deletions(-) create mode 100644 basis/windows/dinput/constants/constants-tests.factor diff --git a/basis/windows/dinput/constants/constants-tests.factor b/basis/windows/dinput/constants/constants-tests.factor new file mode 100644 index 0000000000..67785844fa --- /dev/null +++ b/basis/windows/dinput/constants/constants-tests.factor @@ -0,0 +1,5 @@ +IN: windows.dinput.constants.tests +USING: tools.test windows.dinput.constants.private ; + +[ ] [ define-constants ] unit-test +[ ] [ free-dinput-constants ] unit-test \ No newline at end of file diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor index cd1033d418..0f95c6d683 100755 --- a/basis/windows/dinput/constants/constants.factor +++ b/basis/windows/dinput/constants/constants.factor @@ -27,12 +27,12 @@ SYMBOLS: : (flag) ( thing -- integer ) { - { [ dup word? ] [ execute ] } - { [ dup callable? ] [ call ] } + { [ dup word? ] [ execute( -- value ) ] } + { [ dup callable? ] [ call( -- value ) ] } [ ] } cond ; -: (flags) ( array -- ) +: (flags) ( array -- n ) 0 [ (flag) bitor ] reduce ; : (DIOBJECTDATAFORMAT) ( pguid dwOfs dwType dwFlags alien -- alien ) @@ -63,14 +63,16 @@ SYMBOLS: ] ; : (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien ) - [ { - [ set-DIDATAFORMAT-rgodf ] - [ set-DIDATAFORMAT-dwNumObjs ] - [ set-DIDATAFORMAT-dwDataSize ] - [ set-DIDATAFORMAT-dwFlags ] - [ set-DIDATAFORMAT-dwObjSize ] - [ set-DIDATAFORMAT-dwSize ] - } cleave ] keep ; + [ + { + [ set-DIDATAFORMAT-rgodf ] + [ set-DIDATAFORMAT-dwNumObjs ] + [ set-DIDATAFORMAT-dwDataSize ] + [ set-DIDATAFORMAT-dwFlags ] + [ set-DIDATAFORMAT-dwObjSize ] + [ set-DIDATAFORMAT-dwSize ] + } cleave + ] keep ; : ( dwFlags dwDataSize struct rgodf-array -- alien ) [ "DIDATAFORMAT" heap-size "DIOBJECTDATAFORMAT" heap-size ] 4 ndip @@ -78,9 +80,10 @@ SYMBOLS: "DIDATAFORMAT" (DIDATAFORMAT) ; : (malloc-guid-symbol) ( symbol guid -- ) - global swap '[ [ - _ execute [ byte-length malloc ] [ over byte-array>memory ] bi - ] unless* ] change-at ; + '[ + _ execute( -- value ) + [ byte-length malloc ] [ over byte-array>memory ] bi + ] initialize ; : define-guid-constants ( -- ) { @@ -105,7 +108,7 @@ SYMBOLS: } [ first2 (malloc-guid-symbol) ] each ; : define-joystick-format-constant ( -- ) - c_dfDIJoystick2 global [ [ + c_dfDIJoystick2 [ DIDF_ABSAXIS "DIJOYSTATE2" heap-size "DIJOYSTATE2" { @@ -274,10 +277,10 @@ SYMBOLS: { GUID_Slider_malloced "rglFSlider" 0 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } DIDOI_ASPECTFORCE } { GUID_Slider_malloced "rglFSlider" 1 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } DIDOI_ASPECTFORCE } } - ] unless* ] change-at ; + ] initialize ; : define-mouse-format-constant ( -- ) - c_dfDIMouse2 global [ [ + c_dfDIMouse2 [ DIDF_RELAXIS "DIMOUSESTATE2" heap-size "DIMOUSESTATE2" { @@ -293,13 +296,13 @@ SYMBOLS: { GUID_Button_malloced "rgbButtons" 6 { DIDFT_OPTIONAL DIDFT_ANYINSTANCE DIDFT_BUTTON } 0 } { GUID_Button_malloced "rgbButtons" 7 { DIDFT_OPTIONAL DIDFT_ANYINSTANCE DIDFT_BUTTON } 0 } } - ] unless* ] change-at ; + ] initialize ; ! Not a standard DirectInput format. Included for cross-platform niceness. ! This format returns the keyboard keys in USB HID order rather than Windows ! order : define-hid-keyboard-format-constant ( -- ) - c_dfDIKeyboard_HID global [ [ + c_dfDIKeyboard_HID [ DIDF_RELAXIS 256 f { @@ -560,10 +563,10 @@ SYMBOLS: { GUID_Key_malloced f 254 { DIDFT_OPTIONAL DIDFT_BUTTON [ 0 DIDFT_MAKEINSTANCE ] } 0 } { GUID_Key_malloced f 255 { DIDFT_OPTIONAL DIDFT_BUTTON [ 0 DIDFT_MAKEINSTANCE ] } 0 } } - ] unless* ] change-at ; + ] initialize ; : define-keyboard-format-constant ( -- ) - c_dfDIKeyboard global [ [ + c_dfDIKeyboard [ DIDF_RELAXIS 256 f { @@ -824,7 +827,7 @@ SYMBOLS: { GUID_Key_malloced f 254 { DIDFT_OPTIONAL DIDFT_BUTTON [ 254 DIDFT_MAKEINSTANCE ] } 0 } { GUID_Key_malloced f 255 { DIDFT_OPTIONAL DIDFT_BUTTON [ 255 DIDFT_MAKEINSTANCE ] } 0 } } - ] unless* ] change-at ; + ] initialize ; : define-format-constants ( -- ) define-joystick-format-constant @@ -837,7 +840,9 @@ SYMBOLS: define-format-constants ; [ define-constants ] "windows.dinput.constants" add-init-hook -define-constants + +: uninitialize ( variable quot -- ) + [ global ] dip '[ _ when* f ] change-at ; inline : free-dinput-constants ( -- ) { @@ -846,10 +851,11 @@ define-constants GUID_Slider_malloced GUID_Button_malloced GUID_Key_malloced GUID_POV_malloced GUID_Unknown_malloced GUID_SysMouse_malloced GUID_SysKeyboard_malloced GUID_Joystick_malloced GUID_SysMouseEm_malloced GUID_SysMouseEm2_malloced GUID_SysKeyboardEm_malloced GUID_SysKeyboardEm2_malloced - } [ global [ [ free ] when* f ] change-at ] each + } [ [ free ] uninitialize ] each + { c_dfDIKeyboard c_dfDIKeyboard_HID c_dfDIMouse2 c_dfDIJoystick2 - } [ global [ [ DIDATAFORMAT-rgodf free ] when* f ] change-at ] each ; + } [ [ DIDATAFORMAT-rgodf free ] uninitialize ] each ; PRIVATE> From 54f82be4e0553f5c43dad5f658ede99d11870245 Mon Sep 17 00:00:00 2001 From: Alec Berryman Date: Sat, 18 Apr 2009 22:28:57 -0400 Subject: [PATCH 386/772] fuel: fix usage of (fuel-eval) It used to take a string, but now takes a sequence of strings. --- extra/fuel/eval/eval.factor | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/extra/fuel/eval/eval.factor b/extra/fuel/eval/eval.factor index ae1c5863a8..019b9105bc 100644 --- a/extra/fuel/eval/eval.factor +++ b/extra/fuel/eval/eval.factor @@ -59,17 +59,14 @@ t fuel-eval-res-flag set-global [ [ parse-lines ] with-compilation-unit call( -- ) ] curry [ print-error ] recover ; -: (fuel-eval-each) ( lines -- ) - [ (fuel-eval) ] each ; - : (fuel-eval-usings) ( usings -- ) [ "USE: " prepend ] map - (fuel-eval-each) fuel-forget-error fuel-forget-output ; + (fuel-eval) fuel-forget-error fuel-forget-output ; : (fuel-eval-in) ( in -- ) - [ dup "IN: " prepend (fuel-eval) in set ] when* ; + [ dup "IN: " prepend 1array (fuel-eval) in set ] when* ; : (fuel-eval-in-context) ( lines in usings -- ) (fuel-begin-eval) - [ (fuel-eval-usings) (fuel-eval-in) "\n" join (fuel-eval) ] with-string-writer + [ (fuel-eval-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer (fuel-end-eval) ; From 1c123e7e22f84e7c8eeb0d58e3b7cb54efcdef8d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Apr 2009 21:53:22 -0500 Subject: [PATCH 387/772] Remove some usages of -rot and tuck --- basis/hash2/hash2-tests.factor | 6 ++-- basis/hash2/hash2.factor | 12 ++++--- .../launcher/unix/parser/parser-tests.factor | 14 ++++---- basis/io/launcher/unix/parser/parser.factor | 34 +++++-------------- basis/io/sockets/sockets.factor | 2 +- basis/lists/lists.factor | 3 +- basis/match/match.factor | 3 +- basis/smtp/smtp.factor | 7 ++-- basis/tools/completion/completion.factor | 16 ++++----- basis/ui/gadgets/gadgets.factor | 6 ++-- 10 files changed, 44 insertions(+), 59 deletions(-) diff --git a/basis/hash2/hash2-tests.factor b/basis/hash2/hash2-tests.factor index 15bbcb36ef..682680bc50 100644 --- a/basis/hash2/hash2-tests.factor +++ b/basis/hash2/hash2-tests.factor @@ -6,9 +6,9 @@ IN: hash2.tests : sample-hash ( -- hash ) 5 - dup 2 3 "foo" roll set-hash2 - dup 4 2 "bar" roll set-hash2 - dup 4 7 "other" roll set-hash2 ; + [ [ 2 3 "foo" ] dip set-hash2 ] keep + [ [ 4 2 "bar" ] dip set-hash2 ] keep + [ [ 4 7 "other" ] dip set-hash2 ] keep ; [ "foo" ] [ 2 3 sample-hash hash2 ] unit-test [ "bar" ] [ 4 2 sample-hash hash2 ] unit-test diff --git a/basis/hash2/hash2.factor b/basis/hash2/hash2.factor index ffe6926130..aadc0d45a2 100644 --- a/basis/hash2/hash2.factor +++ b/basis/hash2/hash2.factor @@ -1,4 +1,6 @@ -USING: kernel sequences arrays math vectors ; +! Copyright (C) 2007 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences arrays math vectors locals ; IN: hash2 ! Little ad-hoc datastructure used to map two numbers @@ -22,8 +24,8 @@ IN: hash2 : assoc2 ( a b alist -- value ) (assoc2) dup [ third ] when ; inline -: set-assoc2 ( value a b alist -- alist ) - [ rot 3array ] dip ?push ; inline +:: set-assoc2 ( value a b alist -- alist ) + { a b value } alist ?push ; inline : hash2@ ( a b hash2 -- a b bucket hash2 ) [ 2dup hashcode2 ] dip [ length mod ] keep ; inline @@ -31,8 +33,8 @@ IN: hash2 : hash2 ( a b hash2 -- value/f ) hash2@ nth dup [ assoc2 ] [ 3drop f ] if ; -: set-hash2 ( a b value hash2 -- ) - [ -rot ] dip hash2@ [ set-assoc2 ] change-nth ; +:: set-hash2 ( a b value hash2 -- ) + value a b hash2 hash2@ [ set-assoc2 ] change-nth ; : alist>hash2 ( alist size -- hash2 ) [ over [ first3 ] dip set-hash2 ] reduce ; inline diff --git a/basis/io/launcher/unix/parser/parser-tests.factor b/basis/io/launcher/unix/parser/parser-tests.factor index 07502e87a4..90504ccac2 100644 --- a/basis/io/launcher/unix/parser/parser-tests.factor +++ b/basis/io/launcher/unix/parser/parser-tests.factor @@ -10,13 +10,13 @@ USING: io.launcher.unix.parser tools.test ; [ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test [ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test [ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test -[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test -[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test -[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test -[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test -[ "'abc def' \"hey" tokenize-command ] must-fail -[ "'abc def" tokenize-command ] must-fail -[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test +[ V{ "abc\\ def" } ] [ "\"abc\\\\ def\"" tokenize-command ] unit-test +[ V{ "abc\\ def" } ] [ " \"abc\\\\ def\"" tokenize-command ] unit-test +[ V{ "abc\\ def" "hey" } ] [ "\"abc\\\\ def\" hey" tokenize-command ] unit-test +[ V{ "abc def" "hey" } ] [ "\"abc def\" \"hey\"" tokenize-command ] unit-test +[ "\"abc def\" \"hey" tokenize-command ] must-fail +[ "\"abc def" tokenize-command ] must-fail +[ V{ "abc def" "h\"ey" } ] [ "\"abc def\" \"h\\\"ey\" " tokenize-command ] unit-test [ V{ diff --git a/basis/io/launcher/unix/parser/parser.factor b/basis/io/launcher/unix/parser/parser.factor index 97e6dee95f..bcc5f965e9 100644 --- a/basis/io/launcher/unix/parser/parser.factor +++ b/basis/io/launcher/unix/parser/parser.factor @@ -1,33 +1,17 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: peg peg.parsers kernel sequences strings words ; +USING: peg peg.ebnf arrays sequences strings kernel ; IN: io.launcher.unix.parser ! Our command line parser. Supported syntax: ! foo bar baz -- simple tokens ! foo\ bar -- escaping the space -! 'foo bar' -- quotation ! "foo bar" -- quotation -: 'escaped-char' ( -- parser ) - "\\" token any-char 2seq [ second ] action ; - -: 'quoted-char' ( delimiter -- parser' ) - 'escaped-char' - swap [ member? not ] curry satisfy - 2choice ; inline - -: 'quoted' ( delimiter -- parser ) - dup 'quoted-char' repeat0 swap dup surrounded-by ; - -: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ; - -: 'argument' ( -- parser ) - "\"" 'quoted' - "'" 'quoted' - 'unquoted' 3choice - [ >string ] action ; - -PEG: tokenize-command ( command -- ast/f ) - 'argument' " " token repeat1 list-of - " " token repeat0 tuck pack - just ; +EBNF: tokenize-command +space = " " +escaped-char = "\" .:ch => [[ ch ]] +quoted = '"' (escaped-char | [^"])*:a '"' => [[ a ]] +unquoted = (escaped-char | [^ "])+ +argument = (quoted | unquoted) => [[ >string ]] +command = space* (argument:a space* => [[ a ]])+:c !(.) => [[ c ]] +;EBNF diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 8dce527553..a0beb1f421 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -192,7 +192,7 @@ M: object (client) ( remote -- client-in client-out local ) ] with-destructors ; : ( remote encoding -- stream local ) - [ (client) -rot ] dip swap ; + [ (client) ] dip swap [ ] dip ; SYMBOL: local-address diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 4b0abb7f2d..fecb76f1c0 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -106,7 +106,8 @@ PRIVATE> : deep-sequence>cons ( sequence -- cons ) [ ] keep nil - [ tuck same? [ deep-sequence>cons ] when swons ] with reduce ; + [ [ nip ] [ same? ] 2bi [ deep-sequence>cons ] when swons ] + with reduce ; vector) ( acc list quot: ( elt -- elt' ) -- acc ) diff --git a/basis/match/match.factor b/basis/match/match.factor index b21d8c6d73..ec0cb8c9e6 100644 --- a/basis/match/match.factor +++ b/basis/match/match.factor @@ -62,8 +62,7 @@ MACRO: match-cond ( assoc -- ) } cond ; : match-replace ( object pattern1 pattern2 -- result ) - -rot - match [ "Pattern does not match" throw ] unless* + [ match [ "Pattern does not match" throw ] unless* ] dip swap [ replace-patterns ] bind ; : ?1-tail ( seq -- tail/f ) diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 822fc92090..605423820b 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -164,9 +164,8 @@ M: plain-auth send-auth : encode-header ( string -- string' ) dup aux>> [ - "=?utf-8?B?" - swap utf8 encode >base64 - "?=" 3append + utf8 encode >base64 + "=?utf-8?B?" "?=" surround ] when ; ERROR: invalid-header-string string ; @@ -205,7 +204,7 @@ ERROR: invalid-header-string string ; now timestamp>rfc822 "Date" set message-id "Message-Id" set "1.0" "MIME-Version" set - "base64" "Content-Transfer-Encoding" set + "quoted-printable" "Content-Transfer-Encoding" set { [ from>> "From" set ] [ to>> ", " join "To" set ] diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index 14cec8e85f..99def097a2 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -3,20 +3,20 @@ USING: accessors kernel arrays sequences math namespaces strings io fry vectors words assocs combinators sorting unicode.case unicode.categories math.order vocabs -tools.vocabs unicode.data ; +tools.vocabs unicode.data locals ; IN: tools.completion -: (fuzzy) ( accum ch i full -- accum i ? ) - index-from - [ - [ swap push ] 2keep 1+ t +:: (fuzzy) ( accum i full ch -- accum i full ? ) + ch i full index-from [ + :> i i accum push + accum i 1+ full t ] [ - drop f -1 f + f -1 full f ] if* ; : fuzzy ( full short -- indices ) - dup length -rot 0 -rot - [ -rot [ (fuzzy) ] keep swap ] all? 3drop ; + dup [ length 0 ] curry 2dip + [ (fuzzy) ] all? 3drop ; : (runs) ( runs n seq -- runs n ) [ diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index bc07006d62..32d6c0c8a6 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -3,7 +3,7 @@ USING: accessors arrays hashtables kernel models math namespaces make sequences quotations math.vectors combinators sorting binary-search vectors dlists deques models threads -concurrency.flags math.order math.rectangles fry ; +concurrency.flags math.order math.rectangles fry locals ; IN: ui.gadgets ! Values for orientation slot @@ -66,8 +66,8 @@ M: gadget children-on nip children>> ; : ((fast-children-on)) ( gadget dim axis -- <=> ) [ swap loc>> v- ] dip v. 0 <=> ; -: (fast-children-on) ( dim axis children -- i ) - -rot '[ _ _ ((fast-children-on)) ] search drop ; +:: (fast-children-on) ( dim axis children -- i ) + children [ dim axis ((fast-children-on)) ] search drop ; PRIVATE> From 47820bda51f4edfc212c5593b78ad57bf2f57241 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Apr 2009 03:04:35 -0500 Subject: [PATCH 388/772] Oops --- basis/smtp/smtp.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 605423820b..bfba9ea28a 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -204,7 +204,7 @@ ERROR: invalid-header-string string ; now timestamp>rfc822 "Date" set message-id "Message-Id" set "1.0" "MIME-Version" set - "quoted-printable" "Content-Transfer-Encoding" set + "base64" "Content-Transfer-Encoding" set { [ from>> "From" set ] [ to>> ", " join "To" set ] From 97b19ff0254aa21bff39cd99ec0a006e11e84f95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Apr 2009 03:04:41 -0500 Subject: [PATCH 389/772] Fix typo in ui.text docs --- basis/ui/text/text-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/text/text-docs.factor b/basis/ui/text/text-docs.factor index 4ac2fbbaa8..c2732754f6 100644 --- a/basis/ui/text/text-docs.factor +++ b/basis/ui/text/text-docs.factor @@ -46,7 +46,7 @@ HELP: offset>x HELP: line-metrics { $values { "font" font } { "string" string } { "metrics" line-metrics } } -{ $contract "Outputs a " { $link line-metrics } " object with text measurements." } ; +{ $contract "Outputs a " { $link metrics } " object with text measurements." } ; ARTICLE: "text-rendering" "Rendering text" "The " { $vocab-link "ui.text" } " vocabulary provides a cross-platform interface to the operating system's native font rendering engine. Currently, it uses Core Text on Mac OS X and FreeType on Windows and X11." From 3148429e0c44a4b71bb5985adfb770bb40d530f5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Apr 2009 03:06:05 -0500 Subject: [PATCH 390/772] Fix texture resizing on S3 hardware on Windows. Reported by Kobi Lurie --- basis/opengl/textures/textures.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index 6bed17f7ab..d103e90bee 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -45,7 +45,7 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed : adjust-texture-dim ( dim -- dim' ) non-power-of-2-textures? get [ - [ next-power-of-2 ] map + [ dup 1 = [ next-power-of-2 ] unless ] map ] unless ; : (tex-image) ( image bitmap -- ) From e4ce05f73bdfcdfa2f9fc1b13eeb0a9e1b3f215e Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 19 Apr 2009 13:01:02 -0400 Subject: [PATCH 391/772] Additional solution to PE problem 1 from IRC --- extra/project-euler/001/001-tests.factor | 1 + extra/project-euler/001/001.factor | 16 ++++++++++++---- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/extra/project-euler/001/001-tests.factor b/extra/project-euler/001/001-tests.factor index 1cab275619..32a72dfaf0 100644 --- a/extra/project-euler/001/001-tests.factor +++ b/extra/project-euler/001/001-tests.factor @@ -5,3 +5,4 @@ IN: project-euler.001.tests [ 233168 ] [ euler001a ] unit-test [ 233168 ] [ euler001b ] unit-test [ 233168 ] [ euler001c ] unit-test +[ 233168 ] [ euler001d ] unit-test diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor index 20e08242c5..0d4f5fb1bd 100644 --- a/extra/project-euler/001/001.factor +++ b/extra/project-euler/001/001.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions math.ranges sequences project-euler.common ; +USING: kernel math math.functions math.ranges project-euler.common sequences + sets ; IN: project-euler.001 ! http://projecteuler.net/index.php?section=problems&id=1 @@ -32,7 +33,7 @@ PRIVATE> 999 15 sum-divisible-by - ; ! [ euler001 ] 100 ave-time -! 0 ms run / 0 ms GC ave time - 100 trials +! 0 ms ave run time - 0.0 SD (100 trials) ! ALTERNATE SOLUTIONS @@ -42,14 +43,14 @@ PRIVATE> 0 999 3 sum 0 999 5 sum + 0 999 15 sum - ; ! [ euler001a ] 100 ave-time -! 0 ms run / 0 ms GC ave time - 100 trials +! 0 ms ave run time - 0.03 SD (100 trials) : euler001b ( -- answer ) 1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ; ! [ euler001b ] 100 ave-time -! 0 ms run / 0 ms GC ave time - 100 trials +! 0 ms ave run time - 0.06 SD (100 trials) : euler001c ( -- answer ) @@ -58,4 +59,11 @@ PRIVATE> ! [ euler001c ] 100 ave-time ! 0 ms ave run time - 0.06 SD (100 trials) + +: euler001d ( -- answer ) + { 3 5 } [ [ 999 ] keep ] gather sum ; + +! [ euler001d ] 100 ave-time +! 0 ms ave run time - 0.08 SD (100 trials) + SOLUTION: euler001 From 425be6a414306d6f6b1bb95ce3ae2cd40995c2ac Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sun, 19 Apr 2009 20:35:54 +0200 Subject: [PATCH 392/772] FUEL: modify directly use/in to set up evaluation context --- extra/fuel/eval/eval.factor | 8 ++++---- misc/fuel/fuel-connection.el | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/fuel/eval/eval.factor b/extra/fuel/eval/eval.factor index ae1c5863a8..26d3999380 100644 --- a/extra/fuel/eval/eval.factor +++ b/extra/fuel/eval/eval.factor @@ -63,13 +63,13 @@ t fuel-eval-res-flag set-global [ (fuel-eval) ] each ; : (fuel-eval-usings) ( usings -- ) - [ "USE: " prepend ] map - (fuel-eval-each) fuel-forget-error fuel-forget-output ; + [ [ use+ ] curry [ drop ] recover ] each + fuel-forget-error fuel-forget-output ; : (fuel-eval-in) ( in -- ) - [ dup "IN: " prepend (fuel-eval) in set ] when* ; + [ in set ] when* ; : (fuel-eval-in-context) ( lines in usings -- ) (fuel-begin-eval) - [ (fuel-eval-usings) (fuel-eval-in) "\n" join (fuel-eval) ] with-string-writer + [ (fuel-eval-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer (fuel-end-eval) ; diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el index f180d0f2b4..ef39b7af65 100644 --- a/misc/fuel/fuel-connection.el +++ b/misc/fuel/fuel-connection.el @@ -164,7 +164,7 @@ (fuel-con--send-string/wait buffer fuel-con--init-stanza 'fuel-con--establish-connection-cont - 60000) + 3000000) conn)) (defun fuel-con--establish-connection-cont (ignore) From af7ecb16cfd617c78c4987895b96a52328879f27 Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Sun, 19 Apr 2009 14:52:24 -0700 Subject: [PATCH 393/772] Determine restart vocab thru obj>> instead of error string --- extra/fuel/fuel.factor | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 3c623212b0..12eb5bdbfc 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs compiler.units continuations fuel.eval fuel.help -fuel.remote fuel.xref help.topics io.pathnames kernel math namespaces parser -sequences tools.scaffold vocabs.loader ; +fuel.remote fuel.xref help.topics io.pathnames kernel namespaces parser +sequences tools.scaffold vocabs.loader words ; IN: fuel @@ -33,10 +33,8 @@ SYMBOL: :uses-suggestions : is-use-restart ( restart -- ? ) name>> [ "Use the " head? ] [ " vocabulary" tail? ] bi and ; -: get-restart-vocab ( restart -- vocab ) - [ "Use the " length ] dip - name>> [ length " vocabulary" length - ] keep - subseq ; +: get-restart-vocab ( restart -- vocab/f ) + obj>> dup word? [ vocabulary>> ] [ drop f ] if ; : is-suggested-restart ( restart -- ? ) dup is-use-restart [ @@ -56,9 +54,9 @@ SYMBOL: :uses-suggestions PRIVATE> -: fuel-use-suggested-vocabs ( ... suggestions quot: ( ... -- ... ) -- ... ) +: fuel-use-suggested-vocabs ( suggestions quot ... suggestions quot: ( ... -- ... ) -- ... ) [ :uses-suggestions set ] dip - [ try-suggested-restarts rethrow ] recover ; + [ try-suggested-restarts rethrow ] recover ; inline : fuel-run-file ( path -- ) [ fuel-set-use-hook run-file ] curry with-scope ; inline From d039f9a946dfc414213e7dd297f5dc47708cfa95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Apr 2009 17:38:20 -0500 Subject: [PATCH 394/772] help.handbook: fix typos reported by Jon Kleiser --- basis/help/handbook/handbook.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index ebce042e06..1aac99defe 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -13,13 +13,13 @@ ARTICLE: "conventions" "Conventions" { $heading "Documentation conventions" } "Factor documentation consists of two distinct bodies of text. There is a hierarchy of articles, much like this one, and there is word documentation. Help articles reference word documentation, and vice versa, but not every documented word is referenced from some help article." $nl -"Every article has links to parent articles at the top. These can be persued if the article is too specific." +"Every article has links to parent articles at the top. Explore these if the article you are reading is too specific." $nl "Some generic words have " { $strong "Description" } " headings, and others have " { $strong "Contract" } " headings. A distinction is made between words which are not intended to be extended with user-defined methods, and those that are." { $heading "Vocabulary naming conventions" } "A vocabulary name ending in " { $snippet ".private" } " contains words which are either implementation detail, unsafe, or both. For example, the " { $snippet "sequence.private" } " vocabulary contains words which access sequence elements without bounds checking (" { $link "sequences-unsafe" } ")." $nl -"You should should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason." +"You should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason." { $heading "Word naming conventions" } "These conventions are not hard and fast, but are usually a good first step in understanding a word's behavior:" { $table From d3d131d1bda39f6405d806dcfd6278d8e16fb697 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Apr 2009 17:38:48 -0500 Subject: [PATCH 395/772] Strip out error-list related global variables; webkit-demo 14kb smaller --- basis/tools/deploy/shaker/shaker.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 37eec5eae2..ba0daf6056 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -15,6 +15,7 @@ QUALIFIED: definitions QUALIFIED: init QUALIFIED: layouts QUALIFIED: source-files +QUALIFIED: source-files.errors QUALIFIED: vocabs IN: tools.deploy.shaker @@ -264,6 +265,7 @@ IN: tools.deploy.shaker compiled-crossref compiled-generic-crossref compiler-impl + compiler.errors:compiler-errors definition-observers definitions:crossref interactive-vocabs @@ -275,6 +277,7 @@ IN: tools.deploy.shaker lexer-factory print-use-hook root-cache + source-files.errors:error-types vocabs:dictionary vocabs:load-vocab-hook word From 27928f5f8f9b45e40a9d111212e9f2251f32cfce Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Apr 2009 17:39:26 -0500 Subject: [PATCH 396/772] Make couchdb unportable for now --- extra/couchdb/tags.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 extra/couchdb/tags.txt diff --git a/extra/couchdb/tags.txt b/extra/couchdb/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/couchdb/tags.txt @@ -0,0 +1 @@ +unportable From 57d718113e8661c509151336ddb8747eb02d3305 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Apr 2009 18:21:25 -0500 Subject: [PATCH 397/772] tools.test: more robust must-fail --- basis/tools/test/test-tests.factor | 16 +++++++++++++++- basis/tools/test/test.factor | 12 ++++++------ 2 files changed, 21 insertions(+), 7 deletions(-) diff --git a/basis/tools/test/test-tests.factor b/basis/tools/test/test-tests.factor index 473335645f..03f7f006c9 100644 --- a/basis/tools/test/test-tests.factor +++ b/basis/tools/test/test-tests.factor @@ -1,4 +1,18 @@ IN: tools.test.tests -USING: tools.test ; +USING: tools.test tools.test.private namespaces kernel sequences ; \ test-all must-infer + +: fake-unit-test ( quot -- ) + [ + "fake" file set + V{ } clone test-failures set + call + test-failures get + ] with-scope ; inline + +[ 1 ] [ + [ + [ "OOPS" ] must-fail + ] fake-unit-test length +] unit-test \ No newline at end of file diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index b98f58b143..1ff47e3d7f 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -48,17 +48,17 @@ SYMBOL: file f file get f failure ; :: (unit-test) ( output input -- error ? ) - [ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; inline + [ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; : short-effect ( effect -- pair ) [ in>> length ] [ out>> length ] bi 2array ; :: (must-infer-as) ( effect quot -- error ? ) - [ quot infer short-effect effect assert= f f ] [ t ] recover ; inline + [ quot infer short-effect effect assert= f f ] [ t ] recover ; :: (must-infer) ( word/quot -- error ? ) word/quot dup word? [ '[ _ execute ] ] when :> quot - [ quot infer drop f f ] [ t ] recover ; inline + [ quot infer drop f f ] [ t ] recover ; TUPLE: did-not-fail ; CONSTANT: did-not-fail T{ did-not-fail } @@ -66,11 +66,11 @@ CONSTANT: did-not-fail T{ did-not-fail } M: did-not-fail summary drop "Did not fail" ; :: (must-fail-with) ( quot pred -- error ? ) - [ quot call did-not-fail t ] - [ dup pred call [ drop f f ] [ t ] if ] recover ; inline + [ { } quot with-datastack drop did-not-fail t ] + [ dup pred call( error -- ? ) [ drop f f ] [ t ] if ] recover ; :: (must-fail) ( quot -- error ? ) - [ quot call did-not-fail t ] [ drop f f ] recover ; inline + [ { } quot with-datastack drop did-not-fail t ] [ drop f f ] recover ; : experiment-title ( word -- string ) "(" ?head drop ")" ?tail drop { { CHAR: - CHAR: \s } } substitute >title ; From 0719d8365337981d4ee2cc9c5f26be2fe023084d Mon Sep 17 00:00:00 2001 From: Elliott Hird Date: Mon, 20 Apr 2009 01:28:41 +0100 Subject: [PATCH 398/772] Show the signal name next to the number in parentheses on Unices. --- basis/debugger/debugger.factor | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 49ec534e8f..64bac3ecee 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -88,8 +88,27 @@ M: string error. print ; : divide-by-zero-error. ( obj -- ) "Division by zero" print drop ; +CONSTANT: signal-names +{ + "SIGHUP" "SIGINT" "SIGQUIT" "SIGILL" "SIGTRAP" "SIGABRT" + "SIGEMT" "SIGFPE" "SIGKILL" "SIGBUS" "SIGSEGV" "SIGSYS" + "SIGPIPE" "SIGALRM" "SIGTERM" "SIGURG" "SIGSTOP" "SIGTSIP" + "SIGCONT" "SIGCHLD" "SIGTTIN" "SIGTTOU" "SIGIO" "SIGXCPU" + "SIGXFSZ" "SIGVTALRM" "SIGPROF" "SIGWINCH" "SIGINFO" + "SIGUSR1" "SIGUSR2" +} + +: signal-name ( n -- str ) + 1- signal-names nth; + +: signal-name. ( n -- ) + dup signal-names length <= + os unix? and + [ " (" write signal-name write ")" write ] [ drop ] if ; + : signal-error. ( obj -- ) - "Operating system signal " write third . ; + "Operating system signal " write + third [ pprint ] [ signal-name. ] bi nl ; : array-size-error. ( obj -- ) "Invalid array size: " write dup third . From 0f82f4af8709cf85329863f31712c72963db8a5d Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 20 Apr 2009 11:00:38 +1000 Subject: [PATCH 399/772] Merging Diego Martinelli's improvements and simplifications of morse --- extra/morse/authors.txt | 1 + extra/morse/morse-docs.factor | 4 +- extra/morse/morse-tests.factor | 34 +++++- extra/morse/morse.factor | 208 ++++++++++++++++----------------- 4 files changed, 134 insertions(+), 113 deletions(-) diff --git a/extra/morse/authors.txt b/extra/morse/authors.txt index e9c193bac7..409f0443a6 100644 --- a/extra/morse/authors.txt +++ b/extra/morse/authors.txt @@ -1 +1,2 @@ Alex Chapman +Diego Martinelli diff --git a/extra/morse/morse-docs.factor b/extra/morse/morse-docs.factor index e35967d3e9..93350ad02d 100644 --- a/extra/morse/morse-docs.factor +++ b/extra/morse/morse-docs.factor @@ -6,12 +6,12 @@ IN: morse HELP: ch>morse { $values { "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } } -{ $description "If the given character has a morse code translation, then return that translation, otherwise return an empty string." } ; +{ $description "If the given character has a morse code translation, then return that translation, otherwise return a ? character." } ; HELP: morse>ch { $values { "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } } -{ $description "If the given string represents a morse code character, then return that character, otherwise return f" } ; +{ $description "If the given string represents a morse code character, then return that character, otherwise return a space character." } ; HELP: >morse { $values diff --git a/extra/morse/morse-tests.factor b/extra/morse/morse-tests.factor index 144448917f..fd52df1c4d 100644 --- a/extra/morse/morse-tests.factor +++ b/extra/morse/morse-tests.factor @@ -1,13 +1,43 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. USING: arrays morse strings tools.test ; +IN: morse.tests -[ "" ] [ CHAR: \\ ch>morse ] unit-test +[ CHAR: ? ] [ CHAR: \\ ch>morse ] unit-test [ "..." ] [ CHAR: s ch>morse ] unit-test [ CHAR: s ] [ "..." morse>ch ] unit-test -[ f ] [ "..--..--.." morse>ch ] unit-test +[ CHAR: \s ] [ "..--..--.." morse>ch ] unit-test [ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test [ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test [ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test +[ ".- -... -.-." ] [ "abc" >morse ] unit-test + +[ "abc" ] [ ".- -... -.-." morse> ] unit-test + +[ "morse code" ] [ + [MORSE + -- --- .-. ... . / + -.-. --- -.. . + MORSE] >morse morse> ] unit-test + +[ "morse code 123" ] [ + [MORSE + __ ___ ._. ... . / + _._. ___ _.. . / + .____ ..___ ...__ + MORSE] ] unit-test + +[ [MORSE + -- --- .-. ... . / + -.-. --- -.. . + MORSE] ] [ + "morse code" >morse morse> +] unit-test + +[ "factor rocks!" ] [ + [MORSE + ..-. .- -.-. - --- .-. / + .-. --- -.-. -.- ... -.-.-- + MORSE] ] unit-test ! [ ] [ "sos" 0.075 play-as-morse* ] unit-test ! [ ] [ "Factor rocks!" play-as-morse ] unit-test diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index 54abce9395..49e6ae39f5 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -1,130 +1,120 @@ -! Copyright (C) 2007, 2008 Alex Chapman +! Copyright (C) 2007, 2008, 2009 Alex Chapman, 2009 Diego Martinelli ! See http://factorcode.org/license.txt for BSD license. -USING: accessors ascii assocs combinators hashtables kernel lists math -namespaces make openal parser-combinators promises sequences -strings synth synth.buffers unicode.case ; +USING: accessors ascii assocs biassocs combinators hashtables kernel lists math +namespaces make multiline openal parser sequences splitting strings synth synth.buffers ; IN: morse morse-assoc ( -- assoc ) - morse-codes >hashtable ; - -: morse>ch-assoc ( -- assoc ) - morse-codes [ reverse ] map >hashtable ; +CONSTANT: dot-char CHAR: . +CONSTANT: dash-char CHAR: - +CONSTANT: char-gap-char CHAR: \s +CONSTANT: word-gap-char CHAR: / +CONSTANT: unknown-char CHAR: ? PRIVATE> -: ch>morse ( ch -- str ) - ch>lower ch>morse-assoc at* swap "" ? ; +DEFER: morse-code-table + +H{ + { CHAR: a ".-" } + { CHAR: b "-..." } + { CHAR: c "-.-." } + { CHAR: d "-.." } + { CHAR: e "." } + { CHAR: f "..-." } + { CHAR: g "--." } + { CHAR: h "...." } + { CHAR: i ".." } + { CHAR: j ".---" } + { CHAR: k "-.-" } + { CHAR: l ".-.." } + { CHAR: m "--" } + { CHAR: n "-." } + { CHAR: o "---" } + { CHAR: p ".--." } + { CHAR: q "--.-" } + { CHAR: r ".-." } + { CHAR: s "..." } + { CHAR: t "-" } + { CHAR: u "..-" } + { CHAR: v "...-" } + { CHAR: w ".--" } + { CHAR: x "-..-" } + { CHAR: y "-.--" } + { CHAR: z "--.." } + { CHAR: 1 ".----" } + { CHAR: 2 "..---" } + { CHAR: 3 "...--" } + { CHAR: 4 "....-" } + { CHAR: 5 "....." } + { CHAR: 6 "-...." } + { CHAR: 7 "--..." } + { CHAR: 8 "---.." } + { CHAR: 9 "----." } + { CHAR: 0 "-----" } + { CHAR: . ".-.-.-" } + { CHAR: , "--..--" } + { CHAR: ? "..--.." } + { CHAR: ' ".----." } + { CHAR: ! "-.-.--" } + { CHAR: / "-..-." } + { CHAR: ( "-.--." } + { CHAR: ) "-.--.-" } + { CHAR: & ".-..." } + { CHAR: : "---..." } + { CHAR: ; "-.-.-." } + { CHAR: = "-...- " } + { CHAR: + ".-.-." } + { CHAR: - "-....-" } + { CHAR: _ "..--.-" } + { CHAR: " ".-..-." } + { CHAR: $ "...-..-" } + { CHAR: @ ".--.-." } + { CHAR: \s "/" } +} >biassoc \ morse-code-table set-global + +: morse-code-table ( -- biassoc ) + \ morse-code-table get-global ; + +: ch>morse ( ch -- morse ) + ch>lower morse-code-table at [ unknown-char ] unless* ; : morse>ch ( str -- ch ) - morse>ch-assoc at* swap f ? ; - -: >morse ( str -- str ) - [ - [ CHAR: \s , ] [ ch>morse % ] interleave - ] "" make ; - + morse-code-table value-at [ char-gap-char ] unless* ; + morse ( str -- morse ) + [ ch>morse ] { } map-as " " join ; -: dot-char ( -- ch ) CHAR: . ; -: dash-char ( -- ch ) CHAR: - ; -: char-gap-char ( -- ch ) CHAR: \s ; -: word-gap-char ( -- ch ) CHAR: / ; +: sentence>morse ( str -- morse ) + " " split [ word>morse ] map " / " join ; + +: trim-blanks ( str -- newstr ) + [ blank? ] trim ; inline -: =parser ( obj -- parser ) - [ = ] curry satisfy ; +: morse>word ( morse -- str ) + " " split [ morse>ch ] "" map-as ; -LAZY: 'dot' ( -- parser ) - dot-char =parser ; +: morse>sentence ( morse -- sentence ) + "/" split [ trim-blanks morse>word ] map " " join ; -LAZY: 'dash' ( -- parser ) - dash-char =parser ; - -LAZY: 'char-gap' ( -- parser ) - char-gap-char =parser ; - -LAZY: 'word-gap' ( -- parser ) - word-gap-char =parser ; - -LAZY: 'morse-char' ( -- parser ) - 'dot' 'dash' <|> <+> ; - -LAZY: 'morse-word' ( -- parser ) - 'morse-char' 'char-gap' list-of ; - -LAZY: 'morse-words' ( -- parser ) - 'morse-word' 'word-gap' list-of ; +: replace-underscores ( str -- str' ) + [ dup CHAR: _ = [ drop CHAR: - ] when ] map ; PRIVATE> + +: >morse ( str -- newstr ) + trim-blanks sentence>morse ; + +: morse> ( morse -- plain ) + replace-underscores morse>sentence ; -: morse> ( str -- str ) - 'morse-words' parse car parsed>> [ - [ - >string morse>ch - ] map >string - ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ; - +SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> parsed ; + ( -- buffer ) half-sample-freq <8bit-mono-buffer> ; From 616996ab6a77b614538b0ccd09dd179306e09d6c Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 20 Apr 2009 12:20:03 +1000 Subject: [PATCH 400/772] Updating code to use CONSTANT: --- extra/jamshred/game/game.factor | 2 +- extra/jamshred/gl/gl.factor | 15 +++++++-------- extra/jamshred/jamshred.factor | 4 ++-- extra/jamshred/player/player.factor | 4 ++-- extra/jamshred/tunnel/tunnel.factor | 12 +++++++----- extra/synth/buffers/buffers.factor | 10 +++++----- 6 files changed, 24 insertions(+), 23 deletions(-) diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor index 9cb5bc7c3a..14bf18a9c1 100644 --- a/extra/jamshred/game/game.factor +++ b/extra/jamshred/game/game.factor @@ -29,7 +29,7 @@ TUPLE: jamshred sounds tunnel players running quit ; : mouse-moved ( x-radians y-radians jamshred -- ) jamshred-player -rot turn-player ; -: units-per-full-roll ( -- n ) 50 ; +CONSTANT: units-per-full-roll 50 : jamshred-roll ( jamshred n -- ) [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ; diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index bae275e96a..a1d22c48dc 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -6,18 +6,17 @@ math.functions math.vectors opengl opengl.gl opengl.glu opengl.demo-support sequences specialized-arrays.float ; IN: jamshred.gl -: min-vertices ( -- n ) 6 ; inline -: max-vertices ( -- n ) 32 ; inline +CONSTANT: min-vertices 6 +CONSTANT: max-vertices 32 -: n-vertices ( -- n ) 32 ; inline +CONSTANT: n-vertices 32 ! render enough of the tunnel that it looks continuous -: n-segments-ahead ( -- n ) 60 ; inline -: n-segments-behind ( -- n ) 40 ; inline +CONSTANT: n-segments-ahead 60 +CONSTANT: n-segments-behind 40 -: wall-drawing-offset ( -- n ) - #! so that we can't see through the wall, we draw it a bit further away - 0.15 ; +! so that we can't see through the wall, we draw it a bit further away +CONSTANT: wall-drawing-offset 0.15 : wall-drawing-radius ( segment -- r ) radius>> wall-drawing-offset + ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 49624e2947..fd683e3bc4 100644 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -8,8 +8,8 @@ TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ; : ( jamshred -- gadget ) jamshred-gadget new swap >>jamshred ; -: default-width ( -- x ) 800 ; -: default-height ( -- y ) 600 ; +CONSTANT: default-width 800 +CONSTANT: default-height 600 M: jamshred-gadget pref-dim* drop default-width default-height 2array ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index d33b78f29c..5b92b3a434 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -12,8 +12,8 @@ TUPLE: player < oint { speed float } ; ! speeds are in GL units / second -: default-speed ( -- speed ) 1.0 ; -: max-speed ( -- speed ) 30.0 ; +CONSTANT: default-speed 1.0 +CONSTANT: max-speed 30.0 : ( name sounds -- player ) [ float-array{ 0 0 5 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] 2dip diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 4c4b3e6812..d951a37f0c 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -3,7 +3,7 @@ USING: accessors arrays colors combinators kernel locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ; IN: jamshred.tunnel -: n-segments ( -- n ) 5000 ; inline +CONSTANT: n-segments 5000 TUPLE: segment < oint number color radius ; C: segment @@ -14,8 +14,10 @@ C: segment : random-color ( -- color ) { 100 100 100 } [ random 100 / >float ] map first3 1.0 ; -: tunnel-segment-distance ( -- n ) 0.4 ; -: random-rotation-angle ( -- theta ) pi 20 / ; +CONSTANT: tunnel-segment-distance 0.4 +USE: words.constant +DEFER: random-rotation-angle +\ random-rotation-angle pi 20 / define-constant : random-segment ( previous-segment -- segment ) clone dup random-rotation-angle random-turn @@ -27,7 +29,7 @@ C: segment [ dup peek random-segment over push ] dip 1- (random-segments) ] [ drop ] if ; -: default-segment-radius ( -- r ) 1 ; +CONSTANT: default-segment-radius 1 : initial-segment ( -- segment ) float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } @@ -115,7 +117,7 @@ C: segment : wall-normal ( seg oint -- n ) location>> vector-to-centre normalize ; -: distant ( -- n ) 1000 ; +CONSTANT: distant 1000 : max-real ( a b -- c ) #! sometimes collision-coefficient yields complex roots, so we ignore these (hack) diff --git a/extra/synth/buffers/buffers.factor b/extra/synth/buffers/buffers.factor index 671ebead63..4c0ef64607 100644 --- a/extra/synth/buffers/buffers.factor +++ b/extra/synth/buffers/buffers.factor @@ -57,11 +57,11 @@ M: 8bit-stereo-buffer buffer-data M: 16bit-stereo-buffer buffer-data interleaved-stereo-data 16bit-buffer-data ; -: telephone-sample-freq ( -- n ) 8000 ; -: half-sample-freq ( -- n ) 22050 ; -: cd-sample-freq ( -- n ) 44100 ; -: digital-sample-freq ( -- n ) 48000 ; -: professional-sample-freq ( -- n ) 88200 ; +CONSTANT: telephone-sample-freq 8000 +CONSTANT: half-sample-freq 22050 +CONSTANT: cd-sample-freq 44100 +CONSTANT: digital-sample-freq 48000 +CONSTANT: professional-sample-freq 88200 : send-buffer ( buffer -- buffer ) { From 18b5090892e20b5016affc51846340d9e3e52c00 Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Sun, 19 Apr 2009 19:57:35 -0700 Subject: [PATCH 401/772] Add tests for auto-USING selection --- extra/fuel/fuel-tests.factor | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 extra/fuel/fuel-tests.factor diff --git a/extra/fuel/fuel-tests.factor b/extra/fuel/fuel-tests.factor new file mode 100644 index 0000000000..a0cab888e8 --- /dev/null +++ b/extra/fuel/fuel-tests.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2009 Nicholas Seckar. +! See http://factorcode.org/license.txt for BSD license. +USING: continuations eval fuel fuel.private namespaces tools.test words ; +IN: fuel.tests + +: fake-continuation ( -- continuation ) + f f f "fake" f ; + +: make-uses-restart ( -- restart ) + "Use the words vocabulary" \ word? + fake-continuation ; + +: make-defer-restart ( -- restart ) + "Defer word in current vocabulary" f + fake-continuation ; + +{ f } [ make-defer-restart is-use-restart ] unit-test +{ t } [ make-uses-restart is-use-restart ] unit-test + +{ "words" } [ make-uses-restart get-restart-vocab ] unit-test + +{ f } [ make-defer-restart is-suggested-restart ] unit-test +{ f } [ make-uses-restart is-suggested-restart ] unit-test +{ f } [ { "io" } :uses-suggestions + [ make-uses-restart is-suggested-restart ] with-variable +] unit-test +{ t } [ { "words" } :uses-suggestions + [ make-uses-restart is-suggested-restart ] with-variable +] unit-test + +{ } [ + { "kernel" } [ "\\ dup drop" eval( -- ) ] fuel-use-suggested-vocabs +] unit-test From 0e6f76c13d8ded676ea792020f74e1fae00eae84 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 20 Apr 2009 14:15:38 +1000 Subject: [PATCH 402/772] Using literals vocab for defining computed constants --- extra/jamshred/tunnel/tunnel.factor | 6 +- extra/morse/morse.factor | 124 ++++++++++++++-------------- 2 files changed, 62 insertions(+), 68 deletions(-) diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index d951a37f0c..6171c3053b 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays colors combinators kernel locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ; +USING: accessors arrays colors combinators kernel literals locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ; IN: jamshred.tunnel CONSTANT: n-segments 5000 @@ -15,9 +15,7 @@ C: segment { 100 100 100 } [ random 100 / >float ] map first3 1.0 ; CONSTANT: tunnel-segment-distance 0.4 -USE: words.constant -DEFER: random-rotation-angle -\ random-rotation-angle pi 20 / define-constant +CONSTANT: random-rotation-angle $[ pi 20 / ] : random-segment ( previous-segment -- segment ) clone dup random-rotation-angle random-turn diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index 49e6ae39f5..ef4b9d4b88 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2007, 2008, 2009 Alex Chapman, 2009 Diego Martinelli ! See http://factorcode.org/license.txt for BSD license. -USING: accessors ascii assocs biassocs combinators hashtables kernel lists math -namespaces make multiline openal parser sequences splitting strings synth synth.buffers ; +USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ; IN: morse -DEFER: morse-code-table - -H{ - { CHAR: a ".-" } - { CHAR: b "-..." } - { CHAR: c "-.-." } - { CHAR: d "-.." } - { CHAR: e "." } - { CHAR: f "..-." } - { CHAR: g "--." } - { CHAR: h "...." } - { CHAR: i ".." } - { CHAR: j ".---" } - { CHAR: k "-.-" } - { CHAR: l ".-.." } - { CHAR: m "--" } - { CHAR: n "-." } - { CHAR: o "---" } - { CHAR: p ".--." } - { CHAR: q "--.-" } - { CHAR: r ".-." } - { CHAR: s "..." } - { CHAR: t "-" } - { CHAR: u "..-" } - { CHAR: v "...-" } - { CHAR: w ".--" } - { CHAR: x "-..-" } - { CHAR: y "-.--" } - { CHAR: z "--.." } - { CHAR: 1 ".----" } - { CHAR: 2 "..---" } - { CHAR: 3 "...--" } - { CHAR: 4 "....-" } - { CHAR: 5 "....." } - { CHAR: 6 "-...." } - { CHAR: 7 "--..." } - { CHAR: 8 "---.." } - { CHAR: 9 "----." } - { CHAR: 0 "-----" } - { CHAR: . ".-.-.-" } - { CHAR: , "--..--" } - { CHAR: ? "..--.." } - { CHAR: ' ".----." } - { CHAR: ! "-.-.--" } - { CHAR: / "-..-." } - { CHAR: ( "-.--." } - { CHAR: ) "-.--.-" } - { CHAR: & ".-..." } - { CHAR: : "---..." } - { CHAR: ; "-.-.-." } - { CHAR: = "-...- " } - { CHAR: + ".-.-." } - { CHAR: - "-....-" } - { CHAR: _ "..--.-" } - { CHAR: " ".-..-." } - { CHAR: $ "...-..-" } - { CHAR: @ ".--.-." } - { CHAR: \s "/" } -} >biassoc \ morse-code-table set-global - -: morse-code-table ( -- biassoc ) - \ morse-code-table get-global ; +CONSTANT: morse-code-table $[ + H{ + { CHAR: a ".-" } + { CHAR: b "-..." } + { CHAR: c "-.-." } + { CHAR: d "-.." } + { CHAR: e "." } + { CHAR: f "..-." } + { CHAR: g "--." } + { CHAR: h "...." } + { CHAR: i ".." } + { CHAR: j ".---" } + { CHAR: k "-.-" } + { CHAR: l ".-.." } + { CHAR: m "--" } + { CHAR: n "-." } + { CHAR: o "---" } + { CHAR: p ".--." } + { CHAR: q "--.-" } + { CHAR: r ".-." } + { CHAR: s "..." } + { CHAR: t "-" } + { CHAR: u "..-" } + { CHAR: v "...-" } + { CHAR: w ".--" } + { CHAR: x "-..-" } + { CHAR: y "-.--" } + { CHAR: z "--.." } + { CHAR: 1 ".----" } + { CHAR: 2 "..---" } + { CHAR: 3 "...--" } + { CHAR: 4 "....-" } + { CHAR: 5 "....." } + { CHAR: 6 "-...." } + { CHAR: 7 "--..." } + { CHAR: 8 "---.." } + { CHAR: 9 "----." } + { CHAR: 0 "-----" } + { CHAR: . ".-.-.-" } + { CHAR: , "--..--" } + { CHAR: ? "..--.." } + { CHAR: ' ".----." } + { CHAR: ! "-.-.--" } + { CHAR: / "-..-." } + { CHAR: ( "-.--." } + { CHAR: ) "-.--.-" } + { CHAR: & ".-..." } + { CHAR: : "---..." } + { CHAR: ; "-.-.-." } + { CHAR: = "-...- " } + { CHAR: + ".-.-." } + { CHAR: - "-....-" } + { CHAR: _ "..--.-" } + { CHAR: " ".-..-." } + { CHAR: $ "...-..-" } + { CHAR: @ ".--.-." } + { CHAR: \s "/" } + } >biassoc +] : ch>morse ( ch -- morse ) ch>lower morse-code-table at [ unknown-char ] unless* ; From bcd05337943f0b694ed0b54c1a94d3ca55e170bc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 01:42:54 -0500 Subject: [PATCH 403/772] Improve example in syntax vocab --- core/syntax/syntax-docs.factor | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index f869cff506..73335e09cf 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -525,11 +525,19 @@ HELP: (( { $description "Literal stack effect syntax." } { $notes "Useful for meta-programming with " { $link define-declared } "." } { $examples - { $code - "<< SYMBOL: my-dynamic-word" - "USING: math random words ;" - "my-dynamic-word 3 { [ + ] [ - ] [ * ] [ / ] } random curry" - "(( x -- y )) define-declared >>" + { $example + "USING: compiler.units kernel math prettyprint random words ;" + "IN: scratchpad" + "" + "SYMBOL: my-dynamic-word" + "" + "[" + " my-dynamic-word 2 { [ + ] [ * ] } random curry" + " (( x -- y )) define-declared" + "] with-compilation-unit" + "" + "2 my-dynamic-word ." + "4" } } ; From 86e5ddf449aa283ca3894b46b43cdd23df13bec7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 01:47:10 -0500 Subject: [PATCH 404/772] Improve Unix signal and Windows structured exception reporting --- basis/debugger/debugger.factor | 29 +++++++-------------------- basis/debugger/unix/authors.txt | 1 + basis/debugger/unix/unix.factor | 23 +++++++++++++++++++++ basis/debugger/windows/authors.txt | 1 + basis/debugger/windows/windows.factor | 6 ++++++ 5 files changed, 38 insertions(+), 22 deletions(-) create mode 100644 basis/debugger/unix/authors.txt create mode 100644 basis/debugger/unix/unix.factor create mode 100644 basis/debugger/windows/authors.txt create mode 100644 basis/debugger/windows/windows.factor diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 64bac3ecee..9abd5a9033 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -88,27 +88,7 @@ M: string error. print ; : divide-by-zero-error. ( obj -- ) "Division by zero" print drop ; -CONSTANT: signal-names -{ - "SIGHUP" "SIGINT" "SIGQUIT" "SIGILL" "SIGTRAP" "SIGABRT" - "SIGEMT" "SIGFPE" "SIGKILL" "SIGBUS" "SIGSEGV" "SIGSYS" - "SIGPIPE" "SIGALRM" "SIGTERM" "SIGURG" "SIGSTOP" "SIGTSIP" - "SIGCONT" "SIGCHLD" "SIGTTIN" "SIGTTOU" "SIGIO" "SIGXCPU" - "SIGXFSZ" "SIGVTALRM" "SIGPROF" "SIGWINCH" "SIGINFO" - "SIGUSR1" "SIGUSR2" -} - -: signal-name ( n -- str ) - 1- signal-names nth; - -: signal-name. ( n -- ) - dup signal-names length <= - os unix? and - [ " (" write signal-name write ")" write ] [ drop ] if ; - -: signal-error. ( obj -- ) - "Operating system signal " write - third [ pprint ] [ signal-name. ] bi nl ; +HOOK: signal-error. os ( obj -- ) : array-size-error. ( obj -- ) "Invalid array size: " write dup third . @@ -325,4 +305,9 @@ M: check-mixin-class summary drop "Not a mixin class" ; M: not-found-in-roots summary drop "Cannot resolve vocab: path" ; -M: wrong-values summary drop "Quotation called with wrong stack effect" ; \ No newline at end of file +M: wrong-values summary drop "Quotation called with wrong stack effect" ; + +{ + { [ os windows? ] [ "debugger.windows" require ] } + { [ os unix? ] [ "debugger.unix" require ] } +} cond \ No newline at end of file diff --git a/basis/debugger/unix/authors.txt b/basis/debugger/unix/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/debugger/unix/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/debugger/unix/unix.factor b/basis/debugger/unix/unix.factor new file mode 100644 index 0000000000..212908b2fd --- /dev/null +++ b/basis/debugger/unix/unix.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: debugger io kernel math prettyprint sequences system ; +IN: debugger.unix + +CONSTANT: signal-names +{ + "SIGHUP" "SIGINT" "SIGQUIT" "SIGILL" "SIGTRAP" "SIGABRT" + "SIGEMT" "SIGFPE" "SIGKILL" "SIGBUS" "SIGSEGV" "SIGSYS" + "SIGPIPE" "SIGALRM" "SIGTERM" "SIGURG" "SIGSTOP" "SIGTSIP" + "SIGCONT" "SIGCHLD" "SIGTTIN" "SIGTTOU" "SIGIO" "SIGXCPU" + "SIGXFSZ" "SIGVTALRM" "SIGPROF" "SIGWINCH" "SIGINFO" + "SIGUSR1" "SIGUSR2" +} + +: signal-name ( n -- str/f ) 1- signal-names ?nth ; + +: signal-name. ( n -- ) + signal-name [ " (" ")" surround write ] when* ; + +M: unix signal-error. ( obj -- ) + "Unix signal #" write + third [ pprint ] [ signal-name. ] bi nl ; diff --git a/basis/debugger/windows/authors.txt b/basis/debugger/windows/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/debugger/windows/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/debugger/windows/windows.factor b/basis/debugger/windows/windows.factor new file mode 100644 index 0000000000..1f4b8fb0ac --- /dev/null +++ b/basis/debugger/windows/windows.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: debugger io prettyprint sequences system ; +IN: debugger.windows + +M: windows signal-error. "Windows exception #" write third .h ; \ No newline at end of file From 5ac1358aea56fd86bc93206cc940795f0849f4fc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 01:55:27 -0500 Subject: [PATCH 405/772] Report actual SEH code on Windows instead of 'signal 11' --- vm/bignum.c | 6 +++--- vm/errors.c | 9 ++------- vm/errors.h | 3 +-- vm/os-windows-nt.c | 8 +------- 4 files changed, 7 insertions(+), 19 deletions(-) mode change 100644 => 100755 vm/bignum.c diff --git a/vm/bignum.c b/vm/bignum.c old mode 100644 new mode 100755 index 497a4bbf62..c799691f36 --- a/vm/bignum.c +++ b/vm/bignum.c @@ -170,7 +170,7 @@ bignum_divide(bignum_type numerator, bignum_type denominator, { if (BIGNUM_ZERO_P (denominator)) { - divide_by_zero_error(NULL); + divide_by_zero_error(); return; } if (BIGNUM_ZERO_P (numerator)) @@ -242,7 +242,7 @@ bignum_quotient(bignum_type numerator, bignum_type denominator) { if (BIGNUM_ZERO_P (denominator)) { - divide_by_zero_error(NULL); + divide_by_zero_error(); return (BIGNUM_OUT_OF_BAND); } if (BIGNUM_ZERO_P (numerator)) @@ -295,7 +295,7 @@ bignum_remainder(bignum_type numerator, bignum_type denominator) { if (BIGNUM_ZERO_P (denominator)) { - divide_by_zero_error(NULL); + divide_by_zero_error(); return (BIGNUM_OUT_OF_BAND); } if (BIGNUM_ZERO_P (numerator)) diff --git a/vm/errors.c b/vm/errors.c index 9b7b7843d2..8e7b4818bf 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -124,9 +124,9 @@ void signal_error(int signal, F_STACK_FRAME *native_stack) general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack); } -void divide_by_zero_error(F_STACK_FRAME *native_stack) +void divide_by_zero_error(void) { - general_error(ERROR_DIVIDE_BY_ZERO,F,F,native_stack); + general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL); } void memory_signal_handler_impl(void) @@ -134,11 +134,6 @@ void memory_signal_handler_impl(void) memory_protection_error(signal_fault_addr,signal_callstack_top); } -void divide_by_zero_signal_handler_impl(void) -{ - divide_by_zero_error(signal_callstack_top); -} - void misc_signal_handler_impl(void) { signal_error(signal_number,signal_callstack_top); diff --git a/vm/errors.h b/vm/errors.h index da3ee8bbe0..56aaf60d54 100755 --- a/vm/errors.h +++ b/vm/errors.h @@ -26,7 +26,7 @@ void primitive_die(void); void throw_error(CELL error, F_STACK_FRAME *native_stack); void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack); -void divide_by_zero_error(F_STACK_FRAME *native_stack); +void divide_by_zero_error(void); void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack); void signal_error(int signal, F_STACK_FRAME *native_stack); void type_error(CELL type, CELL tagged); @@ -53,7 +53,6 @@ CELL signal_fault_addr; void *signal_callstack_top; void memory_signal_handler_impl(void); -void divide_by_zero_signal_handler_impl(void); void misc_signal_handler_impl(void); void primitive_unimplemented(void); diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index bcddd0b140..501463378a 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -23,12 +23,6 @@ long exception_handler(PEXCEPTION_POINTERS pe) signal_fault_addr = e->ExceptionInformation[1]; c->EIP = (CELL)memory_signal_handler_impl; } - else if(e->ExceptionCode == EXCEPTION_FLT_DIVIDE_BY_ZERO - || e->ExceptionCode == EXCEPTION_INT_DIVIDE_BY_ZERO) - { - signal_number = ERROR_DIVIDE_BY_ZERO; - c->EIP = (CELL)divide_by_zero_signal_handler_impl; - } /* If the Widcomm bluetooth stack is installed, the BTTray.exe process injects code into running programs. For some reason this results in random SEH exceptions with this (undocumented) exception code being @@ -37,7 +31,7 @@ long exception_handler(PEXCEPTION_POINTERS pe) this exception means. */ else if(e->ExceptionCode != 0x40010006) { - signal_number = 11; + signal_number = e->ExceptionCode; c->EIP = (CELL)misc_signal_handler_impl; } From ec72f33fcbe0d8dee60d83b5d5195653511dfdec Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 02:23:52 -0500 Subject: [PATCH 406/772] Documentation updates --- basis/help/handbook/handbook.factor | 1 + basis/ui/tools/profiler/profiler-docs.factor | 10 +++++++--- basis/ui/tools/tools-docs.factor | 11 ----------- core/combinators/combinators-docs.factor | 6 ------ core/parser/parser-docs.factor | 3 +-- core/quotations/quotations-docs.factor | 6 ++++++ 6 files changed, 15 insertions(+), 22 deletions(-) diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 1aac99defe..a97a46badc 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -249,6 +249,7 @@ ARTICLE: "handbook-language-reference" "The language" { $heading "Abstractions" } { $subsection "objects" } { $subsection "destructors" } +{ $subsection "parsing-words" } { $subsection "macros" } { $subsection "fry" } { $heading "Program organization" } diff --git a/basis/ui/tools/profiler/profiler-docs.factor b/basis/ui/tools/profiler/profiler-docs.factor index e2a0ef5f4e..fad2b3614f 100644 --- a/basis/ui/tools/profiler/profiler-docs.factor +++ b/basis/ui/tools/profiler/profiler-docs.factor @@ -1,10 +1,14 @@ IN: ui.tools.profiler -USING: help.markup help.syntax ui.operations help.tips ; +USING: help.markup help.syntax ui.operations ui.commands help.tips ; -ARTICLE: "ui.tools.profiler" "UI profiler tool" +ARTICLE: "ui.tools.profiler" "UI profiler tool" "The " { $vocab-link "ui.tools.profiler" } " vocabulary implements a graphical tool for viewing profiling results (see " { $link "profiling" } ")." $nl -"To use the profiler, enter a piece of code in the listener's input area and press " { $operation com-profile } "." ; +"To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "." +$nl +"Clicking on a vocabulary in the vocabulary list narrows down the word list to only include words from that vocabulary. The sorting options control the order of elements in the vocabulary and word lists. The search fields narrow down the list to only include words or vocabularies whose names contain a substring." +$nl +"Consult " { $link "profiling" } " for details about the profiler itself." ; TIP: "Press " { $operation com-profile } " to run the code in the input field with profiling enabled (" { $link "ui.tools.profiler" } ")." ; diff --git a/basis/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor index 92aa1be947..7be008f296 100644 --- a/basis/ui/tools/tools-docs.factor +++ b/basis/ui/tools/tools-docs.factor @@ -31,17 +31,6 @@ $nl $nl "For more about presentation gadgets, see " { $link "ui.gadgets.presentations" } "." ; -ARTICLE: "ui-profiler" "UI profiler" -"The graphical profiler is based on the terminal profiler (see " { $link "profiling" } ") and adds more convenient browsing of profiler results." -$nl -"To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "." -$nl -"Clicking on a vocabulary in the vocabulary list narrows down the word list to only include words from that vocabulary. The sorting options control the order of elements in the vocabulary and word lists. The search fields narrow down the list to only include words or vocabularies whose names contain a substring." -$nl -"Consult " { $link "profiling" } " for details about the profiler itself." -{ $command-map profiler-gadget "toolbar" } -"The profiler is an instance of " { $link profiler-gadget } "." ; - ARTICLE: "ui-cocoa" "Functionality specific to Mac OS X" "On Mac OS X, the Factor UI offers additional features which integrate with this operating system." $nl diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 9c96fe34c9..dd55d5fabe 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -303,13 +303,7 @@ ARTICLE: "combinators" "Combinators" { $subsection "combinators.short-circuit" } { $subsection "combinators.smart" } "More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "." -$nl -"The " { $vocab-link "combinators" } " provides some less frequently-used features." -$nl -"A combinator which can help with implementing methods on " { $link hashcode* } ":" -{ $subsection recursive-hashcode } { $subsection "combinators-quot" } -"Advanced topics:" { $see-also "quotations" } ; ABOUT: "combinators" diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index be4b345f4f..ea82f7276f 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -94,11 +94,10 @@ $nl "This section concerns itself with usage and extension of the parser. Standard syntax is described in " { $link "syntax" } "." { $subsection "parser-files" } "The parser can be extended." -{ $subsection "parsing-words" } { $subsection "parser-lexer" } "The parser can be invoked reflectively;" { $subsection parse-stream } -{ $see-also "definitions" "definition-checking" } ; +{ $see-also "parsing-words" "definitions" "definition-checking" } ; ABOUT: "parser" diff --git a/core/quotations/quotations-docs.factor b/core/quotations/quotations-docs.factor index 603d6f2847..364f186d52 100644 --- a/core/quotations/quotations-docs.factor +++ b/core/quotations/quotations-docs.factor @@ -25,6 +25,12 @@ ARTICLE: "wrappers" "Wrappers" { $subsection wrapper } { $subsection literalize } "Wrapper literal syntax is documented in " { $link "syntax-words" } "." +{ $example + "IN: scratchpad" + "DEFER: my-word" + "\\ my-word name>> ." + "\"my-word\"" +} { $see-also "combinators" } ; ABOUT: "quotations" From 0f26d02d41edd2fe4d96d00557d6c1cc68aece6a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 03:26:56 -0500 Subject: [PATCH 407/772] Passing the wrong type of sequence to M\ encoder write now throws an error --- basis/io/files/unique/unique-tests.factor | 2 +- core/io/encodings/encodings.factor | 4 +++- core/io/files/files-tests.factor | 14 +++++++++++++- 3 files changed, 17 insertions(+), 3 deletions(-) diff --git a/basis/io/files/unique/unique-tests.factor b/basis/io/files/unique/unique-tests.factor index fd8cf2c69f..53a77907cf 100644 --- a/basis/io/files/unique/unique-tests.factor +++ b/basis/io/files/unique/unique-tests.factor @@ -5,7 +5,7 @@ IN: io.files.unique.tests [ 123 ] [ "core" ".test" [ - [ [ 123 CHAR: a ] dip ascii set-file-contents ] + [ [ 123 CHAR: a ] dip ascii set-file-contents ] [ file-info size>> ] bi ] cleanup-unique-file ] unit-test diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 696de9af69..174816dd34 100644 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -130,7 +130,9 @@ M: encoder stream-element-type M: encoder stream-write1 >encoder< encode-char ; -: encoder-write ( string stream encoding -- ) +GENERIC# encoder-write 2 ( string stream encoding -- ) + +M: string encoder-write [ encode-char ] 2curry each ; M: encoder stream-write diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index ce15a69773..a2d637dcb7 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,7 +1,7 @@ USING: arrays debugger.threads destructors io io.directories io.encodings.8-bit io.encodings.ascii io.encodings.binary io.files io.files.private io.files.temp io.files.unique kernel -make math sequences system threads tools.test ; +make math sequences system threads tools.test generic.standard ; IN: io.files.tests \ exists? must-infer @@ -144,3 +144,15 @@ USE: debugger.threads -10 seek-absolute seek-input ] with-file-reader ] must-fail + +[ + "non-string-error" unique-file ascii [ + { } write + ] with-file-writer +] [ no-method? ] must-fail-with + +[ + "non-byte-array-error" unique-file binary [ + "" write + ] with-file-writer +] [ no-method? ] must-fail-with \ No newline at end of file From ec49307c88cb0db7b4fd0dc4b1ca0694a0e0c654 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 03:27:18 -0500 Subject: [PATCH 408/772] Never inline default methods, and fix inlining of methods with hints --- .../tree/propagation/inlining/inlining.factor | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 0815351057..7ae44a5293 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -3,7 +3,7 @@ USING: accessors kernel arrays sequences math math.order math.partial-dispatch generic generic.standard generic.math classes.algebra classes.union sets quotations assocs combinators -words namespaces continuations classes fry combinators.smart +words namespaces continuations classes fry combinators.smart hints compiler.tree compiler.tree.builder compiler.tree.recursive @@ -136,12 +136,10 @@ DEFER: (flat-length) [ [ classes-known? 2 0 ? ] [ - { - [ body-length-bias ] - [ "default" word-prop -4 0 ? ] - [ "specializer" word-prop 1 0 ? ] - [ method-body? 1 0 ? ] - } cleave + [ body-length-bias ] + [ "specializer" word-prop 1 0 ? ] + [ method-body? 1 0 ? ] + tri node-count-bias loop-nesting get 0 or 2 * ] bi* @@ -172,7 +170,7 @@ SYMBOL: history ] if ; : inline-word ( #call word -- ? ) - dup def>> inline-word-def ; + dup specialized-def inline-word-def ; : inline-method-body ( #call word -- ? ) 2dup should-inline? [ inline-word ] [ 2drop f ] if ; @@ -181,7 +179,9 @@ SYMBOL: history { curry compose } memq? ; : never-inline-word? ( word -- ? ) - [ deferred? ] [ { call execute } memq? ] bi or ; + [ deferred? ] + [ "default" word-prop ] + [ { call execute } memq? ] tri or or ; : custom-inlining? ( word -- ? ) "custom-inlining" word-prop ; From 7aeb13e58a150a2dd8f4e6065677e9b384b1babb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 03:27:30 -0500 Subject: [PATCH 409/772] io.buffers and io.ports performance tweaks --- basis/io/buffers/buffers.factor | 2 +- basis/io/ports/ports.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor index 4df081b17d..49b5357d98 100644 --- a/basis/io/buffers/buffers.factor +++ b/basis/io/buffers/buffers.factor @@ -22,7 +22,7 @@ M: buffer dispose* ptr>> free ; swap >>fill 0 >>pos drop ; : buffer-capacity ( buffer -- n ) - [ size>> ] [ fill>> ] bi - ; inline + [ size>> ] [ fill>> ] bi - >fixnum ; inline : buffer-empty? ( buffer -- ? ) fill>> zero? ; inline diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 569366d4b8..b2d71fd535 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -189,4 +189,4 @@ HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii } HINTS: decoder-readln { input-port utf8 } { input-port ascii } ; -HINTS: encoder-write { string output-port utf8 } { string output-port ascii } ; +HINTS: encoder-write { object output-port utf8 } { object output-port ascii } ; From 3b40334ccda0cd45398e4f8fd6ffca85c8c0e127 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 03:27:52 -0500 Subject: [PATCH 410/772] xml: fix compile warnings in tests --- basis/xml/tests/state-parser-tests.factor | 2 +- basis/xml/tests/xmltest.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/xml/tests/state-parser-tests.factor b/basis/xml/tests/state-parser-tests.factor index 7616efaf1d..5e214dc4a3 100644 --- a/basis/xml/tests/state-parser-tests.factor +++ b/basis/xml/tests/state-parser-tests.factor @@ -2,7 +2,7 @@ USING: tools.test xml.tokenize xml.state io.streams.string kernel io strings asc IN: xml.test.state : string-parse ( str quot -- ) - [ ] dip with-state ; + [ ] dip with-state ; inline : take-rest ( -- string ) [ f ] take-until ; diff --git a/basis/xml/tests/xmltest.factor b/basis/xml/tests/xmltest.factor index c41b05eb85..55b5147abb 100644 --- a/basis/xml/tests/xmltest.factor +++ b/basis/xml/tests/xmltest.factor @@ -43,7 +43,7 @@ MACRO: drop-input ( quot -- newquot ) xml-tests [ unit-test ] assoc-each ; : works? ( result quot -- ? ) - [ first ] [ call ] bi* = ; + [ first ] [ call( -- result ) ] bi* = ; : partition-xml-tests ( -- successes failures ) xml-tests [ first2 works? ] partition ; From a4d48a1cd466ec356b42e55be51bbd1dbed8ec19 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 03:28:03 -0500 Subject: [PATCH 411/772] xml.writer: don't write arrays to output-stream --- basis/xml/writer/writer-tests.factor | 12 ++++++++++-- basis/xml/writer/writer.factor | 2 +- 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor index f19e845ab9..2d31738c4c 100644 --- a/basis/xml/writer/writer-tests.factor +++ b/basis/xml/writer/writer-tests.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: xml.data xml.writer tools.test fry xml kernel multiline +USING: xml.data xml.writer tools.test fry xml xml.syntax kernel multiline xml.writer.private io.streams.string xml.traversal sequences -io.encodings.utf8 io.files accessors io.directories ; +io.encodings.utf8 io.files accessors io.directories math math.parser ; IN: xml.writer.tests \ write-xml must-infer @@ -66,3 +66,11 @@ CONSTANT: test-file "resource:basis/xml/writer/test.xml" [ ] [ "" string>xml test-file utf8 [ write-xml ] with-file-writer ] unit-test [ "x" ] [ test-file file>xml body>> name>> main>> ] unit-test [ ] [ test-file delete-file ] unit-test + +[ ] [ + { 1 2 3 4 } [ + [ number>string ] [ sq number>string ] bi + [XML <-><-> XML] + ] map [XML

    Timings

    <->
    XML] + pprint-xml +] unit-test \ No newline at end of file diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor index 4f5bad1aa5..ab957ebc75 100755 --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -19,7 +19,7 @@ SYMBOL: indentation : indent-string ( -- string ) xml-pprint? get - [ indentation get indenter get concat ] + [ indentation get indenter get "" join ] [ "" ] if ; : ?indent ( -- ) From dff8f80ea657fc51cdcd8454eba0c774391e4a39 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 03:29:16 -0500 Subject: [PATCH 412/772] mason.report: fix timings-table, and add unit tests --- .../report/fake-data/benchmark-error-messages | 1 + .../report/fake-data/benchmark-error-vocabs | 1 + extra/mason/report/fake-data/benchmark-time | 1 + extra/mason/report/fake-data/benchmarks | 1 + extra/mason/report/fake-data/boot-log | 2 ++ extra/mason/report/fake-data/boot-time | 1 + extra/mason/report/fake-data/compile-log | 2 ++ .../report/fake-data/compiler-error-messages | 1 + extra/mason/report/fake-data/compiler-errors | 1 + extra/mason/report/fake-data/git-id | 1 + extra/mason/report/fake-data/help-lint-errors | 1 + extra/mason/report/fake-data/help-lint-time | 1 + extra/mason/report/fake-data/help-lint-vocabs | 1 + extra/mason/report/fake-data/html-help-time | 1 + .../report/fake-data/load-everything-errors | 1 + .../report/fake-data/load-everything-vocabs | 1 + extra/mason/report/fake-data/load-time | 1 + extra/mason/report/fake-data/test-all-errors | 1 + extra/mason/report/fake-data/test-all-vocabs | 1 + extra/mason/report/fake-data/test-log | 2 ++ extra/mason/report/fake-data/test-time | 1 + extra/mason/report/report-tests.factor | 28 +++++++++++++++++-- extra/mason/report/report.factor | 18 ++++++------ 23 files changed, 59 insertions(+), 11 deletions(-) create mode 100644 extra/mason/report/fake-data/benchmark-error-messages create mode 100644 extra/mason/report/fake-data/benchmark-error-vocabs create mode 100644 extra/mason/report/fake-data/benchmark-time create mode 100644 extra/mason/report/fake-data/benchmarks create mode 100644 extra/mason/report/fake-data/boot-log create mode 100644 extra/mason/report/fake-data/boot-time create mode 100644 extra/mason/report/fake-data/compile-log create mode 100644 extra/mason/report/fake-data/compiler-error-messages create mode 100644 extra/mason/report/fake-data/compiler-errors create mode 100644 extra/mason/report/fake-data/git-id create mode 100644 extra/mason/report/fake-data/help-lint-errors create mode 100644 extra/mason/report/fake-data/help-lint-time create mode 100644 extra/mason/report/fake-data/help-lint-vocabs create mode 100644 extra/mason/report/fake-data/html-help-time create mode 100644 extra/mason/report/fake-data/load-everything-errors create mode 100644 extra/mason/report/fake-data/load-everything-vocabs create mode 100644 extra/mason/report/fake-data/load-time create mode 100644 extra/mason/report/fake-data/test-all-errors create mode 100644 extra/mason/report/fake-data/test-all-vocabs create mode 100644 extra/mason/report/fake-data/test-log create mode 100644 extra/mason/report/fake-data/test-time diff --git a/extra/mason/report/fake-data/benchmark-error-messages b/extra/mason/report/fake-data/benchmark-error-messages new file mode 100644 index 0000000000..f738144e3c --- /dev/null +++ b/extra/mason/report/fake-data/benchmark-error-messages @@ -0,0 +1 @@ +Benchmarks diff --git a/extra/mason/report/fake-data/benchmark-error-vocabs b/extra/mason/report/fake-data/benchmark-error-vocabs new file mode 100644 index 0000000000..b5a85b9c41 --- /dev/null +++ b/extra/mason/report/fake-data/benchmark-error-vocabs @@ -0,0 +1 @@ +{ "benchmarks" } diff --git a/extra/mason/report/fake-data/benchmark-time b/extra/mason/report/fake-data/benchmark-time new file mode 100644 index 0000000000..81c545efeb --- /dev/null +++ b/extra/mason/report/fake-data/benchmark-time @@ -0,0 +1 @@ +1234 diff --git a/extra/mason/report/fake-data/benchmarks b/extra/mason/report/fake-data/benchmarks new file mode 100644 index 0000000000..ed8ec42879 --- /dev/null +++ b/extra/mason/report/fake-data/benchmarks @@ -0,0 +1 @@ +H{ { "a" 1 } { "b" 2 } } diff --git a/extra/mason/report/fake-data/boot-log b/extra/mason/report/fake-data/boot-log new file mode 100644 index 0000000000..d9e4d79562 --- /dev/null +++ b/extra/mason/report/fake-data/boot-log @@ -0,0 +1,2 @@ +Boot +Log diff --git a/extra/mason/report/fake-data/boot-time b/extra/mason/report/fake-data/boot-time new file mode 100644 index 0000000000..81c545efeb --- /dev/null +++ b/extra/mason/report/fake-data/boot-time @@ -0,0 +1 @@ +1234 diff --git a/extra/mason/report/fake-data/compile-log b/extra/mason/report/fake-data/compile-log new file mode 100644 index 0000000000..5007c38d13 --- /dev/null +++ b/extra/mason/report/fake-data/compile-log @@ -0,0 +1,2 @@ +Compile +Log diff --git a/extra/mason/report/fake-data/compiler-error-messages b/extra/mason/report/fake-data/compiler-error-messages new file mode 100644 index 0000000000..1a58d6dcf0 --- /dev/null +++ b/extra/mason/report/fake-data/compiler-error-messages @@ -0,0 +1 @@ +Compiler errors diff --git a/extra/mason/report/fake-data/compiler-errors b/extra/mason/report/fake-data/compiler-errors new file mode 100644 index 0000000000..4e5eee20e2 --- /dev/null +++ b/extra/mason/report/fake-data/compiler-errors @@ -0,0 +1 @@ +{ "compiler-errors" } diff --git a/extra/mason/report/fake-data/git-id b/extra/mason/report/fake-data/git-id new file mode 100644 index 0000000000..d4d308b176 --- /dev/null +++ b/extra/mason/report/fake-data/git-id @@ -0,0 +1 @@ +"deadbeef" diff --git a/extra/mason/report/fake-data/help-lint-errors b/extra/mason/report/fake-data/help-lint-errors new file mode 100644 index 0000000000..da540b4802 --- /dev/null +++ b/extra/mason/report/fake-data/help-lint-errors @@ -0,0 +1 @@ +Help lint diff --git a/extra/mason/report/fake-data/help-lint-time b/extra/mason/report/fake-data/help-lint-time new file mode 100644 index 0000000000..81c545efeb --- /dev/null +++ b/extra/mason/report/fake-data/help-lint-time @@ -0,0 +1 @@ +1234 diff --git a/extra/mason/report/fake-data/help-lint-vocabs b/extra/mason/report/fake-data/help-lint-vocabs new file mode 100644 index 0000000000..6d88a7fff8 --- /dev/null +++ b/extra/mason/report/fake-data/help-lint-vocabs @@ -0,0 +1 @@ +{ "help-lint" } diff --git a/extra/mason/report/fake-data/html-help-time b/extra/mason/report/fake-data/html-help-time new file mode 100644 index 0000000000..81c545efeb --- /dev/null +++ b/extra/mason/report/fake-data/html-help-time @@ -0,0 +1 @@ +1234 diff --git a/extra/mason/report/fake-data/load-everything-errors b/extra/mason/report/fake-data/load-everything-errors new file mode 100644 index 0000000000..00d830932d --- /dev/null +++ b/extra/mason/report/fake-data/load-everything-errors @@ -0,0 +1 @@ +Load everything diff --git a/extra/mason/report/fake-data/load-everything-vocabs b/extra/mason/report/fake-data/load-everything-vocabs new file mode 100644 index 0000000000..2ecd4f611c --- /dev/null +++ b/extra/mason/report/fake-data/load-everything-vocabs @@ -0,0 +1 @@ +{ "load-everything" } diff --git a/extra/mason/report/fake-data/load-time b/extra/mason/report/fake-data/load-time new file mode 100644 index 0000000000..81c545efeb --- /dev/null +++ b/extra/mason/report/fake-data/load-time @@ -0,0 +1 @@ +1234 diff --git a/extra/mason/report/fake-data/test-all-errors b/extra/mason/report/fake-data/test-all-errors new file mode 100644 index 0000000000..13a64ee834 --- /dev/null +++ b/extra/mason/report/fake-data/test-all-errors @@ -0,0 +1 @@ +Test all errors diff --git a/extra/mason/report/fake-data/test-all-vocabs b/extra/mason/report/fake-data/test-all-vocabs new file mode 100644 index 0000000000..ef6294b9c7 --- /dev/null +++ b/extra/mason/report/fake-data/test-all-vocabs @@ -0,0 +1 @@ +{ "test-all" } diff --git a/extra/mason/report/fake-data/test-log b/extra/mason/report/fake-data/test-log new file mode 100644 index 0000000000..0b8521b008 --- /dev/null +++ b/extra/mason/report/fake-data/test-log @@ -0,0 +1,2 @@ +Test +Log diff --git a/extra/mason/report/fake-data/test-time b/extra/mason/report/fake-data/test-time new file mode 100644 index 0000000000..81c545efeb --- /dev/null +++ b/extra/mason/report/fake-data/test-time @@ -0,0 +1 @@ +1234 diff --git a/extra/mason/report/report-tests.factor b/extra/mason/report/report-tests.factor index a9e8e2802b..92cada72da 100644 --- a/extra/mason/report/report-tests.factor +++ b/extra/mason/report/report-tests.factor @@ -1,4 +1,28 @@ IN: mason.report.tests -USING: mason.report tools.test ; +USING: io.files io.directories kernel mason.report mason.common +tools.test xml xml.writer ; -{ 0 0 } [ [ ] with-report ] must-infer-as \ No newline at end of file +{ 0 0 } [ [ ] with-report ] must-infer-as + +: verify-report ( -- ) + [ t ] [ "report" exists? ] unit-test + [ ] [ "report" file>xml drop ] unit-test + [ ] [ "report" delete-file ] unit-test ; + +"resource:extra/mason/report/fake-data/" [ + [ ] [ + timings-table pprint-xml + ] unit-test + + [ ] [ successful-report ] unit-test + verify-report + + [ status-error ] [ 1234 compile-failed ] unit-test + verify-report + + [ status-error ] [ 1235 boot-failed ] unit-test + verify-report + + [ status-error ] [ 1236 test-failed ] unit-test + verify-report +] with-directory diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 0839652d55..eb00107d21 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -3,7 +3,8 @@ USING: benchmark combinators.smart debugger fry io assocs io.encodings.utf8 io.files io.sockets io.streams.string kernel locals mason.common mason.config mason.platform math namespaces -prettyprint sequences xml.syntax xml.writer combinators.short-circuit ; +prettyprint sequences xml.syntax xml.writer combinators.short-circuit +literals ; IN: mason.report : common-report ( -- xml ) @@ -56,15 +57,14 @@ IN: mason.report : timings-table ( -- xml ) { - boot-time-file - load-time-file - test-time-file - help-lint-time-file - benchmark-time-file - html-help-time-file + $ boot-time-file + $ load-time-file + $ test-time-file + $ help-lint-time-file + $ benchmark-time-file + $ html-help-time-file } [ - execute( -- string ) - dup utf8 file-contents milli-seconds>time + dup eval-file milli-seconds>time [XML <-><-> XML] ] map [XML

    Timings

    <->
    XML] ; From 5165d811d5dddee055aa5fe5641ccee1e5376965 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 04:21:00 -0500 Subject: [PATCH 413/772] Changing the stack effect of a generic word could break the compiler --- basis/compiler/tests/redefine16.factor | 10 ++++++ .../compiler/tree/optimizer/optimizer.factor | 12 ++++--- .../known-words/known-words.factor | 2 ++ core/words/words.factor | 36 ++++++++++--------- 4 files changed, 40 insertions(+), 20 deletions(-) create mode 100644 basis/compiler/tests/redefine16.factor diff --git a/basis/compiler/tests/redefine16.factor b/basis/compiler/tests/redefine16.factor new file mode 100644 index 0000000000..e0bb1773c9 --- /dev/null +++ b/basis/compiler/tests/redefine16.factor @@ -0,0 +1,10 @@ +IN: compiler.tests.redefine16 +USING: eval tools.test definitions words compiler.units +quotations stack-checker ; + +[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test + +[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test +[ "blah" "compiler.tests.redefine16" lookup 1quotation infer ] must-fail diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index 54c6c2c117..daa8f072ca 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -18,11 +18,18 @@ IN: compiler.tree.optimizer SYMBOL: check-optimizer? +: ?check ( nodes -- nodes' ) + check-optimizer? get [ + compute-def-use + dup check-nodes + ] when ; + : optimize-tree ( nodes -- nodes' ) analyze-recursive normalize propagate cleanup + ?check dup run-escape-analysis? [ escape-analysis unbox-tuples @@ -30,10 +37,7 @@ SYMBOL: check-optimizer? apply-identities compute-def-use remove-dead-code - check-optimizer? get [ - compute-def-use - dup check-nodes - ] when + ?check compute-def-use optimize-modular-arithmetic finalize ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index ff7288202a..abc1f68bb6 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -218,6 +218,8 @@ M: object infer-call* alien-callback } [ t "special" set-word-prop ] each +M\ quotation call t "no-compile" set-word-prop +M\ word execute t "no-compile" set-word-prop \ clear t "no-compile" set-word-prop : non-inline-word ( word -- ) diff --git a/core/words/words.factor b/core/words/words.factor index 5b230c1b00..c388f093fd 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -68,10 +68,6 @@ M: word crossref? vocabulary>> >boolean ] if ; -GENERIC: compiled-crossref? ( word -- ? ) - -M: word compiled-crossref? crossref? ; - GENERIC# (quot-uses) 1 ( obj assoc -- ) M: object (quot-uses) 2drop ; @@ -131,26 +127,38 @@ compiled-generic-crossref [ H{ } clone ] initialize : inline? ( word -- ? ) "inline" word-prop ; inline +GENERIC: subwords ( word -- seq ) + +M: word subwords drop f ; + + + : redefined ( word -- ) [ H{ } clone visited [ (redefined) ] with-variable ] [ changed-definition ] @@ -199,10 +207,6 @@ M: word reset-word "writer" "delimiter" } reset-props ; -GENERIC: subwords ( word -- seq ) - -M: word subwords drop f ; - : reset-generic ( word -- ) [ subwords forget-all ] [ reset-word ] From 74d352434c02faef127f884b241af6b3205f9158 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 04:25:11 -0500 Subject: [PATCH 414/772] morse: fix help lint --- extra/morse/morse-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/morse/morse-docs.factor b/extra/morse/morse-docs.factor index 93350ad02d..e2fab1528b 100644 --- a/extra/morse/morse-docs.factor +++ b/extra/morse/morse-docs.factor @@ -5,7 +5,7 @@ IN: morse HELP: ch>morse { $values - { "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } } + { "ch" "A character that has a morse code translation" } { "morse" "A string consisting of zero or more dots and dashes" } } { $description "If the given character has a morse code translation, then return that translation, otherwise return a ? character." } ; HELP: morse>ch @@ -15,12 +15,12 @@ HELP: morse>ch HELP: >morse { $values - { "str" "A string of ASCII characters which can be translated into morse code" } { "str" "A string in morse code" } } + { "str" "A string of ASCII characters which can be translated into morse code" } { "newstr" "A string in morse code" } } { $description "Translates ASCII text into morse code, represented by a series of dots, dashes, and slashes." } { $see-also morse> ch>morse } ; HELP: morse> -{ $values { "str" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "str" "The ASCII translation of the given string" } } +{ $values { "morse" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "plain" "The ASCII translation of the given string" } } { $description "Translates morse code into ASCII text" } { $see-also >morse morse>ch } ; From 5c236d6585afe7751263ca4d9c74722ef6e17ea7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 16:52:18 -0500 Subject: [PATCH 415/772] add a size-on-disk slot to file-info, the each-file combinator now works better, add a path>sizes word --- basis/io/directories/search/search.factor | 44 +++++++++++++++++----- basis/io/files/info/info.factor | 4 +- basis/io/files/info/unix/unix.factor | 1 + basis/io/files/info/windows/windows.factor | 28 +++++++++++++- basis/windows/kernel32/kernel32.factor | 3 +- 5 files changed, 66 insertions(+), 14 deletions(-) diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 6db83ebca6..38d8ec957e 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays continuations deques dlists fry io.directories io.files io.files.info io.pathnames kernel -sequences system vocabs.loader ; +sequences system vocabs.loader locals math namespaces +sorting assocs ; IN: io.directories.search > ] [ bfs>> ] bi + [ qualified-directory ] dip '[ + _ [ queue>> ] [ bfs>> ] bi [ push-front ] [ push-back ] if - ] curry each ; + ] each ; : ( path bfs? -- iterator ) directory-iterator boa @@ -28,12 +29,11 @@ TUPLE: directory-iterator path bfs queue ; [ over push-directory next-file ] [ nip ] if ] if ; -: iterate-directory ( iter quot: ( obj -- ? ) -- obj ) - over next-file [ - over call - [ 2nip ] [ iterate-directory ] if* +:: iterate-directory ( iter quot: ( obj -- ? ) -- obj ) + iter next-file [ + quot call [ iter quot iterate-directory ] unless* ] [ - 2drop f + f ] if* ; inline recursive PRIVATE> @@ -70,4 +70,30 @@ ERROR: file-not-found ; : find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f ) '[ _ _ find-all-files ] map concat ; inline +: with-qualified-directory-files ( path quot -- ) + '[ + "" directory-files current-directory get + '[ _ prepend-path ] map @ + ] with-directory ; inline + +: with-qualified-directory-entries ( path quot -- ) + '[ + "" directory-entries current-directory get + '[ [ _ prepend-path ] change-name ] map @ + ] with-directory ; inline + +: directory-size ( path -- n ) + 0 swap t [ file-info size-on-disk>> + ] each-file ; + +: path>sizes ( path -- assoc ) + [ + [ + [ name>> dup ] [ directory? ] bi [ + directory-size + ] [ + file-info size-on-disk>> + ] if + ] { } map>assoc + ] with-qualified-directory-entries sort-values ; + os windows? [ "io.directories.search.windows" require ] when diff --git a/basis/io/files/info/info.factor b/basis/io/files/info/info.factor index fd21850612..5c5d2c93d2 100644 --- a/basis/io/files/info/info.factor +++ b/basis/io/files/info/info.factor @@ -5,7 +5,7 @@ vocabs.loader io.files.types ; IN: io.files.info ! File info -TUPLE: file-info type size permissions created modified +TUPLE: file-info type size size-on-disk permissions created modified accessed ; HOOK: file-info os ( path -- info ) @@ -25,4 +25,4 @@ HOOK: file-system-info os ( path -- file-system-info ) { { [ os unix? ] [ "io.files.info.unix." os name>> append ] } { [ os windows? ] [ "io.files.info.windows" ] } -} cond require \ No newline at end of file +} cond require diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index 616f70cccc..d4762a536d 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -80,6 +80,7 @@ M: unix stat>file-info ( stat -- file-info ) [ stat-st_rdev >>rdev ] [ stat-st_blocks >>blocks ] [ stat-st_blksize >>blocksize ] + [ drop blocks>> blocksize>> * >>size-on-disk ] } cleave ; : n>file-type ( n -- type ) diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index fdff368491..81e43f8dd9 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -5,11 +5,33 @@ io.files.windows io.files.windows.nt kernel windows.kernel32 windows.time windows accessors alien.c-types combinators generalizations system alien.strings io.encodings.utf16n sequences splitting windows.errors fry continuations destructors -calendar ascii combinators.short-circuit ; +calendar ascii combinators.short-circuit locals ; IN: io.files.info.windows +:: round-up-to ( n multiple -- n' ) + n multiple rem dup 0 = [ + drop n + ] [ + multiple swap - n + + ] if ; + TUPLE: windows-file-info < file-info attributes ; +: get-compressed-file-size ( path -- n ) + "DWORD" [ GetCompressedFileSize ] keep + over INVALID_FILE_SIZE = [ + win32-error-string throw + ] [ + *uint >64bit + ] if ; + +: set-windows-size-on-disk ( file-info path -- file-info ) + over attributes>> +compressed+ swap member? [ + get-compressed-file-size + ] [ + drop dup size>> 4096 round-up-to + ] if >>size-on-disk ; + : WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info ) [ \ windows-file-info new ] dip { @@ -79,7 +101,9 @@ TUPLE: windows-file-info < file-info attributes ; ] if ; M: windows file-info ( path -- info ) - normalize-path get-file-information-stat ; + normalize-path + [ get-file-information-stat ] + [ set-windows-size-on-disk ] bi ; M: windows link-info ( path -- info ) file-info ; diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 4d3dd81a0e..1a513df186 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -1139,7 +1139,8 @@ FUNCTION: BOOL GetCommState ( HANDLE hFile, LPDCB lpDCB ) ; ! FUNCTION: GetCommTimeouts ! FUNCTION: GetComPlusPackageInstallStatus ! FUNCTION: GetCompressedFileSizeA -! FUNCTION: GetCompressedFileSizeW +FUNCTION: DWORD GetCompressedFileSizeW ( LPCTSTR lpFileName, LPDWORD lpFileSizeHigh ) ; +ALIAS: GetCompressedFileSize GetCompressedFileSizeW FUNCTION: BOOL GetComputerNameW ( LPTSTR lpBuffer, LPDWORD lpnSize ) ; ALIAS: GetComputerName GetComputerNameW FUNCTION: BOOL GetComputerNameExW ( COMPUTER_NAME_FORMAT NameType, LPTSTR lpBuffer, LPDWORD lpnSize ) ; From 12a89f15500cc5ff9b6a7fcdf08ede7e8ce391ca Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 17:25:18 -0500 Subject: [PATCH 416/772] fix size-on-disk for unix --- basis/io/files/info/unix/unix.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index d4762a536d..11fa3130d1 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -80,7 +80,7 @@ M: unix stat>file-info ( stat -- file-info ) [ stat-st_rdev >>rdev ] [ stat-st_blocks >>blocks ] [ stat-st_blksize >>blocksize ] - [ drop blocks>> blocksize>> * >>size-on-disk ] + [ drop dup [ blocks>> ] [ blocksize>> ] bi * >>size-on-disk ] } cleave ; : n>file-type ( n -- type ) From bd6eb42d0f48b412228dbc073ac4a31bdacd9f7a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 17:44:12 -0500 Subject: [PATCH 417/772] fix size-on-disk for unix --- basis/io/files/info/unix/unix.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index 11fa3130d1..80f4b74ac8 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -63,6 +63,8 @@ M: unix link-info ( path -- info ) M: unix new-file-info ( -- class ) unix-file-info new ; +CONSTANT: standard-unix-block-size 512 + M: unix stat>file-info ( stat -- file-info ) [ new-file-info ] dip { @@ -80,7 +82,7 @@ M: unix stat>file-info ( stat -- file-info ) [ stat-st_rdev >>rdev ] [ stat-st_blocks >>blocks ] [ stat-st_blksize >>blocksize ] - [ drop dup [ blocks>> ] [ blocksize>> ] bi * >>size-on-disk ] + [ drop dup blocks>> standard-unix-block-size * >>size-on-disk ] } cleave ; : n>file-type ( n -- type ) From bf0b1e63c812a2eb835165de55d93d0d19cd2e78 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 17:50:26 -0500 Subject: [PATCH 418/772] use link-info instead of file-info --- basis/io/directories/search/search.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 38d8ec957e..236da09489 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -83,15 +83,15 @@ ERROR: file-not-found ; ] with-directory ; inline : directory-size ( path -- n ) - 0 swap t [ file-info size-on-disk>> + ] each-file ; + 0 swap t [ link-info size-on-disk>> + ] each-file ; -: path>sizes ( path -- assoc ) +: directory-usage ( path -- assoc ) [ [ [ name>> dup ] [ directory? ] bi [ directory-size ] [ - file-info size-on-disk>> + link-info size-on-disk>> ] if ] { } map>assoc ] with-qualified-directory-entries sort-values ; From f73a29c1a52cc616506c8b6f5b21560044b1b2d5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 18:37:23 -0500 Subject: [PATCH 419/772] README.txt: don't mention GLUT --- README.txt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.txt b/README.txt index c5d53de842..c0d56dfa09 100755 --- a/README.txt +++ b/README.txt @@ -59,10 +59,10 @@ On Unix, Factor can either run a graphical user interface using X11, or a terminal listener. For X11 support, you need recent development libraries for libc, -Pango, X11, OpenGL and GLUT. On a Debian-derived Linux distribution +Pango, X11, and OpenGL. On a Debian-derived Linux distribution (like Ubuntu), you can use the following line to grab everything: - sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev glutg3-dev + sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev If your DISPLAY environment variable is set, the UI will start automatically: From 84146931429d31e7faff586f3e4476eddb73751e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 18:44:45 -0500 Subject: [PATCH 420/772] stack-checker: trust word declarations instead of recursively checking them --- basis/compiler/compiler.factor | 3 +- basis/compiler/tree/builder/builder.factor | 54 +++++++-------- .../tree/propagation/inlining/inlining.factor | 38 ++++++---- basis/hints/hints.factor | 2 +- basis/prettyprint/prettyprint-tests.factor | 1 - basis/stack-checker/backend/backend.factor | 69 ++++--------------- .../call-effect/call-effect.factor | 8 ++- basis/stack-checker/errors/errors.factor | 4 ++ .../known-words/known-words.factor | 7 +- .../recursive-state/recursive-state.factor | 25 ++----- basis/stack-checker/stack-checker-docs.factor | 9 --- .../stack-checker/stack-checker-tests.factor | 4 ++ basis/stack-checker/stack-checker.factor | 13 ---- basis/stack-checker/state/state.factor | 3 - .../transforms/transforms.factor | 28 +++++--- basis/tools/deploy/shaker/shaker.factor | 2 - core/classes/classes.factor | 2 +- core/classes/tuple/tuple.factor | 2 +- core/words/words-docs.factor | 4 -- core/words/words.factor | 37 +--------- 20 files changed, 114 insertions(+), 201 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index e5d88af14a..7c53e41377 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -57,7 +57,6 @@ SYMBOLS: +optimized+ +unoptimized+ ; { [ inline? ] [ macro? ] - [ "transform-quot" word-prop ] [ "no-compile" word-prop ] [ "special" word-prop ] } 1|| @@ -150,4 +149,4 @@ M: optimizing-compiler recompile ( words -- alist ) f compiler-impl set-global ; : recompile-all ( -- ) - forget-errors all-words compile ; + all-words compile ; diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index fe9c2a26a4..edea9ae6c0 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors quotations kernel sequences namespaces -assocs words arrays vectors hints combinators compiler.tree +assocs words arrays vectors hints combinators continuations +effects compiler.tree stack-checker stack-checker.state stack-checker.errors @@ -15,23 +16,27 @@ IN: compiler.tree.builder with-infer nip ; inline : build-tree ( quot -- nodes ) - #! Not safe to call from inference transforms. [ f initial-recursive-state infer-quot ] with-tree-builder ; : build-tree-with ( in-stack quot -- nodes out-stack ) - #! Not safe to call from inference transforms. [ - [ >vector \ meta-d set ] - [ f initial-recursive-state infer-quot ] bi* - ] with-tree-builder - unclip-last in-d>> ; + [ + [ >vector \ meta-d set ] + [ f initial-recursive-state infer-quot ] bi* + ] with-tree-builder + unclip-last in-d>> + ] [ "OOPS" USE: io print flush 3drop f f ] recover ; -: build-sub-tree ( #call quot -- nodes ) +: build-sub-tree ( #call quot -- nodes/f ) [ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with - over ends-with-terminate? - [ drop swap [ f swap #push ] map append ] - [ rot #copy suffix ] - if ; + { + { [ over not ] [ 3drop f ] } + { [ over ends-with-terminate? ] [ drop swap [ f swap #push ] map append ] } + [ rot #copy suffix ] + } cond ; + +: check-no-compile ( word -- ) + dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ; : (build-tree-from-word) ( word -- ) dup initial-recursive-state recursive-state set @@ -39,24 +44,19 @@ IN: compiler.tree.builder [ 1quotation ] [ specialized-def ] if infer-quot-here ; -: check-cannot-infer ( word -- ) - dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ; +: check-effect ( word effect -- ) + over required-stack-effect 2dup effect<= + [ 3drop ] [ effect-error ] if ; -TUPLE: do-not-compile word ; - -: check-no-compile ( word -- ) - dup "no-compile" word-prop [ do-not-compile inference-warning ] [ drop ] if ; +: finish-word ( word -- ) + current-effect check-effect ; : build-tree-from-word ( word -- nodes ) [ - [ - { - [ check-cannot-infer ] - [ check-no-compile ] - [ (build-tree-from-word) ] - [ finish-word ] - } cleave - ] maybe-cannot-infer + [ check-no-compile ] + [ (build-tree-from-word) ] + [ finish-word ] + tri ] with-tree-builder ; : contains-breakpoints? ( word -- ? ) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 7ae44a5293..b26ce3bed9 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -4,6 +4,7 @@ USING: accessors kernel arrays sequences math math.order math.partial-dispatch generic generic.standard generic.math classes.algebra classes.union sets quotations assocs combinators words namespaces continuations classes fry combinators.smart hints +locals compiler.tree compiler.tree.builder compiler.tree.recursive @@ -27,24 +28,30 @@ SYMBOL: node-count SYMBOL: inlining-count ! Splicing nodes -GENERIC: splicing-nodes ( #call word/quot/f -- nodes ) +GENERIC: splicing-nodes ( #call word/quot/f -- nodes/f ) M: word splicing-nodes [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; M: callable splicing-nodes - build-sub-tree analyze-recursive normalize ; + build-sub-tree dup [ analyze-recursive normalize ] when ; ! Dispatch elimination +: undo-inlining ( #call -- ? ) + f >>method f >>body f >>class drop f ; + +: propagate-body ( #call -- ? ) + body>> (propagate) t ; + : eliminate-dispatch ( #call class/f word/quot/f -- ? ) dup [ [ >>class ] dip - over method>> over = [ drop ] [ - 2dup splicing-nodes - [ >>method ] [ >>body ] bi* + over method>> over = [ drop propagate-body ] [ + 2dup splicing-nodes dup [ + [ >>method ] [ >>body ] bi* propagate-body + ] [ 2drop undo-inlining ] if ] if - body>> (propagate) t - ] [ 2drop f >>method f >>body f >>class drop f ] if ; + ] [ 2drop undo-inlining ] if ; : inlining-standard-method ( #call word -- class/f method/f ) dup "methods" word-prop assoc-empty? [ 2drop f f ] [ @@ -159,14 +166,15 @@ SYMBOL: history [ history [ swap suffix ] change ] bi ; -: inline-word-def ( #call word quot -- ? ) - over history get memq? [ 3drop f ] [ - [ - [ remember-inlining ] dip - [ drop ] [ splicing-nodes ] 2bi - [ >>body drop ] [ count-nodes ] [ (propagate) ] tri - ] with-scope node-count +@ - t +:: inline-word-def ( #call word quot -- ? ) + word history get memq? [ f ] [ + #call quot splicing-nodes [ + [ + word remember-inlining + [ ] [ count-nodes ] [ (propagate) ] tri + ] with-scope + [ #call (>>body) ] [ node-count +@ ] bi* t + ] [ f ] if* ] if ; : inline-word ( #call word -- ? ) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index d44bf92bf4..ed55c1c332 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -65,7 +65,7 @@ M: object specializer-declaration class ; SYNTAX: HINTS: scan-object - [ redefined ] + [ changed-definition ] [ parse-definition "specializer" set-word-prop ] bi ; ! Default specializers diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index a660d4a311..25ee83985e 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -86,7 +86,6 @@ unit-test drop ; [ "drop ;" ] [ - \ blah f "inferred-effect" set-word-prop [ \ blah see ] with-string-writer "\n" ?tail drop 6 tail* ] unit-test diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 9e867f4fbb..ed9c01b06c 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry arrays generic io io.streams.string kernel math namespaces parser sequences strings vectors words quotations effects classes continuations assocs combinators compiler.errors accessors math.order definitions sets -generic.standard.engines.tuple hints stack-checker.state +generic.standard.engines.tuple hints macros stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state ; IN: stack-checker.backend @@ -121,9 +121,6 @@ M: object apply-object push-literal ; : infer-r> ( n -- ) consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ; -: undo-infer ( -- ) - recorded get [ f "inferred-effect" set-word-prop ] each ; - : (consume/produce) ( effect -- inputs outputs ) [ in>> length consume-d ] [ out>> length produce-d ] bi ; @@ -132,65 +129,29 @@ M: object apply-object push-literal ; [ terminated?>> [ terminate ] when ] bi ; inline -: infer-word-def ( word -- ) - [ specialized-def ] [ add-recursive-state ] bi infer-quot ; - : end-infer ( -- ) meta-d clone #return, ; : required-stack-effect ( word -- effect ) dup stack-effect [ ] [ missing-effect ] ?if ; -: check-effect ( word effect -- ) - over required-stack-effect 2dup effect<= - [ 3drop ] [ effect-error ] if ; - -: finish-word ( word -- ) - [ current-effect check-effect ] - [ recorded get push ] - [ t "inferred-effect" set-word-prop ] - tri ; - -: cannot-infer-effect ( word -- * ) - "cannot-infer" word-prop rethrow ; - -: maybe-cannot-infer ( word quot -- ) - [ [ "cannot-infer" set-word-prop ] keep rethrow ] recover ; inline - -: infer-word ( word -- effect ) - [ - [ - init-inference - init-known-values - stack-visitor off - dependencies off - generic-dependencies off - [ infer-word-def end-infer ] - [ finish-word ] - [ stack-effect ] - tri - ] with-scope - ] maybe-cannot-infer ; - : apply-word/effect ( word effect -- ) swap '[ _ #call, ] consume/produce ; -: call-recursive-word ( word -- ) - dup required-stack-effect apply-word/effect ; - -: cached-infer ( word -- ) - dup stack-effect apply-word/effect ; +: infer-word ( word -- ) + { + { [ dup macro? ] [ do-not-compile ] } + { [ dup "no-compile" word-prop ] [ do-not-compile ] } + [ dup required-stack-effect apply-word/effect ] + } cond ; : with-infer ( quot -- effect visitor ) [ - [ - V{ } clone recorded set - init-inference - init-known-values - stack-visitor off - call - end-infer - current-effect - stack-visitor get - ] [ ] [ undo-infer ] cleanup + init-inference + init-known-values + stack-visitor off + call + end-infer + current-effect + stack-visitor get ] with-scope ; inline diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/stack-checker/call-effect/call-effect.factor index bd1f7c73c3..100088f174 100644 --- a/basis/stack-checker/call-effect/call-effect.factor +++ b/basis/stack-checker/call-effect/call-effect.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators combinators.private effects fry kernel kernel.private make sequences continuations quotations -stack-checker stack-checker.transforms ; +stack-checker stack-checker.transforms words ; IN: stack-checker.call-effect ! call( and execute( have complex expansions. @@ -54,6 +54,8 @@ M: quotation cached-effect \ call-effect-slow [ call-effect-slow>quot ] 1 define-transform +\ call-effect-slow t "no-compile" set-word-prop + : call-effect-fast ( quot effect inline-cache -- ) 2over call-effect-unsafe? [ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ] @@ -71,6 +73,8 @@ M: quotation cached-effect ] ] 0 define-transform +\ call-effect t "no-compile" set-word-prop + : execute-effect-slow ( word effect -- ) [ '[ _ execute ] ] dip call-effect-slow ; inline @@ -93,3 +97,5 @@ M: quotation cached-effect inline-cache new '[ _ _ execute-effect-ic ] ; \ execute-effect [ execute-effect>quot ] 1 define-transform + +\ execute-effect t "no-compile" set-word-prop \ No newline at end of file diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index 156900f727..cb45d65954 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -24,6 +24,10 @@ M: inference-error error-type type>> ; : inference-warning ( ... class -- * ) +compiler-warning+ (inference-error) ; inline +TUPLE: do-not-compile word ; + +: do-not-compile ( word -- * ) \ do-not-compile inference-warning ; + TUPLE: literal-expected what ; : literal-expected ( what -- * ) \ literal-expected inference-warning ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index abc1f68bb6..85aa9030f8 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -219,6 +219,8 @@ M: object infer-call* } [ t "special" set-word-prop ] each M\ quotation call t "no-compile" set-word-prop +M\ curry call t "no-compile" set-word-prop +M\ compose call t "no-compile" set-word-prop M\ word execute t "no-compile" set-word-prop \ clear t "no-compile" set-word-prop @@ -230,14 +232,11 @@ M\ word execute t "no-compile" set-word-prop { [ dup "primitive" word-prop ] [ infer-primitive ] } { [ dup "transform-quot" word-prop ] [ apply-transform ] } { [ dup "macro" word-prop ] [ apply-macro ] } - { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] } - { [ dup "inferred-effect" word-prop ] [ cached-infer ] } { [ dup local? ] [ infer-local-reader ] } { [ dup local-reader? ] [ infer-local-reader ] } { [ dup local-writer? ] [ infer-local-writer ] } { [ dup local-word? ] [ infer-local-word ] } - { [ dup recursive-word? ] [ call-recursive-word ] } - [ dup infer-word apply-word/effect ] + [ infer-word ] } cond ; : define-primitive ( word inputs outputs -- ) diff --git a/basis/stack-checker/recursive-state/recursive-state.factor b/basis/stack-checker/recursive-state/recursive-state.factor index 9abfb1fcd5..7740bebf4c 100644 --- a/basis/stack-checker/recursive-state/recursive-state.factor +++ b/basis/stack-checker/recursive-state/recursive-state.factor @@ -1,39 +1,26 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays sequences kernel sequences assocs namespaces stack-checker.recursive-state.tree ; IN: stack-checker.recursive-state -TUPLE: recursive-state word words quotations inline-words ; - -: prepare-recursive-state ( word rstate -- rstate ) - swap >>word - f >>quotations - f >>inline-words ; inline +TUPLE: recursive-state word quotations inline-words ; : initial-recursive-state ( word -- state ) recursive-state new - f >>words - prepare-recursive-state ; inline + swap >>word + f >>quotations + f >>inline-words ; inline f initial-recursive-state recursive-state set-global -: add-recursive-state ( word -- rstate ) - recursive-state get clone - [ word>> dup ] keep [ store ] change-words - prepare-recursive-state ; - -: add-local-quotation ( recursive-state quot -- rstate ) +: add-local-quotation ( rstate quot -- rstate ) swap clone [ dupd store ] change-quotations ; : add-inline-word ( word label -- rstate ) swap recursive-state get clone [ store ] change-inline-words ; -: recursive-word? ( word -- ? ) - recursive-state get 2dup word>> eq? - [ 2drop t ] [ words>> lookup ] if ; - : inline-recursive-label ( word -- label/f ) recursive-state get inline-words>> lookup ; diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 28090918bb..78196abfba 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -109,7 +109,6 @@ HELP: inference-error "The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "." } ; - HELP: infer { $values { "quot" "a quotation" } { "effect" "an instance of " { $link effect } } } { $description "Attempts to infer the quotation's stack effect. For interactive testing, the " { $link infer. } " word should be called instead since it presents the output in a nicely formatted manner." } @@ -121,11 +120,3 @@ HELP: infer. { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; { infer infer. } related-words - -HELP: forget-errors -{ $description "Removes markers indicating which words do not have stack effects." -$nl -"The stack effect inference code remembers which words failed to infer as an optimization, so that it does not try to infer the stack effect of words which do not have one over and over again." } -{ $notes "Usually this word does not need to be called directly; if a word failed to compile because of a stack effect error, fixing the word definition clears the flag automatically. However, if words failed to compile due to external factors which were subsequently rectified, such as an unavailable C library or a missing or broken compiler transform, this flag can be cleared for all words:" -{ $code "forget-errors" } -"Subsequent invocations of the compiler will consider all words for compilation." } ; diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 6b9e9fd8b6..6ac4fce0c0 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -588,3 +588,7 @@ DEFER: eee' [ forget-test ] must-infer [ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test [ forget-test ] must-infer + +[ [ cond ] infer ] must-fail +[ [ bi ] infer ] must-fail +[ at ] must-infer \ No newline at end of file diff --git a/basis/stack-checker/stack-checker.factor b/basis/stack-checker/stack-checker.factor index e18a6f0840..759988a61f 100644 --- a/basis/stack-checker/stack-checker.factor +++ b/basis/stack-checker/stack-checker.factor @@ -16,17 +16,4 @@ M: callable infer ( quot -- effect ) #! Safe to call from inference transforms. infer effect>string print ; -: forget-errors ( -- ) - all-words [ - dup subwords [ f "cannot-infer" set-word-prop ] each - f "cannot-infer" set-word-prop - ] each ; - -: forget-effects ( -- ) - forget-errors - all-words [ - dup subwords [ f "inferred-effect" set-word-prop ] each - f "inferred-effect" set-word-prop - ] each ; - "stack-checker.call-effect" require \ No newline at end of file diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 6ae12dbd0c..a76d302a7e 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -64,6 +64,3 @@ SYMBOL: generic-dependencies : depends-on-generic ( generic class -- ) generic-dependencies get dup [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ; - -! Words we've inferred the stack effect of, for rollback -SYMBOL: recorded diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index fd62c4998d..2e66d7d728 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -10,13 +10,6 @@ stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state ; IN: stack-checker.transforms -: give-up-transform ( word -- ) - { - { [ dup "inferred-effect" word-prop ] [ cached-infer ] } - { [ dup recursive-word? ] [ call-recursive-word ] } - [ dup infer-word apply-word/effect ] - } cond ; - : call-transformer ( word stack quot -- newquot ) '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ] [ transform-expansion-error ] @@ -29,7 +22,7 @@ IN: stack-checker.transforms word inlined-dependency depends-on values [ length meta-d shorten-by ] [ #drop, ] bi rstate infer-quot - ] [ word give-up-transform ] if* ; + ] [ word infer-word ] if* ; : literals? ( values -- ? ) [ literal-value? ] all? ; @@ -41,7 +34,7 @@ IN: stack-checker.transforms [ first literal recursion>> ] tri ] if ((apply-transform)) - ] [ 2drop give-up-transform ] if ; + ] [ 2drop infer-word ] if ; : apply-transform ( word -- ) [ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri @@ -59,6 +52,8 @@ IN: stack-checker.transforms ! Combinators \ cond [ cond>quot ] 1 define-transform +\ cond t "no-compile" set-word-prop + \ case [ [ [ no-case ] @@ -71,14 +66,24 @@ IN: stack-checker.transforms ] if-empty ] 1 define-transform +\ case t "no-compile" set-word-prop + \ cleave [ cleave>quot ] 1 define-transform +\ cleave t "no-compile" set-word-prop + \ 2cleave [ 2cleave>quot ] 1 define-transform +\ 2cleave t "no-compile" set-word-prop + \ 3cleave [ 3cleave>quot ] 1 define-transform +\ 3cleave t "no-compile" set-word-prop + \ spread [ spread>quot ] 1 define-transform +\ spread t "no-compile" set-word-prop + \ (call-next-method) [ [ [ "method-class" word-prop ] @@ -90,6 +95,8 @@ IN: stack-checker.transforms ] bi ] 1 define-transform +\ (call-next-method) t "no-compile" set-word-prop + ! Constructors \ boa [ dup tuple-class? [ @@ -100,6 +107,9 @@ IN: stack-checker.transforms ] [ drop f ] if ] 1 define-transform +\ boa t "no-compile" set-word-prop +M\ tuple-class boa t "no-compile" set-word-prop + \ new [ dup tuple-class? [ dup inlined-dependency depends-on diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index ba0daf6056..807abe4d58 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -97,7 +97,6 @@ IN: tools.deploy.shaker { "alias" "boa-check" - "cannot-infer" "coercer" "combination" "compiled-status" @@ -116,7 +115,6 @@ IN: tools.deploy.shaker "identities" "if-intrinsics" "infer" - "inferred-effect" "inline" "inlined-block" "input-classes" diff --git a/core/classes/classes.factor b/core/classes/classes.factor index ab8ba398cd..dfaec95f76 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -135,7 +135,7 @@ M: sequence implementors [ implementors ] gather ; [ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ] [ reset-class ] [ ?define-symbol ] - [ redefined ] + [ changed-definition ] [ ] } cleave ] dip [ assoc-union ] curry change-props diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index fb7a073205..fb1e613b3e 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -243,7 +243,7 @@ M: tuple-class update-class 2drop [ [ update-tuples-after ] - [ redefined ] + [ changed-definition ] bi ] each-subclass ] diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index c20ee66de8..4bed65374c 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -104,10 +104,6 @@ $nl { { { $snippet "\"help\"" } ", " { $snippet "\"help-loc\"" } ", " { $snippet "\"help-parent\"" } } { "Where word help is stored - " { $link "writing-help" } } } - { { $snippet "\"infer\"" } { $link "macros" } } - - { { { $snippet "\"inferred-effect\"" } } { $link "inference" } } - { { $snippet "\"specializer\"" } { $link "hints" } } { { $snippet "\"predicating\"" } " Set on class predicates, stores the corresponding class word" } diff --git a/core/words/words.factor b/core/words/words.factor index c388f093fd..97225c0f75 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -131,43 +131,10 @@ GENERIC: subwords ( word -- seq ) M: word subwords drop f ; - - -: redefined ( word -- ) - [ H{ } clone visited [ (redefined) ] with-variable ] - [ changed-definition ] - bi ; - : define ( word def -- ) [ ] like over unxref - over redefined + over changed-definition >>def dup crossref? [ dup xref ] when drop ; @@ -176,7 +143,7 @@ PRIVATE> swap [ drop changed-effect ] [ "declared-effect" set-word-prop ] - [ drop dup primitive? [ drop ] [ redefined ] if ] + [ drop dup primitive? [ drop ] [ changed-definition ] if ] 2tri ] if ; From e8d695e3144d3c589f6a4475585fbf8cdf5adcca Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 19:01:33 -0500 Subject: [PATCH 421/772] refactoring directory searching --- basis/io/directories/search/search.factor | 39 +++++++++++++---------- 1 file changed, 22 insertions(+), 17 deletions(-) diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 236da09489..1346fbbdb8 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -3,7 +3,7 @@ USING: accessors arrays continuations deques dlists fry io.directories io.files io.files.info io.pathnames kernel sequences system vocabs.loader locals math namespaces -sorting assocs ; +sorting assocs calendar threads ; IN: io.directories.search > + ] each-file ; + 0 swap t [ + [ link-info size-on-disk>> + ] [ 2drop ] recover + ] each-file ; + +: path>usage ( directory-entry -- name size ) + [ name>> dup ] [ directory? ] bi [ + directory-size + ] [ + [ link-info size-on-disk>> ] [ drop 0 ] recover + ] if ; : directory-usage ( path -- assoc ) [ - [ - [ name>> dup ] [ directory? ] bi [ - directory-size - ] [ - link-info size-on-disk>> - ] if - ] { } map>assoc + [ [ path>usage ] [ drop name>> 0 ] recover ] { } map>assoc ] with-qualified-directory-entries sort-values ; os windows? [ "io.directories.search.windows" require ] when From 3af8f7fba128fc6781c45a7053cd5ba203e8aeb9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 19:11:07 -0500 Subject: [PATCH 422/772] search for emacs.exe on windows by default --- basis/editors/emacs/emacs.factor | 5 ++++- basis/editors/emacs/windows/windows.factor | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/basis/editors/emacs/emacs.factor b/basis/editors/emacs/emacs.factor index 366bc53104..31fcaf114e 100644 --- a/basis/editors/emacs/emacs.factor +++ b/basis/editors/emacs/emacs.factor @@ -11,7 +11,10 @@ M: object default-emacsclient ( -- path ) "emacsclient" ; : emacsclient ( file line -- ) [ - { [ emacsclient-path get ] [ default-emacsclient ] } 0|| , + { + [ emacsclient-path get-global ] + [ default-emacsclient dup emacsclient-path set-global ] + } 0|| , "--no-wait" , number>string "+" prepend , , diff --git a/basis/editors/emacs/windows/windows.factor b/basis/editors/emacs/windows/windows.factor index 91d6e878e4..0b8efcf3ae 100755 --- a/basis/editors/emacs/windows/windows.factor +++ b/basis/editors/emacs/windows/windows.factor @@ -8,5 +8,5 @@ M: windows default-emacsclient { [ "Emacs" [ "emacsclientw.exe" tail? ] find-in-program-files ] [ "Emacs" [ "emacsclient.exe" tail? ] find-in-program-files ] - [ "emacsclient.exe" ] + [ "emacs.exe" ] } 0|| ; From 3d895de0cc9468aa3d3bde14d549e1f1ddb09ae1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 19:11:47 -0500 Subject: [PATCH 423/772] oops, really search for emacs.exe --- basis/editors/emacs/windows/windows.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/editors/emacs/windows/windows.factor b/basis/editors/emacs/windows/windows.factor index 0b8efcf3ae..0fb6c8e68c 100755 --- a/basis/editors/emacs/windows/windows.factor +++ b/basis/editors/emacs/windows/windows.factor @@ -8,5 +8,6 @@ M: windows default-emacsclient { [ "Emacs" [ "emacsclientw.exe" tail? ] find-in-program-files ] [ "Emacs" [ "emacsclient.exe" tail? ] find-in-program-files ] + [ "Emacs" [ "emacs.exe" tail? ] find-in-program-files ] [ "emacs.exe" ] } 0|| ; From be2639c1680f04416d8be3e0405b5afaa834c169 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 19:52:50 -0500 Subject: [PATCH 424/772] look for emacsclient.exe not emacs.exe --- basis/editors/emacs/windows/windows.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/editors/emacs/windows/windows.factor b/basis/editors/emacs/windows/windows.factor index 0fb6c8e68c..91d6e878e4 100755 --- a/basis/editors/emacs/windows/windows.factor +++ b/basis/editors/emacs/windows/windows.factor @@ -8,6 +8,5 @@ M: windows default-emacsclient { [ "Emacs" [ "emacsclientw.exe" tail? ] find-in-program-files ] [ "Emacs" [ "emacsclient.exe" tail? ] find-in-program-files ] - [ "Emacs" [ "emacs.exe" tail? ] find-in-program-files ] - [ "emacs.exe" ] + [ "emacsclient.exe" ] } 0|| ; From 0d0c7f2d552770b3570dbd99025093f9fac3a669 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 20:05:17 -0500 Subject: [PATCH 425/772] Fix unit test failures caused by stricter type checking in M: encoder stream-write --- basis/io/encodings/8-bit/8-bit-tests.factor | 6 ++-- basis/io/encodings/ascii/ascii-tests.factor | 4 +-- .../io/encodings/gb18030/gb18030-tests.factor | 6 ++-- basis/io/encodings/utf16/utf16-tests.factor | 28 ++++++++-------- basis/io/encodings/utf32/utf32-tests.factor | 32 +++++++++---------- .../byte-array/byte-array-tests.factor | 4 +-- basis/io/streams/string/string.factor | 5 +-- basis/smtp/smtp.factor | 19 +++++------ basis/tools/profiler/profiler-docs.factor | 2 +- core/io/encodings/utf8/utf8-tests.factor | 2 +- 10 files changed, 55 insertions(+), 53 deletions(-) diff --git a/basis/io/encodings/8-bit/8-bit-tests.factor b/basis/io/encodings/8-bit/8-bit-tests.factor index 8b18e2a9af..55b9c44934 100644 --- a/basis/io/encodings/8-bit/8-bit-tests.factor +++ b/basis/io/encodings/8-bit/8-bit-tests.factor @@ -4,11 +4,11 @@ IN: io.encodings.8-bit.tests [ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test [ { 256 } >string latin1 encode ] must-fail -[ B{ 255 } ] [ { 255 } latin1 encode ] unit-test +[ B{ 255 } ] [ { 255 } >string latin1 encode ] unit-test [ "bar" ] [ "bar" latin1 decode ] unit-test -[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test -[ { HEX: fffd HEX: 20AC } ] [ { HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test +[ { CHAR: b 233 CHAR: r } ] [ B{ CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test +[ { HEX: fffd HEX: 20AC } ] [ B{ HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test [ t ] [ \ latin1 8-bit-encoding? ] unit-test [ "bar" ] [ "bar" \ latin1 decode ] unit-test diff --git a/basis/io/encodings/ascii/ascii-tests.factor b/basis/io/encodings/ascii/ascii-tests.factor index 4f6d28835a..fcd549d31f 100644 --- a/basis/io/encodings/ascii/ascii-tests.factor +++ b/basis/io/encodings/ascii/ascii-tests.factor @@ -3,7 +3,7 @@ IN: io.encodings.ascii.tests [ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" ascii encode ] unit-test [ { 128 } >string ascii encode ] must-fail -[ B{ 127 } ] [ { 127 } ascii encode ] unit-test +[ B{ 127 } ] [ { 127 } >string ascii encode ] unit-test [ "bar" ] [ "bar" ascii decode ] unit-test -[ { CHAR: b HEX: fffd CHAR: r } ] [ { CHAR: b 233 CHAR: r } ascii decode >array ] unit-test +[ { CHAR: b HEX: fffd CHAR: r } ] [ B{ CHAR: b 233 CHAR: r } ascii decode >array ] unit-test diff --git a/basis/io/encodings/gb18030/gb18030-tests.factor b/basis/io/encodings/gb18030/gb18030-tests.factor index 20ea522a4d..da44d1cf9a 100644 --- a/basis/io/encodings/gb18030/gb18030-tests.factor +++ b/basis/io/encodings/gb18030/gb18030-tests.factor @@ -6,7 +6,7 @@ IN: io.encodings.gb18030.tests [ "hello" ] [ "hello" gb18030 encode >string ] unit-test [ "hello" ] [ "hello" gb18030 decode ] unit-test [ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 HEX: 86 HEX: 30 } ] -[ B{ HEX: B7 HEX: B8 } gb18030 encode ] unit-test +[ B{ HEX: B7 HEX: B8 } >string gb18030 encode ] unit-test [ { HEX: B7 HEX: B8 } ] [ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 HEX: 86 HEX: 30 } gb18030 decode >array ] unit-test [ { HEX: B7 CHAR: replacement-character } ] @@ -18,9 +18,9 @@ IN: io.encodings.gb18030.tests [ { HEX: B7 } ] [ B{ HEX: A1 HEX: A4 } gb18030 decode >array ] unit-test [ { CHAR: replacement-character } ] -[ B{ HEX: A1 } gb18030 decode >array ] unit-test +[ B{ HEX: A1 } >string gb18030 decode >array ] unit-test [ { HEX: 44D7 HEX: 464B } ] [ B{ HEX: 82 HEX: 33 HEX: A3 HEX: 39 HEX: 82 HEX: 33 HEX: C9 HEX: 31 } gb18030 decode >array ] unit-test [ { HEX: 82 HEX: 33 HEX: A3 HEX: 39 HEX: 82 HEX: 33 HEX: C9 HEX: 31 } ] -[ { HEX: 44D7 HEX: 464B } gb18030 encode >array ] unit-test +[ { HEX: 44D7 HEX: 464B } >string gb18030 encode >array ] unit-test diff --git a/basis/io/encodings/utf16/utf16-tests.factor b/basis/io/encodings/utf16/utf16-tests.factor index 230612cc77..e16c1f822e 100644 --- a/basis/io/encodings/utf16/utf16-tests.factor +++ b/basis/io/encodings/utf16/utf16-tests.factor @@ -1,25 +1,25 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test io.encodings.utf16 arrays sbufs -io.streams.byte-array sequences io.encodings io +io.streams.byte-array sequences io.encodings io strings io.encodings.string alien.c-types alien.strings accessors classes ; IN: io.encodings.utf16.tests -[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test -[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test +[ { CHAR: x } ] [ B{ 0 CHAR: x } utf16be decode >array ] unit-test +[ { HEX: 1D11E } ] [ B{ HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test -[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode >array ] unit-test +[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } >string utf16be encode >array ] unit-test -[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode >array ] unit-test -[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test +[ { CHAR: x } ] [ B{ CHAR: x 0 } utf16le decode >array ] unit-test +[ { 119070 } ] [ B{ HEX: 34 HEX: D8 HEX: 1E HEX: DD } >string utf16le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } >string utf16le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } >string utf16le decode >array ] unit-test -[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test +[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16le encode >array ] unit-test -[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test -[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test +[ { CHAR: x } ] [ B{ HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test +[ { CHAR: x } ] [ B{ HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test -[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test +[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16 encode >array ] unit-test diff --git a/basis/io/encodings/utf32/utf32-tests.factor b/basis/io/encodings/utf32/utf32-tests.factor index be1111e242..2a80e47c7b 100644 --- a/basis/io/encodings/utf32/utf32-tests.factor +++ b/basis/io/encodings/utf32/utf32-tests.factor @@ -1,30 +1,30 @@ ! Copyright (C) 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test io.encodings.utf32 arrays sbufs -io.streams.byte-array sequences io.encodings io +io.streams.byte-array sequences io.encodings io strings io.encodings.string alien.c-types alien.strings accessors classes ; IN: io.encodings.utf32.tests -[ { CHAR: x } ] [ { 0 0 0 CHAR: x } utf32be decode >array ] unit-test -[ { HEX: 1D11E } ] [ { 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 1 HEX: D1 } utf32be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 1 } utf32be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 } utf32be decode >array ] unit-test +[ { CHAR: x } ] [ B{ 0 0 0 CHAR: x } utf32be decode >array ] unit-test +[ { HEX: 1D11E } ] [ B{ 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ 0 1 HEX: D1 } utf32be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ 0 1 } utf32be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ 0 } utf32be decode >array ] unit-test [ { } ] [ { } utf32be decode >array ] unit-test -[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } utf32be encode >array ] unit-test +[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } >string utf32be encode >array ] unit-test -[ { CHAR: x } ] [ { CHAR: x 0 0 0 } utf32le decode >array ] unit-test -[ { HEX: 1d11e } ] [ { HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 } utf32le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { HEX: 1e } utf32le decode >array ] unit-test +[ { CHAR: x } ] [ B{ CHAR: x 0 0 0 } utf32le decode >array ] unit-test +[ { HEX: 1d11e } ] [ B{ HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ HEX: 1e HEX: d1 } utf32le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ HEX: 1e } utf32le decode >array ] unit-test [ { } ] [ { } utf32le decode >array ] unit-test -[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32le encode >array ] unit-test +[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32le encode >array ] unit-test -[ { CHAR: x } ] [ { HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test -[ { CHAR: x } ] [ { 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test +[ { CHAR: x } ] [ B{ HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test +[ { CHAR: x } ] [ B{ 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test -[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32 encode >array ] unit-test +[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32 encode >array ] unit-test diff --git a/basis/io/streams/byte-array/byte-array-tests.factor b/basis/io/streams/byte-array/byte-array-tests.factor index 44290bfb47..3cf52c6a78 100644 --- a/basis/io/streams/byte-array/byte-array-tests.factor +++ b/basis/io/streams/byte-array/byte-array-tests.factor @@ -1,11 +1,11 @@ USING: tools.test io.streams.byte-array io.encodings.binary io.encodings.utf8 io kernel arrays strings namespaces ; -[ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test +[ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test [ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test [ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ] -[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test +[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test [ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 contents dup >array swap string? ] unit-test [ B{ 121 120 } 0 ] [ diff --git a/basis/io/streams/string/string.factor b/basis/io/streams/string/string.factor index a0087a70ee..85cb3022f5 100644 --- a/basis/io/streams/string/string.factor +++ b/basis/io/streams/string/string.factor @@ -33,5 +33,6 @@ M: sbuf stream-element-type drop +character+ ; 512 ; : with-string-writer ( quot -- str ) - swap [ output-stream get ] compose with-output-stream* - >string ; inline \ No newline at end of file + [ + swap with-output-stream* + ] keep >string ; inline \ No newline at end of file diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index bfba9ea28a..83457defa5 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -1,12 +1,12 @@ -! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, +! Copyright (C) 2007, 2009 Elie CHAFTARI, Dirk Vleugels, ! Slava Pestov, Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays namespaces make io io.encodings.string io.encodings.utf8 -io.encodings.iana io.timeouts io.sockets io.sockets.secure -io.encodings.ascii kernel logging sequences combinators splitting -assocs strings math.order math.parser random system calendar summary -calendar.format accessors sets hashtables base64 debugger classes -prettyprint io.crlf words ; +USING: arrays namespaces make io io.encodings io.encodings.string +io.encodings.utf8 io.encodings.iana io.encodings.binary +io.encodings.ascii io.timeouts io.sockets io.sockets.secure io.crlf +kernel logging sequences combinators splitting assocs strings +math.order math.parser random system calendar summary calendar.format +accessors sets hashtables base64 debugger classes prettyprint words ; IN: smtp SYMBOL: smtp-domain @@ -88,8 +88,9 @@ M: message-contains-dot summary ( obj -- string ) [ message-contains-dot ] when ; : send-body ( email -- ) - [ body>> ] [ encoding>> ] bi encode - >base64-lines write crlf + binary encode-output + [ body>> ] [ encoding>> ] bi encode >base64-lines write + ascii encode-output crlf "." command ; : quit ( -- ) diff --git a/basis/tools/profiler/profiler-docs.factor b/basis/tools/profiler/profiler-docs.factor index a786cdfef1..baecbd71c1 100644 --- a/basis/tools/profiler/profiler-docs.factor +++ b/basis/tools/profiler/profiler-docs.factor @@ -23,7 +23,7 @@ $nl { $subsection vocabs-profile. } { $subsection method-profile. } { $subsection "profiler-limitations" } -{ $see-also "ui-profiler" } ; +{ $see-also "ui.tools.profiler" } ; ABOUT: "profiling" diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor index 6cd3ee8033..088131acf9 100755 --- a/core/io/encodings/utf8/utf8-tests.factor +++ b/core/io/encodings/utf8/utf8-tests.factor @@ -6,7 +6,7 @@ IN: io.encodings.utf8.tests utf8 decode >array ; : encode-utf8-w/stream ( array -- newarray ) - utf8 encode >array ; + >string utf8 encode >array ; [ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream ] unit-test From 19be5cd5e55d3dc5653e3d66e46b0f4c001d2481 Mon Sep 17 00:00:00 2001 From: "U-HPLAPTOP\\Ken" Date: Mon, 20 Apr 2009 21:06:42 -0500 Subject: [PATCH 426/772] word change --- basis/help/cookbook/cookbook.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index 9bb76f8d5a..cd26c6856e 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -67,7 +67,7 @@ $nl } "In Factor, this example will print 3 since word redefinition is explicitly supported." $nl - "Indeed, redefining a word twice in the same source file is an error; this is almost always a mistake since there's no way to call the first definition. See " { $link "definition-checking" } "." + "However, redefining a word twice in the same source file is an error; this is almost always a mistake since there's no way to call the first definition. See " { $link "definition-checking" } "." } { $references { "A whole slew of shuffle words can be used to rearrange the stack. There are forms of word definition other than colon definition, words can be defined entirely at runtime, and word definitions can be " { $emphasis "annotated" } " with tracing calls and breakpoints without modifying the source code." } From 08d80f623742d396a9626d2242470c9d43ccf1d0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 21:11:50 -0500 Subject: [PATCH 427/772] use HOMEDRIVE/HOMEPATH for HOME, then USERPROFILE, the default to a directory if no env vars are set --- basis/io/files/windows/nt/nt.factor | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/basis/io/files/windows/nt/nt.factor b/basis/io/files/windows/nt/nt.factor index 9e449982fb..afc81c784c 100755 --- a/basis/io/files/windows/nt/nt.factor +++ b/basis/io/files/windows/nt/nt.factor @@ -4,7 +4,7 @@ io.backend.windows io.files.windows io.encodings.utf16n windows windows.kernel32 kernel libc math threads system environment alien.c-types alien.arrays alien.strings sequences combinators combinators.short-circuit ascii splitting alien strings assocs -namespaces make accessors tr windows.time ; +namespaces make accessors tr windows.time windows.shell32 ; IN: io.files.windows.nt M: winnt cwd @@ -58,4 +58,9 @@ M: winnt open-append [ dup windows-file-size ] [ drop 0 ] recover [ (open-append) ] dip >>ptr ; -M: winnt home "USERPROFILE" os-env ; +M: winnt home + { + [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ] + [ "USERPROFILE" os-env ] + [ my-documents ] + } 0|| ; From 05f3f9dcb90b2228c56a3999c8a3fd1f8f544bd7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 21:15:19 -0500 Subject: [PATCH 428/772] Fixing unit tests for stack effect inference changes --- basis/alarms/alarms-tests.factor | 2 - basis/alien/c-types/c-types-tests.factor | 2 - basis/base64/base64-tests.factor | 3 - .../binary-search/binary-search-tests.factor | 2 - basis/bootstrap/image/image-tests.factor | 3 - basis/calendar/calendar-tests.factor | 4 - .../format/macros/macros-tests.factor | 2 +- basis/combinators/smart/smart-tests.factor | 2 +- .../compiler/cfg/builder/builder-tests.factor | 2 - .../assignment/assignment-tests.factor | 2 +- .../linearization/linearization-tests.factor | 2 +- basis/compiler/tests/insane.factor | 5 - basis/compiler/tests/optimizer.factor | 6 +- basis/compiler/tests/redefine1.factor | 38 --- basis/compiler/tests/redefine16.factor | 3 +- basis/compiler/tests/simple.factor | 2 - .../tree/builder/builder-tests.factor | 26 +- .../tree/checker/checker-tests.factor | 2 +- .../tree/dead-code/dead-code-tests.factor | 2 - .../tree/debugger/debugger-tests.factor | 3 - .../tree/def-use/def-use-tests.factor | 2 - .../escape-analysis-tests.factor | 2 - .../normalization/normalization-tests.factor | 3 - .../tree/optimizer/optimizer-tests.factor | 2 +- .../tree/propagation/propagation-tests.factor | 2 - .../tree/recursive/recursive-tests.factor | 6 - .../tuple-unboxing-tests.factor | 2 - basis/db/pools/pools-tests.factor | 2 - basis/db/tuples/tuples-tests.factor | 11 - basis/functors/functors-tests.factor | 2 - basis/furnace/auth/auth-tests.factor | 3 - .../edit-profile/edit-profile-tests.factor | 2 +- .../recover-password-tests.factor | 2 +- .../registration/registration-tests.factor | 2 +- basis/furnace/auth/login/login-tests.factor | 2 +- basis/furnace/db/db-tests.factor | 2 +- basis/help/markup/markup-tests.factor | 2 - basis/help/topics/topics-tests.factor | 5 - basis/html/components/components-tests.factor | 2 - basis/http/client/client-tests.factor | 2 - .../dispatchers/dispatchers-tests.factor | 2 - .../redirection/redirection-tests.factor | 2 - basis/http/server/server-tests.factor | 2 - basis/io/files/info/info-tests.factor | 3 - basis/io/launcher/launcher-tests.factor | 3 - .../monitors/recursive/recursive-tests.factor | 2 - basis/io/monitors/windows/nt/nt-tests.factor | 2 +- .../io/sockets/secure/unix/unix-tests.factor | 1 - basis/io/styles/styles-tests.factor | 6 - basis/lcs/lcs-tests.factor | 4 - basis/locals/backend/backend-tests.factor | 6 +- basis/locals/locals-tests.factor | 45 ++-- basis/math/bitwise/bitwise-tests.factor | 2 +- basis/models/models-tests.factor | 3 - basis/peg/peg-tests.factor | 2 - basis/peg/search/search-tests.factor | 2 - basis/persistent/vectors/vectors-tests.factor | 4 - basis/regexp/regexp-tests.factor | 4 - basis/smtp/smtp-tests.factor | 2 - .../stack-checker/stack-checker-tests.factor | 234 +----------------- .../transforms/transforms-tests.factor | 5 + basis/syndication/syndication-tests.factor | 3 - basis/tools/memory/memory-tests.factor | 3 - basis/tools/test/test-docs.factor | 4 +- basis/tools/test/test-tests.factor | 2 - basis/tools/test/test.factor | 3 +- basis/ui/event-loop/event-loop-tests.factor | 2 - basis/ui/gadgets/books/books-tests.factor | 2 - basis/ui/gadgets/buttons/buttons-tests.factor | 4 - basis/ui/gadgets/editors/editors-tests.factor | 2 - basis/ui/gadgets/gadgets-tests.factor | 13 - .../gadgets/scrollers/scrollers-tests.factor | 2 - basis/ui/gestures/gestures-tests.factor | 3 - basis/ui/operations/operations-tests.factor | 2 - basis/ui/render/render-tests.factor | 2 - basis/ui/tools/browser/browser-tests.factor | 1 - .../ui/tools/inspector/inspector-tests.factor | 2 - basis/ui/tools/listener/listener-tests.factor | 2 - basis/ui/tools/profiler/profiler-tests.factor | 2 +- basis/ui/tools/walker/walker-tests.factor | 1 - basis/ui/ui-tests.factor | 3 - basis/unicode/case/case-tests.factor | 4 - basis/unix/groups/groups-tests.factor | 2 - basis/unix/users/users-tests.factor | 3 - basis/wrap/strings/strings-tests.factor | 2 - basis/wrap/words/words-tests.factor | 1 - basis/xml/syntax/syntax-tests.factor | 3 - basis/xml/tests/test.factor | 2 - basis/xml/writer/writer-tests.factor | 3 - basis/xmode/code2html/code2html-tests.factor | 2 - core/checksums/checksums-tests.factor | 4 - core/classes/algebra/algebra-tests.factor | 6 - core/classes/tuple/tuple-tests.factor | 2 +- core/combinators/combinators-tests.factor | 22 +- core/continuations/continuations-tests.factor | 2 +- core/io/files/files-tests.factor | 3 - core/parser/parser-tests.factor | 2 - extra/contributors/contributors-tests.factor | 1 - extra/infix/parser/parser-tests.factor | 3 - extra/infix/tokenizer/tokenizer-tests.factor | 1 - extra/mason/cleanup/cleanup-tests.factor | 2 - .../mason/release/upload/upload-tests.factor | 1 - extra/multi-methods/tests/definitions.factor | 3 - extra/peg/javascript/javascript-tests.factor | 2 - .../peg/javascript/parser/parser-tests.factor | 2 - .../tokenizer/tokenizer-tests.factor | 2 - 106 files changed, 92 insertions(+), 553 deletions(-) delete mode 100644 basis/compiler/tests/insane.factor diff --git a/basis/alarms/alarms-tests.factor b/basis/alarms/alarms-tests.factor index d1161e4cee..7c64680a83 100644 --- a/basis/alarms/alarms-tests.factor +++ b/basis/alarms/alarms-tests.factor @@ -15,5 +15,3 @@ tools.test threads concurrency.count-downs ; [ resume ] curry instant later drop ] "test" suspend drop ] unit-test - -\ alarm-thread-loop must-infer diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index 988dc180e0..ea9e881fd4 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -2,8 +2,6 @@ IN: alien.c-types.tests USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc alien.strings io.encodings.utf8 ; -\ expand-constants must-infer - CONSTANT: xyz 123 [ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test diff --git a/basis/base64/base64-tests.factor b/basis/base64/base64-tests.factor index 572d8a5227..9094286575 100644 --- a/basis/base64/base64-tests.factor +++ b/basis/base64/base64-tests.factor @@ -25,6 +25,3 @@ IN: base64.tests [ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ] [ malformed-base64? ] must-fail-with - -\ >base64 must-infer -\ base64> must-infer diff --git a/basis/binary-search/binary-search-tests.factor b/basis/binary-search/binary-search-tests.factor index 77b1c16505..63d2697418 100644 --- a/basis/binary-search/binary-search-tests.factor +++ b/basis/binary-search/binary-search-tests.factor @@ -1,8 +1,6 @@ IN: binary-search.tests USING: binary-search math.order vectors kernel tools.test ; -\ sorted-member? must-infer - [ f ] [ 3 { } [ <=> ] with search drop ] unit-test [ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test [ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test diff --git a/basis/bootstrap/image/image-tests.factor b/basis/bootstrap/image/image-tests.factor index c432a47ea4..e7070d3cf2 100644 --- a/basis/bootstrap/image/image-tests.factor +++ b/basis/bootstrap/image/image-tests.factor @@ -2,9 +2,6 @@ IN: bootstrap.image.tests USING: bootstrap.image bootstrap.image.private tools.test kernel math ; -\ ' must-infer -\ write-image must-infer - [ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test [ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor index b6d8e74072..256b4e1b42 100644 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -2,10 +2,6 @@ USING: arrays calendar kernel math sequences tools.test continuations system math.order threads ; IN: calendar.tests -\ time+ must-infer -\ time* must-infer -\ time- must-infer - [ f ] [ 2004 12 32 0 0 0 instant valid-timestamp? ] unit-test [ f ] [ 2004 2 30 0 0 0 instant valid-timestamp? ] unit-test [ f ] [ 2003 2 29 0 0 0 instant valid-timestamp? ] unit-test diff --git a/basis/calendar/format/macros/macros-tests.factor b/basis/calendar/format/macros/macros-tests.factor index 544332770f..48567539ad 100644 --- a/basis/calendar/format/macros/macros-tests.factor +++ b/basis/calendar/format/macros/macros-tests.factor @@ -10,6 +10,6 @@ IN: calendar.format.macros : compiled-test-1 ( -- n ) { [ 1 throw ] [ 2 ] } attempt-all-quots ; -\ compiled-test-1 must-infer +\ compiled-test-1 def>> must-infer [ 2 ] [ compiled-test-1 ] unit-test diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 1cca697dde..080379e924 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -42,7 +42,7 @@ IN: combinators.smart.tests : nested-smart-combo-test ( -- array ) [ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ; -\ nested-smart-combo-test must-infer +\ nested-smart-combo-test def>> must-infer [ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 0b303a8a43..58eae8181b 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -5,8 +5,6 @@ math.private compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays kernel.private math ; -\ build-cfg must-infer - ! Just ensure that various CFGs build correctly. : unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor index 9efc23651b..13c1783711 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor @@ -1,4 +1,4 @@ USING: compiler.cfg.linear-scan.assignment tools.test ; IN: compiler.cfg.linear-scan.assignment.tests -\ assign-registers must-infer + diff --git a/basis/compiler/cfg/linearization/linearization-tests.factor b/basis/compiler/cfg/linearization/linearization-tests.factor index 5e866d15db..fe8b4fd0c0 100644 --- a/basis/compiler/cfg/linearization/linearization-tests.factor +++ b/basis/compiler/cfg/linearization/linearization-tests.factor @@ -1,4 +1,4 @@ IN: compiler.cfg.linearization.tests USING: compiler.cfg.linearization tools.test ; -\ build-mr must-infer + diff --git a/basis/compiler/tests/insane.factor b/basis/compiler/tests/insane.factor deleted file mode 100644 index aa79067252..0000000000 --- a/basis/compiler/tests/insane.factor +++ /dev/null @@ -1,5 +0,0 @@ -IN: compiler.tests -USING: words kernel stack-checker alien.strings tools.test -compiler.units ; - -[ ] [ [ \ if redefined ] with-compilation-unit [ string>alien ] infer. ] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 3aed47ae7e..23b69b06b9 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -261,7 +261,7 @@ USE: binary-search.private : lift-loop-tail-test-2 ( -- a b c ) 10 [ ] lift-loop-tail-test-1 1 2 3 ; -\ lift-loop-tail-test-2 must-infer +\ lift-loop-tail-test-2 def>> must-infer [ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test @@ -302,7 +302,7 @@ HINTS: recursive-inline-hang-3 array ; : member-test ( obj -- ? ) { + - * / /i } member? ; -\ member-test must-infer +\ member-test def>> must-infer [ ] [ \ member-test build-tree-from-word optimize-tree drop ] unit-test [ t ] [ \ + member-test ] unit-test [ f ] [ \ append member-test ] unit-test @@ -325,7 +325,7 @@ PREDICATE: list < improper-list dup "a" get { array-capacity } declare >= [ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ; -\ interval-inference-bug must-infer +[ t ] [ \ interval-inference-bug optimized>> ] unit-test [ ] [ 1 "a" set 2 "b" set ] unit-test [ 2 3 ] [ 2 interval-inference-bug ] unit-test diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor index 8145ad628b..a28b183fb6 100644 --- a/basis/compiler/tests/redefine1.factor +++ b/basis/compiler/tests/redefine1.factor @@ -36,41 +36,3 @@ M: integer method-redefine-generic-2 3 + ; fixnum string [ \ method-redefine-generic-2 method forget ] bi@ ] with-compilation-unit ] unit-test - -! Test ripple-up behavior -: hey ( -- ) ; -: there ( -- ) hey ; - -[ t ] [ \ hey optimized>> ] unit-test -[ t ] [ \ there optimized>> ] unit-test -[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval( -- ) ] unit-test -[ f ] [ \ hey optimized>> ] unit-test -[ f ] [ \ there optimized>> ] unit-test -[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval( -- ) ] unit-test -[ t ] [ \ there optimized>> ] unit-test - -: good ( -- ) ; -: bad ( -- ) good ; -: ugly ( -- ) bad ; - -[ t ] [ \ good optimized>> ] unit-test -[ t ] [ \ bad optimized>> ] unit-test -[ t ] [ \ ugly optimized>> ] unit-test - -[ f ] [ \ good compiled-usage assoc-empty? ] unit-test - -[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval( -- ) ] unit-test - -[ f ] [ \ good optimized>> ] unit-test -[ f ] [ \ bad optimized>> ] unit-test -[ f ] [ \ ugly optimized>> ] unit-test - -[ t ] [ \ good compiled-usage assoc-empty? ] unit-test - -[ ] [ "IN: compiler.tests : good ( -- ) ;" eval( -- ) ] unit-test - -[ t ] [ \ good optimized>> ] unit-test -[ t ] [ \ bad optimized>> ] unit-test -[ t ] [ \ ugly optimized>> ] unit-test - -[ f ] [ \ good compiled-usage assoc-empty? ] unit-test diff --git a/basis/compiler/tests/redefine16.factor b/basis/compiler/tests/redefine16.factor index e0bb1773c9..264b9b0675 100644 --- a/basis/compiler/tests/redefine16.factor +++ b/basis/compiler/tests/redefine16.factor @@ -6,5 +6,4 @@ quotations stack-checker ; [ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test [ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test -[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test -[ "blah" "compiler.tests.redefine16" lookup 1quotation infer ] must-fail +[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index 769182a8b1..11b27979d5 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -3,8 +3,6 @@ sequences.private math.private math combinators strings alien arrays memory vocabs parser eval ; IN: compiler.tests -\ (compile) must-infer - ! Test empty word [ ] [ [ ] compile-call ] unit-test diff --git a/basis/compiler/tree/builder/builder-tests.factor b/basis/compiler/tree/builder/builder-tests.factor index 4982a3986c..9668272957 100755 --- a/basis/compiler/tree/builder/builder-tests.factor +++ b/basis/compiler/tree/builder/builder-tests.factor @@ -1,11 +1,27 @@ IN: compiler.tree.builder.tests USING: compiler.tree.builder tools.test sequences kernel -compiler.tree ; - -\ build-tree must-infer -\ build-tree-with must-infer -\ build-tree-from-word must-infer +compiler.tree stack-checker stack-checker.errors ; : inline-recursive ( -- ) inline-recursive ; inline recursive [ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? ] unit-test + +: bad-recursion-1 ( a -- b ) + dup [ drop bad-recursion-1 5 ] [ ] if ; + +[ \ bad-recursion-1 build-tree-from-word ] [ inference-error? ] must-fail-with + +FORGET: bad-recursion-1 + +: bad-recursion-2 ( obj -- obj ) + dup [ dup first swap second bad-recursion-2 ] [ ] if ; + +[ \ bad-recursion-2 build-tree-from-word ] [ inference-error? ] must-fail-with + +FORGET: bad-recursion-2 + +: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; + +[ \ bad-bin build-tree-from-word ] [ inference-error? ] must-fail-with + +FORGET: bad-bin diff --git a/basis/compiler/tree/checker/checker-tests.factor b/basis/compiler/tree/checker/checker-tests.factor index 5a8706b900..d9591e7be2 100644 --- a/basis/compiler/tree/checker/checker-tests.factor +++ b/basis/compiler/tree/checker/checker-tests.factor @@ -1,4 +1,4 @@ IN: compiler.tree.checker.tests USING: compiler.tree.checker tools.test ; -\ check-nodes must-infer + diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor index 7c28866e94..ed4df91eec 100644 --- a/basis/compiler/tree/dead-code/dead-code-tests.factor +++ b/basis/compiler/tree/dead-code/dead-code-tests.factor @@ -9,8 +9,6 @@ accessors combinators io prettyprint words sequences.deep sequences.private arrays classes kernel.private ; IN: compiler.tree.dead-code.tests -\ remove-dead-code must-infer - : count-live-values ( quot -- n ) build-tree analyze-recursive diff --git a/basis/compiler/tree/debugger/debugger-tests.factor b/basis/compiler/tree/debugger/debugger-tests.factor index 9b4a6da12a..9bacd51be1 100644 --- a/basis/compiler/tree/debugger/debugger-tests.factor +++ b/basis/compiler/tree/debugger/debugger-tests.factor @@ -1,8 +1,5 @@ IN: compiler.tree.debugger.tests USING: compiler.tree.debugger tools.test sorting sequences io math.order ; -\ optimized. must-infer -\ optimizer-report. must-infer - [ [ <=> ] sort ] optimized. [ [ print ] each ] optimizer-report. \ No newline at end of file diff --git a/basis/compiler/tree/def-use/def-use-tests.factor b/basis/compiler/tree/def-use/def-use-tests.factor index d970e04afd..227a1f1dd7 100644 --- a/basis/compiler/tree/def-use/def-use-tests.factor +++ b/basis/compiler/tree/def-use/def-use-tests.factor @@ -7,8 +7,6 @@ compiler.tree.def-use arrays kernel.private sorting math.order binary-search compiler.tree.checker ; IN: compiler.tree.def-use.tests -\ compute-def-use must-infer - [ t ] [ [ 1 2 3 ] build-tree compute-def-use drop def-use get { diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index 9a226b954f..bcb8b2f80a 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -11,8 +11,6 @@ compiler.tree.propagation.info stack-checker.errors compiler.tree.checker kernel.private ; -\ escape-analysis must-infer - GENERIC: count-unboxed-allocations* ( m node -- n ) : (count-unboxed-allocations) ( m node -- n ) diff --git a/basis/compiler/tree/normalization/normalization-tests.factor b/basis/compiler/tree/normalization/normalization-tests.factor index 680ae0b170..3b4574effe 100644 --- a/basis/compiler/tree/normalization/normalization-tests.factor +++ b/basis/compiler/tree/normalization/normalization-tests.factor @@ -6,9 +6,6 @@ compiler.tree.normalization.renaming compiler.tree compiler.tree.checker sequences accessors tools.test kernel math ; -\ count-introductions must-infer -\ normalize must-infer - [ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test [ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree count-introductions ] unit-test diff --git a/basis/compiler/tree/optimizer/optimizer-tests.factor b/basis/compiler/tree/optimizer/optimizer-tests.factor index 1075e441e7..5d05947b8a 100644 --- a/basis/compiler/tree/optimizer/optimizer-tests.factor +++ b/basis/compiler/tree/optimizer/optimizer-tests.factor @@ -1,4 +1,4 @@ USING: compiler.tree.optimizer tools.test ; IN: compiler.tree.optimizer.tests -\ optimize-tree must-infer + diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 5b9b49811f..f6308ac40a 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -12,8 +12,6 @@ specialized-arrays.double system sorting math.libm math.intervals ; IN: compiler.tree.propagation.tests -\ propagate must-infer - [ V{ } ] [ [ ] final-classes ] unit-test [ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test diff --git a/basis/compiler/tree/recursive/recursive-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor index 971675d367..80edae076f 100644 --- a/basis/compiler/tree/recursive/recursive-tests.factor +++ b/basis/compiler/tree/recursive/recursive-tests.factor @@ -10,8 +10,6 @@ compiler.tree.combinators ; [ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test [ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test -\ analyze-recursive must-infer - : label-is-loop? ( nodes word -- ? ) [ { @@ -21,8 +19,6 @@ compiler.tree.combinators ; } 2&& ] curry contains-node? ; -\ label-is-loop? must-infer - : label-is-not-loop? ( nodes word -- ? ) [ { @@ -32,8 +28,6 @@ compiler.tree.combinators ; } 2&& ] curry contains-node? ; -\ label-is-not-loop? must-infer - : loop-test-1 ( a -- ) dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index 81ba01f1e2..8654a6f983 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -8,8 +8,6 @@ compiler.tree.def-use kernel accessors sequences math math.private sorting math.order binary-search sequences.private slots.private ; -\ unbox-tuples must-infer - : test-unboxing ( quot -- ) build-tree analyze-recursive diff --git a/basis/db/pools/pools-tests.factor b/basis/db/pools/pools-tests.factor index 7ff2a33d92..334ff9e11a 100644 --- a/basis/db/pools/pools-tests.factor +++ b/basis/db/pools/pools-tests.factor @@ -2,8 +2,6 @@ IN: db.pools.tests USING: db.pools tools.test continuations io.files io.files.temp io.directories namespaces accessors kernel math destructors ; -\ must-infer - { 1 0 } [ [ ] with-db-pool ] must-infer-as { 1 0 } [ [ ] with-pooled-db ] must-infer-as diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 375ee509bb..afdee3e89f 100644 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -592,17 +592,6 @@ string-encoding-test "STRING_ENCODING_TEST" { [ test-string-encoding ] test-sqlite [ test-string-encoding ] test-postgresql -! Don't comment these out. These words must infer -\ bind-tuple must-infer -\ insert-tuple must-infer -\ update-tuple must-infer -\ delete-tuples must-infer -\ select-tuple must-infer -\ define-persistent must-infer -\ ensure-table must-infer -\ create-table must-infer -\ drop-table must-infer - : test-queries ( -- ) [ ] [ exam ensure-table ] unit-test [ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index b4417532b4..37ec1d3e15 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -43,8 +43,6 @@ WHERE >> -\ sqsq must-infer - [ 16 ] [ 2 sqsq ] unit-test << diff --git a/basis/furnace/auth/auth-tests.factor b/basis/furnace/auth/auth-tests.factor index 220a8cd04c..54c32e7b4a 100644 --- a/basis/furnace/auth/auth-tests.factor +++ b/basis/furnace/auth/auth-tests.factor @@ -1,6 +1,3 @@ USING: furnace.auth tools.test ; IN: furnace.auth.tests -\ logged-in-username must-infer -\ must-infer -\ new-realm must-infer diff --git a/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor b/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor index d0fdf22c27..996047e83d 100644 --- a/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor +++ b/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor @@ -1,4 +1,4 @@ IN: furnace.auth.features.edit-profile.tests USING: tools.test furnace.auth.features.edit-profile ; -\ allow-edit-profile must-infer + diff --git a/basis/furnace/auth/features/recover-password/recover-password-tests.factor b/basis/furnace/auth/features/recover-password/recover-password-tests.factor index b589c52624..313b8ef397 100644 --- a/basis/furnace/auth/features/recover-password/recover-password-tests.factor +++ b/basis/furnace/auth/features/recover-password/recover-password-tests.factor @@ -1,4 +1,4 @@ IN: furnace.auth.features.recover-password USING: tools.test furnace.auth.features.recover-password ; -\ allow-password-recovery must-infer + diff --git a/basis/furnace/auth/features/registration/registration-tests.factor b/basis/furnace/auth/features/registration/registration-tests.factor index e770f35586..42acda416c 100644 --- a/basis/furnace/auth/features/registration/registration-tests.factor +++ b/basis/furnace/auth/features/registration/registration-tests.factor @@ -1,4 +1,4 @@ IN: furnace.auth.features.registration.tests USING: tools.test furnace.auth.features.registration ; -\ allow-registration must-infer + diff --git a/basis/furnace/auth/login/login-tests.factor b/basis/furnace/auth/login/login-tests.factor index 64f7bd3b96..aabd0c5c30 100644 --- a/basis/furnace/auth/login/login-tests.factor +++ b/basis/furnace/auth/login/login-tests.factor @@ -1,4 +1,4 @@ IN: furnace.auth.login.tests USING: tools.test furnace.auth.login ; -\ must-infer + diff --git a/basis/furnace/db/db-tests.factor b/basis/furnace/db/db-tests.factor index 34357ae701..15698d8e9b 100644 --- a/basis/furnace/db/db-tests.factor +++ b/basis/furnace/db/db-tests.factor @@ -1,4 +1,4 @@ IN: furnace.db.tests USING: tools.test furnace.db ; -\ must-infer + diff --git a/basis/help/markup/markup-tests.factor b/basis/help/markup/markup-tests.factor index 9b928f3691..bcd8843b24 100644 --- a/basis/help/markup/markup-tests.factor +++ b/basis/help/markup/markup-tests.factor @@ -26,5 +26,3 @@ TUPLE: blahblah quux ; [ "a string, a fixnum, or an integer" ] [ [ { $or string fixnum integer } print-element ] with-string-writer ] unit-test -\ print-element must-infer -\ print-topic must-infer \ No newline at end of file diff --git a/basis/help/topics/topics-tests.factor b/basis/help/topics/topics-tests.factor index ac9223b5d2..cafeb009a4 100644 --- a/basis/help/topics/topics-tests.factor +++ b/basis/help/topics/topics-tests.factor @@ -3,11 +3,6 @@ help.markup help.syntax kernel sequences tools.test words parser namespaces assocs source-files eval ; IN: help.topics.tests -\ article-name must-infer -\ article-title must-infer -\ article-content must-infer -\ article-parent must-infer - ! Test help cross-referencing [ ] [ "Test B" { "Hello world." }
    { "test" "b" } add-article ] unit-test diff --git a/basis/html/components/components-tests.factor b/basis/html/components/components-tests.factor index 72ceea20a0..da2e5b5991 100644 --- a/basis/html/components/components-tests.factor +++ b/basis/html/components/components-tests.factor @@ -4,8 +4,6 @@ io.streams.null accessors inspector html.streams html.components html.forms namespaces xml.writer ; -\ render must-infer - [ ] [ begin-form ] unit-test [ ] [ 3 "hi" set-value ] unit-test diff --git a/basis/http/client/client-tests.factor b/basis/http/client/client-tests.factor index 4dcc6b8813..4f786cb22c 100644 --- a/basis/http/client/client-tests.factor +++ b/basis/http/client/client-tests.factor @@ -1,8 +1,6 @@ USING: http.client http.client.private http tools.test namespaces urls ; -\ download must-infer - [ "localhost" f ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test diff --git a/basis/http/server/dispatchers/dispatchers-tests.factor b/basis/http/server/dispatchers/dispatchers-tests.factor index 2c8db27259..08974aca3b 100644 --- a/basis/http/server/dispatchers/dispatchers-tests.factor +++ b/basis/http/server/dispatchers/dispatchers-tests.factor @@ -3,8 +3,6 @@ tools.test kernel namespaces accessors io http math sequences assocs arrays classes words urls ; IN: http.server.dispatchers.tests -\ find-responder must-infer - TUPLE: mock-responder path ; C: mock-responder diff --git a/basis/http/server/redirection/redirection-tests.factor b/basis/http/server/redirection/redirection-tests.factor index 14855ca875..72ff111db9 100644 --- a/basis/http/server/redirection/redirection-tests.factor +++ b/basis/http/server/redirection/redirection-tests.factor @@ -2,8 +2,6 @@ IN: http.server.redirection.tests USING: http http.server.redirection urls accessors namespaces tools.test present kernel ; -\ relative-to-request must-infer - [ diff --git a/basis/http/server/server-tests.factor b/basis/http/server/server-tests.factor index 171973fcd8..3dc97098a4 100644 --- a/basis/http/server/server-tests.factor +++ b/basis/http/server/server-tests.factor @@ -4,8 +4,6 @@ IN: http.server.tests [ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test -\ make-http-error must-infer - [ "text/plain; charset=UTF-8" ] [ "text/plain" >>content-type diff --git a/basis/io/files/info/info-tests.factor b/basis/io/files/info/info-tests.factor index b94bc0635c..7b19f56b10 100644 --- a/basis/io/files/info/info-tests.factor +++ b/basis/io/files/info/info-tests.factor @@ -3,9 +3,6 @@ io.directories kernel io.pathnames accessors tools.test sequences io.files.temp ; IN: io.files.info.tests -\ file-info must-infer -\ link-info must-infer - [ t ] [ temp-directory [ "hi41" "test41" utf8 set-file-contents ] with-directory temp-directory "test41" append-path utf8 file-contents "hi41" = diff --git a/basis/io/launcher/launcher-tests.factor b/basis/io/launcher/launcher-tests.factor index 003f382020..da7284dbe5 100644 --- a/basis/io/launcher/launcher-tests.factor +++ b/basis/io/launcher/launcher-tests.factor @@ -1,6 +1,3 @@ IN: io.launcher.tests USING: tools.test io.launcher ; -\ must-infer -\ must-infer -\ must-infer diff --git a/basis/io/monitors/recursive/recursive-tests.factor b/basis/io/monitors/recursive/recursive-tests.factor index ace93ace44..db8e02ae73 100644 --- a/basis/io/monitors/recursive/recursive-tests.factor +++ b/basis/io/monitors/recursive/recursive-tests.factor @@ -4,8 +4,6 @@ concurrency.mailboxes tools.test destructors io.files.info io.pathnames io.files.temp io.directories.hierarchy ; IN: io.monitors.recursive.tests -\ pump-thread must-infer - SINGLETON: mock-io-backend TUPLE: counter i ; diff --git a/basis/io/monitors/windows/nt/nt-tests.factor b/basis/io/monitors/windows/nt/nt-tests.factor index 79cd7e9e9f..a7ee649400 100644 --- a/basis/io/monitors/windows/nt/nt-tests.factor +++ b/basis/io/monitors/windows/nt/nt-tests.factor @@ -1,4 +1,4 @@ IN: io.monitors.windows.nt.tests USING: io.monitors.windows.nt tools.test ; -\ fill-queue-thread must-infer + diff --git a/basis/io/sockets/secure/unix/unix-tests.factor b/basis/io/sockets/secure/unix/unix-tests.factor index a3bfacc8a8..7c4dcc17d1 100644 --- a/basis/io/sockets/secure/unix/unix-tests.factor +++ b/basis/io/sockets/secure/unix/unix-tests.factor @@ -5,7 +5,6 @@ io.backend.unix classes words destructors threads tools.test concurrency.promises byte-arrays locals calendar io.timeouts io.sockets.secure.unix.debug ; -\ must-infer { 1 0 } [ [ ] with-secure-context ] must-infer-as [ ] [ "port" set ] unit-test diff --git a/basis/io/styles/styles-tests.factor b/basis/io/styles/styles-tests.factor index 86c3681c2a..0259e4ab0b 100644 --- a/basis/io/styles/styles-tests.factor +++ b/basis/io/styles/styles-tests.factor @@ -1,8 +1,2 @@ IN: io.styles.tests USING: io.styles tools.test ; - -\ stream-format must-infer -\ stream-write-table must-infer -\ make-span-stream must-infer -\ make-block-stream must-infer -\ make-cell-stream must-infer \ No newline at end of file diff --git a/basis/lcs/lcs-tests.factor b/basis/lcs/lcs-tests.factor index 7d9a9ffd27..3aa10a0687 100644 --- a/basis/lcs/lcs-tests.factor +++ b/basis/lcs/lcs-tests.factor @@ -2,10 +2,6 @@ ! See http://factorcode.org/license.txt for BSD license. USING: tools.test lcs ; -\ lcs must-infer -\ diff must-infer -\ levenshtein must-infer - [ 3 ] [ "sitting" "kitten" levenshtein ] unit-test [ 3 ] [ "kitten" "sitting" levenshtein ] unit-test [ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test diff --git a/basis/locals/backend/backend-tests.factor b/basis/locals/backend/backend-tests.factor index ee714f7ef7..ad78516059 100644 --- a/basis/locals/backend/backend-tests.factor +++ b/basis/locals/backend/backend-tests.factor @@ -1,14 +1,14 @@ IN: locals.backend.tests -USING: tools.test locals.backend kernel arrays ; +USING: tools.test locals.backend kernel arrays accessors ; : get-local-test-1 ( -- x ) 3 1 load-locals 0 get-local 1 drop-locals ; -\ get-local-test-1 must-infer +\ get-local-test-1 def>> must-infer [ 3 ] [ get-local-test-1 ] unit-test : get-local-test-2 ( -- x ) 3 4 2 load-locals -1 get-local 2 drop-locals ; -\ get-local-test-2 must-infer +\ get-local-test-2 def>> must-infer [ 3 ] [ get-local-test-2 ] unit-test diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index d472a8b22b..68fa8dbda0 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -43,8 +43,8 @@ IN: locals.tests [ { 1 2 } ] [ 2 let-test-4 ] unit-test -:: let-test-5 ( a -- b ) - a [let | a [ ] b [ ] | a b 2array ] ; +:: let-test-5 ( a b -- b ) + a b [let | a [ ] b [ ] | a b 2array ] ; [ { 2 1 } ] [ 1 2 let-test-5 ] unit-test @@ -129,7 +129,8 @@ write-test-2 "q" set SYMBOL: a :: use-test ( a b c -- a b c ) - USE: kernel ; + USE: kernel + a b c ; [ t ] [ a symbol? ] unit-test @@ -171,9 +172,9 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ; [ ] [ \ lambda-generic see ] unit-test -:: unparse-test-1 ( a -- ) [let | a! [ ] | ] ; +:: unparse-test-1 ( a -- ) [let | a! [ 3 ] | ] ; -[ "[let | a! [ ] | ]" ] [ +[ "[let | a! [ 3 ] | ]" ] [ \ unparse-test-1 "lambda" word-prop body>> first unparse ] unit-test @@ -286,7 +287,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; { [ a b > ] [ 5 ] } } cond ; -\ cond-test must-infer +\ cond-test def>> must-infer [ 3 ] [ 1 2 cond-test ] unit-test [ 4 ] [ 2 2 cond-test ] unit-test @@ -295,7 +296,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; :: 0&&-test ( a -- ? ) { [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ; -\ 0&&-test must-infer +\ 0&&-test def>> must-infer [ f ] [ 1.5 0&&-test ] unit-test [ f ] [ 3 0&&-test ] unit-test @@ -305,7 +306,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; :: &&-test ( a -- ? ) { [ a integer? ] [ a even? ] [ a 10 > ] } && ; -\ &&-test must-infer +\ &&-test def>> must-infer [ f ] [ 1.5 &&-test ] unit-test [ f ] [ 3 &&-test ] unit-test @@ -321,7 +322,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; ] ] ; -\ let-and-cond-test-1 must-infer +\ let-and-cond-test-1 def>> must-infer [ 20 ] [ let-and-cond-test-1 ] unit-test @@ -332,7 +333,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; ] ] ; -\ let-and-cond-test-2 must-infer +\ let-and-cond-test-2 def>> must-infer [ { 10 20 } ] [ let-and-cond-test-2 ] unit-test @@ -388,7 +389,7 @@ ERROR: punned-class x ; { 5 [ a a ^ ] } } case ; -\ big-case-test must-infer +\ big-case-test def>> must-infer [ 9 ] [ 3 big-case-test ] unit-test @@ -400,7 +401,7 @@ ERROR: punned-class x ; [| x | x 12 + { "howdy" } nth ] } case ; -\ littledan-case-problem-1 must-infer +\ littledan-case-problem-1 def>> must-infer [ "howdy" ] [ -12 \ littledan-case-problem-1 def>> call ] unit-test [ "howdy" ] [ -12 littledan-case-problem-1 ] unit-test @@ -412,7 +413,7 @@ ERROR: punned-class x ; [| x | x a - { "howdy" } nth ] } case ; -\ littledan-case-problem-2 must-infer +\ littledan-case-problem-2 def>> must-infer [ "howdy" ] [ -12 \ littledan-case-problem-2 def>> call ] unit-test [ "howdy" ] [ -12 littledan-case-problem-2 ] unit-test @@ -424,7 +425,7 @@ ERROR: punned-class x ; [| x | x a - { "howdy" } nth ] } cond ; -\ littledan-cond-problem-1 must-infer +\ littledan-cond-problem-1 def>> must-infer [ f ] [ -12 \ littledan-cond-problem-1 def>> call ] unit-test [ 4 ] [ 12 \ littledan-cond-problem-1 def>> call ] unit-test @@ -448,12 +449,12 @@ ERROR: punned-class x ; : littledan-case-problem-4 ( a -- b ) [ 1 + ] littledan-case-problem-3 ; -\ littledan-case-problem-4 must-infer +\ littledan-case-problem-4 def>> must-infer */ GENERIC: lambda-method-forget-test ( a -- b ) -M:: integer lambda-method-forget-test ( a -- b ) ; +M:: integer lambda-method-forget-test ( a -- b ) a ; [ ] [ [ M\ integer lambda-method-forget-test forget ] with-compilation-unit ] unit-test @@ -467,7 +468,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ; :: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline : funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ; -\ funny-macro-test must-infer +\ funny-macro-test def>> must-infer [ t ] [ 3 funny-macro-test ] unit-test [ f ] [ 2 funny-macro-test ] unit-test @@ -483,11 +484,11 @@ M:: integer lambda-method-forget-test ( a -- b ) ; :: FAILdog-1 ( -- b ) { [| c | c ] } ; -\ FAILdog-1 must-infer +\ FAILdog-1 def>> must-infer :: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ; -\ FAILdog-2 must-infer +\ FAILdog-2 def>> must-infer [ 3 ] [ 3 [| a | \ a ] call ] unit-test @@ -518,7 +519,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ; { [ is-integer? ] [ is-even? ] [ >10? ] } && ] ; -\ wlet-&&-test must-infer +\ wlet-&&-test def>> must-infer [ f ] [ 1.5 wlet-&&-test ] unit-test [ f ] [ 3 wlet-&&-test ] unit-test [ f ] [ 8 wlet-&&-test ] unit-test @@ -527,13 +528,13 @@ M:: integer lambda-method-forget-test ( a -- b ) ; : fry-locals-test-1 ( -- n ) [let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ; -\ fry-locals-test-1 must-infer +\ fry-locals-test-1 def>> must-infer [ 10 ] [ fry-locals-test-1 ] unit-test :: fry-locals-test-2 ( -- n ) [let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ; -\ fry-locals-test-2 must-infer +\ fry-locals-test-2 def>> must-infer [ 10 ] [ fry-locals-test-2 ] unit-test [ 1 ] [ 3 4 [| | '[ [ _ swap - ] call ] call ] call ] unit-test diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor index 7698760f84..e10853af18 100644 --- a/basis/math/bitwise/bitwise-tests.factor +++ b/basis/math/bitwise/bitwise-tests.factor @@ -26,7 +26,7 @@ CONSTANT: b 2 [ 3 ] [ foo ] unit-test [ 3 ] [ { a b } flags ] unit-test -\ foo must-infer +\ foo def>> must-infer [ 1 ] [ { 1 } flags ] unit-test diff --git a/basis/models/models-tests.factor b/basis/models/models-tests.factor index f875fa3140..7368a2aa54 100644 --- a/basis/models/models-tests.factor +++ b/basis/models/models-tests.factor @@ -31,6 +31,3 @@ T{ model-tester f f } "tester" set "tester" get "model-c" get value>> ] unit-test - -\ model-changed must-infer -\ set-model must-infer diff --git a/basis/peg/peg-tests.factor b/basis/peg/peg-tests.factor index 7d5cb1e76a..9a15dd2105 100644 --- a/basis/peg/peg-tests.factor +++ b/basis/peg/peg-tests.factor @@ -5,8 +5,6 @@ USING: kernel tools.test strings namespaces make arrays sequences peg peg.private peg.parsers accessors words math accessors ; IN: peg.tests -\ parse must-infer - [ ] [ reset-pegs ] unit-test [ diff --git a/basis/peg/search/search-tests.factor b/basis/peg/search/search-tests.factor index 96d89d4611..b22a5ef0d0 100644 --- a/basis/peg/search/search-tests.factor +++ b/basis/peg/search/search-tests.factor @@ -17,5 +17,3 @@ IN: peg.search.tests "abc 123 def 456" 'integer' [ 2 * number>string ] action replace ] unit-test -\ search must-infer -\ replace must-infer diff --git a/basis/persistent/vectors/vectors-tests.factor b/basis/persistent/vectors/vectors-tests.factor index c232db8533..95fa70558d 100644 --- a/basis/persistent/vectors/vectors-tests.factor +++ b/basis/persistent/vectors/vectors-tests.factor @@ -3,10 +3,6 @@ USING: accessors tools.test persistent.vectors persistent.sequences sequences kernel arrays random namespaces vectors math math.order ; -\ new-nth must-infer -\ ppush must-infer -\ ppop must-infer - [ 0 ] [ PV{ } length ] unit-test [ 1 ] [ 3 PV{ } ppush length ] unit-test diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 0479b104cc..1f72fa04ba 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -4,10 +4,6 @@ USING: regexp tools.test kernel sequences regexp.parser regexp.private eval strings multiline accessors ; IN: regexp-tests -\ must-infer -\ compile-regexp must-infer -\ matches? must-infer - [ f ] [ "b" "a*" matches? ] unit-test [ t ] [ "" "a*" matches? ] unit-test [ t ] [ "a" "a*" matches? ] unit-test diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor index df6510afbf..b8df0b7b5b 100644 --- a/basis/smtp/smtp-tests.factor +++ b/basis/smtp/smtp-tests.factor @@ -4,8 +4,6 @@ namespaces logging accessors assocs sorting smtp.private concurrency.promises system ; IN: smtp.tests -\ send-email must-infer - { 0 0 } [ [ ] with-smtp-connection ] must-infer-as [ "hello\nworld" validate-address ] must-fail diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 6ac4fce0c0..814f528cdb 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -10,7 +10,7 @@ sequences.private destructors combinators eval locals.backend system compiler.units ; IN: stack-checker.tests -\ infer. must-infer +[ 1234 infer ] must-fail { 0 2 } [ 2 "Hello" ] must-infer-as { 1 2 } [ dup ] must-infer-as @@ -65,11 +65,6 @@ IN: stack-checker.tests { 1 1 } [ simple-recursion-2 ] must-infer-as -: bad-recursion-2 ( obj -- obj ) - dup [ dup first swap second bad-recursion-2 ] [ ] if ; - -[ [ bad-recursion-2 ] infer ] must-fail - : funny-recursion ( obj -- obj ) dup [ funny-recursion 1 ] [ 2 ] if drop ; @@ -196,94 +191,11 @@ DEFER: blah4 over string? [ 2array throw ] unless ] must-infer-as -! Regression - -! This order of branches works -DEFER: do-crap -: more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ; -: do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ; -[ [ do-crap ] infer ] must-fail - -! This one does not -DEFER: do-crap* -: more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ; -: do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ; -[ [ do-crap* ] infer ] must-fail - ! Regression : too-deep ( a b -- c ) dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive { 2 1 } [ too-deep ] must-infer-as -! Error reporting is wrong -MATH: xyz ( a b -- c ) -M: fixnum xyz 2array ; -M: float xyz - [ 3 ] bi@ swapd [ 2array swap ] dip 2array swap ; - -[ [ xyz ] infer ] [ inference-error? ] must-fail-with - -! Doug Coleman discovered this one while working on the -! calendar library -DEFER: A -DEFER: B -DEFER: C - -: A ( a -- ) - dup { - [ drop ] - [ A ] - [ \ A no-method ] - [ dup C A ] - } dispatch ; - -: B ( b -- ) - dup { - [ C ] - [ B ] - [ \ B no-method ] - [ dup B B ] - } dispatch ; - -: C ( c -- ) - dup { - [ A ] - [ C ] - [ \ C no-method ] - [ dup B C ] - } dispatch ; - -{ 1 0 } [ A ] must-infer-as -{ 1 0 } [ B ] must-infer-as -{ 1 0 } [ C ] must-infer-as - -! I found this bug by thinking hard about the previous one -DEFER: Y -: X ( a b -- c d ) dup [ swap Y ] [ ] if ; -: Y ( a b -- c d ) X ; - -{ 2 2 } [ X ] must-infer-as -{ 2 2 } [ Y ] must-infer-as - -! This one comes from UI code -DEFER: #1 -: #2 ( a b: ( -- ) -- ) dup [ call ] [ 2drop ] if ; inline -: #3 ( a -- ) [ #1 ] #2 ; -: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ; -: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ; - -[ \ #4 def>> infer ] must-fail -[ [ #1 ] infer ] must-fail - -! Similar -DEFER: bar -: foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ; -: bar ( a b -- ) [ 2 2 + ] t foo drop call drop ; - -[ [ foo ] infer ] must-fail - -[ 1234 infer ] must-fail - ! This used to hang [ [ [ dup call ] dup call ] infer ] [ inference-error? ] must-fail-with @@ -311,16 +223,6 @@ DEFER: bar [ [ [ [ drop 3 ] swap call ] dup call ] infer ] [ inference-error? ] must-fail-with -! This form should not have a stack effect - -: bad-recursion-1 ( a -- b ) - dup [ drop bad-recursion-1 5 ] [ ] if ; - -[ [ bad-recursion-1 ] infer ] must-fail - -: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; -[ [ bad-bin ] infer ] must-fail - [ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with ! Regression @@ -333,114 +235,14 @@ DEFER: bar [ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail -! Test number protocol -\ bitor must-infer -\ bitand must-infer -\ bitxor must-infer -\ mod must-infer -\ /i must-infer -\ /f must-infer -\ /mod must-infer -\ + must-infer -\ - must-infer -\ * must-infer -\ / must-infer -\ < must-infer -\ <= must-infer -\ > must-infer -\ >= must-infer -\ number= must-infer - -! Test object protocol -\ = must-infer -\ clone must-infer -\ hashcode* must-infer - -! Test sequence protocol -\ length must-infer -\ nth must-infer -\ set-length must-infer -\ set-nth must-infer -\ new must-infer -\ new-resizable must-infer -\ like must-infer -\ lengthen must-infer - -! Test assoc protocol -\ at* must-infer -\ set-at must-infer -\ new-assoc must-infer -\ delete-at must-infer -\ clear-assoc must-infer -\ assoc-size must-infer -\ assoc-like must-infer -\ assoc-clone-like must-infer -\ >alist must-infer { 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as -! Test some random library words -\ 1quotation must-infer -\ string>number must-infer -\ get must-infer - -\ push must-infer -\ append must-infer -\ peek must-infer - -\ reverse must-infer -\ member? must-infer -\ remove must-infer -\ natural-sort must-infer - -\ forget must-infer -\ define-class must-infer -\ define-tuple-class must-infer -\ define-union-class must-infer -\ define-predicate-class must-infer -\ instance? must-infer -\ next-method-quot must-infer - ! Test words with continuations { 0 0 } [ [ drop ] callcc0 ] must-infer-as { 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as { 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as { 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as -\ dispose must-infer - -! Test stream protocol -\ set-timeout must-infer -\ stream-read must-infer -\ stream-read1 must-infer -\ stream-readln must-infer -\ stream-read-until must-infer -\ stream-write must-infer -\ stream-write1 must-infer -\ stream-nl must-infer -\ stream-flush must-infer - -! Test stream utilities -\ lines must-infer -\ contents must-infer - -! Test prettyprinting -\ . must-infer -\ short. must-infer -\ unparse must-infer - -\ describe must-infer -\ error. must-infer - -! Test odds and ends -\ io-thread must-infer - -! Incorrect stack declarations on inline recursive words should -! be caught -: fooxxx ( a b -- c ) over [ foo ] when ; inline -: barxxx ( a b -- c ) fooxxx ; - -[ [ barxxx ] infer ] must-fail - ! A typo { 1 0 } [ { [ ] } dispatch ] must-infer-as @@ -463,7 +265,6 @@ DEFER: deferred-word { 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as - DEFER: an-inline-word : normal-word-3 ( -- ) @@ -503,9 +304,7 @@ ERROR: custom-error ; ] unit-test ! Regression -: missing->r-check ( a -- ) 1 load-locals ; - -[ [ missing->r-check ] infer ] must-fail +[ [ 1 load-locals ] infer ] must-fail ! Corner case [ [ [ f dup ] [ dup ] produce ] infer ] must-fail @@ -513,35 +312,12 @@ ERROR: custom-error ; [ [ [ f dup ] [ ] while ] infer ] must-fail : erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline recursive - [ [ erg's-inference-bug ] infer ] must-fail - -: inference-invalidation-a ( -- ) ; -: inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline -: inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline - -[ 7 ] [ 4 3 inference-invalidation-c ] unit-test - -{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as - -[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval( -- ) ] unit-test - -[ 3 ] [ inference-invalidation-c ] unit-test - -{ 0 1 } [ inference-invalidation-c ] must-infer-as - -GENERIC: inference-invalidation-d ( obj -- ) - -M: object inference-invalidation-d inference-invalidation-c 2drop ; - -\ inference-invalidation-d must-infer - -[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval( -- ) ] unit-test - -[ [ inference-invalidation-d ] infer ] must-fail +FORGET: erg's-inference-bug : bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline recursive [ [ bad-recursion-3 ] infer ] must-fail +FORGET: bad-recursion-3 : bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive [ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail @@ -562,6 +338,8 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ; [ [ unbalanced-retain-usage ] infer ] [ inference-error? ] must-fail-with +FORGET: unbalanced-retain-usage + DEFER: eee' : ddd' ( ? -- ) [ f eee' ] when ; inline recursive : eee' ( ? -- ) [ swap [ ] ] dip ddd' call ; inline recursive diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index abb1f2abdb..126f6a9648 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -5,7 +5,12 @@ classes classes.tuple ; : compose-n-quot ( word n -- quot' ) >quotation ; : compose-n ( quot n -- ) compose-n-quot call ; + +<< \ compose-n [ compose-n-quot ] 2 define-transform +\ compose-n t "no-compile" set-word-prop +>> + : compose-n-test ( a b c -- x ) 2 \ + compose-n ; [ 6 ] [ 1 2 3 compose-n-test ] unit-test diff --git a/basis/syndication/syndication-tests.factor b/basis/syndication/syndication-tests.factor index 3ea037352c..b0bd5a2ff5 100644 --- a/basis/syndication/syndication-tests.factor +++ b/basis/syndication/syndication-tests.factor @@ -2,9 +2,6 @@ USING: syndication io kernel io.files tools.test io.encodings.binary calendar urls xml.writer ; IN: syndication.tests -\ download-feed must-infer -\ feed>xml must-infer - : load-news-file ( filename -- feed ) #! Load an news syndication file and process it, returning #! it as an feed tuple. diff --git a/basis/tools/memory/memory-tests.factor b/basis/tools/memory/memory-tests.factor index 60b54c2a0d..4b75cf0bfa 100644 --- a/basis/tools/memory/memory-tests.factor +++ b/basis/tools/memory/memory-tests.factor @@ -1,8 +1,5 @@ USING: tools.test tools.memory ; IN: tools.memory.tests -\ room. must-infer [ ] [ room. ] unit-test - -\ heap-stats. must-infer [ ] [ heap-stats. ] unit-test diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor index 9122edcb67..ac7b33d41e 100644 --- a/basis/tools/test/test-docs.factor +++ b/basis/tools/test/test-docs.factor @@ -58,8 +58,8 @@ HELP: must-fail-with { $notes "This word is used to test error handling code, ensuring that errors thrown by code contain the relevant debugging information." } ; HELP: must-infer -{ $values { "word/quot" "a quotation or a word" } } -{ $description "Ensures that the quotation or word has a static stack effect without running it." } +{ $values { "quot" quotation } } +{ $description "Ensures that the quotation has a static stack effect without running it." } { $notes "This word is used to test that code will compile with the optimizing compiler for optimum performance. See " { $link "compiler" } "." } ; HELP: must-infer-as diff --git a/basis/tools/test/test-tests.factor b/basis/tools/test/test-tests.factor index 03f7f006c9..c8ce3e01c7 100644 --- a/basis/tools/test/test-tests.factor +++ b/basis/tools/test/test-tests.factor @@ -1,8 +1,6 @@ IN: tools.test.tests USING: tools.test tools.test.private namespaces kernel sequences ; -\ test-all must-infer - : fake-unit-test ( quot -- ) [ "fake" file set diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 1ff47e3d7f..c0c2f1892d 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -56,8 +56,7 @@ SYMBOL: file :: (must-infer-as) ( effect quot -- error ? ) [ quot infer short-effect effect assert= f f ] [ t ] recover ; -:: (must-infer) ( word/quot -- error ? ) - word/quot dup word? [ '[ _ execute ] ] when :> quot +:: (must-infer) ( quot -- error ? ) [ quot infer drop f f ] [ t ] recover ; TUPLE: did-not-fail ; diff --git a/basis/ui/event-loop/event-loop-tests.factor b/basis/ui/event-loop/event-loop-tests.factor index ae1d7ec8bc..ac263cb79c 100644 --- a/basis/ui/event-loop/event-loop-tests.factor +++ b/basis/ui/event-loop/event-loop-tests.factor @@ -1,4 +1,2 @@ IN: ui.event-loop.tests USING: ui.event-loop tools.test ; - -\ event-loop must-infer diff --git a/basis/ui/gadgets/books/books-tests.factor b/basis/ui/gadgets/books/books-tests.factor index dab9ef5acf..3076ffc004 100644 --- a/basis/ui/gadgets/books/books-tests.factor +++ b/basis/ui/gadgets/books/books-tests.factor @@ -1,4 +1,2 @@ IN: ui.gadgets.books.tests USING: tools.test ui.gadgets.books ; - -\ must-infer diff --git a/basis/ui/gadgets/buttons/buttons-tests.factor b/basis/ui/gadgets/buttons/buttons-tests.factor index 0aa12f7279..f7c73b2438 100644 --- a/basis/ui/gadgets/buttons/buttons-tests.factor +++ b/basis/ui/gadgets/buttons/buttons-tests.factor @@ -28,10 +28,6 @@ T{ foo-gadget } "t" set } "religion" set ] unit-test -\ must-infer - -\ must-infer - [ 0 ] [ "religion" get gadget-child value>> ] unit-test diff --git a/basis/ui/gadgets/editors/editors-tests.factor b/basis/ui/gadgets/editors/editors-tests.factor index bd610ba53b..3ba32dc3c2 100644 --- a/basis/ui/gadgets/editors/editors-tests.factor +++ b/basis/ui/gadgets/editors/editors-tests.factor @@ -42,8 +42,6 @@ IN: ui.gadgets.editors.tests ] with-grafted-gadget ] unit-test -\ must-infer - "hello" "field" set "field" get [ diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor index 03219c66fd..77860ba5b5 100644 --- a/basis/ui/gadgets/gadgets-tests.factor +++ b/basis/ui/gadgets/gadgets-tests.factor @@ -152,16 +152,3 @@ M: mock-gadget ungraft* { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each ] with-string-writer print - -\ must-infer -\ unparent must-infer -\ add-gadget must-infer -\ add-gadgets must-infer -\ clear-gadget must-infer - -\ relayout must-infer -\ relayout-1 must-infer -\ pref-dim must-infer - -\ graft* must-infer -\ ungraft* must-infer \ No newline at end of file diff --git a/basis/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor index 22df1f328b..4002c8b40e 100644 --- a/basis/ui/gadgets/scrollers/scrollers-tests.factor +++ b/basis/ui/gadgets/scrollers/scrollers-tests.factor @@ -104,5 +104,3 @@ dup layout model>> dependencies>> [ range-max value>> ] map { 0 0 } = ] unit-test - -\ must-infer diff --git a/basis/ui/gestures/gestures-tests.factor b/basis/ui/gestures/gestures-tests.factor index 402015ee7c..3bcea27819 100644 --- a/basis/ui/gestures/gestures-tests.factor +++ b/basis/ui/gestures/gestures-tests.factor @@ -1,5 +1,2 @@ IN: ui.gestures.tests USING: tools.test ui.gestures ; - -\ handle-gesture must-infer -\ send-queued-gesture must-infer \ No newline at end of file diff --git a/basis/ui/operations/operations-tests.factor b/basis/ui/operations/operations-tests.factor index 4612ea79b0..6e8339a539 100644 --- a/basis/ui/operations/operations-tests.factor +++ b/basis/ui/operations/operations-tests.factor @@ -26,5 +26,3 @@ io.streams.string math help help.markup accessors ; [ ] [ [ { $operations \ + } print-element ] with-string-writer drop ] unit-test - -\ object-operations must-infer \ No newline at end of file diff --git a/basis/ui/render/render-tests.factor b/basis/ui/render/render-tests.factor index 3410560ba9..3ae0082be1 100644 --- a/basis/ui/render/render-tests.factor +++ b/basis/ui/render/render-tests.factor @@ -1,4 +1,2 @@ IN: ui.render.tests USING: ui.render tools.test ; - -\ draw-gadget must-infer \ No newline at end of file diff --git a/basis/ui/tools/browser/browser-tests.factor b/basis/ui/tools/browser/browser-tests.factor index 3757f392c4..8027babc3f 100644 --- a/basis/ui/tools/browser/browser-tests.factor +++ b/basis/ui/tools/browser/browser-tests.factor @@ -1,5 +1,4 @@ IN: ui.tools.browser.tests USING: tools.test ui.gadgets.debug ui.tools.browser math ; -\ must-infer [ ] [ \ + [ ] with-grafted-gadget ] unit-test diff --git a/basis/ui/tools/inspector/inspector-tests.factor b/basis/ui/tools/inspector/inspector-tests.factor index 44e20fb0fd..2971b1e8cb 100644 --- a/basis/ui/tools/inspector/inspector-tests.factor +++ b/basis/ui/tools/inspector/inspector-tests.factor @@ -1,6 +1,4 @@ IN: ui.tools.inspector.tests USING: tools.test ui.tools.inspector math models ; -\ must-infer - [ ] [ \ + com-edit-slot ] unit-test \ No newline at end of file diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor index 986e1270eb..45b94344a6 100644 --- a/basis/ui/tools/listener/listener-tests.factor +++ b/basis/ui/tools/listener/listener-tests.factor @@ -6,8 +6,6 @@ threads arrays generic threads accessors listener math calendar concurrency.promises io ui.tools.common ; IN: ui.tools.listener.tests -\ must-infer - [ [ ] [ >>output "interactor" set ] unit-test diff --git a/basis/ui/tools/profiler/profiler-tests.factor b/basis/ui/tools/profiler/profiler-tests.factor index 86bebddbc9..c1c8fdbff9 100644 --- a/basis/ui/tools/profiler/profiler-tests.factor +++ b/basis/ui/tools/profiler/profiler-tests.factor @@ -1,3 +1,3 @@ USING: ui.tools.profiler tools.test ; -\ profiler-window must-infer + diff --git a/basis/ui/tools/walker/walker-tests.factor b/basis/ui/tools/walker/walker-tests.factor index fefb188239..fe0b57b980 100644 --- a/basis/ui/tools/walker/walker-tests.factor +++ b/basis/ui/tools/walker/walker-tests.factor @@ -1,4 +1,3 @@ USING: ui.tools.walker tools.test ; IN: ui.tools.walker.tests -\ must-infer diff --git a/basis/ui/ui-tests.factor b/basis/ui/ui-tests.factor index 4b4bf9d9ee..06de4eb9c2 100644 --- a/basis/ui/ui-tests.factor +++ b/basis/ui/ui-tests.factor @@ -1,5 +1,2 @@ IN: ui.tests USING: ui ui.private tools.test ; - -\ open-window must-infer -\ update-ui must-infer \ No newline at end of file diff --git a/basis/unicode/case/case-tests.factor b/basis/unicode/case/case-tests.factor index a76f5e78c4..9344d1102e 100644 --- a/basis/unicode/case/case-tests.factor +++ b/basis/unicode/case/case-tests.factor @@ -4,10 +4,6 @@ USING: unicode.case tools.test namespaces strings unicode.normalize unicode.case.private ; IN: unicode.case.tests -\ >upper must-infer -\ >lower must-infer -\ >title must-infer - [ "Hello How Are You? I'm Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test [ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test [ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor index 2e989b32c0..eae2020077 100644 --- a/basis/unix/groups/groups-tests.factor +++ b/basis/unix/groups/groups-tests.factor @@ -5,8 +5,6 @@ IN: unix.groups.tests [ ] [ all-groups drop ] unit-test -\ all-groups must-infer - [ t ] [ real-group-name string? ] unit-test [ t ] [ effective-group-name string? ] unit-test diff --git a/basis/unix/users/users-tests.factor b/basis/unix/users/users-tests.factor index f2a4b7bc27..cf3747b346 100644 --- a/basis/unix/users/users-tests.factor +++ b/basis/unix/users/users-tests.factor @@ -3,11 +3,8 @@ USING: tools.test unix.users kernel strings math ; IN: unix.users.tests - [ ] [ all-users drop ] unit-test -\ all-users must-infer - [ t ] [ real-user-name string? ] unit-test [ t ] [ effective-user-name string? ] unit-test diff --git a/basis/wrap/strings/strings-tests.factor b/basis/wrap/strings/strings-tests.factor index e66572dc1b..07f42caae3 100644 --- a/basis/wrap/strings/strings-tests.factor +++ b/basis/wrap/strings/strings-tests.factor @@ -38,6 +38,4 @@ word wrap."> [ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test [ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test -\ wrap-string must-infer - [ "a b c d e f\ng h" ] [ "a b c d e f g h" 11 wrap-string ] unit-test diff --git a/basis/wrap/words/words-tests.factor b/basis/wrap/words/words-tests.factor index 7598b382ba..6df69a65d6 100644 --- a/basis/wrap/words/words-tests.factor +++ b/basis/wrap/words/words-tests.factor @@ -79,4 +79,3 @@ IN: wrap.words.tests } 35 35 wrap-words [ { } like ] map ] unit-test -\ wrap-words must-infer diff --git a/basis/xml/syntax/syntax-tests.factor b/basis/xml/syntax/syntax-tests.factor index 10ab961ec0..6fcaf780cc 100644 --- a/basis/xml/syntax/syntax-tests.factor +++ b/basis/xml/syntax/syntax-tests.factor @@ -33,8 +33,6 @@ TAG: neg calculate calc-arith ] unit-test -\ calc-arith must-infer - XML-NS: foo http://blah.com [ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test @@ -90,7 +88,6 @@ XML-NS: foo http://blah.com [ "3" ] [ 3 [XML <-> XML] xml>string ] unit-test [ "" ] [ f [XML <-> XML] xml>string ] unit-test -\ XML] ] must-infer [ [XML <-> /> XML] ] must-infer diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor index 1d07aa9406..74ba931c79 100644 --- a/basis/xml/tests/test.factor +++ b/basis/xml/tests/test.factor @@ -7,9 +7,7 @@ xml.traversal continuations assocs io.encodings.binary sequences.deep accessors io.streams.string ; ! This is insufficient -\ read-xml must-infer [ [ drop ] each-element ] must-infer -\ string>xml must-infer SYMBOL: xml-file [ ] [ diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor index 2d31738c4c..ee09668a53 100644 --- a/basis/xml/writer/writer-tests.factor +++ b/basis/xml/writer/writer-tests.factor @@ -5,9 +5,6 @@ xml.writer.private io.streams.string xml.traversal sequences io.encodings.utf8 io.files accessors io.directories math math.parser ; IN: xml.writer.tests -\ write-xml must-infer -\ xml>string must-infer -\ pprint-xml must-infer ! Add a test for pprint-xml with sensitive-tags [ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test diff --git a/basis/xmode/code2html/code2html-tests.factor b/basis/xmode/code2html/code2html-tests.factor index 8d5db4a6e9..d57b8ce28d 100644 --- a/basis/xmode/code2html/code2html-tests.factor +++ b/basis/xmode/code2html/code2html-tests.factor @@ -3,8 +3,6 @@ USING: xmode.code2html xmode.catalog tools.test multiline splitting memoize kernel io.streams.string xml.writer ; -\ htmlize-file must-infer - [ ] [ \ (load-mode) reset-memoized ] unit-test [ ] [ diff --git a/core/checksums/checksums-tests.factor b/core/checksums/checksums-tests.factor index 1ec675b0cf..8ba09d8e91 100644 --- a/core/checksums/checksums-tests.factor +++ b/core/checksums/checksums-tests.factor @@ -1,7 +1,3 @@ IN: checksums.tests USING: checksums tools.test ; -\ checksum-bytes must-infer -\ checksum-stream must-infer -\ checksum-lines must-infer -\ checksum-file must-infer diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index a3610ff7c5..a6af5b8c29 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -7,12 +7,6 @@ random stack-checker effects kernel.private sbufs math.order classes.tuple accessors ; IN: classes.algebra.tests -\ class< must-infer -\ class-and must-infer -\ class-or must-infer -\ flatten-class must-infer -\ flatten-builtin-class must-infer - : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ; : class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 68cdc20c53..3800d5056a 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -599,7 +599,7 @@ must-fail-with : foo ( a b -- c ) declared-types boa ; -\ foo must-infer +\ foo def>> must-infer [ T{ declared-types f 0 "hi" } ] [ 0.0 "hi" foo ] unit-test diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index a8049f709e..dd5fa06031 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -42,7 +42,7 @@ IN: combinators.tests { [ dup 2 mod 1 = ] [ drop "odd" ] } } cond ; -\ cond-test-1 must-infer +\ cond-test-1 def>> must-infer [ "even" ] [ 2 cond-test-1 ] unit-test [ "odd" ] [ 3 cond-test-1 ] unit-test @@ -54,7 +54,7 @@ IN: combinators.tests [ drop "something else" ] } cond ; -\ cond-test-2 must-infer +\ cond-test-2 def>> must-infer [ "true" ] [ t cond-test-2 ] unit-test [ "false" ] [ f cond-test-2 ] unit-test @@ -67,7 +67,7 @@ IN: combinators.tests { [ dup f = ] [ drop "false" ] } } cond ; -\ cond-test-3 must-infer +\ cond-test-3 def>> must-infer [ "something else" ] [ t cond-test-3 ] unit-test [ "something else" ] [ f cond-test-3 ] unit-test @@ -77,7 +77,7 @@ IN: combinators.tests { } cond ; -\ cond-test-4 must-infer +\ cond-test-4 def>> must-infer [ cond-test-4 ] [ class \ no-cond = ] must-fail-with @@ -168,7 +168,7 @@ IN: combinators.tests { 4 [ "four" ] } } case ; -\ case-test-1 must-infer +\ case-test-1 def>> must-infer [ "two" ] [ 2 case-test-1 ] unit-test @@ -186,7 +186,7 @@ IN: combinators.tests [ sq ] } case ; -\ case-test-2 must-infer +\ case-test-2 def>> must-infer [ 25 ] [ 5 case-test-2 ] unit-test @@ -204,7 +204,7 @@ IN: combinators.tests [ sq ] } case ; -\ case-test-3 must-infer +\ case-test-3 def>> must-infer [ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test @@ -222,7 +222,7 @@ CONSTANT: case-const-2 2 [ drop "demasiado" ] } case ; -\ case-test-4 must-infer +\ case-test-4 def>> must-infer [ "uno" ] [ 1 case-test-4 ] unit-test [ "dos" ] [ 2 case-test-4 ] unit-test @@ -239,7 +239,7 @@ CONSTANT: case-const-2 2 [ drop "demasiado" print ] } case ; -\ case-test-5 must-infer +\ case-test-5 def>> must-infer [ ] [ 1 case-test-5 ] unit-test @@ -296,7 +296,7 @@ CONSTANT: case-const-2 2 { 3 [ "three" ] } } case ; -\ test-case-6 must-infer +\ test-case-6 def>> must-infer [ "three" ] [ 3 test-case-6 ] unit-test [ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test @@ -343,7 +343,7 @@ CONSTANT: case-const-2 2 { \ ] [ "KFC" ] } } case ; -\ test-case-7 must-infer +\ test-case-7 def>> must-infer [ "plus" ] [ \ + test-case-7 ] unit-test diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 2111cce358..391b87a44f 100644 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -107,4 +107,4 @@ SYMBOL: error-counter [ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test -\ with-datastack must-infer +[ with-datastack ] must-infer diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index a2d637dcb7..8f0fb9e97a 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -4,9 +4,6 @@ io.files io.files.private io.files.temp io.files.unique kernel make math sequences system threads tools.test generic.standard ; IN: io.files.tests -\ exists? must-infer -\ (exists?) must-infer - [ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test [ ] [ "append-test" temp-file ascii dispose ] unit-test diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 2add8663d8..a8a57ccdaa 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -6,8 +6,6 @@ vocabs vocabs.loader accessors eval combinators lexer vocabs.parser words.symbol multiline source-files.errors ; IN: parser.tests -\ run-file must-infer - [ [ 1 [ 2 [ 3 ] 4 ] 5 ] [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval( -- a b c ) ] diff --git a/extra/contributors/contributors-tests.factor b/extra/contributors/contributors-tests.factor index 1476715588..3d9ce0403d 100644 --- a/extra/contributors/contributors-tests.factor +++ b/extra/contributors/contributors-tests.factor @@ -1,5 +1,4 @@ IN: contributors.tests USING: contributors tools.test ; -\ contributors must-infer [ ] [ contributors ] unit-test diff --git a/extra/infix/parser/parser-tests.factor b/extra/infix/parser/parser-tests.factor index d6b5d0559c..fa598a4ac6 100644 --- a/extra/infix/parser/parser-tests.factor +++ b/extra/infix/parser/parser-tests.factor @@ -3,9 +3,6 @@ USING: infix.ast infix.parser infix.tokenizer tools.test ; IN: infix.parser.tests -\ parse-infix must-infer -\ build-infix-ast must-infer - [ T{ ast-number { value 1 } } ] [ "1" build-infix-ast ] unit-test [ T{ ast-negation f T{ ast-number { value 1 } } } ] [ "-1" build-infix-ast ] unit-test diff --git a/extra/infix/tokenizer/tokenizer-tests.factor b/extra/infix/tokenizer/tokenizer-tests.factor index f9c908414a..b068881b84 100644 --- a/extra/infix/tokenizer/tokenizer-tests.factor +++ b/extra/infix/tokenizer/tokenizer-tests.factor @@ -3,7 +3,6 @@ USING: infix.ast infix.tokenizer tools.test ; IN: infix.tokenizer.tests -\ tokenize-infix must-infer [ V{ T{ ast-number f 1 } } ] [ "1" tokenize-infix ] unit-test [ V{ T{ ast-number f 1.02 } CHAR: * T{ ast-number f 3 } } ] [ "1.02*3" tokenize-infix ] unit-test [ V{ T{ ast-number f 3 } CHAR: / CHAR: ( T{ ast-number f 3 } CHAR: + T{ ast-number f 4 } CHAR: ) } ] diff --git a/extra/mason/cleanup/cleanup-tests.factor b/extra/mason/cleanup/cleanup-tests.factor index 9158536ffb..49a5153a8e 100644 --- a/extra/mason/cleanup/cleanup-tests.factor +++ b/extra/mason/cleanup/cleanup-tests.factor @@ -1,4 +1,2 @@ USING: tools.test mason.cleanup ; IN: mason.cleanup.tests - -\ cleanup must-infer diff --git a/extra/mason/release/upload/upload-tests.factor b/extra/mason/release/upload/upload-tests.factor index 73fc311399..09f1e13ae9 100644 --- a/extra/mason/release/upload/upload-tests.factor +++ b/extra/mason/release/upload/upload-tests.factor @@ -1,4 +1,3 @@ IN: mason.release.upload.tests USING: mason.release.upload tools.test ; -\ upload must-infer diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor index 240c9f86d7..aa66f41d8d 100644 --- a/extra/multi-methods/tests/definitions.factor +++ b/extra/multi-methods/tests/definitions.factor @@ -2,9 +2,6 @@ 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 - DEFER: fake \ fake H{ } clone "multi-methods" set-word-prop diff --git a/extra/peg/javascript/javascript-tests.factor b/extra/peg/javascript/javascript-tests.factor index 0d6899714d..69223a418d 100644 --- a/extra/peg/javascript/javascript-tests.factor +++ b/extra/peg/javascript/javascript-tests.factor @@ -4,8 +4,6 @@ USING: kernel tools.test peg.javascript peg.javascript.ast accessors ; IN: peg.javascript.tests -\ parse-javascript must-infer - { T{ ast-begin f V{ T{ ast-number f 123 } } } } [ "123;" parse-javascript ] unit-test \ No newline at end of file diff --git a/extra/peg/javascript/parser/parser-tests.factor b/extra/peg/javascript/parser/parser-tests.factor index a2c50952be..a521202b1c 100644 --- a/extra/peg/javascript/parser/parser-tests.factor +++ b/extra/peg/javascript/parser/parser-tests.factor @@ -5,8 +5,6 @@ USING: kernel tools.test peg peg.javascript.ast peg.javascript.parser accessors multiline sequences math peg.ebnf ; IN: peg.javascript.parser.tests -\ javascript must-infer - { T{ ast-begin diff --git a/extra/peg/javascript/tokenizer/tokenizer-tests.factor b/extra/peg/javascript/tokenizer/tokenizer-tests.factor index f0080a31b2..0fbd55ccfd 100644 --- a/extra/peg/javascript/tokenizer/tokenizer-tests.factor +++ b/extra/peg/javascript/tokenizer/tokenizer-tests.factor @@ -4,8 +4,6 @@ USING: kernel tools.test peg peg.javascript.ast peg.javascript.tokenizer accessors ; IN: peg.javascript.tokenizer.tests -\ tokenize-javascript must-infer - { V{ T{ ast-number f 123 } From 1e21f0ef4373d07bb4050b73aa7721b8329b457d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 21:17:18 -0500 Subject: [PATCH 429/772] better docs for emacs setup --- basis/editors/emacs/authors.txt | 1 + basis/editors/emacs/emacs-docs.factor | 19 ++++++++++++++++--- 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/basis/editors/emacs/authors.txt b/basis/editors/emacs/authors.txt index 6cfd5da273..07c1c4a765 100644 --- a/basis/editors/emacs/authors.txt +++ b/basis/editors/emacs/authors.txt @@ -1 +1,2 @@ Eduardo Cavazos +Doug Coleman diff --git a/basis/editors/emacs/emacs-docs.factor b/basis/editors/emacs/emacs-docs.factor index f55068e143..adf6d8a7b7 100644 --- a/basis/editors/emacs/emacs-docs.factor +++ b/basis/editors/emacs/emacs-docs.factor @@ -2,10 +2,23 @@ USING: help help.syntax help.markup ; IN: editors.emacs ARTICLE: "editors.emacs" "Integration with Emacs" -"Put this in your " { $snippet ".emacs" } " file:" +"Full Emacs integration with Factor requires the use of two executable files -- " { $snippet "emacs" } " and " { $snippet "emacsclient" } ", which act as a client/server pair. To start the server, run the " { $snippet "emacs" } " binary and run " { $snippet "M-x server-start" } " or start " { $snippet "emacs" } " with the following line in your " { $snippet ".emacs" } " file:" { $code "(server-start)" } +"On Windows, if you install Emacs to " { $snippet "Program Files" } " or " { $snippet "Program Files(x86)" } ", Factor will automatically detect the path to " { $snippet "emacsclient.exe" } ". On Unix systems, make sure that " { $snippet "emacsclient" } " is in your path. To set the path manually, use the following snippet:" +{ $code "USE: edtiors.emacs" + "\"/my/crazy/bin/emacsclient\" emacsclient-path set-global" +} + "If you would like a new window to open when you ask Factor to edit an object, put this in your " { $snippet ".emacs" } " file:" { $code "(setq server-window 'switch-to-buffer-other-frame)" } -{ $see-also "editor" } ; -ABOUT: "editors.emacs" \ No newline at end of file +"To quickly scaffold a " { $snippet ".emacs" } " file, run the following code:" +{ $code "USE: tools.scaffold" + "scaffold-emacs" +} + +{ $see-also "editor" } + +; + +ABOUT: "editors.emacs" From 687190bbeebd5687d6392afc7030a1db03999920 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 21:32:23 -0500 Subject: [PATCH 430/772] fix a bug in db.tester --- basis/db/tester/tester.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/db/tester/tester.factor b/basis/db/tester/tester.factor index fcc5abf1cf..a700e3eaa2 100644 --- a/basis/db/tester/tester.factor +++ b/basis/db/tester/tester.factor @@ -3,7 +3,7 @@ USING: concurrency.combinators db.pools db.sqlite db.tuples db.types kernel math random threads tools.test db sequences io prettyprint db.postgresql db.sqlite accessors io.files.temp -namespaces fry system ; +namespaces fry system math.parser ; IN: db.tester : postgresql-test-db ( -- postgresql-db ) @@ -67,8 +67,8 @@ test-2 "TEST2" { drop 10 [ dup [ - f 100 random 100 random 100 random test-1 boa - insert-tuple yield + f 100 random 100 random 100 random [ number>string ] tri@ + test-1 boa insert-tuple yield ] with-db ] times ] with parallel-each From 706fb78d5b9ff3a9f905539e0cbee3a39ea29685 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 21:47:16 -0500 Subject: [PATCH 431/772] better fix for db.tester --- basis/db/tester/tester.factor | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/basis/db/tester/tester.factor b/basis/db/tester/tester.factor index a700e3eaa2..56bac7efcd 100644 --- a/basis/db/tester/tester.factor +++ b/basis/db/tester/tester.factor @@ -56,6 +56,10 @@ test-2 "TEST2" { { "z" "Z" { VARCHAR 256 } +not-null+ } } define-persistent +: test-1-tuple ( -- tuple ) + f 100 random 100 random 100 random [ number>string ] tri@ + test-1 boa ; + : db-tester ( test-db -- ) [ [ @@ -67,8 +71,7 @@ test-2 "TEST2" { drop 10 [ dup [ - f 100 random 100 random 100 random [ number>string ] tri@ - test-1 boa insert-tuple yield + test-1-tuple insert-tuple yield ] with-db ] times ] with parallel-each @@ -84,8 +87,7 @@ test-2 "TEST2" { [ 10 [ 10 [ - f 100 random 100 random 100 random test-1 boa - insert-tuple yield + test-1-tuple insert-tuple yield ] times ] parallel-each ] with-pooled-db From f38d2f91f62e1495b718d90d12957b82955eaff5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Apr 2009 22:05:41 -0500 Subject: [PATCH 432/772] Words which didn't compile cannot be run at all --- basis/compiler/compiler.factor | 17 ++++++++++++----- basis/compiler/errors/errors.factor | 2 ++ basis/compiler/tree/builder/builder.factor | 4 ++-- basis/stack-checker/errors/errors.factor | 4 ++-- .../errors/prettyprint/prettyprint.factor | 5 +---- basis/tools/errors/errors.factor | 8 +++++++- core/compiler/units/units-docs.factor | 4 ++-- core/compiler/units/units-tests.factor | 2 +- core/compiler/units/units.factor | 2 +- vm/code_heap.c | 18 +++++++++++------- vm/code_heap.h | 2 +- vm/quotations.c | 3 +-- vm/types.c | 2 +- 13 files changed, 44 insertions(+), 29 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 7c53e41377..b8ba620f32 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -62,18 +62,25 @@ SYMBOLS: +optimized+ +unoptimized+ ; } 1|| ] [ error-type +compiler-warning+ eq? ] bi* and ; -: (fail) ( word -- * ) +: (fail) ( word compiled -- * ) + swap [ compiled-unxref ] - [ f swap compiled get set-at ] + [ compiled get set-at ] [ +unoptimized+ save-compiled-status ] tri return ; +: not-compiled-def ( word error -- def ) + '[ _ _ not-compiled ] [ ] like ; + : fail ( word error -- * ) - [ 2dup ignore-error? [ drop f ] when swap compiler-error ] [ drop (fail) ] 2bi ; + 2dup ignore-error? + [ drop f over def>> ] + [ 2dup not-compiled-def ] if + [ swap compiler-error ] [ (fail) ] bi-curry* bi ; : frontend ( word -- nodes ) - dup contains-breakpoints? [ (fail) ] [ + dup contains-breakpoints? [ dup def>> (fail) ] [ [ build-tree-from-word ] [ fail ] recover optimize-tree ] if ; @@ -124,7 +131,7 @@ t compile-dependencies? set-global [ (compile) yield-hook get call( -- ) ] slurp-deque ; : decompile ( word -- ) - f 2array 1array modify-code-heap ; + dup def>> 2array 1array modify-code-heap ; : compile-call ( quot -- ) [ dup infer define-temp ] with-compilation-unit execute ; diff --git a/basis/compiler/errors/errors.factor b/basis/compiler/errors/errors.factor index 22ae8d97ff..7e2f3d95f8 100644 --- a/basis/compiler/errors/errors.factor +++ b/basis/compiler/errors/errors.factor @@ -52,3 +52,5 @@ T{ error-type : compiler-error ( error word -- ) compiler-errors get-global pick [ [ [ ] keep ] dip set-at ] [ delete-at drop ] if ; + +ERROR: not-compiled word error ; \ No newline at end of file diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index edea9ae6c0..bda64569c3 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -45,8 +45,8 @@ IN: compiler.tree.builder infer-quot-here ; : check-effect ( word effect -- ) - over required-stack-effect 2dup effect<= - [ 3drop ] [ effect-error ] if ; + swap required-stack-effect 2dup effect<= + [ 2drop ] [ effect-error ] if ; : finish-word ( word -- ) current-effect check-effect ; diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index cb45d65954..550e283dbf 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -52,9 +52,9 @@ TUPLE: missing-effect word ; : missing-effect ( word -- * ) pretty-word \ missing-effect inference-error ; -TUPLE: effect-error word inferred declared ; +TUPLE: effect-error inferred declared ; -: effect-error ( word inferred declared -- * ) +: effect-error ( inferred declared -- * ) \ effect-error inference-error ; TUPLE: recursive-quotation-error quot ; diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index d6cee8e08f..97fe1522e0 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -40,10 +40,7 @@ M: missing-effect summary ] "" make ; M: effect-error summary - [ - "Stack effect declaration of the word " % - word>> name>> % " is wrong" % - ] "" make ; + drop "Stack effect declaration is wrong" ; M: recursive-quotation-error error. "The quotation " write diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor index 0a28bdec08..422e08f020 100644 --- a/basis/tools/errors/errors.factor +++ b/basis/tools/errors/errors.factor @@ -39,4 +39,10 @@ M: source-file-error error. : :warnings ( -- ) +compiler-warning+ compiler-errors. ; -: :linkage ( -- ) +linkage-error+ compiler-errors. ; \ No newline at end of file +: :linkage ( -- ) +linkage-error+ compiler-errors. ; + +M: not-compiled summary + word>> name>> "The word " " cannot be executed because it failed to compile" surround ; + +M: not-compiled error. + [ summary print nl ] [ error>> error. ] bi ; \ No newline at end of file diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor index bf3b4a7171..94a95ac9c3 100644 --- a/core/compiler/units/units-docs.factor +++ b/core/compiler/units/units-docs.factor @@ -60,8 +60,8 @@ HELP: modify-code-heap ( alist -- ) { $values { "alist" "an alist" } } { $description "Stores compiled code definitions in the code heap. The alist maps words to the following:" { $list - { { $link f } " - in this case, the word is compiled with the non-optimizing compiler part of the VM." } - { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data." } + { "a quotation - in this case, the quotation is compiled with the non-optimizing compiler and the word will call the quotation when executed." } + { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data and the word will call the code block when executed." } } } { $notes "This word is called at the end of " { $link with-compilation-unit } "." } ; diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index 03c68815cc..57726cc269 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -14,7 +14,7 @@ IN: compiler.units.tests ! Non-optimizing compiler bugs [ 1 1 ] [ - "A" "B" [ [ 1 ] dip ] >>def dup f 2array 1array modify-code-heap + "A" "B" [ [ 1 ] dip ] 2array 1array modify-code-heap 1 swap execute ] unit-test diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index a278bf0d5e..02a80c4d84 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -41,7 +41,7 @@ SYMBOL: compiler-impl HOOK: recompile compiler-impl ( words -- alist ) ! Non-optimizing compiler -M: f recompile [ f ] { } map>assoc ; +M: f recompile [ dup def>> ] { } map>assoc ; ! Trivial compiler. We don't want to touch the code heap ! during stage1 bootstrap, it would just waste time. diff --git a/vm/code_heap.c b/vm/code_heap.c index 65a28c6de3..1901c592e6 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -21,14 +21,16 @@ void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled) word->optimizedp = T; } -/* Allocates memory */ -void default_word_code(F_WORD *word, bool relocate) +/* Compile a word definition with the non-optimizing compiler. Allocates memory */ +void jit_compile_word(F_WORD *word, CELL def, bool relocate) { + REGISTER_ROOT(def); REGISTER_UNTAGGED(word); - jit_compile(word->def,relocate); + jit_compile(def,relocate); UNREGISTER_UNTAGGED(word); + UNREGISTER_ROOT(def); - word->code = untag_quotation(word->def)->code; + word->code = untag_quotation(def)->code; word->optimizedp = F; } @@ -83,15 +85,15 @@ void primitive_modify_code_heap(void) CELL data = array_nth(pair,1); - if(data == F) + if(type_of(data) == QUOTATION_TYPE) { REGISTER_UNTAGGED(alist); REGISTER_UNTAGGED(word); - default_word_code(word,false); + jit_compile_word(word,data,false); UNREGISTER_UNTAGGED(word); UNREGISTER_UNTAGGED(alist); } - else + else if(type_of(data) == ARRAY_TYPE) { F_ARRAY *compiled_code = untag_array(data); @@ -115,6 +117,8 @@ void primitive_modify_code_heap(void) set_word_code(word,compiled); } + else + critical_error("Expected a quotation or an array",data); REGISTER_UNTAGGED(alist); update_word_xt(word); diff --git a/vm/code_heap.h b/vm/code_heap.h index 4f52819547..4c5aafcddd 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -5,7 +5,7 @@ void init_code_heap(CELL size); bool in_code_heap_p(CELL ptr); -void default_word_code(F_WORD *word, bool relocate); +void jit_compile_word(F_WORD *word, CELL def, bool relocate); void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled); diff --git a/vm/quotations.c b/vm/quotations.c index e18e6b6098..f56ab6eada 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -532,8 +532,7 @@ void compile_all_words(void) { F_WORD *word = untag_word(array_nth(untag_array(words),i)); REGISTER_UNTAGGED(word); - if(word->optimizedp == F) - default_word_code(word,false); + jit_compile_word(word,word->def,false); UNREGISTER_UNTAGGED(word); update_word_xt(word); } diff --git a/vm/types.c b/vm/types.c index 119dc675bc..889de38016 100755 --- a/vm/types.c +++ b/vm/types.c @@ -54,7 +54,7 @@ F_WORD *allot_word(CELL vocab, CELL name) word->code = NULL; REGISTER_UNTAGGED(word); - default_word_code(word,true); + jit_compile_word(word,word->def,true); UNREGISTER_UNTAGGED(word); REGISTER_UNTAGGED(word); From 7095ace2c1044615fed09422e8c540ec8a8328b0 Mon Sep 17 00:00:00 2001 From: Ken Causey Date: Mon, 20 Apr 2009 22:11:01 -0500 Subject: [PATCH 433/772] Makes it possible to change the names of the exectables named in the variables at the top of the Makefile and still build. Also removes unused IMAGE variable. --- Makefile | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 35a5ba58bf..db99120a77 100644 --- a/Makefile +++ b/Makefile @@ -7,7 +7,6 @@ CONSOLE_EXECUTABLE = factor-console TEST_LIBRARY = factor-ffi-test VERSION = 0.92 -IMAGE = factor.image BUNDLE = Factor.app LIBPATH = -L/usr/X11R6/lib CFLAGS = -Wall @@ -151,17 +150,17 @@ macosx.app: factor @executable_path/../Frameworks/libfactor.dylib \ Factor.app/Contents/MacOS/factor -factor: $(DLL_OBJS) $(EXE_OBJS) +$(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS) $(LINKER) $(ENGINE) $(DLL_OBJS) $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) -factor-console: $(DLL_OBJS) $(EXE_OBJS) +$(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS) $(LINKER) $(ENGINE) $(DLL_OBJS) $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS) -factor-ffi-test: vm/ffi_test.o +$(TEST_LIBRARY): vm/ffi_test.o $(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS) clean: From 2f0058e46ab0c50e7cbb6648a67a132625860bb6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 23:23:16 -0500 Subject: [PATCH 434/772] factor.sh now has an exit routine. it will print _something_ so it doesn't loop when looking for a make target --- build-support/factor.sh | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index 53aab9ad04..3ece72306a 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -22,6 +22,13 @@ test_program_installed() { return 1; } +exit_script() { + if [[ $FIND_MAKE_TARGET -eq true ]] ; then + echo $MAKE_TARGET; + fi + exit $1 +} + ensure_program_installed() { installed=0; for i in $* ; @@ -43,7 +50,7 @@ ensure_program_installed() { $ECHO -n "any of [ $* ]" fi $ECHO " and try again." - exit 1 + exit_script 1; fi } @@ -51,7 +58,7 @@ check_ret() { RET=$? if [[ $RET -ne 0 ]] ; then $ECHO $1 failed - exit 2 + exit_script 2 fi } @@ -62,7 +69,7 @@ check_gcc_version() { if [[ $GCC_VERSION == *3.3.* ]] ; then $ECHO "You have a known buggy version of gcc (3.3)" $ECHO "Install gcc 3.4 or higher and try again." - exit 3 + exit_script 3 elif [[ $GCC_VERSION == *4.3.* ]] ; then MAKE_OPTS="$MAKE_OPTS SITE_CFLAGS=-fno-forward-propagate" fi @@ -154,7 +161,7 @@ check_factor_exists() { if [[ -d "factor" ]] ; then $ECHO "A directory called 'factor' already exists." $ECHO "Rename or delete it and try again." - exit 4 + exit_script 4 fi } @@ -279,7 +286,7 @@ check_os_arch_word() { $ECHO "OS, ARCH, or WORD is empty. Please report this." echo $MAKE_TARGET - exit 5 + exit_script 5 fi } @@ -385,7 +392,7 @@ check_makefile_exists() { echo "You are likely in the wrong directory." echo "Run this script from your factor directory:" echo " ./build-support/factor.sh" - exit 6 + exit_script 6 fi } @@ -536,6 +543,6 @@ case "$1" in bootstrap) get_config_info; bootstrap ;; report) find_build_info ;; net-bootstrap) get_config_info; update_boot_images; bootstrap ;; - make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;; + make-target) FIND_MAKE_TARGET=true; ECHO=false; find_build_info; exit_script ;; *) usage ;; esac From cb6205e9d490d97f5ac4bd6073b4b2389d5817d4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 00:04:56 -0500 Subject: [PATCH 435/772] debugger: add summary method for VM errors --- basis/debugger/debugger.factor | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 9abd5a9033..d8ebd5bbf9 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -126,14 +126,14 @@ HOOK: signal-error. os ( obj -- ) : primitive-error. ( error -- ) "Unimplemented primitive" print drop ; -PREDICATE: kernel-error < array +PREDICATE: vm-error < array { { [ dup empty? ] [ drop f ] } { [ dup first "kernel-error" = not ] [ drop f ] } [ second 0 15 between? ] } cond ; -: kernel-errors ( error -- n errors ) +: vm-errors ( error -- n errors ) second { { 0 [ expired-error. ] } { 1 [ io-error. ] } @@ -153,9 +153,11 @@ PREDICATE: kernel-error < array { 15 [ memory-error. ] } } ; inline -M: kernel-error error. dup kernel-errors case ; +M: vm-error summary drop "VM error" ; -M: kernel-error error-help kernel-errors at first ; +M: vm-error error. dup vm-errors case ; + +M: vm-error error-help vm-errors at first ; M: no-method summary drop "No suitable method" ; From 461ddfac1afa1730055a3b414de82354a964dc1d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 00:05:39 -0500 Subject: [PATCH 436/772] Fix 'become' --- core/memory/memory-tests.factor | 2 ++ vm/data_gc.c | 6 ++++++ vm/quotations.c | 3 ++- 3 files changed, 10 insertions(+), 1 deletion(-) diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index 670c21d6ff..a6ecdc005e 100644 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -3,6 +3,8 @@ sequences tools.test words namespaces layouts classes classes.builtin arrays quotations io.launcher system ; IN: memory.tests +[ ] [ { } { } become ] unit-test + ! LOL [ ] [ vm diff --git a/vm/data_gc.c b/vm/data_gc.c index 2252d07541..cc1df13d58 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -564,6 +564,8 @@ void primitive_clear_gc_stats(void) clear_gc_stats(); } +/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this + to coalesce equal but distinct quotations and wrappers. */ void primitive_become(void) { F_ARRAY *new_objects = untag_array(dpop()); @@ -585,5 +587,9 @@ void primitive_become(void) gc(); + /* If a word's definition quotation was in old_objects and the + quotation in new_objects is not compiled, we might leak memory + by referencing the old quotation unless we recompile all + unoptimized words. */ compile_all_words(); } diff --git a/vm/quotations.c b/vm/quotations.c index f56ab6eada..d08fecdefb 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -532,7 +532,8 @@ void compile_all_words(void) { F_WORD *word = untag_word(array_nth(untag_array(words),i)); REGISTER_UNTAGGED(word); - jit_compile_word(word,word->def,false); + if(word->optimizedp == F) + jit_compile_word(word,word->def,false); UNREGISTER_UNTAGGED(word); update_word_xt(word); } From 782a2beff3e707693446c19fac48f5659f1b5f72 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 00:14:30 -0500 Subject: [PATCH 437/772] tweak error list sorting, listener now shows error list summary in a separate pane --- basis/ui/tools/error-list/error-list.factor | 2 +- basis/ui/tools/listener/listener.factor | 40 ++++++++++++--------- 2 files changed, 25 insertions(+), 17 deletions(-) diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index 6a63a70cf8..42863a8fd2 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -97,7 +97,7 @@ M: error-renderer column-titles M: error-renderer column-alignment drop { 0 1 0 0 } ; : sort-errors ( seq -- seq' ) - [ [ [ asset>> unparse-short ] [ line#>> ] bi 2array ] keep ] { } map>assoc + [ [ [ line#>> ] [ asset>> unparse-short ] bi 2array ] keep ] { } map>assoc sort-keys values ; : file-matches? ( error pathname/f -- ? ) diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 6484b8e1c4..249be0b291 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -32,9 +32,10 @@ output history flag mailbox thread waiting token-model word-model popup ; : interactor-busy? ( interactor -- ? ) #! We're busy if there's no thread to resume. - [ waiting>> ] - [ thread>> dup [ thread-registered? ] when ] - bi and not ; + { + [ waiting>> ] + [ thread>> dup [ thread-registered? ] when ] + } 1&& not ; SLOT: vocabs @@ -171,7 +172,7 @@ M: interactor dispose drop ; over set-caret mark>caret ; -TUPLE: listener-gadget < tool input output scroller ; +TUPLE: listener-gadget < tool error-summary output scroller input ; { 600 700 } listener-gadget set-tool-dim @@ -181,17 +182,22 @@ TUPLE: listener-gadget < tool input output scroller ; : listener-streams ( listener -- input output ) [ input>> ] [ output>> ] bi ; -: init-listener ( listener -- listener ) +: init-input/output ( listener -- listener ) [ >>input ] [ pane new-pane t >>scrolls? >>output ] bi dup listener-streams >>output drop ; -: ( -- gadget ) +: init-error-summary ( listener -- listener ) + >>error-summary + dup error-summary>> f track-add ; + +: ( -- listener ) vertical listener-gadget new-track add-toolbar - init-listener + init-input/output dup output>> >>scroller - dup scroller>> 1 track-add ; + dup scroller>> 1 track-add + init-error-summary ; M: listener-gadget focusable-child* input>> dup popup>> or ; @@ -357,18 +363,20 @@ interactor "completion" f { { T{ key-down f { C+ } "r" } history-completion-popup } } define-command-map -: ui-error-summary ( -- ) - error-counts keys [ - [ icon>> 1array \ $image prefix " " 2array ] { } map-as - { "Press " { $command tool "common" show-error-list } " to view errors." } - append print-element nl - ] unless-empty ; +: ui-error-summary ( listener -- ) + error-summary>> [ + error-counts keys [ + [ icon>> 1array \ $image prefix " " 2array ] { } map-as + { "Press " { $command tool "common" show-error-list } " to view errors." } + append print-element + ] unless-empty + ] with-pane ; : listener-thread ( listener -- ) dup listener-streams [ [ com-browse ] help-hook set - '[ [ _ input>> ] 2dip debugger-popup ] error-hook set - [ ui-error-summary ] error-summary-hook set + [ '[ [ _ input>> ] 2dip debugger-popup ] error-hook set ] + [ '[ _ ui-error-summary ] error-summary-hook set ] bi tip-of-the-day. nl listener ] with-streams* ; From b1d0066baa92f81bc87eda0e8e26eb6bff02fd6c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 00:27:21 -0500 Subject: [PATCH 438/772] ui.tools.listener: better error summary display --- basis/help/markup/markup.factor | 2 +- basis/io/styles/styles.factor | 2 ++ basis/ui/tools/listener/listener.factor | 17 +++++++++++------ 3 files changed, 14 insertions(+), 7 deletions(-) diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index 8b5edf38c1..f22560a4ce 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -138,7 +138,7 @@ ALIAS: $slot $snippet ! Images : $image ( element -- ) - [ [ "" ] dip first image associate format ] ($span) ; + [ first write-image ] ($span) ; : <$image> ( path -- element ) 1array \ $image prefix ; diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor index 66b5f0458f..c3bf5d2f28 100644 --- a/basis/io/styles/styles.factor +++ b/basis/io/styles/styles.factor @@ -156,3 +156,5 @@ M: input summary ] "" make ; : write-object ( str obj -- ) presented associate format ; + +: write-image ( image -- ) [ "" ] dip image associate format ; diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 249be0b291..3a1c68fa25 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -13,7 +13,7 @@ ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations ui.tools.browser ui.tools.common ui.tools.debugger ui.tools.listener.completion ui.tools.listener.popups -ui.tools.listener.history ui.tools.error-list ; +ui.tools.listener.history ui.tools.error-list ui.images ; FROM: source-files.errors => all-errors ; IN: ui.tools.listener @@ -187,8 +187,11 @@ TUPLE: listener-gadget < tool error-summary output scroller input ; [ >>input ] [ pane new-pane t >>scrolls? >>output ] bi dup listener-streams >>output drop ; +: ( -- gadget ) + COLOR: light-yellow >>interior ; + : init-error-summary ( listener -- listener ) - >>error-summary + >>error-summary dup error-summary>> f track-add ; : ( -- listener ) @@ -363,12 +366,14 @@ interactor "completion" f { { T{ key-down f { C+ } "r" } history-completion-popup } } define-command-map -: ui-error-summary ( listener -- ) +: error-summary. ( listener -- ) error-summary>> [ error-counts keys [ - [ icon>> 1array \ $image prefix " " 2array ] { } map-as + H{ { table-gap { 3 3 } } } [ + [ [ [ icon>> write-image ] with-cell ] each ] with-row + ] tabular-output { "Press " { $command tool "common" show-error-list } " to view errors." } - append print-element + print-element ] unless-empty ] with-pane ; @@ -376,7 +381,7 @@ interactor "completion" f { dup listener-streams [ [ com-browse ] help-hook set [ '[ [ _ input>> ] 2dip debugger-popup ] error-hook set ] - [ '[ _ ui-error-summary ] error-summary-hook set ] bi + [ '[ _ error-summary. ] error-summary-hook set ] bi tip-of-the-day. nl listener ] with-streams* ; From 784f34e49f70b0e00b84321856dddaa989e13ab3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Apr 2009 01:44:25 -0500 Subject: [PATCH 439/772] turn off autouse for sandboxed code --- extra/sandbox/sandbox.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/sandbox/sandbox.factor b/extra/sandbox/sandbox.factor index a9d65ee5ab..097a7c8d8a 100644 --- a/extra/sandbox/sandbox.factor +++ b/extra/sandbox/sandbox.factor @@ -10,7 +10,7 @@ SYMBOL: whitelist : with-sandbox-vocabs ( quot -- ) "sandbox.syntax" load-vocab vocab-words 1vector - use [ call ] with-variable ; inline + use [ auto-use? off call ] with-variable ; inline : parse-sandbox ( lines assoc -- quot ) whitelist [ [ parse-lines ] with-sandbox-vocabs ] with-variable ; From 1a28a5e30def0484375d11fd67416c0bca3c82b5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Apr 2009 02:01:35 -0500 Subject: [PATCH 440/772] accidentally checked in db2 branch. move to unmaintained for now --- {extra => unmaintained}/db2/authors.txt | 0 {extra => unmaintained}/db2/connections/authors.txt | 0 {extra => unmaintained}/db2/connections/connections-tests.factor | 0 {extra => unmaintained}/db2/connections/connections.factor | 0 {extra => unmaintained}/db2/db2-tests.factor | 0 {extra => unmaintained}/db2/db2.factor | 0 {extra => unmaintained}/db2/errors/errors.factor | 0 {extra => unmaintained}/db2/errors/summary.txt | 0 {extra => unmaintained}/db2/fql/authors.txt | 0 {extra => unmaintained}/db2/fql/fql-tests.factor | 0 {extra => unmaintained}/db2/fql/fql.factor | 0 {extra => unmaintained}/db2/introspection/authors.txt | 0 {extra => unmaintained}/db2/introspection/introspection.factor | 0 {extra => unmaintained}/db2/pools/authors.txt | 0 {extra => unmaintained}/db2/pools/pools-tests.factor | 0 {extra => unmaintained}/db2/pools/pools.factor | 0 {extra => unmaintained}/db2/result-sets/authors.txt | 0 {extra => unmaintained}/db2/result-sets/result-sets.factor | 0 {extra => unmaintained}/db2/sqlite/authors.txt | 0 {extra => unmaintained}/db2/sqlite/connections/authors.txt | 0 .../db2/sqlite/connections/connections-tests.factor | 0 {extra => unmaintained}/db2/sqlite/connections/connections.factor | 0 {extra => unmaintained}/db2/sqlite/db/authors.txt | 0 {extra => unmaintained}/db2/sqlite/db/db.factor | 0 {extra => unmaintained}/db2/sqlite/errors/authors.txt | 0 {extra => unmaintained}/db2/sqlite/errors/errors.factor | 0 {extra => unmaintained}/db2/sqlite/ffi/ffi.factor | 0 {extra => unmaintained}/db2/sqlite/introspection/authors.txt | 0 .../db2/sqlite/introspection/introspection-tests.factor | 0 .../db2/sqlite/introspection/introspection.factor | 0 {extra => unmaintained}/db2/sqlite/lib/lib.factor | 0 {extra => unmaintained}/db2/sqlite/result-sets/authors.txt | 0 {extra => unmaintained}/db2/sqlite/result-sets/result-sets.factor | 0 {extra => unmaintained}/db2/sqlite/sqlite.factor | 0 {extra => unmaintained}/db2/sqlite/statements/authors.txt | 0 {extra => unmaintained}/db2/sqlite/statements/statements.factor | 0 {extra => unmaintained}/db2/sqlite/types/authors.txt | 0 {extra => unmaintained}/db2/sqlite/types/types.factor | 0 {extra => unmaintained}/db2/statements/authors.txt | 0 {extra => unmaintained}/db2/statements/statements-tests.factor | 0 {extra => unmaintained}/db2/statements/statements.factor | 0 {extra => unmaintained}/db2/tester/authors.txt | 0 {extra => unmaintained}/db2/tester/tester-tests.factor | 0 {extra => unmaintained}/db2/tester/tester.factor | 0 {extra => unmaintained}/db2/transactions/authors.txt | 0 {extra => unmaintained}/db2/transactions/transactions.factor | 0 {extra => unmaintained}/db2/types/authors.txt | 0 {extra => unmaintained}/db2/types/types.factor | 0 {extra => unmaintained}/db2/utils/authors.txt | 0 {extra => unmaintained}/db2/utils/utils.factor | 0 50 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/db2/authors.txt (100%) rename {extra => unmaintained}/db2/connections/authors.txt (100%) rename {extra => unmaintained}/db2/connections/connections-tests.factor (100%) rename {extra => unmaintained}/db2/connections/connections.factor (100%) rename {extra => unmaintained}/db2/db2-tests.factor (100%) rename {extra => unmaintained}/db2/db2.factor (100%) rename {extra => unmaintained}/db2/errors/errors.factor (100%) rename {extra => unmaintained}/db2/errors/summary.txt (100%) rename {extra => unmaintained}/db2/fql/authors.txt (100%) rename {extra => unmaintained}/db2/fql/fql-tests.factor (100%) rename {extra => unmaintained}/db2/fql/fql.factor (100%) rename {extra => unmaintained}/db2/introspection/authors.txt (100%) rename {extra => unmaintained}/db2/introspection/introspection.factor (100%) rename {extra => unmaintained}/db2/pools/authors.txt (100%) rename {extra => unmaintained}/db2/pools/pools-tests.factor (100%) rename {extra => unmaintained}/db2/pools/pools.factor (100%) rename {extra => unmaintained}/db2/result-sets/authors.txt (100%) rename {extra => unmaintained}/db2/result-sets/result-sets.factor (100%) rename {extra => unmaintained}/db2/sqlite/authors.txt (100%) rename {extra => unmaintained}/db2/sqlite/connections/authors.txt (100%) rename {extra => unmaintained}/db2/sqlite/connections/connections-tests.factor (100%) rename {extra => unmaintained}/db2/sqlite/connections/connections.factor (100%) rename {extra => unmaintained}/db2/sqlite/db/authors.txt (100%) rename {extra => unmaintained}/db2/sqlite/db/db.factor (100%) rename {extra => unmaintained}/db2/sqlite/errors/authors.txt (100%) rename {extra => unmaintained}/db2/sqlite/errors/errors.factor (100%) rename {extra => unmaintained}/db2/sqlite/ffi/ffi.factor (100%) rename {extra => unmaintained}/db2/sqlite/introspection/authors.txt (100%) rename {extra => unmaintained}/db2/sqlite/introspection/introspection-tests.factor (100%) rename {extra => unmaintained}/db2/sqlite/introspection/introspection.factor (100%) rename {extra => unmaintained}/db2/sqlite/lib/lib.factor (100%) rename {extra => unmaintained}/db2/sqlite/result-sets/authors.txt (100%) rename {extra => unmaintained}/db2/sqlite/result-sets/result-sets.factor (100%) rename {extra => unmaintained}/db2/sqlite/sqlite.factor (100%) rename {extra => unmaintained}/db2/sqlite/statements/authors.txt (100%) rename {extra => unmaintained}/db2/sqlite/statements/statements.factor (100%) rename {extra => unmaintained}/db2/sqlite/types/authors.txt (100%) rename {extra => unmaintained}/db2/sqlite/types/types.factor (100%) rename {extra => unmaintained}/db2/statements/authors.txt (100%) rename {extra => unmaintained}/db2/statements/statements-tests.factor (100%) rename {extra => unmaintained}/db2/statements/statements.factor (100%) rename {extra => unmaintained}/db2/tester/authors.txt (100%) rename {extra => unmaintained}/db2/tester/tester-tests.factor (100%) rename {extra => unmaintained}/db2/tester/tester.factor (100%) rename {extra => unmaintained}/db2/transactions/authors.txt (100%) rename {extra => unmaintained}/db2/transactions/transactions.factor (100%) rename {extra => unmaintained}/db2/types/authors.txt (100%) rename {extra => unmaintained}/db2/types/types.factor (100%) rename {extra => unmaintained}/db2/utils/authors.txt (100%) rename {extra => unmaintained}/db2/utils/utils.factor (100%) diff --git a/extra/db2/authors.txt b/unmaintained/db2/authors.txt similarity index 100% rename from extra/db2/authors.txt rename to unmaintained/db2/authors.txt diff --git a/extra/db2/connections/authors.txt b/unmaintained/db2/connections/authors.txt similarity index 100% rename from extra/db2/connections/authors.txt rename to unmaintained/db2/connections/authors.txt diff --git a/extra/db2/connections/connections-tests.factor b/unmaintained/db2/connections/connections-tests.factor similarity index 100% rename from extra/db2/connections/connections-tests.factor rename to unmaintained/db2/connections/connections-tests.factor diff --git a/extra/db2/connections/connections.factor b/unmaintained/db2/connections/connections.factor similarity index 100% rename from extra/db2/connections/connections.factor rename to unmaintained/db2/connections/connections.factor diff --git a/extra/db2/db2-tests.factor b/unmaintained/db2/db2-tests.factor similarity index 100% rename from extra/db2/db2-tests.factor rename to unmaintained/db2/db2-tests.factor diff --git a/extra/db2/db2.factor b/unmaintained/db2/db2.factor similarity index 100% rename from extra/db2/db2.factor rename to unmaintained/db2/db2.factor diff --git a/extra/db2/errors/errors.factor b/unmaintained/db2/errors/errors.factor similarity index 100% rename from extra/db2/errors/errors.factor rename to unmaintained/db2/errors/errors.factor diff --git a/extra/db2/errors/summary.txt b/unmaintained/db2/errors/summary.txt similarity index 100% rename from extra/db2/errors/summary.txt rename to unmaintained/db2/errors/summary.txt diff --git a/extra/db2/fql/authors.txt b/unmaintained/db2/fql/authors.txt similarity index 100% rename from extra/db2/fql/authors.txt rename to unmaintained/db2/fql/authors.txt diff --git a/extra/db2/fql/fql-tests.factor b/unmaintained/db2/fql/fql-tests.factor similarity index 100% rename from extra/db2/fql/fql-tests.factor rename to unmaintained/db2/fql/fql-tests.factor diff --git a/extra/db2/fql/fql.factor b/unmaintained/db2/fql/fql.factor similarity index 100% rename from extra/db2/fql/fql.factor rename to unmaintained/db2/fql/fql.factor diff --git a/extra/db2/introspection/authors.txt b/unmaintained/db2/introspection/authors.txt similarity index 100% rename from extra/db2/introspection/authors.txt rename to unmaintained/db2/introspection/authors.txt diff --git a/extra/db2/introspection/introspection.factor b/unmaintained/db2/introspection/introspection.factor similarity index 100% rename from extra/db2/introspection/introspection.factor rename to unmaintained/db2/introspection/introspection.factor diff --git a/extra/db2/pools/authors.txt b/unmaintained/db2/pools/authors.txt similarity index 100% rename from extra/db2/pools/authors.txt rename to unmaintained/db2/pools/authors.txt diff --git a/extra/db2/pools/pools-tests.factor b/unmaintained/db2/pools/pools-tests.factor similarity index 100% rename from extra/db2/pools/pools-tests.factor rename to unmaintained/db2/pools/pools-tests.factor diff --git a/extra/db2/pools/pools.factor b/unmaintained/db2/pools/pools.factor similarity index 100% rename from extra/db2/pools/pools.factor rename to unmaintained/db2/pools/pools.factor diff --git a/extra/db2/result-sets/authors.txt b/unmaintained/db2/result-sets/authors.txt similarity index 100% rename from extra/db2/result-sets/authors.txt rename to unmaintained/db2/result-sets/authors.txt diff --git a/extra/db2/result-sets/result-sets.factor b/unmaintained/db2/result-sets/result-sets.factor similarity index 100% rename from extra/db2/result-sets/result-sets.factor rename to unmaintained/db2/result-sets/result-sets.factor diff --git a/extra/db2/sqlite/authors.txt b/unmaintained/db2/sqlite/authors.txt similarity index 100% rename from extra/db2/sqlite/authors.txt rename to unmaintained/db2/sqlite/authors.txt diff --git a/extra/db2/sqlite/connections/authors.txt b/unmaintained/db2/sqlite/connections/authors.txt similarity index 100% rename from extra/db2/sqlite/connections/authors.txt rename to unmaintained/db2/sqlite/connections/authors.txt diff --git a/extra/db2/sqlite/connections/connections-tests.factor b/unmaintained/db2/sqlite/connections/connections-tests.factor similarity index 100% rename from extra/db2/sqlite/connections/connections-tests.factor rename to unmaintained/db2/sqlite/connections/connections-tests.factor diff --git a/extra/db2/sqlite/connections/connections.factor b/unmaintained/db2/sqlite/connections/connections.factor similarity index 100% rename from extra/db2/sqlite/connections/connections.factor rename to unmaintained/db2/sqlite/connections/connections.factor diff --git a/extra/db2/sqlite/db/authors.txt b/unmaintained/db2/sqlite/db/authors.txt similarity index 100% rename from extra/db2/sqlite/db/authors.txt rename to unmaintained/db2/sqlite/db/authors.txt diff --git a/extra/db2/sqlite/db/db.factor b/unmaintained/db2/sqlite/db/db.factor similarity index 100% rename from extra/db2/sqlite/db/db.factor rename to unmaintained/db2/sqlite/db/db.factor diff --git a/extra/db2/sqlite/errors/authors.txt b/unmaintained/db2/sqlite/errors/authors.txt similarity index 100% rename from extra/db2/sqlite/errors/authors.txt rename to unmaintained/db2/sqlite/errors/authors.txt diff --git a/extra/db2/sqlite/errors/errors.factor b/unmaintained/db2/sqlite/errors/errors.factor similarity index 100% rename from extra/db2/sqlite/errors/errors.factor rename to unmaintained/db2/sqlite/errors/errors.factor diff --git a/extra/db2/sqlite/ffi/ffi.factor b/unmaintained/db2/sqlite/ffi/ffi.factor similarity index 100% rename from extra/db2/sqlite/ffi/ffi.factor rename to unmaintained/db2/sqlite/ffi/ffi.factor diff --git a/extra/db2/sqlite/introspection/authors.txt b/unmaintained/db2/sqlite/introspection/authors.txt similarity index 100% rename from extra/db2/sqlite/introspection/authors.txt rename to unmaintained/db2/sqlite/introspection/authors.txt diff --git a/extra/db2/sqlite/introspection/introspection-tests.factor b/unmaintained/db2/sqlite/introspection/introspection-tests.factor similarity index 100% rename from extra/db2/sqlite/introspection/introspection-tests.factor rename to unmaintained/db2/sqlite/introspection/introspection-tests.factor diff --git a/extra/db2/sqlite/introspection/introspection.factor b/unmaintained/db2/sqlite/introspection/introspection.factor similarity index 100% rename from extra/db2/sqlite/introspection/introspection.factor rename to unmaintained/db2/sqlite/introspection/introspection.factor diff --git a/extra/db2/sqlite/lib/lib.factor b/unmaintained/db2/sqlite/lib/lib.factor similarity index 100% rename from extra/db2/sqlite/lib/lib.factor rename to unmaintained/db2/sqlite/lib/lib.factor diff --git a/extra/db2/sqlite/result-sets/authors.txt b/unmaintained/db2/sqlite/result-sets/authors.txt similarity index 100% rename from extra/db2/sqlite/result-sets/authors.txt rename to unmaintained/db2/sqlite/result-sets/authors.txt diff --git a/extra/db2/sqlite/result-sets/result-sets.factor b/unmaintained/db2/sqlite/result-sets/result-sets.factor similarity index 100% rename from extra/db2/sqlite/result-sets/result-sets.factor rename to unmaintained/db2/sqlite/result-sets/result-sets.factor diff --git a/extra/db2/sqlite/sqlite.factor b/unmaintained/db2/sqlite/sqlite.factor similarity index 100% rename from extra/db2/sqlite/sqlite.factor rename to unmaintained/db2/sqlite/sqlite.factor diff --git a/extra/db2/sqlite/statements/authors.txt b/unmaintained/db2/sqlite/statements/authors.txt similarity index 100% rename from extra/db2/sqlite/statements/authors.txt rename to unmaintained/db2/sqlite/statements/authors.txt diff --git a/extra/db2/sqlite/statements/statements.factor b/unmaintained/db2/sqlite/statements/statements.factor similarity index 100% rename from extra/db2/sqlite/statements/statements.factor rename to unmaintained/db2/sqlite/statements/statements.factor diff --git a/extra/db2/sqlite/types/authors.txt b/unmaintained/db2/sqlite/types/authors.txt similarity index 100% rename from extra/db2/sqlite/types/authors.txt rename to unmaintained/db2/sqlite/types/authors.txt diff --git a/extra/db2/sqlite/types/types.factor b/unmaintained/db2/sqlite/types/types.factor similarity index 100% rename from extra/db2/sqlite/types/types.factor rename to unmaintained/db2/sqlite/types/types.factor diff --git a/extra/db2/statements/authors.txt b/unmaintained/db2/statements/authors.txt similarity index 100% rename from extra/db2/statements/authors.txt rename to unmaintained/db2/statements/authors.txt diff --git a/extra/db2/statements/statements-tests.factor b/unmaintained/db2/statements/statements-tests.factor similarity index 100% rename from extra/db2/statements/statements-tests.factor rename to unmaintained/db2/statements/statements-tests.factor diff --git a/extra/db2/statements/statements.factor b/unmaintained/db2/statements/statements.factor similarity index 100% rename from extra/db2/statements/statements.factor rename to unmaintained/db2/statements/statements.factor diff --git a/extra/db2/tester/authors.txt b/unmaintained/db2/tester/authors.txt similarity index 100% rename from extra/db2/tester/authors.txt rename to unmaintained/db2/tester/authors.txt diff --git a/extra/db2/tester/tester-tests.factor b/unmaintained/db2/tester/tester-tests.factor similarity index 100% rename from extra/db2/tester/tester-tests.factor rename to unmaintained/db2/tester/tester-tests.factor diff --git a/extra/db2/tester/tester.factor b/unmaintained/db2/tester/tester.factor similarity index 100% rename from extra/db2/tester/tester.factor rename to unmaintained/db2/tester/tester.factor diff --git a/extra/db2/transactions/authors.txt b/unmaintained/db2/transactions/authors.txt similarity index 100% rename from extra/db2/transactions/authors.txt rename to unmaintained/db2/transactions/authors.txt diff --git a/extra/db2/transactions/transactions.factor b/unmaintained/db2/transactions/transactions.factor similarity index 100% rename from extra/db2/transactions/transactions.factor rename to unmaintained/db2/transactions/transactions.factor diff --git a/extra/db2/types/authors.txt b/unmaintained/db2/types/authors.txt similarity index 100% rename from extra/db2/types/authors.txt rename to unmaintained/db2/types/authors.txt diff --git a/extra/db2/types/types.factor b/unmaintained/db2/types/types.factor similarity index 100% rename from extra/db2/types/types.factor rename to unmaintained/db2/types/types.factor diff --git a/extra/db2/utils/authors.txt b/unmaintained/db2/utils/authors.txt similarity index 100% rename from extra/db2/utils/authors.txt rename to unmaintained/db2/utils/authors.txt diff --git a/extra/db2/utils/utils.factor b/unmaintained/db2/utils/utils.factor similarity index 100% rename from extra/db2/utils/utils.factor rename to unmaintained/db2/utils/utils.factor From 11be11605f48c90fc3fac66ed45b6c6888d98471 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Apr 2009 02:15:01 -0500 Subject: [PATCH 441/772] remove db2 from unmaintained --- unmaintained/db2/authors.txt | 1 - unmaintained/db2/connections/authors.txt | 1 - .../db2/connections/connections-tests.factor | 8 - .../db2/connections/connections.factor | 20 --- unmaintained/db2/db2-tests.factor | 5 - unmaintained/db2/db2.factor | 78 ---------- unmaintained/db2/errors/errors.factor | 42 ------ unmaintained/db2/errors/summary.txt | 1 - unmaintained/db2/fql/authors.txt | 1 - unmaintained/db2/fql/fql-tests.factor | 72 --------- unmaintained/db2/fql/fql.factor | 116 -------------- unmaintained/db2/introspection/authors.txt | 1 - .../db2/introspection/introspection.factor | 34 ----- unmaintained/db2/pools/authors.txt | 1 - unmaintained/db2/pools/pools-tests.factor | 23 --- unmaintained/db2/pools/pools.factor | 20 --- unmaintained/db2/result-sets/authors.txt | 1 - .../db2/result-sets/result-sets.factor | 33 ---- unmaintained/db2/sqlite/authors.txt | 1 - .../db2/sqlite/connections/authors.txt | 1 - .../connections/connections-tests.factor | 4 - .../db2/sqlite/connections/connections.factor | 17 --- unmaintained/db2/sqlite/db/authors.txt | 1 - unmaintained/db2/sqlite/db/db.factor | 12 -- unmaintained/db2/sqlite/errors/authors.txt | 1 - unmaintained/db2/sqlite/errors/errors.factor | 35 ----- unmaintained/db2/sqlite/ffi/ffi.factor | 142 ------------------ .../db2/sqlite/introspection/authors.txt | 1 - .../introspection/introspection-tests.factor | 38 ----- .../sqlite/introspection/introspection.factor | 16 -- unmaintained/db2/sqlite/lib/lib.factor | 110 -------------- .../db2/sqlite/result-sets/authors.txt | 1 - .../db2/sqlite/result-sets/result-sets.factor | 30 ---- unmaintained/db2/sqlite/sqlite.factor | 12 -- .../db2/sqlite/statements/authors.txt | 1 - .../db2/sqlite/statements/statements.factor | 19 --- unmaintained/db2/sqlite/types/authors.txt | 1 - unmaintained/db2/sqlite/types/types.factor | 104 ------------- unmaintained/db2/statements/authors.txt | 1 - .../db2/statements/statements-tests.factor | 73 --------- unmaintained/db2/statements/statements.factor | 53 ------- unmaintained/db2/tester/authors.txt | 2 - unmaintained/db2/tester/tester-tests.factor | 7 - unmaintained/db2/tester/tester.factor | 96 ------------ unmaintained/db2/transactions/authors.txt | 1 - .../db2/transactions/transactions.factor | 26 ---- unmaintained/db2/types/authors.txt | 1 - unmaintained/db2/types/types.factor | 17 --- unmaintained/db2/utils/authors.txt | 1 - unmaintained/db2/utils/utils.factor | 32 ---- 50 files changed, 1315 deletions(-) delete mode 100644 unmaintained/db2/authors.txt delete mode 100644 unmaintained/db2/connections/authors.txt delete mode 100644 unmaintained/db2/connections/connections-tests.factor delete mode 100644 unmaintained/db2/connections/connections.factor delete mode 100644 unmaintained/db2/db2-tests.factor delete mode 100644 unmaintained/db2/db2.factor delete mode 100644 unmaintained/db2/errors/errors.factor delete mode 100644 unmaintained/db2/errors/summary.txt delete mode 100644 unmaintained/db2/fql/authors.txt delete mode 100644 unmaintained/db2/fql/fql-tests.factor delete mode 100644 unmaintained/db2/fql/fql.factor delete mode 100644 unmaintained/db2/introspection/authors.txt delete mode 100644 unmaintained/db2/introspection/introspection.factor delete mode 100644 unmaintained/db2/pools/authors.txt delete mode 100644 unmaintained/db2/pools/pools-tests.factor delete mode 100644 unmaintained/db2/pools/pools.factor delete mode 100644 unmaintained/db2/result-sets/authors.txt delete mode 100644 unmaintained/db2/result-sets/result-sets.factor delete mode 100644 unmaintained/db2/sqlite/authors.txt delete mode 100644 unmaintained/db2/sqlite/connections/authors.txt delete mode 100644 unmaintained/db2/sqlite/connections/connections-tests.factor delete mode 100644 unmaintained/db2/sqlite/connections/connections.factor delete mode 100644 unmaintained/db2/sqlite/db/authors.txt delete mode 100644 unmaintained/db2/sqlite/db/db.factor delete mode 100644 unmaintained/db2/sqlite/errors/authors.txt delete mode 100644 unmaintained/db2/sqlite/errors/errors.factor delete mode 100644 unmaintained/db2/sqlite/ffi/ffi.factor delete mode 100644 unmaintained/db2/sqlite/introspection/authors.txt delete mode 100644 unmaintained/db2/sqlite/introspection/introspection-tests.factor delete mode 100644 unmaintained/db2/sqlite/introspection/introspection.factor delete mode 100644 unmaintained/db2/sqlite/lib/lib.factor delete mode 100644 unmaintained/db2/sqlite/result-sets/authors.txt delete mode 100644 unmaintained/db2/sqlite/result-sets/result-sets.factor delete mode 100644 unmaintained/db2/sqlite/sqlite.factor delete mode 100644 unmaintained/db2/sqlite/statements/authors.txt delete mode 100644 unmaintained/db2/sqlite/statements/statements.factor delete mode 100644 unmaintained/db2/sqlite/types/authors.txt delete mode 100644 unmaintained/db2/sqlite/types/types.factor delete mode 100644 unmaintained/db2/statements/authors.txt delete mode 100644 unmaintained/db2/statements/statements-tests.factor delete mode 100644 unmaintained/db2/statements/statements.factor delete mode 100644 unmaintained/db2/tester/authors.txt delete mode 100644 unmaintained/db2/tester/tester-tests.factor delete mode 100644 unmaintained/db2/tester/tester.factor delete mode 100644 unmaintained/db2/transactions/authors.txt delete mode 100644 unmaintained/db2/transactions/transactions.factor delete mode 100644 unmaintained/db2/types/authors.txt delete mode 100644 unmaintained/db2/types/types.factor delete mode 100644 unmaintained/db2/utils/authors.txt delete mode 100644 unmaintained/db2/utils/utils.factor diff --git a/unmaintained/db2/authors.txt b/unmaintained/db2/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/connections/authors.txt b/unmaintained/db2/connections/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/connections/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/connections/connections-tests.factor b/unmaintained/db2/connections/connections-tests.factor deleted file mode 100644 index f96a201bf6..0000000000 --- a/unmaintained/db2/connections/connections-tests.factor +++ /dev/null @@ -1,8 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test db2.connections db2.tester ; -IN: db2.connections.tests - -! Tests connection - -{ 1 0 } [ [ ] with-db ] must-infer-as diff --git a/unmaintained/db2/connections/connections.factor b/unmaintained/db2/connections/connections.factor deleted file mode 100644 index 7957cb918a..0000000000 --- a/unmaintained/db2/connections/connections.factor +++ /dev/null @@ -1,20 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors destructors fry kernel namespaces ; -IN: db2.connections - -TUPLE: db-connection handle ; - -: new-db-connection ( handle class -- db-connection ) - new - swap >>handle ; inline - -GENERIC: db-open ( db -- db-connection ) -GENERIC: db-close ( handle -- ) - -M: db-connection dispose ( db-connection -- ) - [ db-close ] [ f >>handle drop ] bi ; - -: with-db ( db quot -- ) - [ db-open db-connection over ] dip - '[ _ [ drop @ ] with-disposal ] with-variable ; inline diff --git a/unmaintained/db2/db2-tests.factor b/unmaintained/db2/db2-tests.factor deleted file mode 100644 index 30ee7b3581..0000000000 --- a/unmaintained/db2/db2-tests.factor +++ /dev/null @@ -1,5 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test db2 kernel ; -IN: db2.tests - diff --git a/unmaintained/db2/db2.factor b/unmaintained/db2/db2.factor deleted file mode 100644 index b14ee969be..0000000000 --- a/unmaintained/db2/db2.factor +++ /dev/null @@ -1,78 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors continuations db2.result-sets db2.sqlite.lib -db2.sqlite.result-sets db2.sqlite.statements db2.statements -destructors fry kernel math namespaces sequences strings -db2.sqlite.types ; -IN: db2 - -ERROR: no-in-types statement ; -ERROR: no-out-types statement ; - -: guard-in ( statement -- statement ) - dup in>> [ no-in-types ] unless ; - -: guard-out ( statement -- statement ) - dup out>> [ no-out-types ] unless ; - -GENERIC: sql-command ( object -- ) -GENERIC: sql-query ( object -- sequence ) -GENERIC: sql-bind-command ( object -- ) -GENERIC: sql-bind-query ( object -- sequence ) -GENERIC: sql-bind-typed-command ( object -- ) -GENERIC: sql-bind-typed-query ( object -- sequence ) - -M: string sql-command ( string -- ) - f f sql-command ; - -M: string sql-query ( string -- sequence ) - f f sql-query ; - -M: statement sql-command ( statement -- ) - [ execute-statement ] with-disposal ; - -M: statement sql-query ( statement -- sequence ) - [ statement>result-sequence ] with-disposal ; - -M: statement sql-bind-command ( statement -- ) - [ - guard-in - prepare-statement - [ bind-sequence ] [ statement>result-set drop ] bi - ] with-disposal ; - -M: statement sql-bind-query ( statement -- sequence ) - [ - guard-in - prepare-statement - [ bind-sequence ] [ statement>result-sequence ] bi - ] with-disposal ; - -M: statement sql-bind-typed-command ( statement -- ) - [ - guard-in - prepare-statement - [ bind-typed-sequence ] [ statement>result-set drop ] bi - ] with-disposal ; - -M: statement sql-bind-typed-query ( statement -- sequence ) - [ - guard-in - guard-out - prepare-statement - [ bind-typed-sequence ] [ statement>typed-result-sequence ] bi - ] with-disposal ; - -M: sequence sql-command [ sql-command ] each ; -M: sequence sql-query [ sql-query ] map ; -M: sequence sql-bind-command [ sql-bind-command ] each ; -M: sequence sql-bind-query [ sql-bind-query ] map ; -M: sequence sql-bind-typed-command [ sql-bind-typed-command ] each ; -M: sequence sql-bind-typed-query [ sql-bind-typed-query ] map ; - -M: integer sql-command throw ; -M: integer sql-query throw ; -M: integer sql-bind-command throw ; -M: integer sql-bind-query throw ; -M: integer sql-bind-typed-command throw ; -M: integer sql-bind-typed-query throw ; diff --git a/unmaintained/db2/errors/errors.factor b/unmaintained/db2/errors/errors.factor deleted file mode 100644 index 45353f6fb9..0000000000 --- a/unmaintained/db2/errors/errors.factor +++ /dev/null @@ -1,42 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel continuations fry words constructors -db2.connections ; -IN: db2.errors - -ERROR: db-error ; -ERROR: sql-error location ; -HOOK: parse-sql-error db-connection ( error -- error' ) - -ERROR: sql-unknown-error < sql-error message ; -CONSTRUCTOR: sql-unknown-error ( message -- error ) ; - -ERROR: sql-table-exists < sql-error table ; -CONSTRUCTOR: sql-table-exists ( table -- error ) ; - -ERROR: sql-table-missing < sql-error table ; -CONSTRUCTOR: sql-table-missing ( table -- error ) ; - -ERROR: sql-syntax-error < sql-error message ; -CONSTRUCTOR: sql-syntax-error ( message -- error ) ; - -ERROR: sql-function-exists < sql-error message ; -CONSTRUCTOR: sql-function-exists ( message -- error ) ; - -ERROR: sql-function-missing < sql-error message ; -CONSTRUCTOR: sql-function-missing ( message -- error ) ; - -: ignore-error ( quot word -- ) - '[ dup _ execute [ drop ] [ rethrow ] if ] recover ; inline - -: ignore-table-exists ( quot -- ) - \ sql-table-exists? ignore-error ; inline - -: ignore-table-missing ( quot -- ) - \ sql-table-missing? ignore-error ; inline - -: ignore-function-exists ( quot -- ) - \ sql-function-exists? ignore-error ; inline - -: ignore-function-missing ( quot -- ) - \ sql-function-missing? ignore-error ; inline diff --git a/unmaintained/db2/errors/summary.txt b/unmaintained/db2/errors/summary.txt deleted file mode 100644 index 1cd102173f..0000000000 --- a/unmaintained/db2/errors/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Errors thrown by database library diff --git a/unmaintained/db2/fql/authors.txt b/unmaintained/db2/fql/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/fql/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/fql/fql-tests.factor b/unmaintained/db2/fql/fql-tests.factor deleted file mode 100644 index 84698c09c2..0000000000 --- a/unmaintained/db2/fql/fql-tests.factor +++ /dev/null @@ -1,72 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors db2 db2.statements.tests db2.tester -kernel tools.test db2.fql ; -IN: db2.fql.tests - -: test-fql ( -- ) - create-computer-table - - [ "insert into computer (name, os) values (?, ?);" ] - [ - "computer" { "name" "os" } { "lol" "os2" } expand-fql - sql>> - ] unit-test - - [ "select name, os from computer" ] - [ - select new - { "name" "os" } >>names - "computer" >>from - expand-fql sql>> - ] unit-test - - [ "select name, os from computer group by os order by lol offset 100 limit 3" ] - [ - select new - { "name" "os" } >>names - "computer" >>from - "os" >>group-by - "lol" >>order-by - 100 >>offset - 3 >>limit - expand-fql sql>> - ] unit-test - - [ - "select name, os from computer where (hmm > 1 or foo is NULL) group by os order by lol offset 100 limit 3" - ] [ - select new - { "name" "os" } >>names - "computer" >>from - T{ or f { "hmm > 1" "foo is NULL" } } >>where - "os" >>group-by - "lol" >>order-by - 100 >>offset - 3 >>limit - expand-fql sql>> - ] unit-test - - [ "delete from computer order by omg limit 3" ] - [ - delete new - "computer" >>tables - "omg" >>order-by - 3 >>limit - expand-fql sql>> - ] unit-test - - [ "update computer set name = oscar order by omg limit 3" ] - [ - update new - "computer" >>tables - "name" >>keys - "oscar" >>values - "omg" >>order-by - 3 >>limit - expand-fql sql>> - ] unit-test - - ; - -[ test-fql ] test-dbs diff --git a/unmaintained/db2/fql/fql.factor b/unmaintained/db2/fql/fql.factor deleted file mode 100644 index 0896899b01..0000000000 --- a/unmaintained/db2/fql/fql.factor +++ /dev/null @@ -1,116 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators constructors db2 -db2.private db2.sqlite.lib db2.statements db2.utils destructors -kernel make math.parser sequences strings assocs db2.utils ; -IN: db2.fql - -GENERIC: expand-fql* ( object -- sequence/statement ) -GENERIC: normalize-fql ( object -- sequence/statement ) - -! M: object normalize-fql ; - -TUPLE: insert into names values ; -CONSTRUCTOR: insert ( into names values -- obj ) ; -M: insert normalize-fql ( insert -- insert ) - [ ??1array ] change-names ; - -TUPLE: update tables keys values where order-by limit ; -CONSTRUCTOR: update ( tables keys values where -- obj ) ; -M: update normalize-fql ( insert -- insert ) - [ ??1array ] change-tables - [ ??1array ] change-keys - [ ??1array ] change-values - [ ??1array ] change-order-by ; - -TUPLE: delete tables where order-by limit ; -CONSTRUCTOR: delete ( tables keys values where -- obj ) ; -M: delete normalize-fql ( insert -- insert ) - [ ??1array ] change-tables - [ ??1array ] change-order-by ; - -TUPLE: select names from where group-by order-by offset limit ; -CONSTRUCTOR: select ( names from -- obj ) ; -M: select normalize-fql ( select -- select ) - [ ??1array ] change-names - [ ??1array ] change-from - [ ??1array ] change-group-by - [ ??1array ] change-order-by ; - -! TUPLE: where sequence ; -! M: where normalize-fql ( where -- where ) - ! [ ??1array ] change-sequence ; - -TUPLE: and sequence ; - -TUPLE: or sequence ; - -: expand-fql ( object1 -- object2 ) normalize-fql expand-fql* ; - -M: or expand-fql* ( obj -- string ) - [ - sequence>> "(" % - [ " or " % ] [ expand-fql* % ] interleave - ")" % - ] "" make ; - -M: and expand-fql* ( obj -- string ) - [ - sequence>> "(" % - [ " and " % ] [ expand-fql* % ] interleave - ")" % - ] "" make ; - -M: string expand-fql* ( string -- string ) ; - -M: insert expand-fql* - [ statement new ] dip - [ - { - [ "insert into " % into>> % ] - [ " (" % names>> ", " join % ")" % ] - [ " values (" % values>> length "?" ", " join % ");" % ] - [ values>> >>in ] - } cleave - ] "" make >>sql ; - -M: update expand-fql* - [ statement new ] dip - [ - { - [ "update " % tables>> ", " join % ] - [ - " set " % [ keys>> ] [ values>> ] bi - zip [ ", " % ] [ first2 [ % ] dip " = " % % ] interleave - ] - ! [ " " % from>> ", " join % ] - [ where>> [ " where " % expand-fql* % ] when* ] - [ order-by>> [ " order by " % ", " join % ] when* ] - [ limit>> [ " limit " % # ] when* ] - } cleave - ] "" make >>sql ; - -M: delete expand-fql* - [ statement new ] dip - [ - { - [ "delete from " % tables>> ", " join % ] - [ where>> [ " where " % expand-fql* % ] when* ] - [ order-by>> [ " order by " % ", " join % ] when* ] - [ limit>> [ " limit " % # ] when* ] - } cleave - ] "" make >>sql ; - -M: select expand-fql* - [ statement new ] dip - [ - { - [ "select " % names>> ", " join % ] - [ " from " % from>> ", " join % ] - [ where>> [ " where " % expand-fql* % ] when* ] - [ group-by>> [ " group by " % ", " join % ] when* ] - [ order-by>> [ " order by " % ", " join % ] when* ] - [ offset>> [ " offset " % # ] when* ] - [ limit>> [ " limit " % # ] when* ] - } cleave - ] "" make >>sql ; diff --git a/unmaintained/db2/introspection/authors.txt b/unmaintained/db2/introspection/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/introspection/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/introspection/introspection.factor b/unmaintained/db2/introspection/introspection.factor deleted file mode 100644 index 8ab08876aa..0000000000 --- a/unmaintained/db2/introspection/introspection.factor +++ /dev/null @@ -1,34 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: combinators constructors db2.connections -db2.sqlite.types kernel sequence-parser sequences splitting ; -IN: db2.introspection - -TUPLE: table-schema table columns ; -CONSTRUCTOR: table-schema ( table columns -- table-schema ) ; - -TUPLE: column name type modifiers ; -CONSTRUCTOR: column ( name type modifiers -- column ) ; - -HOOK: query-table-schema* db-connection ( name -- table-schema ) -HOOK: parse-create-statement db-connection ( name -- table-schema ) - -: parse-column ( string -- column ) - skip-whitespace - [ " " take-until-sequence ] - [ take-token sqlite-type>fql-type ] - [ take-rest ] tri ; - -: parse-columns ( string -- seq ) - "," split [ parse-column ] map ; - -M: object parse-create-statement ( string -- table-schema ) - { - [ "CREATE TABLE " take-sequence* ] - [ "(" take-until-sequence ] - [ "(" take-sequence* ] - [ take-rest [ CHAR: ) = ] trim-tail parse-columns ] - } cleave ; - -: query-table-schema ( name -- table-schema ) - query-table-schema* [ parse-create-statement ] map ; diff --git a/unmaintained/db2/pools/authors.txt b/unmaintained/db2/pools/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/unmaintained/db2/pools/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/unmaintained/db2/pools/pools-tests.factor b/unmaintained/db2/pools/pools-tests.factor deleted file mode 100644 index d61b745b03..0000000000 --- a/unmaintained/db2/pools/pools-tests.factor +++ /dev/null @@ -1,23 +0,0 @@ -USING: accessors continuations db2.pools db2.sqlite -db2.sqlite.connections destructors io.directories io.files -io.files.temp kernel math namespaces tools.test -db2.sqlite.connections ; -IN: db2.pools.tests - -\ must-infer - -{ 1 0 } [ [ ] with-db-pool ] must-infer-as - -{ 1 0 } [ [ ] with-pooled-db ] must-infer-as - -! Test behavior after image save/load - -[ "pool-test.db" temp-file delete-file ] ignore-errors - -[ ] [ "pool-test.db" temp-file "pool" set ] unit-test - -[ ] [ "pool" get expired>> t >>expired drop ] unit-test - -[ ] [ 1000 [ "pool" get [ ] with-pooled-db ] times ] unit-test - -[ ] [ "pool" get dispose ] unit-test diff --git a/unmaintained/db2/pools/pools.factor b/unmaintained/db2/pools/pools.factor deleted file mode 100644 index 2b1aa2f0bf..0000000000 --- a/unmaintained/db2/pools/pools.factor +++ /dev/null @@ -1,20 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors db2.connections fry io.pools kernel -namespaces ; -IN: db2.pools - -TUPLE: db-pool < pool db ; - -: ( db -- pool ) - db-pool - swap >>db ; - -: with-db-pool ( db quot -- ) - [ ] dip with-pool ; inline - -M: db-pool make-connection ( pool -- ) - db>> db-open ; - -: with-pooled-db ( pool quot -- ) - '[ db-connection _ with-variable ] with-pooled-connection ; inline diff --git a/unmaintained/db2/result-sets/authors.txt b/unmaintained/db2/result-sets/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/result-sets/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/result-sets/result-sets.factor b/unmaintained/db2/result-sets/result-sets.factor deleted file mode 100644 index 499808930a..0000000000 --- a/unmaintained/db2/result-sets/result-sets.factor +++ /dev/null @@ -1,33 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences combinators fry ; -IN: db2.result-sets - -TUPLE: result-set sql in out handle n max ; - -GENERIC: #rows ( result-set -- n ) -GENERIC: #columns ( result-set -- n ) -GENERIC: advance-row ( result-set -- ) -GENERIC: more-rows? ( result-set -- ? ) -GENERIC# column 1 ( result-set column -- obj ) -GENERIC# column-typed 2 ( result-set column type -- sql ) - -: init-result-set ( result-set -- result-set ) - dup #rows >>max - 0 >>n ; - -: new-result-set ( query class -- result-set ) - new - swap { - [ handle>> >>handle ] - [ sql>> >>sql ] - [ in>> >>in ] - [ out>> >>out ] - } cleave ; - -: sql-row ( result-set -- seq ) - dup #columns [ column ] with map ; - -: sql-row-typed ( result-set -- seq ) - [ #columns ] [ out>> ] [ ] tri - '[ [ _ ] 2dip column-typed ] 2map ; diff --git a/unmaintained/db2/sqlite/authors.txt b/unmaintained/db2/sqlite/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/sqlite/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/sqlite/connections/authors.txt b/unmaintained/db2/sqlite/connections/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/sqlite/connections/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/sqlite/connections/connections-tests.factor b/unmaintained/db2/sqlite/connections/connections-tests.factor deleted file mode 100644 index ed80810508..0000000000 --- a/unmaintained/db2/sqlite/connections/connections-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test db2.sqlite.connections ; -IN: db2.sqlite.connections.tests diff --git a/unmaintained/db2/sqlite/connections/connections.factor b/unmaintained/db2/sqlite/connections/connections.factor deleted file mode 100644 index ae96e58d28..0000000000 --- a/unmaintained/db2/sqlite/connections/connections.factor +++ /dev/null @@ -1,17 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators db2.connections db2.sqlite -db2.sqlite.errors db2.sqlite.lib kernel db2.errors ; -IN: db2.sqlite.connections - -M: sqlite-db db-open ( db -- db-connection ) - path>> sqlite-open ; - -M: sqlite-db-connection db-close ( db-connection -- ) - handle>> sqlite-close ; - -M: sqlite-db-connection parse-sql-error ( error -- error' ) - dup n>> { - { 1 [ string>> parse-sqlite-sql-error ] } - [ drop ] - } case ; diff --git a/unmaintained/db2/sqlite/db/authors.txt b/unmaintained/db2/sqlite/db/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/sqlite/db/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/sqlite/db/db.factor b/unmaintained/db2/sqlite/db/db.factor deleted file mode 100644 index d5d580cb1a..0000000000 --- a/unmaintained/db2/sqlite/db/db.factor +++ /dev/null @@ -1,12 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors ; -IN: db2.sqlite.db - -TUPLE: sqlite-db path ; - -: ( path -- sqlite-db ) - sqlite-db new - swap >>path ; - - diff --git a/unmaintained/db2/sqlite/errors/authors.txt b/unmaintained/db2/sqlite/errors/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/sqlite/errors/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/sqlite/errors/errors.factor b/unmaintained/db2/sqlite/errors/errors.factor deleted file mode 100644 index 61e70f210d..0000000000 --- a/unmaintained/db2/sqlite/errors/errors.factor +++ /dev/null @@ -1,35 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators db2.connections db2.errors -db2.sqlite.ffi kernel locals namespaces peg.ebnf sequences -strings ; -IN: db2.sqlite.errors - -ERROR: sqlite-error < db-error n string ; -ERROR: sqlite-sql-error < sql-error n string ; - -: sqlite-statement-error ( -- * ) - SQLITE_ERROR - db-connection get handle>> sqlite3_errmsg sqlite-sql-error ; - -TUPLE: unparsed-sqlite-error error ; -C: unparsed-sqlite-error - -EBNF: parse-sqlite-sql-error - -TableMessage = " already exists" -SyntaxError = ": syntax error" - -SqliteError = - "table " (!(TableMessage).)+:table TableMessage:message - => [[ table >string ]] - | "near " (!(SyntaxError).)+:syntax SyntaxError:message - => [[ syntax >string ]] - | "no such table: " .+:table - => [[ table >string ]] - | .*:error - => [[ error >string ]] -;EBNF - -: throw-sqlite-error ( n -- * ) - dup sqlite-error-messages nth sqlite-error ; diff --git a/unmaintained/db2/sqlite/ffi/ffi.factor b/unmaintained/db2/sqlite/ffi/ffi.factor deleted file mode 100644 index 2594978ddf..0000000000 --- a/unmaintained/db2/sqlite/ffi/ffi.factor +++ /dev/null @@ -1,142 +0,0 @@ -! Copyright (C) 2005 Chris Double, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -! Not all functions have been wrapped. -USING: alien alien.libraries alien.syntax combinators system ; -IN: db2.sqlite.ffi - -<< "sqlite" { - { [ os winnt? ] [ "sqlite3.dll" ] } - { [ os macosx? ] [ "/usr/lib/libsqlite3.dylib" ] } - { [ os unix? ] [ "libsqlite3.so" ] } - } cond "cdecl" add-library >> - -LIBRARY: sqlite - -! Return values from sqlite functions -CONSTANT: SQLITE_OK 0 ! Successful result -CONSTANT: SQLITE_ERROR 1 ! SQL error or missing database -CONSTANT: SQLITE_INTERNAL 2 ! An internal logic error in SQLite -CONSTANT: SQLITE_PERM 3 ! Access permission denied -CONSTANT: SQLITE_ABORT 4 ! Callback routine requested an abort -CONSTANT: SQLITE_BUSY 5 ! The database file is locked -CONSTANT: SQLITE_LOCKED 6 ! A table in the database is locked -CONSTANT: SQLITE_NOMEM 7 ! A malloc() failed -CONSTANT: SQLITE_READONLY 8 ! Attempt to write a readonly database -CONSTANT: SQLITE_INTERRUPT 9 ! Operation terminated by sqlite_interrupt() -CONSTANT: SQLITE_IOERR 10 ! Some kind of disk I/O error occurred -CONSTANT: SQLITE_CORRUPT 11 ! The database disk image is malformed -CONSTANT: SQLITE_NOTFOUND 12 ! (Internal Only) Table or record not found -CONSTANT: SQLITE_FULL 13 ! Insertion failed because database is full -CONSTANT: SQLITE_CANTOPEN 14 ! Unable to open the database file -CONSTANT: SQLITE_PROTOCOL 15 ! Database lock protocol error -CONSTANT: SQLITE_EMPTY 16 ! (Internal Only) Database table is empty -CONSTANT: SQLITE_SCHEMA 17 ! The database schema changed -CONSTANT: SQLITE_TOOBIG 18 ! Too much data for one row of a table -CONSTANT: SQLITE_CONSTRAINT 19 ! Abort due to contraint violation -CONSTANT: SQLITE_MISMATCH 20 ! Data type mismatch -CONSTANT: SQLITE_MISUSE 21 ! Library used incorrectly -CONSTANT: SQLITE_NOLFS 22 ! Uses OS features not supported on host -CONSTANT: SQLITE_AUTH 23 ! Authorization denied -CONSTANT: SQLITE_FORMAT 24 ! Auxiliary database format error -CONSTANT: SQLITE_RANGE 25 ! 2nd parameter to sqlite3_bind out of range -CONSTANT: SQLITE_NOTADB 26 ! File opened that is not a database file - -CONSTANT: sqlite-error-messages -{ - "Successful result" - "SQL error or missing database" - "An internal logic error in SQLite" - "Access permission denied" - "Callback routine requested an abort" - "The database file is locked" - "A table in the database is locked" - "A malloc() failed" - "Attempt to write a readonly database" - "Operation terminated by sqlite_interrupt()" - "Some kind of disk I/O error occurred" - "The database disk image is malformed" - "(Internal Only) Table or record not found" - "Insertion failed because database is full" - "Unable to open the database file" - "Database lock protocol error" - "(Internal Only) Database table is empty" - "The database schema changed" - "Too much data for one row of a table" - "Abort due to contraint violation" - "Data type mismatch" - "Library used incorrectly" - "Uses OS features not supported on host" - "Authorization denied" - "Auxiliary database format error" - "2nd parameter to sqlite3_bind out of range" - "File opened that is not a database file" -} - -! Return values from sqlite3_step -CONSTANT: SQLITE_ROW 100 -CONSTANT: SQLITE_DONE 101 - -! Return values from the sqlite3_column_type function -CONSTANT: SQLITE_INTEGER 1 -CONSTANT: SQLITE_FLOAT 2 -CONSTANT: SQLITE_TEXT 3 -CONSTANT: SQLITE_BLOB 4 -CONSTANT: SQLITE_NULL 5 - -! Values for the 'destructor' parameter of the 'bind' routines. -CONSTANT: SQLITE_STATIC 0 -CONSTANT: SQLITE_TRANSIENT -1 - -CONSTANT: SQLITE_OPEN_READONLY HEX: 00000001 -CONSTANT: SQLITE_OPEN_READWRITE HEX: 00000002 -CONSTANT: SQLITE_OPEN_CREATE HEX: 00000004 -CONSTANT: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008 -CONSTANT: SQLITE_OPEN_EXCLUSIVE HEX: 00000010 -CONSTANT: SQLITE_OPEN_MAIN_DB HEX: 00000100 -CONSTANT: SQLITE_OPEN_TEMP_DB HEX: 00000200 -CONSTANT: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400 -CONSTANT: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800 -CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 -CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 -CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 - -TYPEDEF: void sqlite3 -TYPEDEF: void sqlite3_stmt -TYPEDEF: longlong sqlite3_int64 -TYPEDEF: ulonglong sqlite3_uint64 - -FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ; -FUNCTION: int sqlite3_close ( sqlite3* pDb ) ; -FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ; -FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ; -FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ; -FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ; -FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; -FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ; -FUNCTION: sqlite3_uint64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; -FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ; -FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ; -FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; -FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ; -! Bind the same function as above, but for unsigned 64bit integers -: sqlite3-bind-uint64 ( pStmt index in64 -- int ) - "int" "sqlite" "sqlite3_bind_int64" - { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ; -FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ; -FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ; -FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ; -FUNCTION: int sqlite3_clear_bindings ( sqlite3_stmt* pStmt ) ; -FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ; -FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ; -! Bind the same function as above, but for unsigned 64bit integers -: sqlite3-column-uint64 ( pStmt col -- uint64 ) - "sqlite3_uint64" "sqlite" "sqlite3_column_int64" - { "sqlite3_stmt*" "int" } alien-invoke ; -FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ; diff --git a/unmaintained/db2/sqlite/introspection/authors.txt b/unmaintained/db2/sqlite/introspection/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/sqlite/introspection/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/sqlite/introspection/introspection-tests.factor b/unmaintained/db2/sqlite/introspection/introspection-tests.factor deleted file mode 100644 index d8ebc4d60e..0000000000 --- a/unmaintained/db2/sqlite/introspection/introspection-tests.factor +++ /dev/null @@ -1,38 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: db2.connections db2.introspection -db2.sqlite.introspection db2.tester db2.types tools.test ; -IN: db2.sqlite.introspection.tests - - -: test-sqlite-introspection ( -- ) - [ - { - T{ table-schema - { table "computer" } - { columns - { - T{ column - { name "name" } - { type VARCHAR } - { modifiers "" } - } - T{ column - { name "os" } - { type VARCHAR } - { modifiers "" } - } - } - } - } - } - ] [ - - sqlite-test-db [ - "computer" query-table-schema - ] with-db - ] unit-test - - ; - -[ test-sqlite-introspection ] test-sqlite diff --git a/unmaintained/db2/sqlite/introspection/introspection.factor b/unmaintained/db2/sqlite/introspection/introspection.factor deleted file mode 100644 index 41def2c558..0000000000 --- a/unmaintained/db2/sqlite/introspection/introspection.factor +++ /dev/null @@ -1,16 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays db2 db2.introspection db2.sqlite multiline -sequences ; -IN: db2.sqlite.introspection - -M: sqlite-db-connection query-table-schema* - 1array -<" -SELECT sql FROM - (SELECT * FROM sqlite_master UNION ALL - SELECT * FROM sqlite_temp_master) -WHERE type!='meta' and tbl_name = ? -ORDER BY tbl_name, type DESC, name -"> - sql-bind-query* first ; diff --git a/unmaintained/db2/sqlite/lib/lib.factor b/unmaintained/db2/sqlite/lib/lib.factor deleted file mode 100644 index e366305fcd..0000000000 --- a/unmaintained/db2/sqlite/lib/lib.factor +++ /dev/null @@ -1,110 +0,0 @@ -! Copyright (C) 2008 Chris Double, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types arrays calendar.format -combinators db2.sqlite.errors -io.backend io.encodings.string io.encodings.utf8 kernel math -namespaces present sequences serialize urls db2.sqlite.ffi ; -IN: db2.sqlite.lib - -: sqlite-check-result ( n -- ) - { - { SQLITE_OK [ ] } - { SQLITE_ERROR [ sqlite-statement-error ] } - [ throw-sqlite-error ] - } case ; - -: sqlite-open ( path -- db ) - "void*" - [ sqlite3_open sqlite-check-result ] keep *void* ; - -: sqlite-close ( db -- ) - sqlite3_close sqlite-check-result ; - -: sqlite-prepare ( db sql -- handle ) - utf8 encode dup length "void*" "void*" - [ sqlite3_prepare_v2 sqlite-check-result ] 2keep - drop *void* ; - -: sqlite-bind-parameter-index ( handle name -- index ) - sqlite3_bind_parameter_index ; - -: parameter-index ( handle name text -- handle name text ) - [ dupd sqlite-bind-parameter-index ] dip ; - -: sqlite-bind-text ( handle index text -- ) - utf8 encode dup length SQLITE_TRANSIENT - sqlite3_bind_text sqlite-check-result ; - -: sqlite-bind-int ( handle i n -- ) - sqlite3_bind_int sqlite-check-result ; - -: sqlite-bind-int64 ( handle i n -- ) - sqlite3_bind_int64 sqlite-check-result ; - -: sqlite-bind-uint64 ( handle i n -- ) - sqlite3-bind-uint64 sqlite-check-result ; - -: sqlite-bind-boolean ( handle name obj -- ) - >boolean 1 0 ? sqlite-bind-int ; - -: sqlite-bind-double ( handle i x -- ) - sqlite3_bind_double sqlite-check-result ; - -: sqlite-bind-null ( handle i -- ) - sqlite3_bind_null sqlite-check-result ; - -: sqlite-bind-blob ( handle i byte-array -- ) - dup length SQLITE_TRANSIENT - sqlite3_bind_blob sqlite-check-result ; - -: sqlite-bind-text-by-name ( handle name text -- ) - parameter-index sqlite-bind-text ; - -: sqlite-bind-int-by-name ( handle name int -- ) - parameter-index sqlite-bind-int ; - -: sqlite-bind-int64-by-name ( handle name int64 -- ) - parameter-index sqlite-bind-int64 ; - -: sqlite-bind-uint64-by-name ( handle name int64 -- ) - parameter-index sqlite-bind-uint64 ; - -: sqlite-bind-boolean-by-name ( handle name obj -- ) - >boolean 1 0 ? parameter-index sqlite-bind-int ; - -: sqlite-bind-double-by-name ( handle name double -- ) - parameter-index sqlite-bind-double ; - -: sqlite-bind-blob-by-name ( handle name blob -- ) - parameter-index sqlite-bind-blob ; - -: sqlite-bind-null-by-name ( handle name obj -- ) - parameter-index drop sqlite-bind-null ; - -: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ; -: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ; -: sqlite-clear-bindings ( handle -- ) - sqlite3_clear_bindings sqlite-check-result ; -: sqlite-#columns ( query -- int ) sqlite3_column_count ; -: sqlite-column ( handle index -- string ) sqlite3_column_text ; -: sqlite-column-name ( handle index -- string ) sqlite3_column_name ; -: sqlite-column-type ( handle index -- string ) sqlite3_column_type ; - -: sqlite-column-blob ( handle index -- byte-array/f ) - [ sqlite3_column_bytes ] 2keep - pick zero? [ - 3drop f - ] [ - sqlite3_column_blob swap memory>byte-array - ] if ; - -: sqlite-step-has-more-rows? ( prepared -- ? ) - { - { SQLITE_ROW [ t ] } - { SQLITE_DONE [ f ] } - [ sqlite-check-result f ] - } case ; - -: sqlite-next ( prepared -- ? ) - sqlite3_step sqlite-step-has-more-rows? ; - diff --git a/unmaintained/db2/sqlite/result-sets/authors.txt b/unmaintained/db2/sqlite/result-sets/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/sqlite/result-sets/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/sqlite/result-sets/result-sets.factor b/unmaintained/db2/sqlite/result-sets/result-sets.factor deleted file mode 100644 index 3b3226ef39..0000000000 --- a/unmaintained/db2/sqlite/result-sets/result-sets.factor +++ /dev/null @@ -1,30 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors db2.result-sets db2.sqlite.statements -db2.statements kernel db2.sqlite.lib destructors -db2.sqlite.types ; -IN: db2.sqlite.result-sets - -TUPLE: sqlite-result-set < result-set has-more? ; - -M: sqlite-result-set dispose - f >>handle drop ; - -M: sqlite-statement statement>result-set* - prepare-statement - sqlite-result-set new-result-set dup advance-row ; - -M: sqlite-result-set advance-row ( result-set -- ) - dup handle>> sqlite-next >>has-more? drop ; - -M: sqlite-result-set more-rows? ( result-set -- ) - has-more?>> ; - -M: sqlite-result-set #columns ( result-set -- n ) - handle>> sqlite-#columns ; - -M: sqlite-result-set column ( result-set n -- obj ) - [ handle>> ] [ sqlite-column ] bi* ; - -M: sqlite-result-set column-typed ( result-set n type -- obj ) - [ handle>> ] 2dip sqlite-type ; diff --git a/unmaintained/db2/sqlite/sqlite.factor b/unmaintained/db2/sqlite/sqlite.factor deleted file mode 100644 index 82337ae30b..0000000000 --- a/unmaintained/db2/sqlite/sqlite.factor +++ /dev/null @@ -1,12 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: constructors db2.connections ; -IN: db2.sqlite - -TUPLE: sqlite-db path ; -CONSTRUCTOR: sqlite-db ( path -- sqlite-db ) ; - -TUPLE: sqlite-db-connection < db-connection ; - -: ( handle -- db-connection ) - sqlite-db-connection new-db-connection ; diff --git a/unmaintained/db2/sqlite/statements/authors.txt b/unmaintained/db2/sqlite/statements/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/sqlite/statements/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/sqlite/statements/statements.factor b/unmaintained/db2/sqlite/statements/statements.factor deleted file mode 100644 index 0033ad06e1..0000000000 --- a/unmaintained/db2/sqlite/statements/statements.factor +++ /dev/null @@ -1,19 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors db2.connections db2.sqlite.connections -db2.sqlite.ffi db2.sqlite.lib db2.statements destructors kernel -namespaces db2.sqlite ; -IN: db2.sqlite.statements - -TUPLE: sqlite-statement < statement ; - -M: sqlite-db-connection ( string in out -- obj ) - sqlite-statement new-statement ; - -M: sqlite-statement dispose - handle>> - [ [ sqlite3_reset drop ] [ sqlite-finalize ] bi ] when* ; - -M: sqlite-statement prepare-statement* ( statement -- statement ) - db-connection get handle>> over sql>> sqlite-prepare - >>handle ; diff --git a/unmaintained/db2/sqlite/types/authors.txt b/unmaintained/db2/sqlite/types/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/sqlite/types/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/sqlite/types/types.factor b/unmaintained/db2/sqlite/types/types.factor deleted file mode 100644 index d2047c1aeb..0000000000 --- a/unmaintained/db2/sqlite/types/types.factor +++ /dev/null @@ -1,104 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays calendar.format combinators -db2.sqlite.ffi db2.sqlite.lib db2.sqlite.statements -db2.statements db2.types db2.utils fry kernel math present -sequences serialize urls ; -IN: db2.sqlite.types - -: (bind-sqlite-type) ( handle key value type -- ) - dup array? [ first ] when - { - { INTEGER [ sqlite-bind-int-by-name ] } - { BIG-INTEGER [ sqlite-bind-int64-by-name ] } - { SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] } - { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] } - { BOOLEAN [ sqlite-bind-boolean-by-name ] } - { TEXT [ sqlite-bind-text-by-name ] } - { VARCHAR [ sqlite-bind-text-by-name ] } - { DOUBLE [ sqlite-bind-double-by-name ] } - { DATE [ timestamp>ymd sqlite-bind-text-by-name ] } - { TIME [ timestamp>hms sqlite-bind-text-by-name ] } - { DATETIME [ timestamp>ymdhms sqlite-bind-text-by-name ] } - { TIMESTAMP [ timestamp>ymdhms sqlite-bind-text-by-name ] } - { BLOB [ sqlite-bind-blob-by-name ] } - { FACTOR-BLOB [ object>bytes sqlite-bind-blob-by-name ] } - { URL [ present sqlite-bind-text-by-name ] } - { +db-assigned-id+ [ sqlite-bind-int-by-name ] } - { +random-id+ [ sqlite-bind-int64-by-name ] } - { NULL [ sqlite-bind-null-by-name ] } - [ no-sql-type ] - } case ; - -: bind-next-sqlite-type ( handle key value type -- ) - dup array? [ first ] when - { - { INTEGER [ sqlite-bind-int ] } - { BIG-INTEGER [ sqlite-bind-int64 ] } - { SIGNED-BIG-INTEGER [ sqlite-bind-int64 ] } - { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64 ] } - { BOOLEAN [ sqlite-bind-boolean ] } - { TEXT [ sqlite-bind-text ] } - { VARCHAR [ sqlite-bind-text ] } - { DOUBLE [ sqlite-bind-double ] } - { DATE [ timestamp>ymd sqlite-bind-text ] } - { TIME [ timestamp>hms sqlite-bind-text ] } - { DATETIME [ timestamp>ymdhms sqlite-bind-text ] } - { TIMESTAMP [ timestamp>ymdhms sqlite-bind-text ] } - { BLOB [ sqlite-bind-blob ] } - { FACTOR-BLOB [ object>bytes sqlite-bind-blob ] } - { URL [ present sqlite-bind-text ] } - { +db-assigned-id+ [ sqlite-bind-int ] } - { +random-id+ [ sqlite-bind-int64 ] } - { NULL [ drop sqlite-bind-null ] } - [ no-sql-type ] - } case ; - -: bind-sqlite-type ( handle key value type -- ) - #! null and empty values need to be set by sqlite-bind-null-by-name - over [ - NULL = [ 2drop NULL NULL ] when - ] [ - drop NULL - ] if* (bind-sqlite-type) ; - -: sqlite-type ( handle index type -- obj ) - dup array? [ first ] when - { - { +db-assigned-id+ [ sqlite3_column_int64 ] } - { +random-id+ [ sqlite3-column-uint64 ] } - { INTEGER [ sqlite3_column_int ] } - { BIG-INTEGER [ sqlite3_column_int64 ] } - { SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] } - { UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] } - { BOOLEAN [ sqlite3_column_int 1 = ] } - { DOUBLE [ sqlite3_column_double ] } - { TEXT [ sqlite3_column_text ] } - { VARCHAR [ sqlite3_column_text ] } - { DATE [ sqlite3_column_text [ ymd>timestamp ] ?when ] } - { TIME [ sqlite3_column_text [ hms>timestamp ] ?when ] } - { TIMESTAMP [ sqlite3_column_text [ ymdhms>timestamp ] ?when ] } - { DATETIME [ sqlite3_column_text [ ymdhms>timestamp ] ?when ] } - { BLOB [ sqlite-column-blob ] } - { URL [ sqlite3_column_text [ >url ] ?when ] } - { FACTOR-BLOB [ sqlite-column-blob [ bytes>object ] ?when ] } - [ no-sql-type ] - } case ; - -M: sqlite-statement bind-sequence ( statement -- ) - [ in>> ] [ handle>> ] bi '[ - [ _ ] 2dip 1+ swap sqlite-bind-text - ] each-index ; - -M: sqlite-statement bind-typed-sequence ( statement -- ) - [ in>> ] [ handle>> ] bi '[ - [ _ ] 2dip 1+ swap first2 swap bind-next-sqlite-type - ] each-index ; - -ERROR: no-fql-type type ; - -: sqlite-type>fql-type ( string -- type ) - { - { "varchar" [ VARCHAR ] } - [ no-fql-type ] - } case ; diff --git a/unmaintained/db2/statements/authors.txt b/unmaintained/db2/statements/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/statements/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/statements/statements-tests.factor b/unmaintained/db2/statements/statements-tests.factor deleted file mode 100644 index 8a872293d9..0000000000 --- a/unmaintained/db2/statements/statements-tests.factor +++ /dev/null @@ -1,73 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test db2.statements kernel db2 db2.tester -continuations db2.errors accessors db2.types ; -IN: db2.statements.tests - -{ 1 0 } [ [ drop ] result-set-each ] must-infer-as -{ 1 1 } [ [ ] result-set-map ] must-infer-as - -: create-computer-table ( -- ) - [ "drop table computer;" sql-command ] ignore-errors - - [ "drop table computer;" sql-command ] - [ [ sql-table-missing? ] [ table>> "computer" = ] bi and ] must-fail-with - - [ ] [ - "create table computer(name varchar, os varchar, version integer);" - sql-command - ] unit-test ; - - -: test-sql-command ( -- ) - create-computer-table - - [ ] [ - "insert into computer (name, os) values('rocky', 'mac');" - sql-command - ] unit-test - - [ { { "rocky" "mac" } } ] - [ - "select name, os from computer;" - f f sql-query - ] unit-test - - [ "insert into" sql-command ] - [ sql-syntax-error? ] must-fail-with - - [ "selectt" sql-query ] - [ sql-syntax-error? ] must-fail-with - - [ ] [ - "insert into computer (name, os, version) values(?, ?, ?);" - { "clubber" "windows" "7" } - f - sql-bind-command - ] unit-test - - [ { { "windows" } } ] [ - "select os from computer where name = ?;" - { "clubber" } f sql-bind-query - ] unit-test - - [ { { "windows" 7 } } ] [ - "select os, version from computer where name = ?;" - { { VARCHAR "clubber" } } - { VARCHAR INTEGER } - sql-bind-typed-query - ] unit-test - - [ ] [ - "insert into computer (name, os, version) values(?, ?, ?);" - { - { VARCHAR "paulie" } - { VARCHAR "netbsd" } - { INTEGER 7 } - } f - sql-bind-typed-command - ] unit-test - - ; - -[ test-sql-command ] test-dbs diff --git a/unmaintained/db2/statements/statements.factor b/unmaintained/db2/statements/statements.factor deleted file mode 100644 index 9ddd74ded7..0000000000 --- a/unmaintained/db2/statements/statements.factor +++ /dev/null @@ -1,53 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors continuations destructors fry kernel -sequences db2.result-sets db2.connections db2.errors ; -IN: db2.statements - -TUPLE: statement handle sql in out type ; - -: new-statement ( sql in out class -- statement ) - new - swap >>out - swap >>in - swap >>sql ; - -HOOK: db-connection ( sql in out -- statement ) -GENERIC: statement>result-set* ( statement -- result-set ) -GENERIC: execute-statement* ( statement type -- ) -GENERIC: prepare-statement* ( statement -- statement' ) -GENERIC: bind-sequence ( statement -- ) -GENERIC: bind-typed-sequence ( statement -- ) - -: statement>result-set ( statement -- result-set ) - [ statement>result-set* ] - [ dup sql-error? [ parse-sql-error ] when rethrow ] recover ; - -M: object execute-statement* ( statement type -- ) - drop statement>result-set dispose ; - -: execute-one-statement ( statement -- ) - dup type>> execute-statement* ; - -: execute-statement ( statement -- ) - dup sequence? - [ [ execute-one-statement ] each ] - [ execute-one-statement ] if ; - -: prepare-statement ( statement -- statement ) - dup handle>> [ prepare-statement* ] unless ; - -: result-set-each ( statement quot: ( statement -- ) -- ) - over more-rows? - [ [ call ] 2keep over advance-row result-set-each ] - [ 2drop ] if ; inline recursive - -: result-set-map ( statement quot -- sequence ) - accumulator [ result-set-each ] dip { } like ; inline - -: statement>result-sequence ( statement -- sequence ) - statement>result-set [ [ sql-row ] result-set-map ] with-disposal ; - -: statement>typed-result-sequence ( statement -- sequence ) - statement>result-set - [ [ sql-row-typed ] result-set-map ] with-disposal ; diff --git a/unmaintained/db2/tester/authors.txt b/unmaintained/db2/tester/authors.txt deleted file mode 100644 index f372b574ae..0000000000 --- a/unmaintained/db2/tester/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Slava Pestov -Doug Coleman diff --git a/unmaintained/db2/tester/tester-tests.factor b/unmaintained/db2/tester/tester-tests.factor deleted file mode 100644 index b3e8f19e6a..0000000000 --- a/unmaintained/db2/tester/tester-tests.factor +++ /dev/null @@ -1,7 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test db2.tester ; -IN: db2.tester.tests - -! [ ] [ sqlite-test-db db-tester ] unit-test -! [ ] [ sqlite-test-db db-tester2 ] unit-test diff --git a/unmaintained/db2/tester/tester.factor b/unmaintained/db2/tester/tester.factor deleted file mode 100644 index 471752f413..0000000000 --- a/unmaintained/db2/tester/tester.factor +++ /dev/null @@ -1,96 +0,0 @@ -! Copyright (C) 2008 Slava Pestov, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: concurrency.combinators db2.connections -db2.pools db2.sqlite db2.types fry io.files.temp kernel math -namespaces random threads tools.test combinators ; -IN: db2.tester -USE: multiline - -: sqlite-test-db ( -- sqlite-db ) - "tuples-test.db" temp-file ; - -! These words leak resources, but are useful for interactivel testing -: set-sqlite-db ( -- ) - sqlite-db db-open db-connection set ; - -: test-sqlite ( quot -- ) - '[ - [ ] [ sqlite-test-db _ with-db ] unit-test - ] call ; inline - -: test-dbs ( quot -- ) - { - [ test-sqlite ] - } cleave ; - -/* -: postgresql-test-db ( -- postgresql-db ) - - "localhost" >>host - "postgres" >>username - "thepasswordistrust" >>password - "factor-test" >>database ; - -: set-postgresql-db ( -- ) - postgresql-db db-open db-connection set ; - -: test-postgresql ( quot -- ) - '[ - os windows? cpu x86.64? and [ - [ ] [ postgresql-test-db _ with-db ] unit-test - ] unless - ] call ; inline - -TUPLE: test-1 id a b c ; - -test-1 "TEST1" { - { "id" "ID" INTEGER +db-assigned-id+ } - { "a" "A" { VARCHAR 256 } +not-null+ } - { "b" "B" { VARCHAR 256 } +not-null+ } - { "c" "C" { VARCHAR 256 } +not-null+ } -} define-persistent - -TUPLE: test-2 id x y z ; - -test-2 "TEST2" { - { "id" "ID" INTEGER +db-assigned-id+ } - { "x" "X" { VARCHAR 256 } +not-null+ } - { "y" "Y" { VARCHAR 256 } +not-null+ } - { "z" "Z" { VARCHAR 256 } +not-null+ } -} define-persistent - -: db-tester ( test-db -- ) - [ - [ - test-1 ensure-table - test-2 ensure-table - ] with-db - ] [ - 10 [ - drop - 10 [ - dup [ - f 100 random 100 random 100 random test-1 boa - insert-tuple yield - ] with-db - ] times - ] with parallel-each - ] bi ; - -: db-tester2 ( test-db -- ) - [ - [ - test-1 ensure-table - test-2 ensure-table - ] with-db - ] [ - [ - 10 [ - 10 [ - f 100 random 100 random 100 random test-1 boa - insert-tuple yield - ] times - ] parallel-each - ] with-pooled-db - ] bi ; -*/ diff --git a/unmaintained/db2/transactions/authors.txt b/unmaintained/db2/transactions/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/transactions/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/transactions/transactions.factor b/unmaintained/db2/transactions/transactions.factor deleted file mode 100644 index fd0e6ade74..0000000000 --- a/unmaintained/db2/transactions/transactions.factor +++ /dev/null @@ -1,26 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: continuations db2 db2.connections namespaces ; -IN: db2.transactions - -SYMBOL: in-transaction - -HOOK: begin-transaction db-connection ( -- ) - -HOOK: commit-transaction db-connection ( -- ) - -HOOK: rollback-transaction db-connection ( -- ) - -M: db-connection begin-transaction ( -- ) "BEGIN" sql-command ; - -M: db-connection commit-transaction ( -- ) "COMMIT" sql-command ; - -M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ; - -: in-transaction? ( -- ? ) in-transaction get ; - -: with-transaction ( quot -- ) - t in-transaction [ - begin-transaction - [ ] [ rollback-transaction ] cleanup commit-transaction - ] with-variable ; inline diff --git a/unmaintained/db2/types/authors.txt b/unmaintained/db2/types/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/types/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/types/types.factor b/unmaintained/db2/types/types.factor deleted file mode 100644 index 97f9ca0a0c..0000000000 --- a/unmaintained/db2/types/types.factor +++ /dev/null @@ -1,17 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: ; -IN: db2.types - -SINGLETONS: +db-assigned-id+ +user-assigned-id+ +random-id+ ; -UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ; - -SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ -+foreign-id+ +has-many+ +on-update+ +on-delete+ +restrict+ +cascade+ -+set-null+ +set-default+ ; - -SINGLETONS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER -DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB -FACTOR-BLOB NULL URL ; - -ERROR: no-sql-type type ; diff --git a/unmaintained/db2/utils/authors.txt b/unmaintained/db2/utils/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/unmaintained/db2/utils/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/unmaintained/db2/utils/utils.factor b/unmaintained/db2/utils/utils.factor deleted file mode 100644 index 0557593209..0000000000 --- a/unmaintained/db2/utils/utils.factor +++ /dev/null @@ -1,32 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.parser strings sequences -words ; -IN: db2.utils - -: ?when ( object quot -- object' ) dupd when ; inline -: ?1array ( obj -- array ) dup string? [ 1array ] when ; inline -: ??1array ( obj -- array/f ) [ ?1array ] ?when ; inline - -: ?first ( sequence -- object/f ) 0 ?nth ; -: ?second ( sequence -- object/f ) 1 ?nth ; - -: ?first2 ( sequence -- object1/f object2/f ) - [ ?first ] [ ?second ] bi ; - -: assoc-with ( object sequence quot -- obj curry ) - swapd [ [ -rot ] dip call ] 2curry ; inline - -: ?number>string ( n/string -- string ) - dup number? [ number>string ] when ; - -ERROR: no-accessor name ; - -: lookup-accessor ( string -- accessor ) - dup ">>" append "accessors" lookup - [ nip ] [ no-accessor ] if* ; - -ERROR: string-expected object ; - -: ensure-string ( object -- string ) - dup string? [ string-expected ] unless ; From a9b4a724a41ca37eb21539dac9c3ccb3f536fabe Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 03:23:11 -0500 Subject: [PATCH 442/772] Remove "compiled-status" word prop and simplify associated machinery --- basis/compiler/compiler.factor | 37 +++++++++---------------- basis/macros/macros.factor | 9 +++--- basis/tools/deploy/shaker/shaker.factor | 1 - core/definitions/definitions.factor | 3 -- core/words/words.factor | 17 ++++++++---- 5 files changed, 30 insertions(+), 37 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index b8ba620f32..717f66ba88 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -28,23 +28,14 @@ SYMBOL: compiled : maybe-compile ( word -- ) dup optimized>> [ drop ] [ queue-compile ] if ; -SYMBOLS: +optimized+ +unoptimized+ ; +: recompile-callers? ( word -- ? ) + changed-effects get key? ; -: ripple-up ( words -- ) - dup "compiled-status" word-prop +unoptimized+ eq? - [ usage [ word? ] filter ] [ compiled-usage keys ] if - [ queue-compile ] each ; - -: ripple-up? ( status word -- ? ) - [ - [ nip changed-effects get key? ] - [ "compiled-status" word-prop eq? not ] 2bi or - ] keep "compiled-status" word-prop and ; - -: save-compiled-status ( word status -- ) - [ over ripple-up? [ ripple-up ] [ drop ] if ] - [ "compiled-status" set-word-prop ] - 2bi ; +: recompile-callers ( words -- ) + dup recompile-callers? [ + [ usage [ word? ] filter ] [ compiled-usage keys ] bi + [ [ queue-compile ] each ] bi@ + ] [ drop ] if ; : start ( word -- ) "trace-compilation" get [ dup name>> print flush ] when @@ -55,20 +46,19 @@ SYMBOLS: +optimized+ +unoptimized+ ; : ignore-error? ( word error -- ? ) [ { - [ inline? ] [ macro? ] - [ "no-compile" word-prop ] + [ inline? ] [ "special" word-prop ] + [ "no-compile" word-prop ] } 1|| ] [ error-type +compiler-warning+ eq? ] bi* and ; : (fail) ( word compiled -- * ) swap + [ recompile-callers ] [ compiled-unxref ] [ compiled get set-at ] - [ +unoptimized+ save-compiled-status ] - tri - return ; + tri return ; : not-compiled-def ( word error -- def ) '[ _ _ not-compiled ] [ ] like ; @@ -106,11 +96,10 @@ t compile-dependencies? set-global ] each ; : finish ( word -- ) - [ +optimized+ save-compiled-status ] + [ recompile-callers ] [ compiled-unxref ] [ - dup crossref? - [ + dup crossref? [ dependencies get generic-dependencies get compiled-xref diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index a86b711340..0e5ef30f51 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -12,10 +12,11 @@ IN: macros PRIVATE> : define-macro ( word definition effect -- ) - real-macro-effect - [ [ memoize-quot [ call ] append ] keep define-declared ] - [ drop "macro" set-word-prop ] - 3bi ; + real-macro-effect { + [ [ memoize-quot [ call ] append ] keep define-declared ] + [ drop "macro" set-word-prop ] + [ 2drop changed-effect ] + } 3cleave ; SYNTAX: MACRO: (:) define-macro ; diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 807abe4d58..0d7d8fd7c6 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -99,7 +99,6 @@ IN: tools.deploy.shaker "boa-check" "coercer" "combination" - "compiled-status" "compiled-generic-uses" "compiled-uses" "constraints" diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 7463a863e5..1a26e45e87 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -19,9 +19,6 @@ SYMBOL: changed-definitions SYMBOL: changed-effects -: changed-effect ( word -- ) - dup changed-effects get set-in-unit ; - SYMBOL: changed-generics SYMBOL: outdated-generics diff --git a/core/words/words.factor b/core/words/words.factor index 97225c0f75..1a2317997a 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -138,12 +138,15 @@ M: word subwords drop f ; >>def dup crossref? [ dup xref ] when drop ; +: changed-effect ( word -- ) + [ dup changed-effects get set-in-unit ] + [ dup primitive? [ drop ] [ changed-definition ] if ] bi ; + : set-stack-effect ( effect word -- ) 2dup "declared-effect" word-prop = [ 2drop ] [ - swap - [ drop changed-effect ] - [ "declared-effect" set-word-prop ] - [ drop dup primitive? [ drop ] [ changed-definition ] if ] + [ nip changed-effect ] + [ nip subwords [ changed-effect ] each ] + [ swap "declared-effect" set-word-prop ] 2tri ] if ; @@ -151,7 +154,11 @@ M: word subwords drop f ; [ nip swap set-stack-effect ] [ drop define ] 3bi ; : make-inline ( word -- ) - t "inline" set-word-prop ; + dup inline? [ drop ] [ + [ t "inline" set-word-prop ] + [ changed-effect ] + bi + ] if ; : make-recursive ( word -- ) t "recursive" set-word-prop ; From 469c9ee21d93b9b8a29aa81bb5cef7c3fb74083f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 16:09:53 -0500 Subject: [PATCH 443/772] Debugging stack checking --- basis/compiler/tests/redefine0.factor | 74 +++++++++++++++++++ basis/compiler/tests/redefine16.factor | 4 +- basis/compiler/tree/builder/builder.factor | 2 +- .../compiler/tree/optimizer/optimizer.factor | 1 - .../tree/propagation/inlining/inlining.factor | 12 +-- .../known-words/known-words.factor | 5 ++ .../known-words/known-words.factor | 5 +- core/classes/tuple/tuple-tests.factor | 45 ++++------- core/compiler/units/units-tests.factor | 8 +- 9 files changed, 111 insertions(+), 45 deletions(-) create mode 100644 basis/compiler/tests/redefine0.factor diff --git a/basis/compiler/tests/redefine0.factor b/basis/compiler/tests/redefine0.factor new file mode 100644 index 0000000000..cdef7103ce --- /dev/null +++ b/basis/compiler/tests/redefine0.factor @@ -0,0 +1,74 @@ +IN: compiler.tests.redefine0 +USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math ; + +! Test ripple-up behavior +: test-1 ( -- a ) 3 ; +: test-2 ( -- ) test-1 ; + +[ test-2 ] [ not-compiled? ] must-fail-with + +[ ] [ "IN: compiler.tests.redefine0 : test-1 ( -- ) ;" eval( -- ) ] unit-test + +{ 0 0 } [ test-1 ] must-infer-as + +[ ] [ test-2 ] unit-test + +[ ] [ + [ + \ test-1 forget + \ test-2 forget + ] with-compilation-unit +] unit-test + +: test-3 ( a -- ) drop ; +: test-4 ( -- ) [ 1 2 3 ] test-3 ; + +[ ] [ test-4 ] unit-test + +[ ] [ "IN: compiler.tests.redefine0 USE: kernel : test-3 ( a -- ) call ; inline" eval( -- ) ] unit-test + +[ test-4 ] [ not-compiled? ] must-fail-with + +[ ] [ + [ + \ test-3 forget + \ test-4 forget + ] with-compilation-unit +] unit-test + +: test-5 ( a -- quot ) ; +: test-6 ( a -- b ) test-5 ; + +[ 31337 ] [ 31337 test-6 ] unit-test + +[ ] [ "IN: compiler.tests.redefine0 USING: macros kernel ; MACRO: test-5 ( a -- quot ) drop [ ] ;" eval( -- ) ] unit-test + +[ 31337 test-6 ] [ not-compiled? ] must-fail-with + +[ ] [ + [ + \ test-5 forget + \ test-6 forget + ] with-compilation-unit +] unit-test + +GENERIC: test-7 ( a -- b ) + +M: integer test-7 + ; + +: test-8 ( a -- b ) 255 bitand test-7 ; + +[ 1 test-7 ] [ not-compiled? ] must-fail-with +[ 1 test-8 ] [ not-compiled? ] must-fail-with + +[ ] [ "IN: compiler.tests.redefine0 USING: macros kernel ; GENERIC: test-7 ( x y -- z )" eval( -- ) ] unit-test + +[ 4 ] [ 1 3 test-7 ] unit-test +[ 4 ] [ 1 259 test-8 ] unit-test + +[ ] [ + [ + \ test-7 forget + \ test-8 forget + ] with-compilation-unit +] unit-test diff --git a/basis/compiler/tests/redefine16.factor b/basis/compiler/tests/redefine16.factor index 264b9b0675..3bef30f9f1 100644 --- a/basis/compiler/tests/redefine16.factor +++ b/basis/compiler/tests/redefine16.factor @@ -6,4 +6,6 @@ quotations stack-checker ; [ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test [ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test -[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test \ No newline at end of file +[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test + +[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index bda64569c3..05e6c5a14f 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -25,7 +25,7 @@ IN: compiler.tree.builder [ f initial-recursive-state infer-quot ] bi* ] with-tree-builder unclip-last in-d>> - ] [ "OOPS" USE: io print flush 3drop f f ] recover ; + ] [ 3drop f f ] recover ; : build-sub-tree ( #call quot -- nodes/f ) [ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index daa8f072ca..fe3c7acb92 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -29,7 +29,6 @@ SYMBOL: check-optimizer? normalize propagate cleanup - ?check dup run-escape-analysis? [ escape-analysis unbox-tuples diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index b26ce3bed9..8e9476a7ed 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -166,9 +166,9 @@ SYMBOL: history [ history [ swap suffix ] change ] bi ; -:: inline-word-def ( #call word quot -- ? ) +:: inline-word ( #call word -- ? ) word history get memq? [ f ] [ - #call quot splicing-nodes [ + #call word specialized-def splicing-nodes [ [ word remember-inlining [ ] [ count-nodes ] [ (propagate) ] tri @@ -177,9 +177,6 @@ SYMBOL: history ] [ f ] if* ] if ; -: inline-word ( #call word -- ? ) - dup specialized-def inline-word-def ; - : inline-method-body ( #call word -- ? ) 2dup should-inline? [ inline-word ] [ 2drop f ] if ; @@ -199,10 +196,6 @@ SYMBOL: history call( #call -- word/quot/f ) object swap eliminate-dispatch ; -: inline-instance-check ( #call word -- ? ) - over in-d>> second value-info literal>> dup class? - [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ; - : (do-inlining) ( #call word -- ? ) #! If the generic was defined in an outer compilation unit, #! then it doesn't have a definition yet; the definition @@ -214,7 +207,6 @@ SYMBOL: history #! discouraged, but it should still work.) { { [ dup never-inline-word? ] [ 2drop f ] } - { [ dup \ instance? eq? ] [ inline-instance-check ] } { [ dup always-inline-word? ] [ inline-word ] } { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 1b5d383353..b91a1157f7 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -341,6 +341,11 @@ generic-comparison-ops [ ] [ 2drop object-info ] if ] "outputs" set-word-prop +\ instance? [ + in-d>> second value-info literal>> dup class? + [ "predicate" word-prop '[ drop @ ] ] [ drop f ] if +] "custom-inlining" set-word-prop + \ equal? [ ! If first input has a known type and second input is an ! object, we convert this to [ swap equal? ]. diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 85aa9030f8..37059c19d0 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -216,7 +216,10 @@ M: object infer-call* dispatch exit load-local load-locals get-local drop-locals do-primitive alien-invoke alien-indirect alien-callback -} [ t "special" set-word-prop ] each +} [ + [ t "special" set-word-prop ] + [ t "no-compile" set-word-prop ] bi +] each M\ quotation call t "no-compile" set-word-prop M\ curry call t "no-compile" set-word-prop diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 3800d5056a..4b556396e2 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -5,7 +5,7 @@ generic.standard effects classes.tuple classes.tuple.private arrays vectors strings compiler.units accessors classes.algebra calendar prettyprint io.streams.string splitting summary columns math.order classes.private slots slots.private eval see -words.symbol ; +words.symbol compiler.errors ; IN: classes.tuple.tests TUPLE: rect x y w h ; @@ -34,9 +34,7 @@ C: redefinition-test ! Make sure we handle changing shapes! TUPLE: point x y ; -C: point - -[ ] [ 100 200 "p" set ] unit-test +[ ] [ 100 200 point boa "p" set ] unit-test ! Use eval to sequence parsing explicitly [ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval( -- ) ] unit-test @@ -199,17 +197,6 @@ TUPLE: erg's-reshape-problem a b c d ; C: erg's-reshape-problem -! We want to make sure constructors are recompiled when -! tuples are reshaped -: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ; -: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ; - -[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval( -- ) ] unit-test - -[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test - -[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test - ! Inheritance TUPLE: computer cpu ram ; C: computer @@ -287,7 +274,7 @@ test-server-slot-values ! Dynamically changing inheritance hierarchy TUPLE: electronic-device ; -[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ; C: computer C: laptop C: server" eval( -- ) ] unit-test [ f ] [ electronic-device laptop class<= ] unit-test [ t ] [ server electronic-device class<= ] unit-test @@ -303,17 +290,17 @@ TUPLE: electronic-device ; [ f ] [ "server" get laptop? ] unit-test [ t ] [ "server" get server? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ; C: computer C: laptop C: server" eval( -- ) ] unit-test [ f ] [ "laptop" get electronic-device? ] unit-test [ t ] [ "laptop" get computer? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ; C: computer C: laptop C: server" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; C: computer C: laptop C: server" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -326,7 +313,7 @@ TUPLE: make-me-some-accessors voltage grounded? ; [ ] [ "laptop" get 220 >>voltage drop ] unit-test [ ] [ "server" get 110 >>voltage drop ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ; C: computer" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -334,7 +321,7 @@ test-server-slot-values [ 220 ] [ "laptop" get voltage>> ] unit-test [ 110 ] [ "server" get voltage>> ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ; C: computer C: laptop C: server" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -343,7 +330,7 @@ test-server-slot-values [ 110 ] [ "server" get voltage>> ] unit-test ! Reshaping superclass and subclass simultaneously -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ; C: computer C: laptop C: server" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -354,9 +341,7 @@ test-server-slot-values ! Reshape crash TUPLE: test1 a ; TUPLE: test2 < test1 b ; -C: test2 - -"a" "b" "test" set +"a" "b" test2 boa "test" set : test-a/b ( -- ) [ "a" ] [ "test" get a>> ] unit-test @@ -412,15 +397,17 @@ TUPLE: constructor-update-1 xxx ; TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ; -C: constructor-update-2 +: ( a b c -- tuple ) constructor-update-2 boa ; { 3 1 } [ ] must-infer-as [ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval( -- ) ] unit-test -{ 5 1 } [ ] must-infer-as +{ 3 1 } [ ] must-infer-as -[ { 1 2 3 4 5 } ] [ 1 2 3 4 5 tuple-slots ] unit-test +[ 1 2 3 4 5 ] [ not-compiled? ] must-fail-with + +[ ] [ [ \ forget ] with-compilation-unit ] unit-test ! Redefinition problem TUPLE: redefinition-problem ; @@ -623,7 +610,7 @@ must-fail-with : blah ( -- vec ) vector new ; -\ blah must-infer +[ vector new ] must-infer [ V{ } ] [ blah ] unit-test diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index 57726cc269..0b74f3a236 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -1,4 +1,4 @@ -USING: definitions compiler.units tools.test arrays sequences words kernel +USING: compiler definitions compiler.units tools.test arrays sequences words kernel accessors namespaces fry eval ; IN: compiler.units.tests @@ -14,11 +14,13 @@ IN: compiler.units.tests ! Non-optimizing compiler bugs [ 1 1 ] [ - "A" "B" [ [ 1 ] dip ] 2array 1array modify-code-heap + "A" "B" [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep 1 swap execute ] unit-test [ "A" "B" ] [ + disable-compiler + gensym "a" set gensym "b" set [ @@ -30,6 +32,8 @@ IN: compiler.units.tests "a" get [ "B" ] define ] with-compilation-unit "b" get execute + + enable-compiler ] unit-test ! Notify observers even if compilation unit did nothing From 3d5995b3b4faadd0e71e604f0ef1a01c67abba40 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 16:10:42 -0500 Subject: [PATCH 444/772] Two quick fixes --- basis/compiler/tree/optimizer/optimizer.factor | 1 - basis/compiler/tree/propagation/inlining/inlining.factor | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index daa8f072ca..fe3c7acb92 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -29,7 +29,6 @@ SYMBOL: check-optimizer? normalize propagate cleanup - ?check dup run-escape-analysis? [ escape-analysis unbox-tuples diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 7ae44a5293..df9c7be024 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -170,7 +170,7 @@ SYMBOL: history ] if ; : inline-word ( #call word -- ? ) - dup specialized-def inline-word-def ; + dup def>> inline-word-def ; : inline-method-body ( #call word -- ? ) 2dup should-inline? [ inline-word ] [ 2drop f ] if ; From bd8787d540f624d6a2c4211d7e4d3ae37e871fa0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 16:23:54 -0500 Subject: [PATCH 445/772] Tweak unit test in classes vocab to yield more information on failure --- core/classes/classes-tests.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 08746d1ba7..61d153f064 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -3,7 +3,7 @@ io.streams.string kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate classes.algebra vectors definitions source-files compiler.units -kernel.private sorting vocabs memory eval accessors ; +kernel.private sorting vocabs memory eval accessors sets ; IN: classes.tests [ t ] [ 3 object instance? ] unit-test @@ -22,10 +22,11 @@ M: method-forget-class method-forget-test ; [ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test [ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test -[ t ] [ +[ { } { } ] [ all-words [ class? ] filter implementors-map get keys - [ natural-sort ] bi@ = + [ natural-sort ] bi@ + [ diff ] [ swap diff ] 2bi ] unit-test ! Minor leak From b18081929c70920265194d37528ca37846c6228e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 16:25:04 -0500 Subject: [PATCH 446/772] Remove copyright notice from license --- license.txt | 2 -- 1 file changed, 2 deletions(-) diff --git a/license.txt b/license.txt index 8f4f53585a..e9cd58a5e4 100644 --- a/license.txt +++ b/license.txt @@ -1,5 +1,3 @@ -Copyright (C) 2003, 2009 Slava Pestov and friends. - Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: From 6c38831c4813391b2ff380df925e60bc41a2b286 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 21 Apr 2009 18:29:06 -0400 Subject: [PATCH 447/772] Improve license owner phrasing and in-file copyright notices --- basis/tools/scaffold/scaffold.factor | 11 ++++++----- license.txt | 3 +++ 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index f35da24266..6f7cb25ab9 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -1,5 +1,5 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. +! Copyright (c) 2008 Doug Coleman. All rights reserved. +! This software is licensed under the Simplified BSD License. USING: assocs io.files io.pathnames io.directories io.encodings.utf8 hashtables kernel namespaces sequences vocabs.loader io combinators calendar accessors math.parser @@ -79,9 +79,10 @@ ERROR: no-vocab vocab ; dup exists? [ not-scaffolding f ] [ scaffolding t ] if ; : scaffold-copyright ( -- ) - "! Copyright (C) " write now year>> number>string write - developer-name get [ "Your name" ] unless* bl write "." print - "! See http://factorcode.org/license.txt for BSD license." print ; + "! Copyright (c) " write now year>> number>string write + developer-name get [ "Your name" ] unless* bl write + ". All rights reserved." print + "! This software is licensed under the Simplified BSD License." print ; : main-file-string ( vocab -- string ) [ diff --git a/license.txt b/license.txt index e9cd58a5e4..3310ddc18f 100644 --- a/license.txt +++ b/license.txt @@ -1,3 +1,6 @@ +Copyright (c) 2003-2009, Slava Pestov and contributing authors +All rights reserved. + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: From 24a22e233c80678868015243b316d85b0c844b0c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 22:33:04 -0500 Subject: [PATCH 448/772] Clean up compiler vocab --- basis/compiler/compiler.factor | 75 +++++++++++++++++++++------------- 1 file changed, 46 insertions(+), 29 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 717f66ba88..6094efad87 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -15,6 +15,7 @@ SYMBOL: compile-queue SYMBOL: compiled : queue-compile? ( word -- ? ) + #! Don't attempt to compile certain words. { [ "forgotten" word-prop ] [ compiled get key? ] @@ -25,17 +26,14 @@ SYMBOL: compiled : queue-compile ( word -- ) dup queue-compile? [ compile-queue get push-front ] [ drop ] if ; -: maybe-compile ( word -- ) - dup optimized>> [ drop ] [ queue-compile ] if ; - : recompile-callers? ( word -- ? ) changed-effects get key? ; : recompile-callers ( words -- ) - dup recompile-callers? [ - [ usage [ word? ] filter ] [ compiled-usage keys ] bi - [ [ queue-compile ] each ] bi@ - ] [ drop ] if ; + #! If a word's stack effect changed, recompile all words that + #! have compiled calls to it. + dup recompile-callers? + [ compiled-usage keys [ queue-compile ] each ] [ drop ] if ; : start ( word -- ) "trace-compilation" get [ dup name>> print flush ] when @@ -44,6 +42,8 @@ SYMBOL: compiled f swap compiler-error ; : ignore-error? ( word error -- ? ) + #! Ignore warnings on inline combinators, macros, and special + #! words such as 'call'. [ { [ macro? ] @@ -53,35 +53,61 @@ SYMBOL: compiled } 1|| ] [ error-type +compiler-warning+ eq? ] bi* and ; -: (fail) ( word compiled -- * ) - swap +: finish ( word -- ) + #! Recompile callers if the word's stack effect changed, then + #! save the word's dependencies so that if they change, the + #! word can get recompiled too. [ recompile-callers ] [ compiled-unxref ] - [ compiled get set-at ] - tri return ; + [ + dup crossref? [ + dependencies get + generic-dependencies get + compiled-xref + ] [ drop ] if + ] tri ; + +: deoptimize-with ( word def -- * ) + #! If the word failed to infer, compile it with the + #! non-optimizing compiler. + swap [ finish ] [ compiled get set-at ] bi return ; : not-compiled-def ( word error -- def ) '[ _ _ not-compiled ] [ ] like ; -: fail ( word error -- * ) +: deoptimize ( word error -- * ) + #! If the error is ignorable, compile the word with the + #! non-optimizing compiler, using its definition. Otherwise, + #! if the compiler error is not ignorable, use a dummy + #! definition from 'not-compiled-def' which throws an error. 2dup ignore-error? [ drop f over def>> ] [ 2dup not-compiled-def ] if - [ swap compiler-error ] [ (fail) ] bi-curry* bi ; + [ swap compiler-error ] [ deoptimize-with ] bi-curry* bi ; : frontend ( word -- nodes ) - dup contains-breakpoints? [ dup def>> (fail) ] [ - [ build-tree-from-word ] [ fail ] recover optimize-tree + #! If the word contains breakpoints, don't optimize it, since + #! the walker does not support this. + dup contains-breakpoints? [ dup def>> deoptimize-with ] [ + [ build-tree ] [ deoptimize ] recover optimize-tree ] if ; +: compile-dependency ( word -- ) + #! If a word calls an unoptimized word, try to compile the callee. + dup optimized>> [ drop ] [ queue-compile ] if ; + ! Only switch this off for debugging. SYMBOL: compile-dependencies? t compile-dependencies? set-global +: compile-dependencies ( asm -- ) + compile-dependencies? get + [ calls>> [ compile-dependency ] each ] [ drop ] if ; + : save-asm ( asm -- ) [ [ code>> ] [ label>> ] bi compiled get set-at ] - [ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ] + [ compile-dependencies ] bi ; : backend ( nodes word -- ) @@ -95,18 +121,9 @@ t compile-dependencies? set-global save-asm ] each ; -: finish ( word -- ) - [ recompile-callers ] - [ compiled-unxref ] - [ - dup crossref? [ - dependencies get - generic-dependencies get - compiled-xref - ] [ drop ] if - ] tri ; - -: (compile) ( word -- ) +: compile-word ( word -- ) + #! We return early if the word has breakpoints or if it + #! failed to infer. '[ _ { [ start ] @@ -117,7 +134,7 @@ t compile-dependencies? set-global ] with-return ; : compile-loop ( deque -- ) - [ (compile) yield-hook get call( -- ) ] slurp-deque ; + [ compile-word yield-hook get call( -- ) ] slurp-deque ; : decompile ( word -- ) dup def>> 2array 1array modify-code-heap ; From 057f75e9a14e7f04b778afaa9bc251cb23f9bbd6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 23:02:00 -0500 Subject: [PATCH 449/772] Refactor compiler.tree.builder to fix various regressions --- basis/bootstrap/compiler/compiler.factor | 2 +- basis/compiler/cfg/debugger/debugger.factor | 2 +- basis/compiler/compiler-docs.factor | 8 +- basis/compiler/tests/optimizer.factor | 2 +- basis/compiler/tests/redefine0.factor | 37 +++++++++- .../compiler/tree/builder/builder-docs.factor | 9 +-- .../tree/builder/builder-tests.factor | 8 +- basis/compiler/tree/builder/builder.factor | 74 ++++++++++--------- basis/compiler/tree/checker/checker.factor | 12 +-- basis/compiler/tree/debugger/debugger.factor | 3 +- .../compiler/tree/optimizer/optimizer.factor | 1 + .../tree/propagation/inlining/inlining.factor | 14 ++-- basis/stack-checker/backend/backend.factor | 16 ++-- .../known-words/known-words.factor | 4 + .../stack-checker/stack-checker-tests.factor | 2 +- basis/stack-checker/state/state.factor | 1 + 16 files changed, 121 insertions(+), 74 deletions(-) diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 617073bbc4..89a0ed86fe 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -108,7 +108,7 @@ nl "." write flush -{ (compile) } compile-unoptimized +{ compile-word } compile-unoptimized "." write flush diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index 6d0a8f8c8e..6b0aba6813 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -16,7 +16,7 @@ M: callable test-cfg build-tree optimize-tree gensym build-cfg ; M: word test-cfg - [ build-tree-from-word optimize-tree ] keep build-cfg ; + [ build-tree optimize-tree ] keep build-cfg ; SYMBOL: allocate-registers? diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index f92f0015d3..cdd410457c 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -27,12 +27,12 @@ $nl { $subsection compile-queue } "Once compiled, a word is added to the assoc stored in the " { $link compiled } " variable. When compilation is complete, this assoc is passed to " { $link modify-code-heap } "." $nl -"The " { $link (compile) } " word performs the actual task of compiling an individual word. The process proceeds as follows:" +"The " { $link compile-word } " word performs the actual task of compiling an individual word. The process proceeds as follows:" { $list - { "The " { $link frontend } " word calls " { $link build-tree-from-word } ". If this fails, the error is passed to " { $link fail } ". The logic for ignoring compile warnings generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." } + { "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". The logic for ignoring compile warnings generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." } { "If the word contains a breakpoint, compilation ends here. Otherwise, all remaining steps execute until machine code is generated. Any further errors thrown by the compiler are not reported as compile errors, but instead are ordinary exceptions. This is because they indicate bugs in the compiler, not errors in user code." } { "The " { $link frontend } " word then calls " { $link optimize-tree } ". This produces the final optimized tree IR, and this stage of the compiler is complete." } - { "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link maybe-compile } "." } + { "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link compile-dependency } "." } } "If compilation fails, the word is stored in the " { $link compiled } " assoc with a value of " { $link f } ". This causes the VM to compile the word with the non-optimizing compiler." $nl @@ -60,7 +60,7 @@ HELP: decompile { $values { "word" word } } { $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ; -HELP: (compile) +HELP: compile-word { $values { "word" word } } { $description "Compile a single word." } { $notes "This is an internal word, and user code should call " { $link compile } " instead." } ; diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 23b69b06b9..99bdb18812 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -303,7 +303,7 @@ HINTS: recursive-inline-hang-3 array ; : member-test ( obj -- ? ) { + - * / /i } member? ; \ member-test def>> must-infer -[ ] [ \ member-test build-tree-from-word optimize-tree drop ] unit-test +[ ] [ \ member-test build-tree optimize-tree drop ] unit-test [ t ] [ \ + member-test ] unit-test [ f ] [ \ append member-test ] unit-test diff --git a/basis/compiler/tests/redefine0.factor b/basis/compiler/tests/redefine0.factor index cdef7103ce..87b63aa029 100644 --- a/basis/compiler/tests/redefine0.factor +++ b/basis/compiler/tests/redefine0.factor @@ -1,5 +1,6 @@ IN: compiler.tests.redefine0 -USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math ; +USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math +namespaces macros assocs ; ! Test ripple-up behavior : test-1 ( -- a ) 3 ; @@ -61,7 +62,7 @@ M: integer test-7 + ; [ 1 test-7 ] [ not-compiled? ] must-fail-with [ 1 test-8 ] [ not-compiled? ] must-fail-with -[ ] [ "IN: compiler.tests.redefine0 USING: macros kernel ; GENERIC: test-7 ( x y -- z )" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine0 USING: macros math kernel ; GENERIC: test-7 ( x y -- z ) : test-8 ( a b -- c ) 255 bitand test-7 ;" eval( -- ) ] unit-test [ 4 ] [ 1 3 test-7 ] unit-test [ 4 ] [ 1 259 test-8 ] unit-test @@ -72,3 +73,35 @@ M: integer test-7 + ; \ test-8 forget ] with-compilation-unit ] unit-test + +! Indirect dependency on an unoptimized word +: test-9 ( -- ) ; +<< SYMBOL: quot +[ test-9 ] quot set-global >> +MACRO: test-10 ( -- quot ) quot get ; +: test-11 ( -- ) test-10 ; + +[ ] [ test-11 ] unit-test + +[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) 1 ;" eval( -- ) ] unit-test + +! test-11 should get recompiled now + +[ test-11 ] [ not-compiled? ] must-fail-with + +[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- a ) 1 ;" eval( -- ) ] unit-test + +[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) ;" eval( -- ) ] unit-test + +[ ] [ test-11 ] unit-test + +quot global delete-at + +[ ] [ + [ + \ test-9 forget + \ test-10 forget + \ test-11 forget + \ quot forget + ] with-compilation-unit +] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/builder/builder-docs.factor b/basis/compiler/tree/builder/builder-docs.factor index 8cf3796f0a..3fa576faf5 100644 --- a/basis/compiler/tree/builder/builder-docs.factor +++ b/basis/compiler/tree/builder/builder-docs.factor @@ -3,12 +3,11 @@ compiler.tree stack-checker.errors ; IN: compiler.tree.builder HELP: build-tree -{ $values { "quot" quotation } { "nodes" "a sequence of nodes" } } +{ $values { "quot/word" { $or quotation word } } { "nodes" "a sequence of nodes" } } { $description "Attempts to construct tree SSA IR from a quotation." } { $notes "This is the first stage of the compiler." } { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; -HELP: build-tree-with -{ $values { "in-stack" "a sequence of values" } { "quot" quotation } { "nodes" "a sequence of nodes" } { "out-stack" "a sequence of values" } } -{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values, and outputting stack resulting at the end." } -{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; +HELP: build-sub-tree +{ $values { "#call" #call } { "quot/word" { $or quotation word } } { "nodes" { $maybe "a sequence of nodes" } } } +{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values from the call site. Outputs " { $link f } " if stack effect inference fails." } ; diff --git a/basis/compiler/tree/builder/builder-tests.factor b/basis/compiler/tree/builder/builder-tests.factor index 9668272957..f3a2b99db6 100755 --- a/basis/compiler/tree/builder/builder-tests.factor +++ b/basis/compiler/tree/builder/builder-tests.factor @@ -4,24 +4,24 @@ compiler.tree stack-checker stack-checker.errors ; : inline-recursive ( -- ) inline-recursive ; inline recursive -[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? ] unit-test +[ t ] [ \ inline-recursive build-tree [ #recursive? ] any? ] unit-test : bad-recursion-1 ( a -- b ) dup [ drop bad-recursion-1 5 ] [ ] if ; -[ \ bad-recursion-1 build-tree-from-word ] [ inference-error? ] must-fail-with +[ \ bad-recursion-1 build-tree ] [ inference-error? ] must-fail-with FORGET: bad-recursion-1 : bad-recursion-2 ( obj -- obj ) dup [ dup first swap second bad-recursion-2 ] [ ] if ; -[ \ bad-recursion-2 build-tree-from-word ] [ inference-error? ] must-fail-with +[ \ bad-recursion-2 build-tree ] [ inference-error? ] must-fail-with FORGET: bad-recursion-2 : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; -[ \ bad-bin build-tree-from-word ] [ inference-error? ] must-fail-with +[ \ bad-bin build-tree ] [ inference-error? ] must-fail-with FORGET: bad-bin diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 05e6c5a14f..7a9877a406 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry accessors quotations kernel sequences namespaces +USING: fry locals accessors quotations kernel sequences namespaces assocs words arrays vectors hints combinators continuations effects compiler.tree stack-checker @@ -11,53 +11,55 @@ stack-checker.backend stack-checker.recursive-state ; IN: compiler.tree.builder -: with-tree-builder ( quot -- nodes ) - '[ V{ } clone stack-visitor set @ ] - with-infer nip ; inline +vector \ meta-d set ] - [ f initial-recursive-state infer-quot ] bi* - ] with-tree-builder - unclip-last in-d>> - ] [ 3drop f f ] recover ; - -: build-sub-tree ( #call quot -- nodes/f ) - [ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with - { - { [ over not ] [ 3drop f ] } - { [ over ends-with-terminate? ] [ drop swap [ f swap #push ] map append ] } - [ rot #copy suffix ] - } cond ; +M: callable (build-tree) f initial-recursive-state infer-quot ; : check-no-compile ( word -- ) dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ; -: (build-tree-from-word) ( word -- ) - dup initial-recursive-state recursive-state set - dup [ "inline" word-prop ] [ "recursive" word-prop ] bi and - [ 1quotation ] [ specialized-def ] if - infer-quot-here ; - : check-effect ( word effect -- ) swap required-stack-effect 2dup effect<= [ 2drop ] [ effect-error ] if ; -: finish-word ( word -- ) - current-effect check-effect ; +: inline-recursive? ( word -- ? ) + [ "inline" word-prop ] [ "recursive" word-prop ] bi and ; -: build-tree-from-word ( word -- nodes ) - [ +: word-body ( word -- quot ) + dup inline-recursive? [ 1quotation ] [ specialized-def ] if ; + +M: word (build-tree) + { + [ initial-recursive-state recursive-state set ] [ check-no-compile ] - [ (build-tree-from-word) ] - [ finish-word ] - tri - ] with-tree-builder ; + [ word-body infer-quot-here ] + [ current-effect check-effect ] + } cleave ; + +: build-tree-with ( in-stack word/quot -- nodes ) + [ + V{ } clone stack-visitor set + [ [ >vector \ meta-d set ] [ length d-in set ] bi ] + [ (build-tree) ] + bi* + ] with-infer nip ; + +PRIVATE> + +: build-tree ( word/quot -- nodes ) + [ f ] dip build-tree-with ; + +:: build-sub-tree ( #call word/quot -- nodes/f ) + [ + #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d + { + { [ dup not ] [ ] } + { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] } + [ in-d #call out-d>> #copy suffix ] + } cond + ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ; : contains-breakpoints? ( word -- ? ) def>> [ word? ] filter [ "break?" word-prop ] any? ; diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index e25f152aef..718def367d 100755 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -144,13 +144,15 @@ M: #terminate check-stack-flow* SYMBOL: branch-out -: check-branch ( nodes -- stack ) +: check-branch ( nodes -- datastack ) [ datastack [ clone ] change - V{ } clone retainstack set - (check-stack-flow) - terminated? get [ assert-retainstack-empty ] unless - terminated? get f datastack get ? + retainstack [ clone ] change + retainstack get clone [ (check-stack-flow) ] dip + terminated? get [ drop f ] [ + retainstack get assert= + datastack get + ] if ] with-scope ; M: #branch check-stack-flow* diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 8e102e0ea3..b1dc04082e 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -142,8 +142,7 @@ SYMBOL: node-count : make-report ( word/quot -- assoc ) [ - dup word? [ build-tree-from-word ] [ build-tree ] if - optimize-tree + build-tree optimize-tree H{ } clone words-called set H{ } clone generics-called set diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index fe3c7acb92..daa8f072ca 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -29,6 +29,7 @@ SYMBOL: check-optimizer? normalize propagate cleanup + ?check dup run-escape-analysis? [ escape-analysis unbox-tuples diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 8e9476a7ed..aa66b2f6d7 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -28,12 +28,10 @@ SYMBOL: node-count SYMBOL: inlining-count ! Splicing nodes -GENERIC: splicing-nodes ( #call word/quot/f -- nodes/f ) - -M: word splicing-nodes +: splicing-call ( #call word -- nodes ) [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; -M: callable splicing-nodes +: splicing-body ( #call quot/word -- nodes/f ) build-sub-tree dup [ analyze-recursive normalize ] when ; ! Dispatch elimination @@ -43,6 +41,12 @@ M: callable splicing-nodes : propagate-body ( #call -- ? ) body>> (propagate) t ; +GENERIC: splicing-nodes ( #call word/quot -- nodes/f ) + +M: word splicing-nodes splicing-call ; + +M: callable splicing-nodes splicing-body ; + : eliminate-dispatch ( #call class/f word/quot/f -- ? ) dup [ [ >>class ] dip @@ -168,7 +172,7 @@ SYMBOL: history :: inline-word ( #call word -- ? ) word history get memq? [ f ] [ - #call word specialized-def splicing-nodes [ + #call word splicing-body [ [ word remember-inlining [ ] [ count-nodes ] [ (propagate) ] tri diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index ed9c01b06c..182de28cd9 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -84,11 +84,8 @@ M: object apply-object push-literal ; meta-r empty? [ too-many->r ] unless ; : infer-quot-here ( quot -- ) - meta-r [ - V{ } clone \ meta-r set - [ apply-object terminated? get not ] all? - [ commit-literals check->r ] [ literals get delete-all ] if - ] dip \ meta-r set ; + [ apply-object terminated? get not ] all? + [ commit-literals ] [ literals get delete-all ] if ; : infer-quot ( quot rstate -- ) recursive-state get [ @@ -116,10 +113,14 @@ M: object apply-object push-literal ; ] if ; : infer->r ( n -- ) - consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ; + terminated? get [ drop ] [ + consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi + ] if ; : infer-r> ( n -- ) - consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ; + terminated? get [ drop ] [ + consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi + ] if ; : (consume/produce) ( effect -- inputs outputs ) [ in>> length consume-d ] [ out>> length produce-d ] bi ; @@ -130,6 +131,7 @@ M: object apply-object push-literal ; bi ; inline : end-infer ( -- ) + terminated? get [ check->r ] unless meta-d clone #return, ; : required-stack-effect ( word -- effect ) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 37059c19d0..80721d0b0e 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -221,6 +221,10 @@ M: object infer-call* [ t "no-compile" set-word-prop ] bi ] each +! Exceptions to the above +\ curry f "no-compile" set-word-prop +\ compose f "no-compile" set-word-prop + M\ quotation call t "no-compile" set-word-prop M\ curry call t "no-compile" set-word-prop M\ compose call t "no-compile" set-word-prop diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 814f528cdb..9f5d0a2213 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -299,7 +299,7 @@ ERROR: custom-error ; [ custom-error inference-error ] infer ] unit-test -[ T{ effect f 1 2 t } ] [ +[ T{ effect f 1 1 t } ] [ [ dup [ 3 throw ] dip ] infer ] unit-test diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index a76d302a7e..9b87854b69 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -42,6 +42,7 @@ SYMBOL: literals : init-inference ( -- ) terminated? off V{ } clone \ meta-d set + V{ } clone \ meta-r set V{ } clone literals set 0 d-in set ; From 8e1499ab79ec148c10e3c9e062a521d020fb8f99 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 23:02:11 -0500 Subject: [PATCH 450/772] Load tools.errors in stage2 so that bootstrap errors print correctly --- basis/bootstrap/stage2.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index d6c1876d6a..4eb2a1db91 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -78,6 +78,8 @@ SYMBOL: bootstrap-time "stage2: deployment mode" print ] [ "listener" require + "debugger" require + "tools.errors" require "none" require ] if From 399de5137d74a365e5594a064fab0a1217bc1efb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 23:02:20 -0500 Subject: [PATCH 451/772] help.markup: { $maybe "foo" } now works --- basis/help/markup/markup.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index f22560a4ce..04b6d90883 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -251,7 +251,7 @@ M: word ($instance) dup name>> a/an write bl ($link) ; M: string ($instance) - dup a/an write bl $snippet ; + write ; M: f ($instance) drop { f } $link ; From 28b9e474dd0e4328af6831588cf74f57722e9418 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 23:18:19 -0500 Subject: [PATCH 452/772] Set more no-compile word props --- basis/stack-checker/known-words/known-words.factor | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 80721d0b0e..eade33e52b 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -225,10 +225,16 @@ M: object infer-call* \ curry f "no-compile" set-word-prop \ compose f "no-compile" set-word-prop -M\ quotation call t "no-compile" set-word-prop -M\ curry call t "no-compile" set-word-prop -M\ compose call t "no-compile" set-word-prop -M\ word execute t "no-compile" set-word-prop +! More words not to compile +\ call t "no-compile" set-word-prop +\ call subwords [ t "no-compile" set-word-prop ] each + +\ execute t "no-compile" set-word-prop +\ execute subwords [ t "no-compile" set-word-prop ] each + +\ effective-method t "no-compile" set-word-prop +\ effective-method subwords [ t "no-compile" set-word-prop ] each + \ clear t "no-compile" set-word-prop : non-inline-word ( word -- ) From 487b92074c13b1918a5c24f3bbd572f8fc57afb4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 23:19:13 -0500 Subject: [PATCH 453/772] Remove method-declaration stuff from generic.standard since hints accomplishes the same thing --- core/generic/standard/standard.factor | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 5dbc0d17a1..148e16bd33 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -13,13 +13,7 @@ GENERIC: dispatch# ( word -- n ) M: generic dispatch# "combination" word-prop dispatch# ; -GENERIC: method-declaration ( class generic -- quot ) - -M: generic method-declaration - "combination" word-prop method-declaration ; - -M: quotation engine>quot - assumed get generic get method-declaration prepend ; +M: quotation engine>quot ; ERROR: no-method object generic ; @@ -122,9 +116,6 @@ M: standard-combination perform-combination M: standard-combination dispatch# #>> ; -M: standard-combination method-declaration - dispatch# object swap prefix [ declare ] curry [ ] like ; - M: standard-combination next-method-quot* [ single-next-method-quot @@ -151,8 +142,6 @@ PREDICATE: hook-generic < generic M: hook-combination dispatch# drop 0 ; -M: hook-combination method-declaration 2drop [ ] ; - M: hook-generic extra-values drop 1 ; M: hook-generic effective-method From 5d64766e4c89e0518e1ab1d515e5b196d0e1dc9b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Apr 2009 23:19:46 -0500 Subject: [PATCH 454/772] X11.windows: fix bug with radeonhd driver (reported by Chris Double) --- basis/x11/windows/windows.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index 87a212bd8e..37da51e9b8 100644 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -6,7 +6,7 @@ arrays fry ; IN: x11.windows : create-window-mask ( -- n ) - { CWColormap CWEventMask } flags ; + { CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ; : create-colormap ( visinfo -- colormap ) [ dpy get root get ] dip XVisualInfo-visual AllocNone From 25cc5a409ae3fc6d8f26cf3e21b28923834fcf6a Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 22 Apr 2009 00:20:53 -0400 Subject: [PATCH 455/772] Revert "Improve license owner phrasing and in-file copyright notices" This reverts commit 6c38831c4813391b2ff380df925e60bc41a2b286. --- basis/tools/scaffold/scaffold.factor | 11 +++++------ license.txt | 3 --- 2 files changed, 5 insertions(+), 9 deletions(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 6f7cb25ab9..f35da24266 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -1,5 +1,5 @@ -! Copyright (c) 2008 Doug Coleman. All rights reserved. -! This software is licensed under the Simplified BSD License. +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: assocs io.files io.pathnames io.directories io.encodings.utf8 hashtables kernel namespaces sequences vocabs.loader io combinators calendar accessors math.parser @@ -79,10 +79,9 @@ ERROR: no-vocab vocab ; dup exists? [ not-scaffolding f ] [ scaffolding t ] if ; : scaffold-copyright ( -- ) - "! Copyright (c) " write now year>> number>string write - developer-name get [ "Your name" ] unless* bl write - ". All rights reserved." print - "! This software is licensed under the Simplified BSD License." print ; + "! Copyright (C) " write now year>> number>string write + developer-name get [ "Your name" ] unless* bl write "." print + "! See http://factorcode.org/license.txt for BSD license." print ; : main-file-string ( vocab -- string ) [ diff --git a/license.txt b/license.txt index 3310ddc18f..e9cd58a5e4 100644 --- a/license.txt +++ b/license.txt @@ -1,6 +1,3 @@ -Copyright (c) 2003-2009, Slava Pestov and contributing authors -All rights reserved. - Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: From a3c0dd44a167eac164bd28dc7c9b71b3ad9ef92d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 00:15:48 -0500 Subject: [PATCH 456/772] Revert "Remove method-declaration stuff from generic.standard since hints accomplishes the same thing" This reverts commit 487b92074c13b1918a5c24f3bbd572f8fc57afb4. --- core/generic/standard/standard.factor | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 148e16bd33..5dbc0d17a1 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -13,7 +13,13 @@ GENERIC: dispatch# ( word -- n ) M: generic dispatch# "combination" word-prop dispatch# ; -M: quotation engine>quot ; +GENERIC: method-declaration ( class generic -- quot ) + +M: generic method-declaration + "combination" word-prop method-declaration ; + +M: quotation engine>quot + assumed get generic get method-declaration prepend ; ERROR: no-method object generic ; @@ -116,6 +122,9 @@ M: standard-combination perform-combination M: standard-combination dispatch# #>> ; +M: standard-combination method-declaration + dispatch# object swap prefix [ declare ] curry [ ] like ; + M: standard-combination next-method-quot* [ single-next-method-quot @@ -142,6 +151,8 @@ PREDICATE: hook-generic < generic M: hook-combination dispatch# drop 0 ; +M: hook-combination method-declaration 2drop [ ] ; + M: hook-generic extra-values drop 1 ; M: hook-generic effective-method From dea3987ca52699b64b0a08bd7b4e719b5f7b5356 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 00:44:06 -0500 Subject: [PATCH 457/772] Silly workaround for performance regression --- basis/compiler/tree/builder/builder.factor | 5 +++++ basis/hints/hints.factor | 21 +++++++++++++-------- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 7a9877a406..3f00a3bb68 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -52,6 +52,11 @@ PRIVATE> [ f ] dip build-tree-with ; :: build-sub-tree ( #call word/quot -- nodes/f ) + #! We don't want methods on mixins to have a declaration for that mixin. + #! This slows down compiler.tree.propagation.inlining since then every + #! inlined usage of a method has an inline-dependency on the mixin, and + #! not the more specific type at the call site. + specialize-method? off [ #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d { diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index ed55c1c332..d445bf72ad 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: parser words definitions kernel sequences assocs arrays kernel.private fry combinators accessors vectors strings sbufs -byte-arrays byte-vectors io.binary io.streams.string splitting -math math.parser generic generic.standard generic.standard.engines classes -hashtables ; +byte-arrays byte-vectors io.binary io.streams.string splitting math +math.parser generic generic.standard generic.standard.engines classes +hashtables namespaces ; IN: hints GENERIC: specializer-predicate ( spec -- quot ) @@ -37,13 +37,18 @@ M: object specializer-declaration class ; : specialize-quot ( quot specializer -- quot' ) specializer-cases alist>quot ; -: method-declaration ( method -- quot ) - [ "method-generic" word-prop dispatch# object ] - [ "method-class" word-prop ] - bi prefix ; +! compiler.tree.propagation.inlining sets this to f +SYMBOL: specialize-method? + +t specialize-method? set-global : specialize-method ( quot method -- quot' ) - [ method-declaration '[ _ declare ] prepend ] + [ + specialize-method? get [ + [ "method-class" word-prop ] [ "method-generic" word-prop ] bi + method-declaration prepend + ] [ drop ] if + ] [ "method-generic" word-prop "specializer" word-prop ] bi [ specialize-quot ] when* ; From 48e70b65fae81c633f8da9abeac3d8f478d7beb3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 04:20:38 -0500 Subject: [PATCH 458/772] Move cross-referencing stuff to tools.crossref since compiler doesn't depend on it anymore, and compute cross-referencing index as needed; reduces image size by ~4Mb --- basis/bootstrap/stage2.factor | 9 -- basis/help/crossref/crossref-docs.factor | 5 - basis/help/crossref/crossref.factor | 10 +- basis/help/help.factor | 6 +- .../tools/continuations/continuations.factor | 2 +- basis/tools/crossref/crossref-docs.factor | 46 +++++++- basis/tools/crossref/crossref-tests.factor | 37 ++++++ basis/tools/crossref/crossref.factor | 110 +++++++++++++++++- basis/tools/profiler/profiler-docs.factor | 4 +- basis/tools/profiler/profiler.factor | 2 +- basis/tools/vocabs/vocabs.factor | 21 ---- basis/ui/tools/browser/popups/popups.factor | 2 +- core/bootstrap/primitives.factor | 2 - core/classes/tuple/tuple-tests.factor | 2 - core/compiler/units/units-tests.factor | 4 +- core/compiler/units/units.factor | 2 +- core/definitions/definitions-docs.factor | 44 ------- core/definitions/definitions.factor | 28 +---- core/generic/generic-tests.factor | 60 +--------- core/generic/generic.factor | 8 -- .../standard/engines/tuple/tuple.factor | 2 - core/generic/standard/standard-tests.factor | 21 ---- core/parser/parser.factor | 2 +- core/source-files/source-files-docs.factor | 23 +--- core/source-files/source-files.factor | 34 ++---- core/words/words-docs.factor | 4 - core/words/words-tests.factor | 71 ----------- core/words/words.factor | 39 +------ 28 files changed, 219 insertions(+), 381 deletions(-) diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 4eb2a1db91..4d566a288d 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -16,13 +16,6 @@ SYMBOL: bootstrap-time vm file-name os windows? [ "." split1-last drop ] when ".image" append resource-path ; -: do-crossref ( -- ) - "Cross-referencing..." print flush - H{ } clone crossref set-global - xref-words - xref-generics - xref-sources ; - : load-components ( -- ) "include" "exclude" [ get-global " " split harvest ] bi@ @@ -68,8 +61,6 @@ SYMBOL: bootstrap-time (command-line) parse-command-line - do-crossref - ! Set dll paths os wince? [ "windows.ce" require ] when os winnt? [ "windows.nt" require ] when diff --git a/basis/help/crossref/crossref-docs.factor b/basis/help/crossref/crossref-docs.factor index ae227fde89..7f243ec764 100644 --- a/basis/help/crossref/crossref-docs.factor +++ b/basis/help/crossref/crossref-docs.factor @@ -17,8 +17,3 @@ HELP: xref-article { $values { "topic" "an article name or a word" } } { $description "Sets the " { $link article-parent } " of each child of this article." } $low-level-note ; - -HELP: unxref-article -{ $values { "topic" "an article name or a word" } } -{ $description "Clears the " { $link article-parent } " of each child of this article." } -$low-level-note ; diff --git a/basis/help/crossref/crossref.factor b/basis/help/crossref/crossref.factor index b791a4b124..46f9561605 100644 --- a/basis/help/crossref/crossref.factor +++ b/basis/help/crossref/crossref.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic assocs math fry io kernel namespaces prettyprint prettyprint.sections @@ -12,9 +12,6 @@ IN: help.crossref : article-children ( topic -- seq ) { $subsection } article-links ; -M: link uses - { $subsection $link $see-also } article-links ; - : help-path ( topic -- seq ) [ article-parent ] follow rest ; @@ -22,10 +19,7 @@ M: link uses article-children [ set-article-parent ] with each ; : xref-article ( topic -- ) - dup >link xref dup set-article-parents ; - -: unxref-article ( topic -- ) - >link unxref ; + dup set-article-parents ; : prev/next ( obj seq n -- obj' ) [ [ index dup ] keep ] dip swap diff --git a/basis/help/help.factor b/basis/help/help.factor index d20e06b6c6..956bc220e1 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -156,10 +156,7 @@ help-hook [ [ print-topic ] ] initialize error get (:help) ; : remove-article ( name -- ) - dup articles get key? [ - dup unxref-article - dup articles get delete-at - ] when drop ; + articles get delete-at ; : add-article ( article name -- ) [ remove-article ] keep @@ -167,7 +164,6 @@ help-hook [ [ print-topic ] ] initialize xref-article ; : remove-word-help ( word -- ) - dup word-help [ dup unxref-article ] when f "help" set-word-prop ; : set-word-help ( content word -- ) diff --git a/basis/tools/continuations/continuations.factor b/basis/tools/continuations/continuations.factor index 3e28c5925f..1ac4557ec4 100644 --- a/basis/tools/continuations/continuations.factor +++ b/basis/tools/continuations/continuations.factor @@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words sequences.private assocs models models.arrow arrays accessors -generic generic.standard definitions make sbufs ; +generic generic.standard definitions make sbufs tools.crossref ; IN: tools.continuations > "integer=>generic-forget-test-1" = ] any? +] unit-test + +[ ] [ + [ \ generic-forget-test-1 forget ] with-compilation-unit +] unit-test + +[ f ] [ + \ / usage [ word? ] filter + [ name>> "integer=>generic-forget-test-1" = ] any? +] unit-test + +GENERIC: generic-forget-test-2 ( a b -- c ) + +M: sequence generic-forget-test-2 = ; + +[ t ] [ + \ = usage [ word? ] filter + [ name>> "sequence=>generic-forget-test-2" = ] any? +] unit-test + +[ ] [ + [ M\ sequence generic-forget-test-2 forget ] with-compilation-unit +] unit-test + +[ f ] [ + \ = usage [ word? ] filter + [ name>> "sequence=>generic-forget-test-2" = ] any? +] unit-test \ No newline at end of file diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index 36ccaadc98..feaddc8194 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -1,9 +1,84 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs definitions io io.styles kernel prettyprint -sorting see ; +USING: words assocs definitions io io.pathnames io.styles kernel +prettyprint sorting see sets sequences arrays hashtables help.crossref +help.topics help.markup quotations accessors source-files namespaces +graphs vocabs generic generic.standard.engines.tuple threads +compiler.units init ; IN: tools.crossref +SYMBOL: crossref + +GENERIC: uses ( defspec -- seq ) + +alist ] dip seq-uses ; + +M: callable quot-uses seq-uses ; + +M: wrapper quot-uses [ wrapped>> ] dip quot-uses ; + +M: callable uses ( quot -- assoc ) + H{ } clone [ quot-uses ] keep keys ; + +M: word uses def>> uses ; + +M: link uses { $subsection $link $see-also } article-links ; + +M: pathname uses string>> source-file top-level-form>> uses ; + +GENERIC: crossref-def ( defspec -- ) + +M: object crossref-def + dup uses crossref get add-vertex ; + +M: word crossref-def + [ call-next-method ] [ subwords [ crossref-def ] each ] bi ; + +: build-crossref ( -- crossref ) + "Computing usage index... " write flush yield + H{ } clone crossref [ + all-words + source-files get keys [ ] map + [ [ crossref-def ] each ] bi@ + crossref get + ] with-variable + "done" print flush ; + +: get-crossref ( -- crossref ) + crossref global [ drop build-crossref ] cache ; + +GENERIC: irrelevant? ( defspec -- ? ) + +M: object irrelevant? drop f ; + +M: default-method irrelevant? drop t ; + +M: engine-word irrelevant? drop t ; + +PRIVATE> + +: usage ( defspec -- seq ) get-crossref at keys ; + +GENERIC: smart-usage ( defspec -- seq ) + +M: object smart-usage usage [ irrelevant? not ] filter ; + +M: method-body smart-usage "method-generic" word-prop smart-usage ; + +M: f smart-usage drop \ f smart-usage ; + : synopsis-alist ( definitions -- alist ) [ [ synopsis ] keep ] { } map>assoc ; @@ -15,3 +90,34 @@ IN: tools.crossref : usage. ( word -- ) smart-usage sorted-definitions. ; + +: vocab-xref ( vocab quot -- vocabs ) + [ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map + [ + [ [ word? ] [ generic? not ] bi and ] filter [ + dup method-body? + [ "method-generic" word-prop ] when + vocabulary>> + ] map + ] gather natural-sort remove sift ; inline + +: vocabs. ( seq -- ) + [ dup >vocab-link write-object nl ] each ; + +: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; + +: vocab-uses. ( vocab -- ) vocab-uses vocabs. ; + +: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ; + +: vocab-usage. ( vocab -- ) vocab-usage vocabs. ; + + \ No newline at end of file diff --git a/basis/tools/profiler/profiler-docs.factor b/basis/tools/profiler/profiler-docs.factor index baecbd71c1..efd2e164a3 100644 --- a/basis/tools/profiler/profiler-docs.factor +++ b/basis/tools/profiler/profiler-docs.factor @@ -1,5 +1,5 @@ -USING: tools.profiler.private tools.time help.markup help.syntax -quotations io strings words definitions ; +USING: tools.profiler.private tools.time tools.crossref +help.markup help.syntax quotations io strings words definitions ; IN: tools.profiler ARTICLE: "profiler-limitations" "Profiler limitations" diff --git a/basis/tools/profiler/profiler.factor b/basis/tools/profiler/profiler.factor index f4488136b2..219344db3b 100644 --- a/basis/tools/profiler/profiler.factor +++ b/basis/tools/profiler/profiler.factor @@ -3,7 +3,7 @@ USING: accessors words sequences math prettyprint kernel arrays io io.styles namespaces assocs kernel.private strings combinators sorting math.parser vocabs definitions tools.profiler.private -continuations generic compiler.units sets classes fry ; +tools.crossref continuations generic compiler.units sets classes fry ; IN: tools.profiler : profile ( quot -- ) diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index 66618ee23c..ba99a41eba 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -8,27 +8,6 @@ continuations compiler.errors init checksums checksums.crc32 sets accessors generic definitions words ; IN: tools.vocabs -: vocab-xref ( vocab quot -- vocabs ) - [ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map - [ - [ [ word? ] [ generic? not ] bi and ] filter [ - dup method-body? - [ "method-generic" word-prop ] when - vocabulary>> - ] map - ] gather natural-sort remove sift ; inline - -: vocabs. ( seq -- ) - [ dup >vocab-link write-object nl ] each ; - -: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; - -: vocab-uses. ( vocab -- ) vocab-uses vocabs. ; - -: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ; - -: vocab-usage. ( vocab -- ) vocab-usage vocabs. ; - : vocab-tests-file ( vocab -- path ) dup "-tests.factor" vocab-dir+ vocab-append-path dup [ dup exists? [ drop f ] unless ] [ drop f ] if ; diff --git a/basis/ui/tools/browser/popups/popups.factor b/basis/ui/tools/browser/popups/popups.factor index 91ac96e0f9..2cd90ab335 100644 --- a/basis/ui/tools/browser/popups/popups.factor +++ b/basis/ui/tools/browser/popups/popups.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs definitions fry help.topics kernel colors.constants math.rectangles models.arrow namespaces sequences -sorting definitions.icons ui.gadgets ui.gadgets.glass +sorting definitions.icons tools.crossref ui.gadgets ui.gadgets.glass ui.gadgets.labeled ui.gadgets.scrollers ui.gadgets.tables ui.gadgets.search-tables ui.gadgets.wrappers ui.gestures ui.operations ui.pens.solid ui.images ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 4466bd9bfe..1258da8a4d 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -12,8 +12,6 @@ IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush -crossref off - H{ } clone sub-primitives set "vocab:bootstrap/syntax.factor" parse-file diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 4b556396e2..c180807b0c 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -110,8 +110,6 @@ TUPLE: yo-momma ; [ ] [ \ yo-momma forget ] unit-test [ ] [ \ forget ] unit-test [ f ] [ \ yo-momma update-map get values memq? ] unit-test - - [ f ] [ \ yo-momma crossref get at ] unit-test ] with-compilation-unit TUPLE: loc-recording ; diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index 0b74f3a236..da2dce128f 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -36,7 +36,7 @@ IN: compiler.units.tests enable-compiler ] unit-test -! Notify observers even if compilation unit did nothing +! Check that we notify observers SINGLETON: observer observer add-definition-observer @@ -47,7 +47,7 @@ SYMBOL: counter M: observer definitions-changed 2drop global [ counter inc ] bind ; -[ ] with-compilation-unit +[ gensym [ ] (( -- )) define-declared ] with-compilation-unit [ 1 ] [ counter get-global ] unit-test diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 02a80c4d84..c84e8fa73e 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -144,7 +144,7 @@ GENERIC: definitions-changed ( assoc obj -- ) update-tuples process-forgotten-definitions modify-code-heap - updated-definitions notify-definition-observers + updated-definitions dup assoc-empty? [ drop ] [ notify-definition-observers ] if notify-error-observers ; : with-nested-compilation-unit ( quot -- ) diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index 9d49cf62c6..b1575cc1e4 100644 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -10,21 +10,11 @@ $nl { $subsection set-where } "Definitions can be removed:" { $subsection forget } -"Definitions can answer a sequence of definitions they directly depend on:" -{ $subsection uses } "Definitions must implement a few operations used for printing them in source form:" { $subsection definer } { $subsection definition } { $see-also "see" } ; -ARTICLE: "definition-crossref" "Definition cross referencing" -"A common cross-referencing system is used to track definition usages:" -{ $subsection crossref } -{ $subsection xref } -{ $subsection unxref } -{ $subsection delete-xref } -{ $subsection usage } ; - ARTICLE: "definition-checking" "Definition sanity checking" "When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } ". A warning message is printed if any other definitions still depend on the removed definitions." $nl @@ -69,7 +59,6 @@ $nl } "For every source file loaded into the system, a list of definitions is maintained. Pathname objects implement the definition protocol, acting over the definitions their source files contain. See " { $link "source-files" } " for details." { $subsection "definition-protocol" } -{ $subsection "definition-crossref" } { $subsection "definition-checking" } { $subsection "compilation-units" } "A parsing word to remove definitions:" @@ -96,36 +85,3 @@ HELP: forget-all { $values { "definitions" "a sequence of definition specifiers" } } { $description "Forgets every definition in a sequence." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } ; - -HELP: uses -{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } } -{ $description "Outputs a sequence of definitions directory called by the given definition." } -{ $notes "The sequence might include the definition itself, if it is a recursive word." } -{ $examples - "We can ask the " { $link sq } " word to produce a list of words it calls:" - { $unchecked-example "\ sq uses ." "{ dup * }" } -} ; - -HELP: crossref -{ $var-description "A graph whose vertices are definition specifiers and edges are usages. See " { $link "graphs" } "." } ; - -HELP: xref -{ $values { "defspec" "a definition specifier" } } -{ $description "Adds a vertex representing this definition, along with edges representing dependencies to the " { $link crossref } " graph." } -$low-level-note ; - -HELP: usage -{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } } -{ $description "Outputs a sequence of definitions that directly call the given definition." } -{ $notes "The sequence might include the definition itself, if it is a recursive word." } ; - -HELP: unxref -{ $values { "defspec" "a definition specifier" } } -{ $description "Remove edges leaving the vertex which represents the definition from the " { $link crossref } " graph." } -{ $notes "This word is called before a word is redefined." } ; - -HELP: delete-xref -{ $values { "defspec" "a definition specifier" } } -{ $description "Remove the vertex which represents the definition from the " { $link crossref } " graph." } -{ $notes "This word is called before a word is forgotten." } -{ $see-also forget } ; diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 1a26e45e87..5dc3808362 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences namespaces assocs graphs math math.order ; +USING: kernel sequences namespaces assocs math ; IN: definitions MIXIN: definition @@ -53,29 +53,3 @@ SYMBOL: forgotten-definitions GENERIC: definer ( defspec -- start end ) GENERIC: definition ( defspec -- seq ) - -SYMBOL: crossref - -GENERIC: uses ( defspec -- seq ) - -M: object uses drop f ; - -: xref ( defspec -- ) dup uses crossref get add-vertex ; - -: usage ( defspec -- seq ) crossref get at keys ; - -GENERIC: irrelevant? ( defspec -- ? ) - -M: object irrelevant? drop f ; - -GENERIC: smart-usage ( defspec -- seq ) - -M: f smart-usage drop \ f smart-usage ; - -M: object smart-usage usage [ irrelevant? not ] filter ; - -: unxref ( defspec -- ) - dup uses crossref get remove-vertex ; - -: delete-xref ( defspec -- ) - dup unxref crossref get delete-at ; diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 37f5cf40ae..e7ae583aa6 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -133,69 +133,19 @@ M: f tag-and-f 4 ; [ 3.4 3 ] [ 3.4 tag-and-f ] unit-test ! Issues with forget -GENERIC: generic-forget-test-1 ( a b -- c ) +GENERIC: generic-forget-test ( a -- b ) -M: integer generic-forget-test-1 / ; +M: f generic-forget-test ; -[ t ] [ - \ / usage [ word? ] filter - [ name>> "integer=>generic-forget-test-1" = ] any? -] unit-test - -[ ] [ - [ \ generic-forget-test-1 forget ] with-compilation-unit -] unit-test - -[ f ] [ - \ / usage [ word? ] filter - [ name>> "integer=>generic-forget-test-1" = ] any? -] unit-test - -GENERIC: generic-forget-test-2 ( a b -- c ) - -M: sequence generic-forget-test-2 = ; - -[ t ] [ - \ = usage [ word? ] filter - [ name>> "sequence=>generic-forget-test-2" = ] any? -] unit-test - -[ ] [ - [ M\ sequence generic-forget-test-2 forget ] with-compilation-unit -] unit-test - -[ f ] [ - \ = usage [ word? ] filter - [ name>> "sequence=>generic-forget-test-2" = ] any? -] unit-test - -GENERIC: generic-forget-test-3 ( a -- b ) - -M: f generic-forget-test-3 ; - -[ ] [ \ f \ generic-forget-test-3 method "m" set ] unit-test +[ ] [ \ f \ generic-forget-test method "m" set ] unit-test [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test -[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval( -- ) ] unit-test +[ ] [ "IN: generic.tests M: f generic-forget-test ;" eval( -- ) ] unit-test [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test -[ f ] [ f generic-forget-test-3 ] unit-test - -: a-word ( -- ) ; - -GENERIC: a-generic ( a -- b ) - -M: integer a-generic a-word ; - -[ ] [ \ integer \ a-generic method "m" set ] unit-test - -[ t ] [ "m" get \ a-word usage memq? ] unit-test - -[ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval( -- ) ] unit-test - -[ f ] [ "m" get \ a-word usage memq? ] unit-test +[ f ] [ f generic-forget-test ] unit-test ! erg's regression [ ] [ diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 7fdb339069..965be91642 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -123,8 +123,6 @@ M: method-body crossref? PREDICATE: default-method < word "default" word-prop ; -M: default-method irrelevant? drop t ; - : ( generic combination -- method ) [ drop object bootstrap-word swap ] [ make-default-method ] 2bi [ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ; @@ -155,9 +153,6 @@ M: method-body forget* [ call-next-method ] bi ] if ; -M: method-body smart-usage - "method-generic" word-prop smart-usage ; - M: sequence update-methods ( class seq -- ) implementors [ [ changed-generic ] [ remake-generic drop ] 2bi @@ -192,6 +187,3 @@ M: generic forget* M: class forget-methods [ implementors ] [ [ swap method ] curry ] bi map forget-all ; - -: xref-generics ( -- ) - all-words [ subwords [ xref ] each ] each ; diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 7e91adfaa1..a0711af095 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -86,8 +86,6 @@ M: engine-word where "tuple-dispatch-generic" word-prop where ; M: engine-word crossref? "forgotten" word-prop not ; -M: engine-word irrelevant? drop t ; - : remember-engine ( word -- ) generic get "engines" word-prop push ; diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index 420dd16991..58007f795f 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -280,27 +280,6 @@ M: growable call-next-hooker call-next-method "growable " prepend ; V{ } my-var [ call-next-hooker ] with-variable ] unit-test -! Cross-referencing with generic words -TUPLE: xref-tuple-1 ; -TUPLE: xref-tuple-2 < xref-tuple-1 ; - -: (xref-test) ( obj -- ) drop ; - -GENERIC: xref-test ( obj -- ) - -M: xref-tuple-1 xref-test (xref-test) ; -M: xref-tuple-2 xref-test (xref-test) ; - -[ t ] [ - \ xref-test - \ xref-tuple-1 \ xref-test method [ usage unique ] closure key? -] unit-test - -[ t ] [ - \ xref-test - \ xref-tuple-2 \ xref-test method [ usage unique ] closure key? -] unit-test - [ t ] [ { } \ nth effective-method nip \ sequence \ nth method eq? ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 9876818d26..7908f40cbe 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -264,7 +264,7 @@ print-use-hook [ [ ] ] initialize : finish-parsing ( lines quot -- ) file get - [ record-form ] + [ record-top-level-form ] [ record-definitions ] [ record-checksum ] tri ; diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor index 2c9e2172cc..eb1284cd25 100644 --- a/core/source-files/source-files-docs.factor +++ b/core/source-files/source-files-docs.factor @@ -11,9 +11,7 @@ $nl { $subsection source-file } "Words intended for the parser:" { $subsection record-checksum } -{ $subsection record-form } -{ $subsection xref-source } -{ $subsection unxref-source } +{ $subsection record-definitions } "Removing a source file from the database:" { $subsection forget-source } "Updating the database:" @@ -42,25 +40,6 @@ HELP: record-checksum { $description "Records the CRC32 checksm of the source file's contents." } $low-level-note ; -HELP: xref-source -{ $values { "source-file" source-file } } -{ $description "Adds the source file to the " { $link crossref } " graph enabling words to find source files which reference them in their top level forms." } -$low-level-note ; - -HELP: unxref-source -{ $values { "source-file" source-file } } -{ $description "Removes the source file from the " { $link crossref } " graph." } -$low-level-note ; - -HELP: xref-sources -{ $description "Adds all loaded source files to the " { $link crossref } " graph. This is done during bootstrap." } -$low-level-note ; - -HELP: record-form -{ $values { "quot" quotation } { "source-file" source-file } } -{ $description "Records usage information for a source file's top level form." } -$low-level-note ; - HELP: reset-checksums { $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "tools.vocabs" } "." } ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 6884a10d03..558018a147 100644 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic assocs kernel math namespaces sequences strings vectors words quotations io io.files @@ -11,29 +11,16 @@ SYMBOL: source-files TUPLE: source-file path +top-level-form checksum -uses definitions ; +definitions ; + +: record-top-level-form ( quot file -- ) + (>>top-level-form) H{ } notify-definition-observers ; : record-checksum ( lines source-file -- ) [ crc32 checksum-lines ] dip (>>checksum) ; -: (xref-source) ( source-file -- pathname uses ) - [ path>> ] - [ uses>> [ crossref? ] filter ] bi ; - -: xref-source ( source-file -- ) - (xref-source) crossref get add-vertex ; - -: unxref-source ( source-file -- ) - (xref-source) crossref get remove-vertex ; - -: xref-sources ( -- ) - source-files get [ nip xref-source ] assoc-each ; - -: record-form ( quot source-file -- ) - [ quot-uses keys ] dip - [ unxref-source ] [ (>>uses) ] [ xref-source ] tri ; - : record-definitions ( file -- ) new-definitions get >>definitions drop ; @@ -58,13 +45,8 @@ ERROR: invalid-source-file-path path ; M: pathname where string>> 1 2array ; : forget-source ( path -- ) - [ - source-file - [ unxref-source ] - [ definitions>> [ keys forget-all ] each ] bi - ] - [ source-files get delete-at ] - bi ; + source-files get delete-at* + [ definitions>> [ keys forget-all ] each ] [ drop ] if ; M: pathname forget* string>> forget-source ; diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 4bed65374c..c1b8c0c229 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -290,10 +290,6 @@ HELP: define-temp "This word must be called from inside " { $link with-compilation-unit } "." } ; -HELP: quot-uses -{ $values { "quot" quotation } { "assoc" "an assoc with words as keys" } } -{ $description "Outputs a set of words referenced by the quotation and any quotations it contains." } ; - HELP: delimiter? { $values { "obj" object } { "?" "a boolean" } } { $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." } diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 3ba5e1f693..0ecf7b65f0 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -63,52 +63,6 @@ FORGET: forgotten FORGET: another-forgotten : another-forgotten ( -- ) ; -! I forgot remove-crossref calls! -: fee ( -- ) ; -: foe ( -- ) fee ; -: fie ( -- ) foe ; - -[ t ] [ \ fee usage [ word? ] filter empty? ] unit-test -[ t ] [ \ foe usage empty? ] unit-test -[ f ] [ \ foe crossref get key? ] unit-test - -FORGET: foe - -! xref should not retain references to gensyms -[ ] [ - [ gensym [ * ] define ] with-compilation-unit -] unit-test - -[ t ] [ - \ * usage [ word? ] filter [ crossref? ] all? -] unit-test - -DEFER: calls-a-gensym -[ ] [ - [ - \ calls-a-gensym - gensym dup "x" set 1quotation - (( x -- x )) define-declared - ] with-compilation-unit -] unit-test - -[ f ] [ "x" get crossref get at ] unit-test - -! more xref buggery -[ f ] [ - GENERIC: xyzzle ( x -- x ) - : a ( -- ) ; \ a - M: integer xyzzle a ; - FORGET: a - M: object xyzzle ; - crossref get at -] unit-test - -! regression -GENERIC: freakish ( x -- y ) -: bar ( x -- y ) freakish ; -M: array freakish ; -[ t ] [ \ bar \ freakish usage member? ] unit-test DEFER: x [ x ] [ undefined? ] must-fail-with @@ -122,26 +76,6 @@ DEFER: x [ ] [ "IN: words.tests : test-last ( -- ) ;" eval( -- ) ] unit-test [ "test-last" ] [ word name>> ] unit-test -! regression -SYMBOL: quot-uses-a -SYMBOL: quot-uses-b - -[ ] [ - [ - quot-uses-a [ 2 3 + ] define - ] with-compilation-unit -] unit-test - -[ { + } ] [ \ quot-uses-a uses ] unit-test - -[ ] [ - [ - quot-uses-b 2 [ 3 + ] curry define - ] with-compilation-unit -] unit-test - -[ { + } ] [ \ quot-uses-b uses ] unit-test - "undef-test" "words.tests" lookup [ [ forget ] with-compilation-unit ] when* @@ -191,8 +125,3 @@ SYMBOL: quot-uses-b keys [ "forgotten" word-prop ] any? ] filter ] unit-test - -[ { } ] [ - crossref get keys - [ word? ] filter [ "forgotten" word-prop ] filter -] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index 1a2317997a..eb0599db78 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -62,33 +62,7 @@ SYMBOL: bootstrapping? GENERIC: crossref? ( word -- ? ) M: word crossref? - dup "forgotten" word-prop [ - drop f - ] [ - vocabulary>> >boolean - ] if ; - -GENERIC# (quot-uses) 1 ( obj assoc -- ) - -M: object (quot-uses) 2drop ; - -M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ; - -: seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ; - -M: array (quot-uses) seq-uses ; - -M: hashtable (quot-uses) [ >alist ] dip seq-uses ; - -M: callable (quot-uses) seq-uses ; - -M: wrapper (quot-uses) [ wrapped>> ] dip (quot-uses) ; - -: quot-uses ( quot -- assoc ) - global [ H{ } clone [ (quot-uses) ] keep ] bind ; - -M: word uses ( word -- seq ) - def>> quot-uses keys ; + dup "forgotten" word-prop [ drop f ] [ vocabulary>> >boolean ] if ; SYMBOL: compiled-crossref @@ -132,11 +106,7 @@ GENERIC: subwords ( word -- seq ) M: word subwords drop f ; : define ( word def -- ) - [ ] like - over unxref - over changed-definition - >>def - dup crossref? [ dup xref ] when drop ; + over changed-definition [ ] like >>def drop ; : changed-effect ( word -- ) [ dup changed-effects get set-in-unit ] @@ -228,10 +198,9 @@ M: word set-where swap "loc" set-word-prop ; M: word forget* dup "forgotten" word-prop [ drop ] [ - [ delete-xref ] [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ] [ t "forgotten" set-word-prop ] - tri + bi ] if ; M: word hashcode* @@ -239,6 +208,4 @@ M: word hashcode* M: word literalize ; -: xref-words ( -- ) all-words [ xref ] each ; - INSTANCE: word definition \ No newline at end of file From 20ca578ed15fc872f10ef1bf774a929e5210d486 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 04:21:15 -0500 Subject: [PATCH 459/772] stack-checker.transforms: fix tests --- basis/stack-checker/transforms/transforms-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index 126f6a9648..fe0fa08356 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -3,10 +3,10 @@ USING: sequences stack-checker.transforms tools.test math kernel quotations stack-checker stack-checker.errors accessors combinators words arrays classes classes.tuple ; -: compose-n-quot ( word n -- quot' ) >quotation ; -: compose-n ( quot n -- ) compose-n-quot call ; +: compose-n ( quot n -- ) "OOPS" throw ; << +: compose-n-quot ( word n -- quot' ) >quotation ; \ compose-n [ compose-n-quot ] 2 define-transform \ compose-n t "no-compile" set-word-prop >> From 65532de7de4118189290b15e80fd125658bf6e2d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 04:23:26 -0500 Subject: [PATCH 460/772] editors.emacs.windows: Add meta-data --- basis/editors/emacs/windows/authors.txt | 2 +- basis/editors/emacs/windows/tags.txt | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 basis/editors/emacs/windows/tags.txt diff --git a/basis/editors/emacs/windows/authors.txt b/basis/editors/emacs/windows/authors.txt index 7c1b2f2279..1901f27a24 100755 --- a/basis/editors/emacs/windows/authors.txt +++ b/basis/editors/emacs/windows/authors.txt @@ -1 +1 @@ -Doug Coleman +Slava Pestov diff --git a/basis/editors/emacs/windows/tags.txt b/basis/editors/emacs/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/emacs/windows/tags.txt @@ -0,0 +1 @@ +unportable From 3783d8513f9ce57e50a134bbf791aa10c2feac16 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 04:41:03 -0500 Subject: [PATCH 461/772] tools.deploy.shaker: fix --- basis/tools/deploy/shaker/shaker.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 0d7d8fd7c6..e23e1b092d 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -264,7 +264,6 @@ IN: tools.deploy.shaker compiler-impl compiler.errors:compiler-errors definition-observers - definitions:crossref interactive-vocabs layouts:num-tags layouts:num-types From caf6f280eabeb918676870372f441dc4c3649d3b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 04:46:47 -0500 Subject: [PATCH 462/772] annotations: update for usage being moved to tools.crossref --- extra/annotations/annotations-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/annotations/annotations-docs.factor b/extra/annotations/annotations-docs.factor index 1bece9d4fb..8685d954e8 100644 --- a/extra/annotations/annotations-docs.factor +++ b/extra/annotations/annotations-docs.factor @@ -1,6 +1,6 @@ USING: accessors arrays combinators definitions generalizations help help.markup help.topics kernel sequences sorting vocabs -words combinators.smart ; +words combinators.smart tools.crossref ; IN: annotations Date: Wed, 22 Apr 2009 06:50:09 -0500 Subject: [PATCH 463/772] Move multi-methods, and vocabs that depend on them (dns, shell, newfx). Multi methods won't be in Factor 1.0 and I don't want to keep maintaining this feature --- {extra => unmaintained}/boolean-expr/authors.txt | 0 {extra => unmaintained}/boolean-expr/boolean-expr.factor | 0 {extra => unmaintained}/boolean-expr/summary.txt | 0 {extra => unmaintained}/boolean-expr/tags.txt | 0 {extra => unmaintained}/dns/cache/nx/nx.factor | 0 {extra => unmaintained}/dns/cache/rr/rr.factor | 0 {extra => unmaintained}/dns/dns.factor | 0 {extra => unmaintained}/dns/forwarding/forwarding.factor | 0 {extra => unmaintained}/dns/misc/misc.factor | 0 {extra => unmaintained}/dns/resolver/resolver.factor | 0 {extra => unmaintained}/dns/server/server.factor | 0 {extra => unmaintained}/dns/stub/stub.factor | 0 {extra => unmaintained}/dns/util/util.factor | 0 {extra => unmaintained}/multi-methods/authors.txt | 0 {extra => unmaintained}/multi-methods/multi-methods.factor | 0 {extra => unmaintained}/multi-methods/summary.txt | 0 {extra => unmaintained}/multi-methods/tags.txt | 0 {extra => unmaintained}/multi-methods/tests/canonicalize.factor | 0 {extra => unmaintained}/multi-methods/tests/definitions.factor | 0 {extra => unmaintained}/multi-methods/tests/legacy.factor | 0 {extra => unmaintained}/multi-methods/tests/syntax.factor | 0 .../multi-methods/tests/topological-sort.factor | 0 {extra => unmaintained}/shell/parser/parser.factor | 0 {extra => unmaintained}/shell/shell.factor | 0 24 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/boolean-expr/authors.txt (100%) rename {extra => unmaintained}/boolean-expr/boolean-expr.factor (100%) rename {extra => unmaintained}/boolean-expr/summary.txt (100%) rename {extra => unmaintained}/boolean-expr/tags.txt (100%) rename {extra => unmaintained}/dns/cache/nx/nx.factor (100%) rename {extra => unmaintained}/dns/cache/rr/rr.factor (100%) rename {extra => unmaintained}/dns/dns.factor (100%) rename {extra => unmaintained}/dns/forwarding/forwarding.factor (100%) rename {extra => unmaintained}/dns/misc/misc.factor (100%) rename {extra => unmaintained}/dns/resolver/resolver.factor (100%) rename {extra => unmaintained}/dns/server/server.factor (100%) rename {extra => unmaintained}/dns/stub/stub.factor (100%) rename {extra => unmaintained}/dns/util/util.factor (100%) rename {extra => unmaintained}/multi-methods/authors.txt (100%) rename {extra => unmaintained}/multi-methods/multi-methods.factor (100%) rename {extra => unmaintained}/multi-methods/summary.txt (100%) rename {extra => unmaintained}/multi-methods/tags.txt (100%) rename {extra => unmaintained}/multi-methods/tests/canonicalize.factor (100%) rename {extra => unmaintained}/multi-methods/tests/definitions.factor (100%) rename {extra => unmaintained}/multi-methods/tests/legacy.factor (100%) rename {extra => unmaintained}/multi-methods/tests/syntax.factor (100%) rename {extra => unmaintained}/multi-methods/tests/topological-sort.factor (100%) rename {extra => unmaintained}/shell/parser/parser.factor (100%) rename {extra => unmaintained}/shell/shell.factor (100%) diff --git a/extra/boolean-expr/authors.txt b/unmaintained/boolean-expr/authors.txt similarity index 100% rename from extra/boolean-expr/authors.txt rename to unmaintained/boolean-expr/authors.txt diff --git a/extra/boolean-expr/boolean-expr.factor b/unmaintained/boolean-expr/boolean-expr.factor similarity index 100% rename from extra/boolean-expr/boolean-expr.factor rename to unmaintained/boolean-expr/boolean-expr.factor diff --git a/extra/boolean-expr/summary.txt b/unmaintained/boolean-expr/summary.txt similarity index 100% rename from extra/boolean-expr/summary.txt rename to unmaintained/boolean-expr/summary.txt diff --git a/extra/boolean-expr/tags.txt b/unmaintained/boolean-expr/tags.txt similarity index 100% rename from extra/boolean-expr/tags.txt rename to unmaintained/boolean-expr/tags.txt diff --git a/extra/dns/cache/nx/nx.factor b/unmaintained/dns/cache/nx/nx.factor similarity index 100% rename from extra/dns/cache/nx/nx.factor rename to unmaintained/dns/cache/nx/nx.factor diff --git a/extra/dns/cache/rr/rr.factor b/unmaintained/dns/cache/rr/rr.factor similarity index 100% rename from extra/dns/cache/rr/rr.factor rename to unmaintained/dns/cache/rr/rr.factor diff --git a/extra/dns/dns.factor b/unmaintained/dns/dns.factor similarity index 100% rename from extra/dns/dns.factor rename to unmaintained/dns/dns.factor diff --git a/extra/dns/forwarding/forwarding.factor b/unmaintained/dns/forwarding/forwarding.factor similarity index 100% rename from extra/dns/forwarding/forwarding.factor rename to unmaintained/dns/forwarding/forwarding.factor diff --git a/extra/dns/misc/misc.factor b/unmaintained/dns/misc/misc.factor similarity index 100% rename from extra/dns/misc/misc.factor rename to unmaintained/dns/misc/misc.factor diff --git a/extra/dns/resolver/resolver.factor b/unmaintained/dns/resolver/resolver.factor similarity index 100% rename from extra/dns/resolver/resolver.factor rename to unmaintained/dns/resolver/resolver.factor diff --git a/extra/dns/server/server.factor b/unmaintained/dns/server/server.factor similarity index 100% rename from extra/dns/server/server.factor rename to unmaintained/dns/server/server.factor diff --git a/extra/dns/stub/stub.factor b/unmaintained/dns/stub/stub.factor similarity index 100% rename from extra/dns/stub/stub.factor rename to unmaintained/dns/stub/stub.factor diff --git a/extra/dns/util/util.factor b/unmaintained/dns/util/util.factor similarity index 100% rename from extra/dns/util/util.factor rename to unmaintained/dns/util/util.factor diff --git a/extra/multi-methods/authors.txt b/unmaintained/multi-methods/authors.txt similarity index 100% rename from extra/multi-methods/authors.txt rename to unmaintained/multi-methods/authors.txt diff --git a/extra/multi-methods/multi-methods.factor b/unmaintained/multi-methods/multi-methods.factor similarity index 100% rename from extra/multi-methods/multi-methods.factor rename to unmaintained/multi-methods/multi-methods.factor diff --git a/extra/multi-methods/summary.txt b/unmaintained/multi-methods/summary.txt similarity index 100% rename from extra/multi-methods/summary.txt rename to unmaintained/multi-methods/summary.txt diff --git a/extra/multi-methods/tags.txt b/unmaintained/multi-methods/tags.txt similarity index 100% rename from extra/multi-methods/tags.txt rename to unmaintained/multi-methods/tags.txt diff --git a/extra/multi-methods/tests/canonicalize.factor b/unmaintained/multi-methods/tests/canonicalize.factor similarity index 100% rename from extra/multi-methods/tests/canonicalize.factor rename to unmaintained/multi-methods/tests/canonicalize.factor diff --git a/extra/multi-methods/tests/definitions.factor b/unmaintained/multi-methods/tests/definitions.factor similarity index 100% rename from extra/multi-methods/tests/definitions.factor rename to unmaintained/multi-methods/tests/definitions.factor diff --git a/extra/multi-methods/tests/legacy.factor b/unmaintained/multi-methods/tests/legacy.factor similarity index 100% rename from extra/multi-methods/tests/legacy.factor rename to unmaintained/multi-methods/tests/legacy.factor diff --git a/extra/multi-methods/tests/syntax.factor b/unmaintained/multi-methods/tests/syntax.factor similarity index 100% rename from extra/multi-methods/tests/syntax.factor rename to unmaintained/multi-methods/tests/syntax.factor diff --git a/extra/multi-methods/tests/topological-sort.factor b/unmaintained/multi-methods/tests/topological-sort.factor similarity index 100% rename from extra/multi-methods/tests/topological-sort.factor rename to unmaintained/multi-methods/tests/topological-sort.factor diff --git a/extra/shell/parser/parser.factor b/unmaintained/shell/parser/parser.factor similarity index 100% rename from extra/shell/parser/parser.factor rename to unmaintained/shell/parser/parser.factor diff --git a/extra/shell/shell.factor b/unmaintained/shell/shell.factor similarity index 100% rename from extra/shell/shell.factor rename to unmaintained/shell/shell.factor From f4f99036ca2173720fc9338dcc7ea30ec45852d5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 07:04:15 -0500 Subject: [PATCH 464/772] Move lint to unmaintained --- {extra => unmaintained}/lint/authors.txt | 0 {extra => unmaintained}/lint/lint-tests.factor | 0 {extra => unmaintained}/lint/lint.factor | 0 {extra => unmaintained}/lint/summary.txt | 0 4 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/lint/authors.txt (100%) rename {extra => unmaintained}/lint/lint-tests.factor (100%) rename {extra => unmaintained}/lint/lint.factor (100%) rename {extra => unmaintained}/lint/summary.txt (100%) diff --git a/extra/lint/authors.txt b/unmaintained/lint/authors.txt similarity index 100% rename from extra/lint/authors.txt rename to unmaintained/lint/authors.txt diff --git a/extra/lint/lint-tests.factor b/unmaintained/lint/lint-tests.factor similarity index 100% rename from extra/lint/lint-tests.factor rename to unmaintained/lint/lint-tests.factor diff --git a/extra/lint/lint.factor b/unmaintained/lint/lint.factor similarity index 100% rename from extra/lint/lint.factor rename to unmaintained/lint/lint.factor diff --git a/extra/lint/summary.txt b/unmaintained/lint/summary.txt similarity index 100% rename from extra/lint/summary.txt rename to unmaintained/lint/summary.txt From 3353a777f76da28cf25f7835225a3bd144613b13 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 07:05:00 -0500 Subject: [PATCH 465/772] Fixing some unit test failures --- .../format/macros/macros-tests.factor | 2 +- basis/combinators/smart/smart-tests.factor | 2 +- .../cpu/ppc/assembler/assembler-tests.factor | 2 -- basis/debugger/debugger-tests.factor | 3 +++ basis/help/markup/markup-tests.factor | 2 +- basis/math/intervals/intervals-tests.factor | 4 +-- basis/peg/ebnf/ebnf-tests.factor | 2 -- basis/peg/peg-tests.factor | 2 -- basis/regexp/parser/parser-tests.factor | 2 +- basis/tools/crossref/crossref-tests.factor | 2 +- basis/tools/crossref/crossref.factor | 25 ++++++++++++++--- basis/tools/profiler/profiler-tests.factor | 2 +- basis/unicode/breaks/breaks-tests.factor | 2 +- .../unicode/collation/collation-tests.factor | 5 ++-- .../unicode/normalize/normalize-tests.factor | 2 -- basis/windows/com/wrapper/wrapper.factor | 2 +- core/continuations/continuations-tests.factor | 12 ++++----- core/kernel/kernel-tests.factor | 27 ++++++++++++------- core/parser/parser-tests.factor | 3 ++- .../client/internals/internals-tests.factor | 2 +- 20 files changed, 62 insertions(+), 43 deletions(-) diff --git a/basis/calendar/format/macros/macros-tests.factor b/basis/calendar/format/macros/macros-tests.factor index 48567539ad..4ba2872b43 100644 --- a/basis/calendar/format/macros/macros-tests.factor +++ b/basis/calendar/format/macros/macros-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test kernel ; +USING: tools.test kernel accessors ; IN: calendar.format.macros [ 2 ] [ { [ 2 ] } attempt-all-quots ] unit-test diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 080379e924..a18ef1f3b8 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test combinators.smart math kernel ; +USING: tools.test combinators.smart math kernel accessors ; IN: combinators.smart.tests : test-bi ( -- 9 11 ) diff --git a/basis/cpu/ppc/assembler/assembler-tests.factor b/basis/cpu/ppc/assembler/assembler-tests.factor index f35a5cfca8..09db4cb050 100644 --- a/basis/cpu/ppc/assembler/assembler-tests.factor +++ b/basis/cpu/ppc/assembler/assembler-tests.factor @@ -114,5 +114,3 @@ make vocabs sequences ; { HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler { HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler { HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler - -"cpu.ppc.assembler" words [ must-infer ] each diff --git a/basis/debugger/debugger-tests.factor b/basis/debugger/debugger-tests.factor index afa4aa1c28..08f84d9335 100644 --- a/basis/debugger/debugger-tests.factor +++ b/basis/debugger/debugger-tests.factor @@ -2,3 +2,6 @@ IN: debugger.tests USING: debugger kernel continuations tools.test ; [ ] [ [ drop ] [ error. ] recover ] unit-test + +[ f ] [ { } vm-error? ] unit-test +[ f ] [ { "A" "B" } vm-error? ] unit-test \ No newline at end of file diff --git a/basis/help/markup/markup-tests.factor b/basis/help/markup/markup-tests.factor index bcd8843b24..93bed37a55 100644 --- a/basis/help/markup/markup-tests.factor +++ b/basis/help/markup/markup-tests.factor @@ -5,7 +5,7 @@ IN: help.markup.tests TUPLE: blahblah quux ; -[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test +[ "int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test [ ] [ \ quux>> print-topic ] unit-test [ ] [ \ >>quux print-topic ] unit-test diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 8b43456901..2b8b3dff24 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -302,8 +302,8 @@ IN: math.intervals.tests : comparison-test ( -- ? ) random-interval random-interval random-comparison - [ [ [ random-element ] bi@ ] dip first execute ] 3keep - second execute dup incomparable eq? [ 2drop t ] [ = ] if ; + [ [ [ random-element ] bi@ ] dip first execute( a b -- ? ) ] 3keep + second execute( a b -- ? ) dup incomparable eq? [ 2drop t ] [ = ] if ; [ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test diff --git a/basis/peg/ebnf/ebnf-tests.factor b/basis/peg/ebnf/ebnf-tests.factor index 58102cffc3..329156d733 100644 --- a/basis/peg/ebnf/ebnf-tests.factor +++ b/basis/peg/ebnf/ebnf-tests.factor @@ -300,8 +300,6 @@ main = Primary "x[i][j].y" primary ] unit-test -'ebnf' compile must-infer - { V{ V{ "a" "b" } "c" } } [ "abc" [EBNF a="a" "b" foo=(a "c") EBNF] ] unit-test diff --git a/basis/peg/peg-tests.factor b/basis/peg/peg-tests.factor index 9a15dd2105..683fa328d8 100644 --- a/basis/peg/peg-tests.factor +++ b/basis/peg/peg-tests.factor @@ -206,5 +206,3 @@ USE: compiler [ ] [ enable-compiler ] unit-test [ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test - -[ [ ] ] [ "" epsilon [ drop [ [ ] ] ] action [ call ] action parse ] unit-test \ No newline at end of file diff --git a/basis/regexp/parser/parser-tests.factor b/basis/regexp/parser/parser-tests.factor index 0e12014eef..5ea9753fba 100644 --- a/basis/regexp/parser/parser-tests.factor +++ b/basis/regexp/parser/parser-tests.factor @@ -4,7 +4,7 @@ IN: regexp.parser.tests : regexp-parses ( string -- ) [ [ ] ] dip '[ _ parse-regexp drop ] unit-test ; -: regexp-fails ( string -- regexp ) +: regexp-fails ( string -- ) '[ _ parse-regexp ] must-fail ; { diff --git a/basis/tools/crossref/crossref-tests.factor b/basis/tools/crossref/crossref-tests.factor index 26c6c4e597..80f5367fb6 100755 --- a/basis/tools/crossref/crossref-tests.factor +++ b/basis/tools/crossref/crossref-tests.factor @@ -1,6 +1,6 @@ USING: math kernel sequences io.files io.pathnames tools.crossref tools.test parser namespaces source-files generic -definitions ; +definitions words accessors compiler.units ; IN: tools.crossref.tests GENERIC: foo ( a b -- c ) diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index feaddc8194..c5cd246f2e 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -13,30 +13,47 @@ GENERIC: uses ( defspec -- seq ) alist ] dip (seq-uses) + ] if ; M: array quot-uses seq-uses ; -M: hashtable quot-uses [ >alist ] dip seq-uses ; +M: hashtable quot-uses assoc-uses ; M: callable quot-uses seq-uses ; M: wrapper quot-uses [ wrapped>> ] dip quot-uses ; M: callable uses ( quot -- assoc ) - H{ } clone [ quot-uses ] keep keys ; + V{ } clone visited [ + H{ } clone [ quot-uses ] keep keys + ] with-variable ; M: word uses def>> uses ; M: link uses { $subsection $link $see-also } article-links ; -M: pathname uses string>> source-file top-level-form>> uses ; +M: pathname uses string>> source-file top-level-form>> [ uses ] [ { } ] if* ; GENERIC: crossref-def ( defspec -- ) diff --git a/basis/tools/profiler/profiler-tests.factor b/basis/tools/profiler/profiler-tests.factor index 0bd3663729..d2e605ecdc 100644 --- a/basis/tools/profiler/profiler-tests.factor +++ b/basis/tools/profiler/profiler-tests.factor @@ -34,7 +34,7 @@ words ; [ 1 ] [ \ foobar counter>> ] unit-test -: fooblah ( -- ) { } [ ] like call ; +: fooblah ( -- ) { } [ ] like call( -- ) ; : foobaz ( -- ) fooblah fooblah ; diff --git a/basis/unicode/breaks/breaks-tests.factor b/basis/unicode/breaks/breaks-tests.factor index 3a26b01213..6d6d4233f5 100644 --- a/basis/unicode/breaks/breaks-tests.factor +++ b/basis/unicode/breaks/breaks-tests.factor @@ -32,7 +32,7 @@ IN: unicode.breaks.tests [ concat [ quot call [ "" like ] map ] curry ] bi unit-test ] each ; -: grapheme-test ( tests quot -- ) +: grapheme-test ( tests -- ) [ [ 1quotation ] [ concat [ >graphemes [ "" like ] map ] curry ] bi unit-test diff --git a/basis/unicode/collation/collation-tests.factor b/basis/unicode/collation/collation-tests.factor index f53a1382ae..fdeb721e65 100644 --- a/basis/unicode/collation/collation-tests.factor +++ b/basis/unicode/collation/collation-tests.factor @@ -11,9 +11,10 @@ IN: unicode.collation.tests : test-two ( str1 str2 -- ) [ +lt+ ] -rot [ string<=> ] 2curry unit-test ; -: test-equality ( str1 str2 -- ) +: test-equality ( str1 str2 -- ? ? ? ? ) { primary= secondary= tertiary= quaternary= } - [ execute ] with with each ; + [ execute( a b -- ? ) ] with with map + first4 ; [ f f f f ] [ "hello" "hi" test-equality ] unit-test [ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test diff --git a/basis/unicode/normalize/normalize-tests.factor b/basis/unicode/normalize/normalize-tests.factor index f774016272..cea880c0b0 100644 --- a/basis/unicode/normalize/normalize-tests.factor +++ b/basis/unicode/normalize/normalize-tests.factor @@ -3,8 +3,6 @@ simple-flat-file io.encodings.utf8 io.files splitting math.parser locals math quotations assocs combinators unicode.normalize.private ; IN: unicode.normalize.tests -{ nfc nfkc nfd nfkd } [ must-infer ] each - [ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test [ "ab\u00064b\u000347\u00034e\u00034d\u000346" ] [ "ab\u000346\u000347\u00064b\u00034e\u00034d" dup reorder ] unit-test diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index a014a56ea0..e78c987cd4 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -132,7 +132,7 @@ unless [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ; : (callbacks>vtbl) ( callbacks -- vtbl ) - [ execute ] void*-array{ } map-as malloc-byte-array ; + [ execute( -- callback ) ] void*-array{ } map-as malloc-byte-array ; : (callbacks>vtbls) ( callbacks -- vtbls ) [ (callbacks>vtbl) ] map ; diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 391b87a44f..f4eeeefb77 100644 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -50,21 +50,19 @@ IN: continuations.tests gc ] unit-test -[ f ] [ { } kernel-error? ] unit-test -[ f ] [ { "A" "B" } kernel-error? ] unit-test - ! ! See how well callstack overflow is handled ! [ clear drop ] must-fail ! ! : callstack-overflow callstack-overflow f ; ! [ callstack-overflow ] must-fail -: don't-compile-me ( n -- ) { } [ ] each ; - -: foo ( -- ) callstack "c" set 3 don't-compile-me ; +: don't-compile-me ( -- ) ; +: foo ( -- ) callstack "c" set don't-compile-me ; : bar ( -- a b ) 1 foo 2 ; -[ 1 3 2 ] [ bar ] unit-test +<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >> + +[ 1 2 ] [ bar ] unit-test [ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 84a356805b..b58c744b05 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -1,7 +1,7 @@ USING: arrays byte-arrays kernel kernel.private math memory namespaces sequences tools.test math.private quotations continuations prettyprint io.streams.string debugger assocs -sequences.private accessors locals.backend grouping ; +sequences.private accessors locals.backend grouping words ; IN: kernel.tests [ 0 ] [ f size ] unit-test @@ -23,20 +23,25 @@ IN: kernel.tests : overflow-d ( -- ) 3 overflow-d ; -[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with - -[ ] [ :c ] unit-test - : (overflow-d-alt) ( -- n ) 3 ; : overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ; +: overflow-r ( -- ) 3 load-local overflow-r ; + +<< +{ overflow-d (overflow-d-alt) overflow-d-alt overflow-r } +[ t "no-compile" set-word-prop ] each +>> + +[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with + +[ ] [ :c ] unit-test + [ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ [ :c ] with-string-writer drop ] unit-test -: overflow-r ( -- ) 3 load-local overflow-r ; - [ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with [ ] [ :c ] unit-test @@ -99,7 +104,9 @@ IN: kernel.tests [ ] [ :c ] unit-test ! Doesn't compile; important -: foo ( a -- b ) 5 + 0 [ ] each ; +: foo ( a -- b ) ; + +<< \ foo t "no-compile" set-word-prop >> [ drop foo ] must-fail [ ] [ :c ] unit-test @@ -109,13 +116,13 @@ IN: kernel.tests [ pick ] dip swap [ pick ] dip swap < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive -: loop ( obj obj -- ) +: loop ( obj -- ) H{ } values swap [ dup length swap ] dip 0 -roll (loop) ; [ loop ] must-fail ! Discovered on Windows -: total-failure-1 ( -- ) "" [ ] map unimplemented ; +: total-failure-1 ( -- a ) "" [ ] map unimplemented ; [ total-failure-1 ] must-fail diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index a8a57ccdaa..e944ecc6f2 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -3,7 +3,8 @@ io.streams.string namespaces classes effects source-files assocs sequences strings io.files io.pathnames definitions continuations sorting classes.tuple compiler.units debugger vocabs vocabs.loader accessors eval combinators lexer -vocabs.parser words.symbol multiline source-files.errors ; +vocabs.parser words.symbol multiline source-files.errors +tools.crossref ; IN: parser.tests [ diff --git a/extra/irc/client/internals/internals-tests.factor b/extra/irc/client/internals/internals-tests.factor index d20ae50bcc..27b5648f97 100644 --- a/extra/irc/client/internals/internals-tests.factor +++ b/extra/irc/client/internals/internals-tests.factor @@ -41,7 +41,7 @@ M: mb-writer dispose drop ; : %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ; : read-matching-message ( chat quot: ( msg -- ? ) -- irc-message ) - [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; + [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; inline : spawning-irc ( quot: ( -- ) -- ) [ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline From 91cd13d2d626428722745cd51933a845a4e8fce3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 07:07:24 -0500 Subject: [PATCH 466/772] mason.test: collect compiler errors at the very end of the process, to catch errors in unit test files --- extra/mason/test/test.factor | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 912fbaa17a..22b932ac5b 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -25,12 +25,6 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; [ file>> ] map prune natural-sort summary-file to-file errors details-file utf8 [ errors. ] with-file-writer ; -: do-compile-errors ( -- ) - compiler-errors get values - compiler-errors-file - compiler-error-messages-file - do-step ; - : do-tests ( -- ) test-all test-failures get test-all-vocabs-file @@ -50,6 +44,12 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; [ benchmark-error-messages-file utf8 [ benchmark-errors. ] with-file-writer ] bi ] bi* ; +: do-compile-errors ( -- ) + compiler-errors get values + compiler-errors-file + compiler-error-messages-file + do-step ; + : benchmark-ms ( quot -- ms ) benchmark 1000 /i ; inline @@ -66,11 +66,12 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; ".." [ bootstrap-time get boot-time-file to-file check-boot-image - [ do-load do-compile-errors ] benchmark-ms load-time-file to-file + [ do-load ] benchmark-ms load-time-file to-file [ generate-help ] benchmark-ms html-help-time-file to-file [ do-tests ] benchmark-ms test-time-file to-file [ do-help-lint ] benchmark-ms help-lint-time-file to-file [ do-benchmarks ] benchmark-ms benchmark-time-file to-file + do-compile-errors ] with-directory ; MAIN: do-all \ No newline at end of file From ea87b380f38604b95819e29445e3d55d152a3ff0 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 22 Apr 2009 16:09:03 +0200 Subject: [PATCH 467/772] made auto node discovery work --- bson/writer/writer.factor | 5 +- mongodb/benchmark/benchmark.factor | 28 ++-- mongodb/connection/connection.factor | 165 ++++++++++++++------- mongodb/driver/driver.factor | 47 ++---- mongodb/tuple/collection/collection.factor | 4 +- mongodb/tuple/state/state.factor | 18 +-- 6 files changed, 148 insertions(+), 119 deletions(-) diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 4ad1d7fdcc..ae12ca0a03 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -4,7 +4,7 @@ USING: accessors assocs bson.constants byte-arrays byte-vectors calendar fry io io.binary io.encodings io.encodings.binary io.encodings.utf8 io.streams.byte-array kernel math math.parser namespaces quotations sequences sequences.private serialize strings -words combinators.short-circuit ; +words combinators.short-circuit literals ; IN: bson.writer @@ -29,7 +29,6 @@ CONSTANT: INT64-SIZE 8 [ set-nth-unsafe ] keep write ] each ; inline - PRIVATE> : reset-buffer ( buffer -- ) @@ -147,7 +146,7 @@ M: sequence bson-write ( array -- ) [ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline : skip-field? ( name -- boolean ) - { "_id" "_mfd" } member? ; inline + { $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline M: assoc bson-write ( assoc -- ) '[ _ [ write-oid ] keep diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index 424aa7732c..683f41b83b 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -131,12 +131,12 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : (insert) ( quot: ( i -- doc ) collection -- ) [ trial-size ] 2dip - '[ _ call [ _ ] dip + '[ _ call( i -- doc ) [ _ ] dip result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ; inline -: (prepare-batch) ( i b quot: ( i -- doc ) -- ) +: (prepare-batch) ( i b quot: ( i -- doc ) -- batch-seq ) [ [ * ] keep 1 range boa ] dip - '[ _ call ] map ; inline + '[ _ call( i -- doc ) ] map ; inline : (insert-batch) ( quot: ( i -- doc ) collection -- ) [ trial-size batch-size [ / ] keep ] 2dip @@ -170,10 +170,10 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ; : serialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) - '[ trial-size [ _ call assoc>bv drop ] each-integer ] ; inline + '[ trial-size [ _ call( i -- doc ) assoc>bv drop ] each-integer ] ; inline : deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) - [ 0 ] dip call assoc>bv + [ 0 ] dip call( i -- doc ) assoc>bv '[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ; inline : check-for-key ( assoc key -- ) @@ -240,41 +240,41 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } [ ] prepose [ print-result ] compose with-scope ; inline -: bench-quot ( feat-seq op-word -- quot: ( elt -- ) ) +: [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) ) '[ _ swap _ - '[ [ [ _ execute ] dip - [ execute ] each _ execute benchmark ] with-result ] each + '[ [ [ _ execute( -- quot: ( i -- doc ) ) ] dip + [ execute( -- ) ] each _ execute( -- quot: ( -- ) ) benchmark ] with-result ] each print-separator ] ; inline : run-serialization-bench ( doc-word-seq feat-seq -- ) "Serialization Tests" print print-separator-bold - \ serialize bench-quot each ; inline + \ serialize [bench-quot] each ; inline : run-deserialization-bench ( doc-word-seq feat-seq -- ) "Deserialization Tests" print print-separator-bold - \ deserialize bench-quot each ; inline + \ deserialize [bench-quot] each ; inline : run-insert-bench ( doc-word-seq feat-seq -- ) "Insert Tests" print print-separator-bold - \ insert bench-quot each ; inline + \ insert [bench-quot] each ; inline : run-find-one-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-One" print print-separator-bold - \ find-one bench-quot each ; inline + \ find-one [bench-quot] each ; inline : run-find-all-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-All" print print-separator-bold - \ find-all bench-quot each ; inline + \ find-all [bench-quot] each ; inline : run-find-range-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-Range" print print-separator-bold - \ find-range bench-quot each ; inline + \ find-range [bench-quot] each ; inline : run-benchmarks ( -- ) diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor index 06394ecf0f..87718a9788 100644 --- a/mongodb/connection/connection.factor +++ b/mongodb/connection/connection.factor @@ -1,79 +1,142 @@ USING: accessors assocs fry io.encodings.binary io.sockets kernel math math.parser mongodb.msg mongodb.operations namespaces destructors -constructors sequences splitting ; +constructors sequences splitting checksums checksums.md5 formatting +io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart +arrays hashtables sequences.deep vectors locals ; IN: mongodb.connection -TUPLE: mdb-db name username password nodes collections ; +: md5-checksum ( string -- digest ) + utf8 encode md5 checksum-bytes hex-string ; inline -TUPLE: mdb-node master? inet ; +TUPLE: mdb-db name username pwd-digest nodes collections ; -CONSTRUCTOR: mdb-node ( inet master? -- mdb-node ) ; +TUPLE: mdb-node master? { address inet } remote ; -TUPLE: mdb-connection instance handle remote local ; +CONSTRUCTOR: mdb-node ( address master? -- mdb-node ) ; -: () ( name nodes -- mdb-db ) +TUPLE: mdb-connection instance node handle remote local ; + +CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; + +: check-ok ( result -- ? ) + [ "ok" ] dip at >integer 1 = ; inline + +: ( name nodes -- mdb-db ) mdb-db new swap >>nodes swap >>name H{ } clone >>collections ; -: master-node ( mdb -- inet ) - nodes>> [ t ] dip at inet>> ; +: master-node ( mdb -- node ) + nodes>> t swap at ; -: slave-node ( mdb -- inet ) - nodes>> [ f ] dip at inet>> ; - -: >mdb-connection ( stream -- ) - mdb-connection set ; inline - -: mdb-connection> ( -- stream ) - mdb-connection get ; inline +: slave-node ( mdb -- node ) + nodes>> f swap at ; +: with-connection ( connection quot -- * ) + [ mdb-connection set ] prepose with-scope ; inline + : mdb-instance ( -- mdb ) - mdb-connection> instance>> ; + mdb-connection get instance>> ; inline + +: index-collection ( -- ns ) + mdb-instance name>> "%s.system.indexes" sprintf ; inline + +: namespaces-collection ( -- ns ) + mdb-instance name>> "%s.system.namespaces" sprintf ; inline + +: cmd-collection ( -- ns ) + mdb-instance name>> "%s.$cmd" sprintf ; inline + +: index-ns ( colname -- index-ns ) + [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline + +: send-message ( message -- ) + [ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ; + +: send-query-plain ( query-message -- result ) + [ mdb-connection get handle>> ] dip + '[ _ write-message read-message ] with-stream* ; + +: send-query-1result ( collection assoc -- result ) + + 1 >>return# + send-query-plain objects>> + [ f ] [ first ] if-empty ; - 1 >>return# '[ _ write-message read-message ] with-client - objects>> first ; +: auth? ( mdb -- ? ) + [ username>> ] [ pwd-digest>> ] bi and ; + +: calculate-key-digest ( nonce -- digest ) + mdb-instance + [ username>> ] + [ pwd-digest>> ] bi + 3array concat md5-checksum ; inline + +: build-auth-query ( -- query-assoc ) + { "authenticate" 1 } + "user" mdb-instance username>> 2array + "nonce" get-nonce 2array + 3array >hashtable + [ [ "nonce" ] dip at calculate-key-digest "key" ] keep + [ set-at ] keep ; inline + +: perform-authentication ( -- ) + cmd-collection build-auth-query send-query-1result + dup check-ok [ drop ] [ [ "errmsg" ] dip at throw ] if ; inline + +: authenticate-connection ( mdb-connection -- ) + [ mdb-connection get instance>> auth? + [ perform-authentication ] when + ] with-connection ; inline + +: open-connection ( mdb-connection node -- mdb-connection ) + [ >>node ] [ address>> ] bi + [ >>remote ] keep binary + [ >>handle ] dip >>local ; + +: get-ismaster ( -- result ) + "admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ; : split-host-str ( hoststr -- host port ) - ":" split [ first ] keep - second string>number ; inline + ":" split [ first ] [ second string>number ] bi ; inline -: eval-ismaster-result ( node result -- node result ) - [ [ "ismaster" ] dip at - >fixnum 1 = - [ t >>master? ] [ f >>master? ] if ] keep ; +: eval-ismaster-result ( node result -- ) + [ [ "ismaster" ] dip at >integer 1 = >>master? drop ] + [ [ "remote" ] dip at + [ split-host-str f >>remote ] when* + drop ] 2bi ; -: check-node ( node -- node remote ) - dup inet>> ismaster-cmd - eval-ismaster-result - [ "remote" ] dip at ; +: check-node ( mdb node -- ) + [ &dispose ] dip + [ open-connection ] keep swap + [ get-ismaster eval-ismaster-result ] with-connection ; +: nodelist>table ( seq -- assoc ) + [ [ master?>> ] keep 2array ] map >hashtable ; + PRIVATE> -: check-nodes ( node -- nodelist ) - check-node - [ V{ } clone [ push ] keep ] dip - [ split-host-str [ f ] dip - mdb-node boa check-node drop - swap tuck push - ] when* ; - -: verify-nodes ( -- ) - mdb-instance nodes>> [ t ] dip at - check-nodes - H{ } clone tuck - '[ dup master?>> _ set-at ] each - [ mdb-instance ] dip >>nodes drop ; - -: mdb-open ( mdb -- connection ) - mdb-connection new swap - [ >>instance ] keep - master-node [ >>remote ] keep - binary [ >>handle ] dip >>local ; inline +:: verify-nodes ( mdb -- ) + [ [let* | acc [ V{ } clone ] + node1 [ mdb dup master-node [ check-node ] keep ] + node2 [ mdb node1 remote>> + [ [ check-node ] keep ] + [ drop f ] if* ] + | node1 [ acc push ] when* + node2 [ acc push ] when* + mdb acc nodelist>table >>nodes drop + ] + ] with-destructors ; + +: mdb-open ( mdb -- mdb-connection ) + clone [ ] keep + master-node open-connection + [ authenticate-connection ] keep ; inline : mdb-close ( mdb-connection -- ) [ dispose f ] change-handle drop ; diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 9f445d71a9..3c61c8e4f0 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -6,7 +6,7 @@ parser prettyprint sequences sets splitting strings uuid arrays ; IN: mongodb.driver -TUPLE: mdb-pool < pool { mdb mdb-db } ; +TUPLE: mdb-pool < pool mdb ; TUPLE: mdb-cursor collection id return# ; @@ -37,9 +37,6 @@ ERROR: mdb-error id msg ; CONSTRUCTOR: mdb-cursor ( id collection return# -- cursor ) ; -: check-ok ( result -- ? ) - [ "ok" ] dip key? ; inline - : >mdbregexp ( value -- regexp ) first ; inline @@ -49,8 +46,7 @@ SYNTAX: r/ ( token -- mdbregexp ) \ / [ >mdbregexp ] parse-literal ; : with-db ( mdb quot -- ... ) - swap [ mdb-open &dispose >mdb-connection ] curry - prepose with-destructors ; inline + '[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline : build-id-selector ( assoc -- selector ) [ MDB_OID_FIELD swap at ] keep @@ -58,25 +54,6 @@ SYNTAX: r/ ( token -- mdbregexp ) > "%s.system.indexes" sprintf ; inline - -: namespaces-collection ( -- ns ) - mdb-instance name>> "%s.system.namespaces" sprintf ; inline - -: cmd-collection ( -- ns ) - mdb-instance name>> "%s.$cmd" sprintf ; inline - -: index-ns ( colname -- index-ns ) - [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline - -: send-message ( message -- ) - [ mdb-connection> handle>> ] dip '[ _ write-message ] with-stream* ; - -: send-query-plain ( query-message -- result ) - [ mdb-connection> handle>> ] dip - '[ _ write-message read-message ] with-stream* ; - : make-cursor ( mdb-result-msg -- cursor/f ) dup cursor>> 0 > [ [ cursor>> ] [ collection>> ] [ requested#>> ] tri ] @@ -91,9 +68,9 @@ SYNTAX: r/ ( token -- mdbregexp ) PRIVATE> : ( db host port -- mdb ) - f - check-nodes [ [ master?>> ] keep 2array ] map - >hashtable () ; + t [ ] keep + H{ } clone [ set-at ] keep + [ verify-nodes ] keep ; GENERIC: create-collection ( name -- ) M: string create-collection @@ -123,7 +100,10 @@ M: mdb-collection create-collection ( mdb-collection -- ) [ ";$." intersect length 0 > ] keep '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline +USE: tools.continuations + : (ensure-collection) ( collection -- ) + break mdb-instance collections>> dup keys length 0 = [ load-collection-list [ [ "options" ] dip key? ] filter @@ -240,8 +220,8 @@ M: assoc ensure-index H{ } clone [ [ "index" ] dip set-at ] keep [ [ "deleteIndexes" ] dip set-at ] keep - [ cmd-collection ] dip find-one - check-ok [ "could not drop index" throw ] unless ; + [ cmd-collection ] dip + find-one drop ; : ( collection selector object -- update-msg ) [ ensure-collection ] 2dip ; @@ -274,5 +254,8 @@ M: assoc delete-unsafe : drop-collection ( name -- ) [ cmd-collection ] dip "drop" H{ } clone [ set-at ] keep - find-one check-ok - [ "could not drop collection" throw ] unless ; + find-one drop ; + +: >pwd-digest ( user password -- digest ) + "mongo" swap 3array ":" join md5-checksum ; + diff --git a/mongodb/tuple/collection/collection.factor b/mongodb/tuple/collection/collection.factor index 6b1371eaf1..a4f86cd6a3 100644 --- a/mongodb/tuple/collection/collection.factor +++ b/mongodb/tuple/collection/collection.factor @@ -1,7 +1,7 @@ USING: accessors arrays assocs bson.constants classes classes.tuple combinators continuations fry kernel mongodb.driver sequences strings -vectors words combinators.smart ; +vectors words combinators.smart literals ; IN: mongodb.tuple @@ -50,7 +50,7 @@ CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map" PRIVATE> : MDB_ADDON_SLOTS ( -- slots ) - [ MDB_OID_FIELD MDB_META_FIELD ] output>array ; inline + { $[ MDB_OID_FIELD MDB_META_FIELD ] } ; inline : link-class ( collection class -- ) over classes>> diff --git a/mongodb/tuple/state/state.factor b/mongodb/tuple/state/state.factor index 955f66c6ce..21923637e5 100644 --- a/mongodb/tuple/state/state.factor +++ b/mongodb/tuple/state/state.factor @@ -1,5 +1,5 @@ USING: classes kernel accessors sequences fry assocs mongodb.tuple.collection -advice words classes.tuple slots generic ; +words classes.tuple slots generic ; IN: mongodb.tuple.state @@ -50,19 +50,3 @@ SYMBOL: mdb-dirty-handling? : needs-store? ( tuple -- ? ) [ persistent? not ] [ dirty? ] bi or ; - - -: annotate-writers ( class -- ) - dup all-slots [ name>> ] map - MDB_ADDON_SLOTS '[ _ memq? not ] filter - [ (annotate-writer) ] with each ; \ No newline at end of file From cd91b2e755cc42649f7837078c4df81eb8368eb6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 10:46:50 -0500 Subject: [PATCH 468/772] tools.errors: fix printing of errors with no associated source file --- basis/tools/errors/errors-tests.factor | 20 ++++++++++++++++++++ basis/tools/errors/errors.factor | 6 ++++-- basis/ui/tools/error-list/error-list.factor | 10 +++++----- 3 files changed, 29 insertions(+), 7 deletions(-) create mode 100644 basis/tools/errors/errors-tests.factor diff --git a/basis/tools/errors/errors-tests.factor b/basis/tools/errors/errors-tests.factor new file mode 100644 index 0000000000..a70aa32be8 --- /dev/null +++ b/basis/tools/errors/errors-tests.factor @@ -0,0 +1,20 @@ +USING: compiler.errors stack-checker.errors tools.test words ; +IN: tools.errors + +DEFER: blah + +[ ] [ + { + T{ compiler-error + { error + T{ inference-error + f + T{ do-not-compile f blah } + +compiler-error+ + blah + } + } + { asset blah } + } + } errors. +] unit-test \ No newline at end of file diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor index 422e08f020..ae55e9a1da 100644 --- a/basis/tools/errors/errors.factor +++ b/basis/tools/errors/errors.factor @@ -14,9 +14,11 @@ M: source-file-error compute-restarts M: source-file-error error-help error>> error-help ; +CONSTANT: +listener-input+ "" + M: source-file-error summary [ - [ file>> [ % ": " % ] [ "" % ] if* ] + [ file>> [ % ": " % ] [ +listener-input+ % ] if* ] [ line#>> [ # ] when* ] bi ] "" make ; @@ -27,7 +29,7 @@ M: source-file-error error. : errors. ( errors -- ) group-by-source-file sort-errors [ - [ nl "==== " write print nl ] + [ nl "==== " write +listener-input+ or print nl ] [ [ nl ] [ error. ] interleave ] bi* ] assoc-each ; diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index 42863a8fd2..5a4fb7376a 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -4,14 +4,14 @@ USING: accessors arrays sequences sorting assocs colors.constants fry combinators combinators.smart combinators.short-circuit editors make memoize compiler.units fonts kernel io.pathnames prettyprint source-files.errors math.parser init math.order models models.arrow -models.arrow.smart models.search models.mapping models.delay debugger namespaces -summary locals ui ui.commands ui.gadgets ui.gadgets.panes +models.arrow.smart models.search models.mapping models.delay debugger +namespaces summary locals ui ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers ui.tools.inspector ui.gadgets.status-bar ui.operations ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs -ui.gadgets.labels ui.baseline-alignment ui.images -compiler.errors calendar ; +ui.gadgets.labels ui.baseline-alignment ui.images ui.tools.listener +compiler.errors calendar tools.errors ; IN: ui.tools.error-list CONSTANT: source-file-icon @@ -39,7 +39,7 @@ SINGLETON: source-file-renderer M: source-file-renderer row-columns drop first2 [ [ source-file-icon ] - [ "" or ] + [ +listener-input+ or ] [ length number>string ] tri* ] output>array ; From 367ec5de939d44ab6bf00d7c166cb3f1cb9f12f5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 11:54:59 -0500 Subject: [PATCH 469/772] newfx => unmaintained since it uses multi-methods --- {extra => unmaintained}/newfx/newfx.factor | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/newfx/newfx.factor (100%) diff --git a/extra/newfx/newfx.factor b/unmaintained/newfx/newfx.factor similarity index 100% rename from extra/newfx/newfx.factor rename to unmaintained/newfx/newfx.factor From 7f983f12d46ac9bafc82c089699d46cde6a56aa0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 22 Apr 2009 12:26:28 -0500 Subject: [PATCH 470/772] fix help lint failures, fix example in words --- basis/compiler/tree/builder/builder-docs.factor | 4 ++-- basis/tools/crossref/crossref-docs.factor | 4 ++-- core/words/words-docs.factor | 6 ++++-- 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/basis/compiler/tree/builder/builder-docs.factor b/basis/compiler/tree/builder/builder-docs.factor index 3fa576faf5..b7ee51834b 100644 --- a/basis/compiler/tree/builder/builder-docs.factor +++ b/basis/compiler/tree/builder/builder-docs.factor @@ -3,11 +3,11 @@ compiler.tree stack-checker.errors ; IN: compiler.tree.builder HELP: build-tree -{ $values { "quot/word" { $or quotation word } } { "nodes" "a sequence of nodes" } } +{ $values { "word/quot" { $or word quotation } } { "nodes" "a sequence of nodes" } } { $description "Attempts to construct tree SSA IR from a quotation." } { $notes "This is the first stage of the compiler." } { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; HELP: build-sub-tree -{ $values { "#call" #call } { "quot/word" { $or quotation word } } { "nodes" { $maybe "a sequence of nodes" } } } +{ $values { "#call" #call } { "word/quot" { $or word quotation } } { "nodes/f" { $maybe "a sequence of nodes" } } } { $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values from the call site. Outputs " { $link f } " if stack effect inference fails." } ; diff --git a/basis/tools/crossref/crossref-docs.factor b/basis/tools/crossref/crossref-docs.factor index 99d1257f31..9108777554 100644 --- a/basis/tools/crossref/crossref-docs.factor +++ b/basis/tools/crossref/crossref-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax words definitions prettyprint -tools.crossref.private math quotations assocs ; +tools.crossref.private math quotations assocs kernel ; IN: tools.crossref ARTICLE: "tools.crossref" "Definition cross referencing" @@ -51,7 +51,7 @@ HELP: usage. { $examples { $code "\\ reverse usage." } } ; HELP: quot-uses -{ $values { "quot" quotation } { "assoc" "an assoc with words as keys" } } +{ $values { "obj" object } { "assoc" "an assoc with words as keys" } } { $description "Outputs a set of words referenced by the quotation and any quotations it contains." } ; { usage usage. } related-words diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index c1b8c0c229..58cc3c4f49 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -160,11 +160,13 @@ ABOUT: "words" HELP: execute ( word -- ) { $values { "word" word } } -{ $description "Executes a word." } +{ $description "Executes a word. Words which call execute must be inlined in order to compile when called from other words." } { $examples - { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ;\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } + { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ; inline\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } } ; +{ execute POSTPONE: execute( } related-words + HELP: deferred { $class-description "The class of deferred words created by " { $link POSTPONE: DEFER: } "." } ; From 553de434bb4e17a7f6750eb6cfd10c3f52391be8 Mon Sep 17 00:00:00 2001 From: Maxim Savchenko Date: Wed, 22 Apr 2009 16:39:28 -0400 Subject: [PATCH 471/772] Cleaning out newfx references --- unmaintained/dns/dns.factor | 30 +++++++++++++++--------------- unmaintained/dns/misc/misc.factor | 6 +++--- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/unmaintained/dns/dns.factor b/unmaintained/dns/dns.factor index cf98154e7a..6d81f2a14b 100644 --- a/unmaintained/dns/dns.factor +++ b/unmaintained/dns/dns.factor @@ -6,7 +6,7 @@ USING: kernel byte-arrays combinators strings arrays sequences splitting io io.binary io.sockets io.encodings.binary accessors combinators.smart - newfx + assocs ; IN: dns @@ -148,8 +148,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ { [ name>> dn->ba ] - [ type>> type-table of uint16->ba ] - [ class>> class-table of uint16->ba ] + [ type>> type-table at uint16->ba ] + [ class>> class-table at uint16->ba ] } cleave ] output>array concat ; @@ -203,8 +203,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ { [ name>> dn->ba ] - [ type>> type-table of uint16->ba ] - [ class>> class-table of uint16->ba ] + [ type>> type-table at uint16->ba ] + [ class>> class-table at uint16->ba ] [ ttl>> uint32->ba ] [ [ type>> ] [ rdata>> ] bi rdata->ba @@ -219,13 +219,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ { [ qr>> 15 shift ] - [ opcode>> opcode-table of 11 shift ] + [ opcode>> opcode-table at 11 shift ] [ aa>> 10 shift ] [ tc>> 9 shift ] [ rd>> 8 shift ] [ ra>> 7 shift ] [ z>> 4 shift ] - [ rcode>> rcode-table of 0 shift ] + [ rcode>> rcode-table at 0 shift ] } cleave ] sum-outputs uint16->ba ; @@ -301,8 +301,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ get-name ] [ skip-name - [ 0 + get-double type-table key-of ] - [ 2 + get-double class-table key-of ] + [ 0 + get-double type-table value-at ] + [ 2 + get-double class-table value-at ] 2bi ] 2bi query boa ; @@ -364,10 +364,10 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ skip-name { - [ 0 + get-double type-table key-of ] - [ 2 + get-double class-table key-of ] + [ 0 + get-double type-table value-at ] + [ 2 + get-double class-table value-at ] [ 4 + get-quad ] - [ [ 10 + ] [ get-double type-table key-of ] 2bi get-rdata ] + [ [ 10 + ] [ get-double type-table value-at ] 2bi get-rdata ] } 2cleave ] @@ -393,13 +393,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED get-double { [ 15 >> BIN: 1 bitand ] - [ 11 >> BIN: 111 bitand opcode-table key-of ] + [ 11 >> BIN: 111 bitand opcode-table value-at ] [ 10 >> BIN: 1 bitand ] [ 9 >> BIN: 1 bitand ] [ 8 >> BIN: 1 bitand ] [ 7 >> BIN: 1 bitand ] [ 4 >> BIN: 111 bitand ] - [ BIN: 1111 bitand rcode-table key-of ] + [ BIN: 1111 bitand rcode-table value-at ] } cleave ; @@ -484,7 +484,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: message-query ( message -- query ) question-section>> 1st ; +: message-query ( message -- query ) question-section>> first ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/unmaintained/dns/misc/misc.factor b/unmaintained/dns/misc/misc.factor index 6e62513a80..af080f61eb 100644 --- a/unmaintained/dns/misc/misc.factor +++ b/unmaintained/dns/misc/misc.factor @@ -1,6 +1,6 @@ USING: kernel combinators sequences splitting math - io.files io.encodings.utf8 random newfx dns.util ; + io.files io.encodings.utf8 random dns.util ; IN: dns.misc @@ -9,8 +9,8 @@ IN: dns.misc : resolv-conf-servers ( -- seq ) "/etc/resolv.conf" utf8 file-lines [ " " split ] map - [ 1st "nameserver" = ] filter - [ 2nd ] map ; + [ first "nameserver" = ] filter + [ second ] map ; : resolv-conf-server ( -- ip ) resolv-conf-servers random ; From 47fb13955c7e49c2ae2adaa38daed06c7c9b9c57 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 22 Apr 2009 16:18:15 -0500 Subject: [PATCH 472/772] move dns from unmaintained to extra for keyholder --- {unmaintained => extra}/dns/cache/nx/nx.factor | 0 {unmaintained => extra}/dns/cache/rr/rr.factor | 0 {unmaintained => extra}/dns/dns.factor | 0 {unmaintained => extra}/dns/forwarding/forwarding.factor | 0 {unmaintained => extra}/dns/misc/misc.factor | 0 {unmaintained => extra}/dns/resolver/resolver.factor | 0 {unmaintained => extra}/dns/server/server.factor | 6 +++--- {unmaintained => extra}/dns/stub/stub.factor | 0 {unmaintained => extra}/dns/util/util.factor | 0 9 files changed, 3 insertions(+), 3 deletions(-) rename {unmaintained => extra}/dns/cache/nx/nx.factor (100%) rename {unmaintained => extra}/dns/cache/rr/rr.factor (100%) rename {unmaintained => extra}/dns/dns.factor (100%) rename {unmaintained => extra}/dns/forwarding/forwarding.factor (100%) rename {unmaintained => extra}/dns/misc/misc.factor (100%) rename {unmaintained => extra}/dns/resolver/resolver.factor (100%) rename {unmaintained => extra}/dns/server/server.factor (97%) rename {unmaintained => extra}/dns/stub/stub.factor (100%) rename {unmaintained => extra}/dns/util/util.factor (100%) diff --git a/unmaintained/dns/cache/nx/nx.factor b/extra/dns/cache/nx/nx.factor similarity index 100% rename from unmaintained/dns/cache/nx/nx.factor rename to extra/dns/cache/nx/nx.factor diff --git a/unmaintained/dns/cache/rr/rr.factor b/extra/dns/cache/rr/rr.factor similarity index 100% rename from unmaintained/dns/cache/rr/rr.factor rename to extra/dns/cache/rr/rr.factor diff --git a/unmaintained/dns/dns.factor b/extra/dns/dns.factor similarity index 100% rename from unmaintained/dns/dns.factor rename to extra/dns/dns.factor diff --git a/unmaintained/dns/forwarding/forwarding.factor b/extra/dns/forwarding/forwarding.factor similarity index 100% rename from unmaintained/dns/forwarding/forwarding.factor rename to extra/dns/forwarding/forwarding.factor diff --git a/unmaintained/dns/misc/misc.factor b/extra/dns/misc/misc.factor similarity index 100% rename from unmaintained/dns/misc/misc.factor rename to extra/dns/misc/misc.factor diff --git a/unmaintained/dns/resolver/resolver.factor b/extra/dns/resolver/resolver.factor similarity index 100% rename from unmaintained/dns/resolver/resolver.factor rename to extra/dns/resolver/resolver.factor diff --git a/unmaintained/dns/server/server.factor b/extra/dns/server/server.factor similarity index 97% rename from unmaintained/dns/server/server.factor rename to extra/dns/server/server.factor index b14d765e8d..644533d3a2 100644 --- a/unmaintained/dns/server/server.factor +++ b/extra/dns/server/server.factor @@ -2,7 +2,7 @@ USING: kernel combinators sequences sets math threads namespaces continuations debugger io io.sockets unicode.case accessors destructors combinators.short-circuit combinators.smart - newfx fry arrays + fry arrays dns dns.util dns.misc ; IN: dns.server @@ -64,7 +64,7 @@ SYMBOL: records-var [ rr->rdata-names ] map concat ; : extract-names ( message -- names ) - [ message-query name>> ] [ extract-rdata-names ] bi prefix-on ; + [ message-query name>> ] [ extract-rdata-names ] bi swap prefix ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! fill-authority @@ -99,7 +99,7 @@ DEFER: query->rrs : matching-cname? ( query -- rrs/f ) [ ] [ clone CNAME >>type matching-rrs ] bi ! query rrs [ empty? not ] - [ 1st swap clone over rdata>> >>name query->rrs prefix-on ] + [ first swap clone over rdata>> >>name query->rrs swap prefix ] [ 2drop f ] 1if ; diff --git a/unmaintained/dns/stub/stub.factor b/extra/dns/stub/stub.factor similarity index 100% rename from unmaintained/dns/stub/stub.factor rename to extra/dns/stub/stub.factor diff --git a/unmaintained/dns/util/util.factor b/extra/dns/util/util.factor similarity index 100% rename from unmaintained/dns/util/util.factor rename to extra/dns/util/util.factor From 47064cd1af6c1ddc6448928acea86f371e293840 Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Wed, 22 Apr 2009 15:40:17 -0700 Subject: [PATCH 473/772] Fix stack effect of fuel-use-suggested-vocabs --- extra/fuel/fuel.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 12eb5bdbfc..a9ed17877e 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -54,7 +54,7 @@ SYMBOL: :uses-suggestions PRIVATE> -: fuel-use-suggested-vocabs ( suggestions quot ... suggestions quot: ( ... -- ... ) -- ... ) +: fuel-use-suggested-vocabs ( suggestions quot -- ... ) [ :uses-suggestions set ] dip [ try-suggested-restarts rethrow ] recover ; inline From 24d854fb8e9fdf519ae475e88fadc4937b5516c6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 19:35:51 -0500 Subject: [PATCH 474/772] inverse: [ \ + ] fold was incorrectly evaluating to [ + ] --- basis/inverse/inverse-tests.factor | 6 ++++++ basis/inverse/inverse.factor | 8 ++++---- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/basis/inverse/inverse-tests.factor b/basis/inverse/inverse-tests.factor index 9d81992eae..75e1198658 100644 --- a/basis/inverse/inverse-tests.factor +++ b/basis/inverse/inverse-tests.factor @@ -83,3 +83,9 @@ C: nil [ [ sqrt ] ] [ [ sq ] [undo] ] unit-test [ [ not ] ] [ [ not ] [undo] ] unit-test [ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] undo ] unit-test + +TUPLE: funny-tuple ; +: ( -- funny-tuple ) \ funny-tuple boa ; +: funny-tuple ( -- ) "OOPS" throw ; + +[ ] [ [ ] [undo] drop ] unit-test \ No newline at end of file diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index 3a86703caf..a988063293 100755 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -74,7 +74,9 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; : fold-word ( stack word -- stack ) 2dup enough? - [ 1quotation with-datastack ] [ [ % ] [ , ] bi* { } ] if ; + [ 1quotation with-datastack ] + [ [ [ literalize , ] each ] [ , ] bi* { } ] + if ; : fold ( quot -- folded-quot ) [ { } [ fold-word ] reduce % ] [ ] make ; @@ -217,9 +219,7 @@ DEFER: _ "predicate" word-prop [ dupd call assure ] curry ; : slot-readers ( class -- quot ) - all-slots - [ name>> reader-word 1quotation [ keep ] curry ] map concat - [ ] like [ drop ] compose ; + all-slots [ name>> reader-word 1quotation ] map [ cleave ] curry ; : ?wrapped ( object -- wrapped ) dup wrapper? [ wrapped>> ] when ; From c9defa64944b0a2c4b784d14254eb2b2eb0ea2eb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 19:36:01 -0500 Subject: [PATCH 475/772] Make FORGET: M\ ... work --- core/definitions/definitions.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 5dc3808362..6f9fdaecf5 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences namespaces assocs math ; +USING: kernel sequences namespaces assocs math accessors ; IN: definitions MIXIN: definition @@ -41,6 +41,8 @@ GENERIC: forget* ( defspec -- ) M: f forget* drop ; +M: wrapper forget* wrapped>> forget* ; + SYMBOL: forgotten-definitions : forgotten-definition ( defspec -- ) From 1dd3ed519f476c3a5fe7ee8e1fdfad5e2b27951b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 21:03:53 -0500 Subject: [PATCH 476/772] Revert part of an earlier ccompiler.tree.checker hange to fix smalltalk.eval regression --- basis/compiler/tree/checker/checker.factor | 12 ++++----- .../compiler/tree/optimizer/optimizer.factor | 1 - basis/stack-checker/backend/backend.factor | 27 ++++++++----------- .../stack-checker/stack-checker-tests.factor | 6 +++-- basis/stack-checker/state/state.factor | 1 - 5 files changed, 20 insertions(+), 27 deletions(-) diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index 718def367d..e25f152aef 100755 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -144,15 +144,13 @@ M: #terminate check-stack-flow* SYMBOL: branch-out -: check-branch ( nodes -- datastack ) +: check-branch ( nodes -- stack ) [ datastack [ clone ] change - retainstack [ clone ] change - retainstack get clone [ (check-stack-flow) ] dip - terminated? get [ drop f ] [ - retainstack get assert= - datastack get - ] if + V{ } clone retainstack set + (check-stack-flow) + terminated? get [ assert-retainstack-empty ] unless + terminated? get f datastack get ? ] with-scope ; M: #branch check-stack-flow* diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index daa8f072ca..fe3c7acb92 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -29,7 +29,6 @@ SYMBOL: check-optimizer? normalize propagate cleanup - ?check dup run-escape-analysis? [ escape-analysis unbox-tuples diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 182de28cd9..4fb5bab96f 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -84,8 +84,11 @@ M: object apply-object push-literal ; meta-r empty? [ too-many->r ] unless ; : infer-quot-here ( quot -- ) - [ apply-object terminated? get not ] all? - [ commit-literals ] [ literals get delete-all ] if ; + meta-r [ + V{ } clone \ meta-r set + [ apply-object terminated? get not ] all? + [ commit-literals check->r ] [ literals get delete-all ] if + ] dip \ meta-r set ; : infer-quot ( quot rstate -- ) recursive-state get [ @@ -113,33 +116,25 @@ M: object apply-object push-literal ; ] if ; : infer->r ( n -- ) - terminated? get [ drop ] [ - consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi - ] if ; + consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ; : infer-r> ( n -- ) - terminated? get [ drop ] [ - consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi - ] if ; - -: (consume/produce) ( effect -- inputs outputs ) - [ in>> length consume-d ] [ out>> length produce-d ] bi ; + consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ; : consume/produce ( effect quot: ( inputs outputs -- ) -- ) - '[ (consume/produce) @ ] + '[ [ in>> length consume-d ] [ out>> length produce-d ] bi @ ] [ terminated?>> [ terminate ] when ] bi ; inline +: apply-word/effect ( word effect -- ) + swap '[ _ #call, ] consume/produce ; + : end-infer ( -- ) - terminated? get [ check->r ] unless meta-d clone #return, ; : required-stack-effect ( word -- effect ) dup stack-effect [ ] [ missing-effect ] ?if ; -: apply-word/effect ( word effect -- ) - swap '[ _ #call, ] consume/produce ; - : infer-word ( word -- ) { { [ dup macro? ] [ do-not-compile ] } diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 9f5d0a2213..919cd098f6 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -299,7 +299,7 @@ ERROR: custom-error ; [ custom-error inference-error ] infer ] unit-test -[ T{ effect f 1 1 t } ] [ +[ T{ effect f 1 2 t } ] [ [ dup [ 3 throw ] dip ] infer ] unit-test @@ -369,4 +369,6 @@ DEFER: eee' [ [ cond ] infer ] must-fail [ [ bi ] infer ] must-fail -[ at ] must-infer \ No newline at end of file +[ at ] must-infer + +[ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer \ No newline at end of file diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 9b87854b69..a76d302a7e 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -42,7 +42,6 @@ SYMBOL: literals : init-inference ( -- ) terminated? off V{ } clone \ meta-d set - V{ } clone \ meta-r set V{ } clone literals set 0 d-in set ; From 8432c30ed144f217fad6a84960c66479e384b08d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 21:20:36 -0500 Subject: [PATCH 477/772] Fix docs --- core/kernel/kernel-docs.factor | 4 +++- core/syntax/syntax-docs.factor | 9 ++++++++- core/words/words-docs.factor | 2 +- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 36d04f1437..371edcf995 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -182,12 +182,14 @@ HELP: either? HELP: call { $values { "callable" callable } } -{ $description "Calls a quotation." } +{ $description "Calls a quotation. Words which " { $link call } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal quotation can have a static stack effect." } { $examples "The following two lines are equivalent:" { $code "2 [ 2 + 3 * ] call" "2 2 + 3 *" } } ; +{ call POSTPONE: call( } related-words + HELP: call-clear ( quot -- ) { $values { "quot" callable } } { $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." } diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 73335e09cf..a0e1d280d5 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -791,7 +791,14 @@ HELP: call-next-method HELP: call( { $syntax "call( stack -- effect )" } -{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ; +{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } +{ $examples + { $code + "TUPLE: action name quot ;" + ": perform-action ( action -- )" + " [ name>> print ] [ quot>> call( -- ) ] bi ;" + } +} ; HELP: execute( { $syntax "execute( stack -- effect )" } diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 58cc3c4f49..9cc1f5b2b9 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -160,7 +160,7 @@ ABOUT: "words" HELP: execute ( word -- ) { $values { "word" word } } -{ $description "Executes a word. Words which call execute must be inlined in order to compile when called from other words." } +{ $description "Executes a word. Words which " { $link execute } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal word can have a static stack effect." } { $examples { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ; inline\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } } ; From d3cffcbee28302c0399dfc75bce7e7a4ea5d394a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 21:26:22 -0500 Subject: [PATCH 478/772] Slightly more efficient compilation of 'new' --- basis/stack-checker/transforms/transforms.factor | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 2e66d7d728..955399b00b 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -113,11 +113,9 @@ M\ tuple-class boa t "no-compile" set-word-prop \ new [ dup tuple-class? [ dup inlined-dependency depends-on - [ - [ all-slots [ initial>> literalize , ] each ] - [ literalize , ] bi - \ boa , - ] [ ] make + [ all-slots [ initial>> literalize ] map ] + [ tuple-layout '[ _ ] ] + bi append ] [ drop f ] if ] 1 define-transform From 57e1de5181abe41d33deead3e819d04b573bb0de Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 21:26:55 -0500 Subject: [PATCH 479/772] stack-checker.transforms doesn't need make anymore --- basis/stack-checker/transforms/transforms.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 955399b00b..cd8a57bf2e 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors arrays kernel kernel.private combinators.private -words sequences generic math math.order namespaces make quotations +words sequences generic math math.order namespaces quotations assocs combinators combinators.short-circuit classes.tuple classes.tuple.private effects summary hashtables classes generic sets definitions generic.standard slots.private continuations locals From c2fe2a4feab2a25849672e90e3bdb8f8485c502d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Apr 2009 03:48:32 -0500 Subject: [PATCH 480/772] Improve stack checker documentation --- basis/combinators/smart/smart-docs.factor | 7 +- basis/compiler/compiler-docs.factor | 4 +- basis/help/cookbook/cookbook.factor | 69 +-------- basis/help/handbook/handbook.factor | 17 ++- basis/io/mmap/mmap-docs.factor | 11 +- basis/io/sockets/sockets-docs.factor | 11 ++ basis/math/matrices/matrices.factor | 19 ++- basis/memoize/memoize-docs.factor | 14 ++ basis/stack-checker/errors/errors-docs.factor | 34 +++-- basis/stack-checker/stack-checker-docs.factor | 133 +++++++++++------- basis/threads/threads-docs.factor | 2 +- basis/tools/errors/errors-docs.factor | 6 +- core/combinators/combinators-docs.factor | 40 +++--- core/continuations/continuations-docs.factor | 4 +- core/effects/effects-docs.factor | 40 ++---- core/generic/generic-docs.factor | 2 +- core/io/files/files-docs.factor | 13 ++ core/io/io-docs.factor | 20 ++- core/syntax/syntax-docs.factor | 12 +- core/words/words-docs.factor | 63 +++++---- 20 files changed, 286 insertions(+), 235 deletions(-) diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor index 679b587759..d8ee89ef2d 100644 --- a/basis/combinators/smart/smart-docs.factor +++ b/basis/combinators/smart/smart-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel quotations math sequences -multiline ; +multiline stack-checker ; IN: combinators.smart HELP: inputnumber ;" - ": print-age ( n -- )" - " \"You are \" write" - " number>string write" - " \" years old.\" print ;" - ": example ( -- ) ask-age read-age print-age ;" - "example" -} -"Print the lines of a file in sorted order:" -{ $code - "USING: io io.encodings.utf8 io.files sequences sorting ;" - "\"lines.txt\" utf8 file-lines natural-sort [ print ] each" -} -"Read 1024 bytes from a file:" -{ $code - "USING: io io.encodings.binary io.files ;" - "\"data.bin\" binary [ 1024 read ] with-file-reader" -} -"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:" -{ $code - "USING: accessors grouping io.files io.mmap.char kernel sequences ;" - "\"mydata.dat\" [" - " 4 [ reverse-here ] change-each" - "] with-mapped-char-file" -} -"Send some bytes to a remote host:" -{ $code - "USING: io io.encodings.ascii io.sockets strings ;" - "\"myhost\" 1033 ascii" - "[ B{ 12 17 102 } write ] with-client" -} -{ $references - { } - "number-strings" - "io" -} ; - ARTICLE: "cookbook-application" "Application cookbook" "Vocabularies can define a main entry point:" { $code "IN: game-of-life" "..." -": play-life ... ;" +": play-life ( -- ) ... ;" "" "MAIN: play-life" } @@ -318,7 +267,6 @@ $nl { "Use " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " instead of " { $link "shuffle-words" } " to give your code more structure." } { "Not everything has to go on the stack. The " { $vocab-link "namespaces" } " vocabulary provides dynamically-scoped variables, and the " { $vocab-link "locals" } " vocabulary provides lexically-scoped variables. Learn both and use them where they make sense, but keep in mind that overuse of variables makes code harder to factor." } "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. 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 } "." } @@ -332,6 +280,7 @@ $nl "Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such manual memory management, pointer arithmetic, and inline assembly code." $nl "Unsafe features are tucked away so that you will not invoke them by accident, or have to use them to solve conventional programming problems. However when the need arises, unsafe features are invaluable, for example you might have to do some pointer arithmetic when interfacing directly with C libraries." ; + ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid" "Factor is a very clean and consistent language. However, it has some limitations and leaky abstractions you should keep in mind, as well as behaviors which differ from other languages you may be used to." { $list @@ -341,13 +290,6 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid" { "If a literal object appears in a word definition, the object itself is pushed on the stack when the word executes, not a copy. If you intend to mutate this object, you must " { $link clone } " it first. See " { $link "syntax-literals" } "." } { "For a discussion of potential issues surrounding the " { $link f } " object, see " { $link "booleans" } "." } { "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by “multiple inheritance” in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." } - { "Performance-sensitive code should have a static stack effect so that it can be compiled by the optimizing word compiler, which generates more efficient code than the non-optimizing quotation compiler. See " { $link "inference" } " and " { $link "compiler" } "." - $nl - "This means that methods defined on performance sensitive, frequently-called core generic words such as " { $link nth } " should have static stack effects which are consistent with each other, since a generic word will only have a static stack effect if all methods do." - $nl - "Unit tests for the " { $vocab-link "stack-checker" } " vocabulary can be used to ensure that any methods your vocabulary defines on core generic words have static stack effects:" - { $code "\"stack-checker\" test" } - "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." } } ; @@ -372,7 +314,6 @@ ARTICLE: "cookbook" "Factor cookbook" { $subsection "cookbook-combinators" } { $subsection "cookbook-variables" } { $subsection "cookbook-vocabs" } -{ $subsection "cookbook-io" } { $subsection "cookbook-application" } { $subsection "cookbook-scripts" } { $subsection "cookbook-philosophy" } diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index a97a46badc..262c46bbc3 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -39,7 +39,7 @@ $nl { { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } } } { $heading "Stack effect conventions" } -"Stack effect conventions are documented in " { $link "effect-declaration" } "." +"Stack effect conventions are documented in " { $link "effects" } "." { $heading "Glossary of terms" } "Common terminology and abbreviations used throughout Factor and its documentation:" { $table @@ -229,9 +229,11 @@ ARTICLE: "handbook-language-reference" "The language" { $heading "Fundamentals" } { $subsection "conventions" } { $subsection "syntax" } -{ $subsection "effects" } +{ $heading "The stack" } { $subsection "evaluator" } -{ $heading "Data types" } +{ $subsection "effects" } +{ $subsection "inference" } +{ $heading "Basic data types" } { $subsection "booleans" } { $subsection "numbers" } { $subsection "collections" } @@ -239,16 +241,18 @@ ARTICLE: "handbook-language-reference" "The language" { $subsection "words" } { $subsection "shuffle-words" } { $subsection "combinators" } -{ $subsection "errors" } -{ $subsection "continuations" } +{ $subsection "threads" } { $heading "Named values" } { $subsection "locals" } { $subsection "namespaces" } { $subsection "namespaces-global" } { $subsection "values" } { $heading "Abstractions" } +{ $subsection "errors" } { $subsection "objects" } { $subsection "destructors" } +{ $subsection "continuations" } +{ $subsection "memoize" } { $subsection "parsing-words" } { $subsection "macros" } { $subsection "fry" } @@ -263,6 +267,7 @@ ARTICLE: "handbook-system-reference" "The implementation" { $subsection "vocabularies" } { $subsection "source-files" } { $subsection "compiler" } +{ $subsection "tools.errors" } { $heading "Virtual machine" } { $subsection "images" } { $subsection "cli" } @@ -283,7 +288,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools" { $subsection "prettyprint" } { $subsection "inspector" } { $subsection "tools.annotations" } -{ $subsection "inference" } +{ $subsection "tools.inference" } { $heading "Browsing" } { $subsection "see" } { $subsection "tools.crossref" } diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index 5ef3400a6d..f0adb47321 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -54,11 +54,20 @@ ARTICLE: "io.mmap.arrays" "Memory-mapped arrays" ARTICLE: "io.mmap.low-level" "Reading and writing mapped files directly" "Data can be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. See " { $link "reading-writing-memory" } "." ; +ARTICLE: "io.mmap.examples" "Memory-mapped file example" +"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:" +{ $code + "USING: accessors grouping io.files io.mmap.char kernel sequences ;" + "\"mydata.dat\" [" + " 4 [ reverse-here ] change-each" + "] with-mapped-char-file" +} ; + ARTICLE: "io.mmap" "Memory-mapped files" "The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files." { $subsection } "Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "." -$nl +{ $subsection "io.mmap.examples" } "A utility combinator which wraps the above:" { $subsection with-mapped-file } "Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:" diff --git a/basis/io/sockets/sockets-docs.factor b/basis/io/sockets/sockets-docs.factor index a66ed1d0c0..970aa34ea6 100644 --- a/basis/io/sockets/sockets-docs.factor +++ b/basis/io/sockets/sockets-docs.factor @@ -56,12 +56,23 @@ $nl } "The " { $link inet } " address specifier is not supported by the " { $link send } " word because a single host name can resolve to any number of IPv4 or IPv6 addresses, therefore there is no way to know which address should be used. Applications should call " { $link resolve-host } " then use some kind of strategy to pick the correct address (for example, by sending a packet to each one and waiting for a response, or always assuming IPv4)." ; +ARTICLE: "network-examples" "Networking examples" +"Send some bytes to a remote host:" +{ $code + "USING: io io.encodings.ascii io.sockets strings ;" + "\"myhost\" 1033 ascii" + "[ B{ 12 17 102 } write ] with-client" +} +"Look up the IP addresses associated with a host name:" +{ $code "USING: io.sockets ;" "\"www.apple.com\" 80 resolve-host ." } ; + ARTICLE: "network-streams" "Networking" "Factor supports connection-oriented and packet-oriented communication over a variety of protocols:" { $list "TCP/IP and UDP/IP, over IPv4 and IPv6" "Unix domain sockets (Unix only)" } +{ $subsection "network-examples" } { $subsection "network-addressing" } { $subsection "network-connection" } { $subsection "network-packet" } diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index 7c687d753d..4c2c641c84 100755 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.order math.vectors sequences ; +USING: arrays kernel math math.order math.vectors +sequences sequences.private accessors columns ; IN: math.matrices ! Matrices @@ -24,9 +25,19 @@ IN: math.matrices : m* ( m m -- m ) [ v* ] 2map ; : m/ ( m m -- m ) [ v/ ] 2map ; -: v.m ( v m -- v ) flip [ v. ] with map ; -: m.v ( m v -- v ) [ v. ] curry map ; -: m. ( m m -- m ) flip [ swap m.v ] curry map ; +TUPLE: flipped { seq read-only } ; + +M: flipped length seq>> first length ; + +M: flipped nth-unsafe seq>> swap ; + +INSTANCE: flipped sequence + +C: flipped + +: v.m ( v m -- v ) [ v. ] with map ; +: m.v ( m v -- v ) [ v. ] curry map ; inline +: m. ( m m -- m ) [ swap m.v ] curry map ; : mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ; : mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ; diff --git a/basis/memoize/memoize-docs.factor b/basis/memoize/memoize-docs.factor index cfb5cffb37..a551272f43 100644 --- a/basis/memoize/memoize-docs.factor +++ b/basis/memoize/memoize-docs.factor @@ -3,6 +3,20 @@ USING: help.syntax help.markup words quotations effects ; IN: memoize +ARTICLE: "memoize" "Memoization" +"The " { $vocab-link "memoize" } " vocabulary implements a simple form of memoization, which is when a word caches results for every unique set of inputs that is supplied. Calling a memoized word with the same inputs more than once does not recalculate anything." +$nl +"Memoization is useful in situations where the set of possible inputs is small, but the results are expensive to compute and should be cached. Memoized words should not have any side effects." +$nl +"Defining a memoized word at parse time:" +{ $subsection POSTPONE: MEMO: } +"Defining a memoized word at run time:" +{ $subsection define-memoized } +"Clearing memoized results:" +{ $subsection reset-memoized } ; + +ABOUT: "memoize" + HELP: define-memoized { $values { "word" word } { "quot" quotation } { "effect" effect } } { $description "defines the given word at runtime as one which memoizes its output given a particular input" } diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor index 5b314a3154..3c36d95d1e 100644 --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -3,10 +3,9 @@ sequences.private words ; IN: stack-checker.errors 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 if the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } +{ $error-description "Thrown when inference encounters a combinator or macro being applied to a value which is not known to be a literal, or constructed in a manner which can be analyzed statically. Such code needs changes before it can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." } { $examples - "In this example, words calling " { $snippet "literal-expected-example" } " will compile, even if " { $snippet "literal-expected-example" } " does not compile itself:" + "In this example, words calling " { $snippet "literal-expected-example" } " will have a static stac keffect, even if " { $snippet "literal-expected-example" } " does not:" { $code ": literal-expected-example ( quot -- )" " [ call ] [ call ] bi ; inline" @@ -16,10 +15,8 @@ HELP: literal-expected HELP: unbalanced-branches-error { $values { "in" "a sequence of integers" } { "out" "a sequence of integers" } } { $description "Throws an " { $link unbalanced-branches-error } "." } -{ $error-description "Thrown when inference encounters an " { $link if } " or " { $link dispatch } " where the branches do not all exit with the same stack height." } -{ $notes "Conditionals with variable stack effects are considered to be bad style and should be avoided since they do not compile." -$nl -"If this error comes up when inferring the stack effect of a recursive word, check the word's stack effect declaration; it might be wrong." } +{ $error-description "Thrown when inference encounters an " { $link if } " or " { $link dispatch } " where the branches do not all exit with the same stack height. See " { $link "inference-branches" } " for details." } +{ $notes "If this error comes up when inferring the stack effect of a recursive word, check the word's stack effect declaration; it might be wrong." } { $examples { $code ": unbalanced-branches-example ( a b c -- )" @@ -86,25 +83,26 @@ HELP: inconsistent-recursive-call-error } } ; -ARTICLE: "inference-errors" "Inference warnings and errors" +ARTICLE: "inference-errors" "Stack checker errors" "These conditions are thrown by " { $link "inference" } ", as well as the " { $link "compiler" } "." $nl -"Main wrapper for all inference warnings and errors:" -{ $subsection inference-error } -"Inference warnings:" +"Error thrown when insufficient information is available to calculate the stack effect of a combinator call (see " { $link "inference-combinators" } "):" { $subsection literal-expected } -"Inference errors:" -{ $subsection recursive-quotation-error } -{ $subsection unbalanced-branches-error } +"Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:" { $subsection effect-error } -{ $subsection missing-effect } -"Inference errors for inline recursive words:" +"Error thrown when branches have incompatible stack effects (see " { $link "inference-branches" } "):" +{ $subsection unbalanced-branches-error } +"Inference errors for inline recursive words (see " { $link "inference-recursive-combinators" } "):" { $subsection undeclared-recursion-error } { $subsection diverging-recursion-error } { $subsection unbalanced-recursion-error } { $subsection inconsistent-recursive-call-error } -"Retain stack usage errors:" +"More obscure errors that are unlikely to arise in ordinary code:" +{ $subsection recursive-quotation-error } { $subsection too-many->r } -{ $subsection too-many-r> } ; +{ $subsection too-many-r> } +{ $subsection missing-effect } +"Main wrapper for all inference warnings and errors:" +{ $subsection inference-error } ; ABOUT: "inference-errors" diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 78196abfba..243221ccf0 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -4,38 +4,54 @@ stack-checker.backend stack-checker.branches stack-checker.errors stack-checker.transforms -stack-checker.state ; +stack-checker.state +continuations ; IN: stack-checker ARTICLE: "inference-simple" "Straight-line stack effects" -"The simplest case to look at is that of a quotation which does not have any branches or recursion, and just pushes literals and calls words, each of which has a known stack effect." +"The simplest case is when a piece of code does not have any branches or recursion, and just pushes literals and calls words." $nl -"Stack effect inference works by stepping through the quotation, while maintaining a \"shadow stack\" which tracks stack height at the current position in the quotation. Initially, the shadow stack is empty. If a word is encountered which expects more values than there are on the shadow stack, a global counter is incremented. This counter keeps track of the number of inputs the quotation expects on the stack. When inference is done, this counter, together with the final height of the shadow stack, gives the inferred stack effect." -{ $subsection d-in } -{ $subsection meta-d } -"When a literal is encountered, it is simply pushed on the shadow stack. For example, the stack effect of the following quotation is inferred by pushing all three literals on the shadow stack, then taking the value of " { $link d-in } " and the length of " { $link meta-d } ":" +"Pushing a literal has stack effect " { $snippet "( -- object )" } ". The stack effect of a most words is always known statically from the declaration. Stack effects of " { $link POSTPONE: inline } " words and " { $link "macros" } ", may depend on literals pushed on the stack prior to the call, and this case is discussed in " { $link "inference-combinators" } "." +$nl +"The stack effect of each element in a code snippet is composed. The result is then the stack effect of the snippet." +$nl +"An example:" { $example "[ 1 2 3 ] infer." "( -- object object object )" } -"In the following example, the call to " { $link + } " expects two values on the shadow stack, but only one value is present, the literal which was pushed previously. This increments the " { $link d-in } " counter by one:" -{ $example "[ 2 + ] infer." "( object -- object )" } -"After the call to " { $link + } ", the shadow stack contains a \"computed value placeholder\", since the inferencer has no way to know what the resulting value actually is (in fact it is arbitrary)." ; +"Another example:" +{ $example "[ 2 + ] infer." "( object -- object )" } ; ARTICLE: "inference-combinators" "Combinator stack effects" -"Without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the inferencer encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised." -{ $example "[ dup call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." } -"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point:" -{ $example "[ [ 2 + ] call ] infer." "( object -- object )" } -"Consider a combinator such as " { $link keep } ". The combinator itself does not have a stack effect, because it applies " { $link call } " to a potentially arbitrary quotation. However, since the combinator is declared " { $link POSTPONE: inline } ", a given usage of it can have a stack effect:" -{ $example "[ [ 2 + ] keep ] infer." "( object -- object object )" } -"Another example is the " { $link compose } " combinator. Because it is decared " { $link POSTPONE: inline } ", we can infer the stack effect of applying " { $link call } " to the result of " { $link compose } ":" -{ $example "[ 2 [ + ] curry [ sq ] compose ] infer." "( -- object )" } -"Incidentally, this example demonstrates that the stack effect of nested currying and composition can also be inferred." +"If a word, call it " { $snippet "W" } ", calls a combinator, one of the following two conditions must hold:" +{ $list + { "The combinator may be called with a quotation that is either a literal, or built from literals, " { $link curry } " and " { $link compose } "." } + { "The combinator must be called on an input parameter, or be built from input parameters, literals, " { $link curry } " and " { $link compose } ", " { $strong "if" } " the word " { $snippet "W" } " must be declared " { $link POSTPONE: inline } ". Then " { $snippet "W" } " is itself considered to be a combinator, and its callers must satisfy one of these two conditions." } +} +"If neither condition holds, the stack checker throws a " { $link literal-expected } " error, and an escape hatch such as " { $link POSTPONE: call( } " must be used instead. See " { $link "inference-escape" } " for details. An inline combinator can be called with an unknown quotation by currying the quotation onto a literal quotation that uses " { $link POSTPONE: call( } "." +{ $heading "Examples" } +{ $subheading "Calling a combinator" } +"The following usage of " { $link map } " passes the stack checker, because the quotation is the result of " { $link curry } ":" +{ $example "[ [ + ] curry map ] infer." "( object object -- object )" } +{ $subheading "Defining an inline combinator" } +"The following word calls a quotation twice; the word is declared " { $link POSTPONE: inline } ", since it invokes " { $link call } " on the result of " { $link compose } " on an input parameter:" +{ $code ": twice ( value quot -- result ) dup compose call ; inline" } +"The following code now passes the stack checker; it would fail were " { $snippet "twice" } " not declared " { $link POSTPONE: inline } ":" +{ $unchecked-example "USE: math.functions" "[ [ sqrt ] twice ] infer." "( object -- object )" } +{ $subheading "Defining a combinator for unknown quotations" } +"In the next example, " { $link POSTPONE: call( } " must be used because the quotation the result of calling a runtime accessor, and the compiler cannot make any static assumptions about this quotation at all:" +{ $code + "TUPLE: action name quot ;" + ": perform ( value action -- result ) quot>> call( value -- result ) ;" +} +{ $subheading "Passing an unknown quotation to an inline combinator" } +"Suppose we want to write :" +{ $code ": perform ( values action -- results ) quot>> map ;" } +"However this fails to pass the stack checker since there is no guarantee the quotation has the right stack effect for " { $link map } ". It can be wrapped in a new quotation with a declaration:" +{ $code ": perform ( values action -- results )" " quot>> [ call( value -- result ) ] curry map ;" } +{ $heading "Explanation" } +"This restriction exists because without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the stack checker encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised." $nl -"A general rule of thumb is that any word which applies " { $link call } " or " { $link curry } " to one of its inputs must be declared " { $link POSTPONE: inline } "." -$nl -"Here is an example where the stack effect cannot be inferred:" -{ $code ": foo ( -- n quot ) 0 [ + ] ;" "[ foo reduce ] infer." } -"However if " { $snippet "foo" } " was declared " { $link POSTPONE: inline } ", everything would work, since the " { $link reduce } " combinator is also " { $link POSTPONE: inline } ", and the inferencer can see the literal quotation value at the point it is passed to " { $link call } ":" -{ $example ": foo ( -- n quot ) 0 [ + ] ; inline" "[ foo reduce ] infer." "( object -- object )" } +"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point." +{ $heading "Limitations" } "Passing a literal quotation on the data stack through an inlined recursive combinator nullifies its literal status. For example, the following will not infer:" { $example "[ [ reverse ] swap [ reverse ] map swap call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." @@ -46,30 +62,25 @@ $nl } ; ARTICLE: "inference-branches" "Branch stack effects" -"Conditionals such as " { $link if } " and combinators built on " { $link if } " present a problem, in that if the two branches leave the stack at a different height, it is not clear what the stack effect should be. In this case, inference throws a " { $link unbalanced-branches-error } "." +"Conditionals such as " { $link if } " and combinators built on top have the same restrictions as " { $link POSTPONE: inline } " combinators (see " { $link "inference-combinators" } ") with the additional requirement that all branches leave the stack at the same height. If this is not the case, the stack checker throws a " { $link unbalanced-branches-error } "." $nl "If all branches leave the stack at the same height, then the stack effect of the conditional is just the maximum of the stack effect of each branch. For example," { $example "[ [ + ] [ drop ] if ] infer." "( object object object -- object )" } "The call to " { $link if } " takes one value from the stack, a generalized boolean. The first branch " { $snippet "[ + ]" } " has stack effect " { $snippet "( x x -- x )" } " and the second has stack effect " { $snippet "( x -- )" } ". Since both branches decrease the height of the stack by one, we say that the stack effect of the two branches is " { $snippet "( x x -- x )" } ", and together with the boolean popped off the stack by " { $link if } ", this gives a total stack effect of " { $snippet "( x x x -- x )" } "." ; -ARTICLE: "inference-recursive" "Stack effects of recursive words" -"When a recursive call is encountered, the declared stack effect is substituted in. When inference is complete, the inferred stack effect is compared with the declared stack effect." +ARTICLE: "inference-recursive-combinators" "Recursive combinator stack effects" +"Most combinators do not call themselves recursively directly; instead, they are implemented in terms of existing combinators, for example " { $link while } ", " { $link map } ", and the " { $link "compositional-combinators" } ". In these cases, the rules outlined in " { $link "inference-combinators" } " apply." $nl -"Attempting to infer the stack effect of a recursive word which outputs a variable number of objects on the stack will fail. For example, the following will throw an " { $link unbalanced-branches-error } ":" -{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if ;" "[ foo ] infer." } -"If you declare an incorrect stack effect, inference will fail also. Badly defined recursive words cannot confuse the inferencer." ; - -ARTICLE: "inference-recursive-combinators" "Recursive combinator inference" -"Most combinators are not explicitly recursive; instead, they are implemented in terms of existing combinators, for example " { $link while } ", " { $link map } ", and the " { $link "compositional-combinators" } "." -$nl -"Combinators which are recursive require additional care." -$nl -"If a recursive word takes quotation parameters from the stack and calls them, it must be declared " { $link POSTPONE: inline } " (as documented in " { $link "inference-combinators" } ") as well as " { $link POSTPONE: recursive } "." -$nl -"Furthermore, the input parameters which are quotations must be annotated in the stack effect. For example, the following will not infer:" +"Combinators which are recursive require additional care. In addition to being declared " { $link POSTPONE: inline } ", they must be declared " { $link POSTPONE: recursive } ". There are three restrictions that only apply to combinators with this declaration:" +{ $heading "Input quotation declaration" } +"Input parameters which are quotations must be annotated as much in the stack effect. For example, the following will not infer:" { $example ": bad ( quot -- ) [ call ] keep foo ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." } "The following is correct:" { $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" } +"The effect of the nested quotation itself is only present for documentation purposes; the mere presence of a nested effect is sufficient to mark that value as a quotation parameter." +{ $heading "Data flow restrictions" } +"The stack checker does not trace data flow in two instances." +$nl "An inline recursive word cannot pass a quotation on the data stack through the recursive call. For example, the following will not infer:" { $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." } "However a small change can be made:" @@ -80,23 +91,47 @@ $nl "[ [ 5 ] t foo ] infer." } ; -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 optimizing compiler to build the high-level SSA representation on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")." -$nl -"The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:" -{ $subsection infer. } -"Instead of printing the inferred information, it can be returned as objects on the stack:" +ARTICLE: "tools.inference" "Stack effect tools" +{ $link "inference" } " can be used interactively to print stack effects of quotations without running them. It can also be used from " { $link "combinators.smart" } "." { $subsection infer } -"Static stack effect inference can be combined with unit tests; see " { $link "tools.test.write" } "." +{ $subsection infer. } +"There are also some words for working with " { $link effect } " instances. Getting a word's declared stack effect:" +{ $subsection stack-effect } +"Converting a stack effect to a string form:" +{ $subsection effect>string } +"Comparing effects:" +{ $subsection effect-height } +{ $subsection effect<= } +"The class of stack effects:" +{ $subsection effect } +{ $subsection effect? } ; + +ARTICLE: "inference-escape" "Stack effect checking escape hatches" +"In a static checking regime, sometimes it is necessary to step outside the boundaries and run some code which cannot be statically checked; perhaps this code is constructed at run-time. There are two ways to get around the static stack checker." $nl -"The following articles describe the implementation of the stack effect inference algorithm:" +"If the stack effect of a word or quotation is known, but the word or quotation itself is not, " { $link POSTPONE: execute( } " or " { $link POSTPONE: call( } " can be used. See " { $link "call" } " for details." +$nl +"If the stack effect is not known, the code being called cannot manipulate the datastack directly. Instead, it must reflect the datastack into an array:" +{ $subsection with-datastack } +"The surrounding code has a static stack effect since " { $link with-datastack } " has one. However, the array passed in as input may be transformed arbitrarily by calling this combinator." ; + +ARTICLE: "inference" "Stack effect checking" +"The " { $link "compiler" } " checks the " { $link "effects" } " of words before they can be run. This ensures that words take exactly the number of inputs and outputs that the programmer declares in source." +$nl +"Words that do not pass the stack checker are rejected and cannot be run, and so essentially this defines a very simple and permissive type system that nevertheless catches some invalid programs and enables compiler optimizations." +$nl +"If a word's stack effect cannot be inferred, a compile error is reported. See " { $link "compiler-errors" } "." +$nl +"The following articles describe how different control structures are handled by the stack checker." { $subsection "inference-simple" } -{ $subsection "inference-recursive" } { $subsection "inference-combinators" } { $subsection "inference-recursive-combinators" } { $subsection "inference-branches" } +"Stack checking catches several classes of errors." { $subsection "inference-errors" } -{ $see-also "effects" } ; +"Sometimes code with a dynamic stack effect has to be run." +{ $subsection "inference-escape" } +{ $see-also "effects" "tools.inference" "tools.errors" } ; ABOUT: "inference" diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor index a1d7e50594..dbdb69b3e9 100644 --- a/basis/threads/threads-docs.factor +++ b/basis/threads/threads-docs.factor @@ -48,7 +48,7 @@ ARTICLE: "thread-impl" "Thread implementation" { $subsection sleep-queue } ; ARTICLE: "threads" "Lightweight co-operative threads" -"Factor supports lightweight co-operative threads implemented on top of continuations. A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested." +"Factor supports lightweight co-operative threads implemented on top of " { $link "continuations" } ". A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested." $nl "Factor threads are very lightweight. Each thread can take as little as 900 bytes of memory. This library has been tested running hundreds of thousands of simple threads." $nl diff --git a/basis/tools/errors/errors-docs.factor b/basis/tools/errors/errors-docs.factor index 96b13b69b6..5bbb6c4721 100644 --- a/basis/tools/errors/errors-docs.factor +++ b/basis/tools/errors/errors-docs.factor @@ -6,15 +6,15 @@ ARTICLE: "compiler-errors" "Compiler warnings and errors" "After loading a vocabulary, you might see messages like:" { $code ":errors - print 2 compiler errors" - ":warnings - print 50 compiler warnings" + ":warnings - print 1 compiler warnings" } -"These messages arise from the compiler's stack effect checker. Production code should not have any warnings and errors in it. Warning and error conditions are documented in " { $link "inference-errors" } "." +"This indicates that some words did not pass the stack checker. Stack checker error conditions are documented in " { $link "inference-errors" } ", and the stack checker itself in " { $link "inference" } "." $nl "Words to view warnings and errors:" { $subsection :warnings } { $subsection :errors } { $subsection :linkage } -"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "." ; +"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism, and as a result, they are also are shown in the " { $link "ui.tools.error-list" } "." ; HELP: compiler-error { $values { "error" "an error" } { "word" word } } diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index dd55d5fabe..e02103697d 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -269,28 +269,28 @@ ARTICLE: "combinators-quot" "Quotation construction utilities" { $subsection case>quot } { $subsection alist>quot } ; -ARTICLE: "call" "Fundamental combinators" -"The most basic combinators are those that take either a quotation or word, and invoke it immediately. There are two sets of combinators; they differe in whether or not the stack effect of the expected code is declared." -$nl -"The simplest combinators do not take an effect declaration:" -{ $subsection call } -{ $subsection execute } -"These combinators only get optimized by the compiler if the quotation or word parameter is a literal; otherwise a compiler warning will result. Definitions of combinators which require literal parameters must be followed by the " { $link POSTPONE: inline } " declaration. For example:" -{ $code - ": keep ( x quot -- x )" - " over [ call ] dip ; inline" -} -"See " { $link "declarations" } " and " { $link "compiler-errors" } " for details." -$nl -"The other set of combinators allow arbitrary quotations and words to be called from optimized code. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate." -{ $subsection call-effect } -{ $subsection execute-effect } -"A simple layer of syntax sugar is defined on top:" -{ $subsection POSTPONE: call( } -{ $subsection POSTPONE: execute( } +ARTICLE: "call-unsafe" "Unsafe combinators" "Unsafe calls declare an effect statically without any runtime checking:" { $subsection call-effect-unsafe } -{ $subsection execute-effect-unsafe } +{ $subsection execute-effect-unsafe } ; + +ARTICLE: "call" "Fundamental combinators" +"The most basic combinators are those that take either a quotation or word, and invoke it immediately." +$nl +"There are two sets of combinators; they differ in whether or not the stack effect of the expected code is declared." +$nl +"The simplest combinators do not take an effect declaration. The compiler checks the stack effect at compile time, rejecting the program if this cannot be done:" +{ $subsection call } +{ $subsection execute } +"The second set of combinators takes an effect declaration. The stack effect of the quotation or word is checked at runtime:" +{ $subsection POSTPONE: call( } +{ $subsection POSTPONE: execute( } +"The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:" +{ $subsection call-effect } +{ $subsection execute-effect } +{ $subsection "call-unsafe" } +"The combinator variants that do not take an effect declaration can only be used if the compiler is able to infer the stack effect by other means. See " { $link "inference-combinators" } "." +{ $subsection "call-unsafe" } { $see-also "effects" "inference" } ; ARTICLE: "combinators" "Combinators" diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 651169554e..2c91981f13 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -81,8 +81,6 @@ $nl { $subsection attempt-all } { $subsection retry } { $subsection with-return } -"Reflecting the datastack:" -{ $subsection with-datastack } "Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "." { $subsection "continuations.private" } ; @@ -211,7 +209,7 @@ $low-level-note ; HELP: with-datastack { $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } } -{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." } +{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." } { $examples { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } } ; diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor index 20709ca807..495aeb39c1 100644 --- a/core/effects/effects-docs.factor +++ b/core/effects/effects-docs.factor @@ -1,16 +1,20 @@ USING: help.markup help.syntax math strings words kernel combinators ; IN: effects -ARTICLE: "effect-declaration" "Stack effect declaration" -"Stack effects of words must be declared, with the exception of words which only push literals on the stack." -$nl -"A stack effect declaration is written in parentheses and lists word inputs and outputs, separated by " { $snippet "--" } ". Here is an example:" -{ $synopsis sq } +ARTICLE: "effects" "Stack effect declarations" +"Word definition words such as " { $link POSTPONE: : } " and " { $link POSTPONE: GENERIC: } " have a " { $emphasis "stack effect declaration" } " as part of their syntax. A stack effect declaration takes the following form:" +{ $code "( input1 input2 ... -- output1 ... )" } +"Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Here is an example:" +{ $synopsis + } "Parameters which are quotations can be declared by suffixing the parameter name with " { $snippet ":" } " and then writing a nested stack effect declaration:" { $synopsis while } -"Stack effect declarations are read in using a parsing word:" -{ $subsection POSTPONE: ( } -"Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Each value can be named by a data type or description. The following are some examples of value names:" +"Only the number of inputs and outputs carries semantic meaning." +$nl +"Nested quotation declaration only has semantic meaning for " { $link POSTPONE: inline } " " { $link POSTPONE: recursive } " words. See " { $link "inference-recursive-combinators" } "." +$nl +"In concatenative code, input and output names are for documentation purposes only and certain conventions have been established to make them more descriptive. For code written with " { $link "locals" } ", stack values are bound to local variables named by the stack effect's input parameters." +$nl +"Inputs and outputs are typically named after some pun on their data type, or a description of the value's purpose if the type is very general. The following are some examples of value names:" { $table { { { $snippet "?" } } "a boolean" } { { { $snippet "<=>" } } { "an ordering sepcifier; see " { $link "order-specifiers" } } } @@ -26,25 +30,7 @@ $nl { { $snippet "dim" } "a screen dimension specified as a two-element array holding width and height values" } { { $snippet "*" } "when this symbol appears by itself in the list of outputs, it means the word unconditionally throws an error" } } -"The stack effect inferencer verifies stack effect comments to ensure the correct number of inputs and outputs is listed. Value names are ignored; only their number matters. An error is thrown if a word's declared stack effect does not match its inferred stack effect. See " { $link "inference" } "." ; - -ARTICLE: "effects" "Stack effects" -"A " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that an operation takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effects are first-class, and words for working with them are found in the " { $vocab-link "effects" } " vocabulary." -$nl -"Stack effects of words must be declared, and the " { $link "compiler" } " checks that these declarations are correct. Invalid declarations are reported as " { $link "compiler-errors" } ". The " { $link "inference" } " tool can be used to check stack effects interactively." -{ $subsection "effect-declaration" } -"There is a literal syntax for stack objects. It is most often used with " { $link define-declared } ", " { $link call-effect } " and " { $link execute-effect } "." -{ $subsection POSTPONE: (( } -"Getting a word's declared stack effect:" -{ $subsection stack-effect } -"Converting a stack effect to a string form:" -{ $subsection effect>string } -"Comparing effects:" -{ $subsection effect-height } -{ $subsection effect<= } -"The class of stack effects:" -{ $subsection effect } -{ $subsection effect? } ; +{ $see-also "inference" } ; ABOUT: "effects" diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 7017ef8a08..e8b5e6d69c 100644 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -95,7 +95,7 @@ $nl { $subsection POSTPONE: MATH: } "Method definition:" { $subsection POSTPONE: M: } -"Generic words must declare their stack effect in order to compile. See " { $link "effect-declaration" } "." +"Generic words must declare their stack effect in order to compile. See " { $link "effects" } "." { $subsection "method-order" } { $subsection "call-next-method" } { $subsection "method-combination" } diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index cf0aea787b..9989d889a8 100644 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -2,7 +2,20 @@ USING: help.markup help.syntax io strings arrays io.backend io.files.private quotations sequences ; IN: io.files +ARTICLE: "io.files.examples" "Examples of reading and writing files" +"Sort the lines in a file and write them back to the same file:" +{ $code + "USING: io io.encodings.utf8 io.files sequences sorting ;" + "\"lines.txt\" utf8 [ file-lines natural-sort ] 2keep set-file-lines" +} +"Read 1024 bytes from a file:" +{ $code + "USING: io io.encodings.binary io.files ;" + "\"data.bin\" binary [ 1024 read ] with-file-reader" +} ; + ARTICLE: "io.files" "Reading and writing files" +{ $subsection "io.files.examples" } "File streams:" { $subsection } { $subsection } diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index ebc248bbbf..740152f294 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -355,9 +355,27 @@ $nl "Copying the contents of one stream to another:" { $subsection stream-copy } ; +ARTICLE: "stream-examples" "Stream example" +"Ask the user for their age, and print it back:" +{ $code + "USING: io math.parser ;" + "" + ": ask-age ( -- ) \"How old are you?\" print ;" + "" + ": read-age ( -- n ) readln string>number ;" + "" + ": print-age ( n -- )" + " \"You are \" write" + " number>string write" + " \" years old.\" print ;" + ": example ( -- ) ask-age read-age print-age ;" + "" + "example" +} ; + ARTICLE: "streams" "Streams" "Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of " { $emphasis "elements" } "." -$nl +{ $subsection "stream-examples" } "A stream can either be passed around on the stack or bound to a dynamic variable and used as one of the two implicit " { $emphasis "default streams" } "." { $subsection "stream-protocol" } { $subsection "stdio" } diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index a0e1d280d5..7ab287fd20 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -1,7 +1,7 @@ USING: generic help.syntax help.markup kernel math parser words effects classes generic.standard classes.tuple generic.math generic.standard arrays io.pathnames vocabs.loader io sequences -assocs words.symbol words.alias words.constant ; +assocs words.symbol words.alias words.constant combinators ; IN: syntax ARTICLE: "parser-algorithm" "Parser algorithm" @@ -152,6 +152,11 @@ ARTICLE: "syntax-pathnames" "Pathname syntax" { $subsection POSTPONE: P" } "Pathnames are documented in " { $link "io.pathnames" } "." ; +ARTICLE: "syntax-effects" "Stack effect syntax" +"Note that this is " { $emphasis "not" } " syntax to declare stack effects of words. This pushes an " { $link effect } " instance on the stack for reflection, for use with words such as " { $link define-declared } ", " { $link call-effect } " and " { $link execute-effect } "." +{ $subsection POSTPONE: (( } +{ $see-also "effects" "inference" "tools.inference" } ; + ARTICLE: "syntax-literals" "Literals" "Many different types of objects can be constructed at parse time via literal syntax. Numbers are a special case since support for reading them is built-in to the parser. All other literals are constructed via parsing words." $nl @@ -168,7 +173,8 @@ $nl { $subsection "syntax-sbufs" } { $subsection "syntax-hashtables" } { $subsection "syntax-tuples" } -{ $subsection "syntax-pathnames" } ; +{ $subsection "syntax-pathnames" } +{ $subsection "syntax-effects" } ; ARTICLE: "syntax" "Syntax" "Factor has two main forms of syntax: " { $emphasis "definition" } " syntax and " { $emphasis "literal" } " syntax. Code is data, so the syntax for code is a special case of object literal syntax. This section documents literal syntax. Definition syntax is covered in " { $link "words" } ". Extending the parser is the main topic of " { $link "parser" } "." @@ -517,7 +523,7 @@ HELP: ( { $syntax "( inputs -- outputs )" } { $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } } { $description "A stack effect declaration. This is treated as a comment unless it appears inside a word definition." } -{ $see-also "effect-declaration" } ; +{ $see-also "effects" } ; HELP: (( { $syntax "(( inputs -- outputs ))" } diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 9cc1f5b2b9..94609a06e5 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -21,8 +21,8 @@ $nl { $subsection gensym } { $subsection define-temp } ; -ARTICLE: "colon-definition" "Word definitions" -"Every word has an associated quotation definition that is called when the word is executed." +ARTICLE: "colon-definition" "Colon definitions" +"Every word has an associated quotation definition that is called when the word is executed. A " { $emphasis "colon definition" } " is a word where this quotation is supplied directly by the user. This is the simplest and most common type of word definition." $nl "Defining words at parse time:" { $subsection POSTPONE: : } @@ -31,7 +31,7 @@ $nl { $subsection define } { $subsection define-declared } { $subsection define-inline } -"Word definitions must declare their stack effect. See " { $link "effect-declaration" } "." +"Word definitions must declare their stack effect. See " { $link "effects" } "." $nl "All other types of word definitions, such as " { $link "words.symbol" } " and " { $link "generic" } ", are just special cases of the above." ; @@ -56,30 +56,16 @@ $nl ": foo undefined ;" } ; -ARTICLE: "declarations" "Declarations" -"Declarations are parsing words that set a word property in the most recently defined word. Declarations only affect definitions compiled with the optimizing compiler. They do not change evaluation semantics of a word, but instead declare that the word follows a certain contract, and thus may be compiled differently." +ARTICLE: "declarations" "Compiler declarations" +"Compiler declarations are parsing words that set a word property in the most recently defined word. They appear after the final " { $link POSTPONE: ; } " of a word definition:" +{ $code ": cubed ( x -- y ) dup dup * * ; foldable" } +"Compiler declarations assert that the word follows a certain contract, enabling certain optimizations that are not valid in general." { $subsection POSTPONE: inline } { $subsection POSTPONE: foldable } { $subsection POSTPONE: flushable } { $subsection POSTPONE: recursive } -{ $warning "If a generic word is declared " { $link POSTPONE: foldable } " or " { $link POSTPONE: flushable } ", all methods must satisfy the contract, otherwise unpredicable behavior will occur." } -"Stack effect declarations are documented in " { $link "effect-declaration" } "." ; - -ARTICLE: "word-definition" "Defining words" -"There are two approaches to creating word definitions:" -{ $list - "using parsing words at parse time," - "using defining words at run time." -} -"The latter is a more dynamic feature that can be used to implement code generation and such, and in fact parse time defining words are implemented in terms of run time defining words." -{ $subsection "colon-definition" } -{ $subsection "words.symbol" } -{ $subsection "words.alias" } -{ $subsection "words.constant" } -{ $subsection "primitives" } -{ $subsection "deferred" } -{ $subsection "declarations" } -"Words implement the definition protocol; see " { $link "definitions" } "." ; +"It is entirely up to the programmer to ensure that the word satisfies the contract of a declaration. Furthermore, if a generic word is declared " { $link POSTPONE: foldable } " or " { $link POSTPONE: flushable } ", all methods must satisfy the contract. Unspecified behavior may result if a word does not follow the contract of one of its declarations." +{ $see-also "effects" } ; ARTICLE: "word-props" "Word properties" "Each word has a hashtable of properties." @@ -100,7 +86,7 @@ $nl { { { $snippet "\"reading\"" } ", " { $snippet "\"writing\"" } } { "Set on slot accessor words - " { $link "slots" } } } - { { $snippet "\"declared-effect\"" } { $link "effect-declaration" } } + { { $snippet "\"declared-effect\"" } { $link "effects" } } { { { $snippet "\"help\"" } ", " { $snippet "\"help-loc\"" } ", " { $snippet "\"help-parent\"" } } { "Where word help is stored - " { $link "writing-help" } } } @@ -134,9 +120,7 @@ $nl "An " { $emphasis "XT" } " (execution token) is the machine code address of a word:" { $subsection word-xt } ; -ARTICLE: "words" "Words" -"Words are the Factor equivalent of functions or procedures; a word is essentially a named quotation." -$nl +ARTICLE: "words.introspection" "Word introspection" "Word introspection facilities and implementation details are found in the " { $vocab-link "words" } " vocabulary." $nl "Word objects contain several slots:" @@ -149,11 +133,32 @@ $nl "Words are instances of a class." { $subsection word } { $subsection word? } +"Words implement the definition protocol; see " { $link "definitions" } "." { $subsection "interned-words" } { $subsection "uninterned-words" } -{ $subsection "word-definition" } { $subsection "word-props" } -{ $subsection "word.private" } +{ $subsection "word.private" } ; + +ARTICLE: "words" "Words" +"Words are the Factor equivalent of functions or procedures; a word is essentially a named quotation." +$nl +"There are two ways of creating word definitions:" +{ $list + "using parsing words at parse time," + "using defining words at run time." +} +"The latter is a more dynamic feature that can be used to implement code generation and such, and in fact parse time defining words are implemented in terms of run time defining words." +$nl +"Types of words:" +{ $subsection "colon-definition" } +{ $subsection "words.symbol" } +{ $subsection "words.alias" } +{ $subsection "words.constant" } +{ $subsection "primitives" } +"Advanced topics:" +{ $subsection "deferred" } +{ $subsection "declarations" } +{ $subsection "words.introspection" } { $see-also "vocabularies" "vocabs.loader" "definitions" "see" } ; ABOUT: "words" From 77c56e55a3d3c1d0c7e3d1cb9f6db20d6961df44 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Apr 2009 03:57:05 -0500 Subject: [PATCH 481/772] Oops --- basis/math/matrices/matrices.factor | 16 +++------------- 1 file changed, 3 insertions(+), 13 deletions(-) diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index 4c2c641c84..cfdbe17c06 100755 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -25,19 +25,9 @@ IN: math.matrices : m* ( m m -- m ) [ v* ] 2map ; : m/ ( m m -- m ) [ v/ ] 2map ; -TUPLE: flipped { seq read-only } ; - -M: flipped length seq>> first length ; - -M: flipped nth-unsafe seq>> swap ; - -INSTANCE: flipped sequence - -C: flipped - -: v.m ( v m -- v ) [ v. ] with map ; -: m.v ( m v -- v ) [ v. ] curry map ; inline -: m. ( m m -- m ) [ swap m.v ] curry map ; +: v.m ( v m -- v ) flip [ v. ] with map ; +: m.v ( m v -- v ) [ v. ] curry map ; +: m. ( m m -- m ) flip [ swap m.v ] curry map ; : mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ; : mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ; From d039c803eb3df092ce5ccb78300c6eff2a9840f8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 23 Apr 2009 12:08:30 -0500 Subject: [PATCH 482/772] env vocab for accessing the environment as an assoc --- extra/env/authors.txt | 1 + extra/env/env-docs.factor | 13 +++++++++++++ extra/env/env.factor | 26 ++++++++++++++++++++++++++ extra/env/summary.txt | 1 + 4 files changed, 41 insertions(+) create mode 100644 extra/env/authors.txt create mode 100644 extra/env/env-docs.factor create mode 100644 extra/env/env.factor create mode 100644 extra/env/summary.txt diff --git a/extra/env/authors.txt b/extra/env/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/env/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/env/env-docs.factor b/extra/env/env-docs.factor new file mode 100644 index 0000000000..918b30af4b --- /dev/null +++ b/extra/env/env-docs.factor @@ -0,0 +1,13 @@ +! (c)2009 Joe Groff, see bsd license +USING: help.markup help.syntax ; +IN: env + +HELP: env +{ $class-description "A singleton that implements the " { $link "assocs-protocol" } " over " { $link "environment" } "." } ; + +ARTICLE: "env" "Accessing the environment via the assoc protocol" +"The " { $vocab-link "env" } " vocabulary defines a " { $link env } " word which implements the " { $link "assocs-protocol" } " over " { $link "environment" } "." +{ $subsection env } +; + +ABOUT: "env" diff --git a/extra/env/env.factor b/extra/env/env.factor new file mode 100644 index 0000000000..f7f4c5d231 --- /dev/null +++ b/extra/env/env.factor @@ -0,0 +1,26 @@ +! (c)2009 Joe Groff, see bsd license +USING: assocs environment kernel sequences ; +IN: env + +SINGLETON: env + +INSTANCE: env assoc + +M: env at* + drop os-env dup >boolean ; + +M: env assoc-size + drop (os-envs) length ; + +M: env >alist + drop os-envs >alist ; + +M: env set-at + drop set-os-env ; + +M: env delete-at + drop unset-os-env ; + +M: env clear-assoc + drop os-envs keys [ unset-os-env ] each ; + diff --git a/extra/env/summary.txt b/extra/env/summary.txt new file mode 100644 index 0000000000..bd15472427 --- /dev/null +++ b/extra/env/summary.txt @@ -0,0 +1 @@ +Access environment variables via the assoc protocol From d88a89a3a00bcdb3a32691b8dad9e7ed8daeeb80 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 23 Apr 2009 12:32:18 -0500 Subject: [PATCH 483/772] booleans union class --- basis/booleans/booleans-docs.factor | 7 +++++++ basis/booleans/booleans-tests.factor | 7 +++++++ basis/booleans/booleans.factor | 5 +++++ 3 files changed, 19 insertions(+) create mode 100644 basis/booleans/booleans-docs.factor create mode 100644 basis/booleans/booleans-tests.factor create mode 100644 basis/booleans/booleans.factor diff --git a/basis/booleans/booleans-docs.factor b/basis/booleans/booleans-docs.factor new file mode 100644 index 0000000000..d3e9dfaed3 --- /dev/null +++ b/basis/booleans/booleans-docs.factor @@ -0,0 +1,7 @@ +! (c)2009 Joe Groff, see bsd license +USING: help.markup help.syntax ; +IN: booleans + +HELP: boolean +{ $class-description "A union of the " { $link POSTPONE: t } " and " { $link POSTPONE: f } " classes." } ; + diff --git a/basis/booleans/booleans-tests.factor b/basis/booleans/booleans-tests.factor new file mode 100644 index 0000000000..4b3154236d --- /dev/null +++ b/basis/booleans/booleans-tests.factor @@ -0,0 +1,7 @@ +! (c)2009 Joe Groff, see bsd license +USING: booleans tools.test ; +IN: booleans.tests + +[ t ] [ t boolean? ] unit-test +[ t ] [ f boolean? ] unit-test +[ f ] [ 1 boolean? ] unit-test diff --git a/basis/booleans/booleans.factor b/basis/booleans/booleans.factor new file mode 100644 index 0000000000..0ec7db33bf --- /dev/null +++ b/basis/booleans/booleans.factor @@ -0,0 +1,5 @@ +! (c)2009 Joe Groff, see bsd license +USING: kernel ; +IN: booleans + +UNION: boolean POSTPONE: t POSTPONE: f ; From c074c2c93bfd4ef3cafc5e7105153f7e26949d6f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Apr 2009 19:07:27 -0500 Subject: [PATCH 484/772] Fix >alist docs --- core/assocs/assocs-docs.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 9576a41b7b..d4046a4dcf 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -361,8 +361,7 @@ HELP: inc-at HELP: >alist { $values { "assoc" assoc } { "newassoc" "an array of key/value pairs" } } -{ $contract "Converts an associative structure into an association list." } -{ $notes "The " { $link assoc } " mixin has a default implementation for this generic word which constructs the association list by iterating over the assoc with " { $link assoc-find } "." } ; +{ $contract "Converts an associative structure into an association list." } ; HELP: assoc-clone-like { $values From 5649cc7a0a6cbc849160859a68edc01175b231cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Apr 2009 22:17:25 -0500 Subject: [PATCH 485/772] Compiler warnings are no more --- basis/bootstrap/stage2.factor | 4 +- basis/compiler/codegen/codegen.factor | 38 ++------ basis/compiler/compiler-docs.factor | 2 +- basis/compiler/compiler.factor | 39 +++++--- basis/compiler/errors/errors.factor | 68 ++++++++----- basis/compiler/tree/builder/builder.factor | 12 +-- basis/stack-checker/errors/errors-docs.factor | 4 +- basis/stack-checker/errors/errors.factor | 91 ++++-------------- .../errors/prettyprint/prettyprint.factor | 69 +++++-------- .../recursive-state/recursive-state.factor | 16 +-- basis/tools/errors/errors-docs.factor | 27 +++--- basis/tools/errors/errors.factor | 25 ++--- .../tools/error-list/error-list-docs.factor | 7 +- .../error-list/icons/compiler-warning.tiff | Bin 1036 -> 0 bytes core/parser/parser-docs.factor | 4 +- extra/mason/report/report.factor | 2 +- 16 files changed, 157 insertions(+), 251 deletions(-) delete mode 100644 basis/ui/tools/error-list/icons/compiler-warning.tiff diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 4d566a288d..cc853e4842 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -68,9 +68,11 @@ SYMBOL: bootstrap-time "staging" get "deploy-vocab" get or [ "stage2: deployment mode" print ] [ - "listener" require "debugger" require + "alien.prettyprint" require + "inspector" require "tools.errors" require + "listener" require "none" require ] if diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index a220de476a..2a0456e3b7 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -375,45 +375,21 @@ M: long-long-type flatten-value-type ( type -- types ) : box-return* ( node -- ) return>> [ ] [ box-return ] if-void ; -TUPLE: no-such-library name ; - -M: no-such-library summary - drop "Library not found" ; - -M: no-such-library error-type drop +linkage-error+ ; - -: no-such-library ( name -- ) - \ no-such-library boa - compiling-word get compiler-error ; - -TUPLE: no-such-symbol name ; - -M: no-such-symbol summary - drop "Symbol not found" ; - -M: no-such-symbol error-type drop +linkage-error+ ; - -: no-such-symbol ( name -- ) - \ no-such-symbol boa - compiling-word get compiler-error ; - : check-dlsym ( symbols dll -- ) dup dll-valid? [ dupd '[ _ dlsym ] any? - [ drop ] [ no-such-symbol ] if + [ drop ] [ compiling-word get no-such-symbol ] if ] [ - dll-path no-such-library drop + dll-path compiling-word get no-such-library drop ] if ; -: stdcall-mangle ( symbol node -- symbol ) - "@" - swap parameters>> parameter-sizes drop - number>string 3append ; +: stdcall-mangle ( symbol params -- symbol ) + parameters>> parameter-sizes drop number>string "@" glue ; : alien-invoke-dlsym ( params -- symbols dll ) - dup function>> dup pick stdcall-mangle 2array - swap library>> library dup [ dll>> ] when - 2dup check-dlsym ; + [ [ function>> dup ] keep stdcall-mangle 2array ] + [ library>> library dup [ dll>> ] when ] + bi 2dup check-dlsym ; M: ##alien-invoke generate-insn params>> diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index 89b9b3cbe9..b96d5e573a 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -29,7 +29,7 @@ $nl $nl "The " { $link compile-word } " word performs the actual task of compiling an individual word. The process proceeds as follows:" { $list - { "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". The logic for ignoring compile warnings generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." } + { "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". The logic for ignoring certain compile errors generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." } { "If the word contains a breakpoint, compilation ends here. Otherwise, all remaining steps execute until machine code is generated. Any further errors thrown by the compiler are not reported as compile errors, but instead are ordinary exceptions. This is because they indicate bugs in the compiler, not errors in user code." } { "The " { $link frontend } " word then calls " { $link optimize-tree } ". This produces the final optimized tree IR, and this stage of the compiler is complete." } { "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link compile-dependency } "." } diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 6094efad87..ee91d04b3d 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -2,13 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io words fry continuations vocabs assocs dlists definitions math graphs generic -combinators deques search-deques macros io source-files.errors stack-checker -stack-checker.state stack-checker.inlining combinators.short-circuit -compiler.errors compiler.units compiler.tree.builder -compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer -compiler.cfg.linearization compiler.cfg.two-operand -compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen -compiler.utilities ; +combinators deques search-deques macros io source-files.errors +stack-checker stack-checker.state stack-checker.inlining +stack-checker.errors combinators.short-circuit compiler.errors +compiler.units compiler.tree.builder compiler.tree.optimizer +compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization +compiler.cfg.two-operand compiler.cfg.linear-scan +compiler.cfg.stack-frame compiler.codegen compiler.utilities ; IN: compiler SYMBOL: compile-queue @@ -39,10 +39,10 @@ SYMBOL: compiled "trace-compilation" get [ dup name>> print flush ] when H{ } clone dependencies set H{ } clone generic-dependencies set - f swap compiler-error ; + clear-compiler-error ; : ignore-error? ( word error -- ? ) - #! Ignore warnings on inline combinators, macros, and special + #! Ignore some errors on inline combinators, macros, and special #! words such as 'call'. [ { @@ -51,7 +51,12 @@ SYMBOL: compiled [ "special" word-prop ] [ "no-compile" word-prop ] } 1|| - ] [ error-type +compiler-warning+ eq? ] bi* and ; + ] [ + { + [ do-not-compile? ] + [ literal-expected? ] + } 1|| + ] bi* and ; : finish ( word -- ) #! Recompile callers if the word's stack effect changed, then @@ -80,10 +85,16 @@ SYMBOL: compiled #! non-optimizing compiler, using its definition. Otherwise, #! if the compiler error is not ignorable, use a dummy #! definition from 'not-compiled-def' which throws an error. - 2dup ignore-error? - [ drop f over def>> ] - [ 2dup not-compiled-def ] if - [ swap compiler-error ] [ deoptimize-with ] bi-curry* bi ; + 2dup ignore-error? [ + drop + [ dup def>> deoptimize-with ] + [ clear-compiler-error ] + bi + ] [ + [ swap compiler-error ] + [ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ] + 2bi + ] if ; : frontend ( word -- nodes ) #! If the word contains breakpoints, don't optimize it, since diff --git a/basis/compiler/errors/errors.factor b/basis/compiler/errors/errors.factor index 7e2f3d95f8..3881439fc0 100644 --- a/basis/compiler/errors/errors.factor +++ b/basis/compiler/errors/errors.factor @@ -1,56 +1,72 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors source-files.errors kernel namespaces assocs ; +USING: accessors source-files.errors kernel namespaces assocs fry +summary ; IN: compiler.errors -TUPLE: compiler-error < source-file-error ; - -M: compiler-error error-type error>> error-type ; - +SYMBOL: +compiler-error+ SYMBOL: compiler-errors compiler-errors [ H{ } clone ] initialize -SYMBOLS: +compiler-error+ +compiler-warning+ +linkage-error+ ; +TUPLE: compiler-error < source-file-error ; -: errors-of-type ( type -- assoc ) - compiler-errors get-global - swap [ [ nip error-type ] dip eq? ] curry - assoc-filter ; +M: compiler-error error-type drop +compiler-error+ ; + +SYMBOL: +linkage-error+ +SYMBOL: linkage-errors + +linkage-errors [ H{ } clone ] initialize + +TUPLE: linkage-error < source-file-error ; + +M: linkage-error error-type drop +linkage-error+ ; + +: clear-compiler-error ( word -- ) + compiler-errors linkage-errors + [ get-global delete-at ] bi-curry@ bi ; + +: compiler-error ( error -- ) + dup asset>> compiler-errors get-global set-at ; T{ error-type { type +compiler-error+ } { word ":errors" } { plural "compiler errors" } { icon "vocab:ui/tools/error-list/icons/compiler-error.tiff" } - { quot [ +compiler-error+ errors-of-type values ] } + { quot [ compiler-errors get values ] } { forget-quot [ compiler-errors get delete-at ] } } define-error-type -T{ error-type - { type +compiler-warning+ } - { word ":warnings" } - { plural "compiler warnings" } - { icon "vocab:ui/tools/error-list/icons/compiler-warning.tiff" } - { quot [ +compiler-warning+ errors-of-type values ] } - { forget-quot [ compiler-errors get delete-at ] } -} define-error-type +: ( error word -- compiler-error ) + \ compiler-error ; + +: ( error word -- linkage-error ) + \ linkage-error ; + +: linkage-error ( error word class -- ) + '[ _ boa ] dip dup asset>> linkage-errors get set-at ; inline T{ error-type { type +linkage-error+ } { word ":linkage" } { plural "linkage errors" } { icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" } - { quot [ +linkage-error+ errors-of-type values ] } - { forget-quot [ compiler-errors get delete-at ] } + { quot [ linkage-errors get values ] } + { forget-quot [ linkage-errors get delete-at ] } { fatal? f } } define-error-type -: ( error word -- compiler-error ) - \ compiler-error ; +TUPLE: no-such-library name ; -: compiler-error ( error word -- ) - compiler-errors get-global pick - [ [ [ ] keep ] dip set-at ] [ delete-at drop ] if ; +M: no-such-library summary drop "Library not found" ; + +: no-such-library ( name word -- ) \ no-such-library linkage-error ; + +TUPLE: no-such-symbol name ; + +M: no-such-symbol summary drop "Symbol not found" ; + +: no-such-symbol ( name word -- ) \ no-such-symbol linkage-error ; ERROR: not-compiled word error ; \ No newline at end of file diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 3f00a3bb68..7f760650e7 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -15,7 +15,7 @@ IN: compiler.tree.builder GENERIC: (build-tree) ( quot -- ) -M: callable (build-tree) f initial-recursive-state infer-quot ; +M: callable (build-tree) infer-quot-here ; : check-no-compile ( word -- ) dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ; @@ -31,15 +31,13 @@ M: callable (build-tree) f initial-recursive-state infer-quot ; dup inline-recursive? [ 1quotation ] [ specialized-def ] if ; M: word (build-tree) - { - [ initial-recursive-state recursive-state set ] - [ check-no-compile ] - [ word-body infer-quot-here ] - [ current-effect check-effect ] - } cleave ; + [ check-no-compile ] + [ word-body infer-quot-here ] + [ current-effect check-effect ] tri ; : build-tree-with ( in-stack word/quot -- nodes ) [ + recursive-state set V{ } clone stack-visitor set [ [ >vector \ meta-d set ] [ length d-in set ] bi ] [ (build-tree) ] diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor index 3c36d95d1e..7a87ab988d 100644 --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -101,8 +101,6 @@ $nl { $subsection recursive-quotation-error } { $subsection too-many->r } { $subsection too-many-r> } -{ $subsection missing-effect } -"Main wrapper for all inference warnings and errors:" -{ $subsection inference-error } ; +{ $subsection missing-effect } ; ABOUT: "inference-errors" diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index 550e283dbf..e036d4d81b 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -1,93 +1,36 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel generic sequences io words arrays summary effects -continuations assocs accessors namespaces compiler.errors -stack-checker.values stack-checker.recursive-state -source-files.errors compiler.errors ; +USING: kernel stack-checker.values ; IN: stack-checker.errors -: pretty-word ( word -- word' ) - dup method-body? [ "method-generic" word-prop ] when ; +TUPLE: inference-error ; -TUPLE: inference-error error type word ; +ERROR: do-not-compile < inference-error word ; -M: inference-error error-type type>> ; +ERROR: literal-expected < inference-error what ; -: (inference-error) ( ... class type -- * ) - [ boa ] dip - recursive-state get word>> - \ inference-error boa rethrow ; inline +ERROR: unbalanced-branches-error < inference-error branches quots ; -: inference-error ( ... class -- * ) - +compiler-error+ (inference-error) ; inline +ERROR: too-many->r < inference-error ; -: inference-warning ( ... class -- * ) - +compiler-warning+ (inference-error) ; inline +ERROR: too-many-r> < inference-error ; -TUPLE: do-not-compile word ; +ERROR: missing-effect < inference-error word ; -: do-not-compile ( word -- * ) \ do-not-compile inference-warning ; +ERROR: effect-error < inference-error inferred declared ; -TUPLE: literal-expected what ; +ERROR: recursive-quotation-error < inference-error quot ; -: literal-expected ( what -- * ) \ literal-expected inference-warning ; +ERROR: undeclared-recursion-error < inference-error word ; -M: object (literal) "literal value" literal-expected ; +ERROR: diverging-recursion-error < inference-error word ; -TUPLE: unbalanced-branches-error branches quots ; +ERROR: unbalanced-recursion-error < inference-error word height ; -: unbalanced-branches-error ( branches quots -- * ) - \ unbalanced-branches-error inference-error ; +ERROR: inconsistent-recursive-call-error < inference-error word ; -TUPLE: too-many->r ; +ERROR: unknown-primitive-error < inference-error ; -: too-many->r ( -- * ) \ too-many->r inference-error ; +ERROR: transform-expansion-error < inference-error word error ; -TUPLE: too-many-r> ; - -: too-many-r> ( -- * ) \ too-many-r> inference-error ; - -TUPLE: missing-effect word ; - -: missing-effect ( word -- * ) - pretty-word \ missing-effect inference-error ; - -TUPLE: effect-error inferred declared ; - -: effect-error ( inferred declared -- * ) - \ effect-error inference-error ; - -TUPLE: recursive-quotation-error quot ; - -: recursive-quotation-error ( word -- * ) - \ recursive-quotation-error inference-error ; - -TUPLE: undeclared-recursion-error word ; - -: undeclared-recursion-error ( word -- * ) - \ undeclared-recursion-error inference-error ; - -TUPLE: diverging-recursion-error word ; - -: diverging-recursion-error ( word -- * ) - \ diverging-recursion-error inference-error ; - -TUPLE: unbalanced-recursion-error word height ; - -: unbalanced-recursion-error ( word height -- * ) - \ unbalanced-recursion-error inference-error ; - -TUPLE: inconsistent-recursive-call-error word ; - -: inconsistent-recursive-call-error ( word -- * ) - \ inconsistent-recursive-call-error inference-error ; - -TUPLE: unknown-primitive-error ; - -: unknown-primitive-error ( -- * ) - \ unknown-primitive-error inference-warning ; - -TUPLE: transform-expansion-error word error ; - -: transform-expansion-error ( word error -- * ) - \ transform-expansion-error inference-error ; \ No newline at end of file +M: object (literal) "literal value" literal-expected ; \ No newline at end of file diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index 97fe1522e0..5be5722c23 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -1,18 +1,11 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel prettyprint io debugger -sequences assocs stack-checker.errors summary effects make ; +sequences assocs stack-checker.errors summary effects ; IN: stack-checker.errors.prettyprint -M: inference-error summary error>> summary ; - -M: inference-error error-help error>> error-help ; - -M: inference-error error. - [ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ; - M: literal-expected summary - [ "Got a computed value where a " % what>> % " was expected" % ] "" make ; + what>> "Got a computed value where a " " was expected" surround ; M: literal-expected error. summary print ; @@ -25,63 +18,45 @@ M: unbalanced-branches-error error. [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ; M: too-many->r summary - drop - "Quotation pushes elements on retain stack without popping them" ; + drop "Quotation pushes elements on retain stack without popping them" ; M: too-many-r> summary - drop - "Quotation pops retain stack elements which it did not push" ; + drop "Quotation pops retain stack elements which it did not push" ; M: missing-effect summary - [ - "The word " % - word>> name>> % - " must declare a stack effect" % - ] "" make ; + drop "Missing stack effect declaration" ; M: effect-error summary drop "Stack effect declaration is wrong" ; -M: recursive-quotation-error error. - "The quotation " write - quot>> pprint - " calls itself." print - "Stack effect inference is undecidable when quotation-level recursion is permitted." print ; +M: recursive-quotation-error summary + drop "Recursive quotation" ; M: undeclared-recursion-error summary - drop - "Inline recursive words must be declared recursive" ; + word>> name>> + "The inline recursive word " " must be declared recursive" surround ; M: diverging-recursion-error summary - [ - "The recursive word " % - word>> name>> % - " digs arbitrarily deep into the stack" % - ] "" make ; + word>> name>> + "The recursive word " " digs arbitrarily deep into the stack" surround ; M: unbalanced-recursion-error summary - [ - "The recursive word " % - word>> name>> % - " leaves with the stack having the wrong height" % - ] "" make ; + word>> name>> + "The recursive word " " leaves with the stack having the wrong height" surround ; M: inconsistent-recursive-call-error summary - [ - "The recursive word " % - word>> name>> % - " calls itself with a different set of quotation parameters than were input" % - ] "" make ; + word>> name>> + "The recursive word " + " calls itself with a different set of quotation parameters than were input" surround ; M: unknown-primitive-error summary - drop - "Cannot determine stack effect statically" ; + word>> name>> "The " " word cannot be called from optimized words" surround ; M: transform-expansion-error summary - drop - "Compiler transform threw an error" ; + word>> name>> "Macro expansion of " " threw an error" surround ; M: transform-expansion-error error. - [ summary print ] - [ "Word: " write word>> . nl ] - [ error>> error. ] tri ; \ No newline at end of file + [ summary print ] [ error>> error. ] bi ; + +M: do-not-compile summary + word>> name>> "Cannot compile call to " prepend ; \ No newline at end of file diff --git a/basis/stack-checker/recursive-state/recursive-state.factor b/basis/stack-checker/recursive-state/recursive-state.factor index 7740bebf4c..345e69e653 100644 --- a/basis/stack-checker/recursive-state/recursive-state.factor +++ b/basis/stack-checker/recursive-state/recursive-state.factor @@ -1,25 +1,19 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays sequences kernel sequences assocs -namespaces stack-checker.recursive-state.tree ; +USING: accessors kernel namespaces stack-checker.recursive-state.tree ; IN: stack-checker.recursive-state -TUPLE: recursive-state word quotations inline-words ; +TUPLE: recursive-state quotations inline-words ; -: initial-recursive-state ( word -- state ) - recursive-state new - swap >>word - f >>quotations - f >>inline-words ; inline +: ( -- state ) recursive-state new ; inline -f initial-recursive-state recursive-state set-global + recursive-state set-global : add-local-quotation ( rstate quot -- rstate ) swap clone [ dupd store ] change-quotations ; : add-inline-word ( word label -- rstate ) - swap recursive-state get clone - [ store ] change-inline-words ; + swap recursive-state get clone [ store ] change-inline-words ; : inline-recursive-label ( word -- label/f ) recursive-state get inline-words>> lookup ; diff --git a/basis/tools/errors/errors-docs.factor b/basis/tools/errors/errors-docs.factor index 5bbb6c4721..eb7b465d30 100644 --- a/basis/tools/errors/errors-docs.factor +++ b/basis/tools/errors/errors-docs.factor @@ -2,34 +2,33 @@ IN: tools.errors USING: help.markup help.syntax source-files.errors words io compiler.errors ; -ARTICLE: "compiler-errors" "Compiler warnings and errors" -"After loading a vocabulary, you might see messages like:" +ARTICLE: "compiler-errors" "Compiler errors" +"After loading a vocabulary, you might see a message like:" { $code ":errors - print 2 compiler errors" - ":warnings - print 1 compiler warnings" } "This indicates that some words did not pass the stack checker. Stack checker error conditions are documented in " { $link "inference-errors" } ", and the stack checker itself in " { $link "inference" } "." $nl -"Words to view warnings and errors:" -{ $subsection :warnings } +"Words to view errors:" { $subsection :errors } { $subsection :linkage } -"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism, and as a result, they are also are shown in the " { $link "ui.tools.error-list" } "." ; +"Compiler errors are reported using the " { $link "tools.errors" } " mechanism, and as a result, they are also are shown in the " { $link "ui.tools.error-list" } "." ; HELP: compiler-error -{ $values { "error" "an error" } { "word" word } } -{ $description "Saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } "." } ; +{ $values { "error" compiler-error } { "word" word } } +{ $description "Saves the error for viewing with " { $link :errors } "." } ; + +HELP: linkage-error +{ $values { "error" linkage-error } { "word" word } } +{ $description "Saves the error for viewing with " { $link :linkage } "." } ; HELP: :errors -{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ; - -HELP: :warnings -{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ; +{ $description "Prints all compiler errors." } ; HELP: :linkage -{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ; +{ $description "Prints all C library interface linkage errors." } ; -{ :errors :warnings :linkage } related-words +{ :errors :linkage } related-words HELP: errors. { $values { "errors" "a sequence of " { $link source-file-error } " instances" } } diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor index ae55e9a1da..ccedf365e3 100644 --- a/basis/tools/errors/errors.factor +++ b/basis/tools/errors/errors.factor @@ -2,17 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs debugger io kernel sequences source-files.errors summary accessors continuations make math.parser io.styles namespaces -compiler.errors ; +compiler.errors prettyprint ; IN: tools.errors #! Tools for source-files.errors. Used by tools.tests and others #! for error reporting -M: source-file-error compute-restarts - error>> compute-restarts ; +M: source-file-error compute-restarts error>> compute-restarts ; -M: source-file-error error-help - error>> error-help ; +M: source-file-error error-help error>> error-help ; CONSTANT: +listener-input+ "" @@ -20,11 +18,13 @@ M: source-file-error summary [ [ file>> [ % ": " % ] [ +listener-input+ % ] if* ] [ line#>> [ # ] when* ] bi - ] "" make - ; + ] "" make ; M: source-file-error error. - [ summary print nl ] [ error>> error. ] bi ; + [ summary print nl ] + [ "Asset: " write asset>> short. nl ] + [ error>> error. ] + tri ; : errors. ( errors -- ) group-by-source-file sort-errors @@ -34,14 +34,9 @@ M: source-file-error error. bi* ] assoc-each ; -: compiler-errors. ( type -- ) - errors-of-type values errors. ; +: :errors ( -- ) compiler-errors get values errors. ; -: :errors ( -- ) +compiler-error+ compiler-errors. ; - -: :warnings ( -- ) +compiler-warning+ compiler-errors. ; - -: :linkage ( -- ) +linkage-error+ compiler-errors. ; +: :linkage ( -- ) linkage-errors get values errors. ; M: not-compiled summary word>> name>> "The word " " cannot be executed because it failed to compile" surround ; diff --git a/basis/ui/tools/error-list/error-list-docs.factor b/basis/ui/tools/error-list/error-list-docs.factor index 10ca80d97d..5040a13be2 100644 --- a/basis/ui/tools/error-list/error-list-docs.factor +++ b/basis/ui/tools/error-list/error-list-docs.factor @@ -8,13 +8,12 @@ $nl { $heading "Message icons" } { $table { "Icon" "Message type" "Reference" } - { { $image "vocab:ui/tools/error-list/icons/note.tiff" } "Parser note" { $link "parser" } } - { { $image "vocab:ui/tools/error-list/icons/syntax-error.tiff" } "Syntax error" { $link "syntax" } } - { { $image "vocab:ui/tools/error-list/icons/compiler-warning.tiff" } "Compiler warning" { $link "compiler-errors" } } + ! { { $image "vocab:ui/tools/error-list/icons/note.tiff" } "Parser note" { $link "parser" } } + ! { { $image "vocab:ui/tools/error-list/icons/syntax-error.tiff" } "Syntax error" { $link "syntax" } } { { $image "vocab:ui/tools/error-list/icons/compiler-error.tiff" } "Compiler error" { $link "compiler-errors" } } + { { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } } { { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } } { { $image "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } "Help lint failure" { $link "help.lint" } } - { { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } } } ; ABOUT: "ui.tools.error-list" diff --git a/basis/ui/tools/error-list/icons/compiler-warning.tiff b/basis/ui/tools/error-list/icons/compiler-warning.tiff deleted file mode 100644 index 405cfd4761c00b17a9be353006e56125a91d639c..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1036 zcmebD)M8l2#K6#C|G8s@u=Z z)zR9fJ7i`BCY-vd(4W3V;8bdp=9Ei;5$iZMMLM!LX?!ydtUuvY6zRS0l-RFYM>b~- z<kYPd0xf}*J<@k-icBt~tY~SN4sx?EgW?z%M z`Y9WWJ`F_~cZGJx3r+lwe{tCKYbbCqDKtE=xU`mka!AyY_Z4n}4Xnx^jx2u8d8moi zF*xnkidIFBCXOU24hI1aMT0J#v&K?+vllSz;B8J|+>w@MDZ;q;UC{)NPG@LM2JNZgwtDg6< zKUT`lA9>s+%{XSnA={o4@W)=Eg_G&1#mOy|@^)vdUfM5dRyfflyyTUa7;A^(gcOAd zuR7f}UbsEo)8O>xPpvZTDj%9;j~59rG-xP>geo*GSg|&w*PCI7=?d@np*kxzamcl= zyS-}?qks_@Wj9awvYR2EHCwATEm|L&%_Hi^n z{C4zvZeqkOzGtd0yV7Po`2No}A?~M@SlhxEU20v6UYs)Pd+HIy#2~`Jz{t$N$iToL z0mO_*Y$hO^1t_+JnSp^BD$WYzvq9OwB+kGEWrOtdGBPoU0qHeB^@5BnU^6*@d?6$? zqEI%-Trns+6v!5bs$U8;REm)mtoIPm9BC-~6p$^0WR3=u4HRZD1lnr_q%Q$Ewoq}9 z+q|G=0+|d!Na7$q2NWjf=N4q Date: Thu, 23 Apr 2009 22:36:34 -0500 Subject: [PATCH 486/772] Split off some code into tools.errors.model and update UI listener's error summary when errors change --- basis/listener/listener.factor | 9 ++----- basis/tools/errors/errors.factor | 2 +- basis/tools/errors/model/authors.txt | 1 + basis/tools/errors/model/model.factor | 18 +++++++++++++ basis/ui/tools/error-list/error-list.factor | 22 +++------------- basis/ui/tools/listener/listener.factor | 29 ++++++++++----------- 6 files changed, 40 insertions(+), 41 deletions(-) create mode 100644 basis/tools/errors/model/authors.txt create mode 100644 basis/tools/errors/model/model.factor diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index 4234a0023b..d96e0df6c1 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -60,7 +60,7 @@ SYMBOL: max-stack-items 10 max-stack-items set-global -SYMBOL: error-summary-hook +SYMBOL: error-summary? > short. nl ] + [ asset>> [ "Asset: " write short. nl ] when* ] [ error>> error. ] tri ; diff --git a/basis/tools/errors/model/authors.txt b/basis/tools/errors/model/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/tools/errors/model/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/errors/model/model.factor b/basis/tools/errors/model/model.factor new file mode 100644 index 0000000000..c874363fe6 --- /dev/null +++ b/basis/tools/errors/model/model.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: models source-files.errors namespaces models.delay init +kernel calendar ; +IN: tools.errors.model + +SYMBOLS: (error-list-model) error-list-model ; + +(error-list-model) [ f ] initialize + +error-list-model [ (error-list-model) get-global 100 milliseconds ] initialize + +SINGLETON: updater + +M: updater errors-changed drop f (error-list-model) get-global set-model ; + +[ updater add-error-observer ] "ui.tools.error-list" add-init-hook + diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index 5a4fb7376a..aa23a8ebe1 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -4,14 +4,14 @@ USING: accessors arrays sequences sorting assocs colors.constants fry combinators combinators.smart combinators.short-circuit editors make memoize compiler.units fonts kernel io.pathnames prettyprint source-files.errors math.parser init math.order models models.arrow -models.arrow.smart models.search models.mapping models.delay debugger +models.arrow.smart models.search models.mapping debugger namespaces summary locals ui ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers ui.tools.inspector ui.gadgets.status-bar ui.operations ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs ui.gadgets.labels ui.baseline-alignment ui.images ui.tools.listener -compiler.errors calendar tools.errors ; +compiler.errors tools.errors tools.errors.model ; IN: ui.tools.error-list CONSTANT: source-file-icon @@ -180,23 +180,9 @@ error-list-gadget "toolbar" f { { T{ key-down f f "F1" } error-list-help } } define-command-map -SYMBOL: error-list-model - -error-list-model [ f ] initialize - -SINGLETON: updater - -M: updater errors-changed - drop f error-list-model get-global set-model ; - -[ updater add-error-observer ] "ui.tools.error-list" add-init-hook - -: ( -- model ) - error-list-model get-global - 1/2 seconds [ drop all-errors ] ; - : error-list-window ( -- ) - "Errors" open-status-window ; + error-list-model get [ drop all-errors ] + "Errors" open-status-window ; : show-error-list ( -- ) [ error-list-gadget? ] find-window diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 3a1c68fa25..eca16e7286 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -13,7 +13,7 @@ ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations ui.tools.browser ui.tools.common ui.tools.debugger ui.tools.listener.completion ui.tools.listener.popups -ui.tools.listener.history ui.tools.error-list ui.images ; +ui.tools.listener.history ui.images ui.tools.error-list tools.errors.model ; FROM: source-files.errors => all-errors ; IN: ui.tools.listener @@ -187,8 +187,18 @@ TUPLE: listener-gadget < tool error-summary output scroller input ; [ >>input ] [ pane new-pane t >>scrolls? >>output ] bi dup listener-streams >>output drop ; +: error-summary. ( -- ) + error-counts keys [ + H{ { table-gap { 3 3 } } } [ + [ [ [ icon>> write-image ] with-cell ] each ] with-row + ] tabular-output + { "Press " { $command tool "common" show-error-list } " to view errors." } + print-element + ] unless-empty ; + : ( -- gadget ) - COLOR: light-yellow >>interior ; + error-list-model get [ drop error-summary. ] + COLOR: light-yellow >>interior ; : init-error-summary ( listener -- listener ) >>error-summary @@ -366,22 +376,11 @@ interactor "completion" f { { T{ key-down f { C+ } "r" } history-completion-popup } } define-command-map -: error-summary. ( listener -- ) - error-summary>> [ - error-counts keys [ - H{ { table-gap { 3 3 } } } [ - [ [ [ icon>> write-image ] with-cell ] each ] with-row - ] tabular-output - { "Press " { $command tool "common" show-error-list } " to view errors." } - print-element - ] unless-empty - ] with-pane ; - : listener-thread ( listener -- ) dup listener-streams [ [ com-browse ] help-hook set - [ '[ [ _ input>> ] 2dip debugger-popup ] error-hook set ] - [ '[ _ error-summary. ] error-summary-hook set ] bi + '[ [ _ input>> ] 2dip debugger-popup ] error-hook set + error-summary? off tip-of-the-day. nl listener ] with-streams* ; From ba40acda282a056caf07c1593733528a4d97d0f8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Apr 2009 22:39:31 -0500 Subject: [PATCH 487/772] Merge Joe Groff's booleans vocab into kernel --- basis/booleans/booleans-docs.factor | 7 ------- basis/booleans/booleans-tests.factor | 7 ------- basis/booleans/booleans.factor | 5 ----- core/combinators/combinators-docs.factor | 2 ++ core/kernel/kernel-docs.factor | 3 +++ core/kernel/kernel.factor | 6 ++++-- 6 files changed, 9 insertions(+), 21 deletions(-) delete mode 100644 basis/booleans/booleans-docs.factor delete mode 100644 basis/booleans/booleans-tests.factor delete mode 100644 basis/booleans/booleans.factor diff --git a/basis/booleans/booleans-docs.factor b/basis/booleans/booleans-docs.factor deleted file mode 100644 index d3e9dfaed3..0000000000 --- a/basis/booleans/booleans-docs.factor +++ /dev/null @@ -1,7 +0,0 @@ -! (c)2009 Joe Groff, see bsd license -USING: help.markup help.syntax ; -IN: booleans - -HELP: boolean -{ $class-description "A union of the " { $link POSTPONE: t } " and " { $link POSTPONE: f } " classes." } ; - diff --git a/basis/booleans/booleans-tests.factor b/basis/booleans/booleans-tests.factor deleted file mode 100644 index 4b3154236d..0000000000 --- a/basis/booleans/booleans-tests.factor +++ /dev/null @@ -1,7 +0,0 @@ -! (c)2009 Joe Groff, see bsd license -USING: booleans tools.test ; -IN: booleans.tests - -[ t ] [ t boolean? ] unit-test -[ t ] [ f boolean? ] unit-test -[ f ] [ 1 boolean? ] unit-test diff --git a/basis/booleans/booleans.factor b/basis/booleans/booleans.factor deleted file mode 100644 index 0ec7db33bf..0000000000 --- a/basis/booleans/booleans.factor +++ /dev/null @@ -1,5 +0,0 @@ -! (c)2009 Joe Groff, see bsd license -USING: kernel ; -IN: booleans - -UNION: boolean POSTPONE: t POSTPONE: f ; diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index e02103697d..cbef25ac38 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -198,6 +198,8 @@ ARTICLE: "booleans" "Booleans" "In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value." { $subsection f } { $subsection t } +"A union class of the above:" +{ $subsection boolean } "There are some logical operations on booleans:" { $subsection >boolean } { $subsection not } diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 371edcf995..1d8c09a9b2 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -129,6 +129,9 @@ HELP: ? { $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } } { $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ; +HELP: boolean +{ $class-description "A union of the " { $link POSTPONE: t } " and " { $link POSTPONE: f } " classes." } ; + HELP: >boolean { $values { "obj" "a generalized boolean" } { "?" "a boolean" } } { $description "Convert a generalized boolean into a boolean. That is, " { $link f } " retains its value, whereas anything else becomes " { $link t } "." } ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index baccf56059..6245080225 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -176,12 +176,14 @@ PRIVATE> : tri-curry@ ( x y z q -- p' q' r' ) [curry] tri@ ; inline ! Booleans +UNION: boolean POSTPONE: t POSTPONE: f ; + +: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline + : not ( obj -- ? ) [ f ] [ t ] if ; inline : and ( obj1 obj2 -- ? ) over ? ; inline -: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline - : or ( obj1 obj2 -- ? ) dupd ? ; inline : xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline From 04c6e8fcf8d691919e7ed77439f6c15272f40ebb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 00:10:48 -0500 Subject: [PATCH 488/772] Fix tools.errors unit test and help lint --- basis/tools/errors/errors-docs.factor | 6 +++--- basis/tools/errors/errors-tests.factor | 9 +-------- 2 files changed, 4 insertions(+), 11 deletions(-) diff --git a/basis/tools/errors/errors-docs.factor b/basis/tools/errors/errors-docs.factor index eb7b465d30..4eb9115d05 100644 --- a/basis/tools/errors/errors-docs.factor +++ b/basis/tools/errors/errors-docs.factor @@ -1,6 +1,6 @@ IN: tools.errors USING: help.markup help.syntax source-files.errors words io -compiler.errors ; +compiler.errors classes ; ARTICLE: "compiler-errors" "Compiler errors" "After loading a vocabulary, you might see a message like:" @@ -15,11 +15,11 @@ $nl "Compiler errors are reported using the " { $link "tools.errors" } " mechanism, and as a result, they are also are shown in the " { $link "ui.tools.error-list" } "." ; HELP: compiler-error -{ $values { "error" compiler-error } { "word" word } } +{ $values { "error" compiler-error } } { $description "Saves the error for viewing with " { $link :errors } "." } ; HELP: linkage-error -{ $values { "error" linkage-error } { "word" word } } +{ $values { "error" linkage-error } { "word" word } { "class" class } } { $description "Saves the error for viewing with " { $link :linkage } "." } ; HELP: :errors diff --git a/basis/tools/errors/errors-tests.factor b/basis/tools/errors/errors-tests.factor index a70aa32be8..709adafb4e 100644 --- a/basis/tools/errors/errors-tests.factor +++ b/basis/tools/errors/errors-tests.factor @@ -6,14 +6,7 @@ DEFER: blah [ ] [ { T{ compiler-error - { error - T{ inference-error - f - T{ do-not-compile f blah } - +compiler-error+ - blah - } - } + { error T{ do-not-compile f blah } } { asset blah } } } errors. From 00b6107d3bd4efb2523625f311fcd029e38af6a0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 00:12:23 -0500 Subject: [PATCH 489/772] Add benchmark.gc1 --- extra/benchmark/gc1/authors.txt | 1 + extra/benchmark/gc1/gc1.factor | 8 ++++++++ 2 files changed, 9 insertions(+) create mode 100644 extra/benchmark/gc1/authors.txt create mode 100644 extra/benchmark/gc1/gc1.factor diff --git a/extra/benchmark/gc1/authors.txt b/extra/benchmark/gc1/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/benchmark/gc1/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/benchmark/gc1/gc1.factor b/extra/benchmark/gc1/gc1.factor new file mode 100644 index 0000000000..d201a08ecf --- /dev/null +++ b/extra/benchmark/gc1/gc1.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: math sequences kernel ; +IN: benchmark.gc1 + +: gc1 ( -- ) 6000000 [ >bignum 1+ ] map drop ; + +MAIN: gc1 \ No newline at end of file From 2e115dc5c398fbf0cdea6d3771dcb4d5c9ad65c1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 00:20:33 -0500 Subject: [PATCH 490/772] Better prettyprinting of method-body instances --- basis/help/help.factor | 2 +- basis/prettyprint/backend/backend.factor | 15 ++++++++------- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/basis/help/help.factor b/basis/help/help.factor index 956bc220e1..6e09e298f4 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -54,7 +54,7 @@ M: word article-title dup [ parsing-word? ] [ symbol? ] bi or [ name>> ] [ - [ name>> ] + [ unparse ] [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi append ] if ; diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 8004c1141f..1976c84fd1 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -35,8 +35,8 @@ M: effect pprint* effect>string "(" ")" surround text ; name>> "( no name )" or ; : pprint-word ( word -- ) - dup record-vocab - dup word-name* swap word-style styled-text ; + [ record-vocab ] + [ [ word-name* ] [ word-style ] bi styled-text ] bi ; : pprint-prefix ( word quot -- ) ; inline @@ -48,11 +48,12 @@ M: word pprint* [ pprint-word ] [ ?start-group ] [ ?end-group ] tri ; M: method-body pprint* - ; + [ + [ + [ "M\\ " % "method-class" word-prop word-name* % ] + [ " " % "method-generic" word-prop word-name* % ] bi + ] "" make + ] [ word-style ] bi styled-text ; M: real pprint* number>string text ; From d035c91e3fb21a49d34d774f71cd131e9a861178 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 24 Apr 2009 02:05:52 -0400 Subject: [PATCH 491/772] Add pidigits benchmark from language shootout --- extra/benchmark/pidigits/authors.txt | 1 + extra/benchmark/pidigits/pidigits.factor | 59 ++++++++++++++++++++++++ 2 files changed, 60 insertions(+) create mode 100644 extra/benchmark/pidigits/authors.txt create mode 100644 extra/benchmark/pidigits/pidigits.factor diff --git a/extra/benchmark/pidigits/authors.txt b/extra/benchmark/pidigits/authors.txt new file mode 100644 index 0000000000..4eec9c9a08 --- /dev/null +++ b/extra/benchmark/pidigits/authors.txt @@ -0,0 +1 @@ +Aaron Schaefer diff --git a/extra/benchmark/pidigits/pidigits.factor b/extra/benchmark/pidigits/pidigits.factor new file mode 100644 index 0000000000..5de5cc5e99 --- /dev/null +++ b/extra/benchmark/pidigits/pidigits.factor @@ -0,0 +1,59 @@ +! Copyright (c) 2009 Aaron Schaefer. All rights reserved. +! The contents of this file are licensed under the Simplified BSD License +! A copy of the license is available at http://factorcode.org/license.txt +USING: arrays formatting fry grouping io kernel locals math math.functions + math.matrices math.parser math.primes.factors math.vectors prettyprint + sequences sequences.deep sets ; +IN: benchmark.pidigits + +: extract ( z x -- n ) + 1 2array '[ _ v* sum ] map first2 /i ; + +: next ( z -- n ) + 3 extract ; + +: safe? ( z n -- ? ) + [ 4 extract ] dip = ; + +: >matrix ( q s r t -- z ) + 4array 2 group ; + +: produce ( z n -- z' ) + [ 10 ] dip -10 * 0 1 >matrix swap m. ; + +: gen-x ( x -- matrix ) + dup 2 * 1 + [ 2 * 0 ] keep >matrix ; + +: consume ( z k -- z' ) + gen-x m. ; + +:: (padded-total) ( row col -- str n format ) + "" row col + "%" "s\t:%d\n" + 10 col - number>string glue ; + +: padded-total ( row col -- ) + (padded-total) '[ _ printf ] call( str n -- ) ; + +:: (pidigits) ( k z n row col -- ) + n 0 > [ + z next :> y + z y safe? [ + col 10 = [ + row 10 + y "\t:%d\n%d" printf + k z y produce n 1 - row 10 + 1 (pidigits) + ] [ + y number>string write + k z y produce n 1 - row col 1 + (pidigits) + ] if + ] [ + k 1 + z k consume n row col (pidigits) + ] if + ] [ row col padded-total ] if ; + +: pidigits ( n -- ) + [ 1 { { 1 0 } { 0 1 } } ] dip 0 0 (pidigits) ; + +: pidigits-main ( -- ) + 10000 pidigits ; + +MAIN: pidigits-main From eb4981fb007d0527cf6325c238ed2b7d2ce5b13e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 01:14:02 -0500 Subject: [PATCH 492/772] ui.gadgets.tables: if model changes, try to preserve selection --- basis/ui/gadgets/tables/tables-tests.factor | 35 ++++++++++++++++--- basis/ui/gadgets/tables/tables.factor | 37 ++++++++++++++++----- 2 files changed, 59 insertions(+), 13 deletions(-) diff --git a/basis/ui/gadgets/tables/tables-tests.factor b/basis/ui/gadgets/tables/tables-tests.factor index 11f080af0a..3191753324 100644 --- a/basis/ui/gadgets/tables/tables-tests.factor +++ b/basis/ui/gadgets/tables/tables-tests.factor @@ -1,6 +1,6 @@ IN: ui.gadgets.tables.tests -USING: ui.gadgets.tables ui.gadgets.scrollers accessors -models namespaces tools.test kernel ; +USING: ui.gadgets.tables ui.gadgets.scrollers ui.gadgets.debug accessors +models namespaces tools.test kernel combinators ; SINGLETON: test-renderer @@ -8,15 +8,40 @@ M: test-renderer row-columns drop ; M: test-renderer column-titles drop { "First" "Last" } ; -[ ] [ +: test-table ( -- table ) { { "Britney" "Spears" } { "Justin" "Timberlake" } { "Don" "Stewart" } - } test-renderer - "table" set + } test-renderer
    ; + +[ ] [ + test-table "table" set ] unit-test [ ] [ "table" get "scroller" set +] unit-test + +[ { "Justin" "Timberlake" } { "Britney" "Spears" } ] [ + test-table t >>selection-required? dup [ + { + [ 1 select-row ] + [ + model>> { + { "Justin" "Timberlake" } + { "Britney" "Spears" } + { "Don" "Stewart" } + } swap set-model + ] + [ selected-row drop ] + [ + model>> { + { "Britney" "Spears" } + { "Don" "Stewart" } + } swap set-model + ] + [ selected-row drop ] + } cleave + ] with-grafted-gadget ] unit-test \ No newline at end of file diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index 3fe2156df0..d390b1e49b 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -5,8 +5,8 @@ math.functions math.rectangles math.order math.vectors namespaces opengl sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.worlds ui.gestures ui.render ui.pens.solid ui.text ui.commands ui.images ui.gadgets.menus ui.gadgets.line-support -math.rectangles models math.ranges sequences combinators fonts locals -strings ; +math.rectangles models math.ranges sequences combinators +combinators.short-circuit fonts locals strings ; IN: ui.gadgets.tables ! Row rendererer protocol @@ -246,9 +246,6 @@ PRIVATE> : update-selected-value ( table -- ) [ selected-row drop ] [ selected-value>> ] bi set-model ; -: initial-selected-index ( model table -- n/f ) - [ value>> length 1 >= ] [ selection-required?>> ] bi* and 0 f ? ; - : show-row-summary ( table n -- ) over nth-row [ swap [ renderer>> row-value ] keep show-summary ] @@ -258,8 +255,28 @@ PRIVATE> : hide-mouse-help ( table -- ) f >>mouse-index [ hide-status ] [ relayout-1 ] bi ; +: find-row-index ( value table -- n/f ) + [ model>> value>> ] [ renderer>> '[ _ row-value ] map index ] bi ; + +: initial-selected-index ( table -- n/f ) + { + [ model>> value>> empty? not ] + [ selection-required?>> ] + [ drop 0 ] + } 1&& ; + +: (update-selected-index) ( table -- n/f ) + [ selected-value>> value>> ] keep over + [ find-row-index ] [ 2drop f ] if ; + +: update-selected-index ( table -- n/f ) + { + [ (update-selected-index) ] + [ initial-selected-index ] + } 1|| ; + M: table model-changed - [ nip ] [ initial-selected-index ] 2bi { + nip dup update-selected-index { [ >>selected-index f >>mouse-index drop ] [ show-row-summary ] [ drop update-selected-value ] @@ -302,6 +319,8 @@ PRIVATE> : table-button-up ( table -- ) dup row-action? [ row-action ] [ update-selected-value ] if ; +PRIVATE> + : select-row ( table n -- ) over validate-line [ (select-row) ] @@ -309,6 +328,8 @@ PRIVATE> [ show-row-summary ] 2tri ; +> ] dip '[ _ + ] [ 0 ] if* select-row ; @@ -354,9 +375,9 @@ PRIVATE> show-operations-menu ] [ drop ] if-mouse-row ; -: focus-table ( table -- ) t >>focused? drop ; +: focus-table ( table -- ) t >>focused? relayout-1 ; -: unfocus-table ( table -- ) f >>focused? drop ; +: unfocus-table ( table -- ) f >>focused? relayout-1 ; table "sundry" f { { mouse-enter show-mouse-help } From 0759ddcfcaf74a5853ba172af9eff4a4f285a0e3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 24 Apr 2009 01:18:29 -0500 Subject: [PATCH 493/772] fix io.directories.search -- doens't call link-info twice on every file now --- basis/io/directories/search/search.factor | 28 +++++++++++------------ 1 file changed, 13 insertions(+), 15 deletions(-) diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 1346fbbdb8..87fbf67110 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -6,15 +6,20 @@ sequences system vocabs.loader locals math namespaces sorting assocs calendar threads ; IN: io.directories.search +: qualified-directory-entries ( path -- seq ) + dup directory-entries + [ [ append-path ] change-name ] with map ; + +: qualified-directory-files ( path -- seq ) + dup directory-files [ append-path ] with map ; + > ] when ] dip + [ qualified-directory-entries ] dip '[ _ [ queue>> ] [ bfs>> ] bi [ push-front ] [ push-back ] if ] each ; @@ -25,8 +30,9 @@ TUPLE: directory-iterator path bfs queue ; : next-file ( iter -- file/f ) dup queue>> deque-empty? [ drop f ] [ - dup queue>> pop-back dup link-info directory? - [ over push-directory next-file ] [ nip ] if + dup queue>> pop-back dup directory? + [ over push-directory next-file ] + [ nip name>> ] if ] if ; :: iterate-directory ( iter quot: ( obj -- ? ) -- obj ) @@ -70,14 +76,6 @@ ERROR: file-not-found ; : find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f ) '[ _ _ find-all-files ] map concat ; inline -: qualified-directory-entries ( path -- seq ) - directory-entries - current-directory get '[ [ _ prepend-path ] change-name ] map ; - -: qualified-directory-files ( path -- seq ) - directory-files - current-directory get '[ _ prepend-path ] map ; - : with-qualified-directory-files ( path quot -- ) '[ "" qualified-directory-files @ ] with-directory ; inline @@ -93,7 +91,7 @@ ERROR: file-not-found ; [ name>> dup ] [ directory? ] bi [ directory-size ] [ - [ link-info size-on-disk>> ] [ drop 0 ] recover + [ link-info size-on-disk>> ] [ 2drop 0 ] recover ] if ; : directory-usage ( path -- assoc ) From 7d0ae65adc84e4db9d7d87b7fd53902f4c22971c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 01:19:28 -0500 Subject: [PATCH 494/772] Don't call notify-error-observers if there weren't any new definitions --- core/compiler/units/units.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index c84e8fa73e..c4a137b2ba 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -144,8 +144,8 @@ GENERIC: definitions-changed ( assoc obj -- ) update-tuples process-forgotten-definitions modify-code-heap - updated-definitions dup assoc-empty? [ drop ] [ notify-definition-observers ] if - notify-error-observers ; + updated-definitions dup assoc-empty? + [ drop ] [ notify-definition-observers notify-error-observers ] if ; : with-nested-compilation-unit ( quot -- ) [ From 449f677ad8262c2c98d94a6369dad3deb3682215 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 24 Apr 2009 08:24:12 +0200 Subject: [PATCH 495/772] removed inlines from benchmark.factor added call( and execute( statements to make code compile --- mongodb/benchmark/benchmark.factor | 88 +++++++++++++++------------- mongodb/connection/connection.factor | 7 ++- mongodb/driver/driver.factor | 9 ++- 3 files changed, 54 insertions(+), 50 deletions(-) diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index 683f41b83b..ff963bcebc 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -1,6 +1,7 @@ USING: calendar math fry kernel assocs math.ranges bson.reader io.streams.byte-array sequences formatting combinators namespaces io tools.time prettyprint io.encodings.binary -accessors words mongodb.driver strings math.parser tools.walker bson.writer ; +accessors words mongodb.driver strings math.parser tools.walker bson.writer +tools.continuations ; IN: mongodb.benchmark @@ -106,25 +107,25 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : set-doc ( name -- ) [ result ] dip '[ _ >>doc ] change ; inline -: small-doc ( -- ) - "small" set-doc ; inline +: small-doc ( -- quot ) + "small" set-doc [ ] ; inline -: medium-doc ( -- ) - "medium" set-doc ; inline +: medium-doc ( -- quot ) + "medium" set-doc [ ] ; inline -: large-doc ( -- ) - "large" set-doc ; inline +: large-doc ( -- quot ) + "large" set-doc [ ] ; inline : small-doc-prepare ( -- quot: ( i -- doc ) ) - small-doc - '[ "x" DOC-SMALL clone [ set-at ] keep ] ; inline + small-doc drop + '[ "x" DOC-SMALL clone [ set-at ] keep ] ; : medium-doc-prepare ( -- quot: ( i -- doc ) ) - medium-doc - '[ "x" DOC-MEDIUM clone [ set-at ] keep ] ; inline + medium-doc drop + '[ "x" DOC-MEDIUM clone [ set-at ] keep ] ; : large-doc-prepare ( -- quot: ( i -- doc ) ) - large-doc + large-doc drop [ "x" DOC-LARGE clone [ set-at ] keep [ now "access-time" ] dip [ set-at ] keep ] ; @@ -132,36 +133,36 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : (insert) ( quot: ( i -- doc ) collection -- ) [ trial-size ] 2dip '[ _ call( i -- doc ) [ _ ] dip - result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ; inline + result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ; : (prepare-batch) ( i b quot: ( i -- doc ) -- batch-seq ) [ [ * ] keep 1 range boa ] dip - '[ _ call( i -- doc ) ] map ; inline + '[ _ call( i -- doc ) ] map ; : (insert-batch) ( quot: ( i -- doc ) collection -- ) [ trial-size batch-size [ / ] keep ] 2dip '[ _ _ (prepare-batch) [ _ ] dip result get lasterror>> [ save ] [ save-unsafe ] if - ] each-integer ; inline + ] each-integer ; : bchar ( boolean -- char ) - [ "t" ] [ "f" ] if ; inline + [ "t" ] [ "f" ] if ; inline : collection-name ( -- collection ) collection "benchmark" get* result get doc>> result get index>> bchar "%s-%s-%s" sprintf - [ [ result get ] dip >>collection drop ] keep ; inline + [ [ result get ] dip >>collection drop ] keep ; : prepare-collection ( -- collection ) collection-name [ "_x_idx" drop-index ] keep [ drop-collection ] keep - [ create-collection ] keep ; inline + [ create-collection ] keep ; : prepare-index ( collection -- ) - "_x_idx" H{ { "x" 1 } } ensure-index ; inline + "_x_idx" H{ { "x" 1 } } ensure-index ; : insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) prepare-collection @@ -170,14 +171,14 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ; : serialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) - '[ trial-size [ _ call( i -- doc ) assoc>bv drop ] each-integer ] ; inline + '[ trial-size [ _ call( i -- doc ) assoc>bv drop ] each-integer ] ; : deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) [ 0 ] dip call( i -- doc ) assoc>bv - '[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ; inline + '[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ; : check-for-key ( assoc key -- ) - CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ; inline + CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ; : (check-find-result) ( result -- ) "x" check-for-key ; inline @@ -185,24 +186,28 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : (find) ( cursor -- ) [ find [ (check-find-result) ] each (find) ] when* ; inline recursive -: find-one ( -- quot: ( -- ) ) +: find-one ( quot -- quot: ( -- ) ) + drop [ trial-size collection-name trial-size 2 / "x" H{ } clone [ set-at ] keep '[ _ _ 1 limit (find) ] times ] ; -: find-all ( -- quot: ( -- ) ) - collection-name - H{ } clone - '[ _ _ (find) ] ; +: find-all ( quot -- quot: ( -- ) ) + drop + collection-name + H{ } clone + '[ _ _ (find) ] ; -: find-range ( -- quot: ( -- ) ) +: find-range ( quot -- quot: ( -- ) ) + break + drop [ trial-size batch-size /i collection-name trial-size 2 / "$gt" H{ } clone [ set-at ] keep [ trial-size 2 / batch-size + "$lt" ] dip [ set-at ] keep "x" H{ } clone [ set-at ] keep - '[ _ _ find [ "x" check-for-key ] each drop ] times ] ; + '[ _ _ (find) ] times ] ; : batch ( -- ) result [ t >>batch ] change ; inline @@ -221,7 +226,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } trial-size ] dip 1000000 / /i "%-18s: {batch:%s,index:%s;errchk:%s} %10s docs/s" - sprintf print flush ; inline + sprintf print flush ; : print-separator ( -- ) "----------------------------------------------------------------" print flush ; inline @@ -236,45 +241,44 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } sprintf print flush print-separator-bold ; -: with-result ( quot: ( -- ) -- ) - [ ] prepose - [ print-result ] compose with-scope ; inline +: with-result ( options quot -- ) + '[ _ call( options -- time ) print-result ] with-scope ; : [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) ) '[ _ swap _ - '[ [ [ _ execute( -- quot: ( i -- doc ) ) ] dip - [ execute( -- ) ] each _ execute( -- quot: ( -- ) ) benchmark ] with-result ] each - print-separator ] ; inline + '[ [ [ _ execute( -- quot ) ] dip + [ execute( -- ) ] each _ execute( quot -- quot ) benchmark ] with-result ] each + print-separator ] ; : run-serialization-bench ( doc-word-seq feat-seq -- ) "Serialization Tests" print print-separator-bold - \ serialize [bench-quot] each ; inline + \ serialize [bench-quot] '[ _ call( doc-word -- ) ] each ; : run-deserialization-bench ( doc-word-seq feat-seq -- ) "Deserialization Tests" print print-separator-bold - \ deserialize [bench-quot] each ; inline + \ deserialize [bench-quot] '[ _ call( doc-word -- ) ] each ; : run-insert-bench ( doc-word-seq feat-seq -- ) "Insert Tests" print print-separator-bold - \ insert [bench-quot] each ; inline + \ insert [bench-quot] '[ _ call( doc-word -- ) ] each ; : run-find-one-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-One" print print-separator-bold - \ find-one [bench-quot] each ; inline + \ find-one [bench-quot] '[ _ call( doc-word -- ) ] each ; : run-find-all-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-All" print print-separator-bold - \ find-all [bench-quot] each ; inline + \ find-all [bench-quot] '[ _ call( doc-word -- ) ] each ; : run-find-range-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-Range" print print-separator-bold - \ find-range [bench-quot] each ; inline + \ find-range [bench-quot] '[ _ call( doc-word -- ) ] each ; : run-benchmarks ( -- ) diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor index 87718a9788..7e5bd81f58 100644 --- a/mongodb/connection/connection.factor +++ b/mongodb/connection/connection.factor @@ -19,8 +19,9 @@ TUPLE: mdb-connection instance node handle remote local ; CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; -: check-ok ( result -- ? ) - [ "ok" ] dip at >integer 1 = ; inline +: check-ok ( result -- errmsg ? ) + [ [ "errmsg" ] dip at ] + [ [ "ok" ] dip at >integer 1 = ] bi ; inline : ( name nodes -- mdb-db ) mdb-db new swap >>nodes swap >>name H{ } clone >>collections ; @@ -87,7 +88,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; : perform-authentication ( -- ) cmd-collection build-auth-query send-query-1result - dup check-ok [ drop ] [ [ "errmsg" ] dip at throw ] if ; inline + check-ok [ drop ] [ throw ] if ; inline : authenticate-connection ( mdb-connection -- ) [ mdb-connection get instance>> auth? diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 426167b08e..02b2f1b7c8 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -86,7 +86,7 @@ M: mdb-collection create-collection ( mdb-collection -- ) ] 2bi ] keep 1 >>return# send-query-plain objects>> first check-ok - [ "could not create collection" throw ] unless ; + [ drop ] [ throw ] if ; : load-collection-list ( -- collection-list ) namespaces-collection @@ -101,7 +101,6 @@ M: mdb-collection create-collection ( mdb-collection -- ) USE: tools.continuations : (ensure-collection) ( collection -- ) - break mdb-instance collections>> dup keys length 0 = [ load-collection-list [ [ "options" ] dip key? ] filter @@ -170,7 +169,7 @@ M: mdb-query-msg count [ collection>> "count" H{ } clone [ set-at ] keep ] keep query>> [ over [ "query" ] dip set-at ] when* [ cmd-collection ] dip find-one - [ check-ok ] keep '[ "n" _ at >fixnum ] [ f ] if ; + [ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ; : lasterror ( -- error ) cmd-collection H{ { "getlasterror" 1 } } @@ -180,8 +179,8 @@ GENERIC: validate. ( collection -- ) M: string validate. [ cmd-collection ] dip "validate" H{ } clone [ set-at ] keep - find-one [ check-ok ] keep - '[ "result" _ at print ] when ; + find-one [ check-ok nip ] keep + '[ "result" _ at print ] [ ] if ; M: mdb-collection validate. name>> validate. ; From 56bad90e732e4e0f5de9e649c49f5138d517bc78 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 24 Apr 2009 09:32:00 +0200 Subject: [PATCH 496/772] fixed collection problem (query) --- mongodb/driver/driver.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 02b2f1b7c8..d488dcc872 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -120,6 +120,9 @@ MEMO: check-collection ( collection -- fq-collection ) [ [ (ensure-collection) ] keep ] unless [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline +: fix-query-collection ( mdb-query -- mdb-query ) + [ check-collection ] change-collection ; inline + PRIVATE> : ( collection query -- mdb-query ) @@ -151,7 +154,7 @@ M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects ) GENERIC: find ( mdb-query -- cursor result ) M: mdb-query-msg find - send-query ; + fix-query-collection send-query ; M: mdb-cursor find get-more ; @@ -161,6 +164,7 @@ M: mdb-query-msg explain. GENERIC: find-one ( mdb-query -- result/f ) M: mdb-query-msg find-one + fix-query-collection 1 >>return# send-query-plain objects>> dup empty? [ drop f ] [ first ] if ; From 7b0d5b2432d784162dd234f6f724d8ec242828fa Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 24 Apr 2009 09:32:22 +0200 Subject: [PATCH 497/772] removed breakpoint --- mongodb/benchmark/benchmark.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index ff963bcebc..110a4b5091 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -200,7 +200,6 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } '[ _ _ (find) ] ; : find-range ( quot -- quot: ( -- ) ) - break drop [ trial-size batch-size /i collection-name From b00d81e47bfcd4e25640ec294091272f98829774 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 09:44:29 -0500 Subject: [PATCH 498/772] Add time spent scanning cards to 'time' output --- basis/tools/time/time.factor | 3 ++- vm/data_gc.c | 14 ++++++++++---- vm/data_gc.h | 1 + 3 files changed, 13 insertions(+), 5 deletions(-) diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index 58fc531623..0d1d9f6fa1 100644 --- a/basis/tools/time/time.factor +++ b/basis/tools/time/time.factor @@ -10,7 +10,7 @@ IN: tools.time : time. ( data -- ) unclip "==== RUNNING TIME" print nl 1000000 /f pprint " seconds" print nl - 4 cut* + 5 cut* "==== GARBAGE COLLECTION" print nl [ 6 group @@ -32,6 +32,7 @@ IN: tools.time "Total GC time (us):" "Cards scanned:" "Decks scanned:" + "Card scan time (us):" "Code heap literal scans:" } swap zip simple-table. ] bi* ; diff --git a/vm/data_gc.c b/vm/data_gc.c index cc1df13d58..50f38bc881 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -115,9 +115,13 @@ void copy_gen_cards(CELL gen) old->new references */ void copy_cards(void) { + u64 start = current_micros(); + int i; for(i = collecting_gen + 1; i < data_heap->gen_count; i++) copy_gen_cards(i); + + card_scan_time += (current_micros() - start); } /* Copy all tagged pointers in a range of memory */ @@ -435,7 +439,7 @@ void garbage_collection(CELL gen, return; } - s64 start = current_micros(); + u64 start = current_micros(); performing_gc = true; growing_data_heap = growing_data_heap_; @@ -539,9 +543,10 @@ void primitive_gc_stats(void) total_gc_time += s->gc_time; } - GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(total_gc_time))); - GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned))); - GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned))); + GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(total_gc_time))); + GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(cards_scanned))); + GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(decks_scanned))); + GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(card_scan_time))); GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans)); GROWABLE_ARRAY_TRIM(stats); @@ -556,6 +561,7 @@ void clear_gc_stats(void) cards_scanned = 0; decks_scanned = 0; + card_scan_time = 0; code_heap_scans = 0; } diff --git a/vm/data_gc.h b/vm/data_gc.h index feae26706d..52d8b603ad 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -28,6 +28,7 @@ typedef struct { F_GC_STATS gc_stats[MAX_GEN_COUNT]; u64 cards_scanned; u64 decks_scanned; +u64 card_scan_time; CELL code_heap_scans; /* What generation was being collected when copy_code_heap_roots() was last From b1c790da416e845786bbc7203dcc3034f36d4693 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 12:29:29 -0500 Subject: [PATCH 499/772] benchmark.javascript: new benchmark --- extra/benchmark/javascript/authors.txt | 1 + extra/benchmark/javascript/javascript.factor | 10 ++++++++++ .../benchmark/javascript/jquery-1.3.2.min.js | 19 +++++++++++++++++++ 3 files changed, 30 insertions(+) create mode 100644 extra/benchmark/javascript/authors.txt create mode 100644 extra/benchmark/javascript/javascript.factor create mode 100644 extra/benchmark/javascript/jquery-1.3.2.min.js diff --git a/extra/benchmark/javascript/authors.txt b/extra/benchmark/javascript/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/benchmark/javascript/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/benchmark/javascript/javascript.factor b/extra/benchmark/javascript/javascript.factor new file mode 100644 index 0000000000..4c05439e99 --- /dev/null +++ b/extra/benchmark/javascript/javascript.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.utf8 io.files kernel peg.javascript ; +IN: benchmark.javascript + +: javascript-parser-benchmark ( -- ) + "vocab:benchmark/javascript/jquery-1.3.2.min.js" + utf8 file-contents parse-javascript drop ; + +MAIN: javascript-parser-benchmark \ No newline at end of file diff --git a/extra/benchmark/javascript/jquery-1.3.2.min.js b/extra/benchmark/javascript/jquery-1.3.2.min.js new file mode 100644 index 0000000000..b1ae21d8b2 --- /dev/null +++ b/extra/benchmark/javascript/jquery-1.3.2.min.js @@ -0,0 +1,19 @@ +/* + * jQuery JavaScript Library v1.3.2 + * http://jquery.com/ + * + * Copyright (c) 2009 John Resig + * Dual licensed under the MIT and GPL licenses. + * http://docs.jquery.com/License + * + * Date: 2009-02-19 17:34:21 -0500 (Thu, 19 Feb 2009) + * Revision: 6246 + */ +(function(){var l=this,g,y=l.jQuery,p=l.$,o=l.jQuery=l.$=function(E,F){return new o.fn.init(E,F)},D=/^[^<]*(<(.|\s)+>)[^>]*$|^#([\w-]+)$/,f=/^.[^:#\[\.,]*$/;o.fn=o.prototype={init:function(E,H){E=E||document;if(E.nodeType){this[0]=E;this.length=1;this.context=E;return this}if(typeof E==="string"){var G=D.exec(E);if(G&&(G[1]||!H)){if(G[1]){E=o.clean([G[1]],H)}else{var I=document.getElementById(G[3]);if(I&&I.id!=G[3]){return o().find(E)}var F=o(I||[]);F.context=document;F.selector=E;return F}}else{return o(H).find(E)}}else{if(o.isFunction(E)){return o(document).ready(E)}}if(E.selector&&E.context){this.selector=E.selector;this.context=E.context}return this.setArray(o.isArray(E)?E:o.makeArray(E))},selector:"",jquery:"1.3.2",size:function(){return this.length},get:function(E){return E===g?Array.prototype.slice.call(this):this[E]},pushStack:function(F,H,E){var G=o(F);G.prevObject=this;G.context=this.context;if(H==="find"){G.selector=this.selector+(this.selector?" ":"")+E}else{if(H){G.selector=this.selector+"."+H+"("+E+")"}}return G},setArray:function(E){this.length=0;Array.prototype.push.apply(this,E);return this},each:function(F,E){return o.each(this,F,E)},index:function(E){return o.inArray(E&&E.jquery?E[0]:E,this)},attr:function(F,H,G){var E=F;if(typeof F==="string"){if(H===g){return this[0]&&o[G||"attr"](this[0],F)}else{E={};E[F]=H}}return this.each(function(I){for(F in E){o.attr(G?this.style:this,F,o.prop(this,E[F],G,I,F))}})},css:function(E,F){if((E=="width"||E=="height")&&parseFloat(F)<0){F=g}return this.attr(E,F,"curCSS")},text:function(F){if(typeof F!=="object"&&F!=null){return this.empty().append((this[0]&&this[0].ownerDocument||document).createTextNode(F))}var E="";o.each(F||this,function(){o.each(this.childNodes,function(){if(this.nodeType!=8){E+=this.nodeType!=1?this.nodeValue:o.fn.text([this])}})});return E},wrapAll:function(E){if(this[0]){var F=o(E,this[0].ownerDocument).clone();if(this[0].parentNode){F.insertBefore(this[0])}F.map(function(){var G=this;while(G.firstChild){G=G.firstChild}return G}).append(this)}return this},wrapInner:function(E){return this.each(function(){o(this).contents().wrapAll(E)})},wrap:function(E){return this.each(function(){o(this).wrapAll(E)})},append:function(){return this.domManip(arguments,true,function(E){if(this.nodeType==1){this.appendChild(E)}})},prepend:function(){return this.domManip(arguments,true,function(E){if(this.nodeType==1){this.insertBefore(E,this.firstChild)}})},before:function(){return this.domManip(arguments,false,function(E){this.parentNode.insertBefore(E,this)})},after:function(){return this.domManip(arguments,false,function(E){this.parentNode.insertBefore(E,this.nextSibling)})},end:function(){return this.prevObject||o([])},push:[].push,sort:[].sort,splice:[].splice,find:function(E){if(this.length===1){var F=this.pushStack([],"find",E);F.length=0;o.find(E,this[0],F);return F}else{return this.pushStack(o.unique(o.map(this,function(G){return o.find(E,G)})),"find",E)}},clone:function(G){var E=this.map(function(){if(!o.support.noCloneEvent&&!o.isXMLDoc(this)){var I=this.outerHTML;if(!I){var J=this.ownerDocument.createElement("div");J.appendChild(this.cloneNode(true));I=J.innerHTML}return o.clean([I.replace(/ jQuery\d+="(?:\d+|null)"/g,"").replace(/^\s*/,"")])[0]}else{return this.cloneNode(true)}});if(G===true){var H=this.find("*").andSelf(),F=0;E.find("*").andSelf().each(function(){if(this.nodeName!==H[F].nodeName){return}var I=o.data(H[F],"events");for(var K in I){for(var J in I[K]){o.event.add(this,K,I[K][J],I[K][J].data)}}F++})}return E},filter:function(E){return this.pushStack(o.isFunction(E)&&o.grep(this,function(G,F){return E.call(G,F)})||o.multiFilter(E,o.grep(this,function(F){return F.nodeType===1})),"filter",E)},closest:function(E){var G=o.expr.match.POS.test(E)?o(E):null,F=0;return this.map(function(){var H=this;while(H&&H.ownerDocument){if(G?G.index(H)>-1:o(H).is(E)){o.data(H,"closest",F);return H}H=H.parentNode;F++}})},not:function(E){if(typeof E==="string"){if(f.test(E)){return this.pushStack(o.multiFilter(E,this,true),"not",E)}else{E=o.multiFilter(E,this)}}var F=E.length&&E[E.length-1]!==g&&!E.nodeType;return this.filter(function(){return F?o.inArray(this,E)<0:this!=E})},add:function(E){return this.pushStack(o.unique(o.merge(this.get(),typeof E==="string"?o(E):o.makeArray(E))))},is:function(E){return !!E&&o.multiFilter(E,this).length>0},hasClass:function(E){return !!E&&this.is("."+E)},val:function(K){if(K===g){var E=this[0];if(E){if(o.nodeName(E,"option")){return(E.attributes.value||{}).specified?E.value:E.text}if(o.nodeName(E,"select")){var I=E.selectedIndex,L=[],M=E.options,H=E.type=="select-one";if(I<0){return null}for(var F=H?I:0,J=H?I+1:M.length;F=0||o.inArray(this.name,K)>=0)}else{if(o.nodeName(this,"select")){var N=o.makeArray(K);o("option",this).each(function(){this.selected=(o.inArray(this.value,N)>=0||o.inArray(this.text,N)>=0)});if(!N.length){this.selectedIndex=-1}}else{this.value=K}}})},html:function(E){return E===g?(this[0]?this[0].innerHTML.replace(/ jQuery\d+="(?:\d+|null)"/g,""):null):this.empty().append(E)},replaceWith:function(E){return this.after(E).remove()},eq:function(E){return this.slice(E,+E+1)},slice:function(){return this.pushStack(Array.prototype.slice.apply(this,arguments),"slice",Array.prototype.slice.call(arguments).join(","))},map:function(E){return this.pushStack(o.map(this,function(G,F){return E.call(G,F,G)}))},andSelf:function(){return this.add(this.prevObject)},domManip:function(J,M,L){if(this[0]){var I=(this[0].ownerDocument||this[0]).createDocumentFragment(),F=o.clean(J,(this[0].ownerDocument||this[0]),I),H=I.firstChild;if(H){for(var G=0,E=this.length;G1||G>0?I.cloneNode(true):I)}}if(F){o.each(F,z)}}return this;function K(N,O){return M&&o.nodeName(N,"table")&&o.nodeName(O,"tr")?(N.getElementsByTagName("tbody")[0]||N.appendChild(N.ownerDocument.createElement("tbody"))):N}}};o.fn.init.prototype=o.fn;function z(E,F){if(F.src){o.ajax({url:F.src,async:false,dataType:"script"})}else{o.globalEval(F.text||F.textContent||F.innerHTML||"")}if(F.parentNode){F.parentNode.removeChild(F)}}function e(){return +new Date}o.extend=o.fn.extend=function(){var J=arguments[0]||{},H=1,I=arguments.length,E=false,G;if(typeof J==="boolean"){E=J;J=arguments[1]||{};H=2}if(typeof J!=="object"&&!o.isFunction(J)){J={}}if(I==H){J=this;--H}for(;H-1}},swap:function(H,G,I){var E={};for(var F in G){E[F]=H.style[F];H.style[F]=G[F]}I.call(H);for(var F in G){H.style[F]=E[F]}},css:function(H,F,J,E){if(F=="width"||F=="height"){var L,G={position:"absolute",visibility:"hidden",display:"block"},K=F=="width"?["Left","Right"]:["Top","Bottom"];function I(){L=F=="width"?H.offsetWidth:H.offsetHeight;if(E==="border"){return}o.each(K,function(){if(!E){L-=parseFloat(o.curCSS(H,"padding"+this,true))||0}if(E==="margin"){L+=parseFloat(o.curCSS(H,"margin"+this,true))||0}else{L-=parseFloat(o.curCSS(H,"border"+this+"Width",true))||0}})}if(H.offsetWidth!==0){I()}else{o.swap(H,G,I)}return Math.max(0,Math.round(L))}return o.curCSS(H,F,J)},curCSS:function(I,F,G){var L,E=I.style;if(F=="opacity"&&!o.support.opacity){L=o.attr(E,"opacity");return L==""?"1":L}if(F.match(/float/i)){F=w}if(!G&&E&&E[F]){L=E[F]}else{if(q.getComputedStyle){if(F.match(/float/i)){F="float"}F=F.replace(/([A-Z])/g,"-$1").toLowerCase();var M=q.getComputedStyle(I,null);if(M){L=M.getPropertyValue(F)}if(F=="opacity"&&L==""){L="1"}}else{if(I.currentStyle){var J=F.replace(/\-(\w)/g,function(N,O){return O.toUpperCase()});L=I.currentStyle[F]||I.currentStyle[J];if(!/^\d+(px)?$/i.test(L)&&/^\d/.test(L)){var H=E.left,K=I.runtimeStyle.left;I.runtimeStyle.left=I.currentStyle.left;E.left=L||0;L=E.pixelLeft+"px";E.left=H;I.runtimeStyle.left=K}}}}return L},clean:function(F,K,I){K=K||document;if(typeof K.createElement==="undefined"){K=K.ownerDocument||K[0]&&K[0].ownerDocument||document}if(!I&&F.length===1&&typeof F[0]==="string"){var H=/^<(\w+)\s*\/?>$/.exec(F[0]);if(H){return[K.createElement(H[1])]}}var G=[],E=[],L=K.createElement("div");o.each(F,function(P,S){if(typeof S==="number"){S+=""}if(!S){return}if(typeof S==="string"){S=S.replace(/(<(\w+)[^>]*?)\/>/g,function(U,V,T){return T.match(/^(abbr|br|col|img|input|link|meta|param|hr|area|embed)$/i)?U:V+">"});var O=S.replace(/^\s+/,"").substring(0,10).toLowerCase();var Q=!O.indexOf("",""]||!O.indexOf("",""]||O.match(/^<(thead|tbody|tfoot|colg|cap)/)&&[1,"
    ","
    "]||!O.indexOf("",""]||(!O.indexOf("",""]||!O.indexOf("",""]||!o.support.htmlSerialize&&[1,"div
    ","
    "]||[0,"",""];L.innerHTML=Q[1]+S+Q[2];while(Q[0]--){L=L.lastChild}if(!o.support.tbody){var R=/"&&!R?L.childNodes:[];for(var M=N.length-1;M>=0;--M){if(o.nodeName(N[M],"tbody")&&!N[M].childNodes.length){N[M].parentNode.removeChild(N[M])}}}if(!o.support.leadingWhitespace&&/^\s/.test(S)){L.insertBefore(K.createTextNode(S.match(/^\s*/)[0]),L.firstChild)}S=o.makeArray(L.childNodes)}if(S.nodeType){G.push(S)}else{G=o.merge(G,S)}});if(I){for(var J=0;G[J];J++){if(o.nodeName(G[J],"script")&&(!G[J].type||G[J].type.toLowerCase()==="text/javascript")){E.push(G[J].parentNode?G[J].parentNode.removeChild(G[J]):G[J])}else{if(G[J].nodeType===1){G.splice.apply(G,[J+1,0].concat(o.makeArray(G[J].getElementsByTagName("script"))))}I.appendChild(G[J])}}return E}return G},attr:function(J,G,K){if(!J||J.nodeType==3||J.nodeType==8){return g}var H=!o.isXMLDoc(J),L=K!==g;G=H&&o.props[G]||G;if(J.tagName){var F=/href|src|style/.test(G);if(G=="selected"&&J.parentNode){J.parentNode.selectedIndex}if(G in J&&H&&!F){if(L){if(G=="type"&&o.nodeName(J,"input")&&J.parentNode){throw"type property can't be changed"}J[G]=K}if(o.nodeName(J,"form")&&J.getAttributeNode(G)){return J.getAttributeNode(G).nodeValue}if(G=="tabIndex"){var I=J.getAttributeNode("tabIndex");return I&&I.specified?I.value:J.nodeName.match(/(button|input|object|select|textarea)/i)?0:J.nodeName.match(/^(a|area)$/i)&&J.href?0:g}return J[G]}if(!o.support.style&&H&&G=="style"){return o.attr(J.style,"cssText",K)}if(L){J.setAttribute(G,""+K)}var E=!o.support.hrefNormalized&&H&&F?J.getAttribute(G,2):J.getAttribute(G);return E===null?g:E}if(!o.support.opacity&&G=="opacity"){if(L){J.zoom=1;J.filter=(J.filter||"").replace(/alpha\([^)]*\)/,"")+(parseInt(K)+""=="NaN"?"":"alpha(opacity="+K*100+")")}return J.filter&&J.filter.indexOf("opacity=")>=0?(parseFloat(J.filter.match(/opacity=([^)]*)/)[1])/100)+"":""}G=G.replace(/-([a-z])/ig,function(M,N){return N.toUpperCase()});if(L){J[G]=K}return J[G]},trim:function(E){return(E||"").replace(/^\s+|\s+$/g,"")},makeArray:function(G){var E=[];if(G!=null){var F=G.length;if(F==null||typeof G==="string"||o.isFunction(G)||G.setInterval){E[0]=G}else{while(F){E[--F]=G[F]}}}return E},inArray:function(G,H){for(var E=0,F=H.length;E0?this.clone(true):this).get();o.fn[F].apply(o(L[K]),I);J=J.concat(I)}return this.pushStack(J,E,G)}});o.each({removeAttr:function(E){o.attr(this,E,"");if(this.nodeType==1){this.removeAttribute(E)}},addClass:function(E){o.className.add(this,E)},removeClass:function(E){o.className.remove(this,E)},toggleClass:function(F,E){if(typeof E!=="boolean"){E=!o.className.has(this,F)}o.className[E?"add":"remove"](this,F)},remove:function(E){if(!E||o.filter(E,[this]).length){o("*",this).add([this]).each(function(){o.event.remove(this);o.removeData(this)});if(this.parentNode){this.parentNode.removeChild(this)}}},empty:function(){o(this).children().remove();while(this.firstChild){this.removeChild(this.firstChild)}}},function(E,F){o.fn[E]=function(){return this.each(F,arguments)}});function j(E,F){return E[0]&&parseInt(o.curCSS(E[0],F,true),10)||0}var h="jQuery"+e(),v=0,A={};o.extend({cache:{},data:function(F,E,G){F=F==l?A:F;var H=F[h];if(!H){H=F[h]=++v}if(E&&!o.cache[H]){o.cache[H]={}}if(G!==g){o.cache[H][E]=G}return E?o.cache[H][E]:H},removeData:function(F,E){F=F==l?A:F;var H=F[h];if(E){if(o.cache[H]){delete o.cache[H][E];E="";for(E in o.cache[H]){break}if(!E){o.removeData(F)}}}else{try{delete F[h]}catch(G){if(F.removeAttribute){F.removeAttribute(h)}}delete o.cache[H]}},queue:function(F,E,H){if(F){E=(E||"fx")+"queue";var G=o.data(F,E);if(!G||o.isArray(H)){G=o.data(F,E,o.makeArray(H))}else{if(H){G.push(H)}}}return G},dequeue:function(H,G){var E=o.queue(H,G),F=E.shift();if(!G||G==="fx"){F=E[0]}if(F!==g){F.call(H)}}});o.fn.extend({data:function(E,G){var H=E.split(".");H[1]=H[1]?"."+H[1]:"";if(G===g){var F=this.triggerHandler("getData"+H[1]+"!",[H[0]]);if(F===g&&this.length){F=o.data(this[0],E)}return F===g&&H[1]?this.data(H[0]):F}else{return this.trigger("setData"+H[1]+"!",[H[0],G]).each(function(){o.data(this,E,G)})}},removeData:function(E){return this.each(function(){o.removeData(this,E)})},queue:function(E,F){if(typeof E!=="string"){F=E;E="fx"}if(F===g){return o.queue(this[0],E)}return this.each(function(){var G=o.queue(this,E,F);if(E=="fx"&&G.length==1){G[0].call(this)}})},dequeue:function(E){return this.each(function(){o.dequeue(this,E)})}}); +/* + * Sizzle CSS Selector Engine - v0.9.3 + * Copyright 2009, The Dojo Foundation + * Released under the MIT, BSD, and GPL Licenses. + * More information: http://sizzlejs.com/ + */ +(function(){var R=/((?:\((?:\([^()]+\)|[^()]+)+\)|\[(?:\[[^[\]]*\]|['"][^'"]*['"]|[^[\]'"]+)+\]|\\.|[^ >+~,(\[\\]+)+|[>+~])(\s*,\s*)?/g,L=0,H=Object.prototype.toString;var F=function(Y,U,ab,ac){ab=ab||[];U=U||document;if(U.nodeType!==1&&U.nodeType!==9){return[]}if(!Y||typeof Y!=="string"){return ab}var Z=[],W,af,ai,T,ad,V,X=true;R.lastIndex=0;while((W=R.exec(Y))!==null){Z.push(W[1]);if(W[2]){V=RegExp.rightContext;break}}if(Z.length>1&&M.exec(Y)){if(Z.length===2&&I.relative[Z[0]]){af=J(Z[0]+Z[1],U)}else{af=I.relative[Z[0]]?[U]:F(Z.shift(),U);while(Z.length){Y=Z.shift();if(I.relative[Y]){Y+=Z.shift()}af=J(Y,af)}}}else{var ae=ac?{expr:Z.pop(),set:E(ac)}:F.find(Z.pop(),Z.length===1&&U.parentNode?U.parentNode:U,Q(U));af=F.filter(ae.expr,ae.set);if(Z.length>0){ai=E(af)}else{X=false}while(Z.length){var ah=Z.pop(),ag=ah;if(!I.relative[ah]){ah=""}else{ag=Z.pop()}if(ag==null){ag=U}I.relative[ah](ai,ag,Q(U))}}if(!ai){ai=af}if(!ai){throw"Syntax error, unrecognized expression: "+(ah||Y)}if(H.call(ai)==="[object Array]"){if(!X){ab.push.apply(ab,ai)}else{if(U.nodeType===1){for(var aa=0;ai[aa]!=null;aa++){if(ai[aa]&&(ai[aa]===true||ai[aa].nodeType===1&&K(U,ai[aa]))){ab.push(af[aa])}}}else{for(var aa=0;ai[aa]!=null;aa++){if(ai[aa]&&ai[aa].nodeType===1){ab.push(af[aa])}}}}}else{E(ai,ab)}if(V){F(V,U,ab,ac);if(G){hasDuplicate=false;ab.sort(G);if(hasDuplicate){for(var aa=1;aa":function(Z,U,aa){var X=typeof U==="string";if(X&&!/\W/.test(U)){U=aa?U:U.toUpperCase();for(var V=0,T=Z.length;V=0)){if(!V){T.push(Y)}}else{if(V){U[X]=false}}}}return false},ID:function(T){return T[1].replace(/\\/g,"")},TAG:function(U,T){for(var V=0;T[V]===false;V++){}return T[V]&&Q(T[V])?U[1]:U[1].toUpperCase()},CHILD:function(T){if(T[1]=="nth"){var U=/(-?)(\d*)n((?:\+|-)?\d*)/.exec(T[2]=="even"&&"2n"||T[2]=="odd"&&"2n+1"||!/\D/.test(T[2])&&"0n+"+T[2]||T[2]);T[2]=(U[1]+(U[2]||1))-0;T[3]=U[3]-0}T[0]=L++;return T},ATTR:function(X,U,V,T,Y,Z){var W=X[1].replace(/\\/g,"");if(!Z&&I.attrMap[W]){X[1]=I.attrMap[W]}if(X[2]==="~="){X[4]=" "+X[4]+" "}return X},PSEUDO:function(X,U,V,T,Y){if(X[1]==="not"){if(X[3].match(R).length>1||/^\w/.test(X[3])){X[3]=F(X[3],null,null,U)}else{var W=F.filter(X[3],U,V,true^Y);if(!V){T.push.apply(T,W)}return false}}else{if(I.match.POS.test(X[0])||I.match.CHILD.test(X[0])){return true}}return X},POS:function(T){T.unshift(true);return T}},filters:{enabled:function(T){return T.disabled===false&&T.type!=="hidden"},disabled:function(T){return T.disabled===true},checked:function(T){return T.checked===true},selected:function(T){T.parentNode.selectedIndex;return T.selected===true},parent:function(T){return !!T.firstChild},empty:function(T){return !T.firstChild},has:function(V,U,T){return !!F(T[3],V).length},header:function(T){return/h\d/i.test(T.nodeName)},text:function(T){return"text"===T.type},radio:function(T){return"radio"===T.type},checkbox:function(T){return"checkbox"===T.type},file:function(T){return"file"===T.type},password:function(T){return"password"===T.type},submit:function(T){return"submit"===T.type},image:function(T){return"image"===T.type},reset:function(T){return"reset"===T.type},button:function(T){return"button"===T.type||T.nodeName.toUpperCase()==="BUTTON"},input:function(T){return/input|select|textarea|button/i.test(T.nodeName)}},setFilters:{first:function(U,T){return T===0},last:function(V,U,T,W){return U===W.length-1},even:function(U,T){return T%2===0},odd:function(U,T){return T%2===1},lt:function(V,U,T){return UT[3]-0},nth:function(V,U,T){return T[3]-0==U},eq:function(V,U,T){return T[3]-0==U}},filter:{PSEUDO:function(Z,V,W,aa){var U=V[1],X=I.filters[U];if(X){return X(Z,W,V,aa)}else{if(U==="contains"){return(Z.textContent||Z.innerText||"").indexOf(V[3])>=0}else{if(U==="not"){var Y=V[3];for(var W=0,T=Y.length;W=0)}}},ID:function(U,T){return U.nodeType===1&&U.getAttribute("id")===T},TAG:function(U,T){return(T==="*"&&U.nodeType===1)||U.nodeName===T},CLASS:function(U,T){return(" "+(U.className||U.getAttribute("class"))+" ").indexOf(T)>-1},ATTR:function(Y,W){var V=W[1],T=I.attrHandle[V]?I.attrHandle[V](Y):Y[V]!=null?Y[V]:Y.getAttribute(V),Z=T+"",X=W[2],U=W[4];return T==null?X==="!=":X==="="?Z===U:X==="*="?Z.indexOf(U)>=0:X==="~="?(" "+Z+" ").indexOf(U)>=0:!U?Z&&T!==false:X==="!="?Z!=U:X==="^="?Z.indexOf(U)===0:X==="$="?Z.substr(Z.length-U.length)===U:X==="|="?Z===U||Z.substr(0,U.length+1)===U+"-":false},POS:function(X,U,V,Y){var T=U[2],W=I.setFilters[T];if(W){return W(X,V,U,Y)}}}};var M=I.match.POS;for(var O in I.match){I.match[O]=RegExp(I.match[O].source+/(?![^\[]*\])(?![^\(]*\))/.source)}var E=function(U,T){U=Array.prototype.slice.call(U);if(T){T.push.apply(T,U);return T}return U};try{Array.prototype.slice.call(document.documentElement.childNodes)}catch(N){E=function(X,W){var U=W||[];if(H.call(X)==="[object Array]"){Array.prototype.push.apply(U,X)}else{if(typeof X.length==="number"){for(var V=0,T=X.length;V";var T=document.documentElement;T.insertBefore(U,T.firstChild);if(!!document.getElementById(V)){I.find.ID=function(X,Y,Z){if(typeof Y.getElementById!=="undefined"&&!Z){var W=Y.getElementById(X[1]);return W?W.id===X[1]||typeof W.getAttributeNode!=="undefined"&&W.getAttributeNode("id").nodeValue===X[1]?[W]:g:[]}};I.filter.ID=function(Y,W){var X=typeof Y.getAttributeNode!=="undefined"&&Y.getAttributeNode("id");return Y.nodeType===1&&X&&X.nodeValue===W}}T.removeChild(U)})();(function(){var T=document.createElement("div");T.appendChild(document.createComment(""));if(T.getElementsByTagName("*").length>0){I.find.TAG=function(U,Y){var X=Y.getElementsByTagName(U[1]);if(U[1]==="*"){var W=[];for(var V=0;X[V];V++){if(X[V].nodeType===1){W.push(X[V])}}X=W}return X}}T.innerHTML="";if(T.firstChild&&typeof T.firstChild.getAttribute!=="undefined"&&T.firstChild.getAttribute("href")!=="#"){I.attrHandle.href=function(U){return U.getAttribute("href",2)}}})();if(document.querySelectorAll){(function(){var T=F,U=document.createElement("div");U.innerHTML="

    ";if(U.querySelectorAll&&U.querySelectorAll(".TEST").length===0){return}F=function(Y,X,V,W){X=X||document;if(!W&&X.nodeType===9&&!Q(X)){try{return E(X.querySelectorAll(Y),V)}catch(Z){}}return T(Y,X,V,W)};F.find=T.find;F.filter=T.filter;F.selectors=T.selectors;F.matches=T.matches})()}if(document.getElementsByClassName&&document.documentElement.getElementsByClassName){(function(){var T=document.createElement("div");T.innerHTML="
    ";if(T.getElementsByClassName("e").length===0){return}T.lastChild.className="e";if(T.getElementsByClassName("e").length===1){return}I.order.splice(1,0,"CLASS");I.find.CLASS=function(U,V,W){if(typeof V.getElementsByClassName!=="undefined"&&!W){return V.getElementsByClassName(U[1])}}})()}function P(U,Z,Y,ad,aa,ac){var ab=U=="previousSibling"&&!ac;for(var W=0,V=ad.length;W0){X=T;break}}}T=T[U]}ad[W]=X}}}var K=document.compareDocumentPosition?function(U,T){return U.compareDocumentPosition(T)&16}:function(U,T){return U!==T&&(U.contains?U.contains(T):true)};var Q=function(T){return T.nodeType===9&&T.documentElement.nodeName!=="HTML"||!!T.ownerDocument&&Q(T.ownerDocument)};var J=function(T,aa){var W=[],X="",Y,V=aa.nodeType?[aa]:aa;while((Y=I.match.PSEUDO.exec(T))){X+=Y[0];T=T.replace(I.match.PSEUDO,"")}T=I.relative[T]?T+"*":T;for(var Z=0,U=V.length;Z0||T.offsetHeight>0};F.selectors.filters.animated=function(T){return o.grep(o.timers,function(U){return T===U.elem}).length};o.multiFilter=function(V,T,U){if(U){V=":not("+V+")"}return F.matches(V,T)};o.dir=function(V,U){var T=[],W=V[U];while(W&&W!=document){if(W.nodeType==1){T.push(W)}W=W[U]}return T};o.nth=function(X,T,V,W){T=T||1;var U=0;for(;X;X=X[V]){if(X.nodeType==1&&++U==T){break}}return X};o.sibling=function(V,U){var T=[];for(;V;V=V.nextSibling){if(V.nodeType==1&&V!=U){T.push(V)}}return T};return;l.Sizzle=F})();o.event={add:function(I,F,H,K){if(I.nodeType==3||I.nodeType==8){return}if(I.setInterval&&I!=l){I=l}if(!H.guid){H.guid=this.guid++}if(K!==g){var G=H;H=this.proxy(G);H.data=K}var E=o.data(I,"events")||o.data(I,"events",{}),J=o.data(I,"handle")||o.data(I,"handle",function(){return typeof o!=="undefined"&&!o.event.triggered?o.event.handle.apply(arguments.callee.elem,arguments):g});J.elem=I;o.each(F.split(/\s+/),function(M,N){var O=N.split(".");N=O.shift();H.type=O.slice().sort().join(".");var L=E[N];if(o.event.specialAll[N]){o.event.specialAll[N].setup.call(I,K,O)}if(!L){L=E[N]={};if(!o.event.special[N]||o.event.special[N].setup.call(I,K,O)===false){if(I.addEventListener){I.addEventListener(N,J,false)}else{if(I.attachEvent){I.attachEvent("on"+N,J)}}}}L[H.guid]=H;o.event.global[N]=true});I=null},guid:1,global:{},remove:function(K,H,J){if(K.nodeType==3||K.nodeType==8){return}var G=o.data(K,"events"),F,E;if(G){if(H===g||(typeof H==="string"&&H.charAt(0)==".")){for(var I in G){this.remove(K,I+(H||""))}}else{if(H.type){J=H.handler;H=H.type}o.each(H.split(/\s+/),function(M,O){var Q=O.split(".");O=Q.shift();var N=RegExp("(^|\\.)"+Q.slice().sort().join(".*\\.")+"(\\.|$)");if(G[O]){if(J){delete G[O][J.guid]}else{for(var P in G[O]){if(N.test(G[O][P].type)){delete G[O][P]}}}if(o.event.specialAll[O]){o.event.specialAll[O].teardown.call(K,Q)}for(F in G[O]){break}if(!F){if(!o.event.special[O]||o.event.special[O].teardown.call(K,Q)===false){if(K.removeEventListener){K.removeEventListener(O,o.data(K,"handle"),false)}else{if(K.detachEvent){K.detachEvent("on"+O,o.data(K,"handle"))}}}F=null;delete G[O]}}})}for(F in G){break}if(!F){var L=o.data(K,"handle");if(L){L.elem=null}o.removeData(K,"events");o.removeData(K,"handle")}}},trigger:function(I,K,H,E){var G=I.type||I;if(!E){I=typeof I==="object"?I[h]?I:o.extend(o.Event(G),I):o.Event(G);if(G.indexOf("!")>=0){I.type=G=G.slice(0,-1);I.exclusive=true}if(!H){I.stopPropagation();if(this.global[G]){o.each(o.cache,function(){if(this.events&&this.events[G]){o.event.trigger(I,K,this.handle.elem)}})}}if(!H||H.nodeType==3||H.nodeType==8){return g}I.result=g;I.target=H;K=o.makeArray(K);K.unshift(I)}I.currentTarget=H;var J=o.data(H,"handle");if(J){J.apply(H,K)}if((!H[G]||(o.nodeName(H,"a")&&G=="click"))&&H["on"+G]&&H["on"+G].apply(H,K)===false){I.result=false}if(!E&&H[G]&&!I.isDefaultPrevented()&&!(o.nodeName(H,"a")&&G=="click")){this.triggered=true;try{H[G]()}catch(L){}}this.triggered=false;if(!I.isPropagationStopped()){var F=H.parentNode||H.ownerDocument;if(F){o.event.trigger(I,K,F,true)}}},handle:function(K){var J,E;K=arguments[0]=o.event.fix(K||l.event);K.currentTarget=this;var L=K.type.split(".");K.type=L.shift();J=!L.length&&!K.exclusive;var I=RegExp("(^|\\.)"+L.slice().sort().join(".*\\.")+"(\\.|$)");E=(o.data(this,"events")||{})[K.type];for(var G in E){var H=E[G];if(J||I.test(H.type)){K.handler=H;K.data=H.data;var F=H.apply(this,arguments);if(F!==g){K.result=F;if(F===false){K.preventDefault();K.stopPropagation()}}if(K.isImmediatePropagationStopped()){break}}}},props:"altKey attrChange attrName bubbles button cancelable charCode clientX clientY ctrlKey currentTarget data detail eventPhase fromElement handler keyCode metaKey newValue originalTarget pageX pageY prevValue relatedNode relatedTarget screenX screenY shiftKey srcElement target toElement view wheelDelta which".split(" "),fix:function(H){if(H[h]){return H}var F=H;H=o.Event(F);for(var G=this.props.length,J;G;){J=this.props[--G];H[J]=F[J]}if(!H.target){H.target=H.srcElement||document}if(H.target.nodeType==3){H.target=H.target.parentNode}if(!H.relatedTarget&&H.fromElement){H.relatedTarget=H.fromElement==H.target?H.toElement:H.fromElement}if(H.pageX==null&&H.clientX!=null){var I=document.documentElement,E=document.body;H.pageX=H.clientX+(I&&I.scrollLeft||E&&E.scrollLeft||0)-(I.clientLeft||0);H.pageY=H.clientY+(I&&I.scrollTop||E&&E.scrollTop||0)-(I.clientTop||0)}if(!H.which&&((H.charCode||H.charCode===0)?H.charCode:H.keyCode)){H.which=H.charCode||H.keyCode}if(!H.metaKey&&H.ctrlKey){H.metaKey=H.ctrlKey}if(!H.which&&H.button){H.which=(H.button&1?1:(H.button&2?3:(H.button&4?2:0)))}return H},proxy:function(F,E){E=E||function(){return F.apply(this,arguments)};E.guid=F.guid=F.guid||E.guid||this.guid++;return E},special:{ready:{setup:B,teardown:function(){}}},specialAll:{live:{setup:function(E,F){o.event.add(this,F[0],c)},teardown:function(G){if(G.length){var E=0,F=RegExp("(^|\\.)"+G[0]+"(\\.|$)");o.each((o.data(this,"events").live||{}),function(){if(F.test(this.type)){E++}});if(E<1){o.event.remove(this,G[0],c)}}}}}};o.Event=function(E){if(!this.preventDefault){return new o.Event(E)}if(E&&E.type){this.originalEvent=E;this.type=E.type}else{this.type=E}this.timeStamp=e();this[h]=true};function k(){return false}function u(){return true}o.Event.prototype={preventDefault:function(){this.isDefaultPrevented=u;var E=this.originalEvent;if(!E){return}if(E.preventDefault){E.preventDefault()}E.returnValue=false},stopPropagation:function(){this.isPropagationStopped=u;var E=this.originalEvent;if(!E){return}if(E.stopPropagation){E.stopPropagation()}E.cancelBubble=true},stopImmediatePropagation:function(){this.isImmediatePropagationStopped=u;this.stopPropagation()},isDefaultPrevented:k,isPropagationStopped:k,isImmediatePropagationStopped:k};var a=function(F){var E=F.relatedTarget;while(E&&E!=this){try{E=E.parentNode}catch(G){E=this}}if(E!=this){F.type=F.data;o.event.handle.apply(this,arguments)}};o.each({mouseover:"mouseenter",mouseout:"mouseleave"},function(F,E){o.event.special[E]={setup:function(){o.event.add(this,F,a,E)},teardown:function(){o.event.remove(this,F,a)}}});o.fn.extend({bind:function(F,G,E){return F=="unload"?this.one(F,G,E):this.each(function(){o.event.add(this,F,E||G,E&&G)})},one:function(G,H,F){var E=o.event.proxy(F||H,function(I){o(this).unbind(I,E);return(F||H).apply(this,arguments)});return this.each(function(){o.event.add(this,G,E,F&&H)})},unbind:function(F,E){return this.each(function(){o.event.remove(this,F,E)})},trigger:function(E,F){return this.each(function(){o.event.trigger(E,F,this)})},triggerHandler:function(E,G){if(this[0]){var F=o.Event(E);F.preventDefault();F.stopPropagation();o.event.trigger(F,G,this[0]);return F.result}},toggle:function(G){var E=arguments,F=1;while(F=0){var E=G.slice(I,G.length);G=G.slice(0,I)}var H="GET";if(J){if(o.isFunction(J)){K=J;J=null}else{if(typeof J==="object"){J=o.param(J);H="POST"}}}var F=this;o.ajax({url:G,type:H,dataType:"html",data:J,complete:function(M,L){if(L=="success"||L=="notmodified"){F.html(E?o("
    ").append(M.responseText.replace(//g,"")).find(E):M.responseText)}if(K){F.each(K,[M.responseText,L,M])}}});return this},serialize:function(){return o.param(this.serializeArray())},serializeArray:function(){return this.map(function(){return this.elements?o.makeArray(this.elements):this}).filter(function(){return this.name&&!this.disabled&&(this.checked||/select|textarea/i.test(this.nodeName)||/text|hidden|password|search/i.test(this.type))}).map(function(E,F){var G=o(this).val();return G==null?null:o.isArray(G)?o.map(G,function(I,H){return{name:F.name,value:I}}):{name:F.name,value:G}}).get()}});o.each("ajaxStart,ajaxStop,ajaxComplete,ajaxError,ajaxSuccess,ajaxSend".split(","),function(E,F){o.fn[F]=function(G){return this.bind(F,G)}});var r=e();o.extend({get:function(E,G,H,F){if(o.isFunction(G)){H=G;G=null}return o.ajax({type:"GET",url:E,data:G,success:H,dataType:F})},getScript:function(E,F){return o.get(E,null,F,"script")},getJSON:function(E,F,G){return o.get(E,F,G,"json")},post:function(E,G,H,F){if(o.isFunction(G)){H=G;G={}}return o.ajax({type:"POST",url:E,data:G,success:H,dataType:F})},ajaxSetup:function(E){o.extend(o.ajaxSettings,E)},ajaxSettings:{url:location.href,global:true,type:"GET",contentType:"application/x-www-form-urlencoded",processData:true,async:true,xhr:function(){return l.ActiveXObject?new ActiveXObject("Microsoft.XMLHTTP"):new XMLHttpRequest()},accepts:{xml:"application/xml, text/xml",html:"text/html",script:"text/javascript, application/javascript",json:"application/json, text/javascript",text:"text/plain",_default:"*/*"}},lastModified:{},ajax:function(M){M=o.extend(true,M,o.extend(true,{},o.ajaxSettings,M));var W,F=/=\?(&|$)/g,R,V,G=M.type.toUpperCase();if(M.data&&M.processData&&typeof M.data!=="string"){M.data=o.param(M.data)}if(M.dataType=="jsonp"){if(G=="GET"){if(!M.url.match(F)){M.url+=(M.url.match(/\?/)?"&":"?")+(M.jsonp||"callback")+"=?"}}else{if(!M.data||!M.data.match(F)){M.data=(M.data?M.data+"&":"")+(M.jsonp||"callback")+"=?"}}M.dataType="json"}if(M.dataType=="json"&&(M.data&&M.data.match(F)||M.url.match(F))){W="jsonp"+r++;if(M.data){M.data=(M.data+"").replace(F,"="+W+"$1")}M.url=M.url.replace(F,"="+W+"$1");M.dataType="script";l[W]=function(X){V=X;I();L();l[W]=g;try{delete l[W]}catch(Y){}if(H){H.removeChild(T)}}}if(M.dataType=="script"&&M.cache==null){M.cache=false}if(M.cache===false&&G=="GET"){var E=e();var U=M.url.replace(/(\?|&)_=.*?(&|$)/,"$1_="+E+"$2");M.url=U+((U==M.url)?(M.url.match(/\?/)?"&":"?")+"_="+E:"")}if(M.data&&G=="GET"){M.url+=(M.url.match(/\?/)?"&":"?")+M.data;M.data=null}if(M.global&&!o.active++){o.event.trigger("ajaxStart")}var Q=/^(\w+:)?\/\/([^\/?#]+)/.exec(M.url);if(M.dataType=="script"&&G=="GET"&&Q&&(Q[1]&&Q[1]!=location.protocol||Q[2]!=location.host)){var H=document.getElementsByTagName("head")[0];var T=document.createElement("script");T.src=M.url;if(M.scriptCharset){T.charset=M.scriptCharset}if(!W){var O=false;T.onload=T.onreadystatechange=function(){if(!O&&(!this.readyState||this.readyState=="loaded"||this.readyState=="complete")){O=true;I();L();T.onload=T.onreadystatechange=null;H.removeChild(T)}}}H.appendChild(T);return g}var K=false;var J=M.xhr();if(M.username){J.open(G,M.url,M.async,M.username,M.password)}else{J.open(G,M.url,M.async)}try{if(M.data){J.setRequestHeader("Content-Type",M.contentType)}if(M.ifModified){J.setRequestHeader("If-Modified-Since",o.lastModified[M.url]||"Thu, 01 Jan 1970 00:00:00 GMT")}J.setRequestHeader("X-Requested-With","XMLHttpRequest");J.setRequestHeader("Accept",M.dataType&&M.accepts[M.dataType]?M.accepts[M.dataType]+", */*":M.accepts._default)}catch(S){}if(M.beforeSend&&M.beforeSend(J,M)===false){if(M.global&&!--o.active){o.event.trigger("ajaxStop")}J.abort();return false}if(M.global){o.event.trigger("ajaxSend",[J,M])}var N=function(X){if(J.readyState==0){if(P){clearInterval(P);P=null;if(M.global&&!--o.active){o.event.trigger("ajaxStop")}}}else{if(!K&&J&&(J.readyState==4||X=="timeout")){K=true;if(P){clearInterval(P);P=null}R=X=="timeout"?"timeout":!o.httpSuccess(J)?"error":M.ifModified&&o.httpNotModified(J,M.url)?"notmodified":"success";if(R=="success"){try{V=o.httpData(J,M.dataType,M)}catch(Z){R="parsererror"}}if(R=="success"){var Y;try{Y=J.getResponseHeader("Last-Modified")}catch(Z){}if(M.ifModified&&Y){o.lastModified[M.url]=Y}if(!W){I()}}else{o.handleError(M,J,R)}L();if(X){J.abort()}if(M.async){J=null}}}};if(M.async){var P=setInterval(N,13);if(M.timeout>0){setTimeout(function(){if(J&&!K){N("timeout")}},M.timeout)}}try{J.send(M.data)}catch(S){o.handleError(M,J,null,S)}if(!M.async){N()}function I(){if(M.success){M.success(V,R)}if(M.global){o.event.trigger("ajaxSuccess",[J,M])}}function L(){if(M.complete){M.complete(J,R)}if(M.global){o.event.trigger("ajaxComplete",[J,M])}if(M.global&&!--o.active){o.event.trigger("ajaxStop")}}return J},handleError:function(F,H,E,G){if(F.error){F.error(H,E,G)}if(F.global){o.event.trigger("ajaxError",[H,F,G])}},active:0,httpSuccess:function(F){try{return !F.status&&location.protocol=="file:"||(F.status>=200&&F.status<300)||F.status==304||F.status==1223}catch(E){}return false},httpNotModified:function(G,E){try{var H=G.getResponseHeader("Last-Modified");return G.status==304||H==o.lastModified[E]}catch(F){}return false},httpData:function(J,H,G){var F=J.getResponseHeader("content-type"),E=H=="xml"||!H&&F&&F.indexOf("xml")>=0,I=E?J.responseXML:J.responseText;if(E&&I.documentElement.tagName=="parsererror"){throw"parsererror"}if(G&&G.dataFilter){I=G.dataFilter(I,H)}if(typeof I==="string"){if(H=="script"){o.globalEval(I)}if(H=="json"){I=l["eval"]("("+I+")")}}return I},param:function(E){var G=[];function H(I,J){G[G.length]=encodeURIComponent(I)+"="+encodeURIComponent(J)}if(o.isArray(E)||E.jquery){o.each(E,function(){H(this.name,this.value)})}else{for(var F in E){if(o.isArray(E[F])){o.each(E[F],function(){H(F,this)})}else{H(F,o.isFunction(E[F])?E[F]():E[F])}}}return G.join("&").replace(/%20/g,"+")}});var m={},n,d=[["height","marginTop","marginBottom","paddingTop","paddingBottom"],["width","marginLeft","marginRight","paddingLeft","paddingRight"],["opacity"]];function t(F,E){var G={};o.each(d.concat.apply([],d.slice(0,E)),function(){G[this]=F});return G}o.fn.extend({show:function(J,L){if(J){return this.animate(t("show",3),J,L)}else{for(var H=0,F=this.length;H").appendTo("body");K=I.css("display");if(K==="none"){K="block"}I.remove();m[G]=K}o.data(this[H],"olddisplay",K)}}for(var H=0,F=this.length;H=0;H--){if(G[H].elem==this){if(E){G[H](true)}G.splice(H,1)}}});if(!E){this.dequeue()}return this}});o.each({slideDown:t("show",1),slideUp:t("hide",1),slideToggle:t("toggle",1),fadeIn:{opacity:"show"},fadeOut:{opacity:"hide"}},function(E,F){o.fn[E]=function(G,H){return this.animate(F,G,H)}});o.extend({speed:function(G,H,F){var E=typeof G==="object"?G:{complete:F||!F&&H||o.isFunction(G)&&G,duration:G,easing:F&&H||H&&!o.isFunction(H)&&H};E.duration=o.fx.off?0:typeof E.duration==="number"?E.duration:o.fx.speeds[E.duration]||o.fx.speeds._default;E.old=E.complete;E.complete=function(){if(E.queue!==false){o(this).dequeue()}if(o.isFunction(E.old)){E.old.call(this)}};return E},easing:{linear:function(G,H,E,F){return E+F*G},swing:function(G,H,E,F){return((-Math.cos(G*Math.PI)/2)+0.5)*F+E}},timers:[],fx:function(F,E,G){this.options=E;this.elem=F;this.prop=G;if(!E.orig){E.orig={}}}});o.fx.prototype={update:function(){if(this.options.step){this.options.step.call(this.elem,this.now,this)}(o.fx.step[this.prop]||o.fx.step._default)(this);if((this.prop=="height"||this.prop=="width")&&this.elem.style){this.elem.style.display="block"}},cur:function(F){if(this.elem[this.prop]!=null&&(!this.elem.style||this.elem.style[this.prop]==null)){return this.elem[this.prop]}var E=parseFloat(o.css(this.elem,this.prop,F));return E&&E>-10000?E:parseFloat(o.curCSS(this.elem,this.prop))||0},custom:function(I,H,G){this.startTime=e();this.start=I;this.end=H;this.unit=G||this.unit||"px";this.now=this.start;this.pos=this.state=0;var E=this;function F(J){return E.step(J)}F.elem=this.elem;if(F()&&o.timers.push(F)&&!n){n=setInterval(function(){var K=o.timers;for(var J=0;J=this.options.duration+this.startTime){this.now=this.end;this.pos=this.state=1;this.update();this.options.curAnim[this.prop]=true;var E=true;for(var F in this.options.curAnim){if(this.options.curAnim[F]!==true){E=false}}if(E){if(this.options.display!=null){this.elem.style.overflow=this.options.overflow;this.elem.style.display=this.options.display;if(o.css(this.elem,"display")=="none"){this.elem.style.display="block"}}if(this.options.hide){o(this.elem).hide()}if(this.options.hide||this.options.show){for(var I in this.options.curAnim){o.attr(this.elem.style,I,this.options.orig[I])}}this.options.complete.call(this.elem)}return false}else{var J=G-this.startTime;this.state=J/this.options.duration;this.pos=o.easing[this.options.easing||(o.easing.swing?"swing":"linear")](this.state,J,0,1,this.options.duration);this.now=this.start+((this.end-this.start)*this.pos);this.update()}return true}};o.extend(o.fx,{speeds:{slow:600,fast:200,_default:400},step:{opacity:function(E){o.attr(E.elem.style,"opacity",E.now)},_default:function(E){if(E.elem.style&&E.elem.style[E.prop]!=null){E.elem.style[E.prop]=E.now+E.unit}else{E.elem[E.prop]=E.now}}}});if(document.documentElement.getBoundingClientRect){o.fn.offset=function(){if(!this[0]){return{top:0,left:0}}if(this[0]===this[0].ownerDocument.body){return o.offset.bodyOffset(this[0])}var G=this[0].getBoundingClientRect(),J=this[0].ownerDocument,F=J.body,E=J.documentElement,L=E.clientTop||F.clientTop||0,K=E.clientLeft||F.clientLeft||0,I=G.top+(self.pageYOffset||o.boxModel&&E.scrollTop||F.scrollTop)-L,H=G.left+(self.pageXOffset||o.boxModel&&E.scrollLeft||F.scrollLeft)-K;return{top:I,left:H}}}else{o.fn.offset=function(){if(!this[0]){return{top:0,left:0}}if(this[0]===this[0].ownerDocument.body){return o.offset.bodyOffset(this[0])}o.offset.initialized||o.offset.initialize();var J=this[0],G=J.offsetParent,F=J,O=J.ownerDocument,M,H=O.documentElement,K=O.body,L=O.defaultView,E=L.getComputedStyle(J,null),N=J.offsetTop,I=J.offsetLeft;while((J=J.parentNode)&&J!==K&&J!==H){M=L.getComputedStyle(J,null);N-=J.scrollTop,I-=J.scrollLeft;if(J===G){N+=J.offsetTop,I+=J.offsetLeft;if(o.offset.doesNotAddBorder&&!(o.offset.doesAddBorderForTableAndCells&&/^t(able|d|h)$/i.test(J.tagName))){N+=parseInt(M.borderTopWidth,10)||0,I+=parseInt(M.borderLeftWidth,10)||0}F=G,G=J.offsetParent}if(o.offset.subtractsBorderForOverflowNotVisible&&M.overflow!=="visible"){N+=parseInt(M.borderTopWidth,10)||0,I+=parseInt(M.borderLeftWidth,10)||0}E=M}if(E.position==="relative"||E.position==="static"){N+=K.offsetTop,I+=K.offsetLeft}if(E.position==="fixed"){N+=Math.max(H.scrollTop,K.scrollTop),I+=Math.max(H.scrollLeft,K.scrollLeft)}return{top:N,left:I}}}o.offset={initialize:function(){if(this.initialized){return}var L=document.body,F=document.createElement("div"),H,G,N,I,M,E,J=L.style.marginTop,K='
    ';M={position:"absolute",top:0,left:0,margin:0,border:0,width:"1px",height:"1px",visibility:"hidden"};for(E in M){F.style[E]=M[E]}F.innerHTML=K;L.insertBefore(F,L.firstChild);H=F.firstChild,G=H.firstChild,I=H.nextSibling.firstChild.firstChild;this.doesNotAddBorder=(G.offsetTop!==5);this.doesAddBorderForTableAndCells=(I.offsetTop===5);H.style.overflow="hidden",H.style.position="relative";this.subtractsBorderForOverflowNotVisible=(G.offsetTop===-5);L.style.marginTop="1px";this.doesNotIncludeMarginInBodyOffset=(L.offsetTop===0);L.style.marginTop=J;L.removeChild(F);this.initialized=true},bodyOffset:function(E){o.offset.initialized||o.offset.initialize();var G=E.offsetTop,F=E.offsetLeft;if(o.offset.doesNotIncludeMarginInBodyOffset){G+=parseInt(o.curCSS(E,"marginTop",true),10)||0,F+=parseInt(o.curCSS(E,"marginLeft",true),10)||0}return{top:G,left:F}}};o.fn.extend({position:function(){var I=0,H=0,F;if(this[0]){var G=this.offsetParent(),J=this.offset(),E=/^body|html$/i.test(G[0].tagName)?{top:0,left:0}:G.offset();J.top-=j(this,"marginTop");J.left-=j(this,"marginLeft");E.top+=j(G,"borderTopWidth");E.left+=j(G,"borderLeftWidth");F={top:J.top-E.top,left:J.left-E.left}}return F},offsetParent:function(){var E=this[0].offsetParent||document.body;while(E&&(!/^body|html$/i.test(E.tagName)&&o.css(E,"position")=="static")){E=E.offsetParent}return o(E)}});o.each(["Left","Top"],function(F,E){var G="scroll"+E;o.fn[G]=function(H){if(!this[0]){return null}return H!==g?this.each(function(){this==l||this==document?l.scrollTo(!F?H:o(l).scrollLeft(),F?H:o(l).scrollTop()):this[G]=H}):this[0]==l||this[0]==document?self[F?"pageYOffset":"pageXOffset"]||o.boxModel&&document.documentElement[G]||document.body[G]:this[0][G]}});o.each(["Height","Width"],function(I,G){var E=I?"Left":"Top",H=I?"Right":"Bottom",F=G.toLowerCase();o.fn["inner"+G]=function(){return this[0]?o.css(this[0],F,false,"padding"):null};o.fn["outer"+G]=function(K){return this[0]?o.css(this[0],F,false,K?"margin":"border"):null};var J=G.toLowerCase();o.fn[J]=function(K){return this[0]==l?document.compatMode=="CSS1Compat"&&document.documentElement["client"+G]||document.body["client"+G]:this[0]==document?Math.max(document.documentElement["client"+G],document.body["scroll"+G],document.documentElement["scroll"+G],document.body["offset"+G],document.documentElement["offset"+G]):K===g?(this.length?o.css(this[0],J):null):this.css(J,typeof K==="string"?K:K+"px")}})})(); \ No newline at end of file From 33743c1a3d0a240ca6150ac872b4eab80d32b1db Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 24 Apr 2009 14:49:31 -0500 Subject: [PATCH 500/772] refactor io.directories.search --- .../io/directories/search/search-docs.factor | 4 +- basis/io/directories/search/search.factor | 98 +++++++++++-------- 2 files changed, 58 insertions(+), 44 deletions(-) diff --git a/basis/io/directories/search/search-docs.factor b/basis/io/directories/search/search-docs.factor index 818899606d..fb172b78e0 100644 --- a/basis/io/directories/search/search-docs.factor +++ b/basis/io/directories/search/search-docs.factor @@ -41,11 +41,11 @@ HELP: find-all-files { "path" "a pathname string" } { "quot" quotation } { "paths/f" "a sequence of pathname strings or f" } } -{ $description "Finds all files in the input directory matching the predicate quotation in a breadth-first or depth-first traversal." } ; +{ $description "Recursively finds all files in the input directory matching the predicate quotation." } ; HELP: find-all-in-directories { $values - { "directories" "a sequence of directory paths" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation } + { "directories" "a sequence of directory paths" } { "quot" quotation } { "paths/f" "a sequence of pathname strings or f" } } { $description "Finds all files in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ; diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 87fbf67110..440c3a0326 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -3,7 +3,7 @@ USING: accessors arrays continuations deques dlists fry io.directories io.files io.files.info io.pathnames kernel sequences system vocabs.loader locals math namespaces -sorting assocs calendar threads ; +sorting assocs calendar threads io math.parser ; IN: io.directories.search : qualified-directory-entries ( path -- seq ) @@ -13,12 +13,17 @@ IN: io.directories.search : qualified-directory-files ( path -- seq ) dup directory-files [ append-path ] with map ; +: with-qualified-directory-files ( path quot -- ) + '[ "" qualified-directory-files @ ] with-directory ; inline + +: with-qualified-directory-entries ( path quot -- ) + '[ "" qualified-directory-entries @ ] with-directory ; inline + > ] when ] dip +: push-directory-entries ( path iter -- ) [ qualified-directory-entries ] dip '[ _ [ queue>> ] [ bfs>> ] bi [ push-front ] [ push-back ] if @@ -26,77 +31,86 @@ TUPLE: directory-iterator path bfs queue ; : ( path bfs? -- iterator ) directory-iterator boa - dup path>> over push-directory ; + dup path>> over push-directory-entries ; -: next-file ( iter -- file/f ) +: next-directory-entry ( iter -- directory-entry/f ) dup queue>> deque-empty? [ drop f ] [ - dup queue>> pop-back dup directory? - [ over push-directory next-file ] - [ nip name>> ] if - ] if ; + dup queue>> pop-back + dup directory? + [ name>> over push-directory-entries next-directory-entry ] + [ nip ] if + ] if ; recursive -:: iterate-directory ( iter quot: ( obj -- ? ) -- obj ) - iter next-file [ - quot call [ iter quot iterate-directory ] unless* +:: iterate-directory-entries ( iter quot -- directory-entry/f ) + iter next-directory-entry [ + quot call( obj -- obj ) [ iter quot iterate-directory-entries ] unless* ] [ f ] if* ; inline recursive +: iterate-directory ( iter quot -- path/f ) + [ name>> ] prepose iterate-directory-entries ; + +: setup-traversal ( path bfs quot -- iterator quot' ) + [ ] dip [ f ] compose ; + PRIVATE> -: each-file ( path bfs? quot: ( obj -- ) -- ) - [ ] dip - [ f ] compose iterate-directory drop ; inline +: each-file ( path bfs? quot -- ) + setup-traversal [ name>> ] prepose + iterate-directory-entries drop ; inline -: recursive-directory ( path bfs? -- paths ) +: each-directory-entry ( path bfs? quot -- ) + setup-traversal iterate-directory-entries drop ; + +: recursive-directory-files ( path bfs? -- paths ) [ ] accumulator [ each-file ] dip ; -: find-file ( path bfs? quot: ( obj -- ? ) -- path/f ) +: recursive-directory-entries ( path bfs? -- paths ) + [ ] accumulator [ each-directory-entry ] dip ; + +: find-file ( path bfs? quot -- path/f ) '[ _ _ _ [ ] dip [ keep and ] curry iterate-directory - ] [ drop f ] recover ; inline + ] [ drop f ] recover ; -: find-all-files ( path quot: ( obj -- ? ) -- paths/f ) - f swap +: find-all-files ( path quot -- paths/f ) '[ - _ _ _ [ ] dip + _ _ [ f ] dip pusher [ [ f ] compose iterate-directory drop ] dip - ] [ drop f ] recover ; inline + ] [ drop f ] recover ; -ERROR: file-not-found ; +ERROR: file-not-found path bfs? quot ; -: find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path'/f ) +: find-file-throws ( path bfs? quot -- path ) + 3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; + +: find-in-directories ( directories bfs? quot -- path'/f ) '[ - _ [ _ _ find-file [ file-not-found ] unless* ] attempt-all + _ [ _ _ find-file-throws ] attempt-all ] [ drop f - ] recover ; inline + ] recover ; -: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f ) - '[ _ _ find-all-files ] map concat ; inline +: find-all-in-directories ( directories quot -- paths/f ) + '[ _ find-all-files ] map concat ; -: with-qualified-directory-files ( path quot -- ) - '[ "" qualified-directory-files @ ] with-directory ; inline - -: with-qualified-directory-entries ( path quot -- ) - '[ "" qualified-directory-entries @ ] with-directory ; inline +: link-size/0 ( path -- n ) + [ link-info size-on-disk>> ] [ 2drop 0 ] recover ; : directory-size ( path -- n ) - 0 swap t [ - [ link-info size-on-disk>> + ] [ 2drop ] recover - ] each-file ; + 0 swap t [ link-size/0 + ] each-file ; : path>usage ( directory-entry -- name size ) - [ name>> dup ] [ directory? ] bi [ - directory-size - ] [ - [ link-info size-on-disk>> ] [ 2drop 0 ] recover - ] if ; + [ name>> dup ] [ directory? ] bi + [ directory-size ] [ link-size/0 ] if ; : directory-usage ( path -- assoc ) [ - [ [ path>usage ] [ drop name>> 0 ] recover ] { } map>assoc + [ + [ path>usage ] [ drop name>> 0 ] recover + ] { } map>assoc ] with-qualified-directory-entries sort-values ; os windows? [ "io.directories.search.windows" require ] when From ad19fd7cbd94b80da080d4ca07590c855b707c8e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 24 Apr 2009 15:02:53 -0500 Subject: [PATCH 501/772] Web 2.0 style assoc syntax. H{ "foo" => 1 "bar" => { 2 3 } } --- extra/pair-rocket/authors.txt | 1 + extra/pair-rocket/pair-rocket-docs.factor | 15 +++++++++++++++ extra/pair-rocket/pair-rocket-tests.factor | 9 +++++++++ extra/pair-rocket/pair-rocket.factor | 6 ++++++ extra/pair-rocket/summary.txt | 1 + 5 files changed, 32 insertions(+) create mode 100644 extra/pair-rocket/authors.txt create mode 100644 extra/pair-rocket/pair-rocket-docs.factor create mode 100644 extra/pair-rocket/pair-rocket-tests.factor create mode 100644 extra/pair-rocket/pair-rocket.factor create mode 100644 extra/pair-rocket/summary.txt diff --git a/extra/pair-rocket/authors.txt b/extra/pair-rocket/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/pair-rocket/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/pair-rocket/pair-rocket-docs.factor b/extra/pair-rocket/pair-rocket-docs.factor new file mode 100644 index 0000000000..d66df62347 --- /dev/null +++ b/extra/pair-rocket/pair-rocket-docs.factor @@ -0,0 +1,15 @@ +! (c)2009 Joe Groff bsd license +USING: help.markup help.syntax multiline ; +IN: pair-rocket + +HELP: => +{ $syntax "a => b" } +{ $description "Constructs a two-element array from the objects immediately before and after the " { $snippet "=>" } ". This syntax can be used inside sequence and assoc literals." } +{ $examples +{ $unchecked-example <" USING: pair-rocket prettyprint ; + +H{ "foo" => 1 "bar" => 2 } . +"> <" H{ { "foo" 1 } { "bar" 2 } } "> } +} +; + diff --git a/extra/pair-rocket/pair-rocket-tests.factor b/extra/pair-rocket/pair-rocket-tests.factor new file mode 100644 index 0000000000..0e3d27beb1 --- /dev/null +++ b/extra/pair-rocket/pair-rocket-tests.factor @@ -0,0 +1,9 @@ +USING: kernel pair-rocket tools.test ; +IN: pair-rocket.tests + +[ { "a" 1 } ] [ "a" => 1 ] unit-test +[ { { "a" } { 1 } } ] [ { "a" } => { 1 } ] unit-test +[ { drop 1 } ] [ drop => 1 ] unit-test + +[ H{ { "zippity" 5 } { "doo" 2 } { "dah" 7 } } ] +[ H{ "zippity" => 5 "doo" => 2 "dah" => 7 } ] unit-test diff --git a/extra/pair-rocket/pair-rocket.factor b/extra/pair-rocket/pair-rocket.factor new file mode 100644 index 0000000000..3bd8a098f6 --- /dev/null +++ b/extra/pair-rocket/pair-rocket.factor @@ -0,0 +1,6 @@ +! (c)2009 Joe Groff bsd license +USING: arrays kernel parser sequences ; +IN: pair-rocket + +SYNTAX: => dup pop scan-object 2array parsed ; + diff --git a/extra/pair-rocket/summary.txt b/extra/pair-rocket/summary.txt new file mode 100644 index 0000000000..79c8d60149 --- /dev/null +++ b/extra/pair-rocket/summary.txt @@ -0,0 +1 @@ +H{ "foo" => 1 "bar" => 2 } style literal syntax From e4055005ea0cbdfda801f507761fb1d1652f4147 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Fri, 24 Apr 2009 22:03:38 +0200 Subject: [PATCH 502/772] FUEL: Fixes for string highlighting. --- misc/fuel/fuel-syntax.el | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 6b646511ca..61aa2b7cdd 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -241,18 +241,17 @@ table)) (defconst fuel-syntax--syntactic-keywords - `(;; Comments - ("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">")) - ("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">")) - ;; Strings and chars - ("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)" - (1 "w") (2 "\"") (4 "\"")) - ("\\(CHAR:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w")) - ("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" - (3 "\"") (5 "\"")) - ("\\_<\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" (1 "\"") (3 "\"")) + `(;; Strings and chars ("\\_<<\\(\"\\)\\_>" (1 "\\_>" (1 ">b")) + ("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)?\\(\"\\)\\(\\([^\n\r\f\"\\]\\|\\\\.\\)*\\)\\(\"\\)" + (3 "\"") (6 "\"")) + ("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)" + (1 "w") (2 "b")) + ("\\(CHAR:\\|\\\\\\) \\(\\w\\|!\\)\\( \\|$\\)" (2 "w")) + ;; Comments + ("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">")) + ("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">")) ;; postpone ("\\_b")) ;; Multiline constructs From 9b19b341268834751631f1ae69ce870672b33046 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Fri, 24 Apr 2009 22:15:20 +0200 Subject: [PATCH 503/772] FUEL: Fix for C-cC-eC-l (make factor command ( -- )). --- misc/fuel/fuel-mode.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index aa9a7d944e..0186392f34 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -140,7 +140,7 @@ for details." (interactive) (message "Loading all vocabularies in USING: form ...") (let ((err (fuel-eval--retort-error - (fuel-eval--send/wait '(:fuel* (t) t :usings) 120000)))) + (fuel-eval--send/wait '(:fuel* (t .) t :usings) 120000)))) (message (if err "Warning: some vocabularies failed to load" "All vocabularies loaded")))) From c3c51e2c60d6409b95e237c9f1dd559b1fbdff6c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 24 Apr 2009 15:22:12 -0500 Subject: [PATCH 504/772] more tests for io.directories.search, fix docs, refactoring --- .../io/directories/search/search-docs.factor | 12 ++++++++-- .../io/directories/search/search-tests.factor | 23 ++++++++++++++++--- basis/io/directories/search/search.factor | 13 ++++------- 3 files changed, 35 insertions(+), 13 deletions(-) diff --git a/basis/io/directories/search/search-docs.factor b/basis/io/directories/search/search-docs.factor index fb172b78e0..a6c82a1bff 100644 --- a/basis/io/directories/search/search-docs.factor +++ b/basis/io/directories/search/search-docs.factor @@ -15,13 +15,20 @@ HELP: each-file } } ; -HELP: recursive-directory +HELP: recursive-directory-files { $values { "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } { "paths" "a sequence of pathname strings" } } { $description "Traverses a directory path recursively and returns a sequence of files in a breadth-first or depth-first manner." } ; +HELP: recursive-directory-entries +{ $values + { "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } + { "directory-entries" "a sequence of directory-entries" } +} +{ $description "Traverses a directory path recursively and returns a sequence of directory-entries in a breadth-first or depth-first manner." } ; + HELP: find-file { $values { "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation } @@ -55,7 +62,8 @@ HELP: find-all-in-directories ARTICLE: "io.directories.search" "Searching directories" "The " { $vocab-link "io.directories.search" } " vocabulary contains words used for recursively iterating over a directory and for finding files in a directory tree." $nl "Traversing directories:" -{ $subsection recursive-directory } +{ $subsection recursive-directory-files } +{ $subsection recursive-directory-entries } { $subsection each-file } "Finding files:" { $subsection find-file } diff --git a/basis/io/directories/search/search-tests.factor b/basis/io/directories/search/search-tests.factor index 5281ca9c2b..db4b58c4fd 100644 --- a/basis/io/directories/search/search-tests.factor +++ b/basis/io/directories/search/search-tests.factor @@ -1,12 +1,14 @@ -USING: io.directories.search io.files io.files.unique -io.pathnames kernel namespaces sequences sorting tools.test ; +USING: combinators.smart io.directories +io.directories.hierarchy io.directories.search io.files +io.files.unique io.pathnames kernel namespaces sequences +sorting strings tools.test ; IN: io.directories.search.tests [ t ] [ [ 10 [ "io.paths.test" "gogogo" make-unique-file ] replicate current-temporary-directory get [ ] find-all-files - ] with-unique-directory drop [ natural-sort ] bi@ = + ] cleanup-unique-directory [ natural-sort ] bi@ = ] unit-test [ f ] [ @@ -18,3 +20,18 @@ IN: io.directories.search.tests [ f ] [ { } t [ "asdfasdfasdfasdfasdf" tail? ] find-in-directories ] unit-test + +[ t ] [ + [ + current-temporary-directory get + "the-head" unique-file drop t + [ file-name "the-head" head? ] find-file string? + ] cleanup-unique-directory +] unit-test + +[ t ] [ + [ unique-directory unique-directory ] output>array + [ [ "abcd" append-path touch-file ] each ] + [ [ file-name "abcd" = ] find-all-in-directories length 2 = ] + [ [ delete-tree ] each ] tri +] unit-test diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 440c3a0326..dc97d4fe45 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -43,7 +43,8 @@ TUPLE: directory-iterator path bfs queue ; :: iterate-directory-entries ( iter quot -- directory-entry/f ) iter next-directory-entry [ - quot call( obj -- obj ) [ iter quot iterate-directory-entries ] unless* + quot call( obj -- obj ) + [ iter quot iterate-directory-entries ] unless* ] [ f ] if* ; inline recursive @@ -57,8 +58,7 @@ TUPLE: directory-iterator path bfs queue ; PRIVATE> : each-file ( path bfs? quot -- ) - setup-traversal [ name>> ] prepose - iterate-directory-entries drop ; inline + setup-traversal iterate-directory drop ; : each-directory-entry ( path bfs? quot -- ) setup-traversal iterate-directory-entries drop ; @@ -87,11 +87,8 @@ ERROR: file-not-found path bfs? quot ; 3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; : find-in-directories ( directories bfs? quot -- path'/f ) - '[ - _ [ _ _ find-file-throws ] attempt-all - ] [ - drop f - ] recover ; + '[ _ [ _ _ find-file-throws ] attempt-all ] + [ drop f ] recover ; : find-all-in-directories ( directories quot -- paths/f ) '[ _ find-all-files ] map concat ; From 8c5b0373a83955d0f94b86055c6a3623145d8e79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 15:31:06 -0500 Subject: [PATCH 505/772] Working on new method dispatch system --- Makefile | 3 +- .../known-words/known-words.factor | 3 + core/bootstrap/primitives.factor | 2 + core/generic/standard/compiler/authors.txt | 1 + .../generic/standard/compiler/compiler.factor | 174 ++++++++++++++++++ vm/data_heap.c | 2 +- vm/dispatch.c | 108 +++++++++++ vm/dispatch.h | 1 + vm/layouts.h | 2 +- vm/master.h | 1 + vm/primitives.c | 3 +- 11 files changed, 296 insertions(+), 4 deletions(-) create mode 100644 core/generic/standard/compiler/authors.txt create mode 100644 core/generic/standard/compiler/compiler.factor create mode 100644 vm/dispatch.c create mode 100644 vm/dispatch.h diff --git a/Makefile b/Makefile index 35a5ba58bf..511c191711 100644 --- a/Makefile +++ b/Makefile @@ -35,6 +35,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/data_gc.o \ vm/data_heap.o \ vm/debug.o \ + vm/dispatch.o \ vm/errors.o \ vm/factor.o \ vm/image.o \ @@ -182,5 +183,5 @@ vm/ffi_test.o: vm/ffi_test.c .m.o: $(CC) -c $(CFLAGS) -o $@ $< - + .PHONY: factor diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index eade33e52b..ab205b4a16 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -12,6 +12,7 @@ classes.tuple.private vectors vectors.private words definitions words.private assocs summary compiler.units system.private combinators locals locals.backend locals.types words.private quotations.private combinators.private stack-checker.values +generic.standard.private alien.libraries stack-checker.alien stack-checker.state @@ -676,3 +677,5 @@ M: object infer-call* \ gc-stats { } { array } define-primitive \ jit-compile { quotation } { } define-primitive + +\ lookup-method { object array } { word } define-primitive \ No newline at end of file diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 1258da8a4d..a8e23cd336 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -69,6 +69,7 @@ bootstrapping? on "classes.predicate" "compiler.units" "continuations.private" + "generic.standard.private" "growable" "hashtables" "hashtables.private" @@ -532,6 +533,7 @@ tuple { "jit-compile" "quotations" (( quot -- )) } { "load-locals" "locals.backend" (( ... n -- )) } { "check-datastack" "kernel.private" (( array in# out# -- ? )) } + { "lookup-method" "generic.standard.private" (( object methods -- method )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number diff --git a/core/generic/standard/compiler/authors.txt b/core/generic/standard/compiler/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/core/generic/standard/compiler/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/core/generic/standard/compiler/compiler.factor b/core/generic/standard/compiler/compiler.factor new file mode 100644 index 0000000000..0456918b49 --- /dev/null +++ b/core/generic/standard/compiler/compiler.factor @@ -0,0 +1,174 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs classes.algebra math combinators +generic.standard.engines hashtables kernel kernel.private layouts +namespaces sequences words sorting quotations effects +generic.standard.private words.private ; +IN: generic.standard.compiler + +! ! ! Build an engine ! ! ! + +! 1. Flatten methods +TUPLE: predicate-engine methods ; + +: ( methods -- engine ) predicate-engine boa ; + +: push-method ( method specializer atomic assoc -- ) + [ + [ H{ } clone ] unless* + [ methods>> set-at ] keep + ] change-at ; + +: flatten-method ( class method assoc -- ) + [ [ flatten-class keys ] keep ] 2dip [ + [ spin ] dip push-method + ] 3curry each ; + +: flatten-methods ( assoc -- assoc' ) + H{ } clone [ [ flatten-method ] curry assoc-each ] keep ; + +! 2. Convert methods +: convert-methods ( assoc class word -- assoc' ) + over [ split-methods ] 2dip pick assoc-empty? + [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline + +! 2.1 Convert tuple methods +TUPLE: echelon-dispatch-engine n methods ; + +C: echelon-dispatch-engine + +TUPLE: tuple-dispatch-engine echelons ; + +: push-echelon ( class method assoc -- ) + [ swap dup "layout" word-prop third ] dip + [ ?set-at ] change-at ; + +: echelon-sort ( assoc -- assoc' ) + H{ } clone [ [ push-echelon ] curry assoc-each ] keep ; + +: ( methods -- engine ) + echelon-sort + [ dupd ] assoc-map + \ tuple-dispatch-engine boa ; + +: convert-tuple-methods ( assoc -- assoc' ) + tuple bootstrap-word + \ convert-methods ; + +! 2.2 Convert hi-tag methods +TUPLE: hi-tag-dispatch-engine methods ; + +C: hi-tag-dispatch-engine + +: convert-hi-tag-methods ( assoc -- assoc' ) + \ hi-tag bootstrap-word + \ convert-methods ; + +! 3 Tag methods +TUPLE: tag-dispatch-engine methods ; + +C: tag-dispatch-engine + +: ( assoc -- engine ) + flatten-methods + convert-tuple-methods + convert-hi-tag-methods + ; + +! ! ! Compile engine ! ! ! +SYMBOL: assumed +SYMBOL: default +SYMBOL: generic-word + +GENERIC: compile-engine ( engine -- obj ) + +: compile-engines ( assoc -- assoc' ) + [ compile-engine ] assoc-map ; + +: compile-engines* ( assoc -- assoc' ) + [ over assumed [ compile-engine ] with-variable ] assoc-map ; + +: direct-dispatch-table ( assoc n -- table ) + default get [ swap update ] keep ; + +M: tag-dispatch-engine compile-engine + methods>> compile-engines* + [ [ tag-number ] dip ] assoc-map + num-tags get direct-dispatch-table ; + +: hi-tag-number ( class -- n ) "type" word-prop ; + +: num-hi-tags ( -- n ) + num-types get num-tags get - ; + +M: hi-tag-dispatch-engine compile-engine + methods>> compile-engines* + [ [ hi-tag-number num-tags get - ] dip ] assoc-map + num-hi-tags direct-dispatch-table ; + +: build-fast-hash ( methods -- buckets ) + >alist V{ } clone [ hashcode 1array ] distribute-buckets + [ compile-engines* >alist >array ] map ; + +M: echelon-dispatch-engine compile-engine + methods>> compile-engines* build-fast-hash ; + +M: tuple-dispatch-engine compile-engine + tuple assumed [ + echelons>> compile-engines + dup keys supremum f default get prefix + [ swap update ] keep + ] with-variable ; + +: sort-methods ( assoc -- assoc' ) + >alist [ keys sort-classes ] keep extract-keys ; + +: literalize-methods ( assoc -- assoc' ) + [ [ ] curry \ drop prefix ] assoc-map ; + +: methods-with-default ( engine -- assoc ) + methods>> clone default get object bootstrap-word pick set-at ; + +: keep-going? ( assoc -- ? ) + assumed get swap second first class<= ; + +: prune-redundant-predicates ( assoc -- default assoc' ) + { + { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } + { [ dup length 1 = ] [ first second { } ] } + { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] } + [ [ first second ] [ rest-slice ] bi ] + } cond ; + +: class-predicates ( assoc -- assoc ) + [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ; + +: predicate-engine-effect ( -- effect ) + (dispatch#) get 1+ dup 1+ ; + +: define-predicate-engine ( alist -- word ) + [ generic-word get name>> "/predicate-engine" append f dup ] dip + predicate-engine-effect define-declared ; + +M: predicate-engine compile-engine + methods-with-default + sort-methods + literalize-methods + prune-redundant-predicates + class-predicates + [ peek wrapped>> ] + [ alist>quot picker prepend define-predicate-engine ] if-empty ; + +M: word compile-engine ; + +M: f compile-engine ; + +: build-engine ( generic combination -- engine ) + [ + #>> (dispatch#) set + [ generic-word set ] + [ "default-method" word-prop default set ] + [ "methods" word-prop ] tri + compile-engine 1quotation + picker [ lookup-method ] surround + ] with-scope ; \ No newline at end of file diff --git a/vm/data_heap.c b/vm/data_heap.c index c5aa42aebe..eb8add544e 100644 --- a/vm/data_heap.c +++ b/vm/data_heap.c @@ -334,7 +334,7 @@ CELL next_object(void) type = untag_header(value); heap_scan_ptr += untagged_object_size(heap_scan_ptr); - return RETAG(obj,type <= HEADER_TYPE ? type : OBJECT_TYPE); + return RETAG(obj,type < HEADER_TYPE ? type : OBJECT_TYPE); } /* Push object at heap scan cursor and advance; pushes f when done */ diff --git a/vm/dispatch.c b/vm/dispatch.c new file mode 100644 index 0000000000..e231d6f431 --- /dev/null +++ b/vm/dispatch.c @@ -0,0 +1,108 @@ +#include "master.h" + +static CELL search_lookup_alist(CELL table, CELL class) +{ + F_ARRAY *pairs = untag_object(table); + F_FIXNUM index = array_capacity(pairs) - 1; + while(index >= 0) + { + F_ARRAY *pair = untag_object(array_nth(pairs,index)); + if(array_nth(pair,0) == class) + return array_nth(pair,1); + else + index--; + } + + return F; +} + +static CELL search_lookup_hash(CELL table, CELL class, CELL hashcode) +{ + F_ARRAY *buckets = untag_object(table); + CELL bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1)); + if(type_of(bucket) == WORD_TYPE || bucket == F) + return bucket; + else + return search_lookup_alist(bucket,class); +} + +static CELL nth_superclass(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon) +{ + CELL *ptr = (CELL *)(layout + 1); + return ptr[echelon * 2]; +} + +static CELL nth_hashcode(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon) +{ + CELL *ptr = (CELL *)(layout + 1); + return ptr[echelon * 2 + 1]; +} + +static CELL lookup_tuple_method(CELL object, CELL methods) +{ + F_ARRAY *echelons = untag_object(methods); + F_TUPLE *tuple = untag_object(object); + F_TUPLE_LAYOUT *layout = untag_object(tuple->layout); + + F_FIXNUM echelon = untag_fixnum_fast(layout->echelon); + F_FIXNUM max_echelon = array_capacity(echelons) - 1; + if(echelon > max_echelon) echelon = max_echelon; + + while(echelon >= 0) + { + CELL echelon_methods = array_nth(echelons,echelon); + + if(type_of(echelon_methods) == WORD_TYPE) + return echelon_methods; + else if(echelon_methods != F) + { + CELL class = nth_superclass(layout,echelon); + CELL hashcode = untag_fixnum_fast(nth_hashcode(layout,echelon)); + CELL result = search_lookup_hash(echelon_methods,class,hashcode); + if(result != F) + return result; + } + + echelon--; + } + + critical_error("Cannot find tuple method",object); + return F; +} + +static CELL lookup_hi_tag_method(CELL object, CELL methods) +{ + F_ARRAY *hi_tag_methods = untag_object(methods); + CELL hi_tag = object_type(object); + return array_nth(hi_tag_methods,hi_tag - HEADER_TYPE); +} + +static CELL lookup_method(CELL object, CELL methods) +{ + F_ARRAY *tag_methods = untag_object(methods); + CELL tag = TAG(object); + CELL element = array_nth(tag_methods,tag); + + if(type_of(element) == WORD_TYPE) + return element; + else + { + switch(tag) + { + case TUPLE_TYPE: + return lookup_tuple_method(object,element); + case OBJECT_TYPE: + return lookup_hi_tag_method(object,element); + default: + critical_error("Bad methods array",methods); + return F; + } + } +} + +void primitive_lookup_method(void) +{ + CELL methods = dpop(); + CELL object = dpop(); + dpush(lookup_method(object,methods)); +} diff --git a/vm/dispatch.h b/vm/dispatch.h new file mode 100644 index 0000000000..6541c8fef1 --- /dev/null +++ b/vm/dispatch.h @@ -0,0 +1 @@ +void primitive_lookup_method(void); diff --git a/vm/layouts.h b/vm/layouts.h index e9cdef6272..9d92d2c386 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -42,7 +42,7 @@ typedef signed long long s64; #define F_TYPE 7 #define F F_TYPE -#define HEADER_TYPE 7 /* anything less than or equal to this is a tag */ +#define HEADER_TYPE 8 /* anything less than this is a tag */ #define GC_COLLECTED 5 /* See gc.c */ diff --git a/vm/master.h b/vm/master.h index 86b5223eaa..e2cafd9a87 100644 --- a/vm/master.h +++ b/vm/master.h @@ -41,6 +41,7 @@ #include "callstack.h" #include "alien.h" #include "quotations.h" +#include "dispatch.h" #include "factor.h" #include "utilities.h" diff --git a/vm/primitives.c b/vm/primitives.c index 80b672d9d2..4281e88fc3 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -144,5 +144,6 @@ void *primitives[] = { primitive_clear_gc_stats, primitive_jit_compile, primitive_load_locals, - primitive_check_datastack + primitive_check_datastack, + primitive_lookup_method }; From 0220609928a6561195225a89761c19458645386b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 24 Apr 2009 16:24:31 -0500 Subject: [PATCH 506/772] handle errors when traversing directories --- basis/io/directories/search/search.factor | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index dc97d4fe45..2202f7aa08 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -24,7 +24,7 @@ IN: io.directories.search TUPLE: directory-iterator path bfs queue ; : push-directory-entries ( path iter -- ) - [ qualified-directory-entries ] dip '[ + [ [ qualified-directory-entries ] [ 2drop f ] recover ] dip '[ _ [ queue>> ] [ bfs>> ] bi [ push-front ] [ push-back ] if ] each ; @@ -70,16 +70,12 @@ PRIVATE> [ ] accumulator [ each-directory-entry ] dip ; : find-file ( path bfs? quot -- path/f ) - '[ - _ _ _ [ ] dip - [ keep and ] curry iterate-directory - ] [ drop f ] recover ; + [ ] dip + [ keep and ] curry iterate-directory ; : find-all-files ( path quot -- paths/f ) - '[ - _ _ [ f ] dip - pusher [ [ f ] compose iterate-directory drop ] dip - ] [ drop f ] recover ; + [ f ] dip pusher + [ [ f ] compose iterate-directory drop ] dip ; ERROR: file-not-found path bfs? quot ; From c877146531484ef34c93113649e4e26a24687d23 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 16:53:30 -0500 Subject: [PATCH 507/772] Move method-declaration to hints --- basis/hints/hints.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index d445bf72ad..e2506dbe0a 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -42,13 +42,13 @@ SYMBOL: specialize-method? t specialize-method? set-global +: method-declaration ( method -- quot ) + [ "method-generic" word-prop dispatch# object ] + [ "method-class" word-prop ] + bi prefix [ declare ] curry [ ] like ; + : specialize-method ( quot method -- quot' ) - [ - specialize-method? get [ - [ "method-class" word-prop ] [ "method-generic" word-prop ] bi - method-declaration prepend - ] [ drop ] if - ] + [ specialize-method? get [ method-declaration prepend ] [ drop ] if ] [ "method-generic" word-prop "specializer" word-prop ] bi [ specialize-quot ] when* ; From 5e5042fe5ff15fa5e4b4d60ccefa6cb3e8d9b9d8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 24 Apr 2009 19:01:26 -0500 Subject: [PATCH 508/772] fix help-lint, compilation issue in io.directories.search --- basis/io/directories/search/search.factor | 30 +++++++++++------------ 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 2202f7aa08..f7d18306f8 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -39,55 +39,55 @@ TUPLE: directory-iterator path bfs queue ; dup directory? [ name>> over push-directory-entries next-directory-entry ] [ nip ] if - ] if ; recursive + ] if ; -:: iterate-directory-entries ( iter quot -- directory-entry/f ) +:: iterate-directory-entries ( iter quot: ( obj -- obj ) -- directory-entry/f ) iter next-directory-entry [ - quot call( obj -- obj ) + quot call [ iter quot iterate-directory-entries ] unless* ] [ f ] if* ; inline recursive : iterate-directory ( iter quot -- path/f ) - [ name>> ] prepose iterate-directory-entries ; + [ name>> ] prepose iterate-directory-entries ; inline : setup-traversal ( path bfs quot -- iterator quot' ) - [ ] dip [ f ] compose ; + [ ] dip [ f ] compose ; inline PRIVATE> : each-file ( path bfs? quot -- ) - setup-traversal iterate-directory drop ; + setup-traversal iterate-directory drop ; inline : each-directory-entry ( path bfs? quot -- ) - setup-traversal iterate-directory-entries drop ; + setup-traversal iterate-directory-entries drop ; inline : recursive-directory-files ( path bfs? -- paths ) - [ ] accumulator [ each-file ] dip ; + [ ] accumulator [ each-file ] dip ; inline -: recursive-directory-entries ( path bfs? -- paths ) - [ ] accumulator [ each-directory-entry ] dip ; +: recursive-directory-entries ( path bfs? -- directory-entries ) + [ ] accumulator [ each-directory-entry ] dip ; inline : find-file ( path bfs? quot -- path/f ) [ ] dip - [ keep and ] curry iterate-directory ; + [ keep and ] curry iterate-directory ; inline : find-all-files ( path quot -- paths/f ) [ f ] dip pusher - [ [ f ] compose iterate-directory drop ] dip ; + [ [ f ] compose iterate-directory drop ] dip ; inline ERROR: file-not-found path bfs? quot ; : find-file-throws ( path bfs? quot -- path ) - 3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; + 3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; inline : find-in-directories ( directories bfs? quot -- path'/f ) '[ _ [ _ _ find-file-throws ] attempt-all ] - [ drop f ] recover ; + [ drop f ] recover ; inline : find-all-in-directories ( directories quot -- paths/f ) - '[ _ find-all-files ] map concat ; + '[ _ find-all-files ] map concat ; inline : link-size/0 ( path -- n ) [ link-info size-on-disk>> ] [ 2drop 0 ] recover ; From 3dc9fdf9db8113cd6c8276ba0257645c5caab076 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 20:43:01 -0500 Subject: [PATCH 509/772] Fleshed out new dispatch code --- basis/compiler/compiler.factor | 16 +- .../tree/propagation/inlining/inlining.factor | 2 +- basis/debugger/debugger.factor | 2 +- basis/hints/hints.factor | 4 +- basis/see/see.factor | 10 +- basis/stack-checker/backend/backend.factor | 9 +- .../known-words/known-words.factor | 4 +- basis/tools/crossref/crossref.factor | 5 +- .../listener/completion/completion.factor | 12 +- core/bootstrap/primitives.factor | 4 +- .../{standard/compiler => hook}/authors.txt | 0 core/generic/hook/hook-docs.factor | 10 + core/generic/hook/hook.factor | 19 ++ core/generic/single/authors.txt | 1 + core/generic/single/single-docs.factor | 27 +++ .../compiler.factor => single/single.factor} | 125 ++++++++++--- core/generic/standard/authors.txt | 2 +- core/generic/standard/engines/engines.factor | 53 ------ .../engines/predicate/predicate.factor | 38 ---- .../standard/engines/predicate/summary.txt | 1 - core/generic/standard/engines/summary.txt | 1 - core/generic/standard/engines/tag/summary.txt | 1 - core/generic/standard/engines/tag/tag.factor | 71 ------- .../standard/engines/tuple/summary.txt | 1 - .../standard/engines/tuple/tuple.factor | 167 ----------------- core/generic/standard/standard-docs.factor | 35 +--- core/generic/standard/standard.factor | 173 ++---------------- core/generic/standard/summary.txt | 1 - core/syntax/syntax-docs.factor | 4 +- core/syntax/syntax.factor | 2 +- core/words/words.factor | 11 +- 31 files changed, 218 insertions(+), 593 deletions(-) rename core/generic/{standard/compiler => hook}/authors.txt (100%) create mode 100644 core/generic/hook/hook-docs.factor create mode 100644 core/generic/hook/hook.factor create mode 100644 core/generic/single/authors.txt create mode 100644 core/generic/single/single-docs.factor rename core/generic/{standard/compiler/compiler.factor => single/single.factor} (57%) delete mode 100644 core/generic/standard/engines/engines.factor delete mode 100644 core/generic/standard/engines/predicate/predicate.factor delete mode 100644 core/generic/standard/engines/predicate/summary.txt delete mode 100644 core/generic/standard/engines/summary.txt delete mode 100644 core/generic/standard/engines/tag/summary.txt delete mode 100644 core/generic/standard/engines/tag/tag.factor delete mode 100644 core/generic/standard/engines/tuple/summary.txt delete mode 100644 core/generic/standard/engines/tuple/tuple.factor delete mode 100644 core/generic/standard/summary.txt diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index ee91d04b3d..26f9dc47c9 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -2,13 +2,14 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io words fry continuations vocabs assocs dlists definitions math graphs generic -combinators deques search-deques macros io source-files.errors -stack-checker stack-checker.state stack-checker.inlining -stack-checker.errors combinators.short-circuit compiler.errors -compiler.units compiler.tree.builder compiler.tree.optimizer -compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization -compiler.cfg.two-operand compiler.cfg.linear-scan -compiler.cfg.stack-frame compiler.codegen compiler.utilities ; +generic.single combinators deques search-deques macros io +source-files.errors stack-checker stack-checker.state +stack-checker.inlining stack-checker.errors combinators.short-circuit +compiler.errors compiler.units compiler.tree.builder +compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer +compiler.cfg.linearization compiler.cfg.two-operand +compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen +compiler.utilities ; IN: compiler SYMBOL: compile-queue @@ -19,6 +20,7 @@ SYMBOL: compiled { [ "forgotten" word-prop ] [ compiled get key? ] + [ single-generic? ] [ inlined-block? ] [ primitive? ] } 1|| not ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index aa66b2f6d7..42c47377e0 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel arrays sequences math math.order -math.partial-dispatch generic generic.standard generic.math +math.partial-dispatch generic generic.standard generic.single generic.math classes.algebra classes.union sets quotations assocs combinators words namespaces continuations classes fry combinators.smart hints locals diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index d8ebd5bbf9..2091a26133 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -6,7 +6,7 @@ sequences assocs sequences.private strings io.styles io.pathnames vectors words system splitting math.parser classes.mixin classes.tuple continuations continuations.private combinators generic.math classes.builtin classes compiler.units -generic.standard vocabs init kernel.private io.encodings +generic.standard generic.single vocabs init kernel.private io.encodings accessors math.order destructors source-files parser classes.tuple.parser effects.parser lexer generic.parser strings.parser vocabs.loader vocabs.parser see diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index e2506dbe0a..d83275c750 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser words definitions kernel sequences assocs arrays kernel.private fry combinators accessors vectors strings sbufs byte-arrays byte-vectors io.binary io.streams.string splitting math -math.parser generic generic.standard generic.standard.engines classes +math.parser generic generic.single generic.standard classes hashtables namespaces ; IN: hints diff --git a/basis/see/see.factor b/basis/see/see.factor index 2494c72fa4..37153b5229 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs classes classes.builtin -classes.intersection classes.mixin classes.predicate -classes.singleton classes.tuple classes.union combinators -definitions effects generic generic.standard io io.pathnames +classes.intersection classes.mixin classes.predicate classes.singleton +classes.tuple classes.union combinators definitions effects generic +generic.single generic.standard generic.hook io io.pathnames io.streams.string io.styles kernel make namespaces prettyprint prettyprint.backend prettyprint.config prettyprint.custom -prettyprint.sections sequences sets sorting strings summary -words words.symbol words.constant words.alias ; +prettyprint.sections sequences sets sorting strings summary words +words.symbol words.constant words.alias ; IN: see GENERIC: synopsis* ( defspec -- ) diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 4fb5bab96f..338b052316 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry arrays generic io io.streams.string kernel math -namespaces parser sequences strings vectors words quotations -effects classes continuations assocs combinators -compiler.errors accessors math.order definitions sets -generic.standard.engines.tuple hints macros stack-checker.state +USING: fry arrays generic io io.streams.string kernel math namespaces +parser sequences strings vectors words quotations effects classes +continuations assocs combinators compiler.errors accessors math.order +definitions sets hints macros stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state ; IN: stack-checker.backend diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index ab205b4a16..a3b0c8d704 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -12,7 +12,7 @@ classes.tuple.private vectors vectors.private words definitions words.private assocs summary compiler.units system.private combinators locals locals.backend locals.types words.private quotations.private combinators.private stack-checker.values -generic.standard.private +generic.single generic.single.private alien.libraries stack-checker.alien stack-checker.state @@ -236,6 +236,8 @@ M: object infer-call* \ effective-method t "no-compile" set-word-prop \ effective-method subwords [ t "no-compile" set-word-prop ] each +\ execute-unsafe t "no-compile" set-word-prop + \ clear t "no-compile" set-word-prop : non-inline-word ( word -- ) diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index c5cd246f2e..6082933bcb 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -3,8 +3,7 @@ USING: words assocs definitions io io.pathnames io.styles kernel prettyprint sorting see sets sequences arrays hashtables help.crossref help.topics help.markup quotations accessors source-files namespaces -graphs vocabs generic generic.standard.engines.tuple threads -compiler.units init ; +graphs vocabs generic generic.single threads compiler.units init ; IN: tools.crossref SYMBOL: crossref @@ -82,7 +81,7 @@ M: object irrelevant? drop f ; M: default-method irrelevant? drop t ; -M: engine-word irrelevant? drop t ; +M: predicate-engine irrelevant? drop t ; PRIVATE> diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor index ba66121bc2..70131f3212 100644 --- a/basis/ui/tools/listener/completion/completion.factor +++ b/basis/ui/tools/listener/completion/completion.factor @@ -3,13 +3,13 @@ USING: accessors arrays assocs calendar colors colors.constants documents documents.elements fry kernel words sets splitting math math.vectors models.delay models.arrow combinators.short-circuit -parser present sequences tools.completion help.vocabs generic -generic.standard.engines.tuple fonts definitions.icons ui.images -ui.commands ui.operations ui.gadgets ui.gadgets.editors -ui.gadgets.glass ui.gadgets.scrollers ui.gadgets.tables -ui.gadgets.tracks ui.gadgets.labeled +parser present sequences tools.completion help.vocabs generic fonts +definitions.icons ui.images ui.commands ui.operations ui.gadgets +ui.gadgets.editors ui.gadgets.glass ui.gadgets.scrollers +ui.gadgets.tables ui.gadgets.tracks ui.gadgets.labeled ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.pens.solid -ui.tools.listener.history combinators vocabs ui.tools.listener.popups ; +ui.tools.listener.history combinators vocabs ui.tools.listener.popups + ; IN: ui.tools.listener.completion ! We don't directly depend on the listener tool but we use a few slots diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index a8e23cd336..42627531aa 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -69,7 +69,7 @@ bootstrapping? on "classes.predicate" "compiler.units" "continuations.private" - "generic.standard.private" + "generic.single.private" "growable" "hashtables" "hashtables.private" @@ -533,7 +533,7 @@ tuple { "jit-compile" "quotations" (( quot -- )) } { "load-locals" "locals.backend" (( ... n -- )) } { "check-datastack" "kernel.private" (( array in# out# -- ? )) } - { "lookup-method" "generic.standard.private" (( object methods -- method )) } + { "lookup-method" "generic.single.private" (( object methods -- method )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number diff --git a/core/generic/standard/compiler/authors.txt b/core/generic/hook/authors.txt similarity index 100% rename from core/generic/standard/compiler/authors.txt rename to core/generic/hook/authors.txt diff --git a/core/generic/hook/hook-docs.factor b/core/generic/hook/hook-docs.factor new file mode 100644 index 0000000000..9b57d941c0 --- /dev/null +++ b/core/generic/hook/hook-docs.factor @@ -0,0 +1,10 @@ +USING: generic generic.single generic.standard help.markup help.syntax sequences math +math.parser effects ; +IN: generic.hook + +HELP: hook-combination +{ $class-description + "Performs hook method combination . See " { $link POSTPONE: HOOK: } "." +} ; + +{ standard-combination hook-combination } related-words \ No newline at end of file diff --git a/core/generic/hook/hook.factor b/core/generic/hook/hook.factor new file mode 100644 index 0000000000..0574833fab --- /dev/null +++ b/core/generic/hook/hook.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors definitions generic generic.single kernel +namespaces words ; +IN: generic.hook + +TUPLE: hook-combination < single-combination var ; + +C: hook-combination + +PREDICATE: hook-generic < generic + "combination" word-prop hook-combination? ; + +M: hook-combination picker + combination get var>> [ get ] curry ; + +M: hook-combination dispatch# drop 0 ; + +M: hook-generic definer drop \ HOOK: f ; diff --git a/core/generic/single/authors.txt b/core/generic/single/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/core/generic/single/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/core/generic/single/single-docs.factor b/core/generic/single/single-docs.factor new file mode 100644 index 0000000000..8f81be762c --- /dev/null +++ b/core/generic/single/single-docs.factor @@ -0,0 +1,27 @@ +USING: generic help.markup help.syntax sequences math +math.parser effects ; +IN: generic.single + +HELP: no-method +{ $values { "object" "an object" } { "generic" "a generic word" } } +{ $description "Throws a " { $link no-method } " error." } +{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ; + +HELP: inconsistent-next-method +{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." } +{ $examples + "The following code throws this error:" + { $code + "GENERIC: error-test ( object -- )" + "" + "M: string error-test print ;" + "" + "M: integer error-test number>string call-next-method ;" + "" + "123 error-test" + } + "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method." + $nl + "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:" + { $code "M: integer error-test number>string error-test ;" } +} ; \ No newline at end of file diff --git a/core/generic/standard/compiler/compiler.factor b/core/generic/single/single.factor similarity index 57% rename from core/generic/standard/compiler/compiler.factor rename to core/generic/single/single.factor index 0456918b49..d70a378c67 100644 --- a/core/generic/standard/compiler/compiler.factor +++ b/core/generic/single/single.factor @@ -1,13 +1,66 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs classes.algebra math combinators -generic.standard.engines hashtables kernel kernel.private layouts -namespaces sequences words sorting quotations effects -generic.standard.private words.private ; -IN: generic.standard.compiler +USING: accessors arrays assocs classes classes.algebra +combinators definitions generic hashtables kernel +kernel.private layouts make math namespaces quotations +sequences words generic.single.private words.private +effects ; +IN: generic.single + +ERROR: no-method object generic ; + +ERROR: inconsistent-next-method class generic ; + +TUPLE: single-combination ; + +PREDICATE: single-generic < generic + "combination" word-prop single-combination? ; + +GENERIC: dispatch# ( word -- n ) + +M: generic dispatch# "combination" word-prop dispatch# ; + +SYMBOL: assumed +SYMBOL: default +SYMBOL: generic-word +SYMBOL: combination + +: with-combination ( combination quot -- ) + [ combination ] dip with-variable ; inline + +HOOK: picker combination ( -- quot ) + +M: single-combination next-method-quot* + [ + 2dup next-method dup [ + [ + pick "predicate" word-prop % + 1quotation , + [ inconsistent-next-method ] 2curry , + \ if , + ] [ ] make picker prepend + ] [ 3drop f ] if + ] with-combination ; + +: single-effective-method ( obj word -- method ) + [ [ order [ instance? ] with find-last nip ] keep method ] + [ "default-method" word-prop ] + bi or ; + +M: single-generic effective-method + [ [ picker ] with-combination call ] keep single-effective-method ; + +M: single-combination make-default-method + combination [ [ picker ] dip [ no-method ] curry append ] with-variable ; ! ! ! Build an engine ! ! ! +: find-default ( methods -- default ) + #! Side-effects methods. + [ object bootstrap-word ] dip delete-at* [ + drop generic-word get "default-method" word-prop + ] unless ; + ! 1. Flatten methods TUPLE: predicate-engine methods ; @@ -28,6 +81,10 @@ TUPLE: predicate-engine methods ; H{ } clone [ [ flatten-method ] curry assoc-each ] keep ; ! 2. Convert methods +: split-methods ( assoc class -- first second ) + [ [ nip class<= not ] curry assoc-filter ] + [ [ nip class<= ] curry assoc-filter ] 2bi ; + : convert-methods ( assoc class word -- assoc' ) over [ split-methods ] 2dip pick assoc-empty? [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline @@ -76,10 +133,6 @@ C: tag-dispatch-engine ; ! ! ! Compile engine ! ! ! -SYMBOL: assumed -SYMBOL: default -SYMBOL: generic-word - GENERIC: compile-engine ( engine -- obj ) : compile-engines ( assoc -- assoc' ) @@ -98,8 +151,7 @@ M: tag-dispatch-engine compile-engine : hi-tag-number ( class -- n ) "type" word-prop ; -: num-hi-tags ( -- n ) - num-types get num-tags get - ; +: num-hi-tags ( -- n ) num-types get num-tags get - ; M: hi-tag-dispatch-engine compile-engine methods>> compile-engines* @@ -123,8 +175,8 @@ M: tuple-dispatch-engine compile-engine : sort-methods ( assoc -- assoc' ) >alist [ keys sort-classes ] keep extract-keys ; -: literalize-methods ( assoc -- assoc' ) - [ [ ] curry \ drop prefix ] assoc-map ; +: quote-methods ( assoc -- assoc' ) + [ 1quotation \ drop prefix ] assoc-map ; : methods-with-default ( engine -- assoc ) methods>> clone default get object bootstrap-word pick set-at ; @@ -141,34 +193,49 @@ M: tuple-dispatch-engine compile-engine } cond ; : class-predicates ( assoc -- assoc ) - [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ; + [ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ; -: predicate-engine-effect ( -- effect ) - (dispatch#) get 1+ dup 1+ ; +PREDICATE: predicate-engine-word < word "owner-generic" word-prop ; + +: ( -- word ) + generic-word get name>> "/predicate-engine" append f + dup generic-word get "owner-generic" set-word-prop ; + +M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ; : define-predicate-engine ( alist -- word ) - [ generic-word get name>> "/predicate-engine" append f dup ] dip - predicate-engine-effect define-declared ; + [ ] dip + [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ; M: predicate-engine compile-engine methods-with-default sort-methods - literalize-methods + quote-methods prune-redundant-predicates class-predicates - [ peek wrapped>> ] - [ alist>quot picker prepend define-predicate-engine ] if-empty ; + [ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ; M: word compile-engine ; M: f compile-engine ; -: build-engine ( generic combination -- engine ) - [ - #>> (dispatch#) set +: build-decision-tree ( generic -- methods ) + { [ generic-word set ] - [ "default-method" word-prop default set ] - [ "methods" word-prop ] tri - compile-engine 1quotation - picker [ lookup-method ] surround - ] with-scope ; \ No newline at end of file + [ "engines" word-prop forget-all ] + [ V{ } clone "engines" set-word-prop ] + [ + "methods" word-prop clone + [ find-default default set ] + [ compile-engine ] bi + ] + } cleave ; + +: execute-unsafe ( word -- ) (execute) ; + +M: single-combination perform-combination + [ + dup build-decision-tree + [ "decision-tree" set-word-prop ] + [ 1quotation picker [ lookup-method execute-unsafe ] surround define ] 2bi + ] with-combination ; \ No newline at end of file diff --git a/core/generic/standard/authors.txt b/core/generic/standard/authors.txt index 1901f27a24..d4f5d6b3ae 100644 --- a/core/generic/standard/authors.txt +++ b/core/generic/standard/authors.txt @@ -1 +1 @@ -Slava Pestov +Slava Pestov \ No newline at end of file diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor deleted file mode 100644 index b6cb9fc9f7..0000000000 --- a/core/generic/standard/engines/engines.factor +++ /dev/null @@ -1,53 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel kernel.private namespaces quotations -generic math sequences combinators words classes.algebra arrays -; -IN: generic.standard.engines - -SYMBOL: default -SYMBOL: assumed -SYMBOL: (dispatch#) - -GENERIC: engine>quot ( engine -- quot ) - -: engines>quots ( assoc -- assoc' ) - [ engine>quot ] assoc-map ; - -: engines>quots* ( assoc -- assoc' ) - [ over assumed [ engine>quot ] with-variable ] assoc-map ; - -: if-small? ( assoc true false -- ) - [ dup assoc-size 4 <= ] 2dip if ; inline - -: linear-dispatch-quot ( alist -- quot ) - default get [ drop ] prepend swap - [ - [ [ dup ] swap [ eq? ] curry compose ] - [ [ drop ] prepose ] - bi* [ ] like - ] assoc-map - alist>quot ; - -: split-methods ( assoc class -- first second ) - [ [ nip class<= not ] curry assoc-filter ] - [ [ nip class<= ] curry assoc-filter ] 2bi ; - -: convert-methods ( assoc class word -- assoc' ) - over [ split-methods ] 2dip pick assoc-empty? [ - 3drop - ] [ - [ execute ] dip pick set-at - ] if ; inline - -: (picker) ( n -- quot ) - { - { 0 [ [ dup ] ] } - { 1 [ [ over ] ] } - { 2 [ [ pick ] ] } - [ 1- (picker) [ dip swap ] curry ] - } case ; - -: picker ( -- quot ) \ (dispatch#) get (picker) ; - -GENERIC: extra-values ( generic -- n ) diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor deleted file mode 100644 index 152b112c2a..0000000000 --- a/core/generic/standard/engines/predicate/predicate.factor +++ /dev/null @@ -1,38 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: generic.standard.engines generic namespaces kernel -kernel.private sequences classes.algebra accessors words -combinators assocs arrays ; -IN: generic.standard.engines.predicate - -TUPLE: predicate-dispatch-engine methods ; - -C: predicate-dispatch-engine - -: class-predicates ( assoc -- assoc ) - [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ; - -: keep-going? ( assoc -- ? ) - assumed get swap second first class<= ; - -: prune-redundant-predicates ( assoc -- default assoc' ) - { - { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } - { [ dup length 1 = ] [ first second { } ] } - { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] } - [ [ first second ] [ rest-slice ] bi ] - } cond ; - -: sort-methods ( assoc -- assoc' ) - >alist [ keys sort-classes ] keep extract-keys ; - -: methods-with-default ( engine -- assoc ) - methods>> clone default get object bootstrap-word pick set-at ; - -M: predicate-dispatch-engine engine>quot - methods-with-default - engines>quots - sort-methods - prune-redundant-predicates - class-predicates - alist>quot ; diff --git a/core/generic/standard/engines/predicate/summary.txt b/core/generic/standard/engines/predicate/summary.txt deleted file mode 100644 index 47fee09ee5..0000000000 --- a/core/generic/standard/engines/predicate/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Chained-conditional dispatch strategy diff --git a/core/generic/standard/engines/summary.txt b/core/generic/standard/engines/summary.txt deleted file mode 100644 index 209190799b..0000000000 --- a/core/generic/standard/engines/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Generic word dispatch strategy implementation diff --git a/core/generic/standard/engines/tag/summary.txt b/core/generic/standard/engines/tag/summary.txt deleted file mode 100644 index 3eea4b11cf..0000000000 --- a/core/generic/standard/engines/tag/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Jump table keyed by pointer tag dispatch strategy diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor deleted file mode 100644 index 5ed33009c0..0000000000 --- a/core/generic/standard/engines/tag/tag.factor +++ /dev/null @@ -1,71 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: classes.private generic.standard.engines namespaces make -arrays assocs sequences.private quotations kernel.private -math slots.private math.private kernel accessors words -layouts sorting sequences combinators ; -IN: generic.standard.engines.tag - -TUPLE: lo-tag-dispatch-engine methods ; - -C: lo-tag-dispatch-engine - -: direct-dispatch-quot ( alist n -- quot ) - default get - [ swap update ] keep - [ dispatch ] curry >quotation ; - -: lo-tag-number ( class -- n ) - dup \ hi-tag bootstrap-word eq? [ - drop \ hi-tag tag-number - ] [ - "type" word-prop - ] if ; - -: sort-tags ( assoc -- alist ) >alist sort-keys reverse ; - -: tag-dispatch-test ( tag# -- quot ) - picker [ tag ] append swap [ eq? ] curry append ; - -: tag-dispatch-quot ( alist -- quot ) - [ default get ] dip - [ [ tag-dispatch-test ] dip ] assoc-map - alist>quot ; - -M: lo-tag-dispatch-engine engine>quot - methods>> engines>quots* - [ [ lo-tag-number ] dip ] assoc-map - [ - [ sort-tags tag-dispatch-quot ] - [ picker % [ tag ] % num-tags get direct-dispatch-quot ] - if-small? % - ] [ ] make ; - -TUPLE: hi-tag-dispatch-engine methods ; - -C: hi-tag-dispatch-engine - -: convert-hi-tag-methods ( assoc -- assoc' ) - \ hi-tag bootstrap-word - \ convert-methods ; - -: num-hi-tags ( -- n ) num-types get num-tags get - ; - -: hi-tag-number ( class -- n ) - "type" word-prop ; - -: hi-tag-quot ( -- quot ) - \ hi-tag def>> ; - -M: hi-tag-dispatch-engine engine>quot - methods>> engines>quots* - [ [ hi-tag-number ] dip ] assoc-map - [ - picker % hi-tag-quot % [ - sort-tags linear-dispatch-quot - ] [ - num-tags get , \ fixnum-fast , - [ [ num-tags get - ] dip ] assoc-map - num-hi-tags direct-dispatch-quot - ] if-small? % - ] [ ] make ; diff --git a/core/generic/standard/engines/tuple/summary.txt b/core/generic/standard/engines/tuple/summary.txt deleted file mode 100644 index cb18ac5c78..0000000000 --- a/core/generic/standard/engines/tuple/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Tuple class dispatch strategy diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor deleted file mode 100644 index a0711af095..0000000000 --- a/core/generic/standard/engines/tuple/tuple.factor +++ /dev/null @@ -1,167 +0,0 @@ -! Copyright (c) 2008 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: kernel classes.tuple.private hashtables assocs sorting -accessors combinators sequences slots.private math.parser words -effects namespaces make generic generic.standard.engines -classes.algebra math math.private kernel.private -quotations arrays definitions ; -IN: generic.standard.engines.tuple - -: nth-superclass% ( n -- ) 2 * 5 + , \ slot , ; inline - -: nth-hashcode% ( n -- ) 2 * 6 + , \ slot , ; inline - -: tuple-layout% ( -- ) - [ { tuple } declare 1 slot { array } declare ] % ; inline - -: tuple-layout-echelon% ( -- ) - [ 4 slot ] % ; inline - -TUPLE: echelon-dispatch-engine n methods ; - -C: echelon-dispatch-engine - -TUPLE: trivial-tuple-dispatch-engine n methods ; - -C: trivial-tuple-dispatch-engine - -TUPLE: tuple-dispatch-engine echelons ; - -: push-echelon ( class method assoc -- ) - [ swap dup "layout" word-prop third ] dip - [ ?set-at ] change-at ; - -: echelon-sort ( assoc -- assoc' ) - V{ } clone [ - [ - push-echelon - ] curry assoc-each - ] keep sort-keys ; - -: ( methods -- engine ) - echelon-sort - [ dupd ] assoc-map - \ tuple-dispatch-engine boa ; - -: convert-tuple-methods ( assoc -- assoc' ) - tuple bootstrap-word - \ convert-methods ; - -M: trivial-tuple-dispatch-engine engine>quot - [ n>> ] [ methods>> ] bi dup assoc-empty? [ - 2drop default get [ drop ] prepend - ] [ - [ - [ nth-superclass% ] - [ engines>quots* linear-dispatch-quot % ] bi* - ] [ ] make - ] if ; - -: hash-methods ( n methods -- buckets ) - >alist V{ } clone [ hashcode 1array ] distribute-buckets - [ ] with map ; - -: class-hash-dispatch-quot ( n methods -- quot ) - [ - \ dup , - [ drop nth-hashcode% ] - [ hash-methods [ engine>quot ] map hash-dispatch-quot % ] 2bi - ] [ ] make ; - -: engine-word-name ( -- string ) - generic get name>> "/tuple-dispatch-engine" append ; - -PREDICATE: engine-word < word - "tuple-dispatch-generic" word-prop generic? ; - -M: engine-word stack-effect - "tuple-dispatch-generic" word-prop - [ extra-values ] [ stack-effect ] bi - dup [ - [ in>> length + ] [ out>> ] [ terminated?>> ] tri - effect boa - ] [ 2drop f ] if ; - -M: engine-word where "tuple-dispatch-generic" word-prop where ; - -M: engine-word crossref? "forgotten" word-prop not ; - -: remember-engine ( word -- ) - generic get "engines" word-prop push ; - -: ( -- word ) - engine-word-name f - dup generic get "tuple-dispatch-generic" set-word-prop ; - -: define-engine-word ( quot -- word ) - [ dup ] dip define ; - -: tuple-dispatch-engine-body ( engine -- quot ) - [ - picker % - tuple-layout% - [ n>> ] [ methods>> ] bi - [ engine>quot ] - [ class-hash-dispatch-quot ] - if-small? % - ] [ ] make ; - -M: echelon-dispatch-engine engine>quot - dup n>> zero? [ - methods>> dup assoc-empty? - [ drop default get ] [ values first engine>quot ] if - ] [ - tuple-dispatch-engine-body - ] if ; - -: >=-case-quot ( default alist -- quot ) - [ [ drop ] prepend ] dip - [ - [ [ dup ] swap [ fixnum>= ] curry compose ] - [ [ drop ] prepose ] - bi* [ ] like - ] assoc-map - alist>quot ; - -: simplify-echelon-alist ( default alist -- default' alist' ) - dup empty? [ - dup first first 1 <= [ - nip unclip second swap - simplify-echelon-alist - ] when - ] unless ; - -: echelon-case-quot ( alist -- quot ) - #! We don't have to test for echelon 1 since all tuple - #! classes are at least at depth 1 in the inheritance - #! hierarchy. - default get swap simplify-echelon-alist - [ - [ - picker % - tuple-layout% - tuple-layout-echelon% - >=-case-quot % - ] [ ] make - ] unless-empty ; - -M: tuple-dispatch-engine engine>quot - [ - [ - tuple assumed set - echelons>> unclip-last - [ - [ - engine>quot - over 0 = [ - define-engine-word - [ remember-engine ] [ 1quotation ] bi - ] unless - dup default set - ] assoc-map - ] - [ first2 engine>quot 2array ] bi* - suffix - ] with-scope - echelon-case-quot % - ] [ ] make ; diff --git a/core/generic/standard/standard-docs.factor b/core/generic/standard/standard-docs.factor index 6e788eb947..33da0037b3 100644 --- a/core/generic/standard/standard-docs.factor +++ b/core/generic/standard/standard-docs.factor @@ -1,12 +1,7 @@ -USING: generic help.markup help.syntax sequences math +USING: generic generic.single help.markup help.syntax sequences math math.parser effects ; IN: generic.standard -HELP: no-method -{ $values { "object" "an object" } { "generic" "a generic word" } } -{ $description "Throws a " { $link no-method } " error." } -{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ; - HELP: standard-combination { $class-description "Performs standard method combination." @@ -22,32 +17,6 @@ HELP: standard-combination } } ; -HELP: hook-combination -{ $class-description - "Performs hook method combination . See " { $link POSTPONE: HOOK: } "." -} ; - HELP: define-simple-generic { $values { "word" "a word" } { "effect" effect } } -{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ; - -{ standard-combination hook-combination } related-words - -HELP: inconsistent-next-method -{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." } -{ $examples - "The following code throws this error:" - { $code - "GENERIC: error-test ( object -- )" - "" - "M: string error-test print ;" - "" - "M: integer error-test number>string call-next-method ;" - "" - "123 error-test" - } - "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method." - $nl - "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:" - { $code "M: integer error-test number>string error-test ;" } -} ; +{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ; \ No newline at end of file diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 5dbc0d17a1..bbf458ef1d 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -1,100 +1,10 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs kernel kernel.private slots.private math -namespaces make sequences vectors words quotations definitions -hashtables layouts combinators sequences.private generic -classes classes.algebra classes.private generic.standard.engines -generic.standard.engines.tag generic.standard.engines.predicate -generic.standard.engines.tuple accessors ; +USING: accessors definitions generic generic.single kernel +namespaces words math combinators ; IN: generic.standard -GENERIC: dispatch# ( word -- n ) - -M: generic dispatch# - "combination" word-prop dispatch# ; - -GENERIC: method-declaration ( class generic -- quot ) - -M: generic method-declaration - "combination" word-prop method-declaration ; - -M: quotation engine>quot - assumed get generic get method-declaration prepend ; - -ERROR: no-method object generic ; - -: error-method ( word -- quot ) - [ picker ] dip [ no-method ] curry append ; - -: push-method ( method specializer atomic assoc -- ) - [ - [ H{ } clone ] unless* - [ methods>> set-at ] keep - ] change-at ; - -: flatten-method ( class method assoc -- ) - [ [ flatten-class keys ] keep ] 2dip [ - [ spin ] dip push-method - ] 3curry each ; - -: flatten-methods ( assoc -- assoc' ) - H{ } clone [ - [ - flatten-method - ] curry assoc-each - ] keep ; - -: ( assoc -- engine ) - flatten-methods - convert-tuple-methods - convert-hi-tag-methods - ; - -: mangle-method ( method -- quot ) - 1quotation generic get extra-values \ drop - prepend [ ] like ; - -: find-default ( methods -- quot ) - #! Side-effects methods. - [ object bootstrap-word ] dip delete-at* [ - drop generic get "default-method" word-prop mangle-method - ] unless ; - -: ( word -- engine ) - object bootstrap-word assumed set { - [ generic set ] - [ "engines" word-prop forget-all ] - [ V{ } clone "engines" set-word-prop ] - [ - "methods" word-prop - [ mangle-method ] assoc-map - [ find-default default set ] - [ ] - bi - ] - } cleave ; - -: single-combination ( word -- quot ) - [ engine>quot ] with-scope ; - -ERROR: inconsistent-next-method class generic ; - -: single-next-method-quot ( class generic -- quot/f ) - 2dup next-method dup [ - [ - pick "predicate" word-prop % - 1quotation , - [ inconsistent-next-method ] 2curry , - \ if , - ] [ ] make - ] [ 3drop f ] if ; - -: single-effective-method ( obj word -- method ) - [ [ order [ instance? ] with find-last nip ] keep method ] - [ "default-method" word-prop ] - bi or ; - -TUPLE: standard-combination # ; +TUPLE: standard-combination < single-combination # ; C: standard-combination @@ -102,79 +12,26 @@ PREDICATE: standard-generic < generic "combination" word-prop standard-combination? ; PREDICATE: simple-generic < standard-generic - "combination" word-prop #>> zero? ; + "combination" word-prop #>> 0 = ; CONSTANT: simple-combination T{ standard-combination f 0 } : define-simple-generic ( word effect -- ) [ simple-combination ] dip define-generic ; -: with-standard ( combination quot -- quot' ) - [ #>> (dispatch#) ] dip with-variable ; inline +: (picker) ( n -- quot ) + { + { 0 [ [ dup ] ] } + { 1 [ [ over ] ] } + { 2 [ [ pick ] ] } + [ 1- (picker) [ dip swap ] curry ] + } case ; -M: standard-generic extra-values drop 0 ; - -M: standard-combination make-default-method - [ error-method ] with-standard ; - -M: standard-combination perform-combination - [ drop ] [ [ single-combination ] with-standard ] 2bi define ; +M: standard-combination picker + combination get #>> (picker) ; M: standard-combination dispatch# #>> ; -M: standard-combination method-declaration - dispatch# object swap prefix [ declare ] curry [ ] like ; - -M: standard-combination next-method-quot* - [ - single-next-method-quot - dup [ picker prepend ] when - ] with-standard ; - -M: standard-generic effective-method - [ dispatch# (picker) call ] keep single-effective-method ; - -TUPLE: hook-combination var ; - -C: hook-combination - -PREDICATE: hook-generic < generic - "combination" word-prop hook-combination? ; - -: with-hook ( combination quot -- quot' ) - 0 (dispatch#) [ - [ hook-combination ] dip with-variable - ] with-variable ; inline - -: prepend-hook-var ( quot -- quot' ) - hook-combination get var>> [ get ] curry prepend ; - -M: hook-combination dispatch# drop 0 ; - -M: hook-combination method-declaration 2drop [ ] ; - -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 prepend-hook-var ] with-hook ; - -M: hook-combination perform-combination - [ drop ] [ - [ single-combination prepend-hook-var ] with-hook - ] 2bi define ; - -M: hook-combination next-method-quot* - [ - single-next-method-quot - dup [ prepend-hook-var ] when - ] with-hook ; - M: simple-generic definer drop \ GENERIC: f ; -M: standard-generic definer drop \ GENERIC# f ; - -M: hook-generic definer drop \ HOOK: f ; +M: standard-generic definer drop \ GENERIC# f ; \ No newline at end of file diff --git a/core/generic/standard/summary.txt b/core/generic/standard/summary.txt deleted file mode 100644 index 5e731c6f15..0000000000 --- a/core/generic/standard/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Standard method combination used for most generic words diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 7ab287fd20..e8f86faa9d 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -1,7 +1,7 @@ USING: generic help.syntax help.markup kernel math parser words effects classes generic.standard classes.tuple generic.math -generic.standard arrays io.pathnames vocabs.loader io sequences -assocs words.symbol words.alias words.constant combinators ; +generic.standard generic.single arrays io.pathnames vocabs.loader io +sequences assocs words.symbol words.alias words.constant combinators ; IN: syntax ARTICLE: "parser-algorithm" "Parser algorithm" diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 2e072f72d8..3512b92e4c 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -4,7 +4,7 @@ USING: accessors alien arrays byte-arrays definitions generic hashtables kernel math namespaces parser lexer sequences strings strings.parser sbufs vectors words words.symbol words.constant words.alias quotations io assocs splitting classes.tuple -generic.standard generic.math generic.parser classes +generic.standard generic.hook generic.math generic.parser classes io.pathnames vocabs vocabs.parser classes.parser classes.union classes.intersection classes.mixin classes.predicate classes.singleton classes.tuple.parser compiler.units diff --git a/core/words/words.factor b/core/words/words.factor index eb0599db78..894b671494 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -154,8 +154,15 @@ M: word reset-word : reset-generic ( word -- ) [ subwords forget-all ] [ reset-word ] - [ { "methods" "combination" "default-method" } reset-props ] - tri ; + [ + { + "methods" + "combination" + "default-method" + "engines" + "decision-tree" + } reset-props + ] tri ; : gensym ( -- word ) "( gensym )" f ; From d03b1eef01778242512c6fb0a7fd542fb7ab78e7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 20:54:30 -0500 Subject: [PATCH 510/772] Compile methods of generic words since the generic word itself doesn't get compiled --- basis/compiler/compiler.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 26f9dc47c9..efa6294c98 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -163,7 +163,10 @@ M: optimizing-compiler recompile ( words -- alist ) [ compile-queue set H{ } clone compiled set - [ queue-compile ] each + [ + [ queue-compile ] + [ subwords [ compile-dependency ] each ] bi + ] each compile-queue get compile-loop compiled get >alist ] with-scope ; From b31f8a0d15775357aabbd0ce8e04dea4ad7c3810 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Fri, 24 Apr 2009 23:23:02 -0500 Subject: [PATCH 511/772] peg lexer changes --- extra/peg-lexer/peg-lexer.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/peg-lexer/peg-lexer.factor b/extra/peg-lexer/peg-lexer.factor index e7acf1f5bb..e58d8dd65b 100644 --- a/extra/peg-lexer/peg-lexer.factor +++ b/extra/peg-lexer/peg-lexer.factor @@ -1,5 +1,6 @@ USING: hashtables assocs sequences locals math accessors multiline delegate strings -delegate.protocols kernel peg peg.ebnf lexer namespaces combinators parser words ; +delegate.protocols kernel peg peg.ebnf peg.private lexer namespaces combinators parser +words ; IN: peg-lexer TUPLE: lex-hash hash ; @@ -43,11 +44,11 @@ M: lex-hash at* : parse* ( parser -- ast ) compile - [ execute( -- result ) [ error-stack get first throw ] unless* ] with-global-lexer + [ execute [ error-stack get first throw ] unless* ] with-global-lexer ast>> ; : create-bnf ( name parser -- ) - reset-tokenizer [ lexer get skip-blank parse* parsed ] curry + reset-tokenizer [ lexer get skip-blank parse* dup ignore? [ drop ] [ parsed ] if ] curry define-syntax ; SYNTAX: ON-BNF: From 8be8357e4d7393d114a588b2bee38ec2abdb6632 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Fri, 24 Apr 2009 23:23:35 -0500 Subject: [PATCH 512/772] ui.gadgets.alerts updated for new ui --- extra/ui/gadgets/alerts/alerts.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/ui/gadgets/alerts/alerts.factor b/extra/ui/gadgets/alerts/alerts.factor index 04c6b013df..03d60957fa 100644 --- a/extra/ui/gadgets/alerts/alerts.factor +++ b/extra/ui/gadgets/alerts/alerts.factor @@ -1,4 +1,4 @@ -USING: accessors ui ui.gadgets ui.gadgets.labels ui.gadgets.buttons ui.gadgets.packs locals sequences io.styles ; +USING: accessors ui ui.gadgets ui.gadgets.labels ui.gadgets.buttons ui.gadgets.packs locals sequences fonts io.styles ; IN: ui.gadgets.alerts -:: alert ( quot string -- ) { 10 10 } >>gap 1 >>align string