From c4d6201b7756f3d6a9fd191211cb41c7adb6c750 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 6 Mar 2008 15:07:00 -0600 Subject: [PATCH 01/83] Unit tests and refactoring for ascii and latin1 --- extra/io/encodings/ascii/ascii-tests.factor | 9 +++++++++ extra/io/encodings/ascii/ascii.factor | 9 ++++++--- extra/io/encodings/latin1/latin1-tests.factor | 9 +++++++++ extra/io/encodings/latin1/latin1.factor | 5 +---- 4 files changed, 25 insertions(+), 7 deletions(-) create mode 100644 extra/io/encodings/ascii/ascii-tests.factor create mode 100644 extra/io/encodings/latin1/latin1-tests.factor diff --git a/extra/io/encodings/ascii/ascii-tests.factor b/extra/io/encodings/ascii/ascii-tests.factor new file mode 100644 index 0000000000..4f6d28835a --- /dev/null +++ b/extra/io/encodings/ascii/ascii-tests.factor @@ -0,0 +1,9 @@ +USING: io.encodings.string io.encodings.ascii tools.test strings arrays ; +IN: io.encodings.ascii.tests + +[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" ascii encode ] unit-test +[ { 128 } >string ascii encode ] must-fail +[ B{ 127 } ] [ { 127 } ascii encode ] unit-test + +[ "bar" ] [ "bar" ascii decode ] unit-test +[ { CHAR: b HEX: fffd CHAR: r } ] [ { CHAR: b 233 CHAR: r } ascii decode >array ] unit-test diff --git a/extra/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor index fdefc35634..bd71b733f1 100644 --- a/extra/io/encodings/ascii/ascii.factor +++ b/extra/io/encodings/ascii/ascii.factor @@ -3,13 +3,16 @@ USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ; IN: io.encodings.ascii -: encode-check<= ( string stream max -- ) +: encode-check< ( string stream max -- ) [ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ; +: push-if< ( sbuf character max -- ) + over <= [ drop HEX: fffd ] when swap push ; + TUPLE: ascii ; M: ascii stream-write-encoded ( string stream encoding -- ) - drop 127 encode-check<= ; + drop 128 encode-check< ; M: ascii decode-step - drop dup 128 >= [ decode-error ] [ swap push ] if ; + drop 128 push-if< ; diff --git a/extra/io/encodings/latin1/latin1-tests.factor b/extra/io/encodings/latin1/latin1-tests.factor new file mode 100644 index 0000000000..a89bfe0e6f --- /dev/null +++ b/extra/io/encodings/latin1/latin1-tests.factor @@ -0,0 +1,9 @@ +USING: io.encodings.string io.encodings.latin1 tools.test strings arrays ; +IN: io.encodings.latin1.tests + +[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test +[ { 256 } >string latin1 encode ] must-fail +[ B{ 255 } ] [ { 255 } latin1 encode ] unit-test + +[ "bar" ] [ "bar" latin1 decode ] unit-test +[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test diff --git a/extra/io/encodings/latin1/latin1.factor b/extra/io/encodings/latin1/latin1.factor index 989f45bc64..ec01da5983 100755 --- a/extra/io/encodings/latin1/latin1.factor +++ b/extra/io/encodings/latin1/latin1.factor @@ -6,7 +6,4 @@ IN: io.encodings.latin1 TUPLE: latin1 ; M: latin1 stream-write-encoded - drop 255 encode-check<= ; - -M: latin1 decode-step - drop dup 256 >= [ decode-error ] [ swap push ] if ; + drop 256 encode-check< ; From 839933664880165f6f9f5354ada42e72616992ac Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 12 Mar 2008 19:55:06 -0500 Subject: [PATCH 02/83] tools.vocabs absorbs some words from tools.browser and vocabs.loader --- core/vocabs/loader/loader-docs.factor | 14 +- core/vocabs/loader/loader.factor | 61 --- extra/benchmark/benchmark.factor | 2 +- extra/bootstrap/tools/tools.factor | 1 + extra/editors/editors.factor | 2 +- extra/help/handbook/handbook.factor | 1 + extra/help/lint/lint.factor | 2 +- extra/help/topics/topics.factor | 4 + extra/io/unix/unix.factor | 2 +- extra/io/windows/nt/nt.factor | 2 +- extra/tools/browser/browser-tests.factor | 4 - extra/tools/browser/browser.factor | 364 ------------------ extra/tools/{ => vocabs}/browser/authors.txt | 0 .../tools/vocabs/browser/browser-docs.factor | 7 + .../tools/vocabs/browser/browser-tests.factor | 4 + extra/tools/vocabs/browser/browser.factor | 207 ++++++++++ extra/tools/{ => vocabs}/browser/tags.txt | 0 extra/{ => tools}/vocabs/monitor/authors.txt | 0 .../{ => tools}/vocabs/monitor/monitor.factor | 6 +- extra/{ => tools}/vocabs/monitor/summary.txt | 0 .../vocabs-docs.factor} | 115 +++--- extra/tools/vocabs/vocabs.factor | 232 +++++++++++ extra/ui/tools/operations/operations.factor | 8 +- extra/ui/tools/search/search.factor | 2 +- 24 files changed, 531 insertions(+), 509 deletions(-) mode change 100644 => 100755 extra/help/lint/lint.factor mode change 100644 => 100755 extra/help/topics/topics.factor delete mode 100755 extra/tools/browser/browser-tests.factor delete mode 100755 extra/tools/browser/browser.factor rename extra/tools/{ => vocabs}/browser/authors.txt (100%) create mode 100755 extra/tools/vocabs/browser/browser-docs.factor create mode 100755 extra/tools/vocabs/browser/browser-tests.factor create mode 100755 extra/tools/vocabs/browser/browser.factor rename extra/tools/{ => vocabs}/browser/tags.txt (100%) rename extra/{ => tools}/vocabs/monitor/authors.txt (100%) rename extra/{ => tools}/vocabs/monitor/monitor.factor (79%) rename extra/{ => tools}/vocabs/monitor/summary.txt (100%) rename extra/tools/{browser/browser-docs.factor => vocabs/vocabs-docs.factor} (73%) create mode 100755 extra/tools/vocabs/vocabs.factor diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index 9f7b2b5b9f..886e678330 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -23,9 +23,6 @@ $nl "Application vocabularies can define a main entry point, giving the user a convenient way to run the application:" { $subsection POSTPONE: MAIN: } { $subsection run } -"Reloading source files changed on disk:" -{ $subsection refresh } -{ $subsection refresh-all } { $see-also "vocabularies" "parser-files" "source-files" } ; ABOUT: "vocabs.loader" @@ -80,7 +77,7 @@ HELP: reload HELP: require { $values { "vocab" "a vocabulary specifier" } } { $description "Loads a vocabulary if it has not already been loaded." } -{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files, use " { $link refresh } " or " { $link refresh-all } "." } ; +{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "tools.vocabs" } "." } ; HELP: run { $values { "vocab" "a vocabulary specifier" } } @@ -93,12 +90,3 @@ HELP: vocab-source-path HELP: vocab-docs-path { $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string or " { $link f } } } { $description "Outputs a pathname where the documentation for " { $snippet "vocab" } " might be found. Outputs " { $link f } " if the vocabulary does not have a directory on disk." } ; - -HELP: refresh -{ $values { "prefix" string } } -{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; - -HELP: refresh-all -{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ; - -{ refresh refresh-all } related-words diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 885bccddd1..430aa066a8 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -119,68 +119,7 @@ SYMBOL: load-help? "To define one, refer to \\ MAIN: help" print ] ?if ; -: modified ( seq quot -- seq ) - [ dup ] swap compose { } map>assoc - [ nip ] assoc-subset - [ nip source-modified? ] assoc-subset keys ; inline - -: modified-sources ( vocabs -- seq ) - [ vocab-source-path ] modified ; - -: modified-docs ( vocabs -- seq ) - [ vocab-docs-path ] modified ; - -: update-roots ( vocabs -- ) - [ dup find-vocab-root swap vocab set-vocab-root ] each ; - -: to-refresh ( prefix -- modified-sources modified-docs ) - child-vocabs - dup update-roots - dup modified-sources swap modified-docs ; - -: vocab-heading. ( vocab -- ) - nl - "==== " write - dup vocab-name swap vocab write-object ":" print - nl ; - -: load-error. ( triple -- ) - dup first vocab-heading. - dup second print-error - drop ; - -: load-failures. ( failures -- ) - [ load-error. nl ] each ; - SYMBOL: blacklist -SYMBOL: failures - -: require-all ( vocabs -- failures ) - [ - V{ } clone blacklist set - V{ } clone failures set - [ - [ require ] - [ swap vocab-name failures get set-at ] - recover - ] each - failures get - ] with-compiler-errors ; - -: do-refresh ( modified-sources modified-docs -- ) - 2dup - [ f swap set-vocab-docs-loaded? ] each - [ f swap set-vocab-source-loaded? ] each - append prune require-all load-failures. ; - -: refresh ( prefix -- ) to-refresh do-refresh ; - -SYMBOL: sources-changed? - -[ t sources-changed? set-global ] "vocabs.loader" add-init-hook - -: refresh-all ( -- ) - "" refresh f sources-changed? set-global ; GENERIC: (load-vocab) ( name -- vocab ) diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index 231c6edf50..7eb5f10276 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel vocabs vocabs.loader tools.time tools.browser +USING: kernel vocabs vocabs.loader tools.time tools.vocabs arrays assocs io.styles io help.markup prettyprint sequences continuations debugger ; IN: benchmark diff --git a/extra/bootstrap/tools/tools.factor b/extra/bootstrap/tools/tools.factor index 718f73308c..f395a903c3 100755 --- a/extra/bootstrap/tools/tools.factor +++ b/extra/bootstrap/tools/tools.factor @@ -11,5 +11,6 @@ USING: vocabs.loader sequences ; "tools.test" "tools.time" "tools.threads" + "tools.vocabs" "editors" } [ require ] each diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index 3b65466225..bb3fd05400 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser kernel namespaces sequences definitions io.files -inspector continuations tuples tools.crossref tools.browser +inspector continuations tuples tools.crossref tools.vocabs io prettyprint source-files assocs vocabs vocabs.loader ; IN: editors diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index d77cc9268d..1310b58133 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -196,6 +196,7 @@ ARTICLE: "io" "Input and output" { $subsection "io.timeouts" } ; ARTICLE: "tools" "Developer tools" +{ $subsection "tools.vocabs" } "Exploratory tools:" { $subsection "editor" } { $subsection "tools.crossref" } diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor old mode 100644 new mode 100755 index 22a1945b24..d8a4f83169 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: sequences parser kernel help help.markup help.topics -words strings classes tools.browser namespaces io +words strings classes tools.vocabs namespaces io io.streams.string prettyprint definitions arrays vectors combinators splitting debugger hashtables sorting effects vocabs vocabs.loader assocs editors continuations classes.predicate diff --git a/extra/help/topics/topics.factor b/extra/help/topics/topics.factor old mode 100644 new mode 100755 index c5abc195cf..4a86d49a28 --- a/extra/help/topics/topics.factor +++ b/extra/help/topics/topics.factor @@ -7,6 +7,10 @@ IN: help.topics TUPLE: link name ; +MIXIN: topic +INSTANCE: link topic +INSTANCE: word topic + GENERIC: >link ( obj -- obj ) M: link >link ; M: vocab-spec >link ; diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index 64e2cc3c3d..01e29866eb 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -4,4 +4,4 @@ combinators namespaces system vocabs.loader sequences ; "io.unix." os append require -"vocabs.monitor" require +"tools.vocabs.monitor" require diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index 9bc587e00e..319acc35f8 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -14,4 +14,4 @@ USE: io.backend T{ windows-nt-io } set-io-backend -"vocabs.monitor" require +"tools.vocabs.monitor" require diff --git a/extra/tools/browser/browser-tests.factor b/extra/tools/browser/browser-tests.factor deleted file mode 100755 index 38d9ae65e2..0000000000 --- a/extra/tools/browser/browser-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: tools.browser.tests -USING: tools.browser tools.test help.markup ; - -[ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor deleted file mode 100755 index c189a6f9de..0000000000 --- a/extra/tools/browser/browser.factor +++ /dev/null @@ -1,364 +0,0 @@ -! Copyright (C) 2007, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces splitting sequences io.files kernel assocs -words vocabs vocabs.loader definitions parser continuations -inspector debugger io io.styles hashtables -sorting prettyprint source-files arrays combinators strings -system math.parser help.markup help.topics help.syntax -help.stylesheet memoize io.encodings.utf8 ; -IN: tools.browser - -MEMO: (vocab-file-contents) ( path -- lines ) - ?resource-path dup exists? - [ utf8 file-lines ] [ drop f ] if ; - -: vocab-file-contents ( vocab name -- seq ) - vocab-path+ dup [ (vocab-file-contents) ] when ; - -: set-vocab-file-contents ( seq vocab name -- ) - dupd vocab-path+ [ - ?resource-path utf8 set-file-lines - ] [ - "The " swap vocab-name - " vocabulary was not loaded from the file system" - 3append throw - ] ?if ; - -: vocab-summary-path ( vocab -- string ) - vocab-dir "summary.txt" path+ ; - -: vocab-summary ( vocab -- summary ) - dup dup vocab-summary-path vocab-file-contents - dup empty? [ - drop vocab-name " vocabulary" append - ] [ - nip first - ] if ; - -M: vocab summary - [ - dup vocab-summary % - " (" % - vocab-words assoc-size # - " words)" % - ] "" make ; - -M: vocab-link summary vocab-summary ; - -: set-vocab-summary ( string vocab -- ) - >r 1array r> - dup vocab-summary-path - set-vocab-file-contents ; - -: vocab-tags-path ( vocab -- string ) - vocab-dir "tags.txt" path+ ; - -: vocab-tags ( vocab -- tags ) - dup vocab-tags-path vocab-file-contents ; - -: set-vocab-tags ( tags vocab -- ) - dup vocab-tags-path set-vocab-file-contents ; - -: add-vocab-tags ( tags vocab -- ) - [ vocab-tags append prune ] keep set-vocab-tags ; - -: vocab-authors-path ( vocab -- string ) - vocab-dir "authors.txt" path+ ; - -: vocab-authors ( vocab -- authors ) - dup vocab-authors-path vocab-file-contents ; - -: set-vocab-authors ( authors vocab -- ) - dup vocab-authors-path set-vocab-file-contents ; - -: subdirs ( dir -- dirs ) - directory [ second ] subset keys natural-sort ; - -: (all-child-vocabs) ( root name -- vocabs ) - [ vocab-dir path+ ?resource-path subdirs ] keep - dup empty? [ - drop - ] [ - swap [ "." swap 3append ] with map - ] if ; - -: vocabs-in-dir ( root name -- ) - dupd (all-child-vocabs) [ - 2dup vocab-dir? [ 2dup swap >vocab-link , ] when - vocabs-in-dir - ] with each ; - -: all-vocabs ( -- assoc ) - vocab-roots get [ - dup [ "" vocabs-in-dir ] { } make - ] { } map>assoc ; - -MEMO: all-vocabs-seq ( -- seq ) - all-vocabs values concat ; - -: dangerous? ( name -- ? ) - #! Hack - { - { [ "cpu." ?head ] [ t ] } - { [ "io.unix" ?head ] [ t ] } - { [ "io.windows" ?head ] [ t ] } - { [ "ui.x11" ?head ] [ t ] } - { [ "ui.windows" ?head ] [ t ] } - { [ "ui.cocoa" ?head ] [ t ] } - { [ "cocoa" ?head ] [ t ] } - { [ "core-foundation" ?head ] [ t ] } - { [ "vocabs.loader.test" ?head ] [ t ] } - { [ "editors." ?head ] [ t ] } - { [ ".windows" ?tail ] [ t ] } - { [ ".unix" ?tail ] [ t ] } - { [ "unix." ?head ] [ t ] } - { [ ".linux" ?tail ] [ t ] } - { [ ".bsd" ?tail ] [ t ] } - { [ ".macosx" ?tail ] [ t ] } - { [ "windows." ?head ] [ t ] } - { [ "cocoa" ?head ] [ t ] } - { [ ".test" ?tail ] [ t ] } - { [ "raptor" ?head ] [ t ] } - { [ dup "tools.deploy.app" = ] [ t ] } - { [ t ] [ f ] } - } cond nip ; - -: filter-dangerous ( seq -- seq' ) - [ vocab-name dangerous? not ] subset ; - -: try-everything ( -- failures ) - all-vocabs-seq - filter-dangerous - require-all ; - -: load-everything ( -- ) - try-everything load-failures. ; - -: unrooted-child-vocabs ( prefix -- seq ) - dup empty? [ CHAR: . add ] unless - vocabs - [ vocab-root not ] subset - [ - vocab-name swap ?head CHAR: . rot member? not and - ] with subset - [ vocab ] map ; - -: all-child-vocabs ( prefix -- assoc ) - vocab-roots get [ - over dupd dupd (all-child-vocabs) - swap [ >vocab-link ] curry map - ] { } map>assoc - f rot unrooted-child-vocabs 2array add ; - -: load-children ( prefix -- ) - all-child-vocabs values concat - filter-dangerous - require-all - load-failures. ; - -: vocab-status-string ( vocab -- string ) - { - { [ dup not ] [ drop "" ] } - { [ dup vocab-main ] [ drop "[Runnable]" ] } - { [ t ] [ drop "[Loaded]" ] } - } cond ; - -: write-status ( vocab -- ) - vocab vocab-status-string write ; - -: vocab. ( vocab -- ) - [ - dup [ write-status ] with-cell - dup [ ($link) ] with-cell - [ vocab-summary write ] with-cell - ] with-row ; - -: vocab-headings. ( -- ) - [ - [ "State" write ] with-cell - [ "Vocabulary" write ] with-cell - [ "Summary" write ] with-cell - ] with-row ; - -: root-heading. ( root -- ) - [ "Children from " swap append ] [ "Children" ] if* - $heading ; - -: vocabs. ( assoc -- ) - [ - dup empty? [ - 2drop - ] [ - swap root-heading. - standard-table-style [ - vocab-headings. [ vocab. ] each - ] ($grid) - ] if - ] assoc-each ; - -: describe-summary ( vocab -- ) - vocab-summary [ - "Summary" $heading print-element - ] when* ; - -TUPLE: vocab-tag name ; - -C: vocab-tag - -: tags. ( seq -- ) [ ] map $links ; - -: describe-tags ( vocab -- ) - vocab-tags f like [ - "Tags" $heading tags. - ] when* ; - -TUPLE: vocab-author name ; - -C: vocab-author - -: authors. ( seq -- ) [ ] map $links ; - -: describe-authors ( vocab -- ) - vocab-authors f like [ - "Authors" $heading authors. - ] when* ; - -: describe-help ( vocab -- ) - vocab-help [ - "Documentation" $heading nl ($link) - ] when* ; - -: describe-children ( vocab -- ) - vocab-name all-child-vocabs vocabs. ; - -: describe-files ( vocab -- ) - vocab-files [ ] map [ - "Files" $heading - [ - snippet-style get [ - code-style get [ - stack. - ] with-nesting - ] with-style - ] ($block) - ] when* ; - -: describe-words ( vocab -- ) - words dup empty? [ - "Words" $heading - dup natural-sort $links - ] unless drop ; - -: map>set ( seq quot -- ) - map concat prune natural-sort ; inline - -: vocab-xref ( vocab quot -- vocabs ) - >r dup vocab-name swap words r> map - [ [ word? ] subset [ word-vocabulary ] map ] map>set - remove [ ] subset [ vocab ] map ; inline - -: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; - -: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ; - -: describe-uses ( vocab -- ) - vocab-uses dup empty? [ - "Uses" $heading - dup $links - ] unless drop ; - -: describe-usage ( vocab -- ) - vocab-usage dup empty? [ - "Used by" $heading - dup $links - ] unless drop ; - -: $describe-vocab ( element -- ) - first - dup describe-children - dup vocab-root over vocab-dir? [ - dup describe-summary - dup describe-tags - dup describe-authors - dup describe-files - ] when - dup vocab [ - dup describe-help - dup describe-words - dup describe-uses - dup describe-usage - ] when drop ; - -: keyed-vocabs ( str quot -- seq ) - all-vocabs [ - swap >r - [ >r 2dup r> swap call member? ] subset - r> swap - ] assoc-map 2nip ; inline - -: tagged ( tag -- assoc ) - [ vocab-tags ] keyed-vocabs ; - -: authored ( author -- assoc ) - [ vocab-authors ] keyed-vocabs ; - -: $tagged-vocabs ( element -- ) - first tagged vocabs. ; - -MEMO: all-tags ( -- seq ) - all-vocabs-seq [ vocab-tags ] map>set ; - -: $authored-vocabs ( element -- ) - first authored vocabs. ; - -MEMO: all-authors ( -- seq ) - all-vocabs-seq [ vocab-authors ] map>set ; - -: $tags ( element -- ) - drop "Tags" $heading all-tags tags. ; - -: $authors ( element -- ) - drop "Authors" $heading all-authors authors. ; - -M: vocab-spec article-title vocab-name " vocabulary" append ; - -M: vocab-spec article-name vocab-name ; - -M: vocab-spec article-content - vocab-name \ $describe-vocab swap 2array ; - -M: vocab-spec article-parent drop "vocab-index" ; - -M: vocab-tag >link ; - -M: vocab-tag article-title - vocab-tag-name "Vocabularies tagged ``" swap "''" 3append ; - -M: vocab-tag article-name vocab-tag-name ; - -M: vocab-tag article-content - \ $tagged-vocabs swap vocab-tag-name 2array ; - -M: vocab-tag article-parent drop "vocab-index" ; - -M: vocab-tag summary article-title ; - -M: vocab-author >link ; - -M: vocab-author article-title - vocab-author-name "Vocabularies by " swap append ; - -M: vocab-author article-name vocab-author-name ; - -M: vocab-author article-content - \ $authored-vocabs swap vocab-author-name 2array ; - -M: vocab-author article-parent drop "vocab-index" ; - -M: vocab-author summary article-title ; - -: reset-cache ( -- ) - \ (vocab-file-contents) reset-memoized - \ all-vocabs-seq reset-memoized - \ all-authors reset-memoized - \ all-tags reset-memoized ; diff --git a/extra/tools/browser/authors.txt b/extra/tools/vocabs/browser/authors.txt similarity index 100% rename from extra/tools/browser/authors.txt rename to extra/tools/vocabs/browser/authors.txt diff --git a/extra/tools/vocabs/browser/browser-docs.factor b/extra/tools/vocabs/browser/browser-docs.factor new file mode 100755 index 0000000000..3765efb863 --- /dev/null +++ b/extra/tools/vocabs/browser/browser-docs.factor @@ -0,0 +1,7 @@ +USING: help.markup help.syntax io strings ; +IN: tools.vocabs.browser + +ARTICLE: "vocab-index" "Vocabulary index" +{ $tags } +{ $authors } +{ $describe-vocab "" } ; diff --git a/extra/tools/vocabs/browser/browser-tests.factor b/extra/tools/vocabs/browser/browser-tests.factor new file mode 100755 index 0000000000..7e12a56cf2 --- /dev/null +++ b/extra/tools/vocabs/browser/browser-tests.factor @@ -0,0 +1,4 @@ +IN: tools.vocabs.browser.tests +USING: tools.vocabs.browser tools.test help.markup ; + +[ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor new file mode 100755 index 0000000000..2c66305d47 --- /dev/null +++ b/extra/tools/vocabs/browser/browser.factor @@ -0,0 +1,207 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel combinators vocabs vocabs.loader tools.vocabs io +io.files io.styles help.markup help.stylesheet sequences assocs +help.topics namespaces prettyprint words sorting definitions +arrays inspector ; +IN: tools.vocabs.browser + +: vocab-status-string ( vocab -- string ) + { + { [ dup not ] [ drop "" ] } + { [ dup vocab-main ] [ drop "[Runnable]" ] } + { [ t ] [ drop "[Loaded]" ] } + } cond ; + +: write-status ( vocab -- ) + vocab vocab-status-string write ; + +: vocab. ( vocab -- ) + [ + dup [ write-status ] with-cell + dup [ ($link) ] with-cell + [ vocab-summary write ] with-cell + ] with-row ; + +: vocab-headings. ( -- ) + [ + [ "State" write ] with-cell + [ "Vocabulary" write ] with-cell + [ "Summary" write ] with-cell + ] with-row ; + +: root-heading. ( root -- ) + [ "Children from " swap append ] [ "Children" ] if* + $heading ; + +: vocabs. ( assoc -- ) + [ + dup empty? [ + 2drop + ] [ + swap root-heading. + standard-table-style [ + vocab-headings. [ vocab. ] each + ] ($grid) + ] if + ] assoc-each ; + +: describe-summary ( vocab -- ) + vocab-summary [ + "Summary" $heading print-element + ] when* ; + +TUPLE: vocab-tag name ; + +INSTANCE: vocab-tag topic + +C: vocab-tag + +: tags. ( seq -- ) [ ] map $links ; + +: describe-tags ( vocab -- ) + vocab-tags f like [ + "Tags" $heading tags. + ] when* ; + +TUPLE: vocab-author name ; + +INSTANCE: vocab-author topic + +C: vocab-author + +: authors. ( seq -- ) [ ] map $links ; + +: describe-authors ( vocab -- ) + vocab-authors f like [ + "Authors" $heading authors. + ] when* ; + +: describe-help ( vocab -- ) + vocab-help [ + "Documentation" $heading nl ($link) + ] when* ; + +: describe-children ( vocab -- ) + vocab-name all-child-vocabs vocabs. ; + +: describe-files ( vocab -- ) + vocab-files [ ] map [ + "Files" $heading + [ + snippet-style get [ + code-style get [ + stack. + ] with-nesting + ] with-style + ] ($block) + ] when* ; + +: describe-words ( vocab -- ) + words dup empty? [ + "Words" $heading + dup natural-sort $links + ] unless drop ; + +: vocab-xref ( vocab quot -- vocabs ) + >r dup vocab-name swap words r> map + [ [ word? ] subset [ word-vocabulary ] map ] map>set + remove [ ] subset [ vocab ] map ; inline + +: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; + +: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ; + +: describe-uses ( vocab -- ) + vocab-uses dup empty? [ + "Uses" $heading + dup $links + ] unless drop ; + +: describe-usage ( vocab -- ) + vocab-usage dup empty? [ + "Used by" $heading + dup $links + ] unless drop ; + +: $describe-vocab ( element -- ) + first + dup describe-children + dup vocab-root over vocab-dir? [ + dup describe-summary + dup describe-tags + dup describe-authors + dup describe-files + ] when + dup vocab [ + dup describe-help + dup describe-words + dup describe-uses + dup describe-usage + ] when drop ; + +: keyed-vocabs ( str quot -- seq ) + all-vocabs [ + swap >r + [ >r 2dup r> swap call member? ] subset + r> swap + ] assoc-map 2nip ; inline + +: tagged ( tag -- assoc ) + [ vocab-tags ] keyed-vocabs ; + +: authored ( author -- assoc ) + [ vocab-authors ] keyed-vocabs ; + +: $tagged-vocabs ( element -- ) + first tagged vocabs. ; + +: $authored-vocabs ( element -- ) + first authored vocabs. ; + +: $tags ( element -- ) + drop "Tags" $heading all-tags tags. ; + +: $authors ( element -- ) + drop "Authors" $heading all-authors authors. ; + +INSTANCE: vocab topic + +INSTANCE: vocab-link topic + +M: vocab-spec article-title vocab-name " vocabulary" append ; + +M: vocab-spec article-name vocab-name ; + +M: vocab-spec article-content + vocab-name \ $describe-vocab swap 2array ; + +M: vocab-spec article-parent drop "vocab-index" ; + +M: vocab-tag >link ; + +M: vocab-tag article-title + vocab-tag-name "Vocabularies tagged ``" swap "''" 3append ; + +M: vocab-tag article-name vocab-tag-name ; + +M: vocab-tag article-content + \ $tagged-vocabs swap vocab-tag-name 2array ; + +M: vocab-tag article-parent drop "vocab-index" ; + +M: vocab-tag summary article-title ; + +M: vocab-author >link ; + +M: vocab-author article-title + vocab-author-name "Vocabularies by " swap append ; + +M: vocab-author article-name vocab-author-name ; + +M: vocab-author article-content + \ $authored-vocabs swap vocab-author-name 2array ; + +M: vocab-author article-parent drop "vocab-index" ; + +M: vocab-author summary article-title ; diff --git a/extra/tools/browser/tags.txt b/extra/tools/vocabs/browser/tags.txt similarity index 100% rename from extra/tools/browser/tags.txt rename to extra/tools/vocabs/browser/tags.txt diff --git a/extra/vocabs/monitor/authors.txt b/extra/tools/vocabs/monitor/authors.txt similarity index 100% rename from extra/vocabs/monitor/authors.txt rename to extra/tools/vocabs/monitor/authors.txt diff --git a/extra/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor similarity index 79% rename from extra/vocabs/monitor/monitor.factor rename to extra/tools/vocabs/monitor/monitor.factor index 78e2339764..071f179676 100755 --- a/extra/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: threads io.files io.monitors init kernel -tools.browser namespaces continuations vocabs.loader ; -IN: vocabs.monitor +vocabs.loader tools.vocabs namespaces continuations ; +IN: tools.vocabs.monitor ! Use file system change monitoring to flush the tags/authors ! cache @@ -21,4 +21,4 @@ SYMBOL: vocab-monitor [ monitor-thread t ] "Vocabulary monitor" spawn-server drop ] ignore-errors ; -[ start-monitor-thread ] "vocabs.monitor" add-init-hook +[ start-monitor-thread ] "tools.vocabs.monitor" add-init-hook diff --git a/extra/vocabs/monitor/summary.txt b/extra/tools/vocabs/monitor/summary.txt similarity index 100% rename from extra/vocabs/monitor/summary.txt rename to extra/tools/vocabs/monitor/summary.txt diff --git a/extra/tools/browser/browser-docs.factor b/extra/tools/vocabs/vocabs-docs.factor similarity index 73% rename from extra/tools/browser/browser-docs.factor rename to extra/tools/vocabs/vocabs-docs.factor index 28bef58a8a..bdc3954e2e 100755 --- a/extra/tools/browser/browser-docs.factor +++ b/extra/tools/vocabs/vocabs-docs.factor @@ -1,52 +1,63 @@ -USING: help.markup help.syntax io strings ; -IN: tools.browser - -ARTICLE: "vocab-index" "Vocabulary index" -{ $tags } -{ $authors } -{ $describe-vocab "" } ; - -ARTICLE: "tools.browser" "Vocabulary browser" -"Getting and setting vocabulary meta-data:" -{ $subsection vocab-file-contents } -{ $subsection set-vocab-file-contents } -{ $subsection vocab-summary } -{ $subsection set-vocab-summary } -{ $subsection vocab-tags } -{ $subsection set-vocab-tags } -{ $subsection add-vocab-tags } -"Global meta-data:" -{ $subsection all-vocabs } -{ $subsection all-vocabs-seq } -{ $subsection all-tags } -{ $subsection all-authors } -"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:" -{ $subsection reset-cache } ; - -HELP: vocab-file-contents -{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } } -{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-file-contents -{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } } -{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ; - -HELP: vocab-summary -{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } } -{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-summary -{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } } -{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ; - -HELP: vocab-tags -{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } } -{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-tags -{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } } -{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ; - -HELP: all-vocabs -{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } } -{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ; +USING: help.markup help.syntax strings ; +IN: tools.vocabs + +ARTICLE: "tools.vocabs" "Vocabulary tools" +"Reloading source files changed on disk:" +{ $subsection refresh } +{ $subsection refresh-all } +"Vocabulary summaries:" +{ $subsection vocab-summary } +{ $subsection set-vocab-summary } +"Vocabulary tags:" +{ $subsection vocab-tags } +{ $subsection set-vocab-tags } +{ $subsection add-vocab-tags } +"Getting and setting vocabulary meta-data:" +{ $subsection vocab-file-contents } +{ $subsection set-vocab-file-contents } +"Global meta-data:" +{ $subsection all-vocabs } +{ $subsection all-vocabs-seq } +{ $subsection all-tags } +{ $subsection all-authors } +"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "tools.vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:" +{ $subsection reset-cache } ; + +ABOUT: "tools.vocabs" + +HELP: refresh +{ $values { "prefix" string } } +{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; + +HELP: refresh-all +{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ; + +{ refresh refresh-all } related-words + +HELP: vocab-file-contents +{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } } +{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-file-contents +{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } } +{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ; + +HELP: vocab-summary +{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } } +{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-summary +{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } } +{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ; + +HELP: vocab-tags +{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } } +{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-tags +{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } } +{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ; + +HELP: all-vocabs +{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } } +{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ; diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor new file mode 100755 index 0000000000..ba6baa543f --- /dev/null +++ b/extra/tools/vocabs/vocabs.factor @@ -0,0 +1,232 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.files kernel io.encodings.utf8 vocabs.loader vocabs +sequences namespaces math.parser arrays hashtables assocs +memoize inspector sorting splitting combinators source-files +io debugger continuations compiler.errors init ; +IN: tools.vocabs + +: modified ( seq quot -- seq ) + [ dup ] swap compose { } map>assoc + [ nip ] assoc-subset + [ nip source-modified? ] assoc-subset keys ; inline + +: modified-sources ( vocabs -- seq ) + [ vocab-source-path ] modified ; + +: modified-docs ( vocabs -- seq ) + [ vocab-docs-path ] modified ; + +: update-roots ( vocabs -- ) + [ dup find-vocab-root swap vocab set-vocab-root ] each ; + +: to-refresh ( prefix -- modified-sources modified-docs ) + child-vocabs + dup update-roots + dup modified-sources swap modified-docs ; + +: vocab-heading. ( vocab -- ) + nl + "==== " write + dup vocab-name swap vocab write-object ":" print + nl ; + +: load-error. ( triple -- ) + dup first vocab-heading. + dup second print-error + drop ; + +: load-failures. ( failures -- ) + [ load-error. nl ] each ; + +SYMBOL: failures + +: require-all ( vocabs -- failures ) + [ + V{ } clone blacklist set + V{ } clone failures set + [ + [ require ] + [ swap vocab-name failures get set-at ] + recover + ] each + failures get + ] with-compiler-errors ; + +: do-refresh ( modified-sources modified-docs -- ) + 2dup + [ f swap set-vocab-docs-loaded? ] each + [ f swap set-vocab-source-loaded? ] each + append prune require-all load-failures. ; + +: refresh ( prefix -- ) to-refresh do-refresh ; + +SYMBOL: sources-changed? + +[ t sources-changed? set-global ] "tools.vocabs" add-init-hook + +: refresh-all ( -- ) + "" refresh f sources-changed? set-global ; + +MEMO: (vocab-file-contents) ( path -- lines ) + ?resource-path dup exists? + [ utf8 file-lines ] [ drop f ] if ; + +: vocab-file-contents ( vocab name -- seq ) + vocab-path+ dup [ (vocab-file-contents) ] when ; + +: set-vocab-file-contents ( seq vocab name -- ) + dupd vocab-path+ [ + ?resource-path utf8 set-file-lines + ] [ + "The " swap vocab-name + " vocabulary was not loaded from the file system" + 3append throw + ] ?if ; + +: vocab-summary-path ( vocab -- string ) + vocab-dir "summary.txt" path+ ; + +: vocab-summary ( vocab -- summary ) + dup dup vocab-summary-path vocab-file-contents + dup empty? [ + drop vocab-name " vocabulary" append + ] [ + nip first + ] if ; + +M: vocab summary + [ + dup vocab-summary % + " (" % + vocab-words assoc-size # + " words)" % + ] "" make ; + +M: vocab-link summary vocab-summary ; + +: set-vocab-summary ( string vocab -- ) + >r 1array r> + dup vocab-summary-path + set-vocab-file-contents ; + +: vocab-tags-path ( vocab -- string ) + vocab-dir "tags.txt" path+ ; + +: vocab-tags ( vocab -- tags ) + dup vocab-tags-path vocab-file-contents ; + +: set-vocab-tags ( tags vocab -- ) + dup vocab-tags-path set-vocab-file-contents ; + +: add-vocab-tags ( tags vocab -- ) + [ vocab-tags append prune ] keep set-vocab-tags ; + +: vocab-authors-path ( vocab -- string ) + vocab-dir "authors.txt" path+ ; + +: vocab-authors ( vocab -- authors ) + dup vocab-authors-path vocab-file-contents ; + +: set-vocab-authors ( authors vocab -- ) + dup vocab-authors-path set-vocab-file-contents ; + +: subdirs ( dir -- dirs ) + directory [ second ] subset keys natural-sort ; + +: (all-child-vocabs) ( root name -- vocabs ) + [ vocab-dir path+ ?resource-path subdirs ] keep + dup empty? [ + drop + ] [ + swap [ "." swap 3append ] with map + ] if ; + +: vocabs-in-dir ( root name -- ) + dupd (all-child-vocabs) [ + 2dup vocab-dir? [ 2dup swap >vocab-link , ] when + vocabs-in-dir + ] with each ; + +: all-vocabs ( -- assoc ) + vocab-roots get [ + dup [ "" vocabs-in-dir ] { } make + ] { } map>assoc ; + +MEMO: all-vocabs-seq ( -- seq ) + all-vocabs values concat ; + +: dangerous? ( name -- ? ) + #! Hack + { + { [ "cpu." ?head ] [ t ] } + { [ "io.unix" ?head ] [ t ] } + { [ "io.windows" ?head ] [ t ] } + { [ "ui.x11" ?head ] [ t ] } + { [ "ui.windows" ?head ] [ t ] } + { [ "ui.cocoa" ?head ] [ t ] } + { [ "cocoa" ?head ] [ t ] } + { [ "core-foundation" ?head ] [ t ] } + { [ "vocabs.loader.test" ?head ] [ t ] } + { [ "editors." ?head ] [ t ] } + { [ ".windows" ?tail ] [ t ] } + { [ ".unix" ?tail ] [ t ] } + { [ "unix." ?head ] [ t ] } + { [ ".linux" ?tail ] [ t ] } + { [ ".bsd" ?tail ] [ t ] } + { [ ".macosx" ?tail ] [ t ] } + { [ "windows." ?head ] [ t ] } + { [ "cocoa" ?head ] [ t ] } + { [ ".test" ?tail ] [ t ] } + { [ "raptor" ?head ] [ t ] } + { [ dup "tools.deploy.app" = ] [ t ] } + { [ t ] [ f ] } + } cond nip ; + +: filter-dangerous ( seq -- seq' ) + [ vocab-name dangerous? not ] subset ; + +: try-everything ( -- failures ) + all-vocabs-seq + filter-dangerous + require-all ; + +: load-everything ( -- ) + try-everything load-failures. ; + +: unrooted-child-vocabs ( prefix -- seq ) + dup empty? [ CHAR: . add ] unless + vocabs + [ vocab-root not ] subset + [ + vocab-name swap ?head CHAR: . rot member? not and + ] with subset + [ vocab ] map ; + +: all-child-vocabs ( prefix -- assoc ) + vocab-roots get [ + over dupd dupd (all-child-vocabs) + swap [ >vocab-link ] curry map + ] { } map>assoc + f rot unrooted-child-vocabs 2array add ; + +: load-children ( prefix -- ) + all-child-vocabs values concat + filter-dangerous + require-all + load-failures. ; + +: map>set ( seq quot -- ) + map concat prune natural-sort ; inline + +MEMO: all-tags ( -- seq ) + all-vocabs-seq [ vocab-tags ] map>set ; + +MEMO: all-authors ( -- seq ) + all-vocabs-seq [ vocab-authors ] map>set ; + +: reset-cache ( -- ) + \ (vocab-file-contents) reset-memoized + \ all-vocabs-seq reset-memoized + \ all-authors reset-memoized + \ all-tags reset-memoized ; diff --git a/extra/ui/tools/operations/operations.factor b/extra/ui/tools/operations/operations.factor index 093222f17b..51a545db47 100755 --- a/extra/ui/tools/operations/operations.factor +++ b/extra/ui/tools/operations/operations.factor @@ -8,7 +8,7 @@ namespaces parser prettyprint quotations tools.annotations editors tools.profiler tools.test tools.time tools.walker ui.commands ui.gadgets.editors ui.gestures ui.operations ui.tools.deploy vocabs vocabs.loader words sequences -tools.browser classes compiler.units ; +tools.vocabs classes compiler.units ; IN: ui.tools.operations V{ } clone operations set-global @@ -84,11 +84,7 @@ UNION: definition word method-spec link vocab vocab-link ; { +secondary+ t } } define-operation -[ - class - { link word vocab vocab-link vocab-tag vocab-author } - memq? -] \ com-follow H{ +[ topic? ] \ com-follow H{ { +keyboard+ T{ key-down f { C+ } "H" } } { +primary+ t } } define-operation diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor index b37b4ca707..45ac645392 100755 --- a/extra/ui/tools/search/search.factor +++ b/extra/ui/tools/search/search.factor @@ -7,7 +7,7 @@ source-files definitions strings tools.completion tools.crossref tuples ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations vocabs words vocabs.loader -tools.browser unicode.case calendar ui ; +tools.vocabs unicode.case calendar ui ; IN: ui.tools.search TUPLE: live-search field list ; From bae538d9bdcbf8f0e2ff3d46ee4e385817a6d30e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 12 Mar 2008 23:17:54 -0500 Subject: [PATCH 03/83] fix syntax highlighting add image links --- extra/farkup/farkup-tests.factor | 9 +++++++-- extra/farkup/farkup.factor | 34 ++++++++++++++++++++++++-------- 2 files changed, 33 insertions(+), 10 deletions(-) diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor index bdb08bd29a..af4ddd8839 100755 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -52,7 +52,12 @@ IN: farkup.tests [ "

foo

" ] [ "==foo==" convert-farkup ] unit-test [ "

foo

" ] [ "==foo==" convert-farkup ] unit-test [ "

=

foo

" ] [ "===foo==" convert-farkup ] unit-test - - [ "

foo

=

" ] [ "=foo==" convert-farkup ] unit-test +[ "int main()
" ] +[ "[c{int main()}]" convert-farkup ] unit-test + +[ "

" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test +[ "

\"teh

" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test +[ "

" ] [ "[[lol.com]]" convert-farkup ] unit-test +[ "

haha

" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index ac91a77685..142fc5de6c 100755 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -55,10 +55,31 @@ MEMO: eq ( -- parser ) >r string-lines r> [ [ htmlize-lines ] with-html-stream ] with-string-writer ; +: escape-link ( href text -- href-esc text-esc ) + >r escape-quoted-string r> escape-string ; + : make-link ( href text -- seq ) - >r escape-quoted-string r> escape-string + escape-link [ "r , r> "\">" , [ , ] when* "" , ] { } make ; +: make-image-link ( href alt -- seq ) + escape-link + [ + "\""" , ] + { } make ; + +MEMO: image-link ( -- parser ) + [ + "[[image:" token hide , + [ "|]" member? not ] satisfy repeat1 [ >string ] action , + "|" token hide + [ CHAR: ] = not ] satisfy repeat0 2seq + [ first >string ] action optional , + "]]" token hide , + ] seq* [ first2 make-image-link ] action ; + MEMO: simple-link ( -- parser ) [ "[[" token hide , @@ -75,7 +96,7 @@ MEMO: labelled-link ( -- parser ) "]]" token hide , ] seq* [ first2 make-link ] action ; -MEMO: link ( -- parser ) [ simple-link , labelled-link , ] choice* ; +MEMO: link ( -- parser ) [ image-link , simple-link , labelled-link , ] choice* ; DEFER: line MEMO: list-item ( -- parser ) @@ -101,13 +122,10 @@ MEMO: table ( -- parser ) MEMO: code ( -- parser ) [ "[" token hide , - [ "{" member? not ] satisfy repeat1 optional [ >string ] action , + [ CHAR: { = not ] satisfy repeat1 optional [ >string ] action , "{" token hide , - [ - [ any-char , "}]" token ensure-not , ] seq* - repeat1 [ concat >string ] action , - [ any-char , "}]" token hide , ] seq* optional [ >string ] action , - ] seq* [ concat ] action , + "}]" token ensure-not any-char 2seq repeat0 [ concat >string ] action , + "}]" token hide , ] seq* [ first2 swap render-code ] action ; MEMO: line ( -- parser ) From 208423471913dd638920fb07f67e49f35050ecd4 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 13 Mar 2008 15:20:05 +1100 Subject: [PATCH 04/83] improved and updated the vim syntax file, and fixed the syntax generator --- .../generate-syntax/generate-syntax.factor | 10 ++ extra/editors/vim/generate-vim-syntax.factor | 10 -- misc/factor.vim | 97 +++++++++++++------ misc/factor.vim.fgen | 85 +++++++++++----- 4 files changed, 134 insertions(+), 68 deletions(-) create mode 100644 extra/editors/vim/generate-syntax/generate-syntax.factor delete mode 100644 extra/editors/vim/generate-vim-syntax.factor diff --git a/extra/editors/vim/generate-syntax/generate-syntax.factor b/extra/editors/vim/generate-syntax/generate-syntax.factor new file mode 100644 index 0000000000..178a1b3b8b --- /dev/null +++ b/extra/editors/vim/generate-syntax/generate-syntax.factor @@ -0,0 +1,10 @@ +! Generate a new factor.vim file for syntax highlighting +USING: http.server.templating.fhtml io.files ; +IN: editors.vim.generate-syntax + +: generate-vim-syntax ( -- ) + "misc/factor.vim.fgen" resource-path + "misc/factor.vim" resource-path + template-convert ; + +MAIN: generate-vim-syntax diff --git a/extra/editors/vim/generate-vim-syntax.factor b/extra/editors/vim/generate-vim-syntax.factor deleted file mode 100644 index 23bd49cdb8..0000000000 --- a/extra/editors/vim/generate-vim-syntax.factor +++ /dev/null @@ -1,10 +0,0 @@ -! Generate a new factor.vim file for syntax highlighting -REQUIRES: apps/http-server ; - -IN: vim - -USING: embedded io ; - -"extras/factor.vim.fgen" resource-path -"extras/factor.vim" resource-path -embedded-convert diff --git a/misc/factor.vim b/misc/factor.vim index 4d15245da8..93ce3d6bd5 100644 --- a/misc/factor.vim +++ b/misc/factor.vim @@ -21,15 +21,26 @@ else set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255 endif -syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple +syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple syn match factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained syn match factorComment /\<#! .*/ contains=factorTodo syn match factorComment /\/ end=/\<;\>/ contains=@factorCluster,factorStackEffect,factorStackEffectErr,factorArray0,factorQuotation0 +syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorArray0,factorQuotation0 + +syn region factorDefn matchgroup=factorDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents +syn region factorMethod matchgroup=factorMethodDelims start=/\/ end=/\<;\>/ contains=@factorDefnContents +syn region factorGeneric matchgroup=factorGenericDelims start=/\/ end=/$/ contains=factorStackEffect +syn region factorGenericN matchgroup=factorGenericNDelims start=/\/ end=/$/ contains=factorStackEffect + +syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained +syn region factorPrivateMethod matchgroup=factorPrivateMethodDelims start=/\/ end=/\<;\>/ contains=@factorDefnContents contained +syn region factorPGeneric matchgroup=factorPGenericDelims start=/\/ end=/$/ contains=factorStackEffect contained +syn region factorPGenericN matchgroup=factorPGenericNDelims start=/\/ end=/$/ contains=factorStackEffect + +syn region None matchgroup=factorPrivate start=/\</ end=/\\>/ contains=@factorDefnContents,factorPrivateDefn,factorPrivateMethod,factorPGeneric,factorPGenericN -syn region None matchgroup=factorGeneric start=/\/ end=/$/ contains=factorStackEffect,factorStackEffectErr syn keyword factorBoolean boolean f general-t t syn keyword factorCompileDirective inline foldable parsing @@ -37,15 +48,17 @@ syn keyword factorCompileDirective inline foldable parsing " kernel vocab keywords -syn keyword factorKeyword continuation-name set-datastack wrapper continuation-catch set-continuation-name slip pick 2slip 2nip tuple set-boot clone with-datastack cpu -roll tuck -rot (continue) set-continuation-retain swapd >boolean wrapper? dupd 3dup dup ifcc callstack windows? os-env = over continuation alist>quot ? 2dup cond win64? continue 3drop hashcode quotation xor when curry millis set-callstack unless >r die version callcc0 or os callcc1 get-walker-hook depth equal? 3keep no-cond? continue-with if exit tuple? set-retainstack unix? (continue-with) general-t continuation? 3slip macosx? r> rot win32? retainstack 2apply >quotation >continuation< type continuation-call clear call drop continuation-data set-continuation-call 2drop no-cond unit set-continuation-data keep-datastack and when* quotation? ?if literalize datastack swap unless* 2swap set-continuation-catch eq? not roll set-walker-hook continuation-retain with make-dip wrapped keep 2keep <=> if* nip -syn keyword factorKeyword sin integer? log2 cot oct> number>string integer first-bignum sech abs repeat tanh real? vmin norm-sq neg between? asech >rect bignum? atanh -i * + fp-nan? - small / sqrt infimum fix-float cosech even? v*n < bits>double > most-positive-fixnum ^theta numerator digit+ >base (random-int) acosech cosh min pi number vmax zero? sum digit> rem bitor supremum string>integer most-negative-fixnum >polar >fraction ceiling acos acot ^ asin acosh /f ratio e fixnum? /i ^n cis coth 1+ 1- conjugate sinh acosec i number= number? double>bits epsilon float product string>number n/v norm max tan acoth absq float? asinh denominator rational? fixnum rect> >fixnum imaginary recip exp sec bitxor w>h/h >bin align base> times log <= [-] init-random sq odd? (repeat) [v-] ^mag bitnot ratio? random-int >digit (next-power-of-2) v* v+ v- v. v/ >float [-1,1]? arg small? bitand set-axis >oct v/n complex rational shift (^) polar> (gcd) cosec next-power-of-2 >float-rect atan sgn >= float>bits normalize real bin> complex? gcd d>w/w hex> mod string>ratio asec floor n*v >hex truncate bits>float vneg >bignum bignum power-of-2? integer, /mod (string>integer) cos -syn keyword factorKeyword second sort-values all-eq? pop* find slice-error-reason inject-with prune remove (group) split1-slice slice-error (slice*) split* head-slice* find* split, first remove-nth hash-prune push-if ?push reverse subseq split1 diff subset split new padding column? copy-into-check column@ peek last/first add find-last ?nth add* slice-from cache-nth subseq? (3append) replace-slice reversed-seq find-last-with empty? ((append)) reversed? reversed@ map-with find-last-with* set-slice-error-reason set-column-col natural-sort (subst) set-slice-seq index* concat push binsearch slice-seq 3append nsort length tail-slice* reversed ?head sequence= ?tail sequence? memq? join split-next, delete set-nth subst monotonic? group map flip unclip set-reversed-seq find-last* start* max-length assoc min-length all-equal? all? pad-left contains? inject slice first2 first3 first4 exchange bounds-check? column-seq check-slice pad-right each subset-with unpair tail head interleave (delete) copy-into sort sequence reduce set-slice-from set-slice-to 2map (cut) member? cut rassoc (append) last-index* sort-keys change-nth 2each >sequence nth tail* head* third tail-slice set-length collapse-slice column (mismatch) contains-with? push-new pop tail? head? slice? slice@ delete-all binsearch* move find-with* 2reduce slice-to find-with like slice-error? set-column-seq nappend column-col cut* (split) index each-with last-index fourth append accumulate drop-prefix mismatch head-slice all-with? start -syn keyword factorKeyword namespace-error-object inc dec make off bind get-global init-namespaces set-global namespace on ndrop namespace-error? namestack namespace-error +@ # % make-hash global , set-namestack with-scope building change nest set-namespace-error-object get set counter -syn keyword factorKeyword array pair byte-array pair? 1array 2array resize-array 4array 3array byte-array? array? >array -syn keyword factorKeyword cwd duplex-stream pathname? set-pathname-string with-log-file directory duplex-stream-out format (readln) duplex-stream? read1 with-stream-style c-stream-error? stream-write1 with-stream line-reader? set-duplex-stream-out server? cr> directory? log-message flush format-column stream-readln nested-style-stream? set-timeout write-pathname file-modified duplex-stream-closed? print set-duplex-stream-closed? pathname line-reader ?resource-path terpri write-object le> string-out stream-terpri log-client do-nested-style path+ set-client-stream-host plain-writer? server-stream resource-path >be parent-dir with-stream* server-loop string-in nested-style-stream stream-close stream-copy c-stream-error with-style client-stream-host stat plain-writer file-length contents stream-read stream-format check-closed? set-client-stream-port write1 bl write-outliner map-last (with-stream-style) set-line-reader-cr tabular-output (lines) stream-write log-stream server-client (stream-copy) with-nested-stream lines readln cd client-stream nth-byte with-logging stream-read1 nested-style-stream-style accept check-closed client-stream-port do-nested-quot pathname-string set-nested-style-stream-style read home close with-stream-table stdio be> log-error duplex-stream-out+ server stream-flush set-duplex-stream-in line-reader-cr >le with-client (directory) set-server-client stream-print with-server exists? with-nesting string-lines write duplex-stream-in client-stream? duplex-stream-in+ -syn keyword factorKeyword sbuf ch>upper string? LETTER? >sbuf >lower quotable? string>sbuf blank? string sbuf? printable? >string letter? resize-string control? alpha? >upper Letter? ch>lower digit? ch>string -syn keyword factorKeyword >vector array>vector vector? vector -syn keyword factorKeyword set-restart-continuation cleanup error-hook restart-name restarts. stack-underflow. expired-error. restart restart? word-xt. (:help-none) set-catchstack c-string-error. condition debug-help :get datastack-overflow. set-condition-restarts condition? error. objc-error. print-error assert :res catchstack rethrow assert= kernel-error restart-obj assert? undefined-symbol-error. retainstack-overflow. restarts error-help divide-by-zero-error. ffi-error. signal-error. (:help-multi) set-restart-obj xt. memory-error. retainstack-underflow. set-condition-continuation datastack-underflow. try assert-depth error-continuation error-stack-trace assert-expect recover :edit kernel-error? error callstack-overflow. stack-overflow. callstack-underflow. set-assert-got set-restart-name restart-continuation condition-restarts heap-scan-error. :help type-check-error. assert-got throw negative-array-size-error. :c condition-continuation :trace undefined-word-error. io-error. parse-dump set-assert-expect :r :s compute-restarts catch restart. +syn keyword factorKeyword or construct-delegate set-slots tuck while wrapper nip hashcode wrapper? both? callstack>array die dupd set-delegate callstack callstack? 3dup pick curry build >boolean ?if clone eq? = ? swapd call-clear 2over 2keep 3keep construct general-t clear 2dup when not tuple? 3compose dup call object wrapped unless* if* 2apply >r curry-quot drop when* retainstack -rot delegate with 3slip construct-boa slip compose-first compose-second 3drop construct-empty either? curry? datastack compare curry-obj over 3curry roll throw swap and 2nip set-retainstack (clone) hashcode* get-slots compose spin if <=> unless compose? tuple keep 2curry object? equal? set-datastack 2slip 2drop most null r> set-callstack dip xor rot -roll +syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc union search-alist assoc-like key? update at* assoc-empty? at+ set-at assoc-all? assoc-hashcode intersect change-at assoc-each assoc-subset values rename-at value-at (assoc-stack) at cache assoc>map assoc-contains? assoc assoc-map assoc-pusher diff (assoc>map) assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute delete-at assoc-find keys +syn keyword factorKeyword case dispatch-case-quot with-datastack alist>quot dispatch-case hash-case-table hash-case-quot no-cond no-case? cond distribute-buckets (distribute-buckets) contiguous-range? cond>quot no-cond? no-case recursive-hashcode linear-case-quot hash-dispatch-quot case>quot +syn keyword factorKeyword byte-array>bignum sgn >bignum number= each-integer next-power-of-2 before? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? after? fixnum before=? bignum sq neg denominator [-] (all-integers?) times find-last-integer (each-integer) bit? * + - / >= bitand find-integer complex < real > log2 integer? max number bits>double double>bits bitor 2/ zero? rem all-integers? (find-integer) real-part align bits>float float? shift between? float 1+ 1- min fp-nan? ratio? bitxor even? ratio <= /mod >integer odd? rational? bitnot real? >fixnum complex? (next-power-of-2) /i numerator after=? /f +syn keyword factorKeyword slice-to append left-trim clone-like 3sequence set-column-seq map-as reversed pad-left cut* nth sequence slice? tail-slice empty? tail* member? unclip virtual-sequence? set-length last-index* drop-prefix bounds-error? set-slice-seq set-column-col seq-diff map start open-slice midpoint@ add* set-immutable-seq move-forward fourth delete set-slice-to all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) column? reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice index* move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right concat find* set-slice-from flip sum find-last* immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice column-seq sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find column remove ((append)) set-fourth peek contains? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth second change-each join set-repetition-len all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index seq-intersect push-if 2all? lengthen column-col joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first bounds-error add bounds-error-seq bounds-error-index unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice sum-lengths new 2each head* infimum subset slice-error subseq replace-slice repetition push trim sequence-hashcode mismatch +syn keyword factorKeyword global +@ set-namestack with-variable on set bind dec namestack get get-global change init-namespaces with-scope off set-global namespace % make , inc counter building make-assoc +syn keyword factorKeyword 3array >array 4array pair? array pair 2array 1array resize-array array? +syn keyword factorKeyword readln stream-read-until stream-read-partial stderr with-stream read with-stream* print contents make-span-stream write1 stream-write1 stream-format make-block-stream stream-copy with-cell stream-write format with-row stream-print stream-read with-nesting (stream-copy) bl write-object nl stream-nl write stdio flush read-until tabular-output make-cell-stream write-cell stream-flush read1 lines stream-read1 stream-write-table with-style stream-readln +syn keyword factorKeyword resize-string >string 1string string string? +syn keyword factorKeyword vector? ?push vector >vector 1vector +syn keyword factorKeyword rethrow-restarts restarts recover set-restart-name set-continuation-name condition-continuation ifcc continuation-name set-restart-continuation ignore-errors continuation-retain continue restart-continuation with-disposal set-continuation-catch restart-obj error thread-error-hook set-continuation-retain continuation rethrow callcc1 callcc0 condition continuation? continuation-call continuation-data set-condition-restarts set-catchstack >continuation< error-continuation cleanup restart? compute-restarts condition? error-thread set-continuation-call set-condition-continuation set-restart-obj dispose set-continuation-data throw-restarts catchstack continue-with attempt-all restart restart-name continuation-catch condition-restarts syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal @@ -73,11 +86,16 @@ syn match factorBackslash /\<\\\>\s\+\S\+\>/ syn region factorUsing start=/\/ end=/;/ syn region factorRequires start=/\/ end=/;/ -syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget +syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor syn match factorSymbol /\/ syn match factorPostpone /\/ syn match factorDefer /\/ syn match factorForget /\/ +syn match factorMixin /\/ +syn match factorInstance /\/ +syn match factorHook /\/ +syn match factorMain /\/ +syn match factorConstructor /\/ syn match factorAlien /\/ @@ -87,8 +105,6 @@ syn region factorTuple start=/\/ end=/\<;\>/ "misc: " HELP: " ARTICLE: -" PROVIDE: -" MAIN: "literals: " PRIMITIVE: @@ -106,8 +122,11 @@ syn region factorTuple start=/\/ end=/\<;\>/ syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline -syn match factorStackEffectErr /\<)\>/ -syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/ +syn region factorMultiString matchgroup=factorMultiStringDelims start=/\/ end=/^;$/ contains=factorMultiStringContents +syn match factorMultiStringContents /.*/ contained + +"syn match factorStackEffectErr /\<)\>/ +"syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/ syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained "adapted from lisp.vim @@ -127,18 +146,18 @@ else endif if exists("g:factor_norainbow") - syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL + syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL else - syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1 - syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2 - syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3 - syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4 - syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5 - syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6 - syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7 - syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8 - syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9 - syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0 + syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1 + syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2 + syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3 + syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4 + syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5 + syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6 + syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7 + syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8 + syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9 + syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0 endif syn match factorBracketErr /\<\]\>/ @@ -163,11 +182,21 @@ if version >= 508 || !exists("did_factor_syn_inits") HiLink factorKeyword Keyword HiLink factorOperator Operator HiLink factorBoolean Boolean - HiLink factorDefinition Typedef + HiLink factorDefnDelims Typedef + HiLink factorMethodDelims Typedef + HiLink factorGenericDelims Typedef + HiLink factorGenericNDelims Typedef + HiLink factorConstructor Typedef + HiLink factorPrivate Special + HiLink factorPrivateDefnDelims Special + HiLink factorPrivateMethodDelims Special + HiLink factorPGenericDelims Special + HiLink factorPGenericNDelims Special HiLink factorString String HiLink factorSbuf String + HiLink factorMultiStringContents String + HiLink factorMultiStringDelims Typedef HiLink factorBracketErr Error - HiLink factorStackEffectErr Error HiLink factorComplex Number HiLink factorRatio Number HiLink factorBinary Number @@ -186,14 +215,17 @@ if version >= 508 || !exists("did_factor_syn_inits") HiLink factorCharErr Error HiLink factorDelimiter Delimiter HiLink factorBackslash Special - HiLink factorCompileDirective Keyword + HiLink factorCompileDirective Typedef HiLink factorSymbol Define + HiLink factorMixin Typedef + HiLink factorInstance Typedef + HiLink factorHook Typedef + HiLink factorMain Define HiLink factorPostpone Define HiLink factorDefer Define HiLink factorForget Define HiLink factorAlien Define HiLink factorTuple Typedef - HiLink factorGeneric Define if &bg == "dark" hi hlLevel0 ctermfg=red guifg=red1 @@ -230,3 +262,4 @@ set expandtab set autoindent " annoying? " vim: syntax=vim + diff --git a/misc/factor.vim.fgen b/misc/factor.vim.fgen index 9782c4f1d0..7bcba78cde 100644 --- a/misc/factor.vim.fgen +++ b/misc/factor.vim.fgen @@ -1,4 +1,4 @@ -<% USING: kernel io prettyprint words sequences ; +<% USING: kernel io prettyprint vocabs sequences ; %>" Vim syntax file " Language: factor " Maintainer: Alex Chapman @@ -22,15 +22,26 @@ else set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255 endif -syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple +syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple syn match factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained syn match factorComment /\<#! .*/ contains=factorTodo syn match factorComment /\/ end=/\<;\>/ contains=@factorCluster,factorStackEffect,factorStackEffectErr,factorArray0,factorQuotation0 +syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorArray0,factorQuotation0 + +syn region factorDefn matchgroup=factorDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents +syn region factorMethod matchgroup=factorMethodDelims start=/\/ end=/\<;\>/ contains=@factorDefnContents +syn region factorGeneric matchgroup=factorGenericDelims start=/\/ end=/$/ contains=factorStackEffect +syn region factorGenericN matchgroup=factorGenericNDelims start=/\/ end=/$/ contains=factorStackEffect + +syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained +syn region factorPrivateMethod matchgroup=factorPrivateMethodDelims start=/\/ end=/\<;\>/ contains=@factorDefnContents contained +syn region factorPGeneric matchgroup=factorPGenericDelims start=/\/ end=/$/ contains=factorStackEffect contained +syn region factorPGenericN matchgroup=factorPGenericNDelims start=/\/ end=/$/ contains=factorStackEffect + +syn region None matchgroup=factorPrivate start=/\</ end=/\\>/ contains=@factorDefnContents,factorPrivateDefn,factorPrivateMethod,factorPGeneric,factorPGenericN -syn region None matchgroup=factorGeneric start=/\/ end=/$/ contains=factorStackEffect,factorStackEffectErr syn keyword factorBoolean boolean f general-t t syn keyword factorCompileDirective inline foldable parsing @@ -40,10 +51,13 @@ syn keyword factorCompileDirective inline foldable parsing ! that this changes factor.vim from around 8k to around 100k (and is a bit ! broken) -! vocabs [ words [ "syn keyword factorKeyword " write [ pprint " " write ] each "\n" write ] when* ] each %> +! vocabs [ words [ "syn keyword factorKeyword " write [ pprint " " write ] each "\n" write ] when* ] each +%> " kernel vocab keywords -<% { "kernel" "math" "sequences" "namespaces" "arrays" "io" "strings" "vectors" "errors" } [ words "syn keyword factorKeyword " write [ pprint " " write ] each "\n" write ] each %> +<% { "kernel" "assocs" "combinators" "math" "sequences" "namespaces" "arrays" "io" "strings" "vectors" "continuations" } [ + words "syn keyword factorKeyword " write [ pprint " " write ] each "\n" write + ] each %> syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal syn cluster factorNumber contains=@factorReal,factorComplex @@ -70,11 +84,16 @@ syn match factorBackslash /\<\\\>\s\+\S\+\>/ syn region factorUsing start=/\/ end=/;/ syn region factorRequires start=/\/ end=/;/ -syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget +syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor syn match factorSymbol /\/ syn match factorPostpone /\/ syn match factorDefer /\/ syn match factorForget /\/ +syn match factorMixin /\/ +syn match factorInstance /\/ +syn match factorHook /\/ +syn match factorMain /\/ +syn match factorConstructor /\/ syn match factorAlien /\/ @@ -84,8 +103,6 @@ syn region factorTuple start=/\/ end=/\<;\>/ "misc: " HELP: " ARTICLE: -" PROVIDE: -" MAIN: "literals: " PRIMITIVE: @@ -103,8 +120,11 @@ syn region factorTuple start=/\/ end=/\<;\>/ syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline -syn match factorStackEffectErr /\<)\>/ -syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/ +syn region factorMultiString matchgroup=factorMultiStringDelims start=/\/ end=/^;$/ contains=factorMultiStringContents +syn match factorMultiStringContents /.*/ contained + +"syn match factorStackEffectErr /\<)\>/ +"syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/ syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained "adapted from lisp.vim @@ -124,18 +144,18 @@ else endif if exists("g:factor_norainbow") - syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL + syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL else - syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1 - syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2 - syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3 - syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4 - syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5 - syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6 - syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7 - syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8 - syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9 - syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0 + syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1 + syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2 + syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3 + syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4 + syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5 + syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6 + syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7 + syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8 + syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9 + syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0 endif syn match factorBracketErr /\<\]\>/ @@ -160,11 +180,21 @@ if version >= 508 || !exists("did_factor_syn_inits") HiLink factorKeyword Keyword HiLink factorOperator Operator HiLink factorBoolean Boolean - HiLink factorDefinition Typedef + HiLink factorDefnDelims Typedef + HiLink factorMethodDelims Typedef + HiLink factorGenericDelims Typedef + HiLink factorGenericNDelims Typedef + HiLink factorConstructor Typedef + HiLink factorPrivate Special + HiLink factorPrivateDefnDelims Special + HiLink factorPrivateMethodDelims Special + HiLink factorPGenericDelims Special + HiLink factorPGenericNDelims Special HiLink factorString String HiLink factorSbuf String + HiLink factorMultiStringContents String + HiLink factorMultiStringDelims Typedef HiLink factorBracketErr Error - HiLink factorStackEffectErr Error HiLink factorComplex Number HiLink factorRatio Number HiLink factorBinary Number @@ -183,14 +213,17 @@ if version >= 508 || !exists("did_factor_syn_inits") HiLink factorCharErr Error HiLink factorDelimiter Delimiter HiLink factorBackslash Special - HiLink factorCompileDirective Keyword + HiLink factorCompileDirective Typedef HiLink factorSymbol Define + HiLink factorMixin Typedef + HiLink factorInstance Typedef + HiLink factorHook Typedef + HiLink factorMain Define HiLink factorPostpone Define HiLink factorDefer Define HiLink factorForget Define HiLink factorAlien Define HiLink factorTuple Typedef - HiLink factorGeneric Define if &bg == "dark" hi hlLevel0 ctermfg=red guifg=red1 From 4a4aeb821e96bfb68f5520310af40c382e2c5e2a Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 13 Mar 2008 15:22:16 +1100 Subject: [PATCH 05/83] semantic-db: got rid of uniq in favour of prune --- extra/semantic-db/hierarchy/hierarchy.factor | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor index 7d5f976909..7465d67664 100644 --- a/extra/semantic-db/hierarchy/hierarchy.factor +++ b/extra/semantic-db/hierarchy/hierarchy.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors db.tuples kernel new-slots semantic-db -semantic-db.relations sorting sequences sequences.deep ; +USING: accessors db.tuples hashtables kernel new-slots +semantic-db semantic-db.relations sorting sequences ; IN: semantic-db.hierarchy TUPLE: tree id children ; @@ -34,9 +34,6 @@ C: tree : get-node-hierarchy ( node-id -- tree ) dup children [ get-node-hierarchy ] map ; -: uniq ( sorted-seq -- seq ) - f swap [ tuck = not ] subset nip ; - : (get-root-nodes) ( node-id -- root-nodes/node-id ) dup parents dup empty? [ drop @@ -45,4 +42,4 @@ C: tree ] if ; : get-root-nodes ( node-id -- root-nodes ) - (get-root-nodes) flatten natural-sort uniq ; + (get-root-nodes) flatten prune ; From 88c0ca84ef4145b7825c53843d039889a145984d Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 13 Mar 2008 15:41:51 +1100 Subject: [PATCH 06/83] semantic-db: fix a unit test and USE a missing vocab --- extra/semantic-db/hierarchy/hierarchy.factor | 2 +- extra/semantic-db/semantic-db-tests.factor | 9 +++++---- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor index 7465d67664..be0789ba5e 100644 --- a/extra/semantic-db/hierarchy/hierarchy.factor +++ b/extra/semantic-db/hierarchy/hierarchy.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. USING: accessors db.tuples hashtables kernel new-slots -semantic-db semantic-db.relations sorting sequences ; +semantic-db semantic-db.relations sequences sequences.deep ; IN: semantic-db.hierarchy TUPLE: tree id children ; diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 6c2c4d3e9e..257133c67f 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -1,6 +1,7 @@ -USING: accessors arrays continuations db db.sqlite db.tuples io.files -kernel math namespaces semantic-db semantic-db.context -semantic-db.hierarchy semantic-db.relations sequences tools.test +USING: accessors arrays continuations db db.sqlite +db.tuples io.files kernel math namespaces semantic-db +semantic-db.context semantic-db.hierarchy +semantic-db.relations sequences sorting tools.test tools.walker ; IN: semantic-db.tests @@ -63,7 +64,7 @@ test-db [ [ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test [ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test [ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test - [ { "adam" "eve" } ] [ "charlie" get get-root-nodes [ node-content ] map ] unit-test + [ { "adam" "eve" } ] [ "charlie" get get-root-nodes [ node-content ] map natural-sort >array ] unit-test [ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test ] with-context ] with-db From 4398458248233f4bbeb1236f8ab91d11d0136a74 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 12 Mar 2008 23:57:56 -0500 Subject: [PATCH 07/83] add ensure-table --- extra/db/tuples/tuples-tests.factor | 10 ++++++---- extra/db/tuples/tuples.factor | 6 +++++- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 584282e1c8..4c47066d35 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -30,9 +30,11 @@ SYMBOL: person3 SYMBOL: person4 : test-tuples ( -- ) - [ person drop-table ] [ drop ] recover + [ ] [ person ensure-table ] unit-test + [ ] [ person drop-table ] unit-test [ ] [ person create-table ] unit-test [ person create-table ] must-fail + [ ] [ person ensure-table ] unit-test [ ] [ person1 get insert-tuple ] unit-test @@ -191,8 +193,8 @@ TUPLE: annotation n paste-id summary author mode contents ; [ native-person-schema test-tuples ] test-sqlite [ assigned-person-schema test-tuples ] test-sqlite -[ native-person-schema test-tuples ] test-postgresql -[ assigned-person-schema test-tuples ] test-postgresql +! [ native-person-schema test-tuples ] test-postgresql +! [ assigned-person-schema test-tuples ] test-postgresql TUPLE: serialize-me id data ; @@ -211,7 +213,7 @@ TUPLE: serialize-me id data ; ] [ T{ serialize-me f 1 } select-tuples ] unit-test ; [ test-serialize ] test-sqlite -[ test-serialize ] test-postgresql +! [ test-serialize ] test-postgresql TUPLE: exam id name score ; diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 32055ccedc..82147a2efa 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -3,7 +3,8 @@ USING: arrays assocs classes db kernel namespaces tuples words sequences slots math math.parser io prettyprint db.types continuations -mirrors sequences.lib tools.walker combinators.lib ; +mirrors sequences.lib tools.walker combinators.lib +combinators.cleave ; IN: db.tuples : define-persistent ( class table columns -- ) @@ -73,6 +74,9 @@ HOOK: insert-tuple* db ( tuple statement -- ) : drop-table ( class -- ) drop-sql-statement [ execute-statement ] with-disposals ; +: ensure-table ( class -- ) + [ dup drop-table ] ignore-errors create-table ; + : insert-native ( tuple -- ) dup class db get db-insert-statements [ ] cache From c3d41967f7433002dff0b9b145ee824fcc21f888 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 13 Mar 2008 02:10:43 -0500 Subject: [PATCH 08/83] fix some formatting --- extra/db/sqlite/lib/lib.factor | 15 ++++----------- extra/db/sqlite/sqlite.factor | 35 ++++++++++------------------------ 2 files changed, 14 insertions(+), 36 deletions(-) diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index dbada854fb..d630522eb8 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -102,17 +102,10 @@ IN: db.sqlite.lib [ no-sql-type ] } case ; -: sqlite-finalize ( handle -- ) - sqlite3_finalize sqlite-check-result ; - -: sqlite-reset ( handle -- ) - sqlite3_reset sqlite-check-result ; - -: sqlite-#columns ( query -- int ) - sqlite3_column_count ; - -: sqlite-column ( handle index -- string ) - sqlite3_column_text ; +: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ; +: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ; +: sqlite-#columns ( query -- int ) sqlite3_column_count ; +: sqlite-column ( handle index -- string ) sqlite3_column_text ; : sqlite-column-blob ( handle index -- byte-array/f ) [ sqlite3_column_bytes ] 2keep diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index b72d788605..9a9db74401 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -17,16 +17,11 @@ M: sqlite-db db-open ( db -- ) dup sqlite-db-path sqlite-open swap set-delegate ; -M: sqlite-db db-close ( handle -- ) - sqlite-close ; - +M: sqlite-db db-close ( handle -- ) sqlite-close ; M: sqlite-db dispose ( db -- ) dispose-db ; - -: with-sqlite ( path quot -- ) - sqlite-db swap with-db ; inline +: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline TUPLE: sqlite-statement ; - TUPLE: sqlite-result-set has-more? ; M: sqlite-db ( str in out -- obj ) @@ -51,8 +46,7 @@ M: sqlite-result-set dispose ( result-set -- ) : sqlite-bind ( triples handle -- ) swap [ first3 sqlite-bind-type ] with each ; -: reset-statement ( statement -- ) - statement-handle sqlite-reset ; +: reset-statement ( statement -- ) statement-handle sqlite-reset ; M: sqlite-statement bind-statement* ( statement -- ) dup statement-bound? [ dup reset-statement ] when @@ -98,14 +92,9 @@ M: sqlite-statement query-results ( query -- result-set ) dup statement-handle sqlite-result-set dup advance-row ; -M: sqlite-db begin-transaction ( -- ) - "BEGIN" sql-command ; - -M: sqlite-db commit-transaction ( -- ) - "COMMIT" sql-command ; - -M: sqlite-db rollback-transaction ( -- ) - "ROLLBACK" sql-command ; +M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; +M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ; +M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; : sqlite-make ( class quot -- ) >r sql-props r> @@ -123,9 +112,7 @@ M: sqlite-db create-sql-statement ( class -- statement ) ] sqlite-make ; M: sqlite-db drop-sql-statement ( class -- statement ) - [ - "drop table " 0% 0% ";" 0% drop - ] sqlite-make ; + [ "drop table " 0% 0% ";" 0% drop ] sqlite-make ; M: sqlite-db ( tuple -- statement ) [ @@ -195,10 +182,9 @@ M: sqlite-db modifier-table ( -- hashtable ) { +not-null+ "not null" } } ; -M: sqlite-db compound-modifier ( str obj -- newstr ) - compound-type ; +M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ; -M: sqlite-db compound-type ( str seq -- newstr ) +M: sqlite-db compound-type ( str seq -- str' ) over { { "default" [ first number>string join-space ] } [ 2drop ] ! "no sqlite compound data type" 3array throw ] @@ -219,5 +205,4 @@ M: sqlite-db type-table ( -- assoc ) { FACTOR-BLOB "blob" } } ; -M: sqlite-db create-type-table - type-table ; +M: sqlite-db create-type-table ( symbol -- str ) type-table ; From d5572b62181e83599f048dc76b51474aae279da8 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 13 Mar 2008 01:43:30 -0600 Subject: [PATCH 09/83] io.files-docs: add some file-info docs --- core/io/files/files-docs.factor | 41 +++++++++++++++++++++++++-------- 1 file changed, 32 insertions(+), 9 deletions(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 1ff972b505..6eb025b6fd 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -1,5 +1,5 @@ -USING: help.markup help.syntax io io.styles strings -io.backend io.files.private quotations ; +USING: help.markup help.syntax io io.styles strings calendar + io.backend io.files.private quotations ; IN: io.files ARTICLE: "file-streams" "Reading and writing files" @@ -43,12 +43,18 @@ ARTICLE: "directories" "Directories" { $subsection make-directory } { $subsection make-directories } ; +! ARTICLE: "file-types" "File Types" + +! { $table { +directory+ "" } } + +! ; + ARTICLE: "fs-meta" "File meta-data" + { $subsection file-info } { $subsection link-info } { $subsection exists? } { $subsection directory? } -{ $subsection file-length } { $subsection file-modified } { $subsection stat } ; @@ -119,11 +125,26 @@ HELP: file-name ! need a $class-description file-info HELP: file-info + { $values { "path" "a pathname string" } - { "info" "a file-info tuple" } } + { "info" file-info } } { $description "Queries the file system for meta data. " "If path refers to a symbolic link, it is followed." - "If the file does not exist, an exception is thrown." } ; + "If the file does not exist, an exception is thrown." } + + { $class-description "File meta data" } + + { $table + { "type" { "One of the following:" + { $list { $link +regular-file+ } + { $link +directory+ } + { $link +symbolic-link+ } } } } + + { "size" "Size of the file in bytes" } + { "modified" { "Last modification " { $link timestamp } } } } + + ; + ! need a see also to link-info HELP: link-info @@ -135,6 +156,8 @@ HELP: link-info "If the file does not exist, an exception is thrown." } ; ! need a see also to file-info +{ file-info link-info } related-words + HELP: { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } } { "stream" "an input stream" } } @@ -199,7 +222,7 @@ HELP: stat ( path -- directory? permissions length modified ) "Queries the file system for file meta data. If the file does not exist, outputs " { $link f } " for all four values." } ; -{ stat exists? directory? file-length file-modified } related-words +{ stat exists? directory? file-modified } related-words HELP: path+ { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } @@ -227,9 +250,9 @@ HELP: directory* { $description "Outputs the contents of a directory named by " { $snippet "path" } "." } { $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ; -HELP: file-length -{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } } -{ $description "Outputs the length of the file in bytes, or " { $link f } " if it does not exist." } ; +! HELP: file-length +! { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } } +! { $description "Outputs the length of the file in bytes, or " { $link f } " if it does not exist." } ; HELP: file-modified { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } } From ce8828e00736299daac95a30a8f65e76a54b2c65 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 13 Mar 2008 01:47:39 -0600 Subject: [PATCH 10/83] io.files-docs: fix bug --- core/io/files/files-docs.factor | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 6eb025b6fd..55458b96b8 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -141,7 +141,7 @@ HELP: file-info { $link +symbolic-link+ } } } } { "size" "Size of the file in bytes" } - { "modified" { "Last modification " { $link timestamp } } } } + { "modified" "Last modification timestamp." } } ; @@ -250,10 +250,6 @@ HELP: directory* { $description "Outputs the contents of a directory named by " { $snippet "path" } "." } { $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ; -! HELP: file-length -! { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } } -! { $description "Outputs the length of the file in bytes, or " { $link f } " if it does not exist." } ; - HELP: file-modified { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } } { $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ; From 979a81a25d0c509aac01fa601fb7fe4d3efaf21a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 13 Mar 2008 01:48:11 -0600 Subject: [PATCH 11/83] io.files-docs: fix another bug (reference to calendar which is in extra) --- core/io/files/files-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 55458b96b8..a6dd1e0818 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io io.styles strings calendar +USING: help.markup help.syntax io io.styles strings io.backend io.files.private quotations ; IN: io.files From c3391ac0ae1b6420a6b37f55fab5b77a4b2ee759 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 13 Mar 2008 01:49:21 -0600 Subject: [PATCH 12/83] Remove file-length --- core/io/files/files.factor | 2 +- extra/ui/freetype/freetype.factor | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index cbb6e77ff9..104c38518a 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -220,7 +220,7 @@ M: pathname <=> [ pathname-string ] compare ; >r r> with-stream ; inline : file-contents ( path encoding -- str ) - dupd [ file-length read ] with-file-reader ; + dupd [ file-info file-info-size read ] with-file-reader ; : with-file-writer ( path encoding quot -- ) >r r> with-stream ; inline diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 8078ec4a33..8dca72c29e 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -4,6 +4,7 @@ USING: alien alien.accessors alien.c-types arrays io kernel libc math math.vectors namespaces opengl opengl.gl prettyprint assocs sequences io.files io.styles continuations freetype ui.gadgets.worlds ui.render ui.backend byte-arrays ; + IN: ui.freetype TUPLE: freetype-renderer ; @@ -74,7 +75,7 @@ M: freetype-renderer free-fonts ( world -- ) : open-face ( font style -- face ) ttf-name ttf-path dup malloc-file-contents - swap file-length + swap file-info file-info-size (open-face) ; SYMBOL: dpi From f341b2a02c7d1ae749ce36b389a241e497d889b1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:35:54 -0500 Subject: [PATCH 13/83] Clean up tools.vocabs a bit --- extra/benchmark/benchmark.factor | 14 +++++++------- extra/editors/editors.factor | 3 +-- extra/tools/vocabs/vocabs.factor | 10 +++++----- 3 files changed, 13 insertions(+), 14 deletions(-) diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index 7eb5f10276..26f1a9e96d 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -2,27 +2,27 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel vocabs vocabs.loader tools.time tools.vocabs arrays assocs io.styles io help.markup prettyprint sequences -continuations debugger ; +continuations debugger combinators.cleave ; IN: benchmark : run-benchmark ( vocab -- result ) - [ dup require [ run ] benchmark ] [ error. drop f f ] recover 2array ; + [ [ require ] [ [ run ] benchmark nip ] bi ] curry + [ error. f ] recover ; : run-benchmarks ( -- assoc ) - "benchmark" all-child-vocabs values concat [ vocab-name ] map + "benchmark" all-child-vocabs-seq [ dup run-benchmark ] { } map>assoc ; : benchmarks. ( assoc -- ) standard-table-style [ [ [ "Benchmark" write ] with-cell - [ "Run time (ms)" write ] with-cell - [ "GC time (ms)" write ] with-cell + [ "Time (ms)" write ] with-cell ] with-row [ [ - swap [ dup ($vocab-link) ] with-cell - first2 pprint-cell pprint-cell + [ [ 1array $vocab-link ] with-cell ] + [ pprint-cell ] bi* ] with-row ] assoc-each ] tabular-output ; diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index bb3fd05400..4ee906bccb 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -13,8 +13,7 @@ M: no-edit-hook summary SYMBOL: edit-hook : available-editors ( -- seq ) - "editors" all-child-vocabs - values concat [ vocab-name ] map ; + "editors" all-child-vocabs-seq [ vocab-name ] map ; : editor-restarts ( -- alist ) available-editors diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index ba6baa543f..21b8da8910 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -210,11 +210,11 @@ MEMO: all-vocabs-seq ( -- seq ) ] { } map>assoc f rot unrooted-child-vocabs 2array add ; -: load-children ( prefix -- ) - all-child-vocabs values concat - filter-dangerous - require-all - load-failures. ; +: all-child-vocabs-seq ( prefix -- assoc ) + vocab-roots get swap [ + dupd (all-child-vocabs) + [ vocab-dir? ] with subset + ] curry map concat ; : map>set ( seq quot -- ) map concat prune natural-sort ; inline From 37d5ca384ec8382b4e7fdfefe13d4dcb3d5c06aa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:36:13 -0500 Subject: [PATCH 14/83] Clean up cross product --- extra/math/matrices/matrices.factor | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) mode change 100644 => 100755 extra/math/matrices/matrices.factor diff --git a/extra/math/matrices/matrices.factor b/extra/math/matrices/matrices.factor old mode 100644 new mode 100755 index df9a87fb40..e74ffc64d2 --- a/extra/math/matrices/matrices.factor +++ b/extra/math/matrices/matrices.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel sequences math math.functions -math.vectors ; +math.vectors combinators.cleave ; IN: math.matrices ! Matrices @@ -33,23 +33,22 @@ IN: math.matrices : mmax ( m -- n ) >r -1/0. r> [ [ max ] each ] each ; : mnorm ( m -- n ) dup mmax abs m/n ; -: cross-i ( vec1 vec2 -- i ) - over third over second * >r - swap second swap third * r> - ; +r - swap third swap first * r> - ; +: x first ; inline +: y second ; inline +: z third ; inline -: cross-k ( vec1 vec2 -- k ) - over first over second * >r - swap second swap first * r> - ; +: i [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ; +: j [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ; +: k [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ; -: cross ( vec1 vec2 -- vec3 ) - [ cross-i ] 2keep [ cross-j ] 2keep cross-k 3array ; +PRIVATE> + +: cross ( vec1 vec2 -- vec3 ) [ i ] [ j ] [ k ] 2tri 3array ; : proj ( v u -- w ) - [ [ v. ] keep norm-sq / ] keep n*v ; + [ [ v. ] [ norm-sq ] bi / ] keep n*v ; : (gram-schmidt) ( v seq -- newseq ) [ dupd proj v- ] each ; From b95d5beba165923082f4be3fdb25f34bab2a8b33 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:38:01 -0500 Subject: [PATCH 15/83] Fix erronous stack comment in fasta --- extra/benchmark/fasta/fasta.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) mode change 100644 => 100755 extra/benchmark/fasta/fasta.factor diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor old mode 100644 new mode 100755 index 3c9c78d358..30c3beb1ef --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -51,7 +51,7 @@ HINTS: random fixnum ; dup keys >byte-array swap values >float-array unclip [ + ] accumulate swap add ; -:: select-random ( seed chars floats -- elt ) +:: select-random ( seed chars floats -- seed elt ) floats seed random -rot [ >= ] curry find drop chars nth-unsafe ; inline @@ -71,7 +71,7 @@ HINTS: random fixnum ; write-description [ make-random-fasta ] 2curry split-lines ; inline -:: make-repeat-fasta ( k len alu -- ) +:: make-repeat-fasta ( k len alu -- k' ) [let | kn [ alu length ] | len [ k + kn mod alu nth-unsafe ] B{ } map-as print k len + From dec21de6c3dd1c7d04978fa456bbd9a4281f6b05 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:38:11 -0500 Subject: [PATCH 16/83] Load vocab browser --- extra/bootstrap/tools/tools.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/bootstrap/tools/tools.factor b/extra/bootstrap/tools/tools.factor index f395a903c3..0bf7a032ee 100755 --- a/extra/bootstrap/tools/tools.factor +++ b/extra/bootstrap/tools/tools.factor @@ -12,5 +12,6 @@ USING: vocabs.loader sequences ; "tools.time" "tools.threads" "tools.vocabs" + "tools.vocabs.browser" "editors" } [ require ] each From 618962aa7128b0c52a15f083110f2734f5dea3f8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:39:05 -0500 Subject: [PATCH 17/83] Fix minor bunny bug --- extra/bunny/deploy.factor | 14 ++++++++------ extra/bunny/outlined/outlined.factor | 6 +++--- extra/opengl/demo-support/demo-support.factor | 13 +++++++------ 3 files changed, 18 insertions(+), 15 deletions(-) mode change 100644 => 100755 extra/bunny/outlined/outlined.factor mode change 100644 => 100755 extra/opengl/demo-support/demo-support.factor diff --git a/extra/bunny/deploy.factor b/extra/bunny/deploy.factor index 12aaffc19c..a3f6174726 100755 --- a/extra/bunny/deploy.factor +++ b/extra/bunny/deploy.factor @@ -1,12 +1,14 @@ USING: tools.deploy.config ; -V{ +H{ + { deploy-math? t } + { deploy-reflection 1 } + { deploy-name "Bunny" } + { deploy-threads? t } + { deploy-word-props? f } + { "stop-after-last-window?" t } { deploy-ui? t } { deploy-io 3 } - { deploy-reflection 1 } { deploy-compiler? t } - { deploy-math? t } - { deploy-word-props? f } + { deploy-word-defs? f } { deploy-c-types? f } - { "stop-after-last-window?" t } - { deploy-name "Bunny" } } diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor old mode 100644 new mode 100755 index d7064ebdde..012aa1fd78 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -1,7 +1,7 @@ USING: arrays bunny.model bunny.cel-shaded combinators.lib continuations kernel math multiline opengl opengl.shaders opengl.framebuffers opengl.gl -opengl.capabilities sequences ui.gadgets ; +opengl.capabilities sequences ui.gadgets combinators.cleave ; IN: bunny.outlined STRING: outlined-pass1-fragment-shader-main-source @@ -177,7 +177,7 @@ TUPLE: bunny-outlined [ bunny-outlined-normal-texture [ delete-texture ] when* ] [ bunny-outlined-depth-texture [ delete-texture ] when* ] [ f swap set-bunny-outlined-framebuffer-dim ] - } call-with + } cleave ] [ drop ] if ; : remake-framebuffer-if-needed ( draw -- ) @@ -237,4 +237,4 @@ M: bunny-outlined dispose [ bunny-outlined-pass1-program [ delete-gl-program ] when* ] [ bunny-outlined-pass2-program [ delete-gl-program ] when* ] [ dispose-framebuffer ] - } call-with ; + } cleave ; diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor old mode 100644 new mode 100755 index 59b7a3bcc3..8fee55962f --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -1,5 +1,5 @@ USING: arrays combinators.lib kernel math math.functions math.vectors namespaces - opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ; + opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render combinators.cleave ; IN: opengl.demo-support : NEAR-PLANE 1.0 64.0 / ; inline @@ -47,14 +47,15 @@ M: demo-gadget pref-dim* ( gadget -- dim ) GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear GL_MODELVIEW glMatrixMode glLoadIdentity - { [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ] - [ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ] - [ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] } call-with ; + [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ] + [ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ] + [ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] + tri ; : reset-last-drag-rel ( -- ) - { 0 0 } last-drag-loc set ; + { 0 0 } last-drag-loc set-global ; : last-drag-rel ( -- rel ) - drag-loc [ last-drag-loc get v- ] keep last-drag-loc set ; + drag-loc [ last-drag-loc get v- ] keep last-drag-loc set-global ; : drag-yaw-pitch ( -- yaw pitch ) last-drag-rel MOUSE-MOTION-SCALE v*n first2 ; From fd9bf040baa678235d44c71353b38d950971e77d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:41:57 -0500 Subject: [PATCH 18/83] Removing call-with call-with2; use cleave instead --- extra/combinators/cleave/cleave.factor | 3 ++ extra/combinators/lib/lib.factor | 6 --- extra/io/windows/files/files.factor | 47 ++++++++++------------- extra/io/windows/launcher/launcher.factor | 14 +++---- extra/opengl/shaders/shaders.factor | 4 +- 5 files changed, 32 insertions(+), 42 deletions(-) mode change 100644 => 100755 extra/combinators/cleave/cleave.factor mode change 100644 => 100755 extra/io/windows/files/files.factor mode change 100644 => 100755 extra/opengl/shaders/shaders.factor diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor old mode 100644 new mode 100755 index 5359512610..383d5ca9ac --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -17,6 +17,9 @@ IN: combinators.cleave : 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline +: 2tri ( obj obj quot quot quot -- val val val ) + >r >r 2keep r> 2keep r> call ; inline + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! General cleave diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index f65b94dc11..7c93f805cd 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -133,9 +133,6 @@ MACRO: parallel-call ( quots -- ) : (make-call-with) ( quots -- quot ) [ [ keep ] curry ] map concat [ drop ] append ; -MACRO: call-with ( quots -- ) - (make-call-with) ; - MACRO: map-call-with ( quots -- ) [ (make-call-with) ] keep length [ narray ] curry compose ; @@ -143,9 +140,6 @@ MACRO: map-call-with ( quots -- ) [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat [ 2drop ] append ; -MACRO: call-with2 ( quots -- ) - (make-call-with2) ; - MACRO: map-call-with2 ( quots -- ) [ (make-call-with2) ] keep length [ narray ] curry append ; diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor old mode 100644 new mode 100755 index 3d51e65116..2180ff7901 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -3,7 +3,7 @@ USING: alien.c-types io.files io.windows kernel math windows windows.kernel32 combinators.cleave windows.time calendar combinators math.functions -sequences combinators.lib namespaces words symbols ; +sequences namespaces words symbols ; IN: io.windows.files SYMBOLS: +read-only+ +hidden+ +system+ @@ -11,34 +11,27 @@ SYMBOLS: +read-only+ +hidden+ +system+ +sparse-file+ +reparse-point+ +compressed+ +offline+ +not-content-indexed+ +encrypted+ ; -: expand-constants ( word/obj -- obj'/obj ) - dup word? [ execute ] when ; - -: get-flags ( n seq -- seq' ) - [ - [ - first2 expand-constants - [ swapd mask? [ , ] [ drop ] if ] 2curry - ] map call-with - ] { } make ; +: win32-file-attribute ( n attr symbol -- n ) + >r dupd mask? [ r> , ] [ r> drop ] if ; : win32-file-attributes ( n -- seq ) - { - { +read-only+ FILE_ATTRIBUTE_READONLY } - { +hidden+ FILE_ATTRIBUTE_HIDDEN } - { +system+ FILE_ATTRIBUTE_SYSTEM } - { +directory+ FILE_ATTRIBUTE_DIRECTORY } - { +archive+ FILE_ATTRIBUTE_ARCHIVE } - { +device+ FILE_ATTRIBUTE_DEVICE } - { +normal+ FILE_ATTRIBUTE_NORMAL } - { +temporary+ FILE_ATTRIBUTE_TEMPORARY } - { +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE } - { +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT } - { +compressed+ FILE_ATTRIBUTE_COMPRESSED } - { +offline+ FILE_ATTRIBUTE_OFFLINE } - { +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED } - { +encrypted+ FILE_ATTRIBUTE_ENCRYPTED } - } get-flags ; + [ + FILE_ATTRIBUTE_READONLY +read-only+ win32-file-attribute + FILE_ATTRIBUTE_HIDDEN +hidden+ win32-file-attribute + FILE_ATTRIBUTE_SYSTEM +system+ win32-file-attribute + FILE_ATTRIBUTE_DIRECTORY +directory+ win32-file-attribute + FILE_ATTRIBUTE_ARCHIVE +archive+ win32-file-attribute + FILE_ATTRIBUTE_DEVICE +device+ win32-file-attribute + FILE_ATTRIBUTE_NORMAL +normal+ win32-file-attribute + FILE_ATTRIBUTE_TEMPORARY +temporary+ win32-file-attribute + FILE_ATTRIBUTE_SPARSE_FILE +sparse-file+ win32-file-attribute + FILE_ATTRIBUTE_REPARSE_POINT +reparse-point+ win32-file-attribute + FILE_ATTRIBUTE_COMPRESSED +compressed+ win32-file-attribute + FILE_ATTRIBUTE_OFFLINE +offline+ win32-file-attribute + FILE_ATTRIBUTE_NOT_CONTENT_INDEXED +not-content-indexed+ win32-file-attribute + FILE_ATTRIBUTE_ENCRYPTED +encrypted+ win32-file-attribute + drop + ] { } make ; : win32-file-type ( n -- symbol ) FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ; diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index b09d867e10..3e49f1dc10 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -5,7 +5,7 @@ io.windows io.windows.nt.pipes libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system threads init strings combinators -io.backend new-slots accessors ; +io.backend new-slots accessors concurrency.flags ; IN: io.windows.launcher TUPLE: CreateProcess-args @@ -137,18 +137,18 @@ M: windows-io kill-process* ( handle -- ) dup HEX: ffffffff = [ win32-error ] when dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ; +SYMBOL: wait-flag + : wait-loop ( -- ) processes get dup assoc-empty? - [ drop f sleep-until ] + [ drop wait-flag get-global lower-flag ] [ wait-for-processes [ 100 sleep ] when ] if ; -SYMBOL: wait-thread - : start-wait-thread ( -- ) - [ wait-loop t ] "Process wait" spawn-server - wait-thread set-global ; + wait-flag set-global + [ wait-loop t ] "Process wait" spawn-server drop ; M: windows-io register-process - drop wait-thread get-global interrupt ; + drop wait-flag get-global raise-flag ; [ start-wait-thread ] "io.windows.launcher" add-init-hook diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor old mode 100644 new mode 100755 index fbbc4c496a..ceda434c75 --- a/extra/opengl/shaders/shaders.factor +++ b/extra/opengl/shaders/shaders.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel opengl.gl alien.c-types continuations namespaces assocs alien libc opengl math sequences combinators.lib -macros arrays ; +macros arrays combinators.cleave ; IN: opengl.shaders : with-gl-shader-source-ptr ( string quot -- ) @@ -117,7 +117,7 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ; : (make-with-gl-program) ( uniforms quot -- q ) [ \ dup , - [ swap (with-gl-program-uniforms) , \ call-with , % ] + [ swap (with-gl-program-uniforms) , \ cleave , % ] [ ] make , \ (with-gl-program) , ] [ ] make ; From 0ed8bfe276636364834be5b52f6953b0878a6b8e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:44:58 -0500 Subject: [PATCH 19/83] Documentation updates --- core/compiler/errors/errors-docs.factor | 2 +- core/source-files/source-files-docs.factor | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/core/compiler/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor index 6cce72eed0..dd71eb704f 100755 --- a/core/compiler/errors/errors-docs.factor +++ b/core/compiler/errors/errors-docs.factor @@ -9,7 +9,7 @@ ARTICLE: "compiler-errors" "Compiler warnings and errors" { $subsection :errors } { $subsection :warnings } { $subsection :linkage } -"Words such as " { $link require } " and " { $link refresh-all } " use a combinator which counts errors and prints a report at the end:" +"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:" { $link with-compiler-errors } ; HELP: compiler-errors diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor index 2371c27e52..31c2defd19 100755 --- a/core/source-files/source-files-docs.factor +++ b/core/source-files/source-files-docs.factor @@ -3,7 +3,7 @@ definitions quotations compiler.units ; IN: source-files ARTICLE: "source-files" "Source files" -"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement features such as " { $link refresh-all } "." +"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement " { $link "tools.vocabs" } "." $nl "The source file database:" { $subsection source-files } @@ -75,7 +75,7 @@ HELP: record-form $low-level-note ; HELP: reset-checksums -{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link refresh } "." } ; +{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "tools.vocabs" } "." } ; HELP: forget-source { $values { "path" "a pathname string" } } From cb2863ea5f566f62beda44c9a791c6727ac62055 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:45:08 -0500 Subject: [PATCH 20/83] Add tools.vocabs to default using --- core/parser/parser.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 81c9b68668..cc28f09855 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -416,6 +416,7 @@ SYMBOL: interactive-vocabs "tools.test" "tools.threads" "tools.time" + "tools.vocabs" "vocabs" "vocabs.loader" "words" From 5d1dbeeaf67de3302c6ddcc5422271820aa81145 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:45:34 -0500 Subject: [PATCH 21/83] Help updates --- extra/help/markup/markup.factor | 3 ++- extra/help/tutorial/tutorial.factor | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index d81e9cd81e..710671857e 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -169,7 +169,8 @@ M: f print-element drop ; ] if ] ($subsection) ; -: $vocab-link ( element -- ) first dup ($vocab-link) ; +: $vocab-link ( element -- ) + first dup vocab-name swap ($vocab-link) ; : $vocabulary ( element -- ) first word-vocabulary [ diff --git a/extra/help/tutorial/tutorial.factor b/extra/help/tutorial/tutorial.factor index f6b1faf385..f01840d927 100755 --- a/extra/help/tutorial/tutorial.factor +++ b/extra/help/tutorial/tutorial.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax ui.commands ui.operations ui.tools.search ui.tools.workspace editors vocabs.loader -kernel sequences prettyprint tools.test strings +kernel sequences prettyprint tools.test tools.vocabs strings unicode.categories unicode.case ; IN: help.tutorial From cf4dee6e0fd14de3ff83aa55e495622ddf8c8eb0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:46:25 -0500 Subject: [PATCH 22/83] Tree-shaker now computes which globals it needs to strip, not which ones it needs to keep --- extra/tools/deploy/backend/backend.factor | 48 +++--- extra/tools/deploy/config/config.factor | 2 +- extra/tools/deploy/deploy-tests.factor | 24 ++- extra/tools/deploy/shaker/shaker.factor | 190 ++++++++++++++-------- extra/tools/deploy/test/1/1.factor | 6 + extra/tools/deploy/test/1/deploy.factor | 14 ++ extra/tools/deploy/test/2/2.factor | 6 + extra/tools/deploy/test/2/deploy.factor | 14 ++ extra/tools/deploy/test/3/3.factor | 8 + extra/tools/deploy/test/3/deploy.factor | 14 ++ 10 files changed, 237 insertions(+), 89 deletions(-) create mode 100755 extra/tools/deploy/test/1/1.factor create mode 100755 extra/tools/deploy/test/1/deploy.factor create mode 100755 extra/tools/deploy/test/2/2.factor create mode 100755 extra/tools/deploy/test/2/deploy.factor create mode 100755 extra/tools/deploy/test/3/3.factor create mode 100755 extra/tools/deploy/test/3/deploy.factor diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 301ffa3378..15dc32115e 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -34,31 +34,33 @@ IN: tools.deploy.backend : ?, [ , ] [ drop ] if ; -: bootstrap-profile ( config -- profile ) +: bootstrap-profile ( -- profile ) [ - [ - "math" deploy-math? get ?, - "compiler" deploy-compiler? get ?, - "ui" deploy-ui? get ?, - "io" native-io? ?, - ] { } make - ] bind ; + "math" deploy-math? get ?, + "compiler" deploy-compiler? get ?, + "ui" deploy-ui? get ?, + "io" native-io? ?, + ] { } make ; -: staging-image-name ( profile -- name ) - "staging." swap bootstrap-profile "-" join ".image" 3append ; +: staging-image-name ( -- name ) + "staging." + bootstrap-profile strip-word-names? [ "strip" add ] when + "-" join ".image" 3append ; : staging-command-line ( config -- flags ) [ - "-i=" my-boot-image-name append , + [ + "-i=" my-boot-image-name append , - "-output-image=" over staging-image-name append , + "-output-image=" staging-image-name append , - "-include=" swap bootstrap-profile " " join append , + "-include=" bootstrap-profile " " join append , - "-no-stack-traces" , + strip-word-names? [ "-no-stack-traces" , ] when - "-no-user-init" , - ] { } make ; + "-no-user-init" , + ] { } make + ] bind ; : run-factor ( vm flags -- ) swap add* dup . run-with-output ; inline @@ -68,16 +70,18 @@ IN: tools.deploy.backend : deploy-command-line ( image vocab config -- flags ) [ - "-i=" swap staging-image-name append , + [ + "-i=" staging-image-name append , - "-run=tools.deploy.shaker" , + "-run=tools.deploy.shaker" , - "-deploy-vocab=" swap append , + "-deploy-vocab=" swap append , - "-output-image=" swap append , + "-output-image=" swap append , - "-no-stack-traces" , - ] { } make ; + strip-word-names? [ "-no-stack-traces" , ] when + ] { } make + ] bind ; : make-deploy-image ( vm image vocab config -- ) make-boot-image diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor index 64f863b730..78f1d487de 100755 --- a/extra/tools/deploy/config/config.factor +++ b/extra/tools/deploy/config/config.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: vocabs.loader io.files io kernel sequences assocs splitting parser prettyprint namespaces math vocabs -hashtables tools.browser ; +hashtables tools.vocabs ; IN: tools.deploy.config SYMBOL: deploy-name diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index d473d8f640..0f770f7b60 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -5,7 +5,7 @@ tools.deploy.backend math ; : shake-and-bake "." resource-path [ vm - "hello.image" temp-file + "test.image" temp-file rot dup deploy-config make-deploy-image ] with-directory ; @@ -15,8 +15,30 @@ tools.deploy.backend math ; "hello.image" temp-file file-length 500000 <= ] unit-test +[ ] [ "sudoku" shake-and-bake ] unit-test + +[ t ] [ + "hello.image" temp-file file-length 1500000 <= +] unit-test + [ ] [ "hello-ui" shake-and-bake ] unit-test [ t ] [ "hello.image" temp-file file-length 2000000 <= ] unit-test + +[ ] [ "bunny" shake-and-bake ] unit-test + +[ t ] [ + "hello.image" temp-file file-length 3000000 <= +] unit-test + +[ ] [ + "tools.deploy.test.1" shake-and-bake + vm "-i=" "test.image" temp-file append try-process +] unit-test + +[ ] [ + "tools.deploy.test.2" shake-and-bake + vm "-i=" "test.image" temp-file append try-process +] unit-test diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 0ddc2d5707..bddf3d76c9 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -1,11 +1,29 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces continuations.private kernel.private init -assocs kernel vocabs words sequences memory io system arrays -continuations math definitions mirrors splitting parser classes -inspector layouts vocabs.loader prettyprint.config prettyprint -debugger io.streams.c io.streams.duplex io.files io.backend -quotations words.private tools.deploy.config compiler.units ; +USING: qualified io.streams.c init fry namespaces assocs kernel +parser tools.deploy.config vocabs sequences words words.private +memory kernel.private continuations io prettyprint +vocabs.loader debugger system strings ; +QUALIFIED: bootstrap.stage2 +QUALIFIED: classes +QUALIFIED: compiler.errors.private +QUALIFIED: compiler.units +QUALIFIED: continuations +QUALIFIED: definitions +QUALIFIED: init +QUALIFIED: inspector +QUALIFIED: io.backend +QUALIFIED: io.nonblocking +QUALIFIED: io.thread +QUALIFIED: layouts +QUALIFIED: libc.private +QUALIFIED: libc.private +QUALIFIED: listener +QUALIFIED: prettyprint.config +QUALIFIED: random.private +QUALIFIED: source-files +QUALIFIED: threads +QUALIFIED: vocabs IN: tools.deploy.shaker : strip-init-hooks ( -- ) @@ -43,9 +61,6 @@ IN: tools.deploy.shaker run-file ] when ; -: strip-assoc ( retained-keys assoc -- newassoc ) - swap [ nip member? ] curry assoc-subset ; - : strip-word-names ( words -- ) "Stripping word names" show [ f over set-word-name f swap set-word-vocabulary ] each ; @@ -57,8 +72,11 @@ IN: tools.deploy.shaker : strip-word-props ( retain-props words -- ) "Stripping word properties" show [ - [ word-props strip-assoc f assoc-like ] keep - set-word-props + [ + word-props swap + '[ , nip member? ] assoc-subset + f assoc-like + ] keep set-word-props ] with each ; : retained-props ( -- seq ) @@ -81,10 +99,101 @@ IN: tools.deploy.shaker strip-word-names? [ dup strip-word-names ] when 2drop ; -: strip-environment ( retain-globals -- ) +: strip-recompile-hook ( -- ) + [ [ f ] { } map>assoc ] + compiler.units:recompile-hook + set-global ; + +: strip-vocab-globals ( except names -- words ) + [ child-vocabs [ words ] map concat ] map concat seq-diff ; + +: stripped-globals ( -- seq ) + [ + random.private:mt , + + { + bootstrap.stage2:bootstrap-time + continuations:error + continuations:error-continuation + continuations:error-thread + continuations:restarts + error-hook + init:init-hooks + inspector:inspector-hook + io.thread:io-thread + libc.private:mallocs + source-files:source-files + stderr + stdio + } % + + deploy-threads? [ + threads:initial-thread , + ] unless + + strip-io? [ io.backend:io-backend , ] when + + { io.backend:io-backend io.nonblocking:default-buffer-size } + { "alarms" "io" "tools" } strip-vocab-globals % + + strip-dictionary? [ + { } { "cpu" } strip-vocab-globals % + + { + vocabs:dictionary + lexer-factory + vocabs:load-vocab-hook + layouts:num-tags + layouts:num-types + layouts:tag-mask + layouts:tag-numbers + layouts:type-numbers + classes:typemap + vocab-roots + definitions:crossref + compiled-crossref + interactive-vocabs + word + compiler.units:recompile-hook + listener:listener-hook + lexer-factory + classes:update-map + classes:classr word-vocabulary r> member? ] curry - subset % - ] when - ] { } make dup . ; - -: strip-recompile-hook ( -- ) - [ [ f ] { } map>assoc ] recompile-hook set-global ; - : strip ( -- ) strip-libc strip-cocoa @@ -165,7 +225,7 @@ SYMBOL: deploy-vocab strip-init-hooks deploy-vocab get vocab-main set-boot-quot* retained-props >r - retained-globals strip-environment + stripped-globals strip-globals r> strip-words ; : (deploy) ( final-image vocab config -- ) diff --git a/extra/tools/deploy/test/1/1.factor b/extra/tools/deploy/test/1/1.factor new file mode 100755 index 0000000000..0bf8b10d0c --- /dev/null +++ b/extra/tools/deploy/test/1/1.factor @@ -0,0 +1,6 @@ +IN: tools.deploy.test.1 +USING: threads ; + +: deploy-test-1 1000 sleep ; + +MAIN: deploy-test-1 diff --git a/extra/tools/deploy/test/1/deploy.factor b/extra/tools/deploy/test/1/deploy.factor new file mode 100755 index 0000000000..f06bcbc0f0 --- /dev/null +++ b/extra/tools/deploy/test/1/deploy.factor @@ -0,0 +1,14 @@ +USING: tools.deploy.config ; +H{ + { deploy-c-types? f } + { deploy-io 2 } + { deploy-reflection 1 } + { deploy-threads? t } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-name "tools.deploy.test.1" } + { deploy-math? t } + { deploy-compiler? t } + { "stop-after-last-window?" t } + { deploy-ui? f } +} diff --git a/extra/tools/deploy/test/2/2.factor b/extra/tools/deploy/test/2/2.factor new file mode 100755 index 0000000000..e029e3050a --- /dev/null +++ b/extra/tools/deploy/test/2/2.factor @@ -0,0 +1,6 @@ +IN: tools.deploy.test.2 +USING: calendar calendar.format ; + +: deploy-test-2 now (timestamp>string) ; + +MAIN: deploy-test-2 diff --git a/extra/tools/deploy/test/2/deploy.factor b/extra/tools/deploy/test/2/deploy.factor new file mode 100755 index 0000000000..bd087d65bf --- /dev/null +++ b/extra/tools/deploy/test/2/deploy.factor @@ -0,0 +1,14 @@ +USING: tools.deploy.config ; +H{ + { deploy-c-types? f } + { deploy-io 2 } + { deploy-reflection 1 } + { deploy-threads? t } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-name "tools.deploy.test.2" } + { deploy-math? t } + { deploy-compiler? t } + { "stop-after-last-window?" t } + { deploy-ui? f } +} diff --git a/extra/tools/deploy/test/3/3.factor b/extra/tools/deploy/test/3/3.factor new file mode 100755 index 0000000000..443e82f7d9 --- /dev/null +++ b/extra/tools/deploy/test/3/3.factor @@ -0,0 +1,8 @@ +IN: tools.deploy.test.3 +USING: io.encodings.ascii io.files kernel ; + +: deploy-test-3 + "resource:extra/tools/deploy/test/3/3.factor" + ?resource-path ascii file-contents drop ; + +MAIN: deploy-test-3 diff --git a/extra/tools/deploy/test/3/deploy.factor b/extra/tools/deploy/test/3/deploy.factor new file mode 100755 index 0000000000..b8b8bf4aa2 --- /dev/null +++ b/extra/tools/deploy/test/3/deploy.factor @@ -0,0 +1,14 @@ +USING: tools.deploy.config ; +H{ + { deploy-math? t } + { deploy-reflection 1 } + { deploy-name "tools.deploy.test.3" } + { deploy-threads? t } + { deploy-word-props? f } + { "stop-after-last-window?" t } + { deploy-ui? f } + { deploy-io 3 } + { deploy-compiler? t } + { deploy-word-defs? f } + { deploy-c-types? f } +} From 85cfca546847cfb20f20e60224fb7ae72d51d9b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:48:39 -0500 Subject: [PATCH 23/83] Fix minor HTTPd omissions --- extra/http/server/server.factor | 1 + extra/http/server/static/static.factor | 2 -- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 37f21278df..283cb53627 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -12,6 +12,7 @@ GENERIC: call-responder ( path responder -- response ) : ( content-type -- response ) 200 >>code + "Document follows" >>message swap set-content-type ; TUPLE: trivial-responder response ; diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 6c365ad87b..18870a993f 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -7,8 +7,6 @@ calendar.format new-slots accessors io.encodings.binary combinators.cleave fry ; IN: http.server.static -SYMBOL: responder - ! special maps mime types to quots with effect ( path -- ) TUPLE: file-responder root hook special ; From 5e6a1bd241023c4a2b38af5f06c69079079e6aba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:49:07 -0500 Subject: [PATCH 24/83] Locals doesn't need to use map-call-with2 --- extra/locals/locals.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 956504be2c..9819e65e37 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -5,7 +5,7 @@ inference.transforms parser words quotations debugger macros arrays macros splitting combinators prettyprint.backend definitions prettyprint hashtables combinators.lib prettyprint.sections sequences.private effects generic -compiler.units ; +compiler.units combinators.cleave ; IN: locals ! Inspired by @@ -108,8 +108,8 @@ UNION: special local quote local-word local-reader local-writer ; if ; : (point-free) ( quot args -- newquot ) - { [ load-locals ] [ point-free-body ] [ point-free-end ] } - map-call-with2 concat >quotation ; + [ load-locals ] [ point-free-body ] [ point-free-end ] + 2tri 3append >quotation ; : point-free ( quot args -- newquot ) over empty? [ drop ] [ (point-free) ] if ; From b846d9797d709e88b3f9561b6267718dfbaa4e26 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:49:22 -0500 Subject: [PATCH 25/83] Fix using --- extra/tools/test/test.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 259b91c3af..031b3c3af8 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -4,7 +4,7 @@ USING: namespaces arrays prettyprint sequences kernel vectors quotations words parser assocs combinators continuations debugger io io.files vocabs tools.time vocabs.loader source-files compiler.units inspector -inference effects ; +inference effects tools.vocabs ; IN: tools.test SYMBOL: failures From cc5ee16f06ca1e486395e6b2d1f84c6c51cf20d9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:49:31 -0500 Subject: [PATCH 26/83] Add disassembler tests --- extra/tools/disassembler/disassembler-tests.factor | 5 +++++ 1 file changed, 5 insertions(+) create mode 100755 extra/tools/disassembler/disassembler-tests.factor diff --git a/extra/tools/disassembler/disassembler-tests.factor b/extra/tools/disassembler/disassembler-tests.factor new file mode 100755 index 0000000000..2a89fe908e --- /dev/null +++ b/extra/tools/disassembler/disassembler-tests.factor @@ -0,0 +1,5 @@ +IN: tools.disassembler.tests +USING: math tuples prettyprint.backend tools.disassembler ; + +[ ] [ \ + disassemble ] unit-test +[ ] [ { tuple prettyprint* } disassemble ] unit-test From bb137bb7841b47848f0a5d92b9e5c83e2e677b0f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:51:25 -0500 Subject: [PATCH 27/83] Fix disassembler tests --- extra/tools/disassembler/disassembler-tests.factor | 5 +++-- extra/tools/disassembler/disassembler.factor | 6 +++++- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/extra/tools/disassembler/disassembler-tests.factor b/extra/tools/disassembler/disassembler-tests.factor index 2a89fe908e..9983db7d00 100755 --- a/extra/tools/disassembler/disassembler-tests.factor +++ b/extra/tools/disassembler/disassembler-tests.factor @@ -1,5 +1,6 @@ IN: tools.disassembler.tests -USING: math tuples prettyprint.backend tools.disassembler ; +USING: math tuples prettyprint.backend tools.disassembler +tools.test strings ; [ ] [ \ + disassemble ] unit-test -[ ] [ { tuple prettyprint* } disassemble ] unit-test +[ ] [ { string pprint* } disassemble ] unit-test diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index 2fa882ff68..479ae9c42c 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.files io words alien kernel math.parser alien.syntax io.launcher system assocs arrays sequences namespaces qualified -system math generator.fixup io.encodings.ascii accessors ; +system math generator.fixup io.encodings.ascii accessors +generic ; IN: tools.disassembler : in-file "gdb-in.txt" temp-file ; @@ -22,6 +23,9 @@ M: pair make-disassemble-cmd [ number>string write bl ] each ] with-file-writer ; +M: method-spec make-disassemble-cmd + first2 method make-disassemble-cmd ; + : run-gdb ( -- lines ) +closed+ >>stdin From b55fa49b7c5e29f6fb0a71ac08ef2c513e8a38a4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:51:39 -0500 Subject: [PATCH 28/83] Update builder for tools.vocabs --- extra/builder/test/test.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 extra/builder/test/test.factor diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor old mode 100644 new mode 100755 index dd3c640a84..409d0db11c --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -4,7 +4,7 @@ USING: kernel namespaces sequences assocs builder continuations io io.files prettyprint - tools.browser + tools.vocabs tools.test io.encodings.utf8 combinators.cleave From 37a44cebc513a1b2898dcb623a6ce04bdb4b8839 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:51:54 -0500 Subject: [PATCH 29/83] Fix typo --- extra/ui/render/render-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/ui/render/render-docs.factor b/extra/ui/render/render-docs.factor index 2f82d983cc..fb4c000971 100755 --- a/extra/ui/render/render-docs.factor +++ b/extra/ui/render/render-docs.factor @@ -1,5 +1,5 @@ USING: ui.gadgets ui.gestures help.markup help.syntax -kernel classes strings opengl.gl ; +kernel classes strings opengl.gl models ; IN: ui.render HELP: gadget @@ -15,7 +15,7 @@ HELP: gadget { { $link gadget-clipped? } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." } { { $link gadget-interior } " - an object whose class implements the " { $link draw-interior } " generic word." } { { $link gadget-boundary } " - an object whose class implements the " { $link draw-boundary } " generic word." } - { { $link gadget-model } " - XXX" } + { { $link gadget-model } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } } } "Gadgets delegate to " { $link rect } " instances holding their location and dimensions." } { $notes From 99665a749f3e0c0f743ab1e5c5ef27bbcd632c33 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 03:52:04 -0500 Subject: [PATCH 30/83] Update ui.tools for tools.vocabs --- extra/ui/tools/tools.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor index b98b1dba28..d71b657491 100755 --- a/extra/ui/tools/tools.factor +++ b/extra/ui/tools/tools.factor @@ -8,7 +8,8 @@ prettyprint quotations sequences ui ui.commands ui.gadgets ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds ui.gadgets.presentations ui.gestures words vocabs.loader -tools.test ui.gadgets.buttons ui.gadgets.status-bar mirrors ; +tools.test tools.vocabs ui.gadgets.buttons ui.gadgets.status-bar +mirrors ; IN: ui.tools : ( -- tabs ) From 3929d02f17c83fe5a43ec29c3c6cf62e0f71d89a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 13 Mar 2008 04:19:32 -0600 Subject: [PATCH 31/83] Fix a couple of problems preventing bootstrap --- core/io/files/files-docs.factor | 10 +++++----- core/io/files/files.factor | 5 ++++- extra/io/unix/files/files.factor | 2 +- 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index a6dd1e0818..df9c78fe47 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -55,7 +55,7 @@ ARTICLE: "fs-meta" "File meta-data" { $subsection link-info } { $subsection exists? } { $subsection directory? } -{ $subsection file-modified } +! { $subsection file-modified } { $subsection stat } ; ARTICLE: "delete-move-copy" "Deleting, moving, copying files" @@ -222,7 +222,7 @@ HELP: stat ( path -- directory? permissions length modified ) "Queries the file system for file meta data. If the file does not exist, outputs " { $link f } " for all four values." } ; -{ stat exists? directory? file-modified } related-words +{ stat exists? directory? } related-words HELP: path+ { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } @@ -250,9 +250,9 @@ HELP: directory* { $description "Outputs the contents of a directory named by " { $snippet "path" } "." } { $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ; -HELP: file-modified -{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } } -{ $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ; +! HELP: file-modified +! { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } } +! { $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ; HELP: resource-path { $values { "path" "a pathname string" } { "newpath" "a pathname string" } } diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 104c38518a..8a81bb1972 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -219,8 +219,11 @@ M: pathname <=> [ pathname-string ] compare ; : with-file-reader ( path encoding quot -- ) >r r> with-stream ; inline +! : file-contents ( path encoding -- str ) +! dupd [ file-info file-info-size read ] with-file-reader ; + : file-contents ( path encoding -- str ) - dupd [ file-info file-info-size read ] with-file-reader ; + dupd [ file-length read ] with-file-reader ; : with-file-writer ( path encoding quot -- ) >r r> with-stream ; inline diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 73090ea724..bdcd0b985d 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -68,7 +68,7 @@ M: unix-io delete-directory ( path -- ) ] with-disposal ; M: unix-io copy-file ( from to -- ) - [ (copy-file) ] 2keep swap file-permissions chmod io-error ; + [ (copy-file) ] 2keep swap file-info file-info-permissions io-error ; : stat>type ( stat -- type ) stat-st_mode { From 3cddca95ae6d09a447411b70bc44d861e800d30f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 04:54:33 -0500 Subject: [PATCH 32/83] Simply core: don't call directory? and file-modified until after bootstrap --- core/parser/parser.factor | 1 - core/source-files/source-files-docs.factor | 12 ------ core/source-files/source-files.factor | 43 ++++++---------------- core/vocabs/loader/loader-tests.factor | 2 +- core/vocabs/loader/loader.factor | 21 ----------- extra/tools/vocabs/vocabs-docs.factor | 4 ++ extra/tools/vocabs/vocabs.factor | 38 ++++++++++++++++++- 7 files changed, 53 insertions(+), 68 deletions(-) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index cc28f09855..50f8f582d3 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -484,7 +484,6 @@ SYMBOL: interactive-vocabs : finish-parsing ( lines quot -- ) file get [ record-form ] keep - [ record-modified ] keep [ record-definitions ] keep record-checksum ; diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor index 31c2defd19..505ca59425 100755 --- a/core/source-files/source-files-docs.factor +++ b/core/source-files/source-files-docs.factor @@ -9,10 +9,7 @@ $nl { $subsection source-files } "The class of source files:" { $subsection source-file } -"Testing if a source file has been changed on disk:" -{ $subsection source-modified? } "Words intended for the parser:" -{ $subsection record-modified } { $subsection record-checksum } { $subsection record-form } { $subsection xref-source } @@ -41,15 +38,6 @@ HELP: source-file } } ; -HELP: source-modified? -{ $values { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's modification time and CRC32 checksum of the file's contents against previously-recorded values." } ; - -HELP: record-modified -{ $values { "source-file" source-file } } -{ $description "Records the modification time of the source file." } -$low-level-note ; - HELP: record-checksum { $values { "source-file" source-file } { "lines" "a sequence of strings" } } { $description "Records the CRC32 checksm of the source file's contents." } diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 98438b48d8..f4428e4e8b 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -1,44 +1,25 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays definitions generic assocs kernel math -namespaces prettyprint sequences strings vectors words -quotations inspector io.styles io combinators sorting -splitting math.parser effects continuations debugger -io.files io.crc32 io.streams.string vocabs -hashtables graphs compiler.units io.encodings.utf8 ; +USING: arrays definitions generic assocs kernel math namespaces +prettyprint sequences strings vectors words quotations inspector +io.styles io combinators sorting splitting math.parser effects +continuations debugger io.files io.crc32 vocabs hashtables +graphs compiler.units io.encodings.utf8 ; IN: source-files SYMBOL: source-files TUPLE: source-file path -modified checksum +checksum uses definitions ; -: (source-modified?) ( path modified checksum -- ? ) - pick file-modified rot [ 0 or ] 2apply > - [ swap utf8 file-lines lines-crc32 = not ] [ 2drop f ] if ; - -: source-modified? ( path -- ? ) - dup source-files get at [ - dup source-file-path ?resource-path - over source-file-modified - rot source-file-checksum - (source-modified?) - ] [ - resource-exists? - ] ?if ; - -: record-modified ( source-file -- ) - dup source-file-path ?resource-path file-modified - swap set-source-file-modified ; - : record-checksum ( lines source-file -- ) - swap lines-crc32 swap set-source-file-checksum ; + >r lines-crc32 r> set-source-file-checksum ; : (xref-source) ( source-file -- pathname uses ) - dup source-file-path swap source-file-uses - [ crossref? ] subset ; + dup source-file-path + swap source-file-uses [ crossref? ] subset ; : xref-source ( source-file -- ) (xref-source) crossref get add-vertex ; @@ -67,9 +48,7 @@ uses definitions ; : reset-checksums ( -- ) source-files get [ - swap ?resource-path dup exists? - [ - over record-modified + swap ?resource-path dup exists? [ utf8 file-lines swap record-checksum ] [ 2drop ] if ] assoc-each ; diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index f99bf94aa4..514e45f10f 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -3,7 +3,7 @@ IN: vocabs.loader.tests USING: vocabs.loader tools.test continuations vocabs math kernel arrays sequences namespaces io.streams.string parser source-files words assocs tuples definitions -debugger compiler.units ; +debugger compiler.units tools.vocabs ; ! This vocab should not exist, but just in case... [ ] [ diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 430aa066a8..fa9ff5b504 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -48,27 +48,6 @@ M: string vocab-root M: vocab-link vocab-root vocab-link-root ; -: vocab-tests ( vocab -- tests ) - dup vocab-root [ - [ - f >vocab-link dup - - dup "-tests.factor" vocab-dir+ vocab-path+ - dup resource-exists? [ , ] [ drop ] if - - dup vocab-dir "tests" path+ vocab-path+ dup - ?resource-path directory keys [ ".factor" tail? ] subset - [ path+ , ] with each - ] { } make - ] [ drop f ] if ; - -: vocab-files ( vocab -- seq ) - f >vocab-link [ - dup vocab-source-path [ , ] when* - dup vocab-docs-path [ , ] when* - vocab-tests % - ] { } make ; - SYMBOL: load-help? : source-was-loaded t swap set-vocab-source-loaded? ; diff --git a/extra/tools/vocabs/vocabs-docs.factor b/extra/tools/vocabs/vocabs-docs.factor index bdc3954e2e..ee82134379 100755 --- a/extra/tools/vocabs/vocabs-docs.factor +++ b/extra/tools/vocabs/vocabs-docs.factor @@ -25,6 +25,10 @@ ARTICLE: "tools.vocabs" "Vocabulary tools" ABOUT: "tools.vocabs" +HELP: source-modified? +{ $values { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's CRC32 checksum of the file's contents against the previously-recorded value." } ; + HELP: refresh { $values { "prefix" string } } { $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 21b8da8910..675a2e1d6e 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -3,9 +3,45 @@ USING: io.files kernel io.encodings.utf8 vocabs.loader vocabs sequences namespaces math.parser arrays hashtables assocs memoize inspector sorting splitting combinators source-files -io debugger continuations compiler.errors init ; +io debugger continuations compiler.errors init io.crc32 ; IN: tools.vocabs +: vocab-tests-file, ( vocab -- ) + dup "-tests.factor" vocab-dir+ vocab-path+ + dup resource-exists? [ , ] [ drop ] if ; + +: vocab-tests-dir, ( vocab -- ) + dup vocab-dir "tests" path+ vocab-path+ + dup resource-exists? [ + dup ?resource-path directory keys + [ ".factor" tail? ] subset + [ path+ , ] with each + ] [ drop ] if ; + +: vocab-tests ( vocab -- tests ) + dup vocab-root [ + [ + f >vocab-link dup + vocab-tests-file, + vocab-tests-dir, + ] { } make + ] [ drop f ] if ; + +: vocab-files ( vocab -- seq ) + f >vocab-link [ + dup vocab-source-path [ , ] when* + dup vocab-docs-path [ , ] when* + vocab-tests % + ] { } make ; + +: source-modified? ( path -- ? ) + dup source-files get at [ + dup source-file-path ?resource-path utf8 file-lines lines-crc32 + swap source-file-checksum = not + ] [ + resource-exists? + ] ?if ; + : modified ( seq quot -- seq ) [ dup ] swap compose { } map>assoc [ nip ] assoc-subset From 02d7c9fb24937f726fc9e2c48eac392c957b0d70 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 05:21:56 -0500 Subject: [PATCH 33/83] Simplifications --- core/source-files/source-files-docs.factor | 1 - core/vocabs/loader/loader-docs.factor | 8 -------- extra/http/server/server.factor | 2 +- extra/tools/deploy/deploy-tests.factor | 2 +- extra/tools/vocabs/vocabs-docs.factor | 8 ++++++++ 5 files changed, 10 insertions(+), 11 deletions(-) diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor index 505ca59425..2f2f8fd0c0 100755 --- a/core/source-files/source-files-docs.factor +++ b/core/source-files/source-files-docs.factor @@ -31,7 +31,6 @@ HELP: source-file { $class-description "Instances retain information about loaded source files, and have the following slots:" { $list { { $link source-file-path } " - a pathname string." } - { { $link source-file-modified } " - the result of " { $link file-modified } " at the time the source file was most recently loaded." } { { $link source-file-checksum } " - the CRC32 checksum of the source file's contents at the time it was most recently loaded." } { { $link source-file-uses } " - an assoc whose keys are words referenced from this source file's top level form." } { { $link source-file-definitions } " - a pair of assocs, containing definitions and classes defined in this source file, respectively" } diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index 886e678330..c7652c34c7 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -39,20 +39,12 @@ HELP: vocab-main HELP: vocab-roots { $var-description "A sequence of pathname strings to search for vocabularies." } ; -HELP: vocab-tests -{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } } -{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ; - HELP: find-vocab-root { $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } } { $description "Searches for a vocabulary in the vocabulary roots." } ; { vocab-root find-vocab-root } related-words -HELP: vocab-files -{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } } -{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ; - HELP: no-vocab { $values { "name" "a vocabulary name" } } { $description "Throws a " { $link no-vocab } "." } diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 283cb53627..b3fafc543f 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -3,7 +3,7 @@ USING: assocs kernel namespaces io io.timeouts strings splitting threads http sequences prettyprint io.server logging calendar new-slots html.elements accessors math.parser combinators.lib -vocabs.loader debugger html continuations random combinators +tools.vocabs debugger html continuations random combinators destructors io.encodings.latin1 fry combinators.cleave ; IN: http.server diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 0f770f7b60..d26e278fc5 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -1,6 +1,6 @@ IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config -tools.deploy.backend math ; +tools.deploy.backend math sequences ; : shake-and-bake "." resource-path [ diff --git a/extra/tools/vocabs/vocabs-docs.factor b/extra/tools/vocabs/vocabs-docs.factor index ee82134379..33f197d0ea 100755 --- a/extra/tools/vocabs/vocabs-docs.factor +++ b/extra/tools/vocabs/vocabs-docs.factor @@ -25,6 +25,14 @@ ARTICLE: "tools.vocabs" "Vocabulary tools" ABOUT: "tools.vocabs" +HELP: vocab-files +{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } } +{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ; + +HELP: vocab-tests +{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } } +{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ; + HELP: source-modified? { $values { "path" "a pathname string" } { "?" "a boolean" } } { $description "Tests if the source file has been modified since it was last loaded. This compares the file's CRC32 checksum of the file's contents against the previously-recorded value." } ; From 93afd5a7c5c20eec4267759e69e89feb1a986d9e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 06:15:11 -0500 Subject: [PATCH 34/83] Get jamshred to load --- extra/jamshred/jamshred.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 extra/jamshred/jamshred.factor diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor old mode 100644 new mode 100755 index 8beecc955c..42414b9893 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -59,7 +59,7 @@ M: jamshred-gadget ungraft* ( gadget -- ) USE: vocabs.loader jamshred-gadget H{ - { T{ key-down f f "r" } [ jamshred-restart refresh-all ] } + { T{ key-down f f "r" } [ jamshred-restart ] } { T{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] } { T{ motion } [ handle-mouse-motion ] } } set-gestures From 067fae725c60a9b8fd19fb0e4e51f1b1799c2812 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 06:37:50 -0500 Subject: [PATCH 35/83] Fix deploy tests again --- extra/tools/deploy/deploy-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index d26e278fc5..c68c259a6e 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -1,6 +1,6 @@ IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config -tools.deploy.backend math sequences ; +tools.deploy.backend math sequences io.launcher ; : shake-and-bake "." resource-path [ From a34146e33c4b28d1f96eb6c1a587478226096ba0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 06:38:00 -0500 Subject: [PATCH 36/83] Fix Window UI mouse handling bug --- extra/ui/windows/windows.factor | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index f65f293ca4..8eb5fe59aa 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -266,11 +266,6 @@ SYMBOL: nc-buttons key-modifiers swap message>button [ ] [ ] if ; -: mouse-buttons ( -- seq ) WM_LBUTTONDOWN WM_RBUTTONDOWN 2array ; - -: capture-mouse? ( umsg -- ? ) - mouse-buttons member? ; - : prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world ) nip >r mouse-event>gesture r> >lo-hi rot window ; @@ -287,8 +282,10 @@ SYMBOL: nc-buttons mouse-captured off ; : handle-wm-buttondown ( hWnd uMsg wParam lParam -- ) - >r >r dup capture-mouse? [ over set-capture ] when r> r> - prepare-mouse send-button-down ; + >r >r + over set-capture + dup message>button drop nc-buttons get delete + r> r> prepare-mouse send-button-down ; : handle-wm-buttonup ( hWnd uMsg wParam lParam -- ) mouse-captured get [ release-capture ] when From fc725ce7fa7c6cd0c6d286b900d9df10c661dc57 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 06:38:09 -0500 Subject: [PATCH 37/83] Add unit test --- core/parser/parser-tests.factor | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 89783d1b3c..a69e28ab97 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -430,3 +430,20 @@ IN: parser.tests [ "resource:core/parser/test/assert-depth.factor" run-file ] [ relative-overflow-stack { 1 2 3 } sequence= ] must-fail-with + +2 [ + [ ] [ + "IN: parser.tests DEFER: d-f-s d-f-s SYMBOL: d-f-s d-f-s" + "d-f-s-test" parse-stream drop + ] unit-test + + [ ] [ + "IN: parser.tests DEFER: d-f-s d-f-s FORGET: d-f-s SYMBOL: d-f-s d-f-s" + "d-f-s-test" parse-stream drop + ] unit-test + + [ ] [ + "IN: parser.tests DEFER: d-f-s d-f-s SYMBOL: d-f-s d-f-s" + "d-f-s-test" parse-stream drop + ] unit-test +] times From 67562173a4441e5c8ce174b7e98d997364ead3b8 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 13 Mar 2008 14:10:56 -0600 Subject: [PATCH 38/83] Replace more old 'stat' based code --- core/io/files/files.factor | 12 ++++++------ extra/http/server/static/static.factor | 5 +++-- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 8a81bb1972..3ab489739b 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -86,11 +86,11 @@ SYMBOL: +unknown+ : stat ( path -- directory? permissions length modified ) normalize-pathname (stat) ; -: file-length ( path -- n ) stat drop 2nip ; +! : file-length ( path -- n ) stat drop 2nip ; : file-modified ( path -- n ) stat >r 3drop r> ; -: file-permissions ( path -- perm ) stat 2drop nip ; +! : file-permissions ( path -- perm ) stat 2drop nip ; : exists? ( path -- ? ) file-modified >boolean ; @@ -219,11 +219,11 @@ M: pathname <=> [ pathname-string ] compare ; : with-file-reader ( path encoding quot -- ) >r r> with-stream ; inline -! : file-contents ( path encoding -- str ) -! dupd [ file-info file-info-size read ] with-file-reader ; - : file-contents ( path encoding -- str ) - dupd [ file-length read ] with-file-reader ; + dupd [ file-info file-info-size read ] with-file-reader ; + +! : file-contents ( path encoding -- str ) +! dupd [ file-length read ] with-file-reader ; : with-file-writer ( path encoding quot -- ) >r r> with-stream ; inline diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 18870a993f..9c05b87a71 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -14,7 +14,8 @@ TUPLE: file-responder root hook special ; >r unix-1970 r> seconds time+ ; : file-http-date ( filename -- string ) - file-modified unix-time>timestamp timestamp>http-string ; + file-info file-info-modified + unix-time>timestamp timestamp>http-string ; : last-modified-matches? ( filename -- ? ) file-http-date dup [ @@ -31,7 +32,7 @@ TUPLE: file-responder root hook special ; [ swap - [ file-length "content-length" set-header ] + [ file-info file-info-size "content-length" set-header ] [ file-http-date "last-modified" set-header ] [ '[ , binary stdio get stream-copy ] >>body ] tri From a5551f8f56341427ce92a06434d385150dd818e5 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 13 Mar 2008 15:39:25 -0600 Subject: [PATCH 39/83] combinators.cleave: add 2cleave and improve stack effect comments --- extra/combinators/cleave/cleave.factor | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) mode change 100755 => 100644 extra/combinators/cleave/cleave.factor diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor old mode 100755 new mode 100644 index 383d5ca9ac..fd66536c12 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -15,9 +15,9 @@ IN: combinators.cleave ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline +: 2bi ( x y p q -- p(x,y) q(x,y) ) >r 2keep r> call ; inline -: 2tri ( obj obj quot quot quot -- val val val ) +: 2tri ( x y z p q r -- p(x,y,z) q(x,y,z) r(x,y,z) ) >r >r 2keep r> 2keep r> call ; inline ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -36,6 +36,18 @@ MACRO: cleave ( seq -- ) [ drop ] append ; +MACRO: 2cleave ( seq -- ) + dup + [ drop [ 2dup ] ] map concat + swap + dup + [ drop [ >r >r ] ] map concat + swap + [ [ r> r> ] append ] map concat + 3append + [ 2drop ] + append ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! The spread family ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 70e160d08c769608b4607b0716a36b75bc46dc8f Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 13 Mar 2008 15:39:54 -0600 Subject: [PATCH 40/83] combinators.cleave-docs: Add a couple of items --- extra/combinators/cleave/cleave-docs.factor | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/extra/combinators/cleave/cleave-docs.factor b/extra/combinators/cleave/cleave-docs.factor index 0c491b88b1..18968628d5 100644 --- a/extra/combinators/cleave/cleave-docs.factor +++ b/extra/combinators/cleave/cleave-docs.factor @@ -9,6 +9,7 @@ ARTICLE: "cleave-combinators" "Cleave Combinators" { $subsection bi } { $subsection tri } +{ $subsection cleave } { $notes "From the Merriam-Webster Dictionary: " @@ -49,10 +50,17 @@ HELP: tri ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +HELP: cleave + +{ $code "( obj { q1 q2 ... qN } -- q1(obj) q2(obj) ... qN(obj) )" } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ARTICLE: "spread-combinators" "Spread Combinators" { $subsection bi* } -{ $subsection tri* } ; +{ $subsection tri* } +{ $subsection spread } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -80,3 +88,9 @@ HELP: tri* { "p(x)" "p applied to x" } { "q(y)" "q applied to y" } { "r(z)" "r applied to z" } } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +HELP: spread + +{ $code "( v1 v2 ... vN { q1 q2 ... qN } -- q1(v1) q2(v2) ... qN(vN) )" } ; \ No newline at end of file From f6a2a9fa49f5243c1b7cd5f56b42d97cd0edd922 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 13 Mar 2008 15:40:55 -0600 Subject: [PATCH 41/83] builder: change mode --- extra/builder/builder.factor | 0 1 file changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 extra/builder/builder.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor old mode 100755 new mode 100644 From 93ad9cb096fa78e1e82244dedc729730b0945ea2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 17:20:28 -0500 Subject: [PATCH 42/83] Working on classes --- core/classes/classes-docs.factor | 21 ++-------- core/classes/classes-tests.factor | 66 +++++++++++++++---------------- core/classes/classes.factor | 14 ++----- 3 files changed, 40 insertions(+), 61 deletions(-) diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index df97a3eff5..1e71173153 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -1,7 +1,7 @@ USING: help.markup help.syntax kernel kernel.private namespaces sequences words arrays layouts help effects math layouts classes.private classes.union classes.mixin -classes.predicate ; +classes.predicate quotations ; IN: classes ARTICLE: "builtin-classes" "Built-in classes" @@ -114,24 +114,9 @@ HELP: predicate-word { $values { "word" "a word" } { "predicate" "a predicate word" } } { $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ; -HELP: define-predicate* -{ $values { "class" class } { "predicate" "a predicate word" } { "quot" "a quotation" } } -{ $description - "Defines a predicate word. This is identical to a word definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:" - { $list - { "the class word's " { $snippet "\"predicate\"" } " property is set to a quotation that calls the predicate" } - { "the predicate word's " { $snippet "\"predicating\"" } " property is set to the class word" } - { "the predicate word's " { $snippet "\"declared-effect\"" } " word property is set to a descriptive " { $link effect } } - } - "These properties are used by method dispatch and the help system." -} -$low-level-note ; - HELP: define-predicate -{ $values { "class" class } { "quot" "a quotation" } } -{ $description - "Defines a predicate word named " { $snippet "class?" } " with " { $link define-predicate* } "." -} +{ $values { "class" class } { "quot" quotation } } +{ $description "Defines a predicate word for a class." } $low-level-note ; HELP: superclass diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 640439312d..dbc1bcace2 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -178,39 +178,39 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ; [ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test -DEFER: mixin-forget-test-g - -[ "mixin-forget-test" forget-source ] with-compilation-unit - -[ ] [ - { - "USING: sequences ;" - "IN: classes.tests" - "MIXIN: mixin-forget-test" - "INSTANCE: sequence mixin-forget-test" - "GENERIC: mixin-forget-test-g ( x -- y )" - "M: mixin-forget-test mixin-forget-test-g ;" - } "\n" join "mixin-forget-test" - parse-stream drop -] unit-test - -[ { } ] [ { } mixin-forget-test-g ] unit-test -[ H{ } mixin-forget-test-g ] must-fail - -[ ] [ - { - "USING: hashtables ;" - "IN: classes.tests" - "MIXIN: mixin-forget-test" - "INSTANCE: hashtable mixin-forget-test" - "GENERIC: mixin-forget-test-g ( x -- y )" - "M: mixin-forget-test mixin-forget-test-g ;" - } "\n" join "mixin-forget-test" - parse-stream drop -] unit-test - -[ { } mixin-forget-test-g ] must-fail -[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test +2 [ + [ "mixin-forget-test" forget-source ] with-compilation-unit + + [ ] [ + { + "USING: sequences ;" + "IN: classes.tests" + "MIXIN: mixin-forget-test" + "INSTANCE: sequence mixin-forget-test" + "GENERIC: mixin-forget-test-g ( x -- y )" + "M: mixin-forget-test mixin-forget-test-g ;" + } "\n" join "mixin-forget-test" + parse-stream drop + ] unit-test + + [ { } ] [ { } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test + [ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail + + [ ] [ + { + "USING: hashtables ;" + "IN: classes.tests" + "MIXIN: mixin-forget-test" + "INSTANCE: hashtable mixin-forget-test" + "GENERIC: mixin-forget-test-g ( x -- y )" + "M: mixin-forget-test mixin-forget-test-g ;" + } "\n" join "mixin-forget-test" + parse-stream drop + ] unit-test + + [ { } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail + [ H{ } ] [ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test +] times ! Method flattening interfered with mixin update MIXIN: flat-mx-1 diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 48ddb2adf5..e60d3ba223 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -31,17 +31,9 @@ PREDICATE: class tuple-class PREDICATE: word predicate "predicating" word-prop >boolean ; -: define-predicate* ( class predicate quot -- ) - over [ - dupd predicate-effect define-declared - 2dup 1quotation "predicate" set-word-prop - swap "predicating" set-word-prop - ] [ 3drop ] if ; - : define-predicate ( class quot -- ) - over "forgotten" word-prop [ 2drop ] [ - >r dup predicate-word r> define-predicate* - ] if ; + >r "predicate" word-prop first + r> predicate-effect define-declared ; : superclass ( class -- super ) "superclass" word-prop ; @@ -257,6 +249,8 @@ PRIVATE> over reset-class over deferred? [ over define-symbol ] when >r dup word-props r> union over set-word-props + dup predicate-word 2dup 1quotation "predicate" set-word-prop + over "predicating" set-word-prop t "class" set-word-prop ; GENERIC: update-predicate ( class -- ) From 31e15e3204778a7caf16bed3b55d433209c9d322 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 18:56:24 -0500 Subject: [PATCH 43/83] Fix bootstrap problems --- core/bootstrap/primitives.factor | 88 +++++++++++++++----------------- extra/io/windows/windows.factor | 2 +- 2 files changed, 41 insertions(+), 49 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index aeb5ec1d82..9a903d90cd 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -98,26 +98,34 @@ H{ } clone classr dup make-inline >r - dup dup lookup-type-number "type" set-word-prop +: register-builtin ( class -- ) + dup + dup lookup-type-number "type" set-word-prop + dup "type" word-prop builtins get set-nth ; + +: define-builtin-slots ( symbol slotspec -- ) + dupd 1 simple-slots + 2dup "slots" set-word-prop + define-slots ; + +: define-builtin ( symbol slotspec -- ) + >r + dup register-builtin dup f f builtin-class define-class - dup r> builtin-predicate - dup r> 1 simple-slots 2dup "slots" set-word-prop - dupd define-slots - register-builtin ; + dup define-builtin-predicate + r> define-builtin-slots ; H{ } clone typemap set num-types get f builtins set @@ -128,17 +136,15 @@ num-types get f builtins set "null" "kernel" create drop -"fixnum" "math" create "fixnum?" "math" create { } define-builtin +"fixnum" "math" create { } define-builtin "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop -"bignum" "math" create "bignum?" "math" create { } define-builtin +"bignum" "math" create { } define-builtin "bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop -"tuple" "kernel" create "tuple?" "kernel" create -{ } define-builtin +"tuple" "kernel" create { } define-builtin -"ratio" "math" create "ratio?" "math" create -{ +"ratio" "math" create { { { "integer" "math" } "numerator" @@ -153,11 +159,10 @@ num-types get f builtins set } } define-builtin -"float" "math" create "float?" "math" create { } define-builtin +"float" "math" create { } define-builtin "float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop -"complex" "math" create "complex?" "math" create -{ +"complex" "math" create { { { "real" "math" } "real-part" @@ -172,14 +177,13 @@ num-types get f builtins set } } define-builtin -"f" "syntax" lookup "not" "kernel" create -{ } define-builtin +"f" "syntax" lookup { } define-builtin -"array" "arrays" create "array?" "arrays" create -{ } define-builtin +! do not word... -"wrapper" "kernel" create "wrapper?" "kernel" create -{ +"array" "arrays" create { } define-builtin + +"wrapper" "kernel" create { { { "object" "kernel" } "wrapped" @@ -188,8 +192,7 @@ num-types get f builtins set } } define-builtin -"string" "strings" create "string?" "strings" create -{ +"string" "strings" create { { { "array-capacity" "sequences.private" } "length" @@ -203,8 +206,7 @@ num-types get f builtins set } } define-builtin -"quotation" "quotations" create "quotation?" "quotations" create -{ +"quotation" "quotations" create { { { "object" "kernel" } "array" @@ -219,8 +221,7 @@ num-types get f builtins set } } define-builtin -"dll" "alien" create "dll?" "alien" create -{ +"dll" "alien" create { { { "byte-array" "byte-arrays" } "path" @@ -230,8 +231,7 @@ num-types get f builtins set } define-builtin -"alien" "alien" create "alien?" "alien" create -{ +"alien" "alien" create { { { "c-ptr" "alien" } "alien" @@ -246,8 +246,7 @@ define-builtin } define-builtin -"word" "words" create "word?" "words" create -{ +"word" "words" create { f { { "object" "kernel" } @@ -287,20 +286,13 @@ define-builtin } } define-builtin -"byte-array" "byte-arrays" create -"byte-array?" "byte-arrays" create -{ } define-builtin +"byte-array" "byte-arrays" create { } define-builtin -"bit-array" "bit-arrays" create -"bit-array?" "bit-arrays" create -{ } define-builtin +"bit-array" "bit-arrays" create { } define-builtin -"float-array" "float-arrays" create -"float-array?" "float-arrays" create -{ } define-builtin +"float-array" "float-arrays" create { } define-builtin -"callstack" "kernel" create "callstack?" "kernel" create -{ } define-builtin +"callstack" "kernel" create { } define-builtin ! Define general-t type, which is any object that is not f. "general-t" "kernel" create diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 094a6ec0d6..f6a9dd451f 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -76,7 +76,7 @@ M: win32-file close-handle ( handle -- ) ] when drop ; : open-append ( path -- handle length ) - dup file-length dup [ + dup file-info file-info-size dup [ >r (open-append) r> 2dup set-file-pointer ] [ drop open-write From 753fa3824e58b4578e89898c37c64df70bdd4da3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 18:56:33 -0500 Subject: [PATCH 44/83] Fix file responder --- extra/http/server/static/static.factor | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 9c05b87a71..b408b1b6b0 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -10,12 +10,8 @@ IN: http.server.static ! special maps mime types to quots with effect ( path -- ) TUPLE: file-responder root hook special ; -: unix-time>timestamp ( n -- timestamp ) - >r unix-1970 r> seconds time+ ; - : file-http-date ( filename -- string ) - file-info file-info-modified - unix-time>timestamp timestamp>http-string ; + file-info file-info-modified timestamp>http-string ; : last-modified-matches? ( filename -- ? ) file-http-date dup [ From a65c96042d71c45ecc1c9d57196c62741ed9b2c1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 21:07:53 -0500 Subject: [PATCH 45/83] Fix usages of file-length --- extra/help/cookbook/cookbook.factor | 2 +- extra/io/mmap/mmap-tests.factor | 4 ++-- extra/tools/deploy/deploy-tests.factor | 8 ++++---- 3 files changed, 7 insertions(+), 7 deletions(-) mode change 100644 => 100755 extra/io/mmap/mmap-tests.factor diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index 72b300b585..319dd1586b 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -199,7 +199,7 @@ ARTICLE: "cookbook-io" "Input and output cookbook" } "Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:" { $code - "\"mydata.dat\" dup file-length [" + "\"mydata.dat\" dup file-info file-info-length [" " 4 [ reverse-here ] change-each" "] with-mapped-file" } diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor old mode 100644 new mode 100755 index f1c65178d9..be5dc48bf0 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -4,7 +4,7 @@ IN: io.mmap.tests [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors [ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test -[ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test -[ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test +[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test +[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-length [ length ] with-mapped-file ] unit-test [ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index c68c259a6e..408d3d0afb 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -12,25 +12,25 @@ tools.deploy.backend math sequences io.launcher ; [ ] [ "hello-world" shake-and-bake ] unit-test [ t ] [ - "hello.image" temp-file file-length 500000 <= + "hello.image" temp-file file-info file-info-length 500000 <= ] unit-test [ ] [ "sudoku" shake-and-bake ] unit-test [ t ] [ - "hello.image" temp-file file-length 1500000 <= + "hello.image" temp-file file-info file-info-length 1500000 <= ] unit-test [ ] [ "hello-ui" shake-and-bake ] unit-test [ t ] [ - "hello.image" temp-file file-length 2000000 <= + "hello.image" temp-file file-info file-info-length 2000000 <= ] unit-test [ ] [ "bunny" shake-and-bake ] unit-test [ t ] [ - "hello.image" temp-file file-length 3000000 <= + "hello.image" temp-file file-info file-info-length 3000000 <= ] unit-test [ ] [ From 1289cfa8e3f6d7bf49b016844954d6756448c1cc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 22:08:57 -0500 Subject: [PATCH 46/83] More fixes --- extra/io/mmap/mmap-tests.factor | 2 +- extra/io/unix/files/files.factor | 29 +++++++++++++------------- extra/tools/deploy/deploy-tests.factor | 8 +++---- 3 files changed, 19 insertions(+), 20 deletions(-) diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index be5dc48bf0..c75c7b9bd4 100755 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -5,6 +5,6 @@ IN: io.mmap.tests [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors [ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test [ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test -[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-length [ length ] with-mapped-file ] unit-test +[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] with-mapped-file ] unit-test [ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index bdcd0b985d..1e7d682314 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,15 +1,15 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.nonblocking io.unix.backend io.files io -unix unix.stat unix.time kernel math continuations math.bitfields -byte-arrays alien combinators combinators.cleave calendar -io.encodings.binary ; +unix unix.stat unix.time kernel math continuations +math.bitfields byte-arrays alien combinators combinators.cleave +calendar io.encodings.binary ; IN: io.unix.files M: unix-io cwd - MAXPATHLEN dup swap - getcwd [ (io-error) ] unless* ; + MAXPATHLEN [ ] [ ] bi getcwd + [ (io-error) ] unless* ; M: unix-io cd chdir io-error ; @@ -68,7 +68,9 @@ M: unix-io delete-directory ( path -- ) ] with-disposal ; M: unix-io copy-file ( from to -- ) - [ (copy-file) ] 2keep swap file-info file-info-permissions io-error ; + [ (copy-file) ] + [ swap file-info file-info-permissions chmod io-error ] + 2bi ; : stat>type ( stat -- type ) stat-st_mode { @@ -82,8 +84,8 @@ M: unix-io copy-file ( from to -- ) { [ t ] [ +unknown+ ] } } cond nip ; -M: unix-io file-info ( path -- info ) - stat* { +: stat>file-info ( stat -- info ) + { [ stat>type ] [ stat-st_size ] [ stat-st_mode ] @@ -91,11 +93,8 @@ M: unix-io file-info ( path -- info ) } cleave \ file-info construct-boa ; +M: unix-io file-info ( path -- info ) + stat* stat>file-info ; + M: unix-io link-info ( path -- info ) - lstat* { - [ stat>type ] - [ stat-st_size ] - [ stat-st_mode ] - [ stat-st_mtim timespec-sec seconds unix-1970 time+ ] - } cleave - \ file-info construct-boa ; + lstat* stat>file-info ; diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 408d3d0afb..a6e126ea9e 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -12,25 +12,25 @@ tools.deploy.backend math sequences io.launcher ; [ ] [ "hello-world" shake-and-bake ] unit-test [ t ] [ - "hello.image" temp-file file-info file-info-length 500000 <= + "hello.image" temp-file file-info file-info-size 500000 <= ] unit-test [ ] [ "sudoku" shake-and-bake ] unit-test [ t ] [ - "hello.image" temp-file file-info file-info-length 1500000 <= + "hello.image" temp-file file-info file-info-size 1500000 <= ] unit-test [ ] [ "hello-ui" shake-and-bake ] unit-test [ t ] [ - "hello.image" temp-file file-info file-info-length 2000000 <= + "hello.image" temp-file file-info file-info-size 2000000 <= ] unit-test [ ] [ "bunny" shake-and-bake ] unit-test [ t ] [ - "hello.image" temp-file file-info file-info-length 3000000 <= + "hello.image" temp-file file-info file-info-size 3000000 <= ] unit-test [ ] [ From 033085a68369e6b5a28ef88f927ba83c251e56b7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 22:11:10 -0500 Subject: [PATCH 47/83] Fix inference.class regression --- core/bootstrap/primitives.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 9a903d90cd..b900b2fd49 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -105,7 +105,9 @@ H{ } clone update-map set ] [ ] make ; : define-builtin-predicate ( class -- ) - dup builtin-predicate-quot define-predicate ; + dup + dup builtin-predicate-quot define-predicate + predicate-word make-inline ; : lookup-type-number ( word -- n ) global [ target-word ] bind type-number ; From 6c73d6a24590e50223e87a9bda2267120c85edff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 22:14:32 -0500 Subject: [PATCH 48/83] Improving session management and action link generation --- extra/http/client/client.factor | 3 +- extra/http/http.factor | 82 ++++++++++++------- .../http/server/actions/actions-tests.factor | 1 + extra/http/server/actions/actions.factor | 24 ++---- extra/http/server/auth/login/login.factor | 3 +- extra/http/server/auth/login/login.fhtml | 13 ++- extra/http/server/auth/login/recover-1.fhtml | 5 +- extra/http/server/auth/login/recover-3.fhtml | 7 +- extra/http/server/auth/login/recover-4.fhtml | 6 +- extra/http/server/auth/login/register.fhtml | 4 +- extra/http/server/auth/providers/db/db.factor | 4 +- extra/http/server/server.factor | 34 ++++++-- .../server/sessions/sessions-tests.factor | 6 +- extra/http/server/sessions/sessions.factor | 34 ++++---- 14 files changed, 136 insertions(+), 90 deletions(-) diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index ee0d5f7f3b..6d875ef560 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -95,5 +95,4 @@ PRIVATE> swap >>post-data-type ; : http-post ( content-type content url -- response string ) - #! The content is URL encoded for you. - >r url-encode r> http-request contents ; + http-request contents ; diff --git a/extra/http/http.factor b/extra/http/http.factor index c72a631d16..4dd433f85d 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -4,7 +4,8 @@ USING: fry hashtables io io.streams.string kernel math namespaces math.parser assocs sequences strings splitting ascii io.encodings.utf8 io.encodings.string namespaces unicode.case combinators vectors sorting new-slots accessors calendar -calendar.format quotations arrays ; +calendar.format quotations arrays combinators.cleave +combinators.lib byte-arrays ; IN: http : http-port 80 ; inline @@ -12,18 +13,21 @@ IN: http : url-quotable? ( ch -- ? ) #! In a URL, can this character be used without #! URL-encoding? - dup letter? - over LETTER? or - over digit? or - swap "/_-." member? or ; foldable + { + [ dup letter? ] + [ dup LETTER? ] + [ dup digit? ] + [ dup "/_-.:" member? ] + } || nip ; foldable : push-utf8 ( ch -- ) - 1string utf8 encode [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; + 1string utf8 encode + [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; : url-encode ( str -- str ) - [ [ - dup url-quotable? [ , ] [ push-utf8 ] if - ] each ] "" make ; + [ + [ dup url-quotable? [ , ] [ push-utf8 ] if ] each + ] "" make ; : url-decode-hex ( index str -- ) 2dup length 2 - >= [ @@ -108,7 +112,12 @@ IN: http ] when ; : assoc>query ( hash -- str ) - [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map + [ + [ url-encode ] + [ dup number? [ number>string ] when url-encode ] + bi* + "=" swap 3append + ] { } assoc>map "&" join ; TUPLE: cookie name value path domain expires http-only ; @@ -169,10 +178,10 @@ cookies ; : request construct-empty - "1.1" >>version - http-port >>port - H{ } clone >>query - V{ } clone >>cookies ; + "1.1" >>version + http-port >>port + H{ } clone >>query + V{ } clone >>cookies ; : query-param ( request key -- value ) swap query>> at ; @@ -245,6 +254,10 @@ SYMBOL: max-post-request : extract-post-data-type ( request -- request ) dup "content-type" header >>post-data-type ; +: parse-post-data ( request -- request ) + dup post-data-type>> "application/x-www-form-urlencoded" = + [ dup post-data>> query>assoc >>post-data ] when ; + : extract-cookies ( request -- request ) dup "cookie" header [ parse-cookies >>cookies ] when* ; @@ -257,24 +270,31 @@ SYMBOL: max-post-request read-post-data extract-host extract-post-data-type + parse-post-data extract-cookies ; : write-method ( request -- request ) dup method>> write bl ; -: write-url ( request -- request ) - dup path>> url-encode write - dup query>> dup assoc-empty? [ drop ] [ - "?" write - assoc>query write - ] if ; +: (link>string) ( url query -- url' ) + [ url-encode ] [ assoc>query ] bi* + dup empty? [ drop ] [ "?" swap 3append ] if ; + +: write-url ( request -- ) + [ path>> ] [ query>> ] bi (link>string) write ; : write-request-url ( request -- request ) - write-url bl ; + dup write-url bl ; : write-version ( request -- request ) "HTTP/" write dup request-version write crlf ; +: unparse-post-data ( request -- request ) + dup post-data>> dup sequence? [ drop ] [ + assoc>query >>post-data + "application/x-www-form-urlencoded" >>post-data-type + ] if ; + : write-request-header ( request -- request ) dup header>> >hashtable over host>> [ "host" pick set-at ] when* @@ -287,6 +307,7 @@ SYMBOL: max-post-request dup post-data>> [ write ] when* ; : write-request ( request -- ) + unparse-post-data write-method write-request-url write-version @@ -297,15 +318,16 @@ SYMBOL: max-post-request : request-url ( request -- url ) [ - dup host>> [ - "http://" write - dup host>> url-encode write - ":" write - dup port>> number>string write - ] when - dup path>> "/" head? [ "/" write ] unless - write-url - drop + [ + dup host>> [ + [ "http://" write host>> url-encode write ] + [ ":" write port>> number>string write ] + bi + ] [ drop ] if + ] + [ path>> "/" head? [ "/" write ] unless ] + [ write-url ] + tri ] with-string-writer ; : set-header ( request/response value key -- request/response ) diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor index 98a92e083a..45f7ff385d 100755 --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/http/server/actions/actions-tests.factor @@ -29,6 +29,7 @@ blah STRING: action-request-test-2 POST http://foo/bar/baz HTTP/1.1 content-length: 5 +content-type: application/x-www-form-urlencoded xxx=4 ; diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index bab55eef0c..72c2d2df8e 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -17,14 +17,6 @@ TUPLE: action init display submit get-params post-params ; [ <400> ] >>display [ <400> ] >>submit ; -: extract-params ( path -- assoc ) - +path+ associate - request get dup method>> { - { "GET" [ query>> ] } - { "HEAD" [ query>> ] } - { "POST" [ post-data>> query>assoc ] } - } case union ; - : with-validator ( string quot -- result error? ) '[ , @ f ] [ dup validation-error? [ t ] [ rethrow ] if @@ -50,12 +42,10 @@ TUPLE: action init display submit get-params post-params ; action get display>> call exit-with ; M: action call-responder ( path action -- response ) - [ extract-params params set ] - [ - action set - request get method>> { - { "GET" [ handle-get ] } - { "HEAD" [ handle-get ] } - { "POST" [ handle-post ] } - } case - ] bi* ; + [ +path+ associate request-params union params set ] + [ action set ] bi* + request get method>> { + { "GET" [ handle-get ] } + { "HEAD" [ handle-get ] } + { "POST" [ handle-post ] } + } case ; diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 7d92c727c6..9b2648158d 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -30,7 +30,8 @@ SYMBOL: login-failed? : successful-login ( user -- response ) logged-in-user sset - post-login-url sget f ; + post-login-url sget "" or f + f post-login-url sset ; :: ( -- action ) [let | form [ ] | diff --git a/extra/http/server/auth/login/login.fhtml b/extra/http/server/auth/login/login.fhtml index 8e879420a9..07201719e5 100755 --- a/extra/http/server/auth/login/login.fhtml +++ b/extra/http/server/auth/login/login.fhtml @@ -1,10 +1,13 @@ -<% USING: http.server.auth.login http.server.components kernel -namespaces ; %> +<% USING: http.server.auth.login http.server.components http.server +kernel namespaces ; %>

