diff --git a/GNUmakefile b/GNUmakefile index 38e3b0d736..43fba15c0b 100755 --- a/GNUmakefile +++ b/GNUmakefile @@ -154,12 +154,12 @@ solaris-x86-64: $(MAKE) $(ALL) CONFIG=vm/Config.solaris.x86.64 winnt-x86-32: - $(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.32 - $(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.32 + $(MAKE) $(ALL) CONFIG=vm/Config.windows.x86.32 + $(MAKE) factor-console CONFIG=vm/Config.windows.x86.32 winnt-x86-64: - $(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.64 - $(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.64 + $(MAKE) $(ALL) CONFIG=vm/Config.windows.x86.64 + $(MAKE) factor-console CONFIG=vm/Config.windows.x86.64 ifdef CONFIG diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index 32c1d18d51..e14a5cb5e1 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -38,16 +38,6 @@ HELP: set-alien-value { $description "Stores a value at a byte offset from a base C pointer." } { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; -HELP: define-deref -{ $values { "c-type" "a C type" } } -{ $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." } -{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ; - -HELP: define-out -{ $values { "c-type" "a C type" } } -{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." } -{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ; - HELP: char { $description "This C type represents a one-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ; HELP: uchar @@ -118,43 +108,6 @@ $nl "If this condition is not satisfied, " { $link "malloc" } " must be used instead." { $warning "Failure to comply with these requirements can lead to crashes, data corruption, and security exploits." } ; -ARTICLE: "c-out-params" "Output parameters in C" -"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations." -$nl -"Each numerical C type, together with " { $snippet "void*" } ", has an associated " { $emphasis "out parameter constructor" } " word which takes a Factor object as input, constructs a byte array of the correct size, and converts the Factor object to a C value stored into the byte array:" -{ $subsections - - - - - - - - - - - - - -} -"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 } " 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 diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index 5e4635e018..661478e4bd 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -2,16 +2,13 @@ USING: alien alien.syntax alien.c-types alien.parser eval kernel tools.test sequences system libc alien.strings io.encodings.ascii io.encodings.utf8 math.constants classes.struct classes accessors compiler.units ; +FROM: alien.c-types => short ; IN: alien.c-types.tests CONSTANT: xyz 123 [ 492 ] [ { int xyz } heap-size ] unit-test -[ -1 ] [ -1 *char ] unit-test -[ -1 ] [ -1 *short ] unit-test -[ -1 ] [ -1 *int ] unit-test - UNION-STRUCT: foo { a int } { b int } ; @@ -52,14 +49,6 @@ TYPEDEF: int* MyIntArray [ t ] [ void* c-type MyIntArray c-type = ] unit-test -[ - 0 B{ 1 2 3 4 } -] must-fail - -os windows? cpu x86.64? and [ - [ -2147467259 ] [ 2147500037 *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 diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 04755ea033..19103ce3a8 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -1,12 +1,9 @@ ! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: byte-arrays arrays assocs delegate kernel kernel.private math -math.order math.parser namespaces make parser sequences strings -words splitting cpu.architecture alien alien.accessors -alien.strings quotations layouts system compiler.units io -io.files io.encodings.binary io.streams.memory accessors -combinators effects continuations fry classes vocabs -vocabs.loader words.symbol macros ; +USING: accessors alien alien.accessors arrays byte-arrays +classes combinators compiler.units cpu.architecture delegate +fry kernel layouts locals macros math math.order quotations +sequences system words words.symbol ; QUALIFIED: math IN: alien.c-types @@ -21,9 +18,6 @@ SYMBOLS: SINGLETON: void -DEFER: -DEFER: *char - TUPLE: abstract-c-type { class class initial: object } { boxed-class class initial: object } @@ -111,8 +105,6 @@ M: c-type-name base-type c-type ; M: c-type base-type ; -: little-endian? ( -- ? ) 1 *char 1 = ; foldable - GENERIC: heap-size ( name -- size ) M: abstract-c-type heap-size size>> ; @@ -170,19 +162,6 @@ TUPLE: long-long-type < c-type ; : ( -- c-type ) long-long-type new ; -: define-deref ( c-type -- ) - [ name>> CHAR: * prefix "alien.c-types" create ] - [ '[ 0 _ alien-value ] ] - bi (( c-ptr -- value )) define-inline ; - -: define-out ( c-type -- ) - [ name>> "alien.c-types" constructor-word ] - [ dup '[ _ heap-size (byte-array) [ 0 _ set-alien-value ] keep ] ] bi - (( value -- c-ptr )) define-inline ; - -: define-primitive-type ( c-type name -- ) - [ typedef ] [ define-deref ] [ define-out ] tri ; - : if-void ( c-type true false -- ) pick void? [ drop nip call ] [ nip call ] if ; inline @@ -247,7 +226,7 @@ M: pointer c-type [ >c-ptr ] >>unboxer-quot "allot_alien" >>boxer "alien_offset" >>unboxer - \ void* define-primitive-type + \ void* typedef fixnum >>class @@ -260,7 +239,7 @@ M: pointer c-type "from_signed_2" >>boxer "to_signed_2" >>unboxer [ >fixnum ] >>unboxer-quot - \ short define-primitive-type + \ short typedef fixnum >>class @@ -273,7 +252,7 @@ M: pointer c-type "from_unsigned_2" >>boxer "to_unsigned_2" >>unboxer [ >fixnum ] >>unboxer-quot - \ ushort define-primitive-type + \ ushort typedef fixnum >>class @@ -286,7 +265,7 @@ M: pointer c-type "from_signed_1" >>boxer "to_signed_1" >>unboxer [ >fixnum ] >>unboxer-quot - \ char define-primitive-type + \ char typedef fixnum >>class @@ -299,7 +278,7 @@ M: pointer c-type "from_unsigned_1" >>boxer "to_unsigned_1" >>unboxer [ >fixnum ] >>unboxer-quot - \ uchar define-primitive-type + \ uchar typedef math:float >>class @@ -313,7 +292,7 @@ M: pointer c-type "to_float" >>unboxer float-rep >>rep [ >float ] >>unboxer-quot - \ float define-primitive-type + \ float typedef math:float >>class @@ -326,7 +305,7 @@ M: pointer c-type "to_double" >>unboxer double-rep >>rep [ >float ] >>unboxer-quot - \ double define-primitive-type + \ double typedef cell 8 = [ @@ -340,7 +319,7 @@ M: pointer c-type "from_signed_4" >>boxer "to_signed_4" >>unboxer [ >fixnum ] >>unboxer-quot - \ int define-primitive-type + \ int typedef fixnum >>class @@ -353,7 +332,7 @@ M: pointer c-type "from_unsigned_4" >>boxer "to_unsigned_4" >>unboxer [ >fixnum ] >>unboxer-quot - \ uint define-primitive-type + \ uint typedef integer >>class @@ -365,7 +344,8 @@ M: pointer c-type 8 >>align-first "from_signed_cell" >>boxer "to_fixnum" >>unboxer - \ longlong define-primitive-type + [ >integer ] >>unboxer-quot + \ longlong typedef integer >>class @@ -377,14 +357,15 @@ M: pointer c-type 8 >>align-first "from_unsigned_cell" >>boxer "to_cell" >>unboxer - \ ulonglong define-primitive-type + [ >integer ] >>unboxer-quot + \ ulonglong typedef os windows? [ - \ int c-type \ long define-primitive-type - \ uint c-type \ ulong define-primitive-type + \ int c-type \ long typedef + \ uint c-type \ ulong typedef ] [ - \ longlong c-type \ long define-primitive-type - \ ulonglong c-type \ ulong define-primitive-type + \ longlong c-type \ long typedef + \ ulonglong c-type \ ulong typedef ] if \ longlong c-type \ ptrdiff_t typedef @@ -403,7 +384,8 @@ M: pointer c-type 4 >>align-first "from_signed_cell" >>boxer "to_fixnum" >>unboxer - \ int define-primitive-type + [ >integer ] >>unboxer-quot + \ int typedef integer >>class @@ -415,7 +397,8 @@ M: pointer c-type 4 >>align-first "from_unsigned_cell" >>boxer "to_cell" >>unboxer - \ uint define-primitive-type + [ >integer ] >>unboxer-quot + \ uint typedef integer >>class @@ -426,7 +409,8 @@ M: pointer c-type 8-byte-alignment "from_signed_8" >>boxer "to_signed_8" >>unboxer - \ longlong define-primitive-type + [ >integer ] >>unboxer-quot + \ longlong typedef integer >>class @@ -437,10 +421,11 @@ M: pointer c-type 8-byte-alignment "from_unsigned_8" >>boxer "to_unsigned_8" >>unboxer - \ ulonglong define-primitive-type + [ >integer ] >>unboxer-quot + \ ulonglong typedef - \ int c-type \ long define-primitive-type - \ uint c-type \ ulong define-primitive-type + \ int c-type \ long typedef + \ uint c-type \ ulong typedef \ int c-type \ ptrdiff_t typedef \ int c-type \ intptr_t typedef @@ -453,7 +438,7 @@ M: pointer c-type [ >c-bool ] >>unboxer-quot [ c-bool> ] >>boxer-quot object >>boxed-class - \ bool define-primitive-type + \ bool typedef ] with-compilation-unit diff --git a/basis/alien/data/data-docs.factor b/basis/alien/data/data-docs.factor index 1bfaa007fc..e860ff6889 100644 --- a/basis/alien/data/data-docs.factor +++ b/basis/alien/data/data-docs.factor @@ -1,7 +1,7 @@ USING: alien alien.c-types help.syntax help.markup libc kernel.private byte-arrays math strings hashtables alien.syntax alien.strings sequences io.encodings.string debugger destructors -vocabs.loader classes.struct quotations ; +vocabs.loader classes.struct quotations kernel ; IN: alien.data HELP: @@ -10,11 +10,6 @@ HELP: { $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: -{ $values { "type" "a C type" } { "array" byte-array } } -{ $description "Creates a byte array suitable for holding a value with the given C type." } -{ $errors "Throws an " { $link no-c-type } " error if the type does not exist." } ; - HELP: memory>byte-array { $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } } { $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ; @@ -125,6 +120,10 @@ ARTICLE: "c-pointers" "Passing pointers to C functions" { $warning "The Factor garbage collector can move byte arrays around, and code passing byte arrays, or objects backed by byte arrays, must obey important guidelines. See " { $link "byte-arrays-gc" } "." } ; +ARTICLE: "c-boxes" "C value boxes" +"Sometimes it is useful to create a byte array storing a single C value, like a struct with a single field. A pair of utility macros exist to make this more convenient:" +{ $subsections deref } ; + ARTICLE: "c-data" "Passing data between Factor and C" "Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers." $nl @@ -135,13 +134,12 @@ $nl "malloc" "c-strings" "c-out-params" + "c-boxes" } "Important guidelines for passing data in byte arrays:" { $subsections "byte-arrays-gc" } "C-style enumerated types are supported:" -{ $subsections "alien.enums" POSTPONE: ENUM: } -"C types can be aliased for convenience and consistency with native library documentation:" -{ $subsections POSTPONE: TYPEDEF: } +{ $subsections "alien.enums" } "A utility for defining " { $link "destructors" } " for deallocating memory:" { $subsections "alien.destructors" } "C struct and union types can be defined with " { $link POSTPONE: STRUCT: } " and " { $link POSTPONE: UNION: } ". See " { $link "classes.struct" } " for details. For passing arrays to and from C, use the " { $link "specialized-arrays" } " vocabulary." ; @@ -190,3 +188,20 @@ $nl { $subsections alien>string } "For example, if a C function returns a " { $link c-string } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "char*" } " and call " { $link (free) } " yourself." ; +HELP: +{ $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 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 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 } ; diff --git a/basis/alien/data/data-tests.factor b/basis/alien/data/data-tests.factor index 20a6c26b84..7d53c71815 100644 --- a/basis/alien/data/data-tests.factor +++ b/basis/alien/data/data-tests.factor @@ -1,9 +1,32 @@ -USING: alien alien.c-types alien.data alien.syntax +USING: alien alien.data alien.syntax classes.struct kernel sequences specialized-arrays -specialized-arrays.private tools.test compiler.units vocabs ; +specialized-arrays.private tools.test compiler.units vocabs +system ; +QUALIFIED-WITH: alien.c-types c IN: alien.data.tests -STRUCT: foo { a int } { b void* } { c bool } ; +[ -1 ] [ -1 c:char c:char deref ] unit-test +[ -1 ] [ -1 c:short c:short deref ] unit-test +[ -1 ] [ -1 c:int 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 c:int deref ] unit-test +[ -1 ] [ -1.0 c:long c:long deref ] unit-test +[ -1 ] [ -1.0 c:longlong c:longlong deref ] unit-test +[ 1 ] [ 1.0 c:uint c:uint deref ] unit-test +[ 1 ] [ 1.0 c:ulong c:ulong deref ] unit-test +[ 1 ] [ 1.0 c:ulonglong c:ulonglong deref ] unit-test + +[ + 0 B{ 1 2 3 4 } c:void* +] must-fail + +os windows? cpu x86.64? and [ + [ -2147467259 ] [ 2147500037 c:long c:long deref ] unit-test +] when + +STRUCT: foo { a c:int } { b c:void* } { c c:bool } ; SPECIALIZED-ARRAY: foo diff --git a/basis/alien/data/data.factor b/basis/alien/data/data.factor index ab34bf5a4e..e17ed9dc3c 100644 --- a/basis/alien/data/data.factor +++ b/basis/alien/data/data.factor @@ -7,6 +7,15 @@ stack-checker.dependencies combinators.short-circuit ; QUALIFIED: math IN: alien.data +: ( value c-type -- c-ptr ) + [ heap-size ] keep + '[ 0 _ set-alien-value ] keep ; inline + +: deref ( c-ptr c-type -- value ) + [ 0 ] dip alien-value ; inline + +: little-endian? ( -- ? ) 1 int char deref 1 = ; foldable + GENERIC: require-c-array ( c-type -- ) M: array require-c-array first require-c-array ; @@ -44,15 +53,6 @@ M: pointer : malloc-array ( n type -- array ) [ heap-size calloc ] [ ] 2bi ; inline -: (malloc-array) ( n type -- alien ) - [ heap-size * malloc ] [ ] 2bi ; inline - -: ( type -- array ) - heap-size ; inline - -: (c-object) ( type -- array ) - heap-size (byte-array) ; inline - : malloc-byte-array ( byte-array -- alien ) binary-object [ nip malloc dup ] 2keep memcpy ; diff --git a/basis/alien/enums/enums-docs.factor b/basis/alien/enums/enums-docs.factor index cc23a40df3..0625b07799 100644 --- a/basis/alien/enums/enums-docs.factor +++ b/basis/alien/enums/enums-docs.factor @@ -23,14 +23,6 @@ HELP: number>enum } { $description "Convert a number to an enum." } ; -ARTICLE: "alien.enums" "Enumeration types" -"The " { $vocab-link "alien.enums" } " vocab contains the implementation for " { $link POSTPONE: ENUM: } " C types, and provides words for converting between enum symbols and integers." -$nl -"Defining enums at run-time:" -{ $subsection define-enum } -"Conversions between enums and integers:" -{ $subsections enum>number number>enum } ; - { POSTPONE: ENUM: define-enum enum>number number>enum } related-words ABOUT: "alien.enums" diff --git a/basis/alien/enums/enums.factor b/basis/alien/enums/enums.factor index f46702f450..b0755c130b 100644 --- a/basis/alien/enums/enums.factor +++ b/basis/alien/enums/enums.factor @@ -13,7 +13,7 @@ PRIVATE> GENERIC: enum>number ( enum -- number ) foldable M: integer enum>number ; -M: symbol enum>number "enum-value" word-prop ; +M: word enum>number "enum-value" word-prop ; alien ] - [ ] - [ ] + [ longlong ] + [ float ] [ ] - [ 1 0 ? ] + [ 1 0 ? c:short ] } spread ] [ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ] } 5 ncleave @@ -211,7 +211,7 @@ intel-unix-abi fortran-abi [ [ drop ] [ drop ] [ drop ] - [ *float ] + [ float deref ] [ drop ] [ drop ] } spread @@ -239,7 +239,7 @@ intel-unix-abi fortran-abi [ [ [ ! [] - [ complex-float ] 1 ndip + [ complex-float heap-size ] 1 ndip ! [fortran-args>c-args] { [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave ! [fortran-invoke] @@ -280,7 +280,7 @@ intel-unix-abi fortran-abi [ { [ { [ ascii string>alien ] - [ ] + [ float ] [ ascii string>alien ] } spread ] [ { [ length ] [ drop ] [ length ] } spread ] @@ -298,7 +298,7 @@ intel-unix-abi fortran-abi [ [ ascii alien>nstring ] [ ] [ ascii alien>nstring ] - [ *float ] + [ float deref ] [ ] [ ascii alien>nstring ] } spread diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 3d87431084..f17e91b90c 100755 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -1,5 +1,5 @@ ! (c) 2009 Joe Groff, see BSD license -USING: accessors alien alien.c-types alien.complex alien.data +USING: accessors alien alien.complex alien.c-types alien.data alien.parser grouping alien.strings alien.syntax arrays ascii assocs byte-arrays combinators combinators.short-circuit fry generalizations kernel lexer macros math math.parser namespaces @@ -211,11 +211,11 @@ GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot ) M: integer-type (fortran-arg>c-args) [ size>> { - { f [ [ ] [ drop ] ] } - { 1 [ [ ] [ drop ] ] } - { 2 [ [ ] [ drop ] ] } - { 4 [ [ ] [ drop ] ] } - { 8 [ [ ] [ drop ] ] } + { f [ [ c:int ] [ drop ] ] } + { 1 [ [ c:char ] [ drop ] ] } + { 2 [ [ c:short ] [ drop ] ] } + { 4 [ [ c:int ] [ drop ] ] } + { 8 [ [ c:longlong ] [ drop ] ] } [ invalid-fortran-type ] } case ] args?dims ; @@ -226,9 +226,9 @@ M: logical-type (fortran-arg>c-args) M: real-type (fortran-arg>c-args) [ size>> { - { f [ [ ] [ drop ] ] } - { 4 [ [ ] [ drop ] ] } - { 8 [ [ ] [ drop ] ] } + { f [ [ c:float ] [ drop ] ] } + { 4 [ [ c:float ] [ drop ] ] } + { 8 [ [ c:double ] [ drop ] ] } [ invalid-fortran-type ] } case ] args?dims ; @@ -244,14 +244,14 @@ M: real-complex-type (fortran-arg>c-args) ] args?dims ; M: double-precision-type (fortran-arg>c-args) - [ drop [ ] [ drop ] ] args?dims ; + [ drop [ c:double ] [ drop ] ] args?dims ; M: double-complex-type (fortran-arg>c-args) [ drop [ ] [ drop ] ] args?dims ; M: character-type (fortran-arg>c-args) fix-character-type single-char? - [ [ first ] [ drop ] ] + [ [ first c:char ] [ drop ] ] [ [ ascii string>alien ] [ length ] ] if ; M: misc-type (fortran-arg>c-args) @@ -263,23 +263,25 @@ GENERIC: (fortran-result>) ( type -- quots ) [ dup dims>> [ drop { [ ] } ] ] dip if ; inline M: integer-type (fortran-result>) - [ size>> { - { f [ { [ *int ] } ] } - { 1 [ { [ *char ] } ] } - { 2 [ { [ *short ] } ] } - { 4 [ { [ *int ] } ] } - { 8 [ { [ *longlong ] } ] } - [ invalid-fortran-type ] - } case ] result?dims ; + [ + size>> { + { f [ { [ c:int deref ] } ] } + { 1 [ { [ c:char deref ] } ] } + { 2 [ { [ c:short deref ] } ] } + { 4 [ { [ c:int deref ] } ] } + { 8 [ { [ c:longlong deref ] } ] } + [ invalid-fortran-type ] + } case + ] result?dims ; M: logical-type (fortran-result>) [ call-next-method first [ zero? not ] append 1array ] result?dims ; M: real-type (fortran-result>) [ size>> { - { f [ { [ *float ] } ] } - { 4 [ { [ *float ] } ] } - { 8 [ { [ *double ] } ] } + { f [ { [ c:float deref ] } ] } + { 4 [ { [ c:float deref ] } ] } + { 8 [ { [ c:double deref ] } ] } [ invalid-fortran-type ] } case ] result?dims ; @@ -292,14 +294,14 @@ M: real-complex-type (fortran-result>) } case ] result?dims ; M: double-precision-type (fortran-result>) - [ drop { [ *double ] } ] result?dims ; + [ drop { [ c:double deref ] } ] result?dims ; M: double-complex-type (fortran-result>) [ drop { [ *complex-double ] } ] result?dims ; M: character-type (fortran-result>) fix-character-type single-char? - [ { [ *char 1string ] } ] + [ { [ c:char deref 1string ] } ] [ { [ ] [ ascii alien>nstring ] } ] if ; M: misc-type (fortran-result>) @@ -308,7 +310,7 @@ M: misc-type (fortran-result>) GENERIC: () ( type -- quot ) M: fortran-type () - (fortran-type>c-type) \ [ ] 2sequence ; + (fortran-type>c-type) \ heap-size \ [ ] 3sequence ; M: character-type () fix-character-type dims>> product dup @@ -425,8 +427,11 @@ MACRO: fortran-invoke ( return library function parameters -- ) { [ 2drop nip set-fortran-abi ] [ (fortran-invoke) ] } 4 ncleave ; : parse-arglist ( parameters return -- types effect ) - [ 2 group unzip [ "," ?tail drop ] map ] - [ [ { } ] [ 1array ] if-void ] + [ + 2 group + [ unzip [ "," ?tail drop ] map ] + [ [ first "!" head? ] filter [ second "," ?tail drop "'" append ] map ] bi + ] [ [ ] [ prefix ] if-void ] bi* ; :: define-fortran-function ( return library function parameters -- ) diff --git a/basis/alien/libraries/libraries-tests.factor b/basis/alien/libraries/libraries-tests.factor old mode 100644 new mode 100755 index f1dc228d83..2721ce48c0 --- a/basis/alien/libraries/libraries-tests.factor +++ b/basis/alien/libraries/libraries-tests.factor @@ -1,4 +1,4 @@ -USING: alien.libraries alien.syntax tools.test kernel ; +USING: alien alien.libraries alien.syntax tools.test kernel ; IN: alien.libraries.tests [ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test @@ -8,3 +8,21 @@ IN: alien.libraries.tests [ ] [ "doesnotexist" dlopen dlclose ] unit-test [ "fdasfsf" dll-valid? drop ] must-fail + +[ t ] [ + "test-library" "blah" cdecl add-library + "test-library" "BLAH" cdecl add-library? + "blah" remove-library +] unit-test + +[ t ] [ + "test-library" "blah" cdecl add-library + "test-library" "blah" stdcall add-library? + "blah" remove-library +] unit-test + +[ f ] [ + "test-library" "blah" cdecl add-library + "test-library" "blah" cdecl add-library? + "blah" remove-library +] unit-test diff --git a/basis/alien/libraries/libraries.factor b/basis/alien/libraries/libraries.factor index a3f52df098..206db7b188 100755 --- a/basis/alien/libraries/libraries.factor +++ b/basis/alien/libraries/libraries.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.strings assocs io.backend kernel namespaces destructors sequences strings -system io.pathnames ; +system io.pathnames fry ; IN: alien.libraries : dlopen ( path -- dll ) native-string>alien (dlopen) ; @@ -32,9 +32,15 @@ M: library dispose dll>> [ dispose ] when* ; : remove-library ( name -- ) libraries get delete-at* [ dispose ] [ drop ] if ; +: add-library? ( name path abi -- ? ) + [ library ] 2dip + '[ [ path>> _ = ] [ abi>> _ = ] bi and not ] [ t ] if* ; + : add-library ( name path abi -- ) - [ 2drop remove-library ] - [ swap libraries get set-at ] 3bi ; + 3dup add-library? [ + [ 2drop remove-library ] + [ swap libraries get set-at ] 3bi + ] [ 3drop ] if ; : library-abi ( library -- abi ) library [ abi>> ] [ cdecl ] if* ; diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor index c7ff228ab2..8f60e7e088 100644 --- a/basis/alien/syntax/syntax-docs.factor +++ b/basis/alien/syntax/syntax-docs.factor @@ -123,3 +123,13 @@ HELP: C-GLOBAL: { $syntax "C-GLOBAL: type name" } { $values { "type" "a C type" } { "name" "a C global variable name" } } { $description "Defines a new word named " { $snippet "name" } " which accesses a global variable in the current library, set with " { $link POSTPONE: LIBRARY: } "." } ; + +ARTICLE: "alien.enums" "Enumeration types" +"The " { $vocab-link "alien.enums" } " vocab contains the implementation for " { $link POSTPONE: ENUM: } " C types, and provides words for converting between enum singletons and integers. It is possible to dispatch off of members of an enum." +$nl +"Defining enums:" +{ $subsection POSTPONE: ENUM: } +"Defining enums at run-time:" +{ $subsection define-enum } +"Conversions between enums and integers:" +{ $subsections enum>number number>enum } ; diff --git a/basis/biassocs/biassocs-docs.factor b/basis/biassocs/biassocs-docs.factor index 5588920f2e..ac5f4324a4 100644 --- a/basis/biassocs/biassocs-docs.factor +++ b/basis/biassocs/biassocs-docs.factor @@ -18,10 +18,10 @@ HELP: once-at HELP: >biassoc { $values { "assoc" assoc } { "biassoc" biassoc } } -{ $description "Costructs a new biassoc with the same key/value pairs as the given assoc." } ; +{ $description "Constructs a new biassoc with the same key/value pairs as the given assoc." } ; ARTICLE: "biassocs" "Bidirectional assocs" -"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc opeartions (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time." +"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc operations (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time." $nl "Bidirectional assocs implement the entire " { $link "assocs-protocol" } " with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with." $nl diff --git a/basis/bit-sets/bit-sets-tests.factor b/basis/bit-sets/bit-sets-tests.factor index 0d4543f8f2..379dc1befc 100644 --- a/basis/bit-sets/bit-sets-tests.factor +++ b/basis/bit-sets/bit-sets-tests.factor @@ -64,3 +64,8 @@ IN: bit-sets.tests [ T{ bit-set f ?{ f } } T{ bit-set f ?{ t } } ] [ 1 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 diff --git a/basis/bit-sets/bit-sets.factor b/basis/bit-sets/bit-sets.factor index aa74c2b9fb..9720125621 100644 --- a/basis/bit-sets/bit-sets.factor +++ b/basis/bit-sets/bit-sets.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences byte-arrays bit-arrays math hints sets ; +USING: kernel accessors sequences byte-arrays bit-arrays math +math.bitwise hints sets ; IN: bit-sets TUPLE: bit-set { table bit-array read-only } ; @@ -14,19 +15,21 @@ M: bit-set in? over integer? [ table>> ?nth ] [ 2drop f ] if ; inline M: bit-set adjoin - ! This is allowed to crash when the elt couldn't go in the set + ! This is allowed to throw an error when the elt couldn't + ! go in the set [ t ] 2dip table>> set-nth ; M: bit-set delete - ! This isn't allowed to crash if the elt wasn't in the set + ! This isn't allowed to throw an error if the elt wasn't + ! in the set over integer? [ table>> 2dup bounds-check? [ [ f ] 2dip set-nth ] [ 2drop ] if ] [ 2drop ] if ; -! If you do binary set operations with a bitset, it's expected -! that the other thing can also be represented as a bitset +! If you do binary set operations with a bit-set, it's expected +! that the other thing can also be represented as a bit-set ! of the same length. > length ] bi@ = ] [ f ] if [ drop ] [ [ members ] dip table>> length @@ -84,3 +88,6 @@ M: bit-set set-like M: bit-set clone table>> clone bit-set boa ; + +M: bit-set cardinality + table>> bit-count ; diff --git a/basis/cache/cache-tests.factor b/basis/cache/cache-tests.factor new file mode 100755 index 0000000000..ea1c22b2cf --- /dev/null +++ b/basis/cache/cache-tests.factor @@ -0,0 +1,50 @@ +USING: cache tools.test accessors destructors kernel assocs +namespaces ; +IN: cache.tests + +TUPLE: mock-disposable < disposable n ; + +: ( n -- mock-disposable ) + mock-disposable new-disposable swap >>n ; + +M: mock-disposable dispose* drop ; + +[ ] [ "cache" set ] unit-test + +[ 0 ] [ "cache" get assoc-size ] unit-test + +[ ] [ "cache" get 2 >>max-age drop ] unit-test + +[ ] [ 1 dup "a" set 2 "cache" get set-at ] unit-test + +[ 1 ] [ "cache" get assoc-size ] unit-test + +[ ] [ "cache" get purge-cache ] unit-test + +[ ] [ 2 3 "cache" get set-at ] unit-test + +[ 2 ] [ "cache" get assoc-size ] unit-test + +[ ] [ "cache" get purge-cache ] unit-test + +[ 1 ] [ "cache" get assoc-size ] unit-test + +[ ] [ 3 dup "b" set 4 "cache" get set-at ] unit-test + +[ 2 ] [ "cache" get assoc-size ] unit-test + +[ ] [ "cache" get purge-cache ] unit-test + +[ 1 ] [ "cache" get assoc-size ] unit-test + +[ f ] [ 2 "cache" get key? ] unit-test + +[ 3 ] [ 4 "cache" get at n>> ] unit-test + +[ t ] [ "a" get disposed>> ] unit-test + +[ f ] [ "b" get disposed>> ] unit-test + +[ ] [ "cache" get clear-assoc ] unit-test + +[ t ] [ "b" get disposed>> ] unit-test diff --git a/basis/cache/cache.factor b/basis/cache/cache.factor old mode 100644 new mode 100755 index a226500c63..1247774bee --- a/basis/cache/cache.factor +++ b/basis/cache/cache.factor @@ -25,19 +25,21 @@ M: cache-assoc set-at [ ] 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 ; diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index c31ddca2c1..a520eca53b 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -5,10 +5,10 @@ math.order ; IN: calendar HELP: duration -{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two durations with the " { $link <=> } " word." } ; +{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two durations with the " { $link <=> } " word." } ; HELP: timestamp -{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two durations with the " { $link <=> } " word." } ; +{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two durations with the " { $link <=> } " word." } ; { timestamp duration } related-words @@ -33,7 +33,7 @@ HELP: month-names HELP: month-name { $values { "obj" { $or integer timestamp } } { "string" string } } -{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ; +{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ; HELP: month-abbreviations { $values { "value" array } } @@ -42,7 +42,7 @@ HELP: month-abbreviations HELP: month-abbreviation { $values { "n" integer } { "string" string } } -{ $description "Looks up the abbreviated month name and returns it as a string. January has an index of 1 instead of zero." } ; +{ $description "Looks up the abbreviated month name and returns it as a string. January has an index of 1 instead of zero." } ; HELP: day-names @@ -55,7 +55,7 @@ HELP: day-name HELP: day-abbreviations2 { $values { "value" array } } -{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ; +{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ; HELP: day-abbreviation2 { $values { "n" integer } { "string" string } } @@ -63,7 +63,7 @@ HELP: day-abbreviation2 HELP: day-abbreviations3 { $values { "value" array } } -{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ; +{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ; HELP: day-abbreviation3 { $values { "n" integer } { "string" string } } @@ -101,7 +101,7 @@ HELP: seconds-per-year HELP: julian-day-number { $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } } -{ $description "Calculates the Julian day number from a year, month, and day. The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." } +{ $description "Calculates the Julian day number from a year, month, and day. The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." } { $warning "Not valid before year -4800 BCE." } ; HELP: julian-day-number>date @@ -340,7 +340,7 @@ HELP: >gmt HELP: time* { $values { "obj1" object } { "obj2" object } { "obj3" object } } -{ $description "Multiplies each time slot of a timestamp or duration by a number and make a new duration from the result. Used in the implementation of " { $link before } "." } ; +{ $description "Multiplies each time slot of a timestamp or duration by a number and make a new duration from the result. Used in the implementation of " { $link before } "." } ; { time+ time- time* } related-words HELP: before @@ -355,7 +355,7 @@ HELP: before HELP: { $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" } } @@ -419,7 +419,7 @@ HELP: zeller-congruence { $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 ;" diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index 9f7d165925..f5b3afe9ee 100644 --- a/basis/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax arrays calendar -kernel math unix unix.time unix.types namespaces system +USING: alien alien.c-types alien.data alien.syntax arrays +calendar kernel math unix unix.time unix.types namespaces system accessors classes.struct ; IN: calendar.unix @@ -21,7 +21,7 @@ IN: calendar.unix timespec>duration since-1970 ; : get-time ( -- alien ) - f time localtime ; + f time time_t localtime ; : timezone-name ( -- string ) get-time zone>> ; diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index f83d0354f6..b2af09b7d5 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2006, 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel io io.binary io.files io.streams.byte-array math -math.functions math.parser namespaces splitting grouping strings -sequences byte-arrays locals sequences.private macros fry -io.encodings.binary math.bitwise checksums accessors -checksums.common checksums.stream combinators combinators.smart -specialized-arrays literals hints ; +USING: alien.c-types alien.data kernel io io.binary io.files +io.streams.byte-array math math.functions math.parser namespaces +splitting grouping strings sequences byte-arrays locals +sequences.private macros fry io.encodings.binary math.bitwise +checksums accessors checksums.common checksums.stream +combinators combinators.smart specialized-arrays literals hints ; SPECIALIZED-ARRAY: uint IN: checksums.md5 diff --git a/basis/colors/hex/authors.txt b/basis/colors/hex/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/colors/hex/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/colors/hex/hex-docs.factor b/basis/colors/hex/hex-docs.factor new file mode 100644 index 0000000000..ca49692200 --- /dev/null +++ b/basis/colors/hex/hex-docs.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2010 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: colors help.markup help.syntax strings ; + +IN: colors.hex + +HELP: hex>rgba +{ $values { "hex" string } { "rgba" color } } +{ $description "Converts a hexadecimal string value into a " { $link color } "." } +; + +HELP: rgba>hex +{ $values { "rgba" color } { "hex" string } } +{ $description "Converts a " { $link color } " into a hexadecimal string value." } +; + +HELP: HEXCOLOR: +{ $syntax "HEXCOLOR: value" } +{ $description "Parses as a " { $link color } " object with the given hexadecimal value." } +{ $examples + { $code + "USING: colors.hex io.styles ;" + "\"Hello!\" { { foreground HEXCOLOR: 336699 } } format nl" + } +} ; + +ARTICLE: "colors.hex" "HEX colors" +"The " { $vocab-link "colors.hex" } " vocabulary implements colors specified " +"by their hexidecimal value." +{ $subsections + hex>rgba + rgba>hex + POSTPONE: HEXCOLOR: +} +{ $see-also "colors" } ; + +ABOUT: "colors.hex" diff --git a/basis/colors/hex/hex-tests.factor b/basis/colors/hex/hex-tests.factor new file mode 100644 index 0000000000..0ab1fd5216 --- /dev/null +++ b/basis/colors/hex/hex-tests.factor @@ -0,0 +1,12 @@ +! Copyright (C) 2010 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: colors colors.hex tools.test ; + +IN: colors.hex.test + +[ HEXCOLOR: 000000 ] [ 0.0 0.0 0.0 1.0 ] unit-test +[ HEXCOLOR: FFFFFF ] [ 1.0 1.0 1.0 1.0 ] unit-test +[ HEXCOLOR: abcdef ] [ "abcdef" hex>rgba ] unit-test +[ HEXCOLOR: abcdef ] [ "ABCDEF" hex>rgba ] unit-test +[ "ABCDEF" ] [ HEXCOLOR: abcdef rgba>hex ] unit-test diff --git a/basis/colors/hex/hex.factor b/basis/colors/hex/hex.factor new file mode 100644 index 0000000000..a4b1aef7e5 --- /dev/null +++ b/basis/colors/hex/hex.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2010 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: accessors colors formatting grouping kernel lexer math +math.parser sequences ; + +IN: colors.hex + +: hex>rgba ( hex -- rgba ) + 2 group [ hex> 255 /f ] map first3 1.0 ; + +: rgba>hex ( rgba -- hex ) + [ red>> ] [ green>> ] [ blue>> ] tri + [ 255 * >integer ] tri@ "%02X%02X%02X" sprintf ; + +SYNTAX: HEXCOLOR: scan hex>rgba suffix! ; diff --git a/basis/colors/hex/summary.txt b/basis/colors/hex/summary.txt new file mode 100644 index 0000000000..37b6abaac4 --- /dev/null +++ b/basis/colors/hex/summary.txt @@ -0,0 +1 @@ +Hexadecimal colors diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 4c4e8de94d..f5555716f3 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces sequences tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io combinators vectors grouping -make alien.c-types combinators.short-circuit math.order +make alien.c-types alien.data combinators.short-circuit math.order math.libm math.parser math.functions alien.syntax memory stack-checker ; FROM: math => float ; @@ -275,7 +275,8 @@ M: cucumber equal? "The cucumber has no equal" throw ; [ 4294967295 B{ 255 255 255 255 } -1 ] [ - -1 -1 + -1 int + -1 int [ [ 0 alien-unsigned-4 swap ] [ 0 alien-signed-2 ] bi ] compile-call ] unit-test diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 53017ff452..00345081ca 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -6,6 +6,8 @@ sbufs strings.private slots.private alien math.order alien.accessors alien.c-types alien.data alien.syntax alien.strings namespaces libc io.encodings.ascii classes compiler.test ; FROM: math => float ; +FROM: alien.c-types => short ; +QUALIFIED-WITH: alien.c-types c IN: compiler.tests.intrinsics ! Make sure that intrinsic ops compile to correct code. @@ -429,46 +431,46 @@ ERROR: bug-in-fixnum* x y a b ; [ ] [ "hello world" ascii malloc-string "s" set ] unit-test "s" get [ - [ "hello world" ] [ "s" get [ { byte-array } declare *void* ] compile-call ascii alien>string ] unit-test - [ "hello world" ] [ "s" get [ { c-ptr } declare *void* ] compile-call ascii alien>string ] unit-test + [ "hello world" ] [ "s" get void* [ { byte-array } declare void* deref ] compile-call ascii alien>string ] unit-test + [ "hello world" ] [ "s" get void* [ { c-ptr } declare void* deref ] compile-call ascii alien>string ] unit-test [ ] [ "s" get free ] unit-test ] when -[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare ] compile-call *void* ] unit-test -[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare ] compile-call *void* ] unit-test -[ f ] [ f [ { POSTPONE: f } declare ] compile-call *void* ] unit-test +[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare void* ] compile-call void* deref ] unit-test +[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare void* ] compile-call void* deref ] unit-test +[ f ] [ f [ { POSTPONE: f } declare void* ] 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 [ { byte-array } declare *char ] compile-call ] unit-test -[ 156 ] [ -100 [ { byte-array } declare *uchar ] compile-call ] unit-test +[ -100 ] [ -100 char [ { byte-array } declare char deref ] compile-call ] unit-test +[ 156 ] [ -100 uchar [ { byte-array } declare uchar deref ] compile-call ] unit-test -[ -100 ] [ -100 \ def>> [ { fixnum } declare ] prepend compile-call *char ] unit-test -[ 156 ] [ -100 \ def>> [ { fixnum } declare ] prepend compile-call *uchar ] unit-test +[ -100 ] [ -100 [ char ] [ { fixnum } declare ] prepend compile-call char deref ] unit-test +[ 156 ] [ -100 [ uchar ] [ { fixnum } declare ] prepend compile-call uchar deref ] unit-test -[ -1000 ] [ -1000 [ { byte-array } declare *short ] compile-call ] unit-test -[ 64536 ] [ -1000 [ { byte-array } declare *ushort ] compile-call ] unit-test +[ -1000 ] [ -1000 short [ { byte-array } declare short deref ] compile-call ] unit-test +[ 64536 ] [ -1000 ushort [ { byte-array } declare ushort deref ] compile-call ] unit-test -[ -1000 ] [ -1000 \ def>> [ { fixnum } declare ] prepend compile-call *short ] unit-test -[ 64536 ] [ -1000 \ def>> [ { fixnum } declare ] prepend compile-call *ushort ] unit-test +[ -1000 ] [ -1000 [ short ] [ { fixnum } declare ] prepend compile-call short deref ] unit-test +[ 64536 ] [ -1000 [ ushort ] [ { fixnum } declare ] prepend compile-call ushort deref ] unit-test -[ -100000 ] [ -100000 [ { byte-array } declare *int ] compile-call ] unit-test -[ 4294867296 ] [ -100000 [ { byte-array } declare *uint ] compile-call ] unit-test +[ -100000 ] [ -100000 int [ { byte-array } declare int deref ] compile-call ] unit-test +[ 4294867296 ] [ -100000 uint [ { byte-array } declare uint deref ] compile-call ] unit-test -[ -100000 ] [ -100000 \ def>> [ { fixnum } declare ] prepend compile-call *int ] unit-test -[ 4294867296 ] [ -100000 \ def>> [ { fixnum } declare ] prepend compile-call *uint ] unit-test +[ -100000 ] [ -100000 [ int ] [ { fixnum } declare ] prepend compile-call int deref ] unit-test +[ 4294867296 ] [ -100000 [ uint ] [ { fixnum } declare ] prepend compile-call uint deref ] unit-test -[ t ] [ pi pi *double = ] unit-test +[ t ] [ pi pi double double deref = ] unit-test -[ t ] [ pi [ { byte-array } declare *double ] compile-call pi = ] unit-test +[ t ] [ pi double [ { byte-array } declare double deref ] compile-call pi = ] unit-test ! Silly -[ t ] [ pi 4 [ [ { float byte-array } declare 0 set-alien-float ] compile-call ] keep *float pi - -0.001 0.001 between? ] unit-test -[ t ] [ pi [ { byte-array } declare *float ] compile-call pi - -0.001 0.001 between? ] unit-test +[ t ] [ pi 4 [ [ { 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 [ { byte-array } declare c:float deref ] compile-call pi - -0.001 0.001 between? ] unit-test -[ t ] [ pi 8 [ [ { float byte-array } declare 0 set-alien-double ] compile-call ] keep *double pi = ] unit-test +[ t ] [ pi 8 [ [ { 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 } [ @@ -532,12 +534,14 @@ ERROR: bug-in-fixnum* x y a b ; ] compile-call ] unit-test +! These tests must fail because we're not allowed to store +! a pointer to a byte array inside of an alien object [ - B{ 0 0 0 0 } [ { byte-array } declare ] compile-call + B{ 0 0 0 0 } [ { byte-array } declare void* ] compile-call ] must-fail [ - B{ 0 0 0 0 } [ { c-ptr } declare ] compile-call + B{ 0 0 0 0 } [ { c-ptr } declare void* ] compile-call ] must-fail [ diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 88e7895c89..dfce70ae38 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -1,11 +1,11 @@ USING: tools.test kernel.private kernel arrays sequences math.private math generic words quotations alien alien.c-types -strings sbufs sequences.private slots.private combinators -definitions system layouts vectors math.partial-dispatch -math.order math.functions accessors hashtables classes assocs -io.encodings.utf8 io.encodings.ascii io.encodings fry slots -sorting.private combinators.short-circuit grouping prettyprint -generalizations +alien.data strings sbufs sequences.private slots.private +combinators definitions system layouts vectors +math.partial-dispatch math.order math.functions accessors +hashtables classes assocs io.encodings.utf8 io.encodings.ascii +io.encodings fry slots sorting.private combinators.short-circuit +grouping prettyprint generalizations compiler.tree compiler.tree.combinators compiler.tree.cleanup @@ -17,6 +17,7 @@ compiler.tree.propagation.info compiler.tree.checker compiler.tree.debugger ; FROM: math => float ; +QUALIFIED-WITH: alien.c-types c IN: compiler.tree.cleanup.tests [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test @@ -244,22 +245,22 @@ cell-bits 32 = [ ] when [ t ] [ - [ B{ 1 0 } *short 0 number= ] + [ B{ 1 0 } c:short deref 0 number= ] \ number= inlined? ] unit-test [ t ] [ - [ B{ 1 0 } *short 0 { number number } declare number= ] + [ B{ 1 0 } c:short deref 0 { number number } declare number= ] \ number= inlined? ] unit-test [ t ] [ - [ B{ 1 0 } *short 0 = ] + [ B{ 1 0 } c:short deref 0 = ] \ number= inlined? ] unit-test [ t ] [ - [ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ] + [ B{ 1 0 } c:short deref dup number? [ 0 number= ] [ drop f ] if ] \ number= inlined? ] unit-test @@ -520,8 +521,6 @@ cell-bits 32 = [ ] cleaned-up-tree nodes>quot ] unit-test -USING: alien alien.c-types ; - [ t ] [ [ int { } cdecl [ 2 2 + ] alien-callback ] { + } inlined? diff --git a/basis/compression/zlib/zlib.factor b/basis/compression/zlib/zlib.factor index c662eec049..02a40defcf 100644 --- a/basis/compression/zlib/zlib.factor +++ b/basis/compression/zlib/zlib.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax byte-arrays combinators -kernel math math.functions sequences system accessors -libc ; +USING: alien alien.c-types alien.data alien.syntax byte-arrays +combinators kernel math math.functions sequences system +accessors libc ; QUALIFIED: compression.zlib.ffi IN: compression.zlib @@ -36,15 +36,15 @@ ERROR: zlib-failed n string ; : compress ( byte-array -- compressed ) [ - [ compressed-size dup length ] keep [ + [ compressed-size dup length ulong ] keep [ dup length compression.zlib.ffi:compress zlib-error - ] 3keep drop *ulong head + ] 3keep drop ulong deref head ] keep length ; : uncompress ( compressed -- byte-array ) [ - length>> [ ] keep 2dup + length>> [ ] keep ulong 2dup ] [ data>> dup length compression.zlib.ffi:uncompress zlib-error - ] bi *ulong head ; + ] bi ulong deref head ; diff --git a/basis/concurrency/combinators/combinators-docs.factor b/basis/concurrency/combinators/combinators-docs.factor index 57470209b6..c3389a1aec 100644 --- a/basis/concurrency/combinators/combinators-docs.factor +++ b/basis/concurrency/combinators/combinators-docs.factor @@ -43,6 +43,6 @@ $nl parallel-spread parallel-napply } -"The " { $vocab-link "concurrency.semaphores" } " vocabulary can be used in conjuction with the above combinators to limit the maximum number of concurrent operations." ; +"The " { $vocab-link "concurrency.semaphores" } " vocabulary can be used in conjunction with the above combinators to limit the maximum number of concurrent operations." ; ABOUT: "concurrency.combinators" diff --git a/basis/concurrency/count-downs/count-downs.factor b/basis/concurrency/count-downs/count-downs.factor old mode 100644 new mode 100755 index d88fcef609..51dfc9e706 --- a/basis/concurrency/count-downs/count-downs.factor +++ b/basis/concurrency/count-downs/count-downs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: dlists kernel math concurrency.promises -concurrency.mailboxes debugger accessors fry ; +concurrency.mailboxes accessors fry ; IN: concurrency.count-downs ! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html diff --git a/basis/concurrency/distributed/distributed-tests.factor b/basis/concurrency/distributed/distributed-tests.factor index ebe5bc5da2..c0ae33150e 100644 --- a/basis/concurrency/distributed/distributed-tests.factor +++ b/basis/concurrency/distributed/distributed-tests.factor @@ -16,7 +16,7 @@ CONSTANT: test-ip "127.0.0.1" : test-node-client ( -- addrspec ) { { [ os unix? ] [ "distributed-concurrency-test" temp-file ] } - { [ os windows? ] [ test-ip insecure-port ] } + { [ os windows? ] [ insecure-addr ] } } cond ; diff --git a/basis/concurrency/locks/locks-docs.factor b/basis/concurrency/locks/locks-docs.factor index f600b01056..4a331e8f19 100644 --- a/basis/concurrency/locks/locks-docs.factor +++ b/basis/concurrency/locks/locks-docs.factor @@ -60,7 +60,7 @@ ARTICLE: "concurrency.locks.rw" "Read-write locks" $nl "While this can be achieved with a simple " { $link "concurrency.locks.mutex" } ", performance will suffer, since in fact multiple threads can view the structure at the same time; serialization must only be enforced for writes." $nl -"Read/write locks allow any number of threads to hold the read lock simulateneously, however attempting to acquire a write lock blocks until all other threads release read locks and write locks." +"Read/write locks allow any number of threads to hold the read lock simultaneously, however attempting to acquire a write lock blocks until all other threads release read locks and write locks." $nl "Read/write locks are reentrant. A thread holding a write lock may acquire a read lock or a write lock without blocking. However a thread holding a read lock may not acquire a write lock recursively since that could break invariants assumed by the code executing with the read lock held." { $subsections diff --git a/basis/concurrency/mailboxes/debugger/authors.txt b/basis/concurrency/mailboxes/debugger/authors.txt new file mode 100755 index 0000000000..56f4654064 --- /dev/null +++ b/basis/concurrency/mailboxes/debugger/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/concurrency/mailboxes/debugger/debugger.factor b/basis/concurrency/mailboxes/debugger/debugger.factor new file mode 100755 index 0000000000..c222ab0a16 --- /dev/null +++ b/basis/concurrency/mailboxes/debugger/debugger.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: debugger accessors debugger.threads kernel +concurrency.mailboxes ; +IN: concurrency.mailboxes.debugger + +M: linked-error error. + [ thread>> error-in-thread. ] [ error>> error. ] bi ; diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor old mode 100644 new mode 100755 index 163873575c..df73c36183 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: dlists deques threads sequences continuations namespaces math quotations words kernel arrays assocs init system -concurrency.conditions accessors debugger debugger.threads -locals fry ; +concurrency.conditions accessors locals fry vocabs.loader ; IN: concurrency.mailboxes TUPLE: mailbox { threads dlist } { data dlist } ; @@ -77,9 +76,6 @@ M: mailbox mailbox-get-timeout block-if-empty data>> pop-back ; TUPLE: linked-error error thread ; -M: linked-error error. - [ thread>> error-in-thread. ] [ error>> error. ] bi ; - C: linked-error : ?linked ( message -- message ) @@ -95,3 +91,5 @@ M: linked-thread error-in-thread : spawn-linked-to ( quot name mailbox -- thread ) [ (spawn) ] keep ; + +{ "concurrency.mailboxes" "debugger" } "concurrency.mailboxes.debugger" require-when diff --git a/basis/concurrency/messaging/messaging-docs.factor b/basis/concurrency/messaging/messaging-docs.factor index 85870db4df..b2c0d656f4 100644 --- a/basis/concurrency/messaging/messaging-docs.factor +++ b/basis/concurrency/messaging/messaging-docs.factor @@ -1,35 +1,35 @@ ! 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" @@ -65,15 +65,15 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends" } ; 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" diff --git a/basis/core-foundation/numbers/numbers.factor b/basis/core-foundation/numbers/numbers.factor index ae061cb4eb..81440e20f6 100644 --- a/basis/core-foundation/numbers/numbers.factor +++ b/basis/core-foundation/numbers/numbers.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.syntax kernel math core-foundation ; +USING: alien.c-types alien.data alien.syntax kernel math +core-foundation ; FROM: math => float ; IN: core-foundation.numbers @@ -30,14 +31,14 @@ FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType th GENERIC: ( number -- alien ) M: integer - [ f kCFNumberLongLongType ] dip CFNumberCreate ; + [ f kCFNumberLongLongType ] dip longlong CFNumberCreate ; M: float - [ f kCFNumberDoubleType ] dip CFNumberCreate ; + [ f kCFNumberDoubleType ] dip double CFNumberCreate ; M: t - drop f kCFNumberIntType 1 CFNumberCreate ; + drop f kCFNumberIntType 1 int CFNumberCreate ; M: f - drop f kCFNumberIntType 0 CFNumberCreate ; + drop f kCFNumberIntType 0 int CFNumberCreate ; diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index d921789cb0..8463bf145f 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/basis/core-graphics/core-graphics.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.destructors alien.syntax accessors -destructors fry kernel math math.bitwise sequences libc colors -images images.memory core-graphics.types core-foundation.utilities -opengl.gl literals ; +USING: alien alien.c-types alien.data alien.destructors +alien.syntax accessors destructors fry kernel math math.bitwise +sequences libc colors images images.memory core-graphics.types +core-foundation.utilities opengl.gl literals ; IN: core-graphics TYPEDEF: int CGImageAlphaInfo diff --git a/basis/cpu/x86/sse/sse.factor b/basis/cpu/x86/sse/sse.factor index afcc877953..0b71681d0d 100644 --- a/basis/cpu/x86/sse/sse.factor +++ b/basis/cpu/x86/sse/sse.factor @@ -1,15 +1,16 @@ ! Copyright (C) 2009, 2010 Joe Groff, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types arrays assocs combinators fry kernel locals +USING: alien.data arrays assocs combinators fry kernel locals macros math math.vectors namespaces quotations sequences system compiler.cfg.comparisons compiler.cfg.intrinsics compiler.codegen.fixup cpu.architecture cpu.x86 cpu.x86.assembler cpu.x86.assembler.operands cpu.x86.features ; +QUALIFIED-WITH: alien.c-types c IN: cpu.x86.sse ! Scalar floating point with SSE2 -M: x86 %load-float float-rep %load-vector ; -M: x86 %load-double double-rep %load-vector ; +M: x86 %load-float c:float float-rep %load-vector ; +M: x86 %load-double c:double double-rep %load-vector ; M: float-rep copy-register* drop MOVAPS ; M: double-rep copy-register* drop MOVAPS ; diff --git a/basis/cpu/x86/x87/x87.factor b/basis/cpu/x86/x87/x87.factor index 445b913bc9..9ba707709b 100644 --- a/basis/cpu/x86/x87/x87.factor +++ b/basis/cpu/x86/x87/x87.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types combinators kernel locals system namespaces -compiler.codegen.fixup compiler.constants +USING: alien.c-types alien.data combinators kernel locals system +namespaces compiler.codegen.fixup compiler.constants compiler.cfg.comparisons compiler.cfg.intrinsics cpu.architecture cpu.x86 cpu.x86.assembler cpu.x86.assembler.operands ; @@ -38,12 +38,12 @@ M: double-rep copy-memory* copy-memory-x87 ; M: x86 %load-float 0 [] FLDS - rc-absolute rel-binary-literal + float rc-absolute rel-binary-literal shuffle-down FSTP ; M: x86 %load-double 0 [] FLDL - rc-absolute rel-binary-literal + double rc-absolute rel-binary-literal shuffle-down FSTP ; :: binary-op ( dst src1 src2 quot -- ) diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index 66c9f32f7f..cf358fa4b2 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -271,24 +271,21 @@ ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial" { $subsections sql-query } "Here's an example usage where we'll make a book table, insert some objects, and query them." $nl "First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details." -{ $code """ -USING: db.sqlite db io.files io.files.temp ; +{ $code """USING: db.sqlite db io.files io.files.temp ; : with-book-db ( quot -- ) - "book.db" temp-file swap with-db ; inline" } + "book.db" temp-file swap with-db ; inline""" } "Now let's create the table manually:" -{ $code " "create table books +{ $code """"create table books (id integer primary key, title text, author text, date_published timestamp, edition integer, cover_price double, condition text)" [ sql-command ] with-book-db""" } "Time to insert some books:" -{ $code """ -"insert into books +{ $code """"insert into books (title, author, date_published, edition, cover_price, condition) values('Factor for Sheeple', 'Mister Stacky Pants', date('now'), 1, 13.37, 'mint')" [ sql-command ] with-book-db""" } "Now let's select the book:" -{ $code """ -"select id, title, cover_price from books;" [ sql-query ] with-book-db""" } +{ $code """"select id, title, cover_price from books;" [ sql-query ] with-book-db""" } "Notice that the result of this query is a Factor array containing the database rows as arrays of strings. We would have to convert the " { $snippet "cover_price" } " from a string to a number in order to use it in a calculation." $nl "In conclusion, this method of accessing a database is supported, but it is fairly low-level and generally specific to a single database. The " { $vocab-link "db.tuples" } " vocabulary is a good alternative to writing SQL by hand." ; @@ -298,10 +295,9 @@ ARTICLE: "db-custom-database-combinators" "Custom database combinators" "Make a " { $snippet "with-" } " combinator to open and close a database so that resources are not leaked." $nl "SQLite example combinator:" -{ $code """ -USING: db.sqlite db io.files io.files.temp ; +{ $code """USING: db.sqlite db io.files io.files.temp ; : with-sqlite-db ( quot -- ) - "my-database.db" temp-file swap with-db ; inline""" } + "my-database.db" temp-file swap with-db ; inline""" } "PostgreSQL example combinator:" { $code """USING: db.postgresql db ; diff --git a/basis/db/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor index 3f77f9abaf..36e6b4bf2c 100644 --- a/basis/db/tuples/tuples-docs.factor +++ b/basis/db/tuples/tuples-docs.factor @@ -70,14 +70,13 @@ HELP: define-persistent { "the name of a database column that maps to the slot" } { "a database type (see " { $link "db.types" } ")" } } "Throws an error if the slot name (column one from each row) is not a slot in the tuple or its superclases." } { $examples - { $unchecked-example "USING: db.tuples db.types ;" + { $code "USING: db.tuples db.types ;" "TUPLE: boat id year name ;" "boat \"BOAT\" {" " { \"id\" \"ID\" +db-assigned-id+ }" " { \"year\" \"YEAR\" INTEGER }" " { \"name\" \"NAME\" TEXT }" "} define-persistent" - "" } } ; @@ -233,8 +232,7 @@ T{ book { date-published T{ timestamp { year 2009 } { month 3 } { day 3 } } } { edition 1 } { cover-price 13.37 } -} book set -""" } +} book set""" } "Now we've created a book. Let's save it to the database." { $code """USING: db db.sqlite fry io.files.temp ; : with-book-tutorial ( quot -- ) @@ -243,8 +241,7 @@ T{ book [ book recreate-table book get insert-tuple -] with-book-tutorial -""" } +] with-book-tutorial""" } "Is it really there?" { $code """[ T{ book { title "Factor for Sheeple" } } select-tuples . diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor index 4bcd9c5b78..50461226b5 100644 --- a/basis/debugger/debugger-docs.factor +++ b/basis/debugger/debugger-docs.factor @@ -117,7 +117,7 @@ HELP: signal-error. { "8 - Arithmetic exception. Most likely a divide by zero in " { $link /i } "." } { "10, 11 - Memory protection fault. This error suggests invalid values are being passed to C functions by an " { $link alien-invoke } ". Factor also uses memory protection to trap stack underflows and overflows, but usually these are reported as their own errors. Sometimes they'll show up as a generic signal 11, though." } } - "The Windows equivalent of a signal 11 is a SEH fault. When one occurs, the runtime throws a singal error, even though it does not correspond to a Unix signal." + "The Windows equivalent of a signal 11 is a SEH fault. When one occurs, the runtime throws a signal error, even though it does not correspond to a Unix signal." } ; HELP: array-size-error. diff --git a/basis/endian/endian.factor b/basis/endian/endian.factor index 4928458543..4f59f71f3a 100644 --- a/basis/endian/endian.factor +++ b/basis/endian/endian.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types namespaces io.binary fry +USING: alien.c-types alien.data namespaces io.binary fry kernel math grouping sequences math.bitwise ; IN: endian SINGLETONS: big-endian little-endian ; : compute-native-endianness ( -- class ) - 1 *char 0 = big-endian little-endian ? ; + 1 int char deref 0 = big-endian little-endian ? ; SYMBOL: native-endianness native-endianness [ compute-native-endianness ] initialize diff --git a/basis/environment/unix/unix.factor b/basis/environment/unix/unix.factor index ec41e919d8..abfa15b5ed 100644 --- a/basis/environment/unix/unix.factor +++ b/basis/environment/unix/unix.factor @@ -17,7 +17,7 @@ M: unix set-os-env ( value key -- ) swap 1 setenv io-error ; M: unix unset-os-env ( key -- ) unsetenv io-error ; M: unix (os-envs) ( -- seq ) - environ *void* utf8 alien>strings ; + environ void* deref utf8 alien>strings ; : set-void* ( value alien -- ) 0 set-alien-cell ; diff --git a/basis/eval/eval-docs.factor b/basis/eval/eval-docs.factor index f3ee35d91c..e7e3c02303 100644 --- a/basis/eval/eval-docs.factor +++ b/basis/eval/eval-docs.factor @@ -50,7 +50,7 @@ $nl { $code """USING: eval listener vocabs.parser ; [ - "cad-objects" use-vocab + "cad.objects" use-vocab (( -- seq )) (eval) ] with-interactive-vocabs""" } diff --git a/basis/ftp/client/client.factor b/basis/ftp/client/client.factor index 9d51ba259e..c94d5a273a 100644 --- a/basis/ftp/client/client.factor +++ b/basis/ftp/client/client.factor @@ -61,7 +61,7 @@ ERROR: ftp-error got expected ; strings>> first "|" split 2 tail* first string>number ; : open-passive-client ( url protocol -- stream ) - [ host>> ftp-epsv parse-epsv ] dip drop ; + [ url-addr ftp-epsv parse-epsv with-port ] dip drop ; : list ( url -- ftp-response ) utf8 open-passive-client @@ -84,7 +84,7 @@ ERROR: ftp-error got expected ; ftp-set-binary 200 ftp-assert ; : ftp-connect ( url -- stream ) - [ host>> ] [ port>> ] bi utf8 drop ; + url-addr utf8 drop ; : with-ftp-client ( url quot -- ) [ [ ftp-connect ] keep ] dip diff --git a/basis/ftp/server/server-tests.factor b/basis/ftp/server/server-tests.factor index fa6afa30cc..49ffc25e0a 100644 --- a/basis/ftp/server/server-tests.factor +++ b/basis/ftp/server/server-tests.factor @@ -17,11 +17,8 @@ CONSTANT: test-file-contents "Files are so boring anymore." '[ current-temporary-directory get 0 [ - insecure-port - - swap >>port + "ftp://localhost" >url insecure-addr set-url-addr "ftp" >>protocol - "localhost" >>host create-test-file >>path @ ] with-threaded-server diff --git a/basis/furnace/actions/actions-docs.factor b/basis/furnace/actions/actions-docs.factor index ae9dd9b65c..76f2ec036a 100644 --- a/basis/furnace/actions/actions-docs.factor +++ b/basis/furnace/actions/actions-docs.factor @@ -9,7 +9,7 @@ HELP: HELP: { $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" } "." } ; diff --git a/basis/furnace/auth/auth.factor b/basis/furnace/auth/auth.factor index 2acb09919d..7cd2a890ee 100644 --- a/basis/furnace/auth/auth.factor +++ b/basis/furnace/auth/auth.factor @@ -1,9 +1,9 @@ -! Copyright (c) 2008 Slava Pestov +! Copyright (c) 2008, 2010 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs namespaces kernel sequences sets -destructors combinators fry logging -io.encodings.utf8 io.encodings.string io.binary random -checksums checksums.sha urls +destructors combinators fry logging io.encodings.utf8 +io.encodings.string io.binary io.sockets.secure random checksums +checksums.sha urls html.forms http.server http.server.filters @@ -79,7 +79,7 @@ GENERIC: logged-in-username ( realm -- username ) swap >>default users-in-db >>users sha-256 >>checksum - t >>secure ; inline + ssl-supported? >>secure ; inline : users ( -- provider ) realm get users>> ; diff --git a/basis/furnace/recaptcha/recaptcha.factor b/basis/furnace/recaptcha/recaptcha.factor index 38ba8e2b1f..7889ffc626 100644 --- a/basis/furnace/recaptcha/recaptcha.factor +++ b/basis/furnace/recaptcha/recaptcha.factor @@ -21,7 +21,7 @@ M: recaptcha call-responder* [ f DirectInput8Create ole32-error ] keep *void* + f void* [ 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 - [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ; + +dinput+ get-global swap f void* + [ f IDirectInput8W::CreateDevice ole32-error ] keep void* deref ; : set-coop-level ( device -- ) +device-change-window+ get-global DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor @@ -303,8 +303,8 @@ CONSTANT: pov-values } 2cleave ; : read-device-buffer ( device buffer count -- buffer count' ) - [ DIDEVICEOBJECTDATA heap-size ] 2dip - [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ; + [ DIDEVICEOBJECTDATA heap-size ] 2dip uint + [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep uint deref ; : (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state ) [ dwData>> 32 >signed ] [ dwOfs>> ] bi { diff --git a/basis/grouping/grouping-docs.factor b/basis/grouping/grouping-docs.factor index c91eb231ab..44da43a76b 100644 --- a/basis/grouping/grouping-docs.factor +++ b/basis/grouping/grouping-docs.factor @@ -26,7 +26,7 @@ ARTICLE: "grouping" "Groups and clumps" "{ 1 2 3 4 } dup" "2 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 } }" diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index da5f2911f8..9c8464cae1 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -45,7 +45,7 @@ $nl $nl "Some generic words have " { $strong "Description" } " headings, and others have " { $strong "Contract" } " headings. A distinction is made between words which are not intended to be extended with user-defined methods, and those that are." { $heading "Vocabulary naming conventions" } -"A vocabulary name ending in " { $snippet ".private" } " contains words which are either implementation details, unsafe, or both. For example, the " { $snippet "sequence.private" } " vocabulary contains words which access sequence elements without bounds checking (" { $link "sequences-unsafe" } "). You should avoid using private words from the Factor library unless absolutely necessary. Similarly, your own code can place words in private vocabularies using " { $link POSTPONE: " + "! Copyright (C) 2011 " "! See http://factorcode.org/license.txt for BSD license." "USING: ;" "IN: palindrome" @@ -127,7 +127,7 @@ $nl "Finally, pass the string and the quotation to the " { $link filter } " word:" { $code "filter" } "Now the stack should contain the following string:" -{ "\"AmanaplanacanalPanama\"" } +{ "\"AmanaplanacanalPanama\"" } ". " "This is almost what we want; we just need to convert the string to lower case now. This can be done by calling " { $link >lower } "; the " { $snippet ">" } " prefix is a naming convention for conversion operations, and should be read as “to”:" { $code ">lower" } "Finally, let's print the top of the stack and discard it:" diff --git a/basis/hints/hints-docs.factor b/basis/hints/hints-docs.factor index 46bdc698b7..b5e7b37725 100644 --- a/basis/hints/hints-docs.factor +++ b/basis/hints/hints-docs.factor @@ -24,20 +24,25 @@ HELP: HINTS: { $description "Defines specialization hints for a word or a method." $nl "Each sequence in the list will cause a specialized version of the word to be compiled. Classes are tested for using their predicate, and literals are tested using " { $link eq? } "." } -{ $examples "The " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:" -{ $code "HINTS: append { string string } { array array } ;" } -"Specializers can also be defined on methods:" -{ $code - "GENERIC: count-occurrences ( elt obj -- n )" - "" - "M: sequence count-occurrences [ = ] with count ;" - "" - "M: assoc count-occurrences" - " swap [ = nip ] curry assoc-filter assoc-size ;" - "" - "HINTS: M\ sequence count-occurrences { object array } ;" - "HINTS: M\ assoc count-occurrences { object hashtable } ;" -} +{ $examples + "The " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:" + { $code + "USING: arrays hints sequences strings ;" + "HINTS: append { string string } { array array } ;" + } + "Specializers can also be defined on methods:" + { $code + "USING: assocs hashtables hints kernel sequences ;" + "GENERIC: count-occurrences ( elt obj -- n )" + "" + "M: sequence count-occurrences [ = ] with count ;" + "" + "M: assoc count-occurrences" + " swap [ = nip ] curry assoc-filter assoc-size ;" + "" + "HINTS: M\\ sequence count-occurrences { object array } ;" + "HINTS: M\\ assoc count-occurrences { object hashtable } ;" + } } ; ABOUT: "hints" diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index dc16cf8b24..abfb3199a2 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -3,9 +3,9 @@ USING: accessors arrays assocs byte-arrays byte-vectors classes combinators definitions effects fry generic generic.single generic.standard hashtables io.binary io.encodings -io.streams.string kernel kernel.private math -math.integers.private math.parser namespaces parser sbufs -sequences splitting splitting.private strings vectors words ; +io.streams.string kernel kernel.private math math.parser +namespaces parser sbufs sequences splitting splitting.private +strings vectors words ; IN: hints GENERIC: specializer-predicate ( spec -- quot ) @@ -130,6 +130,4 @@ M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-pr M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop -\ bignum/f { { bignum bignum } { bignum fixnum } { fixnum bignum } { fixnum fixnum } } "specializer" set-word-prop - \ encode-string { string object object } "specializer" set-word-prop diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index 2aca1c98aa..7b5f6bc619 100644 --- a/basis/html/templates/chloe/chloe-docs.factor +++ b/basis/html/templates/chloe/chloe-docs.factor @@ -84,13 +84,13 @@ ARTICLE: "html.templates.chloe.tags.boilerplate" "Boilerplate Chloe tags" $nl "The tags marked with (*) are only available if the " { $vocab-link "furnace.chloe-tags" } " vocabulary is loaded." { $table - { { $snippet "t:title" } "Sets the title from a child template" } - { { $snippet "t:write-title" } "Renders the child's title from a master template" } - { { $snippet "t:style" } "Adds CSS markup from a child template" } - { { $snippet "t:write-style" } "Renders the children's CSS from a master template" } - { { $snippet "t:atom" } "Adds an Atom feed link from a child template (*)" } - { { $snippet "t:write-atom" } "Renders the children's list of Atom feed links (*)" } - { { $snippet "t:call-next-template" } "Calls the child template from a master template" } + { { $snippet "t:title" } "Sets the title. Intended for use in a master template." } + { { $snippet "t:write-title" } "Renders the child's title. Intended for use in a child template." } + { { $snippet "t:style" } { "Adds CSS markup from the file named by the " { $snippet "t:include" } " attribute. Intended for use in a child template." } } + { { $snippet "t:write-style" } "Renders the children's CSS markup. Intended for use in a master template." } + { { $snippet "t:atom" } { "Adds an Atom feed link. The attributes are the same as the " { $snippet "t:link" } " tag. Intended for use in a child template. (*)" } } + { { $snippet "t:write-atom" } "Renders the children's list of Atom feed links. Intended for use in a master template. (*)" } + { { $snippet "t:call-next-template" } "Calls the next child template from a master template." } } ; ARTICLE: "html.templates.chloe.tags.control" "Control-flow Chloe tags" diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index 04077fc2f7..d5f50de109 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -129,7 +129,7 @@ ARTICLE: "http.client.errors" "HTTP client errors" ARTICLE: "http.client" "HTTP client" "The " { $vocab-link "http.client" } " vocabulary implements an HTTP and HTTPS client on top of " { $link "http" } "." $nl -"For HTTPS support, you must load the " { $vocab-link "urls.secure" } " vocab first. If you don't need HTTPS support, don't load " { $vocab-link "urls.secure" } "; this will reduce the size of images generated by " { $vocab-link "tools.deploy" } "." +"For HTTPS support, you must load the " { $vocab-link "io.sockets.secure" } " vocab first. If you don't need HTTPS support, don't load " { $vocab-link "io.sockets.secure" } "; this will reduce the size of images generated by " { $vocab-link "tools.deploy" } "." $nl "There are two primary usage patterns, data retrieval with GET requests and form submission with POST requests:" { $subsections @@ -139,7 +139,7 @@ $nl } "Submission data for POST and PUT requests:" { $subsections "http.client.post-data" } -"More esoteric use-cases, for example HTTP methods other than the above, are accomodated by constructing an empty request object with " { $link } " 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 } " and filling everything in by hand." { $subsections "http.client.encoding" "http.client.errors" diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index ed146d98de..f161b4276f 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -3,7 +3,7 @@ multiline io.streams.string io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.encodings.string io.encodings.ascii kernel arrays splitting sequences assocs io.sockets db db.sqlite continuations urls hashtables accessors namespaces xml.data -io.encodings.8-bit.latin1 random ; +io.encodings.8-bit.latin1 random combinators.short-circuit ; IN: http.tests [ "text/plain" "UTF-8" ] [ "text/plain" parse-content-type ] unit-test @@ -16,6 +16,8 @@ IN: http.tests [ "localhost" f ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test +[ "::1" 8888 ] [ "::1:8888" parse-host ] unit-test +[ "127.0.0.1" 8888 ] [ "127.0.0.1:8888" parse-host ] unit-test [ "localhost" ] [ T{ url { protocol "http" } { host "localhost" } } unparse-host ] unit-test [ "localhost" ] [ T{ url { protocol "http" } { host "localhost" } { port 80 } } unparse-host ] unit-test @@ -219,12 +221,6 @@ http.server.dispatchers db.tuples ; : test-db ( -- db ) test-db-file ; -[ test-db-file delete-file ] ignore-errors - -test-db [ - init-furnace-tables -] with-db - : test-httpd ( responder -- ) [ main-responder set @@ -232,16 +228,25 @@ test-db [ 0 >>insecure f >>secure start-server - servers>> random addr>> port>> - ] with-scope "port" set ; + threaded-server set + server-addrs random + ] with-scope "addr" set ; -: add-port ( url -- url' ) - >url clone "port" get >>port ; +: add-addr ( url -- url' ) + >url clone "addr" get set-url-addr ; : stop-test-httpd ( -- ) - "http://localhost/quit" add-port http-get nip + "http://localhost/quit" add-addr http-get nip "Goodbye" assert= ; +[ ] [ + [ test-db-file delete-file ] ignore-errors + + test-db [ + init-furnace-tables + ] with-db +] unit-test + [ ] [ add-quit-action @@ -257,14 +262,14 @@ test-db [ [ t ] [ "vocab:http/test/foo.html" ascii file-contents - "http://localhost/nested/foo.html" add-port http-get nip = + "http://localhost/nested/foo.html" add-addr http-get nip = ] unit-test -[ "http://localhost/redirect-loop" add-port http-get nip ] +[ "http://localhost/redirect-loop" add-addr http-get nip ] [ too-many-redirects? ] must-fail-with [ "Goodbye" ] [ - "http://localhost/quit" add-port http-get nip + "http://localhost/quit" add-addr http-get nip ] unit-test ! HTTP client redirect bug @@ -278,7 +283,7 @@ test-db [ ] unit-test [ "Goodbye" ] [ - "http://localhost/redirect" add-port http-get nip + "http://localhost/redirect" add-addr http-get nip ] unit-test @@ -302,15 +307,20 @@ test-db [ test-httpd ] unit-test -: 404? ( response -- ? ) [ download-failed? ] [ response>> code>> 404 = ] bi and ; +: 404? ( response -- ? ) + { + [ download-failed? ] + [ response>> response? ] + [ response>> code>> 404 = ] + } 1&& ; ! This should give a 404 not an infinite redirect loop -[ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with +[ "http://localhost/d/blah" add-addr http-get nip ] [ 404? ] must-fail-with ! This should give a 404 not an infinite redirect loop -[ "http://localhost/blah/" add-port http-get nip ] [ 404? ] must-fail-with +[ "http://localhost/blah/" add-addr http-get nip ] [ 404? ] must-fail-with -[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test +[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test [ ] [ @@ -324,9 +334,9 @@ test-db [ test-httpd ] unit-test -[ "Hi" ] [ "http://localhost/" add-port http-get nip ] unit-test +[ "Hi" ] [ "http://localhost/" add-addr http-get nip ] unit-test -[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test +[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test USING: html.components html.forms xml xml.traversal validators @@ -356,7 +366,7 @@ SYMBOL: a string>xml body>> "input" deep-tag-named "value" attr ; [ "3" ] [ - "http://localhost/" add-port http-get + "http://localhost/" add-addr http-get swap dup cookies>> "cookies" set session-id-key get-cookie value>> "session-id" set test-a ] unit-test @@ -364,10 +374,10 @@ SYMBOL: a [ "4" ] [ [ "4" "a" set - "http://localhost" add-port "__u" set + "http://localhost" add-addr "__u" set "session-id" get session-id-key set ] H{ } make-assoc - "http://localhost/" add-port "cookies" get >>cookies http-request nip test-a + "http://localhost/" add-addr "cookies" get >>cookies http-request nip test-a ] unit-test [ 4 ] [ a get-global ] unit-test @@ -376,15 +386,15 @@ SYMBOL: a [ "xyz" ] [ [ "xyz" "a" set - "http://localhost" add-port "__u" set + "http://localhost" add-addr "__u" set "session-id" get session-id-key set ] H{ } make-assoc - "http://localhost/" add-port "cookies" get >>cookies http-request nip test-a + "http://localhost/" add-addr "cookies" get >>cookies http-request nip test-a ] unit-test [ 4 ] [ a get-global ] unit-test -[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test +[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test ! Test cloning [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test @@ -402,7 +412,7 @@ SYMBOL: a ] unit-test [ t ] [ - "http://localhost/" add-port http-get nip + "http://localhost/" add-addr http-get nip "vocab:http/test/foo.html" ascii file-contents = ] unit-test @@ -424,12 +434,12 @@ SYMBOL: a test-httpd ] unit-test -[ "OK" ] [ "data" "http://localhost/a" add-port http-post nip ] unit-test +[ "OK" ] [ "data" "http://localhost/a" add-addr http-post nip ] unit-test ! Check that download throws errors (reported by Chris Double) [ "resource:temp" [ - "http://localhost/tweet_my_twat" add-port download + "http://localhost/tweet_my_twat" add-addr download ] with-directory ] must-fail @@ -443,6 +453,6 @@ SYMBOL: a test-httpd ] unit-test -[ "OK\n\n" ] [ "http://localhost/" add-port http-get nip ] unit-test +[ "OK\n\n" ] [ "http://localhost/" add-addr http-get nip ] unit-test [ ] [ stop-test-httpd ] unit-test diff --git a/basis/http/server/remapping/remapping.factor b/basis/http/server/remapping/remapping.factor index 6eed900acc..9068b6c7d0 100644 --- a/basis/http/server/remapping/remapping.factor +++ b/basis/http/server/remapping/remapping.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs kernel io.servers ; +USING: accessors namespaces assocs kernel io.servers ; IN: http.server.remapping SYMBOL: port-remapping @@ -9,4 +9,4 @@ SYMBOL: port-remapping [ port-remapping get at ] keep or ; : secure-http-port ( -- n ) - secure-port remap-port ; + secure-addr port>> remap-port ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index 7da9f6fc09..227aab21cd 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -121,16 +121,14 @@ TUPLE: jpeg-color-info : decode-huff-table ( chunk -- ) data>> [ binary ] [ 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 -- ) diff --git a/basis/io/backend/unix/multiplexers/select/select.factor b/basis/io/backend/unix/multiplexers/select/select.factor index 2cf406a941..3c1e5b06f7 100644 --- a/basis/io/backend/unix/multiplexers/select/select.factor +++ b/basis/io/backend/unix/multiplexers/select/select.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel bit-arrays sequences assocs math +USING: alien.data kernel bit-arrays sequences assocs math namespaces accessors math.order locals fry io.ports io.backend.unix io.backend.unix.multiplexers unix unix.ffi unix.time ; diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index fd9fed0472..22f0a339a9 100755 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax generic assocs kernel -kernel.private math io.ports sequences strings sbufs threads -unix unix.ffi vectors io.buffers io.backend io.encodings math.parser -continuations system libc namespaces make io.timeouts -io.encodings.utf8 destructors destructors.private accessors -summary combinators locals unix.time unix.types fry -io.backend.unix.multiplexers ; +USING: alien alien.c-types alien.data alien.syntax generic +assocs kernel kernel.private math io.ports sequences strings +sbufs threads unix unix.ffi vectors io.buffers io.backend +io.encodings math.parser continuations system libc namespaces +make io.timeouts io.encodings.utf8 destructors +destructors.private accessors summary combinators locals +unix.time unix.types fry io.backend.unix.multiplexers ; QUALIFIED: io IN: io.backend.unix @@ -146,7 +146,7 @@ M: stdin dispose* : wait-for-stdin ( stdin -- size ) [ control>> CHAR: X over io:stream-write1 io:stream-flush ] - [ size>> ssize_t heap-size swap io:stream-read *int ] + [ size>> ssize_t heap-size swap io:stream-read int deref ] bi ; :: refill-stdin ( buffer stdin size -- ) @@ -167,11 +167,11 @@ M: stdin refill M: stdin cancel-operation [ size>> ] [ control>> ] bi [ cancel-operation ] bi@ ; -: control-write-fd ( -- fd ) &: control_write *uint ; +: control-write-fd ( -- fd ) &: control_write uint deref ; -: size-read-fd ( -- fd ) &: size_read *uint ; +: size-read-fd ( -- fd ) &: size_read uint deref ; -: data-read-fd ( -- fd ) &: stdin_read *uint ; +: data-read-fd ( -- fd ) &: stdin_read uint deref ; : ( -- stdin ) stdin new-disposable diff --git a/basis/io/directories/directories-docs.factor b/basis/io/directories/directories-docs.factor index 3871f9be41..6370fdb90d 100644 --- a/basis/io/directories/directories-docs.factor +++ b/basis/io/directories/directories-docs.factor @@ -52,7 +52,7 @@ HELP: with-directory-files { $examples "Print all files in your home directory which are larger than a megabyte:" { $code - """USING: io.directoies io.files.info io.pathnames ; + """USING: io.directories io.files.info io.pathnames ; home [ [ dup link-info size>> 20 2^ > diff --git a/basis/io/directories/search/search-docs.factor b/basis/io/directories/search/search-docs.factor index 4f7e0ba212..de61aeaf0b 100644 --- a/basis/io/directories/search/search-docs.factor +++ b/basis/io/directories/search/search-docs.factor @@ -64,7 +64,7 @@ HELP: find-by-extension } { $description "Searches a directory for all files with the given extension. File extension and filenames are converted to lower-case and compared using the " { $link tail? } " word. The file extension should contain the period." } { $examples - { $unchecked-example + { $code "USING: io.directories.search ;" "\"/\" \".mp3\" find-by-extension" } @@ -77,7 +77,7 @@ HELP: find-by-extensions } { $description "Searches a directory for all files in the given list of extensions. File extensions and filenames are converted to lower-case and compared using the " { $link tail? } " word. File extensions should contain the period." } { $examples - { $unchecked-example + { $code "USING: io.directories.search ;" "\"/\" { \".jpg\" \".gif\" \".tiff\" \".png\" \".bmp\" } find-by-extensions" } diff --git a/basis/io/directories/unix/linux/linux.factor b/basis/io/directories/unix/linux/linux.factor index 3d69c5f890..3429d5beb2 100644 --- a/basis/io/directories/unix/linux/linux.factor +++ b/basis/io/directories/unix/linux/linux.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types io.directories.unix kernel system unix -classes.struct unix.ffi ; +USING: alien.c-types alien.data io.directories.unix kernel +system unix classes.struct unix.ffi ; IN: io.directories.unix.linux M: linux find-next-file ( DIR* -- dirent ) dirent - f + f void* [ [ readdir64_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep - *void* [ drop f ] unless ; + void* deref [ drop f ] unless ; diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor index 0cc8aaa0e4..d5dc0ab905 100644 --- a/basis/io/directories/unix/unix.factor +++ b/basis/io/directories/unix/unix.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types alien.strings combinators -continuations destructors fry io io.backend io.backend.unix -io.directories io.encodings.binary io.encodings.utf8 io.files -io.pathnames io.files.types kernel math.bitwise sequences system -unix unix.stat vocabs.loader classes.struct unix.ffi literals ; +USING: accessors alien.c-types alien.data alien.strings +combinators continuations destructors fry io io.backend +io.backend.unix io.directories io.encodings.binary +io.encodings.utf8 io.files io.pathnames io.files.types kernel +math.bitwise sequences system unix unix.stat vocabs.loader +classes.struct unix.ffi literals ; IN: io.directories.unix CONSTANT: touch-mode flags{ O_WRONLY O_APPEND O_CREAT O_EXCL } @@ -37,9 +38,9 @@ HOOK: find-next-file os ( DIR* -- byte-array ) M: unix find-next-file ( DIR* -- byte-array ) dirent - f + f void* [ readdir_r 0 = [ (io-error) ] unless ] 2keep - *void* [ drop f ] unless ; + void* deref [ drop f ] unless ; : dirent-type>file-type ( ch -- type ) { diff --git a/basis/io/files/info/unix/macosx/macosx.factor b/basis/io/files/info/unix/macosx/macosx.factor index ac5f8c23b1..d0d4bb7c05 100644 --- a/basis/io/files/info/unix/macosx/macosx.factor +++ b/basis/io/files/info/unix/macosx/macosx.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types alien.strings combinators -grouping io.encodings.utf8 io.files kernel math sequences system -unix io.files.unix arrays unix.statfs.macosx unix.statvfs.macosx -unix.getfsstat.macosx io.files.info.unix io.files.info -classes.struct specialized-arrays ; +USING: accessors alien.c-types alien.data alien.strings +combinators grouping io.encodings.utf8 io.files kernel math +sequences system unix io.files.unix arrays unix.statfs.macosx +unix.statvfs.macosx unix.getfsstat.macosx io.files.info.unix +io.files.info classes.struct specialized-arrays ; SPECIALIZED-ARRAY: uint SPECIALIZED-ARRAY: statfs64 IN: io.files.info.unix.macosx @@ -13,8 +13,8 @@ TUPLE: macosx-file-system-info < unix-file-system-info io-size owner type-id filesystem-subtype ; M: macosx file-systems ( -- array ) - f dup 0 getmntinfo64 dup io-error - [ *void* ] dip + f void* dup 0 getmntinfo64 dup io-error + [ void* deref ] dip [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ; M: macosx new-file-system-info macosx-file-system-info new ; diff --git a/basis/io/files/info/unix/unix-docs.factor b/basis/io/files/info/unix/unix-docs.factor index 7b98788226..c8fc965eca 100644 --- a/basis/io/files/info/unix/unix-docs.factor +++ b/basis/io/files/info/unix/unix-docs.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: classes help.markup help.syntax io.streams.string strings math calendar io.files.info io.files.info.unix ; -IN: io.files.unix +IN: io.files.info.unix HELP: add-file-permissions { $values @@ -102,16 +102,15 @@ HELP: set-file-permissions { "path" "a pathname string" } { "n" "an integer, interepreted as a string of bits" } } { $description "Sets the file permissions for a given file with the supplied Unix permissions integer. Supplying an octal number with " { $link POSTPONE: OCT: } " is recommended." } { $examples "Using the tradidional octal value:" - { $unchecked-example "USING: io.files.unix kernel ;" + { $code "USING: io.files.info.unix kernel ;" "\"resource:license.txt\" OCT: 755 set-file-permissions" - "" } "Higher-level, setting named bits:" - { $unchecked-example "USING: io.files.unix kernel math.bitwise ;" + { $code "USING: io.files.info.unix kernel literals ;" "\"resource:license.txt\"" - "{ USER-ALL GROUP-READ GROUP-EXECUTE OTHER-READ OTHER-EXECUTE }" - "flags set-file-permissions" - "" } + "flags{ USER-ALL GROUP-READ GROUP-EXECUTE OTHER-READ OTHER-EXECUTE }" + "set-file-permissions" + } } ; HELP: set-file-times diff --git a/basis/io/files/windows/windows.factor b/basis/io/files/windows/windows.factor old mode 100644 new mode 100755 index 024b278b4b..6a83fcec27 --- a/basis/io/files/windows/windows.factor +++ b/basis/io/files/windows/windows.factor @@ -3,13 +3,13 @@ USING: accessors alien alien.c-types alien.data alien.strings alien.syntax arrays assocs classes.struct combinators combinators.short-circuit continuations destructors environment -io io.backend io.binary io.buffers -io.encodings.utf16n io.files io.files.private io.files.types -io.pathnames io.ports io.streams.c io.streams.null io.timeouts -kernel libc literals locals make math math.bitwise namespaces -sequences specialized-arrays system -threads tr windows windows.errors windows.handles -windows.kernel32 windows.shell32 windows.time windows.types ; +io io.backend io.binary io.buffers io.encodings.utf16n io.files +io.files.private io.files.types io.pathnames io.ports +io.streams.c io.streams.null io.timeouts kernel libc literals +locals make math math.bitwise namespaces sequences +specialized-arrays system threads tr windows windows.errors +windows.handles windows.kernel32 windows.shell32 windows.time +windows.types ; SPECIALIZED-ARRAY: ushort IN: io.files.windows @@ -52,7 +52,7 @@ C: FileArgs [ handle>> handle>> ] [ buffer>> ] [ buffer>> buffer-length ] - [ drop DWORD ] + [ drop 0 DWORD ] [ FileArgs-overlapped ] } cleave ; @@ -131,7 +131,7 @@ M: winnt init-io ( -- ) ERROR: invalid-file-size n ; : handle>file-size ( handle -- n ) - 0 [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ; + 0 ulonglong [ GetFileSizeEx win32-error=0/f ] keep ulonglong deref ; ERROR: seek-before-start n ; @@ -249,7 +249,7 @@ M: winnt init-stdio GetLastError ERROR_ALREADY_EXISTS = not ; : set-file-pointer ( handle length method -- ) - [ [ handle>> ] dip d>w/w ] dip SetFilePointer + [ [ handle>> ] dip d>w/w uint ] dip SetFilePointer INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ; M: windows (file-reader) ( path -- stream ) @@ -350,4 +350,4 @@ M: winnt home [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ] [ "USERPROFILE" os-env ] [ my-documents ] - } 0|| ; \ No newline at end of file + } 0|| ; diff --git a/basis/io/launcher/launcher-docs.factor b/basis/io/launcher/launcher-docs.factor index cf74113506..6f48cfcdc8 100644 --- a/basis/io/launcher/launcher-docs.factor +++ b/basis/io/launcher/launcher-docs.factor @@ -128,7 +128,7 @@ HELP: kill-process HELP: kill-process* { $values { "handle" "a process handle" } } { $contract "Kills a running process." } -{ $notes "User code should call " { $link kill-process } " intead." } ; +{ $notes "User code should call " { $link kill-process } " instead." } ; HELP: process { $class-description "A class representing a process. Instances are created by calling " { $link } "." } ; diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index 0b58df2e43..4a84064c33 100755 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -180,12 +180,12 @@ M: windows wait-for-processes ( -- ? ) GetCurrentProcess ! source process swap handle>> ! handle GetCurrentProcess ! target process - f [ ! target handle + f void* [ ! target handle DUPLICATE_SAME_ACCESS ! desired access TRUE ! inherit handle 0 ! options DuplicateHandle win32-error=0/f - ] keep *void* &dispose ; + ] keep void* deref &dispose ; ! /dev/null simulation : null-input ( -- pipe ) diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index d99bebbdc3..7418eb0a19 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -12,7 +12,7 @@ HELP: mapped-file } ; HELP: -{ $values { "path" "a pathname string" } { "mmap" mapped-file } } +{ $values { "path" "a pathname string" } { "mmap" mapped-file } } { $contract "Opens a file and maps its contents into memory. The length is permitted to exceed the length of the file on disk, in which case the remaining space is padded with zero bytes." } { $notes "You must call " { $link dispose } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." } { $errors "Throws an error if a memory mapping could not be established." } ; @@ -35,7 +35,7 @@ HELP: close-mapped-file { $errors "Throws an error if a memory mapping could not be established." } ; HELP: -{ $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." } ; diff --git a/basis/io/monitors/windows/windows.factor b/basis/io/monitors/windows/windows.factor index 8887d718d1..43b3ac7ef4 100644 --- a/basis/io/monitors/windows/windows.factor +++ b/basis/io/monitors/windows/windows.factor @@ -32,7 +32,7 @@ TUPLE: win32-monitor < monitor port ; [ recursive>> 1 0 ? ] } cleave FILE_NOTIFY_CHANGE_ALL - 0 + 0 uint (make-overlapped) [ f ReadDirectoryChangesW win32-error=0/f ] keep ; diff --git a/basis/io/servers/servers-docs.factor b/basis/io/servers/servers-docs.factor index 051dfad975..a054a836de 100644 --- a/basis/io/servers/servers-docs.factor +++ b/basis/io/servers/servers-docs.factor @@ -76,8 +76,8 @@ ARTICLE: "io.servers" "Threaded servers" "From within the dynamic scope of a client handler, several words can be used to interact with the threaded server:" { $subsections stop-this-server - secure-port - insecure-port + secure-addr + insecure-addr } "Additionally, the " { $link local-address } " and " { $subsections remote-address } " variables are set, as in " { $link with-client } "." ; @@ -125,12 +125,12 @@ HELP: with-threaded-server } { $description "Runs a server and calls a quotation, stopping the server once the quotation returns." } ; -HELP: secure-port -{ $values { "n/f" { $maybe integer } } } +HELP: secure-addr +{ $values { "addrspec" "an addrspec" } } { $description "Outputs one of the port numbers on which the current threaded server accepts secure socket connections. Outputs " { $link f } " if the current threaded server does not accept secure socket connections." } { $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ; -HELP: insecure-port -{ $values { "n/f" { $maybe integer } } } +HELP: insecure-addr +{ $values { "addrspec" "an addrspec" } } { $description "Outputs one of the port numbers on which the current threaded server accepts ordinary socket connections. Outputs " { $link f } " if the current threaded server does not accept ordinary socket connections." } { $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ; diff --git a/basis/io/servers/servers-tests.factor b/basis/io/servers/servers-tests.factor index bcba7f7d90..e081b655d3 100644 --- a/basis/io/servers/servers-tests.factor +++ b/basis/io/servers/servers-tests.factor @@ -34,7 +34,7 @@ IN: io.servers 0 >>insecure [ "Hello world." write stop-this-server ] >>handler [ - "localhost" insecure-port ascii drop stream-contents + insecure-addr ascii drop stream-contents ] with-threaded-server ] unit-test diff --git a/basis/io/servers/servers.factor b/basis/io/servers/servers.factor old mode 100644 new mode 100755 index 66d0112561..5eee753db2 --- a/basis/io/servers/servers.factor +++ b/basis/io/servers/servers.factor @@ -86,7 +86,9 @@ M: f >insecure ; [ dup secure? [ ] unless ] map ; : listen-on ( threaded-server -- addrspecs ) - [ secure>> >secure ] [ insecure>> >insecure ] bi append + [ secure>> ssl-supported? [ >secure ] [ drop { } ] if ] + [ insecure>> >insecure ] + bi append [ resolve-host ] map concat ; : accepted-connection ( remote local -- ) @@ -141,7 +143,7 @@ M: threaded-server handle-client* handler>> call( -- ) ; \ start-accept-loop NOTICE add-error-logging : create-secure-context ( threaded-server -- threaded-server ) - dup secure>> [ + dup secure>> ssl-supported? and [ dup secure-config>> >>secure-context ] when ; @@ -162,7 +164,8 @@ ERROR: no-ports-configured threaded-server ; : set-servers ( threaded-server -- threaded-server ) dup [ - dup dup listen-on [ no-ports-configured ] [ (make-servers) ] if-empty + dup dup listen-on + [ no-ports-configured ] [ (make-servers) ] if-empty >>servers ] with-existing-secure-context ; @@ -221,21 +224,26 @@ PRIVATE> > ] dip - filter [ f ] [ first addr>> port>> ] if-empty ; inline +GENERIC: connect-addr ( addrspec -- addrspec ) + +M: inet4 connect-addr [ "127.0.0.1" ] dip port>> ; + +M: inet6 connect-addr [ "::1" ] dip port>> ; + +M: secure connect-addr addrspec>> connect-addr ; + +M: local connect-addr ; PRIVATE> -: secure-port ( -- n/f ) [ addr>> secure? ] first-port ; +: server-addrs ( -- addrspecs ) + threaded-server get servers>> [ addr>> connect-addr ] map ; -: insecure-port ( -- n/f ) [ addr>> secure? not ] first-port ; +: secure-addr ( -- addrspec ) + server-addrs [ secure? ] filter random ; -: secure-addr ( -- inet ) - threaded-server get servers>> [ addr>> secure? ] filter random ; - -: insecure-addr ( -- inet ) - threaded-server get servers>> [ addr>> secure? not ] filter random addr>> ; +: insecure-addr ( -- addrspec ) + server-addrs [ secure? not ] filter random ; : server. ( threaded-server -- ) [ [ "=== " write name>> ] [ ] bi write-object nl ] diff --git a/basis/io/sockets/secure/secure.factor b/basis/io/sockets/secure/secure.factor index fbbea7c4c3..92403a58cb 100644 --- a/basis/io/sockets/secure/secure.factor +++ b/basis/io/sockets/secure/secure.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces continuations destructors io debugger io.sockets io.sockets.private sequences summary @@ -11,6 +11,10 @@ SYMBOL: secure-socket-timeout SYMBOL: secure-socket-backend +HOOK: ssl-supported? secure-socket-backend ( -- ? ) + +M: object ssl-supported? f ; + SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ; TUPLE: secure-config diff --git a/basis/io/sockets/secure/unix/unix.factor b/basis/io/sockets/secure/unix/unix.factor index 8fe9facc0c..c856ef2bc8 100644 --- a/basis/io/sockets/secure/unix/unix.factor +++ b/basis/io/sockets/secure/unix/unix.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. +! Copyright (C) 2007, 2010, Slava Pestov, Elie CHAFTARI. ! See http://factorcode.org/license.txt for BSD license. USING: accessors unix byte-arrays kernel sequences namespaces math math.order combinators init alien alien.c-types @@ -11,6 +11,8 @@ unix.ffi ; FROM: io.ports => shutdown ; IN: io.sockets.secure.unix +M: openssl ssl-supported? t ; + M: ssl-handle handle-fd file>> handle-fd ; : syscall-error ( r -- * ) diff --git a/basis/io/sockets/sockets-docs.factor b/basis/io/sockets/sockets-docs.factor index 95ad57a46d..afd0ae1c44 100644 --- a/basis/io/sockets/sockets-docs.factor +++ b/basis/io/sockets/sockets-docs.factor @@ -118,10 +118,10 @@ HELP: inet HELP: { $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 } "." } +{ $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 } ". 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 " } @@ -129,10 +129,10 @@ HELP: inet4 HELP: { $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 } "." } +{ $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 } ". 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 " } @@ -140,7 +140,7 @@ HELP: inet6 HELP: { $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: { $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } { "local" "an address specifier" } } diff --git a/basis/io/sockets/sockets-tests.factor b/basis/io/sockets/sockets-tests.factor index 56939f484f..d601512753 100644 --- a/basis/io/sockets/sockets-tests.factor +++ b/basis/io/sockets/sockets-tests.factor @@ -1,8 +1,21 @@ -IN: io.sockets.tests USING: io.sockets io.sockets.private sequences math tools.test namespaces accessors kernel destructors calendar io.timeouts io.encodings.utf8 io concurrency.promises threads io.streams.string ; +IN: io.sockets.tests + +[ T{ inet4 f f 0 } ] [ f 0 ] unit-test +[ T{ inet6 f f 0 } ] [ f 0 ] unit-test + +[ T{ inet f "google.com" f } ] [ "google.com" f ] unit-test + +[ T{ inet f "google.com" 0 } ] [ "google.com" 0 ] unit-test +[ T{ inet f "google.com" 80 } ] [ "google.com" 0 80 with-port ] unit-test +[ T{ inet4 f "8.8.8.8" 0 } ] [ "8.8.8.8" 0 ] unit-test +[ T{ inet4 f "8.8.8.8" 53 } ] [ "8.8.8.8" 0 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 12 with-port ] unit-test + +[ T{ inet f "google.com" 80 } ] [ "google.com" 80 with-port ] unit-test [ B{ 1 2 3 4 } ] [ "1.2.3.4" T{ inet4 } inet-pton ] unit-test @@ -132,3 +145,4 @@ io.streams.string ; ! Binding to all interfaces should work [ ] [ f 0 dispose ] unit-test +[ ] [ f 0 dispose ] unit-test diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index a48e6ffc95..fcdc00d127 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -16,6 +16,8 @@ IN: io.sockets { [ os unix? ] [ "unix.ffi" ] } } cond use-vocab >> +GENERIC# with-port 1 ( addrspec port -- addrspec ) + ! Addressing > 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>> ] dip inet-ntop ; + [ addr>> uint ] dip inet-ntop ; TUPLE: inet4 < ipv4 { port integer read-only } ; @@ -368,13 +368,18 @@ M: inet present C: inet M: string resolve-host - f prepare-addrinfo f - [ getaddrinfo addrinfo-error ] keep *void* addrinfo memory>struct + f prepare-addrinfo f void* + [ getaddrinfo addrinfo-error ] keep void* deref addrinfo memory>struct [ parse-addrinfo-list ] keep freeaddrinfo ; +M: string with-port ; + M: hostname resolve-host host>> resolve-host ; +M: hostname with-port + [ host>> ] dip ; + M: inet resolve-host [ call-next-method ] [ port>> ] bi '[ _ with-port ] map ; diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index 4d6c699211..3f91c0e8b6 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -16,7 +16,7 @@ IN: io.sockets.unix socket dup io-error init-fd |dispose ; : set-socket-option ( fd level opt -- ) - [ handle-fd ] 2dip 1 dup byte-length setsockopt io-error ; + [ handle-fd ] 2dip 1 int dup byte-length setsockopt io-error ; M: unix addrinfo-error ( n -- ) [ gai_strerror throw ] unless-zero ; @@ -39,11 +39,11 @@ M: unix addrspec-of-family ( af -- addrspec ) ! Client sockets - TCP and Unix domain M: object (get-local-address) ( handle remote -- sockaddr ) - [ handle-fd ] dip empty-sockaddr/size + [ handle-fd ] dip empty-sockaddr/size int [ getsockname io-error ] 2keep drop ; M: object (get-remote-address) ( handle local -- sockaddr ) - [ handle-fd ] dip empty-sockaddr/size + [ handle-fd ] dip empty-sockaddr/size int [ getpeername io-error ] 2keep drop ; : init-client-socket ( fd -- ) @@ -101,7 +101,7 @@ M: object (server) ( addrspec -- handle ) ] with-destructors ; : do-accept ( server addrspec -- fd sockaddr ) - [ handle>> handle-fd ] [ empty-sockaddr/size ] bi* + [ handle>> handle-fd ] [ empty-sockaddr/size int ] bi* [ accept ] 2keep drop ; inline M: object (accept) ( server addrspec -- fd sockaddr ) @@ -138,7 +138,7 @@ CONSTANT: packet-size 65536 packet-size ! nbytes 0 ! flags sockaddr ! from - len ! fromlen + len int ! fromlen recvfrom dup 0 >= [ receive-buffer get-global swap memory>byte-array sockaddr ] [ drop f f ] diff --git a/basis/io/sockets/windows/windows.factor b/basis/io/sockets/windows/windows.factor index 157aa5c848..aea8016156 100755 --- a/basis/io/sockets/windows/windows.factor +++ b/basis/io/sockets/windows/windows.factor @@ -48,11 +48,11 @@ M: win32-socket dispose* ( stream -- ) opened-socket ; M: object (get-local-address) ( socket addrspec -- sockaddr ) - [ handle>> ] dip empty-sockaddr/size + [ handle>> ] dip empty-sockaddr/size int [ getsockname socket-error ] 2keep drop ; M: object (get-remote-address) ( socket addrspec -- sockaddr ) - [ handle>> ] dip empty-sockaddr/size + [ handle>> ] dip empty-sockaddr/size int [ getpeername socket-error ] 2keep drop ; : bind-socket ( win32-socket sockaddr len -- ) @@ -87,7 +87,7 @@ M: windows (raw) ( addrspec -- handle ) [ SOCK_RAW server-socket ] with-destructors ; : malloc-int ( n -- alien ) - malloc-byte-array ; inline + int malloc-byte-array ; inline M: winnt WSASocket-flags ( -- DWORD ) WSA_FLAG_OVERLAPPED ; @@ -99,7 +99,7 @@ M: winnt WSASocket-flags ( -- DWORD ) { void* } [ void* heap-size - DWORD + 0 DWORD f f WSAIoctl SOCKET_ERROR = [ @@ -181,7 +181,8 @@ TUPLE: AcceptEx-args port } cleave AcceptEx drop winsock-error ; inline : (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr ) - f 0 f [ 0 GetAcceptExSockaddrs ] keep *void* ; + f void* 0 int f void* + [ 0 int GetAcceptExSockaddrs ] keep void* deref ; : extract-remote-address ( AcceptEx -- sockaddr ) [ @@ -246,7 +247,7 @@ TUPLE: WSARecvFrom-args port [ [ port>> addr>> empty-sockaddr dup ] [ lpFrom>> ] - [ lpFromLen>> *int ] + [ lpFromLen>> int deref ] tri memcpy ] bi ; inline @@ -278,7 +279,7 @@ TUPLE: WSASendTo-args port swap make-send-buffer >>lpBuffers 1 >>dwBufferCount 0 >>dwFlags - 0 >>lpNumberOfBytesSent + 0 uint >>lpNumberOfBytesSent (make-overlapped) >>lpOverlapped ; inline : call-WSASendTo ( WSASendTo -- ) diff --git a/basis/io/styles/styles-docs.factor b/basis/io/styles/styles-docs.factor index 7750db8f1d..98338639bb 100644 --- a/basis/io/styles/styles-docs.factor +++ b/basis/io/styles/styles-docs.factor @@ -61,6 +61,7 @@ $nl "The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." } { $examples { $code + "USING: io.styles prettyprint sequences ;" "{ { 1 2 } { 3 4 } }" "H{ { table-gap { 10 10 } } } [" " [ [ [ [ . ] with-cell ] each ] with-row ] each" @@ -201,12 +202,13 @@ HELP: bold-italic { $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 foreground associate format" + " \"Hello world\\n\"" + " swap 10 / 1 foreground associate format" "] each" } } ; @@ -215,10 +217,11 @@ HELP: background { $description "Character style. An instance of " { $link color } ". See " { $link "colors" } "." } { $examples { $code + "USING: colors hashtables io io.styles kernel math sequences ;" "10 iota [" - " \"Hello world\\n\"" - " swap 10 / 1 over - over 1 " - " background associate format nl" + " \"Hello world\\n\"" + " swap 10 / 1 over - over 1 " + " background associate format nl" "] each" } } ; @@ -227,14 +230,20 @@ HELP: font-name { $description "Character style. Font family named by a string." } { $examples "This example outputs some different font sizes:" - { $code "{ \"monospace\" \"serif\" \"sans-serif\" }\n[ dup font-name associate format nl ] each" } + { $code + "USING: hashtables io io.styles kernel sequences ;" + "{ \"monospace\" \"serif\" \"sans-serif\" }" + "[ dup font-name associate format nl ] each" + } } ; HELP: font-size { $description "Character style. Font size, an integer." } { $examples "This example outputs some different font sizes:" - { $code "{ 12 18 24 72 }" + { $code + "USING: hashtables io io.styles kernel sequences ;" + "{ 12 18 24 72 }" "[ \"Bigger\" swap font-size associate format nl ] each" } } ; @@ -243,28 +252,44 @@ HELP: font-style { $description "Character style. Font style, one of " { $link plain } ", " { $link bold } ", " { $link italic } ", or " { $link bold-italic } "." } { $examples "This example outputs text in all three styles:" - { $code "{ plain bold italic bold-italic }\n[ [ name>> ] keep font-style associate format nl ] each" } + { $code + "USING: accessors hashtables io io.styles kernel sequences ;" + "{ plain bold italic bold-italic }" + "[ [ name>> ] keep font-style associate format nl ] each" + } } ; HELP: presented { $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 @@ -284,7 +309,10 @@ HELP: input { $class-description "Class of input text presentations. Instances can be used passed to " { $link write-object } " to output a clickable piece of input. Input text presentations are created by calling " { $link } "." } { $examples "This presentation class is used for the code examples you see in the online help:" - { $code "\"2 3 + .\" dup write-object nl" } + { $code + "USING: io io.styles kernel ;" + "\"2 3 + .\" dup write-object nl" + } } ; HELP: @@ -302,4 +330,4 @@ ARTICLE: "io.streams.plain" "Plain writer streams" { $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 } ; diff --git a/basis/iokit/iokit.factor b/basis/iokit/iokit.factor index 4dc4932222..c9de6f8035 100644 --- a/basis/iokit/iokit.factor +++ b/basis/iokit/iokit.factor @@ -156,9 +156,9 @@ TUPLE: mach-error error-code error-string ; io-objects-from-iterator* [ release-io-object ] dip ; : properties-from-io-object ( o -- o nsdictionary ) - dup f [ + dup f void* [ kCFAllocatorDefault kNilOptions IORegistryEntryCreateCFProperties mach-error ] - keep *void* ; + keep void* deref ; diff --git a/basis/literals/literals-docs.factor b/basis/literals/literals-docs.factor index 6fcf8a5e07..52aa1cd717 100644 --- a/basis/literals/literals-docs.factor +++ b/basis/literals/literals-docs.factor @@ -8,23 +8,22 @@ HELP: $ { $description "Executes " { $snippet "word" } " at parse time and adds the result(s) to the parser accumulator." } { $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." } { $examples - - { $example """ -USING: kernel literals prettyprint ; -IN: scratchpad - -CONSTANT: five 5 -{ $ five } . - """ "{ 5 }" } - - { $example """ -USING: kernel literals prettyprint ; -IN: scratchpad - -: seven-eleven ( -- a b ) 7 11 ; -{ $ seven-eleven } . - """ "{ 7 11 }" } - + { $example + "USING: kernel literals prettyprint ;" + "IN: scratchpad" + "" + "CONSTANT: five 5" + "{ $ five } ." + "{ 5 }" + } + { $example + "USING: kernel literals prettyprint ;" + "IN: scratchpad" + "" + ": seven-eleven ( -- a b ) 7 11 ;" + "{ $ seven-eleven } ." + "{ 7 11 }" + } } ; HELP: $[ @@ -32,15 +31,14 @@ HELP: $[ { $description "Calls " { $snippet "code" } " at parse time and adds the result(s) to the parser accumulator." } { $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." } { $examples - - { $example """ -USING: kernel literals math prettyprint ; -IN: scratchpad - -<< CONSTANT: five 5 >> -{ $[ five dup 1 + dup 2 + ] } . - """ "{ 5 6 8 }" } - + { $example + "USING: kernel literals math prettyprint ;" + "IN: scratchpad" + "" + "<< CONSTANT: five 5 >>" + "{ $[ five dup 1 + dup 2 + ] } ." + "{ 5 6 8 }" + } } ; HELP: ${ @@ -48,15 +46,14 @@ HELP: ${ { $description "Outputs an array containing the results of executing " { $snippet "code" } " at parse time." } { $notes { $snippet "code" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." } { $examples - - { $example """ -USING: kernel literals math prettyprint ; -IN: scratchpad - -CONSTANT: five 5 -CONSTANT: six 6 -${ five six 7 } . - """ "{ 5 6 7 }" + { $example + "USING: kernel literals math prettyprint ;" + "IN: scratchpad" + "" + "CONSTANT: five 5" + "CONSTANT: six 6" + "${ five six 7 } ." + "{ 5 6 7 }" } } ; @@ -66,7 +63,8 @@ HELP: flags{ { $values { "values" sequence } } { $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at parse-time, which makes this word as efficient as using a literal integer." } { $examples - { $example "USING: literals kernel prettyprint ;" + { $example + "USING: literals kernel prettyprint ;" "IN: scratchpad" "CONSTANT: x HEX: 1" "flags{ HEX: 20 x BIN: 100 } .h" @@ -77,13 +75,14 @@ HELP: flags{ ARTICLE: "literals" "Interpolating code results into literal values" "The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values." -{ $example """ -USE: literals -IN: scratchpad - -CONSTANT: five 5 -{ $ five $[ five dup 1 + dup 2 + ] } . - """ "{ 5 5 6 8 }" } +{ $example + "USING: kernel literals math prettyprint ;" + "IN: scratchpad" + "" + "<< CONSTANT: five 5 >>" + "{ $ five $[ five dup 1 + dup 2 + ] } ." + "{ 5 5 6 8 }" +} { $subsections POSTPONE: $ POSTPONE: $[ diff --git a/basis/logging/analysis/analysis.factor b/basis/logging/analysis/analysis.factor index eb8a2eaf76..786aa77c52 100644 --- a/basis/logging/analysis/analysis.factor +++ b/basis/logging/analysis/analysis.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences namespaces words assocs logging sorting prettyprint io io.styles io.files io.encodings.utf8 -strings combinators accessors arrays +strings combinators accessors arrays math logging.server logging.parser calendar.format ; IN: logging.analysis @@ -20,6 +20,9 @@ SYMBOL: message-histogram ] when drop ; +: recent-histogram ( assoc n -- alist ) + [ >alist sort-values ] dip short head ; + : analyze-entries ( entries word-names -- errors word-histogram message-histogram ) [ word-names set @@ -27,44 +30,40 @@ SYMBOL: message-histogram H{ } clone word-histogram set H{ } clone message-histogram set - [ - analyze-entry - ] each + [ analyze-entry ] each errors get - word-histogram get - message-histogram get + word-histogram get 10 recent-histogram + message-histogram get 10 recent-histogram ] with-scope ; : histogram. ( assoc quot -- ) standard-table-style [ - [ >alist sort-values ] dip [ + [ [ swapd with-cell pprint-cell ] with-row ] curry assoc-each ] tabular-output ; inline -: log-entry. ( entry -- ) - "====== " write - { - [ date>> (timestamp>string) bl ] - [ level>> pprint bl ] - [ word-name>> write nl ] - [ message>> "\n" join print ] - } cleave ; +: 10-most-recent ( errors -- errors ) + 10 tail* "Only showing 10 most recent errors" print nl ; : errors. ( errors -- ) - [ log-entry. ] each ; + dup length 10 >= [ 10-most-recent ] when + log-entries. ; : analysis. ( errors word-histogram message-histogram -- ) - "==== INTERESTING MESSAGES:" print nl + nl "==== FREQUENT MESSAGES:" print nl "Total: " write dup values sum . nl [ - dup level>> write ": " write message>> "\n" join write + [ first name>> write bl ] + [ second write ": " write ] + [ third "\n" join write ] + tri ] histogram. - nl - "==== WORDS:" print nl + nl nl + "==== FREQUENT WORDS:" print nl [ write ] histogram. - nl + nl nl "==== ERRORS:" print nl errors. ; diff --git a/basis/logging/insomniac/insomniac-docs.factor b/basis/logging/insomniac/insomniac-docs.factor index ccec5e50cf..4a989cfc87 100644 --- a/basis/logging/insomniac/insomniac-docs.factor +++ b/basis/logging/insomniac/insomniac-docs.factor @@ -8,11 +8,6 @@ HELP: insomniac-sender HELP: insomniac-recipients { $var-description "A sequence of e-mail addresses to mail log reports to. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ; -HELP: ?analyze-log -{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } { "string/f" string } } -{ $description "Analyzes the most recent log and outputs the string analysis, or outputs " { $link f } " if it doesn't exist." } -{ $see-also analyze-log } ; - HELP: email-log-report { $values { "service" "a log service name" } { "word-names" "a sequence of strings" } } { $description "E-mails a log report for the given log service. The " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ; diff --git a/basis/logging/insomniac/insomniac.factor b/basis/logging/insomniac/insomniac.factor index 2a0be6aa79..5f323d7ada 100644 --- a/basis/logging/insomniac/insomniac.factor +++ b/basis/logging/insomniac/insomniac.factor @@ -1,31 +1,26 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: logging.analysis logging.server logging smtp kernel io.files io.streams.string namespaces make timers assocs -io.encodings.utf8 accessors calendar sequences ; +io.encodings.utf8 accessors calendar sequences locals ; QUALIFIED: io.sockets IN: logging.insomniac SYMBOL: insomniac-sender SYMBOL: insomniac-recipients -: ?analyze-log ( service word-names -- string/f ) - [ analyze-log-file ] with-string-writer ; - : email-subject ( service -- string ) [ - "[INSOMNIAC] " % % " on " % io.sockets:host-name % + "Log analysis for " % % " on " % io.sockets:host-name % ] "" make ; -: (email-log-report) ( service word-names -- ) - dupd ?analyze-log [ drop ] [ - - swap >>body - insomniac-recipients get >>to - insomniac-sender get >>from - swap email-subject >>subject - send-email - ] if-empty ; +:: (email-log-report) ( service word-names -- ) + + [ service word-names analyze-log-file ] with-string-writer >>body + insomniac-recipients get >>to + insomniac-sender get >>from + service email-subject >>subject + send-email ; \ (email-log-report) NOTICE add-error-logging @@ -33,5 +28,5 @@ SYMBOL: insomniac-recipients "logging.insomniac" [ (email-log-report) ] with-logging ; : schedule-insomniac ( service word-names -- ) - [ [ email-log-report ] assoc-each rotate-logs ] 2curry - 1 days delayed-every drop ; + [ email-log-report rotate-logs ] 2curry + 1 days every drop ; diff --git a/basis/logging/logging-tests.factor b/basis/logging/logging-tests.factor index 796c8769fc..a7cc6c6f5f 100644 --- a/basis/logging/logging-tests.factor +++ b/basis/logging/logging-tests.factor @@ -1,5 +1,5 @@ IN: logging.tests -USING: tools.test logging math ; +USING: tools.test logging logging.analysis io math ; : input-logging-test ( a b -- c ) + ; @@ -22,3 +22,5 @@ USING: tools.test logging math ; [ f ] [ 1 0 error-logging-test ] unit-test ] with-logging + +[ ] [ "logging-test" { "input-logging-test" } analyze-log-file ] unit-test diff --git a/basis/logging/parser/parser.factor b/basis/logging/parser/parser.factor index dbc26c7efc..a359c9a254 100644 --- a/basis/logging/parser/parser.factor +++ b/basis/logging/parser/parser.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors peg peg.parsers memoize kernel sequences logging arrays words strings vectors io io.files io.encodings.utf8 namespaces make combinators logging.server -calendar calendar.format assocs ; +calendar calendar.format assocs prettyprint ; IN: logging.parser TUPLE: log-entry date level word-name message ; @@ -83,3 +83,20 @@ PEG: parse-log-line ( string -- entry ) 'log-line' ; : parse-log-file ( service -- entries ) log-path 1 log# dup exists? [ utf8 file-lines parse-log ] [ drop f ] if ; + +GENERIC: log-timestamp. ( date -- ) + +M: timestamp log-timestamp. (timestamp>string) ; +M: word log-timestamp. drop "multiline" write ; + +: log-entry. ( entry -- ) + "====== " write + { + [ date>> log-timestamp. bl ] + [ level>> pprint bl ] + [ word-name>> write nl ] + [ message>> "\n" join print ] + } cleave ; + +: log-entries. ( errors -- ) + [ log-entry. ] each ; diff --git a/basis/math/floats/half/half.factor b/basis/math/floats/half/half.factor index ffa3550452..d82e3b1fdd 100644 --- a/basis/math/floats/half/half.factor +++ b/basis/math/floats/half/half.factor @@ -41,6 +41,6 @@ SYMBOL: half 2 >>align 2 >>align-first [ >float ] >>unboxer-quot -\ half define-primitive-type +\ half typedef >> diff --git a/basis/math/primes/erato/erato-docs.factor b/basis/math/primes/erato/erato-docs.factor index 1e32818fe3..b9d9ea38df 100644 --- a/basis/math/primes/erato/erato-docs.factor +++ b/basis/math/primes/erato/erato-docs.factor @@ -1,10 +1,14 @@ -USING: help.markup help.syntax ; +USING: byte-arrays help.markup help.syntax kernel math ; IN: math.primes.erato HELP: sieve -{ $values { "n" "the greatest odd number to consider" } { "arr" "a bit array" } } -{ $description "Apply Eratostene sieve up to " { $snippet "n" } ". Primality can then be tested using " { $link sieve } "." } ; +{ $values { "n" integer } { "arr" byte-array } } +{ $description "Apply Eratostene sieve up to " { $snippet "n" } +". " { $snippet "n" } " must be greater than 1" +". Primality can then be tested using " { $link marked-prime? } "." } ; HELP: marked-prime? -{ $values { "n" "an integer" } { "arr" "a byte array returned by " { $link sieve } } { "?" "a boolean" } } -{ $description "Check whether a number between 3 and the limit given to " { $link sieve } " has been marked as a prime number."} ; +{ $values { "n" integer } { "arr" byte-array } { "?" boolean } } +{ $description "Checks whether " { $snippet "n" } " has been marked as a prime number. " +{ $snippet "arr" } " must be " { $instance byte-array } " returned by " { $link sieve } ". " +{ $snippet "n" } " must be between 2 and the limit given to " { $link sieve } "." } ; diff --git a/basis/math/primes/erato/erato-tests.factor b/basis/math/primes/erato/erato-tests.factor index e6f7765bd6..ff44ec2210 100644 --- a/basis/math/primes/erato/erato-tests.factor +++ b/basis/math/primes/erato/erato-tests.factor @@ -1,4 +1,5 @@ -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 @@ -8,3 +9,8 @@ USING: byte-arrays math math.bitwise math.primes.erato sequences tools.test ; ! 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 diff --git a/basis/math/primes/erato/erato.factor b/basis/math/primes/erato/erato.factor index fdc2f9fc3b..4df724cfc2 100644 --- a/basis/math/primes/erato/erato.factor +++ b/basis/math/primes/erato/erato.factor @@ -28,7 +28,7 @@ CONSTANT: masks B{ 0 128 0 0 0 0 0 64 0 0 0 32 0 16 0 0 0 8 0 4 0 0 0 2 0 0 0 0 2drop ] if ; -: init-sieve ( n -- arr ) 29 + 30 /i 255 >byte-array ; +: init-sieve ( n -- arr ) 30 /i 1 + 255 >byte-array ; PRIVATE> diff --git a/basis/models/arrow/arrow.factor b/basis/models/arrow/arrow.factor index e0cf73c7f1..a1654ccc34 100644 --- a/basis/models/arrow/arrow.factor +++ b/basis/models/arrow/arrow.factor @@ -1,18 +1,18 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors models kernel ; +USING: accessors models kernel sequences ; IN: models.arrow -TUPLE: arrow < model model quot ; +TUPLE: arrow < model quot ; : ( model quot -- arrow ) f arrow new-model swap >>quot - over >>model [ add-dependency ] keep ; M: arrow model-changed [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi set-model ; -M: arrow model-activated [ model>> ] keep model-changed ; +M: arrow model-activated + [ dependencies>> ] keep [ model-changed ] curry each ; diff --git a/basis/multiline/multiline-docs.factor b/basis/multiline/multiline-docs.factor index 9e7c28e89f..09f86197ba 100644 --- a/basis/multiline/multiline-docs.factor +++ b/basis/multiline/multiline-docs.factor @@ -17,7 +17,7 @@ HELP: /* 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 ;" diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index fda840b281..0589e0eede 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -142,7 +142,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) [ 1 { uint } ] dip with-out-parameters ; inline : (delete-gl-object) ( id quot -- ) - [ 1 swap ] dip call ; inline + [ 1 swap uint ] dip call ; inline : gen-gl-buffer ( -- id ) [ glGenBuffers ] (gen-gl-object) ; diff --git a/basis/opengl/shaders/shaders.factor b/basis/opengl/shaders/shaders.factor index 720665a1b8..1b7ac94f4d 100644 --- a/basis/opengl/shaders/shaders.factor +++ b/basis/opengl/shaders/shaders.factor @@ -1,14 +1,14 @@ ! 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 [ swap call ] keep free ; inline + swap ascii malloc-string [ void* swap call ] keep free ; inline : ( source kind -- shader ) glCreateShader dup rot @@ -47,7 +47,7 @@ IN: opengl.shaders : gl-shader-info-log ( shader -- log ) dup gl-shader-info-log-length dup [ 1 calloc &free - [ 0 swap glGetShaderInfoLog ] keep + [ 0 int swap glGetShaderInfoLog ] keep ascii alien>string ] with-destructors ; @@ -90,7 +90,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; : gl-program-info-log ( program -- log ) dup gl-program-info-log-length dup [ 1 calloc &free - [ 0 swap glGetProgramInfoLog ] keep + [ 0 int swap glGetProgramInfoLog ] keep ascii alien>string ] with-destructors ; @@ -107,7 +107,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; : gl-program-shaders ( program -- shaders ) dup gl-program-shaders-length 2 * - 0 + 0 int over [ glGetAttachedShaders ] keep [ zero? not ] filter ; diff --git a/basis/random/random.factor b/basis/random/random.factor index ba5d9c7ca3..bf99b47ba7 100644 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -1,9 +1,9 @@ ! 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 @@ -90,8 +90,8 @@ ERROR: too-many-samples seq n ; 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 diff --git a/basis/random/sfmt/sfmt.factor b/basis/random/sfmt/sfmt.factor index ccccaac7ea..2efe6f6fac 100644 --- a/basis/random/sfmt/sfmt.factor +++ b/basis/random/sfmt/sfmt.factor @@ -1,7 +1,7 @@ ! 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 diff --git a/basis/sequences/product/product.factor b/basis/sequences/product/product.factor index 4290085482..487d7b2eca 100644 --- a/basis/sequences/product/product.factor +++ b/basis/sequences/product/product.factor @@ -14,7 +14,7 @@ M: product-sequence length lengths>> product ; > product ; [ 0 over [ 1 + ] change-nth ] dip carry-ns ; : start-product-iter ( sequences -- ns lengths ) - [ [ drop 0 ] map ] [ [ length ] map ] bi ; + [ length 0 ] [ [ length ] map ] bi ; : end-product-iter? ( ns lengths -- ? ) - [ 1 tail* first ] bi@ = ; + [ last ] bi@ = ; PRIVATE> diff --git a/basis/specialized-arrays/specialized-arrays-docs.factor b/basis/specialized-arrays/specialized-arrays-docs.factor index b476a47072..99036ac013 100644 --- a/basis/specialized-arrays/specialized-arrays-docs.factor +++ b/basis/specialized-arrays/specialized-arrays-docs.factor @@ -41,7 +41,7 @@ ARTICLE: "specialized-array-words" "Specialized array words" { { $snippet "T-array" } { "The class of arrays with elements of type " { $snippet "T" } } } { { $snippet "" } { "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 "" } { "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 )" } } } @@ -86,7 +86,7 @@ $nl } "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 "" } ":" { $code - "USING: alien.c-types classes.struct ;" + "USING: alien.c-types alien.data classes.struct ;" "" "STRUCT: device_info" " { id int }" @@ -94,7 +94,7 @@ $nl "" "FUNCTION: void get_device_info ( int* length ) ;" "" - "0 [ get_device_info ] keep ." + "0 int [ get_device_info ] keep ." } "For a full discussion of Factor heap allocation versus unmanaged memory allocation, see " { $link "byte-arrays-gc" } "." $nl diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index 02424a22fd..e3770220e8 100644 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -6,7 +6,8 @@ multiline eval words vocabs namespaces assocs prettyprint 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 diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 47e882f227..43bff4e96a 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -338,7 +338,6 @@ M: object infer-call* \ call bad-macro-input ; \ 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 diff --git a/basis/system-info/macosx/macosx.factor b/basis/system-info/macosx/macosx.factor index b51fd52995..d4f2277128 100644 --- a/basis/system-info/macosx/macosx.factor +++ b/basis/system-info/macosx/macosx.factor @@ -1,6 +1,6 @@ ! 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 @@ -11,23 +11,23 @@ LIBRARY: libc FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, void* newp, size_t newlen ) ; : make-int-array ( seq -- byte-array ) - [ ] map concat ; + [ int ] 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 - [ ] [ ] bi (sysctl-query) ; + [ ] [ uint ] 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 ; diff --git a/basis/system-info/windows/windows.factor b/basis/system-info/windows/windows.factor index 0aba5eeff1..4ff252bf25 100644 --- a/basis/system-info/windows/windows.factor +++ b/basis/system-info/windows/windows.factor @@ -1,10 +1,9 @@ ! 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 @@ -95,10 +94,10 @@ M: winnt available-virtual-mem ( -- n ) : computer-name ( -- string ) MAX_COMPUTERNAME_LENGTH 1 + - [ dup ] keep + [ dup ] keep uint GetComputerName win32-error=0/f alien>native-string ; : username ( -- string ) UNLEN 1 + - [ dup ] keep + [ dup ] keep uint GetUserName win32-error=0/f alien>native-string ; diff --git a/basis/timers/timers-docs.factor b/basis/timers/timers-docs.factor index f3a3e4437b..9a9b29cbf3 100644 --- a/basis/timers/timers-docs.factor +++ b/basis/timers/timers-docs.factor @@ -22,10 +22,9 @@ HELP: every { "timer" timer } } { $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." } { $examples - { $unchecked-example + { $code "USING: timers io calendar ;" """[ "Hi Buddy." print flush ] 10 seconds every drop""" - "" } } ; @@ -33,10 +32,9 @@ HELP: later { $values { "quot" quotation } { "delay-duration" duration } { "timer" timer } } { $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." } { $examples - { $unchecked-example + { $code "USING: timers io calendar ;" """[ "Break's over!" print flush ] 15 minutes later drop""" - "" } } ; @@ -46,10 +44,9 @@ HELP: delayed-every { "timer" timer } } { $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." } { $examples - { $unchecked-example + { $code "USING: timers io calendar ;" """[ "Hi Buddy." print flush ] 10 seconds every drop""" - "" } } ; diff --git a/basis/tools/crossref/crossref-docs.factor b/basis/tools/crossref/crossref-docs.factor index e8c45ee4a0..29b3d26d10 100644 --- a/basis/tools/crossref/crossref-docs.factor +++ b/basis/tools/crossref/crossref-docs.factor @@ -28,7 +28,7 @@ HELP: uses { $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 diff --git a/basis/tools/deploy/config/config-docs.factor b/basis/tools/deploy/config/config-docs.factor index 0b06abc29a..2f52547104 100644 --- a/basis/tools/deploy/config/config-docs.factor +++ b/basis/tools/deploy/config/config-docs.factor @@ -40,13 +40,15 @@ HELP: deploy-c-types? $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 } { $link } + { $link } { $link malloc-array } + { $link } + { $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." } ; diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index e8888717ab..1da32f3f42 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -134,3 +134,5 @@ os macosx? [ [ ] [ "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 diff --git a/basis/tools/dns/authors.txt b/basis/tools/dns/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/tools/dns/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/tools/dns/dns.factor b/basis/tools/dns/dns.factor new file mode 100644 index 0000000000..f59a9da217 --- /dev/null +++ b/basis/tools/dns/dns.factor @@ -0,0 +1,24 @@ +! 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 ; diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 48647df92d..1e7777d9d7 100644 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -128,7 +128,7 @@ CONSTANT: window-control>styleMask : make-context-transparent ( view -- ) -> openGLContext - 0 NSOpenGLCPSurfaceOpacity -> setValues:forParameter: ; + 0 int NSOpenGLCPSurfaceOpacity -> setValues:forParameter: ; M:: cocoa-ui-backend (open-window) ( world -- ) world [ [ dim>> ] dip ] diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index e98c31b295..7837402701 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -332,7 +332,7 @@ CLASS: FactorView < NSOpenGLView NSTextInput ] : sync-refresh-to-screen ( GLView -- ) - -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 + -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 int CGLSetParameter drop ; : ( dim pixel-format -- view ) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 5178dbb499..072924fa57 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -1,21 +1,22 @@ ! 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 @@ -59,14 +60,14 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: WGL_ARB { $ WGL_SUPPORT_OPENGL_ARB 1 } H{ 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 } + first c:int { c:int } [ wglGetPixelFormatAttribivARB win32-error=0/f ] with-out-parameters ] if-empty ; @@ -95,7 +96,7 @@ CONSTANT: pfd-flag-map H{ : >pfd ( attributes -- pfd ) [ PIXELFORMATDESCRIPTOR ] dip { - [ drop PIXELFORMATDESCRIPTOR heap-size >>nSize ] + [ drop PIXELFORMATDESCRIPTOR c:heap-size >>nSize ] [ drop 1 >>nVersion ] [ >pfd-flags >>dwFlags ] [ drop PFD_TYPE_RGBA >>iPixelType ] @@ -121,12 +122,12 @@ CONSTANT: pfd-flag-map H{ : get-pfd ( pixel-format -- pfd ) [ world>> handle>> hDC>> ] [ handle>> ] bi - PIXELFORMATDESCRIPTOR heap-size + PIXELFORMATDESCRIPTOR c:heap-size PIXELFORMATDESCRIPTOR [ 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 ) { @@ -168,7 +169,7 @@ M: windows-ui-backend (pixel-format-attribute) PRIVATE> -: lo-word ( wparam -- lo ) *short ; inline +: lo-word ( wparam -- lo ) c:short 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 ) @@ -524,7 +525,7 @@ SYMBOL: nc-buttons : make-TRACKMOUSEEVENT ( hWnd -- alien ) TRACKMOUSEEVENT swap >>hwndTrack - TRACKMOUSEEVENT heap-size >>cbSize ; + TRACKMOUSEEVENT c:heap-size >>cbSize ; : handle-wm-mousemove ( hWnd uMsg wParam lParam -- ) 2nip @@ -613,7 +614,7 @@ SYMBOL: trace-messages? ! 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 @@ -635,7 +636,7 @@ M: windows-ui-backend do-events :: register-window-class ( class-name-ptr -- ) WNDCLASSEX 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 @@ -798,7 +799,7 @@ M: windows-ui-backend system-alert : fullscreen-RECT ( hwnd -- RECT ) MONITOR_DEFAULTTONEAREST MonitorFromWindow MONITORINFOEX - MONITORINFOEX heap-size >>cbSize + MONITORINFOEX c:heap-size >>cbSize [ GetMonitorInfo win32-error=0/f ] keep rcMonitor>> ; : client-area>RECT ( hwnd -- RECT ) diff --git a/basis/ui/pixel-formats/pixel-formats-docs.factor b/basis/ui/pixel-formats/pixel-formats-docs.factor index c82990a79e..6537f34727 100644 --- a/basis/ui/pixel-formats/pixel-formats-docs.factor +++ b/basis/ui/pixel-formats/pixel-formats-docs.factor @@ -45,8 +45,7 @@ ARTICLE: "ui.pixel-formats-attributes" "Pixel format attributes" } { $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 ; @@ -63,8 +62,7 @@ M: picky-depth-buffered-world check-world-pixel-format [ 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 diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index 64eb5db07e..5e6d3150c7 100644 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -47,7 +47,7 @@ HELP: find-window 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" } } @@ -75,7 +75,7 @@ HELP: raise-window 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 @@ -255,7 +255,7 @@ $nl } "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." ; diff --git a/basis/unix/ffi/bsd/bsd.factor b/basis/unix/ffi/bsd/bsd.factor index 3b3052af23..388fd5a692 100644 --- a/basis/unix/ffi/bsd/bsd.factor +++ b/basis/unix/ffi/bsd/bsd.factor @@ -69,12 +69,10 @@ CONSTANT: SOCK_RAW 3 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 diff --git a/basis/unix/ffi/bsd/freebsd/freebsd.factor b/basis/unix/ffi/bsd/freebsd/freebsd.factor index 112758a3e8..cb45cf2b20 100644 --- a/basis/unix/ffi/bsd/freebsd/freebsd.factor +++ b/basis/unix/ffi/bsd/freebsd/freebsd.factor @@ -1,6 +1,9 @@ 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 diff --git a/basis/unix/ffi/bsd/macosx/macosx.factor b/basis/unix/ffi/bsd/macosx/macosx.factor index 2ca1d9315d..5a6775f214 100644 --- a/basis/unix/ffi/bsd/macosx/macosx.factor +++ b/basis/unix/ffi/bsd/macosx/macosx.factor @@ -5,6 +5,9 @@ IN: unix.ffi CONSTANT: FD_SETSIZE 1024 +CONSTANT: AF_INET6 30 +ALIAS: PF_INET6 AF_INET6 + STRUCT: addrinfo { flags int } { family int } diff --git a/basis/unix/ffi/bsd/openbsd/openbsd.factor b/basis/unix/ffi/bsd/openbsd/openbsd.factor index 1f4eddef66..dba7ddd3cd 100644 --- a/basis/unix/ffi/bsd/openbsd/openbsd.factor +++ b/basis/unix/ffi/bsd/openbsd/openbsd.factor @@ -1,6 +1,9 @@ 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 diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index 5da7c189ae..c4632c590f 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -1,7 +1,7 @@ ! 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 ; @@ -22,10 +22,10 @@ GENERIC: group-struct ( obj -- group/f ) : (group-struct) ( id -- group-struct id group-struct byte-array length void* ) [ \ unix.ffi:group ] dip over 4096 - [ ] keep f ; + [ ] keep f void* ; : 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) @@ -67,13 +67,13 @@ ERROR: no-group string ; 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 * ] keep - [ [ unix.ffi:getgrouplist ] unix-system-call drop ] 2keep - [ 4 tail-slice ] [ *int 1 - ] bi* >groups ; + int [ [ unix.ffi:getgrouplist ] unix-system-call drop ] 2keep + [ 4 tail-slice ] [ int deref 1 - ] bi* >groups ; PRIVATE> diff --git a/basis/unix/types/freebsd/freebsd.factor b/basis/unix/types/freebsd/freebsd.factor index 4973df989d..41cf7ac188 100644 --- a/basis/unix/types/freebsd/freebsd.factor +++ b/basis/unix/types/freebsd/freebsd.factor @@ -22,5 +22,3 @@ TYPEDEF: __uint32_t fflags_t TYPEDEF: long ssize_t TYPEDEF: int pid_t TYPEDEF: long time_t - -ALIAS: diff --git a/basis/unix/types/linux/linux.factor b/basis/unix/types/linux/linux.factor index a3dddfc93e..7a09b0474a 100644 --- a/basis/unix/types/linux/linux.factor +++ b/basis/unix/types/linux/linux.factor @@ -31,5 +31,3 @@ TYPEDEF: ulonglong __fsblkcnt64_t TYPEDEF: ulonglong __fsfilcnt64_t TYPEDEF: ulonglong ino64_t TYPEDEF: ulonglong off64_t - -ALIAS: \ No newline at end of file diff --git a/basis/unix/types/macosx/macosx.factor b/basis/unix/types/macosx/macosx.factor index 2bebc981f9..fc435cd9fb 100644 --- a/basis/unix/types/macosx/macosx.factor +++ b/basis/unix/types/macosx/macosx.factor @@ -33,7 +33,3 @@ TYPEDEF: char[512] io_string_t TYPEDEF: kern_return_t IOReturn TYPEDEF: uint IOOptionBits - - - -ALIAS: diff --git a/basis/unix/types/netbsd/netbsd.factor b/basis/unix/types/netbsd/netbsd.factor index 7dacc97061..58fd5d400b 100644 --- a/basis/unix/types/netbsd/netbsd.factor +++ b/basis/unix/types/netbsd/netbsd.factor @@ -17,8 +17,6 @@ TYPEDEF: long ssize_t TYPEDEF: int pid_t TYPEDEF: int time_t -ALIAS: - cell-bits { { 32 [ "unix.types.netbsd.32" require ] } { 64 [ "unix.types.netbsd.64" require ] } diff --git a/basis/unix/types/openbsd/openbsd.factor b/basis/unix/types/openbsd/openbsd.factor index 7c8fbd2b9d..30bc539207 100644 --- a/basis/unix/types/openbsd/openbsd.factor +++ b/basis/unix/types/openbsd/openbsd.factor @@ -17,5 +17,3 @@ TYPEDEF: __uint32_t fflags_t TYPEDEF: long ssize_t TYPEDEF: int pid_t TYPEDEF: int time_t - -ALIAS: \ No newline at end of file diff --git a/basis/unix/users/users-docs.factor b/basis/unix/users/users-docs.factor index a0b2b264f7..fe0c3e853d 100644 --- a/basis/unix/users/users-docs.factor +++ b/basis/unix/users/users-docs.factor @@ -20,7 +20,7 @@ HELP: new-passwd { $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 } "." } ; @@ -82,7 +82,7 @@ HELP: with-real-user { 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 @@ -95,7 +95,7 @@ HELP: ?user-id HELP: all-user-names { $values - + { "seq" sequence } } { $description "Returns a sequence of group names as strings." } ; diff --git a/basis/unix/utilities/utilities.factor b/basis/unix/utilities/utilities.factor index 919b2ae8a2..cd32c91d3c 100644 --- a/basis/unix/utilities/utilities.factor +++ b/basis/unix/utilities/utilities.factor @@ -8,14 +8,14 @@ IN: unix.utilities SPECIALIZED-ARRAY: void* : more? ( alien -- ? ) - { [ ] [ *void* ] } 1&& ; + { [ ] [ void* deref ] } 1&& ; : advance ( void* -- void* ) cell swap ; : 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 ) diff --git a/basis/urls/encoding/encoding-docs.factor b/basis/urls/encoding/encoding-docs.factor index 39ce5c7bca..1f2b6e8e47 100644 --- a/basis/urls/encoding/encoding-docs.factor +++ b/basis/urls/encoding/encoding-docs.factor @@ -1,4 +1,4 @@ -USING: strings help.markup help.syntax assocs ; +USING: strings help.markup help.syntax assocs urls ; IN: urls.encoding HELP: url-decode diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor index a66ba14694..c177196786 100644 --- a/basis/urls/urls-docs.factor +++ b/basis/urls/urls-docs.factor @@ -76,7 +76,7 @@ HELP: ensure-port } ; 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 diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor index 0f89ba0d9f..19aea0fdac 100644 --- a/basis/urls/urls.factor +++ b/basis/urls/urls.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel ascii combinators combinators.short-circuit sequences splitting fry namespaces make assocs arrays strings @@ -24,14 +24,12 @@ TUPLE: url protocol username password host port path query anchor ; 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 ) @@ -68,22 +66,22 @@ url = ((protocol "://") => [[ first ]] auth hostname)? PRIVATE> M: string >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 ) @@ -177,6 +175,9 @@ PRIVATE> ] [ 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 ; @@ -186,3 +187,4 @@ SYNTAX: URL" lexer get skip-blank parse-string >url suffix! ; USE: vocabs.loader { "urls" "prettyprint" } "urls.prettyprint" require-when +{ "urls" "io.sockets.secure" } "urls.secure" require-when diff --git a/basis/windows/com/com-tests.factor b/basis/windows/com/com-tests.factor index fdc48adfbe..f11c930c85 100644 --- a/basis/windows/com/com-tests.factor +++ b/basis/windows/com/com-tests.factor @@ -1,7 +1,8 @@ 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} @@ -58,7 +59,7 @@ C: test-implementation dup +guinea-pig-implementation+ set [ drop S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test - E_FAIL *long 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test + E_FAIL long long deref 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test 20 1array [ +guinea-pig-implementation+ get [ 20 IInherited::setX ] diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor old mode 100644 new mode 100755 index dc6a0604fb..27105992ec --- a/basis/windows/com/syntax/syntax.factor +++ b/basis/windows/com/syntax/syntax.factor @@ -1,6 +1,6 @@ -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 ; @@ -11,7 +11,7 @@ IN: windows.com.syntax MACRO: com-invoke ( n return parameters -- ) [ 2nip length ] 3keep '[ - _ npick *void* _ cell * alien-cell _ _ + _ npick void* deref _ cell * alien-cell _ _ stdcall alien-indirect ] ; diff --git a/basis/windows/iphlpapi/iphlpapi.factor b/basis/windows/iphlpapi/iphlpapi.factor index cb00dde66b..9beb3bd9a6 100644 --- a/basis/windows/iphlpapi/iphlpapi.factor +++ b/basis/windows/iphlpapi/iphlpapi.factor @@ -1,6 +1,6 @@ ! 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 @@ -63,7 +63,7 @@ TYPEDEF: FIXED_INFO* PFIXED_INFO FUNCTION: DWORD GetNetworkParams ( PFIXED_INFO pFixedInfo, PULONG pOutBufLen ) ; : get-fixed-info ( -- FIXED_INFO ) - FIXED_INFO dup byte-length + FIXED_INFO dup byte-length ulong [ GetNetworkParams n>win32-error-check ] 2keep drop ; : dns-server-ips ( -- sequence ) @@ -72,4 +72,4 @@ FUNCTION: DWORD GetNetworkParams ( PFIXED_INFO pFixedInfo, PULONG pOutBufLen ) ; [ IpAddress>> String>> [ 0 = ] trim-tail utf8 decode , ] [ Next>> ] bi dup ] loop drop - ] { } make ; \ No newline at end of file + ] { } make ; diff --git a/basis/windows/registry/registry.factor b/basis/windows/registry/registry.factor index 25c80061b2..1d6a302b2a 100644 --- a/basis/windows/registry/registry.factor +++ b/basis/windows/registry/registry.factor @@ -13,7 +13,7 @@ samDesired lpSecurityAttributes phkResult lpdwDisposition ; CONSTANT: registry-value-max-length 16384 :: open-key ( key subkey mode -- hkey ) - key subkey 0 mode HKEY + key subkey 0 mode 0 HKEY [ RegOpenKeyEx dup ERROR_SUCCESS = [ drop @@ -21,16 +21,16 @@ CONSTANT: registry-value-max-length 16384 [ 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 - DWORD f :> ret! + hKey lpSubKey 0 lpClass dwOptions samDesired lpSecurityAttributes + 0 HKEY + 0 DWORD [ 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 @@ -67,11 +67,11 @@ CONSTANT: registry-value-max-length 16384 length 2 * ; :: reg-query-value-ex ( key subkey ptr1 ptr2 buffer -- buffer ) - buffer length :> pdword + buffer length uint :> pdword key subkey ptr1 ptr2 buffer pdword [ RegQueryValueEx ] 2keep rot :> ret ret ERROR_SUCCESS = [ - *uint head + uint deref head ] [ ret ERROR_MORE_DATA = [ 2drop @@ -103,9 +103,9 @@ TUPLE: registry-enum-key ; registry-value-max-length TCHAR dup :> registry-value registry-value length dup :> registry-value-length f - DWORD dup :> type - f ! BYTE dup :> data - f ! BYTE dup :> buffer + 0 DWORD dup :> type + f ! 0 BYTE dup :> data + f ! 0 BYTE dup :> buffer RegEnumKeyEx dup ERROR_SUCCESS = [ ] [ @@ -116,27 +116,27 @@ TUPLE: registry-enum-key ; key MAX_PATH dup TCHAR dup :> class-buffer - swap dup :> class-buffer-length + swap int dup :> class-buffer-length f - DWORD dup :> sub-keys - DWORD dup :> longest-subkey - DWORD dup :> longest-class-string - DWORD dup :> #values - DWORD dup :> max-value - DWORD dup :> max-value-data - DWORD dup :> security-descriptor + 0 DWORD dup :> sub-keys + 0 DWORD dup :> longest-subkey + 0 DWORD dup :> longest-class-string + 0 DWORD dup :> #values + 0 DWORD dup :> max-value + 0 DWORD dup :> max-value-data + 0 DWORD dup :> security-descriptor FILETIME 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 ] [ @@ -191,4 +191,4 @@ PRIVATE> 21 2^ 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 ; diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index cde6c11efb..4c6593f921 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -42,9 +42,9 @@ TUPLE: script-string < disposable font string metrics ssa size image ; f ! piDx f ! pTabdef f ! pbInClass - f ! pssa + f void* ! pssa [ ScriptStringAnalyse ] keep - [ ole32-error ] [ |ScriptStringFree *void* ] bi* ; + [ ole32-error ] [ |ScriptStringFree void* deref ] bi* ; : set-dc-colors ( dc font -- ) [ background>> color>RGB SetBkColor drop ] @@ -103,7 +103,7 @@ TUPLE: script-string < disposable font string metrics ssa size image ; PRIVATE> M: script-string dispose* - ssa>> ScriptStringFree ole32-error ; + ssa>> void* ScriptStringFree ole32-error ; SYMBOL: cached-script-strings diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor index 496b9d688c..319ca46714 100644 --- a/basis/x11/clipboard/clipboard.factor +++ b/basis/x11/clipboard/clipboard.factor @@ -1,7 +1,7 @@ ! 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 @@ -28,11 +28,11 @@ TUPLE: x-clipboard atom contents ; 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 0 0 0 f + 0 Atom 0 int 0 ulong 0 ulong f void* [ XGetWindowProperty drop ] keep snarf-property ; : selection-from-event ( event window -- string ) @@ -53,7 +53,7 @@ TUPLE: x-clipboard atom contents ; [ dpy get ] dip [ requestor>> ] [ property>> XA_TIMESTAMP 32 PropModeReplace ] - [ time>> ] tri + [ time>> int ] tri 1 XChangeProperty drop ; : send-notify ( evt prop -- ) diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index 1becb30f45..72c0670482 100644 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -1,8 +1,8 @@ ! 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 @@ -79,7 +79,7 @@ CONSTANT: event-mask dpy get swap XDestroyWindow drop ; : set-closable ( win -- ) - dpy get swap XA_WM_DELETE_WINDOW 1 + dpy get swap XA_WM_DELETE_WINDOW Atom 1 XSetWMProtocols drop ; : map-window ( win -- ) dpy get swap XMapWindow drop ; diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor index 06add388b1..b9248bac05 100644 --- a/basis/x11/xim/xim.factor +++ b/basis/x11/xim/xim.factor @@ -1,8 +1,8 @@ ! 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 @@ -42,7 +42,7 @@ SYMBOL: keysym : prepare-lookup ( -- ) buf-size keybuf set - 0 keysym set ; + 0 KeySym keysym set ; : finish-lookup ( len -- string keysym ) keybuf get swap 2 * head utf16n decode @@ -51,7 +51,7 @@ SYMBOL: keysym : lookup-string ( event xic -- string keysym ) [ prepare-lookup - swap keybuf get buf-size keysym get 0 + swap keybuf get buf-size keysym get 0 int XwcLookupString finish-lookup ] with-scope ; diff --git a/basis/x11/xinput2/xinput2.factor b/basis/x11/xinput2/xinput2.factor index 80aaf95d63..5e38d70cb6 100644 --- a/basis/x11/xinput2/xinput2.factor +++ b/basis/x11/xinput2/xinput2.factor @@ -1,11 +1,11 @@ ! 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 [ ] bi@ + 2 0 [ int ] bi@ XIQueryVersion { { BadRequest [ f ] } diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index e20314bf11..33293746c5 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -48,17 +48,11 @@ TYPEDEF: int Bool TYPEDEF: ulong VisualID TYPEDEF: ulong Time -ALIAS: -ALIAS: -ALIAS: -ALIAS: -ALIAS: - -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 ! diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 2439f03aac..9fee74897c 100644 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -298,6 +298,10 @@ HELP: assoc-all? { $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" } "." } ; diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 58a2a29eb1..0508d2e569 100644 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -117,7 +117,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) [ 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* ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 8e3af26932..90b48c6a37 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -491,7 +491,6 @@ tuple { "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 )) } diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor index f913ca5fec..c4c65c6209 100644 --- a/core/classes/algebra/algebra-docs.factor +++ b/core/classes/algebra/algebra-docs.factor @@ -50,7 +50,7 @@ HELP: class<= { $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" } "." } ; HELP: sort-classes -{ $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } } +{ $values { "seq" "a sequence of class" } { "newseq" "a new sequence of classes" } } { $description "Outputs a linear sort of a sequence of classes. Larger classes come before their subclasses." } ; HELP: class-or diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 037ecf8715..7443e02cc5 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -190,7 +190,7 @@ $nl { $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" } ; @@ -215,12 +215,14 @@ ARTICLE: "tuple-examples" "Tuple examples" { $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 new ;" } +{ $code + ": ( -- employee )" + " employee new ;" +} "Or we may wish the default constructor to always give employees a starting salary:" { $code ": ( -- employee )" diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 67bf6da23c..23ead78d94 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -150,7 +150,7 @@ $nl { $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." @@ -253,7 +253,7 @@ HELP: execute-effect-unsafe { $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 @@ -344,7 +344,7 @@ HELP: case { $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" } @@ -372,10 +372,10 @@ HELP: recursive-hashcode 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 } } diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index dfecf75f90..300c9c63bc 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -131,7 +131,7 @@ HELP: >continuation< 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 diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor index db33aaa244..44d216f872 100644 --- a/core/effects/effects-docs.factor +++ b/core/effects/effects-docs.factor @@ -19,7 +19,7 @@ $nl "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" } diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 8d4f1f61a5..c9673a95b8 100644 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -129,7 +129,7 @@ HELP: define-generic 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 } } } diff --git a/core/hash-sets/hash-sets.factor b/core/hash-sets/hash-sets.factor index ac198a2ca2..028c324f6a 100644 --- a/core/hash-sets/hash-sets.factor +++ b/core/hash-sets/hash-sets.factor @@ -19,6 +19,7 @@ M: hash-set members table>> keys ; inline M: hash-set set-like drop dup hash-set? [ members ] 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 ; M: f fast-set drop H{ } clone hash-set boa ; diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index be5aa97634..e7acf12454 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -151,10 +151,7 @@ M: hashtable clone (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 ; inline diff --git a/core/io/binary/binary-docs.factor b/core/io/binary/binary-docs.factor index 1339cc6090..443de70132 100644 --- a/core/io/binary/binary-docs.factor +++ b/core/io/binary/binary-docs.factor @@ -6,7 +6,7 @@ ARTICLE: "stream-binary" "Working with binary data" $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" } } diff --git a/core/io/encodings/utf16n/utf16n-tests.factor b/core/io/encodings/utf16n/utf16n-tests.factor index 9f3f35ff2a..96c4c29265 100644 --- a/core/io/encodings/utf16n/utf16n-tests.factor +++ b/core/io/encodings/utf16n/utf16n-tests.factor @@ -1,4 +1,4 @@ -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 diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 11848cfa03..86f27f5186 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -12,7 +12,7 @@ ARTICLE: "stream-types" "Binary and text streams" $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" } "." ; @@ -89,7 +89,7 @@ $io-error ; 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 @@ -112,21 +112,21 @@ HELP: stream-seek 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." } ; @@ -203,19 +203,19 @@ $io-error ; 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 @@ -224,12 +224,12 @@ HELP: with-streams* 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 @@ -262,6 +262,18 @@ HELP: contents { $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 @@ -290,6 +302,8 @@ $nl { $subsections stream-tell stream-seek + tell-input + tell-output } { $see-also "io.timeouts" } ; @@ -370,12 +384,6 @@ $nl } "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 diff --git a/core/io/pathnames/pathnames-docs.factor b/core/io/pathnames/pathnames-docs.factor index cc637b59c3..a3b9338978 100644 --- a/core/io/pathnames/pathnames-docs.factor +++ b/core/io/pathnames/pathnames-docs.factor @@ -106,7 +106,7 @@ HELP: absolute-path { "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 diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 8d63dfdf54..3412ec767e 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -242,7 +242,7 @@ HELP: bi "[ p ] [ q ] bi" "[ p ] keep q" } - + } ; HELP: 2bi @@ -512,7 +512,7 @@ HELP: bi-curry* "[ 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* @@ -682,7 +682,7 @@ HELP: die { $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" } } ; @@ -763,7 +763,7 @@ HELP: with { $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 diff --git a/core/math/floats/floats-tests.factor b/core/math/floats/floats-tests.factor index 84f993c5ac..3893e0cc9f 100644 --- a/core/math/floats/floats-tests.factor +++ b/core/math/floats/floats-tests.factor @@ -62,6 +62,21 @@ unit-test [ 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 diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index 45fce36ee6..49e5ec30cc 100644 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -7,9 +7,6 @@ IN: math.floats.private : 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 diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index 6f57b06658..178bb544c1 100644 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -216,8 +216,8 @@ unit-test : 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 [ @@ -232,5 +232,20 @@ unit-test [ 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 diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 4dd948021a..940ffa65ac 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -14,6 +14,7 @@ M: integer denominator drop 1 ; inline 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 @@ -37,16 +38,6 @@ M: fixnum - fixnum- ; 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 @@ -130,33 +121,49 @@ M: bignum (log2) bignum-log2 ; 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/f ; +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 >float bignum>float ; inline diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 1de443b0c5..079fa56acd 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -124,9 +124,9 @@ HELP: mod { $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" } "." } } } @@ -136,9 +136,9 @@ HELP: /mod { $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" } ; @@ -213,10 +213,10 @@ HELP: rem { $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 } ; @@ -244,7 +244,7 @@ HELP: 2/ 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" } } @@ -421,7 +421,7 @@ HELP: all-integers? 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 diff --git a/core/math/math.factor b/core/math/math.factor index bc7658feba..e8f2813a95 100644 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -59,11 +59,7 @@ PRIVATE> 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 @@ -74,8 +70,8 @@ ERROR: log2-expects-positive x ; : ?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 diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 6889f497e1..24ddc0b7c9 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -56,7 +56,7 @@ ARTICLE: "parsing-tokens" "Parsing raw tokens" "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 @@ -215,7 +215,7 @@ HELP: parse-fresh { $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 diff --git a/core/sbufs/sbufs-docs.factor b/core/sbufs/sbufs-docs.factor index c1f48d661b..fa2db15aad 100644 --- a/core/sbufs/sbufs-docs.factor +++ b/core/sbufs/sbufs-docs.factor @@ -5,7 +5,7 @@ IN: sbufs 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 diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index ed0f4b16b0..12d6813ebd 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -15,7 +15,7 @@ HELP: length 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 @@ -45,7 +45,7 @@ HELP: nths { "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\" }" @@ -243,12 +243,12 @@ HELP: array-capacity { $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." } ; @@ -430,7 +430,7 @@ HELP: all? 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 @@ -557,7 +557,7 @@ HELP: append! 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 }" } } ; @@ -713,7 +713,7 @@ HELP: append { $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 }" @@ -728,7 +728,7 @@ HELP: append-as { $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 }" @@ -872,7 +872,7 @@ HELP: tail* 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" } } @@ -992,7 +992,7 @@ HELP: selector { $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 }" @@ -1004,7 +1004,7 @@ HELP: trim-head { "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 }" } ; @@ -1014,7 +1014,7 @@ HELP: trim-head-slice { "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 } } }" } ; @@ -1024,7 +1024,7 @@ HELP: trim-tail { "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 }" } ; @@ -1034,7 +1034,7 @@ HELP: trim-tail-slice { "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 } } }" } ; @@ -1044,7 +1044,7 @@ HELP: trim { "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 }" } ; @@ -1054,7 +1054,7 @@ HELP: trim-slice { "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 } } }" } ; @@ -1065,8 +1065,8 @@ HELP: sift { $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 { } }" @@ -1078,7 +1078,7 @@ HELP: harvest { "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 } }" @@ -1091,9 +1091,9 @@ HELP: set-first { $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 }" } } ; @@ -1102,9 +1102,9 @@ HELP: set-second { $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 }" } } ; @@ -1113,9 +1113,9 @@ HELP: set-third { $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 }" } } ; @@ -1124,9 +1124,9 @@ HELP: set-fourth { $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 }" } } ; @@ -1138,7 +1138,7 @@ HELP: replicate { "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 }" @@ -1150,7 +1150,7 @@ HELP: replicate-as { "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 }" @@ -1163,8 +1163,8 @@ HELP: partition { $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 }" @@ -1198,7 +1198,7 @@ HELP: 2selector { $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 @@ -1235,7 +1235,7 @@ HELP: follow { $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 ;" @@ -1293,7 +1293,7 @@ HELP: new-like 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 @@ -1343,10 +1343,9 @@ HELP: assert-sequence= { $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=" - "" } } ; diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index bf2b6904c3..5197e57ad0 100644 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -18,6 +18,8 @@ ARTICLE: "set-operations" "Operations on sets" { $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 @@ -184,3 +186,7 @@ HELP: without 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." } ; diff --git a/core/sets/sets-tests.factor b/core/sets/sets-tests.factor index 9a48acc4cf..df6185671c 100644 --- a/core/sets/sets-tests.factor +++ b/core/sets/sets-tests.factor @@ -3,15 +3,19 @@ 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 @@ -64,3 +68,9 @@ IN: sets.tests [ 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 diff --git a/core/sets/sets.factor b/core/sets/sets.factor index 9c1870aa2e..06f6e04655 100644 --- a/core/sets/sets.factor +++ b/core/sets/sets.factor @@ -22,12 +22,17 @@ GENERIC: set= ( set1 set2 -- ? ) 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 @@ -41,22 +46,25 @@ 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 ; @@ -94,10 +102,13 @@ M: sequence set-like 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 ] diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor index cb1e5e6017..fc99b7afd1 100644 --- a/core/source-files/source-files-docs.factor +++ b/core/source-files/source-files-docs.factor @@ -39,7 +39,7 @@ HELP: source-file 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 diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 7e5c301711..c2ba53f1b6 100644 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -55,7 +55,7 @@ PRIVATE> 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>" } } ; @@ -727,7 +728,7 @@ HELP: HOOK: "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" diff --git a/core/vocabs/parser/parser-docs.factor b/core/vocabs/parser/parser-docs.factor index 66900978a8..9f60f79047 100644 --- a/core/vocabs/parser/parser-docs.factor +++ b/core/vocabs/parser/parser-docs.factor @@ -1,7 +1,7 @@ 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." @@ -142,7 +142,7 @@ HELP: add-words-from 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 diff --git a/core/vocabs/vocabs-docs.factor b/core/vocabs/vocabs-docs.factor index 3f8a71e76c..b2cb422178 100644 --- a/core/vocabs/vocabs-docs.factor +++ b/core/vocabs/vocabs-docs.factor @@ -77,7 +77,7 @@ HELP: forget-vocab { $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" } } diff --git a/extra/alien/cxx/demangle/libstdcxx/libstdcxx.factor b/extra/alien/cxx/demangle/libstdcxx/libstdcxx.factor index 403015bad5..ae727ac370 100644 --- a/extra/alien/cxx/demangle/libstdcxx/libstdcxx.factor +++ b/extra/alien/cxx/demangle/libstdcxx/libstdcxx.factor @@ -1,7 +1,7 @@ ! (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 ) ; @@ -22,9 +22,9 @@ ERROR: invalid-demangle-args name ; "_Z" head? ; :: demangle ( mangled-name -- c++-name ) - 0 :> length - 0 :> status [ + 0 ulong :> length + 0 int :> 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 ; diff --git a/extra/audio/engine/engine.factor b/extra/audio/engine/engine.factor index d7079c4aaa..9932953822 100644 --- a/extra/audio/engine/engine.factor +++ b/extra/audio/engine/engine.factor @@ -1,8 +1,8 @@ ! (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 @@ -122,7 +122,7 @@ ERROR: audio-context-not-available device-name ; :: flush-source ( al-source -- ) al-source alSourceStop - 0 c: :> dummy-buffer + 0 c:uint :> dummy-buffer al-source AL_BUFFERS_PROCESSED get-source-param [ al-source 1 dummy-buffer alSourceUnqueueBuffers ] times @@ -161,7 +161,7 @@ ERROR: audio-context-not-available device-name ; audio-clip t >>done? drop ] [ al-buffer audio-clip openal-format data size audio-clip sample-rate>> alBufferData - al-source 1 al-buffer c: alSourceQueueBuffers + al-source 1 al-buffer c:uint alSourceQueueBuffers ] if ] unless ; @@ -190,10 +190,10 @@ M: static-audio-clip (update-audio-clip) M:: streaming-audio-clip (update-audio-clip) ( audio-clip -- ) audio-clip al-source>> :> al-source - 0 c: :> buffer + 0 c:uint :> 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 -- ) @@ -256,7 +256,7 @@ M: audio-engine dispose* audio-engine get-available-source :> al-source al-source [ - 1 0 c: [ alGenBuffers ] keep c:*uint :> al-buffer + 1 0 c:uint [ alGenBuffers ] keep c:uint deref :> al-buffer al-buffer audio { [ openal-format ] [ data>> ] [ size>> ] [ sample-rate>> ] } cleave alBufferData @@ -301,7 +301,7 @@ M: audio-clip dispose* M: static-audio-clip dispose* [ call-next-method ] - [ [ 1 ] dip al-buffer>> c: alDeleteBuffers ] bi ; + [ [ 1 ] dip al-buffer>> c:uint alDeleteBuffers ] bi ; M: streaming-audio-clip dispose* [ call-next-method ] diff --git a/extra/audio/vorbis/vorbis.factor b/extra/audio/vorbis/vorbis.factor index e67c7b7934..2ae957812e 100644 --- a/extra/audio/vorbis/vorbis.factor +++ b/extra/audio/vorbis/vorbis.factor @@ -1,9 +1,9 @@ ! (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 @@ -157,7 +157,7 @@ ERROR: no-vorbis-in-ogg ; [ init-vorbis-codec ] if ; : get-pending-decoded-audio ( vorbis-stream -- pcm len ) - dsp-state>> f [ vorbis_synthesis_pcmout ] keep *void* swap ; + dsp-state>> f void* [ vorbis_synthesis_pcmout ] keep void* deref swap ; : float>short-sample ( float -- short ) -32767.5 * 0.5 - >integer -32768 32767 clamp ; inline diff --git a/extra/benchmark/ui-panes/deploy.factor b/extra/benchmark/ui-panes/deploy.factor new file mode 100644 index 0000000000..90bd34bd3a --- /dev/null +++ b/extra/benchmark/ui-panes/deploy.factor @@ -0,0 +1,15 @@ +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" } +} diff --git a/extra/benchmark/ui-panes/ui-panes.factor b/extra/benchmark/ui-panes/ui-panes.factor index 9d16f75e15..f50a966218 100644 --- a/extra/benchmark/ui-panes/ui-panes.factor +++ b/extra/benchmark/ui-panes/ui-panes.factor @@ -1,7 +1,7 @@ -USING: ui.gadgets.panes prettyprint io sequences ; +USING: io kernel math.parser sequences ui.gadgets.panes ; IN: benchmark.ui-panes : ui-pane-benchmark ( -- ) - [ 10000 iota [ . ] each ] with-output-stream* ; + [ 10000 iota [ number>string print ] each ] make-pane drop ; MAIN: ui-pane-benchmark diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index cfe95956c0..0f22b531c6 100644 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -42,7 +42,7 @@ IN: bunny.model : 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? [ diff --git a/extra/central/authors.txt b/extra/central/authors.txt deleted file mode 100644 index 5645cd91bd..0000000000 --- a/extra/central/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Matthew Willis diff --git a/extra/central/central-docs.factor b/extra/central/central-docs.factor deleted file mode 100644 index 458f528c53..0000000000 --- a/extra/central/central-docs.factor +++ /dev/null @@ -1,16 +0,0 @@ -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 diff --git a/extra/central/central-tests.factor b/extra/central/central-tests.factor deleted file mode 100644 index 17c5ee901f..0000000000 --- a/extra/central/central-tests.factor +++ /dev/null @@ -1,19 +0,0 @@ -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 diff --git a/extra/central/central.factor b/extra/central/central.factor deleted file mode 100644 index f7175141dd..0000000000 --- a/extra/central/central.factor +++ /dev/null @@ -1,28 +0,0 @@ -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 diff --git a/extra/central/tags.txt b/extra/central/tags.txt deleted file mode 100644 index f4274299b1..0000000000 --- a/extra/central/tags.txt +++ /dev/null @@ -1 +0,0 @@ -extensions diff --git a/extra/cuda/contexts/contexts.factor b/extra/cuda/contexts/contexts.factor index 7a9ab59a6a..5218f7b23e 100644 --- a/extra/cuda/contexts/contexts.factor +++ b/extra/cuda/contexts/contexts.factor @@ -9,14 +9,14 @@ IN: cuda.contexts : create-context ( device flags -- context ) swap - [ CUcontext ] 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 [ cuCtxGetDevice cuda-error ] keep *int ; inline + { CUdevice } [ cuCtxGetDevice cuda-error ] with-out-parameters ; inline : destroy-context ( context -- ) cuCtxDestroy cuda-error ; inline diff --git a/extra/cuda/cuda.factor b/extra/cuda/cuda.factor index 2e2cdd660f..c86fbacc69 100644 --- a/extra/cuda/cuda.factor +++ b/extra/cuda/cuda.factor @@ -16,7 +16,7 @@ TUPLE: cuda-error code ; dup CUDA_SUCCESS = [ drop ] [ \ cuda-error boa throw ] if ; : cuda-version ( -- n ) - c:int [ cuDriverGetVersion cuda-error ] keep c:*int ; + { c:int } [ cuDriverGetVersion cuda-error ] with-out-parameters ; : init-cuda ( -- ) 0 cuInit cuda-error ; inline diff --git a/extra/cuda/devices/devices.factor b/extra/cuda/devices/devices.factor index 4e7a50e6f2..079234b2ee 100644 --- a/extra/cuda/devices/devices.factor +++ b/extra/cuda/devices/devices.factor @@ -8,10 +8,10 @@ prettyprint sequences ; IN: cuda.devices : #cuda-devices ( -- n ) - int [ cuDeviceGetCount cuda-error ] keep *int ; + { int } [ cuDeviceGetCount cuda-error ] with-out-parameters ; : n>cuda-device ( n -- device ) - [ CUdevice ] 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 ; @@ -32,19 +32,17 @@ IN: cuda.devices [ 2drop utf8 alien>string ] 3bi ; : cuda-device-capability ( n -- pair ) - [ int int ] 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 ] dip - [ cuDeviceTotalMem cuda-error ] - [ drop *uint ] 2bi ; + [ { uint } ] dip + '[ _ cuDeviceTotalMem cuda-error ] with-out-parameters ; : cuda-device-attribute ( attribute n -- n ) - [ int ] 2dip - [ cuDeviceGetAttribute cuda-error ] - [ 2drop *int ] 3bi ; + [ { int } ] 2dip + '[ _ _ cuDeviceGetAttribute cuda-error ] with-out-parameters ; : cuda-device. ( n -- ) { diff --git a/extra/cuda/gl/gl.factor b/extra/cuda/gl/gl.factor index d4943e1350..e4e093c1e9 100644 --- a/extra/cuda/gl/gl.factor +++ b/extra/cuda/gl/gl.factor @@ -6,29 +6,29 @@ IN: cuda.gl : create-gl-cuda-context ( device flags -- context ) swap - [ CUcontext ] 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 ] 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 f cuGraphicsMapResources cuda-error ] [ - [ CUdeviceptr uint ] dip - [ cuGraphicsResourceGetMappedPointer cuda-error ] 3keep drop - [ *uint ] [ *uint ] bi* + [ 1 swap void* f cuGraphicsMapResources cuda-error ] [ + [ { CUdeviceptr uint } ] dip + '[ _ cuGraphicsResourceGetMappedPointer cuda-error ] + with-out-parameters ] bi ; inline : unmap-resource ( resource -- ) - 1 swap f cuGraphicsUnmapResources cuda-error ; inline + 1 swap void* f cuGraphicsUnmapResources cuda-error ; inline DESTRUCTOR: unmap-resource diff --git a/extra/cuda/libraries/libraries.factor b/extra/cuda/libraries/libraries.factor index e930745a17..faf50bb39b 100644 --- a/extra/cuda/libraries/libraries.factor +++ b/extra/cuda/libraries/libraries.factor @@ -74,8 +74,8 @@ M: sequence grid-dim PRIVATE> : load-module ( path -- module ) - [ CUmodule ] dip - [ cuModuleLoad cuda-error ] 2keep drop c:*void* ; + [ { CUmodule } ] dip + '[ _ cuModuleLoad cuda-error ] with-out-parameters ; : unload-module ( module -- ) cuModuleUnload cuda-error ; @@ -151,8 +151,8 @@ MACRO: cuda-arguments ( c-types abi -- quot: ( args... function -- ) ) [ [ 0 cuda-param-size ] ] swap '[ _ [cuda-arguments] ] if-empty ; : get-function-ptr ( module string -- function ) - [ CUfunction ] 2dip - [ cuModuleGetFunction cuda-error ] 3keep 2drop c:*void* ; + [ { CUfunction } ] 2dip + '[ _ _ cuModuleGetFunction cuda-error ] with-out-parameters ; : cached-module ( module-name -- alien ) lookup-cuda-library @@ -170,9 +170,9 @@ MACRO: cuda-invoke ( module-name function-name arguments -- ) ] ; : cuda-global* ( module-name symbol-name -- device-ptr size ) - [ CUdeviceptr c:uint ] 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 diff --git a/extra/cuda/memory/memory.factor b/extra/cuda/memory/memory.factor index f3c452093a..2369851292 100644 --- a/extra/cuda/memory/memory.factor +++ b/extra/cuda/memory/memory.factor @@ -8,9 +8,8 @@ QUALIFIED-WITH: alien.c-types c IN: cuda.memory : cuda-malloc ( n -- ptr ) - [ CUdeviceptr ] 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 diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index 61bdebfedd..a0e6ba5f6e 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -1,28 +1,15 @@ ! 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 @@ -59,17 +46,6 @@ SYMBOL: dns-servers : 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 ; @@ -172,7 +148,8 @@ CONSTANT: ipv4-arpa-suffix ".in-addr.arpa" 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 ; @@ -190,21 +167,21 @@ CONSTANT: ipv6-arpa-suffix ".ip6.arpa" 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 ) @@ -246,7 +223,7 @@ M: SOA parse-rdata 2drop parse-soa ; 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 @@ -261,12 +238,12 @@ M: SOA parse-rdata 2drop parse-soa ; [ [ 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 ] @@ -309,7 +286,7 @@ M: SOA rdata>byte-array } cleave ] B{ } append-outputs-as ; -: rr>byte-array ( rr -- ba ) +: rr>byte-array ( rr -- byte-array ) [ { [ name>> >name ] @@ -323,7 +300,7 @@ M: SOA rdata>byte-array } cleave ] B{ } append-outputs-as ; -: message>byte-array ( message -- ba ) +: message>byte-array ( message -- byte-array ) [ { [ id>> 2 >be ] @@ -341,7 +318,7 @@ M: SOA rdata>byte-array : udp-query ( bytes server -- bytes' ) f 0 - 5 seconds over set-timeout [ + 30 seconds over set-timeout [ [ send ] [ receive drop ] bi ] with-disposal ; @@ -369,6 +346,10 @@ M: SOA rdata>byte-array : 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 ; @@ -387,22 +368,21 @@ M: SOA rdata>byte-array : message>query-name ( message -- string ) query>> first name>> dotted> ; -: a-line. ( host ip -- ) - [ write " has address " write ] [ print ] bi* ; +USE: nested-comments +(* +M: string resolve-host + dup >lower "localhost" = [ + drop resolve-localhost + ] [ + dns-A-query message>a-names [ ] map + ] if ; +*) + +HOOK: initial-dns-servers os ( -- sequence ) -: 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 ; +{ + { [ os windows? ] [ "dns.windows" ] } + { [ os unix? ] [ "dns.unix" ] } +} cond require + +dns-servers [ initial-dns-servers >vector ] initialize diff --git a/extra/dns/unix/authors.txt b/extra/dns/unix/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/dns/unix/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/dns/unix/platforms.txt b/extra/dns/unix/platforms.txt new file mode 100644 index 0000000000..509143d863 --- /dev/null +++ b/extra/dns/unix/platforms.txt @@ -0,0 +1 @@ +unix diff --git a/extra/dns/unix/unix.factor b/extra/dns/unix/unix.factor new file mode 100644 index 0000000000..31af530f5c --- /dev/null +++ b/extra/dns/unix/unix.factor @@ -0,0 +1,7 @@ +! 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>> ; diff --git a/extra/dns/windows/authors.txt b/extra/dns/windows/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/dns/windows/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/dns/windows/platforms.txt b/extra/dns/windows/platforms.txt new file mode 100644 index 0000000000..8e1a55995e --- /dev/null +++ b/extra/dns/windows/platforms.txt @@ -0,0 +1 @@ +windows diff --git a/extra/dns/windows/windows.factor b/extra/dns/windows/windows.factor new file mode 100644 index 0000000000..a43eede183 --- /dev/null +++ b/extra/dns/windows/windows.factor @@ -0,0 +1,6 @@ +! 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 diff --git a/extra/ecdsa/ecdsa.factor b/extra/ecdsa/ecdsa.factor index 547b7b9ae9..74fdad63ea 100644 --- a/extra/ecdsa/ecdsa.factor +++ b/extra/ecdsa/ecdsa.factor @@ -67,9 +67,9 @@ PRIVATE> :: ecdsa-sign ( DGST -- sig ) ec-key-handle :> KEY KEY ECDSA_size dup ssl-error :> SIG - 0 :> LEN + 0 uint :> 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 > ; diff --git a/extra/game/loop/loop.factor b/extra/game/loop/loop.factor old mode 100644 new mode 100755 index 1bdcece936..fa9d17eb0f --- a/extra/game/loop/loop.factor +++ b/extra/game/loop/loop.factor @@ -2,7 +2,7 @@ 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 diff --git a/extra/gpu/buffers/buffers.factor b/extra/gpu/buffers/buffers.factor index 6172c8ad8c..9ea08a7c83 100644 --- a/extra/gpu/buffers/buffers.factor +++ b/extra/gpu/buffers/buffers.factor @@ -57,7 +57,7 @@ TUPLE: buffer < gpu-object } case ; inline : get-buffer-int ( target enum -- value ) - 0 [ glGetBufferParameteriv ] keep *int ; inline + 0 int [ glGetBufferParameteriv ] keep int deref ; inline : bind-buffer ( buffer -- target ) [ kind>> gl-target dup ] [ handle>> glBindBuffer ] bi ; inline diff --git a/extra/gpu/demos/bunny/bunny.factor b/extra/gpu/demos/bunny/bunny.factor index f29e12c1a2..0491191c63 100644 --- a/extra/gpu/demos/bunny/bunny.factor +++ b/extra/gpu/demos/bunny/bunny.factor @@ -145,7 +145,7 @@ UNIFORM-TUPLE: loading-uniforms : 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? [ diff --git a/extra/gpu/framebuffers/framebuffers.factor b/extra/gpu/framebuffers/framebuffers.factor index 1aa9ae33df..9a594c1cd0 100644 --- a/extra/gpu/framebuffers/framebuffers.factor +++ b/extra/gpu/framebuffers/framebuffers.factor @@ -1,8 +1,8 @@ ! (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 @@ -18,7 +18,8 @@ TUPLE: renderbuffer < gpu-object [ glGetRenderbufferParameteriv ] keep *int ; + GL_RENDERBUFFER swap 0 int + [ glGetRenderbufferParameteriv ] keep int deref ; PRIVATE> diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor index d1c137128a..b032004d40 100755 --- a/extra/gpu/shaders/shaders.factor +++ b/extra/gpu/shaders/shaders.factor @@ -199,7 +199,7 @@ TR: hyphens>underscores "-" "_" ; name length 1 + :> name-buffer-length { index name-buffer-length dup - [ f 0 0 ] dip + [ f 0 int 0 int ] dip [ glGetTransformFeedbackVarying ] 3keep ascii alien>string vertex-attribute assert-feedback-attribute diff --git a/extra/gpu/state/state.factor b/extra/gpu/state/state.factor index db76774038..31a8678060 100755 --- a/extra/gpu/state/state.factor +++ b/extra/gpu/state/state.factor @@ -416,11 +416,11 @@ M: mask-state set-gpu-state* [ set-gpu-state* ] if ; inline : get-gl-bool ( enum -- value ) - 0 [ glGetBooleanv ] keep *uchar c-bool> ; + 0 uchar [ glGetBooleanv ] keep uchar deref c-bool> ; : get-gl-int ( enum -- value ) - 0 [ glGetIntegerv ] keep *int ; + 0 int [ glGetIntegerv ] keep int deref ; : get-gl-float ( enum -- value ) - 0 [ glGetFloatv ] keep *float ; + 0 c:float [ glGetFloatv ] keep c:float deref ; : get-gl-bools ( enum count -- value ) [ glGetBooleanv ] keep [ c-bool> ] { } map-as ; diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index c67a03cbfc..d9ae88675a 100644 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -171,8 +171,8 @@ ERROR: undefined-find-nth m n seq quot ; [ [ 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 ; diff --git a/extra/images/gif/gif.factor b/extra/images/gif/gif.factor index c72f06f139..b06210fc00 100644 --- a/extra/images/gif/gif.factor +++ b/extra/images/gif/gif.factor @@ -3,7 +3,7 @@ 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 @@ -74,14 +74,6 @@ CONSTANT: block-terminator HEX: 00 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 ; diff --git a/extra/javascriptcore/javascriptcore.factor b/extra/javascriptcore/javascriptcore.factor index 738f1749bc..e3465a324b 100644 --- a/extra/javascriptcore/javascriptcore.factor +++ b/extra/javascriptcore/javascriptcore.factor @@ -37,8 +37,8 @@ SYMBOL: js-context : eval-js ( string -- result-string ) [ js-context get dup ] dip - JSStringCreateWithUTF8CString f f 0 JSValueRef - [ 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 ) diff --git a/extra/llvm/jit/jit.factor b/extra/llvm/jit/jit.factor index fc755fd00f..eb3bebe819 100644 --- a/extra/llvm/jit/jit.factor +++ b/extra/llvm/jit/jit.factor @@ -1,7 +1,8 @@ ! 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 @@ -25,9 +26,9 @@ TUPLE: jit ee mps ; LLVMGetFirstFunction dup ALIEN: 0 = [ drop ] [ (remove-functions) ] if ; : remove-provider ( provider -- ) - current-jit ee>> value>> swap value>> f f - [ LLVMRemoveModuleProvider drop ] 2keep *void* [ llvm-throw ] when* - *void* module new swap >>value + current-jit ee>> value>> swap value>> f void* f void* + [ LLVMRemoveModuleProvider drop ] 2keep void* deref [ llvm-throw ] when* + void* deref module new swap >>value [ value>> remove-functions ] with-disposal ; : remove-module ( name -- ) @@ -44,5 +45,5 @@ TUPLE: jit ee mps ; : function-pointer ( name -- alien ) current-jit ee>> value>> dup - rot f [ LLVMFindFunction drop ] keep - *void* LLVMGetPointerToGlobal ; \ No newline at end of file + rot f void* [ LLVMFindFunction drop ] keep + void* deref LLVMGetPointerToGlobal ; diff --git a/extra/llvm/reader/reader.factor b/extra/llvm/reader/reader.factor index 8c324b41e4..90cf36f955 100644 --- a/extra/llvm/reader/reader.factor +++ b/extra/llvm/reader/reader.factor @@ -1,15 +1,16 @@ ! 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 f + value>> f void* f void* [ LLVMParseBitcode drop ] 2keep - *void* [ llvm-throw ] when* *void* + void* deref [ llvm-throw ] when* void* deref module new swap >>value ] with-disposal ; @@ -17,4 +18,4 @@ IN: llvm.reader buffer>module ; : load-into-jit ( path name -- ) - [ load-module ] dip add-module ; \ No newline at end of file + [ load-module ] dip add-module ; diff --git a/extra/llvm/wrappers/wrappers.factor b/extra/llvm/wrappers/wrappers.factor index 05aafce973..27c8a0592a 100644 --- a/extra/llvm/wrappers/wrappers.factor +++ b/extra/llvm/wrappers/wrappers.factor @@ -1,6 +1,6 @@ ! 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 ; @@ -33,9 +33,9 @@ M: engine dispose* value>> LLVMDisposeExecutionEngine ; : (engine) ( provider -- engine ) [ - value>> f f + value>> f void* f void* [ swapd 0 swap LLVMCreateJITCompiler drop ] 2keep - *void* [ llvm-throw ] when* *void* + void* deref [ llvm-throw ] when* void* deref ] [ t >>disposed drop ] bi engine ; @@ -57,6 +57,6 @@ TUPLE: buffer value disposed ; M: buffer dispose* value>> LLVMDisposeMemoryBuffer ; : ( path -- module ) - f f + f void* f void* [ LLVMCreateMemoryBufferWithContentsOfFile drop ] 2keep - *void* [ llvm-throw ] when* *void* buffer ; \ No newline at end of file + void* deref [ llvm-throw ] when* void* deref buffer ; diff --git a/extra/math/finance/finance-tests.factor b/extra/math/finance/finance-tests.factor index fc4ad0d07e..eb4b238f61 100644 --- a/extra/math/finance/finance-tests.factor +++ b/extra/math/finance/finance-tests.factor @@ -2,6 +2,8 @@ USING: kernel math math.functions math.finance tools.test ; 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 diff --git a/extra/math/finance/finance.factor b/extra/math/finance/finance.factor index f1c608bad9..12f58c891b 100644 --- a/extra/math/finance/finance.factor +++ b/extra/math/finance/finance.factor @@ -15,7 +15,7 @@ IN: math.finance 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 ; diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index c6f1601955..6803dfa67b 100755 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -1,6 +1,9 @@ ! 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 ; diff --git a/extra/openal/alut/macosx/macosx.factor b/extra/openal/alut/macosx/macosx.factor index 54439b762c..ccc4238533 100755 --- a/extra/openal/alut/macosx/macosx.factor +++ b/extra/openal/alut/macosx/macosx.factor @@ -1,6 +1,6 @@ ! 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 @@ -9,6 +9,6 @@ LIBRARY: alut 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 f 0 0 + 0 int f void* 0 int 0 int [ alutLoadWAVFile ] 4 nkeep - [ [ [ *int ] dip *void* ] dip *int ] dip *int ; + [ [ [ int deref ] dip void* deref ] dip int deref ] dip int deref ; diff --git a/extra/openal/alut/other/other.factor b/extra/openal/alut/other/other.factor index 8b1cbd0cb3..8b446c3f5c 100755 --- a/extra/openal/alut/other/other.factor +++ b/extra/openal/alut/other/other.factor @@ -1,7 +1,7 @@ ! 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 @@ -9,6 +9,9 @@ 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 f 0 0 - [ 0 alutLoadWAVFile ] 4 nkeep - { [ *int ] [ *void* ] [ *int ] [ *int ] } spread ; + 0 int + f void* + 0 int + 0 int + [ 0 char alutLoadWAVFile ] 4 nkeep + { [ int deref ] [ void* deref ] [ int deref ] [ int deref ] } spread ; diff --git a/extra/openal/openal.factor b/extra/openal/openal.factor index 853b33b386..8f2d77b1e4 100755 --- a/extra/openal/openal.factor +++ b/extra/openal/openal.factor @@ -1,10 +1,11 @@ ! 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 @@ -264,13 +265,13 @@ DESTRUCTOR: alcDestroyContext alSourcei ; : get-source-param ( source param -- value ) - 0 dup [ alGetSourcei ] dip *uint ; + 0 uint dup [ alGetSourcei ] dip uint deref ; : set-buffer-param ( source param value -- ) alBufferi ; : get-buffer-param ( source param -- value ) - 0 dup [ alGetBufferi ] dip *uint ; + 0 uint dup [ alGetBufferi ] dip uint deref ; : source-play ( source -- ) alSourcePlay ; diff --git a/extra/opencl/ffi/ffi-tests.factor b/extra/opencl/ffi/ffi-tests.factor index 1ec96e4c76..60083a0b0a 100644 --- a/extra/opencl/ffi/ffi-tests.factor +++ b/extra/opencl/ffi/ffi-tests.factor @@ -29,33 +29,33 @@ ERROR: cl-error err ; str-alien str-buffer dup length memcpy str-alien ; :: opencl-square ( in -- out ) - 0 f 0 [ clGetPlatformIDs cl-success ] keep *uint + 0 f 0 uint [ clGetPlatformIDs cl-success ] keep uint deref dup [ f clGetPlatformIDs cl-success ] keep first - CL_DEVICE_TYPE_DEFAULT 1 f [ f clGetDeviceIDs cl-success ] keep *void* :> device-id - f 1 device-id f f 0 [ clCreateContext ] keep *int cl-success :> context - context device-id 0 0 [ clCreateCommandQueue ] keep *int cl-success :> queue + CL_DEVICE_TYPE_DEFAULT 1 f void* [ f clGetDeviceIDs cl-success ] keep void* deref :> device-id + f 1 device-id void* f f 0 int [ clCreateContext ] keep int deref cl-success :> context + context device-id 0 0 int [ clCreateCommandQueue ] keep int deref cl-success :> queue [ - context 1 kernel-source cl-string-array - f 0 [ clCreateProgramWithSource ] keep *int cl-success + context 1 kernel-source cl-string-array void* + f 0 int [ clCreateProgramWithSource ] keep int deref cl-success [ 0 f f f f clBuildProgram cl-success ] - [ "square" cl-string-array 0 [ clCreateKernel ] keep *int cl-success ] + [ "square" cl-string-array 0 int [ clCreateKernel ] keep int deref cl-success ] [ ] tri ] with-destructors :> ( kernel program ) context CL_MEM_READ_ONLY in byte-length f - 0 [ clCreateBuffer ] keep *int cl-success :> input + 0 int [ clCreateBuffer ] keep int deref cl-success :> input context CL_MEM_WRITE_ONLY in byte-length f - 0 [ clCreateBuffer ] keep *int cl-success :> output + 0 int [ 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 clSetKernelArg cl-success - kernel 1 cl_mem heap-size output clSetKernelArg cl-success - kernel 2 uint heap-size in length clSetKernelArg 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 - queue kernel 1 f in length f + queue kernel 1 f in length ulonglong f 0 f f clEnqueueNDRangeKernel cl-success queue clFinish cl-success diff --git a/extra/opencl/opencl-tests.factor b/extra/opencl/opencl-tests.factor index 6fd7bb581d..628a9b0d63 100644 --- a/extra/opencl/opencl-tests.factor +++ b/extra/opencl/opencl-tests.factor @@ -32,7 +32,7 @@ __kernel void square( cl-read-access num-bytes in &dispose :> in-buffer cl-write-access num-bytes f &dispose :> out-buffer - kernel in-buffer out-buffer num-floats 3array + kernel in-buffer out-buffer num-floats uint 3array { num-floats } [ ] cl-queue-kernel &dispose drop cl-finish diff --git a/extra/opencl/opencl.factor b/extra/opencl/opencl.factor index 17f0143ae1..01ceb4e88f 100644 --- a/extra/opencl/opencl.factor +++ b/extra/opencl/opencl.factor @@ -1,9 +1,10 @@ ! 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 ; @@ -17,7 +18,7 @@ ERROR: cl-error err ; dup f = [ cl-error ] [ drop ] if ; inline : info-data-size ( handle name info-quot -- size_t ) - [ 0 f 0 ] dip [ call cl-success ] 2keep drop *size_t ; inline + [ 0 f 0 ] dip [ call cl-success ] 2keep drop size_t deref ; inline : info-data-bytes ( handle name info-quot size -- bytes ) swap [ dup f ] dip [ call cl-success ] 3keep 2drop ; inline @@ -26,7 +27,7 @@ ERROR: cl-error err ; [ 3dup info-data-size info-data-bytes ] dip call ; inline : 2info-data-size ( handle1 handle2 name info-quot -- size_t ) - [ 0 f 0 ] dip [ call cl-success ] 2keep drop *size_t ; inline + [ 0 f 0 ] dip [ call cl-success ] 2keep drop size_t deref ; inline : 2info-data-bytes ( handle1 handle2 name info-quot size -- bytes ) swap [ dup f ] dip [ call cl-success ] 3keep 2drop ; inline @@ -35,22 +36,22 @@ ERROR: cl-error err ; [ 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 @@ -311,7 +312,7 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ; : platform-devices ( platform-id -- devices ) CL_DEVICE_TYPE_ALL [ - 0 f 0 [ clGetDeviceIDs cl-success ] keep *uint + 0 f 0 uint [ clGetDeviceIDs cl-success ] keep uint deref ] [ rot dup [ f clGetDeviceIDs cl-success ] keep ] 2bi ; inline @@ -340,7 +341,7 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ; [ length ] [ strings>char*-array ] [ [ length ] size_t-array{ } map-as ] tri - 0 [ clCreateProgramWithSource ] keep *int cl-success + 0 int [ clCreateProgramWithSource ] keep int deref cl-success ] with-destructors ; :: (build-program) ( program-handle device options -- program ) @@ -403,7 +404,7 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ; [ clGetEventProfilingInfo ] info-ulong ; : bind-kernel-arg-buffer ( kernel index buffer -- ) - [ handle>> ] [ cl_mem heap-size ] [ handle>> ] tri* + [ handle>> ] [ cl_mem heap-size ] [ handle>> void* deref ] tri* clSetKernelArg cl-success ; inline : bind-kernel-arg-data ( kernel index byte-array -- ) @@ -425,7 +426,7 @@ PRIVATE> ] dip bind ; inline : cl-platforms ( -- platforms ) - 0 f 0 [ clGetPlatformIDs cl-success ] keep *uint + 0 f 0 uint [ clGetPlatformIDs cl-success ] keep uint deref dup [ f clGetPlatformIDs cl-success ] keep [ dup @@ -437,14 +438,14 @@ PRIVATE> : ( devices -- cl-context ) [ f ] dip [ length ] [ [ id>> ] void*-array{ } map-as ] bi - f f 0 [ clCreateContext ] keep *int cl-success + f f 0 int [ clCreateContext ] keep int deref cl-success cl-context new-disposable swap >>handle ; : ( 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 [ clCreateCommandQueue ] keep *int cl-success + 0 int [ clCreateCommandQueue ] keep int deref cl-success cl-queue new-disposable swap >>handle ; : cl-out-of-order-execution? ( command-queue -- ? ) @@ -462,7 +463,7 @@ PRIVATE> [ buffer-access-constant ] [ [ CL_MEM_COPY_HOST_PTR ] [ CL_MEM_ALLOC_HOST_PTR ] if ] tri* bitor ] 2dip - 0 [ clCreateBuffer ] keep *int cl-success + 0 int [ clCreateBuffer ] keep int deref cl-success cl-buffer new-disposable swap >>handle ; : cl-read-buffer ( buffer-range -- byte-array ) @@ -488,7 +489,7 @@ PRIVATE> [ [ buffer>> handle>> ] [ offset>> ] bi ] tri* swapd ] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty - f [ clEnqueueCopyBuffer cl-success ] keep *void* cl-event + f void* [ clEnqueueCopyBuffer cl-success ] keep void* deref cl-event new-disposable swap >>handle ; : cl-queue-read-buffer ( buffer-range alien dependent-events -- event ) @@ -496,7 +497,7 @@ PRIVATE> [ (current-cl-queue) handle>> ] dip [ buffer>> handle>> CL_FALSE ] [ offset>> ] [ size>> ] tri ] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty - f [ clEnqueueReadBuffer cl-success ] keep *void* cl-event + f void* [ clEnqueueReadBuffer cl-success ] keep void* cl-event new-disposable swap >>handle ; : cl-queue-write-buffer ( buffer-range alien dependent-events -- event ) @@ -504,7 +505,7 @@ PRIVATE> [ (current-cl-queue) handle>> ] dip [ buffer>> handle>> CL_FALSE ] [ offset>> ] [ size>> ] tri ] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty - f [ clEnqueueWriteBuffer cl-success ] keep *void* cl-event + f void* [ clEnqueueWriteBuffer cl-success ] keep void* deref cl-event new-disposable swap >>handle ; : ( normalized-coords? addressing-mode filter-mode -- sampler ) @@ -512,7 +513,7 @@ PRIVATE> [ [ CL_TRUE ] [ CL_FALSE ] if ] [ addressing-mode-constant ] [ filter-mode-constant ] - tri* 0 [ clCreateSampler ] keep *int cl-success + tri* 0 int [ clCreateSampler ] keep int deref cl-success cl-sampler new-disposable swap >>handle ; : cl-normalized-coords? ( sampler -- ? ) @@ -531,7 +532,7 @@ PRIVATE> : ( program kernel-name -- kernel ) [ handle>> ] [ ascii encode 0 suffix ] bi* - 0 [ clCreateKernel ] keep *int cl-success + 0 int [ clCreateKernel ] keep int deref cl-success cl-kernel new-disposable swap >>handle ; inline : cl-kernel-name ( kernel -- string ) @@ -549,7 +550,7 @@ PRIVATE> 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 [ clEnqueueNDRangeKernel cl-success ] keep *void* + f void* [ clEnqueueNDRangeKernel cl-success ] keep void* deref cl-event new-disposable swap >>handle ; : cl-event-type ( event -- command-type ) @@ -573,7 +574,7 @@ PRIVATE> : cl-marker ( -- event ) (current-cl-queue) - f [ clEnqueueMarker cl-success ] keep *void* cl-event new-disposable + f void* [ clEnqueueMarker cl-success ] keep void* deref cl-event new-disposable swap >>handle ; inline : cl-barrier ( -- ) diff --git a/extra/path-finding/path-finding-docs.factor b/extra/path-finding/path-finding-docs.factor index 46f1048ba7..c282aa1dc0 100644 --- a/extra/path-finding/path-finding-docs.factor +++ b/extra/path-finding/path-finding-docs.factor @@ -1,9 +1,9 @@ ! 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 -{ } related-words +{ } related-words HELP: astar { $description "This tuple must be subclassed and its method " { $link cost } ", " @@ -45,7 +45,7 @@ HELP: { "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 " @@ -57,19 +57,31 @@ HELP: HELP: { $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: +{ $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" } } @@ -79,7 +91,7 @@ HELP: find-path 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 " diff --git a/extra/path-finding/path-finding-tests.factor b/extra/path-finding/path-finding-tests.factor index 11a047cb89..0e9b5289b1 100644 --- a/extra/path-finding/path-finding-tests.factor +++ b/extra/path-finding/path-finding-tests.factor @@ -120,3 +120,21 @@ MEMO: routes ( -- hash ) $[ { "ABD" "BC" "C" "DCE" "ECF" } [ unclip swap 2array [ f ] [ "FA" first2 routes find-path ] unit-test [ "DC" ] [ "DC" first2 routes 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 [ 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 diff --git a/extra/path-finding/path-finding.factor b/extra/path-finding/path-finding.factor index cd63a5c8d5..4b11616c20 100644 --- a/extra/path-finding/path-finding.factor +++ b/extra/path-finding/path-finding.factor @@ -74,6 +74,11 @@ M: bfs cost 3drop 1 ; 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 ) @@ -87,3 +92,6 @@ PRIVATE> : ( neighbours -- astar ) [ bfs new ] dip >>neighbours ; + +: ( costs -- astar ) + [ dijkstra new ] dip >>costs ; diff --git a/extra/project-euler/006/006.factor b/extra/project-euler/006/006.factor index 00a5c44771..c786c98c6c 100644 --- a/extra/project-euler/006/006.factor +++ b/extra/project-euler/006/006.factor @@ -15,7 +15,7 @@ IN: project-euler.006 ! (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. diff --git a/extra/resolv-conf/authors.txt b/extra/resolv-conf/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/resolv-conf/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/resolv-conf/resolv-conf.factor b/extra/resolv-conf/resolv-conf.factor new file mode 100644 index 0000000000..d8d370a02b --- /dev/null +++ b/extra/resolv-conf/resolv-conf.factor @@ -0,0 +1,97 @@ +! 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 ; + +> 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 ] 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 ) + [ ] 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 ; diff --git a/extra/resolv-conf/resolv-conf.test b/extra/resolv-conf/resolv-conf.test new file mode 100644 index 0000000000..1b17c3a70e --- /dev/null +++ b/extra/resolv-conf/resolv-conf.test @@ -0,0 +1,28 @@ +# +# 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 + + + + + + diff --git a/extra/tokyo/assoc-functor/assoc-functor.factor b/extra/tokyo/assoc-functor/assoc-functor.factor index de160f5598..acc1d7999f 100644 --- a/extra/tokyo/assoc-functor/assoc-functor.factor +++ b/extra/tokyo/assoc-functor/assoc-functor.factor @@ -1,7 +1,8 @@ ! 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 -- ) @@ -28,14 +29,14 @@ INSTANCE: TYPE assoc M: TYPE dispose* [ DBDEL f ] change-handle drop ; M: TYPE at* ( key db -- value/f ? ) - handle>> swap object>bytes dup length 0 + handle>> swap object>bytes dup length 0 int DBGET [ [ memory>object ] [ tcfree ] bi t ] [ f f ] if* ; M: TYPE assoc-size ( db -- size ) handle>> DBRNUM ; : DBKEYS ( db -- keys ) [ assoc-size ] [ handle>> ] bi - dup DBITERINIT drop 0 + dup DBITERINIT drop 0 int [ 2dup DBITERNEXT dup ] [ [ memory>object ] [ tcfree ] bi [ pick ] dip swap push diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor index 9b4819d3aa..68efbdd2b4 100644 --- a/extra/trees/avl/avl.factor +++ b/extra/trees/avl/avl.factor @@ -3,13 +3,13 @@ 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 ; : ( -- tree ) - avl new-tree ; + avl new-tree ; inline ( 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 ) @@ -36,8 +37,8 @@ TUPLE: avl-node < node balance ; : 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 ) @@ -57,9 +58,8 @@ TUPLE: avl-node < node balance ; : 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 @@ -68,7 +68,7 @@ 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 ; @@ -95,14 +95,14 @@ M: avl set-at ( value key node -- node ) 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? ) @@ -155,7 +155,7 @@ M: avl new-assoc 2drop ; 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 ; diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index d56e338234..76a8e39d83 100644 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -5,7 +5,7 @@ prettyprint.private kernel.private assocs random combinators parser math.order accessors deques make prettyprint.custom ; IN: trees -TUPLE: tree root count ; +TUPLE: tree root { count integer } ; >value - swap >>key ; + swap >>key ; inline : ( key value -- node ) node new-node ; diff --git a/extra/twitter/twitter.factor b/extra/twitter/twitter.factor index 9236cc9504..81a676ec24 100644 --- a/extra/twitter/twitter.factor +++ b/extra/twitter/twitter.factor @@ -2,7 +2,7 @@ ! 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 @@ -20,9 +20,8 @@ twitter-source [ "factor" ] initialize ] 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> diff --git a/extra/webapps/mason/backend/backend.factor b/extra/webapps/mason/backend/backend.factor index 217e6b8a1a..bb77dd8143 100644 --- a/extra/webapps/mason/backend/backend.factor +++ b/extra/webapps/mason/backend/backend.factor @@ -1,7 +1,8 @@ ! 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" @@ -72,7 +73,7 @@ counter "COUNTER" { : os/cpu ( builder -- string ) [ os>> ] [ cpu>> ] bi "/" glue ; -: mason-db ( -- db ) "resource:mason.db" ; +: mason-db ( -- db ) home "mason.db" append-path ; : with-mason-db ( quot -- ) mason-db [ with-transaction ] with-db ; inline diff --git a/extra/webapps/mason/docs-update/docs-update.factor b/extra/webapps/mason/docs-update/docs-update.factor index 7b685890e7..2df1f9ee83 100644 --- a/extra/webapps/mason/docs-update/docs-update.factor +++ b/extra/webapps/mason/docs-update/docs-update.factor @@ -1,15 +1,20 @@ ! 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 diff --git a/extra/webapps/mason/download-package.xml b/extra/webapps/mason/download-package.xml index ff366fb4f4..1d56d3e3cb 100644 --- a/extra/webapps/mason/download-package.xml +++ b/extra/webapps/mason/download-package.xml @@ -7,7 +7,7 @@ Factor binary package for -
Logo
+
Logo

Factor binary package for

diff --git a/extra/webapps/mason/download-release.xml b/extra/webapps/mason/download-release.xml index ffb485e173..a1d4766206 100644 --- a/extra/webapps/mason/download-release.xml +++ b/extra/webapps/mason/download-release.xml @@ -7,7 +7,7 @@ Factor binary package for -
Logo
+
Logo

Factor binary package for

diff --git a/extra/webapps/mason/package/package.factor b/extra/webapps/mason/package/package.factor index 224c586f2f..b8409b0123 100644 --- a/extra/webapps/mason/package/package.factor +++ b/extra/webapps/mason/package/package.factor @@ -44,7 +44,7 @@ IN: webapps.mason.package 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 ; diff --git a/extra/webapps/planet/icons/feed-icon-14x14.png b/extra/webapps/planet/icons/feed-icon-14x14.png new file mode 100644 index 0000000000..b3c949d224 Binary files /dev/null and b/extra/webapps/planet/icons/feed-icon-14x14.png differ diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index a2beb513ab..cf48f6dfbc 100644 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -8,6 +8,7 @@ html.forms html.components http.server http.server.dispatchers +http.server.static furnace furnace.actions furnace.redirection @@ -190,6 +191,7 @@ posting "POSTINGS" "" add-responder "feed.xml" add-responder "admin" add-responder + "vocab:webapps/planet/icons/" "icons" add-responder { planet "planet-common" } >>template ; diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml index 08cf07d4ce..c7c124d23c 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -48,7 +48,7 @@ Planet Lisp.

- + Syndicate

diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index 379ba32a57..b91d58f433 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -3,7 +3,7 @@ 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 @@ -27,15 +27,16 @@ webapps.user-admin webapps.help webapps.mason webapps.mason.backend +webapps.mason.backend.watchdog websites.factorcode ; IN: websites.concatenative -: test-db ( -- db ) "resource:test.db" ; +: website-db ( -- db ) home "website.db" append-path ; : init-factor-db ( -- ) mason-db [ init-mason-db ] with-db - test-db [ + website-db [ init-furnace-tables { @@ -59,25 +60,22 @@ TUPLE: concatenative-website < dispatcher ; allow-edit-profile allow-deactivation ; +SYMBOLS: factor-recaptcha-public-key factor-recaptcha-private-key ; + : ( responder -- responder' ) "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 ; : ( -- responder ) concatenative-website new-dispatcher URL" /wiki/view/Front Page" "" add-responder ; -SYMBOL: key-password -SYMBOL: key-file -SYMBOL: dh-file +SYMBOLS: key-password key-file dh-file ; : common-configuration ( -- ) - "concatenative.org" 25 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 ( -- ) @@ -92,7 +90,7 @@ SYMBOL: dh-file "planet" add-responder "mason" add-responder "/tmp/docs/" "docs" add-responder - test-db + website-db main-responder set-global ; : ( path -- responder ) @@ -106,13 +104,12 @@ SYMBOL: dh-file "wiki" add-responder "user-admin" add-responder - test-db "concatenative.org" add-responder - test-db "paste.factorcode.org" add-responder - test-db "planet.factorcode.org" add-responder - test-db "builds.factorcode.org" add-responder + website-db "concatenative.org" add-responder + website-db "paste.factorcode.org" add-responder + website-db "planet.factorcode.org" add-responder + website-db "builds.factorcode.org" add-responder home "docs" append-path "docs.factorcode.org" add-responder home "cgi" append-path "gitweb.factorcode.org" add-responder - "new.factorcode.org" add-responder main-responder set-global ; : ( -- config ) @@ -127,8 +124,12 @@ SYMBOL: dh-file 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 start-server ; diff --git a/extra/websites/factorcode/factor-macosx.png b/extra/websites/factorcode/factor-macosx.png new file mode 100644 index 0000000000..06e44ecf70 Binary files /dev/null and b/extra/websites/factorcode/factor-macosx.png differ diff --git a/extra/websites/factorcode/factor-windows7.png b/extra/websites/factorcode/factor-windows7.png new file mode 100644 index 0000000000..aa6f1787ea Binary files /dev/null and b/extra/websites/factorcode/factor-windows7.png differ diff --git a/extra/websites/factorcode/factorcode.factor b/extra/websites/factorcode/factorcode.factor index 36450509b3..d4abba7988 100644 --- a/extra/websites/factorcode/factorcode.factor +++ b/extra/websites/factorcode/factorcode.factor @@ -4,14 +4,9 @@ USING: accessors http.server http.server.dispatchers http.server.static kernel namespaces sequences ; IN: websites.factorcode -SYMBOL: users - : ( -- website ) - "resource:extra/websites/factorcode/" enable-fhtml >>default - users get [ - [ "/home/" "/www/" surround ] keep add-responder - ] each ; + "resource:extra/websites/factorcode/" enable-fhtml >>default ; : init-testing ( -- ) main-responder set-global ; diff --git a/extra/websites/factorcode/license.txt b/extra/websites/factorcode/license.txt new file mode 100644 index 0000000000..e9cd58a5e4 --- /dev/null +++ b/extra/websites/factorcode/license.txt @@ -0,0 +1,20 @@ +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. diff --git a/vm/Config.windows b/vm/Config.windows old mode 100644 new mode 100755 index 1886ee77d6..1ae91b15c2 --- a/vm/Config.windows +++ b/vm/Config.windows @@ -5,6 +5,7 @@ SHARED_DLL_EXTENSION=.dll 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= diff --git a/vm/bignum.cpp b/vm/bignum.cpp index 47896340cd..adcfa6f4da 100755 --- a/vm/bignum.cpp +++ b/vm/bignum.cpp @@ -381,25 +381,11 @@ FOO_TO_BIGNUM(ulong_long,u64,s64,u64) } \ } -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); \ diff --git a/vm/gc.cpp b/vm/gc.cpp index 0de3dac91f..1bb339a70a 100755 --- a/vm/gc.cpp +++ b/vm/gc.cpp @@ -230,8 +230,8 @@ struct call_frame_scrubber { 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); } }; diff --git a/vm/gc_info.cpp b/vm/gc_info.cpp index 7c727aac0d..a693fc5455 100644 --- a/vm/gc_info.cpp +++ b/vm/gc_info.cpp @@ -13,7 +13,7 @@ cell gc_info::return_address_index(cell return_address) return i; } - return gc_info_missing_value; + return (cell)-1; } } diff --git a/vm/gc_info.hpp b/vm/gc_info.hpp index eee7b1a8e8..9bff88b9b2 100644 --- a/vm/gc_info.hpp +++ b/vm/gc_info.hpp @@ -1,8 +1,6 @@ namespace factor { -const u32 gc_info_missing_value = (u32)-1; - struct gc_info { u32 scrub_d_count; u32 scrub_r_count; @@ -58,7 +56,7 @@ struct gc_info { + 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]; } diff --git a/vm/math.cpp b/vm/math.cpp index 67cab3570d..4bc918ad66 100755 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -255,11 +255,6 @@ void factor_vm::primitive_fixnum_to_float() 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); diff --git a/vm/math.hpp b/vm/math.hpp index ffe60dced5..62c007be8d 100644 --- a/vm/math.hpp +++ b/vm/math.hpp @@ -33,11 +33,6 @@ inline bignum *factor_vm::float_to_bignum(cell tagged) return double_to_bignum(untag_float(tagged)); } -inline double factor_vm::bignum_to_float(cell tagged) -{ - return bignum_to_double(untag(tagged)); -} - inline double factor_vm::untag_float(cell tagged) { return untag(tagged)->n; diff --git a/vm/primitives.hpp b/vm/primitives.hpp index ce40ca0a7e..573f91b072 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -27,7 +27,6 @@ namespace factor _(bignum_shift) \ _(bignum_subtract) \ _(bignum_to_fixnum) \ - _(bignum_to_float) \ _(bignum_xor) \ _(bits_double) \ _(bits_float) \ diff --git a/vm/slot_visitor.hpp b/vm/slot_visitor.hpp index 303fc37544..b2dd40e582 100755 --- a/vm/slot_visitor.hpp +++ b/vm/slot_visitor.hpp @@ -292,8 +292,8 @@ struct call_frame_slot_visitor { 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 @@ -305,8 +305,8 @@ struct call_frame_slot_visitor { /* 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 @@ -334,8 +334,8 @@ struct call_frame_slot_visitor { /* 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]; } } diff --git a/vm/vm.hpp b/vm/vm.hpp index f940bd5937..38eb5033d7 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -192,7 +192,6 @@ struct factor_vm 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); @@ -457,7 +456,6 @@ struct factor_vm 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(); @@ -487,7 +485,6 @@ struct factor_vm 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);