Merge branch 'master' of git://factorcode.org/git/factor

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 "-generations=" { $emphasis "n" } } "Number of generations, must equal 1, 2 or 3" }
-    { { $snippet "-young=" { $emphasis "n" } } { "Size of " { $snippet { $emphasis "n" } "-1" } " youngest generations, megabytes" } }
+    { { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
-    { { $snippet "-aging=" { $emphasis "n" } } "Size of tenured and semi-spaces, 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" }
 }

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 )
     [

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 -- )

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
+    [ extra-values ] [ stack-effect ] bi
-    [ length + ] change-in ;
+    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?
 
 : <tuple-dispatch-engine-word> ( engine -- word )
     tuple-dispatch-engine-word-name f <word>
-    {
-        [ t "tuple-dispatch-engine" set-word-prop ]
     [ generic get "tuple-dispatch-generic" set-word-prop ]
     [ remember-engine ]
     [ ]
-    } cleave ;
+    tri ;
 
 : define-tuple-dispatch-engine-word ( engine quot -- word )
     >r <tuple-dispatch-engine-word> dup r> define ;

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

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"
+ARTICLE: "current-directory" "Current working directory"
-"Current 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 <pathname> } ". Instances can be passed to " { $link write-object } " to output a clickable pathname." } ;

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 <duplex-stream> }
+{ $subsection <duplex-stream> } ;
-{ $subsection check-closed } ;
 
 ABOUT: "io.streams.duplex"
 
@@ -16,7 +15,5 @@ HELP: <duplex-stream>
 { $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
+HELP: stream-closed-twice
-{ $values { "stream" "a duplex stream" } }
-{ $description "Throws a " { $link check-closed } " error if the stream has already been closed." }
 { $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;

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 ;
 
 : <duplex-stream> ( in out -- stream )
     f duplex-stream construct-boa ;
 
 ERROR: stream-closed-twice ;
 
-: check-closed ( stream -- )
+<PRIVATE
-    duplex-stream-closed? [ stream-closed-twice ] when ;
 
-: duplex-stream-in+ ( duplex -- stream )
+: check-closed ( stream -- stream )
-    dup check-closed duplex-stream-in ;
+    dup closed>> [ stream-closed-twice ] when ; inline
 
-: duplex-stream-out+ ( duplex -- stream )
+: in ( duplex -- stream ) check-closed in>> ;
-    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? [
+    dup closed>> [
-        t over set-duplex-stream-closed?
+        t >>closed
-        [ dup duplex-stream-out dispose ]
+        [ dup out>> dispose ]
-        [ dup duplex-stream-in dispose ] [ ] cleanup
+        [ dup in>> dispose ] [ ] cleanup
     ] unless drop ;

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

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." }

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 ] }
+        { "<" [ scan-word parse-tuple-slots ] }
-        [ >r tuple ";" parse-tokens r> prefix ]
+        [ >r tuple parse-tuple-slots r> prefix ]
     } case 3dup check-slot-shadowing ;
 
 ERROR: staging-violation word ;

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* ;
 

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

extra/builder/builder.factor

@@ -1,259 +1,21 @@
 
-USING: kernel namespaces sequences splitting system combinators continuations
+USING: kernel debugger io.files threads calendar 
-       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
        builder.common
-       builder.benchmark
+       builder.updates
-       builder.release ;
+       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 <process-stream>
-  [ 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 )
-  <process>
-    { 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 )
-  <process>
-    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 )
-  <process>
-    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 ( -- )
-  <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
+    builds/factor set-current-directory
-      [
+    new-code-available? [ build ] when
-        updates-available? new-image-available? or
-          [ build ]
-        when
-      ]
-    with-directory
   ]
   try
   5 minutes sleep
   build-loop ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 MAIN: build-loop

extra/builder/child/child.factor

@@ -0,0 +1,68 @@
+
+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 ( -- )
+  <process>
+    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 ( -- )
+  <process>
+    boot-cmd      >>command
+    +closed+      >>stdin
+    "../boot-log" >>stdout
+    +stdout+      >>stderr
+    60 minutes    >>timeout
+  try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } ;
+
+: test ( -- )
+  <process>
+    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" set-current-directory
+    [ (build-child) ] try
+  ".." set-current-directory ;

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 ;
+

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
 