Login required

+ +<% hidden-form-field %> + @@ -30,10 +33,12 @@ login-failed? get

<% allow-registration? [ %> - Register + ">Register <% ] when %> <% allow-password-recovery? [ %> - Recover Password + "> + Recover Password + <% ] when %>

diff --git a/extra/http/server/auth/login/recover-1.fhtml b/extra/http/server/auth/login/recover-1.fhtml index 3e8448f64b..8ec01f22e9 100755 --- a/extra/http/server/auth/login/recover-1.fhtml +++ b/extra/http/server/auth/login/recover-1.fhtml @@ -1,4 +1,4 @@ -<% USING: http.server.components ; %> +<% USING: http.server.components http.server ; %>

Recover lost password: step 1 of 4

@@ -6,6 +6,9 @@

Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.

+ +<% hidden-form-field %> +
diff --git a/extra/http/server/auth/login/recover-3.fhtml b/extra/http/server/auth/login/recover-3.fhtml index b220cc4f75..edd32fffe8 100755 --- a/extra/http/server/auth/login/recover-3.fhtml +++ b/extra/http/server/auth/login/recover-3.fhtml @@ -1,4 +1,4 @@ -<% USING: http.server.components http.server.auth.login +<% USING: http.server.components http.server.auth.login http.server namespaces kernel combinators ; %> @@ -7,6 +7,9 @@ namespaces kernel combinators ; %>

