Fix conflicts
commit
f51708386d
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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" } }
|
||||
|
|
|
@ -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*
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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? }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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> %
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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: ;
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ] }
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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\""
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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:
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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,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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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" } ;
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Help lint tool
|
|
@ -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:"
|
||||
|
|
|
@ -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:"
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ] }
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
{
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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"
|
||||
|
||||
|
|
|
@ -39,8 +39,6 @@ ready ;
|
|||
: <threaded-server> ( -- threaded-server )
|
||||
threaded-server new-threaded-server ;
|
||||
|
||||
SYMBOL: remote-address
|
||||
|
||||
GENERIC: handle-client* ( threaded-server -- )
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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 ] }
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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 [
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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' )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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 -- )
|
||||
[
|
||||
[
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
Loading…
Reference in New Issue