From bb2453de0d705e96e4964797cd7bcf62998a6642 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Apr 2008 18:06:01 -0500 Subject: [PATCH 01/18] Document multi-touch gestures --- extra/ui/gestures/gestures.factor | 12 ++++++++++++ extra/ui/tools/tools-docs.factor | 8 ++++++-- 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index 195bf42f6e..2eb165c186 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -281,4 +281,16 @@ M: button-down gesture>string button-down-# [ " " % # ] when* ] "" make ; +M: left-action gesture>string drop "Swipe left" ; + +M: right-action gesture>string drop "Swipe right" ; + +M: up-action gesture>string drop "Swipe up" ; + +M: down-action gesture>string drop "Swipe down" ; + +M: zoom-in-action gesture>string drop "Zoom in" ; + +M: zoom-out-action gesture>string drop "Zoom out (pinch)" ; + M: object gesture>string drop f ; diff --git a/extra/ui/tools/tools-docs.factor b/extra/ui/tools/tools-docs.factor index 57ad16bf70..4a8e1ddf4a 100755 --- a/extra/ui/tools/tools-docs.factor +++ b/extra/ui/tools/tools-docs.factor @@ -2,8 +2,9 @@ USING: editors help.markup help.syntax inspector io listener parser prettyprint tools.profiler tools.walker ui.commands ui.gadgets.editors ui.gadgets.panes ui.gadgets.presentations ui.gadgets.slots ui.operations ui.tools.browser -ui.tools.interactor ui.tools.listener ui.tools.operations -ui.tools.profiler ui.tools.walker ui.tools.workspace vocabs ; +ui.tools.interactor ui.tools.inspector ui.tools.listener +ui.tools.operations ui.tools.profiler ui.tools.walker +ui.tools.workspace vocabs ; IN: ui.tools ARTICLE: "ui-presentations" "Presentations in the UI" @@ -46,12 +47,14 @@ $nl $nl "The slot editor has a toolbar containing various commands." { $command-map slot-editor "toolbar" } +{ $command-map inspector-gadget "multi-touch" } "The following commands are also available." { $command-map source-editor "word" } ; ARTICLE: "ui-browser" "UI browser" "The browser is used to display Factor code, documentation, and vocabularies." { $command-map browser-gadget "toolbar" } +{ $command-map browser-gadget "multi-touch" } "Browsers are instances of " { $link browser-gadget } "." ; ARTICLE: "ui-profiler" "UI profiler" @@ -110,6 +113,7 @@ ARTICLE: "ui-workspace-keys" "UI keyboard shortcuts" { $command-map workspace "tool-switching" } { $command-map workspace "scrolling" } { $command-map workspace "workflow" } +{ $command-map workspace "multi-touch" } { $heading "Implementation" } "Workspaces are instances of " { $link workspace } "." ; From 615f7057e4a60112c73964c5240831a870f143ef Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Apr 2008 19:05:06 -0500 Subject: [PATCH 02/18] Omit tuple dispatch engines from usage listings --- core/compiler/compiler.factor | 2 +- core/compiler/units/units.factor | 4 ++-- .../standard/engines/tuple/tuple.factor | 18 ++++++++---------- core/generic/standard/standard-tests.factor | 13 ++++++++++++- core/words/words.factor | 6 +++++- 5 files changed, 28 insertions(+), 15 deletions(-) diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 6f75ca873d..806ea914bb 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -20,7 +20,7 @@ IN: compiler : finish-compile ( word effect dependencies -- ) >r dupd save-effect r> over compiled-unxref - over crossref? [ compiled-xref ] [ 2drop ] if ; + over compiled-crossref? [ compiled-xref ] [ 2drop ] if ; : compile-succeeded ( word -- effect dependencies ) [ diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index a780e0a745..58300b721a 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -66,7 +66,7 @@ GENERIC: definitions-changed ( assoc obj -- ) : compile ( words -- ) recompile-hook get call - dup [ drop crossref? ] assoc-contains? + dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap ; SYMBOL: outdated-tuples @@ -82,7 +82,7 @@ SYMBOL: update-tuples-hook : finish-compilation-unit ( -- ) call-recompile-hook call-update-tuples-hook - dup [ drop crossref? ] assoc-contains? modify-code-heap + dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap updated-definitions notify-definition-observers ; : with-compilation-unit ( quot -- ) diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 69d73aa872..a13cbc092d 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -63,14 +63,14 @@ M: trivial-tuple-dispatch-engine engine>quot ] "" make ; PREDICATE: tuple-dispatch-engine-word < word - "tuple-dispatch-engine" word-prop ; + "tuple-dispatch-generic" word-prop generic? ; M: tuple-dispatch-engine-word stack-effect "tuple-dispatch-generic" word-prop - [ extra-values ] [ stack-effect clone ] bi - [ length + ] change-in ; + [ extra-values ] [ stack-effect ] bi + dup [ clone [ length + ] change-in ] [ 2drop f ] if ; -M: tuple-dispatch-engine-word crossref? +M: tuple-dispatch-engine-word compiled-crossref? drop t ; : remember-engine ( word -- ) @@ -78,12 +78,10 @@ M: tuple-dispatch-engine-word crossref? : ( engine -- word ) tuple-dispatch-engine-word-name f - { - [ t "tuple-dispatch-engine" set-word-prop ] - [ generic get "tuple-dispatch-generic" set-word-prop ] - [ remember-engine ] - [ ] - } cleave ; + [ generic get "tuple-dispatch-generic" set-word-prop ] + [ remember-engine ] + [ ] + tri ; : define-tuple-dispatch-engine-word ( engine quot -- word ) >r dup r> define ; diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index a906acd324..9eb39cf16e 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -2,7 +2,8 @@ IN: generic.standard.tests USING: tools.test math math.functions math.constants generic.standard strings sequences arrays kernel accessors words float-arrays byte-arrays bit-arrays parser namespaces -quotations inference vectors growable ; +quotations inference vectors growable hashtables sbufs +prettyprint ; GENERIC: lo-tag-test @@ -268,3 +269,13 @@ M: growable call-next-hooker call-next-method "growable " prepend ; [ "vector growable sequence" ] [ V{ } my-var [ call-next-hooker ] with-variable ] unit-test + +GENERIC: no-stack-effect-decl + +M: hashtable no-stack-effect-decl ; +M: vector no-stack-effect-decl ; +M: sbuf no-stack-effect-decl ; + +[ ] [ \ no-stack-effect-decl see ] unit-test + +[ ] [ \ no-stack-effect-decl word-def . ] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index e1d2f11356..3466544eef 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -71,6 +71,10 @@ M: word crossref? word-vocabulary >boolean ] if ; +GENERIC: compiled-crossref? ( word -- ? ) + +M: word compiled-crossref? crossref? ; + GENERIC# (quot-uses) 1 ( obj assoc -- ) M: object (quot-uses) 2drop ; @@ -97,7 +101,7 @@ SYMBOL: compiled-crossref compiled-crossref global [ H{ } assoc-like ] change-at : compiled-xref ( word dependencies -- ) - [ drop crossref? ] assoc-subset + [ drop compiled-crossref? ] assoc-subset 2dup "compiled-uses" set-word-prop compiled-crossref get add-vertex* ; From ca4fc74b1fe1c213f56254af6eb128909c795ea3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Apr 2008 21:54:35 -0500 Subject: [PATCH 03/18] builder: more refactoring --- extra/builder/build/build.factor | 46 ++++ extra/builder/builder.factor | 250 +-------------------- extra/builder/child/child.factor | 70 ++++++ extra/builder/cleanup/cleanup.factor | 24 ++ extra/builder/common/common.factor | 49 +++- extra/builder/email/email.factor | 22 ++ extra/builder/release/branch/branch.factor | 2 +- extra/builder/release/release.factor | 7 +- extra/builder/report/report.factor | 35 +++ extra/builder/updates/updates.factor | 31 +++ extra/builder/util/util.factor | 23 +- 11 files changed, 303 insertions(+), 256 deletions(-) create mode 100644 extra/builder/build/build.factor create mode 100644 extra/builder/child/child.factor create mode 100644 extra/builder/cleanup/cleanup.factor create mode 100644 extra/builder/email/email.factor create mode 100644 extra/builder/report/report.factor create mode 100644 extra/builder/updates/updates.factor diff --git a/extra/builder/build/build.factor b/extra/builder/build/build.factor new file mode 100644 index 0000000000..e9f58980ea --- /dev/null +++ b/extra/builder/build/build.factor @@ -0,0 +1,46 @@ + +USING: io.files io.launcher io.encodings.utf8 prettyprint + builder.util builder.common builder.child builder.release + builder.report builder.email builder.cleanup ; + +IN: builder.build + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: create-build-dir ( -- ) + datestamp >stamp + build-dir make-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: enter-build-dir ( -- ) build-dir set-current-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: clone-builds-factor ( -- ) + { "git" "clone" builds/factor } to-strings try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: record-id ( -- ) + "factor" + [ git-id "../git-id" utf8 [ . ] with-file-writer ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: build ( -- ) + reset-status + create-build-dir + enter-build-dir + clone-builds-factor + record-id + build-child + release + report + email-report + cleanup ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: build \ No newline at end of file diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index d81b934f2c..29daa8160b 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,259 +1,21 @@ -USING: kernel namespaces sequences splitting system combinators continuations - parser io io.files io.launcher io.sockets prettyprint threads - bootstrap.image benchmark vars bake smtp builder.util accessors - debugger io.encodings.utf8 - calendar - tools.test +USING: kernel debugger io.files threads calendar builder.common - builder.benchmark - builder.release ; + builder.updates + builder.build ; IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: cd ( path -- ) set-current-directory ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: builds/factor ( -- path ) builds "factor" append-path ; -: build-dir ( -- path ) builds stamp> append-path ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: prepare-build-machine ( -- ) - builds make-directory - builds - [ - { "git" "clone" "git://factorcode.org/git/factor.git" } try-process - ] - with-directory ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: git-clone ( -- desc ) { "git" "clone" "../factor" } ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: enter-build-dir ( -- ) - datestamp >stamp - builds cd - stamp> make-directory - stamp> cd ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: git-id ( -- id ) - { "git" "show" } utf8 - [ readln ] with-stream " " split second ; - -: record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: gnu-make ( -- string ) - os { freebsd openbsd netbsd } member? - [ "gmake" ] - [ "make" ] - if ; - -: do-make-clean ( -- ) { gnu-make "clean" } to-strings try-process ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: make-vm ( -- desc ) - - { gnu-make } to-strings >>command - "../compile-log" >>stdout - +stdout+ >>stderr ; - -: do-make-vm ( -- ) - make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: copy-image ( -- ) - builds/factor my-boot-image-name append-path ".." copy-file-into - builds/factor my-boot-image-name append-path "." copy-file-into ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: bootstrap-cmd ( -- cmd ) - { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ; - -: bootstrap ( -- desc ) - - bootstrap-cmd >>command - +closed+ >>stdin - "../boot-log" >>stdout - +stdout+ >>stderr - 60 minutes >>timeout ; - -: do-bootstrap ( -- ) - bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ; - -: builder-test-cmd ( -- cmd ) - { "./factor" "-run=builder.test" } to-strings ; - -: builder-test ( -- desc ) - - builder-test-cmd >>command - +closed+ >>stdin - "../test-log" >>stdout - +stdout+ >>stderr - 240 minutes >>timeout ; - -: do-builder-test ( -- ) - builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -SYMBOL: build-status - -: (build) ( -- ) - - builds-check - - build-status off - - enter-build-dir - - "report" utf8 - [ - "Build machine: " write host-name print - "CPU: " write cpu . - "OS: " write os . - "Build directory: " write current-directory get print - - git-clone [ "git clone failed" print ] run-or-bail - - "factor" - [ - record-git-id - do-make-clean - do-make-vm - copy-image - do-bootstrap - do-builder-test - ] - with-directory - - "test-log" delete-file - - "git id: " write "git-id" eval-file print nl - - "Boot time: " write "boot-time" eval-file milli-seconds>time print - "Load time: " write "load-time" eval-file milli-seconds>time print - "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-failures" cat - - "help-lint results:" print "help-lint" cat - - "Benchmarks: " print "benchmarks" eval-file benchmarks. - - nl - - show-benchmark-deltas - - "benchmarks" ".." copy-file-into - - release - ] - with-file-writer - - build-status on ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -SYMBOL: builder-from - -SYMBOL: builder-recipients - -: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ; - -: subject ( -- str ) build-status get [ "report" ] [ "error" ] if tag-subject ; - -: send-builder-email ( -- ) - - builder-from get >>from - builder-recipients get >>to - subject >>subject - "./report" file>string >>body - send-email ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ; - -! : build ( -- ) -! [ (build) ] try -! builds cd stamp> cd -! [ send-builder-email ] try -! { "rm" "-rf" "factor" } [ ] run-or-bail -! [ compress-image ] try ; - -: build ( -- ) - [ - (build) - build-dir - [ - { "rm" "-rf" "factor" } try-process - compress-image - ] - with-directory - ] - try - send-builder-email ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -USE: bootstrap.image.download - -: git-pull ( -- desc ) - { - "git" - "pull" - "--no-summary" - "git://factorcode.org/git/factor.git" - "master" - } ; - -: updates-available? ( -- ? ) - git-id - git-pull try-process - git-id - = not ; - -: new-image-available? ( -- ? ) - my-boot-image-name need-new-image? - [ download-my-image t ] - [ f ] - if ; - : build-loop ( -- ) builds-check [ - builds/factor - [ - updates-available? new-image-available? or - [ build ] - when - ] - with-directory + builds/factor set-current-directory + new-code-available? [ build ] when ] try 5 minutes sleep build-loop ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MAIN: build-loop +MAIN: build-loop \ No newline at end of file diff --git a/extra/builder/child/child.factor b/extra/builder/child/child.factor new file mode 100644 index 0000000000..a63ae88f7f --- /dev/null +++ b/extra/builder/child/child.factor @@ -0,0 +1,70 @@ + +USING: namespaces debugger io.files io.launcher accessors bootstrap.image + calendar builder.util builder.common ; + +IN: builder.child + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: make-clean ( -- ) { gnu-make "clean" } to-strings try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: make-vm ( -- ) + + gnu-make >>command + "../compile-log" >>stdout + +stdout+ >>stderr + try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: builds-factor-image ( -- img ) builds/factor my-boot-image-name append-path ; + +: copy-image ( -- ) + builds-factor-image ".." copy-file-into + builds-factor-image "." copy-file-into ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: boot-cmd ( -- cmd ) + { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ; + +: boot ( -- ) + + boot-cmd >>command + +closed+ >>stdin + "../boot-log" >>stdout + +stdout+ >>stderr + 60 minutes >>timeout + try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } ; + +: test ( -- ) + + test-cmd >>command + +closed+ >>stdin + "../test-log" >>stdout + +stdout+ >>stderr + 240 minutes >>timeout + try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: (build-child) ( -- ) + make-clean + make-vm status-vm on + copy-image + boot status-boot on + test status-test on + status on ; + +! : build-child ( -- ) "factor" [ (build-child) ] with-directory ; + +: build-child ( -- ) + "factor" set-current-directory + [ (build-child) ] try + ".." set-current-directory ; diff --git a/extra/builder/cleanup/cleanup.factor b/extra/builder/cleanup/cleanup.factor new file mode 100644 index 0000000000..327b90e01f --- /dev/null +++ b/extra/builder/cleanup/cleanup.factor @@ -0,0 +1,24 @@ + +USING: kernel namespaces io.files io.launcher bootstrap.image + builder.util builder.common ; + +IN: builder.cleanup + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: builder-debug + +: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ; + +: delete-child-factor ( -- ) + build-dir [ { "rm" "-rf" "factor" } try-process ] with-directory ; + +: cleanup ( -- ) + builder-debug get f = + [ + "test-log" delete-file + delete-child-factor + compress-image + ] + when ; + diff --git a/extra/builder/common/common.factor b/extra/builder/common/common.factor index 2fe2aa06ab..e3c207eaaa 100644 --- a/extra/builder/common/common.factor +++ b/extra/builder/common/common.factor @@ -1,5 +1,7 @@ -USING: kernel namespaces io.files sequences vars ; +USING: kernel namespaces sequences splitting + io io.files io.launcher io.encodings.utf8 prettyprint + vars builder.util ; IN: builder.common @@ -16,4 +18,47 @@ SYMBOL: builds-dir VAR: stamp -SYMBOL: upload-to-factorcode \ No newline at end of file +: builds/factor ( -- path ) builds "factor" append-path ; +: build-dir ( -- path ) builds stamp> append-path ; + +: create-build-dir ( -- ) + datestamp >stamp + build-dir make-directory ; + +: enter-build-dir ( -- ) build-dir set-current-directory ; + +: clone-builds-factor ( -- ) + { "git" "clone" builds/factor } to-strings try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: prepare-build-machine ( -- ) + builds make-directory + builds + [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: status-vm +SYMBOL: status-boot +SYMBOL: status-test +SYMBOL: status-build +SYMBOL: status-release +SYMBOL: status + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: reset-status ( -- ) + { status-vm status-boot status-test status-build status-release status } + [ off ] + each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: upload-to-factorcode + diff --git a/extra/builder/email/email.factor b/extra/builder/email/email.factor new file mode 100644 index 0000000000..eed48cb177 --- /dev/null +++ b/extra/builder/email/email.factor @@ -0,0 +1,22 @@ + +USING: kernel namespaces accessors smtp builder.util builder.common ; + +IN: builder.email + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: builder-from +SYMBOL: builder-recipients + +: subject-status ( -- str ) status get [ "report" ] [ "error" ] if ; + +: subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ; + +: email-report ( -- ) + + builder-from get >>from + builder-recipients get >>to + subject >>subject + "report" file>string >>body + send-email ; + diff --git a/extra/builder/release/branch/branch.factor b/extra/builder/release/branch/branch.factor index 838a74394b..6218a2ea90 100644 --- a/extra/builder/release/branch/branch.factor +++ b/extra/builder/release/branch/branch.factor @@ -36,5 +36,5 @@ IN: builder.release.branch : update-clean-branch ( -- ) upload-to-factorcode get - [ update-clean-branch ] + [ (update-clean-branch) ] when ; diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index 33e5edfbf9..8f4c0e30f5 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -1,5 +1,5 @@ -USING: kernel system namespaces sequences splitting combinators +USING: kernel debugger system namespaces sequences splitting combinators io io.files io.launcher prettyprint bootstrap.image bake combinators.cleave builder.util @@ -18,9 +18,10 @@ IN: builder.release tidy make-archive upload - save-archive ; + save-archive + status-release on ; : clean-build? ( -- ? ) { "load-everything-vocabs" "test-all-vocabs" } [ eval-file empty? ] all? ; -: release ( -- ) clean-build? [ (release) ] when ; \ No newline at end of file +: release ( -- ) [ clean-build? [ (release) ] when ] try ; \ No newline at end of file diff --git a/extra/builder/report/report.factor b/extra/builder/report/report.factor new file mode 100644 index 0000000000..101d259f7c --- /dev/null +++ b/extra/builder/report/report.factor @@ -0,0 +1,35 @@ + +USING: kernel namespaces debugger system io io.files io.sockets + io.encodings.utf8 prettyprint benchmark + builder.util builder.common ; + +IN: builder.report + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: (report) ( -- ) + + "Build machine: " write host-name print + "CPU: " write cpu . + "OS: " write os . + "Build directory: " write build-dir print + "git id: " write "git-id" eval-file print nl + + status-vm get f = [ "compile-log" cat "vm compile error" throw ] when + status-boot get f = [ "boot-log" cat "Boot error" throw ] when + status-test get f = [ "test-log" 100 cat-n "Test error" throw ] when + + "Boot time: " write "boot-time" eval-file milli-seconds>time print + "Load time: " write "load-time" eval-file milli-seconds>time print + "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-failures" cat + + "help-lint results:" print "help-lint" cat + + "Benchmarks: " print "benchmarks" eval-file benchmarks. ; + +: report ( -- ) "report" utf8 [ [ (report) ] try ] with-file-writer ; \ No newline at end of file diff --git a/extra/builder/updates/updates.factor b/extra/builder/updates/updates.factor new file mode 100644 index 0000000000..a8184550e0 --- /dev/null +++ b/extra/builder/updates/updates.factor @@ -0,0 +1,31 @@ + +USING: kernel io.launcher bootstrap.image bootstrap.image.download + builder.util builder.common ; + +IN: builder.updates + +: git-pull-cmd ( -- cmd ) + { + "git" + "pull" + "--no-summary" + "git://factorcode.org/git/factor.git" + "master" + } ; + +: updates-available? ( -- ? ) + git-id + git-pull-cmd try-process + git-id + = not ; + +: new-image-available? ( -- ? ) + my-boot-image-name need-new-image? + [ download-my-image t ] + [ f ] + if ; + +: new-code-available? ( -- ? ) + updates-available? + new-image-available? + or ; \ No newline at end of file diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index e80d83e24c..3b0834b190 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -25,11 +25,11 @@ DEFER: to-strings : to-string ( obj -- str ) dup class { - { string [ ] } - { quotation [ call ] } - { word [ execute ] } - { fixnum [ number>string ] } - { array [ to-strings concat ] } + { \ string [ ] } + { \ quotation [ call ] } + { \ word [ execute ] } + { \ fixnum [ number>string ] } + { \ array [ to-strings concat ] } } case ; @@ -97,4 +97,15 @@ USE: prettyprint : cpu- ( -- cpu ) cpu unparse "." split "-" join ; -: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ; \ No newline at end of file +: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: gnu-make ( -- string ) + os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: git-id ( -- id ) + { "git" "show" } utf8 [ readln ] with-stream + " " split second ; From 68c82f88b1f0a0a5dd001a81a9307787d7c2a5d2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Apr 2008 23:59:11 -0500 Subject: [PATCH 04/18] Add a couple of inverses to inverse, fix summary --- extra/inverse/inverse.factor | 4 ++++ extra/macros/summary.txt | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 9c94c86ce9..6852d70e48 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -195,6 +195,10 @@ DEFER: _ \ first3 [ 3array ] define-inverse \ first4 [ 4array ] define-inverse +\ prefix [ unclip ] define-inverse +\ unclip [ prefix ] define-inverse +\ suffix [ dup 1 head* swap peek ] define-inverse + ! Constructor inverse : deconstruct-pred ( class -- quot ) "predicate" word-prop [ dupd call assure ] curry ; diff --git a/extra/macros/summary.txt b/extra/macros/summary.txt index 93ecb60f1c..cfd00d9795 100644 --- a/extra/macros/summary.txt +++ b/extra/macros/summary.txt @@ -1 +1 @@ -Utility for defining compiler transforms, and short-circuiting boolean operators +Utility for defining compiler transforms From 069045c3963b29eb6e7735fa39a924fbbc1d4ddf Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 13 Apr 2008 00:14:32 -0500 Subject: [PATCH 05/18] builder.child: remove old code --- extra/builder/child/child.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/extra/builder/child/child.factor b/extra/builder/child/child.factor index a63ae88f7f..0f701dfdd7 100644 --- a/extra/builder/child/child.factor +++ b/extra/builder/child/child.factor @@ -62,9 +62,7 @@ IN: builder.child test status-test on status on ; -! : build-child ( -- ) "factor" [ (build-child) ] with-directory ; - : build-child ( -- ) "factor" set-current-directory [ (build-child) ] try - ".." set-current-directory ; + ".." set-current-directory ; \ No newline at end of file From a5d5dfb0df7347f3e8b9e233af295540dc390f44 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Apr 2008 00:21:48 -0500 Subject: [PATCH 06/18] Update duplex streams for new-slots --- core/io/streams/duplex/duplex.factor | 56 ++++++++++++++-------------- 1 file changed, 29 insertions(+), 27 deletions(-) diff --git a/core/io/streams/duplex/duplex.factor b/core/io/streams/duplex/duplex.factor index 83e991b713..574735a9c5 100755 --- a/core/io/streams/duplex/duplex.factor +++ b/core/io/streams/duplex/duplex.factor @@ -1,75 +1,77 @@ -! Copyright (C) 2005 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel continuations io accessors ; IN: io.streams.duplex -USING: kernel continuations io ; ! We ensure that the stream can only be closed once, to preserve ! integrity of duplex I/O ports. -TUPLE: duplex-stream in out closed? ; +TUPLE: duplex-stream in out closed ; : ( in out -- stream ) f duplex-stream construct-boa ; +> [ stream-closed-twice ] when ; inline -: duplex-stream-in+ ( duplex -- stream ) - dup check-closed duplex-stream-in ; +: in ( duplex -- stream ) check-closed in>> ; -: duplex-stream-out+ ( duplex -- stream ) - dup check-closed duplex-stream-out ; +: out ( duplex -- stream ) check-closed out>> ; + +PRIVATE> M: duplex-stream stream-flush - duplex-stream-out+ stream-flush ; + out stream-flush ; M: duplex-stream stream-readln - duplex-stream-in+ stream-readln ; + in stream-readln ; M: duplex-stream stream-read1 - duplex-stream-in+ stream-read1 ; + in stream-read1 ; M: duplex-stream stream-read-until - duplex-stream-in+ stream-read-until ; + in stream-read-until ; M: duplex-stream stream-read-partial - duplex-stream-in+ stream-read-partial ; + in stream-read-partial ; M: duplex-stream stream-read - duplex-stream-in+ stream-read ; + in stream-read ; M: duplex-stream stream-write1 - duplex-stream-out+ stream-write1 ; + out stream-write1 ; M: duplex-stream stream-write - duplex-stream-out+ stream-write ; + out stream-write ; M: duplex-stream stream-nl - duplex-stream-out+ stream-nl ; + out stream-nl ; M: duplex-stream stream-format - duplex-stream-out+ stream-format ; + out stream-format ; M: duplex-stream make-span-stream - duplex-stream-out+ make-span-stream ; + out make-span-stream ; M: duplex-stream make-block-stream - duplex-stream-out+ make-block-stream ; + out make-block-stream ; M: duplex-stream make-cell-stream - duplex-stream-out+ make-cell-stream ; + out make-cell-stream ; M: duplex-stream stream-write-table - duplex-stream-out+ stream-write-table ; + out stream-write-table ; M: duplex-stream dispose #! The output stream is closed first, in case both streams #! are attached to the same file descriptor, the output #! buffer needs to be flushed before we close the fd. - dup duplex-stream-closed? [ - t over set-duplex-stream-closed? - [ dup duplex-stream-out dispose ] - [ dup duplex-stream-in dispose ] [ ] cleanup + dup closed>> [ + t >>closed + [ dup out>> dispose ] + [ dup in>> dispose ] [ ] cleanup ] unless drop ; From 55e777476c77abb2362c7fc7b388fefee093997d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Apr 2008 00:26:03 -0500 Subject: [PATCH 07/18] Add parser logic to catch common mistake --- core/parser/parser-docs.factor | 12 ++++++++++++ core/parser/parser.factor | 30 ++++++++++++++++++++++++++++-- 2 files changed, 40 insertions(+), 2 deletions(-) diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index e7984f7ec3..23363c30ad 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -358,6 +358,18 @@ HELP: scan-word { $errors "Throws an error if the token does not name a word, and does not parse as a number." } $parsing-note ; +HELP: invalid-slot-name +{ $values { "name" string } } +{ $description "Throws an " { $link invalid-slot-name } " error." } +{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." } +{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:" + { $code + "TUPLE: my-mistaken-tuple slot-a slot-b" + "" + ": some-word ( a b c -- ) ... ;" + } +} ; + HELP: unexpected { $values { "want" "a " { $link word } " or " { $link f } } { "got" word } } { $description "Throws an " { $link unexpected } " error." } diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 1e1d6a5606..13f768a810 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -184,6 +184,9 @@ M: parse-error summary M: parse-error compute-restarts error>> compute-restarts ; +M: parse-error error-help + error>> error-help ; + SYMBOL: use SYMBOL: in @@ -298,12 +301,35 @@ M: no-word-error summary ] "" make note. ] with each ; +ERROR: invalid-slot-name name ; + +M: invalid-slot-name summary + drop + "Invalid slot name" ; + +: (parse-tuple-slots) ( -- ) + #! This isn't meant to enforce any kind of policy, just + #! to check for mistakes of this form: + #! + #! TUPLE: blahblah foo bing + #! + #! : ... + scan { + { [ dup not ] [ unexpected-eof ] } + { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] } + { [ dup ";" = ] [ drop ] } + [ , (parse-tuple-slots) ] + } cond ; + +: parse-tuple-slots ( -- seq ) + [ (parse-tuple-slots) ] { } make ; + : parse-tuple-definition ( -- class superclass slots ) CREATE-CLASS scan { { ";" [ tuple f ] } - { "<" [ scan-word ";" parse-tokens ] } - [ >r tuple ";" parse-tokens r> prefix ] + { "<" [ scan-word parse-tuple-slots ] } + [ >r tuple parse-tuple-slots r> prefix ] } case 3dup check-slot-shadowing ; ERROR: staging-violation word ; From d45b12b3ed557d89d294c625b94f551d9b1b08c8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Apr 2008 00:26:44 -0500 Subject: [PATCH 08/18] Windows I/O fixes --- extra/io/nonblocking/nonblocking.factor | 9 ++- .../windows/nt/monitors/monitors-tests.factor | 4 ++ extra/io/windows/nt/monitors/monitors.factor | 58 ++++++++++++------- extra/io/windows/nt/sockets/sockets.factor | 2 +- 4 files changed, 48 insertions(+), 25 deletions(-) create mode 100755 extra/io/windows/nt/monitors/monitors-tests.factor diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 048a5d7b1c..aa56b507ff 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -3,7 +3,7 @@ USING: math kernel io sequences io.buffers io.timeouts generic byte-vectors system io.streams.duplex io.encodings io.backend continuations debugger classes byte-arrays namespaces -splitting dlists assocs io.encodings.binary accessors ; +splitting dlists assocs io.encodings.binary inspector accessors ; IN: io.nonblocking SYMBOL: default-buffer-size @@ -43,8 +43,13 @@ TUPLE: output-port < port ; : pending-error ( port -- ) [ f ] change-error drop [ throw ] when* ; +ERROR: port-closed-error port ; + +M: port-closed-error summary + drop "Port has been closed" ; + : check-closed ( port -- port ) - dup closed>> [ "Port closed" throw ] when ; + dup closed>> [ port-closed-error ] when ; HOOK: cancel-io io-backend ( port -- ) diff --git a/extra/io/windows/nt/monitors/monitors-tests.factor b/extra/io/windows/nt/monitors/monitors-tests.factor new file mode 100755 index 0000000000..ef36baedc5 --- /dev/null +++ b/extra/io/windows/nt/monitors/monitors-tests.factor @@ -0,0 +1,4 @@ +IN: io.windows.nt.monitors.tests +USING: io.windows.nt.monitors tools.test ; + +\ fill-queue-thread must-infer diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index 7f3a13b281..0dbf08d6a5 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -3,12 +3,14 @@ USING: alien alien.c-types libc destructors locals kernel math assocs namespaces continuations sequences hashtables sorting arrays combinators math.bitfields strings system -io.windows io.windows.nt.backend io.monitors io.nonblocking -io.buffers io.files io.timeouts io accessors threads +accessors threads +io.backend io.windows io.windows.nt.backend io.monitors +io.nonblocking io.buffers io.files io.timeouts io windows windows.kernel32 windows.types ; IN: io.windows.nt.monitors : open-directory ( path -- handle ) + normalize-path FILE_LIST_DIRECTORY share-mode f @@ -28,8 +30,8 @@ TUPLE: win32-monitor < monitor port ; : begin-reading-changes ( port -- overlapped ) { [ handle>> handle>> ] - [ buffer>> buffer-ptr ] - [ buffer>> buffer-size ] + [ buffer>> ptr>> ] + [ buffer>> size>> ] [ recursive>> 1 0 ? ] } cleave FILE_NOTIFY_CHANGE_ALL @@ -39,12 +41,11 @@ TUPLE: win32-monitor < monitor port ; : read-changes ( port -- bytes ) [ - [ - dup begin-reading-changes - swap [ save-callback ] 2keep - check-closed ! we may have closed it... - get-overlapped-result - ] with-timeout + dup begin-reading-changes + swap [ save-callback ] 2keep + check-closed ! we may have closed it... + dup eof>> [ "EOF??" throw ] when + get-overlapped-result ] with-destructors ; : parse-action ( action -- changed ) @@ -55,32 +56,45 @@ TUPLE: win32-monitor < monitor port ; { FILE_ACTION_RENAMED_OLD_NAME [ +rename-file+ ] } { FILE_ACTION_RENAMED_NEW_NAME [ +rename-file+ ] } [ drop +modify-file+ ] - } case ; + } case 1array ; : memory>u16-string ( alien len -- string ) [ memory>byte-array ] keep 2/ c-ushort-array> >string ; -: parse-notify-record ( buffer -- changed path ) - [ FILE_NOTIFY_INFORMATION-Action parse-action ] - [ FILE_NOTIFY_INFORMATION-FileName ] - [ FILE_NOTIFY_INFORMATION-FileNameLength ] tri - memory>u16-string ; +: parse-notify-record ( buffer -- path changed ) + [ + [ FILE_NOTIFY_INFORMATION-FileName ] + [ FILE_NOTIFY_INFORMATION-FileNameLength ] + bi memory>u16-string + ] + [ FILE_NOTIFY_INFORMATION-Action parse-action ] bi ; + +: (file-notify-records) ( buffer -- buffer ) + dup , + dup FILE_NOTIFY_INFORMATION-NextEntryOffset zero? [ + [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep + (file-notify-records) + ] unless ; : file-notify-records ( buffer -- seq ) - [ dup FILE_NOTIFY_INFORMATION-NextEntryOffset 0 > ] - [ [ [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep ] keep ] - [ ] unfold nip ; + [ (file-notify-records) drop ] { } make ; : parse-notify-records ( monitor buffer -- ) file-notify-records [ parse-notify-record rot queue-change ] with each ; : fill-queue ( monitor -- ) - dup port>> [ buffer>> buffer-ptr ] [ read-changes zero? ] bi - [ 2dup parse-notify-records ] unless 2drop ; + dup port>> check-closed + [ buffer>> ptr>> ] [ read-changes zero? ] bi + [ 2dup parse-notify-records ] unless + 2drop ; + +: (fill-queue-thread) ( monitor -- ) + dup fill-queue (fill-queue-thread) ; : fill-queue-thread ( monitor -- ) - dup fill-queue fill-queue ; + [ dup fill-queue (fill-queue-thread) ] + [ dup port-closed-error? [ 2drop ] [ rethrow ] if ] recover ; M:: winnt (monitor) ( path recursive? mailbox -- monitor ) [ diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index a9d487dad7..1617b9f9a0 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -50,7 +50,7 @@ TUPLE: ConnectEx-args port 2dup save-callback get-overlapped-result drop ; -M: winnt (client) ( addrspec -- client-in client-out ) +M: winnt ((client)) ( addrspec -- client-in client-out ) [ \ ConnectEx-args construct-empty over make-sockaddr/size pick init-connect From 49f846ca4bc243e4c75f505469610d8922cec36f Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 13 Apr 2008 00:27:58 -0500 Subject: [PATCH 09/18] builder.test: remove old code --- extra/builder/test/test.factor | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index d5c3e9cd94..957af28dc1 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -1,16 +1,4 @@ -! USING: kernel namespaces sequences assocs continuations -! vocabs vocabs.loader -! io -! io.files -! prettyprint -! tools.vocabs -! tools.test -! io.encodings.utf8 -! combinators.cleave -! help.lint -! bootstrap.stage2 benchmark builder.util ; - USING: kernel namespaces assocs io.files io.encodings.utf8 prettyprint help.lint From 8110074bc03c12dcb8b49672b2ccb4f5c5c5e220 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Apr 2008 00:39:56 -0500 Subject: [PATCH 10/18] Doc updates --- core/command-line/command-line-docs.factor | 7 ++--- core/io/files/files-docs.factor | 31 +++++++++++++++++----- 2 files changed, 29 insertions(+), 9 deletions(-) diff --git a/core/command-line/command-line-docs.factor b/core/command-line/command-line-docs.factor index e41d316792..88ea43be20 100644 --- a/core/command-line/command-line-docs.factor +++ b/core/command-line/command-line-docs.factor @@ -7,9 +7,10 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM" { { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } } { { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" } { { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" } - { { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must be >= 2" } - { { $snippet "-young=" { $emphasis "n" } } { "Size of " { $snippet { $emphasis "n" } "-1" } " youngest generations, megabytes" } } - { { $snippet "-aging=" { $emphasis "n" } } "Size of tenured and semi-spaces, megabytes" } + { { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must equal 1, 2 or 3" } + { { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } } + { { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" } + { { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" } { { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" } { { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" } } diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 0d49e344a8..ba17223a29 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -39,11 +39,19 @@ ARTICLE: "symbolic-links" "Symbolic links" "Not all operating systems support symbolic links." { $see-also link-info } ; -ARTICLE: "directories" "Directories" -"Current directory:" +ARTICLE: "current-directory" "Current working directory" +"File system I/O operations use the value of a variable to resolve relative pathnames:" { $subsection current-directory } +"This variable can be changed with a pair of words:" { $subsection set-current-directory } { $subsection with-directory } +"This variable is independent of the operating system notion of ``current working directory''. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:" +{ $subsection (normalize-path) } +"The second is to change the working directory of the current process:" +{ $subsection cd } +{ $subsection cwd } ; + +ARTICLE: "directories" "Directories" "Home directory:" { $subsection home } "Directory listing:" @@ -51,7 +59,8 @@ ARTICLE: "directories" "Directories" { $subsection directory* } "Creating directories:" { $subsection make-directory } -{ $subsection make-directories } ; +{ $subsection make-directories } +{ $subsection "current-directory" } ; ARTICLE: "file-types" "File Types" "Platform-independent types:" @@ -242,11 +251,21 @@ HELP: cd { cd cwd current-directory set-current-directory with-directory } related-words HELP: current-directory -{ $description "A variable holding the current directory. Words that use the filesystem do so in relation to this variable. On startup, an init hook sets this word to the directory from which Factor was run." } ; +{ $description "A variable holding the current directory as an absolute path. Words that use the filesystem do so in relation to this variable." +$nl +"This variable should never be set directly; instead, use " { $link set-current-directory } " or " { $link with-directory } ". This preserves the invariant that the value of this variable is an absolute path." } ; + +HELP: set-current-directory +{ $values { "path" "a pathname string" } } +{ $description "Changes the " { $link current-directory } " variable." +$nl +"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ; HELP: with-directory { $values { "path" "a pathname string" } { "quot" quotation } } -{ $description "Changes the " { $link current-directory } " variable for the duration of a quotation's execution. Words that use the file-system should call " { $link normalize-path } " in order to obtain a path relative to the current directory." } ; +{ $description "Calls the quotation in a new dynamic scope with the " { $link current-directory } " variable rebound." +$nl +"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ; HELP: append-path { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } @@ -300,7 +319,7 @@ HELP: directory* HELP: resource-path { $values { "path" "a pathname string" } { "newpath" "a pathname string" } } -{ $description "Resolve a path relative to the Factor source code location. This first checks if the " { $link resource-path } " variable is set to a path, and if not, uses the parent directory of the current image." } ; +{ $description "Resolve a path relative to the Factor source code location." } ; HELP: pathname { $class-description "Class of pathname presentations. Path name presentations can be created by calling " { $link } ". Instances can be passed to " { $link write-object } " to output a clickable pathname." } ; From 3fc06f02ece3ec4724d4730a22a78ab1d6309c04 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Apr 2008 00:52:49 -0500 Subject: [PATCH 11/18] Clean up circular --- extra/circular/circular.factor | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/extra/circular/circular.factor b/extra/circular/circular.factor index 08deb004e8..b6e350a9e5 100755 --- a/extra/circular/circular.factor +++ b/extra/circular/circular.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2005, 2006 Alex Chapman, Daniel Ehrenberg ! See http;//factorcode.org/license.txt for BSD license -USING: kernel sequences math sequences.private strings ; +USING: kernel sequences math sequences.private strings +accessors ; IN: circular ! a circular sequence wraps another sequence, but begins at an @@ -11,27 +12,27 @@ TUPLE: circular seq start ; 0 circular construct-boa ; : circular-wrap ( n circular -- n circular ) - [ circular-start + ] keep - [ circular-seq length rem ] keep ; inline + [ start>> + ] keep + [ seq>> length rem ] keep ; inline -M: circular length circular-seq length ; +M: circular length seq>> length ; -M: circular virtual@ circular-wrap circular-seq ; +M: circular virtual@ circular-wrap seq>> ; M: circular nth virtual@ nth ; M: circular set-nth virtual@ set-nth ; +M: circular virtual-seq seq>> ; + : change-circular-start ( n circular -- ) #! change start to (start + n) mod length - circular-wrap set-circular-start ; + circular-wrap (>>start) ; : push-circular ( elt circular -- ) - [ set-first ] keep 1 swap change-circular-start ; + [ set-first ] [ 1 swap change-circular-start ] bi ; : ( n -- circular ) 0 ; -M: circular virtual-seq circular-seq ; - INSTANCE: circular virtual-sequence From 8a9baa8660cc6905647bf61cdcb699cbc013eadd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Apr 2008 01:07:13 -0500 Subject: [PATCH 12/18] Increase timeout --- extra/io/monitors/monitors-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index ab919dd008..6407108a61 100644 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -75,13 +75,13 @@ os { winnt linux macosx } member? [ [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test - [ ] [ "c1" get 15 seconds await-timeout ] unit-test + [ ] [ "c1" get 1 minutes await-timeout ] unit-test [ ] [ "monitor-test/subdir/blah/yxy" temp-file make-directories ] unit-test [ ] [ "monitor-test/subdir/blah/yxy/test.txt" temp-file touch-file ] unit-test - [ ] [ "c2" get 15 seconds await-timeout ] unit-test + [ ] [ "c2" get 1 minutes await-timeout ] unit-test ! Dispose twice [ ] [ "m" get dispose ] unit-test From 50e3d36d8ea6f293808888caac88269812afa113 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Apr 2008 01:23:08 -0500 Subject: [PATCH 13/18] Fix nths --- extra/sequences/lib/lib.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 0221d9b99a..15983329d6 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -227,8 +227,8 @@ PRIVATE> : ?nth* ( n seq -- elt/f ? ) 2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable -: nths ( indices seq -- seq' ) - [ swap nth ] with map ; +: nths ( seq indices -- seq' ) + swap [ nth ] curry map ; : replace ( str oldseq newseq -- str' ) zip >hashtable substitute ; From 8bb7aafee5922e7f961a9ec8bb8f5f03311d601c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Apr 2008 03:22:51 -0500 Subject: [PATCH 14/18] Fix bootstrap error --- core/io/streams/duplex/duplex-docs.factor | 4 +--- core/io/streams/duplex/duplex.factor | 4 ++-- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/core/io/streams/duplex/duplex-docs.factor b/core/io/streams/duplex/duplex-docs.factor index 6a956c6694..a745d07f4b 100755 --- a/core/io/streams/duplex/duplex-docs.factor +++ b/core/io/streams/duplex/duplex-docs.factor @@ -16,7 +16,5 @@ HELP: { $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } } { $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ; -HELP: check-closed -{ $values { "stream" "a duplex stream" } } -{ $description "Throws a " { $link check-closed } " error if the stream has already been closed." } +HELP: stream-closed-twice { $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ; diff --git a/core/io/streams/duplex/duplex.factor b/core/io/streams/duplex/duplex.factor index 574735a9c5..008416ab66 100755 --- a/core/io/streams/duplex/duplex.factor +++ b/core/io/streams/duplex/duplex.factor @@ -11,10 +11,10 @@ TUPLE: duplex-stream in out closed ; : ( in out -- stream ) f duplex-stream construct-boa ; -> [ stream-closed-twice ] when ; inline From 9cc25c3effd8f4d639fb4cdf62db2bf291362b52 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Apr 2008 03:47:51 -0500 Subject: [PATCH 15/18] Fix docs --- core/io/streams/duplex/duplex-docs.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/core/io/streams/duplex/duplex-docs.factor b/core/io/streams/duplex/duplex-docs.factor index a745d07f4b..c9691af5ba 100755 --- a/core/io/streams/duplex/duplex-docs.factor +++ b/core/io/streams/duplex/duplex-docs.factor @@ -4,8 +4,7 @@ IN: io.streams.duplex ARTICLE: "io.streams.duplex" "Duplex streams" "Duplex streams combine an input stream and an output stream into a bidirectional stream." { $subsection duplex-stream } -{ $subsection } -{ $subsection check-closed } ; +{ $subsection } ; ABOUT: "io.streams.duplex" From ca0cb895b36b820621d3b882111ba21c7f49408e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Apr 2008 03:49:56 -0500 Subject: [PATCH 16/18] Fix issue with lost callbacks --- extra/core-foundation/fsevents/fsevents.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/extra/core-foundation/fsevents/fsevents.factor b/extra/core-foundation/fsevents/fsevents.factor index 24211a59c7..8f687a896f 100644 --- a/extra/core-foundation/fsevents/fsevents.factor +++ b/extra/core-foundation/fsevents/fsevents.factor @@ -153,7 +153,6 @@ SYMBOL: event-stream-callbacks [ event-stream-callbacks global [ [ drop expired? not ] assoc-subset H{ } assoc-like ] change-at - 1 \ event-stream-counter set-global ] "core-foundation" add-init-hook : add-event-source-callback ( quot -- id ) From aaf48cebf5e5c2d9c7f7ddf31927b5274ee09f59 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Apr 2008 03:52:40 -0500 Subject: [PATCH 17/18] New utility word --- core/math/math.factor | 2 ++ extra/documents/documents.factor | 3 +-- extra/ui/gadgets/gadgets.factor | 2 +- extra/unicode/breaks/breaks.factor | 5 ++--- extra/unicode/data/data.factor | 3 --- extra/unicode/normalize/normalize.factor | 2 +- extra/xml/writer/writer.factor | 4 +--- 7 files changed, 8 insertions(+), 13 deletions(-) diff --git a/core/math/math.factor b/core/math/math.factor index cd908ea10f..064b488ac3 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -62,6 +62,8 @@ M: object zero? drop f ; : neg ( x -- -x ) 0 swap - ; foldable : recip ( x -- y ) 1 swap / ; foldable +: ?1+ [ 1+ ] [ 0 ] if* ; inline + : /f ( x y -- z ) >r >float r> >float float/f ; inline : max ( x y -- z ) [ > ] most ; foldable diff --git a/extra/documents/documents.factor b/extra/documents/documents.factor index 1c0802b721..4fa4ed3c09 100755 --- a/extra/documents/documents.factor +++ b/extra/documents/documents.factor @@ -184,8 +184,7 @@ M: one-char-elt next-elt 2drop ; [ >r blank? r> xor ] curry ; inline : (prev-word) ( ? col str -- col ) - rot break-detector find-last* - drop [ 1+ ] [ 0 ] if* ; + rot break-detector find-last* drop ?1+ ; : (next-word) ( ? col str -- col ) [ rot break-detector find* drop ] keep diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index f4e5ca2a46..15c174d52e 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -111,7 +111,7 @@ M: gadget children-on nip gadget-children ; : fast-children-on ( rect axis children -- from to ) 3dup >r >r dup rect-loc swap rect-dim v+ - r> r> (fast-children-on) [ 1+ ] [ 0 ] if* + r> r> (fast-children-on) ?1+ >r >r >r rect-loc r> r> (fast-children-on) 0 or diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index 54bf766f52..319b822b39 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -21,7 +21,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; } case ; : trim-blank ( str -- newstr ) - dup [ blank? not ] find-last 1+* head ; + [ blank? ] trim-right ; : process-other-extend ( lines -- set ) [ "#" split1 drop ";" split1 drop trim-blank ] map @@ -110,8 +110,7 @@ VALUE: grapheme-table : last-grapheme ( str -- i ) unclip-last-slice grapheme-class swap - [ grapheme-class dup rot grapheme-break? ] find-last-index - nip -1 or 1+ ; + [ grapheme-class dup rot grapheme-break? ] find-last-index ?1+ nip ; [ other-extend-lines process-other-extend \ other-extend set-value diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index ba9c0370cc..b6449f6a0f 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -12,9 +12,6 @@ IN: unicode.data >> ! Convenience functions -: 1+* ( n/f _ -- n+1 ) - drop [ 1+ ] [ 0 ] if* ; - : ?between? ( n/f from to -- ? ) pick [ between? ] [ 3drop f ] if ; diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor index 951430b2b5..34c329b55c 100644 --- a/extra/unicode/normalize/normalize.factor +++ b/extra/unicode/normalize/normalize.factor @@ -67,7 +67,7 @@ IN: unicode.normalize 0 reorder-loop ; : reorder-back ( string i -- ) - over [ non-starter? not ] find-last* 1+* reorder-next 2drop ; + over [ non-starter? not ] find-last* drop ?1+ reorder-next 2drop ; : decompose ( string quot -- decomposed ) ! When there are 8 and 32-bit strings, this'll be diff --git a/extra/xml/writer/writer.factor b/extra/xml/writer/writer.factor index 28b8f26068..27880da07f 100644 --- a/extra/xml/writer/writer.factor +++ b/extra/xml/writer/writer.factor @@ -29,9 +29,7 @@ SYMBOL: indenter xml-pprint? get [ -1 indentation +@ ] when ; : trim-whitespace ( string -- no-whitespace ) - [ [ blank? not ] find drop 0 or ] keep - [ [ blank? not ] find-last drop [ 1+ ] [ 0 ] if* ] keep - subseq ; + [ blank? ] trim ; : ?filter-children ( children -- no-whitespace ) xml-pprint? get [ From 4fe4605e9e05a0f723523fe359e998c3b6ba049f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Apr 2008 05:22:17 -0500 Subject: [PATCH 18/18] Fix load error --- extra/unicode/breaks/breaks.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index 319b822b39..ee3c8729c4 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -21,7 +21,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; } case ; : trim-blank ( str -- newstr ) - [ blank? ] trim-right ; + [ blank? ] right-trim ; : process-other-extend ( lines -- set ) [ "#" split1 drop ";" split1 drop trim-blank ] map