Choose a new password for your account.

+ +<% hidden-form-field %> +
<% "username" component render-edit %> @@ -32,7 +35,7 @@ namespaces kernel combinators ; %>

<% password-mismatch? get [ -"passwords do not match" render-error + "passwords do not match" render-error ] when %>

diff --git a/extra/http/server/auth/login/recover-4.fhtml b/extra/http/server/auth/login/recover-4.fhtml index dec7a5404f..239d71d293 100755 --- a/extra/http/server/auth/login/recover-4.fhtml +++ b/extra/http/server/auth/login/recover-4.fhtml @@ -1,10 +1,10 @@ -<% USING: http.server.components http.server.auth.login -namespaces kernel combinators ; %> +<% USING: http.server ; %>

Recover lost password: step 4 of 4

-

Your password has been reset. You may now log in.

+

Your password has been reset. +You may now ">log in.

diff --git a/extra/http/server/auth/login/register.fhtml b/extra/http/server/auth/login/register.fhtml index c7e274e626..99d1547d03 100755 --- a/extra/http/server/auth/login/register.fhtml +++ b/extra/http/server/auth/login/register.fhtml @@ -1,10 +1,12 @@ <% USING: http.server.components http.server.auth.login -namespaces kernel combinators ; %> +http.server namespaces kernel combinators ; %>

