diff --git a/basis/alien/arrays/arrays-docs.factor b/basis/alien/arrays/arrays-docs.factor index 09a09cdc6f..c5efe1e030 100644 --- a/basis/alien/arrays/arrays-docs.factor +++ b/basis/alien/arrays/arrays-docs.factor @@ -1,69 +1,7 @@ IN: alien.arrays USING: help.syntax help.markup byte-arrays alien.c-types ; -ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays" -"Each primitive C type has a pair of words, " { $snippet ">" { $emphasis "type" } "-array" } " and " { $snippet { $emphasis "type" } "-array>" } ", for converting an array of Factor objects to and from a " { $link byte-array } " of C values. This set of words consists of:" -{ $subsection >c-bool-array } -{ $subsection >c-char-array } -{ $subsection >c-double-array } -{ $subsection >c-float-array } -{ $subsection >c-int-array } -{ $subsection >c-long-array } -{ $subsection >c-longlong-array } -{ $subsection >c-short-array } -{ $subsection >c-uchar-array } -{ $subsection >c-uint-array } -{ $subsection >c-ulong-array } -{ $subsection >c-ulonglong-array } -{ $subsection >c-ushort-array } -{ $subsection >c-void*-array } -{ $subsection c-bool-array> } -{ $subsection c-char-array> } -{ $subsection c-double-array> } -{ $subsection c-float-array> } -{ $subsection c-int-array> } -{ $subsection c-long-array> } -{ $subsection c-longlong-array> } -{ $subsection c-short-array> } -{ $subsection c-uchar-array> } -{ $subsection c-uint-array> } -{ $subsection c-ulong-array> } -{ $subsection c-ulonglong-array> } -{ $subsection c-ushort-array> } -{ $subsection c-void*-array> } ; - -ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays" -"Each C type has a pair of words, " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } ", for reading and writing values of this type stored in an array. This set of words includes but is not limited to:" -{ $subsection char-nth } -{ $subsection set-char-nth } -{ $subsection uchar-nth } -{ $subsection set-uchar-nth } -{ $subsection short-nth } -{ $subsection set-short-nth } -{ $subsection ushort-nth } -{ $subsection set-ushort-nth } -{ $subsection int-nth } -{ $subsection set-int-nth } -{ $subsection uint-nth } -{ $subsection set-uint-nth } -{ $subsection long-nth } -{ $subsection set-long-nth } -{ $subsection ulong-nth } -{ $subsection set-ulong-nth } -{ $subsection longlong-nth } -{ $subsection set-longlong-nth } -{ $subsection ulonglong-nth } -{ $subsection set-ulonglong-nth } -{ $subsection float-nth } -{ $subsection set-float-nth } -{ $subsection double-nth } -{ $subsection set-double-nth } -{ $subsection void*-nth } -{ $subsection set-void*-nth } ; - ARTICLE: "c-arrays" "C arrays" "C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "." $nl -"C type specifiers for array types are documented in " { $link "c-types-specs" } "." -{ $subsection "c-arrays-factor" } -{ $subsection "c-arrays-get/set" } ; +"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ; diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index 739b45486f..a2b555b057 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -89,16 +89,6 @@ HELP: malloc-byte-array { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } { $errors "Throws an error if memory allocation fails." } ; -HELP: define-nth -{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } } -{ $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." } -{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ; - -HELP: define-set-nth -{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } } -{ $description "Defines a word " { $snippet "set-" { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( value n c-ptr -- )" } " for writing the value with C type " { $snippet "name" } " to an alien pointer, displaced by a multiple of the C type's size." } -{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ; - HELP: box-parameter { $values { "n" integer } { "ctype" string } } { $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." } @@ -115,12 +105,12 @@ HELP: unbox-return { $notes "This is an internal word used by the compiler when compiling callbacks." } ; HELP: define-deref -{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } } +{ $values { "name" "a word name" } } { $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 { "name" "a word name" } { "vocab" "a vocabulary name" } } +{ $values { "name" "a word name" } } { $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." } ; @@ -230,9 +220,7 @@ $nl "You can copy a range of bytes from memory into a byte array:" { $subsection memory>byte-array } "You can copy a byte array to memory unsafely:" -{ $subsection byte-array>memory } -"A wrapper for temporarily allocating a block of memory:" -{ $subsection with-malloc } ; +{ $subsection byte-array>memory } ; 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." diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index 5c4f022e93..f57d102452 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -55,8 +55,6 @@ TYPEDEF: uchar* MyLPBYTE 0 B{ 1 2 3 4 } ] must-fail -[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test - os windows? cpu x86.64? and [ - [ -2147467259 ] [ 2147500037 *long ] unit-test + [ -2147467259 ] [ 2147500037 *long ] unit-test ] when diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index de8d36521e..c3ae644b47 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math namespaces make parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations layouts system compiler.units io.files io.encodings.binary -accessors combinators effects continuations ; +accessors combinators effects continuations fry ; IN: alien.c-types DEFER: @@ -21,7 +21,7 @@ reg-class size align stack-align? ; : new-c-type ( class -- type ) new int-regs >>reg-class - object >>class ; + object >>class ; inline : ( -- type ) \ c-type new-c-type ; @@ -180,12 +180,12 @@ M: byte-array byte-length length ; : c-getter ( name -- quot ) c-type-getter [ - [ "Cannot read struct fields with type" throw ] + [ "Cannot read struct fields with this type" throw ] ] unless* ; : c-setter ( name -- quot ) c-type-setter [ - [ "Cannot write struct fields with type" throw ] + [ "Cannot write struct fields with this type" throw ] ] unless* ; : ( n type -- array ) @@ -209,28 +209,13 @@ M: byte-array byte-length length ; : byte-array>memory ( byte-array base -- ) swap dup length memcpy ; -: (define-nth) ( word type quot -- ) +: array-accessor ( type quot -- def ) [ \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi* - ] [ ] make define-inline ; - -: nth-word ( name vocab -- word ) - [ "-nth" append ] dip create ; - -: define-nth ( name vocab -- ) - dupd nth-word swap dup c-getter (define-nth) ; - -: set-nth-word ( name vocab -- word ) - [ "set-" swap "-nth" 3append ] dip create ; - -: define-set-nth ( name vocab -- ) - dupd set-nth-word swap dup c-setter (define-nth) ; + ] [ ] make ; : typedef ( old new -- ) c-types get set-at ; -: define-c-type ( type name vocab -- ) - [ tuck typedef ] dip [ define-nth ] 2keep define-set-nth ; - TUPLE: long-long-type < c-type ; : ( -- type ) @@ -248,54 +233,24 @@ M: long-long-type box-parameter ( n type -- ) M: long-long-type box-return ( type -- ) f swap box-parameter ; -: define-deref ( name vocab -- ) - [ dup CHAR: * prefix ] dip create - swap c-getter 0 prefix define-inline ; +: define-deref ( name -- ) + [ CHAR: * prefix "alien.c-types" create ] + [ c-getter 0 prefix ] bi + define-inline ; -: define-out ( name vocab -- ) - over [ tuck 0 ] over c-setter append swap - [ constructor-word ] 2dip prefix define-inline ; +: define-out ( name -- ) + [ "alien.c-types" constructor-word ] + [ dup c-setter '[ _ [ 0 @ ] keep ] ] + bi define-inline ; : c-bool> ( int -- ? ) zero? not ; -: >c-array ( seq type word -- byte-array ) - [ [ dup length ] dip ] dip - [ [ execute ] 2curry each-index ] 2keep drop ; inline - -: >c-array-quot ( type vocab -- quot ) - dupd set-nth-word [ >c-array ] 2curry ; - -: to-array-word ( name vocab -- word ) - [ ">c-" swap "-array" 3append ] dip create ; - -: define-to-array ( type vocab -- ) - [ to-array-word ] 2keep >c-array-quot - (( array -- byte-array )) define-declared ; - -: c-array>quot ( type vocab -- quot ) - [ - \ swap , - nth-word 1quotation , - [ curry map ] % - ] [ ] make ; - -: from-array-word ( name vocab -- word ) - [ "c-" swap "-array>" 3append ] dip create ; - -: define-from-array ( type vocab -- ) - [ from-array-word ] 2keep c-array>quot - (( c-ptr n -- array )) define-declared ; - : define-primitive-type ( type name -- ) - "alien.c-types" - { - [ define-c-type ] - [ define-deref ] - [ define-to-array ] - [ define-from-array ] - [ define-out ] - } 2cleave ; + [ typedef ] + [ define-deref ] + [ define-out ] + tri ; : expand-constants ( c-type -- c-type' ) dup array? [ @@ -314,6 +269,17 @@ M: long-long-type box-return ( type -- ) : if-void ( type true false -- ) pick "void" = [ drop nip call ] [ nip call ] if ; inline +: primitive-types + { + "char" "uchar" + "short" "ushort" + "int" "uint" + "long" "ulong" + "longlong" "ulonglong" + "float" "double" + "void*" "bool" + } ; + [ c-ptr >>class diff --git a/basis/alien/strings/strings.factor b/basis/alien/strings/strings.factor index 54a6cbfb4a..d482634772 100644 --- a/basis/alien/strings/strings.factor +++ b/basis/alien/strings/strings.factor @@ -3,7 +3,7 @@ USING: arrays sequences kernel accessors math alien.accessors alien.c-types byte-arrays words io io.encodings io.streams.byte-array io.streams.memory io.encodings.utf8 -io.encodings.utf16 system alien strings cpu.architecture ; +io.encodings.utf16 system alien strings cpu.architecture fry ; IN: alien.strings GENERIC# alien>string 1 ( c-ptr encoding -- string/f ) @@ -77,10 +77,10 @@ M: string-type c-type-unboxer drop "void*" c-type-unboxer ; M: string-type c-type-boxer-quot - second [ alien>string ] curry [ ] like ; + second '[ _ alien>string ] ; M: string-type c-type-unboxer-quot - second [ string>alien ] curry [ ] like ; + second '[ _ string>alien ] ; M: string-type c-type-getter drop [ alien-cell ] ; diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index d1fdbef4c0..a3c616cda2 100644 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -38,25 +38,26 @@ M: struct-type stack-size : c-struct? ( type -- ? ) (c-type) struct-type? ; -: (define-struct) ( name vocab size align fields -- ) +: (define-struct) ( name size align fields -- ) [ [ align ] keep ] dip struct-type boa - -rot define-c-type ; + swap typedef ; -: define-struct-early ( name vocab fields -- fields ) +: make-fields ( name vocab fields -- fields ) [ first2 ] with with map ; : compute-struct-align ( types -- n ) [ c-type-align ] map supremum ; : define-struct ( name vocab fields -- ) - pick [ + [ + [ 2drop ] [ make-fields ] 3bi [ struct-offsets ] keep [ [ type>> ] map compute-struct-align ] keep [ (define-struct) ] keep - ] dip [ swap define-field ] curry each ; + ] [ 2drop '[ _ swap define-field ] ] 3bi each ; -: define-union ( name vocab members -- ) +: define-union ( name members -- ) [ expand-constants ] map [ [ heap-size ] map supremum ] keep compute-struct-align f (define-struct) ; diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index a204b1621c..d10c97cd3d 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -24,13 +24,10 @@ IN: alien.syntax scan scan typedef ; parsing : C-STRUCT: - scan in get - parse-definition - [ 2dup ] dip define-struct-early - define-struct ; parsing + scan in get parse-definition define-struct ; parsing : C-UNION: - scan in get parse-definition define-union ; parsing + scan parse-definition define-union ; parsing : C-ENUM: ";" parse-tokens diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index 11601f7b63..4cb2032f4f 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types accessors math alien.accessors kernel kernel.private locals sequences sequences.private byte-arrays -parser prettyprint.backend ; +parser prettyprint.backend fry ; IN: bit-arrays TUPLE: bit-array @@ -24,9 +24,8 @@ TUPLE: bit-array : bits>bytes 7 + n>byte ; inline : (set-bits) ( bit-array n -- ) - [ [ length bits>cells ] keep ] dip - [ -rot underlying>> set-uint-nth ] 2curry - each ; inline + [ [ length bits>cells ] keep ] dip swap underlying>> + '[ [ _ _ ] dip set-alien-unsigned-4 ] each ; inline PRIVATE> @@ -84,9 +83,9 @@ M: bit-array byte-length length 7 + -3 shift ; ] if ; : bit-array>integer ( bit-array -- n ) - 0 swap underlying>> [ length ] keep [ - uchar-nth swap 8 shift bitor - ] curry each ; + 0 swap underlying>> dup length [ + alien-unsigned-1 swap 8 shift bitor + ] with each ; INSTANCE: bit-array sequence diff --git a/basis/cocoa/enumeration/enumeration.factor b/basis/cocoa/enumeration/enumeration.factor index 7de1f24a3c..7f5b777283 100644 --- a/basis/cocoa/enumeration/enumeration.factor +++ b/basis/cocoa/enumeration/enumeration.factor @@ -1,26 +1,31 @@ -USING: kernel cocoa cocoa.types alien.c-types locals math sequences -vectors fry libc ; +! Copyright (C) 2008 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel cocoa cocoa.types alien.c-types locals math +sequences vectors fry libc destructors +specialized-arrays.direct.alien ; IN: cocoa.enumeration : NS-EACH-BUFFER-SIZE 16 ; inline -: (with-enumeration-buffers) ( quot -- ) - "NSFastEnumerationState" heap-size swap '[ - NS-EACH-BUFFER-SIZE "id" heap-size * [ - NS-EACH-BUFFER-SIZE @ - ] with-malloc - ] with-malloc ; inline +: with-enumeration-buffers ( quot -- ) + [ + [ + "NSFastEnumerationState" malloc-object &free + NS-EACH-BUFFER-SIZE "id" heap-size * malloc-object &free + NS-EACH-BUFFER-SIZE + ] dip call + ] with-destructors ; inline :: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- ) object state stackbuf count -> countByEnumeratingWithState:objects:count: - dup zero? [ drop ] [ + dup 0 = [ drop ] [ state NSFastEnumerationState-itemsPtr [ stackbuf ] unless* - '[ _ void*-nth quot call ] each + swap quot each object quot state stackbuf count (NSFastEnumeration-each) ] if ; inline recursive : NSFastEnumeration-each ( object quot -- ) - [ (NSFastEnumeration-each) ] (with-enumeration-buffers) ; inline + [ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline : NSFastEnumeration-map ( object quot -- vector ) NS-EACH-BUFFER-SIZE diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 5bcd6d6f60..791674428b 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -5,7 +5,8 @@ combinators compiler compiler.alien kernel math namespaces make parser prettyprint prettyprint.sections quotations sequences strings words cocoa.runtime io macros memoize debugger io.encodings.ascii effects libc libc.private parser lexer init -core-foundation fry generalizations ; +core-foundation fry generalizations +specialized-arrays.direct.alien ; IN: cocoa.messages : make-sender ( method function -- quot ) @@ -198,8 +199,11 @@ assoc-union alien>objc-types set-global objc-methods get set-at ; : each-method-in-class ( class quot -- ) - [ 0 [ class_copyMethodList ] keep *uint over ] dip - '[ _ void*-nth @ ] each (free) ; inline + [ 0 [ class_copyMethodList ] keep *uint ] dip + over 0 = [ 3drop ] [ + [ ] dip + [ each ] [ drop underlying>> (free) ] 2bi + ] if ; inline : register-objc-methods ( class -- ) [ register-objc-method ] each-method-in-class ; diff --git a/basis/cocoa/pasteboard/pasteboard.factor b/basis/cocoa/pasteboard/pasteboard.factor index 9302097adf..b530ccbc37 100644 --- a/basis/cocoa/pasteboard/pasteboard.factor +++ b/basis/cocoa/pasteboard/pasteboard.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types arrays kernel cocoa.messages -cocoa.classes cocoa.application cocoa core-foundation -sequences ; +USING: alien.accessors arrays kernel cocoa.messages +cocoa.classes cocoa.application cocoa core-foundation sequences +; IN: cocoa.pasteboard : NSStringPboardType "NSStringPboardType" ; @@ -24,7 +24,7 @@ IN: cocoa.pasteboard : pasteboard-error ( error -- f ) "Pasteboard does not hold a string" - 0 spin set-void*-nth f ; + 0 set-alien-cell f ; : ?pasteboard-string ( pboard error -- str/f ) over pasteboard-string? [ diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index cd113b5c64..be67f03184 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2006, 2007 Slava Pestov +! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types arrays kernel math namespaces make cocoa -cocoa.messages cocoa.classes cocoa.types sequences -continuations ; +USING: specialized-arrays.int arrays kernel math namespaces make +cocoa cocoa.messages cocoa.classes cocoa.types sequences +continuations accessors ; IN: cocoa.views : NSOpenGLPFAAllRenderers 1 ; @@ -69,7 +69,7 @@ PRIVATE> NSOpenGLPFASamples , 8 , ] when 0 , - ] { } make >c-int-array + ] int-array{ } make underlying>> -> initWithAttributes: -> autorelease ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index abcdb46ea2..230a7bf542 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -3,7 +3,8 @@ USING: alien alien.c-types alien.syntax compiler kernel namespaces namespaces tools.test sequences stack-checker stack-checker.errors words arrays parser quotations continuations effects namespaces.private io io.streams.string -memory system threads tools.test math accessors combinators ; +memory system threads tools.test math accessors combinators +specialized-arrays.float ; FUNCTION: void ffi_test_0 ; [ ] [ ffi_test_0 ] unit-test @@ -196,7 +197,11 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; -[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test +[ 32.0 ] [ + { 1.0 2.0 3.0 } >float-array underlying>> + { 4.0 5.0 6.0 } >float-array underlying>> + ffi_test_23 +] unit-test ! Test odd-size structs C-STRUCT: test-struct-1 { { "char" 1 } "x" } ; diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 59434b6dc5..e743c8484b 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 sequences.private tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io -combinators vectors float-arrays grouping make ; +combinators vectors grouping make ; IN: compiler.tests ! Originally, this file did black box testing of templating diff --git a/basis/compiler/tests/spilling.factor b/basis/compiler/tests/spilling.factor index 156fdfff02..ee8c2f056a 100644 --- a/basis/compiler/tests/spilling.factor +++ b/basis/compiler/tests/spilling.factor @@ -1,5 +1,5 @@ USING: math.private kernel combinators accessors arrays -generalizations float-arrays tools.test ; +generalizations tools.test ; IN: compiler.tests : float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b ) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 0beff42f4d..83a4a7aef7 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -3,7 +3,7 @@ USING: accessors kernel arrays sequences math math.order math.partial-dispatch generic generic.standard generic.math classes.algebra classes.union sets quotations assocs combinators -words namespaces continuations +words namespaces continuations classes fry compiler.tree compiler.tree.builder compiler.tree.recursive @@ -26,7 +26,7 @@ GENERIC: splicing-nodes ( #call word/quot/f -- nodes ) M: word splicing-nodes [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; -M: quotation splicing-nodes +M: callable splicing-nodes build-sub-tree analyze-recursive normalize ; : propagate-body ( #call -- ) @@ -140,18 +140,21 @@ SYMBOL: history : remember-inlining ( word -- ) history [ swap suffix ] change ; -: inline-word ( #call word -- ? ) - dup history get memq? [ - 2drop f +: inline-word-def ( #call word quot -- ? ) + over history get memq? [ + 3drop f ] [ [ - dup remember-inlining - dupd def>> splicing-nodes >>body + swap remember-inlining + dupd splicing-nodes >>body propagate-body ] with-scope t ] if ; +: inline-word ( #call word -- ? ) + dup def>> inline-word-def ; + : inline-method-body ( #call word -- ? ) 2dup should-inline? [ inline-word ] [ 2drop f ] if ; @@ -165,6 +168,10 @@ SYMBOL: history [ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack first object swap eliminate-dispatch ; +: inline-instance-check ( #call word -- ? ) + over in-d>> second value-info literal>> dup class? + [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ; + : do-inlining ( #call word -- ? ) #! If the generic was defined in an outer compilation unit, #! then it doesn't have a definition yet; the definition @@ -177,6 +184,7 @@ SYMBOL: history { { [ dup deferred? ] [ 2drop f ] } { [ dup custom-inlining? ] [ inline-custom ] } + { [ dup \ instance? eq? ] [ inline-instance-check ] } { [ dup always-inline-word? ] [ inline-word ] } { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 5a7b096039..06412209ca 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -8,7 +8,7 @@ math.functions math.private strings layouts compiler.tree.propagation.info compiler.tree.def-use compiler.tree.debugger compiler.tree.checker slots.private words hashtables classes assocs locals -float-arrays system sorting math.libm ; +specialized-arrays.double system sorting math.libm ; IN: compiler.tree.propagation.tests \ propagate must-infer @@ -167,7 +167,8 @@ IN: compiler.tree.propagation.tests [ V{ fixnum } ] [ [ - [ uchar-nth ] 2keep [ uchar-nth ] 2keep uchar-nth + { fixnum byte-array } declare + [ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift 255 min 0 max ] final-classes @@ -588,7 +589,7 @@ MIXIN: empty-mixin [ { fixnum integer } declare bitand ] final-classes ] unit-test -[ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test +[ V{ double-array } ] [ [| | double-array{ } ] final-classes ] unit-test [ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index 8a5bd1d240..8e5051e75d 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/basis/core-foundation/core-foundation.factor @@ -104,7 +104,7 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ; CF>array [ CF>string ] map ; : ( seq -- alien ) - [ ] map dup swap [ CFRelease ] each ; + [ ] map [ ] [ [ CFRelease ] each ] bi ; : ( string dir? -- url ) [ f over kCFURLPOSIXPathStyle ] dip diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index 80678ec3da..d4d5e88512 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -4,7 +4,9 @@ USING: alien alien.c-types alien.strings alien.syntax kernel math sequences namespaces make assocs init accessors continuations combinators core-foundation core-foundation.run-loop core-foundation.run-loop.thread -io.encodings.utf8 destructors locals arrays ; +io.encodings.utf8 destructors locals arrays +specialized-arrays.direct.alien specialized-arrays.direct.int +specialized-arrays.direct.longlong ; IN: core-foundation.fsevents : kFSEventStreamCreateFlagUseCFTypes 2 ; inline @@ -160,11 +162,12 @@ SYMBOL: event-stream-callbacks : remove-event-source-callback ( id -- ) event-stream-callbacks get delete-at ; -:: >event-triple ( n eventPaths eventFlags eventIds -- triple ) - n eventPaths void*-nth utf8 alien>string - n eventFlags int-nth - n eventIds longlong-nth - 3array ; +:: (master-event-source-callback) ( eventStream info numEvents eventPaths eventFlags eventIds -- ) + eventPaths numEvents [ utf8 alien>string ] { } map-as + eventFlags numEvents + eventIds numEvents + 3array flip + info event-stream-callbacks get at [ drop ] or call ; : master-event-source-callback ( -- alien ) "void" @@ -176,19 +179,15 @@ SYMBOL: event-stream-callbacks "FSEventStreamEventFlags*" "FSEventStreamEventId*" } - "cdecl" [ - [ >event-triple ] 3curry map - swap event-stream-callbacks get at - dup [ call drop ] [ 3drop ] if - ] alien-callback ; + "cdecl" [ (master-event-source-callback) ] alien-callback ; TUPLE: event-stream info handle disposed ; : ( quot paths latency flags -- event-stream ) - >r >r >r - add-event-source-callback dup - >r master-event-source-callback r> - r> r> r> + [ + add-event-source-callback dup + [ master-event-source-callback ] dip + ] 3dip dup enable-event-stream f event-stream boa ; diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor index 3a5942fce3..5149d14f3d 100644 --- a/basis/db/postgresql/lib/lib.factor +++ b/basis/db/postgresql/lib/lib.factor @@ -5,7 +5,8 @@ quotations sequences db.postgresql.ffi alien alien.c-types db.types tools.walker ascii splitting math.parser combinators libc shuffle calendar.format byte-arrays destructors prettyprint accessors strings serialize io.encodings.binary io.encodings.utf8 -alien.strings io.streams.byte-array summary present urls ; +alien.strings io.streams.byte-array summary present urls +specialized-arrays.uint specialized-arrays.alien ; IN: db.postgresql.lib : postgresql-result-error-message ( res -- str/f ) @@ -64,7 +65,7 @@ M: postgresql-result-null summary ( obj -- str ) } case ; : param-types ( statement -- seq ) - in-params>> [ type>> type>oid ] map >c-uint-array ; + in-params>> [ type>> type>oid ] uint-array{ } map-as underlying>> ; : malloc-byte-array/length ( byte-array -- alien length ) [ malloc-byte-array &free ] [ length ] bi ; @@ -90,11 +91,11 @@ M: postgresql-result-null summary ( obj -- str ) ] 2map flip [ f f ] [ - first2 [ >c-void*-array ] [ >c-uint-array ] bi* + first2 [ >void*-array underlying>> ] [ >uint-array underlying>> ] bi* ] if-empty ; : param-formats ( statement -- seq ) - in-params>> [ type>> type>param-format ] map >c-uint-array ; + in-params>> [ type>> type>param-format ] uint-array{ } map-as underlying>> ; : do-postgresql-bound-statement ( statement -- res ) [ diff --git a/basis/float-arrays/float-arrays-docs.factor b/basis/float-arrays/float-arrays-docs.factor deleted file mode 100644 index 6c775dbd78..0000000000 --- a/basis/float-arrays/float-arrays-docs.factor +++ /dev/null @@ -1,62 +0,0 @@ -USING: arrays bit-arrays vectors strings sbufs -kernel help.markup help.syntax math ; -IN: float-arrays - -ARTICLE: "float-arrays" "Float arrays" -"Float arrays are fixed-size mutable sequences (" { $link "sequence-protocol" } ") whose elements are instances of " { $link float } ". Elements are unboxed, hence the memory usage is lower than an equivalent " { $link array } " of floats." -$nl -"Float array words are in the " { $vocab-link "float-arrays" } " vocabulary." -$nl -"Float arrays play a special role in the C library interface; they can be used to pass binary data back and forth between Factor and C. See " { $link "c-byte-arrays" } "." -$nl -"Float arrays form a class of objects." -{ $subsection float-array } -{ $subsection float-array? } -"There are several ways to construct float arrays." -{ $subsection >float-array } -{ $subsection } -"Creating a float array from several elements on the stack:" -{ $subsection 1float-array } -{ $subsection 2float-array } -{ $subsection 3float-array } -{ $subsection 4float-array } -"Float array literal syntax:" -{ $subsection POSTPONE: F{ } ; - -ABOUT: "float-arrays" - -HELP: F{ -{ $syntax "F{ elements... }" } -{ $values { "elements" "a list of real numbers" } } -{ $description "Marks the beginning of a literal float array. Literal float arrays are terminated by " { $link POSTPONE: } } "." } -{ $examples { $code "F{ 1.0 2.0 3.0 }" } } ; - -HELP: float-array -{ $description "The class of float arrays." } ; - -HELP: ( n -- float-array ) -{ $values { "n" "a non-negative integer" } { "float-array" "a new float array" } } -{ $description "Creates a new float array holding " { $snippet "n" } " floats with all elements initially set to " { $snippet "0.0" } "." } ; - -HELP: >float-array -{ $values { "seq" "a sequence" } { "float-array" float-array } } -{ $description "Outputs a freshly-allocated float array whose elements have the same floating-point values as a given sequence." } -{ $errors "Throws an error if the sequence contains elements other than real numbers." } ; - -HELP: 1float-array -{ $values { "x" object } { "array" float-array } } -{ $description "Create a new float array with one element." } ; - -{ 1array 2array 3array 4array } related-words - -HELP: 2float-array -{ $values { "x" object } { "y" object } { "array" float-array } } -{ $description "Create a new float array with two elements, with " { $snippet "x" } " appearing first." } ; - -HELP: 3float-array -{ $values { "x" object } { "y" object } { "z" object } { "array" float-array } } -{ $description "Create a new float array with three elements, with " { $snippet "x" } " appearing first." } ; - -HELP: 4float-array -{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "array" float-array } } -{ $description "Create a new float array with four elements, with " { $snippet "w" } " appearing first." } ; diff --git a/basis/float-arrays/float-arrays-tests.factor b/basis/float-arrays/float-arrays-tests.factor deleted file mode 100644 index 64070b99b7..0000000000 --- a/basis/float-arrays/float-arrays-tests.factor +++ /dev/null @@ -1,12 +0,0 @@ -IN: float-arrays.tests -USING: float-arrays tools.test sequences.private ; - -[ F{ 0.0 0.0 0.0 } ] [ 3 ] unit-test - -[ F{ 1 2 3 0 0 0 } ] [ 6 F{ 1 2 3 } resize ] unit-test - -[ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize ] unit-test - -[ -10 F{ } resize ] must-fail - -[ F{ 1.3 } ] [ 1.3 1float-array ] unit-test diff --git a/basis/float-arrays/float-arrays.factor b/basis/float-arrays/float-arrays.factor deleted file mode 100644 index 4aa9f79414..0000000000 --- a/basis/float-arrays/float-arrays.factor +++ /dev/null @@ -1,130 +0,0 @@ -! Copyright (C) 2007, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private alien.accessors sequences -sequences.private math math.private byte-arrays accessors -alien.c-types parser prettyprint.backend combinators ; -IN: float-arrays - -TUPLE: float-array -{ length array-capacity read-only } -{ underlying byte-array read-only } ; - -: ( n -- float-array ) - dup "double" float-array boa ; inline - -M: float-array clone - [ length>> ] [ underlying>> clone ] bi float-array boa ; - -M: float-array length length>> ; - -M: float-array nth-unsafe - underlying>> double-nth ; - -M: float-array set-nth-unsafe - [ >float ] 2dip underlying>> set-double-nth ; - -: >float-array ( seq -- float-array ) - T{ float-array } clone-like ; inline - -M: float-array like - drop dup float-array? [ >float-array ] unless ; - -M: float-array new-sequence - drop ; - -M: float-array equal? - over float-array? [ sequence= ] [ 2drop f ] if ; - -M: float-array resize - [ drop ] [ - [ "double" heap-size * ] [ underlying>> ] bi* - resize-byte-array - ] 2bi - float-array boa ; - -M: float-array byte-length length "double" heap-size * ; - -INSTANCE: float-array sequence - -: 1float-array ( x -- array ) - 1 [ set-first ] keep ; inline - -: 2float-array ( x y -- array ) - T{ float-array } 2sequence ; inline - -: 3float-array ( x y z -- array ) - T{ float-array } 3sequence ; inline - -: 4float-array ( w x y z -- array ) - T{ float-array } 4sequence ; inline - -: F{ \ } [ >float-array ] parse-literal ; parsing - -M: float-array pprint-delims drop \ F{ \ } ; -M: float-array >pprint-sequence ; -M: float-array pprint* pprint-object ; - -! Specializer hints -USING: hints math.vectors arrays ; - -HINTS: { 2 } { 3 } ; - -HINTS: vneg { array } { float-array } ; -HINTS: v*n { array object } { float-array float } ; -HINTS: n*v { array object } { float float-array } ; -HINTS: v/n { array object } { float-array float } ; -HINTS: n/v { object array } { float float-array } ; -HINTS: v+ { array array } { float-array float-array } ; -HINTS: v- { array array } { float-array float-array } ; -HINTS: v* { array array } { float-array float-array } ; -HINTS: v/ { array array } { float-array float-array } ; -HINTS: vmax { array array } { float-array float-array } ; -HINTS: vmin { array array } { float-array float-array } ; -HINTS: v. { array array } { float-array float-array } ; -HINTS: norm-sq { array } { float-array } ; -HINTS: norm { array } { float-array } ; -HINTS: normalize { array } { float-array } ; -HINTS: distance { array array } { float-array float-array } ; - -! Type functions -USING: words classes.algebra compiler.tree.propagation.info -math.intervals ; - -{ v+ v- v* v/ vmax vmin } [ - [ - [ class>> float-array class<= ] both? - float-array object ? - ] "outputs" set-word-prop -] each - -{ n*v n/v } [ - [ - nip class>> float-array class<= float-array object ? - ] "outputs" set-word-prop -] each - -{ v*n v/n } [ - [ - drop class>> float-array class<= float-array object ? - ] "outputs" set-word-prop -] each - -{ vneg normalize } [ - [ - class>> float-array class<= float-array object ? - ] "outputs" set-word-prop -] each - -\ norm-sq [ - class>> float-array class<= [ float 0. 1/0. [a,b] ] [ object-info ] if -] "outputs" set-word-prop - -\ v. [ - [ class>> float-array class<= ] both? - float object ? -] "outputs" set-word-prop - -\ distance [ - [ class>> float-array class<= ] both? - [ float 0. 1/0. [a,b] ] [ object-info ] if -] "outputs" set-word-prop diff --git a/basis/float-arrays/summary.txt b/basis/float-arrays/summary.txt deleted file mode 100644 index 0eac3b0b1a..0000000000 --- a/basis/float-arrays/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Efficient fixed-length floating point number arrays diff --git a/basis/float-vectors/float-vectors-docs.factor b/basis/float-vectors/float-vectors-docs.factor deleted file mode 100644 index 714c8512c1..0000000000 --- a/basis/float-vectors/float-vectors-docs.factor +++ /dev/null @@ -1,37 +0,0 @@ -USING: arrays float-arrays help.markup help.syntax kernel -combinators ; -IN: float-vectors - -ARTICLE: "float-vectors" "Float vectors" -"A float vector is a resizable mutable sequence of unsigned floats. Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary." -$nl -"Float vectors form a class:" -{ $subsection float-vector } -{ $subsection float-vector? } -"Creating float vectors:" -{ $subsection >float-vector } -{ $subsection } -"Literal syntax:" -{ $subsection POSTPONE: FV{ } -"If you don't care about initial capacity, a more elegant way to create a new float vector is to write:" -{ $code "FV{ } clone" } ; - -ABOUT: "float-vectors" - -HELP: float-vector -{ $description "The class of resizable float vectors. See " { $link "float-vectors" } " for information." } ; - -HELP: -{ $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } } -{ $description "Creates a new float vector that can hold " { $snippet "n" } " floats before resizing." } ; - -HELP: >float-vector -{ $values { "seq" "a sequence" } { "float-vector" float-vector } } -{ $description "Outputs a freshly-allocated float vector with the same elements as a given sequence." } -{ $errors "Throws an error if the sequence contains elements other than real numbers." } ; - -HELP: FV{ -{ $syntax "FV{ elements... }" } -{ $values { "elements" "a list of real numbers" } } -{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." } -{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ; diff --git a/basis/float-vectors/float-vectors-tests.factor b/basis/float-vectors/float-vectors-tests.factor deleted file mode 100644 index 1483b269e0..0000000000 --- a/basis/float-vectors/float-vectors-tests.factor +++ /dev/null @@ -1,14 +0,0 @@ -USING: tools.test float-vectors vectors sequences kernel math ; -IN: float-vectors.tests - -[ 0 ] [ 123 length ] unit-test - -: do-it - 12345 [ >float over push ] each ; - -[ t ] [ - 3 do-it - 3 do-it sequence= -] unit-test - -[ t ] [ FV{ } float-vector? ] unit-test diff --git a/basis/float-vectors/float-vectors.factor b/basis/float-vectors/float-vectors.factor deleted file mode 100644 index 8e93582f04..0000000000 --- a/basis/float-vectors/float-vectors.factor +++ /dev/null @@ -1,38 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel kernel.private math sequences -sequences.private growable float-arrays prettyprint.backend -parser accessors ; -IN: float-vectors - -TUPLE: float-vector -{ underlying float-array initial: F{ } } -{ length array-capacity } ; - -: ( n -- float-vector ) - 0 float-vector boa ; inline - -: >float-vector ( seq -- float-vector ) - T{ float-vector f F{ } 0 } clone-like ; - -M: float-vector like - drop dup float-vector? [ - dup float-array? - [ dup length float-vector boa ] [ >float-vector ] if - ] unless ; - -M: float-vector new-sequence - drop [ ] [ >fixnum ] bi float-vector boa ; - -M: float-vector equal? - over float-vector? [ sequence= ] [ 2drop f ] if ; - -M: float-array new-resizable drop ; - -INSTANCE: float-vector growable - -: FV{ \ } [ >float-vector ] parse-literal ; parsing - -M: float-vector >pprint-sequence ; -M: float-vector pprint-delims drop \ FV{ \ } ; -M: float-vector pprint* pprint-object ; diff --git a/basis/float-vectors/summary.txt b/basis/float-vectors/summary.txt deleted file mode 100644 index c476f41a6e..0000000000 --- a/basis/float-vectors/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Growable float arrays diff --git a/basis/float-arrays/authors.txt b/basis/functors/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from basis/float-arrays/authors.txt rename to basis/functors/authors.txt diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor new file mode 100644 index 0000000000..39923afee7 --- /dev/null +++ b/basis/functors/functors-tests.factor @@ -0,0 +1,47 @@ +IN: functors.tests +USING: functors tools.test math words kernel ; + +<< + +FUNCTOR: define-box ( T -- ) + +B DEFINES ${T}-box + DEFINES <${B}> + +WHERE + +TUPLE: B { value T } ; + +C: B + +;FUNCTOR + +\ float define-box + +>> + +{ 1 0 } [ define-box ] must-infer-as + +[ T{ float-box f 5.0 } ] [ 5.0 ] unit-test + +: twice ( word -- ) + [ execute ] [ execute ] bi ; inline +<< + +FUNCTOR: wrapper-test ( W -- ) + +WW DEFINES ${W}${W} + +WHERE + +: WW W twice ; inline + +;FUNCTOR + +\ sq wrapper-test + +>> + +\ sqsq must-infer + +[ 16 ] [ 2 sqsq ] unit-test diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor new file mode 100644 index 0000000000..d5ac3b6878 --- /dev/null +++ b/basis/functors/functors.factor @@ -0,0 +1,106 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel locals.private quotations classes.tuple make +combinators generic words interpolate namespaces sequences +io.streams.string fry classes.mixin effects lexer parser +classes.tuple.parser effects.parser ; +IN: functors + +: scan-param ( -- obj ) + scan-object dup special? [ literalize ] unless ; + +: define* ( word def effect -- ) pick set-word define-declared ; + +: DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ; + +: `TUPLE: + scan-param parsed + scan { + { ";" [ tuple parsed f parsed ] } + { "<" [ scan-param [ parse-tuple-slots ] { } make parsed ] } + [ + [ tuple parsed ] dip + [ parse-slot-name [ parse-tuple-slots ] when ] { } + make parsed + ] + } case + \ define-tuple-class parsed ; parsing + +: `M: + effect off + scan-param parsed + scan-param parsed + \ create-method parsed + parse-definition parsed + DEFINE* ; parsing + +: `C: + effect off + scan-param parsed + scan-param parsed + [ [ boa ] curry ] over push-all + DEFINE* ; parsing + +: `: + effect off + scan-param parsed + parse-definition parsed + DEFINE* ; parsing + +: `INSTANCE: + scan-param parsed + scan-param parsed + \ add-mixin-instance parsed ; parsing + +: `inline \ inline parsed ; parsing + +: `parsing \ parsing parsed ; parsing + +: `( + ")" parse-effect effect set ; parsing + +: (INTERPOLATE) ( accum quot -- accum ) + [ scan interpolate-locals ] dip + '[ _ with-string-writer @ ] parsed ; + +: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; parsing + +: DEFINES [ create-in ] (INTERPOLATE) ; parsing + +DEFER: ;FUNCTOR delimiter + +: functor-words ( -- assoc ) + H{ + { "TUPLE:" POSTPONE: `TUPLE: } + { "M:" POSTPONE: `M: } + { "C:" POSTPONE: `C: } + { ":" POSTPONE: `: } + { "INSTANCE:" POSTPONE: `INSTANCE: } + { "inline" POSTPONE: `inline } + { "parsing" POSTPONE: `parsing } + { "(" POSTPONE: `( } + } ; + +: push-functor-words ( -- ) + functor-words use get push ; + +: pop-functor-words ( -- ) + functor-words use get delq ; + +: parse-functor-body ( -- form ) + t in-lambda? [ + V{ } clone + push-functor-words + "WHERE" parse-bindings* \ ;FUNCTOR (parse-lambda) + parsed-lambda + pop-functor-words + >quotation + ] with-variable ; + +: (FUNCTOR:) ( -- word def ) + CREATE + parse-locals + parse-functor-body swap pop-locals + lambda-rewrite first ; + +: FUNCTOR: (FUNCTOR:) define ; parsing diff --git a/basis/functors/summary.txt b/basis/functors/summary.txt new file mode 100644 index 0000000000..d95b366bc1 --- /dev/null +++ b/basis/functors/summary.txt @@ -0,0 +1 @@ +First-class syntax diff --git a/basis/functors/tags.txt b/basis/functors/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/basis/functors/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index fcde1ccedf..e72fbb439c 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -205,10 +205,10 @@ ARTICLE: "cookbook-io" "Input and output cookbook" } "Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:" { $code - "USING: accessors grouping io.files io.mmap kernel sequences ;" - "\"mydata.dat\" dup file-info size>> [" + "USING: accessors grouping io.files io.mmap.char kernel sequences ;" + "\"mydata.dat\" [" " 4 [ reverse-here ] change-each" - "] with-mapped-file" + "] with-mapped-char-file" } "Send some bytes to a remote host:" { $code diff --git a/basis/io/mmap/alien/alien.factor b/basis/io/mmap/alien/alien.factor new file mode 100644 index 0000000000..4b0a532407 --- /dev/null +++ b/basis/io/mmap/alien/alien.factor @@ -0,0 +1,4 @@ +USING: io.mmap.functor specialized-arrays.direct.alien ; +IN: io.mmap.alien + +<< "void*" define-mapped-array >> \ No newline at end of file diff --git a/basis/io/mmap/bool/bool.factor b/basis/io/mmap/bool/bool.factor new file mode 100644 index 0000000000..a2b596fff6 --- /dev/null +++ b/basis/io/mmap/bool/bool.factor @@ -0,0 +1,4 @@ +USING: io.mmap.functor specialized-arrays.direct.bool ; +IN: io.mmap.bool + +<< "bool" define-mapped-array >> \ No newline at end of file diff --git a/basis/io/mmap/char/char.factor b/basis/io/mmap/char/char.factor new file mode 100644 index 0000000000..453e7e940c --- /dev/null +++ b/basis/io/mmap/char/char.factor @@ -0,0 +1,4 @@ +USING: io.mmap.functor specialized-arrays.direct.char ; +IN: io.mmap.char + +<< "char" define-mapped-array >> \ No newline at end of file diff --git a/basis/io/mmap/double/double.factor b/basis/io/mmap/double/double.factor new file mode 100644 index 0000000000..919c006748 --- /dev/null +++ b/basis/io/mmap/double/double.factor @@ -0,0 +1,4 @@ +USING: io.mmap.functor specialized-arrays.direct.double ; +IN: io.mmap.double + +<< "double" define-mapped-array >> \ No newline at end of file diff --git a/basis/io/mmap/float/float.factor b/basis/io/mmap/float/float.factor new file mode 100644 index 0000000000..33cf16c29f --- /dev/null +++ b/basis/io/mmap/float/float.factor @@ -0,0 +1,4 @@ +USING: io.mmap.functor specialized-arrays.direct.float ; +IN: io.mmap.float + +<< "float" define-mapped-array >> \ No newline at end of file diff --git a/basis/io/mmap/functor/functor.factor b/basis/io/mmap/functor/functor.factor new file mode 100644 index 0000000000..4587a75fd9 --- /dev/null +++ b/basis/io/mmap/functor/functor.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.mmap functors accessors alien.c-types math kernel +words fry ; +IN: io.mmap.functor + +SLOT: address +SLOT: length + +: mapped-file>direct ( mapped-file type -- alien length ) + [ [ address>> ] [ length>> ] bi ] dip + heap-size [ 1- + ] keep /i ; + +FUNCTOR: define-mapped-array ( T -- ) + + DEFINES + IS +with-mapped-A-file DEFINES with-mapped-${T}-file + +WHERE + +: ( mapped-file -- direct-array ) + T mapped-file>direct execute ; inline + +: with-mapped-A-file ( path length quot -- ) + '[ execute @ ] with-mapped-file ; inline + +;FUNCTOR diff --git a/basis/io/mmap/int/int.factor b/basis/io/mmap/int/int.factor new file mode 100644 index 0000000000..400e81e401 --- /dev/null +++ b/basis/io/mmap/int/int.factor @@ -0,0 +1,4 @@ +USING: io.mmap.functor specialized-arrays.direct.int ; +IN: io.mmap.int + +<< "int" define-mapped-array >> \ No newline at end of file diff --git a/basis/io/mmap/long/long.factor b/basis/io/mmap/long/long.factor new file mode 100644 index 0000000000..190dd288ea --- /dev/null +++ b/basis/io/mmap/long/long.factor @@ -0,0 +1,4 @@ +USING: io.mmap.functor specialized-arrays.direct.long ; +IN: io.mmap.long + +<< "long" define-mapped-array >> \ No newline at end of file diff --git a/basis/io/mmap/longlong/longlong.factor b/basis/io/mmap/longlong/longlong.factor new file mode 100644 index 0000000000..4d0a2aaa5a --- /dev/null +++ b/basis/io/mmap/longlong/longlong.factor @@ -0,0 +1,4 @@ +USING: io.mmap.functor specialized-arrays.direct.longlong ; +IN: io.mmap.longlong + +<< "longlong" define-mapped-array >> \ No newline at end of file diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index 09922fc929..bd971656d4 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -11,13 +11,13 @@ HELP: mapped-file } ; HELP: -{ $values { "path" "a pathname string" } { "length" integer } { "mmap" mapped-file } } -{ $contract "Opens a file and maps the first " { $snippet "length" } " bytes 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 close-mapped-file } " 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." } +{ $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." } ; HELP: with-mapped-file -{ $values { "path" "a pathname string" } { "length" integer } { "quot" { $quotation "( mmap -- )" } } } +{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } } { $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } { $errors "Throws an error if a memory mapping could not be established." } ; @@ -26,6 +26,33 @@ HELP: close-mapped-file { $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." } { $errors "Throws an error if a memory mapping could not be established." } ; +ARTICLE: "io.mmap.arrays" "Memory-mapped arrays" +"Mapped file can be viewed as a sequence using the words in sub-vocabularies of " { $vocab-link "io.mmap" } ". For each primitive C type " { $snippet "T" } ", a set of words are defined in the vocabulary named " { $snippet "io.mmap.T" } ":" +{ $table + { { $snippet "" } { "Wraps a " { $link mapped-file } " in a sequence; stack effect " { $snippet "( mapped-file -- direct-array )" } } } + { { $snippet "with-mapped-T-file" } { "Maps a file into memory and wraps it in a sequence by combining " { $link with-mapped-file } " and " { $snippet "" } "; stack effect " { $snippet "( path quot -- )" } } } +} +"The primitive C types for which mapped arrays exist:" +{ $list + { $snippet "char" } + { $snippet "uchar" } + { $snippet "short" } + { $snippet "ushort" } + { $snippet "int" } + { $snippet "uint" } + { $snippet "long" } + { $snippet "ulong" } + { $snippet "longlong" } + { $snippet "ulonglong" } + { $snippet "float" } + { $snippet "double" } + { $snippet "void*" } + { $snippet "bool" } +} ; + +ARTICLE: "io.mmap.low-level" "Reading and writing mapped files directly" +"Data can be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. See " { $link "reading-writing-memory" } "." ; + ARTICLE: "io.mmap" "Memory-mapped files" "The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files." { $subsection } @@ -33,7 +60,8 @@ ARTICLE: "io.mmap" "Memory-mapped files" $nl "A utility combinator which wraps the above:" { $subsection with-mapped-file } -"Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly with the " { $snippet "address" } " slot." $nl -"Data can be read and written from the memory area using alien words. See " { $link "reading-writing-memory" } "." ; +"Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:" +{ $subsection "io.mmap.arrays" } +{ $subsection "io.mmap.low-level" } ; ABOUT: "io.mmap" diff --git a/basis/io/mmap/mmap-tests.factor b/basis/io/mmap/mmap-tests.factor index 57faca01c7..dc2f0b4687 100644 --- a/basis/io/mmap/mmap-tests.factor +++ b/basis/io/mmap/mmap-tests.factor @@ -1,10 +1,10 @@ -USING: io io.mmap io.files kernel tools.test continuations -sequences io.encodings.ascii accessors ; +USING: io io.mmap io.mmap.char io.files kernel tools.test +continuations sequences io.encodings.ascii accessors ; IN: io.mmap.tests [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors [ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test -[ ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test -[ 5 ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ length ] with-mapped-file ] unit-test +[ ] [ "mmap-test-file.txt" temp-file [ CHAR: 2 0 pick set-nth drop ] with-mapped-char-file ] unit-test +[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test [ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor index 01e7054ef1..3cf451bd03 100644 --- a/basis/io/mmap/mmap.factor +++ b/basis/io/mmap/mmap.factor @@ -1,34 +1,24 @@ ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: continuations destructors io.backend kernel quotations -sequences system alien alien.accessors accessors -sequences.private system vocabs.loader combinators ; +USING: continuations destructors io.files io.backend kernel +quotations system alien alien.accessors accessors system +vocabs.loader combinators alien.c-types ; IN: io.mmap TUPLE: mapped-file address handle length disposed ; -M: mapped-file length dup check-disposed length>> ; - -M: mapped-file nth-unsafe - dup check-disposed address>> swap alien-unsigned-1 ; - -M: mapped-file set-nth-unsafe - dup check-disposed address>> swap set-alien-unsigned-1 ; - -INSTANCE: mapped-file sequence - HOOK: (mapped-file) io-backend ( path length -- address handle ) -: ( path length -- mmap ) - [ >r normalize-path r> (mapped-file) ] keep +: ( path -- mmap ) + [ normalize-path ] [ file-info size>> ] bi [ (mapped-file) ] keep f mapped-file boa ; HOOK: close-mapped-file io-backend ( mmap -- ) M: mapped-file dispose* ( mmap -- ) close-mapped-file ; -: with-mapped-file ( path length quot -- ) - >r r> with-disposal ; inline +: with-mapped-file ( path quot -- ) + [ ] dip with-disposal ; inline { { [ os unix? ] [ "io.unix.mmap" require ] } diff --git a/basis/io/mmap/short/short.factor b/basis/io/mmap/short/short.factor new file mode 100644 index 0000000000..add58157f9 --- /dev/null +++ b/basis/io/mmap/short/short.factor @@ -0,0 +1,4 @@ +USING: io.mmap.functor specialized-arrays.direct.short ; +IN: io.mmap.short + +<< "short" define-mapped-array >> \ No newline at end of file diff --git a/basis/io/mmap/uchar/uchar.factor b/basis/io/mmap/uchar/uchar.factor new file mode 100644 index 0000000000..d30fb60251 --- /dev/null +++ b/basis/io/mmap/uchar/uchar.factor @@ -0,0 +1,4 @@ +USING: io.mmap.functor specialized-arrays.direct.uchar ; +IN: io.mmap.uchar + +<< "uchar" define-mapped-array >> \ No newline at end of file diff --git a/basis/io/mmap/uint/uint.factor b/basis/io/mmap/uint/uint.factor new file mode 100644 index 0000000000..926a0f4af8 --- /dev/null +++ b/basis/io/mmap/uint/uint.factor @@ -0,0 +1,4 @@ +USING: io.mmap.functor specialized-arrays.direct.uint ; +IN: io.mmap.uint + +<< "uint" define-mapped-array >> \ No newline at end of file diff --git a/basis/io/mmap/ulong/ulong.factor b/basis/io/mmap/ulong/ulong.factor new file mode 100644 index 0000000000..80f70b3596 --- /dev/null +++ b/basis/io/mmap/ulong/ulong.factor @@ -0,0 +1,4 @@ +USING: io.mmap.functor specialized-arrays.direct.ulong ; +IN: io.mmap.ulong + +<< "ulong" define-mapped-array >> \ No newline at end of file diff --git a/basis/io/mmap/ulonglong/ulonglong.factor b/basis/io/mmap/ulonglong/ulonglong.factor new file mode 100644 index 0000000000..91f481cef9 --- /dev/null +++ b/basis/io/mmap/ulonglong/ulonglong.factor @@ -0,0 +1,4 @@ +USING: io.mmap.functor specialized-arrays.direct.ulonglong ; +IN: io.mmap.ulonglong + +<< "ulonglong" define-mapped-array >> \ No newline at end of file diff --git a/basis/io/mmap/ushort/ushort.factor b/basis/io/mmap/ushort/ushort.factor new file mode 100644 index 0000000000..e0989aa9d4 --- /dev/null +++ b/basis/io/mmap/ushort/ushort.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.ushort + +<< "ushort" define-array >> \ No newline at end of file diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index 6f542361ee..1fc5fe9226 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -80,7 +80,7 @@ TUPLE: unix-file-system-info < file-system-info block-size preferred-block-size blocks blocks-free blocks-available files files-free files-available -name-max flags id id0 id1 ; +name-max flags id ; HOOK: new-file-system-info os ( -- file-system-info ) @@ -108,8 +108,6 @@ M: unix statvfs>file-system-info drop ; [ dup [ blocks-free>> ] [ block-size>> ] bi * >>free-space drop ] [ dup [ blocks>> ] [ block-size>> ] bi * >>total-space drop ] [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] - [ dup id>> 2 c-uint-array> first2 [ >>id0 ] [ >>id1 ] bi* drop ] - [ f >>id drop ] [ ] } cleave ; @@ -316,8 +314,7 @@ PRIVATE> ] keep - dup length [ over [ pick set-timeval-nth ] [ 2drop ] if ] 2each ; + [ [ "timeval" ] unless* ] map concat ; : timestamp>timeval ( timestamp -- timeval ) unix-1970 time- duration>microseconds make-timeval ; diff --git a/basis/io/unix/pipes/pipes.factor b/basis/io/unix/pipes/pipes.factor index 53c336c555..a28738e147 100644 --- a/basis/io/unix/pipes/pipes.factor +++ b/basis/io/unix/pipes/pipes.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: system alien.c-types kernel unix math sequences -qualified io.unix.backend io.ports ; +USING: system kernel unix math sequences qualified +io.unix.backend io.ports specialized-arrays.int accessors ; IN: io.unix.pipes QUALIFIED: io.pipes M: unix io.pipes:(pipe) ( -- pair ) - 2 "int" - dup pipe io-error - 2 c-int-array> first2 [ init-fd ] bi@ io.pipes:pipe boa ; + 2 + [ underlying>> pipe io-error ] + [ first2 [ init-fd ] bi@ io.pipes:pipe boa ] bi ; diff --git a/basis/io/windows/launcher/launcher.factor b/basis/io/windows/launcher/launcher.factor index d1ad309dd5..212b405a54 100644 --- a/basis/io/windows/launcher/launcher.factor +++ b/basis/io/windows/launcher/launcher.factor @@ -6,7 +6,8 @@ windows.types math windows.kernel32 namespaces make io.launcher kernel sequences windows.errors splitting system threads init strings combinators io.backend accessors concurrency.flags io.files assocs -io.files.private windows destructors ; +io.files.private windows destructors specialized-arrays.ushort +specialized-arrays.alien ; IN: io.windows.launcher TUPLE: CreateProcess-args @@ -45,7 +46,7 @@ TUPLE: CreateProcess-args CreateProcess win32-error=0/f ; : count-trailing-backslashes ( str n -- str n ) - >r "\\" ?tail r> swap [ + [ "\\" ?tail ] dip swap [ 1+ count-trailing-backslashes ] when ; @@ -84,8 +85,7 @@ TUPLE: CreateProcess-args : fill-lpApplicationName ( process args -- process args ) over app-name/cmd-line - >r >>lpApplicationName - r> >>lpCommandLine ; + [ >>lpApplicationName ] [ >>lpCommandLine ] bi* ; : fill-lpCommandLine ( process args -- process args ) over cmd-line >>lpCommandLine ; @@ -103,7 +103,7 @@ TUPLE: CreateProcess-args over get-environment [ swap % "=" % % "\0" % ] assoc-each "\0" % - ] "" make >c-ushort-array + ] ushort-array{ } make underlying>> >>lpEnvironment ] when ; @@ -157,8 +157,8 @@ M: windows kill-process* ( handle -- ) M: windows wait-for-processes ( -- ? ) processes get keys dup - [ handle>> PROCESS_INFORMATION-hProcess ] map - dup length swap >c-void*-array 0 0 + [ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as + [ length ] [ underlying>> ] bi 0 0 WaitForMultipleObjects dup HEX: ffffffff = [ win32-error ] when dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ; diff --git a/basis/io/windows/nt/monitors/monitors.factor b/basis/io/windows/nt/monitors/monitors.factor old mode 100644 new mode 100755 index 2680b40089..30345c8c69 --- a/basis/io/windows/nt/monitors/monitors.factor +++ b/basis/io/windows/nt/monitors/monitors.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types libc destructors locals kernel math -assocs namespaces make continuations sequences hashtables -sorting arrays combinators math.bitwise strings system accessors -threads splitting io.backend io.windows io.windows.nt.backend -io.windows.nt.files io.monitors io.ports io.buffers io.files -io.timeouts io windows windows.kernel32 windows.types ; +USING: alien alien.c-types alien.strings libc destructors locals +kernel math assocs namespaces make continuations sequences +hashtables sorting arrays combinators math.bitwise strings +system accessors threads splitting io.backend io.windows +io.windows.nt.backend io.windows.nt.files io.monitors io.ports +io.buffers io.files io.timeouts io.encodings.string io +windows windows.kernel32 windows.types ; IN: io.windows.nt.monitors : open-directory ( path -- handle ) @@ -50,7 +51,7 @@ TUPLE: win32-monitor < monitor port ; } case 1array ; : memory>u16-string ( alien len -- string ) - [ memory>byte-array ] keep 2/ c-ushort-array> >string ; + memory>byte-array utf16n decode ; : parse-notify-record ( buffer -- path changed ) [ diff --git a/basis/libc/libc-docs.factor b/basis/libc/libc-docs.factor index 37a3b7068f..b89f4174bf 100644 --- a/basis/libc/libc-docs.factor +++ b/basis/libc/libc-docs.factor @@ -32,10 +32,6 @@ HELP: free { $values { "alien" c-ptr } } { $description "Deallocates a block of memory allocated by " { $link malloc } ", " { $link calloc } " or " { $link realloc } "." } ; -HELP: with-malloc -{ $values { "size" "a positive integer" } { "quot" { $quotation "( c-ptr -- )" } } } -{ $description "Allocates a zeroed block of " { $snippet "n" } " bytes and passes it to the quotation. When the quotation returns, the block is freed." } ; - HELP: &free { $values { "alien" c-ptr } } { $description "Marks the block of memory for unconditional deallocation at the end of the current " { $link with-destructors } " scope." } ; diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index cf4e2fb722..c4d351e6a0 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -87,9 +87,6 @@ PRIVATE> : memcpy ( dst src size -- ) "void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ; -: with-malloc ( size quot -- ) - swap 1 calloc [ swap keep ] [ free ] [ ] cleanup ; inline - : strlen ( alien -- len ) "size_t" "libc" "strlen" { "char*" } alien-invoke ; diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index d2b057953c..b78b95bc24 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -316,27 +316,26 @@ SYMBOL: in-lambda? "|" parse-tokens make-locals dup push-locals \ ] (parse-lambda) ; -: parse-binding ( -- pair/f ) +: parse-binding ( end -- pair/f ) scan { { [ dup not ] [ unexpected-eof ] } - { [ dup "|" = ] [ drop f ] } - { [ dup "!" = ] [ drop POSTPONE: ! parse-binding ] } - [ scan-object 2array ] + { [ 2dup = ] [ 2drop f ] } + [ nip scan-object 2array ] } cond ; -: (parse-bindings) ( -- ) - parse-binding [ +: (parse-bindings) ( end -- ) + dup parse-binding dup [ first2 [ make-local ] dip 2array , (parse-bindings) - ] when* ; + ] [ 2drop ] if ; -: parse-bindings ( -- bindings vars ) +: parse-bindings ( end -- bindings vars ) [ [ (parse-bindings) ] H{ } make-assoc dup push-locals ] { } make swap ; -: parse-bindings* ( -- words assoc ) +: parse-bindings* ( end -- words assoc ) [ [ namespace push-locals @@ -345,13 +344,13 @@ SYMBOL: in-lambda? ] { } make-assoc ] { } make swap ; -: (parse-wbindings) ( -- ) - parse-binding [ +: (parse-wbindings) ( end -- ) + dup parse-binding dup [ first2 [ make-local-word ] keep 2array , (parse-wbindings) - ] when* ; + ] [ 2drop ] if ; -: parse-wbindings ( -- bindings vars ) +: parse-wbindings ( end -- bindings vars ) [ [ (parse-wbindings) ] H{ } make-assoc dup push-locals @@ -374,12 +373,12 @@ M: wlet local-rewrite* let-rewrite ; : parse-locals ( -- vars assoc ) - ")" parse-effect + "(" expect ")" parse-effect word [ over "declared-effect" set-word-prop ] when* in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ; : parse-locals-definition ( word -- word quot ) - "(" expect parse-locals \ ; (parse-lambda) + parse-locals \ ; (parse-lambda) 2dup "lambda" set-word-prop lambda-rewrite dup length 1 = [ first ] [ bad-lambda-rewrite ] if ; @@ -397,15 +396,15 @@ PRIVATE> : [| parse-lambda parsed-lambda ; parsing : [let - "|" expect parse-bindings + "|" expect "|" parse-bindings \ ] (parse-lambda) parsed-lambda ; parsing : [let* - "|" expect parse-bindings* + "|" expect "|" parse-bindings* \ ] (parse-lambda) parsed-lambda ; parsing : [wlet - "|" expect parse-wbindings + "|" expect "|" parse-wbindings \ ] (parse-lambda) parsed-lambda ; parsing : :: (::) define ; parsing diff --git a/basis/nibble-arrays/nibble-arrays-tests.factor b/basis/nibble-arrays/nibble-arrays-tests.factor new file mode 100644 index 0000000000..2a0eef7227 --- /dev/null +++ b/basis/nibble-arrays/nibble-arrays-tests.factor @@ -0,0 +1,6 @@ +USING: nibble-arrays tools.test sequences kernel math ; +IN: nibble-arrays.tests + +[ t ] [ 16 dup >nibble-array sequence= ] unit-test +[ N{ 4 2 1 3 } ] [ N{ 3 1 2 4 } reverse ] unit-test +[ N{ 1 4 9 0 9 4 } ] [ N{ 1 2 3 4 5 6 } [ sq ] map ] unit-test diff --git a/basis/nibble-arrays/nibble-arrays.factor b/basis/nibble-arrays/nibble-arrays.factor new file mode 100644 index 0000000000..c753d0fb78 --- /dev/null +++ b/basis/nibble-arrays/nibble-arrays.factor @@ -0,0 +1,71 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: math kernel sequences sequences.private byte-arrays +alien.c-types prettyprint.backend parser accessors ; +IN: nibble-arrays + +TUPLE: nibble-array +{ length array-capacity read-only } +{ underlying byte-array read-only } ; + +bytes 1 + 2/ ; inline + +: byte/nibble ( n -- shift n' ) + [ 1 bitand 2 shift ] [ -1 shift ] bi ; inline + +: get-nibble ( n byte -- nibble ) + swap neg shift nibble bitand ; inline + +: set-nibble ( value n byte -- byte' ) + nibble pick shift bitnot bitand -rot shift bitor ; inline + +: nibble@ ( n nibble-array -- shift n' byte-array ) + [ >fixnum byte/nibble ] [ underlying>> ] bi* ; inline + +PRIVATE> + +: ( n -- nibble-array ) + dup nibbles>bytes nibble-array boa ; inline + +M: nibble-array length length>> ; + +M: nibble-array nth-unsafe + nibble@ nth-unsafe get-nibble ; + +M: nibble-array set-nth-unsafe + nibble@ [ nth-unsafe set-nibble ] 2keep set-nth-unsafe ; + +M: nibble-array clone + [ length>> ] [ underlying>> clone ] bi nibble-array boa ; + +: >nibble-array ( seq -- nibble-array ) + T{ nibble-array } clone-like ; inline + +M: nibble-array like + drop dup nibble-array? [ >nibble-array ] unless ; + +M: nibble-array new-sequence drop ; + +M: nibble-array equal? + over nibble-array? [ sequence= ] [ 2drop f ] if ; + +M: nibble-array resize + [ drop ] [ + [ nibbles>bytes ] [ underlying>> ] bi* + resize-byte-array + ] 2bi + nibble-array boa ; + +M: nibble-array byte-length length nibbles>bytes ; + +: N{ \ } [ >nibble-array ] parse-literal ; parsing + +INSTANCE: nibble-array sequence + +M: nibble-array pprint-delims drop \ N{ \ } ; +M: nibble-array >pprint-sequence ; +M: nibble-array pprint* pprint-object ; diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index d9a9b9bf40..10f9c57a83 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -6,7 +6,8 @@ USING: alien alien.c-types continuations kernel libc math macros namespaces math.vectors math.constants math.functions math.parser opengl.gl opengl.glu combinators arrays sequences splitting words byte-arrays assocs colors accessors -generalizations locals memoize ; +generalizations locals specialized-arrays.float +specialized-arrays.uint ; IN: opengl : color>raw ( object -- r g b a ) @@ -52,20 +53,20 @@ MACRO: all-enabled-client-state ( seq quot -- ) glMatrixMode glPopMatrix ; inline : gl-material ( face pname params -- ) - >c-float-array glMaterialfv ; + float-array{ } like underlying>> glMaterialfv ; : gl-vertex-pointer ( seq -- ) - [ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline + [ 2 GL_FLOAT 0 ] dip underlying>> glVertexPointer ; inline : gl-color-pointer ( seq -- ) - [ 4 GL_FLOAT 0 ] dip glColorPointer ; inline + [ 4 GL_FLOAT 0 ] dip underlying>> glColorPointer ; inline : gl-texture-coord-pointer ( seq -- ) - [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline + [ 2 GL_FLOAT 0 ] dip underlying>> glTexCoordPointer ; inline : line-vertices ( a b -- ) - [ first2 [ 0.5 + ] bi@ ] bi@ 4 narray - >c-float-array gl-vertex-pointer ; + [ first2 [ 0.5 + ] bi@ ] bi@ 4 float-array{ } nsequence + gl-vertex-pointer ; : gl-line ( a b -- ) line-vertices GL_LINES 0 2 glDrawArrays ; @@ -80,7 +81,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) [ [ first 0.3 - ] [ second 0.3 - ] bi ] [ second 0.3 - 0.5 swap ] [ drop 0.5 0.5 ] - } cleave 10 narray >c-float-array ; + } cleave 10 float-array{ } nsequence ; : rect-vertices ( dim -- ) (rect-vertices) gl-vertex-pointer ; @@ -97,7 +98,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) [ first 0 ] [ first2 ] [ second 0 swap ] - } cleave 8 narray >c-float-array ; + } cleave 8 float-array{ } nsequence ; : fill-rect-vertices ( dim -- ) (fill-rect-vertices) gl-vertex-pointer ; @@ -130,10 +131,10 @@ MACRO: all-enabled-client-state ( seq quot -- ) #! We use GL_LINE_STRIP with a duplicated first vertex #! instead of GL_LINE_LOOP to work around a bug in Apple's #! X3100 driver. - circle-points close-path concat >c-float-array ; + circle-points close-path concat >float-array ; : fill-circle-vertices ( loc dim steps -- vertices ) - circle-points concat >c-float-array ; + circle-points concat >float-array ; : (gen-gl-object) ( quot -- id ) [ 1 0 ] dip keep *uint ; inline @@ -174,7 +175,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) glActiveTexture swap glBindTexture gl-error ; : (set-draw-buffers) ( buffers -- ) - dup length swap >c-uint-array glDrawBuffers ; + [ length ] [ >uint-array underlying>> ] bi glDrawBuffers ; MACRO: set-draw-buffers ( buffers -- ) words>values [ (set-draw-buffers) ] curry ; @@ -219,11 +220,8 @@ TUPLE: sprite loc dim dim2 dlist texture ; : gl-translate ( point -- ) first2 0.0 glTranslated ; -MEMO: (rect-texture-coords) ( -- seq ) - { 0 0 1 0 1 1 0 1 } >c-float-array ; - : rect-texture-coords ( -- ) - (rect-texture-coords) gl-texture-coord-pointer ; + float-array{ 0 0 1 0 1 1 0 1 } gl-texture-coord-pointer ; : draw-sprite ( sprite -- ) GL_TEXTURE_COORD_ARRAY [ diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index c31d338fac..5610ef18c2 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. ! mersenne twister based on ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c -USING: arrays kernel math namespaces sequences system init +USING: kernel math namespaces sequences system init accessors math.ranges random circular math.bitwise -combinators ; +combinators specialized-arrays.uint ; IN: random.mersenne-twister r 1+ r> set-nth ] 2bi + [ init-mt-formula ] [ [ 1+ ] dip set-nth ] 2bi ] curry each ; : init-mt-seq ( seed -- seq ) - 32 bits mt-n 0 + 32 bits mt-n [ set-first ] [ init-mt-rest ] [ ] tri ; : mt-temper ( y -- yt ) diff --git a/basis/serialize/serialize-tests.factor b/basis/serialize/serialize-tests.factor index 4ed534151b..99c6d0e255 100644 --- a/basis/serialize/serialize-tests.factor +++ b/basis/serialize/serialize-tests.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: tools.test kernel serialize serialize.private io -io.streams.byte-array math alien arrays byte-arrays bit-arrays -float-arrays sequences math prettyprint parser classes -math.constants io.encodings.binary random assocs ; +USING: tools.test kernel serialize io io.streams.byte-array math +alien arrays byte-arrays bit-arrays specialized-arrays.double +sequences math prettyprint parser classes math.constants +io.encodings.binary random assocs serialize.private ; IN: serialize.tests : test-serialize-cell @@ -48,7 +48,7 @@ C: serialize-test T{ serialize-test f "a" 2 } B{ 50 13 55 64 1 } ?{ t f t f f t f } - F{ 1.0 3.0 4.0 1.0 2.35 0.33 } + double-array{ 1.0 3.0 4.0 1.0 2.35 0.33 } << 1 [ 2 ] curry parsed >> { { "a" "bc" } { "de" "fg" } } H{ { "a" "bc" } { "de" "fg" } } diff --git a/basis/specialized-arrays/alien/alien.factor b/basis/specialized-arrays/alien/alien.factor new file mode 100644 index 0000000000..465d1665f9 --- /dev/null +++ b/basis/specialized-arrays/alien/alien.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.alien + +<< "void*" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/authors.txt b/basis/specialized-arrays/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/specialized-arrays/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/specialized-arrays/bool/bool.factor b/basis/specialized-arrays/bool/bool.factor new file mode 100644 index 0000000000..759ee91abc --- /dev/null +++ b/basis/specialized-arrays/bool/bool.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.bool + +<< "bool" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/char/char.factor b/basis/specialized-arrays/char/char.factor new file mode 100644 index 0000000000..cdf78eeef8 --- /dev/null +++ b/basis/specialized-arrays/char/char.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.char + +<< "char" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/alien/alien.factor b/basis/specialized-arrays/direct/alien/alien.factor new file mode 100644 index 0000000000..3949c40352 --- /dev/null +++ b/basis/specialized-arrays/direct/alien/alien.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.alien specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.alien + +<< "void*" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/bool/bool.factor b/basis/specialized-arrays/direct/bool/bool.factor new file mode 100644 index 0000000000..689fcc3069 --- /dev/null +++ b/basis/specialized-arrays/direct/bool/bool.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.bool specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.bool + +<< "bool" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/char/char.factor b/basis/specialized-arrays/direct/char/char.factor new file mode 100644 index 0000000000..cca3a62010 --- /dev/null +++ b/basis/specialized-arrays/direct/char/char.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.char specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.char + +<< "char" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/direct-docs.factor b/basis/specialized-arrays/direct/direct-docs.factor new file mode 100644 index 0000000000..e2638c4af4 --- /dev/null +++ b/basis/specialized-arrays/direct/direct-docs.factor @@ -0,0 +1,33 @@ +USING: help.markup help.syntax byte-arrays alien ; +IN: specialized-arrays.direct + +ARTICLE: "specialized-arrays.direct" "Direct-mapped specialized arrays" +"The " { $vocab-link "specialized-arrays.direct" } " vocabulary implements fixed-length sequence types for storing machine values in unmanaged C memory." +$nl +"For each primitive C type " { $snippet "T" } ", a set of words are defined:" +{ $table + { { $snippet "direct-T-array" } { "The class of direct arrays with elements of type " { $snippet "T" } } } + { { $snippet "" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( alien len -- array )" } } } +} +"Each direct array has a " { $slot "underlying" } " slot holding an " { $link simple-alien } " pointer to the raw data. This data can be passed to C functions." +$nl +"The primitive C types for which direct arrays exist:" +{ $list + { $snippet "char" } + { $snippet "uchar" } + { $snippet "short" } + { $snippet "ushort" } + { $snippet "int" } + { $snippet "uint" } + { $snippet "long" } + { $snippet "ulong" } + { $snippet "longlong" } + { $snippet "ulonglong" } + { $snippet "float" } + { $snippet "double" } + { $snippet "void*" } + { $snippet "bool" } +} +"Direct arrays are generated with a functor in the " { $vocab-link "specialized-arrays.direct.functor" } " vocabulary." ; + +ABOUT: "specialized-arrays.direct" diff --git a/basis/specialized-arrays/direct/direct-tests.factor b/basis/specialized-arrays/direct/direct-tests.factor new file mode 100644 index 0000000000..2a48b5d3d3 --- /dev/null +++ b/basis/specialized-arrays/direct/direct-tests.factor @@ -0,0 +1,7 @@ +IN: specialized-arrays.direct.tests +USING: specialized-arrays.direct.ushort tools.test +specialized-arrays.ushort alien.syntax sequences ; + +[ ushort-array{ 0 0 0 } ] [ + 3 ALIEN: 123 100 new-sequence +] unit-test diff --git a/basis/specialized-arrays/direct/direct.factor b/basis/specialized-arrays/direct/direct.factor new file mode 100644 index 0000000000..7c15c66415 --- /dev/null +++ b/basis/specialized-arrays/direct/direct.factor @@ -0,0 +1,3 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: specialized-arrays.direct diff --git a/basis/specialized-arrays/direct/double/double.factor b/basis/specialized-arrays/direct/double/double.factor new file mode 100644 index 0000000000..c3089b3e48 --- /dev/null +++ b/basis/specialized-arrays/direct/double/double.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.double specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.double + +<< "double" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/float/float.factor b/basis/specialized-arrays/direct/float/float.factor new file mode 100644 index 0000000000..94caa95685 --- /dev/null +++ b/basis/specialized-arrays/direct/float/float.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.float specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.float + +<< "float" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor new file mode 100755 index 0000000000..2cde26b731 --- /dev/null +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: functors sequences sequences.private kernel words classes +math alien alien.c-types byte-arrays accessors +specialized-arrays ; +IN: specialized-arrays.direct.functor + +FUNCTOR: define-direct-array ( T -- ) + +A' IS ${T}-array +>A' IS >${T}-array + IS <${A'}> + +A DEFINES direct-${T}-array + DEFINES <${A}> + +NTH [ T dup c-getter array-accessor ] +SET-NTH [ T dup c-setter array-accessor ] + +WHERE + +TUPLE: A +{ underlying alien read-only } +{ length fixnum read-only } ; + +: ( alien len -- direct-array ) A boa ; inline +M: A length length>> ; +M: A nth-unsafe underlying>> NTH call ; +M: A set-nth-unsafe underlying>> SET-NTH call ; +M: A like drop dup A instance? [ >A' execute ] unless ; +M: A new-sequence drop execute ; + +INSTANCE: A sequence + +;FUNCTOR diff --git a/basis/specialized-arrays/direct/int/int.factor b/basis/specialized-arrays/direct/int/int.factor new file mode 100644 index 0000000000..c204e2706f --- /dev/null +++ b/basis/specialized-arrays/direct/int/int.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.int specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.int + +<< "int" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/long/long.factor b/basis/specialized-arrays/direct/long/long.factor new file mode 100644 index 0000000000..33c52bb524 --- /dev/null +++ b/basis/specialized-arrays/direct/long/long.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.long specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.long + +<< "long" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/longlong/longlong.factor b/basis/specialized-arrays/direct/longlong/longlong.factor new file mode 100644 index 0000000000..f132000227 --- /dev/null +++ b/basis/specialized-arrays/direct/longlong/longlong.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.longlong specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.longlong + +<< "longlong" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/short/short.factor b/basis/specialized-arrays/direct/short/short.factor new file mode 100644 index 0000000000..f837bebb84 --- /dev/null +++ b/basis/specialized-arrays/direct/short/short.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.short specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.short + +<< "short" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/uchar/uchar.factor b/basis/specialized-arrays/direct/uchar/uchar.factor new file mode 100644 index 0000000000..34409798ad --- /dev/null +++ b/basis/specialized-arrays/direct/uchar/uchar.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.uchar specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.uchar + +<< "uchar" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/uint/uint.factor b/basis/specialized-arrays/direct/uint/uint.factor new file mode 100644 index 0000000000..22f7ba333f --- /dev/null +++ b/basis/specialized-arrays/direct/uint/uint.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.uint specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.uint + +<< "uint" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/ulong/ulong.factor b/basis/specialized-arrays/direct/ulong/ulong.factor new file mode 100644 index 0000000000..8a568ab631 --- /dev/null +++ b/basis/specialized-arrays/direct/ulong/ulong.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.ulong specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.ulong + +<< "ulong" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/ulonglong/ulonglong.factor b/basis/specialized-arrays/direct/ulonglong/ulonglong.factor new file mode 100644 index 0000000000..10fa178c41 --- /dev/null +++ b/basis/specialized-arrays/direct/ulonglong/ulonglong.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.ulonglong specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.ulonglong + +<< "ulonglong" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/direct/ushort/ushort.factor b/basis/specialized-arrays/direct/ushort/ushort.factor new file mode 100644 index 0000000000..6bd34c7eee --- /dev/null +++ b/basis/specialized-arrays/direct/ushort/ushort.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.ushort specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.ushort + +<< "ushort" define-direct-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/double/double.factor b/basis/specialized-arrays/double/double.factor new file mode 100644 index 0000000000..b7fc3a8143 --- /dev/null +++ b/basis/specialized-arrays/double/double.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.double + +<< "double" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/float/float.factor b/basis/specialized-arrays/float/float.factor new file mode 100644 index 0000000000..5d9da66739 --- /dev/null +++ b/basis/specialized-arrays/float/float.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.float + +<< "float" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor new file mode 100644 index 0000000000..52977dc22a --- /dev/null +++ b/basis/specialized-arrays/functor/functor.factor @@ -0,0 +1,71 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: functors sequences sequences.private prettyprint.backend +kernel words classes math parser alien.c-types byte-arrays +accessors summary ; +IN: specialized-arrays.functor + +ERROR: bad-byte-array-length byte-array type ; + +M: bad-byte-array-length summary + drop "Byte array length doesn't divide type width" ; + +FUNCTOR: define-array ( T -- ) + +A DEFINES ${T}-array + DEFINES <${A}> +>A DEFINES >${A} +byte-array>A DEFINES byte-array>${A} +A{ DEFINES ${A}{ + +NTH [ T dup c-getter array-accessor ] +SET-NTH [ T dup c-setter array-accessor ] + +WHERE + +TUPLE: A +{ length array-capacity read-only } +{ underlying byte-array read-only } ; + +: ( n -- specialized-array ) dup T A boa ; inline + +: byte-array>A ( byte-array -- specialized-array ) + dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless + swap A boa ; inline + +M: A clone [ length>> ] [ underlying>> clone ] bi A boa ; + +M: A length length>> ; + +M: A nth-unsafe underlying>> NTH call ; + +M: A set-nth-unsafe underlying>> SET-NTH call ; + +: >A ( seq -- specialized-array ) A new clone-like ; inline + +M: A like drop dup A instance? [ >A execute ] unless ; + +M: A new-sequence drop execute ; + +M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ; + +M: A resize + [ drop ] [ + [ T heap-size * ] [ underlying>> ] bi* + resize-byte-array + ] 2bi + A boa ; + +M: A byte-length underlying>> length ; + +M: A pprint-delims drop A{ \ } ; + +M: A >pprint-sequence ; + +M: A pprint* pprint-object ; + +: A{ \ } [ >A execute ] parse-literal ; parsing + +INSTANCE: A sequence + +;FUNCTOR diff --git a/basis/specialized-arrays/int/int.factor b/basis/specialized-arrays/int/int.factor new file mode 100644 index 0000000000..37f4b59c80 --- /dev/null +++ b/basis/specialized-arrays/int/int.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.int + +<< "int" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/long/long.factor b/basis/specialized-arrays/long/long.factor new file mode 100644 index 0000000000..2cba6424eb --- /dev/null +++ b/basis/specialized-arrays/long/long.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.long + +<< "long" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/longlong/longlong.factor b/basis/specialized-arrays/longlong/longlong.factor new file mode 100644 index 0000000000..195dd78f7b --- /dev/null +++ b/basis/specialized-arrays/longlong/longlong.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.longlong + +<< "longlong" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/short/short.factor b/basis/specialized-arrays/short/short.factor new file mode 100644 index 0000000000..3891462159 --- /dev/null +++ b/basis/specialized-arrays/short/short.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.short + +<< "short" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/specialized-arrays-docs.factor b/basis/specialized-arrays/specialized-arrays-docs.factor new file mode 100644 index 0000000000..1c1b3dbc59 --- /dev/null +++ b/basis/specialized-arrays/specialized-arrays-docs.factor @@ -0,0 +1,40 @@ +USING: help.markup help.syntax byte-arrays ; +IN: specialized-arrays + +ARTICLE: "specialized-arrays" "Specialized arrays" +"The " { $vocab-link "specialized-arrays" } " vocabulary implements fixed-length sequence types for storing machine values in a space-efficient manner without boxing." +$nl +"For each primitive C type " { $snippet "T" } ", a set of words are defined in the vocabulary named " { $snippet "specialized-arrays.T" } ":" +{ $table + { { $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" } { "Converts a sequence into a specialized array of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- array )" } } } + { { $snippet "byte-array>T-array" } { "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{" } { "Literal syntax, consists of a series of values terminated by " { $snippet "}" } } } +} +"Each specialized array has a " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. This data can be passed to C functions." +$nl +"The primitive C types for which specialized arrays exist:" +{ $list + { $snippet "char" } + { $snippet "uchar" } + { $snippet "short" } + { $snippet "ushort" } + { $snippet "int" } + { $snippet "uint" } + { $snippet "long" } + { $snippet "ulong" } + { $snippet "longlong" } + { $snippet "ulonglong" } + { $snippet "float" } + { $snippet "double" } + { $snippet "void*" } + { $snippet "bool" } +} +"Note that " { $vocab-link "specialized-arrays.bool" } " behaves like a C " { $snippet "bool[]" } " array, and each element takes up 8 bits of space. For a more space-efficient boolean array, see " { $link "bit-arrays" } "." +$nl +"Specialized arrays are generated with a functor in the " { $vocab-link "specialized-arrays.functor" } " vocabulary." +$nl +"The " { $vocab-link "specialized-vectors" } " vocabulary provides resizable versions of the above." ; + +ABOUT: "specialized-arrays" diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor new file mode 100644 index 0000000000..1ca041191e --- /dev/null +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -0,0 +1,18 @@ +IN: specialized-arrays.tests +USING: tools.test specialized-arrays sequences +specialized-arrays.int specialized-arrays.bool +specialized-arrays.ushort alien.c-types accessors kernel ; + +[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test + +[ t ] [ int-array{ 1 2 3 } int-array? ] unit-test + +[ 2 ] [ int-array{ 1 2 3 } second ] unit-test + +[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >int-array underlying>> = ] unit-test + +[ ushort-array{ 1234 } ] [ + little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array +] unit-test + +[ B{ 210 4 1 } byte-array>ushort-array ] must-fail diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor new file mode 100644 index 0000000000..631d28ddd9 --- /dev/null +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -0,0 +1,3 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: specialized-arrays diff --git a/basis/specialized-arrays/summary.txt b/basis/specialized-arrays/summary.txt new file mode 100644 index 0000000000..6191766134 --- /dev/null +++ b/basis/specialized-arrays/summary.txt @@ -0,0 +1 @@ +Arrays of unboxed primitive C types diff --git a/basis/float-arrays/tags.txt b/basis/specialized-arrays/tags.txt similarity index 100% rename from basis/float-arrays/tags.txt rename to basis/specialized-arrays/tags.txt diff --git a/basis/specialized-arrays/uchar/uchar.factor b/basis/specialized-arrays/uchar/uchar.factor new file mode 100644 index 0000000000..c6ed4f3ab6 --- /dev/null +++ b/basis/specialized-arrays/uchar/uchar.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.uchar + +<< "uchar" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/uint/uint.factor b/basis/specialized-arrays/uint/uint.factor new file mode 100644 index 0000000000..1534a3d158 --- /dev/null +++ b/basis/specialized-arrays/uint/uint.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.uint + +<< "uint" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/ulong/ulong.factor b/basis/specialized-arrays/ulong/ulong.factor new file mode 100644 index 0000000000..27dc1295b3 --- /dev/null +++ b/basis/specialized-arrays/ulong/ulong.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.ulong + +<< "ulong" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/ulonglong/ulonglong.factor b/basis/specialized-arrays/ulonglong/ulonglong.factor new file mode 100644 index 0000000000..cbb2b3cf9d --- /dev/null +++ b/basis/specialized-arrays/ulonglong/ulonglong.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.ulonglong + +<< "ulonglong" define-array >> \ No newline at end of file diff --git a/basis/specialized-arrays/ushort/ushort.factor b/basis/specialized-arrays/ushort/ushort.factor new file mode 100644 index 0000000000..e0989aa9d4 --- /dev/null +++ b/basis/specialized-arrays/ushort/ushort.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.ushort + +<< "ushort" define-array >> \ No newline at end of file diff --git a/basis/specialized-vectors/alien/alien.factor b/basis/specialized-vectors/alien/alien.factor new file mode 100644 index 0000000000..2b9855f6c9 --- /dev/null +++ b/basis/specialized-vectors/alien/alien.factor @@ -0,0 +1,4 @@ +USING: specialized-vectors.functor specialized-arrays.alien ; +IN: specialized-vectors.alien + +<< "void*" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/authors.txt b/basis/specialized-vectors/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/specialized-vectors/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/specialized-vectors/bool/bool.factor b/basis/specialized-vectors/bool/bool.factor new file mode 100644 index 0000000000..75d452a1d8 --- /dev/null +++ b/basis/specialized-vectors/bool/bool.factor @@ -0,0 +1,4 @@ +USING: specialized-vectors.functor specialized-arrays.bool ; +IN: specialized-vectors.bool + +<< "bool" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/char/char.factor b/basis/specialized-vectors/char/char.factor new file mode 100644 index 0000000000..c34167cb6c --- /dev/null +++ b/basis/specialized-vectors/char/char.factor @@ -0,0 +1,4 @@ +USING: specialized-vectors.functor specialized-arrays.char ; +IN: specialized-vectors.char + +<< "char" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/double/double.factor b/basis/specialized-vectors/double/double.factor new file mode 100644 index 0000000000..5e77162517 --- /dev/null +++ b/basis/specialized-vectors/double/double.factor @@ -0,0 +1,4 @@ +USING: specialized-vectors.functor specialized-arrays.double ; +IN: specialized-vectors.double + +<< "double" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/float/float.factor b/basis/specialized-vectors/float/float.factor new file mode 100644 index 0000000000..010b4486cf --- /dev/null +++ b/basis/specialized-vectors/float/float.factor @@ -0,0 +1,4 @@ +USING: specialized-vectors.functor specialized-arrays.float ; +IN: specialized-vectors.float + +<< "float" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor new file mode 100644 index 0000000000..0628f8b484 --- /dev/null +++ b/basis/specialized-vectors/functor/functor.factor @@ -0,0 +1,46 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: functors sequences sequences.private growable +prettyprint.backend kernel words classes math parser ; +IN: specialized-vectors.functor + +FUNCTOR: define-vector ( T -- ) + +A IS ${T}-array + IS <${A}> + +V DEFINES ${T}-vector + DEFINES <${V}> +>V DEFINES >${V} +V{ DEFINES ${V}{ + +WHERE + +TUPLE: V { underlying A } { length array-capacity } ; + +: execute 0 V boa ; inline + +M: V like + drop dup V instance? [ + dup A instance? [ dup length V boa ] [ >V execute ] if + ] unless ; + +M: V new-sequence drop [ execute ] [ >fixnum ] bi V boa ; + +M: A new-resizable drop execute ; + +M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; + +: >V V new clone-like ; inline + +M: V pprint-delims drop V{ \ } ; + +M: V >pprint-sequence ; + +M: V pprint* pprint-object ; + +: V{ \ } [ >V execute ] parse-literal ; parsing + +INSTANCE: V growable + +;FUNCTOR diff --git a/basis/specialized-vectors/int/int.factor b/basis/specialized-vectors/int/int.factor new file mode 100644 index 0000000000..d77e6fd214 --- /dev/null +++ b/basis/specialized-vectors/int/int.factor @@ -0,0 +1,4 @@ +USING: specialized-vectors.functor specialized-arrays.int ; +IN: specialized-vectors.int + +<< "int" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/long/long.factor b/basis/specialized-vectors/long/long.factor new file mode 100644 index 0000000000..a026054f0b --- /dev/null +++ b/basis/specialized-vectors/long/long.factor @@ -0,0 +1,4 @@ +USING: specialized-vectors.functor specialized-arrays.long ; +IN: specialized-vectors.long + +<< "long" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/longlong/longlong.factor b/basis/specialized-vectors/longlong/longlong.factor new file mode 100644 index 0000000000..e272ea0bdf --- /dev/null +++ b/basis/specialized-vectors/longlong/longlong.factor @@ -0,0 +1,4 @@ +USING: specialized-vectors.functor specialized-arrays.longlong ; +IN: specialized-vectors.longlong + +<< "longlong" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/short/short.factor b/basis/specialized-vectors/short/short.factor new file mode 100644 index 0000000000..26ffad4245 --- /dev/null +++ b/basis/specialized-vectors/short/short.factor @@ -0,0 +1,4 @@ +USING: specialized-vectors.functor specialized-arrays.short ; +IN: specialized-vectors.short + +<< "short" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/specialized-vectors-docs.factor b/basis/specialized-vectors/specialized-vectors-docs.factor new file mode 100644 index 0000000000..5c0a15cb75 --- /dev/null +++ b/basis/specialized-vectors/specialized-vectors-docs.factor @@ -0,0 +1,35 @@ +USING: help.markup help.syntax byte-vectors ; +IN: specialized-vectors + +ARTICLE: "specialized-vectors" "Specialized vectors" +"The " { $vocab-link "specialized-vectors" } " vocabulary implements resizable sequence types for storing machine values in a space-efficient manner without boxing." +$nl +"For each primitive C type " { $snippet "T" } ", a set of words are defined:" +{ $table + { { $snippet "T-vector" } { "The class of vectors with elements of type " { $snippet "T" } } } + { { $snippet "" } { "Constructor for vectors with elements of type " { $snippet "T" } "; stack effect " { $snippet "( len -- vector )" } } } + { { $snippet ">T-vector" } { "Converts a sequence into a specialized vector of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- vector )" } } } + { { $snippet "T-vector{" } { "Literal syntax, consists of a series of values terminated by " { $snippet "}" } } } +} +"The primitive C types for which specialized vectors exist:" +{ $list + { $snippet "char" } + { $snippet "uchar" } + { $snippet "short" } + { $snippet "ushort" } + { $snippet "int" } + { $snippet "uint" } + { $snippet "long" } + { $snippet "ulong" } + { $snippet "longlong" } + { $snippet "ulonglong" } + { $snippet "float" } + { $snippet "double" } + { $snippet "void*" } + { $snippet "bool" } +} +"Specialized vectors are generated with a functor in the " { $vocab-link "specialized-vectors.functor" } " vocabulary." +$nl +"The " { $vocab-link "specialized-arrays" } " vocabulary provides fixed-length versions of the above." ; + +ABOUT: "specialized-vectors" diff --git a/basis/specialized-vectors/specialized-vectors-tests.factor b/basis/specialized-vectors/specialized-vectors-tests.factor new file mode 100644 index 0000000000..df077ce189 --- /dev/null +++ b/basis/specialized-vectors/specialized-vectors-tests.factor @@ -0,0 +1,5 @@ +IN: specialized-vectors.tests +USING: specialized-vectors.double tools.test kernel sequences ; + +[ 3 ] [ double-vector{ 1 2 } 3 over push length ] unit-test + diff --git a/basis/specialized-vectors/specialized-vectors.factor b/basis/specialized-vectors/specialized-vectors.factor new file mode 100644 index 0000000000..5df602c78d --- /dev/null +++ b/basis/specialized-vectors/specialized-vectors.factor @@ -0,0 +1,3 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: specialized-vectors diff --git a/basis/specialized-vectors/summary.txt b/basis/specialized-vectors/summary.txt new file mode 100644 index 0000000000..9df7115d02 --- /dev/null +++ b/basis/specialized-vectors/summary.txt @@ -0,0 +1 @@ +Vectors of unboxed primitive C types diff --git a/basis/float-vectors/tags.txt b/basis/specialized-vectors/tags.txt similarity index 100% rename from basis/float-vectors/tags.txt rename to basis/specialized-vectors/tags.txt diff --git a/basis/specialized-vectors/uchar/uchar.factor b/basis/specialized-vectors/uchar/uchar.factor new file mode 100644 index 0000000000..76cbd154b0 --- /dev/null +++ b/basis/specialized-vectors/uchar/uchar.factor @@ -0,0 +1,4 @@ +USING: specialized-vectors.functor specialized-arrays.uchar ; +IN: specialized-vectors.uchar + +<< "uchar" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/uint/uint.factor b/basis/specialized-vectors/uint/uint.factor new file mode 100644 index 0000000000..95800878eb --- /dev/null +++ b/basis/specialized-vectors/uint/uint.factor @@ -0,0 +1,4 @@ +USING: specialized-vectors.functor specialized-arrays.uint ; +IN: specialized-vectors.uint + +<< "uint" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/ulong/ulong.factor b/basis/specialized-vectors/ulong/ulong.factor new file mode 100644 index 0000000000..486a9dd513 --- /dev/null +++ b/basis/specialized-vectors/ulong/ulong.factor @@ -0,0 +1,4 @@ +USING: specialized-vectors.functor specialized-arrays.ulong ; +IN: specialized-vectors.ulong + +<< "ulong" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/ulonglong/ulonglong.factor b/basis/specialized-vectors/ulonglong/ulonglong.factor new file mode 100644 index 0000000000..c06ccec1c3 --- /dev/null +++ b/basis/specialized-vectors/ulonglong/ulonglong.factor @@ -0,0 +1,4 @@ +USING: specialized-vectors.functor specialized-arrays.ulonglong ; +IN: specialized-vectors.ulonglong + +<< "ulonglong" define-vector >> \ No newline at end of file diff --git a/basis/specialized-vectors/ushort/ushort.factor b/basis/specialized-vectors/ushort/ushort.factor new file mode 100644 index 0000000000..6968607919 --- /dev/null +++ b/basis/specialized-vectors/ushort/ushort.factor @@ -0,0 +1,4 @@ +USING: specialized-vectors.functor specialized-arrays.ushort ; +IN: specialized-vectors.ushort + +<< "ushort" define-vector >> \ No newline at end of file diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index e0ac391fdf..a44f7e1f89 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -40,9 +40,9 @@ urls math.parser ; [ t ] [ 1500000 small-enough? ] unit-test -[ ] [ "bunny" shake-and-bake ] unit-test +! [ ] [ "bunny" shake-and-bake ] unit-test -[ t ] [ 2500000 small-enough? ] unit-test +! [ t ] [ 2500000 small-enough? ] unit-test : run-temp-image ( -- ) vm diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 53f147ccce..15fd2a37d7 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -109,6 +109,7 @@ IN: tools.deploy.shaker "default-method" "default-output-classes" "derived-from" + "ebnf-parser" "engines" "forgotten" "identities" @@ -269,8 +270,8 @@ IN: tools.deploy.shaker } % { } { "math.partial-dispatch" } strip-vocab-globals % - - "peg-cache" "peg" lookup , + + { } { "peg" } strip-vocab-globals % ] when strip-prettyprint? [ @@ -346,7 +347,7 @@ IN: tools.deploy.shaker : finish-deploy ( final-image -- ) "Finishing up" show - >r { } set-datastack r> + [ { } set-datastack ] dip { } set-retainstack V{ } set-namestack V{ } set-catchstack @@ -387,9 +388,9 @@ SYMBOL: deploy-vocab strip-c-io f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore deploy-vocab get vocab-main set-boot-quot* - stripped-word-props >r + stripped-word-props stripped-globals strip-globals - r> strip-words + strip-words compress-byte-arrays compress-quotations compress-strings diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor index a4ef77e661..b0d152fc88 100644 --- a/basis/ui/freetype/freetype.factor +++ b/basis/ui/freetype/freetype.factor @@ -4,8 +4,7 @@ USING: alien alien.accessors alien.c-types arrays io kernel libc math math.vectors namespaces opengl opengl.gl prettyprint assocs sequences io.files io.styles continuations freetype ui.gadgets.worlds ui.render ui.backend byte-arrays accessors -locals ; - +locals specialized-arrays.direct.uchar ; IN: ui.freetype TUPLE: freetype-renderer ; @@ -135,8 +134,8 @@ M: freetype-renderer string-height ( open-font string -- h ) FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ; :: copy-pixel ( i j bitmap texture -- i j ) - 255 j texture set-char-nth - i bitmap char-nth j 1 + texture set-char-nth + 255 j texture set-nth + i bitmap nth j 1 + texture set-nth i 1 + j 2 + ; inline :: (copy-row) ( i j bitmap texture end -- ) @@ -155,15 +154,18 @@ M: freetype-renderer string-height ( open-font string -- h ) rows [ glyph glyph-bitmap-rows ] width [ glyph glyph-bitmap-width ] width2 [ width next-power-of-2 2 * ] | - 0 0 - rows [ bitmap texture width width2 copy-row ] times - 2drop + bitmap [ + [let | bitmap' [ bitmap rows width * ] | + 0 0 + rows [ bitmap' texture width width2 copy-row ] times + 2drop + ] + ] when ] ; : bitmap>texture ( glyph sprite -- id ) - tuck sprite-size2 * 2 * [ - [ copy-bitmap ] keep gray-texture - ] with-malloc ; + tuck sprite-size2 * 2 * + [ copy-bitmap ] keep gray-texture ; : glyph-texture-loc ( glyph font -- loc ) [ drop glyph-hori-bearing-x ft-floor ] diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index 0fae5103ec..75469671ef 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -2,11 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel math models namespaces sequences strings quotations assocs combinators classes colors -classes.tuple locals alien.c-types fry opengl opengl.gl -math.vectors ui.commands ui.gadgets ui.gadgets.borders -ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks -ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.render -math.geometry.rect ; +classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets +ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme +ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures +ui.render math.geometry.rect locals alien.c-types +specialized-arrays.float fry ; IN: ui.gadgets.buttons TUPLE: button < border pressed? selected? quot ; @@ -119,7 +119,7 @@ TUPLE: checkmark-paint < caching-pen color last-vertices ; } cleave 4array ; : checkmark-vertices ( dim -- vertices ) - checkmark-points concat >c-float-array ; + checkmark-points concat >float-array ; PRIVATE> diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index 4ce36dc3bd..5cbac9798a 100755 --- a/basis/ui/render/render.factor +++ b/basis/ui/render/render.factor @@ -3,7 +3,7 @@ USING: accessors alien alien.c-types arrays hashtables io kernel math namespaces opengl opengl.gl opengl.glu sequences strings io.styles vectors combinators math.vectors ui.gadgets colors -math.order math.geometry.rect locals ; +math.order math.geometry.rect locals specialized-arrays.float ; IN: ui.render SYMBOL: clip @@ -138,10 +138,11 @@ TUPLE: gradient < caching-pen colors last-vertices last-colors ; direction dim v* dim over v- swap colors length dup 1- v/n [ v*n ] with map [ dup rot v+ 2array ] with map - concat concat >c-float-array ; + concat concat >float-array ; : gradient-colors ( colors -- seq ) - [ color>raw 4array dup 2array ] map concat concat >c-float-array ; + [ color>raw 4array dup 2array ] map concat concat + >float-array ; M: gradient recompute-pen ( gadget gradient -- ) tuck @@ -173,7 +174,7 @@ boundary-vertices boundary-count ; : ( color points -- polygon ) - dup close-path [ [ concat >c-float-array ] [ length ] bi ] bi@ + dup close-path [ [ concat >float-array ] [ length ] bi ] bi@ polygon boa ; M: polygon draw-boundary diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor index 8f9fd2c6ef..210e9fbe12 100644 --- a/basis/unix/statfs/macosx/macosx.factor +++ b/basis/unix/statfs/macosx/macosx.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types io.encodings.utf8 io.encodings.string kernel sequences unix.stat accessors unix combinators math -grouping system io.files io.backend alien.strings math.bitwise -alien.syntax io.unix.files ; +grouping system alien.strings math.bitwise alien.syntax ; IN: unix.statfs.macosx : MNT_RDONLY HEX: 00000001 ; inline diff --git a/basis/unix/utilities/utilities.factor b/basis/unix/utilities/utilities.factor index 1f3a6bf78a..e2f780cd13 100644 --- a/basis/unix/utilities/utilities.factor +++ b/basis/unix/utilities/utilities.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings -combinators.short-circuit fry kernel layouts sequences ; +combinators.short-circuit fry kernel layouts sequences +specialized-arrays.alien accessors ; IN: unix.utilities : more? ( alien -- ? ) @@ -16,4 +17,4 @@ IN: unix.utilities [ ] produce nip ; : strings>alien ( strings encoding -- alien ) - '[ _ malloc-string ] map f suffix >c-void*-array ; + '[ _ malloc-string ] void*-array{ } map-as f suffix underlying>> ; diff --git a/basis/windows/com/com.factor b/basis/windows/com/com.factor index 9649de6402..0e1a907ca7 100644 --- a/basis/windows/com/com.factor +++ b/basis/windows/com/com.factor @@ -28,9 +28,10 @@ COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046} HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ; : com-query-interface ( interface iid -- interface' ) - "void*" heap-size [ + [ + "void*" malloc-object &free [ IUnknown::QueryInterface ole32-error ] keep *void* - ] with-malloc ; + ] with-destructors ; : com-add-ref ( interface -- interface ) [ IUnknown::AddRef drop ] keep ; inline diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor old mode 100644 new mode 100755 index c56293babe..620b608afc --- a/basis/windows/com/syntax/syntax.factor +++ b/basis/windows/com/syntax/syntax.factor @@ -1,7 +1,7 @@ -USING: alien alien.c-types effects kernel windows.ole32 -parser lexer splitting grouping sequences namespaces -assocs quotations generalizations accessors words macros alien.syntax -fry arrays ; +USING: alien alien.c-types alien.accessors effects kernel +windows.ole32 parser lexer splitting grouping sequences +namespaces assocs quotations generalizations accessors words +macros alien.syntax fry arrays layouts math ; IN: windows.com.syntax malloc ( byte-array -- alien ) - [ byte-length malloc ] [ over byte-array>memory ] bi ; - : (callback-word) ( function-name interface-name counter -- word ) [ "::" rot 3append "-callback-" ] dip number>string 3append "windows.com.wrapper.callbacks" create ; @@ -132,7 +129,7 @@ unless 1 0 rot set-ulong-nth ; : (callbacks>vtbl) ( callbacks -- vtbl ) - [ execute ] map >c-void*-array byte-array>malloc ; + [ execute ] void*-array{ } map-as underlying>> malloc-byte-array ; : (callbacks>vtbls) ( callbacks -- vtbls ) [ (callbacks>vtbl) ] map ; diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor old mode 100644 new mode 100755 index 6256211266..6d4e60ab22 --- a/basis/windows/ole32/ole32.factor +++ b/basis/windows/ole32/ole32.factor @@ -1,7 +1,7 @@ USING: alien alien.syntax alien.c-types alien.strings math kernel sequences windows windows.types debugger io accessors math.order namespaces make math.parser windows.kernel32 -combinators ; +combinators locals specialized-arrays.direct.uchar ; IN: windows.ole32 LIBRARY: ole32 @@ -134,49 +134,57 @@ M: ole32-error error. : GUID-STRING-LENGTH "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline -: (guid-section>guid) ( guid string start end quot -- ) - [ roll subseq hex> swap ] dip call ; inline -: (guid-byte>guid) ( guid string start end byte -- ) - [ roll subseq hex> ] dip - rot GUID-Data4 set-uchar-nth ; inline +:: (guid-section>guid) ( string guid start end quot -- ) + start end string subseq hex> guid quot call ; inline + +:: (guid-byte>guid) ( string guid start end byte -- ) + start end string subseq hex> byte guid set-nth ; inline : string>guid ( string -- guid ) - "GUID" [ { - [ 1 9 [ set-GUID-Data1 ] (guid-section>guid) ] + "GUID" [ + { + [ 1 9 [ set-GUID-Data1 ] (guid-section>guid) ] + [ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ] + [ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ] + [ ] + } 2cleave - [ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ] + GUID-Data4 8 { + [ 20 22 0 (guid-byte>guid) ] + [ 22 24 1 (guid-byte>guid) ] - [ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ] - - [ 20 22 0 (guid-byte>guid) ] - [ 22 24 1 (guid-byte>guid) ] - - [ 25 27 2 (guid-byte>guid) ] - [ 27 29 3 (guid-byte>guid) ] - [ 29 31 4 (guid-byte>guid) ] - [ 31 33 5 (guid-byte>guid) ] - [ 33 35 6 (guid-byte>guid) ] - [ 35 37 7 (guid-byte>guid) ] - } 2cleave ] keep ; + [ 25 27 2 (guid-byte>guid) ] + [ 27 29 3 (guid-byte>guid) ] + [ 29 31 4 (guid-byte>guid) ] + [ 31 33 5 (guid-byte>guid) ] + [ 33 35 6 (guid-byte>guid) ] + [ 35 37 7 (guid-byte>guid) ] + } 2cleave + ] keep ; : (guid-section%) ( guid quot len -- ) [ call >hex ] dip CHAR: 0 pad-left % ; inline + : (guid-byte%) ( guid byte -- ) - swap GUID-Data4 uchar-nth >hex 2 - CHAR: 0 pad-left % ; inline + swap nth >hex 2 CHAR: 0 pad-left % ; inline : guid>string ( guid -- string ) - [ "{" % { - [ [ GUID-Data1 ] 8 (guid-section%) "-" % ] - [ [ GUID-Data2 ] 4 (guid-section%) "-" % ] - [ [ GUID-Data3 ] 4 (guid-section%) "-" % ] - [ 0 (guid-byte%) ] - [ 1 (guid-byte%) "-" % ] - [ 2 (guid-byte%) ] - [ 3 (guid-byte%) ] - [ 4 (guid-byte%) ] - [ 5 (guid-byte%) ] - [ 6 (guid-byte%) ] - [ 7 (guid-byte%) "}" % ] - } cleave ] "" make ; + [ + "{" % { + [ [ GUID-Data1 ] 8 (guid-section%) "-" % ] + [ [ GUID-Data2 ] 4 (guid-section%) "-" % ] + [ [ GUID-Data3 ] 4 (guid-section%) "-" % ] + [ ] + } cleave + GUID-Data4 8 { + [ 0 (guid-byte%) ] + [ 1 (guid-byte%) "-" % ] + [ 2 (guid-byte%) ] + [ 3 (guid-byte%) ] + [ 4 (guid-byte%) ] + [ 5 (guid-byte%) ] + [ 6 (guid-byte%) ] + [ 7 (guid-byte%) "}" % ] + } cleave + ] "" make ; diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor index 1007b47a5b..1612b7ec11 100644 --- a/basis/x11/clipboard/clipboard.factor +++ b/basis/x11/clipboard/clipboard.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax arrays kernel math namespaces sequences io.encodings.string -io.encodings.utf8 io.encodings.ascii x11.xlib x11.constants ; +io.encodings.utf8 io.encodings.ascii x11.xlib x11.constants +specialized-arrays.int accessors ; IN: x11.clipboard ! This code was based on by McCLIM's Backends/CLX/port.lisp @@ -50,7 +51,7 @@ TUPLE: x-clipboard atom contents ; "TARGETS" x-atom 32 PropModeReplace { "UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP" - } [ x-atom ] map >c-int-array + } [ x-atom ] int-array{ } map-as underlying>> 4 XChangeProperty drop ; : set-timestamp-prop ( evt -- ) @@ -58,7 +59,7 @@ TUPLE: x-clipboard atom contents ; [ XSelectionRequestEvent-requestor ] keep [ XSelectionRequestEvent-property ] keep >r "TIMESTAMP" x-atom 32 PropModeReplace r> - XSelectionRequestEvent-time 1array >c-int-array + XSelectionRequestEvent-time 1 XChangeProperty drop ; : send-notify ( evt prop -- ) diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor index 7a2012f0ea..1fab283242 100644 --- a/basis/x11/glx/glx.factor +++ b/basis/x11/glx/glx.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! based on glx.h from xfree86, and some of glxtokens.h -USING: alien alien.c-types alien.syntax x11.xlib -namespaces make kernel sequences parser words ; +USING: alien alien.c-types alien.syntax x11.xlib namespaces make +kernel sequences parser words specialized-arrays.int accessors ; IN: x11.glx LIBRARY: glx @@ -93,7 +93,7 @@ FUNCTION: void* glXGetProcAddressARB ( char* procname ) ; GLX_DOUBLEBUFFER , GLX_DEPTH_SIZE , 16 , 0 , - ] { } make >c-int-array + ] int-array{ } make underlying>> glXChooseVisual [ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ; diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor index 35e1906b2b..71b0b5f133 100644 --- a/basis/x11/xim/xim.factor +++ b/basis/x11/xim/xim.factor @@ -1,15 +1,16 @@ -! Copyright (C) 2007 Slava Pestov +! Copyright (C) 2007, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays byte-arrays hashtables -io kernel math namespaces sequences strings -continuations x11.xlib ; +USING: alien alien.c-types alien.strings arrays byte-arrays +hashtables io io.encodings.string kernel math namespaces +sequences strings continuations x11.xlib specialized-arrays.uint +accessors ; IN: x11.xim SYMBOL: xim : (init-xim) ( classname medifier -- im ) XSetLocaleModifiers [ "XSetLocaleModifiers() failed" throw ] unless - dpy get f rot dup XOpenIM ; + [ dpy get f ] dip dup XOpenIM ; : init-xim ( classname -- ) dup "" (init-xim) @@ -21,14 +22,15 @@ SYMBOL: xim xim get-global XCloseIM drop f xim set-global ; : with-xim ( quot -- ) - >r "Factor" init-xim r> [ close-xim ] [ ] cleanup ; + [ "Factor" init-xim ] dip [ close-xim ] [ ] cleanup ; : create-xic ( window classname -- xic ) - >r >r xim get-global - XNClientWindow r> - XNFocusWindow over - XNInputStyle XIMPreeditNothing XIMStatusNothing bitor - XNResourceName r> + [ + [ xim get-global XNClientWindow ] dip + XNFocusWindow over + XNInputStyle XIMPreeditNothing XIMStatusNothing bitor + XNResourceName + ] dip XNResourceClass over 0 XCreateIC [ "XCreateIC() failed" throw ] unless* ; @@ -38,17 +40,17 @@ SYMBOL: keybuf SYMBOL: keysym : prepare-lookup ( -- ) - buf-size "uint" keybuf set + buf-size keybuf set 0 keysym set ; : finish-lookup ( len -- string keysym ) - keybuf get swap c-uint-array> >string + keybuf get swap 2 * head utf16n decode keysym get *KeySym ; : lookup-string ( event xic -- string keysym ) [ prepare-lookup - swap keybuf get buf-size keysym get 0 + swap keybuf get underlying>> buf-size keysym get 0 XwcLookupString finish-lookup ] with-scope ; diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 3deb08ac62..969c7249a9 100644 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -1,7 +1,7 @@ IN: assocs.tests USING: kernel math namespaces make tools.test vectors sequences sequences.private hashtables io prettyprint assocs -continuations float-arrays ; +continuations specialized-arrays.double ; [ t ] [ H{ } dup assoc-subset? ] unit-test [ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test @@ -91,7 +91,7 @@ unit-test [ H{ { 1.0 1.0 } { 2.0 2.0 } } ] [ - F{ 1.0 2.0 } [ dup ] H{ } map>assoc + double-array{ 1.0 2.0 } [ dup ] H{ } map>assoc ] unit-test [ { 3 } ] [ diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 4d2c537522..3bac6c87b3 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -90,7 +90,7 @@ ARTICLE: "tuple-constructors" "Tuple constructors" { $subsection POSTPONE: C: } "By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "" } "." $nl -"Constructors play a part in enforcing the invariant that slot values must always match slot declarations. The " { $link new } " word fills in the tuple will initial values, and " { $link boa } " ensures that the values on the stack match the corresponding slot declarations. See " { $link "tuple-declarations" } "." +"Constructors play a part in enforcing the invariant that slot values must always match slot declarations. The " { $link new } " word fills in the tuple with initial values, and " { $link boa } " ensures that the values on the stack match the corresponding slot declarations. See " { $link "tuple-declarations" } "." $nl "All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers." $nl @@ -103,11 +103,11 @@ $nl "{ alpha integer initial: 1 } ;" "" "! The following two are equivalent" - "C: rgba" + "C: color" ": color boa ;" "" "! We can define constructors which call other constructors" - ": 1 ;" + ": ( r g b -- color ) 1 ;" "" "! The following two are equivalent; note the initial value" ": ( -- color ) color new ;" diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index 7dadc807fd..f5f8f85376 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -1,10 +1,10 @@ IN: generic.standard.tests USING: tools.test math math.functions math.constants -generic.standard strings sequences arrays kernel accessors -words float-arrays byte-arrays bit-arrays parser namespaces make -quotations stack-checker vectors growable hashtables sbufs -prettyprint byte-vectors bit-vectors float-vectors definitions -generic sets graphs assocs ; +generic.standard strings sequences arrays kernel accessors words +specialized-arrays.double byte-arrays bit-arrays parser +namespaces make quotations stack-checker vectors growable +hashtables sbufs prettyprint byte-vectors bit-vectors +specialized-vectors.double definitions generic sets graphs assocs ; GENERIC: lo-tag-test ( obj -- obj' ) @@ -110,14 +110,14 @@ M: circle big-mix-test drop "circle" ; [ "integer" ] [ 3 big-mix-test ] unit-test [ "float" ] [ 5.0 big-mix-test ] unit-test [ "complex" ] [ -1 sqrt big-mix-test ] unit-test -[ "sequence" ] [ F{ 1.0 2.0 3.0 } big-mix-test ] unit-test +[ "sequence" ] [ double-array{ 1.0 2.0 3.0 } big-mix-test ] unit-test [ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test [ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test [ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test [ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test [ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test [ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test -[ "sequence" ] [ FV{ -0.3 4.6 } big-mix-test ] unit-test +[ "sequence" ] [ double-vector{ -0.3 4.6 } big-mix-test ] unit-test [ "string" ] [ "hello" big-mix-test ] unit-test [ "rectangle" ] [ 1 2 big-mix-test ] unit-test [ "parallelogram" ] [ 10 4 3 big-mix-test ] unit-test @@ -133,13 +133,13 @@ M: string small-lo-tag drop "string" ; M: array small-lo-tag drop "array" ; -M: float-array small-lo-tag drop "float-array" ; +M: double-array small-lo-tag drop "double-array" ; M: byte-array small-lo-tag drop "byte-array" ; [ "fixnum" ] [ 3 small-lo-tag ] unit-test -[ "float-array" ] [ F{ 1.0 } small-lo-tag ] unit-test +[ "double-array" ] [ double-array{ 1.0 } small-lo-tag ] unit-test ! Testing next-method TUPLE: person ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 7d3553faee..c951750b34 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -23,7 +23,7 @@ IN: bootstrap.syntax "syntax" lookup t "delimiter" set-word-prop ; : define-syntax ( name quot -- ) - [ "syntax" lookup dup ] dip define t "parsing" set-word-prop ; + [ "syntax" lookup dup ] dip define make-parsing ; [ { "]" "}" ";" ">>" } [ define-delimiter ] each @@ -93,7 +93,7 @@ IN: bootstrap.syntax "foldable" [ word make-foldable ] define-syntax "flushable" [ word make-flushable ] define-syntax "delimiter" [ word t "delimiter" set-word-prop ] define-syntax - "parsing" [ word t "parsing" set-word-prop ] define-syntax + "parsing" [ word make-parsing ] define-syntax "SYMBOL:" [ CREATE-WORD define-symbol diff --git a/core/words/words.factor b/core/words/words.factor index 618e04ffb4..b36f8be677 100644 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -243,6 +243,8 @@ ERROR: bad-create name vocab ; PREDICATE: parsing-word < word "parsing" word-prop ; +: make-parsing ( word -- ) t "parsing" set-word-prop ; + : delimiter? ( obj -- ? ) dup word? [ "delimiter" word-prop ] [ drop f ] if ; diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index a8c6e2a2ac..a1e892229a 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -22,7 +22,7 @@ IN: benchmark [ [ [ [ 1array $vocab-link ] with-cell ] - [ 1000000 /f pprint-cell ] bi* + [ [ 1000000 /f pprint-cell ] [ "failed" write ] if* ] bi* ] with-row ] assoc-each ] tabular-output ; diff --git a/extra/benchmark/dawes/dawes.factor b/extra/benchmark/dawes/dawes.factor index 7cff06d1bc..5cd40bc098 100644 --- a/extra/benchmark/dawes/dawes.factor +++ b/extra/benchmark/dawes/dawes.factor @@ -1,21 +1,16 @@ -USING: sequences alien.c-types math hints kernel byte-arrays ; +USING: sequences hints kernel math specialized-arrays.int fry ; IN: benchmark.dawes ! Phil Dawes's performance problem -: int-length ( byte-array -- n ) length "int" heap-size /i ; inline +: count-ones ( int-array -- n ) [ 1 = ] count ; inline -: count-ones ( byte-array -- n ) - 0 swap [ int-length ] keep [ - int-nth 1 = [ 1 + ] when - ] curry each-integer ; +HINTS: count-ones int-array ; -HINTS: count-ones byte-array ; - -: make-byte-array ( -- byte-array ) - 120000 [ 255 bitand ] map >c-int-array ; +: make-int-array ( -- int-array ) + 120000 [ 255 bitand ] int-array{ } map-as ; : dawes-benchmark ( -- ) - make-byte-array 200 swap [ count-ones ] curry replicate drop ; + make-int-array 200 swap '[ _ count-ones ] replicate drop ; MAIN: dawes-benchmark diff --git a/extra/benchmark/dispatch2/dispatch2.factor b/extra/benchmark/dispatch2/dispatch2.factor index 93b42c3e6c..c9d4f9ffa2 100644 --- a/extra/benchmark/dispatch2/dispatch2.factor +++ b/extra/benchmark/dispatch2/dispatch2.factor @@ -1,5 +1,5 @@ USING: make math sequences splitting grouping -kernel columns float-arrays bit-arrays ; +kernel columns specialized-arrays.double bit-arrays ; IN: benchmark.dispatch2 : sequences ( -- seq ) @@ -10,7 +10,7 @@ IN: benchmark.dispatch2 "hello world" , SBUF" sbuf world" , V{ "a" "b" "c" } , - F{ 1.0 2.0 3.0 } , + double-array{ 1.0 2.0 3.0 } , "hello world" 4 tail-slice , 10 f , 100 2 , diff --git a/extra/benchmark/dispatch3/dispatch3.factor b/extra/benchmark/dispatch3/dispatch3.factor index aa3d11e2fb..94925f0d79 100644 --- a/extra/benchmark/dispatch3/dispatch3.factor +++ b/extra/benchmark/dispatch3/dispatch3.factor @@ -1,6 +1,6 @@ USING: sequences math mirrors splitting grouping kernel make assocs alien.syntax columns -float-arrays bit-arrays ; +specialized-arrays.double bit-arrays ; IN: benchmark.dispatch3 GENERIC: g ( obj -- str ) @@ -26,7 +26,7 @@ M: object g drop "object" ; "hello world" , SBUF" sbuf world" , V{ "a" "b" "c" } , - F{ 1.0 2.0 3.0 } , + double-array{ 1.0 2.0 3.0 } , "hello world" 4 tail-slice , 10 f , 100 2 , diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index 015f762c7b..32d3534920 100755 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -1,7 +1,7 @@ ! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=fasta&lang=java&id=2 USING: math kernel io io.files locals multiline assocs sequences sequences.private benchmark.reverse-complement hints io.encodings.ascii -byte-arrays float-arrays ; +byte-arrays specialized-arrays.double ; IN: benchmark.fasta : IM 139968 ; inline @@ -49,7 +49,7 @@ HINTS: random fixnum ; : make-cumulative ( freq -- chars floats ) dup keys >byte-array - swap values >float-array unclip [ + ] accumulate swap suffix ; + swap values >double-array unclip [ + ] accumulate swap suffix ; :: select-random ( seed chars floats -- seed elt ) floats seed random -rot diff --git a/extra/benchmark/nbody/nbody.factor b/extra/benchmark/nbody/nbody.factor index 7b20edaadb..305fc2e33b 100644 --- a/extra/benchmark/nbody/nbody.factor +++ b/extra/benchmark/nbody/nbody.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors float-arrays fry kernel locals make math +USING: accessors specialized-arrays.double fry kernel locals make math math.constants math.functions math.vectors prettyprint sequences hints arrays ; IN: benchmark.nbody @@ -9,39 +9,39 @@ IN: benchmark.nbody : days-per-year 365.24 ; inline TUPLE: body -{ location float-array } -{ velocity float-array } +{ location double-array } +{ velocity double-array } { mass float read-only } ; : ( location velocity mass -- body ) [ days-per-year v*n ] [ solar-mass * ] bi* body boa ; inline : ( -- body ) - F{ 4.84143144246472090e+00 -1.16032004402742839e+00 -1.03622044471123109e-01 } - F{ 1.66007664274403694e-03 7.69901118419740425e-03 -6.90460016972063023e-05 } + double-array{ 4.84143144246472090e+00 -1.16032004402742839e+00 -1.03622044471123109e-01 } + double-array{ 1.66007664274403694e-03 7.69901118419740425e-03 -6.90460016972063023e-05 } 9.54791938424326609e-04 ; : ( -- body ) - F{ 8.34336671824457987e+00 4.12479856412430479e+00 -4.03523417114321381e-01 } - F{ -2.76742510726862411e-03 4.99852801234917238e-03 2.30417297573763929e-05 } + double-array{ 8.34336671824457987e+00 4.12479856412430479e+00 -4.03523417114321381e-01 } + double-array{ -2.76742510726862411e-03 4.99852801234917238e-03 2.30417297573763929e-05 } 2.85885980666130812e-04 ; : ( -- body ) - F{ 1.28943695621391310e+01 -1.51111514016986312e+01 -2.23307578892655734e-01 } - F{ 2.96460137564761618e-03 2.37847173959480950e-03 -2.96589568540237556e-05 } + double-array{ 1.28943695621391310e+01 -1.51111514016986312e+01 -2.23307578892655734e-01 } + double-array{ 2.96460137564761618e-03 2.37847173959480950e-03 -2.96589568540237556e-05 } 4.36624404335156298e-05 ; : ( -- body ) - F{ 1.53796971148509165e+01 -2.59193146099879641e+01 1.79258772950371181e-01 } - F{ 2.68067772490389322e-03 1.62824170038242295e-03 -9.51592254519715870e-05 } + double-array{ 1.53796971148509165e+01 -2.59193146099879641e+01 1.79258772950371181e-01 } + double-array{ 2.68067772490389322e-03 1.62824170038242295e-03 -9.51592254519715870e-05 } 5.15138902046611451e-05 ; : ( -- body ) - F{ 0 0 0 } F{ 0 0 0 } 1 ; + double-array{ 0 0 0 } double-array{ 0 0 0 } 1 ; : offset-momentum ( body offset -- body ) vneg solar-mass v/n >>velocity ; inline @@ -49,7 +49,7 @@ TUPLE: body TUPLE: nbody-system { bodies array read-only } ; : init-bodies ( bodies -- ) - [ first ] [ F{ 0 0 0 } [ [ velocity>> ] [ mass>> ] bi v*n v+ ] reduce ] bi + [ first ] [ double-array{ 0 0 0 } [ [ velocity>> ] [ mass>> ] bi v*n v+ ] reduce ] bi offset-momentum drop ; inline : ( -- system ) diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 34bac61292..7fe46e9c36 100755 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -1,7 +1,7 @@ ! Factor port of the raytracer benchmark from ! http://www.ffconsultancy.com/free/ray_tracer/languages.html -USING: arrays accessors float-arrays io io.files +USING: arrays accessors specialized-arrays.double io io.files io.encodings.binary kernel math math.functions math.vectors math.parser make sequences sequences.private words hints ; IN: benchmark.raytracer @@ -9,7 +9,7 @@ IN: benchmark.raytracer ! parameters : light #! Normalized { -1 -3 2 }. - F{ + double-array{ -0.2672612419124244 -0.8017837257372732 0.5345224838248488 @@ -23,17 +23,17 @@ IN: benchmark.raytracer : delta 1.4901161193847656E-8 ; inline -TUPLE: ray { orig float-array read-only } { dir float-array read-only } ; +TUPLE: ray { orig double-array read-only } { dir double-array read-only } ; C: ray -TUPLE: hit { normal float-array read-only } { lambda float read-only } ; +TUPLE: hit { normal double-array read-only } { lambda float read-only } ; C: hit GENERIC: intersect-scene ( hit ray scene -- hit ) -TUPLE: sphere { center float-array read-only } { radius float read-only } ; +TUPLE: sphere { center double-array read-only } { radius float read-only } ; C: sphere @@ -87,7 +87,7 @@ TUPLE: group < sphere { objs array read-only } ; M: group intersect-scene ( hit ray group -- hit ) [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ; -: initial-hit T{ hit f F{ 0.0 0.0 0.0 } 1/0. } ; inline +: initial-hit T{ hit f double-array{ 0.0 0.0 0.0 } 1/0. } ; inline : initial-intersect ( ray scene -- hit ) [ initial-hit ] 2dip intersect-scene ; inline @@ -120,10 +120,10 @@ DEFER: create ( level c r -- scene ) : create-offsets ( quot -- ) { - F{ -1.0 1.0 -1.0 } - F{ 1.0 1.0 -1.0 } - F{ -1.0 1.0 1.0 } - F{ 1.0 1.0 1.0 } + double-array{ -1.0 1.0 -1.0 } + double-array{ 1.0 1.0 -1.0 } + double-array{ -1.0 1.0 1.0 } + double-array{ 1.0 1.0 1.0 } } swap each ; inline : create-bound ( c r -- sphere ) 3.0 * ; @@ -138,14 +138,14 @@ DEFER: create ( level c r -- scene ) pick 1 = [ nip ] [ create-group ] if ; : ss-point ( dx dy -- point ) - [ oversampling /f ] bi@ 0.0 3float-array ; + [ oversampling /f ] bi@ 0.0 double-array{ } 3sequence ; : ss-grid ( -- ss-grid ) oversampling [ oversampling [ ss-point ] with map ] map ; : ray-grid ( point ss-grid -- ray-grid ) [ - [ v+ normalize F{ 0.0 0.0 -4.0 } swap ] with map + [ v+ normalize double-array{ 0.0 0.0 -4.0 } swap ] with map ] with map ; : ray-pixel ( scene point -- n ) @@ -156,7 +156,7 @@ DEFER: create ( level c r -- scene ) size reverse [ size [ [ size 0.5 * - ] bi@ swap size - 3float-array + double-array{ } 3sequence ] with map ] map ; @@ -169,7 +169,7 @@ DEFER: create ( level c r -- scene ) pixel-grid [ [ ray-pixel ] with map ] with map ; : run ( -- string ) - levels F{ 0.0 -1.0 0.0 } 1.0 create ray-trace [ + levels double-array{ 0.0 -1.0 0.0 } 1.0 create ray-trace [ size size pgm-header [ [ oversampling sq / pgm-pixel ] each ] each ] B{ } make ; diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor index 245027ef77..64d2bdbb1f 100644 --- a/extra/benchmark/spectral-norm/spectral-norm.factor +++ b/extra/benchmark/spectral-norm/spectral-norm.factor @@ -1,8 +1,8 @@ ! Factor port of ! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all -USING: float-arrays kernel math math.functions math.vectors -sequences sequences.private prettyprint words -hints locals ; +USING: specialized-arrays.double kernel math math.functions +math.vectors sequences sequences.private prettyprint words hints +locals ; IN: benchmark.spectral-norm :: inner-loop ( u n quot -- seq ) @@ -10,7 +10,7 @@ IN: benchmark.spectral-norm n 0.0 [| j | u i j quot call + ] reduce - ] F{ } map-as ; inline + ] double-array{ } map-as ; inline : eval-A ( i j -- n ) [ >float ] bi@ @@ -32,7 +32,7 @@ IN: benchmark.spectral-norm : eval-AtA-times-u ( u n -- seq ) [ eval-A-times-u ] [ eval-At-times-u ] bi ; inline -: ones ( n -- seq ) [ 1.0 ] F{ } replicate-as ; inline +: ones ( n -- seq ) [ 1.0 ] double-array{ } replicate-as ; inline :: u/v ( n -- u v ) n ones dup diff --git a/extra/cairo/samples/samples.factor b/extra/cairo/samples/samples.factor index 0f21142f2a..bdd02c9e13 100644 --- a/extra/cairo/samples/samples.factor +++ b/extra/cairo/samples/samples.factor @@ -5,7 +5,7 @@ ! http://cairographics.org/samples/ USING: cairo cairo.ffi locals math.constants math io.backend kernel alien.c-types libc namespaces -cairo.gadgets ui.gadgets accessors ; +cairo.gadgets ui.gadgets accessors specialized-arrays.double ; IN: cairo.samples @@ -69,7 +69,7 @@ M:: clip-image-gadget render-cairo* ( gadget -- ) TUPLE: dash-gadget < cairo-gadget ; M:: dash-gadget render-cairo* ( gadget -- ) - [let | dashes [ { 50 10 10 10 } >c-double-array ] + [let | dashes [ double-array{ 50 10 10 10 } underlying>> ] ndash [ 4 ] | cr dashes ndash -50 cairo_set_dash cr 10 cairo_set_line_width diff --git a/extra/cap/cap.factor b/extra/cap/cap.factor index 3bd1a5f174..716435775d 100644 --- a/extra/cap/cap.factor +++ b/extra/cap/cap.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays byte-arrays kernel math namespaces opengl.gl sequences math.vectors ui graphics.bitmap graphics.viewer -models opengl.framebuffers ui.gadgets.worlds ui.gadgets fry alien.syntax ; +models ui.gadgets.worlds ui.gadgets fry alien.syntax ; IN: cap : screenshot-array ( world -- byte-array ) diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 62b7c2f180..64ea481b03 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,15 +1,14 @@ USING: tools.deploy.config ; H{ - { deploy-threads? f } + { deploy-unicode? f } + { deploy-reflection 1 } + { deploy-word-props? f } + { deploy-math? f } { deploy-name "Hello world (console)" } { deploy-word-defs? f } - { deploy-word-props? f } + { "stop-after-last-window?" t } { deploy-ui? f } { deploy-compiler? f } { deploy-io 2 } - { deploy-math? f } - { deploy-reflection 1 } - { deploy-unicode? f } - { "stop-after-last-window?" t } { deploy-c-types? f } } diff --git a/extra/math/blas/matrices/matrices.factor b/extra/math/blas/matrices/matrices.factor index 4f50543e73..0899e2d079 100755 --- a/extra/math/blas/matrices/matrices.factor +++ b/extra/math/blas/matrices/matrices.factor @@ -3,7 +3,7 @@ combinators.lib combinators.short-circuit fry kernel locals macros math math.blas.cblas math.blas.vectors math.blas.vectors.private math.complex math.functions math.order multi-methods qualified sequences sequences.merged sequences.private generalizations -shuffle symbols ; +shuffle symbols speicalized-arrays.float specialized-arrays.double ; QUALIFIED: syntax IN: math.blas.matrices @@ -143,14 +143,14 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix } PRIVATE> : >float-blas-matrix ( arrays -- matrix ) - [ >c-float-array ] (>matrix) ; + [ >float-array underlying>> ] (>matrix) ; : >double-blas-matrix ( arrays -- matrix ) - [ >c-double-array ] (>matrix) ; + [ >double-array underlying>> ] (>matrix) ; : >float-complex-blas-matrix ( arrays -- matrix ) - [ (flatten-complex-sequence) >c-float-array ] (>matrix) + [ (flatten-complex-sequence) >float-array underlying>> ] (>matrix) ; : >double-complex-blas-matrix ( arrays -- matrix ) - [ (flatten-complex-sequence) >c-double-array ] (>matrix) + [ (flatten-complex-sequence) >double-array underlying>> ] (>matrix) ; GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y ) diff --git a/extra/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor index a135f08f28..f29ef30ab7 100755 --- a/extra/math/blas/vectors/vectors.factor +++ b/extra/math/blas/vectors/vectors.factor @@ -1,7 +1,9 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators combinators.short-circuit fry kernel macros math math.blas.cblas math.complex math.functions math.order multi-methods qualified -sequences sequences.private generalizations ; +sequences sequences.private generalizations +specialized-arrays.float specialized-arrays.double +specialized-arrays.direct.float specialized-arrays.direct.double ; QUALIFIED: syntax IN: math.blas.vectors @@ -90,14 +92,14 @@ MACRO: (do-copy) ( copy make-vector -- ) [ [ real-part ] [ imaginary-part ] bi 2array ] map concat ; : (>c-complex) ( complex -- alien ) - [ real-part ] [ imaginary-part ] bi 2array >c-float-array ; + [ real-part ] [ imaginary-part ] bi float-array{ } 2sequence underlying>> ; : (>z-complex) ( complex -- alien ) - [ real-part ] [ imaginary-part ] bi 2array >c-double-array ; + [ real-part ] [ imaginary-part ] bi double-array{ } 2sequence underlying>> ; : (c-complex>) ( alien -- complex ) - 2 c-float-array> first2 rect> ; + 2 first2 rect> ; : (z-complex>) ( alien -- complex ) - 2 c-double-array> first2 rect> ; + 2 first2 rect> ; : (prepare-nth) ( n v -- n*inc v-data ) [ inc>> ] [ data>> ] bi [ * ] dip ; @@ -170,14 +172,14 @@ syntax:M: blas-vector-base equal? } 2&& ; : >float-blas-vector ( seq -- v ) - [ >c-float-array ] [ length ] bi 1 ; + [ >float-array underlying>> ] [ length ] bi 1 ; : >double-blas-vector ( seq -- v ) - [ >c-double-array ] [ length ] bi 1 ; + [ >double-array underlying>> ] [ length ] bi 1 ; : >float-complex-blas-vector ( seq -- v ) - [ (flatten-complex-sequence) >c-float-array ] [ length ] bi + [ (flatten-complex-sequence) >float-array underlying>> ] [ length ] bi 1 ; : >double-complex-blas-vector ( seq -- v ) - [ (flatten-complex-sequence) >c-double-array ] [ length ] bi + [ (flatten-complex-sequence) >double-array underlying>> ] [ length ] bi 1 ; syntax:M: float-blas-vector clone diff --git a/extra/maze/maze.factor b/extra/maze/maze.factor index f56c579a3f..de345e732e 100644 --- a/extra/maze/maze.factor +++ b/extra/maze/maze.factor @@ -1,7 +1,7 @@ ! From http://www.ffconsultancy.com/ocaml/maze/index.html USING: sequences namespaces math math.vectors opengl opengl.gl -opengl.demo-support arrays kernel random ui ui.gadgets -ui.gadgets.canvas ui.render math.order math.geometry.rect ; +arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render +math.order math.geometry.rect ; IN: maze : line-width 8 ; @@ -28,7 +28,7 @@ SYMBOL: visited : (draw-maze) ( cell -- ) dup vertex glEnd - GL_POINTS [ dup vertex ] do-state + GL_POINTS glBegin dup vertex glEnd GL_LINE_STRIP glBegin dup vertex dup visit diff --git a/extra/processing/shapes/shapes.factor b/extra/processing/shapes/shapes.factor index a530be64fa..51979dc96a 100644 --- a/extra/processing/shapes/shapes.factor +++ b/extra/processing/shapes/shapes.factor @@ -2,13 +2,17 @@ USING: kernel namespaces arrays sequences grouping alien.c-types math math.vectors math.geometry.rect - opengl.gl opengl.glu opengl.demo-support opengl generalizations vars + opengl.gl opengl.glu opengl generalizations vars combinators.cleave colors ; IN: processing.shapes ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: do-state ( mode quot -- ) swap glBegin call glEnd ; inline + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + VAR: fill-color VAR: stroke-color diff --git a/extra/bunny/authors.txt b/unmaintained/bunny/authors.txt similarity index 100% rename from extra/bunny/authors.txt rename to unmaintained/bunny/authors.txt diff --git a/extra/bunny/bun_zipper.ply b/unmaintained/bunny/bun_zipper.ply similarity index 100% rename from extra/bunny/bun_zipper.ply rename to unmaintained/bunny/bun_zipper.ply diff --git a/extra/bunny/bunny.factor b/unmaintained/bunny/bunny.factor similarity index 100% rename from extra/bunny/bunny.factor rename to unmaintained/bunny/bunny.factor diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/unmaintained/bunny/cel-shaded/cel-shaded.factor similarity index 100% rename from extra/bunny/cel-shaded/cel-shaded.factor rename to unmaintained/bunny/cel-shaded/cel-shaded.factor diff --git a/extra/bunny/deploy.factor b/unmaintained/bunny/deploy.factor similarity index 100% rename from extra/bunny/deploy.factor rename to unmaintained/bunny/deploy.factor diff --git a/extra/bunny/fixed-pipeline/fixed-pipeline.factor b/unmaintained/bunny/fixed-pipeline/fixed-pipeline.factor similarity index 80% rename from extra/bunny/fixed-pipeline/fixed-pipeline.factor rename to unmaintained/bunny/fixed-pipeline/fixed-pipeline.factor index 0bad9cc943..fd420d0b7d 100644 --- a/extra/bunny/fixed-pipeline/fixed-pipeline.factor +++ b/unmaintained/bunny/fixed-pipeline/fixed-pipeline.factor @@ -1,5 +1,5 @@ USING: alien.c-types continuations destructors kernel -opengl opengl.gl bunny.model ; +opengl opengl.gl bunny.model specialized-arrays.float ; IN: bunny.fixed-pipeline TUPLE: bunny-fixed-pipeline ; @@ -13,7 +13,7 @@ M: bunny-fixed-pipeline draw-bunny GL_LIGHTING glEnable GL_LIGHT0 glEnable GL_COLOR_MATERIAL glEnable - GL_LIGHT0 GL_POSITION { 1.0 -1.0 1.0 1.0 } >c-float-array glLightfv + GL_LIGHT0 GL_POSITION float-array{ 1.0 -1.0 1.0 1.0 } underlying>> glLightfv GL_FRONT_AND_BACK GL_SHININESS 100.0 glMaterialf GL_FRONT_AND_BACK GL_SPECULAR glColorMaterial GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial diff --git a/extra/bunny/model/model.factor b/unmaintained/bunny/model/model.factor similarity index 94% rename from extra/bunny/model/model.factor rename to unmaintained/bunny/model/model.factor index 1bbaf796ad..c9d109cb71 100755 --- a/extra/bunny/model/model.factor +++ b/unmaintained/bunny/model/model.factor @@ -2,7 +2,8 @@ USING: accessors alien.c-types arrays combinators destructors http.client io io.encodings.ascii io.files kernel math math.matrices math.parser math.vectors opengl opengl.capabilities opengl.gl opengl.demo-support sequences -sequences.lib splitting vectors words ; +sequences.lib splitting vectors words +specialized-arrays.double specialized-arrays.uint ; IN: bunny.model : numbers ( str -- seq ) @@ -65,11 +66,11 @@ TUPLE: bunny-buffers array element-array nv ni ; { [ [ first concat ] [ second concat ] bi - append >c-float-array + append >double-array underlying>> GL_ARRAY_BUFFER swap GL_STATIC_DRAW ] [ - third concat >c-uint-array + third concat >uint-array underlying>> GL_ELEMENT_ARRAY_BUFFER swap GL_STATIC_DRAW ] [ first length 3 * ] diff --git a/extra/bunny/outlined/outlined.factor b/unmaintained/bunny/outlined/outlined.factor similarity index 100% rename from extra/bunny/outlined/outlined.factor rename to unmaintained/bunny/outlined/outlined.factor diff --git a/extra/bunny/summary.txt b/unmaintained/bunny/summary.txt similarity index 100% rename from extra/bunny/summary.txt rename to unmaintained/bunny/summary.txt diff --git a/extra/bunny/tags.txt b/unmaintained/bunny/tags.txt similarity index 100% rename from extra/bunny/tags.txt rename to unmaintained/bunny/tags.txt diff --git a/extra/cfdg/authors.txt b/unmaintained/cfdg/authors.txt similarity index 100% rename from extra/cfdg/authors.txt rename to unmaintained/cfdg/authors.txt diff --git a/extra/cfdg/cfdg.factor b/unmaintained/cfdg/cfdg.factor similarity index 98% rename from extra/cfdg/cfdg.factor rename to unmaintained/cfdg/cfdg.factor index 3278cc6ec1..58772e23e0 100644 --- a/extra/cfdg/cfdg.factor +++ b/unmaintained/cfdg/cfdg.factor @@ -6,7 +6,7 @@ USING: kernel alien.c-types combinators namespaces make arrays vars colors self self.slots random-weighted colors.hsv cfdg.gl accessors ui.gadgets.handler ui.gestures assocs ui.gadgets macros - qualified ; + qualified speicalized-arrays.double ; QUALIFIED: syntax IN: cfdg @@ -75,7 +75,7 @@ VAR: threshold 2 * sin , 2 * cos neg , 0 , 0 , 0 , 0 , 1 , 0 , 0 , 0 , 0 , 1 , ] - { } make >c-double-array glMultMatrixd ; + double-array{ } make underlying>> glMultMatrixd ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/cfdg/gl/authors.txt b/unmaintained/cfdg/gl/authors.txt similarity index 100% rename from extra/cfdg/gl/authors.txt rename to unmaintained/cfdg/gl/authors.txt diff --git a/extra/cfdg/gl/gl.factor b/unmaintained/cfdg/gl/gl.factor similarity index 100% rename from extra/cfdg/gl/gl.factor rename to unmaintained/cfdg/gl/gl.factor diff --git a/extra/cfdg/models/aqua-star/aqua-star.factor b/unmaintained/cfdg/models/aqua-star/aqua-star.factor similarity index 100% rename from extra/cfdg/models/aqua-star/aqua-star.factor rename to unmaintained/cfdg/models/aqua-star/aqua-star.factor diff --git a/extra/cfdg/models/aqua-star/authors.txt b/unmaintained/cfdg/models/aqua-star/authors.txt similarity index 100% rename from extra/cfdg/models/aqua-star/authors.txt rename to unmaintained/cfdg/models/aqua-star/authors.txt diff --git a/extra/cfdg/models/aqua-star/tags.txt b/unmaintained/cfdg/models/aqua-star/tags.txt similarity index 100% rename from extra/cfdg/models/aqua-star/tags.txt rename to unmaintained/cfdg/models/aqua-star/tags.txt diff --git a/extra/cfdg/models/chiaroscuro/authors.txt b/unmaintained/cfdg/models/chiaroscuro/authors.txt similarity index 100% rename from extra/cfdg/models/chiaroscuro/authors.txt rename to unmaintained/cfdg/models/chiaroscuro/authors.txt diff --git a/extra/cfdg/models/chiaroscuro/chiaroscuro.factor b/unmaintained/cfdg/models/chiaroscuro/chiaroscuro.factor similarity index 100% rename from extra/cfdg/models/chiaroscuro/chiaroscuro.factor rename to unmaintained/cfdg/models/chiaroscuro/chiaroscuro.factor diff --git a/extra/cfdg/models/chiaroscuro/tags.txt b/unmaintained/cfdg/models/chiaroscuro/tags.txt similarity index 100% rename from extra/cfdg/models/chiaroscuro/tags.txt rename to unmaintained/cfdg/models/chiaroscuro/tags.txt diff --git a/extra/cfdg/models/flower6/authors.txt b/unmaintained/cfdg/models/flower6/authors.txt similarity index 100% rename from extra/cfdg/models/flower6/authors.txt rename to unmaintained/cfdg/models/flower6/authors.txt diff --git a/extra/cfdg/models/flower6/deploy.factor b/unmaintained/cfdg/models/flower6/deploy.factor similarity index 100% rename from extra/cfdg/models/flower6/deploy.factor rename to unmaintained/cfdg/models/flower6/deploy.factor diff --git a/extra/cfdg/models/flower6/flower6.factor b/unmaintained/cfdg/models/flower6/flower6.factor similarity index 100% rename from extra/cfdg/models/flower6/flower6.factor rename to unmaintained/cfdg/models/flower6/flower6.factor diff --git a/extra/cfdg/models/flower6/tags.txt b/unmaintained/cfdg/models/flower6/tags.txt similarity index 100% rename from extra/cfdg/models/flower6/tags.txt rename to unmaintained/cfdg/models/flower6/tags.txt diff --git a/extra/cfdg/models/game1-turn6/authors.txt b/unmaintained/cfdg/models/game1-turn6/authors.txt similarity index 100% rename from extra/cfdg/models/game1-turn6/authors.txt rename to unmaintained/cfdg/models/game1-turn6/authors.txt diff --git a/extra/cfdg/models/game1-turn6/game1-turn6.factor b/unmaintained/cfdg/models/game1-turn6/game1-turn6.factor similarity index 100% rename from extra/cfdg/models/game1-turn6/game1-turn6.factor rename to unmaintained/cfdg/models/game1-turn6/game1-turn6.factor diff --git a/extra/cfdg/models/game1-turn6/tags.txt b/unmaintained/cfdg/models/game1-turn6/tags.txt similarity index 100% rename from extra/cfdg/models/game1-turn6/tags.txt rename to unmaintained/cfdg/models/game1-turn6/tags.txt diff --git a/extra/cfdg/models/lesson/authors.txt b/unmaintained/cfdg/models/lesson/authors.txt similarity index 100% rename from extra/cfdg/models/lesson/authors.txt rename to unmaintained/cfdg/models/lesson/authors.txt diff --git a/extra/cfdg/models/lesson/lesson.factor b/unmaintained/cfdg/models/lesson/lesson.factor similarity index 100% rename from extra/cfdg/models/lesson/lesson.factor rename to unmaintained/cfdg/models/lesson/lesson.factor diff --git a/extra/cfdg/models/lesson/tags.txt b/unmaintained/cfdg/models/lesson/tags.txt similarity index 100% rename from extra/cfdg/models/lesson/tags.txt rename to unmaintained/cfdg/models/lesson/tags.txt diff --git a/extra/cfdg/models/rules08/rules08.factor b/unmaintained/cfdg/models/rules08/rules08.factor similarity index 100% rename from extra/cfdg/models/rules08/rules08.factor rename to unmaintained/cfdg/models/rules08/rules08.factor diff --git a/extra/cfdg/models/rules08/tags.txt b/unmaintained/cfdg/models/rules08/tags.txt similarity index 100% rename from extra/cfdg/models/rules08/tags.txt rename to unmaintained/cfdg/models/rules08/tags.txt diff --git a/extra/cfdg/models/sierpinski/authors.txt b/unmaintained/cfdg/models/sierpinski/authors.txt similarity index 100% rename from extra/cfdg/models/sierpinski/authors.txt rename to unmaintained/cfdg/models/sierpinski/authors.txt diff --git a/extra/cfdg/models/sierpinski/sierpinski.factor b/unmaintained/cfdg/models/sierpinski/sierpinski.factor similarity index 100% rename from extra/cfdg/models/sierpinski/sierpinski.factor rename to unmaintained/cfdg/models/sierpinski/sierpinski.factor diff --git a/extra/cfdg/models/sierpinski/tags.txt b/unmaintained/cfdg/models/sierpinski/tags.txt similarity index 100% rename from extra/cfdg/models/sierpinski/tags.txt rename to unmaintained/cfdg/models/sierpinski/tags.txt diff --git a/extra/cfdg/models/snowflake/authors.txt b/unmaintained/cfdg/models/snowflake/authors.txt similarity index 100% rename from extra/cfdg/models/snowflake/authors.txt rename to unmaintained/cfdg/models/snowflake/authors.txt diff --git a/extra/cfdg/models/snowflake/snowflake.factor b/unmaintained/cfdg/models/snowflake/snowflake.factor similarity index 100% rename from extra/cfdg/models/snowflake/snowflake.factor rename to unmaintained/cfdg/models/snowflake/snowflake.factor diff --git a/extra/cfdg/models/snowflake/tags.txt b/unmaintained/cfdg/models/snowflake/tags.txt similarity index 100% rename from extra/cfdg/models/snowflake/tags.txt rename to unmaintained/cfdg/models/snowflake/tags.txt diff --git a/extra/cfdg/models/spirales/spirales.factor b/unmaintained/cfdg/models/spirales/spirales.factor similarity index 100% rename from extra/cfdg/models/spirales/spirales.factor rename to unmaintained/cfdg/models/spirales/spirales.factor diff --git a/extra/cfdg/models/spirales/tags.txt b/unmaintained/cfdg/models/spirales/tags.txt similarity index 100% rename from extra/cfdg/models/spirales/tags.txt rename to unmaintained/cfdg/models/spirales/tags.txt diff --git a/extra/cfdg/summary.txt b/unmaintained/cfdg/summary.txt similarity index 100% rename from extra/cfdg/summary.txt rename to unmaintained/cfdg/summary.txt diff --git a/extra/golden-section/authors.txt b/unmaintained/golden-section/authors.txt similarity index 100% rename from extra/golden-section/authors.txt rename to unmaintained/golden-section/authors.txt diff --git a/extra/golden-section/deploy.factor b/unmaintained/golden-section/deploy.factor similarity index 100% rename from extra/golden-section/deploy.factor rename to unmaintained/golden-section/deploy.factor diff --git a/extra/golden-section/golden-section.factor b/unmaintained/golden-section/golden-section.factor similarity index 100% rename from extra/golden-section/golden-section.factor rename to unmaintained/golden-section/golden-section.factor diff --git a/extra/golden-section/summary.txt b/unmaintained/golden-section/summary.txt similarity index 100% rename from extra/golden-section/summary.txt rename to unmaintained/golden-section/summary.txt diff --git a/extra/golden-section/tags.txt b/unmaintained/golden-section/tags.txt similarity index 100% rename from extra/golden-section/tags.txt rename to unmaintained/golden-section/tags.txt diff --git a/extra/jamshred/authors.txt b/unmaintained/jamshred/authors.txt similarity index 100% rename from extra/jamshred/authors.txt rename to unmaintained/jamshred/authors.txt diff --git a/extra/jamshred/deploy.factor b/unmaintained/jamshred/deploy.factor similarity index 100% rename from extra/jamshred/deploy.factor rename to unmaintained/jamshred/deploy.factor diff --git a/extra/jamshred/game/authors.txt b/unmaintained/jamshred/game/authors.txt similarity index 100% rename from extra/jamshred/game/authors.txt rename to unmaintained/jamshred/game/authors.txt diff --git a/extra/jamshred/game/game.factor b/unmaintained/jamshred/game/game.factor similarity index 100% rename from extra/jamshred/game/game.factor rename to unmaintained/jamshred/game/game.factor diff --git a/extra/jamshred/gl/authors.txt b/unmaintained/jamshred/gl/authors.txt similarity index 100% rename from extra/jamshred/gl/authors.txt rename to unmaintained/jamshred/gl/authors.txt diff --git a/extra/jamshred/gl/gl.factor b/unmaintained/jamshred/gl/gl.factor similarity index 88% rename from extra/jamshred/gl/gl.factor rename to unmaintained/jamshred/gl/gl.factor index 7bd6eb7fbc..b78e7de88e 100644 --- a/extra/jamshred/gl/gl.factor +++ b/unmaintained/jamshred/gl/gl.factor @@ -3,7 +3,7 @@ USING: accessors alien.c-types jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu -opengl.demo-support sequences float-arrays ; +opengl.demo-support sequences specialized-arrays.float ; IN: jamshred.gl : min-vertices 6 ; inline @@ -84,10 +84,10 @@ IN: jamshred.gl GL_FOG_DENSITY 0.09 glFogf GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial GL_COLOR_MATERIAL glEnable - GL_LIGHT0 GL_POSITION F{ 0.0 0.0 0.0 1.0 } >c-float-array glLightfv - GL_LIGHT0 GL_AMBIENT F{ 0.2 0.2 0.2 1.0 } >c-float-array glLightfv - GL_LIGHT0 GL_DIFFUSE F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv - GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ; + GL_LIGHT0 GL_POSITION float-array{ 0.0 0.0 0.0 1.0 } underlying>> glLightfv + GL_LIGHT0 GL_AMBIENT float-array{ 0.2 0.2 0.2 1.0 } underlying>> glLightfv + GL_LIGHT0 GL_DIFFUSE float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv + GL_LIGHT0 GL_SPECULAR float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv ; : player-view ( player -- ) [ location>> ] diff --git a/extra/jamshred/jamshred.factor b/unmaintained/jamshred/jamshred.factor similarity index 100% rename from extra/jamshred/jamshred.factor rename to unmaintained/jamshred/jamshred.factor diff --git a/extra/jamshred/log/log.factor b/unmaintained/jamshred/log/log.factor similarity index 100% rename from extra/jamshred/log/log.factor rename to unmaintained/jamshred/log/log.factor diff --git a/extra/jamshred/oint/authors.txt b/unmaintained/jamshred/oint/authors.txt similarity index 100% rename from extra/jamshred/oint/authors.txt rename to unmaintained/jamshred/oint/authors.txt diff --git a/extra/jamshred/oint/oint-tests.factor b/unmaintained/jamshred/oint/oint-tests.factor similarity index 100% rename from extra/jamshred/oint/oint-tests.factor rename to unmaintained/jamshred/oint/oint-tests.factor diff --git a/extra/jamshred/oint/oint.factor b/unmaintained/jamshred/oint/oint.factor similarity index 100% rename from extra/jamshred/oint/oint.factor rename to unmaintained/jamshred/oint/oint.factor diff --git a/extra/jamshred/player/authors.txt b/unmaintained/jamshred/player/authors.txt similarity index 100% rename from extra/jamshred/player/authors.txt rename to unmaintained/jamshred/player/authors.txt diff --git a/extra/jamshred/player/player.factor b/unmaintained/jamshred/player/player.factor similarity index 100% rename from extra/jamshred/player/player.factor rename to unmaintained/jamshred/player/player.factor diff --git a/extra/jamshred/sound/bang.wav b/unmaintained/jamshred/sound/bang.wav similarity index 100% rename from extra/jamshred/sound/bang.wav rename to unmaintained/jamshred/sound/bang.wav diff --git a/extra/jamshred/sound/sound.factor b/unmaintained/jamshred/sound/sound.factor similarity index 100% rename from extra/jamshred/sound/sound.factor rename to unmaintained/jamshred/sound/sound.factor diff --git a/extra/jamshred/summary.txt b/unmaintained/jamshred/summary.txt similarity index 100% rename from extra/jamshred/summary.txt rename to unmaintained/jamshred/summary.txt diff --git a/extra/jamshred/tags.txt b/unmaintained/jamshred/tags.txt similarity index 100% rename from extra/jamshred/tags.txt rename to unmaintained/jamshred/tags.txt diff --git a/extra/jamshred/tunnel/authors.txt b/unmaintained/jamshred/tunnel/authors.txt similarity index 100% rename from extra/jamshred/tunnel/authors.txt rename to unmaintained/jamshred/tunnel/authors.txt diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/unmaintained/jamshred/tunnel/tunnel-tests.factor similarity index 100% rename from extra/jamshred/tunnel/tunnel-tests.factor rename to unmaintained/jamshred/tunnel/tunnel-tests.factor diff --git a/extra/jamshred/tunnel/tunnel.factor b/unmaintained/jamshred/tunnel/tunnel.factor similarity index 100% rename from extra/jamshred/tunnel/tunnel.factor rename to unmaintained/jamshred/tunnel/tunnel.factor diff --git a/extra/math/derivatives/authors.txt b/unmaintained/math/derivatives/authors.txt similarity index 100% rename from extra/math/derivatives/authors.txt rename to unmaintained/math/derivatives/authors.txt diff --git a/extra/math/derivatives/derivatives-docs.factor b/unmaintained/math/derivatives/derivatives-docs.factor similarity index 100% rename from extra/math/derivatives/derivatives-docs.factor rename to unmaintained/math/derivatives/derivatives-docs.factor diff --git a/extra/math/derivatives/derivatives-tests.factor b/unmaintained/math/derivatives/derivatives-tests.factor similarity index 100% rename from extra/math/derivatives/derivatives-tests.factor rename to unmaintained/math/derivatives/derivatives-tests.factor diff --git a/extra/math/derivatives/derivatives.factor b/unmaintained/math/derivatives/derivatives.factor similarity index 100% rename from extra/math/derivatives/derivatives.factor rename to unmaintained/math/derivatives/derivatives.factor diff --git a/extra/math/newtons-method/authors.txt b/unmaintained/math/newtons-method/authors.txt similarity index 100% rename from extra/math/newtons-method/authors.txt rename to unmaintained/math/newtons-method/authors.txt diff --git a/extra/math/newtons-method/newtons-method.factor b/unmaintained/math/newtons-method/newtons-method.factor similarity index 100% rename from extra/math/newtons-method/newtons-method.factor rename to unmaintained/math/newtons-method/newtons-method.factor diff --git a/extra/morse/authors.txt b/unmaintained/morse/authors.txt similarity index 100% rename from extra/morse/authors.txt rename to unmaintained/morse/authors.txt diff --git a/extra/morse/morse-docs.factor b/unmaintained/morse/morse-docs.factor similarity index 100% rename from extra/morse/morse-docs.factor rename to unmaintained/morse/morse-docs.factor diff --git a/extra/morse/morse-tests.factor b/unmaintained/morse/morse-tests.factor similarity index 100% rename from extra/morse/morse-tests.factor rename to unmaintained/morse/morse-tests.factor diff --git a/extra/morse/morse.factor b/unmaintained/morse/morse.factor similarity index 100% rename from extra/morse/morse.factor rename to unmaintained/morse/morse.factor diff --git a/extra/morse/summary.txt b/unmaintained/morse/summary.txt similarity index 100% rename from extra/morse/summary.txt rename to unmaintained/morse/summary.txt diff --git a/extra/morse/tags.txt b/unmaintained/morse/tags.txt similarity index 100% rename from extra/morse/tags.txt rename to unmaintained/morse/tags.txt diff --git a/extra/nehe/2/2.factor b/unmaintained/nehe/2/2.factor similarity index 100% rename from extra/nehe/2/2.factor rename to unmaintained/nehe/2/2.factor diff --git a/extra/nehe/2/authors.txt b/unmaintained/nehe/2/authors.txt similarity index 100% rename from extra/nehe/2/authors.txt rename to unmaintained/nehe/2/authors.txt diff --git a/extra/nehe/3/3.factor b/unmaintained/nehe/3/3.factor similarity index 100% rename from extra/nehe/3/3.factor rename to unmaintained/nehe/3/3.factor diff --git a/extra/nehe/3/authors.txt b/unmaintained/nehe/3/authors.txt similarity index 100% rename from extra/nehe/3/authors.txt rename to unmaintained/nehe/3/authors.txt diff --git a/extra/nehe/4/4.factor b/unmaintained/nehe/4/4.factor similarity index 100% rename from extra/nehe/4/4.factor rename to unmaintained/nehe/4/4.factor diff --git a/extra/nehe/4/authors.txt b/unmaintained/nehe/4/authors.txt similarity index 100% rename from extra/nehe/4/authors.txt rename to unmaintained/nehe/4/authors.txt diff --git a/extra/nehe/5/5.factor b/unmaintained/nehe/5/5.factor similarity index 100% rename from extra/nehe/5/5.factor rename to unmaintained/nehe/5/5.factor diff --git a/extra/nehe/5/authors.txt b/unmaintained/nehe/5/authors.txt similarity index 100% rename from extra/nehe/5/authors.txt rename to unmaintained/nehe/5/authors.txt diff --git a/extra/nehe/authors.txt b/unmaintained/nehe/authors.txt similarity index 100% rename from extra/nehe/authors.txt rename to unmaintained/nehe/authors.txt diff --git a/extra/nehe/deploy.factor b/unmaintained/nehe/deploy.factor similarity index 100% rename from extra/nehe/deploy.factor rename to unmaintained/nehe/deploy.factor diff --git a/extra/nehe/nehe.factor b/unmaintained/nehe/nehe.factor similarity index 100% rename from extra/nehe/nehe.factor rename to unmaintained/nehe/nehe.factor diff --git a/extra/nehe/summary.txt b/unmaintained/nehe/summary.txt similarity index 100% rename from extra/nehe/summary.txt rename to unmaintained/nehe/summary.txt diff --git a/extra/nehe/tags.txt b/unmaintained/nehe/tags.txt similarity index 100% rename from extra/nehe/tags.txt rename to unmaintained/nehe/tags.txt diff --git a/extra/openal/authors.txt b/unmaintained/openal/authors.txt similarity index 100% rename from extra/openal/authors.txt rename to unmaintained/openal/authors.txt diff --git a/extra/openal/backend/authors.txt b/unmaintained/openal/backend/authors.txt similarity index 100% rename from extra/openal/backend/authors.txt rename to unmaintained/openal/backend/authors.txt diff --git a/extra/openal/backend/backend.factor b/unmaintained/openal/backend/backend.factor similarity index 100% rename from extra/openal/backend/backend.factor rename to unmaintained/openal/backend/backend.factor diff --git a/extra/openal/example/authors.txt b/unmaintained/openal/example/authors.txt similarity index 100% rename from extra/openal/example/authors.txt rename to unmaintained/openal/example/authors.txt diff --git a/extra/openal/example/example.factor b/unmaintained/openal/example/example.factor similarity index 100% rename from extra/openal/example/example.factor rename to unmaintained/openal/example/example.factor diff --git a/extra/openal/macosx/authors.txt b/unmaintained/openal/macosx/authors.txt similarity index 100% rename from extra/openal/macosx/authors.txt rename to unmaintained/openal/macosx/authors.txt diff --git a/extra/openal/macosx/macosx.factor b/unmaintained/openal/macosx/macosx.factor similarity index 100% rename from extra/openal/macosx/macosx.factor rename to unmaintained/openal/macosx/macosx.factor diff --git a/extra/openal/macosx/tags.txt b/unmaintained/openal/macosx/tags.txt similarity index 100% rename from extra/openal/macosx/tags.txt rename to unmaintained/openal/macosx/tags.txt diff --git a/extra/openal/openal.factor b/unmaintained/openal/openal.factor similarity index 98% rename from extra/openal/openal.factor rename to unmaintained/openal/openal.factor index 2a8959b4a0..40593d1e8d 100644 --- a/extra/openal/openal.factor +++ b/unmaintained/openal/openal.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel arrays alien system combinators alien.syntax namespaces alien.c-types sequences vocabs.loader shuffle combinators.lib - openal.backend ; + openal.backend specialized-arrays.uint ; IN: openal << "alut" { @@ -248,10 +248,10 @@ SYMBOL: init : ( n -- byte-array ) "ALuint" ; : gen-sources ( size -- seq ) - dup 2dup alGenSources swap c-uint-array> ; + dup 2dup underlying>> alGenSources swap ; : gen-buffers ( size -- seq ) - dup 2dup alGenBuffers swap c-uint-array> ; + dup 2dup underlying>> alGenBuffers swap ; : gen-buffer ( -- buffer ) 1 gen-buffers first ; @@ -267,7 +267,7 @@ os macosx? "openal.macosx" "openal.other" ? require [ alBufferData ] 4keep alutUnloadWAV ; : queue-buffers ( source buffers -- ) - [ length ] [ >c-uint-array ] bi alSourceQueueBuffers ; + [ length ] [ >uint-array underlying>> ] bi alSourceQueueBuffers ; : queue-buffer ( source buffer -- ) 1array queue-buffers ; diff --git a/extra/openal/other/authors.txt b/unmaintained/openal/other/authors.txt similarity index 100% rename from extra/openal/other/authors.txt rename to unmaintained/openal/other/authors.txt diff --git a/extra/openal/other/other.factor b/unmaintained/openal/other/other.factor similarity index 100% rename from extra/openal/other/other.factor rename to unmaintained/openal/other/other.factor diff --git a/extra/openal/summary.txt b/unmaintained/openal/summary.txt similarity index 100% rename from extra/openal/summary.txt rename to unmaintained/openal/summary.txt diff --git a/extra/openal/tags.txt b/unmaintained/openal/tags.txt similarity index 100% rename from extra/openal/tags.txt rename to unmaintained/openal/tags.txt diff --git a/extra/opengl/capabilities/authors.txt b/unmaintained/opengl/capabilities/authors.txt similarity index 100% rename from extra/opengl/capabilities/authors.txt rename to unmaintained/opengl/capabilities/authors.txt diff --git a/extra/opengl/capabilities/capabilities-docs.factor b/unmaintained/opengl/capabilities/capabilities-docs.factor similarity index 100% rename from extra/opengl/capabilities/capabilities-docs.factor rename to unmaintained/opengl/capabilities/capabilities-docs.factor diff --git a/extra/opengl/capabilities/capabilities.factor b/unmaintained/opengl/capabilities/capabilities.factor similarity index 100% rename from extra/opengl/capabilities/capabilities.factor rename to unmaintained/opengl/capabilities/capabilities.factor diff --git a/extra/opengl/capabilities/summary.txt b/unmaintained/opengl/capabilities/summary.txt similarity index 100% rename from extra/opengl/capabilities/summary.txt rename to unmaintained/opengl/capabilities/summary.txt diff --git a/extra/opengl/capabilities/tags.txt b/unmaintained/opengl/capabilities/tags.txt similarity index 100% rename from extra/opengl/capabilities/tags.txt rename to unmaintained/opengl/capabilities/tags.txt diff --git a/extra/opengl/demo-support/authors.txt b/unmaintained/opengl/demo-support/authors.txt similarity index 100% rename from extra/opengl/demo-support/authors.txt rename to unmaintained/opengl/demo-support/authors.txt diff --git a/extra/opengl/demo-support/demo-support.factor b/unmaintained/opengl/demo-support/demo-support.factor similarity index 100% rename from extra/opengl/demo-support/demo-support.factor rename to unmaintained/opengl/demo-support/demo-support.factor diff --git a/extra/opengl/demo-support/summary.txt b/unmaintained/opengl/demo-support/summary.txt similarity index 100% rename from extra/opengl/demo-support/summary.txt rename to unmaintained/opengl/demo-support/summary.txt diff --git a/extra/opengl/demo-support/tags.txt b/unmaintained/opengl/demo-support/tags.txt similarity index 100% rename from extra/opengl/demo-support/tags.txt rename to unmaintained/opengl/demo-support/tags.txt diff --git a/extra/opengl/framebuffers/authors.txt b/unmaintained/opengl/framebuffers/authors.txt similarity index 100% rename from extra/opengl/framebuffers/authors.txt rename to unmaintained/opengl/framebuffers/authors.txt diff --git a/extra/opengl/framebuffers/framebuffers-docs.factor b/unmaintained/opengl/framebuffers/framebuffers-docs.factor similarity index 100% rename from extra/opengl/framebuffers/framebuffers-docs.factor rename to unmaintained/opengl/framebuffers/framebuffers-docs.factor diff --git a/extra/opengl/framebuffers/framebuffers.factor b/unmaintained/opengl/framebuffers/framebuffers.factor similarity index 100% rename from extra/opengl/framebuffers/framebuffers.factor rename to unmaintained/opengl/framebuffers/framebuffers.factor diff --git a/extra/opengl/framebuffers/summary.txt b/unmaintained/opengl/framebuffers/summary.txt similarity index 100% rename from extra/opengl/framebuffers/summary.txt rename to unmaintained/opengl/framebuffers/summary.txt diff --git a/extra/opengl/framebuffers/tags.txt b/unmaintained/opengl/framebuffers/tags.txt similarity index 100% rename from extra/opengl/framebuffers/tags.txt rename to unmaintained/opengl/framebuffers/tags.txt diff --git a/extra/opengl/gadgets/gadgets-tests.factor b/unmaintained/opengl/gadgets/gadgets-tests.factor similarity index 100% rename from extra/opengl/gadgets/gadgets-tests.factor rename to unmaintained/opengl/gadgets/gadgets-tests.factor diff --git a/extra/opengl/gadgets/gadgets.factor b/unmaintained/opengl/gadgets/gadgets.factor similarity index 100% rename from extra/opengl/gadgets/gadgets.factor rename to unmaintained/opengl/gadgets/gadgets.factor diff --git a/extra/opengl/shaders/authors.txt b/unmaintained/opengl/shaders/authors.txt similarity index 100% rename from extra/opengl/shaders/authors.txt rename to unmaintained/opengl/shaders/authors.txt diff --git a/extra/opengl/shaders/shaders-docs.factor b/unmaintained/opengl/shaders/shaders-docs.factor similarity index 100% rename from extra/opengl/shaders/shaders-docs.factor rename to unmaintained/opengl/shaders/shaders-docs.factor diff --git a/extra/opengl/shaders/shaders.factor b/unmaintained/opengl/shaders/shaders.factor similarity index 95% rename from extra/opengl/shaders/shaders.factor rename to unmaintained/opengl/shaders/shaders.factor index d52e55417f..a88ea6de4d 100755 --- a/extra/opengl/shaders/shaders.factor +++ b/unmaintained/opengl/shaders/shaders.factor @@ -44,9 +44,10 @@ IN: opengl.shaders : gl-shader-info-log ( shader -- log ) dup gl-shader-info-log-length dup [ + 1 calloc &free [ 0 swap glGetShaderInfoLog ] keep ascii alien>string - ] with-malloc ; + ] with-destructors ; : check-gl-shader ( shader -- shader ) dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ; @@ -79,9 +80,10 @@ 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 ascii alien>string - ] with-malloc ; + ] with-destructors ; : check-gl-program ( program -- program ) dup gl-program-ok? [ dup gl-program-info-log throw ] unless ; @@ -91,10 +93,9 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; : gl-program-shaders ( program -- shaders ) dup gl-program-shaders-length - dup "GLuint" + dup 0 swap - [ glGetAttachedShaders ] { 3 1 } multikeep - c-uint-array> ; + [ underlying>> glGetAttachedShaders ] { 3 1 } multikeep ; : delete-gl-program-only ( program -- ) glDeleteProgram ; inline diff --git a/extra/opengl/shaders/summary.txt b/unmaintained/opengl/shaders/summary.txt similarity index 100% rename from extra/opengl/shaders/summary.txt rename to unmaintained/opengl/shaders/summary.txt diff --git a/extra/opengl/shaders/tags.txt b/unmaintained/opengl/shaders/tags.txt similarity index 100% rename from extra/opengl/shaders/tags.txt rename to unmaintained/opengl/shaders/tags.txt diff --git a/extra/ui/gadgets/plot/plot.factor b/unmaintained/plot/plot.factor similarity index 100% rename from extra/ui/gadgets/plot/plot.factor rename to unmaintained/plot/plot.factor diff --git a/extra/pong/pong.factor b/unmaintained/pong/pong.factor similarity index 100% rename from extra/pong/pong.factor rename to unmaintained/pong/pong.factor diff --git a/extra/spheres/authors.txt b/unmaintained/spheres/authors.txt similarity index 100% rename from extra/spheres/authors.txt rename to unmaintained/spheres/authors.txt diff --git a/extra/spheres/deploy.factor b/unmaintained/spheres/deploy.factor similarity index 100% rename from extra/spheres/deploy.factor rename to unmaintained/spheres/deploy.factor diff --git a/extra/spheres/spheres.factor b/unmaintained/spheres/spheres.factor similarity index 100% rename from extra/spheres/spheres.factor rename to unmaintained/spheres/spheres.factor diff --git a/extra/spheres/summary.txt b/unmaintained/spheres/summary.txt similarity index 100% rename from extra/spheres/summary.txt rename to unmaintained/spheres/summary.txt diff --git a/extra/spheres/tags.txt b/unmaintained/spheres/tags.txt similarity index 100% rename from extra/spheres/tags.txt rename to unmaintained/spheres/tags.txt diff --git a/extra/synth/authors.txt b/unmaintained/synth/authors.txt similarity index 100% rename from extra/synth/authors.txt rename to unmaintained/synth/authors.txt diff --git a/extra/synth/buffers/authors.txt b/unmaintained/synth/buffers/authors.txt similarity index 100% rename from extra/synth/buffers/authors.txt rename to unmaintained/synth/buffers/authors.txt diff --git a/extra/synth/buffers/buffers.factor b/unmaintained/synth/buffers/buffers.factor similarity index 93% rename from extra/synth/buffers/buffers.factor rename to unmaintained/synth/buffers/buffers.factor index faff19d8fd..b0128ca52a 100644 --- a/extra/synth/buffers/buffers.factor +++ b/unmaintained/synth/buffers/buffers.factor @@ -38,10 +38,10 @@ M: 8bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO8 ; M: 16bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO16 ; : 8bit-buffer-data ( seq -- data size ) - [ 128 * >integer 128 + ] map [ >c-uchar-array ] [ length ] bi ; + [ 128 * >integer 128 + ] uchar-array{ } map-as [ underlying>> ] [ length ] bi ; : 16bit-buffer-data ( seq -- data size ) - [ 32768 * >integer ] map [ >c-short-array ] [ length 2 * ] bi ; + [ 32768 * >integer ] short-array{ } map-as [ underlying>> ] [ byte-length ] bi ; : stereo-data ( stereo-buffer -- left right ) [ left-data>> ] [ right-data>> ] bi@ ; diff --git a/extra/synth/example/authors.txt b/unmaintained/synth/example/authors.txt similarity index 100% rename from extra/synth/example/authors.txt rename to unmaintained/synth/example/authors.txt diff --git a/extra/synth/example/example.factor b/unmaintained/synth/example/example.factor similarity index 100% rename from extra/synth/example/example.factor rename to unmaintained/synth/example/example.factor diff --git a/extra/synth/summary.txt b/unmaintained/synth/summary.txt similarity index 100% rename from extra/synth/summary.txt rename to unmaintained/synth/summary.txt diff --git a/extra/synth/synth.factor b/unmaintained/synth/synth.factor similarity index 100% rename from extra/synth/synth.factor rename to unmaintained/synth/synth.factor diff --git a/extra/xml/syntax/syntax.factor b/unmaintained/xml/syntax/syntax.factor similarity index 100% rename from extra/xml/syntax/syntax.factor rename to unmaintained/xml/syntax/syntax.factor