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

Conflicts:

	extra/benchmark/sockets/sockets.factor

core/generic/generic-docs.factor

@@ -116,16 +116,18 @@ HELP: method-spec
 { $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." }
 { $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ;
 
+HELP: method-body
+{ $class-description "The class of method bodies, which are words with special word properties set." } ;
+
 HELP: method
-{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method } " or " { $link f } } }
+{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
-{ $description "Looks up a method definition." }
+{ $description "Looks up a method definition." } ;
-{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
 
 { method define-method POSTPONE: M: } related-words
 
 HELP: <method>
 { $values { "def" "a quotation" } { "method" "a new method definition" } }
-{ $description "Creates a new  "{ $link method } " instance." } ;
+{ $description "Creates a new method." } ;
 
 HELP: methods
 { $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }

core/generic/generic.factor

@@ -33,8 +33,6 @@ M: generic definition drop f ;
     dup { "unannotated-def" } reset-props
     dup dup "combination" word-prop perform-combination define ;
 
-TUPLE: method word def specializer generic loc ;
-
 : method ( class generic -- method/f )
     "methods" word-prop at ;
 
@@ -47,7 +45,7 @@ PREDICATE: pair method-spec
 : methods ( word -- assoc )
     "methods" word-prop
     [ keys sort-classes ] keep
-    [ dupd at method-word ] curry { } map>assoc ;
+    [ dupd at ] curry { } map>assoc ;
 
 TUPLE: check-method class generic ;
 
@@ -63,29 +61,33 @@ TUPLE: check-method class generic ;
 : method-word-name ( class word -- string )
     word-name "/" rot word-name 3append ;
 
-: make-method-def ( quot word combination -- quot )
+: make-method-def ( quot class generic -- quot )
     "combination" word-prop method-prologue swap append ;
 
-PREDICATE: word method-body "method" word-prop >boolean ;
+PREDICATE: word method-body "method-def" word-prop >boolean ;
 
 M: method-body stack-effect
-    "method" word-prop method-generic stack-effect ;
+    "method-generic" word-prop stack-effect ;
 
-: <method-word> ( quot class generic -- word )
+: method-word-props ( quot class generic -- assoc )
-    [ make-method-def ] 2keep
+    [
-    method-word-name f <word>
+        "method-generic" set
-    dup rot define
+        "method-class" set
-    dup xref ;
+        "method-def" set
+    ] H{ } make-assoc ;
 
-: <method> ( quot class generic -- method )
+: <method> ( quot class generic -- word )
     check-method
-    [ <method-word> ] 3keep f \ method construct-boa
+    [ make-method-def ] 3keep
-    dup method-word over "method" set-word-prop ;
+    [ method-word-props ] 2keep
+    method-word-name f <word>
+    tuck set-word-props
+    dup rot define ;
 
 : redefine-method ( quot class generic -- )
-    [ method set-method-def ] 3keep
+    [ method swap "method-def" set-word-prop ] 3keep
     [ make-method-def ] 2keep
-    method method-word swap define ;
+    method swap define ;
 
 : define-method ( quot class generic -- )
     >r bootstrap-word r>
@@ -102,21 +104,22 @@ M: method-body stack-effect
 
 ! Definition protocol
 M: method-spec where
-    dup first2 method [ method-word ] [ second ] ?if where ;
+    dup first2 method [ ] [ second ] ?if where ;
 
 M: method-spec set-where
-    first2 method method-word set-where ;
+    first2 method set-where ;
 
 M: method-spec definer
     drop \ M: \ ; ;
 
 M: method-spec definition
-    first2 method dup [ method-def ] when ;
+    first2 method dup
+    [ "method-def" word-prop ] when ;
 
 : forget-method ( class generic -- )
     check-method
     [ delete-at* ] with-methods
-    [ method-word forget-word ] [ drop ] if ;
+    [ forget-word ] [ drop ] if ;
 
 M: method-spec forget*
     first2 forget-method ;
@@ -125,11 +128,11 @@ M: method-body definer
     drop \ M: \ ; ;
 
 M: method-body definition
-    "method" word-prop method-def ;
+    "method-def" word-prop ;
 
 M: method-body forget*
-    "method" word-prop
+    dup "method-class" word-prop
-    { method-specializer method-generic } get-slots
+    swap "method-generic" word-prop
     forget-method ;
 
 : implementors* ( classes -- words )
@@ -168,8 +171,7 @@ M: word subwords drop f ;
 
 M: generic subwords
     dup "methods" word-prop values
-    swap "default-method" word-prop add
+    swap "default-method" word-prop add ;
-    [ method-word ] map ;
 
 M: generic forget-word
     dup subwords [ forget-word ] each (forget-word) ;

core/generic/math/math.factor

@@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ;
 
 : applicable-method ( generic class -- quot )
     over method
-    [ method-word word-def ]
+    [ word-def ]
     [ default-math-method ] ?if ;
 
 : object-method ( generic -- quot )

core/generic/standard/standard.factor

@@ -69,7 +69,7 @@ TUPLE: no-method object generic ;
     ] if ;
 
 : default-method ( word -- pair )
-    "default-method" word-prop method-word
+    "default-method" word-prop
     object bootstrap-word swap 2array ;
 
 : method-alist>quot ( alist base-class -- quot )

core/inference/backend/backend.factor

@@ -10,8 +10,7 @@ IN: inference.backend
     recursive-state get at ;
 
 : inline? ( word -- ? )
-    dup "method" word-prop
+    dup "method-generic" word-prop swap or "inline" word-prop ;
-    [ method-generic inline? ] [ "inline" word-prop ] ?if ;
 
 : local-recursive-state ( -- assoc )
     recursive-state get dup keys

core/optimizer/inlining/inlining.factor

@@ -64,7 +64,7 @@ DEFER: (flat-length)
 : inline-standard-method ( node word -- node )
     2dup dispatching-class dup [
         over +inlined+ depends-on
-        swap method method-word 1quotation f splice-quot
+        swap method 1quotation f splice-quot
     ] [
         3drop t
     ] if ;

core/optimizer/optimizer-tests.factor

@@ -293,7 +293,7 @@ TUPLE: silly-tuple a b ;
 [ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
 
 ! Make sure we have sane heuristics
-: should-inline? method method-word flat-length 10 <= ;
+: should-inline? method flat-length 10 <= ;
 
 [ t ] [ \ fixnum \ shift should-inline? ] unit-test
 [ f ] [ \ array \ equal? should-inline? ] unit-test

core/prettyprint/prettyprint.factor

@@ -175,10 +175,10 @@ M: method-spec synopsis*
     dup definer. [ pprint-word ] each ;
 
 M: method-body synopsis*
-    dup definer.
+    dup dup
-    "method" word-prop dup
+    definer.
-    method-specializer pprint*
+    "method-class" word-prop pprint*
-    method-generic pprint* ;
+    "method-generic" word-prop pprint* ;
 
 M: mixin-instance synopsis*
     dup definer.
@@ -269,7 +269,7 @@ M: builtin-class see-class*
 
 : see-implementors ( class -- seq )
     dup implementors
-    [ method method-word ] with map
+    [ method ] with map
     natural-sort ;
 
 : see-class ( class -- )
@@ -280,9 +280,7 @@ M: builtin-class see-class*
     ] when drop ;
 
 : see-methods ( generic -- seq )
-    "methods" word-prop
+    "methods" word-prop values natural-sort ;
-    [ nip method-word ] { } assoc>map
-    natural-sort ;
 
 M: word see
     dup see-class

core/vocabs/vocabs.factor

@@ -55,6 +55,8 @@ M: f vocab-docs-loaded? ;
 
 M: f set-vocab-docs-loaded? 2drop ;
 
+M: f vocab-help ;
+
 : create-vocab ( name -- vocab )
     dictionary get [ <vocab> ] cache ;
 

core/words/words.factor

@@ -68,7 +68,7 @@ SYMBOL: bootstrapping?
 : crossref? ( word -- ? )
     {
         { [ dup "forgotten" word-prop ] [ f ] }
-        { [ dup "method" word-prop ] [ t ] }
+        { [ dup "method-definition" word-prop ] [ t ] }
         { [ dup word-vocabulary ] [ t ] }
         { [ t ] [ f ] }
     } cond nip ;

extra/benchmark/sockets/sockets.factor

@@ -1,4 +1,4 @@
-USING: io.sockets io kernel math threads io.encodings.ascii
+USING: io.sockets io kernel math threads
 debugger tools.time prettyprint concurrency.count-downs
 namespaces arrays continuations ;
 IN: benchmark.sockets
@@ -30,7 +30,7 @@ SYMBOL: counter
     ] ignore-errors ;
 
 : simple-client ( -- )
