diff --git a/Makefile b/Makefile index 35cf7a05c4..6aee3e329d 100755 --- a/Makefile +++ b/Makefile @@ -41,22 +41,25 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/callstack.o \ vm/code_block.o \ vm/code_heap.o \ + vm/compaction.o \ vm/contexts.o \ vm/data_heap.o \ + vm/data_heap_checker.o \ vm/debug.o \ vm/dispatch.o \ vm/errors.o \ vm/factor.o \ + vm/free_list.o \ vm/full_collector.o \ vm/gc.o \ - vm/heap.o \ vm/image.o \ vm/inline_cache.o \ vm/io.o \ vm/jit.o \ vm/math.o \ vm/nursery_collector.o \ - vm/old_space.o \ + vm/object_start_map.o \ + vm/objects.o \ vm/primitives.o \ vm/profiler.o \ vm/quotations.o \ diff --git a/basis/alarms/alarms-docs.factor b/basis/alarms/alarms-docs.factor index 82134e825e..df88f49701 100644 --- a/basis/alarms/alarms-docs.factor +++ b/basis/alarms/alarms-docs.factor @@ -1,16 +1,23 @@ -IN: alarms USING: help.markup help.syntax calendar quotations ; +IN: alarms HELP: alarm { $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ; HELP: add-alarm { $values { "quot" quotation } { "time" timestamp } { "frequency" { $maybe duration } } { "alarm" alarm } } -{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ; +{ $description "Creates and registers an alarm to start at " { $snippet "time" } ". If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ; HELP: later { $values { "quot" quotation } { "duration" duration } { "alarm" alarm } } -{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ; +{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } +{ $examples + { $unchecked-example + "USING: alarms io calendar ;" + """[ "GET BACK TO WORK, Guy." print flush ] 10 minutes later drop""" + "" + } +} ; HELP: cancel-alarm { $values { "alarm" alarm } } @@ -20,16 +27,29 @@ HELP: every { $values { "quot" quotation } { "duration" duration } { "alarm" alarm } } -{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." } ; +{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." } +{ $examples + { $unchecked-example + "USING: alarms io calendar ;" + """[ "Hi Buddy." print flush ] 10 seconds every drop""" + "" + } +} ; ARTICLE: "alarms" "Alarms" -"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread." +"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread." $nl +"The alarm class:" { $subsections alarm - add-alarm - later - cancel-alarm } +"Register a recurring alarm:" +{ $subsections every } +"Register a one-time alarm:" +{ $subsections later } +"Low-level interface to add alarms:" +{ $subsections add-alarm } +"Cancelling an alarm:" +{ $subsections cancel-alarm } "Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ; ABOUT: "alarms" diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index ee75d22c2c..7eed1a0664 100755 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -20,6 +20,8 @@ M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ; M: array c-type-align first c-type-align ; +M: array c-type-align-first first c-type-align-first ; + M: array c-type-stack-align? drop f ; M: array unbox-parameter drop void* unbox-parameter ; @@ -55,6 +57,9 @@ M: string-type heap-size M: string-type c-type-align drop void* c-type-align ; +M: string-type c-type-align-first + drop void* c-type-align-first ; + M: string-type c-type-stack-align? drop void* c-type-stack-align? ; @@ -97,5 +102,5 @@ M: string-type c-type-setter { char* utf8 } char* typedef char* uchar* typedef -char char* "pointer-c-type" set-word-prop +char char* "pointer-c-type" set-word-prop uchar uchar* "pointer-c-type" set-word-prop diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index d622a42c9d..027fe046b6 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -30,8 +30,9 @@ TUPLE: abstract-c-type { unboxer-quot callable } { getter callable } { setter callable } -size -align ; +{ size integer } +{ align integer } +{ align-first integer } ; TUPLE: c-type < abstract-c-type boxer @@ -104,10 +105,9 @@ M: word c-type GENERIC: c-struct? ( c-type -- ? ) -M: object c-struct? - drop f ; -M: c-type-name c-struct? - dup void? [ drop f ] [ c-type c-struct? ] if ; +M: object c-struct? drop f ; + +M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ; ! These words being foldable means that words need to be ! recompiled if a C type is redefined. Even so, folding the @@ -172,6 +172,12 @@ M: abstract-c-type c-type-align align>> ; M: c-type-name c-type-align c-type c-type-align ; +GENERIC: c-type-align-first ( name -- n ) + +M: c-type-name c-type-align-first c-type c-type-align-first ; + +M: abstract-c-type c-type-align-first align-first>> ; + GENERIC: c-type-stack-align? ( name -- ? ) M: c-type c-type-stack-align? stack-align?>> ; @@ -230,6 +236,10 @@ M: byte-array byte-length length ; inline M: f byte-length drop 0 ; inline +: >c-bool ( ? -- int ) 1 0 ? ; inline + +: c-bool> ( int -- ? ) 0 = not ; inline + MIXIN: value-type : c-getter ( name -- quot ) @@ -256,6 +266,7 @@ PREDICATE: typedef-word < c-type-word "c-type" word-prop c-type-name? ; M: string typedef ( old new -- ) c-types get set-at ; + M: word typedef ( old new -- ) { [ nip define-symbol ] @@ -292,7 +303,7 @@ M: long-long-type box-return ( c-type -- ) : define-out ( name -- ) [ "alien.c-types" constructor-word ] - [ dup c-setter '[ _ heap-size [ 0 @ ] keep ] ] bi + [ dup c-setter '[ _ heap-size (byte-array) [ 0 @ ] keep ] ] bi (( value -- c-ptr )) define-inline ; : define-primitive-type ( c-type name -- ) @@ -319,6 +330,13 @@ SYMBOLS: ptrdiff_t intptr_t uintptr_t size_t char* uchar* ; +: 8-byte-alignment ( c-type -- c-type ) + { + { [ cpu ppc? os macosx? and ] [ 4 >>align 8 >>align-first ] } + { [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] } + [ 8 >>align 8 >>align-first ] + } cond ; + [ c-ptr >>class @@ -327,6 +345,7 @@ SYMBOLS: [ [ >c-ptr ] 2dip set-alien-cell ] >>setter bootstrap-cell >>size bootstrap-cell >>align + bootstrap-cell >>align-first [ >c-ptr ] >>unboxer-quot "box_alien" >>boxer "alien_offset" >>unboxer @@ -338,7 +357,7 @@ SYMBOLS: [ alien-signed-8 ] >>getter [ set-alien-signed-8 ] >>setter 8 >>size - 8 >>align + 8-byte-alignment "box_signed_8" >>boxer "to_signed_8" >>unboxer \ longlong define-primitive-type @@ -349,7 +368,7 @@ SYMBOLS: [ alien-unsigned-8 ] >>getter [ set-alien-unsigned-8 ] >>setter 8 >>size - 8 >>align + 8-byte-alignment "box_unsigned_8" >>boxer "to_unsigned_8" >>unboxer \ ulonglong define-primitive-type @@ -361,6 +380,7 @@ SYMBOLS: [ set-alien-signed-cell ] >>setter bootstrap-cell >>size bootstrap-cell >>align + bootstrap-cell >>align-first "box_signed_cell" >>boxer "to_fixnum" >>unboxer \ long define-primitive-type @@ -372,6 +392,7 @@ SYMBOLS: [ set-alien-unsigned-cell ] >>setter bootstrap-cell >>size bootstrap-cell >>align + bootstrap-cell >>align-first "box_unsigned_cell" >>boxer "to_cell" >>unboxer \ ulong define-primitive-type @@ -383,6 +404,7 @@ SYMBOLS: [ set-alien-signed-4 ] >>setter 4 >>size 4 >>align + 4 >>align-first "box_signed_4" >>boxer "to_fixnum" >>unboxer \ int define-primitive-type @@ -394,6 +416,7 @@ SYMBOLS: [ set-alien-unsigned-4 ] >>setter 4 >>size 4 >>align + 4 >>align-first "box_unsigned_4" >>boxer "to_cell" >>unboxer \ uint define-primitive-type @@ -405,6 +428,7 @@ SYMBOLS: [ set-alien-signed-2 ] >>setter 2 >>size 2 >>align + 2 >>align-first "box_signed_2" >>boxer "to_fixnum" >>unboxer \ short define-primitive-type @@ -416,6 +440,7 @@ SYMBOLS: [ set-alien-unsigned-2 ] >>setter 2 >>size 2 >>align + 2 >>align-first "box_unsigned_2" >>boxer "to_cell" >>unboxer \ ushort define-primitive-type @@ -427,6 +452,7 @@ SYMBOLS: [ set-alien-signed-1 ] >>setter 1 >>size 1 >>align + 1 >>align-first "box_signed_1" >>boxer "to_fixnum" >>unboxer \ char define-primitive-type @@ -438,17 +464,30 @@ SYMBOLS: [ set-alien-unsigned-1 ] >>setter 1 >>size 1 >>align + 1 >>align-first "box_unsigned_1" >>boxer "to_cell" >>unboxer \ uchar define-primitive-type - - [ alien-unsigned-1 0 = not ] >>getter - [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter - 1 >>size - 1 >>align - "box_boolean" >>boxer - "to_boolean" >>unboxer + cpu ppc? [ + + [ alien-unsigned-4 c-bool> ] >>getter + [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter + 4 >>size + 4 >>align + 4 >>align-first + "box_boolean" >>boxer + "to_boolean" >>unboxer + ] [ + + [ alien-unsigned-1 c-bool> ] >>getter + [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter + 1 >>size + 1 >>align + 1 >>align-first + "box_boolean" >>boxer + "to_boolean" >>unboxer + ] if \ bool define-primitive-type @@ -458,6 +497,7 @@ SYMBOLS: [ [ >float ] 2dip set-alien-float ] >>setter 4 >>size 4 >>align + 4 >>align-first "box_float" >>boxer "to_float" >>unboxer float-rep >>rep @@ -470,17 +510,24 @@ SYMBOLS: [ alien-double ] >>getter [ [ >float ] 2dip set-alien-double ] >>setter 8 >>size - 8 >>align + 8-byte-alignment "box_double" >>boxer "to_double" >>unboxer double-rep >>rep [ >float ] >>unboxer-quot \ double define-primitive-type - \ long c-type \ ptrdiff_t typedef - \ long c-type \ intptr_t typedef - \ ulong c-type \ uintptr_t typedef - \ ulong c-type \ size_t typedef + cpu x86.64? os windows? and [ + \ longlong c-type \ ptrdiff_t typedef + \ longlong c-type \ intptr_t typedef + \ ulonglong c-type \ uintptr_t typedef + \ ulonglong c-type \ size_t typedef + ] [ + \ long c-type \ ptrdiff_t typedef + \ long c-type \ intptr_t typedef + \ ulong c-type \ uintptr_t typedef + \ ulong c-type \ size_t typedef + ] if ] with-compilation-unit M: char-16-rep rep-component-type drop char ; @@ -501,9 +548,9 @@ M: double-2-rep rep-component-type drop double ; : c-type-interval ( c-type -- from to ) { - { [ dup { float double } memq? ] [ drop -1/0. 1/0. ] } - { [ dup { char short int long longlong } memq? ] [ signed-interval ] } - { [ dup { uchar ushort uint ulong ulonglong } memq? ] [ unsigned-interval ] } + { [ dup { float double } member-eq? ] [ drop -1/0. 1/0. ] } + { [ dup { char short int long longlong } member-eq? ] [ signed-interval ] } + { [ dup { uchar ushort uint ulong ulonglong } member-eq? ] [ unsigned-interval ] } } cond ; foldable : c-type-clamp ( value c-type -- value' ) c-type-interval clamp ; inline diff --git a/basis/alien/data/data.factor b/basis/alien/data/data.factor index fc18921ef1..93b1afd436 100644 --- a/basis/alien/data/data.factor +++ b/basis/alien/data/data.factor @@ -65,10 +65,6 @@ M: memory-stream stream-read : byte-array>memory ( byte-array base -- ) swap dup byte-length memcpy ; inline -: >c-bool ( ? -- int ) 1 0 ? ; inline - -: c-bool> ( int -- ? ) 0 = not ; inline - M: value-type c-type-rep drop int-rep ; M: value-type c-type-getter @@ -77,5 +73,3 @@ M: value-type c-type-getter M: value-type c-type-setter ( type -- quot ) [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri '[ @ swap @ _ memcpy ] ; - - diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index bf8721b549..d7659d8400 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -205,9 +205,6 @@ M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; M: real-type (fortran-ret-type>c-type) drop real-functions-return-double? [ "double" ] [ "float" ] if ; -: suffix! ( seq elt -- seq ) over push ; inline -: append! ( seq-a seq-b -- seq-a ) over push-all ; inline - GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot ) : args?dims ( type quot -- main-quot added-quot ) @@ -333,7 +330,7 @@ M: character-type () ] if-empty ; :: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot ) - return parameters fortran-sig>c-sig :> c-parameters :> c-return + return parameters fortran-sig>c-sig :> ( c-return c-parameters ) function fortran-name>symbol-name :> c-function [args>args] c-return library c-function c-parameters \ alien-invoke diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 4b83739efe..0cf495fd25 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -98,7 +98,7 @@ IN: alien.parser type-name current-vocab create :> type-word type-word [ reset-generic ] [ reset-c-type ] bi void* type-word typedef - parameters return parse-arglist :> callback-effect :> types + parameters return parse-arglist :> ( types callback-effect ) type-word callback-effect "callback-effect" set-word-prop type-word lib "callback-library" set-word-prop type-word return types lib library-abi callback-quot (( quot -- alien )) ; diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 7adf837841..609ed2826d 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -7,11 +7,11 @@ effects assocs combinators lexer strings.parser alien.parser fry vocabs.parser words.constant alien.libraries ; IN: alien.syntax -SYNTAX: DLL" lexer get skip-blank parse-string dlopen parsed ; +SYNTAX: DLL" lexer get skip-blank parse-string dlopen suffix! ; -SYNTAX: ALIEN: 16 scan-base parsed ; +SYNTAX: ALIEN: 16 scan-base suffix! ; -SYNTAX: BAD-ALIEN parsed ; +SYNTAX: BAD-ALIEN suffix! ; SYNTAX: LIBRARY: scan "c-library" set ; @@ -37,7 +37,7 @@ ERROR: no-such-symbol name library ; 2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ; SYNTAX: &: - scan "c-library" get '[ _ _ address-of ] over push-all ; + scan "c-library" get '[ _ _ address-of ] append! ; : global-quot ( type word -- quot ) name>> "c-library" get '[ _ _ address-of 0 ] diff --git a/basis/binary-search/binary-search-docs.factor b/basis/binary-search/binary-search-docs.factor index 728ac41e94..aa015c5502 100644 --- a/basis/binary-search/binary-search-docs.factor +++ b/basis/binary-search/binary-search-docs.factor @@ -25,11 +25,11 @@ HELP: sorted-member? { member? sorted-member? } related-words -HELP: sorted-memq? +HELP: sorted-member-eq? { $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a boolean" } } { $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ; -{ memq? sorted-memq? } related-words +{ member-eq? sorted-member-eq? } related-words ARTICLE: "binary-search" "Binary search" "The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time." @@ -38,7 +38,7 @@ ARTICLE: "binary-search" "Binary search" { $subsections sorted-index sorted-member? - sorted-memq? + sorted-member-eq? } { $see-also "order-specifiers" "sequences-sorting" } ; diff --git a/basis/binary-search/binary-search.factor b/basis/binary-search/binary-search.factor index aba3cfbfe5..89a300202a 100644 --- a/basis/binary-search/binary-search.factor +++ b/basis/binary-search/binary-search.factor @@ -49,5 +49,5 @@ HINTS: natural-search array ; : sorted-member? ( obj seq -- ? ) dupd natural-search nip = ; -: sorted-memq? ( obj seq -- ? ) +: sorted-member-eq? ( obj seq -- ? ) dupd natural-search nip eq? ; diff --git a/basis/bit-arrays/bit-arrays-docs.factor b/basis/bit-arrays/bit-arrays-docs.factor index e9c9e1dc51..76b636c3f3 100644 --- a/basis/bit-arrays/bit-arrays-docs.factor +++ b/basis/bit-arrays/bit-arrays-docs.factor @@ -55,7 +55,7 @@ HELP: clear-bits { $values { "bit-array" bit-array } } { $description "Sets all elements of the bit array to " { $link f } "." } { $notes "Calling this word is more efficient than the following:" - { $code "[ drop f ] change-each" } + { $code "[ drop f ] map! drop" } } { $side-effects "bit-array" } ; @@ -63,7 +63,7 @@ HELP: set-bits { $values { "bit-array" bit-array } } { $description "Sets all elements of the bit array to " { $link t } "." } { $notes "Calling this word is more efficient than the following:" - { $code "[ drop t ] change-each" } + { $code "[ drop t ] map! drop" } } { $side-effects "bit-array" } ; diff --git a/basis/bit-arrays/bit-arrays-tests.factor b/basis/bit-arrays/bit-arrays-tests.factor index 1de49d353d..7397791ab5 100644 --- a/basis/bit-arrays/bit-arrays-tests.factor +++ b/basis/bit-arrays/bit-arrays-tests.factor @@ -20,7 +20,7 @@ IN: bit-arrays.tests [ { t f t } { f t f } ] [ - { t f t } >bit-array dup clone dup [ not ] change-each + { t f t } >bit-array dup clone [ not ] map! [ >array ] bi@ ] unit-test diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 0eef54dc66..c4e1ec42b2 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -113,7 +113,7 @@ PRIVATE> M:: lsb0-bit-writer poke ( value n bs -- ) value n :> widthed widthed - bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte + bs widthed>> #bits>> 8 swap - split-widthed :> ( byte remainder ) byte bs widthed>> |widthed :> new-byte new-byte #bits>> 8 = [ new-byte bits>> bs bytes>> push @@ -143,7 +143,7 @@ ERROR: not-enough-bits n bit-reader ; neg shift n bits ; :: adjust-bits ( n bs -- ) - n 8 /mod :> #bits :> #bytes + n 8 /mod :> ( #bytes #bits ) bs [ #bytes + ] change-byte-pos bit-pos>> #bits + dup 8 >= [ 8 - bs (>>bit-pos) diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index e9187cc3b1..3b7848251b 100755 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -49,7 +49,7 @@ gc { not ? - 2over roll -roll + 2over array? hashtable? vector? tuple? sbuf? tombstone? @@ -94,7 +94,7 @@ gc "." write flush { - memq? split harvest sift cut cut-slice start index clone + member-eq? split harvest sift cut cut-slice start index clone set-at reverse push-all class number>string string>number like clone-like } compile-unoptimized @@ -118,4 +118,4 @@ gc " done" print flush -] unless \ No newline at end of file +] unless diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index e086215e91..b2c7f37013 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -1,14 +1,16 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays byte-arrays generic hashtables hashtables.private -io io.binary io.files io.encodings.binary io.pathnames kernel -kernel.private math namespaces make parser prettyprint sequences -strings sbufs vectors words quotations assocs system layouts splitting -grouping growable classes classes.builtin classes.tuple -classes.tuple.private vocabs vocabs.loader source-files definitions -debugger quotations.private combinators math.order math.private -accessors slots.private generic.single.private compiler.units -compiler.constants fry bootstrap.image.syntax ; +USING: alien arrays byte-arrays generic hashtables +hashtables.private io io.binary io.files io.encodings.binary +io.pathnames kernel kernel.private math namespaces make parser +prettyprint sequences strings sbufs vectors words quotations +assocs system layouts splitting grouping growable classes +classes.builtin classes.tuple classes.tuple.private vocabs +vocabs.loader source-files definitions debugger +quotations.private combinators combinators.short-circuit +math.order math.private accessors slots.private +generic.single.private compiler.units compiler.constants fry +bootstrap.image.syntax ; IN: bootstrap.image : arch ( os cpu -- arch ) @@ -38,7 +40,7 @@ IN: bootstrap.image ! Object cache; we only consider numbers equal if they have the ! same type -TUPLE: eql-wrapper obj ; +TUPLE: eql-wrapper { obj read-only } ; C: eql-wrapper @@ -47,31 +49,31 @@ M: eql-wrapper hashcode* obj>> hashcode* ; GENERIC: (eql?) ( obj1 obj2 -- ? ) : eql? ( obj1 obj2 -- ? ) - [ (eql?) ] [ [ class ] bi@ = ] 2bi and ; + { [ [ class ] bi@ = ] [ (eql?) ] } 2&& ; -M: integer (eql?) = ; +M: fixnum (eql?) eq? ; -M: float (eql?) - over float? [ fp-bitwise= ] [ 2drop f ] if ; +M: bignum (eql?) = ; -M: sequence (eql?) - over sequence? [ - 2dup [ length ] bi@ = - [ [ eql? ] 2all? ] [ 2drop f ] if - ] [ 2drop f ] if ; +M: float (eql?) fp-bitwise= ; + +M: sequence (eql?) 2dup [ length ] bi@ = [ [ eql? ] 2all? ] [ 2drop f ] if ; M: object (eql?) = ; M: eql-wrapper equal? over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ; -TUPLE: eq-wrapper obj ; +TUPLE: eq-wrapper { obj read-only } ; C: eq-wrapper M: eq-wrapper equal? over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ; +M: eq-wrapper hashcode* + nip obj>> identity-hashcode ; + SYMBOL: objects : cache-eql-object ( obj quot -- value ) @@ -177,14 +179,12 @@ USERENV: callback-stub 45 ! PIC stubs USERENV: pic-load 47 USERENV: pic-tag 48 -USERENV: pic-hi-tag 49 -USERENV: pic-tuple 50 -USERENV: pic-hi-tag-tuple 51 -USERENV: pic-check-tag 52 -USERENV: pic-check 53 -USERENV: pic-hit 54 -USERENV: pic-miss-word 55 -USERENV: pic-miss-tail-word 56 +USERENV: pic-tuple 49 +USERENV: pic-check-tag 50 +USERENV: pic-check-tuple 51 +USERENV: pic-hit 52 +USERENV: pic-miss-word 53 +USERENV: pic-miss-tail-word 54 ! Megamorphic dispatch USERENV: mega-lookup 57 @@ -218,13 +218,20 @@ USERENV: undefined-quot 60 : here-as ( tag -- pointer ) here bitor ; +: (align-here) ( alignment -- ) + [ here neg ] dip rem + [ bootstrap-cell /i [ 0 emit ] times ] unless-zero ; + : align-here ( -- ) - here 8 mod 4 = [ 0 emit ] when ; + data-alignment get (align-here) ; : emit-fixnum ( n -- ) tag-fixnum emit ; +: emit-header ( n -- ) tag-header emit ; + : emit-object ( class quot -- addr ) - over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ; + [ type-number ] dip over here-as + [ swap emit-header call align-here ] dip ; inline ! Write an object to the image. @@ -232,7 +239,7 @@ GENERIC: ' ( obj -- ptr ) ! Image header -: emit-header ( -- ) +: emit-image-header ( -- ) image-magic emit image-version emit data-base emit ! relocation base at end of header @@ -293,7 +300,7 @@ M: fake-bignum ' n>> tag-fixnum ; M: float ' [ float [ - align-here double>bits emit-64 + 8 (align-here) double>bits emit-64 ] emit-object ] cache-eql-object ; @@ -305,7 +312,7 @@ M: float ' M: f ' #! f is #define F RETAG(0,F_TYPE) - drop \ f tag-number ; + drop \ f type-number ; : 0, ( -- ) 0 >bignum ' 0-offset fixup ; : 1, ( -- ) 1 >bignum ' 1-offset fixup ; @@ -351,7 +358,7 @@ M: f ' [ ] [ "Not in image: " word-error ] ?if ; : fixup-words ( -- ) - image get [ dup word? [ fixup-word ] when ] change-each ; + image get [ dup word? [ fixup-word ] when ] map! drop ; M: word ' ; @@ -411,6 +418,7 @@ M: byte-array ' [ byte-array [ dup length emit-fixnum + bootstrap-cell 4 = [ 0 emit 0 emit ] when pad-bytes emit-bytes ] emit-object ] cache-eq-object ; @@ -515,7 +523,7 @@ M: quotation ' : build-image ( -- image ) 800000 image set 20000 objects set - emit-header t, 0, 1, -1, + emit-image-header t, 0, 1, -1, "Building generic words..." print flush remake-generics "Serializing words..." print flush diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index b8531abd90..b011b41c4b 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -78,8 +78,6 @@ SYMBOL: bootstrap-time "stage2: deployment mode" print ] [ "debugger" require - "inspector" require - "tools.errors" require "listener" require "none" require ] if diff --git a/basis/bootstrap/tools/tools.factor b/basis/bootstrap/tools/tools.factor index 6bdfd6241c..51f44025c9 100644 --- a/basis/bootstrap/tools/tools.factor +++ b/basis/bootstrap/tools/tools.factor @@ -2,14 +2,17 @@ USING: vocabs.loader sequences ; IN: bootstrap.tools { + "editors" "inspector" "bootstrap.image" + "see" "tools.annotations" "tools.crossref" "tools.errors" "tools.deploy" "tools.destructors" "tools.disassembler" + "tools.dispatch" "tools.memory" "tools.profiler" "tools.test" @@ -19,5 +22,4 @@ IN: bootstrap.tools "vocabs.hierarchy" "vocabs.refresh" "vocabs.refresh.monitor" - "editors" } [ require ] each diff --git a/basis/byte-arrays/hex/hex.factor b/basis/byte-arrays/hex/hex.factor index 5c381b7db0..ae9b9c8ba2 100644 --- a/basis/byte-arrays/hex/hex.factor +++ b/basis/byte-arrays/hex/hex.factor @@ -7,4 +7,4 @@ SYNTAX: HEX{ "}" parse-tokens "" join [ blank? not ] filter 2 group [ hex> ] B{ } map-as - parsed ; + suffix! ; diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 8cb1e751b2..b774e79b8b 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -32,7 +32,7 @@ HELP: month-names { $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ; HELP: month-name -{ $values { "n" integer } { "string" string } } +{ $values { "obj" { $or integer timestamp } } { "string" string } } { $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ; HELP: month-abbreviations @@ -46,11 +46,11 @@ HELP: month-abbreviation HELP: day-names -{ $values { "array" array } } +{ $values { "value" array } } { $description "Returns an array with the English names of the days of the week." } ; HELP: day-name -{ $values { "n" integer } { "string" string } } +{ $values { "obj" { $or integer timestamp } } { "string" string } } { $description "Looks up the day name and returns it as a string." } ; HELP: day-abbreviations2 diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor index 8d1071122d..44ba777c45 100644 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -170,3 +170,8 @@ IN: calendar.tests [ f ] [ now dup midnight eq? ] unit-test [ f ] [ now dup easter eq? ] unit-test [ f ] [ now dup beginning-of-year eq? ] unit-test + +[ t ] [ 1325376000 unix-time>timestamp 2012 = ] unit-test +[ t ] [ 1356998399 unix-time>timestamp 2013 1 seconds time- = ] unit-test + +[ t ] [ 1500000000 random [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index a8bb60cbf3..ef22a98c80 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -17,6 +17,8 @@ TUPLE: duration C: duration +: instant ( -- duration ) 0 0 0 0 0 0 ; + TUPLE: timestamp { year integer } { month integer } @@ -34,6 +36,15 @@ C: timestamp : ( year month day -- timestamp ) 0 0 0 gmt-offset-duration ; +: ( year month day -- timestamp ) + 0 0 0 instant ; + +: ( year -- timestamp ) + 1 1 ; + +: ( year -- timestamp ) + 1 1 ; + ERROR: not-a-month ; M: not-a-month summary drop "Months are indexed starting at 1" ; @@ -51,8 +62,16 @@ CONSTANT: month-names "July" "August" "September" "October" "November" "December" } -: month-name ( n -- string ) - check-month 1 - month-names nth ; + + +GENERIC: month-name ( obj -- string ) + +M: integer month-name check-month 1 - month-names nth ; +M: timestamp month-name month>> 1 - month-names nth ; CONSTANT: month-abbreviations { @@ -65,12 +84,8 @@ CONSTANT: month-abbreviations CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } -: day-names ( -- array ) - { - "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" - } ; - -: day-name ( n -- string ) day-names nth ; +CONSTANT: day-names + { "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" } CONSTANT: day-abbreviations2 { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } @@ -119,16 +134,16 @@ GENERIC: easter ( obj -- obj' ) :: easter-month-day ( year -- month day ) year 19 mod :> a - year 100 /mod :> c :> b - b 4 /mod :> e :> d + year 100 /mod :> ( b c ) + b 4 /mod :> ( d e ) b 8 + 25 /i :> f b f - 1 + 3 /i :> g 19 a * b + d - g - 15 + 30 mod :> h - c 4 /mod :> k :> i + c 4 /mod :> ( i k ) 32 2 e * + 2 i * + h - k - 7 mod :> l a 11 h * + 22 l * + 451 /i :> m - h l + 7 m * - 114 + 31 /mod 1 + :> day :> month + h l + 7 m * - 114 + 31 /mod 1 + :> ( month day ) month day ; M: integer easter ( year -- timestamp ) @@ -145,7 +160,6 @@ M: timestamp easter ( timestamp -- timestamp ) : >time< ( timestamp -- hour minute second ) [ hour>> ] [ minute>> ] [ second>> ] tri ; -: instant ( -- duration ) 0 0 0 0 0 0 ; : years ( x -- duration ) instant clone swap >>year ; : months ( x -- duration ) instant clone swap >>month ; : days ( x -- duration ) instant clone swap >>day ; @@ -157,6 +171,18 @@ M: timestamp easter ( timestamp -- timestamp ) : microseconds ( x -- duration ) 1000000 / seconds ; : nanoseconds ( x -- duration ) 1000000000 / seconds ; +GENERIC: year ( obj -- n ) +M: integer year ; +M: timestamp year year>> ; + +GENERIC: month ( obj -- n ) +M: integer month ; +M: timestamp month month>> ; + +GENERIC: day ( obj -- n ) +M: integer day ; +M: timestamp day day>> ; + GENERIC: leap-year? ( obj -- ? ) M: integer leap-year? ( year -- ? ) @@ -305,6 +331,9 @@ GENERIC: time- ( time1 time2 -- time3 ) M: timestamp <=> ( ts1 ts2 -- n ) [ >gmt tuple-slots ] compare ; +: same-day? ( ts1 ts2 -- ? ) + [ >gmt >date< ] bi@ = ; + : (time-) ( timestamp timestamp -- n ) [ >gmt ] bi@ [ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep @@ -387,6 +416,10 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ; : day-of-week ( timestamp -- n ) >date< zeller-congruence ; +GENERIC: day-name ( obj -- string ) +M: integer day-name day-names nth ; +M: timestamp day-name day-of-week day-names nth ; + :: (day-of-year) ( year month day -- n ) day-counts month head-slice sum day + year leap-year? [ @@ -398,22 +431,6 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ; : day-of-year ( timestamp -- n ) >date< (day-of-year) ; - - -: sunday ( timestamp -- new-timestamp ) 0 day-this-week ; -: monday ( timestamp -- new-timestamp ) 1 day-this-week ; -: tuesday ( timestamp -- new-timestamp ) 2 day-this-week ; -: wednesday ( timestamp -- new-timestamp ) 3 day-this-week ; -: thursday ( timestamp -- new-timestamp ) 4 day-this-week ; -: friday ( timestamp -- new-timestamp ) 5 day-this-week ; -: saturday ( timestamp -- new-timestamp ) 6 day-this-week ; - : midnight ( timestamp -- new-timestamp ) clone 0 >>hour 0 >>minute 0 >>second ; inline @@ -423,11 +440,108 @@ PRIVATE> : beginning-of-month ( timestamp -- new-timestamp ) midnight 1 >>day ; +: end-of-month ( timestamp -- new-timestamp ) + [ midnight ] [ days-in-month ] bi >>day ; + +> ] bi@ = [ 1 weeks time+ ] unless + n 1 - [ weeks time+ ] unless-zero ; + +: last-day-this-month ( timestamp day -- new-timestamp ) + [ 1 months time+ 1 ] dip nth-day-this-month 1 weeks time- ; + +PRIVATE> + +GENERIC: january ( obj -- timestamp ) +GENERIC: february ( obj -- timestamp ) +GENERIC: march ( obj -- timestamp ) +GENERIC: april ( obj -- timestamp ) +GENERIC: may ( obj -- timestamp ) +GENERIC: june ( obj -- timestamp ) +GENERIC: july ( obj -- timestamp ) +GENERIC: august ( obj -- timestamp ) +GENERIC: september ( obj -- timestamp ) +GENERIC: october ( obj -- timestamp ) +GENERIC: november ( obj -- timestamp ) +GENERIC: december ( obj -- timestamp ) + +M: integer january 1 1 ; +M: integer february 2 1 ; +M: integer march 3 1 ; +M: integer april 4 1 ; +M: integer may 5 1 ; +M: integer june 6 1 ; +M: integer july 7 1 ; +M: integer august 8 1 ; +M: integer september 9 1 ; +M: integer october 10 1 ; +M: integer november 11 1 ; +M: integer december 12 1 ; + +M: timestamp january clone 1 >>month ; +M: timestamp february clone 2 >>month ; +M: timestamp march clone 3 >>month ; +M: timestamp april clone 4 >>month ; +M: timestamp may clone 5 >>month ; +M: timestamp june clone 6 >>month ; +M: timestamp july clone 7 >>month ; +M: timestamp august clone 8 >>month ; +M: timestamp september clone 9 >>month ; +M: timestamp october clone 10 >>month ; +M: timestamp november clone 11 >>month ; +M: timestamp december clone 12 >>month ; + +: sunday ( timestamp -- new-timestamp ) 0 day-this-week ; +: monday ( timestamp -- new-timestamp ) 1 day-this-week ; +: tuesday ( timestamp -- new-timestamp ) 2 day-this-week ; +: wednesday ( timestamp -- new-timestamp ) 3 day-this-week ; +: thursday ( timestamp -- new-timestamp ) 4 day-this-week ; +: friday ( timestamp -- new-timestamp ) 5 day-this-week ; +: saturday ( timestamp -- new-timestamp ) 6 day-this-week ; + +: sunday? ( timestamp -- ? ) day-of-week 0 = ; +: monday? ( timestamp -- ? ) day-of-week 1 = ; +: tuesday? ( timestamp -- ? ) day-of-week 2 = ; +: wednesday? ( timestamp -- ? ) day-of-week 3 = ; +: thursday? ( timestamp -- ? ) day-of-week 4 = ; +: friday? ( timestamp -- ? ) day-of-week 5 = ; +: saturday? ( timestamp -- ? ) day-of-week 6 = ; + +: sunday-of-month ( timestamp n -- new-timestamp ) 0 nth-day-this-month ; +: monday-of-month ( timestamp n -- new-timestamp ) 1 nth-day-this-month ; +: tuesday-of-month ( timestamp n -- new-timestamp ) 2 nth-day-this-month ; +: wednesday-of-month ( timestamp n -- new-timestamp ) 3 nth-day-this-month ; +: thursday-of-month ( timestamp n -- new-timestamp ) 4 nth-day-this-month ; +: friday-of-month ( timestamp n -- new-timestamp ) 5 nth-day-this-month ; +: saturday-of-month ( timestamp n -- new-timestamp ) 6 nth-day-this-month ; + +: last-sunday-of-month ( timestamp -- new-timestamp ) 0 last-day-this-month ; +: last-monday-of-month ( timestamp -- new-timestamp ) 1 last-day-this-month ; +: last-tuesday-of-month ( timestamp -- new-timestamp ) 2 last-day-this-month ; +: last-wednesday-of-month ( timestamp -- new-timestamp ) 3 last-day-this-month ; +: last-thursday-of-month ( timestamp -- new-timestamp ) 4 last-day-this-month ; +: last-friday-of-month ( timestamp -- new-timestamp ) 5 last-day-this-month ; +: last-saturday-of-month ( timestamp -- new-timestamp ) 6 last-day-this-month ; + : beginning-of-week ( timestamp -- new-timestamp ) midnight sunday ; -: beginning-of-year ( timestamp -- new-timestamp ) - beginning-of-month 1 >>month ; +GENERIC: beginning-of-year ( object -- new-timestamp ) +M: timestamp beginning-of-year beginning-of-month 1 >>month ; +M: integer beginning-of-year ; + +GENERIC: end-of-year ( object -- new-timestamp ) +M: timestamp end-of-year 12 >>month 31 >>day ; +M: integer end-of-year 12 31 ; : time-since-midnight ( timestamp -- duration ) dup midnight time- ; @@ -435,6 +549,12 @@ PRIVATE> : since-1970 ( duration -- timestamp ) unix-1970 time+ >local-time ; +: timestamp>unix-time ( timestamp -- seconds ) + unix-1970 time- second>> ; + +: unix-time>timestamp ( seconds -- timestamp ) + seconds unix-1970 time+ ; + M: timestamp sleep-until timestamp>micros sleep-until ; M: duration sleep hence sleep-until ; diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index 28e54b89fb..ac72385d8c 100644 --- a/basis/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -14,6 +14,9 @@ IN: calendar.unix : timespec>seconds ( timespec -- seconds ) [ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ; +: timespec>nanoseconds ( timespec -- seconds ) + [ sec>> 1000000000 * ] [ nsec>> ] bi + ; + : timespec>unix-time ( timespec -- timestamp ) timespec>seconds since-1970 ; diff --git a/basis/channels/examples/examples.factor b/basis/channels/examples/examples.factor index 99fa41cd40..4b48d7923c 100644 --- a/basis/channels/examples/examples.factor +++ b/basis/channels/examples/examples.factor @@ -25,12 +25,11 @@ IN: channels.examples ] 3keep filter ; :: (sieve) ( prime c -- ) - [let | p [ c from ] - newc [ ] | - p prime to - [ newc p c filter ] "Filter" spawn drop - prime newc (sieve) - ] ; + c from :> p + :> newc + p prime to + [ newc p c filter ] "Filter" spawn drop + prime newc (sieve) ; : sieve ( prime -- ) #! Send prime numbers to 'prime' channel diff --git a/basis/channels/remote/remote-docs.factor b/basis/channels/remote/remote-docs.factor index 309f764d2d..c612b4256a 100644 --- a/basis/channels/remote/remote-docs.factor +++ b/basis/channels/remote/remote-docs.factor @@ -53,11 +53,11 @@ $nl " to be accessed remotely. " { $link publish } " returns an id which a remote node " "needs to know to access the channel." $nl -{ $snippet "channel [ from . ] spawn drop dup publish" } +{ $snippet " dup [ from . flush ] curry \"test\" spawn drop publish" } $nl -"Given the id from the snippet above, a remote node can put items in the channel." +"Given the id from the snippet above, a remote node can put items in the channel (where 123456 is the id):" $nl -{ $snippet "\"myhost.com\" 9001 \"ID123456\" \n\"hello\" over to" } +{ $snippet "\"myhost.com\" 9001 123456 \n\"hello\" over to" } ; ABOUT: { "remote-channels" "remote-channels" } diff --git a/basis/channels/remote/remote.factor b/basis/channels/remote/remote.factor index bf2438ac19..4eab29fd81 100644 --- a/basis/channels/remote/remote.factor +++ b/basis/channels/remote/remote.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Remote Channels -USING: kernel init namespaces make assocs arrays random +USING: kernel init namespaces assocs arrays random sequences channels match concurrency.messaging concurrency.distributed threads accessors ; IN: channels.remote @@ -27,39 +27,44 @@ PRIVATE> MATCH-VARS: ?from ?tag ?id ?value ; SYMBOL: no-channel +TUPLE: to-message id value ; +TUPLE: from-message id ; -: channel-process ( -- ) +: channel-thread ( -- ) [ { - { { to ?id ?value } + { T{ to-message f ?id ?value } [ ?value ?id get-channel dup [ to f ] [ 2drop no-channel ] if ] } - { { from ?id } + { T{ from-message f ?id } [ ?id get-channel [ from ] [ no-channel ] if* ] } } match-cond ] handle-synchronous ; -PRIVATE> - : start-channel-node ( -- ) - "remote-channels" get-process [ - "remote-channels" - [ channel-process t ] "Remote channels" spawn-server - register-process + "remote-channels" get-remote-thread [ + [ channel-thread t ] "Remote channels" spawn-server + "remote-channels" register-remote-thread ] unless ; +PRIVATE> + TUPLE: remote-channel node id ; C: remote-channel +> "remote-channels" + send-synchronous dup no-channel = [ no-channel throw ] when* ; + +PRIVATE> + M: remote-channel to ( value remote-channel -- ) - [ [ \ to , id>> , , ] { } make ] keep - node>> "remote-channels" - send-synchronous no-channel = [ no-channel throw ] when ; + [ id>> swap to-message boa ] keep send-message drop ; M: remote-channel from ( remote-channel -- value ) - [ [ \ from , id>> , ] { } make ] keep - node>> "remote-channels" - send-synchronous dup no-channel = [ no-channel throw ] when* ; + [ id>> from-message boa ] keep send-message ; [ H{ } clone \ remote-channels set-global diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor index 9ec78248a1..cb536cd75e 100755 --- a/basis/checksums/hmac/hmac.factor +++ b/basis/checksums/hmac/hmac.factor @@ -24,7 +24,7 @@ PRIVATE> :: hmac-stream ( stream key checksum -- value ) checksum initialize-checksum-state :> checksum-state - checksum key checksum-state init-key :> Ki :> Ko + checksum key checksum-state init-key :> ( Ko Ki ) checksum-state Ki add-checksum-bytes stream add-checksum-stream get-checksum checksum initialize-checksum-state diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index b3be4651cd..1c0efb1c36 100644 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -21,7 +21,7 @@ M: circular length seq>> length ; M: circular virtual@ circular-wrap seq>> ; -M: circular virtual-seq seq>> ; +M: circular virtual-exemplar seq>> ; : change-circular-start ( n circular -- ) #! change start to (start + n) mod length diff --git a/basis/classes/struct/bit-accessors/bit-accessors.factor b/basis/classes/struct/bit-accessors/bit-accessors.factor index c535e52c0a..c5959ab7ac 100644 --- a/basis/classes/struct/bit-accessors/bit-accessors.factor +++ b/basis/classes/struct/bit-accessors/bit-accessors.factor @@ -10,7 +10,7 @@ IN: classes.struct.bit-accessors [ 2^ 1 - ] bi@ swap bitnot bitand ; :: manipulate-bits ( offset bits step-quot -- quot shift-amount offset' bits' ) - offset 8 /mod :> start-bit :> i + offset 8 /mod :> ( i start-bit ) start-bit bits + 8 min :> end-bit start-bit end-bit ones-between :> mask end-bit start-bit - :> used-bits diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 58ab2df80b..2c0db93522 100755 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -365,3 +365,18 @@ STRUCT: bit-field-test [ -2 ] [ bit-field-test 2 >>b b>> ] unit-test [ 1 ] [ bit-field-test 257 >>c c>> ] unit-test [ 3 ] [ bit-field-test heap-size ] unit-test + +cpu ppc? [ + STRUCT: ppc-align-test-1 + { x longlong } + { y int } ; + + [ 16 ] [ ppc-align-test-1 heap-size ] unit-test + + STRUCT: ppc-align-test-2 + { y int } + { x longlong } ; + + [ 12 ] [ ppc-align-test-2 heap-size ] unit-test + [ 4 ] [ "x" ppc-align-test-2 offset-of ] unit-test +] when diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index af23834383..c7dd3fb505 100755 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -211,27 +211,32 @@ M: struct-c-type c-struct? drop t ; slots >>fields size >>size align >>align + align >>align-first class (unboxer-quot) >>unboxer-quot - class (boxer-quot) >>boxer-quot ; - -GENERIC: align-offset ( offset class -- offset' ) + class (boxer-quot) >>boxer-quot ; -M: struct-slot-spec align-offset - [ type>> c-type-align 8 * align ] keep +GENERIC: compute-slot-offset ( offset class -- offset' ) + +: c-type-align-at ( class offset -- n ) + 0 = [ c-type-align-first ] [ c-type-align ] if ; + +M: struct-slot-spec compute-slot-offset + [ type>> over c-type-align-at 8 * align ] keep [ [ 8 /i ] dip (>>offset) ] [ type>> heap-size 8 * + ] 2bi ; -M: struct-bit-slot-spec align-offset +M: struct-bit-slot-spec compute-slot-offset [ (>>offset) ] [ bits>> + ] 2bi ; -: struct-offsets ( slots -- size ) - 0 [ align-offset ] reduce 8 align 8 /i ; +: compute-struct-offsets ( slots -- size ) + 0 [ compute-slot-offset ] reduce 8 align 8 /i ; -: union-struct-offsets ( slots -- size ) +: compute-union-offsets ( slots -- size ) 1 [ 0 >>offset type>> heap-size max ] reduce ; -: struct-align ( slots -- align ) +: struct-alignment ( slots -- align ) [ struct-bit-slot-spec? not ] filter - 1 [ type>> c-type-align max ] reduce ; + 1 [ [ type>> ] [ offset>> ] bi c-type-align-at max ] reduce ; + PRIVATE> M: struct byte-length class "struct-size" word-prop ; foldable @@ -243,10 +248,8 @@ GENERIC: binary-zero? ( value -- ? ) M: object binary-zero? drop f ; M: f binary-zero? drop t ; -M: number binary-zero? zero? ; -M: struct binary-zero? - [ byte-length iota ] [ >c-ptr ] bi - [ *uchar zero? ] curry all? ; +M: number binary-zero? 0 = ; +M: struct binary-zero? >c-ptr [ 0 = ] all? ; : struct-needs-prototype? ( class -- ? ) struct-slots [ initial>> binary-zero? ] all? not ; @@ -278,7 +281,7 @@ M: struct binary-zero? slots empty? [ struct-must-have-slots ] when class redefine-struct-tuple-class slots make-slots dup check-struct-slots :> slot-specs - slot-specs struct-align :> alignment + slot-specs struct-alignment :> alignment slot-specs offsets-quot call alignment align :> size class slot-specs size alignment c-type-for-class :> c-type @@ -291,10 +294,10 @@ M: struct binary-zero? PRIVATE> : define-struct-class ( class slots -- ) - [ struct-offsets ] (define-struct-class) ; + [ compute-struct-offsets ] (define-struct-class) ; : define-union-struct-class ( class slots -- ) - [ union-struct-offsets ] (define-struct-class) ; + [ compute-union-offsets ] (define-struct-class) ; M: struct-class reset-class [ call-next-method ] [ name>> c-types get delete-at ] bi ; @@ -350,7 +353,7 @@ PRIVATE> : parse-struct-slots ( slots -- slots' more? ) scan { { ";" [ f ] } - { "{" [ parse-struct-slot over push t ] } + { "{" [ parse-struct-slot suffix! t ] } { f [ unexpected-eof ] } [ invalid-struct-slot ] } case ; @@ -365,10 +368,10 @@ SYNTAX: UNION-STRUCT: parse-struct-definition define-union-struct-class ; SYNTAX: S{ - scan-word dup struct-slots parse-tuple-literal-slots parsed ; + scan-word dup struct-slots parse-tuple-literal-slots suffix! ; SYNTAX: S@ - scan-word scan-object swap memory>struct parsed ; + scan-word scan-object swap memory>struct suffix! ; ! functor support @@ -378,7 +381,7 @@ SYNTAX: S@ : parse-struct-slot` ( accum -- accum ) scan-string-param scan-c-type` \ } parse-until - [ over push ] 3curry over push-all ; + [ suffix! ] 3curry append! ; : parse-struct-slots` ( accum -- accum more? ) scan { @@ -389,10 +392,10 @@ SYNTAX: S@ PRIVATE> FUNCTOR-SYNTAX: STRUCT: - scan-param parsed - [ 8 ] over push-all + scan-param suffix! + [ 8 ] append! [ parse-struct-slots` ] [ ] while - [ >array define-struct-class ] over push-all ; + [ >array define-struct-class ] append! ; USING: vocabs vocabs.loader ; diff --git a/basis/cocoa/callbacks/callbacks.factor b/basis/cocoa/callbacks/callbacks.factor index a798eb15ba..e1ec43f1dc 100644 --- a/basis/cocoa/callbacks/callbacks.factor +++ b/basis/cocoa/callbacks/callbacks.factor @@ -16,11 +16,11 @@ CLASS: { { +superclass+ "NSObject" } } -{ "perform:" "void" { "id" "SEL" "id" } +{ "perform:" void { id SEL id } [ 2drop callbacks get at try ] } -{ "dealloc" "void" { "id" "SEL" } +{ "dealloc" void { id SEL } [ drop dup callbacks get delete-at diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor index c657a5e6e8..892d5ea38d 100644 --- a/basis/cocoa/cocoa-tests.factor +++ b/basis/cocoa/cocoa-tests.factor @@ -1,6 +1,7 @@ USING: cocoa cocoa.messages cocoa.subclassing cocoa.types -compiler kernel namespaces cocoa.classes tools.test memory -compiler.units math core-graphics.types ; +compiler kernel namespaces cocoa.classes cocoa.runtime +tools.test memory compiler.units math core-graphics.types ; +FROM: alien.c-types => int void ; IN: cocoa.tests CLASS: { @@ -8,8 +9,8 @@ CLASS: { { +name+ "Foo" } } { "foo:" - "void" - { "id" "SEL" "NSRect" } + void + { id SEL NSRect } [ gc "x" set 2drop ] } ; @@ -30,8 +31,8 @@ CLASS: { { +name+ "Bar" } } { "bar" - "NSRect" - { "id" "SEL" } + NSRect + { id SEL } [ 2drop test-foo "x" get ] } ; @@ -52,13 +53,13 @@ CLASS: { { +name+ "Bar" } } { "bar" - "NSRect" - { "id" "SEL" } + NSRect + { id SEL } [ 2drop test-foo "x" get ] } { "babb" - "int" - { "id" "SEL" "int" } + int + { id SEL int } [ 2nip sq ] } ; diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index 7f9d3f6814..34bac0a505 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -14,14 +14,14 @@ SYMBOL: sent-messages : remember-send ( selector -- ) sent-messages (remember-send) ; -SYNTAX: -> scan dup remember-send parsed \ send parsed ; +SYNTAX: -> scan dup remember-send suffix! \ send suffix! ; SYMBOL: super-sent-messages : remember-super-send ( selector -- ) super-sent-messages (remember-send) ; -SYNTAX: SUPER-> scan dup remember-super-send parsed \ super-send parsed ; +SYNTAX: SUPER-> scan dup remember-super-send suffix! \ super-send suffix! ; SYMBOL: frameworks diff --git a/basis/cocoa/messages/messages-docs.factor b/basis/cocoa/messages/messages-docs.factor index 400599383f..7dee15d2e2 100644 --- a/basis/cocoa/messages/messages-docs.factor +++ b/basis/cocoa/messages/messages-docs.factor @@ -2,13 +2,13 @@ USING: help.markup help.syntax strings alien ; IN: cocoa.messages HELP: send -{ $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } } +{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } } { $description "Sends an Objective C message named by " { $snippet "selector" } " to " { $snippet "receiver" } ". The arguments must be on the stack in left-to-right order." } { $errors "Throws an error if the receiver does not recognize the message, or if the arguments have inappropriate types." } { $notes "This word uses a special fast code path if " { $snippet "selector" } " is a literal and the word containing the call to " { $link send } " is compiled." } ; HELP: super-send -{ $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } } +{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } } { $description "Sends an Objective C message named by " { $snippet "selector" } " to the super class of " { $snippet "receiver" } ". Otherwise behaves identically to " { $link send } "." } ; HELP: objc-class diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 85cff72749..4cc9554d3c 100755 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -2,10 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.strings arrays assocs classes.struct continuations combinators compiler compiler.alien -stack-checker kernel math namespaces make quotations sequences -strings words cocoa.runtime io macros memoize io.encodings.utf8 -effects libc libc.private lexer init core-foundation fry -generalizations specialized-arrays ; +core-graphics.types stack-checker kernel math namespaces make +quotations sequences strings words cocoa.runtime cocoa.types io +macros memoize io.encodings.utf8 effects layouts libc +libc.private lexer init core-foundation fry generalizations +specialized-arrays ; +QUALIFIED-WITH: alien.c-types c IN: cocoa.messages SPECIALIZED-ARRAY: void* @@ -98,75 +100,84 @@ class-startup-hooks [ H{ } clone ] initialize SYMBOL: objc>alien-types H{ - { "c" "char" } - { "i" "int" } - { "s" "short" } - { "C" "uchar" } - { "I" "uint" } - { "S" "ushort" } - { "f" "float" } - { "d" "double" } - { "B" "bool" } - { "v" "void" } - { "*" "char*" } - { "?" "unknown_type" } - { "@" "id" } - { "#" "Class" } - { ":" "SEL" } + { "c" c:char } + { "i" c:int } + { "s" c:short } + { "C" c:uchar } + { "I" c:uint } + { "S" c:ushort } + { "f" c:float } + { "d" c:double } + { "B" c:bool } + { "v" c:void } + { "*" c:char* } + { "?" unknown_type } + { "@" id } + { "#" Class } + { ":" SEL } } -"ptrdiff_t" heap-size { +cell { { 4 [ H{ - { "l" "long" } - { "q" "longlong" } - { "L" "ulong" } - { "Q" "ulonglong" } + { "l" c:long } + { "q" c:longlong } + { "L" c:ulong } + { "Q" c:ulonglong } } ] } { 8 [ H{ - { "l" "long32" } - { "q" "long" } - { "L" "ulong32" } - { "Q" "ulong" } + { "l" long32 } + { "q" long } + { "L" ulong32 } + { "Q" ulong } } ] } } case assoc-union objc>alien-types set-global +SYMBOL: objc>struct-types + +H{ + { "_NSPoint" NSPoint } + { "NSPoint" NSPoint } + { "CGPoint" NSPoint } + { "_NSRect" NSRect } + { "NSRect" NSRect } + { "CGRect" NSRect } + { "_NSSize" NSSize } + { "NSSize" NSSize } + { "CGSize" NSSize } + { "_NSRange" NSRange } + { "NSRange" NSRange } +} objc>struct-types set-global + ! The transpose of the above map SYMBOL: alien>objc-types objc>alien-types get [ swap ] assoc-map ! A hack... -"ptrdiff_t" heap-size { +cell { { 4 [ H{ - { "NSPoint" "{_NSPoint=ff}" } - { "NSRect" "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" } - { "NSSize" "{_NSSize=ff}" } - { "NSRange" "{_NSRange=II}" } - { "NSInteger" "i" } - { "NSUInteger" "I" } - { "CGFloat" "f" } + { NSPoint "{_NSPoint=ff}" } + { NSRect "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" } + { NSSize "{_NSSize=ff}" } + { NSRange "{_NSRange=II}" } + { NSInteger "i" } + { NSUInteger "I" } + { CGFloat "f" } } ] } { 8 [ H{ - { "NSPoint" "{CGPoint=dd}" } - { "NSRect" "{CGRect={CGPoint=dd}{CGSize=dd}}" } - { "NSSize" "{CGSize=dd}" } - { "NSRange" "{_NSRange=QQ}" } - { "NSInteger" "q" } - { "NSUInteger" "Q" } - { "CGFloat" "d" } + { NSPoint "{CGPoint=dd}" } + { NSRect "{CGRect={CGPoint=dd}{CGSize=dd}}" } + { NSSize "{CGSize=dd}" } + { NSRange "{_NSRange=QQ}" } + { NSInteger "q" } + { NSUInteger "Q" } + { CGFloat "d" } } ] } } case assoc-union alien>objc-types set-global -: internal-cocoa-type? ( c-type -- ? ) - [ "?" = ] [ first CHAR: _ = ] bi or ; - -: warn-c-type ( c-type -- ) - dup internal-cocoa-type? - [ drop ] [ "Warning: no such C type: " write print ] if ; - : objc-struct-type ( i string -- ctype ) [ CHAR: = ] 2keep index-from swap subseq - dup c-types get key? [ warn-c-type "void*" ] unless ; + objc>struct-types get at* [ drop void* ] unless ; ERROR: no-objc-type name ; @@ -177,9 +188,9 @@ ERROR: no-objc-type name ; : (parse-objc-type) ( i string -- ctype ) [ [ 1 + ] dip ] [ nth ] 2bi { { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] } - { [ dup CHAR: ^ = ] [ 3drop "void*" ] } + { [ dup CHAR: ^ = ] [ 3drop void* ] } { [ dup CHAR: { = ] [ drop objc-struct-type ] } - { [ dup CHAR: [ = ] [ 3drop "void*" ] } + { [ dup CHAR: [ = ] [ 3drop void* ] } [ 2nip decode-type ] } cond ; diff --git a/basis/cocoa/subclassing/subclassing-docs.factor b/basis/cocoa/subclassing/subclassing-docs.factor index 181912b0f0..0944727e46 100644 --- a/basis/cocoa/subclassing/subclassing-docs.factor +++ b/basis/cocoa/subclassing/subclassing-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax strings alien hashtables ; IN: cocoa.subclassing HELP: define-objc-class -{ $values { "hash" hashtable } { "imeth" "a sequence of instance method definitions" } } +{ $values { "imeth" "a sequence of instance method definitions" } { "hash" hashtable } } { $description "Defines a new Objective C class. The hashtable can contain the following keys:" { $list { { $link +name+ } " - a string naming the new class. Required." } diff --git a/basis/colors/constants/constants.factor b/basis/colors/constants/constants.factor index 8598fc0663..c17d1069b2 100644 --- a/basis/colors/constants/constants.factor +++ b/basis/colors/constants/constants.factor @@ -30,4 +30,4 @@ ERROR: no-such-color name ; : named-color ( name -- color ) dup colors at [ ] [ no-such-color ] ?if ; -SYNTAX: COLOR: scan named-color parsed ; \ No newline at end of file +SYNTAX: COLOR: scan named-color suffix! ; diff --git a/basis/columns/columns-tests.factor b/basis/columns/columns-tests.factor index a53f5c1185..434c233936 100644 --- a/basis/columns/columns-tests.factor +++ b/basis/columns/columns-tests.factor @@ -5,5 +5,5 @@ IN: columns.tests { { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set [ { 1 4 7 } ] [ "seq" get 0 >array ] unit-test -[ ] [ "seq" get 1 [ sq ] change-each ] unit-test +[ ] [ "seq" get 1 [ sq ] map! drop ] unit-test [ { 4 25 64 } ] [ "seq" get 1 >array ] unit-test diff --git a/basis/columns/columns.factor b/basis/columns/columns.factor index 8f45dab872..8674217655 100644 --- a/basis/columns/columns.factor +++ b/basis/columns/columns.factor @@ -8,7 +8,7 @@ TUPLE: column seq col ; C: column -M: column virtual-seq seq>> ; +M: column virtual-exemplar seq>> ; M: column virtual@ [ col>> swap ] [ seq>> ] bi nth bounds-check ; M: column length seq>> length ; diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 399b4dc36f..bd224919f9 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -47,3 +47,9 @@ IN: combinators.smart.tests [ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test [ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test + +{ 2 3 } [ [ + ] preserving ] must-infer-as + +{ 2 0 } [ [ + ] nullary ] must-infer-as + +{ 2 2 } [ [ [ + ] nullary ] preserving ] must-infer-as diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index a00967742f..91987e0dfa 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -46,5 +46,8 @@ MACRO: append-outputs ( quot -- seq ) MACRO: preserving ( quot -- ) [ infer in>> length ] keep '[ _ ndup @ ] ; +MACRO: nullary ( quot -- quot' ) + dup infer out>> length '[ @ _ ndrop ] ; + MACRO: smart-if ( pred true false -- ) '[ _ preserving _ _ if ] ; inline diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 2303b98aed..9fffa0eed2 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -284,7 +284,7 @@ M: ##copy analyze-aliases* M: ##compare analyze-aliases* call-next-method dup useless-compare? [ - dst>> \ f tag-number \ ##load-immediate new-insn + dst>> \ f type-number \ ##load-immediate new-insn analyze-aliases* ] when ; diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index d303cc597f..7f1b6aa6f2 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -6,6 +6,7 @@ compiler.cfg arrays locals byte-arrays kernel.private math slots.private vectors sbufs strings math.partial-dispatch hashtables assocs combinators.short-circuit strings.private accessors compiler.cfg.instructions ; +FROM: alien.c-types => int ; IN: compiler.cfg.builder.tests ! Just ensure that various CFGs build correctly. @@ -66,9 +67,9 @@ IN: compiler.cfg.builder.tests [ [ t ] loop ] [ [ dup ] loop ] [ [ 2 ] [ 3 throw ] if 4 ] - [ "int" f "malloc" { "int" } alien-invoke ] - [ "int" { "int" } "cdecl" alien-indirect ] - [ "int" { "int" } "cdecl" [ ] alien-callback ] + [ int f "malloc" { int } alien-invoke ] + [ int { int } "cdecl" alien-indirect ] + [ int { int } "cdecl" [ ] alien-callback ] [ swap - + * ] [ swap slot ] [ blahblah ] @@ -118,7 +119,6 @@ IN: compiler.cfg.builder.tests { byte-array - simple-alien alien POSTPONE: f } [| class | @@ -161,7 +161,7 @@ IN: compiler.cfg.builder.tests : count-insns ( quot insn-check -- ? ) [ test-mr [ instructions>> ] map ] dip - '[ _ count ] sigma ; inline + '[ _ count ] map-sum ; inline : contains-insn? ( quot insn-check -- ? ) count-insns 0 > ; inline @@ -191,7 +191,7 @@ IN: compiler.cfg.builder.tests ] unit-test [ f t ] [ - [ { fixnum simple-alien } declare 0 alien-cell ] + [ { fixnum alien } declare 0 alien-cell ] [ [ ##unbox-any-c-ptr? ] contains-insn? ] [ [ ##unbox-alien? ] contains-insn? ] bi ] unit-test @@ -204,7 +204,7 @@ IN: compiler.cfg.builder.tests ] unit-test [ f t ] [ - [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ] + [ { byte-array fixnum } declare alien-cell { alien } declare 4 alien-float ] [ [ ##box-alien? ] contains-insn? ] [ [ ##allot? ] contains-insn? ] bi ] unit-test @@ -213,4 +213,4 @@ IN: compiler.cfg.builder.tests ] when ! Regression. Make sure everything is inlined correctly -[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test \ No newline at end of file +[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 11aae28bf3..cf6215c5cd 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -117,7 +117,7 @@ M: #recursive emit-node and ; : emit-trivial-if ( -- ) - ds-pop \ f tag-number cc/= ^^compare-imm ds-push ; + ds-pop \ f type-number cc/= ^^compare-imm ds-push ; : trivial-not-if? ( #if -- ? ) children>> first2 @@ -126,12 +126,12 @@ M: #recursive emit-node and ; : emit-trivial-not-if ( -- ) - ds-pop \ f tag-number cc= ^^compare-imm ds-push ; + ds-pop \ f type-number cc= ^^compare-imm ds-push ; : emit-actual-if ( #if -- ) ! Inputs to the final instruction need to be copied because of ! loc>vreg sync - ds-pop any-rep ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ; + ds-pop any-rep ^^copy \ f type-number cc/= ##compare-imm-branch emit-if ; M: #if emit-node { diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor index 369e6ebc32..035cc63b1e 100644 --- a/basis/compiler/cfg/cfg.factor +++ b/basis/compiler/cfg/cfg.factor @@ -4,20 +4,20 @@ USING: kernel math vectors arrays accessors namespaces ; IN: compiler.cfg TUPLE: basic-block < identity-tuple -{ id integer } +id number { instructions vector } { successors vector } { predecessors vector } ; -M: basic-block hashcode* nip id>> ; - : ( -- bb ) basic-block new + \ basic-block counter >>id V{ } clone >>instructions V{ } clone >>successors - V{ } clone >>predecessors - \ basic-block counter >>id ; + V{ } clone >>predecessors ; + +M: basic-block hashcode* nip id>> ; TUPLE: cfg { entry basic-block } word label spill-area-size reps diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 510d7c45cb..051b0e3e1f 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -49,7 +49,7 @@ ERROR: bad-kill-insn bb ; ERROR: bad-successors ; : check-successors ( bb -- ) - dup successors>> [ predecessors>> memq? ] with all? + dup successors>> [ predecessors>> member-eq? ] with all? [ bad-successors ] unless ; : check-basic-block ( bb -- ) diff --git a/basis/compiler/cfg/comparisons/comparisons.factor b/basis/compiler/cfg/comparisons/comparisons.factor index 0b4a6f2f02..35f25c2d40 100644 --- a/basis/compiler/cfg/comparisons/comparisons.factor +++ b/basis/compiler/cfg/comparisons/comparisons.factor @@ -90,5 +90,5 @@ SYMBOLS: { cc/> { +lt+ +eq+ +unordered+ } } { cc/<> { +eq+ +unordered+ } } { cc/<>= { +unordered+ } } - } at memq? ; + } at member-eq? ; diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor index 6919ba8b9b..23382c3dbe 100644 --- a/basis/compiler/cfg/copy-prop/copy-prop.factor +++ b/basis/compiler/cfg/copy-prop/copy-prop.factor @@ -63,7 +63,7 @@ M: insn update-insn rename-insn-uses t ; copies get dup assoc-empty? [ 2drop ] [ renamings set [ - instructions>> [ update-insn ] filter-here + instructions>> [ update-insn ] filter! drop ] each-basic-block ] if ; diff --git a/basis/compiler/cfg/dce/dce.factor b/basis/compiler/cfg/dce/dce.factor index b8735e224c..03a43d0ab7 100644 --- a/basis/compiler/cfg/dce/dce.factor +++ b/basis/compiler/cfg/dce/dce.factor @@ -117,5 +117,5 @@ M: insn live-insn? defs-vreg [ live-vreg? ] [ t ] if* ; dup [ [ instructions>> [ build-liveness-graph ] each ] each-basic-block ] [ [ instructions>> [ compute-live-vregs ] each ] each-basic-block ] - [ [ instructions>> [ live-insn? ] filter-here ] each-basic-block ] + [ [ instructions>> [ live-insn? ] filter! drop ] each-basic-block ] tri ; diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 825ff71b9b..54cff2ccaa 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -11,6 +11,10 @@ GENERIC: defs-vreg ( insn -- vreg/f ) GENERIC: temp-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq ) +M: insn defs-vreg drop f ; +M: insn temp-vregs drop { } ; +M: insn uses-vregs drop { } ; + M: ##phi uses-vregs inputs>> values ; > values ; } case ; : define-defs-vreg-method ( insn -- ) - [ \ defs-vreg create-method ] - [ insn-def-slot [ name>> reader-word 1quotation ] [ [ drop f ] ] if* ] bi - define ; + dup insn-def-slot dup [ + [ \ defs-vreg create-method ] + [ name>> reader-word 1quotation ] bi* + define + ] [ 2drop ] if ; : define-uses-vregs-method ( insn -- ) - [ \ uses-vregs create-method ] - [ insn-use-slots [ name>> ] map slot-array-quot ] bi - define ; + dup insn-use-slots [ drop ] [ + [ \ uses-vregs create-method ] + [ [ name>> ] map slot-array-quot ] bi* + define + ] if-empty ; : define-temp-vregs-method ( insn -- ) - [ \ temp-vregs create-method ] - [ insn-temp-slots [ name>> ] map slot-array-quot ] bi - define ; + dup insn-temp-slots [ drop ] [ + [ \ temp-vregs create-method ] + [ [ name>> ] map slot-array-quot ] bi* + define + ] if-empty ; PRIVATE> diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor index 5d3c79e40f..6d192ec54a 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences assocs fry -cpu.architecture layouts +USING: accessors kernel sequences assocs fry math +cpu.architecture layouts namespaces compiler.cfg.rpo compiler.cfg.registers compiler.cfg.instructions @@ -21,12 +21,14 @@ GENERIC: allocation-size* ( insn -- n ) M: ##allot allocation-size* size>> ; -M: ##box-alien allocation-size* drop 4 cells ; +M: ##box-alien allocation-size* drop 5 cells ; -M: ##box-displaced-alien allocation-size* drop 4 cells ; +M: ##box-displaced-alien allocation-size* drop 5 cells ; : allocation-size ( bb -- n ) - instructions>> [ ##allocation? ] filter [ allocation-size* ] sigma ; + instructions>> + [ ##allocation? ] filter + [ allocation-size* data-alignment get align ] map-sum ; : insert-gc-check ( bb -- ) dup dup '[ @@ -44,4 +46,4 @@ M: ##box-displaced-alien allocation-size* drop 4 cells ; dup blocks-with-gc [ over compute-uninitialized-sets [ insert-gc-check ] each - ] unless-empty ; \ No newline at end of file + ] unless-empty ; diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 42aa5512bc..9d1945c525 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -26,7 +26,7 @@ IN: compiler.cfg.hats : hat-effect ( insn -- effect ) "insn-slots" word-prop - [ type>> { def temp } memq? not ] filter [ name>> ] map + [ type>> { def temp } member-eq? not ] filter [ name>> ] map { "vreg" } ; : define-hat ( insn -- ) @@ -43,14 +43,14 @@ insn-classes get [ : ^^load-literal ( obj -- dst ) [ next-vreg dup ] dip { - { [ dup not ] [ drop \ f tag-number ##load-immediate ] } + { [ dup not ] [ drop \ f type-number ##load-immediate ] } { [ dup fixnum? ] [ tag-fixnum ##load-immediate ] } { [ dup float? ] [ ##load-constant ] } [ ##load-reference ] } cond ; : ^^offset>slot ( slot -- vreg' ) - cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; + cell 4 = 2 1 ? ^^shr-imm ; : ^^tag-fixnum ( src -- dst ) tag-bits get ^^shl-imm ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index bffa0e59d0..91ac923273 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -417,12 +417,12 @@ def: dst/scalar-rep use: src literal: rep ; -PURE-INSN: ##horizontal-shl-vector +PURE-INSN: ##horizontal-shl-vector-imm def: dst use: src1 literal: src2 rep ; -PURE-INSN: ##horizontal-shr-vector +PURE-INSN: ##horizontal-shr-vector-imm def: dst use: src1 literal: src2 rep ; @@ -462,6 +462,16 @@ def: dst use: src literal: rep ; +PURE-INSN: ##shl-vector-imm +def: dst +use: src1 +literal: src2 rep ; + +PURE-INSN: ##shr-vector-imm +def: dst +use: src1 +literal: src2 rep ; + PURE-INSN: ##shl-vector def: dst use: src1 src2/int-scalar-rep @@ -502,13 +512,12 @@ temp: temp/int-rep ; PURE-INSN: ##box-displaced-alien def: dst/int-rep use: displacement/int-rep base/int-rep -temp: temp1/int-rep temp2/int-rep +temp: temp/int-rep literal: base-class ; PURE-INSN: ##unbox-any-c-ptr def: dst/int-rep -use: src/int-rep -temp: temp/int-rep ; +use: src/int-rep ; : ##unbox-f ( dst src -- ) drop 0 ##load-immediate ; : ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ; @@ -517,12 +526,12 @@ PURE-INSN: ##unbox-alien def: dst/int-rep use: src/int-rep ; -: ##unbox-c-ptr ( dst src class temp -- ) +: ##unbox-c-ptr ( dst src class -- ) { - { [ over \ f class<= ] [ 2drop ##unbox-f ] } - { [ over simple-alien class<= ] [ 2drop ##unbox-alien ] } - { [ over byte-array class<= ] [ 2drop ##unbox-byte-array ] } - [ nip ##unbox-any-c-ptr ] + { [ dup \ f class<= ] [ drop ##unbox-f ] } + { [ dup alien class<= ] [ drop ##unbox-alien ] } + { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] } + [ drop ##unbox-any-c-ptr ] } cond ; ! Alien accessors @@ -833,7 +842,7 @@ SYMBOL: vreg-insn [ vreg-insn insn-classes get [ - "insn-slots" word-prop [ type>> { def use temp } memq? ] any? + "insn-slots" word-prop [ type>> { def use temp } member-eq? ] any? ] filter define-union-class ] with-compilation-unit diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor index a37e100c3e..320a0a08f7 100644 --- a/basis/compiler/cfg/intrinsics/alien/alien.factor +++ b/basis/compiler/cfg/intrinsics/alien/alien.factor @@ -22,12 +22,10 @@ IN: compiler.cfg.intrinsics.alien ] [ emit-primitive ] if ; :: inline-alien ( node quot test -- ) - [let | infos [ node node-input-infos ] | - infos test call - [ infos quot call ] - [ node emit-primitive ] - if - ] ; inline + node node-input-infos :> infos + infos test call + [ infos quot call ] + [ node emit-primitive ] if ; inline : inline-alien-getter? ( infos -- ? ) [ first class>> c-ptr class<= ] @@ -35,7 +33,7 @@ IN: compiler.cfg.intrinsics.alien bi and ; : ^^unbox-c-ptr ( src class -- dst ) - [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ; + [ next-vreg dup ] 2dip ##unbox-c-ptr ; : prepare-alien-accessor ( info -- ptr-vreg offset ) class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ; diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 8283299ea8..9804244ecb 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -8,7 +8,7 @@ compiler.cfg.utilities compiler.cfg.builder.blocks ; IN: compiler.cfg.intrinsics.allot : ##set-slots ( regs obj class -- ) - '[ _ swap 1 + _ tag-number ##set-slot-imm ] each-index ; + '[ _ swap 1 + _ type-number ##set-slot-imm ] each-index ; : emit-simple-allot ( node -- ) [ in-d>> length ] [ node-output-infos first class>> ] bi @@ -31,10 +31,10 @@ IN: compiler.cfg.intrinsics.allot ] [ drop emit-primitive ] if ; : store-length ( len reg class -- ) - [ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ; + [ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm ; :: store-initial-element ( len reg elt class -- ) - len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ; + len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each ; : expand-? ( obj -- ? ) dup integer? [ 0 8 between? ] [ drop f ] if ; @@ -43,17 +43,15 @@ IN: compiler.cfg.intrinsics.allot 2 + cells array ^^allot ; :: emit- ( node -- ) - [let | len [ node node-input-infos first literal>> ] | - len expand-? [ - [let | elt [ ds-pop ] - reg [ len ^^allot-array ] | - ds-drop - len reg array store-length - len reg elt array store-initial-element - reg ds-push - ] - ] [ node emit-primitive ] if - ] ; + node node-input-infos first literal>> :> len + len expand-? [ + ds-pop :> elt + len ^^allot-array :> reg + ds-drop + len reg array store-length + len reg elt array store-initial-element + reg ds-push + ] [ node emit-primitive ] if ; : expand-(byte-array)? ( obj -- ? ) dup integer? [ 0 1024 between? ] [ drop f ] if ; @@ -64,7 +62,7 @@ IN: compiler.cfg.intrinsics.allot : bytes>cells ( m -- n ) cell align cell /i ; : ^^allot-byte-array ( n -- dst ) - 2 cells + byte-array ^^allot ; + 16 + byte-array ^^allot ; : emit-allot-byte-array ( len -- dst ) ds-drop diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 8ead484cf1..e4d1735eae 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -21,7 +21,7 @@ IN: compiler.cfg.intrinsics.fixnum ds-push ; : tag-literal ( n -- tagged ) - literal>> [ tag-fixnum ] [ \ f tag-number ] if* ; + literal>> [ tag-fixnum ] [ \ f type-number ] if* ; : emit-fixnum-op ( insn -- ) [ 2inputs ] dip call ds-push ; inline diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 3b6674efee..f40b838b97 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -33,6 +33,7 @@ IN: compiler.cfg.intrinsics { { kernel.private:tag [ drop emit-tag ] } { kernel.private:getenv [ emit-getenv ] } + { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] } { math.private:both-fixnums? [ drop emit-both-fixnums? ] } { math.private:fixnum+ [ drop emit-fixnum+ ] } { math.private:fixnum- [ drop emit-fixnum- ] } @@ -163,8 +164,8 @@ IN: compiler.cfg.intrinsics { math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] } { math.vectors.simd.intrinsics:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] } { math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vmin) [ [ ^^min-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vmin) [ [ generate-min-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vmax) [ [ generate-max-vector ] emit-binary-vector-op ] } { math.vectors.simd.intrinsics:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] } { math.vectors.simd.intrinsics:(simd-vabs) [ [ generate-abs-vector ] emit-unary-vector-op ] } { math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] } @@ -187,10 +188,10 @@ IN: compiler.cfg.intrinsics { math.vectors.simd.intrinsics:(simd-vany?) [ [ vcc-any ^^test-vector ] emit-unary-vector-op ] } { math.vectors.simd.intrinsics:(simd-vall?) [ [ vcc-all ^^test-vector ] emit-unary-vector-op ] } { math.vectors.simd.intrinsics:(simd-vnone?) [ [ vcc-none ^^test-vector ] emit-unary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector ] emit-horizontal-shift ] } - { math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector ] emit-horizontal-shift ] } + { math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector-imm ] [ ^^shl-vector ] emit-shift-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector-imm ] [ ^^shr-vector ] emit-shift-vector-op ] } + { math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector-imm ] emit-shift-vector-imm-op ] } + { math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector-imm ] emit-shift-vector-imm-op ] } { math.vectors.simd.intrinsics:(simd-with) [ [ ^^with-vector ] emit-unary-vector-op ] } { math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] } { math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] } diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor index ce005e8353..a477ef4b95 100644 --- a/basis/compiler/cfg/intrinsics/misc/misc.factor +++ b/basis/compiler/cfg/intrinsics/misc/misc.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces layouts sequences kernel -accessors compiler.tree.propagation.info -compiler.cfg.stacks compiler.cfg.hats -compiler.cfg.instructions compiler.cfg.utilities ; +USING: namespaces layouts sequences kernel math accessors +compiler.tree.propagation.info compiler.cfg.stacks +compiler.cfg.hats compiler.cfg.instructions +compiler.cfg.utilities ; IN: compiler.cfg.intrinsics.misc : emit-tag ( -- ) @@ -14,3 +14,9 @@ IN: compiler.cfg.intrinsics.misc swap node-input-infos first literal>> [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if* ds-push ; + +: emit-identity-hashcode ( -- ) + ds-pop tag-mask get bitnot ^^load-immediate ^^and 0 0 ^^slot-imm + hashcode-shift ^^shr-imm + ^^tag-fixnum + ds-push ; diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor index 73f880a102..a8dfaab2dd 100644 --- a/basis/compiler/cfg/intrinsics/simd/simd.factor +++ b/basis/compiler/cfg/intrinsics/simd/simd.factor @@ -10,8 +10,8 @@ compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats compiler.cfg.instructions compiler.cfg.registers compiler.cfg.intrinsics.alien specialized-arrays ; -FROM: alien.c-types => heap-size char uchar float double ; -SPECIALIZED-ARRAYS: float double ; +FROM: alien.c-types => heap-size uchar ushort uint ulonglong float double ; +SPECIALIZED-ARRAYS: uchar ushort uint ulonglong float double ; IN: compiler.cfg.intrinsics.simd MACRO: check-elements ( quots -- ) @@ -55,10 +55,15 @@ MACRO: if-literals-match ( quots -- ) : [unary/param] ( quot -- quot' ) '[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline -: emit-horizontal-shift ( node quot -- ) +: emit-shift-vector-imm-op ( node quot -- ) [unary/param] { [ integer? ] [ representation? ] } if-literals-match ; inline +:: emit-shift-vector-op ( node imm-quot var-quot -- ) + node node-input-infos 2 tail-slice* first literal>> integer? + [ node imm-quot emit-shift-vector-imm-op ] + [ node var-quot emit-binary-vector-op ] if ; inline + : emit-gather-vector-2 ( node -- ) [ ^^gather-vector-2 ] emit-binary-vector-op ; @@ -155,28 +160,79 @@ MACRO: if-literals-match ( quots -- ) [ ^^not-vector ] [ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ; -:: (generate-compare-vector) ( src1 src2 rep {cc,swap} -- dst ) - {cc,swap} first2 :> swap? :> cc +:: ((generate-compare-vector)) ( src1 src2 rep {cc,swap} -- dst ) + {cc,swap} first2 :> ( cc swap? ) swap? [ src2 src1 rep cc ^^compare-vector ] [ src1 src2 rep cc ^^compare-vector ] if ; -:: generate-compare-vector ( src1 src2 rep orig-cc -- dst ) - rep orig-cc %compare-vector-ccs :> not? :> ccs +:: (generate-compare-vector) ( src1 src2 rep orig-cc -- dst ) + rep orig-cc %compare-vector-ccs :> ( ccs not? ) ccs empty? [ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ] [ - ccs unclip :> first-cc :> rest-ccs - src1 src2 rep first-cc (generate-compare-vector) :> first-dst + ccs unclip :> ( rest-ccs first-cc ) + src1 src2 rep first-cc ((generate-compare-vector)) :> first-dst rest-ccs first-dst - [ [ src1 src2 rep ] dip (generate-compare-vector) rep ^^or-vector ] + [ [ src1 src2 rep ] dip ((generate-compare-vector)) rep ^^or-vector ] reduce not? [ rep generate-not-vector ] when ] if ; +: sign-bit-mask ( rep -- byte-array ) + unsign-rep { + { char-16-rep [ uchar-array{ + HEX: 80 HEX: 80 HEX: 80 HEX: 80 + HEX: 80 HEX: 80 HEX: 80 HEX: 80 + HEX: 80 HEX: 80 HEX: 80 HEX: 80 + HEX: 80 HEX: 80 HEX: 80 HEX: 80 + } underlying>> ] } + { short-8-rep [ ushort-array{ + HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000 + HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000 + } underlying>> ] } + { int-4-rep [ uint-array{ + HEX: 8000,0000 HEX: 8000,0000 + HEX: 8000,0000 HEX: 8000,0000 + } underlying>> ] } + { longlong-2-rep [ ulonglong-array{ + HEX: 8000,0000,0000,0000 + HEX: 8000,0000,0000,0000 + } underlying>> ] } + } case ; + +:: (generate-minmax-compare-vector) ( src1 src2 rep orig-cc -- dst ) + orig-cc order-cc { + { cc< [ src1 src2 rep ^^max-vector src1 rep cc/= (generate-compare-vector) ] } + { cc<= [ src1 src2 rep ^^min-vector src1 rep cc= (generate-compare-vector) ] } + { cc> [ src1 src2 rep ^^min-vector src1 rep cc/= (generate-compare-vector) ] } + { cc>= [ src1 src2 rep ^^max-vector src1 rep cc= (generate-compare-vector) ] } + } case ; + +:: generate-compare-vector ( src1 src2 rep orig-cc -- dst ) + { + { + [ rep orig-cc %compare-vector-reps member? ] + [ src1 src2 rep orig-cc (generate-compare-vector) ] + } + { + [ rep %min-vector-reps member? ] + [ src1 src2 rep orig-cc (generate-minmax-compare-vector) ] + } + { + [ rep unsign-rep orig-cc %compare-vector-reps member? ] + [ + rep sign-bit-mask ^^load-constant :> sign-bits + src1 sign-bits rep ^^xor-vector + src2 sign-bits rep ^^xor-vector + rep unsign-rep orig-cc (generate-compare-vector) + ] + } + } cond ; + :: generate-unpack-vector-head ( src rep -- dst ) { { @@ -190,6 +246,14 @@ MACRO: if-literals-match ( quots -- ) src zero rep ^^merge-vector-head ] } + { + [ rep widen-vector-rep %shr-vector-imm-reps member? ] + [ + src src rep ^^merge-vector-head + rep rep-component-type + heap-size 8 * rep widen-vector-rep ^^shr-vector-imm + ] + } [ rep ^^zero-vector :> zero zero src rep cc> ^^compare-vector :> sign @@ -217,6 +281,14 @@ MACRO: if-literals-match ( quots -- ) src zero rep ^^merge-vector-tail ] } + { + [ rep widen-vector-rep %shr-vector-imm-reps member? ] + [ + src src rep ^^merge-vector-tail + rep rep-component-type + heap-size 8 * rep widen-vector-rep ^^shr-vector-imm + ] + } [ rep ^^zero-vector :> zero zero src rep cc> ^^compare-vector :> sign @@ -265,3 +337,17 @@ MACRO: if-literals-match ( quots -- ) ] } cond ; +: generate-min-vector ( src1 src2 rep -- dst ) + dup %min-vector-reps member? + [ ^^min-vector ] [ + [ cc< generate-compare-vector ] + [ generate-blend-vector ] 3bi + ] if ; + +: generate-max-vector ( src1 src2 rep -- dst ) + dup %max-vector-reps member? + [ ^^max-vector ] [ + [ cc> generate-compare-vector ] + [ generate-blend-vector ] 3bi + ] if ; + diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index e1088a80ef..1ceac4990a 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -1,14 +1,17 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: layouts namespaces kernel accessors sequences math -classes.algebra locals combinators cpu.architecture -compiler.tree.propagation.info compiler.cfg.stacks -compiler.cfg.hats compiler.cfg.registers +classes.algebra classes.builtin locals combinators +cpu.architecture compiler.tree.propagation.info +compiler.cfg.stacks compiler.cfg.hats compiler.cfg.registers compiler.cfg.instructions compiler.cfg.utilities compiler.cfg.builder.blocks compiler.constants ; IN: compiler.cfg.intrinsics.slots -: value-tag ( info -- n ) class>> class-tag ; inline +: class-tag ( class -- tag/f ) + builtins get [ class<= ] with find drop ; + +: value-tag ( info -- n ) class>> class-tag ; : ^^tag-offset>slot ( slot tag -- vreg' ) [ ^^offset>slot ] dip ^^sub-imm ; @@ -42,7 +45,7 @@ IN: compiler.cfg.intrinsics.slots first class>> immediate class<= not ; :: (emit-set-slot) ( infos -- ) - 3inputs :> slot :> obj :> src + 3inputs :> ( src obj slot ) slot infos second value-tag ^^tag-offset>slot :> slot @@ -54,7 +57,7 @@ IN: compiler.cfg.intrinsics.slots :: (emit-set-slot-imm) ( infos -- ) ds-drop - 2inputs :> obj :> src + 2inputs :> ( src obj ) infos third literal>> :> slot infos second value-tag :> tag diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index ac32265e65..8951d7a1f1 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -42,7 +42,7 @@ IN: compiler.cfg.linear-scan.allocation : handle-sync-point ( n -- ) [ active-intervals get values ] dip - '[ [ _ spill-at-sync-point ] filter-here ] each ; + '[ [ _ spill-at-sync-point ] filter! drop ] each ; :: handle-progress ( n sync? -- ) n { diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index 8b4dde59da..845cb14d5c 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -18,13 +18,13 @@ ERROR: bad-live-ranges interval ; : trim-before-ranges ( live-interval -- ) [ ranges>> ] [ uses>> last 1 + ] bi - [ '[ from>> _ <= ] filter-here ] + [ '[ from>> _ <= ] filter! drop ] [ swap last (>>to) ] 2bi ; : trim-after-ranges ( live-interval -- ) [ ranges>> ] [ uses>> first ] bi - [ '[ to>> _ >= ] filter-here ] + [ '[ to>> _ >= ] filter! drop ] [ swap first (>>from) ] 2bi ; @@ -103,7 +103,7 @@ ERROR: bad-live-ranges interval ; ! most one) are split and spilled and removed from the inactive ! set. new vreg>> active-intervals-for [ [ reg>> reg = ] find swap dup ] keep - '[ _ delete-nth new start>> spill ] [ 2drop ] if ; + '[ _ remove-nth! drop new start>> spill ] [ 2drop ] if ; :: spill-intersecting-inactive ( new reg -- ) ! Any inactive intervals using 'reg' are split and spilled @@ -114,7 +114,7 @@ ERROR: bad-live-ranges interval ; new start>> spill f ] [ drop t ] if ] [ drop t ] if - ] filter-here ; + ] filter! drop ; : spill-intersecting ( new reg -- ) ! Split and spill all active and inactive intervals @@ -141,4 +141,4 @@ ERROR: bad-live-ranges interval ; { [ 2dup spill-new? ] [ spill-new ] } { [ 2dup register-available? ] [ spill-available ] } [ spill-partially-available ] - } cond ; \ No newline at end of file + } cond ; diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor index aeebe31dcc..4c825c9d7c 100644 --- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor +++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor @@ -33,7 +33,7 @@ SYMBOL: active-intervals dup vreg>> active-intervals-for push ; : delete-active ( live-interval -- ) - dup vreg>> active-intervals-for delq ; + dup vreg>> active-intervals-for remove-eq! drop ; : assign-free-register ( new registers -- ) pop >>reg add-active ; @@ -48,7 +48,7 @@ SYMBOL: inactive-intervals dup vreg>> inactive-intervals-for push ; : delete-inactive ( live-interval -- ) - dup vreg>> inactive-intervals-for delq ; + dup vreg>> inactive-intervals-for remove-eq! drop ; ! Vector of handled live intervals SYMBOL: handled-intervals @@ -83,7 +83,7 @@ ERROR: register-already-used live-interval ; ! Moving intervals between active and inactive sets : process-intervals ( n symbol quots -- ) ! symbol stores an alist mapping register classes to vectors - [ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline + [ get values ] dip '[ [ _ cond ] with filter! drop ] with each ; inline : deactivate-intervals ( n -- ) ! Any active intervals which have ended are moved to handled diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 75dda9b475..00d6f73517 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -152,8 +152,8 @@ ERROR: bad-live-interval live-interval ; ! to reverse some sequences, and compute the start and end. values dup [ { - [ ranges>> reverse-here ] - [ uses>> reverse-here ] + [ ranges>> reverse! drop ] + [ uses>> reverse! drop ] [ compute-start/end ] [ check-start ] } cleave @@ -187,4 +187,4 @@ ERROR: bad-live-interval live-interval ; } cond ; : intervals-intersect? ( interval1 interval2 -- ? ) - relevant-ranges intersect-live-ranges >boolean ; inline \ No newline at end of file + relevant-ranges intersect-live-ranges >boolean ; inline diff --git a/basis/compiler/cfg/predecessors/predecessors.factor b/basis/compiler/cfg/predecessors/predecessors.factor index 8ab9f316a7..506d4aa46c 100644 --- a/basis/compiler/cfg/predecessors/predecessors.factor +++ b/basis/compiler/cfg/predecessors/predecessors.factor @@ -12,7 +12,7 @@ IN: compiler.cfg.predecessors : update-phi ( bb ##phi -- ) [ swap predecessors>> - '[ drop _ memq? ] assoc-filter + '[ drop _ member-eq? ] assoc-filter ] change-inputs drop ; : update-phis ( bb -- ) @@ -30,4 +30,4 @@ PRIVATE> : needs-predecessors ( cfg -- cfg' ) dup predecessors-valid?>> - [ compute-predecessors t >>predecessors-valid? ] unless ; \ No newline at end of file + [ compute-predecessors t >>predecessors-valid? ] unless ; diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor index 0d518735af..2f4f2a99e6 100644 --- a/basis/compiler/cfg/registers/registers.factor +++ b/basis/compiler/cfg/registers/registers.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors namespaces kernel parser assocs ; +USING: accessors namespaces kernel parser assocs sequences ; IN: compiler.cfg.registers ! Virtual registers, used by CFG and machine IRs, are just integers @@ -42,5 +42,5 @@ C: ds-loc TUPLE: rs-loc < loc ; C: rs-loc -SYNTAX: D scan-word parsed ; -SYNTAX: R scan-word parsed ; +SYNTAX: D scan-word suffix! ; +SYNTAX: R scan-word suffix! ; diff --git a/basis/compiler/cfg/renaming/functor/functor.factor b/basis/compiler/cfg/renaming/functor/functor.factor index 2af68e9175..261aab6c54 100644 --- a/basis/compiler/cfg/renaming/functor/functor.factor +++ b/basis/compiler/cfg/renaming/functor/functor.factor @@ -20,15 +20,19 @@ WHERE GENERIC: rename-insn-defs ( insn -- ) -insn-classes get [ +M: insn rename-insn-defs drop ; + +insn-classes get [ insn-def-slot ] filter [ [ \ rename-insn-defs create-method-in ] - [ insn-def-slot dup [ name>> 1array ] when DEF-QUOT slot-change-quot ] bi + [ insn-def-slot name>> 1array DEF-QUOT slot-change-quot ] bi define ] each GENERIC: rename-insn-uses ( insn -- ) -insn-classes get { ##phi } diff [ +M: insn rename-insn-uses drop ; + +insn-classes get { ##phi } diff [ insn-use-slots empty? not ] filter [ [ \ rename-insn-uses create-method-in ] [ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi define @@ -39,7 +43,9 @@ M: ##phi rename-insn-uses GENERIC: rename-insn-temps ( insn -- ) -insn-classes get [ +M: insn rename-insn-temps drop ; + +insn-classes get [ insn-temp-slots empty? not ] filter [ [ \ rename-insn-temps create-method-in ] [ insn-temp-slots [ name>> ] map TEMP-QUOT slot-change-quot ] bi define diff --git a/basis/compiler/cfg/representations/preferred/preferred.factor b/basis/compiler/cfg/representations/preferred/preferred.factor index 4444290f05..726521cfe1 100644 --- a/basis/compiler/cfg/representations/preferred/preferred.factor +++ b/basis/compiler/cfg/representations/preferred/preferred.factor @@ -11,6 +11,10 @@ GENERIC: defs-vreg-rep ( insn -- rep/f ) GENERIC: temp-vreg-reps ( insn -- reps ) GENERIC: uses-vreg-reps ( insn -- reps ) +M: insn defs-vreg-rep drop f ; +M: insn temp-vreg-reps drop { } ; +M: insn uses-vreg-reps drop { } ; + > rep-getter-quot ] [ [ drop f ] ] if* ] - bi define ; + dup insn-def-slot dup [ + [ \ defs-vreg-rep create-method ] + [ rep>> rep-getter-quot ] + bi* define + ] [ 2drop ] if ; : reps-getter-quot ( reps -- quot ) - dup [ rep>> { f scalar-rep } memq? not ] all? [ + dup [ rep>> { f scalar-rep } member-eq? not ] all? [ [ rep>> ] map [ drop ] swap suffix ] [ [ rep>> rep-getter-quot ] map dup length { @@ -38,14 +44,18 @@ GENERIC: uses-vreg-reps ( insn -- reps ) ] if ; : define-uses-vreg-reps-method ( insn -- ) - [ \ uses-vreg-reps create-method ] - [ insn-use-slots reps-getter-quot ] - bi define ; + dup insn-use-slots [ drop ] [ + [ \ uses-vreg-reps create-method ] + [ reps-getter-quot ] + bi* define + ] if-empty ; : define-temp-vreg-reps-method ( insn -- ) - [ \ temp-vreg-reps create-method ] - [ insn-temp-slots reps-getter-quot ] - bi define ; + dup insn-temp-slots [ drop ] [ + [ \ temp-vreg-reps create-method ] + [ reps-getter-quot ] + bi* define + ] if-empty ; PRIVATE> diff --git a/basis/compiler/cfg/representations/representations.factor b/basis/compiler/cfg/representations/representations.factor index 42059f4152..005fe8c90b 100644 --- a/basis/compiler/cfg/representations/representations.factor +++ b/basis/compiler/cfg/representations/representations.factor @@ -47,7 +47,7 @@ M:: vector-rep emit-box ( dst src rep -- ) int-rep next-vreg-rep :> temp dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot temp 16 tag-fixnum ##load-immediate - temp dst 1 byte-array tag-number ##set-slot-imm + temp dst 1 byte-array type-number ##set-slot-imm dst byte-array-offset src rep ##set-alien-vector ; M: vector-rep emit-unbox @@ -209,7 +209,7 @@ RENAMING: convert [ converted-value ] [ converted-value ] [ ] : perform-renaming ( insn -- ) needs-renaming? get [ - renaming-set get reverse-here + renaming-set get reverse! drop [ convert-insn-uses ] [ convert-insn-defs ] bi renaming-set get length 0 assert= ] [ drop ] if ; diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor index 071b5d4b20..d93045da55 100644 --- a/basis/compiler/cfg/ssa/destruction/destruction.factor +++ b/basis/compiler/cfg/ssa/destruction/destruction.factor @@ -102,7 +102,7 @@ M: ##phi prepare-insn [ rename-insn-defs ] [ rename-insn-uses ] [ [ useless-copy? ] [ ##phi? ] bi or not ] tri - ] filter-here + ] filter! drop ] each-basic-block ; : destruct-ssa ( cfg -- cfg' ) @@ -114,4 +114,4 @@ M: ##phi prepare-insn dup compute-live-ranges dup prepare-coalescing process-copies - dup perform-renaming ; \ No newline at end of file + dup perform-renaming ; diff --git a/basis/compiler/cfg/ssa/liveness/liveness.factor b/basis/compiler/cfg/ssa/liveness/liveness.factor index 1ed6010dbe..7847de28fc 100644 --- a/basis/compiler/cfg/ssa/liveness/liveness.factor +++ b/basis/compiler/cfg/ssa/liveness/liveness.factor @@ -121,10 +121,9 @@ PRIVATE> PRIVATE> :: live-out? ( vreg node -- ? ) - [let | def [ vreg def-of ] | - { - { [ node def eq? ] [ vreg uses-of def only? not ] } - { [ def node strictly-dominates? ] [ vreg node (live-out?) ] } - [ f ] - } cond - ] ; + vreg def-of :> def + { + { [ node def eq? ] [ vreg uses-of def only? not ] } + { [ def node strictly-dominates? ] [ vreg node (live-out?) ] } + [ f ] + } cond ; diff --git a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor index cd4978c585..a2885ae26e 100644 --- a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor +++ b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor @@ -13,7 +13,7 @@ IN: compiler.cfg.useless-conditionals ##compare-imm-branch ##compare-float-ordered-branch ##compare-float-unordered-branch - } memq? + } member-eq? ] [ successors>> first2 [ skip-empty-blocks ] bi@ eq? ] } 1&& ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 19c73eebd4..3710f4974b 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -40,8 +40,8 @@ SYMBOL: visited :: insert-basic-block ( froms to bb -- ) bb froms V{ } like >>predecessors drop bb to 1vector >>successors drop - to predecessors>> [ dup froms memq? [ drop bb ] when ] change-each - froms [ successors>> [ dup to eq? [ drop bb ] when ] change-each ] each ; + to predecessors>> [ dup froms member-eq? [ drop bb ] when ] map! drop + froms [ successors>> [ dup to eq? [ drop bb ] when ] map! drop ] each ; : add-instructions ( bb quot -- ) [ instructions>> building ] dip '[ diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor index 0ac973a206..d2e7c2ac86 100644 --- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor +++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor @@ -27,6 +27,9 @@ C: reference-expr M: reference-expr equal? over reference-expr? [ [ value>> ] bi@ eq? ] [ 2drop f ] if ; +M: reference-expr hashcode* + nip value>> identity-hashcode ; + : constant>vn ( constant -- vn ) expr>vn ; inline GENERIC: >expr ( insn -- expr ) @@ -42,7 +45,7 @@ M: ##load-constant >expr obj>> ; << : input-values ( slot-specs -- slot-specs' ) - [ type>> { use literal constant } memq? ] filter ; + [ type>> { use literal constant } member-eq? ] filter ; : expr-class ( insn -- expr ) name>> "##" ?head drop "-expr" append create-class-in ; diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index bc228cb3b4..4864a8bfb7 100755 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -37,7 +37,7 @@ M: insn rewrite drop f ; dup ##compare-imm-branch? [ { [ cc>> cc/= eq? ] - [ src2>> \ f tag-number eq? ] + [ src2>> \ f type-number eq? ] } 1&& ] [ drop f ] if ; inline @@ -110,8 +110,8 @@ M: ##compare-imm rewrite-tagged-comparison : rewrite-redundant-comparison? ( insn -- ? ) { [ src1>> vreg>expr general-compare-expr? ] - [ src2>> \ f tag-number = ] - [ cc>> { cc= cc/= } memq? ] + [ src2>> \ f type-number = ] + [ cc>> { cc= cc/= } member-eq? ] } 1&& ; inline : rewrite-redundant-comparison ( insn -- insn' ) @@ -174,7 +174,7 @@ M: ##compare-imm-branch rewrite [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline : (rewrite-self-compare) ( insn -- ? ) - cc>> { cc= cc<= cc>= } memq? ; + cc>> { cc= cc<= cc>= } member-eq? ; : rewrite-self-compare-branch ( insn -- insn' ) (rewrite-self-compare) fold-branch ; @@ -204,7 +204,7 @@ M: ##compare-branch rewrite [ dst>> ] dip { { t [ t \ ##load-constant new-insn ] } - { f [ \ f tag-number \ ##load-immediate new-insn ] } + { f [ \ f type-number \ ##load-immediate new-insn ] } } case ; : rewrite-self-compare ( insn -- insn' ) @@ -279,7 +279,7 @@ M: ##not rewrite ##sub-imm ##mul ##mul-imm - } memq? ; + } member-eq? ; : immediate? ( value op -- ? ) arithmetic-op? [ immediate-arithmetic? ] [ immediate-bitwise? ] if ; @@ -440,7 +440,7 @@ M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ; :: rewrite-unbox-displaced-alien ( insn expr -- insns ) [ next-vreg :> temp - temp expr base>> vn>vreg expr base-class>> insn temp>> ##unbox-c-ptr + temp expr base>> vn>vreg expr base-class>> ##unbox-c-ptr insn dst>> temp expr displacement>> vn>vreg ##add ] { } make ; @@ -515,3 +515,48 @@ M: ##scalar>vector rewrite M: ##xor-vector rewrite dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq? [ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ; + +: vector-not? ( expr -- ? ) + { + [ not-vector-expr? ] + [ { + [ xor-vector-expr? ] + [ [ src1>> ] [ src2>> ] bi [ vn>expr fill-vector-expr? ] either? ] + } 1&& ] + } 1|| ; + +GENERIC: vector-not-src ( expr -- vreg ) +M: not-vector-expr vector-not-src src>> vn>vreg ; +M: xor-vector-expr vector-not-src + dup src1>> vn>expr fill-vector-expr? [ src2>> ] [ src1>> ] if vn>vreg ; + +M: ##and-vector rewrite + { + { [ dup src1>> vreg>expr vector-not? ] [ + { + [ dst>> ] + [ src1>> vreg>expr vector-not-src ] + [ src2>> ] + [ rep>> ] + } cleave \ ##andn-vector new-insn + ] } + { [ dup src2>> vreg>expr vector-not? ] [ + { + [ dst>> ] + [ src2>> vreg>expr vector-not-src ] + [ src1>> ] + [ rep>> ] + } cleave \ ##andn-vector new-insn + ] } + [ drop f ] + } cond ; + +M: ##andn-vector rewrite + dup src1>> vreg>expr vector-not? [ + { + [ dst>> ] + [ src1>> vreg>expr vector-not-src ] + [ src2>> ] + [ rep>> ] + } cleave \ ##and-vector new-insn + ] [ drop f ] if ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index 733b8cc22a..b404c4d4a4 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -82,7 +82,7 @@ IN: compiler.cfg.value-numbering.tests T{ ##load-reference f 1 + } T{ ##peek f 2 D 0 } T{ ##compare f 4 2 1 cc> } - T{ ##compare-imm f 6 4 5 cc/= } + T{ ##compare-imm f 6 4 $[ \ f type-number ] cc/= } T{ ##replace f 6 D 0 } } value-numbering-step trim-temps ] unit-test @@ -100,7 +100,7 @@ IN: compiler.cfg.value-numbering.tests T{ ##load-reference f 1 + } T{ ##peek f 2 D 0 } T{ ##compare f 4 2 1 cc<= } - T{ ##compare-imm f 6 4 5 cc= } + T{ ##compare-imm f 6 4 $[ \ f type-number ] cc= } T{ ##replace f 6 D 0 } } value-numbering-step trim-temps ] unit-test @@ -118,7 +118,7 @@ IN: compiler.cfg.value-numbering.tests T{ ##peek f 8 D 0 } T{ ##peek f 9 D -1 } T{ ##compare-float-unordered f 12 8 9 cc< } - T{ ##compare-imm f 14 12 5 cc= } + T{ ##compare-imm f 14 12 $[ \ f type-number ] cc= } T{ ##replace f 14 D 0 } } value-numbering-step trim-temps ] unit-test @@ -135,7 +135,7 @@ IN: compiler.cfg.value-numbering.tests T{ ##peek f 29 D -1 } T{ ##peek f 30 D -2 } T{ ##compare f 33 29 30 cc<= } - T{ ##compare-imm-branch f 33 5 cc/= } + T{ ##compare-imm-branch f 33 $[ \ f type-number ] cc/= } } value-numbering-step trim-temps ] unit-test @@ -149,7 +149,7 @@ IN: compiler.cfg.value-numbering.tests { T{ ##peek f 1 D -1 } T{ ##test-vector f 2 1 f float-4-rep vcc-any } - T{ ##compare-imm-branch f 2 5 cc/= } + T{ ##compare-imm-branch f 2 $[ \ f type-number ] cc/= } } value-numbering-step trim-temps ] unit-test @@ -1071,14 +1071,14 @@ cell 8 = [ ! Branch folding [ { - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 2 } - T{ ##load-immediate f 3 5 } + T{ ##load-immediate f 1 10 } + T{ ##load-immediate f 2 20 } + T{ ##load-immediate f 3 $[ \ f type-number ] } } ] [ { - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 2 } + T{ ##load-immediate f 1 10 } + T{ ##load-immediate f 2 20 } T{ ##compare f 3 1 2 cc= } } value-numbering-step ] unit-test @@ -1113,14 +1113,14 @@ cell 8 = [ [ { - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 2 } - T{ ##load-immediate f 3 5 } + T{ ##load-immediate f 1 10 } + T{ ##load-immediate f 2 20 } + T{ ##load-immediate f 3 $[ \ f type-number ] } } ] [ { - T{ ##load-immediate f 1 1 } - T{ ##load-immediate f 2 2 } + T{ ##load-immediate f 1 10 } + T{ ##load-immediate f 2 20 } T{ ##compare f 3 2 1 cc< } } value-numbering-step ] unit-test @@ -1128,7 +1128,7 @@ cell 8 = [ [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 5 } + T{ ##load-immediate f 1 $[ \ f type-number ] } } ] [ { @@ -1152,7 +1152,7 @@ cell 8 = [ [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 5 } + T{ ##load-immediate f 1 $[ \ f type-number ] } } ] [ { @@ -1176,7 +1176,7 @@ cell 8 = [ [ { T{ ##peek f 0 D 0 } - T{ ##load-immediate f 1 5 } + T{ ##load-immediate f 1 $[ \ f type-number ] } } ] [ { @@ -1281,6 +1281,128 @@ cell 8 = [ } value-numbering-step ] unit-test +! NOT x AND y => x ANDN y + +[ + { + T{ ##fill-vector f 3 float-4-rep } + T{ ##xor-vector f 4 0 3 float-4-rep } + T{ ##andn-vector f 5 0 1 float-4-rep } + } +] [ + { + T{ ##fill-vector f 3 float-4-rep } + T{ ##xor-vector f 4 0 3 float-4-rep } + T{ ##and-vector f 5 4 1 float-4-rep } + } value-numbering-step +] unit-test + +[ + { + T{ ##not-vector f 4 0 float-4-rep } + T{ ##andn-vector f 5 0 1 float-4-rep } + } +] [ + { + T{ ##not-vector f 4 0 float-4-rep } + T{ ##and-vector f 5 4 1 float-4-rep } + } value-numbering-step +] unit-test + +! x AND NOT y => y ANDN x + +[ + { + T{ ##fill-vector f 3 float-4-rep } + T{ ##xor-vector f 4 0 3 float-4-rep } + T{ ##andn-vector f 5 0 1 float-4-rep } + } +] [ + { + T{ ##fill-vector f 3 float-4-rep } + T{ ##xor-vector f 4 0 3 float-4-rep } + T{ ##and-vector f 5 1 4 float-4-rep } + } value-numbering-step +] unit-test + +[ + { + T{ ##not-vector f 4 0 float-4-rep } + T{ ##andn-vector f 5 0 1 float-4-rep } + } +] [ + { + T{ ##not-vector f 4 0 float-4-rep } + T{ ##and-vector f 5 1 4 float-4-rep } + } value-numbering-step +] unit-test + +! NOT x ANDN y => x AND y + +[ + { + T{ ##fill-vector f 3 float-4-rep } + T{ ##xor-vector f 4 0 3 float-4-rep } + T{ ##and-vector f 5 0 1 float-4-rep } + } +] [ + { + T{ ##fill-vector f 3 float-4-rep } + T{ ##xor-vector f 4 0 3 float-4-rep } + T{ ##andn-vector f 5 4 1 float-4-rep } + } value-numbering-step +] unit-test + +[ + { + T{ ##not-vector f 4 0 float-4-rep } + T{ ##and-vector f 5 0 1 float-4-rep } + } +] [ + { + T{ ##not-vector f 4 0 float-4-rep } + T{ ##andn-vector f 5 4 1 float-4-rep } + } value-numbering-step +] unit-test + +! AND <=> ANDN + +[ + { + T{ ##fill-vector f 3 float-4-rep } + T{ ##xor-vector f 4 0 3 float-4-rep } + T{ ##andn-vector f 5 0 1 float-4-rep } + T{ ##and-vector f 6 0 2 float-4-rep } + T{ ##or-vector f 7 5 6 float-4-rep } + } +] [ + { + T{ ##fill-vector f 3 float-4-rep } + T{ ##xor-vector f 4 0 3 float-4-rep } + T{ ##and-vector f 5 4 1 float-4-rep } + T{ ##andn-vector f 6 4 2 float-4-rep } + T{ ##or-vector f 7 5 6 float-4-rep } + } value-numbering-step +] unit-test + +[ + { + T{ ##not-vector f 4 0 float-4-rep } + T{ ##andn-vector f 5 0 1 float-4-rep } + T{ ##and-vector f 6 0 2 float-4-rep } + T{ ##or-vector f 7 5 6 float-4-rep } + } +] [ + { + T{ ##not-vector f 4 0 float-4-rep } + T{ ##and-vector f 5 4 1 float-4-rep } + T{ ##andn-vector f 6 4 2 float-4-rep } + T{ ##or-vector f 7 5 6 float-4-rep } + } value-numbering-step +] unit-test + +! branch folding + : test-branch-folding ( insns -- insns' n ) [ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep @@ -1435,7 +1557,7 @@ cell 8 = [ { T{ ##peek f 0 D 0 } T{ ##compare f 1 0 0 cc<= } - T{ ##compare-imm-branch f 1 5 cc/= } + T{ ##compare-imm-branch f 1 $[ \ f type-number ] cc/= } } test-branch-folding ] unit-test @@ -1537,7 +1659,7 @@ V{ T{ ##copy { dst 21 } { src 20 } { rep any-rep } } T{ ##compare-imm-branch { src1 21 } - { src2 5 } + { src2 $[ \ f type-number ] } { cc cc/= } } } 1 test-bb diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index 0217055923..523f7c6d1c 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -37,7 +37,7 @@ M: insn eliminate-write-barrier drop t ; : write-barriers-step ( bb -- ) H{ } clone fresh-allocations set H{ } clone mutated-objects set - instructions>> [ eliminate-write-barrier ] filter-here ; + instructions>> [ eliminate-write-barrier ] filter! drop ; : eliminate-write-barriers ( cfg -- cfg' ) dup [ write-barriers-step ] each-basic-block ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index e8f3ca7d64..15c4e14ac1 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -181,14 +181,16 @@ CODEGEN: ##dot-vector %dot-vector CODEGEN: ##sqrt-vector %sqrt-vector CODEGEN: ##horizontal-add-vector %horizontal-add-vector CODEGEN: ##horizontal-sub-vector %horizontal-sub-vector -CODEGEN: ##horizontal-shl-vector %horizontal-shl-vector -CODEGEN: ##horizontal-shr-vector %horizontal-shr-vector +CODEGEN: ##horizontal-shl-vector-imm %horizontal-shl-vector-imm +CODEGEN: ##horizontal-shr-vector-imm %horizontal-shr-vector-imm CODEGEN: ##abs-vector %abs-vector CODEGEN: ##and-vector %and-vector CODEGEN: ##andn-vector %andn-vector CODEGEN: ##or-vector %or-vector CODEGEN: ##xor-vector %xor-vector CODEGEN: ##not-vector %not-vector +CODEGEN: ##shl-vector-imm %shl-vector-imm +CODEGEN: ##shr-vector-imm %shr-vector-imm CODEGEN: ##shl-vector %shl-vector CODEGEN: ##shr-vector %shr-vector CODEGEN: ##integer>scalar %integer>scalar diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 626ab678c0..a772855ab6 100755 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -5,13 +5,16 @@ continuations vocabs assocs dlists definitions math graphs generic generic.single combinators deques search-deques macros source-files.errors combinators.short-circuit -stack-checker stack-checker.state stack-checker.inlining stack-checker.errors +stack-checker stack-checker.dependencies stack-checker.inlining +stack-checker.errors compiler.errors compiler.units compiler.utilities compiler.tree.builder compiler.tree.optimizer +compiler.crossref + compiler.cfg compiler.cfg.builder compiler.cfg.optimizer @@ -55,28 +58,28 @@ SYMBOL: compiled GENERIC: no-compile? ( word -- ? ) -M: word no-compile? "no-compile" word-prop ; - M: method-body no-compile? "method-generic" word-prop no-compile? ; M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ; +M: word no-compile? + { [ macro? ] [ "special" word-prop ] [ "no-compile" word-prop ] } 1|| ; + +GENERIC: combinator? ( word -- ? ) + +M: method-body combinator? "method-generic" word-prop combinator? ; + +M: predicate-engine-word combinator? "owner-generic" word-prop combinator? ; + +M: word combinator? inline? ; + : ignore-error? ( word error -- ? ) #! Ignore some errors on inline combinators, macros, and special #! words such as 'call'. - [ - { - [ macro? ] - [ inline? ] - [ no-compile? ] - [ "special" word-prop ] - } 1|| - ] [ - { - [ do-not-compile? ] - [ literal-expected? ] - } 1|| - ] bi* and ; + { + [ drop no-compile? ] + [ [ combinator? ] [ unknown-macro-input? ] bi* and ] + } 2|| ; : finish ( word -- ) #! Recompile callers if the word's stack effect changed, then @@ -199,6 +202,14 @@ M: optimizing-compiler recompile ( words -- alist ) ] with-scope "--- compile done" compiler-message ; +M: optimizing-compiler to-recompile ( -- words ) + changed-definitions get compiled-usages + changed-generics get compiled-generic-usages + append assoc-combine keys ; + +M: optimizing-compiler process-forgotten-words + [ delete-compiled-xref ] each ; + : with-optimizer ( quot -- ) [ optimizing-compiler compiler-impl ] dip with-variable ; inline diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index a22d522809..19cdb6eebd 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -12,19 +12,18 @@ CONSTANT: deck-bits 18 ! These constants must match vm/layouts.h : slot-offset ( slot tag -- n ) [ bootstrap-cells ] dip - ; inline -: header-offset ( -- n ) 0 object tag-number slot-offset ; inline -: float-offset ( -- n ) 8 float tag-number - ; inline -: string-offset ( -- n ) 4 string tag-number slot-offset ; inline -: string-aux-offset ( -- n ) 2 string tag-number slot-offset ; inline -: profile-count-offset ( -- n ) 8 \ word tag-number slot-offset ; inline -: byte-array-offset ( -- n ) 2 byte-array tag-number slot-offset ; inline -: alien-offset ( -- n ) 3 alien tag-number slot-offset ; inline -: underlying-alien-offset ( -- n ) 1 alien tag-number slot-offset ; inline -: tuple-class-offset ( -- n ) 1 tuple tag-number slot-offset ; inline -: word-xt-offset ( -- n ) 10 \ word tag-number slot-offset ; inline -: quot-xt-offset ( -- n ) 4 quotation tag-number slot-offset ; inline -: word-code-offset ( -- n ) 11 \ word tag-number slot-offset ; inline -: array-start-offset ( -- n ) 2 array tag-number slot-offset ; inline +: float-offset ( -- n ) 8 float type-number - ; inline +: string-offset ( -- n ) 4 string type-number slot-offset ; inline +: string-aux-offset ( -- n ) 2 string type-number slot-offset ; inline +: profile-count-offset ( -- n ) 8 \ word type-number slot-offset ; inline +: byte-array-offset ( -- n ) 16 byte-array type-number - ; inline +: alien-offset ( -- n ) 4 alien type-number slot-offset ; inline +: underlying-alien-offset ( -- n ) 1 alien type-number slot-offset ; inline +: tuple-class-offset ( -- n ) 1 tuple type-number slot-offset ; inline +: word-xt-offset ( -- n ) 10 \ word type-number slot-offset ; inline +: quot-xt-offset ( -- n ) 4 quotation type-number slot-offset ; inline +: word-code-offset ( -- n ) 11 \ word type-number slot-offset ; inline +: array-start-offset ( -- n ) 2 array type-number slot-offset ; inline : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline ! Relocation classes diff --git a/basis/io/servers/packet/authors.txt b/basis/compiler/crossref/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from basis/io/servers/packet/authors.txt rename to basis/compiler/crossref/authors.txt diff --git a/basis/compiler/crossref/crossref.factor b/basis/compiler/crossref/crossref.factor new file mode 100644 index 0000000000..e6ef5cf17c --- /dev/null +++ b/basis/compiler/crossref/crossref.factor @@ -0,0 +1,68 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs classes.algebra compiler.units definitions graphs +grouping kernel namespaces sequences words +stack-checker.dependencies ; +IN: compiler.crossref + +SYMBOL: compiled-crossref + +compiled-crossref [ H{ } clone ] initialize + +SYMBOL: compiled-generic-crossref + +compiled-generic-crossref [ H{ } clone ] initialize + +: compiled-usage ( word -- assoc ) + compiled-crossref get at ; + +: (compiled-usages) ( word -- assoc ) + #! If the word is not flushable anymore, we have to recompile + #! all words which flushable away a call (presumably when the + #! word was still flushable). If the word is flushable, we + #! don't have to recompile words that folded this away. + [ compiled-usage ] + [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi + [ dependency>= nip ] curry assoc-filter ; + +: compiled-usages ( seq -- assocs ) + [ drop word? ] assoc-filter + [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ; + +: compiled-generic-usage ( word -- assoc ) + compiled-generic-crossref get at ; + +: (compiled-generic-usages) ( generic class -- assoc ) + [ compiled-generic-usage ] dip + [ + 2dup [ valid-class? ] both? + [ classes-intersect? ] [ 2drop f ] if nip + ] curry assoc-filter ; + +: compiled-generic-usages ( assoc -- assocs ) + [ (compiled-generic-usages) ] { } assoc>map ; + +: (compiled-xref) ( word dependencies word-prop variable -- ) + [ [ concat ] dip set-word-prop ] [ get add-vertex* ] bi-curry* 2bi ; + +: compiled-xref ( word dependencies generic-dependencies -- ) + [ [ drop crossref? ] { } assoc-filter-as ] bi@ + [ "compiled-uses" compiled-crossref (compiled-xref) ] + [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ] + bi-curry* bi ; + +: (compiled-unxref) ( word word-prop variable -- ) + [ [ [ dupd word-prop 2 ] dip get remove-vertex* ] 2curry ] + [ drop [ remove-word-prop ] curry ] + 2bi bi ; + +: compiled-unxref ( word -- ) + [ "compiled-uses" compiled-crossref (compiled-unxref) ] + [ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ] + bi ; + +: delete-compiled-xref ( word -- ) + [ compiled-unxref ] + [ compiled-crossref get delete-at ] + [ compiled-generic-crossref get delete-at ] + tri ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 1bf7a00c75..a2ce533afd 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -12,7 +12,7 @@ IN: compiler.tests.alien << : libfactor-ffi-tests-path ( -- string ) - "resource:" (normalize-path) + "resource:" absolute-path { { [ os winnt? ] [ "libfactor-ffi-test.dll" ] } { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] } @@ -90,14 +90,14 @@ FUNCTION: TINY ffi_test_17 int x ; [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with : indirect-test-1 ( ptr -- result ) - "int" { } "cdecl" alien-indirect ; + int { } "cdecl" alien-indirect ; { 1 1 } [ indirect-test-1 ] must-infer-as [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test : indirect-test-1' ( ptr -- ) - "int" { } "cdecl" alien-indirect drop ; + int { } "cdecl" alien-indirect drop ; { 1 0 } [ indirect-test-1' ] must-infer-as @@ -106,7 +106,7 @@ FUNCTION: TINY ffi_test_17 int x ; [ -1 indirect-test-1 ] must-fail : indirect-test-2 ( x y ptr -- result ) - "int" { "int" "int" } "cdecl" alien-indirect gc ; + int { int int } "cdecl" alien-indirect gc ; { 3 1 } [ indirect-test-2 ] must-infer-as @@ -115,20 +115,20 @@ FUNCTION: TINY ffi_test_17 int x ; unit-test : indirect-test-3 ( a b c d ptr -- result ) - "int" { "int" "int" "int" "int" } "stdcall" alien-indirect + int { int int int int } "stdcall" alien-indirect gc ; [ f ] [ "f-stdcall" load-library f = ] unit-test [ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test : ffi_test_18 ( w x y z -- int ) - "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } + int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke gc ; [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test : ffi_test_19 ( x y z -- BAR ) - "BAR" "f-stdcall" "ffi_test_19" { "long" "long" "long" } + BAR "f-stdcall" "ffi_test_19" { long long long } alien-invoke gc ; [ 11 6 -7 ] [ @@ -157,17 +157,17 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3, ! Make sure XT doesn't get clobbered in stack frame : ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y ) - "int" + int "f-cdecl" "ffi_test_31" - { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } + { int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int } alien-invoke gc 3 ; [ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test : ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result ) - "float" + float "f-cdecl" "ffi_test_31_point_5" - { "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" } + { float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float } alien-invoke ; [ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test @@ -312,21 +312,21 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; ! Test callbacks -: callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ; +: callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ; [ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test [ t ] [ callback-1 alien? ] unit-test -: callback_test_1 ( ptr -- ) "void" { } "cdecl" alien-indirect ; +: callback_test_1 ( ptr -- ) void { } "cdecl" alien-indirect ; [ ] [ callback-1 callback_test_1 ] unit-test -: callback-2 ( -- callback ) "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; +: callback-2 ( -- callback ) void { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; [ ] [ callback-2 callback_test_1 ] unit-test -: callback-3 ( -- callback ) "void" { } "cdecl" [ 5 "x" set ] alien-callback ; +: callback-3 ( -- callback ) void { } "cdecl" [ 5 "x" set ] alien-callback ; [ t ] [ namestack* @@ -341,7 +341,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; ] unit-test : callback-4 ( -- callback ) - "void" { } "cdecl" [ "Hello world" write ] alien-callback + void { } "cdecl" [ "Hello world" write ] alien-callback gc ; [ "Hello world" ] [ @@ -349,40 +349,40 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; ] unit-test : callback-5 ( -- callback ) - "void" { } "cdecl" [ gc ] alien-callback ; + void { } "cdecl" [ gc ] alien-callback ; [ "testing" ] [ "testing" callback-5 callback_test_1 ] unit-test : callback-5b ( -- callback ) - "void" { } "cdecl" [ compact-gc ] alien-callback ; + void { } "cdecl" [ compact-gc ] alien-callback ; [ "testing" ] [ "testing" callback-5b callback_test_1 ] unit-test : callback-6 ( -- callback ) - "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; + void { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test : callback-7 ( -- callback ) - "void" { } "cdecl" [ 1000000 sleep ] alien-callback ; + void { } "cdecl" [ 1000000 sleep ] alien-callback ; [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test [ f ] [ namespace global eq? ] unit-test : callback-8 ( -- callback ) - "void" { } "cdecl" [ + void { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; [ ] [ callback-8 callback_test_1 ] unit-test : callback-9 ( -- callback ) - "int" { "int" "int" "int" } "cdecl" [ + int { int int int } "cdecl" [ + + 1 + ] alien-callback ; @@ -440,13 +440,13 @@ STRUCT: double-rect } cleave ; : double-rect-callback ( -- alien ) - "void" { "void*" "void*" "double-rect" } "cdecl" + void { void* void* double-rect } "cdecl" [ "example" set-global 2drop ] alien-callback ; : double-rect-test ( arg -- arg' ) f f rot double-rect-callback - "void" { "void*" "void*" "double-rect" } "cdecl" alien-indirect + void { void* void* double-rect } "cdecl" alien-indirect "example" get-global ; [ 1.0 2.0 3.0 4.0 ] @@ -463,7 +463,7 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ; ] unit-test : callback-10 ( -- callback ) - "test_struct_14" { "double" "double" } "cdecl" + test_struct_14 { double double } "cdecl" [ test_struct_14 swap >>x2 @@ -471,7 +471,7 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ; ] alien-callback ; : callback-10-test ( x1 x2 callback -- result ) - "test_struct_14" { "double" "double" } "cdecl" alien-indirect ; + test_struct_14 { double double } "cdecl" alien-indirect ; [ 1.0 2.0 ] [ 1.0 2.0 callback-10 callback-10-test @@ -486,7 +486,7 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ; ] unit-test : callback-11 ( -- callback ) - "test-struct-12" { "int" "double" } "cdecl" + test-struct-12 { int double } "cdecl" [ test-struct-12 swap >>x @@ -494,7 +494,7 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ; ] alien-callback ; : callback-11-test ( x1 x2 callback -- result ) - "test-struct-12" { "int" "double" } "cdecl" alien-indirect ; + test-struct-12 { int double } "cdecl" alien-indirect ; [ 1 2.0 ] [ 1 2.0 callback-11 callback-11-test @@ -510,7 +510,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ; [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test : callback-12 ( -- callback ) - "test_struct_15" { "float" "float" } "cdecl" + test_struct_15 { float float } "cdecl" [ test_struct_15 swap >>y @@ -518,7 +518,7 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ; ] alien-callback ; : callback-12-test ( x1 x2 callback -- result ) - "test_struct_15" { "float" "float" } "cdecl" alien-indirect ; + test_struct_15 { float float } "cdecl" alien-indirect ; [ 1.0 2.0 ] [ 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi @@ -533,7 +533,7 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ; [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test : callback-13 ( -- callback ) - "test_struct_16" { "float" "int" } "cdecl" + test_struct_16 { float int } "cdecl" [ test_struct_16 swap >>a @@ -541,7 +541,7 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ; ] alien-callback ; : callback-13-test ( x1 x2 callback -- result ) - "test_struct_16" { "float" "int" } "cdecl" alien-indirect ; + test_struct_16 { float int } "cdecl" alien-indirect ; [ 1.0 2 ] [ 1.0 2 callback-13 callback-13-test @@ -588,5 +588,4 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ; ! Regression: calling an undefined function would raise a protection fault FUNCTION: void this_does_not_exist ( ) ; -[ this_does_not_exist ] [ { "kernel-error" 10 f f } = ] must-fail-with - +[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 141fc24309..eba6580574 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -175,20 +175,6 @@ TUPLE: my-tuple ; ] compile-call ] unit-test -[ 1 t ] [ - B{ 1 2 3 4 } [ - { c-ptr } declare - [ 0 alien-unsigned-1 ] keep hi-tag - ] compile-call byte-array type-number = -] unit-test - -[ t ] [ - B{ 1 2 3 4 } [ - { c-ptr } declare - 0 alien-cell hi-tag - ] compile-call alien type-number = -] unit-test - [ 2 1 ] [ 2 1 [ 2dup fixnum< [ [ die ] dip ] when ] compile-call @@ -270,8 +256,8 @@ TUPLE: id obj ; { float } declare dup 0 = [ drop 1 ] [ dup 0 >= - [ 2 "double" "libm" "pow" { "double" "double" } alien-invoke ] - [ -0.5 "double" "libm" "pow" { "double" "double" } alien-invoke ] + [ 2 double "libm" "pow" { double double } alien-invoke ] + [ -0.5 double "libm" "pow" { double double } alien-invoke ] if ] if ; @@ -475,4 +461,4 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read- [ 2 0 ] [ 1 1 [ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor old mode 100644 new mode 100755 index 75cfc1d67f..7fe5e2b601 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -21,7 +21,6 @@ IN: compiler.tests.intrinsics [ 2 1 3 ] [ 1 2 3 [ swapd ] compile-call ] unit-test [ 2 ] [ 1 2 [ nip ] compile-call ] unit-test [ 3 ] [ 1 2 3 [ 2nip ] compile-call ] unit-test -[ 2 1 2 ] [ 1 2 [ tuck ] compile-call ] unit-test [ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test [ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test [ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test @@ -244,20 +243,20 @@ IN: compiler.tests.intrinsics [ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test [ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test -[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test -[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test +[ HEX: 8000000 ] [ HEX: -8000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test +[ HEX: 8000000 ] [ HEX: -7ffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test -[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test -[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test +[ t ] [ 1 26 fixnum-shift dup [ fixnum+ ] compile-call 1 27 fixnum-shift = ] unit-test +[ -134217729 ] [ 1 27 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test [ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test [ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test [ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test [ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-call ] unit-test -[ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-call ] unit-test +[ 134217728 ] [ -134217728 >fixnum -1 [ fixnum/i ] compile-call ] unit-test -[ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test +[ 134217728 0 ] [ -134217728 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test [ t ] [ f [ f eq? ] compile-call ] unit-test @@ -285,8 +284,8 @@ cell 8 = [ ! 64-bit overflow cell 8 = [ - [ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test - [ -1152921504606846977 ] [ 1 60 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test + [ t ] [ 1 58 fixnum-shift dup [ fixnum+ ] compile-call 1 59 fixnum-shift = ] unit-test + [ -576460752303423489 ] [ 1 59 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test [ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-call 1 80 shift = ] unit-test [ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-call 1 80 shift neg = ] unit-test @@ -301,9 +300,9 @@ cell 8 = [ [ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-call ] unit-test [ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test - [ 1152921504606846976 ] [ -1152921504606846976 >fixnum -1 [ fixnum/i ] compile-call ] unit-test + [ 576460752303423488 ] [ -576460752303423488 >fixnum -1 [ fixnum/i ] compile-call ] unit-test - [ 1152921504606846976 0 ] [ -1152921504606846976 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test + [ 576460752303423488 0 ] [ -576460752303423488 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test [ -268435457 ] [ 28 2^ [ fixnum-bitnot ] compile-call ] unit-test ] when @@ -311,12 +310,14 @@ cell 8 = [ ! Some randomized tests : compiled-fixnum* ( a b -- c ) fixnum* ; +ERROR: bug-in-fixnum* x y a b ; + [ ] [ 10000 [ - 32 random-bits >fixnum 32 random-bits >fixnum - 2dup - [ fixnum* ] 2keep compiled-fixnum* = - [ 2drop ] [ "Oops" throw ] if + 32 random-bits >fixnum + 32 random-bits >fixnum + 2dup [ fixnum* ] [ compiled-fixnum* ] 2bi 2dup = + [ 2drop 2drop ] [ bug-in-fixnum* ] if ] times ] unit-test @@ -419,7 +420,7 @@ cell 8 = [ "b" get [ [ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-call ] unit-test [ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-call ] unit-test - [ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test + [ 3 ] [ "b" get 2 [ { alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test [ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test [ ] [ "b" get free ] unit-test @@ -584,16 +585,16 @@ TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ; swap [ { tuple } declare 1 slot ] [ - 0 slot + 1 slot ] if ; -[ t ] [ f B{ } mutable-value-bug-1 byte-array type-number = ] unit-test +[ 0 ] [ f { } mutable-value-bug-1 ] unit-test : mutable-value-bug-2 ( a b -- c ) swap [ - 0 slot + 1 slot ] [ { tuple } declare 1 slot ] if ; -[ t ] [ t B{ } mutable-value-bug-2 byte-array type-number = ] unit-test +[ 0 ] [ t { } mutable-value-bug-2 ] unit-test diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor index 14c470d63f..b6b8e1c031 100644 --- a/basis/compiler/tests/low-level-ir.factor +++ b/basis/compiler/tests/low-level-ir.factor @@ -36,7 +36,7 @@ IN: compiler.tests.low-level-ir ! loading immediates [ f ] [ V{ - T{ ##load-immediate f 0 5 } + T{ ##load-immediate f 0 $[ \ f type-number ] } } compile-test-bb ] unit-test @@ -50,7 +50,7 @@ IN: compiler.tests.low-level-ir ! one of the sources [ t ] [ V{ - T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] } + T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] } T{ ##load-reference f 0 { t f t } } T{ ##slot f 0 0 1 } } compile-test-bb @@ -59,13 +59,13 @@ IN: compiler.tests.low-level-ir [ t ] [ V{ T{ ##load-reference f 0 { t f t } } - T{ ##slot-imm f 0 0 2 $[ array tag-number ] } + T{ ##slot-imm f 0 0 2 $[ array type-number ] } } compile-test-bb ] unit-test [ t ] [ V{ - T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] } + T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] } T{ ##load-reference f 0 { t f t } } T{ ##set-slot f 0 0 1 } } compile-test-bb @@ -75,12 +75,12 @@ IN: compiler.tests.low-level-ir [ t ] [ V{ T{ ##load-reference f 0 { t f t } } - T{ ##set-slot-imm f 0 0 2 $[ array tag-number ] } + T{ ##set-slot-imm f 0 0 2 $[ array type-number ] } } compile-test-bb dup first eq? ] unit-test -[ 8 ] [ +[ 4 ] [ V{ T{ ##load-immediate f 0 4 } T{ ##shl f 0 0 0 } @@ -90,16 +90,16 @@ IN: compiler.tests.low-level-ir [ 4 ] [ V{ T{ ##load-immediate f 0 4 } - T{ ##shl-imm f 0 0 3 } + T{ ##shl-imm f 0 0 4 } } compile-test-bb ] unit-test [ 31 ] [ V{ T{ ##load-reference f 1 B{ 31 67 52 } } - T{ ##unbox-any-c-ptr f 0 1 2 } + T{ ##unbox-any-c-ptr f 0 1 } T{ ##alien-unsigned-1 f 0 0 0 } - T{ ##shl-imm f 0 0 3 } + T{ ##shl-imm f 0 0 4 } } compile-test-bb ] unit-test @@ -108,13 +108,13 @@ IN: compiler.tests.low-level-ir T{ ##load-reference f 0 "hello world" } T{ ##load-immediate f 1 3 } T{ ##string-nth f 0 0 1 2 } - T{ ##shl-imm f 0 0 3 } + T{ ##shl-imm f 0 0 4 } } compile-test-bb ] unit-test [ 1 ] [ V{ - T{ ##load-immediate f 0 16 } - T{ ##add-imm f 0 0 -8 } + T{ ##load-immediate f 0 32 } + T{ ##add-imm f 0 0 -16 } } compile-test-bb ] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 0c9b1817c8..0831d6e8dd 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -4,7 +4,7 @@ sbufs strings tools.test vectors words sequences.private quotations classes classes.algebra classes.tuple.private continuations growable namespaces hints alien.accessors compiler.tree.builder compiler.tree.optimizer sequences.deep -compiler definitions generic.single ; +compiler definitions generic.single shuffle ; IN: compiler.tests.optimizer GENERIC: xyz ( obj -- obj ) @@ -202,7 +202,7 @@ USE: binary-search.private dup length 1 <= [ from>> ] [ - [ midpoint swap call ] 3keep roll dup zero? + [ midpoint swap call ] 3keep [ rot ] dip swap dup zero? [ drop dup from>> swap midpoint@ + ] [ drop dup midpoint@ head-slice old-binsearch ] if ] if ; inline recursive @@ -443,5 +443,7 @@ M: object bad-dispatch-position-test* ; [ -1 ] [ 3 4 0 dispatch-branch-problem ] unit-test [ 12 ] [ 3 4 1 dispatch-branch-problem ] unit-test +[ 1024 bignum ] [ 10 [ 1 >bignum swap >fixnum shift ] compile-call dup class ] unit-test + ! Not sure if I want to fix this... -! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with \ No newline at end of file +! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index 67added49d..913111b8ea 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -1,6 +1,6 @@ USING: accessors compiler compiler.units tools.test math parser kernel sequences sequences.private classes.mixin generic -definitions arrays words assocs eval ; +definitions arrays words assocs eval grouping ; IN: compiler.tests.redefine3 GENERIC: sheeple ( obj -- x ) @@ -13,20 +13,23 @@ M: empty-mixin sheeple drop "wake up" ; inline : sheeple-test ( -- string ) { } sheeple ; +: compiled-use? ( key word -- ? ) + "compiled-uses" word-prop 2 key? ; + [ "sheeple" ] [ sheeple-test ] unit-test [ t ] [ \ sheeple-test optimized? ] unit-test -[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test -[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test +[ t ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test +[ f ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test [ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test [ "wake up" ] [ sheeple-test ] unit-test -[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test -[ t ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test +[ f ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test +[ t ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test [ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test [ "sheeple" ] [ sheeple-test ] unit-test [ t ] [ \ sheeple-test optimized? ] unit-test -[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test -[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test +[ t ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test +[ f ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index da021412fe..a86d5b8c52 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -1,6 +1,7 @@ USING: compiler compiler.units tools.test kernel kernel.private sequences.private math.private math combinators strings alien -arrays memory vocabs parser eval ; +arrays memory vocabs parser eval quotations compiler.errors +definitions ; IN: compiler.tests.simple ! Test empty word @@ -238,3 +239,13 @@ M: f single-combination-test-2 single-combination-test-4 ; "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj ) ] unit-test ] times + +! This should not compile +GENERIC: bad-effect-test ( a -- ) +M: quotation bad-effect-test call ; inline +: bad-effect-test* ( -- ) [ 1 2 3 ] bad-effect-test ; + +[ bad-effect-test* ] [ not-compiled? ] must-fail-with + +! Don't want compiler error to stick around +[ ] [ [ M\ quotation bad-effect-test forget ] with-compilation-unit ] unit-test diff --git a/basis/compiler/tests/stack-trace.factor b/basis/compiler/tests/stack-trace.factor index 20a5cc867c..40aa1bb336 100755 --- a/basis/compiler/tests/stack-trace.factor +++ b/basis/compiler/tests/stack-trace.factor @@ -19,7 +19,7 @@ IN: compiler.tests.stack-trace : bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ; -: stack-trace-any? ( word -- ? ) symbolic-stack-trace memq? ; +: stack-trace-any? ( word -- ? ) symbolic-stack-trace member-eq? ; [ t ] [ [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any? diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index e4523deb9f..8eb66fde1f 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -39,7 +39,7 @@ M: word (build-tree) [ recursive-state set V{ } clone stack-visitor set - [ [ >vector \ meta-d set ] [ length d-in set ] bi ] + [ [ >vector \ meta-d set ] [ length input-count set ] bi ] [ (build-tree) ] bi* ] with-infer nip ; diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 02e7409c24..db96086371 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -491,7 +491,7 @@ cell-bits 32 = [ ] unit-test [ t ] [ - [ { array } declare 2 [ . . ] assoc-each ] + [ { array } declare 2 [ . . ] assoc-each ] \ nth-unsafe inlined? ] unit-test diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index 1cd9589065..ec819d0eac 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -3,7 +3,7 @@ USING: kernel accessors sequences combinators fry classes.algebra namespaces assocs words math math.private math.partial-dispatch math.intervals classes classes.tuple -classes.tuple.private layouts definitions stack-checker.state +classes.tuple.private layouts definitions stack-checker.dependencies stack-checker.branches compiler.utilities compiler.tree @@ -20,7 +20,7 @@ IN: compiler.tree.cleanup GENERIC: delete-node ( node -- ) M: #call-recursive delete-node - dup label>> calls>> [ node>> eq? not ] with filter-here ; + dup label>> calls>> [ node>> eq? not ] with filter! drop ; M: #return-recursive delete-node label>> f >>return drop ; diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor index ed4df91eec..d859096e1d 100644 --- a/basis/compiler/tree/dead-code/dead-code-tests.factor +++ b/basis/compiler/tree/dead-code/dead-code-tests.factor @@ -6,7 +6,7 @@ compiler.tree.tuple-unboxing compiler.tree.debugger compiler.tree.recursive compiler.tree.normalization compiler.tree.checker tools.test kernel math stack-checker.state accessors combinators io prettyprint words sequences.deep -sequences.private arrays classes kernel.private ; +sequences.private arrays classes kernel.private shuffle ; IN: compiler.tree.dead-code.tests : count-live-values ( quot -- n ) diff --git a/basis/compiler/tree/dead-code/recursive/recursive.factor b/basis/compiler/tree/dead-code/recursive/recursive.factor index b0ab864c80..482d370947 100644 --- a/basis/compiler/tree/dead-code/recursive/recursive.factor +++ b/basis/compiler/tree/dead-code/recursive/recursive.factor @@ -39,14 +39,13 @@ M: #enter-recursive remove-dead-code* 2bi ; :: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle ) - [let* | new-live-outputs [ inputs outputs filter-corresponding make-values ] - live-outputs [ outputs filter-live ] | - new-live-outputs - live-outputs - live-outputs - new-live-outputs - drop-values - ] ; + inputs outputs filter-corresponding make-values :> new-live-outputs + outputs filter-live :> live-outputs + new-live-outputs + live-outputs + live-outputs + new-live-outputs + drop-values ; : drop-call-recursive-outputs ( node -- #shuffle ) dup [ label>> return>> in-d>> ] [ out-d>> ] bi @@ -60,22 +59,20 @@ M: #call-recursive remove-dead-code* tri 3array ; :: drop-recursive-inputs ( node -- shuffle ) - [let* | shuffle [ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs ] - new-outputs [ shuffle out-d>> ] | - node new-outputs - [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi - shuffle - ] ; + node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs :> shuffle + shuffle out-d>> :> new-outputs + node new-outputs + [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi + shuffle ; :: drop-recursive-outputs ( node -- shuffle ) - [let* | return [ node label>> return>> ] - new-inputs [ return in-d>> filter-live ] - new-outputs [ return [ in-d>> ] [ out-d>> ] bi filter-corresponding ] | - return - [ new-inputs >>in-d new-outputs >>out-d drop ] - [ drop-dead-outputs ] - bi - ] ; + node label>> return>> :> return + return in-d>> filter-live :> new-inputs + return [ in-d>> ] [ out-d>> ] bi filter-corresponding :> new-outputs + return + [ new-inputs >>in-d new-outputs >>out-d drop ] + [ drop-dead-outputs ] + bi ; M: #recursive remove-dead-code* ( node -- nodes ) [ drop-recursive-inputs ] diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor index 5134a67a5b..67c5cfdc78 100755 --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/basis/compiler/tree/dead-code/simple/simple.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors words assocs sequences arrays namespaces fry locals definitions classes classes.algebra generic -stack-checker.state +stack-checker.dependencies stack-checker.backend compiler.tree compiler.tree.propagation.info @@ -71,14 +71,13 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ; filter-corresponding zip #data-shuffle ; inline :: drop-dead-values ( outputs -- #shuffle ) - [let* | new-outputs [ outputs make-values ] - live-outputs [ outputs filter-live ] | - new-outputs - live-outputs - outputs - new-outputs - drop-values - ] ; + outputs make-values :> new-outputs + outputs filter-live :> live-outputs + new-outputs + live-outputs + outputs + new-outputs + drop-values ; : drop-dead-outputs ( node -- #shuffle ) dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ; diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 4bf4cf88f0..63f145d752 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -51,7 +51,6 @@ MATCH-VARS: ?a ?b ?c ; { { { ?b ?a } { ?a ?b } } [ swap ] } { { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] } { { { ?a ?b } { ?a ?a ?b } } [ dupd ] } - { { { ?a ?b } { ?b ?a ?b } } [ tuck ] } { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] } { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] } { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] } diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor index 8ca80ccbae..ece2ed80f3 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor @@ -75,7 +75,7 @@ M: #push compute-modular-candidates* 0 cell-bits tag-bits get - 1 - [a,b] interval-subset? ; : modular-word? ( #call -- ? ) - dup word>> { shift fixnum-shift bignum-shift } memq? + dup word>> { shift fixnum-shift bignum-shift } member-eq? [ node-input-infos second interval>> small-shift? ] [ word>> "modular-arithmetic" word-prop ] if ; @@ -178,10 +178,10 @@ MEMO: fixnum-coercion ( flags -- nodes ) ] when ; : like->fixnum? ( #call -- ? ) - word>> { >fixnum bignum>fixnum float>fixnum } memq? ; + word>> { >fixnum bignum>fixnum float>fixnum } member-eq? ; : like->integer? ( #call -- ? ) - word>> { >integer >bignum fixnum>bignum } memq? ; + word>> { >integer >bignum fixnum>bignum } member-eq? ; M: #call optimize-modular-arithmetic* { diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor index 0d837d82ae..28f34cb425 100755 --- a/basis/compiler/tree/propagation/branches/branches.factor +++ b/basis/compiler/tree/propagation/branches/branches.factor @@ -97,7 +97,7 @@ M: #phi propagate-before ( #phi -- ) constraints get last update-constraints ; : branch-phi-constraints ( output values booleans -- ) - { + { { { { t } { f } } [ @@ -130,6 +130,22 @@ M: #phi propagate-before ( #phi -- ) swap t--> ] } + { + { { t f } { t } } + [ + first =f + condition-value get =t /\ + swap f--> + ] + } + { + { { t } { t f } } + [ + second =f + condition-value get =f /\ + swap f--> + ] + } { { { t f } { } } [ diff --git a/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor b/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor index 79a9f69de5..4a543fb87a 100644 --- a/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor +++ b/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: compiler.tree.propagation.call-effect tools.test fry math effects kernel -compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences ; +compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences +eval combinators ; IN: compiler.tree.propagation.call-effect.tests [ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test @@ -58,4 +59,23 @@ IN: compiler.tree.propagation.call-effect.tests ! [ boa ] by itself doesn't infer TUPLE: a-tuple x ; -[ V{ a-tuple } ] [ [ a-tuple '[ _ boa ] call( x -- tuple ) ] final-classes ] unit-test \ No newline at end of file +[ V{ a-tuple } ] [ [ a-tuple '[ _ boa ] call( x -- tuple ) ] final-classes ] unit-test + +! See if redefinitions are handled correctly +: call(-redefine-test ( a -- b ) 1 + ; + +: test-quotatation ( -- quot ) [ call(-redefine-test ] ; + +[ t ] [ test-quotatation cached-effect (( a -- b )) effect<= ] unit-test + +[ ] [ "IN: compiler.tree.propagation.call-effect.tests USE: math : call(-redefine-test ( a b -- c ) + ;" eval( -- ) ] unit-test + +[ t ] [ test-quotatation cached-effect (( a b -- c )) effect<= ] unit-test + +: inline-cache-invalidation-test ( a b c -- c ) call( a b -- c ) ; + +[ 4 ] [ 1 3 test-quotatation inline-cache-invalidation-test ] unit-test + +[ ] [ "IN: compiler.tree.propagation.call-effect.tests USE: math : call(-redefine-test ( a -- c ) 1 + ;" eval( -- ) ] unit-test + +[ 1 3 test-quotatation inline-cache-invalidation-test ] [ T{ wrong-values f (( a b -- c )) } = ] must-fail-with diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor index 614ceeb597..ff4886d1c7 100644 --- a/basis/compiler/tree/propagation/call-effect/call-effect.factor +++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators combinators.private effects fry kernel kernel.private make sequences continuations quotations -words math stack-checker stack-checker.transforms -compiler.tree.propagation.info -compiler.tree.propagation.inlining ; +words math stack-checker combinators.short-circuit +stack-checker.transforms compiler.tree.propagation.info +compiler.tree.propagation.inlining compiler.units ; IN: compiler.tree.propagation.call-effect ! call( and execute( have complex expansions. @@ -15,13 +15,20 @@ IN: compiler.tree.propagation.call-effect ! and compare it with declaration. If matches, call it unsafely. ! - Fallback. If the above doesn't work, call it and compare the datastack before ! and after to make sure it didn't mess anything up. +! - Inline caches and cached effects are invalidated whenever a macro is redefined, or +! a word's effect changes, by comparing a global counter against the counter value +! last observed. The counter is incremented by compiler.units. ! execute( uses a similar strategy. -TUPLE: inline-cache value ; +TUPLE: inline-cache value counter ; -: cache-hit? ( word/quot ic -- ? ) - [ value>> eq? ] [ value>> ] bi and ; inline +: inline-cache-hit? ( word/quot ic -- ? ) + { [ value>> eq? ] [ nip counter>> effect-counter eq? ] } 2&& ; inline + +: update-inline-cache ( word/quot ic -- ) + [ effect-counter ] dip + [ (>>value) ] [ (>>counter) ] bi-curry bi* ; inline SINGLETON: +unknown+ @@ -53,9 +60,16 @@ M: compose cached-effect : safe-infer ( quot -- effect ) [ infer ] [ 2drop +unknown+ ] recover ; +: cached-effect-valid? ( quot -- ? ) + cache-counter>> effect-counter eq? ; inline + +: save-effect ( effect quot -- ) + [ effect-counter ] dip + [ (>>cached-effect) ] [ (>>cache-counter) ] bi-curry bi* ; + M: quotation cached-effect - dup cached-effect>> - [ ] [ [ safe-infer dup ] keep (>>cached-effect) ] ?if ; + dup cached-effect-valid? + [ cached-effect>> ] [ [ safe-infer dup ] keep save-effect ] if ; : call-effect-unsafe? ( quot effect -- ? ) [ cached-effect ] dip @@ -82,12 +96,12 @@ M: quotation cached-effect : call-effect-fast ( quot effect inline-cache -- ) 2over call-effect-unsafe? - [ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ] + [ [ nip update-inline-cache ] [ drop call-effect-unsafe ] 3bi ] [ drop call-effect-slow ] if ; inline : call-effect-ic ( quot effect inline-cache -- ) - 3dup nip cache-hit? + 3dup nip inline-cache-hit? [ drop call-effect-unsafe ] [ call-effect-fast ] if ; inline @@ -103,12 +117,12 @@ M: quotation cached-effect : execute-effect-fast ( word effect inline-cache -- ) 2over execute-effect-unsafe? - [ [ nip (>>value) ] [ drop execute-effect-unsafe ] 3bi ] + [ [ nip update-inline-cache ] [ drop execute-effect-unsafe ] 3bi ] [ drop execute-effect-slow ] if ; inline : execute-effect-ic ( word effect inline-cache -- ) - 3dup nip cache-hit? + 3dup nip inline-cache-hit? [ drop execute-effect-unsafe ] [ execute-effect-fast ] if ; inline diff --git a/basis/compiler/tree/propagation/constraints/constraints.factor b/basis/compiler/tree/propagation/constraints/constraints.factor index 59c9912e47..617352d699 100644 --- a/basis/compiler/tree/propagation/constraints/constraints.factor +++ b/basis/compiler/tree/propagation/constraints/constraints.factor @@ -39,8 +39,8 @@ M: true-constraint assume* bi ; M: true-constraint satisfied? - value>> value-info class>> - { [ true-class? ] [ null-class? not ] } 1&& ; + value>> value-info* + [ class>> true-class? ] [ drop f ] if ; TUPLE: false-constraint value ; @@ -52,8 +52,8 @@ M: false-constraint assume* bi ; M: false-constraint satisfied? - value>> value-info class>> - { [ false-class? ] [ null-class? not ] } 1&& ; + value>> value-info* + [ class>> false-class? ] [ drop f ] if ; ! Class constraints TUPLE: class-constraint value class ; diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 9030914e34..6dcf6f7317 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -294,8 +294,11 @@ DEFER: (value-info-union) ! Assoc stack of current value --> info mapping SYMBOL: value-infos +: value-info* ( value -- info ? ) + resolve-copy value-infos get assoc-stack [ null-info or ] [ >boolean ] bi ; inline + : value-info ( value -- info ) - resolve-copy value-infos get assoc-stack null-info or ; + value-info* drop ; : set-value-info ( info value -- ) resolve-copy value-infos get last set-at ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 367427c716..634fade609 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -90,7 +90,7 @@ M: callable splicing-nodes splicing-body ; ! Method body inlining SYMBOL: history -: already-inlined? ( obj -- ? ) history get memq? ; +: already-inlined? ( obj -- ? ) history get member-eq? ; : add-to-history ( obj -- ) history [ swap suffix ] change ; @@ -104,7 +104,7 @@ SYMBOL: history ] if ; : always-inline-word? ( word -- ? ) - { curry compose } memq? ; + { curry compose } member-eq? ; : never-inline-word? ( word -- ? ) { [ deferred? ] [ "default" word-prop ] [ \ call eq? ] } 1|| ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index d4780b335b..1453bebf9a 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -8,7 +8,7 @@ classes.algebra combinators generic.math splitting fry locals classes.tuple alien.accessors classes.tuple.private slots.private definitions strings.private vectors hashtables generic quotations alien -stack-checker.state +stack-checker.dependencies compiler.tree.comparisons compiler.tree.propagation.info compiler.tree.propagation.nodes @@ -140,20 +140,30 @@ IN: compiler.tree.propagation.known-words '[ _ _ 2bi ] "outputs" set-word-prop ] each -\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op -\ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op +: shift-op-class ( info1 info2 -- newclass ) + [ class>> ] bi@ + 2dup [ null-class? ] either? [ 2drop null ] [ drop math-closure ] if ; + +: shift-op ( word interval-quot post-proc-quot -- ) + '[ + [ shift-op-class ] [ _ binary-op-interval ] 2bi + @ + + ] "outputs" set-word-prop ; + +\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] shift-op ] each-derived-op +\ shift [ [ interval-shift-safe ] [ integer-valued ] shift-op ] each-fast-derived-op \ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op \ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op \ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op :: (comparison-constraints) ( in1 in2 op -- constraint ) - [let | i1 [ in1 value-info interval>> ] - i2 [ in2 value-info interval>> ] | - in1 i1 i2 op assumption is-in-interval - in2 i2 i1 op swap-comparison assumption is-in-interval - /\ - ] ; + in1 value-info interval>> :> i1 + in2 value-info interval>> :> i2 + in1 i1 i2 op assumption is-in-interval + in2 i2 i1 op swap-comparison assumption is-in-interval + /\ ; :: comparison-constraints ( in1 in2 out op -- constraint ) in1 in2 op (comparison-constraints) out t--> @@ -269,7 +279,7 @@ generic-comparison-ops [ ] each \ alien-cell [ - 2drop simple-alien \ f class-or + 2drop alien \ f class-or ] "outputs" set-word-prop { } [ diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 0a8cb61a9f..c7e02aef4c 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -224,6 +224,14 @@ IN: compiler.tree.propagation.tests [ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test +[ V{ fixnum } ] [ + [ + [ { fixnum } declare ] [ drop f ] if + dup [ dup 13 eq? [ t ] [ f ] if ] [ t ] if + [ "Oops" throw ] when + ] final-classes +] unit-test + [ V{ fixnum } ] [ [ >fixnum @@ -231,6 +239,14 @@ IN: compiler.tree.propagation.tests ] final-classes ] unit-test +[ ] [ + [ + dup dup dup [ 100 < ] [ drop f ] if dup + [ 2drop f ] [ 2drop f ] if + [ ] [ dup [ ] [ ] if ] if + ] final-info drop +] unit-test + [ V{ fixnum } ] [ [ { fixnum } declare (clone) ] final-classes ] unit-test @@ -407,10 +423,18 @@ IN: compiler.tree.propagation.tests [ { fixnum fixnum } declare 7 bitand neg shift ] final-classes ] unit-test +[ V{ fixnum } ] [ + [ { fixnum fixnum } declare 7 bitand neg >bignum shift ] final-classes +] unit-test + [ V{ fixnum } ] [ [ { fixnum } declare 1 swap 7 bitand shift ] final-classes ] unit-test +[ V{ fixnum } ] [ + [ { fixnum } declare 1 swap 7 bitand >bignum shift ] final-classes +] unit-test + cell-bits 32 = [ [ V{ integer } ] [ [ { fixnum } declare 1 swap 31 bitand shift ] @@ -859,8 +883,8 @@ SYMBOL: not-an-assoc [ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test [ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test -[ t ] [ [ { 1 2 3 } memq? ] { memq? } inlined? ] unit-test -[ f ] [ [ { 1 2 3 } swap memq? ] { memq? } inlined? ] unit-test +[ t ] [ [ { 1 2 3 } member-eq? ] { member-eq? } inlined? ] unit-test +[ f ] [ [ { 1 2 3 } swap member-eq? ] { member-eq? } inlined? ] unit-test [ t ] [ [ V{ } clone ] { clone (clone) } inlined? ] unit-test [ f ] [ [ { } clone ] { clone (clone) } inlined? ] unit-test @@ -882,10 +906,10 @@ M: tuple-with-read-only-slot clone [ { 1 2 3 } dup tuple-with-read-only-slot boa clone x>> eq? ] final-classes ] unit-test -! alien-cell outputs a simple-alien or f +! alien-cell outputs a alien or f [ t ] [ [ { byte-array fixnum } declare alien-cell dup [ "OOPS" throw ] unless ] final-classes - first simple-alien class= + first alien class= ] unit-test ! Don't crash if bad literal inputs are passed to unsafe words @@ -900,9 +924,21 @@ M: tuple-with-read-only-slot clone [ t ] [ [ void* ] { } inlined? ] unit-test [ V{ void*-array } ] [ [ void* ] final-classes ] unit-test +! bitand identities [ t ] [ [ alien-unsigned-1 255 bitand ] { bitand fixnum-bitand } inlined? ] unit-test [ t ] [ [ alien-unsigned-1 255 swap bitand ] { bitand fixnum-bitand } inlined? ] unit-test [ t ] [ [ { fixnum } declare 256 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test [ t ] [ [ { fixnum } declare 250 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test [ f ] [ [ { fixnum } declare 257 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test + +[ V{ fixnum } ] [ [ >bignum 10 mod 2^ ] final-classes ] unit-test +[ V{ bignum } ] [ [ >bignum 10 bitand ] final-classes ] unit-test +[ V{ bignum } ] [ [ >bignum 10 >bignum bitand ] final-classes ] unit-test +[ V{ bignum } ] [ [ >bignum 10 mod ] final-classes ] unit-test +[ V{ bignum } ] [ [ { fixnum } declare -1 >bignum bitand ] final-classes ] unit-test +[ V{ bignum } ] [ [ { fixnum } declare -1 >bignum swap bitand ] final-classes ] unit-test + +! Could be bignum not integer but who cares +[ V{ integer } ] [ [ 10 >bignum bitand ] final-classes ] unit-test + diff --git a/basis/compiler/tree/propagation/recursive/recursive-tests.factor b/basis/compiler/tree/propagation/recursive/recursive-tests.factor index 974bb584eb..42325d97ca 100644 --- a/basis/compiler/tree/propagation/recursive/recursive-tests.factor +++ b/basis/compiler/tree/propagation/recursive/recursive-tests.factor @@ -27,14 +27,16 @@ IN: compiler.tree.propagation.recursive.tests ] unit-test [ t ] [ + T{ interval f { -268435456 t } { 268435455 t } } T{ interval f { 1 t } { 268435455 t } } - T{ interval f { -268435456 t } { 268435455 t } } tuck + over integer generalize-counter-interval = ] unit-test [ t ] [ + T{ interval f { -268435456 t } { 268435455 t } } T{ interval f { 1 t } { 268435455 t } } - T{ interval f { -268435456 t } { 268435455 t } } tuck + over fixnum generalize-counter-interval = ] unit-test diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 5de5e26a30..b4d8b95247 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -4,7 +4,7 @@ USING: fry accessors kernel sequences sequences.private assocs words namespaces classes.algebra combinators combinators.short-circuit classes classes.tuple classes.tuple.private continuations arrays alien.c-types math -math.private slots generic definitions stack-checker.state +math.private slots generic definitions stack-checker.dependencies compiler.tree compiler.tree.propagation.info compiler.tree.propagation.nodes diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 4996729ded..11a4cdc4c6 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -11,7 +11,7 @@ IN: compiler.tree.propagation.slots UNION: fixed-length-sequence array byte-array string ; : sequence-constructor? ( word -- ? ) - { (byte-array) } memq? ; + { (byte-array) } member-eq? ; : constructor-output-class ( word -- class ) { diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index b8ff96f833..5aa490bfd3 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -2,11 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences words fry generic accessors classes.tuple classes classes.algebra definitions -stack-checker.state quotations classes.tuple.private math -math.partial-dispatch math.private math.intervals +stack-checker.dependencies quotations classes.tuple.private math +math.partial-dispatch math.private math.intervals sets.private math.floats.private math.integers.private layouts math.order vectors hashtables combinators effects generalizations assocs -sets combinators.short-circuit sequences.private locals +sets combinators.short-circuit sequences.private locals growable stack-checker namespaces compiler.tree.propagation.info ; IN: compiler.tree.propagation.transforms @@ -42,30 +42,27 @@ IN: compiler.tree.propagation.transforms : positive-fixnum? ( obj -- ? ) { [ fixnum? ] [ 0 >= ] } 1&& ; -: simplify-bitand? ( value -- ? ) - value-info literal>> positive-fixnum? ; +: simplify-bitand? ( value1 value2 -- ? ) + [ literal>> positive-fixnum? ] + [ class>> fixnum swap class<= ] + bi* and ; -: all-ones? ( int -- ? ) - dup 1 + bitand zero? ; inline +: all-ones? ( n -- ? ) dup 1 + bitand zero? ; inline -: redundant-bitand? ( var 111... -- ? ) - [ value-info ] bi@ [ interval>> ] [ literal>> ] bi* { +: redundant-bitand? ( value1 value2 -- ? ) + [ interval>> ] [ literal>> ] bi* { [ nip integer? ] [ nip all-ones? ] [ 0 swap [a,b] interval-subset? ] } 2&& ; -: (zero-bitand?) ( value-info value-info' -- ? ) +: zero-bitand? ( value1 value2 -- ? ) [ interval>> ] [ literal>> ] bi* { [ nip integer? ] [ nip bitnot all-ones? ] [ 0 swap bitnot [a,b] interval-subset? ] } 2&& ; -: zero-bitand? ( var1 var2 -- ? ) - [ value-info ] bi@ - { [ (zero-bitand?) ] [ swap (zero-bitand?) ] } 2|| ; - { bitand-integer-integer bitand-integer-fixnum @@ -73,35 +70,45 @@ IN: compiler.tree.propagation.transforms bitand } [ [ - { + in-d>> first2 [ value-info ] bi@ { { - [ dup in-d>> first2 zero-bitand? ] - [ drop [ 2drop 0 ] ] + [ 2dup zero-bitand? ] + [ 2drop [ 2drop 0 ] ] } { - [ dup in-d>> first2 redundant-bitand? ] - [ drop [ drop ] ] + [ 2dup swap zero-bitand? ] + [ 2drop [ 2drop 0 ] ] } { - [ dup in-d>> first2 swap redundant-bitand? ] - [ drop [ nip ] ] + [ 2dup redundant-bitand? ] + [ 2drop [ drop ] ] } { - [ dup in-d>> first simplify-bitand? ] - [ drop [ >fixnum fixnum-bitand ] ] + [ 2dup swap redundant-bitand? ] + [ 2drop [ nip ] ] } { - [ dup in-d>> second simplify-bitand? ] - [ drop [ [ >fixnum ] dip fixnum-bitand ] ] + [ 2dup simplify-bitand? ] + [ 2drop [ >fixnum fixnum-bitand ] ] } - [ drop f ] + { + [ 2dup swap simplify-bitand? ] + [ 2drop [ [ >fixnum ] dip fixnum-bitand ] ] + } + [ 2drop f ] } cond ] "custom-inlining" set-word-prop ] each ! Speeds up 2^ +: 2^? ( #call -- ? ) + in-d>> first2 [ value-info ] bi@ + [ { [ literal>> 1 = ] [ class>> fixnum class<= ] } 1&& ] + [ class>> fixnum class<= ] + bi* and ; + \ shift [ - in-d>> first value-info literal>> 1 = [ + 2^? [ cell-bits tag-bits get - 1 - '[ >fixnum dup 0 < [ 2drop 0 ] [ @@ -206,12 +213,12 @@ ERROR: bad-partial-eval quot word ; ] [ drop f ] if ] 1 define-partial-eval -: memq-quot ( seq -- newquot ) +: member-eq-quot ( seq -- newquot ) [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc [ drop f ] suffix [ cond ] curry ; -\ memq? [ - dup sequence? [ memq-quot ] [ drop f ] if +\ member-eq? [ + dup sequence? [ member-eq-quot ] [ drop f ] if ] 1 define-partial-eval ! Membership testing @@ -283,3 +290,20 @@ CONSTANT: lookup-table-at-max 256 ] [ drop f ] if ; \ at* [ at-quot ] 1 define-partial-eval + +: diff-quot ( seq -- quot: ( seq' -- seq'' ) ) + tester '[ [ @ not ] filter ] ; + +\ diff [ diff-quot ] 1 define-partial-eval + +: intersect-quot ( seq -- quot: ( seq' -- seq'' ) ) + tester '[ _ filter ] ; + +\ intersect [ intersect-quot ] 1 define-partial-eval + +! Speeds up sum-file, sort and reverse-complement benchmarks by +! compiling decoder-readln better +\ push [ + in-d>> second value-info class>> growable class<= + [ \ push def>> ] [ f ] if +] "custom-inlining" set-word-prop diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor index 7fa096b623..82b8fbb843 100644 --- a/basis/compiler/tree/tree.factor +++ b/basis/compiler/tree/tree.factor @@ -10,8 +10,6 @@ IN: compiler.tree TUPLE: node < identity-tuple ; -M: node hashcode* drop node hashcode* ; - TUPLE: #introduce < node out-d ; : #introduce ( out-d -- node ) diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor index b6c6910e34..84080a73d7 100644 --- a/basis/compiler/utilities/utilities.factor +++ b/basis/compiler/utilities/utilities.factor @@ -36,13 +36,11 @@ yield-hook [ [ ] ] initialize : penultimate ( seq -- elt ) [ length 2 - ] keep nth ; :: compress-path ( source assoc -- destination ) - [let | destination [ source assoc at ] | - source destination = [ source ] [ - [let | destination' [ destination assoc compress-path ] | - destination' destination = [ - destination' source assoc set-at - ] unless - destination' - ] - ] if - ] ; + source assoc at :> destination + source destination = [ source ] [ + destination assoc compress-path :> destination' + destination' destination = [ + destination' source assoc set-at + ] unless + destination' + ] if ; diff --git a/basis/compression/run-length/run-length.factor b/basis/compression/run-length/run-length.factor index cde2a7e113..ce25cd6a63 100644 --- a/basis/compression/run-length/run-length.factor +++ b/basis/compression/run-length/run-length.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators grouping kernel locals math -math.matrices math.order multiline sequence-parser sequences +math.matrices math.order multiline sequences.parser sequences tools.continuations ; IN: compression.run-length diff --git a/basis/concurrency/combinators/combinators.factor b/basis/concurrency/combinators/combinators.factor index 3d18b9e029..918b3c5ba0 100755 --- a/basis/concurrency/combinators/combinators.factor +++ b/basis/concurrency/combinators/combinators.factor @@ -29,7 +29,7 @@ PRIVATE> : [future] ( quot -- quot' ) '[ _ curry future ] ; inline : future-values ( futures -- futures ) - dup [ ?future ] change-each ; inline + [ ?future ] map! ; inline PRIVATE> diff --git a/basis/concurrency/distributed/distributed-docs.factor b/basis/concurrency/distributed/distributed-docs.factor index 76c9918cca..8ea7153b0b 100644 --- a/basis/concurrency/distributed/distributed-docs.factor +++ b/basis/concurrency/distributed/distributed-docs.factor @@ -8,11 +8,54 @@ HELP: start-node { $values { "port" "a port number between 0 and 65535" } } { $description "Starts a node server for receiving messages from remote Factor instances." } ; +ARTICLE: "concurrency.distributed.example" "Distributed Concurrency Example" +"For a Factor instance to be able to send and receive distributed " +"concurrency messages it must first have " { $link start-node } " called." +$nl +"In one factor instance call " { $link start-node } " with the port 9000, " +"and in another with the port 9001." +$nl +"In this example the Factor instance associated with port 9000 will run " +"a thread that sits receiving messages and printing the received message " +"in the listener. The code to start the thread is: " +{ $examples + { $unchecked-example + ": log-message ( -- ) receive . flush log-message ;" + "[ log-message ] \"logger\" spawn dup name>> register-remote-thread" + } +} +"This spawns a thread waits for the messages. It registers that thread as a " +"able to be accessed remotely using " { $link register-remote-thread } "." +$nl +"The second Factor instance, the one associated with port 9001, can send " +"messages to the 'logger' thread by name:" +{ $examples + { $unchecked-example + "USING: io.sockets concurrency.messaging concurrency.distributed ;" + "\"hello\" \"127.0.0.1\" 9000 \"logger\" send" + } +} +"The " { $link send } " word is used to send messages to other threads. If an " +"instance of " { $link remote-thread } " is provided instead of a thread then " +"the message is marshalled to the named thread on the given machine using the " +{ $vocab-link "serialize" } " vocabulary." +$nl +"Running this code should show the message \"hello\" in the first Factor " +"instance." +$nl +"It is also possible to use " { $link send-synchronous } " to receive a " +"response to a distributed message. When an instance of " { $link thread } " " +"is marshalled it is converted into an instance of " { $link remote-thread } +". The receiver of this can use it as the target of a " { $link send } +" or " { $link reply } " call." ; + ARTICLE: "concurrency.distributed" "Distributed message passing" "The " { $vocab-link "concurrency.distributed" } " implements transparent distributed message passing, inspired by Erlang and Termite." { $subsections start-node } -"Instances of " { $link thread } " can be sent to remote processes, at which point they are converted to objects holding the thread ID and the current node's host name:" -{ $subsections remote-process } -"The " { $vocab-link "serialize" } " vocabulary is used to convert Factor objects to byte arrays for transfer over a socket." ; +"Instances of " { $link thread } " can be sent to remote threads, at which point they are converted to objects holding the thread ID and the current node's host name:" +{ $subsections remote-thread } +"The " { $vocab-link "serialize" } " vocabulary is used to convert Factor objects to byte arrays for transfer over a socket." +{ $subsections "concurrency.distributed.example" } ; + ABOUT: "concurrency.distributed" diff --git a/basis/concurrency/distributed/distributed-tests.factor b/basis/concurrency/distributed/distributed-tests.factor index b2a2851926..1a46d0e38f 100644 --- a/basis/concurrency/distributed/distributed-tests.factor +++ b/basis/concurrency/distributed/distributed-tests.factor @@ -18,14 +18,14 @@ IN: concurrency.distributed.tests [ ] [ [ receive first2 [ 3 + ] dip send - "thread-a" unregister-process + "thread-a" unregister-remote-thread ] "Thread A" spawn - "thread-a" swap register-process + "thread-a" register-remote-thread ] unit-test [ 8 ] [ 5 self 2array - "thread-a" test-node send + test-node "thread-a" send receive ] unit-test diff --git a/basis/concurrency/distributed/distributed.factor b/basis/concurrency/distributed/distributed.factor index 52627f2ed9..244f1d95a3 100644 --- a/basis/concurrency/distributed/distributed.factor +++ b/basis/concurrency/distributed/distributed.factor @@ -1,16 +1,32 @@ ! Copyright (C) 2005 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. USING: serialize sequences concurrency.messaging threads io -io.servers.connection io.encodings.binary +io.servers.connection io.encodings.binary assocs init arrays namespaces kernel accessors ; FROM: io.sockets => host-name with-client ; IN: concurrency.distributed + + +: register-remote-thread ( thread name -- ) + registered-remote-threads set-at ; + +: unregister-remote-thread ( name -- ) + registered-remote-threads delete-at ; + +: get-remote-thread ( name -- thread ) + dup registered-remote-threads at [ ] [ thread ] ?if ; + SYMBOL: local-node : handle-node-client ( -- ) deserialize - [ first2 get-process send ] [ stop-this-server ] if* ; + [ first2 get-remote-thread send ] [ stop-this-server ] if* ; : ( addrspec -- threaded-server ) binary @@ -24,20 +40,26 @@ SYMBOL: local-node : start-node ( port -- ) host-name over (start-node) ; -TUPLE: remote-process id node ; +TUPLE: remote-thread node id ; -C: remote-process +C: remote-thread : send-remote-message ( message node -- ) binary [ serialize ] with-client ; -M: remote-process send ( message thread -- ) +M: remote-thread send ( message thread -- ) [ id>> 2array ] [ node>> ] bi send-remote-message ; M: thread (serialize) ( obj -- ) - id>> local-node get-global + id>> [ local-node get-global ] dip (serialize) ; : stop-node ( node -- ) f swap send-remote-message ; + +[ + H{ } clone \ registered-remote-threads set-global +] "remote-thread-registry" add-init-hook + + diff --git a/basis/concurrency/exchangers/exchangers-tests.factor b/basis/concurrency/exchangers/exchangers-tests.factor index a8214cf42f..c411aaea92 100644 --- a/basis/concurrency/exchangers/exchangers-tests.factor +++ b/basis/concurrency/exchangers/exchangers-tests.factor @@ -5,27 +5,25 @@ FROM: sequences => 3append ; IN: concurrency.exchangers.tests :: exchanger-test ( -- string ) - [let | - ex [ ] - c [ 2 ] - v1! [ f ] - v2! [ f ] - pr [ ] | + :> ex + 2 :> c + f :> v1! + f :> v2! + :> pr - [ - c await - v1 ", " v2 3append pr fulfill - ] "Awaiter" spawn drop + [ + c await + v1 ", " v2 3append pr fulfill + ] "Awaiter" spawn drop - [ - "Goodbye world" ex exchange v1! c count-down - ] "Exchanger 1" spawn drop + [ + "Goodbye world" ex exchange v1! c count-down + ] "Exchanger 1" spawn drop - [ - "Hello world" ex exchange v2! c count-down - ] "Exchanger 2" spawn drop + [ + "Hello world" ex exchange v2! c count-down + ] "Exchanger 2" spawn drop - pr ?promise - ] ; + pr ?promise ; [ "Hello world, Goodbye world" ] [ exchanger-test ] unit-test diff --git a/basis/concurrency/flags/flags-tests.factor b/basis/concurrency/flags/flags-tests.factor index 4fc00b71dd..8402a56631 100644 --- a/basis/concurrency/flags/flags-tests.factor +++ b/basis/concurrency/flags/flags-tests.factor @@ -3,46 +3,41 @@ kernel threads locals accessors calendar ; IN: concurrency.flags.tests :: flag-test-1 ( -- val ) - [let | f [ ] | - [ f raise-flag ] "Flag test" spawn drop - f lower-flag - f value>> - ] ; + :> f + [ f raise-flag ] "Flag test" spawn drop + f lower-flag + f value>> ; [ f ] [ flag-test-1 ] unit-test :: flag-test-2 ( -- ? ) - [let | f [ ] | - [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop - f lower-flag - f value>> - ] ; + :> f + [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop + f lower-flag + f value>> ; [ f ] [ flag-test-2 ] unit-test :: flag-test-3 ( -- val ) - [let | f [ ] | - f raise-flag - f value>> - ] ; + :> f + f raise-flag + f value>> ; [ t ] [ flag-test-3 ] unit-test :: flag-test-4 ( -- val ) - [let | f [ ] | - [ f raise-flag ] "Flag test" spawn drop - f wait-for-flag - f value>> - ] ; + :> f + [ f raise-flag ] "Flag test" spawn drop + f wait-for-flag + f value>> ; [ t ] [ flag-test-4 ] unit-test :: flag-test-5 ( -- val ) - [let | f [ ] | - [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop - f wait-for-flag - f value>> - ] ; + :> f + [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop + f wait-for-flag + f value>> ; [ t ] [ flag-test-5 ] unit-test diff --git a/basis/concurrency/locks/locks-tests.factor b/basis/concurrency/locks/locks-tests.factor index f199876fd0..c58d012b3f 100644 --- a/basis/concurrency/locks/locks-tests.factor +++ b/basis/concurrency/locks/locks-tests.factor @@ -4,57 +4,55 @@ threads sequences calendar accessors ; IN: concurrency.locks.tests :: lock-test-0 ( -- v ) - [let | v [ V{ } clone ] - c [ 2 ] | + V{ } clone :> v + 2 :> c - [ - yield - 1 v push - yield - 2 v push - c count-down - ] "Lock test 1" spawn drop + [ + yield + 1 v push + yield + 2 v push + c count-down + ] "Lock test 1" spawn drop - [ - yield - 3 v push - yield - 4 v push - c count-down - ] "Lock test 2" spawn drop + [ + yield + 3 v push + yield + 4 v push + c count-down + ] "Lock test 2" spawn drop - c await - v - ] ; + c await + v ; :: lock-test-1 ( -- v ) - [let | v [ V{ } clone ] - l [ ] - c [ 2 ] | + V{ } clone :> v + :> l + 2 :> c - [ - l [ - yield - 1 v push - yield - 2 v push - ] with-lock - c count-down - ] "Lock test 1" spawn drop + [ + l [ + yield + 1 v push + yield + 2 v push + ] with-lock + c count-down + ] "Lock test 1" spawn drop - [ - l [ - yield - 3 v push - yield - 4 v push - ] with-lock - c count-down - ] "Lock test 2" spawn drop + [ + l [ + yield + 3 v push + yield + 4 v push + ] with-lock + c count-down + ] "Lock test 2" spawn drop - c await - v - ] ; + c await + v ; [ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test [ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test @@ -80,98 +78,96 @@ IN: concurrency.locks.tests [ ] [ dup [ [ ] with-read-lock ] with-write-lock ] unit-test :: rw-lock-test-1 ( -- v ) - [let | l [ ] - c [ 1 ] - c' [ 1 ] - c'' [ 4 ] - v [ V{ } clone ] | + :> l + 1 :> c + 1 :> c' + 4 :> c'' + V{ } clone :> v - [ - l [ - 1 v push - c count-down - yield - 3 v push - ] with-read-lock - c'' count-down - ] "R/W lock test 1" spawn drop + [ + l [ + 1 v push + c count-down + yield + 3 v push + ] with-read-lock + c'' count-down + ] "R/W lock test 1" spawn drop - [ - c await - l [ - 4 v push - 1 seconds sleep - 5 v push - ] with-write-lock - c'' count-down - ] "R/W lock test 2" spawn drop + [ + c await + l [ + 4 v push + 1 seconds sleep + 5 v push + ] with-write-lock + c'' count-down + ] "R/W lock test 2" spawn drop - [ - c await - l [ - 2 v push - c' count-down - ] with-read-lock - c'' count-down - ] "R/W lock test 4" spawn drop + [ + c await + l [ + 2 v push + c' count-down + ] with-read-lock + c'' count-down + ] "R/W lock test 4" spawn drop - [ - c' await - l [ - 6 v push - ] with-write-lock - c'' count-down - ] "R/W lock test 5" spawn drop + [ + c' await + l [ + 6 v push + ] with-write-lock + c'' count-down + ] "R/W lock test 5" spawn drop - c'' await - v - ] ; + c'' await + v ; [ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test :: rw-lock-test-2 ( -- v ) - [let | l [ ] - c [ 1 ] - c' [ 2 ] - v [ V{ } clone ] | + :> l + 1 :> c + 2 :> c' + V{ } clone :> v - [ - l [ - 1 v push - c count-down - 1 seconds sleep - 2 v push - ] with-write-lock - c' count-down - ] "R/W lock test 1" spawn drop + [ + l [ + 1 v push + c count-down + 1 seconds sleep + 2 v push + ] with-write-lock + c' count-down + ] "R/W lock test 1" spawn drop - [ - c await - l [ - 3 v push - ] with-read-lock - c' count-down - ] "R/W lock test 2" spawn drop + [ + c await + l [ + 3 v push + ] with-read-lock + c' count-down + ] "R/W lock test 2" spawn drop - c' await - v - ] ; + c' await + v ; [ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test ! Test lock timeouts :: lock-timeout-test ( -- v ) - [let | l [ ] | - [ - l [ 1 seconds sleep ] with-lock - ] "Lock holder" spawn drop + :> l - [ - l 1/10 seconds [ ] with-lock-timeout - ] "Lock timeout-er" spawn-linked drop + [ + l [ 1 seconds sleep ] with-lock + ] "Lock holder" spawn drop - receive - ] ; + [ + l 1/10 seconds [ ] with-lock-timeout + ] "Lock timeout-er" spawn-linked drop + + receive ; [ lock-timeout-test ] [ thread>> name>> "Lock timeout-er" = diff --git a/basis/concurrency/mailboxes/mailboxes-docs.factor b/basis/concurrency/mailboxes/mailboxes-docs.factor index a58a1a4cc6..727efd45d0 100644 --- a/basis/concurrency/mailboxes/mailboxes-docs.factor +++ b/basis/concurrency/mailboxes/mailboxes-docs.factor @@ -18,9 +18,10 @@ HELP: mailbox-put { $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ; HELP: block-unless-pred -{ $values { "pred" { $quotation "( obj -- ? )" } } +{ $values { "mailbox" mailbox } { "timeout" "a " { $link duration } " or " { $link f } } + { "pred" { $quotation "( obj -- ? )" } } } { $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ; diff --git a/basis/concurrency/messaging/messaging-docs.factor b/basis/concurrency/messaging/messaging-docs.factor index 17f05e20fb..85870db4df 100644 --- a/basis/concurrency/messaging/messaging-docs.factor +++ b/basis/concurrency/messaging/messaging-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup concurrency.messaging.private +USING: help.syntax help.markup threads kernel arrays quotations strings ; IN: concurrency.messaging diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index ce7f7d6110..37965309e8 100644 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -68,21 +68,3 @@ M: cannot-send-synchronous-to-self summary receive [ data>> swap call ] keep reply-synchronous ; inline - - - -: register-process ( name process -- ) - swap registered-processes set-at ; - -: unregister-process ( name -- ) - registered-processes delete-at ; - -: get-process ( name -- process ) - dup registered-processes at [ ] [ thread ] ?if ; - -\ registered-processes [ H{ } clone ] initialize diff --git a/basis/cords/cords.factor b/basis/cords/cords.factor index a50de60c45..ad17da9652 100644 --- a/basis/cords/cords.factor +++ b/basis/cords/cords.factor @@ -12,7 +12,7 @@ TUPLE: simple-cord M: simple-cord length [ first>> length ] [ second>> length ] bi + ; inline -M: simple-cord virtual-seq first>> ; inline +M: simple-cord virtual-exemplar first>> ; inline M: simple-cord virtual@ 2dup first>> length < @@ -28,7 +28,7 @@ M: multi-cord virtual@ seqs>> [ first <=> ] with search nip [ first - ] [ second ] bi ; inline -M: multi-cord virtual-seq +M: multi-cord virtual-exemplar seqs>> [ f ] [ first second ] if-empty ; inline : ( seqs -- cord ) diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index e7a7962e6e..37dbcd1e4f 100755 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -36,8 +36,8 @@ STRUCT: FSEventStreamContext { release void* } { copyDescription void* } ; -! callback(FSEventStreamRef streamRef, void *clientCallBackInfo, size_t numEvents, void *eventPaths, const FSEventStreamEventFlags eventFlags[], const FSEventStreamEventId eventIds[]); -TYPEDEF: void* FSEventStreamCallback +! callback( +CALLBACK: void FSEventStreamCallback ( FSEventStreamRef streamRef, void* clientCallBackInfo, size_t numEvents, void* eventPaths, FSEventStreamEventFlags* eventFlags, FSEventStreamEventId* eventIds ) ; CONSTANT: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 7b454266f2..0b61274b22 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -115,7 +115,7 @@ PRIVATE> [ fds>> [ enable-all-callbacks ] each ] bi ; : timer-callback ( -- callback ) - "void" { "CFRunLoopTimerRef" "void*" } "cdecl" + void { CFRunLoopTimerRef void* } "cdecl" [ 2drop reset-run-loop yield ] alien-callback ; : init-thread-timer ( -- ) diff --git a/basis/core-text/core-text-tests.factor b/basis/core-text/core-text-tests.factor index a5cf69fdee..b6b54df7c3 100644 --- a/basis/core-text/core-text-tests.factor +++ b/basis/core-text/core-text-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: tools.test core-text core-text.fonts core-foundation core-foundation.dictionaries destructors arrays kernel generalizations -math accessors core-foundation.utilities combinators hashtables colors +locals math accessors core-foundation.utilities combinators hashtables colors colors.constants ; IN: core-text.tests @@ -18,10 +18,11 @@ IN: core-text.tests ] with-destructors ] unit-test -: test-typographic-bounds ( string font -- ? ) +:: test-typographic-bounds ( string font -- ? ) [ - test-font &CFRelease tuck COLOR: white &CFRelease - compute-line-metrics { + font test-font &CFRelease :> ctfont + string ctfont COLOR: white &CFRelease :> ctline + ctfont ctline compute-line-metrics { [ width>> float? ] [ ascent>> float? ] [ descent>> float? ] @@ -33,4 +34,4 @@ IN: core-text.tests [ t ] [ "Hello world" "Chicago" test-typographic-bounds ] unit-test -[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test \ No newline at end of file +[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test diff --git a/basis/core-text/core-text.factor b/basis/core-text/core-text.factor index d672815cbe..7af6792e79 100644 --- a/basis/core-text/core-text.factor +++ b/basis/core-text/core-text.factor @@ -112,35 +112,34 @@ TUPLE: line < disposable line metrics image loc dim ; [ line new-disposable - [let* | open-font [ font cache-font ] - line [ string open-font font foreground>> |CFRelease ] + font cache-font :> open-font + string open-font font foreground>> |CFRelease :> line - rect [ line line-rect ] - (loc) [ rect origin>> CGPoint>loc ] - (dim) [ rect size>> CGSize>dim ] - (ext) [ (loc) (dim) v+ ] - loc [ (loc) [ floor ] map ] - ext [ (loc) (dim) [ + ceiling ] 2map ] - dim [ ext loc [ - >integer 1 max ] 2map ] - metrics [ open-font line compute-line-metrics ] | + line line-rect :> rect + rect origin>> CGPoint>loc :> (loc) + rect size>> CGSize>dim :> (dim) + (loc) (dim) v+ :> (ext) + (loc) [ floor ] map :> loc + (loc) (dim) [ + ceiling ] 2map :> ext + ext loc [ - >integer 1 max ] 2map :> dim + open-font line compute-line-metrics :> metrics - line >>line + line >>line - metrics >>metrics + metrics >>metrics - dim [ - { - [ font dim fill-background ] - [ loc dim line string fill-selection-background ] - [ loc set-text-position ] - [ [ line ] dip CTLineDraw ] - } cleave - ] make-bitmap-image >>image + dim [ + { + [ font dim fill-background ] + [ loc dim line string fill-selection-background ] + [ loc set-text-position ] + [ [ line ] dip CTLineDraw ] + } cleave + ] make-bitmap-image >>image - metrics loc dim line-loc >>loc + metrics loc dim line-loc >>loc - metrics metrics>dim >>dim - ] + metrics metrics>dim >>dim ] with-destructors ; M: line dispose* line>> CFRelease ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index c411d97558..6723956780 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -107,6 +107,16 @@ scalar-rep ; { ulonglong-scalar-rep longlong-scalar-rep } } ?at drop ; +: widen-vector-rep ( rep -- rep' ) + { + { char-16-rep short-8-rep } + { short-8-rep int-4-rep } + { int-4-rep longlong-2-rep } + { uchar-16-rep ushort-8-rep } + { ushort-8-rep uint-4-rep } + { uint-4-rep ulonglong-2-rep } + } at ; + ! Register classes SINGLETONS: int-regs float-regs ; @@ -277,8 +287,10 @@ HOOK: %xor-vector cpu ( dst src1 src2 rep -- ) HOOK: %not-vector cpu ( dst src rep -- ) HOOK: %shl-vector cpu ( dst src1 src2 rep -- ) HOOK: %shr-vector cpu ( dst src1 src2 rep -- ) -HOOK: %horizontal-shl-vector cpu ( dst src1 src2 rep -- ) -HOOK: %horizontal-shr-vector cpu ( dst src1 src2 rep -- ) +HOOK: %shl-vector-imm cpu ( dst src1 src2 rep -- ) +HOOK: %shr-vector-imm cpu ( dst src1 src2 rep -- ) +HOOK: %horizontal-shl-vector-imm cpu ( dst src1 src2 rep -- ) +HOOK: %horizontal-shr-vector-imm cpu ( dst src1 src2 rep -- ) HOOK: %integer>scalar cpu ( dst src rep -- ) HOOK: %scalar>integer cpu ( dst src rep -- ) @@ -324,8 +336,10 @@ HOOK: %xor-vector-reps cpu ( -- reps ) HOOK: %not-vector-reps cpu ( -- reps ) HOOK: %shl-vector-reps cpu ( -- reps ) HOOK: %shr-vector-reps cpu ( -- reps ) -HOOK: %horizontal-shl-vector-reps cpu ( -- reps ) -HOOK: %horizontal-shr-vector-reps cpu ( -- reps ) +HOOK: %shl-vector-imm-reps cpu ( -- reps ) +HOOK: %shr-vector-imm-reps cpu ( -- reps ) +HOOK: %horizontal-shl-vector-imm-reps cpu ( -- reps ) +HOOK: %horizontal-shr-vector-imm-reps cpu ( -- reps ) M: object %zero-vector-reps { } ; M: object %fill-vector-reps { } ; @@ -366,13 +380,15 @@ M: object %xor-vector-reps { } ; M: object %not-vector-reps { } ; M: object %shl-vector-reps { } ; M: object %shr-vector-reps { } ; -M: object %horizontal-shl-vector-reps { } ; -M: object %horizontal-shr-vector-reps { } ; +M: object %shl-vector-imm-reps { } ; +M: object %shr-vector-imm-reps { } ; +M: object %horizontal-shl-vector-imm-reps { } ; +M: object %horizontal-shr-vector-imm-reps { } ; HOOK: %unbox-alien cpu ( dst src -- ) -HOOK: %unbox-any-c-ptr cpu ( dst src temp -- ) +HOOK: %unbox-any-c-ptr cpu ( dst src -- ) HOOK: %box-alien cpu ( dst src temp -- ) -HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 base-class -- ) +HOOK: %box-displaced-alien cpu ( dst displacement base temp base-class -- ) HOOK: %alien-unsigned-1 cpu ( dst src offset -- ) HOOK: %alien-unsigned-2 cpu ( dst src offset -- ) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index cd877cfafe..7e7de6d4bc 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -69,7 +69,7 @@ CONSTANT: rs-reg 14 [ 3 ds-reg 0 LWZ ds-reg dup 4 SUBI - 0 3 \ f tag-number CMPI + 0 3 \ f type-number CMPI 2 BEQ 0 B rc-relative-ppc-3 rt-xt jit-rel 0 B rc-relative-ppc-3 rt-xt jit-rel @@ -174,40 +174,15 @@ CONSTANT: rs-reg 14 [ load-tag ] pic-tag jit-define -! Hi-tag -[ - 3 4 MR - load-tag - 0 4 object tag-number tag-fixnum CMPI - 2 BNE - 4 3 object tag-number neg LWZ -] pic-hi-tag jit-define - ! Tuple [ 3 4 MR load-tag - 0 4 tuple tag-number tag-fixnum CMPI + 0 4 tuple type-number tag-fixnum CMPI 2 BNE - 4 3 tuple tag-number neg bootstrap-cell + LWZ + 4 3 tuple type-number neg bootstrap-cell + LWZ ] pic-tuple jit-define -! Hi-tag and tuple -[ - 3 4 MR - load-tag - ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple) - 0 4 BIN: 110 tag-fixnum CMPI - 5 BLT - ! Untag r3 - 3 3 0 0 31 tag-bits get - RLWINM - ! Set r4 to 0 for objects, and bootstrap-cell for tuples - 4 4 1 tag-fixnum ANDI - 4 4 1 SRAWI - ! Load header cell or tuple layout cell - 4 4 3 LWZX -] pic-hi-tag-tuple jit-define - [ 0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel ] pic-check-tag jit-define @@ -215,7 +190,7 @@ CONSTANT: rs-reg 14 [ 0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel 4 0 5 CMP -] pic-check jit-define +] pic-check-tuple jit-define [ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define @@ -224,8 +199,8 @@ CONSTANT: rs-reg 14 [ ! cache = ... 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel - ! key = class - 5 4 MR + ! key = hashcode(class) + 5 4 1 SRAWI ! key &= cache.length - 1 5 5 mega-cache-size get 1 - bootstrap-cell * ANDI ! cache += array-start-offset @@ -278,7 +253,7 @@ CONSTANT: rs-reg 14 [ 3 ds-reg 0 LWZ 4 ds-reg -4 LWZU - 3 3 1 SRAWI + 3 3 2 SRAWI 4 4 0 0 31 tag-bits get - RLWINM 4 3 3 LWZX 3 ds-reg 0 STW @@ -349,14 +324,6 @@ CONSTANT: rs-reg 14 3 ds-reg 4 STWU ] \ dupd define-sub-primitive -[ - 3 ds-reg 0 LWZ - 4 ds-reg -4 LWZ - 3 ds-reg 4 STWU - 4 ds-reg -4 STW - 3 ds-reg -8 STW -] \ tuck define-sub-primitive - [ 3 ds-reg 0 LWZ 4 ds-reg -4 LWZ @@ -399,7 +366,7 @@ CONSTANT: rs-reg 14 5 ds-reg -4 LWZU 5 0 4 CMP 2 swap execute( offset -- ) ! magic number - \ f tag-number 3 LI + \ f type-number 3 LI 3 ds-reg 0 STW ; : define-jit-compare ( insn word -- ) @@ -418,7 +385,7 @@ CONSTANT: rs-reg 14 4 ds-reg 0 LWZ 3 3 4 OR 3 3 tag-mask get ANDI - \ f tag-number 4 LI + \ f type-number 4 LI 0 3 0 CMPI 2 BNE 1 tag-fixnum 4 LI @@ -503,7 +470,7 @@ CONSTANT: rs-reg 14 [ 3 ds-reg 0 LWZ - 3 3 1 SRAWI + 3 3 2 SRAWI rs-reg 3 3 LWZX 3 ds-reg 0 STW ] \ get-local define-sub-primitive @@ -511,7 +478,7 @@ CONSTANT: rs-reg 14 [ 3 ds-reg 0 LWZ ds-reg ds-reg 4 SUBI - 3 3 1 SRAWI + 3 3 2 SRAWI rs-reg 3 rs-reg SUBF ] \ drop-locals define-sub-primitive diff --git a/basis/cpu/ppc/linux/bootstrap.factor b/basis/cpu/ppc/linux/bootstrap.factor index cf6517b664..a5250414ab 100644 --- a/basis/cpu/ppc/linux/bootstrap.factor +++ b/basis/cpu/ppc/linux/bootstrap.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser layouts system kernel ; +USING: parser layouts system kernel sequences ; IN: bootstrap.ppc : c-area-size ( -- n ) 10 bootstrap-cells ; : lr-save ( -- n ) bootstrap-cell ; -<< "vocab:cpu/ppc/bootstrap.factor" parse-file parsed >> +<< "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >> call diff --git a/basis/cpu/ppc/macosx/bootstrap.factor b/basis/cpu/ppc/macosx/bootstrap.factor index 0c383c2fb0..2aa0ddc4a2 100644 --- a/basis/cpu/ppc/macosx/bootstrap.factor +++ b/basis/cpu/ppc/macosx/bootstrap.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser layouts system kernel ; +USING: parser layouts system kernel sequences ; IN: bootstrap.ppc : c-area-size ( -- n ) 14 bootstrap-cells ; : lr-save ( -- n ) 2 bootstrap-cells ; -<< "vocab:cpu/ppc/bootstrap.factor" parse-file parsed >> +<< "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >> call diff --git a/basis/cpu/ppc/macosx/macosx.factor b/basis/cpu/ppc/macosx/macosx.factor index c742cf2ddc..152a3aa720 100644 --- a/basis/cpu/ppc/macosx/macosx.factor +++ b/basis/cpu/ppc/macosx/macosx.factor @@ -4,12 +4,6 @@ USING: accessors system kernel layouts alien.c-types cpu.architecture cpu.ppc ; IN: cpu.ppc.macosx -<< -4 "longlong" c-type (>>align) -4 "ulonglong" c-type (>>align) -4 "double" c-type (>>align) ->> - M: macosx reserved-area-size 6 cells ; M: macosx lr-save 2 cells ; diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 517aa7587d..a7eb3bb4a5 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -256,95 +256,108 @@ M: ppc %double>single-float FRSP ; M: ppc %unbox-alien ( dst src -- ) alien-offset LWZ ; -M:: ppc %unbox-any-c-ptr ( dst src temp -- ) +M:: ppc %unbox-any-c-ptr ( dst src -- ) [ - { "is-byte-array" "end" "start" } [ define-label ] each - ! Address is computed in dst + "end" define-label 0 dst LI - ! Load object into scratch-reg - scratch-reg src MR - ! We come back here with displaced aliens - "start" resolve-label ! Is the object f? - 0 scratch-reg \ f tag-number CMPI - ! If so, done + 0 src \ f type-number CMPI "end" get BEQ + ! Compute tag in dst register + dst src tag-mask get ANDI ! Is the object an alien? - 0 scratch-reg header-offset LWZ - 0 0 alien type-number tag-fixnum CMPI - "is-byte-array" get BNE - ! If so, load the offset - 0 scratch-reg alien-offset LWZ - ! Add it to address being computed - dst dst 0 ADD - ! Now recurse on the underlying alien - scratch-reg scratch-reg underlying-alien-offset LWZ - "start" get B - "is-byte-array" resolve-label - ! Add byte array address to address being computed - dst dst scratch-reg ADD - ! Add an offset to start of byte array's data area - dst dst byte-array-offset ADDI + 0 dst alien type-number CMPI + ! Add an offset to start of byte array's data + dst src byte-array-offset ADDI + "end" get BNE + ! If so, load the offset and add it to the address + dst src alien-offset LWZ "end" resolve-label ] with-scope ; -: alien@ ( n -- n' ) cells object tag-number - ; - -:: %allot-alien ( dst displacement base temp -- ) - dst 4 cells alien temp %allot - temp \ f tag-number %load-immediate - ! Store underlying-alien slot - base dst 1 alien@ STW - ! Store expired slot - temp dst 2 alien@ STW - ! Store offset - displacement dst 3 alien@ STW ; +: alien@ ( n -- n' ) cells alien type-number - ; M:: ppc %box-alien ( dst src temp -- ) [ "f" define-label - dst \ f tag-number %load-immediate + dst \ f type-number %load-immediate 0 src 0 CMPI "f" get BEQ - dst src temp temp %allot-alien + dst 5 cells alien temp %allot + temp \ f type-number %load-immediate + temp dst 1 alien@ STW + temp dst 2 alien@ STW + src dst 3 alien@ STW + src dst 4 alien@ STW "f" resolve-label ] with-scope ; -M:: ppc %box-displaced-alien ( dst displacement base displacement' base' base-class -- ) +M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- ) + ! This is ridiculous [ "end" define-label - "alloc" define-label - "simple-case" define-label + "not-f" define-label + "not-alien" define-label + ! If displacement is zero, return the base dst base MR 0 displacement 0 CMPI "end" get BEQ - ! Quickly use displacement' before its needed for real, as allot temporary - displacement' :> temp - dst 4 cells alien temp %allot - ! If base is already a displaced alien, unpack it - 0 base \ f tag-number CMPI - "simple-case" get BEQ - temp base header-offset LWZ - 0 temp alien type-number tag-fixnum CMPI - "simple-case" get BNE - ! displacement += base.displacement - temp base 3 alien@ LWZ - displacement' displacement temp ADD - ! base = base.base - base' base 1 alien@ LWZ - "alloc" get B - "simple-case" resolve-label - displacement' displacement MR - base' base MR - "alloc" resolve-label - ! Store underlying-alien slot - base' dst 1 alien@ STW - ! Store offset - displacement' dst 3 alien@ STW - ! Store expired slot (its ok to clobber displacement') - temp \ f tag-number %load-immediate + + ! Displacement is non-zero, we're going to be allocating a new + ! object + dst 5 cells alien temp %allot + + ! Set expired to f + temp \ f type-number %load-immediate temp dst 2 alien@ STW + + ! Is base f? + 0 base \ f type-number CMPI + "not-f" get BNE + + ! Yes, it is f. Fill in new object + base dst 1 alien@ STW + displacement dst 3 alien@ STW + displacement dst 4 alien@ STW + + "end" get B + + "not-f" resolve-label + + ! Check base type + temp base tag-mask get ANDI + + ! Is base an alien? + 0 temp alien type-number CMPI + "not-alien" get BNE + + ! Yes, it is an alien. Set new alien's base to base.base + temp base 1 alien@ LWZ + temp dst 1 alien@ STW + + ! Compute displacement + temp base 3 alien@ LWZ + temp temp displacement ADD + temp dst 3 alien@ STW + + ! Compute address + temp base 4 alien@ LWZ + temp temp displacement ADD + temp dst 4 alien@ STW + + ! We are done + "end" get B + + ! Is base a byte array? It has to be, by now... + "not-alien" resolve-label + + base dst 1 alien@ STW + displacement dst 3 alien@ STW + temp base byte-array-offset ADDI + temp temp displacement ADD + temp dst 4 alien@ STW + "end" resolve-label ] with-scope ; @@ -374,15 +387,15 @@ M: ppc %set-alien-double -rot STFD ; [ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ; :: inc-allot-ptr ( nursery-ptr allot-ptr n -- ) - scratch-reg allot-ptr n 8 align ADDI + scratch-reg allot-ptr n data-alignment get align ADDI scratch-reg nursery-ptr 0 STW ; :: store-header ( dst class -- ) - class type-number tag-fixnum scratch-reg LI + class type-number tag-header scratch-reg LI scratch-reg dst 0 STW ; : store-tagged ( dst tag -- ) - dupd tag-number ORI ; + dupd type-number ORI ; M:: ppc %allot ( dst size class nursery-ptr -- ) nursery-ptr dst load-allot-ptr @@ -460,7 +473,7 @@ M: ppc %epilogue ( n -- ) :: (%boolean) ( dst temp branch1 branch2 -- ) "end" define-label - dst \ f tag-number %load-immediate + dst \ f type-number %load-immediate "end" get branch1 execute( label -- ) branch2 [ "end" get branch2 execute( label -- ) ] when dst \ t %load-reference @@ -504,11 +517,11 @@ M: ppc %compare [ (%compare) ] 2dip %boolean ; M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ; M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- ) - src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> branch2 :> branch1 + src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 ) dst temp branch1 branch2 (%boolean) ; M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- ) - src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> branch2 :> branch1 + src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 ) dst temp branch1 branch2 (%boolean) ; :: %branch ( label cc -- ) @@ -534,11 +547,11 @@ M:: ppc %compare-imm-branch ( label src1 src2 cc -- ) branch2 [ label branch2 execute( label -- ) ] when ; inline M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- ) - src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> branch2 :> branch1 + src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 ) label branch1 branch2 (%branch) ; M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- ) - src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> branch2 :> branch1 + src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 ) label branch1 branch2 (%branch) ; : load-from-frame ( dst n rep -- ) @@ -742,14 +755,3 @@ USE: vocabs.loader } cond "complex-double" c-type t >>return-in-registers? drop - -[ - - [ alien-unsigned-4 c-bool> ] >>getter - [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter - 4 >>size - 4 >>align - "box_boolean" >>boxer - "to_boolean" >>unboxer - bool define-primitive-type -] with-compilation-unit diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index cff5c561c8..8867ca6597 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -11,9 +11,6 @@ cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 cpu.architecture ; IN: cpu.x86.32 -! We implement the FFI for Linux, OS X and Windows all at once. -! OS X requires that the stack be 16-byte aligned. - M: x86.32 machine-registers { { int-regs { EAX ECX EDX EBP EBX } } @@ -327,10 +324,4 @@ M: x86.32 dummy-fp-params? f ; ! Dreadful M: object flatten-value-type (flatten-int-type) ; -os windows? [ - cell longlong c-type (>>align) - cell ulonglong c-type (>>align) - 4 double c-type (>>align) -] unless - check-sse diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index c5f6975d33..f777040e86 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system cpu.x86.assembler cpu.x86.assembler.operands layouts -vocabs parser compiler.constants ; +vocabs parser compiler.constants sequences ; IN: bootstrap.x86 4 \ cell set @@ -21,7 +21,7 @@ IN: bootstrap.x86 : stack-reg ( -- reg ) ESP ; : ds-reg ( -- reg ) ESI ; : rs-reg ( -- reg ) EDI ; -: fixnum>slot@ ( -- ) temp0 1 SAR ; +: fixnum>slot@ ( -- ) temp0 2 SAR ; : rex-length ( -- n ) 0 ; [ @@ -35,5 +35,5 @@ IN: bootstrap.x86 0 JMP rc-relative rt-primitive jit-rel ] jit-primitive jit-define -<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >> +<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index b42a38b2d2..0fc029fdfe 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system layouts vocabs parser compiler.constants math -cpu.x86.assembler cpu.x86.assembler.operands ; +cpu.x86.assembler cpu.x86.assembler.operands sequences ; IN: bootstrap.x86 8 \ cell set @@ -18,7 +18,7 @@ IN: bootstrap.x86 : stack-reg ( -- reg ) RSP ; : ds-reg ( -- reg ) R14 ; : rs-reg ( -- reg ) R15 ; -: fixnum>slot@ ( -- ) ; +: fixnum>slot@ ( -- ) temp0 1 SAR ; : rex-length ( -- n ) 1 ; [ @@ -35,5 +35,5 @@ IN: bootstrap.x86 temp1 JMP ] jit-primitive jit-define -<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >> +<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call diff --git a/basis/cpu/x86/64/unix/bootstrap.factor b/basis/cpu/x86/64/unix/bootstrap.factor index 2ad3a721af..238fad984a 100644 --- a/basis/cpu/x86/64/unix/bootstrap.factor +++ b/basis/cpu/x86/64/unix/bootstrap.factor @@ -1,12 +1,13 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: bootstrap.image.private kernel namespaces system -cpu.x86.assembler cpu.x86.assembler.operands layouts vocabs parser ; +USING: bootstrap.image.private cpu.x86.assembler +cpu.x86.assembler.operands kernel layouts namespaces parser +sequences system vocabs ; IN: bootstrap.x86 : stack-frame-size ( -- n ) 4 bootstrap-cells ; : arg1 ( -- reg ) RDI ; : arg2 ( -- reg ) RSI ; -<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >> +<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >> call diff --git a/basis/cpu/x86/64/winnt/bootstrap.factor b/basis/cpu/x86/64/winnt/bootstrap.factor index 2dd3e889a5..2e3944fcaf 100644 --- a/basis/cpu/x86/64/winnt/bootstrap.factor +++ b/basis/cpu/x86/64/winnt/bootstrap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system -layouts vocabs parser cpu.x86.assembler +layouts vocabs parser sequences cpu.x86.assembler parser cpu.x86.assembler.operands ; IN: bootstrap.x86 @@ -9,5 +9,5 @@ IN: bootstrap.x86 : arg1 ( -- reg ) RCX ; : arg2 ( -- reg ) RDX ; -<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >> +<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >> call diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index 3ecd56bdd1..a398c6565c 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -24,9 +24,3 @@ M: x86.64 dummy-fp-params? t ; M: x86.64 temp-reg RAX ; -<< -longlong ptrdiff_t typedef -longlong intptr_t typedef -int c-type long define-primitive-type -uint c-type ulong define-primitive-type ->> diff --git a/basis/cpu/x86/assembler/operands/operands.factor b/basis/cpu/x86/assembler/operands/operands.factor index df49ae0a15..bd9a3f6cdd 100644 --- a/basis/cpu/x86/assembler/operands/operands.factor +++ b/basis/cpu/x86/assembler/operands/operands.factor @@ -65,7 +65,7 @@ M: indirect extended? base>> extended? ; ERROR: bad-index indirect ; : check-ESP ( indirect -- indirect ) - dup index>> { ESP RSP } memq? [ bad-index ] when ; + dup index>> { ESP RSP } member-eq? [ bad-index ] when ; : canonicalize ( indirect -- indirect ) #! Modify the indirect to work around certain addressing mode @@ -103,7 +103,7 @@ TUPLE: byte value ; C: byte : extended-8-bit-register? ( register -- ? ) - { SPL BPL SIL DIL } memq? ; + { SPL BPL SIL DIL } member-eq? ; : n-bit-version-of ( register n -- register' ) ! Certain 8-bit registers don't exist in 32-bit mode... @@ -115,4 +115,4 @@ C: byte : 16-bit-version-of ( register -- register' ) 16 n-bit-version-of ; : 32-bit-version-of ( register -- register' ) 32 n-bit-version-of ; : 64-bit-version-of ( register -- register' ) 64 n-bit-version-of ; -: native-version-of ( register -- register' ) cell-bits n-bit-version-of ; \ No newline at end of file +: native-version-of ( register -- register' ) cell-bits n-bit-version-of ; diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index fb94445f78..c993a1fdec 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: bootstrap.image.private kernel kernel.private namespaces system -layouts compiler.units math math.private compiler.constants vocabs -slots.private words locals.backend make sequences combinators arrays - cpu.x86.assembler cpu.x86.assembler.operands ; +USING: bootstrap.image.private compiler.constants +compiler.units cpu.x86.assembler cpu.x86.assembler.operands +kernel kernel.private layouts locals.backend make math +math.private namespaces sequences slots.private vocabs ; IN: bootstrap.x86 big-endian off @@ -60,7 +60,7 @@ big-endian off ! pop boolean ds-reg bootstrap-cell SUB ! compare boolean with f - temp0 \ f tag-number CMP + temp0 \ f type-number CMP ! jump to true branch if not equal 0 JNE rc-relative rt-xt jit-rel ! jump to false branch if equal @@ -154,7 +154,7 @@ big-endian off ! ! ! Polymorphic inline caches -! The PIC and megamorphic code stubs are not permitted to touch temp3. +! The PIC stubs are not permitted to touch temp3. ! Load a value from a stack position [ @@ -171,41 +171,15 @@ big-endian off ! The 'make' trick lets us compute the jump distance for the ! conditional branches there -! Hi-tag -[ - temp0 temp1 MOV - load-tag - temp1 object tag-number tag-fixnum CMP - [ temp1 temp0 object tag-number neg [+] MOV ] { } make - [ length JNE ] [ % ] bi -] pic-hi-tag jit-define - ! Tuple [ temp0 temp1 MOV load-tag - temp1 tuple tag-number tag-fixnum CMP - [ temp1 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make + temp1 tuple type-number tag-fixnum CMP + [ temp1 temp0 tuple type-number neg bootstrap-cell + [+] MOV ] { } make [ length JNE ] [ % ] bi ] pic-tuple jit-define -! Hi-tag and tuple -[ - temp0 temp1 MOV - load-tag - ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple) - temp1 BIN: 110 tag-fixnum CMP - [ - ! Untag temp0 - temp0 tag-mask get bitnot AND - ! Set temp1 to 0 for objects, and bootstrap-cell for tuples - temp1 1 tag-fixnum AND - bootstrap-cell 4 = [ temp1 1 SHR ] when - ! Load header cell or tuple layout cell - temp1 temp0 temp1 [+] MOV - ] [ ] make [ length JL ] [ % ] bi -] pic-hi-tag-tuple jit-define - [ temp1 HEX: ffffffff CMP rc-absolute rt-immediate jit-rel ] pic-check-tag jit-define @@ -213,7 +187,7 @@ big-endian off [ temp2 HEX: ffffffff MOV rc-absolute-cell rt-immediate jit-rel temp1 temp2 CMP -] pic-check jit-define +] pic-check-tuple jit-define [ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define @@ -222,9 +196,9 @@ big-endian off [ ! cache = ... temp0 0 MOV rc-absolute-cell rt-immediate jit-rel - ! key = class + ! key = hashcode(class) temp2 temp1 MOV - bootstrap-cell 8 = [ temp2 1 SHL ] when + bootstrap-cell 4 = [ temp2 1 SHR ] when ! key &= cache.length - 1 temp2 mega-cache-size get 1 - bootstrap-cell * AND ! cache += array-start-offset @@ -361,15 +335,6 @@ big-endian off ds-reg [] temp0 MOV ] \ dupd define-sub-primitive -[ - temp0 ds-reg [] MOV - temp1 ds-reg -1 bootstrap-cells [+] MOV - ds-reg bootstrap-cell ADD - ds-reg [] temp0 MOV - ds-reg -1 bootstrap-cells [+] temp1 MOV - ds-reg -2 bootstrap-cells [+] temp0 MOV -] \ tuck define-sub-primitive - [ temp0 ds-reg [] MOV temp1 ds-reg bootstrap-cell neg [+] MOV @@ -410,7 +375,7 @@ big-endian off t jit-literal temp3 0 MOV rc-absolute-cell rt-immediate jit-rel ! load f - temp1 \ f tag-number MOV + temp1 \ f type-number MOV ! load first value temp0 ds-reg [] MOV ! adjust stack pointer @@ -540,7 +505,7 @@ big-endian off ds-reg bootstrap-cell SUB temp0 ds-reg [] OR temp0 tag-mask get AND - temp0 \ f tag-number MOV + temp0 \ f type-number MOV temp1 1 tag-fixnum MOV temp0 temp1 CMOVE ds-reg [] temp0 MOV diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 1f5afffe5d..86006f843e 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -4,7 +4,7 @@ USING: accessors assocs alien alien.c-types arrays strings cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands cpu.x86.features cpu.x86.features.private cpu.architecture kernel kernel.private math memory namespaces make sequences words system -layouts combinators math.order fry locals compiler.constants +layouts combinators math.order math.vectors fry locals compiler.constants byte-arrays io macros quotations compiler compiler.units init vm compiler.cfg.registers compiler.cfg.instructions @@ -45,8 +45,7 @@ HOOK: extra-stack-space cpu ( stack-frame -- n ) : incr-stack-reg ( n -- ) dup 0 = [ drop ] [ stack-reg swap ADD ] if ; -: align-stack ( n -- n' ) - os macosx? cpu x86.64? or [ 16 align ] when ; +: align-stack ( n -- n' ) 16 align ; M: x86 stack-frame-size ( stack-frame -- i ) [ (stack-frame-size) ] @@ -141,20 +140,27 @@ M: x86 %not int-rep one-operand NOT ; M: x86 %neg int-rep one-operand NEG ; M: x86 %log2 BSR ; +! A bit of logic to avoid using MOVSS/MOVSD for reg-reg moves +! since this induces partial register stalls GENERIC: copy-register* ( dst src rep -- ) +GENERIC: copy-memory* ( dst src rep -- ) M: int-rep copy-register* drop MOV ; M: tagged-rep copy-register* drop MOV ; -M: float-rep copy-register* drop MOVSS ; -M: double-rep copy-register* drop MOVSD ; -M: float-4-rep copy-register* drop MOVUPS ; -M: double-2-rep copy-register* drop MOVUPD ; -M: vector-rep copy-register* drop MOVDQU ; +M: float-rep copy-register* drop MOVAPS ; +M: double-rep copy-register* drop MOVAPS ; +M: float-4-rep copy-register* drop MOVAPS ; +M: double-2-rep copy-register* drop MOVAPS ; +M: vector-rep copy-register* drop MOVDQA ; + +M: object copy-memory* copy-register* ; +M: float-rep copy-memory* drop MOVSS ; +M: double-rep copy-memory* drop MOVSD ; M: x86 %copy ( dst src rep -- ) 2over eq? [ 3drop ] [ [ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip - copy-register* + 2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if ] if ; M: x86 %fixnum-add ( label dst src1 src2 -- ) @@ -169,76 +175,109 @@ M: x86 %fixnum-mul ( label dst src1 src2 -- ) M: x86 %unbox-alien ( dst src -- ) alien-offset [+] MOV ; -M:: x86 %unbox-any-c-ptr ( dst src temp -- ) +M:: x86 %unbox-any-c-ptr ( dst src -- ) [ - { "is-byte-array" "end" "start" } [ define-label ] each - dst 0 MOV - temp src MOV - ! We come back here with displaced aliens - "start" resolve-label + "end" define-label + dst dst XOR ! Is the object f? - temp \ f tag-number CMP + src \ f type-number CMP "end" get JE + ! Compute tag in dst register + dst src MOV + dst tag-mask get AND ! Is the object an alien? - temp header-offset [+] alien type-number tag-fixnum CMP - "is-byte-array" get JNE - ! If so, load the offset and add it to the address - dst temp alien-offset [+] ADD - ! Now recurse on the underlying alien - temp temp underlying-alien-offset [+] MOV - "start" get JMP - "is-byte-array" resolve-label - ! Add byte array address to address being computed - dst temp ADD + dst alien type-number CMP ! Add an offset to start of byte array's data - dst byte-array-offset ADD + dst src byte-array-offset [+] LEA + "end" get JNE + ! If so, load the offset and add it to the address + dst src alien-offset [+] MOV "end" resolve-label ] with-scope ; -: alien@ ( reg n -- op ) cells alien tag-number - [+] ; - -:: %allot-alien ( dst displacement base temp -- ) - dst 4 cells alien temp %allot - dst 1 alien@ base MOV ! alien - dst 2 alien@ \ f tag-number MOV ! expired - dst 3 alien@ displacement MOV ! displacement - ; +: alien@ ( reg n -- op ) cells alien type-number - [+] ; M:: x86 %box-alien ( dst src temp -- ) [ "end" define-label - dst \ f tag-number MOV - src 0 CMP + dst \ f type-number MOV + src src TEST "end" get JE - dst src \ f tag-number temp %allot-alien + dst 5 cells alien temp %allot + dst 1 alien@ \ f type-number MOV ! base + dst 2 alien@ \ f type-number MOV ! expired + dst 3 alien@ src MOV ! displacement + dst 4 alien@ src MOV ! address "end" resolve-label ] with-scope ; -M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-class -- ) +M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- ) + ! This is ridiculous [ "end" define-label - "ok" define-label + "not-f" define-label + "not-alien" define-label + ! If displacement is zero, return the base dst base MOV - displacement 0 CMP + displacement displacement TEST "end" get JE - ! Quickly use displacement' before its needed for real, as allot temporary - dst 4 cells alien displacement' %allot - ! If base is already a displaced alien, unpack it - base' base MOV - displacement' displacement MOV - base \ f tag-number CMP - "ok" get JE - base header-offset [+] alien type-number tag-fixnum CMP - "ok" get JNE - ! displacement += base.displacement - displacement' base 3 alien@ ADD - ! base = base.base - base' base 1 alien@ MOV - "ok" resolve-label - dst 1 alien@ base' MOV ! alien - dst 2 alien@ \ f tag-number MOV ! expired - dst 3 alien@ displacement' MOV ! displacement + + ! Displacement is non-zero, we're going to be allocating a new + ! object + dst 5 cells alien temp %allot + + ! Set expired to f + dst 2 alien@ \ f type-number MOV + + ! Is base f? + base \ f type-number CMP + "not-f" get JNE + + ! Yes, it is f. Fill in new object + dst 1 alien@ base MOV + dst 3 alien@ displacement MOV + dst 4 alien@ displacement MOV + + "end" get JMP + + "not-f" resolve-label + + ! Check base type + temp base MOV + temp tag-mask get AND + + ! Is base an alien? + temp alien type-number CMP + "not-alien" get JNE + + ! Yes, it is an alien. Set new alien's base to base.base + temp base 1 alien@ MOV + dst 1 alien@ temp MOV + + ! Compute displacement + temp base 3 alien@ MOV + temp displacement ADD + dst 3 alien@ temp MOV + + ! Compute address + temp base 4 alien@ MOV + temp displacement ADD + dst 4 alien@ temp MOV + + ! We are done + "end" get JMP + + ! Is base a byte array? It has to be, by now... + "not-alien" resolve-label + + dst 1 alien@ base MOV + dst 3 alien@ displacement MOV + temp base MOV + temp byte-array-offset ADD + temp displacement ADD + dst 4 alien@ temp MOV + "end" resolve-label ] with-scope ; @@ -254,7 +293,7 @@ CONSTANT: have-byte-regs { EAX ECX EDX EBX } M: x86.32 has-small-reg? { - { 8 [ have-byte-regs memq? ] } + { 8 [ have-byte-regs member-eq? ] } { 16 [ drop t ] } { 32 [ drop t ] } } case ; @@ -264,7 +303,7 @@ M: x86.64 has-small-reg? 2drop t ; : small-reg-that-isn't ( exclude -- reg' ) [ have-byte-regs ] dip [ native-version-of ] map - '[ _ memq? not ] find nip ; + '[ _ member-eq? not ] find nip ; : with-save/restore ( reg quot -- ) [ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline @@ -356,7 +395,7 @@ M: x86 %set-alien-float [ [+] ] dip MOVSS ; M: x86 %set-alien-double [ [+] ] dip MOVSD ; M: x86 %set-alien-vector [ [+] ] 2dip %copy ; -: shift-count? ( reg -- ? ) { ECX RCX } memq? ; +: shift-count? ( reg -- ? ) { ECX RCX } member-eq? ; :: emit-shift ( dst src quot -- ) src shift-count? [ @@ -388,13 +427,13 @@ M: x86 %vm-field-ptr ( dst field -- ) [ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ; : inc-allot-ptr ( nursery-ptr n -- ) - [ [] ] dip 8 align ADD ; + [ [] ] dip data-alignment get align ADD ; : store-header ( temp class -- ) - [ [] ] [ type-number tag-fixnum ] bi* MOV ; + [ [] ] [ type-number tag-header ] bi* MOV ; : store-tagged ( dst tag -- ) - tag-number OR ; + type-number OR ; M:: x86 %allot ( dst size class nursery-ptr -- ) nursery-ptr dst load-allot-ptr @@ -436,7 +475,7 @@ M: x86 %alien-global ( dst symbol library -- ) M: x86 %epilogue ( n -- ) cell - incr-stack-reg ; :: %boolean ( dst temp word -- ) - dst \ f tag-number MOV + dst \ f type-number MOV temp 0 MOV \ t rc-absolute-cell rel-immediate dst temp word execute ; inline @@ -481,10 +520,13 @@ M: x86 %min-float double-rep two-operand MINSD ; M: x86 %max-float double-rep two-operand MAXSD ; M: x86 %sqrt SQRTSD ; -M: x86 %single>double-float CVTSS2SD ; -M: x86 %double>single-float CVTSD2SS ; +: %clear-unless-in-place ( dst src -- ) + over = [ drop ] [ dup XORPS ] if ; -M: x86 %integer>float CVTSI2SD ; +M: x86 %single>double-float [ %clear-unless-in-place ] [ CVTSS2SD ] 2bi ; +M: x86 %double>single-float [ %clear-unless-in-place ] [ CVTSD2SS ] 2bi ; + +M: x86 %integer>float [ drop dup XORPS ] [ CVTSI2SD ] 2bi ; M: x86 %float>integer CVTTSD2SI ; : %cmov-float= ( dst src -- ) @@ -583,7 +625,7 @@ M: x86 %alien-vector-reps M: x86 %zero-vector { - { double-2-rep [ dup XORPD ] } + { double-2-rep [ dup XORPS ] } { float-4-rep [ dup XORPS ] } [ drop dup PXOR ] } case ; @@ -596,7 +638,7 @@ M: x86 %zero-vector-reps M: x86 %fill-vector { - { double-2-rep [ dup [ XORPD ] [ CMPEQPD ] 2bi ] } + { double-2-rep [ dup [ XORPS ] [ CMPEQPS ] 2bi ] } { float-4-rep [ dup [ XORPS ] [ CMPEQPS ] 2bi ] } [ drop dup PCMPEQB ] } case ; @@ -671,7 +713,7 @@ M:: x86 %gather-vector-2 ( dst src1 src2 rep -- ) rep unsign-rep { { double-2-rep [ dst src1 double-2-rep %copy - dst src2 UNPCKLPD + dst src2 MOVLHPS ] } { longlong-2-rep [ dst src1 longlong-2-rep %copy @@ -684,14 +726,6 @@ M: x86 %gather-vector-2-reps { sse2? { double-2-rep longlong-2-rep ulonglong-2-rep } } } available-reps ; -: double-2-shuffle ( dst shuffle -- ) - { - { { 0 1 } [ drop ] } - { { 0 0 } [ dup UNPCKLPD ] } - { { 1 1 } [ dup UNPCKHPD ] } - [ dupd SHUFPD ] - } case ; - : sse1-float-4-shuffle ( dst shuffle -- ) { { { 0 1 2 3 } [ drop ] } @@ -724,10 +758,13 @@ M: x86 %gather-vector-2-reps : longlong-2-shuffle ( dst shuffle -- ) first2 [ 2 * dup 1 + ] bi@ 4array int-4-shuffle ; +: >float-4-shuffle ( double-2-shuffle -- float-4-shuffle ) + [ 2 * { 0 1 } n+v ] map concat ; + M:: x86 %shuffle-vector-imm ( dst src shuffle rep -- ) dst src rep %copy dst shuffle rep unsign-rep { - { double-2-rep [ double-2-shuffle ] } + { double-2-rep [ >float-4-shuffle float-4-shuffle ] } { float-4-rep [ float-4-shuffle ] } { int-4-rep [ int-4-shuffle ] } { longlong-2-rep [ longlong-2-shuffle ] } @@ -750,7 +787,7 @@ M: x86 %shuffle-vector-reps M: x86 %merge-vector-head [ two-operand ] keep unsign-rep { - { double-2-rep [ UNPCKLPD ] } + { double-2-rep [ MOVLHPS ] } { float-4-rep [ UNPCKLPS ] } { longlong-2-rep [ PUNPCKLQDQ ] } { int-4-rep [ PUNPCKLDQ ] } @@ -802,8 +839,8 @@ M: x86 %unsigned-pack-vector-reps M: x86 %tail>head-vector ( dst src rep -- ) dup { - { float-4-rep [ drop MOVHLPS ] } - { double-2-rep [ [ %copy ] [ drop UNPCKHPD ] 3bi ] } + { float-4-rep [ drop UNPCKHPD ] } + { double-2-rep [ drop UNPCKHPD ] } [ drop [ %copy ] [ drop PUNPCKHQDQ ] 3bi ] } case ; @@ -888,12 +925,12 @@ M: x86 %compare-vector ( dst src1 src2 rep cc -- ) { { sse? { float-4-rep } } { sse2? { double-2-rep char-16-rep short-8-rep int-4-rep } } - { sse4.1? { longlong-2-rep } } + { sse4.2? { longlong-2-rep } } } available-reps ; M: x86 %compare-vector-reps { - { [ dup { cc= cc/= } memq? ] [ drop %compare-vector-eq-reps ] } + { [ dup { cc= cc/= cc/<>= cc<>= } member-eq? ] [ drop %compare-vector-eq-reps ] } [ drop %compare-vector-ord-reps ] } cond ; @@ -942,7 +979,7 @@ M: x86 %compare-vector-ccs : %move-vector-mask ( dst src rep -- mask ) { - { double-2-rep [ MOVMSKPD HEX: 3 ] } + { double-2-rep [ MOVMSKPS HEX: f ] } { float-4-rep [ MOVMSKPS HEX: f ] } [ drop PMOVMSKB HEX: ffff ] } case ; @@ -1098,7 +1135,7 @@ M: x86 %min-vector ( dst src1 src2 rep -- ) M: x86 %min-vector-reps { { sse? { float-4-rep } } - { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } } + { sse2? { uchar-16-rep short-8-rep double-2-rep } } { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } } } available-reps ; @@ -1118,7 +1155,7 @@ M: x86 %max-vector ( dst src1 src2 rep -- ) M: x86 %max-vector-reps { { sse? { float-4-rep } } - { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } } + { sse2? { uchar-16-rep short-8-rep double-2-rep } } { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } } } available-reps ; @@ -1155,18 +1192,18 @@ M: x86 %horizontal-add-vector-reps { sse3? { float-4-rep double-2-rep } } } available-reps ; -M: x86 %horizontal-shl-vector ( dst src1 src2 rep -- ) +M: x86 %horizontal-shl-vector-imm ( dst src1 src2 rep -- ) two-operand PSLLDQ ; -M: x86 %horizontal-shl-vector-reps +M: x86 %horizontal-shl-vector-imm-reps { { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } } available-reps ; -M: x86 %horizontal-shr-vector ( dst src1 src2 rep -- ) +M: x86 %horizontal-shr-vector-imm ( dst src1 src2 rep -- ) two-operand PSRLDQ ; -M: x86 %horizontal-shr-vector-reps +M: x86 %horizontal-shr-vector-imm-reps { { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } } available-reps ; @@ -1199,7 +1236,7 @@ M: x86 %and-vector ( dst src1 src2 rep -- ) [ two-operand ] keep { { float-4-rep [ ANDPS ] } - { double-2-rep [ ANDPD ] } + { double-2-rep [ ANDPS ] } [ drop PAND ] } case ; @@ -1213,7 +1250,7 @@ M: x86 %andn-vector ( dst src1 src2 rep -- ) [ two-operand ] keep { { float-4-rep [ ANDNPS ] } - { double-2-rep [ ANDNPD ] } + { double-2-rep [ ANDNPS ] } [ drop PANDN ] } case ; @@ -1227,7 +1264,7 @@ M: x86 %or-vector ( dst src1 src2 rep -- ) [ two-operand ] keep { { float-4-rep [ ORPS ] } - { double-2-rep [ ORPD ] } + { double-2-rep [ ORPS ] } [ drop POR ] } case ; @@ -1241,7 +1278,7 @@ M: x86 %xor-vector ( dst src1 src2 rep -- ) [ two-operand ] keep { { float-4-rep [ XORPS ] } - { double-2-rep [ XORPD ] } + { double-2-rep [ XORPS ] } [ drop PXOR ] } case ; @@ -1282,6 +1319,11 @@ M: x86 %shr-vector-reps { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep ulonglong-2-rep } } } available-reps ; +M: x86 %shl-vector-imm %shl-vector ; +M: x86 %shl-vector-imm-reps %shl-vector-reps ; +M: x86 %shr-vector-imm %shr-vector ; +M: x86 %shr-vector-imm-reps %shr-vector-reps ; + : scalar-sized-reg ( reg rep -- reg' ) rep-size 8 * n-bit-version-of ; diff --git a/basis/csv/csv-tests.factor b/basis/csv/csv-tests.factor index 6ba8e2d5b8..829637b4aa 100644 --- a/basis/csv/csv-tests.factor +++ b/basis/csv/csv-tests.factor @@ -70,11 +70,12 @@ IN: csv.tests "can write csv too!" [ "foo1,bar1\nfoo2,bar2\n" ] -[ { { "foo1" "bar1" } { "foo2" "bar2" } } tuck write-csv >string ] named-unit-test +[ { { "foo1" "bar1" } { "foo2" "bar2" } } [ write-csv ] keep >string ] named-unit-test + "escapes quotes commas and newlines when writing" [ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ] -[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } tuck write-csv >string ] named-unit-test ! " +[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } [ write-csv ] keep >string ] named-unit-test ! " [ { { "writing" "some" "csv" "tests" } } ] [ diff --git a/basis/db/sqlite/ffi/ffi.factor b/basis/db/sqlite/ffi/ffi.factor index 61394391a0..c180df9bf5 100644 --- a/basis/db/sqlite/ffi/ffi.factor +++ b/basis/db/sqlite/ffi/ffi.factor @@ -99,8 +99,8 @@ CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 -TYPEDEF: void sqlite3 -TYPEDEF: void sqlite3_stmt +TYPEDEF: void* sqlite3* +TYPEDEF: void* sqlite3_stmt* TYPEDEF: longlong sqlite3_int64 TYPEDEF: ulonglong sqlite3_uint64 @@ -120,8 +120,8 @@ FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ; ! Bind the same function as above, but for unsigned 64bit integers : sqlite3-bind-uint64 ( pStmt index in64 -- int ) - "int" "sqlite" "sqlite3_bind_int64" - { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ; + int "sqlite" "sqlite3_bind_int64" + { sqlite3_stmt* int sqlite3_uint64 } alien-invoke ; FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ; FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ; FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ; @@ -134,8 +134,8 @@ FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ; ! Bind the same function as above, but for unsigned 64bit integers : sqlite3-column-uint64 ( pStmt col -- uint64 ) - "sqlite3_uint64" "sqlite" "sqlite3_column_int64" - { "sqlite3_stmt*" "int" } alien-invoke ; + sqlite3_uint64 "sqlite" "sqlite3_column_int64" + { sqlite3_stmt* int } alien-invoke ; FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ; diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index ffcbec70d0..8d26d3b098 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -4,7 +4,7 @@ USING: alien arrays assocs classes compiler db hashtables io.files kernel math math.parser namespaces prettyprint fry sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators -math.intervals io nmake accessors vectors math.ranges random +math.intervals io locals nmake accessors vectors math.ranges random math.bitwise db.queries destructors db.tuples.private interpolate io.streams.string make db.private sequences.deep db.errors.sqlite ; @@ -85,12 +85,11 @@ M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array ) nip [ key>> ] [ value>> ] [ type>> ] tri ; -M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array ) - tuck - [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi - rot set-slot-named - [ [ key>> ] [ type>> ] bi ] dip - swap ; +M:: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array ) + generate-bind generator-singleton>> eval-generator :> obj + generate-bind slot-name>> :> name + obj name tuple set-slot-named + generate-bind key>> obj generate-bind type>> ; M: sqlite-statement bind-tuple ( tuple statement -- ) [ diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor index 87e70d69e7..4bcd9c5b78 100644 --- a/basis/debugger/debugger-docs.factor +++ b/basis/debugger/debugger-docs.factor @@ -129,9 +129,6 @@ HELP: c-string-error. HELP: ffi-error. { $error-description "Thrown by " { $link dlopen } " and " { $link dlsym } " if a problem occurs while loading a native library or looking up a symbol. See " { $link "alien" } "." } ; -HELP: heap-scan-error. -{ $error-description "Thrown if " { $link next-object } " is called outside of a " { $link begin-scan } "/" { $link end-scan } " pair." } ; - HELP: undefined-symbol-error. { $error-description "Thrown if a previously-compiled " { $link alien-invoke } " call refers to a native library symbol which no longer exists." } ; diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 4888896866..5c76216c4f 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -8,21 +8,27 @@ continuations.private combinators generic.math classes.builtin classes compiler.units generic.standard generic.single vocabs init kernel.private io.encodings accessors math.order destructors source-files parser classes.tuple.parser effects.parser lexer -generic.parser strings.parser vocabs.loader vocabs.parser see +generic.parser strings.parser vocabs.loader vocabs.parser source-files.errors ; IN: debugger -GENERIC: error. ( error -- ) GENERIC: error-help ( error -- topic ) -M: object error. . ; - M: object error-help drop f ; M: tuple error-help class ; +M: source-file-error error-help error>> error-help ; + +GENERIC: error. ( error -- ) + +M: object error. short. ; + M: string error. print ; +: traceback-link. ( continuation -- ) + "[" write [ "Traceback" ] dip write-object "]" print ; + : :s ( -- ) error-continuation get data>> stack. ; @@ -100,9 +106,6 @@ HOOK: signal-error. os ( obj -- ) : ffi-error. ( obj -- ) "FFI error" print drop ; -: heap-scan-error. ( obj -- ) - "Cannot do next-object outside begin/end-scan" print drop ; - : undefined-symbol-error. ( obj -- ) "The image refers to a library or symbol that was not found at load time" print drop ; @@ -145,14 +148,13 @@ PREDICATE: vm-error < array { 6 [ array-size-error. ] } { 7 [ c-string-error. ] } { 8 [ ffi-error. ] } - { 9 [ heap-scan-error. ] } - { 10 [ undefined-symbol-error. ] } - { 11 [ datastack-underflow. ] } - { 12 [ datastack-overflow. ] } - { 13 [ retainstack-underflow. ] } - { 14 [ retainstack-overflow. ] } - { 15 [ memory-error. ] } - { 16 [ fp-trap-error. ] } + { 9 [ undefined-symbol-error. ] } + { 10 [ datastack-underflow. ] } + { 11 [ datastack-overflow. ] } + { 12 [ retainstack-underflow. ] } + { 13 [ retainstack-overflow. ] } + { 14 [ memory-error. ] } + { 15 [ fp-trap-error. ] } } ; inline M: vm-error summary drop "VM error" ; @@ -331,6 +333,8 @@ M: not-found-in-roots summary drop "Cannot resolve vocab: path" ; M: wrong-values summary drop "Quotation called with wrong stack effect" ; +M: stack-effect-omits-dashes summary drop "Stack effect must contain “--”" ; + { { [ os windows? ] [ "debugger.windows" require ] } { [ os unix? ] [ "debugger.unix" require ] } diff --git a/basis/debugger/windows/windows.factor b/basis/debugger/windows/windows.factor old mode 100644 new mode 100755 index 1f4b8fb0ac..319f100e16 --- a/basis/debugger/windows/windows.factor +++ b/basis/debugger/windows/windows.factor @@ -1,6 +1,42 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: debugger io prettyprint sequences system ; +USING: assocs debugger io kernel literals math.parser namespaces +prettyprint sequences system windows.kernel32 ; IN: debugger.windows -M: windows signal-error. "Windows exception #" write third .h ; \ No newline at end of file +CONSTANT: seh-names + H{ + { $ STATUS_GUARD_PAGE_VIOLATION "STATUS_GUARD_PAGE_VIOLATION" } + { $ STATUS_DATATYPE_MISALIGNMENT "STATUS_DATATYPE_MISALIGNMENT" } + { $ STATUS_BREAKPOINT "STATUS_BREAKPOINT" } + { $ STATUS_SINGLE_STEP "STATUS_SINGLE_STEP" } + { $ STATUS_ACCESS_VIOLATION "STATUS_ACCESS_VIOLATION" } + { $ STATUS_IN_PAGE_ERROR "STATUS_IN_PAGE_ERROR" } + { $ STATUS_INVALID_HANDLE "STATUS_INVALID_HANDLE" } + { $ STATUS_NO_MEMORY "STATUS_NO_MEMORY" } + { $ STATUS_ILLEGAL_INSTRUCTION "STATUS_ILLEGAL_INSTRUCTION" } + { $ STATUS_NONCONTINUABLE_EXCEPTION "STATUS_NONCONTINUABLE_EXCEPTION" } + { $ STATUS_INVALID_DISPOSITION "STATUS_INVALID_DISPOSITION" } + { $ STATUS_ARRAY_BOUNDS_EXCEEDED "STATUS_ARRAY_BOUNDS_EXCEEDED" } + { $ STATUS_FLOAT_DENORMAL_OPERAND "STATUS_FLOAT_DENORMAL_OPERAND" } + { $ STATUS_FLOAT_DIVIDE_BY_ZERO "STATUS_FLOAT_DIVIDE_BY_ZERO" } + { $ STATUS_FLOAT_INEXACT_RESULT "STATUS_FLOAT_INEXACT_RESULT" } + { $ STATUS_FLOAT_INVALID_OPERATION "STATUS_FLOAT_INVALID_OPERATION" } + { $ STATUS_FLOAT_OVERFLOW "STATUS_FLOAT_OVERFLOW" } + { $ STATUS_FLOAT_STACK_CHECK "STATUS_FLOAT_STACK_CHECK" } + { $ STATUS_FLOAT_UNDERFLOW "STATUS_FLOAT_UNDERFLOW" } + { $ STATUS_INTEGER_DIVIDE_BY_ZERO "STATUS_INTEGER_DIVIDE_BY_ZERO" } + { $ STATUS_INTEGER_OVERFLOW "STATUS_INTEGER_OVERFLOW" } + { $ STATUS_PRIVILEGED_INSTRUCTION "STATUS_PRIVILEGED_INSTRUCTION" } + { $ STATUS_STACK_OVERFLOW "STATUS_STACK_OVERFLOW" } + { $ STATUS_CONTROL_C_EXIT "STATUS_CONTROL_C_EXIT" } + { $ STATUS_FLOAT_MULTIPLE_FAULTS "STATUS_FLOAT_MULTIPLE_FAULTS" } + { $ STATUS_FLOAT_MULTIPLE_TRAPS "STATUS_FLOAT_MULTIPLE_TRAPS" } + } + +: seh-name. ( n -- ) + seh-names at [ " (" ")" surround write ] when* ; + +M: windows signal-error. + "Windows exception 0x" write + third [ >hex write ] [ seh-name. ] bi nl ; diff --git a/basis/delegate/delegate-docs.factor b/basis/delegate/delegate-docs.factor index 4ce3776277..d4867714d3 100644 --- a/basis/delegate/delegate-docs.factor +++ b/basis/delegate/delegate-docs.factor @@ -2,7 +2,7 @@ USING: help.syntax help.markup delegate.private ; IN: delegate HELP: define-protocol -{ $values { "wordlist" "a sequence of words" } { "protocol" "a word for the new protocol" } } +{ $values { "protocol" "a word for the new protocol" } { "wordlist" "a sequence of words" } } { $description "Defines a symbol as a protocol." } { $notes "Usually, " { $link POSTPONE: PROTOCOL: } " should be used instead. This is only for runtime use." } ; diff --git a/basis/documents/documents-docs.factor b/basis/documents/documents-docs.factor index 850c68fd9d..a4e02009df 100644 --- a/basis/documents/documents-docs.factor +++ b/basis/documents/documents-docs.factor @@ -12,11 +12,11 @@ HELP: +line { $description "Adds an integer to the line number of a line/column pair." } ; HELP: =col -{ $values { "loc" "a pair of integers" } { "n" integer } { "newloc" "a pair of integers" } } +{ $values { "n" integer } { "loc" "a pair of integers" } { "newloc" "a pair of integers" } } { $description "Sets the column number of a line/column pair." } ; HELP: =line -{ $values { "loc" "a pair of integers" } { "n" integer } { "newloc" "a pair of integers" } } +{ $values { "n" integer } { "loc" "a pair of integers" } { "newloc" "a pair of integers" } } { $description "Sets the line number of a line/column pair." } ; HELP: lines-equal? diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor index b05c86c365..aef4f4de78 100644 --- a/basis/documents/documents.factor +++ b/basis/documents/documents.factor @@ -34,7 +34,7 @@ TUPLE: document < model locs undos redos inside-undo? ; : add-loc ( loc document -- ) locs>> push ; -: remove-loc ( loc document -- ) locs>> delete ; +: remove-loc ( loc document -- ) locs>> remove! drop ; : update-locs ( loc document -- ) locs>> [ set-model ] with each ; diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index 4a6dd9b5be..feb19af040 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -28,7 +28,7 @@ SYMBOL: edit-hook require ; : edit-location ( file line -- ) - [ (normalize-path) ] dip edit-hook get-global + [ absolute-path ] dip edit-hook get-global [ call( file line -- ) ] [ no-edit-hook edit-location ] if* ; ERROR: cannot-find-source definition ; diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index 2a1ac85de0..5795438570 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -114,8 +114,8 @@ DEFER: (parse-paragraph) :: (take-until) ( state delimiter accum -- string/f state' ) state empty? [ accum "\n" join f ] [ - state unclip-slice :> first :> rest - first delimiter split1 :> after :> before + state unclip-slice :> ( rest first ) + first delimiter split1 :> ( before after ) before accum push after [ accum "\n" join diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor index 13b9e61632..b3d2ff296e 100644 --- a/basis/fry/fry-docs.factor +++ b/basis/fry/fry-docs.factor @@ -2,17 +2,20 @@ USING: help.markup help.syntax quotations kernel ; IN: fry HELP: _ -{ $description "Fry specifier. Inserts a literal value into the fried quotation." } ; +{ $description "Fry specifier. Inserts a literal value into the fried quotation." } +{ $examples "See " { $link "fry.examples" } "." } ; HELP: @ -{ $description "Fry specifier. Splices a quotation into the fried quotation." } ; +{ $description "Fry specifier. Splices a quotation into the fried quotation." } +{ $examples "See " { $link "fry.examples" } "." } ; HELP: fry { $values { "quot" quotation } { "quot'" quotation } } { $description "Outputs a quotation that when called, fries " { $snippet "quot" } " by taking values from the stack and substituting them in." } { $notes "This word is used to implement " { $link POSTPONE: '[ } "; the following two lines are equivalent:" { $code "[ X ] fry call" "'[ X ]" } -} ; +} +{ $examples "See " { $link "fry.examples" } "." } ; HELP: '[ { $syntax "'[ code... ]" } @@ -59,7 +62,6 @@ $nl { { $link literalize } { $snippet ": literalize '[ _ ] ;" } } { { $link curry } { $snippet ": curry '[ _ @ ] ;" } } { { $link compose } { $snippet ": compose '[ @ @ ] ;" } } - { { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } } } ; ARTICLE: "fry.philosophy" "Fried quotation philosophy" @@ -68,10 +70,10 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy" "'[ [ _ key? ] all? ] filter" "[ [ key? ] curry all? ] curry filter" } -"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a “let” form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:" +"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a " { $snippet "[| | ]" } " form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:" { $code "'[ 3 _ + 4 _ / ]" - "[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]" + "[| a b | 3 a + 4 b / ]" } ; ARTICLE: "fry" "Fried quotations" diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor index 549db25e09..10d9b282ad 100644 --- a/basis/fry/fry-tests.factor +++ b/basis/fry/fry-tests.factor @@ -1,18 +1,41 @@ +! (c)2009 Slava Pestov, Eduardo Cavazos, Joe Groff bsd license USING: fry tools.test math prettyprint kernel io arrays sequences eval accessors ; IN: fry.tests +SYMBOLS: a b c d e f g h ; + +[ [ 1 ] ] [ 1 '[ _ ] ] unit-test +[ [ 1 ] ] [ [ 1 ] '[ @ ] ] unit-test +[ [ 1 2 ] ] [ [ 1 ] [ 2 ] '[ @ @ ] ] unit-test + +[ [ 1 2 a ] ] [ 1 2 '[ _ _ a ] ] unit-test +[ [ 1 2 ] ] [ 1 2 '[ _ _ ] ] unit-test +[ [ a 1 2 ] ] [ 1 2 '[ a _ _ ] ] unit-test +[ [ 1 2 a ] ] [ [ 1 ] [ 2 ] '[ @ @ a ] ] unit-test +[ [ 1 a 2 b ] ] [ 1 2 '[ _ a _ b ] ] unit-test +[ [ 1 a 2 b ] ] [ 1 [ 2 ] '[ _ a @ b ] ] unit-test +[ [ a 1 b ] ] [ 1 '[ a _ b ] ] unit-test + +[ [ a 1 b ] ] [ [ 1 ] '[ a @ b ] ] unit-test +[ [ a 1 2 ] ] [ [ 1 ] [ 2 ] '[ a @ @ ] ] unit-test + +[ [ a [ 1 ] b ] ] [ 1 '[ a [ _ ] b ] ] unit-test +[ [ a 1 b [ c 2 d ] e 3 f ] ] [ 1 2 3 '[ a _ b [ c _ d ] e _ f ] ] unit-test +[ [ a 1 b [ c 2 d [ e 3 f ] ] g 4 h ] ] [ 1 2 3 4 '[ a _ b [ c _ d [ e _ f ] ] g _ h ] ] unit-test +[ [ a 1 b [ [ c 2 d ] e 3 f ] g 4 h ] ] [ 1 2 3 4 '[ a _ b [ [ c _ d ] e _ f ] g _ h ] ] unit-test + [ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test [ [ 1 3 + ] ] [ 1 3 '[ _ _ + ] ] unit-test -[ [ 1 [ + ] call ] ] [ 1 [ + ] '[ _ @ ] ] unit-test +[ [ 1 + ] ] [ 1 [ + ] '[ _ @ ] ] unit-test -[ [ 1 [ + ] call . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test +[ [ 1 + . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test -[ [ [ + ] [ - ] [ call ] dip call ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test +[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test -[ [ "a" "b" [ write ] dip print ] ] +[ [ "a" write "b" print ] ] [ "a" "b" '[ _ write _ print ] ] unit-test [ 1/2 ] [ diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor index fd029cc329..931397e933 100644 --- a/basis/fry/fry.factor +++ b/basis/fry/fry.factor @@ -1,7 +1,6 @@ -! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences combinators parser splitting math -quotations arrays make words locals.backend summary sets ; +! (c)2009 Slava Pestov, Eduardo Cavazos, Joe Groff bsd license +USING: accessors combinators kernel locals.backend math parser +quotations sequences sets splitting words ; IN: fry : _ ( -- * ) "Only valid inside a fry" throw ; @@ -9,48 +8,138 @@ IN: fry ERROR: >r/r>-in-fry-error ; +GENERIC: fry ( quot -- quot' ) + ] - } case ; - -M: >r/r>-in-fry-error summary - drop - "Explicit retain stack manipulation is not permitted in fried quotations" ; - : check-fry ( quot -- quot ) dup { load-local load-locals get-local drop-locals } intersect [ >r/r>-in-fry-error ] unless-empty ; -PREDICATE: fry-specifier < word { _ @ } memq? ; +PREDICATE: fry-specifier < word { _ @ } member-eq? ; GENERIC: count-inputs ( quot -- n ) -M: callable count-inputs [ count-inputs ] sigma ; +M: callable count-inputs [ count-inputs ] map-sum ; M: fry-specifier count-inputs drop 1 ; M: object count-inputs drop 0 ; -GENERIC: deep-fry ( obj -- ) +MIXIN: fried +PREDICATE: fried-callable < callable + count-inputs 0 > ; +INSTANCE: fried-callable fried -: shallow-fry ( quot -- quot' curry# ) - check-fry - [ [ deep-fry ] each ] [ ] make - [ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat - { _ } split [ spread>quot ] [ length 1 - ] bi ; +: (ncurry) ( quot n -- quot ) + { + { 0 [ ] } + { 1 [ \ curry suffix! ] } + { 2 [ \ 2curry suffix! ] } + { 3 [ \ 3curry suffix! ] } + [ [ \ 3curry suffix! ] dip 3 - (ncurry) ] + } case ; + +: wrap-non-callable ( obj -- quot ) + dup callable? [ ] [ [ call ] curry ] if ; inline + +: [ncurry] ( n -- quot ) + [ V{ } clone ] dip (ncurry) >quotation ; + +: [ndip] ( quot n -- quot' ) + { + { 0 [ wrap-non-callable ] } + { 1 [ \ dip [ ] 2sequence ] } + { 2 [ \ 2dip [ ] 2sequence ] } + { 3 [ \ 3dip [ ] 2sequence ] } + [ [ \ 3dip [ ] 2sequence ] dip 3 - [ndip] ] + } case ; + +: (make-curry) ( tail quot -- quot' ) + swap [ncurry] curry [ compose ] compose ; + +: make-compose ( consecutive quot -- consecutive quot' ) + [ + [ [ ] ] + [ [ncurry] ] if-zero + ] [ + [ [ compose ] ] + [ [ compose compose ] curry ] if-empty + ] bi* compose + 0 swap ; + +: make-curry ( consecutive quot -- consecutive' quot' ) + [ 1 + ] dip + [ [ ] ] [ (make-curry) 0 swap ] if-empty ; + +: convert-curry ( consecutive quot -- consecutive' quot' ) + [ [ ] make-curry ] [ + dup first \ @ = + [ rest >quotation make-compose ] + [ >quotation make-curry ] if + ] if-empty ; + +: prune-curries ( seq -- seq' ) + dup [ empty? not ] find + [ [ 1 + tail ] dip but-last prefix ] + [ 2drop { } ] if* ; + +: convert-curries ( seq -- tail seq' ) + unclip-slice [ 0 swap [ convert-curry ] map ] dip + [ prune-curries ] + [ >quotation 1quotation prefix ] if-empty ; + +: mark-composes ( quot -- quot' ) + [ dup \ @ = [ drop [ _ @ ] ] [ 1quotation ] if ] map concat ; inline + +: shallow-fry ( quot -- quot' ) + check-fry mark-composes + { _ } split convert-curries + [ [ [ ] ] [ [ ] (make-curry) but-last ] if-zero ] + [ spread>quot swap [ [ ] (make-curry) compose ] unless-zero ] if-empty ; + +DEFER: dredge-fry + +TUPLE: dredge-fry-state + { in-quot read-only } + { prequot read-only } + { quot read-only } ; + +: ( quot -- dredge-fry ) + V{ } clone V{ } clone dredge-fry-state boa ; inline + +: in-quot-slices ( n i state -- head tail ) + in-quot>> + [ ] + [ [ drop ] 2dip swap 1 + tail-slice ] 3bi ; inline + +: push-head-slice ( head state -- ) + quot>> [ push-all ] [ \ _ swap push ] bi ; inline + +: push-subquot ( tail elt state -- ) + [ fry swap >quotation count-inputs [ndip] ] dip prequot>> push-all ; inline + +: (dredge-fry-subquot) ( n state i elt -- ) + rot { + [ nip in-quot-slices ] ! head tail i elt state + [ [ 2drop swap ] dip push-head-slice ] + [ [ drop ] 2dip push-subquot ] + [ [ 1 + ] [ drop ] [ ] tri* dredge-fry ] + } 3cleave ; inline recursive + +: (dredge-fry-simple) ( n state -- ) + [ in-quot>> swap tail-slice ] [ quot>> ] bi push-all ; inline recursive + +: dredge-fry ( n dredge-fry -- ) + 2dup in-quot>> [ fried? ] find-from + [ (dredge-fry-subquot) ] + [ drop (dredge-fry-simple) ] if* ; inline recursive PRIVATE> -: fry ( quot -- quot' ) shallow-fry [ncurry] swap prefix ; +M: callable fry ( quot -- quot' ) + 0 swap + [ dredge-fry ] [ + [ prequot>> >quotation ] + [ quot>> >quotation shallow-fry ] bi append + ] bi ; -M: callable deep-fry - [ count-inputs \ _ % ] [ fry % ] bi ; - -M: object deep-fry , ; - -SYNTAX: '[ parse-quotation fry over push-all ; +SYNTAX: '[ parse-quotation fry append! ; diff --git a/basis/ftp/server/server-tests.factor b/basis/ftp/server/server-tests.factor index 3484fb4474..2572f36cb0 100644 --- a/basis/ftp/server/server-tests.factor +++ b/basis/ftp/server/server-tests.factor @@ -1,7 +1,7 @@ USING: calendar ftp.server io.encodings.ascii io.files io.files.unique namespaces threads tools.test kernel io.servers.connection ftp.client accessors urls -io.pathnames io.directories sequences fry ; +io.pathnames io.directories sequences fry io.backend ; FROM: ftp.client => ftp-get ; IN: ftp.server.tests @@ -11,7 +11,7 @@ IN: ftp.server.tests : create-test-file ( -- path ) test-file-contents "ftp.server" "test" make-unique-file - [ ascii set-file-contents ] keep canonicalize-path ; + [ ascii set-file-contents ] [ normalize-path ] bi ; : test-ftp-server ( quot -- ) '[ diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index c9518bdef1..251a99115e 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -3,13 +3,13 @@ USING: accessors assocs byte-arrays calendar classes combinators combinators.short-circuit concurrency.promises continuations destructors ftp io io.backend io.directories -io.encodings io.encodings.8-bit io.encodings.binary +io.encodings io.encodings.binary tools.files io.encodings.utf8 io.files io.files.info io.pathnames io.launcher.unix.parser io.servers.connection io.sockets io.streams.duplex io.streams.string io.timeouts kernel make math math.bitwise math.parser namespaces sequences splitting threads unicode.case logging calendar.format -strings io.files.links io.files.types ; +strings io.files.links io.files.types io.encodings.8-bit.latin1 ; IN: ftp.server SYMBOL: server @@ -58,7 +58,7 @@ C: ftp-disconnect send-response ; : serving? ( path -- ? ) - canonicalize-path server get serving-directory>> head? ; + normalize-path server get serving-directory>> head? ; : can-serve-directory? ( path -- ? ) { [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ; @@ -343,7 +343,7 @@ M: ftp-server handle-client* ( server -- ) : ( directory port -- server ) latin1 ftp-server new-threaded-server swap >>insecure - swap canonicalize-path >>serving-directory + swap normalize-path >>serving-directory "ftp.server" >>name 5 minutes >>timeout ; diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index dacd87507b..a03463e911 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays classes.mixin classes.parser +USING: accessors arrays assocs classes.mixin classes.parser classes.singleton classes.tuple classes.tuple.parser combinators effects.parser fry functors.backend generic generic.parser interpolate io.streams.string kernel lexer @@ -42,85 +42,85 @@ M: fake-call-next-method (fake-quotations>) M: object (fake-quotations>) , ; : parse-definition* ( accum -- accum ) - parse-definition >fake-quotations parsed - [ fake-quotations> first ] over push-all ; + parse-definition >fake-quotations suffix! + [ fake-quotations> first ] append! ; : parse-declared* ( accum -- accum ) complete-effect [ parse-definition* ] dip - parsed ; + suffix! ; FUNCTOR-SYNTAX: TUPLE: - scan-param parsed + scan-param suffix! scan { - { ";" [ tuple parsed f parsed ] } - { "<" [ scan-param parsed [ parse-tuple-slots ] { } make parsed ] } + { ";" [ tuple suffix! f suffix! ] } + { "<" [ scan-param suffix! [ parse-tuple-slots ] { } make suffix! ] } [ - [ tuple parsed ] dip + [ tuple suffix! ] dip [ parse-slot-name [ parse-tuple-slots ] when ] { } - make parsed + make suffix! ] } case - \ define-tuple-class parsed ; + \ define-tuple-class suffix! ; FUNCTOR-SYNTAX: SINGLETON: - scan-param parsed - \ define-singleton-class parsed ; + scan-param suffix! + \ define-singleton-class suffix! ; FUNCTOR-SYNTAX: MIXIN: - scan-param parsed - \ define-mixin-class parsed ; + scan-param suffix! + \ define-mixin-class suffix! ; FUNCTOR-SYNTAX: M: - scan-param parsed - scan-param parsed - [ create-method-in dup method-body set ] over push-all + scan-param suffix! + scan-param suffix! + [ create-method-in dup method-body set ] append! parse-definition* - \ define* parsed ; + \ define* suffix! ; FUNCTOR-SYNTAX: C: - scan-param parsed - scan-param parsed + scan-param suffix! + scan-param suffix! complete-effect - [ [ [ boa ] curry ] over push-all ] dip parsed - \ define-declared* parsed ; + [ [ [ boa ] curry ] append! ] dip suffix! + \ define-declared* suffix! ; FUNCTOR-SYNTAX: : - scan-param parsed + scan-param suffix! parse-declared* - \ define-declared* parsed ; + \ define-declared* suffix! ; FUNCTOR-SYNTAX: SYMBOL: - scan-param parsed - \ define-symbol parsed ; + scan-param suffix! + \ define-symbol suffix! ; FUNCTOR-SYNTAX: SYNTAX: - scan-param parsed + scan-param suffix! parse-definition* - \ define-syntax parsed ; + \ define-syntax suffix! ; FUNCTOR-SYNTAX: INSTANCE: - scan-param parsed - scan-param parsed - \ add-mixin-instance parsed ; + scan-param suffix! + scan-param suffix! + \ add-mixin-instance suffix! ; FUNCTOR-SYNTAX: GENERIC: - scan-param parsed - complete-effect parsed - \ define-simple-generic* parsed ; + scan-param suffix! + complete-effect suffix! + \ define-simple-generic* suffix! ; FUNCTOR-SYNTAX: MACRO: - scan-param parsed + scan-param suffix! parse-declared* - \ define-macro parsed ; + \ define-macro suffix! ; -FUNCTOR-SYNTAX: inline [ word make-inline ] over push-all ; +FUNCTOR-SYNTAX: inline [ word make-inline ] append! ; -FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } parsed ; +FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } suffix! ; : (INTERPOLATE) ( accum quot -- accum ) [ scan interpolate-locals ] dip - '[ _ with-string-writer @ ] parsed ; + '[ _ with-string-writer @ ] suffix! ; PRIVATE> @@ -144,10 +144,31 @@ DEFER: ;FUNCTOR delimiter : pop-functor-words ( -- ) functor-words unuse-words ; +: (parse-bindings) ( end -- ) + dup parse-binding dup [ + first2 [ make-local ] dip 2array , + (parse-bindings) + ] [ 2drop ] if ; + +: with-bindings ( quot -- words assoc ) + '[ + in-lambda? on + _ H{ } make-assoc + ] { } make swap ; inline + +: parse-bindings ( end -- words assoc ) + [ + namespace use-words + (parse-bindings) + namespace unuse-words + ] with-bindings ; + : parse-functor-body ( -- form ) push-functor-words - "WHERE" parse-bindings* - [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) 1quotation + "WHERE" parse-bindings + [ [ swap suffix ] { } assoc>map concat ] + [ [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) ] bi* + [ ] append-as pop-functor-words ; : (FUNCTOR:) ( -- word def effect ) diff --git a/basis/furnace/auth/auth-docs.factor b/basis/furnace/auth/auth-docs.factor index c7fc0d5f0b..5aab808763 100644 --- a/basis/furnace/auth/auth-docs.factor +++ b/basis/furnace/auth/auth-docs.factor @@ -63,7 +63,7 @@ HELP: realm { $class-description "The class of authentication realms. See " { $link "furnace.auth.realms" } " for details." } ; HELP: uchange -{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } } +{ $values { "quot" { $quotation "( old -- new )" } } { "key" symbol } } { $description "Applies the quotation to the old value of the user profile variable, and assigns the resulting value back to the variable." } ; HELP: uget diff --git a/basis/furnace/auth/providers/providers.factor b/basis/furnace/auth/providers/providers.factor index 1933fc8c59..44374fb5a6 100644 --- a/basis/furnace/auth/providers/providers.factor +++ b/basis/furnace/auth/providers/providers.factor @@ -23,26 +23,24 @@ GENERIC: new-user ( user provider -- user/f ) ! Password recovery support :: issue-ticket ( email username provider -- user/f ) - [let | user [ username provider get-user ] | - user [ - user email>> length 0 > [ - user email>> email = [ - user - 256 random-bits >hex >>ticket - dup provider update-user - ] [ f ] if + username provider get-user :> user + user [ + user email>> length 0 > [ + user email>> email = [ + user + 256 random-bits >hex >>ticket + dup provider update-user ] [ f ] if ] [ f ] if - ] ; + ] [ f ] if ; :: claim-ticket ( ticket username provider -- user/f ) - [let | user [ username provider get-user ] | - user [ - user ticket>> ticket = [ - user f >>ticket dup provider update-user - ] [ f ] if + username provider get-user :> user + user [ + user ticket>> ticket = [ + user f >>ticket dup provider update-user ] [ f ] if - ] ; + ] [ f ] if ; ! For configuration diff --git a/basis/game/input/dinput/keys-array/keys-array.factor b/basis/game/input/dinput/keys-array/keys-array.factor index 3426b89141..b9f21f70a2 100755 --- a/basis/game/input/dinput/keys-array/keys-array.factor +++ b/basis/game/input/dinput/keys-array/keys-array.factor @@ -1,5 +1,5 @@ USING: sequences sequences.private math -accessors alien.data ; +accessors alien.c-types ; IN: game.input.dinput.keys-array TUPLE: keys-array diff --git a/basis/game/input/input.factor b/basis/game/input/input.factor index 25283df4bf..261f19cb9e 100755 --- a/basis/game/input/input.factor +++ b/basis/game/input/input.factor @@ -75,9 +75,8 @@ SYMBOLS: get-controllers [ product-id = ] with filter ; : find-controller-instance ( product-id instance-id -- controller/f ) get-controllers [ - tuck [ product-id = ] - [ instance-id = ] 2bi* and + [ instance-id = ] bi-curry bi* and ] with with find nip ; TUPLE: keyboard-state keys ; diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index f5c0de2ea2..5b869f138e 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -212,7 +212,7 @@ HELP: nwith } ; HELP: napply -{ $values { "n" integer } } +{ $values { "quot" quotation } { "n" integer } } { $description "A generalization of " { $link bi@ } " and " { $link tri@ } " that can work for any stack depth." } { $examples @@ -266,26 +266,6 @@ HELP: spread-curry { $description "Curries the " { $snippet "n" } " quotations on the top of the datastack with the " { $snippet "n" } " values just below them. A generalization of " { $link bi-curry* } " and " { $link tri-curry* } "." } { $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry* bi" } ", " { $snippet "tri-curry* tri" } ", " { $snippet "bi-curry* bi*" } ", and " { $snippet "tri-curry* tri*" } "." } ; -HELP: neach -{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- )" } } { "n" integer } } -{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ; - -HELP: nmap -{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } } -{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ; - -HELP: nmap-as -{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } } -{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ; - -HELP: mnmap -{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the first " { $snippet "seq" } } } -{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel and provide any number of output sequences." } ; - -HELP: mnmap-as -{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "n*exemplar" { $snippet "n" } " sequences on the datastack" } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the " { $snippet "exemplar" } "s" } } -{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel and provide any number of output sequences of distinct types." } ; - HELP: mnswap { $values { "m" integer } { "n" integer } } { $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." } @@ -352,18 +332,6 @@ HELP: nappend-as { nappend nappend-as } related-words -HELP: ntuck -{ $values - { "n" integer } -} -{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ; - -HELP: nspin -{ $values - { "n" integer } -} -{ $description "A generalization of " { $link spin } " that can work for any stack depth. The top " { $snippet "n" } " items will be reversed in order." } ; - ARTICLE: "sequence-generalizations" "Generalized sequence operations" { $subsections narray @@ -383,8 +351,6 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words" -nrot nnip ndrop - ntuck - nspin mnswap nweave } ; @@ -401,11 +367,6 @@ ARTICLE: "combinator-generalizations" "Generalized combinators" apply-curry cleave-curry spread-curry - neach - nmap - nmap-as - mnmap - mnmap-as } ; ARTICLE: "other-generalizations" "Additional generalizations" @@ -424,6 +385,7 @@ ARTICLE: "generalizations" "Generalized shuffle words and combinators" "shuffle-generalizations" "combinator-generalizations" "other-generalizations" -} ; +} +"Also see the " { $vocab-link "sequences.generalizations" } " vocabulary for generalized sequence iteration combinators." ; ABOUT: "generalizations" diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index cb2c40ca0a..546413447e 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -26,8 +26,6 @@ IN: generalizations.tests { 0 } [ 0 1 2 3 4 4 ndrop ] unit-test [ [ 1 ] 5 ndip ] must-infer [ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test -[ 5 nspin ] must-infer -[ 1 5 4 3 2 ] [ 1 2 3 4 5 4 nspin ] unit-test [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer [ 1 2 3 4 5 2 '[ drop drop drop drop drop _ ] 5 nkeep ] must-infer @@ -82,108 +80,6 @@ IN: generalizations.tests [ '[ number>string _ append ] 4 napply ] must-infer -: neach-test ( a b c d -- ) - [ 4 nappend print ] 4 neach ; -: nmap-test ( a b c d -- e ) - [ 4 nappend ] 4 nmap ; -: nmap-as-test ( a b c d -- e ) - [ 4 nappend ] [ ] 4 nmap-as ; -: mnmap-3-test ( a b c d -- e f g ) - [ append ] 4 3 mnmap ; -: mnmap-2-test ( a b c d -- e f ) - [ [ append ] 2bi@ ] 4 2 mnmap ; -: mnmap-as-test ( a b c d -- e f ) - [ [ append ] 2bi@ ] { } [ ] 4 2 mnmap-as ; -: mnmap-1-test ( a b c d -- e ) - [ 4 nappend ] 4 1 mnmap ; -: mnmap-0-test ( a b c d -- ) - [ 4 nappend print ] 4 0 mnmap ; - -[ """A1a! -B2b@ -C3c# -D4d$ -""" ] [ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a" "b" "c" "d" } - { "!" "@" "#" "$" } - [ neach-test ] with-string-writer -] unit-test - -[ { "A1a!" "B2b@" "C3c#" "D4d$" } ] -[ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a" "b" "c" "d" } - { "!" "@" "#" "$" } - nmap-test -] unit-test - -[ [ "A1a!" "B2b@" "C3c#" "D4d$" ] ] -[ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a" "b" "c" "d" } - { "!" "@" "#" "$" } - nmap-as-test -] unit-test - -[ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a!" "b@" "c#" "d$" } -] [ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a" "b" "c" "d" } - { "!" "@" "#" "$" } - mnmap-3-test -] unit-test - -[ - { "A1" "B2" "C3" "D4" } - { "a!" "b@" "c#" "d$" } -] [ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a" "b" "c" "d" } - { "!" "@" "#" "$" } - mnmap-2-test -] unit-test - -[ - { "A1" "B2" "C3" "D4" } - [ "a!" "b@" "c#" "d$" ] -] [ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a" "b" "c" "d" } - { "!" "@" "#" "$" } - mnmap-as-test -] unit-test - -[ { "A1a!" "B2b@" "C3c#" "D4d$" } ] -[ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a" "b" "c" "d" } - { "!" "@" "#" "$" } - mnmap-1-test -] unit-test - -[ """A1a! -B2b@ -C3c# -D4d$ -""" ] [ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a" "b" "c" "d" } - { "!" "@" "#" "$" } - [ mnmap-0-test ] with-string-writer -] unit-test - [ 6 8 10 12 ] [ 1 2 3 4 5 6 7 8 [ + ] 4 apply-curry 4 spread* diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 2ae076655e..6c8a0b5fde 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -71,9 +71,6 @@ MACRO: ndrop ( n -- ) MACRO: nnip ( n -- ) '[ [ _ ndrop ] dip ] ; -MACRO: ntuck ( n -- ) - 2 + '[ dup _ -nrot ] ; - MACRO: ndip ( n -- ) [ [ dip ] curry ] n*quot [ call ] compose ; @@ -112,8 +109,8 @@ MACRO: cleave* ( n -- ) [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ] if-zero ; -MACRO: napply ( n -- ) - [ [ drop ] ] dip [ '[ tuck _ 2dip call ] ] times ; +: napply ( quot n -- ) + [ dupn ] [ spread* ] bi ; inline : apply-curry ( ...a quot n -- ) [ [curry] ] dip napply ; inline @@ -139,60 +136,3 @@ MACRO: nbi-curry ( n -- ) : nappend ( n -- seq ) narray concat ; inline -MACRO: nspin ( n -- ) - [ [ ] ] swap [ swap [ ] curry compose ] n*quot [ call ] 3append ; - -MACRO: nmin-length ( n -- ) - dup 1 - [ min ] n*quot - '[ [ length ] _ napply @ ] ; - -: nnth-unsafe ( n ...seq n -- ) - [ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline -MACRO: nset-nth-unsafe ( n -- ) - [ [ drop ] ] - [ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ] - if-zero ; - -: (neach) ( ...seq quot n -- len quot' ) - dup dup dup - '[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline - -: neach ( ...seq quot n -- ) - (neach) each-integer ; inline - -: nmap-as ( ...seq quot exemplar n -- result ) - '[ _ (neach) ] dip map-integers ; inline - -: nmap ( ...seq quot n -- result ) - dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline - -MACRO: nnew-sequence ( n -- ) - [ [ drop ] ] - [ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ; - -: nnew-like ( len ...exemplar quot n -- result... ) - dup dup dup dup '[ - _ nover - [ [ _ nnew-sequence ] dip call ] - _ ndip [ like ] - _ apply-curry - _ spread* - ] call ; inline - -MACRO: (ncollect) ( n -- ) - dup dup 1 + - '[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ; - -: ncollect ( len quot ...into n -- ) - (ncollect) each-integer ; inline - -: nmap-integers ( len quot ...exemplar n -- result... ) - dup dup dup - '[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline - -: mnmap-as ( m*seq quot n*exemplar m n -- result*n ) - dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline - -: mnmap ( m*seq quot m n -- result*n ) - 2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline - diff --git a/basis/grouping/grouping-docs.factor b/basis/grouping/grouping-docs.factor index d64745b834..e1044b0feb 100644 --- a/basis/grouping/grouping-docs.factor +++ b/basis/grouping/grouping-docs.factor @@ -52,7 +52,7 @@ HELP: { $examples { $example "USING: arrays kernel prettyprint sequences grouping ;" - "9 >array 3 dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }" + "9 >array 3 reverse! concat >array ." "{ 6 7 8 3 4 5 0 1 2 }" } { $example "USING: kernel prettyprint sequences grouping ;" @@ -68,7 +68,7 @@ HELP: { $example "USING: arrays kernel prettyprint sequences grouping ;" "9 >array 3 " - "dup [ reverse-here ] each concat >array ." + "dup [ reverse! drop ] each concat >array ." "{ 2 1 0 5 4 3 8 7 6 }" } { $example diff --git a/basis/grouping/grouping-tests.factor b/basis/grouping/grouping-tests.factor index c91e5a56d6..52b436507e 100644 --- a/basis/grouping/grouping-tests.factor +++ b/basis/grouping/grouping-tests.factor @@ -1,5 +1,5 @@ USING: grouping tools.test kernel sequences arrays -math ; +math accessors ; IN: grouping.tests [ { 1 2 3 } 0 group ] must-fail @@ -12,6 +12,15 @@ IN: grouping.tests >array ] unit-test +[ 0 ] [ { } 2 length ] unit-test +[ 0 ] [ { 1 } 2 length ] unit-test +[ 1 ] [ { 1 2 } 2 length ] unit-test +[ 2 ] [ { 1 2 3 } 2 length ] unit-test + +[ 1 ] [ V{ } 2 0 over set-length seq>> length ] unit-test +[ 2 ] [ V{ } 2 1 over set-length seq>> length ] unit-test +[ 3 ] [ V{ } 2 2 over set-length seq>> length ] unit-test + [ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 [ >array ] map ] unit-test [ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test diff --git a/basis/grouping/grouping.factor b/basis/grouping/grouping.factor index 83579d2beb..8a39a5d5cf 100644 --- a/basis/grouping/grouping.factor +++ b/basis/grouping/grouping.factor @@ -46,7 +46,7 @@ M: abstract-groups group@ TUPLE: abstract-clumps < chunking-seq ; M: abstract-clumps length - [ seq>> length ] [ n>> ] bi - 1 + ; inline + [ seq>> length 1 + ] [ n>> ] bi [-] ; inline M: abstract-clumps set-length [ n>> + 1 - ] [ seq>> ] bi set-length ; inline diff --git a/extra/half-floats/authors.txt b/basis/half-floats/authors.txt similarity index 100% rename from extra/half-floats/authors.txt rename to basis/half-floats/authors.txt diff --git a/extra/half-floats/half-floats-tests.factor b/basis/half-floats/half-floats-tests.factor similarity index 100% rename from extra/half-floats/half-floats-tests.factor rename to basis/half-floats/half-floats-tests.factor diff --git a/extra/half-floats/half-floats.factor b/basis/half-floats/half-floats.factor similarity index 98% rename from extra/half-floats/half-floats.factor rename to basis/half-floats/half-floats.factor index d0f6a09067..4c84bb81cc 100755 --- a/extra/half-floats/half-floats.factor +++ b/basis/half-floats/half-floats.factor @@ -39,6 +39,7 @@ SYMBOL: half [ [ >float half>bits ] 2dip set-alien-unsigned-2 ] >>setter 2 >>size 2 >>align + 2 >>align-first [ >float ] >>unboxer-quot \ half define-primitive-type diff --git a/extra/half-floats/summary.txt b/basis/half-floats/summary.txt similarity index 100% rename from extra/half-floats/summary.txt rename to basis/half-floats/summary.txt diff --git a/basis/heaps/heaps-docs.factor b/basis/heaps/heaps-docs.factor index 32b6ffe7ed..8ceb7bb78f 100644 --- a/basis/heaps/heaps-docs.factor +++ b/basis/heaps/heaps-docs.factor @@ -53,12 +53,12 @@ HELP: { $description "Create a new " { $link max-heap } "." } ; HELP: heap-push -{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } } +{ $values { "value" object } { "key" "a comparable object" } { "heap" "a heap" } } { $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." } { $side-effects "heap" } ; HELP: heap-push* -{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } { "entry" entry } } +{ $values { "value" object } { "key" "a comparable object" } { "heap" "a heap" } { "entry" entry } } { $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." } { $side-effects "heap" } ; @@ -68,7 +68,7 @@ HELP: heap-push-all { $side-effects "heap" } ; HELP: heap-peek -{ $values { "heap" "a heap" } { "key" object } { "value" object } } +{ $values { "heap" "a heap" } { "value" object } { "key" object } } { $description "Output the first element in the heap, leaving it in the heap." } ; HELP: heap-pop* @@ -77,7 +77,7 @@ HELP: heap-pop* { $side-effects "heap" } ; HELP: heap-pop -{ $values { "heap" "a heap" } { "key" object } { "value" object } } +{ $values { "heap" "a heap" } { "value" object } { "key" object } } { $description "Output and remove the first element in the heap." } { $side-effects "heap" } ; diff --git a/basis/help/apropos/apropos.factor b/basis/help/apropos/apropos.factor index 3bcc815191..e77e7bccad 100644 --- a/basis/help/apropos/apropos.factor +++ b/basis/help/apropos/apropos.factor @@ -73,4 +73,4 @@ M: apropos >link ; INSTANCE: apropos topic : apropos ( str -- ) - print-topic ; + print-topic nl ; diff --git a/basis/help/crossref/crossref-tests.factor b/basis/help/crossref/crossref-tests.factor index 4022d3bd38..6fb4c562cf 100644 --- a/basis/help/crossref/crossref-tests.factor +++ b/basis/help/crossref/crossref-tests.factor @@ -1,6 +1,7 @@ USING: help.crossref help.topics help.markup tools.test words definitions assocs sequences kernel namespaces parser arrays -io.streams.string continuations debugger compiler.units eval ; +io.streams.string continuations debugger compiler.units eval +help.syntax ; IN: help.crossref.tests [ ] [ @@ -54,3 +55,11 @@ IN: help.crossref.tests ] unit-test [ "xxx" ] [ "yyy" article-parent ] unit-test + +ARTICLE: "crossref-test-1" "Crossref test 1" +"Hello world" ; + +ARTICLE: "crossref-test-2" "Crossref test 2" +{ $markup-example { $subsection "crossref-test-1" } } ; + +[ V{ } ] [ "crossref-test-2" >link article-children ] unit-test diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index afb88bbd3c..0cfa419dd0 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -10,36 +10,6 @@ IN: help.handbook ARTICLE: "conventions" "Conventions" "Various conventions are used throughout the Factor documentation and source code." -{ $heading "Documentation conventions" } -"Factor documentation consists of two distinct bodies of text. There is a hierarchy of articles, much like this one, and there is word documentation. Help articles reference word documentation, and vice versa, but not every documented word is referenced from some help article." -$nl -"Every article has links to parent articles at the top. Explore these if the article you are reading is too specific." -$nl -"Some generic words have " { $strong "Description" } " headings, and others have " { $strong "Contract" } " headings. A distinction is made between words which are not intended to be extended with user-defined methods, and those that are." -{ $heading "Vocabulary naming conventions" } -"A vocabulary name ending in " { $snippet ".private" } " contains words which are either implementation detail, unsafe, or both. For example, the " { $snippet "sequence.private" } " vocabulary contains words which access sequence elements without bounds checking (" { $link "sequences-unsafe" } ")." -$nl -"You should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason." -{ $heading "Word naming conventions" } -"These conventions are not hard and fast, but are usually a good first step in understanding a word's behavior:" -{ $table - { "General form" "Description" "Examples" } - { { $snippet { $emphasis "foo" } "?" } "outputs a boolean" { { $link empty? } } } - { { $snippet "?" { $emphasis "foo" } } { "conditionally performs " { $snippet { $emphasis "foo" } } } { { $links ?nth } } } - { { $snippet "<" { $emphasis "foo" } ">" } { "creates a new " { $snippet "foo" } } { { $link } } } - { { $snippet ">" { $emphasis "foo" } } { "converts the top of the stack into a " { $snippet "foo" } } { { $link >array } } } - { { $snippet { $emphasis "foo" } ">" { $emphasis "bar" } } { "converts a " { $snippet "foo" } " into a " { $snippet "bar" } } { { $link number>string } } } - { { $snippet "new-" { $emphasis "foo" } } { "creates a new " { $snippet "foo" } ", taking some kind of parameter from the stack which determines the type of the object to be created" } { { $link new-sequence } ", " { $link new-lexer } ", " { $link new } } } - { { $snippet { $emphasis "foo" } "*" } { "alternative form of " { $snippet "foo" } ", or a generic word called by " { $snippet "foo" } } { { $links at* pprint* } } } - { { $snippet "(" { $emphasis "foo" } ")" } { "implementation detail word used by " { $snippet "foo" } } { { $link (clone) } } } - { { $snippet "set-" { $emphasis "foo" } } { "sets " { $snippet "foo" } " to a new value" } { $links set-length } } - { { $snippet { $emphasis "foo" } ">>" } { "gets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link name>> } } } - { { $snippet ">>" { $emphasis "foo" } } { "sets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link >>name } } } - { { $snippet "with-" { $emphasis "foo" } } { "performs some kind of initialization and cleanup related to " { $snippet "foo" } ", usually in a new dynamic scope" } { $links with-scope with-input-stream with-output-stream } } - { { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } } -} -{ $heading "Stack effect conventions" } -"Stack effect conventions are documented in " { $link "effects" } "." { $heading "Glossary of terms" } "Common terminology and abbreviations used throughout Factor and its documentation:" { $table @@ -62,10 +32,41 @@ $nl { "slot" { "a component of an object which can store a value" } } { "stack effect" { "a pictorial representation of a word's inputs and outputs, for example " { $snippet "+ ( x y -- z )" } ". See " { $link "effects" } } } { "true value" { "any object not equal to " { $link f } } } - { "vocabulary" { "a named set of words. See " { $link "vocabularies" } } } + { { "vocabulary " { $strong "or" } " vocab" } { "a named set of words. See " { $link "vocabularies" } } } { "vocabulary specifier" { "a " { $link vocab } ", " { $link vocab-link } " or a string naming a vocabulary" } } { "word" { "the basic unit of code, analogous to a function or procedure in other programming languages. See " { $link "words" } } } -} ; +} +{ $heading "Documentation conventions" } +"Factor documentation consists of two distinct bodies of text. There is a hierarchy of articles, much like this one, and there is word documentation. Help articles reference word documentation, and vice versa, but not every documented word is referenced from some help article." +$nl +"The browser, completion popups and other tools use a common set of " { $link "definitions.icons" } "." +$nl +"Every article has links to parent articles at the top. Explore these if the article you are reading is too specific." +$nl +"Some generic words have " { $strong "Description" } " headings, and others have " { $strong "Contract" } " headings. A distinction is made between words which are not intended to be extended with user-defined methods, and those that are." +{ $heading "Vocabulary naming conventions" } +"A vocabulary name ending in " { $snippet ".private" } " contains words which are either implementation details, unsafe, or both. For example, the " { $snippet "sequence.private" } " vocabulary contains words which access sequence elements without bounds checking (" { $link "sequences-unsafe" } "). You should avoid using private words from the Factor library unless absolutely necessary. Similarly, your own code can place words in private vocabularies using " { $link POSTPONE: " } { "creates a new " { $snippet "foo" } } { { $link } } } + { { $snippet ">" { $emphasis "foo" } } { "converts the top of the stack into a " { $snippet "foo" } } { { $link >array } } } + { { $snippet { $emphasis "foo" } ">" { $emphasis "bar" } } { "converts a " { $snippet "foo" } " into a " { $snippet "bar" } } { { $link number>string } } } + { { $snippet "new-" { $emphasis "foo" } } { "creates a new " { $snippet "foo" } ", taking some kind of parameter from the stack which determines the type of the object to be created" } { { $link new-sequence } ", " { $link new-lexer } ", " { $link new } } } + { { $snippet { $emphasis "foo" } "*" } { "alternative form of " { $snippet "foo" } ", or a generic word called by " { $snippet "foo" } } { { $links at* pprint* } } } + { { $snippet "(" { $emphasis "foo" } ")" } { "implementation detail word used by " { $snippet "foo" } } { { $link (clone) } } } + { { $snippet "set-" { $emphasis "foo" } } { "sets " { $snippet "foo" } " to a new value" } { $links set-length } } + { { $snippet { $emphasis "foo" } ">>" } { "gets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link name>> } } } + { { $snippet ">>" { $emphasis "foo" } } { "sets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link >>name } } } + { { $snippet "with-" { $emphasis "foo" } } { "performs some kind of initialization and cleanup related to " { $snippet "foo" } ", usually in a new dynamic scope" } { $links with-scope with-input-stream with-output-stream } } + { { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } } +} +{ $heading "Stack effect conventions" } +"Stack effect conventions are documented in " { $link "effects" } "." +; ARTICLE: "tail-call-opt" "Tail-call optimization" "If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $emphasis "tail-call optimization" } " and the Factor implementation guarantees that it will be performed." @@ -363,7 +364,7 @@ ARTICLE: "handbook-library-reference" "Libraries" { $index [ orphan-articles { "help.home" "handbook" } diff ] } ; ARTICLE: "handbook" "Factor handbook" -{ $heading "Getting Started" } +{ $heading "Getting started" } { $subsections "cookbook" "first-program" @@ -379,14 +380,14 @@ ARTICLE: "handbook" "Factor handbook" "alien" "handbook-library-reference" } -{ $heading "Explore loaded libraries" } +{ $heading "Index" } { $subsections - "article-index" - "primitive-index" - "error-index" - "class-index" + "vocab-index" + "article-index" + "primitive-index" + "error-index" + "class-index" } -{ $heading "Explore the code base" } -{ $subsections "vocab-index" } ; +; ABOUT: "handbook" diff --git a/basis/help/help.factor b/basis/help/help.factor index ddd6ce23fc..6fb87d7a33 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -129,7 +129,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; SYMBOL: help-hook -help-hook [ [ print-topic ] ] initialize +help-hook [ [ print-topic nl ] ] initialize : help ( topic -- ) help-hook get call( topic -- ) ; diff --git a/basis/help/home/home-docs.factor b/basis/help/home/home-docs.factor index b40d162670..b5d23bd7fc 100644 --- a/basis/help/home/home-docs.factor +++ b/basis/help/home/home-docs.factor @@ -2,22 +2,33 @@ IN: help.home USING: help.markup help.syntax ; ARTICLE: "help.home" "Factor documentation" -"If this is your first time with Factor, you can start by writing " { $link "first-program" } "." -{ $heading "Reference" } -{ $list - { $link "handbook" } - { $link "vocab-index" } - { $link "ui-tools" } - { $link "ui-listener" } +{ $heading "Getting started" } +{ $subsections + "cookbook" + "first-program" } -{ $heading "Recently visited" } +{ $heading "User interface" } +{ $subsections + "listener" + "ui-tools" +} +{ $heading "Reference" } +{ $subsections + "handbook" + "vocab-index" + "article-index" + "primitive-index" + "error-index" + "class-index" +} +{ $heading "Searches" } +"Use the search field in the top-right of the " { $link "ui-browser" } " window to search for words, vocabularies, and help articles." +{ $recent-searches } +{ $heading "Recently visited pages" } { $table { "Words" "Articles" "Vocabs" } { { $recent recent-words } { $recent recent-articles } { $recent recent-vocabs } } } -"The browser, completion popups and other tools use a common set of " { $link "definitions.icons" } "." -{ $heading "Recent searches" } -{ $recent-searches } -"Use the search field in the top-right of the " { $link "ui-browser" } " window to search for words, vocabularies and help articles." ; +; -ABOUT: "help.home" \ No newline at end of file +ABOUT: "help.home" diff --git a/basis/help/lint/checks/checks.factor b/basis/help/lint/checks/checks.factor index 56f104a1a1..340f9b16d3 100644 --- a/basis/help/lint/checks/checks.factor +++ b/basis/help/lint/checks/checks.factor @@ -33,18 +33,18 @@ SYMBOL: vocab-articles : extract-values ( element -- seq ) \ $values swap elements dup empty? [ - first rest [ first ] map prune natural-sort + first rest [ first ] map prune ] unless ; : effect-values ( word -- seq ) stack-effect [ in>> ] [ out>> ] bi append - [ dup pair? [ first ] when effect>string ] map - prune natural-sort ; + [ dup pair? [ first ] when effect>string ] map prune ; : contains-funky-elements? ( element -- ? ) { $shuffle + $complex-shuffle $values-x/y $predicate $class-description diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index ea64df3edc..75e6538243 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs classes colors colors.constants -combinators definitions definitions.icons effects fry generic -hashtables help.stylesheet help.topics io io.styles kernel make -math namespaces parser present prettyprint +combinators combinators.smart definitions definitions.icons effects +fry generic hashtables help.stylesheet help.topics io io.styles +kernel make math namespaces parser present prettyprint prettyprint.stylesheet quotations see sequences sets slots sorting splitting strings vectors vocabs vocabs.loader words words.symbol ; @@ -398,7 +398,12 @@ M: f ($instance) : $shuffle ( element -- ) drop - "Shuffle word. Re-arranges the stack according to the stack effect pattern." $description ; + "Shuffle word. Rearranges the top of the datastack as indicated in the stack effect pattern." $description ; + +: $complex-shuffle ( element -- ) + drop + "Shuffle word. Rearranges the top of the datastack as indicated in the stack effect pattern." $description + { "The data flow represented by this shuffle word can be more clearly expressed using " { $link "locals" } "." } $deprecated ; : $low-level-note ( children -- ) drop @@ -430,8 +435,8 @@ M: simple-element elements* M: object elements* 2drop ; M: array elements* - [ [ elements* ] with each ] 2keep - [ first eq? ] keep swap [ , ] [ drop ] if ; + [ dup first \ $markup-example eq? [ 2drop ] [ [ elements* ] with each ] if ] + [ [ first eq? ] keep swap [ , ] [ drop ] if ] 2bi ; : elements ( elt-type element -- seq ) [ elements* ] { } make ; @@ -449,4 +454,4 @@ M: array elements* icons get >alist sort-keys [ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map { "" "Definition class" } prefix - $table ; \ No newline at end of file + $table ; diff --git a/basis/help/tips/tips.factor b/basis/help/tips/tips.factor index 8569be0b8f..06f2255dfa 100644 --- a/basis/help/tips/tips.factor +++ b/basis/help/tips/tips.factor @@ -10,7 +10,7 @@ tips [ V{ } clone ] initialize TUPLE: tip < identity-tuple content loc ; -M: tip forget* tips get delq ; +M: tip forget* tips get remove-eq! drop ; M: tip where loc>> ; @@ -58,4 +58,4 @@ H{ : $tips-of-the-day ( element -- ) drop tips get [ nl nl ] [ content>> print-element ] interleave ; -INSTANCE: tip definition \ No newline at end of file +INSTANCE: tip definition diff --git a/basis/help/vocabs/vocabs-tests.factor b/basis/help/vocabs/vocabs-tests.factor index 5637dd92f4..aca1ae43c9 100644 --- a/basis/help/vocabs/vocabs-tests.factor +++ b/basis/help/vocabs/vocabs-tests.factor @@ -1,5 +1,6 @@ -USING: help.vocabs tools.test help.markup help vocabs ; +USING: help.vocabs tools.test help.markup help vocabs io ; IN: help.vocabs.tests [ ] [ { $vocab "scratchpad" } print-content ] unit-test [ ] [ "classes" vocab print-topic ] unit-test +[ ] [ nl ] unit-test diff --git a/basis/hints/hints-docs.factor b/basis/hints/hints-docs.factor index 56a2cb9142..46bdc698b7 100644 --- a/basis/hints/hints-docs.factor +++ b/basis/hints/hints-docs.factor @@ -20,7 +20,7 @@ HELP: specialized-def { $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ; HELP: HINTS: -{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes or literals" } } +{ $values { "defspec" "a word or method" } { "hints..." "a list of sequences of classes or literals" } } { $description "Defines specialization hints for a word or a method." $nl "Each sequence in the list will cause a specialized version of the word to be compiled. Classes are tested for using their predicate, and literals are tested using " { $link eq? } "." } @@ -35,8 +35,8 @@ $nl "M: assoc count-occurrences" " swap [ = nip ] curry assoc-filter assoc-size ;" "" - "HINTS: { sequence count-occurrences } { object array } ;" - "HINTS: { assoc count-occurrences } { object hashtable } ;" + "HINTS: M\ sequence count-occurrences { object array } ;" + "HINTS: M\ assoc count-occurrences { object hashtable } ;" } } ; diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index f49d2e4229..1ca5bf1bc5 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -3,8 +3,9 @@ USING: accessors arrays assocs byte-arrays byte-vectors classes combinators definitions effects fry generic generic.single generic.standard hashtables io.binary io.streams.string kernel -kernel.private math math.parser namespaces parser sbufs -sequences splitting splitting.private strings vectors words ; +kernel.private math math.integers.private math.parser math.parser.private +namespaces parser sbufs sequences splitting splitting.private strings +vectors words ; IN: hints GENERIC: specializer-predicate ( spec -- quot ) @@ -78,9 +79,6 @@ SYNTAX: HINTS: [ parse-definition { } like "specializer" set-word-prop ] tri ; ! Default specializers -{ first first2 first3 first4 } -[ { array } "specializer" set-word-prop ] each - { last pop* pop } [ { vector } "specializer" set-word-prop ] each @@ -103,7 +101,7 @@ SYNTAX: HINTS: { { fixnum fixnum string } { fixnum fixnum array } } "specializer" set-word-prop -\ reverse-here +\ reverse! { { string } { array } } "specializer" set-word-prop @@ -121,7 +119,7 @@ SYNTAX: HINTS: \ split, { string string } "specializer" set-word-prop -\ memq? { array } "specializer" set-word-prop +\ member-eq? { array } "specializer" set-word-prop \ member? { array } "specializer" set-word-prop @@ -136,3 +134,11 @@ SYNTAX: HINTS: M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop + +\ dec>float { string } "specializer" set-word-prop + +\ hex>float { string } "specializer" set-word-prop + +\ string>integer { string fixnum } "specializer" set-word-prop + +\ bignum/f { { bignum bignum } { bignum fixnum } { fixnum bignum } { fixnum fixnum } } "specializer" set-word-prop diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index a98a21f177..d4cb484a79 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -31,14 +31,14 @@ DEFER: <% delimiter : found-<% ( accum lexer col -- accum ) [ over line-text>> - [ column>> ] 2dip subseq parsed - \ write parsed + [ column>> ] 2dip subseq suffix! + \ write suffix! ] 2keep 2 + >>column drop ; : still-looking ( accum lexer -- accum ) [ [ line-text>> ] [ column>> ] bi tail - parsed \ print parsed + suffix! \ print suffix! ] keep next-line ; : parse-%> ( accum lexer -- accum ) diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index 330db4467b..04077fc2f7 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -1,7 +1,7 @@ USING: http help.markup help.syntax io.pathnames io.streams.string -io.encodings.8-bit io.encodings.binary kernel urls +io.encodings.binary kernel urls urls.encoding byte-arrays strings assocs sequences destructors -http.client.post-data.private ; +http.client.post-data.private io.encodings.8-bit.latin1 ; IN: http.client HELP: download-failed diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 016e347e89..482a23aeaa 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -5,7 +5,7 @@ sequences strings splitting calendar continuations accessors vectors math.order hashtables byte-arrays destructors io io.sockets io.streams.string io.files io.timeouts io.pathnames io.encodings io.encodings.string io.encodings.ascii -io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.crlf +io.encodings.utf8 io.encodings.binary io.crlf io.streams.duplex fry ascii urls urls.encoding present locals http http.parsers http.client.post-data ; IN: http.client diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 3fe5e84abd..35d01c1014 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -2,7 +2,8 @@ USING: http http.server http.client http.client.private tools.test multiline io.streams.string io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.encodings.string io.encodings.ascii kernel arrays splitting sequences assocs io.sockets db db.sqlite -continuations urls hashtables accessors namespaces xml.data ; +continuations urls hashtables accessors namespaces xml.data +io.encodings.8-bit.latin1 ; IN: http.tests [ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test diff --git a/basis/http/http.factor b/basis/http/http.factor index 4c32954eee..6f898e949c 100755 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -5,9 +5,7 @@ sequences splitting sorting sets strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format present urls fry io io.encodings io.encodings.iana io.encodings.binary -io.encodings.8-bit io.crlf ascii -http.parsers -base64 ; +io.crlf ascii io.encodings.8-bit.latin1 http.parsers base64 ; IN: http CONSTANT: max-redirects 10 @@ -193,7 +191,7 @@ M: response clone [ cookies>> ] dip '[ [ _ ] dip name>> = ] find nip ; : delete-cookie ( request/response name -- ) - over cookies>> [ get-cookie ] dip delete ; + over cookies>> [ get-cookie ] dip remove! drop ; : put-cookie ( request/response cookie -- request/response ) [ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep diff --git a/basis/images/bitmap/loading/loading.factor b/basis/images/bitmap/loading/loading.factor index 50926666f6..702fd14472 100644 --- a/basis/images/bitmap/loading/loading.factor +++ b/basis/images/bitmap/loading/loading.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types arrays byte-arrays combinators compression.run-length fry grouping images images.loader io -io.binary io.encodings.8-bit io.encodings.binary +io.binary io.encodings.binary io.encodings.string io.streams.limited kernel math math.bitwise -sequences specialized-arrays summary images.bitmap ; +io.encodings.8-bit.latin1 sequences specialized-arrays summary images.bitmap ; QUALIFIED-WITH: bitstreams b SPECIALIZED-ARRAY: ushort IN: images.bitmap.loading diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index 6e45dd1ce8..e305c8477a 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Marc Fauconneau. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays byte-arrays combinators -grouping compression.huffman images +grouping compression.huffman images fry images.processing io io.binary io.encodings.binary io.files io.streams.byte-array kernel locals math math.bitwise math.constants math.functions math.matrices math.order @@ -232,7 +232,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; block dup length>> sqrt >fixnum group flip dup matrix-dim coord-matrix flip [ - [ first2 spin nth nth ] + [ '[ _ [ second ] [ first ] bi ] dip nth nth ] [ x,y v+ color-id jpeg-image draw-color ] bi ] with each^2 ; @@ -295,7 +295,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; binary [ [ { HEX: FF } read-until - read1 tuck HEX: 00 = and + read1 [ HEX: 00 = and ] keep swap ] [ drop ] produce swap >marker { EOI } assert= @@ -354,7 +354,7 @@ SINGLETONS: YUV420 YUV444 Y MAGIC! ; [ decode-macroblock 2array ] accumulator [ all-macroblocks ] dip jpeg> setup-bitmap draw-macroblocks - jpeg> bitmap>> 3 [ color-transform ] change-each + jpeg> bitmap>> 3 [ color-transform ] map! drop jpeg> [ >byte-array ] change-bitmap drop ; ERROR: not-a-jpeg-image ; diff --git a/extra/images/normalization/authors.txt b/basis/images/normalization/authors.txt similarity index 100% rename from extra/images/normalization/authors.txt rename to basis/images/normalization/authors.txt diff --git a/extra/images/normalization/normalization-docs.factor b/basis/images/normalization/normalization-docs.factor similarity index 100% rename from extra/images/normalization/normalization-docs.factor rename to basis/images/normalization/normalization-docs.factor diff --git a/extra/images/normalization/normalization-tests.factor b/basis/images/normalization/normalization-tests.factor similarity index 100% rename from extra/images/normalization/normalization-tests.factor rename to basis/images/normalization/normalization-tests.factor diff --git a/extra/images/normalization/normalization.factor b/basis/images/normalization/normalization.factor similarity index 92% rename from extra/images/normalization/normalization.factor rename to basis/images/normalization/normalization.factor index 0beaa1de1d..2bd7e6883f 100755 --- a/extra/images/normalization/normalization.factor +++ b/basis/images/normalization/normalization.factor @@ -26,11 +26,11 @@ CONSTANT: fill-value 255 ] B{ } map-as ; :: permute ( bytes src-order dst-order -- new-bytes ) - [let | src [ src-order name>> ] - dst [ dst-order name>> ] | - bytes src length group - [ pad4 src dst permutation shuffle dst length head ] - map concat ] ; + src-order name>> :> src + dst-order name>> :> dst + bytes src length group + [ pad4 src dst permutation shuffle dst length head ] + map concat ; : (reorder-components) ( image src-order dest-order -- image ) [ permute ] 2curry change-bitmap ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index cb9a347de1..26c3ebee34 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -290,6 +290,14 @@ ERROR: invalid-color-type/bit-depth loading-png ; : validate-truecolor-alpha ( loading-png -- loading-png ) { 8 16 } validate-bit-depth ; +: pad-bitmap ( image -- image ) + dup dim>> first 4 divisor? [ + dup [ bytes-per-pixel ] + [ dim>> first * ] + [ dim>> first 4 mod ] tri + '[ _ group [ _ 0 append ] map B{ } concat-as ] change-bitmap + ] unless ; + : loading-png>bitmap ( loading-png -- bytes component-order ) dup color-type>> { { greyscale [ @@ -315,7 +323,7 @@ ERROR: invalid-color-type/bit-depth loading-png ; [ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ] [ [ width>> ] [ height>> ] bi 2array >>dim ] [ png-component >>component-type ] - } cleave ; + } cleave pad-bitmap ; : load-png ( stream -- loading-png ) [ diff --git a/basis/interpolate/interpolate-tests.factor b/basis/interpolate/interpolate-tests.factor index c15debd9b5..8f84da4ff7 100644 --- a/basis/interpolate/interpolate-tests.factor +++ b/basis/interpolate/interpolate-tests.factor @@ -16,7 +16,8 @@ IN: interpolate.tests ] unit-test [ "Oops, I accidentally the whole economy..." ] [ - [let | noun [ "economy" ] | + [let + "economy" :> noun [ I[ Oops, I accidentally the whole ${noun}...]I ] with-string-writer ] ] unit-test diff --git a/basis/interpolate/interpolate.factor b/basis/interpolate/interpolate.factor index ea965aac5b..6e5f68fcdf 100644 --- a/basis/interpolate/interpolate.factor +++ b/basis/interpolate/interpolate.factor @@ -40,4 +40,4 @@ MACRO: interpolate ( string -- ) SYNTAX: I[ "]I" parse-multiline-string - interpolate-locals over push-all ; + interpolate-locals append! ; diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index 6b1e839ca6..4ecb1e12a8 100755 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -97,7 +97,7 @@ SYMBOL: visited [ dup flattenable? [ def>> - [ visited get memq? [ no-recursive-inverse ] when ] + [ visited get member-eq? [ no-recursive-inverse ] when ] [ flatten ] bi ] [ 1quotation ] if @@ -141,7 +141,6 @@ MACRO: undo ( quot -- ) [undo] ; \ 2dup [ over =/fail over =/fail ] define-inverse \ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse \ pick [ [ pick ] dip =/fail ] define-inverse -\ tuck [ swapd [ =/fail ] keep ] define-inverse \ bi@ 1 [ [undo] '[ _ bi@ ] ] define-pop-inverse \ tri@ 1 [ [undo] '[ _ tri@ ] ] define-pop-inverse @@ -149,7 +148,7 @@ MACRO: undo ( quot -- ) [undo] ; \ tri* 3 [ [ [undo] ] tri@ '[ _ _ _ tri* ] ] define-pop-inverse \ not define-involution -\ >boolean [ dup { t f } memq? assure ] define-inverse +\ >boolean [ dup { t f } member-eq? assure ] define-inverse \ tuple>array \ >tuple define-dual \ reverse define-involution diff --git a/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor b/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor index 84a609643a..276949a99f 100644 --- a/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor +++ b/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor @@ -3,13 +3,14 @@ USING: kernel arrays namespaces math accessors alien locals destructors system threads io.backend.unix.multiplexers io.backend.unix.multiplexers.kqueue core-foundation -core-foundation.run-loop ; +core-foundation.run-loop core-foundation.file-descriptors ; +FROM: alien.c-types => void void* ; IN: io.backend.unix.multiplexers.run-loop TUPLE: run-loop-mx kqueue-mx ; : file-descriptor-callback ( -- callback ) - "void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" } + void { CFFileDescriptorRef CFOptionFlags void* } "cdecl" [ 3drop 0 mx get kqueue-mx>> wait-for-events diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 452dc4a409..1301d69913 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -50,16 +50,17 @@ M: winnt add-completion ( win32-handle -- ) } cond ] with-timeout ; -:: wait-for-overlapped ( us -- bytes-transferred overlapped error? ) +:: wait-for-overlapped ( usec -- bytes-transferred overlapped error? ) master-completion-port get-global - 0 [ ! bytes - f ! key - f [ ! overlapped - us [ 1000 /i ] [ INFINITE ] if* ! timeout - GetQueuedCompletionStatus zero? - ] keep - *void* dup [ OVERLAPPED memory>struct ] when - ] keep *int spin ; + 0 :> bytes + f :> key + f :> overlapped + usec [ 1000 /i ] [ INFINITE ] if* :> timeout + bytes key overlapped timeout GetQueuedCompletionStatus zero? :> error? + + bytes *int + overlapped *void* dup [ OVERLAPPED memory>struct ] when + error? ; : resume-callback ( result overlapped -- ) >c-ptr pending-overlapped get-global delete-at* drop resume-with ; diff --git a/basis/io/buffers/buffers-tests.factor b/basis/io/buffers/buffers-tests.factor index d366df7c54..93d2f5b2fc 100644 --- a/basis/io/buffers/buffers-tests.factor +++ b/basis/io/buffers/buffers-tests.factor @@ -8,7 +8,7 @@ strings accessors destructors ; [ length ] dip buffer-reset ; : string>buffer ( string -- buffer ) - dup length tuck buffer-set ; + dup length [ buffer-set ] keep ; : buffer-read-all ( buffer -- byte-array ) [ [ pos>> ] [ ptr>> ] bi ] diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor index aa9cedf340..f45d3bb062 100644 --- a/basis/io/buffers/buffers.factor +++ b/basis/io/buffers/buffers.factor @@ -8,7 +8,7 @@ IN: io.buffers TUPLE: buffer { size fixnum } -{ ptr simple-alien } +{ ptr alien } { fill fixnum } { pos fixnum } disposed ; @@ -73,7 +73,7 @@ HINTS: >buffer byte-array buffer ; bi ; inline : search-buffer-until ( pos fill ptr separators -- n ) - [ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ; inline + [ [ swap alien-unsigned-1 ] dip member-eq? ] 2curry find-from drop ; inline : finish-buffer-until ( buffer n -- byte-array separator ) [ diff --git a/basis/io/directories/directories-docs.factor b/basis/io/directories/directories-docs.factor index 36b46e19ee..e93023523d 100644 --- a/basis/io/directories/directories-docs.factor +++ b/basis/io/directories/directories-docs.factor @@ -119,7 +119,7 @@ ARTICLE: "current-directory" "Current working directory" with-directory } "This variable is independent of the operating system notion of “current working directory”. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:" -{ $subsections (normalize-path) } +{ $subsections absolute-path } "The second is to change the working directory of the current process:" { $subsections cd diff --git a/basis/io/directories/directories.factor b/basis/io/directories/directories.factor index 30f4cebf8d..0524398304 100755 --- a/basis/io/directories/directories.factor +++ b/basis/io/directories/directories.factor @@ -6,10 +6,10 @@ sequences system vocabs.loader fry ; IN: io.directories : set-current-directory ( path -- ) - (normalize-path) current-directory set ; + absolute-path current-directory set ; : with-directory ( path quot -- ) - [ (normalize-path) current-directory ] dip with-variable ; inline + [ absolute-path current-directory ] dip with-variable ; inline ! Creating directories HOOK: make-directory io-backend ( path -- ) diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 0c947e5bc6..4356a0b988 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -6,11 +6,11 @@ locals math sequences sorting system unicode.case vocabs.loader ; IN: io.directories.search : qualified-directory-entries ( path -- seq ) - (normalize-path) + absolute-path dup directory-entries [ [ append-path ] change-name ] with map ; : qualified-directory-files ( path -- seq ) - (normalize-path) + absolute-path dup directory-files [ append-path ] with map ; : with-qualified-directory-files ( path quot -- ) diff --git a/basis/io/encodings/8-bit/8-bit-docs.factor b/basis/io/encodings/8-bit/8-bit-docs.factor index 203d7c187f..b0677e80bd 100644 --- a/basis/io/encodings/8-bit/8-bit-docs.factor +++ b/basis/io/encodings/8-bit/8-bit-docs.factor @@ -5,106 +5,34 @@ strings ; IN: io.encodings.8-bit ARTICLE: "io.encodings.8-bit" "Legacy 8-bit encodings" -"Many encodings are a simple mapping of bytes onto characters. The " { $vocab-link "io.encodings.8-bit" } " vocabulary implements these generically using existing resource files. These encodings should be used with extreme caution, as fully general Unicode encodings like UTF-8 are nearly always more appropriate. The following 8-bit encodings are already defined:" -{ $subsections - latin1 - latin2 - latin3 - latin4 - latin/cyrillic - latin/arabic - latin/greek - latin/hebrew - latin5 - latin6 - latin/thai - latin7 - latin8 - latin9 - latin10 - koi8-r - windows-1252 - ebcdic - mac-roman +"Many encodings are a simple mapping of bytes onto characters. The " { $vocab-link "io.encodings.8-bit" } " vocabulary implements these generically using existing resource files. These encodings should be used with extreme caution, as fully general Unicode encodings like UTF-8 are nearly always more appropriate. The following 8-bit encodings are available:" +{ $list + { $vocab-link "io.encodings.8-bit.ebcdic" } + { $vocab-link "io.encodings.8-bit.latin1" } + { $vocab-link "io.encodings.8-bit.latin2" } + { $vocab-link "io.encodings.8-bit.latin3" } + { $vocab-link "io.encodings.8-bit.latin4" } + { $vocab-link "io.encodings.8-bit.cyrillic" } + { $vocab-link "io.encodings.8-bit.arabic" } + { $vocab-link "io.encodings.8-bit.greek" } + { $vocab-link "io.encodings.8-bit.hebrew" } + { $vocab-link "io.encodings.8-bit.latin5" } + { $vocab-link "io.encodings.8-bit.latin6" } + { $vocab-link "io.encodings.8-bit.thai" } + { $vocab-link "io.encodings.8-bit.latin7" } + { $vocab-link "io.encodings.8-bit.latin8" } + { $vocab-link "io.encodings.8-bit.latin9" } + { $vocab-link "io.encodings.8-bit.koi8-r" } + { $vocab-link "io.encodings.8-bit.mac-roman" } + { $vocab-link "io.encodings.8-bit.windows-1250" } + { $vocab-link "io.encodings.8-bit.windows-1251" } + { $vocab-link "io.encodings.8-bit.windows-1252" } + { $vocab-link "io.encodings.8-bit.windows-1253" } + { $vocab-link "io.encodings.8-bit.windows-1254" } + { $vocab-link "io.encodings.8-bit.windows-1255" } + { $vocab-link "io.encodings.8-bit.windows-1256" } + { $vocab-link "io.encodings.8-bit.windows-1257" } + { $vocab-link "io.encodings.8-bit.windows-1258" } } ; ABOUT: "io.encodings.8-bit" - -HELP: 8-bit -{ $class-description "Describes an 8-bit encoding, including its name (a symbol) and a table used for encoding and decoding." } ; - -HELP: latin1 -{ $description "This is the ISO-8859-1 encoding, also called Latin-1: Western European. It is an 8-bit superset of ASCII which is the default for a mimetype starting with 'text' and provides the characters necessary for most western European languages." } -{ $see-also "encodings-introduction" } ; - -HELP: latin2 -{ $description "This is the ISO-8859-2 encoding, also called Latin-2: Eastern European. It is an 8-bit superset of ASCII and provides the characters necessary for most eastern European languages." } -{ $see-also "encodings-introduction" } ; - -HELP: latin3 -{ $description "This is the ISO-8859-3 encoding, also called Latin-3: South European. It is an 8-bit superset of ASCII and provides the characters necessary for Turkish, Maltese and Esperanto." } -{ $see-also "encodings-introduction" } ; - -HELP: latin4 -{ $description "This is the ISO-8859-4 encoding, also called Latin-4: North European. It is an 8-bit superset of ASCII and provides the characters necessary for Latvian, Lithuanian, Estonian, Greenlandic and Sami." } -{ $see-also "encodings-introduction" } ; - -HELP: latin/cyrillic -{ $description "This is the ISO-8859-5 encoding, also called Latin/Cyrillic. It is an 8-bit superset of ASCII and provides the characters necessary for most languages which use Cyrilic, including Russian, Macedonian, Belarusian, Bulgarian, Serbian, and Ukrainian. KOI8-R is used much more commonly." } -{ $see-also "encodings-introduction" } ; - -HELP: latin/arabic -{ $description "This is the ISO-8859-6 encoding, also called Latin/Arabic. It is an 8-bit superset of ASCII and provides the characters necessary for Arabic, though not other languages which use Arabic script." } -{ $see-also "encodings-introduction" } ; - -HELP: latin/greek -{ $description "This is the ISO-8859-7 encoding, also called Latin/Greek. It is an 8-bit superset of ASCII and provides the characters necessary for Greek written in modern monotonic orthography, or ancient Greek without accent marks." } -{ $see-also "encodings-introduction" } ; - -HELP: latin/hebrew -{ $description "This is the ISO-8859-8 encoding, also called Latin/Hebrew. It is an 8-bit superset of ASCII and provides the characters necessary for modern Hebrew without explicit vowels. Generally, this is interpreted in logical order, making it ISO-8859-8-I, technically." } -{ $see-also "encodings-introduction" } ; - -HELP: latin5 -{ $description "This is the ISO-8859-9 encoding, also called Latin-5: Turkish. It is an 8-bit superset of ASCII and provides the characters necessary for Turkish, similar to Latin-1 but replacing the spots used for Icelandic with characters used in Turkish." } -{ $see-also "encodings-introduction" } ; - -HELP: latin6 -{ $description "This is the ISO-8859-10 encoding, also called Latin-6: Nordic. It is an 8-bit superset of ASCII containing the same characters as Latin-4, but rearranged to be of better use to nordic languages." } -{ $see-also "encodings-introduction" } ; - -HELP: latin/thai -{ $description "This is the ISO-8859-11 encoding, also called Latin/Thai. It is an 8-bit superset of ASCII containing the characters necessary to represent Thai. It is basically identical to TIS-620." } -{ $see-also "encodings-introduction" } ; - -HELP: latin7 -{ $description "This is the ISO-8859-13 encoding, also called Latin-7: Baltic Rim. It is an 8-bit superset of ASCII containing all characters necesary to represent Baltic Rim languages, as previous character sets were incomplete." } -{ $see-also "encodings-introduction" } ; - -HELP: latin8 -{ $description "This is the ISO-8859-14 encoding, also called Latin-8: Celtic. It is an 8-bit superset of ASCII designed for Celtic languages like Gaelic and Breton." } -{ $see-also "encodings-introduction" } ; - -HELP: latin9 -{ $description "This is the ISO-8859-15 encoding, also called Latin-9 and unoffically as Latin-0. It is an 8-bit superset of ASCII designed as a modification of Latin-1, removing little-used characters in favor of the Euro symbol and other characters." } -{ $see-also "encodings-introduction" } ; - -HELP: latin10 -{ $description "This is the ISO-8859-16 encoding, also called Latin-10: South-Eastern European. It is an 8-bit superset of ASCII." } -{ $see-also "encodings-introduction" } ; - -HELP: windows-1252 -{ $description "Windows 1252 is an 8-bit superset of ASCII which is closely related to Latin-1. Control characters in the 0x80 to 0x9F range are replaced with printable characters such as the Euro symbol." } -{ $see-also "encodings-introduction" } ; - -HELP: ebcdic -{ $description "EBCDIC is an 8-bit legacy encoding designed for IBM mainframes like System/360 in the 1960s. It has since fallen into disuse. It contains large unallocated regions, and the version included here (code page 37) contains auxiliary characters in this region for English- and Portugese-speaking countries." } -{ $see-also "encodings-introduction" } ; - -HELP: mac-roman -{ $description "Mac Roman is an 8-bit superset of ASCII which was the standard encoding on Mac OS prior to version 10. It is incompatible with Latin-1 in all but a few places and ASCII, and it is suitable for encoding many Western European languages." } -{ $see-also "encodings-introduction" } ; - -HELP: koi8-r -{ $description "KOI8-R is an 8-bit superset of ASCII which encodes the Cyrillic alphabet, as used in Russian and Bulgarian. Characters are in such an order that, if the eight bit is stripped, text is still interpretable as ASCII. Block-building characters also exist." } -{ $see-also "encodings-introduction" } ; diff --git a/basis/io/encodings/8-bit/8-bit-tests.factor b/basis/io/encodings/8-bit/8-bit-tests.factor index 55b9c44934..5178630f0f 100644 --- a/basis/io/encodings/8-bit/8-bit-tests.factor +++ b/basis/io/encodings/8-bit/8-bit-tests.factor @@ -1,5 +1,6 @@ USING: io.encodings.string io.encodings.8-bit -io.encodings.8-bit.private tools.test strings arrays ; +io.encodings.8-bit.private tools.test strings arrays +io.encodings.8-bit.latin1 io.encodings.8-bit.windows-1252 ; IN: io.encodings.8-bit.tests [ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test diff --git a/basis/io/encodings/8-bit/8-bit.factor b/basis/io/encodings/8-bit/8-bit.factor index bba22268c6..7f92028c31 100644 --- a/basis/io/encodings/8-bit/8-bit.factor +++ b/basis/io/encodings/8-bit/8-bit.factor @@ -1,41 +1,19 @@ -! Copyright (C) 2008 Daniel Ehrenberg +! Copyright (C) 2008 Daniel Ehrenberg, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: math.parser arrays io.encodings sequences kernel assocs hashtables io.encodings.ascii generic parser classes.tuple words words.symbol io io.files splitting namespaces math compiler.units accessors classes.singleton classes.mixin -io.encodings.iana fry simple-flat-file ; +io.encodings.iana fry simple-flat-file lexer ; IN: io.encodings.8-bit 8-bit-encodings get-global at ; : create-encoding ( name -- word ) - "io.encodings.8-bit" create + create-in [ define-singleton-class ] [ 8-bit-encoding add-mixin-instance ] [ ] tri ; +: load-encoding ( name iana-name file-name -- ) + [ create-encoding dup ] + [ register-encoding ] + [ encoding-file flat-file>biassoc 8-bit boa ] tri* + swap 8-bit-encodings get-global set-at ; + PRIVATE> -[ - mappings [ - first3 - [ create-encoding ] - [ dupd register-encoding ] - [ encoding-file flat-file>biassoc 8-bit boa ] - tri* - ] H{ } map>assoc - 8-bit-encodings set-global -] with-compilation-unit +SYNTAX: 8-BIT: scan scan scan load-encoding ; diff --git a/basis/io/encodings/8-bit/CP1250.TXT b/basis/io/encodings/8-bit/CP1250.TXT new file mode 100644 index 0000000000..6bfab9380d --- /dev/null +++ b/basis/io/encodings/8-bit/CP1250.TXT @@ -0,0 +1,274 @@ +# +# Name: cp1250 to Unicode table +# Unicode version: 2.0 +# Table version: 2.01 +# Table format: Format A +# Date: 04/15/98 +# +# Contact: Shawn.Steele@microsoft.com +# +# General notes: none +# +# Format: Three tab-separated columns +# Column #1 is the cp1250 code (in hex) +# Column #2 is the Unicode (in hex as 0xXXXX) +# Column #3 is the Unicode name (follows a comment sign, '#') +# +# The entries are in cp1250 order +# +0x00 0x0000 #NULL +0x01 0x0001 #START OF HEADING +0x02 0x0002 #START OF TEXT +0x03 0x0003 #END OF TEXT +0x04 0x0004 #END OF TRANSMISSION +0x05 0x0005 #ENQUIRY +0x06 0x0006 #ACKNOWLEDGE +0x07 0x0007 #BELL +0x08 0x0008 #BACKSPACE +0x09 0x0009 #HORIZONTAL TABULATION +0x0A 0x000A #LINE FEED +0x0B 0x000B #VERTICAL TABULATION +0x0C 0x000C #FORM FEED +0x0D 0x000D #CARRIAGE RETURN +0x0E 0x000E #SHIFT OUT +0x0F 0x000F #SHIFT IN +0x10 0x0010 #DATA LINK ESCAPE +0x11 0x0011 #DEVICE CONTROL ONE +0x12 0x0012 #DEVICE CONTROL TWO +0x13 0x0013 #DEVICE CONTROL THREE +0x14 0x0014 #DEVICE CONTROL FOUR +0x15 0x0015 #NEGATIVE ACKNOWLEDGE +0x16 0x0016 #SYNCHRONOUS IDLE +0x17 0x0017 #END OF TRANSMISSION BLOCK +0x18 0x0018 #CANCEL +0x19 0x0019 #END OF MEDIUM +0x1A 0x001A #SUBSTITUTE +0x1B 0x001B #ESCAPE +0x1C 0x001C #FILE SEPARATOR +0x1D 0x001D #GROUP SEPARATOR +0x1E 0x001E #RECORD SEPARATOR +0x1F 0x001F #UNIT SEPARATOR +0x20 0x0020 #SPACE +0x21 0x0021 #EXCLAMATION MARK +0x22 0x0022 #QUOTATION MARK +0x23 0x0023 #NUMBER SIGN +0x24 0x0024 #DOLLAR SIGN +0x25 0x0025 #PERCENT SIGN +0x26 0x0026 #AMPERSAND +0x27 0x0027 #APOSTROPHE +0x28 0x0028 #LEFT PARENTHESIS +0x29 0x0029 #RIGHT PARENTHESIS +0x2A 0x002A #ASTERISK +0x2B 0x002B #PLUS SIGN +0x2C 0x002C #COMMA +0x2D 0x002D #HYPHEN-MINUS +0x2E 0x002E #FULL STOP +0x2F 0x002F #SOLIDUS +0x30 0x0030 #DIGIT ZERO +0x31 0x0031 #DIGIT ONE +0x32 0x0032 #DIGIT TWO +0x33 0x0033 #DIGIT THREE +0x34 0x0034 #DIGIT FOUR +0x35 0x0035 #DIGIT FIVE +0x36 0x0036 #DIGIT SIX +0x37 0x0037 #DIGIT SEVEN +0x38 0x0038 #DIGIT EIGHT +0x39 0x0039 #DIGIT NINE +0x3A 0x003A #COLON +0x3B 0x003B #SEMICOLON +0x3C 0x003C #LESS-THAN SIGN +0x3D 0x003D #EQUALS SIGN +0x3E 0x003E #GREATER-THAN SIGN +0x3F 0x003F #QUESTION MARK +0x40 0x0040 #COMMERCIAL AT +0x41 0x0041 #LATIN CAPITAL LETTER A +0x42 0x0042 #LATIN CAPITAL LETTER B +0x43 0x0043 #LATIN CAPITAL LETTER C +0x44 0x0044 #LATIN CAPITAL LETTER D +0x45 0x0045 #LATIN CAPITAL LETTER E +0x46 0x0046 #LATIN CAPITAL LETTER F +0x47 0x0047 #LATIN CAPITAL LETTER G +0x48 0x0048 #LATIN CAPITAL LETTER H +0x49 0x0049 #LATIN CAPITAL LETTER I +0x4A 0x004A #LATIN CAPITAL LETTER J +0x4B 0x004B #LATIN CAPITAL LETTER K +0x4C 0x004C #LATIN CAPITAL LETTER L +0x4D 0x004D #LATIN CAPITAL LETTER M +0x4E 0x004E #LATIN CAPITAL LETTER N +0x4F 0x004F #LATIN CAPITAL LETTER O +0x50 0x0050 #LATIN CAPITAL LETTER P +0x51 0x0051 #LATIN CAPITAL LETTER Q +0x52 0x0052 #LATIN CAPITAL LETTER R +0x53 0x0053 #LATIN CAPITAL LETTER S +0x54 0x0054 #LATIN CAPITAL LETTER T +0x55 0x0055 #LATIN CAPITAL LETTER U +0x56 0x0056 #LATIN CAPITAL LETTER V +0x57 0x0057 #LATIN CAPITAL LETTER W +0x58 0x0058 #LATIN CAPITAL LETTER X +0x59 0x0059 #LATIN CAPITAL LETTER Y +0x5A 0x005A #LATIN CAPITAL LETTER Z +0x5B 0x005B #LEFT SQUARE BRACKET +0x5C 0x005C #REVERSE SOLIDUS +0x5D 0x005D #RIGHT SQUARE BRACKET +0x5E 0x005E #CIRCUMFLEX ACCENT +0x5F 0x005F #LOW LINE +0x60 0x0060 #GRAVE ACCENT +0x61 0x0061 #LATIN SMALL LETTER A +0x62 0x0062 #LATIN SMALL LETTER B +0x63 0x0063 #LATIN SMALL LETTER C +0x64 0x0064 #LATIN SMALL LETTER D +0x65 0x0065 #LATIN SMALL LETTER E +0x66 0x0066 #LATIN SMALL LETTER F +0x67 0x0067 #LATIN SMALL LETTER G +0x68 0x0068 #LATIN SMALL LETTER H +0x69 0x0069 #LATIN SMALL LETTER I +0x6A 0x006A #LATIN SMALL LETTER J +0x6B 0x006B #LATIN SMALL LETTER K +0x6C 0x006C #LATIN SMALL LETTER L +0x6D 0x006D #LATIN SMALL LETTER M +0x6E 0x006E #LATIN SMALL LETTER N +0x6F 0x006F #LATIN SMALL LETTER O +0x70 0x0070 #LATIN SMALL LETTER P +0x71 0x0071 #LATIN SMALL LETTER Q +0x72 0x0072 #LATIN SMALL LETTER R +0x73 0x0073 #LATIN SMALL LETTER S +0x74 0x0074 #LATIN SMALL LETTER T +0x75 0x0075 #LATIN SMALL LETTER U +0x76 0x0076 #LATIN SMALL LETTER V +0x77 0x0077 #LATIN SMALL LETTER W +0x78 0x0078 #LATIN SMALL LETTER X +0x79 0x0079 #LATIN SMALL LETTER Y +0x7A 0x007A #LATIN SMALL LETTER Z +0x7B 0x007B #LEFT CURLY BRACKET +0x7C 0x007C #VERTICAL LINE +0x7D 0x007D #RIGHT CURLY BRACKET +0x7E 0x007E #TILDE +0x7F 0x007F #DELETE +0x80 0x20AC #EURO SIGN +0x81 #UNDEFINED +0x82 0x201A #SINGLE LOW-9 QUOTATION MARK +0x83 #UNDEFINED +0x84 0x201E #DOUBLE LOW-9 QUOTATION MARK +0x85 0x2026 #HORIZONTAL ELLIPSIS +0x86 0x2020 #DAGGER +0x87 0x2021 #DOUBLE DAGGER +0x88 #UNDEFINED +0x89 0x2030 #PER MILLE SIGN +0x8A 0x0160 #LATIN CAPITAL LETTER S WITH CARON +0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK +0x8C 0x015A #LATIN CAPITAL LETTER S WITH ACUTE +0x8D 0x0164 #LATIN CAPITAL LETTER T WITH CARON +0x8E 0x017D #LATIN CAPITAL LETTER Z WITH CARON +0x8F 0x0179 #LATIN CAPITAL LETTER Z WITH ACUTE +0x90 #UNDEFINED +0x91 0x2018 #LEFT SINGLE QUOTATION MARK +0x92 0x2019 #RIGHT SINGLE QUOTATION MARK +0x93 0x201C #LEFT DOUBLE QUOTATION MARK +0x94 0x201D #RIGHT DOUBLE QUOTATION MARK +0x95 0x2022 #BULLET +0x96 0x2013 #EN DASH +0x97 0x2014 #EM DASH +0x98 #UNDEFINED +0x99 0x2122 #TRADE MARK SIGN +0x9A 0x0161 #LATIN SMALL LETTER S WITH CARON +0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK +0x9C 0x015B #LATIN SMALL LETTER S WITH ACUTE +0x9D 0x0165 #LATIN SMALL LETTER T WITH CARON +0x9E 0x017E #LATIN SMALL LETTER Z WITH CARON +0x9F 0x017A #LATIN SMALL LETTER Z WITH ACUTE +0xA0 0x00A0 #NO-BREAK SPACE +0xA1 0x02C7 #CARON +0xA2 0x02D8 #BREVE +0xA3 0x0141 #LATIN CAPITAL LETTER L WITH STROKE +0xA4 0x00A4 #CURRENCY SIGN +0xA5 0x0104 #LATIN CAPITAL LETTER A WITH OGONEK +0xA6 0x00A6 #BROKEN BAR +0xA7 0x00A7 #SECTION SIGN +0xA8 0x00A8 #DIAERESIS +0xA9 0x00A9 #COPYRIGHT SIGN +0xAA 0x015E #LATIN CAPITAL LETTER S WITH CEDILLA +0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK +0xAC 0x00AC #NOT SIGN +0xAD 0x00AD #SOFT HYPHEN +0xAE 0x00AE #REGISTERED SIGN +0xAF 0x017B #LATIN CAPITAL LETTER Z WITH DOT ABOVE +0xB0 0x00B0 #DEGREE SIGN +0xB1 0x00B1 #PLUS-MINUS SIGN +0xB2 0x02DB #OGONEK +0xB3 0x0142 #LATIN SMALL LETTER L WITH STROKE +0xB4 0x00B4 #ACUTE ACCENT +0xB5 0x00B5 #MICRO SIGN +0xB6 0x00B6 #PILCROW SIGN +0xB7 0x00B7 #MIDDLE DOT +0xB8 0x00B8 #CEDILLA +0xB9 0x0105 #LATIN SMALL LETTER A WITH OGONEK +0xBA 0x015F #LATIN SMALL LETTER S WITH CEDILLA +0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK +0xBC 0x013D #LATIN CAPITAL LETTER L WITH CARON +0xBD 0x02DD #DOUBLE ACUTE ACCENT +0xBE 0x013E #LATIN SMALL LETTER L WITH CARON +0xBF 0x017C #LATIN SMALL LETTER Z WITH DOT ABOVE +0xC0 0x0154 #LATIN CAPITAL LETTER R WITH ACUTE +0xC1 0x00C1 #LATIN CAPITAL LETTER A WITH ACUTE +0xC2 0x00C2 #LATIN CAPITAL LETTER A WITH CIRCUMFLEX +0xC3 0x0102 #LATIN CAPITAL LETTER A WITH BREVE +0xC4 0x00C4 #LATIN CAPITAL LETTER A WITH DIAERESIS +0xC5 0x0139 #LATIN CAPITAL LETTER L WITH ACUTE +0xC6 0x0106 #LATIN CAPITAL LETTER C WITH ACUTE +0xC7 0x00C7 #LATIN CAPITAL LETTER C WITH CEDILLA +0xC8 0x010C #LATIN CAPITAL LETTER C WITH CARON +0xC9 0x00C9 #LATIN CAPITAL LETTER E WITH ACUTE +0xCA 0x0118 #LATIN CAPITAL LETTER E WITH OGONEK +0xCB 0x00CB #LATIN CAPITAL LETTER E WITH DIAERESIS +0xCC 0x011A #LATIN CAPITAL LETTER E WITH CARON +0xCD 0x00CD #LATIN CAPITAL LETTER I WITH ACUTE +0xCE 0x00CE #LATIN CAPITAL LETTER I WITH CIRCUMFLEX +0xCF 0x010E #LATIN CAPITAL LETTER D WITH CARON +0xD0 0x0110 #LATIN CAPITAL LETTER D WITH STROKE +0xD1 0x0143 #LATIN CAPITAL LETTER N WITH ACUTE +0xD2 0x0147 #LATIN CAPITAL LETTER N WITH CARON +0xD3 0x00D3 #LATIN CAPITAL LETTER O WITH ACUTE +0xD4 0x00D4 #LATIN CAPITAL LETTER O WITH CIRCUMFLEX +0xD5 0x0150 #LATIN CAPITAL LETTER O WITH DOUBLE ACUTE +0xD6 0x00D6 #LATIN CAPITAL LETTER O WITH DIAERESIS +0xD7 0x00D7 #MULTIPLICATION SIGN +0xD8 0x0158 #LATIN CAPITAL LETTER R WITH CARON +0xD9 0x016E #LATIN CAPITAL LETTER U WITH RING ABOVE +0xDA 0x00DA #LATIN CAPITAL LETTER U WITH ACUTE +0xDB 0x0170 #LATIN CAPITAL LETTER U WITH DOUBLE ACUTE +0xDC 0x00DC #LATIN CAPITAL LETTER U WITH DIAERESIS +0xDD 0x00DD #LATIN CAPITAL LETTER Y WITH ACUTE +0xDE 0x0162 #LATIN CAPITAL LETTER T WITH CEDILLA +0xDF 0x00DF #LATIN SMALL LETTER SHARP S +0xE0 0x0155 #LATIN SMALL LETTER R WITH ACUTE +0xE1 0x00E1 #LATIN SMALL LETTER A WITH ACUTE +0xE2 0x00E2 #LATIN SMALL LETTER A WITH CIRCUMFLEX +0xE3 0x0103 #LATIN SMALL LETTER A WITH BREVE +0xE4 0x00E4 #LATIN SMALL LETTER A WITH DIAERESIS +0xE5 0x013A #LATIN SMALL LETTER L WITH ACUTE +0xE6 0x0107 #LATIN SMALL LETTER C WITH ACUTE +0xE7 0x00E7 #LATIN SMALL LETTER C WITH CEDILLA +0xE8 0x010D #LATIN SMALL LETTER C WITH CARON +0xE9 0x00E9 #LATIN SMALL LETTER E WITH ACUTE +0xEA 0x0119 #LATIN SMALL LETTER E WITH OGONEK +0xEB 0x00EB #LATIN SMALL LETTER E WITH DIAERESIS +0xEC 0x011B #LATIN SMALL LETTER E WITH CARON +0xED 0x00ED #LATIN SMALL LETTER I WITH ACUTE +0xEE 0x00EE #LATIN SMALL LETTER I WITH CIRCUMFLEX +0xEF 0x010F #LATIN SMALL LETTER D WITH CARON +0xF0 0x0111 #LATIN SMALL LETTER D WITH STROKE +0xF1 0x0144 #LATIN SMALL LETTER N WITH ACUTE +0xF2 0x0148 #LATIN SMALL LETTER N WITH CARON +0xF3 0x00F3 #LATIN SMALL LETTER O WITH ACUTE +0xF4 0x00F4 #LATIN SMALL LETTER O WITH CIRCUMFLEX +0xF5 0x0151 #LATIN SMALL LETTER O WITH DOUBLE ACUTE +0xF6 0x00F6 #LATIN SMALL LETTER O WITH DIAERESIS +0xF7 0x00F7 #DIVISION SIGN +0xF8 0x0159 #LATIN SMALL LETTER R WITH CARON +0xF9 0x016F #LATIN SMALL LETTER U WITH RING ABOVE +0xFA 0x00FA #LATIN SMALL LETTER U WITH ACUTE +0xFB 0x0171 #LATIN SMALL LETTER U WITH DOUBLE ACUTE +0xFC 0x00FC #LATIN SMALL LETTER U WITH DIAERESIS +0xFD 0x00FD #LATIN SMALL LETTER Y WITH ACUTE +0xFE 0x0163 #LATIN SMALL LETTER T WITH CEDILLA +0xFF 0x02D9 #DOT ABOVE diff --git a/basis/io/encodings/8-bit/CP1251.TXT b/basis/io/encodings/8-bit/CP1251.TXT new file mode 100644 index 0000000000..4d9b3558ac --- /dev/null +++ b/basis/io/encodings/8-bit/CP1251.TXT @@ -0,0 +1,274 @@ +# +# Name: cp1251 to Unicode table +# Unicode version: 2.0 +# Table version: 2.01 +# Table format: Format A +# Date: 04/15/98 +# +# Contact: Shawn.Steele@microsoft.com +# +# General notes: none +# +# Format: Three tab-separated columns +# Column #1 is the cp1251 code (in hex) +# Column #2 is the Unicode (in hex as 0xXXXX) +# Column #3 is the Unicode name (follows a comment sign, '#') +# +# The entries are in cp1251 order +# +0x00 0x0000 #NULL +0x01 0x0001 #START OF HEADING +0x02 0x0002 #START OF TEXT +0x03 0x0003 #END OF TEXT +0x04 0x0004 #END OF TRANSMISSION +0x05 0x0005 #ENQUIRY +0x06 0x0006 #ACKNOWLEDGE +0x07 0x0007 #BELL +0x08 0x0008 #BACKSPACE +0x09 0x0009 #HORIZONTAL TABULATION +0x0A 0x000A #LINE FEED +0x0B 0x000B #VERTICAL TABULATION +0x0C 0x000C #FORM FEED +0x0D 0x000D #CARRIAGE RETURN +0x0E 0x000E #SHIFT OUT +0x0F 0x000F #SHIFT IN +0x10 0x0010 #DATA LINK ESCAPE +0x11 0x0011 #DEVICE CONTROL ONE +0x12 0x0012 #DEVICE CONTROL TWO +0x13 0x0013 #DEVICE CONTROL THREE +0x14 0x0014 #DEVICE CONTROL FOUR +0x15 0x0015 #NEGATIVE ACKNOWLEDGE +0x16 0x0016 #SYNCHRONOUS IDLE +0x17 0x0017 #END OF TRANSMISSION BLOCK +0x18 0x0018 #CANCEL +0x19 0x0019 #END OF MEDIUM +0x1A 0x001A #SUBSTITUTE +0x1B 0x001B #ESCAPE +0x1C 0x001C #FILE SEPARATOR +0x1D 0x001D #GROUP SEPARATOR +0x1E 0x001E #RECORD SEPARATOR +0x1F 0x001F #UNIT SEPARATOR +0x20 0x0020 #SPACE +0x21 0x0021 #EXCLAMATION MARK +0x22 0x0022 #QUOTATION MARK +0x23 0x0023 #NUMBER SIGN +0x24 0x0024 #DOLLAR SIGN +0x25 0x0025 #PERCENT SIGN +0x26 0x0026 #AMPERSAND +0x27 0x0027 #APOSTROPHE +0x28 0x0028 #LEFT PARENTHESIS +0x29 0x0029 #RIGHT PARENTHESIS +0x2A 0x002A #ASTERISK +0x2B 0x002B #PLUS SIGN +0x2C 0x002C #COMMA +0x2D 0x002D #HYPHEN-MINUS +0x2E 0x002E #FULL STOP +0x2F 0x002F #SOLIDUS +0x30 0x0030 #DIGIT ZERO +0x31 0x0031 #DIGIT ONE +0x32 0x0032 #DIGIT TWO +0x33 0x0033 #DIGIT THREE +0x34 0x0034 #DIGIT FOUR +0x35 0x0035 #DIGIT FIVE +0x36 0x0036 #DIGIT SIX +0x37 0x0037 #DIGIT SEVEN +0x38 0x0038 #DIGIT EIGHT +0x39 0x0039 #DIGIT NINE +0x3A 0x003A #COLON +0x3B 0x003B #SEMICOLON +0x3C 0x003C #LESS-THAN SIGN +0x3D 0x003D #EQUALS SIGN +0x3E 0x003E #GREATER-THAN SIGN +0x3F 0x003F #QUESTION MARK +0x40 0x0040 #COMMERCIAL AT +0x41 0x0041 #LATIN CAPITAL LETTER A +0x42 0x0042 #LATIN CAPITAL LETTER B +0x43 0x0043 #LATIN CAPITAL LETTER C +0x44 0x0044 #LATIN CAPITAL LETTER D +0x45 0x0045 #LATIN CAPITAL LETTER E +0x46 0x0046 #LATIN CAPITAL LETTER F +0x47 0x0047 #LATIN CAPITAL LETTER G +0x48 0x0048 #LATIN CAPITAL LETTER H +0x49 0x0049 #LATIN CAPITAL LETTER I +0x4A 0x004A #LATIN CAPITAL LETTER J +0x4B 0x004B #LATIN CAPITAL LETTER K +0x4C 0x004C #LATIN CAPITAL LETTER L +0x4D 0x004D #LATIN CAPITAL LETTER M +0x4E 0x004E #LATIN CAPITAL LETTER N +0x4F 0x004F #LATIN CAPITAL LETTER O +0x50 0x0050 #LATIN CAPITAL LETTER P +0x51 0x0051 #LATIN CAPITAL LETTER Q +0x52 0x0052 #LATIN CAPITAL LETTER R +0x53 0x0053 #LATIN CAPITAL LETTER S +0x54 0x0054 #LATIN CAPITAL LETTER T +0x55 0x0055 #LATIN CAPITAL LETTER U +0x56 0x0056 #LATIN CAPITAL LETTER V +0x57 0x0057 #LATIN CAPITAL LETTER W +0x58 0x0058 #LATIN CAPITAL LETTER X +0x59 0x0059 #LATIN CAPITAL LETTER Y +0x5A 0x005A #LATIN CAPITAL LETTER Z +0x5B 0x005B #LEFT SQUARE BRACKET +0x5C 0x005C #REVERSE SOLIDUS +0x5D 0x005D #RIGHT SQUARE BRACKET +0x5E 0x005E #CIRCUMFLEX ACCENT +0x5F 0x005F #LOW LINE +0x60 0x0060 #GRAVE ACCENT +0x61 0x0061 #LATIN SMALL LETTER A +0x62 0x0062 #LATIN SMALL LETTER B +0x63 0x0063 #LATIN SMALL LETTER C +0x64 0x0064 #LATIN SMALL LETTER D +0x65 0x0065 #LATIN SMALL LETTER E +0x66 0x0066 #LATIN SMALL LETTER F +0x67 0x0067 #LATIN SMALL LETTER G +0x68 0x0068 #LATIN SMALL LETTER H +0x69 0x0069 #LATIN SMALL LETTER I +0x6A 0x006A #LATIN SMALL LETTER J +0x6B 0x006B #LATIN SMALL LETTER K +0x6C 0x006C #LATIN SMALL LETTER L +0x6D 0x006D #LATIN SMALL LETTER M +0x6E 0x006E #LATIN SMALL LETTER N +0x6F 0x006F #LATIN SMALL LETTER O +0x70 0x0070 #LATIN SMALL LETTER P +0x71 0x0071 #LATIN SMALL LETTER Q +0x72 0x0072 #LATIN SMALL LETTER R +0x73 0x0073 #LATIN SMALL LETTER S +0x74 0x0074 #LATIN SMALL LETTER T +0x75 0x0075 #LATIN SMALL LETTER U +0x76 0x0076 #LATIN SMALL LETTER V +0x77 0x0077 #LATIN SMALL LETTER W +0x78 0x0078 #LATIN SMALL LETTER X +0x79 0x0079 #LATIN SMALL LETTER Y +0x7A 0x007A #LATIN SMALL LETTER Z +0x7B 0x007B #LEFT CURLY BRACKET +0x7C 0x007C #VERTICAL LINE +0x7D 0x007D #RIGHT CURLY BRACKET +0x7E 0x007E #TILDE +0x7F 0x007F #DELETE +0x80 0x0402 #CYRILLIC CAPITAL LETTER DJE +0x81 0x0403 #CYRILLIC CAPITAL LETTER GJE +0x82 0x201A #SINGLE LOW-9 QUOTATION MARK +0x83 0x0453 #CYRILLIC SMALL LETTER GJE +0x84 0x201E #DOUBLE LOW-9 QUOTATION MARK +0x85 0x2026 #HORIZONTAL ELLIPSIS +0x86 0x2020 #DAGGER +0x87 0x2021 #DOUBLE DAGGER +0x88 0x20AC #EURO SIGN +0x89 0x2030 #PER MILLE SIGN +0x8A 0x0409 #CYRILLIC CAPITAL LETTER LJE +0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK +0x8C 0x040A #CYRILLIC CAPITAL LETTER NJE +0x8D 0x040C #CYRILLIC CAPITAL LETTER KJE +0x8E 0x040B #CYRILLIC CAPITAL LETTER TSHE +0x8F 0x040F #CYRILLIC CAPITAL LETTER DZHE +0x90 0x0452 #CYRILLIC SMALL LETTER DJE +0x91 0x2018 #LEFT SINGLE QUOTATION MARK +0x92 0x2019 #RIGHT SINGLE QUOTATION MARK +0x93 0x201C #LEFT DOUBLE QUOTATION MARK +0x94 0x201D #RIGHT DOUBLE QUOTATION MARK +0x95 0x2022 #BULLET +0x96 0x2013 #EN DASH +0x97 0x2014 #EM DASH +0x98 #UNDEFINED +0x99 0x2122 #TRADE MARK SIGN +0x9A 0x0459 #CYRILLIC SMALL LETTER LJE +0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK +0x9C 0x045A #CYRILLIC SMALL LETTER NJE +0x9D 0x045C #CYRILLIC SMALL LETTER KJE +0x9E 0x045B #CYRILLIC SMALL LETTER TSHE +0x9F 0x045F #CYRILLIC SMALL LETTER DZHE +0xA0 0x00A0 #NO-BREAK SPACE +0xA1 0x040E #CYRILLIC CAPITAL LETTER SHORT U +0xA2 0x045E #CYRILLIC SMALL LETTER SHORT U +0xA3 0x0408 #CYRILLIC CAPITAL LETTER JE +0xA4 0x00A4 #CURRENCY SIGN +0xA5 0x0490 #CYRILLIC CAPITAL LETTER GHE WITH UPTURN +0xA6 0x00A6 #BROKEN BAR +0xA7 0x00A7 #SECTION SIGN +0xA8 0x0401 #CYRILLIC CAPITAL LETTER IO +0xA9 0x00A9 #COPYRIGHT SIGN +0xAA 0x0404 #CYRILLIC CAPITAL LETTER UKRAINIAN IE +0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK +0xAC 0x00AC #NOT SIGN +0xAD 0x00AD #SOFT HYPHEN +0xAE 0x00AE #REGISTERED SIGN +0xAF 0x0407 #CYRILLIC CAPITAL LETTER YI +0xB0 0x00B0 #DEGREE SIGN +0xB1 0x00B1 #PLUS-MINUS SIGN +0xB2 0x0406 #CYRILLIC CAPITAL LETTER BYELORUSSIAN-UKRAINIAN I +0xB3 0x0456 #CYRILLIC SMALL LETTER BYELORUSSIAN-UKRAINIAN I +0xB4 0x0491 #CYRILLIC SMALL LETTER GHE WITH UPTURN +0xB5 0x00B5 #MICRO SIGN +0xB6 0x00B6 #PILCROW SIGN +0xB7 0x00B7 #MIDDLE DOT +0xB8 0x0451 #CYRILLIC SMALL LETTER IO +0xB9 0x2116 #NUMERO SIGN +0xBA 0x0454 #CYRILLIC SMALL LETTER UKRAINIAN IE +0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK +0xBC 0x0458 #CYRILLIC SMALL LETTER JE +0xBD 0x0405 #CYRILLIC CAPITAL LETTER DZE +0xBE 0x0455 #CYRILLIC SMALL LETTER DZE +0xBF 0x0457 #CYRILLIC SMALL LETTER YI +0xC0 0x0410 #CYRILLIC CAPITAL LETTER A +0xC1 0x0411 #CYRILLIC CAPITAL LETTER BE +0xC2 0x0412 #CYRILLIC CAPITAL LETTER VE +0xC3 0x0413 #CYRILLIC CAPITAL LETTER GHE +0xC4 0x0414 #CYRILLIC CAPITAL LETTER DE +0xC5 0x0415 #CYRILLIC CAPITAL LETTER IE +0xC6 0x0416 #CYRILLIC CAPITAL LETTER ZHE +0xC7 0x0417 #CYRILLIC CAPITAL LETTER ZE +0xC8 0x0418 #CYRILLIC CAPITAL LETTER I +0xC9 0x0419 #CYRILLIC CAPITAL LETTER SHORT I +0xCA 0x041A #CYRILLIC CAPITAL LETTER KA +0xCB 0x041B #CYRILLIC CAPITAL LETTER EL +0xCC 0x041C #CYRILLIC CAPITAL LETTER EM +0xCD 0x041D #CYRILLIC CAPITAL LETTER EN +0xCE 0x041E #CYRILLIC CAPITAL LETTER O +0xCF 0x041F #CYRILLIC CAPITAL LETTER PE +0xD0 0x0420 #CYRILLIC CAPITAL LETTER ER +0xD1 0x0421 #CYRILLIC CAPITAL LETTER ES +0xD2 0x0422 #CYRILLIC CAPITAL LETTER TE +0xD3 0x0423 #CYRILLIC CAPITAL LETTER U +0xD4 0x0424 #CYRILLIC CAPITAL LETTER EF +0xD5 0x0425 #CYRILLIC CAPITAL LETTER HA +0xD6 0x0426 #CYRILLIC CAPITAL LETTER TSE +0xD7 0x0427 #CYRILLIC CAPITAL LETTER CHE +0xD8 0x0428 #CYRILLIC CAPITAL LETTER SHA +0xD9 0x0429 #CYRILLIC CAPITAL LETTER SHCHA +0xDA 0x042A #CYRILLIC CAPITAL LETTER HARD SIGN +0xDB 0x042B #CYRILLIC CAPITAL LETTER YERU +0xDC 0x042C #CYRILLIC CAPITAL LETTER SOFT SIGN +0xDD 0x042D #CYRILLIC CAPITAL LETTER E +0xDE 0x042E #CYRILLIC CAPITAL LETTER YU +0xDF 0x042F #CYRILLIC CAPITAL LETTER YA +0xE0 0x0430 #CYRILLIC SMALL LETTER A +0xE1 0x0431 #CYRILLIC SMALL LETTER BE +0xE2 0x0432 #CYRILLIC SMALL LETTER VE +0xE3 0x0433 #CYRILLIC SMALL LETTER GHE +0xE4 0x0434 #CYRILLIC SMALL LETTER DE +0xE5 0x0435 #CYRILLIC SMALL LETTER IE +0xE6 0x0436 #CYRILLIC SMALL LETTER ZHE +0xE7 0x0437 #CYRILLIC SMALL LETTER ZE +0xE8 0x0438 #CYRILLIC SMALL LETTER I +0xE9 0x0439 #CYRILLIC SMALL LETTER SHORT I +0xEA 0x043A #CYRILLIC SMALL LETTER KA +0xEB 0x043B #CYRILLIC SMALL LETTER EL +0xEC 0x043C #CYRILLIC SMALL LETTER EM +0xED 0x043D #CYRILLIC SMALL LETTER EN +0xEE 0x043E #CYRILLIC SMALL LETTER O +0xEF 0x043F #CYRILLIC SMALL LETTER PE +0xF0 0x0440 #CYRILLIC SMALL LETTER ER +0xF1 0x0441 #CYRILLIC SMALL LETTER ES +0xF2 0x0442 #CYRILLIC SMALL LETTER TE +0xF3 0x0443 #CYRILLIC SMALL LETTER U +0xF4 0x0444 #CYRILLIC SMALL LETTER EF +0xF5 0x0445 #CYRILLIC SMALL LETTER HA +0xF6 0x0446 #CYRILLIC SMALL LETTER TSE +0xF7 0x0447 #CYRILLIC SMALL LETTER CHE +0xF8 0x0448 #CYRILLIC SMALL LETTER SHA +0xF9 0x0449 #CYRILLIC SMALL LETTER SHCHA +0xFA 0x044A #CYRILLIC SMALL LETTER HARD SIGN +0xFB 0x044B #CYRILLIC SMALL LETTER YERU +0xFC 0x044C #CYRILLIC SMALL LETTER SOFT SIGN +0xFD 0x044D #CYRILLIC SMALL LETTER E +0xFE 0x044E #CYRILLIC SMALL LETTER YU +0xFF 0x044F #CYRILLIC SMALL LETTER YA diff --git a/basis/io/encodings/8-bit/CP1253.TXT b/basis/io/encodings/8-bit/CP1253.TXT new file mode 100644 index 0000000000..20a55b04df --- /dev/null +++ b/basis/io/encodings/8-bit/CP1253.TXT @@ -0,0 +1,274 @@ +# +# Name: cp1253 to Unicode table +# Unicode version: 2.0 +# Table version: 2.01 +# Table format: Format A +# Date: 04/15/98 +# +# Contact: Shawn.Steele@microsoft.com +# +# General notes: none +# +# Format: Three tab-separated columns +# Column #1 is the cp1253 code (in hex) +# Column #2 is the Unicode (in hex as 0xXXXX) +# Column #3 is the Unicode name (follows a comment sign, '#') +# +# The entries are in cp1253 order +# +0x00 0x0000 #NULL +0x01 0x0001 #START OF HEADING +0x02 0x0002 #START OF TEXT +0x03 0x0003 #END OF TEXT +0x04 0x0004 #END OF TRANSMISSION +0x05 0x0005 #ENQUIRY +0x06 0x0006 #ACKNOWLEDGE +0x07 0x0007 #BELL +0x08 0x0008 #BACKSPACE +0x09 0x0009 #HORIZONTAL TABULATION +0x0A 0x000A #LINE FEED +0x0B 0x000B #VERTICAL TABULATION +0x0C 0x000C #FORM FEED +0x0D 0x000D #CARRIAGE RETURN +0x0E 0x000E #SHIFT OUT +0x0F 0x000F #SHIFT IN +0x10 0x0010 #DATA LINK ESCAPE +0x11 0x0011 #DEVICE CONTROL ONE +0x12 0x0012 #DEVICE CONTROL TWO +0x13 0x0013 #DEVICE CONTROL THREE +0x14 0x0014 #DEVICE CONTROL FOUR +0x15 0x0015 #NEGATIVE ACKNOWLEDGE +0x16 0x0016 #SYNCHRONOUS IDLE +0x17 0x0017 #END OF TRANSMISSION BLOCK +0x18 0x0018 #CANCEL +0x19 0x0019 #END OF MEDIUM +0x1A 0x001A #SUBSTITUTE +0x1B 0x001B #ESCAPE +0x1C 0x001C #FILE SEPARATOR +0x1D 0x001D #GROUP SEPARATOR +0x1E 0x001E #RECORD SEPARATOR +0x1F 0x001F #UNIT SEPARATOR +0x20 0x0020 #SPACE +0x21 0x0021 #EXCLAMATION MARK +0x22 0x0022 #QUOTATION MARK +0x23 0x0023 #NUMBER SIGN +0x24 0x0024 #DOLLAR SIGN +0x25 0x0025 #PERCENT SIGN +0x26 0x0026 #AMPERSAND +0x27 0x0027 #APOSTROPHE +0x28 0x0028 #LEFT PARENTHESIS +0x29 0x0029 #RIGHT PARENTHESIS +0x2A 0x002A #ASTERISK +0x2B 0x002B #PLUS SIGN +0x2C 0x002C #COMMA +0x2D 0x002D #HYPHEN-MINUS +0x2E 0x002E #FULL STOP +0x2F 0x002F #SOLIDUS +0x30 0x0030 #DIGIT ZERO +0x31 0x0031 #DIGIT ONE +0x32 0x0032 #DIGIT TWO +0x33 0x0033 #DIGIT THREE +0x34 0x0034 #DIGIT FOUR +0x35 0x0035 #DIGIT FIVE +0x36 0x0036 #DIGIT SIX +0x37 0x0037 #DIGIT SEVEN +0x38 0x0038 #DIGIT EIGHT +0x39 0x0039 #DIGIT NINE +0x3A 0x003A #COLON +0x3B 0x003B #SEMICOLON +0x3C 0x003C #LESS-THAN SIGN +0x3D 0x003D #EQUALS SIGN +0x3E 0x003E #GREATER-THAN SIGN +0x3F 0x003F #QUESTION MARK +0x40 0x0040 #COMMERCIAL AT +0x41 0x0041 #LATIN CAPITAL LETTER A +0x42 0x0042 #LATIN CAPITAL LETTER B +0x43 0x0043 #LATIN CAPITAL LETTER C +0x44 0x0044 #LATIN CAPITAL LETTER D +0x45 0x0045 #LATIN CAPITAL LETTER E +0x46 0x0046 #LATIN CAPITAL LETTER F +0x47 0x0047 #LATIN CAPITAL LETTER G +0x48 0x0048 #LATIN CAPITAL LETTER H +0x49 0x0049 #LATIN CAPITAL LETTER I +0x4A 0x004A #LATIN CAPITAL LETTER J +0x4B 0x004B #LATIN CAPITAL LETTER K +0x4C 0x004C #LATIN CAPITAL LETTER L +0x4D 0x004D #LATIN CAPITAL LETTER M +0x4E 0x004E #LATIN CAPITAL LETTER N +0x4F 0x004F #LATIN CAPITAL LETTER O +0x50 0x0050 #LATIN CAPITAL LETTER P +0x51 0x0051 #LATIN CAPITAL LETTER Q +0x52 0x0052 #LATIN CAPITAL LETTER R +0x53 0x0053 #LATIN CAPITAL LETTER S +0x54 0x0054 #LATIN CAPITAL LETTER T +0x55 0x0055 #LATIN CAPITAL LETTER U +0x56 0x0056 #LATIN CAPITAL LETTER V +0x57 0x0057 #LATIN CAPITAL LETTER W +0x58 0x0058 #LATIN CAPITAL LETTER X +0x59 0x0059 #LATIN CAPITAL LETTER Y +0x5A 0x005A #LATIN CAPITAL LETTER Z +0x5B 0x005B #LEFT SQUARE BRACKET +0x5C 0x005C #REVERSE SOLIDUS +0x5D 0x005D #RIGHT SQUARE BRACKET +0x5E 0x005E #CIRCUMFLEX ACCENT +0x5F 0x005F #LOW LINE +0x60 0x0060 #GRAVE ACCENT +0x61 0x0061 #LATIN SMALL LETTER A +0x62 0x0062 #LATIN SMALL LETTER B +0x63 0x0063 #LATIN SMALL LETTER C +0x64 0x0064 #LATIN SMALL LETTER D +0x65 0x0065 #LATIN SMALL LETTER E +0x66 0x0066 #LATIN SMALL LETTER F +0x67 0x0067 #LATIN SMALL LETTER G +0x68 0x0068 #LATIN SMALL LETTER H +0x69 0x0069 #LATIN SMALL LETTER I +0x6A 0x006A #LATIN SMALL LETTER J +0x6B 0x006B #LATIN SMALL LETTER K +0x6C 0x006C #LATIN SMALL LETTER L +0x6D 0x006D #LATIN SMALL LETTER M +0x6E 0x006E #LATIN SMALL LETTER N +0x6F 0x006F #LATIN SMALL LETTER O +0x70 0x0070 #LATIN SMALL LETTER P +0x71 0x0071 #LATIN SMALL LETTER Q +0x72 0x0072 #LATIN SMALL LETTER R +0x73 0x0073 #LATIN SMALL LETTER S +0x74 0x0074 #LATIN SMALL LETTER T +0x75 0x0075 #LATIN SMALL LETTER U +0x76 0x0076 #LATIN SMALL LETTER V +0x77 0x0077 #LATIN SMALL LETTER W +0x78 0x0078 #LATIN SMALL LETTER X +0x79 0x0079 #LATIN SMALL LETTER Y +0x7A 0x007A #LATIN SMALL LETTER Z +0x7B 0x007B #LEFT CURLY BRACKET +0x7C 0x007C #VERTICAL LINE +0x7D 0x007D #RIGHT CURLY BRACKET +0x7E 0x007E #TILDE +0x7F 0x007F #DELETE +0x80 0x20AC #EURO SIGN +0x81 #UNDEFINED +0x82 0x201A #SINGLE LOW-9 QUOTATION MARK +0x83 0x0192 #LATIN SMALL LETTER F WITH HOOK +0x84 0x201E #DOUBLE LOW-9 QUOTATION MARK +0x85 0x2026 #HORIZONTAL ELLIPSIS +0x86 0x2020 #DAGGER +0x87 0x2021 #DOUBLE DAGGER +0x88 #UNDEFINED +0x89 0x2030 #PER MILLE SIGN +0x8A #UNDEFINED +0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK +0x8C #UNDEFINED +0x8D #UNDEFINED +0x8E #UNDEFINED +0x8F #UNDEFINED +0x90 #UNDEFINED +0x91 0x2018 #LEFT SINGLE QUOTATION MARK +0x92 0x2019 #RIGHT SINGLE QUOTATION MARK +0x93 0x201C #LEFT DOUBLE QUOTATION MARK +0x94 0x201D #RIGHT DOUBLE QUOTATION MARK +0x95 0x2022 #BULLET +0x96 0x2013 #EN DASH +0x97 0x2014 #EM DASH +0x98 #UNDEFINED +0x99 0x2122 #TRADE MARK SIGN +0x9A #UNDEFINED +0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK +0x9C #UNDEFINED +0x9D #UNDEFINED +0x9E #UNDEFINED +0x9F #UNDEFINED +0xA0 0x00A0 #NO-BREAK SPACE +0xA1 0x0385 #GREEK DIALYTIKA TONOS +0xA2 0x0386 #GREEK CAPITAL LETTER ALPHA WITH TONOS +0xA3 0x00A3 #POUND SIGN +0xA4 0x00A4 #CURRENCY SIGN +0xA5 0x00A5 #YEN SIGN +0xA6 0x00A6 #BROKEN BAR +0xA7 0x00A7 #SECTION SIGN +0xA8 0x00A8 #DIAERESIS +0xA9 0x00A9 #COPYRIGHT SIGN +0xAA #UNDEFINED +0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK +0xAC 0x00AC #NOT SIGN +0xAD 0x00AD #SOFT HYPHEN +0xAE 0x00AE #REGISTERED SIGN +0xAF 0x2015 #HORIZONTAL BAR +0xB0 0x00B0 #DEGREE SIGN +0xB1 0x00B1 #PLUS-MINUS SIGN +0xB2 0x00B2 #SUPERSCRIPT TWO +0xB3 0x00B3 #SUPERSCRIPT THREE +0xB4 0x0384 #GREEK TONOS +0xB5 0x00B5 #MICRO SIGN +0xB6 0x00B6 #PILCROW SIGN +0xB7 0x00B7 #MIDDLE DOT +0xB8 0x0388 #GREEK CAPITAL LETTER EPSILON WITH TONOS +0xB9 0x0389 #GREEK CAPITAL LETTER ETA WITH TONOS +0xBA 0x038A #GREEK CAPITAL LETTER IOTA WITH TONOS +0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK +0xBC 0x038C #GREEK CAPITAL LETTER OMICRON WITH TONOS +0xBD 0x00BD #VULGAR FRACTION ONE HALF +0xBE 0x038E #GREEK CAPITAL LETTER UPSILON WITH TONOS +0xBF 0x038F #GREEK CAPITAL LETTER OMEGA WITH TONOS +0xC0 0x0390 #GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS +0xC1 0x0391 #GREEK CAPITAL LETTER ALPHA +0xC2 0x0392 #GREEK CAPITAL LETTER BETA +0xC3 0x0393 #GREEK CAPITAL LETTER GAMMA +0xC4 0x0394 #GREEK CAPITAL LETTER DELTA +0xC5 0x0395 #GREEK CAPITAL LETTER EPSILON +0xC6 0x0396 #GREEK CAPITAL LETTER ZETA +0xC7 0x0397 #GREEK CAPITAL LETTER ETA +0xC8 0x0398 #GREEK CAPITAL LETTER THETA +0xC9 0x0399 #GREEK CAPITAL LETTER IOTA +0xCA 0x039A #GREEK CAPITAL LETTER KAPPA +0xCB 0x039B #GREEK CAPITAL LETTER LAMDA +0xCC 0x039C #GREEK CAPITAL LETTER MU +0xCD 0x039D #GREEK CAPITAL LETTER NU +0xCE 0x039E #GREEK CAPITAL LETTER XI +0xCF 0x039F #GREEK CAPITAL LETTER OMICRON +0xD0 0x03A0 #GREEK CAPITAL LETTER PI +0xD1 0x03A1 #GREEK CAPITAL LETTER RHO +0xD2 #UNDEFINED +0xD3 0x03A3 #GREEK CAPITAL LETTER SIGMA +0xD4 0x03A4 #GREEK CAPITAL LETTER TAU +0xD5 0x03A5 #GREEK CAPITAL LETTER UPSILON +0xD6 0x03A6 #GREEK CAPITAL LETTER PHI +0xD7 0x03A7 #GREEK CAPITAL LETTER CHI +0xD8 0x03A8 #GREEK CAPITAL LETTER PSI +0xD9 0x03A9 #GREEK CAPITAL LETTER OMEGA +0xDA 0x03AA #GREEK CAPITAL LETTER IOTA WITH DIALYTIKA +0xDB 0x03AB #GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA +0xDC 0x03AC #GREEK SMALL LETTER ALPHA WITH TONOS +0xDD 0x03AD #GREEK SMALL LETTER EPSILON WITH TONOS +0xDE 0x03AE #GREEK SMALL LETTER ETA WITH TONOS +0xDF 0x03AF #GREEK SMALL LETTER IOTA WITH TONOS +0xE0 0x03B0 #GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS +0xE1 0x03B1 #GREEK SMALL LETTER ALPHA +0xE2 0x03B2 #GREEK SMALL LETTER BETA +0xE3 0x03B3 #GREEK SMALL LETTER GAMMA +0xE4 0x03B4 #GREEK SMALL LETTER DELTA +0xE5 0x03B5 #GREEK SMALL LETTER EPSILON +0xE6 0x03B6 #GREEK SMALL LETTER ZETA +0xE7 0x03B7 #GREEK SMALL LETTER ETA +0xE8 0x03B8 #GREEK SMALL LETTER THETA +0xE9 0x03B9 #GREEK SMALL LETTER IOTA +0xEA 0x03BA #GREEK SMALL LETTER KAPPA +0xEB 0x03BB #GREEK SMALL LETTER LAMDA +0xEC 0x03BC #GREEK SMALL LETTER MU +0xED 0x03BD #GREEK SMALL LETTER NU +0xEE 0x03BE #GREEK SMALL LETTER XI +0xEF 0x03BF #GREEK SMALL LETTER OMICRON +0xF0 0x03C0 #GREEK SMALL LETTER PI +0xF1 0x03C1 #GREEK SMALL LETTER RHO +0xF2 0x03C2 #GREEK SMALL LETTER FINAL SIGMA +0xF3 0x03C3 #GREEK SMALL LETTER SIGMA +0xF4 0x03C4 #GREEK SMALL LETTER TAU +0xF5 0x03C5 #GREEK SMALL LETTER UPSILON +0xF6 0x03C6 #GREEK SMALL LETTER PHI +0xF7 0x03C7 #GREEK SMALL LETTER CHI +0xF8 0x03C8 #GREEK SMALL LETTER PSI +0xF9 0x03C9 #GREEK SMALL LETTER OMEGA +0xFA 0x03CA #GREEK SMALL LETTER IOTA WITH DIALYTIKA +0xFB 0x03CB #GREEK SMALL LETTER UPSILON WITH DIALYTIKA +0xFC 0x03CC #GREEK SMALL LETTER OMICRON WITH TONOS +0xFD 0x03CD #GREEK SMALL LETTER UPSILON WITH TONOS +0xFE 0x03CE #GREEK SMALL LETTER OMEGA WITH TONOS +0xFF #UNDEFINED diff --git a/basis/io/encodings/8-bit/CP1254.TXT b/basis/io/encodings/8-bit/CP1254.TXT new file mode 100644 index 0000000000..987ed98f75 --- /dev/null +++ b/basis/io/encodings/8-bit/CP1254.TXT @@ -0,0 +1,274 @@ +# +# Name: cp1254 to Unicode table +# Unicode version: 2.0 +# Table version: 2.01 +# Table format: Format A +# Date: 04/15/98 +# +# Contact: Shawn.Steele@microsoft.com +# +# General notes: none +# +# Format: Three tab-separated columns +# Column #1 is the cp1254 code (in hex) +# Column #2 is the Unicode (in hex as 0xXXXX) +# Column #3 is the Unicode name (follows a comment sign, '#') +# +# The entries are in cp1254 order +# +0x00 0x0000 #NULL +0x01 0x0001 #START OF HEADING +0x02 0x0002 #START OF TEXT +0x03 0x0003 #END OF TEXT +0x04 0x0004 #END OF TRANSMISSION +0x05 0x0005 #ENQUIRY +0x06 0x0006 #ACKNOWLEDGE +0x07 0x0007 #BELL +0x08 0x0008 #BACKSPACE +0x09 0x0009 #HORIZONTAL TABULATION +0x0A 0x000A #LINE FEED +0x0B 0x000B #VERTICAL TABULATION +0x0C 0x000C #FORM FEED +0x0D 0x000D #CARRIAGE RETURN +0x0E 0x000E #SHIFT OUT +0x0F 0x000F #SHIFT IN +0x10 0x0010 #DATA LINK ESCAPE +0x11 0x0011 #DEVICE CONTROL ONE +0x12 0x0012 #DEVICE CONTROL TWO +0x13 0x0013 #DEVICE CONTROL THREE +0x14 0x0014 #DEVICE CONTROL FOUR +0x15 0x0015 #NEGATIVE ACKNOWLEDGE +0x16 0x0016 #SYNCHRONOUS IDLE +0x17 0x0017 #END OF TRANSMISSION BLOCK +0x18 0x0018 #CANCEL +0x19 0x0019 #END OF MEDIUM +0x1A 0x001A #SUBSTITUTE +0x1B 0x001B #ESCAPE +0x1C 0x001C #FILE SEPARATOR +0x1D 0x001D #GROUP SEPARATOR +0x1E 0x001E #RECORD SEPARATOR +0x1F 0x001F #UNIT SEPARATOR +0x20 0x0020 #SPACE +0x21 0x0021 #EXCLAMATION MARK +0x22 0x0022 #QUOTATION MARK +0x23 0x0023 #NUMBER SIGN +0x24 0x0024 #DOLLAR SIGN +0x25 0x0025 #PERCENT SIGN +0x26 0x0026 #AMPERSAND +0x27 0x0027 #APOSTROPHE +0x28 0x0028 #LEFT PARENTHESIS +0x29 0x0029 #RIGHT PARENTHESIS +0x2A 0x002A #ASTERISK +0x2B 0x002B #PLUS SIGN +0x2C 0x002C #COMMA +0x2D 0x002D #HYPHEN-MINUS +0x2E 0x002E #FULL STOP +0x2F 0x002F #SOLIDUS +0x30 0x0030 #DIGIT ZERO +0x31 0x0031 #DIGIT ONE +0x32 0x0032 #DIGIT TWO +0x33 0x0033 #DIGIT THREE +0x34 0x0034 #DIGIT FOUR +0x35 0x0035 #DIGIT FIVE +0x36 0x0036 #DIGIT SIX +0x37 0x0037 #DIGIT SEVEN +0x38 0x0038 #DIGIT EIGHT +0x39 0x0039 #DIGIT NINE +0x3A 0x003A #COLON +0x3B 0x003B #SEMICOLON +0x3C 0x003C #LESS-THAN SIGN +0x3D 0x003D #EQUALS SIGN +0x3E 0x003E #GREATER-THAN SIGN +0x3F 0x003F #QUESTION MARK +0x40 0x0040 #COMMERCIAL AT +0x41 0x0041 #LATIN CAPITAL LETTER A +0x42 0x0042 #LATIN CAPITAL LETTER B +0x43 0x0043 #LATIN CAPITAL LETTER C +0x44 0x0044 #LATIN CAPITAL LETTER D +0x45 0x0045 #LATIN CAPITAL LETTER E +0x46 0x0046 #LATIN CAPITAL LETTER F +0x47 0x0047 #LATIN CAPITAL LETTER G +0x48 0x0048 #LATIN CAPITAL LETTER H +0x49 0x0049 #LATIN CAPITAL LETTER I +0x4A 0x004A #LATIN CAPITAL LETTER J +0x4B 0x004B #LATIN CAPITAL LETTER K +0x4C 0x004C #LATIN CAPITAL LETTER L +0x4D 0x004D #LATIN CAPITAL LETTER M +0x4E 0x004E #LATIN CAPITAL LETTER N +0x4F 0x004F #LATIN CAPITAL LETTER O +0x50 0x0050 #LATIN CAPITAL LETTER P +0x51 0x0051 #LATIN CAPITAL LETTER Q +0x52 0x0052 #LATIN CAPITAL LETTER R +0x53 0x0053 #LATIN CAPITAL LETTER S +0x54 0x0054 #LATIN CAPITAL LETTER T +0x55 0x0055 #LATIN CAPITAL LETTER U +0x56 0x0056 #LATIN CAPITAL LETTER V +0x57 0x0057 #LATIN CAPITAL LETTER W +0x58 0x0058 #LATIN CAPITAL LETTER X +0x59 0x0059 #LATIN CAPITAL LETTER Y +0x5A 0x005A #LATIN CAPITAL LETTER Z +0x5B 0x005B #LEFT SQUARE BRACKET +0x5C 0x005C #REVERSE SOLIDUS +0x5D 0x005D #RIGHT SQUARE BRACKET +0x5E 0x005E #CIRCUMFLEX ACCENT +0x5F 0x005F #LOW LINE +0x60 0x0060 #GRAVE ACCENT +0x61 0x0061 #LATIN SMALL LETTER A +0x62 0x0062 #LATIN SMALL LETTER B +0x63 0x0063 #LATIN SMALL LETTER C +0x64 0x0064 #LATIN SMALL LETTER D +0x65 0x0065 #LATIN SMALL LETTER E +0x66 0x0066 #LATIN SMALL LETTER F +0x67 0x0067 #LATIN SMALL LETTER G +0x68 0x0068 #LATIN SMALL LETTER H +0x69 0x0069 #LATIN SMALL LETTER I +0x6A 0x006A #LATIN SMALL LETTER J +0x6B 0x006B #LATIN SMALL LETTER K +0x6C 0x006C #LATIN SMALL LETTER L +0x6D 0x006D #LATIN SMALL LETTER M +0x6E 0x006E #LATIN SMALL LETTER N +0x6F 0x006F #LATIN SMALL LETTER O +0x70 0x0070 #LATIN SMALL LETTER P +0x71 0x0071 #LATIN SMALL LETTER Q +0x72 0x0072 #LATIN SMALL LETTER R +0x73 0x0073 #LATIN SMALL LETTER S +0x74 0x0074 #LATIN SMALL LETTER T +0x75 0x0075 #LATIN SMALL LETTER U +0x76 0x0076 #LATIN SMALL LETTER V +0x77 0x0077 #LATIN SMALL LETTER W +0x78 0x0078 #LATIN SMALL LETTER X +0x79 0x0079 #LATIN SMALL LETTER Y +0x7A 0x007A #LATIN SMALL LETTER Z +0x7B 0x007B #LEFT CURLY BRACKET +0x7C 0x007C #VERTICAL LINE +0x7D 0x007D #RIGHT CURLY BRACKET +0x7E 0x007E #TILDE +0x7F 0x007F #DELETE +0x80 0x20AC #EURO SIGN +0x81 #UNDEFINED +0x82 0x201A #SINGLE LOW-9 QUOTATION MARK +0x83 0x0192 #LATIN SMALL LETTER F WITH HOOK +0x84 0x201E #DOUBLE LOW-9 QUOTATION MARK +0x85 0x2026 #HORIZONTAL ELLIPSIS +0x86 0x2020 #DAGGER +0x87 0x2021 #DOUBLE DAGGER +0x88 0x02C6 #MODIFIER LETTER CIRCUMFLEX ACCENT +0x89 0x2030 #PER MILLE SIGN +0x8A 0x0160 #LATIN CAPITAL LETTER S WITH CARON +0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK +0x8C 0x0152 #LATIN CAPITAL LIGATURE OE +0x8D #UNDEFINED +0x8E #UNDEFINED +0x8F #UNDEFINED +0x90 #UNDEFINED +0x91 0x2018 #LEFT SINGLE QUOTATION MARK +0x92 0x2019 #RIGHT SINGLE QUOTATION MARK +0x93 0x201C #LEFT DOUBLE QUOTATION MARK +0x94 0x201D #RIGHT DOUBLE QUOTATION MARK +0x95 0x2022 #BULLET +0x96 0x2013 #EN DASH +0x97 0x2014 #EM DASH +0x98 0x02DC #SMALL TILDE +0x99 0x2122 #TRADE MARK SIGN +0x9A 0x0161 #LATIN SMALL LETTER S WITH CARON +0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK +0x9C 0x0153 #LATIN SMALL LIGATURE OE +0x9D #UNDEFINED +0x9E #UNDEFINED +0x9F 0x0178 #LATIN CAPITAL LETTER Y WITH DIAERESIS +0xA0 0x00A0 #NO-BREAK SPACE +0xA1 0x00A1 #INVERTED EXCLAMATION MARK +0xA2 0x00A2 #CENT SIGN +0xA3 0x00A3 #POUND SIGN +0xA4 0x00A4 #CURRENCY SIGN +0xA5 0x00A5 #YEN SIGN +0xA6 0x00A6 #BROKEN BAR +0xA7 0x00A7 #SECTION SIGN +0xA8 0x00A8 #DIAERESIS +0xA9 0x00A9 #COPYRIGHT SIGN +0xAA 0x00AA #FEMININE ORDINAL INDICATOR +0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK +0xAC 0x00AC #NOT SIGN +0xAD 0x00AD #SOFT HYPHEN +0xAE 0x00AE #REGISTERED SIGN +0xAF 0x00AF #MACRON +0xB0 0x00B0 #DEGREE SIGN +0xB1 0x00B1 #PLUS-MINUS SIGN +0xB2 0x00B2 #SUPERSCRIPT TWO +0xB3 0x00B3 #SUPERSCRIPT THREE +0xB4 0x00B4 #ACUTE ACCENT +0xB5 0x00B5 #MICRO SIGN +0xB6 0x00B6 #PILCROW SIGN +0xB7 0x00B7 #MIDDLE DOT +0xB8 0x00B8 #CEDILLA +0xB9 0x00B9 #SUPERSCRIPT ONE +0xBA 0x00BA #MASCULINE ORDINAL INDICATOR +0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK +0xBC 0x00BC #VULGAR FRACTION ONE QUARTER +0xBD 0x00BD #VULGAR FRACTION ONE HALF +0xBE 0x00BE #VULGAR FRACTION THREE QUARTERS +0xBF 0x00BF #INVERTED QUESTION MARK +0xC0 0x00C0 #LATIN CAPITAL LETTER A WITH GRAVE +0xC1 0x00C1 #LATIN CAPITAL LETTER A WITH ACUTE +0xC2 0x00C2 #LATIN CAPITAL LETTER A WITH CIRCUMFLEX +0xC3 0x00C3 #LATIN CAPITAL LETTER A WITH TILDE +0xC4 0x00C4 #LATIN CAPITAL LETTER A WITH DIAERESIS +0xC5 0x00C5 #LATIN CAPITAL LETTER A WITH RING ABOVE +0xC6 0x00C6 #LATIN CAPITAL LETTER AE +0xC7 0x00C7 #LATIN CAPITAL LETTER C WITH CEDILLA +0xC8 0x00C8 #LATIN CAPITAL LETTER E WITH GRAVE +0xC9 0x00C9 #LATIN CAPITAL LETTER E WITH ACUTE +0xCA 0x00CA #LATIN CAPITAL LETTER E WITH CIRCUMFLEX +0xCB 0x00CB #LATIN CAPITAL LETTER E WITH DIAERESIS +0xCC 0x00CC #LATIN CAPITAL LETTER I WITH GRAVE +0xCD 0x00CD #LATIN CAPITAL LETTER I WITH ACUTE +0xCE 0x00CE #LATIN CAPITAL LETTER I WITH CIRCUMFLEX +0xCF 0x00CF #LATIN CAPITAL LETTER I WITH DIAERESIS +0xD0 0x011E #LATIN CAPITAL LETTER G WITH BREVE +0xD1 0x00D1 #LATIN CAPITAL LETTER N WITH TILDE +0xD2 0x00D2 #LATIN CAPITAL LETTER O WITH GRAVE +0xD3 0x00D3 #LATIN CAPITAL LETTER O WITH ACUTE +0xD4 0x00D4 #LATIN CAPITAL LETTER O WITH CIRCUMFLEX +0xD5 0x00D5 #LATIN CAPITAL LETTER O WITH TILDE +0xD6 0x00D6 #LATIN CAPITAL LETTER O WITH DIAERESIS +0xD7 0x00D7 #MULTIPLICATION SIGN +0xD8 0x00D8 #LATIN CAPITAL LETTER O WITH STROKE +0xD9 0x00D9 #LATIN CAPITAL LETTER U WITH GRAVE +0xDA 0x00DA #LATIN CAPITAL LETTER U WITH ACUTE +0xDB 0x00DB #LATIN CAPITAL LETTER U WITH CIRCUMFLEX +0xDC 0x00DC #LATIN CAPITAL LETTER U WITH DIAERESIS +0xDD 0x0130 #LATIN CAPITAL LETTER I WITH DOT ABOVE +0xDE 0x015E #LATIN CAPITAL LETTER S WITH CEDILLA +0xDF 0x00DF #LATIN SMALL LETTER SHARP S +0xE0 0x00E0 #LATIN SMALL LETTER A WITH GRAVE +0xE1 0x00E1 #LATIN SMALL LETTER A WITH ACUTE +0xE2 0x00E2 #LATIN SMALL LETTER A WITH CIRCUMFLEX +0xE3 0x00E3 #LATIN SMALL LETTER A WITH TILDE +0xE4 0x00E4 #LATIN SMALL LETTER A WITH DIAERESIS +0xE5 0x00E5 #LATIN SMALL LETTER A WITH RING ABOVE +0xE6 0x00E6 #LATIN SMALL LETTER AE +0xE7 0x00E7 #LATIN SMALL LETTER C WITH CEDILLA +0xE8 0x00E8 #LATIN SMALL LETTER E WITH GRAVE +0xE9 0x00E9 #LATIN SMALL LETTER E WITH ACUTE +0xEA 0x00EA #LATIN SMALL LETTER E WITH CIRCUMFLEX +0xEB 0x00EB #LATIN SMALL LETTER E WITH DIAERESIS +0xEC 0x00EC #LATIN SMALL LETTER I WITH GRAVE +0xED 0x00ED #LATIN SMALL LETTER I WITH ACUTE +0xEE 0x00EE #LATIN SMALL LETTER I WITH CIRCUMFLEX +0xEF 0x00EF #LATIN SMALL LETTER I WITH DIAERESIS +0xF0 0x011F #LATIN SMALL LETTER G WITH BREVE +0xF1 0x00F1 #LATIN SMALL LETTER N WITH TILDE +0xF2 0x00F2 #LATIN SMALL LETTER O WITH GRAVE +0xF3 0x00F3 #LATIN SMALL LETTER O WITH ACUTE +0xF4 0x00F4 #LATIN SMALL LETTER O WITH CIRCUMFLEX +0xF5 0x00F5 #LATIN SMALL LETTER O WITH TILDE +0xF6 0x00F6 #LATIN SMALL LETTER O WITH DIAERESIS +0xF7 0x00F7 #DIVISION SIGN +0xF8 0x00F8 #LATIN SMALL LETTER O WITH STROKE +0xF9 0x00F9 #LATIN SMALL LETTER U WITH GRAVE +0xFA 0x00FA #LATIN SMALL LETTER U WITH ACUTE +0xFB 0x00FB #LATIN SMALL LETTER U WITH CIRCUMFLEX +0xFC 0x00FC #LATIN SMALL LETTER U WITH DIAERESIS +0xFD 0x0131 #LATIN SMALL LETTER DOTLESS I +0xFE 0x015F #LATIN SMALL LETTER S WITH CEDILLA +0xFF 0x00FF #LATIN SMALL LETTER Y WITH DIAERESIS diff --git a/basis/io/encodings/8-bit/CP1255.TXT b/basis/io/encodings/8-bit/CP1255.TXT new file mode 100644 index 0000000000..585f993753 --- /dev/null +++ b/basis/io/encodings/8-bit/CP1255.TXT @@ -0,0 +1,274 @@ +# +# Name: cp1255 to Unicode table +# Unicode version: 2.0 +# Table version: 2.01 +# Table format: Format A +# Date: 1/7/2000 +# +# Contact: Shawn.Steele@microsoft.com +# +# General notes: none +# +# Format: Three tab-separated columns +# Column #1 is the cp1255 code (in hex) +# Column #2 is the Unicode (in hex as 0xXXXX) +# Column #3 is the Unicode name (follows a comment sign, '#') +# +# The entries are in cp1255 order +# +0x00 0x0000 #NULL +0x01 0x0001 #START OF HEADING +0x02 0x0002 #START OF TEXT +0x03 0x0003 #END OF TEXT +0x04 0x0004 #END OF TRANSMISSION +0x05 0x0005 #ENQUIRY +0x06 0x0006 #ACKNOWLEDGE +0x07 0x0007 #BELL +0x08 0x0008 #BACKSPACE +0x09 0x0009 #HORIZONTAL TABULATION +0x0A 0x000A #LINE FEED +0x0B 0x000B #VERTICAL TABULATION +0x0C 0x000C #FORM FEED +0x0D 0x000D #CARRIAGE RETURN +0x0E 0x000E #SHIFT OUT +0x0F 0x000F #SHIFT IN +0x10 0x0010 #DATA LINK ESCAPE +0x11 0x0011 #DEVICE CONTROL ONE +0x12 0x0012 #DEVICE CONTROL TWO +0x13 0x0013 #DEVICE CONTROL THREE +0x14 0x0014 #DEVICE CONTROL FOUR +0x15 0x0015 #NEGATIVE ACKNOWLEDGE +0x16 0x0016 #SYNCHRONOUS IDLE +0x17 0x0017 #END OF TRANSMISSION BLOCK +0x18 0x0018 #CANCEL +0x19 0x0019 #END OF MEDIUM +0x1A 0x001A #SUBSTITUTE +0x1B 0x001B #ESCAPE +0x1C 0x001C #FILE SEPARATOR +0x1D 0x001D #GROUP SEPARATOR +0x1E 0x001E #RECORD SEPARATOR +0x1F 0x001F #UNIT SEPARATOR +0x20 0x0020 #SPACE +0x21 0x0021 #EXCLAMATION MARK +0x22 0x0022 #QUOTATION MARK +0x23 0x0023 #NUMBER SIGN +0x24 0x0024 #DOLLAR SIGN +0x25 0x0025 #PERCENT SIGN +0x26 0x0026 #AMPERSAND +0x27 0x0027 #APOSTROPHE +0x28 0x0028 #LEFT PARENTHESIS +0x29 0x0029 #RIGHT PARENTHESIS +0x2A 0x002A #ASTERISK +0x2B 0x002B #PLUS SIGN +0x2C 0x002C #COMMA +0x2D 0x002D #HYPHEN-MINUS +0x2E 0x002E #FULL STOP +0x2F 0x002F #SOLIDUS +0x30 0x0030 #DIGIT ZERO +0x31 0x0031 #DIGIT ONE +0x32 0x0032 #DIGIT TWO +0x33 0x0033 #DIGIT THREE +0x34 0x0034 #DIGIT FOUR +0x35 0x0035 #DIGIT FIVE +0x36 0x0036 #DIGIT SIX +0x37 0x0037 #DIGIT SEVEN +0x38 0x0038 #DIGIT EIGHT +0x39 0x0039 #DIGIT NINE +0x3A 0x003A #COLON +0x3B 0x003B #SEMICOLON +0x3C 0x003C #LESS-THAN SIGN +0x3D 0x003D #EQUALS SIGN +0x3E 0x003E #GREATER-THAN SIGN +0x3F 0x003F #QUESTION MARK +0x40 0x0040 #COMMERCIAL AT +0x41 0x0041 #LATIN CAPITAL LETTER A +0x42 0x0042 #LATIN CAPITAL LETTER B +0x43 0x0043 #LATIN CAPITAL LETTER C +0x44 0x0044 #LATIN CAPITAL LETTER D +0x45 0x0045 #LATIN CAPITAL LETTER E +0x46 0x0046 #LATIN CAPITAL LETTER F +0x47 0x0047 #LATIN CAPITAL LETTER G +0x48 0x0048 #LATIN CAPITAL LETTER H +0x49 0x0049 #LATIN CAPITAL LETTER I +0x4A 0x004A #LATIN CAPITAL LETTER J +0x4B 0x004B #LATIN CAPITAL LETTER K +0x4C 0x004C #LATIN CAPITAL LETTER L +0x4D 0x004D #LATIN CAPITAL LETTER M +0x4E 0x004E #LATIN CAPITAL LETTER N +0x4F 0x004F #LATIN CAPITAL LETTER O +0x50 0x0050 #LATIN CAPITAL LETTER P +0x51 0x0051 #LATIN CAPITAL LETTER Q +0x52 0x0052 #LATIN CAPITAL LETTER R +0x53 0x0053 #LATIN CAPITAL LETTER S +0x54 0x0054 #LATIN CAPITAL LETTER T +0x55 0x0055 #LATIN CAPITAL LETTER U +0x56 0x0056 #LATIN CAPITAL LETTER V +0x57 0x0057 #LATIN CAPITAL LETTER W +0x58 0x0058 #LATIN CAPITAL LETTER X +0x59 0x0059 #LATIN CAPITAL LETTER Y +0x5A 0x005A #LATIN CAPITAL LETTER Z +0x5B 0x005B #LEFT SQUARE BRACKET +0x5C 0x005C #REVERSE SOLIDUS +0x5D 0x005D #RIGHT SQUARE BRACKET +0x5E 0x005E #CIRCUMFLEX ACCENT +0x5F 0x005F #LOW LINE +0x60 0x0060 #GRAVE ACCENT +0x61 0x0061 #LATIN SMALL LETTER A +0x62 0x0062 #LATIN SMALL LETTER B +0x63 0x0063 #LATIN SMALL LETTER C +0x64 0x0064 #LATIN SMALL LETTER D +0x65 0x0065 #LATIN SMALL LETTER E +0x66 0x0066 #LATIN SMALL LETTER F +0x67 0x0067 #LATIN SMALL LETTER G +0x68 0x0068 #LATIN SMALL LETTER H +0x69 0x0069 #LATIN SMALL LETTER I +0x6A 0x006A #LATIN SMALL LETTER J +0x6B 0x006B #LATIN SMALL LETTER K +0x6C 0x006C #LATIN SMALL LETTER L +0x6D 0x006D #LATIN SMALL LETTER M +0x6E 0x006E #LATIN SMALL LETTER N +0x6F 0x006F #LATIN SMALL LETTER O +0x70 0x0070 #LATIN SMALL LETTER P +0x71 0x0071 #LATIN SMALL LETTER Q +0x72 0x0072 #LATIN SMALL LETTER R +0x73 0x0073 #LATIN SMALL LETTER S +0x74 0x0074 #LATIN SMALL LETTER T +0x75 0x0075 #LATIN SMALL LETTER U +0x76 0x0076 #LATIN SMALL LETTER V +0x77 0x0077 #LATIN SMALL LETTER W +0x78 0x0078 #LATIN SMALL LETTER X +0x79 0x0079 #LATIN SMALL LETTER Y +0x7A 0x007A #LATIN SMALL LETTER Z +0x7B 0x007B #LEFT CURLY BRACKET +0x7C 0x007C #VERTICAL LINE +0x7D 0x007D #RIGHT CURLY BRACKET +0x7E 0x007E #TILDE +0x7F 0x007F #DELETE +0x80 0x20AC #EURO SIGN +0x81 #UNDEFINED +0x82 0x201A #SINGLE LOW-9 QUOTATION MARK +0x83 0x0192 #LATIN SMALL LETTER F WITH HOOK +0x84 0x201E #DOUBLE LOW-9 QUOTATION MARK +0x85 0x2026 #HORIZONTAL ELLIPSIS +0x86 0x2020 #DAGGER +0x87 0x2021 #DOUBLE DAGGER +0x88 0x02C6 #MODIFIER LETTER CIRCUMFLEX ACCENT +0x89 0x2030 #PER MILLE SIGN +0x8A #UNDEFINED +0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK +0x8C #UNDEFINED +0x8D #UNDEFINED +0x8E #UNDEFINED +0x8F #UNDEFINED +0x90 #UNDEFINED +0x91 0x2018 #LEFT SINGLE QUOTATION MARK +0x92 0x2019 #RIGHT SINGLE QUOTATION MARK +0x93 0x201C #LEFT DOUBLE QUOTATION MARK +0x94 0x201D #RIGHT DOUBLE QUOTATION MARK +0x95 0x2022 #BULLET +0x96 0x2013 #EN DASH +0x97 0x2014 #EM DASH +0x98 0x02DC #SMALL TILDE +0x99 0x2122 #TRADE MARK SIGN +0x9A #UNDEFINED +0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK +0x9C #UNDEFINED +0x9D #UNDEFINED +0x9E #UNDEFINED +0x9F #UNDEFINED +0xA0 0x00A0 #NO-BREAK SPACE +0xA1 0x00A1 #INVERTED EXCLAMATION MARK +0xA2 0x00A2 #CENT SIGN +0xA3 0x00A3 #POUND SIGN +0xA4 0x20AA #NEW SHEQEL SIGN +0xA5 0x00A5 #YEN SIGN +0xA6 0x00A6 #BROKEN BAR +0xA7 0x00A7 #SECTION SIGN +0xA8 0x00A8 #DIAERESIS +0xA9 0x00A9 #COPYRIGHT SIGN +0xAA 0x00D7 #MULTIPLICATION SIGN +0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK +0xAC 0x00AC #NOT SIGN +0xAD 0x00AD #SOFT HYPHEN +0xAE 0x00AE #REGISTERED SIGN +0xAF 0x00AF #MACRON +0xB0 0x00B0 #DEGREE SIGN +0xB1 0x00B1 #PLUS-MINUS SIGN +0xB2 0x00B2 #SUPERSCRIPT TWO +0xB3 0x00B3 #SUPERSCRIPT THREE +0xB4 0x00B4 #ACUTE ACCENT +0xB5 0x00B5 #MICRO SIGN +0xB6 0x00B6 #PILCROW SIGN +0xB7 0x00B7 #MIDDLE DOT +0xB8 0x00B8 #CEDILLA +0xB9 0x00B9 #SUPERSCRIPT ONE +0xBA 0x00F7 #DIVISION SIGN +0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK +0xBC 0x00BC #VULGAR FRACTION ONE QUARTER +0xBD 0x00BD #VULGAR FRACTION ONE HALF +0xBE 0x00BE #VULGAR FRACTION THREE QUARTERS +0xBF 0x00BF #INVERTED QUESTION MARK +0xC0 0x05B0 #HEBREW POINT SHEVA +0xC1 0x05B1 #HEBREW POINT HATAF SEGOL +0xC2 0x05B2 #HEBREW POINT HATAF PATAH +0xC3 0x05B3 #HEBREW POINT HATAF QAMATS +0xC4 0x05B4 #HEBREW POINT HIRIQ +0xC5 0x05B5 #HEBREW POINT TSERE +0xC6 0x05B6 #HEBREW POINT SEGOL +0xC7 0x05B7 #HEBREW POINT PATAH +0xC8 0x05B8 #HEBREW POINT QAMATS +0xC9 0x05B9 #HEBREW POINT HOLAM +0xCA #UNDEFINED +0xCB 0x05BB #HEBREW POINT QUBUTS +0xCC 0x05BC #HEBREW POINT DAGESH OR MAPIQ +0xCD 0x05BD #HEBREW POINT METEG +0xCE 0x05BE #HEBREW PUNCTUATION MAQAF +0xCF 0x05BF #HEBREW POINT RAFE +0xD0 0x05C0 #HEBREW PUNCTUATION PASEQ +0xD1 0x05C1 #HEBREW POINT SHIN DOT +0xD2 0x05C2 #HEBREW POINT SIN DOT +0xD3 0x05C3 #HEBREW PUNCTUATION SOF PASUQ +0xD4 0x05F0 #HEBREW LIGATURE YIDDISH DOUBLE VAV +0xD5 0x05F1 #HEBREW LIGATURE YIDDISH VAV YOD +0xD6 0x05F2 #HEBREW LIGATURE YIDDISH DOUBLE YOD +0xD7 0x05F3 #HEBREW PUNCTUATION GERESH +0xD8 0x05F4 #HEBREW PUNCTUATION GERSHAYIM +0xD9 #UNDEFINED +0xDA #UNDEFINED +0xDB #UNDEFINED +0xDC #UNDEFINED +0xDD #UNDEFINED +0xDE #UNDEFINED +0xDF #UNDEFINED +0xE0 0x05D0 #HEBREW LETTER ALEF +0xE1 0x05D1 #HEBREW LETTER BET +0xE2 0x05D2 #HEBREW LETTER GIMEL +0xE3 0x05D3 #HEBREW LETTER DALET +0xE4 0x05D4 #HEBREW LETTER HE +0xE5 0x05D5 #HEBREW LETTER VAV +0xE6 0x05D6 #HEBREW LETTER ZAYIN +0xE7 0x05D7 #HEBREW LETTER HET +0xE8 0x05D8 #HEBREW LETTER TET +0xE9 0x05D9 #HEBREW LETTER YOD +0xEA 0x05DA #HEBREW LETTER FINAL KAF +0xEB 0x05DB #HEBREW LETTER KAF +0xEC 0x05DC #HEBREW LETTER LAMED +0xED 0x05DD #HEBREW LETTER FINAL MEM +0xEE 0x05DE #HEBREW LETTER MEM +0xEF 0x05DF #HEBREW LETTER FINAL NUN +0xF0 0x05E0 #HEBREW LETTER NUN +0xF1 0x05E1 #HEBREW LETTER SAMEKH +0xF2 0x05E2 #HEBREW LETTER AYIN +0xF3 0x05E3 #HEBREW LETTER FINAL PE +0xF4 0x05E4 #HEBREW LETTER PE +0xF5 0x05E5 #HEBREW LETTER FINAL TSADI +0xF6 0x05E6 #HEBREW LETTER TSADI +0xF7 0x05E7 #HEBREW LETTER QOF +0xF8 0x05E8 #HEBREW LETTER RESH +0xF9 0x05E9 #HEBREW LETTER SHIN +0xFA 0x05EA #HEBREW LETTER TAV +0xFB #UNDEFINED +0xFC #UNDEFINED +0xFD 0x200E #LEFT-TO-RIGHT MARK +0xFE 0x200F #RIGHT-TO-LEFT MARK +0xFF #UNDEFINED diff --git a/basis/io/encodings/8-bit/CP1256.TXT b/basis/io/encodings/8-bit/CP1256.TXT new file mode 100644 index 0000000000..244dcce01f --- /dev/null +++ b/basis/io/encodings/8-bit/CP1256.TXT @@ -0,0 +1,274 @@ +# +# Name: cp1256 to Unicode table +# Unicode version: 2.1 +# Table version: 2.01 +# Table format: Format A +# Date: 01/5/99 +# +# Contact: Shawn.Steele@microsoft.com +# +# General notes: none +# +# Format: Three tab-separated columns +# Column #1 is the cp1256 code (in hex) +# Column #2 is the Unicode (in hex as 0xXXXX) +# Column #3 is the Unicode name (follows a comment sign, '#') +# +# The entries are in cp1256 order +# +0x00 0x0000 #NULL +0x01 0x0001 #START OF HEADING +0x02 0x0002 #START OF TEXT +0x03 0x0003 #END OF TEXT +0x04 0x0004 #END OF TRANSMISSION +0x05 0x0005 #ENQUIRY +0x06 0x0006 #ACKNOWLEDGE +0x07 0x0007 #BELL +0x08 0x0008 #BACKSPACE +0x09 0x0009 #HORIZONTAL TABULATION +0x0A 0x000A #LINE FEED +0x0B 0x000B #VERTICAL TABULATION +0x0C 0x000C #FORM FEED +0x0D 0x000D #CARRIAGE RETURN +0x0E 0x000E #SHIFT OUT +0x0F 0x000F #SHIFT IN +0x10 0x0010 #DATA LINK ESCAPE +0x11 0x0011 #DEVICE CONTROL ONE +0x12 0x0012 #DEVICE CONTROL TWO +0x13 0x0013 #DEVICE CONTROL THREE +0x14 0x0014 #DEVICE CONTROL FOUR +0x15 0x0015 #NEGATIVE ACKNOWLEDGE +0x16 0x0016 #SYNCHRONOUS IDLE +0x17 0x0017 #END OF TRANSMISSION BLOCK +0x18 0x0018 #CANCEL +0x19 0x0019 #END OF MEDIUM +0x1A 0x001A #SUBSTITUTE +0x1B 0x001B #ESCAPE +0x1C 0x001C #FILE SEPARATOR +0x1D 0x001D #GROUP SEPARATOR +0x1E 0x001E #RECORD SEPARATOR +0x1F 0x001F #UNIT SEPARATOR +0x20 0x0020 #SPACE +0x21 0x0021 #EXCLAMATION MARK +0x22 0x0022 #QUOTATION MARK +0x23 0x0023 #NUMBER SIGN +0x24 0x0024 #DOLLAR SIGN +0x25 0x0025 #PERCENT SIGN +0x26 0x0026 #AMPERSAND +0x27 0x0027 #APOSTROPHE +0x28 0x0028 #LEFT PARENTHESIS +0x29 0x0029 #RIGHT PARENTHESIS +0x2A 0x002A #ASTERISK +0x2B 0x002B #PLUS SIGN +0x2C 0x002C #COMMA +0x2D 0x002D #HYPHEN-MINUS +0x2E 0x002E #FULL STOP +0x2F 0x002F #SOLIDUS +0x30 0x0030 #DIGIT ZERO +0x31 0x0031 #DIGIT ONE +0x32 0x0032 #DIGIT TWO +0x33 0x0033 #DIGIT THREE +0x34 0x0034 #DIGIT FOUR +0x35 0x0035 #DIGIT FIVE +0x36 0x0036 #DIGIT SIX +0x37 0x0037 #DIGIT SEVEN +0x38 0x0038 #DIGIT EIGHT +0x39 0x0039 #DIGIT NINE +0x3A 0x003A #COLON +0x3B 0x003B #SEMICOLON +0x3C 0x003C #LESS-THAN SIGN +0x3D 0x003D #EQUALS SIGN +0x3E 0x003E #GREATER-THAN SIGN +0x3F 0x003F #QUESTION MARK +0x40 0x0040 #COMMERCIAL AT +0x41 0x0041 #LATIN CAPITAL LETTER A +0x42 0x0042 #LATIN CAPITAL LETTER B +0x43 0x0043 #LATIN CAPITAL LETTER C +0x44 0x0044 #LATIN CAPITAL LETTER D +0x45 0x0045 #LATIN CAPITAL LETTER E +0x46 0x0046 #LATIN CAPITAL LETTER F +0x47 0x0047 #LATIN CAPITAL LETTER G +0x48 0x0048 #LATIN CAPITAL LETTER H +0x49 0x0049 #LATIN CAPITAL LETTER I +0x4A 0x004A #LATIN CAPITAL LETTER J +0x4B 0x004B #LATIN CAPITAL LETTER K +0x4C 0x004C #LATIN CAPITAL LETTER L +0x4D 0x004D #LATIN CAPITAL LETTER M +0x4E 0x004E #LATIN CAPITAL LETTER N +0x4F 0x004F #LATIN CAPITAL LETTER O +0x50 0x0050 #LATIN CAPITAL LETTER P +0x51 0x0051 #LATIN CAPITAL LETTER Q +0x52 0x0052 #LATIN CAPITAL LETTER R +0x53 0x0053 #LATIN CAPITAL LETTER S +0x54 0x0054 #LATIN CAPITAL LETTER T +0x55 0x0055 #LATIN CAPITAL LETTER U +0x56 0x0056 #LATIN CAPITAL LETTER V +0x57 0x0057 #LATIN CAPITAL LETTER W +0x58 0x0058 #LATIN CAPITAL LETTER X +0x59 0x0059 #LATIN CAPITAL LETTER Y +0x5A 0x005A #LATIN CAPITAL LETTER Z +0x5B 0x005B #LEFT SQUARE BRACKET +0x5C 0x005C #REVERSE SOLIDUS +0x5D 0x005D #RIGHT SQUARE BRACKET +0x5E 0x005E #CIRCUMFLEX ACCENT +0x5F 0x005F #LOW LINE +0x60 0x0060 #GRAVE ACCENT +0x61 0x0061 #LATIN SMALL LETTER A +0x62 0x0062 #LATIN SMALL LETTER B +0x63 0x0063 #LATIN SMALL LETTER C +0x64 0x0064 #LATIN SMALL LETTER D +0x65 0x0065 #LATIN SMALL LETTER E +0x66 0x0066 #LATIN SMALL LETTER F +0x67 0x0067 #LATIN SMALL LETTER G +0x68 0x0068 #LATIN SMALL LETTER H +0x69 0x0069 #LATIN SMALL LETTER I +0x6A 0x006A #LATIN SMALL LETTER J +0x6B 0x006B #LATIN SMALL LETTER K +0x6C 0x006C #LATIN SMALL LETTER L +0x6D 0x006D #LATIN SMALL LETTER M +0x6E 0x006E #LATIN SMALL LETTER N +0x6F 0x006F #LATIN SMALL LETTER O +0x70 0x0070 #LATIN SMALL LETTER P +0x71 0x0071 #LATIN SMALL LETTER Q +0x72 0x0072 #LATIN SMALL LETTER R +0x73 0x0073 #LATIN SMALL LETTER S +0x74 0x0074 #LATIN SMALL LETTER T +0x75 0x0075 #LATIN SMALL LETTER U +0x76 0x0076 #LATIN SMALL LETTER V +0x77 0x0077 #LATIN SMALL LETTER W +0x78 0x0078 #LATIN SMALL LETTER X +0x79 0x0079 #LATIN SMALL LETTER Y +0x7A 0x007A #LATIN SMALL LETTER Z +0x7B 0x007B #LEFT CURLY BRACKET +0x7C 0x007C #VERTICAL LINE +0x7D 0x007D #RIGHT CURLY BRACKET +0x7E 0x007E #TILDE +0x7F 0x007F #DELETE +0x80 0x20AC #EURO SIGN +0x81 0x067E #ARABIC LETTER PEH +0x82 0x201A #SINGLE LOW-9 QUOTATION MARK +0x83 0x0192 #LATIN SMALL LETTER F WITH HOOK +0x84 0x201E #DOUBLE LOW-9 QUOTATION MARK +0x85 0x2026 #HORIZONTAL ELLIPSIS +0x86 0x2020 #DAGGER +0x87 0x2021 #DOUBLE DAGGER +0x88 0x02C6 #MODIFIER LETTER CIRCUMFLEX ACCENT +0x89 0x2030 #PER MILLE SIGN +0x8A 0x0679 #ARABIC LETTER TTEH +0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK +0x8C 0x0152 #LATIN CAPITAL LIGATURE OE +0x8D 0x0686 #ARABIC LETTER TCHEH +0x8E 0x0698 #ARABIC LETTER JEH +0x8F 0x0688 #ARABIC LETTER DDAL +0x90 0x06AF #ARABIC LETTER GAF +0x91 0x2018 #LEFT SINGLE QUOTATION MARK +0x92 0x2019 #RIGHT SINGLE QUOTATION MARK +0x93 0x201C #LEFT DOUBLE QUOTATION MARK +0x94 0x201D #RIGHT DOUBLE QUOTATION MARK +0x95 0x2022 #BULLET +0x96 0x2013 #EN DASH +0x97 0x2014 #EM DASH +0x98 0x06A9 #ARABIC LETTER KEHEH +0x99 0x2122 #TRADE MARK SIGN +0x9A 0x0691 #ARABIC LETTER RREH +0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK +0x9C 0x0153 #LATIN SMALL LIGATURE OE +0x9D 0x200C #ZERO WIDTH NON-JOINER +0x9E 0x200D #ZERO WIDTH JOINER +0x9F 0x06BA #ARABIC LETTER NOON GHUNNA +0xA0 0x00A0 #NO-BREAK SPACE +0xA1 0x060C #ARABIC COMMA +0xA2 0x00A2 #CENT SIGN +0xA3 0x00A3 #POUND SIGN +0xA4 0x00A4 #CURRENCY SIGN +0xA5 0x00A5 #YEN SIGN +0xA6 0x00A6 #BROKEN BAR +0xA7 0x00A7 #SECTION SIGN +0xA8 0x00A8 #DIAERESIS +0xA9 0x00A9 #COPYRIGHT SIGN +0xAA 0x06BE #ARABIC LETTER HEH DOACHASHMEE +0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK +0xAC 0x00AC #NOT SIGN +0xAD 0x00AD #SOFT HYPHEN +0xAE 0x00AE #REGISTERED SIGN +0xAF 0x00AF #MACRON +0xB0 0x00B0 #DEGREE SIGN +0xB1 0x00B1 #PLUS-MINUS SIGN +0xB2 0x00B2 #SUPERSCRIPT TWO +0xB3 0x00B3 #SUPERSCRIPT THREE +0xB4 0x00B4 #ACUTE ACCENT +0xB5 0x00B5 #MICRO SIGN +0xB6 0x00B6 #PILCROW SIGN +0xB7 0x00B7 #MIDDLE DOT +0xB8 0x00B8 #CEDILLA +0xB9 0x00B9 #SUPERSCRIPT ONE +0xBA 0x061B #ARABIC SEMICOLON +0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK +0xBC 0x00BC #VULGAR FRACTION ONE QUARTER +0xBD 0x00BD #VULGAR FRACTION ONE HALF +0xBE 0x00BE #VULGAR FRACTION THREE QUARTERS +0xBF 0x061F #ARABIC QUESTION MARK +0xC0 0x06C1 #ARABIC LETTER HEH GOAL +0xC1 0x0621 #ARABIC LETTER HAMZA +0xC2 0x0622 #ARABIC LETTER ALEF WITH MADDA ABOVE +0xC3 0x0623 #ARABIC LETTER ALEF WITH HAMZA ABOVE +0xC4 0x0624 #ARABIC LETTER WAW WITH HAMZA ABOVE +0xC5 0x0625 #ARABIC LETTER ALEF WITH HAMZA BELOW +0xC6 0x0626 #ARABIC LETTER YEH WITH HAMZA ABOVE +0xC7 0x0627 #ARABIC LETTER ALEF +0xC8 0x0628 #ARABIC LETTER BEH +0xC9 0x0629 #ARABIC LETTER TEH MARBUTA +0xCA 0x062A #ARABIC LETTER TEH +0xCB 0x062B #ARABIC LETTER THEH +0xCC 0x062C #ARABIC LETTER JEEM +0xCD 0x062D #ARABIC LETTER HAH +0xCE 0x062E #ARABIC LETTER KHAH +0xCF 0x062F #ARABIC LETTER DAL +0xD0 0x0630 #ARABIC LETTER THAL +0xD1 0x0631 #ARABIC LETTER REH +0xD2 0x0632 #ARABIC LETTER ZAIN +0xD3 0x0633 #ARABIC LETTER SEEN +0xD4 0x0634 #ARABIC LETTER SHEEN +0xD5 0x0635 #ARABIC LETTER SAD +0xD6 0x0636 #ARABIC LETTER DAD +0xD7 0x00D7 #MULTIPLICATION SIGN +0xD8 0x0637 #ARABIC LETTER TAH +0xD9 0x0638 #ARABIC LETTER ZAH +0xDA 0x0639 #ARABIC LETTER AIN +0xDB 0x063A #ARABIC LETTER GHAIN +0xDC 0x0640 #ARABIC TATWEEL +0xDD 0x0641 #ARABIC LETTER FEH +0xDE 0x0642 #ARABIC LETTER QAF +0xDF 0x0643 #ARABIC LETTER KAF +0xE0 0x00E0 #LATIN SMALL LETTER A WITH GRAVE +0xE1 0x0644 #ARABIC LETTER LAM +0xE2 0x00E2 #LATIN SMALL LETTER A WITH CIRCUMFLEX +0xE3 0x0645 #ARABIC LETTER MEEM +0xE4 0x0646 #ARABIC LETTER NOON +0xE5 0x0647 #ARABIC LETTER HEH +0xE6 0x0648 #ARABIC LETTER WAW +0xE7 0x00E7 #LATIN SMALL LETTER C WITH CEDILLA +0xE8 0x00E8 #LATIN SMALL LETTER E WITH GRAVE +0xE9 0x00E9 #LATIN SMALL LETTER E WITH ACUTE +0xEA 0x00EA #LATIN SMALL LETTER E WITH CIRCUMFLEX +0xEB 0x00EB #LATIN SMALL LETTER E WITH DIAERESIS +0xEC 0x0649 #ARABIC LETTER ALEF MAKSURA +0xED 0x064A #ARABIC LETTER YEH +0xEE 0x00EE #LATIN SMALL LETTER I WITH CIRCUMFLEX +0xEF 0x00EF #LATIN SMALL LETTER I WITH DIAERESIS +0xF0 0x064B #ARABIC FATHATAN +0xF1 0x064C #ARABIC DAMMATAN +0xF2 0x064D #ARABIC KASRATAN +0xF3 0x064E #ARABIC FATHA +0xF4 0x00F4 #LATIN SMALL LETTER O WITH CIRCUMFLEX +0xF5 0x064F #ARABIC DAMMA +0xF6 0x0650 #ARABIC KASRA +0xF7 0x00F7 #DIVISION SIGN +0xF8 0x0651 #ARABIC SHADDA +0xF9 0x00F9 #LATIN SMALL LETTER U WITH GRAVE +0xFA 0x0652 #ARABIC SUKUN +0xFB 0x00FB #LATIN SMALL LETTER U WITH CIRCUMFLEX +0xFC 0x00FC #LATIN SMALL LETTER U WITH DIAERESIS +0xFD 0x200E #LEFT-TO-RIGHT MARK +0xFE 0x200F #RIGHT-TO-LEFT MARK +0xFF 0x06D2 #ARABIC LETTER YEH BARREE diff --git a/basis/io/encodings/8-bit/CP1257.TXT b/basis/io/encodings/8-bit/CP1257.TXT new file mode 100644 index 0000000000..0dc475e022 --- /dev/null +++ b/basis/io/encodings/8-bit/CP1257.TXT @@ -0,0 +1,274 @@ +# +# Name: cp1257 to Unicode table +# Unicode version: 2.0 +# Table version: 2.01 +# Table format: Format A +# Date: 04/15/98 +# +# Contact: Shawn.Steele@microsoft.com +# +# General notes: none +# +# Format: Three tab-separated columns +# Column #1 is the cp1257 code (in hex) +# Column #2 is the Unicode (in hex as 0xXXXX) +# Column #3 is the Unicode name (follows a comment sign, '#') +# +# The entries are in cp1257 order +# +0x00 0x0000 #NULL +0x01 0x0001 #START OF HEADING +0x02 0x0002 #START OF TEXT +0x03 0x0003 #END OF TEXT +0x04 0x0004 #END OF TRANSMISSION +0x05 0x0005 #ENQUIRY +0x06 0x0006 #ACKNOWLEDGE +0x07 0x0007 #BELL +0x08 0x0008 #BACKSPACE +0x09 0x0009 #HORIZONTAL TABULATION +0x0A 0x000A #LINE FEED +0x0B 0x000B #VERTICAL TABULATION +0x0C 0x000C #FORM FEED +0x0D 0x000D #CARRIAGE RETURN +0x0E 0x000E #SHIFT OUT +0x0F 0x000F #SHIFT IN +0x10 0x0010 #DATA LINK ESCAPE +0x11 0x0011 #DEVICE CONTROL ONE +0x12 0x0012 #DEVICE CONTROL TWO +0x13 0x0013 #DEVICE CONTROL THREE +0x14 0x0014 #DEVICE CONTROL FOUR +0x15 0x0015 #NEGATIVE ACKNOWLEDGE +0x16 0x0016 #SYNCHRONOUS IDLE +0x17 0x0017 #END OF TRANSMISSION BLOCK +0x18 0x0018 #CANCEL +0x19 0x0019 #END OF MEDIUM +0x1A 0x001A #SUBSTITUTE +0x1B 0x001B #ESCAPE +0x1C 0x001C #FILE SEPARATOR +0x1D 0x001D #GROUP SEPARATOR +0x1E 0x001E #RECORD SEPARATOR +0x1F 0x001F #UNIT SEPARATOR +0x20 0x0020 #SPACE +0x21 0x0021 #EXCLAMATION MARK +0x22 0x0022 #QUOTATION MARK +0x23 0x0023 #NUMBER SIGN +0x24 0x0024 #DOLLAR SIGN +0x25 0x0025 #PERCENT SIGN +0x26 0x0026 #AMPERSAND +0x27 0x0027 #APOSTROPHE +0x28 0x0028 #LEFT PARENTHESIS +0x29 0x0029 #RIGHT PARENTHESIS +0x2A 0x002A #ASTERISK +0x2B 0x002B #PLUS SIGN +0x2C 0x002C #COMMA +0x2D 0x002D #HYPHEN-MINUS +0x2E 0x002E #FULL STOP +0x2F 0x002F #SOLIDUS +0x30 0x0030 #DIGIT ZERO +0x31 0x0031 #DIGIT ONE +0x32 0x0032 #DIGIT TWO +0x33 0x0033 #DIGIT THREE +0x34 0x0034 #DIGIT FOUR +0x35 0x0035 #DIGIT FIVE +0x36 0x0036 #DIGIT SIX +0x37 0x0037 #DIGIT SEVEN +0x38 0x0038 #DIGIT EIGHT +0x39 0x0039 #DIGIT NINE +0x3A 0x003A #COLON +0x3B 0x003B #SEMICOLON +0x3C 0x003C #LESS-THAN SIGN +0x3D 0x003D #EQUALS SIGN +0x3E 0x003E #GREATER-THAN SIGN +0x3F 0x003F #QUESTION MARK +0x40 0x0040 #COMMERCIAL AT +0x41 0x0041 #LATIN CAPITAL LETTER A +0x42 0x0042 #LATIN CAPITAL LETTER B +0x43 0x0043 #LATIN CAPITAL LETTER C +0x44 0x0044 #LATIN CAPITAL LETTER D +0x45 0x0045 #LATIN CAPITAL LETTER E +0x46 0x0046 #LATIN CAPITAL LETTER F +0x47 0x0047 #LATIN CAPITAL LETTER G +0x48 0x0048 #LATIN CAPITAL LETTER H +0x49 0x0049 #LATIN CAPITAL LETTER I +0x4A 0x004A #LATIN CAPITAL LETTER J +0x4B 0x004B #LATIN CAPITAL LETTER K +0x4C 0x004C #LATIN CAPITAL LETTER L +0x4D 0x004D #LATIN CAPITAL LETTER M +0x4E 0x004E #LATIN CAPITAL LETTER N +0x4F 0x004F #LATIN CAPITAL LETTER O +0x50 0x0050 #LATIN CAPITAL LETTER P +0x51 0x0051 #LATIN CAPITAL LETTER Q +0x52 0x0052 #LATIN CAPITAL LETTER R +0x53 0x0053 #LATIN CAPITAL LETTER S +0x54 0x0054 #LATIN CAPITAL LETTER T +0x55 0x0055 #LATIN CAPITAL LETTER U +0x56 0x0056 #LATIN CAPITAL LETTER V +0x57 0x0057 #LATIN CAPITAL LETTER W +0x58 0x0058 #LATIN CAPITAL LETTER X +0x59 0x0059 #LATIN CAPITAL LETTER Y +0x5A 0x005A #LATIN CAPITAL LETTER Z +0x5B 0x005B #LEFT SQUARE BRACKET +0x5C 0x005C #REVERSE SOLIDUS +0x5D 0x005D #RIGHT SQUARE BRACKET +0x5E 0x005E #CIRCUMFLEX ACCENT +0x5F 0x005F #LOW LINE +0x60 0x0060 #GRAVE ACCENT +0x61 0x0061 #LATIN SMALL LETTER A +0x62 0x0062 #LATIN SMALL LETTER B +0x63 0x0063 #LATIN SMALL LETTER C +0x64 0x0064 #LATIN SMALL LETTER D +0x65 0x0065 #LATIN SMALL LETTER E +0x66 0x0066 #LATIN SMALL LETTER F +0x67 0x0067 #LATIN SMALL LETTER G +0x68 0x0068 #LATIN SMALL LETTER H +0x69 0x0069 #LATIN SMALL LETTER I +0x6A 0x006A #LATIN SMALL LETTER J +0x6B 0x006B #LATIN SMALL LETTER K +0x6C 0x006C #LATIN SMALL LETTER L +0x6D 0x006D #LATIN SMALL LETTER M +0x6E 0x006E #LATIN SMALL LETTER N +0x6F 0x006F #LATIN SMALL LETTER O +0x70 0x0070 #LATIN SMALL LETTER P +0x71 0x0071 #LATIN SMALL LETTER Q +0x72 0x0072 #LATIN SMALL LETTER R +0x73 0x0073 #LATIN SMALL LETTER S +0x74 0x0074 #LATIN SMALL LETTER T +0x75 0x0075 #LATIN SMALL LETTER U +0x76 0x0076 #LATIN SMALL LETTER V +0x77 0x0077 #LATIN SMALL LETTER W +0x78 0x0078 #LATIN SMALL LETTER X +0x79 0x0079 #LATIN SMALL LETTER Y +0x7A 0x007A #LATIN SMALL LETTER Z +0x7B 0x007B #LEFT CURLY BRACKET +0x7C 0x007C #VERTICAL LINE +0x7D 0x007D #RIGHT CURLY BRACKET +0x7E 0x007E #TILDE +0x7F 0x007F #DELETE +0x80 0x20AC #EURO SIGN +0x81 #UNDEFINED +0x82 0x201A #SINGLE LOW-9 QUOTATION MARK +0x83 #UNDEFINED +0x84 0x201E #DOUBLE LOW-9 QUOTATION MARK +0x85 0x2026 #HORIZONTAL ELLIPSIS +0x86 0x2020 #DAGGER +0x87 0x2021 #DOUBLE DAGGER +0x88 #UNDEFINED +0x89 0x2030 #PER MILLE SIGN +0x8A #UNDEFINED +0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK +0x8C #UNDEFINED +0x8D 0x00A8 #DIAERESIS +0x8E 0x02C7 #CARON +0x8F 0x00B8 #CEDILLA +0x90 #UNDEFINED +0x91 0x2018 #LEFT SINGLE QUOTATION MARK +0x92 0x2019 #RIGHT SINGLE QUOTATION MARK +0x93 0x201C #LEFT DOUBLE QUOTATION MARK +0x94 0x201D #RIGHT DOUBLE QUOTATION MARK +0x95 0x2022 #BULLET +0x96 0x2013 #EN DASH +0x97 0x2014 #EM DASH +0x98 #UNDEFINED +0x99 0x2122 #TRADE MARK SIGN +0x9A #UNDEFINED +0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK +0x9C #UNDEFINED +0x9D 0x00AF #MACRON +0x9E 0x02DB #OGONEK +0x9F #UNDEFINED +0xA0 0x00A0 #NO-BREAK SPACE +0xA1 #UNDEFINED +0xA2 0x00A2 #CENT SIGN +0xA3 0x00A3 #POUND SIGN +0xA4 0x00A4 #CURRENCY SIGN +0xA5 #UNDEFINED +0xA6 0x00A6 #BROKEN BAR +0xA7 0x00A7 #SECTION SIGN +0xA8 0x00D8 #LATIN CAPITAL LETTER O WITH STROKE +0xA9 0x00A9 #COPYRIGHT SIGN +0xAA 0x0156 #LATIN CAPITAL LETTER R WITH CEDILLA +0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK +0xAC 0x00AC #NOT SIGN +0xAD 0x00AD #SOFT HYPHEN +0xAE 0x00AE #REGISTERED SIGN +0xAF 0x00C6 #LATIN CAPITAL LETTER AE +0xB0 0x00B0 #DEGREE SIGN +0xB1 0x00B1 #PLUS-MINUS SIGN +0xB2 0x00B2 #SUPERSCRIPT TWO +0xB3 0x00B3 #SUPERSCRIPT THREE +0xB4 0x00B4 #ACUTE ACCENT +0xB5 0x00B5 #MICRO SIGN +0xB6 0x00B6 #PILCROW SIGN +0xB7 0x00B7 #MIDDLE DOT +0xB8 0x00F8 #LATIN SMALL LETTER O WITH STROKE +0xB9 0x00B9 #SUPERSCRIPT ONE +0xBA 0x0157 #LATIN SMALL LETTER R WITH CEDILLA +0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK +0xBC 0x00BC #VULGAR FRACTION ONE QUARTER +0xBD 0x00BD #VULGAR FRACTION ONE HALF +0xBE 0x00BE #VULGAR FRACTION THREE QUARTERS +0xBF 0x00E6 #LATIN SMALL LETTER AE +0xC0 0x0104 #LATIN CAPITAL LETTER A WITH OGONEK +0xC1 0x012E #LATIN CAPITAL LETTER I WITH OGONEK +0xC2 0x0100 #LATIN CAPITAL LETTER A WITH MACRON +0xC3 0x0106 #LATIN CAPITAL LETTER C WITH ACUTE +0xC4 0x00C4 #LATIN CAPITAL LETTER A WITH DIAERESIS +0xC5 0x00C5 #LATIN CAPITAL LETTER A WITH RING ABOVE +0xC6 0x0118 #LATIN CAPITAL LETTER E WITH OGONEK +0xC7 0x0112 #LATIN CAPITAL LETTER E WITH MACRON +0xC8 0x010C #LATIN CAPITAL LETTER C WITH CARON +0xC9 0x00C9 #LATIN CAPITAL LETTER E WITH ACUTE +0xCA 0x0179 #LATIN CAPITAL LETTER Z WITH ACUTE +0xCB 0x0116 #LATIN CAPITAL LETTER E WITH DOT ABOVE +0xCC 0x0122 #LATIN CAPITAL LETTER G WITH CEDILLA +0xCD 0x0136 #LATIN CAPITAL LETTER K WITH CEDILLA +0xCE 0x012A #LATIN CAPITAL LETTER I WITH MACRON +0xCF 0x013B #LATIN CAPITAL LETTER L WITH CEDILLA +0xD0 0x0160 #LATIN CAPITAL LETTER S WITH CARON +0xD1 0x0143 #LATIN CAPITAL LETTER N WITH ACUTE +0xD2 0x0145 #LATIN CAPITAL LETTER N WITH CEDILLA +0xD3 0x00D3 #LATIN CAPITAL LETTER O WITH ACUTE +0xD4 0x014C #LATIN CAPITAL LETTER O WITH MACRON +0xD5 0x00D5 #LATIN CAPITAL LETTER O WITH TILDE +0xD6 0x00D6 #LATIN CAPITAL LETTER O WITH DIAERESIS +0xD7 0x00D7 #MULTIPLICATION SIGN +0xD8 0x0172 #LATIN CAPITAL LETTER U WITH OGONEK +0xD9 0x0141 #LATIN CAPITAL LETTER L WITH STROKE +0xDA 0x015A #LATIN CAPITAL LETTER S WITH ACUTE +0xDB 0x016A #LATIN CAPITAL LETTER U WITH MACRON +0xDC 0x00DC #LATIN CAPITAL LETTER U WITH DIAERESIS +0xDD 0x017B #LATIN CAPITAL LETTER Z WITH DOT ABOVE +0xDE 0x017D #LATIN CAPITAL LETTER Z WITH CARON +0xDF 0x00DF #LATIN SMALL LETTER SHARP S +0xE0 0x0105 #LATIN SMALL LETTER A WITH OGONEK +0xE1 0x012F #LATIN SMALL LETTER I WITH OGONEK +0xE2 0x0101 #LATIN SMALL LETTER A WITH MACRON +0xE3 0x0107 #LATIN SMALL LETTER C WITH ACUTE +0xE4 0x00E4 #LATIN SMALL LETTER A WITH DIAERESIS +0xE5 0x00E5 #LATIN SMALL LETTER A WITH RING ABOVE +0xE6 0x0119 #LATIN SMALL LETTER E WITH OGONEK +0xE7 0x0113 #LATIN SMALL LETTER E WITH MACRON +0xE8 0x010D #LATIN SMALL LETTER C WITH CARON +0xE9 0x00E9 #LATIN SMALL LETTER E WITH ACUTE +0xEA 0x017A #LATIN SMALL LETTER Z WITH ACUTE +0xEB 0x0117 #LATIN SMALL LETTER E WITH DOT ABOVE +0xEC 0x0123 #LATIN SMALL LETTER G WITH CEDILLA +0xED 0x0137 #LATIN SMALL LETTER K WITH CEDILLA +0xEE 0x012B #LATIN SMALL LETTER I WITH MACRON +0xEF 0x013C #LATIN SMALL LETTER L WITH CEDILLA +0xF0 0x0161 #LATIN SMALL LETTER S WITH CARON +0xF1 0x0144 #LATIN SMALL LETTER N WITH ACUTE +0xF2 0x0146 #LATIN SMALL LETTER N WITH CEDILLA +0xF3 0x00F3 #LATIN SMALL LETTER O WITH ACUTE +0xF4 0x014D #LATIN SMALL LETTER O WITH MACRON +0xF5 0x00F5 #LATIN SMALL LETTER O WITH TILDE +0xF6 0x00F6 #LATIN SMALL LETTER O WITH DIAERESIS +0xF7 0x00F7 #DIVISION SIGN +0xF8 0x0173 #LATIN SMALL LETTER U WITH OGONEK +0xF9 0x0142 #LATIN SMALL LETTER L WITH STROKE +0xFA 0x015B #LATIN SMALL LETTER S WITH ACUTE +0xFB 0x016B #LATIN SMALL LETTER U WITH MACRON +0xFC 0x00FC #LATIN SMALL LETTER U WITH DIAERESIS +0xFD 0x017C #LATIN SMALL LETTER Z WITH DOT ABOVE +0xFE 0x017E #LATIN SMALL LETTER Z WITH CARON +0xFF 0x02D9 #DOT ABOVE diff --git a/basis/io/encodings/8-bit/CP1258.TXT b/basis/io/encodings/8-bit/CP1258.TXT new file mode 100644 index 0000000000..f402b34b48 --- /dev/null +++ b/basis/io/encodings/8-bit/CP1258.TXT @@ -0,0 +1,274 @@ +# +# Name: cp1258 to Unicode table +# Unicode version: 2.0 +# Table version: 2.01 +# Table format: Format A +# Date: 04/15/98 +# +# Contact: Shawn.Steele@microsoft.com +# +# General notes: none +# +# Format: Three tab-separated columns +# Column #1 is the cp1258 code (in hex) +# Column #2 is the Unicode (in hex as 0xXXXX) +# Column #3 is the Unicode name (follows a comment sign, '#') +# +# The entries are in cp1258 order +# +0x00 0x0000 #NULL +0x01 0x0001 #START OF HEADING +0x02 0x0002 #START OF TEXT +0x03 0x0003 #END OF TEXT +0x04 0x0004 #END OF TRANSMISSION +0x05 0x0005 #ENQUIRY +0x06 0x0006 #ACKNOWLEDGE +0x07 0x0007 #BELL +0x08 0x0008 #BACKSPACE +0x09 0x0009 #HORIZONTAL TABULATION +0x0A 0x000A #LINE FEED +0x0B 0x000B #VERTICAL TABULATION +0x0C 0x000C #FORM FEED +0x0D 0x000D #CARRIAGE RETURN +0x0E 0x000E #SHIFT OUT +0x0F 0x000F #SHIFT IN +0x10 0x0010 #DATA LINK ESCAPE +0x11 0x0011 #DEVICE CONTROL ONE +0x12 0x0012 #DEVICE CONTROL TWO +0x13 0x0013 #DEVICE CONTROL THREE +0x14 0x0014 #DEVICE CONTROL FOUR +0x15 0x0015 #NEGATIVE ACKNOWLEDGE +0x16 0x0016 #SYNCHRONOUS IDLE +0x17 0x0017 #END OF TRANSMISSION BLOCK +0x18 0x0018 #CANCEL +0x19 0x0019 #END OF MEDIUM +0x1A 0x001A #SUBSTITUTE +0x1B 0x001B #ESCAPE +0x1C 0x001C #FILE SEPARATOR +0x1D 0x001D #GROUP SEPARATOR +0x1E 0x001E #RECORD SEPARATOR +0x1F 0x001F #UNIT SEPARATOR +0x20 0x0020 #SPACE +0x21 0x0021 #EXCLAMATION MARK +0x22 0x0022 #QUOTATION MARK +0x23 0x0023 #NUMBER SIGN +0x24 0x0024 #DOLLAR SIGN +0x25 0x0025 #PERCENT SIGN +0x26 0x0026 #AMPERSAND +0x27 0x0027 #APOSTROPHE +0x28 0x0028 #LEFT PARENTHESIS +0x29 0x0029 #RIGHT PARENTHESIS +0x2A 0x002A #ASTERISK +0x2B 0x002B #PLUS SIGN +0x2C 0x002C #COMMA +0x2D 0x002D #HYPHEN-MINUS +0x2E 0x002E #FULL STOP +0x2F 0x002F #SOLIDUS +0x30 0x0030 #DIGIT ZERO +0x31 0x0031 #DIGIT ONE +0x32 0x0032 #DIGIT TWO +0x33 0x0033 #DIGIT THREE +0x34 0x0034 #DIGIT FOUR +0x35 0x0035 #DIGIT FIVE +0x36 0x0036 #DIGIT SIX +0x37 0x0037 #DIGIT SEVEN +0x38 0x0038 #DIGIT EIGHT +0x39 0x0039 #DIGIT NINE +0x3A 0x003A #COLON +0x3B 0x003B #SEMICOLON +0x3C 0x003C #LESS-THAN SIGN +0x3D 0x003D #EQUALS SIGN +0x3E 0x003E #GREATER-THAN SIGN +0x3F 0x003F #QUESTION MARK +0x40 0x0040 #COMMERCIAL AT +0x41 0x0041 #LATIN CAPITAL LETTER A +0x42 0x0042 #LATIN CAPITAL LETTER B +0x43 0x0043 #LATIN CAPITAL LETTER C +0x44 0x0044 #LATIN CAPITAL LETTER D +0x45 0x0045 #LATIN CAPITAL LETTER E +0x46 0x0046 #LATIN CAPITAL LETTER F +0x47 0x0047 #LATIN CAPITAL LETTER G +0x48 0x0048 #LATIN CAPITAL LETTER H +0x49 0x0049 #LATIN CAPITAL LETTER I +0x4A 0x004A #LATIN CAPITAL LETTER J +0x4B 0x004B #LATIN CAPITAL LETTER K +0x4C 0x004C #LATIN CAPITAL LETTER L +0x4D 0x004D #LATIN CAPITAL LETTER M +0x4E 0x004E #LATIN CAPITAL LETTER N +0x4F 0x004F #LATIN CAPITAL LETTER O +0x50 0x0050 #LATIN CAPITAL LETTER P +0x51 0x0051 #LATIN CAPITAL LETTER Q +0x52 0x0052 #LATIN CAPITAL LETTER R +0x53 0x0053 #LATIN CAPITAL LETTER S +0x54 0x0054 #LATIN CAPITAL LETTER T +0x55 0x0055 #LATIN CAPITAL LETTER U +0x56 0x0056 #LATIN CAPITAL LETTER V +0x57 0x0057 #LATIN CAPITAL LETTER W +0x58 0x0058 #LATIN CAPITAL LETTER X +0x59 0x0059 #LATIN CAPITAL LETTER Y +0x5A 0x005A #LATIN CAPITAL LETTER Z +0x5B 0x005B #LEFT SQUARE BRACKET +0x5C 0x005C #REVERSE SOLIDUS +0x5D 0x005D #RIGHT SQUARE BRACKET +0x5E 0x005E #CIRCUMFLEX ACCENT +0x5F 0x005F #LOW LINE +0x60 0x0060 #GRAVE ACCENT +0x61 0x0061 #LATIN SMALL LETTER A +0x62 0x0062 #LATIN SMALL LETTER B +0x63 0x0063 #LATIN SMALL LETTER C +0x64 0x0064 #LATIN SMALL LETTER D +0x65 0x0065 #LATIN SMALL LETTER E +0x66 0x0066 #LATIN SMALL LETTER F +0x67 0x0067 #LATIN SMALL LETTER G +0x68 0x0068 #LATIN SMALL LETTER H +0x69 0x0069 #LATIN SMALL LETTER I +0x6A 0x006A #LATIN SMALL LETTER J +0x6B 0x006B #LATIN SMALL LETTER K +0x6C 0x006C #LATIN SMALL LETTER L +0x6D 0x006D #LATIN SMALL LETTER M +0x6E 0x006E #LATIN SMALL LETTER N +0x6F 0x006F #LATIN SMALL LETTER O +0x70 0x0070 #LATIN SMALL LETTER P +0x71 0x0071 #LATIN SMALL LETTER Q +0x72 0x0072 #LATIN SMALL LETTER R +0x73 0x0073 #LATIN SMALL LETTER S +0x74 0x0074 #LATIN SMALL LETTER T +0x75 0x0075 #LATIN SMALL LETTER U +0x76 0x0076 #LATIN SMALL LETTER V +0x77 0x0077 #LATIN SMALL LETTER W +0x78 0x0078 #LATIN SMALL LETTER X +0x79 0x0079 #LATIN SMALL LETTER Y +0x7A 0x007A #LATIN SMALL LETTER Z +0x7B 0x007B #LEFT CURLY BRACKET +0x7C 0x007C #VERTICAL LINE +0x7D 0x007D #RIGHT CURLY BRACKET +0x7E 0x007E #TILDE +0x7F 0x007F #DELETE +0x80 0x20AC #EURO SIGN +0x81 #UNDEFINED +0x82 0x201A #SINGLE LOW-9 QUOTATION MARK +0x83 0x0192 #LATIN SMALL LETTER F WITH HOOK +0x84 0x201E #DOUBLE LOW-9 QUOTATION MARK +0x85 0x2026 #HORIZONTAL ELLIPSIS +0x86 0x2020 #DAGGER +0x87 0x2021 #DOUBLE DAGGER +0x88 0x02C6 #MODIFIER LETTER CIRCUMFLEX ACCENT +0x89 0x2030 #PER MILLE SIGN +0x8A #UNDEFINED +0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK +0x8C 0x0152 #LATIN CAPITAL LIGATURE OE +0x8D #UNDEFINED +0x8E #UNDEFINED +0x8F #UNDEFINED +0x90 #UNDEFINED +0x91 0x2018 #LEFT SINGLE QUOTATION MARK +0x92 0x2019 #RIGHT SINGLE QUOTATION MARK +0x93 0x201C #LEFT DOUBLE QUOTATION MARK +0x94 0x201D #RIGHT DOUBLE QUOTATION MARK +0x95 0x2022 #BULLET +0x96 0x2013 #EN DASH +0x97 0x2014 #EM DASH +0x98 0x02DC #SMALL TILDE +0x99 0x2122 #TRADE MARK SIGN +0x9A #UNDEFINED +0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK +0x9C 0x0153 #LATIN SMALL LIGATURE OE +0x9D #UNDEFINED +0x9E #UNDEFINED +0x9F 0x0178 #LATIN CAPITAL LETTER Y WITH DIAERESIS +0xA0 0x00A0 #NO-BREAK SPACE +0xA1 0x00A1 #INVERTED EXCLAMATION MARK +0xA2 0x00A2 #CENT SIGN +0xA3 0x00A3 #POUND SIGN +0xA4 0x00A4 #CURRENCY SIGN +0xA5 0x00A5 #YEN SIGN +0xA6 0x00A6 #BROKEN BAR +0xA7 0x00A7 #SECTION SIGN +0xA8 0x00A8 #DIAERESIS +0xA9 0x00A9 #COPYRIGHT SIGN +0xAA 0x00AA #FEMININE ORDINAL INDICATOR +0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK +0xAC 0x00AC #NOT SIGN +0xAD 0x00AD #SOFT HYPHEN +0xAE 0x00AE #REGISTERED SIGN +0xAF 0x00AF #MACRON +0xB0 0x00B0 #DEGREE SIGN +0xB1 0x00B1 #PLUS-MINUS SIGN +0xB2 0x00B2 #SUPERSCRIPT TWO +0xB3 0x00B3 #SUPERSCRIPT THREE +0xB4 0x00B4 #ACUTE ACCENT +0xB5 0x00B5 #MICRO SIGN +0xB6 0x00B6 #PILCROW SIGN +0xB7 0x00B7 #MIDDLE DOT +0xB8 0x00B8 #CEDILLA +0xB9 0x00B9 #SUPERSCRIPT ONE +0xBA 0x00BA #MASCULINE ORDINAL INDICATOR +0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK +0xBC 0x00BC #VULGAR FRACTION ONE QUARTER +0xBD 0x00BD #VULGAR FRACTION ONE HALF +0xBE 0x00BE #VULGAR FRACTION THREE QUARTERS +0xBF 0x00BF #INVERTED QUESTION MARK +0xC0 0x00C0 #LATIN CAPITAL LETTER A WITH GRAVE +0xC1 0x00C1 #LATIN CAPITAL LETTER A WITH ACUTE +0xC2 0x00C2 #LATIN CAPITAL LETTER A WITH CIRCUMFLEX +0xC3 0x0102 #LATIN CAPITAL LETTER A WITH BREVE +0xC4 0x00C4 #LATIN CAPITAL LETTER A WITH DIAERESIS +0xC5 0x00C5 #LATIN CAPITAL LETTER A WITH RING ABOVE +0xC6 0x00C6 #LATIN CAPITAL LETTER AE +0xC7 0x00C7 #LATIN CAPITAL LETTER C WITH CEDILLA +0xC8 0x00C8 #LATIN CAPITAL LETTER E WITH GRAVE +0xC9 0x00C9 #LATIN CAPITAL LETTER E WITH ACUTE +0xCA 0x00CA #LATIN CAPITAL LETTER E WITH CIRCUMFLEX +0xCB 0x00CB #LATIN CAPITAL LETTER E WITH DIAERESIS +0xCC 0x0300 #COMBINING GRAVE ACCENT +0xCD 0x00CD #LATIN CAPITAL LETTER I WITH ACUTE +0xCE 0x00CE #LATIN CAPITAL LETTER I WITH CIRCUMFLEX +0xCF 0x00CF #LATIN CAPITAL LETTER I WITH DIAERESIS +0xD0 0x0110 #LATIN CAPITAL LETTER D WITH STROKE +0xD1 0x00D1 #LATIN CAPITAL LETTER N WITH TILDE +0xD2 0x0309 #COMBINING HOOK ABOVE +0xD3 0x00D3 #LATIN CAPITAL LETTER O WITH ACUTE +0xD4 0x00D4 #LATIN CAPITAL LETTER O WITH CIRCUMFLEX +0xD5 0x01A0 #LATIN CAPITAL LETTER O WITH HORN +0xD6 0x00D6 #LATIN CAPITAL LETTER O WITH DIAERESIS +0xD7 0x00D7 #MULTIPLICATION SIGN +0xD8 0x00D8 #LATIN CAPITAL LETTER O WITH STROKE +0xD9 0x00D9 #LATIN CAPITAL LETTER U WITH GRAVE +0xDA 0x00DA #LATIN CAPITAL LETTER U WITH ACUTE +0xDB 0x00DB #LATIN CAPITAL LETTER U WITH CIRCUMFLEX +0xDC 0x00DC #LATIN CAPITAL LETTER U WITH DIAERESIS +0xDD 0x01AF #LATIN CAPITAL LETTER U WITH HORN +0xDE 0x0303 #COMBINING TILDE +0xDF 0x00DF #LATIN SMALL LETTER SHARP S +0xE0 0x00E0 #LATIN SMALL LETTER A WITH GRAVE +0xE1 0x00E1 #LATIN SMALL LETTER A WITH ACUTE +0xE2 0x00E2 #LATIN SMALL LETTER A WITH CIRCUMFLEX +0xE3 0x0103 #LATIN SMALL LETTER A WITH BREVE +0xE4 0x00E4 #LATIN SMALL LETTER A WITH DIAERESIS +0xE5 0x00E5 #LATIN SMALL LETTER A WITH RING ABOVE +0xE6 0x00E6 #LATIN SMALL LETTER AE +0xE7 0x00E7 #LATIN SMALL LETTER C WITH CEDILLA +0xE8 0x00E8 #LATIN SMALL LETTER E WITH GRAVE +0xE9 0x00E9 #LATIN SMALL LETTER E WITH ACUTE +0xEA 0x00EA #LATIN SMALL LETTER E WITH CIRCUMFLEX +0xEB 0x00EB #LATIN SMALL LETTER E WITH DIAERESIS +0xEC 0x0301 #COMBINING ACUTE ACCENT +0xED 0x00ED #LATIN SMALL LETTER I WITH ACUTE +0xEE 0x00EE #LATIN SMALL LETTER I WITH CIRCUMFLEX +0xEF 0x00EF #LATIN SMALL LETTER I WITH DIAERESIS +0xF0 0x0111 #LATIN SMALL LETTER D WITH STROKE +0xF1 0x00F1 #LATIN SMALL LETTER N WITH TILDE +0xF2 0x0323 #COMBINING DOT BELOW +0xF3 0x00F3 #LATIN SMALL LETTER O WITH ACUTE +0xF4 0x00F4 #LATIN SMALL LETTER O WITH CIRCUMFLEX +0xF5 0x01A1 #LATIN SMALL LETTER O WITH HORN +0xF6 0x00F6 #LATIN SMALL LETTER O WITH DIAERESIS +0xF7 0x00F7 #DIVISION SIGN +0xF8 0x00F8 #LATIN SMALL LETTER O WITH STROKE +0xF9 0x00F9 #LATIN SMALL LETTER U WITH GRAVE +0xFA 0x00FA #LATIN SMALL LETTER U WITH ACUTE +0xFB 0x00FB #LATIN SMALL LETTER U WITH CIRCUMFLEX +0xFC 0x00FC #LATIN SMALL LETTER U WITH DIAERESIS +0xFD 0x01B0 #LATIN SMALL LETTER U WITH HORN +0xFE 0x20AB #DONG SIGN +0xFF 0x00FF #LATIN SMALL LETTER Y WITH DIAERESIS diff --git a/basis/io/encodings/8-bit/arabic/arabic-docs.factor b/basis/io/encodings/8-bit/arabic/arabic-docs.factor new file mode 100644 index 0000000000..5c86326121 --- /dev/null +++ b/basis/io/encodings/8-bit/arabic/arabic-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.arabic + +HELP: latin/arabic +{ $var-description "This is the ISO-8859-6 encoding, also called Latin/Arabic. It is an 8-bit superset of ASCII and provides the characters necessary for Arabic, though not other languages which use Arabic script." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.arabic" "Arabic encoding" +"The " { $vocab-link "io.encodings.8-bit.arabic" } " vocabulary provides the " { $link latin/arabic } " encoding." ; + +ABOUT: "io.encodings.8-bit.arabic" diff --git a/basis/io/encodings/8-bit/arabic/arabic.factor b/basis/io/encodings/8-bit/arabic/arabic.factor new file mode 100644 index 0000000000..5a80921ab3 --- /dev/null +++ b/basis/io/encodings/8-bit/arabic/arabic.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.arabic + +8-BIT: latin/arabic ISO_8859-6:1987 8859-6 diff --git a/basis/io/encodings/8-bit/arabic/authors.txt b/basis/io/encodings/8-bit/arabic/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/arabic/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/cyrillic/authors.txt b/basis/io/encodings/8-bit/cyrillic/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/cyrillic/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/cyrillic/cyrillic-docs.factor b/basis/io/encodings/8-bit/cyrillic/cyrillic-docs.factor new file mode 100644 index 0000000000..741f1de1f6 --- /dev/null +++ b/basis/io/encodings/8-bit/cyrillic/cyrillic-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.cyrillic + +HELP: latin/cyrillic +{ $var-description "This is the ISO-8859-5 encoding, also called Latin/Cyrillic. It is an 8-bit superset of ASCII and provides the characters necessary for most languages which use Cyrilic, including Russian, Macedonian, Belarusian, Bulgarian, Serbian, and Ukrainian. KOI8-R is used much more commonly." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.cyrillic" "Cyrillic encoding" +"The " { $vocab-link "io.encodings.8-bit.cyrillic" } " vocabulary provides the " { $link latin/cyrillic } " encoding." ; + +ABOUT: "io.encodings.8-bit.cyrillic" diff --git a/basis/io/encodings/8-bit/cyrillic/cyrillic.factor b/basis/io/encodings/8-bit/cyrillic/cyrillic.factor new file mode 100644 index 0000000000..13cfbc07da --- /dev/null +++ b/basis/io/encodings/8-bit/cyrillic/cyrillic.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.cyrillic + +8-BIT: latin/cyrillic ISO_8859-5:1988 8859-5 diff --git a/basis/io/encodings/8-bit/ebcdic/authors.txt b/basis/io/encodings/8-bit/ebcdic/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/ebcdic/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/ebcdic/ebcdic-docs.factor b/basis/io/encodings/8-bit/ebcdic/ebcdic-docs.factor new file mode 100644 index 0000000000..09646fddc3 --- /dev/null +++ b/basis/io/encodings/8-bit/ebcdic/ebcdic-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.ebcdic + +HELP: ebcdic +{ $var-description "EBCDIC is an 8-bit legacy encoding designed for IBM mainframes like System/360 in the 1960s. It has since fallen into disuse. It contains large unallocated regions, and the version included here (code page 37) contains auxiliary characters in this region for English- and Portugese-speaking countries." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.ebcdic" "EBCDIC encoding" +"The " { $vocab-link "io.encodings.8-bit.ebcdic" } " vocabulary provides the " { $link ebcdic } " encoding." ; + +ABOUT: "io.encodings.8-bit.ebcdic" diff --git a/basis/io/encodings/8-bit/ebcdic/ebcdic.factor b/basis/io/encodings/8-bit/ebcdic/ebcdic.factor new file mode 100644 index 0000000000..fd8f29c40c --- /dev/null +++ b/basis/io/encodings/8-bit/ebcdic/ebcdic.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.ebcdic + +8-BIT: ebcdic IBM037 CP037 diff --git a/basis/io/encodings/8-bit/greek/authors.txt b/basis/io/encodings/8-bit/greek/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/greek/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/greek/greek-docs.factor b/basis/io/encodings/8-bit/greek/greek-docs.factor new file mode 100644 index 0000000000..b7d658ac70 --- /dev/null +++ b/basis/io/encodings/8-bit/greek/greek-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.greek + +HELP: latin/greek +{ $description "This is the ISO-8859-7 encoding, also called Latin/Greek. It is an 8-bit superset of ASCII and provides the characters necessary for Greek written in modern monotonic orthography, or ancient Greek without accent marks." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.greek" "Greek encoding" +"The " { $vocab-link "io.encodings.8-bit.greek" } " vocabulary provides the " { $link latin/greek } " encoding." ; + +ABOUT: "io.encodings.8-bit.greek" diff --git a/basis/io/encodings/8-bit/greek/greek.factor b/basis/io/encodings/8-bit/greek/greek.factor new file mode 100644 index 0000000000..98eb09ad6d --- /dev/null +++ b/basis/io/encodings/8-bit/greek/greek.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.greek + +8-BIT: latin/greek ISO_8859-7:1987 8859-7 diff --git a/basis/io/encodings/8-bit/hebrew/authors.txt b/basis/io/encodings/8-bit/hebrew/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/hebrew/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/hebrew/hebrew-docs.factor b/basis/io/encodings/8-bit/hebrew/hebrew-docs.factor new file mode 100644 index 0000000000..43433e2c91 --- /dev/null +++ b/basis/io/encodings/8-bit/hebrew/hebrew-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.hebrew + +HELP: latin/hebrew +{ $var-description "This is the ISO-8859-8 encoding, also called Latin/Hebrew. It is an 8-bit superset of ASCII and provides the characters necessary for modern Hebrew without explicit vowels. Generally, this is interpreted in logical order, making it ISO-8859-8-I, technically." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.hebrew" "Hebrew encoding" +"The " { $vocab-link "io.encodings.8-bit.hebrew" } " vocabulary provides the " { $link latin/hebrew } " encoding." ; + +ABOUT: "io.encodings.8-bit.hebrew" diff --git a/basis/io/encodings/8-bit/hebrew/hebrew.factor b/basis/io/encodings/8-bit/hebrew/hebrew.factor new file mode 100644 index 0000000000..6619f64fd6 --- /dev/null +++ b/basis/io/encodings/8-bit/hebrew/hebrew.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.hebrew + +8-BIT: latin/hebrew ISO_8859-8:1988 8859-8 diff --git a/basis/io/encodings/8-bit/koi8-r/authors.txt b/basis/io/encodings/8-bit/koi8-r/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/koi8-r/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/koi8-r/koi8-r-docs.factor b/basis/io/encodings/8-bit/koi8-r/koi8-r-docs.factor new file mode 100644 index 0000000000..94e2652e2a --- /dev/null +++ b/basis/io/encodings/8-bit/koi8-r/koi8-r-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.koi8-r + +HELP: koi8-r +{ $var-description "KOI8-R is an 8-bit superset of ASCII which encodes the Cyrillic alphabet, as used in Russian and Bulgarian. Characters are in such an order that, if the eight bit is stripped, text is still interpretable as ASCII. Block-building characters also exist." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.koi8-r" "KOI8-R encoding" +"The " { $vocab-link "io.encodings.8-bit.koi8-r" } " vocabulary provides the " { $link koi8-r } " encoding." ; + +ABOUT: "io.encodings.8-bit.koi8-r" diff --git a/basis/io/encodings/8-bit/koi8-r/koi8-r.factor b/basis/io/encodings/8-bit/koi8-r/koi8-r.factor new file mode 100644 index 0000000000..6203fbd897 --- /dev/null +++ b/basis/io/encodings/8-bit/koi8-r/koi8-r.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.koi8-r + +8-BIT: koi8-r KOI8-R KOI8-R diff --git a/basis/io/encodings/8-bit/latin1/authors.txt b/basis/io/encodings/8-bit/latin1/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/latin1/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/latin1/latin1-docs.factor b/basis/io/encodings/8-bit/latin1/latin1-docs.factor new file mode 100644 index 0000000000..90bc0125a9 --- /dev/null +++ b/basis/io/encodings/8-bit/latin1/latin1-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.latin1 + +HELP: latin1 +{ $var-description "This is the ISO-8859-1 encoding, also called Latin-1: Western European. It is an 8-bit superset of ASCII which is the default for a mimetype starting with 'text' and provides the characters necessary for most western European languages." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.latin1" "Latin1 encoding" +"The " { $vocab-link "io.encodings.8-bit.latin1" } " vocabulary provides the " { $link latin1 } " encoding." ; + +ABOUT: "io.encodings.8-bit.latin1" diff --git a/basis/io/encodings/8-bit/latin1/latin1.factor b/basis/io/encodings/8-bit/latin1/latin1.factor new file mode 100644 index 0000000000..17a2941f74 --- /dev/null +++ b/basis/io/encodings/8-bit/latin1/latin1.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.latin1 + +8-BIT: latin1 ISO_8859-1:1987 8859-1 diff --git a/basis/io/encodings/8-bit/latin10/authors.txt b/basis/io/encodings/8-bit/latin10/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/latin10/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/latin10/latin10-docs.factor b/basis/io/encodings/8-bit/latin10/latin10-docs.factor new file mode 100644 index 0000000000..382b083a26 --- /dev/null +++ b/basis/io/encodings/8-bit/latin10/latin10-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.latin10 + +HELP: latin10 +{ $var-description "This is the ISO-8859-16 encoding, also called Latin-10: South-Eastern European. It is an 8-bit superset of ASCII." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.latin10" "Latin10 encoding" +"The " { $vocab-link "io.encodings.8-bit.latin10" } " vocabulary provides the " { $link latin10 } " encoding." ; + +ABOUT: "io.encodings.8-bit.latin10" diff --git a/basis/io/encodings/8-bit/latin10/latin10.factor b/basis/io/encodings/8-bit/latin10/latin10.factor new file mode 100644 index 0000000000..86831d4116 --- /dev/null +++ b/basis/io/encodings/8-bit/latin10/latin10.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.latin10 + +8-BIT: latin10 ISO-8859-16 8859-16 diff --git a/basis/io/encodings/8-bit/latin2/authors.txt b/basis/io/encodings/8-bit/latin2/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/latin2/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/latin2/latin2-docs.factor b/basis/io/encodings/8-bit/latin2/latin2-docs.factor new file mode 100644 index 0000000000..1da488fe6c --- /dev/null +++ b/basis/io/encodings/8-bit/latin2/latin2-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.latin2 + +HELP: latin2 +{ $var-description "This is the ISO-8859-2 encoding, also called Latin-2: Eastern European. It is an 8-bit superset of ASCII and provides the characters necessary for most eastern European languages." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.latin2" "Latin2 encoding" +"The " { $vocab-link "io.encodings.8-bit.latin2" } " vocabulary provides the " { $link latin2 } " encoding." ; + +ABOUT: "io.encodings.8-bit.latin2" diff --git a/basis/io/encodings/8-bit/latin2/latin2.factor b/basis/io/encodings/8-bit/latin2/latin2.factor new file mode 100644 index 0000000000..52ecc6460d --- /dev/null +++ b/basis/io/encodings/8-bit/latin2/latin2.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.latin2 + +8-BIT: latin2 ISO_8859-2:1987 8859-2 diff --git a/basis/io/encodings/8-bit/latin3/authors.txt b/basis/io/encodings/8-bit/latin3/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/latin3/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/latin3/latin3-docs.factor b/basis/io/encodings/8-bit/latin3/latin3-docs.factor new file mode 100644 index 0000000000..8cb719b890 --- /dev/null +++ b/basis/io/encodings/8-bit/latin3/latin3-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.latin3 + +HELP: latin3 +{ $var-description "This is the ISO-8859-3 encoding, also called Latin-3: South European. It is an 8-bit superset of ASCII and provides the characters necessary for Turkish, Maltese and Esperanto." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.latin3" "Latin3 encoding" +"The " { $vocab-link "io.encodings.8-bit.latin3" } " vocabulary provides the " { $link latin3 } " encoding." ; + +ABOUT: "io.encodings.8-bit.latin3" diff --git a/basis/io/encodings/8-bit/latin3/latin3.factor b/basis/io/encodings/8-bit/latin3/latin3.factor new file mode 100644 index 0000000000..a9a6333b02 --- /dev/null +++ b/basis/io/encodings/8-bit/latin3/latin3.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.latin3 + +8-BIT: latin3 ISO_8859-3:1988 8859-3 diff --git a/basis/io/encodings/8-bit/latin4/authors.txt b/basis/io/encodings/8-bit/latin4/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/latin4/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/latin4/latin4-docs.factor b/basis/io/encodings/8-bit/latin4/latin4-docs.factor new file mode 100644 index 0000000000..cfb53d23b6 --- /dev/null +++ b/basis/io/encodings/8-bit/latin4/latin4-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.latin4 + +HELP: latin4 +{ $description "This is the ISO-8859-4 encoding, also called Latin-4: North European. It is an 8-bit superset of ASCII and provides the characters necessary for Latvian, Lithuanian, Estonian, Greenlandic and Sami." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.latin4" "Latin4 encoding" +"The " { $vocab-link "io.encodings.8-bit.latin4" } " vocabulary provides the " { $link latin4 } " encoding." ; + +ABOUT: "io.encodings.8-bit.latin4" diff --git a/basis/io/encodings/8-bit/latin4/latin4.factor b/basis/io/encodings/8-bit/latin4/latin4.factor new file mode 100644 index 0000000000..34a68a8810 --- /dev/null +++ b/basis/io/encodings/8-bit/latin4/latin4.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.latin4 + +8-BIT: latin4 ISO_8859-4:1988 8859-4 + diff --git a/basis/io/encodings/8-bit/latin5/authors.txt b/basis/io/encodings/8-bit/latin5/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/latin5/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/latin5/latin5-docs.factor b/basis/io/encodings/8-bit/latin5/latin5-docs.factor new file mode 100644 index 0000000000..60feed181c --- /dev/null +++ b/basis/io/encodings/8-bit/latin5/latin5-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.latin5 + +HELP: latin5 +{ $var-description "This is the ISO-8859-9 encoding, also called Latin-5: Turkish. It is an 8-bit superset of ASCII and provides the characters necessary for Turkish, similar to Latin-1 but replacing the spots used for Icelandic with characters used in Turkish." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.latin5" "Latin5 encoding" +"The " { $vocab-link "io.encodings.8-bit.latin5" } " vocabulary provides the " { $link latin5 } " encoding." ; + +ABOUT: "io.encodings.8-bit.latin5" diff --git a/basis/io/encodings/8-bit/latin5/latin5.factor b/basis/io/encodings/8-bit/latin5/latin5.factor new file mode 100644 index 0000000000..502c10fb2f --- /dev/null +++ b/basis/io/encodings/8-bit/latin5/latin5.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.latin5 + +8-BIT: latin5 ISO_8859-9:1989 8859-9 diff --git a/basis/io/encodings/8-bit/latin6/authors.txt b/basis/io/encodings/8-bit/latin6/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/latin6/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/latin6/latin6-docs.factor b/basis/io/encodings/8-bit/latin6/latin6-docs.factor new file mode 100644 index 0000000000..f1866c3ec1 --- /dev/null +++ b/basis/io/encodings/8-bit/latin6/latin6-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.latin6 + +HELP: latin6 +{ $var-description "This is the ISO-8859-10 encoding, also called Latin-6: Nordic. It is an 8-bit superset of ASCII containing the same characters as Latin-4, but rearranged to be of better use to nordic languages." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.latin6" "Latin6 encoding" +"The " { $vocab-link "io.encodings.8-bit.latin6" } " vocabulary provides the " { $link latin6 } " encoding." ; + +ABOUT: "io.encodings.8-bit.latin6" diff --git a/basis/io/encodings/8-bit/latin6/latin6.factor b/basis/io/encodings/8-bit/latin6/latin6.factor new file mode 100644 index 0000000000..5e71f75a2c --- /dev/null +++ b/basis/io/encodings/8-bit/latin6/latin6.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.latin6 + +8-BIT: latin6 ISO-8859-10 8859-10 + diff --git a/basis/io/encodings/8-bit/latin7/authors.txt b/basis/io/encodings/8-bit/latin7/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/latin7/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/latin7/latin7-docs.factor b/basis/io/encodings/8-bit/latin7/latin7-docs.factor new file mode 100644 index 0000000000..ebd5eb6d97 --- /dev/null +++ b/basis/io/encodings/8-bit/latin7/latin7-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.latin7 + +HELP: latin7 +{ $var-description "This is the ISO-8859-13 encoding, also called Latin-7: Baltic Rim. It is an 8-bit superset of ASCII containing all characters necessary to represent Baltic Rim languages, as previous character sets were incomplete." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.latin7" "Latin7 encoding" +"The " { $vocab-link "io.encodings.8-bit.latin7" } " vocabulary provides the " { $link latin7 } " encoding." ; + +ABOUT: "io.encodings.8-bit.latin7" diff --git a/basis/io/encodings/8-bit/latin7/latin7.factor b/basis/io/encodings/8-bit/latin7/latin7.factor new file mode 100644 index 0000000000..862daaea08 --- /dev/null +++ b/basis/io/encodings/8-bit/latin7/latin7.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.latin7 + +8-BIT: latin7 ISO-8859-13 8859-13 diff --git a/basis/io/encodings/8-bit/latin8/authors.txt b/basis/io/encodings/8-bit/latin8/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/latin8/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/latin8/latin8-docs.factor b/basis/io/encodings/8-bit/latin8/latin8-docs.factor new file mode 100644 index 0000000000..5dc2f1e45d --- /dev/null +++ b/basis/io/encodings/8-bit/latin8/latin8-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.latin8 + +HELP: latin8 +{ $var-description "This is the ISO-8859-14 encoding, also called Latin-8: Celtic. It is an 8-bit superset of ASCII designed for Celtic languages like Gaelic and Breton." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.latin8" "Latin8 encoding" +"The " { $vocab-link "io.encodings.8-bit.latin8" } " vocabulary provides the " { $link latin8 } " encoding." ; + +ABOUT: "io.encodings.8-bit.latin8" diff --git a/basis/io/encodings/8-bit/latin8/latin8.factor b/basis/io/encodings/8-bit/latin8/latin8.factor new file mode 100644 index 0000000000..e925737e41 --- /dev/null +++ b/basis/io/encodings/8-bit/latin8/latin8.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.latin8 + +8-BIT: latin8 ISO-8859-14 8859-14 diff --git a/basis/io/encodings/8-bit/latin9/authors.txt b/basis/io/encodings/8-bit/latin9/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/latin9/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/latin9/latin9-docs.factor b/basis/io/encodings/8-bit/latin9/latin9-docs.factor new file mode 100644 index 0000000000..2416db382f --- /dev/null +++ b/basis/io/encodings/8-bit/latin9/latin9-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.latin9 + +HELP: latin9 +{ $var-description "This is the ISO-8859-15 encoding, also called Latin-9 and unoffically as Latin-0. It is an 8-bit superset of ASCII designed as a modification of Latin-1, removing little-used characters in favor of the Euro symbol and other characters." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.latin9" "Latin9 encoding" +"The " { $vocab-link "io.encodings.8-bit.latin9" } " vocabulary provides the " { $link latin9 } " encoding." ; + +ABOUT: "io.encodings.8-bit.latin9" diff --git a/basis/io/encodings/8-bit/latin9/latin9.factor b/basis/io/encodings/8-bit/latin9/latin9.factor new file mode 100644 index 0000000000..b55ecb30ee --- /dev/null +++ b/basis/io/encodings/8-bit/latin9/latin9.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.latin9 + +8-BIT: latin9 ISO-8859-15 8859-15 diff --git a/basis/io/encodings/8-bit/mac-roman/authors.txt b/basis/io/encodings/8-bit/mac-roman/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/mac-roman/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/mac-roman/mac-roman-docs.factor b/basis/io/encodings/8-bit/mac-roman/mac-roman-docs.factor new file mode 100644 index 0000000000..3fd00fa8a3 --- /dev/null +++ b/basis/io/encodings/8-bit/mac-roman/mac-roman-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.mac-roman + +HELP: mac-roman +{ $var-description "Mac Roman is an 8-bit superset of ASCII which was the standard encoding on Mac OS prior to version 10. It is incompatible with Latin-1 in all but a few places and ASCII, and it is suitable for encoding many Western European languages." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.mac-roman" "Mac Roman encoding" +"The " { $vocab-link "io.encodings.8-bit.mac-roman" } " vocabulary provides the " { $link mac-roman } " encoding." ; + +ABOUT: "io.encodings.8-bit.mac-roman" diff --git a/basis/io/encodings/8-bit/mac-roman/mac-roman.factor b/basis/io/encodings/8-bit/mac-roman/mac-roman.factor new file mode 100644 index 0000000000..0b707656e6 --- /dev/null +++ b/basis/io/encodings/8-bit/mac-roman/mac-roman.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.mac-roman + +8-BIT: mac-roman macintosh ROMAN diff --git a/basis/io/encodings/8-bit/thai/authors.txt b/basis/io/encodings/8-bit/thai/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/thai/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/thai/thai-docs.factor b/basis/io/encodings/8-bit/thai/thai-docs.factor new file mode 100644 index 0000000000..5d2640b6fd --- /dev/null +++ b/basis/io/encodings/8-bit/thai/thai-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.thai + +HELP: latin/thai +{ $var-description "This is the ISO-8859-11 encoding, also called Latin/Thai. It is an 8-bit superset of ASCII containing the characters necessary to represent Thai. It is basically identical to TIS-620." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.thai" "Thai encoding" +"The " { $vocab-link "io.encodings.8-bit.thai" } " vocabulary provides the " { $link latin/thai } " encoding." ; + +ABOUT: "io.encodings.8-bit.thai" diff --git a/basis/io/encodings/8-bit/thai/thai.factor b/basis/io/encodings/8-bit/thai/thai.factor new file mode 100644 index 0000000000..8d119f6309 --- /dev/null +++ b/basis/io/encodings/8-bit/thai/thai.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.thai + +8-BIT: latin/thai TIS-620 8859-11 diff --git a/basis/io/encodings/8-bit/windows-1250/authors.txt b/basis/io/encodings/8-bit/windows-1250/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1250/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/windows-1250/windows-1250.factor b/basis/io/encodings/8-bit/windows-1250/windows-1250.factor new file mode 100644 index 0000000000..745ebe4ade --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1250/windows-1250.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.windows-1250 + +8-BIT: windows-1250 windows-1250 CP1250 diff --git a/basis/io/encodings/8-bit/windows-1251/authors.txt b/basis/io/encodings/8-bit/windows-1251/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1251/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/windows-1251/windows-1251.factor b/basis/io/encodings/8-bit/windows-1251/windows-1251.factor new file mode 100644 index 0000000000..3c50d3c733 --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1251/windows-1251.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.windows-1251 + +8-BIT: windows-1251 windows-1251 CP1251 diff --git a/basis/io/encodings/8-bit/windows-1252/authors.txt b/basis/io/encodings/8-bit/windows-1252/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1252/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/windows-1252/windows-1252-docs.factor b/basis/io/encodings/8-bit/windows-1252/windows-1252-docs.factor new file mode 100644 index 0000000000..cd9461e19d --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1252/windows-1252-docs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: io.encodings.8-bit.windows-1252 + +HELP: windows-1252 +{ $var-description "Windows 1252 is an 8-bit superset of ASCII which is closely related to Latin-1. Control characters in the 0x80 to 0x9F range are replaced with printable characters such as the Euro symbol." } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.8-bit.windows-1252" "Windows 1252 encoding" +"The " { $vocab-link "io.encodings.8-bit.windows-1252" } " vocabulary provides the " { $link windows-1252 } " encoding." ; + +ABOUT: "io.encodings.8-bit.windows-1252" diff --git a/basis/io/encodings/8-bit/windows-1252/windows-1252.factor b/basis/io/encodings/8-bit/windows-1252/windows-1252.factor new file mode 100644 index 0000000000..ddcc4df7e2 --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1252/windows-1252.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.windows-1252 + +8-BIT: windows-1252 windows-1252 CP1252 diff --git a/basis/io/encodings/8-bit/windows-1253/authors.txt b/basis/io/encodings/8-bit/windows-1253/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1253/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/windows-1253/windows-1253.factor b/basis/io/encodings/8-bit/windows-1253/windows-1253.factor new file mode 100644 index 0000000000..ba335be72e --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1253/windows-1253.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.windows-1253 + +8-BIT: windows-1253 windows-1253 CP1253 diff --git a/basis/io/encodings/8-bit/windows-1254/authors.txt b/basis/io/encodings/8-bit/windows-1254/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1254/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/windows-1254/windows-1254.factor b/basis/io/encodings/8-bit/windows-1254/windows-1254.factor new file mode 100644 index 0000000000..982d21a259 --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1254/windows-1254.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.windows-1254 + +8-BIT: windows-1254 windows-1254 CP1254 diff --git a/basis/io/encodings/8-bit/windows-1255/authors.txt b/basis/io/encodings/8-bit/windows-1255/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1255/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/windows-1255/windows-1255.factor b/basis/io/encodings/8-bit/windows-1255/windows-1255.factor new file mode 100644 index 0000000000..952e5fe556 --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1255/windows-1255.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.windows-1255 + +8-BIT: windows-1255 windows-1255 CP1255 diff --git a/basis/io/encodings/8-bit/windows-1256/authors.txt b/basis/io/encodings/8-bit/windows-1256/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1256/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/windows-1256/windows-1256.factor b/basis/io/encodings/8-bit/windows-1256/windows-1256.factor new file mode 100644 index 0000000000..303d25c461 --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1256/windows-1256.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.windows-1256 + +8-BIT: windows-1256 windows-1256 CP1256 diff --git a/basis/io/encodings/8-bit/windows-1257/authors.txt b/basis/io/encodings/8-bit/windows-1257/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1257/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/windows-1257/windows-1257.factor b/basis/io/encodings/8-bit/windows-1257/windows-1257.factor new file mode 100644 index 0000000000..80b21e8d94 --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1257/windows-1257.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.windows-1257 + +8-BIT: windows-1257 windows-1257 CP1257 diff --git a/basis/io/encodings/8-bit/windows-1258/authors.txt b/basis/io/encodings/8-bit/windows-1258/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1258/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/io/encodings/8-bit/windows-1258/windows-1258.factor b/basis/io/encodings/8-bit/windows-1258/windows-1258.factor new file mode 100644 index 0000000000..1c7bf63540 --- /dev/null +++ b/basis/io/encodings/8-bit/windows-1258/windows-1258.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.8-bit ; +IN: io.encodings.8-bit.windows-1258 + +8-BIT: windows-1258 windows-1258 CP1258 diff --git a/basis/io/encodings/gb18030/gb18030.factor b/basis/io/encodings/gb18030/gb18030.factor index 2be709dbc9..512b52ef19 100644 --- a/basis/io/encodings/gb18030/gb18030.factor +++ b/basis/io/encodings/gb18030/gb18030.factor @@ -48,7 +48,8 @@ TUPLE: range ufirst ulast bfirst blast ; ] dip set-at ; : xml>gb-data ( stream -- mapping ranges ) - [let | mapping [ H{ } clone ] ranges [ V{ } clone ] | + [let + H{ } clone :> mapping V{ } clone :> ranges [ dup contained? [ dup name>> main>> { @@ -57,7 +58,7 @@ TUPLE: range ufirst ulast bfirst blast ; [ 2drop ] } case ] [ drop ] if - ] each-element mapping ranges + ] each-element mapping ranges ] ; : unlinear ( num -- bytes ) @@ -66,7 +67,7 @@ TUPLE: range ufirst ulast bfirst blast ; 126 /mod HEX: 81 + swap 10 /mod HEX: 30 + swap HEX: 81 + - 4byte-array dup reverse-here ; + 4byte-array reverse! ; : >interval-map-by ( start-quot end-quot value-quot seq -- interval-map ) '[ _ [ @ 2array ] _ tri ] { } map>assoc ; inline diff --git a/basis/io/encodings/iana/iana.factor b/basis/io/encodings/iana/iana.factor index 594e245a9c..a2a919da0d 100644 --- a/basis/io/encodings/iana/iana.factor +++ b/basis/io/encodings/iana/iana.factor @@ -57,4 +57,4 @@ e>n-table [ initial-e>n ] initialize ascii "ANSI_X3.4-1968" register-encoding utf16be "UTF-16BE" register-encoding utf16le "UTF-16LE" register-encoding -utf16 "UTF-16" register-encoding \ No newline at end of file +utf16 "UTF-16" register-encoding diff --git a/basis/io/encodings/iso2022/iso2022.factor b/basis/io/encodings/iso2022/iso2022.factor index a057df28e0..1726426777 100644 --- a/basis/io/encodings/iso2022/iso2022.factor +++ b/basis/io/encodings/iso2022/iso2022.factor @@ -31,7 +31,7 @@ M: iso2022 M: iso2022 make-iso-coder ; -<< SYNTAX: ESC HEX: 16 parsed ; >> +<< SYNTAX: ESC HEX: 16 suffix! ; >> CONSTANT: switch-ascii B{ ESC CHAR: ( CHAR: B } CONSTANT: switch-jis201 B{ ESC CHAR: ( CHAR: J } diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor index 04dfce7643..8ec5753e11 100644 --- a/basis/io/files/info/unix/linux/linux.factor +++ b/basis/io/files/info/unix/linux/linux.factor @@ -80,7 +80,7 @@ M: linux file-systems ] if ; : find-mount-point ( path -- mtab-entry ) - canonicalize-path + resolve-symlinks parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ; ERROR: file-system-not-found ; diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index 5ae21fcfee..9f0e4534e9 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -151,12 +151,16 @@ PRIVATE> M: winnt file-system-info ( path -- file-system-info ) normalize-path root-directory (file-system-info) ; -: volume>paths ( string -- array ) - 16384 tuck dup length - 0 dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [ - win32-error-string throw +:: volume>paths ( string -- array ) + 16384 :> names-buf-length + names-buf-length :> names + 0 :> names-length + + string names names-buf-length names-length GetVolumePathNamesForVolumeName :> ret + ret 0 = [ + ret win32-error-string throw ] [ - *uint "ushort" heap-size * head + names names-length *uint "ushort" heap-size * head utf16n alien>string CHAR: \0 split ] if ; @@ -166,13 +170,16 @@ M: winnt file-system-info ( path -- file-system-info ) FindFirstVolume dup win32-error=0/f [ utf16n alien>string ] dip ; -: find-next-volume ( handle -- string/f ) - MAX_PATH 1 + [ tuck ] keep - FindNextVolume 0 = [ +:: find-next-volume ( handle -- string/f ) + MAX_PATH 1 + :> buf-length + buf-length :> buf + + handle buf buf-length FindNextVolume :> ret + ret 0 = [ GetLastError ERROR_NO_MORE_FILES = - [ drop f ] [ win32-error-string throw ] if + [ f ] [ win32-error-string throw ] if ] [ - utf16n alien>string + buf utf16n alien>string ] if ; : find-volumes ( -- array ) diff --git a/basis/io/files/links/unix/unix.factor b/basis/io/files/links/unix/unix.factor index c9a651b484..f41adfa731 100644 --- a/basis/io/files/links/unix/unix.factor +++ b/basis/io/files/links/unix/unix.factor @@ -13,6 +13,6 @@ M: unix make-hard-link ( path1 path2 -- ) M: unix read-link ( path -- path' ) normalize-path read-symbolic-link ; -M: unix canonicalize-path ( path -- path' ) +M: unix resolve-symlinks ( path -- path' ) path-components "/" [ append-path dup exists? [ follow-links ] when ] reduce ; diff --git a/basis/io/files/windows/nt/nt.factor b/basis/io/files/windows/nt/nt.factor index 97754cf237..10c5710f7d 100755 --- a/basis/io/files/windows/nt/nt.factor +++ b/basis/io/files/windows/nt/nt.factor @@ -38,7 +38,7 @@ M: winnt root-directory? ( path -- ? ) TR: normalize-separators "/" "\\" ; M: winnt normalize-path ( string -- string' ) - (normalize-path) + absolute-path normalize-separators prepend-prefix ; diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index d1a41a1f09..cb20f78a33 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -82,8 +82,6 @@ SYMBOL: wait-flag V{ } clone swap processes get set-at wait-flag get-global raise-flag ; -M: process hashcode* handle>> hashcode* ; - : pass-environment? ( process -- ? ) dup environment>> assoc-empty? not swap environment-mode>> +replace-environment+ eq? or ; diff --git a/basis/io/launcher/unix/unix-tests.factor b/basis/io/launcher/unix/unix-tests.factor index 852d8171e4..7fa7f4b2c6 100644 --- a/basis/io/launcher/unix/unix-tests.factor +++ b/basis/io/launcher/unix/unix-tests.factor @@ -125,14 +125,15 @@ concurrency.promises threads unix.process ; ! Killed processes were exiting with code 0 on FreeBSD [ f ] [ - [let | p [ ] - s [ ] | - [ - "sleep 1000" run-detached - [ p fulfill ] [ wait-for-process s fulfill ] bi - ] in-thread + [let + :> p + :> s + [ + "sleep 1000" run-detached + [ p fulfill ] [ wait-for-process s fulfill ] bi + ] in-thread - p ?promise handle>> 9 kill drop - s ?promise 0 = + p ?promise handle>> 9 kill drop + s ?promise 0 = ] ] unit-test diff --git a/basis/io/launcher/unix/unix.factor b/basis/io/launcher/unix/unix.factor index 5424ab4238..a9e3324986 100644 --- a/basis/io/launcher/unix/unix.factor +++ b/basis/io/launcher/unix/unix.factor @@ -71,7 +71,7 @@ IN: io.launcher.unix : spawn-process ( process -- * ) [ setup-priority ] [ 250 _exit ] recover [ setup-redirection ] [ 251 _exit ] recover - [ current-directory get (normalize-path) cd ] [ 252 _exit ] recover + [ current-directory get absolute-path cd ] [ 252 _exit ] recover [ setup-environment ] [ 253 _exit ] recover [ get-arguments exec-args-with-path ] [ 254 _exit ] recover 255 _exit ; diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index 39455da578..8a800115f6 100755 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -129,10 +129,10 @@ M: windows current-process-handle ( -- handle ) M: windows run-process* ( process -- handle ) [ - current-directory get (normalize-path) cd + current-directory get absolute-path cd dup make-CreateProcess-args - tuck fill-redirection + [ fill-redirection ] keep dup call-CreateProcess lpProcessInformation>> ] with-destructors ; diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index fe16e08467..33ba6850a5 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -68,8 +68,7 @@ ARTICLE: "io.mmap.arrays" "Working with memory-mapped data" "The " { $link } " word returns an instance of " { $link mapped-file } ", which doesn't directly support the sequence protocol. Instead, it needs to be wrapped in a specialized array of the appropriate C type:" { $subsections } "Additionally, files may be opened with two combinators which take a c-type as input:" -{ $subsections with-mapped-array } -{ $subsections with-mapped-array-reader } +{ $subsections with-mapped-array with-mapped-array-reader } "The appropriate specialized array type must first be generated with " { $link POSTPONE: SPECIALIZED-ARRAY: } "." $nl "Data can also be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. This approach is not recommended, though, since in most cases the compiler will generate efficient code for specialized array usage. See " { $link "reading-writing-memory" } " for a description of low-level memory access primitives." ; @@ -82,7 +81,7 @@ ARTICLE: "io.mmap.examples" "Memory-mapped file examples" "" "\"mydata.dat\" char [" " 4 " - " [ reverse-here ] change-each" + " [ reverse! drop ] map! drop" "] with-mapped-array" } "Normalize a file containing packed quadrupes of floats:" @@ -92,7 +91,7 @@ ARTICLE: "io.mmap.examples" "Memory-mapped file examples" "SPECIALIZED-ARRAY: float-4" "" "\"mydata.dat\" float-4 [" - " [ normalize ] change-each" + " [ normalize ] map! drop" "] with-mapped-array" } ; @@ -101,10 +100,10 @@ ARTICLE: "io.mmap" "Memory-mapped files" { $subsections } "Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "." $nl "Utility combinators which wrap the above:" -{ $subsections with-mapped-file } -{ $subsections with-mapped-file-reader } -{ $subsections with-mapped-array } -{ $subsections with-mapped-array-reader } +{ $subsections with-mapped-file + with-mapped-file-reader + with-mapped-array + with-mapped-array-reader } "Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:" { $subsections "io.mmap.arrays" diff --git a/basis/io/mmap/windows/windows.factor b/basis/io/mmap/windows/windows.factor index a2c1f972a6..e3e3116b59 100644 --- a/basis/io/mmap/windows/windows.factor +++ b/basis/io/mmap/windows/windows.factor @@ -12,14 +12,13 @@ IN: io.mmap.windows MapViewOfFile [ win32-error=0/f ] keep ; :: mmap-open ( path length access-mode create-mode protect access -- handle handle address ) - [let | lo [ length 32 bits ] - hi [ length -32 shift 32 bits ] | - { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [ - path access-mode create-mode 0 open-file |dispose - dup handle>> f protect hi lo f create-file-mapping |dispose - dup handle>> access 0 0 0 map-view-of-file - ] with-privileges - ] ; + length 32 bits :> lo + length -32 shift 32 bits :> hi + { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [ + path access-mode create-mode 0 open-file |dispose + dup handle>> f protect hi lo f create-file-mapping |dispose + dup handle>> access 0 0 0 map-view-of-file + ] with-privileges ; TUPLE: win32-mapped-file file mapping ; diff --git a/basis/io/monitors/linux/linux.factor b/basis/io/monitors/linux/linux.factor index 3e1e919217..7653eaa84c 100644 --- a/basis/io/monitors/linux/linux.factor +++ b/basis/io/monitors/linux/linux.factor @@ -36,7 +36,7 @@ TUPLE: linux-monitor < monitor wd inotify watches ; inotify-fd -rot inotify_add_watch dup io-error dup check-existing ; : add-watch ( path mask mailbox -- monitor ) - [ [ (normalize-path) ] dip [ (add-watch) ] [ drop ] 2bi ] dip + [ [ absolute-path ] dip [ (add-watch) ] [ drop ] 2bi ] dip [ ] [ ] [ wd>> ] tri watches get set-at ; : check-inotify ( -- ) diff --git a/basis/io/monitors/macosx/macosx.factor b/basis/io/monitors/macosx/macosx.factor index 96f178fb79..e71fb2eca2 100644 --- a/basis/io/monitors/macosx/macosx.factor +++ b/basis/io/monitors/macosx/macosx.factor @@ -11,11 +11,10 @@ TUPLE: macosx-monitor < monitor handle ; '[ first { +modify-file+ } _ queue-change ] each ; M:: macosx (monitor) ( path recursive? mailbox -- monitor ) - [let | path [ path normalize-path ] | - path mailbox macosx-monitor new-monitor - dup [ enqueue-notifications ] curry - path 1array 0 0 >>handle - ] ; + path normalize-path :> path + path mailbox macosx-monitor new-monitor + dup [ enqueue-notifications ] curry + path 1array 0 0 >>handle ; M: macosx-monitor dispose* handle>> dispose ; diff --git a/basis/io/monitors/recursive/recursive.factor b/basis/io/monitors/recursive/recursive.factor index 75dfd234a8..33477abdb6 100644 --- a/basis/io/monitors/recursive/recursive.factor +++ b/basis/io/monitors/recursive/recursive.factor @@ -95,7 +95,7 @@ M: recursive-monitor dispose* ready>> ?promise ?linked drop ; : ( path mailbox -- monitor ) - [ (normalize-path) ] dip + [ absolute-path ] dip recursive-monitor new-monitor H{ } clone >>children >>ready diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 8cdd1d97bd..3ea4c105f5 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -53,7 +53,7 @@ M: input-port stream-read-partial ( max stream -- byte-array/f ) : read-loop ( count port accum -- ) pick over length - dup 0 > [ pick read-step dup [ - over push-all read-loop + append! read-loop ] [ 2drop 2drop ] if @@ -78,7 +78,7 @@ M: input-port stream-read : read-until-loop ( seps port buf -- separator/f ) 2over read-until-step over [ - [ over push-all ] dip dup [ + [ append! ] dip dup [ [ 3drop ] dip ] [ drop read-until-loop diff --git a/basis/io/servers/packet/packet.factor b/basis/io/servers/packet/packet.factor deleted file mode 100644 index 2a346b4d13..0000000000 --- a/basis/io/servers/packet/packet.factor +++ /dev/null @@ -1,23 +0,0 @@ -USING: concurrency.combinators destructors fry -io.sockets kernel logging ; -IN: io.servers.packet - - [ datagram-loop ] with-disposal ; inline - -\ spawn-datagrams NOTICE add-input-logging - -PRIVATE> - -: with-datagrams ( seq service quot -- ) - '[ [ [ _ ] dip spawn-datagrams ] parallel-each ] with-logging ; inline diff --git a/basis/io/servers/packet/summary.txt b/basis/io/servers/packet/summary.txt deleted file mode 100644 index 29247a2937..0000000000 --- a/basis/io/servers/packet/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Multi-threaded UDP/IP servers diff --git a/basis/io/servers/packet/tags.txt b/basis/io/servers/packet/tags.txt deleted file mode 100644 index 992ae12982..0000000000 --- a/basis/io/servers/packet/tags.txt +++ /dev/null @@ -1 +0,0 @@ -network diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor index 400a44ea02..b3cf28a497 100644 --- a/basis/io/sockets/secure/openssl/openssl.factor +++ b/basis/io/sockets/secure/openssl/openssl.factor @@ -5,7 +5,7 @@ math.order combinators init alien alien.c-types alien.data alien.strings libc continuations destructors summary splitting assocs random math.parser locals unicode.case openssl openssl.libcrypto openssl.libssl io.backend io.ports io.pathnames -io.encodings.8-bit io.timeouts io.sockets.secure ; +io.encodings.8-bit.latin1 io.timeouts io.sockets.secure ; IN: io.sockets.secure.openssl GENERIC: ssl-method ( symbol -- method ) @@ -25,7 +25,7 @@ TUPLE: openssl-context < secure-context aliens sessions ; : load-certificate-chain ( ctx -- ) dup config>> key-file>> [ - [ handle>> ] [ config>> key-file>> (normalize-path) ] bi + [ handle>> ] [ config>> key-file>> absolute-path ] bi SSL_CTX_use_certificate_chain_file ssl-error ] [ drop ] if ; @@ -35,10 +35,9 @@ TUPLE: openssl-context < secure-context aliens sessions ; [| buf size rwflag password! | password [ B{ 0 } password! ] unless - [let | len [ password strlen ] | - buf password len 1 + size min memcpy - len - ] + password strlen :> len + buf password len 1 + size min memcpy + len ] alien-callback ; : default-pasword ( ctx -- alien ) @@ -56,7 +55,7 @@ TUPLE: openssl-context < secure-context aliens sessions ; : use-private-key-file ( ctx -- ) dup config>> key-file>> [ - [ handle>> ] [ config>> key-file>> (normalize-path) ] bi + [ handle>> ] [ config>> key-file>> absolute-path ] bi SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file ssl-error ] [ drop ] if ; @@ -66,8 +65,8 @@ TUPLE: openssl-context < secure-context aliens sessions ; [ handle>> ] [ config>> - [ ca-file>> dup [ (normalize-path) ] when ] - [ ca-path>> dup [ (normalize-path) ] when ] bi + [ ca-file>> dup [ absolute-path ] when ] + [ ca-path>> dup [ absolute-path ] when ] bi ] bi SSL_CTX_load_verify_locations ] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ; diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index a542575446..e45224fcc2 100755 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -173,6 +173,8 @@ GENERIC: (get-remote-address) ( handle remote -- sockaddr ) [ |dispose ] [ |dispose ] bi ] with-destructors ; +SYMBOL: bind-local-address + GENERIC: establish-connection ( client-out remote -- ) GENERIC: ((client)) ( remote -- handle ) @@ -321,6 +323,18 @@ M: invalid-inet-server summary M: inet (server) invalid-inet-server ; +ERROR: invalid-local-address addrspec ; + +M: invalid-local-address summary + drop "Cannot use with-local-address with ; use or instead" ; + +: with-local-address ( addr quot -- ) + [ + [ ] [ inet4? ] [ inet6? ] tri or + [ bind-local-address ] + [ invalid-local-address ] if + ] dip with-variable ; inline + { { [ os unix? ] [ "io.sockets.unix" require ] } { [ os winnt? ] [ "io.sockets.windows.nt" require ] } diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index d2df4d9e13..71ad5a5758 100755 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -69,8 +69,12 @@ M: object establish-connection ( client-out remote -- ) [ (io-error) ] } cond ; +: ?bind-client ( socket -- ) + bind-local-address get [ [ fd>> ] dip make-sockaddr/size bind io-error ] [ drop ] if* ; inline + M: object ((client)) ( addrspec -- fd ) - protocol-family SOCK_STREAM socket-fd dup init-client-socket ; + protocol-family SOCK_STREAM socket-fd + [ init-client-socket ] [ ?bind-client ] [ ] tri ; ! Server sockets - TCP and Unix domain : init-server-socket ( fd -- ) @@ -116,7 +120,7 @@ CONSTANT: packet-size 65536 [ packet-size malloc &free receive-buffer set-global ] "io.sockets.unix" add-startup-hook :: do-receive ( port -- packet sockaddr ) - port addr>> empty-sockaddr/size :> len :> sockaddr + port addr>> empty-sockaddr/size :> ( sockaddr len ) port handle>> handle-fd ! s receive-buffer get-global ! buf packet-size ! nbytes @@ -159,7 +163,7 @@ M: local sockaddr-size drop sockaddr-un heap-size ; M: local empty-sockaddr drop sockaddr-un ; M: local make-sockaddr - path>> (normalize-path) + path>> absolute-path dup length 1 + max-un-path > [ "Path too long" throw ] when sockaddr-un AF_UNIX >>family diff --git a/basis/io/sockets/windows/windows.factor b/basis/io/sockets/windows/windows.factor index ccf86ca308..0f3ac39607 100755 --- a/basis/io/sockets/windows/windows.factor +++ b/basis/io/sockets/windows/windows.factor @@ -1,6 +1,9 @@ +! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors io.sockets io.sockets.private io.backend.windows io.backend windows.winsock system destructors alien.c-types classes.struct combinators ; +FROM: namespaces => get ; IN: io.sockets.windows M: windows addrinfo-error ( n -- ) @@ -55,7 +58,11 @@ M: object (get-remote-address) ( socket addrspec -- sockaddr ) M: object ((client)) ( addrspec -- handle ) [ SOCK_STREAM open-socket ] keep - [ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ; + [ + bind-local-address get + [ nip make-sockaddr/size ] + [ unspecific-sockaddr/size ] if* bind-socket + ] [ drop ] 2bi ; : server-socket ( addrspec type -- fd ) [ open-socket ] [ drop ] 2bi diff --git a/basis/io/streams/limited/limited-tests.factor b/basis/io/streams/limited/limited-tests.factor index 022d20eb5e..047cd117a0 100644 --- a/basis/io/streams/limited/limited-tests.factor +++ b/basis/io/streams/limited/limited-tests.factor @@ -1,8 +1,9 @@ USING: accessors continuations destructors io io.encodings -io.encodings.8-bit io.encodings.ascii io.encodings.binary +io.encodings.ascii io.encodings.binary io.encodings.string io.encodings.utf8 io.files io.pipes io.streams.byte-array io.streams.limited io.streams.string -kernel namespaces strings tools.test system ; +kernel namespaces strings tools.test system +io.encodings.8-bit.latin1 ; IN: io.streams.limited.tests [ ] [ diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index 403643ed73..f5aab9c976 100755 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -123,7 +123,7 @@ M: limited-stream stream-read-partial matrix + old length [| i | + new length + [| j | i j matrix old new step loop-step ] each + ] each matrix ; inline PRIVATE> : levenshtein ( old new -- n ) diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor index c6a2d0c050..a054067755 100644 --- a/basis/listener/listener-docs.factor +++ b/basis/listener/listener-docs.factor @@ -48,10 +48,12 @@ $nl "Multi-line expressions are supported:" { $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" } "The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them." +$nl +"The listener will display the current contents of the datastack after every expression is evaluated. The listener can additionally watch dynamic variables:" { $subsections "listener-watch" } "To start a nested listener:" { $subsections listener } -"To exit the listener, invoke the " { $link return } " word." +"To exit a listener, invoke the " { $link return } " word." $nl "Multi-line quotations can be read independently of the rest of the listener:" { $subsections read-quot } ; diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index 57d1fd3964..a42eada563 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -163,8 +163,10 @@ SYMBOL: interactive-vocabs "syntax" "tools.annotations" "tools.crossref" + "tools.deprecation" "tools.destructors" "tools.disassembler" + "tools.dispatch" "tools.errors" "tools.memory" "tools.profiler" diff --git a/basis/lists/lazy/lazy-tests.factor b/basis/lists/lazy/lazy-tests.factor index 8fb638b856..39f92158a6 100644 --- a/basis/lists/lazy/lazy-tests.factor +++ b/basis/lists/lazy/lazy-tests.factor @@ -35,5 +35,7 @@ IN: lists.lazy.tests [ [ drop ] leach ] must-infer [ lnth ] must-infer +[ { 1 2 3 } ] [ { 1 2 3 4 5 } >list [ 2 > ] luntil list>array ] unit-test + [ ] [ "resource:license.txt" utf8 llines list>array drop ] unit-test [ ] [ "resource:license.txt" utf8 lcontents list>array drop ] unit-test diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index 7b386e9c81..122a2205dd 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -111,14 +111,15 @@ C: lazy-until over nil? [ drop ] [ ] if ; M: lazy-until car ( lazy-until -- car ) - cons>> car ; + cons>> car ; M: lazy-until cdr ( lazy-until -- cdr ) - [ cons>> unswons ] keep quot>> tuck call( elt -- ? ) - [ 2drop nil ] [ luntil ] if ; + [ [ cons>> cdr ] [ quot>> ] bi ] + [ [ cons>> car ] [ quot>> ] bi call( elt -- ? ) ] bi + [ 2drop nil ] [ luntil ] if ; M: lazy-until nil? ( lazy-until -- ? ) - drop f ; + drop f ; TUPLE: lazy-while cons quot ; @@ -128,13 +129,13 @@ C: lazy-while over nil? [ drop ] [ ] if ; M: lazy-while car ( lazy-while -- car ) - cons>> car ; + cons>> car ; M: lazy-while cdr ( lazy-while -- cdr ) - [ cons>> cdr ] keep quot>> lwhile ; + [ cons>> cdr ] keep quot>> lwhile ; M: lazy-while nil? ( lazy-while -- ? ) - [ car ] keep quot>> call( elt -- ? ) not ; + [ car ] keep quot>> call( elt -- ? ) not ; TUPLE: lazy-filter cons quot ; diff --git a/basis/lists/lists-docs.factor b/basis/lists/lists-docs.factor index f70b6ff4a1..53fde94687 100644 --- a/basis/lists/lists-docs.factor +++ b/basis/lists/lists-docs.factor @@ -44,7 +44,6 @@ ARTICLE: { "lists" "combinators" } "Combinators for lists" foldl foldr lmap>array - traverse } ; ARTICLE: { "lists" "manipulation" } "Manipulating lists" @@ -122,7 +121,7 @@ HELP: uncons { $description "Put the head and tail of the list on the stack." } ; HELP: unswons -{ $values { "cons" list } { "car" "the head of the list" } { "cdr" "the tail of the list" } } +{ $values { "cons" list } { "cdr" "the tail of the list" } { "car" "the head of the list" } } { $description "Put the head and tail of the list on the stack." } ; { leach foldl lmap>array } related-words @@ -151,12 +150,6 @@ HELP: list>array { $values { "list" list } { "array" array } } { $description "Convert a list into an array." } ; -HELP: traverse -{ $values { "list" list } { "pred" { $quotation "( list/elt -- ? )" } } - { "quot" { $quotation "( list/elt -- result)" } } { "result" "a new cons object" } } -{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred" - " returns true for with the result of applying quot to." } ; - HELP: list { $class-description "The class of lists. All lists are expected to conform to " { $link { "lists" "protocol" } } "." } ; diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index ddf1ab9109..f3475f960b 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -93,11 +93,5 @@ PRIVATE> : list>array ( list -- array ) [ ] lmap>array ; -:: traverse ( list pred quot: ( list/elt -- result ) -- result ) - list [| elt | - elt dup pred call [ quot call ] when - dup list? [ pred quot traverse ] when - ] lmap ; inline recursive - INSTANCE: cons list INSTANCE: +nil+ list diff --git a/basis/locals/errors/errors.factor b/basis/locals/errors/errors.factor index e7b4c5a884..468671361f 100644 --- a/basis/locals/errors/errors.factor +++ b/basis/locals/errors/errors.factor @@ -9,10 +9,10 @@ M: >r/r>-in-lambda-error summary drop "Explicit retain stack manipulation is not permitted in lambda bodies" ; -ERROR: binding-form-in-literal-error ; +ERROR: let-form-in-literal-error ; -M: binding-form-in-literal-error summary - drop "[let, [let* and [wlet not permitted inside literals" ; +M: let-form-in-literal-error summary + drop "[let not permitted inside literals" ; ERROR: local-writer-in-literal-error ; @@ -27,7 +27,7 @@ M: local-word-in-literal-error summary ERROR: :>-outside-lambda-error ; M: :>-outside-lambda-error summary - drop ":> cannot be used outside of lambda expressions" ; + drop ":> cannot be used outside of [let, [|, or :: forms" ; ERROR: bad-local args obj ; diff --git a/basis/locals/fry/fry.factor b/basis/locals/fry/fry.factor index 9dc924334c..a2a1a6c178 100644 --- a/basis/locals/fry/fry.factor +++ b/basis/locals/fry/fry.factor @@ -1,18 +1,21 @@ ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: accessors fry fry.private generalizations kernel -locals.types make sequences ; +locals.types sequences ; IN: locals.fry ! Support for mixing locals with fry -M: binding-form count-inputs body>> count-inputs ; - +M: let count-inputs body>> count-inputs ; M: lambda count-inputs body>> count-inputs ; -M: lambda deep-fry - clone [ shallow-fry swap ] change-body - [ [ vars>> length ] keep '[ _ _ mnswap @ ] , ] [ drop [ncurry] % ] 2bi ; +M: lambda fry + clone [ [ count-inputs ] [ fry ] bi ] change-body + [ [ vars>> length ] keep '[ _ _ mnswap _ call ] ] + [ drop [ncurry] curry [ call ] compose ] 2bi ; -M: binding-form deep-fry - clone [ fry '[ @ call ] ] change-body , ; +M: let fry + clone [ fry ] change-body ; + +INSTANCE: lambda fried +INSTANCE: let fried diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index c9c5e7330e..f44b5177e1 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -4,125 +4,166 @@ IN: locals HELP: [| { $syntax "[| bindings... | body... ]" } -{ $description "A lambda abstraction. When called, reads stack values into the bindings from left to right; the body may then refer to these bindings." } -{ $examples - { $example - "USING: kernel locals math prettyprint ;" - "IN: scratchpad" - ":: adder ( n -- quot ) [| m | m n + ] ;" - "3 5 adder call ." - "8" - } -} ; +{ $description "A literal quotation with named variable bindings. When the quotation is " { $link call } "ed, it will take values off the datastack values and place them into the bindings from left to right. The body may then refer to these bindings. The quotation may also bind to named variables in an enclosing scope to create a closure." } +{ $examples "See " { $link "locals-examples" } "." } ; HELP: [let -{ $syntax "[let | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" } -{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [let } " form; for Lisp programmers, this means that " { $link POSTPONE: [let } " is equivalent to the Lisp " { $snippet "let" } ", not " { $snippet "let*" } "." } -{ $examples - { $example - "USING: kernel locals math math.functions prettyprint sequences ;" - "IN: scratchpad" - ":: frobnicate ( n seq -- newseq )" - " [let | n' [ n 6 * ] |" - " seq [ n' gcd nip ] map ] ;" - "6 { 36 14 } frobnicate ." - "{ 36 2 }" - } -} ; - -HELP: [let* -{ $syntax "[let* | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" } -{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated sequentially, and may refer to previous bindings from the same " { $link POSTPONE: [let* } " form; for Lisp programmers, this means that " { $link POSTPONE: [let* } " is equivalent to the Lisp " { $snippet "let*" } ", not " { $snippet "let" } "." } -{ $examples - { $example - "USING: kernel locals math math.functions prettyprint sequences ;" - "IN: scratchpad" - ":: frobnicate ( n seq -- newseq )" - " [let* | a [ n 3 + ]" - " b [ a 4 * ] |" - " seq [ b / ] map ] ;" - "1 { 32 48 } frobnicate ." - "{ 2 3 }" - } -} ; - -{ POSTPONE: [let POSTPONE: [let* } related-words - -HELP: [wlet -{ $syntax "[wlet | binding1 [ body1... ]\n binding2 [ body2... ]\n ... |\n body... ]" } -{ $description "Introduces a set of lexically-scoped non-recursive local functions. The bodies may not refer to other bindings within the same " { $link POSTPONE: [wlet } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [wlet } " is equivalent to the Lisp " { $snippet "flet" } ", not " { $snippet "labels" } "." } -{ $examples - { $example - "USING: locals math prettyprint sequences ;" - "IN: scratchpad" - ":: quuxify ( n seq -- newseq )" - " [wlet | add-n [| m | m n + ] |" - " seq [ add-n ] map ] ;" - "2 { 1 2 3 } quuxify ." - "{ 3 4 5 }" - } -} ; +{ $syntax "[let code :> var code :> var code... ]" } +{ $description "Establishes a new scope for lexical variable bindings. Variables bound with " { $link POSTPONE: :> } " within the body of the " { $snippet "[let" } " will be lexically scoped to the body of the " { $snippet "[let" } " form." } +{ $examples "See " { $link "locals-examples" } "." } ; HELP: :> -{ $syntax ":> binding" } -{ $description "Introduces a new binding, lexically scoped to the enclosing quotation or definition." } +{ $syntax ":> var" ":> var!" ":> ( var-1 var-2 ... )" } +{ $description "Binds one or more new lexical variables. In the " { $snippet ":> var" } " form, the value on the top of the datastack to a new lexical variable named " { $snippet "var" } " and scoped to the enclosing quotation, " { $link POSTPONE: [let } " form, or " { $link POSTPONE: :: } " definition." +$nl +"The " { $snippet ":> ( var-1 ... )" } " form binds multiple variables to the top values off the datastack in left to right order. These two snippets have the same effect:" +{ $code ":> c :> b :> a" } +{ $code ":> ( a b c )" } +$nl +"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), that new variable is mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." } { $notes - "This word can only be used inside a lambda word, lambda quotation or let binding form." - $nl - "Lambda and let forms are really just syntax sugar for " { $link POSTPONE: :> } "." - $nl - "Lambdas desugar as follows:" - { $code - "[| a b | a b + b / ]" - "[ :> b :> a a b + b / ]" - } - "Let forms desugar as follows:" - { $code - "[|let | x [ 10 random ] | { x x } ]" - "10 random :> x { x x }" - } -} -{ $examples - { $code - "USING: locals math kernel ;" - "IN: scratchpad" - ":: quadratic ( a b c -- x y )" - " b sq 4 a c * * - sqrt :> disc" - " b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@ ;" - } -} ; + "This syntax can only be used inside a lexical scope established by a " { $link POSTPONE: :: } " definition, " { $link POSTPONE: [let } " form, or " { $link POSTPONE: [| } " quotation. Normal quotations have their own lexical scope only if they are inside an outer scope. Definition forms such as " { $link POSTPONE: : } " do not establish a lexical scope by themselves unless documented otherwise, nor is there a lexical scope available at the top level of source files or in the listener. " { $link POSTPONE: [let } " can be used to create a lexical scope where one is not otherwise available." } +{ $examples "See " { $link "locals-examples" } "." } ; + +{ POSTPONE: [let POSTPONE: :> } related-words HELP: :: -{ $syntax ":: word ( bindings... -- outputs... ) body... ;" } -{ $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." } -{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } -{ $examples "See " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " and " { $link POSTPONE: [wlet } "." } ; +{ $syntax ":: word ( vars... -- outputs... ) body... ;" } +{ $description "Defines a word with named inputs. The word binds its input values to lexical variables from left to right, then executes the body with those bindings in scope." +$nl +"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." } +{ $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link POSTPONE: : } " definitions." } +{ $examples "See " { $link "locals-examples" } "." } ; { POSTPONE: : POSTPONE: :: } related-words HELP: MACRO:: -{ $syntax "MACRO:: word ( bindings... -- outputs... ) body... ;" } -{ $description "Defines a macro with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." } -{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } ; +{ $syntax "MACRO:: word ( vars... -- outputs... ) body... ;" } +{ $description "Defines a macro with named inputs. The macro binds its input variables to lexical variables from left to right, then executes the body with those bindings in scope." +$nl +"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." } +{ $notes "The expansion of a macro cannot reference lexical variables bound in the outer scope. There are also limitations on passing arguments involving lexical variables into macros. See " { $link "locals-limitations" } " for details." } +{ $examples "See " { $link "locals-examples" } "." } ; { POSTPONE: MACRO: POSTPONE: MACRO:: } related-words HELP: MEMO:: -{ $syntax "MEMO:: word ( bindings... -- outputs... ) body... ;" } -{ $description "Defines a memoized word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." } ; +{ $syntax "MEMO:: word ( vars... -- outputs... ) body... ;" } +{ $description "Defines a memoized word with named inputs. The word binds its input values to lexical variables from left to right, then executes the body with those bindings in scope." +$nl +"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." } +{ $examples "See " { $link "locals-examples" } "." } ; { POSTPONE: MEMO: POSTPONE: MEMO:: } related-words HELP: M:: -{ $syntax "M:: class generic ( bindings... -- outputs... ) body... ;" } -{ $description "Defines a method with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." } -{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } ; +{ $syntax "M:: class generic ( vars... -- outputs... ) body... ;" } +{ $description "Defines a new method on " { $snippet "generic" } " for " { $snippet "class" } " with named inputs. The method binds its input values to lexical variables from left to right, then executes the body with those bindings in scope." +$nl +"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." } +{ $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link POSTPONE: M: } " definitions." } +{ $examples "See " { $link "locals-examples" } "." } ; { POSTPONE: M: POSTPONE: M:: } related-words +ARTICLE: "locals-examples" "Examples of lexical variables" +{ $heading "Definitions with lexical variables" } +"The following example demonstrates lexical variable bindings in word definitions. The " { $snippet "quadratic-roots" } " word is defined with " { $link POSTPONE: :: } ", so it takes its inputs from the top three elements of the datastack and binds them to the variables " { $snippet "a" } ", " { $snippet "b" } ", and " { $snippet "c" } ". In the body, the " { $snippet "disc" } " variable is bound using " { $link POSTPONE: :> } " and then used in the following line of code." +{ $example """USING: locals math math.functions kernel ; +IN: scratchpad +:: quadratic-roots ( a b c -- x y ) + b sq 4 a c * * - sqrt :> disc + b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@ ; +1.0 1.0 -6.0 quadratic-roots [ . ] bi@""" +"""2.0 +-3.0""" +} +"If you wanted to perform the quadratic formula interactively from the listener, you could use " { $link POSTPONE: [let } " to provide a scope for the variables:" +{ $example """USING: locals math math.functions kernel ; +IN: scratchpad +[let 1.0 :> a 1.0 :> b -6.0 :> c + b sq 4 a c * * - sqrt :> disc + b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@ +] [ . ] bi@""" +"""2.0 +-3.0""" +} + +$nl + +{ $heading "Quotations with lexical variables, and closures" } +"These next two examples demonstrate lexical variable bindings in quotations defined with " { $link POSTPONE: [| } ". In this example, the values " { $snippet "5" } " and " { $snippet "3" } " are put on the datastack. When the quotation is called, it takes those values as inputs and binds them respectively to " { $snippet "m" } " and " { $snippet "n" } " before executing the quotation:" +{ $example + "USING: kernel locals math prettyprint ;" + "IN: scratchpad" + "5 3 [| m n | m n - ] call ." + "2" +} +$nl + +"In this example, the " { $snippet "adder" } " word creates a quotation that closes over its argument " { $snippet "n" } ". When called, the result quotation of " { $snippet "5 adder" } " pulls " { $snippet "3" } " off the datastack and binds it to " { $snippet "m" } ", which is added to the value " { $snippet "5" } " bound to " { $snippet "n" } " in the outer scope of " { $snippet "adder" } ":" +{ $example + "USING: kernel locals math prettyprint ;" + "IN: scratchpad" + ":: adder ( n -- quot ) [| m | m n + ] ;" + "3 5 adder call ." + "8" +} +$nl + +{ $heading "Mutable bindings" } +"This next example demonstrates closures and mutable variable bindings. The " { $snippet "make-counter" } " word outputs a tuple containing a pair of quotations that respectively increment and decrement an internal counter in the mutable " { $snippet "value" } " variable and then return the new value. The quotations close over the counter, so each invocation of the word gives new quotations with a new internal counter." +{ $example +"""USING: locals kernel math ; +IN: scratchpad + +TUPLE: counter adder subtractor ; + +:: ( -- counter ) + 0 :> value! + counter new + [ value 1 + dup value! ] >>adder + [ value 1 - dup value! ] >>subtractor ; + +[ adder>> call . ] +[ adder>> call . ] +[ subtractor>> call . ] tri """ +"""1 +2 +1""" +} + $nl + "The same variable name can be bound multiple times in the same scope. This is different from reassigning the value of a mutable variable. The most recent binding for a variable name will mask previous bindings for that name. However, the old binding referring to the previous value can still persist in closures. The following contrived example demonstrates this:" + { $example +"""USING: kernel locals prettyprint ; +IN: scratchpad +:: rebinding-example ( -- quot1 quot2 ) + 5 :> a [ a ] + 6 :> a [ a ] ; +:: mutable-example ( -- quot1 quot2 ) + 5 :> a! [ a ] + 6 a! [ a ] ; +rebinding-example [ call . ] bi@ +mutable-example [ call . ] bi@""" +"""5 +6 +6 +6""" +} + "In " { $snippet "rebinding-example" } ", the binding of " { $snippet "a" } " to " { $snippet "5" } " is closed over in the first quotation, and the binding of " { $snippet "a" } " to " { $snippet "6" } " is closed over in the second, so calling both quotations results in " { $snippet "5" } " and " { $snippet "6" } " respectively. By contrast, in " { $snippet "mutable-example" } ", both quotations close over a single binding of " { $snippet "a" } ". Even though " { $snippet "a" } " is assigned to " { $snippet "6" } " after the first quotation is made, calling either quotation will output the new value of " { $snippet "a" } "." +{ $heading "Lexical variables in literals" } +"Some kinds of literals can include references to lexical variables as described in " { $link "locals-literals" } ". For example, the " { $link 3array } " word could be implemented as follows:" +{ $example +"""USING: locals prettyprint ; +IN: scratchpad + +:: my-3array ( x y z -- array ) { x y z } ; +1 "two" 3.0 my-3array .""" +"""{ 1 "two" 3.0 }""" +} ; -ARTICLE: "locals-literals" "Locals in literals" -"Certain data type literals are permitted to contain free variables. Any such literals are written into code which constructs an instance of the type with the free variable values spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables." +ARTICLE: "locals-literals" "Lexical variables in literals" +"Certain data type literals are permitted to contain lexical variables. Any such literals are rewritten into code which constructs an instance of the type with the values of the variables spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables." $nl "The data types which receive this special handling are the following:" { $list @@ -142,7 +183,7 @@ $nl "ordinary-word-test ordinary-word-test eq? ." "t" } -"In a word with locals, literals which do not contain locals still behave in the same way:" +"Inside a lexical scope, literals which do not contain lexical variables still behave in the same way:" { $example "USE: locals" "IN: scratchpad" @@ -152,7 +193,7 @@ $nl "locals-word-test locals-word-test eq? ." "t" } -"However, literals with locals in them actually expand into code for constructing a new object:" +"However, literals with lexical variables in them actually construct a new object:" { $example "USING: locals splitting ;" "IN: scratchpad" @@ -163,29 +204,19 @@ $nl "constructor-test constructor-test eq? ." "f" } -"One exception to the above rule is that array instances containing no free variables do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile-time." -{ $heading "Example" } -"Here is an implementation of the " { $link 3array } " word which uses this feature:" -{ $code ":: 3array ( x y z -- array ) { x y z } ;" } ; +"One exception to the above rule is that array instances containing free lexical variables (that is, immutable lexical variables not referenced in a closure) do retain identity. This allows macros such as " { $link cond } " to expand at compile time even when their arguments reference variables." ; -ARTICLE: "locals-mutable" "Mutable locals" -"In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's name with the " { $snippet "!" } " suffix." +ARTICLE: "locals-mutable" "Mutable lexical variables" +"When a lexical variable is bound using " { $link POSTPONE: :> } ", " { $link POSTPONE: :: } ", or " { $link POSTPONE: [| } ", the variable may be made mutable by suffixing its name with an exclamation point (" { $snippet "!" } "). A mutable variable's value is read by giving its name without the exclamation point as usual. To write to the variable, use its name with the " { $snippet "!" } " suffix." $nl -"Here is a example word which outputs a pair of quotations which increment and decrement an internal counter, and then return the new value. The quotations are closed over the counter and each invocation of the word yields new quotations with their unique internal counter:" -{ $code - ":: counter ( -- )" - " [let | value! [ 0 ] |" - " [ value 1 + dup value! ]" - " [ value 1 - dup value! ] ] ;" -} -"Mutable bindings are implemented in a manner similar to the ML language; each mutable binding is actually an immutable binding of a mutable cell (in Factor's case, a 1-element array); reading the binding automatically dereferences the array, and writing to the binding stores into the array." +"Mutable bindings are implemented in a manner similar to the ML language; each mutable binding is actually an immutable binding of a mutable cell. Reading the binding automatically unboxes the value from the cell, and writing to the binding stores into it." $nl -"Unlike some languages such as Python and Java, writing to mutable locals in outer scopes is fully supported and has the expected semantics." ; +"Writing to mutable variables from outer lexical scopes is fully supported and has full closure semantics. See " { $link "locals-examples" } " for examples of mutable lexical variables in action." ; -ARTICLE: "locals-fry" "Locals and fry" -"Locals integrate with " { $link "fry" } " so that mixing locals with fried quotations gives intuitive results." +ARTICLE: "locals-fry" "Lexical variables and fry" +"Lexical variables integrate with " { $link "fry" } " so that mixing variables with fried quotations gives intuitive results." $nl -"Recall that the following two code snippets are equivalent:" +"The following two code snippets are equivalent:" { $code "'[ sq _ + ]" } { $code "[ [ sq ] dip + ] curry" } "The semantics of " { $link dip } " and " { $link curry } " are such that the first example behaves as if the top of the stack as “inserted” in the “hole” in the quotation's second element." @@ -193,29 +224,28 @@ $nl "Conceptually, " { $link curry } " is defined so that the following two code snippets are equivalent:" { $code "3 [ - ] curry" } { $code "[ 3 - ]" } -"With lambdas, " { $link curry } " behaves differently. Rather than prepending an element, it fills in named parameters from right to left. The following two snippets are equivalent:" +"When quotations take named parameters using " { $link POSTPONE: [| } ", " { $link curry } " fills in the variable bindings from right to left. The following two snippets are equivalent:" { $code "3 [| a b | a b - ] curry" } { $code "[| a | a 3 - ]" } -"Because of this, the behavior of fry changes when applied to a lambda, to ensure that conceptually, fry behaves as with quotations. So the following snippets are no longer equivalent:" +"Because of this, the behavior of " { $snippet "fry" } " changes when applied to such a quotation to ensure that fry conceptually behaves the same as with normal quotations, placing the fried values “underneath” the variable bindings. Thus, the following snippets are no longer equivalent:" { $code "'[ [| a | _ a - ] ]" } { $code "'[ [| a | a - ] curry ] call" } "Instead, the first line above expands into something like the following:" { $code "[ [ swap [| a | a - ] ] curry call ]" } -"This ensures that the fried value appears “underneath” the local variable " { $snippet "a" } " when the quotation calls." $nl -"The precise behavior is the following. When frying a lambda, a stack shuffle (" { $link mnswap } ") is prepended to the lambda so that the " { $snippet "m" } " curried values, which start off at the top of the stack, are transposed with the " { $snippet "n" } " inputs to the lambda." ; +"The precise behavior is as follows. When frying a " { $link POSTPONE: [| } " quotation, a stack shuffle (" { $link mnswap } ") is prepended so that the " { $snippet "m" } " curried values, which start off at the top of the stack, are transposed with the quotation's " { $snippet "n" } " named input bindings." ; -ARTICLE: "locals-limitations" "Limitations of locals" -"There are two main limitations of the current locals implementation, and both concern macros." +ARTICLE: "locals-limitations" "Limitations of lexical variables" +"There are two main limitations of the current implementation, and both concern macros." { $heading "Macro expansions with free variables" } -"The expansion of a macro cannot reference local variables bound in the outer scope. For example, the following macro is invalid:" +"The expansion of a macro cannot reference lexical variables bound in the outer scope. For example, the following macro is invalid:" { $code "MACRO:: twice ( quot -- ) [ quot call quot call ] ;" } "The following is fine, though:" { $code "MACRO:: twice ( quot -- ) quot quot '[ @ @ ] ;" } { $heading "Static stack effect inference and macros" } -"Recall that a macro will only expand at compile-time, and the word containing it will only get a static stack effect, if all inputs to the macro are literal. When locals are used, there is an additional restriction; the literals must immediately precede the macro call, lexically." +"A macro will only expand at compile-time if all of its inputs are literal. Likewise, the word containing the macro will only have a static stack effect and compile successfully if the macro's inputs are literal. When lexical variables are used in a macro's literal arguments, there is an additional restriction: The literals must immediately precede the macro call lexically." $nl -"For example, all of the following three examples are equivalent semantically, but only the first will have a static stack effect and compile with the optimizing compiler:" +"For example, all of the following three code snippets are superficially equivalent, but only the first will compile:" { $code ":: good-cond-usage ( a -- ... )" " {" @@ -224,7 +254,7 @@ $nl " { [ a 0 = ] [ ... ] }" " } cond ;" } -"The following two will not, and will run slower as a result:" +"The next two snippets will not compile because the argument to " { $link cond } " does not immediately precede the call:" { $code ": my-cond ( alist -- ) cond ; inline" "" @@ -243,30 +273,27 @@ $nl " { [ a 0 = ] [ ... ] }" " } swap swap cond ;" } -"The reason is that locals are rewritten into stack code at parse time, whereas macro expansion is performed later during compile time. To circumvent this problem, the " { $vocab-link "macros.expander" } " vocabulary is used to rewrite simple macro usages prior to local transformation, however "{ $vocab-link "macros.expander" } " does not deal with more complicated cases where the literal inputs to the macro do not immediately precede the macro call in the source." ; +"The reason is that lexical variable references are rewritten into stack code at parse time, whereas macro expansion is performed later during compile time. To circumvent this problem, the " { $vocab-link "macros.expander" } " vocabulary is used to rewrite simple macro usages prior to lexical variable transformation. However, " { $vocab-link "macros.expander" } " cannot deal with more complicated cases where the literal inputs to the macro do not immediately precede the macro call in the source." ; -ARTICLE: "locals" "Lexical variables and closures" -"The " { $vocab-link "locals" } " vocabulary implements lexical scope with full closures, both downward and upward. Mutable bindings are supported, including assignment to bindings in outer scope." -$nl -"Compile-time transformation is used to compile local variables to efficient code; prettyprinter extensions are defined so that " { $link see } " can display original word definitions with local variables and not the closure-converted concatenative code which results." -$nl -"Applicative word definitions where the inputs are named local variables:" +ARTICLE: "locals" "Lexical variables" +"The " { $vocab-link "locals" } " vocabulary provides lexically scoped local variables. Full closure semantics, both downward and upward, are supported. Mutable variable bindings are also provided, supporting assignment to bindings in the current scope or in outer scopes." +{ $subsections + "locals-examples" +} +"Word definitions where the inputs are bound to lexical variables:" { $subsections POSTPONE: :: POSTPONE: M:: POSTPONE: MEMO:: POSTPONE: MACRO:: } -"Lexical binding forms:" +"Lexical scoping and binding forms:" { $subsections POSTPONE: [let - POSTPONE: [let* - POSTPONE: [wlet + POSTPONE: :> } -"Lambda abstractions:" +"Quotation literals where the inputs are bound to lexical variables:" { $subsections POSTPONE: [| } -"Lightweight binding form:" -{ $subsections POSTPONE: :> } "Additional topics:" { $subsections "locals-literals" @@ -274,6 +301,6 @@ $nl "locals-fry" "locals-limitations" } -"Locals complement dynamically scoped variables implemented in the " { $vocab-link "namespaces" } " vocabulary." ; +"Lexical variables complement " { $link "namespaces" } "." ; ABOUT: "locals" diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 63b6d68feb..7aa8032cdd 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -26,58 +26,35 @@ IN: locals.tests [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test :: let-test ( c -- d ) - [let | a [ 1 ] b [ 2 ] | a b + c + ] ; + [let 1 :> a 2 :> b a b + c + ] ; [ 7 ] [ 4 let-test ] unit-test :: let-test-2 ( a -- a ) - a [let | a [ ] | [let | b [ a ] | a ] ] ; + a [let :> a [let a :> b a ] ] ; [ 3 ] [ 3 let-test-2 ] unit-test :: let-test-3 ( a -- a ) - a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ; + a [let :> a [let [ a ] :> b [let 3 :> a b ] ] ] ; :: let-test-4 ( a -- b ) - a [let | a [ 1 ] b [ ] | a b 2array ] ; + a [let 1 :> a :> b a b 2array ] ; [ { 1 2 } ] [ 2 let-test-4 ] unit-test :: let-test-5 ( a b -- b ) - a b [let | a [ ] b [ ] | a b 2array ] ; + a b [let :> a :> b a b 2array ] ; [ { 2 1 } ] [ 1 2 let-test-5 ] unit-test :: let-test-6 ( a -- b ) - a [let | a [ ] b [ 1 ] | a b 2array ] ; + a [let :> a 1 :> b a b 2array ] ; [ { 2 1 } ] [ 2 let-test-6 ] unit-test [ -1 ] [ -1 let-test-3 call ] unit-test -[ 5 ] [ - [let | a [ 3 ] | [wlet | func [ a + ] | 2 func ] ] -] unit-test - -:: wlet-test-2 ( a b -- seq ) - [wlet | add-b [ b + ] | - a [ add-b ] map ] ; - - -[ { 4 5 6 } ] [ { 2 3 4 } 2 wlet-test-2 ] unit-test - -:: wlet-test-3 ( a -- b ) - [wlet | add-a [ a + ] | [ add-a ] ] - [let | a [ 3 ] | a swap call ] ; - -[ 5 ] [ 2 wlet-test-3 ] unit-test - -:: wlet-test-4 ( a -- b ) - [wlet | sub-a [| b | b a - ] | - 3 sub-a ] ; - -[ -7 ] [ 10 wlet-test-4 ] unit-test - :: write-test-1 ( n! -- q ) [| i | n i + dup n! ] ; @@ -94,8 +71,7 @@ IN: locals.tests [ 5 ] [ 2 "q" get call ] unit-test :: write-test-2 ( -- q ) - [let | n! [ 0 ] | - [| i | n i + dup n! ] ] ; + [let 0 :> n! [| i | n i + dup n! ] ] ; write-test-2 "q" set @@ -116,17 +92,11 @@ write-test-2 "q" set [ ] [ 1 2 write-test-3 call ] unit-test -:: write-test-4 ( x! -- q ) [ [let | y! [ 0 ] | f x! ] ] ; +:: write-test-4 ( x! -- q ) [ [let 0 :> y! f x! ] ] ; [ ] [ 5 write-test-4 drop ] unit-test -! Not really a write test; just enforcing consistency -:: write-test-5 ( x -- y ) - [wlet | fun! [ x + ] | 5 fun! ] ; - -[ 9 ] [ 4 write-test-5 ] unit-test - -:: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ; +:: let-let-test ( n -- n ) [let n 3 + :> n n ] ; [ 13 ] [ 10 let-let-test ] unit-test @@ -164,18 +134,12 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ; [ ] [ \ lambda-generic see ] unit-test -:: unparse-test-1 ( a -- ) [let | a! [ 3 ] | ] ; +:: unparse-test-1 ( a -- ) [let 3 :> a! 4 :> b ] ; -[ "[let | a! [ 3 ] | ]" ] [ +[ "[let 3 :> a! 4 :> b ]" ] [ \ unparse-test-1 "lambda" word-prop body>> first unparse ] unit-test -:: unparse-test-2 ( -- ) [wlet | a! [ ] | ] ; - -[ "[wlet | a! [ ] | ]" ] [ - \ unparse-test-2 "lambda" word-prop body>> first unparse -] unit-test - :: unparse-test-3 ( -- b ) [| a! | ] ; [ "[| a! | ]" ] [ @@ -198,38 +162,6 @@ DEFER: xyzzy [ 5 ] [ 10 xyzzy ] unit-test -:: let*-test-1 ( a -- b ) - [let* | b [ a 1 + ] - c [ b 1 + ] | - a b c 3array ] ; - -[ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test - -:: let*-test-2 ( a -- b ) - [let* | b [ a 1 + ] - c! [ b 1 + ] | - a b c 3array ] ; - -[ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test - -:: let*-test-3 ( a -- b ) - [let* | b [ a 1 + ] - c! [ b 1 + ] | - c 1 + c! a b c 3array ] ; - -[ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test - -:: let*-test-4 ( a b -- c d ) - [let | a [ b ] - b [ a ] | - [let* | a' [ a ] - a'' [ a' ] - b' [ b ] - b'' [ b' ] | - a'' b'' ] ] ; - -[ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test - GENERIC: next-method-test ( a -- b ) M: integer next-method-test 3 + ; @@ -244,11 +176,11 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ; { 3 0 } [| a b c | ] must-infer-as -[ ] [ 1 [let | a [ ] | ] ] unit-test +[ ] [ 1 [let :> a ] ] unit-test -[ 3 ] [ 1 [let | a [ ] | 3 ] ] unit-test +[ 3 ] [ 1 [let :> a 3 ] ] unit-test -[ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test +[ ] [ 1 2 [let :> a :> b ] ] unit-test :: a-word-with-locals ( a b -- ) ; @@ -306,10 +238,10 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; [ t ] [ 12 &&-test ] unit-test :: let-and-cond-test-1 ( -- a ) - [let | a [ 10 ] | - [let | a [ 20 ] | + [let 10 :> a + [let 20 :> a { - { [ t ] [ [let | c [ 30 ] | a ] ] } + { [ t ] [ [let 30 :> c a ] ] } } cond ] ] ; @@ -319,8 +251,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; [ 20 ] [ let-and-cond-test-1 ] unit-test :: let-and-cond-test-2 ( -- pair ) - [let | A [ 10 ] | - [let | B [ 20 ] | + [let 10 :> A + [let 20 :> B { { [ t ] [ { A B } ] } } cond ] ] ; @@ -333,7 +265,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; [ { 10 20 } ] [ 10 20 [| a b | { a b } ] call ] unit-test [ { 10 20 30 } ] [ 10 20 30 [| a b c | { a b c } ] call ] unit-test -[ { 10 20 30 } ] [ [let | a [ 10 ] b [ 20 ] c [ 30 ] | { a b c } ] ] unit-test +[ { 10 20 30 } ] [ [let 10 :> a 20 :> b 30 :> c { a b c } ] ] unit-test [ V{ 10 20 30 } ] [ 10 20 30 [| a b c | V{ a b c } ] call ] unit-test @@ -453,11 +385,11 @@ M:: integer lambda-method-forget-test ( a -- b ) a ; [ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test [ - "USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]" + "USING: locals fry math ; 1 '[ [let 10 :> A A _ + ] ]" eval( -- ) call ] [ error>> >r/r>-in-fry-error? ] must-fail-with -:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline +:: (funny-macro-test) ( obj quot -- ? ) obj { [ quot call ] } 1&& ; inline : funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ; \ funny-macro-test def>> must-infer @@ -465,10 +397,7 @@ M:: integer lambda-method-forget-test ( a -- b ) a ; [ t ] [ 3 funny-macro-test ] unit-test [ f ] [ 2 funny-macro-test ] unit-test -! Some odd parser corner cases [ "USE: locals [let" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with -[ "USE: locals [let |" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with -[ "USE: locals [let | a" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with [ "USE: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with [ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test @@ -484,15 +413,9 @@ M:: integer lambda-method-forget-test ( a -- b ) a ; [ 3 ] [ 3 [| a | \ a ] call ] unit-test -[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail +[ "USE: locals [| | { [let 0 :> a a ] } ]" eval( -- ) ] must-fail -[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail - -[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail - -[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval( -- ) ] must-fail - -[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval( -- ) ] must-fail +[ "USE: locals [| | [let 0 :> a! { a! } ] ]" eval( -- ) ] must-fail [ "USE: locals [| | { :> a } ]" eval( -- ) ] must-fail @@ -504,27 +427,14 @@ M:: integer lambda-method-forget-test ( a -- b ) a ; [ 3 ] [ 2 [| | :> a! a 1 + a! a ] call ] unit-test -:: wlet-&&-test ( a -- ? ) - [wlet | is-integer? [ a integer? ] - is-even? [ a even? ] - >10? [ a 10 > ] | - { [ is-integer? ] [ is-even? ] [ >10? ] } && - ] ; - -\ wlet-&&-test def>> must-infer -[ f ] [ 1.5 wlet-&&-test ] unit-test -[ f ] [ 3 wlet-&&-test ] unit-test -[ f ] [ 8 wlet-&&-test ] unit-test -[ t ] [ 12 wlet-&&-test ] unit-test - : fry-locals-test-1 ( -- n ) - [let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ; + [let 6 '[ [let 4 :> A A _ + ] ] call ] ; \ fry-locals-test-1 def>> must-infer [ 10 ] [ fry-locals-test-1 ] unit-test :: fry-locals-test-2 ( -- n ) - [let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ; + [let 6 '[ [let 4 :> A A _ + ] ] call ] ; \ fry-locals-test-2 def>> must-infer [ 10 ] [ fry-locals-test-2 ] unit-test @@ -542,18 +452,18 @@ M:: integer lambda-method-forget-test ( a -- b ) a ; ] unit-test [ 10 ] [ - [| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call + [| | 0 '[ [let 10 :> A A _ + ] ] call ] call ] unit-test ! littledan found this problem -[ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test -[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test +[ "bar" ] [ [let [let "bar" :> foo foo ] :> a a ] ] unit-test +[ 10 ] [ [let 10 :> a [let a :> b b ] ] ] unit-test -[ { \ + } ] [ [let | x [ \ + ] | { \ x } ] ] unit-test +[ { \ + } ] [ [let \ + :> x { \ x } ] ] unit-test -[ { \ + 3 } ] [ [let | a [ 3 ] | { \ + a } ] ] unit-test +[ { \ + 3 } ] [ [let 3 :> a { \ + a } ] ] unit-test -[ 3 ] [ [let | a [ \ + ] | 1 2 [ \ a execute ] ] call ] unit-test +[ 3 ] [ [let \ + :> a 1 2 [ \ a execute ] ] call ] unit-test ! erg found this problem :: erg's-:>-bug ( n ? -- n ) ? [ n :> n n ] [ n :> b b ] if ; @@ -578,3 +488,6 @@ M: integer ed's-bug neg ; { [ a ed's-bug ] } && ; [ t ] [ \ ed's-test-case optimized? ] unit-test + +! multiple bind +[ 3 1 2 ] [ [let 1 2 3 :> ( a b c ) c a b ] ] unit-test diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index 9e26a8caaa..8e940bfdd8 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -7,15 +7,11 @@ IN: locals SYNTAX: :> scan locals get [ :>-outside-lambda-error ] unless* - [ make-local ] bind parsed ; + parse-def suffix! ; -SYNTAX: [| parse-lambda over push-all ; +SYNTAX: [| parse-lambda append! ; -SYNTAX: [let parse-let over push-all ; - -SYNTAX: [let* parse-let* over push-all ; - -SYNTAX: [wlet parse-wlet over push-all ; +SYNTAX: [let parse-let append! ; SYNTAX: :: (::) define-declared ; diff --git a/basis/locals/macros/macros.factor b/basis/locals/macros/macros.factor index 2b52c53eb5..1f9525e5eb 100644 --- a/basis/locals/macros/macros.factor +++ b/basis/locals/macros/macros.factor @@ -7,13 +7,11 @@ M: lambda expand-macros clone [ expand-macros ] change-body ; M: lambda expand-macros* expand-macros literal ; -M: binding-form expand-macros - clone - [ [ expand-macros ] assoc-map ] change-bindings - [ expand-macros ] change-body ; +M: let expand-macros + clone [ expand-macros ] change-body ; -M: binding-form expand-macros* expand-macros literal ; +M: let expand-macros* expand-macros literal ; M: lambda condomize? drop t ; -M: lambda condomize '[ @ ] ; \ No newline at end of file +M: lambda condomize [ call ] curry ; diff --git a/basis/locals/parser/parser.factor b/basis/locals/parser/parser.factor index 8cfe45d1ba..c0184ee0ef 100644 --- a/basis/locals/parser/parser.factor +++ b/basis/locals/parser/parser.factor @@ -46,6 +46,12 @@ SYMBOL: locals (parse-lambda) ?rewrite-closures ; +: parse-multi-def ( locals -- multi-def ) + ")" parse-tokens swap [ [ make-local ] map ] bind ; + +: parse-def ( name/paren locals -- def ) + over "(" = [ nip parse-multi-def ] [ [ make-local ] bind ] if ; + M: lambda-parser parse-quotation ( -- quotation ) H{ } clone (parse-lambda) ; @@ -56,48 +62,8 @@ M: lambda-parser parse-quotation ( -- quotation ) [ nip scan-object 2array ] } cond ; -: (parse-bindings) ( end -- ) - dup parse-binding dup [ - first2 [ make-local ] dip 2array , - (parse-bindings) - ] [ 2drop ] if ; - -: with-bindings ( quot -- words assoc ) - '[ - in-lambda? on - _ H{ } make-assoc - ] { } make swap ; inline - -: parse-bindings ( end -- bindings vars ) - [ (parse-bindings) ] with-bindings ; - : parse-let ( -- form ) - "|" expect "|" parse-bindings - (parse-lambda) ?rewrite-closures ; - -: parse-bindings* ( end -- words assoc ) - [ - namespace use-words - (parse-bindings) - namespace unuse-words - ] with-bindings ; - -: parse-let* ( -- form ) - "|" expect "|" parse-bindings* - (parse-lambda) ?rewrite-closures ; - -: (parse-wbindings) ( end -- ) - dup parse-binding dup [ - first2 [ make-local-word ] keep 2array , - (parse-wbindings) - ] [ 2drop ] if ; - -: parse-wbindings ( end -- bindings vars ) - [ (parse-wbindings) ] with-bindings ; - -: parse-wlet ( -- form ) - "|" expect "|" parse-wbindings - (parse-lambda) ?rewrite-closures ; + H{ } clone (parse-lambda) ?rewrite-closures ; : parse-locals ( -- effect vars assoc ) complete-effect @@ -121,4 +87,4 @@ M: lambda-parser parse-quotation ( -- quotation ) [ [ parse-definition ] parse-locals-definition drop - ] with-method-definition ; \ No newline at end of file + ] with-method-definition ; diff --git a/basis/locals/prettyprint/prettyprint.factor b/basis/locals/prettyprint/prettyprint.factor index 187b663c3c..b0fbebbf31 100644 --- a/basis/locals/prettyprint/prettyprint.factor +++ b/basis/locals/prettyprint/prettyprint.factor @@ -27,22 +27,17 @@ M: lambda pprint* : pprint-let ( let word -- ) pprint-word - [ body>> ] [ bindings>> ] bi - \ | pprint-word - t ] assoc-each - block> - \ | pprint-word - - block> + > pprint-elements block> \ ] pprint-word ; M: let pprint* \ [let pprint-let ; -M: wlet pprint* \ [wlet pprint-let ; - -M: let* pprint* \ [let* pprint-let ; - M: def pprint* - pprint-word local>> pprint-word block> ; + dup local>> word? + [ pprint-word local>> pprint-var block> ] + [ pprint-tuple ] if ; + +M: multi-def pprint* + dup locals>> [ word? ] all? + [ pprint-word "(" text locals>> [ pprint-var ] each ")" text block> ] + [ pprint-tuple ] if ; diff --git a/basis/locals/rewrite/sugar/sugar.factor b/basis/locals/rewrite/sugar/sugar.factor index 87568d596a..a8a12d2614 100755 --- a/basis/locals/rewrite/sugar/sugar.factor +++ b/basis/locals/rewrite/sugar/sugar.factor @@ -6,7 +6,7 @@ locals.errors locals.types make quotations sequences vectors words ; IN: locals.rewrite.sugar -! Step 1: rewrite [| [let [let* [wlet into :> forms, turn +! Step 1: rewrite [| into :> forms, turn ! literals with locals in them into code which constructs ! the literal after pushing locals on the stack @@ -73,7 +73,7 @@ M: quotation rewrite-element rewrite-sugar* ; M: lambda rewrite-element rewrite-sugar* ; -M: binding-form rewrite-element binding-form-in-literal-error ; +M: let rewrite-element let-form-in-literal-error ; M: local rewrite-element , ; @@ -104,28 +104,18 @@ M: tuple rewrite-sugar* rewrite-element ; M: def rewrite-sugar* , ; +M: multi-def rewrite-sugar* locals>> [ , ] each ; + M: hashtable rewrite-sugar* rewrite-element ; M: wrapper rewrite-sugar* rewrite-wrapper ; M: word rewrite-sugar* - dup { load-locals get-local drop-locals } memq? + dup { load-locals get-local drop-locals } member-eq? [ >r/r>-in-lambda-error ] [ call-next-method ] if ; M: object rewrite-sugar* , ; -: let-rewrite ( body bindings -- ) - [ quotation-rewrite % , ] assoc-each - quotation-rewrite % ; - M: let rewrite-sugar* - [ body>> ] [ bindings>> ] bi let-rewrite ; - -M: let* rewrite-sugar* - [ body>> ] [ bindings>> ] bi let-rewrite ; - -M: wlet rewrite-sugar* - [ body>> ] [ bindings>> ] bi - [ '[ _ ] ] assoc-map - let-rewrite ; + body>> quotation-rewrite % ; diff --git a/basis/locals/types/types.factor b/basis/locals/types/types.factor index 3ed753e094..424ef68243 100644 --- a/basis/locals/types/types.factor +++ b/basis/locals/types/types.factor @@ -8,20 +8,10 @@ TUPLE: lambda vars body ; C: lambda -TUPLE: binding-form bindings body ; - -TUPLE: let < binding-form ; +TUPLE: let body ; C: let -TUPLE: let* < binding-form ; - -C: let* - -TUPLE: wlet < binding-form ; - -C: wlet - TUPLE: quote local ; C: quote @@ -32,6 +22,10 @@ TUPLE: def local ; C: def +TUPLE: multi-def locals ; + +C: multi-def + PREDICATE: local < word "local?" word-prop ; : ( name -- word ) diff --git a/basis/logging/analysis/analysis.factor b/basis/logging/analysis/analysis.factor index 0ba98996b3..eb8a2eaf76 100644 --- a/basis/logging/analysis/analysis.factor +++ b/basis/logging/analysis/analysis.factor @@ -12,7 +12,7 @@ SYMBOL: word-histogram SYMBOL: message-histogram : analyze-entry ( entry -- ) - dup level>> { ERROR CRITICAL } memq? [ dup errors get push ] when + dup level>> { ERROR CRITICAL } member-eq? [ dup errors get push ] when dup word-name>> word-histogram get inc-at dup word-name>> word-names get member? [ dup [ level>> ] [ word-name>> ] [ message>> ] tri 3array diff --git a/basis/logging/logging-docs.factor b/basis/logging/logging-docs.factor index 2dc5918bda..4af3f01ef7 100644 --- a/basis/logging/logging-docs.factor +++ b/basis/logging/logging-docs.factor @@ -47,19 +47,19 @@ HELP: log-message { $description "Sends a message to the current log if the level is more urgent than " { $link log-level } ". Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ; HELP: add-logging -{ $values { "level" "a log level" } { "word" word } } +{ $values { "word" word } { "level" "a log level" } } { $description "Causes the word to log a message every time it is called." } ; HELP: add-input-logging -{ $values { "level" "a log level" } { "word" word } } +{ $values { "word" word } { "level" "a log level" } } { $description "Causes the word to log its input values every time it is called. The word must have a stack effect declaration." } ; HELP: add-output-logging -{ $values { "level" "a log level" } { "word" word } } +{ $values { "word" word } { "level" "a log level" } } { $description "Causes the word to log its output values every time it is called. The word must have a stack effect declaration." } ; HELP: add-error-logging -{ $values { "level" "a log level" } { "word" word } } +{ $values { "word" word } { "level" "a log level" } } { $description "Causes the word to log its input values and any errors it throws." $nl "If the word is not executed in a dynamic scope established by " { $link with-logging } ", its behavior is unchanged, and any errors it throws are passed to the caller." diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 0e5ef30f51..0186f6181f 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser kernel sequences words effects combinators assocs -definitions quotations namespaces memoize accessors ; +definitions quotations namespaces memoize accessors +compiler.units ; IN: macros : n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline : n*V ( alpha x -- alpha*x ) clone n*V! ; inline -: V+ ( x y -- x+y ) - 1.0 -rot n*V+V ; inline -: V- ( x y -- x-y ) - -1.0 spin n*V+V ; inline +:: V+ ( x y -- x+y ) + 1.0 x y n*V+V ; inline +:: V- ( x y -- x-y ) + -1.0 y x n*V+V ; inline : Vneg ( x -- -x ) -1.0 swap n*V ; inline @@ -117,7 +117,7 @@ M: blas-vector-base equal? M: blas-vector-base length length>> ; -M: blas-vector-base virtual-seq +M: blas-vector-base virtual-exemplar (blas-direct-array) ; M: blas-vector-base virtual@ [ inc>> * ] [ nip (blas-direct-array) ] 2bi ; diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index bc09f9fe0f..5c03e41870 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -96,9 +96,9 @@ C: combo initial-values [ over 0 > ] [ next-values ] produce [ 3drop ] dip ; -: combination-indices ( m combo -- seq ) - [ tuck dual-index combinadic ] keep - seq>> length 1 - swap [ - ] with map ; +:: combination-indices ( m combo -- seq ) + combo m combo dual-index combinadic + combo seq>> length 1 - swap [ - ] with map ; : apply-combination ( m combo -- seq ) [ combination-indices ] keep seq>> nths ; diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index 5b1920f572..5f7c066efa 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -54,6 +54,8 @@ ARTICLE: "power-functions" "Powers and logarithms" { $subsections log1+ log10 } "Raising a number to a power:" { $subsections ^ 10^ } +"Finding the root of a number:" +{ $subsections nth-root } "Converting between rectangular and polar form:" { $subsections abs @@ -239,7 +241,7 @@ HELP: cis { cis exp } related-words HELP: polar> -{ $values { "z" number } { "abs" "a non-negative real number" } { "arg" real } } +{ $values { "abs" "a non-negative real number" } { "arg" real } { "z" number } } { $description "Converts an absolute value and argument (polar form) to a complex number." } ; HELP: [-1,1]? @@ -259,6 +261,10 @@ HELP: ^ { $description "Raises " { $snippet "x" } " to the power of " { $snippet "y" } ". If " { $snippet "y" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." } { $errors "Throws an error if " { $snippet "x" } " and " { $snippet "y" } " are both integer 0." } ; +HELP: nth-root +{ $values { "n" integer } { "x" number } { "y" number } } +{ $description "Calculates the nth root of a number, such that " { $snippet "y^n=x" } "." } ; + HELP: 10^ { $values { "x" number } { "y" number } } { $description "Raises " { $snippet "x" } " to the power of 10. If " { $snippet "x" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." } ; diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index 1914bae008..73f08e2665 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -25,6 +25,9 @@ IN: math.functions.tests [ t ] [ e pi i* ^ real-part -1.0 = ] unit-test [ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test +[ 1/0. ] [ 2.0 1024 ^ ] unit-test +[ HEX: 1.0p-1024 ] [ 2.0 -1024 ^ ] unit-test + [ t ] [ 0 0 ^ fp-nan? ] unit-test [ 0.0 ] [ 0.0 1.0 ^ ] unit-test [ 1/0. ] [ 0 -2 ^ ] unit-test diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index a9ad003411..d91b4b6b92 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -39,7 +39,7 @@ M: float ^n (^n) ; M: complex ^n (^n) ; : integer^ ( x y -- z ) - dup 0 > [ ^n ] [ neg ^n recip ] if ; inline + dup 0 >= [ ^n ] [ [ recip ] dip neg ^n ] if ; inline PRIVATE> @@ -106,6 +106,8 @@ PRIVATE> [ ^complex ] } cond ; inline +: nth-root ( n x -- y ) swap recip ^ ; inline + : gcd ( x y -- a d ) [ 0 1 ] 2dip (gcd) dup 0 < [ neg ] when ; foldable @@ -304,4 +306,3 @@ M: real atan >float atan ; inline [ [ / floor ] [ * ] bi ] unless-zero ; : lerp ( a b t -- a_t ) [ over - ] dip * + ; inline - diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 1ee4e1e100..a569b4af7b 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -79,7 +79,7 @@ IN: math.intervals.tests [ t ] [ 1 2 [a,b] dup empty-interval interval-union = ] unit-test -[ t ] [ empty-interval 1 2 [a,b] tuck interval-union = ] unit-test +[ t ] [ 1 2 [a,b] empty-interval over interval-union = ] unit-test [ t ] [ 0 1 (a,b) 0 1 [a,b] interval-union 0 1 [a,b] = @@ -250,7 +250,7 @@ IN: math.intervals.tests dup full-interval eq? [ drop 32 random-bits 31 2^ - ] [ - dup to>> first over from>> first tuck - random + + [ ] [ from>> first ] [ to>> first ] tri over - random + 2dup swap interval-contains? [ nip ] [ diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 05f9906bb9..ec742cb1ce 100755 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -192,7 +192,7 @@ MEMO: array-capacity-interval ( -- interval ) : interval-sq ( i1 -- i2 ) dup interval* ; : special-interval? ( interval -- ? ) - { empty-interval full-interval } memq? ; + { empty-interval full-interval } member-eq? ; : interval-singleton? ( int -- ? ) dup special-interval? [ diff --git a/basis/math/matrices/elimination/elimination.factor b/basis/math/matrices/elimination/elimination.factor index 8411447aac..5c154a6820 100755 --- a/basis/math/matrices/elimination/elimination.factor +++ b/basis/math/matrices/elimination/elimination.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.vectors math.matrices namespaces -sequences ; +USING: kernel locals math math.vectors math.matrices +namespaces sequences ; IN: math.matrices.elimination SYMBOL: matrix @@ -85,12 +85,11 @@ SYMBOL: matrix ] each ] with-matrix ; -: basis-vector ( row col# -- ) - [ clone ] dip - [ swap nth neg recip ] 2keep - [ 0 spin set-nth ] 2keep - [ n*v ] dip - matrix get set-nth ; +:: basis-vector ( row col# -- ) + row clone :> row' + col# row' nth neg recip :> a + 0 col# row' set-nth + a row n*v col# matrix get set-nth ; : nullspace ( matrix -- seq ) echelon reduced dup empty? [ diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index 4a76a20598..75b9be5cae 100644 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -16,7 +16,7 @@ IN: math.matrices :: rotation-matrix3 ( axis theta -- matrix ) theta cos :> c theta sin :> s - axis first3 :> z :> y :> x + axis first3 :> ( x y z ) x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 3array x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 3array x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 3array @@ -25,14 +25,14 @@ IN: math.matrices :: rotation-matrix4 ( axis theta -- matrix ) theta cos :> c theta sin :> s - axis first3 :> z :> y :> x + axis first3 :> ( x y z ) x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 0 4array x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 0 4array x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 0 4array { 0.0 0.0 0.0 1.0 } 4array ; :: translation-matrix4 ( offset -- matrix ) - offset first3 :> z :> y :> x + offset first3 :> ( x y z ) { { 1.0 0.0 0.0 x } { 0.0 1.0 0.0 y } @@ -44,7 +44,7 @@ IN: math.matrices dup number? [ dup dup ] [ first3 ] if ; :: scale-matrix3 ( factors -- matrix ) - factors >scale-factors :> z :> y :> x + factors >scale-factors :> ( x y z ) { { x 0.0 0.0 } { 0.0 y 0.0 } @@ -52,7 +52,7 @@ IN: math.matrices } ; :: scale-matrix4 ( factors -- matrix ) - factors >scale-factors :> z :> y :> x + factors >scale-factors :> ( x y z ) { { x 0.0 0.0 0.0 } { 0.0 y 0.0 0.0 } @@ -64,7 +64,7 @@ IN: math.matrices [ recip ] map scale-matrix4 ; :: frustum-matrix4 ( xy-dim near far -- matrix ) - xy-dim first2 :> y :> x + xy-dim first2 :> ( x y ) near x /f :> xf near y /f :> yf near far + near far - /f :> zf @@ -110,19 +110,9 @@ IN: math.matrices : mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ; : mnorm ( m -- n ) dup mmax abs m/n ; - - -: cross ( vec1 vec2 -- vec3 ) [ [ i ] [ j ] [ k ] 2tri ] keep 3sequence ; +: cross ( vec1 vec2 -- vec3 ) + [ [ { 1 2 1 } vshuffle ] [ { 2 0 0 } vshuffle ] bi* v* ] + [ [ { 2 0 0 } vshuffle ] [ { 1 2 1 } vshuffle ] bi* v* ] 2bi v- ; inline : proj ( v u -- w ) [ [ v. ] [ norm-sq ] bi / ] keep n*v ; diff --git a/basis/math/partial-dispatch/partial-dispatch-tests.factor b/basis/math/partial-dispatch/partial-dispatch-tests.factor index 29979b62d3..8bca1459c0 100644 --- a/basis/math/partial-dispatch/partial-dispatch-tests.factor +++ b/basis/math/partial-dispatch/partial-dispatch-tests.factor @@ -10,9 +10,9 @@ tools.test math kernel sequences ; [ f ] [ \ + object number math-both-known? ] unit-test [ f ] [ \ number= fixnum object math-both-known? ] unit-test [ t ] [ \ number= integer fixnum math-both-known? ] unit-test -[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test -[ f ] [ \ >integer \ /i derived-ops memq? ] unit-test -[ t ] [ \ fixnum-shift \ shift derived-ops memq? ] unit-test +[ f ] [ \ >fixnum \ shift derived-ops member-eq? ] unit-test +[ f ] [ \ >integer \ /i derived-ops member-eq? ] unit-test +[ t ] [ \ fixnum-shift \ shift derived-ops member-eq? ] unit-test [ { integer fixnum } ] [ \ +-integer-fixnum integer-op-input-classes ] unit-test [ { fixnum fixnum } ] [ \ fixnum+ integer-op-input-classes ] unit-test @@ -30,4 +30,4 @@ tools.test math kernel sequences ; [ 3 ] [ 1 2 +-integer-integer ] unit-test [ 3 ] [ 1 >bignum 2 +-integer-integer ] unit-test [ 3 ] [ 1 2 >bignum +-integer-integer ] unit-test -[ 3 ] [ 1 >bignum 2 >bignum +-integer-integer ] unit-test \ No newline at end of file +[ 3 ] [ 1 >bignum 2 >bignum +-integer-integer ] unit-test diff --git a/basis/math/primes/erato/erato-tests.factor b/basis/math/primes/erato/erato-tests.factor index e78e5210f9..e6f7765bd6 100644 --- a/basis/math/primes/erato/erato-tests.factor +++ b/basis/math/primes/erato/erato-tests.factor @@ -7,4 +7,4 @@ USING: byte-arrays math math.bitwise math.primes.erato sequences tools.test ; [ t ] [ 113 100 sieve marked-prime? ] unit-test ! There are 25997 primes below 300000. 1 must be removed and 3 5 7 added. -[ 25997 ] [ 299999 sieve [ bit-count ] sigma 2 + ] unit-test \ No newline at end of file +[ 25997 ] [ 299999 sieve [ bit-count ] map-sum 2 + ] unit-test diff --git a/basis/math/primes/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor index b0dfc4ed35..04b1330cc2 100755 --- a/basis/math/primes/miller-rabin/miller-rabin.factor +++ b/basis/math/primes/miller-rabin/miller-rabin.factor @@ -8,7 +8,7 @@ IN: math.primes.miller-rabin :: (miller-rabin) ( n trials -- ? ) n 1 - :> n-1 - n-1 factor-2s :> s :> r + n-1 factor-2s :> ( r s ) 0 :> a! trials [ drop diff --git a/basis/math/primes/primes-docs.factor b/basis/math/primes/primes-docs.factor index 7f525debfe..74aa2ebca3 100644 --- a/basis/math/primes/primes-docs.factor +++ b/basis/math/primes/primes-docs.factor @@ -44,7 +44,8 @@ HELP: random-prime HELP: unique-primes { $values - { "numbits" integer } { "n" integer } + { "n" integer } + { "numbits" integer } { "seq" sequence } } { $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ; diff --git a/basis/math/ranges/ranges-docs.factor b/basis/math/ranges/ranges-docs.factor index 584bb3115b..1c82f516c9 100644 --- a/basis/math/ranges/ranges-docs.factor +++ b/basis/math/ranges/ranges-docs.factor @@ -23,6 +23,6 @@ $nl { $code "3 10 [a,b] [ sqrt ] map" } "Computing the factorial of 100 with a descending range:" { $code "100 1 [a,b] product" } -"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ; +"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link map! } "." ; ABOUT: "math.ranges" diff --git a/basis/math/ratios/ratios-tests.factor b/basis/math/ratios/ratios-tests.factor index 8124fcdd24..153d650914 100644 --- a/basis/math/ratios/ratios-tests.factor +++ b/basis/math/ratios/ratios-tests.factor @@ -84,8 +84,8 @@ unit-test [ 1.0 ] [ 0.5 1/2 + ] unit-test [ 1.0 ] [ 1/2 0.5 + ] unit-test -[ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test -[ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test +[ 1/134217728 ] [ -1 -134217728 >fixnum / ] unit-test +[ 134217728 ] [ -134217728 >fixnum -1 / ] unit-test [ 5 ] [ "10/2" string>number ] diff --git a/basis/math/rectangles/rectangles.factor b/basis/math/rectangles/rectangles.factor index c8569dfdb9..bfde391884 100644 --- a/basis/math/rectangles/rectangles.factor +++ b/basis/math/rectangles/rectangles.factor @@ -8,7 +8,7 @@ TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; : ( loc dim -- rect ) rect boa ; inline -SYNTAX: RECT: scan-object scan-object parsed ; +SYNTAX: RECT: scan-object scan-object suffix! ; : ( -- rect ) rect new ; inline @@ -64,4 +64,4 @@ M: rect contains-point? USING: vocabs vocabs.loader ; -"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when \ No newline at end of file +"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when diff --git a/basis/math/statistics/statistics-docs.factor b/basis/math/statistics/statistics-docs.factor index 1a29d611f9..9834f44add 100644 --- a/basis/math/statistics/statistics-docs.factor +++ b/basis/math/statistics/statistics-docs.factor @@ -1,56 +1,67 @@ -USING: help.markup help.syntax debugger ; +USING: assocs debugger hashtables help.markup help.syntax +quotations sequences math ; IN: math.statistics HELP: geometric-mean -{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } -{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." } +{ $values { "seq" sequence } { "x" "a non-negative real number"} } +{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set and minimizes the effects of extreme values." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } } { $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ; HELP: harmonic-mean -{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } +{ $values { "seq" sequence } { "x" "a non-negative real number"} } { $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." } { $notes "Positive reals only." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: mean -{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } -{ $description "Computes the arithmetic mean of all elements in " { $snippet "seq" } "." } +{ $values { "seq" sequence } { "x" "a non-negative real number"} } +{ $description "Computes the arithmetic mean of the elements in " { $snippet "seq" } "." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } mean ." "2" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: median -{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } -{ $description "Computes the median of " { $snippet "seq" } " by sorting the sequence from lowest value to highest and outputting the middle one. If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is outputted." } +{ $values { "seq" sequence } { "x" "a non-negative real number"} } +{ $description "Computes the median of " { $snippet "seq" } " by finding the middle element of the sequence using " { $link kth-smallest } ". If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is output." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } median ." "2" } { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } median ." "2+1/2" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: range -{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } -{ $description "Computes the distance of the maximum and minimum values in " { $snippet "seq" } "." } +{ $values { "seq" sequence } { "x" "a non-negative real number"} } +{ $description "Computes the difference of the maximum and minimum values in " { $snippet "seq" } "." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } range ." "2" } { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } range ." "3" } } ; +HELP: minmax +{ $values { "seq" sequence } { "min" real } { "max" real } } +{ $description "Finds the minimum and maximum elements of " { $snippet "seq" } " in one pass." } +{ $examples + { $example "USING: arrays math.statistics prettyprint ;" + "{ 1 2 3 } minmax 2array ." + "{ 1 3 }" + } +} ; + HELP: std -{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } +{ $values { "seq" sequence } { "x" "a non-negative real number"} } { $description "Computes the standard deviation of " { $snippet "seq" } ", which is the square root of the variance. It measures how widely spread the values in a sequence are about the mean." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } std ." "1.0" } { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } std ." "1.290994448735806" } } ; HELP: ste - { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } + { $values { "seq" sequence } { "x" "a non-negative real number"} } { $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." } { $examples { $example "USING: math.statistics prettyprint ;" "{ -2 2 } ste ." "2.0" } { $example "USING: math.statistics prettyprint ;" "{ -2 2 2 } ste ." "1.333333333333333" } } ; HELP: var -{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } +{ $values { "seq" sequence } { "x" "a non-negative real number"} } { $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." } { $notes "If the number of elements in " { $snippet "seq" } " is 1 or less, it outputs 0." } { $examples @@ -58,3 +69,118 @@ HELP: var { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } var ." "1" } { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } var ." "1+2/3" } } ; + +HELP: histogram +{ $values + { "seq" sequence } + { "hashtable" hashtable } +} +{ $examples + { $example "! Count the number of times an element appears in a sequence." + "USING: prettyprint math.statistics ;" + "\"aaabc\" histogram ." + "H{ { 97 3 } { 98 1 } { 99 1 } }" + } +} +{ $description "Returns a hashtable where the keys are the elements of the sequence and the values are the number of times they appeared in that sequence." } ; + +HELP: histogram* +{ $values + { "hashtable" hashtable } { "seq" sequence } + { "hashtable" hashtable } +} +{ $examples + { $example "! Count the number of times the elements of two sequences appear." + "USING: prettyprint math.statistics ;" + "\"aaabc\" histogram \"aaaaaabc\" histogram* ." + "H{ { 97 9 } { 98 2 } { 99 2 } }" + } +} +{ $description "Takes an existing hashtable and uses " { $link histogram } " to continue counting the number of occurences of each element." } ; + +HELP: sorted-histogram +{ $values + { "seq" sequence } + { "alist" "an array of key/value pairs" } +} +{ $description "Outputs a " { $link histogram } " of a sequence sorted by number of occurences from lowest to highest." } +{ $examples + { $example "USING: prettyprint math.statistics ;" + """"abababbbbbbc" sorted-histogram .""" + "{ { 99 1 } { 97 3 } { 98 8 } }" + } +} ; + +HELP: sequence>assoc +{ $values + { "seq" sequence } { "quot" quotation } { "exemplar" "an exemplar assoc" } + { "assoc" assoc } +} +{ $examples + { $example "! Iterate over a sequence and increment the count at each element" + "USING: assocs prettyprint math.statistics ;" + "\"aaabc\" [ inc-at ] H{ } sequence>assoc ." + "H{ { 97 3 } { 98 1 } { 99 1 } }" + } +} +{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a newly created " { $snippet "assoc" } " according to the passed quotation." } ; + +HELP: sequence>assoc* +{ $values + { "assoc" assoc } { "seq" sequence } { "quot" quotation } + { "assoc" assoc } +} +{ $examples + { $example "! Iterate over a sequence and add the counts to an existing assoc" + "USING: assocs prettyprint math.statistics kernel ;" + "H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ inc-at ] sequence>assoc* ." + "H{ { 97 5 } { 98 2 } { 99 1 } }" + } +} +{ $description "Iterates over a sequence, allowing elements of the sequence to be added to an existing " { $snippet "assoc" } " according to the passed quotation." } ; + +HELP: sequence>hashtable +{ $values + { "seq" sequence } { "quot" quotation } + { "hashtable" hashtable } +} +{ $examples + { $example "! Count the number of times an element occurs in a sequence" + "USING: assocs prettyprint math.statistics ;" + "\"aaabc\" [ inc-at ] sequence>hashtable ." + "H{ { 97 3 } { 98 1 } { 99 1 } }" + } +} +{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a hashtable according to the passed quotation." } ; + +ARTICLE: "histogram" "Computing histograms" +"Counting elements in a sequence:" +{ $subsections + histogram + histogram* + sorted-histogram +} +"Combinators for implementing histogram:" +{ $subsections + sequence>assoc + sequence>assoc* + sequence>hashtable +} ; + +ARTICLE: "math.statistics" "Statistics" +"Computing the mean:" +{ $subsections mean geometric-mean harmonic-mean } +"Computing the median:" +{ $subsections median lower-median upper-median medians } +"Computing the mode:" +{ $subsections mode } +"Computing the standard deviation, standard error, and variance:" +{ $subsections std ste var } +"Computing the range and minimum and maximum elements:" +{ $subsections range minmax } +"Computing the kth smallest element:" +{ $subsections kth-smallest } +"Counting the frequency of occurrence of elements:" +{ $subsection "histogram" } ; + +ABOUT: "math.statistics" diff --git a/basis/math/statistics/statistics-tests.factor b/basis/math/statistics/statistics-tests.factor index 32ebcbc6a1..0d3172f685 100644 --- a/basis/math/statistics/statistics-tests.factor +++ b/basis/math/statistics/statistics-tests.factor @@ -43,3 +43,13 @@ IN: math.statistics.tests [ 0 ] [ { 1 } var ] unit-test [ 0.0 ] [ { 1 } std ] unit-test [ 0.0 ] [ { 1 } ste ] unit-test + +[ + H{ + { 97 2 } + { 98 2 } + { 99 2 } + } +] [ + "aabbcc" histogram +] unit-test diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index a1a214b2c0..73a87ffb72 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Doug Coleman, Michael Judge. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators kernel math math.analysis -math.functions math.order sequences sorting locals -sequences.private assocs fry ; +USING: arrays combinators kernel math math.functions +math.order sequences sorting locals sequences.private +assocs fry ; IN: math.statistics : mean ( seq -- x ) @@ -12,7 +12,7 @@ IN: math.statistics [ length ] [ product ] bi nth-root ; : harmonic-mean ( seq -- x ) - [ recip ] sigma recip ; + [ recip ] map-sum recip ; :: kth-smallest ( seq k -- elt ) #! Wirth's method, Algorithm's + Data structues = Programs p. 84 @@ -33,7 +33,7 @@ IN: math.statistics [ i seq nth-unsafe x < ] [ i 1 + i! ] while [ x j seq nth-unsafe < ] [ j 1 - j! ] while i j <= [ - i j seq exchange + i j seq exchange-unsafe i 1 + i! j 1 - j! ] when @@ -45,7 +45,8 @@ IN: math.statistics k seq nth ; inline : lower-median ( seq -- elt ) - dup dup length odd? [ midpoint@ ] [ midpoint@ 1 - ] if kth-smallest ; + [ ] [ ] [ length odd? ] tri + [ midpoint@ ] [ midpoint@ 1 - ] if kth-smallest ; : upper-median ( seq -- elt ) dup midpoint@ kth-smallest ; @@ -54,13 +55,38 @@ IN: math.statistics [ lower-median ] [ upper-median ] bi ; : median ( seq -- x ) - dup length odd? [ lower-median ] [ medians + 2 / ] if ; + [ ] [ length odd? ] bi [ lower-median ] [ medians + 2 / ] if ; -: frequency ( seq -- hashtable ) - H{ } clone [ '[ _ inc-at ] each ] keep ; +assoc) ( seq quot assoc -- assoc ) + [ swap curry each ] keep ; inline + +PRIVATE> + +: sequence>assoc* ( assoc seq quot: ( obj assoc -- ) -- assoc ) + rot (sequence>assoc) ; inline + +: sequence>assoc ( seq quot: ( obj assoc -- ) exemplar -- assoc ) + clone (sequence>assoc) ; inline + +: sequence>hashtable ( seq quot: ( obj hashtable -- ) -- hashtable ) + H{ } sequence>assoc ; inline + +: histogram* ( hashtable seq -- hashtable ) + [ inc-at ] sequence>assoc* ; + +: histogram ( seq -- hashtable ) + [ inc-at ] sequence>hashtable ; + +: sorted-histogram ( seq -- alist ) + histogram >alist sort-values ; + +: collect-values ( seq quot: ( obj hashtable -- ) -- hash ) + '[ [ dup @ ] dip push-at ] sequence>hashtable ; inline : mode ( seq -- x ) - frequency >alist + histogram >alist [ ] [ [ [ second ] bi@ > ] 2keep ? ] map-reduce first ; : minmax ( seq -- min max ) @@ -75,7 +101,7 @@ IN: math.statistics dup length 1 <= [ drop 0 ] [ - [ [ mean ] keep [ - sq ] with sigma ] + [ [ mean ] keep [ - sq ] with map-sum ] [ length 1 - ] bi / ] if ; diff --git a/basis/math/vectors/conversion/conversion.factor b/basis/math/vectors/conversion/conversion.factor index f70dfc9b27..fd58b11dc8 100644 --- a/basis/math/vectors/conversion/conversion.factor +++ b/basis/math/vectors/conversion/conversion.factor @@ -11,9 +11,9 @@ ERROR: bad-vconvert-input value expected-type ; MACRO:: vconvert ( from-type to-type -- ) - from-type new [ element-type ] [ byte-length ] bi :> from-length :> from-element - to-type new [ element-type ] [ byte-length ] bi :> to-length :> to-element + from-type new [ element-type ] [ byte-length ] bi :> ( from-element from-length ) + to-type new [ element-type ] [ byte-length ] bi :> ( to-element to-length ) from-element heap-size :> from-size to-element heap-size :> to-size diff --git a/basis/math/vectors/simd/functor/functor.factor b/basis/math/vectors/simd/functor/functor.factor index 480981d165..cdb67f976f 100644 --- a/basis/math/vectors/simd/functor/functor.factor +++ b/basis/math/vectors/simd/functor/functor.factor @@ -146,7 +146,8 @@ TUPLE: simd class elt-class ops special-wrappers schema-wrappers ctor rep ; [ rep alien-vector class boa ] >>getter [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter 16 >>size - 8 >>align + 16 >>align + 16 >>align-first rep >>rep class c:typedef ; @@ -315,7 +316,8 @@ SLOT: underlying2 3bi ] >>setter 32 >>size - 8 >>align + 16 >>align + 16 >>align-first rep >>rep class c:typedef ; diff --git a/basis/math/vectors/simd/intrinsics/intrinsics.factor b/basis/math/vectors/simd/intrinsics/intrinsics.factor index 1bd5834f2c..003b42fe83 100644 --- a/basis/math/vectors/simd/intrinsics/intrinsics.factor +++ b/basis/math/vectors/simd/intrinsics/intrinsics.factor @@ -163,8 +163,8 @@ M: vector-rep supported-simd-op? { \ (simd-v*) [ %mul-vector-reps ] } { \ (simd-vs*) [ %saturated-mul-vector-reps ] } { \ (simd-v/) [ %div-vector-reps ] } - { \ (simd-vmin) [ %min-vector-reps ] } - { \ (simd-vmax) [ %max-vector-reps ] } + { \ (simd-vmin) [ %min-vector-reps cc< %compare-vector-reps union ] } + { \ (simd-vmax) [ %max-vector-reps cc> %compare-vector-reps union ] } { \ (simd-v.) [ %dot-vector-reps ] } { \ (simd-vsqrt) [ %sqrt-vector-reps ] } { \ (simd-sum) [ %horizontal-add-vector-reps ] } @@ -181,8 +181,8 @@ M: vector-rep supported-simd-op? { \ (simd-vnot) [ %xor-vector-reps ] } { \ (simd-vlshift) [ %shl-vector-reps ] } { \ (simd-vrshift) [ %shr-vector-reps ] } - { \ (simd-hlshift) [ %horizontal-shl-vector-reps ] } - { \ (simd-hrshift) [ %horizontal-shr-vector-reps ] } + { \ (simd-hlshift) [ %horizontal-shl-vector-imm-reps ] } + { \ (simd-hrshift) [ %horizontal-shr-vector-imm-reps ] } { \ (simd-vshuffle-elements) [ (%shuffle-imm-reps) ] } { \ (simd-vshuffle-bytes) [ %shuffle-vector-reps ] } { \ (simd-(vmerge-head)) [ %merge-vector-reps ] } @@ -193,12 +193,12 @@ M: vector-rep supported-simd-op? { \ (simd-(vpack-unsigned)) [ %unsigned-pack-vector-reps ] } { \ (simd-(vunpack-head)) [ (%unpack-reps) ] } { \ (simd-(vunpack-tail)) [ (%unpack-reps) ] } - { \ (simd-v<=) [ cc<= %compare-vector-reps ] } - { \ (simd-v<) [ cc< %compare-vector-reps ] } - { \ (simd-v=) [ cc= %compare-vector-reps ] } - { \ (simd-v>) [ cc> %compare-vector-reps ] } - { \ (simd-v>=) [ cc>= %compare-vector-reps ] } - { \ (simd-vunordered?) [ cc/<>= %compare-vector-reps ] } + { \ (simd-v<=) [ unsign-rep cc<= %compare-vector-reps ] } + { \ (simd-v<) [ unsign-rep cc< %compare-vector-reps ] } + { \ (simd-v=) [ unsign-rep cc= %compare-vector-reps ] } + { \ (simd-v>) [ unsign-rep cc> %compare-vector-reps ] } + { \ (simd-v>=) [ unsign-rep cc>= %compare-vector-reps ] } + { \ (simd-vunordered?) [ unsign-rep cc/<>= %compare-vector-reps ] } { \ (simd-gather-2) [ %gather-vector-2-reps ] } { \ (simd-gather-4) [ %gather-vector-4-reps ] } { \ (simd-vany?) [ %test-vector-reps ] } diff --git a/basis/math/vectors/simd/simd-tests.factor b/basis/math/vectors/simd/simd-tests.factor index 7803c00954..46cced3cb7 100644 --- a/basis/math/vectors/simd/simd-tests.factor +++ b/basis/math/vectors/simd/simd-tests.factor @@ -88,8 +88,8 @@ CONSTANT: simd-classes { [ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ] [ "print-checks" get [ [ . ] bi@ ] [ 2drop ] if ] - [ [ call ] dip call ] - [ [ call ] dip compile-call ] + [ [ [ call ] dip call ] call( quot quot -- result ) ] + [ [ [ call ] dip compile-call ] call( quot quot -- result ) ] } 2cleave @ not ] filter ; inline @@ -233,7 +233,7 @@ simd-classes&reps [ ] [ ] map-as word '[ _ execute ] ; -: check-boolean-ops ( class elt-class compare-quot -- ) +: check-boolean-ops ( class elt-class compare-quot -- seq ) [ [ boolean-ops [ dup word-schema ] { } map>assoc ] 2dip '[ first2 inputs _ _ check-boolean-op ] @@ -357,13 +357,15 @@ simd-classes [ new [ drop 16 random ] map ; :: test-shift-vector ( class -- ? ) - class random-int-vector :> src - char-16 random-shift-vector :> perm - { class char-16 } :> decl - - src perm vshuffle - src perm [ decl declare vshuffle ] compile-call - = ; inline + [ + class random-int-vector :> src + char-16 random-shift-vector :> perm + { class char-16 } :> decl + + src perm vshuffle + src perm [ decl declare vshuffle ] compile-call + = + ] call( -- ? ) ; { char-16 uchar-16 short-8 ushort-8 int-4 uint-4 longlong-2 ulonglong-2 } [ 10 swap '[ [ t ] [ _ test-shift-vector ] unit-test ] times ] each @@ -371,19 +373,23 @@ simd-classes [ "== Checking vector tests" print :: test-vector-tests-bool ( vector declaration -- none? any? all? ) - vector - [ [ declaration declare vnone? ] compile-call ] - [ [ declaration declare vany? ] compile-call ] - [ [ declaration declare vall? ] compile-call ] tri ; inline + [ + vector + [ [ declaration declare vnone? ] compile-call ] + [ [ declaration declare vany? ] compile-call ] + [ [ declaration declare vall? ] compile-call ] tri + ] call( -- none? any? all? ) ; : yes ( -- x ) t ; : no ( -- x ) f ; :: test-vector-tests-branch ( vector declaration -- none? any? all? ) - vector - [ [ declaration declare vnone? [ yes ] [ no ] if ] compile-call ] - [ [ declaration declare vany? [ yes ] [ no ] if ] compile-call ] - [ [ declaration declare vall? [ yes ] [ no ] if ] compile-call ] tri ; inline + [ + vector + [ [ declaration declare vnone? [ yes ] [ no ] if ] compile-call ] + [ [ declaration declare vany? [ yes ] [ no ] if ] compile-call ] + [ [ declaration declare vall? [ yes ] [ no ] if ] compile-call ] tri + ] call( -- none? any? all? ) ; TUPLE: inconsistent-vector-test bool branch ; @@ -391,12 +397,14 @@ TUPLE: inconsistent-vector-test bool branch ; 2dup = [ drop ] [ inconsistent-vector-test boa ] if ; :: test-vector-tests ( vector decl -- none? any? all? ) - vector decl test-vector-tests-bool :> bool-all :> bool-any :> bool-none - vector decl test-vector-tests-branch :> branch-all :> branch-any :> branch-none - - bool-none branch-none ?inconsistent - bool-any branch-any ?inconsistent - bool-all branch-all ?inconsistent ; inline + [ + vector decl test-vector-tests-bool :> ( bool-none bool-any bool-all ) + vector decl test-vector-tests-branch :> ( branch-none branch-any branch-all ) + + bool-none branch-none ?inconsistent + bool-any branch-any ?inconsistent + bool-all branch-all ?inconsistent + ] call( -- none? any? all? ) ; [ f t t ] [ float-4{ t t t t } { float-4 } test-vector-tests ] unit-test @@ -470,7 +478,7 @@ TUPLE: inconsistent-vector-test bool branch ; "== Checking broadcast" print : test-broadcast ( seq -- failures ) [ length >array ] keep - '[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ; inline + '[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ; [ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test [ { } ] [ int-4{ HEX: 7fffffff 3 4 -8 } test-broadcast ] unit-test @@ -582,3 +590,20 @@ STRUCT: simd-struct float-4{ 1.0 0.0 1.0 0.0 } pi [ broken 3array ] [ compile-call ] [ call ] 3bi = ] unit-test + +! Spilling SIMD values -- this basically just tests that the +! stack was aligned properly by the runtime + +: simd-spill-test-1 ( a b c -- v ) + { float-4 float-4 float } declare + [ v+ ] dip sin v*n ; + +[ float-4{ 0 0 0 0 } ] +[ float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-1 ] unit-test + +: simd-spill-test-2 ( a b d c -- v ) + { float float-4 float-4 float } declare + [ [ 3.0 + ] 2dip v+ ] dip sin v*n n*v ; + +[ float-4{ 0 0 0 0 } ] +[ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-2 ] unit-test diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor index ffa6b5ba18..388fed5f31 100644 --- a/basis/math/vectors/simd/simd.factor +++ b/basis/math/vectors/simd/simd.factor @@ -15,7 +15,7 @@ ERROR: bad-base-type type ; name>> "math.vectors.simd.instances." prepend ; : parse-base-type ( c-type -- c-type ) - dup { c:char c:uchar c:short c:ushort c:int c:uint c:longlong c:ulonglong c:float c:double } memq? + dup { c:char c:uchar c:short c:ushort c:int c:uint c:longlong c:ulonglong c:float c:double } member-eq? [ bad-base-type ] unless ; : forget-instances ( -- ) diff --git a/basis/math/vectors/specialization/specialization.factor b/basis/math/vectors/specialization/specialization.factor index 3ff286d508..602fd9802c 100644 --- a/basis/math/vectors/specialization/specialization.factor +++ b/basis/math/vectors/specialization/specialization.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: words kernel make sequences effects sets kernel.private accessors combinators math math.intervals math.vectors -math.vectors.conversion.backend -namespaces assocs fry splitting classes.algebra generalizations -locals compiler.tree.propagation.info ; +math.vectors.conversion.backend namespaces assocs fry splitting +classes.algebra generalizations locals +compiler.tree.propagation.info ; IN: math.vectors.specialization SYMBOLS: -> +vector+ +any-vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ; diff --git a/basis/math/vectors/vectors-docs.factor b/basis/math/vectors/vectors-docs.factor index 71e86417f5..b831ac7dbe 100644 --- a/basis/math/vectors/vectors-docs.factor +++ b/basis/math/vectors/vectors-docs.factor @@ -101,6 +101,7 @@ $nl vxor vnot v? + vif } "Entire vector tests:" { $subsections @@ -534,10 +535,19 @@ HELP: vnot { $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." } ; HELP: v? -{ $values { "mask" "a sequence of booleans" } { "true" "a sequence of numbers" } { "false" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $values { "mask" "a sequence of booleans" } { "true" "a sequence of numbers" } { "false" "a sequence of numbers" } { "result" "a sequence of numbers" } } { $description "Creates a new sequence by selecting elements from the " { $snippet "true" } " and " { $snippet "false" } " sequences based on whether the corresponding bits of the " { $snippet "mask" } " sequence are set or not." } { $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." } ; +HELP: vif +{ $values { "mask" "a sequence of booleans" } { "true-quot" { $quotation "( -- vector )" } } { "false-quot" { $quotation "( -- vector )" } } { "result" "a sequence" } } +{ $description "If all of the elements of " { $snippet "mask" } " are true, " { $snippet "true-quot" } " is called and its output value returned. If all of the elements of " { $snippet "mask" } " are false, " { $snippet "false-quot" } " is called and its output value returned. Otherwise, both quotations are called and " { $snippet "mask" } " is used to select elements from each output as with " { $link v? } "." } +{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." +$nl +"For most conditional SIMD code, unless a case is exceptionally expensive to compute, it is usually most efficient to just compute all cases and blend them with " { $link v? } " instead of using " { $snippet "vif" } "." } ; + +{ v? vif } related-words + HELP: vany? { $values { "v" "a sequence of booleans" } { "?" "a boolean" } } { $description "Returns true if any element of " { $snippet "v" } " is true." } diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 51e44d00f0..63564f064d 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -96,6 +96,7 @@ PRIVATE> :: vbroadcast ( u n -- v ) u length n u nth u like ; : vshuffle-elements ( u perm -- v ) + over length 0 pad-tail swap [ '[ _ nth ] ] keep map-as ; : vshuffle-bytes ( u perm -- v ) @@ -142,9 +143,16 @@ M: simd-128 vshuffle ( u perm -- v ) : vunordered? ( u v -- w ) [ unordered? ] 2map ; : v= ( u v -- w ) [ = ] 2map ; -: v? ( mask true false -- w ) +: v? ( mask true false -- result ) [ vand ] [ vandn ] bi-curry* bi vor ; inline +:: vif ( mask true-quot false-quot -- result ) + { + { [ mask vall? ] [ true-quot call ] } + { [ mask vnone? ] [ false-quot call ] } + [ mask true-quot call false-quot call v? ] + } cond ; inline + : vfloor ( u -- v ) [ floor ] map ; : vceiling ( u -- v ) [ ceiling ] map ; : vtruncate ( u -- v ) [ truncate ] map ; @@ -175,20 +183,20 @@ PRIVATE> : bilerp ( aa ba ab bb {t,u} -- a_tu ) [ first lerp ] [ second lerp ] bi-curry - [ 2bi@ ] [ call ] bi* ; + [ 2bi@ ] [ call ] bi* ; inline : vlerp ( a b t -- a_t ) - [ lerp ] 3map ; + [ over v- ] dip v* v+ ; inline : vnlerp ( a b t -- a_t ) - [ lerp ] curry 2map ; + [ over v- ] dip v*n v+ ; inline : vbilerp ( aa ba ab bb {t,u} -- a_tu ) [ first vnlerp ] [ second vnlerp ] bi-curry - [ 2bi@ ] [ call ] bi* ; + [ 2bi@ ] [ call ] bi* ; inline : v~ ( a b epsilon -- ? ) - [ ~ ] curry 2all? ; + [ ~ ] curry 2all? ; inline HINTS: vneg { array } ; HINTS: norm-sq { array } ; diff --git a/basis/mirrors/mirrors.factor b/basis/mirrors/mirrors.factor index b9f9019245..65978f0b46 100644 --- a/basis/mirrors/mirrors.factor +++ b/basis/mirrors/mirrors.factor @@ -3,7 +3,7 @@ USING: assocs hashtables kernel sequences generic words arrays classes slots slots.private classes.tuple classes.tuple.private math vectors math.vectors quotations -accessors combinators byte-arrays specialized-arrays ; +accessors combinators byte-arrays vocabs vocabs.loader ; IN: mirrors TUPLE: mirror { object read-only } ; @@ -53,12 +53,13 @@ INSTANCE: array enumerated-sequence INSTANCE: vector enumerated-sequence INSTANCE: callable enumerated-sequence INSTANCE: byte-array enumerated-sequence -INSTANCE: specialized-array enumerated-sequence -INSTANCE: simd-128 enumerated-sequence -INSTANCE: simd-256 enumerated-sequence GENERIC: make-mirror ( obj -- assoc ) M: hashtable make-mirror ; M: integer make-mirror drop f ; M: enumerated-sequence make-mirror ; M: object make-mirror ; + +"specialized-arrays" vocab [ + "specialized-arrays.mirrors" require +] when diff --git a/basis/models/arrow/arrow-tests.factor b/basis/models/arrow/arrow-tests.factor index d7900f1dbd..6bd6395ac0 100644 --- a/basis/models/arrow/arrow-tests.factor +++ b/basis/models/arrow/arrow-tests.factor @@ -6,12 +6,12 @@ IN: models.arrow.tests "x" get [ 2 * ] dup "z" set [ 1 + ] "y" set [ ] [ "y" get activate-model ] unit-test -[ t ] [ "z" get "x" get connections>> memq? ] unit-test +[ t ] [ "z" get "x" get connections>> member-eq? ] unit-test [ 7 ] [ "y" get value>> ] unit-test [ ] [ 4 "x" get set-model ] unit-test [ 9 ] [ "y" get value>> ] unit-test [ ] [ "y" get deactivate-model ] unit-test -[ f ] [ "z" get "x" get connections>> memq? ] unit-test +[ f ] [ "z" get "x" get connections>> member-eq? ] unit-test 3 "x" set "x" get [ sq ] "y" set diff --git a/basis/models/models.factor b/basis/models/models.factor index 27504bc0fa..f9927cfd4c 100644 --- a/basis/models/models.factor +++ b/basis/models/models.factor @@ -17,13 +17,11 @@ value connections dependencies ref locked? ; : ( value -- model ) model new-model ; -M: model hashcode* drop model hashcode* ; - : add-dependency ( dep model -- ) dependencies>> push ; : remove-dependency ( dep model -- ) - dependencies>> delete ; + dependencies>> remove! drop ; DEFER: add-connection @@ -63,7 +61,7 @@ GENERIC: model-changed ( model observer -- ) connections>> push ; : remove-connection ( observer model -- ) - [ connections>> delete ] keep + [ connections>> remove! drop ] keep dup connections>> empty? [ dup deactivate-model ] when drop ; diff --git a/basis/models/product/product-tests.factor b/basis/models/product/product-tests.factor index f52dc8a3b0..c26866e83b 100644 --- a/basis/models/product/product-tests.factor +++ b/basis/models/product/product-tests.factor @@ -27,11 +27,12 @@ TUPLE: an-observer { i integer } ; M: an-observer model-changed nip [ 1 + ] change-i drop ; [ 1 0 ] [ - [let* | m1 [ 1 ] - m2 [ 2 ] - c [ { m1 m2 } ] - o1 [ an-observer new ] - o2 [ an-observer new ] | + [let + 1 :> m1 + 2 :> m2 + { m1 m2 } :> c + an-observer new :> o1 + an-observer new :> o2 o1 m1 add-connection o2 m2 add-connection diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index e28537066b..5182c33e59 100644 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -81,10 +81,10 @@ SYNTAX: HEREDOC: lexer get skip-blank rest-of-line lexer get next-line - parse-til-line-begins parsed ; + parse-til-line-begins suffix! ; SYNTAX: DELIMITED: lexer get skip-blank rest-of-line lexer get next-line - 0 (parse-multiline-string) parsed ; + 0 (parse-multiline-string) suffix! ; diff --git a/basis/opengl/debug/debug.factor b/basis/opengl/debug/debug.factor index 7cbdf62346..0662a9c08a 100644 --- a/basis/opengl/debug/debug.factor +++ b/basis/opengl/debug/debug.factor @@ -1,5 +1,5 @@ ! (c)2009 Joe Groff bsd license -USING: accessors kernel namespaces parser tools.continuations +USING: accessors kernel namespaces parser sequences tools.continuations ui.backend ui.gadgets.worlds words ; IN: opengl.debug @@ -19,5 +19,5 @@ SYMBOL: G-world << \ gl-break t "break?" set-word-prop >> SYNTAX: GB - \ gl-break parsed ; + \ gl-break suffix! ; diff --git a/basis/opengl/opengl-tests.factor b/basis/opengl/opengl-tests.factor new file mode 100644 index 0000000000..818d0db8b7 --- /dev/null +++ b/basis/opengl/opengl-tests.factor @@ -0,0 +1,6 @@ +USING: tools.test math opengl opengl.gl ; +IN: opengl.tests + +{ 2 1 } [ { GL_TEXTURE_2D } [ + ] all-enabled ] must-infer-as + +{ 2 1 } [ { GL_TEXTURE_2D } [ + ] all-enabled-client-state ] must-infer-as diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index cdf68cebd3..1f6205e64f 100755 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -56,7 +56,9 @@ TUPLE: gl-error function code string ; [ ?execute ] map ; : (all-enabled) ( seq quot -- ) - over [ glEnable ] each dip [ glDisable ] each ; inline + [ dup [ glEnable ] each ] dip + dip + [ glDisable ] each ; inline : (all-enabled-client-state) ( seq quot -- ) [ dup [ glEnableClientState ] each ] dip @@ -95,8 +97,8 @@ 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. - loc first2 :> y :> x - dim first2 :> h :> w + loc first2 :> ( x y ) + dim first2 :> ( w h ) [ x 0.5 + y 0.5 + x w + 0.3 - y 0.5 + @@ -115,8 +117,8 @@ MACRO: all-enabled-client-state ( seq quot -- ) rect-vertices (gl-rect) ; :: (fill-rect-vertices) ( loc dim -- vertices ) - loc first2 :> y :> x - dim first2 :> h :> w + loc first2 :> ( x y ) + dim first2 :> ( w h ) [ x y x w + y diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index d846afe3a9..e53383c98b 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -278,7 +278,7 @@ TUPLE: single-texture < disposable image dim loc texture-coords texture display- ] unless ; :: tex-image ( image bitmap -- ) - image image-format :> type :> format :> internal-format + image image-format :> ( internal-format format type ) GL_TEXTURE_2D 0 internal-format image dim>> adjust-texture-dim first2 0 format type bitmap glTexImage2D ; diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index 3b9739fb0f..a330337c5e 100755 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -97,7 +97,7 @@ MACRO: pack ( str -- quot ) packed-length-table at ; inline : packed-length ( str -- n ) - [ ch>packed-length ] sigma ; + [ ch>packed-length ] map-sum ; : pack-native ( seq str -- seq ) '[ _ _ pack ] with-native-endian ; inline diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index 136007e7ce..5ddd5f9bf0 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -445,16 +445,16 @@ M: ebnf-sequence build-locals ( code ast -- code ) drop ] [ [ - "FROM: locals => [let* ; FROM: sequences => nth ; [let* | " % - dup length swap [ - dup ebnf-var? [ + "FROM: locals => [let :> ; FROM: sequences => nth ; [let " % + dup length [ + over ebnf-var? [ + " " % # " over nth :> " % name>> % - " [ " % # " over nth ] " % ] [ 2drop ] if ] 2each - " | " % + " " % % " nip ]" % ] "" make @@ -463,9 +463,9 @@ M: ebnf-sequence build-locals ( code ast -- code ) M: ebnf-var build-locals ( code ast -- ) [ - "FROM: locals => [let* ; FROM: kernel => dup nip ; [let* | " % - name>> % " [ dup ] " % - " | " % + "FROM: locals => [let :> ; FROM: kernel => dup nip ; [let " % + " dup :> " % name>> % + " " % % " nip ]" % ] "" make ; @@ -547,12 +547,12 @@ PRIVATE> SYNTAX: " reset-tokenizer parse-multiline-string parse-ebnf main swap at - parsed reset-tokenizer ; + suffix! reset-tokenizer ; SYNTAX: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip - parsed \ call parsed reset-tokenizer ; + suffix! \ call suffix! reset-tokenizer ; SYNTAX: EBNF: reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor index 850b585190..c8a8080f38 100644 --- a/basis/peg/parsers/parsers.factor +++ b/basis/peg/parsers/parsers.factor @@ -40,7 +40,7 @@ M: just-parser (compile) ( parser -- quot ) diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 9e777b86af..d4397627e8 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -172,9 +172,7 @@ TUPLE: peg-head rule-id involved-set eval-set ; l lrstack get (setup-lr) ; :: lr-answer ( r p m -- ast ) - [let* | - h [ m ans>> head>> ] - | + m ans>> head>> :> h h rule-id>> r rule-id eq? [ m ans>> seed>> m (>>ans) m ans>> failed? [ @@ -184,14 +182,11 @@ TUPLE: peg-head rule-id involved-set eval-set ; ] if ] [ m ans>> seed>> - ] if - ] ; inline + ] if ; inline :: recall ( r p -- memo-entry ) - [let* | - m [ p r rule-id memo ] - h [ p heads at ] - | + p r rule-id memo :> m + p heads at :> h h [ m r rule-id h involved-set>> h rule-id>> suffix member? not and [ fail p memo-entry boa @@ -207,15 +202,12 @@ TUPLE: peg-head rule-id involved-set eval-set ; ] if ] [ m - ] if - ] ; inline + ] if ; inline :: apply-non-memo-rule ( r p -- ast ) - [let* | - lr [ fail r rule-id f lrstack get left-recursion boa ] - m [ lr lrstack set lr p memo-entry boa dup p r rule-id set-memo ] - ans [ r eval-rule ] - | + fail r rule-id f lrstack get left-recursion boa :> lr + lr lrstack set lr p memo-entry boa dup p r rule-id set-memo :> m + r eval-rule :> ans lrstack get next>> lrstack set pos get m (>>pos) lr head>> [ @@ -226,8 +218,7 @@ TUPLE: peg-head rule-id involved-set eval-set ; ] [ ans m (>>ans) ans - ] if - ] ; inline + ] if ; inline : apply-memo-rule ( r m -- ast ) [ ans>> ] [ pos>> ] bi pos set @@ -622,20 +613,19 @@ PRIVATE> ERROR: parse-failed input word ; SYNTAX: PEG: - (:) - [let | effect [ ] def [ ] word [ ] | - [ - [ - [let | compiled-def [ def call compile ] | + [let + (:) :> ( word def effect ) + [ [ - dup compiled-def compiled-parse - [ ast>> ] [ word parse-failed ] ?if - ] - word swap effect define-declared - ] - ] with-compilation-unit - ] over push-all - ] ; + def call compile :> compiled-def + [ + dup compiled-def compiled-parse + [ ast>> ] [ word parse-failed ] ?if + ] + word swap effect define-declared + ] with-compilation-unit + ] append! + ] ; USING: vocabs vocabs.loader ; diff --git a/basis/persistent/hashtables/config/config.factor b/basis/persistent/hashtables/config/config.factor index cb2abd8015..190db9e9ab 100644 --- a/basis/persistent/hashtables/config/config.factor +++ b/basis/persistent/hashtables/config/config.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: layouts kernel parser math ; +USING: layouts kernel parser math sequences ; IN: persistent.hashtables.config -: radix-bits ( -- n ) << cell 4 = 4 5 ? parsed >> ; foldable +: radix-bits ( -- n ) << cell 4 = 4 5 ? suffix! >> ; foldable : radix-mask ( -- n ) radix-bits 2^ 1 - ; foldable : full-bitmap-mask ( -- n ) radix-bits 2^ 2^ 1 - ; inline diff --git a/basis/persistent/hashtables/hashtables-tests.factor b/basis/persistent/hashtables/hashtables-tests.factor index eea31dd34e..d66fdd0c08 100644 --- a/basis/persistent/hashtables/hashtables-tests.factor +++ b/basis/persistent/hashtables/hashtables-tests.factor @@ -1,6 +1,6 @@ IN: persistent.hashtables.tests USING: persistent.hashtables persistent.assocs hashtables assocs -tools.test kernel namespaces random math.ranges sequences fry ; +tools.test kernel locals namespaces random math.ranges sequences fry ; [ t ] [ PH{ } assoc-empty? ] unit-test @@ -86,7 +86,7 @@ M: hash-0-b hashcode* 2drop 0 ; : random-assocs ( n -- hash phash ) [ random-string ] replicate [ H{ } clone [ '[ swap _ set-at ] each-index ] keep ] - [ PH{ } clone swap [ spin new-at ] each-index ] + [ PH{ } clone swap [| ph elt i | i elt ph new-at ] each-index ] bi ; : ok? ( assoc1 assoc2 -- ? ) diff --git a/basis/persistent/hashtables/hashtables.factor b/basis/persistent/hashtables/hashtables.factor index 0179216e62..256baabd5e 100644 --- a/basis/persistent/hashtables/hashtables.factor +++ b/basis/persistent/hashtables/hashtables.factor @@ -1,7 +1,7 @@ ! Based on Clojure's PersistentHashMap by Rich Hickey. USING: kernel math accessors assocs fry combinators parser -prettyprint.custom make +prettyprint.custom locals make persistent.assocs persistent.hashtables.nodes persistent.hashtables.nodes.empty @@ -38,8 +38,8 @@ M: persistent-hash pluck-at M: persistent-hash >alist [ root>> >alist% ] { } make ; -: >persistent-hash ( assoc -- phash ) - T{ persistent-hash } swap [ spin new-at ] assoc-each ; +:: >persistent-hash ( assoc -- phash ) + T{ persistent-hash } assoc [| ph k v | v k ph new-at ] assoc-each ; M: persistent-hash equal? over persistent-hash? [ assoc= ] [ 2drop f ] if ; diff --git a/basis/persistent/hashtables/nodes/bitmap/bitmap.factor b/basis/persistent/hashtables/nodes/bitmap/bitmap.factor index 4c764eba93..d623e90019 100644 --- a/basis/persistent/hashtables/nodes/bitmap/bitmap.factor +++ b/basis/persistent/hashtables/nodes/bitmap/bitmap.factor @@ -10,77 +10,70 @@ IN: persistent.hashtables.nodes.bitmap : index ( bit bitmap -- n ) [ 1 - ] dip bitand bit-count ; inline M:: bitmap-node (entry-at) ( key hashcode bitmap-node -- entry ) - [let* | shift [ bitmap-node shift>> ] - bit [ hashcode shift bitpos ] - bitmap [ bitmap-node bitmap>> ] - nodes [ bitmap-node nodes>> ] | - bitmap bit bitand 0 eq? [ f ] [ - key hashcode - bit bitmap index nodes nth-unsafe - (entry-at) - ] if - ] ; + bitmap-node shift>> :> shift + hashcode shift bitpos :> bit + bitmap-node bitmap>> :> bitmap + bitmap-node nodes>> :> nodes + bitmap bit bitand 0 eq? [ f ] [ + key hashcode + bit bitmap index nodes nth-unsafe + (entry-at) + ] if ; M:: bitmap-node (new-at) ( shift value key hashcode bitmap-node -- node' added-leaf ) - [let* | shift [ bitmap-node shift>> ] - bit [ hashcode shift bitpos ] - bitmap [ bitmap-node bitmap>> ] - idx [ bit bitmap index ] - nodes [ bitmap-node nodes>> ] | - bitmap bit bitand 0 eq? [ - [let | new-leaf [ value key hashcode ] | - bitmap bit bitor - new-leaf idx nodes insert-nth - shift - - new-leaf - ] + bitmap-node shift>> :> shift + hashcode shift bitpos :> bit + bitmap-node bitmap>> :> bitmap + bit bitmap index :> idx + bitmap-node nodes>> :> nodes + + bitmap bit bitand 0 eq? [ + value key hashcode :> new-leaf + bitmap bit bitor + new-leaf idx nodes insert-nth + shift + + new-leaf + ] [ + idx nodes nth :> n + shift radix-bits + value key hashcode n (new-at) :> ( n' new-leaf ) + n n' eq? [ + bitmap-node ] [ - [let | n [ idx nodes nth ] | - shift radix-bits + value key hashcode n (new-at) - [let | new-leaf [ ] n' [ ] | - n n' eq? [ - bitmap-node - ] [ - bitmap - n' idx nodes new-nth - shift - - ] if - new-leaf - ] - ] + bitmap + n' idx nodes new-nth + shift + ] if - ] ; + new-leaf + ] if ; M:: bitmap-node (pluck-at) ( key hashcode bitmap-node -- node' ) - [let | bit [ hashcode bitmap-node shift>> bitpos ] - bitmap [ bitmap-node bitmap>> ] - nodes [ bitmap-node nodes>> ] - shift [ bitmap-node shift>> ] | - bit bitmap bitand 0 eq? [ bitmap-node ] [ - [let* | idx [ bit bitmap index ] - n [ idx nodes nth-unsafe ] - n' [ key hashcode n (pluck-at) ] | - n n' eq? [ - bitmap-node - ] [ - n' [ - bitmap - n' idx nodes new-nth - shift - - ] [ - bitmap bit eq? [ f ] [ - bitmap bit bitnot bitand - idx nodes remove-nth - shift - - ] if - ] if + hashcode bitmap-node shift>> bitpos :> bit + bitmap-node bitmap>> :> bitmap + bitmap-node nodes>> :> nodes + bitmap-node shift>> :> shift + bit bitmap bitand 0 eq? [ bitmap-node ] [ + bit bitmap index :> idx + idx nodes nth-unsafe :> n + key hashcode n (pluck-at) :> n' + n n' eq? [ + bitmap-node + ] [ + n' [ + bitmap + n' idx nodes new-nth + shift + + ] [ + bitmap bit eq? [ f ] [ + bitmap bit bitnot bitand + idx nodes remove-nth + shift + ] if - ] + ] if ] if - ] ; + ] if ; M: bitmap-node >alist% ( node -- ) nodes>> >alist-each% ; diff --git a/basis/persistent/hashtables/nodes/collision/collision.factor b/basis/persistent/hashtables/nodes/collision/collision.factor index 2ee4008f2b..3d1612862a 100644 --- a/basis/persistent/hashtables/nodes/collision/collision.factor +++ b/basis/persistent/hashtables/nodes/collision/collision.factor @@ -15,43 +15,39 @@ M:: collision-node (entry-at) ( key hashcode collision-node -- leaf-node ) M:: collision-node (pluck-at) ( key hashcode collision-node -- leaf-node ) hashcode collision-node hashcode>> eq? [ - [let | idx [ key hashcode collision-node find-index drop ] | - idx [ - idx collision-node leaves>> smash [ - collision-node hashcode>> - - ] when - ] [ collision-node ] if - ] + key hashcode collision-node find-index drop :> idx + idx [ + idx collision-node leaves>> smash [ + collision-node hashcode>> + + ] when + ] [ collision-node ] if ] [ collision-node ] if ; M:: collision-node (new-at) ( shift value key hashcode collision-node -- node' added-leaf ) hashcode collision-node hashcode>> eq? [ - key hashcode collision-node find-index - [let | leaf-node [ ] idx [ ] | - idx [ - value leaf-node value>> = [ - collision-node f - ] [ - hashcode - value key hashcode - idx - collision-node leaves>> - new-nth - - f - ] if + key hashcode collision-node find-index :> ( idx leaf-node ) + idx [ + value leaf-node value>> = [ + collision-node f ] [ - [let | new-leaf-node [ value key hashcode ] | - hashcode - collision-node leaves>> - new-leaf-node - suffix - - new-leaf-node - ] + hashcode + value key hashcode + idx + collision-node leaves>> + new-nth + + f ] if - ] + ] [ + value key hashcode :> new-leaf-node + hashcode + collision-node leaves>> + new-leaf-node + suffix + + new-leaf-node + ] if ] [ shift collision-node value key hashcode make-bitmap-node ] if ; diff --git a/basis/persistent/hashtables/nodes/full/full.factor b/basis/persistent/hashtables/nodes/full/full.factor index 5c60c91dca..5a9cc2506d 100644 --- a/basis/persistent/hashtables/nodes/full/full.factor +++ b/basis/persistent/hashtables/nodes/full/full.factor @@ -8,39 +8,37 @@ persistent.hashtables.nodes ; IN: persistent.hashtables.nodes.full M:: full-node (new-at) ( shift value key hashcode full-node -- node' added-leaf ) - [let* | nodes [ full-node nodes>> ] - idx [ hashcode full-node shift>> mask ] - n [ idx nodes nth-unsafe ] | - shift radix-bits + value key hashcode n (new-at) - [let | new-leaf [ ] n' [ ] | - n n' eq? [ - full-node - ] [ - n' idx nodes new-nth shift - ] if - new-leaf - ] - ] ; + full-node nodes>> :> nodes + hashcode full-node shift>> mask :> idx + idx nodes nth-unsafe :> n + + shift radix-bits + value key hashcode n (new-at) :> ( n' new-leaf ) + n n' eq? [ + full-node + ] [ + n' idx nodes new-nth shift + ] if + new-leaf ; M:: full-node (pluck-at) ( key hashcode full-node -- node' ) - [let* | idx [ hashcode full-node shift>> mask ] - n [ idx full-node nodes>> nth ] - n' [ key hashcode n (pluck-at) ] | - n n' eq? [ - full-node + hashcode full-node shift>> mask :> idx + idx full-node nodes>> nth :> n + key hashcode n (pluck-at) :> n' + + n n' eq? [ + full-node + ] [ + n' [ + n' idx full-node nodes>> new-nth + full-node shift>> + ] [ - n' [ - n' idx full-node nodes>> new-nth - full-node shift>> - - ] [ - hashcode full-node shift>> bitpos bitnot full-bitmap-mask bitand - idx full-node nodes>> remove-nth - full-node shift>> - - ] if + hashcode full-node shift>> bitpos bitnot full-bitmap-mask bitand + idx full-node nodes>> remove-nth + full-node shift>> + ] if - ] ; + ] if ; M:: full-node (entry-at) ( key hashcode full-node -- node' ) key hashcode diff --git a/basis/persistent/hashtables/nodes/leaf/leaf.factor b/basis/persistent/hashtables/nodes/leaf/leaf.factor index 94174d5667..0a15ea6305 100644 --- a/basis/persistent/hashtables/nodes/leaf/leaf.factor +++ b/basis/persistent/hashtables/nodes/leaf/leaf.factor @@ -19,10 +19,9 @@ M:: leaf-node (new-at) ( shift value key hashcode leaf-node -- node' added-leaf value leaf-node value>> = [ leaf-node f ] [ value key hashcode f ] if ] [ - [let | new-leaf [ value key hashcode ] | - hashcode leaf-node new-leaf 2array - new-leaf - ] + value key hashcode :> new-leaf + hashcode leaf-node new-leaf 2array + new-leaf ] if ] [ shift leaf-node value key hashcode make-bitmap-node ] if ; diff --git a/basis/persistent/heaps/heaps-docs.factor b/basis/persistent/heaps/heaps-docs.factor index 49852bac4d..31422f23b9 100644 --- a/basis/persistent/heaps/heaps-docs.factor +++ b/basis/persistent/heaps/heaps-docs.factor @@ -18,7 +18,7 @@ HELP: pheap-peek { $description "Gets the object in the heap with minumum priority." } ; HELP: pheap-push -{ $values { "heap" "a persistent heap" } { "value" object } { "prio" "a priority" } { "newheap" "a new persistent heap" } } +{ $values { "value" object } { "prio" "a priority" } { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } } { $description "Creates a new persistent heap also containing the given object of the given priority." } ; HELP: pheap-pop* diff --git a/basis/persistent/vectors/vectors.factor b/basis/persistent/vectors/vectors.factor index 2527959f32..b02604e9bd 100644 --- a/basis/persistent/vectors/vectors.factor +++ b/basis/persistent/vectors/vectors.factor @@ -58,7 +58,7 @@ M: persistent-vector nth-unsafe [ 2array ] [ drop level>> 1 + ] 2bi node boa ; : new-child ( new-child node -- node' expansion/f ) - dup full? [ tuck level>> 1node ] [ node-add f ] if ; + dup full? [ [ level>> 1node ] keep swap ] [ node-add f ] if ; : new-last ( val seq -- seq' ) [ length 1 - ] keep new-nth ; @@ -70,7 +70,7 @@ M: persistent-vector nth-unsafe dup level>> 1 = [ new-child ] [ - tuck children>> last (ppush-new-tail) + [ nip ] 2keep children>> last (ppush-new-tail) [ swap new-child ] [ swap node-set-last f ] ?if ] if ; diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index f919573ea9..04617a6c67 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -116,10 +116,9 @@ M: pathname pprint* : check-recursion ( obj quot -- ) nesting-limit? [ drop - "~" over class name>> "~" 3append - swap present-text + [ class name>> "~" dup surround ] keep present-text ] [ - over recursion-check get memq? [ + over recursion-check get member-eq? [ drop "~circularity~" swap present-text ] [ over recursion-check get push @@ -175,7 +174,7 @@ M: tuple pprint* : pprint-elements ( seq -- ) do-length-limit [ [ pprint* ] each ] dip - [ "~" swap number>string " more~" 3append text ] when* ; + [ number>string "~" " more~" surround text ] when* ; M: quotation pprint-delims drop \ [ \ ] ; M: curry pprint-delims drop \ [ \ ] ; diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor index e17e14f323..bd2c4bd924 100644 --- a/basis/prettyprint/prettyprint-docs.factor +++ b/basis/prettyprint/prettyprint-docs.factor @@ -121,7 +121,7 @@ ARTICLE: "prettyprint-literal" "Literal prettyprinting protocol" " scan-word \\ * assert=" " scan-word" " scan-word \\ ] assert=" - " parsed ;" + " suffix! ;" } "An example literal might be:" { $code "RECT[ 100 * 200 ]" } diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index db3331305e..8ba6e94a49 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -196,7 +196,7 @@ DEFER: parse-error-file " {" " { [ dup continuation? ] [ append ] }" " { [ dup not ] [ drop reverse ] }" - " { [ dup pair? ] [ [ delete ] keep ] }" + " { [ dup pair? ] [ [ remove! drop ] keep ] }" " } cond ;" } ; diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 718de7e84c..6cff399201 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -110,3 +110,7 @@ SYMBOL: pprint-string-cells? ] with-row ] each ] tabular-output nl ; + +: object-table. ( obj alist -- ) + [ [ nip first ] [ second call( obj -- str ) ] 2bi 2array ] with map + simple-table. ; diff --git a/basis/quoted-printable/quoted-printable-tests.factor b/basis/quoted-printable/quoted-printable-tests.factor index e258cb9a96..2a3239c72f 100644 --- a/basis/quoted-printable/quoted-printable-tests.factor +++ b/basis/quoted-printable/quoted-printable-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: tools.test quoted-printable io.encodings.string -sequences io.encodings.8-bit splitting kernel ; +sequences splitting kernel io.encodings.8-bit.latin2 ; IN: quoted-printable.tests [ """José was the diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor index 59df4f6e27..788a6e700a 100755 --- a/basis/random/random-docs.factor +++ b/basis/random/random-docs.factor @@ -96,7 +96,7 @@ HELP: delete-random { $values { "seq" sequence } { "elt" object } } -{ $description "Deletes a random number from a sequence using " { $link delete-nth } " and returns the deleted object." } ; +{ $description "Deletes a random number from a sequence using " { $link remove-nth! } " and returns the deleted object." } ; ARTICLE: "random-protocol" "Random protocol" "A random number generator must implement one of these two words:" diff --git a/basis/random/random.factor b/basis/random/random.factor index 197c232404..bfd107dbb6 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -19,7 +19,7 @@ M: object random-bytes* ( n tuple -- byte-array ) [ pick '[ _ random-32* 4 >le _ push-all ] times ] [ over zero? - [ 2drop ] [ random-32* 4 >le swap head over push-all ] if + [ 2drop ] [ random-32* 4 >le swap head append! ] if ] bi-curry bi* ; M: object random-32* ( tuple -- r ) 4 swap random-bytes* le> ; @@ -82,7 +82,7 @@ PRIVATE> '[ _ dup random _ _ next-sample ] replicate ; : delete-random ( seq -- elt ) - [ length random-integer ] keep [ nth ] 2keep delete-nth ; + [ length random-integer ] keep [ nth ] 2keep remove-nth! drop ; : with-random ( tuple quot -- ) random-generator swap with-variable ; inline diff --git a/basis/regexp/dfa/dfa.factor b/basis/regexp/dfa/dfa.factor index 2de4e8b0e0..fa75232fd5 100644 --- a/basis/regexp/dfa/dfa.factor +++ b/basis/regexp/dfa/dfa.factor @@ -25,7 +25,7 @@ IN: regexp.dfa ] unless ; : epsilon-table ( states nfa -- table ) - [ H{ } clone tuck ] dip + [ [ H{ } clone ] dip over ] dip '[ _ _ t epsilon-loop ] each ; : find-epsilon-closure ( states nfa -- dfa-state ) diff --git a/basis/regexp/disambiguate/disambiguate.factor b/basis/regexp/disambiguate/disambiguate.factor index 876d898cb4..fcde135cf8 100644 --- a/basis/regexp/disambiguate/disambiguate.factor +++ b/basis/regexp/disambiguate/disambiguate.factor @@ -44,12 +44,12 @@ TUPLE: parts in out ; [ _ meaningful-integers ] keep add-out ] map ; -: class-partitions ( classes -- assoc ) - [ integer? ] partition [ - dup powerset-partition spin add-integers - [ [ partition>class ] keep 2array ] map - [ first ] filter - ] [ '[ _ singleton-partition ] map ] 2bi append ; +:: class-partitions ( classes -- assoc ) + classes [ integer? ] partition :> ( integers classes ) + + classes powerset-partition classes integers add-integers + [ [ partition>class ] keep 2array ] map [ first ] filter + integers [ classes singleton-partition ] map append ; : new-transitions ( transitions -- assoc ) ! assoc is class, partition values [ keys ] gather diff --git a/basis/regexp/minimize/minimize.factor b/basis/regexp/minimize/minimize.factor index 1885144e6c..a6eb4f00a2 100644 --- a/basis/regexp/minimize/minimize.factor +++ b/basis/regexp/minimize/minimize.factor @@ -85,7 +85,7 @@ IN: regexp.minimize '[ _ delete-duplicates ] change-transitions ; : combine-state-transitions ( hash -- hash ) - H{ } clone tuck '[ + [ H{ } clone ] dip over '[ _ [ 2array ] change-at ] assoc-each [ swap ] assoc-map ; diff --git a/basis/regexp/nfa/nfa.factor b/basis/regexp/nfa/nfa.factor index a692f70778..35edcf328a 100644 --- a/basis/regexp/nfa/nfa.factor +++ b/basis/regexp/nfa/nfa.factor @@ -46,7 +46,7 @@ GENERIC: nfa-node ( node -- start-state end-state ) epsilon nfa-table get add-transition ; M:: star nfa-node ( node -- start end ) - node term>> nfa-node :> s1 :> s0 + node term>> nfa-node :> ( s0 s1 ) next-state :> s2 next-state :> s3 s1 s0 epsilon-transition diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index ba4aa47e7b..e9a86516ca 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -200,7 +200,7 @@ PRIVATE> : parsing-regexp ( accum end -- accum ) lexer get [ take-until ] [ parse-noblank-token ] bi - compile-next-match parsed ; + compile-next-match suffix! ; PRIVATE> diff --git a/basis/roman/roman-tests.factor b/basis/roman/roman-tests.factor index a510514e23..c7ab7fafd9 100644 --- a/basis/roman/roman-tests.factor +++ b/basis/roman/roman-tests.factor @@ -29,7 +29,7 @@ USING: arrays kernel math roman roman.private sequences tools.test ; [ 3444 ] [ 3444 >roman roman> ] unit-test [ 3999 ] [ 3999 >roman roman> ] unit-test [ 0 >roman ] must-fail -[ 4000 >roman ] must-fail +[ 40000 >roman ] must-fail [ "vi" ] [ "iii" "iii" roman+ ] unit-test [ "viii" ] [ "x" "ii" roman- ] unit-test [ "ix" ] [ "iii" "iii" roman* ] unit-test diff --git a/basis/roman/roman.factor b/basis/roman/roman.factor index 817b6637d6..a645898c03 100644 --- a/basis/roman/roman.factor +++ b/basis/roman/roman.factor @@ -17,7 +17,7 @@ CONSTANT: roman-values ERROR: roman-range-error n ; : roman-range-check ( n -- n ) - dup 1 3999 between? [ roman-range-error ] unless ; + dup 1 10000 between? [ roman-range-error ] unless ; : roman-digit-index ( ch -- n ) 1string roman-digits index ; inline @@ -43,7 +43,7 @@ PRIVATE> : >ROMAN ( n -- str ) >roman >upper ; : roman> ( str -- n ) - >lower [ roman>= ] monotonic-split [ (roman>) ] sigma ; + >lower [ roman>= ] monotonic-split [ (roman>) ] map-sum ; parsed ; +SYNTAX: ROMAN: scan roman> suffix! ; diff --git a/basis/sequences/deep/deep-docs.factor b/basis/sequences/deep/deep-docs.factor index ae9d67e29c..e8b9ddea6d 100755 --- a/basis/sequences/deep/deep-docs.factor +++ b/basis/sequences/deep/deep-docs.factor @@ -30,10 +30,10 @@ HELP: flatten { $values { "obj" object } { "seq" "a sequence" } } { $description "Creates a sequence of all of the leaf nodes (non-sequence nodes, but including strings and numbers) in the object." } ; -HELP: deep-change-each -{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } } -{ $description "Modifies each sub-node of an object in place, in preorder." } -{ $see-also change-each } ; +HELP: deep-map! +{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } { "obj" object } } +{ $description "Modifies each sub-node of an object in place, in preorder, and returns that object." } +{ $see-also map! } ; ARTICLE: "sequences.deep" "Deep sequence combinators" "The combinators in the " { $vocab-link "sequences.deep" } " vocabulary are variants of standard sequence combinators which traverse nested subsequences." @@ -43,7 +43,7 @@ ARTICLE: "sequences.deep" "Deep sequence combinators" deep-filter deep-find deep-any? - deep-change-each + deep-map! } "A utility word to collapse nested subsequences:" { $subsections flatten } ; diff --git a/basis/sequences/deep/deep-tests.factor b/basis/sequences/deep/deep-tests.factor index e26241abc3..63611967b9 100755 --- a/basis/sequences/deep/deep-tests.factor +++ b/basis/sequences/deep/deep-tests.factor @@ -17,7 +17,7 @@ IN: sequences.deep.tests [ "hey" 1array 1array [ change-something ] deep-map ] unit-test [ { { "heyhello" "hihello" } } ] -[ "hey" 1array 1array [ [ change-something ] deep-change-each ] keep ] unit-test +[ "hey" 1array 1array [ change-something ] deep-map! ] unit-test [ t ] [ "foo" [ string? ] deep-any? ] unit-test diff --git a/basis/sequences/deep/deep.factor b/basis/sequences/deep/deep.factor index bfc102fdc2..8e01025b94 100755 --- a/basis/sequences/deep/deep.factor +++ b/basis/sequences/deep/deep.factor @@ -48,10 +48,10 @@ M: object branch? drop f ; _ swap dup branch? [ subseq? ] [ 2drop f ] if ] deep-find >boolean ; -: deep-change-each ( obj quot: ( elt -- elt' ) -- ) +: deep-map! ( obj quot: ( elt -- elt' ) -- obj ) over branch? [ - '[ _ [ call ] keep over [ deep-change-each ] dip ] change-each - ] [ 2drop ] if ; inline recursive + '[ _ [ call ] keep over [ deep-map! drop ] dip ] map! + ] [ drop ] if ; inline recursive : flatten ( obj -- seq ) [ branch? not ] deep-filter ; diff --git a/basis/sequences/generalizations/generalizations-docs.factor b/basis/sequences/generalizations/generalizations-docs.factor new file mode 100644 index 0000000000..7940427e69 --- /dev/null +++ b/basis/sequences/generalizations/generalizations-docs.factor @@ -0,0 +1,46 @@ +! (c)2009 Joe Groff bsd license +USING: help.syntax help.markup kernel sequences quotations +math arrays combinators ; +IN: sequences.generalizations + +HELP: neach +{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- )" } } { "n" integer } } +{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ; + +HELP: nmap +{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } } +{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ; + +HELP: nmap-as +{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } } +{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ; + +HELP: mnmap +{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the first " { $snippet "seq" } } } +{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel and provide any number of output sequences." } ; + +HELP: mnmap-as +{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "n*exemplar" { $snippet "n" } " sequences on the datastack" } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } } +{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel and provide any number of output sequences of distinct types." } ; + +HELP: nproduce +{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "n" integer } { "seq..." { $snippet "n" } " arrays on the datastack" } } +{ $description "A generalization of " { $link produce } " that generates " { $snippet "n" } " arrays in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ; + +HELP: nproduce-as +{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "...exemplar" { $snippet "n" } " sequences on the datastack" } { "n" integer } { "seq..." { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } } +{ $description "A generalization of " { $link produce-as } " that generates " { $snippet "n" } " sequences in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ; + +ARTICLE: "sequences.generalizations" "Generalized sequence iteration combinators" +"The " { $vocab-link "sequences.generalizations" } " vocabulary defines generalized versions of the iteration " { $link "sequences-combinators" } "." +{ $subsections + neach + nmap + nmap-as + mnmap + mnmap-as + nproduce + nproduce-as +} ; + +ABOUT: "sequences.generalizations" diff --git a/basis/sequences/generalizations/generalizations-tests.factor b/basis/sequences/generalizations/generalizations-tests.factor new file mode 100644 index 0000000000..d1861b8f9d --- /dev/null +++ b/basis/sequences/generalizations/generalizations-tests.factor @@ -0,0 +1,120 @@ +! (c)2009 Joe Groff bsd license +USING: tools.test generalizations kernel math arrays sequences +sequences.generalizations ascii fry math.parser io io.streams.string ; +IN: sequences.generalizations.tests + +: neach-test ( a b c d -- ) + [ 4 nappend print ] 4 neach ; +: nmap-test ( a b c d -- e ) + [ 4 nappend ] 4 nmap ; +: nmap-as-test ( a b c d -- e ) + [ 4 nappend ] [ ] 4 nmap-as ; +: mnmap-3-test ( a b c d -- e f g ) + [ append ] 4 3 mnmap ; +: mnmap-2-test ( a b c d -- e f ) + [ [ append ] 2bi@ ] 4 2 mnmap ; +: mnmap-as-test ( a b c d -- e f ) + [ [ append ] 2bi@ ] { } [ ] 4 2 mnmap-as ; +: mnmap-1-test ( a b c d -- e ) + [ 4 nappend ] 4 1 mnmap ; +: mnmap-0-test ( a b c d -- ) + [ 4 nappend print ] 4 0 mnmap ; +: nproduce-as-test ( n -- a b ) + [ dup zero? not ] + [ [ 2 - ] [ ] [ 1 - ] tri ] { } B{ } 2 nproduce-as + [ drop ] 2dip ; +: nproduce-test ( n -- a b ) + [ dup zero? not ] + [ [ 2 - ] [ ] [ 1 - ] tri ] 2 nproduce + [ drop ] 2dip ; + +[ """A1a! +B2b@ +C3c# +D4d$ +""" ] [ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a" "b" "c" "d" } + { "!" "@" "#" "$" } + [ neach-test ] with-string-writer +] unit-test + +[ { "A1a!" "B2b@" "C3c#" "D4d$" } ] +[ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a" "b" "c" "d" } + { "!" "@" "#" "$" } + nmap-test +] unit-test + +[ [ "A1a!" "B2b@" "C3c#" "D4d$" ] ] +[ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a" "b" "c" "d" } + { "!" "@" "#" "$" } + nmap-as-test +] unit-test + +[ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a!" "b@" "c#" "d$" } +] [ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a" "b" "c" "d" } + { "!" "@" "#" "$" } + mnmap-3-test +] unit-test + +[ + { "A1" "B2" "C3" "D4" } + { "a!" "b@" "c#" "d$" } +] [ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a" "b" "c" "d" } + { "!" "@" "#" "$" } + mnmap-2-test +] unit-test + +[ + { "A1" "B2" "C3" "D4" } + [ "a!" "b@" "c#" "d$" ] +] [ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a" "b" "c" "d" } + { "!" "@" "#" "$" } + mnmap-as-test +] unit-test + +[ { "A1a!" "B2b@" "C3c#" "D4d$" } ] +[ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a" "b" "c" "d" } + { "!" "@" "#" "$" } + mnmap-1-test +] unit-test + +[ """A1a! +B2b@ +C3c# +D4d$ +""" ] [ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a" "b" "c" "d" } + { "!" "@" "#" "$" } + [ mnmap-0-test ] with-string-writer +] unit-test + +[ { 10 8 6 4 2 } B{ 9 7 5 3 1 } ] +[ 10 nproduce-as-test ] unit-test + +[ { 10 8 6 4 2 } { 9 7 5 3 1 } ] +[ 10 nproduce-test ] unit-test diff --git a/basis/sequences/generalizations/generalizations.factor b/basis/sequences/generalizations/generalizations.factor new file mode 100644 index 0000000000..210b27f3f3 --- /dev/null +++ b/basis/sequences/generalizations/generalizations.factor @@ -0,0 +1,79 @@ +! (c)2009 Joe Groff bsd license +USING: kernel sequences sequences.private math +combinators macros math.order math.ranges quotations fry effects +memoize.private generalizations ; +IN: sequences.generalizations + +MACRO: nmin-length ( n -- ) + dup 1 - [ min ] n*quot + '[ [ length ] _ napply @ ] ; + +: nnth-unsafe ( n ...seq n -- ) + [ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline +MACRO: nset-nth-unsafe ( n -- ) + [ [ drop ] ] + [ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ] + if-zero ; + +: (neach) ( ...seq quot n -- len quot' ) + dup dup dup + '[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline + +: neach ( ...seq quot n -- ) + (neach) each-integer ; inline + +: nmap-as ( ...seq quot exemplar n -- result ) + '[ _ (neach) ] dip map-integers ; inline + +: nmap ( ...seq quot n -- result ) + dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline + +MACRO: nnew-sequence ( n -- ) + [ [ drop ] ] + [ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ; + +: nnew-like ( len ...exemplar quot n -- result... ) + 5 dupn '[ + _ nover + [ [ _ nnew-sequence ] dip call ] + _ ndip [ like ] + _ apply-curry + _ spread* + ] call ; inline + +MACRO: (ncollect) ( n -- ) + 3 dupn 1 + + '[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ; + +: ncollect ( len quot ...into n -- ) + (ncollect) each-integer ; inline + +: nmap-integers ( len quot ...exemplar n -- result... ) + 4 dupn + '[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline + +: mnmap-as ( m*seq quot n*exemplar m n -- result*n ) + dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline + +: mnmap ( m*seq quot m n -- result*n ) + 2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline + +: naccumulator-for ( quot ...exemplar n -- quot' vec... ) + 5 dupn '[ + [ [ length ] keep new-resizable ] _ napply + [ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep + ] call ; inline + +: naccumulator ( quot n -- quot' vec... ) + [ V{ } swap dupn ] keep naccumulator-for ; inline + +: nproduce-as ( pred quot ...exemplar n -- seq... ) + 7 dupn '[ + _ ndup + [ _ naccumulator-for [ while ] _ ndip ] + _ ncurry _ ndip + [ like ] _ apply-curry _ spread* + ] call ; inline + +: nproduce ( pred quot n -- seq... ) + [ { } swap dupn ] keep nproduce-as ; inline diff --git a/extra/sequences/merged/authors.txt b/basis/sequences/merged/authors.txt similarity index 100% rename from extra/sequences/merged/authors.txt rename to basis/sequences/merged/authors.txt diff --git a/extra/sequences/merged/merged-docs.factor b/basis/sequences/merged/merged-docs.factor similarity index 94% rename from extra/sequences/merged/merged-docs.factor rename to basis/sequences/merged/merged-docs.factor index da0d340126..9b98cd1ed8 100644 --- a/extra/sequences/merged/merged-docs.factor +++ b/basis/sequences/merged/merged-docs.factor @@ -20,7 +20,7 @@ HELP: merged HELP: ( seqs -- merged ) { $values { "seqs" "a sequence of sequences to merge" } { "merged" "a virtual sequence" } } -{ $description "Creates an instance of the " { $link merged } " virtual sequence." } +{ $description "Creates an instance of the " { $link merged } " virtual sequence. The length of the created virtual sequences is the minimum length of the input sequences times the number of input sequences." } { $see-also <2merged> <3merged> merge } ; HELP: <2merged> ( seq1 seq2 -- merged ) diff --git a/extra/sequences/merged/merged-tests.factor b/basis/sequences/merged/merged-tests.factor similarity index 89% rename from extra/sequences/merged/merged-tests.factor rename to basis/sequences/merged/merged-tests.factor index 13a46f0b72..cbd4176bef 100644 --- a/extra/sequences/merged/merged-tests.factor +++ b/basis/sequences/merged/merged-tests.factor @@ -15,3 +15,6 @@ IN: sequences.merged.tests [ 6 ] [ 5 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test [ 4 ] [ 4 { 1 2 } { 3 4 } { 5 6 } 3merge nth ] unit-test + +[ "" ] [ "abcdefg" "" 2merge ] unit-test +[ "a1b2" ] [ "abc" "12" <2merged> "" like ] unit-test diff --git a/extra/sequences/merged/merged.factor b/basis/sequences/merged/merged.factor similarity index 51% rename from extra/sequences/merged/merged.factor rename to basis/sequences/merged/merged.factor index d64da6efe6..c14ccf2f20 100644 --- a/extra/sequences/merged/merged.factor +++ b/basis/sequences/merged/merged.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel math sequences ; +USING: accessors arrays kernel math math.order sequences +sequences.private ; IN: sequences.merged TUPLE: merged seqs ; @@ -10,19 +11,21 @@ C: merged : <3merged> ( seq1 seq2 seq3 -- merged ) 3array ; : merge ( seqs -- seq ) - dup swap first like ; + [ ] keep first like ; : 2merge ( seq1 seq2 -- seq ) - dupd <2merged> swap like ; + [ <2merged> ] 2keep drop like ; : 3merge ( seq1 seq2 seq3 -- seq ) - pick [ <3merged> ] dip like ; + [ <3merged> ] 3keep 2drop like ; -M: merged length seqs>> [ length ] map sum ; +M: merged length + seqs>> [ [ length ] [ min ] map-reduce ] [ length ] bi * ; inline M: merged virtual@ ( n seq -- n' seq' ) - seqs>> [ length /mod ] [ nth ] bi ; + seqs>> [ length /mod ] [ nth-unsafe ] bi ; inline -M: merged virtual-seq ( merged -- seq ) [ ] { } map-as ; +M: merged virtual-exemplar ( merged -- seq ) + seqs>> [ f ] [ first ] if-empty ; inline INSTANCE: merged virtual-sequence diff --git a/extra/sequences/merged/summary.txt b/basis/sequences/merged/summary.txt similarity index 100% rename from extra/sequences/merged/summary.txt rename to basis/sequences/merged/summary.txt diff --git a/extra/sequences/merged/tags.txt b/basis/sequences/merged/tags.txt similarity index 100% rename from extra/sequences/merged/tags.txt rename to basis/sequences/merged/tags.txt diff --git a/basis/sequences/parser/authors.txt b/basis/sequences/parser/authors.txt new file mode 100644 index 0000000000..a07c427c98 --- /dev/null +++ b/basis/sequences/parser/authors.txt @@ -0,0 +1,2 @@ +Daniel Ehrenberg +Doug Coleman diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/basis/sequences/parser/parser-tests.factor similarity index 96% rename from extra/sequence-parser/sequence-parser-tests.factor rename to basis/sequences/parser/parser-tests.factor index af13e5b86e..0c4f1390bb 100644 --- a/extra/sequence-parser/sequence-parser-tests.factor +++ b/basis/sequences/parser/parser-tests.factor @@ -1,6 +1,6 @@ -USING: tools.test sequence-parser unicode.categories kernel +USING: tools.test sequences.parser unicode.categories kernel accessors ; -IN: sequence-parser.tests +IN: sequences.parser.tests [ "hello" ] [ "hello" [ take-rest ] parse-sequence ] unit-test diff --git a/extra/sequence-parser/sequence-parser.factor b/basis/sequences/parser/parser.factor similarity index 99% rename from extra/sequence-parser/sequence-parser.factor rename to basis/sequences/parser/parser.factor index d14a77057f..93bbbdf53d 100644 --- a/extra/sequence-parser/sequence-parser.factor +++ b/basis/sequences/parser/parser.factor @@ -3,7 +3,7 @@ USING: accessors circular combinators.short-circuit fry io kernel locals math math.order sequences sorting.functor sorting.slots unicode.categories ; -IN: sequence-parser +IN: sequences.parser TUPLE: sequence-parser sequence n ; diff --git a/extra/sequences/product/authors.txt b/basis/sequences/product/authors.txt similarity index 100% rename from extra/sequences/product/authors.txt rename to basis/sequences/product/authors.txt diff --git a/extra/sequences/product/product-docs.factor b/basis/sequences/product/product-docs.factor similarity index 100% rename from extra/sequences/product/product-docs.factor rename to basis/sequences/product/product-docs.factor diff --git a/extra/sequences/product/product-tests.factor b/basis/sequences/product/product-tests.factor similarity index 100% rename from extra/sequences/product/product-tests.factor rename to basis/sequences/product/product-tests.factor diff --git a/extra/sequences/product/product.factor b/basis/sequences/product/product.factor similarity index 97% rename from extra/sequences/product/product.factor rename to basis/sequences/product/product.factor index c94e13a673..f783fad312 100644 --- a/extra/sequences/product/product.factor +++ b/basis/sequences/product/product.factor @@ -49,7 +49,7 @@ M: product-sequence nth product@ nths ; :: product-each ( sequences quot -- ) - sequences start-product-iter :> lengths :> ns + sequences start-product-iter :> ( ns lengths ) lengths [ 0 = ] any? [ [ ns lengths end-product-iter? ] [ ns sequences nths quot call ns lengths product-iter ] until diff --git a/extra/sequences/product/summary.txt b/basis/sequences/product/summary.txt similarity index 100% rename from extra/sequences/product/summary.txt rename to basis/sequences/product/summary.txt diff --git a/basis/serialize/serialize-tests.factor b/basis/serialize/serialize-tests.factor index cebf69595f..6dbc76386d 100644 --- a/basis/serialize/serialize-tests.factor +++ b/basis/serialize/serialize-tests.factor @@ -50,7 +50,7 @@ CONSTANT: objects B{ 50 13 55 64 1 } ?{ t f t f f t f } double-array{ 1.0 3.0 4.0 1.0 2.35 0.33 } - << 1 [ 2 ] curry parsed >> + << 1 [ 2 ] curry suffix! >> { { "a" "bc" } { "de" "fg" } } H{ { "a" "bc" } { "de" "fg" } } } diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor index 2b4294bda4..9b4b0ac46b 100644 --- a/basis/serialize/serialize.factor +++ b/basis/serialize/serialize.factor @@ -26,7 +26,7 @@ TUPLE: id obj ; C: id -M: id hashcode* obj>> hashcode* ; +M: id hashcode* nip obj>> identity-hashcode ; M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ; @@ -222,7 +222,7 @@ SYMBOL: deserialized :: (deserialize-seq) ( exemplar quot -- seq ) deserialize-cell exemplar new-sequence [ intern-object ] - [ dup [ drop quot call ] change-each ] bi ; inline + [ [ drop quot call ] map! ] bi ; inline : deserialize-array ( -- array ) { } [ (deserialize) ] (deserialize-seq) ; diff --git a/basis/shuffle/shuffle-docs.factor b/basis/shuffle/shuffle-docs.factor new file mode 100644 index 0000000000..363727a6c5 --- /dev/null +++ b/basis/shuffle/shuffle-docs.factor @@ -0,0 +1,7 @@ +USING: help.markup help.syntax ; +IN: shuffle + +HELP: spin $complex-shuffle ; +HELP: roll $complex-shuffle ; +HELP: -roll $complex-shuffle ; +HELP: tuck $complex-shuffle ; diff --git a/basis/shuffle/shuffle-tests.factor b/basis/shuffle/shuffle-tests.factor index e091af2d06..4165efdcfd 100644 --- a/basis/shuffle/shuffle-tests.factor +++ b/basis/shuffle/shuffle-tests.factor @@ -1,5 +1,10 @@ USING: shuffle tools.test ; +IN: shuffle.tests [ 1 2 3 4 ] [ 3 4 1 2 2swap ] unit-test [ 4 2 3 ] [ 1 2 3 4 shuffle( a b c d -- d b c ) ] unit-test + +[ 2 3 4 1 ] [ 1 2 3 4 roll ] unit-test +[ 1 2 3 4 ] [ 2 3 4 1 -roll ] unit-test + diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index d6a4ba8bbb..0ff41edec6 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -20,7 +20,15 @@ MACRO: shuffle-effect ( effect -- ) ] [ ] make ; SYNTAX: shuffle( - ")" parse-effect parsed \ shuffle-effect parsed ; + ")" parse-effect suffix! \ shuffle-effect suffix! ; + +: tuck ( x y -- y x y ) swap over ; inline deprecated + +: spin ( x y z -- z y x ) swap rot ; inline deprecated + +: roll ( x y z t -- y z t x ) [ rot ] dip swap ; inline deprecated + +: -roll ( x y z t -- t x y z ) swap [ -rot ] dip ; inline deprecated : 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline diff --git a/basis/specialized-arrays/mirrors/mirrors.factor b/basis/specialized-arrays/mirrors/mirrors.factor new file mode 100644 index 0000000000..ee7953b501 --- /dev/null +++ b/basis/specialized-arrays/mirrors/mirrors.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2009 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: mirrors specialized-arrays math.vectors ; +IN: specialized-arrays.mirrors + +INSTANCE: specialized-array enumerated-sequence +INSTANCE: simd-128 enumerated-sequence +INSTANCE: simd-256 enumerated-sequence diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index 423c7ad1ee..bc293b19e0 100755 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -45,7 +45,7 @@ SPECIALIZED-ARRAYS: bool ushort char uint float ulonglong ; [ ushort-array{ 0 0 0 } ] [ 3 ALIEN: 123 100 new-sequence - dup [ drop 0 ] change-each + [ drop 0 ] map! ] unit-test STRUCT: test-struct diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index 67c58987a1..711354d803 100755 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -105,7 +105,7 @@ M: A pprint-delims drop \ A{ \ } ; M: A >pprint-sequence ; SYNTAX: A{ \ } [ >A ] parse-literal ; -SYNTAX: A@ scan-object scan-object parsed ; +SYNTAX: A@ scan-object scan-object suffix! ; INSTANCE: A specialized-array @@ -168,3 +168,7 @@ SYNTAX: SPECIALIZED-ARRAY: "prettyprint" vocab [ "specialized-arrays.prettyprint" require ] when + +"mirrors" vocab [ + "specialized-arrays.mirrors" require +] when diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index 2a20ba74cd..f9ab1ae96c 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -69,6 +69,6 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; pop-literal nip >>abi pop-literal nip >>parameters pop-literal nip >>return - "( callback )" f >>xt + "( callback )" >>xt dup callback-bottom #alien-callback, ; diff --git a/basis/stack-checker/backend/backend-tests.factor b/basis/stack-checker/backend/backend-tests.factor index 48cd10a7ee..b58998cb49 100644 --- a/basis/stack-checker/backend/backend-tests.factor +++ b/basis/stack-checker/backend/backend-tests.factor @@ -1,17 +1,21 @@ USING: stack-checker.backend tools.test kernel namespaces -stack-checker.state sequences ; +stack-checker.state stack-checker.values sequences assocs ; IN: stack-checker.backend.tests [ ] [ V{ } clone \ meta-d set V{ } clone \ meta-r set V{ } clone \ literals set - 0 d-in set + H{ } clone known-values set + 0 input-count set ] unit-test [ 0 ] [ 0 ensure-d length ] unit-test [ 2 ] [ 2 ensure-d length ] unit-test + +[ t ] [ meta-d [ known-values get at input-parameter? ] all? ] unit-test + [ 2 ] [ meta-d length ] unit-test [ 3 ] [ 3 ensure-d length ] unit-test diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 5411c885ad..b2a99f0731 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -5,15 +5,19 @@ parser sequences strings vectors words quotations effects classes continuations assocs combinators compiler.errors accessors math.order definitions sets hints macros stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values -stack-checker.recursive-state summary ; +stack-checker.recursive-state stack-checker.dependencies summary ; IN: stack-checker.backend : push-d ( obj -- ) meta-d push ; +: introduce-values ( values -- ) + [ [ [ input-parameter ] dip set-known ] each ] + [ length input-count +@ ] + [ #introduce, ] + tri ; + : pop-d ( -- obj ) - meta-d [ - dup 1array #introduce, d-in inc - ] [ pop ] if-empty ; + meta-d [ dup 1array introduce-values ] [ pop ] if-empty ; : peek-d ( -- obj ) pop-d dup push-d ; @@ -24,7 +28,7 @@ IN: stack-checker.backend meta-d 2dup length > [ 2dup [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri - [ length d-in +@ ] [ #introduce, ] [ meta-d push-all ] tri + [ introduce-values ] [ meta-d push-all ] bi meta-d push-all ] when swap tail* ; diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index 8b0665aa49..99e5a70409 100755 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -11,7 +11,7 @@ IN: stack-checker.branches SYMBOLS: +bottom+ +top+ ; -: unify-inputs ( max-d-in d-in meta-d -- new-meta-d ) +: unify-inputs ( max-input-count input-count meta-d -- new-meta-d ) ! Introduced values can be anything, and don't unify with ! literals. dup [ [ - +top+ ] dip append ] [ 3drop f ] if ; @@ -24,7 +24,7 @@ SYMBOLS: +bottom+ +top+ ; '[ _ +bottom+ pad-head ] map ] unless ; -: phi-inputs ( max-d-in pairs -- newseq ) +: phi-inputs ( max-input-count pairs -- newseq ) dup empty? [ nip ] [ swap '[ [ _ ] dip first2 unify-inputs ] map pad-with-bottom @@ -61,9 +61,9 @@ SYMBOL: quotations branch-variable ; : datastack-phi ( seq -- phi-in phi-out ) - [ d-in branch-variable ] [ \ meta-d active-variable ] bi + [ input-count branch-variable ] [ \ meta-d active-variable ] bi unify-branches - [ d-in set ] [ ] [ dup >vector \ meta-d set ] tri* ; + [ input-count set ] [ ] [ dup >vector \ meta-d set ] tri* ; : terminated-phi ( seq -- terminated ) terminated? branch-variable ; @@ -80,7 +80,7 @@ SYMBOL: quotations : copy-inference ( -- ) \ meta-d [ clone ] change literals [ clone ] change - d-in [ ] change ; + input-count [ ] change ; GENERIC: infer-branch ( literal -- namespace ) diff --git a/basis/stack-checker/dependencies/authors.txt b/basis/stack-checker/dependencies/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/stack-checker/dependencies/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/stack-checker/state/state-tests.factor b/basis/stack-checker/dependencies/dependencies-tests.factor similarity index 53% rename from basis/stack-checker/state/state-tests.factor rename to basis/stack-checker/dependencies/dependencies-tests.factor index a4dea993c0..9bcec64033 100644 --- a/basis/stack-checker/state/state-tests.factor +++ b/basis/stack-checker/dependencies/dependencies-tests.factor @@ -1,5 +1,5 @@ -IN: stack-checker.state.tests -USING: tools.test stack-checker.state words kernel namespaces +IN: stack-checker.dependencies.tests +USING: tools.test stack-checker.dependencies words kernel namespaces definitions ; : computing-dependencies ( quot -- dependencies ) @@ -28,3 +28,10 @@ SYMBOL: b b inlined-dependency depends-on ] computing-dependencies ] unit-test + +[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test +[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test +[ inlined-dependency ] [ flushed-dependency inlined-dependency strongest-dependency ] unit-test +[ inlined-dependency ] [ called-dependency inlined-dependency strongest-dependency ] unit-test +[ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test +[ called-dependency ] [ called-dependency f strongest-dependency ] unit-test diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor new file mode 100644 index 0000000000..f0c77b8398 --- /dev/null +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs classes.algebra fry kernel math namespaces +sequences words ; +IN: stack-checker.dependencies + +! Words that the current quotation depends on +SYMBOL: dependencies + +SYMBOLS: inlined-dependency flushed-dependency called-dependency ; + +: index>= ( obj1 obj2 seq -- ? ) + [ index ] curry bi@ >= ; + +: dependency>= ( how1 how2 -- ? ) + { called-dependency flushed-dependency inlined-dependency } + index>= ; + +: strongest-dependency ( how1 how2 -- how ) + [ called-dependency or ] bi@ [ dependency>= ] most ; + +: depends-on ( word how -- ) + over primitive? [ 2drop ] [ + dependencies get dup [ + swap '[ _ strongest-dependency ] change-at + ] [ 3drop ] if + ] if ; + +! Generic words that the current quotation depends on +SYMBOL: generic-dependencies + +: ?class-or ( class/f class -- class' ) + swap [ class-or ] when* ; + +: depends-on-generic ( generic class -- ) + generic-dependencies get dup + [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ; diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor index 5da5197700..4b432e733f 100755 --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -12,10 +12,10 @@ HELP: do-not-compile } } ; -HELP: literal-expected -{ $error-description "Thrown when inference encounters a combinator or macro being applied to a value which is not known to be a literal, or constructed in a manner which can be analyzed statically. Such code needs changes before it can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." } +HELP: unknown-macro-input +{ $error-description "Thrown when inference encounters a combinator or macro being applied to an input parameter of a non-" { $link POSTPONE: inline } " word. The word needs to be declared " { $link POSTPONE: inline } " before its callers can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." } { $examples - "In this example, the words being defined cannot be called, because they fail to compile with a " { $link literal-expected } " error:" + "In this example, the words being defined cannot be called, because they fail to compile with a " { $link unknown-macro-input } " error:" { $code ": bad-example ( quot -- )" " [ call ] [ call ] bi ;" @@ -41,6 +41,27 @@ HELP: literal-expected } } ; +HELP: bad-macro-input +{ $error-description "Thrown when inference encounters a combinator or macro being applied to a value which is not known at compile time. Such code needs changes before it can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." } +{ $examples + "In this example, the words being defined cannot be called, because they fail to compile with a " { $link bad-macro-input } " error:" + { $code + ": bad-example ( quot -- )" + " [ . ] append call ; inline" + "" + ": usage ( -- )" + " 2 2 [ + ] bad-example ;" + } + "One fix is to use " { $link compose } " instead of " { $link append } ":" + { $code + ": good-example ( quot -- )" + " [ . ] compose call ; inline" + "" + ": usage ( -- )" + " 2 2 [ + ] good-example ;" + } +} ; + HELP: unbalanced-branches-error { $values { "in" "a sequence of integers" } { "out" "a sequence of integers" } } { $description "Throws an " { $link unbalanced-branches-error } "." } @@ -121,7 +142,8 @@ ARTICLE: "inference-errors" "Stack checker errors" "Errors thrown when insufficient information is available to calculate the stack effect of a call to a combinator or macro (see " { $link "inference-combinators" } "):" { $subsections do-not-compile - literal-expected + unknown-macro-input + bad-macro-input } "Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:" { $subsections effect-error } diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index b1071df708..d476de84c5 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel stack-checker.values ; IN: stack-checker.errors TUPLE: inference-error ; ERROR: do-not-compile < inference-error word ; -ERROR: literal-expected < inference-error what ; +ERROR: bad-macro-input < inference-error macro ; + +ERROR: unknown-macro-input < inference-error macro ; ERROR: unbalanced-branches-error < inference-error branches quots ; @@ -31,8 +32,6 @@ ERROR: inconsistent-recursive-call-error < inference-error word ; ERROR: unknown-primitive-error < inference-error ; -ERROR: transform-expansion-error < inference-error word error ; +ERROR: transform-expansion-error < inference-error error continuation word ; -ERROR: bad-declaration-error < inference-error declaration ; - -M: object (literal) "literal value" literal-expected ; \ No newline at end of file +ERROR: bad-declaration-error < inference-error declaration ; \ No newline at end of file diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index 5be5722c23..eef35b61cd 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -4,10 +4,11 @@ USING: accessors kernel prettyprint io debugger sequences assocs stack-checker.errors summary effects ; IN: stack-checker.errors.prettyprint -M: literal-expected summary - what>> "Got a computed value where a " " was expected" surround ; +M: unknown-macro-input summary + macro>> name>> "Cannot apply “" "” to an input parameter of a non-inline word" surround ; -M: literal-expected error. summary print ; +M: bad-macro-input summary + macro>> name>> "Cannot apply “" "” to a run-time computed value" surround ; M: unbalanced-branches-error summary drop "Unbalanced branches" ; @@ -56,7 +57,10 @@ M: transform-expansion-error summary word>> name>> "Macro expansion of " " threw an error" surround ; M: transform-expansion-error error. - [ summary print ] [ error>> error. ] bi ; + [ summary print ] + [ nl "The error was:" print error>> error. nl ] + [ continuation>> traceback-link. ] + tri ; M: do-not-compile summary word>> name>> "Cannot compile call to " prepend ; \ No newline at end of file diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index c99e0f0252..38ac2b0e71 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -10,6 +10,7 @@ stack-checker.visitor stack-checker.backend stack-checker.branches stack-checker.known-words +stack-checker.dependencies stack-checker.recursive-state ; IN: stack-checker.inlining @@ -28,8 +29,6 @@ fixed-point introductions loop? ; -M: inline-recursive hashcode* id>> hashcode* ; - : inlined-block? ( word -- ? ) "inlined-block" word-prop ; : ( word -- label ) @@ -81,7 +80,7 @@ SYMBOL: enter-out bi ; : recursive-word-inputs ( label -- n ) - entry-stack-height d-in get + ; + entry-stack-height input-count get + ; : (inline-recursive-word) ( word -- label in out visitor terminated? ) dup prepare-stack diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 8cddac5a75..3be5244231 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -13,7 +13,7 @@ words.private definitions assocs summary compiler.units system.private combinators combinators.short-circuit locals locals.backend locals.types combinators.private stack-checker.values generic.single generic.single.private -alien.libraries +alien.libraries tools.dispatch.private tools.profiler.private stack-checker.alien stack-checker.state stack-checker.errors @@ -21,6 +21,7 @@ stack-checker.visitor stack-checker.backend stack-checker.branches stack-checker.transforms +stack-checker.dependencies stack-checker.recursive-state ; IN: stack-checker.known-words @@ -43,7 +44,6 @@ IN: stack-checker.known-words { swapd (( x y z -- y x z )) } { nip (( x y -- y )) } { 2nip (( x y z -- z )) } - { tuck (( x y -- y x y )) } { over (( x y -- x y x )) } { pick (( x y z -- x y z x )) } { swap (( x y -- y x )) } @@ -98,8 +98,8 @@ M: composed infer-call* 1 infer->r infer-call terminated? get [ 1 infer-r> infer-call ] unless ; -M: object infer-call* - "literal quotation" literal-expected ; +M: input-parameter infer-call* \ call unknown-macro-input ; +M: object infer-call* \ call bad-macro-input ; : infer-ndip ( word n -- ) [ literals get ] 2dip @@ -192,17 +192,17 @@ M: bad-executable summary \ load-local [ infer-load-local ] "special" set-word-prop -: infer-get-local ( -- ) - [let* | n [ pop-literal nip 1 swap - ] - in-r [ n consume-r ] - out-d [ in-r first copy-value 1array ] - out-r [ in-r copy-values ] | - out-d output-d - out-r output-r - f out-d in-r out-r - out-r in-r zip out-d first in-r first 2array suffix - #shuffle, - ] ; +:: infer-get-local ( -- ) + pop-literal nip 1 swap - :> n + n consume-r :> in-r + in-r first copy-value 1array :> out-d + in-r copy-values :> out-r + + out-d output-d + out-r output-r + f out-d in-r out-r + out-r in-r zip out-d first in-r first 2array suffix + #shuffle, ; \ get-local [ infer-get-local ] "special" set-word-prop @@ -231,7 +231,7 @@ M: bad-executable summary \ alien-callback [ infer-alien-callback ] "special" set-word-prop : infer-special ( word -- ) - "special" word-prop call( -- ) ; + [ current-word set ] [ "special" word-prop call( -- ) ] bi ; : infer-local-reader ( word -- ) (( -- value )) apply-word/effect ; @@ -501,16 +501,14 @@ M: bad-executable summary \ compact-gc { } { } define-primitive -\ gc-stats { } { array } define-primitive - \ (save-image) { byte-array } { } define-primitive \ (save-image-and-exit) { byte-array } { } define-primitive -\ data-room { } { integer integer array } define-primitive +\ data-room { } { byte-array } define-primitive \ data-room make-flushable -\ code-room { } { integer integer integer integer } define-primitive +\ code-room { } { byte-array } define-primitive \ code-room make-flushable \ micros { } { integer } define-primitive @@ -594,7 +592,7 @@ M: bad-executable summary \ set-alien-double { float c-ptr integer } { } define-primitive -\ alien-cell { c-ptr integer } { simple-c-ptr } define-primitive +\ alien-cell { c-ptr integer } { pinned-c-ptr } define-primitive \ alien-cell make-flushable \ set-alien-cell { c-ptr c-ptr integer } { } define-primitive @@ -625,11 +623,7 @@ M: bad-executable summary \ { integer object } { array } define-primitive \ make-flushable -\ begin-scan { } { } define-primitive - -\ next-object { } { object } define-primitive - -\ end-scan { } { } define-primitive +\ all-instances { } { array } define-primitive \ size { object } { fixnum } define-primitive \ size make-flushable @@ -701,21 +695,24 @@ M: bad-executable summary \ unimplemented { } { } define-primitive -\ gc-reset { } { } define-primitive - -\ gc-stats { } { array } define-primitive - \ jit-compile { quotation } { } define-primitive \ lookup-method { object array } { word } define-primitive \ reset-dispatch-stats { } { } define-primitive -\ dispatch-stats { } { array } define-primitive -\ reset-inline-cache-stats { } { } define-primitive -\ inline-cache-stats { } { array } define-primitive +\ dispatch-stats { } { byte-array } define-primitive \ optimized? { word } { object } define-primitive \ strip-stack-traces { } { } define-primitive \ { word } { alien } define-primitive + +\ enable-gc-events { } { } define-primitive +\ disable-gc-events { } { object } define-primitive + +\ profiling { object } { } define-primitive + +\ (identity-hashcode) { object } { fixnum } define-primitive + +\ compute-identity-hashcode { object } { } define-primitive diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 97155bc6d9..cc4a688f7a 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -21,16 +21,19 @@ $nl { $example "[ 2 + ] infer." "( object -- object )" } ; ARTICLE: "inference-combinators" "Combinator stack effects" -"If a word, call it " { $snippet "W" } ", calls a combinator, one of the following two conditions must hold:" +"If a word calls a combinator, one of the following two conditions must hold for the stack checker to succeed:" { $list - { "The combinator may be called with a quotation that is either a literal, or built from literals, " { $link curry } " and " { $link compose } "." } - { "The combinator must be called on an input parameter, or be built from input parameters, literals, " { $link curry } " and " { $link compose } ", " { $strong "if" } " the word " { $snippet "W" } " must be declared " { $link POSTPONE: inline } ". Then " { $snippet "W" } " is itself considered to be a combinator, and its callers must satisfy one of these two conditions." } + { "The combinator must be called with a quotation that is either literal or built from literal quotations, " { $link curry } ", and " { $link compose } ". (Note that quotations that use " { $vocab-link "fry" } " or " { $vocab-link "locals" } " use " { $link curry } " and " { $link compose } " from the perspective of the stack checker.)" } + { "If the word is declared " { $link POSTPONE: inline } ", the combinator may additionally be called on one of the word's input parameters or with quotations built from the word's input parameters, literal quotations, " { $link curry } ", and " { $link compose } ". When inline, a word is itself considered to be a combinator, and its callers must in turn satisfy these conditions." } } -"If neither condition holds, the stack checker throws a " { $link literal-expected } " error, and an escape hatch such as " { $link POSTPONE: call( } " must be used instead. See " { $link "inference-escape" } " for details. An inline combinator can be called with an unknown quotation by currying the quotation onto a literal quotation that uses " { $link POSTPONE: call( } "." +"If neither condition holds, the stack checker throws a " { $link unknown-macro-input } " or " { $link bad-macro-input } " error. To make the code compile, a runtime checking combinator such as " { $link POSTPONE: call( } " must be used instead. See " { $link "inference-escape" } " for details. An inline combinator can be called with an unknown quotation by " { $link curry } "ing the quotation onto a literal quotation that uses " { $link POSTPONE: call( } "." { $heading "Examples" } { $subheading "Calling a combinator" } "The following usage of " { $link map } " passes the stack checker, because the quotation is the result of " { $link curry } ":" -{ $example "[ [ + ] curry map ] infer." "( object object -- object )" } +{ $example "USING: math sequences ;" "[ [ + ] curry map ] infer." "( object object -- object )" } +"The equivalent code using " { $vocab-link "fry" } " and " { $vocab-link "locals" } " likewise passes the stack checker:" +{ $example "USING: fry math sequences ;" "[ '[ _ + ] map ] infer." "( object object -- object )" } +{ $example "USING: locals math sequences ;" "[| a | [ a + ] map ] infer." "( object object -- object )" } { $subheading "Defining an inline combinator" } "The following word calls a quotation twice; the word is declared " { $link POSTPONE: inline } ", since it invokes " { $link call } " on the result of " { $link compose } " on an input parameter:" { $code ": twice ( value quot -- result ) dup compose call ; inline" } @@ -48,15 +51,15 @@ ARTICLE: "inference-combinators" "Combinator stack effects" "However this fails to pass the stack checker since there is no guarantee the quotation has the right stack effect for " { $link map } ". It can be wrapped in a new quotation with a declaration:" { $code ": perform ( values action -- results )" " quot>> [ call( value -- result ) ] curry map ;" } { $heading "Explanation" } -"This restriction exists because without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the stack checker encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised." +"This restriction exists because without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the stack checker encounters a " { $link call } " without further information, a " { $link unknown-macro-input } " or " { $link bad-macro-input } " error is raised." $nl "On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point." { $heading "Limitations" } -"Passing a literal quotation on the data stack through an inlined recursive combinator nullifies its literal status. For example, the following will not infer:" +"The stack checker cannot guarantee that a literal quotation is still literal if it is passed on the data stack to an inlined recursive combinator such as " { $link each } " or " { $link map } ". For example, the following will not infer:" { $example - "[ [ reverse ] swap [ reverse ] map swap call ] infer." "Got a computed value where a literal quotation was expected" + "[ [ reverse ] swap [ reverse ] map swap call ] infer." "Cannot apply “call” to a run-time computed value\nmacro call" } -"To make this work, pass the quotation on the retain stack instead:" +"To make this work, use " { $link dip } " to pass the quotation instead:" { $example "[ [ reverse ] [ [ reverse ] map ] dip call ] infer." "( object -- object )" } ; @@ -74,7 +77,7 @@ $nl "Combinators which are recursive require additional care. In addition to being declared " { $link POSTPONE: inline } ", they must be declared " { $link POSTPONE: recursive } ". There are three restrictions that only apply to combinators with this declaration:" { $heading "Input quotation declaration" } "Input parameters which are quotations must be annotated as much in the stack effect. For example, the following will not infer:" -{ $example ": bad ( quot -- ) [ call ] keep bad ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected" } +{ $unchecked-example ": bad ( quot -- ) [ call ] keep bad ; inline recursive" "[ [ ] bad ] infer." "Cannot apply “call” to a run-time computed value\nmacro call" } "The following is correct:" { $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" } "The effect of the nested quotation itself is only present for documentation purposes; the mere presence of a nested effect is sufficient to mark that value as a quotation parameter." @@ -82,7 +85,7 @@ $nl "The stack checker does not trace data flow in two instances." $nl "An inline recursive word cannot pass a quotation on the data stack through the recursive call. For example, the following will not infer:" -{ $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Got a computed value where a literal quotation was expected" } +{ $unchecked-example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Cannot apply “call” to a run-time computed value\nmacro call" } "However a small change can be made:" { $example ": good ( ? quot: ( ? -- ) -- ) [ good ] 2keep [ not ] dip call ; inline recursive" "[ [ drop ] good ] infer." "( object -- )" } "An inline recursive word must have a fixed stack effect in its base case. The following will not infer:" diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 8fee8df538..7ee7b8e0dd 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -7,7 +7,7 @@ sorting assocs definitions prettyprint io inspector classes.tuple classes.union classes.predicate debugger threads.private io.streams.string io.timeouts io.thread sequences.private destructors combinators eval locals.backend -system compiler.units ; +system compiler.units shuffle ; IN: stack-checker.tests [ 1234 infer ] must-fail @@ -16,14 +16,18 @@ IN: stack-checker.tests { 1 2 } [ dup ] must-infer-as { 1 2 } [ [ dup ] call ] must-infer-as -[ [ call ] infer ] must-fail +[ [ call ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with +[ [ curry call ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with +[ [ { } >quotation call ] infer ] [ T{ bad-macro-input f call } = ] must-fail-with +[ [ append curry call ] infer ] [ T{ bad-macro-input f call } = ] must-fail-with { 2 4 } [ 2dup ] must-infer-as { 1 0 } [ [ ] [ ] if ] must-infer-as -[ [ if ] infer ] must-fail -[ [ [ ] if ] infer ] must-fail -[ [ [ 2 ] [ ] if ] infer ] must-fail +[ [ if ] infer ] [ T{ unknown-macro-input f if } = ] must-fail-with +[ [ { } >quotation { } >quotation if ] infer ] [ T{ bad-macro-input f if } = ] must-fail-with +[ [ [ ] if ] infer ] [ T{ unknown-macro-input f if } = ] must-fail-with +[ [ [ 2 ] [ ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with { 4 3 } [ [ rot ] [ -rot ] if ] must-infer-as { 4 3 } [ @@ -46,7 +50,7 @@ IN: stack-checker.tests [ [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer -] must-fail +] [ T{ bad-macro-input f call } = ] must-fail-with ! Test inference of termination of control flow : termination-test-1 ( -- * ) "foo" throw ; @@ -198,42 +202,42 @@ DEFER: blah4 ! This used to hang [ [ [ dup call ] dup call ] infer ] -[ inference-error? ] must-fail-with +[ recursive-quotation-error? ] must-fail-with : m ( q -- ) dup call ; inline -[ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with +[ [ [ m ] m ] infer ] [ recursive-quotation-error? ] must-fail-with : m' ( quot -- ) dup curry call ; inline -[ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with +[ [ [ m' ] m' ] infer ] [ recursive-quotation-error? ] must-fail-with : m'' ( -- q ) [ dup curry ] ; inline : m''' ( -- ) m'' call call ; inline -[ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with +[ [ [ m''' ] m''' ] infer ] [ recursive-quotation-error? ] must-fail-with -: m-if ( a b c -- ) t over if ; inline +: m-if ( a b c -- ) t over when ; inline -[ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with +[ [ [ m-if ] m-if ] infer ] [ recursive-quotation-error? ] must-fail-with ! This doesn't hang but it's also an example of the ! undedicable case [ [ [ [ drop 3 ] swap call ] dup call ] infer ] -[ inference-error? ] must-fail-with +[ recursive-quotation-error? ] must-fail-with -[ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with +[ [ 1 drop-locals ] infer ] [ too-many-r>? ] must-fail-with ! Regression -[ [ cleave ] infer ] [ inference-error? ] must-fail-with +[ [ cleave ] infer ] [ T{ unknown-macro-input f cleave } = ] must-fail-with ! Test some curry stuff { 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as { 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as -[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail +[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] [ unbalanced-branches-error? ] must-fail-with { 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as @@ -304,7 +308,7 @@ ERROR: custom-error ; ] unit-test ! Regression -[ [ 1 load-locals ] infer ] must-fail +[ [ 1 load-locals ] infer ] [ too-many->r? ] must-fail-with ! Corner case [ [ [ f dup ] [ dup ] produce ] infer ] must-fail @@ -319,7 +323,7 @@ FORGET: erg's-inference-bug [ [ bad-recursion-3 ] infer ] must-fail FORGET: bad-recursion-3 -: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive +: bad-recursion-4 ( -- ) 4 [ dup call [ rot ] dip swap ] times ; inline recursive [ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail : bad-recursion-5 ( obj quot: ( -- ) -- ) dup call swap bad-recursion-5 ; inline recursive @@ -329,6 +333,8 @@ FORGET: bad-recursion-3 dup bad-recursion-6 call ; inline recursive [ [ [ drop f ] bad-recursion-6 ] infer ] must-fail +[ ] [ [ \ bad-recursion-6 forget ] with-compilation-unit ] unit-test + { 3 0 } [ [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as { 2 0 } [ drop f f [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as @@ -346,6 +352,9 @@ DEFER: eee' [ [ eee' ] infer ] [ inference-error? ] must-fail-with +[ ] [ [ \ ddd' forget ] with-compilation-unit ] unit-test +[ ] [ [ \ eee' forget ] with-compilation-unit ] unit-test + : bogus-error ( x -- ) dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive @@ -367,9 +376,9 @@ DEFER: eee' [ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test [ forget-test ] must-infer -[ [ cond ] infer ] must-fail -[ [ bi ] infer ] must-fail -[ at ] must-infer +[ [ cond ] infer ] [ T{ unknown-macro-input f cond } = ] must-fail-with +[ [ bi ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with +[ [ each ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with [ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer @@ -380,5 +389,5 @@ DEFER: eee' { 3 1 } [ call( a b -- c ) ] must-infer-as { 3 1 } [ execute( a b -- c ) ] must-infer-as -[ [ call-effect ] infer ] must-fail -[ [ execute-effect ] infer ] must-fail +[ [ call-effect ] infer ] [ T{ unknown-macro-input f call-effect } = ] must-fail-with +[ [ execute-effect ] infer ] [ T{ unknown-macro-input f execute-effect } = ] must-fail-with diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index a76d302a7e..1c527abfe4 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -2,14 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs arrays namespaces sequences kernel definitions math effects accessors words fry classes.algebra -compiler.units stack-checker.values stack-checker.visitor ; +compiler.units stack-checker.values stack-checker.visitor +stack-checker.errors ; IN: stack-checker.state ! Did the current control-flow path throw an error? SYMBOL: terminated? ! Number of inputs current word expects from the stack -SYMBOL: d-in +SYMBOL: input-count DEFER: commit-literals @@ -34,33 +35,13 @@ SYMBOL: literals [ [ (push-literal) ] each ] [ delete-all ] bi ] unless-empty ; -: current-stack-height ( -- n ) meta-d length d-in get - ; +: current-stack-height ( -- n ) meta-d length input-count get - ; : current-effect ( -- effect ) - d-in get meta-d length terminated? get effect boa ; + input-count get meta-d length terminated? get effect boa ; : init-inference ( -- ) terminated? off V{ } clone \ meta-d set V{ } clone literals set - 0 d-in set ; - -! Words that the current quotation depends on -SYMBOL: dependencies - -: depends-on ( word how -- ) - over primitive? [ 2drop ] [ - dependencies get dup [ - swap '[ _ strongest-dependency ] change-at - ] [ 3drop ] if - ] if ; - -! Generic words that the current quotation depends on -SYMBOL: generic-dependencies - -: ?class-or ( class/f class -- class' ) - swap [ class-or ] when* ; - -: depends-on-generic ( generic class -- ) - generic-dependencies get dup - [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ; + 0 input-count set ; diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index 843083bd52..bbe3cb2ed9 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -1,15 +1,9 @@ IN: stack-checker.transforms.tests USING: sequences stack-checker.transforms tools.test math kernel -quotations stack-checker stack-checker.errors accessors combinators words arrays -classes classes.tuple ; +quotations stack-checker stack-checker.errors accessors +combinators words arrays classes classes.tuple macros ; -: compose-n ( quot n -- ) "OOPS" throw ; - -<< -: compose-n-quot ( n word -- quot' ) >quotation ; -\ compose-n [ compose-n-quot ] 2 define-transform -\ compose-n t "no-compile" set-word-prop ->> +MACRO: compose-n ( n word -- quot' ) >quotation ; : compose-n-test ( a b c -- x ) 2 \ + compose-n ; @@ -64,14 +58,16 @@ DEFER: smart-combo ( quot -- ) [ [ [ "a" "b" ] very-smart-combo "c" ] very-smart-combo ] must-infer ! Caveat found by Doug -DEFER: curry-folding-test ( quot -- ) - -\ curry-folding-test [ length \ drop >quotation ] 1 define-transform +MACRO: curry-folding-test ( quot -- ) + length \ drop >quotation ; { 3 0 } [ [ 1 2 3 ] curry-folding-test ] must-infer-as { 3 0 } [ 1 [ 2 3 ] curry curry-folding-test ] must-infer-as { 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as +[ [ curry curry-folding-test ] infer ] +[ T{ unknown-macro-input f curry-folding-test } = ] must-fail-with + : member?-test ( a -- ? ) { 1 2 3 10 7 58 } member? ; [ f ] [ 1.0 member?-test ] unit-test @@ -82,4 +78,8 @@ DEFER: curry-folding-test ( quot -- ) \ bad-macro [ "OOPS" throw ] 0 define-transform -[ [ bad-macro ] infer ] [ inference-error? ] must-fail-with \ No newline at end of file +[ [ bad-macro ] infer ] [ f >>continuation T{ transform-expansion-error f "OOPS" f bad-macro } = ] must-fail-with + +MACRO: two-params ( a b -- c ) + 1quotation ; + +[ [ 3 two-params ] infer ] [ T{ unknown-macro-input f two-params } = ] must-fail-with \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 11534c58f9..3fdf29b85e 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -7,40 +7,49 @@ classes.tuple.private effects summary hashtables classes sets definitions generic.standard slots.private continuations locals sequences.private generalizations stack-checker.backend stack-checker.state stack-checker.visitor stack-checker.errors -stack-checker.values stack-checker.recursive-state ; +stack-checker.values stack-checker.recursive-state +stack-checker.dependencies ; IN: stack-checker.transforms -: call-transformer ( word stack quot -- newquot ) - '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ] - [ transform-expansion-error ] +: call-transformer ( stack quot -- newquot ) + '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi ] + [ error-continuation get current-word get transform-expansion-error ] recover ; -:: ((apply-transform)) ( word quot values stack rstate -- ) - rstate recursive-state - [ word stack quot call-transformer ] with-variable - [ - values [ length meta-d shorten-by ] [ #drop, ] bi - rstate infer-quot - ] [ word infer-word ] if* ; +:: ((apply-transform)) ( quot values stack rstate -- ) + rstate recursive-state [ stack quot call-transformer ] with-variable + values [ length meta-d shorten-by ] [ #drop, ] bi + rstate infer-quot ; -: literals? ( values -- ? ) [ literal-value? ] all? ; +: literal-values? ( values -- ? ) [ literal-value? ] all? ; -: (apply-transform) ( word quot n -- ) - ensure-d dup literals? [ - dup empty? [ dup recursive-state get ] [ - [ ] - [ [ literal value>> ] map ] - [ first literal recursion>> ] tri - ] if - ((apply-transform)) - ] [ 2drop infer-word ] if ; +: input-values? ( values -- ? ) + [ { [ literal-value? ] [ input-value? ] } 1|| ] all? ; + +: (apply-transform) ( quot n -- ) + ensure-d { + { [ dup literal-values? ] [ + dup empty? [ dup recursive-state get ] [ + [ ] + [ [ literal value>> ] map ] + [ first literal recursion>> ] tri + ] if + ((apply-transform)) + ] } + { [ dup input-values? ] [ drop current-word get unknown-macro-input ] } + [ drop current-word get bad-macro-input ] + } cond ; : apply-transform ( word -- ) - [ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri + [ current-word set ] + [ "transform-quot" word-prop ] + [ "transform-n" word-prop ] tri (apply-transform) ; : apply-macro ( word -- ) - [ ] [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] tri + [ current-word set ] + [ "macro" word-prop ] + [ "declared-effect" word-prop in>> length ] tri (apply-transform) ; : define-transform ( word quot n -- ) diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor index 19db441381..7e11ec3edb 100644 --- a/basis/stack-checker/values/values.factor +++ b/basis/stack-checker/values/values.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors namespaces kernel assocs sequences -stack-checker.recursive-state ; +stack-checker.recursive-state stack-checker.errors ; IN: stack-checker.values ! Values @@ -28,21 +28,25 @@ SYMBOL: known-values GENERIC: (literal-value?) ( value -- ? ) -M: object (literal-value?) drop f ; +: literal-value? ( value -- ? ) known (literal-value?) ; -GENERIC: (literal) ( value -- literal ) +GENERIC: (input-value?) ( value -- ? ) + +: input-value? ( value -- ? ) known (input-value?) ; + +GENERIC: (literal) ( known -- literal ) ! Literal value -TUPLE: literal < identity-tuple value recursion hashcode ; +TUPLE: literal < identity-tuple value recursion ; : literal ( value -- literal ) known (literal) ; -: literal-value? ( value -- ? ) known (literal-value?) ; - -M: literal hashcode* nip hashcode>> ; +M: literal hashcode* nip value>> identity-hashcode ; : ( obj -- value ) - recursive-state get over hashcode \ literal boa ; + recursive-state get \ literal boa ; + +M: literal (input-value?) drop f ; M: literal (literal-value?) drop t ; @@ -51,7 +55,7 @@ M: literal (literal) ; : curried/composed-literal ( input1 input2 quot -- literal ) [ [ literal ] bi@ ] dip [ [ [ value>> ] bi@ ] dip call ] [ drop nip recursion>> ] 3bi - over hashcode \ literal boa ; inline + \ literal boa ; inline ! Result of curry TUPLE: curried obj quot ; @@ -61,7 +65,10 @@ C: curried : >curried< ( curried -- obj quot ) [ obj>> ] [ quot>> ] bi ; inline +M: curried (input-value?) >curried< [ input-value? ] either? ; + M: curried (literal-value?) >curried< [ literal-value? ] both? ; + M: curried (literal) >curried< [ curry ] curried/composed-literal ; ! Result of compose @@ -72,5 +79,27 @@ C: composed : >composed< ( composed -- quot1 quot2 ) [ quot1>> ] [ quot2>> ] bi ; inline +M: composed (input-value?) + [ quot1>> input-value? ] [ quot2>> input-value? ] bi or ; + M: composed (literal-value?) >composed< [ literal-value? ] both? ; -M: composed (literal) >composed< [ compose ] curried/composed-literal ; \ No newline at end of file + +M: composed (literal) >composed< [ compose ] curried/composed-literal ; + +! Input parameters +SINGLETON: input-parameter + +SYMBOL: current-word + +M: input-parameter (input-value?) drop t ; + +M: input-parameter (literal-value?) drop f ; + +M: input-parameter (literal) current-word get unknown-macro-input ; + +! Computed values +M: f (input-value?) drop f ; + +M: f (literal-value?) drop f ; + +M: f (literal) current-word get bad-macro-input ; \ No newline at end of file diff --git a/basis/suffix-arrays/suffix-arrays.factor b/basis/suffix-arrays/suffix-arrays.factor index 931cb36ea9..f486adcb32 100755 --- a/basis/suffix-arrays/suffix-arrays.factor +++ b/basis/suffix-arrays/suffix-arrays.factor @@ -22,8 +22,7 @@ IN: suffix-arrays : ( from/f to/f seq -- slice ) [ - tuck - [ drop 0 or ] [ length or ] 2bi* + [ drop 0 or ] [ length or ] bi-curry bi* [ min ] keep ] keep ; inline diff --git a/basis/system-info/linux/linux.factor b/basis/system-info/linux/linux.factor index 5f83eb268b..0c21597a2f 100644 --- a/basis/system-info/linux/linux.factor +++ b/basis/system-info/linux/linux.factor @@ -7,7 +7,7 @@ SPECIALIZED-ARRAY: char IN: system-info.linux : (uname) ( buf -- int ) - "int" f "uname" { "char*" } alien-invoke ; + int f "uname" { char* } alien-invoke ; : uname ( -- seq ) 65536 [ (uname) io-error ] keep diff --git a/basis/threads/threads-tests.factor b/basis/threads/threads-tests.factor index 610a664c7b..79aad20b85 100644 --- a/basis/threads/threads-tests.factor +++ b/basis/threads/threads-tests.factor @@ -32,13 +32,12 @@ yield [ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with :: spawn-namespace-test ( -- ? ) - [let | p [ ] g [ gensym ] | - [ - g "x" set - [ "x" get p fulfill ] "B" spawn drop - ] with-scope - p ?promise g eq? - ] ; + :> p gensym :> g + [ + g "x" set + [ "x" get p fulfill ] "B" spawn drop + ] with-scope + p ?promise g eq? ; [ t ] [ spawn-namespace-test ] unit-test diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index f5d4b55129..134395f1a8 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -24,13 +24,13 @@ M: word quot-uses over crossref? [ conjoin ] [ 2drop ] if ; [ quot-uses ] curry each ; : seq-uses ( seq assoc -- ) - over visited get memq? [ 2drop ] [ + over visited get member-eq? [ 2drop ] [ over visited get push (seq-uses) ] if ; : assoc-uses ( assoc' assoc -- ) - over visited get memq? [ 2drop ] [ + over visited get member-eq? [ 2drop ] [ over visited get push [ >alist ] dip (seq-uses) ] if ; diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 784b034665..9244f06b4e 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -5,32 +5,32 @@ io.launcher arrays namespaces continuations layouts accessors urls math.parser io.directories tools.deploy.test ; IN: tools.deploy.tests -[ t ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test +[ ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test -[ t ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test +[ ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test -[ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test +[ ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test [ "staging.math-threads-compiler-ui.image" ] [ "hello-ui" deploy-config [ bootstrap-profile staging-image-name file-name ] bind ] unit-test -[ t ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test +[ ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test -[ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test +[ ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test -[ t ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test +[ ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test -[ t ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test +[ ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test -[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test +[ ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test os macosx? [ - [ t ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test + [ ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test ] when -[ t ] [ "benchmark.regex-dna" shake-and-bake 900000 small-enough? ] unit-test +[ ] [ "benchmark.regex-dna" shake-and-bake 900000 small-enough? ] unit-test { "tools.deploy.test.1" diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 470194ed9d..c79065bb29 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -9,6 +9,7 @@ compiler.units definitions generic generic.standard generic.single tools.deploy.config combinators classes classes.builtin slots.private grouping command-line ; QUALIFIED: bootstrap.stage2 +QUALIFIED: compiler.crossref QUALIFIED: compiler.errors QUALIFIED: continuations QUALIFIED: definitions @@ -258,7 +259,7 @@ IN: tools.deploy.shaker ! otherwise do nothing [ 2drop ] } cond - ] change-each ; + ] map! drop ; : strip-default-method ( generic new-default -- ) [ @@ -340,8 +341,8 @@ IN: tools.deploy.shaker implementors-map update-map main-vocab-hook - compiled-crossref - compiled-generic-crossref + compiler.crossref:compiled-crossref + compiler.crossref:compiled-generic-crossref compiler-impl compiler.errors:compiler-errors lexer-factory @@ -477,7 +478,7 @@ SYMBOL: deploy-vocab next-method ; : calls-next-method? ( method -- ? ) - def>> flatten \ (call-next-method) swap memq? ; + def>> flatten \ (call-next-method) swap member-eq? ; : compute-next-methods ( -- ) [ standard-generic? ] instances [ diff --git a/basis/tools/deploy/test/14/14.factor b/basis/tools/deploy/test/14/14.factor index d6caa0e68b..65fd50b5b8 100644 --- a/basis/tools/deploy/test/14/14.factor +++ b/basis/tools/deploy/test/14/14.factor @@ -1,7 +1,9 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors classes.struct cocoa cocoa.classes -cocoa.subclassing core-graphics.types kernel math ; +cocoa.runtime cocoa.subclassing cocoa.types core-graphics.types +kernel math ; +FROM: alien.c-types => float ; IN: tools.deploy.test.14 CLASS: { @@ -9,8 +11,8 @@ CLASS: { { +name+ "Bar" } } { "bar:" - "float" - { "id" "SEL" "NSRect" } + float + { id SEL NSRect } [ [ origin>> [ x>> ] [ y>> ] bi + ] [ size>> [ w>> ] [ h>> ] bi + ] diff --git a/basis/tools/deploy/test/4/4.factor b/basis/tools/deploy/test/4/4.factor index a9ee71131c..fb005d2a46 100644 --- a/basis/tools/deploy/test/4/4.factor +++ b/basis/tools/deploy/test/4/4.factor @@ -1,5 +1,5 @@ +USING: io.encodings.string kernel io.encodings.8-bit.latin7 ; IN: tools.deploy.test.4 -USING: io.encodings.8-bit io.encodings.string kernel ; : deploy-test-4 ( -- ) "xyzthg" \ latin7 encode drop ; diff --git a/basis/tools/deploy/test/9/9.factor b/basis/tools/deploy/test/9/9.factor index a1cbd5bc66..642ee48e67 100644 --- a/basis/tools/deploy/test/9/9.factor +++ b/basis/tools/deploy/test/9/9.factor @@ -1,10 +1,10 @@ -USING: alien kernel math ; +USING: alien alien.c-types kernel math ; IN: tools.deploy.test.9 : callback-test ( -- callback ) - "int" { "int" } "cdecl" [ 1 + ] alien-callback ; + int { int } "cdecl" [ 1 + ] alien-callback ; : indirect-test ( -- ) - 10 callback-test "int" { "int" } "cdecl" alien-indirect 11 assert= ; + 10 callback-test int { int } "cdecl" alien-indirect 11 assert= ; MAIN: indirect-test diff --git a/basis/tools/deploy/test/test.factor b/basis/tools/deploy/test/test.factor index c799ec615e..d8414baba7 100755 --- a/basis/tools/deploy/test/test.factor +++ b/basis/tools/deploy/test/test.factor @@ -10,14 +10,16 @@ IN: tools.deploy.test dup deploy-config make-deploy-image ] with-directory ; -: small-enough? ( n -- ? ) +ERROR: image-too-big actual-size max-size ; + +: small-enough? ( n -- ) [ "test.image" temp-file file-info size>> ] [ cell 4 / * cpu ppc? [ 100000 + ] when os windows? [ 150000 + ] when ] bi* - <= ; + 2dup <= [ 2drop ] [ image-too-big ] if ; : deploy-test-command ( -- args ) os macosx? diff --git a/basis/tools/deprecation/deprecation-docs.factor b/basis/tools/deprecation/deprecation-docs.factor index fb3df736f4..a7390010d0 100644 --- a/basis/tools/deprecation/deprecation-docs.factor +++ b/basis/tools/deprecation/deprecation-docs.factor @@ -6,7 +6,7 @@ HELP: :deprecations { $description "Prints all deprecation notes." } ; ARTICLE: "tools.deprecation" "Deprecation tracking" -"Factor's core syntax defines a " { $link POSTPONE: deprecated } " word that can be applied to words to mark them as deprecated. When the " { $vocab-link "tools.deprecation" } " vocabulary is loaded, notes will be collected and reported by the " { $link "tools.errors" } " mechanism when deprecated words are used to define other words." +"Factor's core syntax defines a " { $link POSTPONE: deprecated } " word that can be applied to words to mark them as deprecated. Notes are collected and reported by the " { $link "tools.errors" } " mechanism when deprecated words are used to define other words." { $subsections POSTPONE: deprecated :deprecations diff --git a/basis/tools/dispatch/authors.txt b/basis/tools/dispatch/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/tools/dispatch/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/dispatch/dispatch-docs.factor b/basis/tools/dispatch/dispatch-docs.factor new file mode 100644 index 0000000000..e93ea165c1 --- /dev/null +++ b/basis/tools/dispatch/dispatch-docs.factor @@ -0,0 +1,8 @@ +IN: tools.dispatch +USING: help.markup help.syntax vm quotations ; + +HELP: last-dispatch-stats +{ $var-description "A " { $link dispatch-statistics } " instance, set by " { $link collect-dispatch-stats } "." } ; + +HELP: dispatch-stats. +{ $description "Prints method dispatch statistics from the last call to " { $link collect-dispatch-stats } "." } ; diff --git a/basis/tools/dispatch/dispatch.factor b/basis/tools/dispatch/dispatch.factor new file mode 100644 index 0000000000..7d30dac36b --- /dev/null +++ b/basis/tools/dispatch/dispatch.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel namespaces prettyprint classes.struct +vm tools.dispatch.private ; +IN: tools.dispatch + +SYMBOL: last-dispatch-stats + +: dispatch-stats. ( -- ) + last-dispatch-stats get { + { "Megamorphic hits" [ megamorphic-cache-hits>> ] } + { "Megamorphic misses" [ megamorphic-cache-misses>> ] } + { "Cold to monomorphic" [ cold-call-to-ic-transitions>> ] } + { "Mono to polymorphic" [ ic-to-pic-transitions>> ] } + { "Poly to megamorphic" [ pic-to-mega-transitions>> ] } + { "Tag check count" [ pic-tag-count>> ] } + { "Tuple check count" [ pic-tuple-count>> ] } + } object-table. ; + +: collect-dispatch-stats ( quot -- ) + reset-dispatch-stats + call + dispatch-stats dispatch-statistics memory>struct + last-dispatch-stats set ; inline diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor index 963ea7592c..0bf271535a 100644 --- a/basis/tools/errors/errors.factor +++ b/basis/tools/errors/errors.factor @@ -8,10 +8,6 @@ IN: tools.errors #! Tools for source-files.errors. Used by tools.tests and others #! for error reporting -M: source-file-error compute-restarts error>> compute-restarts ; - -M: source-file-error error-help error>> error-help ; - CONSTANT: +listener-input+ "" : error-location ( error -- string ) diff --git a/basis/tools/memory/memory-docs.factor b/basis/tools/memory/memory-docs.factor index 7ecbf402ab..b18396538f 100644 --- a/basis/tools/memory/memory-docs.factor +++ b/basis/tools/memory/memory-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax memory sequences ; +USING: help.markup help.syntax memory sequences vm ; IN: tools.memory ARTICLE: "tools.memory" "Object memory tools" @@ -13,11 +13,8 @@ ARTICLE: "tools.memory" "Object memory tools" data-room code-room } -"There are a pair of combinators, analogous to " { $link each } " and " { $link filter } ", which operate on the entire collection of objects in the object heap:" -{ $subsections - each-object - instances -} +"A combinator to get objects from the heap:" +{ $subsections instances } "You can check an object's the heap memory usage:" { $subsections size } "The garbage collector can be invoked manually:" @@ -39,3 +36,15 @@ HELP: heap-stats. { $description "For each class, prints the number of instances and total memory consumed by those instances." } ; { heap-stats heap-stats. } related-words + +HELP: gc-events. +{ $description "Prints all garbage collection events that took place during the last call to " { $link collect-gc-events } "." } ; + +HELP: gc-stats. +{ $description "Prints a breakdown of different garbage collection events that took place during the last call to " { $link collect-gc-events } "." } ; + +HELP: gc-summary. +{ $description "Prints aggregate garbage collection statistics from the last call to " { $link collect-gc-events } "." } ; + +HELP: gc-events +{ $var-description "A sequence of " { $link gc-event } " instances, set by " { $link collect-gc-events } ". Can be inspected directly, or with the " { $link gc-events. } ", " { $link gc-stats. } " and " { $link gc-summary. } " words." } ; diff --git a/basis/tools/memory/memory-tests.factor b/basis/tools/memory/memory-tests.factor index 4b75cf0bfa..4711f472a3 100644 --- a/basis/tools/memory/memory-tests.factor +++ b/basis/tools/memory/memory-tests.factor @@ -1,5 +1,9 @@ -USING: tools.test tools.memory ; +USING: tools.test tools.memory memory ; IN: tools.memory.tests [ ] [ room. ] unit-test [ ] [ heap-stats. ] unit-test +[ ] [ [ gc gc ] collect-gc-events ] unit-test +[ ] [ gc-events. ] unit-test +[ ] [ gc-stats. ] unit-test +[ ] [ gc-summary. ] unit-test diff --git a/basis/tools/memory/memory.factor b/basis/tools/memory/memory.factor index 81785f7ea4..cf7e3ee38d 100644 --- a/basis/tools/memory/memory.factor +++ b/basis/tools/memory/memory.factor @@ -1,55 +1,77 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences arrays generic assocs io math -namespaces parser prettyprint strings io.styles words -system sorting splitting grouping math.parser classes memory -combinators fry ; +USING: accessors arrays assocs classes classes.struct +combinators combinators.smart continuations fry generalizations +generic grouping io io.styles kernel make math math.parser +math.statistics memory namespaces parser prettyprint sequences +sorting splitting strings system vm words ; IN: tools.memory string - dup length 4 > [ 3 cut* "," glue ] when - " KB" append write-cell ; +: commas ( n -- str ) + dup 0 < [ neg commas "-" prepend ] [ + number>string + reverse 3 group "," join reverse + ] if ; -: write-total/used/free ( free total str -- ) - [ - write-cell - dup write-size - over - write-size - write-size - ] with-row ; +: kilobytes ( n -- str ) + 1024 /i commas " KB" append ; -: write-total ( n str -- ) - [ - write-cell - write-size - [ ] with-cell - [ ] with-cell - ] with-row ; +: micros>string ( n -- str ) + commas " µs" append ; -: write-headings ( seq -- ) - [ [ write-cell ] each ] with-row ; +: copying-room. ( copying-sizes -- ) + { + { "Size:" [ size>> kilobytes ] } + { "Occupied:" [ occupied>> kilobytes ] } + { "Free:" [ free>> kilobytes ] } + } object-table. ; -: (data-room.) ( -- ) - data-room 2 [ - [ first2 ] [ number>string "Generation " prepend ] bi* - write-total/used/free - ] each-index - "Decks" write-total - "Cards" write-total ; +: nursery-room. ( data-room -- ) + "- Nursery space" print nursery>> copying-room. ; -: write-labeled-size ( n string -- ) - [ write-cell write-size ] with-row ; +: aging-room. ( data-room -- ) + "- Aging space" print aging>> copying-room. ; -: (code-room.) ( -- ) - code-room { - [ "Size:" write-labeled-size ] - [ "Used:" write-labeled-size ] - [ "Total free space:" write-labeled-size ] - [ "Largest free block:" write-labeled-size ] - } spread ; +: mark-sweep-table. ( mark-sweep-sizes -- ) + { + { "Size:" [ size>> kilobytes ] } + { "Occupied:" [ occupied>> kilobytes ] } + { "Total free:" [ total-free>> kilobytes ] } + { "Contiguous free:" [ contiguous-free>> kilobytes ] } + { "Free block count:" [ free-block-count>> number>string ] } + } object-table. ; + +: tenured-room. ( data-room -- ) + "- Tenured space" print tenured>> mark-sweep-table. ; + +: misc-room. ( data-room -- ) + "- Miscellaneous buffers" print + { + { "Card array:" [ cards>> kilobytes ] } + { "Deck array:" [ decks>> kilobytes ] } + { "Mark stack:" [ mark-stack>> kilobytes ] } + } object-table. ; + +: data-room. ( -- ) + "== Data heap ==" print nl + data-room data-heap-room memory>struct { + [ nursery-room. nl ] + [ aging-room. nl ] + [ tenured-room. nl ] + [ misc-room. ] + } cleave ; + +: code-room. ( -- ) + "== Code heap ==" print nl + code-room mark-sweep-sizes memory>struct mark-sweep-table. ; + +PRIVATE> + +: room. ( -- ) data-room. nl code-room. ; + + -: room. ( -- ) - "==== DATA HEAP" print - standard-table-style [ - { "" "Total" "Used" "Free" } write-headings - (data-room.) - ] tabular-output - nl nl - "==== CODE HEAP" print - standard-table-style [ - (code-room.) - ] tabular-output - nl ; - : heap-stats ( -- counts sizes ) [ ] instances H{ } clone H{ } clone [ '[ _ _ heap-stat-step ] each ] 2keep ; : heap-stats. ( -- ) heap-stats dup keys natural-sort standard-table-style [ - { "Class" "Bytes" "Instances" } write-headings + [ { "Class" "Bytes" "Instances" } [ write-cell ] each ] with-row [ [ dup pprint-cell @@ -85,3 +94,104 @@ PRIVATE> ] with-row ] each 2drop ] tabular-output nl ; + +SYMBOL: gc-events + +: collect-gc-events ( quot -- ) + enable-gc-events + [ ] [ disable-gc-events drop ] cleanup + disable-gc-events [ gc-event memory>struct ] map gc-events set ; inline + +> ] [ aging>> ] [ tenured>> ] tri [ occupied>> ] tri@ ] + [ occupied>> ] + bi* + ] sum-outputs ; + +: space-occupied-before ( event -- bytes ) + [ data-heap-before>> ] [ code-heap-before>> ] bi (space-occupied) ; + +: space-occupied-after ( event -- bytes ) + [ data-heap-after>> ] [ code-heap-after>> ] bi (space-occupied) ; + +: space-reclaimed ( event -- bytes ) + [ space-occupied-before ] [ space-occupied-after ] bi - ; + +TUPLE: gc-stats collections times ; + +: ( -- stats ) + gc-stats new + 0 >>collections + V{ } clone >>times ; inline + +: compute-gc-stats ( events -- stats ) + V{ } clone [ + '[ + dup op>> _ [ drop ] cache + [ 1 + ] change-collections + [ total-time>> ] dip times>> push + ] each + ] keep sort-keys ; + +: gc-stats-table-row ( pair -- row ) + [ + [ first gc-op-string ] [ + second + [ collections>> ] + [ + times>> { + [ sum micros>string ] + [ mean >integer micros>string ] + [ median >integer micros>string ] + [ infimum micros>string ] + [ supremum micros>string ] + } cleave + ] bi + ] bi + ] output>array ; + +: gc-stats-table ( stats -- table ) + [ gc-stats-table-row ] map + { "" "Number" "Total" "Mean" "Median" "Min" "Max" } prefix ; + +PRIVATE> + +: gc-event. ( event -- ) + { + { "Event type:" [ op>> gc-op-string ] } + { "Total time:" [ total-time>> micros>string ] } + { "Space reclaimed:" [ space-reclaimed kilobytes ] } + } object-table. ; + +: gc-events. ( -- ) + gc-events get [ gc-event. nl ] each ; + +: gc-stats. ( -- ) + gc-events get compute-gc-stats gc-stats-table simple-table. ; + +: gc-summary. ( -- ) + gc-events get { + { "Collections:" [ length commas ] } + { "Cards scanned:" [ [ cards-scanned>> ] map-sum commas ] } + { "Decks scanned:" [ [ decks-scanned>> ] map-sum commas ] } + { "Code blocks scanned:" [ [ code-blocks-scanned>> ] map-sum commas ] } + { "Total time:" [ [ total-time>> ] map-sum micros>string ] } + { "Card scan time:" [ [ card-scan-time>> ] map-sum micros>string ] } + { "Code block scan time:" [ [ code-scan-time>> ] map-sum micros>string ] } + { "Data heap sweep time:" [ [ data-sweep-time>> ] map-sum micros>string ] } + { "Code heap sweep time:" [ [ code-sweep-time>> ] map-sum micros>string ] } + { "Compaction time:" [ [ compaction-time>> ] map-sum micros>string ] } + } object-table. ; diff --git a/basis/tools/profiler/profiler-docs.factor b/basis/tools/profiler/profiler-docs.factor index 0fda4a65e5..66ae5d7bd3 100644 --- a/basis/tools/profiler/profiler-docs.factor +++ b/basis/tools/profiler/profiler-docs.factor @@ -25,7 +25,7 @@ $nl method-profile. "profiler-limitations" } -{ $see-also "ui.tools.profiler" } ; +{ $see-also "ui.tools.profiler" "tools.annotations" "timing" } ; ABOUT: "profiling" diff --git a/basis/tools/profiler/profiler-tests.factor b/basis/tools/profiler/profiler-tests.factor index dda531faee..6e5177fbae 100644 --- a/basis/tools/profiler/profiler-tests.factor +++ b/basis/tools/profiler/profiler-tests.factor @@ -1,7 +1,7 @@ -IN: tools.profiler.tests USING: accessors tools.profiler tools.test kernel memory math -threads alien tools.profiler.private sequences compiler compiler.units -words ; +threads alien alien.c-types tools.profiler.private sequences +compiler compiler.units words ; +IN: tools.profiler.tests [ t ] [ \ length counter>> @@ -21,9 +21,9 @@ words ; [ ] [ \ + usage-profile. ] unit-test -: callback-test ( -- callback ) "void" { } "cdecl" [ ] alien-callback ; +: callback-test ( -- callback ) void { } "cdecl" [ ] alien-callback ; -: indirect-test ( callback -- ) "void" { } "cdecl" alien-indirect ; +: indirect-test ( callback -- ) void { } "cdecl" alien-indirect ; : foobar ( -- ) ; @@ -60,7 +60,7 @@ words ; [ [ gensym execute ] profile ] [ T{ undefined } = ] must-fail-with -: crash-bug-1 ( -- x ) "hi" "bye" ; +: crash-bug-1 ( -- x ) "hi" ; : crash-bug-2 ( -- ) 100000 [ crash-bug-1 drop ] times ; [ ] [ [ crash-bug-2 ] profile ] unit-test diff --git a/basis/tools/profiler/profiler.factor b/basis/tools/profiler/profiler.factor index 219344db3b..8279a90514 100644 --- a/basis/tools/profiler/profiler.factor +++ b/basis/tools/profiler/profiler.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors words sequences math prettyprint kernel arrays io -io.styles namespaces assocs kernel.private strings combinators -sorting math.parser vocabs definitions tools.profiler.private -tools.crossref continuations generic compiler.units sets classes fry ; +USING: accessors words sequences math prettyprint kernel arrays +io io.styles namespaces assocs kernel.private strings +combinators sorting math.parser vocabs definitions +tools.profiler.private tools.crossref continuations generic +compiler.units compiler.crossref sets classes fry ; IN: tools.profiler : profile ( quot -- ) @@ -19,7 +20,7 @@ IN: tools.profiler [ dup counter>> ] map-counters ; : cumulative-counters ( obj quot -- alist ) - '[ dup @ [ counter>> ] sigma ] map-counters ; inline + '[ dup @ [ counter>> ] map-sum ] map-counters ; inline : vocab-counters ( -- alist ) vocabs [ words [ predicate? not ] filter ] cumulative-counters ; diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 089bad3158..936d388b01 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -98,7 +98,7 @@ M: bad-developer-name summary [ main-file-string ] dip utf8 set-file-contents ; : scaffold-main ( vocab-root vocab -- ) - tuck ".factor" vocab-root/vocab/suffix>path scaffolding? [ + [ ".factor" vocab-root/vocab/suffix>path ] keep swap scaffolding? [ set-scaffold-main-file ] [ 2drop diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 097460837b..559b1357c8 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -96,9 +96,9 @@ MACRO: ( word -- ) ] [ drop ] if ; inline : parse-test ( accum word -- accum ) - literalize parsed - lexer get line>> parsed - \ experiment parsed ; inline + literalize suffix! + lexer get line>> suffix! + \ experiment suffix! ; inline << @@ -121,9 +121,6 @@ SYNTAX: TEST: vocab-tests [ run-test-file ] each ] [ drop ] if ; -: traceback-button. ( failure -- ) - "[" write [ "Traceback" ] dip continuation>> write-object "]" print ; - PRIVATE> TEST: unit-test @@ -137,7 +134,7 @@ M: test-failure error. ( error -- ) [ error-location print nl ] [ asset>> [ experiment. nl ] when* ] [ error>> error. ] - [ traceback-button. ] + [ continuation>> traceback-link. ] } cleave ; : :test-failures ( -- ) test-failures get errors. ; diff --git a/basis/tools/time/time-docs.factor b/basis/tools/time/time-docs.factor index 408592d0c6..9e892c33ec 100644 --- a/basis/tools/time/time-docs.factor +++ b/basis/tools/time/time-docs.factor @@ -1,28 +1,38 @@ -USING: help.markup help.syntax memory system ; +USING: help.markup help.syntax memory system tools.dispatch +tools.memory quotations vm ; IN: tools.time -ARTICLE: "timing" "Timing code" +ARTICLE: "timing" "Timing code and collecting statistics" "You can time the execution of a quotation in the listener:" { $subsections time } +"This word also collects statistics about method dispatch and garbage collection:" +{ $subsections dispatch-stats. gc-events. gc-stats. gc-summary. } "A lower-level word puts timings on the stack, intead of printing:" { $subsections benchmark } -"You can also read the system clock and garbage collection statistics directly:" -{ $subsections - micros - gc-stats -} -{ $see-also "profiling" } ; +"You can also read the system clock directly:" +{ $subsections micros } +{ $see-also "profiling" "calendar" } ; ABOUT: "timing" HELP: benchmark -{ $values { "quot" "a quotation" } +{ $values { "quot" quotation } { "runtime" "the runtime in microseconds" } } { $description "Runs a quotation, measuring the total wall clock time." } { $notes "A nicer word for interactive use is " { $link time } "." } ; HELP: time -{ $values { "quot" "a quotation" } } -{ $description "Runs a quotation and then prints the total run time and some garbage collection statistics." } ; +{ $values { "quot" quotation } } +{ $description "Runs a quotation, gathering statistics about method dispatch and garbage collection, and then prints the total run time." } ; { benchmark micros time } related-words + +HELP: collect-gc-events +{ $values { "quot" quotation } } +{ $description "Calls the quotation, storing an array of " { $link gc-event } " instances in the " { $link gc-events } " variable." } +{ $notes "The " { $link time } " combinator automatically calls this combinator." } ; + +HELP: collect-dispatch-stats +{ $values { "quot" quotation } } +{ $description "Calls the quotation, collecting method dispatch statistics and storing them in the " { $link last-dispatch-stats } " variable. " } +{ $notes "The " { $link time } " combinator automatically calls this combinator." } ; diff --git a/basis/tools/time/time-tests.factor b/basis/tools/time/time-tests.factor new file mode 100644 index 0000000000..00c774663c --- /dev/null +++ b/basis/tools/time/time-tests.factor @@ -0,0 +1,4 @@ +IN: tools.time.tests +USING: tools.time tools.test compiler ; + +[ ] [ [ [ ] time ] compile-call ] unit-test diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index 948c0d482d..3724a741b7 100644 --- a/basis/tools/time/time.factor +++ b/basis/tools/time/time.factor @@ -1,74 +1,22 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math memory io io.styles prettyprint -namespaces system sequences splitting grouping assocs strings -generic.single combinators ; +USING: system kernel math io prettyprint tools.memory +tools.dispatch ; IN: tools.time : benchmark ( quot -- runtime ) micros [ call micros ] dip - ; inline : time. ( time -- ) - "== Running time ==" print nl 1000000 /f pprint " seconds" print ; + "Running time: " write 1000000 /f pprint " seconds" print ; -: gc-stats. ( stats -- ) - 5 cut* - "== Garbage collection ==" print nl - "Times are in microseconds." print nl - [ - 6 group - { - "GC count:" - "Total GC time:" - "Longest GC pause:" - "Average GC pause:" - "Objects copied:" - "Bytes copied:" - } prefix - flip - { "" "Nursery" "Aging" "Tenured" } prefix - simple-table. - ] - [ - nl - { - "Total GC time:" - "Cards scanned:" - "Decks scanned:" - "Card scan time:" - "Code heap literal scans:" - } swap zip simple-table. - ] bi* ; - -: dispatch-stats. ( stats -- ) - "== Megamorphic caches ==" print nl - { "Hits" "Misses" } swap zip simple-table. ; - -: inline-cache-stats. ( stats -- ) - nl "== Polymorphic inline caches ==" print nl - 3 cut - [ - "Transitions:" print - { "Cold to monomorphic" "Mono to polymorphic" "Poly to megamorphic" } swap zip - simple-table. nl - ] [ - "Type check stubs:" print - { "Tag only" "Hi-tag" "Tuple" "Hi-tag and tuple" } swap zip - simple-table. - ] bi* ; +: time-banner. ( -- ) + "Additional information was collected." print + "dispatch-stats. - Print method dispatch statistics" print + "gc-events. - Print all garbage collection events" print + "gc-stats. - Print breakdown of different garbage collection events" print + "gc-summary. - Print aggregate garbage collection statistics" print ; : time ( quot -- ) - gc-reset - reset-dispatch-stats - reset-inline-cache-stats - benchmark gc-stats dispatch-stats inline-cache-stats - H{ { table-gap { 20 20 } } } [ - [ - [ [ time. ] 3dip ] with-cell - [ ] with-cell - ] with-row - [ - [ [ gc-stats. ] 2dip ] with-cell - [ [ dispatch-stats. ] [ inline-cache-stats. ] bi* ] with-cell - ] with-row - ] tabular-output nl ; inline + [ [ benchmark ] collect-dispatch-stats ] collect-gc-events + time. nl time-banner. ; inline diff --git a/basis/tools/walker/debug/debug.factor b/basis/tools/walker/debug/debug.factor index 80113607d4..2ab74bf735 100644 --- a/basis/tools/walker/debug/debug.factor +++ b/basis/tools/walker/debug/debug.factor @@ -6,26 +6,25 @@ namespaces namespaces.private assocs accessors ; IN: tools.walker.debug :: test-walker ( quot -- data ) - [let | p [ ] | + :> p + [ + H{ } clone >n + [ - H{ } clone >n + p promise-fulfilled? + [ drop ] [ p fulfill ] if + 2drop + ] show-walker-hook set - [ - p promise-fulfilled? - [ drop ] [ p fulfill ] if - 2drop - ] show-walker-hook set + break - break + quot call + ] "Walker test" spawn drop - quot call - ] "Walker test" spawn drop + step-into-all + p ?promise + send-synchronous drop - step-into-all - p ?promise - send-synchronous drop - - p ?promise - variables>> walker-continuation swap at - value>> data>> - ] ; + p ?promise + variables>> walker-continuation swap at + value>> data>> ; diff --git a/basis/tools/walker/walker-docs.factor b/basis/tools/walker/walker-docs.factor index bbfb9cbd9f..318f7e065c 100644 --- a/basis/tools/walker/walker-docs.factor +++ b/basis/tools/walker/walker-docs.factor @@ -6,7 +6,7 @@ HELP: breakpoint { $description "Annotates a word definition to enter the single stepper when executed." } ; HELP: breakpoint-if -{ $values { "quot" { $quotation "( -- ? )" } } { "word" word } } +{ $values { "word" word } { "quot" { $quotation "( -- ? )" } } } { $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ; HELP: B diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index 19924d67e4..35a9ce7787 100644 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -167,4 +167,4 @@ SYMBOL: +stopped+ ! For convenience IN: syntax -SYNTAX: B \ break parsed ; +SYNTAX: B \ break suffix! ; diff --git a/basis/tr/tr.factor b/basis/tr/tr.factor index daac3c96c7..f75adcbf04 100644 --- a/basis/tr/tr.factor +++ b/basis/tr/tr.factor @@ -33,7 +33,7 @@ M: bad-tr summary tr-quot (( seq -- translated )) define-declared ; : fast-tr-quot ( mapping -- quot ) - '[ [ _ tr-nth ] change-each ] ; + '[ [ _ tr-nth ] map! drop ] ; : define-fast-tr ( word mapping -- ) fast-tr-quot (( seq -- )) define-declared ; diff --git a/basis/typed/typed-tests.factor b/basis/typed/typed-tests.factor index d8cbb814d8..f7b853cff7 100644 --- a/basis/typed/typed-tests.factor +++ b/basis/typed/typed-tests.factor @@ -1,4 +1,5 @@ -USING: accessors effects eval kernel layouts math quotations tools.test typed words ; +USING: accessors effects eval kernel layouts math namespaces +quotations tools.test typed words ; IN: typed.tests TYPED: f+ ( a: float b: float -- c: float ) @@ -71,3 +72,28 @@ IN: typed.tests T{ unboxable f 12 3 4.0 } unboxy xy>> """ eval( -- xy ) ] unit-test + +TYPED: no-inputs ( -- out: integer ) + 1 ; + +[ 1 ] [ no-inputs ] unit-test + +TUPLE: unboxable3 + { x read-only } ; + +TYPED: no-inputs-unboxable-output ( -- out: unboxable3 ) + T{ unboxable3 } ; + +[ T{ unboxable3 } ] [ no-inputs-unboxable-output ] unit-test + +SYMBOL: buh + +TYPED: no-outputs ( x: integer -- ) + buh set ; + +[ 2 ] [ 2 no-outputs buh get ] unit-test + +TYPED: no-outputs-unboxable-input ( x: unboxable3 -- ) + buh set ; + +[ T{ unboxable3 } ] [ T{ unboxable3 } no-outputs-unboxable-input buh get ] unit-test diff --git a/basis/typed/typed.factor b/basis/typed/typed.factor index 84a8ea3217..0b3ac9d5f8 100644 --- a/basis/typed/typed.factor +++ b/basis/typed/typed.factor @@ -3,7 +3,7 @@ USING: accessors arrays classes classes.tuple combinators combinators.short-circuit definitions effects fry hints math kernel kernel.private namespaces parser quotations sequences slots words locals -locals.parser macros stack-checker.state ; +locals.parser macros stack-checker.dependencies ; IN: typed ERROR: type-mismatch-error word expected-types ; @@ -79,7 +79,8 @@ DEFER: make-boxer [ drop [ ] ] if ; : make-boxer ( types -- quot ) - [ boxer ] [ swap '[ @ _ dip ] ] map-reduce ; + [ [ ] ] + [ [ boxer ] [ swap '[ @ _ dip ] ] map-reduce ] if-empty ; ! defining typed words diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 84e55ed134..8eeca89c2f 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -130,7 +130,7 @@ CONSTANT: window-control>styleMask M:: cocoa-ui-backend (open-window) ( world -- ) world [ [ dim>> ] dip ] with-world-pixel-format :> view - world window-controls>> textured-background swap memq? + world window-controls>> textured-background swap member-eq? [ view make-context-transparent ] when view world [ world>NSRect ] [ world>styleMask ] bi :> window view -> release @@ -218,7 +218,7 @@ CLASS: { { +name+ "FactorApplicationDelegate" } } -{ "applicationDidUpdate:" "void" { "id" "SEL" "id" } +{ "applicationDidUpdate:" void { id SEL id } [ 3drop reset-run-loop ] } ; diff --git a/basis/ui/backend/cocoa/tools/tools.factor b/basis/ui/backend/cocoa/tools/tools.factor index ddcf79208d..00c1ad3583 100644 --- a/basis/ui/backend/cocoa/tools/tools.factor +++ b/basis/ui/backend/cocoa/tools/tools.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.syntax cocoa cocoa.nibs cocoa.application -cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing -core-foundation core-foundation.strings help.topics kernel -memory namespaces parser system ui ui.tools.browser -ui.tools.listener ui.backend.cocoa eval locals -vocabs.refresh ; +cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.runtime +cocoa.subclassing core-foundation core-foundation.strings +help.topics kernel memory namespaces parser system ui +ui.tools.browser ui.tools.listener ui.backend.cocoa eval +locals vocabs.refresh ; +FROM: alien.c-types => int void ; IN: ui.backend.cocoa.tools : finder-run-files ( alien -- ) @@ -25,43 +26,43 @@ CLASS: { { +name+ "FactorWorkspaceApplicationDelegate" } } -{ "application:openFiles:" "void" { "id" "SEL" "id" "id" } +{ "application:openFiles:" void { id SEL id id } [ [ 3drop ] dip finder-run-files ] } -{ "applicationShouldHandleReopen:hasVisibleWindows:" "int" { "id" "SEL" "id" "int" } +{ "applicationShouldHandleReopen:hasVisibleWindows:" int { id SEL id int } [ [ 3drop ] dip 0 = [ show-listener ] when 1 ] } -{ "factorListener:" "id" { "id" "SEL" "id" } +{ "factorListener:" id { id SEL id } [ 3drop show-listener f ] } -{ "factorBrowser:" "id" { "id" "SEL" "id" } +{ "factorBrowser:" id { id SEL id } [ 3drop show-browser f ] } -{ "newFactorListener:" "id" { "id" "SEL" "id" } +{ "newFactorListener:" id { id SEL id } [ 3drop listener-window f ] } -{ "newFactorBrowser:" "id" { "id" "SEL" "id" } +{ "newFactorBrowser:" id { id SEL id } [ 3drop browser-window f ] } -{ "runFactorFile:" "id" { "id" "SEL" "id" } +{ "runFactorFile:" id { id SEL id } [ 3drop menu-run-files f ] } -{ "saveFactorImage:" "id" { "id" "SEL" "id" } +{ "saveFactorImage:" id { id SEL id } [ 3drop save f ] } -{ "saveFactorImageAs:" "id" { "id" "SEL" "id" } +{ "saveFactorImageAs:" id { id SEL id } [ 3drop menu-save-image f ] } -{ "refreshAll:" "id" { "id" "SEL" "id" } +{ "refreshAll:" id { id SEL id } [ 3drop [ refresh-all ] \ refresh-all call-listener f ] } ; @@ -79,13 +80,13 @@ CLASS: { { +name+ "FactorServiceProvider" } } { "evalInListener:userData:error:" - "void" - { "id" "SEL" "id" "id" "id" } + void + { id SEL id id id } [ nip [ eval-listener f ] do-service 2drop ] } { "evalToString:userData:error:" - "void" - { "id" "SEL" "id" "id" "id" } + void + { id SEL id id id } [ nip [ eval>string ] do-service 2drop ] } ; diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index 9577696314..88e5f243ad 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -3,8 +3,8 @@ USING: accessors alien alien.c-types alien.data alien.strings arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views cocoa.application cocoa.pasteboard -cocoa.types cocoa.windows sequences io.encodings.utf8 ui ui.private -ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures +cocoa.runtime cocoa.types cocoa.windows sequences io.encodings.utf8 +ui ui.private ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures core-foundation.strings core-graphics core-graphics.types threads combinators math.rectangles ; IN: ui.backend.cocoa.views @@ -148,76 +148,76 @@ CLASS: { } ! Rendering -{ "drawRect:" "void" { "id" "SEL" "NSRect" } +{ "drawRect:" void { id SEL NSRect } [ 2drop window relayout-1 yield ] } ! Events -{ "acceptsFirstMouse:" "char" { "id" "SEL" "id" } +{ "acceptsFirstMouse:" char { id SEL id } [ 3drop 1 ] } -{ "mouseEntered:" "void" { "id" "SEL" "id" } +{ "mouseEntered:" void { id SEL id } [ nip send-mouse-moved ] } -{ "mouseExited:" "void" { "id" "SEL" "id" } +{ "mouseExited:" void { id SEL id } [ 3drop forget-rollover ] } -{ "mouseMoved:" "void" { "id" "SEL" "id" } +{ "mouseMoved:" void { id SEL id } [ nip send-mouse-moved ] } -{ "mouseDragged:" "void" { "id" "SEL" "id" } +{ "mouseDragged:" void { id SEL id } [ nip send-mouse-moved ] } -{ "rightMouseDragged:" "void" { "id" "SEL" "id" } +{ "rightMouseDragged:" void { id SEL id } [ nip send-mouse-moved ] } -{ "otherMouseDragged:" "void" { "id" "SEL" "id" } +{ "otherMouseDragged:" void { id SEL id } [ nip send-mouse-moved ] } -{ "mouseDown:" "void" { "id" "SEL" "id" } +{ "mouseDown:" void { id SEL id } [ nip send-button-down$ ] } -{ "mouseUp:" "void" { "id" "SEL" "id" } +{ "mouseUp:" void { id SEL id } [ nip send-button-up$ ] } -{ "rightMouseDown:" "void" { "id" "SEL" "id" } +{ "rightMouseDown:" void { id SEL id } [ nip send-button-down$ ] } -{ "rightMouseUp:" "void" { "id" "SEL" "id" } +{ "rightMouseUp:" void { id SEL id } [ nip send-button-up$ ] } -{ "otherMouseDown:" "void" { "id" "SEL" "id" } +{ "otherMouseDown:" void { id SEL id } [ nip send-button-down$ ] } -{ "otherMouseUp:" "void" { "id" "SEL" "id" } +{ "otherMouseUp:" void { id SEL id } [ nip send-button-up$ ] } -{ "scrollWheel:" "void" { "id" "SEL" "id" } +{ "scrollWheel:" void { id SEL id } [ nip send-wheel$ ] } -{ "keyDown:" "void" { "id" "SEL" "id" } +{ "keyDown:" void { id SEL id } [ nip send-key-down-event ] } -{ "keyUp:" "void" { "id" "SEL" "id" } +{ "keyUp:" void { id SEL id } [ nip send-key-up-event ] } -{ "validateUserInterfaceItem:" "char" { "id" "SEL" "id" } +{ "validateUserInterfaceItem:" char { id SEL id } [ nip -> action 2dup [ window ] [ utf8 alien>string ] bi* validate-action @@ -225,57 +225,57 @@ CLASS: { ] } -{ "undo:" "id" { "id" "SEL" "id" } +{ "undo:" id { id SEL id } [ nip undo-action send-action$ ] } -{ "redo:" "id" { "id" "SEL" "id" } +{ "redo:" id { id SEL id } [ nip redo-action send-action$ ] } -{ "cut:" "id" { "id" "SEL" "id" } +{ "cut:" id { id SEL id } [ nip cut-action send-action$ ] } -{ "copy:" "id" { "id" "SEL" "id" } +{ "copy:" id { id SEL id } [ nip copy-action send-action$ ] } -{ "paste:" "id" { "id" "SEL" "id" } +{ "paste:" id { id SEL id } [ nip paste-action send-action$ ] } -{ "delete:" "id" { "id" "SEL" "id" } +{ "delete:" id { id SEL id } [ nip delete-action send-action$ ] } -{ "selectAll:" "id" { "id" "SEL" "id" } +{ "selectAll:" id { id SEL id } [ nip select-all-action send-action$ ] } -{ "newDocument:" "id" { "id" "SEL" "id" } +{ "newDocument:" id { id SEL id } [ nip new-action send-action$ ] } -{ "openDocument:" "id" { "id" "SEL" "id" } +{ "openDocument:" id { id SEL id } [ nip open-action send-action$ ] } -{ "saveDocument:" "id" { "id" "SEL" "id" } +{ "saveDocument:" id { id SEL id } [ nip save-action send-action$ ] } -{ "saveDocumentAs:" "id" { "id" "SEL" "id" } +{ "saveDocumentAs:" id { id SEL id } [ nip save-as-action send-action$ ] } -{ "revertDocumentToSaved:" "id" { "id" "SEL" "id" } +{ "revertDocumentToSaved:" id { id SEL id } [ nip revert-action send-action$ ] } ! Multi-touch gestures: this is undocumented. ! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html -{ "magnifyWithEvent:" "void" { "id" "SEL" "id" } +{ "magnifyWithEvent:" void { id SEL id } [ nip dup -> deltaZ sgn { @@ -286,7 +286,7 @@ CLASS: { ] } -{ "swipeWithEvent:" "void" { "id" "SEL" "id" } +{ "swipeWithEvent:" void { id SEL id } [ nip dup -> deltaX sgn { @@ -305,14 +305,14 @@ CLASS: { ] } -! "rotateWithEvent:" "void" { "id" "SEL" "id" }} +! "rotateWithEvent:" void { id SEL id }} -{ "acceptsFirstResponder" "char" { "id" "SEL" } +{ "acceptsFirstResponder" char { id SEL } [ 2drop 1 ] } ! Services -{ "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" } +{ "validRequestorForSendType:returnType:" id { id SEL id id } [ ! We return either self or nil [ over window-focus ] 2dip @@ -320,7 +320,7 @@ CLASS: { ] } -{ "writeSelectionToPasteboard:types:" "char" { "id" "SEL" "id" "id" } +{ "writeSelectionToPasteboard:types:" char { id SEL id id } [ CF>string-array NSStringPboardType swap member? [ [ drop window-focus gadget-selection ] dip over @@ -329,7 +329,7 @@ CLASS: { ] } -{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" } +{ "readSelectionFromPasteboard:" char { id SEL id } [ pasteboard-string dup [ [ drop window ] dip swap user-input 1 @@ -338,60 +338,60 @@ CLASS: { } ! Text input -{ "insertText:" "void" { "id" "SEL" "id" } +{ "insertText:" void { id SEL id } [ nip CF>string swap window user-input ] } -{ "hasMarkedText" "char" { "id" "SEL" } +{ "hasMarkedText" char { id SEL } [ 2drop 0 ] } -{ "markedRange" "NSRange" { "id" "SEL" } +{ "markedRange" NSRange { id SEL } [ 2drop 0 0 ] } -{ "selectedRange" "NSRange" { "id" "SEL" } +{ "selectedRange" NSRange { id SEL } [ 2drop 0 0 ] } -{ "setMarkedText:selectedRange:" "void" { "id" "SEL" "id" "NSRange" } +{ "setMarkedText:selectedRange:" void { id SEL id NSRange } [ 2drop 2drop ] } -{ "unmarkText" "void" { "id" "SEL" } +{ "unmarkText" void { id SEL } [ 2drop ] } -{ "validAttributesForMarkedText" "id" { "id" "SEL" } +{ "validAttributesForMarkedText" id { id SEL } [ 2drop NSArray -> array ] } -{ "attributedSubstringFromRange:" "id" { "id" "SEL" "NSRange" } +{ "attributedSubstringFromRange:" id { id SEL NSRange } [ 3drop f ] } -{ "characterIndexForPoint:" "NSUInteger" { "id" "SEL" "NSPoint" } +{ "characterIndexForPoint:" NSUInteger { id SEL NSPoint } [ 3drop 0 ] } -{ "firstRectForCharacterRange:" "NSRect" { "id" "SEL" "NSRange" } +{ "firstRectForCharacterRange:" NSRect { id SEL NSRange } [ 3drop 0 0 0 0 ] } -{ "conversationIdentifier" "NSInteger" { "id" "SEL" } +{ "conversationIdentifier" NSInteger { id SEL } [ drop alien-address ] } ! Initialization -{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" } +{ "updateFactorGadgetSize:" void { id SEL id } [ 2drop [ window ] [ view-dim ] bi >>dim drop yield ] } -{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" } +{ "doCommandBySelector:" void { id SEL SEL } [ 3drop ] } -{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" } +{ "initWithFrame:pixelFormat:" id { id SEL NSRect id } [ [ drop ] 2dip SUPER-> initWithFrame:pixelFormat: @@ -399,13 +399,13 @@ CLASS: { ] } -{ "isOpaque" "char" { "id" "SEL" } +{ "isOpaque" char { id SEL } [ 2drop 0 ] } -{ "dealloc" "void" { "id" "SEL" } +{ "dealloc" void { id SEL } [ drop [ unregister-window ] @@ -430,19 +430,19 @@ CLASS: { { +name+ "FactorWindowDelegate" } } -{ "windowDidMove:" "void" { "id" "SEL" "id" } +{ "windowDidMove:" void { id SEL id } [ 2nip -> object [ -> contentView window ] keep save-position ] } -{ "windowDidBecomeKey:" "void" { "id" "SEL" "id" } +{ "windowDidBecomeKey:" void { id SEL id } [ 2nip -> object -> contentView window focus-world ] } -{ "windowDidResignKey:" "void" { "id" "SEL" "id" } +{ "windowDidResignKey:" void { id SEL id } [ forget-rollover 2nip -> object -> contentView @@ -452,13 +452,13 @@ CLASS: { ] } -{ "windowShouldClose:" "char" { "id" "SEL" "id" } +{ "windowShouldClose:" char { id SEL id } [ 3drop 1 ] } -{ "windowWillClose:" "void" { "id" "SEL" "id" } +{ "windowWillClose:" void { id SEL id } [ 2nip -> object -> contentView window ungraft ] diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 0e07ff6611..a6d73ca80f 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -470,7 +470,7 @@ SYMBOL: nc-buttons : handle-wm-ncbutton ( hWnd uMsg wParam lParam -- ) 2drop nip message>button nc-buttons get - swap [ push ] [ delete ] if ; + swap [ push ] [ remove! drop ] if ; : mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ; @@ -498,13 +498,13 @@ SYMBOL: nc-buttons : handle-wm-buttondown ( hWnd uMsg wParam lParam -- ) [ over set-capture - dup message>button drop nc-buttons get delete + dup message>button drop nc-buttons get remove! drop ] 2dip prepare-mouse send-button-down ; : handle-wm-buttonup ( hWnd uMsg wParam lParam -- ) mouse-captured get [ release-capture ] when pick message>button drop dup nc-buttons get member? [ - nc-buttons get delete 4drop + nc-buttons get remove! drop 4drop ] [ drop prepare-mouse send-button-up ] if ; @@ -537,7 +537,7 @@ SYMBOL: nc-buttons COLOR_BTNFACE GetSysColor RGB>color ; : ?make-glass ( world hwnd -- ) - over window-controls>> textured-background swap memq? [ + over window-controls>> textured-background swap member-eq? [ composition-enabled? [ full-window-margins DwmExtendFrameIntoClientArea drop T{ rgba f 0.0 0.0 0.0 0.0 } @@ -596,7 +596,7 @@ SYMBOL: trace-messages? ! return 0 if you handle the message, else just let DefWindowProc return its val : ui-wndproc ( -- object ) - "uint" { "void*" "uint" "long" "long" } "stdcall" [ + uint { void* uint long long } "stdcall" [ pick trace-messages? get-global [ dup windows-message-name name>> print flush ] when wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 071ac1cffe..f42fdf4616 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -533,8 +533,8 @@ PRIVATE> : join-lines ( string -- string' ) "\n" split - [ rest-slice [ [ blank? ] trim-head-slice ] change-each ] - [ but-last-slice [ [ blank? ] trim-tail-slice ] change-each ] + [ rest-slice [ [ blank? ] trim-head-slice ] map! drop ] + [ but-last-slice [ [ blank? ] trim-tail-slice ] map! drop ] [ " " join ] tri ; diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index e4a0e672d2..8eb11a7753 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -11,7 +11,6 @@ CONSTANT: horizontal { 1 0 } CONSTANT: vertical { 0 1 } TUPLE: gadget < rect -id pref-dim parent children @@ -29,7 +28,7 @@ model ; M: gadget equal? 2drop f ; -M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ; +M: gadget hashcode* nip identity-hashcode ; M: gadget model-changed 2drop ; @@ -306,7 +305,7 @@ M: gadget remove-gadget 2drop ; [ remove-gadget ] [ over (unparent) [ unfocus-gadget ] - [ children>> delete ] + [ children>> remove! drop ] [ nip relayout ] 2tri ] 2bi diff --git a/basis/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor index 83d15911e7..c655e289b0 100644 --- a/basis/ui/gadgets/labels/labels.factor +++ b/basis/ui/gadgets/labels/labels.factor @@ -22,7 +22,7 @@ PREDICATE: string-array < array [ string? ] all? ; PRIVATE> : ?string-lines ( string -- string/array ) - CHAR: \n over memq? [ string-lines ] when ; + CHAR: \n over member-eq? [ string-lines ] when ; ERROR: not-a-string object ; diff --git a/basis/ui/gadgets/menus/menus-docs.factor b/basis/ui/gadgets/menus/menus-docs.factor index bebfaf13fe..b1ae421f52 100644 --- a/basis/ui/gadgets/menus/menus-docs.factor +++ b/basis/ui/gadgets/menus/menus-docs.factor @@ -3,7 +3,7 @@ kernel ; IN: ui.gadgets.menus HELP: -{ $values { "target" object } { "commands" "a sequence of commands" } { "hook" { $quotation "( button -- )" } } { "menu" "a new " { $link gadget } } } +{ $values { "target" object } { "hook" { $quotation "( button -- )" } } { "commands" "a sequence of commands" } { "menu" "a new " { $link gadget } } } { $description "Creates a popup menu of commands which are to be invoked on " { $snippet "target" } ". The " { $snippet "hook" } " quotation is run before a command is invoked." } ; HELP: show-menu diff --git a/basis/ui/gadgets/paragraphs/paragraphs.factor b/basis/ui/gadgets/paragraphs/paragraphs.factor index fd5ae0b246..8002fba4ae 100644 --- a/basis/ui/gadgets/paragraphs/paragraphs.factor +++ b/basis/ui/gadgets/paragraphs/paragraphs.factor @@ -40,13 +40,13 @@ TUPLE: line words height ; dup wrap-words [ ] map ; : line-width ( wrapped-line -- n ) - [ break?>> ] trim-tail-slice [ width>> ] sigma ; + [ break?>> ] trim-tail-slice [ width>> ] map-sum ; : max-line-width ( wrapped-paragraph -- x ) [ words>> line-width ] [ max ] map-reduce ; : sum-line-heights ( wrapped-paragraph -- y ) - [ height>> ] sigma ; + [ height>> ] map-sum ; M: paragraph pref-dim* wrap-paragraph [ max-line-width ] [ sum-line-heights ] bi 2array ; @@ -82,4 +82,4 @@ M: paragraph baseline M: paragraph cap-height pack-cap-height ; -PRIVATE> \ No newline at end of file +PRIVATE> diff --git a/basis/ui/gadgets/scrollers/scrollers-docs.factor b/basis/ui/gadgets/scrollers/scrollers-docs.factor index 1e4b875f28..17adb2bd64 100644 --- a/basis/ui/gadgets/scrollers/scrollers-docs.factor +++ b/basis/ui/gadgets/scrollers/scrollers-docs.factor @@ -24,7 +24,7 @@ HELP: { } related-words HELP: set-scroll-position -{ $values { "scroller" scroller } { "value" "a pair of integers" } } +{ $values { "value" "a pair of integers" } { "scroller" scroller } } { $description "Sets the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ; HELP: relative-scroll-rect diff --git a/basis/ui/gadgets/tracks/tracks-docs.factor b/basis/ui/gadgets/tracks/tracks-docs.factor index 0bbedc8d0d..cf5c94aa6b 100644 --- a/basis/ui/gadgets/tracks/tracks-docs.factor +++ b/basis/ui/gadgets/tracks/tracks-docs.factor @@ -18,7 +18,7 @@ HELP: { $description "Creates a new track which lays out children along the given orientation, either " { $link horizontal } " or " { $link vertical } "." } ; HELP: track-add -{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } } +{ $values { "track" track } { "gadget" gadget } { "constraint" "a number between 0 and 1, or " { $link f } } } { $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ; ABOUT: "ui-track-layout" diff --git a/basis/ui/gadgets/tracks/tracks.factor b/basis/ui/gadgets/tracks/tracks.factor index 4bccab8c98..387f41a6a4 100644 --- a/basis/ui/gadgets/tracks/tracks.factor +++ b/basis/ui/gadgets/tracks/tracks.factor @@ -61,7 +61,7 @@ PRIVATE> pick sizes>> push add-gadget ; M: track remove-gadget - [ [ children>> index ] [ sizes>> ] bi delete-nth ] + [ [ children>> index ] [ sizes>> ] bi remove-nth! drop ] [ call-next-method ] 2bi ; : clear-track ( track -- ) [ sizes>> delete-all ] [ clear-gadget ] bi ; diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index b736c3f74f..8f38cee988 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -120,7 +120,7 @@ M: world request-focus-on ( child gadget -- ) V{ } clone >>window-resources ; : initial-background-color ( attributes -- color ) - window-controls>> textured-background swap memq? + window-controls>> textured-background swap member-eq? [ T{ rgba f 0.0 0.0 0.0 0.0 } ] [ T{ rgba f 1.0 1.0 1.0 1.0 } ] if ; @@ -151,8 +151,8 @@ M: world focusable-child* children>> [ t ] [ first ] if-empty ; M: world children-on nip children>> ; M: world remove-gadget - 2dup layers>> memq? - [ layers>> delq ] [ call-next-method ] if ; + 2dup layers>> member-eq? + [ layers>> remove-eq! drop ] [ call-next-method ] if ; SYMBOL: flush-layout-cache-hook diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index 26eb45c8d0..8e982f8e45 100644 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -297,7 +297,7 @@ SYMBOL: drag-timer : send-button-up ( gesture loc world -- ) move-hand - dup #>> hand-buttons get-global delete + dup #>> hand-buttons get-global remove! drop stop-drag-timer button-gesture ; diff --git a/basis/ui/pens/pens-docs.factor b/basis/ui/pens/pens-docs.factor index 4aa0e50945..4a5ec277f0 100644 --- a/basis/ui/pens/pens-docs.factor +++ b/basis/ui/pens/pens-docs.factor @@ -2,11 +2,11 @@ IN: ui.pens USING: help.markup help.syntax kernel ui.gadgets ; HELP: draw-interior -{ $values { "pen" object } { "gadget" gadget } } +{ $values { "gadget" gadget } { "pen" object } } { $contract "Draws the interior of a gadget by making OpenGL calls. The " { $snippet "interior" } " slot may be set to objects implementing this generic word." } ; HELP: draw-boundary -{ $values { "pen" object } { "gadget" gadget } } +{ $values { "gadget" gadget } { "pen" object } } { $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $snippet "boundary" } " slot may be set to objects implementing this generic word." } ; ARTICLE: "ui-pen-protocol" "UI pen protocol" @@ -23,4 +23,4 @@ $nl { $vocab-subsection "Polygon pens" "ui.pens.polygon" } { $vocab-subsection "Solid pens" "ui.pens.solid" } { $vocab-subsection "Tile pens" "ui.pens.tile" } -"Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ; \ No newline at end of file +"Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ; diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index 173e1c0595..c9c2201e33 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -13,7 +13,7 @@ IN: ui.tools.browser TUPLE: browser-gadget < tool history scroller search-field popup ; -{ 650 400 } browser-gadget set-tool-dim +{ 650 700 } browser-gadget set-tool-dim M: browser-gadget history-value [ control-value ] [ scroller>> scroll-position ] @@ -121,13 +121,17 @@ M: browser-gadget focusable-child* search-field>> ; : browser-help ( -- ) "ui-browser" com-browse ; +: glossary ( -- ) "conventions" com-browse ; + \ browser-help H{ { +nullary+ t } } define-command +\ glossary H{ { +nullary+ t } } define-command browser-gadget "toolbar" f { { T{ key-down f { A+ } "LEFT" } com-back } { T{ key-down f { A+ } "RIGHT" } com-forward } { T{ key-down f { A+ } "H" } com-home } { T{ key-down f f "F1" } browser-help } + { T{ key-down f { A+ } "F1" } glossary } } define-command-map : ?show-help ( link browser -- ) diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor index 5dd0581cf2..b069de1887 100644 --- a/basis/ui/tools/listener/completion/completion.factor +++ b/basis/ui/tools/listener/completion/completion.factor @@ -64,7 +64,7 @@ M: definition-completion row-columns M: word-completion row-color [ vocabulary>> ] [ manifest>> ] bi* { { [ dup not ] [ COLOR: black ] } - { [ 2dup search-vocabs>> memq? ] [ COLOR: black ] } + { [ 2dup search-vocabs>> member-eq? ] [ COLOR: black ] } { [ over ".private" tail? ] [ COLOR: dark-red ] } [ COLOR: dark-gray ] } cond 2nip ; @@ -181,4 +181,4 @@ completion-popup H{ M: completion-popup handle-gesture ( gesture completion -- ? ) 2dup completion-gesture dup [ [ nip hide-glass ] [ invoke-command ] 2bi* f - ] [ 2drop call-next-method ] if ; \ No newline at end of file + ] [ 2drop call-next-method ] if ; diff --git a/basis/ui/tools/listener/listener-docs.factor b/basis/ui/tools/listener/listener-docs.factor index 998020c9c4..8cef10b06f 100644 --- a/basis/ui/tools/listener/listener-docs.factor +++ b/basis/ui/tools/listener/listener-docs.factor @@ -12,7 +12,7 @@ $nl "Interactors implement the " { $link stream-readln } ", " { $link stream-read } " and " { $link read-quot } " generic words." } ; ARTICLE: "ui-listener" "UI listener" -"The graphical listener is based around the terminal listener (" { $link "listener" } ") and adds an input history, and word and vocabulary completion." +"The graphical listener adds input history and word and vocabulary completion. See " { $link "listener" } " for general information on the listener." { $command-map listener-gadget "toolbar" } { $command-map interactor "completion" } { $command-map interactor "interactor" } @@ -48,4 +48,4 @@ TIP: "Scroll the listener from the keyboard by pressing " { $command listener-ga TIP: "Press " { $command tool "common" refresh-all } " or run " { $link refresh-all } " to reload changed source files from disk. " ; -ABOUT: "ui-listener" \ No newline at end of file +ABOUT: "ui-listener" diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 990bafec90..2a948fddc0 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -379,12 +379,16 @@ interactor "completion" f { { T{ key-down f { C+ } "r" } history-completion-popup } } define-command-map +: introduction. ( -- ) + tip-of-the-day. nl + { $strong "Press " { $snippet "F1" } " at any time for help." } print-content nl nl ; + : listener-thread ( listener -- ) dup listener-streams [ [ com-browse ] help-hook set '[ [ _ input>> ] 2dip debugger-popup ] error-hook set error-summary? off - tip-of-the-day. nl + introduction. listener nl "The listener has exited. To start it again, click “Restart Listener”." print diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor index bb23bc0692..3de7c9cc70 100644 --- a/basis/ui/tools/profiler/profiler.factor +++ b/basis/ui/tools/profiler/profiler.factor @@ -107,7 +107,7 @@ M: method-renderer column-titles drop { "" "Method" "Count" } ; : method-matches? ( method generic class -- ? ) [ first ] 2dip { - [ drop dup [ subwords memq? ] [ 2drop t ] if ] + [ drop dup [ subwords member-eq? ] [ 2drop t ] if ] [ nip dup [ swap "method-class" word-prop = ] [ 2drop t ] if ] } 3&& ; diff --git a/basis/ui/traverse/traverse.factor b/basis/ui/traverse/traverse.factor index 11c2a48a2a..5a92a4cea2 100644 --- a/basis/ui/traverse/traverse.factor +++ b/basis/ui/traverse/traverse.factor @@ -20,8 +20,9 @@ TUPLE: node value children ; ] [ [ [ children>> swap first head-slice % ] - [ tuck traverse-step traverse-to-path ] - 2bi + [ nip ] + [ traverse-step traverse-to-path ] + 2tri ] make-node ] if ] if ; @@ -35,7 +36,9 @@ TUPLE: node value children ; ] [ [ [ traverse-step traverse-from-path ] - [ tuck children>> swap first 1 + tail-slice % ] 2bi + [ nip ] + [ children>> swap first 1 + tail-slice % ] + 2tri ] make-node ] if ] if ; diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index c75f5956b3..8260608cd4 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -34,7 +34,7 @@ SYMBOL: windows : raised-window ( world -- ) windows get-global [ [ second eq? ] with find drop ] keep - [ nth ] [ delete-nth ] [ nip ] 2tri push ; + [ nth ] [ remove-nth! drop ] [ nip ] 2tri push ; : focus-gestures ( new old -- ) drop-prefix diff --git a/basis/unicode/collation/collation.factor b/basis/unicode/collation/collation.factor index 5cab884b3c..ea0487c703 100755 --- a/basis/unicode/collation/collation.factor +++ b/basis/unicode/collation/collation.factor @@ -76,10 +76,9 @@ ducet insert-helpers drop [ 0 ] unless* tail-slice ; :: ?combine ( char slice i -- ? ) - [let | str [ i slice nth char suffix ] | - str ducet key? dup - [ str i slice set-nth ] when - ] ; + i slice nth char suffix :> str + str ducet key? dup + [ str i slice set-nth ] when ; : add ( char -- ) dup blocked? [ 1string , ] [ diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index c4392c4c6d..02d9f37023 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -23,7 +23,7 @@ GENERIC: group-struct ( obj -- group/f ) gr_mem>> utf8 alien>strings ; : (group-struct) ( id -- group-struct id group-struct byte-array length void* ) - \ unix:group tuck 4096 + [ \ unix:group ] dip over 4096 [ ] keep f ; : check-group-struct ( group-struct ptr -- group-struct/f ) diff --git a/basis/unix/types/macosx/macosx.factor b/basis/unix/types/macosx/macosx.factor index 421efa60bc..2bebc981f9 100644 --- a/basis/unix/types/macosx/macosx.factor +++ b/basis/unix/types/macosx/macosx.factor @@ -21,5 +21,19 @@ TYPEDEF: __int32_t blksize_t TYPEDEF: long ssize_t TYPEDEF: __int32_t pid_t TYPEDEF: long time_t +TYPEDEF: uint mach_port_t +TYPEDEF: int kern_return_t +TYPEDEF: int boolean_t +TYPEDEF: mach_port_t io_object_t +TYPEDEF: io_object_t io_iterator_t +TYPEDEF: io_object_t io_registry_entry_t +TYPEDEF: io_object_t io_service_t +TYPEDEF: char[128] io_name_t +TYPEDEF: char[512] io_string_t +TYPEDEF: kern_return_t IOReturn -ALIAS: \ No newline at end of file +TYPEDEF: uint IOOptionBits + + + +ALIAS: diff --git a/basis/unix/types/types.factor b/basis/unix/types/types.factor index 7650e9962f..ec638e6f31 100644 --- a/basis/unix/types/types.factor +++ b/basis/unix/types/types.factor @@ -36,6 +36,7 @@ TYPEDEF: __uint64_t fsfilcnt_t TYPEDEF: fsfilcnt_t __fsfilcnt_t TYPEDEF: __uint64_t rlim_t TYPEDEF: uint32_t id_t +TYPEDEF: long clockid_t C-TYPE: DIR C-TYPE: FILE diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index afe24905d6..a672c850d2 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -5,7 +5,7 @@ USING: alien alien.c-types alien.syntax kernel libc sequences continuations byte-arrays strings math namespaces system combinators vocabs.loader accessors stack-checker macros locals generalizations unix.types -io vocabs classes.struct unix.time ; +io vocabs classes.struct unix.time alien.libraries ; IN: unix CONSTANT: PROT_NONE 0 @@ -48,18 +48,17 @@ ERROR: unix-error errno message ; ERROR: unix-system-call-error args errno message word ; MACRO:: unix-system-call ( quot -- ) - [let | n [ quot infer in>> ] - word [ quot first ] | - [ - n ndup quot call dup 0 < [ - drop - n narray - errno dup strerror - word unix-system-call-error - ] [ - n nnip - ] if - ] + quot infer in>> :> n + quot first :> word + [ + n ndup quot call dup 0 < [ + drop + n narray + errno dup strerror + word unix-system-call-error + ] [ + n nnip + ] if ] ; HOOK: open-file os ( path flags mode -- fd ) @@ -221,3 +220,4 @@ FUNCTION: int utimes ( char* path, timeval[2] times ) ; FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; +"librt" "librt.so" "cdecl" add-library diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor index a72fac567a..bf4a9bb76c 100644 --- a/basis/urls/urls.factor +++ b/basis/urls/urls.factor @@ -181,7 +181,7 @@ PRIVATE> clone dup protocol>> '[ _ protocol-port or ] change-port ; ! Literal syntax -SYNTAX: URL" lexer get skip-blank parse-string >url parsed ; +SYNTAX: URL" lexer get skip-blank parse-string >url suffix! ; USING: vocabs vocabs.loader ; diff --git a/basis/validators/validators.factor b/basis/validators/validators.factor index f0ee13dd38..f2c5691452 100644 --- a/basis/validators/validators.factor +++ b/basis/validators/validators.factor @@ -9,7 +9,7 @@ IN: validators >lower "on" = ; : v-default ( str def -- str/def ) - over empty? spin ? ; + [ nip empty? ] 2keep ? ; : v-required ( str -- str ) dup empty? [ "required" throw ] when ; diff --git a/basis/values/values.factor b/basis/values/values.factor index b15dcebe49..4329affe82 100644 --- a/basis/values/values.factor +++ b/basis/values/values.factor @@ -44,8 +44,8 @@ M: value-word definition drop f ; def>> first (>>obj) ; SYNTAX: to: - scan-word literalize parsed - \ set-value parsed ; + scan-word literalize suffix! + \ set-value suffix! ; : get-value ( word -- value ) def>> first obj>> ; diff --git a/basis/vectors/functor/functor.factor b/basis/vectors/functor/functor.factor index b70c7c5050..a2a67d58bc 100644 --- a/basis/vectors/functor/functor.factor +++ b/basis/vectors/functor/functor.factor @@ -24,6 +24,8 @@ M: V new-sequence drop [ ] [ >fixnum ] bi V boa ; inline M: A new-resizable drop ; inline +M: V new-resizable drop ; inline + M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; : >V ( seq -- vector ) V new clone-like ; inline diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor index 11d9dabb3d..e3585952db 100644 --- a/basis/vm/vm.factor +++ b/basis/vm/vm.factor @@ -3,20 +3,77 @@ USING: classes.struct alien.c-types alien.syntax ; IN: vm -TYPEDEF: void* cell +TYPEDEF: uintptr_t cell C-TYPE: context STRUCT: zone - { start cell } - { here cell } - { size cell } - { end cell } ; +{ start cell } +{ here cell } +{ size cell } +{ end cell } ; STRUCT: vm - { stack_chain context* } - { nursery zone } - { cards_offset cell } - { decks_offset cell } - { userenv cell[70] } ; +{ stack_chain context* } +{ nursery zone } +{ cards_offset cell } +{ decks_offset cell } +{ userenv cell[70] } ; : vm-field-offset ( field -- offset ) vm offset-of ; inline + +C-ENUM: +collect-nursery-op +collect-aging-op +collect-to-tenured-op +collect-full-op +collect-compact-op +collect-growing-heap-op ; + +STRUCT: copying-sizes +{ size cell } +{ occupied cell } +{ free cell } ; + +STRUCT: mark-sweep-sizes +{ size cell } +{ occupied cell } +{ total-free cell } +{ contiguous-free cell } +{ free-block-count cell } ; + +STRUCT: data-heap-room +{ nursery copying-sizes } +{ aging copying-sizes } +{ tenured mark-sweep-sizes } +{ cards cell } +{ decks cell } +{ mark-stack cell } ; + +STRUCT: gc-event +{ op uint } +{ data-heap-before data-heap-room } +{ code-heap-before mark-sweep-sizes } +{ data-heap-after data-heap-room } +{ code-heap-after mark-sweep-sizes } +{ cards-scanned cell } +{ decks-scanned cell } +{ code-blocks-scanned cell } +{ start-time ulonglong } +{ total-time cell } +{ card-scan-time cell } +{ code-scan-time cell } +{ data-sweep-time cell } +{ code-sweep-time cell } +{ compaction-time cell } +{ temp-time ulonglong } ; + +STRUCT: dispatch-statistics +{ megamorphic-cache-hits cell } +{ megamorphic-cache-misses cell } + +{ cold-call-to-ic-transitions cell } +{ ic-to-pic-transitions cell } +{ pic-to-mega-transitions cell } + +{ pic-tag-count cell } +{ pic-tuple-count cell } ; diff --git a/basis/windows/com/com-tests.factor b/basis/windows/com/com-tests.factor index ae8ef62c16..25e30829c0 100644 --- a/basis/windows/com/com-tests.factor +++ b/basis/windows/com/com-tests.factor @@ -44,8 +44,8 @@ C: test-implementation [ >>x drop ] ! IInherited::setX } } { IUnrelated { - [ swap x>> + ] ! IUnrelated::xPlus - [ spin x>> * + ] ! IUnrelated::xMulAdd + [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus + [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrelated::xMulAdd } } } dup +test-wrapper+ set [ diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor index bbade332cc..fc7d986cbc 100755 --- a/basis/windows/com/syntax/syntax.factor +++ b/basis/windows/com/syntax/syntax.factor @@ -101,7 +101,7 @@ SYNTAX: COM-INTERFACE: dup save-com-interface-definition define-words-for-com-interface ; -SYNTAX: GUID: scan string>guid parsed ; +SYNTAX: GUID: scan string>guid suffix! ; USING: vocabs vocabs.loader ; diff --git a/basis/windows/com/wrapper/wrapper-docs.factor b/basis/windows/com/wrapper/wrapper-docs.factor index 6a6f6f2bb4..0298e80445 100644 --- a/basis/windows/com/wrapper/wrapper-docs.factor +++ b/basis/windows/com/wrapper/wrapper-docs.factor @@ -27,8 +27,8 @@ COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c} [ >>x drop ] ! IInherited::setX } } { "IUnrelated" { - [ swap x>> + ] ! IUnrelated::xPlus - [ spin x>> * + ] ! IUnrealted::xMulAdd + [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus + [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrealted::xMulAdd } } } """ } ; diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index c007a8c400..696902439c 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -159,7 +159,7 @@ PRIVATE> M: com-wrapper dispose* [ [ free ] each f ] change-vtbls - +live-wrappers+ get-global delete ; + +live-wrappers+ get-global remove! drop ; : com-wrap ( object wrapper -- wrapped-object ) [ vtbls>> ] [ (malloc-wrapped-object) ] bi diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor index ab37f96c2a..4e97cb0e01 100755 --- a/basis/windows/dinput/constants/constants.factor +++ b/basis/windows/dinput/constants/constants.factor @@ -56,13 +56,12 @@ M: array array-base-type first ; DIOBJECTDATAFORMAT ; :: make-DIOBJECTDATAFORMAT-array ( struct array -- alien ) - [let | alien [ array length malloc-DIOBJECTDATAFORMAT-array ] | - array [| args i | - struct args - i alien set-nth - ] each-index - alien - ] ; + array length malloc-DIOBJECTDATAFORMAT-array :> alien + array [| args i | + struct args + i alien set-nth + ] each-index + alien ; : ( dwFlags dwDataSize struct rgodf-array -- alien ) [ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 70c104e2df..80f50ef2b0 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -759,6 +759,34 @@ CONSTANT: PIPE_NOWAIT 1 CONSTANT: PIPE_UNLIMITED_INSTANCES 255 +CONSTANT: EXCEPTION_NONCONTINUABLE HEX: 1 +CONSTANT: STATUS_GUARD_PAGE_VIOLATION HEX: 80000001 +CONSTANT: STATUS_DATATYPE_MISALIGNMENT HEX: 80000002 +CONSTANT: STATUS_BREAKPOINT HEX: 80000003 +CONSTANT: STATUS_SINGLE_STEP HEX: 80000004 +CONSTANT: STATUS_ACCESS_VIOLATION HEX: C0000005 +CONSTANT: STATUS_IN_PAGE_ERROR HEX: C0000006 +CONSTANT: STATUS_INVALID_HANDLE HEX: C0000008 +CONSTANT: STATUS_NO_MEMORY HEX: C0000017 +CONSTANT: STATUS_ILLEGAL_INSTRUCTION HEX: C000001D +CONSTANT: STATUS_NONCONTINUABLE_EXCEPTION HEX: C0000025 +CONSTANT: STATUS_INVALID_DISPOSITION HEX: C0000026 +CONSTANT: STATUS_ARRAY_BOUNDS_EXCEEDED HEX: C000008C +CONSTANT: STATUS_FLOAT_DENORMAL_OPERAND HEX: C000008D +CONSTANT: STATUS_FLOAT_DIVIDE_BY_ZERO HEX: C000008E +CONSTANT: STATUS_FLOAT_INEXACT_RESULT HEX: C000008F +CONSTANT: STATUS_FLOAT_INVALID_OPERATION HEX: C0000090 +CONSTANT: STATUS_FLOAT_OVERFLOW HEX: C0000091 +CONSTANT: STATUS_FLOAT_STACK_CHECK HEX: C0000092 +CONSTANT: STATUS_FLOAT_UNDERFLOW HEX: C0000093 +CONSTANT: STATUS_INTEGER_DIVIDE_BY_ZERO HEX: C0000094 +CONSTANT: STATUS_INTEGER_OVERFLOW HEX: C0000095 +CONSTANT: STATUS_PRIVILEGED_INSTRUCTION HEX: C0000096 +CONSTANT: STATUS_STACK_OVERFLOW HEX: C00000FD +CONSTANT: STATUS_CONTROL_C_EXIT HEX: C000013A +CONSTANT: STATUS_FLOAT_MULTIPLE_FAULTS HEX: C00002B4 +CONSTANT: STATUS_FLOAT_MULTIPLE_TRAPS HEX: C00002B5 + LIBRARY: kernel32 ! FUNCTION: _hread ! FUNCTION: _hwrite @@ -1594,8 +1622,8 @@ FUNCTION: HANDLE OpenProcess ( DWORD dwDesiredAccess, BOOL bInheritHandle, DWORD ! FUNCTION: QueryDosDeviceW ! FUNCTION: QueryInformationJobObject ! FUNCTION: QueryMemoryResourceNotification -! FUNCTION: QueryPerformanceCounter -! FUNCTION: QueryPerformanceFrequency +FUNCTION: BOOL QueryPerformanceCounter ( LARGE_INTEGER* lpPerformanceCount ) ; +FUNCTION: BOOL QueryPerformanceFrequency ( LARGE_INTEGER* lpFrequency ) ; ! FUNCTION: QueryWin31IniFilesMappedToRegistry ! FUNCTION: QueueUserAPC ! FUNCTION: QueueUserWorkItem diff --git a/basis/windows/shell32/shell32.factor b/basis/windows/shell32/shell32.factor index bede62c813..08474d4bdd 100755 --- a/basis/windows/shell32/shell32.factor +++ b/basis/windows/shell32/shell32.factor @@ -88,7 +88,7 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi ALIAS: ShellExecute ShellExecuteW : open-in-explorer ( dir -- ) - [ f "open" ] dip (normalize-path) f f SW_SHOWNORMAL ShellExecute drop ; + [ f "open" ] dip absolute-path f f SW_SHOWNORMAL ShellExecute drop ; : shell32-directory ( n -- str ) f swap f SHGFP_TYPE_DEFAULT diff --git a/basis/xml/data/data.factor b/basis/xml/data/data.factor index 6cd975d42d..419dfbba53 100644 --- a/basis/xml/data/data.factor +++ b/basis/xml/data/data.factor @@ -66,7 +66,7 @@ M: attrs clear-assoc f >>alist drop ; M: attrs delete-at [ nip ] [ attr@ drop ] 2bi - [ swap alist>> delete-nth ] [ drop ] if* ; + [ swap alist>> remove-nth! drop ] [ drop ] if* ; M: attrs clone alist>> clone ; diff --git a/basis/xml/entities/html/html.factor b/basis/xml/entities/html/html.factor index 04c0b66063..fd8480307a 100644 --- a/basis/xml/entities/html/html.factor +++ b/basis/xml/entities/html/html.factor @@ -11,8 +11,8 @@ VALUE: html-entities : get-html ( -- table ) { "lat1" "special" "symbol" } [ - "vocab:xml/entities/html/xhtml-" - swap ".ent" 3append read-entities-file + "vocab:xml/entities/html/xhtml-" ".ent" surround + read-entities-file ] map first3 assoc-union assoc-union ; get-html to: html-entities diff --git a/basis/xml/syntax/syntax-docs.factor b/basis/xml/syntax/syntax-docs.factor index 9e0c50a37d..376c9b3f0c 100644 --- a/basis/xml/syntax/syntax-docs.factor +++ b/basis/xml/syntax/syntax-docs.factor @@ -74,12 +74,12 @@ $nl "Here is an example of the locals version:" { $example """USING: locals urls xml.syntax xml.writer ; -[let | - number [ 3 ] - false [ f ] - url [ URL" http://factorcode.org/" ] - string [ "hello" ] - word [ \\ drop ] | +[let + 3 :> number + f :> false + URL" http://factorcode.org/" :> url + "hello" :> string + \\ drop :> word diff --git a/basis/xml/syntax/syntax-tests.factor b/basis/xml/syntax/syntax-tests.factor index 5c1669adb1..40c86237a7 100644 --- a/basis/xml/syntax/syntax-tests.factor +++ b/basis/xml/syntax/syntax-tests.factor @@ -54,8 +54,7 @@ XML-NS: foo http://blah.com y """ ] [ - [let* | a [ "one" ] c [ "two" ] x [ "y" ] - d [ [XML <-x-> XML] ] | + [let "one" :> a "two" :> c "y" :> x [XML <-x-> XML] :> d <-a-> /> <-d-> XML> pprint-xml>string diff --git a/basis/xml/syntax/syntax.factor b/basis/xml/syntax/syntax.factor index 5b2a0bcfb4..4b9900d3b0 100644 --- a/basis/xml/syntax/syntax.factor +++ b/basis/xml/syntax/syntax.factor @@ -156,16 +156,16 @@ MACRO: interpolate-xml ( xml -- quot ) : collect ( accum variables -- accum ? ) { { [ dup empty? ] [ drop f ] } ! Just a literal - { [ dup [ ] all? ] [ >search-hash parsed t ] } ! locals - { [ dup [ not ] all? ] [ length parsed \ nenum parsed t ] } ! fry + { [ dup [ ] all? ] [ >search-hash suffix! t ] } ! locals + { [ dup [ not ] all? ] [ length suffix! \ nenum suffix! t ] } ! fry [ drop "XML interpolation contains both fry and locals" throw ] ! mixed } cond ; : parse-def ( accum delimiter quot -- accum ) [ parse-multiline-string [ blank? ] trim ] dip call [ extract-variables collect ] keep swap - [ number<-> parsed ] dip - [ \ interpolate-xml parsed ] when ; inline + [ number<-> suffix! ] dip + [ \ interpolate-xml suffix! ] when ; inline PRIVATE> diff --git a/basis/xml/tests/encodings.factor b/basis/xml/tests/encodings.factor index 2f1d73f9ca..6149910a55 100644 --- a/basis/xml/tests/encodings.factor +++ b/basis/xml/tests/encodings.factor @@ -1,5 +1,4 @@ -USING: xml xml.data xml.traversal tools.test accessors kernel -io.encodings.8-bit ; +USING: xml xml.data xml.traversal tools.test accessors kernel ; [ "\u000131" ] [ "vocab:xml/tests/latin5.xml" file>xml children>string ] unit-test [ "\u0000e9" ] [ "vocab:xml/tests/latin1.xml" file>xml children>string ] unit-test diff --git a/basis/xmode/catalog/catalog.factor b/basis/xmode/catalog/catalog.factor index 894ec264ab..40b8e2191c 100644 --- a/basis/xmode/catalog/catalog.factor +++ b/basis/xmode/catalog/catalog.factor @@ -48,7 +48,7 @@ SYMBOL: rule-sets : get-rule-set ( name -- rule-sets rules ) dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if* - dup -roll at* [ nip ] [ drop no-such-rule-set ] if ; + [ at* [ nip ] [ drop no-such-rule-set ] if ] keep swap ; DEFER: finalize-rule-set @@ -110,7 +110,7 @@ ERROR: mutually-recursive-rulesets ruleset ; dup [ glob-matches? ] [ 2drop f ] if ; : suitable-mode? ( file-name first-line mode -- ? ) - tuck first-line-glob>> ?glob-matches + [ nip ] 2keep first-line-glob>> ?glob-matches [ 2drop t ] [ file-name-glob>> ?glob-matches ] if ; : find-mode ( file-name first-line -- mode ) diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index d3a4f1e9a2..6b8db76ac9 100755 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -86,7 +86,7 @@ M: regexp text-matches? [ >string ] dip first-match dup [ to>> ] when ; : rule-start-matches? ( rule -- match-count/f ) - dup start>> tuck swap can-match-here? [ + [ start>> dup ] keep can-match-here? [ rest-of-line swap text>> text-matches? ] [ drop f @@ -96,7 +96,7 @@ M: regexp text-matches? dup mark-following-rule? [ dup start>> swap can-match-here? 0 and ] [ - dup end>> tuck swap can-match-here? [ + [ end>> dup ] keep can-match-here? [ rest-of-line swap text>> context get end>> or text-matches? @@ -170,7 +170,7 @@ M: seq-rule handle-rule-start ?end-rule mark-token add-remaining-token - tuck body-token>> next-token, + [ body-token>> next-token, ] keep delegate>> [ push-context ] when* ; UNION: abstract-span-rule span-rule eol-span-rule ; @@ -179,7 +179,7 @@ M: abstract-span-rule handle-rule-start ?end-rule mark-token add-remaining-token - tuck rule-match-token* next-token, + [ rule-match-token* next-token, ] keep ! ... end subst ... dup context get (>>in-rule) delegate>> push-context ; @@ -190,7 +190,7 @@ M: span-rule handle-rule-end M: mark-following-rule handle-rule-start ?end-rule mark-token add-remaining-token - tuck rule-match-token* next-token, + [ rule-match-token* next-token, ] keep f context get (>>end) context get (>>in-rule) ; diff --git a/basis/xmode/rules/rules.factor b/basis/xmode/rules/rules.factor index 51f216fa44..ffe6db3b46 100644 --- a/basis/xmode/rules/rules.factor +++ b/basis/xmode/rules/rules.factor @@ -43,7 +43,7 @@ MEMO: standard-rule-set ( id -- ruleset ) : ?push-all ( seq1 seq2 -- seq1+seq2 ) [ - over [ [ V{ } like ] dip over push-all ] [ nip ] if + over [ [ V{ } like ] dip append! ] [ nip ] if ] when* ; : rule-set-no-word-sep* ( ruleset -- str ) diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 9fb9c042ee..6787d3714b 100644 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -79,7 +79,7 @@ HELP: alien-callback-error HELP: alien-callback { $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" "a quotation" } { "alien" alien } } { $description - "Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "\"void\"" } " indicates that no value is to be returned." + "Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "void" } " indicates that no value is to be returned." $nl "When a compiled reference to this word is called, it pushes the callback's alien address on the data stack. This address can be passed to any C function expecting a C function pointer with the correct signature. The callback is actually generated when the word calling " { $link alien-callback } " is compiled." $nl @@ -90,7 +90,7 @@ HELP: alien-callback "A simple example, showing a C function which returns the difference of two given integers:" { $code ": difference-callback ( -- alien )" - " \"int\" { \"int\" \"int\" } \"cdecl\" [ - ] alien-callback ;" + " int { int int } \"cdecl\" [ - ] alien-callback ;" } } { $errors "Throws an " { $link alien-callback-error } " if the word calling " { $link alien-callback } " is not compiled." } ; diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 368f0b25e7..91dd150e8f 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -4,19 +4,9 @@ USING: accessors assocs kernel math namespaces sequences system kernel.private byte-arrays arrays init ; IN: alien -! Some predicate classes used by the compiler for optimization -! purposes -PREDICATE: simple-alien < alien underlying>> not ; +PREDICATE: pinned-alien < alien underlying>> not ; -UNION: simple-c-ptr -simple-alien POSTPONE: f byte-array ; - -DEFER: pinned-c-ptr? - -PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ; - -UNION: pinned-c-ptr - pinned-alien POSTPONE: f ; +UNION: pinned-c-ptr pinned-alien POSTPONE: f ; GENERIC: >c-ptr ( obj -- c-ptr ) @@ -33,7 +23,7 @@ M: alien expired? expired>> ; M: f expired? drop t ; : ( address -- alien ) - f { simple-c-ptr } declare ; inline + f { pinned-c-ptr } declare ; inline : ( -- alien ) -1 t >>expired ; inline @@ -49,7 +39,8 @@ M: alien equal? 2drop f ] if ; -M: simple-alien hashcode* nip dup expired>> [ drop 1234 ] [ alien-address ] if ; +M: pinned-alien hashcode* + nip dup expired>> [ drop 1234 ] [ alien-address ] if ; ERROR: alien-callback-error ; diff --git a/core/alien/strings/strings-tests.factor b/core/alien/strings/strings-tests.factor index c1b5a9e159..c6516d3839 100644 --- a/core/alien/strings/strings-tests.factor +++ b/core/alien/strings/strings-tests.factor @@ -1,6 +1,6 @@ -USING: alien.strings alien.c-types alien.data tools.test kernel libc -io.encodings.8-bit io.encodings.utf8 io.encodings.utf16 -io.encodings.utf16n io.encodings.ascii alien io.encodings.string ; +USING: alien.strings alien.c-types alien.data tools.test +kernel libc io.encodings.utf8 io.encodings.utf16 io.encodings.utf16n +io.encodings.ascii alien io.encodings.string io.encodings.8-bit.latin1 ; IN: alien.strings.tests [ "\u0000ff" ] diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor index 9dd6ae425f..8e09fa8c2c 100644 --- a/core/alien/strings/strings.factor +++ b/core/alien/strings/strings.factor @@ -21,7 +21,7 @@ M: f alien>string ERROR: invalid-c-string string ; : check-string ( string -- ) - 0 over memq? [ invalid-c-string ] [ drop ] if ; + 0 over member-eq? [ invalid-c-string ] [ drop ] if ; GENERIC# string>alien 1 ( string encoding -- byte-array ) diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 22556ef94c..5a69df8cb4 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -28,7 +28,7 @@ ARTICLE: "enums" "Enumerations" HELP: enum { $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence." $nl -"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ; +"Enumerations are mutable; note that deleting a key calls " { $link remove-nth! } ", which results in all subsequent elements being shifted down." } ; HELP: { $values { "seq" sequence } { "enum" enum } } @@ -96,9 +96,7 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" update assoc-union assoc-diff - remove-all substitute - substitute-here extract-keys } { $see-also key? assoc-any? assoc-all? "sets" } ; @@ -348,17 +346,6 @@ HELP: assoc-diff { $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } } { $description "Outputs an assoc consisting of all entries from " { $snippet "assoc1" } " whose key is not contained in " { $snippet "assoc2" } "." } ; -HELP: remove-all -{ $values { "assoc" assoc } { "seq" "a sequence" } { "subseq" "a new sequence" } } -{ $description "Constructs a sequence consisting of all elements in " { $snippet "seq" } " which do not appear as keys in " { $snippet "assoc" } "." } -{ $notes "The values of the keys in the assoc are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." } -{ $side-effects "assoc" } ; - -HELP: substitute-here -{ $values { "seq" "a mutable sequence" } { "assoc" assoc } } -{ $description "Replaces elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " with the corresponding values, acting as the identity on all other elements." } -{ $errors "Throws an error if " { $snippet "assoc" } " contains values whose types are not permissible in " { $snippet "seq" } "." } -{ $side-effects "seq" } ; HELP: substitute { $values { "seq" sequence } { "assoc" assoc } { "newseq" sequence } } diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 53c3adcf3e..646f9a4561 100644 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -79,8 +79,6 @@ H{ } clone "cache-test" set H{ { 1 f } } H{ { 1 f } } assoc-intersect ] unit-test -[ { 1 3 } ] [ H{ { 2 2 } } { 1 2 3 } remove-all ] unit-test - [ H{ { "hi" 2 } { 3 4 } } ] [ "hi" 1 H{ { 1 2 } { 3 4 } } clone [ rename-at ] keep ] unit-test diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index e633a54843..e441855ed1 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -135,12 +135,6 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : assoc-diff ( assoc1 assoc2 -- diff ) [ nip key? not ] curry assoc-filter ; -: remove-all ( assoc seq -- subseq ) - swap [ key? not ] curry filter ; - -: substitute-here ( seq assoc -- ) - substituter change-each ; - : substitute ( seq assoc -- newseq ) substituter map ; @@ -195,7 +189,7 @@ M: sequence clear-assoc delete-all ; inline M: sequence delete-at [ nip ] [ search-alist nip ] 2bi - [ swap delete-nth ] [ drop ] if* ; + [ swap remove-nth! drop ] [ drop ] if* ; M: sequence assoc-size length ; inline @@ -208,6 +202,10 @@ M: sequence assoc-like M: sequence >alist ; inline ! Override sequence => assoc instance for f +M: f at* 2drop f f ; inline + +M: f assoc-size drop 0 ; inline + M: f clear-assoc drop ; inline M: f assoc-like drop dup assoc-empty? [ drop f ] when ; inline @@ -224,7 +222,7 @@ M: enum at* M: enum set-at seq>> set-nth ; inline -M: enum delete-at seq>> delete-nth ; inline +M: enum delete-at seq>> remove-nth! drop ; inline M: enum >alist ( enum -- alist ) seq>> [ length ] keep zip ; inline diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index 5ed92b7776..61bff38201 100644 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -5,32 +5,30 @@ hashtables vectors strings sbufs arrays quotations assocs layouts classes.tuple.private kernel.private ; -BIN: 111 tag-mask set -8 num-tags set -3 tag-bits set +16 data-alignment set -15 num-types set +BIN: 1111 tag-mask set +4 tag-bits set + +14 num-types set 32 mega-cache-size set H{ - { fixnum BIN: 000 } - { bignum BIN: 001 } - { array BIN: 010 } - { float BIN: 011 } - { quotation BIN: 100 } - { POSTPONE: f BIN: 101 } - { object BIN: 110 } - { hi-tag BIN: 110 } - { tuple BIN: 111 } -} tag-numbers set - -tag-numbers get H{ + { fixnum 0 } + { POSTPONE: f 1 } + { array 2 } + { float 3 } + { quotation 4 } + { bignum 5 } + { alien 6 } + { tuple 7 } { wrapper 8 } { byte-array 9 } { callstack 10 } { string 11 } { word 12 } { dll 13 } - { alien 14 } -} assoc-union type-numbers set +} type-numbers set + +2 header-bits set diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 8058707efa..ca9056805e 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -16,7 +16,7 @@ H{ } clone sub-primitives set "vocab:bootstrap/syntax.factor" parse-file -"vocab:cpu/" architecture get { +architecture get { { "x86.32" "x86/32" } { "winnt-x86.64" "x86/64/winnt" } { "unix-x86.64" "x86/64/unix" } @@ -24,7 +24,7 @@ H{ } clone sub-primitives set { "macosx-ppc" "ppc/macosx" } { "arm" "arm" } } ?at [ "Bad architecture: " prepend throw ] unless -"/bootstrap.factor" 3append parse-file +"vocab:cpu/" "/bootstrap.factor" surround parse-file "vocab:bootstrap/layouts/layouts.factor" parse-file @@ -55,6 +55,8 @@ num-types get f builtins set bootstrapping? on +[ + ! Create some empty vocabs where the below primitives and ! classes will go { @@ -99,6 +101,7 @@ bootstrapping? on "system" "system.private" "threads.private" + "tools.dispatch.private" "tools.profiler.private" "words" "words.private" @@ -177,10 +180,6 @@ bi "object?" "kernel" vocab-words delete-at -! Class of objects with object tag -"hi-tag" "kernel.private" create -builtins get num-tags get tail define-union-class - ! Empty class with no instances "null" "kernel" create [ f { } f union-class define-class ] @@ -343,7 +342,6 @@ tuple { "swapd" "kernel" (( x y z -- y x z )) } { "nip" "kernel" (( x y -- y )) } { "2nip" "kernel" (( x y z -- z )) } - { "tuck" "kernel" (( x y -- y x y )) } { "over" "kernel" (( x y -- x y x )) } { "pick" "kernel" (( x y z -- x y z x )) } { "swap" "kernel" (( x y -- y x )) } @@ -423,7 +421,6 @@ tuple { "minor-gc" "memory" (( -- )) } { "gc" "memory" (( -- )) } { "compact-gc" "memory" (( -- )) } - { "gc-stats" "memory" f } { "(save-image)" "memory.private" (( path -- )) } { "(save-image-and-exit)" "memory.private" (( path -- )) } { "datastack" "kernel" (( -- ds )) } @@ -433,8 +430,8 @@ tuple { "set-retainstack" "kernel" (( rs -- )) } { "set-callstack" "kernel" (( cs -- )) } { "(exit)" "system" (( n -- )) } - { "data-room" "memory" (( -- cards decks generations )) } - { "code-room" "memory" (( -- code-total code-used code-free largest-free-block )) } + { "data-room" "memory" (( -- data-room )) } + { "code-room" "memory" (( -- code-room )) } { "micros" "system" (( -- us )) } { "modify-code-heap" "compiler.units" (( alist -- )) } { "(dlopen)" "alien.libraries" (( path -- dll )) } @@ -477,9 +474,7 @@ tuple { "resize-array" "arrays" (( n array -- newarray )) } { "resize-string" "strings" (( n str -- newstr )) } { "" "arrays" (( n elt -- array )) } - { "begin-scan" "memory" (( -- )) } - { "next-object" "memory" (( -- obj )) } - { "end-scan" "memory" (( -- )) } + { "all-instances" "memory" (( -- array )) } { "size" "memory" (( obj -- n )) } { "die" "kernel" (( -- )) } { "(fopen)" "io.streams.c" (( path mode -- alien )) } @@ -509,7 +504,6 @@ tuple { "resize-byte-array" "byte-arrays" (( n byte-array -- newbyte-array )) } { "dll-valid?" "alien.libraries" (( dll -- ? )) } { "unimplemented" "kernel.private" (( -- * )) } - { "gc-reset" "memory" (( -- )) } { "jit-compile" "quotations" (( quot -- )) } { "load-locals" "locals.backend" (( ... n -- )) } { "check-datastack" "kernel.private" (( array in# out# -- ? )) } @@ -517,16 +511,20 @@ tuple { "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) } { "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) } { "lookup-method" "generic.single.private" (( object methods -- method )) } - { "reset-dispatch-stats" "generic.single" (( -- )) } - { "dispatch-stats" "generic.single" (( -- stats )) } - { "reset-inline-cache-stats" "generic.single" (( -- )) } - { "inline-cache-stats" "generic.single" (( -- stats )) } + { "reset-dispatch-stats" "tools.dispatch.private" (( -- )) } + { "dispatch-stats" "tools.dispatch.private" (( -- stats )) } { "optimized?" "words" (( word -- ? )) } { "quot-compiled?" "quotations" (( quot -- ? )) } { "vm-ptr" "vm" (( -- ptr )) } { "strip-stack-traces" "kernel.private" (( -- )) } { "" "alien" (( word -- alien )) } + { "enable-gc-events" "memory" (( -- )) } + { "disable-gc-events" "memory" (( -- events )) } + { "(identity-hashcode)" "kernel.private" (( obj -- code )) } + { "compute-identity-hashcode" "kernel.private" (( obj -- )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number "build" "kernel" create build 1 + [ ] curry (( -- n )) define-declared + +] with-compilation-unit diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 1e8ebe2938..29d0a311a3 100644 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -14,28 +14,23 @@ IN: bootstrap.stage1 load-help? off { "resource:core" } vocab-roots set -! Create a boot quotation for the target +! Create a boot quotation for the target by collecting all top-level +! forms into a quotation, surrounded by some boilerplate. [ [ - ! Rehash hashtables, since bootstrap.image creates them - ! using the host image's hashing algorithms. We don't - ! use each-object here since the catch stack isn't yet - ! set up. - gc - begin-scan - [ hashtable? ] pusher [ (each-object) ] dip - end-scan - [ rehash ] each + ! Rehash hashtables first, since bootstrap.image creates + ! them using the host image's hashing algorithms. + [ hashtable? ] instances [ rehash ] each boot ] % "math.integers" require "math.floats" require "memory" require - + "io.streams.c" require "vocabs.loader" require - + "syntax" require "bootstrap.layouts" require diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 57be2fb90f..bb159f04df 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -1,90 +1,93 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: words words.symbol sequences vocabs kernel ; +USING: words words.symbol sequences vocabs kernel +compiler.units ; IN: bootstrap.syntax -"syntax" create-vocab drop +[ + "syntax" create-vocab drop -{ - "!" - "\"" - "#!" - "(" - "((" - ":" - ";" - "" - "SBUF\"" - "SINGLETON:" - "SINGLETONS:" - "SYMBOL:" - "SYMBOLS:" - "CONSTANT:" - "TUPLE:" - "SLOT:" - "T{" - "UNION:" - "INTERSECTION:" - "USE:" - "UNUSE:" - "USING:" - "QUALIFIED:" - "QUALIFIED-WITH:" - "FROM:" - "EXCLUDE:" - "RENAME:" - "ALIAS:" - "SYNTAX:" - "V{" - "W{" - "[" - "\\" - "M\\" - "]" - "delimiter" - "deprecated" - "f" - "flushable" - "foldable" - "inline" - "recursive" - "t" - "{" - "}" - "CS{" - "<<" - ">>" - "call-next-method" - "initial:" - "read-only" - "call(" - "execute(" -} [ "syntax" create drop ] each + { + "!" + "\"" + "#!" + "(" + "((" + ":" + ";" + "" + "SBUF\"" + "SINGLETON:" + "SINGLETONS:" + "SYMBOL:" + "SYMBOLS:" + "CONSTANT:" + "TUPLE:" + "SLOT:" + "T{" + "UNION:" + "INTERSECTION:" + "USE:" + "UNUSE:" + "USING:" + "QUALIFIED:" + "QUALIFIED-WITH:" + "FROM:" + "EXCLUDE:" + "RENAME:" + "ALIAS:" + "SYNTAX:" + "V{" + "W{" + "[" + "\\" + "M\\" + "]" + "delimiter" + "deprecated" + "f" + "flushable" + "foldable" + "inline" + "recursive" + "t" + "{" + "}" + "CS{" + "<<" + ">>" + "call-next-method" + "initial:" + "read-only" + "call(" + "execute(" + } [ "syntax" create drop ] each -"t" "syntax" lookup define-symbol + "t" "syntax" lookup define-symbol +] with-compilation-unit diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index 287e972405..4f6ade8580 100644 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -43,4 +43,6 @@ M: byte-array like M: byte-array new-resizable drop ; inline +M: byte-vector new-resizable drop ; inline + INSTANCE: byte-vector growable diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor index 1b2ea7dfd4..7b931c80e8 100644 --- a/core/classes/algebra/algebra-docs.factor +++ b/core/classes/algebra/algebra-docs.factor @@ -11,13 +11,7 @@ ARTICLE: "class-operations" "Class operations" class-and class-or classes-intersect? -} -"Low-level implementation detail:" -{ $subsections flatten-class - flatten-builtin-class - class-types - class-tags } ; ARTICLE: "class-linearization" "Class linearization" @@ -46,18 +40,10 @@ $nl "Metaclass order:" { $subsections rank-class } ; -HELP: flatten-builtin-class -{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } } -{ $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ; - HELP: flatten-class { $values { "class" class } { "assoc" "an assoc whose keys are classes" } } { $description "Outputs a set of builtin and tuple classes whose union is the smallest cover of " { $snippet "class" } "." } ; -HELP: class-types -{ $values { "class" class } { "seq" "an increasing sequence of integers" } } -{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ; - HELP: class<= { $values { "first" "a class" } { "second" "a class" } { "?" "a boolean" } } { $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." } diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 855a15b66f..c016b0169b 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -7,36 +7,42 @@ stack-checker effects kernel.private sbufs math.order classes.tuple accessors generic.private ; IN: classes.algebra.tests -: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ; - -: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ; - -[ t ] [ object object object class-and* ] unit-test -[ t ] [ fixnum object fixnum class-and* ] unit-test -[ t ] [ object fixnum fixnum class-and* ] unit-test -[ t ] [ fixnum fixnum fixnum class-and* ] unit-test -[ t ] [ fixnum integer fixnum class-and* ] unit-test -[ t ] [ integer fixnum fixnum class-and* ] unit-test - -[ t ] [ vector fixnum null class-and* ] unit-test -[ t ] [ number object number class-and* ] unit-test -[ t ] [ object number number class-and* ] unit-test -[ t ] [ slice reversed null class-and* ] unit-test -[ t ] [ \ f class-not \ f null class-and* ] unit-test -[ t ] [ \ f class-not \ f object class-or* ] unit-test - TUPLE: first-one ; TUPLE: second-one ; UNION: both first-one union-class ; -[ t ] [ both tuple classes-intersect? ] unit-test -[ t ] [ vector virtual-sequence null class-and* ] unit-test -[ f ] [ vector virtual-sequence classes-intersect? ] unit-test +PREDICATE: no-docs < word "documentation" word-prop not ; -[ t ] [ number vector class-or sequence classes-intersect? ] unit-test +UNION: no-docs-union no-docs integer ; -[ f ] [ number vector class-and sequence classes-intersect? ] unit-test +TUPLE: a ; +TUPLE: b ; +UNION: c a b ; +TUPLE: tuple-example ; + +TUPLE: a1 ; +TUPLE: b1 ; +TUPLE: c1 ; + +UNION: x1 a1 b1 ; +UNION: y1 a1 c1 ; +UNION: z1 b1 c1 ; + +SINGLETON: sa +SINGLETON: sb +SINGLETON: sc + +INTERSECTION: empty-intersection ; + +INTERSECTION: generic-class generic class ; + +UNION: union-with-one-member a ; + +MIXIN: mixin-with-one-member +INSTANCE: union-with-one-member mixin-with-one-member + +! class<= [ t ] [ \ fixnum \ integer class<= ] unit-test [ t ] [ \ fixnum \ fixnum class<= ] unit-test [ f ] [ \ integer \ fixnum class<= ] unit-test @@ -50,73 +56,41 @@ UNION: both first-one union-class ; [ f ] [ \ reversed \ slice class<= ] unit-test [ f ] [ \ slice \ reversed class<= ] unit-test -PREDICATE: no-docs < word "documentation" word-prop not ; - -UNION: no-docs-union no-docs integer ; - [ t ] [ no-docs no-docs-union class<= ] unit-test [ f ] [ no-docs-union no-docs class<= ] unit-test -TUPLE: a ; -TUPLE: b ; -UNION: c a b ; - [ t ] [ \ c \ tuple class<= ] unit-test [ f ] [ \ tuple \ c class<= ] unit-test [ t ] [ \ tuple-class \ class class<= ] unit-test [ f ] [ \ class \ tuple-class class<= ] unit-test -TUPLE: tuple-example ; - [ t ] [ \ null \ tuple-example class<= ] unit-test [ f ] [ \ object \ tuple-example class<= ] unit-test [ f ] [ \ object \ tuple-example class<= ] unit-test [ t ] [ \ tuple-example \ tuple class<= ] unit-test [ f ] [ \ tuple \ tuple-example class<= ] unit-test -TUPLE: a1 ; -TUPLE: b1 ; -TUPLE: c1 ; - -UNION: x1 a1 b1 ; -UNION: y1 a1 c1 ; -UNION: z1 b1 c1 ; - [ f ] [ z1 x1 y1 class-and class<= ] unit-test [ t ] [ x1 y1 class-and a1 class<= ] unit-test -[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test - [ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test [ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test -[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test +[ t ] [ growable tuple sequence class-and class<= ] unit-test -[ f ] [ growable \ hi-tag classes-intersect? ] unit-test - -[ t ] [ - growable tuple sequence class-and class<= -] unit-test - -[ t ] [ - growable assoc class-and tuple class<= -] unit-test +[ t ] [ growable assoc class-and tuple class<= ] unit-test [ t ] [ object \ f \ f class-not class-or class<= ] unit-test [ t ] [ fixnum class-not integer class-and bignum class= ] unit-test -[ f ] [ integer integer class-not classes-intersect? ] unit-test - [ t ] [ array number class-not class<= ] unit-test [ f ] [ bignum number class-not class<= ] unit-test -[ vector ] [ vector class-not class-not ] unit-test - [ t ] [ fixnum fixnum bignum class-or class<= ] unit-test [ f ] [ fixnum class-not integer class-and array class<= ] unit-test @@ -129,12 +103,99 @@ UNION: z1 b1 c1 ; [ t ] [ number class-not integer class-not class<= ] unit-test -[ t ] [ vector array class-not class-and vector class= ] unit-test +[ f ] [ fixnum class-not integer class<= ] unit-test + +[ t ] [ object empty-intersection class<= ] unit-test +[ t ] [ empty-intersection object class<= ] unit-test +[ t ] [ \ f class-not empty-intersection class<= ] unit-test +[ f ] [ empty-intersection \ f class-not class<= ] unit-test +[ t ] [ \ number empty-intersection class<= ] unit-test +[ t ] [ empty-intersection class-not null class<= ] unit-test +[ t ] [ null empty-intersection class-not class<= ] unit-test + +[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test +[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test + +[ t ] [ object \ f class-not \ f class-or class<= ] unit-test + +[ t ] [ + fixnum class-not + fixnum fixnum class-not class-or + class<= +] unit-test + +[ t ] [ generic-class generic class<= ] unit-test +[ t ] [ generic-class \ class class<= ] unit-test + +[ t ] [ a union-with-one-member class<= ] unit-test +[ f ] [ union-with-one-member class-not integer class<= ] unit-test + +! class-and +: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ; + +[ t ] [ object object object class-and* ] unit-test +[ t ] [ fixnum object fixnum class-and* ] unit-test +[ t ] [ object fixnum fixnum class-and* ] unit-test +[ t ] [ fixnum fixnum fixnum class-and* ] unit-test +[ t ] [ fixnum integer fixnum class-and* ] unit-test +[ t ] [ integer fixnum fixnum class-and* ] unit-test + +[ t ] [ vector fixnum null class-and* ] unit-test +[ t ] [ number object number class-and* ] unit-test +[ t ] [ object number number class-and* ] unit-test +[ t ] [ slice reversed null class-and* ] unit-test +[ t ] [ \ f class-not \ f null class-and* ] unit-test + +[ t ] [ vector virtual-sequence null class-and* ] unit-test + +[ t ] [ vector array class-not vector class-and* ] unit-test + +! class-or +: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ; + +[ t ] [ \ f class-not \ f object class-or* ] unit-test + +! class-not +[ vector ] [ vector class-not class-not ] unit-test + +! classes-intersect? +[ t ] [ both tuple classes-intersect? ] unit-test +[ f ] [ vector virtual-sequence classes-intersect? ] unit-test + +[ t ] [ number vector class-or sequence classes-intersect? ] unit-test + +[ f ] [ number vector class-and sequence classes-intersect? ] unit-test + +[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test + +[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test + +[ f ] [ integer integer class-not classes-intersect? ] unit-test [ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test -[ f ] [ fixnum class-not integer class<= ] unit-test +[ t ] [ \ word generic-class classes-intersect? ] unit-test +[ f ] [ number generic-class classes-intersect? ] unit-test +[ f ] [ sa sb classes-intersect? ] unit-test + +[ t ] [ a union-with-one-member classes-intersect? ] unit-test +[ f ] [ fixnum union-with-one-member classes-intersect? ] unit-test +[ t ] [ object union-with-one-member classes-intersect? ] unit-test + +[ t ] [ union-with-one-member a classes-intersect? ] unit-test +[ f ] [ union-with-one-member fixnum classes-intersect? ] unit-test +[ t ] [ union-with-one-member object classes-intersect? ] unit-test + +[ t ] [ a mixin-with-one-member classes-intersect? ] unit-test +[ f ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test +[ t ] [ object mixin-with-one-member classes-intersect? ] unit-test + +[ t ] [ mixin-with-one-member a classes-intersect? ] unit-test +[ f ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test +[ t ] [ mixin-with-one-member object classes-intersect? ] unit-test + +! class= [ t ] [ null class-not object class= ] unit-test [ t ] [ object class-not null class= ] unit-test @@ -143,13 +204,14 @@ UNION: z1 b1 c1 ; [ f ] [ null class-not null class= ] unit-test -[ t ] [ - fixnum class-not - fixnum fixnum class-not class-or - class<= -] unit-test +! class<=> -! Test method inlining +[ +lt+ ] [ integer sequence class<=> ] unit-test +[ +lt+ ] [ sequence object class<=> ] unit-test +[ +gt+ ] [ object sequence class<=> ] unit-test +[ +eq+ ] [ integer integer class<=> ] unit-test + +! smallest-class etc [ real ] [ { real sequence } smallest-class ] unit-test [ real ] [ { sequence real } smallest-class ] unit-test @@ -268,59 +330,10 @@ TUPLE: xh < xb ; [ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test -INTERSECTION: generic-class generic class ; - -[ t ] [ generic-class generic class<= ] unit-test -[ t ] [ generic-class \ class class<= ] unit-test - -! Later -[ - [ t ] [ \ class generic class-and generic-class class<= ] unit-test - [ t ] [ \ class generic class-and generic-class swap class<= ] unit-test -] drop - -[ t ] [ \ word generic-class classes-intersect? ] unit-test -[ f ] [ number generic-class classes-intersect? ] unit-test - [ H{ { word word } } ] [ generic-class flatten-class ] unit-test -[ \ + flatten-class ] must-fail - -INTERSECTION: empty-intersection ; - -[ t ] [ object empty-intersection class<= ] unit-test -[ t ] [ empty-intersection object class<= ] unit-test -[ t ] [ \ f class-not empty-intersection class<= ] unit-test -[ f ] [ empty-intersection \ f class-not class<= ] unit-test -[ t ] [ \ number empty-intersection class<= ] unit-test -[ t ] [ empty-intersection class-not null class<= ] unit-test -[ t ] [ null empty-intersection class-not class<= ] unit-test - -[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test -[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test - -[ t ] [ object \ f class-not \ f class-or class<= ] unit-test - -[ ] [ object flatten-builtin-class drop ] unit-test - -SINGLETON: sa -SINGLETON: sb -SINGLETON: sc - [ sa ] [ sa { sa sb sc } min-class ] unit-test -[ f ] [ sa sb classes-intersect? ] unit-test - -[ +lt+ ] [ integer sequence class<=> ] unit-test -[ +lt+ ] [ sequence object class<=> ] unit-test -[ +gt+ ] [ object sequence class<=> ] unit-test -[ +eq+ ] [ integer integer class<=> ] unit-test - -! Limitations: - -! UNION: u1 sa sb ; -! UNION: u2 sc ; - -! [ f ] [ u1 u2 classes-intersect? ] unit-test +[ \ + flatten-class ] must-fail diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 2d67403f94..e98470cd83 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -5,18 +5,44 @@ vectors assocs namespaces words sorting layouts math hashtables kernel.private sets math.order ; IN: classes.algebra -TUPLE: anonymous-union members ; + anonymous-union +TUPLE: anonymous-union { members read-only } ; -TUPLE: anonymous-intersection participants ; +: ( members -- class ) + [ null eq? not ] filter prune + dup length 1 = [ first ] [ anonymous-union boa ] if ; -C: anonymous-intersection +TUPLE: anonymous-intersection { participants read-only } ; -TUPLE: anonymous-complement class ; +: ( participants -- class ) + prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ; + +TUPLE: anonymous-complement { class read-only } ; C: anonymous-complement +DEFER: (class<=) + +DEFER: (class-not) + +GENERIC: (classes-intersect?) ( first second -- ? ) + +DEFER: (class-and) + +DEFER: (class-or) + +GENERIC: (flatten-class) ( class -- ) + +: normalize-class ( class -- class' ) + { + { [ dup members ] [ members normalize-class ] } + { [ dup participants ] [ participants normalize-class ] } + [ ] + } cond ; + +PRIVATE> + GENERIC: valid-class? ( obj -- ? ) M: class valid-class? drop t ; @@ -25,40 +51,42 @@ M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ; M: anonymous-complement valid-class? class>> valid-class? ; M: word valid-class? drop f ; -DEFER: (class<=) - : class<= ( first second -- ? ) class<=-cache get [ (class<=) ] 2cache ; -DEFER: (class-not) +: class< ( first second -- ? ) + { + { [ 2dup class<= not ] [ 2drop f ] } + { [ 2dup swap class<= not ] [ 2drop t ] } + [ [ rank-class ] bi@ < ] + } cond ; + +: class<=> ( first second -- ? ) + { + { [ 2dup class<= not ] [ 2drop +gt+ ] } + { [ 2dup swap class<= not ] [ 2drop +lt+ ] } + [ [ rank-class ] bi@ <=> ] + } cond ; + +: class= ( first second -- ? ) + [ class<= ] [ swap class<= ] 2bi and ; : class-not ( class -- complement ) class-not-cache get [ (class-not) ] cache ; -GENERIC: (classes-intersect?) ( first second -- ? ) - -: normalize-class ( class -- class' ) - { - { [ dup members ] [ members ] } - { [ dup participants ] [ participants ] } - [ ] - } cond ; - : classes-intersect? ( first second -- ? ) classes-intersect-cache get [ normalize-class (classes-intersect?) ] 2cache ; -DEFER: (class-and) - : class-and ( first second -- class ) class-and-cache get [ (class-and) ] 2cache ; -DEFER: (class-or) - : class-or ( first second -- class ) class-or-cache get [ (class-or) ] 2cache ; + ] } + [ ] } cond ; : left-anonymous-complement<= ( first second -- ? ) @@ -108,8 +137,10 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; : (class<=) ( first second -- ? ) 2dup eq? [ 2drop t ] [ + [ normalize-class ] bi@ 2dup superclass<= [ 2drop t ] [ - [ normalize-class ] bi@ { + { + { [ 2dup eq? ] [ 2drop t ] } { [ dup empty-intersection? ] [ 2drop t ] } { [ over empty-union? ] [ 2drop t ] } { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] } @@ -185,22 +216,10 @@ M: anonymous-complement (classes-intersect?) [ ] } cond ; -: class< ( first second -- ? ) - { - { [ 2dup class<= not ] [ 2drop f ] } - { [ 2dup swap class<= not ] [ 2drop t ] } - [ [ rank-class ] bi@ < ] - } cond ; +M: anonymous-union (flatten-class) + members>> [ (flatten-class) ] each ; -: class<=> ( first second -- ? ) - { - { [ 2dup class<= not ] [ 2drop +gt+ ] } - { [ 2dup swap class<= not ] [ 2drop +lt+ ] } - [ [ rank-class ] bi@ <=> ] - } cond ; - -: class= ( first second -- ? ) - [ class<= ] [ swap class<= ] 2bi and ; +PRIVATE> ERROR: topological-sort-failed ; @@ -211,7 +230,7 @@ ERROR: topological-sort-failed ; : sort-classes ( seq -- newseq ) [ name>> ] sort-with >vector [ dup empty? not ] - [ dup largest-class [ over delete-nth ] dip ] + [ dup largest-class [ swap remove-nth! ] dip ] produce nip ; : smallest-class ( classes -- class/f ) @@ -220,28 +239,5 @@ ERROR: topological-sort-failed ; [ ] [ [ class<= ] most ] map-reduce ] if-empty ; -GENERIC: (flatten-class) ( class -- ) - -M: anonymous-union (flatten-class) - members>> [ (flatten-class) ] each ; - : flatten-class ( class -- assoc ) [ (flatten-class) ] H{ } make-assoc ; - -: flatten-builtin-class ( class -- assoc ) - flatten-class [ - dup tuple class<= [ 2drop tuple tuple ] when - ] assoc-map ; - -: class-types ( class -- seq ) - flatten-builtin-class keys - [ "type" word-prop ] map natural-sort ; - -: class-tags ( class -- seq ) - class-types [ - dup num-tags get >= - [ drop \ hi-tag tag-number ] when - ] map prune ; - -: class-tag ( class -- tag/f ) - class-tags dup length 1 = [ first ] [ drop f ] if ; diff --git a/core/classes/builtin/builtin-docs.factor b/core/classes/builtin/builtin-docs.factor index 9d41239206..ecc484df11 100644 --- a/core/classes/builtin/builtin-docs.factor +++ b/core/classes/builtin/builtin-docs.factor @@ -9,7 +9,7 @@ $nl builtin-class builtin-class? } -"See " { $link "type-index" } " for a list of built-in classes." ; +"See " { $link "class-index" } " for a list of built-in classes." ; HELP: builtin-class { $class-description "The class of built-in classes." } diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index 8eeb4ce357..028225ec49 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors classes classes.algebra words kernel -kernel.private namespaces sequences math math.private -combinators assocs quotations ; +USING: accessors classes classes.algebra classes.algebra.private +words kernel kernel.private namespaces sequences math +math.private combinators assocs quotations ; IN: classes.builtin SYMBOL: builtins @@ -12,34 +12,20 @@ PREDICATE: builtin-class < class : class>type ( class -- n ) "type" word-prop ; foldable -PREDICATE: lo-tag-class < builtin-class class>type 7 <= ; - -PREDICATE: hi-tag-class < builtin-class class>type 7 > ; - : type>class ( n -- class ) builtins get-global nth ; : bootstrap-type>class ( n -- class ) builtins get nth ; -M: hi-tag class hi-tag type>class ; inline - M: object class tag type>class ; inline M: builtin-class rank-class drop 0 ; GENERIC: define-builtin-predicate ( class -- ) -M: lo-tag-class define-builtin-predicate +M: builtin-class define-builtin-predicate dup class>type [ eq? ] curry [ tag ] prepend define-predicate ; -M: hi-tag-class define-builtin-predicate - dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation - [ dup tag 6 eq? ] [ [ drop f ] if ] surround - define-predicate ; - -M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ; - -M: hi-tag-class instance? - over tag 6 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ; +M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ; M: builtin-class (flatten-class) dup set ; @@ -50,6 +36,6 @@ M: builtin-class (classes-intersect?) [ swap classes-intersect? ] } cond ; -: full-cover ( -- ) builtins get sift [ (flatten-class) ] each ; +: full-cover ( -- ) builtins get [ (flatten-class) ] each ; M: anonymous-complement (flatten-class) drop full-cover ; diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 5607bc3a22..10a5f674bd 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -11,7 +11,6 @@ IN: classes.tests [ f ] [ 3 float instance? ] unit-test [ t ] [ 3 number instance? ] unit-test [ f ] [ 3 null instance? ] unit-test -[ t ] [ "hi" \ hi-tag instance? ] unit-test ! Regression GENERIC: method-forget-test ( obj -- obj ) diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index a0481a62a7..36514f3cb2 100644 --- a/core/classes/intersection/intersection.factor +++ b/core/classes/intersection/intersection.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words accessors sequences kernel assocs combinators classes -classes.algebra classes.builtin namespaces arrays math quotations ; +classes.algebra classes.algebra.private classes.builtin +namespaces arrays math quotations ; IN: classes.intersection PREDICATE: intersection-class < class diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 6cf95716be..6514f36074 100644 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -34,7 +34,7 @@ TUPLE: check-mixin-class class ; ] unless ; : if-mixin-member? ( class mixin true false -- ) - [ check-mixin-class 2dup members memq? ] 2dip if ; inline + [ check-mixin-class 2dup members member-eq? ] 2dip if ; inline : change-mixin-class ( class mixin quot -- ) [ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index e544c7f8ab..eab2746dea 100644 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes classes.algebra kernel namespaces make words -sequences quotations arrays kernel.private assocs combinators ; +USING: classes classes.algebra classes.algebra.private kernel +namespaces make words sequences quotations arrays kernel.private +assocs combinators ; IN: classes.predicate PREDICATE: predicate-class < class diff --git a/core/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor index 0db49cefa0..e1caf4f46b 100644 --- a/core/classes/singleton/singleton.factor +++ b/core/classes/singleton/singleton.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes classes.algebra classes.predicate kernel -sequences words ; +USING: classes classes.algebra classes.algebra.private +classes.predicate kernel sequences words ; IN: classes.singleton : singleton-predicate-quot ( class -- quot ) [ eq? ] curry ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 5ab83aa015..3555147542 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -110,7 +110,7 @@ TUPLE: yo-momma ; [ t ] [ \ yo-momma class? ] unit-test [ ] [ \ yo-momma forget ] unit-test [ ] [ \ forget ] unit-test - [ f ] [ \ yo-momma update-map get values memq? ] unit-test + [ f ] [ \ yo-momma update-map get values member-eq? ] unit-test ] with-compilation-unit TUPLE: loc-recording ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index ccb4e30c31..d5c8b4dcff 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -3,8 +3,9 @@ USING: arrays definitions hashtables kernel kernel.private math namespaces make sequences sequences.private strings vectors words quotations memory combinators generic classes -classes.algebra classes.builtin classes.private slots.private -slots math.private accessors assocs effects ; +classes.algebra classes.algebra.private classes.builtin +classes.private slots.private slots math.private accessors +assocs effects ; IN: classes.tuple PREDICATE: tuple-class < class @@ -118,7 +119,7 @@ ERROR: bad-superclass class ; } case define-predicate ; : class-size ( class -- n ) - superclasses [ "slots" word-prop length ] sigma ; + superclasses [ "slots" word-prop length ] map-sum ; : (instance-check-quot) ( class -- quot ) [ diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index e0e86e40c0..4615d316ac 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words sequences kernel assocs combinators classes -classes.algebra namespaces arrays math quotations ; +classes.algebra classes.algebra.private namespaces arrays math +quotations ; IN: classes.union PREDICATE: union-class < class diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 4701476d2a..2e9440a874 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -4,29 +4,8 @@ math assocs sequences sequences.private combinators.private effects words ; IN: combinators -ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators" -"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "." -$nl -"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:" -{ $code - ": keep [ ] bi ;" - ": 2keep [ ] 2bi ;" - ": 3keep [ ] 3bi ;" - "" - ": dup [ ] [ ] bi ;" - ": 2dup [ ] [ ] 2bi ;" - ": 3dup [ ] [ ] 3bi ;" - "" - ": tuck [ nip ] [ ] 2bi ;" - ": swap [ nip ] [ drop ] 2bi ;" - "" - ": over [ ] [ drop ] 2bi ;" - ": pick [ ] [ 2drop ] 3bi ;" - ": 2over [ ] [ drop ] 3bi ;" -} ; - ARTICLE: "cleave-combinators" "Cleave combinators" -"The cleave combinators apply multiple quotations to a single value." +"The cleave combinators apply multiple quotations to a single value or set of values." $nl "Two quotations:" { $subsections @@ -46,54 +25,21 @@ $nl 2cleave 3cleave } -$nl -"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:" +"Cleave combinators provide a more readable alternative to repeated applications of the " { $link keep } " combinators. The following example using " { $link keep } ":" { $code - "! First alternative; uses keep" "[ 1 + ] keep" "[ 1 - ] keep" "2 *" - "! Second alternative: uses tri" +} +"can be more clearly written using " { $link tri } ":" +{ $code "[ 1 + ]" "[ 1 - ]" "[ 2 * ] tri" -} -"The latter is more aesthetically pleasing than the former." -$nl -{ $subsections "cleave-shuffle-equivalence" } ; - -ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators" -"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", " { $link tri* } ", and " { $link 2tri* } "." -$nl -"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:" -{ $code - ": dip [ ] bi* ;" - ": 2dip [ ] [ ] tri* ;" - "" - ": nip [ drop ] [ ] bi* ;" - ": 2nip [ drop ] [ drop ] [ ] tri* ;" - "" - ": rot" - " [ [ drop ] [ ] [ drop ] tri* ]" - " [ [ drop ] [ drop ] [ ] tri* ]" - " [ [ ] [ drop ] [ drop ] tri* ]" - " 3tri ;" - "" - ": -rot" - " [ [ drop ] [ drop ] [ ] tri* ]" - " [ [ ] [ drop ] [ drop ] tri* ]" - " [ [ drop ] [ ] [ drop ] tri* ]" - " 3tri ;" - "" - ": spin" - " [ [ drop ] [ drop ] [ ] tri* ]" - " [ [ drop ] [ ] [ drop ] tri* ]" - " [ [ ] [ drop ] [ drop ] tri* ]" - " 3tri ;" } ; ARTICLE: "spread-combinators" "Spread combinators" -"The spread combinators apply multiple quotations to multiple values. In this case, " { $snippet "*" } " suffix signify spreading." +"The spread combinators apply multiple quotations to multiple values. The asterisk (" { $snippet "*" } ") suffixed to these words' names signifies that they are spread combinators." $nl "Two quotations:" { $subsections bi* 2bi* } @@ -101,33 +47,31 @@ $nl { $subsections tri* 2tri* } "An array of quotations:" { $subsections spread } -"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:" +"Spread combinators provide a more readable alternative to repeated applications of the " { $link dip } " combinators. The following example using " { $link dip } ":" { $code - "! First alternative; uses dip" "[ [ 1 + ] dip 1 - ] dip 2 *" - "! Second alternative: uses tri*" +} +"can be more clearly written using " { $link tri* } ":" +{ $code "[ 1 + ] [ 1 - ] [ 2 * ] tri*" } -"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." -$nl -{ $subsections "spread-shuffle-equivalence" } ; +"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." ; ARTICLE: "apply-combinators" "Apply combinators" -"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application." +"The apply combinators apply a single quotation to multiple values. The asterisk (" { $snippet "*" } ") suffixed to these words' names signifies that they are apply combinators." $nl "Two quotations:" { $subsections bi@ 2bi@ } "Three quotations:" { $subsections tri@ 2tri@ } -"A pair of utility words built from " { $link bi@ } ":" -{ $subsections both? either? } ; +"A pair of condition words built from " { $link bi@ } " to test two values:" +{ $subsections both? either? } +"All of the apply combinators are equivalent to using the corresponding " { $link "spread-combinators" } " with the same quotation supplied for every value." ; -ARTICLE: "retainstack-combinators" "Retain stack combinators" -"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators." -$nl -"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:" +ARTICLE: "dip-keep-combinators" "Preserving combinators" +"Sometimes it is necessary to temporarily hide values on the datastack. The " { $snippet "dip" } " combinators invoke the quotation at the top of the stack, hiding some number of values underneath:" { $subsections dip 2dip 3dip 4dip } -"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:" +"The " { $snippet "keep" } " combinators invoke a quotation and restore some number of values to the top of the stack when it completes:" { $subsections keep 2keep 3keep } ; ARTICLE: "curried-dataflow" "Curried dataflow combinators" @@ -237,14 +181,14 @@ ARTICLE: "conditionals" "Conditional combinators" { $see-also "booleans" "bitwise-arithmetic" both? either? } ; ARTICLE: "dataflow-combinators" "Data flow combinators" -"Data flow combinators pass values between quotations:" +"Data flow combinators express common dataflow patterns such as performing a operation while preserving its inputs, applying multiple operations to a single value, applying a set of operations to a set of values, or applying a single operation to multiple values." { $subsections - "retainstack-combinators" + "dip-keep-combinators" "cleave-combinators" "spread-combinators" "apply-combinators" } -{ $see-also "curried-dataflow" } ; +"More intricate data flow can be constructed by composing " { $link "curried-dataflow" } "." ; ARTICLE: "combinators-quot" "Quotation construction utilities" "Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:" @@ -255,17 +199,17 @@ ARTICLE: "call-unsafe" "Unsafe combinators" { $subsections call-effect-unsafe execute-effect-unsafe } ; ARTICLE: "call" "Fundamental combinators" -"The most basic combinators are those that take either a quotation or word, and invoke it immediately." +"The most basic combinators are those that take either a quotation or word, and invoke it immediately. There are two sets of these fundamental combinators. They differ in whether the compiler is expected to determine the stack effect of the expression at compile time or the stack effect is declared and verified at run time." $nl -"There are two sets of combinators; they differ in whether or not the stack effect of the expected code is declared." -$nl -"The simplest combinators do not take an effect declaration. The compiler checks the stack effect at compile time, rejecting the program if this cannot be done:" +{ $heading "Compile-time checked combinators" } +"With these combinators, the compiler attempts to determine the stack effect of the expression at compile time, rejecting the program if the effect cannot be determined. See " { $link "inference-combinators" } "." { $subsections call execute } -"The second set of combinators takes an effect declaration. Note that the opening parenthesis is actually part of the word name; these are parsing words, and they read a stack effect until the corresponding closing parenthesis. The stack effect of the quotation or word is then checked at runtime:" +{ $heading "Run-time checked combinators" } +"With these combinators, the stack effect of the expression is checked at run time." { $subsections POSTPONE: call( POSTPONE: execute( } -"The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:" +"Note that the opening parenthesis is actually part of the word name for " { $snippet "call(" } " and " { $snippet "execute(" } "; they are parsing words, and they read a stack effect until the corresponding closing parenthesis. The underlying words are a bit more verbose, but they can be given non-constant stack effects:" { $subsections call-effect execute-effect } -"The combinator variants that do not take an effect declaration can only be used if the compiler is able to infer the stack effect by other means. See " { $link "inference-combinators" } "." +{ $heading "Unchecked combinators" } { $subsections "call-unsafe" } { $see-also "effects" "inference" } ; @@ -344,7 +288,7 @@ HELP: spread { $values { "objs..." "objects" } { "seq" "a sequence of quotations with stack effect " { $snippet "( x -- ... )" } } } { $description "Applies each quotation to the object in turn." } { $examples - "The " { $link bi* } " combinator takes two values and two quotations; the " { $link tri* } " combinator takes three values and three quotations. The " { $link spread } " combinator takes " { $snippet "n" } " values and " { $snippet "n" } " quotations, where " { $snippet "n" } " is the length of the input sequence, and is essentially equivalent to series of retain stack manipulations:" + "The " { $link bi* } " combinator takes two values and two quotations; the " { $link tri* } " combinator takes three values and three quotations. The " { $link spread } " combinator takes " { $snippet "n" } " values and " { $snippet "n" } " quotations, where " { $snippet "n" } " is the length of the input sequence, and is essentially equivalent to a nested series of " { $link dip } "s:" { $code "! Equivalent" "{ [ p ] [ q ] [ r ] [ s ] } spread" @@ -438,7 +382,7 @@ $nl { $notes "This word is used behind the scenes to compile " { $link cond } " forms efficiently; it can also be called directly, which is useful for meta-programming." } ; HELP: case>quot -{ $values { "assoc" "a sequence of pairs of quotations" } { "default" quotation } { "quot" quotation } } +{ $values { "default" quotation } { "assoc" "a sequence of pairs of quotations" } { "quot" quotation } } { $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "." $nl "This word uses three strategies:" diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index 8dce12f411..eccc292f26 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -5,16 +5,9 @@ IN: compiler.units.tests [ [ [ ] define-temp ] with-compilation-unit ] must-infer [ [ [ ] define-temp ] with-nested-compilation-unit ] must-infer -[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test -[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test -[ inlined-dependency ] [ flushed-dependency inlined-dependency strongest-dependency ] unit-test -[ inlined-dependency ] [ called-dependency inlined-dependency strongest-dependency ] unit-test -[ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test -[ called-dependency ] [ called-dependency f strongest-dependency ] unit-test - ! Non-optimizing compiler bugs [ 1 1 ] [ - "A" "B" [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep + "A" [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep 1 swap execute ] unit-test diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index ac1c9627ac..bc372d8d90 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -3,7 +3,8 @@ USING: accessors arrays kernel continuations assocs namespaces sequences words vocabs definitions hashtables init sets math math.order classes classes.algebra classes.tuple -classes.tuple.private generic source-files.errors ; +classes.tuple.private generic source-files.errors +kernel.private ; IN: compiler.units SYMBOL: old-definitions @@ -15,12 +16,16 @@ TUPLE: redefine-error def ; \ redefine-error boa { { "Continue" t } } throw-restarts drop ; + + : remember-definition ( definition loc -- ) new-definitions get first (remember-definition) ; @@ -40,8 +45,21 @@ SYMBOL: compiler-impl HOOK: recompile compiler-impl ( words -- alist ) +HOOK: to-recompile compiler-impl ( -- words ) + +HOOK: process-forgotten-words compiler-impl ( words -- ) + +: compile ( words -- ) recompile modify-code-heap ; + ! Non-optimizing compiler -M: f recompile [ dup def>> ] { } map>assoc ; +M: f recompile + [ dup def>> ] { } map>assoc ; + +M: f to-recompile + changed-definitions get [ drop word? ] assoc-filter + changed-generics get assoc-union keys ; + +M: f process-forgotten-words drop ; : without-optimizer ( quot -- ) [ f compiler-impl ] dip with-variable ; inline @@ -50,8 +68,12 @@ M: f recompile [ dup def>> ] { } map>assoc ; ! during stage1 bootstrap, it would just waste time. SINGLETON: dummy-compiler +M: dummy-compiler to-recompile f ; + M: dummy-compiler recompile drop { } ; +M: dummy-compiler process-forgotten-words drop ; + : ( -- pair ) { H{ } H{ } } [ clone ] map ; SYMBOL: definition-observers @@ -69,12 +91,23 @@ GENERIC: definitions-changed ( assoc obj -- ) definition-observers get push ; : remove-definition-observer ( obj -- ) - definition-observers get delq ; + definition-observers get remove-eq! drop ; : notify-definition-observers ( assoc -- ) definition-observers get [ definitions-changed ] with each ; +! Incremented each time stack effects potentially changed, used +! by compiler.tree.propagation.call-effect for call( and execute( +! inline caching +: effect-counter ( -- n ) 46 getenv ; inline + +GENERIC: bump-effect-counter* ( defspec -- ? ) + +M: object bump-effect-counter* drop f ; + +> dup [ vocab ] when dup ] assoc-map ; @@ -87,72 +120,34 @@ GENERIC: definitions-changed ( assoc obj -- ) dup changed-definitions get update dup dup changed-vocabs update ; -: compile ( words -- ) recompile modify-code-heap ; - -: index>= ( obj1 obj2 seq -- ? ) - [ index ] curry bi@ >= ; - -: dependency>= ( how1 how2 -- ? ) - { called-dependency flushed-dependency inlined-dependency } - index>= ; - -: strongest-dependency ( how1 how2 -- how ) - [ called-dependency or ] bi@ [ dependency>= ] most ; - -: weakest-dependency ( how1 how2 -- how ) - [ inlined-dependency or ] bi@ [ dependency>= not ] most ; - -: compiled-usage ( word -- assoc ) - compiled-crossref get at ; - -: (compiled-usages) ( word -- assoc ) - #! If the word is not flushable anymore, we have to recompile - #! all words which flushable away a call (presumably when the - #! word was still flushable). If the word is flushable, we - #! don't have to recompile words that folded this away. - [ compiled-usage ] - [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi - [ dependency>= nip ] curry assoc-filter ; - -: compiled-usages ( assoc -- assocs ) - [ drop word? ] assoc-filter - [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ; - -: compiled-generic-usage ( word -- assoc ) - compiled-generic-crossref get at ; - -: (compiled-generic-usages) ( generic class -- assoc ) - [ compiled-generic-usage ] dip - [ - 2dup [ valid-class? ] both? - [ classes-intersect? ] [ 2drop f ] if nip - ] curry assoc-filter ; - -: compiled-generic-usages ( assoc -- assocs ) - [ (compiled-generic-usages) ] { } assoc>map ; - -: words-only ( assoc -- assoc' ) - [ drop word? ] assoc-filter ; - -: to-recompile ( -- seq ) - changed-definitions get compiled-usages - changed-generics get compiled-generic-usages - append assoc-combine keys ; - : process-forgotten-definitions ( -- ) forgotten-definitions get keys - [ [ word? ] filter [ delete-compiled-xref ] each ] + [ [ word? ] filter process-forgotten-words ] [ [ delete-definition-errors ] each ] bi ; +: bump-effect-counter? ( -- ? ) + changed-effects get new-words get assoc-diff assoc-empty? not + changed-definitions get [ drop bump-effect-counter* ] assoc-any? + or ; + +: bump-effect-counter ( -- ) + bump-effect-counter? [ 46 getenv 0 or 1 + 46 setenv ] when ; + +: notify-observers ( -- ) + updated-definitions dup assoc-empty? + [ drop ] [ notify-definition-observers notify-error-observers ] if ; + : finish-compilation-unit ( -- ) remake-generics to-recompile recompile update-tuples process-forgotten-definitions modify-code-heap - updated-definitions dup assoc-empty? - [ drop ] [ notify-definition-observers notify-error-observers ] if ; + bump-effect-counter + notify-observers ; + +PRIVATE> : with-nested-compilation-unit ( quot -- ) [ @@ -161,6 +156,7 @@ GENERIC: definitions-changed ( assoc obj -- ) H{ } clone changed-effects set H{ } clone outdated-generics set H{ } clone outdated-tuples set + H{ } clone new-words set H{ } clone new-classes set [ finish-compilation-unit ] [ ] cleanup ] with-scope ; inline @@ -173,6 +169,7 @@ GENERIC: definitions-changed ( assoc obj -- ) H{ } clone outdated-generics set H{ } clone forgotten-definitions set H{ } clone outdated-tuples set + H{ } clone new-words set H{ } clone new-classes set new-definitions set old-definitions set diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 5fb5a38af2..84da26a082 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -122,7 +122,7 @@ HELP: continuation { $description "Reifies the current continuation from the point immediately after which the caller returns." } ; HELP: >continuation< -{ $values { "continuation" continuation } { "data" vector } { "retain" vector } { "call" vector } { "name" vector } { "catch" vector } } +{ $values { "continuation" continuation } { "data" vector } { "call" vector } { "retain" vector } { "name" vector } { "catch" vector } } { $description "Takes a continuation apart into its constituents." } ; HELP: ifcc @@ -271,4 +271,4 @@ HELP: with-return HELP: restart { $values { "restart" restart } } { $description "Invokes a restart." } -{ $class-description "The class of restarts." } ; \ No newline at end of file +{ $class-description "The class of restarts." } ; diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index f40769ae39..0d207d9cc6 100644 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -20,7 +20,7 @@ $nl { $see-also "see" } ; ARTICLE: "definition-checking" "Definition sanity checking" -"When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } ". A warning message is printed if any other definitions still depend on the removed definitions." +"When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } "." $nl "The parser also catches forward references when reloading source files. This is best illustrated with an example. Suppose we load a source file " { $snippet "a.factor" } ":" { $code diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index e2fb4b8161..597b195c36 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -7,15 +7,13 @@ MIXIN: definition ERROR: no-compilation-unit definition ; -SYMBOLS: inlined-dependency flushed-dependency called-dependency ; - : set-in-unit ( value key assoc -- ) [ set-at ] [ no-compilation-unit ] if* ; SYMBOL: changed-definitions : changed-definition ( defspec -- ) - inlined-dependency swap changed-definitions get set-in-unit ; + dup changed-definitions get set-in-unit ; SYMBOL: changed-effects @@ -23,8 +21,16 @@ SYMBOL: changed-generics SYMBOL: outdated-generics +SYMBOL: new-words + SYMBOL: new-classes +: new-word ( word -- ) + dup new-words get set-in-unit ; + +: new-word? ( word -- ? ) + new-words get key? ; + : new-class ( word -- ) dup new-classes get set-in-unit ; diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor index 1f640beddb..577da7c4eb 100644 --- a/core/destructors/destructors.factor +++ b/core/destructors/destructors.factor @@ -26,15 +26,11 @@ SLOT: continuation PRIVATE> TUPLE: disposable < identity-tuple -{ id integer } { disposed boolean } continuation ; -M: disposable hashcode* nip id>> ; - : new-disposable ( class -- disposable ) - new \ disposable counter >>id - dup register-disposable ; inline + new dup register-disposable ; inline GENERIC: dispose* ( disposable -- ) diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index da27dc28b4..a77ea34c30 100644 --- a/core/effects/parser/parser.factor +++ b/core/effects/parser/parser.factor @@ -25,7 +25,7 @@ ERROR: bad-effect ; : parse-effect-tokens ( end -- tokens ) [ parse-effect-token dup ] curry [ ] produce nip ; -ERROR: stack-effect-omits-dashes effect ; +ERROR: stack-effect-omits-dashes tokens ; : parse-effect ( end -- effect ) parse-effect-tokens { "--" } split1 dup @@ -35,4 +35,4 @@ ERROR: stack-effect-omits-dashes effect ; "(" expect ")" parse-effect ; : parse-call( ( accum word -- accum ) - [ ")" parse-effect ] dip 2array over push-all ; + [ ")" parse-effect ] dip 2array append! ; diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 0f80aac2f3..dea523538e 100644 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -124,7 +124,7 @@ HELP: make-generic $low-level-note ; HELP: define-generic -{ $values { "word" word } { "effect" effect } { "combination" "a method combination" } } +{ $values { "word" word } { "combination" "a method combination" } { "effect" effect } } { $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." } { $contract "The method combination quotation is called each time the generic word has to be updated (for example, when a method is added), and thus must be side-effect free." } ; diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index f5c2018e60..5a98173a89 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -3,7 +3,8 @@ classes.tuple classes.union compiler.units continuations definitions eval generic generic.math generic.standard hashtables io io.streams.string kernel layouts math math.order namespaces parser prettyprint quotations sequences sorting -strings tools.test vectors words generic.single ; +strings tools.test vectors words generic.single +compiler.crossref ; IN: generic.tests GENERIC: foobar ( x -- y ) diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 9e773fe700..d0bc4e1600 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -63,19 +63,18 @@ TUPLE: predicate-engine class methods ; C: predicate-engine -: push-method ( method specializer atomic assoc -- ) +: push-method ( method class atomic assoc -- ) dupd [ [ ] [ H{ } clone ] ?if [ methods>> set-at ] keep ] change-at ; -: flatten-method ( class method assoc -- ) - [ [ flatten-class keys ] keep ] 2dip [ - [ spin ] dip push-method - ] 3curry each ; +: flatten-method ( method class assoc -- ) + over flatten-class keys + [ swap push-method ] with with with each ; : flatten-methods ( assoc -- assoc' ) - H{ } clone [ [ flatten-method ] curry assoc-each ] keep ; + H{ } clone [ [ swapd flatten-method ] curry assoc-each ] keep ; ! 2. Convert methods : split-methods ( assoc class -- first second ) @@ -112,15 +111,6 @@ TUPLE: tuple-dispatch-engine echelons ; tuple bootstrap-word \ convert-methods ; -! 2.2 Convert hi-tag methods -TUPLE: hi-tag-dispatch-engine methods ; - -C: hi-tag-dispatch-engine - -: convert-hi-tag-methods ( assoc -- assoc' ) - \ hi-tag bootstrap-word - \ convert-methods ; - ! 3 Tag methods TUPLE: tag-dispatch-engine methods ; @@ -129,7 +119,6 @@ C: tag-dispatch-engine : ( assoc -- engine ) flatten-methods convert-tuple-methods - convert-hi-tag-methods ; ! ! ! Compile engine ! ! ! @@ -144,23 +133,12 @@ GENERIC: compile-engine ( engine -- obj ) : direct-dispatch-table ( assoc n -- table ) default get [ swap update ] keep ; -: lo-tag-number ( class -- n ) - "type" word-prop dup num-tags get iota member? - [ drop object tag-number ] unless ; +: tag-number ( class -- n ) "type" word-prop ; M: tag-dispatch-engine compile-engine methods>> compile-engines* - [ [ lo-tag-number ] dip ] assoc-map - num-tags get direct-dispatch-table ; - -: num-hi-tags ( -- n ) num-types get num-tags get - ; - -: hi-tag-number ( class -- n ) "type" word-prop ; - -M: hi-tag-dispatch-engine compile-engine - methods>> compile-engines* - [ [ hi-tag-number num-tags get - ] dip ] assoc-map - num-hi-tags direct-dispatch-table ; + [ [ tag-number ] dip ] assoc-map + num-types get direct-dispatch-table ; : build-fast-hash ( methods -- buckets ) >alist V{ } clone [ hashcode 1array ] distribute-buckets diff --git a/core/growable/growable.factor b/core/growable/growable.factor index 68a8de3d43..3d5f16d7f1 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -23,7 +23,7 @@ GENERIC: contract ( len seq -- ) M: growable contract ( len seq -- ) [ length ] keep [ [ 0 ] 2dip set-nth-unsafe ] curry - (each-integer) ; + (each-integer) ; inline : growable-check ( n seq -- n seq ) over 0 < [ bounds-error ] when ; inline @@ -66,4 +66,6 @@ M: growable shorten ( n seq -- ) 2dup (>>length) ] when 2drop ; inline +M: growable new-resizable new-sequence 0 over set-length ; inline + INSTANCE: growable sequence diff --git a/core/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor index 37d6de0a76..f239458355 100755 --- a/core/hashtables/hashtables-docs.factor +++ b/core/hashtables/hashtables-docs.factor @@ -46,7 +46,8 @@ $nl $nl "In certain advanced applications, this cannot be avoided and the best design involves mutating hashtable keys. In this case, a custom " { $link hashcode* } " method must be defined which only depends on immutable slots." $nl -"In addition, the " { $link equal? } " and " { $link hashcode* } " methods must be congruent, and if one is defined the other should be defined also. This is documented in detail in the documentation for these respective words." ; +"In addition, the " { $link equal? } " and " { $link hashcode* } " methods must be congruent, and if one is defined the other should be defined also. This is documented in detail in the documentation for these respective words." +{ $subsections hashcode hashcode* identity-hashcode } ; ARTICLE: "hashtables.utilities" "Hashtable utilities" "Utility words to create a new hashtable from a single key/value pair:" diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index 54e58c0282..05cc27f5e8 100644 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -155,11 +155,6 @@ H{ } "x" set ] { } make ] unit-test -[ { "one" "two" 3 } ] [ - { 1 2 3 } clone dup - H{ { 1 "one" } { 2 "two" } } substitute-here -] unit-test - [ { "one" "two" 3 } ] [ { 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute ] unit-test diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 8547f53a0e..e31ed925d1 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -101,7 +101,7 @@ M: hashtable at* ( key hash -- value ? ) key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ; M: hashtable clear-assoc ( hash -- ) - [ init-hash ] [ array>> [ drop ((empty)) ] change-each ] bi ; + [ init-hash ] [ array>> [ drop ((empty)) ] map! drop ] bi ; M: hashtable delete-at ( key hash -- ) [ nip ] [ key@ ] 2bi [ @@ -115,9 +115,7 @@ M: hashtable assoc-size ( hash -- n ) [ count>> ] [ deleted>> ] bi - ; inline : rehash ( hash -- ) - dup >alist [ - dup clear-assoc - ] dip (rehash) ; + dup >alist [ dup clear-assoc ] dip (rehash) ; M: hashtable set-at ( value key hash -- ) dup ?grow-hash diff --git a/core/io/binary/binary.factor b/core/io/binary/binary.factor index f5467daea6..1275248613 100644 --- a/core/io/binary/binary.factor +++ b/core/io/binary/binary.factor @@ -11,7 +11,7 @@ IN: io.binary : nth-byte ( x n -- b ) -8 * shift mask-byte ; inline : >le ( x n -- byte-array ) iota [ nth-byte ] with B{ } map-as ; -: >be ( x n -- byte-array ) >le dup reverse-here ; +: >be ( x n -- byte-array ) >le reverse! ; : d>w/w ( d -- w1 w2 ) [ HEX: ffffffff bitand ] diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 6387e47dfc..23d974254d 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,7 +1,8 @@ USING: arrays debugger.threads destructors io io.directories -io.encodings.8-bit io.encodings.ascii io.encodings.binary +io.encodings.ascii io.encodings.binary io.files io.files.private io.files.temp io.files.unique kernel -make math sequences system threads tools.test generic.single ; +make math sequences system threads tools.test generic.single +io.encodings.8-bit.latin1 ; IN: io.files.tests [ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test @@ -158,4 +159,4 @@ USE: debugger.threads [ ] [ "closing-twice" unique-file ascii [ dispose ] [ dispose ] bi -] unit-test \ No newline at end of file +] unit-test diff --git a/core/io/io.factor b/core/io/io.factor index e240467c07..ca36bc3b36 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -87,42 +87,51 @@ SYMBOL: error-stream : bl ( -- ) " " write ; - -: each-line ( quot -- ) - [ readln ] each-morsel ; inline +: each-stream-line ( stream quot -- ) + swap [ stream-readln ] curry each-morsel ; inline -: lines ( -- seq ) - [ ] accumulator [ each-line ] dip { } like ; +: each-line ( quot -- ) + input-stream get swap each-stream-line ; inline : stream-lines ( stream -- seq ) - [ lines ] with-input-stream ; + [ [ ] accumulator [ each-stream-line ] dip { } like ] with-disposal ; -: contents ( -- seq ) - [ 65536 read-partial dup ] [ ] produce nip - element-exemplar concat-as ; +: lines ( -- seq ) + input-stream get stream-lines ; inline : stream-contents ( stream -- seq ) - [ contents ] with-input-stream ; + [ + [ [ 65536 swap stream-read-partial dup ] curry [ ] produce nip ] + [ stream-element-exemplar concat-as ] bi + ] with-disposal ; + +: contents ( -- seq ) + input-stream get stream-contents ; inline + +: each-stream-block ( stream quot: ( block -- ) -- ) + swap [ 8192 swap stream-read-partial ] curry each-morsel ; inline : each-block ( quot: ( block -- ) -- ) - [ 8192 read-partial ] each-morsel ; inline + input-stream get swap each-stream-block ; inline : stream-copy ( in out -- ) [ [ [ write ] each-block ] with-output-stream ] diff --git a/core/io/pathnames/pathnames-docs.factor b/core/io/pathnames/pathnames-docs.factor index 889f2262a8..8dacef6f8c 100644 --- a/core/io/pathnames/pathnames-docs.factor +++ b/core/io/pathnames/pathnames-docs.factor @@ -1,5 +1,5 @@ -USING: help.markup help.syntax io.backend io.files io.directories strings -sequences io.pathnames.private ; +USING: help.markup help.syntax io.backend io.files +io.directories strings system sequences io.pathnames.private ; IN: io.pathnames HELP: path-separator? @@ -90,7 +90,7 @@ HELP: pathname HELP: normalize-path { $values { "path" "a pathname string" } { "path'" "a new pathname string" } } -{ $description "Prepends the " { $link current-directory } " to the pathname, resolves a " { $snippet "resource:" } " or " { $snippet "voacb:" } " prefix, if present, and performs any platform-specific pathname normalization." } +{ $description "Prepends the " { $link current-directory } " to the pathname, resolves a " { $snippet "resource:" } " or " { $snippet "vocab:" } " prefix, if present (see " { $link "io.pathnames.special" } "). Also converts the path into a UNC path on Windows." } { $notes "High-level words, such as " { $link } " and " { $link delete-file } " call this word for you. It only needs to be called directly when passing pathnames to C functions or external processes. This is because Factor does not use the operating system's notion of a current directory, and instead maintains its own dynamically-scoped " { $link current-directory } " variable." } { $notes "On Windows NT platforms, this word does prepends the Unicode path prefix." } { $examples @@ -101,15 +101,15 @@ HELP: normalize-path } } ; -HELP: (normalize-path) +HELP: absolute-path { $values { "path" "a pathname string" } { "path'" "a pathname string" } } -{ $description "Prepends the " { $link current-directory } " to the pathname and resolves a " { $snippet "resource:" } " prefix, if present." } -{ $notes "On Windows NT platforms, this word does not prepend the Unicode path prefix." } ; +{ $description "Prepends the " { $link current-directory } " to the pathname and resolves a " { $snippet "resource:" } " or " { $snippet "voacb:" } " prefix, if present (see " { $link "io.pathnames.special" } ")." } +{ $notes "This word is exaclty the same as " { $link normalize-path } ", except on Windows NT platforms, where it does not prepend the Unicode path prefix. Most code should call " { $link normalize-path } " instead." } ; -HELP: canonicalize-path +HELP: resolve-symlinks { $values { "path" "a pathname string" } { "path'" "a new pathname string" } } { $description "Outputs a path where none of the path components are symlinks. This word is useful for determining the actual path on disk where a file is stored; the root of this absolute path is a mount point in the file-system." } { $notes "Most code should not need to call this word except in very special circumstances. One use case is finding the actual file-system on which a file is stored." } ; @@ -128,8 +128,24 @@ HELP: home } } ; +ARTICLE: "io.pathnames.special" "Special pathnames" +"If a pathname begins with " { $snippet "resource:" } ", it is resolved relative to the directory containing the current image (see " { $link image } ")." +$nl +"If a pathname begins with " { $snippet "vocab:" } ", then it will be searched for in all current vocabulary roots (see " { $link "add-vocab-roots" } ")." ; + +ARTICLE: "io.pathnames.presentations" "Pathname presentations" +"Pathname presentations are objects that wrap a pathname string. Clicking a pathname presentation in the UI brings up the file in one of the supported editors. See " { $link "editor" } " for more details." +{ $subsections + pathname + +} +"Literal pathname presentations:" +{ $subsections POSTPONE: P" } +"Many words that accept pathname strings can also work on pathname presentations." ; + ARTICLE: "io.pathnames" "Pathnames" -"Pathnames are objects that contain a string representing the path to a file on disk. Pathnames are cross-platform; Windows accepts both forward and backward slashes as directory separators and new separators are added as a forward slash on all platforms. Clicking a pathname object in the UI brings up the file in one of the supported editors, but otherwise, pathnames and strings are interchangeable. See " { $link "editor" } " for more details." $nl +"Pathnames are strings that refer to a file on disk. Pathname semantics are platform-specific, and Factor makes no attempt to abstract away the differences. Note that on Windows, both forward and backward slashes are accepted as directory separators." +$nl "Pathname introspection:" { $subsections parent-directory @@ -143,18 +159,9 @@ ARTICLE: "io.pathnames" "Pathnames" prepend-path append-path } -"Pathname presentations:" -{ $subsections - pathname - -} -"Literal pathnames:" -{ $subsections POSTPONE: P" } -"Low-level words:" -{ $subsections - normalize-path - (normalize-path) - canonicalize-path -} ; +"Normalizing pathnames:" +{ $subsections normalize-path absolute-path resolve-symlinks } +"Additional topics:" +{ $subsections "io.pathnames.presentations" "io.pathnames.special" } ; ABOUT: "io.pathnames" diff --git a/core/io/pathnames/pathnames-tests.factor b/core/io/pathnames/pathnames-tests.factor index 7a98a47f42..f23a1ac1f4 100644 --- a/core/io/pathnames/pathnames-tests.factor +++ b/core/io/pathnames/pathnames-tests.factor @@ -61,7 +61,7 @@ IN: io.pathnames.tests "." current-directory set ".." "resource-path" set [ "../core/bootstrap/stage2.factor" ] - [ "resource:core/bootstrap/stage2.factor" (normalize-path) ] + [ "resource:core/bootstrap/stage2.factor" absolute-path ] unit-test ] with-scope diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index e8672e6771..b307128efb 100644 --- a/core/io/pathnames/pathnames.factor +++ b/core/io/pathnames/pathnames.factor @@ -102,8 +102,8 @@ PRIVATE> [ 2 head ] dip append ] } [ - [ trim-tail-separators "/" ] dip - trim-head-separators 3append + [ trim-tail-separators ] + [ trim-head-separators ] bi* "/" glue ] } cond ; @@ -127,38 +127,38 @@ PRIVATE> : path-components ( path -- seq ) normalize-path path-separator split harvest ; -HOOK: canonicalize-path os ( path -- path' ) +HOOK: resolve-symlinks os ( path -- path' ) -M: object canonicalize-path normalize-path ; +M: object resolve-symlinks normalize-path ; : resource-path ( path -- newpath ) "resource-path" get prepend-path ; GENERIC: vocab-path ( path -- newpath ) -GENERIC: (normalize-path) ( path -- path' ) +GENERIC: absolute-path ( path -- path' ) -M: string (normalize-path) +M: string absolute-path "resource:" ?head [ trim-head-separators resource-path - (normalize-path) + absolute-path ] [ "vocab:" ?head [ trim-head-separators vocab-path - (normalize-path) + absolute-path ] [ current-directory get prepend-path ] if ] if ; M: object normalize-path ( path -- path' ) - (normalize-path) ; + absolute-path ; TUPLE: pathname string ; C: pathname -M: pathname (normalize-path) string>> (normalize-path) ; +M: pathname absolute-path string>> absolute-path ; M: pathname <=> [ string>> ] compare ; diff --git a/core/io/streams/byte-array/byte-array-docs.factor b/core/io/streams/byte-array/byte-array-docs.factor index 1bc09429dc..eeada8d0c9 100644 --- a/core/io/streams/byte-array/byte-array-docs.factor +++ b/core/io/streams/byte-array/byte-array-docs.factor @@ -27,8 +27,9 @@ HELP: { $description "Creates an output stream writing data to a byte array using an encoding." } ; HELP: with-byte-reader -{ $values { "encoding" "an encoding descriptor" } - { "quot" quotation } { "byte-array" byte-array } } +{ $values { "byte-array" byte-array } + { "encoding" "an encoding descriptor" } + { "quot" quotation } } { $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream for reading from a byte array using an encoding." } ; HELP: with-byte-writer diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 6ff1a4b35c..1da30fe922 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -49,7 +49,7 @@ M: c-reader stream-read1 dup check-disposed handle>> fgetc ; : read-until-loop ( stream delim -- ch ) over stream-read1 dup [ - dup pick memq? [ 2nip ] [ , read-until-loop ] if + dup pick member-eq? [ 2nip ] [ , read-until-loop ] if ] [ 2nip ] if ; diff --git a/core/io/streams/sequence/sequence.factor b/core/io/streams/sequence/sequence.factor index 036bab2213..5ecbc321ce 100644 --- a/core/io/streams/sequence/sequence.factor +++ b/core/io/streams/sequence/sequence.factor @@ -32,7 +32,7 @@ SLOT: i : find-sep ( seps stream -- sep/f n ) swap [ >sequence-stream< swap tail-slice ] dip - [ memq? ] curry find swap ; inline + [ member-eq? ] curry find swap ; inline : sequence-read-until ( separators stream -- seq sep/f ) [ find-sep ] keep diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 3f1e715448..0e8c3368ff 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -14,20 +14,17 @@ HELP: 3drop ( x y z -- ) $shuffle ; HELP: dup ( x -- x x ) $shuffle ; HELP: 2dup ( x y -- x y x y ) $shuffle ; HELP: 3dup ( x y z -- x y z x y z ) $shuffle ; -HELP: rot ( x y z -- y z x ) $shuffle ; -HELP: -rot ( x y z -- z x y ) $shuffle ; -HELP: dupd ( x y -- x x y ) $shuffle ; -HELP: swapd ( x y z -- y x z ) $shuffle ; HELP: nip ( x y -- y ) $shuffle ; HELP: 2nip ( x y z -- z ) $shuffle ; -HELP: tuck ( x y -- y x y ) $shuffle ; HELP: over ( x y -- x y x ) $shuffle ; HELP: 2over $shuffle ; HELP: pick ( x y z -- x y z x ) $shuffle ; HELP: swap ( x y -- y x ) $shuffle ; -HELP: spin $shuffle ; -HELP: roll $shuffle ; -HELP: -roll $shuffle ; + +HELP: rot ( x y z -- y z x ) $complex-shuffle ; +HELP: -rot ( x y z -- z x y ) $complex-shuffle ; +HELP: dupd ( x y -- x x y ) $complex-shuffle ; +HELP: swapd ( x y z -- y x z ) $complex-shuffle ; HELP: datastack ( -- ds ) { $values { "ds" array } } @@ -75,7 +72,11 @@ HELP: hashcode { $values { "obj" object } { "code" fixnum } } { $description "Computes the hashcode of an object with a default hashing depth. See " { $link hashcode* } " for the hashcode contract." } ; -{ hashcode hashcode* } related-words +HELP: identity-hashcode +{ $values { "obj" object } { "code" fixnum } } +{ $description "Outputs the identity hashcode of an object. The identity hashcode is not guaranteed to be unique, however it will not change during the object's lifetime." } ; + +{ hashcode hashcode* identity-hashcode } related-words HELP: = { $values { "obj1" object } { "obj2" object } { "?" "a boolean" } } @@ -168,7 +169,7 @@ HELP: xor { $notes "This word implements boolean exclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise exclusive or is the " { $link bitxor } " word." } ; HELP: both? -{ $values { "quot" { $quotation "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } } +{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ? )" } } { "?" "a boolean" } } { $description "Tests if the quotation yields a true value when applied to both " { $snippet "x" } " and " { $snippet "y" } "." } { $examples { $example "USING: kernel math prettyprint ;" "3 5 [ odd? ] both? ." "t" } @@ -176,7 +177,7 @@ HELP: both? } ; HELP: either? -{ $values { "quot" { $quotation "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } } +{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ? )" } } { "?" "a boolean" } } { $description "Tests if the quotation yields a true value when applied to either " { $snippet "x" } " or " { $snippet "y" } "." } { $examples { $example "USING: kernel math prettyprint ;" "3 6 [ odd? ] either? ." "t" } @@ -213,18 +214,18 @@ HELP: call-clear ( quot -- ) { $notes "Used to implement " { $link "threads" } "." } ; HELP: keep -{ $values { "quot" { $quotation "( x -- ... )" } } { "x" object } } +{ $values { "x" object } { "quot" { $quotation "( x -- ... )" } } } { $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." } { $examples { $example "USING: arrays kernel prettyprint ;" "2 \"greetings\" [ ] keep 2array ." "{ { \"greetings\" \"greetings\" } \"greetings\" }" } } ; HELP: 2keep -{ $values { "quot" { $quotation "( x y -- ... )" } } { "x" object } { "y" object } } +{ $values { "x" object } { "y" object } { "quot" { $quotation "( x y -- ... )" } } } { $description "Call a quotation with two values on the stack, restoring the values when the quotation returns." } ; HELP: 3keep -{ $values { "quot" { $quotation "( x y z -- ... )" } } { "x" object } { "y" object } { "z" object } } +{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( x y z -- ... )" } } } { $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ; HELP: bi @@ -279,11 +280,6 @@ HELP: 3bi "[ p ] [ q ] 3bi" "3dup p q" } - "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- w )" } ", then the following two lines are equivalent:" - { $code - "[ p ] [ q ] 3bi" - "3dup p -roll q" - } "In general, the following two lines are equivalent:" { $code "[ p ] [ q ] 3bi" @@ -657,14 +653,14 @@ HELP: declare HELP: tag ( object -- n ) { $values { "object" object } { "n" "a tag number" } } -{ $description "Outputs an object's tag number, between zero and one less than " { $link num-tags } ". This is implementation detail and user code should call " { $link class } " instead." } ; +{ $description "Outputs an object's tag number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ; HELP: getenv ( n -- obj ) { $values { "n" "a non-negative integer" } { "obj" object } } { $description "Reads an object from the Factor VM's environment table. User code never has to read the environment table directly; instead, use one of the callers of this word." } ; HELP: setenv ( obj n -- ) -{ $values { "n" "a non-negative integer" } { "obj" object } } +{ $values { "obj" object } { "n" "a non-negative integer" } } { $description "Writes an object to the Factor VM's environment table. User code never has to write to the environment table directly; instead, use one of the callers of this word." } ; HELP: object @@ -821,10 +817,22 @@ HELP: assert= { $values { "a" object } { "b" object } } { $description "Throws an " { $link assert } " error if " { $snippet "a" } " does not equal " { $snippet "b" } "." } ; -ARTICLE: "shuffle-words" "Shuffle words" -"Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions." +ARTICLE: "shuffle-words-complex" "Complex shuffle words" +"These shuffle words tend to make code difficult to read and to reason about. Code that uses them should almost always be rewritten using " { $link "locals" } " or " { $link "dataflow-combinators" } "." $nl -"The " { $link "cleave-combinators" } ", " { $link "spread-combinators" } " and " { $link "apply-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "." +"Duplicating stack elements deep in the stack:" +{ $subsections + dupd +} +"Permuting stack elements deep in the stack:" +{ $subsections + swapd + rot + -rot +} ; + +ARTICLE: "shuffle-words" "Shuffle words" +"Shuffle words rearrange items at the top of the data stack as indicated by their stack effects. They provide simple data flow control between words. More complex data flow control is available with the " { $link "dataflow-combinators" } " and with " { $link "locals" } "." $nl "Removing stack elements:" { $subsections @@ -839,21 +847,17 @@ $nl dup 2dup 3dup - dupd over 2over pick - tuck } "Permuting stack elements:" { $subsections swap - swapd - rot - -rot - spin - roll - -roll +} +"There are additional, more complex stack shuffling words whose use is not recommended." +{ $subsections + "shuffle-words-complex" } ; ARTICLE: "equality" "Equality" diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index c8e0fcd2a9..ded2ee9702 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -13,11 +13,11 @@ IN: kernel.tests [ ] [ 10000 [ [ -1 f ] ignore-errors ] times ] unit-test ! Make sure we report the correct error on stack underflow -[ clear drop ] [ { "kernel-error" 11 f f } = ] must-fail-with +[ clear drop ] [ { "kernel-error" 10 f f } = ] must-fail-with [ ] [ :c ] unit-test -[ 3 [ { } set-retainstack ] dip ] [ { "kernel-error" 13 f f } = ] must-fail-with +[ 3 [ { } set-retainstack ] dip ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ :c ] unit-test @@ -34,23 +34,20 @@ IN: kernel.tests [ t "no-compile" set-word-prop ] each >> -[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with +[ overflow-d ] [ { "kernel-error" 11 f f } = ] must-fail-with [ ] [ :c ] unit-test -[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with +[ overflow-d-alt ] [ { "kernel-error" 11 f f } = ] must-fail-with [ ] [ [ :c ] with-string-writer drop ] unit-test -[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with +[ overflow-r ] [ { "kernel-error" 13 f f } = ] must-fail-with [ ] [ :c ] unit-test [ -7 ] must-fail -[ 2 3 4 1 ] [ 1 2 3 4 roll ] unit-test -[ 1 2 3 4 ] [ 2 3 4 1 -roll ] unit-test - [ 3 ] [ t 3 and ] unit-test [ f ] [ f 3 and ] unit-test [ f ] [ 3 f and ] unit-test @@ -113,7 +110,7 @@ IN: kernel.tests < [ [ 1 + ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive : loop ( obj -- ) - H{ } values swap [ dup length swap ] dip 0 -roll (loop) ; + H{ } values swap [ dup length swap ] dip [ 0 ] 3dip (loop) ; [ loop ] must-fail @@ -172,3 +169,7 @@ IN: kernel.tests [ 3 -1 5/6 ] [ 1 2 3 4 5 6 [ + ] [ - ] [ / ] 2tri* ] unit-test [ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test + +[ t ] [ { } identity-hashcode fixnum? ] unit-test +[ 123 ] [ 123 identity-hashcode ] unit-test +[ t ] [ f identity-hashcode fixnum? ] unit-test diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 838d877a40..69d082ed2f 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -8,12 +8,6 @@ DEFER: 2dip DEFER: 3dip ! Stack stuff -: spin ( x y z -- z y x ) swap rot ; inline - -: roll ( x y z t -- y z t x ) [ rot ] dip swap ; inline - -: -roll ( x y z t -- t x y z ) swap [ -rot ] dip ; inline - : 2over ( x y z -- x y z x y ) pick pick ; inline : clear ( -- ) { } set-datastack ; @@ -63,9 +57,9 @@ DEFER: if : dip ( x quot -- x ) swap [ call ] dip ; -: 2dip ( x y quot -- x y ) -rot [ call ] 2dip ; +: 2dip ( x y quot -- x y ) swap [ dip ] dip ; -: 3dip ( x y z quot -- x y z ) -roll [ call ] 3dip ; +: 3dip ( x y z quot -- x y z ) swap [ 2dip ] dip ; : 4dip ( w x y z quot -- w x y z ) swap [ 3dip ] dip ; inline @@ -122,7 +116,7 @@ DEFER: if : 2bi@ ( w x y z quot -- ) dup 2bi* ; inline -: 2tri@ ( u v w y x z quot -- ) +: 2tri@ ( u v w x y z quot -- ) dup dup 2tri* ; inline ! Quotation building @@ -198,6 +192,16 @@ M: f hashcode* 2drop 31337 ; inline : hashcode ( obj -- code ) 3 swap hashcode* ; inline +: identity-hashcode ( obj -- code ) + dup tag 0 eq? [ + dup tag 1 eq? [ drop 0 ] [ + dup (identity-hashcode) dup 0 eq? [ + drop dup compute-identity-hashcode + (identity-hashcode) + ] [ nip ] if + ] if + ] unless ; inline + GENERIC: equal? ( obj1 obj2 -- ? ) M: object equal? 2drop f ; inline @@ -206,6 +210,8 @@ TUPLE: identity-tuple ; M: identity-tuple equal? 2drop f ; inline +M: identity-tuple hashcode* nip identity-hashcode ; inline + : = ( obj1 obj2 -- ? ) 2dup eq? [ 2drop t ] [ 2dup both-fixnums? [ 2drop f ] [ equal? ] if @@ -234,8 +240,6 @@ ERROR: assert got expect ; : declare ( spec -- ) drop ; -: hi-tag ( obj -- n ) { hi-tag } declare 0 slot ; inline - : do-primitive ( number -- ) "Improper primitive call" throw ; PRIVATE> diff --git a/core/layouts/layouts-docs.factor b/core/layouts/layouts-docs.factor index 8dd1e6901f..efea1ffb4e 100644 --- a/core/layouts/layouts-docs.factor +++ b/core/layouts/layouts-docs.factor @@ -7,18 +7,11 @@ HELP: tag-bits { $var-description "Number of least significant bits reserved for a type tag in a tagged pointer." } { $see-also tag } ; -HELP: num-tags -{ $var-description "Number of distinct pointer tags. This is one more than the maximum value from the " { $link tag } " primitive." } ; - HELP: tag-mask { $var-description "Taking the bitwise and of a tagged pointer with this mask leaves the tag." } ; HELP: num-types -{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link hi-tag } " primitive." } ; - -HELP: tag-number -{ $values { "class" class } { "n" "an integer or " { $link f } } } -{ $description "Outputs the pointer tag for pointers to instances of " { $link class } ". Will output " { $link f } " if instances of this class are not identified by a distinct pointer tag." } ; +{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link tag } " primitive." } ; HELP: type-number { $values { "class" class } { "n" "an integer or " { $link f } } } @@ -76,7 +69,7 @@ HELP: bootstrap-cell-bits ARTICLE: "layouts-types" "Type numbers" "Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:" -{ $subsections hi-tag } +{ $subsections tag } "Built-in type numbers can be converted to classes, and vice versa:" { $subsections type>class @@ -88,14 +81,10 @@ ARTICLE: "layouts-types" "Type numbers" ARTICLE: "layouts-tags" "Tagged pointers" "Every pointer stored on the stack or in the heap has a " { $emphasis "tag" } ", which is a small integer identifying the type of the pointer. If the tag is not equal to one of the two special tags, the remaining bits contain the memory address of a heap-allocated object. The two special tags are the " { $link fixnum } " tag and the " { $link f } " tag." $nl -"Getting the tag of an object:" -{ $link tag } "Words for working with tagged pointers:" { $subsections tag-bits - num-tags tag-mask - tag-number } "The Factor VM does not actually expose any words for working with tagged pointers directly. The above words operate on integers; they are used in the bootstrap image generator and the optimizing compiler." ; diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index be6276a684..05fe03315c 100644 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -4,32 +4,35 @@ USING: namespaces math words kernel assocs classes math.order kernel.private ; IN: layouts -SYMBOL: tag-mask +SYMBOL: data-alignment -SYMBOL: num-tags +SYMBOL: tag-mask SYMBOL: tag-bits SYMBOL: num-types -SYMBOL: tag-numbers - SYMBOL: type-numbers SYMBOL: mega-cache-size +SYMBOL: header-bits + : type-number ( class -- n ) type-numbers get at ; -: tag-number ( class -- n ) - type-number dup num-tags get >= [ drop object tag-number ] when ; - : tag-fixnum ( n -- tagged ) tag-bits get shift ; +: tag-header ( n -- tagged ) + header-bits get shift ; + : untag-fixnum ( n -- tagged ) tag-bits get neg shift ; +: hashcode-shift ( -- n ) + tag-bits get header-bits get + ; + ! We do this in its own compilation unit so that they can be ! folded below << @@ -58,7 +61,7 @@ SYMBOL: mega-cache-size first-bignum neg >fixnum ; inline : (max-array-capacity) ( b -- n ) - 5 - 2^ 1 - ; inline + 6 - 2^ 1 - ; inline : max-array-capacity ( -- n ) cell-bits (max-array-capacity) ; inline diff --git a/core/math/integers/integers-docs.factor b/core/math/integers/integers-docs.factor index c09f2950e4..e25bbf13e2 100644 --- a/core/math/integers/integers-docs.factor +++ b/core/math/integers/integers-docs.factor @@ -4,7 +4,7 @@ IN: math.integers ARTICLE: "integers" "Integers" { $subsections integer } "Integers come in two varieties -- fixnums and bignums. Fixnums fit in a machine word and are faster to manipulate; if the result of a fixnum operation is too large to fit in a fixnum, the result is upgraded to a bignum. Here is an example where two fixnums are multiplied yielding a bignum:" -{ $example "USE: classes" "134217728 class ." "fixnum" } +{ $example "USE: classes" "67108864 class ." "fixnum" } { $example "USE: classes" "128 class ." "fixnum" } { $example "134217728 128 * ." "17179869184" } { $example "USE: classes" "1 128 shift class ." "bignum" } diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index a9469ae91a..30d1254082 100644 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -23,8 +23,8 @@ IN: math.integers.tests [ -1 ] [ 1 neg ] unit-test [ -1 ] [ 1 >bignum neg ] unit-test -[ 268435456 ] [ -268435456 >fixnum -1 * ] unit-test -[ 268435456 ] [ -268435456 >fixnum neg ] unit-test +[ 134217728 ] [ -134217728 >fixnum -1 * ] unit-test +[ 134217728 ] [ -134217728 >fixnum neg ] unit-test [ 9 3 ] [ 93 10 /mod ] unit-test [ 9 3 ] [ 93 >bignum 10 /mod ] unit-test @@ -100,12 +100,12 @@ unit-test [ 16 ] [ 13 next-power-of-2 ] unit-test [ 16 ] [ 16 next-power-of-2 ] unit-test -[ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test -[ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test -[ 0 ] [ -1 -268435456 >fixnum /i ] unit-test +[ 134217728 ] [ -134217728 >fixnum -1 /i ] unit-test +[ 134217728 0 ] [ -134217728 >fixnum -1 /mod ] unit-test +[ 0 ] [ -1 -134217728 >fixnum /i ] unit-test [ 4420880996869850977 ] [ 13262642990609552931 3 /i ] unit-test -[ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test -[ 0 -1 ] [ -1 -268435456 >bignum /mod ] unit-test +[ 0 -1 ] [ -1 -134217728 >fixnum /mod ] unit-test +[ 0 -1 ] [ -1 -134217728 >bignum /mod ] unit-test [ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test [ 8 530505719624382123 ] [ 13262642990609552931 1591517158873146351 /mod ] unit-test [ 8 ] [ 13262642990609552931 1591517158873146351 /i ] unit-test @@ -117,7 +117,7 @@ unit-test [ f ] [ 30 zero? ] unit-test [ t ] [ 0 >bignum zero? ] unit-test -[ 4294967280 ] [ 268435455 >fixnum 16 fixnum* ] unit-test +[ 2147483632 ] [ 134217727 >fixnum 16 fixnum* ] unit-test [ 23603949310011464311086123800853779733506160743636399259558684142844552151041 ] [ @@ -156,7 +156,7 @@ unit-test [ 4294967296 ] [ 1 32 shift ] unit-test [ 1267650600228229401496703205376 ] [ 1 100 shift ] unit-test -[ t ] [ 1 27 shift fixnum? ] unit-test +[ t ] [ 1 26 shift fixnum? ] unit-test [ t ] [ t @@ -226,3 +226,7 @@ unit-test [ >float / ] [ /f ] 2bi 0.1 ~ ] all? ] unit-test + +! Ensure that /f is accurate for fixnums > 2^53 on 64-bit platforms +[ HEX: 1.758bec11492f9p-54 ] [ 1 12345678901234567 /f ] unit-test +[ HEX: -1.758bec11492f9p-54 ] [ 1 -12345678901234567 /f ] unit-test diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index e684b8edfb..eb94597160 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -33,7 +33,16 @@ M: fixnum + fixnum+ ; inline M: fixnum - fixnum- ; inline M: fixnum * fixnum* ; inline M: fixnum /i fixnum/i ; inline -M: fixnum /f [ >float ] dip >float float/f ; inline + +DEFER: bignum/f +CONSTANT: bignum/f-threshold HEX: 20,0000,0000,0000 + +: fixnum/f ( m n -- m/n ) + [ >float ] bi@ float/f ; inline + +M: fixnum /f + 2dup [ abs bignum/f-threshold >= ] either? + [ bignum/f ] [ fixnum/f ] if ; inline M: fixnum mod fixnum-mod ; inline @@ -144,5 +153,8 @@ M: bignum (log2) bignum-log2 ; inline ] if-zero ] if ; inline -M: bignum /f ( m n -- f ) +: bignum/f ( m n -- f ) [ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ; + +M: bignum /f ( m n -- f ) + bignum/f ; diff --git a/core/math/math.factor b/core/math/math.factor index 8ef4f38f9a..c1a8ba32f7 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -147,14 +147,16 @@ PRIVATE> : (find-integer) ( i n quot: ( i -- ? ) -- i ) [ - iterate-step roll - [ 2drop ] [ iterate-next (find-integer) ] if + iterate-step + [ [ ] ] 2dip + [ iterate-next (find-integer) ] 2curry bi-curry if ] [ 3drop f ] if-iterate? ; inline recursive : (all-integers?) ( i n quot: ( i -- ? ) -- ? ) [ - iterate-step roll - [ iterate-next (all-integers?) ] [ 3drop f ] if + iterate-step + [ iterate-next (all-integers?) ] 3curry + [ f ] if ] [ 3drop t ] if-iterate? ; inline recursive : each-integer ( n quot -- ) diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index a53604ddf9..f04c0104a5 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -5,39 +5,18 @@ strings arrays combinators splitting math assocs byte-arrays make ; IN: math.parser : digit> ( ch -- n ) - H{ - { CHAR: 0 0 } - { CHAR: 1 1 } - { CHAR: 2 2 } - { CHAR: 3 3 } - { CHAR: 4 4 } - { CHAR: 5 5 } - { CHAR: 6 6 } - { CHAR: 7 7 } - { CHAR: 8 8 } - { CHAR: 9 9 } - { CHAR: A 10 } - { CHAR: B 11 } - { CHAR: C 12 } - { CHAR: D 13 } - { CHAR: E 14 } - { CHAR: F 15 } - { CHAR: a 10 } - { CHAR: b 11 } - { CHAR: c 12 } - { CHAR: d 13 } - { CHAR: e 14 } - { CHAR: f 15 } - { CHAR: , f } - } at* [ drop 255 ] unless ; inline + 127 bitand { + { [ dup CHAR: 9 <= ] [ CHAR: 0 - ] } + { [ dup CHAR: a < ] [ CHAR: A 10 - - ] } + [ CHAR: a 10 - - ] + } cond + dup 0 < [ drop 255 ] [ dup 16 >= [ drop 255 ] when ] if ; inline : string>digits ( str -- digits ) [ digit> ] B{ } map-as ; inline : (digits>integer) ( valid? accum digit radix -- valid? accum ) - over [ - 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if - ] [ 2drop ] if ; inline + 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline : each-digit ( seq radix quot -- n/f ) [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline @@ -54,8 +33,8 @@ SYMBOL: negative? : string>natural ( seq radix -- n/f ) over empty? [ 2drop f ] [ - [ [ digit> ] dip (digits>integer) ] each-digit - ] if ; inline + [ over CHAR: , eq? [ 2drop ] [ [ digit> ] dip (digits>integer) ] if ] each-digit + ] if ; : sign ( -- str ) negative? get "-" "+" ? ; @@ -83,14 +62,14 @@ SYMBOL: negative? ] if ; inline : dec>float ( str -- n/f ) - [ CHAR: , eq? not ] filter - >byte-array 0 suffix (string>float) ; + [ CHAR: , eq? not ] BV{ } filter-as + 0 over push B{ } like (string>float) ; : hex>float-parts ( str -- neg? mantissa-str expt ) - "-" ?head swap "p" split1 [ 10 base> ] [ 0 ] if* ; + "-" ?head swap "p" split1 [ 10 base> ] [ 0 ] if* ; inline : make-mantissa ( str -- bits ) - 16 base> dup log2 52 swap - shift ; + 16 base> dup log2 52 swap - shift ; inline : combine-hex-float-parts ( neg? mantissa expt -- float ) dup 2046 > [ 2drop -1/0. 1/0. ? ] [ @@ -99,7 +78,7 @@ SYMBOL: negative? [ 52 2^ 1 - bitand ] [ 52 shift ] tri* bitor bitor bits>double - ] if ; + ] if ; inline : hex>float ( str -- n/f ) hex>float-parts @@ -111,23 +90,33 @@ SYMBOL: negative? { { 16 [ hex>float ] } [ drop dec>float ] - } case ; + } case ; inline : number-char? ( char -- ? ) - "0123456789ABCDEFabcdef." member? ; + "0123456789ABCDEFabcdef." member? ; inline + +: last-unsafe ( seq -- elt ) + [ length 1 - ] [ nth-unsafe ] bi ; inline : numeric-looking? ( str -- ? ) - "-" ?head drop dup empty? [ drop f ] [ - dup first number-char? [ - last number-char? - ] [ drop f ] if - ] if ; + dup first-unsafe number-char? [ + last-unsafe number-char? + ] [ + dup first-unsafe CHAR: - eq? [ + dup length 1 eq? [ drop f ] [ + 1 over nth-unsafe number-char? [ + last-unsafe number-char? + ] [ drop f ] if + ] if + ] [ drop f ] if + ] if + ] if ; inline PRIVATE> : string>float ( str -- n/f ) - 10 base>float ; + 10 base>float ; inline : base> ( str radix -- n/f ) over numeric-looking? [ @@ -138,20 +127,18 @@ PRIVATE> } case ] [ 2drop f ] if ; -: string>number ( str -- n/f ) 10 base> ; -: bin> ( str -- n/f ) 2 base> ; -: oct> ( str -- n/f ) 8 base> ; -: hex> ( str -- n/f ) 16 base> ; +: string>number ( str -- n/f ) 10 base> ; inline +: bin> ( str -- n/f ) 2 base> ; inline +: oct> ( str -- n/f ) 8 base> ; inline +: hex> ( str -- n/f ) 16 base> ; inline : >digit ( n -- ch ) - dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; + dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; inline : positive>base ( num radix -- str ) dup 1 <= [ "Invalid radix" throw ] when [ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip - dup reverse-here ; inline - -PRIVATE> + reverse! ; inline GENERIC# >base 1 ( n radix -- str ) @@ -234,12 +221,12 @@ M: ratio >base { { 16 [ float>hex ] } [ drop float>decimal ] - } case ; + } case ; inline PRIVATE> : float>string ( n -- str ) - 10 float>base ; + 10 float>base ; inline M: float >base { @@ -251,9 +238,9 @@ M: float >base [ float>base ] } cond ; -: number>string ( n -- str ) 10 >base ; -: >bin ( n -- str ) 2 >base ; -: >oct ( n -- str ) 8 >base ; -: >hex ( n -- str ) 16 >base ; +: number>string ( n -- str ) 10 >base ; inline +: >bin ( n -- str ) 2 >base ; inline +: >oct ( n -- str ) 8 >base ; inline +: >hex ( n -- str ) 16 >base ; inline -: # ( n -- ) number>string % ; +: # ( n -- ) number>string % ; inline diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor index d40705a531..acf187a33a 100644 --- a/core/memory/memory-docs.factor +++ b/core/memory/memory-docs.factor @@ -2,42 +2,20 @@ USING: help.markup help.syntax debugger sequences kernel quotations math ; IN: memory -HELP: begin-scan ( -- ) -{ $description "Disables the garbage collector and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects." -$nl -"This word must always be paired with a call to " { $link end-scan } "." } -{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ; - -HELP: next-object ( -- obj ) -{ $values { "obj" object } } -{ $description "Outputs the object at the heap scan pointer, and then advances the heap scan pointer. If the end of the heap has been reached, outputs " { $link f } ". This is unambiguous since the " { $link f } " object is tagged immediate and not actually stored in the heap." } -{ $errors "Throws a " { $link heap-scan-error. } " if called outside a " { $link begin-scan } "/" { $link end-scan } " pair." } -{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ; - -HELP: end-scan ( -- ) -{ $description "Finishes a heap iteration by re-enabling the garbage collector. This word must always be paired with a call to " { $link begin-scan } "." } -{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ; - -HELP: each-object -{ $values { "quot" { $quotation "( obj -- )" } } } -{ $description "Applies a quotation to each object in the heap. The garbage collector is switched off while this combinator runs, so the given quotation must not allocate too much memory." } -{ $notes "This word is the low-level facility used to implement the " { $link instances } " word." } ; - HELP: instances { $values { "quot" { $quotation "( obj -- ? )" } } { "seq" "a fresh sequence" } } -{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." } -{ $notes "This word relies on " { $link each-object } ", so in particular the garbage collector is switched off while it runs and the given quotation must not allocate too much memory." } ; +{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." } ; HELP: gc ( -- ) { $description "Performs a full garbage collection." } ; -HELP: data-room ( -- cards decks generations ) -{ $values { "cards" "number of kilobytes reserved for card marking" } { "decks" "number of kilobytes reserved for decks of cards" } { "generations" "array of free/total kilobytes pairs" } } -{ $description "Queries the runtime for memory usage information." } ; +HELP: data-room ( -- data-room ) +{ $values { "data-room" data-room } } +{ $description "Queries the VM for memory usage information." } ; -HELP: code-room ( -- code-total code-used code-free largest-free-block ) -{ $values { "code-total" "total kilobytes in the code heap" } { "code-used" "kilobytes used in the code heap" } { "code-free" "kilobytes free in the code heap" } { "largest-free-block" "size of largest free block" } } -{ $description "Queries the runtime for memory usage information." } ; +HELP: code-room ( -- code-room ) +{ $values { "code-room" code-room } } +{ $description "Queries the VM for memory usage information." } ; HELP: size ( obj -- n ) { $values { "obj" "an object" } { "n" "a size in bytes" } } @@ -56,17 +34,6 @@ HELP: save-image-and-exit ( path -- ) HELP: save { $description "Saves a snapshot of the heap to the current image file." } ; -HELP: count-instances -{ $values - { "quot" quotation } - { "n" integer } } -{ $description "Applies the predicate quotation to each object in the heap and returns the number of objects that match. Since this word uses " { $link each-object } " with the garbage collector switched off, avoid allocating too much memory in the quotation." } -{ $examples { $unchecked-example - "USING: memory words prettyprint ;" - "[ word? ] count-instances ." - "24210" -} } ; - ARTICLE: "images" "Images" "Factor has the ability to save the entire state of the system into an " { $emphasis "image file" } ". The image contains a complete dump of all data and code in the current Factor instance." { $subsections diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index 8ecf673b8a..45e6090e77 100755 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -31,4 +31,4 @@ TUPLE: testing x y z ; 2 [ [ [ 3 throw ] instances ] must-fail ] times ! Bug found on Windows build box, having too many words in the image breaks 'become' -[ ] [ 100000 [ f f ] replicate { } { } become drop ] unit-test +[ ] [ 100000 [ f ] replicate { } { } become drop ] unit-test diff --git a/core/memory/memory.factor b/core/memory/memory.factor index 1c61e33d83..4ab68a1ef1 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -1,26 +1,11 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences vectors arrays system math +USING: kernel continuations sequences system io.backend alien.strings memory.private ; IN: memory -: (each-object) ( quot: ( obj -- ) -- ) - next-object dup [ - swap [ call ] keep (each-object) - ] [ 2drop ] if ; inline recursive - -: each-object ( quot -- ) - gc begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline - -: count-instances ( quot -- n ) - 0 swap [ 1 0 ? + ] compose each-object ; inline - : instances ( quot -- seq ) - #! To ensure we don't need to grow the vector while scanning - #! the heap, we do two scans, the first one just counts the - #! number of objects that satisfy the predicate. - [ count-instances 100 + ] keep swap - [ [ push-if ] 2curry each-object ] keep >array ; inline + [ all-instances ] dip filter ; inline : save-image ( path -- ) normalize-path native-string>alien (save-image) ; diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor index 9fc4695e66..05a72c6025 100755 --- a/core/namespaces/namespaces-docs.factor +++ b/core/namespaces/namespaces-docs.factor @@ -43,24 +43,24 @@ ARTICLE: "namespaces.private" "Namespace implementation details" ndrop } ; -ARTICLE: "namespaces" "Dynamic variables and namespaces" -"The " { $vocab-link "namespaces" } " vocabulary implements simple dynamically-scoped variables." +ARTICLE: "namespaces" "Dynamic variables" +"The " { $vocab-link "namespaces" } " vocabulary implements dynamically-scoped variables." $nl -"A variable is an entry in an assoc of bindings, where the assoc is implicit rather than passed on the stack. These assocs are termed " { $emphasis "namespaces" } ". Nesting of scopes is implemented with a search order on namespaces, defined by a " { $emphasis "namestack" } ". Since namespaces are just assoc, any object can be used as a variable, however by convention, variables are keyed by symbols (see " { $link "words.symbol" } ")." +"A dynamic variable is an entry in an assoc of bindings, where the assoc is implicit rather than passed on the stack. These assocs are termed " { $emphasis "namespaces" } ". Nesting of scopes is implemented with a search order on namespaces, defined by a " { $emphasis "namestack" } ". Since namespaces are just assocs, any object can be used as a variable. By convention, variables are keyed by " { $link "words.symbol" } "." $nl -"The " { $link get } " and " { $link set } " words read and write variable values. The " { $link get } " word searches up the chain of nested namespaces, while " { $link set } " always sets variable values in the current namespace only. Namespaces are dynamically scoped; when a quotation is called from a nested scope, any words called by the quotation also execute in that scope." +"The " { $link get } " and " { $link set } " words read and write variable values. The " { $link get } " word searches the chain of nested namespaces, while " { $link set } " always sets variable values in the current namespace only. Namespaces are dynamically scoped; when a quotation is called from a nested scope, any words called by the quotation also execute in that scope." { $subsections get set } -"Various utility words abstract away common variable access patterns:" +"Various utility words provide common variable access patterns:" { $subsections "namespaces-change" "namespaces-combinators" } "Implementation details your code probably does not care about:" { $subsections "namespaces.private" } -"An alternative to dynamic scope is lexical scope. Lexically-scoped values and closures are implemented in the " { $vocab-link "locals" } " vocabulary." ; +"Dynamic variables complement " { $link "locals" } "." ; ABOUT: "namespaces" diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 7e94d71c29..97dbab384e 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -66,7 +66,7 @@ $nl $nl "Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can." $nl -"Because of the stack restriction, parsing words cannot pass data to other words by leaving values on the stack; instead, use " { $link parsed } " to add the data to the parse tree so that it can be evaluated later." +"Because of the stack restriction, parsing words cannot pass data to other words by leaving values on the stack; instead, use " { $link suffix! } " to add the data to the parse tree so that it can be evaluated later." $nl "Parsing words cannot be called from the same source file where they are defined, because new definitions are only compiled at the end of the source file. An attempt to use a parsing word in its own source file raises an error:" { $subsections staging-violation } @@ -172,11 +172,6 @@ $parsing-note ; { parse-tokens (parse-until) parse-until } related-words -HELP: parsed -{ $values { "accum" vector } { "obj" object } } -{ $description "Convenience word for parsing words. It behaves exactly the same as " { $link push } ", except the accumulator remains on the stack." } -$parsing-note ; - HELP: (parse-lines) { $values { "lexer" lexer } { "quot" "a new " { $link quotation } } } { $description "Parses Factor source code using a custom lexer. The vocabulary search path is taken from the current scope." } @@ -188,7 +183,7 @@ HELP: parse-lines { $errors "Throws a " { $link lexer-error } " if the input is malformed." } ; HELP: parse-base -{ $values { "base" "an integer between 2 and 36" } { "parsed" integer } } +{ $values { "parsed" integer } { "base" "an integer between 2 and 36" } { "parsed" integer } } { $description "Reads an integer in a specific numerical base from the parser input." } $parsing-note ; @@ -221,7 +216,7 @@ HELP: filter-moved { $description "Removes all definitions from " { $snippet "assoc2" } " which are in " { $snippet "assoc1" } " or are are no longer present in the current " { $link file } "." } ; HELP: forget-smudged -{ $description "Forgets removed definitions and prints a warning message if any of them are still referenced from other source files." } ; +{ $description "Forgets removed definitions." } ; HELP: finish-parsing { $values { "lines" "the lines of text just parsed" } { "quot" "the quotation just parsed" } } diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 791fe1fa36..f30eb68684 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -141,15 +141,15 @@ IN: parser.tests ] unit-test [ t ] [ - array "smudge-me" "parser.tests" lookup order memq? + array "smudge-me" "parser.tests" lookup order member-eq? ] unit-test [ t ] [ - integer "smudge-me" "parser.tests" lookup order memq? + integer "smudge-me" "parser.tests" lookup order member-eq? ] unit-test [ f ] [ - string "smudge-me" "parser.tests" lookup order memq? + string "smudge-me" "parser.tests" lookup order member-eq? ] unit-test [ ] [ diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 3152afc093..d920e1fc73 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -79,8 +79,6 @@ HOOK: parse-quotation quotation-parser ( -- quot ) M: f parse-quotation \ ] parse-until >quotation ; -: parsed ( accum obj -- accum ) over push ; - : (parse-lines) ( lexer -- quot ) [ f parse-until >quotation ] with-lexer ; @@ -88,7 +86,7 @@ M: f parse-quotation \ ] parse-until >quotation ; lexer-factory get call( lines -- lexer ) (parse-lines) ; : parse-literal ( accum end quot -- accum ) - [ parse-until ] dip call parsed ; inline + [ parse-until ] dip call suffix! ; inline : parse-definition ( -- quot ) \ ; parse-until >quotation ; @@ -104,7 +102,7 @@ ERROR: bad-number ; scan swap base> [ bad-number ] unless* ; : parse-base ( parsed base -- parsed ) - scan-base parsed ; + scan-base suffix! ; SYMBOL: bootstrap-syntax diff --git a/core/quotations/quotations-docs.factor b/core/quotations/quotations-docs.factor index 983ddbaf9a..b6be8d36f3 100644 --- a/core/quotations/quotations-docs.factor +++ b/core/quotations/quotations-docs.factor @@ -3,29 +3,28 @@ vectors kernel combinators ; IN: quotations ARTICLE: "quotations" "Quotations" -"Conceptually, a quotation is an anonymous function (a value denoting a snippet of code) which can be passed around and called." +"A quotation is an anonymous function (a value denoting a snippet of code) which can be used as a value and called. Quotations are delimited by square brackets (" { $snippet "[ ]" } "); see " { $link "syntax-quots" } " for details on their syntax." $nl -"Concretely, a quotation is an immutable sequence of objects, some of which may be words, together with a block of machine code which may be executed to achieve the effect of evaluating the quotation. The machine code is generated by a fast non-optimizing quotation compiler which is always running and is transparent to the developer." -$nl -"Quotations form a class of objects, however in most cases, methods should dispatch on " { $link callable } " instead, so that " { $link curry } " and " { $link compose } " values can participate." +"Quotations form a class of objects:" { $subsections quotation quotation? } -"Quotations evaluate sequentially from beginning to end. Literals are pushed on the stack and words are executed. Details can be found in " { $link "evaluator" } "." -$nl -"Quotation literal syntax is documented in " { $link "syntax-quots" } "." -$nl +"A more general class is provided for methods to dispatch on that includes quotations, " { $link curry } ", and " { $link compose } " objects:" +{ $subsections + callable +} +"Quotations evaluate sequentially from beginning to end. Literals are pushed on the stack and words are executed. Details can be found in " { $link "evaluator" } ". Words can be placed in wrappers to suppress execution:" +{ $subsections "wrappers" } "Quotations implement the " { $link "sequence-protocol" } ", and existing sequences can be converted into quotations:" { $subsections >quotation 1quotation } -"Wrappers:" -{ $subsections "wrappers" } ; +"Although quotations can be treated as sequences, the compiler will be unable to reason about quotations manipulated as sequences at runtime. " { $link "compositional-combinators" } " are provided for runtime partial application and composition of quotations." ; ARTICLE: "wrappers" "Wrappers" -"Wrappers are used to push words on the data stack; they evaluate to the object being wrapped:" +"Wrappers evaluate to the object being wrapped when encountered in code. They are are used to suppress the execution of " { $link "words" } " so that they can be used as values." { $subsections wrapper literalize diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index f2b17b3f9d..2af94159f8 100644 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -61,7 +61,7 @@ INSTANCE: curry immutable-sequence M: compose length [ first>> length ] [ second>> length ] bi + ; -M: compose virtual-seq first>> ; +M: compose virtual-exemplar first>> ; M: compose virtual@ 2dup first>> length < [ diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor index 49b6ec1374..db2649142d 100644 --- a/core/sbufs/sbufs.factor +++ b/core/sbufs/sbufs.factor @@ -23,13 +23,13 @@ M: sbuf like dup string? [ dup length sbuf boa ] [ >sbuf ] if ] unless ; inline -M: sbuf new-resizable drop ; inline - M: sbuf equal? over sbuf? [ sequence= ] [ 2drop f ] if ; M: string new-resizable drop ; inline +M: sbuf new-resizable drop ; inline + M: string like #! If we have a string, we're done. #! If we have an sbuf, and it's at full capacity, we're done. diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index ef02754a60..6d7ff241ef 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -44,7 +44,7 @@ HELP: nths { $values { "indices" sequence } { "seq" sequence } { "seq'" sequence } } -{ $description "Ouptuts a sequence of elements from the input sequence indexed by the indices." } +{ $description "Outputs a sequence of elements from the input sequence indexed by the indices." } { $examples { $example "USING: prettyprint sequences ;" "{ 0 2 } { \"a\" \"b\" \"c\" } nths ." @@ -218,7 +218,7 @@ HELP: 3sequence { $description "Creates a three-element sequence of the same type as " { $snippet "exemplar" } "." } ; HELP: 4sequence -{ $values { "obj1" object } { "obj2" object } { "exemplar" sequence } { "obj3" object } { "obj4" object } { "seq" sequence } } +{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "obj4" object } { "exemplar" sequence } { "seq" sequence } } { $description "Creates a four-element sequence of the same type as " { $snippet "exemplar" } "." } ; HELP: first2 @@ -277,7 +277,7 @@ HELP: reduce-index } } ; HELP: accumulate-as -{ $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "exemplar" sequence } { "final" "the final result" } { "newseq" "a new sequence" } } +{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "exemplar" sequence } { "final" "the final result" } { "newseq" "a new sequence" } } { $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of the same type as " { $snippet "exemplar" } " containing intermediate results, together with the final result." $nl "The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence." @@ -285,7 +285,7 @@ $nl "When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." } ; HELP: accumulate -{ $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new array" } } +{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new array" } } { $description "Combines successive elements of the sequence using a binary operation, and outputs an array of intermediate results, together with the final result." $nl "The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence." @@ -295,12 +295,23 @@ $nl { $example "USING: math prettyprint sequences ;" "{ 2 2 2 2 2 } 0 [ + ] accumulate . ." "{ 0 2 4 6 8 }\n10" } } ; +HELP: accumulate! +{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "seq" sequence } } +{ $description "Combines successive elements of the sequence using a binary operation, and outputs the original sequence of intermediate results, together with the final result." +$nl +"The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence." +$nl +"When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." } +{ $examples + { $example "USING: math prettyprint sequences ;" "{ 2 2 2 2 2 } 0 [ + ] accumulate! . ." "{ 0 2 4 6 8 }\n10" } +} ; + HELP: map { $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "newseq" "a new sequence" } } { $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ; HELP: map-as -{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "newseq" "a new sequence" } { "exemplar" sequence } } +{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } } { $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as " { $snippet "exemplar" } "." } { $examples "The following example converts a string into an array of one-element strings:" @@ -332,9 +343,9 @@ HELP: change-nth { $errors "Throws an error if the sequence is immutable, if the index is out of bounds, or the sequence cannot hold elements of the type output by " { $snippet "quot" } "." } { $side-effects "seq" } ; -HELP: change-each -{ $values { "seq" "a mutable sequence" } { "quot" { $quotation "( old -- new )" } } } -{ $description "Applies the quotation to each element yielding a new element, storing the new elements back in the original sequence." } +HELP: map! +{ $values { "seq" "a mutable sequence" } { "quot" { $quotation "( old -- new )" } } { "seq" "a mutable sequence" } } +{ $description "Applies the quotation to each element yielding a new element, storing the new elements back in the original sequence. Returns the original sequence." } { $errors "Throws an error if the sequence is immutable, or the sequence cannot hold elements of the type output by " { $snippet "quot" } "." } { $side-effects "seq" } ; @@ -426,8 +437,12 @@ HELP: filter { $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "subseq" "a new sequence" } } { $description "Applies the quotation to each element in turn, and outputs a new sequence containing the elements of the original sequence for which the quotation output a true value." } ; -HELP: filter-here -{ $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( elt -- ? )" } } } +HELP: filter-as +{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "exemplar" sequence } { "subseq" "a new sequence" } } +{ $description "Applies the quotation to each element in turn, and outputs a new sequence of the same type as " { $snippet "exemplar" } " containing the elements of the original sequence for which the quotation output a true value." } ; + +HELP: filter! +{ $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( elt -- ? )" } } { "seq" "a resizable mutable sequence" } } { $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." } { $side-effects "seq" } ; @@ -457,7 +472,7 @@ HELP: member? { $description "Tests if the sequence contains an element equal to the object." } { $notes "This word uses equality comparison (" { $link = } ")." } ; -HELP: memq? +HELP: member-eq? { $values { "elt" object } { "seq" sequence } { "?" "a boolean" } } { $description "Tests if the sequence contains the object." } { $notes "This word uses identity comparison (" { $link eq? } ")." } ; @@ -467,7 +482,7 @@ HELP: remove { $description "Outputs a new sequence containing all elements of the input sequence except for given element." } { $notes "This word uses equality comparison (" { $link = } ")." } ; -HELP: remq +HELP: remove-eq { $values { "elt" object } { "seq" sequence } { "newseq" "a new sequence" } } { $description "Outputs a new sequence containing all elements of the input sequence except those equal to the given element." } { $notes "This word uses identity comparison (" { $link eq? } ")." } ; @@ -483,24 +498,24 @@ HELP: remove-nth } } ; HELP: move -{ $values { "from" "an index in " { $snippet "seq" } } { "to" "an index in " { $snippet "seq" } } { "seq" "a mutable sequence" } } +{ $values { "to" "an index in " { $snippet "seq" } } { "from" "an index in " { $snippet "seq" } } { "seq" "a mutable sequence" } } { $description "Sets the element with index " { $snippet "m" } " to the element with index " { $snippet "n" } "." } { $side-effects "seq" } ; -HELP: delete -{ $values { "elt" object } { "seq" "a resizable mutable sequence" } } -{ $description "Removes all elements equal to " { $snippet "elt" } " from " { $snippet "seq" } "." } +HELP: remove! +{ $values { "elt" object } { "seq" "a resizable mutable sequence" } { "elt" object } } +{ $description "Removes all elements equal to " { $snippet "elt" } " from " { $snippet "seq" } " and returns " { $snippet "seq" } "." } { $notes "This word uses equality comparison (" { $link = } ")." } { $side-effects "seq" } ; -HELP: delq -{ $values { "elt" object } { "seq" "a resizable mutable sequence" } } +HELP: remove-eq! +{ $values { "elt" object } { "seq" "a resizable mutable sequence" } { "seq" "a resizable mutable sequence" } } { $description "Outputs a new sequence containing all elements of the input sequence except the given element." } { $notes "This word uses identity comparison (" { $link eq? } ")." } { $side-effects "seq" } ; -HELP: delete-nth -{ $values { "n" "a non-negative integer" } { "seq" "a resizable mutable sequence" } } +HELP: remove-nth! +{ $values { "n" "a non-negative integer" } { "seq" "a resizable mutable sequence" } { "seq" "a resizable mutable sequence" } } { $description "Removes the " { $snippet "n" } "th element from the sequence, shifting all other elements down and reducing its length by one." } { $side-effects "seq" } ; @@ -510,7 +525,7 @@ HELP: delete-slice { $side-effects "seq" } ; HELP: replace-slice -{ $values { "new" sequence } { "seq" sequence } { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq'" sequence } } +{ $values { "new" sequence } { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "seq'" sequence } } { $description "Replaces a range of elements beginning at index " { $snippet "from" } " and ending before index " { $snippet "to" } " with a new sequence." } { $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." } ; @@ -524,6 +539,21 @@ HELP: suffix { $example "USING: prettyprint sequences ;" "{ 1 2 3 } 4 suffix ." "{ 1 2 3 4 }" } } ; +HELP: suffix! +{ $values { "seq" sequence } { "elt" object } { "seq" sequence } } +{ $description "Modifiers a sequence in-place by adding " { $snippet "elt" } " to the end of " { $snippet "seq" } ". Outputs " { $snippet "seq" } "." } +{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq" } "." } +{ $examples + { $example "USING: prettyprint sequences ;" "V{ 1 2 3 } 4 suffix! ." "V{ 1 2 3 4 }" } +} ; + +HELP: append! +{ $values { "seq1" sequence } { "seq2" sequence } { "seq1" sequence } } +{ $description "Modifiers " { $snippet "seq1" } " in-place by adding the elements from " { $snippet "seq2" } " to the end and outputs " { $snippet "seq1" } "." } +{ $examples + { $example "USING: prettyprint sequences ;" "V{ 1 2 3 } { 4 5 6 } append! ." "V{ 1 2 3 4 5 6 }" } +} ; + HELP: prefix { $values { "seq" sequence } { "elt" object } { "newseq" sequence } } { $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the beginning of " { $snippet "seq" } "." } @@ -586,9 +616,9 @@ HELP: exchange { $values { "m" "a non-negative integer" } { "n" "a non-negative integer" } { "seq" "a mutable sequence" } } { $description "Exchanges the " { $snippet "m" } "th and " { $snippet "n" } "th elements of " { $snippet "seq" } "." } ; -HELP: reverse-here +HELP: reverse! { $values { "seq" "a mutable sequence" } } -{ $description "Reverses a sequence in-place." } +{ $description "Reverses a sequence in-place and outputs that sequence." } { $side-effects "seq" } ; HELP: padding @@ -616,7 +646,7 @@ HELP: reverse { $values { "seq" sequence } { "newseq" "a new sequence" } } { $description "Outputs a new sequence having the same elements as " { $snippet "seq" } " but in reverse order." } ; -{ reverse reverse-here } related-words +{ reverse reverse! } related-words HELP: { $values { "seq" sequence } { "reversed" "a new sequence" } } @@ -857,7 +887,7 @@ HELP: tail? { $values { "seq" sequence } { "end" sequence } { "?" "a boolean" } } { $description "Tests if " { $snippet "seq" } " ends with " { $snippet "end" } ". If " { $snippet "end" } " is longer than " { $snippet "seq" } ", this word outputs " { $link f } "." } ; -{ remove remove-nth remq delq delete delete-nth } related-words +{ remove remove-nth remove-eq remove-eq! remove! remove-nth! } related-words HELP: cut-slice { $values { "seq" sequence } { "n" "a non-negative integer" } { "before-slice" sequence } { "after-slice" "a slice" } } @@ -945,13 +975,12 @@ HELP: produce-as { $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence of type " { $snippet "exemplar" } " at the end." } { $examples "See " { $link produce } " for examples." } ; -HELP: sigma +HELP: map-sum { $values { "seq" sequence } { "quot" quotation } { "n" number } } { $description "Like map sum, but without creating an intermediate sequence." } { $example - "! Find the sum of the squares [0,99]" "USING: math math.ranges sequences prettyprint ;" - "100 [1,b] [ sq ] sigma ." + "100 [1,b] [ sq ] map-sum ." "338350" } ; @@ -1061,7 +1090,7 @@ HELP: harvest } } ; -{ filter filter-here sift harvest } related-words +{ filter filter! sift harvest } related-words HELP: set-first { $values @@ -1146,17 +1175,17 @@ HELP: partition } } ; -HELP: virtual-seq +HELP: virtual-exemplar { $values { "seq" sequence } { "seq'" sequence } } -{ $description "Part of the virtual sequence protocol, this word is used to return an underlying array from which to look up a value at an index given by " { $link virtual@ } "." } ; +{ $description "Part of the virtual sequence protocol, this word is used to return an exemplar of the underlying storage. This is used in words like " { $link new-sequence } "." } ; HELP: virtual@ { $values { "n" integer } { "seq" sequence } { "n'" integer } { "seq'" sequence } } -{ $description "Part of the sequence protocol, this word translates the input index " { $snippet "n" } " into an index into the underlying storage returned by " { $link virtual-seq } "." } ; +{ $description "Part of the sequence protocol, this word translates the input index " { $snippet "n" } " into an index and the underlying storage this index points into." } ; HELP: 2map-reduce { $values @@ -1368,9 +1397,9 @@ $nl ARTICLE: "virtual-sequences-protocol" "Virtual sequence protocol" "Virtual sequences must know their length:" { $subsections length } -"The underlying sequence to look up a value in:" -{ $subsections virtual-seq } -"The index of the value in the underlying sequence:" +"An exemplar of the underlying storage:" +{ $subsections virtual-exemplar } +"The index and the underlying storage where the value is located:" { $subsections virtual@ } ; ARTICLE: "virtual-sequences" "Virtual sequences" @@ -1412,7 +1441,7 @@ ARTICLE: "sequences-add-remove" "Adding and removing sequence elements" "Adding elements:" { $subsections prefix suffix insert-nth } "Removing elements:" -{ $subsections remove remq remove-nth } ; +{ $subsections remove remove-eq remove-nth } ; ARTICLE: "sequences-reshape" "Reshaping sequences" "A " { $emphasis "repetition" } " is a virtual sequence consisting of a single element repeated multiple times:" @@ -1506,12 +1535,14 @@ ARTICLE: "sequences-combinators" "Sequence combinators" map-reduce accumulate accumulate-as + accumulate! produce produce-as } "Filtering:" { $subsections filter + filter-as partition } "Testing if a sequence contains elements satisfying a predicate:" @@ -1546,7 +1577,7 @@ ARTICLE: "sequences-tests" "Testing sequences" "Testing indices:" { $subsections bounds-check? } "Testing if a sequence contains an object:" -{ $subsections member? memq? } +{ $subsections member? member-eq? } "Testing if a sequence contains a subsequence:" { $subsections head? tail? subseq? } ; @@ -1576,57 +1607,55 @@ ARTICLE: "sequences-trimming" "Trimming sequences" { $subsections trim-slice trim-head-slice trim-tail-slice } ; ARTICLE: "sequences-destructive-discussion" "When to use destructive operations" -"Constructive (non-destructive) operations should be preferred where possible because code without side-effects is usually more re-usable and easier to reason about. There are two main reasons to use destructive operations:" +"Constructive (non-destructive) operations should be preferred where possible because code without side-effects is usually more reusable and easier to reason about. There are two main reasons to use destructive operations:" { $list "For the side-effect. Some code is simpler to express with destructive operations; constructive operations return new objects, and sometimes ``threading'' the objects through the program manually complicates stack shuffling." - { "As an optimization. Some code can be written to use constructive operations, however would suffer from worse performance. An example is a loop which adds an element to a sequence on each iteration; one could use either " { $link suffix } " or " { $link push } ", however the former copies the entire sequence first, which would cause the loop to run in quadratic time." } + { "As an optimization. Some code written to use constructive operations suffers from worse performance. An example is a loop which adds an element to a sequence on each iteration. Either " { $link suffix } " or " { $link suffix! } " could be used; however, the former copies the entire sequence each time, which would cause the loop to run in quadratic time." } } "The second reason is much weaker than the first one. In particular, many combinators (see " { $link map } ", " { $link produce } " and " { $link "namespaces-make" } ") as well as more advanced data structures (such as " { $vocab-link "persistent.vectors" } ") alleviate the need for explicit use of side effects." ; ARTICLE: "sequences-destructive" "Destructive operations" -"Changing elements:" -{ $subsections change-each change-nth } -"Deleting elements:" -{ $subsections - delete - delq - delete-nth - delete-slice - delete-all - filter-here -} -"Other destructive words:" -{ $subsections - reverse-here - push-all - move - exchange - copy -} "Many operations have constructive and destructive variants:" { $table { "Constructive" "Destructive" } - { { $link suffix } { $link push } } - { { $link but-last } { $link pop* } } - { { $link unclip-last } { $link pop } } - { { $link remove } { $link delete } } - { { $link remq } { $link delq } } - { { $link remove-nth } { $link delete-nth } } - { { $link reverse } { $link reverse-here } } - { { $link append } { $link push-all } } - { { $link map } { $link change-each } } - { { $link filter } { $link filter-here } } + { { $link suffix } { $link suffix! } } + { { $link remove } { $link remove! } } + { { $link remove-eq } { $link remove-eq! } } + { { $link remove-nth } { $link remove-nth! } } + { { $link reverse } { $link reverse! } } + { { $link append } { $link append! } } + { { $link map } { $link map! } } + { { $link filter } { $link filter! } } +} +"Changing elements:" +{ $subsections map! change-nth } +"Deleting elements:" +{ $subsections + remove! + remove-eq! + remove-nth! + delete-slice + delete-all + filter! +} +"Other destructive words:" +{ $subsections + reverse! + append! + move + exchange + copy } { $heading "Related Articles" } { $subsections "sequences-destructive-discussion" "sequences-stacks" } -{ $see-also set-nth push pop } ; +{ $see-also set-nth push push-all pop pop* } ; ARTICLE: "sequences-stacks" "Treating sequences as stacks" "The classical stack operations, modifying a sequence in place:" -{ $subsections push pop pop* } +{ $subsections push push-all pop pop* } { $see-also empty? } ; ARTICLE: "sequences-comparing" "Comparing sequences" diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index e36bfaf9d2..c82caec3f9 100644 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -24,6 +24,12 @@ IN: sequences.tests [ 5040 { 1 1 2 6 24 120 720 } ] [ { 1 2 3 4 5 6 7 } 1 [ * ] accumulate ] unit-test +[ 5040 { 1 1 2 6 24 120 720 } ] +[ { 1 2 3 4 5 6 7 } 1 [ * ] accumulate! ] unit-test + +[ t ] +[ { 1 2 3 4 5 6 7 } dup 1 [ * ] accumulate! nip eq? ] unit-test + [ f f ] [ [ ] [ ] find ] unit-test [ 0 1 ] [ [ 1 ] [ ] find ] unit-test [ 1 "world" ] [ [ "hello" "world" ] [ "world" = ] find ] unit-test @@ -42,7 +48,7 @@ IN: sequences.tests [ t ] [ 2 [ 1 2 ] member? ] unit-test [ t ] -[ [ "hello" "world" ] [ second ] keep memq? ] unit-test +[ [ "hello" "world" ] [ second ] keep member-eq? ] unit-test [ 4 ] [ CHAR: x "tuvwxyz" >vector index ] unit-test @@ -59,10 +65,10 @@ IN: sequences.tests [ [ 3 ] ] [ [ 1 2 3 ] 2 [ swap < ] curry filter ] unit-test -[ V{ 1 2 3 } ] [ V{ 1 4 2 5 3 6 } clone [ [ 4 < ] filter-here ] keep ] unit-test -[ V{ 4 2 6 } ] [ V{ 1 4 2 5 3 6 } clone [ [ 2 mod 0 = ] filter-here ] keep ] unit-test +[ V{ 1 2 3 } ] [ V{ 1 4 2 5 3 6 } clone [ 4 < ] filter! ] unit-test +[ V{ 4 2 6 } ] [ V{ 1 4 2 5 3 6 } clone [ 2 mod 0 = ] filter! ] unit-test -[ V{ 3 } ] [ V{ 1 2 3 } clone [ 2 [ swap < ] curry filter-here ] keep ] unit-test +[ V{ 3 } ] [ V{ 1 2 3 } clone 2 [ swap < ] curry filter! ] unit-test [ "hello world how are you" ] [ { "hello" "world" "how" "are" "you" } " " join ] @@ -126,11 +132,11 @@ unit-test [ 4 [ CHAR: a ] map ] unit-test -[ V{ } ] [ "f" V{ } clone [ delete ] keep ] unit-test -[ V{ } ] [ "f" V{ "f" } clone [ delete ] keep ] unit-test -[ V{ } ] [ "f" V{ "f" "f" } clone [ delete ] keep ] unit-test -[ V{ "x" } ] [ "f" V{ "f" "x" "f" } clone [ delete ] keep ] unit-test -[ V{ "y" "x" } ] [ "f" V{ "y" "f" "x" "f" } clone [ delete ] keep ] unit-test +[ V{ } ] [ "f" V{ } clone remove! ] unit-test +[ V{ } ] [ "f" V{ "f" } clone remove! ] unit-test +[ V{ } ] [ "f" V{ "f" "f" } clone remove! ] unit-test +[ V{ "x" } ] [ "f" V{ "f" "x" "f" } clone remove! ] unit-test +[ V{ "y" "x" } ] [ "f" V{ "y" "f" "x" "f" } clone remove! ] unit-test [ V{ 0 1 4 5 } ] [ 6 >vector 2 4 pick delete-slice ] unit-test @@ -162,7 +168,7 @@ unit-test { "a" } 0 2 { 1 2 3 } replace-slice ] unit-test -[ { 1 4 9 } ] [ { 1 2 3 } clone dup [ sq ] change-each ] unit-test +[ { 1 4 9 } ] [ { 1 2 3 } clone [ sq ] map! ] unit-test [ 5 ] [ 1 >bignum { 1 5 7 } nth-unsafe ] unit-test [ 5 ] [ 1 >bignum { 1 5 7 } nth-unsafe ] unit-test @@ -207,7 +213,7 @@ unit-test [ 10 "hi" "bye" copy ] must-fail [ V{ 1 2 3 5 6 } ] [ - 3 V{ 1 2 3 4 5 6 } clone [ delete-nth ] keep + 3 V{ 1 2 3 4 5 6 } clone remove-nth! ] unit-test ! erg's random tester found this one @@ -227,7 +233,7 @@ unit-test [ -3 10 nth ] must-fail [ 11 10 nth ] must-fail -[ -1/0. 0 delete-nth ] must-fail +[ -1/0. 0 remove-nth! ] must-fail [ "" ] [ "" [ CHAR: \s = ] trim ] unit-test [ "" ] [ "" [ CHAR: \s = ] trim-head ] unit-test [ "" ] [ "" [ CHAR: \s = ] trim-tail ] unit-test @@ -237,7 +243,7 @@ unit-test [ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-head ] unit-test [ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-tail ] unit-test -[ 328350 ] [ 100 [ sq ] sigma ] unit-test +[ 328350 ] [ 100 [ sq ] map-sum ] unit-test [ 50 ] [ 100 [ even? ] count ] unit-test [ 50 ] [ 100 [ odd? ] count ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index c64095cb73..5017e52ce5 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -170,27 +170,27 @@ PRIVATE> 4 swap [ (4sequence) ] new-like ; inline : first2 ( seq -- first second ) - 1 swap bounds-check nip first2-unsafe ; flushable + 1 swap bounds-check nip first2-unsafe ; inline : first3 ( seq -- first second third ) - 2 swap bounds-check nip first3-unsafe ; flushable + 2 swap bounds-check nip first3-unsafe ; inline : first4 ( seq -- first second third fourth ) - 3 swap bounds-check nip first4-unsafe ; flushable + 3 swap bounds-check nip first4-unsafe ; inline : ?nth ( n seq -- elt/f ) 2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; inline MIXIN: virtual-sequence -GENERIC: virtual-seq ( seq -- seq' ) +GENERIC: virtual-exemplar ( seq -- seq' ) GENERIC: virtual@ ( n seq -- n' seq' ) M: virtual-sequence nth virtual@ nth ; inline M: virtual-sequence set-nth virtual@ set-nth ; inline M: virtual-sequence nth-unsafe virtual@ nth-unsafe ; inline M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ; inline -M: virtual-sequence like virtual-seq like ; inline -M: virtual-sequence new-sequence virtual-seq new-sequence ; inline +M: virtual-sequence like virtual-exemplar like ; inline +M: virtual-sequence new-sequence virtual-exemplar new-sequence ; inline INSTANCE: virtual-sequence sequence @@ -199,7 +199,7 @@ TUPLE: reversed { seq read-only } ; C: reversed -M: reversed virtual-seq seq>> ; inline +M: reversed virtual-exemplar seq>> ; inline M: reversed virtual@ seq>> [ length swap - 1 - ] keep ; inline M: reversed length seq>> length ; inline @@ -231,7 +231,7 @@ TUPLE: slice-error from to seq reason ; check-slice slice boa ; inline -M: slice virtual-seq seq>> ; inline +M: slice virtual-exemplar seq>> ; inline M: slice virtual@ [ from>> + ] [ seq>> ] bi ; inline @@ -268,33 +268,36 @@ INSTANCE: repetition immutable-sequence ERROR: integer-length-expected obj ; : check-length ( n -- n ) - #! Ricing. dup integer? [ integer-length-expected ] unless ; inline -: ((copy)) ( dst i src j n -- dst i src j n ) - dup -roll [ - + swap nth-unsafe -roll [ - + swap set-nth-unsafe - ] 3keep drop - ] 3keep ; inline +TUPLE: copy-state + { src-i read-only } + { src read-only } + { dst-i read-only } + { dst read-only } ; -: (copy) ( dst i src j n -- dst ) - dup 0 <= [ 2drop 2drop ] [ 1 - ((copy)) (copy) ] if ; +C: copy-state + +: ((copy)) ( n copy -- ) + [ [ src-i>> + ] [ src>> ] bi nth-unsafe ] + [ [ dst-i>> + ] [ dst>> ] bi set-nth-unsafe ] 2bi ; inline + +: (copy) ( n copy -- dst ) + over 0 <= [ nip dst>> ] [ [ 1 - ] dip [ ((copy)) ] [ (copy) ] 2bi ] if ; inline recursive -: prepare-subseq ( from to seq -- dst i src j n ) - #! The check-length call forces partial dispatch - [ [ swap - ] dip new-sequence dup 0 ] 3keep - -rot drop roll length check-length ; inline +: subseq>copy ( from to seq -- n copy ) + [ over - check-length swap ] dip + 3dup nip new-sequence 0 swap ; inline -: check-copy ( src n dst -- ) - over 0 < [ bounds-error ] when +: check-copy ( src n dst -- src n dst ) + 3dup over 0 < [ bounds-error ] when [ swap length + ] dip lengthen ; inline PRIVATE> : subseq ( from to seq -- subseq ) - [ check-slice prepare-subseq (copy) ] keep like ; + [ check-slice subseq>copy (copy) ] keep like ; : head ( seq n -- headseq ) (head) subseq ; @@ -310,8 +313,8 @@ PRIVATE> : copy ( src i dst -- ) #! The check-length call forces partial dispatch - pick length check-length [ 3dup check-copy spin 0 ] dip - (copy) drop ; inline + [ [ length check-length 0 ] keep ] 2dip + check-copy (copy) drop ; inline M: sequence clone-like [ dup length ] dip new-sequence [ 0 swap copy ] keep ; inline @@ -429,15 +432,21 @@ PRIVATE> : replicate-as ( seq quot exemplar -- newseq ) [ [ drop ] prepose ] dip map-as ; inline -: change-each ( seq quot -- ) - over map-into ; inline +: map! ( seq quot -- seq ) + over [ map-into ] keep ; inline + +: (accumulate) ( seq identity quot -- seq identity quot ) + [ swap ] dip [ curry keep ] curry ; inline : accumulate-as ( seq identity quot exemplar -- final newseq ) - [ [ swap ] dip [ curry keep ] curry ] dip map-as ; inline + [ (accumulate) ] dip map-as ; inline : accumulate ( seq identity quot -- final newseq ) { } accumulate-as ; inline +: accumulate! ( seq identity quot -- final seq ) + (accumulate) map! ; inline + : 2each ( seq1 seq2 quot -- ) (2each) each-integer ; inline @@ -483,11 +492,17 @@ PRIVATE> : push-if ( elt quot accum -- ) [ keep ] dip rot [ push ] [ 2drop ] if ; inline +: pusher-for ( quot exemplar -- quot accum ) + [ length ] keep new-resizable [ [ push-if ] 2curry ] keep ; inline + : pusher ( quot -- quot accum ) - V{ } clone [ [ push-if ] 2curry ] keep ; inline + V{ } pusher-for ; inline + +: filter-as ( seq quot exemplar -- subseq ) + dup [ pusher-for [ each ] dip ] curry dip like ; inline : filter ( seq quot -- subseq ) - over [ pusher [ each ] dip ] dip like ; inline + over filter-as ; inline : push-either ( elt quot accum1 accum2 -- ) [ keep swap ] 2dip ? push ; inline @@ -498,11 +513,14 @@ PRIVATE> : partition ( seq quot -- trueseq falseseq ) over [ 2pusher [ each ] 2dip ] dip [ like ] curry bi@ ; inline +: accumulator-for ( quot exemplar -- quot' vec ) + [ length ] keep new-resizable [ [ push ] curry compose ] keep ; inline + : accumulator ( quot -- quot' vec ) - V{ } clone [ [ push ] curry compose ] keep ; inline + V{ } accumulator-for ; inline : produce-as ( pred quot exemplar -- seq ) - [ accumulator [ while ] dip ] dip like ; inline + dup [ accumulator-for [ while ] dip ] curry dip like ; inline : produce ( pred quot -- seq ) { } produce-as ; inline @@ -558,13 +576,13 @@ PRIVATE> : member? ( elt seq -- ? ) [ = ] with any? ; -: memq? ( elt seq -- ? ) +: member-eq? ( elt seq -- ? ) [ eq? ] with any? ; : remove ( elt seq -- newseq ) [ = not ] with filter ; -: remq ( elt seq -- newseq ) +: remove-eq ( elt seq -- newseq ) [ eq? not ] with filter ; : sift ( seq -- newseq ) @@ -610,24 +628,24 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; -: filter-here ( seq quot -- ) - swap [ 0 0 ] dip (filter-here) ; inline +: filter! ( seq quot -- seq ) + swap [ [ 0 0 ] dip (filter!) ] keep ; inline -: delete ( elt seq -- ) - [ = not ] with filter-here ; +: remove! ( elt seq -- seq ) + [ = not ] with filter! ; -: delq ( elt seq -- ) - [ eq? not ] with filter-here ; +: remove-eq! ( elt seq -- seq ) + [ eq? not ] with filter! ; : prefix ( seq elt -- newseq ) over [ over length 1 + ] dip [ @@ -641,6 +659,10 @@ PRIVATE> [ 0 swap copy ] keep ] new-like ; +: suffix! ( seq elt -- seq ) over push ; inline + +: append! ( seq1 seq2 -- seq1 ) over push-all ; inline + : last ( seq -- elt ) [ length 1 - ] [ nth ] bi ; : set-last ( elt seq -- ) [ length 1 - ] keep set-nth ; @@ -686,8 +708,8 @@ PRIVATE> : delete-slice ( from to seq -- ) check-slice [ over [ - ] dip ] dip open-slice ; -: delete-nth ( n seq -- ) - [ dup 1 + ] dip delete-slice ; +: remove-nth! ( n seq -- seq ) + [ [ dup 1 + ] dip delete-slice ] keep ; : snip ( from to seq -- head tail ) [ swap head ] [ swap tail ] bi-curry bi* ; inline @@ -710,15 +732,16 @@ PRIVATE> [ exchange-unsafe ] 3tri ; -: reverse-here ( seq -- ) - [ length 2/ iota ] [ length ] [ ] tri - [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ; +: reverse! ( seq -- seq ) + [ + [ length 2/ iota ] [ length ] [ ] tri + [ [ over - 1 - ] dip exchange-unsafe ] 2curry each + ] keep ; : reverse ( seq -- newseq ) [ dup [ length ] keep new-sequence - [ 0 swap copy ] keep - [ reverse-here ] keep + [ 0 swap copy ] keep reverse! ] keep like ; : sum-lengths ( seq -- n ) @@ -727,7 +750,7 @@ PRIVATE> : concat-as ( seq exemplar -- newseq ) swap [ { } ] [ [ sum-lengths over new-resizable ] keep - [ over push-all ] each + [ append! ] each ] if-empty swap like ; : concat ( seq -- newseq ) @@ -914,10 +937,10 @@ PRIVATE> : supremum ( seq -- n ) [ ] [ max ] map-reduce ; -: sigma ( seq quot -- n ) +: map-sum ( seq quot -- n ) [ 0 ] 2dip [ dip + ] curry [ swap ] prepose each ; inline -: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline +: count ( seq quot -- n ) [ 1 0 ? ] compose map-sum ; inline ! We hand-optimize flip to such a degree because type hints ! cannot express that an array is an array of arrays yet, and diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index 26bfc140fb..999e963f36 100755 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -32,7 +32,7 @@ $nl conjoin conjoin-at } -{ $see-also member? memq? any? all? "assocs-sets" } ; +{ $see-also member? member-eq? any? all? "assocs-sets" } ; ABOUT: "sets" diff --git a/core/sets/sets.factor b/core/sets/sets.factor index c7b834297a..38c1f73bb3 100755 --- a/core/sets/sets.factor +++ b/core/sets/sets.factor @@ -3,7 +3,7 @@ USING: assocs hashtables kernel sequences vectors ; IN: sets -: adjoin ( elt seq -- ) [ delete ] [ push ] 2bi ; +: adjoin ( elt seq -- ) [ remove! drop ] [ push ] 2bi ; : conjoin ( elt assoc -- ) dupd set-at ; diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index ce29c14b01..92b34db6ec 100644 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -71,7 +71,7 @@ $nl { { { $link float } } { $snippet "0.0" } } { { { $link string } } { $snippet "\"\"" } } { { { $link byte-array } } { $snippet "B{ }" } } - { { { $link simple-alien } } { $snippet "BAD-ALIEN" } } + { { { $link pinned-alien } } { $snippet "BAD-ALIEN" } } } "All other classes are handled with one of two cases:" { $list diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 95a854f493..0422478884 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -173,7 +173,7 @@ M: class initial-value* no-initial-value ; { [ string bootstrap-word over class<= ] [ "" ] } { [ array bootstrap-word over class<= ] [ { } ] } { [ byte-array bootstrap-word over class<= ] [ B{ } ] } - { [ simple-alien bootstrap-word over class<= ] [ ] } + { [ pinned-alien bootstrap-word over class<= ] [ ] } { [ quotation bootstrap-word over class<= ] [ [ ] ] } [ dup initial-value* ] } cond nip ; diff --git a/core/source-files/errors/errors.factor b/core/source-files/errors/errors.factor index f5c41285ee..4f5473ce9d 100644 --- a/core/source-files/errors/errors.factor +++ b/core/source-files/errors/errors.factor @@ -17,6 +17,7 @@ TUPLE: source-file-error error asset file line# ; M: source-file-error error-file [ error>> error-file ] [ file>> ] bi or ; M: source-file-error error-line [ error>> error-line ] [ line#>> ] bi or ; +M: source-file-error compute-restarts error>> compute-restarts ; : sort-errors ( errors -- alist ) [ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ; @@ -71,7 +72,7 @@ SYMBOL: error-observers : add-error-observer ( observer -- ) error-observers get push ; -: remove-error-observer ( observer -- ) error-observers get delq ; +: remove-error-observer ( observer -- ) error-observers get remove-eq! drop ; : notify-error-observers ( -- ) error-observers get [ errors-changed ] each ; @@ -79,7 +80,7 @@ SYMBOL: error-observers [ [ swap file>> = ] [ swap error-type = ] bi-curry* bi and not - ] 2curry filter-here + ] 2curry filter! drop notify-error-observers ; : delete-definition-errors ( definition -- ) diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor index ef19d16351..cb1e5e6017 100644 --- a/core/source-files/source-files-docs.factor +++ b/core/source-files/source-files-docs.factor @@ -38,7 +38,7 @@ HELP: source-file } ; HELP: record-checksum -{ $values { "source-file" source-file } { "lines" "a sequence of strings" } } +{ $values { "lines" "a sequence of strings" } { "source-file" source-file } } { $description "Records the CRC32 checksm of the source file's contents." } $low-level-note ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 558018a147..4991a0860a 100644 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -3,7 +3,7 @@ USING: arrays definitions generic assocs kernel math namespaces sequences strings vectors words quotations io io.files io.pathnames combinators sorting splitting math.parser effects -continuations checksums checksums.crc32 vocabs hashtables graphs +continuations checksums checksums.crc32 vocabs hashtables compiler.units io.encodings.utf8 accessors source-files.errors ; IN: source-files diff --git a/core/splitting/splitting-docs.factor b/core/splitting/splitting-docs.factor index 10fea15a64..5085571312 100644 --- a/core/splitting/splitting-docs.factor +++ b/core/splitting/splitting-docs.factor @@ -13,6 +13,7 @@ ARTICLE: "sequences-split" "Splitting sequences" split1-last split1-last-slice split + split-when } "Splitting a string into lines:" { $subsections string-lines } ; @@ -37,9 +38,14 @@ HELP: split1-last-slice { split1 split1-slice split1-last split1-last-slice } related-words +HELP: split-when +{ $values { "seq" "a sequence" } { "quot" { $quotation "( elt -- ? )" } } { "pieces" "a new array" } } +{ $description "Splits " { $snippet "seq" } " at each occurrence of an element for which " { $snippet "quot" } " gives a true output and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." } +{ $examples { $example "USING: ascii kernel prettyprint splitting ;" "\"hello,world-how.are:you\" [ letter? not ] split-when ." "{ \"hello\" \"world\" \"how\" \"are\" \"you\" }" } } ; + HELP: split { $values { "seq" "a sequence" } { "separators" "a sequence" } { "pieces" "a new array" } } -{ $description "Splits " { $snippet "seq" } " at each occurrence of an element of " { $snippet "separators" } ", and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." } +{ $description "Splits " { $snippet "seq" } " at each occurrence of an element of " { $snippet "separators" } " and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." } { $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ; HELP: ?head diff --git a/core/splitting/splitting-tests.factor b/core/splitting/splitting-tests.factor index ed68038fa6..e672624d96 100644 --- a/core/splitting/splitting-tests.factor +++ b/core/splitting/splitting-tests.factor @@ -1,4 +1,4 @@ -USING: splitting tools.test kernel sequences arrays strings ; +USING: splitting tools.test kernel sequences arrays strings ascii ; IN: splitting.tests [ "hello" "world ." ] [ "hello world ." " " split1 ] unit-test @@ -57,3 +57,6 @@ unit-test [ { "hello" "hi" } ] [ "hello\nhi" string-lines ] unit-test [ { "hello" "hi" } ] [ "hello\rhi" string-lines ] unit-test [ { "hello" "hi" } ] [ "hello\r\nhi" string-lines ] unit-test + +[ { "hey" "world" "what's" "happening" } ] +[ "heyAworldBwhat'sChappening" [ LETTER? ] split-when ] unit-test diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 7aae30f20b..7b805dffe5 100644 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -55,17 +55,21 @@ PRIVATE> : split ( seq separators -- pieces ) - [ split, ] { } make ; + [ [ member? ] curry split, ] { } make ; + +: split-when ( seq quot -- pieces ) + [ split, ] { } make ; inline GENERIC: string-lines ( str -- seq ) diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 22bf7bb821..689d88be71 100644 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -86,7 +86,7 @@ unit-test ] unit-test ! Make sure we clear aux vector when storing octets -[ "\u123456hi" ] [ "ih\u123456" clone dup reverse-here ] unit-test +[ "\u123456hi" ] [ "ih\u123456" clone reverse! ] unit-test ! Make sure aux vector is not shared [ "\udeadbe" ] [ diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 2a8bf53e64..e0b6c1acb9 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -106,7 +106,7 @@ ARTICLE: "syntax-numbers" "Number syntax" } ; ARTICLE: "syntax-words" "Word syntax" -"A word occurring inside a quotation is executed when the quotation is called. Sometimes a word needs to be pushed on the data stack instead. The canonical use-case for this is passing the word to the " { $link execute } " combinator, or alternatively, reflectively accessing word properties (" { $link "word-props" } ")." +"A word occurring inside a quotation is executed when the quotation is called. Sometimes a word needs to be pushed on the data stack instead. The canonical use case for this is passing the word to the " { $link execute } " combinator, or alternatively, reflectively accessing word properties (" { $link "word-props" } ")." { $subsections POSTPONE: \ POSTPONE: POSTPONE: diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 80c7a42f30..dfb3e0bc10 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -73,9 +73,9 @@ IN: bootstrap.syntax "OCT:" [ 8 parse-base ] define-core-syntax "BIN:" [ 2 parse-base ] define-core-syntax - "NAN:" [ 16 scan-base parsed ] define-core-syntax + "NAN:" [ 16 scan-base suffix! ] define-core-syntax - "f" [ f parsed ] define-core-syntax + "f" [ f suffix! ] define-core-syntax "t" "syntax" lookup define-singleton-class "CHAR:" [ @@ -83,31 +83,31 @@ IN: bootstrap.syntax { [ dup length 1 = ] [ first ] } { [ "\\" ?head ] [ next-escape >string "" assert= ] } [ name>char-hook get call( name -- char ) ] - } cond parsed + } cond suffix! ] define-core-syntax - "\"" [ parse-multiline-string parsed ] define-core-syntax + "\"" [ parse-multiline-string suffix! ] define-core-syntax "SBUF\"" [ - lexer get skip-blank parse-string >sbuf parsed + lexer get skip-blank parse-string >sbuf suffix! ] define-core-syntax "P\"" [ - lexer get skip-blank parse-string parsed + lexer get skip-blank parse-string suffix! ] define-core-syntax - "[" [ parse-quotation parsed ] define-core-syntax + "[" [ parse-quotation suffix! ] define-core-syntax "{" [ \ } [ >array ] parse-literal ] define-core-syntax "V{" [ \ } [ >vector ] parse-literal ] define-core-syntax "B{" [ \ } [ >byte-array ] parse-literal ] define-core-syntax "BV{" [ \ } [ >byte-vector ] parse-literal ] define-core-syntax "H{" [ \ } [ >hashtable ] parse-literal ] define-core-syntax - "T{" [ parse-tuple-literal parsed ] define-core-syntax + "T{" [ parse-tuple-literal suffix! ] define-core-syntax "W{" [ \ } [ first ] parse-literal ] define-core-syntax - "POSTPONE:" [ scan-word parsed ] define-core-syntax - "\\" [ scan-word parsed ] define-core-syntax - "M\\" [ scan-word scan-word method parsed ] define-core-syntax + "POSTPONE:" [ scan-word suffix! ] define-core-syntax + "\\" [ scan-word suffix! ] define-core-syntax + "M\\" [ scan-word scan-word method suffix! ] define-core-syntax "inline" [ word make-inline ] define-core-syntax "recursive" [ word make-recursive ] define-core-syntax "foldable" [ word make-foldable ] define-core-syntax @@ -227,7 +227,7 @@ IN: bootstrap.syntax ] define-core-syntax "((" [ - "))" parse-effect parsed + "))" parse-effect suffix! ] define-core-syntax "MAIN:" [ scan-word current-vocab (>>main) ] define-core-syntax @@ -240,8 +240,8 @@ IN: bootstrap.syntax "call-next-method" [ current-method get [ - literalize parsed - \ (call-next-method) parsed + literalize suffix! + \ (call-next-method) suffix! ] [ not-in-a-method-error ] if* diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index 352ccdebd4..02a604ac32 100644 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -102,7 +102,7 @@ HELP: load-docs HELP: reload { $values { "name" "a vocabulary name" } } -{ $description "Loads it's source code and documentation." } +{ $description "Reloads the source code and documentation for a vocabulary." } { $errors "Throws a " { $link no-vocab } " error if the vocabulary does not exist on disk." } ; HELP: require diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index 2fc9d05d79..7ca2027ec2 100755 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -129,7 +129,7 @@ TUPLE: no-current-vocab ; : unuse-vocab ( vocab -- ) dup using-vocab? [ manifest get - [ [ load-vocab ] dip search-vocabs>> delq ] + [ [ load-vocab ] dip search-vocabs>> remove-eq! drop ] [ [ vocab-name ] dip search-vocab-names>> delete-at ] 2bi ] [ drop ] if ; @@ -172,7 +172,7 @@ TUPLE: rename word vocab words ; : use-words ( assoc -- ) (use-words) push ; -: unuse-words ( assoc -- ) (use-words) delete ; +: unuse-words ( assoc -- ) (use-words) remove! drop ; TUPLE: ambiguous-use-error words ; diff --git a/core/vocabs/vocabs-docs.factor b/core/vocabs/vocabs-docs.factor index 671d1f82d2..1c65e627d5 100644 --- a/core/vocabs/vocabs-docs.factor +++ b/core/vocabs/vocabs-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax strings words compiler.units ; IN: vocabs ARTICLE: "vocabularies" "Vocabularies" -"A " { $emphasis "vocabulary" } " is a named collection of words. Vocabularies are defined in the " { $vocab-link "vocabs" } " vocabulary." +"A " { $emphasis "vocabulary" } " is a named collection of " { $link "words" } ". Vocabularies are defined in the " { $vocab-link "vocabs" } " vocabulary." $nl "Vocabularies are stored in a global hashtable:" { $subsections dictionary } @@ -108,4 +108,4 @@ HELP: >vocab-link { $description "If the vocabulary is loaded, outputs the corresponding " { $link vocab } " instance, otherwise creates a new " { $link vocab-link } "." } ; HELP: runnable-vocab -{ $class-description "The class of vocabularies with a " { $slot "main" } " word." } ; \ No newline at end of file +{ $class-description "The class of vocabularies with a " { $slot "main" } " word." } ; diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 914f1cd601..239b88a2e8 100644 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -73,7 +73,7 @@ GENERIC: vocabs-changed ( obj -- ) vocab-observers get push ; : remove-vocab-observer ( obj -- ) - vocab-observers get delq ; + vocab-observers get remove-eq! drop ; : notify-vocab-observers ( -- ) vocab-observers get [ vocabs-changed ] each ; @@ -131,4 +131,4 @@ SYMBOL: load-vocab-hook ! ( name -- vocab ) PREDICATE: runnable-vocab < vocab vocab-main >boolean ; -INSTANCE: vocab-spec definition \ No newline at end of file +INSTANCE: vocab-spec definition diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 19913f2ff7..a13bfb0740 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -26,7 +26,7 @@ $nl } ; ARTICLE: "colon-definition" "Colon definitions" -"Every word has an associated quotation definition that is called when the word is executed. A " { $emphasis "colon definition" } " is a word where this quotation is supplied directly by the user. This is the simplest and most common type of word definition." +"All words have associated definition " { $link "quotations" } ". A word's definition quotation is called when the word is executed. A " { $emphasis "colon definition" } " is a word where this quotation is supplied directly by the user. This is the simplest and most common type of word definition." $nl "Defining words at parse time:" { $subsections @@ -160,7 +160,7 @@ $nl } ; ARTICLE: "words" "Words" -"Words are the Factor equivalent of functions or procedures; a word is essentially a named quotation." +"Words are the Factor equivalent of functions or procedures in other languages. Words are essentially named " { $link "quotations" } "." $nl "There are two ways of creating word definitions:" { $list @@ -238,7 +238,8 @@ $low-level-note HELP: ( name vocab -- word ) { $values { "name" string } { "vocab" string } { "word" word } } -{ $description "Allocates an uninterned word with the specified name and vocabulary, and a blank word property hashtable. User code should call " { $link gensym } " to create uninterned words and " { $link create } " to create interned words." } ; +{ $description "Allocates an uninterned word with the specified name and vocabulary, and a blank word property hashtable. User code should call " { $link gensym } " to create uninterned words and " { $link create } " to create interned words." } +{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } ; HELP: gensym { $values { "word" word } } @@ -279,12 +280,14 @@ HELP: check-create HELP: create { $values { "name" string } { "vocab" string } { "word" word } } -{ $description "Creates a new word. If the vocabulary already contains a word with the requested name, outputs the existing word. The vocabulary must exist already; if it does not, you must call " { $link create-vocab } " first." } ; +{ $description "Creates a new word. If the vocabulary already contains a word with the requested name, outputs the existing word. The vocabulary must exist already; if it does not, you must call " { $link create-vocab } " first." } +{ $notes "This word must be called from inside " { $link with-compilation-unit } ". Parsing words should call " { $link create-in } " instead of this word." } ; HELP: constructor-word { $values { "name" string } { "vocab" string } { "word" word } } { $description "Creates a new word, surrounding " { $snippet "name" } " in angle brackets." } -{ $examples { $example "USING: prettyprint words ;" "\"salmon\" \"scratchpad\" constructor-word ." "" } } ; +{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } +{ $examples { $example "USING: compiler.units prettyprint words ;" "[ \"salmon\" \"scratchpad\" constructor-word ] with-compilation-unit ." "" } } ; { POSTPONE: FORGET: forget forget* forget-vocab } related-words diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index b9d6e80630..cb4ecb1e06 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -1,7 +1,7 @@ USING: arrays generic assocs kernel math namespaces sequences tools.test words definitions parser quotations vocabs continuations classes.tuple compiler.units -io.streams.string accessors eval words.symbol ; +io.streams.string accessors eval words.symbol grouping ; IN: words.tests [ 4 ] [ @@ -25,7 +25,8 @@ DEFER: plist-test \ plist-test "sample-property" word-prop ] unit-test -"create-test" "scratchpad" create { 1 2 } "testing" set-word-prop +[ ] [ [ "create-test" "scratchpad" create { 1 2 } "testing" set-word-prop ] with-compilation-unit ] unit-test + [ { 1 2 } ] [ "create-test" "scratchpad" lookup "testing" word-prop ] unit-test @@ -33,7 +34,7 @@ DEFER: plist-test [ [ t ] [ \ array? "array?" "arrays" lookup = ] unit-test - [ ] [ "test-scope" "scratchpad" create drop ] unit-test + [ ] [ [ "test-scope" "scratchpad" create drop ] with-compilation-unit ] unit-test ] with-scope [ "test-scope" ] [ @@ -67,7 +68,7 @@ FORGET: another-forgotten DEFER: x [ x ] [ undefined? ] must-fail-with -[ ] [ "no-loc" "words.tests" create drop ] unit-test +[ ] [ [ "no-loc" "words.tests" create drop ] with-compilation-unit ] unit-test [ f ] [ "no-loc" "words.tests" lookup where ] unit-test [ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" eval( -- ) ] unit-test @@ -121,7 +122,7 @@ DEFER: x [ { } ] [ all-words [ - "compiled-uses" word-prop + "compiled-uses" word-prop 2 keys [ "forgotten" word-prop ] filter ] map harvest ] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index 45e014f6be..3dbfb3c864 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays definitions graphs kernel -kernel.private slots.private math namespaces sequences -strings vectors sbufs quotations assocs hashtables sorting vocabs -math.order sets words.private ; +USING: accessors arrays definitions kernel kernel.private +slots.private math namespaces sequences strings vectors sbufs +quotations assocs hashtables sorting vocabs math.order sets +words.private ; IN: words : word ( -- word ) \ word get-global ; @@ -64,41 +64,6 @@ GENERIC: crossref? ( word -- ? ) M: word crossref? dup "forgotten" word-prop [ drop f ] [ vocabulary>> >boolean ] if ; -SYMBOL: compiled-crossref - -compiled-crossref [ H{ } clone ] initialize - -SYMBOL: compiled-generic-crossref - -compiled-generic-crossref [ H{ } clone ] initialize - -: (compiled-xref) ( word dependencies word-prop variable -- ) - [ [ set-word-prop ] curry ] - [ [ get add-vertex* ] curry ] - bi* 2bi ; - -: compiled-xref ( word dependencies generic-dependencies -- ) - [ [ drop crossref? ] { } assoc-filter-as f like ] bi@ - [ "compiled-uses" compiled-crossref (compiled-xref) ] - [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ] - bi-curry* bi ; - -: (compiled-unxref) ( word word-prop variable -- ) - [ [ [ dupd word-prop ] dip get remove-vertex* ] 2curry ] - [ drop [ remove-word-prop ] curry ] - 2bi bi ; - -: compiled-unxref ( word -- ) - [ "compiled-uses" compiled-crossref (compiled-unxref) ] - [ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ] - bi ; - -: delete-compiled-xref ( word -- ) - [ compiled-unxref ] - [ compiled-crossref get delete-at ] - [ compiled-generic-crossref get delete-at ] - tri ; - : inline? ( word -- ? ) "inline" word-prop ; inline GENERIC: subwords ( word -- seq ) @@ -170,10 +135,13 @@ M: word reset-word ] tri ; : ( name vocab -- word ) - 2dup [ hashcode ] bi@ bitxor >fixnum (word) ; + 2dup [ hashcode ] bi@ bitxor >fixnum (word) dup new-word ; + +: ( name -- word ) + f \ counter >fixnum (word) ; : gensym ( -- word ) - "( gensym )" f \ gensym counter >fixnum (word) ; + "( gensym )" ; : define-temp ( quot effect -- word ) [ gensym dup ] 2dip define-declared ; diff --git a/extra/alien/data/map/map.factor b/extra/alien/data/map/map.factor index 72f5cb5517..6c93e8f4b6 100644 --- a/extra/alien/data/map/map.factor +++ b/extra/alien/data/map/map.factor @@ -1,7 +1,8 @@ ! (c)Joe Groff bsd license USING: accessors alien alien.c-types alien.data alien.parser arrays byte-arrays combinators effects.parser fry generalizations grouping kernel -lexer locals macros make math math.ranges parser sequences sequences.private ; +lexer locals macros make math math.ranges parser sequences +sequences.generalizations sequences.private ; FROM: alien.arrays => array-length ; IN: alien.data.map @@ -117,14 +118,14 @@ MACRO: data-map! ( ins outs -- ) : parse-data-map-effect ( accum -- accum ) ")" parse-effect - [ in>> [ (parse-c-type) ] map parsed ] - [ out>> [ (parse-c-type) ] map parsed ] bi ; + [ in>> [ (parse-c-type) ] map suffix! ] + [ out>> [ (parse-c-type) ] map suffix! ] bi ; PRIVATE> SYNTAX: data-map( - parse-data-map-effect \ data-map parsed ; + parse-data-map-effect \ data-map suffix! ; SYNTAX: data-map!( - parse-data-map-effect \ data-map! parsed ; + parse-data-map-effect \ data-map! suffix! ; diff --git a/extra/annotations/annotations-tests.factor b/extra/annotations/annotations-tests.factor index 48fd281c6c..b03494ce01 100644 --- a/extra/annotations/annotations-tests.factor +++ b/extra/annotations/annotations-tests.factor @@ -23,5 +23,8 @@ IN: annotations.tests } 1&& ] unit-test -[ { four three } ] [ BROKENs natural-sort ] unit-test -[ { five } ] [ TODOs ] unit-test +[ t ] [ + BROKENs { [ \ four swap member? ] [ \ three swap member? ] } 1&& +] unit-test + +[ t ] [ TODOs \ five swap member? ] unit-test diff --git a/extra/annotations/annotations.factor b/extra/annotations/annotations.factor index 387c73abe4..e463206e4f 100644 --- a/extra/annotations/annotations.factor +++ b/extra/annotations/annotations.factor @@ -7,7 +7,7 @@ IN: annotations << : (parse-annotation) ( accum -- accum ) - lexer get [ line-text>> parsed ] [ next-line ] bi ; + lexer get [ line-text>> suffix! ] [ next-line ] bi ; : (non-annotation-usage) ( word -- usages ) smart-usage @@ -24,7 +24,7 @@ NAMEs. DEFINES ${NAME}s. WHERE : (NAME) ( str -- ) drop ; inline -SYNTAX: !NAME (parse-annotation) \ (NAME) parsed ; +SYNTAX: !NAME (parse-annotation) \ (NAME) suffix! ; : NAMEs ( -- usages ) \ (NAME) (non-annotation-usage) ; diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor index 31a4b75eb2..a379a03828 100644 --- a/extra/bank/bank.factor +++ b/extra/bank/bank.factor @@ -63,7 +63,7 @@ C: transaction : process-to-date ( account date -- account ) over interest-last-paid>> 1 days time+ - [ dupd process-day ] spin each-day ; + [ [ dupd process-day ] ] 2dip swap each-day ; : inserting-transactions ( account transactions -- account ) [ [ date>> process-to-date ] keep >>transaction ] each ; diff --git a/extra/benchmark/backtrack/backtrack.factor b/extra/benchmark/backtrack/backtrack.factor index 27040edac3..856fd8e25d 100755 --- a/extra/benchmark/backtrack/backtrack.factor +++ b/extra/benchmark/backtrack/backtrack.factor @@ -38,9 +38,9 @@ MEMO: 24-from-4 ( a b c d -- ? ) 1 10 [a,b] [| d | a b c d 24-from-4 ] count - ] sigma - ] sigma - ] sigma ; + ] map-sum + ] map-sum + ] map-sum ; CONSTANT: words { 24-from-1 24-from-2 24-from-3 24-from-4 } diff --git a/extra/benchmark/beust2/beust2.factor b/extra/benchmark/beust2/beust2.factor index 14ebcb1c5b..92715dc9c7 100755 --- a/extra/benchmark/beust2/beust2.factor +++ b/extra/benchmark/beust2/beust2.factor @@ -7,25 +7,24 @@ IN: benchmark.beust2 :: (count-numbers) ( remaining first value used max listener: ( -- ) -- ? ) 10 first - iota [| i | - [let* | digit [ i first + ] - mask [ digit 2^ ] - value' [ i value + ] | - used mask bitand zero? [ - value max > [ t ] [ - remaining 1 <= [ - listener call f - ] [ - remaining 1 - - 0 - value' 10 * - used mask bitor - max - listener - (count-numbers) - ] if + i first + :> digit + digit 2^ :> mask + i value + :> value' + used mask bitand zero? [ + value max > [ t ] [ + remaining 1 <= [ + listener call f + ] [ + remaining 1 - + 0 + value' 10 * + used mask bitor + max + listener + (count-numbers) ] if - ] [ f ] if - ] + ] if + ] [ f ] if ] any? ; inline recursive :: count-numbers ( max listener -- ) @@ -33,9 +32,8 @@ IN: benchmark.beust2 inline :: beust ( -- ) - [let | i! [ 0 ] | - 5000000000 [ i 1 + i! ] count-numbers - i number>string " unique numbers." append print - ] ; + 0 :> i! + 5000000000 [ i 1 + i! ] count-numbers + i number>string " unique numbers." append print ; MAIN: beust diff --git a/extra/benchmark/e-ratios/e-ratios.factor b/extra/benchmark/e-ratios/e-ratios.factor index 4957822b5e..a909602f8c 100644 --- a/extra/benchmark/e-ratios/e-ratios.factor +++ b/extra/benchmark/e-ratios/e-ratios.factor @@ -4,7 +4,7 @@ USING: kernel math math.combinatorics math.ranges sequences ; IN: benchmark.e-ratios : calculate-e-ratios ( n -- e ) - iota [ factorial recip ] sigma ; + iota [ factorial recip ] map-sum ; : calculate-e-ratios-benchmark ( -- ) 5 [ 300 calculate-e-ratios drop ] times ; diff --git a/extra/benchmark/fannkuch/fannkuch.factor b/extra/benchmark/fannkuch/fannkuch.factor index 63e635f3de..f3a41ca4a9 100644 --- a/extra/benchmark/fannkuch/fannkuch.factor +++ b/extra/benchmark/fannkuch/fannkuch.factor @@ -12,7 +12,7 @@ IN: benchmark.fannkuch : count-flips ( perm -- flip# ) '[ _ dup first dup 1 = - [ 2drop f ] [ head-slice reverse-here t ] if + [ 2drop f ] [ head-slice reverse! drop t ] if ] count ; inline : write-permutation ( perm -- ) @@ -24,7 +24,7 @@ IN: benchmark.fannkuch : fannkuch ( n -- ) [ - [ 0 0 ] dip [ 1 + ] B{ } map-as + [ 0 0 ] dip iota [ 1 + ] B{ } map-as [ fannkuch-step ] each-permutation nip ] keep "Pfannkuchen(" write pprint ") = " write . ; diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index 1ad769173b..5ba285dbb1 100755 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -71,37 +71,35 @@ CONSTANT: homo-sapiens [ make-random-fasta ] 2curry split-lines ; inline :: make-repeat-fasta ( k len alu -- k' ) - [let | kn [ alu length ] | - len [ k + kn mod alu nth-unsafe ] "" map-as print - k len + - ] ; inline + alu length :> kn + len [ k + kn mod alu nth-unsafe ] "" map-as print + k len + ; inline : write-repeat-fasta ( n alu desc id -- ) write-description - [let | k! [ 0 ] alu [ ] | + [let + :> alu + 0 :> k! [| len | k len alu make-repeat-fasta k! ] split-lines ] ; inline : fasta ( n out -- ) homo-sapiens make-cumulative IUB make-cumulative - [let | homo-sapiens-floats [ ] - homo-sapiens-chars [ ] - IUB-floats [ ] - IUB-chars [ ] - out [ ] - n [ ] - seed [ initial-seed ] | + [let + :> ( n out IUB-chars IUB-floats homo-sapiens-chars homo-sapiens-floats ) + initial-seed :> seed out ascii [ n 2 * ALU "Homo sapiens alu" "ONE" write-repeat-fasta initial-seed - n 3 * homo-sapiens-chars homo-sapiens-floats "IUB ambiguity codes" "TWO" write-random-fasta - n 5 * IUB-chars IUB-floats "Homo sapiens frequency" "THREE" write-random-fasta + n 3 * homo-sapiens-chars homo-sapiens-floats + "IUB ambiguity codes" "TWO" write-random-fasta + n 5 * IUB-chars IUB-floats + "Homo sapiens frequency" "THREE" write-random-fasta drop ] with-file-writer - ] ; : run-fasta ( -- ) 2500000 reverse-complement-in fasta ; diff --git a/extra/benchmark/fib6/fib6.factor b/extra/benchmark/fib6/fib6.factor index 7ddd58468a..561110d941 100755 --- a/extra/benchmark/fib6/fib6.factor +++ b/extra/benchmark/fib6/fib6.factor @@ -1,13 +1,13 @@ -USING: math kernel alien ; +USING: math kernel alien alien.c-types ; IN: benchmark.fib6 : fib ( x -- y ) - "int" { "int" } "cdecl" [ + int { int } "cdecl" [ dup 1 <= [ drop 1 ] [ 1 - dup fib swap 1 - fib + ] if ] alien-callback - "int" { "int" } "cdecl" alien-indirect ; + int { int } "cdecl" alien-indirect ; : fib-main ( -- ) 32 fib drop ; diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index fb4f17cca5..a28a676b90 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -1,4 +1,4 @@ -USING: kernel io io.files splitting strings io.encodings.ascii +USING: kernel locals io io.files splitting strings io.encodings.ascii hashtables sequences assocs math namespaces prettyprint math.parser combinators arrays sorting unicode.case ; @@ -21,10 +21,7 @@ IN: benchmark.knucleotide CHAR: \n swap remove >upper ; : tally ( x exemplar -- b ) - clone tuck - [ - [ [ 1 + ] [ 1 ] if* ] change-at - ] curry each ; + clone [ [ inc-at ] curry each ] keep ; : small-groups ( x n -- b ) swap @@ -42,10 +39,10 @@ IN: benchmark.knucleotide ] each drop ; -: handle-n ( inputs x -- ) - tuck length - small-groups H{ } tally - at [ 0 ] unless* +:: handle-n ( inputs x -- ) + inputs x length small-groups :> groups + groups H{ } tally :> b + x b at [ 0 ] unless* number>string 8 CHAR: \s pad-tail write ; : process-input ( input -- ) diff --git a/extra/benchmark/nsieve-bytes/nsieve-bytes.factor b/extra/benchmark/nsieve-bytes/nsieve-bytes.factor index 15c0f9ee0b..e27d5159fd 100644 --- a/extra/benchmark/nsieve-bytes/nsieve-bytes.factor +++ b/extra/benchmark/nsieve-bytes/nsieve-bytes.factor @@ -20,7 +20,7 @@ byte-arrays make io ; ] if ; inline recursive : nsieve ( m -- count ) - 0 2 rot 1 + dup [ drop 1 ] change-each (nsieve) ; + 0 2 rot 1 + [ drop 1 ] map! (nsieve) ; : nsieve. ( m -- ) [ "Primes up to " % dup # " " % nsieve # ] "" make print ; diff --git a/extra/benchmark/reverse-complement/reverse-complement.factor b/extra/benchmark/reverse-complement/reverse-complement.factor index 4147ffabdf..95035e6cd8 100755 --- a/extra/benchmark/reverse-complement/reverse-complement.factor +++ b/extra/benchmark/reverse-complement/reverse-complement.factor @@ -9,13 +9,13 @@ IN: benchmark.reverse-complement TR: trans-map ch>upper "ACGTUMRYKVHDB" "TGCAAKYRMBDHV" ; : translate-seq ( seq -- str ) - concat dup reverse-here dup trans-map-fast ; + concat reverse! dup trans-map-fast ; : show-seq ( seq -- ) translate-seq 60 [ print ] each ; : do-line ( seq line -- seq ) - dup first ">;" memq? + dup first ">;" member-eq? [ over show-seq print dup delete-all ] [ over push ] if ; HINTS: do-line vector string ; diff --git a/extra/benchmark/simd-1/simd-1.factor b/extra/benchmark/simd-1/simd-1.factor index 4b3c4a5b9f..ff0cb98a00 100644 --- a/extra/benchmark/simd-1/simd-1.factor +++ b/extra/benchmark/simd-1/simd-1.factor @@ -15,7 +15,7 @@ IN: benchmark.simd-1 iota [ ] float-4-array{ } map-as ; inline : normalize-points ( points -- ) - [ normalize ] change-each ; inline + [ normalize ] map! drop ; inline : max-points ( points -- point ) [ ] [ vmax ] map-reduce ; inline diff --git a/extra/benchmark/tuple-arrays/tuple-arrays.factor b/extra/benchmark/tuple-arrays/tuple-arrays.factor index bd9a7139b3..38ce0087a2 100644 --- a/extra/benchmark/tuple-arrays/tuple-arrays.factor +++ b/extra/benchmark/tuple-arrays/tuple-arrays.factor @@ -14,7 +14,7 @@ TUPLE-ARRAY: point [ 1 + ] change-x [ 1 - ] change-y [ 1 + 2 / ] change-z - ] map [ z>> ] sigma - ] sigma . ; + ] map [ z>> ] map-sum + ] map-sum . ; MAIN: tuple-array-benchmark diff --git a/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor b/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor index bd13de32c7..024887991e 100644 --- a/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor +++ b/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor @@ -17,20 +17,19 @@ STRUCT: yuv_buffer { v void* } ; :: fake-data ( -- rgb yuv ) - [let* | w [ 1600 ] - h [ 1200 ] - buffer [ yuv_buffer ] - rgb [ w h * 3 * ] | - rgb buffer - w >>y_width - h >>y_height - h >>uv_height - w >>y_stride - w >>uv_stride - w h * [ dup * ] B{ } map-as malloc-byte-array &free >>y - w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free >>u - w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v - ] ; + 1600 :> w + 1200 :> h + yuv_buffer :> buffer + w h * 3 * :> rgb + rgb buffer + w >>y_width + h >>y_height + h >>uv_height + w >>y_stride + w >>uv_stride + w h * [ dup * ] B{ } map-as malloc-byte-array &free >>y + w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free >>u + w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v ; : clamp ( n -- n ) 255 min 0 max ; inline diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index d80f3aa98a..b9923d5976 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -1,6 +1,6 @@ USING: accessors alien.c-types arrays combinators destructors http.client io io.encodings.ascii io.files io.files.temp kernel -math math.matrices math.parser math.vectors opengl +locals math math.matrices math.parser math.vectors opengl opengl.capabilities opengl.gl opengl.demo-support sequences splitting vectors words specialized-arrays ; QUALIFIED-WITH: alien.c-types c @@ -51,8 +51,11 @@ IN: bunny.model over download-to ] unless ; -: (draw-triangle) ( ns vs triple -- ) - [ dup roll nth gl-normal swap nth gl-vertex ] with with each ; +:: (draw-triangle) ( ns vs triple -- ) + triple [| elt | + elt ns nth gl-normal + elt vs nth gl-vertex + ] each ; : draw-triangles ( ns vs is -- ) GL_TRIANGLES [ [ (draw-triangle) ] with with each ] do-state ; diff --git a/extra/c/lexer/lexer-tests.factor b/extra/c/lexer/lexer-tests.factor index c972b8816c..082827353d 100644 --- a/extra/c/lexer/lexer-tests.factor +++ b/extra/c/lexer/lexer-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors c.lexer kernel sequence-parser tools.test ; +USING: accessors c.lexer kernel sequences.parser tools.test ; IN: c.lexer.tests [ 36 ] diff --git a/extra/c/lexer/lexer.factor b/extra/c/lexer/lexer.factor index 962407e6ec..57894217bd 100644 --- a/extra/c/lexer/lexer.factor +++ b/extra/c/lexer/lexer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators combinators.short-circuit generalizations kernel locals math.order math.ranges -sequence-parser sequences sorting.functor sorting.slots +sequences.parser sequences sorting.functor sorting.slots unicode.categories ; IN: c.lexer diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor index 3018fa7a24..d69583e124 100644 --- a/extra/c/preprocessor/preprocessor.factor +++ b/extra/c/preprocessor/preprocessor.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: sequence-parser io io.encodings.utf8 io.files +USING: sequences.parser io io.encodings.utf8 io.files io.streams.string kernel combinators accessors io.pathnames fry sequences arrays locals namespaces io.directories assocs math splitting make unicode.categories @@ -93,11 +93,11 @@ ERROR: header-file-missing path ; skip-whitespace/comments [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ; -: handle-define ( preprocessor-state sequence-parser -- ) - [ take-define-identifier ] - [ skip-whitespace/comments take-rest ] bi - "\\" ?tail [ readlns append ] when - spin symbol-table>> set-at ; +:: handle-define ( preprocessor-state sequence-parser -- ) + sequence-parser take-define-identifier :> ident + sequence-parser skip-whitespace/comments take-rest :> def + def "\\" ?tail [ readlns append ] when :> def + def ident preprocessor-state symbol-table>> set-at ; : handle-undef ( preprocessor-state sequence-parser -- ) take-token swap symbol-table>> delete-at ; diff --git a/extra/calendar/holidays/authors.txt b/extra/calendar/holidays/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/calendar/holidays/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/calendar/holidays/canada/authors.txt b/extra/calendar/holidays/canada/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/calendar/holidays/canada/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/calendar/holidays/canada/canada-tests.factor b/extra/calendar/holidays/canada/canada-tests.factor new file mode 100644 index 0000000000..916f5ee9ab --- /dev/null +++ b/extra/calendar/holidays/canada/canada-tests.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar.holidays calendar.holidays.canada kernel +tools.test ; +IN: calendar.holidays.canada.tests + +[ ] [ 2009 canada holidays drop ] unit-test diff --git a/extra/calendar/holidays/canada/canada.factor b/extra/calendar/holidays/canada/canada.factor new file mode 100644 index 0000000000..304388fe4b --- /dev/null +++ b/extra/calendar/holidays/canada/canada.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar calendar.holidays ; +IN: calendar.holidays.canada + +SINGLETONS: canada canadian-federal ; + +HOLIDAY: canadian-thanksgiving-day october 2 monday-of-month ; +HOLIDAY-NAME: canadian-thanksgiving-day canadian-federal "Thanksgiving Day" + +HOLIDAY-NAME: armistice-day commonwealth-of-nations "Remembrance Day" diff --git a/extra/calendar/holidays/holidays.factor b/extra/calendar/holidays/holidays.factor new file mode 100644 index 0000000000..0b8a1bb781 --- /dev/null +++ b/extra/calendar/holidays/holidays.factor @@ -0,0 +1,55 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs calendar fry kernel parser sequences +shuffle vocabs words memoize ; +IN: calendar.holidays + +SINGLETONS: all world commonwealth-of-nations ; + +<< +SYNTAX: HOLIDAY: + CREATE-WORD + dup "holiday" word-prop [ + dup H{ } clone "holiday" set-word-prop + ] unless + parse-definition (( timestamp/n -- timestamp )) define-declared ; + +SYNTAX: HOLIDAY-NAME: + scan-word "holiday" word-prop scan-word scan-object spin set-at ; +>> + +GENERIC: holidays ( n singleton -- seq ) + + + +M: all holidays + drop + all-words [ "holiday" word-prop key? ] with filter ; + +: holiday? ( timestamp/n singleton -- ? ) + [ holidays ] [ drop ] 2bi '[ _ same-day? ] any? ; + +: holiday-assoc ( timestamp singleton -- assoc ) + (holidays) swap + '[ [ _ swap execute( ts -- ts' ) >gmt midnight ] keep ] { } map>assoc ; + +: holiday-name ( singleton word -- string/f ) + "holiday" word-prop at ; + +: holiday-names ( timestamp/n singleton -- seq ) + [ + [ >gmt midnight ] dip + [ drop ] [ holiday-assoc ] 2bi swap + '[ drop _ same-day? ] assoc-filter values + ] keep '[ _ swap "holiday" word-prop at ] map ; + +HOLIDAY: armistice-day november 11 >>day ; +HOLIDAY-NAME: armistice-day world "Armistice Day" diff --git a/extra/calendar/holidays/us/authors.txt b/extra/calendar/holidays/us/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/calendar/holidays/us/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/calendar/holidays/us/us-tests.factor b/extra/calendar/holidays/us/us-tests.factor new file mode 100644 index 0000000000..23ab535e98 --- /dev/null +++ b/extra/calendar/holidays/us/us-tests.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar.holidays calendar.holidays.us kernel sequences +tools.test ; +IN: calendar.holidays.us.tests + +[ 10 ] [ 2009 us-federal holidays length ] unit-test diff --git a/extra/calendar/holidays/us/us.factor b/extra/calendar/holidays/us/us.factor new file mode 100644 index 0000000000..a4fb19c597 --- /dev/null +++ b/extra/calendar/holidays/us/us.factor @@ -0,0 +1,117 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs calendar calendar.holidays +calendar.holidays.private combinators combinators.short-circuit +fry kernel lexer math namespaces parser sequences shuffle +vocabs words ; +IN: calendar.holidays.us + +SINGLETONS: us us-federal ; + + + +M: us-federal holidays + (holidays) + [ execute( timestamp -- timestamp' ) adjust-federal-holiday ] with map ; + +: us-post-office-open? ( timestamp -- ? ) + { [ sunday? not ] [ us-federal holiday? not ] } 1&& ; + +HOLIDAY: new-years-day january 1 >>day ; +HOLIDAY-NAME: new-years-day world "New Year's Day" +HOLIDAY-NAME: new-years-day us-federal "New Year's Day" + +HOLIDAY: martin-luther-king-day january 3 monday-of-month ; +HOLIDAY-NAME: martin-luther-king-day us-federal "Martin Luther King Day" + +HOLIDAY: inauguration-day year dup 4 neg rem + january 20 >>day ; +HOLIDAY-NAME: inauguration-day us "Inauguration Day" + +HOLIDAY: washingtons-birthday february 3 monday-of-month ; +HOLIDAY-NAME: washingtons-birthday us-federal "Washington's Birthday" + +HOLIDAY: memorial-day may last-monday-of-month ; +HOLIDAY-NAME: memorial-day us-federal "Memorial Day" + +HOLIDAY: independence-day july 4 >>day ; +HOLIDAY-NAME: independence-day us-federal "Independence Day" + +HOLIDAY: labor-day september 1 monday-of-month ; +HOLIDAY-NAME: labor-day us-federal "Labor Day" + +HOLIDAY: columbus-day october 2 monday-of-month ; +HOLIDAY-NAME: columbus-day us-federal "Columbus Day" + +HOLIDAY-NAME: armistice-day us-federal "Veterans Day" + +HOLIDAY: thanksgiving-day november 4 thursday-of-month ; +HOLIDAY-NAME: thanksgiving-day us-federal "Thanksgiving Day" + +HOLIDAY: christmas-day december 25 >>day ; +HOLIDAY-NAME: christmas-day world "Christmas Day" +HOLIDAY-NAME: christmas-day us-federal "Christmas Day" + +HOLIDAY: belly-laugh-day january 24 >>day ; + +HOLIDAY: groundhog-day february 2 >>day ; + +HOLIDAY: lincolns-birthday february 12 >>day ; + +HOLIDAY: valentines-day february 14 >>day ; + +HOLIDAY: st-patricks-day march 17 >>day ; + +HOLIDAY: ash-wednesday easter 46 days time- ; + +ALIAS: first-day-of-lent ash-wednesday + +HOLIDAY: fat-tuesday ash-wednesday 1 days time- ; + +HOLIDAY: good-friday easter 2 days time- ; + +HOLIDAY: tax-day april 15 >>day ; + +HOLIDAY: earth-day april 22 >>day ; + +HOLIDAY: administrative-professionals-day april last-saturday-of-month wednesday ; + +HOLIDAY: cinco-de-mayo may 5 >>day ; + +HOLIDAY: mothers-day may 2 sunday-of-month ; + +HOLIDAY: armed-forces-day may 3 saturday-of-month ; + +HOLIDAY: flag-day june 14 >>day ; + +HOLIDAY: parents-day july 4 sunday-of-month ; + +HOLIDAY: grandparents-day labor-day 1 weeks time+ ; + +HOLIDAY: patriot-day september 11 >>day ; + +HOLIDAY: stepfamily-day september 16 >>day ; + +HOLIDAY: citizenship-day september 17 >>day ; + +HOLIDAY: bosss-day october 16 >>day ; + +HOLIDAY: sweetest-day october 3 saturday-of-month ; + +HOLIDAY: halloween october 31 >>day ; + +HOLIDAY: election-day november 1 monday-of-month 1 days time+ ; + +HOLIDAY: black-friday thanksgiving-day 1 days time+ ; + +HOLIDAY: pearl-harbor-remembrance-day december 7 >>day ; + +HOLIDAY: new-years-eve december 31 >>day ; diff --git a/extra/closures/closures.factor b/extra/closures/closures.factor index 79fcf7564e..faa8ec07ee 100644 --- a/extra/closures/closures.factor +++ b/extra/closures/closures.factor @@ -4,10 +4,10 @@ SYMBOL: | ! Selective Binding : delayed-bind-with ( vars quot -- quot' ) '[ _ dup [ get ] map zip >hashtable [ _ bind ] curry ] ; -SYNTAX: C[ | parse-until parse-quotation delayed-bind-with over push-all ; +SYNTAX: C[ | parse-until parse-quotation delayed-bind-with append! ; ! Common ones -SYNTAX: DIR[ parse-quotation { current-directory } swap delayed-bind-with over push-all ; +SYNTAX: DIR[ parse-quotation { current-directory } swap delayed-bind-with append! ; ! Namespace Binding : bind-to-namespace ( quot -- quot' ) '[ namespace [ _ bind ] curry ] ; -SYNTAX: NS[ parse-quotation bind-to-namespace over push-all ; \ No newline at end of file +SYNTAX: NS[ parse-quotation bind-to-namespace append! ; diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor index da71acb074..ed5dd1268f 100644 --- a/extra/couchdb/couchdb.factor +++ b/extra/couchdb/couchdb.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs continuations debugger hashtables http http.client io io.encodings.string io.encodings.utf8 json.reader -json.writer kernel make math math.parser namespaces sequences strings -urls urls.encoding vectors ; +json.writer kernel locals make math math.parser namespaces sequences +strings urls urls.encoding vectors ; IN: couchdb ! NOTE: This code only works with the latest couchdb (0.9.*), because old @@ -136,8 +136,9 @@ C: db : attachments> ( assoc -- attachments ) "_attachments" swap at ; : >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ; -: copy-key ( to from to-key from-key -- ) - rot at spin set-at ; +:: copy-key ( to from to-key from-key -- ) + from-key from at + to-key to set-at ; : copy-id ( to from -- ) "_id" "id" copy-key ; diff --git a/extra/crypto/aes/aes.factor b/extra/crypto/aes/aes.factor index 0807420266..a5a6709c6d 100644 --- a/extra/crypto/aes/aes.factor +++ b/extra/crypto/aes/aes.factor @@ -61,37 +61,33 @@ CONSTANT: AES_BLOCK_SIZE 16 bitor bitor bitor 32 bits ; :: set-t ( T i -- ) - [let* | - a1 [ i sbox nth ] - a2 [ a1 xtime ] - a3 [ a1 a2 bitxor ] | - a2 a1 a1 a3 ui32 i T set-nth - a3 a2 a1 a1 ui32 i HEX: 100 + T set-nth - a1 a3 a2 a1 ui32 i HEX: 200 + T set-nth - a1 a1 a3 a2 ui32 i HEX: 300 + T set-nth - ] ; + i sbox nth :> a1 + a1 xtime :> a2 + a1 a2 bitxor :> a3 + a2 a1 a1 a3 ui32 i T set-nth + a3 a2 a1 a1 ui32 i HEX: 100 + T set-nth + a1 a3 a2 a1 ui32 i HEX: 200 + T set-nth + a1 a1 a3 a2 ui32 i HEX: 300 + T set-nth ; MEMO:: t-table ( -- array ) 1024 0 dup 256 [ set-t ] with each ; :: set-d ( D i -- ) - [let* | - a1 [ i inv-sbox nth ] - a2 [ a1 xtime ] - a4 [ a2 xtime ] - a8 [ a4 xtime ] - a9 [ a8 a1 bitxor ] - ab [ a9 a2 bitxor ] - ad [ a9 a4 bitxor ] - ae [ a8 a4 a2 bitxor bitxor ] - | - ae a9 ad ab ui32 i D set-nth - ab ae a9 ad ui32 i HEX: 100 + D set-nth - ad ab ae a9 ui32 i HEX: 200 + D set-nth - a9 ad ab ae ui32 i HEX: 300 + D set-nth - ] ; + i inv-sbox nth :> a1 + a1 xtime :> a2 + a2 xtime :> a4 + a4 xtime :> a8 + a8 a1 bitxor :> a9 + a9 a2 bitxor :> ab + a9 a4 bitxor :> ad + a8 a4 a2 bitxor bitxor :> ae + + ae a9 ad ab ui32 i D set-nth + ab ae a9 ad ui32 i HEX: 100 + D set-nth + ad ab ae a9 ui32 i HEX: 200 + D set-nth + a9 ad ab ae ui32 i HEX: 300 + D set-nth ; MEMO:: d-table ( -- array ) 1024 0 diff --git a/extra/crypto/passwd-md5/passwd-md5.factor b/extra/crypto/passwd-md5/passwd-md5.factor index 30650c1e40..a8706a7531 100644 --- a/extra/crypto/passwd-md5/passwd-md5.factor +++ b/extra/crypto/passwd-md5/passwd-md5.factor @@ -17,31 +17,32 @@ IN: crypto.passwd-md5 PRIVATE> :: passwd-md5 ( magic salt password -- bytes ) - [let* | final! [ password magic salt 3append - salt password tuck 3append md5 checksum-bytes - password length - [ 16 / ceiling swap concat ] keep - head-slice append - password [ length make-bits ] [ first ] bi - '[ CHAR: \0 _ ? ] "" map-as append - md5 checksum-bytes ] | - 1000 [ - "" swap - { - [ 0 bit? password final ? append ] - [ 3 mod 0 > [ salt append ] when ] - [ 7 mod 0 > [ password append ] when ] - [ 0 bit? final password ? append ] - } cleave md5 checksum-bytes final! - ] each + password magic salt 3append + salt password dup surround md5 checksum-bytes + password length + [ 16 / ceiling swap concat ] keep + head-slice append + password [ length make-bits ] [ first ] bi + '[ CHAR: \0 _ ? ] "" map-as append + md5 checksum-bytes :> final! - magic salt "$" 3append - { 12 0 6 13 1 7 14 2 8 15 3 9 5 4 10 } final nths 3 group - [ first3 [ 16 shift ] [ 8 shift ] bi* + + 4 to64 ] map concat - 11 final nth 2 to64 3append ] ; + 1000 iota [ + "" swap + { + [ 0 bit? password final ? append ] + [ 3 mod 0 > [ salt append ] when ] + [ 7 mod 0 > [ password append ] when ] + [ 0 bit? final password ? append ] + } cleave md5 checksum-bytes final! + ] each + + magic salt "$" 3append + { 12 0 6 13 1 7 14 2 8 15 3 9 5 4 10 } final nths 3 group + [ first3 [ 16 shift ] [ 8 shift ] bi* + + 4 to64 ] map concat + 11 final nth 2 to64 3append ; : parse-shadow-password ( string -- magic salt password ) - "$" split harvest first3 [ "$" tuck 3append ] 2dip ; + "$" split harvest first3 [ "$" dup surround ] 2dip ; : authenticate-password ( shadow password -- ? ) '[ parse-shadow-password drop _ passwd-md5 ] keep = ; diff --git a/extra/curses/curses.factor b/extra/curses/curses.factor index 4d6c77fd23..69c6503aa2 100644 --- a/extra/curses/curses.factor +++ b/extra/curses/curses.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.strings assocs byte-arrays combinators continuations destructors fry io.encodings.8-bit -io io.encodings.string io.encodings.utf8 kernel math +io io.encodings.string io.encodings.utf8 kernel locals math namespaces prettyprint sequences classes.struct strings threads curses.ffi ; IN: curses @@ -123,8 +123,10 @@ PRIVATE> : curses-writef ( window string -- ) [ window-ptr dup ] dip (curses-wprint) (curses-window-refresh) ; -: (curses-read) ( window-ptr n encoding -- string ) - [ [ tuck ] keep wgetnstr curses-error ] dip alien>string ; +:: (curses-read) ( window-ptr n encoding -- string ) + n :> buf + window-ptr buf n wgetnstr curses-error + buf encoding alien>string ; : curses-read ( window n -- string ) utf8 [ window-ptr ] 2dip (curses-read) ; diff --git a/extra/db/info/info.factor b/extra/db/info/info.factor index 66409f2834..4d17b6bf10 100644 --- a/extra/db/info/info.factor +++ b/extra/db/info/info.factor @@ -10,6 +10,6 @@ SYNTAX: get-psql-info get-info 5 firstn [ >>username ] [ [ f ] [ ] if-empty >>password ] [ >>database ] - } spread parsed ; + } spread suffix! ; -SYNTAX: get-sqlite-info get-info first parsed ; \ No newline at end of file +SYNTAX: get-sqlite-info get-info first suffix! ; diff --git a/extra/decimals/decimals-tests.factor b/extra/decimals/decimals-tests.factor index bb9e60cfc1..29b9d98b38 100644 --- a/extra/decimals/decimals-tests.factor +++ b/extra/decimals/decimals-tests.factor @@ -49,3 +49,4 @@ ERROR: decimal-test-failure D1 D2 quot ; [ f ] [ D: -1 D: -2 before? ] unit-test [ f ] [ D: -2 D: -2 before? ] unit-test [ t ] [ D: -3 D: -2 before? ] unit-test +[ t ] [ D: .5 D: 0 D: 1.0 between? ] unit-test diff --git a/extra/decimals/decimals.factor b/extra/decimals/decimals.factor index d9bafd43d0..d5c62fee5e 100644 --- a/extra/decimals/decimals.factor +++ b/extra/decimals/decimals.factor @@ -20,7 +20,7 @@ TUPLE: decimal { mantissa read-only } { exponent read-only } ; : parse-decimal ( -- decimal ) scan string>decimal ; -SYNTAX: D: parse-decimal parsed ; +SYNTAX: D: parse-decimal suffix! ; : decimal>ratio ( decimal -- ratio ) >decimal< 10^ * ; : decimal>float ( decimal -- ratio ) decimal>ratio >float ; @@ -37,8 +37,7 @@ SYNTAX: D: parse-decimal parsed ; ] 2bi ; : scale-decimals ( D1 D2 -- D1' D2' ) - [ drop ] - [ scale-mantissas nip ] 2bi ; + scale-mantissas [ ] curry bi@ ; ERROR: decimal-types-expected d1 d2 ; @@ -76,10 +75,13 @@ M: decimal before? :: D/ ( D1 D2 a -- D3 ) D1 D2 guard-decimals 2drop - D1 >decimal< :> e1 :> m1 - D2 >decimal< :> e2 :> m2 + D1 >decimal< :> ( m1 e1 ) + D2 >decimal< :> ( m2 e2 ) m1 a 10^ * m2 /i e1 e2 a + - ; + +M: decimal <=> + 2dup before? [ 2drop +lt+ ] [ equal? +eq+ +gt+ ? ] if ; inline diff --git a/extra/digraphs/digraphs.factor b/extra/digraphs/digraphs.factor index 5ccc0d5a60..ccbe90fb3c 100755 --- a/extra/digraphs/digraphs.factor +++ b/extra/digraphs/digraphs.factor @@ -21,10 +21,10 @@ TUPLE: vertex value edges ; : @edges ( from to digraph -- to edges ) swapd at edges>> ; : add-edge ( from to digraph -- ) @edges push ; -: delete-edge ( from to digraph -- ) @edges delete ; +: delete-edge ( from to digraph -- ) @edges remove! drop ; : delete-to-edges ( to digraph -- ) - [ nip dupd edges>> delete ] assoc-each drop ; + [ nip dupd edges>> remove! drop ] assoc-each drop ; : delete-vertex ( key digraph -- ) 2dup delete-at delete-to-edges ; @@ -44,7 +44,7 @@ DEFER: (topological-sort) ] if ; : topological-sort ( digraph -- seq ) - dup clone V{ } clone spin + [ V{ } clone ] dip [ clone ] keep [ drop (topological-sort) ] assoc-each drop reverse ; : topological-sorted-values ( digraph -- seq ) diff --git a/extra/ecdsa/ecdsa.factor b/extra/ecdsa/ecdsa.factor index c4d889991e..8e285a0904 100644 --- a/extra/ecdsa/ecdsa.factor +++ b/extra/ecdsa/ecdsa.factor @@ -50,7 +50,7 @@ PRIVATE> : get-private-key ( -- bin/f ) ec-key-handle EC_KEY_get0_private_key - dup [ dup BN_num_bits bits>bytes tuck BN_bn2bin drop ] when ; + dup [ dup BN_num_bits bits>bytes [ BN_bn2bin drop ] keep ] when ; :: get-public-key ( -- bin/f ) ec-key-handle :> KEY diff --git a/extra/fonts/syntax/syntax.factor b/extra/fonts/syntax/syntax.factor index c296dfb3df..34ccbc8aa8 100644 --- a/extra/fonts/syntax/syntax.factor +++ b/extra/fonts/syntax/syntax.factor @@ -13,4 +13,4 @@ SYNTAX: FONT: \ ; parse-until { [ [ italic = ] find nip [ >>italic? ] install ] [ [ bold = ] find nip [ >>bold? ] install ] [ [ fontname? ] find nip [ >>name* ] install ] -} cleave 4array concat '[ dup font>> @ drop ] over push-all ; +} cleave 4array concat '[ dup font>> @ drop ] append! ; diff --git a/extra/fries/fries.factor b/extra/fries/fries.factor index f67d0d7cd3..3f970a86bf 100644 --- a/extra/fries/fries.factor +++ b/extra/fries/fries.factor @@ -1,13 +1,17 @@ USING: arrays vectors combinators effects kernel math sequences splitting strings.parser parser fry sequences.extras ; + +! a b c glue => acb +! c b a [ append ] dip prepend + IN: fries : str-fry ( str on -- quot ) split - [ unclip-last [ [ spin glue ] reduce-r ] 2curry ] + [ unclip-last [ [ [ append ] [ prepend ] bi* ] reduce-r ] 2curry ] [ length 1 - 1 [ call-effect ] 2curry ] bi ; : gen-fry ( str on -- quot ) split - [ unclip-last [ [ spin 1array glue ] reduce-r ] 2curry ] + [ unclip-last [ [ [ 1array ] [ append ] [ prepend ] tri* ] reduce-r ] 2curry ] [ length 1 - 1 [ call-effect ] 2curry ] bi ; -SYNTAX: i" parse-string rest "_" str-fry over push-all ; -SYNTAX: i{ \ } parse-until >array { _ } gen-fry over push-all ; -SYNTAX: iV{ \ } parse-until >vector V{ _ } gen-fry over push-all ; +SYNTAX: i" parse-string rest "_" str-fry append! ; +SYNTAX: i{ \ } parse-until >array { _ } gen-fry append! ; +SYNTAX: iV{ \ } parse-until >vector V{ _ } gen-fry append! ; diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index ded10b66cb..d64ef41f8c 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -139,11 +139,11 @@ PRIVATE> : fuel-scaffold-vocab ( root name devname -- ) [ fuel-scaffold-name dup [ scaffold-vocab ] dip ] with-scope - dup require vocab-source-path (normalize-path) fuel-eval-set-result ; + dup require vocab-source-path absolute-path fuel-eval-set-result ; : fuel-scaffold-help ( name devname -- ) [ fuel-scaffold-name dup require dup scaffold-help ] with-scope - vocab-docs-path (normalize-path) fuel-eval-set-result ; + vocab-docs-path absolute-path fuel-eval-set-result ; : fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ; diff --git a/extra/fuel/xref/xref.factor b/extra/fuel/xref/xref.factor index c228901afb..39ba3bd2b3 100644 --- a/extra/fuel/xref/xref.factor +++ b/extra/fuel/xref/xref.factor @@ -11,7 +11,7 @@ IN: fuel.xref [ first (normalize-path) ] [ drop f ] if ] + [ dup length 0 > [ first absolute-path ] [ drop f ] if ] [ dup length 1 > [ second ] [ drop 1 ] if ] bi ; : get-loc ( object -- loc ) normalize-loc 2array ; diff --git a/extra/galois-talk/galois-talk.factor b/extra/galois-talk/galois-talk.factor index 0d2a5a73d8..4c9c04ba8d 100644 --- a/extra/galois-talk/galois-talk.factor +++ b/extra/galois-talk/galois-talk.factor @@ -189,7 +189,7 @@ CONSTANT: galois-slides } { $slide "Locals and lexical scope" { "Define lambda words with " { $link POSTPONE: :: } } - { "Establish bindings with " { $link POSTPONE: [let } " and " { $link POSTPONE: [let* } } + { "Establish bindings with " { $link POSTPONE: [let } " and " { $snippet "[let*" } } "Mutable bindings with correct semantics" { "Named inputs for quotations with " { $link POSTPONE: [| } } "Full closures" diff --git a/extra/geo-ip/geo-ip.factor b/extra/geo-ip/geo-ip.factor index d07ed4b69c..f23848ce30 100644 --- a/extra/geo-ip/geo-ip.factor +++ b/extra/geo-ip/geo-ip.factor @@ -14,7 +14,7 @@ CONSTANT: db-url "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=down : download-db ( -- path ) db-path dup exists? [ db-url over ".gz" append download-to - { "gunzip" } over ".gz" append (normalize-path) suffix try-process + { "gunzip" } over ".gz" append absolute-path suffix try-process ] unless ; TUPLE: ip-entry from to registry assigned city cntry country ; diff --git a/extra/geobytes/geobytes.factor b/extra/geobytes/geobytes.factor index bbd16b7ff4..c398bdde7a 100644 --- a/extra/geobytes/geobytes.factor +++ b/extra/geobytes/geobytes.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: combinators combinators.smart csv io.encodings.8-bit -math.parser memoize sequences kernel unicode.categories money ; +math.parser memoize sequences kernel unicode.categories money +io.encodings.8-bit.latin1 ; IN: geobytes ! GeoBytes is not free software. diff --git a/extra/google-tech-talk/google-tech-talk.factor b/extra/google-tech-talk/google-tech-talk.factor index 5f33af04fe..02d0bedb2c 100644 --- a/extra/google-tech-talk/google-tech-talk.factor +++ b/extra/google-tech-talk/google-tech-talk.factor @@ -272,7 +272,7 @@ CONSTANT: google-slides } { $slide "Locals and lexical scope" { "Define lambda words with " { $link POSTPONE: :: } } - { "Establish bindings with " { $link POSTPONE: [let } " and " { $link POSTPONE: [let* } } + { "Establish bindings with " { $link POSTPONE: [let } " and " { $snippet "[let*" } } "Mutable bindings with correct semantics" { "Named inputs for quotations with " { $link POSTPONE: [| } } "Full closures" diff --git a/extra/gpu/buffers/buffers.factor b/extra/gpu/buffers/buffers.factor index 3de5a03d35..351a8b39b0 100644 --- a/extra/gpu/buffers/buffers.factor +++ b/extra/gpu/buffers/buffers.factor @@ -124,7 +124,7 @@ UNION: gpu-data-ptr buffer-ptr c-ptr ; quot call - target glUnmapBuffer ; inline + target glUnmapBuffer drop ; inline :: with-bound-buffer ( buffer target quot: ( -- ) -- ) target gl-target buffer glBindBuffer diff --git a/extra/gpu/demos/bunny/bunny.factor b/extra/gpu/demos/bunny/bunny.factor index 2e292f0141..09853263ce 100755 --- a/extra/gpu/demos/bunny/bunny.factor +++ b/extra/gpu/demos/bunny/bunny.factor @@ -3,13 +3,15 @@ USING: accessors alien.c-types arrays classes.struct combinators combinators.short-circuit game.worlds gpu gpu.buffers gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state gpu.textures gpu.util grouping http.client images images.loader -io io.encodings.ascii io.files io.files.temp kernel math -math.matrices math.parser math.vectors method-chains sequences -splitting threads ui ui.gadgets ui.gadgets.worlds -ui.pixel-formats specialized-arrays specialized-vectors ; +io io.encodings.ascii io.files io.files.temp kernel locals math +math.matrices math.vectors.simd math.parser math.vectors +method-chains namespaces sequences splitting threads ui ui.gadgets +ui.gadgets.worlds ui.pixel-formats specialized-arrays +specialized-vectors ; FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float SPECIALIZED-VECTOR: uint +SIMD: float IN: gpu.demos.bunny GLSL-SHADER-FILE: bunny-vertex-shader vertex-shader "bunny.v.glsl" @@ -52,7 +54,10 @@ VERTEX-FORMAT: bunny-vertex { f float-components 1 f } { "normal" float-components 3 f } { f float-components 1 f } ; -VERTEX-STRUCT: bunny-vertex-struct bunny-vertex + +STRUCT: bunny-vertex-struct + { vertex float-4 } + { normal float-4 } ; SPECIALIZED-VECTOR: bunny-vertex-struct @@ -74,43 +79,58 @@ UNIFORM-TUPLE: loading-uniforms { "texcoord-scale" vec2-uniform f } { "loading-texture" texture-uniform f } ; -: numbers ( str -- seq ) - " " split [ string>number ] map sift ; +: numbers ( tokens -- seq ) + [ string>number ] map ; inline : ( vertex -- struct ) bunny-vertex-struct - swap >float-array >>vertex ; inline + swap first3 0.0 float-4-boa >>vertex ; inline + +: (read-line-tokens) ( seq stream -- seq ) + " \n" over stream-read-until + [ [ pick push ] unless-empty ] + [ + { + { CHAR: \s [ (read-line-tokens) ] } + { CHAR: \n [ drop ] } + [ 2drop [ f ] when-empty ] + } case + ] bi* ; inline recursive + +: stream-read-line-tokens ( stream -- seq ) + V{ } clone swap (read-line-tokens) ; + +: each-line-tokens ( quot -- ) + input-stream get [ stream-read-line-tokens ] curry each-morsel ; inline : (parse-bunny-model) ( vs is -- vs is ) - readln [ + [ numbers { - { [ dup length 5 = ] [ 3 head pick push ] } - { [ dup first 3 = ] [ rest over push-all ] } + { [ dup length 5 = ] [ pick push ] } + { [ dup first 3 = ] [ rest append! ] } [ drop ] - } cond (parse-bunny-model) - ] when* ; + } cond + ] each-line-tokens ; inline : parse-bunny-model ( -- vertexes indexes ) 100000 100000 - (parse-bunny-model) ; + (parse-bunny-model) ; inline -: normal ( vertexes -- normal ) - [ [ second ] [ first ] bi v- ] - [ [ third ] [ first ] bi v- ] bi cross - vneg normalize ; inline +:: normal ( a b c -- normal ) + c a v- + b a v- cross normalize ; inline -: calc-bunny-normal ( vertexes indexes -- ) - swap - [ [ nth vertex>> ] curry { } map-as normal ] - [ [ nth [ v+ ] change-normal drop ] curry with each ] 2bi ; +:: calc-bunny-normal ( a b c vertexes -- ) + a b c [ vertexes nth vertex>> ] tri@ normal :> n + a b c [ vertexes nth [ n v+ ] change-normal drop ] tri@ ; inline : calc-bunny-normals ( vertexes indexes -- ) - 3 - [ calc-bunny-normal ] with each ; + 3 swap + [ [ first3 ] dip calc-bunny-normal ] curry each ; inline : normalize-bunny-normals ( vertexes -- ) - [ [ normalize ] change-normal drop ] each ; + [ [ normalize ] change-normal drop ] each ; inline : bunny-data ( filename -- vertexes indexes ) ascii [ parse-bunny-model ] with-file-reader diff --git a/extra/gpu/framebuffers/framebuffers.factor b/extra/gpu/framebuffers/framebuffers.factor index efd71782d0..bea72961e4 100755 --- a/extra/gpu/framebuffers/framebuffers.factor +++ b/extra/gpu/framebuffers/framebuffers.factor @@ -157,10 +157,13 @@ M: renderbuffer framebuffer-attachment-dim [ swap depth-attachment>> [ swap call ] [ drop ] if* ] [ swap stencil-attachment>> [ swap call ] [ drop ] if* ] 2tri ; inline -: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- ) - [ [ color-attachments>> ] dip [ GL_COLOR_ATTACHMENT0 + swap ] prepose each-index ] - [ swap depth-attachment>> [ GL_DEPTH_ATTACHMENT spin call ] [ drop ] if* ] - [ swap stencil-attachment>> [ GL_STENCIL_ATTACHMENT spin call ] [ drop ] if* ] 2tri ; inline +:: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- ) + framebuffer color-attachments>> + [| attachment n | n GL_COLOR_ATTACHMENT0 + attachment quot call ] each-index + framebuffer depth-attachment>> + [| attachment | GL_DEPTH_ATTACHMENT attachment quot call ] when* + framebuffer stencil-attachment>> + [| attachment | GL_STENCIL_ATTACHMENT attachment quot call ] when* ; inline GENERIC: bind-framebuffer-attachment ( attachment-target attachment -- ) diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index 5f92cf3dbf..1a13d3e556 100644 --- a/extra/gpu/render/render.factor +++ b/extra/gpu/render/render.factor @@ -332,13 +332,13 @@ DEFER: [bind-uniform-tuple] ] [ { [ ] } name "." append 1array - ] if* :> name-prefixes :> quot-prefixes + ] if* :> ( quot-prefixes name-prefixes ) type all-uniform-tuple-slots :> uniforms texture-unit quot-prefixes name-prefixes [| quot-prefix name-prefix | uniforms name-prefix [bind-uniform-tuple] quot-prefix prepend - ] 2map :> value-cleave :> texture-unit' + ] 2map :> ( texture-unit' value-cleave ) texture-unit' value>>-quot { value-cleave 2cleave } append ; @@ -356,7 +356,7 @@ DEFER: [bind-uniform-tuple] } cond ; :: [bind-uniform-tuple] ( texture-unit uniforms prefix -- texture-unit' quot ) - texture-unit uniforms [ prefix [bind-uniform] ] map :> uniforms-cleave :> texture-unit' + texture-unit uniforms [ prefix [bind-uniform] ] map :> ( texture-unit' uniforms-cleave ) texture-unit' { uniforms-cleave 2cleave } >quotation ; diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor index aece1b40d6..fc6d495dff 100755 --- a/extra/gpu/shaders/shaders.factor +++ b/extra/gpu/shaders/shaders.factor @@ -277,7 +277,7 @@ padding-no [ 0 ] initialize ] [ nip ] if ":" join ; : replace-log-line-numbers ( object log -- log' ) - "\n" split [ empty? not ] filter + "\n" split harvest [ replace-log-line-number ] with map "\n" join ; diff --git a/extra/gpu/util/wasd/wasd.factor b/extra/gpu/util/wasd/wasd.factor index bee05463af..b5ed28cc3d 100644 --- a/extra/gpu/util/wasd/wasd.factor +++ b/extra/gpu/util/wasd/wasd.factor @@ -49,6 +49,9 @@ M: wasd-world wasd-fly-vertically? drop t ; : wasd-p-matrix ( world -- matrix ) p-matrix>> ; +: ( world -- uniforms ) + [ wasd-mv-matrix ] [ wasd-p-matrix ] bi mvp-uniforms boa ; + CONSTANT: fov 0.7 :: generate-p-matrix ( world -- matrix ) @@ -107,12 +110,12 @@ CONSTANT: fov 0.7 :: wasd-keyboard-input ( world -- ) read-keyboard keys>> :> keys - key-w keys nth key-, keys nth or [ world walk-forward ] when - key-s keys nth key-o keys nth or [ world walk-backward ] when - key-a keys nth [ world walk-leftward ] when - key-d keys nth key-e keys nth or [ world walk-rightward ] when + key-w keys nth [ world walk-forward ] when + key-s keys nth [ world walk-backward ] when + key-a keys nth [ world walk-leftward ] when + key-d keys nth [ world walk-rightward ] when key-space keys nth [ world walk-upward ] when - key-c keys nth key-j keys nth or [ world walk-downward ] when + key-c keys nth [ world walk-downward ] when key-escape keys nth [ world close-window ] when ; : wasd-mouse-input ( world -- ) diff --git a/extra/histogram/histogram-docs.factor b/extra/histogram/histogram-docs.factor deleted file mode 100755 index fc463cabfe..0000000000 --- a/extra/histogram/histogram-docs.factor +++ /dev/null @@ -1,87 +0,0 @@ -IN: histogram -USING: help.markup help.syntax sequences hashtables quotations assocs ; - -HELP: histogram -{ $values - { "seq" sequence } - { "hashtable" hashtable } -} -{ $examples - { $example "! Count the number of times an element appears in a sequence." - "USING: prettyprint histogram ;" - "\"aaabc\" histogram ." - "H{ { 97 3 } { 98 1 } { 99 1 } }" - } -} -{ $description "Returns a hashtable where the keys are the elements of the sequence and the values are the number of times they appeared in that sequence." } ; - -HELP: histogram* -{ $values - { "hashtable" hashtable } { "seq" sequence } - { "hashtable" hashtable } -} -{ $examples - { $example "! Count the number of times the elements of two sequences appear." - "USING: prettyprint histogram ;" - "\"aaabc\" histogram \"aaaaaabc\" histogram* ." - "H{ { 97 9 } { 98 2 } { 99 2 } }" - } -} -{ $description "Takes an existing hashtable and uses " { $link histogram } " to continue counting the number of occurences of each element." } ; - -HELP: sequence>assoc -{ $values - { "seq" sequence } { "quot" quotation } { "exemplar" "an exemplar assoc" } - { "assoc" assoc } -} -{ $examples - { $example "! Iterate over a sequence and increment the count at each element" - "USING: assocs prettyprint histogram ;" - "\"aaabc\" [ inc-at ] H{ } sequence>assoc ." - "H{ { 97 3 } { 98 1 } { 99 1 } }" - } -} -{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a newly created " { $snippet "assoc" } " according to the passed quotation." } ; - -HELP: sequence>assoc* -{ $values - { "assoc" assoc } { "seq" sequence } { "quot" quotation } - { "assoc" assoc } -} -{ $examples - { $example "! Iterate over a sequence and add the counts to an existing assoc" - "USING: assocs prettyprint histogram kernel ;" - "H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ inc-at ] sequence>assoc* ." - "H{ { 97 5 } { 98 2 } { 99 1 } }" - } -} -{ $description "Iterates over a sequence, allowing elements of the sequence to be added to an existing " { $snippet "assoc" } " according to the passed quotation." } ; - -HELP: sequence>hashtable -{ $values - { "seq" sequence } { "quot" quotation } - { "hashtable" hashtable } -} -{ $examples - { $example "! Count the number of times an element occurs in a sequence" - "USING: assocs prettyprint histogram ;" - "\"aaabc\" [ inc-at ] sequence>hashtable ." - "H{ { 97 3 } { 98 1 } { 99 1 } }" - } -} -{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a hashtable according to the passed quotation." } ; - -ARTICLE: "histogram" "Computing histograms" -"Counting elements in a sequence:" -{ $subsections - histogram - histogram* -} -"Combinators for implementing histogram:" -{ $subsections - sequence>assoc - sequence>assoc* - sequence>hashtable -} ; - -ABOUT: "histogram" diff --git a/extra/histogram/histogram-tests.factor b/extra/histogram/histogram-tests.factor deleted file mode 100755 index f0e7b3e80e..0000000000 --- a/extra/histogram/histogram-tests.factor +++ /dev/null @@ -1,12 +0,0 @@ -IN: histogram.tests -USING: help.markup help.syntax tools.test histogram ; - -[ - H{ - { 97 2 } - { 98 2 } - { 99 2 } - } -] [ - "aabbcc" histogram -] unit-test diff --git a/extra/histogram/histogram.factor b/extra/histogram/histogram.factor deleted file mode 100755 index d5c6ab3778..0000000000 --- a/extra/histogram/histogram.factor +++ /dev/null @@ -1,29 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences assocs fry ; -IN: histogram - -assoc) ( seq quot assoc -- assoc ) - [ swap curry each ] keep ; inline - -PRIVATE> - -: sequence>assoc* ( assoc seq quot: ( obj assoc -- ) -- assoc ) - rot (sequence>assoc) ; inline - -: sequence>assoc ( seq quot: ( obj assoc -- ) exemplar -- assoc ) - clone (sequence>assoc) ; inline - -: sequence>hashtable ( seq quot: ( obj hashtable -- ) -- hashtable ) - H{ } sequence>assoc ; inline - -: histogram* ( hashtable seq -- hashtable ) - [ inc-at ] sequence>assoc* ; - -: histogram ( seq -- hashtable ) - [ inc-at ] sequence>hashtable ; - -: collect-values ( seq quot: ( obj hashtable -- ) -- hash ) - '[ [ dup @ ] dip push-at ] sequence>hashtable ; inline diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 9fcbffd0db..8d506cda28 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays hashtables sequence-parser +USING: accessors arrays hashtables sequences.parser html.parser.utils kernel namespaces sequences math unicode.case unicode.categories combinators.short-circuit quoting fry ; diff --git a/basis/images/testing/bmp/1bit.bmp b/extra/images/testing/bmp/1bit.bmp similarity index 100% rename from basis/images/testing/bmp/1bit.bmp rename to extra/images/testing/bmp/1bit.bmp diff --git a/basis/images/testing/bmp/42red_24bit.bmp b/extra/images/testing/bmp/42red_24bit.bmp similarity index 100% rename from basis/images/testing/bmp/42red_24bit.bmp rename to extra/images/testing/bmp/42red_24bit.bmp diff --git a/basis/images/testing/bmp/42red_24bit.fig b/extra/images/testing/bmp/42red_24bit.fig similarity index 100% rename from basis/images/testing/bmp/42red_24bit.fig rename to extra/images/testing/bmp/42red_24bit.fig diff --git a/basis/images/testing/bmp/rgb_4bit.bmp b/extra/images/testing/bmp/rgb_4bit.bmp similarity index 100% rename from basis/images/testing/bmp/rgb_4bit.bmp rename to extra/images/testing/bmp/rgb_4bit.bmp diff --git a/basis/images/testing/bmp/rgb_8bit.bmp b/extra/images/testing/bmp/rgb_8bit.bmp similarity index 100% rename from basis/images/testing/bmp/rgb_8bit.bmp rename to extra/images/testing/bmp/rgb_8bit.bmp diff --git a/basis/images/testing/bmp/rgb_8bit.fig b/extra/images/testing/bmp/rgb_8bit.fig similarity index 100% rename from basis/images/testing/bmp/rgb_8bit.fig rename to extra/images/testing/bmp/rgb_8bit.fig diff --git a/basis/images/testing/gif/alpha.fig b/extra/images/testing/gif/alpha.fig similarity index 100% rename from basis/images/testing/gif/alpha.fig rename to extra/images/testing/gif/alpha.fig diff --git a/basis/images/testing/gif/alpha.gif b/extra/images/testing/gif/alpha.gif similarity index 100% rename from basis/images/testing/gif/alpha.gif rename to extra/images/testing/gif/alpha.gif diff --git a/basis/images/testing/gif/astronaut_animation.fig b/extra/images/testing/gif/astronaut_animation.fig similarity index 100% rename from basis/images/testing/gif/astronaut_animation.fig rename to extra/images/testing/gif/astronaut_animation.fig diff --git a/basis/images/testing/gif/astronaut_animation.gif b/extra/images/testing/gif/astronaut_animation.gif similarity index 100% rename from basis/images/testing/gif/astronaut_animation.gif rename to extra/images/testing/gif/astronaut_animation.gif diff --git a/basis/images/testing/gif/checkmark.fig b/extra/images/testing/gif/checkmark.fig similarity index 100% rename from basis/images/testing/gif/checkmark.fig rename to extra/images/testing/gif/checkmark.fig diff --git a/basis/images/testing/gif/checkmark.gif b/extra/images/testing/gif/checkmark.gif similarity index 100% rename from basis/images/testing/gif/checkmark.gif rename to extra/images/testing/gif/checkmark.gif diff --git a/basis/images/testing/gif/circle.fig b/extra/images/testing/gif/circle.fig similarity index 100% rename from basis/images/testing/gif/circle.fig rename to extra/images/testing/gif/circle.fig diff --git a/basis/images/testing/gif/circle.gif b/extra/images/testing/gif/circle.gif similarity index 100% rename from basis/images/testing/gif/circle.gif rename to extra/images/testing/gif/circle.gif diff --git a/basis/images/testing/gif/monochrome.fig b/extra/images/testing/gif/monochrome.fig similarity index 100% rename from basis/images/testing/gif/monochrome.fig rename to extra/images/testing/gif/monochrome.fig diff --git a/basis/images/testing/gif/monochrome.gif b/extra/images/testing/gif/monochrome.gif similarity index 100% rename from basis/images/testing/gif/monochrome.gif rename to extra/images/testing/gif/monochrome.gif diff --git a/basis/images/testing/gif/noise.fig b/extra/images/testing/gif/noise.fig similarity index 100% rename from basis/images/testing/gif/noise.fig rename to extra/images/testing/gif/noise.fig diff --git a/basis/images/testing/gif/noise.gif b/extra/images/testing/gif/noise.gif similarity index 100% rename from basis/images/testing/gif/noise.gif rename to extra/images/testing/gif/noise.gif diff --git a/basis/images/testing/png/basn2c08.fig b/extra/images/testing/png/basn2c08.fig similarity index 100% rename from basis/images/testing/png/basn2c08.fig rename to extra/images/testing/png/basn2c08.fig diff --git a/basis/images/testing/png/basn2c08.png b/extra/images/testing/png/basn2c08.png similarity index 100% rename from basis/images/testing/png/basn2c08.png rename to extra/images/testing/png/basn2c08.png diff --git a/basis/images/testing/png/basn6a08.fig b/extra/images/testing/png/basn6a08.fig similarity index 100% rename from basis/images/testing/png/basn6a08.fig rename to extra/images/testing/png/basn6a08.fig diff --git a/basis/images/testing/png/basn6a08.png b/extra/images/testing/png/basn6a08.png similarity index 100% rename from basis/images/testing/png/basn6a08.png rename to extra/images/testing/png/basn6a08.png diff --git a/basis/images/testing/png/f00n2c08.fig b/extra/images/testing/png/f00n2c08.fig similarity index 100% rename from basis/images/testing/png/f00n2c08.fig rename to extra/images/testing/png/f00n2c08.fig diff --git a/basis/images/testing/png/f00n2c08.png b/extra/images/testing/png/f00n2c08.png similarity index 100% rename from basis/images/testing/png/f00n2c08.png rename to extra/images/testing/png/f00n2c08.png diff --git a/basis/images/testing/png/f01n2c08.fig b/extra/images/testing/png/f01n2c08.fig similarity index 100% rename from basis/images/testing/png/f01n2c08.fig rename to extra/images/testing/png/f01n2c08.fig diff --git a/basis/images/testing/png/f01n2c08.png b/extra/images/testing/png/f01n2c08.png similarity index 100% rename from basis/images/testing/png/f01n2c08.png rename to extra/images/testing/png/f01n2c08.png diff --git a/basis/images/testing/png/f02n2c08.fig b/extra/images/testing/png/f02n2c08.fig similarity index 100% rename from basis/images/testing/png/f02n2c08.fig rename to extra/images/testing/png/f02n2c08.fig diff --git a/basis/images/testing/png/f02n2c08.png b/extra/images/testing/png/f02n2c08.png similarity index 100% rename from basis/images/testing/png/f02n2c08.png rename to extra/images/testing/png/f02n2c08.png diff --git a/basis/images/testing/png/f03n2c08.fig b/extra/images/testing/png/f03n2c08.fig similarity index 100% rename from basis/images/testing/png/f03n2c08.fig rename to extra/images/testing/png/f03n2c08.fig diff --git a/basis/images/testing/png/f03n2c08.png b/extra/images/testing/png/f03n2c08.png similarity index 100% rename from basis/images/testing/png/f03n2c08.png rename to extra/images/testing/png/f03n2c08.png diff --git a/basis/images/testing/png/f04n2c08.fig b/extra/images/testing/png/f04n2c08.fig similarity index 100% rename from basis/images/testing/png/f04n2c08.fig rename to extra/images/testing/png/f04n2c08.fig diff --git a/basis/images/testing/png/f04n2c08.png b/extra/images/testing/png/f04n2c08.png similarity index 100% rename from basis/images/testing/png/f04n2c08.png rename to extra/images/testing/png/f04n2c08.png diff --git a/basis/images/testing/png/suite/basi0g01.png b/extra/images/testing/png/suite/basi0g01.png similarity index 100% rename from basis/images/testing/png/suite/basi0g01.png rename to extra/images/testing/png/suite/basi0g01.png diff --git a/basis/images/testing/png/suite/basi0g02.png b/extra/images/testing/png/suite/basi0g02.png similarity index 100% rename from basis/images/testing/png/suite/basi0g02.png rename to extra/images/testing/png/suite/basi0g02.png diff --git a/basis/images/testing/png/suite/basi0g04.png b/extra/images/testing/png/suite/basi0g04.png similarity index 100% rename from basis/images/testing/png/suite/basi0g04.png rename to extra/images/testing/png/suite/basi0g04.png diff --git a/basis/images/testing/png/suite/basi0g08.png b/extra/images/testing/png/suite/basi0g08.png similarity index 100% rename from basis/images/testing/png/suite/basi0g08.png rename to extra/images/testing/png/suite/basi0g08.png diff --git a/basis/images/testing/png/suite/basi0g16.png b/extra/images/testing/png/suite/basi0g16.png similarity index 100% rename from basis/images/testing/png/suite/basi0g16.png rename to extra/images/testing/png/suite/basi0g16.png diff --git a/basis/images/testing/png/suite/basi2c08.png b/extra/images/testing/png/suite/basi2c08.png similarity index 100% rename from basis/images/testing/png/suite/basi2c08.png rename to extra/images/testing/png/suite/basi2c08.png diff --git a/basis/images/testing/png/suite/basi2c16.png b/extra/images/testing/png/suite/basi2c16.png similarity index 100% rename from basis/images/testing/png/suite/basi2c16.png rename to extra/images/testing/png/suite/basi2c16.png diff --git a/basis/images/testing/png/suite/basi3p01.png b/extra/images/testing/png/suite/basi3p01.png similarity index 100% rename from basis/images/testing/png/suite/basi3p01.png rename to extra/images/testing/png/suite/basi3p01.png diff --git a/basis/images/testing/png/suite/basi3p02.png b/extra/images/testing/png/suite/basi3p02.png similarity index 100% rename from basis/images/testing/png/suite/basi3p02.png rename to extra/images/testing/png/suite/basi3p02.png diff --git a/basis/images/testing/png/suite/basi3p04.png b/extra/images/testing/png/suite/basi3p04.png similarity index 100% rename from basis/images/testing/png/suite/basi3p04.png rename to extra/images/testing/png/suite/basi3p04.png diff --git a/basis/images/testing/png/suite/basi3p08.png b/extra/images/testing/png/suite/basi3p08.png similarity index 100% rename from basis/images/testing/png/suite/basi3p08.png rename to extra/images/testing/png/suite/basi3p08.png diff --git a/basis/images/testing/png/suite/basi4a08.png b/extra/images/testing/png/suite/basi4a08.png similarity index 100% rename from basis/images/testing/png/suite/basi4a08.png rename to extra/images/testing/png/suite/basi4a08.png diff --git a/basis/images/testing/png/suite/basi4a16.png b/extra/images/testing/png/suite/basi4a16.png similarity index 100% rename from basis/images/testing/png/suite/basi4a16.png rename to extra/images/testing/png/suite/basi4a16.png diff --git a/basis/images/testing/png/suite/basi6a08.png b/extra/images/testing/png/suite/basi6a08.png similarity index 100% rename from basis/images/testing/png/suite/basi6a08.png rename to extra/images/testing/png/suite/basi6a08.png diff --git a/basis/images/testing/png/suite/basi6a16.png b/extra/images/testing/png/suite/basi6a16.png similarity index 100% rename from basis/images/testing/png/suite/basi6a16.png rename to extra/images/testing/png/suite/basi6a16.png diff --git a/basis/images/testing/png/suite/basn0g01.png b/extra/images/testing/png/suite/basn0g01.png similarity index 100% rename from basis/images/testing/png/suite/basn0g01.png rename to extra/images/testing/png/suite/basn0g01.png diff --git a/basis/images/testing/png/suite/basn0g02.png b/extra/images/testing/png/suite/basn0g02.png similarity index 100% rename from basis/images/testing/png/suite/basn0g02.png rename to extra/images/testing/png/suite/basn0g02.png diff --git a/basis/images/testing/png/suite/basn0g04.png b/extra/images/testing/png/suite/basn0g04.png similarity index 100% rename from basis/images/testing/png/suite/basn0g04.png rename to extra/images/testing/png/suite/basn0g04.png diff --git a/basis/images/testing/png/suite/basn0g08.png b/extra/images/testing/png/suite/basn0g08.png similarity index 100% rename from basis/images/testing/png/suite/basn0g08.png rename to extra/images/testing/png/suite/basn0g08.png diff --git a/basis/images/testing/png/suite/basn0g16.png b/extra/images/testing/png/suite/basn0g16.png similarity index 100% rename from basis/images/testing/png/suite/basn0g16.png rename to extra/images/testing/png/suite/basn0g16.png diff --git a/basis/images/testing/png/suite/basn2c08.png b/extra/images/testing/png/suite/basn2c08.png similarity index 100% rename from basis/images/testing/png/suite/basn2c08.png rename to extra/images/testing/png/suite/basn2c08.png diff --git a/basis/images/testing/png/suite/basn2c16.png b/extra/images/testing/png/suite/basn2c16.png similarity index 100% rename from basis/images/testing/png/suite/basn2c16.png rename to extra/images/testing/png/suite/basn2c16.png diff --git a/basis/images/testing/png/suite/basn3p01.png b/extra/images/testing/png/suite/basn3p01.png similarity index 100% rename from basis/images/testing/png/suite/basn3p01.png rename to extra/images/testing/png/suite/basn3p01.png diff --git a/basis/images/testing/png/suite/basn3p02.png b/extra/images/testing/png/suite/basn3p02.png similarity index 100% rename from basis/images/testing/png/suite/basn3p02.png rename to extra/images/testing/png/suite/basn3p02.png diff --git a/basis/images/testing/png/suite/basn3p04.png b/extra/images/testing/png/suite/basn3p04.png similarity index 100% rename from basis/images/testing/png/suite/basn3p04.png rename to extra/images/testing/png/suite/basn3p04.png diff --git a/basis/images/testing/png/suite/basn3p08.png b/extra/images/testing/png/suite/basn3p08.png similarity index 100% rename from basis/images/testing/png/suite/basn3p08.png rename to extra/images/testing/png/suite/basn3p08.png diff --git a/basis/images/testing/png/suite/basn4a08.png b/extra/images/testing/png/suite/basn4a08.png similarity index 100% rename from basis/images/testing/png/suite/basn4a08.png rename to extra/images/testing/png/suite/basn4a08.png diff --git a/basis/images/testing/png/suite/basn4a16.png b/extra/images/testing/png/suite/basn4a16.png similarity index 100% rename from basis/images/testing/png/suite/basn4a16.png rename to extra/images/testing/png/suite/basn4a16.png diff --git a/basis/images/testing/png/suite/basn6a08.png b/extra/images/testing/png/suite/basn6a08.png similarity index 100% rename from basis/images/testing/png/suite/basn6a08.png rename to extra/images/testing/png/suite/basn6a08.png diff --git a/basis/images/testing/png/suite/basn6a16.png b/extra/images/testing/png/suite/basn6a16.png similarity index 100% rename from basis/images/testing/png/suite/basn6a16.png rename to extra/images/testing/png/suite/basn6a16.png diff --git a/basis/images/testing/png/suite/bgai4a08.png b/extra/images/testing/png/suite/bgai4a08.png similarity index 100% rename from basis/images/testing/png/suite/bgai4a08.png rename to extra/images/testing/png/suite/bgai4a08.png diff --git a/basis/images/testing/png/suite/bgai4a16.png b/extra/images/testing/png/suite/bgai4a16.png similarity index 100% rename from basis/images/testing/png/suite/bgai4a16.png rename to extra/images/testing/png/suite/bgai4a16.png diff --git a/basis/images/testing/png/suite/bgan6a08.png b/extra/images/testing/png/suite/bgan6a08.png similarity index 100% rename from basis/images/testing/png/suite/bgan6a08.png rename to extra/images/testing/png/suite/bgan6a08.png diff --git a/basis/images/testing/png/suite/bgan6a16.png b/extra/images/testing/png/suite/bgan6a16.png similarity index 100% rename from basis/images/testing/png/suite/bgan6a16.png rename to extra/images/testing/png/suite/bgan6a16.png diff --git a/basis/images/testing/png/suite/bgbn4a08.png b/extra/images/testing/png/suite/bgbn4a08.png similarity index 100% rename from basis/images/testing/png/suite/bgbn4a08.png rename to extra/images/testing/png/suite/bgbn4a08.png diff --git a/basis/images/testing/png/suite/bggn4a16.png b/extra/images/testing/png/suite/bggn4a16.png similarity index 100% rename from basis/images/testing/png/suite/bggn4a16.png rename to extra/images/testing/png/suite/bggn4a16.png diff --git a/basis/images/testing/png/suite/bgwn6a08.png b/extra/images/testing/png/suite/bgwn6a08.png similarity index 100% rename from basis/images/testing/png/suite/bgwn6a08.png rename to extra/images/testing/png/suite/bgwn6a08.png diff --git a/basis/images/testing/png/suite/bgyn6a16.png b/extra/images/testing/png/suite/bgyn6a16.png similarity index 100% rename from basis/images/testing/png/suite/bgyn6a16.png rename to extra/images/testing/png/suite/bgyn6a16.png diff --git a/basis/images/testing/png/suite/ccwn2c08.png b/extra/images/testing/png/suite/ccwn2c08.png similarity index 100% rename from basis/images/testing/png/suite/ccwn2c08.png rename to extra/images/testing/png/suite/ccwn2c08.png diff --git a/basis/images/testing/png/suite/ccwn3p08.png b/extra/images/testing/png/suite/ccwn3p08.png similarity index 100% rename from basis/images/testing/png/suite/ccwn3p08.png rename to extra/images/testing/png/suite/ccwn3p08.png diff --git a/basis/images/testing/png/suite/cdfn2c08.png b/extra/images/testing/png/suite/cdfn2c08.png similarity index 100% rename from basis/images/testing/png/suite/cdfn2c08.png rename to extra/images/testing/png/suite/cdfn2c08.png diff --git a/basis/images/testing/png/suite/cdhn2c08.png b/extra/images/testing/png/suite/cdhn2c08.png similarity index 100% rename from basis/images/testing/png/suite/cdhn2c08.png rename to extra/images/testing/png/suite/cdhn2c08.png diff --git a/basis/images/testing/png/suite/cdsn2c08.png b/extra/images/testing/png/suite/cdsn2c08.png similarity index 100% rename from basis/images/testing/png/suite/cdsn2c08.png rename to extra/images/testing/png/suite/cdsn2c08.png diff --git a/basis/images/testing/png/suite/cdun2c08.png b/extra/images/testing/png/suite/cdun2c08.png similarity index 100% rename from basis/images/testing/png/suite/cdun2c08.png rename to extra/images/testing/png/suite/cdun2c08.png diff --git a/basis/images/testing/png/suite/ch1n3p04.png b/extra/images/testing/png/suite/ch1n3p04.png similarity index 100% rename from basis/images/testing/png/suite/ch1n3p04.png rename to extra/images/testing/png/suite/ch1n3p04.png diff --git a/basis/images/testing/png/suite/ch2n3p08.png b/extra/images/testing/png/suite/ch2n3p08.png similarity index 100% rename from basis/images/testing/png/suite/ch2n3p08.png rename to extra/images/testing/png/suite/ch2n3p08.png diff --git a/basis/images/testing/png/suite/cm0n0g04.png b/extra/images/testing/png/suite/cm0n0g04.png similarity index 100% rename from basis/images/testing/png/suite/cm0n0g04.png rename to extra/images/testing/png/suite/cm0n0g04.png diff --git a/basis/images/testing/png/suite/cm7n0g04.png b/extra/images/testing/png/suite/cm7n0g04.png similarity index 100% rename from basis/images/testing/png/suite/cm7n0g04.png rename to extra/images/testing/png/suite/cm7n0g04.png diff --git a/basis/images/testing/png/suite/cm9n0g04.png b/extra/images/testing/png/suite/cm9n0g04.png similarity index 100% rename from basis/images/testing/png/suite/cm9n0g04.png rename to extra/images/testing/png/suite/cm9n0g04.png diff --git a/basis/images/testing/png/suite/cs3n2c16.png b/extra/images/testing/png/suite/cs3n2c16.png similarity index 100% rename from basis/images/testing/png/suite/cs3n2c16.png rename to extra/images/testing/png/suite/cs3n2c16.png diff --git a/basis/images/testing/png/suite/cs3n3p08.png b/extra/images/testing/png/suite/cs3n3p08.png similarity index 100% rename from basis/images/testing/png/suite/cs3n3p08.png rename to extra/images/testing/png/suite/cs3n3p08.png diff --git a/basis/images/testing/png/suite/cs5n2c08.png b/extra/images/testing/png/suite/cs5n2c08.png similarity index 100% rename from basis/images/testing/png/suite/cs5n2c08.png rename to extra/images/testing/png/suite/cs5n2c08.png diff --git a/basis/images/testing/png/suite/cs5n3p08.png b/extra/images/testing/png/suite/cs5n3p08.png similarity index 100% rename from basis/images/testing/png/suite/cs5n3p08.png rename to extra/images/testing/png/suite/cs5n3p08.png diff --git a/basis/images/testing/png/suite/cs8n2c08.png b/extra/images/testing/png/suite/cs8n2c08.png similarity index 100% rename from basis/images/testing/png/suite/cs8n2c08.png rename to extra/images/testing/png/suite/cs8n2c08.png diff --git a/basis/images/testing/png/suite/cs8n3p08.png b/extra/images/testing/png/suite/cs8n3p08.png similarity index 100% rename from basis/images/testing/png/suite/cs8n3p08.png rename to extra/images/testing/png/suite/cs8n3p08.png diff --git a/basis/images/testing/png/suite/ct0n0g04.png b/extra/images/testing/png/suite/ct0n0g04.png similarity index 100% rename from basis/images/testing/png/suite/ct0n0g04.png rename to extra/images/testing/png/suite/ct0n0g04.png diff --git a/basis/images/testing/png/suite/ct1n0g04.png b/extra/images/testing/png/suite/ct1n0g04.png similarity index 100% rename from basis/images/testing/png/suite/ct1n0g04.png rename to extra/images/testing/png/suite/ct1n0g04.png diff --git a/basis/images/testing/png/suite/ctzn0g04.png b/extra/images/testing/png/suite/ctzn0g04.png similarity index 100% rename from basis/images/testing/png/suite/ctzn0g04.png rename to extra/images/testing/png/suite/ctzn0g04.png diff --git a/basis/images/testing/png/suite/f00n0g08.png b/extra/images/testing/png/suite/f00n0g08.png similarity index 100% rename from basis/images/testing/png/suite/f00n0g08.png rename to extra/images/testing/png/suite/f00n0g08.png diff --git a/basis/images/testing/png/suite/f00n2c08.png b/extra/images/testing/png/suite/f00n2c08.png similarity index 100% rename from basis/images/testing/png/suite/f00n2c08.png rename to extra/images/testing/png/suite/f00n2c08.png diff --git a/basis/images/testing/png/suite/f01n0g08.png b/extra/images/testing/png/suite/f01n0g08.png similarity index 100% rename from basis/images/testing/png/suite/f01n0g08.png rename to extra/images/testing/png/suite/f01n0g08.png diff --git a/basis/images/testing/png/suite/f01n2c08.png b/extra/images/testing/png/suite/f01n2c08.png similarity index 100% rename from basis/images/testing/png/suite/f01n2c08.png rename to extra/images/testing/png/suite/f01n2c08.png diff --git a/basis/images/testing/png/suite/f02n0g08.png b/extra/images/testing/png/suite/f02n0g08.png similarity index 100% rename from basis/images/testing/png/suite/f02n0g08.png rename to extra/images/testing/png/suite/f02n0g08.png diff --git a/basis/images/testing/png/suite/f02n2c08.png b/extra/images/testing/png/suite/f02n2c08.png similarity index 100% rename from basis/images/testing/png/suite/f02n2c08.png rename to extra/images/testing/png/suite/f02n2c08.png diff --git a/basis/images/testing/png/suite/f03n0g08.png b/extra/images/testing/png/suite/f03n0g08.png similarity index 100% rename from basis/images/testing/png/suite/f03n0g08.png rename to extra/images/testing/png/suite/f03n0g08.png diff --git a/basis/images/testing/png/suite/f03n2c08.png b/extra/images/testing/png/suite/f03n2c08.png similarity index 100% rename from basis/images/testing/png/suite/f03n2c08.png rename to extra/images/testing/png/suite/f03n2c08.png diff --git a/basis/images/testing/png/suite/f04n0g08.png b/extra/images/testing/png/suite/f04n0g08.png similarity index 100% rename from basis/images/testing/png/suite/f04n0g08.png rename to extra/images/testing/png/suite/f04n0g08.png diff --git a/basis/images/testing/png/suite/f04n2c08.png b/extra/images/testing/png/suite/f04n2c08.png similarity index 100% rename from basis/images/testing/png/suite/f04n2c08.png rename to extra/images/testing/png/suite/f04n2c08.png diff --git a/basis/images/testing/png/suite/g03n0g16.png b/extra/images/testing/png/suite/g03n0g16.png similarity index 100% rename from basis/images/testing/png/suite/g03n0g16.png rename to extra/images/testing/png/suite/g03n0g16.png diff --git a/basis/images/testing/png/suite/g03n2c08.png b/extra/images/testing/png/suite/g03n2c08.png similarity index 100% rename from basis/images/testing/png/suite/g03n2c08.png rename to extra/images/testing/png/suite/g03n2c08.png diff --git a/basis/images/testing/png/suite/g03n3p04.png b/extra/images/testing/png/suite/g03n3p04.png similarity index 100% rename from basis/images/testing/png/suite/g03n3p04.png rename to extra/images/testing/png/suite/g03n3p04.png diff --git a/basis/images/testing/png/suite/g04n0g16.png b/extra/images/testing/png/suite/g04n0g16.png similarity index 100% rename from basis/images/testing/png/suite/g04n0g16.png rename to extra/images/testing/png/suite/g04n0g16.png diff --git a/basis/images/testing/png/suite/g04n2c08.png b/extra/images/testing/png/suite/g04n2c08.png similarity index 100% rename from basis/images/testing/png/suite/g04n2c08.png rename to extra/images/testing/png/suite/g04n2c08.png diff --git a/basis/images/testing/png/suite/g04n3p04.png b/extra/images/testing/png/suite/g04n3p04.png similarity index 100% rename from basis/images/testing/png/suite/g04n3p04.png rename to extra/images/testing/png/suite/g04n3p04.png diff --git a/basis/images/testing/png/suite/g05n0g16.png b/extra/images/testing/png/suite/g05n0g16.png similarity index 100% rename from basis/images/testing/png/suite/g05n0g16.png rename to extra/images/testing/png/suite/g05n0g16.png diff --git a/basis/images/testing/png/suite/g05n2c08.png b/extra/images/testing/png/suite/g05n2c08.png similarity index 100% rename from basis/images/testing/png/suite/g05n2c08.png rename to extra/images/testing/png/suite/g05n2c08.png diff --git a/basis/images/testing/png/suite/g05n3p04.png b/extra/images/testing/png/suite/g05n3p04.png similarity index 100% rename from basis/images/testing/png/suite/g05n3p04.png rename to extra/images/testing/png/suite/g05n3p04.png diff --git a/basis/images/testing/png/suite/g07n0g16.png b/extra/images/testing/png/suite/g07n0g16.png similarity index 100% rename from basis/images/testing/png/suite/g07n0g16.png rename to extra/images/testing/png/suite/g07n0g16.png diff --git a/basis/images/testing/png/suite/g07n2c08.png b/extra/images/testing/png/suite/g07n2c08.png similarity index 100% rename from basis/images/testing/png/suite/g07n2c08.png rename to extra/images/testing/png/suite/g07n2c08.png diff --git a/basis/images/testing/png/suite/g07n3p04.png b/extra/images/testing/png/suite/g07n3p04.png similarity index 100% rename from basis/images/testing/png/suite/g07n3p04.png rename to extra/images/testing/png/suite/g07n3p04.png diff --git a/basis/images/testing/png/suite/g10n0g16.png b/extra/images/testing/png/suite/g10n0g16.png similarity index 100% rename from basis/images/testing/png/suite/g10n0g16.png rename to extra/images/testing/png/suite/g10n0g16.png diff --git a/basis/images/testing/png/suite/g10n2c08.png b/extra/images/testing/png/suite/g10n2c08.png similarity index 100% rename from basis/images/testing/png/suite/g10n2c08.png rename to extra/images/testing/png/suite/g10n2c08.png diff --git a/basis/images/testing/png/suite/g10n3p04.png b/extra/images/testing/png/suite/g10n3p04.png similarity index 100% rename from basis/images/testing/png/suite/g10n3p04.png rename to extra/images/testing/png/suite/g10n3p04.png diff --git a/basis/images/testing/png/suite/g25n0g16.png b/extra/images/testing/png/suite/g25n0g16.png similarity index 100% rename from basis/images/testing/png/suite/g25n0g16.png rename to extra/images/testing/png/suite/g25n0g16.png diff --git a/basis/images/testing/png/suite/g25n2c08.png b/extra/images/testing/png/suite/g25n2c08.png similarity index 100% rename from basis/images/testing/png/suite/g25n2c08.png rename to extra/images/testing/png/suite/g25n2c08.png diff --git a/basis/images/testing/png/suite/g25n3p04.png b/extra/images/testing/png/suite/g25n3p04.png similarity index 100% rename from basis/images/testing/png/suite/g25n3p04.png rename to extra/images/testing/png/suite/g25n3p04.png diff --git a/basis/images/testing/png/suite/oi1n0g16.png b/extra/images/testing/png/suite/oi1n0g16.png similarity index 100% rename from basis/images/testing/png/suite/oi1n0g16.png rename to extra/images/testing/png/suite/oi1n0g16.png diff --git a/basis/images/testing/png/suite/oi1n2c16.png b/extra/images/testing/png/suite/oi1n2c16.png similarity index 100% rename from basis/images/testing/png/suite/oi1n2c16.png rename to extra/images/testing/png/suite/oi1n2c16.png diff --git a/basis/images/testing/png/suite/oi2n0g16.png b/extra/images/testing/png/suite/oi2n0g16.png similarity index 100% rename from basis/images/testing/png/suite/oi2n0g16.png rename to extra/images/testing/png/suite/oi2n0g16.png diff --git a/basis/images/testing/png/suite/oi2n2c16.png b/extra/images/testing/png/suite/oi2n2c16.png similarity index 100% rename from basis/images/testing/png/suite/oi2n2c16.png rename to extra/images/testing/png/suite/oi2n2c16.png diff --git a/basis/images/testing/png/suite/oi4n0g16.png b/extra/images/testing/png/suite/oi4n0g16.png similarity index 100% rename from basis/images/testing/png/suite/oi4n0g16.png rename to extra/images/testing/png/suite/oi4n0g16.png diff --git a/basis/images/testing/png/suite/oi4n2c16.png b/extra/images/testing/png/suite/oi4n2c16.png similarity index 100% rename from basis/images/testing/png/suite/oi4n2c16.png rename to extra/images/testing/png/suite/oi4n2c16.png diff --git a/basis/images/testing/png/suite/oi9n0g16.png b/extra/images/testing/png/suite/oi9n0g16.png similarity index 100% rename from basis/images/testing/png/suite/oi9n0g16.png rename to extra/images/testing/png/suite/oi9n0g16.png diff --git a/basis/images/testing/png/suite/oi9n2c16.png b/extra/images/testing/png/suite/oi9n2c16.png similarity index 100% rename from basis/images/testing/png/suite/oi9n2c16.png rename to extra/images/testing/png/suite/oi9n2c16.png diff --git a/basis/images/testing/png/suite/pngsuite.doc b/extra/images/testing/png/suite/pngsuite.doc similarity index 100% rename from basis/images/testing/png/suite/pngsuite.doc rename to extra/images/testing/png/suite/pngsuite.doc diff --git a/basis/images/testing/png/suite/pngsuite_logo.png b/extra/images/testing/png/suite/pngsuite_logo.png similarity index 100% rename from basis/images/testing/png/suite/pngsuite_logo.png rename to extra/images/testing/png/suite/pngsuite_logo.png diff --git a/basis/images/testing/png/suite/pp0n2c16.png b/extra/images/testing/png/suite/pp0n2c16.png similarity index 100% rename from basis/images/testing/png/suite/pp0n2c16.png rename to extra/images/testing/png/suite/pp0n2c16.png diff --git a/basis/images/testing/png/suite/pp0n6a08.png b/extra/images/testing/png/suite/pp0n6a08.png similarity index 100% rename from basis/images/testing/png/suite/pp0n6a08.png rename to extra/images/testing/png/suite/pp0n6a08.png diff --git a/basis/images/testing/png/suite/ps1n0g08.png b/extra/images/testing/png/suite/ps1n0g08.png similarity index 100% rename from basis/images/testing/png/suite/ps1n0g08.png rename to extra/images/testing/png/suite/ps1n0g08.png diff --git a/basis/images/testing/png/suite/ps1n2c16.png b/extra/images/testing/png/suite/ps1n2c16.png similarity index 100% rename from basis/images/testing/png/suite/ps1n2c16.png rename to extra/images/testing/png/suite/ps1n2c16.png diff --git a/basis/images/testing/png/suite/ps2n0g08.png b/extra/images/testing/png/suite/ps2n0g08.png similarity index 100% rename from basis/images/testing/png/suite/ps2n0g08.png rename to extra/images/testing/png/suite/ps2n0g08.png diff --git a/basis/images/testing/png/suite/ps2n2c16.png b/extra/images/testing/png/suite/ps2n2c16.png similarity index 100% rename from basis/images/testing/png/suite/ps2n2c16.png rename to extra/images/testing/png/suite/ps2n2c16.png diff --git a/basis/images/testing/png/suite/s01i3p01.png b/extra/images/testing/png/suite/s01i3p01.png similarity index 100% rename from basis/images/testing/png/suite/s01i3p01.png rename to extra/images/testing/png/suite/s01i3p01.png diff --git a/basis/images/testing/png/suite/s01n3p01.png b/extra/images/testing/png/suite/s01n3p01.png similarity index 100% rename from basis/images/testing/png/suite/s01n3p01.png rename to extra/images/testing/png/suite/s01n3p01.png diff --git a/basis/images/testing/png/suite/s02i3p01.png b/extra/images/testing/png/suite/s02i3p01.png similarity index 100% rename from basis/images/testing/png/suite/s02i3p01.png rename to extra/images/testing/png/suite/s02i3p01.png diff --git a/basis/images/testing/png/suite/s02n3p01.png b/extra/images/testing/png/suite/s02n3p01.png similarity index 100% rename from basis/images/testing/png/suite/s02n3p01.png rename to extra/images/testing/png/suite/s02n3p01.png diff --git a/basis/images/testing/png/suite/s03i3p01.png b/extra/images/testing/png/suite/s03i3p01.png similarity index 100% rename from basis/images/testing/png/suite/s03i3p01.png rename to extra/images/testing/png/suite/s03i3p01.png diff --git a/basis/images/testing/png/suite/s03n3p01.png b/extra/images/testing/png/suite/s03n3p01.png similarity index 100% rename from basis/images/testing/png/suite/s03n3p01.png rename to extra/images/testing/png/suite/s03n3p01.png diff --git a/basis/images/testing/png/suite/s04i3p01.png b/extra/images/testing/png/suite/s04i3p01.png similarity index 100% rename from basis/images/testing/png/suite/s04i3p01.png rename to extra/images/testing/png/suite/s04i3p01.png diff --git a/basis/images/testing/png/suite/s04n3p01.png b/extra/images/testing/png/suite/s04n3p01.png similarity index 100% rename from basis/images/testing/png/suite/s04n3p01.png rename to extra/images/testing/png/suite/s04n3p01.png diff --git a/basis/images/testing/png/suite/s05i3p02.png b/extra/images/testing/png/suite/s05i3p02.png similarity index 100% rename from basis/images/testing/png/suite/s05i3p02.png rename to extra/images/testing/png/suite/s05i3p02.png diff --git a/basis/images/testing/png/suite/s05n3p02.png b/extra/images/testing/png/suite/s05n3p02.png similarity index 100% rename from basis/images/testing/png/suite/s05n3p02.png rename to extra/images/testing/png/suite/s05n3p02.png diff --git a/basis/images/testing/png/suite/s06i3p02.png b/extra/images/testing/png/suite/s06i3p02.png similarity index 100% rename from basis/images/testing/png/suite/s06i3p02.png rename to extra/images/testing/png/suite/s06i3p02.png diff --git a/basis/images/testing/png/suite/s06n3p02.png b/extra/images/testing/png/suite/s06n3p02.png similarity index 100% rename from basis/images/testing/png/suite/s06n3p02.png rename to extra/images/testing/png/suite/s06n3p02.png diff --git a/basis/images/testing/png/suite/s07i3p02.png b/extra/images/testing/png/suite/s07i3p02.png similarity index 100% rename from basis/images/testing/png/suite/s07i3p02.png rename to extra/images/testing/png/suite/s07i3p02.png diff --git a/basis/images/testing/png/suite/s07n3p02.png b/extra/images/testing/png/suite/s07n3p02.png similarity index 100% rename from basis/images/testing/png/suite/s07n3p02.png rename to extra/images/testing/png/suite/s07n3p02.png diff --git a/basis/images/testing/png/suite/s08i3p02.png b/extra/images/testing/png/suite/s08i3p02.png similarity index 100% rename from basis/images/testing/png/suite/s08i3p02.png rename to extra/images/testing/png/suite/s08i3p02.png diff --git a/basis/images/testing/png/suite/s08n3p02.png b/extra/images/testing/png/suite/s08n3p02.png similarity index 100% rename from basis/images/testing/png/suite/s08n3p02.png rename to extra/images/testing/png/suite/s08n3p02.png diff --git a/basis/images/testing/png/suite/s09i3p02.png b/extra/images/testing/png/suite/s09i3p02.png similarity index 100% rename from basis/images/testing/png/suite/s09i3p02.png rename to extra/images/testing/png/suite/s09i3p02.png diff --git a/basis/images/testing/png/suite/s09n3p02.png b/extra/images/testing/png/suite/s09n3p02.png similarity index 100% rename from basis/images/testing/png/suite/s09n3p02.png rename to extra/images/testing/png/suite/s09n3p02.png diff --git a/basis/images/testing/png/suite/s32i3p04.png b/extra/images/testing/png/suite/s32i3p04.png similarity index 100% rename from basis/images/testing/png/suite/s32i3p04.png rename to extra/images/testing/png/suite/s32i3p04.png diff --git a/basis/images/testing/png/suite/s32n3p04.png b/extra/images/testing/png/suite/s32n3p04.png similarity index 100% rename from basis/images/testing/png/suite/s32n3p04.png rename to extra/images/testing/png/suite/s32n3p04.png diff --git a/basis/images/testing/png/suite/s33i3p04.png b/extra/images/testing/png/suite/s33i3p04.png similarity index 100% rename from basis/images/testing/png/suite/s33i3p04.png rename to extra/images/testing/png/suite/s33i3p04.png diff --git a/basis/images/testing/png/suite/s33n3p04.png b/extra/images/testing/png/suite/s33n3p04.png similarity index 100% rename from basis/images/testing/png/suite/s33n3p04.png rename to extra/images/testing/png/suite/s33n3p04.png diff --git a/basis/images/testing/png/suite/s34i3p04.png b/extra/images/testing/png/suite/s34i3p04.png similarity index 100% rename from basis/images/testing/png/suite/s34i3p04.png rename to extra/images/testing/png/suite/s34i3p04.png diff --git a/basis/images/testing/png/suite/s34n3p04.png b/extra/images/testing/png/suite/s34n3p04.png similarity index 100% rename from basis/images/testing/png/suite/s34n3p04.png rename to extra/images/testing/png/suite/s34n3p04.png diff --git a/basis/images/testing/png/suite/s35i3p04.png b/extra/images/testing/png/suite/s35i3p04.png similarity index 100% rename from basis/images/testing/png/suite/s35i3p04.png rename to extra/images/testing/png/suite/s35i3p04.png diff --git a/basis/images/testing/png/suite/s35n3p04.png b/extra/images/testing/png/suite/s35n3p04.png similarity index 100% rename from basis/images/testing/png/suite/s35n3p04.png rename to extra/images/testing/png/suite/s35n3p04.png diff --git a/basis/images/testing/png/suite/s36i3p04.png b/extra/images/testing/png/suite/s36i3p04.png similarity index 100% rename from basis/images/testing/png/suite/s36i3p04.png rename to extra/images/testing/png/suite/s36i3p04.png diff --git a/basis/images/testing/png/suite/s36n3p04.png b/extra/images/testing/png/suite/s36n3p04.png similarity index 100% rename from basis/images/testing/png/suite/s36n3p04.png rename to extra/images/testing/png/suite/s36n3p04.png diff --git a/basis/images/testing/png/suite/s37i3p04.png b/extra/images/testing/png/suite/s37i3p04.png similarity index 100% rename from basis/images/testing/png/suite/s37i3p04.png rename to extra/images/testing/png/suite/s37i3p04.png diff --git a/basis/images/testing/png/suite/s37n3p04.png b/extra/images/testing/png/suite/s37n3p04.png similarity index 100% rename from basis/images/testing/png/suite/s37n3p04.png rename to extra/images/testing/png/suite/s37n3p04.png diff --git a/basis/images/testing/png/suite/s38i3p04.png b/extra/images/testing/png/suite/s38i3p04.png similarity index 100% rename from basis/images/testing/png/suite/s38i3p04.png rename to extra/images/testing/png/suite/s38i3p04.png diff --git a/basis/images/testing/png/suite/s38n3p04.png b/extra/images/testing/png/suite/s38n3p04.png similarity index 100% rename from basis/images/testing/png/suite/s38n3p04.png rename to extra/images/testing/png/suite/s38n3p04.png diff --git a/basis/images/testing/png/suite/s39i3p04.png b/extra/images/testing/png/suite/s39i3p04.png similarity index 100% rename from basis/images/testing/png/suite/s39i3p04.png rename to extra/images/testing/png/suite/s39i3p04.png diff --git a/basis/images/testing/png/suite/s39n3p04.png b/extra/images/testing/png/suite/s39n3p04.png similarity index 100% rename from basis/images/testing/png/suite/s39n3p04.png rename to extra/images/testing/png/suite/s39n3p04.png diff --git a/basis/images/testing/png/suite/s40i3p04.png b/extra/images/testing/png/suite/s40i3p04.png similarity index 100% rename from basis/images/testing/png/suite/s40i3p04.png rename to extra/images/testing/png/suite/s40i3p04.png diff --git a/basis/images/testing/png/suite/s40n3p04.png b/extra/images/testing/png/suite/s40n3p04.png similarity index 100% rename from basis/images/testing/png/suite/s40n3p04.png rename to extra/images/testing/png/suite/s40n3p04.png diff --git a/basis/images/testing/png/suite/tbbn1g04.png b/extra/images/testing/png/suite/tbbn1g04.png similarity index 100% rename from basis/images/testing/png/suite/tbbn1g04.png rename to extra/images/testing/png/suite/tbbn1g04.png diff --git a/basis/images/testing/png/suite/tbbn2c16.png b/extra/images/testing/png/suite/tbbn2c16.png similarity index 100% rename from basis/images/testing/png/suite/tbbn2c16.png rename to extra/images/testing/png/suite/tbbn2c16.png diff --git a/basis/images/testing/png/suite/tbbn3p08.png b/extra/images/testing/png/suite/tbbn3p08.png similarity index 100% rename from basis/images/testing/png/suite/tbbn3p08.png rename to extra/images/testing/png/suite/tbbn3p08.png diff --git a/basis/images/testing/png/suite/tbgn2c16.png b/extra/images/testing/png/suite/tbgn2c16.png similarity index 100% rename from basis/images/testing/png/suite/tbgn2c16.png rename to extra/images/testing/png/suite/tbgn2c16.png diff --git a/basis/images/testing/png/suite/tbgn3p08.png b/extra/images/testing/png/suite/tbgn3p08.png similarity index 100% rename from basis/images/testing/png/suite/tbgn3p08.png rename to extra/images/testing/png/suite/tbgn3p08.png diff --git a/basis/images/testing/png/suite/tbrn2c08.png b/extra/images/testing/png/suite/tbrn2c08.png similarity index 100% rename from basis/images/testing/png/suite/tbrn2c08.png rename to extra/images/testing/png/suite/tbrn2c08.png diff --git a/basis/images/testing/png/suite/tbwn1g16.png b/extra/images/testing/png/suite/tbwn1g16.png similarity index 100% rename from basis/images/testing/png/suite/tbwn1g16.png rename to extra/images/testing/png/suite/tbwn1g16.png diff --git a/basis/images/testing/png/suite/tbwn3p08.png b/extra/images/testing/png/suite/tbwn3p08.png similarity index 100% rename from basis/images/testing/png/suite/tbwn3p08.png rename to extra/images/testing/png/suite/tbwn3p08.png diff --git a/basis/images/testing/png/suite/tbyn3p08.png b/extra/images/testing/png/suite/tbyn3p08.png similarity index 100% rename from basis/images/testing/png/suite/tbyn3p08.png rename to extra/images/testing/png/suite/tbyn3p08.png diff --git a/basis/images/testing/png/suite/tp0n1g08.png b/extra/images/testing/png/suite/tp0n1g08.png similarity index 100% rename from basis/images/testing/png/suite/tp0n1g08.png rename to extra/images/testing/png/suite/tp0n1g08.png diff --git a/basis/images/testing/png/suite/tp0n2c08.png b/extra/images/testing/png/suite/tp0n2c08.png similarity index 100% rename from basis/images/testing/png/suite/tp0n2c08.png rename to extra/images/testing/png/suite/tp0n2c08.png diff --git a/basis/images/testing/png/suite/tp0n3p08.png b/extra/images/testing/png/suite/tp0n3p08.png similarity index 100% rename from basis/images/testing/png/suite/tp0n3p08.png rename to extra/images/testing/png/suite/tp0n3p08.png diff --git a/basis/images/testing/png/suite/tp1n3p08.png b/extra/images/testing/png/suite/tp1n3p08.png similarity index 100% rename from basis/images/testing/png/suite/tp1n3p08.png rename to extra/images/testing/png/suite/tp1n3p08.png diff --git a/basis/images/testing/png/suite/x00n0g01.png b/extra/images/testing/png/suite/x00n0g01.png similarity index 100% rename from basis/images/testing/png/suite/x00n0g01.png rename to extra/images/testing/png/suite/x00n0g01.png diff --git a/basis/images/testing/png/suite/xcrn0g04.png b/extra/images/testing/png/suite/xcrn0g04.png similarity index 100% rename from basis/images/testing/png/suite/xcrn0g04.png rename to extra/images/testing/png/suite/xcrn0g04.png diff --git a/basis/images/testing/png/suite/xlfn0g04.png b/extra/images/testing/png/suite/xlfn0g04.png similarity index 100% rename from basis/images/testing/png/suite/xlfn0g04.png rename to extra/images/testing/png/suite/xlfn0g04.png diff --git a/basis/images/testing/png/suite/z00n2c08.png b/extra/images/testing/png/suite/z00n2c08.png similarity index 100% rename from basis/images/testing/png/suite/z00n2c08.png rename to extra/images/testing/png/suite/z00n2c08.png diff --git a/basis/images/testing/png/suite/z03n2c08.png b/extra/images/testing/png/suite/z03n2c08.png similarity index 100% rename from basis/images/testing/png/suite/z03n2c08.png rename to extra/images/testing/png/suite/z03n2c08.png diff --git a/basis/images/testing/png/suite/z06n2c08.png b/extra/images/testing/png/suite/z06n2c08.png similarity index 100% rename from basis/images/testing/png/suite/z06n2c08.png rename to extra/images/testing/png/suite/z06n2c08.png diff --git a/basis/images/testing/png/suite/z09n2c08.png b/extra/images/testing/png/suite/z09n2c08.png similarity index 100% rename from basis/images/testing/png/suite/z09n2c08.png rename to extra/images/testing/png/suite/z09n2c08.png diff --git a/basis/images/testing/png/z00n2c08.fig b/extra/images/testing/png/z00n2c08.fig similarity index 100% rename from basis/images/testing/png/z00n2c08.fig rename to extra/images/testing/png/z00n2c08.fig diff --git a/basis/images/testing/png/z00n2c08.png b/extra/images/testing/png/z00n2c08.png similarity index 100% rename from basis/images/testing/png/z00n2c08.png rename to extra/images/testing/png/z00n2c08.png diff --git a/basis/images/testing/png/z03n2c08.fig b/extra/images/testing/png/z03n2c08.fig similarity index 100% rename from basis/images/testing/png/z03n2c08.fig rename to extra/images/testing/png/z03n2c08.fig diff --git a/basis/images/testing/png/z03n2c08.png b/extra/images/testing/png/z03n2c08.png similarity index 100% rename from basis/images/testing/png/z03n2c08.png rename to extra/images/testing/png/z03n2c08.png diff --git a/basis/images/testing/png/z06n2c08.fig b/extra/images/testing/png/z06n2c08.fig similarity index 100% rename from basis/images/testing/png/z06n2c08.fig rename to extra/images/testing/png/z06n2c08.fig diff --git a/basis/images/testing/png/z06n2c08.png b/extra/images/testing/png/z06n2c08.png similarity index 100% rename from basis/images/testing/png/z06n2c08.png rename to extra/images/testing/png/z06n2c08.png diff --git a/basis/images/testing/png/z09n2c08.fig b/extra/images/testing/png/z09n2c08.fig similarity index 100% rename from basis/images/testing/png/z09n2c08.fig rename to extra/images/testing/png/z09n2c08.fig diff --git a/basis/images/testing/png/z09n2c08.png b/extra/images/testing/png/z09n2c08.png similarity index 100% rename from basis/images/testing/png/z09n2c08.png rename to extra/images/testing/png/z09n2c08.png diff --git a/basis/images/testing/testing-docs.factor b/extra/images/testing/testing-docs.factor similarity index 100% rename from basis/images/testing/testing-docs.factor rename to extra/images/testing/testing-docs.factor diff --git a/basis/images/testing/testing.factor b/extra/images/testing/testing.factor similarity index 94% rename from basis/images/testing/testing.factor rename to extra/images/testing/testing.factor index 538f098df5..a6644ed710 100644 --- a/basis/images/testing/testing.factor +++ b/extra/images/testing/testing.factor @@ -3,13 +3,13 @@ USING: fry images.loader images.normalization images.viewer io io.directories io.encodings.binary io.files io.pathnames io.streams.byte-array kernel locals namespaces quotations -sequences serialize tools.test ; +sequences serialize tools.test io.backend ; IN: images.testing myarr [infix myarr[4/2]*3 infix] ] ." "9" } "Please note: in Factor " { $emphasis "fixnums are sequences too." } " If you are not careful with sequence accesses you may introduce subtle bugs:" diff --git a/extra/infix/infix-tests.factor b/extra/infix/infix-tests.factor index 5e3d5d67cb..c2b0d9d7b4 100644 --- a/extra/infix/infix-tests.factor +++ b/extra/infix/infix-tests.factor @@ -13,17 +13,6 @@ IN: infix.tests -5* 0 infix] ] unit-test -[ 452.16 ] [ [infix| r [ 12 ] pi [ 3.14 ] | - r*r*pi infix] ] unit-test -[ 0 ] [ [infix| a [ 3 ] | 0 infix] ] unit-test -[ 4/5 ] [ [infix| x [ 3 ] f [ 12 ] | f/(f+x) infix] ] unit-test -[ 144 ] [ [infix| a [ 0 ] b [ 12 ] | b*b-a infix] ] unit-test - -[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | a[0] infix] ] unit-test -[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | 3*a[0]*2*a[1] infix] ] unit-test -[ 6 ] [ [infix| a [ { 0 1 2 3 } ] | a[0]+a[10%3]+a[3-1]+a[18/6] infix] ] unit-test -[ -1 ] [ [infix| a [ { 0 1 2 3 } ] | -a[+1] infix] ] unit-test - [ 0.0 ] [ [infix sin(0) infix] ] unit-test [ 10 ] [ [infix lcm(2,5) infix] ] unit-test [ 1.0 ] [ [infix +cos(-0*+3) infix] ] unit-test @@ -42,4 +31,4 @@ IN: infix.tests [ t ] [ 5 \ stupid_function check-word ] unit-test [ 10 ] [ [infix stupid_function (0, 1, 2, 3, 4) infix] ] unit-test -[ -1 ] [ [let | a [ 1 ] | [infix -a infix] ] ] unit-test +[ -1 ] [ [let 1 :> a [infix -a infix] ] ] unit-test diff --git a/extra/infix/infix.factor b/extra/infix/infix.factor index ce19780058..48ac35264b 100644 --- a/extra/infix/infix.factor +++ b/extra/infix/infix.factor @@ -82,15 +82,4 @@ M: ast-function infix-codegen PRIVATE> SYNTAX: [infix - "infix]" [infix-parse parsed \ call parsed ; - - - -SYNTAX: [infix| - "|" parse-bindings "infix]" parse-infix-locals - ?rewrite-closures over push-all ; + "infix]" [infix-parse suffix! \ call suffix! ; diff --git a/extra/io/serial/windows/windows.factor b/extra/io/serial/windows/windows.factor index 551fd16b33..645e4939de 100755 --- a/extra/io/serial/windows/windows.factor +++ b/extra/io/serial/windows/windows.factor @@ -11,8 +11,7 @@ IN: io.serial.windows : get-comm-state ( duplex -- dcb ) in>> handle>> - DCB tuck - GetCommState win32-error=0/f ; + DCB [ GetCommState win32-error=0/f ] keep ; : set-comm-state ( duplex dcb -- ) [ in>> handle>> ] dip diff --git a/extra/irc/client/chats/chats.factor b/extra/irc/client/chats/chats.factor index 3f6cf4945d..8a87c1a613 100644 --- a/extra/irc/client/chats/chats.factor +++ b/extra/irc/client/chats/chats.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. -USING: accessors concurrency.mailboxes kernel calendar io.sockets io.encodings.8-bit -destructors arrays sequences ; +USING: accessors concurrency.mailboxes kernel calendar io.sockets +destructors arrays sequences io.encodings.8-bit.latin1 ; IN: irc.client.chats CONSTANT: irc-port 6667 ! Default irc port diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor index ef1695f563..f2030e87b0 100644 --- a/extra/irc/client/internals/internals.factor +++ b/extra/irc/client/internals/internals.factor @@ -26,7 +26,7 @@ IN: irc.client.internals irc> [ connect>> ] [ reconnect-attempts>> ] bi do-connect ; : /JOIN ( channel password -- ) - [ " :" swap 3append ] when* "JOIN " prepend irc-print ; + [ " :" glue ] when* "JOIN " prepend irc-print ; : try-connect ( -- stream/f ) irc> profile>> [ server>> ] [ port>> ] bi /CONNECT ; diff --git a/extra/irc/gitbot/gitbot.factor b/extra/irc/gitbot/gitbot.factor index 161a81d555..0963765482 100644 --- a/extra/irc/gitbot/gitbot.factor +++ b/extra/irc/gitbot/gitbot.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry irc.client irc.client.chats kernel namespaces -sequences threads io.encodings.8-bit io.launcher io splitting -make mason.common mason.updates calendar math alarms ; +sequences threads io.launcher io splitting +make mason.common mason.updates calendar math alarms +io.encodings.8-bit.latin1 ; IN: irc.gitbot : bot-profile ( -- obj ) diff --git a/extra/irc/logbot/logbot.factor b/extra/irc/logbot/logbot.factor index 976a3832f4..0bc4d71707 100644 --- a/extra/irc/logbot/logbot.factor +++ b/extra/irc/logbot/logbot.factor @@ -3,7 +3,7 @@ USING: accessors calendar calendar.format destructors fry io io.encodings.8-bit io.files io.pathnames irc.client irc.client.chats irc.messages irc.messages.base kernel make namespaces sequences threads -irc.logbot.log-line ; +irc.logbot.log-line io.encodings.8-bit.latin1 ; IN: irc.logbot CONSTANT: bot-channel "#concatenative" diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index 60e9e39d9f..48bf2b693a 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/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 specialized-arrays ; +opengl.demo-support sequences specialized-arrays locals ; FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: jamshred.gl @@ -50,8 +50,9 @@ CONSTANT: wall-drawing-offset 0.15 over color>> gl-color segment-vertex-and-normal gl-normal gl-vertex ; -: draw-vertex-pair ( theta next-segment segment -- ) - rot tuck draw-segment-vertex draw-segment-vertex ; +:: draw-vertex-pair ( theta next-segment segment -- ) + segment theta draw-segment-vertex + next-segment theta draw-segment-vertex ; : draw-segment ( next-segment segment -- ) GL_QUAD_STRIP [ diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index ae72bd847c..b1644ef443 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -53,13 +53,13 @@ C: oint : scalar-projection ( v1 v2 -- n ) #! the scalar projection of v1 onto v2 - tuck v. swap norm / ; + [ v. ] [ norm ] bi / ; : proj-perp ( u v -- w ) dupd proj v- ; : perpendicular-distance ( oint oint -- distance ) - tuck distance-vector swap 2dup left>> scalar-projection abs + [ distance-vector ] keep 2dup left>> scalar-projection abs -rot up>> scalar-projection abs + ; :: reflect ( v n -- v' ) diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index e4c954d793..6982af63f6 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -31,16 +31,13 @@ CONSTANT: max-speed 30.0 forward-pivot ; : to-tunnel-start ( player -- ) - [ tunnel>> first dup location>> ] - [ tuck (>>location) (>>nearest-segment) ] bi ; + dup tunnel>> first + [ >>nearest-segment ] + [ location>> >>location ] bi drop ; : play-in-tunnel ( player segments -- ) >>tunnel to-tunnel-start ; -: update-nearest-segment ( player -- ) - [ tunnel>> ] [ dup nearest-segment>> nearest-segment ] - [ (>>nearest-segment) ] tri ; - : update-time ( player -- seconds-passed ) millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ; @@ -101,11 +98,12 @@ CONSTANT: max-speed 30.0 ] if ; :: move-player-on-heading ( d-left player distance heading -- d-left' player ) - [let* | d-to-move [ d-left distance min ] - move-v [ d-to-move heading n*v ] | - move-v player location+ - heading player update-nearest-segment2 - d-left d-to-move - player ] ; + d-left distance min :> d-to-move + d-to-move heading n*v :> move-v + + move-v player location+ + heading player update-nearest-segment2 + d-left d-to-move - player ; : distance-to-move-freely ( player -- distance ) [ almost-to-collision ] diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index e2e1c20122..ac696f5444 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -6,19 +6,6 @@ alien.c-types ; SPECIALIZED-ARRAY: float IN: jamshred.tunnel.tests -[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 } - T{ segment f { 1 1 1 } f f f 1 } - T{ oint f { 0 0 0.25 } } - nearer-segment number>> ] unit-test - -[ 0 ] [ T{ oint f { 0 0 0 } } find-nearest-segment number>> ] unit-test -[ 1 ] [ T{ oint f { 0 0 -1 } } find-nearest-segment number>> ] unit-test -[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } find-nearest-segment number>> ] unit-test - -[ 3 ] [ T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test - -[ float-array{ 0 0 0 } ] [ T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test - : test-segment-oint ( -- oint ) { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } ; diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 742f834622..f94fc979ce 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -63,32 +63,6 @@ CONSTANT: default-segment-radius 1 #! valid values [ '[ _ clamp-length ] bi@ ] keep ; -: nearer-segment ( segment segment oint -- segment ) - #! return whichever of the two segments is nearer to the oint - [ 2dup ] dip tuck distance [ distance ] dip < -rot ? ; - -: (find-nearest-segment) ( nearest next oint -- nearest ? ) - #! find the nearest of 'next' and 'nearest' to 'oint', and return - #! t if the nearest hasn't changed - pick [ nearer-segment dup ] dip = ; - -: find-nearest-segment ( oint segments -- segment ) - dup first swap rest-slice rot [ (find-nearest-segment) ] curry - find 2drop ; - -: nearest-segment-forward ( segments oint start -- segment ) - rot dup length swap find-nearest-segment ; - -: nearest-segment-backward ( segments oint start -- segment ) - swapd 1 + 0 spin find-nearest-segment ; - -: nearest-segment ( segments oint start-segment -- segment ) - #! find the segment nearest to 'oint', and return it. - #! start looking at segment 'start-segment' - number>> over [ - [ nearest-segment-forward ] 3keep nearest-segment-backward - ] dip nearer-segment ; - : get-segment ( segments n -- segment ) over clamp-length swap nth ; @@ -107,13 +81,13 @@ CONSTANT: default-segment-radius 1 } case ; :: distance-to-next-segment ( current next location heading -- distance ) - [let | cf [ current forward>> ] | - cf next location>> v. cf location v. - cf heading v. / ] ; + current forward>> :> cf + cf next location>> v. cf location v. - cf heading v. / ; :: distance-to-next-segment-area ( current next location heading -- distance ) - [let | cf [ current forward>> ] - h [ next current half-way-between-oints ] | - cf h v. cf location v. - cf heading v. / ] ; + current forward>> :> cf + next current half-way-between-oints :> h + cf h v. cf location v. - cf heading v. / ; : vector-to-centre ( seg loc -- v ) over location>> swap v- swap forward>> proj-perp ; @@ -138,10 +112,10 @@ CONSTANT: distant 1000 v norm 0 = [ distant ] [ - [let* | a [ v dup v. ] - b [ v w v. 2 * ] - c [ w dup v. r sq - ] | - c b a quadratic max-real ] + v dup v. :> a + v w v. 2 * :> b + w dup v. r sq - :> c + c b a quadratic max-real ] if ; : sideways-heading ( oint segment -- v ) diff --git a/extra/joystick-demo/joystick-demo.factor b/extra/joystick-demo/joystick-demo.factor index 90e28594e7..6ea1dc5633 100755 --- a/extra/joystick-demo/joystick-demo.factor +++ b/extra/joystick-demo/joystick-demo.factor @@ -50,10 +50,10 @@ CONSTANT: pov-polygons [ [ 0.0 ] unless* ] tri@ [ (xy>loc) ] dip (z>loc) ; -: move-axis ( gadget x y z -- ) - (xyz>loc) rot tuck - [ indicator>> (>>loc) ] - [ z-indicator>> (>>loc) ] 2bi* ; +:: move-axis ( gadget x y z -- ) + x y z (xyz>loc) :> ( xy z ) + xy gadget indicator>> (>>loc) + z gadget z-indicator>> (>>loc) ; : move-pov ( gadget pov -- ) swap pov>> [ interior>> -rot = COLOR: gray COLOR: white ? >>color drop ] @@ -82,10 +82,10 @@ TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ; [ >>controller ] [ product-string