New user registration

+<% hidden-form-field %> +
diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor index e9e79ff82f..c9e1328052 100755 --- a/extra/http/server/auth/providers/db/db.factor +++ b/extra/http/server/auth/providers/db/db.factor @@ -14,9 +14,7 @@ user "USERS" { "profile" "PROFILE" FACTOR-BLOB } } define-persistent -: init-users-table ( -- ) - [ user drop-table ] ignore-errors - user create-table ; +: init-users-table user ensure-table ; TUPLE: from-db ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index b3fafc543f..60bb5d921d 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -9,6 +9,13 @@ IN: http.server GENERIC: call-responder ( path responder -- response ) +: request-params ( -- assoc ) + request get dup method>> { + { "GET" [ query>> ] } + { "HEAD" [ query>> ] } + { "POST" [ post-data>> ] } + } case ; + : ( content-type -- response ) 200 >>code @@ -45,19 +52,27 @@ SYMBOL: 404-responder [ <404> ] 404-responder set-global -: url-redirect ( to query -- url ) - #! Different host. - dup assoc-empty? [ - drop - ] [ - assoc>query "?" swap 3append - ] if ; +SYMBOL: link-hook + +: modify-query ( query -- query ) + link-hook get [ ] or call ; + +: link>string ( url query -- url' ) + modify-query (link>string) ; + +: write-link ( url query -- ) + link>string write ; + +SYMBOL: form-hook + +: hidden-form-field ( -- ) + form-hook get [ ] or call ; : absolute-redirect ( to query -- url ) #! Same host. request get clone swap [ >>query ] when* - swap >>path + swap url-encode >>path request-url ; : replace-last-component ( path with -- path' ) @@ -67,11 +82,12 @@ SYMBOL: 404-responder request get clone swap [ >>query ] when* swap [ '[ , replace-last-component ] change-path ] when* + dup query>> modify-query >>query request-url ; : derive-url ( to query -- url ) { - { [ over "http://" head? ] [ url-redirect ] } + { [ over "http://" head? ] [ link>string ] } { [ over "/" head? ] [ absolute-redirect ] } { [ t ] [ relative-redirect ] } } cond ; diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index 5c2d3a57cd..5530b04611 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -2,6 +2,8 @@ IN: http.server.sessions.tests USING: tools.test http.server.sessions math namespaces kernel accessors ; +[ H{ } ] [ H{ } add-session-id ] unit-test + : with-session \ session swap with-variable ; inline TUPLE: foo ; @@ -10,7 +12,9 @@ C: foo M: foo init-session* drop 0 "x" sset ; -f [ +f "123" >>id [ + [ H{ { "factorsessid" "123" } } ] [ H{ } add-session-id ] unit-test + [ ] [ 3 "x" sset ] unit-test [ 9 ] [ "x" sget sq ] unit-test diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index 1d90a32faf..260c80914e 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs calendar kernel math.parser namespaces random boxes alarms new-slots accessors http http.server -quotations hashtables sequences fry combinators.cleave ; +quotations hashtables sequences fry combinators.cleave +html.elements ; IN: http.server.sessions ! ! ! ! ! ! @@ -67,12 +68,6 @@ TUPLE: session manager id namespace alarm ; : sessions ( -- manager/f ) \ session get dup [ manager>> ] when ; -GENERIC: session-link* ( url query sessions -- string ) - -M: object session-link* 2drop url-encode ; - -: session-link ( url query -- string ) sessions session-link* ; - TUPLE: null-sessions ; : @@ -88,23 +83,30 @@ TUPLE: url-sessions ; : sess-id "factorsessid" ; -: current-session ( responder request -- session ) - sess-id query-param swap get-session ; +: current-session ( responder -- session ) + >r request-params sess-id swap at r> get-session ; + +: add-session-id ( query -- query' ) + \ session get [ id>> sess-id associate union ] when* ; + +: session-form-field ( -- ) + > =value + input/> ; M: url-sessions call-responder ( path responder -- response ) - dup request get current-session [ + [ add-session-id ] link-hook set + [ session-form-field ] form-hook set + dup current-session [ call-responder/session ] [ nip f swap new-session sess-id associate ] if* ; -M: url-sessions session-link* - drop - url-encode - \ session get id>> sess-id associate union assoc>query - dup assoc-empty? [ drop ] [ "?" swap 3append ] if ; - TUPLE: cookie-sessions ; : ( responder -- responder' ) From acdbfeb72893837924ec7a3ec5ff0fc03aeed9b4 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 14 Mar 2008 00:17:00 -0600 Subject: [PATCH 49/83] cleave-docs: minor additions --- extra/combinators/cleave/cleave-docs.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/extra/combinators/cleave/cleave-docs.factor b/extra/combinators/cleave/cleave-docs.factor index 18968628d5..46e9abcd9f 100644 --- a/extra/combinators/cleave/cleave-docs.factor +++ b/extra/combinators/cleave/cleave-docs.factor @@ -7,10 +7,18 @@ IN: combinators.cleave ARTICLE: "cleave-combinators" "Cleave Combinators" +"Basic cleavers:" + { $subsection bi } { $subsection tri } + +"General cleave: " { $subsection cleave } +"Cleave combinators for quotations with arity 2:" +{ $subsection 2bi } +{ $subsection 2tri } + { $notes "From the Merriam-Webster Dictionary: " $nl @@ -56,6 +64,10 @@ HELP: cleave ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +{ bi tri cleave 2bi 2tri } related-words + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ARTICLE: "spread-combinators" "Spread Combinators" { $subsection bi* } From 628e213a20484b521492dd3968b7be205a06feaf Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 14 Mar 2008 00:17:17 -0600 Subject: [PATCH 50/83] builder: fix bug --- extra/builder/benchmark/benchmark.factor | 2 +- extra/builder/builder.factor | 4 ++++ extra/builder/test/test.factor | 22 +++++++++++----------- 3 files changed, 16 insertions(+), 12 deletions(-) diff --git a/extra/builder/benchmark/benchmark.factor b/extra/builder/benchmark/benchmark.factor index 48891593d2..444e5b6ea7 100644 --- a/extra/builder/benchmark/benchmark.factor +++ b/extra/builder/benchmark/benchmark.factor @@ -21,7 +21,7 @@ IN: builder.benchmark [ benchmark-difference ] with map ; : benchmark-deltas ( -- table ) - "../../benchmarks" "../benchmarks" [ eval-file ] 2apply + "../benchmarks" "benchmarks" [ eval-file ] 2apply compare-tables sort-values ; diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index da96e51dd4..52150b07a8 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -4,6 +4,7 @@ USING: kernel namespaces sequences splitting system combinators continuations bootstrap.image benchmark vars bake smtp builder.util accessors io.encodings.utf8 calendar + tools.test builder.common builder.benchmark builder.release ; @@ -131,7 +132,10 @@ SYMBOL: build-status "Test time: " write "test-time" eval-file milli-seconds>time print nl "Did not pass load-everything: " print "load-everything-vocabs" cat + "Did not pass test-all: " print "test-all-vocabs" cat + "test-all-vocabs" eval-file test-failures. + "help-lint results:" print "help-lint" cat "Benchmarks: " print "benchmarks" eval-file benchmarks. diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index 409d0db11c..54c40f18c8 100755 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -16,18 +16,18 @@ IN: builder.test : do-load ( -- ) try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ; -! : do-tests ( -- ) -! run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ; - : do-tests ( -- ) - run-all-tests - "../test-all-vocabs" utf8 - [ - [ keys . ] - [ test-failures. ] - bi - ] - with-file-writer ; + run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ; + +! : do-tests ( -- ) +! run-all-tests +! "../test-all-vocabs" utf8 +! [ +! [ keys . ] +! [ test-failures. ] +! bi +! ] +! with-file-writer ; : do-help-lint ( -- ) "" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ; From 5b0244104099919d76423f3ec34a3e1a3fae5724 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 14 Mar 2008 02:24:42 -0500 Subject: [PATCH 51/83] Add missing types --- extra/unix/types/freebsd/freebsd.factor | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) mode change 100644 => 100755 extra/unix/types/freebsd/freebsd.factor diff --git a/extra/unix/types/freebsd/freebsd.factor b/extra/unix/types/freebsd/freebsd.factor old mode 100644 new mode 100755 index 8d2d11e8ee..6e01ae9fd5 --- a/extra/unix/types/freebsd/freebsd.factor +++ b/extra/unix/types/freebsd/freebsd.factor @@ -2,6 +2,10 @@ USING: alien.syntax ; IN: unix.types +! FreeBSD 7 x86.32 + +! Need to verify on 64-bit + TYPEDEF: ushort __uint16_t TYPEDEF: uint __uint32_t TYPEDEF: int __int32_t @@ -16,4 +20,7 @@ TYPEDEF: __uint32_t gid_t TYPEDEF: __int64_t off_t TYPEDEF: __int64_t blkcnt_t TYPEDEF: __uint32_t blksize_t -TYPEDEF: __uint32_t fflags_t \ No newline at end of file +TYPEDEF: __uint32_t fflags_t +TYPEDEF: int ssize_t +TYPEDEF: int pid_t +TYPEDEF: int time_t \ No newline at end of file From 90f8aa3136d994dd027370bf554fbe01bdbb2efe Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 14 Mar 2008 02:27:43 -0500 Subject: [PATCH 52/83] Fix regressions --- core/bootstrap/primitives.factor | 6 ++++++ extra/io/mmap/mmap-tests.factor | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index b900b2fd49..52067b888c 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -301,6 +301,12 @@ define-builtin "f" "syntax" lookup builtins get remove [ ] subset f union-class define-class +"f" "syntax" create [ not ] "predicate" set-word-prop +"f?" "syntax" create "syntax" vocab-words delete-at + +"general-t" "kernel" create [ ] "predicate" set-word-prop +"general-t?" "kernel" create "syntax" vocab-words delete-at + ! Catch-all class for providing a default method. "object" "kernel" create [ drop t ] "predicate" set-word-prop "object" "kernel" create diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index c75c7b9bd4..b17d7aeab9 100755 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -4,7 +4,7 @@ IN: io.mmap.tests [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors [ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test -[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test +[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test [ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] with-mapped-file ] unit-test [ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors From c13d759ec684c44b1365988724159a5a1fb0bfc8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 14 Mar 2008 02:27:51 -0500 Subject: [PATCH 53/83] Cleanup --- extra/pack/pack.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/pack/pack.factor b/extra/pack/pack.factor index a2958d5bea..f5ba0fd11d 100755 --- a/extra/pack/pack.factor +++ b/extra/pack/pack.factor @@ -88,7 +88,7 @@ M: string b, ( n string -- ) heap-size b, ; read [ zero? ] right-trim dup empty? [ drop f ] when ; : (read-128-ber) ( n -- n ) - 1 read first + read1 [ >r 7 shift r> 7 clear-bit bitor ] keep 7 bit? [ (read-128-ber) ] when ; From dcda3d5bcfdaa79c34eaba04030eca7e8096d902 Mon Sep 17 00:00:00 2001 From: sheeple Date: Fri, 14 Mar 2008 01:36:30 -0500 Subject: [PATCH 54/83] Fix FreeBSD --- Makefile | 4 ++-- extra/io/unix/freebsd/freebsd.factor | 2 +- misc/_target | 20 ++++++++++++++++++++ misc/target | 9 ++++++--- 4 files changed, 29 insertions(+), 6 deletions(-) create mode 100755 misc/_target diff --git a/Makefile b/Makefile index 6f12633871..054d57b641 100755 --- a/Makefile +++ b/Makefile @@ -46,10 +46,10 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ EXE_OBJS = $(PLAF_EXE_OBJS) default: misc/wordsize - make `./misc/target` + $(MAKE) `./misc/target` help: - @echo "Run 'make' with one of the following parameters:" + @echo "Run '$(MAKE)' with one of the following parameters:" @echo "" @echo "freebsd-x86-32" @echo "freebsd-x86-64" diff --git a/extra/io/unix/freebsd/freebsd.factor b/extra/io/unix/freebsd/freebsd.factor index 2aad0bdb1a..65b4a6f0f7 100644 --- a/extra/io/unix/freebsd/freebsd.factor +++ b/extra/io/unix/freebsd/freebsd.factor @@ -1,5 +1,5 @@ IN: io.unix.freebsd -USING: io.unix.bsd io.backend core-foundation.fsevents ; +USING: io.unix.bsd io.backend ; TUPLE: freebsd-io ; diff --git a/misc/_target b/misc/_target new file mode 100755 index 0000000000..2be071c17d --- /dev/null +++ b/misc/_target @@ -0,0 +1,20 @@ +#!/bin/bash + +if [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ] +then + echo macosx-ppc +elif [ `uname -s` = Darwin ] +then + echo macosx-x86-`./misc/wordsize` +elif [ \( `uname -s` = Linux \) -a \( `uname -m` = i686 \) ] +then + echo linux-x86-32 +elif [ \( `uname -s` = Linux \) -a \( `uname -m` = x86_64 \) ] +then + echo linux-x86-64 +elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ] +then + echo winnt-x86-`./misc/wordsize` +else + echo help +fi \ No newline at end of file diff --git a/misc/target b/misc/target index 2be071c17d..880de8f47a 100755 --- a/misc/target +++ b/misc/target @@ -1,6 +1,9 @@ -#!/bin/bash +#!/bin/sh -if [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ] +if [ \( `uname -s ` = FreeBSD \) -a \( `uname -p` = i386 \) ] +then + echo freebsd-x86-32 +elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ] then echo macosx-ppc elif [ `uname -s` = Darwin ] @@ -17,4 +20,4 @@ then echo winnt-x86-`./misc/wordsize` else echo help -fi \ No newline at end of file +fi From 5c783e4f6fe66f199c6f551ae6629faa5323f165 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 14 Mar 2008 01:26:39 -0600 Subject: [PATCH 55/83] builder.test: fix bug --- extra/builder/test/test.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) mode change 100755 => 100644 extra/builder/test/test.factor diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor old mode 100755 new mode 100644 index 54c40f18c8..3634082f56 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -16,8 +16,14 @@ IN: builder.test : do-load ( -- ) try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ; +! : do-tests ( -- ) +! run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ; + : do-tests ( -- ) - run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ; + run-all-tests + [ keys "../test-all-vocabs" utf8 [ . ] with-file-writer ] + [ "../test-failures" utf8 [ test-failures. ] with-file-writer ] + bi ; ! : do-tests ( -- ) ! run-all-tests From f1ba5e8368f51c6b39b593407a6a2cca7fd5317a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 14 Mar 2008 02:36:27 -0500 Subject: [PATCH 56/83] Remove obsolete file --- misc/_target | 20 -------------------- 1 file changed, 20 deletions(-) delete mode 100755 misc/_target diff --git a/misc/_target b/misc/_target deleted file mode 100755 index 2be071c17d..0000000000 --- a/misc/_target +++ /dev/null @@ -1,20 +0,0 @@ -#!/bin/bash - -if [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ] -then - echo macosx-ppc -elif [ `uname -s` = Darwin ] -then - echo macosx-x86-`./misc/wordsize` -elif [ \( `uname -s` = Linux \) -a \( `uname -m` = i686 \) ] -then - echo linux-x86-32 -elif [ \( `uname -s` = Linux \) -a \( `uname -m` = x86_64 \) ] -then - echo linux-x86-64 -elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ] -then - echo winnt-x86-`./misc/wordsize` -else - echo help -fi \ No newline at end of file From 8a2e52a10b67c7fb61241502fdceab7bff93f42b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 14 Mar 2008 10:54:20 -0600 Subject: [PATCH 57/83] builder: fix bug --- extra/builder/builder.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 52150b07a8..7d95ce2409 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -134,7 +134,9 @@ SYMBOL: build-status "Did not pass load-everything: " print "load-everything-vocabs" cat "Did not pass test-all: " print "test-all-vocabs" cat - "test-all-vocabs" eval-file test-failures. + "test-failures" cat + +! "test-failures" eval-file test-failures. "help-lint results:" print "help-lint" cat From 080628af9ff52d6ca01fff09900310d4c26d37c2 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 14 Mar 2008 10:54:46 -0600 Subject: [PATCH 58/83] fix ldap and openssl on unix --- extra/ldap/libldap/libldap.factor | 4 ++-- extra/openssl/libcrypto/libcrypto.factor | 4 ++-- extra/openssl/libssl/libssl.factor | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/ldap/libldap/libldap.factor b/extra/ldap/libldap/libldap.factor index ae613bd461..6db6884071 100755 --- a/extra/ldap/libldap/libldap.factor +++ b/extra/ldap/libldap/libldap.factor @@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ; IN: ldap.libldap << "libldap" { - { [ win32? ] [ "libldap.dll" "stdcall" ] } + { [ win32? ] [ "libldap.dll" "stdcall" ] } { [ macosx? ] [ "libldap.dylib" "cdecl" ] } - { [ unix? ] [ "$LD_LIBRARY_PATH/libldap.so" "cdecl" ] } + { [ unix? ] [ "libldap.so" "cdecl" ] } } cond add-library >> : LDAP_VERSION1 1 ; inline diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor index 8378a11956..7b3ad2cf9f 100755 --- a/extra/openssl/libcrypto/libcrypto.factor +++ b/extra/openssl/libcrypto/libcrypto.factor @@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ; IN: openssl.libcrypto "libcrypto" { - { [ win32? ] [ "libeay32.dll" "stdcall" ] } + { [ win32? ] [ "libeay32.dll" "stdcall" ] } { [ macosx? ] [ "libcrypto.dylib" "cdecl" ] } - { [ unix? ] [ "$LD_LIBRARY_PATH/libcrypto.so" "cdecl" ] } + { [ unix? ] [ "libcrypto.so" "cdecl" ] } } cond add-library C-STRUCT: bio-method diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor index 8d1b3b5247..d8709cbf53 100644 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ; IN: openssl.libssl << "libssl" { - { [ win32? ] [ "ssleay32.dll" "stdcall" ] } + { [ win32? ] [ "ssleay32.dll" "stdcall" ] } { [ macosx? ] [ "libssl.dylib" "cdecl" ] } - { [ unix? ] [ "$LD_LIBRARY_PATH/libssl.so" "cdecl" ] } + { [ unix? ] [ "libssl.so" "cdecl" ] } } cond add-library >> : X509_FILETYPE_PEM 1 ; inline From d6fb777e508aad4d7785515e99c7dd3fd45c69ef Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 14 Mar 2008 12:56:36 -0500 Subject: [PATCH 59/83] write a replace word and 2seq>assoc --- extra/assocs/lib/lib.factor | 5 ++++- extra/sequences/lib/lib.factor | 6 +++++- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 88095759e6..d2eb42a117 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -1,4 +1,4 @@ -USING: assocs kernel vectors sequences namespaces ; +USING: arrays assocs kernel vectors sequences namespaces ; IN: assocs.lib : >set ( seq -- hash ) @@ -35,3 +35,6 @@ IN: assocs.lib [ with each ] curry assoc-each ; inline : insert ( value variable -- ) namespace insert-at ; + +: 2seq>assoc ( keys values exemplar -- assoc ) + >r 2array flip r> assoc-like ; diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 050de0ae1c..fe0ee52ff4 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -3,7 +3,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: combinators.lib kernel sequences math namespaces assocs random sequences.private shuffle math.functions mirrors -arrays math.parser math.private sorting strings ascii macros ; +arrays math.parser math.private sorting strings ascii macros +assocs.lib ; IN: sequences.lib : each-withn ( seq quot n -- ) nwith each ; inline @@ -220,3 +221,6 @@ PRIVATE> : nths ( indices seq -- seq' ) [ swap nth ] with map ; + +: replace ( str oldseq newseq -- str' ) + H{ } 2seq>assoc [ dupd at* [ nip ] [ drop ] if ] curry map ; From 21d52749a27149aa44fd3f7c87a62d91ab0bdaa2 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 14 Mar 2008 12:58:10 -0600 Subject: [PATCH 60/83] io.files: 'directory?' uses file-info --- core/io/files/files.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 3ab489739b..18cdbd3791 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -94,7 +94,9 @@ SYMBOL: +unknown+ : exists? ( path -- ? ) file-modified >boolean ; -: directory? ( path -- ? ) stat 3drop ; +! : directory? ( path -- ? ) stat 3drop ; + +: directory? ( path -- ? ) file-info file-info-type +directory+ = ; ! Current working directory HOOK: cd io-backend ( path -- ) From 02758aeadbac0ebe4c93d2284cc3cab1bc80d93b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 14 Mar 2008 12:59:17 -0600 Subject: [PATCH 61/83] combinators.cleave: and --- extra/combinators/cleave/cleave.factor | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index fd66536c12..049c8bf2a9 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -70,3 +70,29 @@ MACRO: spread ( seq -- ) swap [ [ r> ] swap append ] map concat append ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Cleave into array +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USING: words quotations fry arrays.lib ; + +: >quot ( obj -- quot ) dup word? [ 1quotation ] when ; + +: >quots ( seq -- seq ) [ >quot ] map ; + +MACRO: ( seq -- ) + [ >quots ] [ length ] bi + '[ , cleave , narray ] ; + +MACRO: <2arr> ( seq -- ) + [ >quots ] [ length ] bi + '[ , 2cleave , narray ] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Spread into array +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MACRO: ( seq -- ) + [ >quots ] [ length ] bi + '[ , spread , narray ] ; From 2029be73440b86b9a1b8e037cc79e4224ddc5eb4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 14 Mar 2008 16:44:40 -0500 Subject: [PATCH 62/83] better replace word --- extra/sequences/lib/lib.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index fe0ee52ff4..13e8eb949f 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -223,4 +223,4 @@ PRIVATE> [ swap nth ] with map ; : replace ( str oldseq newseq -- str' ) - H{ } 2seq>assoc [ dupd at* [ nip ] [ drop ] if ] curry map ; + H{ } 2seq>assoc substitute ; From f1cadef89d747975d44a726bac3b6490718d8800 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 14 Mar 2008 17:39:57 -0500 Subject: [PATCH 63/83] More deployment fixes --- extra/hello-world/deploy.factor | 14 +++++++------- extra/sudoku/deploy.factor | 17 +++++++++-------- extra/tools/deploy/backend/backend.factor | 12 +++++++----- extra/tools/deploy/deploy-tests.factor | 23 +++++++++++++---------- extra/tools/deploy/shaker/shaker.factor | 7 ++++--- 5 files changed, 40 insertions(+), 33 deletions(-) diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 45d19cb891..2341aabc9d 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,14 +1,14 @@ USING: tools.deploy.config ; H{ - { deploy-io 2 } - { deploy-math? f } - { deploy-threads? f } - { deploy-compiler? f } - { deploy-word-props? f } - { deploy-word-defs? f } { deploy-name "Hello world (console)" } - { deploy-reflection 2 } + { deploy-threads? f } { deploy-c-types? f } + { deploy-compiler? f } { deploy-ui? f } + { deploy-math? f } + { deploy-reflection 1 } + { deploy-word-defs? f } + { deploy-io 2 } + { deploy-word-props? f } { "stop-after-last-window?" t } } diff --git a/extra/sudoku/deploy.factor b/extra/sudoku/deploy.factor index de60bed20b..11a06f46bc 100755 --- a/extra/sudoku/deploy.factor +++ b/extra/sudoku/deploy.factor @@ -1,13 +1,14 @@ USING: tools.deploy.config ; H{ - { deploy-reflection 2 } - { deploy-word-props? f } - { deploy-compiler? t } - { deploy-math? f } - { deploy-c-types? f } - { deploy-io 2 } - { deploy-ui? f } { deploy-name "Sudoku" } - { "stop-after-last-window?" t } + { deploy-threads? f } + { deploy-c-types? f } + { deploy-compiler? t } + { deploy-ui? f } + { deploy-math? f } + { deploy-reflection 1 } { deploy-word-defs? f } + { deploy-io 2 } + { deploy-word-props? f } + { "stop-after-last-window?" t } } diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 15dc32115e..60dc11257f 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -65,8 +65,12 @@ IN: tools.deploy.backend : run-factor ( vm flags -- ) swap add* dup . run-with-output ; inline -: make-staging-image ( vm config -- ) - staging-command-line run-factor ; +: make-staging-image ( config -- ) + vm swap staging-command-line run-factor ; + +: ?make-staging-image ( config -- ) + dup [ staging-image-name ] bind exists? + [ drop ] [ make-staging-image ] if ; : deploy-command-line ( image vocab config -- flags ) [ @@ -85,9 +89,7 @@ IN: tools.deploy.backend : make-deploy-image ( vm image vocab config -- ) make-boot-image - dup staging-image-name exists? [ - >r pick r> tuck make-staging-image - ] unless + dup ?make-staging-image deploy-command-line run-factor ; SYMBOL: deploy-implementation diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index a6e126ea9e..6d3385d0a4 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -1,44 +1,47 @@ IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config -tools.deploy.backend math sequences io.launcher ; +tools.deploy.backend math sequences io.launcher arrays ; -: shake-and-bake +: shake-and-bake ( vocab -- ) "." resource-path [ - vm + >r vm "test.image" temp-file - rot dup deploy-config make-deploy-image + r> dup deploy-config make-deploy-image ] with-directory ; +: small-enough? ( n -- ? ) + >r "test.image" temp-file file-info file-info-size r> <= ; + [ ] [ "hello-world" shake-and-bake ] unit-test [ t ] [ - "hello.image" temp-file file-info file-info-size 500000 <= + 500000 small-enough? ] unit-test [ ] [ "sudoku" shake-and-bake ] unit-test [ t ] [ - "hello.image" temp-file file-info file-info-size 1500000 <= + 1500000 small-enough? ] unit-test [ ] [ "hello-ui" shake-and-bake ] unit-test [ t ] [ - "hello.image" temp-file file-info file-info-size 2000000 <= + 2000000 small-enough? ] unit-test [ ] [ "bunny" shake-and-bake ] unit-test [ t ] [ - "hello.image" temp-file file-info file-info-size 3000000 <= + 3000000 small-enough? ] unit-test [ ] [ "tools.deploy.test.1" shake-and-bake - vm "-i=" "test.image" temp-file append try-process + vm "-i=" "test.image" temp-file append 2array try-process ] unit-test [ ] [ "tools.deploy.test.2" shake-and-bake - vm "-i=" "test.image" temp-file append try-process + vm "-i=" "test.image" temp-file append 2array try-process ] unit-test diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index bddf3d76c9..edf78de479 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -13,7 +13,6 @@ QUALIFIED: definitions QUALIFIED: init QUALIFIED: inspector QUALIFIED: io.backend -QUALIFIED: io.nonblocking QUALIFIED: io.thread QUALIFIED: layouts QUALIFIED: libc.private @@ -133,8 +132,10 @@ IN: tools.deploy.shaker strip-io? [ io.backend:io-backend , ] when - { io.backend:io-backend io.nonblocking:default-buffer-size } - { "alarms" "io" "tools" } strip-vocab-globals % + [ + io.backend:io-backend + "default-buffer-size" "io.nonblocking" lookup , + ] { "alarms" "io" "tools" } strip-vocab-globals % strip-dictionary? [ { } { "cpu" } strip-vocab-globals % From 16244ab15aeed1523d72af0891055ef74ea50598 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 14 Mar 2008 17:40:08 -0500 Subject: [PATCH 64/83] Run dtors in reverse order --- extra/destructors/destructors.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor index b2561c7439..1b98d2ee0d 100755 --- a/extra/destructors/destructors.factor +++ b/extra/destructors/destructors.factor @@ -26,11 +26,14 @@ M: destructor dispose : add-always-destructor ( obj -- ) always-destructors get push ; +: dispose-each ( seq -- ) + [ dispose ] each ; + : do-always-destructors ( -- ) - always-destructors get [ dispose ] each ; + always-destructors get dispose-each ; : do-error-destructors ( -- ) - error-destructors get [ dispose ] each ; + error-destructors get dispose-each ; : with-destructors ( quot -- ) [ From d6d71aeb131160e3a643393aabd470876aae0af3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 14 Mar 2008 17:40:47 -0500 Subject: [PATCH 65/83] Fixing httpd bugs --- extra/http/server/actions/actions.factor | 5 - .../http/server/auth/login/edit-profile.fhtml | 77 ++++++++++++ extra/http/server/auth/login/login.factor | 110 ++++++++++++++---- extra/http/server/auth/login/recover-3.fhtml | 2 +- extra/http/server/auth/login/register.fhtml | 2 +- .../server/auth/providers/providers.factor | 4 +- .../server/components/components-tests.factor | 13 +++ .../http/server/components/components.factor | 16 +-- .../server/validators/validators-tests.factor | 6 +- .../http/server/validators/validators.factor | 33 +++--- 10 files changed, 212 insertions(+), 56 deletions(-) create mode 100755 extra/http/server/auth/login/edit-profile.fhtml diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index 72c2d2df8e..7bee96edce 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -17,11 +17,6 @@ TUPLE: action init display submit get-params post-params ; [ <400> ] >>display [ <400> ] >>submit ; -: with-validator ( string quot -- result error? ) - '[ , @ f ] [ - dup validation-error? [ t ] [ rethrow ] if - ] recover ; inline - : validate-param ( name validator assoc -- error? ) swap pick >r >r at r> with-validator swap r> set ; diff --git a/extra/http/server/auth/login/edit-profile.fhtml b/extra/http/server/auth/login/edit-profile.fhtml new file mode 100755 index 0000000000..7d94ca1791 --- /dev/null +++ b/extra/http/server/auth/login/edit-profile.fhtml @@ -0,0 +1,77 @@ +<% USING: http.server.components http.server.auth.login +http.server namespaces kernel combinators ; %> + + +

