diff --git a/basis/math/bitwise/bitwise-docs.factor b/basis/math/bitwise/bitwise-docs.factor index 247523369b..4f2606bda0 100644 --- a/basis/math/bitwise/bitwise-docs.factor +++ b/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" diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor index 8b13cb23b3..4422992956 100644 --- a/basis/math/bitwise/bitwise-tests.factor +++ b/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 diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 871f40e74c..ad1907fcb0 100644 --- a/basis/math/bitwise/bitwise.factor +++ b/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 - [ shift-mod ] - [ [ - ] keep shift-mod ] 3bi bitor ; inline + [ wrap ] keep + [ shift-mod ] + [ [ - ] 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 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 diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index 712883e4b8..c31d338fac 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/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 ) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 6659940b2b..e1076775fa 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/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* ; diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor index 9e7122fc34..7e7ebd902a 100644 --- a/basis/unix/groups/groups-tests.factor +++ b/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 diff --git a/basis/unix/users/users-docs.factor b/basis/unix/users/users-docs.factor index c466ad1575..83e7e99481 100644 --- a/basis/unix/users/users-docs.factor +++ b/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 -{ $description "A symbol storing passwd structures indexed by user-ids when within a " { $link with-passwd-cache } "." } ; +HELP: user-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 diff --git a/basis/unix/users/users-tests.factor b/basis/unix/users/users-tests.factor index a85c322aca..1113383635 100644 --- a/basis/unix/users/users-tests.factor +++ b/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 diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index eac771160b..f76fbd5388 100644 --- a/basis/unix/users/users.factor +++ b/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 ) diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor index 9b9a2214c1..8413331c00 100644 --- a/extra/ftp/client/client.factor +++ b/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 -- ) diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor index 1fd97df6d5..8f0b48bd4d 100644 --- a/extra/ftp/ftp.factor +++ b/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 diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor index 3ecf8d2f3f..170155bd43 100644 --- a/extra/ftp/server/server.factor +++ b/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 ; : ( path -- obj ) - ftp-get new swap >>path ; + ftp-get new + swap >>path ; TUPLE: ftp-put path ; : ( path -- obj ) - ftp-put new swap >>path ; + ftp-put new + swap >>path ; TUPLE: ftp-list ; @@ -62,7 +65,7 @@ C: 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 : 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 r> fulfill ] if-command-promise + [ [ ] 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 r> fulfill ] if-command-promise ; + [ [ ] 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 diff --git a/extra/math/floating-point/floating-point.factor b/extra/math/floating-point/floating-point.factor index 87767181cd..3792d6ba9b 100644 --- a/extra/math/floating-point/floating-point.factor +++ b/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 -- ? ) - float>bits -31 shift { 1 -1 } nth ; +: (double-sign) ( bits -- n ) -63 shift ; inline +: double-sign ( double -- n ) double>bits (double-sign) ; -: double-sign ( float -- ? ) - double>bits -63 shift { 1 -1 } nth ; - -: float-exponent-bits ( float -- n ) - float>bits -23 shift 8 2^ 1- bitand ; +: (double-exponent-bits) ( bits -- n ) + -52 shift 11 2^ 1- bitand ; inline : double-exponent-bits ( double -- n ) - double>bits -52 shift 11 2^ 1- bitand ; + double>bits (double-exponent-bits) ; -: float-mantissa-bits ( float -- n ) - float>bits 23 2^ 1- bitand ; +: (double-mantissa-bits) ( double -- n ) + 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-e ( -- float ) 1023 ; inline +: >double ( S E M -- frac ) + [ 52 shift ] dip + [ 63 shift ] 2dip bitor bitor bits>double ; -! : calculate-float ( S M E -- float ) - ! float-e - 2^ * * ; ! bits>float ; +: >double< ( double -- S E M ) + double>bits + [ (double-sign) ] + [ (double-exponent-bits) ] + [ (double-mantissa-bits) ] tri ; -! : calculate-double ( S M E -- frac ) - ! double-e - 2^ swap 52 2^ /f 1+ * * ; +: double. ( double -- ) + 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 ; diff --git a/extra/pack/pack.factor b/extra/pack/pack.factor index 889eecb49a..0e5cb7dbbc 100755 --- a/extra/pack/pack.factor +++ b/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 ) diff --git a/extra/roman/roman-docs.factor b/extra/roman/roman-docs.factor index 87551635f1..4a8197f064 100644 --- a/extra/roman/roman-docs.factor +++ b/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" diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 6fe3de4f03..9dc01c04fa 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -152,3 +152,6 @@ PRIVATE> : enumerate ( seq -- seq' ) >alist ; +: splice ( left-seq right-seq seq -- newseq ) swap 3append ; + +: surround ( seq left-seq right-seq -- newseq ) swapd 3append ;