Merge branch 'master' of git://github.com/slavapestov/factor
Anton Gorenko
commit
8f297055d6
|
|
@ -154,12 +154,12 @@ solaris-x86-64:
|
|||
$(MAKE) $(ALL) CONFIG=vm/Config.solaris.x86.64
|
||||
|
||||
winnt-x86-32:
|
||||
$(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.32
|
||||
$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.32
|
||||
$(MAKE) $(ALL) CONFIG=vm/Config.windows.x86.32
|
||||
$(MAKE) factor-console CONFIG=vm/Config.windows.x86.32
|
||||
|
||||
winnt-x86-64:
|
||||
$(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.64
|
||||
$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.64
|
||||
$(MAKE) $(ALL) CONFIG=vm/Config.windows.x86.64
|
||||
$(MAKE) factor-console CONFIG=vm/Config.windows.x86.64
|
||||
|
||||
ifdef CONFIG
|
||||
|
||||
|
|
|
|||
|
|
@ -38,16 +38,6 @@ HELP: set-alien-value
|
|||
{ $description "Stores a value at a byte offset from a base C pointer." }
|
||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||
|
||||
HELP: define-deref
|
||||
{ $values { "c-type" "a C type" } }
|
||||
{ $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." }
|
||||
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
|
||||
|
||||
HELP: define-out
|
||||
{ $values { "c-type" "a C type" } }
|
||||
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
|
||||
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
|
||||
|
||||
HELP: char
|
||||
{ $description "This C type represents a one-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ;
|
||||
HELP: uchar
|
||||
|
|
@ -118,43 +108,6 @@ $nl
|
|||
"If this condition is not satisfied, " { $link "malloc" } " must be used instead."
|
||||
{ $warning "Failure to comply with these requirements can lead to crashes, data corruption, and security exploits." } ;
|
||||
|
||||
ARTICLE: "c-out-params" "Output parameters in C"
|
||||
"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
|
||||
$nl
|
||||
"Each numerical C type, together with " { $snippet "void*" } ", has an associated " { $emphasis "out parameter constructor" } " word which takes a Factor object as input, constructs a byte array of the correct size, and converts the Factor object to a C value stored into the byte array:"
|
||||
{ $subsections
|
||||
<char>
|
||||
<uchar>
|
||||
<short>
|
||||
<ushort>
|
||||
<int>
|
||||
<uint>
|
||||
<long>
|
||||
<ulong>
|
||||
<longlong>
|
||||
<ulonglong>
|
||||
<float>
|
||||
<double>
|
||||
<void*>
|
||||
}
|
||||
"You call the out parameter constructor with the required initial value, then pass the byte array to the C function, which receives a pointer to the start of the byte array's data area. The C function then returns, leaving the result in the byte array; you read it back using the next set of words:"
|
||||
{ $subsections
|
||||
*char
|
||||
*uchar
|
||||
*short
|
||||
*ushort
|
||||
*int
|
||||
*uint
|
||||
*long
|
||||
*ulong
|
||||
*longlong
|
||||
*ulonglong
|
||||
*float
|
||||
*double
|
||||
*void*
|
||||
}
|
||||
"Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link <void*> } " and " { $link *void* } " may be used." ;
|
||||
|
||||
ARTICLE: "c-types.primitives" "Primitive C types"
|
||||
"The following numerical types are defined in the " { $vocab-link "alien.c-types" } " vocabulary; a " { $snippet "u" } " prefix denotes an unsigned type:"
|
||||
{ $table
|
||||
|
|
|
|||
|
|
@ -2,16 +2,13 @@ USING: alien alien.syntax alien.c-types alien.parser
|
|||
eval kernel tools.test sequences system libc alien.strings
|
||||
io.encodings.ascii io.encodings.utf8 math.constants classes.struct classes
|
||||
accessors compiler.units ;
|
||||
FROM: alien.c-types => short ;
|
||||
IN: alien.c-types.tests
|
||||
|
||||
CONSTANT: xyz 123
|
||||
|
||||
[ 492 ] [ { int xyz } heap-size ] unit-test
|
||||
|
||||
[ -1 ] [ -1 <char> *char ] unit-test
|
||||
[ -1 ] [ -1 <short> *short ] unit-test
|
||||
[ -1 ] [ -1 <int> *int ] unit-test
|
||||
|
||||
UNION-STRUCT: foo
|
||||
{ a int }
|
||||
{ b int } ;
|
||||
|
|
@ -52,14 +49,6 @@ TYPEDEF: int* MyIntArray
|
|||
|
||||
[ t ] [ void* c-type MyIntArray c-type = ] unit-test
|
||||
|
||||
[
|
||||
0 B{ 1 2 3 4 } <displaced-alien> <void*>
|
||||
] must-fail
|
||||
|
||||
os windows? cpu x86.64? and [
|
||||
[ -2147467259 ] [ 2147500037 <long> *long ] unit-test
|
||||
] when
|
||||
|
||||
[ 0 ] [ -10 uchar c-type-clamp ] unit-test
|
||||
[ 12 ] [ 12 uchar c-type-clamp ] unit-test
|
||||
[ -10 ] [ -10 char c-type-clamp ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,12 +1,9 @@
|
|||
! Copyright (C) 2004, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: byte-arrays arrays assocs delegate kernel kernel.private math
|
||||
math.order math.parser namespaces make parser sequences strings
|
||||
words splitting cpu.architecture alien alien.accessors
|
||||
alien.strings quotations layouts system compiler.units io
|
||||
io.files io.encodings.binary io.streams.memory accessors
|
||||
combinators effects continuations fry classes vocabs
|
||||
vocabs.loader words.symbol macros ;
|
||||
USING: accessors alien alien.accessors arrays byte-arrays
|
||||
classes combinators compiler.units cpu.architecture delegate
|
||||
fry kernel layouts locals macros math math.order quotations
|
||||
sequences system words words.symbol ;
|
||||
QUALIFIED: math
|
||||
IN: alien.c-types
|
||||
|
||||
|
|
@ -21,9 +18,6 @@ SYMBOLS:
|
|||
|
||||
SINGLETON: void
|
||||
|
||||
DEFER: <int>
|
||||
DEFER: *char
|
||||
|
||||
TUPLE: abstract-c-type
|
||||
{ class class initial: object }
|
||||
{ boxed-class class initial: object }
|
||||
|
|
@ -111,8 +105,6 @@ M: c-type-name base-type c-type ;
|
|||
|
||||
M: c-type base-type ;
|
||||
|
||||
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
|
||||
|
||||
GENERIC: heap-size ( name -- size )
|
||||
|
||||
M: abstract-c-type heap-size size>> ;
|
||||
|
|
@ -170,19 +162,6 @@ TUPLE: long-long-type < c-type ;
|
|||
: <long-long-type> ( -- c-type )
|
||||
long-long-type new ;
|
||||
|
||||
: define-deref ( c-type -- )
|
||||
[ name>> CHAR: * prefix "alien.c-types" create ]
|
||||
[ '[ 0 _ alien-value ] ]
|
||||
bi (( c-ptr -- value )) define-inline ;
|
||||
|
||||
: define-out ( c-type -- )
|
||||
[ name>> "alien.c-types" constructor-word ]
|
||||
[ dup '[ _ heap-size (byte-array) [ 0 _ set-alien-value ] keep ] ] bi
|
||||
(( value -- c-ptr )) define-inline ;
|
||||
|
||||
: define-primitive-type ( c-type name -- )
|
||||
[ typedef ] [ define-deref ] [ define-out ] tri ;
|
||||
|
||||
: if-void ( c-type true false -- )
|
||||
pick void? [ drop nip call ] [ nip call ] if ; inline
|
||||
|
||||
|
|
@ -247,7 +226,7 @@ M: pointer c-type
|
|||
[ >c-ptr ] >>unboxer-quot
|
||||
"allot_alien" >>boxer
|
||||
"alien_offset" >>unboxer
|
||||
\ void* define-primitive-type
|
||||
\ void* typedef
|
||||
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
|
|
@ -260,7 +239,7 @@ M: pointer c-type
|
|||
"from_signed_2" >>boxer
|
||||
"to_signed_2" >>unboxer
|
||||
[ >fixnum ] >>unboxer-quot
|
||||
\ short define-primitive-type
|
||||
\ short typedef
|
||||
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
|
|
@ -273,7 +252,7 @@ M: pointer c-type
|
|||
"from_unsigned_2" >>boxer
|
||||
"to_unsigned_2" >>unboxer
|
||||
[ >fixnum ] >>unboxer-quot
|
||||
\ ushort define-primitive-type
|
||||
\ ushort typedef
|
||||
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
|
|
@ -286,7 +265,7 @@ M: pointer c-type
|
|||
"from_signed_1" >>boxer
|
||||
"to_signed_1" >>unboxer
|
||||
[ >fixnum ] >>unboxer-quot
|
||||
\ char define-primitive-type
|
||||
\ char typedef
|
||||
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
|
|
@ -299,7 +278,7 @@ M: pointer c-type
|
|||
"from_unsigned_1" >>boxer
|
||||
"to_unsigned_1" >>unboxer
|
||||
[ >fixnum ] >>unboxer-quot
|
||||
\ uchar define-primitive-type
|
||||
\ uchar typedef
|
||||
|
||||
<c-type>
|
||||
math:float >>class
|
||||
|
|
@ -313,7 +292,7 @@ M: pointer c-type
|
|||
"to_float" >>unboxer
|
||||
float-rep >>rep
|
||||
[ >float ] >>unboxer-quot
|
||||
\ float define-primitive-type
|
||||
\ float typedef
|
||||
|
||||
<c-type>
|
||||
math:float >>class
|
||||
|
|
@ -326,7 +305,7 @@ M: pointer c-type
|
|||
"to_double" >>unboxer
|
||||
double-rep >>rep
|
||||
[ >float ] >>unboxer-quot
|
||||
\ double define-primitive-type
|
||||
\ double typedef
|
||||
|
||||
cell 8 = [
|
||||
<c-type>
|
||||
|
|
@ -340,7 +319,7 @@ M: pointer c-type
|
|||
"from_signed_4" >>boxer
|
||||
"to_signed_4" >>unboxer
|
||||
[ >fixnum ] >>unboxer-quot
|
||||
\ int define-primitive-type
|
||||
\ int typedef
|
||||
|
||||
<c-type>
|
||||
fixnum >>class
|
||||
|
|
@ -353,7 +332,7 @@ M: pointer c-type
|
|||
"from_unsigned_4" >>boxer
|
||||
"to_unsigned_4" >>unboxer
|
||||
[ >fixnum ] >>unboxer-quot
|
||||
\ uint define-primitive-type
|
||||
\ uint typedef
|
||||
|
||||
<c-type>
|
||||
integer >>class
|
||||
|
|
@ -365,7 +344,8 @@ M: pointer c-type
|
|||
8 >>align-first
|
||||
"from_signed_cell" >>boxer
|
||||
"to_fixnum" >>unboxer
|
||||
\ longlong define-primitive-type
|
||||
[ >integer ] >>unboxer-quot
|
||||
\ longlong typedef
|
||||
|
||||
<c-type>
|
||||
integer >>class
|
||||
|
|
@ -377,14 +357,15 @@ M: pointer c-type
|
|||
8 >>align-first
|
||||
"from_unsigned_cell" >>boxer
|
||||
"to_cell" >>unboxer
|
||||
\ ulonglong define-primitive-type
|
||||
[ >integer ] >>unboxer-quot
|
||||
\ ulonglong typedef
|
||||
|
||||
os windows? [
|
||||
\ int c-type \ long define-primitive-type
|
||||
\ uint c-type \ ulong define-primitive-type
|
||||
\ int c-type \ long typedef
|
||||
\ uint c-type \ ulong typedef
|
||||
] [
|
||||
\ longlong c-type \ long define-primitive-type
|
||||
\ ulonglong c-type \ ulong define-primitive-type
|
||||
\ longlong c-type \ long typedef
|
||||
\ ulonglong c-type \ ulong typedef
|
||||
] if
|
||||
|
||||
\ longlong c-type \ ptrdiff_t typedef
|
||||
|
|
@ -403,7 +384,8 @@ M: pointer c-type
|
|||
4 >>align-first
|
||||
"from_signed_cell" >>boxer
|
||||
"to_fixnum" >>unboxer
|
||||
\ int define-primitive-type
|
||||
[ >integer ] >>unboxer-quot
|
||||
\ int typedef
|
||||
|
||||
<c-type>
|
||||
integer >>class
|
||||
|
|
@ -415,7 +397,8 @@ M: pointer c-type
|
|||
4 >>align-first
|
||||
"from_unsigned_cell" >>boxer
|
||||
"to_cell" >>unboxer
|
||||
\ uint define-primitive-type
|
||||
[ >integer ] >>unboxer-quot
|
||||
\ uint typedef
|
||||
|
||||
<long-long-type>
|
||||
integer >>class
|
||||
|
|
@ -426,7 +409,8 @@ M: pointer c-type
|
|||
8-byte-alignment
|
||||
"from_signed_8" >>boxer
|
||||
"to_signed_8" >>unboxer
|
||||
\ longlong define-primitive-type
|
||||
[ >integer ] >>unboxer-quot
|
||||
\ longlong typedef
|
||||
|
||||
<long-long-type>
|
||||
integer >>class
|
||||
|
|
@ -437,10 +421,11 @@ M: pointer c-type
|
|||
8-byte-alignment
|
||||
"from_unsigned_8" >>boxer
|
||||
"to_unsigned_8" >>unboxer
|
||||
\ ulonglong define-primitive-type
|
||||
[ >integer ] >>unboxer-quot
|
||||
\ ulonglong typedef
|
||||
|
||||
\ int c-type \ long define-primitive-type
|
||||
\ uint c-type \ ulong define-primitive-type
|
||||
\ int c-type \ long typedef
|
||||
\ uint c-type \ ulong typedef
|
||||
|
||||
\ int c-type \ ptrdiff_t typedef
|
||||
\ int c-type \ intptr_t typedef
|
||||
|
|
@ -453,7 +438,7 @@ M: pointer c-type
|
|||
[ >c-bool ] >>unboxer-quot
|
||||
[ c-bool> ] >>boxer-quot
|
||||
object >>boxed-class
|
||||
\ bool define-primitive-type
|
||||
\ bool typedef
|
||||
|
||||
] with-compilation-unit
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: alien alien.c-types help.syntax help.markup libc
|
||||
kernel.private byte-arrays math strings hashtables alien.syntax
|
||||
alien.strings sequences io.encodings.string debugger destructors
|
||||
vocabs.loader classes.struct quotations ;
|
||||
vocabs.loader classes.struct quotations kernel ;
|
||||
IN: alien.data
|
||||
|
||||
HELP: <c-array>
|
||||
|
|
@ -10,11 +10,6 @@ HELP: <c-array>
|
|||
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
|
||||
{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
|
||||
|
||||
HELP: <c-object>
|
||||
{ $values { "type" "a C type" } { "array" byte-array } }
|
||||
{ $description "Creates a byte array suitable for holding a value with the given C type." }
|
||||
{ $errors "Throws an " { $link no-c-type } " error if the type does not exist." } ;
|
||||
|
||||
HELP: memory>byte-array
|
||||
{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
|
||||
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
|
||||
|
|
@ -125,6 +120,10 @@ ARTICLE: "c-pointers" "Passing pointers to C functions"
|
|||
{ $warning
|
||||
"The Factor garbage collector can move byte arrays around, and code passing byte arrays, or objects backed by byte arrays, must obey important guidelines. See " { $link "byte-arrays-gc" } "." } ;
|
||||
|
||||
ARTICLE: "c-boxes" "C value boxes"
|
||||
"Sometimes it is useful to create a byte array storing a single C value, like a struct with a single field. A pair of utility macros exist to make this more convenient:"
|
||||
{ $subsections <ref> deref } ;
|
||||
|
||||
ARTICLE: "c-data" "Passing data between Factor and C"
|
||||
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
|
||||
$nl
|
||||
|
|
@ -135,13 +134,12 @@ $nl
|
|||
"malloc"
|
||||
"c-strings"
|
||||
"c-out-params"
|
||||
"c-boxes"
|
||||
}
|
||||
"Important guidelines for passing data in byte arrays:"
|
||||
{ $subsections "byte-arrays-gc" }
|
||||
"C-style enumerated types are supported:"
|
||||
{ $subsections "alien.enums" POSTPONE: ENUM: }
|
||||
"C types can be aliased for convenience and consistency with native library documentation:"
|
||||
{ $subsections POSTPONE: TYPEDEF: }
|
||||
{ $subsections "alien.enums" }
|
||||
"A utility for defining " { $link "destructors" } " for deallocating memory:"
|
||||
{ $subsections "alien.destructors" }
|
||||
"C struct and union types can be defined with " { $link POSTPONE: STRUCT: } " and " { $link POSTPONE: UNION: } ". See " { $link "classes.struct" } " for details. For passing arrays to and from C, use the " { $link "specialized-arrays" } " vocabulary." ;
|
||||
|
|
@ -190,3 +188,20 @@ $nl
|
|||
{ $subsections alien>string }
|
||||
"For example, if a C function returns a " { $link c-string } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "char*" } " and call " { $link (free) } " yourself." ;
|
||||
|
||||
HELP: <ref>
|
||||
{ $values { "value" object } { "c-type" "a C type" } { "c-ptr" c-ptr } }
|
||||
{ $description "Creates a new byte array to store a Factor object as a C value." }
|
||||
{ $examples
|
||||
{ $example "USING: alien.c-types alien.data prettyprint sequences ;" "123 int <ref> length ." "4" }
|
||||
} ;
|
||||
|
||||
HELP: deref
|
||||
{ $values { "c-ptr" c-ptr } { "c-type" "a C type" } { "value" object } }
|
||||
{ $description "Loads a C value from a byte array." }
|
||||
{ $examples
|
||||
{ $example "USING: alien.c-types alien.data prettyprint sequences ;" "321 int <ref> int deref ." "321" }
|
||||
} ;
|
||||
|
||||
ARTICLE: "c-out-params" "Output parameters in C"
|
||||
"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
|
||||
{ $subsection with-out-parameters } ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,32 @@
|
|||
USING: alien alien.c-types alien.data alien.syntax
|
||||
USING: alien alien.data alien.syntax
|
||||
classes.struct kernel sequences specialized-arrays
|
||||
specialized-arrays.private tools.test compiler.units vocabs ;
|
||||
specialized-arrays.private tools.test compiler.units vocabs
|
||||
system ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
IN: alien.data.tests
|
||||
|
||||
STRUCT: foo { a int } { b void* } { c bool } ;
|
||||
[ -1 ] [ -1 c:char <ref> c:char deref ] unit-test
|
||||
[ -1 ] [ -1 c:short <ref> c:short deref ] unit-test
|
||||
[ -1 ] [ -1 c:int <ref> c:int deref ] unit-test
|
||||
|
||||
! I don't care if this throws an error or works, but at least
|
||||
! it should be consistent between platforms
|
||||
[ -1 ] [ -1.0 c:int <ref> c:int deref ] unit-test
|
||||
[ -1 ] [ -1.0 c:long <ref> c:long deref ] unit-test
|
||||
[ -1 ] [ -1.0 c:longlong <ref> c:longlong deref ] unit-test
|
||||
[ 1 ] [ 1.0 c:uint <ref> c:uint deref ] unit-test
|
||||
[ 1 ] [ 1.0 c:ulong <ref> c:ulong deref ] unit-test
|
||||
[ 1 ] [ 1.0 c:ulonglong <ref> c:ulonglong deref ] unit-test
|
||||
|
||||
[
|
||||
0 B{ 1 2 3 4 } <displaced-alien> c:void* <ref>
|
||||
] must-fail
|
||||
|
||||
os windows? cpu x86.64? and [
|
||||
[ -2147467259 ] [ 2147500037 c:long <ref> c:long deref ] unit-test
|
||||
] when
|
||||
|
||||
STRUCT: foo { a c:int } { b c:void* } { c c:bool } ;
|
||||
|
||||
SPECIALIZED-ARRAY: foo
|
||||
|
||||
|
|
|
|||
|
|
@ -7,6 +7,15 @@ stack-checker.dependencies combinators.short-circuit ;
|
|||
QUALIFIED: math
|
||||
IN: alien.data
|
||||
|
||||
: <ref> ( value c-type -- c-ptr )
|
||||
[ heap-size <byte-array> ] keep
|
||||
'[ 0 _ set-alien-value ] keep ; inline
|
||||
|
||||
: deref ( c-ptr c-type -- value )
|
||||
[ 0 ] dip alien-value ; inline
|
||||
|
||||
: little-endian? ( -- ? ) 1 int <ref> char deref 1 = ; foldable
|
||||
|
||||
GENERIC: require-c-array ( c-type -- )
|
||||
|
||||
M: array require-c-array first require-c-array ;
|
||||
|
|
@ -44,15 +53,6 @@ M: pointer <c-direct-array>
|
|||
: malloc-array ( n type -- array )
|
||||
[ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
|
||||
|
||||
: (malloc-array) ( n type -- alien )
|
||||
[ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
|
||||
|
||||
: <c-object> ( type -- array )
|
||||
heap-size <byte-array> ; inline
|
||||
|
||||
: (c-object) ( type -- array )
|
||||
heap-size (byte-array) ; inline
|
||||
|
||||
: malloc-byte-array ( byte-array -- alien )
|
||||
binary-object [ nip malloc dup ] 2keep memcpy ;
|
||||
|
||||
|
|
|
|||
|
|
@ -23,14 +23,6 @@ HELP: number>enum
|
|||
}
|
||||
{ $description "Convert a number to an enum." } ;
|
||||
|
||||
ARTICLE: "alien.enums" "Enumeration types"
|
||||
"The " { $vocab-link "alien.enums" } " vocab contains the implementation for " { $link POSTPONE: ENUM: } " C types, and provides words for converting between enum symbols and integers."
|
||||
$nl
|
||||
"Defining enums at run-time:"
|
||||
{ $subsection define-enum }
|
||||
"Conversions between enums and integers:"
|
||||
{ $subsections enum>number number>enum } ;
|
||||
|
||||
{ POSTPONE: ENUM: define-enum enum>number number>enum } related-words
|
||||
|
||||
ABOUT: "alien.enums"
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ PRIVATE>
|
|||
|
||||
GENERIC: enum>number ( enum -- number ) foldable
|
||||
M: integer enum>number ;
|
||||
M: symbol enum>number "enum-value" word-prop ;
|
||||
M: word enum>number "enum-value" word-prop ;
|
||||
|
||||
<PRIVATE
|
||||
: enum-boxer ( members -- quot )
|
||||
|
|
|
|||
|
|
@ -192,10 +192,10 @@ intel-unix-abi fortran-abi [
|
|||
{
|
||||
[ {
|
||||
[ ascii string>alien ]
|
||||
[ <longlong> ]
|
||||
[ <float> ]
|
||||
[ longlong <ref> ]
|
||||
[ float <ref> ]
|
||||
[ <complex-float> ]
|
||||
[ 1 0 ? <short> ]
|
||||
[ 1 0 ? c:short <ref> ]
|
||||
} spread ]
|
||||
[ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ]
|
||||
} 5 ncleave
|
||||
|
|
@ -211,7 +211,7 @@ intel-unix-abi fortran-abi [
|
|||
[ drop ]
|
||||
[ drop ]
|
||||
[ drop ]
|
||||
[ *float ]
|
||||
[ float deref ]
|
||||
[ drop ]
|
||||
[ drop ]
|
||||
} spread
|
||||
|
|
@ -239,7 +239,7 @@ intel-unix-abi fortran-abi [
|
|||
|
||||
[ [
|
||||
! [<fortran-result>]
|
||||
[ complex-float <c-object> ] 1 ndip
|
||||
[ complex-float heap-size <byte-array> ] 1 ndip
|
||||
! [fortran-args>c-args]
|
||||
{ [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave
|
||||
! [fortran-invoke]
|
||||
|
|
@ -280,7 +280,7 @@ intel-unix-abi fortran-abi [
|
|||
{
|
||||
[ {
|
||||
[ ascii string>alien ]
|
||||
[ <float> ]
|
||||
[ float <ref> ]
|
||||
[ ascii string>alien ]
|
||||
} spread ]
|
||||
[ { [ length ] [ drop ] [ length ] } spread ]
|
||||
|
|
@ -298,7 +298,7 @@ intel-unix-abi fortran-abi [
|
|||
[ ascii alien>nstring ]
|
||||
[ ]
|
||||
[ ascii alien>nstring ]
|
||||
[ *float ]
|
||||
[ float deref ]
|
||||
[ ]
|
||||
[ ascii alien>nstring ]
|
||||
} spread
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
! (c) 2009 Joe Groff, see BSD license
|
||||
USING: accessors alien alien.c-types alien.complex alien.data
|
||||
USING: accessors alien alien.complex alien.c-types alien.data
|
||||
alien.parser grouping alien.strings alien.syntax arrays ascii
|
||||
assocs byte-arrays combinators combinators.short-circuit fry
|
||||
generalizations kernel lexer macros math math.parser namespaces
|
||||
|
|
@ -211,11 +211,11 @@ GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
|
|||
M: integer-type (fortran-arg>c-args)
|
||||
[
|
||||
size>> {
|
||||
{ f [ [ <int> ] [ drop ] ] }
|
||||
{ 1 [ [ <char> ] [ drop ] ] }
|
||||
{ 2 [ [ <short> ] [ drop ] ] }
|
||||
{ 4 [ [ <int> ] [ drop ] ] }
|
||||
{ 8 [ [ <longlong> ] [ drop ] ] }
|
||||
{ f [ [ c:int <ref> ] [ drop ] ] }
|
||||
{ 1 [ [ c:char <ref> ] [ drop ] ] }
|
||||
{ 2 [ [ c:short <ref> ] [ drop ] ] }
|
||||
{ 4 [ [ c:int <ref> ] [ drop ] ] }
|
||||
{ 8 [ [ c:longlong <ref> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case
|
||||
] args?dims ;
|
||||
|
|
@ -226,9 +226,9 @@ M: logical-type (fortran-arg>c-args)
|
|||
M: real-type (fortran-arg>c-args)
|
||||
[
|
||||
size>> {
|
||||
{ f [ [ <float> ] [ drop ] ] }
|
||||
{ 4 [ [ <float> ] [ drop ] ] }
|
||||
{ 8 [ [ <double> ] [ drop ] ] }
|
||||
{ f [ [ c:float <ref> ] [ drop ] ] }
|
||||
{ 4 [ [ c:float <ref> ] [ drop ] ] }
|
||||
{ 8 [ [ c:double <ref> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case
|
||||
] args?dims ;
|
||||
|
|
@ -244,14 +244,14 @@ M: real-complex-type (fortran-arg>c-args)
|
|||
] args?dims ;
|
||||
|
||||
M: double-precision-type (fortran-arg>c-args)
|
||||
[ drop [ <double> ] [ drop ] ] args?dims ;
|
||||
[ drop [ c:double <ref> ] [ drop ] ] args?dims ;
|
||||
|
||||
M: double-complex-type (fortran-arg>c-args)
|
||||
[ drop [ <complex-double> ] [ drop ] ] args?dims ;
|
||||
|
||||
M: character-type (fortran-arg>c-args)
|
||||
fix-character-type single-char?
|
||||
[ [ first <char> ] [ drop ] ]
|
||||
[ [ first c:char <ref> ] [ drop ] ]
|
||||
[ [ ascii string>alien ] [ length ] ] if ;
|
||||
|
||||
M: misc-type (fortran-arg>c-args)
|
||||
|
|
@ -263,23 +263,25 @@ GENERIC: (fortran-result>) ( type -- quots )
|
|||
[ dup dims>> [ drop { [ ] } ] ] dip if ; inline
|
||||
|
||||
M: integer-type (fortran-result>)
|
||||
[ size>> {
|
||||
{ f [ { [ *int ] } ] }
|
||||
{ 1 [ { [ *char ] } ] }
|
||||
{ 2 [ { [ *short ] } ] }
|
||||
{ 4 [ { [ *int ] } ] }
|
||||
{ 8 [ { [ *longlong ] } ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case ] result?dims ;
|
||||
[
|
||||
size>> {
|
||||
{ f [ { [ c:int deref ] } ] }
|
||||
{ 1 [ { [ c:char deref ] } ] }
|
||||
{ 2 [ { [ c:short deref ] } ] }
|
||||
{ 4 [ { [ c:int deref ] } ] }
|
||||
{ 8 [ { [ c:longlong deref ] } ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case
|
||||
] result?dims ;
|
||||
|
||||
M: logical-type (fortran-result>)
|
||||
[ call-next-method first [ zero? not ] append 1array ] result?dims ;
|
||||
|
||||
M: real-type (fortran-result>)
|
||||
[ size>> {
|
||||
{ f [ { [ *float ] } ] }
|
||||
{ 4 [ { [ *float ] } ] }
|
||||
{ 8 [ { [ *double ] } ] }
|
||||
{ f [ { [ c:float deref ] } ] }
|
||||
{ 4 [ { [ c:float deref ] } ] }
|
||||
{ 8 [ { [ c:double deref ] } ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case ] result?dims ;
|
||||
|
||||
|
|
@ -292,14 +294,14 @@ M: real-complex-type (fortran-result>)
|
|||
} case ] result?dims ;
|
||||
|
||||
M: double-precision-type (fortran-result>)
|
||||
[ drop { [ *double ] } ] result?dims ;
|
||||
[ drop { [ c:double deref ] } ] result?dims ;
|
||||
|
||||
M: double-complex-type (fortran-result>)
|
||||
[ drop { [ *complex-double ] } ] result?dims ;
|
||||
|
||||
M: character-type (fortran-result>)
|
||||
fix-character-type single-char?
|
||||
[ { [ *char 1string ] } ]
|
||||
[ { [ c:char deref 1string ] } ]
|
||||
[ { [ ] [ ascii alien>nstring ] } ] if ;
|
||||
|
||||
M: misc-type (fortran-result>)
|
||||
|
|
@ -308,7 +310,7 @@ M: misc-type (fortran-result>)
|
|||
GENERIC: (<fortran-result>) ( type -- quot )
|
||||
|
||||
M: fortran-type (<fortran-result>)
|
||||
(fortran-type>c-type) \ <c-object> [ ] 2sequence ;
|
||||
(fortran-type>c-type) \ heap-size \ <byte-array> [ ] 3sequence ;
|
||||
|
||||
M: character-type (<fortran-result>)
|
||||
fix-character-type dims>> product dup
|
||||
|
|
@ -425,8 +427,11 @@ MACRO: fortran-invoke ( return library function parameters -- )
|
|||
{ [ 2drop nip set-fortran-abi ] [ (fortran-invoke) ] } 4 ncleave ;
|
||||
|
||||
: parse-arglist ( parameters return -- types effect )
|
||||
[ 2 group unzip [ "," ?tail drop ] map ]
|
||||
[ [ { } ] [ 1array ] if-void ]
|
||||
[
|
||||
2 group
|
||||
[ unzip [ "," ?tail drop ] map ]
|
||||
[ [ first "!" head? ] filter [ second "," ?tail drop "'" append ] map ] bi
|
||||
] [ [ ] [ prefix ] if-void ]
|
||||
bi* <effect> ;
|
||||
|
||||
:: define-fortran-function ( return library function parameters -- )
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: alien.libraries alien.syntax tools.test kernel ;
|
||||
USING: alien alien.libraries alien.syntax tools.test kernel ;
|
||||
IN: alien.libraries.tests
|
||||
|
||||
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
|
||||
|
|
@ -8,3 +8,21 @@ IN: alien.libraries.tests
|
|||
[ ] [ "doesnotexist" dlopen dlclose ] unit-test
|
||||
|
||||
[ "fdasfsf" dll-valid? drop ] must-fail
|
||||
|
||||
[ t ] [
|
||||
"test-library" "blah" cdecl add-library
|
||||
"test-library" "BLAH" cdecl add-library?
|
||||
"blah" remove-library
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
"test-library" "blah" cdecl add-library
|
||||
"test-library" "blah" stdcall add-library?
|
||||
"blah" remove-library
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
"test-library" "blah" cdecl add-library
|
||||
"test-library" "blah" cdecl add-library?
|
||||
"blah" remove-library
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.strings assocs io.backend
|
||||
kernel namespaces destructors sequences strings
|
||||
system io.pathnames ;
|
||||
system io.pathnames fry ;
|
||||
IN: alien.libraries
|
||||
|
||||
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
|
||||
|
|
@ -32,9 +32,15 @@ M: library dispose dll>> [ dispose ] when* ;
|
|||
: remove-library ( name -- )
|
||||
libraries get delete-at* [ dispose ] [ drop ] if ;
|
||||
|
||||
: add-library? ( name path abi -- ? )
|
||||
[ library ] 2dip
|
||||
'[ [ path>> _ = ] [ abi>> _ = ] bi and not ] [ t ] if* ;
|
||||
|
||||
: add-library ( name path abi -- )
|
||||
[ 2drop remove-library ]
|
||||
[ <library> swap libraries get set-at ] 3bi ;
|
||||
3dup add-library? [
|
||||
[ 2drop remove-library ]
|
||||
[ <library> swap libraries get set-at ] 3bi
|
||||
] [ 3drop ] if ;
|
||||
|
||||
: library-abi ( library -- abi )
|
||||
library [ abi>> ] [ cdecl ] if* ;
|
||||
|
|
|
|||
|
|
@ -123,3 +123,13 @@ HELP: C-GLOBAL:
|
|||
{ $syntax "C-GLOBAL: type name" }
|
||||
{ $values { "type" "a C type" } { "name" "a C global variable name" } }
|
||||
{ $description "Defines a new word named " { $snippet "name" } " which accesses a global variable in the current library, set with " { $link POSTPONE: LIBRARY: } "." } ;
|
||||
|
||||
ARTICLE: "alien.enums" "Enumeration types"
|
||||
"The " { $vocab-link "alien.enums" } " vocab contains the implementation for " { $link POSTPONE: ENUM: } " C types, and provides words for converting between enum singletons and integers. It is possible to dispatch off of members of an enum."
|
||||
$nl
|
||||
"Defining enums:"
|
||||
{ $subsection POSTPONE: ENUM: }
|
||||
"Defining enums at run-time:"
|
||||
{ $subsection define-enum }
|
||||
"Conversions between enums and integers:"
|
||||
{ $subsections enum>number number>enum } ;
|
||||
|
|
|
|||
|
|
@ -18,10 +18,10 @@ HELP: once-at
|
|||
|
||||
HELP: >biassoc
|
||||
{ $values { "assoc" assoc } { "biassoc" biassoc } }
|
||||
{ $description "Costructs a new biassoc with the same key/value pairs as the given assoc." } ;
|
||||
{ $description "Constructs a new biassoc with the same key/value pairs as the given assoc." } ;
|
||||
|
||||
ARTICLE: "biassocs" "Bidirectional assocs"
|
||||
"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc opeartions (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time."
|
||||
"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc operations (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time."
|
||||
$nl
|
||||
"Bidirectional assocs implement the entire " { $link "assocs-protocol" } " with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with."
|
||||
$nl
|
||||
|
|
|
|||
|
|
@ -64,3 +64,8 @@ IN: bit-sets.tests
|
|||
|
||||
[ T{ bit-set f ?{ f } } T{ bit-set f ?{ t } } ]
|
||||
[ 1 <bit-set> dup clone 0 over adjoin ] unit-test
|
||||
|
||||
[ 0 ] [ T{ bit-set f ?{ } } cardinality ] unit-test
|
||||
[ 0 ] [ T{ bit-set f ?{ f f f f } } cardinality ] unit-test
|
||||
[ 1 ] [ T{ bit-set f ?{ f t f f } } cardinality ] unit-test
|
||||
[ 2 ] [ T{ bit-set f ?{ f t f t } } cardinality ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences byte-arrays bit-arrays math hints sets ;
|
||||
USING: kernel accessors sequences byte-arrays bit-arrays math
|
||||
math.bitwise hints sets ;
|
||||
IN: bit-sets
|
||||
|
||||
TUPLE: bit-set { table bit-array read-only } ;
|
||||
|
|
@ -14,19 +15,21 @@ M: bit-set in?
|
|||
over integer? [ table>> ?nth ] [ 2drop f ] if ; inline
|
||||
|
||||
M: bit-set adjoin
|
||||
! This is allowed to crash when the elt couldn't go in the set
|
||||
! This is allowed to throw an error when the elt couldn't
|
||||
! go in the set
|
||||
[ t ] 2dip table>> set-nth ;
|
||||
|
||||
M: bit-set delete
|
||||
! This isn't allowed to crash if the elt wasn't in the set
|
||||
! This isn't allowed to throw an error if the elt wasn't
|
||||
! in the set
|
||||
over integer? [
|
||||
table>> 2dup bounds-check? [
|
||||
[ f ] 2dip set-nth
|
||||
] [ 2drop ] if
|
||||
] [ 2drop ] if ;
|
||||
|
||||
! If you do binary set operations with a bitset, it's expected
|
||||
! that the other thing can also be represented as a bitset
|
||||
! If you do binary set operations with a bit-set, it's expected
|
||||
! that the other thing can also be represented as a bit-set
|
||||
! of the same length.
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -70,7 +73,8 @@ M: bit-set members
|
|||
<PRIVATE
|
||||
|
||||
: bit-set-like ( set bit-set -- bit-set' )
|
||||
! This crashes if there are keys that can't be put in the bit set
|
||||
! Throws an error if there are keys that can't be put
|
||||
! in the bit set
|
||||
over bit-set? [ 2dup [ table>> length ] bi@ = ] [ f ] if
|
||||
[ drop ] [
|
||||
[ members ] dip table>> length <bit-set>
|
||||
|
|
@ -84,3 +88,6 @@ M: bit-set set-like
|
|||
|
||||
M: bit-set clone
|
||||
table>> clone bit-set boa ;
|
||||
|
||||
M: bit-set cardinality
|
||||
table>> bit-count ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,50 @@
|
|||
USING: cache tools.test accessors destructors kernel assocs
|
||||
namespaces ;
|
||||
IN: cache.tests
|
||||
|
||||
TUPLE: mock-disposable < disposable n ;
|
||||
|
||||
: <mock-disposable> ( n -- mock-disposable )
|
||||
mock-disposable new-disposable swap >>n ;
|
||||
|
||||
M: mock-disposable dispose* drop ;
|
||||
|
||||
[ ] [ <cache-assoc> "cache" set ] unit-test
|
||||
|
||||
[ 0 ] [ "cache" get assoc-size ] unit-test
|
||||
|
||||
[ ] [ "cache" get 2 >>max-age drop ] unit-test
|
||||
|
||||
[ ] [ 1 <mock-disposable> dup "a" set 2 "cache" get set-at ] unit-test
|
||||
|
||||
[ 1 ] [ "cache" get assoc-size ] unit-test
|
||||
|
||||
[ ] [ "cache" get purge-cache ] unit-test
|
||||
|
||||
[ ] [ 2 <mock-disposable> 3 "cache" get set-at ] unit-test
|
||||
|
||||
[ 2 ] [ "cache" get assoc-size ] unit-test
|
||||
|
||||
[ ] [ "cache" get purge-cache ] unit-test
|
||||
|
||||
[ 1 ] [ "cache" get assoc-size ] unit-test
|
||||
|
||||
[ ] [ 3 <mock-disposable> dup "b" set 4 "cache" get set-at ] unit-test
|
||||
|
||||
[ 2 ] [ "cache" get assoc-size ] unit-test
|
||||
|
||||
[ ] [ "cache" get purge-cache ] unit-test
|
||||
|
||||
[ 1 ] [ "cache" get assoc-size ] unit-test
|
||||
|
||||
[ f ] [ 2 "cache" get key? ] unit-test
|
||||
|
||||
[ 3 ] [ 4 "cache" get at n>> ] unit-test
|
||||
|
||||
[ t ] [ "a" get disposed>> ] unit-test
|
||||
|
||||
[ f ] [ "b" get disposed>> ] unit-test
|
||||
|
||||
[ ] [ "cache" get clear-assoc ] unit-test
|
||||
|
||||
[ t ] [ "b" get disposed>> ] unit-test
|
||||
|
|
@ -25,19 +25,21 @@ M: cache-assoc set-at
|
|||
[ <cache-entry> ] 2dip
|
||||
assoc>> set-at ;
|
||||
|
||||
M: cache-assoc clear-assoc assoc>> clear-assoc ;
|
||||
M: cache-assoc clear-assoc
|
||||
[ assoc>> values dispose-each ]
|
||||
[ assoc>> clear-assoc ]
|
||||
bi ;
|
||||
|
||||
M: cache-assoc >alist assoc>> [ value>> ] { } assoc-map-as ;
|
||||
|
||||
INSTANCE: cache-assoc assoc
|
||||
|
||||
M: cache-assoc dispose*
|
||||
[ values dispose-each ] [ clear-assoc ] bi ;
|
||||
M: cache-assoc dispose* clear-assoc ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: purge-cache ( cache -- )
|
||||
dup max-age>> '[
|
||||
[ nip [ 1 + ] change-age age>> _ >= ] assoc-partition
|
||||
[ values dispose-each ] dip
|
||||
[ nip [ 1 + ] change-age age>> _ < ] assoc-partition
|
||||
values dispose-each
|
||||
] change-assoc drop ;
|
||||
|
|
|
|||
|
|
@ -5,10 +5,10 @@ math.order ;
|
|||
IN: calendar
|
||||
|
||||
HELP: duration
|
||||
{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two durations with the " { $link <=> } " word." } ;
|
||||
{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two durations with the " { $link <=> } " word." } ;
|
||||
|
||||
HELP: timestamp
|
||||
{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two durations with the " { $link <=> } " word." } ;
|
||||
{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two durations with the " { $link <=> } " word." } ;
|
||||
|
||||
{ timestamp duration } related-words
|
||||
|
||||
|
|
@ -33,7 +33,7 @@ HELP: month-names
|
|||
|
||||
HELP: month-name
|
||||
{ $values { "obj" { $or integer timestamp } } { "string" string } }
|
||||
{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ;
|
||||
{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ;
|
||||
|
||||
HELP: month-abbreviations
|
||||
{ $values { "value" array } }
|
||||
|
|
@ -42,7 +42,7 @@ HELP: month-abbreviations
|
|||
|
||||
HELP: month-abbreviation
|
||||
{ $values { "n" integer } { "string" string } }
|
||||
{ $description "Looks up the abbreviated month name and returns it as a string. January has an index of 1 instead of zero." } ;
|
||||
{ $description "Looks up the abbreviated month name and returns it as a string. January has an index of 1 instead of zero." } ;
|
||||
|
||||
|
||||
HELP: day-names
|
||||
|
|
@ -55,7 +55,7 @@ HELP: day-name
|
|||
|
||||
HELP: day-abbreviations2
|
||||
{ $values { "value" array } }
|
||||
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ;
|
||||
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ;
|
||||
|
||||
HELP: day-abbreviation2
|
||||
{ $values { "n" integer } { "string" string } }
|
||||
|
|
@ -63,7 +63,7 @@ HELP: day-abbreviation2
|
|||
|
||||
HELP: day-abbreviations3
|
||||
{ $values { "value" array } }
|
||||
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ;
|
||||
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ;
|
||||
|
||||
HELP: day-abbreviation3
|
||||
{ $values { "n" integer } { "string" string } }
|
||||
|
|
@ -101,7 +101,7 @@ HELP: seconds-per-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." }
|
||||
{ $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." }
|
||||
{ $warning "Not valid before year -4800 BCE." } ;
|
||||
|
||||
HELP: julian-day-number>date
|
||||
|
|
@ -340,7 +340,7 @@ HELP: >gmt
|
|||
|
||||
HELP: time*
|
||||
{ $values { "obj1" object } { "obj2" object } { "obj3" object } }
|
||||
{ $description "Multiplies each time slot of a timestamp or duration by a number and make a new duration from the result. Used in the implementation of " { $link before } "." } ;
|
||||
{ $description "Multiplies each time slot of a timestamp or duration by a number and make a new duration from the result. Used in the implementation of " { $link before } "." } ;
|
||||
{ time+ time- time* } related-words
|
||||
|
||||
HELP: before
|
||||
|
|
@ -355,7 +355,7 @@ HELP: before
|
|||
|
||||
HELP: <zero>
|
||||
{ $values { "timestamp" timestamp } }
|
||||
{ $description "Returns a zero timestamp that consists of zeros for every slot. Used to see if timestamps are valid." } ;
|
||||
{ $description "Returns a zero timestamp that consists of zeros for every slot. Used to see if timestamps are valid." } ;
|
||||
|
||||
HELP: valid-timestamp?
|
||||
{ $values { "timestamp" timestamp } { "?" "a boolean" } }
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.syntax arrays calendar
|
||||
kernel math unix unix.time unix.types namespaces system
|
||||
USING: alien alien.c-types alien.data alien.syntax arrays
|
||||
calendar kernel math unix unix.time unix.types namespaces system
|
||||
accessors classes.struct ;
|
||||
IN: calendar.unix
|
||||
|
||||
|
|
@ -21,7 +21,7 @@ IN: calendar.unix
|
|||
timespec>duration since-1970 ;
|
||||
|
||||
: get-time ( -- alien )
|
||||
f time <time_t> localtime ;
|
||||
f time time_t <ref> localtime ;
|
||||
|
||||
: timezone-name ( -- string )
|
||||
get-time zone>> ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2006, 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types kernel io io.binary io.files io.streams.byte-array math
|
||||
math.functions math.parser namespaces splitting grouping strings
|
||||
sequences byte-arrays locals sequences.private macros fry
|
||||
io.encodings.binary math.bitwise checksums accessors
|
||||
checksums.common checksums.stream combinators combinators.smart
|
||||
specialized-arrays literals hints ;
|
||||
USING: alien.c-types alien.data kernel io io.binary io.files
|
||||
io.streams.byte-array math math.functions math.parser namespaces
|
||||
splitting grouping strings sequences byte-arrays locals
|
||||
sequences.private macros fry io.encodings.binary math.bitwise
|
||||
checksums accessors checksums.common checksums.stream
|
||||
combinators combinators.smart specialized-arrays literals hints ;
|
||||
SPECIALIZED-ARRAY: uint
|
||||
IN: checksums.md5
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
! Copyright (C) 2010 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: colors help.markup help.syntax strings ;
|
||||
|
||||
IN: colors.hex
|
||||
|
||||
HELP: hex>rgba
|
||||
{ $values { "hex" string } { "rgba" color } }
|
||||
{ $description "Converts a hexadecimal string value into a " { $link color } "." }
|
||||
;
|
||||
|
||||
HELP: rgba>hex
|
||||
{ $values { "rgba" color } { "hex" string } }
|
||||
{ $description "Converts a " { $link color } " into a hexadecimal string value." }
|
||||
;
|
||||
|
||||
HELP: HEXCOLOR:
|
||||
{ $syntax "HEXCOLOR: value" }
|
||||
{ $description "Parses as a " { $link color } " object with the given hexadecimal value." }
|
||||
{ $examples
|
||||
{ $code
|
||||
"USING: colors.hex io.styles ;"
|
||||
"\"Hello!\" { { foreground HEXCOLOR: 336699 } } format nl"
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "colors.hex" "HEX colors"
|
||||
"The " { $vocab-link "colors.hex" } " vocabulary implements colors specified "
|
||||
"by their hexidecimal value."
|
||||
{ $subsections
|
||||
hex>rgba
|
||||
rgba>hex
|
||||
POSTPONE: HEXCOLOR:
|
||||
}
|
||||
{ $see-also "colors" } ;
|
||||
|
||||
ABOUT: "colors.hex"
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
! Copyright (C) 2010 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: colors colors.hex tools.test ;
|
||||
|
||||
IN: colors.hex.test
|
||||
|
||||
[ HEXCOLOR: 000000 ] [ 0.0 0.0 0.0 1.0 <rgba> ] unit-test
|
||||
[ HEXCOLOR: FFFFFF ] [ 1.0 1.0 1.0 1.0 <rgba> ] unit-test
|
||||
[ HEXCOLOR: abcdef ] [ "abcdef" hex>rgba ] unit-test
|
||||
[ HEXCOLOR: abcdef ] [ "ABCDEF" hex>rgba ] unit-test
|
||||
[ "ABCDEF" ] [ HEXCOLOR: abcdef rgba>hex ] unit-test
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2010 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: accessors colors formatting grouping kernel lexer math
|
||||
math.parser sequences ;
|
||||
|
||||
IN: colors.hex
|
||||
|
||||
: hex>rgba ( hex -- rgba )
|
||||
2 group [ hex> 255 /f ] map first3 1.0 <rgba> ;
|
||||
|
||||
: rgba>hex ( rgba -- hex )
|
||||
[ red>> ] [ green>> ] [ blue>> ] tri
|
||||
[ 255 * >integer ] tri@ "%02X%02X%02X" sprintf ;
|
||||
|
||||
SYNTAX: HEXCOLOR: scan hex>rgba suffix! ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Hexadecimal colors
|
||||
|
|
@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces
|
|||
sequences tools.test namespaces.private slots.private
|
||||
sequences.private byte-arrays alien alien.accessors layouts
|
||||
words definitions compiler.units io combinators vectors grouping
|
||||
make alien.c-types combinators.short-circuit math.order
|
||||
make alien.c-types alien.data combinators.short-circuit math.order
|
||||
math.libm math.parser math.functions alien.syntax memory
|
||||
stack-checker ;
|
||||
FROM: math => float ;
|
||||
|
|
@ -275,7 +275,8 @@ M: cucumber equal? "The cucumber has no equal" throw ;
|
|||
|
||||
[ 4294967295 B{ 255 255 255 255 } -1 ]
|
||||
[
|
||||
-1 <int> -1 <int>
|
||||
-1 int <ref>
|
||||
-1 int <ref>
|
||||
[ [ 0 alien-unsigned-4 swap ] [ 0 alien-signed-2 ] bi ]
|
||||
compile-call
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -6,6 +6,8 @@ sbufs strings.private slots.private alien math.order
|
|||
alien.accessors alien.c-types alien.data alien.syntax alien.strings
|
||||
namespaces libc io.encodings.ascii classes compiler.test ;
|
||||
FROM: math => float ;
|
||||
FROM: alien.c-types => short ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
IN: compiler.tests.intrinsics
|
||||
|
||||
! Make sure that intrinsic ops compile to correct code.
|
||||
|
|
@ -429,46 +431,46 @@ ERROR: bug-in-fixnum* x y a b ;
|
|||
[ ] [ "hello world" ascii malloc-string "s" set ] unit-test
|
||||
|
||||
"s" get [
|
||||
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call ascii alien>string ] unit-test
|
||||
[ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call ascii alien>string ] unit-test
|
||||
[ "hello world" ] [ "s" get void* <ref> [ { byte-array } declare void* deref ] compile-call ascii alien>string ] unit-test
|
||||
[ "hello world" ] [ "s" get void* <ref> [ { c-ptr } declare void* deref ] compile-call ascii alien>string ] unit-test
|
||||
|
||||
[ ] [ "s" get free ] unit-test
|
||||
] when
|
||||
|
||||
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare <void*> ] compile-call *void* ] unit-test
|
||||
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare <void*> ] compile-call *void* ] unit-test
|
||||
[ f ] [ f [ { POSTPONE: f } declare <void*> ] compile-call *void* ] unit-test
|
||||
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare void* <ref> ] compile-call void* deref ] unit-test
|
||||
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare void* <ref> ] compile-call void* deref ] unit-test
|
||||
[ f ] [ f [ { POSTPONE: f } declare void* <ref> ] compile-call void* deref ] unit-test
|
||||
|
||||
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
|
||||
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
|
||||
|
||||
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
|
||||
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
|
||||
[ -100 ] [ -100 char <ref> [ { byte-array } declare char deref ] compile-call ] unit-test
|
||||
[ 156 ] [ -100 uchar <ref> [ { byte-array } declare uchar deref ] compile-call ] unit-test
|
||||
|
||||
[ -100 ] [ -100 \ <char> def>> [ { fixnum } declare ] prepend compile-call *char ] unit-test
|
||||
[ 156 ] [ -100 \ <uchar> def>> [ { fixnum } declare ] prepend compile-call *uchar ] unit-test
|
||||
[ -100 ] [ -100 [ char <ref> ] [ { fixnum } declare ] prepend compile-call char deref ] unit-test
|
||||
[ 156 ] [ -100 [ uchar <ref> ] [ { fixnum } declare ] prepend compile-call uchar deref ] unit-test
|
||||
|
||||
[ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-call ] unit-test
|
||||
[ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-call ] unit-test
|
||||
[ -1000 ] [ -1000 short <ref> [ { byte-array } declare short deref ] compile-call ] unit-test
|
||||
[ 64536 ] [ -1000 ushort <ref> [ { byte-array } declare ushort deref ] compile-call ] unit-test
|
||||
|
||||
[ -1000 ] [ -1000 \ <short> def>> [ { fixnum } declare ] prepend compile-call *short ] unit-test
|
||||
[ 64536 ] [ -1000 \ <ushort> def>> [ { fixnum } declare ] prepend compile-call *ushort ] unit-test
|
||||
[ -1000 ] [ -1000 [ short <ref> ] [ { fixnum } declare ] prepend compile-call short deref ] unit-test
|
||||
[ 64536 ] [ -1000 [ ushort <ref> ] [ { fixnum } declare ] prepend compile-call ushort deref ] unit-test
|
||||
|
||||
[ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-call ] unit-test
|
||||
[ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-call ] unit-test
|
||||
[ -100000 ] [ -100000 int <ref> [ { byte-array } declare int deref ] compile-call ] unit-test
|
||||
[ 4294867296 ] [ -100000 uint <ref> [ { byte-array } declare uint deref ] compile-call ] unit-test
|
||||
|
||||
[ -100000 ] [ -100000 \ <int> def>> [ { fixnum } declare ] prepend compile-call *int ] unit-test
|
||||
[ 4294867296 ] [ -100000 \ <uint> def>> [ { fixnum } declare ] prepend compile-call *uint ] unit-test
|
||||
[ -100000 ] [ -100000 [ int <ref> ] [ { fixnum } declare ] prepend compile-call int deref ] unit-test
|
||||
[ 4294867296 ] [ -100000 [ uint <ref> ] [ { fixnum } declare ] prepend compile-call uint deref ] unit-test
|
||||
|
||||
[ t ] [ pi pi <double> *double = ] unit-test
|
||||
[ t ] [ pi pi double <ref> double deref = ] unit-test
|
||||
|
||||
[ t ] [ pi <double> [ { byte-array } declare *double ] compile-call pi = ] unit-test
|
||||
[ t ] [ pi double <ref> [ { byte-array } declare double deref ] compile-call pi = ] unit-test
|
||||
|
||||
! Silly
|
||||
[ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-call ] keep *float pi - -0.001 0.001 between? ] unit-test
|
||||
[ t ] [ pi <float> [ { byte-array } declare *float ] compile-call pi - -0.001 0.001 between? ] unit-test
|
||||
[ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-call ] keep c:float deref pi - -0.001 0.001 between? ] unit-test
|
||||
[ t ] [ pi c:float <ref> [ { byte-array } declare c:float deref ] compile-call pi - -0.001 0.001 between? ] unit-test
|
||||
|
||||
[ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-call ] keep *double pi = ] unit-test
|
||||
[ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-call ] keep double deref pi = ] unit-test
|
||||
|
||||
[ 4 ] [
|
||||
2 B{ 1 2 3 4 5 6 } <displaced-alien> [
|
||||
|
|
@ -532,12 +534,14 @@ ERROR: bug-in-fixnum* x y a b ;
|
|||
] compile-call
|
||||
] unit-test
|
||||
|
||||
! These tests must fail because we're not allowed to store
|
||||
! a pointer to a byte array inside of an alien object
|
||||
[
|
||||
B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
|
||||
B{ 0 0 0 0 } [ { byte-array } declare void* <ref> ] compile-call
|
||||
] must-fail
|
||||
|
||||
[
|
||||
B{ 0 0 0 0 } [ { c-ptr } declare <void*> ] compile-call
|
||||
B{ 0 0 0 0 } [ { c-ptr } declare void* <ref> ] compile-call
|
||||
] must-fail
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
USING: tools.test kernel.private kernel arrays sequences
|
||||
math.private math generic words quotations alien alien.c-types
|
||||
strings sbufs sequences.private slots.private combinators
|
||||
definitions system layouts vectors math.partial-dispatch
|
||||
math.order math.functions accessors hashtables classes assocs
|
||||
io.encodings.utf8 io.encodings.ascii io.encodings fry slots
|
||||
sorting.private combinators.short-circuit grouping prettyprint
|
||||
generalizations
|
||||
alien.data strings sbufs sequences.private slots.private
|
||||
combinators definitions system layouts vectors
|
||||
math.partial-dispatch math.order math.functions accessors
|
||||
hashtables classes assocs io.encodings.utf8 io.encodings.ascii
|
||||
io.encodings fry slots sorting.private combinators.short-circuit
|
||||
grouping prettyprint generalizations
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.cleanup
|
||||
|
|
@ -17,6 +17,7 @@ compiler.tree.propagation.info
|
|||
compiler.tree.checker
|
||||
compiler.tree.debugger ;
|
||||
FROM: math => float ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
IN: compiler.tree.cleanup.tests
|
||||
|
||||
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
|
||||
|
|
@ -244,22 +245,22 @@ cell-bits 32 = [
|
|||
] when
|
||||
|
||||
[ t ] [
|
||||
[ B{ 1 0 } *short 0 number= ]
|
||||
[ B{ 1 0 } c:short deref 0 number= ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ B{ 1 0 } *short 0 { number number } declare number= ]
|
||||
[ B{ 1 0 } c:short deref 0 { number number } declare number= ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ B{ 1 0 } *short 0 = ]
|
||||
[ B{ 1 0 } c:short deref 0 = ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
|
||||
[ B{ 1 0 } c:short deref dup number? [ 0 number= ] [ drop f ] if ]
|
||||
\ number= inlined?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -520,8 +521,6 @@ cell-bits 32 = [
|
|||
] cleaned-up-tree nodes>quot
|
||||
] unit-test
|
||||
|
||||
USING: alien alien.c-types ;
|
||||
|
||||
[ t ] [
|
||||
[ int { } cdecl [ 2 2 + ] alien-callback ]
|
||||
{ + } inlined?
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.syntax byte-arrays combinators
|
||||
kernel math math.functions sequences system accessors
|
||||
libc ;
|
||||
USING: alien alien.c-types alien.data alien.syntax byte-arrays
|
||||
combinators kernel math math.functions sequences system
|
||||
accessors libc ;
|
||||
QUALIFIED: compression.zlib.ffi
|
||||
IN: compression.zlib
|
||||
|
||||
|
|
@ -36,15 +36,15 @@ ERROR: zlib-failed n string ;
|
|||
|
||||
: compress ( byte-array -- compressed )
|
||||
[
|
||||
[ compressed-size <byte-array> dup length <ulong> ] keep [
|
||||
[ compressed-size <byte-array> dup length ulong <ref> ] keep [
|
||||
dup length compression.zlib.ffi:compress zlib-error
|
||||
] 3keep drop *ulong head
|
||||
] 3keep drop ulong deref head
|
||||
] keep length <compressed> ;
|
||||
|
||||
: uncompress ( compressed -- byte-array )
|
||||
[
|
||||
length>> [ <byte-array> ] keep <ulong> 2dup
|
||||
length>> [ <byte-array> ] keep ulong <ref> 2dup
|
||||
] [
|
||||
data>> dup length
|
||||
compression.zlib.ffi:uncompress zlib-error
|
||||
] bi *ulong head ;
|
||||
] bi ulong deref head ;
|
||||
|
|
|
|||
|
|
@ -43,6 +43,6 @@ $nl
|
|||
parallel-spread
|
||||
parallel-napply
|
||||
}
|
||||
"The " { $vocab-link "concurrency.semaphores" } " vocabulary can be used in conjuction with the above combinators to limit the maximum number of concurrent operations." ;
|
||||
"The " { $vocab-link "concurrency.semaphores" } " vocabulary can be used in conjunction with the above combinators to limit the maximum number of concurrent operations." ;
|
||||
|
||||
ABOUT: "concurrency.combinators"
|
||||
|
|
|
|||
|
|
@ -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 fry ;
|
||||
concurrency.mailboxes accessors fry ;
|
||||
IN: concurrency.count-downs
|
||||
|
||||
! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ CONSTANT: test-ip "127.0.0.1"
|
|||
: test-node-client ( -- addrspec )
|
||||
{
|
||||
{ [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
|
||||
{ [ os windows? ] [ test-ip insecure-port <inet4> ] }
|
||||
{ [ os windows? ] [ insecure-addr ] }
|
||||
} cond ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ ARTICLE: "concurrency.locks.rw" "Read-write locks"
|
|||
$nl
|
||||
"While this can be achieved with a simple " { $link "concurrency.locks.mutex" } ", performance will suffer, since in fact multiple threads can view the structure at the same time; serialization must only be enforced for writes."
|
||||
$nl
|
||||
"Read/write locks allow any number of threads to hold the read lock simulateneously, however attempting to acquire a write lock blocks until all other threads release read locks and write locks."
|
||||
"Read/write locks allow any number of threads to hold the read lock simultaneously, however attempting to acquire a write lock blocks until all other threads release read locks and write locks."
|
||||
$nl
|
||||
"Read/write locks are reentrant. A thread holding a write lock may acquire a read lock or a write lock without blocking. However a thread holding a read lock may not acquire a write lock recursively since that could break invariants assumed by the code executing with the read lock held."
|
||||
{ $subsections
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: debugger accessors debugger.threads kernel
|
||||
concurrency.mailboxes ;
|
||||
IN: concurrency.mailboxes.debugger
|
||||
|
||||
M: linked-error error.
|
||||
[ thread>> error-in-thread. ] [ error>> error. ] bi ;
|
||||
|
|
@ -2,8 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: dlists deques threads sequences continuations namespaces
|
||||
math quotations words kernel arrays assocs init system
|
||||
concurrency.conditions accessors debugger debugger.threads
|
||||
locals fry ;
|
||||
concurrency.conditions accessors locals fry vocabs.loader ;
|
||||
IN: concurrency.mailboxes
|
||||
|
||||
TUPLE: mailbox { threads dlist } { data dlist } ;
|
||||
|
|
@ -77,9 +76,6 @@ M: mailbox mailbox-get-timeout block-if-empty data>> pop-back ;
|
|||
|
||||
TUPLE: linked-error error thread ;
|
||||
|
||||
M: linked-error error.
|
||||
[ thread>> error-in-thread. ] [ error>> error. ] bi ;
|
||||
|
||||
C: <linked-error> linked-error
|
||||
|
||||
: ?linked ( message -- message )
|
||||
|
|
@ -95,3 +91,5 @@ M: linked-thread error-in-thread
|
|||
|
||||
: spawn-linked-to ( quot name mailbox -- thread )
|
||||
<linked-thread> [ (spawn) ] keep ;
|
||||
|
||||
{ "concurrency.mailboxes" "debugger" } "concurrency.mailboxes.debugger" require-when
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ HELP: send
|
|||
{ $values { "message" object }
|
||||
{ "thread" thread }
|
||||
}
|
||||
{ $description "Send the message to the thread by placing it in the threads mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." }
|
||||
{ $description "Send the message to the thread by placing it in the threads mailbox. This is an asynchronous operation and will return immediately. The receiving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." }
|
||||
{ $see-also receive receive-if } ;
|
||||
|
||||
HELP: receive
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types alien.syntax kernel math core-foundation ;
|
||||
USING: alien.c-types alien.data alien.syntax kernel math
|
||||
core-foundation ;
|
||||
FROM: math => float ;
|
||||
IN: core-foundation.numbers
|
||||
|
||||
|
|
@ -30,14 +31,14 @@ FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType th
|
|||
GENERIC: <CFNumber> ( number -- alien )
|
||||
|
||||
M: integer <CFNumber>
|
||||
[ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
|
||||
[ f kCFNumberLongLongType ] dip longlong <ref> CFNumberCreate ;
|
||||
|
||||
M: float <CFNumber>
|
||||
[ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
|
||||
[ f kCFNumberDoubleType ] dip double <ref> CFNumberCreate ;
|
||||
|
||||
M: t <CFNumber>
|
||||
drop f kCFNumberIntType 1 <int> CFNumberCreate ;
|
||||
drop f kCFNumberIntType 1 int <ref> CFNumberCreate ;
|
||||
|
||||
M: f <CFNumber>
|
||||
drop f kCFNumberIntType 0 <int> CFNumberCreate ;
|
||||
drop f kCFNumberIntType 0 int <ref> CFNumberCreate ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.destructors alien.syntax accessors
|
||||
destructors fry kernel math math.bitwise sequences libc colors
|
||||
images images.memory core-graphics.types core-foundation.utilities
|
||||
opengl.gl literals ;
|
||||
USING: alien alien.c-types alien.data alien.destructors
|
||||
alien.syntax accessors destructors fry kernel math math.bitwise
|
||||
sequences libc colors images images.memory core-graphics.types
|
||||
core-foundation.utilities opengl.gl literals ;
|
||||
IN: core-graphics
|
||||
|
||||
TYPEDEF: int CGImageAlphaInfo
|
||||
|
|
|
|||
|
|
@ -1,15 +1,16 @@
|
|||
! Copyright (C) 2009, 2010 Joe Groff, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types arrays assocs combinators fry kernel locals
|
||||
USING: alien.data arrays assocs combinators fry kernel locals
|
||||
macros math math.vectors namespaces quotations sequences system
|
||||
compiler.cfg.comparisons compiler.cfg.intrinsics
|
||||
compiler.codegen.fixup cpu.architecture cpu.x86
|
||||
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86.features ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
IN: cpu.x86.sse
|
||||
|
||||
! Scalar floating point with SSE2
|
||||
M: x86 %load-float <float> float-rep %load-vector ;
|
||||
M: x86 %load-double <double> double-rep %load-vector ;
|
||||
M: x86 %load-float c:float <ref> float-rep %load-vector ;
|
||||
M: x86 %load-double c:double <ref> double-rep %load-vector ;
|
||||
|
||||
M: float-rep copy-register* drop MOVAPS ;
|
||||
M: double-rep copy-register* drop MOVAPS ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types combinators kernel locals system namespaces
|
||||
compiler.codegen.fixup compiler.constants
|
||||
USING: alien.c-types alien.data combinators kernel locals system
|
||||
namespaces compiler.codegen.fixup compiler.constants
|
||||
compiler.cfg.comparisons compiler.cfg.intrinsics
|
||||
cpu.architecture cpu.x86 cpu.x86.assembler
|
||||
cpu.x86.assembler.operands ;
|
||||
|
|
@ -38,12 +38,12 @@ M: double-rep copy-memory* copy-memory-x87 ;
|
|||
|
||||
M: x86 %load-float
|
||||
0 [] FLDS
|
||||
<float> rc-absolute rel-binary-literal
|
||||
float <ref> rc-absolute rel-binary-literal
|
||||
shuffle-down FSTP ;
|
||||
|
||||
M: x86 %load-double
|
||||
0 [] FLDL
|
||||
<double> rc-absolute rel-binary-literal
|
||||
double <ref> rc-absolute rel-binary-literal
|
||||
shuffle-down FSTP ;
|
||||
|
||||
:: binary-op ( dst src1 src2 quot -- )
|
||||
|
|
|
|||
|
|
@ -271,24 +271,21 @@ ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial"
|
|||
{ $subsections sql-query }
|
||||
"Here's an example usage where we'll make a book table, insert some objects, and query them." $nl
|
||||
"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
|
||||
{ $code """
|
||||
USING: db.sqlite db io.files io.files.temp ;
|
||||
{ $code """USING: db.sqlite db io.files io.files.temp ;
|
||||
: with-book-db ( quot -- )
|
||||
"book.db" temp-file <sqlite-db> swap with-db ; inline" }
|
||||
"book.db" temp-file <sqlite-db> swap with-db ; inline""" }
|
||||
"Now let's create the table manually:"
|
||||
{ $code " "create table books
|
||||
{ $code """"create table books
|
||||
(id integer primary key, title text, author text, date_published timestamp,
|
||||
edition integer, cover_price double, condition text)"
|
||||
[ sql-command ] with-book-db""" }
|
||||
"Time to insert some books:"
|
||||
{ $code """
|
||||
"insert into books
|
||||
{ $code """"insert into books
|
||||
(title, author, date_published, edition, cover_price, condition)
|
||||
values('Factor for Sheeple', 'Mister Stacky Pants', date('now'), 1, 13.37, 'mint')"
|
||||
[ sql-command ] with-book-db""" }
|
||||
"Now let's select the book:"
|
||||
{ $code """
|
||||
"select id, title, cover_price from books;" [ sql-query ] with-book-db""" }
|
||||
{ $code """"select id, title, cover_price from books;" [ sql-query ] with-book-db""" }
|
||||
"Notice that the result of this query is a Factor array containing the database rows as arrays of strings. We would have to convert the " { $snippet "cover_price" } " from a string to a number in order to use it in a calculation." $nl
|
||||
"In conclusion, this method of accessing a database is supported, but it is fairly low-level and generally specific to a single database. The " { $vocab-link "db.tuples" } " vocabulary is a good alternative to writing SQL by hand." ;
|
||||
|
||||
|
|
@ -298,8 +295,7 @@ ARTICLE: "db-custom-database-combinators" "Custom database combinators"
|
|||
"Make a " { $snippet "with-" } " combinator to open and close a database so that resources are not leaked." $nl
|
||||
|
||||
"SQLite example combinator:"
|
||||
{ $code """
|
||||
USING: db.sqlite db io.files io.files.temp ;
|
||||
{ $code """USING: db.sqlite db io.files io.files.temp ;
|
||||
: with-sqlite-db ( quot -- )
|
||||
"my-database.db" temp-file <sqlite-db> swap with-db ; inline""" }
|
||||
|
||||
|
|
|
|||
|
|
@ -70,14 +70,13 @@ HELP: define-persistent
|
|||
{ "the name of a database column that maps to the slot" } { "a database type (see " { $link "db.types" } ")" }
|
||||
} "Throws an error if the slot name (column one from each row) is not a slot in the tuple or its superclases." }
|
||||
{ $examples
|
||||
{ $unchecked-example "USING: db.tuples db.types ;"
|
||||
{ $code "USING: db.tuples db.types ;"
|
||||
"TUPLE: boat id year name ;"
|
||||
"boat \"BOAT\" {"
|
||||
" { \"id\" \"ID\" +db-assigned-id+ }"
|
||||
" { \"year\" \"YEAR\" INTEGER }"
|
||||
" { \"name\" \"NAME\" TEXT }"
|
||||
"} define-persistent"
|
||||
""
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
@ -233,8 +232,7 @@ T{ book
|
|||
{ date-published T{ timestamp { year 2009 } { month 3 } { day 3 } } }
|
||||
{ edition 1 }
|
||||
{ cover-price 13.37 }
|
||||
} book set
|
||||
""" }
|
||||
} book set""" }
|
||||
"Now we've created a book. Let's save it to the database."
|
||||
{ $code """USING: db db.sqlite fry io.files.temp ;
|
||||
: with-book-tutorial ( quot -- )
|
||||
|
|
@ -243,8 +241,7 @@ T{ book
|
|||
[
|
||||
book recreate-table
|
||||
book get insert-tuple
|
||||
] with-book-tutorial
|
||||
""" }
|
||||
] with-book-tutorial""" }
|
||||
"Is it really there?"
|
||||
{ $code """[
|
||||
T{ book { title "Factor for Sheeple" } } select-tuples .
|
||||
|
|
|
|||
|
|
@ -117,7 +117,7 @@ HELP: signal-error.
|
|||
{ "8 - Arithmetic exception. Most likely a divide by zero in " { $link /i } "." }
|
||||
{ "10, 11 - Memory protection fault. This error suggests invalid values are being passed to C functions by an " { $link alien-invoke } ". Factor also uses memory protection to trap stack underflows and overflows, but usually these are reported as their own errors. Sometimes they'll show up as a generic signal 11, though." }
|
||||
}
|
||||
"The Windows equivalent of a signal 11 is a SEH fault. When one occurs, the runtime throws a singal error, even though it does not correspond to a Unix signal."
|
||||
"The Windows equivalent of a signal 11 is a SEH fault. When one occurs, the runtime throws a signal error, even though it does not correspond to a Unix signal."
|
||||
} ;
|
||||
|
||||
HELP: array-size-error.
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types namespaces io.binary fry
|
||||
USING: alien.c-types alien.data namespaces io.binary fry
|
||||
kernel math grouping sequences math.bitwise ;
|
||||
IN: endian
|
||||
|
||||
SINGLETONS: big-endian little-endian ;
|
||||
|
||||
: compute-native-endianness ( -- class )
|
||||
1 <int> *char 0 = big-endian little-endian ? ;
|
||||
1 int <ref> char deref 0 = big-endian little-endian ? ;
|
||||
|
||||
SYMBOL: native-endianness
|
||||
native-endianness [ compute-native-endianness ] initialize
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ M: unix set-os-env ( value key -- ) swap 1 setenv io-error ;
|
|||
M: unix unset-os-env ( key -- ) unsetenv io-error ;
|
||||
|
||||
M: unix (os-envs) ( -- seq )
|
||||
environ *void* utf8 alien>strings ;
|
||||
environ void* deref utf8 alien>strings ;
|
||||
|
||||
: set-void* ( value alien -- ) 0 set-alien-cell ;
|
||||
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ $nl
|
|||
{ $code
|
||||
"""USING: eval listener vocabs.parser ;
|
||||
[
|
||||
"cad-objects" use-vocab
|
||||
"cad.objects" use-vocab
|
||||
(( -- seq )) (eval)
|
||||
] with-interactive-vocabs"""
|
||||
}
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@ ERROR: ftp-error got expected ;
|
|||
strings>> first "|" split 2 tail* first string>number ;
|
||||
|
||||
: open-passive-client ( url protocol -- stream )
|
||||
[ host>> ftp-epsv parse-epsv <inet> ] dip <client> drop ;
|
||||
[ url-addr ftp-epsv parse-epsv with-port ] dip <client> drop ;
|
||||
|
||||
: list ( url -- ftp-response )
|
||||
utf8 open-passive-client
|
||||
|
|
@ -84,7 +84,7 @@ ERROR: ftp-error got expected ;
|
|||
ftp-set-binary 200 ftp-assert ;
|
||||
|
||||
: ftp-connect ( url -- stream )
|
||||
[ host>> ] [ port>> ] bi <inet> utf8 <client> drop ;
|
||||
url-addr utf8 <client> drop ;
|
||||
|
||||
: with-ftp-client ( url quot -- )
|
||||
[ [ ftp-connect ] keep ] dip
|
||||
|
|
|
|||
|
|
@ -17,11 +17,8 @@ CONSTANT: test-file-contents "Files are so boring anymore."
|
|||
'[
|
||||
current-temporary-directory get
|
||||
0 <ftp-server> [
|
||||
insecure-port
|
||||
<url>
|
||||
swap >>port
|
||||
"ftp://localhost" >url insecure-addr set-url-addr
|
||||
"ftp" >>protocol
|
||||
"localhost" >>host
|
||||
create-test-file >>path
|
||||
@
|
||||
] with-threaded-server
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ HELP: <action>
|
|||
|
||||
HELP: <chloe-content>
|
||||
{ $values
|
||||
{ "pair" "a pair with shape " { $snippet "{ class string }" } }
|
||||
{ "path" "a path" }
|
||||
{ "response" response }
|
||||
}
|
||||
{ $description "Creates an HTTP response which serves a Chloe template. See " { $link "html.templates.chloe" } "." } ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (c) 2008 Slava Pestov
|
||||
! Copyright (c) 2008, 2010 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs namespaces kernel sequences sets
|
||||
destructors combinators fry logging
|
||||
io.encodings.utf8 io.encodings.string io.binary random
|
||||
checksums checksums.sha urls
|
||||
destructors combinators fry logging io.encodings.utf8
|
||||
io.encodings.string io.binary io.sockets.secure random checksums
|
||||
checksums.sha urls
|
||||
html.forms
|
||||
http.server
|
||||
http.server.filters
|
||||
|
|
@ -79,7 +79,7 @@ GENERIC: logged-in-username ( realm -- username )
|
|||
swap >>default
|
||||
users-in-db >>users
|
||||
sha-256 >>checksum
|
||||
t >>secure ; inline
|
||||
ssl-supported? >>secure ; inline
|
||||
|
||||
: users ( -- provider )
|
||||
realm get users>> ;
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ M: recaptcha call-responder*
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: (render-recaptcha) ( private-key -- xml )
|
||||
: (render-recaptcha) ( url -- xml )
|
||||
dup
|
||||
[XML
|
||||
<script type="text/javascript"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors combinators namespaces fry urls urls.secure
|
||||
http http.server http.server.redirection http.server.responses
|
||||
USING: kernel accessors combinators namespaces fry urls http
|
||||
http.server http.server.redirection http.server.responses
|
||||
http.server.remapping http.server.filters furnace.utilities ;
|
||||
IN: furnace.redirection
|
||||
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
USING: accessors alien alien.c-types alien.strings arrays assocs
|
||||
byte-arrays combinators combinators.short-circuit continuations
|
||||
game.input game.input.dinput.keys-array io.encodings.utf16
|
||||
io.encodings.utf16n kernel locals math math.bitwise
|
||||
math.rectangles namespaces parser sequences shuffle
|
||||
USING: accessors alien alien.c-types alien.data alien.strings
|
||||
arrays assocs byte-arrays combinators combinators.short-circuit
|
||||
continuations game.input game.input.dinput.keys-array
|
||||
io.encodings.utf16 io.encodings.utf16n kernel locals math
|
||||
math.bitwise math.rectangles namespaces parser sequences shuffle
|
||||
specialized-arrays ui.backend.windows vectors windows.com
|
||||
windows.directx.dinput windows.directx.dinput.constants
|
||||
windows.kernel32 windows.messages windows.ole32 windows.errors
|
||||
windows.user32 classes.struct alien.data ;
|
||||
windows.user32 classes.struct ;
|
||||
SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA
|
||||
IN: game.input.dinput
|
||||
|
||||
|
|
@ -23,15 +23,15 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
|||
|
||||
: create-dinput ( -- )
|
||||
f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
|
||||
f <void*> [ f DirectInput8Create ole32-error ] keep *void*
|
||||
f void* <ref> [ f DirectInput8Create ole32-error ] keep void* deref
|
||||
+dinput+ set-global ;
|
||||
|
||||
: delete-dinput ( -- )
|
||||
+dinput+ [ com-release f ] change-global ;
|
||||
|
||||
: device-for-guid ( guid -- device )
|
||||
+dinput+ get-global swap f <void*>
|
||||
[ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
|
||||
+dinput+ get-global swap f void* <ref>
|
||||
[ f IDirectInput8W::CreateDevice ole32-error ] keep void* deref ;
|
||||
|
||||
: set-coop-level ( device -- )
|
||||
+device-change-window+ get-global DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
|
||||
|
|
@ -303,8 +303,8 @@ CONSTANT: pov-values
|
|||
} 2cleave ;
|
||||
|
||||
: read-device-buffer ( device buffer count -- buffer count' )
|
||||
[ DIDEVICEOBJECTDATA heap-size ] 2dip <uint>
|
||||
[ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
|
||||
[ DIDEVICEOBJECTDATA heap-size ] 2dip uint <ref>
|
||||
[ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep uint deref ;
|
||||
|
||||
: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
|
||||
[ dwData>> 32 >signed ] [ dwOfs>> ] bi {
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ ARTICLE: "grouping" "Groups and clumps"
|
|||
"{ 1 2 3 4 } dup" "2 <groups> concat sequence= ." "t"
|
||||
}
|
||||
}
|
||||
{ "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
|
||||
{ "With clumps, collecting the first element of each subsequence but the last one, together with the last subsequence, yields the original sequence:"
|
||||
{ $unchecked-example
|
||||
"USING: grouping ;"
|
||||
"{ 1 2 3 4 } 2 clump ." "{ { 1 2 } { 2 3 } { 3 4 } }"
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@ $nl
|
|||
$nl
|
||||
"Some generic words have " { $strong "Description" } " headings, and others have " { $strong "Contract" } " headings. A distinction is made between words which are not intended to be extended with user-defined methods, and those that are."
|
||||
{ $heading "Vocabulary naming conventions" }
|
||||
"A vocabulary name ending in " { $snippet ".private" } " contains words which are either implementation details, unsafe, or both. For example, the " { $snippet "sequence.private" } " vocabulary contains words which access sequence elements without bounds checking (" { $link "sequences-unsafe" } "). You should avoid using private words from the Factor library unless absolutely necessary. Similarly, your own code can place words in private vocabularies using " { $link POSTPONE: <PRIVATE } " if you do not want other people using them without good reason."
|
||||
"A vocabulary name ending in " { $snippet ".private" } " contains words which are either implementation details, unsafe, or both. For example, the " { $snippet "sequences.private" } " vocabulary contains words which access sequence elements without bounds checking (" { $link "sequences-unsafe" } "). You should avoid using private words from the Factor library unless absolutely necessary. Similarly, your own code can place words in private vocabularies using " { $link POSTPONE: <PRIVATE } " if you do not want other people using them without good reason."
|
||||
{ $heading "Word naming conventions" }
|
||||
"These conventions are not hard and fast, but are usually a good first step in understanding a word's behavior:"
|
||||
{ $table
|
||||
|
|
|
|||
|
|
@ -476,7 +476,8 @@ HELP: HELP:
|
|||
{ $description "Defines documentation for a word." }
|
||||
{ $examples
|
||||
{ $code
|
||||
": foo 2 + ;"
|
||||
"USING: help help.markup help.syntax math ;"
|
||||
": foo ( m -- n ) 2 + ;"
|
||||
"HELP: foo"
|
||||
"{ $values { \"m\" \"an integer\" } { \"n\" \"an integer\" } }"
|
||||
"{ $description \"Increments a value by 2.\" } ;"
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ $nl
|
|||
ARTICLE: "first-program-logic" "Writing some logic in your first program"
|
||||
"Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:"
|
||||
{ $code
|
||||
"! Copyright (C) 2009 <your name here>"
|
||||
"! Copyright (C) 2011 <your name here>"
|
||||
"! See http://factorcode.org/license.txt for BSD license."
|
||||
"USING: ;"
|
||||
"IN: palindrome"
|
||||
|
|
@ -127,7 +127,7 @@ $nl
|
|||
"Finally, pass the string and the quotation to the " { $link filter } " word:"
|
||||
{ $code "filter" }
|
||||
"Now the stack should contain the following string:"
|
||||
{ "\"AmanaplanacanalPanama\"" }
|
||||
{ "\"AmanaplanacanalPanama\"" } ". "
|
||||
"This is almost what we want; we just need to convert the string to lower case now. This can be done by calling " { $link >lower } "; the " { $snippet ">" } " prefix is a naming convention for conversion operations, and should be read as “to”:"
|
||||
{ $code ">lower" }
|
||||
"Finally, let's print the top of the stack and discard it:"
|
||||
|
|
|
|||
|
|
@ -24,20 +24,25 @@ HELP: HINTS:
|
|||
{ $description "Defines specialization hints for a word or a method."
|
||||
$nl
|
||||
"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:"
|
||||
{ $code
|
||||
"GENERIC: count-occurrences ( elt obj -- n )"
|
||||
""
|
||||
"M: sequence count-occurrences [ = ] with count ;"
|
||||
""
|
||||
"M: assoc count-occurrences"
|
||||
" swap [ = nip ] curry assoc-filter assoc-size ;"
|
||||
""
|
||||
"HINTS: M\ sequence count-occurrences { object array } ;"
|
||||
"HINTS: M\ assoc count-occurrences { object hashtable } ;"
|
||||
}
|
||||
{ $examples
|
||||
"The " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
|
||||
{ $code
|
||||
"USING: arrays hints sequences strings ;"
|
||||
"HINTS: append { string string } { array array } ;"
|
||||
}
|
||||
"Specializers can also be defined on methods:"
|
||||
{ $code
|
||||
"USING: assocs hashtables hints kernel sequences ;"
|
||||
"GENERIC: count-occurrences ( elt obj -- n )"
|
||||
""
|
||||
"M: sequence count-occurrences [ = ] with count ;"
|
||||
""
|
||||
"M: assoc count-occurrences"
|
||||
" swap [ = nip ] curry assoc-filter assoc-size ;"
|
||||
""
|
||||
"HINTS: M\\ sequence count-occurrences { object array } ;"
|
||||
"HINTS: M\\ assoc count-occurrences { object hashtable } ;"
|
||||
}
|
||||
} ;
|
||||
|
||||
ABOUT: "hints"
|
||||
|
|
|
|||
|
|
@ -3,9 +3,9 @@
|
|||
USING: accessors arrays assocs byte-arrays byte-vectors classes
|
||||
combinators definitions effects fry generic generic.single
|
||||
generic.standard hashtables io.binary io.encodings
|
||||
io.streams.string kernel kernel.private math
|
||||
math.integers.private math.parser namespaces parser sbufs
|
||||
sequences splitting splitting.private strings vectors words ;
|
||||
io.streams.string kernel kernel.private math math.parser
|
||||
namespaces parser sbufs sequences splitting splitting.private
|
||||
strings vectors words ;
|
||||
IN: hints
|
||||
|
||||
GENERIC: specializer-predicate ( spec -- quot )
|
||||
|
|
@ -130,6 +130,4 @@ M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-pr
|
|||
|
||||
M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop
|
||||
|
||||
\ bignum/f { { bignum bignum } { bignum fixnum } { fixnum bignum } { fixnum fixnum } } "specializer" set-word-prop
|
||||
|
||||
\ encode-string { string object object } "specializer" set-word-prop
|
||||
|
|
|
|||
|
|
@ -84,13 +84,13 @@ ARTICLE: "html.templates.chloe.tags.boilerplate" "Boilerplate Chloe tags"
|
|||
$nl
|
||||
"The tags marked with (*) are only available if the " { $vocab-link "furnace.chloe-tags" } " vocabulary is loaded."
|
||||
{ $table
|
||||
{ { $snippet "t:title" } "Sets the title from a child template" }
|
||||
{ { $snippet "t:write-title" } "Renders the child's title from a master template" }
|
||||
{ { $snippet "t:style" } "Adds CSS markup from a child template" }
|
||||
{ { $snippet "t:write-style" } "Renders the children's CSS from a master template" }
|
||||
{ { $snippet "t:atom" } "Adds an Atom feed link from a child template (*)" }
|
||||
{ { $snippet "t:write-atom" } "Renders the children's list of Atom feed links (*)" }
|
||||
{ { $snippet "t:call-next-template" } "Calls the child template from a master template" }
|
||||
{ { $snippet "t:title" } "Sets the title. Intended for use in a master template." }
|
||||
{ { $snippet "t:write-title" } "Renders the child's title. Intended for use in a child template." }
|
||||
{ { $snippet "t:style" } { "Adds CSS markup from the file named by the " { $snippet "t:include" } " attribute. Intended for use in a child template." } }
|
||||
{ { $snippet "t:write-style" } "Renders the children's CSS markup. Intended for use in a master template." }
|
||||
{ { $snippet "t:atom" } { "Adds an Atom feed link. The attributes are the same as the " { $snippet "t:link" } " tag. Intended for use in a child template. (*)" } }
|
||||
{ { $snippet "t:write-atom" } "Renders the children's list of Atom feed links. Intended for use in a master template. (*)" }
|
||||
{ { $snippet "t:call-next-template" } "Calls the next child template from a master template." }
|
||||
} ;
|
||||
|
||||
ARTICLE: "html.templates.chloe.tags.control" "Control-flow Chloe tags"
|
||||
|
|
|
|||
|
|
@ -129,7 +129,7 @@ ARTICLE: "http.client.errors" "HTTP client errors"
|
|||
ARTICLE: "http.client" "HTTP client"
|
||||
"The " { $vocab-link "http.client" } " vocabulary implements an HTTP and HTTPS client on top of " { $link "http" } "."
|
||||
$nl
|
||||
"For HTTPS support, you must load the " { $vocab-link "urls.secure" } " vocab first. If you don't need HTTPS support, don't load " { $vocab-link "urls.secure" } "; this will reduce the size of images generated by " { $vocab-link "tools.deploy" } "."
|
||||
"For HTTPS support, you must load the " { $vocab-link "io.sockets.secure" } " vocab first. If you don't need HTTPS support, don't load " { $vocab-link "io.sockets.secure" } "; this will reduce the size of images generated by " { $vocab-link "tools.deploy" } "."
|
||||
$nl
|
||||
"There are two primary usage patterns, data retrieval with GET requests and form submission with POST requests:"
|
||||
{ $subsections
|
||||
|
|
@ -139,7 +139,7 @@ $nl
|
|||
}
|
||||
"Submission data for POST and PUT requests:"
|
||||
{ $subsections "http.client.post-data" }
|
||||
"More esoteric use-cases, for example HTTP methods other than the above, are accomodated by constructing an empty request object with " { $link <request> } " and filling everything in by hand."
|
||||
"More esoteric use-cases, for example HTTP methods other than the above, are accommodated by constructing an empty request object with " { $link <request> } " and filling everything in by hand."
|
||||
{ $subsections
|
||||
"http.client.encoding"
|
||||
"http.client.errors"
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ multiline io.streams.string io.encodings.utf8 io.encodings.8-bit
|
|||
io.encodings.binary io.encodings.string io.encodings.ascii kernel
|
||||
arrays splitting sequences assocs io.sockets db db.sqlite
|
||||
continuations urls hashtables accessors namespaces xml.data
|
||||
io.encodings.8-bit.latin1 random ;
|
||||
io.encodings.8-bit.latin1 random combinators.short-circuit ;
|
||||
IN: http.tests
|
||||
|
||||
[ "text/plain" "UTF-8" ] [ "text/plain" parse-content-type ] unit-test
|
||||
|
|
@ -16,6 +16,8 @@ IN: http.tests
|
|||
|
||||
[ "localhost" f ] [ "localhost" parse-host ] unit-test
|
||||
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
|
||||
[ "::1" 8888 ] [ "::1:8888" parse-host ] unit-test
|
||||
[ "127.0.0.1" 8888 ] [ "127.0.0.1:8888" parse-host ] unit-test
|
||||
|
||||
[ "localhost" ] [ T{ url { protocol "http" } { host "localhost" } } unparse-host ] unit-test
|
||||
[ "localhost" ] [ T{ url { protocol "http" } { host "localhost" } { port 80 } } unparse-host ] unit-test
|
||||
|
|
@ -219,12 +221,6 @@ http.server.dispatchers db.tuples ;
|
|||
|
||||
: test-db ( -- db ) test-db-file <sqlite-db> ;
|
||||
|
||||
[ test-db-file delete-file ] ignore-errors
|
||||
|
||||
test-db [
|
||||
init-furnace-tables
|
||||
] with-db
|
||||
|
||||
: test-httpd ( responder -- )
|
||||
[
|
||||
main-responder set
|
||||
|
|
@ -232,16 +228,25 @@ test-db [
|
|||
0 >>insecure
|
||||
f >>secure
|
||||
start-server
|
||||
servers>> random addr>> port>>
|
||||
] with-scope "port" set ;
|
||||
threaded-server set
|
||||
server-addrs random
|
||||
] with-scope "addr" set ;
|
||||
|
||||
: add-port ( url -- url' )
|
||||
>url clone "port" get >>port ;
|
||||
: add-addr ( url -- url' )
|
||||
>url clone "addr" get set-url-addr ;
|
||||
|
||||
: stop-test-httpd ( -- )
|
||||
"http://localhost/quit" add-port http-get nip
|
||||
"http://localhost/quit" add-addr http-get nip
|
||||
"Goodbye" assert= ;
|
||||
|
||||
[ ] [
|
||||
[ test-db-file delete-file ] ignore-errors
|
||||
|
||||
test-db [
|
||||
init-furnace-tables
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
<dispatcher>
|
||||
add-quit-action
|
||||
|
|
@ -257,14 +262,14 @@ test-db [
|
|||
|
||||
[ t ] [
|
||||
"vocab:http/test/foo.html" ascii file-contents
|
||||
"http://localhost/nested/foo.html" add-port http-get nip =
|
||||
"http://localhost/nested/foo.html" add-addr http-get nip =
|
||||
] unit-test
|
||||
|
||||
[ "http://localhost/redirect-loop" add-port http-get nip ]
|
||||
[ "http://localhost/redirect-loop" add-addr http-get nip ]
|
||||
[ too-many-redirects? ] must-fail-with
|
||||
|
||||
[ "Goodbye" ] [
|
||||
"http://localhost/quit" add-port http-get nip
|
||||
"http://localhost/quit" add-addr http-get nip
|
||||
] unit-test
|
||||
|
||||
! HTTP client redirect bug
|
||||
|
|
@ -278,7 +283,7 @@ test-db [
|
|||
] unit-test
|
||||
|
||||
[ "Goodbye" ] [
|
||||
"http://localhost/redirect" add-port http-get nip
|
||||
"http://localhost/redirect" add-addr http-get nip
|
||||
] unit-test
|
||||
|
||||
|
||||
|
|
@ -302,15 +307,20 @@ test-db [
|
|||
test-httpd
|
||||
] unit-test
|
||||
|
||||
: 404? ( response -- ? ) [ download-failed? ] [ response>> code>> 404 = ] bi and ;
|
||||
: 404? ( response -- ? )
|
||||
{
|
||||
[ download-failed? ]
|
||||
[ response>> response? ]
|
||||
[ response>> code>> 404 = ]
|
||||
} 1&& ;
|
||||
|
||||
! This should give a 404 not an infinite redirect loop
|
||||
[ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with
|
||||
[ "http://localhost/d/blah" add-addr http-get nip ] [ 404? ] must-fail-with
|
||||
|
||||
! This should give a 404 not an infinite redirect loop
|
||||
[ "http://localhost/blah/" add-port http-get nip ] [ 404? ] must-fail-with
|
||||
[ "http://localhost/blah/" add-addr http-get nip ] [ 404? ] must-fail-with
|
||||
|
||||
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
|
||||
[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
|
||||
|
||||
[ ] [
|
||||
<dispatcher>
|
||||
|
|
@ -324,9 +334,9 @@ test-db [
|
|||
test-httpd
|
||||
] unit-test
|
||||
|
||||
[ "Hi" ] [ "http://localhost/" add-port http-get nip ] unit-test
|
||||
[ "Hi" ] [ "http://localhost/" add-addr http-get nip ] unit-test
|
||||
|
||||
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
|
||||
[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
|
||||
|
||||
USING: html.components html.forms
|
||||
xml xml.traversal validators
|
||||
|
|
@ -356,7 +366,7 @@ SYMBOL: a
|
|||
string>xml body>> "input" deep-tag-named "value" attr ;
|
||||
|
||||
[ "3" ] [
|
||||
"http://localhost/" add-port http-get
|
||||
"http://localhost/" add-addr http-get
|
||||
swap dup cookies>> "cookies" set session-id-key get-cookie
|
||||
value>> "session-id" set test-a
|
||||
] unit-test
|
||||
|
|
@ -364,10 +374,10 @@ SYMBOL: a
|
|||
[ "4" ] [
|
||||
[
|
||||
"4" "a" set
|
||||
"http://localhost" add-port "__u" set
|
||||
"http://localhost" add-addr "__u" set
|
||||
"session-id" get session-id-key set
|
||||
] H{ } make-assoc
|
||||
"http://localhost/" add-port <post-request> "cookies" get >>cookies http-request nip test-a
|
||||
"http://localhost/" add-addr <post-request> "cookies" get >>cookies http-request nip test-a
|
||||
] unit-test
|
||||
|
||||
[ 4 ] [ a get-global ] unit-test
|
||||
|
|
@ -376,15 +386,15 @@ SYMBOL: a
|
|||
[ "xyz" ] [
|
||||
[
|
||||
"xyz" "a" set
|
||||
"http://localhost" add-port "__u" set
|
||||
"http://localhost" add-addr "__u" set
|
||||
"session-id" get session-id-key set
|
||||
] H{ } make-assoc
|
||||
"http://localhost/" add-port <post-request> "cookies" get >>cookies http-request nip test-a
|
||||
"http://localhost/" add-addr <post-request> "cookies" get >>cookies http-request nip test-a
|
||||
] unit-test
|
||||
|
||||
[ 4 ] [ a get-global ] unit-test
|
||||
|
||||
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
|
||||
[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
|
||||
|
||||
! Test cloning
|
||||
[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
|
||||
|
|
@ -402,7 +412,7 @@ SYMBOL: a
|
|||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
"http://localhost/" add-port http-get nip
|
||||
"http://localhost/" add-addr http-get nip
|
||||
"vocab:http/test/foo.html" ascii file-contents =
|
||||
] unit-test
|
||||
|
||||
|
|
@ -424,12 +434,12 @@ SYMBOL: a
|
|||
test-httpd
|
||||
] unit-test
|
||||
|
||||
[ "OK" ] [ "data" "http://localhost/a" add-port http-post nip ] unit-test
|
||||
[ "OK" ] [ "data" "http://localhost/a" add-addr http-post nip ] unit-test
|
||||
|
||||
! Check that download throws errors (reported by Chris Double)
|
||||
[
|
||||
"resource:temp" [
|
||||
"http://localhost/tweet_my_twat" add-port download
|
||||
"http://localhost/tweet_my_twat" add-addr download
|
||||
] with-directory
|
||||
] must-fail
|
||||
|
||||
|
|
@ -443,6 +453,6 @@ SYMBOL: a
|
|||
test-httpd
|
||||
] unit-test
|
||||
|
||||
[ "OK\n\n" ] [ "http://localhost/" add-port http-get nip ] unit-test
|
||||
[ "OK\n\n" ] [ "http://localhost/" add-addr http-get nip ] unit-test
|
||||
|
||||
[ ] [ stop-test-httpd ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs kernel io.servers ;
|
||||
USING: accessors namespaces assocs kernel io.servers ;
|
||||
IN: http.server.remapping
|
||||
|
||||
SYMBOL: port-remapping
|
||||
|
|
@ -9,4 +9,4 @@ SYMBOL: port-remapping
|
|||
[ port-remapping get at ] keep or ;
|
||||
|
||||
: secure-http-port ( -- n )
|
||||
secure-port remap-port ;
|
||||
secure-addr port>> remap-port ;
|
||||
|
|
|
|||
|
|
@ -121,16 +121,14 @@ TUPLE: jpeg-color-info
|
|||
|
||||
: decode-huff-table ( chunk -- )
|
||||
data>> [ binary <byte-reader> ] [ length ] bi limit-stream [
|
||||
[ input-stream get stream>> [ count>> ] [ limit>> ] bi < ]
|
||||
[
|
||||
[ input-stream get stream>> [ count>> ] [ limit>> ] bi < ]
|
||||
[
|
||||
read4/4 swap 2 * +
|
||||
16 read
|
||||
dup [ ] [ + ] map-reduce read
|
||||
binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
|
||||
swap jpeg> huff-tables>> set-nth
|
||||
] while
|
||||
] with-input-stream*
|
||||
read4/4 swap 2 * +
|
||||
16 read
|
||||
dup [ ] [ + ] map-reduce read
|
||||
binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
|
||||
swap jpeg> huff-tables>> set-nth
|
||||
] while
|
||||
] stream-throw-on-eof ;
|
||||
|
||||
: decode-scan ( chunk -- )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types kernel bit-arrays sequences assocs math
|
||||
USING: alien.data kernel bit-arrays sequences assocs math
|
||||
namespaces accessors math.order locals fry io.ports
|
||||
io.backend.unix io.backend.unix.multiplexers unix unix.ffi
|
||||
unix.time ;
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.syntax generic assocs kernel
|
||||
kernel.private math io.ports sequences strings sbufs threads
|
||||
unix unix.ffi vectors io.buffers io.backend io.encodings math.parser
|
||||
continuations system libc namespaces make io.timeouts
|
||||
io.encodings.utf8 destructors destructors.private accessors
|
||||
summary combinators locals unix.time unix.types fry
|
||||
io.backend.unix.multiplexers ;
|
||||
USING: alien alien.c-types alien.data alien.syntax generic
|
||||
assocs kernel kernel.private math io.ports sequences strings
|
||||
sbufs threads unix unix.ffi vectors io.buffers io.backend
|
||||
io.encodings math.parser continuations system libc namespaces
|
||||
make io.timeouts io.encodings.utf8 destructors
|
||||
destructors.private accessors summary combinators locals
|
||||
unix.time unix.types fry io.backend.unix.multiplexers ;
|
||||
QUALIFIED: io
|
||||
IN: io.backend.unix
|
||||
|
||||
|
|
@ -146,7 +146,7 @@ M: stdin dispose*
|
|||
|
||||
: wait-for-stdin ( stdin -- size )
|
||||
[ control>> CHAR: X over io:stream-write1 io:stream-flush ]
|
||||
[ size>> ssize_t heap-size swap io:stream-read *int ]
|
||||
[ size>> ssize_t heap-size swap io:stream-read int deref ]
|
||||
bi ;
|
||||
|
||||
:: refill-stdin ( buffer stdin size -- )
|
||||
|
|
@ -167,11 +167,11 @@ M: stdin refill
|
|||
M: stdin cancel-operation
|
||||
[ size>> ] [ control>> ] bi [ cancel-operation ] bi@ ;
|
||||
|
||||
: control-write-fd ( -- fd ) &: control_write *uint ;
|
||||
: control-write-fd ( -- fd ) &: control_write uint deref ;
|
||||
|
||||
: size-read-fd ( -- fd ) &: size_read *uint ;
|
||||
: size-read-fd ( -- fd ) &: size_read uint deref ;
|
||||
|
||||
: data-read-fd ( -- fd ) &: stdin_read *uint ;
|
||||
: data-read-fd ( -- fd ) &: stdin_read uint deref ;
|
||||
|
||||
: <stdin> ( -- stdin )
|
||||
stdin new-disposable
|
||||
|
|
|
|||
|
|
@ -52,7 +52,7 @@ HELP: with-directory-files
|
|||
{ $examples
|
||||
"Print all files in your home directory which are larger than a megabyte:"
|
||||
{ $code
|
||||
"""USING: io.directoies io.files.info io.pathnames ;
|
||||
"""USING: io.directories io.files.info io.pathnames ;
|
||||
home [
|
||||
[
|
||||
dup link-info size>> 20 2^ >
|
||||
|
|
|
|||
|
|
@ -64,7 +64,7 @@ HELP: find-by-extension
|
|||
}
|
||||
{ $description "Searches a directory for all files with the given extension. File extension and filenames are converted to lower-case and compared using the " { $link tail? } " word. The file extension should contain the period." }
|
||||
{ $examples
|
||||
{ $unchecked-example
|
||||
{ $code
|
||||
"USING: io.directories.search ;"
|
||||
"\"/\" \".mp3\" find-by-extension"
|
||||
}
|
||||
|
|
@ -77,7 +77,7 @@ HELP: find-by-extensions
|
|||
}
|
||||
{ $description "Searches a directory for all files in the given list of extensions. File extensions and filenames are converted to lower-case and compared using the " { $link tail? } " word. File extensions should contain the period." }
|
||||
{ $examples
|
||||
{ $unchecked-example
|
||||
{ $code
|
||||
"USING: io.directories.search ;"
|
||||
"\"/\" { \".jpg\" \".gif\" \".tiff\" \".png\" \".bmp\" } find-by-extensions"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types io.directories.unix kernel system unix
|
||||
classes.struct unix.ffi ;
|
||||
USING: alien.c-types alien.data io.directories.unix kernel
|
||||
system unix classes.struct unix.ffi ;
|
||||
IN: io.directories.unix.linux
|
||||
|
||||
M: linux find-next-file ( DIR* -- dirent )
|
||||
dirent <struct>
|
||||
f <void*>
|
||||
f void* <ref>
|
||||
[ [ readdir64_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep
|
||||
*void* [ drop f ] unless ;
|
||||
void* deref [ drop f ] unless ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types alien.strings combinators
|
||||
continuations destructors fry io io.backend io.backend.unix
|
||||
io.directories io.encodings.binary io.encodings.utf8 io.files
|
||||
io.pathnames io.files.types kernel math.bitwise sequences system
|
||||
unix unix.stat vocabs.loader classes.struct unix.ffi literals ;
|
||||
USING: accessors alien.c-types alien.data alien.strings
|
||||
combinators continuations destructors fry io io.backend
|
||||
io.backend.unix io.directories io.encodings.binary
|
||||
io.encodings.utf8 io.files io.pathnames io.files.types kernel
|
||||
math.bitwise sequences system unix unix.stat vocabs.loader
|
||||
classes.struct unix.ffi literals ;
|
||||
IN: io.directories.unix
|
||||
|
||||
CONSTANT: touch-mode flags{ O_WRONLY O_APPEND O_CREAT O_EXCL }
|
||||
|
|
@ -37,9 +38,9 @@ HOOK: find-next-file os ( DIR* -- byte-array )
|
|||
|
||||
M: unix find-next-file ( DIR* -- byte-array )
|
||||
dirent <struct>
|
||||
f <void*>
|
||||
f void* <ref>
|
||||
[ readdir_r 0 = [ (io-error) ] unless ] 2keep
|
||||
*void* [ drop f ] unless ;
|
||||
void* deref [ drop f ] unless ;
|
||||
|
||||
: dirent-type>file-type ( ch -- type )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types alien.strings combinators
|
||||
grouping io.encodings.utf8 io.files kernel math sequences system
|
||||
unix io.files.unix arrays unix.statfs.macosx unix.statvfs.macosx
|
||||
unix.getfsstat.macosx io.files.info.unix io.files.info
|
||||
classes.struct specialized-arrays ;
|
||||
USING: accessors alien.c-types alien.data alien.strings
|
||||
combinators grouping io.encodings.utf8 io.files kernel math
|
||||
sequences system unix io.files.unix arrays unix.statfs.macosx
|
||||
unix.statvfs.macosx unix.getfsstat.macosx io.files.info.unix
|
||||
io.files.info classes.struct specialized-arrays ;
|
||||
SPECIALIZED-ARRAY: uint
|
||||
SPECIALIZED-ARRAY: statfs64
|
||||
IN: io.files.info.unix.macosx
|
||||
|
|
@ -13,8 +13,8 @@ TUPLE: macosx-file-system-info < unix-file-system-info
|
|||
io-size owner type-id filesystem-subtype ;
|
||||
|
||||
M: macosx file-systems ( -- array )
|
||||
f <void*> dup 0 getmntinfo64 dup io-error
|
||||
[ *void* ] dip <direct-statfs64-array>
|
||||
f void* <ref> dup 0 getmntinfo64 dup io-error
|
||||
[ void* deref ] dip <direct-statfs64-array>
|
||||
[ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ;
|
||||
|
||||
M: macosx new-file-system-info macosx-file-system-info new ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes help.markup help.syntax io.streams.string
|
||||
strings math calendar io.files.info io.files.info.unix ;
|
||||
IN: io.files.unix
|
||||
IN: io.files.info.unix
|
||||
|
||||
HELP: add-file-permissions
|
||||
{ $values
|
||||
|
|
@ -102,16 +102,15 @@ HELP: set-file-permissions
|
|||
{ "path" "a pathname string" } { "n" "an integer, interepreted as a string of bits" } }
|
||||
{ $description "Sets the file permissions for a given file with the supplied Unix permissions integer. Supplying an octal number with " { $link POSTPONE: OCT: } " is recommended." }
|
||||
{ $examples "Using the tradidional octal value:"
|
||||
{ $unchecked-example "USING: io.files.unix kernel ;"
|
||||
{ $code "USING: io.files.info.unix kernel ;"
|
||||
"\"resource:license.txt\" OCT: 755 set-file-permissions"
|
||||
""
|
||||
}
|
||||
"Higher-level, setting named bits:"
|
||||
{ $unchecked-example "USING: io.files.unix kernel math.bitwise ;"
|
||||
{ $code "USING: io.files.info.unix kernel literals ;"
|
||||
"\"resource:license.txt\""
|
||||
"{ USER-ALL GROUP-READ GROUP-EXECUTE OTHER-READ OTHER-EXECUTE }"
|
||||
"flags set-file-permissions"
|
||||
"" }
|
||||
"flags{ USER-ALL GROUP-READ GROUP-EXECUTE OTHER-READ OTHER-EXECUTE }"
|
||||
"set-file-permissions"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: set-file-times
|
||||
|
|
|
|||
|
|
@ -3,13 +3,13 @@
|
|||
USING: accessors alien alien.c-types alien.data alien.strings
|
||||
alien.syntax arrays assocs classes.struct combinators
|
||||
combinators.short-circuit continuations destructors environment
|
||||
io io.backend io.binary io.buffers
|
||||
io.encodings.utf16n io.files io.files.private io.files.types
|
||||
io.pathnames io.ports io.streams.c io.streams.null io.timeouts
|
||||
kernel libc literals locals make math math.bitwise namespaces
|
||||
sequences specialized-arrays system
|
||||
threads tr windows windows.errors windows.handles
|
||||
windows.kernel32 windows.shell32 windows.time windows.types ;
|
||||
io io.backend io.binary io.buffers io.encodings.utf16n io.files
|
||||
io.files.private io.files.types io.pathnames io.ports
|
||||
io.streams.c io.streams.null io.timeouts kernel libc literals
|
||||
locals make math math.bitwise namespaces sequences
|
||||
specialized-arrays system threads tr windows windows.errors
|
||||
windows.handles windows.kernel32 windows.shell32 windows.time
|
||||
windows.types ;
|
||||
SPECIALIZED-ARRAY: ushort
|
||||
IN: io.files.windows
|
||||
|
||||
|
|
@ -52,7 +52,7 @@ C: <FileArgs> FileArgs
|
|||
[ handle>> handle>> ]
|
||||
[ buffer>> ]
|
||||
[ buffer>> buffer-length ]
|
||||
[ drop DWORD <c-object> ]
|
||||
[ drop 0 DWORD <ref> ]
|
||||
[ FileArgs-overlapped ]
|
||||
} cleave <FileArgs> ;
|
||||
|
||||
|
|
@ -131,7 +131,7 @@ M: winnt init-io ( -- )
|
|||
ERROR: invalid-file-size n ;
|
||||
|
||||
: handle>file-size ( handle -- n )
|
||||
0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
|
||||
0 ulonglong <ref> [ GetFileSizeEx win32-error=0/f ] keep ulonglong deref ;
|
||||
|
||||
ERROR: seek-before-start n ;
|
||||
|
||||
|
|
@ -249,7 +249,7 @@ M: winnt init-stdio
|
|||
GetLastError ERROR_ALREADY_EXISTS = not ;
|
||||
|
||||
: set-file-pointer ( handle length method -- )
|
||||
[ [ handle>> ] dip d>w/w <uint> ] dip SetFilePointer
|
||||
[ [ handle>> ] dip d>w/w uint <ref> ] dip SetFilePointer
|
||||
INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ;
|
||||
|
||||
M: windows (file-reader) ( path -- stream )
|
||||
|
|
|
|||
|
|
@ -128,7 +128,7 @@ HELP: kill-process
|
|||
HELP: kill-process*
|
||||
{ $values { "handle" "a process handle" } }
|
||||
{ $contract "Kills a running process." }
|
||||
{ $notes "User code should call " { $link kill-process } " intead." } ;
|
||||
{ $notes "User code should call " { $link kill-process } " instead." } ;
|
||||
|
||||
HELP: process
|
||||
{ $class-description "A class representing a process. Instances are created by calling " { $link <process> } "." } ;
|
||||
|
|
|
|||
|
|
@ -180,12 +180,12 @@ M: windows wait-for-processes ( -- ? )
|
|||
GetCurrentProcess ! source process
|
||||
swap handle>> ! handle
|
||||
GetCurrentProcess ! target process
|
||||
f <void*> [ ! target handle
|
||||
f void* <ref> [ ! target handle
|
||||
DUPLICATE_SAME_ACCESS ! desired access
|
||||
TRUE ! inherit handle
|
||||
0 ! options
|
||||
DuplicateHandle win32-error=0/f
|
||||
] keep *void* <win32-handle> &dispose ;
|
||||
] keep void* deref <win32-handle> &dispose ;
|
||||
|
||||
! /dev/null simulation
|
||||
: null-input ( -- pipe )
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ HELP: mapped-file
|
|||
} ;
|
||||
|
||||
HELP: <mapped-file>
|
||||
{ $values { "path" "a pathname string" } { "mmap" mapped-file } }
|
||||
{ $values { "path" "a pathname string" } { "mmap" mapped-file } }
|
||||
{ $contract "Opens a file and maps its contents into memory. The length is permitted to exceed the length of the file on disk, in which case the remaining space is padded with zero bytes." }
|
||||
{ $notes "You must call " { $link dispose } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." }
|
||||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
|
@ -35,7 +35,7 @@ HELP: close-mapped-file
|
|||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
||||
HELP: <mapped-file-reader>
|
||||
{ $values { "path" "a pathname string" } { "mmap" mapped-file } }
|
||||
{ $values { "path" "a pathname string" } { "mmap" mapped-file } }
|
||||
{ $contract "Opens a file for reading only and maps its contents into memory. The length is permitted to exceed the length of the file on disk, in which case the remaining space is padded with zero bytes." }
|
||||
{ $notes "You must call " { $link dispose } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." }
|
||||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ TUPLE: win32-monitor < monitor port ;
|
|||
[ recursive>> 1 0 ? ]
|
||||
} cleave
|
||||
FILE_NOTIFY_CHANGE_ALL
|
||||
0 <uint>
|
||||
0 uint <ref>
|
||||
(make-overlapped)
|
||||
[ f ReadDirectoryChangesW win32-error=0/f ] keep ;
|
||||
|
||||
|
|
|
|||
|
|
@ -76,8 +76,8 @@ ARTICLE: "io.servers" "Threaded servers"
|
|||
"From within the dynamic scope of a client handler, several words can be used to interact with the threaded server:"
|
||||
{ $subsections
|
||||
stop-this-server
|
||||
secure-port
|
||||
insecure-port
|
||||
secure-addr
|
||||
insecure-addr
|
||||
}
|
||||
"Additionally, the " { $link local-address } " and "
|
||||
{ $subsections remote-address } " variables are set, as in " { $link with-client } "." ;
|
||||
|
|
@ -125,12 +125,12 @@ HELP: with-threaded-server
|
|||
}
|
||||
{ $description "Runs a server and calls a quotation, stopping the server once the quotation returns." } ;
|
||||
|
||||
HELP: secure-port
|
||||
{ $values { "n/f" { $maybe integer } } }
|
||||
HELP: secure-addr
|
||||
{ $values { "addrspec" "an addrspec" } }
|
||||
{ $description "Outputs one of the port numbers on which the current threaded server accepts secure socket connections. Outputs " { $link f } " if the current threaded server does not accept secure socket connections." }
|
||||
{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
|
||||
|
||||
HELP: insecure-port
|
||||
{ $values { "n/f" { $maybe integer } } }
|
||||
HELP: insecure-addr
|
||||
{ $values { "addrspec" "an addrspec" } }
|
||||
{ $description "Outputs one of the port numbers on which the current threaded server accepts ordinary socket connections. Outputs " { $link f } " if the current threaded server does not accept ordinary socket connections." }
|
||||
{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ IN: io.servers
|
|||
0 >>insecure
|
||||
[ "Hello world." write stop-this-server ] >>handler
|
||||
[
|
||||
"localhost" insecure-port <inet> ascii <client> drop stream-contents
|
||||
insecure-addr ascii <client> drop stream-contents
|
||||
] with-threaded-server
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -86,7 +86,9 @@ M: f >insecure ;
|
|||
[ dup secure? [ <secure> ] unless ] map ;
|
||||
|
||||
: listen-on ( threaded-server -- addrspecs )
|
||||
[ secure>> >secure ] [ insecure>> >insecure ] bi append
|
||||
[ secure>> ssl-supported? [ >secure ] [ drop { } ] if ]
|
||||
[ insecure>> >insecure ]
|
||||
bi append
|
||||
[ resolve-host ] map concat ;
|
||||
|
||||
: accepted-connection ( remote local -- )
|
||||
|
|
@ -141,7 +143,7 @@ M: threaded-server handle-client* handler>> call( -- ) ;
|
|||
\ start-accept-loop NOTICE add-error-logging
|
||||
|
||||
: create-secure-context ( threaded-server -- threaded-server )
|
||||
dup secure>> [
|
||||
dup secure>> ssl-supported? and [
|
||||
dup secure-config>> <secure-context> >>secure-context
|
||||
] when ;
|
||||
|
||||
|
|
@ -162,7 +164,8 @@ ERROR: no-ports-configured threaded-server ;
|
|||
|
||||
: set-servers ( threaded-server -- threaded-server )
|
||||
dup [
|
||||
dup dup listen-on [ no-ports-configured ] [ (make-servers) ] if-empty
|
||||
dup dup listen-on
|
||||
[ no-ports-configured ] [ (make-servers) ] if-empty
|
||||
>>servers
|
||||
] with-existing-secure-context ;
|
||||
|
||||
|
|
@ -221,21 +224,26 @@ PRIVATE>
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: first-port ( quot -- n/f )
|
||||
[ threaded-server get servers>> ] dip
|
||||
filter [ f ] [ first addr>> port>> ] if-empty ; inline
|
||||
GENERIC: connect-addr ( addrspec -- addrspec )
|
||||
|
||||
M: inet4 connect-addr [ "127.0.0.1" ] dip port>> <inet4> ;
|
||||
|
||||
M: inet6 connect-addr [ "::1" ] dip port>> <inet6> ;
|
||||
|
||||
M: secure connect-addr addrspec>> connect-addr <secure> ;
|
||||
|
||||
M: local connect-addr ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: secure-port ( -- n/f ) [ addr>> secure? ] first-port ;
|
||||
: server-addrs ( -- addrspecs )
|
||||
threaded-server get servers>> [ addr>> connect-addr ] map ;
|
||||
|
||||
: insecure-port ( -- n/f ) [ addr>> secure? not ] first-port ;
|
||||
: secure-addr ( -- addrspec )
|
||||
server-addrs [ secure? ] filter random ;
|
||||
|
||||
: secure-addr ( -- inet )
|
||||
threaded-server get servers>> [ addr>> secure? ] filter random ;
|
||||
|
||||
: insecure-addr ( -- inet )
|
||||
threaded-server get servers>> [ addr>> secure? not ] filter random addr>> ;
|
||||
: insecure-addr ( -- addrspec )
|
||||
server-addrs [ secure? not ] filter random ;
|
||||
|
||||
: server. ( threaded-server -- )
|
||||
[ [ "=== " write name>> ] [ ] bi write-object nl ]
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces continuations destructors io
|
||||
debugger io.sockets io.sockets.private sequences summary
|
||||
|
|
@ -11,6 +11,10 @@ SYMBOL: secure-socket-timeout
|
|||
|
||||
SYMBOL: secure-socket-backend
|
||||
|
||||
HOOK: ssl-supported? secure-socket-backend ( -- ? )
|
||||
|
||||
M: object ssl-supported? f ;
|
||||
|
||||
SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ;
|
||||
|
||||
TUPLE: secure-config
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
|
||||
! Copyright (C) 2007, 2010, Slava Pestov, Elie CHAFTARI.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors unix byte-arrays kernel sequences namespaces
|
||||
math math.order combinators init alien alien.c-types
|
||||
|
|
@ -11,6 +11,8 @@ unix.ffi ;
|
|||
FROM: io.ports => shutdown ;
|
||||
IN: io.sockets.secure.unix
|
||||
|
||||
M: openssl ssl-supported? t ;
|
||||
|
||||
M: ssl-handle handle-fd file>> handle-fd ;
|
||||
|
||||
: syscall-error ( r -- * )
|
||||
|
|
|
|||
|
|
@ -118,10 +118,10 @@ HELP: inet
|
|||
|
||||
HELP: <inet>
|
||||
{ $values { "host" "a host name" } { "port" "a port number" } { "inet" inet } }
|
||||
{ $description "Creates a new " { $link inet } " address specifier." } ;
|
||||
{ $description "Creates a new " { $link inet } " address specifier. If the host is an IPv4 address, an " { $link inet4 } " tuple will be returned; likewise for " { $link inet6 } "." } ;
|
||||
|
||||
HELP: inet4
|
||||
{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link <inet4> } "." }
|
||||
{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link <inet4> } ". A host of " { $link f } " refers to localhost, and a port of " { $link f } " defers the port choice until later." }
|
||||
{ $notes "Most applications do not operate on IPv4 addresses directly, and instead should use the " { $link inet } " address specifier, or call " { $link resolve-host } "." }
|
||||
{ $examples
|
||||
{ $code "\"127.0.0.1\" 8080 <inet4>" }
|
||||
|
|
@ -129,10 +129,10 @@ HELP: inet4
|
|||
|
||||
HELP: <inet4>
|
||||
{ $values { "host" "an IPv4 address" } { "port" "a port number" } { "inet4" inet4 } }
|
||||
{ $description "Creates a new " { $link inet4 } " address specifier." } ;
|
||||
{ $description "Creates a new " { $link inet4 } " address specifier. A value of " { $link f } " as the host refers to localhost, while " { $link f } " as the port defers the port choice until a later time." } ;
|
||||
|
||||
HELP: inet6
|
||||
{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link <inet6> } "." }
|
||||
{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link <inet6> } ". A host of " { $link f } " refers to localhost, and a port of " { $link f } " defers the port choice until later." }
|
||||
{ $notes "Most applications do not operate on IPv6 addresses directly, and instead should use the " { $link inet } " address specifier, or call " { $link resolve-host } "." }
|
||||
{ $examples
|
||||
{ $code "\"::1\" 8080 <inet6>" }
|
||||
|
|
@ -140,7 +140,7 @@ HELP: inet6
|
|||
|
||||
HELP: <inet6>
|
||||
{ $values { "host" "an IPv6 address" } { "port" "a port number" } { "inet6" inet6 } }
|
||||
{ $description "Creates a new " { $link inet6 } " address specifier." } ;
|
||||
{ $description "Creates a new " { $link inet6 } " address specifier. A value of " { $link f } " as the host refers to localhost, while " { $link f } " as the port defers the port choice until a later time." } ;
|
||||
|
||||
HELP: <client>
|
||||
{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } { "local" "an address specifier" } }
|
||||
|
|
|
|||
|
|
@ -1,8 +1,21 @@
|
|||
IN: io.sockets.tests
|
||||
USING: io.sockets io.sockets.private sequences math tools.test
|
||||
namespaces accessors kernel destructors calendar io.timeouts
|
||||
io.encodings.utf8 io concurrency.promises threads
|
||||
io.streams.string ;
|
||||
IN: io.sockets.tests
|
||||
|
||||
[ T{ inet4 f f 0 } ] [ f 0 <inet4> ] unit-test
|
||||
[ T{ inet6 f f 0 } ] [ f 0 <inet6> ] unit-test
|
||||
|
||||
[ T{ inet f "google.com" f } ] [ "google.com" f <inet> ] unit-test
|
||||
|
||||
[ T{ inet f "google.com" 0 } ] [ "google.com" 0 <inet> ] unit-test
|
||||
[ T{ inet f "google.com" 80 } ] [ "google.com" 0 <inet> 80 with-port ] unit-test
|
||||
[ T{ inet4 f "8.8.8.8" 0 } ] [ "8.8.8.8" 0 <inet4> ] unit-test
|
||||
[ T{ inet4 f "8.8.8.8" 53 } ] [ "8.8.8.8" 0 <inet4> 53 with-port ] unit-test
|
||||
[ T{ inet6 f "5:5:5:5:6:6:6:6" 12 } ] [ "5:5:5:5:6:6:6:6" 0 <inet6> 12 with-port ] unit-test
|
||||
|
||||
[ T{ inet f "google.com" 80 } ] [ "google.com" 80 with-port ] unit-test
|
||||
|
||||
[ B{ 1 2 3 4 } ]
|
||||
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
|
||||
|
|
@ -132,3 +145,4 @@ io.streams.string ;
|
|||
|
||||
! Binding to all interfaces should work
|
||||
[ ] [ f 0 <inet4> <datagram> dispose ] unit-test
|
||||
[ ] [ f 0 <inet6> <datagram> dispose ] unit-test
|
||||
|
|
|
|||
|
|
@ -16,6 +16,8 @@ IN: io.sockets
|
|||
{ [ os unix? ] [ "unix.ffi" ] }
|
||||
} cond use-vocab >>
|
||||
|
||||
GENERIC# with-port 1 ( addrspec port -- addrspec )
|
||||
|
||||
! Addressing
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -37,8 +39,6 @@ GENERIC: inet-ntop ( data addrspec -- str )
|
|||
|
||||
GENERIC: inet-pton ( str addrspec -- data )
|
||||
|
||||
GENERIC# with-port 1 ( addrspec port -- addrspec )
|
||||
|
||||
: make-sockaddr/size ( addrspec -- sockaddr size )
|
||||
[ make-sockaddr ] [ sockaddr-size ] bi ;
|
||||
|
||||
|
|
@ -106,10 +106,10 @@ M: ipv4 make-sockaddr ( inet -- sockaddr )
|
|||
swap
|
||||
[ port>> htons >>port ]
|
||||
[ host>> "0.0.0.0" or ]
|
||||
[ inet-pton *uint >>addr ] tri ;
|
||||
[ inet-pton uint deref >>addr ] tri ;
|
||||
|
||||
M: ipv4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
|
||||
[ addr>> <uint> ] dip inet-ntop <ipv4> ;
|
||||
[ addr>> uint <ref> ] dip inet-ntop <ipv4> ;
|
||||
|
||||
TUPLE: inet4 < ipv4 { port integer read-only } ;
|
||||
|
||||
|
|
@ -368,13 +368,18 @@ M: inet present
|
|||
C: <inet> inet
|
||||
|
||||
M: string resolve-host
|
||||
f prepare-addrinfo f <void*>
|
||||
[ getaddrinfo addrinfo-error ] keep *void* addrinfo memory>struct
|
||||
f prepare-addrinfo f void* <ref>
|
||||
[ getaddrinfo addrinfo-error ] keep void* deref addrinfo memory>struct
|
||||
[ parse-addrinfo-list ] keep freeaddrinfo ;
|
||||
|
||||
M: string with-port <inet> ;
|
||||
|
||||
M: hostname resolve-host
|
||||
host>> resolve-host ;
|
||||
|
||||
M: hostname with-port
|
||||
[ host>> ] dip <inet> ;
|
||||
|
||||
M: inet resolve-host
|
||||
[ call-next-method ] [ port>> ] bi '[ _ with-port ] map ;
|
||||
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ IN: io.sockets.unix
|
|||
socket dup io-error <fd> init-fd |dispose ;
|
||||
|
||||
: set-socket-option ( fd level opt -- )
|
||||
[ handle-fd ] 2dip 1 <int> dup byte-length setsockopt io-error ;
|
||||
[ handle-fd ] 2dip 1 int <ref> dup byte-length setsockopt io-error ;
|
||||
|
||||
M: unix addrinfo-error ( n -- )
|
||||
[ gai_strerror throw ] unless-zero ;
|
||||
|
|
@ -39,11 +39,11 @@ M: unix addrspec-of-family ( af -- addrspec )
|
|||
|
||||
! Client sockets - TCP and Unix domain
|
||||
M: object (get-local-address) ( handle remote -- sockaddr )
|
||||
[ handle-fd ] dip empty-sockaddr/size <int>
|
||||
[ handle-fd ] dip empty-sockaddr/size int <ref>
|
||||
[ getsockname io-error ] 2keep drop ;
|
||||
|
||||
M: object (get-remote-address) ( handle local -- sockaddr )
|
||||
[ handle-fd ] dip empty-sockaddr/size <int>
|
||||
[ handle-fd ] dip empty-sockaddr/size int <ref>
|
||||
[ getpeername io-error ] 2keep drop ;
|
||||
|
||||
: init-client-socket ( fd -- )
|
||||
|
|
@ -101,7 +101,7 @@ M: object (server) ( addrspec -- handle )
|
|||
] with-destructors ;
|
||||
|
||||
: do-accept ( server addrspec -- fd sockaddr )
|
||||
[ handle>> handle-fd ] [ empty-sockaddr/size <int> ] bi*
|
||||
[ handle>> handle-fd ] [ empty-sockaddr/size int <ref> ] bi*
|
||||
[ accept ] 2keep drop ; inline
|
||||
|
||||
M: object (accept) ( server addrspec -- fd sockaddr )
|
||||
|
|
@ -138,7 +138,7 @@ CONSTANT: packet-size 65536
|
|||
packet-size ! nbytes
|
||||
0 ! flags
|
||||
sockaddr ! from
|
||||
len <int> ! fromlen
|
||||
len int <ref> ! fromlen
|
||||
recvfrom dup 0 >=
|
||||
[ receive-buffer get-global swap memory>byte-array sockaddr ]
|
||||
[ drop f f ]
|
||||
|
|
|
|||
|
|
@ -48,11 +48,11 @@ M: win32-socket dispose* ( stream -- )
|
|||
opened-socket ;
|
||||
|
||||
M: object (get-local-address) ( socket addrspec -- sockaddr )
|
||||
[ handle>> ] dip empty-sockaddr/size <int>
|
||||
[ handle>> ] dip empty-sockaddr/size int <ref>
|
||||
[ getsockname socket-error ] 2keep drop ;
|
||||
|
||||
M: object (get-remote-address) ( socket addrspec -- sockaddr )
|
||||
[ handle>> ] dip empty-sockaddr/size <int>
|
||||
[ handle>> ] dip empty-sockaddr/size int <ref>
|
||||
[ getpeername socket-error ] 2keep drop ;
|
||||
|
||||
: bind-socket ( win32-socket sockaddr len -- )
|
||||
|
|
@ -87,7 +87,7 @@ M: windows (raw) ( addrspec -- handle )
|
|||
[ SOCK_RAW server-socket ] with-destructors ;
|
||||
|
||||
: malloc-int ( n -- alien )
|
||||
<int> malloc-byte-array ; inline
|
||||
int <ref> malloc-byte-array ; inline
|
||||
|
||||
M: winnt WSASocket-flags ( -- DWORD )
|
||||
WSA_FLAG_OVERLAPPED ;
|
||||
|
|
@ -99,7 +99,7 @@ M: winnt WSASocket-flags ( -- DWORD )
|
|||
{ void* }
|
||||
[
|
||||
void* heap-size
|
||||
DWORD <c-object>
|
||||
0 DWORD <ref>
|
||||
f
|
||||
f
|
||||
WSAIoctl SOCKET_ERROR = [
|
||||
|
|
@ -181,7 +181,8 @@ TUPLE: AcceptEx-args port
|
|||
} cleave AcceptEx drop winsock-error ; inline
|
||||
|
||||
: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
|
||||
f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
|
||||
f void* <ref> 0 int <ref> f void* <ref>
|
||||
[ 0 int <ref> GetAcceptExSockaddrs ] keep void* deref ;
|
||||
|
||||
: extract-remote-address ( AcceptEx -- sockaddr )
|
||||
[
|
||||
|
|
@ -246,7 +247,7 @@ TUPLE: WSARecvFrom-args port
|
|||
[
|
||||
[ port>> addr>> empty-sockaddr dup ]
|
||||
[ lpFrom>> ]
|
||||
[ lpFromLen>> *int ]
|
||||
[ lpFromLen>> int deref ]
|
||||
tri memcpy
|
||||
] bi ; inline
|
||||
|
||||
|
|
@ -278,7 +279,7 @@ TUPLE: WSASendTo-args port
|
|||
swap make-send-buffer >>lpBuffers
|
||||
1 >>dwBufferCount
|
||||
0 >>dwFlags
|
||||
0 <uint> >>lpNumberOfBytesSent
|
||||
0 uint <ref> >>lpNumberOfBytesSent
|
||||
(make-overlapped) >>lpOverlapped ; inline
|
||||
|
||||
: call-WSASendTo ( WSASendTo -- )
|
||||
|
|
|
|||
|
|
@ -61,6 +61,7 @@ $nl
|
|||
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
|
||||
{ $examples
|
||||
{ $code
|
||||
"USING: io.styles prettyprint sequences ;"
|
||||
"{ { 1 2 } { 3 4 } }"
|
||||
"H{ { table-gap { 10 10 } } } ["
|
||||
" [ [ [ [ . ] with-cell ] each ] with-row ] each"
|
||||
|
|
@ -204,9 +205,10 @@ HELP: foreground
|
|||
{ $description "Character style. An instance of " { $link color } ". See " { $link "colors" } "." }
|
||||
{ $examples
|
||||
{ $code
|
||||
"USING: colors.gray io.styles hashtables sequences kernel math ;"
|
||||
"10 iota ["
|
||||
" \"Hello world\\n\""
|
||||
" swap 10 / 1 <gray> foreground associate format"
|
||||
" \"Hello world\\n\""
|
||||
" swap 10 / 1 <gray> foreground associate format"
|
||||
"] each"
|
||||
}
|
||||
} ;
|
||||
|
|
@ -215,10 +217,11 @@ HELP: background
|
|||
{ $description "Character style. An instance of " { $link color } ". See " { $link "colors" } "." }
|
||||
{ $examples
|
||||
{ $code
|
||||
"USING: colors hashtables io io.styles kernel math sequences ;"
|
||||
"10 iota ["
|
||||
" \"Hello world\\n\""
|
||||
" swap 10 / 1 over - over 1 <rgba>"
|
||||
" background associate format nl"
|
||||
" \"Hello world\\n\""
|
||||
" swap 10 / 1 over - over 1 <rgba>"
|
||||
" background associate format nl"
|
||||
"] each"
|
||||
}
|
||||
} ;
|
||||
|
|
@ -227,14 +230,20 @@ HELP: font-name
|
|||
{ $description "Character style. Font family named by a string." }
|
||||
{ $examples
|
||||
"This example outputs some different font sizes:"
|
||||
{ $code "{ \"monospace\" \"serif\" \"sans-serif\" }\n[ dup font-name associate format nl ] each" }
|
||||
{ $code
|
||||
"USING: hashtables io io.styles kernel sequences ;"
|
||||
"{ \"monospace\" \"serif\" \"sans-serif\" }"
|
||||
"[ dup font-name associate format nl ] each"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: font-size
|
||||
{ $description "Character style. Font size, an integer." }
|
||||
{ $examples
|
||||
"This example outputs some different font sizes:"
|
||||
{ $code "{ 12 18 24 72 }"
|
||||
{ $code
|
||||
"USING: hashtables io io.styles kernel sequences ;"
|
||||
"{ 12 18 24 72 }"
|
||||
"[ \"Bigger\" swap font-size associate format nl ] each"
|
||||
}
|
||||
} ;
|
||||
|
|
@ -243,7 +252,11 @@ HELP: font-style
|
|||
{ $description "Character style. Font style, one of " { $link plain } ", " { $link bold } ", " { $link italic } ", or " { $link bold-italic } "." }
|
||||
{ $examples
|
||||
"This example outputs text in all three styles:"
|
||||
{ $code "{ plain bold italic bold-italic }\n[ [ name>> ] keep font-style associate format nl ] each" }
|
||||
{ $code
|
||||
"USING: accessors hashtables io io.styles kernel sequences ;"
|
||||
"{ plain bold italic bold-italic }"
|
||||
"[ [ name>> ] keep font-style associate format nl ] each"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: presented
|
||||
|
|
@ -252,19 +265,31 @@ HELP: presented
|
|||
HELP: page-color
|
||||
{ $description "Paragraph style. An instance of " { $link color } ". See " { $link "colors" } "." }
|
||||
{ $examples
|
||||
{ $code "H{ { page-color T{ rgba f 1 0.8 0.5 1 } } }\n[ \"A background\" write ] with-nesting nl" }
|
||||
{ $code
|
||||
"USING: colors io io.styles ;"
|
||||
"H{ { page-color T{ rgba f 1 0.8 0.5 1 } } }"
|
||||
"[ \"A background\" write ] with-nesting nl"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: border-color
|
||||
{ $description "Paragraph style. An instance of " { $link color } ". See " { $link "colors" } "." }
|
||||
{ $examples
|
||||
{ $code "H{ { border-color T{ rgba f 1 0 0 1 } } }\n[ \"A border\" write ] with-nesting nl" }
|
||||
{ $code
|
||||
"USING: colors io io.styles ;"
|
||||
"H{ { border-color T{ rgba f 1 0 0 1 } } }"
|
||||
"[ \"A border\" write ] with-nesting nl"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: inset
|
||||
{ $description "Paragraph style. A pair of integers representing the number of pixels that the content should be inset from the border. The first number is the horizontal inset, and the second is the vertical inset." }
|
||||
{ $examples
|
||||
{ $code "H{ { inset { 10 10 } } }\n[ \"Some inset text\" write ] with-nesting nl" }
|
||||
{ $code
|
||||
"USING: io io.styles ;"
|
||||
"H{ { inset { 10 10 } } }"
|
||||
"[ \"Some inset text\" write ] with-nesting nl"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: wrap-margin
|
||||
|
|
@ -284,7 +309,10 @@ HELP: input
|
|||
{ $class-description "Class of input text presentations. Instances can be used passed to " { $link write-object } " to output a clickable piece of input. Input text presentations are created by calling " { $link <input> } "." }
|
||||
{ $examples
|
||||
"This presentation class is used for the code examples you see in the online help:"
|
||||
{ $code "\"2 3 + .\" dup <input> write-object nl" }
|
||||
{ $code
|
||||
"USING: io io.styles kernel ;"
|
||||
"\"2 3 + .\" dup <input> write-object nl"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: <input>
|
||||
|
|
|
|||
|
|
@ -156,9 +156,9 @@ TUPLE: mach-error error-code error-string ;
|
|||
io-objects-from-iterator* [ release-io-object ] dip ;
|
||||
|
||||
: properties-from-io-object ( o -- o nsdictionary )
|
||||
dup f <void*> [
|
||||
dup f void* <ref> [
|
||||
kCFAllocatorDefault kNilOptions
|
||||
IORegistryEntryCreateCFProperties mach-error
|
||||
]
|
||||
keep *void* ;
|
||||
keep void* deref ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,23 +8,22 @@ HELP: $
|
|||
{ $description "Executes " { $snippet "word" } " at parse time and adds the result(s) to the parser accumulator." }
|
||||
{ $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
|
||||
{ $examples
|
||||
|
||||
{ $example """
|
||||
USING: kernel literals prettyprint ;
|
||||
IN: scratchpad
|
||||
|
||||
CONSTANT: five 5
|
||||
{ $ five } .
|
||||
""" "{ 5 }" }
|
||||
|
||||
{ $example """
|
||||
USING: kernel literals prettyprint ;
|
||||
IN: scratchpad
|
||||
|
||||
: seven-eleven ( -- a b ) 7 11 ;
|
||||
{ $ seven-eleven } .
|
||||
""" "{ 7 11 }" }
|
||||
|
||||
{ $example
|
||||
"USING: kernel literals prettyprint ;"
|
||||
"IN: scratchpad"
|
||||
""
|
||||
"CONSTANT: five 5"
|
||||
"{ $ five } ."
|
||||
"{ 5 }"
|
||||
}
|
||||
{ $example
|
||||
"USING: kernel literals prettyprint ;"
|
||||
"IN: scratchpad"
|
||||
""
|
||||
": seven-eleven ( -- a b ) 7 11 ;"
|
||||
"{ $ seven-eleven } ."
|
||||
"{ 7 11 }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: $[
|
||||
|
|
@ -32,15 +31,14 @@ HELP: $[
|
|||
{ $description "Calls " { $snippet "code" } " at parse time and adds the result(s) to the parser accumulator." }
|
||||
{ $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." }
|
||||
{ $examples
|
||||
|
||||
{ $example """
|
||||
USING: kernel literals math prettyprint ;
|
||||
IN: scratchpad
|
||||
|
||||
<< CONSTANT: five 5 >>
|
||||
{ $[ five dup 1 + dup 2 + ] } .
|
||||
""" "{ 5 6 8 }" }
|
||||
|
||||
{ $example
|
||||
"USING: kernel literals math prettyprint ;"
|
||||
"IN: scratchpad"
|
||||
""
|
||||
"<< CONSTANT: five 5 >>"
|
||||
"{ $[ five dup 1 + dup 2 + ] } ."
|
||||
"{ 5 6 8 }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: ${
|
||||
|
|
@ -48,15 +46,14 @@ HELP: ${
|
|||
{ $description "Outputs an array containing the results of executing " { $snippet "code" } " at parse time." }
|
||||
{ $notes { $snippet "code" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
|
||||
{ $examples
|
||||
|
||||
{ $example """
|
||||
USING: kernel literals math prettyprint ;
|
||||
IN: scratchpad
|
||||
|
||||
CONSTANT: five 5
|
||||
CONSTANT: six 6
|
||||
${ five six 7 } .
|
||||
""" "{ 5 6 7 }"
|
||||
{ $example
|
||||
"USING: kernel literals math prettyprint ;"
|
||||
"IN: scratchpad"
|
||||
""
|
||||
"CONSTANT: five 5"
|
||||
"CONSTANT: six 6"
|
||||
"${ five six 7 } ."
|
||||
"{ 5 6 7 }"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
@ -66,7 +63,8 @@ HELP: flags{
|
|||
{ $values { "values" sequence } }
|
||||
{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at parse-time, which makes this word as efficient as using a literal integer." }
|
||||
{ $examples
|
||||
{ $example "USING: literals kernel prettyprint ;"
|
||||
{ $example
|
||||
"USING: literals kernel prettyprint ;"
|
||||
"IN: scratchpad"
|
||||
"CONSTANT: x HEX: 1"
|
||||
"flags{ HEX: 20 x BIN: 100 } .h"
|
||||
|
|
@ -77,13 +75,14 @@ HELP: flags{
|
|||
|
||||
ARTICLE: "literals" "Interpolating code results into literal values"
|
||||
"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
|
||||
{ $example """
|
||||
USE: literals
|
||||
IN: scratchpad
|
||||
|
||||
CONSTANT: five 5
|
||||
{ $ five $[ five dup 1 + dup 2 + ] } .
|
||||
""" "{ 5 5 6 8 }" }
|
||||
{ $example
|
||||
"USING: kernel literals math prettyprint ;"
|
||||
"IN: scratchpad"
|
||||
""
|
||||
"<< CONSTANT: five 5 >>"
|
||||
"{ $ five $[ five dup 1 + dup 2 + ] } ."
|
||||
"{ 5 5 6 8 }"
|
||||
}
|
||||
{ $subsections
|
||||
POSTPONE: $
|
||||
POSTPONE: $[
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences namespaces words assocs logging sorting
|
||||
prettyprint io io.styles io.files io.encodings.utf8
|
||||
strings combinators accessors arrays
|
||||
strings combinators accessors arrays math
|
||||
logging.server logging.parser calendar.format ;
|
||||
IN: logging.analysis
|
||||
|
||||
|
|
@ -20,6 +20,9 @@ SYMBOL: message-histogram
|
|||
] when
|
||||
drop ;
|
||||
|
||||
: recent-histogram ( assoc n -- alist )
|
||||
[ >alist sort-values <reversed> ] dip short head ;
|
||||
|
||||
: analyze-entries ( entries word-names -- errors word-histogram message-histogram )
|
||||
[
|
||||
word-names set
|
||||
|
|
@ -27,44 +30,40 @@ SYMBOL: message-histogram
|
|||
H{ } clone word-histogram set
|
||||
H{ } clone message-histogram set
|
||||
|
||||
[
|
||||
analyze-entry
|
||||
] each
|
||||
[ analyze-entry ] each
|
||||
|
||||
errors get
|
||||
word-histogram get
|
||||
message-histogram get
|
||||
word-histogram get 10 recent-histogram
|
||||
message-histogram get 10 recent-histogram
|
||||
] with-scope ;
|
||||
|
||||
: histogram. ( assoc quot -- )
|
||||
standard-table-style [
|
||||
[ >alist sort-values <reversed> ] dip [
|
||||
[
|
||||
[ swapd with-cell pprint-cell ] with-row
|
||||
] curry assoc-each
|
||||
] tabular-output ; inline
|
||||
|
||||
: log-entry. ( entry -- )
|
||||
"====== " write
|
||||
{
|
||||
[ date>> (timestamp>string) bl ]
|
||||
[ level>> pprint bl ]
|
||||
[ word-name>> write nl ]
|
||||
[ message>> "\n" join print ]
|
||||
} cleave ;
|
||||
: 10-most-recent ( errors -- errors )
|
||||
10 tail* "Only showing 10 most recent errors" print nl ;
|
||||
|
||||
: errors. ( errors -- )
|
||||
[ log-entry. ] each ;
|
||||
dup length 10 >= [ 10-most-recent ] when
|
||||
log-entries. ;
|
||||
|
||||
: analysis. ( errors word-histogram message-histogram -- )
|
||||
"==== INTERESTING MESSAGES:" print nl
|
||||
nl "==== FREQUENT MESSAGES:" print nl
|
||||
"Total: " write dup values sum . nl
|
||||
[
|
||||
dup level>> write ": " write message>> "\n" join write
|
||||
[ first name>> write bl ]
|
||||
[ second write ": " write ]
|
||||
[ third "\n" join write ]
|
||||
tri
|
||||
] histogram.
|
||||
nl
|
||||
"==== WORDS:" print nl
|
||||
nl nl
|
||||
"==== FREQUENT WORDS:" print nl
|
||||
[ write ] histogram.
|
||||
nl
|
||||
nl nl
|
||||
"==== ERRORS:" print nl
|
||||
errors. ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,11 +8,6 @@ HELP: insomniac-sender
|
|||
HELP: insomniac-recipients
|
||||
{ $var-description "A sequence of e-mail addresses to mail log reports to. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ;
|
||||
|
||||
HELP: ?analyze-log
|
||||
{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } { "string/f" string } }
|
||||
{ $description "Analyzes the most recent log and outputs the string analysis, or outputs " { $link f } " if it doesn't exist." }
|
||||
{ $see-also analyze-log } ;
|
||||
|
||||
HELP: email-log-report
|
||||
{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } }
|
||||
{ $description "E-mails a log report for the given log service. The " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ;
|
||||
|
|
|
|||
|
|
@ -1,31 +1,26 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: logging.analysis logging.server logging smtp kernel
|
||||
io.files io.streams.string namespaces make timers assocs
|
||||
io.encodings.utf8 accessors calendar sequences ;
|
||||
io.encodings.utf8 accessors calendar sequences locals ;
|
||||
QUALIFIED: io.sockets
|
||||
IN: logging.insomniac
|
||||
|
||||
SYMBOL: insomniac-sender
|
||||
SYMBOL: insomniac-recipients
|
||||
|
||||
: ?analyze-log ( service word-names -- string/f )
|
||||
[ analyze-log-file ] with-string-writer ;
|
||||
|
||||
: email-subject ( service -- string )
|
||||
[
|
||||
"[INSOMNIAC] " % % " on " % io.sockets:host-name %
|
||||
"Log analysis for " % % " on " % io.sockets:host-name %
|
||||
] "" make ;
|
||||
|
||||
: (email-log-report) ( service word-names -- )
|
||||
dupd ?analyze-log [ drop ] [
|
||||
<email>
|
||||
swap >>body
|
||||
insomniac-recipients get >>to
|
||||
insomniac-sender get >>from
|
||||
swap email-subject >>subject
|
||||
send-email
|
||||
] if-empty ;
|
||||
:: (email-log-report) ( service word-names -- )
|
||||
<email>
|
||||
[ service word-names analyze-log-file ] with-string-writer >>body
|
||||
insomniac-recipients get >>to
|
||||
insomniac-sender get >>from
|
||||
service email-subject >>subject
|
||||
send-email ;
|
||||
|
||||
\ (email-log-report) NOTICE add-error-logging
|
||||
|
||||
|
|
@ -33,5 +28,5 @@ SYMBOL: insomniac-recipients
|
|||
"logging.insomniac" [ (email-log-report) ] with-logging ;
|
||||
|
||||
: schedule-insomniac ( service word-names -- )
|
||||
[ [ email-log-report ] assoc-each rotate-logs ] 2curry
|
||||
1 days delayed-every drop ;
|
||||
[ email-log-report rotate-logs ] 2curry
|
||||
1 days every drop ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: logging.tests
|
||||
USING: tools.test logging math ;
|
||||
USING: tools.test logging logging.analysis io math ;
|
||||
|
||||
: input-logging-test ( a b -- c ) + ;
|
||||
|
||||
|
|
@ -22,3 +22,5 @@ USING: tools.test logging math ;
|
|||
|
||||
[ f ] [ 1 0 error-logging-test ] unit-test
|
||||
] with-logging
|
||||
|
||||
[ ] [ "logging-test" { "input-logging-test" } analyze-log-file ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors peg peg.parsers memoize kernel sequences
|
||||
logging arrays words strings vectors io io.files
|
||||
io.encodings.utf8 namespaces make combinators logging.server
|
||||
calendar calendar.format assocs ;
|
||||
calendar calendar.format assocs prettyprint ;
|
||||
IN: logging.parser
|
||||
|
||||
TUPLE: log-entry date level word-name message ;
|
||||
|
|
@ -83,3 +83,20 @@ PEG: parse-log-line ( string -- entry ) 'log-line' ;
|
|||
: parse-log-file ( service -- entries )
|
||||
log-path 1 log# dup exists?
|
||||
[ utf8 file-lines parse-log ] [ drop f ] if ;
|
||||
|
||||
GENERIC: log-timestamp. ( date -- )
|
||||
|
||||
M: timestamp log-timestamp. (timestamp>string) ;
|
||||
M: word log-timestamp. drop "multiline" write ;
|
||||
|
||||
: log-entry. ( entry -- )
|
||||
"====== " write
|
||||
{
|
||||
[ date>> log-timestamp. bl ]
|
||||
[ level>> pprint bl ]
|
||||
[ word-name>> write nl ]
|
||||
[ message>> "\n" join print ]
|
||||
} cleave ;
|
||||
|
||||
: log-entries. ( errors -- )
|
||||
[ log-entry. ] each ;
|
||||
|
|
|
|||
|
|
@ -41,6 +41,6 @@ SYMBOL: half
|
|||
2 >>align
|
||||
2 >>align-first
|
||||
[ >float ] >>unboxer-quot
|
||||
\ half define-primitive-type
|
||||
\ half typedef
|
||||
|
||||
>>
|
||||
|
|
|
|||
|
|
@ -1,10 +1,14 @@
|
|||
USING: help.markup help.syntax ;
|
||||
USING: byte-arrays help.markup help.syntax kernel math ;
|
||||
IN: math.primes.erato
|
||||
|
||||
HELP: sieve
|
||||
{ $values { "n" "the greatest odd number to consider" } { "arr" "a bit array" } }
|
||||
{ $description "Apply Eratostene sieve up to " { $snippet "n" } ". Primality can then be tested using " { $link sieve } "." } ;
|
||||
{ $values { "n" integer } { "arr" byte-array } }
|
||||
{ $description "Apply Eratostene sieve up to " { $snippet "n" }
|
||||
". " { $snippet "n" } " must be greater than 1"
|
||||
". Primality can then be tested using " { $link marked-prime? } "." } ;
|
||||
|
||||
HELP: marked-prime?
|
||||
{ $values { "n" "an integer" } { "arr" "a byte array returned by " { $link sieve } } { "?" "a boolean" } }
|
||||
{ $description "Check whether a number between 3 and the limit given to " { $link sieve } " has been marked as a prime number."} ;
|
||||
{ $values { "n" integer } { "arr" byte-array } { "?" boolean } }
|
||||
{ $description "Checks whether " { $snippet "n" } " has been marked as a prime number. "
|
||||
{ $snippet "arr" } " must be " { $instance byte-array } " returned by " { $link sieve } ". "
|
||||
{ $snippet "n" } " must be between 2 and the limit given to " { $link sieve } "." } ;
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue