diff --git a/Makefile b/Makefile index 80621d8f0a..772f3f9875 100755 --- a/Makefile +++ b/Makefile @@ -47,6 +47,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/data_heap_checker.o \ vm/debug.o \ vm/dispatch.o \ + vm/entry_points.o \ vm/errors.o \ vm/factor.o \ vm/free_list.o \ diff --git a/basis/alien/remote-control/remote-control.factor b/basis/alien/remote-control/remote-control.factor index 6a5644cceb..ae694bed9c 100644 --- a/basis/alien/remote-control/remote-control.factor +++ b/basis/alien/remote-control/remote-control.factor @@ -19,8 +19,8 @@ IN: alien.remote-control dup optimized? [ execute ] [ drop f ] if ; inline : init-remote-control ( -- ) - \ eval-callback ?callback 16 setenv - \ yield-callback ?callback 17 setenv - \ sleep-callback ?callback 18 setenv ; + \ eval-callback ?callback 16 set-special-object + \ yield-callback ?callback 17 set-special-object + \ sleep-callback ?callback 18 set-special-object ; MAIN: init-remote-control diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index eb2c9193a3..1a0648cef8 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -13,7 +13,8 @@ ERROR: malformed-base64 ; read1 2dup swap member? [ drop read1-ignoring ] [ nip ] if ; : read-ignoring ( ignoring n -- str ) - [ drop read1-ignoring ] with map harvest + [ drop read1-ignoring ] with { } map-integers + [ { f 0 } member? not ] filter [ f ] [ >string ] if-empty ; : ch>base64 ( ch -- ch ) @@ -42,7 +43,7 @@ SYMBOL: column [ write1-lines ] each ; : encode3 ( seq -- ) - be> 4 [ + be> 4 iota [ -6 * shift HEX: 3f bitand ch>base64 write1-lines ] with each ; inline diff --git a/basis/binary-search/binary-search-tests.factor b/basis/binary-search/binary-search-tests.factor index f2ea7503f4..a797219a01 100644 --- a/basis/binary-search/binary-search-tests.factor +++ b/basis/binary-search/binary-search-tests.factor @@ -1,4 +1,4 @@ -USING: binary-search math.order vectors kernel tools.test ; +USING: binary-search math.order sequences kernel tools.test ; IN: binary-search.tests [ f ] [ 3 { } [ <=> ] with search drop ] unit-test @@ -7,7 +7,7 @@ IN: binary-search.tests [ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] with search drop ] unit-test [ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test [ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test -[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test +[ 10 ] [ 10 20 iota [ <=> ] with search drop ] unit-test [ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test [ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test diff --git a/basis/bit-arrays/bit-arrays-tests.factor b/basis/bit-arrays/bit-arrays-tests.factor index 7397791ab5..f08db68441 100644 --- a/basis/bit-arrays/bit-arrays-tests.factor +++ b/basis/bit-arrays/bit-arrays-tests.factor @@ -40,7 +40,7 @@ IN: bit-arrays.tests 100 [ drop 100 [ 2 random zero? ] replicate dup >bit-array >array = - ] all? + ] all-integers? ] unit-test [ ?{ f } ] [ diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index f5613da6b5..4fafc528fd 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.data accessors math alien.accessors kernel kernel.private sequences sequences.private byte-arrays @@ -25,7 +25,7 @@ TUPLE: bit-array : (set-bits) ( bit-array n -- ) [ [ length bits>cells ] keep ] dip swap underlying>> - '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline + '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each-integer ; inline : clean-up ( bit-array -- ) ! Zero bits after the end. @@ -99,7 +99,7 @@ SYNTAX: ?{ \ } [ >bit-array ] parse-literal ; ] if ; : bit-array>integer ( bit-array -- n ) - 0 swap underlying>> dup length [ + 0 swap underlying>> dup length iota [ alien-unsigned-1 swap 8 shift bitor ] with each ; diff --git a/basis/bit-vectors/bit-vectors-tests.factor b/basis/bit-vectors/bit-vectors-tests.factor index 5af44b59f7..a8a856ffd0 100644 --- a/basis/bit-vectors/bit-vectors-tests.factor +++ b/basis/bit-vectors/bit-vectors-tests.factor @@ -4,7 +4,7 @@ IN: bit-vectors.tests [ 0 ] [ 123 length ] unit-test : do-it ( seq -- ) - 1234 swap [ [ even? ] dip push ] curry each ; + 1234 swap [ [ even? ] dip push ] curry each-integer ; [ t ] [ 3 dup do-it diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index bf2d14e3aa..90b4c3ae6f 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2009 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.strings arrays byte-arrays generic hashtables hashtables.private io io.binary io.files io.encodings.binary @@ -93,7 +93,7 @@ CONSTANT: image-version 4 CONSTANT: data-base 1024 -CONSTANT: userenv-size 70 +CONSTANT: special-objects-size 70 CONSTANT: header-size 10 @@ -155,7 +155,7 @@ SYMBOL: jit-literals : define-sub-primitive ( quot word -- ) [ make-jit 3array ] dip sub-primitives get set-at ; -: define-sub-primitive* ( quot non-tail-quot tail-quot word -- ) +: define-combinator-primitive ( quot non-tail-quot tail-quot word -- ) [ [ make-jit ] [ make-jit 2nip ] @@ -176,54 +176,58 @@ SYMBOL: architecture RESET ! Boot quotation, set in stage1.factor -USERENV: bootstrap-startup-quot 20 +SPECIAL-OBJECT: bootstrap-startup-quot 20 ! Bootstrap global namesapce -USERENV: bootstrap-global 21 +SPECIAL-OBJECT: bootstrap-global 21 ! JIT parameters -USERENV: jit-prolog 23 -USERENV: jit-primitive-word 24 -USERENV: jit-primitive 25 -USERENV: jit-word-jump 26 -USERENV: jit-word-call 27 -USERENV: jit-if-word 28 -USERENV: jit-if 29 -USERENV: jit-epilog 30 -USERENV: jit-return 31 -USERENV: jit-profiling 32 -USERENV: jit-push 33 -USERENV: jit-dip-word 34 -USERENV: jit-dip 35 -USERENV: jit-2dip-word 36 -USERENV: jit-2dip 37 -USERENV: jit-3dip-word 38 -USERENV: jit-3dip 39 -USERENV: jit-execute 40 -USERENV: jit-declare-word 41 +SPECIAL-OBJECT: jit-prolog 23 +SPECIAL-OBJECT: jit-primitive-word 24 +SPECIAL-OBJECT: jit-primitive 25 +SPECIAL-OBJECT: jit-word-jump 26 +SPECIAL-OBJECT: jit-word-call 27 +SPECIAL-OBJECT: jit-if-word 28 +SPECIAL-OBJECT: jit-if 29 +SPECIAL-OBJECT: jit-epilog 30 +SPECIAL-OBJECT: jit-return 31 +SPECIAL-OBJECT: jit-profiling 32 +SPECIAL-OBJECT: jit-push 33 +SPECIAL-OBJECT: jit-dip-word 34 +SPECIAL-OBJECT: jit-dip 35 +SPECIAL-OBJECT: jit-2dip-word 36 +SPECIAL-OBJECT: jit-2dip 37 +SPECIAL-OBJECT: jit-3dip-word 38 +SPECIAL-OBJECT: jit-3dip 39 +SPECIAL-OBJECT: jit-execute 40 +SPECIAL-OBJECT: jit-declare-word 41 -USERENV: callback-stub 48 +SPECIAL-OBJECT: c-to-factor-word 42 +SPECIAL-OBJECT: lazy-jit-compile-word 43 +SPECIAL-OBJECT: unwind-native-frames-word 44 + +SPECIAL-OBJECT: callback-stub 48 ! PIC stubs -USERENV: pic-load 49 -USERENV: pic-tag 50 -USERENV: pic-tuple 51 -USERENV: pic-check-tag 52 -USERENV: pic-check-tuple 53 -USERENV: pic-hit 54 -USERENV: pic-miss-word 55 -USERENV: pic-miss-tail-word 56 +SPECIAL-OBJECT: pic-load 49 +SPECIAL-OBJECT: pic-tag 50 +SPECIAL-OBJECT: pic-tuple 51 +SPECIAL-OBJECT: pic-check-tag 52 +SPECIAL-OBJECT: pic-check-tuple 53 +SPECIAL-OBJECT: pic-hit 54 +SPECIAL-OBJECT: pic-miss-word 55 +SPECIAL-OBJECT: pic-miss-tail-word 56 ! Megamorphic dispatch -USERENV: mega-lookup 57 -USERENV: mega-lookup-word 58 -USERENV: mega-miss-word 59 +SPECIAL-OBJECT: mega-lookup 57 +SPECIAL-OBJECT: mega-lookup-word 58 +SPECIAL-OBJECT: mega-miss-word 59 ! Default definition for undefined words -USERENV: undefined-quot 60 +SPECIAL-OBJECT: undefined-quot 60 -: userenv-offset ( symbol -- n ) - userenvs get at header-size + ; +: special-object-offset ( symbol -- n ) + special-objects get at header-size + ; : emit ( cell -- ) image get push ; @@ -239,7 +243,7 @@ USERENV: undefined-quot 60 : fixup ( value offset -- ) image get set-nth ; : heap-size ( -- size ) - image get length header-size - userenv-size - + image get length header-size - special-objects-size - bootstrap-cells ; : here ( -- size ) heap-size data-base + ; @@ -278,10 +282,10 @@ GENERIC: ' ( obj -- ptr ) 0 emit ! pointer to bignum 0 0 emit ! pointer to bignum 1 0 emit ! pointer to bignum -1 - userenv-size [ f ' emit ] times ; + special-objects-size [ f ' emit ] times ; -: emit-userenv ( symbol -- ) - [ get ' ] [ userenv-offset ] bi fixup ; +: emit-special-object ( symbol -- ) + [ get ' ] [ special-object-offset ] bi fixup ; ! Bignums @@ -534,15 +538,18 @@ M: quotation ' \ dip jit-dip-word set \ 2dip jit-2dip-word set \ 3dip jit-3dip-word set - \ inline-cache-miss \ pic-miss-word set - \ inline-cache-miss-tail \ pic-miss-tail-word set - \ mega-cache-lookup \ mega-lookup-word set - \ mega-cache-miss \ mega-miss-word set + \ inline-cache-miss pic-miss-word set + \ inline-cache-miss-tail pic-miss-tail-word set + \ mega-cache-lookup mega-lookup-word set + \ mega-cache-miss mega-miss-word set \ declare jit-declare-word set + \ c-to-factor c-to-factor-word set + \ lazy-jit-compile lazy-jit-compile-word set + \ unwind-native-frames unwind-native-frames-word set [ undefined ] undefined-quot set ; -: emit-userenvs ( -- ) - userenvs get keys [ emit-userenv ] each ; +: emit-special-objects ( -- ) + special-objects get keys [ emit-special-object ] each ; : fixup-header ( -- ) heap-size data-heap-size-offset fixup ; @@ -559,8 +566,8 @@ M: quotation ' emit-jit-data "Serializing global namespace..." print flush emit-global - "Serializing user environment..." print flush - emit-userenvs + "Serializing special object table..." print flush + emit-special-objects "Performing word fixups..." print flush fixup-words "Performing header fixups..." print flush diff --git a/basis/bootstrap/image/syntax/syntax.factor b/basis/bootstrap/image/syntax/syntax.factor index 29dc09717a..7025cd61e1 100644 --- a/basis/bootstrap/image/syntax/syntax.factor +++ b/basis/bootstrap/image/syntax/syntax.factor @@ -1,14 +1,14 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser kernel namespaces assocs words.symbol ; IN: bootstrap.image.syntax -SYMBOL: userenvs +SYMBOL: special-objects -SYNTAX: RESET H{ } clone userenvs set-global ; +SYNTAX: RESET H{ } clone special-objects set-global ; -SYNTAX: USERENV: +SYNTAX: SPECIAL-OBJECT: CREATE-WORD scan-word - [ swap userenvs get set-at ] + [ swap special-objects get set-at ] [ drop define-symbol ] 2bi ; \ No newline at end of file diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 25cf35c062..3940af4856 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -554,7 +554,8 @@ M: integer end-of-year 12 31 ; : unix-time>timestamp ( seconds -- timestamp ) seconds unix-1970 time+ ; -M: duration sleep duration>nanoseconds nano-count + sleep-until ; +M: duration sleep + duration>nanoseconds >integer nano-count + sleep-until ; { { [ os unix? ] [ "calendar.unix" ] } diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index d07d74722a..96d76d0ce8 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: math math.order math.parser math.functions kernel sequences io accessors arrays io.streams.string splitting @@ -70,7 +70,7 @@ M: array month. ( pair -- ) [ [ 1 + day. ] keep 1 + + 7 mod zero? [ nl ] [ bl ] if - ] with each nl ; + ] with each-integer nl ; M: timestamp month. ( timestamp -- ) [ year>> ] [ month>> ] bi 2array month. ; @@ -78,7 +78,7 @@ M: timestamp month. ( timestamp -- ) GENERIC: year. ( obj -- ) M: integer year. ( n -- ) - 12 [ 1 + 2array month. nl ] with each ; + 12 [ 1 + 2array month. nl ] with each-integer ; M: timestamp year. ( timestamp -- ) year>> year. ; diff --git a/basis/checksums/sha/sha.factor b/basis/checksums/sha/sha.factor index 35262bb0b0..ba85add03c 100644 --- a/basis/checksums/sha/sha.factor +++ b/basis/checksums/sha/sha.factor @@ -301,7 +301,7 @@ GENERIC: pad-initial-bytes ( string sha2 -- padded-string ) M cloned-H sha2 T1-256 cloned-H T2-256 cloned-H update-H - ] each + ] each-integer sha2 [ cloned-H [ w+ ] 2map ] change-H drop ; inline M: sha2-short checksum-block @@ -391,7 +391,7 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array ) b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe a H nth-unsafe b H set-nth-unsafe a H set-nth-unsafe - ] each + ] each-integer state [ H [ w+ ] 2map ] change-H drop ; inline M:: sha1-state checksum-block ( bytes state -- ) diff --git a/basis/classes/struct/bit-accessors/bit-accessors-tests.factor b/basis/classes/struct/bit-accessors/bit-accessors-tests.factor index e2ff6dbd9c..ecf7b68a2d 100644 --- a/basis/classes/struct/bit-accessors/bit-accessors-tests.factor +++ b/basis/classes/struct/bit-accessors/bit-accessors-tests.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: classes.struct.bit-accessors tools.test effects kernel random stack-checker ; +USING: classes.struct.bit-accessors tools.test effects kernel +sequences random stack-checker ; IN: classes.struct.bit-accessors.test [ t ] [ 20 random 20 random bit-reader infer (( alien -- n )) effect= ] unit-test diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index 83213b47ba..df56ce5c4c 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -49,7 +49,7 @@ TUPLE: objc-error alien reason ; M: objc-error summary ( error -- ) drop "Objective C exception" ; -[ [ objc-error ] 19 setenv ] "cocoa.application" add-startup-hook +[ [ objc-error ] 19 set-special-object ] "cocoa.application" add-startup-hook : running.app? ( -- ? ) #! Test if we're running a .app. diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 4cc9554d3c..02e6335c54 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2009 Slava Pestov. +! Copyright (C) 2006, 2010 Slava Pestov. ! 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 @@ -202,7 +202,7 @@ ERROR: no-objc-type name ; (free) ; : method-arg-types ( method -- args ) - dup method_getNumberOfArguments + dup method_getNumberOfArguments iota [ method-arg-type ] with map ; : method-return-type ( method -- ctype ) diff --git a/basis/columns/columns-tests.factor b/basis/columns/columns-tests.factor index 434c233936..c0e0956709 100644 --- a/basis/columns/columns-tests.factor +++ b/basis/columns/columns-tests.factor @@ -7,3 +7,5 @@ IN: columns.tests [ { 1 4 7 } ] [ "seq" get 0 >array ] unit-test [ ] [ "seq" get 1 [ sq ] map! drop ] unit-test [ { 4 25 64 } ] [ "seq" get 1 >array ] unit-test + +[ { { 1 3 } { 2 4 } } ] [ { { 1 2 } { 3 4 } } [ >array ] map ] unit-test diff --git a/basis/columns/columns.factor b/basis/columns/columns.factor index 8674217655..c36505ab6d 100644 --- a/basis/columns/columns.factor +++ b/basis/columns/columns.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2005, 2010 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: sequences kernel accessors ; IN: columns @@ -15,4 +15,4 @@ M: column length seq>> length ; INSTANCE: column virtual-sequence : ( seq -- seq' ) - dup empty? [ dup first length [ ] with map ] unless ; + dup empty? [ dup first length [ ] with { } map-integers ] unless ; diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index 91987e0dfa..cb1b309c86 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -5,49 +5,49 @@ stack-checker math sequences ; IN: combinators.smart MACRO: drop-outputs ( quot -- quot' ) - dup infer out>> '[ @ _ ndrop ] ; + dup outputs '[ @ _ ndrop ] ; MACRO: keep-inputs ( quot -- quot' ) - dup infer in>> '[ _ _ nkeep ] ; + dup inputs '[ _ _ nkeep ] ; MACRO: output>sequence ( quot exemplar -- newquot ) - [ dup infer out>> ] dip + [ dup outputs ] dip '[ @ _ _ nsequence ] ; MACRO: output>array ( quot -- newquot ) '[ _ { } output>sequence ] ; MACRO: input> ] keep + [ inputs ] keep '[ _ firstn @ ] ; MACRO: input> ] keep + [ inputs ] keep '[ _ firstn-unsafe @ ] ; MACRO: reduce-outputs ( quot operation -- newquot ) - [ dup infer out>> 1 [-] ] dip n*quot compose ; + [ dup outputs 1 [-] ] dip n*quot compose ; MACRO: sum-outputs ( quot -- n ) '[ _ [ + ] reduce-outputs ] ; MACRO: map-reduce-outputs ( quot mapper reducer -- newquot ) - [ dup infer out>> ] 2dip + [ dup outputs ] 2dip [ swap '[ _ _ napply ] ] [ [ 1 [-] ] dip n*quot ] bi-curry* bi '[ @ @ @ ] ; MACRO: append-outputs-as ( quot exemplar -- newquot ) - [ dup infer out>> ] dip '[ @ _ _ nappend-as ] ; + [ dup outputs ] dip '[ @ _ _ nappend-as ] ; MACRO: append-outputs ( quot -- seq ) '[ _ { } append-outputs-as ] ; MACRO: preserving ( quot -- ) - [ infer in>> length ] keep '[ _ ndup @ ] ; + [ inputs ] keep '[ _ ndup @ ] ; MACRO: nullary ( quot -- quot' ) - dup infer out>> length '[ @ _ ndrop ] ; + dup outputs '[ @ _ ndrop ] ; MACRO: smart-if ( pred true false -- ) '[ _ preserving _ _ if ] ; inline diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor index f1748d3708..939fb82f00 100644 --- a/basis/command-line/command-line.factor +++ b/basis/command-line/command-line.factor @@ -8,7 +8,8 @@ IN: command-line SYMBOL: script SYMBOL: command-line -: (command-line) ( -- args ) 10 getenv sift [ alien>native-string ] map ; +: (command-line) ( -- args ) + 10 special-object sift [ alien>native-string ] map ; : rc-path ( name -- path ) os windows? [ "." prepend ] unless diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor index 6f45a51f55..670e34e5f9 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces accessors math.order assocs kernel sequences combinators make classes words cpu.architecture layouts @@ -17,6 +17,7 @@ GENERIC: compute-stack-frame* ( insn -- ) UNION: stack-frame-insn ##alien-invoke ##alien-indirect + ##alien-assembly ##alien-callback ; M: stack-frame-insn compute-stack-frame* diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index e67b8e3737..529c3b5ae6 100644 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -236,6 +236,9 @@ M: #alien-invoke emit-node M: #alien-indirect emit-node [ ##alien-indirect ] emit-alien-node ; +M: #alien-assembly emit-node + [ ##alien-assembly ] emit-alien-node ; + M: #alien-callback emit-node dup params>> xt>> dup [ diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 20008ea85e..68a8b8ce59 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -671,6 +671,9 @@ literal: params stack-frame ; INSN: ##alien-indirect literal: params stack-frame ; +INSN: ##alien-assembly +literal: params stack-frame ; + INSN: ##alien-callback literal: params stack-frame ; diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor index bca5e1ee64..cd76652d06 100644 --- a/basis/compiler/cfg/instructions/syntax/syntax.factor +++ b/basis/compiler/cfg/instructions/syntax/syntax.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes.tuple classes.tuple.parser kernel words make fry sequences parser accessors effects namespaces @@ -61,14 +61,14 @@ TUPLE: insn-slot-spec type name rep ; "pure-insn" "compiler.cfg.instructions" lookup ; : insn-effect ( word -- effect ) - boa-effect in>> but-last f ; + boa-effect in>> but-last { } ; : define-insn-tuple ( class superclass specs -- ) [ name>> ] map "insn#" suffix define-tuple-class ; : define-insn-ctor ( class specs -- ) [ dup '[ _ ] [ f ] [ boa , ] surround ] dip - [ name>> ] map f define-declared ; + [ name>> ] map { } define-declared ; : define-insn ( class superclass specs -- ) parse-insn-slot-specs { diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 9804244ecb..31a8a898bc 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.order sequences accessors arrays byte-arrays layouts classes.tuple.private fry locals @@ -34,7 +34,7 @@ IN: compiler.cfg.intrinsics.allot [ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm ; :: store-initial-element ( len reg elt class -- ) - len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each ; + len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each-integer ; : expand-? ( obj -- ? ) dup integer? [ 0 8 between? ] [ drop f ] if ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index e8c93899cb..d753a4c1b4 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -30,7 +30,7 @@ IN: compiler.cfg.intrinsics { { kernel.private:tag [ drop emit-tag ] } - { kernel.private:getenv [ emit-getenv ] } + { kernel.private:special-object [ emit-special-object ] } { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] } { math.private:both-fixnums? [ drop emit-both-fixnums? ] } { math.private:fixnum+ [ drop emit-fixnum+ ] } diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor index a477ef4b95..fed5492220 100644 --- a/basis/compiler/cfg/intrinsics/misc/misc.factor +++ b/basis/compiler/cfg/intrinsics/misc/misc.factor @@ -9,8 +9,8 @@ IN: compiler.cfg.intrinsics.misc : emit-tag ( -- ) ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ; -: emit-getenv ( node -- ) - "userenv" ^^vm-field-ptr +: emit-special-object ( node -- ) + "special-objects" ^^vm-field-ptr swap node-input-infos first literal>> [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if* ds-push ; diff --git a/basis/compiler/cfg/intrinsics/simd/backend/backend.factor b/basis/compiler/cfg/intrinsics/simd/backend/backend.factor index cf61a560d2..e8b9e3c5de 100644 --- a/basis/compiler/cfg/intrinsics/simd/backend/backend.factor +++ b/basis/compiler/cfg/intrinsics/simd/backend/backend.factor @@ -110,7 +110,7 @@ MACRO: vvvv-vector-op ( trials -- ) blub ; MACRO: can-has-case ( cases -- ) - dup first second infer in>> length 1 + + dup first second inputs 1 + '[ _ ndrop f ] suffix '[ _ case ] ; GENERIC# >can-has-trial 1 ( obj #pick -- quot ) @@ -118,7 +118,7 @@ GENERIC# >can-has-trial 1 ( obj #pick -- quot ) M: callable >can-has-trial drop '[ _ can-has? ] ; M: pair >can-has-trial - swap first2 dup infer in>> length + swap first2 dup inputs '[ _ npick _ instance? [ _ can-has? ] [ _ ndrop blub ] if ] ; MACRO: can-has-vector-op ( trials #pick #dup -- ) diff --git a/basis/compiler/cfg/save-contexts/save-contexts.factor b/basis/compiler/cfg/save-contexts/save-contexts.factor index 4296fb54f9..c7b6db0671 100644 --- a/basis/compiler/cfg/save-contexts/save-contexts.factor +++ b/basis/compiler/cfg/save-contexts/save-contexts.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators.short-circuit compiler.cfg.instructions compiler.cfg.registers @@ -14,6 +14,7 @@ IN: compiler.cfg.save-contexts [ ##binary-float-function? ] [ ##alien-invoke? ] [ ##alien-indirect? ] + [ ##alien-assembly? ] } 1|| ] any? ; diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor index ce673ba5bb..6cf362c230 100644 --- a/basis/compiler/cfg/stacks/stacks.factor +++ b/basis/compiler/cfg/stacks/stacks.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math sequences kernel namespaces accessors biassocs compiler.cfg compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats @@ -33,7 +33,7 @@ IN: compiler.cfg.stacks : ds-load ( n -- vregs ) dup 0 = [ drop f ] - [ [ [ peek-loc ] map ] [ neg inc-d ] bi ] if ; + [ [ iota [ peek-loc ] map ] [ neg inc-d ] bi ] if ; : ds-store ( vregs -- ) [ diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor index 0bed759e52..e5fbfa6c40 100644 --- a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences byte-arrays namespaces accessors classes math math.order fry arrays combinators compiler.cfg.registers @@ -55,7 +55,7 @@ M: insn visit-insn drop ; 2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ; : (uninitialized-locs) ( seq quot -- seq' ) - [ dup length [ drop 0 = ] pusher [ 2each ] dip ] dip map ; inline + [ [ drop 0 = ] pusher [ each-index ] dip ] dip map ; inline PRIVATE> diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index c67048cf0d..ef6794e9fa 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -380,7 +380,7 @@ M: c-type-name flatten-value-type c-type flatten-value-type ; [ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline : prepare-unbox-parameters ( parameters -- offsets types indices ) - [ parameter-offsets nip ] [ ] [ length iota reverse ] tri ; + [ parameter-offsets nip ] [ ] [ length iota ] tri ; : unbox-parameters ( offset node -- ) parameters>> swap @@ -436,6 +436,16 @@ M: ##alien-invoke generate-insn dup %cleanup box-return* ; +M: ##alien-assembly generate-insn + params>> + ! Unbox parameters + dup objects>registers + %prepare-var-args + ! Generate assembly + dup quot>> call( -- ) + ! Box return value + box-return* ; + ! ##alien-indirect M: ##alien-indirect generate-insn params>> @@ -464,7 +474,7 @@ M: ##alien-indirect generate-insn TUPLE: callback-context ; -: current-callback ( -- id ) 2 getenv ; +: current-callback ( -- id ) 2 special-object ; : wait-to-return ( token -- ) dup current-callback eq? [ @@ -475,7 +485,7 @@ TUPLE: callback-context ; : do-callback ( quot token -- ) init-catchstack - [ 2 setenv call ] keep + [ 2 set-special-object call ] keep wait-to-return ; inline : callback-return-quot ( ctype -- quot ) diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index dbe7c864a5..efdc02cc1f 100644 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2007, 2009 Slava Pestov. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays byte-arrays byte-vectors generic assocs hashtables io.binary kernel kernel.private math namespaces make sequences words quotations strings alien.accessors alien.strings layouts system combinators math.bitwise math.order generalizations -accessors growable fry compiler.constants ; +accessors growable fry compiler.constants memoize ; IN: compiler.codegen.fixup ! Owner @@ -52,8 +52,11 @@ SYMBOL: relocation-table : rel-fixup ( class type -- ) swap compiled-offset add-relocation-entry ; +! Caching common symbol names reduces image size a bit +MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ; + : add-dlsym-parameters ( symbol dll -- ) - [ string>symbol add-parameter ] [ add-parameter ] bi* ; + [ cached-string>symbol add-parameter ] [ add-parameter ] bi* ; : rel-dlsym ( name dll class -- ) [ add-dlsym-parameters ] dip rt-dlsym rel-fixup ; diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 83b50b61f4..499a1b192f 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -25,6 +25,13 @@ CONSTANT: deck-bits 18 : 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 +: callstack-length-offset ( -- n ) 1 \ callstack type-number slot-offset ; inline +: callstack-top-offset ( -- n ) 2 \ callstack type-number slot-offset ; inline +: vm-context-offset ( -- n ) 0 bootstrap-cells ; inline +: context-callstack-top-offset ( -- n ) 0 bootstrap-cells ; inline +: context-callstack-bottom-offset ( -- n ) 1 bootstrap-cells ; inline +: context-datastack-offset ( -- n ) 2 bootstrap-cells ; inline +: context-retainstack-offset ( -- n ) 3 bootstrap-cells ; inline ! Relocation classes CONSTANT: rc-absolute-cell 0 diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index e6abab1267..4cfbe8f6fa 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -164,7 +164,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3, { 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 +[ 861 3 ] [ 42 [ ] each-integer 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 @@ -172,7 +172,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3, { 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 +[ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test FUNCTION: longlong ffi_test_21 long x long y ; @@ -316,7 +316,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; : callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ; -[ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test +[ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test [ t ] [ callback-1 alien? ] unit-test @@ -377,9 +377,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; [ f ] [ namespace global eq? ] unit-test : callback-8 ( -- callback ) - void { } "cdecl" [ - [ continue ] callcc0 - ] alien-callback ; + void { } "cdecl" [ [ ] in-thread yield ] alien-callback ; [ ] [ callback-8 callback_test_1 ] unit-test @@ -591,3 +589,8 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ; FUNCTION: void this_does_not_exist ( ) ; [ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with + +! More alien-assembly tests are in cpu.* vocabs +: assembly-test-1 ( -- ) void { } "cdecl" [ ] alien-assembly ; + +[ ] [ assembly-test-1 ] unit-test diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index eba6580574..cff685eaf6 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -116,7 +116,7 @@ unit-test 1 1.0 2.5 try-breaking-dispatch "bye" = [ 3.5 = ] dip and ; [ t ] [ - 10000000 [ drop try-breaking-dispatch-2 ] all? + 10000000 [ drop try-breaking-dispatch-2 ] all-integers? ] unit-test ! Regression @@ -314,7 +314,7 @@ cell 4 = [ ! Bug with ##return node construction : return-recursive-bug ( nodes -- ? ) - { fixnum } declare [ + { fixnum } declare iota [ dup 3 bitand 1 = [ drop t ] [ dup 3 bitand 2 = [ return-recursive-bug diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index 14b347008c..632a560c0d 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -1,5 +1,5 @@ USING: compiler.units compiler kernel kernel.private memory math -math.private tools.test math.floats.private ; +math.private tools.test math.floats.private math.order fry ; IN: compiler.tests.float [ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test @@ -84,11 +84,6 @@ IN: compiler.tests.float [ 315 315.0 ] [ 313 [ 2 fixnum+fast dup fixnum>float ] compile-call ] unit-test -[ 17.5 ] [ -11.3 17.5 [ float-max ] compile-call ] unit-test -[ 17.5 ] [ 17.5 -11.3 [ float-max ] compile-call ] unit-test -[ -11.3 ] [ -11.3 17.5 [ float-min ] compile-call ] unit-test -[ -11.3 ] [ 17.5 -11.3 [ float-min ] compile-call ] unit-test - [ t ] [ 0/0. 0/0. [ float-unordered? ] compile-call ] unit-test [ t ] [ 0/0. 1.0 [ float-unordered? ] compile-call ] unit-test [ t ] [ 1.0 0/0. [ float-unordered? ] compile-call ] unit-test @@ -100,3 +95,23 @@ IN: compiler.tests.float [ 1 ] [ 1.0 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test [ 2 ] [ 3.0 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test [ 2 ] [ 1.0 3.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test + +! Ensure that float-min and min, and float-max and max, have +! consistent behavior with respect to NaNs + +: two-floats ( a b -- a b ) { float float } declare ; inline + +[ -11.3 ] [ -11.3 17.5 [ two-floats min ] compile-call ] unit-test +[ -11.3 ] [ 17.5 -11.3 [ two-floats min ] compile-call ] unit-test +[ 17.5 ] [ -11.3 17.5 [ two-floats max ] compile-call ] unit-test +[ 17.5 ] [ 17.5 -11.3 [ two-floats max ] compile-call ] unit-test + +: check-compiled-binary-op ( a b word -- ) + [ '[ [ [ two-floats _ execute ] compile-call ] call( a b -- c ) ] ] + [ '[ _ execute ] ] + bi 2bi fp-bitwise= ; inline + +[ t ] [ 0/0. 3.0 \ min check-compiled-binary-op ] unit-test +[ t ] [ 3.0 0/0. \ min check-compiled-binary-op ] unit-test +[ t ] [ 0/0. 3.0 \ max check-compiled-binary-op ] unit-test +[ t ] [ 3.0 0/0. \ max check-compiled-binary-op ] unit-test diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 7fe5e2b601..1c066f26a3 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -54,8 +54,8 @@ IN: compiler.tests.intrinsics [ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test [ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test -[ ] [ [ 0 getenv ] compile-call drop ] unit-test -[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test +[ ] [ [ 0 special-object ] compile-call drop ] unit-test +[ ] [ 1 special-object [ 1 set-special-object ] compile-call ] unit-test [ ] [ 1 [ drop ] compile-call ] unit-test [ ] [ [ 1 drop ] compile-call ] unit-test @@ -337,7 +337,7 @@ ERROR: bug-in-fixnum* x y a b ; [ ] [ 10000 [ - 5 random [ drop 32 random-bits ] map product >bignum + 5 random iota [ drop 32 random-bits ] map product >bignum dup [ bignum>fixnum ] keep compiled-bignum>fixnum = [ drop ] [ "Oops" throw ] if ] times diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 0831d6e8dd..865cd639a3 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 shuffle ; +compiler definitions generic.single shuffle math.order ; IN: compiler.tests.optimizer GENERIC: xyz ( obj -- obj ) @@ -90,7 +90,7 @@ TUPLE: pred-test ; : double-label-2 ( a -- b ) dup array? [ ] [ ] if 0 t double-label-1 ; -[ 0 ] [ 10 double-label-2 ] unit-test +[ 0 ] [ 10 iota double-label-2 ] unit-test ! regression GENERIC: void-generic ( obj -- * ) @@ -208,7 +208,7 @@ USE: binary-search.private ] if ; inline recursive [ 10 ] [ - 10 20 >vector + 10 20 iota [ [ - ] swap old-binsearch ] compile-call 2nip ] unit-test @@ -349,7 +349,7 @@ TUPLE: some-tuple x ; [ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test [ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test -[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test +[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 iota [ ] B{ } map-as ] compile-call ] unit-test [ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test @@ -445,5 +445,17 @@ M: object bad-dispatch-position-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 +TUPLE: grid-mesh-tuple { length read-only } { step read-only } ; + +: grid-mesh-test-case ( -- vertices ) + 1.0 1.0 { 2 } first /f [ /i 1 + ] keep grid-mesh-tuple boa + 1 f + [ + [ drop length>> >fixnum 2 min ] 2keep + [ + [ step>> 1 * ] dip + 0 swap set-nth-unsafe + ] 2curry times + ] keep ; + +[ { 0.5 } ] [ grid-mesh-test-case ] unit-test diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index 0b3b46fe33..b3f01c8c01 100644 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -185,9 +185,7 @@ M: #recursive check-stack-flow* M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; -M: #alien-invoke check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; - -M: #alien-indirect check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; +M: #alien-node check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; M: #alien-callback check-stack-flow* drop ; diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index db96086371..05f9092ee1 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -339,28 +339,23 @@ cell-bits 32 = [ ] unit-test [ t ] [ - [ { fixnum } declare length [ drop ] each-integer ] + [ { fixnum } declare iota [ drop ] each ] { < <-integer-fixnum +-integer-fixnum + } inlined? ] unit-test [ t ] [ - [ { fixnum } declare [ drop ] each ] - { < <-integer-fixnum +-integer-fixnum + } inlined? -] unit-test - -[ t ] [ - [ { fixnum } declare 0 [ + ] reduce ] + [ { fixnum } declare iota 0 [ + ] reduce ] { < <-integer-fixnum nth-unsafe } inlined? ] unit-test [ f ] [ - [ { fixnum } declare 0 [ + ] reduce ] + [ { fixnum } declare iota 0 [ + ] reduce ] \ +-integer-fixnum inlined? ] unit-test [ f ] [ [ - { integer } declare [ ] map + { integer } declare iota [ ] map ] \ >fixnum inlined? ] unit-test @@ -403,7 +398,7 @@ cell-bits 32 = [ [ t ] [ [ - { integer } declare [ 0 >= ] map + { integer } declare iota [ 0 >= ] map ] { >= fixnum>= } inlined? ] unit-test diff --git a/basis/compiler/tree/dead-code/branches/branches.factor b/basis/compiler/tree/dead-code/branches/branches.factor index 6cef45a9c9..d1fdf6359a 100644 --- a/basis/compiler/tree/dead-code/branches/branches.factor +++ b/basis/compiler/tree/dead-code/branches/branches.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: sequences namespaces kernel accessors assocs sets fry arrays combinators columns stack-checker.backend @@ -36,7 +36,7 @@ M: #branch remove-dead-code* : drop-indexed-values ( values indices -- node ) [ drop filter-live ] [ swap nths ] 2bi - [ make-values ] keep + [ length make-values ] keep [ drop ] [ zip ] 2bi #data-shuffle ; diff --git a/basis/compiler/tree/dead-code/recursive/recursive.factor b/basis/compiler/tree/dead-code/recursive/recursive.factor index 482d370947..0c9464374a 100644 --- a/basis/compiler/tree/dead-code/recursive/recursive.factor +++ b/basis/compiler/tree/dead-code/recursive/recursive.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs sequences kernel locals fry combinators stack-checker.backend @@ -24,7 +24,7 @@ M: #call-recursive compute-live-values* :: drop-dead-inputs ( inputs outputs -- #shuffle ) inputs filter-live - outputs inputs filter-corresponding make-values + outputs inputs filter-corresponding length make-values outputs inputs drop-values ; @@ -39,7 +39,7 @@ M: #enter-recursive remove-dead-code* 2bi ; :: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle ) - inputs outputs filter-corresponding make-values :> new-live-outputs + inputs outputs filter-corresponding length make-values :> new-live-outputs outputs filter-live :> live-outputs new-live-outputs live-outputs diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor index 67c5cfdc78..77523568d7 100644 --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/basis/compiler/tree/dead-code/simple/simple.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors words assocs sequences arrays namespaces fry locals definitions classes classes.algebra generic @@ -28,9 +28,7 @@ M: method-body flushable? "method-generic" word-prop flushable? ; M: #call mark-live-values* dup flushable-call? [ drop ] [ look-at-inputs ] if ; -M: #alien-invoke mark-live-values* look-at-inputs ; - -M: #alien-indirect mark-live-values* look-at-inputs ; +M: #alien-node mark-live-values* look-at-inputs ; M: #return mark-live-values* look-at-inputs ; @@ -47,9 +45,7 @@ M: #call compute-live-values* nip look-at-inputs ; M: #shuffle compute-live-values* mapping>> at look-at-value ; -M: #alien-invoke compute-live-values* nip look-at-inputs ; - -M: #alien-indirect compute-live-values* nip look-at-inputs ; +M: #alien-node compute-live-values* nip look-at-inputs ; : filter-mapping ( assoc -- assoc' ) live-values get '[ drop _ key? ] assoc-filter ; @@ -71,7 +67,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ; filter-corresponding zip #data-shuffle ; inline :: drop-dead-values ( outputs -- #shuffle ) - outputs make-values :> new-outputs + outputs length make-values :> new-outputs outputs filter-live :> live-outputs new-outputs live-outputs @@ -127,8 +123,5 @@ M: #terminate remove-dead-code* [ filter-live ] change-in-d [ filter-live ] change-in-r ; -M: #alien-invoke remove-dead-code* - maybe-drop-dead-outputs ; - -M: #alien-indirect remove-dead-code* +M: #alien-node remove-dead-code* maybe-drop-dead-outputs ; diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 63f145d752..47ec13e809 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2009 Slava Pestov. +! Copyright (C) 2006, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel assocs match fry accessors namespaces make effects sequences sequences.private quotations generic macros arrays @@ -64,7 +64,7 @@ TUPLE: shuffle-node { effect effect } ; M: shuffle-node pprint* effect>> effect>string text ; : (shuffle-effect) ( in out #shuffle -- effect ) - mapping>> '[ _ at ] map ; + mapping>> '[ _ at ] map [ >array ] bi@ ; : shuffle-effect ( #shuffle -- effect ) [ in-d>> ] [ out-d>> ] [ ] tri (shuffle-effect) ; @@ -126,6 +126,8 @@ M: #alien-invoke node>quot params>> , \ #alien-invoke , ; M: #alien-indirect node>quot params>> , \ #alien-indirect , ; +M: #alien-assembly node>quot params>> , \ #alien-assembly , ; + M: #alien-callback node>quot params>> , \ #alien-callback , ; M: node node>quot drop ; diff --git a/basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor b/basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor index c26f3ddefc..bb32e6e23b 100644 --- a/basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor +++ b/basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor @@ -1,4 +1,4 @@ -USING: kernel tools.test namespaces sequences +USING: kernel tools.test namespaces sequences math compiler.tree.escape-analysis.recursive compiler.tree.escape-analysis.allocations ; IN: compiler.tree.escape-analysis.recursive.tests @@ -6,7 +6,7 @@ IN: compiler.tree.escape-analysis.recursive.tests H{ } clone allocations set escaping-values set -[ ] [ 8 [ introduce-value ] each ] unit-test +[ ] [ 8 [ introduce-value ] each-integer ] unit-test [ ] [ { 1 2 } 3 record-allocation ] unit-test diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor index c053b15f29..50fa7ef0a8 100644 --- a/basis/compiler/tree/escape-analysis/simple/simple.factor +++ b/basis/compiler/tree/escape-analysis/simple/simple.factor @@ -86,12 +86,7 @@ M: #call escape-analysis* M: #return escape-analysis* in-d>> add-escaping-values ; -M: #alien-invoke escape-analysis* - [ in-d>> add-escaping-values ] - [ out-d>> unknown-allocations ] - bi ; - -M: #alien-indirect escape-analysis* +M: #alien-node escape-analysis* [ in-d>> add-escaping-values ] [ out-d>> unknown-allocations ] bi ; diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor index 42e7f421bf..7366a83ee1 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -73,7 +73,7 @@ TUPLE: declared-fixnum { x fixnum } ; [ t ] [ [ - { fixnum } declare 0 swap + { fixnum } declare iota 0 swap [ drop 615949 * 797807 + 20 2^ rem dup 19 2^ - ] map @@ -94,7 +94,7 @@ TUPLE: declared-fixnum { x fixnum } ; [ t ] [ [ - { integer } declare [ 256 mod ] map + { integer } declare iota [ 256 mod ] map ] { mod fixnum-mod } inlined? ] unit-test diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index fcfa42c70b..7912fce1f6 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/basis/compiler/tree/normalization/normalization.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry namespaces sequences math math.order accessors kernel arrays combinators assocs @@ -75,10 +75,9 @@ M: #phi normalize* ] with-variable ; M: #recursive normalize* - dup label>> introductions>> - [ drop [ child>> first ] [ in-d>> ] bi >>in-d drop ] - [ make-values '[ _ (normalize) ] change-child ] - 2bi ; + [ [ child>> first ] [ in-d>> ] bi >>in-d drop ] + [ dup label>> introductions>> make-values '[ _ (normalize) ] change-child ] + bi ; M: #enter-recursive normalize* [ introduction-stack get prepend ] change-out-d diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor index ff4886d1c7..439b428784 100644 --- a/basis/compiler/tree/propagation/call-effect/call-effect.factor +++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2009, 2010 Slava Pestov, Daniel Ehrenberg. ! 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 combinators.short-circuit +USING: accessors arrays combinators combinators.private effects +fry kernel kernel.private make sequences continuations +quotations 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 @@ -43,7 +43,7 @@ M: +unknown+ curry-effect ; M: effect curry-effect [ in>> length ] [ out>> length ] [ terminated?>> ] tri pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if - effect boa ; + [ [ "x" ] bi@ ] dip effect boa ; M: curry cached-effect quot>> cached-effect curry-effect ; diff --git a/basis/compiler/tree/propagation/info/info-tests.factor b/basis/compiler/tree/propagation/info/info-tests.factor index 826131ab61..446aad89e5 100644 --- a/basis/compiler/tree/propagation/info/info-tests.factor +++ b/basis/compiler/tree/propagation/info/info-tests.factor @@ -4,13 +4,6 @@ IN: compiler.tree.propagation.info.tests [ f ] [ 0.0 -0.0 eql? ] unit-test -[ t ] [ - number - sequence - value-info-intersect - class>> integer class= -] unit-test - [ t t ] [ 0 10 [a,b] 5 20 [a,b] diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 0fde7ffa86..6aacbc57da 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel effects accessors math math.private math.integers.private math.floats.private math.partial-dispatch @@ -23,11 +23,10 @@ IN: compiler.tree.propagation.known-words { + - * / } [ { number number } "input-classes" set-word-prop ] each -{ /f < > <= >= u< u> u<= u>= } +{ /f /i mod < > <= >= u< u> u<= u>= } [ { real real } "input-classes" set-word-prop ] each -{ /i mod /mod } -[ { rational rational } "input-classes" set-word-prop ] each +\ /mod { rational rational } "input-classes" set-word-prop { bitand bitor bitxor bitnot shift } [ { integer integer } "input-classes" set-word-prop ] each diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index c7e02aef4c..2c80b87e76 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -1,14 +1,13 @@ USING: kernel compiler.tree.builder compiler.tree compiler.tree.propagation compiler.tree.recursive -compiler.tree.normalization tools.test math math.order -accessors sequences arrays kernel.private vectors -alien.accessors alien.c-types sequences.private -byte-arrays classes.algebra classes.tuple.private -math.functions math.private strings layouts -compiler.tree.propagation.info compiler.tree.def-use -compiler.tree.debugger compiler.tree.checker -slots.private words hashtables classes assocs locals -specialized-arrays system sorting math.libm +compiler.tree.normalization tools.test math math.order accessors +sequences arrays kernel.private vectors alien.accessors +alien.c-types sequences.private byte-arrays classes.algebra +classes.tuple.private math.functions math.private strings +layouts compiler.tree.propagation.info compiler.tree.def-use +compiler.tree.debugger compiler.tree.checker slots.private words +hashtables classes assocs locals specialized-arrays system +sorting math.libm math.floats.private math.integers.private math.intervals quotations effects alien alien.data ; FROM: math => float ; SPECIALIZED-ARRAY: double @@ -91,6 +90,8 @@ IN: compiler.tree.propagation.tests [ float ] [ [ { float float } declare mod ] final-math-class ] unit-test +[ V{ integer float } ] [ [ { float float } declare [ /i ] keep ] final-classes ] unit-test + [ V{ fixnum } ] [ [ 255 bitand ] final-classes ] unit-test [ V{ fixnum } ] [ @@ -405,14 +406,6 @@ IN: compiler.tree.propagation.tests ] final-literals ] unit-test -[ V{ 27 } ] [ - [ - dup number? over sequence? and [ - dup 10 < over 8 <= not and [ 3 * ] [ "A" throw ] if - ] [ "B" throw ] if - ] final-literals -] unit-test - [ V{ string string } ] [ [ 2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop @@ -680,7 +673,7 @@ M: array iterate first t ; inline ] unit-test [ V{ fixnum } ] [ - [ { fixnum fixnum } declare [ nth-unsafe ] curry call ] final-classes + [ { fixnum fixnum } declare iota [ nth-unsafe ] curry call ] final-classes ] unit-test [ V{ f } ] [ @@ -942,3 +935,14 @@ M: tuple-with-read-only-slot clone ! Could be bignum not integer but who cares [ V{ integer } ] [ [ 10 >bignum bitand ] final-classes ] unit-test +[ t ] [ [ { fixnum fixnum } declare min ] { min } inlined? ] unit-test +[ f ] [ [ { fixnum fixnum } declare min ] { fixnum-min } inlined? ] unit-test + +[ t ] [ [ { float float } declare min ] { min } inlined? ] unit-test +[ f ] [ [ { float float } declare min ] { float-min } inlined? ] unit-test + +[ t ] [ [ { fixnum fixnum } declare max ] { max } inlined? ] unit-test +[ f ] [ [ { fixnum fixnum } declare max ] { fixnum-max } inlined? ] unit-test + +[ t ] [ [ { float float } declare max ] { max } inlined? ] unit-test +[ f ] [ [ { float float } declare max ] { float-max } inlined? ] unit-test diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index b4d8b95247..225f10d342 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -80,7 +80,7 @@ M: #declare propagate-before : (fold-call) ( #call word -- info ) [ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi* '[ _ _ with-datastack [ ] map nip ] - [ drop [ object-info ] replicate ] + [ drop length [ object-info ] replicate ] recover ; : fold-call ( #call word -- ) @@ -153,8 +153,6 @@ M: #call propagate-after [ out-d>> ] [ params>> return>> ] bi [ drop ] [ c-type-class swap first set-value-info ] if-void ; -M: #alien-invoke propagate-before propagate-alien-invoke ; - -M: #alien-indirect propagate-before propagate-alien-invoke ; +M: #alien-node propagate-before propagate-alien-invoke ; M: #return annotate-node dup in-d>> (annotate-node) ; diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 809b51c6ef..63c0aea13e 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types kernel sequences words fry generic accessors classes.tuple classes classes.algebra definitions @@ -132,26 +132,6 @@ IN: compiler.tree.propagation.transforms ] "custom-inlining" set-word-prop ] each -! Integrate this with generic arithmetic optimization instead? -: both-inputs? ( #call class -- ? ) - [ in-d>> first2 ] dip '[ value-info class>> _ class<= ] both? ; - -\ min [ - { - { [ dup fixnum both-inputs? ] [ [ fixnum-min ] ] } - { [ dup float both-inputs? ] [ [ float-min ] ] } - [ f ] - } cond nip -] "custom-inlining" set-word-prop - -\ max [ - { - { [ dup fixnum both-inputs? ] [ [ fixnum-max ] ] } - { [ dup float both-inputs? ] [ [ float-max ] ] } - [ f ] - } cond nip -] "custom-inlining" set-word-prop - ! Generate more efficient code for common idiom \ clone [ in-d>> first value-info literal>> { @@ -209,7 +189,7 @@ ERROR: bad-partial-eval quot word ; \ index [ dup sequence? [ dup length 4 >= [ - dup length zip >hashtable '[ _ at ] + dup length iota zip >hashtable '[ _ at ] ] [ drop f ] if ] [ drop f ] if ] 1 define-partial-eval @@ -248,7 +228,7 @@ CONSTANT: lookup-table-at-max 256 } 1&& ; : lookup-table-seq ( assoc -- table ) - [ keys supremum 1 + ] keep '[ _ at ] { } map-as ; + [ keys supremum 1 + iota ] keep '[ _ at ] { } map-as ; : lookup-table-quot ( seq -- newquot ) lookup-table-seq diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor index 82b8fbb843..a1d1b4db61 100644 --- a/basis/compiler/tree/tree.factor +++ b/basis/compiler/tree/tree.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry arrays generic assocs kernel math namespaces parser sequences words vectors math.intervals classes @@ -149,7 +149,12 @@ TUPLE: #alien-indirect < #alien-node in-d out-d ; : #alien-indirect ( params -- node ) \ #alien-indirect new-alien-node ; -TUPLE: #alien-callback < #alien-node ; +TUPLE: #alien-assembly < #alien-node in-d out-d ; + +: #alien-assembly ( params -- node ) + \ #alien-assembly new-alien-node ; + +TUPLE: #alien-callback < node params ; : #alien-callback ( params -- node ) \ #alien-callback new @@ -187,4 +192,5 @@ M: vector #recursive, #recursive node, ; M: vector #copy, #copy node, ; M: vector #alien-invoke, #alien-invoke node, ; M: vector #alien-indirect, #alien-indirect node, ; +M: vector #alien-assembly, #alien-assembly node, ; M: vector #alien-callback, #alien-callback node, ; diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index de2848ea78..d4ca3010ce 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -164,9 +164,7 @@ M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ; M: #return unbox-tuples* dup in-d>> assert-not-unboxed ; -M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ; - -M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ; +M: #alien-node unbox-tuples* dup in-d>> assert-not-unboxed ; M: #alien-callback unbox-tuples* ; diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor index 567c435c2e..d96946d53d 100644 --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -36,7 +36,7 @@ CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 } 5 bitstream bs:read 1 + 4 bitstream bs:read 4 + clen-shuffle swap head - dup length iota [ 3 bitstream bs:read ] replicate + dup length [ 3 bitstream bs:read ] replicate get-table bitstream swap [ 2dup + ] dip swap :> k! @@ -64,13 +64,13 @@ CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 } MEMO: static-huffman-tables ( -- obj ) [ - 0 143 [a,b] [ 8 ] replicate - 144 255 [a,b] [ 9 ] replicate append - 256 279 [a,b] [ 7 ] replicate append - 280 287 [a,b] [ 8 ] replicate append + 0 143 [a,b] length [ 8 ] replicate + 144 255 [a,b] length [ 9 ] replicate append + 256 279 [a,b] length [ 7 ] replicate append + 280 287 [a,b] length [ 8 ] replicate append ] append-outputs - 0 31 [a,b] [ 5 ] replicate 2array - [ [ length>> [0,b) ] [ ] bi get-table ] map ; + 0 31 [a,b] length [ 5 ] replicate 2array + [ [ length>> iota ] [ ] bi get-table ] map ; CONSTANT: length-table { diff --git a/basis/compression/zlib/zlib-tests.factor b/basis/compression/zlib/zlib-tests.factor index 1baeba73d9..b9bc502d46 100644 --- a/basis/compression/zlib/zlib-tests.factor +++ b/basis/compression/zlib/zlib-tests.factor @@ -1,9 +1,12 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel tools.test compression.zlib classes ; +USING: accessors kernel tools.test compression.zlib classes ; +QUALIFIED-WITH: compression.zlib.ffi ffi IN: compression.zlib.tests : compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ; [ t ] [ compress-me [ compress uncompress ] keep = ] unit-test [ t ] [ compress-me compress compressed instance? ] unit-test + +[ ffi:Z_DATA_ERROR zlib-error-message ] [ string>> "data error" = ] must-fail-with diff --git a/basis/compression/zlib/zlib.factor b/basis/compression/zlib/zlib.factor index 7818173498..c662eec049 100644 --- a/basis/compression/zlib/zlib.factor +++ b/basis/compression/zlib/zlib.factor @@ -19,7 +19,9 @@ ERROR: zlib-failed n string ; dup compression.zlib.ffi:Z_ERRNO = [ drop errno "native libc error" ] [ - dup { + dup + neg ! zlib error codes are negative + { "no error" "libc_error" "stream error" "data error" "memory error" "buffer error" "zlib version error" diff --git a/basis/concurrency/combinators/combinators-tests.factor b/basis/concurrency/combinators/combinators-tests.factor index d3f3229171..f33f6513a9 100644 --- a/basis/concurrency/combinators/combinators-tests.factor +++ b/basis/concurrency/combinators/combinators-tests.factor @@ -17,12 +17,12 @@ IN: concurrency.combinators.tests [ error>> "Even" = ] must-fail-with [ V{ 0 3 6 9 } ] -[ 10 [ 3 mod zero? ] parallel-filter ] unit-test +[ 10 iota [ 3 mod zero? ] parallel-filter ] unit-test [ 10 ] [ V{ } clone - 10 over [ push ] curry parallel-each + 10 iota over [ push ] curry parallel-each length ] unit-test @@ -41,7 +41,7 @@ IN: concurrency.combinators.tests [ 20 ] [ V{ } clone - 10 10 pick [ [ push ] [ push ] bi ] curry 2parallel-each + 10 iota 10 iota pick [ [ push ] [ push ] bi ] curry 2parallel-each length ] unit-test diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 5127b56acf..03090dc4b5 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -550,7 +550,7 @@ HOOK: %save-param-reg cpu ( stack reg rep -- ) HOOK: %load-param-reg cpu ( stack reg rep -- ) -HOOK: %load-context cpu ( temp1 temp2 -- ) +HOOK: %restore-context cpu ( temp1 temp2 -- ) HOOK: %save-context cpu ( temp1 temp2 -- ) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index a5267b898b..e3c212bd48 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2007, 2009 Slava Pestov. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel kernel.private namespaces system cpu.ppc.assembler compiler.codegen.fixup compiler.units -compiler.constants math math.private layouts words vocabs -slots.private locals locals.backend generic.single.private fry ; +compiler.constants math math.private math.ranges layouts words vocabs +slots.private locals locals.backend generic.single.private fry +sequences ; FROM: cpu.ppc.assembler => B ; IN: bootstrap.ppc @@ -13,28 +14,88 @@ big-endian on CONSTANT: ds-reg 13 CONSTANT: rs-reg 14 CONSTANT: vm-reg 15 +CONSTANT: ctx-reg 16 -: factor-area-size ( -- n ) 4 bootstrap-cells ; +: factor-area-size ( -- n ) 16 ; : stack-frame ( -- n ) - factor-area-size c-area-size + 4 bootstrap-cells align ; + reserved-size + factor-area-size + + 16 align ; -: next-save ( -- n ) stack-frame bootstrap-cell - ; -: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ; +: next-save ( -- n ) stack-frame 4 - ; +: xt-save ( -- n ) stack-frame 8 - ; + +: param-size ( -- n ) 32 ; + +: save-at ( m -- n ) reserved-size + param-size + ; + +: save-int ( register offset -- ) [ 1 ] dip save-at STW ; +: restore-int ( register offset -- ) [ 1 ] dip save-at LWZ ; + +: save-fp ( register offset -- ) [ 1 ] dip save-at STFD ; +: restore-fp ( register offset -- ) [ 1 ] dip save-at LFD ; + +: save-vec ( register offset -- ) save-at 2 LI 2 1 STVXL ; +: restore-vec ( register offset -- ) save-at 2 LI 2 1 LVXL ; + +: nv-int-regs ( -- seq ) 13 31 [a,b] ; +: nv-fp-regs ( -- seq ) 14 31 [a,b] ; +: nv-vec-regs ( -- seq ) 20 31 [a,b] ; + +: saved-int-regs-size ( -- n ) 96 ; +: saved-fp-regs-size ( -- n ) 144 ; +: saved-vec-regs-size ( -- n ) 208 ; + +: callback-frame-size ( -- n ) + reserved-size + param-size + + saved-int-regs-size + + saved-fp-regs-size + + saved-vec-regs-size + + 16 align ; + +[ + 0 MFLR + 1 1 callback-frame-size neg STWU + 0 1 callback-frame-size lr-save + STW + + nv-int-regs [ 4 * save-int ] each-index + nv-fp-regs [ 8 * 80 + save-fp ] each-index + nv-vec-regs [ 16 * 224 + save-vec ] each-index + + 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel + + 0 2 LOAD32 rc-absolute-ppc-2/2 rt-xt jit-rel + 2 MTLR + BLRL + + nv-vec-regs [ 16 * 224 + restore-vec ] each-index + nv-fp-regs [ 8 * 80 + restore-fp ] each-index + nv-int-regs [ 4 * restore-int ] each-index + + 0 1 callback-frame-size lr-save + LWZ + 1 1 0 LWZ + 0 MTLR + BLR +] callback-stub jit-define : jit-conditional* ( test-quot false-quot -- ) - [ '[ bootstrap-cell /i 1 + @ ] ] dip jit-conditional ; inline + [ '[ 4 /i 1 + @ ] ] dip jit-conditional ; inline + +: jit-load-context ( -- ) + ctx-reg vm-reg vm-context-offset LWZ ; : jit-save-context ( -- ) - 4 vm-reg 0 LWZ - 1 4 0 STW - ds-reg 4 8 STW - rs-reg 4 12 STW ; + jit-load-context + 1 ctx-reg context-callstack-top-offset STW + ds-reg ctx-reg context-datastack-offset STW + rs-reg ctx-reg context-retainstack-offset STW ; : jit-restore-context ( -- ) - 4 vm-reg 0 LWZ - ds-reg 4 8 LWZ - rs-reg 4 12 LWZ ; + jit-load-context + ds-reg ctx-reg context-datastack-offset LWZ + rs-reg ctx-reg context-retainstack-offset LWZ ; [ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel @@ -48,12 +109,12 @@ CONSTANT: vm-reg 15 ] jit-profiling jit-define [ - 0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel + 0 2 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel 0 MFLR 1 1 stack-frame SUBI - 3 1 xt-save STW - stack-frame 3 LI - 3 1 next-save STW + 2 1 xt-save STW + stack-frame 2 LI + 2 1 next-save STW 0 1 lr-save stack-frame + STW ] jit-prolog jit-define @@ -181,7 +242,7 @@ CONSTANT: vm-reg 15 load-tag 0 4 tuple type-number tag-fixnum CMPI [ BNE ] - [ 4 3 tuple type-number neg bootstrap-cell + LWZ ] + [ 4 3 tuple type-number neg 4 + LWZ ] jit-conditional* ] pic-tuple jit-define @@ -215,12 +276,12 @@ CONSTANT: vm-reg 15 [ jit-load-return-address jit-inline-cache-miss ] [ 3 MTLR BLRL ] [ 3 MTCTR BCTR ] -\ inline-cache-miss define-sub-primitive* +\ inline-cache-miss define-combinator-primitive [ jit-inline-cache-miss ] [ 3 MTLR BLRL ] [ 3 MTCTR BCTR ] -\ inline-cache-miss-tail define-sub-primitive* +\ inline-cache-miss-tail define-combinator-primitive ! ! ! Megamorphic caches @@ -230,7 +291,7 @@ CONSTANT: vm-reg 15 ! key = hashcode(class) 5 4 1 SRAWI ! key &= cache.length - 1 - 5 5 mega-cache-size get 1 - bootstrap-cell * ANDI + 5 5 mega-cache-size get 1 - 4 * ANDI ! cache += array-start-offset 3 3 array-start-offset ADDI ! cache += key @@ -245,7 +306,7 @@ CONSTANT: vm-reg 15 5 4 0 LWZ 5 5 1 ADDI 5 4 0 STW - ! ... goto get(cache + bootstrap-cell) + ! ... goto get(cache + 4) 3 3 4 LWZ 3 3 word-xt-offset LWZ 3 MTCTR @@ -255,23 +316,16 @@ CONSTANT: vm-reg 15 ! fall-through on miss ] mega-lookup jit-define -[ - 0 2 LOAD32 rc-absolute-ppc-2/2 rt-xt jit-rel - 2 MTCTR - BCTR -] callback-stub jit-define - ! ! ! Sub-primitives ! Quotations and words [ 3 ds-reg 0 LWZ ds-reg dup 4 SUBI - 4 vm-reg MR 5 3 quot-xt-offset LWZ ] [ 5 MTLR BLRL ] -[ 5 MTCTR BCTR ] \ (call) define-sub-primitive* +[ 5 MTCTR BCTR ] \ (call) define-combinator-primitive [ 3 ds-reg 0 LWZ @@ -279,7 +333,7 @@ CONSTANT: vm-reg 15 4 3 word-xt-offset LWZ ] [ 4 MTLR BLRL ] -[ 4 MTCTR BCTR ] \ (execute) define-sub-primitive* +[ 4 MTCTR BCTR ] \ (execute) define-combinator-primitive [ 3 ds-reg 0 LWZ @@ -288,6 +342,79 @@ CONSTANT: vm-reg 15 4 MTCTR BCTR ] jit-execute jit-define +! Special primitives +[ + jit-restore-context + ! Save ctx->callstack_bottom + 1 ctx-reg context-callstack-bottom-offset STW + ! Call quotation + 5 3 quot-xt-offset LWZ + 5 MTLR + BLRL + jit-save-context +] \ c-to-factor define-sub-primitive + +[ + ! Unwind stack frames + 1 4 MR + + ! Load VM pointer into vm-reg, since we're entering from + ! C code + 0 vm-reg LOAD32 0 rc-absolute-ppc-2/2 jit-vm + + ! Load ds and rs registers + jit-restore-context + + ! We have changed the stack; load return address again + 0 1 lr-save LWZ + 0 MTLR + + ! Call quotation + 4 3 quot-xt-offset LWZ + 4 MTCTR + BCTR +] \ unwind-native-frames define-sub-primitive + +[ + ! Load callstack object + 6 ds-reg 0 LWZ + ds-reg ds-reg 4 SUBI + ! Get ctx->callstack_bottom + jit-load-context + 3 ctx-reg context-callstack-bottom-offset LWZ + ! Get top of callstack object -- 'src' for memcpy + 4 6 callstack-top-offset ADDI + ! Get callstack length, in bytes --- 'len' for memcpy + 5 6 callstack-length-offset LWZ + 5 5 tag-bits get SRAWI + ! Compute new stack pointer -- 'dst' for memcpy + 3 5 3 SUBF + ! Install new stack pointer + 1 3 MR + ! Call memcpy; arguments are now in the correct registers + 1 1 -64 STWU + 0 2 LOAD32 "factor_memcpy" f rc-absolute-ppc-2/2 jit-dlsym + 2 MTLR + BLRL + 1 1 0 LWZ + ! Return with new callstack + 0 1 lr-save LWZ + 0 MTLR + BLR +] \ set-callstack define-sub-primitive + +[ + jit-save-context + 4 vm-reg MR + 0 2 LOAD32 "lazy_jit_compile" f rc-absolute-ppc-2/2 jit-dlsym + 2 MTLR + BLRL + 5 3 quot-xt-offset LWZ +] +[ 5 MTLR BLRL ] +[ 5 MTCTR BCTR ] +\ lazy-jit-compile define-combinator-primitive + ! Objects [ 3 ds-reg 0 LWZ diff --git a/basis/cpu/ppc/linux/bootstrap.factor b/basis/cpu/ppc/linux/bootstrap.factor index a5250414ab..2f463dea00 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. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser layouts system kernel sequences ; +USING: parser system kernel sequences ; IN: bootstrap.ppc -: c-area-size ( -- n ) 10 bootstrap-cells ; -: lr-save ( -- n ) bootstrap-cell ; +: reserved-size ( -- n ) 24 ; +: lr-save ( -- n ) 4 ; << "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 2aa0ddc4a2..0960011c70 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. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser layouts system kernel sequences ; +USING: parser system kernel sequences ; IN: bootstrap.ppc -: c-area-size ( -- n ) 14 bootstrap-cells ; -: lr-save ( -- n ) 2 bootstrap-cells ; +: reserved-size ( -- n ) 24 ; +: lr-save ( -- n ) 8 ; << "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >> call diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index d641ed7039..4842327973 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -83,8 +83,8 @@ HOOK: reserved-area-size os ( -- n ) ! The start of the stack frame contains the size of this frame ! as well as the currently executing XT : factor-area-size ( -- n ) 2 cells ; foldable -: next-save ( n -- i ) cell - ; -: xt-save ( n -- i ) 2 cells - ; +: next-save ( n -- i ) cell - ; foldable +: xt-save ( n -- i ) 2 cells - ; foldable ! Next, we have the spill area as well as the FFI parameter area. ! It is safe for them to overlap, since basic blocks with FFI calls @@ -126,7 +126,7 @@ M: ppc stack-frame-size ( stack-frame -- i ) M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ; M: ppc %jump ( word -- ) - 0 6 LOAD32 8 rc-absolute-ppc-2/2 rel-here + 0 6 LOAD32 4 rc-absolute-ppc-2/2 rel-here 0 B rc-relative-ppc-3 rel-word-pic-tail ; M: ppc %jump-label ( label -- ) B ; @@ -134,7 +134,7 @@ M: ppc %return ( -- ) BLR ; M:: ppc %dispatch ( src temp -- ) 0 temp LOAD32 - 4 cells rc-absolute-ppc-2/2 rel-here + 3 cells rc-absolute-ppc-2/2 rel-here temp temp src LWZX temp MTCTR BCTR ; @@ -564,14 +564,16 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- ) { stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] } } case ; -: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ; +: next-param@ ( n -- reg x ) + 2 1 stack-frame get total-size>> LWZ + [ 2 ] dip param@ ; : store-to-frame ( src n rep -- ) { { int-rep [ [ 1 ] dip STW ] } { float-rep [ [ 1 ] dip STFS ] } { double-rep [ [ 1 ] dip STFD ] } - { stack-params [ [ [ 0 1 ] dip next-param@ LWZ 0 1 ] dip STW ] } + { stack-params [ [ [ 0 ] dip next-param@ LWZ 0 1 ] dip STW ] } } case ; M: ppc %spill ( src rep dst -- ) @@ -679,10 +681,15 @@ M: ppc %box-large-struct ( n c-type -- ) ! Call the function "from_value_struct" f %alien-invoke ; +M:: ppc %restore-context ( temp1 temp2 -- ) + temp1 "ctx" %load-vm-field-addr + temp1 temp1 0 LWZ + temp2 1 stack-frame get total-size>> ADDI + temp2 temp1 "callstack-bottom" context-field-offset STW + ds-reg temp1 8 LWZ + rs-reg temp1 12 LWZ ; + M:: ppc %save-context ( temp1 temp2 -- ) - #! Save Factor stack pointers in case the C code calls a - #! callback which does a GC, which must reliably trace - #! all roots. temp1 "ctx" %load-vm-field-addr temp1 temp1 0 LWZ 1 temp1 0 STW @@ -693,13 +700,18 @@ M: ppc %alien-invoke ( symbol dll -- ) [ 11 ] 2dip %alien-global 11 MTLR BLRL ; M: ppc %alien-callback ( quot -- ) + 3 4 %restore-context 3 swap %load-reference - 4 %load-vm-addr - "c_to_factor" f %alien-invoke ; + 4 3 quot-xt-offset LWZ + 4 MTLR + BLRL + 3 4 %save-context ; M: ppc %prepare-alien-indirect ( -- ) - 3 %load-vm-addr - "from_alien" f %alien-invoke + 3 ds-reg 0 LWZ + ds-reg ds-reg 4 SUBI + 4 %load-vm-addr + "pinned_alien_offset" f %alien-invoke 16 3 MR ; M: ppc %alien-indirect ( -- ) @@ -753,9 +765,7 @@ M: ppc %box-small-struct ( c-type -- ) 3 3 0 LWZ ; M: ppc %nest-stacks ( -- ) - ! Save current frame. See comment in vm/contexts.hpp - 3 1 stack-frame get total-size>> 2 cells - ADDI - 4 %load-vm-addr + 3 %load-vm-addr "nest_stacks" f %alien-invoke ; M: ppc %unnest-stacks ( -- ) @@ -763,7 +773,6 @@ M: ppc %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ; M: ppc %unbox-small-struct ( size -- ) - #! Alien must be in EAX. heap-size cell align cell /i { { 1 [ %unbox-struct-1 ] } { 2 [ %unbox-struct-2 ] } diff --git a/basis/cpu/x86/32/32-tests.factor b/basis/cpu/x86/32/32-tests.factor new file mode 100644 index 0000000000..bc07e3a25b --- /dev/null +++ b/basis/cpu/x86/32/32-tests.factor @@ -0,0 +1,7 @@ +IN: cpu.x86.32.tests +USING: alien alien.c-types tools.test cpu.x86.assembler +cpu.x86.assembler.operands ; + +: assembly-test-1 ( -- x ) int { } "cdecl" [ EAX 3 MOV ] alien-assembly ; + +[ 3 ] [ assembly-test-1 ] unit-test diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 8b44b65809..0f98170d66 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -8,7 +8,8 @@ compiler.codegen compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 -cpu.architecture ; +cpu.architecture vm ; +FROM: layouts => cell ; IN: cpu.x86.32 M: x86.32 machine-registers @@ -23,6 +24,12 @@ M: x86.32 stack-reg ESP ; M: x86.32 frame-reg EBP ; M: x86.32 temp-reg ECX ; +M: x86.32 %mov-vm-ptr ( reg -- ) + 0 MOV 0 rc-absolute-cell rel-vm ; + +M: x86.32 %vm-field-ptr ( dst field -- ) + [ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ; + : local@ ( n -- op ) stack-frame get extra-stack-space dup 16 assert= + stack@ ; @@ -235,9 +242,8 @@ M: x86.32 %alien-indirect ( -- ) EBP CALL ; M: x86.32 %alien-callback ( quot -- ) - EAX EDX %load-context + EAX EDX %restore-context EAX swap %load-reference - EDX %mov-vm-ptr EAX quot-xt-offset [+] CALL EAX EDX %save-context ; diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 580db11946..bcab5a54ee 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2009 Slava Pestov. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel kernel.private namespaces system cpu.x86.assembler cpu.x86.assembler.operands layouts @@ -19,6 +19,8 @@ IN: bootstrap.x86 : safe-reg ( -- reg ) EAX ; : stack-reg ( -- reg ) ESP ; : frame-reg ( -- reg ) EBP ; +: vm-reg ( -- reg ) ECX ; +: ctx-reg ( -- reg ) EBP ; : nv-regs ( -- seq ) { ESI EDI EBX } ; : ds-reg ( -- reg ) ESI ; : rs-reg ( -- reg ) EDI ; @@ -35,49 +37,122 @@ IN: bootstrap.x86 ] jit-prolog jit-define : jit-load-vm ( -- ) - EBP 0 MOV 0 rc-absolute-cell jit-vm ; + vm-reg 0 MOV 0 rc-absolute-cell jit-vm ; + +: jit-load-context ( -- ) + ! VM pointer must be in vm-reg already + ctx-reg vm-reg vm-context-offset [+] MOV ; : jit-save-context ( -- ) - ! VM pointer must be in EBP already - ECX EBP [] MOV - ! save ctx->callstack_top - EAX ESP -4 [+] LEA - ECX [] EAX MOV - ! save ctx->datastack - ECX 8 [+] ds-reg MOV - ! save ctx->retainstack - ECX 12 [+] rs-reg MOV ; + EDX RSP -4 [+] LEA + ctx-reg context-callstack-top-offset [+] EDX MOV + ctx-reg context-datastack-offset [+] ds-reg MOV + ctx-reg context-retainstack-offset [+] rs-reg MOV ; : jit-restore-context ( -- ) - ! VM pointer must be in EBP already - ECX EBP [] MOV - ! restore ctx->datastack - ds-reg ECX 8 [+] MOV - ! restore ctx->retainstack - rs-reg ECX 12 [+] MOV ; + ds-reg ctx-reg context-datastack-offset [+] MOV + rs-reg ctx-reg context-retainstack-offset [+] MOV ; [ jit-load-vm - ! save ds, rs registers + jit-load-context jit-save-context ! call the primitive - ESP [] EBP MOV + ESP [] vm-reg MOV 0 CALL rc-relative rt-primitive jit-rel ! restore ds, rs registers jit-restore-context ] jit-primitive jit-define [ - ! load from stack + ! Load quotation + EAX EBP 8 [+] MOV + ! save ctx->callstack_bottom, load ds, rs registers + jit-load-vm + jit-load-context + jit-restore-context + EDX stack-reg stack-frame-size 4 - [+] LEA + ctx-reg context-callstack-bottom-offset [+] EDX MOV + ! call the quotation + EAX quot-xt-offset [+] CALL + ! save ds, rs registers + jit-save-context +] \ c-to-factor define-sub-primitive + +[ EAX ds-reg [] MOV - ! pop stack ds-reg bootstrap-cell SUB - ! load VM pointer - EDX 0 MOV 0 rc-absolute-cell jit-vm ] [ EAX quot-xt-offset [+] CALL ] [ EAX quot-xt-offset [+] JMP ] -\ (call) define-sub-primitive* +\ (call) define-combinator-primitive + +[ + ! Clear x87 stack, but preserve rounding mode and exception flags + ESP 2 SUB + ESP [] FNSTCW + FNINIT + ESP [] FLDCW + ESP 2 ADD + + ! Load arguments + EAX ESP stack-frame-size [+] MOV + EDX ESP stack-frame-size 4 + [+] MOV + + ! Unwind stack frames + ESP EDX MOV + + ! Load ds and rs registers + jit-load-vm + jit-load-context + jit-restore-context + + ! Call quotation + EAX quot-xt-offset [+] JMP +] \ unwind-native-frames define-sub-primitive + +[ + ! Load callstack object + EBX ds-reg [] MOV + ds-reg bootstrap-cell SUB + ! Get ctx->callstack_bottom + jit-load-vm + jit-load-context + EAX ctx-reg context-callstack-bottom-offset [+] MOV + ! Get top of callstack object -- 'src' for memcpy + EBP EBX callstack-top-offset [+] LEA + ! Get callstack length, in bytes --- 'len' for memcpy + EDX EBX callstack-length-offset [+] MOV + EDX tag-bits get SHR + ! Compute new stack pointer -- 'dst' for memcpy + EAX EDX SUB + ! Install new stack pointer + ESP EAX MOV + ! Call memcpy + EDX PUSH + EBP PUSH + EAX PUSH + 0 CALL "factor_memcpy" f rc-relative jit-dlsym + ESP 12 ADD + ! Return with new callstack + 0 RET +] \ set-callstack define-sub-primitive + +[ + jit-load-vm + jit-load-context + jit-save-context + + ! Store arguments + ESP [] EAX MOV + ESP 4 [+] vm-reg MOV + + ! Call VM + 0 CALL "lazy_jit_compile" f rc-relative jit-dlsym +] +[ EAX quot-xt-offset [+] CALL ] +[ EAX quot-xt-offset [+] JMP ] +\ lazy-jit-compile define-combinator-primitive ! Inline cache miss entry points : jit-load-return-address ( -- ) @@ -87,8 +162,9 @@ IN: bootstrap.x86 ! frame, and the stack. The frame setup takes this into account. : jit-inline-cache-miss ( -- ) jit-load-vm + jit-load-context jit-save-context - ESP 4 [+] EBP MOV + ESP 4 [+] vm-reg MOV ESP [] EBX MOV 0 CALL "inline_cache_miss" f rc-relative jit-dlsym jit-restore-context ; @@ -96,28 +172,29 @@ IN: bootstrap.x86 [ jit-load-return-address jit-inline-cache-miss ] [ EAX CALL ] [ EAX JMP ] -\ inline-cache-miss define-sub-primitive* +\ inline-cache-miss define-combinator-primitive [ jit-inline-cache-miss ] [ EAX CALL ] [ EAX JMP ] -\ inline-cache-miss-tail define-sub-primitive* +\ inline-cache-miss-tail define-combinator-primitive ! Overflowing fixnum arithmetic : jit-overflow ( insn func -- ) ds-reg 4 SUB jit-load-vm + jit-load-context jit-save-context EAX ds-reg [] MOV EDX ds-reg 4 [+] MOV - ECX EAX MOV - [ [ ECX EDX ] dip call( dst src -- ) ] dip - ds-reg [] ECX MOV + EBX EAX MOV + [ [ EBX EDX ] dip call( dst src -- ) ] dip + ds-reg [] EBX MOV [ JNO ] [ ESP [] EAX MOV ESP 4 [+] EDX MOV - ESP 8 [+] EBP MOV + ESP 8 [+] vm-reg MOV [ 0 CALL ] dip f rc-relative jit-dlsym ] jit-conditional ; @@ -129,19 +206,20 @@ IN: bootstrap.x86 [ ds-reg 4 SUB jit-load-vm + jit-load-context jit-save-context - ECX ds-reg [] MOV - EAX ECX MOV - EBX ds-reg 4 [+] MOV - EBX tag-bits get SAR - EBX IMUL + EBX ds-reg [] MOV + EAX EBX MOV + EBP ds-reg 4 [+] MOV + EBP tag-bits get SAR + EBP IMUL ds-reg [] EAX MOV [ JNO ] [ - ECX tag-bits get SAR - ESP [] ECX MOV - ESP 4 [+] EBX MOV - ESP 8 [+] EBP MOV + EBX tag-bits get SAR + ESP [] EBX MOV + ESP 4 [+] EBP MOV + ESP 8 [+] vm-reg MOV 0 CALL "overflow_fixnum_multiply" f rc-relative jit-dlsym ] jit-conditional diff --git a/basis/cpu/x86/64/64-tests.factor b/basis/cpu/x86/64/64-tests.factor new file mode 100644 index 0000000000..6d171af7ea --- /dev/null +++ b/basis/cpu/x86/64/64-tests.factor @@ -0,0 +1,15 @@ +USING: alien alien.c-types cpu.architecture cpu.x86.64 +cpu.x86.assembler cpu.x86.assembler.operands tools.test ; +IN: cpu.x86.64.tests + +: assembly-test-1 ( -- x ) int { } "cdecl" [ RAX 3 MOV ] alien-assembly ; + +[ 3 ] [ assembly-test-1 ] unit-test + +: assembly-test-2 ( a b -- x ) + int { int int } "cdecl" [ + param-reg-0 param-reg-1 ADD + int-regs return-reg param-reg-0 MOV + ] alien-assembly ; + +[ 23 ] [ 17 6 assembly-test-2 ] unit-test diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 5fc6ae8c16..676c96ce50 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -7,7 +7,8 @@ compiler.codegen compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 -cpu.architecture ; +cpu.architecture vm ; +FROM: layouts => cell cells ; IN: cpu.x86.64 : param-reg-0 ( -- reg ) 0 int-regs param-reg ; inline @@ -29,13 +30,21 @@ M: x86.64 extra-stack-space drop 0 ; M: x86.64 machine-registers { - { int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } } + { int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 } } { float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 } } } ; +: vm-reg ( -- reg ) R13 ; inline + +M: x86.64 %mov-vm-ptr ( reg -- ) + vm-reg MOV ; + +M: x86.64 %vm-field-ptr ( dst field -- ) + [ vm-reg ] dip vm-field-offset [+] LEA ; + : param@ ( n -- op ) reserved-stack-space + stack@ ; M: x86.64 %prologue ( n -- ) @@ -223,9 +232,8 @@ M: x86.64 %alien-indirect ( -- ) RBP CALL ; M: x86.64 %alien-callback ( quot -- ) - param-reg-0 param-reg-1 %load-context + param-reg-0 param-reg-1 %restore-context param-reg-0 swap %load-reference - param-reg-1 %mov-vm-ptr param-reg-0 quot-xt-offset [+] CALL param-reg-0 param-reg-1 %save-context ; diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index a1bdcbd1ff..74943a94bb 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2009 Slava Pestov. +! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel kernel.private namespaces system layouts vocabs parser compiler.constants math @@ -15,9 +15,12 @@ IN: bootstrap.x86 : temp1 ( -- reg ) RSI ; : temp2 ( -- reg ) RDX ; : temp3 ( -- reg ) RBX ; +: return-reg ( -- reg ) RAX ; : safe-reg ( -- reg ) RAX ; : stack-reg ( -- reg ) RSP ; : frame-reg ( -- reg ) RBP ; +: ctx-reg ( -- reg ) R12 ; +: vm-reg ( -- reg ) R13 ; : ds-reg ( -- reg ) R14 ; : rs-reg ( -- reg ) R15 ; : fixnum>slot@ ( -- ) temp0 1 SAR ; @@ -25,60 +28,114 @@ IN: bootstrap.x86 [ ! load XT - RDI 0 MOV rc-absolute-cell rt-this jit-rel + safe-reg 0 MOV rc-absolute-cell rt-this jit-rel ! save stack frame size stack-frame-size PUSH ! push XT - RDI PUSH + safe-reg PUSH ! alignment RSP stack-frame-size 3 bootstrap-cells - SUB ] jit-prolog jit-define -: jit-load-vm ( -- ) - RBP 0 MOV 0 rc-absolute-cell jit-vm ; +: jit-load-context ( -- ) + ctx-reg vm-reg vm-context-offset [+] MOV ; : jit-save-context ( -- ) - ! VM pointer must be in RBP already - RCX RBP [] MOV - ! save ctx->callstack_top - RAX RSP -8 [+] LEA - RCX [] RAX MOV - ! save ctx->datastack - RCX 16 [+] ds-reg MOV - ! save ctx->retainstack - RCX 24 [+] rs-reg MOV ; + jit-load-context + safe-reg RSP -8 [+] LEA + ctx-reg context-callstack-top-offset [+] safe-reg MOV + ctx-reg context-datastack-offset [+] ds-reg MOV + ctx-reg context-retainstack-offset [+] rs-reg MOV ; : jit-restore-context ( -- ) - ! VM pointer must be in EBP already - RCX RBP [] MOV - ! restore ctx->datastack - ds-reg RCX 16 [+] MOV - ! restore ctx->retainstack - rs-reg RCX 24 [+] MOV ; + jit-load-context + ds-reg ctx-reg context-datastack-offset [+] MOV + rs-reg ctx-reg context-retainstack-offset [+] MOV ; [ - jit-load-vm - ! save ds, rs registers jit-save-context ! call the primitive - arg1 RBP MOV + arg1 vm-reg MOV RAX 0 MOV rc-absolute-cell rt-primitive jit-rel RAX CALL - ! restore ds, rs registers jit-restore-context ] jit-primitive jit-define [ - ! load from stack + jit-restore-context + ! save ctx->callstack_bottom + safe-reg stack-reg stack-frame-size 8 - [+] LEA + ctx-reg context-callstack-bottom-offset [+] safe-reg MOV + ! call the quotation + arg1 quot-xt-offset [+] CALL + jit-save-context +] \ c-to-factor define-sub-primitive + +[ arg1 ds-reg [] MOV - ! pop stack ds-reg bootstrap-cell SUB - ! load VM pointer - arg2 0 MOV 0 rc-absolute-cell jit-vm ] [ arg1 quot-xt-offset [+] CALL ] [ arg1 quot-xt-offset [+] JMP ] -\ (call) define-sub-primitive* +\ (call) define-combinator-primitive + +[ + ! Clear x87 stack, but preserve rounding mode and exception flags + RSP 2 SUB + RSP [] FNSTCW + FNINIT + RSP [] FLDCW + + ! Unwind stack frames + RSP arg2 MOV + + ! Load VM pointer into vm-reg, since we're entering from + ! C code + vm-reg 0 MOV 0 rc-absolute-cell jit-vm + + ! Load ds and rs registers + jit-restore-context + + ! Call quotation + arg1 quot-xt-offset [+] JMP +] \ unwind-native-frames define-sub-primitive + +[ + ! Load callstack object + arg4 ds-reg [] MOV + ds-reg bootstrap-cell SUB + ! Get ctx->callstack_bottom + jit-load-context + arg1 ctx-reg context-callstack-bottom-offset [+] MOV + ! Get top of callstack object -- 'src' for memcpy + arg2 arg4 callstack-top-offset [+] LEA + ! Get callstack length, in bytes --- 'len' for memcpy + arg3 arg4 callstack-length-offset [+] MOV + arg3 tag-bits get SHR + ! Compute new stack pointer -- 'dst' for memcpy + arg1 arg3 SUB + ! Install new stack pointer + RSP arg1 MOV + ! Call memcpy; arguments are now in the correct registers + ! Create register shadow area for Win64 + RSP 32 SUB + safe-reg 0 MOV "factor_memcpy" f rc-absolute-cell jit-dlsym + safe-reg CALL + ! Tear down register shadow area + RSP 32 ADD + ! Return with new callstack + 0 RET +] \ set-callstack define-sub-primitive + +[ + jit-save-context + arg2 vm-reg MOV + safe-reg 0 MOV "lazy_jit_compile" f rc-absolute-cell jit-dlsym + safe-reg CALL +] +[ return-reg quot-xt-offset [+] CALL ] +[ return-reg quot-xt-offset [+] JMP ] +\ lazy-jit-compile define-combinator-primitive ! Inline cache miss entry points : jit-load-return-address ( -- ) @@ -87,10 +144,9 @@ IN: bootstrap.x86 ! These are always in tail position with an existing stack ! frame, and the stack. The frame setup takes this into account. : jit-inline-cache-miss ( -- ) - jit-load-vm jit-save-context arg1 RBX MOV - arg2 RBP MOV + arg2 vm-reg MOV RAX 0 MOV "inline_cache_miss" f rc-absolute-cell jit-dlsym RAX CALL jit-restore-context ; @@ -98,17 +154,16 @@ IN: bootstrap.x86 [ jit-load-return-address jit-inline-cache-miss ] [ RAX CALL ] [ RAX JMP ] -\ inline-cache-miss define-sub-primitive* +\ inline-cache-miss define-combinator-primitive [ jit-inline-cache-miss ] [ RAX CALL ] [ RAX JMP ] -\ inline-cache-miss-tail define-sub-primitive* +\ inline-cache-miss-tail define-combinator-primitive ! Overflowing fixnum arithmetic : jit-overflow ( insn func -- ) ds-reg 8 SUB - jit-load-vm jit-save-context arg1 ds-reg [] MOV arg2 ds-reg 8 [+] MOV @@ -117,7 +172,7 @@ IN: bootstrap.x86 ds-reg [] arg3 MOV [ JNO ] [ - arg3 RBP MOV + arg3 vm-reg MOV RAX 0 MOV f rc-absolute-cell jit-dlsym RAX CALL ] @@ -129,7 +184,6 @@ IN: bootstrap.x86 [ ds-reg 8 SUB - jit-load-vm jit-save-context RCX ds-reg [] MOV RBX ds-reg 8 [+] MOV @@ -142,7 +196,7 @@ IN: bootstrap.x86 arg1 RCX MOV arg1 tag-bits get SAR arg2 RBX MOV - arg3 RBP MOV + arg3 vm-reg MOV RAX 0 MOV "overflow_fixnum_multiply" f rc-absolute-cell jit-dlsym RAX CALL ] diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 57738ce4ba..b075b121a5 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -375,6 +375,7 @@ PRIVATE> : NOP ( -- ) HEX: 90 , ; : PAUSE ( -- ) HEX: f3 , HEX: 90 , ; +: RDTSC ( -- ) HEX: 0f , HEX: 31 , ; : RDPMC ( -- ) HEX: 0f , HEX: 33 , ; ! x87 Floating Point Unit @@ -385,6 +386,13 @@ PRIVATE> : FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ; : FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ; +: FNSTCW ( operand -- ) { BIN: 111 f HEX: d9 } 1-operand ; +: FNSTSW ( operand -- ) { BIN: 111 f HEX: dd } 1-operand ; +: FLDCW ( operand -- ) { BIN: 101 f HEX: d9 } 1-operand ; + +: FNCLEX ( -- ) HEX: db , HEX: e2 , ; +: FNINIT ( -- ) HEX: db , HEX: e3 , ; + ! SSE multimedia instructions MEMO: sse-version ( -- n ) - sse_version - "sse-version" get string>number [ min ] when* ; + (sse-version) "sse-version" get string>number [ min ] when* ; [ \ sse-version reset-memoized ] "cpu.x86.features" add-startup-hook @@ -39,7 +96,18 @@ MEMO: sse-version ( -- n ) HOOK: instruction-count cpu ( -- n ) -M: x86 instruction-count read_timestamp_counter ; +M: x86.32 instruction-count + longlong { } "cdecl" [ + RDTSC + ] alien-assembly ; + +M: x86.64 instruction-count + longlong { } "cdecl" [ + RAX 0 MOV + RDTSC + RDX 32 SHL + RAX RDX OR + ] alien-assembly ; : count-instructions ( quot -- n ) - instruction-count [ call ] dip instruction-count swap - ; inline + instruction-count [ call instruction-count ] dip - ; inline diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 69a0f39945..f2751b1be2 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2009 Slava Pestov. +! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs alien alien.c-types arrays strings cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands @@ -419,11 +419,7 @@ M: x86 %shl int-rep two-operand [ SHL ] emit-shift ; M: x86 %shr int-rep two-operand [ SHR ] emit-shift ; M: x86 %sar int-rep two-operand [ SAR ] emit-shift ; -: %mov-vm-ptr ( reg -- ) - 0 MOV 0 rc-absolute-cell rel-vm ; - -M: x86 %vm-field-ptr ( dst field -- ) - [ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ; +HOOK: %mov-vm-ptr cpu ( reg -- ) : load-allot-ptr ( nursery-ptr allot-ptr -- ) [ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ; @@ -1410,18 +1406,15 @@ M:: x86 %reload ( dst rep src -- ) dst src rep %copy ; M: x86 %loop-entry 16 code-alignment [ NOP ] times ; -M:: x86 %load-context ( temp1 temp2 -- ) +M:: x86 %restore-context ( temp1 temp2 -- ) #! Load Factor stack pointers on entry from C to Factor. #! Also save callstack bottom! temp1 "ctx" %vm-field-ptr temp1 temp1 [] MOV - ! callstack_bottom temp2 stack-reg stack-frame get total-size>> cell - [+] LEA - temp1 1 cells [+] temp2 MOV - ! datastack - ds-reg temp1 2 cells [+] MOV - ! retainstack - rs-reg temp1 3 cells [+] MOV ; + temp1 "callstack-bottom" context-field-offset [+] temp2 MOV + ds-reg temp1 "datastack" context-field-offset [+] MOV + rs-reg temp1 "retainstack" context-field-offset [+] MOV ; M:: x86 %save-context ( temp1 temp2 -- ) #! Save Factor stack pointers in case the C code calls a @@ -1429,13 +1422,10 @@ M:: x86 %save-context ( temp1 temp2 -- ) #! all roots. temp1 "ctx" %vm-field-ptr temp1 temp1 [] MOV - ! callstack_top temp2 stack-reg cell neg [+] LEA - temp1 [] temp2 MOV - ! datastack - temp1 2 cells [+] ds-reg MOV - ! retainstack - temp1 3 cells [+] rs-reg MOV ; + temp1 "callstack-top" context-field-offset [+] temp2 MOV + temp1 "datastack" context-field-offset [+] ds-reg MOV + temp1 "retainstack" context-field-offset [+] rs-reg MOV ; M: x86 value-struct? drop t ; @@ -1475,6 +1465,6 @@ enable-fixnum-log2 ] when ; : check-sse ( -- ) - [ { sse_version } compile ] with-optimizer + [ { (sse-version) } compile ] with-optimizer "Checking for multimedia extensions: " write sse-version [ sse-string write " detected" print ] [ enable-sse2 ] bi ; diff --git a/basis/db/db.factor b/basis/db/db.factor index bd523b38e6..f26729f8ea 100644 --- a/basis/db/db.factor +++ b/basis/db/db.factor @@ -100,10 +100,10 @@ M: object execute-statement* ( statement type -- ) t >>bound? drop ; : sql-row ( result-set -- seq ) - dup #columns [ row-column ] with map ; + dup #columns [ row-column ] with { } map-integers ; : sql-row-typed ( result-set -- seq ) - dup #columns [ row-column-typed ] with map ; + dup #columns [ row-column-typed ] with { } map-integers ; : query-each ( statement quot: ( statement -- ) -- ) over more-rows? [ diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index e9aa01feb4..3ff93f49c6 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -34,7 +34,7 @@ SINGLETON: retryable ] 2map >>bind-params ; M: retryable execute-statement* ( statement type -- ) - drop [ retries>> ] [ + drop [ retries>> iota ] [ [ nip [ query-results dispose t ] diff --git a/basis/db/tester/tester.factor b/basis/db/tester/tester.factor index 19140259bf..d0ea6cbcf1 100644 --- a/basis/db/tester/tester.factor +++ b/basis/db/tester/tester.factor @@ -67,7 +67,7 @@ test-2 "TEST2" { test-2 ensure-table ] with-db ] [ - 10 [ + 10 iota [ drop 10 [ dup [ @@ -85,7 +85,7 @@ test-2 "TEST2" { ] with-db ] [ [ - 10 [ + 10 iota [ 10 [ test-1-tuple insert-tuple yield ] times diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index 863dc522b2..7ef62bfb77 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -205,7 +205,7 @@ link-no-follow? off 100 [ drop random-markup [ convert-farkup drop t ] [ drop print f ] recover - ] all? + ] all-integers? ] unit-test [ "

http://foo.com/~foo

" ] [ "[[http://foo.com/~foo]]" convert-farkup ] unit-test diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor index f33eb276a0..b341c462be 100644 --- a/basis/fry/fry-tests.factor +++ b/basis/fry/fry-tests.factor @@ -64,7 +64,7 @@ SYMBOLS: a b c d e f g h ; [ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test [ { 1 2 3 } ] [ - 3 1 '[ _ [ _ + ] map ] call + 3 1 '[ _ iota [ _ + ] map ] call ] unit-test [ { 1 { 2 { 3 } } } ] [ diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 546413447e..0c35f15714 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -64,7 +64,7 @@ IN: generalizations.tests { 3 5 } [ 2 nweave ] must-infer-as [ { 0 1 2 } { 3 5 4 } { 7 8 6 } ] -[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test +[ 9 [ ] each-integer { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test [ 1 2 3 4 1 2 3 ] [ 1 2 3 4 3 nover ] unit-test diff --git a/basis/grouping/grouping-docs.factor b/basis/grouping/grouping-docs.factor index e1044b0feb..2c2fee1d70 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 reverse! concat >array ." "{ 6 7 8 3 4 5 0 1 2 }" + "9 iota >array 3 reverse! concat >array ." "{ 6 7 8 3 4 5 0 1 2 }" } { $example "USING: kernel prettyprint sequences grouping ;" @@ -67,7 +67,7 @@ HELP: { $examples { $example "USING: arrays kernel prettyprint sequences grouping ;" - "9 >array 3 " + "9 iota >array 3 " "dup [ reverse! drop ] each concat >array ." "{ 2 1 0 5 4 3 8 7 6 }" } diff --git a/basis/heaps/heaps-tests.factor b/basis/heaps/heaps-tests.factor index c1985c516f..703cf53080 100644 --- a/basis/heaps/heaps-tests.factor +++ b/basis/heaps/heaps-tests.factor @@ -31,7 +31,7 @@ IN: heaps.tests [ heap-push-all ] keep heap-pop-all ; : random-alist ( n -- alist ) - [ + iota [ drop 32 random-bits dup number>string ] H{ } map>assoc ; @@ -40,16 +40,16 @@ IN: heaps.tests 14 [ [ t ] swap [ 2^ test-heap-sort ] curry unit-test -] each +] each-integer : test-entry-indices ( n -- ? ) random-alist [ heap-push-all ] keep - data>> dup length swap [ index>> ] map sequence= ; + data>> dup length iota swap [ index>> ] map sequence= ; 14 [ [ t ] swap [ 2^ test-entry-indices ] curry unit-test -] each +] each-integer : sort-entries ( entries -- entries' ) [ key>> ] sort-with ; @@ -66,4 +66,4 @@ IN: heaps.tests 11 [ [ t ] swap [ 2^ delete-test sequence= ] curry unit-test -] each +] each-integer diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 1ca5bf1bc5..e4bbb3459e 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs byte-arrays byte-vectors classes combinators definitions effects fry generic generic.single @@ -24,7 +24,7 @@ M: object specializer-declaration class ; "specializer" word-prop ; : make-specializer ( specs -- quot ) - dup length + dup length iota [ (picker) 2array ] 2map [ drop object eq? not ] assoc-filter [ [ t ] ] [ diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index e305c8477a..9a67d43e7d 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -137,7 +137,7 @@ TUPLE: jpeg-color-info data>> binary [ - read1 [0,b) + read1 iota [ drop read1 jpeg> color-info>> nth clone read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi* @@ -198,7 +198,7 @@ MEMO: yuv>bgr-matrix ( -- m ) { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2 1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ; -MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ; +MEMO: dct-matrix ( -- m ) 64 iota [ 8 /mod dct-vect flatten ] map ; : mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index 0817a59e7b..d4a9c4ab56 100644 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -120,7 +120,7 @@ ERROR: unimplemented-color-type image ; prev width tail-slice :> b curr :> a curr width tail-slice :> x - x length [0,b) + x length iota filter { { filter-none [ drop ] } { filter-sub [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] } diff --git a/basis/images/processing/processing.factor b/basis/images/processing/processing.factor index cd6754550d..b21eb50c62 100644 --- a/basis/images/processing/processing.factor +++ b/basis/images/processing/processing.factor @@ -6,7 +6,7 @@ math.ranges math.vectors sequences sequences.deep fry ; IN: images.processing : coord-matrix ( dim -- m ) - [ [0,b) ] map first2 [ [ 2array ] with map ] curry map ; + [ iota ] map first2 [ [ 2array ] with map ] curry map ; : map^2 ( m quot -- m' ) '[ _ map ] map ; inline : each^2 ( m quot -- m' ) '[ _ each ] each ; inline @@ -16,7 +16,7 @@ IN: images.processing : matrix>image ( m -- image ) over matrix-dim >>dim swap flip flatten - [ 128 * 128 + 0 max 255 min >fixnum ] map + [ 128 * 128 + 0 255 clamp >fixnum ] map >byte-array >>bitmap L >>component-order ubyte-components >>component-type ; :: matrix-zoom ( m f -- m' ) @@ -30,7 +30,7 @@ IN: images.processing :: draw-grey ( value x,y image -- ) x,y image image-offset 3 * { 0 1 2 } [ - + value 128 + >fixnum 0 max 255 min swap image bitmap>> set-nth + + value 128 + >fixnum 0 255 clamp swap image bitmap>> set-nth ] with each ; :: draw-color ( value x,y color-id image -- ) diff --git a/basis/inspector/inspector.factor b/basis/inspector/inspector.factor index 82c2487f67..2aa7cd218e 100644 --- a/basis/inspector/inspector.factor +++ b/basis/inspector/inspector.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2009 Slava Pestov. +! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays generic hashtables io kernel assocs math namespaces prettyprint prettyprint.custom prettyprint.sections @@ -23,9 +23,7 @@ GENERIC: add-numbers ( alist -- table' ) M: enum add-numbers ; M: assoc add-numbers - +number-rows+ get [ - dup length [ prefix ] 2map - ] when ; + +number-rows+ get [ [ prefix ] map-index ] when ; TUPLE: slot-name name ; diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index 4ecb1e12a8..d112e4e6eb 100644 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -68,7 +68,7 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; : enough? ( stack word -- ? ) dup deferred? [ 2drop f ] [ - [ [ length ] [ 1quotation infer in>> ] bi* >= ] + [ [ length ] [ 1quotation inputs ] bi* >= ] [ 3drop f ] recover ] if ; @@ -273,10 +273,10 @@ DEFER: __ ] recover ; inline : true-out ( quot effect -- quot' ) - out>> '[ @ _ ndrop t ] ; + out>> length '[ @ _ ndrop t ] ; : false-recover ( effect -- quot ) - in>> [ ndrop f ] curry [ recover-fail ] curry ; + in>> length [ ndrop f ] curry [ recover-fail ] curry ; : [matches?] ( quot -- undoes?-quot ) [undo] dup infer [ true-out ] [ false-recover ] bi curry ; diff --git a/basis/io/encodings/iso2022/iso2022.factor b/basis/io/encodings/iso2022/iso2022.factor index 1726426777..7d4d7f1215 100644 --- a/basis/io/encodings/iso2022/iso2022.factor +++ b/basis/io/encodings/iso2022/iso2022.factor @@ -18,7 +18,7 @@ VALUE: jis212 "vocab:io/encodings/iso2022/212.txt" flat-file>biassoc to: jis212 VALUE: ascii -128 unique >biassoc to: ascii +128 iota unique >biassoc to: ascii TUPLE: iso2022-state type ; diff --git a/basis/io/files/links/unix/unix-tests.factor b/basis/io/files/links/unix/unix-tests.factor index ef7d778abe..23de95f519 100644 --- a/basis/io/files/links/unix/unix-tests.factor +++ b/basis/io/files/links/unix/unix-tests.factor @@ -4,7 +4,7 @@ io.pathnames namespaces ; IN: io.files.links.unix.tests : make-test-links ( n path -- ) - [ '[ [ 1 + ] keep [ number>string _ prepend ] bi@ make-link ] each ] + [ '[ [ 1 + ] keep [ number>string _ prepend ] bi@ make-link ] each-integer ] [ [ number>string ] dip prepend touch-file ] 2bi ; inline [ t ] [ diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor index f167b1e99b..07f7b25140 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -35,8 +35,8 @@ SYMBOL: unique-retries : random-name ( -- string ) unique-length get [ random-ch ] "" replicate-as ; -: retry ( quot: ( -- ? ) n -- ) - swap [ drop ] prepose attempt-all ; inline +: retry ( quot: ( -- ? ) n -- ) + iota swap [ drop ] prepose attempt-all ; inline : (make-unique-file) ( path prefix suffix -- path ) '[ diff --git a/basis/lcs/diff2html/diff2html-tests.factor b/basis/lcs/diff2html/diff2html-tests.factor index 0c2ed34f45..2ee662c0ac 100644 --- a/basis/lcs/diff2html/diff2html-tests.factor +++ b/basis/lcs/diff2html/diff2html-tests.factor @@ -3,4 +3,4 @@ USING: lcs.diff2html lcs kernel tools.test strings sequences xml.writer ; IN: lcs.diff2html.tests -[ ] [ "hello" "heyo" [ 1string ] { } map-as diff htmlize-diff xml>string drop ] unit-test +[ ] [ "hello" "heyo" [ [ 1string ] { } map-as ] bi@ diff htmlize-diff xml>string drop ] unit-test diff --git a/basis/lcs/diff2html/diff2html.factor b/basis/lcs/diff2html/diff2html.factor index ca9e48eb05..545610a0ea 100644 --- a/basis/lcs/diff2html/diff2html.factor +++ b/basis/lcs/diff2html/diff2html.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov +! Copyright (C) 2008, 2010 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: lcs xml.syntax xml.writer kernel strings ; FROM: accessors => item>> ; diff --git a/basis/lcs/lcs.factor b/basis/lcs/lcs.factor index 38920f5764..5861d90dc3 100644 --- a/basis/lcs/lcs.factor +++ b/basis/lcs/lcs.factor @@ -19,15 +19,15 @@ IN: lcs i 1 + j 1 + matrix nth set-nth ; inline : lcs-initialize ( |str1| |str2| -- matrix ) - [ drop 0 ] with map ; + iota [ drop 0 ] with map ; : levenshtein-initialize ( |str1| |str2| -- matrix ) - [ [ + ] curry map ] with map ; + [ iota ] bi@ [ [ + ] curry map ] with map ; :: run-lcs ( old new init step -- matrix ) old length 1 + new length 1 + init call :> matrix - old length [| i | - new length + old length iota [| i | + new length iota [| j | i j matrix old new step loop-step ] each ] each matrix ; inline PRIVATE> diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor index 25f754e92a..3dab0c3cdb 100644 --- a/basis/macros/expander/expander.factor +++ b/basis/macros/expander/expander.factor @@ -49,7 +49,7 @@ M: wrapper expand-macros* wrapped>> literal ; stack get pop end [ [ expand-macros ] [ ] map-as '[ _ dip ] % ] [ - length [ ] keep + length iota [ ] keep [ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch , ] bi ; diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor index 10584f2004..ec3cd6ee76 100644 --- a/basis/math/combinatorics/combinatorics-docs.factor +++ b/basis/math/combinatorics/combinatorics-docs.factor @@ -31,7 +31,7 @@ HELP: permutation { $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1 -" } "." } { $examples { $example "USING: math.combinatorics prettyprint ;" - "1 3 permutation ." "{ 0 2 1 }" } + "1 { 0 1 2 } permutation ." "{ 0 2 1 }" } { $example "USING: math.combinatorics prettyprint ;" "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } } ; @@ -41,7 +41,7 @@ HELP: all-permutations { $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." } { $examples { $example "USING: math.combinatorics prettyprint ;" - "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } + "{ 0 1 2 } all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ; HELP: each-permutation diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor index ca6ec9cb53..bbf5a1cb85 100644 --- a/basis/math/combinatorics/combinatorics-tests.factor +++ b/basis/math/combinatorics/combinatorics-tests.factor @@ -56,7 +56,7 @@ IN: math.combinatorics.tests [ 0 ] [ 9 5 iota 3 dual-index ] unit-test [ 179 ] [ 72 10 iota 5 dual-index ] unit-test -[ { 5 3 2 1 } ] [ 7 4 8 combinadic ] unit-test +[ { 5 3 2 1 } ] [ 7 iota 4 8 combinadic ] unit-test [ { 4 3 2 1 0 } ] [ 10 iota 5 0 combinadic ] unit-test [ { 8 6 3 1 0 } ] [ 10 iota 5 72 combinadic ] unit-test [ { 9 8 7 6 5 } ] [ 10 iota 5 251 combinadic ] unit-test diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index 36b62ddcc0..7c68aede09 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer. +! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs binary-search fry kernel locals math math.order math.ranges namespaces sequences sorting ; @@ -15,7 +15,7 @@ IN: math.combinatorics PRIVATE> : factorial ( n -- n! ) - 1 [ 1 + * ] reduce ; + iota 1 [ 1 + * ] reduce ; : nPk ( n k -- nPk ) 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ; @@ -46,11 +46,11 @@ PRIVATE> [ permutation-indices ] keep nths ; : all-permutations ( seq -- seq ) - [ length factorial ] keep + [ length factorial iota ] keep '[ _ permutation ] map ; : each-permutation ( seq quot -- ) - [ [ length factorial ] keep ] dip + [ [ length factorial iota ] keep ] dip '[ _ permutation @ ] each ; inline : reduce-permutations ( seq identity quot -- result ) @@ -77,7 +77,7 @@ C: combo dup 0 = [ drop 1 - nip ] [ - [ [0,b) ] 2dip '[ _ nCk _ >=< ] search nip + [ iota ] 2dip '[ _ nCk _ >=< ] search nip ] if ; :: next-values ( a b x -- a' b' x' v ) @@ -104,7 +104,7 @@ C: combo [ combination-indices ] keep seq>> nths ; : combinations-quot ( seq k quot -- seq quot ) - [ [ choose [0,b) ] keep ] dip + [ [ choose iota ] keep ] dip '[ _ apply-combination @ ] ; inline PRIVATE> diff --git a/basis/math/complex/complex-tests.factor b/basis/math/complex/complex-tests.factor index 4b0481eca1..f85ec49f81 100644 --- a/basis/math/complex/complex-tests.factor +++ b/basis/math/complex/complex-tests.factor @@ -70,4 +70,7 @@ IN: math.complex.tests [ ] [ C{ 1 4 } coth drop ] unit-test [ ] [ C{ 1 4 } cot drop ] unit-test +[ t ] [ 0.0 pi rect> exp C{ -1 0 } 1.0e-7 ~ ] unit-test +[ t ] [ 0 pi rect> exp C{ -1 0 } 1.0e-7 ~ ] unit-test + [ "C{ 1/2 2/3 }" ] [ C{ 1/2 2/3 } unparse ] unit-test diff --git a/basis/math/floats/env/x86/32/32.factor b/basis/math/floats/env/x86/32/32.factor new file mode 100644 index 0000000000..ea3bee424f --- /dev/null +++ b/basis/math/floats/env/x86/32/32.factor @@ -0,0 +1,29 @@ +USING: alien alien.c-types cpu.x86.assembler +cpu.x86.assembler.operands math.floats.env.x86 system ; +IN: math.floats.env.x86.32 + +M: x86.32 get-sse-env + void { void* } "cdecl" [ + EAX ESP [] MOV + EAX [] STMXCSR + ] alien-assembly ; + +M: x86.32 set-sse-env + void { void* } "cdecl" [ + EAX ESP [] MOV + EAX [] LDMXCSR + ] alien-assembly ; + +M: x86.32 get-x87-env + void { void* } "cdecl" [ + EAX ESP [] MOV + EAX [] FNSTSW + EAX 2 [+] FNSTCW + ] alien-assembly ; + +M: x86.32 set-x87-env + void { void* } "cdecl" [ + EAX ESP [] MOV + FNCLEX + EAX 2 [+] FLDCW + ] alien-assembly ; diff --git a/basis/math/floats/env/x86/32/tags.txt b/basis/math/floats/env/x86/32/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/math/floats/env/x86/32/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/math/floats/env/x86/64/64.factor b/basis/math/floats/env/x86/64/64.factor new file mode 100644 index 0000000000..b6f8ee151f --- /dev/null +++ b/basis/math/floats/env/x86/64/64.factor @@ -0,0 +1,25 @@ +USING: alien alien.c-types cpu.architecture cpu.x86.assembler +cpu.x86.assembler.operands math.floats.env.x86 sequences system ; +IN: math.floats.env.x86.64 + +M: x86.64 get-sse-env + void { void* } "cdecl" [ + int-regs param-regs first [] STMXCSR + ] alien-assembly ; + +M: x86.64 set-sse-env + void { void* } "cdecl" [ + int-regs param-regs first [] LDMXCSR + ] alien-assembly ; + +M: x86.64 get-x87-env + void { void* } "cdecl" [ + int-regs param-regs first [] FNSTSW + int-regs param-regs first 2 [+] FNSTCW + ] alien-assembly ; + +M: x86.64 set-x87-env + void { void* } "cdecl" [ + FNCLEX + int-regs param-regs first 2 [+] FLDCW + ] alien-assembly ; diff --git a/basis/math/floats/env/x86/64/tags.txt b/basis/math/floats/env/x86/64/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/math/floats/env/x86/64/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/math/floats/env/x86/x86.factor b/basis/math/floats/env/x86/x86.factor index 2b73628b4c..89dd402378 100644 --- a/basis/math/floats/env/x86/x86.factor +++ b/basis/math/floats/env/x86/x86.factor @@ -1,7 +1,7 @@ -USING: accessors alien.c-types alien.syntax arrays assocs -biassocs classes.struct combinators cpu.x86.features kernel -literals math math.bitwise math.floats.env -math.floats.env.private system ; +USING: accessors alien.c-types arrays assocs biassocs +classes.struct combinators cpu.x86.features kernel literals +math math.bitwise math.floats.env math.floats.env.private +system vocabs.loader ; IN: math.floats.env.x86 STRUCT: sse-env @@ -11,24 +11,23 @@ STRUCT: x87-env { status ushort } { control ushort } ; -! defined in the vm, cpu-x86*.S -FUNCTION: void get_sse_env ( sse-env* env ) ; -FUNCTION: void set_sse_env ( sse-env* env ) ; +HOOK: get-sse-env cpu ( sse-env -- ) +HOOK: set-sse-env cpu ( sse-env -- ) -FUNCTION: void get_x87_env ( x87-env* env ) ; -FUNCTION: void set_x87_env ( x87-env* env ) ; +HOOK: get-x87-env cpu ( x87-env -- ) +HOOK: set-x87-env cpu ( x87-env -- ) : ( -- sse-env ) - sse-env (struct) [ get_sse_env ] keep ; + sse-env (struct) [ get-sse-env ] keep ; M: sse-env (set-fp-env-register) - set_sse_env ; + set-sse-env ; : ( -- x87-env ) - x87-env (struct) [ get_x87_env ] keep ; + x87-env (struct) [ get-x87-env ] keep ; M: x87-env (set-fp-env-register) - set_x87_env ; + set-x87-env ; M: x86 (fp-env-registers) sse2? [ 2array ] [ 1array ] if ; @@ -128,3 +127,7 @@ M: x87-env (get-denormal-mode) ( register -- mode ) M: x87-env (set-denormal-mode) ( register mode -- register' ) drop ; +cpu { + { x86.32 [ "math.floats.env.x86.32" ] } + { x86.64 [ "math.floats.env.x86.64" ] } +} case require diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index d91b4b6b92..a1466dd22c 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel math.constants math.private math.bits math.libm combinators math.order sequences ; @@ -62,7 +62,7 @@ M: float exp fexp ; inline M: real exp >float exp ; inline -M: complex exp >rect swap fexp swap polar> ; inline +M: complex exp >rect swap exp swap polar> ; inline ; + rows dup iota ; : clear-col ( col# row# rows -- ) [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ; @@ -79,9 +79,9 @@ SYMBOL: matrix : reduced ( matrix' -- matrix'' ) [ - rows [ + rows iota [ dup nth-row leading drop - dup [ swap dup clear-col ] [ 2drop ] if + dup [ swap dup iota clear-col ] [ 2drop ] if ] each ] with-matrix ; diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index 75b9be5cae..bf14d7ba13 100644 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2009 Slava Pestov. +! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays columns kernel locals math math.bits math.functions math.order math.vectors sequences @@ -11,7 +11,7 @@ IN: math.matrices : identity-matrix ( n -- matrix ) #! Make a nxn identity matrix. - dup [ [ = 1 0 ? ] with map ] curry map ; + iota dup [ [ = 1 0 ? ] with map ] curry map ; :: rotation-matrix3 ( axis theta -- matrix ) theta cos :> c diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index 0de18b6feb..99d77d0ce2 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -32,7 +32,7 @@ PRIVATE> 2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ; : p* ( p q -- r ) - 2unempty pextend-conv dup length + 2unempty pextend-conv dup length iota [ over length pick pick [ * ] 2map sum ] map 2nip reverse ; : p-sq ( p -- p^2 ) diff --git a/basis/math/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor index d201abfef8..f803b7db01 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor @@ -8,4 +8,4 @@ IN: math.primes.miller-rabin.tests [ t ] [ 37 miller-rabin ] unit-test [ t ] [ 2135623355842621559 miller-rabin ] unit-test -[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test +[ f ] [ 1000 iota [ drop 15 miller-rabin ] any? ] unit-test diff --git a/basis/math/primes/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor index 04b1330cc2..ac5c2df705 100644 --- a/basis/math/primes/miller-rabin/miller-rabin.factor +++ b/basis/math/primes/miller-rabin/miller-rabin.factor @@ -10,7 +10,7 @@ IN: math.primes.miller-rabin n 1 - :> n-1 n-1 factor-2s :> ( r s ) 0 :> a! - trials [ + trials iota [ drop 2 n 2 - [a,b] random a! a s n ^mod 1 = [ diff --git a/basis/math/vectors/simd/cords/cords.factor b/basis/math/vectors/simd/cords/cords.factor index e099f6e830..815b34a90d 100644 --- a/basis/math/vectors/simd/cords/cords.factor +++ b/basis/math/vectors/simd/cords/cords.factor @@ -22,7 +22,7 @@ A-cast DEFINES ${A}-cast A{ DEFINES ${A}{ N [ A-rep rep-length ] -BOA-EFFECT [ N 2 * "n" >array { "v" } ] +BOA-EFFECT [ N 2 * "n" { "v" } ] WHERE diff --git a/basis/math/vectors/simd/intrinsics/intrinsics.factor b/basis/math/vectors/simd/intrinsics/intrinsics.factor index 658d9b270c..d80755a6a5 100644 --- a/basis/math/vectors/simd/intrinsics/intrinsics.factor +++ b/basis/math/vectors/simd/intrinsics/intrinsics.factor @@ -238,7 +238,7 @@ PRIVATE> [ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi [ tail-slice ] dip call( a' -- c' ) underlying>> ; : (simd-with) ( n rep -- v ) - [ rep-length iota swap '[ _ ] ] [ ] bi replicate-as + [ rep-length swap '[ _ ] ] [ ] bi replicate-as underlying>> ; : (simd-gather-2) ( m n rep -- v ) [ 2 set-firstn ] keep underlying>> ; : (simd-gather-4) ( m n o p rep -- v ) [ 4 set-firstn ] keep underlying>> ; diff --git a/basis/math/vectors/simd/simd-tests.factor b/basis/math/vectors/simd/simd-tests.factor index aaa5507864..342c565dce 100644 --- a/basis/math/vectors/simd/simd-tests.factor +++ b/basis/math/vectors/simd/simd-tests.factor @@ -175,7 +175,8 @@ CONSTANT: vector-words "== Checking vector operations" print : random-int-vector ( class -- vec ) - new [ drop 1,000 random ] map ; + new [ drop 1000 random ] map ; + : random-float-vector ( class -- vec ) new [ drop @@ -463,7 +464,7 @@ TUPLE: inconsistent-vector-test bool branch ; ! Test element access -- it should box bignums for int-4 on x86 : test-accesses ( seq -- failures ) - [ length >array ] keep + [ length iota >array ] keep '[ [ _ 1quotation ] dip '[ _ swap nth ] ] [ = ] check-optimizer ; inline [ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test @@ -480,7 +481,7 @@ TUPLE: inconsistent-vector-test bool branch ; "== Checking broadcast" print : test-broadcast ( seq -- failures ) - [ length >array ] keep + [ length iota >array ] keep '[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ; [ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor index 905737c266..acf13599c1 100644 --- a/basis/math/vectors/simd/simd.factor +++ b/basis/math/vectors/simd/simd.factor @@ -247,7 +247,7 @@ COERCER [ ELT c-type-class "coercer" word-prop [ ] or ] SET-NTH [ ELT dup c:c-setter c:array-accessor ] -BOA-EFFECT [ N "n" >array { "v" } ] +BOA-EFFECT [ N "n" { "v" } ] WHERE diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 311abf50af..69d8929c65 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -58,21 +58,14 @@ M: object v*hs+ [ * ] 2map (h+) ; GENERIC: v/ ( u v -- w ) M: object v/ [ / ] 2map ; - - GENERIC: vavg ( u v -- w ) M: object vavg [ + 2 / ] 2map ; GENERIC: vmax ( u v -- w ) -M: object vmax [ [ float-max ] [ max ] if-both-floats ] 2map ; +M: object vmax [ max ] 2map ; GENERIC: vmin ( u v -- w ) -M: object vmin [ [ float-min ] [ min ] if-both-floats ] 2map ; +M: object vmin [ min ] 2map ; GENERIC: v+- ( u v -- w ) M: object v+- diff --git a/basis/models/arrow/smart/smart.factor b/basis/models/arrow/smart/smart.factor index 257a2bb1ea..7c29310a97 100644 --- a/basis/models/arrow/smart/smart.factor +++ b/basis/models/arrow/smart/smart.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: models.arrow models.product stack-checker accessors fry -generalizations macros kernel ; +generalizations combinators.smart macros kernel ; IN: models.arrow.smart MACRO: ( quot -- quot' ) - [ infer in>> dup ] keep + [ inputs dup ] keep '[ _ narray [ _ firstn @ ] ] ; \ No newline at end of file diff --git a/basis/nibble-arrays/nibble-arrays-tests.factor b/basis/nibble-arrays/nibble-arrays-tests.factor index 2a0eef7227..363f30678d 100644 --- a/basis/nibble-arrays/nibble-arrays-tests.factor +++ b/basis/nibble-arrays/nibble-arrays-tests.factor @@ -1,6 +1,6 @@ USING: nibble-arrays tools.test sequences kernel math ; IN: nibble-arrays.tests -[ t ] [ 16 dup >nibble-array sequence= ] unit-test +[ t ] [ 16 iota dup >nibble-array sequence= ] unit-test [ N{ 4 2 1 3 } ] [ N{ 3 1 2 4 } reverse ] unit-test [ N{ 1 4 9 0 9 4 } ] [ N{ 1 2 3 4 5 6 } [ sq ] map ] unit-test diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index 5ddd5f9bf0..ffc4cb91ad 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -446,14 +446,14 @@ M: ebnf-sequence build-locals ( code ast -- code ) ] [ [ "FROM: locals => [let :> ; FROM: sequences => nth ; [let " % - dup length [ + [ over ebnf-var? [ " " % # " over nth :> " % name>> % ] [ 2drop ] if - ] 2each + ] each-index " " % % " nip ]" % diff --git a/basis/persistent/hashtables/hashtables-tests.factor b/basis/persistent/hashtables/hashtables-tests.factor index d66fdd0c08..482367ad9c 100644 --- a/basis/persistent/hashtables/hashtables-tests.factor +++ b/basis/persistent/hashtables/hashtables-tests.factor @@ -81,7 +81,8 @@ M: hash-0-b hashcode* 2drop 0 ; ] unit-test : random-string ( -- str ) - 1000000 random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ; + 1000000 random ; + ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ; : random-assocs ( n -- hash phash ) [ random-string ] replicate diff --git a/basis/persistent/vectors/vectors-tests.factor b/basis/persistent/vectors/vectors-tests.factor index 95fa70558d..6d340ca78a 100644 --- a/basis/persistent/vectors/vectors-tests.factor +++ b/basis/persistent/vectors/vectors-tests.factor @@ -18,14 +18,14 @@ vectors math math.order ; ] unit-test { 100 1060 2000 10000 100000 1000000 } [ - [ t ] swap [ dup >persistent-vector sequence= ] curry unit-test + [ t ] swap [ iota dup >persistent-vector sequence= ] curry unit-test ] each [ ] [ 10000 [ 16 random-bits ] PV{ } replicate-as "1" set ] unit-test [ ] [ "1" get >vector "2" set ] unit-test [ t ] [ - 3000 [ + 3000 iota [ drop 16 random-bits 10000 random [ "1" [ new-nth ] change ] @@ -56,11 +56,11 @@ vectors math math.order ; ] unit-test [ t ] [ - 10000 >persistent-vector 752 [ ppop ] times dup length sequence= + 10000 iota >persistent-vector 752 [ ppop ] times dup length iota sequence= ] unit-test [ t ] [ - 100 [ + 100 iota [ drop 100 random [ 16 random-bits [ "1" [ ppush ] change ] [ "2" get push ] bi diff --git a/basis/porter-stemmer/porter-stemmer.factor b/basis/porter-stemmer/porter-stemmer.factor index 2e1a47b951..e3cb186bf8 100644 --- a/basis/porter-stemmer/porter-stemmer.factor +++ b/basis/porter-stemmer/porter-stemmer.factor @@ -33,10 +33,10 @@ IN: porter-stemmer ] if ; : consonant-seq ( str -- n ) - 0 0 rot skip-consonants (consonant-seq) ; + [ 0 0 ] dip skip-consonants (consonant-seq) ; : stem-vowel? ( str -- ? ) - [ length ] keep [ consonant? ] curry all? not ; + [ length iota ] keep [ consonant? ] curry all? not ; : double-consonant? ( i str -- ? ) over 1 < [ diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 6cff399201..65d25f1812 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -73,8 +73,8 @@ SYMBOL: -> : remove-breakpoints ( quot pos -- quot' ) over quotation? [ - 1 + cut [ (remove-breakpoints) ] bi@ - [ -> ] glue + 1 + short cut [ (remove-breakpoints) ] bi@ + [ -> ] glue ] [ drop ] if ; diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index 040b6d8f7c..6f5f61f688 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2009 Slava Pestov. +! Copyright (C) 2003, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic hashtables io kernel math assocs namespaces make sequences strings io.styles vectors words @@ -309,7 +309,7 @@ SYMBOL: next : group-flow ( seq -- newseq ) [ - dup length [ + dup length iota [ 2dup 1 - swap ?nth prev set 2dup 1 + swap ?nth next set swap nth dup split-before dup , split-after diff --git a/basis/random/mersenne-twister/mersenne-twister-tests.factor b/basis/random/mersenne-twister/mersenne-twister-tests.factor index b877af6f79..ede3c92f51 100644 --- a/basis/random/mersenne-twister/mersenne-twister-tests.factor +++ b/basis/random/mersenne-twister/mersenne-twister-tests.factor @@ -5,7 +5,7 @@ IN: random.mersenne-twister.tests : check-random ( max -- ? ) [ random 0 ] keep between? ; -[ t ] [ 100 [ drop 674 check-random ] all? ] unit-test +[ t ] [ 100 [ drop 674 check-random ] all-integers? ] unit-test : randoms ( -- seq ) 100 [ 100 random ] replicate ; @@ -16,11 +16,11 @@ IN: random.mersenne-twister.tests [ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test [ 1333075495 ] [ - 0 [ 1000 [ drop random-generator get random-32* drop ] each random-generator get random-32* ] test-rng + 0 [ 1000 [ drop random-generator get random-32* drop ] each-integer random-generator get random-32* ] test-rng ] unit-test [ 1575309035 ] [ - 0 [ 10000 [ drop random-generator get random-32* drop ] each random-generator get random-32* ] test-rng + 0 [ 10000 [ drop random-generator get random-32* drop ] each-integer random-generator get random-32* ] test-rng ] unit-test diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index 90489d3052..9fd82a3062 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -30,8 +30,8 @@ CONSTANT: a uint-array{ 0 HEX: 9908b0df } : mt-generate ( mt -- ) [ seq>> - [ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each ] - [ [ m 1 - ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ] + [ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each-integer ] + [ [ m 1 - ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each-integer ] bi ] [ 0 >>i drop ] bi ; inline @@ -41,7 +41,7 @@ CONSTANT: a uint-array{ 0 HEX: 9908b0df } : init-mt-rest ( seq -- ) n 1 - swap '[ _ [ init-mt-formula ] [ [ 1 + ] dip set-nth ] 2bi - ] each ; inline + ] each-integer ; inline : init-mt-seq ( seed -- seq ) 32 bits n diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor index 788a6e700a..2bf92f64a3 100644 --- a/basis/random/random-docs.factor +++ b/basis/random/random-docs.factor @@ -19,9 +19,8 @@ HELP: random-bytes* { $description "Generates a byte-array of random bytes." } ; HELP: random -{ $values { "seq" sequence } { "elt" "a random element" } } -{ $description "Outputs a random element of the input sequence. Outputs " { $link f } " if the sequence is empty." } -{ $notes "Since integers are sequences, passing an integer " { $snippet "n" } " outputs an integer in the interval " { $snippet "[0,n)" } "." } +{ $values { "obj" object } { "elt" "a random element" } } +{ $description "Outputs a random element of the input object, or outputs " { $link f } " if the object contains no elements." } { $examples { $unchecked-example "USING: random prettyprint ;" "10 random ." diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index 96dc8cc783..9341b96b11 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -11,8 +11,8 @@ IN: random.tests [ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test [ V{ } [ delete-random drop ] keep length ] must-fail -[ t ] [ 10000 [ 0 [ drop 187 random + ] reduce ] keep / 2 * 187 10 ~ ] unit-test -[ t ] [ 10000 [ 0 [ drop 400 random + ] reduce ] keep / 2 * 400 10 ~ ] unit-test +[ t ] [ 10000 [ iota 0 [ drop 187 random + ] reduce ] keep / 2 * 187 10 ~ ] unit-test +[ t ] [ 10000 [ iota 0 [ drop 400 random + ] reduce ] keep / 2 * 400 10 ~ ] unit-test [ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test @@ -29,7 +29,7 @@ IN: random.tests [ { 1 2 } 3 sample ] [ too-many-samples? ] must-fail-with [ 3 ] [ { 1 2 3 4 } 3 sample prune length ] unit-test -[ 99 ] [ 100 99 sample prune length ] unit-test +[ 99 ] [ 100 iota 99 sample prune length ] unit-test [ ] [ [ 100 random-bytes ] with-system-random drop ] unit-test diff --git a/basis/random/random.factor b/basis/random/random.factor index bfd107dbb6..1e54c56728 100644 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -50,7 +50,11 @@ PRIVATE> : random-bits* ( numbits -- n ) 1 - [ random-bits ] keep set-bit ; -: random ( seq -- elt ) +GENERIC: random ( obj -- elt ) + +M: integer random [ f ] [ random-integer ] if-zero ; + +M: sequence random [ f ] [ [ length random-integer ] keep nth ] if-empty ; @@ -59,7 +63,7 @@ PRIVATE> : randomize ( seq -- seq ) dup length [ dup 1 > ] - [ [ iota random ] [ 1 - ] bi [ pick exchange ] keep ] + [ [ random ] [ 1 - ] bi [ pick exchange ] keep ] while drop ; ERROR: too-many-samples seq n ; diff --git a/basis/regexp/disambiguate/disambiguate.factor b/basis/regexp/disambiguate/disambiguate.factor index fcde135cf8..33b2ded448 100644 --- a/basis/regexp/disambiguate/disambiguate.factor +++ b/basis/regexp/disambiguate/disambiguate.factor @@ -11,9 +11,7 @@ TUPLE: parts in out ; zip [ first ] partition [ values ] bi@ parts boa ; : powerset-partition ( sequence -- partitions ) - [ length [ 2^ ] keep ] keep '[ - _ _ make-partition - ] map rest ; + [ length [ 2^ iota ] keep ] keep '[ _ _ make-partition ] map rest ; : partition>class ( parts -- class ) [ out>> [ ] map ] diff --git a/basis/roman/roman-docs.factor b/basis/roman/roman-docs.factor index 50a057d7f4..c81ed0ae42 100644 --- a/basis/roman/roman-docs.factor +++ b/basis/roman/roman-docs.factor @@ -4,7 +4,7 @@ USING: help.markup help.syntax kernel math strings ; IN: roman HELP: >roman -{ $values { "n" "an integer" } { "str" "a string" } } +{ $values { "n" integer } { "str" string } } { $description "Converts a number to its lower-case Roman Numeral equivalent." } { $notes "The range for this word is 1-3999, inclusive." } { $examples @@ -15,7 +15,7 @@ HELP: >roman } ; HELP: >ROMAN -{ $values { "n" "an integer" } { "str" "a string" } } +{ $values { "n" integer } { "str" string } } { $description "Converts a number to its upper-case Roman numeral equivalent." } { $notes "The range for this word is 1-3999, inclusive." } { $examples @@ -26,7 +26,7 @@ HELP: >ROMAN } ; HELP: roman> -{ $values { "str" "a string" } { "n" "an integer" } } +{ $values { "str" string } { "n" integer } } { $description "Converts a Roman numeral to an integer." } { $notes "The range for this word is i-mmmcmxcix, inclusive." } { $examples @@ -39,7 +39,7 @@ HELP: roman> { >roman >ROMAN roman> } related-words HELP: roman+ -{ $values { "string" string } { "string" string } { "string" string } } +{ $values { "x" string } { "x" string } { "x" string } } { $description "Adds two Roman numerals." } { $examples { $example "USING: io roman ;" @@ -49,7 +49,7 @@ HELP: roman+ } ; HELP: roman- -{ $values { "string" string } { "string" string } { "string" string } } +{ $values { "x" string } { "x" string } { "x" string } } { $description "Subtracts two Roman numerals." } { $examples { $example "USING: io roman ;" @@ -61,7 +61,7 @@ HELP: roman- { roman+ roman- } related-words HELP: roman* -{ $values { "string" string } { "string" string } { "string" string } } +{ $values { "x" string } { "x" string } { "x" string } } { $description "Multiplies two Roman numerals." } { $examples { $example "USING: io roman ;" @@ -71,7 +71,7 @@ HELP: roman* } ; HELP: roman/i -{ $values { "string" string } { "string" string } { "string" string } } +{ $values { "x" string } { "x" string } { "x" string } } { $description "Computes the integer division of two Roman numerals." } { $examples { $example "USING: io roman ;" @@ -81,7 +81,7 @@ HELP: roman/i } ; HELP: roman/mod -{ $values { "string" string } { "string" string } { "string" string } { "string" string } } +{ $values { "x" string } { "x" string } { "x" string } { "x" string } } { $description "Computes the quotient and remainder of two Roman numerals." } { $examples { $example "USING: kernel io roman ;" diff --git a/basis/roman/roman.factor b/basis/roman/roman.factor index a645898c03..a783e7973c 100644 --- a/basis/roman/roman.factor +++ b/basis/roman/roman.factor @@ -48,7 +48,7 @@ PRIVATE> > ] [ ] [ infer out>> ] tri + [ inputs ] [ ] [ outputs ] tri '[ [ roman> ] _ napply @ [ >roman ] _ napply ] ; PRIVATE> @@ -58,8 +58,7 @@ PRIVATE> SYNTAX: ROMAN-OP: scan-word [ name>> "roman" prepend create-in ] keep 1quotation '[ _ binary-roman-op ] - dup infer [ in>> ] [ out>> ] bi - [ "string" ] bi@ define-declared ; + dup infer define-declared ; >> diff --git a/basis/serialize/serialize-tests.factor b/basis/serialize/serialize-tests.factor index 6dbc76386d..036356e137 100644 --- a/basis/serialize/serialize-tests.factor +++ b/basis/serialize/serialize-tests.factor @@ -16,12 +16,12 @@ IN: serialize.tests [ t ] [ 100 [ drop - 40 [ test-serialize-cell ] all? - 4 [ 40 * test-serialize-cell ] all? - 4 [ 400 * test-serialize-cell ] all? - 4 [ 4000 * test-serialize-cell ] all? + 40 [ test-serialize-cell ] all-integers? + 4 [ 40 * test-serialize-cell ] all-integers? + 4 [ 400 * test-serialize-cell ] all-integers? + 4 [ 4000 * test-serialize-cell ] all-integers? and and and - ] all? + ] all-integers? ] unit-test TUPLE: serialize-test a b ; diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor index 9b4b0ac46b..0840c778d7 100644 --- a/basis/serialize/serialize.factor +++ b/basis/serialize/serialize.factor @@ -240,7 +240,7 @@ SYMBOL: deserialized [ ] tri ; : copy-seq-to-tuple ( seq tuple -- ) - [ dup length ] dip [ set-array-nth ] curry 2each ; + [ set-array-nth ] curry each-index ; : deserialize-tuple ( -- array ) #! Ugly because we have to intern the tuple before reading diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index 0ff41edec6..b826606df5 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -8,7 +8,7 @@ IN: shuffle index-assoc ( sequence -- assoc ) - dup length zip >hashtable ; + dup length iota zip >hashtable ; PRIVATE> diff --git a/basis/sorting/insertion/insertion.factor b/basis/sorting/insertion/insertion.factor index 78b1493920..b7fefcad63 100644 --- a/basis/sorting/insertion/insertion.factor +++ b/basis/sorting/insertion/insertion.factor @@ -13,4 +13,4 @@ PRIVATE> : insertion-sort ( seq quot -- ) ! quot is a transformation on elements - over length [ insert ] with with each ; inline + over length [ insert ] with with each-integer ; inline diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor index 5ebd4438fe..08fc0e921d 100644 --- a/basis/sorting/slots/slots-tests.factor +++ b/basis/sorting/slots/slots-tests.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors math.order sorting.slots tools.test -sorting.human arrays sequences kernel assocs multiline -sorting.functor ; +arrays sequences kernel assocs multiline sorting.functor ; IN: sorting.literals.tests TUPLE: sort-test a b c tuple2 ; @@ -42,7 +41,7 @@ TUPLE: tuple2 d ; T{ sort-test f 1 1 11 } T{ sort-test f 2 5 3 } T{ sort-test f 2 5 2 } - } { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by + } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by ] unit-test [ { } ] @@ -83,14 +82,14 @@ TUPLE: tuple2 d ; { length-test<=> <=> } sort-by ] unit-test -[ { { 0 1 } { 1 2 } { 1 1 } { 3 2 } } ] +[ { { { 0 } 1 } { { 1 } 2 } { { 1 } 1 } { { 3 1 } 2 } } ] [ - { { 3 2 } { 1 2 } { 0 1 } { 1 1 } } + { { { 3 1 } 2 } { { 1 } 2 } { { 0 } 1 } { { 1 } 1 } } { length-test<=> <=> } sort-keys-by ] unit-test -[ { { 0 1 } { 1 1 } { 3 2 } { 1 2 } } ] +[ { { 0 { 1 } } { 1 { 1 } } { 3 { 2 4 } } { 1 { 2 0 0 0 } } } ] [ - { { 3 2 } { 1 2 } { 0 1 } { 1 1 } } + { { 3 { 2 4 } } { 1 { 2 0 0 0 } } { 0 { 1 } } { 1 { 1 } } } { length-test<=> <=> } sort-values-by ] unit-test diff --git a/basis/splitting/monotonic/monotonic.factor b/basis/splitting/monotonic/monotonic.factor index 3641345a3e..32bb8b46c6 100644 --- a/basis/splitting/monotonic/monotonic.factor +++ b/basis/splitting/monotonic/monotonic.factor @@ -26,7 +26,7 @@ PRIVATE> : (monotonic-slice) ( seq quot class -- slices ) [ dupd '[ - [ length ] [ ] [ 1 over change-circular-start ] tri + [ length iota ] [ ] [ 1 over change-circular-start ] tri [ @ not [ , ] [ drop ] if ] 3each ] { } make dup empty? [ over length 1 - prefix ] when -1 prefix 2 clump diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index deeada3735..fdfda6dd9e 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -12,6 +12,8 @@ TUPLE: alien-invoke-params < alien-node-params library function ; TUPLE: alien-indirect-params < alien-node-params ; +TUPLE: alien-assembly-params < alien-node-params quot ; + TUPLE: alien-callback-params < alien-node-params quot xt ; : param-prep-quot ( node -- quot ) @@ -58,6 +60,22 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; ! Quotation which coerces return value to required type return-prep-quot infer-quot-here ; +: infer-alien-assembly ( -- ) + alien-assembly-params new + ! Compile-time parameters + pop-literal nip >>quot + pop-literal nip >>abi + pop-literal nip >>parameters + pop-literal nip >>return + ! Quotation which coerces parameters to required types + dup param-prep-quot infer-quot-here + ! Magic #: consume exactly the number of inputs + dup 0 alien-stack + ! Add node to IR + dup #alien-assembly, + ! Quotation which coerces return value to required type + return-prep-quot infer-quot-here ; + : callback-xt ( word return-rewind -- alien ) [ callbacks get ] dip '[ _ ] cache ; diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index d008c4921d..433c11d34c 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel prettyprint io debugger +USING: accessors arrays kernel prettyprint io debugger sequences assocs stack-checker.errors summary effects ; IN: stack-checker.errors.prettyprint @@ -15,7 +15,7 @@ M: unbalanced-branches-error summary M: unbalanced-branches-error error. dup summary print - [ quots>> ] [ branches>> [ length ] { } assoc>map ] bi zip + [ quots>> ] [ branches>> [ length [ "x" ] bi@ ] { } assoc>map ] bi zip [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ; M: too-many->r summary diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index 38ac2b0e71..20d61b9c37 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry namespaces assocs kernel sequences words accessors definitions math math.order effects classes arrays combinators @@ -42,7 +42,7 @@ loop? ; : make-copies ( values effect-in -- values' ) [ length cut* ] keep [ quotation-param? [ copy-value ] [ drop ] if ] 2map - [ make-values ] dip append ; + [ length make-values ] dip append ; SYMBOL: enter-in SYMBOL: enter-out diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 316ae6ca2f..b217f4d659 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2009 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2004, 2010 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors alien alien.accessors arrays byte-arrays classes continuations.private effects generic hashtables @@ -153,7 +153,7 @@ M: bad-executable summary : infer- ( -- ) \ - peek-d literal value>> second 1 + { tuple } + peek-d literal value>> second 1 + "obj" { tuple } apply-word/effect ; \ [ infer- ] "special" set-word-prop @@ -228,6 +228,7 @@ M: bad-executable summary \ alien-invoke [ infer-alien-invoke ] "special" set-word-prop \ alien-indirect [ infer-alien-indirect ] "special" set-word-prop +\ alien-assembly [ infer-alien-assembly ] "special" set-word-prop \ alien-callback [ infer-alien-callback ] "special" set-word-prop : infer-special ( word -- ) @@ -488,10 +489,10 @@ M: bad-executable summary \ word-xt { word } { integer integer } define-primitive \ word-xt make-flushable -\ getenv { fixnum } { object } define-primitive -\ getenv make-flushable +\ special-object { fixnum } { object } define-primitive +\ special-object make-flushable -\ setenv { object fixnum } { } define-primitive +\ set-special-object { object fixnum } { } define-primitive \ (exists?) { string } { object } define-primitive diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index cc4a688f7a..eb25b9be57 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -11,14 +11,14 @@ IN: stack-checker ARTICLE: "inference-simple" "Straight-line stack effects" "The simplest case is when a piece of code does not have any branches or recursion, and just pushes literals and calls words." $nl -"Pushing a literal has stack effect " { $snippet "( -- object )" } ". The stack effect of a most words is always known statically from the declaration. Stack effects of " { $link POSTPONE: inline } " words and " { $link "macros" } ", may depend on literals pushed on the stack prior to the call, and this case is discussed in " { $link "inference-combinators" } "." +"Pushing a literal has stack effect " { $snippet "( -- x )" } ". The stack effect of a most words is always known statically from the declaration. Stack effects of " { $link POSTPONE: inline } " words and " { $link "macros" } ", may depend on literals pushed on the stack prior to the call, and this case is discussed in " { $link "inference-combinators" } "." $nl "The stack effect of each element in a code snippet is composed. The result is then the stack effect of the snippet." $nl "An example:" -{ $example "[ 1 2 3 ] infer." "( -- object object object )" } +{ $example "[ 1 2 3 ] infer." "( -- x x x )" } "Another example:" -{ $example "[ 2 + ] infer." "( object -- object )" } ; +{ $example "[ 2 + ] infer." "( x -- x )" } ; ARTICLE: "inference-combinators" "Combinator stack effects" "If a word calls a combinator, one of the following two conditions must hold for the stack checker to succeed:" @@ -30,15 +30,15 @@ ARTICLE: "inference-combinators" "Combinator stack effects" { $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 "USING: math sequences ;" "[ [ + ] curry map ] infer." "( object object -- object )" } +{ $example "USING: math sequences ;" "[ [ + ] curry map ] infer." "( x x -- x )" } "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 )" } +{ $example "USING: fry math sequences ;" "[ '[ _ + ] map ] infer." "( x x -- x )" } +{ $example "USING: locals math sequences ;" "[| a | [ a + ] map ] infer." "( x x -- x )" } { $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" } "The following code now passes the stack checker; it would fail were " { $snippet "twice" } " not declared " { $link POSTPONE: inline } ":" -{ $unchecked-example "USE: math.functions" "[ [ sqrt ] twice ] infer." "( object -- object )" } +{ $unchecked-example "USE: math.functions" "[ [ sqrt ] twice ] infer." "( x -- x )" } { $subheading "Defining a combinator for unknown quotations" } "In the next example, " { $link POSTPONE: call( } " must be used because the quotation the result of calling a runtime accessor, and the compiler cannot make any static assumptions about this quotation at all:" { $code @@ -61,14 +61,14 @@ $nl } "To make this work, use " { $link dip } " to pass the quotation instead:" { $example - "[ [ reverse ] [ [ reverse ] map ] dip call ] infer." "( object -- object )" + "[ [ reverse ] [ [ reverse ] map ] dip call ] infer." "( x -- x )" } ; ARTICLE: "inference-branches" "Branch stack effects" "Conditionals such as " { $link if } " and combinators built on top have the same restrictions as " { $link POSTPONE: inline } " combinators (see " { $link "inference-combinators" } ") with the additional requirement that all branches leave the stack at the same height. If this is not the case, the stack checker throws a " { $link unbalanced-branches-error } "." $nl "If all branches leave the stack at the same height, then the stack effect of the conditional is just the maximum of the stack effect of each branch. For example," -{ $example "[ [ + ] [ drop ] if ] infer." "( object object object -- object )" } +{ $example "[ [ + ] [ drop ] if ] infer." "( x x x -- x )" } "The call to " { $link if } " takes one value from the stack, a generalized boolean. The first branch " { $snippet "[ + ]" } " has stack effect " { $snippet "( x x -- x )" } " and the second has stack effect " { $snippet "( x -- )" } ". Since both branches decrease the height of the stack by one, we say that the stack effect of the two branches is " { $snippet "( x x -- x )" } ", and together with the boolean popped off the stack by " { $link if } ", this gives a total stack effect of " { $snippet "( x x x -- x )" } "." ; ARTICLE: "inference-recursive-combinators" "Recursive combinator stack effects" @@ -87,7 +87,7 @@ $nl "An inline recursive word cannot pass a quotation on the data stack through the recursive call. For example, the following will not infer:" { $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 -- )" } +{ $example ": good ( ? quot: ( ? -- ) -- ) [ good ] 2keep [ not ] dip call ; inline recursive" "[ [ drop ] good ] infer." "( x -- )" } "An inline recursive word must have a fixed stack effect in its base case. The following will not infer:" { $code ": foo ( quot ? -- ) [ f foo ] [ call ] if ; inline" diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 6af0ec64e5..8a0724556e 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -289,21 +289,21 @@ DEFER: an-inline-word ERROR: custom-error ; -[ T{ effect f 0 0 t } ] [ +[ T{ effect f { } { } t } ] [ [ custom-error ] infer ] unit-test : funny-throw ( a -- * ) throw ; inline -[ T{ effect f 0 0 t } ] [ +[ T{ effect f { } { } t } ] [ [ 3 funny-throw ] infer ] unit-test -[ T{ effect f 0 0 t } ] [ +[ T{ effect f { } { } t } ] [ [ custom-error inference-error ] infer ] unit-test -[ T{ effect f 1 2 t } ] [ +[ T{ effect f { "x" } { "x" "x" } t } ] [ [ dup [ 3 throw ] dip ] infer ] unit-test @@ -392,5 +392,5 @@ DEFER: eee' [ [ 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 -[ \ set-callstack def>> infer ] [ T{ unknown-primitive-error } = ] must-fail-with -[ ] [ [ \ set-callstack def>> infer ] try ] unit-test +[ \ set-datastack def>> infer ] [ T{ unknown-primitive-error } = ] must-fail-with +[ ] [ [ \ set-datastack def>> infer ] try ] unit-test diff --git a/basis/stack-checker/stack-checker.factor b/basis/stack-checker/stack-checker.factor index fe52357f9e..12e8660900 100644 --- a/basis/stack-checker/stack-checker.factor +++ b/basis/stack-checker/stack-checker.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2004, 2009 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel io effects namespaces sequences quotations vocabs -vocabs.loader generic words stack-checker.backend stack-checker.state +USING: accessors kernel io effects namespaces sequences +quotations vocabs vocabs.loader generic words +stack-checker.backend stack-checker.state stack-checker.known-words stack-checker.transforms stack-checker.errors stack-checker.inlining stack-checker.visitor.dummy ; @@ -15,3 +16,7 @@ M: callable infer ( quot -- effect ) : infer. ( quot -- ) #! Safe to call from inference transforms. infer effect>string print ; + +: inputs ( quot -- n ) infer in>> length ; + +: outputs ( quot -- n ) infer out>> length ; diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 1c527abfe4..f0b595ebe5 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs arrays namespaces sequences kernel definitions math effects accessors words fry classes.algebra @@ -38,7 +38,9 @@ SYMBOL: literals : current-stack-height ( -- n ) meta-d length input-count get - ; : current-effect ( -- effect ) - input-count get meta-d length terminated? get effect boa ; + input-count get "x" + meta-d length "x" + terminated? get effect boa ; : init-inference ( -- ) terminated? off diff --git a/basis/stack-checker/visitor/dummy/dummy.factor b/basis/stack-checker/visitor/dummy/dummy.factor index 5f05d97d1a..871f79d320 100644 --- a/basis/stack-checker/visitor/dummy/dummy.factor +++ b/basis/stack-checker/visitor/dummy/dummy.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: stack-checker.visitor kernel ; IN: stack-checker.visitor.dummy @@ -24,4 +24,5 @@ M: f #copy, 2drop ; M: f #drop, drop ; M: f #alien-invoke, drop ; M: f #alien-indirect, drop ; +M: f #alien-assembly, drop ; M: f #alien-callback, drop ; diff --git a/basis/stack-checker/visitor/visitor.factor b/basis/stack-checker/visitor/visitor.factor index 6093cd008a..d4207caf5b 100644 --- a/basis/stack-checker/visitor/visitor.factor +++ b/basis/stack-checker/visitor/visitor.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel arrays namespaces ; IN: stack-checker.visitor @@ -29,4 +29,5 @@ HOOK: #recursive, stack-visitor ( label inputs visitor -- ) HOOK: #copy, stack-visitor ( inputs outputs -- ) HOOK: #alien-invoke, stack-visitor ( params -- ) HOOK: #alien-indirect, stack-visitor ( params -- ) +HOOK: #alien-assembly, stack-visitor ( params -- ) HOOK: #alien-callback, stack-visitor ( params -- ) diff --git a/basis/strings/tables/tables.factor b/basis/strings/tables/tables.factor index 51032264c7..19d0051d17 100644 --- a/basis/strings/tables/tables.factor +++ b/basis/strings/tables/tables.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences fry math.order splitting ; IN: strings.tables @@ -6,7 +6,7 @@ IN: strings.tables ] dip '[ 0 = @ ] 2map ; inline + [ dup length iota ] dip '[ 0 = @ ] 2map ; inline : max-length ( seq -- n ) [ length ] [ max ] map-reduce ; diff --git a/basis/suffix-arrays/suffix-arrays.factor b/basis/suffix-arrays/suffix-arrays.factor index f486adcb32..134c144fda 100644 --- a/basis/suffix-arrays/suffix-arrays.factor +++ b/basis/suffix-arrays/suffix-arrays.factor @@ -7,7 +7,7 @@ IN: suffix-arrays ( begin seq -- <=> ) [ <=> ] [ swap head? ] 2bi [ drop +eq+ ] when ; diff --git a/basis/threads/threads-tests.factor b/basis/threads/threads-tests.factor index 79aad20b85..4568b7c491 100644 --- a/basis/threads/threads-tests.factor +++ b/basis/threads/threads-tests.factor @@ -1,6 +1,6 @@ USING: namespaces io tools.test threads kernel concurrency.combinators concurrency.promises locals math -words ; +words calendar sequences ; IN: threads.tests 3 "x" set @@ -20,7 +20,7 @@ yield [ f ] [ f get-global ] unit-test { { 0 3 6 9 12 15 18 21 24 27 } } [ - 10 [ + 10 iota [ 0 "i" tset [ "i" [ yield 3 + ] tchange @@ -42,3 +42,5 @@ yield [ t ] [ spawn-namespace-test ] unit-test [ "a" [ 1 1 + ] spawn 100 sleep ] must-fail + +[ ] [ 0.1 seconds sleep ] unit-test diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 9d1cd29337..952652d801 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -21,7 +21,7 @@ mailbox variables sleep-entry ; -: self ( -- thread ) 63 getenv ; inline +: self ( -- thread ) 63 special-object ; inline ! Thread-local storage : tnamespace ( -- assoc ) @@ -36,7 +36,7 @@ sleep-entry ; : tchange ( key quot -- ) tnamespace swap change-at ; inline -: threads ( -- assoc ) 64 getenv ; +: threads ( -- assoc ) 64 special-object ; : thread ( id -- thread ) threads at ; @@ -61,7 +61,7 @@ ERROR: not-running thread ; : unregister-thread ( thread -- ) check-registered id>> threads delete-at ; -: set-self ( thread -- ) 63 setenv ; inline +: set-self ( thread -- ) 63 set-special-object ; inline PRIVATE> @@ -75,9 +75,9 @@ PRIVATE> : ( quot name -- thread ) \ thread new-thread ; -: run-queue ( -- dlist ) 65 getenv ; +: run-queue ( -- dlist ) 65 special-object ; -: sleep-queue ( -- heap ) 66 getenv ; +: sleep-queue ( -- heap ) 66 special-object ; : resume ( thread -- ) f >>state @@ -216,9 +216,9 @@ GENERIC: error-in-thread ( error thread -- ) 65 setenv - 66 setenv + H{ } clone 64 set-special-object + 65 set-special-object + 66 set-special-object initial-thread global [ drop [ ] "Initial" ] cache >>continuation diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index ea02aa03c9..06009992ad 100644 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -393,7 +393,7 @@ IN: tools.deploy.shaker '[ drop _ member? not ] assoc-filter [ drop string? not ] assoc-filter ! strip CLI args sift-assoc - 21 setenv + 21 set-special-object ] [ drop ] if ; : strip-c-io ( -- ) @@ -518,7 +518,7 @@ SYMBOL: deploy-vocab strip-c-io strip-default-methods strip-compiler-classes - f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore + f 5 set-special-object ! we can't use the Factor debugger or Factor I/O anymore deploy-vocab get vocab-main deploy-startup-quot find-megamorphic-caches stripped-word-props diff --git a/basis/tools/deploy/shaker/strip-cocoa.factor b/basis/tools/deploy/shaker/strip-cocoa.factor index d5c5bd54da..7bb2f651dc 100644 --- a/basis/tools/deploy/shaker/strip-cocoa.factor +++ b/basis/tools/deploy/shaker/strip-cocoa.factor @@ -17,7 +17,7 @@ IN: cocoa.application : objc-error ( error -- ) die ; -[ [ die ] 19 setenv ] "cocoa.application" add-startup-hook +[ [ die ] 19 set-special-object ] "cocoa.application" add-startup-hook H{ } clone \ pool [ global [ diff --git a/basis/tr/tr.factor b/basis/tr/tr.factor index f75adcbf04..690103edf5 100644 --- a/basis/tr/tr.factor +++ b/basis/tr/tr.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays strings sequences sequences.private ascii fry kernel words parser lexer assocs math math.order summary ; @@ -17,7 +17,7 @@ M: bad-tr summary [ [ ascii? ] all? ] both? [ bad-tr ] unless ; : compute-tr ( quot from to -- mapping ) - [ 128 ] 3dip zip + [ 128 iota ] 3dip zip '[ [ _ call( x -- y ) _ at ] keep or ] B{ } map-as ; inline : tr-hints ( word -- ) diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor index 92e7541616..1bc6270524 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -10,7 +10,7 @@ IN: tuple-arrays MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ ] ; -MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ; +MACRO: infer-in ( class -- quot ) inputs '[ _ ] ; : tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline @@ -28,7 +28,7 @@ MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ; MACRO: write-tuple ( class -- quot ) [ '[ [ _ boa ] undo ] ] - [ tuple-arity [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ] + [ tuple-arity iota [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ] bi '[ _ dip @ ] ; PRIVATE> diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor index d7f77d9e54..ea16abb9ba 100644 --- a/basis/ui/gadgets/gadgets-tests.factor +++ b/basis/ui/gadgets/gadgets-tests.factor @@ -123,7 +123,7 @@ M: mock-gadget ungraft* over >>model "g" get over add-gadget drop swap 1 + number>string set - ] each ; + ] each-integer ; : status-flags ( -- seq ) { "g" "1" "2" "3" } [ get graft-state>> ] map prune ; diff --git a/basis/ui/gadgets/packs/packs-tests.factor b/basis/ui/gadgets/packs/packs-tests.factor index b49f46c05a..7ca83ce465 100644 --- a/basis/ui/gadgets/packs/packs-tests.factor +++ b/basis/ui/gadgets/packs/packs-tests.factor @@ -1,14 +1,14 @@ USING: ui.gadgets.packs ui.gadgets.packs.private ui.gadgets.labels ui.gadgets ui.gadgets.debug ui.render ui.baseline-alignment kernel namespaces tools.test math.parser -sequences math.rectangles accessors ; +sequences math.rectangles accessors math ; IN: ui.gadgets.packs.tests [ t ] [ { 0 0 } { 100 100 } clip set - 100 [ number>string