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

basis/math/bitwise/bitwise-docs.factor

@@ -1,12 +1,8 @@
-USING: help.markup help.syntax math ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax math sequences ;
 IN: math.bitwise
 
-ARTICLE: "math-bitfields" "Constructing bit fields"
-"Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:"
-{ $subsection bitfield } ;
-
-ABOUT: "math-bitfields"
-
 HELP: bitfield
 { $values { "values..." "a series of objects" } { "bitspec" "an array" } { "n" integer } }
 { $description "Constructs an integer from a series of values on the stack together with a bit field specifier, which is an array whose elements have one of the following shapes:"
@@ -42,9 +38,307 @@ HELP: bits
 { $example "USING: math.bitwise prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ;
 
 HELP: bitroll
-{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } }
+{ $values { "x" integer } { "s" "a shift integer" } { "w" "a wrap integer" } { "y" integer }
+}
 { $description "Roll n by s bits to the left, wrapping around after w bits." }
 { $examples
     { $example "USING: math.bitwise prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
     { $example "USING: math.bitwise prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
 } ;
+
+HELP: bit-clear?
+{ $values
+     { "x" integer } { "n" integer }
+     { "?" "a boolean" }
+}
+{ $description "Returns " { $link t } " if the nth bit is set to zero." }
+{ $examples 
+    { $example "USING: math.bitwise prettyprint ;"
+               "HEX: ff 8 bit-clear? ."
+               "t"
+    }
+    { $example "" "USING: math.bitwise prettyprint ;"
+               "HEX: ff 7 bit-clear? ."
+               "f"
+    }
+} ;
+
+{ bit? bit-clear? set-bit clear-bit } related-words
+
+HELP: bit-count
+{ $values
+     { "x" integer }
+     { "n" integer }
+}
+{ $description "Returns the number of set bits as an integer." }
+{ $examples 
+    { $example "USING: math.bitwise prettyprint ;"
+               "HEX: f0 bit-count ."
+               "4"
+    }
+    { $example "USING: math.bitwise prettyprint ;"
+               "-7 bit-count ."
+               "2"
+    }
+} ;
+
+HELP: bitroll-32
+{ $values
+     { "n" integer } { "s" integer }
+     { "n'" integer }
+}     
+{ $description "Rolls the number " { $snippet "n" } " by " { $snippet "s" } " bits to the left, wrapping around after 32 bits." }
+{ $examples 
+    { $example "USING: math.bitwise prettyprint ;"
+               "HEX: 1 10 bitroll-32 .h"
+               "400"
+    }
+    { $example "USING: math.bitwise prettyprint ;"
+               "HEX: 1 -10 bitroll-32 .h"
+               "400000"
+    }
+} ;
+
+HELP: bitroll-64
+{ $values
+     { "n" integer } { "s" "a shift integer" }
+     { "n'" integer }
+}
+{ $description "Rolls the number " { $snippet "n" } " by " { $snippet "s" } " bits to the left, wrapping around after 64 bits." }
+{ $examples 
+    { $example "USING: math.bitwise prettyprint ;"
+               "HEX: 1 10 bitroll-64 .h"
+               "400"
+    }
+    { $example "USING: math.bitwise prettyprint ;"
+               "HEX: 1 -10 bitroll-64 .h"
+               "40000000000000"
+    }
+} ;
+
+{ bitroll bitroll-32 bitroll-64 } related-words
+
+HELP: clear-bit
+{ $values
+     { "x" integer } { "n" integer }
+     { "y" integer }
+}
+{ $description "Sets the nth bit of " { $snippet "x" } " to zero." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: ff 7 clear-bit .h"
+        "7f"
+    }
+} ;
+
+HELP: flags
+{ $values
+     { "values" sequence }
+}
+{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at compile-time, which makes this word as efficient as using a literal integer." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "IN: scratchpad"
+        ": MY-CONSTANT HEX: 1 ; inline"
+        "{ HEX: 20 MY-CONSTANT BIN: 100 } flags .h"
+        "25"
+    }
+} ;
+
+HELP: mask
+{ $values
+     { "x" integer } { "n" integer }
+     { "?" "a boolean" }
+}
+{ $description "After the operation, only the bits that were set in both the mask and the original number are set." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "BIN: 11111111 BIN: 101 mask .b"
+        "101"
+    }
+} ;
+
+HELP: mask-bit
+{ $values
+     { "m" integer } { "n" integer }
+     { "m'" integer }
+}
+{ $description "Turns off all bits besides the nth bit." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: ff 2 mask-bit .b"
+        "100"
+    }
+} ;
+
+HELP: mask?
+{ $values
+     { "x" integer } { "n" integer }
+     { "?" "a boolean" }
+}
+{ $description "Returns true if all of the bits in the mask " { $snippet "n" } " are set in the integer input " { $snippet "x" } "." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: ff HEX: f mask? ."
+        "t"
+    }
+
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: f0 HEX: 1 mask? ."
+        "f"
+    }
+} ;
+
+HELP: on-bits
+{ $values
+     { "n" integer }
+     { "m" integer }
+}
+{ $description "Returns an integer with " { $snippet "n" } " bits set." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "6 on-bits .h"
+        "3f"
+    }
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "64 on-bits .h"
+        "ffffffffffffffff"
+    }
+}
+;
+
+HELP: set-bit
+{ $values
+     { "x" integer } { "n" integer }
+     { "y" integer }
+}
+{ $description "Sets the nth bit of " { $snippet "x" } "." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "0 5 set-bit .h"
+        "20"
+    }
+} ;
+
+HELP: shift-mod
+{ $values
+     { "n" integer } { "s" integer } { "w" integer }
+     { "n" integer }
+}
+{ $description "" } ;
+
+HELP: unmask
+{ $values
+     { "x" integer } { "n" integer }
+     { "?" "a boolean" }
+}
+{ $description "Clears the bits in " { $snippet "x" } " if they are set in the mask " { $snippet "n" } "." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: ff  HEX: 0f unmask .h"
+        "f0"
+    }
+} ;
+
+HELP: unmask?
+{ $values
+     { "x" integer } { "n" integer }
+     { "?" "a boolean" }
+}
+{ $description "Tests whether unmasking the bits in " { $snippet "x" } " would return an integer greater than zero." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: ff  HEX: 0f unmask? ."
+        "t"
+    }
+} ;
+
+HELP: w*
+{ $values
+     { "int" integer } { "int" integer }
+     { "int" integer }
+}
+{ $description "Multiplies two integers and wraps the result to 32 bits." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: ffffffff HEX: 2 w* ."
+        "4294967294"
+    }
+} ;
+
+HELP: w+
+{ $values
+     { "int" integer } { "int" integer }
+     { "int" integer }
+}
+{ $description "Adds two integers and wraps the result to 32 bits." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: ffffffff HEX: 2 w+ ."
+        "1"
+    }
+} ;
+
+HELP: w-
+{ $values
+     { "int" integer } { "int" integer }
+     { "int" integer }
+}
+{ $description "Subtracts two integers and wraps the result to 32 bits." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: 0 HEX: ff w- ."
+        "4294967041"
+    }
+} ;
+
+HELP: wrap
+{ $values
+     { "m" integer } { "n" integer }
+     { "m'" integer }
+}
+{ $description "Wraps an integer " { $snippet "m" } " by modding it by " { $snippet "n" } ". This word is uses bitwise arithmetic and does not actually call the modulus word, and as such can only mod by powers of two." }
+{ $examples "Equivalent to modding by 8:"
+    { $example 
+        "USING: math.bitwise prettyprint ;"
+        "HEX: ffff 8 wrap .h"
+        "7"
+    }
+} ;
+
+ARTICLE: "math-bitfields" "Constructing bit fields"
+"Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:"
+{ $subsection bitfield } ;
+
+ARTICLE: "math.bitwise" "Bitwise arithmetic"
+"The " { $vocab-link "math.bitwise" } " vocabulary can implements bitwise arithmetic words that are useful for efficiency, low-level programming, and interfacing with C libraries." $nl
+"Setting and clearing bits:"
+{ $subsection set-bit }
+{ $subsection clear-bit }
+"Testing if bits are set or clear:"
+{ $subsection bit? }
+{ $subsection bit-clear? }
+"Operations with bitmasks:"
+{ $subsection mask }
+{ $subsection unmask }
+{ $subsection mask? }
+{ $subsection unmask? }
+"Generating an integer with n set bits:"
+{ $subsection on-bits }
+"Counting the number of set bits:"
+{ $subsection bit-count }
+"More efficient modding by powers of two:"
+{ $subsection wrap }
+"Bit-rolling:"
+{ $subsection bitroll }
+{ $subsection bitroll-32 }
+{ $subsection bitroll-64 }
+"32-bit arithmetic:"
+{ $subsection w+ }
+{ $subsection w- }
+{ $subsection w* }
+"Bitfields:"
+{ $subsection flags }
+{ $subsection "math-bitfields" } ;
+
+ABOUT: "math.bitwise"

