steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix conflicts

db4
Slava Pestov 2008-12-01 20:39:43 -06:00
parent e8a69a3aea 6c5aeca2f7
commit f51708386d
205 changed files with 5061 additions and 2852 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
README.txt
View File

@ -43,13 +43,10 @@ Compilation will yield an executable named 'factor' on Unix,
For X11 support, you need recent development libraries for libc,
Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
(like Ubuntu), you can use the line
(like Ubuntu), you can use the following line to grab everything:
sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
to grab everything (if you're on a non-debian-derived distro please tell
us what the equivalent command is on there and it can be added).
* Bootstrapping the Factor image
Once you have compiled the Factor runtime, you must bootstrap the Factor

6
basis/alien/c-types/c-types.factor
View File

@ -52,7 +52,7 @@ GENERIC: c-type ( name -- type ) foldable
: parse-array-type ( name -- array )
"[" split unclip
>r [ "]" ?tail drop string>number ] map r> prefix ;
[ [ "]" ?tail drop string>number ] map ] dip prefix ;
M: string c-type ( name -- type )
CHAR: ] over member? [
@ -201,10 +201,10 @@ M: byte-array byte-length length ;
1 swap malloc-array ; inline
: malloc-byte-array ( byte-array -- alien )
dup length dup malloc [ -rot memcpy ] keep ;
dup length [ nip malloc dup ] 2keep memcpy ;
: memory>byte-array ( alien len -- byte-array )
dup <byte-array> [ -rot memcpy ] keep ;
[ nip <byte-array> dup ] 2keep memcpy ;
: byte-array>memory ( byte-array base -- )
swap dup length memcpy ;

19
basis/alien/parser/parser.factor Normal file
View File

@ -0,0 +1,19 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays assocs effects grouping kernel
parser sequences splitting words fry locals ;
IN: alien.parser
: parse-arglist ( parameters return -- types effect )
[ 2 group unzip [ "," ?tail drop ] map ]
[ [ { } ] [ 1array ] if-void ]
bi* <effect> ;
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
:: define-function ( return library function parameters -- )
function create-in dup reset-generic
return library function
parameters return parse-arglist [ function-quot ] dip
define-declared ;

2
basis/alien/strings/strings.factor
View File

@ -9,7 +9,7 @@ IN: alien.strings
GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
M: c-ptr alien>string
>r <memory-stream> r> <decoder>
[ <memory-stream> ] [ <decoder> ] bi*
"\0" swap stream-read-until drop ;
M: f alien>string

18
basis/alien/structs/fields/fields.factor
View File

@ -29,10 +29,10 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
writer>> swap "writing" set-word-prop ;
: reader-word ( class name vocab -- word )
>r >r "-" r> 3append r> create ;
[ "-" swap 3append ] dip create ;
: writer-word ( class name vocab -- word )
>r [ swap "set-" % % "-" % % ] "" make r> create ;
[ [ swap "set-" % % "-" % % ] "" make ] dip create ;
: <field-spec> ( struct-name vocab type field-name -- spec )
field-spec new
@ -52,25 +52,21 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
[ (>>offset) ] [ type>> heap-size + ] 2bi
] reduce ;
: define-struct-slot-word ( spec word quot -- )
rot offset>> prefix define-inline ;
: define-struct-slot-word ( word quot spec -- )
offset>> prefix define-inline ;
: define-getter ( type spec -- )
[ set-reader-props ] keep
[ ]
[ reader>> ]
[
type>>
[ c-getter ] [ c-type-boxer-quot ] bi append
] tri
define-struct-slot-word ;
]
[ ] tri define-struct-slot-word ;
: define-setter ( type spec -- )
[ set-writer-props ] keep
[ ]
[ writer>> ]
[ type>> c-setter ] tri
define-struct-slot-word ;
[ writer>> ] [ type>> c-setter ] [ ] tri define-struct-slot-word ;
: define-field ( type spec -- )
[ define-getter ] [ define-setter ] 2bi ;

2
basis/alien/structs/structs-tests.factor
View File

@ -38,7 +38,7 @@ C-UNION: barx
[ 120 ] [ "barx" heap-size ] unit-test
"help" vocab [
"help" "help" lookup "help" set
"print-topic" "help" lookup "help" set
[ ] [ \ foox-x "help" get execute ] unit-test
[ ] [ \ set-foox-x "help" get execute ] unit-test
] when

12
basis/alien/structs/structs.factor
View File

@ -39,7 +39,7 @@ M: struct-type stack-size
: c-struct? ( type -- ? ) (c-type) struct-type? ;
: (define-struct) ( name size align fields -- )
>r [ align ] keep r>
[ [ align ] keep ] dip
struct-type boa
swap typedef ;
@ -50,11 +50,11 @@ M: struct-type stack-size
[ c-type-align ] map supremum ;
: define-struct ( name vocab fields -- )
pick >r
[ struct-offsets ] keep
[ [ type>> ] map compute-struct-align ] keep
[ (define-struct) ] keep
r> [ swap define-field ] curry each ;
pick [
[ struct-offsets ] keep
[ [ type>> ] map compute-struct-align ] keep
[ (define-struct) ] keep
] dip [ swap define-field ] curry each ;
: define-union ( name vocab members -- )
[ expand-constants ] map

10
basis/alien/syntax/syntax-docs.factor
View File

