$(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
{ $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
"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
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 } ;
[ 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
! 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
SINGLETON: void
-DEFER: <int>
-DEFER: *char
-
TUPLE: abstract-c-type
{ class class initial: object }
{ boxed-class class initial: object }
M: c-type base-type ;
-: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
-
GENERIC: heap-size ( name -- size )
M: abstract-c-type heap-size size>> ;
: <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
[ >c-ptr ] >>unboxer-quot
"allot_alien" >>boxer
"alien_offset" >>unboxer
- \ void* define-primitive-type
+ \ void* typedef
<c-type>
fixnum >>class
"from_signed_2" >>boxer
"to_signed_2" >>unboxer
[ >fixnum ] >>unboxer-quot
- \ short define-primitive-type
+ \ short typedef
<c-type>
fixnum >>class
"from_unsigned_2" >>boxer
"to_unsigned_2" >>unboxer
[ >fixnum ] >>unboxer-quot
- \ ushort define-primitive-type
+ \ ushort typedef
<c-type>
fixnum >>class
"from_signed_1" >>boxer
"to_signed_1" >>unboxer
[ >fixnum ] >>unboxer-quot
- \ char define-primitive-type
+ \ char typedef
<c-type>
fixnum >>class
"from_unsigned_1" >>boxer
"to_unsigned_1" >>unboxer
[ >fixnum ] >>unboxer-quot
- \ uchar define-primitive-type
+ \ uchar typedef
<c-type>
math:float >>class
"to_float" >>unboxer
float-rep >>rep
[ >float ] >>unboxer-quot
- \ float define-primitive-type
+ \ float typedef
<c-type>
math:float >>class
"to_double" >>unboxer
double-rep >>rep
[ >float ] >>unboxer-quot
- \ double define-primitive-type
+ \ double typedef
cell 8 = [
<c-type>
"from_signed_4" >>boxer
"to_signed_4" >>unboxer
[ >fixnum ] >>unboxer-quot
- \ int define-primitive-type
+ \ int typedef
<c-type>
fixnum >>class
"from_unsigned_4" >>boxer
"to_unsigned_4" >>unboxer
[ >fixnum ] >>unboxer-quot
- \ uint define-primitive-type
+ \ uint typedef
<c-type>
integer >>class
8 >>align-first
"from_signed_cell" >>boxer
"to_fixnum" >>unboxer
- \ longlong define-primitive-type
+ [ >integer ] >>unboxer-quot
+ \ longlong typedef
<c-type>
integer >>class
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
4 >>align-first
"from_signed_cell" >>boxer
"to_fixnum" >>unboxer
- \ int define-primitive-type
+ [ >integer ] >>unboxer-quot
+ \ int typedef
<c-type>
integer >>class
4 >>align-first
"from_unsigned_cell" >>boxer
"to_cell" >>unboxer
- \ uint define-primitive-type
+ [ >integer ] >>unboxer-quot
+ \ uint typedef
<long-long-type>
integer >>class
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
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
[ >c-bool ] >>unboxer-quot
[ c-bool> ] >>boxer-quot
object >>boxed-class
- \ bool define-primitive-type
+ \ bool typedef
] with-compilation-unit
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>
{ $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." } ;
{ $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
"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." ;
{ $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 } ;
-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
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 ;
: 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 ;
}
{ $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"
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 )
{
[ {
[ 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
[ drop ]
[ drop ]
[ drop ]
- [ *float ]
+ [ float deref ]
[ drop ]
[ drop ]
} spread
[ [
! [<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]
{
[ {
[ ascii string>alien ]
- [ <float> ]
+ [ float <ref> ]
[ ascii string>alien ]
} spread ]
[ { [ length ] [ drop ] [ length ] } spread ]
[ ascii alien>nstring ]
[ ]
[ ascii alien>nstring ]
- [ *float ]
+ [ float deref ]
[ ]
[ ascii alien>nstring ]
} spread
! (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
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 ;
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 ;
] 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)
[ 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 ;
} 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>)
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
{ [ 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 -- )
-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
[ ] [ "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
! 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) ;
: 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* ;
{ $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 } ;
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
[ 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
! 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 } ;
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
<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>
M: bit-set clone
table>> clone bit-set boa ;
+
+M: bit-set cardinality
+ table>> bit-count ;
--- /dev/null
+USING: cache tools.test accessors destructors kernel assocs\r
+namespaces ;\r
+IN: cache.tests\r
+\r
+TUPLE: mock-disposable < disposable n ;\r
+\r
+: <mock-disposable> ( n -- mock-disposable )\r
+ mock-disposable new-disposable swap >>n ;\r
+\r
+M: mock-disposable dispose* drop ;\r
+\r
+[ ] [ <cache-assoc> "cache" set ] unit-test\r
+\r
+[ 0 ] [ "cache" get assoc-size ] unit-test\r
+\r
+[ ] [ "cache" get 2 >>max-age drop ] unit-test\r
+\r
+[ ] [ 1 <mock-disposable> dup "a" set 2 "cache" get set-at ] unit-test\r
+\r
+[ 1 ] [ "cache" get assoc-size ] unit-test\r
+\r
+[ ] [ "cache" get purge-cache ] unit-test\r
+\r
+[ ] [ 2 <mock-disposable> 3 "cache" get set-at ] unit-test\r
+\r
+[ 2 ] [ "cache" get assoc-size ] unit-test\r
+\r
+[ ] [ "cache" get purge-cache ] unit-test\r
+\r
+[ 1 ] [ "cache" get assoc-size ] unit-test\r
+\r
+[ ] [ 3 <mock-disposable> dup "b" set 4 "cache" get set-at ] unit-test\r
+\r
+[ 2 ] [ "cache" get assoc-size ] unit-test\r
+\r
+[ ] [ "cache" get purge-cache ] unit-test\r
+\r
+[ 1 ] [ "cache" get assoc-size ] unit-test\r
+\r
+[ f ] [ 2 "cache" get key? ] unit-test\r
+\r
+[ 3 ] [ 4 "cache" get at n>> ] unit-test\r
+\r
+[ t ] [ "a" get disposed>> ] unit-test\r
+\r
+[ f ] [ "b" get disposed>> ] unit-test\r
+\r
+[ ] [ "cache" get clear-assoc ] unit-test\r
+\r
+[ t ] [ "b" get disposed>> ] unit-test\r
[ <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 ;
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
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 } }
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
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 } }
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 } }
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
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
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" } }
{ $notes "User code should use the " { $link day-of-week } " word, which takes a " { $snippet "timestamp" } " instead of integers." } ;
HELP: days-in-year
-{ $values { "obj" "a timestamp or an integer" } { "n" integer } }
+{ $values { "obj" "a timestamp or an integer" } { "n" integer } }
{ $description "Calculates the number of days in a given year." }
{ $examples
{ $example "USING: calendar prettyprint ;"
! 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
timespec>duration since-1970 ;
: get-time ( -- alien )
- f time <time_t> localtime ;
+ f time time_t <ref> localtime ;
: timezone-name ( -- string )
get-time zone>> ;
! 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
--- /dev/null
+John Benediktsson
--- /dev/null
+! 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"
--- /dev/null
+! 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
--- /dev/null
+! 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! ;
--- /dev/null
+Hexadecimal colors
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 ;
[ 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
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.
[ ] [ "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> [
] 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
[
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
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
] 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
] cleaned-up-tree nodes>quot
] unit-test
-USING: alien alien.c-types ;
-
[ t ] [
[ int { } cdecl [ 2 2 + ] alien-callback ]
{ + } inlined?
! 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
: 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 ;
parallel-spread\r
parallel-napply\r
}\r
-"The " { $vocab-link "concurrency.semaphores" } " vocabulary can be used in conjuction with the above combinators to limit the maximum number of concurrent operations." ;\r
+"The " { $vocab-link "concurrency.semaphores" } " vocabulary can be used in conjunction with the above combinators to limit the maximum number of concurrent operations." ;\r
\r
ABOUT: "concurrency.combinators"\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: dlists kernel math concurrency.promises\r
-concurrency.mailboxes debugger accessors fry ;\r
+concurrency.mailboxes accessors fry ;\r
IN: concurrency.count-downs\r
\r
! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html\r
: test-node-client ( -- addrspec )
{
{ [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
- { [ os windows? ] [ test-ip insecure-port <inet4> ] }
+ { [ os windows? ] [ insecure-addr ] }
} cond ;
$nl\r
"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."\r
$nl\r
-"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."\r
+"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."\r
$nl\r
"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."\r
{ $subsections\r
--- /dev/null
+Slava Pestov\r
--- /dev/null
+! 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 ;
! 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 } ;
TUPLE: linked-error error thread ;
-M: linked-error error.
- [ thread>> error-in-thread. ] [ error>> error. ] bi ;
-
C: <linked-error> linked-error
: ?linked ( message -- message )
: spawn-linked-to ( quot name mailbox -- thread )
<linked-thread> [ (spawn) ] keep ;
+
+{ "concurrency.mailboxes" "debugger" } "concurrency.mailboxes.debugger" require-when
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup
+USING: help.syntax help.markup
threads kernel arrays quotations strings ;
IN: concurrency.messaging
HELP: send
-{ $values { "message" object }
- { "thread" thread }
+{ $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
-{ $values { "message" object }
+{ $values { "message" object }
}
-{ $description "Return a message from the current threads mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." }
+{ $description "Return a message from the current threads mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." }
{ $see-also send receive-if } ;
HELP: receive-if
-{ $values { "pred" "a predicate with stack effect " { $snippet "( obj -- ? )" } }
- { "message" object }
+{ $values { "pred" "a predicate with stack effect " { $snippet "( obj -- ? )" } }
+ { "message" object }
}
-{ $description "Return the first message from the current threads mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." }
+{ $description "Return the first message from the current threads mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." }
{ $see-also send receive } ;
HELP: spawn-linked
{ $values { "quot" quotation }
{ "name" string }
- { "thread" thread }
+ { "thread" thread }
}
-{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threads that restart child threads that crash due to uncaught errors.\n" }
+{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threads that restart child threads that crash due to uncaught errors.\n" }
{ $see-also spawn } ;
ARTICLE: { "concurrency" "messaging" } "Sending and receiving messages"
} ;
ARTICLE: { "concurrency" "exceptions" } "Linked exceptions"
-"A thread can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the thread will terminate. For example:"
-{ $code "[ 1 0 / \"This will not print\" print ] \"division-by-zero\" spawn" }
+"A thread can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the thread will terminate. For example:"
+{ $code "[ 1 0 / \"This will not print\" print ] \"division-by-zero\" spawn" }
"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threads can be created that are notified when child threads terminate and possibly restart them."
{ $subsections spawn-linked }
"This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:"
{ $code "["
" [ 1 0 / \"This will not print\" print ] \"linked-division\" spawn-linked drop"
" receive"
-"] [ \"Exception caught.\" print ] recover" }
+"] [ \"Exception caught.\" print ] recover" }
"Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ;
ARTICLE: "concurrency.messaging" "Message-passing concurrency"
! 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
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 ;
! 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
! 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 ;
! 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 ;
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 -- )
{ $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." ;
"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""" }
+ "my-database.db" temp-file <sqlite-db> swap with-db ; inline""" }
"PostgreSQL example combinator:"
{ $code """USING: db.postgresql db ;
{ "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"
- ""
}
} ;
{ 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 -- )
[
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 .
{ "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.
! 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
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 ;
{ $code
"""USING: eval listener vocabs.parser ;
[
- "cad-objects" use-vocab
+ "cad.objects" use-vocab
(( -- seq )) (eval)
] with-interactive-vocabs"""
}
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
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
'[
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
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" } "." } ;
-! Copyright (c) 2008 Slava Pestov\r
+! Copyright (c) 2008, 2010 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors assocs namespaces kernel sequences sets\r
-destructors combinators fry logging\r
-io.encodings.utf8 io.encodings.string io.binary random\r
-checksums checksums.sha urls\r
+destructors combinators fry logging io.encodings.utf8\r
+io.encodings.string io.binary io.sockets.secure random checksums\r
+checksums.sha urls\r
html.forms\r
http.server\r
http.server.filters\r
swap >>default\r
users-in-db >>users\r
sha-256 >>checksum\r
- t >>secure ; inline\r
+ ssl-supported? >>secure ; inline\r
\r
: users ( -- provider )\r
realm get users>> ;\r
<PRIVATE
-: (render-recaptcha) ( private-key -- xml )
+: (render-recaptcha) ( url -- xml )
dup
[XML
<script type="text/javascript"
-! 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
-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
: 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
} 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 {
"{ 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 } }"
$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 "sequence
s.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
{ $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.\" } ;"
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"
"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:"
{ $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"
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 )
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
$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"
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
}
"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"
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
[ "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
: 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
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
[ 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
] unit-test
[ "Goodbye" ] [
- "http://localhost/redirect" add-port http-get nip
+ "http://localhost/redirect" add-addr http-get nip
] unit-test
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>
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
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
[ "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
[ "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
] 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
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
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
-! 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
[ port-remapping get at ] keep or ;
: secure-http-port ( -- n )
- secure-port remap-port ;
+ secure-addr port>> remap-port ;
: 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 -- )
! 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 ;
! 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
: 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 -- )
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
{ $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^ >
}
{ $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"
}
}
{ $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"
}
! 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 ;
! 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 }
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 )
{
! 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
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 ;
! 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
{ "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
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
[ handle>> handle>> ]
[ buffer>> ]
[ buffer>> buffer-length ]
- [ drop DWORD <c-object> ]
+ [ drop 0 DWORD <ref> ]
[ FileArgs-overlapped ]
} cleave <FileArgs> ;
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 ;
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 )
[ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ]
[ "USERPROFILE" os-env ]
[ my-documents ]
- } 0|| ;
\ No newline at end of file
+ } 0|| ;
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> } "." } ;
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 )
} ;
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." } ;
{ $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." } ;
[ recursive>> 1 0 ? ]
} cleave
FILE_NOTIFY_CHANGE_ALL
- 0 <uint>
+ 0 uint <ref>
(make-overlapped)
[ f ReadDirectoryChangesW win32-error=0/f ] keep ;
"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 } "." ;
}
{ $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." } ;
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
[ 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 -- )
\ 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 ;
: 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 ;
<PRIVATE
-: first-port ( quot -- n/f )
- [ threaded-server get servers>> ] dip
- filter [ f ] [ first addr>> port>> ] if-empty ; inline
+GENERIC: connect-addr ( addrspec -- addrspec )
-PRIVATE>
+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> ;
-: secure-port ( -- n/f ) [ addr>> secure? ] first-port ;
+M: local connect-addr ;
+
+PRIVATE>
-: insecure-port ( -- n/f ) [ addr>> secure? not ] first-port ;
+: server-addrs ( -- addrspecs )
+ threaded-server get servers>> [ addr>> connect-addr ] map ;
-: secure-addr ( -- inet )
- threaded-server get servers>> [ addr>> secure? ] filter random ;
+: secure-addr ( -- addrspec )
+ server-addrs [ 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 ]
-! 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
SYMBOL: secure-socket-backend
+HOOK: ssl-supported? secure-socket-backend ( -- ? )
+
+M: object ssl-supported? f ;
+
SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ;
TUPLE: secure-config
-! 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
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 -- * )
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>" }
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>" }
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" } }
-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
! Binding to all interfaces should work
[ ] [ f 0 <inet4> <datagram> dispose ] unit-test
+[ ] [ f 0 <inet6> <datagram> dispose ] unit-test
{ [ os unix? ] [ "unix.ffi" ] }
} cond use-vocab >>
+GENERIC# with-port 1 ( addrspec port -- addrspec )
+
! Addressing
<PRIVATE
GENERIC: inet-pton ( str addrspec -- data )
-GENERIC# with-port 1 ( addrspec port -- addrspec )
-
: make-sockaddr/size ( addrspec -- sockaddr size )
[ make-sockaddr ] [ sockaddr-size ] bi ;
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 } ;
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 ;
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 ;
! 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 -- )
] 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 )
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 ]
opened-socket ;\r
\r
M: object (get-local-address) ( socket addrspec -- sockaddr )\r
- [ handle>> ] dip empty-sockaddr/size <int>\r
+ [ handle>> ] dip empty-sockaddr/size int <ref>\r
[ getsockname socket-error ] 2keep drop ;\r
\r
M: object (get-remote-address) ( socket addrspec -- sockaddr )\r
- [ handle>> ] dip empty-sockaddr/size <int>\r
+ [ handle>> ] dip empty-sockaddr/size int <ref>\r
[ getpeername socket-error ] 2keep drop ;\r
\r
: bind-socket ( win32-socket sockaddr len -- )\r
[ SOCK_RAW server-socket ] with-destructors ;\r
\r
: malloc-int ( n -- alien )\r
- <int> malloc-byte-array ; inline\r
+ int <ref> malloc-byte-array ; inline\r
\r
M: winnt WSASocket-flags ( -- DWORD )\r
WSA_FLAG_OVERLAPPED ;\r
{ void* }\r
[\r
void* heap-size\r
- DWORD <c-object>\r
+ 0 DWORD <ref>\r
f\r
f\r
WSAIoctl SOCKET_ERROR = [\r
} cleave AcceptEx drop winsock-error ; inline\r
\r
: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )\r
- f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;\r
+ f void* <ref> 0 int <ref> f void* <ref>\r
+ [ 0 int <ref> GetAcceptExSockaddrs ] keep void* deref ;\r
\r
: extract-remote-address ( AcceptEx -- sockaddr )\r
[\r
[\r
[ port>> addr>> empty-sockaddr dup ]\r
[ lpFrom>> ]\r
- [ lpFromLen>> *int ]\r
+ [ lpFromLen>> int deref ]\r
tri memcpy\r
] bi ; inline\r
\r
swap make-send-buffer >>lpBuffers\r
1 >>dwBufferCount\r
0 >>dwFlags\r
- 0 <uint> >>lpNumberOfBytesSent\r
+ 0 uint <ref> >>lpNumberOfBytesSent\r
(make-overlapped) >>lpOverlapped ; inline\r
\r
: call-WSASendTo ( WSASendTo -- )\r
"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"
{ $description "A value for the " { $link font-style } " character style denoting boldface italicized text." } ;
HELP: foreground
-{ $description "Character style. An instance of " { $link color } ". See " { $link "colors" } "." }
+{ $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"
}
} ;
{ $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"
}
} ;
{ $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"
}
} ;
{ $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
{ $description "Character and paragraph style. An object associated with the text. In the Factor UI, this is shown as a clickable presentation of the object; left-clicking invokes a default command, and right-clicking shows a menu of commands." } ;
HELP: page-color
-{ $description "Paragraph style. An instance of " { $link color } ". See " { $link "colors" } "." }
+{ $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." }
+{ $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
{ $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>
{ $link make-span-stream } ", "
{ $link make-block-stream } " and "
{ $link make-cell-stream } "."
-{ $subsections plain-writer } ;
\ No newline at end of file
+{ $subsections plain-writer } ;
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 ;
{ $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: $[
{ $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: ${
{ $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 }"
}
} ;
{ $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"
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: $[
-! Copyright (C) 2008 Slava Pestov.\r
+! Copyright (C) 2008, 2010 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel sequences namespaces words assocs logging sorting\r
prettyprint io io.styles io.files io.encodings.utf8\r
-strings combinators accessors arrays\r
+strings combinators accessors arrays math\r
logging.server logging.parser calendar.format ;\r
IN: logging.analysis\r
\r
] when\r
drop ;\r
\r
+: recent-histogram ( assoc n -- alist )\r
+ [ >alist sort-values <reversed> ] dip short head ;\r
+\r
: analyze-entries ( entries word-names -- errors word-histogram message-histogram )\r
[\r
word-names set\r
H{ } clone word-histogram set\r
H{ } clone message-histogram set\r
\r
- [\r
- analyze-entry\r
- ] each\r
+ [ analyze-entry ] each\r
\r
errors get\r
- word-histogram get\r
- message-histogram get\r
+ word-histogram get 10 recent-histogram\r
+ message-histogram get 10 recent-histogram\r
] with-scope ;\r
\r
: histogram. ( assoc quot -- )\r
standard-table-style [\r
- [ >alist sort-values <reversed> ] dip [\r
+ [\r
[ swapd with-cell pprint-cell ] with-row\r
] curry assoc-each\r
] tabular-output ; inline\r
\r
-: log-entry. ( entry -- )\r
- "====== " write\r
- {\r
- [ date>> (timestamp>string) bl ]\r
- [ level>> pprint bl ]\r
- [ word-name>> write nl ]\r
- [ message>> "\n" join print ]\r
- } cleave ;\r
+: 10-most-recent ( errors -- errors )\r
+ 10 tail* "Only showing 10 most recent errors" print nl ;\r
\r
: errors. ( errors -- )\r
- [ log-entry. ] each ;\r
+ dup length 10 >= [ 10-most-recent ] when\r
+ log-entries. ;\r
\r
: analysis. ( errors word-histogram message-histogram -- )\r
- "==== INTERESTING MESSAGES:" print nl\r
+ nl "==== FREQUENT MESSAGES:" print nl\r
"Total: " write dup values sum . nl\r
[\r
- dup level>> write ": " write message>> "\n" join write\r
+ [ first name>> write bl ]\r
+ [ second write ": " write ]\r
+ [ third "\n" join write ]\r
+ tri\r
] histogram.\r
- nl\r
- "==== WORDS:" print nl\r
+ nl nl\r
+ "==== FREQUENT WORDS:" print nl\r
[ write ] histogram.\r
- nl\r
+ nl nl\r
"==== ERRORS:" print nl\r
errors. ;\r
\r
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 } "." } ;
-! Copyright (C) 2008 Slava Pestov.\r
+! Copyright (C) 2008, 2010 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: logging.analysis logging.server logging smtp kernel\r
io.files io.streams.string namespaces make timers assocs\r
-io.encodings.utf8 accessors calendar sequences ;\r
+io.encodings.utf8 accessors calendar sequences locals ;\r
QUALIFIED: io.sockets\r
IN: logging.insomniac\r
\r
SYMBOL: insomniac-sender\r
SYMBOL: insomniac-recipients\r
\r
-: ?analyze-log ( service word-names -- string/f )\r
- [ analyze-log-file ] with-string-writer ;\r
-\r
: email-subject ( service -- string )\r
[\r
- "[INSOMNIAC] " % % " on " % io.sockets:host-name %\r
+ "Log analysis for " % % " on " % io.sockets:host-name %\r
] "" make ;\r
\r
-: (email-log-report) ( service word-names -- )\r
- dupd ?analyze-log [ drop ] [\r
- <email>\r
- swap >>body\r
- insomniac-recipients get >>to\r
- insomniac-sender get >>from\r
- swap email-subject >>subject\r
- send-email\r
- ] if-empty ;\r
+:: (email-log-report) ( service word-names -- )\r
+ <email>\r
+ [ service word-names analyze-log-file ] with-string-writer >>body\r
+ insomniac-recipients get >>to\r
+ insomniac-sender get >>from\r
+ service email-subject >>subject\r
+ send-email ;\r
\r
\ (email-log-report) NOTICE add-error-logging\r
\r
"logging.insomniac" [ (email-log-report) ] with-logging ;\r
\r
: schedule-insomniac ( service word-names -- )\r
- [ [ email-log-report ] assoc-each rotate-logs ] 2curry\r
- 1 days delayed-every drop ;\r
+ [ email-log-report rotate-logs ] 2curry\r
+ 1 days every drop ;\r
IN: logging.tests
-USING: tools.test logging math ;
+USING: tools.test logging logging.analysis io math ;
: input-logging-test ( a b -- c ) + ;
[ f ] [ 1 0 error-logging-test ] unit-test
] with-logging
+
+[ ] [ "logging-test" { "input-logging-test" } analyze-log-file ] unit-test
-! Copyright (C) 2008 Slava Pestov.\r
+! Copyright (C) 2008, 2010 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors peg peg.parsers memoize kernel sequences\r
logging arrays words strings vectors io io.files\r
io.encodings.utf8 namespaces make combinators logging.server\r
-calendar calendar.format assocs ;\r
+calendar calendar.format assocs prettyprint ;\r
IN: logging.parser\r
\r
TUPLE: log-entry date level word-name message ;\r
: parse-log-file ( service -- entries )\r
log-path 1 log# dup exists?\r
[ utf8 file-lines parse-log ] [ drop f ] if ;\r
+\r
+GENERIC: log-timestamp. ( date -- )\r
+\r
+M: timestamp log-timestamp. (timestamp>string) ;\r
+M: word log-timestamp. drop "multiline" write ;\r
+\r
+: log-entry. ( entry -- )\r
+ "====== " write\r
+ {\r
+ [ date>> log-timestamp. bl ]\r
+ [ level>> pprint bl ]\r
+ [ word-name>> write nl ]\r
+ [ message>> "\n" join print ]\r
+ } cleave ;\r
+\r
+: log-entries. ( errors -- )\r
+ [ log-entry. ] each ;\r
2 >>align
2 >>align-first
[ >float ] >>unboxer-quot
-\ half define-primitive-type
+\ half typedef
>>
-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 } "." } ;
-USING: byte-arrays math math.bitwise math.primes.erato sequences tools.test ;
+USING: kernel byte-arrays sequences tools.test ;
+USING: math math.bitwise math.ranges math.primes.erato ;
[ B{ 255 251 247 126 } ] [ 100 sieve ] unit-test
[ 1 100 sieve marked-prime? ] [ bounds-error? ] must-fail-with
! There are 25997 primes below 300000. 1 must be removed and 3 5 7 added.
[ 25997 ] [ 299999 sieve [ bit-count ] map-sum 2 + ] unit-test
+
+! Check sieve array length logic by making sure we get the right
+! end-point for numbers with all possibilities mod 30. If something
+! were to go wrong, we'd get a bounds-error.
+[ ] [ 2 100 [a,b] [ dup sieve marked-prime? drop ] each ] unit-test
2drop
] if ;
-: init-sieve ( n -- arr )
29 + 30 /i 255 <array> >byte-array ;
+: init-sieve ( n -- arr )
30 /i 1 + 255 <array> >byte-array ;
PRIVATE>
! Copyright (C) 2008, 2009 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors models kernel ;\r
+USING: accessors models kernel sequences ;\r
IN: models.arrow\r
\r
-TUPLE: arrow < model model quot ;\r
+TUPLE: arrow < model quot ;\r
\r
: <arrow> ( model quot -- arrow )\r
f arrow new-model\r
swap >>quot\r
- over >>model\r
[ add-dependency ] keep ;\r
\r
M: arrow model-changed\r
[ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi\r
set-model ;\r
\r
-M: arrow model-activated [ model>> ] keep model-changed ;\r
+M: arrow model-activated\r
+ [ dependencies>> ] keep [ model-changed ] curry each ;\r
HELP: HEREDOC:
{ $syntax "HEREDOC: marker\n...text...\nmarker" }
{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } }
-{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after " { $link POSTPONE: HEREDOC: } " until the end of the line containing " { $link POSTPONE: HEREDOC: } ". Text is captured until a line is found conatining exactly this delimter string." }
+{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after " { $link POSTPONE: HEREDOC: } " until the end of the line containing " { $link POSTPONE: HEREDOC: } ". Text is captured until a line is found containing exactly this delimiter string." }
{ $warning "Whitespace is significant." }
{ $examples
{ $example "USING: multiline prettyprint ;"
[ 1 { uint } ] dip with-out-parameters ; inline
: (delete-gl-object) ( id quot -- )
- [ 1 swap <uint> ] dip call ; inline
+ [ 1 swap uint <ref> ] dip call ; inline
: gen-gl-buffer ( -- id )
[ glGenBuffers ] (gen-gl-object) ;
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
-assocs alien alien.data alien.strings libc opengl math sequences combinators
-macros arrays io.encodings.ascii fry specialized-arrays
-destructors accessors ;
+assocs alien alien.data alien.strings libc opengl math sequences
+combinators macros arrays io.encodings.ascii fry
+specialized-arrays destructors accessors ;
SPECIALIZED-ARRAY: uint
IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- )
- swap ascii malloc-string [ <void*> swap call ] keep free ; inline
+ swap ascii malloc-string [ void* <ref> swap call ] keep free ; inline
: <gl-shader> ( source kind -- shader )
glCreateShader dup rot
: gl-shader-info-log ( shader -- log )
dup gl-shader-info-log-length dup [
1 calloc &free
- [ 0 <int> swap glGetShaderInfoLog ] keep
+ [ 0 int <ref> swap glGetShaderInfoLog ] keep
ascii alien>string
] with-destructors ;
: gl-program-info-log ( program -- log )
dup gl-program-info-log-length dup [
1 calloc &free
- [ 0 <int> swap glGetProgramInfoLog ] keep
+ [ 0 int <ref> swap glGetProgramInfoLog ] keep
ascii alien>string
] with-destructors ;
: gl-program-shaders ( program -- shaders )
dup gl-program-shaders-length 2 *
- 0 <int>
+ 0 int <ref>
over <uint-array>
[ glGetAttachedShaders ] keep [ zero? not ] filter ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays assocs byte-arrays
-byte-vectors combinators fry io.backend io.binary kernel locals
-math math.bitwise math.constants math.functions math.order
-math.ranges namespaces sequences sets summary system
+USING: accessors alien.c-types alien.data arrays assocs
+byte-arrays byte-vectors combinators fry io.backend io.binary
+kernel locals math math.bitwise math.constants math.functions
+math.order math.ranges namespaces sequences sets summary system
vocabs.loader ;
IN: random
secure-random-generator get swap with-random ; inline
: uniform-random-float ( min max -- n )
- 4 random-bytes underlying>> *uint >float
- 4 random-bytes underlying>> *uint >float
+ 4 random-bytes underlying>> uint deref >float
+ 4 random-bytes underlying>> uint deref >float
2.0 32 ^ * +
[ over - 2.0 -64 ^ * ] dip
* + ; inline
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types kernel locals math math.ranges
-math.bitwise math.vectors math.vectors.simd random
+USING: accessors alien.c-types alien.data kernel locals math
+math.ranges math.bitwise math.vectors math.vectors.simd random
sequences specialized-arrays sequences.private classes.struct
combinators.short-circuit fry ;
SPECIALIZED-ARRAY: uint
<PRIVATE
: ns ( n lengths -- ns )
- [ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ;
+ [ /mod ] map nip ;
: nths ( ns seqs -- nths )
[ nth ] { } 2map-as ;
[ 0 over [ 1 + ] change-nth ] dip carry-ns ;
: start-product-iter ( sequences -- ns lengths )
- [ [ drop 0 ] map ] [ [ length ] map ] bi ;
+ [ length 0 <array> ] [ [ length ] map ] bi ;
: end-product-iter? ( ns lengths -- ? )
- [ 1 tail* first ] bi@ = ;
+ [ last ] bi@ = ;
PRIVATE>
{ { $snippet "T-array" } { "The class of arrays with elements of type " { $snippet "T" } } }
{ { $snippet "<T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( len -- array )" } } }
{ { $snippet "(T-array)" } { "Constructor for arrays with elements of type " { $snippet "T" } ", where the initial contents are uninitialized; stack effect " { $snippet "( len -- array )" } } }
- { { $snippet "malloc-T-array" } { "Constructor for arrays with elements of type " { $snippet "T" } " backed by newly-allocated unmanaged memory; stack effect " { $snippet "( alien len -- array )" } } }
+ { { $snippet "malloc-T-array" } { "Constructor for arrays with elements of type " { $snippet "T" } " backed by newly-allocated, zeroed out, unmanaged memory; stack effect " { $snippet "( len -- array )" } } }
{ { $snippet "<direct-T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } " backed by raw memory; stack effect " { $snippet "( alien len -- array )" } } }
{ { $snippet "T-array-cast" } { "Converts a byte array into a specialized array by interpreting the bytes in as machine-specific values. Code which uses this word is unportable" } }
{ { $snippet ">T-array" } { "Converts a sequence into a specialized array of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- array )" } } }
}
"Finally, sometimes a C library returns a pointer to an array in unmanaged memory, together with a length. In this case, a specialized array can be constructed to view this memory using " { $snippet "<direct-T-array>" } ":"
{ $code
- "USING: alien.c-types classes.struct ;"
+ "USING: alien.c-types alien.data classes.struct ;"
""
"STRUCT: device_info"
" { id int }"
""
"FUNCTION: void get_device_info ( int* length ) ;"
""
- "0 <int> [ get_device_info ] keep <direct-int-array> ."
+ "0 int <ref> [ get_device_info ] keep <direct-int-array> ."
}
"For a full discussion of Factor heap allocation versus unmanaged memory allocation, see " { $link "byte-arrays-gc" } "."
$nl
alien.data math.vectors definitions compiler.test ;
FROM: specialized-arrays.private => specialized-array-vocab ;
FROM: alien.c-types => int float bool char float ulonglong ushort uint
-heap-size little-endian? ;
+heap-size ;
+FROM: alien.data => little-endian? ;
IN: specialized-arrays.tests
SPECIALIZED-ARRAY: int
\ bignum> { bignum bignum } { object } define-primitive \ bignum> make-foldable
\ bignum>= { bignum bignum } { object } define-primitive \ bignum>= make-foldable
\ bignum>fixnum { bignum } { fixnum } define-primitive \ bignum>fixnum make-foldable
-\ bignum>float { bignum } { float } define-primitive \ bignum>float make-foldable
\ bits>double { integer } { float } define-primitive \ bits>double make-foldable
\ bits>float { integer } { float } define-primitive \ bits>float make-foldable
\ both-fixnums? { object object } { object } define-primitive
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings alien.syntax
+USING: alien alien.c-types alien.data alien.strings alien.syntax
byte-arrays kernel namespaces sequences unix
system-info.backend system io.encodings.utf8 ;
IN: system-info.macosx
FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, void* newp, size_t newlen ) ;
: make-int-array ( seq -- byte-array )
- [ <int> ] map concat ;
+ [ int <ref> ] map concat ;
: (sysctl-query) ( name namelen oldp oldlenp -- oldp )
over [ f 0 sysctl io-error ] dip ;
: sysctl-query ( seq n -- byte-array )
[ [ make-int-array ] [ length ] bi ] dip
- [ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
+ [ <byte-array> ] [ uint <ref> ] bi (sysctl-query) ;
: sysctl-query-string ( seq -- n )
4096 sysctl-query utf8 alien>string ;
: sysctl-query-uint ( seq -- n )
- 4 sysctl-query *uint ;
+ 4 sysctl-query uint deref ;
: sysctl-query-ulonglong ( seq -- n )
- 8 sysctl-query *ulonglong ;
+ 8 sysctl-query ulonglong deref ;
: machine ( -- str ) { 6 1 } sysctl-query-string ;
: model ( -- str ) { 6 2 } sysctl-query-string ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.strings byte-arrays
-classes.struct combinators kernel math namespaces
-specialized-arrays system
-system-info.backend vocabs.loader windows windows.advapi32
-windows.errors windows.kernel32 words ;
+USING: accessors alien alien.c-types alien.data alien.strings
+byte-arrays classes.struct combinators kernel math namespaces
+specialized-arrays system system-info.backend vocabs.loader
+windows windows.advapi32 windows.errors windows.kernel32 words ;
SPECIALIZED-ARRAY: ushort
IN: system-info.windows
: computer-name ( -- string )
MAX_COMPUTERNAME_LENGTH 1 +
- [ <byte-array> dup ] keep <uint>
+ [ <byte-array> dup ] keep uint <ref>
GetComputerName win32-error=0/f alien>native-string ;
: username ( -- string )
UNLEN 1 +
- [ <byte-array> dup ] keep <uint>
+ [ <byte-array> dup ] keep uint <ref>
GetUserName win32-error=0/f alien>native-string ;
{ "timer" timer } }\r
{ $description "Creates a timer that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the timer will stop." }\r
{ $examples\r
- { $unchecked-example\r
+ { $code\r
"USING: timers io calendar ;"\r
"""[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
- ""\r
}\r
} ;\r
\r
{ $values { "quot" quotation } { "delay-duration" duration } { "timer" timer } }\r
{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the timer before " { $snippet "quot" } " runs. This timer is not repeated." }\r
{ $examples\r
- { $unchecked-example\r
+ { $code\r
"USING: timers io calendar ;"\r
"""[ "Break's over!" print flush ] 15 minutes later drop"""\r
- ""\r
}\r
} ;\r
\r
{ "timer" timer } }\r
{ $description "Creates a timer that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the timer will stop." }\r
{ $examples\r
- { $unchecked-example\r
+ { $code\r
"USING: timers io calendar ;"\r
"""[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
- ""\r
}\r
} ;\r
\r
{ $notes "The sequence might include the definition itself, if it is a recursive word." }
{ $examples
"We can ask the " { $link sq } " word to produce a list of words it calls:"
- { $unchecked-example "\ sq uses ." "{ dup * }" }
+ { $unchecked-example "\\ sq uses ." "{ dup * }" }
} ;
HELP: crossref
$nl
"Off by default."
$nl
-"The optimizing compiler is able to fold away calls to various words which take a C type as an input if the C type is a literal string:"
+"The optimizing compiler is able to fold away calls to various words which take a C type as an input if the C type is a literal string, for example,"
{ $list
{ $link c-type }
{ $link heap-size }
- { $link <c-object> }
{ $link <c-array> }
+ { $link <c-direct-array> }
{ $link malloc-array }
+ { $link <ref> }
+ { $link deref }
}
"If your program looks up C types dynamically or from words which do not have a stack effect, you must enable this flag, because in these situations the C type lookup code is not folded away and the word properties must be consulted at runtime." } ;
[ ] [ "resource:license.txt" "license.txt" temp-file copy-file ] unit-test
[ ] [ "tools.deploy.test.19" shake-and-bake run-temp-image ] unit-test
+
+[ ] [ "benchmark.ui-panes" shake-and-bake run-temp-image ] unit-test
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: dns io kernel math.parser sequences ;
+IN: tools.dns
+
+: a-line. ( host ip -- )
+ [ write " has address " write ] [ print ] bi* ;
+
+: a-message. ( message -- )
+ [ message>query-name ] [ message>names ] bi
+ [ a-line. ] with each ;
+
+: mx-line. ( host pair -- )
+ [ write " mail is handled by " write ]
+ [ first2 [ number>string write bl ] [ print ] bi* ] bi* ;
+
+: mx-message. ( message -- )
+ [ message>query-name ] [ message>mxs ] bi
+ [ mx-line. ] with each ;
+
+: host ( domain -- )
+ [ dns-A-query a-message. ]
+ [ dns-AAAA-query a-message. ]
+ [ dns-MX-query mx-message. ] tri ;
: make-context-transparent ( view -- )
-> openGLContext
- 0 <int> NSOpenGLCPSurfaceOpacity -> setValues:forParameter: ;
+ 0 int <ref> NSOpenGLCPSurfaceOpacity -> setValues:forParameter: ;
M:: cocoa-ui-backend (open-window) ( world -- )
world [ [ dim>> ] dip <FactorView> ]
]
: sync-refresh-to-screen ( GLView -- )
- -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
+ -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 int <ref>
CGLSetParameter drop ;
: <FactorView> ( dim pixel-format -- view )
! Copyright (C) 2005, 2006 Doug Coleman.
! Portions copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings arrays assocs ui
+USING: alien alien.data alien.strings arrays assocs ui
ui.private ui.gadgets ui.gadgets.private ui.backend
ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io
kernel math math.vectors namespaces make sequences strings
-vectors words windows.dwmapi system-info.windows windows.kernel32
-windows.gdi32 windows.user32 windows.opengl32 windows.messages
-windows.types windows.offscreen windows threads libc combinators
-fry combinators.short-circuit continuations command-line shuffle
-opengl ui.render math.bitwise locals accessors math.rectangles
-math.order calendar ascii sets io.encodings.utf16n
-windows.errors literals ui.pixel-formats
+vectors words windows.dwmapi system-info.windows
+windows.kernel32 windows.gdi32 windows.user32 windows.opengl32
+windows.messages windows.types windows.offscreen windows threads
+libc combinators fry combinators.short-circuit continuations
+command-line shuffle opengl ui.render math.bitwise locals
+accessors math.rectangles math.order calendar ascii sets
+io.encodings.utf16n windows.errors literals ui.pixel-formats
ui.pixel-formats.private memoize classes colors
-specialized-arrays classes.struct alien.data ;
+specialized-arrays classes.struct ;
FROM: namespaces => set ;
SPECIALIZED-ARRAY: POINT
+QUALIFIED-WITH: alien.c-types c
IN: ui.backend.windows
SINGLETON: windows-ui-backend
drop f ;
: arb-make-pixel-format ( world attributes -- pf )
- [ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 { int int }
+ [ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 { c:int c:int }
[ wglChoosePixelFormatARB win32-error=0/f ] with-out-parameters drop ;
: arb-pixel-format-attribute ( pixel-format attribute -- value )
>WGL_ARB
[ drop f ] [
[ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
- first <int> { int }
+ first c:int <ref> { c:int }
[ wglGetPixelFormatAttribivARB win32-error=0/f ]
with-out-parameters
] if-empty ;
: >pfd ( attributes -- pfd )
[ PIXELFORMATDESCRIPTOR <struct> ] dip
{
- [ drop PIXELFORMATDESCRIPTOR heap-size >>nSize ]
+ [ drop PIXELFORMATDESCRIPTOR c:heap-size >>nSize ]
[ drop 1 >>nVersion ]
[ >pfd-flags >>dwFlags ]
[ drop PFD_TYPE_RGBA >>iPixelType ]
: get-pfd ( pixel-format -- pfd )
[ world>> handle>> hDC>> ] [ handle>> ] bi
- PIXELFORMATDESCRIPTOR heap-size
+ PIXELFORMATDESCRIPTOR c:heap-size
PIXELFORMATDESCRIPTOR <struct>
[ DescribePixelFormat win32-error=0/f ] keep ;
: pfd-flag? ( pfd flag -- ? )
- [ dwFlags>> ] dip bitand c-bool> ;
+ [ dwFlags>> ] dip bitand c:c-bool> ;
: (pfd-pixel-format-attribute) ( pfd attribute -- value )
{
PRIVATE>
-: lo-word ( wparam -- lo ) <short> *short ; inline
+: lo-word ( wparam -- lo ) c:short <ref> c:short deref ; inline
: hi-word ( wparam -- hi ) -16 shift lo-word ; inline
: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
: GET_APPCOMMAND_LPARAM ( lParam -- appCommand )
: make-TRACKMOUSEEVENT ( hWnd -- alien )
TRACKMOUSEEVENT <struct>
swap >>hwndTrack
- TRACKMOUSEEVENT heap-size >>cbSize ;
+ TRACKMOUSEEVENT c:heap-size >>cbSize ;
: handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
2nip
! return 0 if you handle the message, else just let DefWindowProc return its val
: ui-wndproc ( -- object )
- uint { void* uint long long } stdcall [
+ c:uint { c:void* c:uint c:long c:long } stdcall [
pick
trace-messages? get-global
:: register-window-class ( class-name-ptr -- )
WNDCLASSEX <struct> f GetModuleHandle
class-name-ptr pick GetClassInfoEx 0 = [
- WNDCLASSEX heap-size >>cbSize
+ WNDCLASSEX c:heap-size >>cbSize
flags{ CS_HREDRAW CS_VREDRAW CS_OWNDC } >>style
ui-wndproc >>lpfnWndProc
0 >>cbClsExtra
: fullscreen-RECT ( hwnd -- RECT )
MONITOR_DEFAULTTONEAREST MonitorFromWindow
MONITORINFOEX <struct>
- MONITORINFOEX heap-size >>cbSize
+ MONITORINFOEX c:heap-size >>cbSize
[ GetMonitorInfo win32-error=0/f ] keep rcMonitor>> ;
: client-area>RECT ( hwnd -- RECT )
}
{ $examples
"The following " { $link world } " subclass will request a double-buffered window with minimum 24-bit color and depth buffers, and will throw an error if the requirements aren't met:"
-{ $code """
-USING: kernel ui.worlds ui.pixel-formats ;
+{ $code """USING: kernel ui.gadgets.worlds ui.pixel-formats ;
IN: ui.pixel-formats.examples
TUPLE: picky-depth-buffered-world < world ;
[ double-buffered pixel-format-attribute 0 = [ "Not double buffered!" throw ] when ]
[ color-bits pixel-format-attribute 24 < [ "Not enough color bits!" throw ] when ]
[ depth-bits pixel-format-attribute 24 < [ "Not enough depth bits!" throw ] when ]
- tri ;
-""" } }
+ tri ;""" } }
;
HELP: double-buffered
HELP: register-window
{ $values { "world" world } { "handle" "a backend-specific handle" } }
{ $description "Adds a window to the global " { $link windows } " variable." }
-{ $notes "This word should only be called by the UI backend. User code can open new windows with " { $link open-window } "." } ;
+{ $notes "This word should only be called by the UI backend. User code can open new windows with " { $link open-window } "." } ;
HELP: unregister-window
{ $values { "handle" "a backend-specific handle" } }
HELP: with-ui
{ $values { "quot" { $quotation "( -- )" } } }
{ $description "Calls the quotation, starting the UI first if necessary. If the UI is started, this word does not return." }
-{ $notes "This word should be used in the " { $link POSTPONE: MAIN: } " word of an application that uses the UI in order for the vocabulary to work when run from either the UI listener (" { $snippet "\"my-app\" run" } " and the command line (" { $snippet "./factor -run=my-app" } ")." }
+{ $notes "This word should be used in the " { $link POSTPONE: MAIN: } " word of an application that uses the UI in order for the vocabulary to work when run from either the UI listener (" { $snippet "\"my-app\" run" } ") and the command line (" { $snippet "./factor -run=my-app" } ")." }
{ $examples "The " { $vocab-link "hello-ui" } " vocabulary implements a simple UI application which uses this word." } ;
HELP: beep
}
"Gadgets implement a generic word to inform their parents of their preferred size:"
{ $subsections pref-dim* }
-"To get a gadget's preferred size, do not call the above word, instead use " { $link pref-dim } ", which caches the result." ;
+"To get a gadget's preferred size, do not call the above word, instead use " { $link pref-dim } ", which caches the result." ;
ARTICLE: "ui-null-layout" "Manual layouts"
"When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually by setting the " { $snippet "loc" } " field." ;
CONSTANT: AF_UNSPEC 0
CONSTANT: AF_UNIX 1
CONSTANT: AF_INET 2
-CONSTANT: AF_INET6 30
ALIAS: PF_UNSPEC AF_UNSPEC
ALIAS: PF_UNIX AF_UNIX
ALIAS: PF_INET AF_INET
-ALIAS: PF_INET6 AF_INET6
CONSTANT: IPPROTO_TCP 6
CONSTANT: IPPROTO_UDP 17
USING: alien.c-types alien.syntax classes.struct unix.types ;
IN: unix.ffi
+CONSTANT: AF_INET6 28
+ALIAS: PF_INET6 AF_INET6
+
CONSTANT: FD_SETSIZE 1024
STRUCT: addrinfo
CONSTANT: FD_SETSIZE 1024
+CONSTANT: AF_INET6 30
+ALIAS: PF_INET6 AF_INET6
+
STRUCT: addrinfo
{ flags int }
{ family int }
USING: alien.c-types alien.syntax classes.struct unix.types ;
IN: unix.ffi
+CONSTANT: AF_INET6 24
+ALIAS: PF_INET6 AF_INET6
+
CONSTANT: FD_SETSIZE 1024
STRUCT: addrinfo
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.strings assocs
-byte-arrays classes.struct combinators
+USING: accessors alien alien.c-types alien.data alien.strings
+assocs byte-arrays classes.struct combinators
combinators.short-circuit continuations fry io.backend.unix
io.encodings.utf8 kernel math math.parser namespaces sequences
splitting strings unix unix.ffi unix.users unix.utilities ;
: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
[ \ unix.ffi:group <struct> ] dip over 4096
- [ <byte-array> ] keep f <void*> ;
+ [ <byte-array> ] keep f void* <ref> ;
: check-group-struct ( group-struct ptr -- group-struct/f )
- *void* [ drop f ] unless ;
+ void* deref [ drop f ] unless ;
M: integer group-struct ( id -- group/f )
(group-struct)
<PRIVATE
: >groups ( byte-array n -- groups )
- [ 4 grouping:group ] dip head-slice [ *uint group-name ] map ;
+ [ 4 grouping:group ] dip head-slice [ uint deref group-name ] map ;
: (user-groups) ( string -- seq )
#! first group is -1337, legacy unix code
-1337 unix.ffi:NGROUPS_MAX [ 4 * <byte-array> ] keep
- <int> [ [ unix.ffi:getgrouplist ] unix-system-call drop ] 2keep
- [ 4 tail-slice ] [ *int 1 - ] bi* >groups ;
+ int <ref> [ [ unix.ffi:getgrouplist ] unix-system-call drop ] 2keep
+ [ 4 tail-slice ] [ int deref 1 - ] bi* >groups ;
PRIVATE>
TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: long time_t
-
-ALIAS: <time_t> <long>
TYPEDEF: ulonglong __fsfilcnt64_t
TYPEDEF: ulonglong ino64_t
TYPEDEF: ulonglong off64_t
-
-ALIAS: <time_t> <long>
\ No newline at end of file
TYPEDEF: kern_return_t IOReturn
TYPEDEF: uint IOOptionBits
-
-
-
-ALIAS: <time_t> <long>
TYPEDEF: int pid_t
TYPEDEF: int time_t
-ALIAS: <time_t> <int>
-
cell-bits {
{ 32 [ "unix.types.netbsd.32" require ] }
{ 64 [ "unix.types.netbsd.64" require ] }
TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: int time_t
-
-ALIAS: <time_t> <int>
\ No newline at end of file
{ $description "Creates a new passwd tuple dependent on the operating system." } ;
HELP: passwd
-{ $description "A platform-specific tuple correspding to every field from the Unix passwd struct. BSD passwd structures have four extra slots: " { $slot "change" } ", " { $slot "class" } "," { $slot "expire" } ", " { $slot "fields" } "." } ;
+{ $description "A platform-specific tuple corresponding to every field from the Unix passwd struct. BSD passwd structures have four extra slots: " { $slot "change" } ", " { $slot "class" } ", " { $slot "expire" } ", " { $slot "fields" } "." } ;
HELP: user-cache
{ $description "A symbol storing passwd structures indexed by user-ids when within a " { $link with-user-cache } "." } ;
{
real-user-name real-user-id set-real-user
- effective-user-name effective-user-id
+ effective-user-name effective-user-id
set-effective-user
} related-words
HELP: all-user-names
{ $values
-
+
{ "seq" sequence }
}
{ $description "Returns a sequence of group names as strings." } ;
SPECIALIZED-ARRAY: void*
: more? ( alien -- ? )
- { [ ] [ *void* ] } 1&& ;
+ { [ ] [ void* deref ] } 1&& ;
: advance ( void* -- void* )
cell swap <displaced-alien> ;
: alien>strings ( alien encoding -- strings )
[ [ dup more? ] ] dip
- '[ [ advance ] [ *void* _ alien>string ] bi ]
+ '[ [ advance ] [ void* deref _ alien>string ] bi ]
produce nip ;
: strings>alien ( strings encoding -- array )
-USING: strings help.markup help.syntax assocs ;
+USING: strings help.markup help.syntax assocs urls ;
IN: urls.encoding
HELP: url-decode
} ;
HELP: parse-host
-{ $values { "string" string } { "host" string } { "port" { $maybe integer } } }
+{ $values { "string" string } { "host/f" { $maybe string } } { "port/f" { $maybe integer } } }
{ $description "Splits a string of the form " { $snippet "host:port" } " into a host and a port number. If the port number is not specified, outputs " { $link f } "." }
{ $notes "This word is used by " { $link >url } ". It can also be used directly to parse " { $snippet "host:port" } " strings which are not full URLs." }
{ $examples
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ascii combinators combinators.short-circuit
sequences splitting fry namespaces make assocs arrays strings
nip delete-query-param
] if ;
-: parse-host ( string -- host port )
+ERROR: malformed-port ;
+
+: parse-host ( string -- host/f port/f )
[
- ":" split1 [ url-decode ] [
- dup [
- string>number
- dup [ "Invalid port" throw ] unless
- ] when
- ] bi*
+ ":" split1-last [ url-decode ]
+ [ dup [ string>number [ malformed-port ] unless* ] when ] bi*
] [ f f ] if* ;
GENERIC: >url ( obj -- url )
PRIVATE>
M: string >url
+ [ <url> ] dip
parse-url {
[
first [
- [ first ] ! protocol
+ [ first >>protocol ]
[
second
- [ first [ first2 ] [ f f ] if* ] ! username, password
- [ second parse-host ] ! host, port
- bi
+ [ first [ first2 [ >>username ] [ >>password ] bi* ] when* ]
+ [ second parse-host [ >>host ] [ >>port ] bi* ] bi
] bi
- ] [ f f f f f ] if*
+ ] when*
]
- [ second ] ! pathname
- [ third ] ! query
- [ fourth ] ! anchor
- } cleave url boa
+ [ second >>path ]
+ [ third >>query ]
+ [ fourth >>anchor ]
+ } cleave
dup host>> [ [ "/" or ] change-path ] when ;
: protocol-port ( protocol -- port )
] [ protocol>> ] bi
secure-protocol? [ >secure-addr ] when ;
+: set-url-addr ( url addr -- url )
+ [ host>> >>host ] [ port>> >>port ] bi ;
+
: ensure-port ( url -- url' )
clone dup protocol>> '[ _ protocol-port or ] change-port ;
USE: vocabs.loader
{ "urls" "prettyprint" } "urls.prettyprint" require-when
+{ "urls" "io.sockets.secure" } "urls.secure" require-when
USING: kernel windows.com windows.com.syntax windows.ole32
-windows.types alien alien.syntax tools.test libc alien.c-types
-namespaces arrays continuations accessors math windows.com.wrapper
-windows.com.wrapper.private destructors effects compiler.units ;
+windows.types alien alien.data alien.syntax tools.test libc
+alien.c-types namespaces arrays continuations accessors math
+windows.com.wrapper windows.com.wrapper.private destructors
+effects compiler.units ;
IN: windows.com.tests
COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
dup +guinea-pig-implementation+ set [ drop
S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test
- E_FAIL <long> *long 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
+ E_FAIL long <ref> long deref 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
20 1array [
+guinea-pig-implementation+ get
[ 20 IInherited::setX ]
-USING: alien alien.c-types alien.accessors alien.parser
-effects kernel windows.ole32 parser lexer splitting grouping
-sequences namespaces assocs quotations generalizations
+USING: alien alien.c-types alien.data alien.accessors
+alien.parser effects kernel windows.ole32 parser lexer splitting
+grouping sequences namespaces assocs quotations generalizations
accessors words macros alien.syntax fry arrays layouts math
classes.struct windows.kernel32 locals ;
FROM: alien.parser.private => parse-pointers return-type-name ;
MACRO: com-invoke ( n return parameters -- )
[ 2nip length ] 3keep
'[
- _ npick *void* _ cell * alien-cell _ _
+ _ npick void* deref _ cell * alien-cell _ _
stdcall alien-indirect
] ;
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.syntax
+USING: accessors alien alien.c-types alien.data alien.syntax
classes.struct io.encodings.string io.encodings.utf8 kernel
make sequences windows.errors windows.types ;
IN: windows.iphlpapi
FUNCTION: DWORD GetNetworkParams ( PFIXED_INFO pFixedInfo, PULONG pOutBufLen ) ;
: get-fixed-info ( -- FIXED_INFO )
- FIXED_INFO <struct> dup byte-length <ulong>
+ FIXED_INFO <struct> dup byte-length ulong <ref>
[ GetNetworkParams n>win32-error-check ] 2keep drop ;
: dns-server-ips ( -- sequence )
[ IpAddress>> String>> [ 0 = ] trim-tail utf8 decode , ]
[ Next>> ] bi dup
] loop drop
- ] { } make ;
\ No newline at end of file
+ ] { } make ;
CONSTANT: registry-value-max-length 16384
:: open-key ( key subkey mode -- hkey )
- key subkey 0 mode HKEY <c-object>
+ key subkey 0 mode 0 HKEY <ref>
[
RegOpenKeyEx dup ERROR_SUCCESS = [
drop
[ key subkey mode ] dip n>win32-error-string
open-key-failed
] if
- ] keep *uint ;
+ ] keep HKEY deref ;
:: create-key* ( hKey lpSubKey lpClass dwOptions samDesired lpSecurityAttributes -- hkey new? )
- hKey lpSubKey 0 lpClass dwOptions samDesired lpSecurityAttributes
- HKEY <c-object>
- DWORD <c-object>
f :> ret!
+ hKey lpSubKey 0 lpClass dwOptions samDesired lpSecurityAttributes
+ 0 HKEY <ref>
+ 0 DWORD <ref>
[ RegCreateKeyEx ret! ] 2keep
- [ *uint ]
- [ *uint REG_CREATED_NEW_KEY = ] bi*
+ [ HKEY deref ]
+ [ DWORD deref REG_CREATED_NEW_KEY = ] bi*
ret ERROR_SUCCESS = [
[
hKey lpSubKey 0 lpClass dwOptions samDesired
length 2 * <byte-array> ;
:: reg-query-value-ex ( key subkey ptr1 ptr2 buffer -- buffer )
- buffer length <uint> :> pdword
+ buffer length uint <ref> :> pdword
key subkey ptr1 ptr2 buffer pdword [ RegQueryValueEx ] 2keep
rot :> ret
ret ERROR_SUCCESS = [
- *uint head
+ uint deref head
] [
ret ERROR_MORE_DATA = [
2drop
registry-value-max-length TCHAR <c-array> dup :> registry-value
registry-value length dup :> registry-value-length
f
- DWORD <c-object> dup :> type
- f ! BYTE <c-object> dup :> data
- f ! BYTE <c-object> dup :> buffer
+ 0 DWORD <ref> dup :> type
+ f ! 0 BYTE <ref> dup :> data
+ f ! 0 BYTE <ref> dup :> buffer
RegEnumKeyEx dup ERROR_SUCCESS = [
] [
key
MAX_PATH
dup TCHAR <c-array> dup :> class-buffer
- swap <int> dup :> class-buffer-length
+ swap int <ref> dup :> class-buffer-length
f
- DWORD <c-object> dup :> sub-keys
- DWORD <c-object> dup :> longest-subkey
- DWORD <c-object> dup :> longest-class-string
- DWORD <c-object> dup :> #values
- DWORD <c-object> dup :> max-value
- DWORD <c-object> dup :> max-value-data
- DWORD <c-object> dup :> security-descriptor
+ 0 DWORD <ref> dup :> sub-keys
+ 0 DWORD <ref> dup :> longest-subkey
+ 0 DWORD <ref> dup :> longest-class-string
+ 0 DWORD <ref> dup :> #values
+ 0 DWORD <ref> dup :> max-value
+ 0 DWORD <ref> dup :> max-value-data
+ 0 DWORD <ref> dup :> security-descriptor
FILETIME <struct> dup :> last-write-time
RegQueryInfoKey :> ret
ret ERROR_SUCCESS = [
key
class-buffer
- sub-keys *uint
- longest-subkey *uint
- longest-class-string *uint
- #values *uint
- max-value *uint
- max-value-data *uint
- security-descriptor *uint
+ sub-keys uint deref
+ longest-subkey uint deref
+ longest-class-string uint deref
+ #values uint deref
+ max-value uint deref
+ max-value-data uint deref
+ security-descriptor uint deref
last-write-time FILETIME>timestamp
registry-info boa
] [
21 2^ <byte-array> reg-query-value-ex ;
: read-registry ( key subkey -- registry-info )
- KEY_READ [ reg-query-info-key ] with-open-registry-key ;
\ No newline at end of file
+ KEY_READ [ reg-query-info-key ] with-open-registry-key ;
f ! piDx
f ! pTabdef
f ! pbInClass
- f <void*> ! pssa
+ f void* <ref> ! pssa
[ ScriptStringAnalyse ] keep
- [ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
+ [ ole32-error ] [ |ScriptStringFree void* deref ] bi* ;
: set-dc-colors ( dc font -- )
[ background>> color>RGB SetBkColor drop ]
PRIVATE>
M: script-string dispose*
- ssa>> <void*> ScriptStringFree ole32-error ;
+ ssa>> void* <ref> ScriptStringFree ole32-error ;
SYMBOL: cached-script-strings
! Copyright (C) 2006, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.strings classes.struct
-io.encodings.utf8 kernel namespaces sequences
+USING: accessors alien.c-types alien.data alien.strings
+classes.struct io.encodings.utf8 kernel namespaces sequences
specialized-arrays x11 x11.constants x11.xlib ;
SPECIALIZED-ARRAY: int
IN: x11.clipboard
CurrentTime XConvertSelection drop ;
: snarf-property ( prop-return -- string )
- dup *void* [ *void* utf8 alien>string ] [ drop f ] if ;
+ dup void* deref [ void* deref utf8 alien>string ] [ drop f ] if ;
: window-property ( win prop delete? -- string )
[ [ dpy get ] 2dip 0 -1 ] dip AnyPropertyType
- 0 <Atom> 0 <int> 0 <ulong> 0 <ulong> f <void*>
+ 0 Atom <ref> 0 int <ref> 0 ulong <ref> 0 ulong <ref> f void* <ref>
[ XGetWindowProperty drop ] keep snarf-property ;
: selection-from-event ( event window -- string )
[ dpy get ] dip
[ requestor>> ]
[ property>> XA_TIMESTAMP 32 PropModeReplace ]
- [ time>> <int> ] tri
+ [ time>> int <ref> ] tri
1 XChangeProperty drop ;
: send-notify ( evt prop -- )
! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math math.bitwise math.vectors
-namespaces sequences arrays fry classes.struct literals
-x11 x11.xlib x11.constants x11.events
+USING: accessors alien.c-types alien.data kernel math
+math.bitwise math.vectors namespaces sequences arrays fry
+classes.struct literals x11 x11.xlib x11.constants x11.events
x11.glx ;
IN: x11.windows
dpy get swap XDestroyWindow drop ;
: set-closable ( win -- )
- dpy get swap XA_WM_DELETE_WINDOW <Atom> 1
+ dpy get swap XA_WM_DELETE_WINDOW Atom <ref> 1
XSetWMProtocols drop ;
: map-window ( win -- ) dpy get swap XMapWindow drop ;
! Copyright (C) 2007, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings arrays byte-arrays
-hashtables io io.encodings.string kernel math namespaces
-sequences strings continuations x11 x11.xlib
+USING: alien alien.c-types alien.data alien.strings arrays
+byte-arrays hashtables io io.encodings.string kernel math
+namespaces sequences strings continuations x11 x11.xlib
specialized-arrays accessors io.encodings.utf16n ;
SPECIALIZED-ARRAY: uint
IN: x11.xim
: prepare-lookup ( -- )
buf-size <uint-array> keybuf set
- 0 <KeySym> keysym set ;
+ 0 KeySym <ref> keysym set ;
: finish-lookup ( len -- string keysym )
keybuf get swap 2 * head utf16n decode
: lookup-string ( event xic -- string keysym )
[
prepare-lookup
- swap keybuf get buf-size keysym get 0 <int>
+ swap keybuf get buf-size keysym get 0 int <ref>
XwcLookupString
finish-lookup
] with-scope ;
! Copyright (C) 2010 Niklas Waern.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types combinators kernel namespaces x11
-x11.constants x11.xinput2.ffi ;
+USING: alien.c-types alien.data combinators kernel namespaces
+x11 x11.constants x11.xinput2.ffi ;
IN: x11.xinput2
: (xi2-available?) ( display -- ? )
- 2 0 [ <int> ] bi@
+ 2 0 [ int <ref> ] bi@
XIQueryVersion
{
{ BadRequest [ f ] }
TYPEDEF: ulong VisualID
TYPEDEF: ulong Time
-ALIAS: <XID> <ulong>
-ALIAS: <Window> <XID>
-ALIAS: <Drawable> <XID>
-ALIAS: <KeySym> <XID>
-ALIAS: <Atom> <ulong>
-
-ALIAS: *XID *ulong
+: *XID ( bytes -- n ) ulong deref ;
ALIAS: *Window *XID
ALIAS: *Drawable *XID
ALIAS: *KeySym *XID
-ALIAS: *Atom *ulong
+: *Atom ( bytes -- n ) ulong deref ;
!
! 2 - Display Functions
!
{ $values { "assoc" assoc } { "quot" { $quotation "( ... key value -- ... ? )" } } { "?" "a boolean" } }
{ $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ;
+HELP: assoc-refine
+{ $values { "seq" sequence } { "assoc" assoc } }
+{ $description "Outputs the intersection of all the assocs of the assocs sequence " { $snippet "seq" } ", or " { $link f } " if " { $snippet "seq" } " is empty." } ;
+
HELP: assoc-subset?
{ $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } }
{ $description "Tests if " { $snippet "assoc2" } " contains all key/value pairs of " { $snippet "assoc1" } "." } ;
[ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ;
: assoc= ( assoc1 assoc2 -- ? )
- [ assoc-subset? ] [ swap assoc-subset? ] 2bi and ;
+ 2dup [ assoc-size ] bi@ eq? [ assoc-subset? ] [ 2drop f ] if ;
: assoc-hashcode ( n assoc -- code )
>alist hashcode* ;
{ "bignum>" "math.private" "primitive_bignum_greater" (( x y -- ? )) }
{ "bignum>=" "math.private" "primitive_bignum_greatereq" (( x y -- ? )) }
{ "bignum>fixnum" "math.private" "primitive_bignum_to_fixnum" (( x -- y )) }
- { "bignum>float" "math.private" "primitive_bignum_to_float" (( x -- y )) }
{ "fixnum-shift" "math.private" "primitive_fixnum_shift" (( x y -- z )) }
{ "fixnum/i" "math.private" "primitive_fixnum_divint" (( x y -- z )) }
{ "fixnum/mod" "math.private" "primitive_fixnum_divmod" (( x y -- z w )) }
{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;\r
\r
HELP: sort-classes\r
-{ $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }\r
+{ $values { "seq" "a sequence of class" } { "newseq" "a new sequence of classes" } }\r
{ $description "Outputs a linear sort of a sequence of classes. Larger classes come before their subclasses." } ;\r
\r
HELP: class-or\r
{ $subsections
"tuple-inheritance-example"
"tuple-inheritance-anti-example"
-}
+}
"Declaring a tuple class final prohibits other classes from subclassing it:"
{ $subsections POSTPONE: final }
{ $see-also "call-next-method" "parametrized-constructors" "unions" "mixins" } ;
{ $table
{ "Reader" "Writer" "Setter" "Changer" }
{ { $snippet "name>>" } { $snippet "name<<" } { $snippet ">>name" } { $snippet "change-name" } }
+ { { $snippet "position>>" } { $snippet "position<<" } { $snippet ">>position" } { $snippet "change-position" } }
{ { $snippet "salary>>" } { $snippet "salary<<" } { $snippet ">>salary" } { $snippet "change-salary" } }
- { { $snippet "position>>" } { $snippet "position<<" } { $snippet ">>position" } { $snippet "change-position" } }
}
"We can define a constructor which makes an empty employee:"
-{ $code ": <employee> ( -- employee )"
- " employee new ;" }
+{ $code
+ ": <employee> ( -- employee )"
+ " employee new ;"
+}
"Or we may wish the default constructor to always give employees a starting salary:"
{ $code
": <employee> ( -- employee )"
{ $example "USE: classes" "\\ f class ." "word" }
"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of."
{ $example "t \\ t eq? ." "t" }
-"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
+"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is important, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic"
"Certain simple conditional forms can be expressed in a simpler manner using boolean logic."
{ $values { "word" word } { "effect" effect } }
{ $description "Given a word and a stack effect, executes the word, blindly declaring at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." }
{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link POSTPONE: execute( } " instead." } ;
-
+
{ call-effect call-effect-unsafe execute-effect execute-effect-unsafe } related-words
HELP: cleave
{ $description
"Compares " { $snippet "obj" } " against the first element of every pair, first evaluating the first element if it is a word. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation."
$nl
- "If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied."
+ "If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is raised."
$nl
"The following two phrases are equivalent:"
{ $code "{ { X [ Y ] } { Z [ T ] } } case" }
HELP: cond>quot
{ $values { "assoc" "a sequence of pairs of quotations" } { "quot" quotation } }
-{ $description "Creates a quotation that when called, has the same effect as applying " { $link cond } " to " { $snippet "assoc" } "."
+{ $description "Creates a quotation that when called, has the same effect as applying " { $link cond } " to " { $snippet "assoc" } "."
$nl
"The generated quotation is more efficient than the naive implementation of " { $link cond } ", though, since it expands into a series of conditionals, and no iteration through " { $snippet "assoc" } " has to be performed." }
-{ $notes "This word is used behind the scenes to compile " { $link cond } " forms efficiently; it can also be called directly, which is useful for meta-programming." } ;
+{ $notes "This word is used behind the scenes to compile " { $link cond } " forms efficiently; it can also be called directly, which is useful for meta-programming." } ;
HELP: case>quot
{ $values { "default" quotation } { "assoc" "a sequence of pairs of quotations" } { "quot" quotation } }
HELP: ifcc
{ $values { "capture" { $quotation "( continuation -- )" } } { "restore" quotation } }
-{ $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and "{ $snippet "restore" } " is called." } ;
+{ $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and " { $snippet "restore" } " is called." } ;
{ callcc0 continue callcc1 continue-with ifcc } related-words
"Inputs and outputs are typically named after some pun on their data type, or a description of the value's purpose if the type is very general. The following are some examples of value names:"
{ $table
{ { { $snippet "?" } } "a boolean" }
- { { { $snippet "<=>" } } { "an ordering sepcifier; see " { $link "order-specifiers" } } }
+ { { { $snippet "<=>" } } { "an ordering specifier; see " { $link "order-specifiers" } } }
{ { { $snippet "elt" } } "an object which is an element of a sequence" }
{ { { $snippet "m" } ", " { $snippet "n" } } "an integer" }
{ { { $snippet "obj" } } "an object" }
HELP: M\
{ $syntax "M\\ class generic" }
{ $class-description "Pushes a method on the stack." }
-{ $examples { $code "M\\ fixnum + see" } { $code "USING: ui.gadgets ui.gadgets.editors ;" "M\\ editor draw-gadget* edit" } } ;
+{ $examples { $code "M\\ fixnum + see" } { $code "USING: ui.gadgets.editors ui.render ;" "M\\ editor draw-gadget* edit" } } ;
HELP: method
{ $values { "class" class } { "generic" generic } { "method/f" { $maybe method } } }
M: hash-set set-like drop dup hash-set? [ members <hash-set> ] unless ;
M: hash-set clone table>> clone hash-set boa ;
M: hash-set null? table>> assoc-empty? ;
+M: hash-set cardinality table>> assoc-size ;
M: sequence fast-set <hash-set> ;
M: f fast-set drop H{ } clone hash-set boa ;
(clone) [ clone ] change-array ; inline
M: hashtable equal?
- over hashtable? [
- 2dup [ assoc-size ] bi@ eq?
- [ assoc= ] [ 2drop f ] if
- ] [ 2drop f ] if ;
+ over hashtable? [ assoc= ] [ 2drop f ] if ;
! Default method
M: assoc new-assoc drop <hashtable> ; inline
$nl
"There are two ways to order the bytes making up an integer; " { $emphasis "little endian" } " byte order outputs the least significant byte first, and the most significant byte last, whereas " { $emphasis "big endian" } " is the other way around."
$nl
-"Consider the hexadecimal integer "{ $snippet "HEX: cafebabe" } ". Little endian byte order yields the following sequence of bytes:"
+"Consider the hexadecimal integer " { $snippet "HEX: cafebabe" } ". Little endian byte order yields the following sequence of bytes:"
{ $table
{ "Byte:" "1" "2" "3" "4" }
{ "Value:" { $snippet "be" } { $snippet "ba" } { $snippet "fe" } { $snippet "ca" } }
-USING: accessors alien.c-types kernel
+USING: accessors alien.c-types alien.data kernel
io.encodings.utf16 io.streams.byte-array tools.test ;
IN: io.encodings.utf16n
$nl
"Binary streams have an element type of " { $link +byte+ } ". Elements are integers in the range " { $snippet "[0,255]" } ", representing bytes. Reading a sequence of elements produces a " { $link byte-array } ". Any object implementing the " { $link >c-ptr } " and " { $link byte-length } " generic words can be written to a binary stream."
$nl
-"Character streams have an element tye of " { $link +character+ } ". Elements are non-negative integers, representing Unicode code points. Only instances of the " { $link string } " class can be read or written on a character stream."
+"Character streams have an element type of " { $link +character+ } ". Elements are non-negative integers, representing Unicode code points. Only instances of the " { $link string } " class can be read or written on a character stream."
$nl
"Most external streams are binary streams, and can be wrapped in string streams once a suitable encoding has been provided; see " { $link "io.encodings" } "." ;
HELP: stream-copy
{ $values { "in" "an input stream" } { "out" "an output stream" } }
-{ $description "Copies the contents of one stream into another, closing both streams when done." }
+{ $description "Copies the contents of one stream into another, closing both streams when done." }
$io-error ;
HELP: stream-tell
HELP: seek-absolute
{ $values
-
+
{ "value" "a seek singleton" }
}
{ $description "Seeks to an offset from the beginning of the stream." } ;
HELP: seek-end
{ $values
-
+
{ "value" "a seek singleton" }
}
{ $description "Seeks to an offset from the end of the stream. If the offset puts the stream pointer past the end of the data on an output stream, writing to it will pad the difference with zeros." } ;
HELP: seek-relative
{ $values
-
+
{ "value" "a seek singleton" }
}
{ $description "Seeks to an offset from the current position of the stream pointer." } ;
HELP: with-input-stream
{ $values { "stream" "an input stream" } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
+{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
HELP: with-output-stream
{ $values { "stream" "an output stream" } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope, with " { $link output-stream } " rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
+{ $description "Calls the quotation in a new dynamic scope, with " { $link output-stream } " rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
HELP: with-streams
{ $values { "input" "an input stream" } { "output" "an output stream" } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "input" } " and " { $link output-stream } " rebound to " { $snippet "output" } ". The stream is closed if the quotation returns or throws an error." } ;
+{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "input" } " and " { $link output-stream } " rebound to " { $snippet "output" } ". The stream is closed if the quotation returns or throws an error." } ;
HELP: with-streams*
{ $values { "input" "an input stream" } { "output" "an output stream" } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "input" } " and " { $link output-stream } " rebound to " { $snippet "output" } "." }
+{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "input" } " and " { $link output-stream } " rebound to " { $snippet "output" } "." }
{ $notes "This word does not close the stream. Compare with " { $link with-streams } "." } ;
{ with-input-stream with-input-stream* } related-words
HELP: with-input-stream*
{ $values { "stream" "an input stream" } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "stream" } "." }
+{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "stream" } "." }
{ $notes "This word does not close the stream. Compare with " { $link with-input-stream } "." } ;
HELP: with-output-stream*
{ $values { "stream" "an output stream" } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope, with " { $link output-stream } " rebound to " { $snippet "stream" } "." }
+{ $description "Calls the quotation in a new dynamic scope, with " { $link output-stream } " rebound to " { $snippet "stream" } "." }
{ $notes "This word does not close the stream. Compare with " { $link with-output-stream } "." } ;
HELP: bl
{ $description "Reads all elements in the " { $link input-stream } " until the stream is exhausted. The type of the sequence depends on the stream's element type." }
$io-error ;
+HELP: tell-input
+{ $values
+ { "n" integer }
+}
+{ $description "Returns the index of the stream stored in " { $link input-stream } "." } ;
+
+HELP: tell-output
+{ $values
+ { "n" integer }
+}
+{ $description "Returns the index of the stream stored in " { $link output-stream } "." } ;
+
ARTICLE: "stream-protocol" "Stream protocol"
"The stream protocol consists of a large number of generic words, many of which are optional."
$nl
{ $subsections
stream-tell
stream-seek
+ tell-input
+ tell-output
}
{ $see-also "io.timeouts" } ;
}
"Seeking on the default output stream:"
{ $subsections seek-output }
-"Seeking descriptors:"
-{ $subsections
- seek-absolute
- seek-relative
- seek-end
-}
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
{ $subsections
with-output-stream
{ "path" "a pathname string" }
{ "path'" "a pathname string" }
}
-{ $description "Prepends the " { $link current-directory } " to the pathname and resolves a " { $snippet "resource:" } " or " { $snippet "voacb:" } " prefix, if present (see " { $link "io.pathnames.special" } ")." }
+{ $description "Prepends the " { $link current-directory } " to the pathname and resolves a " { $snippet "resource:" } " or " { $snippet "vocab:" } " prefix, if present (see " { $link "io.pathnames.special" } ")." }
{ $notes "This word is exaclty the same as " { $link normalize-path } ", except on Windows NT platforms, where it does not prepend the Unicode path prefix. Most code should call " { $link normalize-path } " instead." } ;
HELP: resolve-symlinks
"[ p ] [ q ] bi"
"[ p ] keep q"
}
-
+
} ;
HELP: 2bi
"[ swap ] dip [ p ] [ q ] 2bi*"
}
"In other words, " { $snippet "bi-curry* bi*" } " handles the case where you have the four values " { $snippet "a b c d" } " on the stack, and you wish to apply " { $snippet "p" } " to " { $snippet "a c" } " and " { $snippet "q" } " to " { $snippet "b d" } "."
-
+
} ;
HELP: tri-curry*
{ $notes
"The term FEP originates from the Lisp machines of old. According to the Jargon File,"
$nl
- { $strong "fepped out" } " /fept owt/ " { $emphasis "adj." } " The Symbolics 3600 LISP Machine has a Front-End Processor called a `FEP' (compare sense 2 of box). When the main processor gets wedged, the FEP takes control of the keyboard and screen. Such a machine is said to have `fepped out' or `dropped into the fep'."
+ { $strong "fepped out" } " /fept owt/ " { $emphasis "adj." } " The Symbolics 3600 LISP Machine has a Front-End Processor called a `FEP' (compare sense 2 of box). When the main processor gets wedged, the FEP takes control of the keyboard and screen. Such a machine is said to have `fepped out' or `dropped into the fep'."
$nl
{ $url "http://www.jargon.net/jargonfile/f/feppedout.html" }
} ;
{ $description "Partial application on the left. The following two lines are equivalent:"
{ $code "swap [ swap A ] curry B" }
{ $code "[ A ] with B" }
-
+
}
{ $notes "This operation is efficient and does not copy the quotation." }
{ $examples
[ 5 ] [ 10.5 1.9 /i ] unit-test
+[ t ] [ 0 0 /f fp-nan? ] unit-test
+[ t ] [ 0.0 0.0 /f fp-nan? ] unit-test
+[ t ] [ 0.0 0.0 / fp-nan? ] unit-test
+[ t ] [ 0 0 [ >bignum ] bi@ /f fp-nan? ] unit-test
+
+[ 1/0. ] [ 1 0 /f ] unit-test
+[ 1/0. ] [ 1.0 0.0 /f ] unit-test
+[ 1/0. ] [ 1.0 0.0 / ] unit-test
+[ 1/0. ] [ 1 0 [ >bignum ] bi@ /f ] unit-test
+
+[ -1/0. ] [ -1 0 /f ] unit-test
+[ -1/0. ] [ -1.0 0.0 /f ] unit-test
+[ -1/0. ] [ -1.0 0.0 / ] unit-test
+[ -1/0. ] [ -1 0 [ >bignum ] bi@ /f ] unit-test
+
[ t ] [ 0/0. 0/0. unordered? ] unit-test
[ t ] [ 1.0 0/0. unordered? ] unit-test
[ t ] [ 0/0. 1.0 unordered? ] unit-test
: float-min ( x y -- z ) [ float< ] most ; foldable
: float-max ( x y -- z ) [ float> ] most ; foldable
-M: fixnum >float fixnum>float ; inline
-M: bignum >float bignum>float ; inline
-
M: float >fixnum float>fixnum ; inline
M: float >bignum float>bignum ; inline
M: float >float ; inline
: random-integer ( -- n )
32 random-bits
- 1 random zero? [ neg ] when
- 1 random zero? [ >bignum ] when ;
+ { t f } random [ neg ] when
+ { t f } random [ >bignum ] when ;
[ t ] [
10000 [
[ HEX: 1.758bec11492f9p-54 ] [ 1 12345678901234567 /f ] unit-test
[ HEX: -1.758bec11492f9p-54 ] [ 1 -12345678901234567 /f ] unit-test
+! Ensure that /f rounds to nearest and not to zero
+[ HEX: 1.0p55 ] [ HEX: 7f,ffff,ffff,ffff >bignum 1 /f ] unit-test
+[ HEX: 1.0p55 ] [ HEX: -7f,ffff,ffff,ffff >bignum -1 /f ] unit-test
+[ HEX: -1.0p55 ] [ HEX: -7f,ffff,ffff,ffff >bignum 1 /f ] unit-test
+[ HEX: -1.0p55 ] [ HEX: 7f,ffff,ffff,ffff >bignum -1 /f ] unit-test
+
[ 17 ] [ 17 >bignum 5 max ] unit-test
[ 5 ] [ 17 >bignum 5 min ] unit-test
+
+[ 1 ] [ 1 202402253307310618352495346718917307049556649764142118356901358027430339567995346891960383701437124495187077864316811911389808737385793476867013399940738509921517424276566361364466907742093216341239767678472745068562007483424692698618103355649159556340810056512358769552333414615230502532186327508646006263307707741093494784 /f double>bits ] unit-test
+[ 12 ] [ 3 50600563326827654588123836679729326762389162441035529589225339506857584891998836722990095925359281123796769466079202977847452184346448369216753349985184627480379356069141590341116726935523304085309941919618186267140501870856173174654525838912289889085202514128089692388083353653807625633046581877161501565826926935273373696 /f double>bits ] unit-test
+[ 123 ] [ 123 202402253307310618352495346718917307049556649764142118356901358027430339567995346891960383701437124495187077864316811911389808737385793476867013399940738509921517424276566361364466907742093216341239767678472745068562007483424692698618103355649159556340810056512358769552333414615230502532186327508646006263307707741093494784 /f double>bits ] unit-test
+[ 1234 ] [ 617 101201126653655309176247673359458653524778324882071059178450679013715169783997673445980191850718562247593538932158405955694904368692896738433506699970369254960758712138283180682233453871046608170619883839236372534281003741712346349309051677824579778170405028256179384776166707307615251266093163754323003131653853870546747392 /f double>bits ] unit-test
+[ 1/0. ] [ 2048 2^ 1 /f ] unit-test
+[ -1/0. ] [ 2048 2^ -1 /f ] unit-test
+[ -1/0. ] [ 2048 2^ neg 1 /f ] unit-test
+[ 1/0. ] [ 2048 2^ neg -1 /f ] unit-test
M: fixnum >fixnum ; inline
M: fixnum >bignum fixnum>bignum ; inline
M: fixnum >integer ; inline
+M: fixnum >float fixnum>float ; inline
M: fixnum hashcode* nip ; inline
M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ; inline
M: fixnum * fixnum* ; inline
M: fixnum /i fixnum/i ; inline
-DEFER: bignum/f
-CONSTANT: bignum/f-threshold HEX: 20,0000,0000,0000
-
-: fixnum/f ( m n -- m/n )
- [ >float ] bi@ float/f ; inline
-
-M: fixnum /f
- 2dup [ abs bignum/f-threshold >= ] either?
- [ bignum/f ] [ fixnum/f ] if ; inline
-
M: fixnum mod fixnum-mod ; inline
M: fixnum /mod fixnum/mod ; inline
[ /mod ] dip ; inline
! Third step: post-scaling
-: unscaled-float ( mantissa -- n )
- 52 2^ 1 - bitand 1022 52 shift bitor bits>double ; inline
-
: scale-float ( mantissa scale -- float' )
- dup 0 < [ neg 2^ recip ] [ 2^ ] if * ; inline
+ {
+ { [ dup 1024 > ] [ 2drop 1/0. ] }
+ { [ dup -1023 < ] [ 1021 + shift bits>double ] }
+ [ [ 52 2^ 1 - bitand ] dip 1022 + 52 shift bitor bits>double ]
+ } cond ; inline
: post-scale ( mantissa scale -- n )
[ 2/ ] dip over log2 52 > [ [ 2/ ] [ 1 + ] bi* ] when
- [ unscaled-float ] dip scale-float ; inline
+ scale-float ; inline
+
+: round-to-nearest ( fraction-and-guard rem -- fraction-and-guard' )
+ over odd?
+ [ zero? [ dup zero? [ 1 + ] unless ] [ 1 + ] if ] [ drop ] if ;
+ inline
! Main word
: /f-abs ( m n -- f )
- over zero? [
- 2drop 0.0
- ] [
- [
- drop 1/0.
- ] [
+ over zero? [ nip zero? 0/0. 0.0 ? ] [
+ [ drop 1/0. ] [
pre-scale
/f-loop
- [ over odd? [ zero? [ 1 + ] unless ] [ drop ] if ] dip
+ [ round-to-nearest ] dip
post-scale
] if-zero
] if ; inline
: bignum/f ( m n -- f )
- [ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ;
+ [ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ; inline
+
+M: bignum /f ( m n -- f ) { bignum bignum } declare bignum/f ;
+
+CONSTANT: bignum/f-threshold HEX: 20,0000,0000,0000
+
+: fixnum/f ( m n -- m/n )
+ [ >float ] bi@ float/f ; inline
+
+M: fixnum /f
+ { fixnum fixnum } declare
+ 2dup [ abs bignum/f-threshold >= ] either?
+ [ bignum/f ] [ fixnum/f ] if ; inline
+
+: bignum>float ( bignum -- float )
+ { bignum } declare 1 >bignum bignum/f ;
-M: bignum /f ( m n -- f )
- bignum/f ;
+M: bignum >float bignum>float ; inline
{ $values { "x" rational } { "y" rational } { "z" rational } }
{ $description
"Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder being negative if " { $snippet "x" } " is negative."
- { $list
+ { $list
"Modulus of fixnums always yields a fixnum."
- "Modulus of bignums always yields a bignum."
+ "Modulus of bignums always yields a bignum."
{ "Modulus of rationals always yields a rational. In this case, the remainder is computed using the formula " { $snippet "x - (x mod y) * y" } "." }
}
}
{ $values { "x" integer } { "y" integer } { "z" integer } { "w" integer } }
{ $description
"Computes the quotient " { $snippet "z" } " and remainder " { $snippet "w" } " of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder being negative if " { $snippet "x" } " is negative."
- { $list
+ { $list
"The quotient of two fixnums may overflow and yield a bignum; the remainder is always a fixnum"
- "The quotient and remainder of two bignums is always a bignum."
+ "The quotient and remainder of two bignums is always a bignum."
}
}
{ $see-also "division-by-zero" } ;
{ $values { "x" rational } { "y" rational } { "z" rational } }
{ $description
"Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder always positive or zero."
- { $list
+ { $list
"Given fixnums, always yields a fixnum."
"Given bignums, always yields a bignum."
- "Given rationals, always yields a rational."
+ "Given rationals, always yields a rational."
}
}
{ $see-also "division-by-zero" mod } ;
HELP: 2^
{ $values { "n" "a positive integer" } { "2^n" "a positive integer" } }
-{ $description "Computes two to the power of " { $snippet "n" } ". This word will only give correct results if " { $snippet "n" } " is greater than zero; for the general case, use " { $snippet "2 swap ^" } "." } ;
+{ $description "Computes two to the power of " { $snippet "n" } ". This word will only give correct results if " { $snippet "n" } " is greater than zero; for the general case, use " { $snippet "2 swap ^" } "." } ;
HELP: zero?
{ $values { "x" number } { "?" "a boolean" } }
HELP: find-integer
{ $values { "n" integer } { "quot" { $quotation "( ... i -- ... ? )" } } { "i" "an integer or " { $link f } } }
-{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iterationi stops when the quotation outputs a true value or the end is reached. If the quotation yields a true value for some integer, this word outputs that integer. Otherwise, this word outputs " { $link f } "." }
+{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iteration stops when the quotation outputs a true value or the end is reached. If the quotation yields a true value for some integer, this word outputs that integer. Otherwise, this word outputs " { $link f } "." }
{ $notes "This word is used to implement " { $link find } "." } ;
HELP: find-last-integer
ERROR: log2-expects-positive x ;
: log2 ( x -- n )
- dup 0 <= [
- log2-expects-positive
- ] [
- (log2)
- ] if ; inline
+ dup 0 <= [ log2-expects-positive ] [ (log2) ] if ; inline
: zero? ( x -- ? ) 0 number= ; inline
: 2/ ( x -- y ) -1 shift ; inline
: ?1+ ( x -- y ) [ 1 + ] [ 0 ] if* ; inline
: rem ( x y -- z ) abs [ mod ] [ + ] [ mod ] tri ; foldable
: 2^ ( n -- 2^n ) 1 swap shift ; inline
-: even? ( n -- ? ) 1 bitand zero? ;
-: odd? ( n -- ? ) 1 bitand 1 number= ;
+: even? ( n -- ? ) 1 bitand zero? ; inline
+: odd? ( n -- ? ) 1 bitand 1 number= ; inline
: if-zero ( ..a n quot1: ( ..a -- ..b ) quot2: ( ..a n -- ..b ) -- ..b )
[ dup zero? ] [ [ drop ] prepose ] [ ] tri* if ; inline
"So far we have seen how to read individual tokens, or read a sequence of parsed objects until a delimiter. It is also possible to read raw tokens from the input and perform custom processing."
$nl
"One example is the " { $link POSTPONE: USING: } " parsing word."
-{ $see POSTPONE: USING: }
+{ $see POSTPONE: USING: }
"It reads a list of vocabularies terminated by " { $link POSTPONE: ; } ". However, the vocabulary names do not name words, except by coincidence; so " { $link parse-until } " cannot be used here. Instead, a set of lower-level combinators can be used:"
{ $subsections
each-token
{ $errors "Throws a parse error if the input is malformed." } ;
HELP: filter-moved
-{ $values { "assoc1" assoc } { "assoc2" assoc } { "seq" "an seqence of definitions" } }
+{ $values { "assoc1" assoc } { "assoc2" assoc } { "seq" "an sequence of definitions" } }
{ $description "Removes all definitions from " { $snippet "assoc2" } " which are in " { $snippet "assoc1" } " or are are no longer present in the current " { $link file } "." } ;
HELP: forget-smudged
ARTICLE: "sbufs" "String buffers"
"The " { $vocab-link "sbufs" } " vocabulary implements resizable mutable sequence of characters. The literal syntax is covered in " { $link "syntax-sbufs" } "."
$nl
-"String buffers implement the " { $link "sequence-protocol" } " and thus all " { $link "sequences" } " can be used with them. String buffers can be used to construct new strings by accumilating substrings and characters, however usually they are only used indirectly, since the sequence construction words are more convenient to use in most cases (see " { $link "namespaces-make" } ")."
+"String buffers implement the " { $link "sequence-protocol" } " and thus all " { $link "sequences" } " can be used with them. String buffers can be used to construct new strings by accumulating substrings and characters, however usually they are only used indirectly, since the sequence construction words are more convenient to use in most cases (see " { $link "namespaces-make" } ")."
$nl
"String buffers form a class of objects:"
{ $subsections
HELP: set-length
{ $values { "n" "a non-negative integer" } { "seq" "a resizable sequence" } }
{ $contract "Resizes a sequence. The initial contents of the new area is undefined." }
-{ $errors "Throws a " { $link no-method } " error if the sequence is not resizable, and a " { $link bounds-error } " if the new length is negative." }
+{ $errors "Throws a " { $link no-method } " error if the sequence is not resizable, and a " { $link bounds-error } " if the new length is negative." }
{ $side-effects "seq" } ;
HELP: lengthen
{ "indices" sequence } { "seq" sequence }
{ "seq'" sequence } }
{ $description "Outputs a sequence of elements from the input sequence indexed by the indices." }
-{ $examples
+{ $examples
{ $example "USING: prettyprint sequences ;"
"{ 0 2 } { \"a\" \"b\" \"c\" } nths ."
"{ \"a\" \"c\" }"
{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is unsafe. It does not check types, so improper use can corrupt memory." } ;
HELP: array-nth
-{ $values { "n" "a non-negative fixnum" } { "array" "an array" } { "elt" object } }
+{ $values { "n" "a non-negative fixnum" } { "array" "an array" } { "elt" object } }
{ $description "Low-level array element accessor." }
{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is unsafe. It does not check types or array bounds, and improper use can corrupt memory. User code must use " { $link nth } " instead." } ;
HELP: set-array-nth
-{ $values { "elt" object } { "n" "a non-negative fixnum" } { "array" "an array" } }
+{ $values { "elt" object } { "n" "a non-negative fixnum" } { "array" "an array" } }
{ $description "Low-level array element mutator." }
{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is unsafe. It does not check types or array bounds, and improper use can corrupt memory. User code must use " { $link set-nth } " instead." } ;
HELP: push-if
{ $values { "elt" object } { "quot" { $quotation "( ..a elt -- ..b ? )" } } { "accum" "a resizable mutable sequence" } }
-{ $description "Adds the element at the end of the sequence if the quotation yields a true value." }
+{ $description "Adds the element at the end of the sequence if the quotation yields a true value." }
{ $notes "This word is a factor of " { $link filter } "." } ;
HELP: filter
HELP: prefix
{ $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
{ $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the beginning of " { $snippet "seq" } "." }
-{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." }
+{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." }
{ $examples
{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 prefix ." "{ 0 1 2 3 }" }
} ;
{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
{ $description "Outputs a new sequence of the same type as " { $snippet "seq1" } " consisting of the elements of " { $snippet "seq1" } " followed by " { $snippet "seq2" } "." }
{ $errors "Throws an error if " { $snippet "seq2" } " contains elements not permitted in sequences of the same class as " { $snippet "seq1" } "." }
-{ $examples
+{ $examples
{ $example "USING: prettyprint sequences ;"
"{ 1 2 } B{ 3 4 } append ."
"{ 1 2 3 4 }"
{ $values { "seq1" sequence } { "seq2" sequence } { "exemplar" sequence } { "newseq" sequence } }
{ $description "Outputs a new sequence of the same type as " { $snippet "exemplar" } " consisting of the elements of " { $snippet "seq1" } " followed by " { $snippet "seq2" } "." }
{ $errors "Throws an error if " { $snippet "seq1" } " or " { $snippet "seq2" } " contain elements not permitted in sequences of the same class as " { $snippet "exemplar" } "." }
-{ $examples
+{ $examples
{ $example "USING: prettyprint sequences ;"
"{ 1 2 } B{ 3 4 } B{ } append-as ."
"B{ 1 2 3 4 }"
HELP: shorter?
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
-{ $description "Tets if the length of " { $snippet "seq1" } " is smaller than the length of " { $snippet "seq2" } "." } ;
+{ $description "Tests if the length of " { $snippet "seq1" } " is smaller than the length of " { $snippet "seq2" } "." } ;
HELP: head?
{ $values { "seq" sequence } { "begin" sequence } { "?" "a boolean" } }
{ $values
{ "quot" { $quotation "( ... elt -- ... ? )" } }
{ "selector" { $quotation "( ... elt -- ... )" } } { "accum" vector } }
-{ $description "Creates a new vector to accumulate the values which return true for a predicate. Returns a new quotation which accepts an object to be tested and stored in the collector if the test yields true. The collector is left on the stack for convenience." }
+{ $description "Creates a new vector to accumulate the values which return true for a predicate. Returns a new quotation which accepts an object to be tested and stored in the collector if the test yields true. The collector is left on the stack for convenience." }
{ $example "! Find all the even numbers:" "USING: prettyprint sequences math kernel ;"
"10 iota [ even? ] selector [ each ] dip ."
"V{ 0 2 4 6 8 }"
{ "seq" sequence } { "quot" quotation }
{ "newseq" sequence } }
{ $description "Removes elements starting from the left side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." }
-{ $example "" "USING: prettyprint math sequences ;"
+{ $example "USING: prettyprint math sequences ;"
"{ 0 0 1 2 3 0 0 } [ zero? ] trim-head ."
"{ 1 2 3 0 0 }"
} ;
{ "seq" sequence } { "quot" quotation }
{ "slice" slice } }
{ $description "Removes elements starting from the left side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a slice" }
-{ $example "" "USING: prettyprint math sequences ;"
+{ $example "USING: prettyprint math sequences ;"
"{ 0 0 1 2 3 0 0 } [ zero? ] trim-head-slice ."
"T{ slice { from 2 } { to 7 } { seq { 0 0 1 2 3 0 0 } } }"
} ;
{ "seq" sequence } { "quot" quotation }
{ "newseq" sequence } }
{ $description "Removes elements starting from the right side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." }
-{ $example "" "USING: prettyprint math sequences ;"
+{ $example "USING: prettyprint math sequences ;"
"{ 0 0 1 2 3 0 0 } [ zero? ] trim-tail ."
"{ 0 0 1 2 3 }"
} ;
{ "seq" sequence } { "quot" quotation }
{ "slice" slice } }
{ $description "Removes elements starting from the right side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a slice." }
-{ $example "" "USING: prettyprint math sequences ;"
+{ $example "USING: prettyprint math sequences ;"
"{ 0 0 1 2 3 0 0 } [ zero? ] trim-tail-slice ."
"T{ slice { from 0 } { to 5 } { seq { 0 0 1 2 3 0 0 } } }"
} ;
{ "seq" sequence } { "quot" quotation }
{ "newseq" sequence } }
{ $description "Removes elements starting from the left and right sides of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." }
-{ $example "" "USING: prettyprint math sequences ;"
+{ $example "USING: prettyprint math sequences ;"
"{ 0 0 1 2 3 0 0 } [ zero? ] trim ."
"{ 1 2 3 }"
} ;
{ "seq" sequence } { "quot" quotation }
{ "slice" slice } }
{ $description "Removes elements starting from the left and right sides of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a slice." }
-{ $example "" "USING: prettyprint math sequences ;"
+{ $example "USING: prettyprint math sequences ;"
"{ 0 0 1 2 3 0 0 } [ zero? ] trim-slice ."
"T{ slice { from 2 } { to 5 } { seq { 0 0 1 2 3 0 0 } } }"
} ;
{ $values
{ "seq" sequence }
{ "newseq" sequence } }
- { $description "Outputs a new sequence with all instance of " { $link f } " removed." }
- { $examples
+ { $description "Outputs a new sequence with all instance of " { $link f } " removed." }
+ { $examples
{ $example "USING: prettyprint sequences ;"
"{ \"a\" 3 { } f } sift ."
"{ \"a\" 3 { } }"
{ "seq" sequence }
{ "newseq" sequence } }
{ $description "Outputs a new sequence with all empty sequences removed." }
-{ $examples
+{ $examples
{ $example "USING: prettyprint sequences ;"
"{ { } { 2 3 } { 5 } { } } harvest ."
"{ { 2 3 } { 5 } }"
{ $values
{ "first" object } { "seq" sequence } }
{ $description "Sets the first element of a sequence." }
-{ $examples
+{ $examples
{ $example "USING: prettyprint kernel sequences ;"
- "{ 1 2 3 4 } 5 over set-first ."
+ "{ 1 2 3 4 } 5 over set-first ."
"{ 5 2 3 4 }"
}
} ;
{ $values
{ "second" object } { "seq" sequence } }
{ $description "Sets the second element of a sequence." }
-{ $examples
+{ $examples
{ $example "USING: prettyprint kernel sequences ;"
- "{ 1 2 3 4 } 5 over set-second ."
+ "{ 1 2 3 4 } 5 over set-second ."
"{ 1 5 3 4 }"
}
} ;
{ $values
{ "third" object } { "seq" sequence } }
{ $description "Sets the third element of a sequence." }
-{ $examples
+{ $examples
{ $example "USING: prettyprint kernel sequences ;"
- "{ 1 2 3 4 } 5 over set-third ."
+ "{ 1 2 3 4 } 5 over set-third ."
"{ 1 2 5 4 }"
}
} ;
{ $values
{ "fourth" object } { "seq" sequence } }
{ $description "Sets the fourth element of a sequence." }
-{ $examples
+{ $examples
{ $example "USING: prettyprint kernel sequences ;"
- "{ 1 2 3 4 } 5 over set-fourth ."
+ "{ 1 2 3 4 } 5 over set-fourth ."
"{ 1 2 3 5 }"
}
} ;
{ "len" integer } { "quot" { $quotation "( ... -- ... newelt )" } }
{ "newseq" sequence } }
{ $description "Calls the quotation " { $snippet "len" } " times, collecting results into a new array." }
-{ $examples
+{ $examples
{ $unchecked-example "USING: kernel prettyprint random sequences ;"
"5 [ 100 random ] replicate ."
"{ 52 10 45 81 30 }"
{ "len" integer } { "quot" { $quotation "( ... -- ... newelt )" } } { "exemplar" sequence }
{ "newseq" sequence } }
{ $description "Calls the quotation " { $snippet "len" } " times, collecting results into a new sequence of the same type as the exemplar sequence." }
-{ $examples
+{ $examples
{ $unchecked-example "USING: prettyprint kernel sequences ;"
"5 [ 100 random ] B{ } replicate-as ."
"B{ 44 8 2 33 18 }"
{ $values
{ "seq" sequence } { "quot" quotation }
{ "trueseq" sequence } { "falseseq" sequence } }
- { $description "Calls a predicate quotation on each element of the input sequence. If the test yields true, the element is added to " { $snippet "trueseq" } "; if false, it's added to " { $snippet "falseseq" } "." }
-{ $examples
+ { $description "Calls a predicate quotation on each element of the input sequence. If the test yields true, the element is added to " { $snippet "trueseq" } "; if false, it's added to " { $snippet "falseseq" } "." }
+{ $examples
{ $example "USING: prettyprint kernel math sequences ;"
"{ 1 2 3 4 5 } [ even? ] partition [ . ] bi@"
"{ 2 4 }\n{ 1 3 5 }"
{ $values
{ "quot" quotation }
{ "selector" quotation } { "accum1" vector } { "accum2" vector } }
-{ $description "Creates two new vectors to accumultate values based on a predicate. The first vector accumulates values for which the predicate yields true; the second for false." } ;
+{ $description "Creates two new vectors to accumulate values based on a predicate. The first vector accumulates values for which the predicate yields true; the second for false." } ;
HELP: 2unclip-slice
{ $values
{ $values
{ "obj" object } { "quot" { $quotation "( ... prev -- ... result/f )" } }
{ "seq" sequence } }
-{ $description "Outputs a sequence containing the input object and all of the objects generated by successively feeding the result of the quotation called on the input object to the quotation recursuively. Objects yielded by the quotation are added to the output sequence until the quotation yields " { $link f } ", at which point the recursion terminates." }
+{ $description "Outputs a sequence containing the input object and all of the objects generated by successively feeding the result of the quotation called on the input object to the quotation recursively. Objects yielded by the quotation are added to the output sequence until the quotation yields " { $link f } ", at which point the recursion terminates." }
{ $examples "Get random numbers until zero is reached:"
{ $unchecked-example
"USING: random sequences prettyprint math ;"
HELP: push-either
{ $values
{ "elt" object } { "quot" quotation } { "accum1" vector } { "accum2" vector } }
-{ $description "Pushes the input object onto one of the accumualators; the first if the quotation yields true, the second if false." } ;
+{ $description "Pushes the input object onto one of the accumulators; the first if the quotation yields true, the second if false." } ;
HELP: sequence-hashcode
{ $values
{ $description "Throws an error if all the elements of two sequences, taken pairwise, are not equal." }
{ $notes "The sequences need not be of the same type." }
{ $examples
- { $example
+ { $code
"USING: prettyprint sequences ;"
"{ 1 2 3 } V{ 1 2 3 } assert-sequence="
- ""
}
} ;
{ $subsections in? }
"All sets can be represented as a sequence, without duplicates, of their members:"
{ $subsections members }
+"To get the number of elements in a set:"
+{ $subsections cardinality }
"Sets can have members added or removed destructively:"
{ $subsections
adjoin
HELP: null?
{ $values { "set" set } { "?" "a boolean" } }
{ $description "Tests whether the given set is empty. This outputs " { $snippet "t" } " when given a null set of any type." } ;
+
+HELP: cardinality
+{ $values { "set" set } { "n" "a non-negative integer" } }
+{ $description "Returns the number of elements in the set. All sets support this operation." } ;
USING: sets tools.test kernel prettyprint hash-sets sorting ;
IN: sets.tests
-[ { } ] [ { } { } intersect ] unit-test
+[ { } ] [ { } { } intersect ] unit-test
[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } intersect ] unit-test
+[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 5 } intersect ] unit-test
+[ { 2 3 4 } ] [ { 1 2 3 4 } { 2 3 4 } intersect ] unit-test
[ { 2 3 } ] [ { 1 2 2 3 } { 2 3 3 4 } intersect ] unit-test
[ { } ] [ { } { } diff ] unit-test
[ { 1 } ] [ { 1 2 3 } { 2 3 4 } diff ] unit-test
+[ { 1 } ] [ { 1 2 3 } { 2 3 4 5 } diff ] unit-test
+[ { 1 } ] [ { 1 2 3 4 } { 2 3 4 } diff ] unit-test
[ { 1 } ] [ { 1 1 2 3 } { 2 3 4 4 } diff ] unit-test
-[ { } ] [ { } { } within ] unit-test
+[ { } ] [ { } { } within ] unit-test
[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } within ] unit-test
[ { 2 2 3 } ] [ { 1 2 2 3 } { 2 3 3 4 } within ] unit-test
[ t ] [ f null? ] unit-test
[ f ] [ { 4 } null? ] unit-test
+
+[ 0 ] [ f cardinality ] unit-test
+[ 0 ] [ { } cardinality ] unit-test
+[ 1 ] [ { 1 } cardinality ] unit-test
+[ 1 ] [ HS{ 1 } cardinality ] unit-test
+[ 3 ] [ HS{ 1 2 3 } cardinality ] unit-test
GENERIC: duplicates ( set -- seq )
GENERIC: all-unique? ( set -- ? )
GENERIC: null? ( set -- ? )
+GENERIC: cardinality ( set -- n )
+
+M: f cardinality drop 0 ;
! Defaults for some methods.
! Override them for efficiency
M: set null? members null? ; inline
+M: set cardinality members length ;
+
M: set set-like drop ; inline
M: set union
: sequence/tester ( set1 set2 -- set1' quot )
[ members ] [ tester ] bi* ; inline
+: small/large ( set1 set2 -- set1' set2' )
+ 2dup [ cardinality ] bi@ > [ swap ] when ;
+
PRIVATE>
M: set intersect
- [ sequence/tester filter ] keep set-like ;
+ [ small/large sequence/tester filter ] keep set-like ;
M: set diff
[ sequence/tester [ not ] compose filter ] keep set-like ;
M: set intersects?
- sequence/tester any? ;
+ small/large sequence/tester any? ;
M: set subset?
- sequence/tester all? ;
-
+ small/large sequence/tester all? ;
+
M: set set=
- 2dup subset? [ swap subset? ] [ 2drop f ] if ;
+ 2dup [ cardinality ] bi@ eq? [ subset? ] [ 2drop f ] if ;
M: set fast-set ;
M: sequence members
[ pruned ] keep like ;
-
+
M: sequence null?
empty? ; inline
+M: sequence cardinality
+ length ;
+
: combine ( sets -- set )
[ f ]
[ [ [ members ] map concat ] [ first ] bi set-like ]
HELP: record-checksum
{ $values { "lines" "a sequence of strings" } { "source-file" source-file } }
-{ $description "Records the CRC32 checksm of the source file's contents." }
+{ $description "Records the CRC32 checksum of the source file's contents." }
$low-level-note ;
HELP: reset-checksums
<PRIVATE
-: (split) ( n seq quot: ( elt -- ? ) -- )
+: (split) ( n seq quot: ( ... elt -- ... ? ) -- )
[ find-from drop ]
[ [ [ 3dup swapd subseq , ] dip [ drop 1 + ] 2dip (split) ] 3curry ]
[ drop [ swap [ tail ] unless-zero , ] 2curry ]
ARTICLE: "syntax-tuples" "Tuple syntax"
{ $subsections POSTPONE: T{ }
-"Tuples are documented in " { $link "tuples" } "." ;
+"Tuples are documented in " { $link "tuples" } "." ;
ARTICLE: "syntax-quots" "Quotation syntax"
{ $subsections
HELP: {
{ $syntax "{ elements... }" }
{ $values { "elements" "a list of objects" } }
-{ $description "Marks the beginning of a literal array. Literal arrays are terminated by " { $link POSTPONE: } } "." }
+{ $description "Marks the beginning of a literal array. Literal arrays are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "{ 1 2 3 }" } } ;
HELP: V{
{ $syntax "V{ elements... }" }
{ $values { "elements" "a list of objects" } }
-{ $description "Marks the beginning of a literal vector. Literal vectors are terminated by " { $link POSTPONE: } } "." }
+{ $description "Marks the beginning of a literal vector. Literal vectors are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "V{ 1 2 3 }" } } ;
HELP: B{
{ $syntax "B{ elements... }" }
{ $values { "elements" "a list of integers" } }
-{ $description "Marks the beginning of a literal byte array. Literal byte arrays are terminated by " { $link POSTPONE: } } "." }
+{ $description "Marks the beginning of a literal byte array. Literal byte arrays are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "B{ 1 2 3 }" } } ;
HELP: H{
{ $syntax "H{ { key value }... }" }
{ $values { "key" "an object" } { "value" "an object" } }
-{ $description "Marks the beginning of a literal hashtable, given as a list of two-element arrays holding key/value pairs. Literal hashtables are terminated by " { $link POSTPONE: } } "." }
+{ $description "Marks the beginning of a literal hashtable, given as a list of two-element arrays holding key/value pairs. Literal hashtables are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "H{ { \"tuna\" \"fish\" } { \"jalapeno\" \"vegetable\" } }" } } ;
HELP: HS{
{ $syntax "HS{ members ... }" }
{ $values { "members" "a list of objects" } }
-{ $description "Marks the beginning of a literal hash set, given as a list of its members. Literal hashtables are terminated by " { $link POSTPONE: } } "." }
+{ $description "Marks the beginning of a literal hash set, given as a list of its members. Literal hashtables are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "HS{ 3 \"foo\" }" } } ;
HELP: C{
{ $syntax "C{ real-part imaginary-part }" }
{ $values { "real-part" "a real number" } { "imaginary-part" "a real number" } }
-{ $description "Parses a complex number given in rectangular form as a pair of real numbers. Literal complex numbers are terminated by " { $link POSTPONE: } } "." } ;
+{ $description "Parses a complex number given in rectangular form as a pair of real numbers. Literal complex numbers are terminated by " { $link POSTPONE: } } "." } ;
HELP: T{
{ $syntax "T{ class }" "T{ class f slot-values... }" "T{ class { slot-name slot-value } ... }" }
{ $examples
{ $example "USING: classes.singleton kernel io ;" "IN: singleton-demo" "USE: prettyprint SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
} ;
-
+
HELP: SINGLETONS:
{ $syntax "SINGLETONS: words... ;" }
{ $values { "words" "a sequence of new words to define" } }
{ $examples { $example
"USING: prettyprint ;"
"QUALIFIED: math"
- "1 2 math:+ ." "3"
+ "1 2 math:+ ."
+ "3"
} } ;
HELP: QUALIFIED-WITH:
{ $syntax "QUALIFIED-WITH: vocab word-prefix" }
{ $description "Like " { $link POSTPONE: QUALIFIED: } " but uses " { $snippet "word-prefix" } " as prefix." }
-{ $examples { $code
+{ $examples { $example
"USING: prettyprint ;"
"QUALIFIED-WITH: math m"
"1 2 m:+ ."
HELP: EXCLUDE:
{ $syntax "EXCLUDE: vocab => words ... ;" }
-{ $description "Adds all words except for " { $snippet "words" } " from " { $snippet "vocab" } " to the search path." }
+{ $description "Adds all words except for " { $snippet "words" } " from " { $snippet "vocab" } " to the search path." }
{ $examples { $code
"EXCLUDE: math.parser => bin> hex> ;" "! imports everything but bin> and hex>" } } ;
"TUPLE: air-transport ;"
"HOOK: deliver transport ( destination -- )"
"M: land-transport deliver \"Land delivery to \" write print ;"
- "M: air-transport deliver \"Air delivery to \" write print ;"
+ "M: air-transport deliver \"Air delivery to \" write print ;"
"T{ air-transport } transport set"
"\"New York City\" deliver"
"Air delivery to New York City"
USING: help.markup help.syntax parser strings words assocs vocabs ;
IN: vocabs.parser
-ARTICLE: "word-search-errors" "Word lookup errors"
+ARTICLE: "word-search-errors" "Word lookup errors"
"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies."
$nl
"If " { $link auto-use? } " mode is off, a restartable error is thrown with a restart for each vocabulary in question, together with a restart which defers the word in the current vocabulary, as if " { $link POSTPONE: DEFER: } " was used."
HELP: add-words-excluding
{ $values { "vocab" "a vocabulary specifier" } { "words" "a sequence of word names" } }
-{ $description "Adds all words except for " { $snippet "words" } " from " { $snippet "vocab" } " to the manifest." }
+{ $description "Adds all words except for " { $snippet "words" } " from " { $snippet "vocab" } " to the manifest." }
{ $notes "This word is used to implement " { $link POSTPONE: EXCLUDE: } "." } ;
HELP: add-renamed-word
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } ;
HELP: load-vocab-hook
-{ $var-description { $quotation "( name -- vocab )" } " which loads a vocabulary. This quotation is called by " { $link load-vocab } ". The default value should not need to be changed; this functinality is implemented via a hook stored in a variable to break a circular dependency which would otherwise exist from " { $vocab-link "vocabs" } " to " { $vocab-link "vocabs.loader" } " to " { $vocab-link "parser" } " back to " { $vocab-link "vocabs" } "." } ;
+{ $var-description { $quotation "( name -- vocab )" } " which loads a vocabulary. This quotation is called by " { $link load-vocab } ". The default value should not need to be changed; this functionality is implemented via a hook stored in a variable to break a circular dependency which would otherwise exist from " { $vocab-link "vocabs" } " to " { $vocab-link "vocabs.loader" } " to " { $vocab-link "parser" } " back to " { $vocab-link "vocabs" } "." } ;
HELP: words-named
{ $values { "str" string } { "seq" "a sequence of words" } }
! (c)2010 Joe Groff bsd license
-USING: alien alien.c-types alien.libraries alien.strings
-alien.syntax combinators destructors io.encodings.ascii kernel
-libc locals sequences system ;
+USING: alien alien.c-types alien.data alien.libraries
+alien.strings alien.syntax combinators destructors
+io.encodings.ascii kernel libc locals sequences system ;
IN: alien.cxx.demangle.libstdcxx
FUNCTION: char* __cxa_demangle ( char* mangled_name, char* output_buffer, size_t* length, int* status ) ;
"_Z" head? ;
:: demangle ( mangled-name -- c++-name )
- 0 <ulong> :> length
- 0 <int> :> status [
+ 0 ulong <ref> :> length
+ 0 int <ref> :> status [
mangled-name ascii string>alien f length status __cxa_demangle &(free) :> demangled-buf
- mangled-name status *int demangle-error
+ mangled-name status int deref demangle-error
demangled-buf ascii alien>string
] with-destructors ;
! (c)2009 Joe Groff bsd license
-USING: accessors alien audio classes.struct fry calendar timers
-combinators combinators.short-circuit destructors generalizations
-kernel literals locals math openal sequences
-sequences.generalizations specialized-arrays strings ;
+USING: accessors alien alien.data audio classes.struct fry
+calendar timers combinators combinators.short-circuit
+destructors generalizations kernel literals locals math openal
+sequences sequences.generalizations specialized-arrays strings ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAYS: c:float c:uchar c:uint ;
IN: audio.engine
:: flush-source ( al-source -- )
al-source alSourceStop
- 0 c:<uint> :> dummy-buffer
+ 0 c:uint <ref> :> dummy-buffer
al-source AL_BUFFERS_PROCESSED get-source-param [
al-source 1 dummy-buffer alSourceUnqueueBuffers
] times
audio-clip t >>done? drop
] [
al-buffer audio-clip openal-format data size audio-clip sample-rate>> alBufferData
- al-source 1 al-buffer c:<uint> alSourceQueueBuffers
+ al-source 1 al-buffer c:uint <ref> alSourceQueueBuffers
] if
] unless ;
M:: streaming-audio-clip (update-audio-clip) ( audio-clip -- )
audio-clip al-source>> :> al-source
- 0 c:<uint> :> buffer
+ 0 c:uint <ref> :> buffer
al-source AL_BUFFERS_PROCESSED get-source-param [
al-source 1 buffer alSourceUnqueueBuffers
- audio-clip buffer c:*uint queue-clip-buffer
+ audio-clip buffer c:uint deref queue-clip-buffer
] times ;
: update-audio-clip ( audio-clip -- )
audio-engine get-available-source :> al-source
al-source [
- 1 0 c:<uint> [ alGenBuffers ] keep c:*uint :> al-buffer
+ 1 0 c:uint <ref> [ alGenBuffers ] keep c:uint deref :> al-buffer
al-buffer audio { [ openal-format ] [ data>> ] [ size>> ] [ sample-rate>> ] } cleave
alBufferData
M: static-audio-clip dispose*
[ call-next-method ]
- [ [ 1 ] dip al-buffer>> c:<uint> alDeleteBuffers ] bi ;
+ [ [ 1 ] dip al-buffer>> c:uint <ref> alDeleteBuffers ] bi ;
M: streaming-audio-clip dispose*
[ call-next-method ]
! (c)2007, 2010 Chris Double, Joe Groff bsd license
-USING: accessors alien alien.c-types audio.engine byte-arrays
-classes.struct combinators destructors fry io io.files
-io.encodings.binary kernel libc locals make math math.order
-math.parser ogg ogg.vorbis sequences specialized-arrays
-specialized-vectors ;
+USING: accessors alien alien.c-types alien.data audio.engine
+byte-arrays classes.struct combinators destructors fry io
+io.files io.encodings.binary kernel libc locals make math
+math.order math.parser ogg ogg.vorbis sequences
+specialized-arrays specialized-vectors ;
FROM: alien.c-types => float short void* ;
SPECIALIZED-ARRAYS: float void* ;
SPECIALIZED-VECTOR: short
[ init-vorbis-codec ] if ;
: get-pending-decoded-audio ( vorbis-stream -- pcm len )
- dsp-state>> f <void*> [ vorbis_synthesis_pcmout ] keep *void* swap ;
+ dsp-state>> f void* <ref> [ vorbis_synthesis_pcmout ] keep void* deref swap ;
: float>short-sample ( float -- short )
-32767.5 * 0.5 - >integer -32768 32767 clamp ; inline
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-ui? t }
+ { deploy-word-defs? f }
+ { deploy-threads? t }
+ { deploy-math? t }
+ { deploy-io 1 }
+ { deploy-reflection 1 }
+ { deploy-unicode? f }
+ { "stop-after-last-window?" t }
+ { deploy-console? f }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { deploy-name "benchmark.ui-panes" }
+}
-USING: ui.gadgets.panes prettyprint io sequences ;
+USING: io kernel math.parser sequences ui.gadgets.panes ;
IN: benchmark.ui-panes
: ui-pane-benchmark ( -- )
- <pane> <pane-stream> [ 10000 iota [ . ] each ] with-output-stream* ;
+ [ 10000 iota [ number>string print ] each ] make-pane drop ;
MAIN: ui-pane-benchmark
: model-path ( -- path ) "bun_zipper.ply" temp-file ;
-: model-url ( -- url ) "http://factorcode.org/bun_zipper.ply" ;
+: model-url ( -- url ) "http://factorcode.org/slava/bun_zipper.ply" ;
: maybe-download ( -- path )
model-path dup exists? [
+++ /dev/null
-Matthew Willis
+++ /dev/null
-USING: central destructors help.markup help.syntax ;
-
-HELP: CENTRAL:
-{ $description
- "This parsing word defines a pair of words useful for "
- "implementing the \"central\" pattern: " { $snippet "symbol" } " and "
- { $snippet "with-symbol" } ". This is a middle ground between excessive "
- "stack manipulation and full-out locals, meant to solve the case where "
- "one object is operated on by several related words."
-} ;
-
-HELP: DISPOSABLE-CENTRAL:
-{ $description
- "Like " { $link POSTPONE: CENTRAL: } ", but generates " { $snippet "with-" }
- " words that are wrapped in a " { $link with-disposal } "."
-} ;
\ No newline at end of file
+++ /dev/null
-USING: accessors central destructors kernel math tools.test ;
-
-IN: scratchpad
-
-CENTRAL: test-central
-
-[ 3 ] [ 3 [ test-central ] with-test-central ] unit-test
-
-TUPLE: test-disp-cent value disposed ;
-
-! A phony destructor that adds 1 to the value so we can make sure it got called.
-M: test-disp-cent dispose* dup value>> 1 + >>value drop ;
-
-DISPOSABLE-CENTRAL: t-d-c
-
-: test-t-d-c ( -- n )
- test-disp-cent new 3 >>value [ t-d-c ] with-t-d-c value>> ;
-
-[ 4 ] [ test-t-d-c ] unit-test
+++ /dev/null
-USING: destructors kernel lexer namespaces parser sequences words ;
-
-IN: central
-
-: define-central-getter ( word -- )
- dup [ get ] curry (( -- obj )) define-declared ;
-
-: define-centrals ( str -- getter setter )
- [ create-in dup define-central-getter ]
- [ "with-" prepend create-in dup make-inline ] bi ;
-
-: central-setter-def ( word with-word -- with-word quot )
- [ with-variable ] with ;
-
-: disposable-setter-def ( word with-word -- with-word quot )
- [ pick [ drop with-variable ] with-disposal ] with ;
-
-: declare-central ( with-word quot -- ) (( object quot -- )) define-declared ;
-
-: define-central ( word-name -- )
- define-centrals central-setter-def declare-central ;
-
-: define-disposable-central ( word-name -- )
- define-centrals disposable-setter-def declare-central ;
-
-SYNTAX: CENTRAL: ( -- ) scan define-central ;
-
-SYNTAX: DISPOSABLE-CENTRAL: ( -- ) scan define-disposable-central ;
\ No newline at end of file
+++ /dev/null
-extensions
: create-context ( device flags -- context )
swap
- [ CUcontext <c-object> ] 2dip
- [ cuCtxCreate cuda-error ] 3keep 2drop *void* ; inline
+ [ { CUcontext } ] 2dip
+ '[ _ _ cuCtxCreate cuda-error ] with-out-parameters ; inline
: sync-context ( -- )
cuCtxSynchronize cuda-error ; inline
: context-device ( -- n )
- CUdevice <c-object> [ cuCtxGetDevice cuda-error ] keep *int ; inline
+ { CUdevice } [ cuCtxGetDevice cuda-error ] with-out-parameters ; inline
: destroy-context ( context -- ) cuCtxDestroy cuda-error ; inline
dup CUDA_SUCCESS = [ drop ] [ \ cuda-error boa throw ] if ;
: cuda-version ( -- n )
- c:int <c-object> [ cuDriverGetVersion cuda-error ] keep c:*int ;
+ { c:int } [ cuDriverGetVersion cuda-error ] with-out-parameters ;
: init-cuda ( -- )
0 cuInit cuda-error ; inline
IN: cuda.devices
: #cuda-devices ( -- n )
- int <c-object> [ cuDeviceGetCount cuda-error ] keep *int ;
+ { int } [ cuDeviceGetCount cuda-error ] with-out-parameters ;
: n>cuda-device ( n -- device )
- [ CUdevice <c-object> ] dip [ cuDeviceGet cuda-error ] 2keep drop *int ;
+ [ { CUdevice } ] dip '[ _ cuDeviceGet cuda-error ] with-out-parameters ;
: enumerate-cuda-devices ( -- devices )
#cuda-devices iota [ n>cuda-device ] map ;
[ 2drop utf8 alien>string ] 3bi ;
: cuda-device-capability ( n -- pair )
- [ int <c-object> int <c-object> ] dip
- [ cuDeviceComputeCapability cuda-error ]
- [ drop [ *int ] bi@ ] 3bi 2array ;
+ [ { int int } ] dip
+ '[ _ cuDeviceComputeCapability cuda-error ] with-out-parameters
+ 2array ;
: cuda-device-memory ( n -- bytes )
- [ uint <c-object> ] dip
- [ cuDeviceTotalMem cuda-error ]
- [ drop *uint ] 2bi ;
+ [ { uint } ] dip
+ '[ _ cuDeviceTotalMem cuda-error ] with-out-parameters ;
: cuda-device-attribute ( attribute n -- n )
- [ int <c-object> ] 2dip
- [ cuDeviceGetAttribute cuda-error ]
- [ 2drop *int ] 3bi ;
+ [ { int } ] 2dip
+ '[ _ _ cuDeviceGetAttribute cuda-error ] with-out-parameters ;
: cuda-device. ( n -- )
{
: create-gl-cuda-context ( device flags -- context )
swap
- [ CUcontext <c-object> ] 2dip
- [ cuGLCtxCreate cuda-error ] 3keep 2drop *void* ; inline
+ [ { CUcontext } ] 2dip
+ '[ _ _ cuGLCtxCreate cuda-error ] with-out-parameters ; inline
: with-gl-cuda-context ( device flags quot -- )
[ set-up-cuda-context create-gl-cuda-context ] dip (with-cuda-context) ; inline
: gl-buffer>resource ( gl-buffer flags -- resource )
enum>number
- [ CUgraphicsResource <c-object> ] 2dip
- [ cuGraphicsGLRegisterBuffer cuda-error ] 3keep 2drop *void* ; inline
+ [ { CUgraphicsResource } ] 2dip
+ '[ _ _ cuGraphicsGLRegisterBuffer cuda-error ] with-out-parameters ; inline
: buffer>resource ( buffer flags -- resource )
[ handle>> ] dip gl-buffer>resource ; inline
: map-resource ( resource -- device-ptr size )
- [ 1 swap <void*> f cuGraphicsMapResources cuda-error ] [
- [ CUdeviceptr <c-object> uint <c-object> ] dip
- [ cuGraphicsResourceGetMappedPointer cuda-error ] 3keep drop
- [ *uint ] [ *uint ] bi*
+ [ 1 swap void* <ref> f cuGraphicsMapResources cuda-error ] [
+ [ { CUdeviceptr uint } ] dip
+ '[ _ cuGraphicsResourceGetMappedPointer cuda-error ]
+ with-out-parameters
] bi ; inline
: unmap-resource ( resource -- )
- 1 swap <void*> f cuGraphicsUnmapResources cuda-error ; inline
+ 1 swap void* <ref> f cuGraphicsUnmapResources cuda-error ; inline
DESTRUCTOR: unmap-resource
PRIVATE>
: load-module ( path -- module )
- [ CUmodule <c-object> ] dip
- [ cuModuleLoad cuda-error ] 2keep drop c:*void* ;
+ [ { CUmodule } ] dip
+ '[ _ cuModuleLoad cuda-error ] with-out-parameters ;
: unload-module ( module -- )
cuModuleUnload cuda-error ;
[ [ 0 cuda-param-size ] ] swap '[ _ [cuda-arguments] ] if-empty ;
: get-function-ptr ( module string -- function )
- [ CUfunction <c-object> ] 2dip
- [ cuModuleGetFunction cuda-error ] 3keep 2drop c:*void* ;
+ [ { CUfunction } ] 2dip
+ '[ _ _ cuModuleGetFunction cuda-error ] with-out-parameters ;
: cached-module ( module-name -- alien )
lookup-cuda-library
] ;
: cuda-global* ( module-name symbol-name -- device-ptr size )
- [ CUdeviceptr <c-object> c:uint <c-object> ] 2dip
+ [ { CUdeviceptr { c:uint initial: 0 } } ] 2dip
[ cached-module ] dip
- '[ _ _ cuModuleGetGlobal cuda-error ] 2keep [ c:*uint ] bi@ ; inline
+ '[ _ _ cuModuleGetGlobal cuda-error ] with-out-parameters ; inline
: cuda-global ( module-name symbol-name -- device-ptr )
cuda-global* drop ; inline
IN: cuda.memory
: cuda-malloc ( n -- ptr )
- [ CUdeviceptr <c-object> ] dip
- '[ _ cuMemAlloc cuda-error ] keep
- c:*int ; inline
+ [ { CUdeviceptr } ] dip
+ '[ _ cuMemAlloc cuda-error ] with-out-parameters ; inline
: cuda-malloc-type ( n type -- ptr )
c:heap-size * cuda-malloc ; inline
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.enums alien.syntax arrays assocs
-byte-arrays calendar combinators combinators.smart constructors
-destructors fry grouping io io.binary io.buffers
-io.encodings.binary io.encodings.string io.encodings.utf8
-io.files io.ports io.sockets io.streams.byte-array io.timeouts
-kernel make math math.bitwise math.parser math.ranges
-math.statistics memoize namespaces random sequences
-slots.syntax splitting strings system unicode.categories
-vectors nested-comments io.sockets.private ;
+USING: accessors alien.enums alien.syntax arrays calendar
+combinators combinators.smart constructors destructors grouping
+io io.binary io.encodings.binary io.encodings.string
+io.encodings.utf8 io.sockets io.sockets.private
+io.streams.byte-array io.timeouts kernel make math math.bitwise
+math.parser namespaces nested-comments random sequences
+slots.syntax splitting system vectors vocabs.loader ;
IN: dns
-GENERIC: stream-peek1 ( stream -- byte/f )
-
-M: input-port stream-peek1
- dup check-disposed dup wait-to-read
- [ drop f ] [ buffer>> buffer-peek ] if ; inline
-
-M: byte-reader stream-peek1
- [ i>> ] [ underlying>> ] bi ?nth ;
-
-: peek1 ( -- byte ) input-stream get stream-peek1 ;
-
-: with-temporary-input-seek ( n seek-type quot -- )
+: with-input-seek ( n seek-type quot -- )
tell-input [
[ seek-input ] dip call
] dip seek-absolute seek-input ; inline
: clear-dns-servers ( -- )
V{ } clone dns-servers set-global ;
-! Google DNS servers
-CONSTANT: initial-dns-servers { "8.8.8.8" "8.8.4.4" }
-
-: load-resolve.conf ( -- seq )
- "/etc/resolv.conf" utf8 file-lines
- [ [ blank? ] trim ] map
- [ "#" head? not ] filter
- [ [ " " split1 swap ] dip push-at ] sequence>hashtable "nameserver" swap at ;
-
-dns-servers [ initial-dns-servers >vector ] initialize
-
: >dotted ( domain -- domain' )
dup "." tail? [ "." append ] unless ;
CONSTANT: ipv6-arpa-suffix ".ip6.arpa"
: ipv6>arpa ( string -- string )
- ipv6>byte-array [ [ -4 shift 4 bits ] [ 4 bits ] bi 2array ] { } map-as
+ ipv6>byte-array
+ [ [ -4 shift 4 bits ] [ 4 bits ] bi 2array ] { } map-as
B{ } concat-as reverse
[ >hex ] { } map-as "." join ipv6-arpa-suffix append ;
first2 swap [ hex> ] bi@ [ 4 shift ] [ ] bi* bitor
] B{ } map-as byte-array>ipv6 ;
-: parse-length-bytes ( -- seq ) read1 read utf8 decode ;
+: parse-length-bytes ( byte -- sequence ) read utf8 decode ;
: (parse-name) ( -- )
- peek1 [
- read1 drop
- ] [
- HEX: C0 mask? [
- 2 read be> HEX: 3fff bitand
- seek-absolute [ parse-length-bytes , (parse-name) ] with-temporary-input-seek
+ read1 [
+ dup HEX: C0 mask? [
+ 8 shift read1 bitor HEX: 3fff bitand
+ seek-absolute [
+ read1 parse-length-bytes , (parse-name)
+ ] with-input-seek
] [
parse-length-bytes , (parse-name)
] if
- ] if-zero ;
+ ] unless-zero ;
-: parse-name ( -- seq )
+: parse-name ( -- sequence )
[ (parse-name) ] { } make "." join ;
: parse-query ( -- query )
4 read be> >>ttl
2 read be> over type>> parse-rdata >>rdata ;
-: parse-message ( ba -- message )
+: parse-message ( byte-array -- message )
[ message new ] dip
binary [
2 read be> >>id
[ [ parse-rr ] replicate ] change-additional-section
] with-byte-reader ;
-: >n/label ( string -- ba )
+: >n/label ( string -- byte-array )
[ length 1array ] [ utf8 encode ] bi B{ } append-as ;
-: >name ( dn -- ba ) "." split [ >n/label ] map concat ;
+: >name ( domain -- byte-array ) "." split [ >n/label ] map concat ;
-: query>byte-array ( query -- ba )
+: query>byte-array ( query -- byte-array )
[
{
[ name>> >name ]
} cleave
] B{ } append-outputs-as ;
-: rr>byte-array ( rr -- ba )
+: rr>byte-array ( rr -- byte-array )
[
{
[ name>> >name ]
} cleave
] B{ } append-outputs-as ;
-: message>byte-array ( message -- ba )
+: message>byte-array ( message -- byte-array )
[
{
[ id>> 2 >be ]
: udp-query ( bytes server -- bytes' )
f 0 <inet4> <datagram>
- 5 seconds over set-timeout [
+ 30 seconds over set-timeout [
[ send ] [ receive drop ] bi
] with-disposal ;
: message>names ( message -- names )
answer-section>> [ rdata>> name>> ] map ;
+: message>a-names ( message -- names )
+ answer-section>>
+ [ rdata>> ] map [ a? ] filter [ name>> ] map ;
+
: message>mxs ( message -- assoc )
answer-section>> [ rdata>> [ preference>> ] [ exchange>> ] bi 2array ] map ;
: message>query-name ( message -- string )
query>> first name>> dotted> ;
-: a-line. ( host ip -- )
- [ write " has address " write ] [ print ] bi* ;
-
-: a-message. ( message -- )
- [ message>query-name ] [ message>names ] bi
- [ a-line. ] with each ;
-
-: mx-line. ( host pair -- )
- [ write " mail is handled by " write ]
- [ first2 [ number>string write bl ] [ print ] bi* ] bi* ;
-
-: mx-message. ( message -- )
- [ message>query-name ] [ message>mxs ] bi
- [ mx-line. ] with each ;
-
-: host ( domain -- )
- [ dns-A-query a-message. ]
- [ dns-AAAA-query a-message. ]
- [ dns-MX-query mx-message. ] tri ;
+USE: nested-comments
+(*
+M: string resolve-host
+ dup >lower "localhost" = [
+ drop resolve-localhost
+ ] [
+ dns-A-query message>a-names [ <ipv4> ] map
+ ] if ;
+*)
+
+HOOK: initial-dns-servers os ( -- sequence )
+
+{
+ { [ os windows? ] [ "dns.windows" ] }
+ { [ os unix? ] [ "dns.unix" ] }
+} cond require
+
+dns-servers [ initial-dns-servers >vector ] initialize
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors dns resolv-conf system ;
+IN: dns.unix
+
+M: unix initial-dns-servers
+ default-resolv.conf nameserver>> ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: dns system windows.iphlpapi ;
+IN: dns.windows
+
+M: windows initial-dns-servers dns-server-ips ;
\ No newline at end of file
:: ecdsa-sign ( DGST -- sig )
ec-key-handle :> KEY
KEY ECDSA_size dup ssl-error <byte-array> :> SIG
- 0 <uint> :> LEN
+ 0 uint <ref> :> LEN
0 DGST dup length SIG LEN KEY ECDSA_sign ssl-error
- LEN *uint SIG resize ;
+ LEN uint deref SIG resize ;
: ecdsa-verify ( dgst sig -- ? )
ec-key-handle [ 0 -rot [ dup length ] bi@ ] dip ECDSA_verify 0 > ;
USING: accessors timers alien.c-types calendar classes.struct
continuations destructors fry kernel math math.order memory
namespaces sequences specialized-vectors system
-tools.memory ui ui.gadgets.worlds vm vocabs.loader arrays
+ui ui.gadgets.worlds vm vocabs.loader arrays
tools.time.struct locals ;
IN: game.loop
} case ; inline
: get-buffer-int ( target enum -- value )
- 0 <int> [ glGetBufferParameteriv ] keep *int ; inline
+ 0 int <ref> [ glGetBufferParameteriv ] keep int deref ; inline
: bind-buffer ( buffer -- target )
[ kind>> gl-target dup ] [ handle>> glBindBuffer ] bi ; inline
: bunny-model-path ( -- path ) "bun_zipper.ply" temp-file ;
-CONSTANT: bunny-model-url "http://factorcode.org/bun_zipper.ply"
+CONSTANT: bunny-model-url "http://factorcode.org/slava/bun_zipper.ply"
: download-bunny ( -- path )
bunny-model-path dup exists? [
! (c)2009 Joe Groff bsd license
-USING: accessors alien.c-types arrays byte-arrays combinators
-destructors gpu gpu.buffers gpu.private gpu.textures
-gpu.textures.private images kernel locals math math.rectangles opengl
-opengl.framebuffers opengl.gl opengl.textures sequences
+USING: accessors alien.c-types alien.data arrays byte-arrays
+combinators destructors gpu gpu.buffers gpu.private gpu.textures
+gpu.textures.private images kernel locals math math.rectangles
+opengl opengl.framebuffers opengl.gl opengl.textures sequences
specialized-arrays typed ui.gadgets.worlds variants ;
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: uint
<PRIVATE
: get-framebuffer-int ( enum -- value )
- GL_RENDERBUFFER swap 0 <int> [ glGetRenderbufferParameteriv ] keep *int ;
+ GL_RENDERBUFFER swap 0 int <ref>
+ [ glGetRenderbufferParameteriv ] keep int deref ;
PRIVATE>
name length 1 + :> name-buffer-length
{
index name-buffer-length dup
- [ f 0 <int> 0 <int> ] dip <byte-array>
+ [ f 0 int <ref> 0 int <ref> ] dip <byte-array>
[ glGetTransformFeedbackVarying ] 3keep
ascii alien>string
vertex-attribute assert-feedback-attribute
[ set-gpu-state* ] if ; inline
: get-gl-bool ( enum -- value )
- 0 <uchar> [ glGetBooleanv ] keep *uchar c-bool> ;
+ 0 uchar <ref> [ glGetBooleanv ] keep uchar deref c-bool> ;
: get-gl-int ( enum -- value )
- 0 <int> [ glGetIntegerv ] keep *int ;
+ 0 int <ref> [ glGetIntegerv ] keep int deref ;
: get-gl-float ( enum -- value )
- 0 <float> [ glGetFloatv ] keep *float ;
+ 0 c:float <ref> [ glGetFloatv ] keep c:float deref ;
: get-gl-bools ( enum count -- value )
<byte-array> [ glGetBooleanv ] keep [ c-bool> ] { } map-as ;
[ [ name>> { "form" "input" } member? ] filter ] map ;
: find-html-objects ( vector string -- vector' )
- dupd find-opening-tags-by-name
- [ first2 find-between* ] curry map ;
+ over find-opening-tags-by-name
+ [ first2 find-between* ] with map ;
: form-action ( vector -- string )
[ name>> "form" = ] find nip "action" attribute ;
USING: accessors arrays combinators compression.lzw
constructors destructors grouping images images.loader io
io.binary io.buffers io.encodings.string io.encodings.utf8
-io.ports kernel make math math.bitwise namespaces sequences ;
+kernel make math math.bitwise namespaces sequences ;
IN: images.gif
SINGLETON: gif-image
V{ } clone >>comment-extensions
t >>loading? ;
-GENERIC: stream-peek1 ( stream -- byte )
-
-M: input-port stream-peek1
- dup check-disposed dup wait-to-read
- [ drop f ] [ buffer>> buffer-peek ] if ; inline
-
-: peek1 ( -- byte ) input-stream get stream-peek1 ;
-
: (read-sub-blocks) ( -- )
read1 [ read , (read-sub-blocks) ] unless-zero ;
: eval-js ( string -- result-string )
[ js-context get dup ] dip
- JSStringCreateWithUTF8CString f f 0 JSValueRef <c-object>
- [ JSEvaluateScript ] keep *void*
+ JSStringCreateWithUTF8CString f f 0
+ { { void* initial: f } } [ JSEvaluateScript ] with-out-parameters
dup [ nip JSValueRef>string javascriptcore-error ] [ drop JSValueRef>string ] if ;
: eval-js-standalone ( string -- result-string )
! Copyright (C) 2009 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.syntax assocs destructors
-kernel llvm.core llvm.engine llvm.wrappers namespaces ;
+USING: accessors alien.c-types alien.data alien.syntax assocs
+destructors kernel llvm.core llvm.engine llvm.wrappers
+namespaces ;
IN: llvm.jit
LLVMGetFirstFunction dup ALIEN: 0 = [ drop ] [ (remove-functions) ] if ;
: remove-provider ( provider -- )
- current-jit ee>> value>> swap value>> f <void*> f <void*>
- [ LLVMRemoveModuleProvider drop ] 2keep *void* [ llvm-throw ] when*
- *void* module new swap >>value
+ current-jit ee>> value>> swap value>> f void* <ref> f void* <ref>
+ [ LLVMRemoveModuleProvider drop ] 2keep void* deref [ llvm-throw ] when*
+ void* deref module new swap >>value
[ value>> remove-functions ] with-disposal ;
: remove-module ( name -- )
: function-pointer ( name -- alien )
current-jit ee>> value>> dup
- rot f <void*> [ LLVMFindFunction drop ] keep
- *void* LLVMGetPointerToGlobal ;
\ No newline at end of file
+ rot f void* <ref> [ LLVMFindFunction drop ] keep
+ void* deref LLVMGetPointerToGlobal ;
! Copyright (C) 2009 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.syntax destructors kernel
-llvm.core llvm.engine llvm.jit llvm.wrappers ;
+USING: accessors alien.c-types alien.data alien.syntax
+destructors kernel llvm.core llvm.engine llvm.jit llvm.wrappers
+;
IN: llvm.reader
: buffer>module ( buffer -- module )
[
- value>> f <void*> f <void*>
+ value>> f void* <ref> f void* <ref>
[ LLVMParseBitcode drop ] 2keep
- *void* [ llvm-throw ] when* *void*
+ void* deref [ llvm-throw ] when* void* deref
module new swap >>value
] with-disposal ;
<buffer> buffer>module ;
: load-into-jit ( path name -- )
- [ load-module ] dip add-module ;
\ No newline at end of file
+ [ load-module ] dip add-module ;
! Copyright (C) 2009 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.strings
+USING: accessors alien.c-types alien.data alien.strings
io.encodings.utf8 destructors kernel
llvm.core llvm.engine ;
: (engine) ( provider -- engine )
[
- value>> f <void*> f <void*>
+ value>> f void* <ref> f void* <ref>
[ swapd 0 swap LLVMCreateJITCompiler drop ] 2keep
- *void* [ llvm-throw ] when* *void*
+ void* deref [ llvm-throw ] when* void* deref
]
[ t >>disposed drop ] bi
engine <dispose> ;
M: buffer dispose* value>> LLVMDisposeMemoryBuffer ;
: <buffer> ( path -- module )
- f <void*> f <void*>
+ f void* <ref> f void* <ref>
[ LLVMCreateMemoryBufferWithContentsOfFile drop ] 2keep
- *void* [ llvm-throw ] when* *void* buffer <dispose> ;
\ No newline at end of file
+ void* deref [ llvm-throw ] when* void* deref buffer <dispose> ;
IN: math.finance.tests
+[ { 1 2 3 4 } ] [ { 1 2 3 4 5 } 1 ema ] unit-test
+
[ { 2 4 } ] [ { 1 3 5 } 2 sma ] unit-test
[ { 1 3 1 } ] [ { 1 3 2 6 3 } 2 momentum ] unit-test
PRIVATE>
: ema ( seq n -- newseq )
- a swap unclip [ [ dup ] 2dip spin weighted ] accumulate 2nip ;
+ a swap unclip [ swap pick weighted ] accumulate 2nip ;
: sma ( seq n -- newseq )
clump [ mean ] map ;
! Copyright (C) 2007, 2008, 2009 Alex Chapman, 2009 Diego Martinelli
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal openal.alut parser sequences splitting strings synth synth.buffers ;
+USING: accessors ascii assocs biassocs combinators hashtables
+kernel lists literals math namespaces make multiline openal
+openal.alut parser sequences splitting strings synth
+synth.buffers ;
IN: morse
ERROR: no-morse-ch ch ;
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel alien alien.syntax shuffle
+USING: alien.c-types alien.data kernel alien alien.syntax shuffle
openal openal.alut.backend namespaces system generalizations ;
IN: openal.alut.macosx
FUNCTION: void alutLoadWAVFile ( c-string fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
M: macosx load-wav-file ( path -- format data size frequency )
- 0 <int> f <void*> 0 <int> 0 <int>
+ 0 int <ref> f void* <ref> 0 int <ref> 0 int <ref>
[ alutLoadWAVFile ] 4 nkeep
- [ [ [ *int ] dip *void* ] dip *int ] dip *int ;
+ [ [ [ int deref ] dip void* deref ] dip int deref ] dip int deref ;
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax combinators generalizations
-kernel openal openal.alut.backend ;
+USING: alien.c-types alien.data alien.syntax combinators
+generalizations kernel openal openal.alut.backend ;
IN: openal.alut.other
LIBRARY: alut
FUNCTION: void alutLoadWAVFile ( c-string fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
M: object load-wav-file ( filename -- format data size frequency )
- 0 <int> f <void*> 0 <int> 0 <int>
- [ 0 <char> alutLoadWAVFile ] 4 nkeep
- { [ *int ] [ *void* ] [ *int ] [ *int ] } spread ;
+ 0 int <ref>
+ f void* <ref>
+ 0 int <ref>
+ 0 int <ref>
+ [ 0 char <ref> alutLoadWAVFile ] 4 nkeep
+ { [ int deref ] [ void* deref ] [ int deref ] [ int deref ] } spread ;
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors arrays alien system combinators
-alien.syntax namespaces alien.c-types sequences vocabs.loader
+alien.syntax namespaces sequences vocabs.loader
shuffle alien.libraries generalizations
-specialized-arrays alien.destructors ;
-FROM: alien.c-types => float short ;
+specialized-arrays alien.destructors alien.data ;
+FROM: alien.c-types => char double float int short uchar uint
+ushort void ;
SPECIALIZED-ARRAY: uint
IN: openal
alSourcei ;
: get-source-param ( source param -- value )
- 0 <uint> dup [ alGetSourcei ] dip *uint ;
+ 0 uint <ref> dup [ alGetSourcei ] dip uint deref ;
: set-buffer-param ( source param value -- )
alBufferi ;
: get-buffer-param ( source param -- value )
- 0 <uint> dup [ alGetBufferi ] dip *uint ;
+ 0 uint <ref> dup [ alGetBufferi ] dip uint deref ;
: source-play ( source -- ) alSourcePlay ;
str-alien str-buffer dup length memcpy str-alien ;
:: opencl-square ( in -- out )
- 0 f 0 <uint> [ clGetPlatformIDs cl-success ] keep *uint
+ 0 f 0 uint <ref> [ clGetPlatformIDs cl-success ] keep uint deref
dup <void*-array> [ f clGetPlatformIDs cl-success ] keep first
- CL_DEVICE_TYPE_DEFAULT 1 f <void*> [ f clGetDeviceIDs cl-success ] keep *void* :> device-id
- f 1 device-id <void*> f f 0 <int> [ clCreateContext ] keep *int cl-success :> context
- context device-id 0 0 <int> [ clCreateCommandQueue ] keep *int cl-success :> queue
+ CL_DEVICE_TYPE_DEFAULT 1 f void* <ref> [ f clGetDeviceIDs cl-success ] keep void* deref :> device-id
+ f 1 device-id void* <ref> f f 0 int <ref> [ clCreateContext ] keep int deref cl-success :> context
+ context device-id 0 0 int <ref> [ clCreateCommandQueue ] keep int deref cl-success :> queue
[
- context 1 kernel-source cl-string-array <void*>
- f 0 <int> [ clCreateProgramWithSource ] keep *int cl-success
+ context 1 kernel-source cl-string-array void* <ref>
+ f 0 int <ref> [ clCreateProgramWithSource ] keep int deref cl-success
[ 0 f f f f clBuildProgram cl-success ]
- [ "square" cl-string-array 0 <int> [ clCreateKernel ] keep *int cl-success ]
+ [ "square" cl-string-array 0 int <ref> [ clCreateKernel ] keep int deref cl-success ]
[ ] tri
] with-destructors :> ( kernel program )
context CL_MEM_READ_ONLY in byte-length f
- 0 <int> [ clCreateBuffer ] keep *int cl-success :> input
+ 0 int <ref> [ clCreateBuffer ] keep int deref cl-success :> input
context CL_MEM_WRITE_ONLY in byte-length f
- 0 <int> [ clCreateBuffer ] keep *int cl-success :> output
+ 0 int <ref> [ clCreateBuffer ] keep int deref cl-success :> output
queue input CL_TRUE 0 in byte-length in 0 f f clEnqueueWriteBuffer cl-success
- kernel 0 cl_mem heap-size input <void*> clSetKernelArg cl-success
- kernel 1 cl_mem heap-size output <void*> clSetKernelArg cl-success
- kernel 2 uint heap-size in length <uint> clSetKernelArg cl-success
+ kernel 0 cl_mem heap-size input void* <ref> clSetKernelArg cl-success
+ kernel 1 cl_mem heap-size output void* <ref> clSetKernelArg cl-success
+ kernel 2 uint heap-size in length uint <ref> clSetKernelArg cl-success
- queue kernel 1 f in length <ulonglong> f
+ queue kernel 1 f in length ulonglong <ref> f
0 f f clEnqueueNDRangeKernel cl-success
queue clFinish cl-success
cl-read-access num-bytes in <cl-buffer> &dispose :> in-buffer
cl-write-access num-bytes f <cl-buffer> &dispose :> out-buffer
- kernel in-buffer out-buffer num-floats <uint> 3array
+ kernel in-buffer out-buffer num-floats uint <ref> 3array
{ num-floats } [ ] cl-queue-kernel &dispose drop
cl-finish
! Copyright (C) 2010 Erik Charlebois.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays byte-arrays combinators
-combinators.smart destructors io.encodings.ascii io.encodings.string
-kernel libc locals math namespaces opencl.ffi sequences shuffle
-specialized-arrays variants ;
+USING: accessors alien alien.c-types alien.data arrays
+byte-arrays combinators combinators.smart destructors
+io.encodings.ascii io.encodings.string kernel libc locals math
+namespaces opencl.ffi sequences shuffle specialized-arrays
+variants ;
IN: opencl
SPECIALIZED-ARRAYS: void* char size_t ;
dup f = [ cl-error ] [ drop ] if ; inline
: info-data-size ( handle name info-quot -- size_t )
- [ 0 f 0 <size_t> ] dip [ call cl-success ] 2keep drop *size_t ; inline
+ [ 0 f 0 <size_t> ] dip [ call cl-success ] 2keep drop size_t deref ; inline
: info-data-bytes ( handle name info-quot size -- bytes )
swap [ dup <byte-array> f ] dip [ call cl-success ] 3keep 2drop ; inline
[ 3dup info-data-size info-data-bytes ] dip call ; inline
: 2info-data-size ( handle1 handle2 name info-quot -- size_t )
- [ 0 f 0 <size_t> ] dip [ call cl-success ] 2keep drop *size_t ; inline
+ [ 0 f 0 <size_t> ] dip [ call cl-success ] 2keep drop size_t deref ; inline
: 2info-data-bytes ( handle1 handle2 name info-quot size -- bytes )
swap [ dup <byte-array> f ] dip [ call cl-success ] 3keep 2drop ; inline
[ 4dup 2info-data-size 2info-data-bytes ] dip call ; inline
: info-bool ( handle name quot -- ? )
- [ *uint CL_TRUE = ] info ; inline
+ [ uint deref CL_TRUE = ] info ; inline
: info-ulong ( handle name quot -- ulong )
- [ *ulonglong ] info ; inline
+ [ ulonglong deref ] info ; inline
: info-int ( handle name quot -- int )
- [ *int ] info ; inline
+ [ int deref ] info ; inline
: info-uint ( handle name quot -- uint )
- [ *uint ] info ; inline
+ [ uint deref ] info ; inline
: info-size_t ( handle name quot -- size_t )
- [ *size_t ] info ; inline
+ [ size_t deref ] info ; inline
: 2info-size_t ( handle1 handle2 name quot -- size_t )
- [ *size_t ] 2info ; inline
+ [ size_t deref ] 2info ; inline
: info-string ( handle name quot -- string )
[ ascii decode 1 head* ] info ; inline
: platform-devices ( platform-id -- devices )
CL_DEVICE_TYPE_ALL [
- 0 f 0 <uint> [ clGetDeviceIDs cl-success ] keep *uint
+ 0 f 0 uint <ref> [ clGetDeviceIDs cl-success ] keep uint deref
] [
rot dup <void*-array> [ f clGetDeviceIDs cl-success ] keep
] 2bi ; inline
[ length ]
[ strings>char*-array ]
[ [ length ] size_t-array{ } map-as ] tri
- 0 <int> [ clCreateProgramWithSource ] keep *int cl-success
+ 0 int <ref> [ clCreateProgramWithSource ] keep int deref cl-success
] with-destructors ;
:: (build-program) ( program-handle device options -- program )
[ clGetEventProfilingInfo ] info-ulong ;
: bind-kernel-arg-buffer ( kernel index buffer -- )
- [ handle>> ] [ cl_mem heap-size ] [ handle>> <void*> ] tri*
+ [ handle>> ] [ cl_mem heap-size ] [ handle>> void* deref ] tri*
clSetKernelArg cl-success ; inline
: bind-kernel-arg-data ( kernel index byte-array -- )
] dip bind ; inline
: cl-platforms ( -- platforms )
- 0 f 0 <uint> [ clGetPlatformIDs cl-success ] keep *uint
+ 0 f 0 uint <ref> [ clGetPlatformIDs cl-success ] keep uint deref
dup <void*-array> [ f clGetPlatformIDs cl-success ] keep
[
dup
: <cl-context> ( devices -- cl-context )
[ f ] dip
[ length ] [ [ id>> ] void*-array{ } map-as ] bi
- f f 0 <int> [ clCreateContext ] keep *int cl-success
+ f f 0 int <ref> [ clCreateContext ] keep int deref cl-success
cl-context new-disposable swap >>handle ;
: <cl-queue> ( context device out-of-order? profiling? -- command-queue )
[ [ handle>> ] [ id>> ] bi* ] 2dip
[ [ CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE ] [ 0 ] if ]
[ [ CL_QUEUE_PROFILING_ENABLE ] [ 0 ] if ] bi* bitor
- 0 <int> [ clCreateCommandQueue ] keep *int cl-success
+ 0 int <ref> [ clCreateCommandQueue ] keep int deref cl-success
cl-queue new-disposable swap >>handle ;
: cl-out-of-order-execution? ( command-queue -- ? )
[ buffer-access-constant ]
[ [ CL_MEM_COPY_HOST_PTR ] [ CL_MEM_ALLOC_HOST_PTR ] if ] tri* bitor
] 2dip
- 0 <int> [ clCreateBuffer ] keep *int cl-success
+ 0 int <ref> [ clCreateBuffer ] keep int deref cl-success
cl-buffer new-disposable swap >>handle ;
: cl-read-buffer ( buffer-range -- byte-array )
[ [ buffer>> handle>> ] [ offset>> ] bi ]
tri* swapd
] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty
- f <void*> [ clEnqueueCopyBuffer cl-success ] keep *void* cl-event
+ f void* <ref> [ clEnqueueCopyBuffer cl-success ] keep void* deref cl-event
new-disposable swap >>handle ;
: cl-queue-read-buffer ( buffer-range alien dependent-events -- event )
[ (current-cl-queue) handle>> ] dip
[ buffer>> handle>> CL_FALSE ] [ offset>> ] [ size>> ] tri
] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty
- f <void*> [ clEnqueueReadBuffer cl-success ] keep *void* cl-event
+ f void* <ref> [ clEnqueueReadBuffer cl-success ] keep void* <ref> cl-event
new-disposable swap >>handle ;
: cl-queue-write-buffer ( buffer-range alien dependent-events -- event )
[ (current-cl-queue) handle>> ] dip
[ buffer>> handle>> CL_FALSE ] [ offset>> ] [ size>> ] tri
] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty
- f <void*> [ clEnqueueWriteBuffer cl-success ] keep *void* cl-event
+ f void* <ref> [ clEnqueueWriteBuffer cl-success ] keep void* deref cl-event
new-disposable swap >>handle ;
: <cl-sampler> ( normalized-coords? addressing-mode filter-mode -- sampler )
[ [ CL_TRUE ] [ CL_FALSE ] if ]
[ addressing-mode-constant ]
[ filter-mode-constant ]
- tri* 0 <int> [ clCreateSampler ] keep *int cl-success
+ tri* 0 int <ref> [ clCreateSampler ] keep int deref cl-success
cl-sampler new-disposable swap >>handle ;
: cl-normalized-coords? ( sampler -- ? )
: <cl-kernel> ( program kernel-name -- kernel )
[ handle>> ] [ ascii encode 0 suffix ] bi*
- 0 <int> [ clCreateKernel ] keep *int cl-success
+ 0 int <ref> [ clCreateKernel ] keep int deref cl-success
cl-kernel new-disposable swap >>handle ; inline
: cl-kernel-name ( kernel -- string )
kernel handle>>
sizes [ length f ] [ [ ] size_t-array{ } map-as f ] bi
dependent-events [ length ] [ [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty ] bi
- f <void*> [ clEnqueueNDRangeKernel cl-success ] keep *void*
+ f void* <ref> [ clEnqueueNDRangeKernel cl-success ] keep void* deref
cl-event new-disposable swap >>handle ;
: cl-event-type ( event -- command-type )
: cl-marker ( -- event )
(current-cl-queue)
- f <void*> [ clEnqueueMarker cl-success ] keep *void* cl-event new-disposable
+ f void* <ref> [ clEnqueueMarker cl-success ] keep void* deref cl-event new-disposable
swap >>handle ; inline
: cl-barrier ( -- )
! Copyright (C) 2010 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax assocs ;
IN: path-finding
-{ <astar> <bfs> } related-words
+{ <astar> <bfs> <dijkstra> } related-words
HELP: astar
{ $description "This tuple must be subclassed and its method " { $link cost } ", "
{ "neighbours" "a quotation with stack effect ( node -- seq )" }
{ "cost" "a quotation with stack effect ( from to -- cost )" }
{ "heuristic" "a quotation with stack effect ( pos target -- cost )" }
- { "astar" "a astar tuple" }
+ { "astar" astar }
}
{ $description "Build an astar object from the given quotations. The "
{ $snippet "neighbours" } " one builds the list of neighbours. The "
HELP: <bfs>
{ $values
- { "neighbours" "an assoc" }
- { "astar" "a astar tuple" }
+ { "neighbours" assoc }
+ { "astar" astar }
}
{ $description "Build an astar object from the " { $snippet "neighbours" } " assoc. "
"When used with " { $link find-path } ", this astar tuple will use the breadth-first search (BFS) "
"path finding algorithm which is a particular case of the general A* algorithm."
} ;
+HELP: <dijkstra>
+{ $values
+ { "costs" assoc }
+ { "astar" astar }
+}
+{ $description "Build an astar object from the " { $snippet "costs" } " assoc. "
+ "The assoc keys are edges of the graph, while the corresponding values are assocs whose keys are "
+ "the edges that can be reached and whose values are the costs to reach those edges. When used with "
+ { $link find-path } ", this astar tuple will use the Dijkstra path finding algorithm which is "
+ "a particular case of the general A* algorithm."
+} ;
+
HELP: find-path
{ $values
{ "start" "a node" }
{ "target" "a node" }
- { "astar" "a astar tuple" }
+ { "astar" astar }
{ "path/f" "an optimal path from " { $snippet "start" } " to " { $snippet "target" }
", or f if no such path exists" }
}
HELP: considered
{ $values
- { "astar" "a astar tuple" }
+ { "astar" astar }
{ "considered" "a sequence" }
}
{ $description "When called after a call to " { $link find-path } ", return a list of nodes "
[ f ] [ "FA" first2 routes <bfs> find-path ] unit-test
[ "DC" ] [ "DC" first2 routes <bfs> find-path >string ] unit-test
+
+<<
+
+! Build the costs as expected by the dijkstra word.
+
+MEMO: costs ( -- costs )
+ routes keys [ dup dup n [ dup [ c ] dip swap 2array ] with { } map-as >hashtable 2array ] map >hashtable ;
+
+: test3 ( fromto -- path considered )
+ first2 costs <dijkstra> [ find-path ] [ considered natural-sort >string ] bi ;
+
+>>
+
+! Check path from A to C -- all nodes but F must have been examined
+[ "ADC" "ABCDE" ] [ "AC" test3 [ >string ] dip ] unit-test
+
+! No path from D to B -- all nodes reachable from D must have been examined
+[ f "CDEF" ] [ "DB" test3 ] unit-test
M: bfs heuristic 3drop 0 ;
M: bfs neighbours neighbours>> at ;
+TUPLE: dijkstra < astar costs ;
+M: dijkstra cost costs>> swapd at at ;
+M: dijkstra heuristic 3drop 0 ;
+M: dijkstra neighbours costs>> at keys ;
+
PRIVATE>
: find-path ( start target astar -- path/f )
: <bfs> ( neighbours -- astar )
[ bfs new ] dip >>neighbours ;
+
+: <dijkstra> ( costs -- astar )
+ [ dijkstra new ] dip >>costs ;
! (1 + 2 + ... + 10)² = 55² = 3025
! Hence the difference between the sum of the squares of the first ten natural
-! numbers and the square of the sum is 3025 385 = 2640.
+! numbers and the square of the sum is 3025 - 385 = 2640.
! Find the difference between the sum of the squares of the first one hundred
! natural numbers and the square of the sum.
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators constructors io.encodings.utf8
+io.files kernel math math.parser sequences splitting
+unicode.categories ;
+IN: resolv-conf
+
+TUPLE: network ip netmask ;
+CONSTRUCTOR: network ( ip netmask -- network ) ;
+
+TUPLE: options
+debug?
+edns0?
+insecure1?
+insecure2?
+{ ndots integer initial: 1 }
+{ timeout integer initial: 5 }
+{ attempts integer initial: 2 }
+rotate? no-check-names? inet6? tcp? ;
+
+CONSTRUCTOR: options ( -- options ) ;
+
+TUPLE: resolv.conf nameserver domain lookup search sortlist options ;
+
+CONSTRUCTOR: resolv.conf ( -- resolv.conf )
+ V{ } clone >>nameserver
+ V{ } clone >>domain
+ V{ } clone >>search
+ V{ } clone >>sortlist
+ V{ } clone >>lookup
+ <options> >>options ;
+
+<PRIVATE
+
+: trim-blanks ( string -- string' ) [ blank? ] trim ;
+
+: split-line ( resolv.conf string -- resolv.conf seq resolv.conf )
+ trim-blanks " " split
+ [ trim-blanks ] map harvest over ;
+
+: parse-nameserver ( resolv.conf string -- resolv.conf )
+ split-line nameserver>> push-all ;
+
+: parse-domain ( resolv.conf string -- resolv.conf )
+ split-line domain>> push-all ;
+
+: parse-lookup ( resolv.conf string -- resolv.conf )
+ split-line lookup>> push-all ;
+
+: parse-search ( resolv.conf string -- resolv.conf )
+ split-line search>> push-all ;
+
+: parse-sortlist ( resolv.conf string -- resolv.conf )
+ trim-blanks " " split
+ [ trim-blanks "/" split1 <network> ] map >>sortlist ;
+
+ERROR: unsupported-resolv.conf-option string ;
+
+: parse-integer ( string -- n )
+ trim-blanks ":" ?head drop trim-blanks string>number ;
+
+: parse-option ( resolv.conf string -- resolv.conf )
+ [ dup options>> ] dip trim-blanks {
+ { [ "debug" ?head ] [ drop t >>debug? ] }
+ { [ "ndots:" ?head ] [ parse-integer >>ndots ] }
+ { [ "timeout" ?head ] [ parse-integer >>timeout ] }
+ { [ "attempts" ?head ] [ parse-integer >>attempts ] }
+ { [ "rotate" ?head ] [ drop t >>rotate? ] }
+ { [ "no-check-names" ?head ] [ drop t >>no-check-names? ] }
+ { [ "inet6" ?head ] [ drop t >>inet6? ] }
+ [ unsupported-resolv.conf-option ]
+ } cond drop ;
+
+ERROR: unsupported-resolv.conf-line string ;
+
+: parse-resolv.conf-line ( resolv.conf string -- resolv.conf )
+ {
+ { [ "nameserver" ?head ] [ parse-nameserver ] }
+ { [ "domain" ?head ] [ parse-domain ] }
+ { [ "lookup" ?head ] [ parse-lookup ] }
+ { [ "search" ?head ] [ parse-search ] }
+ { [ "sortlist" ?head ] [ parse-sortlist ] }
+ { [ "options" ?head ] [ parse-option ] }
+ [ unsupported-resolv.conf-line ]
+ } cond ;
+
+PRIVATE>
+
+: parse-resolve.conf ( path -- resolv.conf )
+ [ <resolv.conf> ] dip
+ utf8 file-lines
+ [ [ blank? ] trim ] map harvest
+ [ "#" head? not ] filter
+ [ parse-resolv.conf-line ] each ;
+
+: default-resolv.conf ( -- resolv.conf )
+ "/etc/resolv.conf" parse-resolve.conf ;
--- /dev/null
+#
+# Mac OS X Notice
+#
+# This file is not used by the host name and address resolution
+# or the DNS query routing mechanisms used by most processes on
+# this Mac OS X system.
+ #
+ # This file is automatically generated.
+ #
+ nameserver 8.8.8.8
+ domain hmm.lol.com
+ search a.com b.com c.com
+
+sortlist 130.155.160.0/255.255.240.0 130.155.0.0 131.155.160.0/255.255.240.0 130.155.0.1
+
+ options debug
+ options ndots:10
+ options timeout:11
+ options attempts : 12
+ options rotate
+ options no-check-names
+ options inet6
+
+
+
+
+
+
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays assocs destructors fry functors
-kernel locals sequences serialize tokyo.alien.tcutil tokyo.utils vectors ;
+USING: accessors alien.c-types alien.data arrays assocs
+destructors fry functors kernel locals sequences serialize
+tokyo.alien.tcutil tokyo.utils vectors ;
IN: tokyo.assoc-functor
FUNCTOR: define-tokyo-assoc-api ( T N -- )
M: TYPE dispose* [ DBDEL f ] change-handle drop ;
M: TYPE at* ( key db -- value/f ? )
- handle>> swap object>bytes dup length 0 <int>
+ handle>> swap object>bytes dup length 0 int <ref>
DBGET [ [ memory>object ] [ tcfree ] bi t ] [ f f ] if* ;
M: TYPE assoc-size ( db -- size ) handle>> DBRNUM ;
: DBKEYS ( db -- keys )
[ assoc-size <vector> ] [ handle>> ] bi
- dup DBITERINIT drop 0 <int>
+ dup DBITERINIT drop 0 int <ref>
[ 2dup DBITERNEXT dup ] [
[ memory>object ] [ tcfree ] bi
[ pick ] dip swap push
USING: combinators kernel generic math math.functions
math.parser namespaces io sequences trees shuffle
assocs parser accessors math.order prettyprint.custom
-trees.private ;
+trees.private fry ;
IN: trees.avl
TUPLE: avl < tree ;
: <avl> ( -- tree )
- avl new-tree ;
+ avl new-tree ; inline
<PRIVATE
: <avl-node> ( key value -- node )
avl-node new-node
- 0 >>balance ;
+ 0 >>balance ; inline
-: increase-balance ( node amount -- )
- swap [ + ] change-balance drop ;
+: increase-balance ( node amount -- node )
+ '[ _ + ] change-balance ;
: rotate ( node -- node )
- dup node+link
- dup node-link
- pick set-node+link
+ dup
+ [ node+link ]
+ [ node-link ]
+ [ set-node+link ] tri
[ set-node-link ] keep ;
: single-rotate ( node -- node )
: pick-balances ( a node -- balance balance )
balance>> {
{ [ dup zero? ] [ 2drop 0 0 ] }
- { [ over = ] [ neg 0 ] }
- [ 0 swap ]
+ { [ 2dup = ] [ nip neg 0 ] }
+ [ drop 0 swap ]
} cond ;
: double-rotate ( node -- node )
: balance-insert ( node -- node taller? )
dup balance>> {
{ [ dup zero? ] [ drop f ] }
- { [ dup abs 2 = ]
- [ sgn neg [ select-rotate ] with-side f ] }
- { [ drop t ] [ t ] } ! balance is -1 or 1, tree is taller
+ { [ dup abs 2 = ] [ sgn neg [ select-rotate ] with-side f ] }
+ [ drop t ] ! balance is -1 or 1, tree is taller
} cond ;
DEFER: avl-set
2dup key>> before? left right ? [
[ node-link avl-set ] keep swap
[ [ set-node-link ] keep ] dip
- [ dup current-side get increase-balance balance-insert ]
+ [ current-side get increase-balance balance-insert ]
[ f ] if
] with-side ;
dup balance>> {
{ [ dup zero? ] [ drop t ] }
{ [ dup abs 2 = ] [ sgn neg [ delete-select-rotate ] with-side ] }
- { [ drop t ] [ f ] } ! balance is -1 or 1, tree is not shorter
+ [ drop f ] ! balance is -1 or 1, tree is not shorter
} cond ;
: balance-delete ( node -- node shorter? )
current-side get over balance>> {
{ [ dup zero? ] [ drop neg over balance<< f ] }
- { [ dupd = ] [ drop 0 >>balance t ] }
- [ dupd neg increase-balance rebalance-delete ]
+ { [ 2dup = ] [ 2drop 0 >>balance t ] }
+ [ drop neg increase-balance rebalance-delete ]
} cond ;
: avl-replace-with-extremity ( to-replace node -- node shorter? )
PRIVATE>
: >avl ( assoc -- avl )
- T{ avl f f 0 } assoc-clone-like ;
+ T{ avl } assoc-clone-like ;
M: avl assoc-like
drop dup avl? [ >avl ] unless ;
parser math.order accessors deques make prettyprint.custom ;
IN: trees
-TUPLE: tree root count ;
+TUPLE: tree root { count integer } ;
<PRIVATE
: new-node ( key value class -- node )
new
swap >>value
- swap >>key ;
+ swap >>key ; inline
: <node> ( key value -- node )
node new-node ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators hashtables http
http.client json.reader kernel macros namespaces sequences
-urls.secure fry oauth urls system ;
+io.sockets.secure fry oauth urls ;
IN: twitter
! Configuration
] with-scope ; inline
: twitter-url ( string -- string' )
- os windows?
- "http://twitter.com/"
- "https://twitter.com/" ? prepend ;
+ ssl-supported?
+ "https://twitter.com/" "http://twitter.com/" ? prepend ;
PRIVATE>
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar db db.sqlite db.tuples db.types kernel
-math math.order sequences combinators.short-circuit ;
+math math.order sequences combinators.short-circuit
+io.pathnames ;
IN: webapps.mason.backend
CONSTANT: +idle+ "idle"
: os/cpu ( builder -- string )
[ os>> ] [ cpu>> ] bi "/" glue ;
-: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
+: mason-db ( -- db ) home "mason.db" append-path <sqlite-db> ;
: with-mason-db ( quot -- )
mason-db [ with-transaction ] with-db ; inline
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors continuations furnace.actions help.html
+USING: accessors furnace.actions help.html
http.server.responses io.directories io.directories.hierarchy
-io.launcher io.files io.pathnames kernel memoize threads
-webapps.mason.utils ;
+io.files io.launcher io.pathnames kernel mason.config memoize
+namespaces sequences threads webapps.mason.utils ;
IN: webapps.mason.docs-update
+: docs-path ( -- path )
+ docs-directory get "docs.tar.gz" append-path ;
+
: update-docs ( -- )
home [
+ "newdocs" exists? [ "newdocs" delete-tree ] when
+
"newdocs" make-directory
- "newdocs" [ { "tar" "xfz" "../docs.tar.gz" } try-process ] with-directory
+ "newdocs" [ { "tar" "xfz" } docs-path suffix try-process ] with-directory
"docs" exists? [ "docs" "docs.old" move-file ] when
"newdocs/docs" "docs" move-file
<t:title>Factor binary package for <t:label t:name="platform" /></t:title>
- <div><img src="http://factorcode.org/graphics/logo.png" alt="Logo" /></div>
+ <div><img src="http://factorcode.org/logo.png" alt="Logo" /></div>
<h1>Factor binary package for <t:label t:name="platform" /></h1>
<t:title>Factor binary package for <t:label t:name="platform" /></t:title>
- <div><img src="http://factorcode.org/graphics/logo.png" alt="Logo" /></div>
+ <div><img src="http://factorcode.org/logo.png" alt="Logo" /></div>
<h1>Factor binary package for <t:label t:name="platform" /></h1>
packages-url dup link ;
: clean-image-url ( builder -- url )
- platform "http://factorcode.org/images/clean/" prepend ;
+ platform "http://downloads.factorcode.org/images/clean/" prepend ;
: clean-image-link ( builder -- link )
clean-image-url dup link ;
html.components
http.server
http.server.dispatchers
+http.server.static
furnace
furnace.actions
furnace.redirection
<planet-action> "" add-responder
<planet-feed-action> "feed.xml" add-responder
<planet-admin> "admin" add-responder
+ "vocab:webapps/planet/icons/" <static> "icons" add-responder
<boilerplate>
{ planet "planet-common" } >>template ;
<a href="http://planet.lisp.org">Planet Lisp</a>.
</p>
<p>
- <img src="http://factorcode.org/feed-icon-14x14.png" />
+ <img src="http://planet.factorcode.org/icons/feed-icon-14x14.png" />
<t:a t:href="$planet/feed.xml">Syndicate</t:a>
</p>
</td>
USING: accessors kernel sequences assocs io.files io.pathnames
io.sockets io.sockets.secure io.servers
namespaces db db.tuples db.sqlite smtp urls
-logging.insomniac
+logging.insomniac calendar timers
html.templates.chloe
http.server
http.server.dispatchers
webapps.help
webapps.mason
webapps.mason.backend
+webapps.mason.backend.watchdog
websites.factorcode ;
IN: websites.concatenative
-: test-db ( -- db ) "resource:test.db" <sqlite-db> ;
+: website-db ( -- db ) home "website.db" append-path <sqlite-db> ;
: init-factor-db ( -- )
mason-db [ init-mason-db ] with-db
- test-db [
+ website-db [
init-furnace-tables
{
allow-edit-profile
allow-deactivation ;
+SYMBOLS: factor-recaptcha-public-key factor-recaptcha-private-key ;
+
: <factor-recaptcha> ( responder -- responder' )
<recaptcha>
"concatenative.org" >>domain
- "6LeJWQgAAAAAAFlYV7SuBClE9uSpGtV_ZS-qVON7" >>public-key
- "6LeJWQgAAAAAALh-XJgSSQ6xKygRgJ8-029Ip2Xv" >>private-key ;
+ factor-recaptcha-public-key get >>public-key
+ factor-recaptcha-private-key get >>private-key ;
: <concatenative-website> ( -- responder )
concatenative-website new-dispatcher
URL" /wiki/view/Front Page" <redirect-responder> "" add-responder ;
-SYMBOL: key-password
-SYMBOL: key-file
-SYMBOL: dh-file
+SYMBOLS: key-password key-file dh-file ;
: common-configuration ( -- )
- "concatenative.org" 25 <inet> smtp-server set-global
"noreply@concatenative.org" lost-password-from set-global
- "website@concatenative.org" insomniac-sender set-global
- { "slava@factorcode.org" } insomniac-recipients set-global
init-factor-db ;
: init-testing ( -- )
<planet> <login-config> <factor-boilerplate> "planet" add-responder
<mason-app> <login-config> <factor-boilerplate> "mason" add-responder
"/tmp/docs/" <help-webapp> "docs" add-responder
main-responder set-global ;
: <gitweb> ( path -- responder )
<concatenative-website>
<wiki> "wiki" add-responder
<user-admin> "user-admin" add-responder
- <login-config> <factor-boilerplate>
test-db <alloy> "concatenative.org" add-responder
- <pastebin> <factor-recaptcha> <login-config> <factor-boilerplate>
test-db <alloy> "paste.factorcode.org" add-responder
- <planet> <login-config> <factor-boilerplate>
test-db <alloy> "planet.factorcode.org" add-responder
- <mason-app> <login-config> <factor-boilerplate>
test-db <alloy> "builds.factorcode.org" add-responder
+ <login-config> <factor-boilerplate>
website-db <alloy> "concatenative.org" add-responder
+ <pastebin> <factor-recaptcha> <login-config> <factor-boilerplate>
website-db <alloy> "paste.factorcode.org" add-responder
+ <planet> <login-config> <factor-boilerplate>
website-db <alloy> "planet.factorcode.org" add-responder
+ <mason-app> <login-config> <factor-boilerplate>
website-db <alloy> "builds.factorcode.org" add-responder
home "docs" append-path <help-webapp> "docs.factorcode.org" add-responder
home "cgi" append-path <gitweb> "gitweb.factorcode.org" add-responder
- <factor-website> "new.factorcode.org" add-responder
main-responder set-global ;
: <factor-secure-config> ( -- config )
8080 >>insecure
8431 >>secure ;
+: start-watchdog ( -- )
+ [ check-builders ] 6 hours every drop ;
+
: start-website ( -- server )
- test-db start-expiring
- test-db start-update-task
+ website-db start-expiring
+ website-db start-update-task
http-insomniac
+ start-watchdog
<concatenative-website-server> start-server ;
http.server.static kernel namespaces sequences ;
IN: websites.factorcode
-SYMBOL: users
-
: <factor-website> ( -- website )
<dispatcher>
- "resource:extra/websites/factorcode/" <static> enable-fhtml >>default
- users get [
- [ "/home/" "/www/" surround <static> ] keep add-responder
- ] each ;
+ "resource:extra/websites/factorcode/" <static> enable-fhtml >>default ;
: init-testing ( -- )
<factor-website> main-responder set-global ;
--- /dev/null
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
LIBS = -lm
+PLAF_DLL_OBJS += vm/os-windows.o vm/mvm-windows.o
PLAF_EXE_OBJS += vm/resources.o vm/main-windows.o
EXE_SUFFIX=
} \
}
-BIGNUM_TO_FOO(cell,cell,fixnum,cell);
-BIGNUM_TO_FOO(fixnum,fixnum,fixnum,cell);
+BIGNUM_TO_FOO(cell,cell,fixnum,cell)
+BIGNUM_TO_FOO(fixnum,fixnum,fixnum,cell)
BIGNUM_TO_FOO(long_long,s64,s64,u64)
BIGNUM_TO_FOO(ulong_long,u64,s64,u64)
-double factor_vm::bignum_to_double(bignum * bignum)
-{
- if (BIGNUM_ZERO_P (bignum))
- return (0);
- {
- double accumulator = 0;
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
- while (start < scan)
- accumulator = ((accumulator * BIGNUM_RADIX) + (*--scan));
- return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator);
- }
-}
-
#define DTB_WRITE_DIGIT(factor) \
{ \
significand *= (factor); \
gc_info *info = compiled->block_gc_info();
assert(return_address < compiled->size());
- int index = info->return_address_index(return_address);
- if(index != -1)
+ cell index = info->return_address_index(return_address);
+ if(index != (cell)-1)
ctx->scrub_stacks(info,index);
}
};
return i;
}
- return gc_info_missing_value;
+ return (cell)-1;
}
}
namespace factor
{
-const u32 gc_info_missing_value = (u32)-1;
-
struct gc_info {
u32 scrub_d_count;
u32 scrub_r_count;
+ index * gc_root_count;
}
- cell lookup_base_pointer(cell index, cell derived_root)
+ u32 lookup_base_pointer(cell index, cell derived_root)
{
return base_pointer_map()[index * derived_root_count + derived_root];
}
ctx->replace(allot_float(fixnum_to_float(ctx->peek())));
}
-void factor_vm::primitive_bignum_to_float()
-{
- ctx->replace(allot_float(bignum_to_float(ctx->peek())));
-}
-
void factor_vm::primitive_format_float()
{
byte_array *array = allot_byte_array(100);
return double_to_bignum(untag_float(tagged));
}
-inline double factor_vm::bignum_to_float(cell tagged)
-{
- return bignum_to_double(untag<bignum>(tagged));
-}
-
inline double factor_vm::untag_float(cell tagged)
{
return untag<boxed_float>(tagged)->n;
_(bignum_shift) \
_(bignum_subtract) \
_(bignum_to_fixnum) \
- _(bignum_to_float) \
_(bignum_xor) \
_(bits_double) \
_(bits_float) \
gc_info *info = compiled->block_gc_info();
assert(return_address < compiled->size());
- u32 callsite = info->return_address_index(return_address);
- if(callsite == gc_info_missing_value)
+ cell callsite = info->return_address_index(return_address);
+ if(callsite == (cell)-1)
return;
#ifdef DEBUG_GC_MAPS
/* Subtract old value of base pointer from every derived pointer. */
for(cell spill_slot = 0; spill_slot < info->derived_root_count; spill_slot++)
{
- cell base_pointer = info->lookup_base_pointer(callsite, spill_slot);
- if(base_pointer != gc_info_missing_value)
+ u32 base_pointer = info->lookup_base_pointer(callsite, spill_slot);
+ if(base_pointer != (u32)-1)
{
#ifdef DEBUG_GC_MAPS
std::cout << "visiting derived root " << spill_slot
/* Add the base pointers to obtain new derived pointer values. */
for(cell spill_slot = 0; spill_slot < info->derived_root_count; spill_slot++)
{
- cell base_pointer = info->lookup_base_pointer(callsite, spill_slot);
- if(base_pointer != gc_info_missing_value)
+ u32 base_pointer = info->lookup_base_pointer(callsite, spill_slot);
+ if(base_pointer != (u32)-1)
stack_pointer[spill_slot] += stack_pointer[base_pointer];
}
}
fixnum bignum_to_fixnum(bignum * bignum);
s64 bignum_to_long_long(bignum * bignum);
u64 bignum_to_ulong_long(bignum * bignum);
- double bignum_to_double(bignum * bignum);
bignum *double_to_bignum(double x);
int bignum_equal_p_unsigned(bignum * x, bignum * y);
enum bignum_comparison bignum_compare_unsigned(bignum * x, bignum * y);
inline cell unbox_array_size();
cell unbox_array_size_slow();
void primitive_fixnum_to_float();
- void primitive_bignum_to_float();
void primitive_format_float();
void primitive_float_eq();
void primitive_float_add();
inline cell from_unsigned_cell(cell x);
inline cell allot_float(double n);
inline bignum *float_to_bignum(cell tagged);
- inline double bignum_to_float(cell tagged);
inline double untag_float(cell tagged);
inline double untag_float_check(cell tagged);
inline fixnum float_to_fixnum(cell tagged);
projects / factor.git / commitdiff
