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
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 )
[ write1-lines ] each ;
: encode3 ( seq -- )
- be> 4 <reversed> [
+ be> 4 iota <reversed> [
-6 * shift HEX: 3f bitand ch>base64 write1-lines
] with each ; inline
-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
[ 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
100 [
drop 100 [ 2 random zero? ] replicate
dup >bit-array >array =
- ] all?
+ ] all-integers?
] unit-test
[ ?{ f } ] [
-! 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
: (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.
] if ;
: bit-array>integer ( bit-array -- n )
- 0 swap underlying>> dup length <reversed> [
+ 0 swap underlying>> dup length iota <reversed> [
alien-unsigned-1 swap 8 shift bitor
] with each ;
[ 0 ] [ 123 <bit-vector> length ] unit-test\r
\r
: do-it ( seq -- )\r
- 1234 swap [ [ even? ] dip push ] curry each ;\r
+ 1234 swap [ [ even? ] dip push ] curry each-integer ;\r
\r
[ t ] [\r
3 <bit-vector> dup do-it\r
-! 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
CONSTANT: data-base 1024
-CONSTANT: userenv-size 70
+CONSTANT: special-objects-size 70
CONSTANT: header-size 10
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
-
-USERENV: c-to-factor-word 42
-USERENV: lazy-jit-compile-word 43
-USERENV: unwind-native-frames-word 44
-
-USERENV: callback-stub 48
+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
+
+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 ;
: 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 + ;
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
\ 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 ;
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
-! 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
-! Copyright (C) 2008 Slava Pestov.\r
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: math math.order math.parser math.functions kernel\r
sequences io accessors arrays io.streams.string splitting\r
[\r
[ 1 + day. ] keep\r
1 + + 7 mod zero? [ nl ] [ bl ] if\r
- ] with each nl ;\r
+ ] with each-integer nl ;\r
\r
M: timestamp month. ( timestamp -- )\r
[ year>> ] [ month>> ] bi 2array month. ;\r
GENERIC: year. ( obj -- )\r
\r
M: integer year. ( n -- )\r
- 12 [ 1 + 2array month. nl ] with each ;\r
+ 12 [ 1 + 2array month. nl ] with each-integer ;\r
\r
M: timestamp year. ( timestamp -- )\r
year>> year. ;\r
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
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 -- )
! 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
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.
-! 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
(free) ;
: method-arg-types ( method -- args )
- dup method_getNumberOfArguments
+ dup method_getNumberOfArguments iota
[ method-arg-type ] with map ;
: method-return-type ( method -- ctype )
[ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
[ ] [ "seq" get 1 <column> [ sq ] map! drop ] unit-test
[ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
+
+[ { { 1 3 } { 2 4 } } ] [ { { 1 2 } { 3 4 } } <flipped> [ >array ] map ] unit-test
-! 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
INSTANCE: column virtual-sequence
: <flipped> ( seq -- seq' )
- dup empty? [ dup first length [ <column> ] with map ] unless ;
+ dup empty? [ dup first length [ <column> ] with { } map-integers ] unless ;
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<sequence ( quot -- newquot )
- [ infer in>> ] keep
+ [ inputs ] keep
'[ _ firstn @ ] ;
MACRO: input<sequence-unsafe ( quot -- newquot )
- [ infer in>> ] 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
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
-! 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
"pure-insn" "compiler.cfg.instructions" lookup ;
: insn-effect ( word -- effect )
- boa-effect in>> but-last f <effect> ;
+ boa-effect in>> but-last { } <effect> ;
: 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 <effect> define-declared ;
+ [ name>> ] map { } <effect> define-declared ;
: define-insn ( class superclass specs -- )
parse-insn-slot-specs {
-! 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
[ [ ^^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-<array>? ( obj -- ? )
dup integer? [ 0 8 between? ] [ drop f ] if ;
{
{ 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+ ] }
: 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 ;
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 )
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 -- )
-! 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
: ds-load ( n -- vregs )
dup 0 =
[ drop f ]
- [ [ <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
+ [ [ iota <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
: ds-store ( vregs -- )
[
-! 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
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>
[ [ 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 <reversed> ] tri ;
: unbox-parameters ( offset node -- )
parameters>> swap
TUPLE: callback-context ;
-: current-callback ( -- id ) 2 getenv ;
+: current-callback ( -- id ) 2 special-object ;
: wait-to-return ( token -- )
dup current-callback eq? [
: 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 )
-! 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
: 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 ;
{ 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
{ 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 ;
: 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
[ 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
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
! 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
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
[ 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
[ 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
[ 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
[ ] [
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
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 )
: 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 -- * )
] if ; inline recursive
[ 10 ] [
- 10 20 >vector <flat-slice>
+ 10 20 iota <flat-slice>
[ [ - ] swap old-binsearch ] compile-call 2nip
] unit-test
[ 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
[ 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 <array>
+ [
+ [ 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
] 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
[ t ] [
[
- { integer } declare [ 0 >= ] map
+ { integer } declare iota [ 0 >= ] map
] { >= fixnum>= } inlined?
] unit-test
-! 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
: drop-indexed-values ( values indices -- node )
[ drop filter-live ] [ swap nths ] 2bi
- [ make-values ] keep
+ [ length make-values ] keep
[ drop ] [ zip ] 2bi
#data-shuffle ;
-! 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
:: 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 ;
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
-! 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
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
M: shuffle-node pprint* effect>> effect>string text ;
: (shuffle-effect) ( in out #shuffle -- effect )
- mapping>> '[ _ at ] map <effect> ;
+ mapping>> '[ _ at ] map [ >array ] bi@ <effect> ;
: shuffle-effect ( #shuffle -- effect )
[ in-d>> ] [ out-d>> ] [ ] tri (shuffle-effect) ;
-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
H{ } clone allocations set
<escaping-values> escaping-values set
-[ ] [ 8 [ introduce-value ] each ] unit-test
+[ ] [ 8 [ introduce-value ] each-integer ] unit-test
[ ] [ { 1 2 } 3 record-allocation ] unit-test
[ t ] [
[
- { fixnum } declare 0 swap
+ { fixnum } declare iota 0 swap
[
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
] map
[ t ] [
[
- { integer } declare [ 256 mod ] map
+ { integer } declare iota [ 256 mod ] map
] { mod fixnum-mod } inlined?
] unit-test
-! 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
] 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
-! 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
M: effect curry-effect
[ in>> length ] [ out>> length ] [ terminated?>> ] tri
pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
- effect boa ;
+ [ [ "x" <array> ] bi@ ] dip effect boa ;
M: curry cached-effect
quot>> cached-effect curry-effect ;
[ f ] [ 0.0 -0.0 eql? ] unit-test
-[ t ] [
- number <class-info>
- sequence <class-info>
- value-info-intersect
- class>> integer class=
-] unit-test
-
[ t t ] [
0 10 [a,b] <interval-info>
5 20 [a,b] <interval-info>
-! 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
{ + - * / }
[ { 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
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
[ 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 } ] [
] 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
] 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 } ] [
! 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
: (fold-call) ( #call word -- info )
[ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi*
'[ _ _ with-datastack [ <literal-info> ] map nip ]
- [ drop [ object-info ] replicate ]
+ [ drop length [ object-info ] replicate ]
recover ;
: fold-call ( #call word -- )
-! 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
] "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>> {
\ 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
} 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
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 <huffman-decoder>
[ 2dup + ] dip swap :> k!
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
{
[ error>> "Even" = ] must-fail-with\r
\r
[ V{ 0 3 6 9 } ]\r
-[ 10 [ 3 mod zero? ] parallel-filter ] unit-test\r
+[ 10 iota [ 3 mod zero? ] parallel-filter ] unit-test\r
\r
[ 10 ]\r
[\r
V{ } clone\r
- 10 over [ push ] curry parallel-each\r
+ 10 iota over [ push ] curry parallel-each\r
length\r
] unit-test\r
\r
[ 20 ]\r
[\r
V{ } clone\r
- 10 10 pick [ [ push ] [ push ] bi ] curry 2parallel-each\r
+ 10 iota 10 iota pick [ [ push ] [ push ] bi ] curry 2parallel-each\r
length\r
] unit-test\r
\r
1 1 callback-frame-size neg STWU\r
0 1 callback-frame-size lr-save + STW\r
\r
- nv-int-regs [ cells save-int ] each-index\r
+ nv-int-regs [ 4 * save-int ] each-index\r
nv-fp-regs [ 8 * 80 + save-fp ] each-index\r
nv-vec-regs [ 16 * 224 + save-vec ] each-index\r
\r
- 0 vm-reg LOAD32 rt-vm rc-absolute-ppc-2/2 jit-rel\r
+ 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel\r
\r
0 2 LOAD32 rc-absolute-ppc-2/2 rt-xt jit-rel\r
2 MTLR\r
\r
nv-vec-regs [ 16 * 224 + restore-vec ] each-index\r
nv-fp-regs [ 8 * 80 + restore-fp ] each-index\r
- nv-int-regs [ cells restore-int ] each-index\r
+ nv-int-regs [ 4 * restore-int ] each-index\r
\r
0 1 callback-frame-size lr-save + LWZ\r
1 1 0 LWZ\r
\r
: jit-save-context ( -- )\r
jit-load-context\r
- 1 2 context-callstack-top-offset STW\r
+ 1 ctx-reg context-callstack-top-offset STW\r
ds-reg ctx-reg context-datastack-offset STW\r
rs-reg ctx-reg context-retainstack-offset STW ;\r
\r
] jit-profiling jit-define\r
\r
[\r
- 0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel\r
+ 0 2 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel\r
0 MFLR\r
1 1 stack-frame SUBI\r
- 3 1 xt-save STW\r
- stack-frame 3 LI\r
- 3 1 next-save STW\r
+ 2 1 xt-save STW\r
+ stack-frame 2 LI\r
+ 2 1 next-save STW\r
0 1 lr-save stack-frame + STW\r
] jit-prolog jit-define\r
\r
! Unwind stack frames\r
1 4 MR\r
\r
+ ! Load VM pointer into vm-reg, since we're entering from\r
+ ! C code\r
+ 0 vm-reg LOAD32 0 rc-absolute-ppc-2/2 jit-vm\r
+\r
! Load ds and rs registers\r
jit-restore-context\r
\r
! We have changed the stack; load return address again\r
- 0 1 stack-frame lr-save + LWZ\r
+ 0 1 lr-save LWZ\r
0 MTLR\r
\r
! Call quotation\r
5 6 callstack-length-offset LWZ\r
5 5 tag-bits get SRAWI\r
! Compute new stack pointer -- 'dst' for memcpy\r
- 3 3 5 SUBF\r
+ 3 5 3 SUBF\r
! Install new stack pointer\r
1 3 MR\r
! Call memcpy; arguments are now in the correct registers\r
BLRL\r
1 1 0 LWZ\r
! Return with new callstack\r
- 0 1 lr-save stack-frame + LWZ\r
+ 0 1 lr-save LWZ\r
0 MTLR\r
BLR\r
] \ set-callstack define-sub-primitive\r
[\r
jit-save-context\r
4 vm-reg MR\r
- 2 0 LOAD32 "lazy_jit_compile" f rc-absolute-ppc-2/2 jit-dlsym\r
+ 0 2 LOAD32 "lazy_jit_compile" f rc-absolute-ppc-2/2 jit-dlsym\r
2 MTLR\r
BLRL\r
5 3 quot-xt-offset LWZ\r
! 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
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 ;
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 ;
{ 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 -- )
! 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
[ 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 ( -- )
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 ( -- )
"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 ] }
! 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
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? [
] 2map >>bind-params ;
M: retryable execute-statement* ( statement type -- )
- drop [ retries>> ] [
+ drop [ retries>> iota ] [
[
nip
[ query-results dispose t ]
test-2 ensure-table
] with-db
] [
- 10 [
+ 10 iota [
drop
10 [
dup [
] with-db
] [
<db-pool> [
- 10 [
+ 10 iota [
10 [
test-1-tuple insert-tuple yield
] times
100 [
drop random-markup
[ convert-farkup drop t ] [ drop print f ] recover
- ] all?
+ ] all-integers?
] unit-test
[ "<p><a href=\"http://foo.com/~foo\">http://foo.com/~foo</a></p>" ] [ "[[http://foo.com/~foo]]" convert-farkup ] unit-test
[ "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 } } } ] [
{ 3 5 } [ 2 nweave ] must-infer-as\r
\r
[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ]\r
-[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test\r
+[ 9 [ ] each-integer { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test\r
\r
[ 1 2 3 4 1 2 3 ] [ 1 2 3 4 3 nover ] unit-test\r
\r
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences grouping ;"
- "9 >array 3 <groups> reverse! concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
+ "9 iota >array 3 <groups> reverse! concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
}
{ $example
"USING: kernel prettyprint sequences grouping ;"
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences grouping ;"
- "9 >array 3 <sliced-groups>"
+ "9 iota >array 3 <sliced-groups>"
"dup [ reverse! drop ] each concat >array ."
"{ 2 1 0 5 4 3 8 7 6 }"
}
<min-heap> [ heap-push-all ] keep heap-pop-all ;
: random-alist ( n -- alist )
- [
+ iota [
drop 32 random-bits dup number>string
] H{ } map>assoc ;
14 [
[ t ] swap [ 2^ test-heap-sort ] curry unit-test
-] each
+] each-integer
: test-entry-indices ( n -- ? )
random-alist
<min-heap> [ 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 ;
11 [
[ t ] swap [ 2^ delete-test sequence= ] curry unit-test
-] each
+] each-integer
-! 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
"specializer" word-prop ;
: make-specializer ( specs -- quot )
- dup length <reversed>
+ dup length iota <reversed>
[ (picker) 2array ] 2map
[ drop object eq? not ] assoc-filter
[ [ t ] ] [
data>>
binary
[
- read1 [0,b)
+ read1 iota
[ drop
read1 jpeg> color-info>> nth clone
read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
{ 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 ;
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 ] }
IN: images.processing\r
\r
: coord-matrix ( dim -- m )\r
- [ [0,b) ] map first2 [ [ 2array ] with map ] curry map ;\r
+ [ iota ] map first2 [ [ 2array ] with map ] curry map ;\r
\r
: map^2 ( m quot -- m' ) '[ _ map ] map ; inline\r
: each^2 ( m quot -- m' ) '[ _ each ] each ; inline\r
: matrix>image ( m -- image )\r
<image> over matrix-dim >>dim\r
swap flip flatten\r
- [ 128 * 128 + 0 max 255 min >fixnum ] map\r
+ [ 128 * 128 + 0 255 clamp >fixnum ] map\r
>byte-array >>bitmap L >>component-order ubyte-components >>component-type ;\r
\r
:: matrix-zoom ( m f -- m' )\r
:: draw-grey ( value x,y image -- )\r
x,y image image-offset 3 * { 0 1 2 }\r
[\r
- + value 128 + >fixnum 0 max 255 min swap image bitmap>> set-nth\r
+ + value 128 + >fixnum 0 255 clamp swap image bitmap>> set-nth\r
] with each ;\r
\r
:: draw-color ( value x,y color-id image -- )\r
-! 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
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 ;
: enough? ( stack word -- ? )
dup deferred? [ 2drop f ] [
- [ [ length ] [ 1quotation infer in>> ] bi* >= ]
+ [ [ length ] [ 1quotation inputs ] bi* >= ]
[ 3drop f ] recover
] if ;
] 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 ;
"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 ;
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 ] [
: 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 )
'[
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
-! 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>> ;
i 1 + j 1 + matrix nth set-nth ; inline\r
\r
: lcs-initialize ( |str1| |str2| -- matrix )\r
- [ drop 0 <array> ] with map ;\r
+
iota [ drop 0 <array> ] with map ;
\r \r
: levenshtein-initialize ( |str1| |str2| -- matrix )\r
- [ [ + ] curry map ] with map ;\r
+ [ iota ] bi@ [ [ + ] curry map ] with map ;\r
\r
:: run-lcs ( old new init step -- matrix )\r
old length 1 + new length 1 + init call :> matrix\r
- old length [| i |\r
- new length\r
+ old length iota [| i |\r
+ new length iota\r
[| j | i j matrix old new step loop-step ] each\r
] each matrix ; inline\r
PRIVATE>\r
stack get pop end
[ [ expand-macros ] [ ] map-as '[ _ dip ] % ]
[
- length [ <reversed> ] keep
+ length iota [ <reversed> ] keep
[ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
] bi ;
{ $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\" }" }
} ;
{ $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
[ 0 ] [ 9 5 iota 3 <combo> dual-index ] unit-test
[ 179 ] [ 72 10 iota 5 <combo> dual-index ] unit-test
-[ { 5 3 2 1 } ] [ 7 4 <combo> 8 combinadic ] unit-test
+[ { 5 3 2 1 } ] [ 7 iota 4 <combo> 8 combinadic ] unit-test
[ { 4 3 2 1 0 } ] [ 10 iota 5 <combo> 0 combinadic ] unit-test
[ { 8 6 3 1 0 } ] [ 10 iota 5 <combo> 72 combinadic ] unit-test
[ { 9 8 7 6 5 } ] [ 10 iota 5 <combo> 251 combinadic ] unit-test
-! 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 ;
PRIVATE>
: factorial ( n -- n! )
- 1 [ 1 + * ] reduce ;
+ iota 1 [ 1 + * ] reduce ;
: nPk ( n k -- nPk )
2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
[ 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 )
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 )
[ combination-indices ] keep seq>> nths ;
: combinations-quot ( seq k quot -- seq quot )
- [ <combo> [ choose [0,b) ] keep ] dip
+ [ <combo> [ choose iota ] keep ] dip
'[ _ apply-combination @ ] ; inline
PRIVATE>
[ ] [ 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
-! 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 ;
M: real exp >float exp ; inline
-M: complex exp >rect swap fexp swap polar> ; inline
+M: complex exp >rect swap exp swap polar> ; inline
<PRIVATE
] if ;
unary-ops [
- [ [ t ] ] dip '[ 8000 iota [ drop _ unary-test ] all? ] unit-test
+ [ [ t ] ] dip '[ 8000 [ drop _ unary-test ] all-integers? ] unit-test
] each
: binary-ops ( -- alist )
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel locals math math.vectors math.matrices
namespaces sequences fry sorting ;
[ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;
: rows-from ( row# -- slice )
- rows dup <slice> ;
+ rows dup iota <slice> ;
: clear-col ( col# row# rows -- )
[ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;
: reduced ( matrix' -- matrix'' )
[
- rows <reversed> [
+ rows iota <reversed> [
dup nth-row leading drop
- dup [ swap dup clear-col ] [ 2drop ] if
+ dup [ swap dup iota clear-col ] [ 2drop ] if
] each
] with-matrix ;
-! 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
: 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
2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ;
: p* ( p q -- r )
- 2unempty pextend-conv <reversed> dup length
+ 2unempty pextend-conv <reversed> dup length iota
[ over length pick <slice> pick [ * ] 2map sum ] map 2nip reverse ;
: p-sq ( p -- p^2 )
[ 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
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 = [
A{ DEFINES ${A}{
N [ A-rep rep-length ]
-BOA-EFFECT [ N 2 * "n" <repetition> >array { "v" } <effect> ]
+BOA-EFFECT [ N 2 * "n" <array> { "v" } <effect> ]
WHERE
[ >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 '[ _ ] ] [ <rep-array> ] bi replicate-as
+ [ rep-length swap '[ _ ] ] [ <rep-array> ] bi replicate-as
underlying>> ;
: (simd-gather-2) ( m n rep -- v ) <rep-array> [ 2 set-firstn ] keep underlying>> ;
: (simd-gather-4) ( m n o p rep -- v ) <rep-array> [ 4 set-firstn ] keep underlying>> ;
"== 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
! 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
"== 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
SET-NTH [ ELT dup c:c-setter c:array-accessor ]
-BOA-EFFECT [ N "n" <repetition> >array { "v" } <effect> ]
+BOA-EFFECT [ N "n" <array> { "v" } <effect> ]
WHERE
GENERIC: v/ ( u v -- w )
M: object v/ [ / ] 2map ;
-<PRIVATE
-
-: if-both-floats ( x y p q -- )
- [ 2dup [ float? ] both? ] 2dip if ; inline
-
-PRIVATE>
-
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+-
-! 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: <smart-arrow> ( quot -- quot' )
- [ infer in>> dup ] keep
+ [ inputs dup ] keep
'[ _ narray <product> [ _ firstn @ ] <arrow> ] ;
\ No newline at end of file
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
] [ \r
[\r
"FROM: locals => [let :> ; FROM: sequences => nth ; [let " %\r
- dup length [\r
+ [\r
over ebnf-var? [\r
" " % # " over nth :> " %\r
name>> % \r
] [\r
2drop\r
] if\r
- ] 2each\r
+ ] each-index\r
" " %\r
% \r
" nip ]" % \r
] 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
] 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 ]
] 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
] 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 < [
-! 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
: 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
: 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 ;
[ 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
: 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
: 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 <uint-array>
{ $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 ."
[ 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
[ { 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
: 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 ;
: 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 ;
zip [ first ] partition [ values ] bi@ parts boa ;
: powerset-partition ( sequence -- partitions )
- [ length [ 2^ ] keep ] keep '[
- _ <bits> _ make-partition
- ] map rest ;
+ [ length [ 2^ iota ] keep ] keep '[ _ <bits> _ make-partition ] map rest ;
: partition>class ( parts -- class )
[ out>> [ <not-class> ] map ]
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
} ;
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
} ;
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
{ >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 ;"
} ;
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 ;"
{ 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 ;"
} ;
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 ;"
} ;
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 ;"
<PRIVATE
MACRO: binary-roman-op ( quot -- quot' )
- [ infer in>> ] [ ] [ infer out>> ] tri
+ [ inputs ] [ ] [ outputs ] tri
'[ [ roman> ] _ napply @ [ >roman ] _ napply ] ;
PRIVATE>
SYNTAX: ROMAN-OP:
scan-word [ name>> "roman" prepend create-in ] keep
1quotation '[ _ binary-roman-op ]
- dup infer [ in>> ] [ out>> ] bi
- [ "string" <repetition> ] bi@ <effect> define-declared ;
+ dup infer define-declared ;
>>
[ 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 ;
[ ] 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
<PRIVATE
: >index-assoc ( sequence -- assoc )
- dup length zip >hashtable ;
+ dup length iota zip >hashtable ;
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
! 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 ;
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
[ { } ]
{ 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
: (monotonic-slice) ( seq quot class -- slices )
[
dupd '[
- [ length ] [ ] [ <circular> 1 over change-circular-start ] tri
+ [ length iota ] [ ] [ <circular> 1 over change-circular-start ] tri
[ @ not [ , ] [ drop ] if ] 3each
] { } make
dup empty? [ over length 1 - prefix ] when -1 prefix 2 clump
-! 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
M: unbalanced-branches-error error.
dup summary print
- [ quots>> ] [ branches>> [ length <effect> ] { } assoc>map ] bi zip
+ [ quots>> ] [ branches>> [ length [ "x" <array> ] bi@ <effect> ] { } assoc>map ] bi zip
[ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
M: too-many->r summary
-! 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
: make-copies ( values effect-in -- values' )
[ length cut* ] keep
[ quotation-param? [ copy-value ] [ drop <value> ] if ] 2map
- [ make-values ] dip append ;
+ [ length make-values ] dip append ;
SYMBOL: enter-in
SYMBOL: enter-out
: infer-<tuple-boa> ( -- )
\ <tuple-boa>
- peek-d literal value>> second 1 + { tuple } <effect>
+ peek-d literal value>> second 1 + "obj" <array> { tuple } <effect>
apply-word/effect ;
\ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
\ 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
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:"
{ $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
}
"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"
"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"
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
-! 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 ;
: infer. ( quot -- )
#! Safe to call from inference transforms.
infer effect>string print ;
+
+: inputs ( quot -- n ) infer in>> length ;
+
+: outputs ( quot -- n ) infer out>> length ;
-! 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
: 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" <array>
+ meta-d length "x" <array>
+ terminated? get effect boa ;
: init-inference ( -- )
terminated? off
-! 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
<PRIVATE
: map-last ( seq quot -- seq )
- [ dup length <reversed> ] dip '[ 0 = @ ] 2map ; inline
+ [ dup length iota <reversed> ] dip '[ 0 = @ ] 2map ; inline
: max-length ( seq -- n )
[ length ] [ max ] map-reduce ;
<PRIVATE
: suffixes ( string -- suffixes-seq )
- dup length [ tail-slice ] with map ;
+ dup length iota [ tail-slice ] with map ;
: prefix<=> ( begin seq -- <=> )
[ <=> ] [ swap head? ] 2bi [ drop +eq+ ] when ;
USING: namespaces io tools.test threads kernel
concurrency.combinators concurrency.promises locals math
-words calendar ;
+words calendar sequences ;
IN: threads.tests
3 "x" set
[ 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
variables
sleep-entry ;
-: self ( -- thread ) 63 getenv ; inline
+: self ( -- thread ) 63 special-object ; inline
! Thread-local storage
: tnamespace ( -- assoc )
: tchange ( key quot -- )
tnamespace swap change-at ; inline
-: threads ( -- assoc ) 64 getenv ;
+: threads ( -- assoc ) 64 special-object ;
: thread ( id -- thread ) threads at ;
: unregister-thread ( thread -- )
check-registered id>> threads delete-at ;
-: set-self ( thread -- ) 63 setenv ; inline
+: set-self ( thread -- ) 63 set-special-object ; inline
PRIVATE>
: <thread> ( 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
<PRIVATE
: init-threads ( -- )
- H{ } clone 64 setenv
- <dlist> 65 setenv
- <min-heap> 66 setenv
+ H{ } clone 64 set-special-object
+ <dlist> 65 set-special-object
+ <min-heap> 66 set-special-object
initial-thread global
[ drop [ ] "Initial" <thread> ] cache
<box> >>continuation
'[ 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 ( -- )
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
: 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 [
-! 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 ;
[ [ 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 -- )
MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ <tuple-boa> ] ;
-MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ;
+MACRO: infer-in ( class -- quot ) inputs '[ _ ] ;
: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline
MACRO: write-tuple ( class -- quot )
[ '[ [ _ boa ] undo ] ]
- [ tuple-arity <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
+ [ tuple-arity iota <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
bi '[ _ dip @ ] ;
PRIVATE>
<mock-gadget> over <model> >>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 ;
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 } <rect> clip set
<pile>
- 100 [ number>string <label> add-gadget ] each
+ 100 [ number>string <label> add-gadget ] each-integer
dup layout
visible-children [ label? ] all?
[ ] [ #children "num-children" set ] unit-test
[ ] [
- "pane" get <pane-stream> [ 100 [ . ] each ] with-output-stream*
+ "pane" get <pane-stream> [ 100 [ . ] each-integer ] with-output-stream*
] unit-test
[ t ] [ #children "num-children" get = ] unit-test
"s" set
[ t ] [
- 10 [
+ 10 iota [
drop
"g2" get scroll>gadget
"s" get layout
IN: ui.gadgets.slots.tests
USING: assocs ui.gadgets.slots tools.test refs ;
-[ t ] [ [ ] [ ] { 1 2 3 } 2 <value-ref> <slot-editor> slot-editor? ] unit-test
+[ t ] [ [ ] [ ] { { 1 1 } { 2 2 } { 3 3 } } 2 <value-ref> <slot-editor> slot-editor? ] unit-test
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test ui.pens.gradient ;
+USING: tools.test ui.pens.gradient ui.pens.gradient.private
+colors.constants specialized-arrays alien.c-types ;
+SPECIALIZED-ARRAY: float
IN: ui.pens.gradient.tests
+
+[
+ float-array{
+ 0.0
+ 0.0
+ 0.0
+ 100.0
+ 50.0
+ 0.0
+ 50.0
+ 100.0
+ 100.0
+ 0.0
+ 100.0
+ 100.0
+ }
+] [
+ { 1 0 } { 100 100 } { COLOR: red COLOR: green COLOR: blue }
+ gradient-vertices
+] unit-test
:: gradient-vertices ( direction dim colors -- seq )
direction dim v* dim over v- swap
- colors length dup 1 - v/n [ v*n ] with map
+ colors length [ iota ] [ 1 - ] bi v/n [ v*n ] with map
swap [ over v+ 2array ] curry map
concat concat >float-array ;
utf8 file-lines
[ "#" split1 drop ] map harvest [
"÷" split
- [ "×" split [ [ blank? ] trim hex> ] map harvest >string ] map
+ [
+ "×" split
+ [ [ blank? ] trim hex> ] map
+ [ { f 0 } member? not ] filter
+ >string
+ ] map
harvest
] map ;
grapheme-break-test parse-test-file [ >graphemes ] test
word-break-test parse-test-file [ >words ] test
-[ { t f t t f t } ] [ 6 [ "as df" word-break-at? ] map ] unit-test
+[ { t f t t f t } ] [ 6 iota [ "as df" word-break-at? ] map ] unit-test
: make-grapheme-table ( -- )
{ CR } { LF } connect
- { Control CR LF } graphemes disconnect
- graphemes { Control CR LF } disconnect
+ { Control CR LF } graphemes iota disconnect
+ graphemes iota { Control CR LF } disconnect
{ L } { L V LV LVT } connect
{ LV V } { V T } connect
{ LVT T } { T } connect
- graphemes { Extend } connect
- graphemes { SpacingMark } connect
- { Prepend } graphemes connect ;
+ graphemes iota { Extend } connect
+ graphemes iota { SpacingMark } connect
+ { Prepend } graphemes iota connect ;
VALUE: grapheme-table
: make-word-table ( -- )
{ wCR } { wLF } connect
- { wNewline wCR wLF } words disconnect
- words { wNewline wCR wLF } disconnect
+ { wNewline wCR wLF } words iota disconnect
+ words iota { wNewline wCR wLF } disconnect
{ wALetter } { wMidLetter wMidNumLet } check-letter-after set-table
{ wMidLetter wMidNumLet } { wALetter } check-letter-before set-table
{ wNumeric wALetter } { wNumeric wALetter } connect
over tail-slice first-word + ;
: last-word ( str -- i )
- [ length ] keep '[ _ word-break-at? ] find-last drop 0 or ;
+ [ length iota ] keep '[ _ word-break-at? ] find-last drop 0 or ;
: last-word-from ( end str -- i )
swap head-slice last-word ;
\r
: add ( char -- )\r
dup blocked? [ 1string , ] [\r
- dup possible-bases dup length\r
+ dup possible-bases dup length iota\r
[ ?combine ] with with any?\r
[ drop ] [ 1string , ] if\r
] if ;\r
: exclusions ( -- set )
exclusions-file utf8 file-lines
- [ "#" split1 drop [ blank? ] trim-tail hex> ] map harvest ;
+ [ "#" split1 drop [ blank? ] trim-tail hex> ] map
+ [ 0 = not ] filter ;
: remove-exclusions ( alist -- alist )
exclusions [ dup ] H{ } map>assoc assoc-diff ;
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! Copyright (C) 2008 Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.syntax kernel libc
-sequences continuations byte-arrays strings math namespaces
-system combinators vocabs.loader accessors
-stack-checker macros locals generalizations unix.types
-io vocabs classes.struct unix.time alien.libraries ;
+USING: alien alien.c-types alien.syntax kernel libc sequences
+continuations byte-arrays strings math namespaces system
+combinators combinators.smart vocabs.loader accessors
+stack-checker macros locals generalizations unix.types io vocabs
+classes.struct unix.time alien.libraries ;
IN: unix
CONSTANT: PROT_NONE 0
ERROR: unix-system-call-error args errno message word ;
MACRO:: unix-system-call ( quot -- )
- quot infer in>> :> n
+ quot inputs :> n
quot first :> word
[
n ndup quot call dup 0 < [
USING: unrolled-lists tools.test deques kernel sequences
-random prettyprint grouping ;
+random prettyprint grouping math ;
IN: unrolled-lists.tests
[ 1 ] [ <unrolled-list> 1 over push-front pop-front ] unit-test
[ { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } ] [
<unrolled-list>
- 32 [ over push-front ] each
+ 32 [ over push-front ] each-integer
32 [ dup pop-back ] replicate
nip
] unit-test
[ { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } ] [
<unrolled-list>
- 32 [ over push-front ] each
+ 32 [ over push-front ] each-integer
32 [ dup pop-front ] replicate reverse
nip
] unit-test
<unrolled-list>
1000 [ 1000 random ] replicate
[ [ over push-front ] each ]
- [ [ dup pop-back ] replicate ]
+ [ length [ dup pop-back ] replicate ]
[ ]
tri
=
[
10 group [
[ [ over push-front ] each ]
- [ [ dup pop-back ] replicate ]
+ [ length [ dup pop-back ] replicate ]
bi
] map concat
] keep
-! Copyright (C) 2009 Phil Dawes.
+! Copyright (C) 2009, 2010 Phil Dawes, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.struct alien.c-types alien.syntax ;
IN: vm
{ nursery zone }
{ cards-offset cell }
{ decks-offset cell }
-{ userenv cell[70] } ;
+{ special-objects cell[70] } ;
: vm-field-offset ( field -- offset ) vm offset-of ; inline
: >64bit ( lo hi -- n )
32 shift bitor ; inline
-: windows-1601 ( -- timestamp )
- 1601 1 1 0 0 0 instant <timestamp> ;
+: windows-1601 ( -- timestamp ) 1601 <year-gmt> ;
: FILETIME>windows-time ( FILETIME -- n )
[ dwLowDateTime>> ] [ dwHighDateTime>> ] bi >64bit ;
-USING: accessors assocs combinators continuations fry generalizations
-io.pathnames kernel macros sequences stack-checker tools.test xml
-xml.traversal xml.writer arrays xml.data ;
+USING: accessors assocs combinators combinators.smart
+continuations fry generalizations io.pathnames kernel macros
+sequences stack-checker tools.test xml xml.traversal xml.writer
+arrays xml.data ;
IN: xml.tests.suite
TUPLE: xml-test id uri sections description type ;
CONSTANT: base "vocab:xml/tests/xmltest/"
-MACRO: drop-output ( quot -- newquot )
- dup infer out>> '[ @ _ ndrop ] ;
-
-MACRO: drop-input ( quot -- newquot )
- infer in>> '[ _ ndrop ] ;
+MACRO: drop-inputs ( quot -- newquot )
+ inputs '[ _ ndrop ] ;
: fails? ( quot -- ? )
- [ drop-output f ] [ nip drop-input t ] bi-curry recover ; inline
+ [ drop-outputs f ] [ nip drop-inputs t ] bi-curry recover ; inline
: well-formed? ( uri -- answer )
[ file>xml ] fails? "not-wf" "valid" ? ;
get-char [ missing-close ] unless next ;
: expect ( string -- )
- dup spot get '[ _ [ char>> ] keep next* ] replicate
+ dup length spot get '[ _ [ char>> ] keep next* ] "" replicate-as
2dup = [ 2drop ] [ expected ] if ;
! Suddenly XML-specific
exit_script() {
if [[ $FIND_MAKE_TARGET -eq true ]] ; then
- echo $MAKE_TARGET;
- fi
- exit $1
+ echo $MAKE_TARGET;
+ fi
+ exit $1
}
ensure_program_installed() {
update_script() {
update_script=`update_script_name`
-
- echo "#!/bin/sh" >"$update_script"
+ bash_path=`which bash`
+ echo "#!$bash_path" >"$update_script"
echo "git pull \"$GIT_URL\" master" >>"$update_script"
echo "if [[ \$? -eq 0 ]]; then exec \"$0\" $SCRIPT_ARGS; else echo \"git pull failed\"; exit 2; fi" \
>>"$update_script"
update_boot_images() {
echo "Deleting old images..."
$DELETE checksums.txt* > /dev/null 2>&1
- # delete boot images with one or two characters after the dot
+ # delete boot images with one or two characters after the dot
$DELETE $BOOT_IMAGE.{?,??} > /dev/null 2>&1
$DELETE temp/staging.*.image > /dev/null 2>&1
if [[ -f $BOOT_IMAGE ]] ; then
M: sequence string>symbol [ string>symbol* ] map ;
[
- 8 getenv utf8 alien>string string>cpu \ cpu set-global
- 9 getenv utf8 alien>string string>os \ os set-global
+ 8 special-object utf8 alien>string string>cpu \ cpu set-global
+ 9 special-object utf8 alien>string string>os \ os set-global
] "alien.strings" add-startup-hook
-! Copyright (C) 2007, 2009 Daniel Ehrenberg, Slava Pestov
+! Copyright (C) 2007, 2010 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences arrays math sequences.private vectors
accessors ;
M: enum delete-at seq>> remove-nth! drop ; inline
M: enum >alist ( enum -- alist )
- seq>> [ length ] keep zip ; inline
+ seq>> [ length iota ] keep zip ; inline
M: enum assoc-size seq>> length ; inline
{ "float-u>=" "math.private" (( x y -- ? )) }
{ "(word)" "words.private" (( name vocab -- word )) }
{ "word-xt" "words" (( word -- start end )) }
- { "getenv" "kernel.private" (( n -- obj )) }
- { "setenv" "kernel.private" (( obj n -- )) }
+ { "special-object" "kernel.private" (( n -- obj )) }
+ { "set-special-object" "kernel.private" (( obj n -- )) }
{ "(exists?)" "io.files.private" (( path -- ? )) }
{ "minor-gc" "memory" (( -- )) }
{ "gc" "memory" (( -- )) }
USING: tools.test byte-vectors vectors sequences kernel\r
-prettyprint ;\r
+prettyprint math ;\r
IN: byte-vectors.tests\r
\r
[ 0 ] [ 123 <byte-vector> length ] unit-test\r
\r
: do-it ( seq -- seq )\r
- 123 [ over push ] each ;\r
+ 123 [ over push ] each-integer ;\r
\r
[ t ] [\r
3 <byte-vector> do-it\r
\r
! class<=>\r
\r
-[ +lt+ ] [ integer sequence class<=> ] unit-test\r
[ +lt+ ] [ sequence object class<=> ] unit-test\r
[ +gt+ ] [ object sequence class<=> ] unit-test\r
[ +eq+ ] [ integer integer class<=> ] unit-test\r
10 [\r
[ ] [\r
20 [ random-op ] [ ] replicate-as\r
- [ infer in>> [ random-class ] times ] keep\r
+ [ infer in>> length [ random-class ] times ] keep\r
call\r
drop\r
] unit-test\r
20 [\r
[ t ] [\r
20 [ random-boolean-op ] [ ] replicate-as dup .\r
- [ infer in>> [ random-boolean ] replicate dup . ] keep\r
+ [ infer in>> length [ random-boolean ] replicate dup . ] keep\r
\r
[ [ [ ] each ] dip call ] 2keep\r
\r
: execute-effect-unsafe ( word effect -- ) drop execute ;
-M: object throw 5 getenv [ die ] or (( error -- * )) call-effect-unsafe ;
+M: object throw
+ 5 special-object [ die ] or
+ (( error -- * )) call-effect-unsafe ;
PRIVATE>
! Incremented each time stack effects potentially changed, used
! by compiler.tree.propagation.call-effect for call( and execute(
! inline caching
-: effect-counter ( -- n ) 47 getenv ; inline
+: effect-counter ( -- n ) 47 special-object ; inline
GENERIC: bump-effect-counter* ( defspec -- ? )
or ;
: bump-effect-counter ( -- )
- bump-effect-counter? [ 47 getenv 0 or 1 + 47 setenv ] when ;
+ bump-effect-counter? [
+ 47 special-object 0 or
+ 1 +
+ 47 set-special-object
+ ] when ;
: notify-observers ( -- )
updated-definitions dup assoc-empty?
] with-scope
] callcc0 "x" get 5 = ;
-[ t ] [ 10 callcc1-test 10 reverse >vector = ] unit-test
+[ t ] [ 10 callcc1-test 10 iota reverse >vector = ] unit-test
[ t ] [ callcc-namespace-test ] unit-test
[ 5 throw ] [ 5 = ] must-fail-with
<PRIVATE
: catchstack* ( -- catchstack )
- 1 getenv { vector } declare ; inline
+ 1 special-object { vector } declare ; inline
: >c ( continuation -- ) catchstack* push ;
: dummy-1 ( -- obj ) f ;
: dummy-2 ( obj -- obj ) dup drop ;
-: init-catchstack ( -- ) V{ } clone 1 setenv ;
+: init-catchstack ( -- ) V{ } clone 1 set-special-object ;
PRIVATE>
: catchstack ( -- catchstack ) catchstack* clone ; inline
-: set-catchstack ( catchstack -- ) >vector 1 setenv ; inline
+: set-catchstack ( catchstack -- ) >vector 1 set-special-object ; inline
TUPLE: continuation data call retain name catch ;
: continue-with ( obj continuation -- * )
[
- swap 4 setenv
+ swap 4 set-special-object
>continuation<
set-catchstack
set-namestack
set-retainstack
- [ set-datastack drop 4 getenv f 4 setenv f ] dip
+ [ set-datastack drop 4 special-object f 4 set-special-object f ] dip
set-callstack
] (( obj continuation -- * )) call-effect-unsafe ;
! VM calls on error
[
! 63 = self
- 63 getenv error-thread set-global
+ 63 special-object error-thread set-global
continuation error-continuation set-global
rethrow
- ] 5 setenv
+ ] 5 set-special-object
! VM adds this to kernel errors, so that user-space
! can identify them
- "kernel-error" 6 setenv ;
+ "kernel-error" 6 set-special-object ;
PRIVATE>
{ $values { "obj" object } { "str" string } }
{ $description "Turns a stack effect object into a string mnemonic." }
{ $examples
- { $example "USING: effects io ;" "1 2 <effect> effect>string print" "( object -- object object )" }
+ { $example "USING: effects io ;" "{ \"x\" } { \"y\" \"z\" } <effect> effect>string print" "( x -- y z )" }
} ;
HELP: stack-effect
quotations sequences ;
IN: effects.tests
-[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
-[ f ] [ 1 0 <effect> 2 2 <effect> effect<= ] unit-test
-[ t ] [ 2 2 <effect> 2 2 <effect> effect<= ] unit-test
-[ f ] [ 3 3 <effect> 2 2 <effect> effect<= ] unit-test
-[ f ] [ 2 3 <effect> 2 2 <effect> effect<= ] unit-test
+[ t ] [ { "a" } { "a" } <effect> { "a" "b" } { "a" "b" } <effect> effect<= ] unit-test
+[ f ] [ { "a" } { } <effect> { "a" "b" } { "a" "b" } <effect> effect<= ] unit-test
+[ t ] [ { "a" "b" } { "a" "b" } <effect> { "a" "b" } { "a" "b" } <effect> effect<= ] unit-test
+[ f ] [ { "a" "b" "c" } { "a" "b" "c" } <effect> { "a" "b" } { "a" "b" } <effect> effect<= ] unit-test
+[ f ] [ { "a" "b" } { "a" "b" "c" } <effect> { "a" "b" } { "a" "b" } <effect> effect<= ] unit-test
[ 2 ] [ (( a b -- c )) in>> length ] unit-test
[ 1 ] [ (( a b -- c )) out>> length ] unit-test
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser math.order namespaces make sequences strings
words assocs combinators accessors arrays quotations ;
IN: effects
-TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ;
-
-GENERIC: effect-length ( obj -- n )
-M: sequence effect-length length ;
-M: integer effect-length ;
+TUPLE: effect
+{ in array read-only }
+{ out array read-only }
+{ terminated? read-only } ;
: <effect> ( in out -- effect )
- dup { "*" } sequence= [ drop { } t ] [ f ] if
+ dup { "*" } = [ drop { } t ] [ f ] if
effect boa ;
: effect-height ( effect -- n )
- [ out>> effect-length ] [ in>> effect-length ] bi - ; inline
+ [ out>> length ] [ in>> length ] bi - ; inline
: effect<= ( effect1 effect2 -- ? )
{
{ [ over terminated?>> ] [ t ] }
{ [ dup terminated?>> ] [ f ] }
- { [ 2dup [ in>> effect-length ] bi@ > ] [ f ] }
+ { [ 2dup [ in>> length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
[ t ]
} cond 2nip ; inline
: effect= ( effect1 effect2 -- ? )
- [ [ in>> effect-length ] bi@ = ]
- [ [ out>> effect-length ] bi@ = ]
+ [ [ in>> length ] bi@ = ]
+ [ [ out>> length ] bi@ = ]
[ [ terminated?>> ] bi@ = ]
2tri and and ;
M: pair effect>string first2 [ effect>string ] bi@ ": " glue ;
: stack-picture ( seq -- string )
- dup integer? [ "object" <repetition> ] when
[ [ effect>string % CHAR: \s , ] each ] "" make ;
M: effect effect>string ( effect -- string )
GENERIC: effect>type ( obj -- type )
M: object effect>type drop object ;
M: word effect>type ;
-! attempting to specialize on callable breaks compiling
-! M: effect effect>type drop callable ;
M: pair effect>type second effect>type ;
+: effect-in-types ( effect -- input-types )
+ in>> [ effect>type ] map ;
+
+: effect-out-types ( effect -- input-types )
+ out>> [ effect>type ] map ;
+
GENERIC: stack-effect ( word -- effect/f )
M: word stack-effect "declared-effect" word-prop ;
stack-effect effect-height ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
- in>> effect-length cut* ;
+ in>> length cut* ;
: shuffle-mapping ( effect -- mapping )
[ out>> ] [ in>> ] bi [ index ] curry map ;
over terminated?>> [
drop
] [
- [ [ [ in>> effect-length ] [ out>> effect-length ] bi ] [ in>> effect-length ] bi* swap [-] + ]
- [ [ out>> effect-length ] [ [ in>> effect-length ] [ out>> effect-length ] bi ] bi* [ [-] ] dip + ]
+ [ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ]
+ [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
[ nip terminated?>> ] 2tri
- [ [ [ "obj" ] replicate ] bi@ ] dip
+ [ [ "x" <array> ] bi@ ] dip
effect boa
] if ; inline
-
-: effect-in-types ( effect -- input-types )
- in>> [ effect>type ] map ;
-: effect-out-types ( effect -- input-types )
- out>> [ effect>type ] map ;
{ $code
"GENERIC: explain ( object -- )"
"M: object explain drop \"an object\" print ;"
- "M: number explain drop \"a number\" print ;"
- "M: sequence explain drop \"a sequence\" print ;"
+ "M: generic explain drop \"a class word\" print ;"
+ "M: class explain drop \"a generic word\" print ;"
}
"The linear order is the following, from least-specific to most-specific:"
-{ $code "{ object sequence number }" }
-"Neither " { $link number } " nor " { $link sequence } " are subclasses of each other, yet their intersection is the non-empty " { $link integer } " class. Calling " { $snippet "explain" } " with an integer on the stack will print " { $snippet "a number" } " because " { $link number } " precedes " { $link sequence } " in the class linearization order. If this was not the desired outcome, define a method on the intersection:"
-{ $code "M: integer explain drop \"an integer\" print ;" }
-"Now, the linear order is the following, from least-specific to most-specific:"
-{ $code "{ object sequence number integer }" }
+{ $code "{ object generic class }" }
+"Neither " { $link class } " nor " { $link generic } " are subclasses of each other, and their intersection is non-empty. Calling " { $snippet "explain" } " with a word on the stack that is both a class and a generic word will print " { $snippet "a generic word" } " because " { $link class } " precedes " { $link generic } " in the class linearization order. (One example of a word which is both a class and a generic word is the class of classes, " { $link class } ", which is also a word to get the class of an object.)"
+$nl
"The " { $link order } " word can be useful to clarify method dispatch order:"
{ $subsections order } ;
continuations ;
IN: hashtables.tests
-[ f ] [ "hi" V{ 1 2 3 } at ] unit-test
-
[ H{ } ] [ { } [ dup ] H{ } map>assoc ] unit-test
-[ ] [ 1000 [ dup sq ] H{ } map>assoc "testhash" set ] unit-test
+[ ] [ 1000 iota [ dup sq ] H{ } map>assoc "testhash" set ] unit-test
[ V{ } ]
-[ 1000 [ dup sq swap "testhash" get at = not ] filter ]
+[ 1000 iota [ dup sq swap "testhash" get at = not ] filter ]
unit-test
[ t ]
! Resource leak...
H{ } "x" set
-100 [ drop "x" get clear-assoc ] each
+100 [ drop "x" get clear-assoc ] each-integer
! Crash discovered by erg
[ t ] [ 0.75 <hashtable> dup clone = ] unit-test
[ 1 ] [ 2 "h" get at ] unit-test
! Random test case
-[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test
+[ "A" ] [ 100 iota [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test
: boot ( -- ) init-namespaces init-catchstack init-error-handler ;
-: startup-quot ( -- quot ) 20 getenv ;
+: startup-quot ( -- quot ) 20 special-object ;
-: set-startup-quot ( quot -- ) 20 setenv ;
+: set-startup-quot ( quot -- ) 20 set-special-object ;
-: shutdown-quot ( -- quot ) 22 getenv ;
+: shutdown-quot ( -- quot ) 22 special-object ;
-: set-shutdown-quot ( quot -- ) 22 setenv ;
+: set-shutdown-quot ( quot -- ) 22 set-special-object ;
[ do-shutdown-hooks ] set-shutdown-quot
[ 3 ] [ 2 "lápis" >utf8-index ] unit-test
-[ V{ } ] [ 100000 [ [ code-point-length ] [ 1string utf8 encode length ] bi = not ] filter ] unit-test
+[ V{ } ] [ 100000 iota [ [ code-point-length ] [ 1string utf8 encode length ] bi = not ] filter ] unit-test
[
cwd current-directory set-global
- 13 getenv alien>native-string cwd prepend-path \ image set-global
- 14 getenv alien>native-string cwd prepend-path \ vm set-global
+ 13 special-object alien>native-string cwd prepend-path \ image set-global
+ 14 special-object alien>native-string cwd prepend-path \ vm set-global
image parent-directory "resource-path" set-global
] "io.files" add-startup-hook
M: c-io-backend init-io ;
-: stdin-handle ( -- alien ) 11 getenv ;
-: stdout-handle ( -- alien ) 12 getenv ;
-: stderr-handle ( -- alien ) 61 getenv ;
+: stdin-handle ( -- alien ) 11 special-object ;
+: stdout-handle ( -- alien ) 12 special-object ;
+: stderr-handle ( -- alien ) 61 special-object ;
: init-c-stdio ( -- )
stdin-handle <c-reader>
{ $values { "object" object } { "n" "a tag number" } }
{ $description "Outputs an object's tag number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
-HELP: getenv ( n -- obj )
+HELP: special-object ( n -- obj )
{ $values { "n" "a non-negative integer" } { "obj" object } }
-{ $description "Reads an object from the Factor VM's environment table. User code never has to read the environment table directly; instead, use one of the callers of this word." } ;
+{ $description "Reads an object from the Factor VM's special object table. User code never has to read the special object table directly; instead, use one of the callers of this word." } ;
-HELP: setenv ( obj n -- )
+HELP: set-special-object ( obj n -- )
{ $values { "obj" object } { "n" "a non-negative integer" } }
-{ $description "Writes an object to the Factor VM's environment table. User code never has to write to the environment table directly; instead, use one of the callers of this word." } ;
+{ $description "Writes an object to the Factor VM's special object table. User code never has to write to the special object table directly; instead, use one of the callers of this word." } ;
HELP: object
{ $class-description
! We do this in its own compilation unit so that they can be
! folded below
<<
-: cell ( -- n ) 7 getenv ; foldable
+: cell ( -- n ) 7 special-object ; foldable
: (first-bignum) ( m -- n ) tag-bits get - 1 - 2^ ; foldable
>>
-USING: kernel math math.constants tools.test sequences
+USING: kernel math math.constants math.order tools.test sequences
grouping ;
IN: math.floats.tests
[ 0 ] [ 1/0. >bignum ] unit-test
-[ t ] [ 64 [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test
+[ t ] [ 64 iota [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test
[ 5 ] [ 10.5 1.9 /i ] unit-test
[ t ] [ -0.0 abs 0.0 fp-bitwise= ] unit-test
[ 1.5 ] [ -1.5 abs ] unit-test
[ 1.5 ] [ 1.5 abs ] unit-test
+
+[ 5.0 ] [ 3 5.0 max ] unit-test
+[ 3 ] [ 3 5.0 min ] unit-test
-! Copyright (C) 2004, 2009 Slava Pestov, Joe Groff.
+! Copyright (C) 2004, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.private ;
+USING: kernel math math.private math.order ;
IN: math.floats.private
: float-unordered? ( x y -- ? ) [ fp-nan? ] bi@ or ;
M: float u> float-u> ; inline
M: float u>= float-u>= ; inline
+M: float min over float? [ float-min ] [ call-next-method ] if ; inline
+M: float max over float? [ float-max ] [ call-next-method ] if ; inline
+
M: float + float+ ; inline
M: float - float- ; inline
M: float * float* ; inline
-USING: kernel math math.functions namespaces prettyprint
-math.private continuations tools.test sequences random ;
+USING: kernel math math.functions math.order namespaces
+prettyprint math.private continuations tools.test sequences
+random ;
IN: math.integers.tests
[ "-8" ] [ -8 unparse ] unit-test
random-integer
random-integer
[ >float / ] [ /f ] 2bi 0.1 ~
- ] all?
+ ] all-integers?
] unit-test
! Ensure that /f is accurate for fixnums > 2^53 on 64-bit platforms
[ HEX: 1.758bec11492f9p-54 ] [ 1 12345678901234567 /f ] unit-test
[ HEX: -1.758bec11492f9p-54 ] [ 1 -12345678901234567 /f ] unit-test
+
+[ 17 ] [ 17 >bignum 5 max ] unit-test
+[ 5 ] [ 17 >bignum 5 min ] unit-test
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! Copyright (C) 2008, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private sequences
-sequences.private math math.private combinators ;
+USING: kernel kernel.private sequences sequences.private math
+math.private math.order combinators ;
IN: math.integers.private
: fixnum-min ( x y -- z ) [ fixnum< ] most ; foldable
M: fixnum u> fixnum> ; inline
M: fixnum u>= fixnum>= ; inline
+M: fixnum min over fixnum? [ fixnum-min ] [ call-next-method ] if ; inline
+M: fixnum max over fixnum? [ fixnum-max ] [ call-next-method ] if ; inline
+
M: fixnum + fixnum+ ; inline
M: fixnum - fixnum- ; inline
M: fixnum * fixnum* ; inline
{ $examples "This word is equivalent to " { $link if-zero } " with an empty first quotation:"
{ $example
"USING: sequences math prettyprint ;"
- "3 [ ] [ sq ] if-empty ."
+ "3 [ ] [ sq ] if-zero ."
"9"
}
{ $example
} ;
HELP: max
-{ $values { "x" object } { "y" object } { "z" object } }
+{ $values { "obj1" object } { "obj2" object } { "obj" object } }
{ $description "Outputs the greatest of two ordered values." }
{ $notes "If one value is a floating point positive zero and the other is a negative zero, the result is undefined." } ;
HELP: min
-{ $values { "x" object } { "y" object } { "z" object } }
+{ $values { "obj1" object } { "obj2" object } { "obj" object } }
{ $description "Outputs the smallest of two ordered values." }
{ $notes "If one value is a floating point positive zero and the other is a negative zero, the result is undefined." } ;
HELP: clamp
{ $values { "x" object } { "min" object } { "max" object } { "y" object } }
-{ $description "Outputs " { $snippet "x" } " if contained in the interval " { $snippet "[min,max]" } " or outputs one of the endpoints." } ;
+{ $description "Outputs " { $snippet "x" } " if contained in the interval " { $snippet "[min,max]" } " or else outputs one of the endpoints." } ;
HELP: between?
{ $values { "x" object } { "y" object } { "z" real } { "?" "a boolean" } }
-! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math ;
IN: math.order
M: real before=? ( obj1 obj2 -- ? ) <= ; inline
M: real after=? ( obj1 obj2 -- ? ) >= ; inline
-: min ( x y -- z ) [ before? ] most ;
-: max ( x y -- z ) [ after? ] most ;
+GENERIC: min ( obj1 obj2 -- obj )
+GENERIC: max ( obj1 obj2 -- obj )
+
+M: object min [ before? ] most ; inline
+M: object max [ after? ] most ; inline
+
: clamp ( x min max -- y ) [ max ] dip min ; inline
: between? ( x y z -- ? )
ABOUT: "number-strings"
HELP: digits>integer
-{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n/f" { $maybe integer } } }
+{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 16" } { "n/f" { $maybe integer } } }
{ $description "Converts a sequence of digits (with most significant digit first) into an integer." }
{ $notes "This is one of the factors of " { $link string>number } "." } ;
HELP: >digit
-{ $values { "n" "an integer between 0 and 35" } { "ch" "a character" } }
+{ $values { "n" "an integer between 0 and 15" } { "ch" "a character" } }
{ $description "Outputs a character representation of a digit." }
{ $notes "This is one of the factors of " { $link number>string } "." } ;
{ $notes "This is one of the factors of " { $link string>number } "." } ;
HELP: base>
-{ $values { "str" string } { "radix" "an integer between 2 and 36" } { "n/f" "a real number or " { $link f } } }
+{ $values { "str" string } { "radix" "an integer between 2 and 16" } { "n/f" "a real number or " { $link f } } }
{ $description "Creates a real number from a string representation with the given radix. The radix is ignored for floating point literals; they are always taken to be in base 10."
$nl
"Outputs " { $link f } " if the string does not represent a number." } ;
{ >hex POSTPONE: HEX: hex> .h } related-words
HELP: >base
-{ $values { "n" real } { "radix" "an integer between 2 and 36" } { "str" string } }
+{ $values { "n" real } { "radix" "an integer between 2 and 16" } { "str" string } }
{ $description "Converts a real number into a string representation using the given radix. If the number is a float, the radix is ignored and the output is always in base 10." } ;
HELP: >bin
<PRIVATE
-: namestack* ( -- namestack ) 0 getenv { vector } declare ; inline
+: namestack* ( -- namestack ) 0 special-object { vector } declare ; inline
: >n ( namespace -- ) namestack* push ;
: ndrop ( -- ) namestack* pop* ;
: namespace ( -- namespace ) namestack* last ; inline
: namestack ( -- namestack ) namestack* clone ;
-: set-namestack ( namestack -- ) >vector 0 setenv ;
-: global ( -- g ) 21 getenv { hashtable } declare ; inline
+: set-namestack ( namestack -- ) >vector 0 set-special-object ;
+: global ( -- g ) 21 special-object { hashtable } declare ; inline
: init-namespaces ( -- ) global 1array set-namestack ;
: get ( variable -- value ) namestack* assoc-stack ; inline
: set ( value variable -- ) namespace set-at ;
execute( accum -- accum ) ;
: scan-object ( -- object )
- scan-word dup parsing-word?
- [ V{ } clone swap execute-parsing first ] when ;
+ scan-word {
+ { [ dup not ] [ unexpected-eof ] }
+ { [ dup parsing-word? ] [ V{ } clone swap execute-parsing first ] }
+ [ ]
+ } cond ;
: parse-step ( accum end -- accum ? )
scan-word {
[ fixnum ] [ 1 >bignum SBUF" " new-sequence length class ] unit-test
-[ fixnum ] [ 1 >bignum [ ] SBUF" " map-as length class ] unit-test
+[ fixnum ] [ 1 >bignum iota [ ] SBUF" " map-as length class ] unit-test
{ "quot" quotation } { "accum" vector } }
{ $description "Creates a new vector to accumulate the values which return true for a predicate. Returns a new quotation which accepts an object to be tested and stored in the accumulator if the test yields true. The accumulator is left on the stack for convenience." }
{ $example "! Find all the even numbers:" "USING: prettyprint sequences math kernel ;"
- "10 [ even? ] pusher [ each ] dip ."
+ "10 iota [ even? ] pusher [ each ] dip ."
"V{ 0 2 4 6 8 }"
}
{ $notes "Used to implement the " { $link filter } " word. Compare this word with " { $link accumulator } ", which is an unfiltering version." } ;
HELP: replicate
{ $values
- { "seq" sequence } { "quot" { $quotation "( -- elt )" } }
+ { "len" integer } { "quot" { $quotation "( -- elt )" } }
{ "newseq" sequence } }
-{ $description "Calls the quotation for every element of the sequence in order. However, the element is not passed to the quotation -- it is dropped, and the quotation produces an element of its own that is collected into a sequence of the same class as the input sequence." }
+ { $description "Calls the quotation " { $snippet "len" } " times, collecting results into a new array." }
{ $examples
{ $unchecked-example "USING: kernel prettyprint random sequences ;"
"5 [ 100 random ] replicate ."
HELP: replicate-as
{ $values
- { "seq" sequence } { "quot" quotation } { "exemplar" sequence }
+ { "len" integer } { "quot" quotation } { "exemplar" sequence }
{ "newseq" sequence } }
-{ $description "Calls the quotation for every element of the sequence in order. However, the element is not passed to the quotation -- it is dropped, and the quotation produces an element of its own that is collected into a sequence of the same class as the exemplar sequence." }
+ { $description "Calls the quotation " { $snippet "len" } " times, collecting results into a new sequence of the same type as the exemplar sequence." }
{ $examples
{ $unchecked-example "USING: prettyprint kernel sequences ;"
"5 [ 100 random ] B{ } replicate-as ."
"B{ 44 8 2 33 18 }"
}
} ;
+
{ replicate replicate-as } related-words
HELP: partition
{ $description "Like " { $link reduce } ", but splits the sequence in half recursively until each sequence is small enough, and calls the quotation on these smaller sequences. If the quotation computes values that depend on the size of their input, such as bignum arithmetic, then this algorithm can be more efficient than using " { $link reduce } "." }
{ $examples "Computing factorial:"
{ $example "USING: prettyprint sequences math ;"
- "40 rest-slice 1 [ * ] binary-reduce ."
+ "40 iota rest-slice 1 [ * ] binary-reduce ."
"20397882081197443358640281739902897356800000000" }
} ;
"A virtual sequence is an implementation of the " { $link "sequence-protocol" } " which does not store its own elements, and instead computes them, either from scratch or by retrieving them from another sequence."
$nl
"Implementations include the following:"
-{ $subsections reversed slice iota }
-"Virtual sequences can be implemented with the " { $link "virtual-sequences-protocol" } ", by translating an index in the virtual sequence into an index in another sequence." ;
+{ $subsections reversed slice }
+"Virtual sequences can be implemented with the " { $link "virtual-sequences-protocol" } ", by translating an index in the virtual sequence into an index in another sequence."
+{ $see-also "sequences-integers" } ;
ARTICLE: "sequences-integers" "Counted loops"
-"Integers support the sequence protocol in a trivial fashion; a non-negative integer presents its non-negative predecessors as elements. For example, the integer 3, when viewed as a sequence, contains the elements 0, 1, and 2. This is very useful for performing counted loops."
+"A virtual sequence is defined for iterating over integers from zero."
+{ $subsection iota }
+"For example, calling " { $link iota } " on the integer 3 produces a sequence containing the elements 0, 1, and 2. This is very useful for performing counted loops."
$nl
-"For example, the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:"
-{ $example "3 [ . ] each" "0\n1\n2" }
+"This means the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:"
+{ $example "3 iota [ . ] each" "0\n1\n2" }
"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "."
$nl
-"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer."
+"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an instance of " { $link iota } "."
$nl
"More elaborate counted loops can be performed with " { $link "math.ranges" } "." ;
[ "empty" ] [ { } [ "empty" ] [ "not empty" ] if-empty ] unit-test
[ { 1 } "not empty" ] [ { 1 } [ "empty" ] [ "not empty" ] if-empty ] unit-test
-[ V{ 1 2 3 4 } ] [ 1 5 dup <slice> >vector ] unit-test
-[ 3 ] [ 1 4 dup <slice> length ] unit-test
+[ V{ 1 2 3 4 } ] [ 1 5 dup iota <slice> >vector ] unit-test
+[ 3 ] [ 1 4 dup iota <slice> length ] unit-test
[ 2 ] [ 1 3 { 1 2 3 4 } <slice> length ] unit-test
[ V{ 2 3 } ] [ 1 3 { 1 2 3 4 } <slice> >vector ] unit-test
[ V{ 4 5 } ] [ { 1 2 3 4 5 } 2 tail-slice* >vector ] unit-test
-[ V{ 3 4 } ] [ 2 4 1 10 dup <slice> subseq >vector ] unit-test
-[ V{ 3 4 } ] [ 0 2 2 4 1 10 dup <slice> <slice> subseq >vector ] unit-test
+[ V{ 3 4 } ] [ 2 4 1 10 dup iota <slice> subseq >vector ] unit-test
+[ V{ 3 4 } ] [ 0 2 2 4 1 10 dup iota <slice> <slice> subseq >vector ] unit-test
[ 0 10 "hello" <slice> ] must-fail
[ -10 3 "hello" <slice> ] must-fail
[ 2 1 "hello" <slice> ] must-fail
[ { 1 3 2 4 } ] [ { 1 2 3 4 } clone 1 2 pick exchange ] unit-test
[ { "" "a" "aa" "aaa" } ]
-[ 4 [ CHAR: a <string> ] map ]
+[ 4 [ CHAR: a <string> ] { } map-integers ]
unit-test
[ V{ } ] [ "f" V{ } clone remove! ] unit-test
[ V{ "x" } ] [ "f" V{ "f" "x" "f" } clone remove! ] unit-test
[ V{ "y" "x" } ] [ "f" V{ "y" "f" "x" "f" } clone remove! ] unit-test
-[ V{ 0 1 4 5 } ] [ 6 >vector 2 4 pick delete-slice ] unit-test
+[ V{ 0 1 4 5 } ] [ 6 iota >vector 2 4 pick delete-slice ] unit-test
[ 6 >vector 2 8 pick delete-slice ] must-fail
-[ V{ } ] [ 6 >vector 0 6 pick delete-slice ] unit-test
+[ V{ } ] [ 6 iota >vector 0 6 pick delete-slice ] unit-test
[ { 1 2 "a" "b" 5 6 7 } ] [
{ "a" "b" } 2 4 { 1 2 3 4 5 6 7 }
[ 0 ] [ f length ] unit-test
[ f first ] must-fail
-[ 3 ] [ 3 10 nth ] unit-test
-[ 3 ] [ 3 10 nth-unsafe ] unit-test
-[ -3 10 nth ] must-fail
-[ 11 10 nth ] must-fail
+[ 3 ] [ 3 10 iota nth ] unit-test
+[ 3 ] [ 3 10 iota nth-unsafe ] unit-test
+[ -3 10 iota nth ] must-fail
+[ 11 10 iota nth ] must-fail
[ -1/0. 0 remove-nth! ] must-fail
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
[ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-head ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-tail ] unit-test
-[ 328350 ] [ 100 [ sq ] map-sum ] unit-test
+[ 328350 ] [ 100 iota [ sq ] map-sum ] unit-test
-[ 50 ] [ 100 [ even? ] count ] unit-test
-[ 50 ] [ 100 [ odd? ] count ] unit-test
+[ 50 ] [ 100 iota [ even? ] count ] unit-test
+[ 50 ] [ 100 iota [ odd? ] count ] unit-test
[ { "b" "d" } ] [ { 1 3 } { "a" "b" "c" "d" } nths ] unit-test
[ { "a" "b" "c" "d" } ] [ { 0 1 2 3 } { "a" "b" "c" "d" } nths ] unit-test
-! Copyright (C) 2005, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2005, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private slots.private math
math.private math.order ;
INSTANCE: f immutable-sequence
-! Integers used to support the sequence protocol
-M: integer length ; inline
-M: integer nth-unsafe drop ; inline
-
-INSTANCE: integer immutable-sequence
-
PRIVATE>
! In the future, this will replace integer sequences
: map ( seq quot -- newseq )
over map-as ; inline
-: replicate ( seq quot -- newseq )
- [ drop ] prepose map ; inline
+: replicate-as ( len quot exemplar -- newseq )
+ [ [ drop ] prepose ] dip map-integers ; inline
-: replicate-as ( seq quot exemplar -- newseq )
- [ [ drop ] prepose ] dip map-as ; inline
+: replicate ( len quot -- newseq )
+ { } replicate-as ; inline
: map! ( seq quot -- seq )
over [ map-into ] keep ; inline
(2each) all-integers? ; inline
: 3each ( seq1 seq2 seq3 quot -- )
- (3each) each ; inline
+ (3each) each-integer ; inline
: 3map-as ( seq1 seq2 seq3 quot exemplar -- newseq )
[ (3each) ] dip map-integers ; inline
[ { } ] [ { } natural-sort ] unit-test
[ { 270000000 270000001 } ]
-[ T{ slice f 270000000 270000002 270000002 } natural-sort ]
+[ T{ slice f 270000000 270000002 T{ iota f 270000002 } } natural-sort ]
unit-test
[ t ] [
100 [ 20 random [ 1000 random ] replicate ] replicate
dup natural-sort
[ set= ] [ nip [ before=? ] monotonic? ] 2bi and
- ] all?
+ ] all-integers?
] unit-test
[ ] [ { 1 2 } [ 2drop 1 ] sort drop ] unit-test
M: source-file-error compute-restarts error>> compute-restarts ;
: sort-errors ( errors -- alist )
- [ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ;
+ [ [ line#>> 0 or ] sort-with ] { } assoc-map-as sort-keys ;
: group-by-source-file ( errors -- assoc )
H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;
drop
300 100 CHAR: \u123456
[ <string> clone resize-string first ] keep =
- ] all?
+ ] all-integers?
] unit-test
: vm ( -- path ) \ vm get-global ;
-: embedded? ( -- ? ) 15 getenv ;
+: embedded? ( -- ? ) 15 special-object ;
: exit ( n -- ) do-shutdown-hooks (exit) ;
[ 4 ] [ 5 V{ 1 2 3 4 5 } index ] unit-test
[ t ] [
- 100 >array dup >vector <reversed> >array [ reverse ] dip =
+ 100 iota >array dup >vector <reversed> >array [ reverse ] dip =
] unit-test
[ fixnum ] [ 1 >bignum V{ } new-sequence length class ] unit-test
-[ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test
+[ fixnum ] [ 1 >bignum iota [ ] V{ } map-as length class ] unit-test
[ V{ "lulz" } ] [ "lulz" 1vector ] unit-test
[ end-game ]
[ dup quit? [ quit-game ] [ repeat ] if ]
if ;
-: build-quad ( -- array ) 4 [ 10 random ] replicate >array ;
+: build-quad ( -- array ) 4 [ 10 random ] replicate ;
: 24-able? ( quad -- t/f ) [ makes-24? ] with-datastack first ;
: 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ;
: set-commands ( -- ) { + - * / rot swap q } commands set ;
! (c)Joe Groff bsd license
USING: alien.data.map fry generalizations kernel locals math.vectors
-math.vectors.conversion math math.vectors.simd sequences
+math.vectors.conversion math math.vectors.simd math.ranges sequences
specialized-arrays tools.test ;
FROM: alien.c-types => uchar short int float ;
SPECIALIZED-ARRAYS: int float float-4 uchar-16 ;
B{ 15 25 35 45 55 65 75 85 95 105 115 125 135 145 155 165 }
fold-rgba-planes
] unit-test
+
+: data-map-compiler-bug-test ( n -- byte-array )
+ [ 0.0 1.0 1.0 ] dip /f <range>
+ [ ] data-map( object -- float ) ;
+
+[ float-array{ 0.0 0.5 1.0 } ]
+[ 2 data-map-compiler-bug-test byte-array>float-array ]
+unit-test
IN: benchmark.base64
: base64-benchmark ( -- )
- 65535 [ 255 bitand ] "" map-as
+ 65535 iota [ 255 bitand ] "" map-as
20 [ >base64 base64> ] times
drop ;
: count-ones ( int-array -- n ) [ 1 = ] count ; inline
: make-int-array ( -- int-array )
- 120000 [ 255 bitand ] int-array{ } map-as ; inline
+ 120000 iota [ 255 bitand ] int-array{ } map-as ; inline
: dawes-benchmark ( -- )
200 make-int-array '[ _ count-ones ] replicate drop ;
: sequences ( -- seq )
[
- 1 ,
- 10 >bignum ,
+ 1 iota ,
+ 10 >bignum iota ,
{ 1 2 3 } ,
"hello world" ,
SBUF" sbuf world" ,
double-array{ 1.0 2.0 3.0 } ,
"hello world" 4 tail-slice ,
10 f <repetition> ,
- 100 2 <sliced-groups> ,
+ 100 iota 2 <sliced-groups> ,
"hello" <reversed> ,
{ { 1 2 } { 3 4 } } 0 <column> ,
?{ t f t } ,
20000000 [
20 [
foobar-1 drop
- ] each
+ ] each-integer
] times ;
: foobar-test-2 ( -- )
20000000 [
20 [
foobar-2 drop
- ] each
+ ] each-integer
] times ;
MAIN: foobar-test-1
IN: benchmark.e-decimals
: D-factorial ( n -- D! )
- D: 1 [ 0 <decimal> D: 1 D+ D* ] reduce ; inline
+ iota D: 1 [ 0 <decimal> D: 1 D+ D* ] reduce ; inline
:: calculate-e-decimals ( n -- e )
n [1,b] D: 1
IN: benchmark.empty-loop-2
: empty-loop-2 ( n -- )
- [ drop ] each ;
+ iota [ drop ] each ;
: empty-loop-main ( -- )
50000000 empty-loop-2 ;
chars nth-unsafe ; inline
: make-random-fasta ( seed len chars floats -- seed )
- [ rot drop select-random ] 2curry "" map-as print ; inline
+ [ iota ] 2dip [ [ drop ] 2dip select-random ] 2curry "" map-as print ; inline
: write-description ( desc id -- )
">" write write bl print ; inline
:: make-repeat-fasta ( k len alu -- k' )
alu length :> kn
- len [ k + kn mod alu nth-unsafe ] "" map-as print
+ len iota [ k + kn mod alu nth-unsafe ] "" map-as print
k len + ; inline
: write-repeat-fasta ( n alu desc id -- )
USING: math sequences kernel ;
IN: benchmark.gc1
-: gc1 ( -- ) 600000 [ >bignum 1 + ] map drop ;
+: gc1 ( -- ) 600000 iota [ >bignum 1 + ] map drop ;
MAIN: gc1
USING: sequences vectors arrays strings sbufs math math.vectors
kernel ;
-: <range> ( from to -- seq ) dup <slice> ; inline
+: <range> ( from to -- seq ) dup iota <slice> ; inline
: vector-iter ( -- ) 100 [ 0 100000 <range> >vector [ ] map drop ] times ;
: array-iter ( -- ) 100 [ 0 100000 <range> >array [ ] map drop ] times ;
: small-groups ( x n -- b )
swap
- [ length swap - 1 + ] 2keep
+ [ length swap - 1 + iota ] 2keep
[ [ over + ] dip subseq ] 2curry map ;
: handle-table ( inputs n -- )
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.functions kernel io io.styles prettyprint
combinators hints fry namespaces sequences ;
IN: benchmark.partial-sums
! Helper words
-: summing-integers ( n quot -- y ) [ 0.0 ] 2dip '[ 1 + @ + ] each ; inline
+: summing-integers ( n quot -- y ) [ 0.0 ] [ iota ] [ ] tri* '[ 1 + @ + ] each ; inline
: summing-floats ( n quot -- y ) '[ >float @ ] summing-integers ; inline
: cube ( x -- y ) dup dup * * ; inline
: -1^ ( n -- -1/1 ) 2 mod 2 * 1 - ; inline
USING: io io.files io.files.temp io.encodings.ascii random
-math.parser math ;
+math.parser math sequences ;
IN: benchmark.random
: random-numbers-path ( -- path )
[ oversampling /f ] bi@ 0.0 0.0 double-4-boa ;
: ss-grid ( -- ss-grid )
- oversampling [ oversampling [ ss-point ] with map ] map ;
+ oversampling iota [ oversampling iota [ ss-point ] with map ] map ;
: ray-grid ( point ss-grid -- ray-grid )
[
[ [ swap cast-ray + ] with each ] with each ;
: pixel-grid ( -- grid )
- size reverse [
- size [
+ size iota reverse [
+ size iota [
[ size 0.5 * - ] bi@ swap size
0.0 double-4-boa
] with map
[ oversampling /f ] bi@ 0.0 double-array{ } 3sequence ;
: ss-grid ( -- ss-grid )
- oversampling [ oversampling [ ss-point ] with map ] map ;
+ oversampling iota [ oversampling iota [ ss-point ] with map ] map ;
: ray-grid ( point ss-grid -- ray-grid )
[
[ [ swap cast-ray + ] with each ] with each ;
: pixel-grid ( -- grid )
- size reverse [
- size [
+ size iota reverse [
+ size iota [
[ size 0.5 * - ] bi@ swap size
double-array{ } 3sequence
] with map
] times ;
: send-messages ( messages target -- )
- dupd [ send ] curry each [ receive drop ] times ;
+ [ dup iota ] dip [ send ] curry each [ receive drop ] times ;
: destroy-ring ( target -- )
done swap send [ done eq? ] receive-if drop ;
IN: benchmark.spectral-norm
:: inner-loop ( u n quot -- seq )
- n [| i |
- n 0.0 [| j |
+ n iota [| i |
+ n iota 0.0 [| j |
u i j quot call +
] reduce
] double-array{ } map-as ; inline
TUPLE-ARRAY: point
: tuple-array-benchmark ( -- )
- 100 [
+ 100 iota [
drop 5000 <point-array> [
[ 1 + ] change-x
[ 1 - ] change-y
IN: benchmark.ui-panes
: ui-pane-benchmark ( -- )
- <pane> <pane-stream> [ 10000 [ . ] each ] with-output-stream* ;
+ <pane> <pane-stream> [ 10000 iota [ . ] each ] with-output-stream* ;
MAIN: ui-pane-benchmark
h >>uv_height
w >>y_stride
w >>uv_stride
- w h * [ dup * ] B{ } map-as malloc-byte-array &free >>y
- w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free >>u
- w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v ;
+ w h * iota [ dup * ] B{ } map-as malloc-byte-array &free >>y
+ w h * 2/ iota [ dup dup * * ] B{ } map-as malloc-byte-array &free >>u
+ w h * 2/ iota [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v ;
: clamp ( n -- n )
255 min 0 max ; inline
: yuv>rgb-row ( index rgb yuv y -- index )
over stride
- pick y_width>>
+ pick y_width>> iota
[ yuv>rgb-pixel ] with with with with each ; inline
: yuv>rgb ( rgb yuv -- )
[ 0 ] 2dip
- dup y_height>>
+ dup y_height>> iota
[ yuv>rgb-row ] with with each
drop ;
[ t ] [ 1000 iota [ drop most-positive-fixnum random 1000 + ] map
full-bloom-filter
[ bloom-filter-member? ] curry map
- [ ] filter
+ [ ] count
! TODO: This should be 10, but the false positive rate is currently very
! high. 300 is large enough not to prevent builds from succeeding.
- length 300 <=
+ 300 <=
] unit-test
math.functions multiline sequences ;
IN: bloom-filters
-FROM: math.ranges => [1,b] [0,b) ;
+FROM: math.ranges => [1,b] ;
FROM: math.intervals => (a,b) interval-contains? ;
/*
[infix hash0 + (index * hash1) + ((pow(index, 3) - index) / 6) infix] ;
: enhanced-double-hashes ( hash0 hash1 n -- seq )
- [0,b)
+ iota
[ '[ _ _ enhanced-double-hash ] ] dip
swap map ;
reverse? [ reverse ] when
'[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ;
-: scan-constructor ( -- class word )
- scan-word [ name>> "<" ">" surround create-in ] keep ;
+: scan-constructor ( -- word class )
+ scan-word [ name>> "<" ">" surround create-in dup reset-generic ] keep ;
: parse-constructor ( -- class word effect def )
scan-constructor complete-effect parse-definition ;
: inv-sbox ( -- array )
256 0 <array>
- dup 256 [ dup sbox nth rot set-nth ] with each ;
+ dup 256 [ dup sbox nth rot set-nth ] with each-integer ;
: rcon ( -- array )
{
MEMO:: t-table ( -- array )
1024 0 <array>
- dup 256 [ set-t ] with each ;
+ dup 256 [ set-t ] with each-integer ;
:: set-d ( D i -- )
i inv-sbox nth :> a1
MEMO:: d-table ( -- array )
1024 0 <array>
- dup 256 [ set-d ] with each ;
+ dup 256 [ set-d ] with each-integer ;
USE: multiline
: test-decimal-op ( quot1 quot2 -- ? )
[ random-test-decimal random-test-decimal ] 2dip (test-decimal-op) ; inline
-[ t ] [ 1000 [ drop [ D+ ] [ + ] test-decimal-op ] all? ] unit-test
-[ t ] [ 1000 [ drop [ D- ] [ - ] test-decimal-op ] all? ] unit-test
-[ t ] [ 1000 [ drop [ D* ] [ * ] test-decimal-op ] all? ] unit-test
+[ t ] [ 1000 [ drop [ D+ ] [ + ] test-decimal-op ] all-integers? ] unit-test
+[ t ] [ 1000 [ drop [ D- ] [ - ] test-decimal-op ] all-integers? ] unit-test
+[ t ] [ 1000 [ drop [ D* ] [ * ] test-decimal-op ] all-integers? ] unit-test
[ t ] [
1000 [
drop
[ [ 100 D/ ] [ /f ] test-decimal-op ]
[ { "kernel-error" 4 f f } = ] recover
- ] all?
+ ] all-integers?
] unit-test
[ t ] [
--- /dev/null
+IN: grid-meshes.tests
+USING: alien.c-types grid-meshes grid-meshes.private
+specialized-arrays tools.test ;
+SPECIALIZED-ARRAY: float
+
+[
+ float-array{
+ 0.0 0.0 0.0 1.0
+ 0.0 0.0 0.5 1.0
+ 0.5 0.0 0.0 1.0
+ 0.5 0.0 0.5 1.0
+ 1.0 0.0 0.0 1.0
+ 1.0 0.0 0.5 1.0
+ 0.0 0.0 0.5 1.0
+ 0.0 0.0 1.0 1.0
+ 0.5 0.0 0.5 1.0
+ 0.5 0.0 1.0 1.0
+ 1.0 0.0 0.5 1.0
+ 1.0 0.0 1.0 1.0
+ }
+] [ { 2 2 } vertex-array byte-array>float-array ] unit-test
] map ;
: find-by-id ( vector id -- vector' elt/f )
- '[ attributes>> "id" at _ = ] find ;
+ '[ attributes>> "id" swap at _ = ] find ;
: find-by-class ( vector id -- vector' elt/f )
- '[ attributes>> "class" at _ = ] find ;
+ '[ attributes>> "class" swap at _ = ] find ;
: find-by-name ( vector string -- vector elt/f )
>lower '[ name>> _ = ] find ;
[ t ]
-[ 10000 [ synchsafe>seq seq>synchsafe ] map [ < ] monotonic? ] unit-test
+[ 10000 iota [ synchsafe>seq seq>synchsafe ] map [ < ] monotonic? ] unit-test
"Please note: in Factor " { $emphasis "fixnums are sequences too." } " If you are not careful with sequence accesses you may introduce subtle bugs:"
{ $example
"USING: arrays infix locals ;"
- ":: add-2nd-element ( x y -- res )"
+ ":: add-2nd-elements ( x y -- res )"
" [infix x[1] + y[1] infix] ;"
- "{ 1 2 3 } 5 add-2nd-element ."
+ "{ 1 2 3 } { 0 1 2 3 } add-2nd-elements ."
"3"
}
;
: equally-spaced-radians ( n -- seq )
#! return a sequence of n numbers between 0 and 2pi
- dup [ / pi 2 * * ] curry map ;
+ [ iota ] keep [ / pi 2 * * ] curry map ;
: draw-segment-vertex ( segment theta -- )
over color>> gl-color segment-vertex-and-normal
: random-float+- ( n -- m )
#! find a random float between -n/2 and n/2
- dup 10000 * >fixnum random 10000 / swap 2 / - ;
+ dup 10000 * >integer random 10000 / swap 2 / - ;
: random-turn ( oint theta -- )
2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
[ natural-sort ] keep [ index ] curry map ;
: (inversions) ( n seq -- n )
- [ > ] with filter length ;
+ [ > ] with count ;
: inversions ( seq -- n )
- 0 swap [ length ] keep [
+ 0 swap [ length iota ] keep [
[ nth ] 2keep swap 1 + tail-slice (inversions) +
] curry each ;
[ dup length pick nth push ] reduce ;
: nth-basis-elt ( generators n -- elt )
- over length [
+ over length iota [
3dup bit? [ nth ] [ 2drop f ] if
] map sift 2nip ;
: basis ( generators -- seq )
- natural-sort dup length 2^ [ nth-basis-elt ] with map ;
+ natural-sort dup length 2^ iota [ nth-basis-elt ] with map ;
: (tensor) ( seq1 seq2 -- seq )
[
dim-im/ker-d ;
: graded-ker/im-d ( graded-basis -- seq )
- [ length ] keep [ (graded-ker/im-d) ] curry map ;
+ [ length iota ] keep [ (graded-ker/im-d) ] curry map ;
: graded-betti ( generators -- seq )
basis graded graded-ker/im-d unzip but-last 0 prefix v- ;
3array ;
:: bigraded-triples ( grid -- triples )
- grid length [| z |
- grid first length [| u |
+ grid length iota [| z |
+ grid first length iota [| u |
u z grid bigraded-triple
] map
] map ;
M: unix really-delete-tree delete-tree ;
: retry ( n quot -- )
+ [ iota ] dip
'[ drop @ f ] attempt-all drop ; inline
:: upload-safely ( local username host remote -- )
}
: gamma-z ( x n -- seq )
- [ + recip ] with map 1.0 0 pick set-nth ;
+ [ + recip ] with { } map-integers 1.0 0 pick set-nth ;
: (gamma-lanczos6) ( x -- log[gamma[x+1]] )
#! log(gamma(x+1)
first 3digits>text
] [
[ set-conjunction "" ] [ length ] [ ] tri
- [ (recombine) ] curry each
+ [ (recombine) ] curry each-integer
] if ;
: (number>text) ( n -- str )
line-width 2 - glLineWidth
line-width 2 - glPointSize
1.0 1.0 1.0 1.0 glColor4d
- dup [ drop t <array> ] with map visited set
+ dup
iota [ drop t <array> ] with map visited set
GL_LINE_STRIP glBegin
{ 0 0 } dup vertex (draw-maze)
glEnd ;
! (c)2009 Joe Groff bsd license
USING: accessors arrays bit-arrays classes
-classes.tuple.private fry kernel locals parser
+classes.tuple.private fry kernel locals math parser
sequences sequences.private vectors words ;
IN: memory.pools
: <pool> ( size class -- pool )
[ nip new ]
- [ [ iota ] dip '[ _ new ] V{ } replicate-as ] 2bi
+ [ '[ _ new ] V{ } replicate-as ] 2bi
pool boa ;
: pool-size ( pool -- size )
:: copy-tuple ( from to -- to )
from tuple-size :> size
- size [| n | n from array-nth n to set-array-nth ] each
+ size [| n | n from array-nth n to set-array-nth ] each-integer
to ; inline
: (pool-new) ( pool -- object )
: canonicalize-specializer-1 ( specializer -- specializer' )
[
[ class? ] filter
- [ length <reversed> [ 1 + neg ] map ] keep zip
+ [ length iota <reversed> [ 1 + neg ] map ] keep zip
[ length args [ max ] change ] keep
]
[
swap "predicate" word-prop append ;
: multi-predicate ( classes -- quot )
- dup length <reversed>
+ dup length iota <reversed>
[ picker 2array ] 2map
[ drop object eq? not ] assoc-filter
[ [ t ] ] [
--- /dev/null
+IN: noise.tests
+USING: noise tools.test sequences math ;
+
+[ t ] [ { 100 100 } perlin-noise-map-coords [ [ 100 <= ] all? ] all? ] unit-test
faded trilerp ;
MEMO: perlin-noise-map-coords ( dim -- coords )
- first2 [| x y | x [ y 0.0 0.0 float-4-boa ] float-4-array{ } map-as ] with map concat ;
+ first2 iota [| x y | x iota [ y 0.0 0.0 float-4-boa ] float-4-array{ } map-as ] with map concat ;
TYPED:: perlin-noise-map ( table: byte-array transform: matrix4 coords: float-4-array -- map: float-array )
coords [| coord | table transform coord m4.v perlin-noise ] data-map( float-4 -- c:float )
: range ( r from to -- n )
over - 1 + rot [
- '[ over + @ drop ] each drop f
+ '[ over + @ drop ] each-integer drop f
] bshift 2nip ; inline
[ 55 ] [
: euler001b ( -- answer )
- 1000 [0,b) [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
+ 1000 iota [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
! [ euler001b ] 100 ave-time
! 0 ms ave run time - 0.06 SD (100 trials)
: euler001c ( -- answer )
- 1000 [0,b) [ { 3 5 } [ divisor? ] with any? ] filter sum ;
+ 1000 iota [ { 3 5 } [ divisor? ] with any? ] filter sum ;
! [ euler001c ] 100 ave-time
! 0 ms ave run time - 0.06 SD (100 trials)
: pad-front ( matrix -- matrix )
[
- length [ 0 <repetition> ] map
+ length iota [ 0 <repetition> ] map
] keep [ append ] 2map ;
: pad-back ( matrix -- matrix )
<reversed> [
- length [ 0 <repetition> ] map
+ length iota [ 0 <repetition> ] map
] keep [ <reversed> append ] 2map ;
: diagonal/ ( -- matrix )
[ [ dup 1 > ] [ dup , next-collatz ] while , ] { } make ;
: euler014 ( -- answer )
- 1000000 [1,b] 0 [ collatz longest ] reduce first ;
+ 1000000 [1,b] { } [ collatz longest ] reduce first ;
! [ euler014 ] time
! 52868 ms run / 483 ms GC time
PRIVATE>
: euler014a ( -- answer )
- 500000 1000000 [a,b] 1 [
+ 500000 1000000 [a,b] { 1 } [
dup worth-calculating? [ collatz longest ] [ drop ] if
] reduce first ;
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.combinatorics math.parser project-euler.common ;
+USING: kernel math.combinatorics math.parser project-euler.common
+sequences ;
IN: project-euler.024
! http://projecteuler.net/index.php?section=problems&id=24
! --------
: euler024 ( -- answer )
- 999999 10 permutation 10 digits>integer ;
+ 999999 10 iota permutation 10 digits>integer ;
! [ euler024 ] 100 ave-time
! 0 ms ave run time - 0.27 SD (100 trials)
<PRIVATE
: source-027 ( -- seq )
- 1000 [0,b) [ prime? ] filter [ dup [ neg ] map append ] keep
+ 1000 iota [ prime? ] filter [ dup [ neg ] map append ] keep
cartesian-product [ first2 < ] filter ;
: quadratic ( b a n -- m )
PRIVATE>
: euler030 ( -- answer )
- 325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1 - ;
+ 325537 iota [ dup sum-fifth-powers = ] filter sum 1 - ;
! [ euler030 ] 100 ave-time
! 1700 ms ave run time - 64.84 SD (100 trials)
: source-032 ( -- seq )
9 factorial iota [
- 9 permutation [ 1 + ] map 10 digits>integer
+ 9 iota permutation [ 1 + ] map 10 digits>integer
] map ;
: 1and4 ( n -- ? )
: interesting? ( seq -- ? )
{
- [ 17 8 rot subseq-divisible? ]
- [ 13 7 rot subseq-divisible? ]
- [ 11 6 rot subseq-divisible? ]
- [ 7 5 rot subseq-divisible? ]
- [ 5 4 rot subseq-divisible? ]
- [ 3 3 rot subseq-divisible? ]
- [ 2 2 rot subseq-divisible? ]
+ [ [ 17 8 ] dip subseq-divisible? ]
+ [ [ 13 7 ] dip subseq-divisible? ]
+ [ [ 11 6 ] dip subseq-divisible? ]
+ [ [ 7 5 ] dip subseq-divisible? ]
+ [ [ 5 4 ] dip subseq-divisible? ]
+ [ [ 3 3 ] dip subseq-divisible? ]
+ [ [ 2 2 ] dip subseq-divisible? ]
} 1&& ;
PRIVATE>
[ unclip 1 head prefix concat ] map [ all-unique? ] filter ;
: add-missing-digit ( seq -- seq )
- dup natural-sort 10 swap diff prepend ;
+ dup natural-sort 10 iota swap diff prepend ;
: interesting-pandigitals ( -- seq )
17 candidates { 13 11 7 5 3 2 } [
<PRIVATE
: map-nx ( n x -- seq )
- [ 1 + * ] with map ; inline
+ iota [ 1 + * ] with map ; inline
: all-same-digits? ( seq -- ? )
[ number>digits natural-sort ] map all-equal? ;
! --------
: euler053 ( -- answer )
- 23 100 [a,b] [ dup [ nCk 1000000 > ] with count ] map-sum ;
+ 23 100 [a,b] [ dup iota [ nCk 1000000 > ] with count ] map-sum ;
! [ euler053 ] 100 ave-time
! 52 ms ave run time - 4.44 SD (100 trials)
PRIVATE>
: euler055 ( -- answer )
- 10000 [0,b) [ lychrel? ] count ;
+ 10000 iota [ lychrel? ] count ;
! [ euler055 ] 100 ave-time
! 478 ms ave run time - 30.63 SD (100 trials)
>fraction [ number>string length ] bi@ > ; inline
: euler057 ( -- answer )
- 0 1000 [0,b) [ drop 2 + recip dup 1 + longer-numerator? ] count nip ;
+ 0 1000 iota [ drop 2 + recip dup 1 + longer-numerator? ] count nip ;
! [ euler057 ] 100 ave-time
! 1728 ms ave run time - 80.81 SD (100 trials)
3dup minimal-path-sum-to '[ _ + ] change-matrix ;
: (euler081) ( matrix -- n )
- dup first length [0,b) dup cartesian-product
+ dup first length iota dup cartesian-product
[ first2 pick update-minimal-path-sum ] each
last last ;
:: (euler150) ( m -- n )
sums-triangle :> table
- m [| x |
- x 1 + [| y |
- m x - [0,b) [| z |
+ m iota [| x |
+ x 1 + iota [| y |
+ m x - iota [| z |
x z + table nth-unsafe
[ y z + 1 + swap nth-unsafe ]
[ y swap nth-unsafe ] bi -
{ { 0 0 1 0 } [ { 0 0 0 1 } (euler151) 1 + ] }
{ { 0 1 0 0 } [ { 0 0 1 1 } (euler151) 1 + ] }
{ { 1 0 0 0 } [ { 0 1 1 1 } (euler151) 1 + ] }
- [ [ dup length [ pick-sheet ] with map sum ] [ sum ] bi / ]
+ [ [ dup length iota [ pick-sheet ] with map sum ] [ sum ] bi / ]
} case ] cache ;
: euler151 ( -- answer )
<PRIVATE
: next-keys ( key -- keys )
- [ last ] [ 10 swap sum - ] bi [ 2array ] with map ;
+ [ last ] [ 10 swap sum - iota ] bi [ 2array ] with map ;
: next-table ( assoc -- assoc )
H{ } clone swap
<PRIVATE
: max-children ( seq -- seq )
- [ dup length 1 - [ nth-pair max , ] with each ] { } make ;
+ [ dup length 1 - iota [ nth-pair max , ] with each ] { } make ;
! Propagate one row into the upper one
: propagate ( bottom top -- newtop )
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables help.markup help.stylesheet io
io.styles kernel math models namespaces sequences ui ui.gadgets
[ first3 ] dip head 3array ;
: strip-tease ( data -- seq )
- dup third length 1 - [
+ dup third length 1 - iota [
2 + (strip-tease)
] with map ;
] with-compilation-unit ;
: test-inference ( ast -- in# out# )
- test-compilation infer [ in>> ] [ out>> ] bi ;
+ test-compilation infer [ in>> ] [ out>> ] bi [ length ] bi@ ;
[ 2 1 ] [
T{ ast-block f
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators effects generic generic.standard
+USING: arrays combinators effects generic generic.standard
kernel sequences words lexer ;
IN: smalltalk.selectors
: selector>effect ( selector -- effect )
dup selector-type {
- { unary [ drop 0 ] }
- { binary [ drop 1 ] }
- { keyword [ [ CHAR: : = ] count ] }
+ { unary [ drop { } ] }
+ { binary [ drop { "x" } ] }
+ { keyword [ [ CHAR: : = ] count "x" <array> ] }
} case "receiver" suffix { "result" } <effect> ;
: selector>generic ( selector -- generic )
--- /dev/null
+IN: sudoku.tests
+USING: tools.test sudoku ;
+
+[ ] [ sudoku-demo ] unit-test
: box-any? ( n x y -- ? )
[ 3 /i 3 * ] bi@
- 9 [ [ 3dup ] dip cell-any? ] any?
+ 9 iota [ [ 3dup ] dip cell-any? ] any?
[ 3drop ] dip ;
DEFER: search
[ assume ]
} cond ;
-: solve ( x y -- ) 9 [ 1 + 2over attempt ] each 2drop ;
+: solve ( x y -- ) 9 [ 1 + 2over attempt ] each-integer 2drop ;
: board. ( board -- )
standard-table-style [
] each
] with-row
] each
- ] tabular-output ;
+ ] tabular-output nl ;
: solution. ( -- )
solutions inc "Solution:" print board get board. ;
: fica-base-rate ( year -- x )
H{
+ { 2009 106800 }
{ 2008 102000 }
{ 2007 97500 }
} at [ fica-base-unknown ] unless* ;
TUPLE: board { width integer } { height integer } rows ;
: make-rows ( width height -- rows )
- [ drop f <array> ] with map ;
+
iota [ drop f <array> ] with map ;
: <board> ( width height -- board )
2dup make-rows board boa ;
: block-free? ( board block -- ? ) block not ;
: block-in-bounds? ( board block -- ? )
- [ first swap width>> bounds-check? ] 2keep
- second swap height>> bounds-check? and ;
+ [ first swap width>> iota bounds-check? ]
+ [ second swap height>> iota bounds-check? ] 2bi and ;
: location-valid? ( board block -- ? )
2dup block-in-bounds? [ block-free? ] [ 2drop f ] if ;
[ gl-color 2array draw-block ] [ 3drop ] if ;
: draw-row ( y row -- )
- dup length -rot [ (draw-row) ] 2curry each ;
+ [ length iota swap ] keep [ (draw-row) ] 2curry each ;
: draw-board ( board -- )
- rows>> dup length swap
+ rows>> [ length iota ] keep
[ dupd nth draw-row ] curry each ;
: scale-board ( width height board -- )
IN: trees.splay.tests
: randomize-numeric-splay-tree ( splay-tree -- )
- 100 [ drop 100 random swap at drop ] with each ;
+ 100 iota [ drop 100 random swap at drop ] with each ;
: make-numeric-splay-tree ( n -- splay-tree )
- <splay> [ [ conjoin ] curry each ] keep ;
+ iota <splay> [ [ conjoin ] curry each ] keep ;
[ t ] [
100 make-numeric-splay-tree dup randomize-numeric-splay-tree
-CFLAGS += -DWINDOWS -mno-cygwin
+CFLAGS += -mno-cygwin
LIBS = -lm
PLAF_DLL_OBJS += vm/os-windows.o
SHARED_FLAG = -shared
B blah
the offset from the immediate operand to LOAD32 to the instruction after
- the branch is two instructions. */
-static const fixnum xt_tail_pic_offset = 4 * 2;
+ the branch is one instruction. */
+static const fixnum xt_tail_pic_offset = 4;
inline static void check_call_site(cell return_address)
{
}
/* Defined in assembly */
-VM_C_API void c_to_factor(cell quot, void *vm);
-VM_C_API void throw_impl(cell quot, void *new_stack, void *vm);
-VM_C_API void lazy_jit_compile_impl(cell quot, void *vm);
VM_C_API void flush_icache(cell start, cell len);
-VM_C_API void set_callstack(
- void *vm,
- stack_frame *to,
- stack_frame *from,
- cell length,
- void *(*memcpy)(void*,const void*, size_t));
-
}
case RC_ABSOLUTE_PPC_2:
return load_value_masked(rel_absolute_ppc_2_mask,16,0);
case RC_RELATIVE_PPC_2:
- return load_value_masked(rel_relative_ppc_2_mask,16,0) + relative_to;
+ return load_value_masked(rel_relative_ppc_2_mask,16,0) + relative_to - sizeof(cell);
case RC_RELATIVE_PPC_3:
- return load_value_masked(rel_relative_ppc_3_mask,6,0) + relative_to;
+ return load_value_masked(rel_relative_ppc_3_mask,6,0) + relative_to - sizeof(cell);
case RC_RELATIVE_ARM_3:
return load_value_masked(rel_relative_arm_3_mask,6,2) + relative_to + sizeof(cell);
case RC_INDIRECT_ARM:
store_value_masked(absolute_value,rel_absolute_ppc_2_mask,0);
break;
case RC_RELATIVE_PPC_2:
- store_value_masked(relative_value,rel_relative_ppc_2_mask,0);
+ store_value_masked(relative_value + sizeof(cell),rel_relative_ppc_2_mask,0);
break;
case RC_RELATIVE_PPC_3:
- store_value_masked(relative_value,rel_relative_ppc_3_mask,0);
+ store_value_masked(relative_value + sizeof(cell),rel_relative_ppc_3_mask,0);
break;
case RC_RELATIVE_ARM_3:
store_value_masked(relative_value - sizeof(cell),rel_relative_arm_3_mask,2);
#include <vector>
#include <iostream>
+/* Detect target CPU type */
+#if defined(__arm__)
+ #define FACTOR_ARM
+#elif defined(__amd64__) || defined(__x86_64__)
+ #define FACTOR_AMD64
+ #define FACTOR_64
+#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32)
+ #define FACTOR_X86
+#elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC)
+ #define FACTOR_PPC
+#else
+ #error "Unsupported architecture"
+#endif
+
+#ifdef WIN32
+ #define WINDOWS
+#endif
+
/* Forward-declare this since it comes up in function prototypes */
namespace factor
{
#define STRCMP wcscmp
#define STRNCMP wcsncmp
#define STRDUP _wcsdup
-#define MIN(a,b) ((a)>(b)?(b):(a))
#define FTELL ftello64
#define FSEEK fseeko64
-#if defined(__arm__)
- #define FACTOR_ARM
-#elif defined(__amd64__) || defined(__x86_64__)
- #define FACTOR_AMD64
-#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32)
- #define FACTOR_X86
-#elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC)
- #define FACTOR_PPC
-#else
- #error "Unsupported architecture"
-#endif
-
#if defined(WINDOWS)
#if defined(WINCE)
#include "os-windows-ce.hpp"
#endif
#include "os-windows.hpp"
+
#if defined(FACTOR_AMD64)
#include "os-windows-nt.64.hpp"
#elif defined(FACTOR_X86)
projects / factor.git / commitdiff