+: 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
+

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 ( -- )
+  <email>
+    builder-from get       >>from
+    builder-recipients get >>to
+    subject                >>subject
+    "report" file>string   >>body
+  send-email ;
+

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 ;

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 ;
+: release ( -- ) [ clean-build? [ (release) ] when ] try ;

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 ;

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

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 ;

extra/builder/util/util.factor

@@ -25,11 +25,11 @@ DEFER: to-strings
 : to-string ( obj -- str )
   dup class
     {
-      { string    [ ] }
+      { \ string    [ ] }
-      { quotation [ call ] }
+      { \ quotation [ call ] }
-      { word      [ execute ] }
+      { \ word      [ execute ] }
-      { fixnum    [ number>string ] }
+      { \ fixnum    [ number>string ] }
-      { array     [ to-strings concat ] }
+      { \ array     [ to-strings concat ] }
     }
   case ;
 
@@ -98,3 +98,14 @@ USE: prettyprint
 : cpu- ( -- cpu ) cpu unparse "." split "-" join ;
 
 : 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 <process-stream> [ readln ] with-stream
+  " " split second ;

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
+    [ start>> + ] keep
-    [ circular-seq length rem ] keep ; inline
+    [ 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 ;
 
 : <circular-string> ( n -- circular )
     0 <string> <circular> ;
 
-M: circular virtual-seq circular-seq ;
-
 INSTANCE: circular virtual-sequence

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 )

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*
+    rot break-detector find-last* drop ?1+ ;
-    drop [ 1+ ] [ 0 ] if* ;
 
 : (next-word) ( ? col str -- col )
     [ rot break-detector find* drop ] keep

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 ;

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

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 -- )
 

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

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
+accessors threads
-io.buffers io.files io.timeouts io 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>> ptr>> ]
-        [ buffer>> buffer-size ]
+        [ buffer>> size>> ]
         [ recursive>> 1 0 ? ]
     } cleave
     FILE_NOTIFY_CHANGE_ALL
@@ -38,13 +40,12 @@ TUPLE: win32-monitor < monitor port ;
     [ f ReadDirectoryChangesW win32-error=0/f ] keep ;
 
 : read-changes ( port -- bytes )
-    [
     [
         dup begin-reading-changes
         swap [ save-callback ] 2keep
         check-closed ! we may have closed it...
+        dup eof>> [ "EOF??" throw ] when
         get-overlapped-result
-        ] with-timeout
     ] 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 )
+: parse-notify-record ( buffer -- path changed )
-    [ FILE_NOTIFY_INFORMATION-Action parse-action ]
+    [
         [ FILE_NOTIFY_INFORMATION-FileName ]
-    [ FILE_NOTIFY_INFORMATION-FileNameLength ] tri
+        [ FILE_NOTIFY_INFORMATION-FileNameLength ]
-    memory>u16-string ;
+        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 <displaced-alien>
+        (file-notify-records)
+    ] unless ;
 
 : file-notify-records ( buffer -- seq )
-    [ dup FILE_NOTIFY_INFORMATION-NextEntryOffset 0 > ]
+    [ (file-notify-records) drop ] { } make ;
-    [ [ [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep <displaced-alien> ] keep ]
-    [ ] unfold nip ;
 
 : 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
+    dup port>> check-closed
-    [ 2dup parse-notify-records ] unless 2drop ;
+    [ 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 )
     [

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

extra/macros/summary.txt

@@ -1 +1 @@
-Utility for defining compiler transforms, and short-circuiting boolean operators
+Utility for defining compiler transforms

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' )
+: nths ( seq indices -- seq' )
-    [ swap nth ] with map ;
+    swap [ nth ] curry map ;
 
 : replace ( str oldseq newseq -- str' )
     zip >hashtable substitute ;

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

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 ;

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.interactor ui.tools.inspector ui.tools.listener
-ui.tools.profiler ui.tools.walker ui.tools.workspace vocabs ;
+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 } "." ;
 

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? ] right-trim ;
 
 : 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
+    [ grapheme-class dup rot grapheme-break? ] find-last-index ?1+ nip ;
-    nip -1 or 1+ ;
 
 [
     other-extend-lines process-other-extend \ other-extend set-value

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 ;
 

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

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? ] trim ;
-    [ [ blank? not ] find-last drop [ 1+ ] [ 0 ] if* ] keep
-    subseq ;
 
 : ?filter-children ( children -- no-whitespace )
     xml-pprint? get [