Merge commit 'origin/master' into emacs

basis/columns/columns.factor

@@ -9,7 +9,7 @@ TUPLE: column seq col ;
 C: <column> column
 
 M: column virtual-seq seq>> ;
-M: column virtual@ dup col>> -rot seq>> nth bounds-check ;
+M: column virtual@ [ col>> swap ] [ seq>> ] bi nth bounds-check ;
 M: column length seq>> length ;
 
 INSTANCE: column virtual-sequence

basis/disjoint-sets/disjoint-sets.factor

@@ -60,8 +60,8 @@ GENERIC: add-atom ( a disjoint-set -- )
 
 M: disjoint-set add-atom
     [ dupd parents>> set-at ]
-    [ 0 -rot ranks>> set-at ]
+    [ [ 0 ] 2dip ranks>> set-at ]
-    [ 1 -rot counts>> set-at ]
+    [ [ 1 ] 2dip counts>> set-at ]
     2tri ;
 
 : add-atoms ( seq disjoint-set -- ) '[ _ add-atom ] each ;

basis/documents/documents.factor

@@ -153,18 +153,18 @@ GENERIC: next-elt ( loc document elt -- newloc )
 TUPLE: char-elt ;
 
 : (prev-char) ( loc document quot -- loc )
-    -rot {
+    {
-        { [ over { 0 0 } = ] [ drop ] }
+        { [ pick { 0 0 } = ] [ 2drop ] }
-        { [ over second zero? ] [ [ first 1- ] dip line-end ] }
+        { [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
-        [ pick call ]
+        [ call ]
-    } cond nip ; inline
+    } cond ; inline
 
 : (next-char) ( loc document quot -- loc )
-    -rot {
+    {
-        { [ 2dup doc-end = ] [ drop ] }
+        { [ 2over doc-end = ] [ 2drop ] }
-        { [ 2dup line-end? ] [ drop first 1+ 0 2array ] }
+        { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
-        [ pick call ]
+        [ call ]
-    } cond nip ; inline
+    } cond ; inline
 
 M: char-elt prev-elt
     drop [ drop -1 +col ] (prev-char) ;

basis/help/cookbook/cookbook.factor

@@ -100,14 +100,12 @@ $nl
 { $code "10 [ \"Factor rocks!\" print ] times" }
 "Now we can look at a new data type, the array:"
 { $code "{ 1 2 3 }" }
-"An array looks like a quotation except it cannot be evaluated; it simply stores data."
+"An array differs from a quotation in that it cannot be evaluated; it simply stores data."
 $nl
 "You can perform an operation on each element of an array:"
 { $example
     "{ 1 2 3 } [ \"The number is \" write . ] each"
-    "The number is 1"
+    "The number is 1\nThe number is 2\nThe number is 3"
-    "The number is 2"
-    "The number is 3"
 }
 "You can transform each element, collecting the results in a new array:"
 { $example "{ 5 12 0 -12 -5 } [ sq ] map ." "{ 25 144 0 144 25 }" }

basis/inspector/inspector.factor

@@ -3,7 +3,7 @@
 USING: accessors arrays generic hashtables io kernel assocs math
 namespaces prettyprint sequences strings io.styles vectors words
 quotations mirrors splitting math.parser classes vocabs refs
-sets sorting summary debugger continuations ;
+sets sorting summary debugger continuations fry ;
 IN: inspector
 
 : value-editor ( path -- )
@@ -53,7 +53,7 @@ SYMBOL: +editable+
     [ drop ] [
         dup enum? [ +sequence+ on ] when
         standard-table-style [
-            swap [ -rot describe-row ] curry each-index
+            swap '[ [ _ ] 2dip describe-row ] each-index
         ] tabular-output
     ] if-empty ;
 
@@ -64,7 +64,7 @@ M: tuple error. describe ;
 
 : namestack. ( seq -- )
     [ [ global eq? not ] filter [ keys ] gather ] keep
-    [ dupd assoc-stack ] curry H{ } map>assoc describe ;
+    '[ dup _ assoc-stack ] H{ } map>assoc describe ;
 
 : .vars ( -- )
     namestack namestack. ;

basis/logging/logging.factor

@@ -61,7 +61,7 @@ PRIVATE>
     [ dup ] 2dip 2curry annotate ;
 
 : call-logging-quot ( quot word level -- quot' )
-    "called" -rot [ log-message ] 3curry prepose ;
+    [ "called" ] 2dip [ log-message ] 3curry prepose ;
 
 : add-logging ( word level -- )
     [ call-logging-quot ] (define-logging) ;

basis/logging/server/server.factor

@@ -28,7 +28,7 @@ SYMBOL: log-files
 
 : multiline-header ( -- string ) 20 CHAR: - <string> ; foldable
 
-: (write-message) ( msg name>> level multi? -- )
+: (write-message) ( msg word-name level multi? -- )
     [
         "[" write multiline-header write "] " write
     ] [
@@ -36,18 +36,19 @@ SYMBOL: log-files
     ] if
     write bl write ": " write print ;
 
-: write-message ( msg name>> level -- )
+: write-message ( msg word-name level -- )
-    rot harvest {
+    [ harvest ] 2dip {
-        { [ dup empty? ] [ 3drop ] }
+        { [ pick empty? ] [ 3drop ] }
-        { [ dup length 1 = ] [ first -rot f (write-message) ] }
+        { [ pick length 1 = ] [ [ first ] 2dip f (write-message) ] }
         [
-            [ first -rot f (write-message) ] 3keep
+            [ [ first ] 2dip f (write-message) ]
-            rest -rot [ t (write-message) ] 2curry each
+            [ [ rest ] 2dip [ t (write-message) ] 2curry each ]
+            3bi
         ]
     } cond ;
 
 : (log-message) ( msg -- )
-    #! msg: { msg name>> level service }
+    #! msg: { msg word-name level service }
     first4 log-stream [ write-message flush ] with-output-stream* ;
 
 : try-dispose ( stream -- )

basis/math/ratios/ratios.factor

@@ -50,11 +50,11 @@ M: ratio <= scale <= ;
 M: ratio > scale > ;
 M: ratio >= scale >= ;
 
-M: ratio + 2dup scale + -rot ratio+d / ;
+M: ratio + [ scale + ] [ ratio+d ] 2bi / ;
-M: ratio - 2dup scale - -rot ratio+d / ;
+M: ratio - [ scale - ] [ ratio+d ] 2bi / ;
-M: ratio * 2>fraction * [ * ] dip / ;
+M: ratio * 2>fraction [ * ] 2bi@ / ;
 M: ratio / scale / ;
 M: ratio /i scale /i ;
 M: ratio /f scale /f ;
-M: ratio mod [ /i ] 2keep rot * - ;
+M: ratio mod 2dup /i * - ;
 M: ratio /mod [ /i ] 2keep mod ;

basis/mirrors/mirrors.factor

@@ -32,7 +32,7 @@ M: mirror set-at ( val key mirror -- )
     swap set-slot ;
 
 M: mirror delete-at ( key mirror -- )
-    f -rot set-at ;
+    [ f ] 2dip set-at ;
 
 M: mirror clear-assoc ( mirror -- )
     [ object>> ] [ object-slots ] bi [

basis/opengl/capabilities/capabilities.factor

@@ -1,14 +1,11 @@
 ! Copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces make sequences splitting opengl.gl
-continuations math.parser math arrays sets math.order ;
+continuations math.parser math arrays sets math.order fry ;
 IN: opengl.capabilities
 
 : (require-gl) ( thing require-quot make-error-quot -- )
-    -rot dupd call
+    [ dupd call [ drop ] ] dip '[ _ " " make throw ] if ; inline
-    [ 2drop ]
-    [ swap " " make throw ]
-    if ; inline
 
 : gl-extensions ( -- seq )
     GL_EXTENSIONS glGetString " " split ;

basis/opengl/opengl.factor

@@ -6,7 +6,7 @@ USING: alien alien.c-types continuations kernel libc math macros
 namespaces math.vectors math.constants math.functions
 math.parser opengl.gl opengl.glu combinators arrays sequences
 splitting words byte-arrays assocs colors accessors
-generalizations locals specialized-arrays.float
+generalizations locals fry specialized-arrays.float
 specialized-arrays.uint ;
 IN: opengl
 
@@ -154,19 +154,21 @@ MACRO: all-enabled-client-state ( seq quot -- )
 : delete-gl-buffer ( id -- )
     [ glDeleteBuffers ] (delete-gl-object) ;
 
-: with-gl-buffer ( binding id quot -- )
+:: with-gl-buffer ( binding id quot -- )
-    -rot dupd glBindBuffer
+    binding id glBindBuffer
-    [ slip ] [ 0 glBindBuffer ] [ ] cleanup ; inline
+    quot [ binding 0 glBindBuffer ] [ ] cleanup ; inline
 
 : with-array-element-buffers ( array-buffer element-buffer quot -- )
-    -rot GL_ELEMENT_ARRAY_BUFFER swap [
+    [ GL_ELEMENT_ARRAY_BUFFER ] 2dip '[
-        swap GL_ARRAY_BUFFER -rot with-gl-buffer
+        GL_ARRAY_BUFFER swap _ with-gl-buffer
     ] with-gl-buffer ; inline
 
 : <gl-buffer> ( target data hint -- id )
-    pick gen-gl-buffer [ [
+    pick gen-gl-buffer [
-        [ dup byte-length swap ] dip glBufferData
+        [
-    ] with-gl-buffer ] keep ;
+            [ [ byte-length ] keep ] dip glBufferData
+        ] with-gl-buffer
+    ] keep ;
 
 : buffer-offset ( int -- alien )
     <alien> ; inline

basis/peg/parsers/parsers.factor

@@ -51,8 +51,7 @@ PRIVATE>
   dup zero? [
     2drop epsilon
   ] [
-    2dup exactly-n
+    [ exactly-n ] [ 1- at-most-n ] 2bi 2choice
-    -rot 1- at-most-n 2choice
   ] if ;
 
 : at-least-n ( parser n -- parser' )

basis/peg/peg.factor

@@ -373,7 +373,7 @@ TUPLE: range-parser min max ;
   pick empty? [ 
     3drop f 
   ] [
-    pick first -rot between? [
+    [ dup first ] 2dip between? [
       unclip-slice <parse-result>
     ] [ 
       drop f

basis/sequences/deep/deep.factor

@@ -14,11 +14,11 @@ M: object branch? drop f ;
 
 : deep-each ( obj quot: ( elt -- ) -- )
     [ call ] 2keep over branch?
-    [ [ deep-each ] curry each ] [ 2drop ] if ; inline recursive
+    [ '[ _ deep-each ] each ] [ 2drop ] if ; inline recursive
 
 : deep-map ( obj quot: ( elt -- elt' ) -- newobj )
     [ call ] keep over branch?
-    [ [ deep-map ] curry map ] [ drop ] if ; inline recursive
+    [ '[ _ deep-map ] map ] [ drop ] if ; inline recursive
 
 : deep-filter ( obj quot: ( elt -- ? ) -- seq )
     over [ pusher [ deep-each ] dip ] dip
@@ -27,7 +27,7 @@ M: object branch? drop f ;
 : (deep-find) ( obj quot: ( elt -- ? ) -- elt ? )
     [ call ] 2keep rot [ drop t ] [
         over branch? [
-            f -rot [ [ nip ] dip (deep-find) ] curry find drop >boolean
+            [ f ] 2dip '[ nip _ (deep-find) ] find drop >boolean
         ] [ 2drop f f ] if  
     ] if ; inline recursive
 
@@ -36,7 +36,7 @@ M: object branch? drop f ;
 : deep-contains? ( obj quot -- ? ) (deep-find) nip ; inline
 
 : deep-all? ( obj quot -- ? )
-    [ not ] compose deep-contains? not ; inline
+    '[ @ not ] deep-contains? not ; inline
 
 : deep-member? ( obj seq -- ? )
     swap '[
@@ -50,7 +50,7 @@ M: object branch? drop f ;
 
 : deep-change-each ( obj quot: ( elt -- elt' ) -- )
     over branch? [
-        [ [ call ] keep over [ deep-change-each ] dip ] curry change-each
+        '[ _ [ call ] keep over [ deep-change-each ] dip ] change-each
     ] [ 2drop ] if ; inline recursive
 
 : flatten ( obj -- seq )

basis/tools/deploy/macosx/macosx.factor

@@ -13,7 +13,7 @@ IN: tools.deploy.macosx
     vm parent-directory parent-directory ;
 
 : copy-bundle-dir ( bundle-name dir -- )
-    bundle-dir over append-path -rot
+    [ bundle-dir prepend-path swap ] keep
     "Contents" prepend-path append-path copy-tree ;
 
 : app-plist ( executable bundle-name -- assoc )

basis/uuid/uuid-docs.factor

@@ -4,23 +4,27 @@ USING: help.syntax help.markup kernel prettyprint sequences strings ;
 IN: uuid
 
 HELP: uuid1
+{ $values { "string" "a UUID string" } }
 { $description 
     "Generates a UUID (version 1) from the host ID, sequence number, "
     "and current time."
 } ;
 
 HELP: uuid3
+{ $values { "namespace" string } { "name" string } { "string" "a UUID string" } }
 { $description 
     "Generates a UUID (version 3) from the MD5 hash of a namespace "
     "UUID and a name."
 } ;
 
 HELP: uuid4
+{ $values { "string" "a UUID string" } }
 { $description 
     "Generates a UUID (version 4) from random bits." 
 } ;
 
 HELP: uuid5
+{ $values { "namespace" string } { "name" string } { "string" "a UUID string" } }
 { $description 
     "Generates a UUID (version 5) from the SHA-1 hash of a namespace " 
     "UUID and a name."
@@ -28,12 +32,10 @@ HELP: uuid5
 
 
 ARTICLE: "uuid" "UUID (Universally Unique Identifier)"
-"The " { $vocab-link "uuid" } " vocabulary is used to generate UUID's. "
+"The " { $vocab-link "uuid" } " vocabulary is used to generate UUIDs. "
-"The words uuid1, uuid3, uuid4, uuid5 can be used to generate version "
+"The below words can be used to generate version 1, 3, 4, and 5 UUIDs as specified in RFC 4122."
-"1, 3, 4, and 5 UUIDs as specified in RFC 4122.\n"
+$nl 
-"\n" 
+"If all you want is a unique ID, you should probably call " { $link uuid1 } " or " { $link uuid4 } "."
-"If all you want is a unique ID, you should probably call uuid1 or uuid4."
-"\n"
 { $subsection uuid1 }
 { $subsection uuid3 }
 { $subsection uuid4 }

basis/uuid/uuid.factor

@@ -3,7 +3,7 @@
 
 USING: byte-arrays checksums checksums.md5 checksums.sha1 
 kernel math math.parser math.ranges random unicode.case 
-sequences strings system ;
+sequences strings system io.binary ;
 
 IN: uuid 
 
@@ -16,7 +16,8 @@ IN: uuid
     micros 10 * HEX: 01b21dd213814000 +
     [ -48 shift HEX: 0fff bitand ] 
     [ -32 shift HEX: ffff bitand ]
-    [ HEX: ffffffff bitand ] tri ;
+    [ HEX: ffffffff bitand ]
+    tri ;
 
 : (hardware) ( -- address ) 
     ! Choose a random 48-bit number with eighth bit 
@@ -35,9 +36,10 @@ IN: uuid
     bitor ;
 
 : (version) ( n version -- n' )
-    [ HEX: c000 48 shift bitnot bitand 
+    [
-      HEX: 8000 48 shift bitor 
+        HEX: c000 48 shift bitnot bitand 
-      HEX: f000 64 shift bitnot bitand
+        HEX: 8000 48 shift bitor 
+        HEX: f000 64 shift bitnot bitand
     ] dip 76 shift bitor ;
 
 : uuid>string ( n -- string )
@@ -51,13 +53,7 @@ IN: uuid
     [ CHAR: - = not ] filter 16 base> ;
 
 : uuid>byte-array ( n -- byte-array ) 
-    16 <byte-array> 15 -1 [a,b) [ 
+    16 >be ;
-        [ dup HEX: ff bitand ] 2dip swap
-        [ set-nth -8 shift ] keep 
-    ] each nip ;
-
-: byte-array>uuid ( byte-array -- n )
-     0 swap [ [ 8 shift ] dip + ] each ;
 
 PRIVATE>
 
@@ -65,15 +61,15 @@ PRIVATE>
     string>uuid uuid>byte-array ;
 
 : uuid-unparse ( byte-array -- string ) 
-    byte-array>uuid uuid>string ;
+    be> uuid>string ;
 
 : uuid1 ( -- string )
     (hardware) (clock) (timestamp) <uuid> 
     1 (version) uuid>string ;
 
 : uuid3 ( namespace name -- string )
-    [ uuid-parse ] dip >byte-array append 
+    [ uuid-parse ] dip append 
-    md5 checksum-bytes 16 short head byte-array>uuid 
+    md5 checksum-bytes 16 short head be> 
     3 (version) uuid>string ;
 
 : uuid4 ( -- string )
@@ -81,14 +77,13 @@ PRIVATE>
     4 (version) uuid>string ;
 
 : uuid5 ( namespace name -- string )
-   [ uuid-parse ] dip >byte-array append 
+    [ uuid-parse ] dip append 
-    sha1 checksum-bytes 16 short head byte-array>uuid 
+    sha1 checksum-bytes 16 short head be> 
     5 (version) uuid>string ;
 
-
+CONSTANT: NAMESPACE_DNS  "6ba7b810-9dad-11d1-80b4-00c04fd430c8"
-: NAMESPACE_DNS  "6ba7b810-9dad-11d1-80b4-00c04fd430c8" ; inline
+CONSTANT: NAMESPACE_URL  "6ba7b811-9dad-11d1-80b4-00c04fd430c8"
-: NAMESPACE_URL  "6ba7b811-9dad-11d1-80b4-00c04fd430c8" ; inline
+CONSTANT: NAMESPACE_OID  "6ba7b812-9dad-11d1-80b4-00c04fd430c8"
-: NAMESPACE_OID  "6ba7b812-9dad-11d1-80b4-00c04fd430c8" ; inline
+CONSTANT: NAMESPACE_X500 "6ba7b814-9dad-11d1-80b4-00c04fd430c8"
-: NAMESPACE_X500 "6ba7b814-9dad-11d1-80b4-00c04fd430c8" ; inline
 
 

core/math/math.factor

@@ -114,7 +114,7 @@ M: float fp-infinity? ( float -- ? )
 
 <PRIVATE
 
-: iterate-prep ( n quot -- i n quot ) 0 -rot ; inline
+: iterate-prep ( n quot -- i n quot ) [ 0 ] 2dip ; inline
 
 : if-iterate? ( i n true false -- ) [ 2over < ] 2dip if ; inline
 

core/words/words.factor

@@ -54,7 +54,7 @@ M: primitive definition drop f ;
 SYMBOL: bootstrapping?
 
 : if-bootstrapping ( true false -- )
-    bootstrapping? get -rot if ; inline
+    [ bootstrapping? get ] 2dip if ; inline
 
 : bootstrap-word ( word -- target )
     [ target-word ] [ ] if-bootstrapping ;

extra/bunny/model/model.factor

@@ -30,7 +30,7 @@ IN: bunny.model
     [ n ] keep [ rot [ v+ ] change-nth ] with with each ;
 
 : normals ( vs is -- ns )
-    over length { 0.0 0.0 0.0 } <array> -rot
+    [ [ length { 0.0 0.0 0.0 } <array> ] keep ] dip
     [ [ 2dup ] dip normal ] each drop
     [ normalize ] map ;
 

extra/size-of/size-of.factor

@@ -0,0 +1,38 @@
+
+USING: io io.encodings.ascii io.files io.files.temp io.launcher
+       locals math.parser sequences sequences.deep ;
+
+IN: size-of
+
+! Use 'size-of' to find out the size in bytes of a C type.
+!
+! The 'headers' argument is a list of header files to use. You may
+! pass 'f' to only use 'stdio.h'.
+!
+! Examples:
+! 
+!   f "int" size-of .
+! 
+!   { "X11/Xlib.h" } "XAnyEvent" size-of .
+
+:: size-of ( HEADERS TYPE -- n )
+
+  [let | C-FILE   [ "size-of.c" temp-file ]
+         EXE-FILE [ "size-of"   temp-file ]
+         INCLUDES [ HEADERS [| FILE | { "#include <" FILE ">" } concat ] map ] |
+
+    {
+      "#include <stdio.h>"
+      INCLUDES
+      "main() { printf( \"%i\" , sizeof( " TYPE " ) ) ; }"
+    }
+
+    flatten C-FILE  ascii  set-file-lines
+
+    { "gcc" C-FILE "-o" EXE-FILE } try-process
+
+    EXE-FILE ascii <process-reader> contents string>number ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+