From b65feec3bdcc661b7110892deb6fc92f2f20cc77 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 17 Sep 2008 19:35:30 +1000 Subject: [PATCH 001/177] 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/177] 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/177] 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/177] 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/177] 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/177] 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/177] 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/177] 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/177] 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/177] 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/177] 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 07f585a81d266d7fc470417441c6f38fbed3d676 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Apr 2009 15:24:21 -0500 Subject: [PATCH 012/177] 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 013/177] 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 2b384a7742b55ccaf59bde905798fb7cba15c5b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 8 Apr 2009 23:05:45 -0500 Subject: [PATCH 014/177] 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 015/177] 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 016/177] 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 017/177] 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 018/177] 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 019/177] 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 020/177] 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 021/177] 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 022/177] 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 023/177] 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 024/177] 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 025/177] 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 117/177] 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 118/177] 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 119/177] 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 120/177] 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 121/177] 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 122/177] 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 123/177] 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 124/177] 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 125/177] 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 126/177] 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 127/177] 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 128/177] 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 129/177] 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 130/177] 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 131/177] 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 132/177] 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 133/177] 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 134/177] 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 135/177] 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 136/177] 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 137/177] 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 138/177] 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 139/177] 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 140/177] 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 141/177] 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 142/177] 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 143/177] 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 144/177] 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 145/177] 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 146/177] 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 147/177] 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 148/177] 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 149/177] 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 150/177] 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 151/177] 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 152/177] 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 153/177] 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 154/177] 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 155/177] 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 156/177] 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 157/177] 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 158/177] 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 159/177] 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 160/177] 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 161/177] 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 162/177] 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 163/177] 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 164/177] 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 165/177] 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 166/177] 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 425be6a414306d6f6b1bb95ce3ae2cd40995c2ac Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sun, 19 Apr 2009 20:35:54 +0200 Subject: [PATCH 167/177] 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 168/177] 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 169/177] 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 170/177] 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 171/177] 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 172/177] 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 173/177] 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 174/177] 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 175/177] 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 176/177] 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 177/177] 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