@ -1,5 +1,5 @@
IN: alien.syntax
USING: alien alien.c-types alien.structs alien.syntax.private
USING: alien alien.c-types alien.parser alien.structs
help.markup help.syntax ;
HELP: DLL"
@ -54,12 +54,6 @@ HELP: TYPEDEF:
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." }
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
HELP: TYPEDEF-IF:
{ $syntax "TYPEDEF-IF: word old new" }
{ $values { "word" "a word with stack effect " { $snippet "( -- ? )" } } { "old" "a C type" } { "new" "a C type" } }
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if " { $snippet "word" } " evaluates to a true value." }
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
HELP: C-STRUCT:
{ $syntax "C-STRUCT: name pairs... ;" }
{ $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
@ -88,7 +82,7 @@ HELP: typedef
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
{ $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ;
{ POSTPONE: TYPEDEF-IF: POSTPONE: TYPEDEF: typedef } related-words
{ POSTPONE: TYPEDEF: typedef } related-words
HELP: c-struct?
{ $values { "type" "a string" } { "?" "a boolean" } }

35
basis/alien/syntax/syntax.factor
View File

@ -4,35 +4,9 @@ USING: accessors arrays alien alien.c-types alien.structs
alien.arrays alien.strings kernel math namespaces parser
sequences words quotations math.parser splitting grouping
effects prettyprint prettyprint.sections prettyprint.backend
assocs combinators lexer strings.parser ;
assocs combinators lexer strings.parser alien.parser ;
IN: alien.syntax
<PRIVATE
: parse-arglist ( return seq -- types effect )
2 group dup keys swap values [ "," ?tail drop ] map
rot dup "void" = [ drop { } ] [ 1array ] if <effect> ;
: function-quot ( type lib func types -- quot )
[ alien-invoke ] 2curry 2curry ;
: define-function ( return library function parameters -- )
>r pick r> parse-arglist
pick create-in dup reset-generic
>r >r function-quot r> r>
-rot define-declared ;
PRIVATE>
: indirect-quot ( function-ptr-quot return types abi -- quot )
[ alien-indirect ] 3curry compose ;
: define-indirect ( abi return function-ptr-quot function-name parameters -- )
>r pick r> parse-arglist
rot create-in dup reset-generic
>r >r swapd roll indirect-quot r> r>
-rot define-declared ;
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
: ALIEN: scan string>number <alien> parsed ; parsing
@ -49,13 +23,10 @@ PRIVATE>
: TYPEDEF:
scan scan typedef ; parsing
: TYPEDEF-IF:
scan-word execute scan scan rot [ typedef ] [ 2drop ] if ; parsing
: C-STRUCT:
scan in get
parse-definition
>r 2dup r> define-struct-early
[ 2dup ] dip define-struct-early
define-struct ; parsing
: C-UNION:
@ -64,7 +35,7 @@ PRIVATE>
: C-ENUM:
";" parse-tokens
dup length
[ >r create-in r> 1quotation define ] 2each ;
[ [ create-in ] dip 1quotation define ] 2each ;
parsing
M: alien pprint*

2
basis/bit-vectors/bit-vectors-tests.factor
View File

@ -4,7 +4,7 @@ USING: tools.test bit-vectors vectors sequences kernel math ;
[ 0 ] [ 123 <bit-vector> length ] unit-test
: do-it
1234 swap [ >r even? r> push ] curry each ;
1234 swap [ [ even? ] dip push ] curry each ;
[ t ] [
3 <bit-vector> dup do-it

8
basis/bootstrap/image/image.factor
View File

@ -72,7 +72,7 @@ SYMBOL: objects
: put-object ( n obj -- ) (objects) set-at ;
: cache-object ( obj quot -- value )
>r (objects) r> [ obj>> ] prepose cache ; inline
[ (objects) ] dip [ obj>> ] prepose cache ; inline
! Constants
@ -97,10 +97,10 @@ SYMBOL: sub-primitives
{ [ { } make ] [ ] [ ] [ ] } spread 4array ; inline
: jit-define ( quot rc rt offset name -- )
>r make-jit r> set ; inline
[ make-jit ] dip set ; inline
: define-sub-primitive ( quot rc rt offset word -- )
>r make-jit r> sub-primitives get set-at ;
[ make-jit ] dip sub-primitives get set-at ;
! The image being constructed; a vector of word-size integers
SYMBOL: image
@ -205,7 +205,7 @@ SYMBOL: undefined-quot
: emit-fixnum ( n -- ) tag-fixnum emit ;
: emit-object ( header tag quot -- addr )
swap here-as >r swap tag-fixnum emit call align-here r> ;
swap here-as [ swap tag-fixnum emit call align-here ] dip ;
inline
! Write an object to the image.

11
basis/bootstrap/stage2.factor
View File

@ -59,9 +59,9 @@ SYMBOL: bootstrap-time
"math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
"" "exclude" set-global
parse-command-line
(command-line) parse-command-line
"-no-crossref" cli-args member? [ do-crossref ] unless
do-crossref
! Set dll paths
os wince? [ "windows.ce" require ] when
@ -92,12 +92,7 @@ SYMBOL: bootstrap-time
[
boot
do-init-hooks
[
parse-command-line
run-user-init
"run" get run
output-stream get [ stream-flush ] when*
] [ print-error 1 exit ] recover
handle-command-line
] set-boot-quot
millis swap - bootstrap-time set-global

2
basis/boxes/boxes.factor
View File

@ -23,4 +23,4 @@ ERROR: box-empty box ;
dup occupied>> [ box> t ] [ drop f f ] if ;
: if-box? ( box quot -- )
>r ?box r> [ drop ] if ; inline
[ ?box ] dip [ drop ] if ; inline

56
basis/calendar/calendar-docs.factor
View File

@ -99,6 +99,48 @@ HELP: seconds-per-year
{ $values { "integer" integer } }
{ $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
HELP: biweekly
{ $values
{ "x" number }
{ "y" number }
}
{ $description "Divides a number by the number of two week periods in a year." } ;
HELP: daily-360
{ $values
{ "x" number }
{ "y" number }
}
{ $description "Divides a number by the number of days in a 360-day year." } ;
HELP: daily-365
{ $values
{ "x" number }
{ "y" number }
}
{ $description "Divides a number by the number of days in a 365-day year." } ;
HELP: monthly
{ $values
{ "x" number }
{ "y" number }
}
{ $description "Divides a number by the number of months in a year." } ;
HELP: semimonthly
{ $values
{ "x" number }
{ "y" number }
}
{ $description "Divides a number by the number of half-months in a year. Note that biweekly has two more periods than semimonthly." } ;
HELP: weekly
{ $values
{ "x" number }
{ "y" number }
}
{ $description "Divides a number by the number of weeks in a year." } ;
HELP: julian-day-number
{ $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } }
{ $description "Calculates the Julian day number from a year, month, and day. The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." }
@ -540,6 +582,8 @@ ARTICLE: "calendar" "Calendar"
{ $subsection "years" }
{ $subsection "months" }
{ $subsection "days" }
"Calculating amounts per period of time:"
{ $subsection "time-period-calculations" }
"Meta-data about the calendar:"
{ $subsection "calendar-facts" }
;
@ -626,6 +670,18 @@ ARTICLE: "calendar-facts" "Calendar facts"
{ $subsection day-of-week }
;
ARTICLE: "time-period-calculations" "Calculations over periods of time"
{ $subsection monthly }
{ $subsection semimonthly }
{ $subsection biweekly }
{ $subsection weekly }
{ $subsection daily-360 }
{ $subsection daily-365 }
{ $subsection biweekly }
{ $subsection biweekly }
{ $subsection biweekly }
;
ARTICLE: "years" "Year operations"
"Leap year predicate:"
{ $subsection leap-year? }

2
basis/calendar/calendar-tests.factor
View File

@ -167,3 +167,5 @@ IN: calendar.tests
[ t ] [ now 50 milliseconds sleep now before? ] unit-test
[ t ] [ now 50 milliseconds sleep now swap after? ] unit-test
[ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
[ 4+1/6 ] [ 100 semimonthly ] unit-test

34
basis/calendar/calendar.factor
View File

@ -89,6 +89,13 @@ PRIVATE>
: minutes-per-year ( -- ratio ) 5259492/10 ; inline
: seconds-per-year ( -- integer ) 31556952 ; inline
: monthly ( x -- y ) 12 / ; inline
: semimonthly ( x -- y ) 24 / ; inline
: biweekly ( x -- y ) 26 / ; inline
: weekly ( x -- y ) 52 / ; inline
: daily-360 ( x -- y ) 360 / ; inline
: daily-365 ( x -- y ) 365 / ; inline
:: julian-day-number ( year month day -- n )
#! Returns a composite date number
#! Not valid before year -4800
@ -173,7 +180,7 @@ M: real +year ( timestamp n -- timestamp )
12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
M: integer +month ( timestamp n -- timestamp )
[ over month>> + months/years >r >>month r> +year ] unless-zero ;
[ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
M: real +month ( timestamp n -- timestamp )
[ float>whole-part swapd average-month * +day swap +month ] unless-zero ;
@ -181,7 +188,7 @@ M: real +month ( timestamp n -- timestamp )
M: integer +day ( timestamp n -- timestamp )
[
over >date< julian-day-number + julian-day-number>date
>r >r >>year r> >>month r> >>day
[ >>year ] [ >>month ] [ >>day ] tri*
] unless-zero ;
M: real +day ( timestamp n -- timestamp )
@ -191,7 +198,7 @@ M: real +day ( timestamp n -- timestamp )
24 /rem swap ;
M: integer +hour ( timestamp n -- timestamp )
[ over hour>> + hours/days >r >>hour r> +day ] unless-zero ;
[ over hour>> + hours/days [ >>hour ] dip +day ] unless-zero ;
M: real +hour ( timestamp n -- timestamp )
float>whole-part swapd 60 * +minute swap +hour ;
@ -200,7 +207,7 @@ M: real +hour ( timestamp n -- timestamp )
60 /rem swap ;
M: integer +minute ( timestamp n -- timestamp )
[ over minute>> + minutes/hours >r >>minute r> +hour ] unless-zero ;
[ over minute>> + minutes/hours [ >>minute ] dip +hour ] unless-zero ;
M: real +minute ( timestamp n -- timestamp )
[ float>whole-part swapd 60 * +second swap +minute ] unless-zero ;
@ -209,7 +216,7 @@ M: real +minute ( timestamp n -- timestamp )
60 /rem swap >integer ;
M: number +second ( timestamp n -- timestamp )
[ over second>> + seconds/minutes >r >>second r> +minute ] unless-zero ;
[ over second>> + seconds/minutes [ >>second ] dip +minute ] unless-zero ;
: (time+)
[ second>> +second ] keep
@ -226,7 +233,7 @@ PRIVATE>
GENERIC# time+ 1 ( time1 time2 -- time3 )
M: timestamp time+
>r clone r> (time+) drop ;
[ clone ] dip (time+) drop ;
M: duration time+
dup timestamp? [
@ -284,7 +291,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
: (time-) ( timestamp timestamp -- n )
[ >gmt ] bi@
[ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
[ >time< >r >r 3600 * r> 60 * r> + + ] bi@ - + ;
[ >time< [ [ 3600 * ] [ 60 * ] bi* ] dip + + ] bi@ - + ;
M: timestamp time-
#! Exact calendar-time difference
@ -320,13 +327,13 @@ M: duration time-
1970 1 1 0 0 0 instant <timestamp> ;
: millis>timestamp ( x -- timestamp )
>r unix-1970 r> milliseconds time+ ;
[ unix-1970 ] dip milliseconds time+ ;
: timestamp>millis ( timestamp -- n )
unix-1970 (time-) 1000 * >integer ;
: micros>timestamp ( x -- timestamp )
>r unix-1970 r> microseconds time+ ;
[ unix-1970 ] dip microseconds time+ ;
: timestamp>micros ( timestamp -- n )
unix-1970 (time-) 1000000 * >integer ;
@ -343,10 +350,11 @@ M: duration time-
#! Zeller Congruence
#! http://web.textfiles.com/computers/formulas.txt
#! good for any date since October 15, 1582
>r dup 2 <= [ 12 + >r 1- r> ] when
>r dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + r>
[ 1+ 3 * 5 /i + ] keep 2 * + r>
1+ + 7 mod ;
[
dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
[ dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + ] dip
[ 1+ 3 * 5 /i + ] keep 2 * +
] dip 1+ + 7 mod ;
GENERIC: days-in-year ( obj -- n )

21
basis/calendar/format/format.factor
View File

@ -138,11 +138,11 @@ M: timestamp year. ( timestamp -- )
: read-rfc3339-gmt-offset ( ch -- dt )
dup CHAR: Z = [ drop instant ] [
>r
read-00 hours
read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
time+
r> signed-gmt-offset
[
read-00 hours
read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
time+
] dip signed-gmt-offset
] if ;
: read-ymd ( -- y m d )
@ -152,8 +152,9 @@ M: timestamp year. ( timestamp -- )
read-00 ":" expect read-00 ":" expect read-00 ;
: read-rfc3339-seconds ( s -- s' ch )
"+-Z" read-until >r
[ string>number ] [ length 10 swap ^ ] bi / + r> ;
"+-Z" read-until [
[ string>number ] [ length 10 swap ^ ] bi / +
] dip ;
: (rfc3339>timestamp) ( -- timestamp )
read-ymd
@ -181,9 +182,9 @@ ERROR: invalid-timestamp-format ;
: parse-rfc822-gmt-offset ( string -- dt )
dup "GMT" = [ drop instant ] [
unclip >r
2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
r> signed-gmt-offset
unclip [
2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
] dip signed-gmt-offset
] if ;
: (rfc822>timestamp) ( -- timestamp )

2
basis/channels/remote/remote.factor
View File

@ -14,7 +14,7 @@ IN: channels.remote
PRIVATE>
: publish ( channel -- id )
256 random-bits dup >r remote-channels set-at r> ;
256 random-bits dup [ remote-channels set-at ] dip ;
: get-channel ( id -- channel )
remote-channels at ;

2
basis/checksums/openssl/openssl.factor
View File

@ -28,7 +28,7 @@ M: evp-md-context dispose
handle>> EVP_MD_CTX_cleanup drop ;
: with-evp-md-context ( quot -- )
maybe-init-ssl >r <evp-md-context> r> with-disposal ; inline
maybe-init-ssl [ <evp-md-context> ] dip with-disposal ; inline
: digest-named ( name -- md )
dup EVP_get_digestbyname

4
basis/checksums/sha1/sha1.factor
View File

@ -41,9 +41,9 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
: sha1-f ( B C D t -- f_tbcd )
20 /i
{
{ 0 [ >r over bitnot r> bitand >r bitand r> bitor ] }
{ 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] }
{ 1 [ bitxor bitxor ] }
{ 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] }
{ 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] }
{ 3 [ bitxor bitxor ] }
} case ;

10
basis/checksums/sha2/sha2.factor
View File

@ -59,7 +59,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
[ 15 - swap nth s0-256 ] 2keep
[ 7 - swap nth ] 2keep
[ 2 - swap nth s1-256 ] 2keep
>r >r + + w+ r> r> swap set-nth ; inline
[ + + w+ ] 2dip swap set-nth ; inline
: prepare-message-schedule ( seq -- w-seq )
word-size get group [ be> ] map block-size get 0 pad-right
@ -71,7 +71,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
[ bitxor bitand ] keep bitxor ;
: maj ( x y z -- x' )
>r [ bitand ] 2keep bitor r> bitand bitor ;
[ [ bitand ] 2keep bitor ] dip bitand bitor ;
: S0-256 ( x -- x' )
[ -2 bitroll-32 ] keep
@ -83,7 +83,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
[ -11 bitroll-32 ] keep
-25 bitroll-32 bitxor bitxor ; inline
: slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ; inline
: slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
: T1 ( W n -- T1 )
[ swap nth ] keep
@ -105,7 +105,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
d c pick exchange
c b pick exchange
b a pick exchange
>r w+ a r> set-nth ;
[ w+ a ] dip set-nth ;
: process-chunk ( M -- )
H get clone vars set
@ -118,7 +118,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
: preprocess-plaintext ( string big-endian? -- padded-string )
#! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
>r >sbuf r> over [
[ >sbuf ] dip over [
HEX: 80 ,
dup length HEX: 3f bitand
calculate-pad-length 0 <string> %

9
basis/cocoa/application/application.factor
View File

@ -40,12 +40,13 @@ FUNCTION: void NSBeep ( ) ;
dup next-event [ -> sendEvent: t ] [ drop f ] if* ;
: add-observer ( observer selector name object -- )
>r >r >r >r NSNotificationCenter -> defaultCenter
r> r> sel_registerName
r> r> -> addObserver:selector:name:object: ;
[
[ NSNotificationCenter -> defaultCenter ] 2dip
sel_registerName
] 2dip -> addObserver:selector:name:object: ;
: remove-observer ( observer -- )
>r NSNotificationCenter -> defaultCenter r>
[ NSNotificationCenter -> defaultCenter ] dip
-> removeObserver: ;
: finish-launching ( -- ) NSApp -> finishLaunching ;

6
basis/cocoa/dialogs/dialogs.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2007 Slava Pestov
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cocoa cocoa.messages cocoa.classes
cocoa.application sequences splitting core-foundation ;
@ -29,6 +29,6 @@ IN: cocoa.dialogs
"/" split1-last [ <NSString> ] bi@ ;
: save-panel ( path -- paths )
<NSSavePanel> dup
rot split-path -> runModalForDirectory:file: NSOKButton =
[ <NSSavePanel> dup ] dip
split-path -> runModalForDirectory:file: NSOKButton =
[ -> filename CF>string ] [ drop f ] if ;

30
basis/cocoa/messages/messages.factor
View File

@ -5,7 +5,7 @@ combinators compiler compiler.alien kernel math namespaces make
parser prettyprint prettyprint.sections quotations sequences
strings words cocoa.runtime io macros memoize debugger
io.encodings.ascii effects libc libc.private parser lexer init
core-foundation fry ;
core-foundation fry generalizations ;
IN: cocoa.messages
: make-sender ( method function -- quot )
@ -27,7 +27,7 @@ super-message-senders global [ H{ } assoc-like ] change-at
: cache-stub ( method function hash -- )
[
over get [ 2drop ] [ over >r sender-stub r> set ] if
over get [ 2drop ] [ over [ sender-stub ] dip set ] if
] bind ;
: cache-stubs ( method -- )
@ -37,7 +37,7 @@ super-message-senders global [ H{ } assoc-like ] change-at
: <super> ( receiver -- super )
"objc-super" <c-object> [
>r dup object_getClass class_getSuperclass r>
[ dup object_getClass class_getSuperclass ] dip
set-objc-super-class
] keep
[ set-objc-super-receiver ] keep ;
@ -62,23 +62,18 @@ objc-methods global [ H{ } assoc-like ] change-at
dup objc-methods get at
[ ] [ "No such method: " prepend throw ] ?if ;
: make-dip ( quot n -- quot' )
dup
\ >r <repetition> >quotation -rot
\ r> <repetition> >quotation 3append ;
MEMO: make-prepare-send ( selector method super? -- quot )
[
[ \ <super> , ] when
swap <selector> , \ selector ,
] [ ] make
swap second length 2 - make-dip ;
swap second length 2 - '[ _ _ ndip ] ;
MACRO: (send) ( selector super? -- quot )
>r dup lookup-method r>
[ dup lookup-method ] dip
[ make-prepare-send ] 2keep
super-message-senders message-senders ? get at
[ slip execute ] 2curry ;
'[ _ call _ execute ] ;
: send ( receiver args... selector -- return... ) f (send) ; inline
@ -165,14 +160,14 @@ objc>alien-types get [ swap ] assoc-map
assoc-union alien>objc-types set-global
: objc-struct-type ( i string -- ctype )
2dup CHAR: = -rot index-from swap subseq
[ CHAR: = ] 2keep index-from swap subseq
dup c-types get key? [
"Warning: no such C type: " write dup print
drop "void*"
] unless ;
: (parse-objc-type) ( i string -- ctype )
2dup nth >r >r 1+ r> r> {
[ [ 1+ ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
@ -223,22 +218,23 @@ assoc-union alien>objc-types set-global
: class-exists? ( string -- class ) objc_getClass >boolean ;
: unless-defined ( class quot -- )
>r class-exists? r> unless ; inline
[ class-exists? ] dip unless ; inline
: define-objc-class-word ( name quot -- )
[
over , , \ unless-defined , dup , \ objc-class ,
] [ ] make >r "cocoa.classes" create r>
] [ ] make [ "cocoa.classes" create ] dip
(( -- class )) define-declared ;
: import-objc-class ( name quot -- )
2dup unless-defined
dupd define-objc-class-word
[
'[
_
dup
objc-class register-objc-methods
objc-meta-class register-objc-methods
] curry try ;
] try ;
: root-class ( class -- root )
dup class_getSuperclass [ root-class ] [ ] ?if ;

2
basis/cocoa/pasteboard/pasteboard.factor
View File

@ -20,7 +20,7 @@ IN: cocoa.pasteboard
: set-pasteboard-string ( str pasteboard -- )
NSStringPboardType <NSString>
dup 1array pick set-pasteboard-types
>r swap <NSString> r> -> setString:forType: drop ;
[ swap <NSString> ] dip -> setString:forType: drop ;
: pasteboard-error ( error -- f )
"Pasteboard does not hold a string" <NSString>

2
basis/cocoa/subclassing/subclassing.factor
View File

@ -36,7 +36,7 @@ IN: cocoa.subclassing
] map concat ;
: prepare-method ( ret types quot -- type imp )
>r [ encode-types ] 2keep r> [
[ [ encode-types ] 2keep ] dip [
"cdecl" swap 4array % \ alien-callback ,
] [ ] make define-temp ;

11
basis/cocoa/views/views.factor
View File

@ -74,7 +74,7 @@ PRIVATE>
-> autorelease ;
: <GLView> ( class dim -- view )
>r -> alloc 0 0 r> first2 <NSRect> <PixelFormat>
[ -> alloc 0 0 ] dip first2 <NSRect> <PixelFormat>
-> initWithFrame:pixelFormat:
dup 1 -> setPostsBoundsChangedNotifications:
dup 1 -> setPostsFrameChangedNotifications: ;
@ -85,10 +85,11 @@ PRIVATE>
swap NSRect-h >fixnum 2array ;
: mouse-location ( view event -- loc )
over >r
-> locationInWindow f -> convertPoint:fromView:
dup NSPoint-x swap NSPoint-y
r> -> frame NSRect-h swap - 2array ;
[
-> locationInWindow f -> convertPoint:fromView:
[ NSPoint-x ] [ NSPoint-y ] bi
] [ drop -> frame NSRect-h ] 2bi
swap - 2array ;
USE: opengl.gl
USE: alien.syntax

3
basis/cocoa/windows/windows.factor
View File

@ -34,5 +34,6 @@ IN: cocoa.windows
dup 0 -> setReleasedWhenClosed: ;
: window-content-rect ( window -- rect )
NSWindow over -> frame rot -> styleMask
[ NSWindow ] dip
[ -> frame ] [ -> styleMask ] bi
-> contentRectForFrameRect:styleMask: ;

49
basis/command-line/command-line-docs.factor
View File

@ -1,4 +1,5 @@
USING: help.markup help.syntax parser vocabs.loader strings ;
USING: help.markup help.syntax parser vocabs.loader strings
command-line.private ;
IN: command-line
HELP: run-bootstrap-init
@ -7,7 +8,10 @@ HELP: run-bootstrap-init
HELP: run-user-init
{ $description "Runs the startup initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-rc" } " on Unix and " { $snippet "factor-rc" } " on Windows." } ;
HELP: cli-param
HELP: load-vocab-roots
{ $description "Loads the newline-separated list of additional vocabulary roots from the file named " { $snippet ".factor-roots" } " on Unix and " { $snippet "factor-roots" } " on Windows." } ;
HELP: param
{ $values { "param" string } }
{ $description "Process a command-line switch."
$nl
@ -17,10 +21,13 @@ $nl
$nl
"Otherwise, sets the global variable named by the parameter to " { $link t } "." } ;
HELP: cli-args
HELP: (command-line)
{ $values { "args" "a sequence of strings" } }
{ $description "Outputs the command line parameters which were passed to the Factor VM on startup." } ;
HELP: command-line
{ $var-description "The command line parameters which follow the name of the script on the command line." } ;
HELP: main-vocab-hook
{ $var-description "Global variable holding a quotation which outputs a vocabulary name. UI backends set this so that the UI can automatically start if the prerequisites are met (for example, " { $snippet "$DISPLAY" } " being set on X11)." } ;
@ -35,9 +42,6 @@ HELP: ignore-cli-args?
{ $values { "?" "a boolean" } }
{ $description "On Mac OS X, source files to run are supplied by the Cocoa API, so to avoid running them twice the startup code has to call this word." } ;
HELP: parse-command-line
{ $description "Called on startup to process command line arguments. This sets global variables with " { $link cli-param } ", runs source files, and evaluates the string given by the " { $snippet "-e" } " switch, if there is one." } ;
ARTICLE: "runtime-cli-args" "Command line switches for the VM"
"A handful of command line switches are processed by the VM and not the library. They control low-level features."
{ $table
@ -64,9 +68,12 @@ ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
}
"Bootstrap can load various optional components:"
{ $table
{ { $snippet "math" } "Rational and complex number support." }
{ { $snippet "threads" } "Thread support." }
{ { $snippet "compiler" } "The compiler." }
{ { $snippet "tools" } "Terminal-based developer tools." }
{ { $snippet "help" } "The help system." }
{ { $snippet "help.handbook" } "The help handbook." }
{ { $snippet "ui" } "The graphical user interface." }
{ { $snippet "ui.tools" } "Graphical developer tools." }
{ { $snippet "io" } "Non-blocking I/O and networking." }
@ -86,7 +93,6 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage"
{ { $snippet "-run=" { $emphasis "vocab" } } { { $snippet { $emphasis "vocab" } } " is the name of a vocabulary with a " { $link POSTPONE: MAIN: } " hook to run on startup, for example " { $vocab-link "listener" } ", " { $vocab-link "ui" } " or " { $vocab-link "none" } "." } }
{ { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } }
{ { $snippet "-quiet" } { "If set, " { $link run-file } " and " { $link require } " will not print load messages." } }
{ { $snippet "-script" } { "Equivalent to " { $snippet "-quiet -run=none" } "." $nl "On Unix systems, Factor can be used for scripting - just create an executable text file whose first line is:" { $code "#! /usr/local/bin/factor -script" } "The space after " { $snippet "#!" } " is necessary because of Factor syntax." } }
} ;
ARTICLE: "factor-boot-rc" "Bootstrap initialization file"
@ -102,11 +108,18 @@ $nl
"A word to run this file from an existing Factor session:"
{ $subsection run-user-init } ;
ARTICLE: "factor-roots" "Additional vocabulary roots file"
"The vocabulary roots file is named " { $snippet "factor-roots" } " on Windows and " { $snippet ".factor-roots" } " on Unix. If it exists, it is loaded every time Factor starts. It contains a newline-separated list of " { $link "vocabs.roots" } "."
$nl
"A word to run this file from an existing Factor session:"
{ $subsection load-vocab-roots } ;
ARTICLE: "rc-files" "Running code on startup"
"Factor looks for two files in your home directory."
"Factor looks for three optional files in your home directory."
{ $subsection "factor-boot-rc" }
{ $subsection "factor-rc" }
"The " { $snippet "-no-user-init" } " command line switch will inhibit the running of these files."
{ $subsection "factor-roots" }
"The " { $snippet "-no-user-init" } " command line switch will inhibit loading running of these files."
$nl
"If you are unsure where the files should be located, evaluate the following code:"
{ $code
@ -122,8 +135,16 @@ $nl
"100 dpi set-global"
} ;
ARTICLE: "cli" "Command line usage"
"Zero or more command line arguments may be passed to the Factor runtime. Command line arguments starting with a dash (" { $snippet "-" } ") is interpreted as switches. All other arguments are taken to be file names to be run by " { $link run-file } "."
ARTICLE: "cli" "Command line arguments"
"Factor command line usage:"
{ $code "factor [system switches...] [script args...]" }
"Zero or more system switches can be passed in, followed by an optional script file name. If the script file is specified, it will be run on startup, any arguments after the script file are stored in a variable, with no further processing by Factor itself:"
{ $subsection command-line }
"Instead of running a script, it is also possible to run a vocabulary; this invokes the vocabulary's " { $link POSTPONE: MAIN: } " word:"
{ $code "factor [system switches...] -run=<vocab name>" }
"If no script file or " { $snippet "-run=" } " switch is specified, Factor will start " { $link "listener" } " or " { $link "ui-tools" } ", depending on the operating system."
$nl
"As stated above, arguments in the first part of the command line, before the optional script name, are interpreted by to the Factor system. These arguments all start with a dash (" { $snippet "-" } ")."
$nl
"Switches can take one of the following three forms:"
{ $list
@ -134,9 +155,9 @@ $nl
{ $subsection "runtime-cli-args" }
{ $subsection "bootstrap-cli-args" }
{ $subsection "standard-cli-args" }
"The list of command line arguments can be obtained and inspected directly:"
{ $subsection cli-args }
"There is a way to override the default vocabulary to run on startup:"
"The raw list of command line arguments can also be obtained and inspected directly:"
{ $subsection (command-line) }
"There is a way to override the default vocabulary to run on startup, if no script name or " { $snippet "-run" } " switch is specified:"
{ $subsection main-vocab-hook } ;
ABOUT: "cli"

12
basis/command-line/command-line-tests.factor
View File

@ -1,12 +0,0 @@
USING: namespaces tools.test kernel command-line ;
IN: command-line.tests
[
[ f ] [ "-no-user-init" cli-arg ] unit-test
[ f ] [ "user-init" get ] unit-test
[ f ] [ "-user-init" cli-arg ] unit-test
[ t ] [ "user-init" get ] unit-test
[ "sdl.factor" ] [ "sdl.factor" cli-arg ] unit-test
] with-scope

60
basis/command-line/command-line.factor
View File

@ -1,10 +1,15 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init continuations debugger hashtables io kernel
kernel.private namespaces parser sequences strings system
splitting io.files eval ;
USING: init continuations debugger hashtables io
io.encodings.utf8 io.files kernel kernel.private namespaces
parser sequences strings system splitting eval vocabs.loader ;
IN: command-line
SYMBOL: script
SYMBOL: command-line
: (command-line) ( -- args ) 10 getenv sift ;
: rc-path ( name -- path )
os windows? [ "." prepend ] unless
home prepend-path ;
@ -19,17 +24,33 @@ IN: command-line
"factor-rc" rc-path ?run-file
] when ;
: cli-var-param ( name value -- ) swap set-global ;
: load-vocab-roots ( -- )
"user-init" get [
"factor-roots" rc-path dup exists? [
utf8 file-lines [ add-vocab-root ] each
] [ drop ] if
] when ;
: cli-bool-param ( name -- ) "no-" ?head not cli-var-param ;
<PRIVATE
: cli-param ( param -- )
"=" split1 [ cli-var-param ] [ cli-bool-param ] if* ;
: var-param ( name value -- ) swap set-global ;
: cli-arg ( argument -- argument )
"-" ?head [ cli-param f ] when ;
: bool-param ( name -- ) "no-" ?head not var-param ;
: cli-args ( -- args ) 10 getenv ;
: param ( param -- )
"=" split1 [ var-param ] [ bool-param ] if* ;
: run-script ( file -- )
t "quiet" set-global run-file ;
PRIVATE>
: parse-command-line ( args -- )
[ command-line off script off ] [
unclip "-" ?head
[ param parse-command-line ]
[ script set command-line set ] if
] if-empty ;
SYMBOL: main-vocab-hook
@ -53,14 +74,17 @@ SYMBOL: main-vocab-hook
: ignore-cli-args? ( -- ? )
os macosx? "run" get "ui" = and ;
: script-mode ( -- )
t "quiet" set-global
"none" "run" set-global ;
: script-mode ( -- ) ;
: parse-command-line ( -- )
cli-args [ cli-arg ] filter
"script" get [ script-mode ] when
ignore-cli-args? [ drop ] [ [ run-file ] each ] if
"e" get [ eval ] when* ;
: handle-command-line ( -- )
[
(command-line) parse-command-line
load-vocab-roots
run-user-init
"e" get [ eval ] when*
ignore-cli-args? not script get and
[ run-script ] [ "run" get run ] if*
output-stream get [ stream-flush ] when*
] [ print-error 1 exit ] recover ;
[ default-cli-args ] "command-line" add-init-hook

2
basis/compiler/alien/alien.factor
View File

@ -18,7 +18,7 @@ IN: compiler.alien
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
: parameter-align ( n type -- n delta )
over >r c-type-stack-align align dup r> - ;
[ c-type-stack-align align dup ] [ drop ] 2bi - ;
: parameter-sizes ( types -- total offsets )
#! Compute stack frame locations.

2
basis/compiler/cfg/def-use/def-use.factor
View File

@ -18,6 +18,8 @@ M: ##string-nth defs-vregs dst/tmp-vregs ;
M: ##compare defs-vregs dst/tmp-vregs ;
M: ##compare-imm defs-vregs dst/tmp-vregs ;
M: ##compare-float defs-vregs dst/tmp-vregs ;
M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: insn defs-vregs drop f ;
M: ##unary uses-vregs src>> 1array ;

4
basis/compiler/cfg/instructions/instructions.factor
View File

@ -98,8 +98,8 @@ INSN: ##fixnum-add < ##fixnum-overflow ;
INSN: ##fixnum-add-tail < ##fixnum-overflow ;
INSN: ##fixnum-sub < ##fixnum-overflow ;
INSN: ##fixnum-sub-tail < ##fixnum-overflow ;
INSN: ##fixnum-mul < ##fixnum-overflow ;
INSN: ##fixnum-mul-tail < ##fixnum-overflow ;
INSN: ##fixnum-mul < ##fixnum-overflow temp1 temp2 ;
INSN: ##fixnum-mul-tail < ##fixnum-overflow temp1 temp2 ;
: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline

6
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -26,6 +26,7 @@ IN: compiler.cfg.intrinsics
math.private:both-fixnums?
math.private:fixnum+
math.private:fixnum-
math.private:fixnum*
math.private:fixnum+fast
math.private:fixnum-fast
math.private:fixnum-bitand
@ -89,16 +90,13 @@ IN: compiler.cfg.intrinsics
alien.accessors:set-alien-double
} [ t "intrinsic" set-word-prop ] each ;
: enable-fixnum*-intrinsic ( -- )
\ math.private:fixnum* t "intrinsic" set-word-prop ;
: emit-intrinsic ( node word -- node/f )
{
{ \ kernel.private:tag [ drop emit-tag iterate-next ] }
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
{ \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum* [ drop [ ##fixnum-mul ] [ ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] }

23
basis/compiler/codegen/codegen.factor
View File

@ -159,12 +159,15 @@ M: ##not generate-insn dst/src %not ;
: src1/src2 ( insn -- src1 src2 )
[ src1>> register ] [ src2>> register ] bi ; inline
: src1/src2/temp1/temp2 ( insn -- src1 src2 temp1 temp2 )
[ src1/src2 ] [ temp1>> register ] [ temp2>> register ] tri ; inline
M: ##fixnum-add generate-insn src1/src2 %fixnum-add ;
M: ##fixnum-add-tail generate-insn src1/src2 %fixnum-add-tail ;
M: ##fixnum-sub generate-insn src1/src2 %fixnum-sub ;
M: ##fixnum-sub-tail generate-insn src1/src2 %fixnum-sub-tail ;
M: ##fixnum-mul generate-insn src1/src2 %fixnum-mul ;
M: ##fixnum-mul-tail generate-insn src1/src2 %fixnum-mul-tail ;
M: ##fixnum-mul generate-insn src1/src2/temp1/temp2 %fixnum-mul ;
M: ##fixnum-mul-tail generate-insn src1/src2/temp1/temp2 %fixnum-mul-tail ;
: dst/src/temp ( insn -- dst src temp )
[ dst/src ] [ temp>> register ] bi ; inline
@ -274,7 +277,7 @@ M: object reg-class-full?
: spill-param ( reg-class -- n reg-class )
stack-params get
>r reg-size cell align stack-params +@ r>
[ reg-size cell align stack-params +@ ] dip
stack-params ;
: fastcall-param ( reg-class -- n reg-class )
@ -310,10 +313,10 @@ M: long-long-type flatten-value-type ( type -- types )
] { } make ;
: each-parameter ( parameters quot -- )
>r [ parameter-sizes nip ] keep r> 2each ; inline
[ [ parameter-sizes nip ] keep ] dip 2each ; inline
: reverse-each-parameter ( parameters quot -- )
>r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
[ [ parameter-sizes nip ] keep ] dip 2reverse-each ; inline
: reset-freg-counts ( -- )
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
@ -326,15 +329,13 @@ M: long-long-type flatten-value-type ( type -- types )
#! Moves values from C stack to registers (if word is
#! %load-param-reg) and registers to C stack (if word is
#! %save-param-reg).
>r
alien-parameters
flatten-value-types
r> '[ alloc-parameter _ execute ] each-parameter ;
inline
[ alien-parameters flatten-value-types ]
[ '[ alloc-parameter _ execute ] ]
bi* each-parameter ; inline
: unbox-parameters ( offset node -- )
parameters>> [
%prepare-unbox >r over + r> unbox-parameter
%prepare-unbox [ over + ] dip unbox-parameter
] reverse-each-parameter drop ;
: prepare-box-struct ( node -- offset )

15
basis/compiler/codegen/fixup/fixup.factor
View File

@ -46,28 +46,27 @@ M: integer fixup* , ;
: indq ( elt seq -- n ) [ eq? ] with find drop ;
: adjoin* ( obj table -- n )
2dup indq [ 2nip ] [ dup length >r push r> ] if* ;
2dup indq [ 2nip ] [ dup length [ push ] dip ] if* ;
SYMBOL: literal-table
: add-literal ( obj -- n ) literal-table get adjoin* ;
: add-dlsym-literals ( symbol dll -- )
>r string>symbol r> 2array literal-table get push-all ;
[ string>symbol ] dip 2array literal-table get push-all ;
: rel-dlsym ( name dll class -- )
>r literal-table get length >r
add-dlsym-literals
r> r> rt-dlsym rel-fixup ;
[ literal-table get length [ add-dlsym-literals ] dip ] dip
rt-dlsym rel-fixup ;
: rel-word ( word class -- )
>r add-literal r> rt-xt rel-fixup ;
[ add-literal ] dip rt-xt rel-fixup ;
: rel-primitive ( word class -- )
>r def>> first r> rt-primitive rel-fixup ;
[ def>> first ] dip rt-primitive rel-fixup ;
: rel-immediate ( literal class -- )
>r add-literal r> rt-immediate rel-fixup ;
[ add-literal ] dip rt-immediate rel-fixup ;
: rel-this ( class -- )
0 swap rt-label rel-fixup ;

1
basis/compiler/tests/intrinsics.factor
View File

@ -213,6 +213,7 @@ IN: compiler.tests
[ -1 ] [ [ -123 -64 fixnum-shift ] compile-call ] unit-test
[ -1 ] [ -123 -64 [ fixnum-shift ] compile-call ] unit-test
[ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test
[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test

17
basis/concurrency/conditions/conditions.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: deques threads kernel arrays sequences alarms ;
USING: deques threads kernel arrays sequences alarms fry ;
IN: concurrency.conditions
: notify-1 ( deque -- )
@ -12,15 +12,18 @@ IN: concurrency.conditions
: queue-timeout ( queue timeout -- alarm )
#! Add an alarm which removes the current thread from the
#! queue, and resumes it, passing it a value of t.
>r [ self swap push-front* ] keep [
[ delete-node ] [ drop node-value ] 2bi
t swap resume-with
] 2curry r> later ;
[
[ self swap push-front* ] keep '[
_ _
[ delete-node ] [ drop node-value ] 2bi
t swap resume-with
]
] dip later ;
: wait ( queue timeout status -- )
over [
>r queue-timeout [ drop ] r> suspend
[ queue-timeout [ drop ] ] dip suspend
[ "Timeout" throw ] [ cancel-alarm ] if
] [
>r drop [ push-front ] curry r> suspend drop
[ drop '[ _ push-front ] ] dip suspend drop
] if ;

6
basis/concurrency/count-downs/count-downs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: dlists kernel math concurrency.promises
concurrency.mailboxes debugger accessors ;
concurrency.mailboxes debugger accessors fry ;
IN: concurrency.count-downs
! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html
@ -26,12 +26,12 @@ ERROR: count-down-already-done ;
[ 1- >>n count-down-check ] if ;
: await-timeout ( count-down timeout -- )
>r promise>> r> ?promise-timeout ?linked t assert= ;
[ promise>> ] dip ?promise-timeout ?linked t assert= ;
: await ( count-down -- )
f await-timeout ;
: spawn-stage ( quot count-down -- )
[ [ count-down ] curry compose ] keep
[ '[ @ _ count-down ] ] keep
"Count down stage"
swap promise>> mailbox>> spawn-linked-to drop ;

2
basis/concurrency/distributed/distributed-tests.factor
View File

@ -15,7 +15,7 @@ concurrency.messaging continuations accessors prettyprint ;
[ ] [
[
receive first2 >r 3 + r> send
receive first2 [ 3 + ] dip send
"thread-a" unregister-process
] "Thread A" spawn
"thread-a" swap register-process

6
basis/concurrency/exchangers/exchangers.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel threads boxes accessors ;
USING: kernel threads boxes accessors fry ;
IN: concurrency.exchangers
! Motivated by
@ -14,8 +14,8 @@ TUPLE: exchanger thread object ;
: exchange ( obj exchanger -- newobj )
dup thread>> occupied>> [
dup object>> box>
>r thread>> box> resume-with r>
[ thread>> box> resume-with ] dip
] [
[ object>> >box ] keep
[ thread>> >box ] curry "exchange" suspend
'[ _ thread>> >box ] "exchange" suspend
] if ;

8
basis/concurrency/flags/flags-tests.factor
View File

@ -2,7 +2,7 @@ IN: concurrency.flags.tests
USING: tools.test concurrency.flags concurrency.combinators
kernel threads locals accessors calendar ;
:: flag-test-1 ( -- )
:: flag-test-1 ( -- val )
[let | f [ <flag> ] |
[ f raise-flag ] "Flag test" spawn drop
f lower-flag
@ -20,7 +20,7 @@ kernel threads locals accessors calendar ;
[ f ] [ flag-test-2 ] unit-test
:: flag-test-3 ( -- )
:: flag-test-3 ( -- val )
[let | f [ <flag> ] |
f raise-flag
f value>>
@ -28,7 +28,7 @@ kernel threads locals accessors calendar ;
[ t ] [ flag-test-3 ] unit-test
:: flag-test-4 ( -- )
:: flag-test-4 ( -- val )
[let | f [ <flag> ] |
[ f raise-flag ] "Flag test" spawn drop
f wait-for-flag
@ -37,7 +37,7 @@ kernel threads locals accessors calendar ;
[ t ] [ flag-test-4 ] unit-test
:: flag-test-5 ( -- )
:: flag-test-5 ( -- val )
[let | f [ <flag> ] |
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f wait-for-flag

2
basis/concurrency/flags/flags.factor
View File

@ -11,7 +11,7 @@ TUPLE: flag value threads ;
dup value>> [ drop ] [ t >>value threads>> notify-all ] if ;
: wait-for-flag-timeout ( flag timeout -- )
over value>> [ 2drop ] [ >r threads>> r> "flag" wait ] if ;
over value>> [ 2drop ] [ [ threads>> ] dip "flag" wait ] if ;
: wait-for-flag ( flag -- )
f wait-for-flag-timeout ;

4
basis/concurrency/futures/futures.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises concurrency.mailboxes kernel arrays
continuations accessors ;
continuations accessors fry ;
IN: concurrency.futures
: future ( quot -- future )
<promise> [
[ [ >r call r> fulfill ] 2curry "Future" ] keep
[ '[ @ _ fulfill ] "Future" ] keep
mailbox>> spawn-linked-to drop
] keep ; inline

23
basis/concurrency/locks/locks-tests.factor
View File

@ -3,7 +3,7 @@ USING: tools.test concurrency.locks concurrency.count-downs
concurrency.messaging concurrency.mailboxes locals kernel
threads sequences calendar accessors ;
:: lock-test-0 ( -- )
:: lock-test-0 ( -- v )
[let | v [ V{ } clone ]
c [ 2 <count-down> ] |
@ -27,7 +27,7 @@ threads sequences calendar accessors ;
v
] ;
:: lock-test-1 ( -- )
:: lock-test-1 ( -- v )
[let | v [ V{ } clone ]
l [ <lock> ]
c [ 2 <count-down> ] |
@ -79,7 +79,7 @@ threads sequences calendar accessors ;
[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
:: rw-lock-test-1 ( -- )
:: rw-lock-test-1 ( -- v )
[let | l [ <rw-lock> ]
c [ 1 <count-down> ]
c' [ 1 <count-down> ]
@ -129,7 +129,7 @@ threads sequences calendar accessors ;
[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test
:: rw-lock-test-2 ( -- )
:: rw-lock-test-2 ( -- v )
[let | l [ <rw-lock> ]
c [ 1 <count-down> ]
c' [ 2 <count-down> ]
@ -160,7 +160,7 @@ threads sequences calendar accessors ;
[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
! Test lock timeouts
:: lock-timeout-test ( -- )
:: lock-timeout-test ( -- v )
[let | l [ <lock> ] |
[
l [ 1 seconds sleep ] with-lock
@ -177,19 +177,6 @@ threads sequences calendar accessors ;
thread>> name>> "Lock timeout-er" =
] must-fail-with
:: read/write-test ( -- )
[let | l [ <lock> ] |
[
l [ 1 seconds sleep ] with-lock
] "Lock holder" spawn drop
[
l 1/10 seconds [ ] with-lock-timeout
] "Lock timeout-er" spawn-linked drop
receive
] ;
[
<rw-lock> dup [
1 seconds [ ] with-write-lock-timeout

15
basis/concurrency/locks/locks.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: deques dlists kernel threads continuations math
concurrency.conditions combinators.short-circuit accessors ;
concurrency.conditions combinators.short-circuit accessors
locals ;
IN: concurrency.locks
! Simple critical sections
@ -17,16 +18,16 @@ TUPLE: lock threads owner reentrant? ;
: acquire-lock ( lock timeout -- )
over owner>>
[ 2dup >r threads>> r> "lock" wait ] when drop
[ 2dup [ threads>> ] dip "lock" wait ] when drop
self >>owner drop ;
: release-lock ( lock -- )
f >>owner
threads>> notify-1 ;
: do-lock ( lock timeout quot acquire release -- )
>r >r pick rot r> call ! use up timeout acquire
swap r> curry [ ] cleanup ; inline
:: do-lock ( lock timeout quot acquire release -- )
lock timeout acquire call
quot lock release curry [ ] cleanup ; inline
: (with-lock) ( lock timeout quot -- )
[ acquire-lock ] [ release-lock ] do-lock ; inline
@ -60,7 +61,7 @@ TUPLE: rw-lock readers writers reader# writer ;
: acquire-read-lock ( lock timeout -- )
over writer>>
[ 2dup >r readers>> r> "read lock" wait ] when drop
[ 2dup [ readers>> ] dip "read lock" wait ] when drop
add-reader ;
: notify-writer ( lock -- )
@ -75,7 +76,7 @@ TUPLE: rw-lock readers writers reader# writer ;
: acquire-write-lock ( lock timeout -- )
over writer>> pick reader#>> 0 > or
[ 2dup >r writers>> r> "write lock" wait ] when drop
[ 2dup [ writers>> ] dip "write lock" wait ] when drop
self >>writer drop ;
: release-write-lock ( lock -- )

10
basis/concurrency/mailboxes/mailboxes.factor
View File

@ -4,7 +4,7 @@ IN: concurrency.mailboxes
USING: dlists deques threads sequences continuations
destructors namespaces math quotations words kernel
arrays assocs init system concurrency.conditions accessors
debugger debugger.threads locals ;
debugger debugger.threads locals fry ;
TUPLE: mailbox threads data disposed ;
@ -21,7 +21,7 @@ M: mailbox dispose* threads>> notify-all ;
[ threads>> notify-all ] bi yield ;
: wait-for-mailbox ( mailbox timeout -- )
>r threads>> r> "mailbox" wait ;
[ threads>> ] dip "mailbox" wait ;
:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
mailbox check-disposed
@ -57,11 +57,11 @@ M: mailbox dispose* threads>> notify-all ;
f mailbox-get-all-timeout ;
: while-mailbox-empty ( mailbox quot -- )
[ [ mailbox-empty? ] curry ] dip [ ] while ; inline
[ '[ _ mailbox-empty? ] ] dip [ ] while ; inline
: mailbox-get-timeout? ( mailbox timeout pred -- obj )
[ block-unless-pred ]
[ nip >r data>> r> delete-node-if ]
[ [ drop data>> ] dip delete-node-if ]
3bi ; inline
: mailbox-get? ( mailbox pred -- obj )
@ -90,7 +90,7 @@ M: linked-thread error-in-thread
[ <linked-error> ] [ supervisor>> ] bi mailbox-put ;
: <linked-thread> ( quot name mailbox -- thread' )
>r linked-thread new-thread r> >>supervisor ;
[ linked-thread new-thread ] dip >>supervisor ;
: spawn-linked-to ( quot name mailbox -- thread )
<linked-thread> [ (spawn) ] keep ;

2
basis/concurrency/messaging/messaging-docs.factor
View File

@ -55,7 +55,7 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
{ $example
"USING: concurrency.messaging kernel threads ;"
": pong-server ( -- )"
" receive >r \"pong\" r> reply-synchronous ;"
" receive [ \"pong\" ] dip reply-synchronous ;"
"[ pong-server t ] \"pong-server\" spawn-server"
"\"ping\" swap send-synchronous ."
"\"pong\""

15
basis/concurrency/messaging/messaging.factor
View File

@ -1,10 +1,7 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
!
! Concurrency library for Factor, based on Erlang/Termite style
! concurrency.
USING: kernel threads concurrency.mailboxes continuations
namespaces assocs accessors summary ;
namespaces assocs accessors summary fry ;
IN: concurrency.messaging
GENERIC: send ( message thread -- )
@ -32,7 +29,7 @@ M: thread send ( message thread -- )
my-mailbox -rot mailbox-get-timeout? ?linked ; inline
: rethrow-linked ( error process supervisor -- )
>r <linked-error> r> send ;
[ <linked-error> ] dip send ;
: spawn-linked ( quot name -- thread )
my-mailbox spawn-linked-to ;
@ -48,9 +45,7 @@ TUPLE: reply data tag ;
tag>> \ reply boa ;
: synchronous-reply? ( response synchronous -- ? )
over reply?
[ >r tag>> r> tag>> = ]
[ 2drop f ] if ;
over reply? [ [ tag>> ] bi@ = ] [ 2drop f ] if ;
ERROR: cannot-send-synchronous-to-self message thread ;
@ -61,8 +56,8 @@ M: cannot-send-synchronous-to-self summary
dup self eq? [
cannot-send-synchronous-to-self
] [
>r <synchronous> dup r> send
[ synchronous-reply? ] curry receive-if
[ <synchronous> dup ] dip send
'[ _ synchronous-reply? ] receive-if
data>>
] if ;

2
basis/concurrency/promises/promises.factor
View File

@ -20,7 +20,7 @@ ERROR: promise-already-fulfilled promise ;
] if ;
: ?promise-timeout ( promise timeout -- result )
>r mailbox>> r> block-if-empty mailbox-peek ;
[ mailbox>> ] dip block-if-empty mailbox-peek ;
: ?promise ( promise -- result )
f ?promise-timeout ;

10
basis/concurrency/semaphores/semaphores.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: dlists kernel threads math concurrency.conditions
continuations accessors summary ;
continuations accessors summary locals fry ;
IN: concurrency.semaphores
TUPLE: semaphore count threads ;
@ -30,9 +30,9 @@ M: negative-count-semaphore summary
[ 1+ ] change-count
threads>> notify-1 ;
: with-semaphore-timeout ( semaphore timeout quot -- )
pick rot acquire-timeout swap
[ release ] curry [ ] cleanup ; inline
:: with-semaphore-timeout ( semaphore timeout quot -- )
semaphore timeout acquire-timeout
quot [ semaphore release ] [ ] cleanup ; inline
: with-semaphore ( semaphore quot -- )
over acquire swap [ release ] curry [ ] cleanup ; inline
swap dup acquire '[ _ release ] [ ] cleanup ; inline

8
basis/core-foundation/core-foundation.factor
View File

@ -90,14 +90,14 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
: <CFArray> ( seq -- alien )
[ f swap length f CFArrayCreateMutable ] keep
[ length ] keep
[ >r dupd r> CFArraySetValueAtIndex ] 2each ;
[ [ dupd ] dip CFArraySetValueAtIndex ] 2each ;
: <CFString> ( string -- alien )
f swap dup length CFStringCreateWithCharacters ;
: CF>string ( alien -- string )
dup CFStringGetLength 1+ "ushort" <c-array> [
>r 0 over CFStringGetLength r> CFStringGetCharacters
[ 0 over CFStringGetLength ] dip CFStringGetCharacters
] keep utf16n alien>string ;
: CF>string-array ( alien -- seq )
@ -107,8 +107,8 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
[ <CFString> ] map dup <CFArray> swap [ CFRelease ] each ;
: <CFFileSystemURL> ( string dir? -- url )
>r <CFString> f over kCFURLPOSIXPathStyle
r> CFURLCreateWithFileSystemPath swap CFRelease ;
[ <CFString> f over kCFURLPOSIXPathStyle ] dip
CFURLCreateWithFileSystemPath swap CFRelease ;
: <CFURL> ( string -- url )
<CFString>

27
basis/core-foundation/fsevents/fsevents.factor
View File

@ -4,7 +4,7 @@ USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces make assocs init accessors
continuations combinators core-foundation
core-foundation.run-loop core-foundation.run-loop.thread
io.encodings.utf8 destructors ;
io.encodings.utf8 destructors locals arrays ;
IN: core-foundation.fsevents
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
@ -105,15 +105,14 @@ FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef
"FSEventStreamContext" <c-object>
[ set-FSEventStreamContext-info ] keep ;
: <FSEventStream> ( callback info paths latency flags -- event-stream )
>r >r >r >r >r
:: <FSEventStream> ( callback info paths latency flags -- event-stream )
f ! allocator
r> ! callback
r> make-FSEventStreamContext
r> <CFStringArray> ! paths
callback
info make-FSEventStreamContext
paths <CFStringArray>
FSEventStreamEventIdSinceNow ! sinceWhen
r> ! latency
r> ! flags
latency
flags
FSEventStreamCreate ;
: kCFRunLoopCommonModes ( -- string )
@ -161,13 +160,11 @@ SYMBOL: event-stream-callbacks
: remove-event-source-callback ( id -- )
event-stream-callbacks get delete-at ;
: >event-triple ( n eventPaths eventFlags eventIds -- triple )
[
>r >r >r dup dup
r> void*-nth utf8 alien>string ,
r> int-nth ,
r> longlong-nth ,
] { } make ;
:: >event-triple ( n eventPaths eventFlags eventIds -- triple )
n eventPaths void*-nth utf8 alien>string
n eventFlags int-nth
n eventIds longlong-nth
3array ;
: master-event-source-callback ( -- alien )
"void"

4
basis/cpu/architecture/architecture.factor
View File

@ -81,8 +81,8 @@ HOOK: %fixnum-add cpu ( src1 src2 -- )
HOOK: %fixnum-add-tail cpu ( src1 src2 -- )
HOOK: %fixnum-sub cpu ( src1 src2 -- )
HOOK: %fixnum-sub-tail cpu ( src1 src2 -- )
HOOK: %fixnum-mul cpu ( src1 src2 -- )
HOOK: %fixnum-mul-tail cpu ( src1 src2 -- )
HOOK: %fixnum-mul cpu ( src1 src2 temp1 temp2 -- )
HOOK: %fixnum-mul-tail cpu ( src1 src2 temp1 temp2 -- )
HOOK: %integer>bignum cpu ( dst src temp -- )
HOOK: %bignum>integer cpu ( dst src temp -- )

43
basis/cpu/ppc/ppc.factor
View File

@ -17,7 +17,6 @@ IN: cpu.ppc
! f30, f31: float scratch
enable-float-intrinsics
enable-fixnum*-intrinsic
<< \ ##integer>float t frame-required? set-word-prop
\ ##float>integer t frame-required? set-word-prop >>
@ -187,30 +186,32 @@ M: ppc %not NOT ;
[ 3 src1 MR 4 src2 MR ]
} cond ;
: clear-xer ( -- )
0 0 LI
0 MTXER ; inline
:: overflow-template ( src1 src2 insn func -- )
"no-overflow" define-label
0 0 LI
0 MTXER
clear-xer
scratch-reg src2 src1 insn call
scratch-reg ds-reg 0 STW
"no-overflow" get BNO
src2 src1 move>args
src1 src2 move>args
%prepare-alien-invoke
func f %alien-invoke
"no-overflow" resolve-label ; inline
:: overflow-template-tail ( src1 src2 insn func -- )
"overflow" define-label
0 0 LI
0 MTXER
clear-xer
scratch-reg src2 src1 insn call
"overflow" get BO
scratch-reg ds-reg 0 STW
BLR
"overflow" resolve-label
src2 src1 move>args
src1 src2 move>args
%prepare-alien-invoke
func f %alien-invoke-tail ;
func f %alien-invoke-tail ; inline
M: ppc %fixnum-add ( src1 src2 -- )
[ ADDO. ] "overflow_fixnum_add" overflow-template ;
@ -224,32 +225,30 @@ M: ppc %fixnum-sub ( src1 src2 -- )
M: ppc %fixnum-sub-tail ( src1 src2 -- )
[ SUBFO. ] "overflow_fixnum_subtract" overflow-template-tail ;
M:: ppc %fixnum-mul ( src1 src2 -- )
M:: ppc %fixnum-mul ( src1 src2 temp1 temp2 -- )
"no-overflow" define-label
0 0 LI
0 MTXER
scratch-reg src1 tag-bits get SRAWI
scratch-reg scratch-reg src2 MULLWO.
scratch-reg ds-reg 0 STW
clear-xer
temp1 src1 tag-bits get SRAWI
temp2 temp1 src2 MULLWO.
temp2 ds-reg 0 STW
"no-overflow" get BNO
src2 src2 tag-bits get SRAWI
scratch-reg src2 move>args
temp1 src2 move>args
%prepare-alien-invoke
"overflow_fixnum_multiply" f %alien-invoke
"no-overflow" resolve-label ;
M:: ppc %fixnum-mul-tail ( src1 src2 -- )
M:: ppc %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
"overflow" define-label
0 0 LI
0 MTXER
scratch-reg src1 tag-bits get SRAWI
scratch-reg scratch-reg src2 MULLWO.
clear-xer
temp1 src1 tag-bits get SRAWI
temp2 temp1 src2 MULLWO.
"overflow" get BO
scratch-reg ds-reg 0 STW
temp2 ds-reg 0 STW
BLR
"overflow" resolve-label
src2 src2 tag-bits get SRAWI
scratch-reg src2 move>args
temp1 src2 move>args
%prepare-alien-invoke
"overflow_fixnum_multiply" f %alien-invoke-tail ;

2
basis/cpu/x86/32/32.factor
View File

@ -307,7 +307,7 @@ FUNCTION: bool check_sse2 ( ) ;
: sse2? ( -- ? )
check_sse2 ;
"-no-sse2" cli-args member? [
"-no-sse2" (command-line) member? [
[ optimized-recompile-hook ] recompile-hook
[ { check_sse2 } compile ] with-variable

2
basis/cpu/x86/64/64.factor
View File

@ -21,8 +21,6 @@ M: x86.64 machine-registers
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
M: x86.64 temp-reg-1 R8 ;
M: x86.64 temp-reg-2 R9 ;
M:: x86.64 %dispatch ( src temp offset -- )
! Load jump table base.

4
basis/cpu/x86/64/unix/unix.factor
View File

@ -52,3 +52,7 @@ M: x86.64 dummy-stack-params? f ;
M: x86.64 dummy-int-params? f ;
M: x86.64 dummy-fp-params? f ;
M: x86.64 temp-reg-1 R8 ;
M: x86.64 temp-reg-2 R9 ;

4
basis/cpu/x86/64/winnt/winnt.factor
View File

@ -20,6 +20,10 @@ M: x86.64 dummy-int-params? t ;
M: x86.64 dummy-fp-params? t ;
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
<<
"longlong" "ptrdiff_t" typedef
"longlong" "intptr_t" typedef

2
basis/cpu/x86/assembler/assembler.factor
View File

@ -300,7 +300,7 @@ PREDICATE: callable < word register? not ;
GENERIC: MOV ( dst src -- )
M: immediate MOV swap (MOV-I) ;
M: callable MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ;
M: operand MOV HEX: 88 2-operand ;
: LEA ( dst src -- ) swap HEX: 8d 2-operand ;

29
basis/cpu/x86/x86.factor
View File

@ -145,6 +145,35 @@ M: x86 %fixnum-sub ( src1 src2 -- )
M: x86 %fixnum-sub-tail ( src1 src2 -- )
[ SUB ] [ ADD ] "overflow_fixnum_subtract" overflow-template-tail ;
M:: x86 %fixnum-mul ( src1 src2 temp1 temp2 -- )
"no-overflow" define-label
temp1 src1 MOV
temp1 tag-bits get SAR
src2 temp1 IMUL2
ds-reg [] temp1 MOV
"no-overflow" get JNO
src1 src2 move>args
param-reg-1 tag-bits get SAR
param-reg-2 tag-bits get SAR
%prepare-alien-invoke
"overflow_fixnum_multiply" f %alien-invoke
"no-overflow" resolve-label ;
M:: x86 %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
"overflow" define-label
temp1 src1 MOV
temp1 tag-bits get SAR
src2 temp1 IMUL2
"overflow" get JO
ds-reg [] temp1 MOV
0 RET
"overflow" resolve-label
src1 src2 move>args
param-reg-1 tag-bits get SAR
param-reg-2 tag-bits get SAR
%prepare-alien-invoke
"overflow_fixnum_multiply" f %alien-invoke-tail ;
: bignum@ ( reg n -- op )
cells bignum tag-number - [+] ; inline

2
basis/db/db.factor
View File

@ -48,7 +48,7 @@ GENERIC: more-rows? ( result-set -- ? )
: new-result-set ( query handle class -- result-set )
new
swap >>handle
>r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
[ [ sql>> ] [ in-params>> ] [ out-params>> ] tri ] dip
swap >>out-params
swap >>in-params
swap >>sql ;

6
basis/db/postgresql/lib/lib.factor
View File

@ -76,7 +76,7 @@ M: postgresql-result-null summary ( obj -- str )
: param-values ( statement -- seq seq2 )
[ bind-params>> ] [ in-params>> ] bi
[
>r value>> r> type>> {
[ value>> ] [ type>> ] bi* {
{ FACTOR-BLOB [
dup [ object>bytes malloc-byte-array/length ] [ 0 ] if
] }
@ -99,7 +99,7 @@ M: postgresql-result-null summary ( obj -- str )
: do-postgresql-bound-statement ( statement -- res )
[
>r db get handle>> r>
[ db get handle>> ] dip
{
[ sql>> ]
[ bind-params>> length ]
@ -117,7 +117,7 @@ M: postgresql-result-null summary ( obj -- str )
: pq-get-string ( handle row column -- obj )
3dup PQgetvalue utf8 alien>string
dup empty? [ >r pq-get-is-null f r> ? ] [ 3nip ] if ;
dup empty? [ [ pq-get-is-null f ] dip ? ] [ 3nip ] if ;
: pq-get-number ( handle row column -- obj )
pq-get-string dup [ string>number ] when ;

4
basis/db/queries/queries.factor
View File

@ -95,7 +95,7 @@ M: random-id-generator eval-generator ( singleton -- obj )
3drop
] [
pick column-name>> 0%
>r first2 r> interval-comparison 0%
[ first2 ] dip interval-comparison 0%
bind#
] if ;
@ -201,7 +201,7 @@ M: db <count-statement> ( query -- statement )
: create-index ( index-name table-name columns -- )
[
>r >r "create index " % % r> " on " % % r> "(" %
[ [ "create index " % % ] dip " on " % % ] dip "(" %
"," join % ")" %
] "" make sql-command ;

14
basis/delegate/delegate-docs.factor
View File

@ -28,21 +28,21 @@ HELP: group-words
{ $values { "group" "a group" } { "words" "an array of words" } }
{ $description "Given a protocol or tuple class, this returns the corresponding generic words that this group contains." } ;
ARTICLE: { "delegate" "intro" } "Delegation"
ARTICLE: "delegate" "Delegation"
"The " { $vocab-link "delegate" } " vocabulary implements run-time consultation for method dispatch."
$nl
"Fundamental to the concept of " { $emphasis "protocols" } ", which are groups of tuple slot accessors, or groups of arbtirary generic words."
"A " { $emphasis "protocol" } " is a collection of related generic words. An object is said to " { $emphasis "consult" } " another object if it implements a protocol by forwarding all methods onto the other object."
$nl
"This allows an object to implement a certain protocol by passing the method calls to another object."
"Using this vocabulary, protocols can be defined and consulation can be set up without any repetitive boilerplate."
$nl
"Unlike " { $link "tuple-subclassing" } ", which expresses " { $emphasis "is-a" } " relationships by statically including the methods and slots of the superclass in all subclasses, consultation forwards generic word calls to another distinct object."
$nl
"Fundamentally, a protocol is a word which has a method for " { $link group-words } ". One type of protocol is a tuple, which consists of the slot accessors. To define a protocol as a set of words, use"
"Defining new protocols:"
{ $subsection POSTPONE: PROTOCOL: }
{ $subsection define-protocol }
"The literal syntax and defining word are:"
"Defining consultation:"
{ $subsection POSTPONE: CONSULT: }
{ $subsection define-consult }
"The " { $vocab-link "delegate.protocols" } " vocabulary defines formal protocols for the various informal protocols used in the Factor core, such as " { $link "sequence-protocol" } ", " { $link "assocs-protocol" } " or " { $link "stream-protocol" } ;
"Every tuple class has an associated protocol consisting of all of its slot accessor methods. The " { $vocab-link "delegate.protocols" } " vocabulary defines formal protocols for the various informal protocols used in the Factor core, such as " { $link "sequence-protocol" } ", " { $link "assocs-protocol" } " or " { $link "stream-protocol" } ;
ABOUT: { "delegate" "intro" }
ABOUT: "delegate"

2
basis/delegate/delegate.factor
View File

@ -36,7 +36,7 @@ M: tuple-class group-words
: define-consult ( group class quot -- )
[ register-protocol ]
[ rot group-words -rot [ consult-method ] 2curry each ]
[ [ group-words ] 2dip [ consult-method ] 2curry each ]
3bi ;
: CONSULT:

4
basis/dlists/dlists-tests.factor
View File

@ -75,3 +75,7 @@ IN: dlists.tests
dup clone 3 over push-back
[ dlist>seq ] bi@
] unit-test
[ V{ f 3 1 f } ] [ <dlist> 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test
[ V{ } ] [ <dlist> dlist>seq ] unit-test

26
basis/dlists/dlists.factor
View File

@ -57,11 +57,11 @@ M: dlist-node node-value obj>> ;
: (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? )
over [
[ call ] 2keep rot
[ drop t ] [ >r next>> r> (dlist-find-node) ] if
[ drop t ] [ [ next>> ] dip (dlist-find-node) ] if
] [ 2drop f f ] if ; inline recursive
: dlist-find-node ( dlist quot -- node/f ? )
>r front>> r> (dlist-find-node) ; inline
[ front>> ] dip (dlist-find-node) ; inline
: dlist-each-node ( dlist quot -- )
[ f ] compose dlist-find-node 2drop ; inline
@ -93,11 +93,11 @@ M: dlist peek-front ( dlist -- obj )
M: dlist pop-front* ( dlist -- )
[
dup front>> [ empty-dlist ] unless*
dup next>>
f rot (>>next)
f over set-prev-when
swap (>>front)
[
[ empty-dlist ] unless*
[ f ] change-next drop
f over set-prev-when
] change-front drop
] keep
normalize-back ;
@ -106,11 +106,11 @@ M: dlist peek-back ( dlist -- obj )
M: dlist pop-back* ( dlist -- )
[
dup back>> [ empty-dlist ] unless*
dup prev>>
f rot (>>prev)
f over set-next-when
swap (>>back)
[
[ empty-dlist ] unless*
[ f ] change-prev drop
f over set-next-when
] change-back drop
] keep
normalize-front ;
@ -154,7 +154,7 @@ M: dlist clear-deque ( dlist -- )
[ obj>> ] prepose dlist-each-node ; inline
: dlist>seq ( dlist -- seq )
[ ] pusher [ dlist-each ] dip ;
[ ] accumulator [ dlist-each ] dip ;
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;

3
basis/editors/editors.factor
View File

@ -26,8 +26,7 @@ SYMBOL: edit-hook
require ;
: edit-location ( file line -- )
>r (normalize-path) r>
edit-hook get-global
[ (normalize-path) ] dip edit-hook get-global
[ call ] [ no-edit-hook edit-location ] if* ;
: edit ( defspec -- )

7
basis/environment/environment.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs combinators kernel sequences splitting system
vocabs.loader ;
vocabs.loader init ;
IN: environment
HOOK: os-env os ( key -- value )
@ -25,3 +25,8 @@ HOOK: (set-os-envs) os ( seq -- )
{ [ os winnt? ] [ "environment.winnt" require ] }
{ [ os wince? ] [ ] }
} cond
[
"FACTOR_ROOTS" os-env os windows? ";" ":" ? split
[ add-vocab-root ] each
] "environment" add-init-hook

4
basis/farkup/farkup.factor
View File

@ -167,7 +167,7 @@ stand-alone
} cond ;
: escape-link ( href text -- href-esc text-esc )
>r check-url escape-quoted-string r> escape-string ;
[ check-url escape-quoted-string ] dip escape-string ;
: write-link ( href text -- )
escape-link
@ -185,7 +185,7 @@ stand-alone
] if ;
: render-code ( string mode -- string' )
>r string-lines r>
[ string-lines ] dip
[
<pre>
htmlize-lines

2
basis/furnace/sessions/sessions.factor
View File

@ -3,7 +3,7 @@
USING: assocs kernel math.intervals math.parser namespaces
strings random accessors quotations hashtables sequences
continuations fry calendar combinators combinators.short-circuit
destructors alarms io.servers.connection db db.tuples db.types
destructors alarms io.sockets db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
html.elements furnace.cache furnace.scopes furnace.utilities ;
IN: furnace.sessions

2
basis/grouping/grouping.factor
View File

@ -11,7 +11,7 @@ TUPLE: chunking-seq { seq read-only } { n read-only } ;
: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
: new-groups ( seq n class -- groups )
>r check-groups r> boa ; inline
[ check-groups ] dip boa ; inline
GENERIC: group@ ( n groups -- from to seq )

14
basis/hash2/hash2.factor
View File

@ -14,25 +14,25 @@ IN: hash2
: <hash2> ( size -- hash2 ) f <array> ;
: 2= ( a b pair -- ? )
first2 swapd >r >r = r> r> = and ; inline
first2 swapd [ = ] 2bi@ and ; inline
: (assoc2) ( a b alist -- {a,b,val} )
[ >r 2dup r> 2= ] find >r 3drop r> ; inline
[ 2= ] with with find nip ; inline
: assoc2 ( a b alist -- value )
(assoc2) dup [ third ] when ; inline
: set-assoc2 ( value a b alist -- alist )
>r rot 3array r> ?push ; inline
[ rot 3array ] dip ?push ; inline
: hash2@ ( a b hash2 -- a b bucket hash2 )
>r 2dup hashcode2 r> [ length mod ] keep ; inline
[ 2dup hashcode2 ] dip [ length mod ] keep ; inline
: hash2 ( a b hash2 -- value/f )
hash2@ nth [ assoc2 ] [ 2drop f ] if* ;
hash2@ nth dup [ assoc2 ] [ 3drop f ] if ;
: set-hash2 ( a b value hash2 -- )
>r -rot r> hash2@ [ set-assoc2 ] change-nth ;
[ -rot ] dip hash2@ [ set-assoc2 ] change-nth ;
: alist>hash2 ( alist size -- hash2 )
<hash2> [ over >r first3 r> set-hash2 ] reduce ; inline
<hash2> [ over [ first3 ] dip set-hash2 ] reduce ; inline

22
basis/heaps/heaps.factor
View File

@ -18,7 +18,7 @@ GENERIC: heap-size ( heap -- n )
TUPLE: heap data ;
: <heap> ( class -- heap )
>r V{ } clone r> boa ; inline
[ V{ } clone ] dip boa ; inline
TUPLE: entry value key heap index ;
@ -52,16 +52,16 @@ M: heap heap-size ( heap -- n )
data>> nth-unsafe ; inline
: up-value ( n heap -- entry )
>r up r> data-nth ; inline
[ up ] dip data-nth ; inline
: left-value ( n heap -- entry )
>r left r> data-nth ; inline
[ left ] dip data-nth ; inline
: right-value ( n heap -- entry )
>r right r> data-nth ; inline
[ right ] dip data-nth ; inline
: data-set-nth ( entry n heap -- )
>r [ >>index drop ] 2keep r>
[ [ >>index drop ] 2keep ] dip
data>> set-nth-unsafe ; inline
: data-push ( entry heap -- n )
@ -82,8 +82,8 @@ M: heap heap-size ( heap -- n )
data>> first ; inline
: data-exchange ( m n heap -- )
[ tuck data-nth >r data-nth r> ] 3keep
tuck >r >r data-set-nth r> r> data-set-nth ; inline
[ tuck data-nth [ data-nth ] dip ] 3keep
tuck [ data-set-nth ] 2dip data-set-nth ; inline
GENERIC: heap-compare ( pair1 pair2 heap -- ? )
@ -97,10 +97,10 @@ M: max-heap heap-compare (heap-compare) +lt+ eq? ;
heap-size >= ; inline
: left-bounds-check? ( m heap -- ? )
>r left r> heap-bounds-check? ; inline
[ left ] dip heap-bounds-check? ; inline
: right-bounds-check? ( m heap -- ? )
>r right r> heap-bounds-check? ; inline
[ right ] dip heap-bounds-check? ; inline
: continue? ( m up[m] heap -- ? )
[ data-nth swap ] keep [ data-nth ] keep
@ -109,7 +109,7 @@ M: max-heap heap-compare (heap-compare) +lt+ eq? ;
DEFER: up-heap
: (up-heap) ( n heap -- )
>r dup up r>
[ dup up ] dip
3dup continue? [
[ data-exchange ] 2keep up-heap
] [
@ -121,7 +121,7 @@ DEFER: up-heap
: (child) ( m heap -- n )
2dup right-value
>r 2dup left-value r>
[ 2dup left-value ] dip
rot heap-compare
[ right ] [ left ] if ;

70
basis/help/cookbook/cookbook.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax io kernel math namespaces parser
prettyprint sequences vocabs.loader namespaces stack-checker
help ;
help command-line multiline ;
IN: help.cookbook
ARTICLE: "cookbook-syntax" "Basic syntax cookbook"
@ -263,15 +263,65 @@ ARTICLE: "cookbook-application" "Application cookbook"
ARTICLE: "cookbook-scripts" "Scripting cookbook"
"Factor can be used for command-line scripting on Unix-like systems."
$nl
"A text file can begin with a comment like the following, and made executable:"
{ $code "#! /usr/bin/env factor -script" }
"Running the text file will run it through Factor, assuming the " { $snippet "factor" } " binary is in your " { $snippet "$PATH" } "."
"To run a script, simply pass it as an argument to the Factor executable:"
{ $code "./factor cleanup.factor" }
"The script may access command line arguments by inspecting the value of the " { $link command-line } " variable. It can also get its own path from the " { $link script } " variable."
{ $heading "Example: ls" }
"Here is an example implementing a simplified version of the Unix " { $snippet "ls" } " command in Factor:"
{ $code
<" USING: command-line namespaces io io.files io.files.listing
sequences kernel ;
command-line get [
current-directory get directory.
] [
dup length 1 = [ first directory. ] [
[ [ nl write ":" print ] [ directory. ] bi ] each
] if
] if-empty">
}
"You can put it in a file named " { $snippet "ls.factor" } ", and then run it, to list the " { $snippet "/usr/bin" } " directory for example:"
{ $code "./factor ls.factor /usr/bin" }
{ $heading "Example: grep" }
"The following is a more complicated example, implementing something like the Unix " { $snippet "grep" } " command:"
{ $code <" USING: kernel fry io io.files io.encodings.ascii sequences
regexp command-line namespaces ;
IN: grep
: grep-lines ( pattern -- )
'[ dup _ matches? [ print ] [ drop ] if ] each-line ;
: grep-file ( pattern filename -- )
ascii [ grep-lines ] with-file-reader ;
: grep-usage ( -- )
"Usage: factor grep.factor <pattern> [<file>...]" print ;
command-line get [
grep-usage
] [
unclip <regexp> swap [
grep-lines
] [
[ grep-file ] with each
] if-empty
] if-empty"> }
"You can run it like so,"
{ $code "./factor grep.factor '.*hello.*' myfile.txt" }
"You'll notice this script takes a while to start. This is because it is loading and compiling the " { $vocab-link "regexp" } " vocabulary every time. To speed up startup, load the vocabulary into your image, and save the image:"
{ $code "USE: regexp" "save" }
"Now, the " { $snippet "grep.factor" } " script will start up much faster. See " { $link "images" } " for details."
{ $heading "Executable scripts" }
"It is also possible to make executable scripts. A Factor file can begin with a comment like the following:"
{ $code "#! /usr/bin/env factor" }
"If the text file is made executable, then it can be run, assuming the " { $snippet "factor" } " binary is in your " { $snippet "$PATH" } "."
$nl
"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch suppresses compiler messages, and exits Factor when the script finishes."
"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result."
{ $references
{ }
"cli"
"cookbook-application"
"images"
} ;
ARTICLE: "cookbook-philosophy" "Factor philosophy"
@ -325,15 +375,6 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
{ "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." }
} ;
ARTICLE: "cookbook-images" "Image file cookbook"
"Factor has the ability to save the entire state of the system into an " { $emphasis "image file" } "."
$nl
"You can save a custom image if you find yourself loading the same libraries in every Factor session; some libraries take a little while to compile, so saving an image with those libraries loaded can save you a lot of time."
$nl
"For example, to save an image with the web framework loaded,"
{ $code "USE: furnace" "save" }
"See " { $link "images" } " for details." ;
ARTICLE: "cookbook-next" "Next steps"
"Once you have read through " { $link "first-program" } " and " { $link "cookbook" } ", the best way to keep learning Factor is to start looking at some simple example programs. Here are a few particularly nice vocabularies which should keep you busy for a little while:"
{ $list
@ -358,7 +399,6 @@ ARTICLE: "cookbook" "Factor cookbook"
{ $subsection "cookbook-application" }
{ $subsection "cookbook-scripts" }
{ $subsection "cookbook-compiler" }
{ $subsection "cookbook-images" }
{ $subsection "cookbook-philosophy" }
{ $subsection "cookbook-pitfalls" }
{ $subsection "cookbook-next" } ;

1
basis/help/lint/summary.txt
View File

@ -0,0 +1 @@
Help lint tool

2
basis/help/tutorial/tutorial.factor
View File

@ -13,6 +13,8 @@ $nl
{ $code "\"resource:work\" \"palindrome\" scaffold-vocab" }
"If you look at the output, you will see that a few files were created in your ``work'' directory. The following phrase will print the full path of your work directory:"
{ $code "\"work\" resource-path ." }
"The work directory is one of several " { $link "vocabs.roots" } " where Factor searches for vocabularies. It is possible to define new vocabulary roots; see " { $link "add-vocab-roots" } ". To keep things simple in this tutorial, we'll just use the work directory, though."
$nl
"Open the work directory in your file manager, and open the subdirectory named " { $snippet "palindrome" } ". Inside this subdirectory you will see a file named " { $snippet "palindrome.factor" } ". We will be editing this file."
$nl
"Notice that the file ends with an " { $link POSTPONE: IN: } " form telling Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"

8
basis/hints/hints-docs.factor
View File

@ -1,10 +1,10 @@
IN: hints
USING: help.markup help.syntax words quotations sequences ;
USING: help.markup help.syntax words quotations sequences kernel ;
ARTICLE: "hints" "Compiler specialization hints"
"Specialization hints help the compiler generate efficient code."
$nl
"Specialization hints can help words which call a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place."
"Specialization hints can help words which call a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class, or even " { $link eq? } " to some literal. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class or value, and inlining of generic methods can take place."
$nl
"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information."
$nl
@ -20,10 +20,10 @@ HELP: specialized-def
{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;
HELP: HINTS:
{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes" } }
{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes or literals" } }
{ $description "Defines specialization hints for a word or a method."
$nl
"Each sequence of classes in the list will cause a specialized version of the word to be compiled." }
"Each sequence in the list will cause a specialized version of the word to be compiled. Classes are tested for using their predicate, and literals are tested using " { $link eq? } "." }
{ $examples "The " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
{ $code "HINTS: append { string string } { array array } ;" }
"Specializers can also be defined on methods:"

21
basis/hints/hints.factor
View File

@ -3,25 +3,34 @@
USING: parser words definitions kernel sequences assocs arrays
kernel.private fry combinators accessors vectors strings sbufs
byte-arrays byte-vectors io.binary io.streams.string splitting
math generic generic.standard generic.standard.engines ;
math generic generic.standard generic.standard.engines classes ;
IN: hints
: (make-specializer) ( class picker -- quot )
swap "predicate" word-prop append ;
GENERIC: specializer-predicate ( spec -- quot )
: make-specializer ( classes -- quot )
M: class specializer-predicate "predicate" word-prop ;
M: object specializer-predicate '[ _ eq? ] ;
GENERIC: specializer-declaration ( spec -- class )
M: class specializer-declaration ;
M: object specializer-declaration class ;
: make-specializer ( specs -- quot )
dup length <reversed>
[ (picker) 2array ] 2map
[ drop object eq? not ] assoc-filter
[ [ t ] ] [
[ (make-specializer) ] { } assoc>map
[ swap specializer-predicate append ] { } assoc>map
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if-empty ;
: specializer-cases ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
'[ _ declare ] pick append
[ specializer-declaration ] map '[ _ declare ] pick append
] { } map>assoc ;
: method-declaration ( method -- quot )

6
basis/inspector/inspector.factor
View File

@ -49,10 +49,8 @@ SYMBOL: +editable+
] [ keys ] if ;
: describe* ( obj mirror keys -- )
rot summary.
[
drop
] [
[ summary. ] 2dip
[ drop ] [
dup enum? [ +sequence+ on ] when
standard-table-style [
swap [ -rot describe-row ] curry each-index

85
basis/io/launcher/launcher.factor
View File

@ -183,16 +183,18 @@ M: object run-pipeline-element
: <process-reader*> ( desc encoding -- stream process )
[
>r (pipe) {
[ |dispose drop ]
[
swap >process
[ swap out>> or ] change-stdout
run-detached
]
[ out>> dispose ]
[ in>> <input-port> ]
} cleave r> <decoder> swap
[
(pipe) {
[ |dispose drop ]
[
swap >process
[ swap out>> or ] change-stdout
run-detached
]
[ out>> dispose ]
[ in>> <input-port> ]
} cleave
] dip <decoder> swap
] with-destructors ;
: <process-reader> ( desc encoding -- stream )
@ -205,16 +207,18 @@ M: object run-pipeline-element
: <process-writer*> ( desc encoding -- stream process )
[
>r (pipe) {
[ |dispose drop ]
[
swap >process
[ swap in>> or ] change-stdin
run-detached
]
[ in>> dispose ]
[ out>> <output-port> ]
} cleave r> <encoder> swap
[
(pipe) {
[ |dispose drop ]
[
swap >process
[ swap in>> or ] change-stdin
run-detached
]
[ in>> dispose ]
[ out>> <output-port> ]
} cleave
] dip <encoder> swap
] with-destructors ;
: <process-writer> ( desc encoding -- stream )
@ -227,17 +231,19 @@ M: object run-pipeline-element
: <process-stream*> ( desc encoding -- stream process )
[
>r (pipe) (pipe) {
[ [ |dispose drop ] bi@ ]
[
rot >process
[ swap in>> or ] change-stdin
[ swap out>> or ] change-stdout
run-detached
]
[ [ out>> dispose ] [ in>> dispose ] bi* ]
[ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
} 2cleave r> <encoder-duplex> swap
[
(pipe) (pipe) {
[ [ |dispose drop ] bi@ ]
[
rot >process
[ swap in>> or ] change-stdin
[ swap out>> or ] change-stdout
run-detached
]
[ [ out>> dispose ] [ in>> dispose ] bi* ]
[ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
} 2cleave
] dip <encoder-duplex> swap
] with-destructors ;
: <process-stream> ( desc encoding -- stream )
@ -254,23 +260,6 @@ M: object run-pipeline-element
f >>handle
drop ;
GENERIC: underlying-handle ( stream -- handle )
M: port underlying-handle handle>> ;
ERROR: invalid-duplex-stream ;
M: duplex-stream underlying-handle
[ in>> underlying-handle ]
[ out>> underlying-handle ] bi
[ = [ invalid-duplex-stream ] when ] keep ;
M: encoder underlying-handle
stream>> underlying-handle ;
M: decoder underlying-handle
stream>> underlying-handle ;
{
{ [ os unix? ] [ "io.unix.launcher" require ] }
{ [ os winnt? ] [ "io.windows.nt.launcher" require ] }

14
basis/io/pipes/pipes.factor
View File

@ -15,9 +15,10 @@ HOOK: (pipe) io-backend ( -- pipe )
: <pipe> ( encoding -- stream )
[
>r (pipe) |dispose
[ in>> <input-port> ] [ out>> <output-port> ] bi
r> <encoder-duplex>
[
(pipe) |dispose
[ in>> <input-port> ] [ out>> <output-port> ] bi
] dip <encoder-duplex>
] with-destructors ;
<PRIVATE
@ -32,8 +33,7 @@ GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot )
M: callable run-pipeline-element
[
>r [ ?reader ] [ ?writer ] bi*
r> with-streams*
[ [ ?reader ] [ ?writer ] bi* ] dip with-streams*
] with-destructors ;
: <pipes> ( n -- pipes )
@ -48,8 +48,8 @@ PRIVATE>
: run-pipeline ( seq -- results )
[ length dup zero? [ drop { } ] [ 1- <pipes> ] if ] keep
[
>r [ first in>> ] [ second out>> ] bi
r> run-pipeline-element
[ [ first in>> ] [ second out>> ] bi ] dip
run-pipeline-element
] 2parallel-map ;
{

28
basis/io/ports/ports.factor
View File

@ -46,7 +46,7 @@ M: input-port stream-read1
M: input-port stream-read-partial ( max stream -- byte-array/f )
dup check-disposed
>r 0 max >integer r> read-step ;
[ 0 max >integer ] dip read-step ;
: read-loop ( count port accum -- )
pick over length - dup 0 > [
@ -61,7 +61,7 @@ M: input-port stream-read-partial ( max stream -- byte-array/f )
M: input-port stream-read
dup check-disposed
>r 0 max >fixnum r>
[ 0 max >fixnum ] dip
2dup read-step dup [
pick over length > [
pick <byte-vector>
@ -76,21 +76,21 @@ M: input-port stream-read
: read-until-loop ( seps port buf -- separator/f )
2over read-until-step over [
>r over push-all r> dup [
>r 3drop r>
[ over push-all ] dip dup [
[ 3drop ] dip
] [
drop read-until-loop
] if
] [
>r 2drop 2drop r>
[ 2drop 2drop ] dip
] if ;
M: input-port stream-read-until ( seps port -- str/f sep/f )
2dup read-until-step dup [ >r 2nip r> ] [
2dup read-until-step dup [ [ 2drop ] 2dip ] [
over [
drop
BV{ } like [ read-until-loop ] keep B{ } like swap
] [ >r 2nip r> ] if
] [ [ 2drop ] 2dip ] if
] if ;
TUPLE: output-port < buffered-port ;
@ -114,7 +114,7 @@ M: output-port stream-write
[ [ stream-write ] curry ] bi
each
] [
[ >r length r> wait-to-write ]
[ [ length ] dip wait-to-write ]
[ buffer>> >buffer ] 2bi
] if ;
@ -153,6 +153,18 @@ M: port dispose*
bi
] with-destructors ;
GENERIC: underlying-port ( stream -- port )
M: port underlying-port ;
M: encoder underlying-port stream>> underlying-port ;
M: decoder underlying-port stream>> underlying-port ;
GENERIC: underlying-handle ( stream -- handle )
M: object underlying-handle underlying-port handle>> ;
! Fast-path optimization
USING: hints strings io.encodings.utf8 io.encodings.ascii
io.encodings.private ;

4
basis/io/servers/connection/connection-docs.factor
View File

@ -66,11 +66,11 @@ ARTICLE: "io.servers.connection" "Threaded servers"
"Stopping the server:"
{ $subsection stop-server }
"From within the dynamic scope of a client handler, several words can be used to interact with the threaded server:"
{ $subsection remote-address }
{ $subsection stop-this-server }
{ $subsection secure-port }
{ $subsection insecure-port }
"Additionally, the " { $link local-address } " variable is set, as in " { $link with-client } "." ;
"Additionally, the " { $link local-address } " and "
{ $subsection remote-address } " variables are set, as in " { $link with-client } "." ;
ABOUT: "io.servers.connection"

2
basis/io/servers/connection/connection.factor
View File

@ -39,8 +39,6 @@ ready ;
: <threaded-server> ( -- threaded-server )
threaded-server new-threaded-server ;
SYMBOL: remote-address
GENERIC: handle-client* ( threaded-server -- )
<PRIVATE

41
basis/io/sockets/secure/secure-docs.factor
View File

@ -1,5 +1,5 @@
USING: io help.markup help.syntax calendar quotations io.sockets ;
IN: io.sockets.secure
USING: help.markup help.syntax calendar quotations io.sockets ;
HELP: secure-socket-timeout
{ $var-description "Timeout for operations not associated with a constructed port instance, such as SSL handshake and shutdown. Represented as a " { $link duration } "." } ;
@ -99,6 +99,23 @@ $nl
{ $subsection <secure> }
"Instances of this class can wrap an " { $link inet } ", " { $link inet4 } " or an " { $link inet6 } ", although note that certificate validation is only performed for instances of " { $link inet } " since otherwise the host name is not available." ;
HELP: send-secure-handshake
{ $contract "Upgrades the socket connection of the current " { $link with-client } " scope to a secure connection and initiates a SSL/TLS handshake." }
{ $errors "Throws " { $link upgrade-on-non-socket } " or " { $link upgrade-buffers-full } " if used improperly." }
{ $examples "This word is used by the " { $vocab-link "smtp" } " library to implement SMTP-TLS." } ;
HELP: accept-secure-handshake
{ $contract "Upgrades the socket connection stored in the " { $link input-stream } " and " { $link output-stream } " variables to a secure connection and waits for an SSL/TLS handshake." }
{ $errors "Throws " { $link upgrade-on-non-socket } " or " { $link upgrade-buffers-full } " if used improperly." } ;
ARTICLE: "ssl-upgrade" "Upgrading existing connections"
"Some protocols, such as HTTPS, require that the connection be established as an SSL/TLS connection. Others, such as secure SMTP and POP3 require that the client and server initiate an SSL/TLS handshake upon the client sending a plain-text request. The latter use-case is accomodated by a pair of words."
$nl
"Upgrading a connection to a secure socket by initiating an SSL/TLS handshake with the server:"
{ $subsection send-secure-handshake }
"Upgrading a connection to a secure socket by waiting for an SSL/TLS handshake from the client:"
{ $subsection accept-secure-handshake } ;
HELP: premature-close
{ $error-description "Thrown if an SSL connection is closed without the proper " { $snippet "close_notify" } " sequence. This error is never reported for " { $link SSLv2 } " connections because there is no distinction between expected and unexpected connection closure in that case." } ;
@ -106,20 +123,34 @@ HELP: certificate-verify-error
{ $error-description "Thrown if certificate verification failed. The " { $snippet "result" } " slot contains an object identifying the low-level error that occurred." } ;
HELP: common-name-verify-error
{ $error-description "Thrown during certificate verification if the host name on the certificate does not match the host name the socket was connected to. This indicates a potential man-in-the-middle attack. The " { $snippet "expected" } " and " { $snippet "got" } " slots contain the mismatched host names." } ;
{ $error-description "Thrown during certificate verification if the host name on the certificate does not match the host name the socket was connected to. This indicates a potential man-in-the-middle attack. The " { $slot "expected" } " and " { $slot "got" } " slots contain the mismatched host names." } ;
HELP: upgrade-on-non-socket
{ $error-description "Thrown if " { $link send-secure-handshake } " or " { $link accept-secure-handshake } " is called with the " { $link input-stream } " and " { $link output-stream } " variables not set to a socket. This error can also indicate that the connection has already been upgraded to a secure connection." } ;
HELP: upgrade-buffers-full
{ $error-description "Thrown if " { $link send-secure-handshake } " or " { $link accept-secure-handshake } " is called when there is still data which hasn't been read or written." }
{ $notes "Clients should ensure to " { $link flush } " their last command to the server before calling " { $link send-secure-handshake } "." } ;
ARTICLE: "ssl-errors" "Secure socket errors"
"Secure sockets can throw one of several errors in addition to the usual I/O errors:"
{ $subsection premature-close }
{ $subsection certificate-verify-error }
{ $subsection common-name-verify-error } ;
{ $subsection common-name-verify-error }
"The " { $link send-secure-handshake } " word can throw one of two errors:"
{ $subsection upgrade-on-non-socket }
{ $subsection upgrade-buffers-full } ;
ARTICLE: "io.sockets.secure" "Secure sockets (SSL, TLS)"
"The " { $vocab-link "io.sockets.secure" } " vocabulary implements secure, encrypted sockets using the OpenSSL library."
$nl
"At present, this vocabulary only works on Unix, and not on Windows."
$nl
"This product includes software developed by the OpenSSL Project for use in the OpenSSL Toolkit (" { $url "http://www.openssl.org/" } "), cryptographic software written by Eric Young (eay@cryptsoft.com) and software written by Tim Hudson (tjh@cryptsoft.com)."
{ $subsection "ssl-config" }
{ $subsection "ssl-contexts" }
{ $subsection "ssl-addresses" }
{ $subsection "ssl-errors" }
"This product includes software developed by the OpenSSL Project for use in the OpenSSL Toolkit (" { $url "http://www.openssl.org/" } "), cryptographic software written by Eric Young (eay@cryptsoft.com) and software written by Tim Hudson (tjh@cryptsoft.com)." ;
{ $subsection "ssl-upgrade" }
{ $subsection "ssl-errors" } ;
ABOUT: "io.sockets.secure"

25
basis/io/sockets/secure/secure.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel symbols namespaces continuations
destructors io.sockets sequences summary calendar delegate
system vocabs.loader combinators present ;
destructors io debugger io.sockets sequences summary calendar
delegate system vocabs.loader combinators present ;
IN: io.sockets.secure
SYMBOL: secure-socket-timeout
@ -52,10 +52,10 @@ M: secure resolve-host ( secure -- seq )
HOOK: check-certificate secure-socket-backend ( host handle -- )
<PRIVATE
PREDICATE: secure-inet < secure addrspec>> inet? ;
<PRIVATE
M: secure-inet (client)
[
[ resolve-host (client) [ |dispose ] dip ] keep
@ -79,6 +79,23 @@ ERROR: common-name-verify-error expected got ;
M: common-name-verify-error summary
drop "Common name verification failed" ;
ERROR: upgrade-on-non-socket ;
M: upgrade-on-non-socket summary
drop
"send-secure-handshake can only be used if input-stream and" print
"output-stream are a socket" ;
ERROR: upgrade-buffers-full ;
M: upgrade-buffers-full summary
drop
"send-secure-handshake can only be used if buffers are empty" ;
HOOK: send-secure-handshake secure-socket-backend ( -- )
HOOK: accept-secure-handshake secure-socket-backend ( -- )
{
{ [ os unix? ] [ "io.unix.sockets.secure" require ] }
{ [ os windows? ] [ "openssl" require ] }

2
basis/io/sockets/sockets-docs.factor
View File

@ -105,7 +105,7 @@ HELP: <client>
HELP: with-client
{ $values { "remote" "an address specifier" } { "encoding" "an encoding descriptor" } { "quot" quotation } }
{ $description "Opens a network connection and calls the quotation in a new dynamic scope with " { $link input-stream } " and " { $link output-stream } " rebound to the network streams. The local address the socket is bound to is stored in the " { $link local-address } " variable." }
{ $description "Opens a network connection and calls the quotation in a new dynamic scope with " { $link input-stream } " and " { $link output-stream } " rebound to the network streams. The local address the socket is connected to is stored in the " { $link local-address } " variable, and the remote address is stored in the " { $link remote-address } " variable." }
{ $errors "Throws an error if the connection cannot be established." } ;
HELP: <server>

31
basis/io/sockets/sockets.factor
View File

@ -6,7 +6,7 @@ sequences arrays io.encodings io.ports io.streams.duplex
io.encodings.ascii alien.strings io.binary accessors destructors
classes debugger byte-arrays system combinators parser
alien.c-types math.parser splitting grouping math assocs summary
system vocabs.loader combinators present ;
system vocabs.loader combinators present fry ;
IN: io.sockets
<< {
@ -89,7 +89,7 @@ M: inet4 make-sockaddr ( inet -- sockaddr )
rot inet-pton *uint over set-sockaddr-in-addr ;
M: inet4 parse-sockaddr
>r dup sockaddr-in-addr <uint> r> inet-ntop
[ dup sockaddr-in-addr <uint> ] dip inet-ntop
swap sockaddr-in-port ntohs <inet4> ;
TUPLE: inet6 < abstract-inet ;
@ -144,7 +144,7 @@ M: inet6 make-sockaddr ( inet -- sockaddr )
rot inet-pton over set-sockaddr-in6-addr ;
M: inet6 parse-sockaddr
>r dup sockaddr-in6-addr r> inet-ntop
[ dup sockaddr-in6-addr ] dip inet-ntop
swap sockaddr-in6-port ntohs <inet6> ;
: addrspec-of-family ( af -- addrspec )
@ -184,7 +184,7 @@ M: object (client) ( remote -- client-in client-out local )
[
[ ((client)) ] keep
[
>r <ports> [ |dispose ] bi@ dup r>
[ <ports> [ |dispose ] bi@ dup ] dip
establish-connection
]
[ get-local-address ]
@ -192,13 +192,19 @@ M: object (client) ( remote -- client-in client-out local )
] with-destructors ;
: <client> ( remote encoding -- stream local )
>r (client) -rot r> <encoder-duplex> swap ;
[ (client) -rot ] dip <encoder-duplex> swap ;
SYMBOL: local-address
SYMBOL: remote-address
: with-client ( remote encoding quot -- )
>r <client> [ local-address set ] curry
r> compose with-stream ; inline
[
[
over remote-address set
<client> local-address set
] dip with-stream
] with-scope ; inline
TUPLE: server-port < port addr encoding ;
@ -209,10 +215,11 @@ TUPLE: server-port < port addr encoding ;
GENERIC: (server) ( addrspec -- handle )
: <server> ( addrspec encoding -- server )
>r
[ (server) ] keep
[ drop server-port <port> ] [ get-local-address ] 2bi
>>addr r> >>encoding ;
[
[ (server) ] keep
[ drop server-port <port> ] [ get-local-address ] 2bi
>>addr
] dip >>encoding ;
GENERIC: (accept) ( server addrspec -- handle sockaddr )
@ -281,7 +288,7 @@ C: <inet> inet
IPPROTO_TCP over set-addrinfo-protocol ;
: fill-in-ports ( addrspecs port -- addrspecs )
[ >>port ] curry map ;
'[ _ >>port ] map ;
M: inet resolve-host
[ port>> ] [ host>> ] bi [

16
basis/io/streams/duplex/duplex.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations destructors io io.encodings
io.encodings.private io.timeouts debugger summary listener
accessors delegate delegate.protocols ;
io.encodings.private io.timeouts io.ports debugger summary
listener accessors delegate delegate.protocols ;
IN: io.streams.duplex
TUPLE: duplex-stream in out ;
@ -30,7 +30,15 @@ M: duplex-stream dispose
tuck re-encode >r re-decode r> <duplex-stream> ;
: with-stream* ( stream quot -- )
>r [ in>> ] [ out>> ] bi r> with-streams* ; inline
[ [ in>> ] [ out>> ] bi ] dip with-streams* ; inline
: with-stream ( stream quot -- )
>r [ in>> ] [ out>> ] bi r> with-streams ; inline
[ [ in>> ] [ out>> ] bi ] dip with-streams ; inline
ERROR: invalid-duplex-stream ;
M: duplex-stream underlying-handle
[ in>> underlying-handle ]
[ out>> underlying-handle ] bi
[ = [ invalid-duplex-stream ] when ] keep ;

101
basis/io/unix/files/files.factor
View File

@ -167,19 +167,23 @@ M: unix (directory-entries) ( path -- seq )
: stat-mode ( path -- mode )
normalize-path file-status stat-st_mode ;
: chmod-set-bit ( path mask ? -- )
[ dup stat-mode ] 2dip
: chmod-set-bit ( path mask ? -- )
[ dup stat-mode ] 2dip
[ bitor ] [ unmask ] if chmod io-error ;
: file-mode? ( path mask -- ? ) [ stat-mode ] dip mask? ;
GENERIC# file-mode? 1 ( obj mask -- ? )
M: integer file-mode? mask? ;
M: string file-mode? [ stat-mode ] dip mask? ;
M: file-info file-mode? [ permissions>> ] dip mask? ;
PRIVATE>
: ch>file-type ( ch -- type )
{
{ CHAR: b [ +block-device+ ] }
{ CHAR: c [ +character-device+ ] }
{ CHAR: c [ +character-device+ ] }
{ CHAR: d [ +directory+ ] }
{ CHAR: l [ +symbolic-link+ ] }
{ CHAR: s [ +socket+ ] }
@ -205,29 +209,29 @@ PRIVATE>
: STICKY OCT: 0001000 ; inline
: USER-ALL OCT: 0000700 ; inline
: USER-READ OCT: 0000400 ; inline
: USER-WRITE OCT: 0000200 ; inline
: USER-EXECUTE OCT: 0000100 ; inline
: USER-WRITE OCT: 0000200 ; inline
: USER-EXECUTE OCT: 0000100 ; inline
: GROUP-ALL OCT: 0000070 ; inline
: GROUP-READ OCT: 0000040 ; inline
: GROUP-WRITE OCT: 0000020 ; inline
: GROUP-EXECUTE OCT: 0000010 ; inline
: GROUP-READ OCT: 0000040 ; inline
: GROUP-WRITE OCT: 0000020 ; inline
: GROUP-EXECUTE OCT: 0000010 ; inline
: OTHER-ALL OCT: 0000007 ; inline
: OTHER-READ OCT: 0000004 ; inline
: OTHER-WRITE OCT: 0000002 ; inline
: OTHER-EXECUTE OCT: 0000001 ; inline
: OTHER-WRITE OCT: 0000002 ; inline
: OTHER-EXECUTE OCT: 0000001 ; inline
GENERIC: uid? ( obj -- ? )
GENERIC: gid? ( obj -- ? )
GENERIC: sticky? ( obj -- ? )
GENERIC: user-read? ( obj -- ? )
GENERIC: user-write? ( obj -- ? )
GENERIC: user-execute? ( obj -- ? )
GENERIC: group-read? ( obj -- ? )
GENERIC: group-write? ( obj -- ? )
GENERIC: group-execute? ( obj -- ? )
GENERIC: other-read? ( obj -- ? )
GENERIC: other-write? ( obj -- ? )
GENERIC: other-execute? ( obj -- ? )
: uid? ( obj -- ? ) UID file-mode? ;
: gid? ( obj -- ? ) GID file-mode? ;
: sticky? ( obj -- ? ) STICKY file-mode? ;
: user-read? ( obj -- ? ) USER-READ file-mode? ;
: user-write? ( obj -- ? ) USER-WRITE file-mode? ;
: user-execute? ( obj -- ? ) USER-EXECUTE file-mode? ;
: group-read? ( obj -- ? ) GROUP-READ file-mode? ;
: group-write? ( obj -- ? ) GROUP-WRITE file-mode? ;
: group-execute? ( obj -- ? ) GROUP-EXECUTE file-mode? ;
: other-read? ( obj -- ? ) OTHER-READ file-mode? ;
: other-write? ( obj -- ? ) OTHER-WRITE file-mode? ;
: other-execute? ( obj -- ? ) OTHER-EXECUTE file-mode? ;
: any-read? ( obj -- ? )
{ [ user-read? ] [ group-read? ] [ other-read? ] } 1|| ;
@ -238,56 +242,17 @@ GENERIC: other-execute? ( obj -- ? )
: any-execute? ( obj -- ? )
{ [ user-execute? ] [ group-execute? ] [ other-execute? ] } 1|| ;
M: integer uid? ( integer -- ? ) UID mask? ;
M: integer gid? ( integer -- ? ) GID mask? ;
M: integer sticky? ( integer -- ? ) STICKY mask? ;
M: integer user-read? ( integer -- ? ) USER-READ mask? ;
M: integer user-write? ( integer -- ? ) USER-WRITE mask? ;
M: integer user-execute? ( integer -- ? ) USER-EXECUTE mask? ;
M: integer group-read? ( integer -- ? ) GROUP-READ mask? ;
M: integer group-write? ( integer -- ? ) GROUP-WRITE mask? ;
M: integer group-execute? ( integer -- ? ) GROUP-EXECUTE mask? ;
M: integer other-read? ( integer -- ? ) OTHER-READ mask? ;
M: integer other-write? ( integer -- ? ) OTHER-WRITE mask? ;
M: integer other-execute? ( integer -- ? ) OTHER-EXECUTE mask? ;
M: file-info uid? ( file-info -- ? ) permissions>> uid? ;
M: file-info gid? ( file-info -- ? ) permissions>> gid? ;
M: file-info sticky? ( file-info -- ? ) permissions>> sticky? ;
M: file-info user-read? ( file-info -- ? ) permissions>> user-read? ;
M: file-info user-write? ( file-info -- ? ) permissions>> user-write? ;
M: file-info user-execute? ( file-info -- ? ) permissions>> user-execute? ;
M: file-info group-read? ( file-info -- ? ) permissions>> group-read? ;
M: file-info group-write? ( file-info -- ? ) permissions>> group-write? ;
M: file-info group-execute? ( file-info -- ? ) permissions>> group-execute? ;
M: file-info other-read? ( file-info -- ? ) permissions>> other-read? ;
M: file-info other-write? ( file-info -- ? ) permissions>> other-write? ;
M: file-info other-execute? ( file-info -- ? ) permissions>> other-execute? ;
M: string uid? ( path -- ? ) UID file-mode? ;
M: string gid? ( path -- ? ) GID file-mode? ;
M: string sticky? ( path -- ? ) STICKY file-mode? ;
M: string user-read? ( path -- ? ) USER-READ file-mode? ;
M: string user-write? ( path -- ? ) USER-WRITE file-mode? ;
M: string user-execute? ( path -- ? ) USER-EXECUTE file-mode? ;
M: string group-read? ( path -- ? ) GROUP-READ file-mode? ;
M: string group-write? ( path -- ? ) GROUP-WRITE file-mode? ;
M: string group-execute? ( path -- ? ) GROUP-EXECUTE file-mode? ;
M: string other-read? ( path -- ? ) OTHER-READ file-mode? ;
M: string other-write? ( path -- ? ) OTHER-WRITE file-mode? ;
M: string other-execute? ( path -- ? ) OTHER-EXECUTE file-mode? ;
: set-uid ( path ? -- ) UID swap chmod-set-bit ;
: set-gid ( path ? -- ) GID swap chmod-set-bit ;
: set-sticky ( path ? -- ) STICKY swap chmod-set-bit ;
: set-user-read ( path ? -- ) USER-READ swap chmod-set-bit ;
: set-user-write ( path ? -- ) USER-WRITE swap chmod-set-bit ;
: set-user-write ( path ? -- ) USER-WRITE swap chmod-set-bit ;
: set-user-execute ( path ? -- ) USER-EXECUTE swap chmod-set-bit ;
: set-group-read ( path ? -- ) GROUP-READ swap chmod-set-bit ;
: set-group-write ( path ? -- ) GROUP-WRITE swap chmod-set-bit ;
: set-group-write ( path ? -- ) GROUP-WRITE swap chmod-set-bit ;
: set-group-execute ( path ? -- ) GROUP-EXECUTE swap chmod-set-bit ;
: set-other-read ( path ? -- ) OTHER-READ swap chmod-set-bit ;
: set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ;
: set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ;
: set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ;
: set-file-permissions ( path n -- )
@ -334,10 +299,10 @@ M: integer set-file-user ( path uid -- )
M: string set-file-user ( path string -- )
user-id f set-file-ids ;
M: integer set-file-group ( path gid -- )
f swap set-file-ids ;
M: string set-file-group ( path string -- )
group-id
f swap set-file-ids ;

11
basis/io/unix/launcher/launcher.factor
View File

@ -40,14 +40,13 @@ USE: unix
3drop ;
: redirect-file ( obj mode fd -- )
>r >r normalize-path r> file-mode
open-file r> redirect-fd ;
[ [ normalize-path ] dip file-mode open-file ] dip redirect-fd ;
: redirect-file-append ( obj mode fd -- )
>r drop path>> normalize-path open-append r> redirect-fd ;
[ drop path>> normalize-path open-append ] dip redirect-fd ;
: redirect-closed ( obj mode fd -- )
>r >r drop "/dev/null" r> r> redirect-file ;
[ drop "/dev/null" ] 2dip redirect-file ;
: redirect ( obj mode fd -- )
{
@ -55,8 +54,8 @@ USE: unix
{ [ pick string? ] [ redirect-file ] }
{ [ pick appender? ] [ redirect-file-append ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }
{ [ pick fd? ] [ >r drop fd>> dup reset-fd r> redirect-fd ] }
[ >r >r underlying-handle r> r> redirect ]
{ [ pick fd? ] [ [ drop fd>> dup reset-fd ] dip redirect-fd ] }
[ [ underlying-handle ] 2dip redirect ]
} cond ;
: ?closed ( obj -- obj' )

2
basis/io/unix/select/select.factor
View File

@ -19,7 +19,7 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
FD_SETSIZE 8 * <bit-array> >>write-fdset ;
: clear-nth ( n seq -- ? )
[ nth ] [ f -rot set-nth ] 2bi ;
[ nth ] [ [ f ] 2dip set-nth ] 2bi ;
:: check-fd ( fd fdset mx quot -- )
fd munge fdset clear-nth [ fd mx quot call ] when ; inline

11
basis/io/unix/sockets/secure/debug/debug.factor Normal file
View File

@ -0,0 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io.sockets.secure kernel ;
IN: io.unix.sockets.secure.debug
: with-test-context ( quot -- )
<secure-config>
"resource:basis/openssl/test/server.pem" >>key-file
"resource:basis/openssl/test/dh1024.pem" >>dh-file
"password" >>password
swap with-secure-context ; inline

10
basis/io/unix/sockets/secure/secure-tests.factor
View File

@ -2,20 +2,14 @@ IN: io.sockets.secure.tests
USING: accessors kernel namespaces io io.sockets
io.sockets.secure io.encodings.ascii io.streams.duplex
io.unix.backend classes words destructors threads tools.test
concurrency.promises byte-arrays locals calendar io.timeouts ;
concurrency.promises byte-arrays locals calendar io.timeouts
io.unix.sockets.secure.debug ;
\ <secure-config> must-infer
{ 1 0 } [ [ ] with-secure-context ] must-infer-as
[ ] [ <promise> "port" set ] unit-test
: with-test-context ( quot -- )
<secure-config>
"resource:basis/openssl/test/server.pem" >>key-file
"resource:basis/openssl/test/dh1024.pem" >>dh-file
"password" >>password
swap with-secure-context ; inline
:: server-test ( quot -- )
[
[

60
basis/io/unix/sockets/secure/secure.factor
View File

@ -3,10 +3,10 @@
USING: accessors unix byte-arrays kernel debugger sequences
namespaces math math.order combinators init alien alien.c-types
alien.strings libc continuations destructors openssl
openssl.libcrypto openssl.libssl io.files io.ports
openssl.libcrypto openssl.libssl io io.files io.ports
io.unix.backend io.unix.sockets io.encodings.ascii io.buffers
io.sockets io.sockets.secure io.sockets.secure.openssl
io.timeouts system summary ;
io.timeouts system summary fry ;
IN: io.unix.sockets.secure
M: ssl-handle handle-fd file>> handle-fd ;
@ -18,9 +18,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
{ -1 [ err_no ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
{ 0 [ premature-close ] }
} case
] [
nip (ssl-error)
] if ;
] [ nip (ssl-error) ] if ;
: check-accept-response ( handle r -- event )
over handle>> over SSL_get_error
@ -36,7 +34,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
: do-ssl-accept ( ssl-handle -- )
dup dup handle>> SSL_accept check-accept-response dup
[ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ;
[ [ dup file>> ] dip wait-for-fd do-ssl-accept ] [ 2drop ] if ;
: maybe-handshake ( ssl-handle -- )
dup connected>> [ drop ] [
@ -130,24 +128,23 @@ M: secure (get-local-address) addrspec>> (get-local-address) ;
[ [ handle>> SSL_get1_session ] dip save-session ]
2bi ;
: secure-connection ( ssl-handle addrspec -- )
dup get-session [ resume-session ] [ begin-session ] ?if ;
: secure-connection ( client-out addrspec -- )
[ handle>> ] dip
[
'[
_ dup get-session
[ resume-session ] [ begin-session ] ?if
] with-timeout
] [ drop t >>connected drop ] 2bi ;
M: secure establish-connection ( client-out remote -- )
addrspec>>
[ establish-connection ]
[
[ handle>> ] dip
[ [ secure-connection ] curry with-timeout ]
[ drop t >>connected drop ]
2bi
] 2bi ;
addrspec>> [ establish-connection ] [ secure-connection ] 2bi ;
M: secure (server) addrspec>> (server) ;
M: secure (accept)
[
addrspec>> (accept) >r |dispose <ssl-socket> r>
addrspec>> (accept) [ |dispose <ssl-socket> ] dip
] with-destructors ;
: check-shutdown-response ( handle r -- event )
@ -172,3 +169,32 @@ M: ssl-handle shutdown
dup connected>> [
f >>connected [ (shutdown) ] with-timeout
] [ drop ] if ;
: check-buffer ( port -- port )
dup buffer>> buffer-empty? [ upgrade-buffers-full ] unless ;
: input/output-ports ( -- input output )
input-stream output-stream
[ get underlying-port check-buffer ] bi@
2dup [ handle>> ] bi@ eq? [ upgrade-on-non-socket ] unless ;
: make-input/output-secure ( input output -- )
dup handle>> fd? [ upgrade-on-non-socket ] unless
[ <ssl-socket> ] change-handle
handle>> >>handle drop ;
: (send-secure-handshake) ( output -- )
remote-address get [ upgrade-on-non-socket ] unless*
secure-connection ;
M: openssl send-secure-handshake
input/output-ports
[ make-input/output-secure ] keep
[ (send-secure-handshake) ] keep
remote-address get dup inet? [
host>> swap handle>> check-certificate
] [ 2drop ] if ;
M: openssl accept-secure-handshake
input/output-ports
make-input/output-secure ;

2
basis/io/unix/sockets/sockets.factor
View File

@ -114,7 +114,7 @@ SYMBOL: receive-buffer
] call ;
M: unix (receive) ( datagram -- packet sockaddr )
dup do-receive dup [ rot drop ] [
dup do-receive dup [ [ drop ] 2dip ] [
2drop [ +input+ wait-for-port ] [ (receive) ] bi
] if ;

3
basis/linked-assocs/linked-assocs.factor
View File

@ -28,9 +28,6 @@ M: linked-assoc set-at
[ 2dup assoc>> key? [ 2dup delete-at ] when add-to-dlist ] 2keep
assoc>> set-at ;
: dlist>seq ( dlist -- seq )
[ ] pusher [ dlist-each ] dip ;
M: linked-assoc >alist
dlist>> dlist>seq ;

Some files were not shown because too many files have changed in this diff Show More