-    server-addr <client> [
+    server-addr ascii <client> [
         CHAR: b write1 flush
         number-of-requests
         [ CHAR: a dup write1 flush read1 assert= ] times
@@ -38,7 +38,7 @@ SYMBOL: counter
     ] with-stream ;
 
 : stop-server ( -- )
-    server-addr <client> [
+    server-addr ascii <client> [
         CHAR: x write1
     ] with-stream ;
 
@@ -53,13 +53,6 @@ SYMBOL: counter
         yield yield
     ] time ;
 
-: socket-benchmarks
+: socket-benchmarks ;
-    10 clients
-    20 clients
-    40 clients ;
-    ! 80 clients
-    ! 160 clients
-    ! 320 clients
-    ! 640 clients ;
 
 MAIN: socket-benchmarks

extra/bootstrap/image/upload/upload.factor

@@ -8,7 +8,7 @@ SYMBOL: upload-images-destination
 
 : destination ( -- dest )
   upload-images-destination get
-  "slava@/var/www/factorcode.org/newsite/images/latest/"
+  "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
   or ;
 
 : checksums "checksums.txt" temp-file ;

extra/help/markup/markup.factor

@@ -144,20 +144,32 @@ M: f print-element drop ;
 : $link ( element -- )
     first ($link) ;
 
-: ($subsection) ( object -- )
+: ($long-link) ( object -- )
-    [ article-title ] keep >link write-object ;
+    dup article-title swap >link write-link ;
 
-: $subsection ( element -- )
+: ($subsection) ( element quot -- )
     [
         subsection-style get [
             bullet get write bl
-            first ($subsection)
+            call
         ] with-style
-    ] ($block) ;
+    ] ($block) ; inline
 
