From b65feec3bdcc661b7110892deb6fc92f2f20cc77 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 17 Sep 2008 19:35:30 +1000 Subject: [PATCH 001/320] 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 002/320] 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 003/320] 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 004/320] 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 005/320] 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 006/320] 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 007/320] 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 008/320] 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 009/320] 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: Sat, 28 Mar 2009 04:19:02 -0500 Subject: [PATCH 010/320] 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 011/320] 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 509399b620e7046abac9bb67a84ce1a90c6b3b04 Mon Sep 17 00:00:00 2001 From: Maxim Savchenko Date: Wed, 1 Apr 2009 19:11:08 -0400 Subject: [PATCH 012/320] 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 07f585a81d266d7fc470417441c6f38fbed3d676 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 15:24:21 -0500 Subject: [PATCH 013/320] 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 59e0434815dbb5a32a79389568ed0ad934ee40b7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 8 Apr 2009 06:23:07 -0500 Subject: [PATCH 014/320] 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 015/320] 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 016/320] 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 2b384a7742b55ccaf59bde905798fb7cba15c5b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 8 Apr 2009 23:05:45 -0500 Subject: [PATCH 017/320] 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 018/320] 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 019/320] 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 020/320] 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 021/320] 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 022/320] 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 0a7485190bb88a87f6138efe4e63b065f0b47c95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 03:52:12 -0500 Subject: [PATCH 023/320] 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 4f41e07147f2ae26404e353f86b4c17cd1e53f00 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 04:41:12 -0500 Subject: [PATCH 024/320] 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 025/320] 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 8290624733f6f4df5c0ca5d6e87c8b374e95c706 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Apr 2009 07:08:16 -0500 Subject: [PATCH 026/320] 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 027/320] 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 028/320] 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 133/320] 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 134/320] 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 135/320] 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 136/320] 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 137/320] 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 138/320] 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 139/320] 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 140/320] 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 141/320] 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 142/320] 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 143/320] 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 144/320] 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 145/320] 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 146/320] 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 147/320] 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 148/320] 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 149/320] 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 150/320] 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 151/320] 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 152/320] 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 153/320] 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 154/320] 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 155/320] 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 156/320] 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 157/320] 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 158/320] 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 159/320] 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 160/320] 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 161/320] 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 162/320] 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 163/320] 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 164/320] 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 165/320] 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 166/320] 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 167/320] 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 168/320] 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 169/320] 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 170/320] 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 171/320] 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 172/320] 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 173/320] 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 174/320] 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 175/320] 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 176/320] 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 177/320] 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 178/320] 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 179/320] 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 180/320] 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 181/320] 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 182/320] 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 183/320] 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 184/320] 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 d039f9a946dfc414213e7dd297f5dc47708cfa95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Apr 2009 17:38:20 -0500 Subject: [PATCH 185/320] 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 186/320] 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 187/320] 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 188/320] 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 189/320] 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 190/320] 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 191/320] 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 0e6f76c13d8ded676ea792020f74e1fae00eae84 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 20 Apr 2009 14:15:38 +1000 Subject: [PATCH 192/320] 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 193/320] 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 194/320] 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 195/320] 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 196/320] 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 197/320] 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 198/320] 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 199/320] 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 200/320] 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 201/320] 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 202/320] 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 203/320] 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 204/320] 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 205/320] 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 206/320] 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 207/320] 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 208/320] 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 209/320] 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 210/320] 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 211/320] 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 212/320] 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 213/320] 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 214/320] 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 215/320] 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 216/320] 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 217/320] 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 218/320] 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 219/320] 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 220/320] 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 221/320] 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 222/320] 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 223/320] 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 224/320] 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 225/320] 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 226/320] 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 227/320] 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 228/320] 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 229/320] 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 230/320] 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 231/320] 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 232/320] 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 233/320] 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 234/320] 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 235/320] 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 236/320] 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 237/320] 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 238/320] 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 239/320] 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 240/320] 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 241/320] 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 242/320] 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 243/320] 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 244/320] 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 245/320] 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 246/320] 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 247/320] 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 248/320] 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 249/320] 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 250/320] 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 251/320] 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 252/320] 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 253/320] 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 254/320] 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 255/320] 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 256/320] 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 cd91b2e755cc42649f7837078c4df81eb8368eb6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 10:46:50 -0500 Subject: [PATCH 257/320] 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 258/320] 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 259/320] 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 260/320] 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 261/320] 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 24d854fb8e9fdf519ae475e88fadc4937b5516c6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 19:35:51 -0500 Subject: [PATCH 262/320] 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 263/320] 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 264/320] 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 265/320] 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 266/320] 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 267/320] 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 268/320] 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 269/320] 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 270/320] 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 271/320] 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 272/320] 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 273/320] 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 274/320] 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 275/320] 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 276/320] 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 277/320] 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 278/320] 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 279/320] 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 280/320] 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 281/320] 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 282/320] 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 b00d81e47bfcd4e25640ec294091272f98829774 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 09:44:29 -0500 Subject: [PATCH 283/320] 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 284/320] 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 285/320] 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 286/320] 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 c3c51e2c60d6409b95e237c9f1dd559b1fbdff6c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 24 Apr 2009 15:22:12 -0500 Subject: [PATCH 287/320] 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 0220609928a6561195225a89761c19458645386b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 24 Apr 2009 16:24:31 -0500 Subject: [PATCH 288/320] 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 5e5042fe5ff15fa5e4b4d60ccefa6cb3e8d9b9d8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 24 Apr 2009 19:01:26 -0500 Subject: [PATCH 289/320] 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 f24bf512890bc009b47f54113e395eada3510606 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 25 Apr 2009 16:52:23 -0500 Subject: [PATCH 290/320] mason: some fixes --- extra/mason/notify/notify.factor | 4 ++-- extra/mason/report/report.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor index 6bf4ae090d..96e31c4a45 100644 --- a/extra/mason/notify/notify.factor +++ b/extra/mason/notify/notify.factor @@ -2,7 +2,7 @@ ! 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 ; +mason.twitter namespaces sequences prettyprint ; IN: mason.notify : status-notify ( input-file args -- ) @@ -38,7 +38,7 @@ IN: mason.notify f { "test" } status-notify ; : notify-report ( status -- ) - [ "Build finished with status: " write print flush ] + [ "Build finished with status: " write . flush ] [ [ "report" utf8 file-contents ] dip email-report "report" { "report" } status-notify diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index edc8416235..64d31b4368 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -28,7 +28,7 @@ IN: mason.report common-report _ call( -- xml ) [XML <-><-> XML] - pprint-xml + write-xml ] with-file-writer ; inline :: failed-report ( error file what -- status ) From 66b4d42e133a412bbf6f844fab4168ed16804440 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 25 Apr 2009 17:03:50 -0500 Subject: [PATCH 291/320] math.blas: use gfortran by default on linux-x86-64 since latest ubuntu blas packages are compiled with gfortran abi --- basis/math/blas/config/config.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/blas/config/config.factor b/basis/math/blas/config/config.factor index 327c546963..09f736c036 100644 --- a/basis/math/blas/config/config.factor +++ b/basis/math/blas/config/config.factor @@ -18,7 +18,7 @@ blas-fortran-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 ] } + { [ os linux? ] [ gfortran-abi ] } [ f2c-abi ] } cond ] initialize From 2330ec3042f986abd8714837ca359563ad5f6c55 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Apr 2009 18:59:03 -0500 Subject: [PATCH 292/320] use ui.images drawing code in images.viewer --- extra/images/viewer/viewer.factor | 25 +++++++++---------------- 1 file changed, 9 insertions(+), 16 deletions(-) diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index cf9e9c836a..2818c16f9f 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -2,33 +2,26 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors images images.loader io.pathnames kernel namespaces opengl opengl.gl opengl.textures sequences strings ui ui.gadgets -ui.gadgets.panes ui.render ; +ui.gadgets.panes ui.render ui.images ; IN: images.viewer -TUPLE: image-gadget < gadget { image image } ; +TUPLE: image-gadget < gadget image-name ; M: image-gadget pref-dim* - image>> dim>> ; - -: draw-image ( image -- ) - 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom - [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri - glDrawPixels ; + image-name>> image-dim ; M: image-gadget draw-gadget* ( gadget -- ) - image>> draw-image ; + image-name>> draw-image ; -: ( image -- gadget ) +: ( image-name -- gadget ) \ image-gadget new - swap >>image ; + swap >>image-name ; : image-window ( path -- gadget ) - [ load-image dup ] [ open-window ] bi ; + [ dup ] [ open-window ] bi ; GENERIC: image. ( object -- ) -M: string image. ( image -- ) load-image image. ; +M: string image. ( image -- ) gadget. ; -M: pathname image. ( image -- ) load-image image. ; - -M: image image. ( image -- ) gadget. ; +M: pathname image. ( image -- ) gadget. ; From 2484ea07b0f7de236bbb5260116a8243f35ea453 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Apr 2009 19:22:00 -0500 Subject: [PATCH 293/320] support read-only mmap --- basis/io/mmap/functor/functor.factor | 12 ++++++++---- basis/io/mmap/mmap-docs.factor | 8 +++++++- basis/io/mmap/mmap.factor | 24 ++++++++++++++++++++---- basis/io/mmap/unix/unix.factor | 7 ++++++- basis/io/mmap/windows/windows.factor | 11 ++++++++++- 5 files changed, 51 insertions(+), 11 deletions(-) diff --git a/basis/io/mmap/functor/functor.factor b/basis/io/mmap/functor/functor.factor index 21b3d294c9..a80ce3bc82 100644 --- a/basis/io/mmap/functor/functor.factor +++ b/basis/io/mmap/functor/functor.factor @@ -9,13 +9,14 @@ SLOT: length : mapped-file>direct ( mapped-file type -- alien length ) [ [ address>> ] [ length>> ] bi ] dip - heap-size [ 1- + ] keep /i ; + heap-size [ 1 - + ] keep /i ; FUNCTOR: define-mapped-array ( T -- ) - DEFINES - IS -with-mapped-A-file DEFINES with-mapped-${T}-file + DEFINES + IS +with-mapped-A-file DEFINES with-mapped-${T}-file +with-mapped-A-file-reader DEFINES with-mapped-${T}-file-reader WHERE @@ -25,4 +26,7 @@ WHERE : with-mapped-A-file ( path quot -- ) '[ @ ] with-mapped-file ; inline +: with-mapped-A-file-reader ( path quot -- ) + '[ @ ] with-mapped-file-reader ; inline + ;FUNCTOR diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index f0adb47321..1da82e42e2 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -18,7 +18,13 @@ HELP: HELP: with-mapped-file { $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } } -{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } +{ $contract "Opens a file for read/write access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } +{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." } +{ $errors "Throws an error if a memory mapping could not be established." } ; + +HELP: with-mapped-file-reader +{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } } +{ $contract "Opens a file for read-only access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } { $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." } { $errors "Throws an error if a memory mapping could not be established." } ; diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor index 1a58471514..e03d5fb30b 100644 --- a/basis/io/mmap/mmap.factor +++ b/basis/io/mmap/mmap.factor @@ -8,14 +8,27 @@ IN: io.mmap TUPLE: mapped-file address handle length disposed ; -HOOK: (mapped-file) os ( path length -- address handle ) +HOOK: (mapped-file-reader) os ( path length -- address handle ) +HOOK: (mapped-file-r/w) os ( path length -- address handle ) ERROR: bad-mmap-size path size ; -: ( path -- mmap ) +> ] bi - dup 0 <= [ bad-mmap-size ] when - [ (mapped-file) ] keep + dup 0 <= [ bad-mmap-size ] when ; + +PRIVATE> + +: ( path -- mmap ) + prepare-mapped-file + [ (mapped-file-reader) ] keep + f mapped-file boa ; + +: ( path -- mmap ) + prepare-mapped-file + [ (mapped-file-r/w) ] keep f mapped-file boa ; HOOK: close-mapped-file io-backend ( mmap -- ) @@ -25,6 +38,9 @@ M: mapped-file dispose* ( mmap -- ) close-mapped-file ; : with-mapped-file ( path quot -- ) [ ] dip with-disposal ; inline +: with-mapped-file-reader ( path quot -- ) + [ ] dip with-disposal ; inline + { { [ os unix? ] [ "io.mmap.unix" require ] } { [ os winnt? ] [ "io.mmap.windows" require ] } diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor index 0fa8e1151f..0424321b84 100644 --- a/basis/io/mmap/unix/unix.factor +++ b/basis/io/mmap/unix/unix.factor @@ -13,11 +13,16 @@ IN: io.mmap.unix [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep ] with-destructors ; -M: unix (mapped-file) +M: unix (mapped-file-r/w) { PROT_READ PROT_WRITE } flags { MAP_FILE MAP_SHARED } flags mmap-open ; +M: unix (mapped-file-reader) + { PROT_READ } flags + { MAP_FILE MAP_SHARED } flags + mmap-open ; + M: unix close-mapped-file ( mmap -- ) [ [ address>> ] [ length>> ] bi munmap io-error ] [ handle>> close-file ] diff --git a/basis/io/mmap/windows/windows.factor b/basis/io/mmap/windows/windows.factor index fcdf416511..ebd8109d14 100644 --- a/basis/io/mmap/windows/windows.factor +++ b/basis/io/mmap/windows/windows.factor @@ -28,7 +28,7 @@ M: win32-mapped-file dispose C: win32-mapped-file -M: windows (mapped-file) +M: windows (mapped-file-r/w) [ { GENERIC_WRITE GENERIC_READ } flags OPEN_ALWAYS @@ -37,6 +37,15 @@ M: windows (mapped-file) -rot ] with-destructors ; +M: windows (mapped-file-reader) + [ + GENERIC_READ + OPEN_ALWAYS + { PAGE_READONLY SEC_COMMIT } flags + FILE_MAP_READ mmap-open + -rot + ] with-destructors ; + M: windows close-mapped-file ( mapped-file -- ) [ [ handle>> &dispose drop ] From 345b27a67327d9db425b3c8f3f208105ef1121ab Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 25 Apr 2009 19:22:03 -0500 Subject: [PATCH 294/320] dog tag for pair-rocket --- extra/pair-rocket/pair-rocket-tests.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/pair-rocket/pair-rocket-tests.factor b/extra/pair-rocket/pair-rocket-tests.factor index 0e3d27beb1..695e50ea7e 100644 --- a/extra/pair-rocket/pair-rocket-tests.factor +++ b/extra/pair-rocket/pair-rocket-tests.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff bsd license USING: kernel pair-rocket tools.test ; IN: pair-rocket.tests From 90d40a7650c16dda91e8bc01c33676a8cb0c71cd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Apr 2009 19:22:46 -0500 Subject: [PATCH 295/320] calculate a magic number in md5 --- basis/checksums/md5/md5.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index 04c6c2497e..29620b089d 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -14,7 +14,7 @@ IN: checksums.md5 SYMBOLS: a b c d old-a old-b old-c old-d ; : T ( N -- Y ) - sin abs 4294967296 * >integer ; foldable + sin abs 32 2^ * >integer ; foldable : initialize-md5 ( -- ) 0 bytes-read set From 592a840c52ad322ef7cf2841e06ea02d1cfd7563 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 25 Apr 2009 19:22:47 -0500 Subject: [PATCH 296/320] a syntax pearl for literal string arrays --- extra/qw/authors.txt | 1 + extra/qw/qw-docs.factor | 11 +++++++++++ extra/qw/qw-tests.factor | 5 +++++ extra/qw/qw.factor | 5 +++++ extra/qw/summary.txt | 1 + 5 files changed, 23 insertions(+) create mode 100644 extra/qw/authors.txt create mode 100644 extra/qw/qw-docs.factor create mode 100644 extra/qw/qw-tests.factor create mode 100644 extra/qw/qw.factor create mode 100644 extra/qw/summary.txt diff --git a/extra/qw/authors.txt b/extra/qw/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/qw/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/qw/qw-docs.factor b/extra/qw/qw-docs.factor new file mode 100644 index 0000000000..8af2c14f1e --- /dev/null +++ b/extra/qw/qw-docs.factor @@ -0,0 +1,11 @@ +USING: help.markup help.syntax multiline ; +IN: qw + +HELP: qw{ +{ $syntax "qw{ lorem ipsum }" } +{ $description "Marks the beginning of a literal array of strings. Component strings are delimited by whitespace." } +{ $examples +{ $unchecked-example <" USING: prettyprint qw ; +qw{ pop quiz my hive of big wild ex tranny jocks } . "> +<" { "pop" "quiz" "my" "hive" "of" "big" "wild" "ex" "tranny" "jocks" } "> } +} ; diff --git a/extra/qw/qw-tests.factor b/extra/qw/qw-tests.factor new file mode 100644 index 0000000000..c9d9208751 --- /dev/null +++ b/extra/qw/qw-tests.factor @@ -0,0 +1,5 @@ +! (c)2009 Joe Groff bsd license +USING: qw tools.test ; +IN: qw.tests + +[ { "zippity" "doo" "dah" } ] [ qw{ zippity doo dah } ] unit-test diff --git a/extra/qw/qw.factor b/extra/qw/qw.factor new file mode 100644 index 0000000000..ce96587c92 --- /dev/null +++ b/extra/qw/qw.factor @@ -0,0 +1,5 @@ +! (c)2009 Joe Groff bsd license +USING: lexer parser ; +IN: qw + +SYNTAX: qw{ "}" parse-tokens parsed ; diff --git a/extra/qw/summary.txt b/extra/qw/summary.txt new file mode 100644 index 0000000000..8c31961dc8 --- /dev/null +++ b/extra/qw/summary.txt @@ -0,0 +1 @@ +Perlish syntax for literal arrays of whitespace-delimited strings (qw{ foo bar }) From a1fc4616e93dfa85cb991c7d0f9a446fcd312493 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 25 Apr 2009 19:24:01 -0500 Subject: [PATCH 297/320] dog tag again --- extra/qw/qw-docs.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/qw/qw-docs.factor b/extra/qw/qw-docs.factor index 8af2c14f1e..4709ef620d 100644 --- a/extra/qw/qw-docs.factor +++ b/extra/qw/qw-docs.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff bsd license USING: help.markup help.syntax multiline ; IN: qw From 71f2e997a6febc2787413bcb28877aac99a4f953 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Apr 2009 19:26:16 -0500 Subject: [PATCH 298/320] use read-only mmap in id3. save id3 parsing errors --- extra/id3/id3.factor | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index a5671a5822..6025af4926 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 math.functions ; +io.directories.search literals math.functions continuations ; IN: id3 id3) ( path -- id3v2/f ) +PRIVATE> + +: mp3>id3 ( path -- id3v2/f ) [ [ ] dip { @@ -213,12 +215,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] [ 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 -- id3/f ) - dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; + ] with-mapped-uchar-file-reader ; : find-id3-frame ( id3 name -- obj/f ) swap frames>> at* [ data>> ] when ; @@ -239,8 +236,14 @@ PRIVATE> : find-mp3s ( path -- seq ) [ >lower ".mp3" tail? ] find-all-files ; +ERROR: id3-parse-error path error ; + +: (mp3-paths>id3s) ( seq -- seq' ) + [ dup [ mp3>id3 ] [ \ id3-parse-error boa ] recover ] { } map>assoc ; + : mp3-paths>id3s ( seq -- seq' ) - [ dup mp3>id3 ] { } map>assoc ; + (mp3-paths>id3s) + [ dup second id3-parse-error? [ f over set-second ] when ] map ; : parse-mp3-directory ( path -- seq ) find-mp3s mp3-paths>id3s ; From c44349c74eaca7dea0b41ec86673625ce8480248 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Apr 2009 19:32:44 -0500 Subject: [PATCH 299/320] test read-only mmap --- basis/io/mmap/mmap-tests.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/io/mmap/mmap-tests.factor b/basis/io/mmap/mmap-tests.factor index a4d55f3c1e..0e1cd1a036 100644 --- a/basis/io/mmap/mmap-tests.factor +++ b/basis/io/mmap/mmap-tests.factor @@ -7,6 +7,7 @@ IN: io.mmap.tests [ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test [ ] [ "mmap-test-file.txt" temp-file [ CHAR: 2 0 pick set-nth drop ] with-mapped-char-file ] unit-test [ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test +[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file-reader ] unit-test [ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors From 3f764fc8720469b77ed3d37b7069d5bc0b8e675a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Apr 2009 20:02:41 -0500 Subject: [PATCH 300/320] fix file mode for read only mmap in unix --- basis/io/mmap/unix/unix.factor | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor index 0424321b84..7d12d52361 100644 --- a/basis/io/mmap/unix/unix.factor +++ b/basis/io/mmap/unix/unix.factor @@ -4,26 +4,23 @@ USING: alien io io.files kernel math math.bitwise system unix io.backend.unix io.ports io.mmap destructors locals accessors ; IN: io.mmap.unix -: open-r/w ( path -- fd ) O_RDWR file-mode open-file ; - -:: mmap-open ( path length prot flags -- alien fd ) +:: mmap-open ( path length prot flags open-mode -- alien fd ) [ f length prot flags - path open-r/w [ |dispose drop ] keep + path open-mode file-mode open-file [ |dispose drop ] keep [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep ] with-destructors ; M: unix (mapped-file-r/w) { PROT_READ PROT_WRITE } flags { MAP_FILE MAP_SHARED } flags - mmap-open ; + O_RDWR mmap-open ; M: unix (mapped-file-reader) { PROT_READ } flags { MAP_FILE MAP_SHARED } flags - mmap-open ; + O_RDONLY mmap-open ; M: unix close-mapped-file ( mmap -- ) [ [ address>> ] [ length>> ] bi munmap io-error ] - [ handle>> close-file ] - bi ; + [ handle>> close-file ] bi ; From e32869b0c305cfea8f932fc2856399aab04c26f0 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 25 Apr 2009 20:07:54 -0500 Subject: [PATCH 301/320] =?UTF-8?q?r=C3=B4les?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- extra/roles/roles-tests.factor | 55 +++++++++++++++++++++++++++ extra/roles/roles.factor | 69 ++++++++++++++++++++++++++++++++++ 2 files changed, 124 insertions(+) create mode 100644 extra/roles/roles-tests.factor create mode 100644 extra/roles/roles.factor diff --git a/extra/roles/roles-tests.factor b/extra/roles/roles-tests.factor new file mode 100644 index 0000000000..aaa197f5ed --- /dev/null +++ b/extra/roles/roles-tests.factor @@ -0,0 +1,55 @@ +! (c)2009 Joe Groff bsd license +USING: accessors classes.tuple compiler.units kernel qw roles sequences +tools.test ; +IN: roles.tests + +ROLE: fork tines ; +ROLE: spoon bowl ; +ROLE: instrument tone ; +ROLE: tuning-fork <{ fork instrument } volume ; + +TUPLE: utensil handle ; + +! role consumption and tuple inheritance can be mixed +TUPLE: foon <{ utensil fork spoon } ; +TUPLE: tuning-spork <{ utensil spoon tuning-fork } ; + +! role class testing +[ t ] [ fork role? ] unit-test +[ f ] [ foon role? ] unit-test + +! roles aren't tuple classes by themselves and can't be instantiated +[ f ] [ fork tuple-class? ] unit-test +[ fork new ] must-fail + +! tuples which consume roles fall under their class +[ t ] [ foon new fork? ] unit-test +[ t ] [ foon new spoon? ] unit-test +[ f ] [ foon new tuning-fork? ] unit-test +[ f ] [ foon new instrument? ] unit-test + +[ t ] [ tuning-spork new fork? ] unit-test +[ t ] [ tuning-spork new spoon? ] unit-test +[ t ] [ tuning-spork new tuning-fork? ] unit-test +[ t ] [ tuning-spork new instrument? ] unit-test + +! consumed role slots are placed in tuples in order +[ qw{ handle tines bowl } ] [ foon all-slots [ name>> ] map ] unit-test +[ qw{ handle bowl tines tone volume } ] [ tuning-spork all-slots [ name>> ] map ] unit-test + +! can't combine roles whose slots overlap +ROLE: bong bowl ; +SYMBOL: spong + +[ [ spong { spoon bong } { } define-tuple-class-with-roles ] with-compilation-unit ] +[ role-slot-overlap? ] must-fail-with + +[ [ spong { spoon bong } { } define-role ] with-compilation-unit ] +[ role-slot-overlap? ] must-fail-with + +! can't try to inherit multiple tuple classes +TUPLE: tool blade ; +SYMBOL: knife + +[ knife { utensil tool } { } define-tuple-class-with-roles ] +[ multiple-inheritance-attempted? ] must-fail-with diff --git a/extra/roles/roles.factor b/extra/roles/roles.factor new file mode 100644 index 0000000000..f9ce808eb8 --- /dev/null +++ b/extra/roles/roles.factor @@ -0,0 +1,69 @@ +! (c)2009 Joe Groff bsd license +USING: accessors arrays classes classes.mixin classes.parser +classes.tuple classes.tuple.parser combinators +combinators.short-circuit kernel lexer make parser sequences +sets strings words ; +IN: roles + +ERROR: role-slot-overlap class slots ; +ERROR: multiple-inheritance-attempted classes ; + +PREDICATE: role < class + { [ mixin-class? ] [ "role-slots" word-prop >boolean ] } 1&& ; + +: parse-role-definition ( -- class superroles slots ) + CREATE-CLASS scan { + { ";" [ { } { } ] } + { "<" [ scan-word 1array [ parse-tuple-slots ] { } make ] } + { "<{" [ \ } parse-until >array [ parse-tuple-slots ] { } make ] } + [ { } swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ] + } case ; + +: slot-name ( name/array -- name ) + dup string? [ ] [ first ] if ; +: slot-names ( array -- names ) + [ slot-name ] map ; + +: role-slots ( role -- slots ) + [ "superroles" word-prop [ role-slots ] map concat ] + [ "role-slots" word-prop ] bi append ; + +: role-or-tuple-slot-names ( role-or-tuple -- names ) + dup role? + [ role-slots slot-names ] + [ all-slots [ name>> ] map ] if ; + +: check-for-slot-overlap ( class roles-and-superclass slots -- ) + [ [ role-or-tuple-slot-names ] map concat ] [ slot-names ] bi* append + duplicates dup empty? [ 2drop ] [ role-slot-overlap ] if ; + +: roles>slots ( roles-and-superclass slots -- superclass slots' ) + [ + [ role? ] partition + dup length { + { 0 [ drop tuple ] } + { 1 [ first ] } + [ drop multiple-inheritance-attempted ] + } case + swap [ role-slots ] map concat + ] dip append ; + +: add-to-roles ( class roles -- ) + [ add-mixin-instance ] with each ; + +: (define-role) ( class superroles slots -- ) + [ "superroles" set-word-prop ] [ "role-slots" set-word-prop ] bi-curry* + [ define-mixin-class ] tri ; + +: define-role ( class superroles slots -- ) + [ check-for-slot-overlap ] [ (define-role) ] [ drop add-to-roles ] 3tri ; + +: define-tuple-class-with-roles ( class roles-and-superclass slots -- ) + [ check-for-slot-overlap ] + [ roles>slots define-tuple-class ] + [ drop [ role? ] filter add-to-roles ] 3tri ; + +SYNTAX: ROLE: parse-role-definition define-role ; +SYNTAX: TUPLE: parse-role-definition define-tuple-class-with-roles ; + + From 32d2377df1f0799354e0d21bcae371e5d41d239b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 25 Apr 2009 20:18:45 -0500 Subject: [PATCH 302/320] test method dispatch on roles --- extra/roles/roles-tests.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/extra/roles/roles-tests.factor b/extra/roles/roles-tests.factor index aaa197f5ed..fcbc20db16 100644 --- a/extra/roles/roles-tests.factor +++ b/extra/roles/roles-tests.factor @@ -53,3 +53,15 @@ SYMBOL: knife [ knife { utensil tool } { } define-tuple-class-with-roles ] [ multiple-inheritance-attempted? ] must-fail-with + +! make sure method dispatch works +GENERIC: poke ( pokee poker -- result ) +GENERIC: scoop ( scoopee scooper -- result ) +GENERIC: tune ( tunee tuner -- result ) + +M: fork poke drop " got poked" append ; +M: spoon scoop drop " got scooped" append ; +M: instrument tune drop " got tuned" append ; + +[ "potato got poked" "potato got scooped" "potato got tuned" ] +[ "potato" tuning-spork new [ poke ] [ scoop ] [ tune ] 2tri ] unit-test From 81bef5d62c6f893110871211798168eb5b4f709b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Apr 2009 21:03:12 -0500 Subject: [PATCH 303/320] fix help lint for id3 --- extra/id3/id3.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 6025af4926..79df00ff5e 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -207,7 +207,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] PRIVATE> -: mp3>id3 ( path -- id3v2/f ) +: mp3>id3 ( path -- id3/f ) [ [ ] dip { From 395e4267fd68142716861ec4468441092ddbfc28 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 25 Apr 2009 21:20:19 -0500 Subject: [PATCH 304/320] docs for roles --- extra/roles/authors.txt | 1 + extra/roles/roles-docs.factor | 48 +++++++++++++++++++++++++++++++++++ extra/roles/summary.txt | 1 + 3 files changed, 50 insertions(+) create mode 100644 extra/roles/authors.txt create mode 100644 extra/roles/roles-docs.factor create mode 100644 extra/roles/summary.txt diff --git a/extra/roles/authors.txt b/extra/roles/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/roles/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/roles/roles-docs.factor b/extra/roles/roles-docs.factor new file mode 100644 index 0000000000..412a7b8dcb --- /dev/null +++ b/extra/roles/roles-docs.factor @@ -0,0 +1,48 @@ +! (c)2009 Joe Groff bsd license +USING: classes.mixin help.markup help.syntax kernel multiline roles ; +IN: roles + +HELP: ROLE: +{ $syntax <" ROLE: name slots... ; +ROLE: name < role slots... ; +ROLE: name <{ roles... } slots... ; "> } +{ $description "Defines a new " { $link role } ". " { $link tuple } " classes which inherit this role will contain the specified " { $snippet "slots" } " as well as the slots associated with the optional inherited " { $snippet "roles" } "." +$nl +"Slot specifiers take one of the following three forms:" +{ $list + { { $snippet "name" } " - a slot which can hold any object, with no attributes" } + { { $snippet "{ name attributes... }" } " - a slot which can hold any object, with optional attributes" } + { { $snippet "{ name class attributes... }" } " - a slot specialized to a specific class, with optional attributes" } +} +"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } ; + +HELP: TUPLE: +{ $syntax <" TUPLE: name slots ; +TUPLE: name < estate slots ; +TUPLE: name <{ estates... } slots... ; "> } +{ $description "Defines a new " { $link tuple } " class." +$nl +"The list of inherited " { $snippet "estates" } " is optional; a single tuple superclass and/or a set of " { $link role } "s can be specified. If no superclass is provided, it defaults to " { $link tuple } "." +$nl +"Slot specifiers take one of the following three forms:" +{ $list + { { $snippet "name" } " - a slot which can hold any object, with no attributes" } + { { $snippet "{ name attributes... }" } " - a slot which can hold any object, with optional attributes" } + { { $snippet "{ name class attributes... }" } " - a slot specialized to a specific class, with optional attributes" } +} +"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } ; + +{ + POSTPONE: ROLE: + POSTPONE: TUPLE: +} related-words + +HELP: role +{ $class-description "The superclass of all role classes. A " { $snippet "role" } " is a " { $link mixin-class } " that includes a set of slot definitions that can be added to " { $link tuple } " classes alongside other " { $snippet "role" } "s." } ; + +HELP: multiple-inheritance-attempted +{ $class-description "This error is thrown if a " { $link POSTPONE: TUPLE: } " definition attempts to inherit more than one " { $link tuple } " class." } ; + +HELP: role-slot-overlap +{ $class-description "This error is thrown if a " { $link POSTPONE: TUPLE: } " or " { $link POSTPONE: ROLE: } " definition attempts to inherit a set of " { $link role } "s in which more than one attempts to define the same slot." } ; + diff --git a/extra/roles/summary.txt b/extra/roles/summary.txt new file mode 100644 index 0000000000..a14aae4838 --- /dev/null +++ b/extra/roles/summary.txt @@ -0,0 +1 @@ +Mixins for tuples From bada2176bc6af9bd3cd736aaaf639dcd01bbad1b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Apr 2009 21:21:15 -0500 Subject: [PATCH 305/320] use new locals syntax in calendar, add routine for calculating easter --- basis/calendar/calendar-tests.factor | 9 +++- basis/calendar/calendar.factor | 64 +++++++++++++++++++--------- 2 files changed, 52 insertions(+), 21 deletions(-) diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor index 256b4e1b42..8d1071122d 100644 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -1,5 +1,5 @@ USING: arrays calendar kernel math sequences tools.test -continuations system math.order threads ; +continuations system math.order threads accessors ; IN: calendar.tests [ f ] [ 2004 12 32 0 0 0 instant valid-timestamp? ] unit-test @@ -163,3 +163,10 @@ IN: calendar.tests [ t ] [ now 50 milliseconds sleep now before? ] unit-test [ t ] [ now 50 milliseconds sleep now swap after? ] unit-test [ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test + +[ 4 12 ] [ 2009 easter [ month>> ] [ day>> ] bi ] unit-test +[ 4 2 ] [ 1961 easter [ month>> ] [ day>> ] bi ] unit-test + +[ f ] [ now dup midnight eq? ] unit-test +[ f ] [ now dup easter eq? ] unit-test +[ f ] [ now dup beginning-of-year eq? ] unit-test diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 7a03fe4408..4b58b1b496 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays classes.tuple combinators combinators.short-circuit - kernel locals math math.functions math.order namespaces sequences strings - summary system threads vocabs.loader ; +USING: accessors arrays classes.tuple combinators +combinators.short-circuit kernel locals math math.functions +math.order sequences summary system threads vocabs.loader ; IN: calendar HOOK: gmt-offset os ( -- hours minutes seconds ) @@ -94,26 +94,50 @@ CONSTANT: day-abbreviations3 :: julian-day-number ( year month day -- n ) #! Returns a composite date number #! Not valid before year -4800 - [let* | a [ 14 month - 12 /i ] - y [ year 4800 + a - ] - m [ month 12 a * + 3 - ] | - day 153 m * 2 + 5 /i + 365 y * + - y 4 /i + y 100 /i - y 400 /i + 32045 - - ] ; + 14 month - 12 /i :> a + year 4800 + a - :> y + month 12 a * + 3 - :> m + + day 153 m * 2 + 5 /i + 365 y * + + y 4 /i + y 100 /i - y 400 /i + 32045 - ; :: julian-day-number>date ( n -- year month day ) #! Inverse of julian-day-number - [let* | a [ n 32044 + ] - b [ 4 a * 3 + 146097 /i ] - c [ a 146097 b * 4 /i - ] - d [ 4 c * 3 + 1461 /i ] - e [ c 1461 d * 4 /i - ] - m [ 5 e * 2 + 153 /i ] | - 100 b * d + 4800 - - m 10 /i + m 3 + - 12 m 10 /i * - - e 153 m * 2 + 5 /i - 1+ - ] ; + n 32044 + :> a + 4 a * 3 + 146097 /i :> b + a 146097 b * 4 /i - :> c + 4 c * 3 + 1461 /i :> d + c 1461 d * 4 /i - :> e + 5 e * 2 + 153 /i :> m + + 100 b * d + 4800 - + m 10 /i + m 3 + + 12 m 10 /i * - + e 153 m * 2 + 5 /i - 1+ ; + +GENERIC: easter ( obj -- obj' ) + +:: easter-month-day ( year -- month day ) + year 19 mod :> a + year 100 /mod :> c :> b + b 4 /mod :> e :> d + b 8 + 25 /i :> f + b f - 1 + 3 /i :> g + 19 a * b + d - g - 15 + 30 mod :> h + c 4 /mod :> k :> i + 32 2 e * + 2 i * + h - k - 7 mod :> l + a 11 h * + 22 l * + 451 /i :> m + + h l + 7 m * - 114 + 31 /mod 1 + :> day :> month + month day ; + +M: integer easter ( year -- timestamp ) + dup easter-month-day ; + +M: timestamp easter ( timestamp -- timestamp ) + clone + dup year>> easter-month-day + swapd >>day swap >>month ; : >date< ( timestamp -- year month day ) [ year>> ] [ month>> ] [ day>> ] tri ; From cdb17b74333d3cd13f6516cb46ea4d60d4b2dc99 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 26 Apr 2009 00:45:03 -0500 Subject: [PATCH 306/320] make fasta work again --- extra/benchmark/fasta/fasta.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index 2ae5ada8a1..f457b90c30 100755 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -46,8 +46,8 @@ CONSTANT: homo-sapiens } : make-cumulative ( freq -- chars floats ) - dup keys >byte-array - swap values >double-array unclip [ + ] accumulate swap suffix ; + [ keys >byte-array ] + [ values >double-array ] bi unclip [ + ] accumulate swap suffix ; :: select-random ( seed chars floats -- seed elt ) floats seed random -rot @@ -55,7 +55,7 @@ CONSTANT: homo-sapiens chars nth-unsafe ; inline : make-random-fasta ( seed len chars floats -- seed ) - [ rot drop select-random ] 2curry B{ } map-as print ; inline + [ rot drop select-random ] 2curry "" map-as print ; inline : write-description ( desc id -- ) ">" write write bl print ; inline @@ -71,7 +71,7 @@ CONSTANT: homo-sapiens :: make-repeat-fasta ( k len alu -- k' ) [let | kn [ alu length ] | - len [ k + kn mod alu nth-unsafe ] B{ } map-as print + len [ k + kn mod alu nth-unsafe ] "" map-as print k len + ] ; inline From a25376278b4cf396fb81c9fbe8b4f36cd112a12c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 26 Apr 2009 00:45:14 -0500 Subject: [PATCH 307/320] set error-summary? to true by default --- basis/listener/listener.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index d96e0df6c1..68777f2f73 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -62,6 +62,8 @@ SYMBOL: max-stack-items SYMBOL: error-summary? +t error-summary? set-global + Date: Sun, 26 Apr 2009 00:51:47 -0500 Subject: [PATCH 308/320] fix IN: for compiler tests --- basis/compiler/tests/alien.factor | 2 +- basis/compiler/tests/codegen.factor | 4 ++-- basis/compiler/tests/curry.factor | 2 +- basis/compiler/tests/float.factor | 2 +- basis/compiler/tests/folding.factor | 2 +- basis/compiler/tests/intrinsics.factor | 2 +- basis/compiler/tests/optimizer.factor | 2 +- basis/compiler/tests/peg-regression-2.factor | 4 ++-- basis/compiler/tests/peg-regression.factor | 2 +- basis/compiler/tests/redefine0.factor | 2 +- basis/compiler/tests/redefine1.factor | 2 +- basis/compiler/tests/redefine10.factor | 2 +- basis/compiler/tests/redefine11.factor | 2 +- basis/compiler/tests/redefine15.factor | 2 +- basis/compiler/tests/redefine2.factor | 2 +- basis/compiler/tests/redefine3.factor | 2 +- basis/compiler/tests/redefine4.factor | 2 +- basis/compiler/tests/redefine5.factor | 2 +- basis/compiler/tests/redefine6.factor | 2 +- basis/compiler/tests/redefine7.factor | 2 +- basis/compiler/tests/redefine8.factor | 2 +- basis/compiler/tests/redefine9.factor | 2 +- basis/compiler/tests/reload.factor | 2 +- basis/compiler/tests/simple.factor | 2 +- basis/compiler/tests/spilling.factor | 2 +- basis/compiler/tests/stack-trace.factor | 2 +- basis/compiler/tests/tuples.factor | 2 +- 27 files changed, 29 insertions(+), 29 deletions(-) diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 4d7882ad08..42ed90d64a 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -5,7 +5,7 @@ continuations effects namespaces.private io io.streams.string memory system threads tools.test math accessors combinators specialized-arrays.float alien.libraries io.pathnames io.backend ; -IN: compiler.tests +IN: compiler.tests.alien << : libfactor-ffi-tests-path ( -- string ) diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 2e02e5476c..c746fdfb45 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -4,7 +4,7 @@ sequences sequences.private tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io combinators vectors grouping make ; -IN: compiler.tests +IN: compiler.tests.codegen ! Originally, this file did black box testing of templating ! optimization. We now have a different codegen, but the tests @@ -281,4 +281,4 @@ TUPLE: cucumber ; M: cucumber equal? "The cucumber has no equal" throw ; -[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test \ No newline at end of file +[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test diff --git a/basis/compiler/tests/curry.factor b/basis/compiler/tests/curry.factor index 2d1f15b9a8..32611ba87a 100644 --- a/basis/compiler/tests/curry.factor +++ b/basis/compiler/tests/curry.factor @@ -1,6 +1,6 @@ USING: tools.test quotations math kernel sequences assocs namespaces make compiler.units compiler ; -IN: compiler.tests +IN: compiler.tests.curry [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test [ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index b439b5f6a4..1a604dbd8e 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.float USING: compiler.units compiler kernel kernel.private memory math math.private tools.test math.floats.private ; diff --git a/basis/compiler/tests/folding.factor b/basis/compiler/tests/folding.factor index fe2f801de2..5050ce1950 100644 --- a/basis/compiler/tests/folding.factor +++ b/basis/compiler/tests/folding.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel classes.mixin arrays ; -IN: compiler.tests +IN: compiler.tests.folding ! Calls to generic words were not folded away. diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 93860db924..a6e827ea33 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -6,7 +6,7 @@ sbufs strings.private slots.private alien math.order alien.accessors alien.c-types alien.syntax alien.strings namespaces libc sequences.private io.encodings.ascii classes compiler ; -IN: compiler.tests +IN: compiler.tests.intrinsics ! Make sure that intrinsic ops compile to correct code. [ ] [ 1 [ drop ] compile-call ] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 99bdb18812..bd7008f909 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -5,7 +5,7 @@ quotations classes classes.algebra classes.tuple.private continuations growable namespaces hints alien.accessors compiler.tree.builder compiler.tree.optimizer sequences.deep compiler ; -IN: optimizer.tests +IN: compiler.tests.optimizer GENERIC: xyz ( obj -- obj ) M: array xyz xyz ; diff --git a/basis/compiler/tests/peg-regression-2.factor b/basis/compiler/tests/peg-regression-2.factor index 1efadba3aa..7929d9e6f6 100644 --- a/basis/compiler/tests/peg-regression-2.factor +++ b/basis/compiler/tests/peg-regression-2.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.peg-regression-2 USING: peg.ebnf strings tools.test ; GENERIC: ( times -- term' ) @@ -12,4 +12,4 @@ Regexp = Times:t => [[ t ]] ;EBNF -[ "foo" ] [ "a" parse-regexp ] unit-test \ No newline at end of file +[ "foo" ] [ "a" parse-regexp ] unit-test diff --git a/basis/compiler/tests/peg-regression.factor b/basis/compiler/tests/peg-regression.factor index 56a4021eed..e107135305 100644 --- a/basis/compiler/tests/peg-regression.factor +++ b/basis/compiler/tests/peg-regression.factor @@ -5,7 +5,7 @@ ! end of a compilation unit. USING: kernel accessors peg.ebnf ; -IN: compiler.tests +IN: compiler.tests.peg-regression TUPLE: pipeline-expr background ; diff --git a/basis/compiler/tests/redefine0.factor b/basis/compiler/tests/redefine0.factor index 87b63aa029..3d7a05a74b 100644 --- a/basis/compiler/tests/redefine0.factor +++ b/basis/compiler/tests/redefine0.factor @@ -104,4 +104,4 @@ quot global delete-at \ test-11 forget \ quot forget ] with-compilation-unit -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor index a28b183fb6..af0fd52a47 100644 --- a/basis/compiler/tests/redefine1.factor +++ b/basis/compiler/tests/redefine1.factor @@ -1,7 +1,7 @@ USING: accessors compiler compiler.units tools.test math parser kernel sequences sequences.private classes.mixin generic definitions arrays words assocs eval strings ; -IN: compiler.tests +IN: compiler.tests.redefine1 GENERIC: method-redefine-generic-1 ( a -- b ) diff --git a/basis/compiler/tests/redefine10.factor b/basis/compiler/tests/redefine10.factor index faae7b8ed1..66edd75097 100644 --- a/basis/compiler/tests/redefine10.factor +++ b/basis/compiler/tests/redefine10.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine10 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/redefine11.factor b/basis/compiler/tests/redefine11.factor index 57f9f9caf0..dbec57e3d5 100644 --- a/basis/compiler/tests/redefine11.factor +++ b/basis/compiler/tests/redefine11.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel classes.mixin arrays ; -IN: compiler.tests +IN: compiler.tests.redefine11 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/redefine15.factor b/basis/compiler/tests/redefine15.factor index 797460a411..33aa080bac 100644 --- a/basis/compiler/tests/redefine15.factor +++ b/basis/compiler/tests/redefine15.factor @@ -17,4 +17,4 @@ DEFER: word-1 [ \ word-3 [ [ 2 + ] bi@ ] (( a b -- c d )) define-declared ] with-compilation-unit -[ 2 3 ] [ 0 word-4 ] unit-test \ No newline at end of file +[ 2 3 ] [ 0 word-4 ] unit-test diff --git a/basis/compiler/tests/redefine2.factor b/basis/compiler/tests/redefine2.factor index 6a7b7a6941..f74ba46fd4 100644 --- a/basis/compiler/tests/redefine2.factor +++ b/basis/compiler/tests/redefine2.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.redefine2 USING: compiler compiler.units tools.test math parser kernel sequences sequences.private classes.mixin generic definitions arrays words assocs eval words.symbol ; diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index 87ab100879..a5962ff91a 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.redefine3 USING: accessors compiler compiler.units tools.test math parser kernel sequences sequences.private classes.mixin generic definitions arrays words assocs eval ; diff --git a/basis/compiler/tests/redefine4.factor b/basis/compiler/tests/redefine4.factor index 88b40f0c5a..5e0c6c0270 100644 --- a/basis/compiler/tests/redefine4.factor +++ b/basis/compiler/tests/redefine4.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.redefine4 USING: io.streams.string kernel tools.test eval ; : declaration-test-1 ( -- a ) 3 ; flushable diff --git a/basis/compiler/tests/redefine5.factor b/basis/compiler/tests/redefine5.factor index c390f9a1ec..7613987852 100644 --- a/basis/compiler/tests/redefine5.factor +++ b/basis/compiler/tests/redefine5.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine5 ! Regression: if dispatch was eliminated but method was not inlined, ! compiled usage information was not recorded. diff --git a/basis/compiler/tests/redefine6.factor b/basis/compiler/tests/redefine6.factor index 7f1be973e7..fdf3e7edbb 100644 --- a/basis/compiler/tests/redefine6.factor +++ b/basis/compiler/tests/redefine6.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine6 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/redefine7.factor b/basis/compiler/tests/redefine7.factor index d6dfdf20fd..cfe29603f9 100644 --- a/basis/compiler/tests/redefine7.factor +++ b/basis/compiler/tests/redefine7.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine7 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/redefine8.factor b/basis/compiler/tests/redefine8.factor index 3499c5070a..a79bfb5af5 100644 --- a/basis/compiler/tests/redefine8.factor +++ b/basis/compiler/tests/redefine8.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine8 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/redefine9.factor b/basis/compiler/tests/redefine9.factor index 25ed5f15db..2598246472 100644 --- a/basis/compiler/tests/redefine9.factor +++ b/basis/compiler/tests/redefine9.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel generic.math ; -IN: compiler.tests +IN: compiler.tests.redefine9 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/reload.factor b/basis/compiler/tests/reload.factor index b2b65b5868..62c7c31bc2 100644 --- a/basis/compiler/tests/reload.factor +++ b/basis/compiler/tests/reload.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.reload USE: vocabs.loader ! "parser" reload diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index 11b27979d5..82cc97e0f6 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -1,7 +1,7 @@ USING: compiler compiler.units tools.test kernel kernel.private sequences.private math.private math combinators strings alien arrays memory vocabs parser eval ; -IN: compiler.tests +IN: compiler.tests.simple ! Test empty word [ ] [ [ ] compile-call ] unit-test diff --git a/basis/compiler/tests/spilling.factor b/basis/compiler/tests/spilling.factor index 4092352fd5..2ec6fbde95 100644 --- a/basis/compiler/tests/spilling.factor +++ b/basis/compiler/tests/spilling.factor @@ -1,6 +1,6 @@ USING: math.private kernel combinators accessors arrays generalizations tools.test ; -IN: compiler.tests +IN: compiler.tests.spilling : float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b ) { diff --git a/basis/compiler/tests/stack-trace.factor b/basis/compiler/tests/stack-trace.factor index b317ed3eb5..1cb11571ef 100755 --- a/basis/compiler/tests/stack-trace.factor +++ b/basis/compiler/tests/stack-trace.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.stack-trace USING: compiler tools.test namespaces sequences kernel.private kernel math continuations continuations.private words splitting grouping sorting accessors ; diff --git a/basis/compiler/tests/tuples.factor b/basis/compiler/tests/tuples.factor index caa214b70c..fc249d99db 100644 --- a/basis/compiler/tests/tuples.factor +++ b/basis/compiler/tests/tuples.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.tuples USING: kernel tools.test compiler.units compiler ; TUPLE: color red green blue ; From dd15bd0fee3df59f137754361cb8647b198a561a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 26 Apr 2009 01:25:19 -0500 Subject: [PATCH 309/320] fix morse for characters that don't exist like "\n". "resource:core/kernel/kernel.factor" utf8 file-contents play-as-morse listen to factor! --- extra/morse/morse-tests.factor | 1 + extra/morse/morse.factor | 11 +++++++---- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/extra/morse/morse-tests.factor b/extra/morse/morse-tests.factor index fd52df1c4d..13818a06a0 100644 --- a/extra/morse/morse-tests.factor +++ b/extra/morse/morse-tests.factor @@ -41,3 +41,4 @@ IN: morse.tests MORSE] ] unit-test ! [ ] [ "sos" 0.075 play-as-morse* ] unit-test ! [ ] [ "Factor rocks!" play-as-morse ] unit-test +! [ ] [ "\n" play-as-morse ] unit-test diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index ef4b9d4b88..20989f2f2f 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -3,13 +3,15 @@ USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ; IN: morse +ERROR: no-morse-code ch ; + @@ -74,10 +76,10 @@ CONSTANT: morse-code-table $[ ] : ch>morse ( ch -- morse ) - ch>lower morse-code-table at [ unknown-char ] unless* ; + ch>lower morse-code-table at unknown-char or ; : morse>ch ( str -- ch ) - morse-code-table value-at [ char-gap-char ] unless* ; + morse-code-table value-at char-gap-char or ; Date: Sun, 26 Apr 2009 02:23:33 -0500 Subject: [PATCH 310/320] fix some compiler tests --- basis/compiler/tests/redefine1.factor | 4 ++-- basis/compiler/tests/redefine2.factor | 2 +- basis/compiler/tests/redefine3.factor | 2 +- basis/compiler/tests/redefine4.factor | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor index af0fd52a47..6bb623cac4 100644 --- a/basis/compiler/tests/redefine1.factor +++ b/basis/compiler/tests/redefine1.factor @@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ; [ 6 ] [ method-redefine-test-1 ] unit-test -[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine1 USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test [ 7 ] [ method-redefine-test-1 ] unit-test @@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ; [ 6 ] [ method-redefine-test-2 ] unit-test -[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine1 USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test [ 7 ] [ method-redefine-test-2 ] unit-test diff --git a/basis/compiler/tests/redefine2.factor b/basis/compiler/tests/redefine2.factor index f74ba46fd4..9112a1e1af 100644 --- a/basis/compiler/tests/redefine2.factor +++ b/basis/compiler/tests/redefine2.factor @@ -5,7 +5,7 @@ arrays words assocs eval words.symbol ; DEFER: redefine2-test -[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test +[ ] [ "USE: sequences USE: kernel IN: compiler.tests.redefine2 TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test [ t ] [ \ redefine2-test symbol? ] unit-test diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index a5962ff91a..51ce33c1bd 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ; [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test -[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test [ "wake up" ] [ sheeple-test ] unit-test [ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test diff --git a/basis/compiler/tests/redefine4.factor b/basis/compiler/tests/redefine4.factor index 5e0c6c0270..2320f64af6 100644 --- a/basis/compiler/tests/redefine4.factor +++ b/basis/compiler/tests/redefine4.factor @@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ; [ "" ] [ [ declaration-test ] with-string-writer ] unit-test -[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine4 USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test [ "X" ] [ [ declaration-test ] with-string-writer ] unit-test From fc8b04466a70e6729b964976945d4438979bd588 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 26 Apr 2009 03:26:15 -0500 Subject: [PATCH 311/320] fix morse unit test --- extra/morse/morse-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/morse/morse-tests.factor b/extra/morse/morse-tests.factor index 13818a06a0..f1da7ce139 100644 --- a/extra/morse/morse-tests.factor +++ b/extra/morse/morse-tests.factor @@ -3,7 +3,7 @@ USING: arrays morse strings tools.test ; IN: morse.tests -[ CHAR: ? ] [ CHAR: \\ ch>morse ] unit-test +[ "?" ] [ CHAR: \\ ch>morse ] unit-test [ "..." ] [ CHAR: s ch>morse ] unit-test [ CHAR: s ] [ "..." morse>ch ] unit-test [ CHAR: \s ] [ "..--..--.." morse>ch ] unit-test From 6688cf1c9779dce87529392f3bbdcdcabcd81baa Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Apr 2009 08:42:31 -0500 Subject: [PATCH 312/320] mopping up some noobsauce --- extra/roles/roles.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/roles/roles.factor b/extra/roles/roles.factor index f9ce808eb8..d54b4339a7 100644 --- a/extra/roles/roles.factor +++ b/extra/roles/roles.factor @@ -8,8 +8,8 @@ IN: roles ERROR: role-slot-overlap class slots ; ERROR: multiple-inheritance-attempted classes ; -PREDICATE: role < class - { [ mixin-class? ] [ "role-slots" word-prop >boolean ] } 1&& ; +PREDICATE: role < mixin-class + "role-slots" word-prop >boolean ; : parse-role-definition ( -- class superroles slots ) CREATE-CLASS scan { From 5f756a8019c208e268737282d5a3b93b08a2b658 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Apr 2009 09:15:58 -0500 Subject: [PATCH 313/320] Code GC: segregated free list for faster allocation, combine unmark/build free list/update literals passes into one pass for faster deallocation --- vm/code_gc.c | 166 ++++++++++++++++++++++++++++++++------------------- vm/code_gc.h | 14 ++++- vm/data_gc.c | 9 +-- 3 files changed, 119 insertions(+), 70 deletions(-) diff --git a/vm/code_gc.c b/vm/code_gc.c index c3c5bc9a10..e7fcfd3289 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -1,5 +1,10 @@ #include "master.h" +static void clear_free_list(F_HEAP *heap) +{ + memset(&heap->free,0,sizeof(F_HEAP_FREE_LIST)); +} + /* This malloc-style heap code is reasonably generic. Maybe in the future, it will be used for the data heap too, if we ever get incremental mark/sweep/compact GC. */ @@ -8,17 +13,23 @@ void new_heap(F_HEAP *heap, CELL size) heap->segment = alloc_segment(align_page(size)); if(!heap->segment) fatal_error("Out of memory in new_heap",size); - heap->free_list = NULL; + + clear_free_list(heap); } -/* If there is no previous block, next_free becomes the head of the free list, -else its linked in */ -INLINE void update_free_list(F_HEAP *heap, F_FREE_BLOCK *prev, F_FREE_BLOCK *next_free) +void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block) { - if(prev) - prev->next_free = next_free; + if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) + { + int index = block->block.size / BLOCK_SIZE_INCREMENT; + block->next_free = heap->free.small[index]; + heap->free.small[index] = block; + } else - heap->free_list = next_free; + { + block->next_free = heap->free.large; + heap->free.large = block; + } } /* Called after reading the code heap from the image file, and after code GC. @@ -28,7 +39,11 @@ compiling.limit. */ void build_free_list(F_HEAP *heap, CELL size) { F_BLOCK *prev = NULL; - F_FREE_BLOCK *prev_free = NULL; + + clear_free_list(heap); + + size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1); + F_BLOCK *scan = first_block(heap); F_FREE_BLOCK *end = (F_FREE_BLOCK *)(heap->segment->start + size); @@ -38,8 +53,7 @@ void build_free_list(F_HEAP *heap, CELL size) switch(scan->status) { case B_FREE: - update_free_list(heap,prev_free,(F_FREE_BLOCK *)scan); - prev_free = (F_FREE_BLOCK *)scan; + add_to_free_list(heap,(F_FREE_BLOCK *)scan); break; case B_ALLOCATED: break; @@ -58,10 +72,9 @@ void build_free_list(F_HEAP *heap, CELL size) { end->block.status = B_FREE; end->block.size = heap->segment->end - (CELL)end; - end->next_free = NULL; /* add final free block */ - update_free_list(heap,prev_free,end); + add_to_free_list(heap,end); } /* This branch is taken if the newly loaded image fits exactly, or after code GC */ @@ -70,63 +83,88 @@ void build_free_list(F_HEAP *heap, CELL size) /* even if there's no room at the end of the heap for a new free block, we might have to jigger it up by a few bytes in case prev + prev->size */ - if(prev) - prev->size = heap->segment->end - (CELL)prev; - - /* this is the last free block */ - update_free_list(heap,prev_free,NULL); + if(prev) prev->size = heap->segment->end - (CELL)prev; } } +static void assert_free_block(F_FREE_BLOCK *block) +{ + if(block->block.status != B_FREE) + critical_error("Invalid block in free list",(CELL)block); +} + +F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) +{ + CELL attempt = size; + + while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) + { + int index = attempt / BLOCK_SIZE_INCREMENT; + F_FREE_BLOCK *block = heap->free.small[index]; + if(block) + { + assert_free_block(block); + heap->free.small[index] = block->next_free; + return block; + } + + attempt *= 2; + } + + F_FREE_BLOCK *prev = NULL; + F_FREE_BLOCK *block = heap->free.large; + + while(block) + { + assert_free_block(block); + if(block->block.size >= size) + { + if(prev) + prev->next_free = block->next_free; + else + heap->free.large = block->next_free; + return block; + } + + prev = block; + block = block->next_free; + } + + return NULL; +} + +F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL size) +{ + if(block->block.size != size ) + { + /* split the block in two */ + F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)block + size); + split->block.status = B_FREE; + split->block.size = block->block.size - size; + split->next_free = block->next_free; + block->block.size = size; + add_to_free_list(heap,split); + } + + return block; +} + /* Allocate a block of memory from the mark and sweep GC heap */ F_BLOCK *heap_allot(F_HEAP *heap, CELL size) { - F_FREE_BLOCK *prev = NULL; - F_FREE_BLOCK *scan = heap->free_list; + size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1); - size = (size + 31) & ~31; - - while(scan) + F_FREE_BLOCK *block = find_free_block(heap,size); + if(block) { - if(scan->block.status != B_FREE) - critical_error("Invalid block in free list",(CELL)scan); + block = split_free_block(heap,block,size); - if(scan->block.size < size) - { - prev = scan; - scan = scan->next_free; - continue; - } - - /* we found a candidate block */ - F_FREE_BLOCK *next_free; - - if(scan->block.size - size <= sizeof(F_BLOCK) * 2) - { - /* too small to be split */ - next_free = scan->next_free; - } - else - { - /* split the block in two */ - F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)scan + size); - split->block.status = B_FREE; - split->block.size = scan->block.size - size; - split->next_free = scan->next_free; - scan->block.size = size; - next_free = split; - } - - /* update the free list */ - update_free_list(heap,prev,next_free); - - /* this is our new block */ - scan->block.status = B_ALLOCATED; - return &scan->block; + block->block.status = B_ALLOCATED; + return &block->block; } - - return NULL; + else + return NULL; } void mark_block(F_BLOCK *block) @@ -162,8 +200,10 @@ void unmark_marked(F_HEAP *heap) /* After code GC, all referenced code blocks have status set to B_MARKED, so any which are allocated and not marked can be reclaimed. */ -void free_unmarked(F_HEAP *heap) +void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter) { + clear_free_list(heap); + F_BLOCK *prev = NULL; F_BLOCK *scan = first_block(heap); @@ -183,10 +223,15 @@ void free_unmarked(F_HEAP *heap) case B_FREE: if(prev && prev->status == B_FREE) prev->size += scan->size; + else + prev = scan; break; case B_MARKED: + if(prev && prev->status == B_FREE) + add_to_free_list(heap,(F_FREE_BLOCK *)prev); scan->status = B_ALLOCATED; prev = scan; + iter(scan); break; default: critical_error("Invalid scan->status",(CELL)scan); @@ -195,7 +240,8 @@ void free_unmarked(F_HEAP *heap) scan = next_block(heap,scan); } - build_free_list(heap,heap->segment->size); + if(prev && prev->status == B_FREE) + add_to_free_list(heap,(F_FREE_BLOCK *)prev); } /* Compute total sum of sizes of free blocks, and size of largest free block */ diff --git a/vm/code_gc.h b/vm/code_gc.h index cc2c42f120..9b1e768a7b 100644 --- a/vm/code_gc.h +++ b/vm/code_gc.h @@ -1,14 +1,24 @@ +#define FREE_LIST_COUNT 16 +#define BLOCK_SIZE_INCREMENT 32 + +typedef struct { + F_FREE_BLOCK *small[FREE_LIST_COUNT]; + F_FREE_BLOCK *large; +} F_HEAP_FREE_LIST; + typedef struct { F_SEGMENT *segment; - F_FREE_BLOCK *free_list; + F_HEAP_FREE_LIST free; } F_HEAP; +typedef void (*HEAP_ITERATOR)(F_BLOCK *compiled); + void new_heap(F_HEAP *heap, CELL size); void build_free_list(F_HEAP *heap, CELL size); F_BLOCK *heap_allot(F_HEAP *heap, CELL size); void mark_block(F_BLOCK *block); void unmark_marked(F_HEAP *heap); -void free_unmarked(F_HEAP *heap); +void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter); void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free); CELL heap_size(F_HEAP *heap); CELL compute_heap_forwarding(F_HEAP *heap); diff --git a/vm/data_gc.c b/vm/data_gc.c index 50f38bc881..3ab2055d82 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -416,13 +416,6 @@ void end_gc(CELL gc_elapsed) reset_generations(NURSERY,collecting_gen); } - if(collecting_gen == TENURED) - { - /* now that all reachable code blocks have been marked, - deallocate the rest */ - free_unmarked(&code_heap); - } - collecting_aging_again = false; } @@ -491,7 +484,7 @@ void garbage_collection(CELL gen, code_heap_scans++; if(collecting_gen == TENURED) - update_code_heap_roots(); + free_unmarked(&code_heap,(HEAP_ITERATOR)update_literal_references); else copy_code_heap_roots(); From d2e293eb5ea779d2bfbbde84b76009748ab8de6b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Apr 2009 09:39:38 -0500 Subject: [PATCH 314/320] product virtual sequence --- extra/sequences/product/product-tests.factor | 24 ++++++++++------- extra/sequences/product/product.factor | 28 ++++++++++++++++++++ 2 files changed, 42 insertions(+), 10 deletions(-) create mode 100644 extra/sequences/product/product.factor diff --git a/extra/sequences/product/product-tests.factor b/extra/sequences/product/product-tests.factor index dfabc166ac..0a984072e0 100644 --- a/extra/sequences/product/product-tests.factor +++ b/extra/sequences/product/product-tests.factor @@ -1,19 +1,23 @@ -USING: arrays kernel sequences sequences.cartesian-product tools.test ; +USING: arrays kernel make sequences sequences.product tools.test ; IN: sequences.product.tests -[ - { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } -] [ { { 0 1 2 } { "a" "b" } } [ ] cartesian-product-map ] unit-test + +[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ] +[ { { 0 1 2 } { "a" "b" } } >array ] unit-test + +[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ] +[ { { 0 1 2 } { "a" "b" } } [ ] product-map ] unit-test [ { { 0 "a" t } { 1 "a" t } { 2 "a" t } { 0 "b" t } { 1 "b" t } { 2 "b" t } { 0 "a" f } { 1 "a" f } { 2 "a" f } { 0 "b" f } { 1 "b" f } { 2 "b" f } } -] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] cartesian-product-map ] unit-test - -[ - { "012012" "aaabbb" } -] [ { { "0" "1" "2" } { "a" "b" } } [ [ first2 ] bi* [ append ] bi@ 2array ] cartesian-product-each ] unit-test - +] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] product-map ] unit-test +[ "a1b1c1a2b2c2" ] [ + [ + { { "a" "b" "c" } { "1" "2" } } + [ [ % ] each ] product-each + ] "" make +] unit-test diff --git a/extra/sequences/product/product.factor b/extra/sequences/product/product.factor new file mode 100644 index 0000000000..73ba1e4e01 --- /dev/null +++ b/extra/sequences/product/product.factor @@ -0,0 +1,28 @@ +USING: accessors arrays kernel math sequences ; +IN: sequences.product + +TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ; + +: ( sequences -- product-sequence ) + >array dup [ length ] map product-sequence boa ; + +INSTANCE: product-sequence sequence + +M: product-sequence length lengths>> product ; + +: ns ( n lengths -- ns ) + [ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ; + +: product@ ( n product-sequence -- ns seqs ) + [ lengths>> ns ] [ nip sequences>> ] 2bi ; + +M: product-sequence nth + product@ [ nth ] { } 2map-as ; + +M: product-sequence set-nth + immutable ; + +: product-map ( sequences quot -- sequence ) + [ ] dip map ; inline +: product-each ( sequences quot -- ) + [ ] dip each ; inline From e0f6825757892b7226853af7d54d38c33795bb71 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Apr 2009 10:02:52 -0500 Subject: [PATCH 315/320] Rename some fields to avoid conflicting with windows.h macros 'small' and 'large' --- vm/code_gc.c | 16 ++++++++-------- vm/code_gc.h | 4 ++-- 2 files changed, 10 insertions(+), 10 deletions(-) mode change 100644 => 100755 vm/code_gc.h diff --git a/vm/code_gc.c b/vm/code_gc.c index e7fcfd3289..1405daa93f 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -22,13 +22,13 @@ void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block) if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) { int index = block->block.size / BLOCK_SIZE_INCREMENT; - block->next_free = heap->free.small[index]; - heap->free.small[index] = block; + block->next_free = heap->free.small_blocks[index]; + heap->free.small_blocks[index] = block; } else { - block->next_free = heap->free.large; - heap->free.large = block; + block->next_free = heap->free.large_blocks; + heap->free.large_blocks = block; } } @@ -101,11 +101,11 @@ F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) { int index = attempt / BLOCK_SIZE_INCREMENT; - F_FREE_BLOCK *block = heap->free.small[index]; + F_FREE_BLOCK *block = heap->free.small_blocks[index]; if(block) { assert_free_block(block); - heap->free.small[index] = block->next_free; + heap->free.small_blocks[index] = block->next_free; return block; } @@ -113,7 +113,7 @@ F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) } F_FREE_BLOCK *prev = NULL; - F_FREE_BLOCK *block = heap->free.large; + F_FREE_BLOCK *block = heap->free.large_blocks; while(block) { @@ -123,7 +123,7 @@ F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) if(prev) prev->next_free = block->next_free; else - heap->free.large = block->next_free; + heap->free.large_blocks = block->next_free; return block; } diff --git a/vm/code_gc.h b/vm/code_gc.h old mode 100644 new mode 100755 index 9b1e768a7b..d71dee29c5 --- a/vm/code_gc.h +++ b/vm/code_gc.h @@ -2,8 +2,8 @@ #define BLOCK_SIZE_INCREMENT 32 typedef struct { - F_FREE_BLOCK *small[FREE_LIST_COUNT]; - F_FREE_BLOCK *large; + F_FREE_BLOCK *small_blocks[FREE_LIST_COUNT]; + F_FREE_BLOCK *large_blocks; } F_HEAP_FREE_LIST; typedef struct { From 303ce55dc6d9ed566d05f36a995ba21200a56626 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Apr 2009 12:27:50 -0500 Subject: [PATCH 316/320] more efficient product-each and product-map that don't /mod all over the place --- extra/sequences/product/product-tests.factor | 6 ++- extra/sequences/product/product.factor | 50 ++++++++++++++++---- 2 files changed, 46 insertions(+), 10 deletions(-) diff --git a/extra/sequences/product/product-tests.factor b/extra/sequences/product/product-tests.factor index 0a984072e0..087d7a6175 100644 --- a/extra/sequences/product/product-tests.factor +++ b/extra/sequences/product/product-tests.factor @@ -5,8 +5,10 @@ IN: sequences.product.tests [ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ] [ { { 0 1 2 } { "a" "b" } } >array ] unit-test -[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ] -[ { { 0 1 2 } { "a" "b" } } [ ] product-map ] unit-test +: x ( n s -- sss ) concat ; + +[ { "a" "aa" "aaa" "b" "bb" "bbb" } ] +[ { { 1 2 3 } { "a" "b" } } [ first2 x ] product-map ] unit-test [ { diff --git a/extra/sequences/product/product.factor b/extra/sequences/product/product.factor index 73ba1e4e01..0c5bb88f32 100644 --- a/extra/sequences/product/product.factor +++ b/extra/sequences/product/product.factor @@ -1,4 +1,4 @@ -USING: accessors arrays kernel math sequences ; +USING: accessors arrays kernel locals math sequences ; IN: sequences.product TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ; @@ -10,19 +10,53 @@ INSTANCE: product-sequence sequence M: product-sequence length lengths>> product ; +> ns ] [ nip sequences>> ] 2bi ; +:: (carry-n) ( ns lengths i -- ) + ns length i 1+ = [ + i ns nth i lengths nth = [ + 0 i ns set-nth + i 1+ ns [ 1+ ] change-nth + ns lengths i 1+ (carry-n) + ] when + ] unless ; + +: carry-ns ( ns lengths -- ) + 0 (carry-n) ; + +: product-iter ( ns lengths -- ) + [ 0 over [ 1+ ] change-nth ] dip carry-ns ; + +: start-product-iter ( sequence-product -- ns lengths ) + [ [ drop 0 ] map ] [ [ length ] map ] bi ; + +: end-product-iter? ( ns lengths -- ? ) + [ 1 tail* first ] bi@ = ; + +PRIVATE> + M: product-sequence nth - product@ [ nth ] { } 2map-as ; + product@ nths ; -M: product-sequence set-nth - immutable ; +:: product-each ( sequences quot -- ) + sequences start-product-iter :> lengths :> ns + [ ns lengths end-product-iter? ] + [ ns sequences nths quot call ns lengths product-iter ] until ; inline + +:: product-map ( sequences quot -- sequence ) + 0 :> i! + sequences [ length ] [ * ] map-reduce sequences + [| result | + sequences [ quot call i result set-nth i 1+ i! ] product-each + result + ] new-like ; inline -: product-map ( sequences quot -- sequence ) - [ ] dip map ; inline -: product-each ( sequences quot -- ) - [ ] dip each ; inline From f007c281e3b2c0645a095b1f9febb31668eea9e9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Apr 2009 13:08:15 -0500 Subject: [PATCH 317/320] docs for sequences.product --- extra/sequences/product/product-docs.factor | 60 +++++++++++++++++++++ 1 file changed, 60 insertions(+) create mode 100644 extra/sequences/product/product-docs.factor diff --git a/extra/sequences/product/product-docs.factor b/extra/sequences/product/product-docs.factor new file mode 100644 index 0000000000..6033767f47 --- /dev/null +++ b/extra/sequences/product/product-docs.factor @@ -0,0 +1,60 @@ +USING: help.markup help.syntax multiline quotations sequences sequences.product ; +IN: sequences + +HELP: product-sequence +{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link } " word." } +{ $examples +{ $example <" USING: arrays prettyprint sequences.product ; +{ { 1 2 3 } { "a" "b" "c" } } >array . +"> <" { + { 1 "a" } + { 2 "a" } + { 3 "a" } + { 1 "b" } + { 2 "b" } + { 3 "b" } + { 1 "c" } + { 2 "c" } + { 3 "c" } +}"> } } ; + +HELP: +{ $values { "sequences" sequence } { "product-sequence" product-sequence } } +{ $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." } +{ $examples +{ $example <" USING: arrays prettyprint sequences.product ; +{ { 1 2 3 } { "a" "b" "c" } } >array . +"> <" { + { 1 "a" } + { 2 "a" } + { 3 "a" } + { 1 "b" } + { 2 "b" } + { 3 "b" } + { 1 "c" } + { 2 "c" } + { 3 "c" } +}"> } } ; + +{ product-sequence } related-words + +HELP: product-map +{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- value )" } } { "sequence" sequence } } +{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence." } +{ $notes { $snippet "[ ... ] product-map" } " is equivalent to, but more efficient than, " { $snippet " [ ... ] map" } "." } ; + +HELP: product-each +{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- )" } } } +{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } "." } +{ $notes { $snippet "[ ... ] product-each" } " is equivalent to, but more efficient than, " { $snippet " [ ... ] each" } "." } ; + +{ product-map product-each } related-words + +ARTICLE: "sequences.product" "Product sequences" +"The " { $vocab-link "sequences.product" } " vocabulary provides a virtual sequence and combinators for manipulating the cartesian product of a set of sequences." +{ $subsection product-sequence } +{ $subsection } +{ $subsection product-map } +{ $subsection product-each } ; + +ABOUT: "sequences.product" From a2056d932c3c02fd6ecc5673a3f75ee067648990 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Apr 2009 13:09:30 -0500 Subject: [PATCH 318/320] gold plating for sequences.product --- extra/sequences/product/authors.txt | 1 + extra/sequences/product/product-docs.factor | 1 + extra/sequences/product/product-tests.factor | 1 + extra/sequences/product/product.factor | 1 + extra/sequences/product/summary.txt | 1 + 5 files changed, 5 insertions(+) create mode 100644 extra/sequences/product/authors.txt create mode 100644 extra/sequences/product/summary.txt diff --git a/extra/sequences/product/authors.txt b/extra/sequences/product/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/sequences/product/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/sequences/product/product-docs.factor b/extra/sequences/product/product-docs.factor index 6033767f47..b7dcaa626e 100644 --- a/extra/sequences/product/product-docs.factor +++ b/extra/sequences/product/product-docs.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff bsd license USING: help.markup help.syntax multiline quotations sequences sequences.product ; IN: sequences diff --git a/extra/sequences/product/product-tests.factor b/extra/sequences/product/product-tests.factor index 087d7a6175..5e0997dc2e 100644 --- a/extra/sequences/product/product-tests.factor +++ b/extra/sequences/product/product-tests.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff bsd license USING: arrays kernel make sequences sequences.product tools.test ; IN: sequences.product.tests diff --git a/extra/sequences/product/product.factor b/extra/sequences/product/product.factor index 0c5bb88f32..665d43f0cd 100644 --- a/extra/sequences/product/product.factor +++ b/extra/sequences/product/product.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff bsd license USING: accessors arrays kernel locals math sequences ; IN: sequences.product diff --git a/extra/sequences/product/summary.txt b/extra/sequences/product/summary.txt new file mode 100644 index 0000000000..c234c84a94 --- /dev/null +++ b/extra/sequences/product/summary.txt @@ -0,0 +1 @@ +Cartesian products of sequences From 291ac48a1766e942a20099d023ba3e84deee5609 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Apr 2009 13:31:10 -0500 Subject: [PATCH 319/320] tuple-arrays: completely rewritten to use functors, 10x faster on benchmark --- basis/inverse/inverse.factor | 2 +- basis/tuple-arrays/authors.txt | 2 +- basis/tuple-arrays/summary.txt | 1 - basis/tuple-arrays/tags.txt | 1 - basis/tuple-arrays/tuple-arrays-docs.factor | 13 ---- basis/tuple-arrays/tuple-arrays-tests.factor | 16 ++-- basis/tuple-arrays/tuple-arrays.factor | 76 ++++++++++++++----- extra/benchmark/tuple-arrays/authors.txt | 1 + .../tuple-arrays/tuple-arrays.factor | 20 +++++ 9 files changed, 88 insertions(+), 44 deletions(-) delete mode 100644 basis/tuple-arrays/summary.txt delete mode 100644 basis/tuple-arrays/tags.txt delete mode 100644 basis/tuple-arrays/tuple-arrays-docs.factor create mode 100644 extra/benchmark/tuple-arrays/authors.txt create mode 100644 extra/benchmark/tuple-arrays/tuple-arrays.factor diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index a988063293..0b86b02e92 100755 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -12,7 +12,7 @@ IN: inverse ERROR: fail ; M: fail summary drop "Matching failed" ; -: assure ( ? -- ) [ fail ] unless ; +: assure ( ? -- ) [ fail ] unless ; inline : =/fail ( obj1 obj2 -- ) = assure ; diff --git a/basis/tuple-arrays/authors.txt b/basis/tuple-arrays/authors.txt index f990dd0ed2..d4f5d6b3ae 100644 --- a/basis/tuple-arrays/authors.txt +++ b/basis/tuple-arrays/authors.txt @@ -1 +1 @@ -Daniel Ehrenberg +Slava Pestov \ No newline at end of file diff --git a/basis/tuple-arrays/summary.txt b/basis/tuple-arrays/summary.txt deleted file mode 100644 index ac05ae9bcc..0000000000 --- a/basis/tuple-arrays/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Packed homogeneous tuple arrays diff --git a/basis/tuple-arrays/tags.txt b/basis/tuple-arrays/tags.txt deleted file mode 100644 index 42d711b32b..0000000000 --- a/basis/tuple-arrays/tags.txt +++ /dev/null @@ -1 +0,0 @@ -collections diff --git a/basis/tuple-arrays/tuple-arrays-docs.factor b/basis/tuple-arrays/tuple-arrays-docs.factor deleted file mode 100644 index 18f5547e7f..0000000000 --- a/basis/tuple-arrays/tuple-arrays-docs.factor +++ /dev/null @@ -1,13 +0,0 @@ -USING: help.syntax help.markup splitting kernel sequences ; -IN: tuple-arrays - -HELP: tuple-array -{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. To convert a sequence to a tuple array, use the word " { $link >tuple-array } "." } ; - -HELP: -{ $values { "class" "a tuple class" } { "length" "a non-negative integer" } { "tuple-array" tuple-array } } -{ $description "Creates an instance of the " { $link } " class with the given length and containing the given tuple class." } ; - -HELP: >tuple-array -{ $values { "seq" sequence } { "tuple-array" tuple-array } } -{ $description "Converts a sequence into a homogeneous unboxed tuple array of the type indicated by the first element." } ; diff --git a/basis/tuple-arrays/tuple-arrays-tests.factor b/basis/tuple-arrays/tuple-arrays-tests.factor index 7aa49b880f..4606ecdada 100644 --- a/basis/tuple-arrays/tuple-arrays-tests.factor +++ b/basis/tuple-arrays/tuple-arrays-tests.factor @@ -5,17 +5,21 @@ IN: tuple-arrays.tests SYMBOL: mat TUPLE: foo bar ; C: foo -[ 2 ] [ 2 foo dup mat set length ] unit-test +TUPLE-ARRAY: foo + +[ 2 ] [ 2 dup mat set length ] unit-test [ T{ foo } ] [ mat get first ] unit-test [ T{ foo f 2 } ] [ T{ foo f 2 } 0 mat get [ set-nth ] keep first ] unit-test -[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test +[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >foo-array dup mat set foo-array? ] unit-test [ T{ foo f 3 } t ] -[ mat get [ bar>> 2 + ] map [ first ] keep tuple-array? ] unit-test +[ mat get [ bar>> 2 + ] map [ first ] keep foo-array? ] unit-test -[ 2 ] [ 2 foo dup mat set length ] unit-test +[ 2 ] [ 2 dup mat set length ] unit-test [ T{ foo } ] [ mat get first ] unit-test [ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test TUPLE: baz { bing integer } bong ; -[ 0 ] [ 1 baz first bing>> ] unit-test -[ f ] [ 1 baz first bong>> ] unit-test +TUPLE-ARRAY: baz + +[ 0 ] [ 1 first bing>> ] unit-test +[ f ] [ 1 first bong>> ] unit-test diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor index af62c0b0d7..466262f3e0 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -1,34 +1,68 @@ -! Copyright (C) 2007 Daniel Ehrenberg. +! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: splitting grouping classes.tuple classes math kernel -sequences arrays accessors ; +USING: accessors arrays combinators.smart fry functors grouping +kernel macros sequences sequences.private stack-checker +parser ; +FROM: inverse => undo ; IN: tuple-arrays -TUPLE: tuple-array { seq read-only } { class read-only } ; + ( length class -- tuple-array ) - [ - new tuple>array 1 tail - [ concat ] [ length ] bi - ] [ ] bi tuple-array boa ; +MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ; -M: tuple-array nth - [ seq>> nth ] [ class>> ] bi prefix >tuple ; +: smart-tuple>array ( tuple class -- array ) + '[ [ _ boa ] undo ] output>array ; inline -M: tuple-array set-nth ( elt n seq -- ) - [ tuple>array 1 tail ] 2dip seq>> set-nth ; +: smart-array>tuple ( array class -- tuple ) + '[ _ boa ] input> ; +: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline -: >tuple-array ( seq -- tuple-array ) +: tuple-prototype ( class -- array ) + [ new ] [ smart-tuple>array ] bi ; inline + +PRIVATE> + +FUNCTOR: define-tuple-array ( CLASS -- ) + +CLASS IS ${CLASS} + +CLASS-array DEFINES-CLASS ${CLASS}-array +CLASS-array? IS ${CLASS-array}? + + DEFINES <${CLASS}-array> +>CLASS-array DEFINES >${CLASS}-array + +WHERE + +TUPLE: CLASS-array { seq sliced-groups read-only } ; + +: ( length -- tuple-array ) + CLASS tuple-prototype concat + CLASS tuple-arity + CLASS-array boa ; + +M: CLASS-array nth-unsafe + seq>> nth-unsafe CLASS smart-array>tuple ; + +M: CLASS-array set-nth-unsafe + [ CLASS smart-tuple>array ] 2dip seq>> set-nth-unsafe ; + +M: CLASS-array new-sequence + drop ; + +: >CLASS-array ( seq -- tuple-array ) dup empty? [ - 0 over first class clone-like + 0 clone-like ] unless ; -M: tuple-array like - drop dup tuple-array? [ >tuple-array ] unless ; +M: CLASS-array like + drop dup CLASS-array? [ >CLASS-array ] unless ; -M: tuple-array length seq>> length ; +M: CLASS-array length seq>> length ; -INSTANCE: tuple-array sequence +INSTANCE: CLASS-array sequence + +;FUNCTOR + +SYNTAX: TUPLE-ARRAY: scan-word define-tuple-array ; diff --git a/extra/benchmark/tuple-arrays/authors.txt b/extra/benchmark/tuple-arrays/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/benchmark/tuple-arrays/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/benchmark/tuple-arrays/tuple-arrays.factor b/extra/benchmark/tuple-arrays/tuple-arrays.factor new file mode 100644 index 0000000000..483311d4f4 --- /dev/null +++ b/extra/benchmark/tuple-arrays/tuple-arrays.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions tuple-arrays accessors fry sequences +prettyprint ; +IN: benchmark.tuple-arrays + +TUPLE: point { x float } { y float } { z float } ; + +TUPLE-ARRAY: point + +: tuple-array-benchmark ( -- ) + 100 [ + drop 5000 [ + [ 1+ ] change-x + [ 1- ] change-y + [ 1+ 2 / ] change-z + ] map [ z>> ] sigma + ] sigma . ; + +MAIN: tuple-array-benchmark \ No newline at end of file From 06012cf2917e632f3b14c1a80c221b59e1f383b4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Apr 2009 14:58:31 -0500 Subject: [PATCH 320/320] order-insensitive pair methods --- extra/pair-methods/authors.txt | 1 + extra/pair-methods/pair-methods-tests.factor | 43 +++++++++++++++ extra/pair-methods/pair-methods.factor | 57 ++++++++++++++++++++ extra/pair-methods/summary.txt | 1 + 4 files changed, 102 insertions(+) create mode 100644 extra/pair-methods/authors.txt create mode 100644 extra/pair-methods/pair-methods-tests.factor create mode 100644 extra/pair-methods/pair-methods.factor create mode 100644 extra/pair-methods/summary.txt diff --git a/extra/pair-methods/authors.txt b/extra/pair-methods/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/pair-methods/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/pair-methods/pair-methods-tests.factor b/extra/pair-methods/pair-methods-tests.factor new file mode 100644 index 0000000000..f88ca966aa --- /dev/null +++ b/extra/pair-methods/pair-methods-tests.factor @@ -0,0 +1,43 @@ +! (c)2009 Joe Groff bsd license +USING: accessors pair-methods classes kernel sequences tools.test ; +IN: pair-methods.tests + +TUPLE: thang ; + +TUPLE: foom < thang ; +TUPLE: barm < foom ; + +TUPLE: zim < thang ; +TUPLE: zang < zim ; + +: class-names ( a b prefix -- string ) + [ [ class name>> ] bi@ "-" glue ] dip prepend ; + +PAIR-GENERIC: blibble ( a b -- c ) + +PAIR-M: thang thang blibble + "vanilla " class-names ; + +PAIR-M: foom thang blibble + "chocolate " class-names ; + +PAIR-M: barm thang blibble + "strawberry " class-names ; + +PAIR-M: barm zim blibble + "coconut " class-names ; + +[ "vanilla zang-zim" ] [ zim new zang new blibble ] unit-test + +! args automatically swap to match most specific method +[ "chocolate foom-zim" ] [ foom new zim new blibble ] unit-test +[ "chocolate foom-zim" ] [ zim new foom new blibble ] unit-test + +[ "strawberry barm-barm" ] [ barm new barm new blibble ] unit-test +[ "strawberry barm-foom" ] [ barm new foom new blibble ] unit-test +[ "strawberry barm-foom" ] [ foom new barm new blibble ] unit-test + +[ "coconut barm-zang" ] [ zang new barm new blibble ] unit-test +[ "coconut barm-zim" ] [ barm new zim new blibble ] unit-test + +[ 1 2 blibble ] [ no-pair-method? ] must-fail-with diff --git a/extra/pair-methods/pair-methods.factor b/extra/pair-methods/pair-methods.factor new file mode 100644 index 0000000000..d44d5bce78 --- /dev/null +++ b/extra/pair-methods/pair-methods.factor @@ -0,0 +1,57 @@ +! (c)2009 Joe Groff bsd license +USING: arrays assocs classes classes.tuple.private combinators +effects.parser generic.parser kernel math math.order parser +quotations sequences sorting words ; +IN: pair-methods + +ERROR: no-pair-method a b generic ; + +: ?swap ( a b ? -- a/b b/a ) + [ swap ] when ; + +: method-sort-key ( pair -- key ) + first2 [ tuple-layout third ] bi@ + ; + +: pair-match-condition ( pair -- quot ) + first2 [ [ instance? ] swap prefix ] bi@ [ ] 2sequence + [ 2dup ] [ bi* and ] surround ; + +: pair-method-cond ( pair quot -- array ) + [ pair-match-condition ] [ ] bi* 2array ; + +: sorted-pair-methods ( word -- alist ) + "pair-generic-methods" word-prop >alist + [ [ first method-sort-key ] bi@ >=< ] sort ; + +: pair-generic-definition ( word -- def ) + [ sorted-pair-methods [ first2 pair-method-cond ] map ] + [ [ no-pair-method ] curry suffix ] bi 1quotation + [ 2dup [ class ] bi@ <=> +gt+ eq? ?swap ] [ cond ] surround ; + +: make-pair-generic ( word -- ) + dup pair-generic-definition define ; + +: define-pair-generic ( word effect -- ) + [ swap set-stack-effect ] + [ drop H{ } clone "pair-generic-methods" set-word-prop ] + [ drop make-pair-generic ] 2tri ; + +: (PAIR-GENERIC:) ( -- ) + CREATE-GENERIC complete-effect define-pair-generic ; + +SYNTAX: PAIR-GENERIC: (PAIR-GENERIC:) ; + +: define-pair-method ( a b pair-generic definition -- ) + [ 2array ] 2dip swap + [ "pair-generic-methods" word-prop [ swap ] dip set-at ] + [ make-pair-generic ] bi ; + +: ?prefix-swap ( quot ? -- quot' ) + [ \ swap prefix ] when ; + +: (PAIR-M:) ( -- ) + scan-word scan-word 2dup <=> +gt+ eq? [ + ?swap scan-word parse-definition + ] keep ?prefix-swap define-pair-method ; + +SYNTAX: PAIR-M: (PAIR-M:) ; diff --git a/extra/pair-methods/summary.txt b/extra/pair-methods/summary.txt new file mode 100644 index 0000000000..823bc712f6 --- /dev/null +++ b/extra/pair-methods/summary.txt @@ -0,0 +1 @@ +Order-insensitive double dispatch generics