basis/math/bitwise/bitwise-tests.factor

@@ -27,3 +27,5 @@ IN: math.bitwise.tests
 [ 3 ] [ foo ] unit-test
 [ 3 ] [ { a b } flags ] unit-test
 \ foo must-infer
+
+[ 1 ] [ { 1 } flags ] unit-test

basis/math/bitwise/bitwise.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel math math.functions sequences
 sequences.private words namespaces macros hints
@@ -8,28 +8,29 @@ IN: math.bitwise
 ! utilities
 : clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
 : set-bit ( x n -- y ) 2^ bitor ; inline
-: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline
+: bit-clear? ( x n -- ? ) 2^ bitand 0 = ; inline
 : unmask ( x n -- ? ) bitnot bitand ; inline
 : unmask? ( x n -- ? ) unmask 0 > ; inline
 : mask ( x n -- ? ) bitand ; inline
 : mask? ( x n -- ? ) mask 0 > ; inline
 : wrap ( m n -- m' ) 1- bitand ; inline
 : bits ( m n -- m' ) 2^ wrap ; inline
-: mask-bit ( m n -- m' ) 1- 2^ mask ; inline
+: mask-bit ( m n -- m' ) 2^ mask ; inline
+: on-bits ( n -- m ) 2^ 1- ; inline
 
 : shift-mod ( n s w -- n )
-    >r shift r> 2^ wrap ; inline
+    [ shift ] dip 2^ wrap ; inline
 
 : bitroll ( x s w -- y )
-     [ wrap ] keep
+    [ wrap ] keep
-     [ shift-mod ]
+    [ shift-mod ]
-     [ [ - ] keep shift-mod ] 3bi bitor ; inline
+    [ [ - ] keep shift-mod ] 3bi bitor ; inline
 
-: bitroll-32 ( n s -- n' ) 32 bitroll ;
+: bitroll-32 ( n s -- n' ) 32 bitroll ; inline
 
 HINTS: bitroll-32 bignum fixnum ;
 
-: bitroll-64 ( n s -- n' ) 64 bitroll ;
+: bitroll-64 ( n s -- n' ) 64 bitroll ; inline
 
 HINTS: bitroll-64 bignum fixnum ;
 
@@ -40,7 +41,7 @@ HINTS: bitroll-64 bignum fixnum ;
 
 ! flags
 MACRO: flags ( values -- )
-    [ 0 ] [ [ execute bitor ] curry compose ] reduce ;
+    [ 0 ] [ [ dup word? [ execute ] when bitor ] curry compose ] reduce ;
 
 ! bitfield
 <PRIVATE
@@ -51,7 +52,7 @@ M: integer (bitfield-quot) ( spec -- quot )
     [ swapd shift bitor ] curry ;
 
 M: pair (bitfield-quot) ( spec -- quot )
-    first2 over word? [ >r swapd execute r> ] [ ] ?
+    first2 over word? [ [ swapd execute ] dip ] [ ] ?
     [ shift bitor ] append 2curry ;
 
 PRIVATE>
@@ -91,4 +92,4 @@ M: bignum (bit-count)
 PRIVATE>
 
 : bit-count ( x -- n )
-    dup 0 >= [ (bit-count) ] [ bitnot (bit-count) ] if ; inline
+    dup 0 < [ bitnot ] when (bit-count) ; inline

basis/random/mersenne-twister/mersenne-twister.factor

@@ -16,7 +16,7 @@ TUPLE: mersenne-twister seq i ;
 : mt-a HEX: 9908b0df ; inline
 
 : calculate-y ( n seq -- y )
-    [ nth 32 mask-bit ]
+    [ nth 31 mask-bit ]
     [ [ 1+ ] [ nth ] bi* 31 bits ] 2bi bitor ; inline
 
 : (mt-generate) ( n seq -- next-mt )

basis/tools/scaffold/scaffold.factor

@@ -148,7 +148,7 @@ ERROR: no-vocab vocab ;
             "{ $values" print
             [ "    " write ($values.) ]
             [ [ nl "    " write ($values.) ] unless-empty ] bi*
-            " }" write nl
+            nl "}" print
         ] if
     ] when* ;
 

basis/unix/groups/groups-tests.factor

@@ -22,3 +22,5 @@ IN: unix.groups.tests
 
 [ ] [ effective-group-name [ ] with-effective-group ] unit-test
 [ ] [ effective-group-id [ ] with-effective-group ] unit-test
+
+[ ] [ [ ] with-group-cache ] unit-test

basis/unix/users/users-docs.factor

@@ -22,8 +22,8 @@ HELP: new-passwd
 HELP: passwd
 { $description "A platform-specific tuple correspding to every field from the Unix passwd struct. BSD passwd structures have four extra slots: " { $slot "change" } ", " { $slot "class" } "," { $slot "expire" } ", " { $slot "fields" } "." } ;
 
-HELP: passwd-cache
+HELP: user-cache
-{ $description "A symbol storing passwd structures indexed by user-ids when within a " { $link with-passwd-cache } "." } ;
+{ $description "A symbol storing passwd structures indexed by user-ids when within a " { $link with-user-cache } "." } ;
 
 HELP: passwd>new-passwd
 { $values
@@ -70,10 +70,10 @@ HELP: with-effective-user
      { "string/id" "a string or a uid" } { "quot" quotation } }
 { $description "Sets the effective username and calls the quotation. Restores the current username on success or on error after the call." } ;
 
-HELP: with-passwd-cache
+HELP: with-user-cache
 { $values
      { "quot" quotation } }
-{ $description "Iterates over the password file using library calls and creates a cache in the " { $link passwd-cache } " symbol. The cache is a hashtable indexed by user id. When looking up many users, this approach is much faster than calling system calls." } ;
+{ $description "Iterates over the password file using library calls and creates a cache in the " { $link user-cache } " symbol. The cache is a hashtable indexed by user id. When looking up many users, this approach is much faster than calling system calls." } ;
 
 HELP: with-real-user
 { $values

basis/unix/users/users-tests.factor

@@ -22,3 +22,5 @@ IN: unix.users.tests
 
 [ ] [ effective-username [ ] with-effective-user ] unit-test
 [ ] [ effective-user-id [ ] with-effective-user ] unit-test
+
+[ ] [ [ ] with-user-cache ] unit-test

basis/unix/users/users.factor

@@ -39,16 +39,16 @@ PRIVATE>
         [ getpwent dup ] [ passwd>new-passwd ] [ drop ] produce
     ] with-pwent ;
 
-SYMBOL: passwd-cache
+SYMBOL: user-cache
 
-: with-passwd-cache ( quot -- )
+: with-user-cache ( quot -- )
     all-users [ [ uid>> ] keep ] H{ } map>assoc
-    passwd-cache swap with-variable ; inline
+    user-cache rot with-variable ; inline
 
 GENERIC: user-passwd ( obj -- passwd )
 
 M: integer user-passwd ( id -- passwd/f )
-    passwd-cache get
+    user-cache get
     [ at ] [ getpwuid passwd>new-passwd ] if* ;
 
 M: string user-passwd ( string -- passwd/f )

extra/ftp/client/client.factor

@@ -120,7 +120,7 @@ name target ;
 
 ERROR: ftp-error got expected ;
 : ftp-assert ( ftp-response n -- )
-    2dup >r n>> r> = [ 2drop ] [ ftp-error ] if ;
+    2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ;
 
 : ftp-login ( ftp-client -- )
     read-response 220 ftp-assert
@@ -156,12 +156,12 @@ GENERIC: ftp-download ( path obj -- )
     dupd '[
         _ [ ftp-login ] [ @ ] bi
         ftp-quit drop
-    ] >r ftp-connect r> with-stream ; inline
+    ] [ ftp-connect ] dip with-stream ; inline
 
 M: ftp-client ftp-download ( path ftp-client -- )
     [
         [ drop parent-directory ftp-cwd drop ]
-        [ >r file-name r> ftp-get drop ] 2bi
+        [ [ file-name ] dip ftp-get drop ] 2bi
     ] with-ftp-client ;
 
 M: string ftp-download ( path string -- )

extra/ftp/ftp.factor

@@ -36,7 +36,6 @@ TUPLE: ftp-response n strings parsed ;
 : ftp-ipv4 1 ; inline
 : ftp-ipv6 2 ; inline
 
-
 : ch>type ( ch -- type )
     {
         { CHAR: d [ +directory+ ] }
@@ -54,9 +53,13 @@ TUPLE: ftp-response n strings parsed ;
     } case ;
 
 : file-info>string ( file-info name -- string )
-    >r [ [ type>> type>ch 1string ] [ drop "rwx------" append ] bi ]
+    [
-    [ size>> number>string 15 CHAR: \s pad-left ] bi r>
+        [
-    3array " " join ;
+            [ type>> type>ch 1string ]
+            [ drop "rwx------" append ] bi
+        ]
+        [ size>> number>string 15 CHAR: \s pad-left ] bi
+    ] dip 3array " " join ;
 
 : directory-list ( -- seq )
     "" directory-files

extra/ftp/server/server.factor

@@ -6,7 +6,8 @@ io.encodings.utf8 io.files io.sockets kernel math.parser
 namespaces make sequences ftp io.unix.launcher.parser
 unicode.case splitting assocs classes io.servers.connection
 destructors calendar io.timeouts io.streams.duplex threads
-continuations math concurrency.promises byte-arrays ;
+continuations math concurrency.promises byte-arrays sequences.lib
+hexdump ;
 IN: ftp.server
 
 SYMBOL: client
@@ -19,12 +20,14 @@ TUPLE: ftp-command raw tokenized ;
 TUPLE: ftp-get path ;
 
 : <ftp-get> ( path -- obj )
-    ftp-get new swap >>path ;
+    ftp-get new
+        swap >>path ;
 
 TUPLE: ftp-put path ;
 
 : <ftp-put> ( path -- obj )
-    ftp-put new swap >>path ;
+    ftp-put new
+        swap >>path ;
 
 TUPLE: ftp-list ;
 
@@ -62,7 +65,7 @@ C: <ftp-list> ftp-list
 
 : handle-USER ( ftp-command -- )
     [
-        tokenized>> second client get swap >>user drop
+        tokenized>> second client get (>>user)
         331 "Please specify the password." server-response
     ] [
         2drop "bad USER" ftp-error
@@ -70,7 +73,7 @@ C: <ftp-list> ftp-list
 
 : handle-PASS ( ftp-command -- )
     [
-        tokenized>> second client get swap >>password drop
+        tokenized>> second client get (>>password)
         230 "Login successful" server-response
     ] [
         2drop "PASS error" ftp-error
@@ -101,20 +104,20 @@ ERROR: type-error type ;
 
 : handle-PWD ( obj -- )
     drop
-    257 current-directory get "\"" swap "\"" 3append server-response ;
+    257 current-directory get "\"" "\"" surround server-response ;
 
 : handle-SYST ( obj -- )
     drop
     215 "UNIX Type: L8" server-response ;
 
 : if-command-promise ( quot -- )
-    >r client get command-promise>> r>
+    [ client get command-promise>> ] dip
     [ "Establish an active or passive connection first" ftp-error ] if* ;
 
 : handle-STOR ( obj -- )
     [
         tokenized>> second
-        [ >r <ftp-put> r> fulfill ] if-command-promise
+        [ [ <ftp-put> ] dip fulfill ] if-command-promise
     ] [
         2drop
     ] recover ;
@@ -145,7 +148,7 @@ M: ftp-list service-command ( stream obj -- )
     rot   
     [ file-name ] [
         " " swap  file-info size>> number>string
-        "(" " bytes)." swapd 3append append
+        "(" " bytes)." surround append
     ] bi 3append server-response ;
 
 : transfer-incoming-file ( path -- )
@@ -191,7 +194,7 @@ M: ftp-put service-command ( stream obj -- )
 
 : handle-LIST ( obj -- )
     drop
-    [ >r <ftp-list> r> fulfill ] if-command-promise ;
+    [ [ <ftp-list> ] dip fulfill ] if-command-promise ;
 
 : handle-SIZE ( obj -- )
     [
@@ -217,7 +220,7 @@ M: ftp-put service-command ( stream obj -- )
     expect-connection
     [
         "Entering Passive Mode (127,0,0,1," %
-        port>bytes [ number>string ] bi@ "," swap 3append %
+        port>bytes [ number>string ] bi@ "," splice %
         ")" %
     ] "" make 227 swap server-response ;
 
@@ -242,7 +245,7 @@ ERROR: not-a-directory ;
             set-current-directory
             250 "Directory successully changed." server-response
         ] [
-            not-a-directory throw
+            not-a-directory
         ] if
     ] [
         2drop

extra/math/floating-point/floating-point.factor

@@ -1,32 +1,40 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences ;
+USING: kernel math sequences prettyprint math.parser io
+math.functions ;
 IN: math.floating-point
 
-: float-sign ( float -- ? )
+: (double-sign) ( bits -- n ) -63 shift ; inline
-    float>bits -31 shift { 1 -1 } nth ; 
+: double-sign ( double -- n ) double>bits (double-sign) ;
 
-: double-sign ( float -- ? )
+: (double-exponent-bits) ( bits -- n )
-    double>bits -63 shift { 1 -1 } nth ;
+    -52 shift 11 2^ 1- bitand ; inline
-
-: float-exponent-bits ( float -- n )
-    float>bits -23 shift 8 2^ 1- bitand ;
 
 : double-exponent-bits ( double -- n )
-    double>bits -52 shift 11 2^ 1- bitand ;
+    double>bits (double-exponent-bits) ;
 
-: float-mantissa-bits ( float -- n )
+: (double-mantissa-bits) ( double -- n )
-    float>bits 23 2^ 1- bitand ;
+    52 2^ 1- bitand ;
 
 : double-mantissa-bits ( double -- n )
-    double>bits 52 2^ 1- bitand ;
+    double>bits (double-mantissa-bits) ;
 
-: float-e ( -- float ) 127 ; inline
+: >double ( S E M -- frac )
-: double-e ( -- float ) 1023 ; inline
+    [ 52 shift ] dip
+    [ 63 shift ] 2dip bitor bitor bits>double ;
 
-! : calculate-float ( S M E -- float )
+: >double< ( double -- S E M )
-    ! float-e - 2^ * * ; ! bits>float ;
+    double>bits
+    [ (double-sign) ]
+    [ (double-exponent-bits) ]
+    [ (double-mantissa-bits) ] tri ;
 
-! : calculate-double ( S M E -- frac )
+: double. ( double -- )
-    ! double-e - 2^ swap 52 2^ /f 1+ * * ;
+    double>bits
+    [ (double-sign) .b ]
+    [ (double-exponent-bits) >bin 11 CHAR: 0 pad-left bl print ]
+    [
+        (double-mantissa-bits) >bin 52 CHAR: 0 pad-left
+        11 [ bl ] times print
+    ] tri ;
 

extra/pack/pack.factor

@@ -88,7 +88,7 @@ M: string b, ( n string -- ) heap-size b, ;
 
 : (read-128-ber) ( n -- n )
     read1
-    [ >r 7 shift r> 7 clear-bit bitor ] keep
+    [ [ 7 shift ] [ 7 clear-bit ] bi* bitor ] keep
     7 bit? [ (read-128-ber) ] when ;
     
 : read-128-ber ( -- n )

extra/roman/roman-docs.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax kernel math ;
 IN: roman
 
@@ -5,44 +7,114 @@ HELP: >roman
 { $values { "n" "an integer" } { "str" "a string" } }
 { $description "Converts a number to its lower-case Roman Numeral equivalent." }
 { $notes "The range for this word is 1-3999, inclusive." }
-{ $see-also >ROMAN roman> } ;
+{ $examples 
+    { $example "USING: io roman ;"
+               "56 >roman print"
+               "lvi"
+    }
+} ;
 
 HELP: >ROMAN
 { $values { "n" "an integer" } { "str" "a string" } }
 { $description "Converts a number to its upper-case Roman numeral equivalent." }
 { $notes "The range for this word is 1-3999, inclusive." }
-{ $see-also >roman roman> } ;
+{ $examples 
+    { $example "USING: io roman ;"
+               "56 >ROMAN print"
+               "LVI"
+    }
+} ;
 
 HELP: roman>
 { $values { "str" "a string" } { "n" "an integer" } }
 { $description "Converts a Roman numeral to an integer." }
 { $notes "The range for this word is i-mmmcmxcix, inclusive." }
-{ $see-also >roman } ;
+{ $examples 
+    { $example "USING: prettyprint roman ;"
+               "\"lvi\" roman> ."
+               "56"
+    }
+} ;
+
+{ >roman >ROMAN roman> } related-words
 
 HELP: roman+
 { $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
 { $description "Adds two Roman numerals." }
-{ $see-also roman- } ;
+{ $examples 
+    { $example "USING: io roman ;"
+               "\"v\" \"v\" roman+ print"
+               "x"
+    }
+} ;
 
 HELP: roman-
 { $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
 { $description "Subtracts two Roman numerals." }
-{ $see-also roman+ } ;
+{ $examples 
+    { $example "USING: io roman ;"
+               "\"x\" \"v\" roman- print"
+               "v"
+    }
+} ;
+
+{ roman+ roman- } related-words
 
 HELP: roman*
 { $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
 { $description "Multiplies two Roman numerals." }
-{ $see-also roman/i roman/mod } ;
+{ $examples 
+    { $example "USING: io roman ;"
+        "\"ii\" \"iii\" roman* print"
+        "vi"
+    }
+} ;
 
 HELP: roman/i
 { $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
 { $description "Computes the integer division of two Roman numerals." }
-{ $see-also roman* roman/mod /i } ;
+{ $examples 
+    { $example "USING: io roman ;"
+        "\"v\" \"iv\" roman/i print"
+        "i"
+    }
+} ;
 
 HELP: roman/mod
 { $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } }
 { $description "Computes the quotient and remainder of two Roman numerals." }
-{ $see-also roman* roman/i /mod } ;
+{ $examples 
+    { $example "USING: kernel io roman ;"
+        "\"v\" \"iv\" roman/mod [ print ] bi@"
+        "i\ni"
+    }
+} ;
+
+{ roman* roman/i roman/mod } related-words
 
 HELP: ROMAN:
-{ $description "A parsing word that reads the next token and converts it to an integer." } ;
+{ $description "A parsing word that reads the next token and converts it to an integer." }
+{ $examples 
+    { $example "USING: prettyprint roman ;"
+               "ROMAN: v ."
+               "5"
+    }
+} ;
+
+ARTICLE: "roman" "Roman numerals"
+"The " { $vocab-link "roman" } " vocabulary can convert numbers to and from the Roman numeral system and can perform arithmetic given Roman numerals as input." $nl
+"A parsing word for literal Roman numerals:"
+{ $subsection POSTPONE: ROMAN: }
+"Converting to Roman numerals:"
+{ $subsection >roman }
+{ $subsection >ROMAN }
+"Converting Roman numerals to integers:"
+{ $subsection roman> }
+"Roman numeral arithmetic:"
+{ $subsection roman+ }
+{ $subsection roman- }
+{ $subsection roman* }
+{ $subsection roman/i }
+{ $subsection roman/mod } ;
+
+ABOUT: "roman"

extra/sequences/lib/lib.factor

@@ -152,3 +152,6 @@ PRIVATE>
 
 : enumerate ( seq -- seq' ) <enum> >alist ;
 
+: splice ( left-seq right-seq seq -- newseq ) swap 3append ;
+
+: surround ( seq left-seq right-seq -- newseq ) swapd 3append ;