-: ($vocab-link) ( vocab -- ) dup f >vocab-link write-link ;
+: $subsection ( element -- )
+    [ first ($long-link) ] ($subsection) ;
 
-: $vocab-link ( element -- ) first ($vocab-link) ;
+: ($vocab-link) ( text vocab -- ) f >vocab-link write-link ;
+
+: $vocab-subsection ( element -- )
+    [
+        first2 dup vocab-help dup [
+            2nip ($long-link)
+        ] [
+            drop ($vocab-link)
+        ] if
+    ] ($subsection) ;
+
+: $vocab-link ( element -- ) first dup ($vocab-link) ;
 
 : $vocabulary ( element -- )
     first word-vocabulary [

extra/io/launcher/launcher-docs.factor

@@ -35,33 +35,43 @@ HELP: +environment-mode+
 HELP: +stdin+
 { $description "Launch descriptor key. Must equal one of the following:"
     { $list
-        { { $link f } " - standard input is inherited" }
+        { { $link f } " - standard input is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
+        { { $link +inherit+ } " - standard input is inherited from the current process" }
         { { $link +closed+ } " - standard input is closed" }
         { "a path name - standard input is read from the given file, which must exist" }
+        { "a file stream or a socket - standard input is read from the given stream, which must be closed after the process has been started" }
     }
 } ;
 
 HELP: +stdout+
 { $description "Launch descriptor key. Must equal one of the following:"
     { $list
-        { { $link f } " - standard output is inherited" }
+        { { $link f } " - standard output is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
+        { { $link +inherit+ } " - standard output is inherited from the current process" }
         { { $link +closed+ } " - standard output is closed" }
         { "a path name - standard output is written to the given file, which is overwritten if it already exists" }
+        { "a file stream or a socket - standard output is written to the given stream, which must be closed after the process has been started" }
     }
 } ;
 
 HELP: +stderr+
 { $description "Launch descriptor key. Must equal one of the following:"
     { $list
-        { { $link f } " - standard error is inherited" }
+        { { $link f } " - standard error is inherited from the current process" }
+        { { $link +inherit+ } " - same as above" }
+        { { $link +stdout+ } " - standard error is merged with standard output" }
         { { $link +closed+ } " - standard error is closed" }
         { "a path name - standard error is written to the given file, which is overwritten if it already exists" }
+        { "a file stream or a socket - standard error is written to the given stream, which must be closed after the process has been started" }
     }
 } ;
 
 HELP: +closed+
 { $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
 
+HELP: +inherit+
+{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
+
 HELP: +prepend-environment+
 { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence."
 $nl

extra/io/windows/nt/launcher/launcher.factor

@@ -1,18 +1,38 @@
-! Copyright (C) 2007 Doug Coleman, Slava Pestov.
+! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays continuations destructors io
 io.windows libc io.nonblocking io.streams.duplex windows.types
 math windows.kernel32 windows namespaces io.launcher kernel
 sequences windows.errors assocs splitting system strings
 io.windows.launcher io.windows.nt.pipes io.backend
-combinators ;
+combinators shuffle ;
 IN: io.windows.nt.launcher
 
+: duplicate-handle ( handle -- handle' )
+    GetCurrentProcess ! source process
+    swap ! handle
+    GetCurrentProcess ! target process
+    f <void*> [ ! target handle
+        DUPLICATE_SAME_ACCESS ! desired access
+        TRUE ! inherit handle
+        DUPLICATE_CLOSE_SOURCE ! options
+        DuplicateHandle win32-error=0/f
+    ] keep *void* ;
+
 ! The below code is based on the example given in
 ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
 
-: (redirect) ( path access-mode create-mode -- handle )
+: redirect-default ( default obj access-mode create-mode -- handle )
-    >r >r
+    3drop ;
+
+: redirect-inherit ( default obj access-mode create-mode -- handle )
+    4drop f ;
+
+: redirect-closed ( default obj access-mode create-mode -- handle )
+    drop 2nip null-pipe ;
+
+: redirect-file ( default path access-mode create-mode -- handle )
+    >r >r >r drop r>
     normalize-pathname
     r> ! access-mode
     share-mode
@@ -22,47 +42,59 @@ IN: io.windows.nt.launcher
     f ! template file
     CreateFile dup invalid-handle? dup close-later ;
 
-: redirect ( obj access-mode create-mode -- handle )
-    {
-        { [ pick not ] [ 3drop f ] }
-        { [ pick +closed+ eq? ] [ drop nip null-pipe ] }
-        { [ pick string? ] [ (redirect) ] }
-    } cond ;
-
-: ?closed or dup t eq? [ drop f ] when ;
-
-: inherited-stdout ( args -- handle )
-    CreateProcess-args-stdout-pipe
-    [ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
-
-: redirect-stdout ( args -- handle )
-    +stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
-    swap inherited-stdout ?closed ;
-
-: inherited-stderr ( args -- handle )
-    drop STD_ERROR_HANDLE GetStdHandle ;
-
-: redirect-stderr ( args -- handle )
-    +stderr+ get
-    dup +stdout+ eq? [
-        drop
-        CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
-    ] [
-        GENERIC_WRITE CREATE_ALWAYS redirect
-        swap inherited-stderr ?closed
-    ] if ;
-
-: inherited-stdin ( args -- handle )
-    CreateProcess-args-stdin-pipe
-    [ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
-
-: redirect-stdin ( args -- handle )
-    +stdin+ get GENERIC_READ OPEN_EXISTING redirect
-    swap inherited-stdin ?closed ;
-
 : set-inherit ( handle ? -- )
     >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
 
+: redirect-stream ( default stream access-mode create-mode -- handle )
+    2drop nip
+    underlying-handle win32-file-handle
+    duplicate-handle dup t set-inherit ;
+
+: redirect ( default obj access-mode create-mode -- handle )
+    {
+        { [ pick not ] [ redirect-default ] }
+        { [ pick +inherit+ eq? ] [ redirect-inherit ] }
+        { [ pick +closed+ eq? ] [ redirect-closed ] }
+        { [ pick string? ] [ redirect-file ] }
+        { [ t ] [ redirect-stream ] }
+    } cond ;
+
+: default-stdout ( args -- handle )
+    CreateProcess-args-stdout-pipe dup [ pipe-out ] when ;
+
+: redirect-stdout ( args -- handle )
+    default-stdout
+    +stdout+ get
+    GENERIC_WRITE
+    CREATE_ALWAYS
+    redirect
+    STD_OUTPUT_HANDLE GetStdHandle or ;
+
+: redirect-stderr ( args -- handle )
+    +stderr+ get +stdout+ eq? [
+        CreateProcess-args-lpStartupInfo
+        STARTUPINFO-hStdOutput
+    ] [
+        drop
+        f
+        +stderr+ get
+        GENERIC_WRITE
+        CREATE_ALWAYS
+        redirect
+        STD_ERROR_HANDLE GetStdHandle or
+    ] if ;
+
+: default-stdin ( args -- handle )
+    CreateProcess-args-stdin-pipe dup [ pipe-in ] when ;
+
+: redirect-stdin ( args -- handle )
+    default-stdin
+    +stdin+ get
+    GENERIC_READ
+    OPEN_EXISTING
+    redirect
+    STD_INPUT_HANDLE GetStdHandle or ;
+
 : add-pipe-dtors ( pipe -- )
     dup
     pipe-in close-later

extra/io/windows/windows.factor

@@ -52,7 +52,7 @@ M: win32-file close-handle ( handle -- )
 : open-file ( path access-mode create-mode flags -- handle )
     [
         >r >r >r normalize-pathname r>
-        share-mode f r> r> CreateFile-flags f CreateFile
+        share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile
         dup invalid-handle? dup close-later
         dup add-completion
     ] with-destructors ;

extra/locals/locals.factor

@@ -279,7 +279,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ;
 ! are unified
 : create-method ( class generic -- method )
     2dup method dup
-    [ 2nip method-word ]
+    [ 2nip ]
     [ drop 2dup [ ] -rot define-method create-method ] if ;
 
 : CREATE-METHOD ( -- class generic body )
@@ -369,14 +369,14 @@ M: lambda-method definition
 
 : method-stack-effect
     dup "lambda" word-prop lambda-vars
-    swap "method" word-prop method-generic stack-effect dup [ effect-out ] when
+    swap "method-generic" word-prop stack-effect
+    dup [ effect-out ] when
     <effect> ;
 
 M: lambda-method synopsis*
-    dup definer.
+    dup dup definer.
-    dup "method" word-prop dup
+    "method-specializer" word-prop pprint*
-        method-specializer pprint*
+    "method-generic" word-prop pprint*
-        method-generic pprint*
     method-stack-effect effect>string comment. ;
 
 PRIVATE>

extra/logging/insomniac/insomniac-docs.factor

@@ -27,7 +27,7 @@ HELP: schedule-insomniac
 { $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } }
 { $description "Starts a thread which e-mails log reports and rotates logs daily." } ;
 
-ARTICLE: "logging.insomniac" "Automating log analysis and rotation"
+ARTICLE: "logging.insomniac" "Automated log analysis"
 "The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary."
 $nl
 "Required configuration parameters:"

extra/logging/logging-docs.factor

@@ -115,9 +115,9 @@ ARTICLE: "logging" "Logging framework"
 { $subsection "logging.levels" }
 { $subsection "logging.messages" }
 { $subsection "logging.rotation" }
-{ $subsection "logging.parser" }
+{ $vocab-subsection "Log file parser" "logging.parser" }
-{ $subsection "logging.analysis" }
+{ $vocab-subsection "Log analysis" "logging.analysis" }
-{ $subsection "logging.insomniac" }
+{ $vocab-subsection "Automated log analysis" "logging.insomniac" }
 { $subsection "logging.server" } ;
 
 ABOUT: "logging"

extra/tools/profiler/profiler.factor

@@ -29,9 +29,8 @@ M: string (profile.)
     dup <vocab-profile> write-object ;
 
 M: method-body (profile.)
-    "method" word-prop
+    dup synopsis swap "method-generic" word-prop
-    dup method-specializer over method-generic 2array synopsis
+    <usage-profile> write-object ;
-    swap method-generic <usage-profile> write-object ;
 
 : counter. ( obj n -- )
     [