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

db4
Slava Pestov 2008-11-11 13:14:56 -06:00
commit d53d7d0baa
16 changed files with 467 additions and 77 deletions

View File

@ -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 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 HELP: bitfield
{ $values { "values..." "a series of objects" } { "bitspec" "an array" } { "n" integer } } { $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:" { $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" } ; { $example "USING: math.bitwise prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ;
HELP: bitroll 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." } { $description "Roll n by s bits to the left, wrapping around after w bits." }
{ $examples { $examples
{ $example "USING: math.bitwise prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" } { $example "USING: math.bitwise prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
{ $example "USING: math.bitwise prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" } { $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"

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -22,8 +22,8 @@ HELP: new-passwd
HELP: 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" } "." } ; { $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 HELP: passwd>new-passwd
{ $values { $values
@ -70,10 +70,10 @@ HELP: with-effective-user
{ "string/id" "a string or a uid" } { "quot" quotation } } { "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." } ; { $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 { $values
{ "quot" quotation } } { "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 HELP: with-real-user
{ $values { $values

View File

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

View File

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

View File

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

View File

@ -36,7 +36,6 @@ TUPLE: ftp-response n strings parsed ;
: ftp-ipv4 1 ; inline : ftp-ipv4 1 ; inline
: ftp-ipv6 2 ; inline : ftp-ipv6 2 ; inline
: ch>type ( ch -- type ) : ch>type ( ch -- type )
{ {
{ CHAR: d [ +directory+ ] } { CHAR: d [ +directory+ ] }
@ -54,9 +53,13 @@ TUPLE: ftp-response n strings parsed ;
} case ; } case ;
: file-info>string ( file-info name -- string ) : 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-list ( -- seq )
"" directory-files "" directory-files

View File

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

View File

@ -1,32 +1,40 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! 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 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-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-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 ;

View File

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

View File

@ -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 ; USING: help.markup help.syntax kernel math ;
IN: roman IN: roman
@ -5,44 +7,114 @@ HELP: >roman
{ $values { "n" "an integer" } { "str" "a string" } } { $values { "n" "an integer" } { "str" "a string" } }
{ $description "Converts a number to its lower-case Roman Numeral equivalent." } { $description "Converts a number to its lower-case Roman Numeral equivalent." }
{ $notes "The range for this word is 1-3999, inclusive." } { $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 HELP: >ROMAN
{ $values { "n" "an integer" } { "str" "a string" } } { $values { "n" "an integer" } { "str" "a string" } }
{ $description "Converts a number to its upper-case Roman numeral equivalent." } { $description "Converts a number to its upper-case Roman numeral equivalent." }
{ $notes "The range for this word is 1-3999, inclusive." } { $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> HELP: roman>
{ $values { "str" "a string" } { "n" "an integer" } } { $values { "str" "a string" } { "n" "an integer" } }
{ $description "Converts a Roman numeral to an integer." } { $description "Converts a Roman numeral to an integer." }
{ $notes "The range for this word is i-mmmcmxcix, inclusive." } { $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+ HELP: roman+
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } } { $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $description "Adds two Roman numerals." } { $description "Adds two Roman numerals." }
{ $see-also roman- } ; { $examples
{ $example "USING: io roman ;"
"\"v\" \"v\" roman+ print"
"x"
}
} ;
HELP: roman- HELP: roman-
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } } { $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $description "Subtracts two Roman numerals." } { $description "Subtracts two Roman numerals." }
{ $see-also roman+ } ; { $examples
{ $example "USING: io roman ;"
"\"x\" \"v\" roman- print"
"v"
}
} ;
{ roman+ roman- } related-words
HELP: roman* HELP: roman*
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } } { $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $description "Multiplies two Roman numerals." } { $description "Multiplies two Roman numerals." }
{ $see-also roman/i roman/mod } ; { $examples
{ $example "USING: io roman ;"
"\"ii\" \"iii\" roman* print"
"vi"
}
} ;
HELP: roman/i HELP: roman/i
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } } { $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $description "Computes the integer division of two Roman numerals." } { $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 HELP: roman/mod
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } } { $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } }
{ $description "Computes the quotient and remainder of two Roman numerals." } { $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: 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"

View File

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