Edit profile

+ + +<% hidden-form-field %> + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
User name:<% "username" component render-view %>
Real name:<% "realname" component render-edit %>
Specifying a real name is optional.
Current password:<% "password" component render-edit %>
If you don't want to change your current password, leave this field blank.
New password:<% "new-password" component render-edit %>
Verify:<% "verify-password" component render-edit %>
If you are changing your password, enter it twice to ensure it is correct.
E-mail:<% "email" component render-edit %>
Specifying an e-mail address is optional. It enables the "recover password" feature.
+ +

+ +<% { + { [ login-failed? get ] [ "invalid password" render-error ] } + { [ password-mismatch? get ] [ "passwords do not match" render-error ] } + { [ t ] [ ] } +} cond %> + +

+ +
+ + + diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 9b2648158d..8842e1639e 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -13,6 +13,8 @@ QUALIFIED: smtp TUPLE: login users ; +: users login get users>> ; + SYMBOL: post-login-url SYMBOL: login-failed? @@ -49,7 +51,7 @@ SYMBOL: login-failed? form validate-form "password" value "username" value - login get users>> check-login [ + users check-login [ successful-login ] [ login-failed? on @@ -67,7 +69,7 @@ SYMBOL: login-failed? t >>required add-field "realname" add-field - "password" + "new-password" t >>required add-field "verify-password" @@ -80,7 +82,7 @@ SYMBOL: password-mismatch? SYMBOL: user-exists? : same-password-twice ( -- ) - "password" value "verify-password" value = [ + "new-password" value "verify-password" value = [ password-mismatch? on validation-failed ] unless ; @@ -102,14 +104,13 @@ SYMBOL: user-exists? same-password-twice - values get [ - "username" get >>username - "realname" get >>realname - "password" get >>password - "email" get >>email - ] bind + + "username" value >>username + "realname" value >>realname + "new-password" value >>password + "email" value >>email - login get users>> new-user [ + users new-user [ user-exists? on validation-failed ] unless* @@ -118,6 +119,64 @@ SYMBOL: user-exists? ] >>submit ] ; +! ! ! Editing user profile + +: ( -- form ) + "edit-profile"
+ "resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template + "username" add-field + "realname" add-field + "password" add-field + "new-password" add-field + "verify-password" add-field + "email" add-field ; + +SYMBOL: previous-page + +:: ( -- action ) + [let | form [ ] | + + [ + blank-values + logged-in-user sget + dup username>> "username" set-value + dup realname>> "realname" set-value + dup email>> "email" set-value + ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + blank-values + uid "username" set-value + + form validate-form + + "password" value empty? [ + logged-in-user sget + ] [ + same-password-twice + + "password" value uid users check-login + [ login-failed? on validation-failed ] unless + + "new-password" value uid users set-password + [ "User deleted" throw ] unless* + ] if + + "realname" value >>realname + "email" value >>email + + dup users update-user + logged-in-user sset + + previous-page sget dup [ f ] when + ] >>submit + ] ; + ! ! ! Password recovery SYMBOL: lost-password-from @@ -186,7 +245,7 @@ SYMBOL: lost-password-from form validate-form "email" value "username" value - login get users>> issue-ticket [ + users issue-ticket [ send-password-email ] when* @@ -200,7 +259,7 @@ SYMBOL: lost-password-from "username" t >>required add-field - "password" + "new-password" t >>required add-field "verify-password" @@ -239,9 +298,9 @@ SYMBOL: lost-password-from "ticket" value "username" value - login get users>> claim-ticket [ - "password" value >>password - login get users>> update-user + users claim-ticket [ + "new-password" value >>password + users update-user "resource:extra/http/server/auth/login/recover-4.fhtml" serve-template @@ -265,13 +324,18 @@ TUPLE: protected responder ; C: protected +: show-login-page ( -- response ) + request get request-url post-login-url sset + "login" f ; + M: protected call-responder ( path responder -- response ) - logged-in-user sget [ responder>> call-responder ] [ + logged-in-user sget [ + request get request-url previous-page sset + responder>> call-responder + ] [ 2drop - request get method>> { "GET" "HEAD" } member? [ - request get request-url post-login-url sset - "login" f - ] [ <400> ] if + request get method>> { "GET" "HEAD" } member? + [ show-login-page ] [ <400> ] if ] if ; M: login call-responder ( path responder -- response ) @@ -287,6 +351,9 @@ M: login call-responder ( path responder -- response ) ! ! ! Configuration +: allow-edit-profile ( login -- login ) + "edit-profile" add-responder ; + : allow-registration ( login -- login ) "register" add-responder ; @@ -294,6 +361,9 @@ M: login call-responder ( path responder -- response ) "recover-password" add-responder "new-password" add-responder ; +: allow-edit-profile? ( -- ? ) + login get responders>> "edit-profile" swap key? ; + : allow-registration? ( -- ? ) login get responders>> "register" swap key? ; diff --git a/extra/http/server/auth/login/recover-3.fhtml b/extra/http/server/auth/login/recover-3.fhtml index edd32fffe8..ca4823baab 100755 --- a/extra/http/server/auth/login/recover-3.fhtml +++ b/extra/http/server/auth/login/recover-3.fhtml @@ -17,7 +17,7 @@ namespaces kernel combinators ; %> Password: -<% "password" component render-edit %> +<% "new-password" component render-edit %> diff --git a/extra/http/server/auth/login/register.fhtml b/extra/http/server/auth/login/register.fhtml index 99d1547d03..9106497def 100755 --- a/extra/http/server/auth/login/register.fhtml +++ b/extra/http/server/auth/login/register.fhtml @@ -26,7 +26,7 @@ http.server namespaces kernel combinators ; %> Password: -<% "password" component render-edit %> +<% "new-password" component render-edit %> diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor index 0aa27f870d..74620a4f5d 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/http/server/auth/providers/providers.factor @@ -17,12 +17,12 @@ GENERIC: new-user ( user provider -- user/f ) : check-login ( password username provider -- user/f ) get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ; -:: set-password ( password username provider -- ? ) +:: set-password ( password username provider -- user/f ) [let | user [ username provider get-user ] | user [ user password >>password - provider update-user t + provider dup update-user ] [ f ] if ] ; diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor index 2a507e6416..83ae7b0118 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -86,3 +86,16 @@ TUPLE: test-tuple text number more-text ; [ t ] [ "number" value validation-error? ] unit-test ] with-scope + +[ + [ ] [ + "n" + 0 >>min-value + 10 >>max-value + "n" set + ] unit-test + + [ "123" ] [ + "123" "n" get validate value>> + ] unit-test +] with-scope diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index bb0fc4b3dd..df46259c14 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -7,8 +7,6 @@ http.server.actions splitting mirrors hashtables combinators.cleave fry continuations math ; IN: http.server.components -SYMBOL: validation-failed? - SYMBOL: components TUPLE: component id required default ; @@ -30,16 +28,13 @@ SYMBOL: values : validate ( value component -- result ) '[ - , , + , over empty? [ [ default>> [ v-default ] when* ] [ required>> [ v-required ] when ] bi ] [ validate* ] if - ] [ - dup validation-error? - [ validation-failed? on ] [ rethrow ] if - ] recover ; + ] with-validator ; : render-view ( component -- ) [ id>> value ] [ render-view* ] bi ; @@ -215,7 +210,12 @@ M: number render-error* ! Text areas TUPLE: text ; -: ( id -- component ) text construct-delegate ; +: ( id -- component ) text ; + +M: text validate* 2drop ; + +M: text render-view* + drop write ; : render-textarea