diff --git a/basis/alarms/alarms-tests.factor b/basis/alarms/alarms-tests.factor index 7c64680a83..2379e3e80d 100644 --- a/basis/alarms/alarms-tests.factor +++ b/basis/alarms/alarms-tests.factor @@ -1,6 +1,6 @@ -IN: alarms.tests USING: alarms alarms.private kernel calendar sequences tools.test threads concurrency.count-downs ; +IN: alarms.tests [ ] [ 1 diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor index f9fdce806f..9943d39ad1 100644 --- a/basis/alarms/alarms.factor +++ b/basis/alarms/alarms.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays calendar combinators generic init -kernel math namespaces sequences heaps boxes threads -quotations assocs math.order ; +USING: accessors assocs boxes calendar +combinators.short-circuit fry heaps init kernel math.order +namespaces quotations threads ; IN: alarms TUPLE: alarm @@ -21,21 +21,21 @@ SYMBOL: alarm-thread ERROR: bad-alarm-frequency frequency ; : check-alarm ( frequency/f -- frequency/f ) - dup [ duration? ] [ not ] bi or [ bad-alarm-frequency ] unless ; + dup { [ duration? ] [ not ] } 1|| [ bad-alarm-frequency ] unless ; : ( quot time frequency -- alarm ) check-alarm alarm boa ; : register-alarm ( alarm -- ) - dup dup time>> alarms get-global heap-push* - swap entry>> >box + [ dup time>> alarms get-global heap-push* ] + [ entry>> >box ] bi notify-alarm-thread ; : alarm-expired? ( alarm now -- ? ) [ time>> ] dip before=? ; : reschedule-alarm ( alarm -- ) - dup [ swap interval>> time+ now max ] change-time register-alarm ; + dup '[ _ interval>> time+ now max ] change-time register-alarm ; : call-alarm ( alarm -- ) [ entry>> box> drop ] diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index ea9e881fd4..0de26aad20 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -1,6 +1,6 @@ -IN: alien.c-types.tests USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc alien.strings io.encodings.utf8 ; +IN: alien.c-types.tests CONSTANT: xyz 123 diff --git a/basis/alien/complex/complex.factor b/basis/alien/complex/complex.factor index c80ead73f0..b0229358d1 100644 --- a/basis/alien/complex/complex.factor +++ b/basis/alien/complex/complex.factor @@ -10,4 +10,4 @@ IN: alien.complex ! This overrides the fact that small structures are never returned ! in registers on NetBSD, Linux and Solaris running on 32-bit x86. "complex-float" c-type t >>return-in-registers? drop - >> +>> diff --git a/basis/alien/complex/functor/functor-tests.factor b/basis/alien/complex/functor/functor-tests.factor deleted file mode 100644 index c2df22be1d..0000000000 --- a/basis/alien/complex/functor/functor-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test alien.complex.functor ; -IN: alien.complex.functor.tests diff --git a/basis/alien/destructors/destructors-tests.factor b/basis/alien/destructors/destructors-tests.factor deleted file mode 100644 index 4f434452d4..0000000000 --- a/basis/alien/destructors/destructors-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test alien.destructors ; -IN: alien.destructors.tests diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 15840dfd66..013c4d6f6a 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -357,10 +357,10 @@ M: character-type () : (shuffle-map) ( return parameters -- ret par ) [ - fortran-ret-type>c-type length swap "void" = [ 1+ ] unless + fortran-ret-type>c-type length swap "void" = [ 1 + ] unless letters swap head [ "ret" swap suffix ] map ] [ - [ fortran-arg-type>c-type nip length 1+ ] map letters swap zip + [ fortran-arg-type>c-type nip length 1 + ] map letters swap zip [ first2 letters swap head [ "" 2sequence ] with map ] map concat ] bi* ; diff --git a/basis/alien/libraries/libraries-tests.factor b/basis/alien/libraries/libraries-tests.factor index 13eb134ea9..f1dc228d83 100644 --- a/basis/alien/libraries/libraries-tests.factor +++ b/basis/alien/libraries/libraries-tests.factor @@ -1,5 +1,5 @@ -IN: alien.libraries.tests USING: alien.libraries alien.syntax tools.test kernel ; +IN: alien.libraries.tests [ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test @@ -7,4 +7,4 @@ USING: alien.libraries alien.syntax tools.test kernel ; [ ] [ "doesnotexist" dlopen dlclose ] unit-test -[ "fdasfsf" dll-valid? drop ] must-fail \ No newline at end of file +[ "fdasfsf" dll-valid? drop ] must-fail diff --git a/basis/alien/structs/structs-tests.factor b/basis/alien/structs/structs-tests.factor index 231f1bd428..3f84377d5c 100755 --- a/basis/alien/structs/structs-tests.factor +++ b/basis/alien/structs/structs-tests.factor @@ -1,6 +1,6 @@ -IN: alien.structs.tests USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc words vocabs namespaces layouts ; +IN: alien.structs.tests C-STRUCT: bar { "int" "x" } diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index d479e6d498..b70aa3557c 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -31,8 +31,10 @@ SYNTAX: C-ENUM: ";" parse-tokens [ [ create-in ] dip define-constant ] each-index ; +ERROR: no-such-symbol name library ; + : address-of ( name library -- value ) - load-library dlsym [ "No such symbol" throw ] unless* ; + 2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ; SYNTAX: &: scan "c-library" get '[ _ _ address-of ] over push-all ; diff --git a/basis/ascii/ascii-tests.factor b/basis/ascii/ascii-tests.factor index 6f39b32a01..8551ba53ef 100644 --- a/basis/ascii/ascii-tests.factor +++ b/basis/ascii/ascii-tests.factor @@ -10,7 +10,7 @@ IN: ascii.tests [ 4 ] [ 0 "There are Four Upper Case characters" - [ LETTER? [ 1+ ] when ] each + [ LETTER? [ 1 + ] when ] each ] unit-test [ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index 47147fa306..eb2c9193a3 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -34,7 +34,7 @@ SYMBOL: column : write1-lines ( ch -- ) write1 column get [ - 1+ [ 76 = [ crlf ] when ] + 1 + [ 76 = [ crlf ] when ] [ 76 mod column set ] bi ] when* ; @@ -48,7 +48,7 @@ SYMBOL: column : encode-pad ( seq n -- ) [ 3 0 pad-tail binary [ encode3 ] with-byte-writer ] - [ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline + [ 1 + ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline : decode4 ( seq -- ) [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ] diff --git a/basis/biassocs/biassocs-tests.factor b/basis/biassocs/biassocs-tests.factor index f408cc82a8..af10eb18e4 100644 --- a/basis/biassocs/biassocs-tests.factor +++ b/basis/biassocs/biassocs-tests.factor @@ -1,5 +1,5 @@ +USING: biassocs assocs namespaces tools.test hashtables kernel ; IN: biassocs.tests -USING: biassocs assocs namespaces tools.test ; "h" set @@ -29,4 +29,14 @@ H{ { "a" "A" } { "b" "B" } } "a" set [ "A" ] [ "a" "b" get at ] unit-test -[ "a" ] [ "A" "b" get value-at ] unit-test \ No newline at end of file +[ "a" ] [ "A" "b" get value-at ] unit-test + +[ ] [ H{ { 1 2 } } >biassoc "h" set ] unit-test + +[ ] [ "h" get clone "g" set ] unit-test + +[ ] [ 3 4 "g" get set-at ] unit-test + +[ H{ { 1 2 } } ] [ "h" get >hashtable ] unit-test + +[ H{ { 1 2 } { 4 3 } } ] [ "g" get >hashtable ] unit-test diff --git a/basis/biassocs/biassocs.factor b/basis/biassocs/biassocs.factor index 5956589ba5..7daa478f54 100644 --- a/basis/biassocs/biassocs.factor +++ b/basis/biassocs/biassocs.factor @@ -43,4 +43,7 @@ M: biassoc new-assoc INSTANCE: biassoc assoc : >biassoc ( assoc -- biassoc ) - T{ biassoc } assoc-clone-like ; \ No newline at end of file + T{ biassoc } assoc-clone-like ; + +M: biassoc clone + [ from>> ] [ to>> ] bi [ clone ] bi@ biassoc boa ; diff --git a/basis/binary-search/binary-search-tests.factor b/basis/binary-search/binary-search-tests.factor index 63d2697418..f2ea7503f4 100644 --- a/basis/binary-search/binary-search-tests.factor +++ b/basis/binary-search/binary-search-tests.factor @@ -1,5 +1,5 @@ -IN: binary-search.tests USING: binary-search math.order vectors kernel tools.test ; +IN: binary-search.tests [ f ] [ 3 { } [ <=> ] with search drop ] unit-test [ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test @@ -9,7 +9,7 @@ USING: binary-search math.order vectors kernel tools.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 -[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test -[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test -[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test -[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] 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 +[ f ] [ "hello" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test +[ f ] [ "zebra" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index cdec87b61d..0b5a63a906 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -44,33 +44,33 @@ PRIVATE> : ( n -- bit-array ) dup bits>bytes bit-array boa ; inline -M: bit-array length length>> ; +M: bit-array length length>> ; inline M: bit-array nth-unsafe - [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; + [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline M: bit-array set-nth-unsafe [ >fixnum ] [ underlying>> ] bi* [ byte/bit set-bit ] 2keep - swap n>byte set-alien-unsigned-1 ; + swap n>byte set-alien-unsigned-1 ; inline GENERIC: clear-bits ( bit-array -- ) -M: bit-array clear-bits 0 (set-bits) ; +M: bit-array clear-bits 0 (set-bits) ; inline GENERIC: set-bits ( bit-array -- ) -M: bit-array set-bits -1 (set-bits) ; +M: bit-array set-bits -1 (set-bits) ; inline M: bit-array clone - [ length>> ] [ underlying>> clone ] bi bit-array boa ; + [ length>> ] [ underlying>> clone ] bi bit-array boa ; inline : >bit-array ( seq -- bit-array ) T{ bit-array f 0 B{ } } clone-like ; inline -M: bit-array like drop dup bit-array? [ >bit-array ] unless ; +M: bit-array like drop dup bit-array? [ >bit-array ] unless ; inline -M: bit-array new-sequence drop ; +M: bit-array new-sequence drop ; inline M: bit-array equal? over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ; @@ -81,7 +81,7 @@ M: bit-array resize resize-byte-array ] 2bi bit-array boa - dup clean-up ; + dup clean-up ; inline M: bit-array byte-length length 7 + -3 shift ; @@ -91,10 +91,10 @@ SYNTAX: ?{ \ } [ >bit-array ] parse-literal ; dup 0 = [ ] [ - [ log2 1+ 0 ] keep + [ log2 1 + 0 ] keep [ dup 0 = ] [ [ pick underlying>> pick set-alien-unsigned-1 ] keep - [ 1+ ] [ -8 shift ] bi* + [ 1 + ] [ -8 shift ] bi* ] until 2drop ] if ; diff --git a/basis/bit-sets/bit-sets-tests.factor b/basis/bit-sets/bit-sets-tests.factor index e77bb43986..6a1366a1ea 100644 --- a/basis/bit-sets/bit-sets-tests.factor +++ b/basis/bit-sets/bit-sets-tests.factor @@ -1,5 +1,5 @@ -IN: bit-sets.tests USING: bit-sets tools.test bit-arrays ; +IN: bit-sets.tests [ ?{ t f t f t f } ] [ ?{ t f f f t f } diff --git a/basis/bit-vectors/bit-vectors-tests.factor b/basis/bit-vectors/bit-vectors-tests.factor index 41efdbd0d2..5af44b59f7 100644 --- a/basis/bit-vectors/bit-vectors-tests.factor +++ b/basis/bit-vectors/bit-vectors-tests.factor @@ -1,5 +1,5 @@ -IN: bit-vectors.tests USING: tools.test bit-vectors vectors sequences kernel math ; +IN: bit-vectors.tests [ 0 ] [ 123 length ] unit-test diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor index a5b1b43acd..794faa6055 100644 --- a/basis/bitstreams/bitstreams-tests.factor +++ b/basis/bitstreams/bitstreams-tests.factor @@ -5,7 +5,6 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary io.streams.byte-array ; IN: bitstreams.tests - [ BIN: 1111111111 ] [ B{ HEX: 0f HEX: ff HEX: ff HEX: ff } diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 2aa0059542..0eef54dc66 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -70,7 +70,7 @@ GENERIC: poke ( value n bitstream -- ) [ get-abp + ] [ set-abp ] bi ; inline : (align) ( n m -- n' ) - [ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline + [ /mod 0 > [ 1 + ] when ] [ * ] bi ; inline : align ( n bitstream -- ) [ get-abp swap (align) ] [ set-abp ] bi ; inline diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index d0f7147452..e9187cc3b1 100755 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -35,83 +35,87 @@ gc : compile-unoptimized ( words -- ) [ optimized? not ] filter compile ; -nl -"Compiling..." write flush +"debug-compiler" get [ + + nl + "Compiling..." write flush -! Compile a set of words ahead of the full compile. -! This set of words was determined semi-empirically -! using the profiler. It improves bootstrap time -! significantly, because frequenly called words -! which are also quick to compile are replaced by -! compiled definitions as soon as possible. -{ - not ? + ! Compile a set of words ahead of the full compile. + ! This set of words was determined semi-empirically + ! using the profiler. It improves bootstrap time + ! significantly, because frequenly called words + ! which are also quick to compile are replaced by + ! compiled definitions as soon as possible. + { + not ? - 2over roll -roll + 2over roll -roll - array? hashtable? vector? - tuple? sbuf? tombstone? - curry? compose? callable? - quotation? + array? hashtable? vector? + tuple? sbuf? tombstone? + curry? compose? callable? + quotation? - curry compose uncurry + curry compose uncurry - array-nth set-array-nth length>> + array-nth set-array-nth length>> - wrap probe + wrap probe - namestack* + namestack* - layout-of -} compile-unoptimized + layout-of + } compile-unoptimized -"." write flush + "." write flush -{ - bitand bitor bitxor bitnot -} compile-unoptimized + { + bitand bitor bitxor bitnot + } compile-unoptimized -"." write flush + "." write flush -{ - + 1+ 1- 2/ < <= > >= shift -} compile-unoptimized + { + + 2/ < <= > >= shift + } compile-unoptimized -"." write flush + "." write flush -{ - new-sequence nth push pop last flip -} compile-unoptimized + { + new-sequence nth push pop last flip + } compile-unoptimized -"." write flush + "." write flush -{ - hashcode* = equal? assoc-stack (assoc-stack) get set -} compile-unoptimized + { + hashcode* = equal? assoc-stack (assoc-stack) get set + } compile-unoptimized -"." write flush + "." write flush -{ - memq? split harvest sift cut cut-slice start index clone - set-at reverse push-all class number>string string>number - like clone-like -} compile-unoptimized + { + memq? split harvest sift cut cut-slice start index clone + set-at reverse push-all class number>string string>number + like clone-like + } compile-unoptimized -"." write flush + "." write flush -{ - lines prefix suffix unclip new-assoc update - word-prop set-word-prop 1array 2array 3array ?nth -} compile-unoptimized + { + lines prefix suffix unclip new-assoc update + word-prop set-word-prop 1array 2array 3array ?nth + } compile-unoptimized -"." write flush + "." write flush -{ - malloc calloc free memcpy -} compile-unoptimized + { + malloc calloc free memcpy + } compile-unoptimized -"." write flush + "." write flush -vocabs [ words compile-unoptimized "." write flush ] each + vocabs [ words compile-unoptimized "." write flush ] each -" done" print flush + " done" print flush + +] unless \ No newline at end of file diff --git a/basis/bootstrap/image/image-tests.factor b/basis/bootstrap/image/image-tests.factor index e7070d3cf2..c5c6460041 100644 --- a/basis/bootstrap/image/image-tests.factor +++ b/basis/bootstrap/image/image-tests.factor @@ -1,6 +1,6 @@ -IN: bootstrap.image.tests USING: bootstrap.image bootstrap.image.private tools.test kernel math ; +IN: bootstrap.image.tests [ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index d76588e4e4..38cb5c12fe 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -234,7 +234,7 @@ GENERIC: ' ( obj -- ptr ) : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ; -: bignum-radix ( -- n ) bignum-bits 2^ 1- ; +: bignum-radix ( -- n ) bignum-bits 2^ 1 - ; : bignum>seq ( n -- seq ) #! n is positive or zero. @@ -244,7 +244,7 @@ GENERIC: ' ( obj -- ptr ) : emit-bignum ( n -- ) dup dup 0 < [ neg ] when bignum>seq - [ nip length 1+ emit-fixnum ] + [ nip length 1 + emit-fixnum ] [ drop 0 < 1 0 ? emit ] [ nip emit-seq ] 2tri ; diff --git a/basis/bootstrap/image/upload/upload.factor b/basis/bootstrap/image/upload/upload.factor index d70a253e5f..7f25ce9c01 100644 --- a/basis/bootstrap/image/upload/upload.factor +++ b/basis/bootstrap/image/upload/upload.factor @@ -9,9 +9,9 @@ IN: bootstrap.image.upload SYMBOL: upload-images-destination : destination ( -- dest ) - upload-images-destination get - "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/" - or ; + upload-images-destination get + "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/" + or ; : checksums ( -- temp ) "checksums.txt" temp-file ; diff --git a/basis/bootstrap/math/math.factor b/basis/bootstrap/math/math.factor index 27b2f6b181..3bab31daeb 100644 --- a/basis/bootstrap/math/math.factor +++ b/basis/bootstrap/math/math.factor @@ -2,4 +2,4 @@ USING: vocabs vocabs.loader kernel ; "math.ratios" require "math.floats" require -"math.complex" require \ No newline at end of file +"math.complex" require diff --git a/basis/bootstrap/tools/tools.factor b/basis/bootstrap/tools/tools.factor index 6017469925..e5e7e869c8 100644 --- a/basis/bootstrap/tools/tools.factor +++ b/basis/bootstrap/tools/tools.factor @@ -14,6 +14,7 @@ IN: bootstrap.tools "tools.test" "tools.time" "tools.threads" + "tools.deprecation" "vocabs.hierarchy" "vocabs.refresh" "vocabs.refresh.monitor" diff --git a/basis/boxes/boxes-tests.factor b/basis/boxes/boxes-tests.factor index 71fc1c9a7b..3bcb735217 100644 --- a/basis/boxes/boxes-tests.factor +++ b/basis/boxes/boxes-tests.factor @@ -1,5 +1,5 @@ -IN: boxes.tests USING: boxes namespaces tools.test accessors ; +IN: boxes.tests [ ] [ "b" set ] unit-test diff --git a/basis/byte-arrays/hex/hex.factor b/basis/byte-arrays/hex/hex.factor index f1b9a52303..5c381b7db0 100644 --- a/basis/byte-arrays/hex/hex.factor +++ b/basis/byte-arrays/hex/hex.factor @@ -8,4 +8,3 @@ SYNTAX: HEX{ [ blank? not ] filter 2 group [ hex> ] B{ } map-as parsed ; - diff --git a/basis/cache/cache-tests.factor b/basis/cache/cache-tests.factor deleted file mode 100644 index cbf4f64e22..0000000000 --- a/basis/cache/cache-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test cache ; -IN: cache.tests diff --git a/basis/cache/cache.factor b/basis/cache/cache.factor index f16461bf45..3dab1acac8 100644 --- a/basis/cache/cache.factor +++ b/basis/cache/cache.factor @@ -38,6 +38,6 @@ PRIVATE> : purge-cache ( cache -- ) dup max-age>> '[ - [ nip [ 1+ ] change-age age>> _ >= ] assoc-partition + [ nip [ 1 + ] change-age age>> _ >= ] assoc-partition [ values dispose-each ] dip - ] change-assoc drop ; \ No newline at end of file + ] change-assoc drop ; diff --git a/basis/cairo/cairo-tests.factor b/basis/cairo/cairo-tests.factor index bf7c468774..cb19259984 100644 --- a/basis/cairo/cairo-tests.factor +++ b/basis/cairo/cairo-tests.factor @@ -1,8 +1,8 @@ -IN: cairo.tests USING: cairo tools.test math.rectangles accessors ; +IN: cairo.tests [ { 10 20 } ] [ { 10 20 } [ { 0 1 } { 3 4 } fill-rect ] make-bitmap-image dim>> -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index b39a7c7464..71e052bb6c 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -27,7 +27,7 @@ HELP: } ; HELP: month-names -{ $values { "array" array } } +{ $values { "value" object } } { $description "Returns an array with the English names of all the months." } { $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ; diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 4b58b1b496..a8bb60cbf3 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -34,25 +34,25 @@ C: timestamp : ( year month day -- timestamp ) 0 0 0 gmt-offset-duration ; -ERROR: not-a-month n ; +ERROR: not-a-month ; M: not-a-month summary drop "Months are indexed starting at 1" ; -: month-names ( -- array ) +CONSTANT: month-names { "January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December" - } ; + } : month-name ( n -- string ) - check-month 1- month-names nth ; + check-month 1 - month-names nth ; CONSTANT: month-abbreviations { @@ -61,7 +61,7 @@ CONSTANT: month-abbreviations } : month-abbreviation ( n -- string ) - check-month 1- month-abbreviations nth ; + check-month 1 - month-abbreviations nth ; CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } @@ -113,7 +113,7 @@ CONSTANT: day-abbreviations3 100 b * d + 4800 - m 10 /i + m 3 + 12 m 10 /i * - - e 153 m * 2 + 5 /i - 1+ ; + e 153 m * 2 + 5 /i - 1 + ; GENERIC: easter ( obj -- obj' ) @@ -186,9 +186,6 @@ GENERIC: +second ( timestamp x -- timestamp ) { [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&& [ 3 >>month 1 >>day ] when ; -: unless-zero ( n quot -- ) - [ dup zero? [ drop ] ] dip if ; inline - M: integer +year ( timestamp n -- timestamp ) [ [ + ] curry change-year adjust-leap-year ] unless-zero ; @@ -196,7 +193,7 @@ M: real +year ( timestamp n -- timestamp ) [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ; : months/years ( n -- months years ) - 12 /rem dup zero? [ drop 1- 12 ] when swap ; inline + 12 /rem [ 1 - 12 ] when-zero swap ; inline M: integer +month ( timestamp n -- timestamp ) [ over month>> + months/years [ >>month ] dip +year ] unless-zero ; @@ -371,10 +368,10 @@ M: duration time- #! http://web.textfiles.com/computers/formulas.txt #! good for any date since October 15, 1582 [ - dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when + dup 2 <= [ [ 1 - ] [ 12 + ] bi* ] when [ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip - [ 1+ 3 * 5 /i + ] keep 2 * + - ] dip 1+ + 7 mod ; + [ 1 + 3 * 5 /i + ] keep 2 * + + ] dip 1 + + 7 mod ; GENERIC: days-in-year ( obj -- n ) @@ -395,7 +392,7 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ; year leap-year? [ year month day year 3 1 - after=? [ 1+ ] when + after=? [ 1 + ] when ] when ; : day-of-year ( timestamp -- n ) diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index ad43cc2f1d..6aa4126ff9 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -68,8 +68,8 @@ M: array month. ( pair -- ) [ (days-in-month) day-abbreviations2 " " join print ] 2tri over " " concat write [ - [ 1+ day. ] keep - 1+ + 7 mod zero? [ nl ] [ bl ] if + [ 1 + day. ] keep + 1 + + 7 mod zero? [ nl ] [ bl ] if ] with each nl ; M: timestamp month. ( timestamp -- ) @@ -78,7 +78,7 @@ M: timestamp month. ( timestamp -- ) GENERIC: year. ( obj -- ) M: integer year. ( n -- ) - 12 [ 1+ 2array month. nl ] with each ; + 12 [ 1 + 2array month. nl ] with each ; M: timestamp year. ( timestamp -- ) year>> year. ; @@ -162,7 +162,7 @@ M: timestamp year. ( timestamp -- ) : read-rfc3339-seconds ( s -- s' ch ) "+-Z" read-until [ - [ string>number ] [ length 10 swap ^ ] bi / + + [ string>number ] [ length 10^ ] bi / + ] dip ; : (rfc3339>timestamp) ( -- timestamp ) @@ -201,7 +201,7 @@ ERROR: invalid-timestamp-format ; "," read-token day-abbreviations3 member? check-timestamp drop read1 CHAR: \s assert= read-sp checked-number >>day - read-sp month-abbreviations index 1+ check-timestamp >>month + read-sp month-abbreviations index 1 + check-timestamp >>month read-sp checked-number >>year ":" read-token checked-number >>hour ":" read-token checked-number >>minute @@ -220,7 +220,7 @@ ERROR: invalid-timestamp-format ; "," read-token check-day-name read1 CHAR: \s assert= "-" read-token checked-number >>day - "-" read-token month-abbreviations index 1+ check-timestamp >>month + "-" read-token month-abbreviations index 1 + check-timestamp >>month read-sp checked-number >>year ":" read-token checked-number >>hour ":" read-token checked-number >>minute @@ -233,7 +233,7 @@ ERROR: invalid-timestamp-format ; : (cookie-string>timestamp-2) ( -- timestamp ) timestamp new read-sp check-day-name - read-sp month-abbreviations index 1+ check-timestamp >>month + read-sp month-abbreviations index 1 + check-timestamp >>month read-sp checked-number >>day ":" read-token checked-number >>hour ":" read-token checked-number >>minute diff --git a/basis/channels/examples/examples.factor b/basis/channels/examples/examples.factor index 1e51fb06d8..99fa41cd40 100644 --- a/basis/channels/examples/examples.factor +++ b/basis/channels/examples/examples.factor @@ -7,7 +7,7 @@ locals sequences ; IN: channels.examples : (counter) ( channel n -- ) - [ swap to ] 2keep 1+ (counter) ; + [ swap to ] 2keep 1 + (counter) ; : counter ( channel -- ) 2 (counter) ; diff --git a/basis/checksums/fnv1/fnv1.factor b/basis/checksums/fnv1/fnv1.factor index f221cefef2..5cc6b02425 100644 --- a/basis/checksums/fnv1/fnv1.factor +++ b/basis/checksums/fnv1/fnv1.factor @@ -1,9 +1,7 @@ ! Copyright (C) 2009 Alaric Snell-Pym ! See http://factorcode.org/license.txt for BSD license. - USING: checksums classes.singleton kernel math math.ranges math.vectors sequences ; - IN: checksums.fnv1 SINGLETON: fnv1-32 diff --git a/basis/checksums/md5/md5-tests.factor b/basis/checksums/md5/md5-tests.factor index b7f388c002..730c0b8516 100644 --- a/basis/checksums/md5/md5-tests.factor +++ b/basis/checksums/md5/md5-tests.factor @@ -1,6 +1,8 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays checksums checksums.md5 io.encodings.binary io.streams.byte-array kernel math namespaces tools.test ; - +IN: checksums.md5.tests [ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test [ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test diff --git a/basis/circular/circular-tests.factor b/basis/circular/circular-tests.factor index b4a9d547f2..c3c4860f95 100644 --- a/basis/circular/circular-tests.factor +++ b/basis/circular/circular-tests.factor @@ -2,6 +2,7 @@ ! See http;//factorcode.org/license.txt for BSD license USING: arrays kernel tools.test sequences sequences.private circular strings ; +IN: circular.tests [ 0 ] [ { 0 1 2 3 4 } 0 swap virtual@ drop ] unit-test [ 2 ] [ { 0 1 2 3 4 } 2 swap virtual@ drop ] unit-test diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index 9995567ec8..b3be4651cd 100644 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -51,7 +51,7 @@ PRIVATE> : push-growing-circular ( elt circular -- ) dup full? [ push-circular ] - [ [ 1+ ] change-length set-last ] if ; + [ [ 1 + ] change-length set-last ] if ; : ( capacity -- growing-circular ) { } new-sequence 0 0 growing-circular boa ; diff --git a/basis/cocoa/callbacks/callbacks.factor b/basis/cocoa/callbacks/callbacks.factor index 4ed9d7de67..a798eb15ba 100644 --- a/basis/cocoa/callbacks/callbacks.factor +++ b/basis/cocoa/callbacks/callbacks.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2006 Kevin Reid. ! See http://factorcode.org/license.txt for BSD license. -IN: cocoa.callbacks USING: assocs kernel namespaces cocoa cocoa.classes cocoa.subclassing debugger ; +IN: cocoa.callbacks SYMBOL: callbacks diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor index 4b5af2e39d..c657a5e6e8 100644 --- a/basis/cocoa/cocoa-tests.factor +++ b/basis/cocoa/cocoa-tests.factor @@ -1,7 +1,7 @@ -IN: cocoa.tests USING: cocoa cocoa.messages cocoa.subclassing cocoa.types compiler kernel namespaces cocoa.classes tools.test memory compiler.units math core-graphics.types ; +IN: cocoa.tests CLASS: { { +superclass+ "NSObject" } diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index a3fa788f20..9da285f34c 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -172,7 +172,7 @@ ERROR: no-objc-type name ; [ ] [ no-objc-type ] ?if ; : (parse-objc-type) ( i string -- ctype ) - [ [ 1+ ] dip ] [ nth ] 2bi { + [ [ 1 + ] dip ] [ nth ] 2bi { { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] } { [ dup CHAR: ^ = ] [ 3drop "void*" ] } { [ dup CHAR: { = ] [ drop objc-struct-type ] } diff --git a/basis/cocoa/plists/plists-tests.factor b/basis/cocoa/plists/plists-tests.factor index 4f74cd850a..e5d7dfd239 100644 --- a/basis/cocoa/plists/plists-tests.factor +++ b/basis/cocoa/plists/plists-tests.factor @@ -1,7 +1,7 @@ -IN: cocoa.plists.tests USING: tools.test cocoa.plists colors kernel hashtables core-foundation.utilities core-foundation destructors assocs cocoa.enumeration ; +IN: cocoa.plists.tests [ [ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test @@ -37,4 +37,4 @@ assocs cocoa.enumeration ; [ 3.5 ] [ 3.5 >cf &CFRelease plist> ] unit-test -] with-destructors \ No newline at end of file +] with-destructors diff --git a/basis/colors/hsv/hsv-tests.factor b/basis/colors/hsv/hsv-tests.factor index a825cacda8..278906ce0e 100644 --- a/basis/colors/hsv/hsv-tests.factor +++ b/basis/colors/hsv/hsv-tests.factor @@ -1,5 +1,5 @@ -IN: colors.hsv.tests USING: accessors kernel colors colors.hsv tools.test math ; +IN: colors.hsv.tests : hsv>rgb ( h s v -- r g b ) [ 360 * ] 2dip @@ -25,4 +25,4 @@ USING: accessors kernel colors colors.hsv tools.test math ; [ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test [ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test -[ 0.5 ] [ 180 0.1 0.2 0.5 alpha>> ] unit-test \ No newline at end of file +[ 0.5 ] [ 180 0.1 0.2 0.5 alpha>> ] unit-test diff --git a/basis/columns/columns-tests.factor b/basis/columns/columns-tests.factor index 657b9e0a25..a53f5c1185 100644 --- a/basis/columns/columns-tests.factor +++ b/basis/columns/columns-tests.factor @@ -1,5 +1,5 @@ -IN: columns.tests USING: columns sequences kernel namespaces arrays tools.test math ; +IN: columns.tests ! Columns { { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set diff --git a/basis/combinators/short-circuit/smart/smart-tests.factor b/basis/combinators/short-circuit/smart/smart-tests.factor index 7ec4a0e657..c8cf8ffc1b 100644 --- a/basis/combinators/short-circuit/smart/smart-tests.factor +++ b/basis/combinators/short-circuit/smart/smart-tests.factor @@ -1,32 +1,18 @@ - USING: kernel math tools.test combinators.short-circuit.smart ; - IN: combinators.short-circuit.smart.tests -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +[ t ] [ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] unit-test +[ t ] [ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] unit-test +[ t ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] unit-test -: must-be-t ( in -- ) [ t ] swap unit-test ; -: must-be-f ( in -- ) [ f ] swap unit-test ; +[ f ] [ { [ 1 ] [ f ] [ 3 ] } && 3 = ] unit-test +[ f ] [ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] unit-test +[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] unit-test -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +[ t ] [ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] unit-test -[ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] must-be-t -[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] must-be-t -[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] must-be-t +[ t ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] unit-test -[ { [ 1 ] [ f ] [ 3 ] } && 3 = ] must-be-f -[ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] must-be-f -[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] must-be-f - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -[ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] must-be-t - -[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] must-be-t - -[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] must-be-t - -[ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] must-be-f - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +[ t ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] unit-test +[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] unit-test diff --git a/basis/combinators/short-circuit/smart/smart.factor b/basis/combinators/short-circuit/smart/smart.factor index b80e7294d1..7264a07917 100644 --- a/basis/combinators/short-circuit/smart/smart.factor +++ b/basis/combinators/short-circuit/smart/smart.factor @@ -1,13 +1,15 @@ -USING: kernel sequences math stack-checker effects accessors macros -fry combinators.short-circuit ; +USING: kernel sequences math stack-checker effects accessors +macros fry combinators.short-circuit ; IN: combinators.short-circuit.smart > [ "Cannot determine arity" throw ] when - effect-height neg 1+ ; + dup terminated?>> [ cannot-determine-arity ] when + effect-height neg 1 + ; PRIVATE> diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor index d8ee89ef2d..59b65d91cd 100644 --- a/basis/combinators/smart/smart-docs.factor +++ b/basis/combinators/smart/smart-docs.factor @@ -28,7 +28,7 @@ HELP: output>array { $example <" USING: combinators combinators.smart math prettyprint ; 9 [ - { [ 1- ] [ 1+ ] [ sq ] } cleave + { [ 1 - ] [ 1 + ] [ sq ] } cleave ] output>array ."> "{ 8 10 81 }" } @@ -71,7 +71,7 @@ HELP: sum-outputs { $examples { $example "USING: combinators.smart kernel math prettyprint ;" - "10 [ [ 1- ] [ 1+ ] bi ] sum-outputs ." + "10 [ [ 1 - ] [ 1 + ] bi ] sum-outputs ." "20" } } ; diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index a18ef1f3b8..399b4dc36f 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -4,7 +4,7 @@ USING: tools.test combinators.smart math kernel accessors ; IN: combinators.smart.tests : test-bi ( -- 9 11 ) - 10 [ 1- ] [ 1+ ] bi ; + 10 [ 1 - ] [ 1 + ] bi ; [ [ test-bi ] output>array ] must-infer [ { 9 11 } ] [ [ test-bi ] output>array ] unit-test @@ -46,4 +46,4 @@ IN: combinators.smart.tests [ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test -[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test \ No newline at end of file +[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor deleted file mode 100644 index 79165f2c96..0000000000 --- a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor +++ /dev/null @@ -1 +0,0 @@ -IN: compiler.cfg.alias-analysis.tests diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index c3d2deeb02..526df79cb3 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -144,7 +144,7 @@ ERROR: vreg-has-no-slots vreg ; SYMBOL: ac-counter : next-ac ( -- n ) - ac-counter [ dup 1+ ] change ; + ac-counter [ dup 1 + ] change ; ! Alias class for objects which are loaded from the data stack ! or other object slots. We pessimistically assume that they @@ -285,4 +285,4 @@ M: insn eliminate-dead-stores* ; eliminate-dead-stores ; : alias-analysis ( cfg -- cfg' ) - [ alias-analysis-step ] local-optimization ; \ No newline at end of file + [ alias-analysis-step ] local-optimization ; diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 09f670ac54..2c472bc0ff 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -1,11 +1,11 @@ -IN: compiler.cfg.builder.tests USING: tools.test kernel sequences words sequences.private fry prettyprint alien alien.accessors math.private compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker compiler.cfg arrays locals byte-arrays kernel.private math slots.private vectors sbufs strings math.partial-dispatch -strings.private ; +strings.private accessors compiler.cfg.instructions ; +IN: compiler.cfg.builder.tests ! Just ensure that various CFGs build correctly. : unit-test-cfg ( quot -- ) @@ -157,3 +157,26 @@ strings.private ; { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg ] each + +: contains-insn? ( quot insn-check -- ? ) + [ test-mr [ instructions>> ] map ] dip + '[ _ any? ] any? ; inline + +[ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test + +[ f ] [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test + +[ t ] [ + [ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ] + [ ##set-alien-integer-1? ] contains-insn? +] unit-test + +[ t ] [ + [ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ] + [ ##set-alien-integer-1? ] contains-insn? +] unit-test + +[ f ] [ + [ { byte-array fixnum } declare set-alien-unsigned-1 ] + [ ##set-alien-integer-1? ] contains-insn? +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/cfg-tests.factor b/basis/compiler/cfg/cfg-tests.factor deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor index 62043fb413..dde44fd15d 100644 --- a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor +++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor @@ -5,7 +5,7 @@ namespaces functors compiler.cfg.rpo compiler.cfg.utilities compiler.cfg.predecessors compiler.cfg ; IN: compiler.cfg.dataflow-analysis -GENERIC: join-sets ( sets dfa -- set ) +GENERIC: join-sets ( sets bb dfa -- set ) GENERIC: transfer-set ( in-set bb dfa -- out-set ) GENERIC: block-order ( cfg dfa -- bbs ) GENERIC: successors ( bb dfa -- seq ) @@ -23,7 +23,11 @@ GENERIC# compute-in-set 2 ( bb out-sets dfa -- set ) M: kill-block compute-in-set 3drop f ; M:: basic-block compute-in-set ( bb out-sets dfa -- set ) - bb dfa predecessors [ out-sets at ] map dfa join-sets ; + ! Only consider initialized sets. + bb dfa predecessors + [ out-sets key? ] filter + [ out-sets at ] map + bb dfa join-sets ; :: update-in-set ( bb in-sets out-sets dfa -- ? ) bb out-sets dfa compute-in-set @@ -56,7 +60,7 @@ M:: basic-block compute-out-set ( bb in-sets dfa -- set ) in-sets out-sets ; inline -M: dataflow-analysis join-sets drop assoc-refine ; +M: dataflow-analysis join-sets 2drop assoc-refine ; FUNCTOR: define-analysis ( name -- ) diff --git a/basis/compiler/cfg/def-use/def-use-tests.factor b/basis/compiler/cfg/def-use/def-use-tests.factor index 21978d0f9b..a4f0819397 100644 --- a/basis/compiler/cfg/def-use/def-use-tests.factor +++ b/basis/compiler/cfg/def-use/def-use-tests.factor @@ -8,6 +8,7 @@ compiler.cfg compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.registers ; +IN: compiler.cfg.def-use.tests V{ T{ ##peek f 0 D 0 } diff --git a/basis/compiler/cfg/dominance/dominance-tests.factor b/basis/compiler/cfg/dominance/dominance-tests.factor index 81d573a4e2..b24e51abfb 100644 --- a/basis/compiler/cfg/dominance/dominance-tests.factor +++ b/basis/compiler/cfg/dominance/dominance-tests.factor @@ -1,7 +1,7 @@ -IN: compiler.cfg.dominance.tests USING: tools.test sequences vectors namespaces kernel accessors assocs sets math.ranges arrays compiler.cfg compiler.cfg.dominance compiler.cfg.debugger compiler.cfg.predecessors ; +IN: compiler.cfg.dominance.tests : test-dominance ( -- ) cfg new 0 get >>entry diff --git a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor index 9059713e21..5580de9a47 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor @@ -1,8 +1,8 @@ -IN: compiler.cfg.gc-checks.tests USING: compiler.cfg.gc-checks compiler.cfg.debugger compiler.cfg.registers compiler.cfg.instructions compiler.cfg compiler.cfg.predecessors cpu.architecture tools.test kernel vectors namespaces accessors sequences ; +IN: compiler.cfg.gc-checks.tests : test-gc-checks ( -- ) H{ } clone representations set @@ -23,4 +23,4 @@ V{ [ ] [ test-gc-checks ] unit-test -[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test \ No newline at end of file +[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 8afd9f80ca..d4aa2750c0 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -8,11 +8,11 @@ compiler.cfg.utilities compiler.cfg.builder.blocks ; IN: compiler.cfg.intrinsics.allot : ##set-slots ( regs obj class -- ) - '[ _ swap 1+ _ tag-number ##set-slot-imm ] each-index ; + '[ _ swap 1 + _ tag-number ##set-slot-imm ] each-index ; : emit-simple-allot ( node -- ) [ in-d>> length ] [ node-output-infos first class>> ] bi - [ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri + [ drop ds-load ] [ [ 1 + cells ] dip ^^allot ] [ nip ] 2tri [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ; : tuple-slot-regs ( layout -- vregs ) diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor index b1a8223026..47c1f0ae76 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -1,9 +1,9 @@ -IN: compiler.cfg.linear-scan.resolve.tests USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces accessors compiler.cfg compiler.cfg.instructions cpu.architecture make sequences compiler.cfg.linear-scan.allocation.state ; +IN: compiler.cfg.linear-scan.resolve.tests [ { @@ -64,4 +64,4 @@ H{ } clone spill-temps set T{ _reload { dst 0 } { rep int-rep } { n 8 } } } } member? -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index b45e2c9597..15dff23448 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -65,7 +65,7 @@ SYMBOL: temp : perform-mappings ( bb to mappings -- ) dup empty? [ 3drop ] [ - mapping-instructions insert-basic-block + mapping-instructions insert-simple-basic-block cfg get cfg-changed drop ] if ; diff --git a/basis/compiler/cfg/linearization/linearization-tests.factor b/basis/compiler/cfg/linearization/linearization-tests.factor deleted file mode 100644 index fe8b4fd0c0..0000000000 --- a/basis/compiler/cfg/linearization/linearization-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: compiler.cfg.linearization.tests -USING: compiler.cfg.linearization tools.test ; - - diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index 6c67769a45..a10b48cc0c 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -28,4 +28,4 @@ M: live-analysis transfer-set drop instructions>> transfer-liveness ; M: live-analysis join-sets - drop assoc-combine ; \ No newline at end of file + 2drop assoc-combine ; diff --git a/basis/compiler/cfg/loop-detection/loop-detection-tests.factor b/basis/compiler/cfg/loop-detection/loop-detection-tests.factor index d525f91ed3..80203c65e4 100644 --- a/basis/compiler/cfg/loop-detection/loop-detection-tests.factor +++ b/basis/compiler/cfg/loop-detection/loop-detection-tests.factor @@ -1,8 +1,8 @@ -IN: compiler.cfg.loop-detection.tests USING: compiler.cfg compiler.cfg.loop-detection compiler.cfg.predecessors compiler.cfg.debugger tools.test kernel namespaces accessors ; +IN: compiler.cfg.loop-detection.tests V{ } 0 test-bb V{ } 1 test-bb diff --git a/basis/compiler/cfg/loop-detection/loop-detection.factor b/basis/compiler/cfg/loop-detection/loop-detection.factor index dc70656c08..73b99ee132 100644 --- a/basis/compiler/cfg/loop-detection/loop-detection.factor +++ b/basis/compiler/cfg/loop-detection/loop-detection.factor @@ -6,10 +6,10 @@ IN: compiler.cfg.loop-detection TUPLE: natural-loop header index ends blocks ; - ( header index -- loop ) H{ } clone H{ } clone natural-loop boa ; @@ -80,4 +80,4 @@ PRIVATE> : needs-loops ( cfg -- cfg' ) needs-predecessors - dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ; \ No newline at end of file + dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ; diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor deleted file mode 100755 index e69de29bb2..0000000000 diff --git a/basis/compiler/cfg/representations/preferred/preferred-tests.factor b/basis/compiler/cfg/representations/preferred/preferred-tests.factor deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/basis/compiler/cfg/stacks/finalize/finalize.factor b/basis/compiler/cfg/stacks/finalize/finalize.factor index ca81c69bc0..f1f7880c90 100644 --- a/basis/compiler/cfg/stacks/finalize/finalize.factor +++ b/basis/compiler/cfg/stacks/finalize/finalize.factor @@ -45,7 +45,7 @@ ERROR: bad-peek dst loc ; ! computing anything. 2dup [ kill-block? ] both? [ 2drop ] [ 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make - [ 2drop ] [ insert-basic-block ] if-empty + [ 2drop ] [ insert-simple-basic-block ] if-empty ] if ; : visit-block ( bb -- ) @@ -56,4 +56,4 @@ ERROR: bad-peek dst loc ; dup [ visit-block ] each-basic-block - cfg-changed ; \ No newline at end of file + cfg-changed ; diff --git a/basis/compiler/cfg/stacks/global/global.factor b/basis/compiler/cfg/stacks/global/global.factor index c0ca385d90..30a999064a 100644 --- a/basis/compiler/cfg/stacks/global/global.factor +++ b/basis/compiler/cfg/stacks/global/global.factor @@ -21,7 +21,7 @@ BACKWARD-ANALYSIS: live M: live-analysis transfer-set drop transfer-peeked-locs ; -M: live-analysis join-sets drop assoc-combine ; +M: live-analysis join-sets 2drop assoc-combine ; ! A stack location is available at a location if all paths from ! the entry block to the location load the location into a @@ -56,4 +56,4 @@ M: dead-analysis transfer-set [ compute-dead-sets ] [ compute-avail-sets ] [ ] - } cleave ; \ No newline at end of file + } cleave ; diff --git a/basis/compiler/cfg/stacks/local/local.factor b/basis/compiler/cfg/stacks/local/local.factor index 4878dbe3ab..30a2c4c13f 100644 --- a/basis/compiler/cfg/stacks/local/local.factor +++ b/basis/compiler/cfg/stacks/local/local.factor @@ -69,18 +69,11 @@ M: rs-loc translate-local-loc n>> current-height get r>> - ; : peek-loc ( loc -- vreg ) translate-local-loc - dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless - dup replace-mapping get at [ ] [ loc>vreg ] ?if ; + dup replace-mapping get at + [ ] [ dup local-peek-set get conjoin loc>vreg ] ?if ; : replace-loc ( vreg loc -- ) - translate-local-loc - 2dup loc>vreg = - [ nip replace-mapping get delete-at ] - [ - [ local-replace-set get conjoin ] - [ replace-mapping get set-at ] - bi - ] if ; + translate-local-loc replace-mapping get set-at ; : compute-local-kill-set ( -- assoc ) basic-block get current-height get @@ -90,13 +83,17 @@ M: rs-loc translate-local-loc n>> current-height get r>> - ; : begin-local-analysis ( -- ) H{ } clone local-peek-set set - H{ } clone local-replace-set set H{ } clone replace-mapping set current-height get [ 0 >>emit-d 0 >>emit-r drop ] [ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ; +: remove-redundant-replaces ( -- ) + replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter + [ replace-mapping set ] [ keys unique local-replace-set set ] bi ; + : end-local-analysis ( -- ) + remove-redundant-replaces emit-changes basic-block get { [ [ local-peek-set get ] dip peek-sets get set-at ] diff --git a/basis/compiler/cfg/stacks/stacks-tests.factor b/basis/compiler/cfg/stacks/stacks-tests.factor deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor index 9c8a41f2c4..61c3cd67d1 100644 --- a/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor @@ -1,8 +1,8 @@ -IN: compiler.cfg.stacks.uninitialized.tests USING: compiler.cfg.stacks.uninitialized compiler.cfg.debugger compiler.cfg.registers compiler.cfg.instructions compiler.cfg compiler.cfg.predecessors cpu.architecture tools.test kernel vectors namespaces accessors sequences ; +IN: compiler.cfg.stacks.uninitialized.tests : test-uninitialized ( -- ) cfg new 0 get >>entry diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor index 97211eb8e8..ce0e98de5f 100644 --- a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor @@ -65,7 +65,7 @@ M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' ) drop [ prepare ] dip visit-block finish ; M: uninitialized-analysis join-sets ( sets analysis -- pair ) - drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ; + 2drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ; : uninitialized-locs ( bb -- locs ) uninitialized-in dup [ @@ -73,4 +73,4 @@ M: uninitialized-analysis join-sets ( sets analysis -- pair ) [ [ ] (uninitialized-locs) ] [ [ ] (uninitialized-locs) ] bi* append - ] when ; \ No newline at end of file + ] when ; diff --git a/basis/compiler/cfg/two-operand/two-operand-tests.factor b/basis/compiler/cfg/two-operand/two-operand-tests.factor index 2e26151d04..09d88a2959 100644 --- a/basis/compiler/cfg/two-operand/two-operand-tests.factor +++ b/basis/compiler/cfg/two-operand/two-operand-tests.factor @@ -1,6 +1,6 @@ -IN: compiler.cfg.two-operand.tests USING: kernel compiler.cfg.two-operand compiler.cfg.instructions compiler.cfg.registers cpu.architecture namespaces tools.test ; +IN: compiler.cfg.two-operand.tests 3 vreg-counter set-global diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 6d68bca4b9..bb61a63939 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -3,7 +3,7 @@ USING: accessors assocs combinators combinators.short-circuit cpu.architecture kernel layouts locals make math namespaces sequences sets vectors fry compiler.cfg compiler.cfg.instructions -compiler.cfg.rpo ; +compiler.cfg.rpo arrays ; IN: compiler.cfg.utilities PREDICATE: kill-block < basic-block @@ -37,16 +37,16 @@ SYMBOL: visited : skip-empty-blocks ( bb -- bb' ) H{ } clone visited [ (skip-empty-blocks) ] with-variable ; -:: insert-basic-block ( from to bb -- ) - bb from 1vector >>predecessors drop +:: insert-basic-block ( froms to bb -- ) + bb froms V{ } like >>predecessors drop bb to 1vector >>successors drop - to predecessors>> [ dup from eq? [ drop bb ] when ] change-each - from successors>> [ dup to eq? [ drop bb ] when ] change-each ; + to predecessors>> [ dup froms memq? [ drop bb ] when ] change-each + froms [ successors>> [ dup to eq? [ drop bb ] when ] change-each ] each ; : add-instructions ( bb quot -- ) [ instructions>> building ] dip '[ building get pop - @ + [ @ ] dip , ] with-variable ; inline @@ -56,6 +56,9 @@ SYMBOL: visited \ ##branch new-insn over push >>instructions ; +: insert-simple-basic-block ( from to insns -- ) + [ 1vector ] 2dip insert-basic-block ; + : has-phis? ( bb -- ? ) instructions>> first ##phi? ; diff --git a/basis/compiler/cfg/write-barrier/authors.txt b/basis/compiler/cfg/write-barrier/authors.txt new file mode 100644 index 0000000000..a44f8d7f8d --- /dev/null +++ b/basis/compiler/cfg/write-barrier/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Daniel Ehrenberg diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor index c09f404d4c..a73451042d 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor @@ -1,7 +1,16 @@ -USING: compiler.cfg.write-barrier compiler.cfg.instructions -compiler.cfg.registers compiler.cfg.debugger cpu.architecture -arrays tools.test vectors compiler.cfg kernel accessors -compiler.cfg.utilities ; +! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs compiler.cfg +compiler.cfg.alias-analysis compiler.cfg.block-joining +compiler.cfg.branch-splitting compiler.cfg.copy-prop +compiler.cfg.dce compiler.cfg.debugger +compiler.cfg.instructions compiler.cfg.loop-detection +compiler.cfg.registers compiler.cfg.ssa.construction +compiler.cfg.tco compiler.cfg.useless-conditionals +compiler.cfg.utilities compiler.cfg.value-numbering +compiler.cfg.write-barrier cpu.architecture kernel +kernel.private math namespaces sequences sequences.private +tools.test vectors ; IN: compiler.cfg.write-barrier.tests : test-write-barrier ( insns -- insns ) @@ -70,3 +79,112 @@ IN: compiler.cfg.write-barrier.tests T{ ##write-barrier f 19 30 3 } } test-write-barrier ] unit-test + +V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 1 test-bb +V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 2 test-bb +1 get 2 get 1vector >>successors drop +cfg new 1 get >>entry 0 set + +[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test +[ V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} ] [ 1 get instructions>> ] unit-test +[ V{ + T{ ##set-slot-imm f 2 1 3 4 } +} ] [ 2 get instructions>> ] unit-test + +V{ + T{ ##allot f 1 } +} 1 test-bb +V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 2 test-bb +1 get 2 get 1vector >>successors drop +cfg new 1 get >>entry 0 set + +[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test +[ V{ + T{ ##allot f 1 } +} ] [ 1 get instructions>> ] unit-test +[ V{ + T{ ##set-slot-imm f 2 1 3 4 } +} ] [ 2 get instructions>> ] unit-test + +V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 1 test-bb +V{ + T{ ##allot } + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 2 test-bb +1 get 2 get 1vector >>successors drop +cfg new 1 get >>entry 0 set + +[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test +[ V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} ] [ 1 get instructions>> ] unit-test +[ V{ + T{ ##allot } + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} ] [ 2 get instructions>> ] unit-test + +V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 1 test-bb +V{ + T{ ##allot } +} 2 test-bb +1 get 2 get 1vector >>successors drop +V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} 3 test-bb +2 get 3 get 1vector >>successors drop +cfg new 1 get >>entry 0 set +[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test +[ V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} ] [ 1 get instructions>> ] unit-test +[ V{ T{ ##allot } } ] [ 2 get instructions>> ] unit-test +[ V{ + T{ ##set-slot-imm f 2 1 3 4 } + T{ ##write-barrier f 1 2 3 } +} ] [ 3 get instructions>> ] unit-test + +: reverse-here' ( seq -- ) + { array } declare + [ length 2/ iota ] [ length ] [ ] tri + [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ; + +: write-barrier-stats ( word -- cfg ) + test-cfg first [ + optimize-tail-calls + delete-useless-conditionals + split-branches + join-blocks + construct-ssa + alias-analysis + value-numbering + copy-propagation + eliminate-dead-code + eliminate-write-barriers + ] with-cfg + post-order>> write-barriers + [ [ loop-nesting-at ] [ length ] bi* ] assoc-map ; + +[ { { 0 1 } } ] [ \ reverse-here' write-barrier-stats ] unit-test diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index 2f32a4ca81..97b0c27af1 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -1,7 +1,16 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors namespaces assocs sets sequences -compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ; +fry combinators.short-circuit locals make arrays +compiler.cfg +compiler.cfg.dominance +compiler.cfg.predecessors +compiler.cfg.loop-detection +compiler.cfg.rpo +compiler.cfg.instructions +compiler.cfg.registers +compiler.cfg.dataflow-analysis +compiler.cfg.utilities ; IN: compiler.cfg.write-barrier ! Eliminate redundant write barrier hits. @@ -19,21 +28,112 @@ M: ##allot eliminate-write-barrier dst>> safe get conjoin t ; M: ##write-barrier eliminate-write-barrier - src>> dup [ safe get key? not ] [ mutated get key? ] bi and + src>> dup safe get key? not [ safe get conjoin t ] [ drop f ] if ; -M: ##set-slot eliminate-write-barrier - obj>> mutated get conjoin t ; - -M: ##set-slot-imm eliminate-write-barrier - obj>> mutated get conjoin t ; - M: insn eliminate-write-barrier drop t ; +! This doesn't actually benefit from being a dataflow analysis +! might as well be dominator-based +! Dealing with phi functions would help, though +FORWARD-ANALYSIS: safe + +: has-allocation? ( bb -- ? ) + instructions>> [ { [ ##allocation? ] [ ##call? ] } 1|| ] any? ; + +M: safe-analysis transfer-set + drop [ H{ } assoc-clone-like safe set ] dip + instructions>> [ + eliminate-write-barrier drop + ] each safe get ; + +M: safe-analysis join-sets + drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ; + : write-barriers-step ( bb -- ) - H{ } clone safe set - H{ } clone mutated set + dup safe-in H{ } assoc-clone-like safe set instructions>> [ eliminate-write-barrier ] filter-here ; +GENERIC: remove-dead-barrier ( insn -- ? ) + +M: ##write-barrier remove-dead-barrier + src>> mutated get key? ; + +M: ##set-slot remove-dead-barrier + obj>> mutated get conjoin t ; + +M: ##set-slot-imm remove-dead-barrier + obj>> mutated get conjoin t ; + +M: insn remove-dead-barrier drop t ; + +: remove-dead-barriers ( bb -- ) + H{ } clone mutated set + instructions>> [ remove-dead-barrier ] filter-here ; + +! Availability of slot +! Anticipation of this and set-slot would help too, maybe later +FORWARD-ANALYSIS: slot + +UNION: access ##read ##write ; + +M: slot-analysis transfer-set + drop [ H{ } assoc-clone-like ] dip + instructions>> over '[ + dup access? [ + obj>> _ conjoin + ] [ drop ] if + ] each ; + +: slot-available? ( vreg bb -- ? ) + slot-in key? ; + +: make-barriers ( vregs -- bb ) + [ [ next-vreg next-vreg ##write-barrier ] each ] V{ } make ; + +: emit-barriers ( vregs loop -- ) + swap [ + [ [ header>> predecessors>> ] [ ends>> keys ] bi diff ] + [ header>> ] bi + ] [ make-barriers ] bi* + insert-basic-block ; + +: write-barriers ( bbs -- bb=>barriers ) + [ + dup instructions>> + [ ##write-barrier? ] filter + [ src>> ] map + ] { } map>assoc + [ nip empty? not ] assoc-filter ; + +: filter-dominant ( bb=>barriers bbs -- barriers ) + '[ drop _ [ dominates? ] with all? ] assoc-filter + values concat prune ; + +: dominant-write-barriers ( loop -- vregs ) + [ blocks>> values write-barriers ] [ ends>> keys ] bi filter-dominant ; + +: safe-loops ( -- loops ) + loops get values + [ blocks>> keys [ has-allocation? not ] all? ] filter ; + +:: insert-extra-barriers ( cfg -- ) + safe-loops [| loop | + cfg needs-dominance needs-predecessors drop + loop dominant-write-barriers + loop header>> '[ _ slot-available? ] filter + [ loop emit-barriers cfg cfg-changed drop ] unless-empty + ] each ; + +: contains-write-barrier? ( cfg -- ? ) + post-order [ instructions>> [ ##write-barrier? ] any? ] any? ; + : eliminate-write-barriers ( cfg -- cfg' ) - dup [ write-barriers-step ] each-basic-block ; + dup contains-write-barrier? [ + needs-loops + dup [ remove-dead-barriers ] each-basic-block + dup compute-slot-sets + dup insert-extra-barriers + dup compute-safe-sets + dup [ write-barriers-step ] each-basic-block + ] when ; diff --git a/basis/compiler/codegen/codegen-tests.factor b/basis/compiler/codegen/codegen-tests.factor index 9c3817bad6..225577d0b9 100644 --- a/basis/compiler/codegen/codegen-tests.factor +++ b/basis/compiler/codegen/codegen-tests.factor @@ -1,6 +1,6 @@ -IN: compiler.codegen.tests USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make compiler.constants ; +IN: compiler.codegen.tests [ ] [ [ ] with-fixup drop ] unit-test [ ] [ [ \ + %call ] with-fixup drop ] unit-test diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor old mode 100644 new mode 100755 index 3b8d996f34..504acc74b0 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -120,7 +120,7 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ; } cond ; : optimize? ( word -- ? ) - { [ predicate-engine-word? ] [ single-generic? ] } 1|| not ; + single-generic? not ; : contains-breakpoints? ( -- ? ) dependencies get keys [ "break?" word-prop ] any? ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 91215baf19..e3c5dee917 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -395,7 +395,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; : callback-9 ( -- callback ) "int" { "int" "int" "int" } "cdecl" [ - + + 1+ + + + 1 + ] alien-callback ; FUNCTION: void ffi_test_36_point_5 ( ) ; @@ -599,4 +599,4 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ; [ 123 ] [ "bool-field-test" 123 over set-bool-field-test-parents ffi_test_48 -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/compiler/tests/call-effect.factor b/basis/compiler/tests/call-effect.factor index a9fd313d64..f90897bc9b 100644 --- a/basis/compiler/tests/call-effect.factor +++ b/basis/compiler/tests/call-effect.factor @@ -1,5 +1,5 @@ -IN: compiler.tests.call-effect USING: tools.test combinators generic.single sequences kernel ; +IN: compiler.tests.call-effect : execute-ic-test ( a b -- c ) execute( a -- c ) ; @@ -11,4 +11,4 @@ USING: tools.test combinators generic.single sequences kernel ; [ ] [ [ ] call-test ] unit-test [ ] [ f [ drop ] curry call-test ] unit-test [ ] [ [ ] [ ] compose call-test ] unit-test -[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with \ No newline at end of file +[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index 7074b73845..138437543e 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -1,6 +1,6 @@ -IN: compiler.tests.float USING: compiler.units compiler kernel kernel.private memory math math.private tools.test math.floats.private ; +IN: compiler.tests.float [ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test [ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test diff --git a/basis/compiler/tests/generic.factor b/basis/compiler/tests/generic.factor index 6b0ef2d439..30392f1598 100644 --- a/basis/compiler/tests/generic.factor +++ b/basis/compiler/tests/generic.factor @@ -1,5 +1,5 @@ -IN: compiler.tests.generic USING: tools.test math kernel compiler.units definitions ; +IN: compiler.tests.generic GENERIC: bad ( -- ) M: integer bad ; @@ -8,4 +8,4 @@ M: object bad ; [ 0 bad ] must-fail [ "" bad ] must-fail -[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test \ No newline at end of file +[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 20fcff8440..45ea841a73 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -4,7 +4,7 @@ sbufs strings tools.test vectors words sequences.private quotations classes classes.algebra classes.tuple.private continuations growable namespaces hints alien.accessors compiler.tree.builder compiler.tree.optimizer sequences.deep -compiler definitions ; +compiler definitions generic.single ; IN: compiler.tests.optimizer GENERIC: xyz ( obj -- obj ) @@ -67,7 +67,7 @@ TUPLE: pred-test ; [ 3 ] [ t bad-kill-2 ] unit-test ! regression -: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline recursive +: (the-test) ( x -- y ) dup 0 > [ 1 - (the-test) ] when ; inline recursive : the-test ( -- x y ) 2 dup (the-test) ; [ 2 0 ] [ the-test ] unit-test @@ -100,7 +100,7 @@ GENERIC: void-generic ( obj -- * ) ! regression : branch-fold-regression-0 ( m -- n ) - t [ ] [ 1+ branch-fold-regression-0 ] if ; inline recursive + t [ ] [ 1 + branch-fold-regression-0 ] if ; inline recursive : branch-fold-regression-1 ( -- m ) 10 branch-fold-regression-0 ; @@ -348,12 +348,12 @@ TUPLE: some-tuple x ; [ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test -[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-signed-4 1+ ] compile-call ] unit-test -[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-unsigned-4 1+ ] compile-call ] unit-test -[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-8 1+ ] compile-call ] unit-test -[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test -[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test -[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test +[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-signed-4 1 + ] compile-call ] unit-test +[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-unsigned-4 1 + ] compile-call ] unit-test +[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-8 1 + ] compile-call ] unit-test +[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1 + ] compile-call ] unit-test +[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1 + ] compile-call ] unit-test +[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1 + ] compile-call ] unit-test : deep-find-test ( seq -- ? ) [ 5 = ] deep-find ; @@ -382,7 +382,7 @@ DEFER: loop-bbb ! Type inference issue [ 4 3 ] [ 1 >bignum 2 >bignum - [ { bignum integer } declare [ shift ] keep 1+ ] compile-call + [ { bignum integer } declare [ shift ] keep 1 + ] compile-call ] unit-test : broken-declaration ( -- ) \ + declare ; @@ -422,4 +422,7 @@ M: object bad-dispatch-position-test* ; \ bad-dispatch-position-test forget \ bad-dispatch-position-test* forget ] with-compilation-unit -] unit-test \ No newline at end of file +] unit-test + +! Not sure if I want to fix this... +! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with \ No newline at end of file diff --git a/basis/compiler/tests/peg-regression-2.factor b/basis/compiler/tests/peg-regression-2.factor index 7929d9e6f6..cae57e5bd9 100644 --- a/basis/compiler/tests/peg-regression-2.factor +++ b/basis/compiler/tests/peg-regression-2.factor @@ -1,5 +1,5 @@ -IN: compiler.tests.peg-regression-2 USING: peg.ebnf strings tools.test ; +IN: compiler.tests.peg-regression-2 GENERIC: ( times -- term' ) M: string ; diff --git a/basis/compiler/tests/pic-problem-1.factor b/basis/compiler/tests/pic-problem-1.factor index 4adf0b36b9..4da83f53e4 100644 --- a/basis/compiler/tests/pic-problem-1.factor +++ b/basis/compiler/tests/pic-problem-1.factor @@ -1,5 +1,5 @@ -IN: compiler.tests.pic-problem-1 USING: kernel sequences prettyprint memory tools.test ; +IN: compiler.tests.pic-problem-1 TUPLE: x ; @@ -11,4 +11,4 @@ INSTANCE: x sequence CONSTANT: blah T{ x } -[ T{ x } ] [ blah ] unit-test \ No newline at end of file +[ T{ x } ] [ blah ] unit-test diff --git a/basis/compiler/tests/redefine0.factor b/basis/compiler/tests/redefine0.factor index 3d7a05a74b..4de6d952c8 100644 --- a/basis/compiler/tests/redefine0.factor +++ b/basis/compiler/tests/redefine0.factor @@ -1,6 +1,6 @@ -IN: compiler.tests.redefine0 USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math namespaces macros assocs ; +IN: compiler.tests.redefine0 ! Test ripple-up behavior : test-1 ( -- a ) 3 ; diff --git a/basis/compiler/tests/redefine15.factor b/basis/compiler/tests/redefine15.factor index 33aa080bac..54066c690d 100644 --- a/basis/compiler/tests/redefine15.factor +++ b/basis/compiler/tests/redefine15.factor @@ -11,7 +11,7 @@ DEFER: word-1 : word-3 ( a -- b ) 1 + ; -: word-4 ( a -- b c ) 0 swap word-3 swap 1+ ; +: word-4 ( a -- b c ) 0 swap word-3 swap 1 + ; [ 1 1 ] [ 0 word-4 ] unit-test diff --git a/basis/compiler/tests/redefine16.factor b/basis/compiler/tests/redefine16.factor index 3bef30f9f1..ac879a7c75 100644 --- a/basis/compiler/tests/redefine16.factor +++ b/basis/compiler/tests/redefine16.factor @@ -1,6 +1,6 @@ -IN: compiler.tests.redefine16 USING: eval tools.test definitions words compiler.units quotations stack-checker ; +IN: compiler.tests.redefine16 [ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test diff --git a/basis/compiler/tests/redefine17.factor b/basis/compiler/tests/redefine17.factor index 4ed3e36f4d..5a1c33ad27 100644 --- a/basis/compiler/tests/redefine17.factor +++ b/basis/compiler/tests/redefine17.factor @@ -1,6 +1,6 @@ -IN: compiler.tests.redefine17 USING: tools.test classes.mixin compiler.units arrays kernel.private strings sequences vocabs definitions kernel ; +IN: compiler.tests.redefine17 << "compiler.tests.redefine17" words forget-all >> diff --git a/basis/compiler/tests/redefine2.factor b/basis/compiler/tests/redefine2.factor index 9112a1e1af..b6a46fc0df 100644 --- a/basis/compiler/tests/redefine2.factor +++ b/basis/compiler/tests/redefine2.factor @@ -1,7 +1,7 @@ -IN: compiler.tests.redefine2 USING: compiler compiler.units tools.test math parser kernel sequences sequences.private classes.mixin generic definitions arrays words assocs eval words.symbol ; +IN: compiler.tests.redefine2 DEFER: redefine2-test diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index 0a5eb84579..67added49d 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -1,15 +1,15 @@ -IN: compiler.tests.redefine3 USING: accessors compiler compiler.units tools.test math parser kernel sequences sequences.private classes.mixin generic definitions arrays words assocs eval ; +IN: compiler.tests.redefine3 GENERIC: sheeple ( obj -- x ) -M: object sheeple drop "sheeple" ; +M: object sheeple drop "sheeple" ; inline MIXIN: empty-mixin -M: empty-mixin sheeple drop "wake up" ; +M: empty-mixin sheeple drop "wake up" ; inline : sheeple-test ( -- string ) { } sheeple ; diff --git a/basis/compiler/tests/redefine4.factor b/basis/compiler/tests/redefine4.factor index 2320f64af6..cc74e5a783 100644 --- a/basis/compiler/tests/redefine4.factor +++ b/basis/compiler/tests/redefine4.factor @@ -1,5 +1,5 @@ -IN: compiler.tests.redefine4 USING: io.streams.string kernel tools.test eval ; +IN: compiler.tests.redefine4 : declaration-test-1 ( -- a ) 3 ; flushable diff --git a/basis/compiler/tests/reload.factor b/basis/compiler/tests/reload.factor index 62c7c31bc2..3bbfca876b 100644 --- a/basis/compiler/tests/reload.factor +++ b/basis/compiler/tests/reload.factor @@ -1,5 +1,5 @@ -IN: compiler.tests.reload USE: vocabs.loader +IN: compiler.tests.reload ! "parser" reload ! "sequences" reload diff --git a/basis/compiler/tests/stack-trace.factor b/basis/compiler/tests/stack-trace.factor index 1cb11571ef..20a5cc867c 100755 --- a/basis/compiler/tests/stack-trace.factor +++ b/basis/compiler/tests/stack-trace.factor @@ -1,7 +1,7 @@ -IN: compiler.tests.stack-trace USING: compiler tools.test namespaces sequences kernel.private kernel math continuations continuations.private words splitting grouping sorting accessors ; +IN: compiler.tests.stack-trace : symbolic-stack-trace ( -- newseq ) error-continuation get call>> callstack>array @@ -13,7 +13,7 @@ words splitting grouping sorting accessors ; [ baz ] [ 3 = ] must-fail-with [ t ] [ symbolic-stack-trace - [ word? ] filter + 2 head* { baz bar foo } tail? ] unit-test @@ -24,7 +24,7 @@ words splitting grouping sorting accessors ; [ t ] [ [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any? ] unit-test - + [ t f ] [ [ { "hi" } bleh ] ignore-errors \ + stack-trace-any? diff --git a/basis/compiler/tests/tuples.factor b/basis/compiler/tests/tuples.factor index fc249d99db..3d6301249f 100644 --- a/basis/compiler/tests/tuples.factor +++ b/basis/compiler/tests/tuples.factor @@ -1,5 +1,5 @@ -IN: compiler.tests.tuples USING: kernel tools.test compiler.units compiler ; +IN: compiler.tests.tuples TUPLE: color red green blue ; diff --git a/basis/compiler/tree/builder/builder-tests.factor b/basis/compiler/tree/builder/builder-tests.factor index f3a2b99db6..8359334550 100755 --- a/basis/compiler/tree/builder/builder-tests.factor +++ b/basis/compiler/tree/builder/builder-tests.factor @@ -1,6 +1,6 @@ -IN: compiler.tree.builder.tests USING: compiler.tree.builder tools.test sequences kernel compiler.tree stack-checker stack-checker.errors ; +IN: compiler.tree.builder.tests : inline-recursive ( -- ) inline-recursive ; inline recursive diff --git a/basis/compiler/tree/checker/checker-tests.factor b/basis/compiler/tree/checker/checker-tests.factor deleted file mode 100644 index d9591e7be2..0000000000 --- a/basis/compiler/tree/checker/checker-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: compiler.tree.checker.tests -USING: compiler.tree.checker tools.test ; - - diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 228a4e3efb..faf6968670 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -1,4 +1,3 @@ -IN: compiler.tree.cleanup.tests USING: tools.test kernel.private kernel arrays sequences math.private math generic words quotations alien alien.c-types strings sbufs sequences.private slots.private combinators @@ -17,6 +16,7 @@ compiler.tree.propagation compiler.tree.propagation.info compiler.tree.checker compiler.tree.debugger ; +IN: compiler.tree.cleanup.tests [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test @@ -41,13 +41,13 @@ compiler.tree.debugger ; GENERIC: mynot ( x -- y ) -M: f mynot drop t ; +M: f mynot drop t ; inline -M: object mynot drop f ; +M: object mynot drop f ; inline GENERIC: detect-f ( x -- y ) -M: f detect-f ; +M: f detect-f ; inline [ t ] [ [ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined? @@ -55,9 +55,9 @@ M: f detect-f ; GENERIC: xyz ( n -- n ) -M: integer xyz ; +M: integer xyz ; inline -M: object xyz ; +M: object xyz ; inline [ t ] [ [ { integer } declare xyz ] \ xyz inlined? @@ -88,7 +88,7 @@ M: object xyz ; 2over dup xyz drop >= [ 3drop ] [ - [ swap [ call 1+ ] dip ] keep (i-repeat) + [ swap [ call 1 + ] dip ] keep (i-repeat) ] if ; inline recursive : i-repeat ( n quot -- ) [ { integer } declare ] dip 0 -rot (i-repeat) ; inline @@ -115,10 +115,6 @@ M: object xyz ; [ { fixnum } declare [ ] times ] \ >= inlined? ] unit-test -[ t ] [ - [ { fixnum } declare [ ] times ] \ 1+ inlined? -] unit-test - [ t ] [ [ { fixnum } declare [ ] times ] \ + inlined? ] unit-test @@ -172,19 +168,6 @@ M: object xyz ; [ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined? ] unit-test -[ t ] [ - [ 5000 [ 5000 [ ] times ] times ] \ 1+ inlined? -] unit-test - -[ t ] [ - [ 5000 [ [ ] times ] each ] \ 1+ inlined? -] unit-test - -[ t ] [ - [ 5000 0 [ dup 2 - swap [ 2drop ] curry each ] reduce ] - \ 1+ inlined? -] unit-test - GENERIC: annotate-entry-test-1 ( x -- ) M: fixnum annotate-entry-test-1 drop ; @@ -193,7 +176,7 @@ M: fixnum annotate-entry-test-1 drop ; 2dup >= [ 2drop ] [ - [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2) + [ dup annotate-entry-test-1 1 + ] dip (annotate-entry-test-2) ] if ; inline recursive : annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline @@ -305,10 +288,6 @@ cell-bits 32 = [ ] \ + inlined? ] unit-test -[ t ] [ - [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined? -] unit-test - : rec ( a -- b ) dup 0 > [ 1 - rec ] when ; inline recursive @@ -467,7 +446,7 @@ cell-bits 32 = [ : buffalo-wings ( i seq -- ) 2dup < [ 2dup chicken-fingers - [ 1+ ] dip buffalo-wings + [ 1 + ] dip buffalo-wings ] [ 2drop ] if ; inline recursive @@ -486,7 +465,7 @@ cell-bits 32 = [ : ribs ( i seq -- ) 2dup < [ steak - [ 1+ ] dip ribs + [ 1 + ] dip ribs ] [ 2drop ] if ; inline recursive @@ -543,4 +522,4 @@ cell-bits 32 = [ [ 12 swap nth ] keep 14 ndrop ] cleaned-up-tree nodes>quot -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/compiler/tree/combinators/combinators-tests.factor b/basis/compiler/tree/combinators/combinators-tests.factor index d012b5f658..305ba5b2b5 100644 --- a/basis/compiler/tree/combinators/combinators-tests.factor +++ b/basis/compiler/tree/combinators/combinators-tests.factor @@ -1,5 +1,5 @@ -IN: compiler.tree.combinators.tests USING: compiler.tree.combinators tools.test kernel ; +IN: compiler.tree.combinators.tests { 1 0 } [ [ drop ] each-node ] must-infer-as { 1 1 } [ [ ] map-nodes ] must-infer-as diff --git a/basis/compiler/tree/dead-code/branches/branches.factor b/basis/compiler/tree/dead-code/branches/branches.factor index fd1b2d5adb..f09593824e 100644 --- a/basis/compiler/tree/dead-code/branches/branches.factor +++ b/basis/compiler/tree/dead-code/branches/branches.factor @@ -3,8 +3,7 @@ USING: sequences namespaces kernel accessors assocs sets fry arrays combinators columns stack-checker.backend stack-checker.branches compiler.tree compiler.tree.combinators -compiler.tree.dead-code.liveness compiler.tree.dead-code.simple -; +compiler.tree.dead-code.liveness compiler.tree.dead-code.simple ; IN: compiler.tree.dead-code.branches M: #if mark-live-values* look-at-inputs ; diff --git a/basis/compiler/tree/debugger/debugger-tests.factor b/basis/compiler/tree/debugger/debugger-tests.factor index 9bacd51be1..3cdbbf5944 100644 --- a/basis/compiler/tree/debugger/debugger-tests.factor +++ b/basis/compiler/tree/debugger/debugger-tests.factor @@ -1,5 +1,5 @@ -IN: compiler.tree.debugger.tests USING: compiler.tree.debugger tools.test sorting sequences io math.order ; +IN: compiler.tree.debugger.tests [ [ <=> ] sort ] optimized. -[ [ print ] each ] optimizer-report. \ No newline at end of file +[ [ print ] each ] optimizer-report. diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 6f313320d0..4bf4cf88f0 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -11,6 +11,8 @@ compiler.tree.normalization compiler.tree.cleanup compiler.tree.propagation compiler.tree.propagation.info +compiler.tree.escape-analysis +compiler.tree.tuple-unboxing compiler.tree.def-use compiler.tree.builder compiler.tree.optimizer @@ -154,7 +156,7 @@ SYMBOL: node-count H{ } clone intrinsics-called set 0 swap [ - [ 1+ ] dip + [ 1 + ] dip dup #call? [ word>> { { [ dup "intrinsic" word-prop ] [ intrinsics-called ] } @@ -209,6 +211,8 @@ SYMBOL: node-count normalize propagate cleanup + escape-analysis + unbox-tuples apply-identities compute-def-use remove-dead-code diff --git a/basis/compiler/tree/def-use/def-use.factor b/basis/compiler/tree/def-use/def-use.factor index 21e79eb6c4..872b6131c9 100644 --- a/basis/compiler/tree/def-use/def-use.factor +++ b/basis/compiler/tree/def-use/def-use.factor @@ -21,7 +21,7 @@ TUPLE: definition value node uses ; ERROR: no-def-error value ; : def-of ( value -- definition ) - dup def-use get at* [ nip ] [ no-def-error ] if ; + def-use get ?at [ no-def-error ] unless ; ERROR: multiple-defs-error ; diff --git a/basis/compiler/tree/def-use/simplified/simplified-tests.factor b/basis/compiler/tree/def-use/simplified/simplified-tests.factor index a1a768d429..72c7e4c60c 100644 --- a/basis/compiler/tree/def-use/simplified/simplified-tests.factor +++ b/basis/compiler/tree/def-use/simplified/simplified-tests.factor @@ -1,6 +1,6 @@ USING: kernel tools.test compiler.tree compiler.tree.builder -compiler.tree.def-use compiler.tree.def-use.simplified accessors -sequences sorting classes ; +compiler.tree.recursive compiler.tree.def-use +compiler.tree.def-use.simplified accessors sequences sorting classes ; IN: compiler.tree.def-use.simplified [ { #call #return } ] [ @@ -8,3 +8,17 @@ IN: compiler.tree.def-use.simplified first out-d>> first actually-used-by [ node>> class ] map natural-sort ] unit-test + +: word-1 ( a -- b ) dup [ word-1 ] when ; inline recursive + +[ { #introduce } ] [ + [ word-1 ] build-tree analyze-recursive compute-def-use + last in-d>> first actually-defined-by + [ node>> class ] map natural-sort +] unit-test + +[ { #if #return } ] [ + [ word-1 ] build-tree analyze-recursive compute-def-use + first out-d>> first actually-used-by + [ node>> class ] map natural-sort +] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/def-use/simplified/simplified.factor b/basis/compiler/tree/def-use/simplified/simplified.factor index 9b2a2038da..c2fb74c97e 100644 --- a/basis/compiler/tree/def-use/simplified/simplified.factor +++ b/basis/compiler/tree/def-use/simplified/simplified.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences kernel fry vectors -compiler.tree compiler.tree.def-use ; +USING: sequences kernel fry vectors accessors namespaces assocs sets +stack-checker.branches compiler.tree compiler.tree.def-use ; IN: compiler.tree.def-use.simplified ! Simplified def-use follows chains of copies. @@ -9,32 +9,85 @@ IN: compiler.tree.def-use.simplified ! A 'real' usage is a usage of a value that is not a #renaming. TUPLE: real-usage value node ; -! Def -GENERIC: actually-defined-by* ( value node -- real-usage ) + + +! Def +GENERIC: actually-defined-by* ( value node -- ) + +: (actually-defined-by) ( value -- ) + [ dup defined-by actually-defined-by* ] if-not-visited ; M: #renaming actually-defined-by* - inputs/outputs swap [ index ] dip nth actually-defined-by ; + inputs/outputs swap [ index ] dip nth (actually-defined-by) ; -M: #return-recursive actually-defined-by* real-usage boa ; +M: #call-recursive actually-defined-by* + [ out-d>> index ] [ label>> return>> in-d>> nth ] bi + (actually-defined-by) ; -M: node actually-defined-by* real-usage boa ; +M: #enter-recursive actually-defined-by* + [ out-d>> index ] keep + [ in-d>> nth (actually-defined-by) ] + [ label>> calls>> [ node>> in-d>> nth (actually-defined-by) ] with each ] 2bi ; + +M: #phi actually-defined-by* + [ out-d>> index ] [ phi-in-d>> ] bi + [ + nth dup +bottom+ eq? + [ drop ] [ (actually-defined-by) ] if + ] with each ; + +M: node actually-defined-by* + real-usage boa accum get conjoin ; + +: actually-defined-by ( value -- real-usages ) + [ (actually-defined-by) ] with-simplified-def-use ; ! Use -GENERIC# actually-used-by* 1 ( value node accum -- ) +GENERIC: actually-used-by* ( value node -- ) -: (actually-used-by) ( value accum -- ) - [ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ; +: (actually-used-by) ( value -- ) + [ dup used-by [ actually-used-by* ] with each ] if-not-visited ; M: #renaming actually-used-by* - [ inputs/outputs [ indices ] dip nths ] dip - '[ _ (actually-used-by) ] each ; + inputs/outputs [ indices ] dip nths + [ (actually-used-by) ] each ; -M: #return-recursive actually-used-by* [ real-usage boa ] dip push ; +M: #return-recursive actually-used-by* + [ in-d>> index ] keep + [ out-d>> nth (actually-used-by) ] + [ label>> calls>> [ node>> out-d>> nth (actually-used-by) ] with each ] 2bi ; -M: node actually-used-by* [ real-usage boa ] dip push ; +M: #call-recursive actually-used-by* + [ in-d>> index ] [ label>> enter-out>> nth ] bi + (actually-used-by) ; + +M: #enter-recursive actually-used-by* + [ in-d>> index ] [ out-d>> nth ] bi (actually-used-by) ; + +M: #phi actually-used-by* + [ phi-in-d>> [ index ] with map-find drop ] [ out-d>> nth ] bi + (actually-used-by) ; + +M: #recursive actually-used-by* 2drop ; + +M: node actually-used-by* + real-usage boa accum get conjoin ; : actually-used-by ( value -- real-usages ) - 10 [ (actually-used-by) ] keep ; + [ (actually-used-by) ] with-simplified-def-use ; diff --git a/basis/compiler/tree/escape-analysis/check/check-tests.factor b/basis/compiler/tree/escape-analysis/check/check-tests.factor index 075e20eb23..bd91dd53e8 100644 --- a/basis/compiler/tree/escape-analysis/check/check-tests.factor +++ b/basis/compiler/tree/escape-analysis/check/check-tests.factor @@ -1,7 +1,7 @@ -IN: compiler.tree.escape-analysis.check.tests USING: compiler.tree.escape-analysis.check tools.test accessors kernel kernel.private math compiler.tree.builder compiler.tree.normalization compiler.tree.propagation compiler.tree.cleanup ; +IN: compiler.tree.escape-analysis.check.tests : test-checker ( quot -- ? ) build-tree normalize propagate cleanup run-escape-analysis? ; @@ -24,4 +24,4 @@ compiler.tree.propagation compiler.tree.cleanup ; [ f ] [ [ swap 1 2 ? ] test-checker -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index be6b2863f0..debb66b8d4 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -1,4 +1,3 @@ -IN: compiler.tree.escape-analysis.tests USING: compiler.tree.escape-analysis compiler.tree.escape-analysis.allocations compiler.tree.builder compiler.tree.recursive compiler.tree.normalization @@ -10,11 +9,12 @@ classes.tuple namespaces compiler.tree.propagation.info stack-checker.errors compiler.tree.checker kernel.private vectors ; +IN: compiler.tree.escape-analysis.tests GENERIC: count-unboxed-allocations* ( m node -- n ) : (count-unboxed-allocations) ( m node -- n ) - out-d>> first escaping-allocation? [ 1+ ] unless ; + out-d>> first escaping-allocation? [ 1 + ] unless ; M: #call count-unboxed-allocations* dup immutable-tuple-boa? @@ -25,7 +25,7 @@ M: #push count-unboxed-allocations* [ (count-unboxed-allocations) ] [ drop ] if ; M: #introduce count-unboxed-allocations* - out-d>> [ escaping-allocation? [ 1+ ] unless ] each ; + out-d>> [ escaping-allocation? [ 1 + ] unless ] each ; M: node count-unboxed-allocations* drop ; @@ -212,10 +212,10 @@ C: ro-box dup i>> 1 <= [ drop 1 ] [ - i>> 1- + i>> 1 - dup tuple-fib swap - i>> 1- + i>> 1 - tuple-fib swap i>> swap i>> + ] if ; inline recursive @@ -225,7 +225,7 @@ C: ro-box [ 3 ] [ [ tuple-fib ] count-unboxed-allocations ] unit-test : tuple-fib' ( m -- n ) - dup 1 <= [ 1- tuple-fib' i>> ] when ; inline recursive + dup 1 <= [ 1 - tuple-fib' i>> ] when ; inline recursive [ 0 ] [ [ tuple-fib' ] count-unboxed-allocations ] unit-test @@ -233,10 +233,10 @@ C: ro-box dup i>> 1 <= [ drop 1 ] [ - i>> 1- + i>> 1 - dup bad-tuple-fib-1 swap - i>> 1- + i>> 1 - bad-tuple-fib-1 dup . swap i>> swap i>> + ] if ; inline recursive @@ -248,10 +248,10 @@ C: ro-box dup i>> 1 <= [ drop 1 ] [ - i>> 1- + i>> 1 - dup bad-tuple-fib-2 swap - i>> 1- + i>> 1 - bad-tuple-fib-2 swap i>> swap i>> + ] if ; inline recursive @@ -262,9 +262,9 @@ C: ro-box dup 1 <= [ drop 1 ] [ - 1- dup tuple-fib-2 + 1 - dup tuple-fib-2 swap - 1- tuple-fib-2 + 1 - tuple-fib-2 swap i>> swap i>> + ] if ; inline recursive @@ -274,9 +274,9 @@ C: ro-box dup 1 <= [ drop 1 ] [ - 1- dup tuple-fib-3 + 1 - dup tuple-fib-3 swap - 1- tuple-fib-3 dup . + 1 - tuple-fib-3 dup . swap i>> swap i>> + ] if ; inline recursive @@ -286,9 +286,9 @@ C: ro-box dup 1 <= [ drop 1 ] [ - 1- dup bad-tuple-fib-3 + 1 - dup bad-tuple-fib-3 swap - 1- bad-tuple-fib-3 + 1 - bad-tuple-fib-3 2drop f ] if ; inline recursive @@ -344,4 +344,4 @@ TUPLE: empty-tuple ; [ 0 ] [ [ { vector } declare length>> ] count-unboxed-allocations -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor b/basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor index 033d5b01cc..c26f3ddefc 100644 --- a/basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor +++ b/basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor @@ -1,7 +1,7 @@ -IN: compiler.tree.escape-analysis.recursive.tests USING: kernel tools.test namespaces sequences compiler.tree.escape-analysis.recursive compiler.tree.escape-analysis.allocations ; +IN: compiler.tree.escape-analysis.recursive.tests H{ } clone allocations set escaping-values set diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor old mode 100644 new mode 100755 index 9b278dde9b..fca35a5653 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences words memoize combinators -classes classes.builtin classes.tuple math.partial-dispatch -fry assocs combinators.short-circuit +classes classes.builtin classes.tuple classes.singleton +math.partial-dispatch fry assocs combinators.short-circuit compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -45,6 +45,7 @@ M: predicate finalize-word "predicating" word-prop { { [ dup builtin-class? ] [ drop word>> cached-expansion ] } { [ dup tuple-class? ] [ drop word>> def>> splice-final ] } + { [ dup singleton-class? ] [ drop word>> def>> splice-final ] } [ drop ] } cond ; diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor index a9415adbd7..42e7f421bf 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -1,12 +1,11 @@ ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -IN: compiler.tree.modular-arithmetic.tests USING: kernel kernel.private tools.test math math.partial-dispatch -math.private accessors slots.private sequences sequences.private strings sbufs -compiler.tree.builder -compiler.tree.normalization -compiler.tree.debugger -alien.accessors layouts combinators byte-arrays ; +prettyprint math.private accessors slots.private sequences +sequences.private strings sbufs compiler.tree.builder +compiler.tree.normalization compiler.tree.debugger alien.accessors +layouts combinators byte-arrays arrays ; +IN: compiler.tree.modular-arithmetic.tests : test-modular-arithmetic ( quot -- quot' ) cleaned-up-tree nodes>quot ; @@ -93,8 +92,6 @@ TUPLE: declared-fixnum { x fixnum } ; [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined? ] unit-test - - [ t ] [ [ { integer } declare [ 256 mod ] map @@ -137,9 +134,14 @@ TUPLE: declared-fixnum { x fixnum } ; ] { mod fixnum-mod rem } inlined? ] unit-test -[ [ >fixnum 255 fixnum-bitand ] ] +[ [ >fixnum 255 >R R> fixnum-bitand ] ] [ [ >integer 256 rem ] test-modular-arithmetic ] unit-test +[ t ] [ + [ { fixnum fixnum } declare + [ 1 + >fixnum ] [ 2 + >fixnum ] bi ] + { >fixnum } inlined? +] unit-test + [ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-unsigned-1 ] ] [ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-1 ] test-modular-arithmetic ] unit-test @@ -175,4 +177,116 @@ cell { [ t ] [ [ 0 10 10 [ 1 pick 0 + >fixnum pick set-nth-unsafe [ 1 + >fixnum ] dip ] times ] { >fixnum } inlined? +] unit-test + +[ f ] [ [ + >fixnum ] { >fixnum } inlined? ] unit-test + +[ t ] [ + [ >integer [ >fixnum ] [ >fixnum ] bi ] + { >integer } inlined? +] unit-test + +[ f ] [ + [ >integer [ >fixnum ] [ >fixnum ] bi ] + { >fixnum } inlined? +] unit-test + +[ t ] [ + [ >integer [ 2 + >fixnum ] [ 3 + >fixnum ] bi ] + { >integer } inlined? +] unit-test + +[ f ] [ + [ >integer [ 2 + >fixnum ] [ 3 + >fixnum ] bi ] + { >fixnum } inlined? +] unit-test + +[ t ] [ + [ >integer [ >fixnum ] [ >fixnum ] bi ] + { >integer } inlined? +] unit-test + +[ f ] [ + [ >bignum [ >fixnum ] [ >fixnum ] bi ] + { >fixnum } inlined? +] unit-test + +[ t ] [ + [ >bignum [ >fixnum ] [ >fixnum ] bi ] + { >bignum } inlined? +] unit-test + +[ f ] [ + [ [ { fixnum } declare 2 fixnum+ ] dip [ >fixnum 2 - ] [ ] if ] + { fixnum+ } inlined? +] unit-test + +[ t ] [ + [ { fixnum boolean } declare [ 1 + ] [ "HI" throw ] if >fixnum ] + { fixnum+ >fixnum } inlined? +] unit-test + +[ t ] [ + [ { fixnum boolean } declare [ 1 + ] [ drop 5 ] if >fixnum ] + { fixnum+ >fixnum } inlined? +] unit-test + +[ t ] [ + [ { fixnum boolean } declare [ 1 + ] [ 2 + ] if >fixnum ] + { fixnum+ >fixnum } inlined? +] unit-test + +[ [ [ 1 ] [ 4 ] if ] ] [ + [ [ 1.5 ] [ 4 ] if >fixnum ] test-modular-arithmetic +] unit-test + +[ [ [ 1 ] [ 2 ] if ] ] [ + [ [ 1.5 ] [ 2.3 ] if >fixnum ] test-modular-arithmetic +] unit-test + +[ f ] [ + [ { fixnum fixnum boolean } declare [ [ 3 * ] [ 1 + ] dip ] [ [ 4 - ] [ 2 + ] dip ] if >fixnum ] + { fixnum+ >fixnum } inlined? +] unit-test + +[ t ] [ + [ 0 1000 [ 1 + dup >fixnum . ] times drop ] + { fixnum+ >fixnum } inlined? +] unit-test + +[ t ] [ + [ { fixnum } declare 3 + [ 1000 ] dip [ >fixnum . ] curry times ] + { fixnum+ >fixnum } inlined? +] unit-test + +[ t ] [ + [ 0 1000 [ 1 + ] times >fixnum ] + { fixnum+ >fixnum } inlined? +] unit-test + +[ f ] [ + [ f >fixnum ] + { >fixnum } inlined? +] unit-test + +[ f ] [ + [ [ >fixnum ] 2dip set-alien-unsigned-1 ] + { >fixnum } inlined? +] unit-test + +[ t ] [ + [ { fixnum } declare 123 >bignum bitand >fixnum ] + { >bignum fixnum>bignum bignum-bitand } inlined? +] unit-test + +! Shifts +[ t ] [ + [ + [ 0 ] 2dip { array } declare [ + hashcode* >fixnum swap [ + [ -2 shift ] [ 5 shift ] bi + + + + ] keep bitxor >fixnum + ] with each + ] { + bignum+ fixnum-shift bitxor bignum-bitxor } inlined? ] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor index 148286faba..8ca80ccbae 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: math math.partial-dispatch namespaces sequences sets -accessors assocs words kernel memoize fry combinators -combinators.short-circuit layouts alien.accessors +USING: math math.intervals math.private math.partial-dispatch +namespaces sequences sets accessors assocs words kernel memoize fry +combinators combinators.short-circuit layouts alien.accessors compiler.tree compiler.tree.combinators +compiler.tree.propagation.info compiler.tree.def-use compiler.tree.def-use.simplified compiler.tree.late-optimizations ; @@ -19,17 +20,24 @@ IN: compiler.tree.modular-arithmetic ! ==> ! [ >fixnum ] bi@ fixnum+fast +! Words where the low-order bits of the output only depends on the +! low-order bits of the input. If the output is only used for its +! low-order bits, then the word can be converted into a form that is +! cheaper to compute. { + - * bitand bitor bitxor } [ [ t "modular-arithmetic" set-word-prop ] each-integer-derived-op ] each -{ bitand bitor bitxor bitnot } +{ bitand bitor bitxor bitnot >integer >bignum fixnum>bignum } [ t "modular-arithmetic" set-word-prop ] each +! Words that only use the low-order bits of their input. If the input +! is a modular arithmetic word, then the input can be converted into +! a form that is cheaper to compute. { - >fixnum + >fixnum bignum>fixnum float>fixnum set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2 set-alien-signed-2 } @@ -38,80 +46,156 @@ cell 8 = [ ] when [ t "low-order" set-word-prop ] each -SYMBOL: modularize-values +! Values which only have their low-order bits used. This set starts out +! big and is gradually refined. +SYMBOL: modular-values : modular-value? ( value -- ? ) - modularize-values get key? ; + modular-values get key? ; -: modularize-value ( value -- ) modularize-values get conjoin ; +: modular-value ( value -- ) + modular-values get conjoin ; -GENERIC: maybe-modularize* ( value node -- ) +! Values which are known to be fixnums. +SYMBOL: fixnum-values -: maybe-modularize ( value -- ) - actually-defined-by [ value>> ] [ node>> ] bi - over actually-used-by length 1 = [ - maybe-modularize* - ] [ 2drop ] if ; +: fixnum-value? ( value -- ? ) + fixnum-values get key? ; -M: #call maybe-modularize* - dup word>> "modular-arithmetic" word-prop [ - [ modularize-value ] - [ in-d>> [ maybe-modularize ] each ] bi* - ] [ 2drop ] if ; +: fixnum-value ( value -- ) + fixnum-values get conjoin ; -M: node maybe-modularize* 2drop ; +GENERIC: compute-modular-candidates* ( node -- ) -GENERIC: compute-modularized-values* ( node -- ) +M: #push compute-modular-candidates* + [ out-d>> first ] [ literal>> ] bi + real? [ [ modular-value ] [ fixnum-value ] bi ] [ drop ] if ; -M: #call compute-modularized-values* - dup word>> "low-order" word-prop - [ in-d>> first maybe-modularize ] [ drop ] if ; +: small-shift? ( interval -- ? ) + 0 cell-bits tag-bits get - 1 - [a,b] interval-subset? ; -M: node compute-modularized-values* drop ; +: modular-word? ( #call -- ? ) + dup word>> { shift fixnum-shift bignum-shift } memq? + [ node-input-infos second interval>> small-shift? ] + [ word>> "modular-arithmetic" word-prop ] + if ; -: compute-modularized-values ( nodes -- ) - [ compute-modularized-values* ] each-node ; +: output-candidate ( #call -- ) + out-d>> first [ modular-value ] [ fixnum-value ] bi ; + +: low-order-word? ( #call -- ? ) + word>> "low-order" word-prop ; + +: input-candidiate ( #call -- ) + in-d>> first modular-value ; + +M: #call compute-modular-candidates* + { + { [ dup modular-word? ] [ output-candidate ] } + { [ dup low-order-word? ] [ input-candidiate ] } + [ drop ] + } cond ; + +M: node compute-modular-candidates* + drop ; + +: compute-modular-candidates ( nodes -- ) + H{ } clone modular-values set + H{ } clone fixnum-values set + [ compute-modular-candidates* ] each-node ; + +GENERIC: only-reads-low-order? ( node -- ? ) + +: output-modular? ( #call -- ? ) + out-d>> first modular-values get key? ; + +M: #call only-reads-low-order? + { + [ low-order-word? ] + [ { [ modular-word? ] [ output-modular? ] } 1&& ] + } 1|| ; + +M: node only-reads-low-order? drop f ; + +SYMBOL: changed? + +: only-used-as-low-order? ( value -- ? ) + actually-used-by [ node>> only-reads-low-order? ] all? ; + +: (compute-modular-values) ( -- ) + modular-values get keys [ + dup only-used-as-low-order? + [ drop ] [ modular-values get delete-at changed? on ] if + ] each ; + +: compute-modular-values ( -- ) + [ changed? off (compute-modular-values) changed? get ] loop ; GENERIC: optimize-modular-arithmetic* ( node -- nodes ) +M: #push optimize-modular-arithmetic* + dup [ out-d>> first modular-value? ] [ literal>> real? ] bi and + [ [ >fixnum ] change-literal ] when ; + : redundant->fixnum? ( #call -- ? ) - in-d>> first actually-defined-by value>> modular-value? ; + in-d>> first actually-defined-by + [ value>> { [ modular-value? ] [ fixnum-value? ] } 1&& ] all? ; : optimize->fixnum ( #call -- nodes ) dup redundant->fixnum? [ drop f ] when ; +: should-be->fixnum? ( #call -- ? ) + out-d>> first modular-value? ; + : optimize->integer ( #call -- nodes ) - dup out-d>> first actually-used-by dup length 1 = [ - first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&& - [ drop { } ] when - ] [ drop ] if ; + dup should-be->fixnum? [ \ >fixnum >>word ] when ; MEMO: fixnum-coercion ( flags -- nodes ) + ! flags indicate which input parameters are already known to be fixnums, + ! and don't need a coercion as a result. [ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ; +: modular-value-info ( #call -- alist ) + [ in-d>> ] [ out-d>> ] bi append + fixnum '[ _ ] { } map>assoc ; + : optimize-modular-op ( #call -- nodes ) dup out-d>> first modular-value? [ [ in-d>> ] [ word>> integer-op-input-classes ] [ ] tri [ [ - [ actually-defined-by value>> modular-value? ] + [ actually-defined-by [ value>> modular-value? ] all? ] [ fixnum eq? ] bi* or ] 2map fixnum-coercion ] [ [ modular-variant ] change-word ] bi* suffix ] when ; +: optimize-low-order-op ( #call -- nodes ) + dup in-d>> first actually-defined-by [ value>> fixnum-value? ] all? [ + [ ] [ in-d>> first ] [ info>> ] tri + [ drop fixnum ] change-at + ] when ; + +: like->fixnum? ( #call -- ? ) + word>> { >fixnum bignum>fixnum float>fixnum } memq? ; + +: like->integer? ( #call -- ? ) + word>> { >integer >bignum fixnum>bignum } memq? ; + M: #call optimize-modular-arithmetic* - dup word>> { - { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] } - { [ dup \ >integer eq? ] [ drop optimize->integer ] } - { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] } - [ drop ] + { + { [ dup like->fixnum? ] [ optimize->fixnum ] } + { [ dup like->integer? ] [ optimize->integer ] } + { [ dup modular-word? ] [ optimize-modular-op ] } + { [ dup low-order-word? ] [ optimize-low-order-op ] } + [ ] } cond ; M: node optimize-modular-arithmetic* ; : optimize-modular-arithmetic ( nodes -- nodes' ) - H{ } clone modularize-values set - dup compute-modularized-values - [ optimize-modular-arithmetic* ] map-nodes ; + dup compute-modular-candidates compute-modular-values + modular-values get assoc-empty? [ + [ optimize-modular-arithmetic* ] map-nodes + ] unless ; diff --git a/basis/compiler/tree/normalization/normalization-tests.factor b/basis/compiler/tree/normalization/normalization-tests.factor index 3b4574effe..19669c2239 100644 --- a/basis/compiler/tree/normalization/normalization-tests.factor +++ b/basis/compiler/tree/normalization/normalization-tests.factor @@ -1,10 +1,10 @@ -IN: compiler.tree.normalization.tests USING: compiler.tree.builder compiler.tree.recursive compiler.tree.normalization compiler.tree.normalization.introductions compiler.tree.normalization.renaming compiler.tree compiler.tree.checker sequences accessors tools.test kernel math ; +IN: compiler.tree.normalization.tests [ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test diff --git a/basis/compiler/tree/optimizer/optimizer-tests.factor b/basis/compiler/tree/optimizer/optimizer-tests.factor deleted file mode 100644 index 5d05947b8a..0000000000 --- a/basis/compiler/tree/optimizer/optimizer-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -USING: compiler.tree.optimizer tools.test ; -IN: compiler.tree.optimizer.tests - - diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor index ec2a4b1ece..cdbeabe532 100644 --- a/basis/compiler/tree/propagation/call-effect/call-effect.factor +++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor @@ -35,7 +35,7 @@ M: +unknown+ curry-effect ; M: effect curry-effect [ in>> length ] [ out>> length ] [ terminated?>> ] tri - pick 0 = [ [ 1+ ] dip ] [ [ 1- ] 2dip ] if + pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if effect boa ; M: curry cached-effect @@ -153,7 +153,7 @@ ERROR: uninferable ; : (value>quot) ( value-info -- quot ) dup class>> { - { \ quotation [ literal>> dup remember-inlining '[ drop @ ] ] } + { \ quotation [ literal>> dup add-to-history '[ drop @ ] ] } { \ curry [ slots>> third (value>quot) '[ [ obj>> ] [ quot>> @ ] bi ] diff --git a/basis/compiler/tree/propagation/copy/copy-tests.factor b/basis/compiler/tree/propagation/copy/copy-tests.factor index a99c2a2447..b546e56e4b 100644 --- a/basis/compiler/tree/propagation/copy/copy-tests.factor +++ b/basis/compiler/tree/propagation/copy/copy-tests.factor @@ -1,6 +1,6 @@ -IN: compiler.tree.propagation.copy.tests USING: compiler.tree.propagation.copy tools.test namespaces kernel assocs ; +IN: compiler.tree.propagation.copy.tests H{ } clone copies set diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index cae8d6cde6..0a04b48160 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs classes classes.algebra classes.tuple classes.tuple.private kernel accessors math math.intervals namespaces -sequences sequences.private words combinators +sequences sequences.private words combinators memoize combinators.short-circuit byte-arrays strings arrays layouts cpu.architecture compiler.tree.propagation.copy ; IN: compiler.tree.propagation.info @@ -78,21 +78,37 @@ UNION: fixed-length array byte-array string ; : empty-set? ( info -- ? ) { [ class>> null-class? ] - [ [ class>> real class<= ] [ interval>> empty-interval eq? ] bi and ] + [ [ interval>> empty-interval eq? ] [ class>> real class<= ] bi and ] } 1|| ; -: min-value ( class -- n ) fixnum eq? [ most-negative-fixnum ] [ -1/0. ] if ; +: min-value ( class -- n ) + { + { fixnum [ most-negative-fixnum ] } + { array-capacity [ 0 ] } + [ drop -1/0. ] + } case ; -: max-value ( class -- n ) fixnum eq? [ most-positive-fixnum ] [ 1/0. ] if ; +: max-value ( class -- n ) + { + { fixnum [ most-positive-fixnum ] } + { array-capacity [ max-array-capacity ] } + [ drop 1/0. ] + } case ; -: class-interval ( class -- i ) fixnum eq? [ fixnum-interval ] [ full-interval ] if ; +: class-interval ( class -- i ) + { + { fixnum [ fixnum-interval ] } + { array-capacity [ array-capacity-interval ] } + [ drop full-interval ] + } case ; : wrap-interval ( interval class -- interval' ) { - { fixnum [ interval->fixnum ] } - { array-capacity [ max-array-capacity [a,a] interval-rem ] } + { [ over empty-interval eq? ] [ drop ] } + { [ over full-interval eq? ] [ nip class-interval ] } + { [ 2dup class-interval interval-subset? not ] [ nip class-interval ] } [ drop ] - } case ; + } cond ; : init-interval ( info -- info ) dup [ interval>> full-interval or ] [ class>> ] bi wrap-interval >>interval diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index ef1326c81f..3836e0f3ba 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -3,8 +3,8 @@ USING: accessors kernel arrays sequences math math.order math.partial-dispatch generic generic.standard generic.single generic.math classes.algebra classes.union sets quotations assocs combinators -words namespaces continuations classes fry combinators.smart hints -locals +combinators.short-circuit words namespaces continuations classes +fry hints locals compiler.tree compiler.tree.builder compiler.tree.recursive @@ -14,19 +14,6 @@ compiler.tree.propagation.info compiler.tree.propagation.nodes ; IN: compiler.tree.propagation.inlining -! We count nodes up-front; if there are relatively few nodes, -! we are more eager to inline -SYMBOL: node-count - -: count-nodes ( nodes -- n ) - 0 swap [ drop 1+ ] each-node ; - -: compute-node-count ( nodes -- ) count-nodes node-count set ; - -! We try not to inline the same word too many times, to avoid -! combinatorial explosion -SYMBOL: inlining-count - ! Splicing nodes : splicing-call ( #call word -- nodes ) [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; @@ -101,99 +88,28 @@ M: callable splicing-nodes splicing-body ; dupd inlining-math-partial eliminate-dispatch ; ! Method body inlining -SYMBOL: recursive-calls -DEFER: (flat-length) - -: word-flat-length ( word -- n ) - { - ! special-case - { [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] } - ! not inline - { [ dup inline? not ] [ drop 1 ] } - ! recursive and inline - { [ dup recursive-calls get key? ] [ drop 10 ] } - ! inline - [ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ] - } cond ; - -: (flat-length) ( seq -- n ) - [ - { - { [ dup quotation? ] [ (flat-length) 2 + ] } - { [ dup array? ] [ (flat-length) ] } - { [ dup word? ] [ word-flat-length ] } - [ drop 0 ] - } cond - ] sigma ; - -: flat-length ( word -- n ) - H{ } clone recursive-calls [ - [ recursive-calls get conjoin ] - [ def>> (flat-length) 5 /i ] - bi - ] with-variable ; - -: classes-known? ( #call -- ? ) - in-d>> [ - value-info class>> - [ class-types length 1 = ] - [ union-class? not ] - bi and - ] any? ; - -: node-count-bias ( -- n ) - 45 node-count get [-] 8 /i ; - -: body-length-bias ( word -- n ) - [ flat-length ] [ inlining-count get at 0 or ] bi - over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ; - -: inlining-rank ( #call word -- n ) - [ - [ classes-known? 2 0 ? ] - [ - [ body-length-bias ] - [ "specializer" word-prop 1 0 ? ] - [ method-body? 1 0 ? ] - tri - node-count-bias - loop-nesting get 0 or 2 * - ] bi* - ] sum-outputs ; - -: should-inline? ( #call word -- ? ) - dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ; - SYMBOL: history : already-inlined? ( obj -- ? ) history get memq? ; : add-to-history ( obj -- ) history [ swap suffix ] change ; -: remember-inlining ( word -- ) - [ inlining-count get inc-at ] - [ add-to-history ] - bi ; - :: inline-word ( #call word -- ? ) word already-inlined? [ f ] [ #call word splicing-body [ [ - word remember-inlining - [ ] [ count-nodes ] [ (propagate) ] tri + word add-to-history + dup (propagate) ] with-scope - [ #call (>>body) ] [ node-count +@ ] bi* t + #call (>>body) t ] [ f ] if* ] if ; -: inline-method-body ( #call word -- ? ) - 2dup should-inline? [ inline-word ] [ 2drop f ] if ; - : always-inline-word? ( word -- ? ) { curry compose } memq? ; : never-inline-word? ( word -- ? ) - [ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ; + { [ deferred? ] [ "default" word-prop ] [ \ call eq? ] } 1|| ; : custom-inlining? ( word -- ? ) "custom-inlining" word-prop ; @@ -217,7 +133,7 @@ SYMBOL: history { [ dup always-inline-word? ] [ inline-word ] } { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } - { [ dup method-body? ] [ inline-method-body ] } + { [ dup inline? ] [ inline-word ] } [ 2drop f ] } cond ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 8c4e81f41d..3a20424e18 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel effects accessors math math.private math.integers.private math.partial-dispatch math.intervals -math.parser math.order layouts words sequences sequences.private +math.parser math.order math.functions layouts words sequences sequences.private arrays assocs classes classes.algebra combinators generic.math splitting fry locals classes.tuple alien.accessors classes.tuple.private slots.private definitions strings.private @@ -32,14 +32,20 @@ IN: compiler.tree.propagation.known-words \ bitnot { integer } "input-classes" set-word-prop -: ?change-interval ( info quot -- quot' ) - over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline +: real-op ( info quot -- quot' ) + [ + dup class>> real classes-intersect? + [ clone ] [ drop real ] if + ] dip + change-interval ; inline { bitnot fixnum-bitnot bignum-bitnot } [ - [ [ interval-bitnot ] ?change-interval ] "outputs" set-word-prop + [ [ interval-bitnot ] real-op ] "outputs" set-word-prop ] each -\ abs [ [ interval-abs ] ?change-interval ] "outputs" set-word-prop +\ abs [ [ interval-abs ] real-op ] "outputs" set-word-prop + +\ absq [ [ interval-absq ] real-op ] "outputs" set-word-prop : math-closure ( class -- newclass ) { fixnum bignum integer rational float real number object } @@ -240,11 +246,11 @@ generic-comparison-ops [ dup name>> { { [ "alien-signed-" ?head ] - [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ] + [ string>number 8 * 1 - 2^ dup neg swap 1 - [a,b] ] } { [ "alien-unsigned-" ?head ] - [ string>number 8 * 2^ 1- 0 swap [a,b] ] + [ string>number 8 * 2^ 1 - 0 swap [a,b] ] } } cond [ fits-in-fixnum? fixnum integer ? ] keep diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 59631d04c6..511f87dd09 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -82,6 +82,8 @@ IN: compiler.tree.propagation.tests [ bignum ] [ [ { bignum bignum } declare bitxor ] final-math-class ] unit-test +[ bignum ] [ [ { integer } declare 123 >bignum bitand ] final-math-class ] unit-test + [ float ] [ [ { float float } declare mod ] final-math-class ] unit-test [ V{ fixnum } ] [ [ 255 bitand ] final-classes ] unit-test @@ -157,6 +159,22 @@ IN: compiler.tree.propagation.tests [ V{ t } ] [ [ abs 40 mod 0 >= ] final-literals ] unit-test +[ t ] [ [ abs ] final-info first interval>> [0,inf] = ] unit-test + +[ t ] [ [ absq ] final-info first interval>> [0,inf] = ] unit-test + +[ t ] [ [ { float } declare abs ] final-info first interval>> [0,inf] = ] unit-test + +[ t ] [ [ { float } declare absq ] final-info first interval>> [0,inf] = ] unit-test + +[ t ] [ [ { complex } declare abs ] final-info first interval>> [0,inf] = ] unit-test + +[ t ] [ [ { complex } declare absq ] final-info first interval>> [0,inf] = ] unit-test + +[ t ] [ [ [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test + +[ t ] [ [ { double-array double-array } declare [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test + [ V{ string } ] [ [ dup string? not [ "Oops" throw ] [ ] if ] final-classes ] unit-test @@ -278,11 +296,11 @@ IN: compiler.tree.propagation.tests ] unit-test [ V{ fixnum } ] [ - [ >fixnum dup 100 < [ 1+ ] [ "Oops" throw ] if ] final-classes + [ >fixnum dup 100 < [ 1 + ] [ "Oops" throw ] if ] final-classes ] unit-test [ V{ -1 } ] [ - [ 0 dup 100 < not [ 1+ ] [ 1- ] if ] final-literals + [ 0 dup 100 < not [ 1 + ] [ 1 - ] if ] final-literals ] unit-test [ V{ 2 } ] [ @@ -444,6 +462,13 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; ] final-classes ] unit-test +[ V{ f { } } ] [ + [ + T{ mixed-mutable-immutable f 3 { } } + [ x>> ] [ y>> ] bi + ] final-literals +] unit-test + ! Recursive propagation : recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive @@ -472,7 +497,7 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; ] unit-test : recursive-test-4 ( i n -- ) - 2dup < [ [ 1+ ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive + 2dup < [ [ 1 + ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive [ ] [ [ recursive-test-4 ] final-info drop ] unit-test @@ -487,7 +512,7 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; [ V{ integer } ] [ [ { fixnum } declare recursive-test-6 ] final-classes ] unit-test : recursive-test-7 ( a -- b ) - dup 10 < [ 1+ recursive-test-7 ] when ; inline recursive + dup 10 < [ 1 + recursive-test-7 ] when ; inline recursive [ V{ fixnum } ] [ [ 0 recursive-test-7 ] final-classes ] unit-test @@ -502,8 +527,8 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; ] unit-test GENERIC: iterate ( obj -- next-obj ? ) -M: fixnum iterate f ; -M: array iterate first t ; +M: fixnum iterate f ; inline +M: array iterate first t ; inline : dead-loop ( obj -- final-obj ) iterate [ dead-loop ] when ; inline recursive @@ -567,7 +592,7 @@ M: array iterate first t ; ] unit-test GENERIC: bad-generic ( a -- b ) -M: fixnum bad-generic 1 fixnum+fast ; +M: fixnum bad-generic 1 fixnum+fast ; inline : bad-behavior ( -- b ) 4 bad-generic ; inline recursive [ V{ fixnum } ] [ [ bad-behavior ] final-classes ] unit-test @@ -645,7 +670,7 @@ MIXIN: empty-mixin ] unit-test [ V{ bignum } ] [ - [ { bignum } declare dup 1- bitxor ] final-classes + [ { bignum } declare dup 1 - bitxor ] final-classes ] unit-test [ V{ bignum integer } ] [ @@ -685,7 +710,7 @@ MIXIN: empty-mixin TUPLE: littledan-1 { a read-only } ; -: (littledan-1-test) ( a -- ) a>> 1+ littledan-1 boa (littledan-1-test) ; inline recursive +: (littledan-1-test) ( a -- ) a>> 1 + littledan-1 boa (littledan-1-test) ; inline recursive : littledan-1-test ( -- ) 0 littledan-1 boa (littledan-1-test) ; inline @@ -702,7 +727,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ; [ ] [ [ littledan-2-test ] final-classes drop ] unit-test : (littledan-3-test) ( x -- ) - length 1+ f (littledan-3-test) ; inline recursive + length 1 + f (littledan-3-test) ; inline recursive : littledan-3-test ( -- ) 0 f (littledan-3-test) ; inline @@ -711,7 +736,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ; [ V{ 0 } ] [ [ { } length ] final-literals ] unit-test -[ V{ 1 } ] [ [ { } length 1+ f length ] final-literals ] unit-test +[ V{ 1 } ] [ [ { } length 1 + f length ] final-literals ] unit-test ! generalize-counter is not tight enough [ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times ] final-classes ] unit-test @@ -740,7 +765,7 @@ TUPLE: foo bar ; [ t ] [ [ foo new ] { new } inlined? ] unit-test GENERIC: whatever ( x -- y ) -M: number whatever drop foo ; +M: number whatever drop foo ; inline [ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test @@ -749,8 +774,8 @@ M: number whatever drop foo ; [ f ] [ [ that-thing new ] { new } inlined? ] unit-test GENERIC: whatever2 ( x -- y ) -M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; -M: f whatever2 ; +M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; inline +M: f whatever2 ; inline [ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test [ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor index 3dd2c4998a..a11264fb7f 100644 --- a/basis/compiler/tree/propagation/propagation.factor +++ b/basis/compiler/tree/propagation/propagation.factor @@ -19,6 +19,4 @@ IN: compiler.tree.propagation H{ } clone copies set H{ } clone 1array value-infos set H{ } clone 1array constraints set - H{ } clone inlining-count set - dup compute-node-count dup (propagate) ; diff --git a/basis/compiler/tree/propagation/recursive/recursive-tests.factor b/basis/compiler/tree/propagation/recursive/recursive-tests.factor index db427d34af..974bb584eb 100644 --- a/basis/compiler/tree/propagation/recursive/recursive-tests.factor +++ b/basis/compiler/tree/propagation/recursive/recursive-tests.factor @@ -1,6 +1,6 @@ -IN: compiler.tree.propagation.recursive.tests USING: tools.test compiler.tree.propagation.recursive math.intervals kernel math literals layouts ; +IN: compiler.tree.propagation.recursive.tests [ T{ interval f { 0 t } { 1/0. t } } ] [ T{ interval f { 1 t } { 1 t } } diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 5837d59ef9..88c9831a24 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -119,7 +119,9 @@ M: #declare propagate-before M: #call propagate-before dup word>> { { [ 2dup foldable-call? ] [ fold-call ] } - { [ 2dup do-inlining ] [ 2drop ] } + { [ 2dup do-inlining ] [ + [ output-value-infos ] [ drop out-d>> ] 2bi refine-value-infos + ] } [ [ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ] [ compute-constraints ] diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 86114772f7..4996729ded 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -63,5 +63,5 @@ UNION: fixed-length-sequence array byte-array string ; { [ over 0 = ] [ 2drop fixnum ] } { [ 2dup length-accessor? ] [ nip length>> ] } { [ dup literal?>> ] [ literal>> literal-info-slot ] } - [ [ 1- ] [ slots>> ] bi* ?nth ] + [ [ 1 - ] [ slots>> ] bi* ?nth ] } cond [ object-info ] unless* ; diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 3fd7af0324..683c182903 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -20,7 +20,7 @@ IN: compiler.tree.propagation.transforms : rem-custom-inlining ( #call -- quot/f ) second value-info literal>> dup integer? - [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ; + [ power-of-2? [ 1 - bitand ] f ? ] [ drop f ] if ; { mod-integer-integer @@ -38,6 +38,12 @@ IN: compiler.tree.propagation.transforms in-d>> rem-custom-inlining ] "custom-inlining" set-word-prop +: positive-fixnum? ( obj -- ? ) + { [ fixnum? ] [ 0 >= ] } 1&& ; + +: simplify-bitand? ( value -- ? ) + value-info literal>> positive-fixnum? ; + { bitand-integer-integer bitand-integer-fixnum @@ -45,10 +51,17 @@ IN: compiler.tree.propagation.transforms bitand } [ [ - in-d>> second value-info >literal< [ - 0 most-positive-fixnum between? - [ [ >fixnum ] bi@ fixnum-bitand ] f ? - ] when + { + { + [ dup in-d>> first simplify-bitand? ] + [ drop [ >fixnum fixnum-bitand ] ] + } + { + [ dup in-d>> second simplify-bitand? ] + [ drop [ [ >fixnum ] dip fixnum-bitand ] ] + } + [ drop f ] + } cond ] "custom-inlining" set-word-prop ] each @@ -162,7 +175,7 @@ CONSTANT: lookup-table-at-max 256 } 1&& ; : lookup-table-seq ( assoc -- table ) - [ keys supremum 1+ ] keep '[ _ at ] { } map-as ; + [ keys supremum 1 + ] keep '[ _ at ] { } map-as ; : lookup-table-quot ( seq -- newquot ) lookup-table-seq diff --git a/basis/compiler/tree/recursive/recursive-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor index 8157084805..4c4220f238 100644 --- a/basis/compiler/tree/recursive/recursive-tests.factor +++ b/basis/compiler/tree/recursive/recursive-tests.factor @@ -1,10 +1,10 @@ -IN: compiler.tree.recursive.tests USING: tools.test kernel combinators.short-circuit math sequences accessors compiler.tree compiler.tree.builder compiler.tree.combinators compiler.tree.recursive compiler.tree.recursive.private ; +IN: compiler.tree.recursive.tests [ { f f f f } ] [ f { f t f f } (tail-calls) ] unit-test [ { f f f t } ] [ t { f t f f } (tail-calls) ] unit-test @@ -30,7 +30,7 @@ compiler.tree.recursive.private ; ] curry contains-node? ; : loop-test-1 ( a -- ) - dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive + dup [ 1 + loop-test-1 ] [ drop ] if ; inline recursive [ t ] [ [ loop-test-1 ] build-tree analyze-recursive @@ -53,7 +53,7 @@ compiler.tree.recursive.private ; ] unit-test : loop-test-2 ( a b -- a' ) - dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive + dup [ 1 + loop-test-2 1 - ] [ drop ] if ; inline recursive [ t ] [ [ loop-test-2 ] build-tree analyze-recursive @@ -198,4 +198,4 @@ DEFER: b4 [ t ] [ [ b4 ] build-tree analyze-recursive \ a4 label-is-loop? ] unit-test [ t ] [ [ b4 ] build-tree analyze-recursive \ b4 label-is-not-loop? ] unit-test [ t ] [ [ a4 ] build-tree analyze-recursive \ a4 label-is-not-loop? ] unit-test -[ t ] [ [ a4 ] build-tree analyze-recursive \ b4 label-is-loop? ] unit-test \ No newline at end of file +[ t ] [ [ a4 ] build-tree analyze-recursive \ b4 label-is-loop? ] unit-test diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index a96fc0501d..d73368867d 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -1,4 +1,3 @@ -IN: compiler.tree.tuple-unboxing.tests USING: tools.test compiler.tree compiler.tree.builder compiler.tree.recursive compiler.tree.normalization compiler.tree.propagation @@ -7,6 +6,7 @@ compiler.tree.tuple-unboxing compiler.tree.checker compiler.tree.def-use kernel accessors sequences math math.private sorting math.order binary-search sequences.private slots.private ; +IN: compiler.tree.tuple-unboxing.tests : test-unboxing ( quot -- ) build-tree diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor index 9ece36e6cd..2df4dce916 100755 --- a/basis/compression/huffman/huffman.factor +++ b/basis/compression/huffman/huffman.factor @@ -17,8 +17,8 @@ TUPLE: huffman-code { code } ; : ( -- code ) 0 0 0 huffman-code boa ; -: next-size ( code -- ) [ 1+ ] change-size [ 2 * ] change-code drop ; -: next-code ( code -- ) [ 1+ ] change-code drop ; +: next-size ( code -- ) [ 1 + ] change-size [ 2 * ] change-code drop ; +: next-code ( code -- ) [ 1 + ] change-code drop ; :: all-patterns ( huff n -- seq ) n log2 huff size>> - :> free-bits diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor index 05ec94a794..ff38f94c68 100644 --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -64,7 +64,7 @@ CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 } k swap - dup k! 0 > ] [ ] produce swap suffix - { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap append ] bi* ] [ suffix ] if ] reduce + { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1 + swap append ] bi* ] [ suffix ] if ] reduce [ dup array? [ second 0 ] [ 1array ] if ] map concat nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ; @@ -91,14 +91,14 @@ CONSTANT: dist-table } : nth* ( n seq -- elt ) - [ length 1- swap - ] [ nth ] bi ; + [ length 1 - swap - ] [ nth ] bi ; :: inflate-lz77 ( seq -- bytes ) 1000 :> bytes seq [ dup array? - [ first2 '[ _ 1- bytes nth* bytes push ] times ] + [ first2 '[ _ 1 - bytes nth* bytes push ] times ] [ bytes push ] if ] each bytes ; diff --git a/basis/compression/lzw/lzw-tests.factor b/basis/compression/lzw/lzw-tests.factor deleted file mode 100644 index 698e35d87e..0000000000 --- a/basis/compression/lzw/lzw-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors tools.test compression.lzw ; -IN: compression.lzw.tests diff --git a/basis/concurrency/combinators/combinators-tests.factor b/basis/concurrency/combinators/combinators-tests.factor index 1c2dea2d79..d3f3229171 100644 --- a/basis/concurrency/combinators/combinators-tests.factor +++ b/basis/concurrency/combinators/combinators-tests.factor @@ -1,7 +1,7 @@ -IN: concurrency.combinators.tests USING: concurrency.combinators tools.test random kernel math concurrency.mailboxes threads sequences accessors arrays math.parser ; +IN: concurrency.combinators.tests [ [ drop ] parallel-each ] must-infer { 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as @@ -49,7 +49,7 @@ math.parser ; [ "1a" "4b" "3c" ] [ 2 - { [ 1- ] [ sq ] [ 1+ ] } parallel-cleave + { [ 1 - ] [ sq ] [ 1 + ] } parallel-cleave [ number>string ] 3 parallel-napply { [ "a" append ] [ "b" append ] [ "c" append ] } parallel-spread ] unit-test diff --git a/basis/concurrency/count-downs/count-downs.factor b/basis/concurrency/count-downs/count-downs.factor index d79cfbf1c9..d88fcef609 100644 --- a/basis/concurrency/count-downs/count-downs.factor +++ b/basis/concurrency/count-downs/count-downs.factor @@ -23,7 +23,7 @@ ERROR: count-down-already-done ; : count-down ( count-down -- ) dup n>> dup zero? [ count-down-already-done ] - [ 1- >>n count-down-check ] if ; + [ 1 - >>n count-down-check ] if ; : await-timeout ( count-down timeout -- ) [ promise>> ] dip ?promise-timeout ?linked t assert= ; diff --git a/basis/concurrency/distributed/distributed-tests.factor b/basis/concurrency/distributed/distributed-tests.factor index 6c0d882cac..b2a2851926 100644 --- a/basis/concurrency/distributed/distributed-tests.factor +++ b/basis/concurrency/distributed/distributed-tests.factor @@ -1,9 +1,9 @@ -IN: concurrency.distributed.tests USING: tools.test concurrency.distributed kernel io.files io.files.temp io.directories arrays io.sockets system combinators threads math sequences concurrency.messaging continuations accessors prettyprint ; FROM: concurrency.messaging => receive send ; +IN: concurrency.distributed.tests : test-node ( -- addrspec ) { diff --git a/basis/concurrency/exchangers/exchangers-tests.factor b/basis/concurrency/exchangers/exchangers-tests.factor index 7ec9db8ad9..a8214cf42f 100644 --- a/basis/concurrency/exchangers/exchangers-tests.factor +++ b/basis/concurrency/exchangers/exchangers-tests.factor @@ -1,8 +1,8 @@ -IN: concurrency.exchangers.tests USING: tools.test concurrency.exchangers concurrency.count-downs concurrency.promises locals kernel threads ; FROM: sequences => 3append ; +IN: concurrency.exchangers.tests :: exchanger-test ( -- string ) [let | diff --git a/basis/concurrency/flags/flags-tests.factor b/basis/concurrency/flags/flags-tests.factor index 05ff74b03f..4fc00b71dd 100644 --- a/basis/concurrency/flags/flags-tests.factor +++ b/basis/concurrency/flags/flags-tests.factor @@ -1,6 +1,6 @@ -IN: concurrency.flags.tests USING: tools.test concurrency.flags concurrency.combinators kernel threads locals accessors calendar ; +IN: concurrency.flags.tests :: flag-test-1 ( -- val ) [let | f [ ] | diff --git a/basis/concurrency/futures/futures-tests.factor b/basis/concurrency/futures/futures-tests.factor index 208a72f820..07466e5ffd 100644 --- a/basis/concurrency/futures/futures-tests.factor +++ b/basis/concurrency/futures/futures-tests.factor @@ -1,5 +1,5 @@ -IN: concurrency.futures.tests USING: concurrency.futures kernel tools.test threads ; +IN: concurrency.futures.tests [ 50 ] [ [ 50 ] future ?future diff --git a/basis/concurrency/locks/locks-tests.factor b/basis/concurrency/locks/locks-tests.factor index 8f82aa88ba..f199876fd0 100644 --- a/basis/concurrency/locks/locks-tests.factor +++ b/basis/concurrency/locks/locks-tests.factor @@ -1,7 +1,7 @@ -IN: concurrency.locks.tests USING: tools.test concurrency.locks concurrency.count-downs concurrency.messaging concurrency.mailboxes locals kernel threads sequences calendar accessors ; +IN: concurrency.locks.tests :: lock-test-0 ( -- v ) [let | v [ V{ } clone ] diff --git a/basis/concurrency/locks/locks.factor b/basis/concurrency/locks/locks.factor index 0094f3323d..18cd86fa53 100644 --- a/basis/concurrency/locks/locks.factor +++ b/basis/concurrency/locks/locks.factor @@ -57,7 +57,7 @@ TUPLE: rw-lock readers writers reader# writer ; > @@ -68,7 +68,7 @@ TUPLE: rw-lock readers writers reader# writer ; writers>> notify-1 ; : remove-reader ( lock -- ) - [ 1- ] change-reader# drop ; + [ 1 - ] change-reader# drop ; : release-read-lock ( lock -- ) dup remove-reader diff --git a/basis/concurrency/mailboxes/mailboxes-tests.factor b/basis/concurrency/mailboxes/mailboxes-tests.factor index 81e54f1807..56d579d6c7 100644 --- a/basis/concurrency/mailboxes/mailboxes-tests.factor +++ b/basis/concurrency/mailboxes/mailboxes-tests.factor @@ -1,7 +1,7 @@ -IN: concurrency.mailboxes.tests USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions vectors sequences threads tools.test math kernel strings namespaces continuations calendar destructors ; +IN: concurrency.mailboxes.tests { 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as @@ -86,4 +86,4 @@ continuations calendar destructors ; [ 1 seconds mailbox-get-timeout ] [ wait-timeout? ] must-fail-with - \ No newline at end of file + diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor index 200adb14ae..419277647d 100755 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: concurrency.mailboxes USING: dlists deques threads sequences continuations destructors namespaces math quotations words kernel arrays assocs init system concurrency.conditions accessors debugger debugger.threads locals fry ; +IN: concurrency.mailboxes TUPLE: mailbox threads data disposed ; diff --git a/basis/concurrency/promises/promises-tests.factor b/basis/concurrency/promises/promises-tests.factor index 36fe4ef907..353f4a69b7 100644 --- a/basis/concurrency/promises/promises-tests.factor +++ b/basis/concurrency/promises/promises-tests.factor @@ -1,6 +1,6 @@ -IN: concurrency.promises.tests USING: vectors concurrency.promises kernel threads sequences tools.test ; +IN: concurrency.promises.tests [ V{ 50 50 50 } ] [ 0 diff --git a/basis/concurrency/semaphores/semaphores.factor b/basis/concurrency/semaphores/semaphores.factor index 59518f4c8d..dcd0ed9a2c 100644 --- a/basis/concurrency/semaphores/semaphores.factor +++ b/basis/concurrency/semaphores/semaphores.factor @@ -21,13 +21,13 @@ M: negative-count-semaphore summary : acquire-timeout ( semaphore timeout -- ) over count>> zero? [ dupd wait-to-acquire ] [ drop ] if - [ 1- ] change-count drop ; + [ 1 - ] change-count drop ; : acquire ( semaphore -- ) f acquire-timeout ; : release ( semaphore -- ) - [ 1+ ] change-count + [ 1 + ] change-count threads>> notify-1 ; :: with-semaphore-timeout ( semaphore timeout quot -- ) diff --git a/basis/cords/cords-tests.factor b/basis/cords/cords-tests.factor index 0058c8f07a..898e4e51c8 100644 --- a/basis/cords/cords-tests.factor +++ b/basis/cords/cords-tests.factor @@ -1,5 +1,5 @@ -IN: cords.tests USING: cords strings tools.test kernel sequences ; +IN: cords.tests [ "hello world" ] [ "hello" " world" cord-append dup like ] unit-test [ "hello world" ] [ { "he" "llo" " world" } cord-concat dup like ] unit-test diff --git a/basis/core-foundation/numbers/numbers-tests.factor b/basis/core-foundation/numbers/numbers-tests.factor deleted file mode 100644 index 1c50f2dcb2..0000000000 --- a/basis/core-foundation/numbers/numbers-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test core-foundation.numbers ; -IN: core-foundation.numbers.tests diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index a63a3ea674..6446eacd08 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -103,7 +103,7 @@ TUPLE: run-loop fds sources timers ; : (reset-timer) ( timer counter -- ) yield { { [ dup 0 = ] [ now ((reset-timer)) ] } - { [ run-queue deque-empty? not ] [ 1- (reset-timer) ] } + { [ run-queue deque-empty? not ] [ 1 - (reset-timer) ] } { [ sleep-queue heap-empty? ] [ 5 minutes hence ((reset-timer)) ] } [ sleep-queue heap-peek nip micros>timestamp ((reset-timer)) ] } cond ; diff --git a/basis/core-foundation/utilities/utilities-tests.factor b/basis/core-foundation/utilities/utilities-tests.factor deleted file mode 100644 index fb3deb2ca5..0000000000 --- a/basis/core-foundation/utilities/utilities-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test core-foundation.utilities ; -IN: core-foundation.utilities.tests diff --git a/basis/core-graphics/types/types-tests.factor b/basis/core-graphics/types/types-tests.factor deleted file mode 100644 index d3b081fccc..0000000000 --- a/basis/core-graphics/types/types-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test core-graphics.types ; -IN: core-graphics.types.tests diff --git a/basis/core-text/fonts/fonts-tests.factor b/basis/core-text/fonts/fonts-tests.factor deleted file mode 100644 index 45fa2bcdc0..0000000000 --- a/basis/core-text/fonts/fonts-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test core-text.fonts ; -IN: core-text.fonts.tests diff --git a/basis/core-text/utilities/utilities-tests.factor b/basis/core-text/utilities/utilities-tests.factor deleted file mode 100644 index 65914a3fcd..0000000000 --- a/basis/core-text/utilities/utilities-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test core-text.utilities ; -IN: core-text.utilities.tests diff --git a/basis/cpu/ppc/assembler/assembler-tests.factor b/basis/cpu/ppc/assembler/assembler-tests.factor index 23b1d1e6f4..6ee1c84558 100644 --- a/basis/cpu/ppc/assembler/assembler-tests.factor +++ b/basis/cpu/ppc/assembler/assembler-tests.factor @@ -1,7 +1,7 @@ -IN: cpu.ppc.assembler.tests USING: cpu.ppc.assembler tools.test arrays kernel namespaces make vocabs sequences ; FROM: cpu.ppc.assembler => B ; +IN: cpu.ppc.assembler.tests : test-assembler ( expected quot -- ) [ 1array ] [ [ B{ } make ] curry ] bi* unit-test ; diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index cbb914121e..c63372fa3f 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -226,7 +226,7 @@ CONSTANT: rs-reg 14 ! key = class 5 4 MR ! key &= cache.length - 1 - 5 5 mega-cache-size get 1- bootstrap-cell * ANDI + 5 5 mega-cache-size get 1 - bootstrap-cell * ANDI ! cache += array-start-offset 3 3 array-start-offset ADDI ! cache += key diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index eba2099399..b8e5bdbe10 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -214,7 +214,7 @@ M:: ppc %integer>bignum ( dst src temp -- ) temp dst 1 bignum@ STW ! Compute sign temp src MR - temp temp cell-bits 1- SRAWI + temp temp cell-bits 1 - SRAWI temp temp 1 ANDI ! Store sign temp dst 2 bignum@ STW diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index aeca1accce..7c832fe66c 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -131,7 +131,7 @@ M:: x86.64 %box ( n rep func -- ) M: x86.64 %box-long-long ( n func -- ) [ int-rep ] dip %box ; -: box-struct-field@ ( i -- operand ) 1+ cells param@ ; +: box-struct-field@ ( i -- operand ) 1 + cells param@ ; : %box-struct-field ( c-type i -- ) box-struct-field@ swap c-type-rep reg-class-of { diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 6363f17e48..0dafc3d9c4 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -226,7 +226,7 @@ big-endian off temp2 temp1 MOV bootstrap-cell 8 = [ temp2 1 SHL ] when ! key &= cache.length - 1 - temp2 mega-cache-size get 1- bootstrap-cell * AND + temp2 mega-cache-size get 1 - bootstrap-cell * AND ! cache += array-start-offset temp0 array-start-offset ADD ! cache += key @@ -496,7 +496,7 @@ big-endian off ! make a copy mod-arg div-arg MOV ! sign-extend - mod-arg bootstrap-cell-bits 1- SAR + mod-arg bootstrap-cell-bits 1 - SAR ! divide temp3 IDIV ; diff --git a/basis/cpu/x86/features/features-tests.factor b/basis/cpu/x86/features/features-tests.factor index 69847cacfa..680e655995 100644 --- a/basis/cpu/x86/features/features-tests.factor +++ b/basis/cpu/x86/features/features-tests.factor @@ -1,7 +1,7 @@ -IN: cpu.x86.features.tests USING: cpu.x86.features tools.test kernel sequences math system ; +IN: cpu.x86.features.tests cpu x86? [ [ t ] [ sse2? { t f } member? ] unit-test [ t ] [ [ 10000 [ ] times ] count-instructions integer? ] unit-test -] when \ No newline at end of file +] when diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index d8fa1fae7e..a6c958083c 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -162,7 +162,7 @@ M:: x86 %integer>bignum ( dst src temp -- ) dst 3 bignum@ src MOV ! Compute sign temp src MOV - temp cell-bits 1- SAR + temp cell-bits 1 - SAR temp 1 AND ! Store sign dst 2 bignum@ temp MOV diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index 9e51f41ff1..e5e8097d3f 100644 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -88,7 +88,7 @@ M: postgresql-statement query-results ( query -- result-set ) dup init-result-set ; M: postgresql-result-set advance-row ( result-set -- ) - [ 1+ ] change-n drop ; + [ 1 + ] change-n drop ; M: postgresql-result-set more-rows? ( result-set -- ? ) [ n>> ] [ max>> ] bi < ; diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index c4aa47d383..e9aa01feb4 100755 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -75,7 +75,7 @@ M: db-connection ( class -- statement ) M: random-id-generator eval-generator ( singleton -- obj ) drop system-random-generator get [ - 63 [ random-bits ] keep 1- set-bit + 63 [ random-bits ] keep 1 - set-bit ] with-random ; : interval-comparison ( ? str -- str ) diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 6bf8dd3075..7f109d80e0 100644 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -469,7 +469,7 @@ TUPLE: bignum-test id m n o ; } define-persistent [ bignum-test drop-table ] ignore-errors [ ] [ bignum-test ensure-table ] unit-test - [ ] [ 63 2^ 1- dup dup insert-tuple ] unit-test ; + [ ] [ 63 2^ 1 - dup dup insert-tuple ] unit-test ; ! sqlite only ! [ T{ bignum-test f 1 diff --git a/basis/debugger/debugger-tests.factor b/basis/debugger/debugger-tests.factor index 08f84d9335..6800c83a9c 100644 --- a/basis/debugger/debugger-tests.factor +++ b/basis/debugger/debugger-tests.factor @@ -1,7 +1,7 @@ -IN: debugger.tests USING: debugger kernel continuations tools.test ; +IN: debugger.tests [ ] [ [ drop ] [ error. ] recover ] unit-test [ f ] [ { } vm-error? ] unit-test -[ f ] [ { "A" "B" } vm-error? ] unit-test \ No newline at end of file +[ f ] [ { "A" "B" } vm-error? ] unit-test diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 6c0985ce06..ce9496291c 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -36,7 +36,7 @@ M: string error. print ; error-continuation get name>> assoc-stack ; : :res ( n -- * ) - 1- restarts get-global nth f restarts set-global restart ; + 1 - restarts get-global nth f restarts set-global restart ; : :1 ( -- * ) 1 :res ; : :2 ( -- * ) 2 :res ; @@ -44,7 +44,7 @@ M: string error. print ; : restart. ( restart n -- ) [ - 1+ dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if + 1 + dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if name>> % ] "" make print ; @@ -92,7 +92,7 @@ HOOK: signal-error. os ( obj -- ) : array-size-error. ( obj -- ) "Invalid array size: " write dup third . - "Maximum: " write fourth 1- . ; + "Maximum: " write fourth 1 - . ; : c-string-error. ( obj -- ) "Cannot convert to C string: " write third . ; diff --git a/basis/debugger/unix/unix.factor b/basis/debugger/unix/unix.factor index 212908b2fd..1eb916487c 100644 --- a/basis/debugger/unix/unix.factor +++ b/basis/debugger/unix/unix.factor @@ -13,7 +13,7 @@ CONSTANT: signal-names "SIGUSR1" "SIGUSR2" } -: signal-name ( n -- str/f ) 1- signal-names ?nth ; +: signal-name ( n -- str/f ) 1 - signal-names ?nth ; : signal-name. ( n -- ) signal-name [ " (" ")" surround write ] when* ; diff --git a/basis/definitions/icons/icons-tests.factor b/basis/definitions/icons/icons-tests.factor deleted file mode 100644 index 47e106f8ec..0000000000 --- a/basis/definitions/icons/icons-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test definitions.icons ; -IN: definitions.icons.tests diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index 9f9aca8702..d9581152e1 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -55,8 +55,8 @@ PROTOCOL: beta three ; TUPLE: hey value ; C: hey -CONSULT: alpha hey value>> 1+ ; -CONSULT: beta hey value>> 1- ; +CONSULT: alpha hey value>> 1 + ; +CONSULT: beta hey value>> 1 - ; [ 2 ] [ 1 one ] unit-test [ 2 ] [ 1 two ] unit-test diff --git a/basis/disjoint-sets/disjoint-sets-tests.factor b/basis/disjoint-sets/disjoint-sets-tests.factor index 74746f1a3a..cb9233343e 100644 --- a/basis/disjoint-sets/disjoint-sets-tests.factor +++ b/basis/disjoint-sets/disjoint-sets-tests.factor @@ -1,5 +1,5 @@ -IN: disjoint-sets.testes USING: tools.test disjoint-sets namespaces slots.private ; +IN: disjoint-sets.testes SYMBOL: +blah+ -405534154 +blah+ 1 set-slot diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor index 80ab2f58bf..05df13f073 100644 --- a/basis/disjoint-sets/disjoint-sets.factor +++ b/basis/disjoint-sets/disjoint-sets.factor @@ -30,7 +30,7 @@ TUPLE: disjoint-set ranks>> at ; inline : inc-rank ( a disjoint-set -- ) - ranks>> [ 1+ ] change-at ; inline + ranks>> [ 1 + ] change-at ; inline : representative? ( a disjoint-set -- ? ) dupd parent = ; inline diff --git a/basis/documents/documents-tests.factor b/basis/documents/documents-tests.factor index 9f7f25c56e..41d93c889e 100644 --- a/basis/documents/documents-tests.factor +++ b/basis/documents/documents-tests.factor @@ -1,6 +1,6 @@ -IN: documents.tests USING: documents documents.private accessors sequences namespaces tools.test make arrays kernel fry ; +IN: documents.tests ! Tests diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor index cc2466053b..b05c86c365 100644 --- a/basis/documents/documents.factor +++ b/basis/documents/documents.factor @@ -45,7 +45,7 @@ TUPLE: document < model locs undos redos inside-undo? ; [ drop ] [ doc-line length ] 2bi 2array ; : doc-lines ( from to document -- slice ) - [ 1+ ] [ value>> ] bi* ; + [ 1 + ] [ value>> ] bi* ; : start-on-line ( from line# document -- n1 ) drop over first = @@ -67,7 +67,7 @@ TUPLE: document < model locs undos redos inside-undo? ; [ start-on-line ] [ end-on-line ] bi-curry bi-curry bi* ; : last-line# ( document -- line ) - value>> length 1- ; + value>> length 1 - ; CONSTANT: doc-start { 0 0 } @@ -84,7 +84,7 @@ CONSTANT: doc-start { 0 0 } over length 1 = [ nip first2 ] [ - first swap length 1- + 0 + first swap length 1 - + 0 ] if ] dip last length + 2array ; @@ -92,7 +92,7 @@ CONSTANT: doc-start { 0 0 } 0 swap [ append ] change-nth ; : append-last ( str seq -- ) - [ length 1- ] keep [ prepend ] change-nth ; + [ length 1 - ] keep [ prepend ] change-nth ; : loc-col/str ( loc document -- str col ) [ first2 swap ] dip nth swap ; @@ -103,7 +103,7 @@ CONSTANT: doc-start { 0 0 } : (set-doc-range) ( doc-lines from to lines -- changed-lines ) [ prepare-insert ] 3keep - [ [ first ] bi@ 1+ ] dip + [ [ first ] bi@ 1 + ] dip replace-slice ; : entire-doc ( document -- start end document ) diff --git a/basis/documents/elements/elements.factor b/basis/documents/elements/elements.factor index 0776f8f158..7ba3cb8a6e 100644 --- a/basis/documents/elements/elements.factor +++ b/basis/documents/elements/elements.factor @@ -23,14 +23,14 @@ SINGLETON: char-elt : prev ( loc document quot: ( loc document -- loc ) -- loc ) { { [ pick { 0 0 } = ] [ 2drop ] } - { [ pick second zero? ] [ drop [ first 1- ] dip line-end ] } + { [ pick second zero? ] [ drop [ first 1 - ] dip line-end ] } [ call ] } cond ; inline : next ( loc document quot: ( loc document -- loc ) -- loc ) { { [ 2over doc-end = ] [ 2drop ] } - { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] } + { [ 2over line-end? ] [ 2drop first 1 + 0 2array ] } [ call ] } cond ; inline @@ -73,7 +73,7 @@ SINGLETON: one-word-elt M: one-word-elt prev-elt drop - [ [ 1- ] dip f prev-word ] modify-col ; + [ [ 1 - ] dip f prev-word ] modify-col ; M: one-word-elt next-elt drop @@ -90,7 +90,7 @@ SINGLETON: word-elt M: word-elt prev-elt drop - [ [ [ 1- ] dip blank-at? prev-word ] modify-col ] + [ [ [ 1 - ] dip blank-at? prev-word ] modify-col ] prev ; M: word-elt next-elt diff --git a/basis/editors/macvim/macvim.factor b/basis/editors/macvim/macvim.factor index c178207e49..6dcf724e8e 100644 --- a/basis/editors/macvim/macvim.factor +++ b/basis/editors/macvim/macvim.factor @@ -1,6 +1,5 @@ USING: definitions io.launcher kernel math math.parser parser namespaces prettyprint editors make ; - IN: editors.macvim : macvim ( file line -- ) diff --git a/basis/eval/eval-tests.factor b/basis/eval/eval-tests.factor index d27e661193..09c7533b28 100644 --- a/basis/eval/eval-tests.factor +++ b/basis/eval/eval-tests.factor @@ -1,5 +1,5 @@ -IN: eval.tests USING: eval tools.test ; +IN: eval.tests [ 4 ] [ "USE: math 2 2 +" eval( -- result ) ] unit-test [ "USE: math 2 2 +" eval( -- ) ] must-fail diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index 4acd1eeab8..2a1ac85de0 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -50,7 +50,7 @@ DEFER: (parse-paragraph) parse-paragraph paragraph boa ; : cut-half-slice ( string i -- before after-slice ) - [ head ] [ 1+ short tail-slice ] 2bi ; + [ head ] [ 1 + short tail-slice ] 2bi ; : find-cut ( string quot -- before after delimiter ) dupd find diff --git a/basis/formatting/formatting-tests.factor b/basis/formatting/formatting-tests.factor index c56372f023..5710ceb985 100644 --- a/basis/formatting/formatting-tests.factor +++ b/basis/formatting/formatting-tests.factor @@ -1,8 +1,6 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license - USING: calendar kernel formatting tools.test ; - IN: formatting.tests [ "%s" printf ] must-infer diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index f8b9ba501b..40279749d6 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -1,11 +1,9 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license - USING: accessors arrays assocs calendar combinators fry kernel generalizations io io.streams.string macros math math.functions math.parser peg.ebnf quotations sequences splitting strings unicode.categories unicode.case vectors combinators.smart ; - IN: formatting exp ( x -- exp base ) [ abs 0 swap [ dup [ 10.0 >= ] [ 1.0 < ] bi or ] [ dup 10.0 >= - [ 10.0 / [ 1+ ] dip ] - [ 10.0 * [ 1- ] dip ] if + [ 10.0 / [ 1 + ] dip ] + [ 10.0 * [ 1 - ] dip ] if ] while ] keep 0 < [ neg ] when ; @@ -140,7 +138,7 @@ MACRO: printf ( format-string -- ) : (week-of-year) ( timestamp day -- n ) [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when - [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ; + [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1 + >fixnum ] if ; : week-of-year-sunday ( timestamp -- n ) 0 (week-of-year) ; inline diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor index 88ecae66ad..549db25e09 100644 --- a/basis/fry/fry-tests.factor +++ b/basis/fry/fry-tests.factor @@ -1,6 +1,6 @@ -IN: fry.tests USING: fry tools.test math prettyprint kernel io arrays sequences eval accessors ; +IN: fry.tests [ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor index d50fd9442b..fd029cc329 100644 --- a/basis/fry/fry.factor +++ b/basis/fry/fry.factor @@ -26,7 +26,7 @@ M: >r/r>-in-fry-error summary : check-fry ( quot -- quot ) dup { load-local load-locals get-local drop-locals } intersect - empty? [ >r/r>-in-fry-error ] unless ; + [ >r/r>-in-fry-error ] unless-empty ; PREDICATE: fry-specifier < word { _ @ } memq? ; @@ -42,7 +42,7 @@ GENERIC: deep-fry ( obj -- ) check-fry [ [ deep-fry ] each ] [ ] make [ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat - { _ } split [ spread>quot ] [ length 1- ] bi ; + { _ } split [ spread>quot ] [ length 1 - ] bi ; PRIVATE> diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index 03bd21e58c..a21313312b 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -1,6 +1,6 @@ -IN: functors.tests USING: functors tools.test math words kernel multiline parser io.streams.string generic ; +IN: functors.tests << diff --git a/basis/furnace/auth/auth-tests.factor b/basis/furnace/auth/auth-tests.factor deleted file mode 100644 index 54c32e7b4a..0000000000 --- a/basis/furnace/auth/auth-tests.factor +++ /dev/null @@ -1,3 +0,0 @@ -USING: furnace.auth tools.test ; -IN: furnace.auth.tests - diff --git a/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor b/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor deleted file mode 100644 index 996047e83d..0000000000 --- a/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: furnace.auth.features.edit-profile.tests -USING: tools.test furnace.auth.features.edit-profile ; - - diff --git a/basis/furnace/auth/features/recover-password/recover-password-tests.factor b/basis/furnace/auth/features/recover-password/recover-password-tests.factor deleted file mode 100644 index 313b8ef397..0000000000 --- a/basis/furnace/auth/features/recover-password/recover-password-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: furnace.auth.features.recover-password -USING: tools.test furnace.auth.features.recover-password ; - - diff --git a/basis/furnace/auth/features/registration/registration-tests.factor b/basis/furnace/auth/features/registration/registration-tests.factor deleted file mode 100644 index 42acda416c..0000000000 --- a/basis/furnace/auth/features/registration/registration-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: furnace.auth.features.registration.tests -USING: tools.test furnace.auth.features.registration ; - - diff --git a/basis/furnace/auth/login/login-tests.factor b/basis/furnace/auth/login/login-tests.factor deleted file mode 100644 index aabd0c5c30..0000000000 --- a/basis/furnace/auth/login/login-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: furnace.auth.login.tests -USING: tools.test furnace.auth.login ; - - diff --git a/basis/furnace/auth/login/permits/permits.factor b/basis/furnace/auth/login/permits/permits.factor index 1a9784f147..c6a037cea1 100644 --- a/basis/furnace/auth/login/permits/permits.factor +++ b/basis/furnace/auth/login/permits/permits.factor @@ -1,6 +1,5 @@ USING: accessors namespaces kernel combinators.short-circuit db.tuples db.types furnace.auth furnace.sessions furnace.cache ; - IN: furnace.auth.login.permits TUPLE: permit < server-state session uid ; diff --git a/basis/furnace/auth/providers/assoc/assoc-tests.factor b/basis/furnace/auth/providers/assoc/assoc-tests.factor index 8fe1dd4dd4..44a20e7ae3 100644 --- a/basis/furnace/auth/providers/assoc/assoc-tests.factor +++ b/basis/furnace/auth/providers/assoc/assoc-tests.factor @@ -1,7 +1,7 @@ -IN: furnace.auth.providers.assoc.tests USING: furnace.actions furnace.auth furnace.auth.providers furnace.auth.providers.assoc furnace.auth.login tools.test namespaces accessors kernel ; +IN: furnace.auth.providers.assoc.tests "Test" >>users diff --git a/basis/furnace/auth/providers/assoc/assoc.factor b/basis/furnace/auth/providers/assoc/assoc.factor index f5a79d701b..a7a48307c9 100644 --- a/basis/furnace/auth/providers/assoc/assoc.factor +++ b/basis/furnace/auth/providers/assoc/assoc.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: furnace.auth.providers.assoc USING: accessors assocs kernel furnace.auth.providers ; +IN: furnace.auth.providers.assoc TUPLE: users-in-memory assoc ; diff --git a/basis/furnace/auth/providers/db/db-tests.factor b/basis/furnace/auth/providers/db/db-tests.factor index de7650d9ef..f23a4a8527 100644 --- a/basis/furnace/auth/providers/db/db-tests.factor +++ b/basis/furnace/auth/providers/db/db-tests.factor @@ -1,4 +1,3 @@ -IN: furnace.auth.providers.db.tests USING: furnace.actions furnace.auth furnace.auth.login @@ -6,6 +5,7 @@ furnace.auth.providers furnace.auth.providers.db tools.test namespaces db db.sqlite db.tuples continuations io.files io.files.temp io.directories accessors kernel ; +IN: furnace.auth.providers.db.tests "test" realm set diff --git a/basis/furnace/db/db-tests.factor b/basis/furnace/db/db-tests.factor deleted file mode 100644 index 15698d8e9b..0000000000 --- a/basis/furnace/db/db-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: furnace.db.tests -USING: tools.test furnace.db ; - - diff --git a/basis/furnace/furnace-tests.factor b/basis/furnace/furnace-tests.factor index 1d5aa43c7b..6fe2633031 100644 --- a/basis/furnace/furnace-tests.factor +++ b/basis/furnace/furnace-tests.factor @@ -1,7 +1,8 @@ -IN: furnace.tests USING: http http.server.dispatchers http.server.responses http.server furnace furnace.utilities tools.test kernel namespaces accessors io.streams.string urls xml.writer ; +IN: furnace.tests + TUPLE: funny-dispatcher < dispatcher ; : ( -- dispatcher ) funny-dispatcher new-dispatcher ; diff --git a/basis/furnace/sessions/sessions-tests.factor b/basis/furnace/sessions/sessions-tests.factor index 392d43e89b..49311ee891 100644 --- a/basis/furnace/sessions/sessions-tests.factor +++ b/basis/furnace/sessions/sessions-tests.factor @@ -1,10 +1,10 @@ -IN: furnace.sessions.tests USING: tools.test http furnace.sessions furnace.actions http.server http.server.responses math namespaces make kernel accessors io.sockets io.servers.connection prettyprint io.streams.string io.files io.files.temp io.directories splitting destructors sequences db db.tuples db.sqlite continuations urls math.parser furnace furnace.utilities ; +IN: furnace.sessions.tests : with-session ( session quot -- ) [ @@ -19,7 +19,7 @@ M: foo init-session* drop 0 "x" sset ; M: foo call-responder* 2drop - "x" [ 1+ ] schange + "x" [ 1 + ] schange "x" sget number>string "text/html" ; : url-responder-mock-test ( -- string ) @@ -73,7 +73,7 @@ M: foo call-responder* [ 9 ] [ "x" sget sq ] unit-test - [ ] [ "x" [ 1- ] schange ] unit-test + [ ] [ "x" [ 1 - ] schange ] unit-test [ 4 ] [ "x" sget sq ] unit-test diff --git a/basis/game-input/game-input-tests.factor b/basis/game-input/game-input-tests.factor index 3cce0da575..10f3b5d7f5 100644 --- a/basis/game-input/game-input-tests.factor +++ b/basis/game-input/game-input-tests.factor @@ -1,8 +1,9 @@ +USING: ui game-input tools.test kernel system threads calendar +combinators.short-circuit ; IN: game-input.tests -USING: ui game-input tools.test kernel system threads calendar ; -os windows? os macosx? or [ +os { [ windows? ] [ macosx? ] } 1|| [ [ ] [ open-game-input ] unit-test [ ] [ 1 seconds sleep ] unit-test [ ] [ close-game-input ] unit-test -] when \ No newline at end of file +] when diff --git a/basis/game-input/game-input.factor b/basis/game-input/game-input.factor index 922906df48..c21b900d8c 100755 --- a/basis/game-input/game-input.factor +++ b/basis/game-input/game-input.factor @@ -45,12 +45,12 @@ ERROR: game-input-not-open ; game-input-opened? [ (open-game-input) ] unless - game-input-opened [ 1+ ] change-global + game-input-opened [ 1 + ] change-global reset-mouse ; : close-game-input ( -- ) game-input-opened [ dup zero? [ game-input-not-open ] when - 1- + 1 - ] change-global game-input-opened? [ (close-game-input) diff --git a/basis/game-input/iokit/iokit.factor b/basis/game-input/iokit/iokit.factor index 92c0c7173a..71d547ad29 100755 --- a/basis/game-input/iokit/iokit.factor +++ b/basis/game-input/iokit/iokit.factor @@ -153,7 +153,7 @@ CONSTANT: pov-values IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ; : record-button ( state hid-value element -- ) - [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ; + [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1 - ] tri* rot set-nth ; : record-controller ( controller-state value -- ) dup IOHIDValueGetElement { diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index abcbd54cab..e7b3ee8252 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -24,20 +24,20 @@ MACRO: narray ( n -- ) '[ _ { } nsequence ] ; MACRO: nsum ( n -- ) - 1- [ + ] n*quot ; + 1 - [ + ] n*quot ; MACRO: firstn-unsafe ( n -- ) [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ; MACRO: firstn ( n -- ) dup zero? [ drop [ drop ] ] [ - [ 1- swap bounds-check 2drop ] + [ 1 - swap bounds-check 2drop ] [ firstn-unsafe ] bi-curry '[ _ _ bi ] ] if ; MACRO: npick ( n -- ) - 1- [ dup ] [ '[ _ dip swap ] ] repeat ; + 1 - [ dup ] [ '[ _ dip swap ] ] repeat ; MACRO: nover ( n -- ) dup 1 + '[ _ npick ] n*quot ; @@ -46,10 +46,10 @@ MACRO: ndup ( n -- ) dup '[ _ npick ] n*quot ; MACRO: nrot ( n -- ) - 1- [ ] [ '[ _ dip swap ] ] repeat ; + 1 - [ ] [ '[ _ dip swap ] ] repeat ; MACRO: -nrot ( n -- ) - 1- [ ] [ '[ swap _ dip ] ] repeat ; + 1 - [ ] [ '[ swap _ dip ] ] repeat ; MACRO: ndrop ( n -- ) [ drop ] n*quot ; @@ -91,7 +91,7 @@ MACRO: napply ( quot n -- ) swap spread>quot ; MACRO: mnswap ( m n -- ) - 1+ '[ _ -nrot ] swap '[ _ _ napply ] ; + 1 + '[ _ -nrot ] swap '[ _ _ napply ] ; MACRO: nweave ( n -- ) [ dup [ '[ _ _ mnswap ] ] with map ] keep diff --git a/basis/globs/globs-tests.factor b/basis/globs/globs-tests.factor index 45eb27ea62..bdc0623d54 100644 --- a/basis/globs/globs-tests.factor +++ b/basis/globs/globs-tests.factor @@ -1,5 +1,5 @@ -IN: globs.tests USING: tools.test globs ; +IN: globs.tests [ f ] [ "abd" "fdf" glob-matches? ] unit-test [ f ] [ "fdsafas" "?" glob-matches? ] unit-test diff --git a/basis/grouping/grouping.factor b/basis/grouping/grouping.factor index ec13e3a750..83579d2beb 100644 --- a/basis/grouping/grouping.factor +++ b/basis/grouping/grouping.factor @@ -18,41 +18,41 @@ GENERIC: group@ ( n groups -- from to seq ) M: chunking-seq set-nth group@ 0 swap copy ; -M: chunking-seq like drop { } like ; +M: chunking-seq like drop { } like ; inline INSTANCE: chunking-seq sequence MIXIN: subseq-chunking -M: subseq-chunking nth group@ subseq ; +M: subseq-chunking nth group@ subseq ; inline MIXIN: slice-chunking -M: slice-chunking nth group@ ; +M: slice-chunking nth group@ ; inline -M: slice-chunking nth-unsafe group@ slice boa ; +M: slice-chunking nth-unsafe group@ slice boa ; inline TUPLE: abstract-groups < chunking-seq ; M: abstract-groups length - [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ; + [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; inline M: abstract-groups set-length - [ n>> * ] [ seq>> ] bi set-length ; + [ n>> * ] [ seq>> ] bi set-length ; inline M: abstract-groups group@ - [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ; + [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ; inline TUPLE: abstract-clumps < chunking-seq ; M: abstract-clumps length - [ seq>> length ] [ n>> ] bi - 1+ ; + [ seq>> length ] [ n>> ] bi - 1 + ; inline M: abstract-clumps set-length - [ n>> + 1- ] [ seq>> ] bi set-length ; + [ n>> + 1 - ] [ seq>> ] bi set-length ; inline M: abstract-clumps group@ - [ n>> over + ] [ seq>> ] bi ; + [ n>> over + ] [ seq>> ] bi ; inline PRIVATE> @@ -100,4 +100,4 @@ INSTANCE: sliced-clumps slice-chunking : all-equal? ( seq -- ? ) [ = ] monotonic? ; -: all-eq? ( seq -- ? ) [ eq? ] monotonic? ; \ No newline at end of file +: all-eq? ( seq -- ? ) [ eq? ] monotonic? ; diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index 32ed10d8f2..677daca69d 100644 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -46,7 +46,7 @@ M: heap heap-size ( heap -- n ) : right ( n -- m ) 1 shift 2 + ; inline -: up ( n -- m ) 1- 2/ ; inline +: up ( n -- m ) 1 - 2/ ; inline : data-nth ( n heap -- entry ) data>> nth-unsafe ; inline @@ -164,7 +164,7 @@ M: bad-heap-delete summary M: heap heap-delete ( entry heap -- ) [ entry>index ] keep - 2dup heap-size 1- = [ + 2dup heap-size 1 - = [ nip data-pop* ] [ [ nip data-pop ] 2keep diff --git a/basis/help/apropos/apropos-tests.factor b/basis/help/apropos/apropos-tests.factor index 3dbda475de..6fa4217522 100644 --- a/basis/help/apropos/apropos-tests.factor +++ b/basis/help/apropos/apropos-tests.factor @@ -1,4 +1,4 @@ -IN: help.apropos.tests USING: help.apropos tools.test ; +IN: help.apropos.tests [ ] [ "swp" apropos ] unit-test diff --git a/basis/help/crossref/crossref-tests.factor b/basis/help/crossref/crossref-tests.factor index 95d4612cbe..4022d3bd38 100644 --- a/basis/help/crossref/crossref-tests.factor +++ b/basis/help/crossref/crossref-tests.factor @@ -1,7 +1,7 @@ -IN: help.crossref.tests USING: help.crossref help.topics help.markup tools.test words definitions assocs sequences kernel namespaces parser arrays io.streams.string continuations debugger compiler.units eval ; +IN: help.crossref.tests [ ] [ "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval( -- ) diff --git a/basis/help/handbook/handbook-tests.factor b/basis/help/handbook/handbook-tests.factor index 240ce67240..709d56c5d6 100644 --- a/basis/help/handbook/handbook-tests.factor +++ b/basis/help/handbook/handbook-tests.factor @@ -1,5 +1,5 @@ -IN: help.handbook.tests USING: help tools.test ; +IN: help.handbook.tests [ ] [ "article-index" print-topic ] unit-test [ ] [ "primitive-index" print-topic ] unit-test diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index a18dcd03f7..1c63360025 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -288,6 +288,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools" { $subsection "prettyprint" } { $subsection "inspector" } { $subsection "tools.annotations" } +{ $subsection "tools.deprecation" } { $subsection "tools.inference" } { $heading "Browsing" } { $subsection "see" } diff --git a/basis/help/help-tests.factor b/basis/help/help-tests.factor index e091278359..d8c5a32f3d 100644 --- a/basis/help/help-tests.factor +++ b/basis/help/help-tests.factor @@ -1,6 +1,6 @@ -IN: help.tests USING: tools.test help kernel ; +IN: help.tests [ 3 throw ] must-fail [ ] [ :help ] unit-test -[ ] [ f print-topic ] unit-test \ No newline at end of file +[ ] [ f print-topic ] unit-test diff --git a/basis/help/html/html-tests.factor b/basis/help/html/html-tests.factor index 3ba336be0b..90ff6c110f 100644 --- a/basis/help/html/html-tests.factor +++ b/basis/help/html/html-tests.factor @@ -1,6 +1,6 @@ -IN: help.html.tests USING: help.html tools.test help.topics kernel ; +IN: help.html.tests [ ] [ "xml" >link help>html drop ] unit-test -[ "article-foobar.html" ] [ "foobar" >link topic>filename ] unit-test \ No newline at end of file +[ "article-foobar.html" ] [ "foobar" >link topic>filename ] unit-test diff --git a/basis/help/vocabs/vocabs-tests.factor b/basis/help/vocabs/vocabs-tests.factor index f03e0b3337..5637dd92f4 100644 --- a/basis/help/vocabs/vocabs-tests.factor +++ b/basis/help/vocabs/vocabs-tests.factor @@ -1,5 +1,5 @@ -IN: help.vocabs.tests USING: help.vocabs tools.test help.markup help vocabs ; +IN: help.vocabs.tests [ ] [ { $vocab "scratchpad" } print-content ] unit-test -[ ] [ "classes" vocab print-topic ] unit-test \ No newline at end of file +[ ] [ "classes" vocab print-topic ] unit-test diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 6b7a6ae8ca..08d794090c 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -71,7 +71,8 @@ t specialize-method? set-global SYNTAX: HINTS: scan-object dup wrapper? [ wrapped>> ] when [ changed-definition ] - [ parse-definition { } like "specializer" set-word-prop ] bi ; + [ subwords [ changed-definition ] each ] + [ parse-definition { } like "specializer" set-word-prop ] tri ; ! Default specializers { first first2 first3 first4 } diff --git a/basis/html/components/components-tests.factor b/basis/html/components/components-tests.factor index c901e35e3e..d1d43c762c 100644 --- a/basis/html/components/components-tests.factor +++ b/basis/html/components/components-tests.factor @@ -1,9 +1,9 @@ -IN: html.components.tests USING: tools.test kernel io.streams.string io.streams.null accessors inspector html.streams html.components html.forms namespaces xml.writer ; FROM: html.components => inspector ; +IN: html.components.tests [ ] [ begin-form ] unit-test diff --git a/basis/html/forms/forms-tests.factor b/basis/html/forms/forms-tests.factor index 006a435cf0..b1596e9aa6 100644 --- a/basis/html/forms/forms-tests.factor +++ b/basis/html/forms/forms-tests.factor @@ -1,7 +1,7 @@ -IN: html.forms.tests USING: kernel sequences tools.test assocs html.forms validators accessors namespaces ; FROM: html.forms => values ; +IN: html.forms.tests : with-validation ( quot -- messages ) [ diff --git a/basis/html/forms/forms.factor b/basis/html/forms/forms.factor index cc8b4f0a15..5cf318bcaf 100644 --- a/basis/html/forms/forms.factor +++ b/basis/html/forms/forms.factor @@ -44,7 +44,7 @@ M: form clone [ value ] dip '[ [ form [ clone ] change - 1+ "index" set-value + 1 + "index" set-value "value" set-value @ ] with-scope @@ -54,7 +54,7 @@ M: form clone [ value ] dip '[ [ begin-form - 1+ "index" set-value + 1 + "index" set-value from-object @ ] with-scope diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index ceb2e72478..a98a21f177 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -17,7 +17,7 @@ TUPLE: template-lexer < lexer ; M: template-lexer skip-word [ { - { [ 2dup nth CHAR: " = ] [ drop 1+ ] } + { [ 2dup nth CHAR: " = ] [ drop 1 + ] } { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] } [ f skip ] } cond diff --git a/basis/http/client/client-tests.factor b/basis/http/client/client-tests.factor index c391b417a9..7a7fcffc74 100644 --- a/basis/http/client/client-tests.factor +++ b/basis/http/client/client-tests.factor @@ -1,5 +1,6 @@ USING: http.client http.client.private http tools.test namespaces urls ; +IN: http.client.tests [ "localhost" f ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test diff --git a/basis/http/client/post-data/post-data-tests.factor b/basis/http/client/post-data/post-data-tests.factor deleted file mode 100644 index 2704ce169f..0000000000 --- a/basis/http/client/post-data/post-data-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test http.client.post-data ; -IN: http.client.post-data.tests diff --git a/basis/http/parsers/parsers-tests.factor b/basis/http/parsers/parsers-tests.factor index f87ed47f00..f8c3b836a6 100644 --- a/basis/http/parsers/parsers-tests.factor +++ b/basis/http/parsers/parsers-tests.factor @@ -1,5 +1,5 @@ -IN: http.parsers.tests USING: http http.parsers tools.test ; +IN: http.parsers.tests [ { } ] [ "" parse-cookie ] unit-test [ { } ] [ "" parse-set-cookie ] unit-test @@ -13,4 +13,4 @@ unit-test [ { T{ cookie { name "__s" } { value "12345567" } } } ] [ "__s=12345567;" parse-cookie ] -unit-test \ No newline at end of file +unit-test diff --git a/basis/http/server/redirection/redirection-tests.factor b/basis/http/server/redirection/redirection-tests.factor index 72ff111db9..d502de75b0 100644 --- a/basis/http/server/redirection/redirection-tests.factor +++ b/basis/http/server/redirection/redirection-tests.factor @@ -1,6 +1,6 @@ -IN: http.server.redirection.tests USING: http http.server.redirection urls accessors namespaces tools.test present kernel ; +IN: http.server.redirection.tests [ diff --git a/basis/http/server/static/static-tests.factor b/basis/http/server/static/static-tests.factor index d54be03698..185b0eb361 100644 --- a/basis/http/server/static/static-tests.factor +++ b/basis/http/server/static/static-tests.factor @@ -1,4 +1,4 @@ -IN: http.server.static.tests USING: http.server.static tools.test xml.writer ; +IN: http.server.static.tests -[ ] [ "resource:basis" directory>html write-xml ] unit-test \ No newline at end of file +[ ] [ "resource:basis" directory>html write-xml ] unit-test diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index ca3ea8d2b4..ec7a70b656 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -229,8 +229,8 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; ] with each^2 ; : sign-extend ( bits v -- v' ) - swap [ ] [ 1- 2^ < ] 2bi - [ -1 swap shift 1+ + ] [ drop ] if ; + swap [ ] [ 1 - 2^ < ] 2bi + [ -1 swap shift 1 + + ] [ drop ] if ; : read1-jpeg-dc ( decoder -- dc ) [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ; @@ -245,7 +245,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; 0 :> k! [ color ac-huff-table>> read1-jpeg-ac - [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri + [ first 1 + k + k! ] [ second k coefs set-nth ] [ ] tri { 0 0 } = not k 63 < and ] loop diff --git a/basis/interval-maps/interval-maps.factor b/basis/interval-maps/interval-maps.factor index b94266282c..e9130a3c40 100644 --- a/basis/interval-maps/interval-maps.factor +++ b/basis/interval-maps/interval-maps.factor @@ -58,7 +58,7 @@ PRIVATE> [ alist sort-keys unclip swap [ [ first dup ] [ second ] bi ] dip [| oldkey oldval key val | ! Underneath is start - oldkey 1+ key = + oldkey 1 + key = oldval val = and [ oldkey 2array oldval 2array , key ] unless key val diff --git a/basis/inverse/inverse-tests.factor b/basis/inverse/inverse-tests.factor index 51ab6f27d9..571957cf4c 100644 --- a/basis/inverse/inverse-tests.factor +++ b/basis/inverse/inverse-tests.factor @@ -21,7 +21,7 @@ C: foo : something ( array -- num ) { - { [ dup 1+ 2array ] [ 3 * ] } + { [ dup 1 + 2array ] [ 3 * ] } { [ 3array ] [ + + ] } } switch ; @@ -92,5 +92,5 @@ TUPLE: funny-tuple ; [ ] [ [ ] [undo] drop ] unit-test -[ 0 ] [ { 1 2 } [ [ 1+ 2 ] { } output>sequence ] undo ] unit-test -[ { 0 1 } ] [ 1 2 [ [ [ 1+ ] bi@ ] inputsequence ] undo ] unit-test +[ { 0 1 } ] [ 1 2 [ [ [ 1 + ] bi@ ] inputmap recover-chain ; -MACRO: switch ( quot-alist -- ) [switch] ; \ No newline at end of file +MACRO: switch ( quot-alist -- ) [switch] ; diff --git a/basis/io/backend/unix/multiplexers/select/select.factor b/basis/io/backend/unix/multiplexers/select/select.factor index 7d0acb4140..8022ed34e2 100644 --- a/basis/io/backend/unix/multiplexers/select/select.factor +++ b/basis/io/backend/unix/multiplexers/select/select.factor @@ -40,7 +40,7 @@ TUPLE: select-mx < mx read-fdset write-fdset ; dup assoc-empty? [ drop 0 ] [ keys supremum ] if ; : num-fds ( mx -- n ) - [ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ; + [ reads>> max-fd ] [ writes>> max-fd ] bi max 1 + ; : init-fdsets ( mx -- nfds read write except ) [ num-fds ] diff --git a/basis/io/backend/windows/privileges/privileges-tests.factor b/basis/io/backend/windows/privileges/privileges-tests.factor index 7237651b80..a66b2aad7a 100755 --- a/basis/io/backend/windows/privileges/privileges-tests.factor +++ b/basis/io/backend/windows/privileges/privileges-tests.factor @@ -1,4 +1,4 @@ -IN: io.backend.windows.privileges.tests USING: io.backend.windows.privileges tools.test ; +IN: io.backend.windows.privileges.tests [ [ ] with-privileges ] must-infer diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor index 2e9aac2ac9..fde5cf9b12 100755 --- a/basis/io/backend/windows/windows.factor +++ b/basis/io/backend/windows/windows.factor @@ -4,23 +4,36 @@ USING: alien alien.c-types arrays destructors io io.backend io.buffers io.files io.ports io.binary io.timeouts system strings kernel math namespaces sequences windows.errors windows.kernel32 windows.shell32 windows.types windows.winsock -splitting continuations math.bitwise accessors ; +splitting continuations math.bitwise accessors init sets assocs ; IN: io.backend.windows +: win32-handles ( -- assoc ) + \ win32-handles [ H{ } clone ] initialize-alien ; + +TUPLE: win32-handle < identity-tuple handle disposed ; + +M: win32-handle hashcode* handle>> hashcode* ; + : set-inherit ( handle ? -- ) - [ HANDLE_FLAG_INHERIT ] dip + [ handle>> HANDLE_FLAG_INHERIT ] dip >BOOLEAN SetHandleInformation win32-error=0/f ; -TUPLE: win32-handle handle disposed ; - : new-win32-handle ( handle class -- win32-handle ) - new swap [ >>handle ] [ f set-inherit ] bi ; + new swap >>handle + dup f set-inherit + dup win32-handles conjoin ; : ( handle -- win32-handle ) win32-handle new-win32-handle ; +ERROR: disposing-twice ; + +: unregister-handle ( handle -- ) + win32-handles delete-at* + [ t >>disposed drop ] [ disposing-twice ] if ; + M: win32-handle dispose* ( handle -- ) - handle>> CloseHandle drop ; + [ unregister-handle ] [ handle>> CloseHandle win32-error=0/f ] bi ; TUPLE: win32-file < win32-handle ptr ; diff --git a/basis/io/encodings/ascii/ascii.factor b/basis/io/encodings/ascii/ascii.factor index 1654cb8b83..00d3bc7509 100644 --- a/basis/io/encodings/ascii/ascii.factor +++ b/basis/io/encodings/ascii/ascii.factor @@ -5,7 +5,7 @@ IN: io.encodings.ascii SINGLETON: ascii M: ascii encode-char - 128 encode-if< ; + 128 encode-if< ; inline M: ascii decode-char - 128 decode-if< ; \ No newline at end of file + 128 decode-if< ; inline diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index 81e43f8dd9..38165e4267 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -9,11 +9,11 @@ calendar ascii combinators.short-circuit locals ; IN: io.files.info.windows :: round-up-to ( n multiple -- n' ) - n multiple rem dup 0 = [ - drop n + n multiple rem [ + n ] [ multiple swap - n + - ] if ; + ] if-zero ; TUPLE: windows-file-info < file-info attributes ; @@ -109,11 +109,11 @@ M: windows link-info ( path -- info ) file-info ; : volume-information ( normalized-path -- volume-name volume-serial max-component flags type ) - MAX_PATH 1+ [ ] keep + MAX_PATH 1 + [ ] keep "DWORD" "DWORD" "DWORD" - MAX_PATH 1+ [ ] keep + MAX_PATH 1 + [ ] keep [ GetVolumeInformation win32-error=0/f ] 7 nkeep drop 5 nrot drop [ utf16n alien>string ] 4 ndip @@ -165,13 +165,13 @@ M: winnt file-system-info ( path -- file-system-info ) ] if ; : find-first-volume ( -- string handle ) - MAX_PATH 1+ [ ] keep + MAX_PATH 1 + [ ] keep dupd FindFirstVolume dup win32-error=0/f [ utf16n alien>string ] dip ; : find-next-volume ( handle -- string/f ) - MAX_PATH 1+ [ tuck ] keep + MAX_PATH 1 + [ tuck ] keep FindNextVolume 0 = [ GetLastError ERROR_NO_MORE_FILES = [ drop f ] [ win32-error-string throw ] if diff --git a/basis/io/files/links/links.factor b/basis/io/files/links/links.factor index 7aec916c72..38bcc86cc6 100644 --- a/basis/io/files/links/links.factor +++ b/basis/io/files/links/links.factor @@ -28,7 +28,7 @@ ERROR: too-many-symlinks path n ; : (follow-links) ( n path -- path' ) over 0 = [ symlink-depth get too-many-symlinks ] when dup link-info type>> +symbolic-link+ = - [ [ 1- ] [ follow-link ] bi* (follow-links) ] + [ [ 1 - ] [ follow-link ] bi* (follow-links) ] [ nip ] if ; inline recursive PRIVATE> diff --git a/basis/io/files/links/unix/unix-tests.factor b/basis/io/files/links/unix/unix-tests.factor index dd5eb5c8d9..ef7d778abe 100644 --- a/basis/io/files/links/unix/unix-tests.factor +++ b/basis/io/files/links/unix/unix-tests.factor @@ -4,7 +4,7 @@ io.pathnames namespaces ; IN: io.files.links.unix.tests : make-test-links ( n path -- ) - [ '[ [ 1+ ] keep [ number>string _ prepend ] bi@ make-link ] each ] + [ '[ [ 1 + ] keep [ number>string _ prepend ] bi@ make-link ] each ] [ [ number>string ] dip prepend touch-file ] 2bi ; inline [ t ] [ diff --git a/basis/io/files/windows/windows.factor b/basis/io/files/windows/windows.factor index 444ba98c7d..43463bd3f1 100755 --- a/basis/io/files/windows/windows.factor +++ b/basis/io/files/windows/windows.factor @@ -47,10 +47,8 @@ IN: io.files.windows GetLastError ERROR_ALREADY_EXISTS = not ; : set-file-pointer ( handle length method -- ) - [ dupd d>w/w ] dip SetFilePointer - INVALID_SET_FILE_POINTER = [ - CloseHandle "SetFilePointer failed" throw - ] when drop ; + [ [ handle>> ] dip d>w/w ] dip SetFilePointer + INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ; HOOK: open-append os ( path -- win32-file ) diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor index 4587556e0c..f57f7b6d47 100755 --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -164,4 +164,19 @@ IN: io.launcher.windows.nt.tests "append-test" temp-file ascii file-contents ] unit-test +[ "( scratchpad ) " ] [ + console-vm "-run=listener" 2array + ascii [ "USE: system 0 exit" print flush readln ] with-process-stream +] unit-test +[ ] [ + console-vm "-run=listener" 2array + ascii [ "USE: system 0 exit" print ] with-process-writer +] unit-test + +[ ] [ + + console-vm "-run=listener" 2array >>command + "vocab:io/launcher/windows/nt/test/input.txt" >>stdin + try-process +] unit-test diff --git a/basis/io/launcher/windows/nt/nt.factor b/basis/io/launcher/windows/nt/nt.factor index 5ebb38abc2..e62373cbd7 100755 --- a/basis/io/launcher/windows/nt/nt.factor +++ b/basis/io/launcher/windows/nt/nt.factor @@ -10,21 +10,21 @@ IN: io.launcher.windows.nt : duplicate-handle ( handle -- handle' ) GetCurrentProcess ! source process - swap ! handle + swap handle>> ! handle GetCurrentProcess ! target process f [ ! target handle DUPLICATE_SAME_ACCESS ! desired access TRUE ! inherit handle - DUPLICATE_CLOSE_SOURCE ! options + 0 ! options DuplicateHandle win32-error=0/f - ] keep *void* ; + ] keep *void* &dispose ; ! /dev/null simulation : null-input ( -- pipe ) - (pipe) [ in>> handle>> ] [ out>> dispose ] bi ; + (pipe) [ in>> &dispose ] [ out>> dispose ] bi ; : null-output ( -- pipe ) - (pipe) [ in>> dispose ] [ out>> handle>> ] bi ; + (pipe) [ in>> dispose ] [ out>> &dispose ] bi ; : null-pipe ( mode -- pipe ) { @@ -49,7 +49,7 @@ IN: io.launcher.windows.nt create-mode FILE_ATTRIBUTE_NORMAL ! flags and attributes f ! template file - CreateFile dup invalid-handle? &dispose handle>> ; + CreateFile dup invalid-handle? &dispose ; : redirect-append ( path access-mode create-mode -- handle ) [ path>> ] 2dip @@ -58,10 +58,10 @@ IN: io.launcher.windows.nt dup 0 FILE_END set-file-pointer ; : redirect-handle ( handle access-mode create-mode -- handle ) - 2drop handle>> duplicate-handle ; + 2drop ; : redirect-stream ( stream access-mode create-mode -- handle ) - [ underlying-handle handle>> ] 2dip redirect-handle ; + [ underlying-handle ] 2dip redirect-handle ; : redirect ( obj access-mode create-mode -- handle ) { @@ -72,7 +72,7 @@ IN: io.launcher.windows.nt { [ pick win32-file? ] [ redirect-handle ] } [ redirect-stream ] } cond - dup [ dup t set-inherit ] when ; + dup [ dup t set-inherit handle>> ] when ; : redirect-stdout ( process args -- handle ) drop diff --git a/basis/io/launcher/windows/nt/test/input.txt b/basis/io/launcher/windows/nt/test/input.txt new file mode 100755 index 0000000000..99c3cc6fb1 --- /dev/null +++ b/basis/io/launcher/windows/nt/test/input.txt @@ -0,0 +1 @@ +USE: system 0 exit diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index 7de6c25a13..d17cd1ff80 100755 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -47,7 +47,7 @@ TUPLE: CreateProcess-args : count-trailing-backslashes ( str n -- str n ) [ "\\" ?tail ] dip swap [ - 1+ count-trailing-backslashes + 1 + count-trailing-backslashes ] when ; : fix-trailing-backslashes ( str -- str' ) diff --git a/basis/io/monitors/recursive/recursive-tests.factor b/basis/io/monitors/recursive/recursive-tests.factor index db8e02ae73..7329e73a80 100644 --- a/basis/io/monitors/recursive/recursive-tests.factor +++ b/basis/io/monitors/recursive/recursive-tests.factor @@ -14,13 +14,13 @@ SYMBOL: dummy-monitor-disposed TUPLE: dummy-monitor < monitor ; M: dummy-monitor dispose - drop dummy-monitor-disposed get [ 1+ ] change-i drop ; + drop dummy-monitor-disposed get [ 1 + ] change-i drop ; M: mock-io-backend (monitor) nip over exists? [ dummy-monitor new-monitor - dummy-monitor-created get [ 1+ ] change-i drop + dummy-monitor-created get [ 1 + ] change-i drop ] [ "Does not exist" throw ] if ; diff --git a/basis/io/pipes/pipes.factor b/basis/io/pipes/pipes.factor index c15663b031..8d747086a7 100644 --- a/basis/io/pipes/pipes.factor +++ b/basis/io/pipes/pipes.factor @@ -47,7 +47,7 @@ M: callable run-pipeline-element PRIVATE> : run-pipeline ( seq -- results ) - [ length dup zero? [ drop { } ] [ 1- ] if ] keep + [ length dup zero? [ drop { } ] [ 1 - ] if ] keep [ [ [ first in>> ] [ second out>> ] bi ] dip run-pipeline-element diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor index e72b267c04..07246354e3 100644 --- a/basis/io/sockets/secure/openssl/openssl.factor +++ b/basis/io/sockets/secure/openssl/openssl.factor @@ -36,7 +36,7 @@ TUPLE: openssl-context < secure-context aliens sessions ; password [ B{ 0 } password! ] unless [let | len [ password strlen ] | - buf password len 1+ size min memcpy + buf password len 1 + size min memcpy len ] ] alien-callback ; diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index fe136cd887..ec8b4206e3 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -19,7 +19,7 @@ IN: io.sockets.unix [ handle-fd ] 2dip 1 "int" heap-size setsockopt io-error ; M: unix addrinfo-error ( n -- ) - dup zero? [ drop ] [ gai_strerror throw ] if ; + [ gai_strerror throw ] unless-zero ; ! Client sockets - TCP and Unix domain M: object (get-local-address) ( handle remote -- sockaddr ) diff --git a/basis/lcs/lcs.factor b/basis/lcs/lcs.factor index ab4fbd60bb..aabd4bbafc 100644 --- a/basis/lcs/lcs.factor +++ b/basis/lcs/lcs.factor @@ -5,18 +5,18 @@ IN: lcs ] with map ; @@ -25,7 +25,7 @@ IN: lcs [ [ + ] curry map ] with map ; :: run-lcs ( old new init step -- matrix ) - [let | matrix [ old length 1+ new length 1+ init call ] | + [let | matrix [ old length 1 + new length 1 + init call ] | old length [| i | new length [| j | i j matrix old new step loop-step ] each @@ -44,14 +44,14 @@ TUPLE: insert item ; TUPLE: trace-state old new table i j ; : old-nth ( state -- elt ) - [ i>> 1- ] [ old>> ] bi nth ; + [ i>> 1 - ] [ old>> ] bi nth ; : new-nth ( state -- elt ) - [ j>> 1- ] [ new>> ] bi nth ; + [ j>> 1 - ] [ new>> ] bi nth ; : top-beats-side? ( state -- ? ) - [ [ i>> ] [ j>> 1- ] [ table>> ] tri nth nth ] - [ [ i>> 1- ] [ j>> ] [ table>> ] tri nth nth ] bi > ; + [ [ i>> ] [ j>> 1 - ] [ table>> ] tri nth nth ] + [ [ i>> 1 - ] [ j>> ] [ table>> ] tri nth nth ] bi > ; : retained? ( state -- ? ) { @@ -61,7 +61,7 @@ TUPLE: trace-state old new table i j ; : do-retain ( state -- state ) dup old-nth retain boa , - [ 1- ] change-i [ 1- ] change-j ; + [ 1 - ] change-i [ 1 - ] change-j ; : inserted? ( state -- ? ) { @@ -70,7 +70,7 @@ TUPLE: trace-state old new table i j ; } 1&& ; : do-insert ( state -- state ) - dup new-nth insert boa , [ 1- ] change-j ; + dup new-nth insert boa , [ 1 - ] change-j ; : deleted? ( state -- ? ) { @@ -79,7 +79,7 @@ TUPLE: trace-state old new table i j ; } 1&& ; : do-delete ( state -- state ) - dup old-nth delete boa , [ 1- ] change-i ; + dup old-nth delete boa , [ 1 - ] change-i ; : (trace-diff) ( state -- ) { @@ -90,7 +90,7 @@ TUPLE: trace-state old new table i j ; } cond ; : trace-diff ( old new table -- diff ) - [ ] [ first length 1- ] [ length 1- ] tri trace-state boa + [ ] [ first length 1 - ] [ length 1 - ] tri trace-state boa [ (trace-diff) ] { } make reverse ; PRIVATE> diff --git a/basis/linked-assocs/linked-assocs-tests.factor b/basis/linked-assocs/linked-assocs-tests.factor index 5030e93abc..603b04e895 100644 --- a/basis/linked-assocs/linked-assocs-tests.factor +++ b/basis/linked-assocs/linked-assocs-tests.factor @@ -50,8 +50,8 @@ IN: linked-assocs.test { 9 } [ - { [ 3 * ] [ 1- ] } "first" pick set-at - { [ [ 1- ] bi@ ] [ 2 / ] } "second" pick set-at + { [ 3 * ] [ 1 - ] } "first" pick set-at + { [ [ 1 - ] bi@ ] [ 2 / ] } "second" pick set-at 4 6 pick values [ first call ] each + swap values [ second call ] each ] unit-test @@ -62,4 +62,4 @@ IN: linked-assocs.test 2 "by" pick set-at 3 "cx" pick set-at >alist -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index bde26e2fb9..7b386e9c81 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -97,7 +97,7 @@ M: lazy-take car ( lazy-take -- car ) cons>> car ; M: lazy-take cdr ( lazy-take -- cdr ) - [ n>> 1- ] keep + [ n>> 1 - ] keep cons>> cdr ltake ; M: lazy-take nil? ( lazy-take -- ? ) @@ -191,7 +191,7 @@ TUPLE: lazy-from-by n quot ; C: lfrom-by lazy-from-by : lfrom ( n -- list ) - [ 1+ ] lfrom-by ; + [ 1 + ] lfrom-by ; M: lazy-from-by car ( lazy-from-by -- car ) n>> ; @@ -235,7 +235,7 @@ M: sequence-cons car ( sequence-cons -- car ) [ index>> ] [ seq>> nth ] bi ; M: sequence-cons cdr ( sequence-cons -- cdr ) - [ index>> 1+ ] [ seq>> sequence-tail>list ] bi ; + [ index>> 1 + ] [ seq>> sequence-tail>list ] bi ; M: sequence-cons nil? ( sequence-cons -- ? ) drop f ; diff --git a/basis/lists/lists-tests.factor b/basis/lists/lists-tests.factor index e34a719c57..d2f969cddc 100644 --- a/basis/lists/lists-tests.factor +++ b/basis/lists/lists-tests.factor @@ -24,7 +24,7 @@ IN: lists.tests ] unit-test { T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [ - { 1 2 3 4 } sequence>list [ 1+ ] lmap + { 1 2 3 4 } sequence>list [ 1 + ] lmap ] unit-test { 15 } [ diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 0eedb80889..ddf1ab9109 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -71,7 +71,7 @@ PRIVATE> ] if ; inline recursive : llength ( list -- n ) - 0 [ drop 1+ ] foldl ; + 0 [ drop 1 + ] foldl ; : lreverse ( list -- newlist ) nil [ swap cons ] foldl ; diff --git a/basis/literals/literals-docs.factor b/basis/literals/literals-docs.factor index 9ec8e30133..1caa4b746f 100644 --- a/basis/literals/literals-docs.factor +++ b/basis/literals/literals-docs.factor @@ -38,7 +38,7 @@ USING: kernel literals math prettyprint ; IN: scratchpad << CONSTANT: five 5 >> -{ $[ five dup 1+ dup 2 + ] } . +{ $[ five dup 1 + dup 2 + ] } . "> "{ 5 6 8 }" } } ; @@ -69,7 +69,7 @@ USE: literals IN: scratchpad CONSTANT: five 5 -{ $ five $[ five dup 1+ dup 2 + ] } . +{ $ five $[ five dup 1 + dup 2 + ] } . "> "{ 5 5 6 8 }" } { $subsection POSTPONE: $ } { $subsection POSTPONE: $[ } diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index b1f0b6ca17..0f94e0591a 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -175,8 +175,8 @@ $nl { $code ":: counter ( -- )" " [let | value! [ 0 ] |" - " [ value 1+ dup value! ]" - " [ value 1- dup value! ] ] ;" + " [ value 1 + dup value! ]" + " [ value 1 - dup value! ] ] ;" } "Mutable bindings are implemented in a manner similar to the ML language; each mutable binding is actually an immutable binding of a mutable cell (in Factor's case, a 1-element array); reading the binding automatically dereferences the array, and writing to the binding stores into the array." $nl diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 414b2da45c..63b6d68feb 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -199,23 +199,23 @@ DEFER: xyzzy [ 5 ] [ 10 xyzzy ] unit-test :: let*-test-1 ( a -- b ) - [let* | b [ a 1+ ] - c [ b 1+ ] | + [let* | b [ a 1 + ] + c [ b 1 + ] | a b c 3array ] ; [ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test :: let*-test-2 ( a -- b ) - [let* | b [ a 1+ ] - c! [ b 1+ ] | + [let* | b [ a 1 + ] + c! [ b 1 + ] | a b c 3array ] ; [ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test :: let*-test-3 ( a -- b ) - [let* | b [ a 1+ ] - c! [ b 1+ ] | - c 1+ c! a b c 3array ] ; + [let* | b [ a 1 + ] + c! [ b 1 + ] | + c 1 + c! a b c 3array ] ; [ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test @@ -502,7 +502,7 @@ M:: integer lambda-method-forget-test ( a -- b ) a ; [ 3 ] [ 3 [| | :> a! a ] call ] unit-test -[ 3 ] [ 2 [| | :> a! a 1+ a! a ] call ] unit-test +[ 3 ] [ 2 [| | :> a! a 1 + a! a ] call ] unit-test :: wlet-&&-test ( a -- ? ) [wlet | is-integer? [ a integer? ] diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor index 8374ab421b..848ad5d40e 100644 --- a/basis/logging/server/server.factor +++ b/basis/logging/server/server.factor @@ -74,7 +74,7 @@ CONSTANT: keep-logs 10 over exists? [ move-file ] [ 2drop ] if ; : advance-log ( path n -- ) - [ 1- log# ] 2keep log# ?move-file ; + [ 1 - log# ] 2keep log# ?move-file ; : rotate-log ( service -- ) dup close-log diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor index 0fbfdf0bd9..4de49c06a7 100644 --- a/basis/math/bits/bits.factor +++ b/basis/math/bits/bits.factor @@ -7,13 +7,13 @@ TUPLE: bits { number read-only } { length read-only } ; C: bits : make-bits ( number -- bits ) - dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + ] if ; inline + [ T{ bits f 0 0 } ] [ dup abs log2 1 + ] if-zero ; inline -M: bits length length>> ; +M: bits length length>> ; inline -M: bits nth-unsafe number>> swap bit? ; +M: bits nth-unsafe number>> swap bit? ; inline INSTANCE: bits immutable-sequence : unbits ( seq -- number ) - 0 [ [ 1 shift ] dip [ 1+ ] when ] reduce ; + 0 [ [ 1 shift ] dip [ 1 + ] when ] reduce ; diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor index e10853af18..d1e6c11b6c 100644 --- a/basis/math/bitwise/bitwise-tests.factor +++ b/basis/math/bitwise/bitwise-tests.factor @@ -17,7 +17,8 @@ IN: math.bitwise.tests [ 256 ] [ 1 { 8 } bitfield ] unit-test [ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test [ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test -[ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test +: test-1+ ( x -- y ) 1 + ; +[ 512 ] [ 1 { { test-1+ 8 } } bitfield ] unit-test CONSTANT: a 1 CONSTANT: b 2 diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor index 041539c981..0e0b7ae167 100644 --- a/basis/math/combinatorics/combinatorics-docs.factor +++ b/basis/math/combinatorics/combinatorics-docs.factor @@ -28,7 +28,7 @@ HELP: nCk HELP: permutation { $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } } { $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." } -{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." } +{ $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 }" } diff --git a/basis/math/complex/complex.factor b/basis/math/complex/complex.factor index 832a9e64ba..ce94dfaca8 100644 --- a/basis/math/complex/complex.factor +++ b/basis/math/complex/complex.factor @@ -5,29 +5,29 @@ math.libm math.functions arrays math.functions.private sequences parser ; IN: math.complex.private -M: real real-part ; -M: real imaginary-part drop 0 ; -M: complex real-part real>> ; -M: complex imaginary-part imaginary>> ; -M: complex absq >rect [ sq ] bi@ + ; -M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ; +M: real real-part ; inline +M: real imaginary-part drop 0 ; inline +M: complex real-part real>> ; inline +M: complex imaginary-part imaginary>> ; inline +M: complex absq >rect [ sq ] bi@ + ; inline +M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ; inline : componentwise ( x y quot -- a b ) [ [ >rect ] bi@ ] dip bi-curry@ bi* ; inline : complex= ( x y quot -- ? ) componentwise and ; inline -M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ; -M: complex number= [ number= ] complex= ; +M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ; inline +M: complex number= [ number= ] complex= ; inline : complex-op ( x y quot -- z ) componentwise rect> ; inline -M: complex + [ + ] complex-op ; -M: complex - [ - ] complex-op ; +M: complex + [ + ] complex-op ; inline +M: complex - [ - ] complex-op ; inline : *re ( x y -- xr*yr xi*yi ) [ >rect ] bi@ [ * ] bi-curry@ bi* ; inline : *im ( x y -- xi*yr xr*yi ) swap [ >rect ] bi@ swap [ * ] bi-curry@ bi* ; inline -M: complex * [ *re - ] [ *im + ] 2bi rect> ; +M: complex * [ *re - ] [ *im + ] 2bi rect> ; inline : (complex/) ( x y -- r i m ) [ [ *re + ] [ *im - ] 2bi ] keep absq ; inline : complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ rect> ; inline -M: complex / [ / ] complex/ ; -M: complex /f [ /f ] complex/ ; -M: complex /i [ /i ] complex/ ; -M: complex abs absq >float fsqrt ; -M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; +M: complex / [ / ] complex/ ; inline +M: complex /f [ /f ] complex/ ; inline +M: complex /i [ /i ] complex/ ; inline +M: complex abs absq >float fsqrt ; inline +M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; inline IN: syntax diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index 41800e46da..114b92ecde 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -20,9 +20,6 @@ ARTICLE: "arithmetic-functions" "Arithmetic functions" "Computing additive and multiplicative inverses:" { $subsection neg } { $subsection recip } -"Incrementing, decrementing:" -{ $subsection 1+ } -{ $subsection 1- } "Minimum, maximum, clamping:" { $subsection min } { $subsection max } @@ -32,6 +29,10 @@ ARTICLE: "arithmetic-functions" "Arithmetic functions" "Tests:" { $subsection zero? } { $subsection between? } +"Control flow:" +{ $subsection if-zero } +{ $subsection when-zero } +{ $subsection unless-zero } "Sign:" { $subsection sgn } "Rounding:" @@ -50,8 +51,10 @@ ARTICLE: "power-functions" "Powers and logarithms" { $subsection exp } { $subsection cis } { $subsection log } +{ $subsection log10 } "Raising a number to a power:" { $subsection ^ } +{ $subsection 10^ } "Converting between rectangular and polar form:" { $subsection abs } { $subsection absq } @@ -122,6 +125,10 @@ HELP: log { $values { "x" number } { "y" number } } { $description "Natural logarithm function. Outputs negative infinity if " { $snippet "x" } " is 0." } ; +HELP: log10 +{ $values { "x" number } { "y" number } } +{ $description "Logarithm function base 10. Outputs negative infinity if " { $snippet "x" } " is 0." } ; + HELP: sqrt { $values { "x" number } { "y" number } } { $description "Square root function." } ; @@ -261,6 +268,10 @@ HELP: ^ { $description "Raises " { $snippet "x" } " to the power of " { $snippet "y" } ". If " { $snippet "y" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." } { $errors "Throws an error if " { $snippet "x" } " and " { $snippet "y" } " are both integer 0." } ; +HELP: 10^ +{ $values { "x" number } { "y" number } } +{ $description "Raises " { $snippet "x" } " to the power of 10. If " { $snippet "x" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." } ; + HELP: gcd { $values { "x" integer } { "y" integer } { "a" integer } { "d" integer } } { $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*y = d mod x" } } diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 314062591d..0daea7f706 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -13,7 +13,7 @@ IN: math.functions GENERIC: sqrt ( x -- y ) foldable M: real sqrt - >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; + >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; inline : factor-2s ( n -- r s ) #! factor an integer into 2^r * s @@ -71,7 +71,7 @@ PRIVATE> 2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline : 0^ ( x -- z ) - dup zero? [ drop 0/0. ] [ 0 < 1/0. 0 ? ] if ; inline + [ 0/0. ] [ 0 < 1/0. 0 ? ] if-zero ; inline : (^mod) ( n x y -- z ) make-bits 1 [ @@ -104,10 +104,12 @@ PRIVATE> : divisor? ( m n -- ? ) mod 0 = ; +ERROR: non-trivial-divisor n ; + : mod-inv ( x n -- y ) [ nip ] [ gcd 1 = ] 2bi [ dup 0 < [ + ] [ nip ] if ] - [ "Non-trivial divisor found" throw ] if ; foldable + [ non-trivial-divisor ] if ; foldable : ^mod ( x y n -- z ) over 0 < [ @@ -118,7 +120,7 @@ PRIVATE> GENERIC: absq ( x -- y ) foldable -M: real absq sq ; +M: real absq sq ; inline : ~abs ( x y epsilon -- ? ) [ - abs ] dip < ; @@ -146,16 +148,20 @@ M: real absq sq ; GENERIC: exp ( x -- y ) -M: real exp fexp ; +M: real exp fexp ; inline M: complex exp >rect swap fexp swap polar> ; GENERIC: log ( x -- y ) -M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; +M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; inline M: complex log >polar swap flog swap rect> ; +: 10^ ( x -- y ) 10 swap ^ ; inline + +: log10 ( x -- y ) log 10 log / ; inline + GENERIC: cos ( x -- y ) foldable M: complex cos @@ -163,7 +169,7 @@ M: complex cos [ [ fcos ] [ fcosh ] bi* * ] [ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ; -M: real cos fcos ; +M: real cos fcos ; inline : sec ( x -- y ) cos recip ; inline @@ -174,7 +180,7 @@ M: complex cosh [ [ fcosh ] [ fcos ] bi* * ] [ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ; -M: real cosh fcosh ; +M: real cosh fcosh ; inline : sech ( x -- y ) cosh recip ; inline @@ -185,7 +191,7 @@ M: complex sin [ [ fsin ] [ fcosh ] bi* * ] [ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ; -M: real sin fsin ; +M: real sin fsin ; inline : cosec ( x -- y ) sin recip ; inline @@ -196,7 +202,7 @@ M: complex sinh [ [ fsinh ] [ fcos ] bi* * ] [ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ; -M: real sinh fsinh ; +M: real sinh fsinh ; inline : cosech ( x -- y ) sinh recip ; inline @@ -204,13 +210,13 @@ GENERIC: tan ( x -- y ) foldable M: complex tan [ sin ] [ cos ] bi / ; -M: real tan ftan ; +M: real tan ftan ; inline GENERIC: tanh ( x -- y ) foldable M: complex tanh [ sinh ] [ cosh ] bi / ; -M: real tanh ftanh ; +M: real tanh ftanh ; inline : cot ( x -- y ) tan recip ; inline @@ -246,7 +252,7 @@ GENERIC: atan ( x -- y ) foldable M: complex atan i* atanh i* ; -M: real atan fatan ; +M: real atan fatan ; inline : asec ( x -- y ) recip acos ; inline @@ -259,13 +265,13 @@ M: real atan fatan ; : round ( x -- y ) dup sgn 2 / + truncate ; inline : floor ( x -- y ) - dup 1 mod dup zero? - [ drop ] [ dup 0 < [ - 1 - ] [ - ] if ] if ; foldable + dup 1 mod + [ ] [ dup 0 < [ - 1 - ] [ - ] if ] if-zero ; foldable : ceiling ( x -- y ) neg floor neg ; foldable : floor-to ( x step -- y ) - dup zero? [ drop ] [ [ / floor ] [ * ] bi ] if ; + [ [ / floor ] [ * ] bi ] unless-zero ; : lerp ( a b t -- a_t ) [ over - ] dip * + ; inline diff --git a/basis/math/intervals/intervals-docs.factor b/basis/math/intervals/intervals-docs.factor index 4be8dcc9a7..0c0f95b48c 100644 --- a/basis/math/intervals/intervals-docs.factor +++ b/basis/math/intervals/intervals-docs.factor @@ -253,7 +253,7 @@ HELP: interval-bitnot { $description "Computes the bitwise complement of the interval." } ; HELP: points>interval -{ $values { "seq" "a sequence of " { $snippet "{ point included? }" } " pairs" } { "interval" interval } } +{ $values { "seq" "a sequence of " { $snippet "{ point included? }" } " pairs" } { "interval" interval } { "nan?" "true if the computation produced NaNs" } } { $description "Outputs the smallest interval containing all of the endpoints." } ; diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 760338a7c3..a2bdf6d98f 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -113,6 +113,22 @@ IN: math.intervals.tests 0 1 (a,b) 0 1 [a,b] interval-subset? ] unit-test +[ t ] [ + full-interval -1/0. 1/0. [a,b] interval-subset? +] unit-test + +[ t ] [ + -1/0. 1/0. [a,b] full-interval interval-subset? +] unit-test + +[ f ] [ + full-interval 0 1/0. [a,b] interval-subset? +] unit-test + +[ t ] [ + 0 1/0. [a,b] full-interval interval-subset? +] unit-test + [ f ] [ 0 0 1 (a,b) interval-contains? ] unit-test @@ -251,8 +267,6 @@ IN: math.intervals.tests { bitnot interval-bitnot } { abs interval-abs } { 2/ interval-2/ } - { 1+ interval-1+ } - { 1- interval-1- } { neg interval-neg } } "math.ratios.private" vocab [ @@ -334,6 +348,10 @@ comparison-ops [ [ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test +[ t ] [ full-interval interval-abs [0,inf] = ] unit-test + +[ t ] [ [0,inf] interval-sq [0,inf] = ] unit-test + ! Test that commutative interval ops really are : random-interval-or-empty ( -- obj ) 10 random 0 = [ empty-interval ] [ random-interval ] if ; diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 3c33940676..99997ab8cb 100755 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -11,14 +11,21 @@ SYMBOL: full-interval TUPLE: interval { from read-only } { to read-only } ; +: closed-point? ( from to -- ? ) + 2dup [ first ] bi@ number= + [ [ second ] both? ] [ 2drop f ] if ; + : ( from to -- interval ) - 2dup [ first ] bi@ { - { [ 2dup > ] [ 2drop 2drop empty-interval ] } - { [ 2dup number= ] [ - 2drop 2dup [ second ] both? + { + { [ 2dup [ first ] bi@ > ] [ 2drop empty-interval ] } + { [ 2dup [ first ] bi@ number= ] [ + 2dup [ second ] both? [ interval boa ] [ 2drop empty-interval ] if ] } - [ 2drop interval boa ] + { [ 2dup [ { -1/0. t } = ] [ { 1/0. t } = ] bi* and ] [ + 2drop full-interval + ] } + [ interval boa ] } cond ; : open-point ( n -- endpoint ) f 2array ; @@ -53,6 +60,9 @@ MEMO: [0,inf] ( -- interval ) 0 [a,inf] ; foldable MEMO: fixnum-interval ( -- interval ) most-negative-fixnum most-positive-fixnum [a,b] ; inline +MEMO: array-capacity-interval ( -- interval ) + 0 max-array-capacity [a,b] ; inline + : [-inf,inf] ( -- interval ) full-interval ; inline : compare-endpoints ( p1 p2 quot -- ? ) @@ -84,21 +94,25 @@ MEMO: fixnum-interval ( -- interval ) : interval>points ( int -- from to ) [ from>> ] [ to>> ] bi ; -: points>interval ( seq -- interval ) - dup [ first fp-nan? ] any? - [ drop [-inf,inf] ] [ - dup first - [ [ endpoint-min ] reduce ] - [ [ endpoint-max ] reduce ] - 2bi - ] if ; +: points>interval ( seq -- interval nan? ) + [ first fp-nan? not ] partition + [ + [ [ ] [ endpoint-min ] map-reduce ] + [ [ ] [ endpoint-max ] map-reduce ] bi + + ] + [ empty? not ] + bi* ; + +: nan-ok ( interval nan? -- interval ) drop ; inline +: nan-not-ok ( interval nan? -- interval ) [ drop full-interval ] when ; inline : (interval-op) ( p1 p2 quot -- p3 ) [ [ first ] [ first ] [ call ] tri* ] [ drop [ second ] both? ] 3bi 2array ; inline -: interval-op ( i1 i2 quot -- i3 ) +: interval-op ( i1 i2 quot -- i3 nan? ) { [ [ from>> ] [ from>> ] [ ] tri* (interval-op) ] [ [ to>> ] [ from>> ] [ ] tri* (interval-op) ] @@ -116,10 +130,10 @@ MEMO: fixnum-interval ( -- interval ) } cond ; inline : interval+ ( i1 i2 -- i3 ) - [ [ + ] interval-op ] do-empty-interval ; + [ [ + ] interval-op nan-ok ] do-empty-interval ; : interval- ( i1 i2 -- i3 ) - [ [ - ] interval-op ] do-empty-interval ; + [ [ - ] interval-op nan-ok ] do-empty-interval ; : interval-intersect ( i1 i2 -- i3 ) { @@ -144,7 +158,7 @@ MEMO: fixnum-interval ( -- interval ) { [ dup empty-interval eq? ] [ drop ] } { [ over full-interval eq? ] [ drop ] } { [ dup full-interval eq? ] [ nip ] } - [ [ interval>points 2array ] bi@ append points>interval ] + [ [ interval>points 2array ] bi@ append points>interval nan-not-ok ] } cond ; : interval-subset? ( i1 i2 -- ? ) @@ -163,7 +177,7 @@ MEMO: fixnum-interval ( -- interval ) 0 swap interval-contains? ; : interval* ( i1 i2 -- i3 ) - [ [ [ * ] interval-op ] do-empty-interval ] + [ [ [ * ] interval-op nan-ok ] do-empty-interval ] [ [ interval-zero? ] either? ] 2bi [ 0 [a,a] interval-union ] when ; @@ -210,7 +224,7 @@ MEMO: fixnum-interval ( -- interval ) [ [ [ interval-closure ] bi@ - [ shift ] interval-op + [ shift ] interval-op nan-not-ok ] interval-integer-op ] do-empty-interval ; @@ -225,11 +239,11 @@ MEMO: fixnum-interval ( -- interval ) : interval-max ( i1 i2 -- i3 ) #! Inaccurate; could be tighter - [ [ interval-closure ] bi@ [ max ] interval-op ] do-empty-interval ; + [ [ interval-closure ] bi@ [ max ] interval-op nan-not-ok ] do-empty-interval ; : interval-min ( i1 i2 -- i3 ) #! Inaccurate; could be tighter - [ [ interval-closure ] bi@ [ min ] interval-op ] do-empty-interval ; + [ [ interval-closure ] bi@ [ min ] interval-op nan-not-ok ] do-empty-interval ; : interval-interior ( i1 -- i2 ) dup special-interval? [ @@ -244,7 +258,7 @@ MEMO: fixnum-interval ( -- interval ) } cond ; inline : interval/ ( i1 i2 -- i3 ) - [ [ [ / ] interval-op ] interval-division-op ] do-empty-interval ; + [ [ [ / ] interval-op nan-not-ok ] interval-division-op ] do-empty-interval ; : interval/-safe ( i1 i2 -- i3 ) #! Just a hack to make the compiler work if bootstrap.math @@ -256,13 +270,13 @@ MEMO: fixnum-interval ( -- interval ) [ [ [ interval-closure ] bi@ - [ /i ] interval-op + [ /i ] interval-op nan-not-ok ] interval-integer-op ] interval-division-op ] do-empty-interval ; : interval/f ( i1 i2 -- i3 ) - [ [ [ /f ] interval-op ] interval-division-op ] do-empty-interval ; + [ [ [ /f ] interval-op nan-not-ok ] interval-division-op ] do-empty-interval ; : (interval-abs) ( i1 -- i2 ) interval>points [ first2 [ abs ] dip 2array ] bi@ 2array ; @@ -271,10 +285,13 @@ MEMO: fixnum-interval ( -- interval ) { { [ dup empty-interval eq? ] [ ] } { [ dup full-interval eq? ] [ drop [0,inf] ] } - { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] } - [ (interval-abs) points>interval ] + { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval nan-not-ok ] } + [ (interval-abs) points>interval nan-not-ok ] } cond ; +: interval-absq ( i1 -- i2 ) + interval-abs interval-sq ; + : interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ; : interval-2/ ( i1 -- i2 ) -1 [a,a] interval-shift ; @@ -344,14 +361,6 @@ SYMBOL: incomparable [ nip (rem-range) ] } cond ; -: interval->fixnum ( i1 -- i2 ) - { - { [ dup empty-interval eq? ] [ ] } - { [ dup full-interval eq? ] [ drop fixnum-interval ] } - { [ dup fixnum-interval interval-subset? not ] [ drop fixnum-interval ] } - [ ] - } cond ; - : interval-bitand-pos ( i1 i2 -- ? ) [ to>> first ] bi@ min 0 swap [a,b] ; diff --git a/basis/math/matrices/elimination/elimination.factor b/basis/math/matrices/elimination/elimination.factor index 0368dd5286..8411447aac 100755 --- a/basis/math/matrices/elimination/elimination.factor +++ b/basis/math/matrices/elimination/elimination.factor @@ -50,7 +50,7 @@ SYMBOL: matrix : do-row ( exchange-with row# -- ) [ exchange-rows ] keep [ first-col ] keep - dup 1+ rows-from clear-col ; + dup 1 + rows-from clear-col ; : find-row ( row# quot -- i elt ) [ rows-from ] dip find ; inline @@ -60,8 +60,8 @@ SYMBOL: matrix : (echelon) ( col# row# -- ) over cols < over rows < and [ - 2dup pivot-row [ over do-row 1+ ] when* - [ 1+ ] dip (echelon) + 2dup pivot-row [ over do-row 1 + ] when* + [ 1 + ] dip (echelon) ] [ 2drop ] if ; diff --git a/basis/math/primes/erato/erato.factor b/basis/math/primes/erato/erato.factor index 673f9c97cd..fdc2f9fc3b 100644 --- a/basis/math/primes/erato/erato.factor +++ b/basis/math/primes/erato/erato.factor @@ -9,7 +9,7 @@ IN: math.primes.erato CONSTANT: masks B{ 0 128 0 0 0 0 0 64 0 0 0 32 0 16 0 0 0 8 0 4 0 0 0 2 0 0 0 0 0 1 } : bit-pos ( n -- byte/f mask/f ) - 30 /mod masks nth-unsafe dup zero? [ 2drop f f ] when ; + 30 /mod masks nth-unsafe [ drop f f ] when-zero ; : marked-unsafe? ( n arr -- ? ) [ bit-pos ] dip swap [ [ nth-unsafe ] [ bitand zero? not ] bi* ] [ 2drop f ] if* ; @@ -38,4 +38,4 @@ PRIVATE> : marked-prime? ( n arr -- ? ) 2dup upper-bound 2 swap between? [ bounds-error ] unless - over { 2 3 5 } member? [ 2drop t ] [ marked-unsafe? ] if ; \ No newline at end of file + over { 2 3 5 } member? [ 2drop t ] [ marked-unsafe? ] if ; diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor index 439d55ee8d..da1c36196b 100644 --- a/basis/math/primes/factors/factors.factor +++ b/basis/math/primes/factors/factors.factor @@ -8,7 +8,7 @@ IN: math.primes.factors : count-factor ( n d -- n' c ) [ 1 ] 2dip [ /i ] keep - [ dupd /mod zero? ] curry [ nip [ 1+ ] dip ] while drop + [ dupd /mod zero? ] curry [ nip [ 1 + ] dip ] while drop swap ; : write-factor ( n d -- n' d' ) @@ -39,7 +39,7 @@ PRIVATE> : totient ( n -- t ) { { [ dup 2 < ] [ drop 0 ] } - [ dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / * ] + [ dup unique-factors [ 1 [ 1 - * ] reduce ] [ product ] bi / * ] } cond ; foldable : divisors ( n -- seq ) diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index d28afa1413..58cb2b09db 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -12,11 +12,9 @@ TUPLE: range : ( a b step -- range ) [ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline -M: range length ( seq -- n ) - length>> ; +M: range length ( seq -- n ) length>> ; inline -M: range nth-unsafe ( n range -- obj ) - [ step>> * ] keep from>> + ; +M: range nth-unsafe ( n range -- obj ) [ step>> * ] keep from>> + ; inline ! For ranges with many elements, the default element-wise methods ! sequences define are unsuitable because they're O(n) diff --git a/basis/math/ratios/ratios-tests.factor b/basis/math/ratios/ratios-tests.factor index c01e7377b2..8124fcdd24 100644 --- a/basis/math/ratios/ratios-tests.factor +++ b/basis/math/ratios/ratios-tests.factor @@ -78,8 +78,8 @@ unit-test [ 3 ] [ 10/3 truncate ] unit-test [ -3 ] [ -10/3 truncate ] unit-test -[ -1/2 ] [ 1/2 1- ] unit-test -[ 3/2 ] [ 1/2 1+ ] unit-test +[ -1/2 ] [ 1/2 1 - ] unit-test +[ 3/2 ] [ 1/2 1 + ] unit-test [ 1.0 ] [ 0.5 1/2 + ] unit-test [ 1.0 ] [ 1/2 0.5 + ] unit-test diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index d4f457180e..dcb8e87e7c 100644 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel kernel.private math math.functions math.private ; +USING: accessors kernel kernel.private math math.functions +math.private sequences summary ; IN: math.ratios : 2>fraction ( a/b c/d -- a c b d ) @@ -19,13 +20,18 @@ IN: math.ratios PRIVATE> +ERROR: division-by-zero x ; + +M: division-by-zero summary + drop "Division by zero" ; + M: integer / - dup zero? [ - "Division by zero" throw + [ + division-by-zero ] [ dup 0 < [ [ neg ] bi@ ] when 2dup gcd nip [ /i ] curry bi@ fraction> - ] if ; + ] if-zero ; M: ratio hashcode* nip >fraction [ hashcode ] bi@ bitxor ; @@ -42,8 +48,8 @@ M: ratio >fixnum >fraction /i >fixnum ; M: ratio >bignum >fraction /i >bignum ; M: ratio >float >fraction /f ; -M: ratio numerator numerator>> ; -M: ratio denominator denominator>> ; +M: ratio numerator numerator>> ; inline +M: ratio denominator denominator>> ; inline M: ratio < scale < ; M: ratio <= scale <= ; diff --git a/basis/memoize/memoize-tests.factor b/basis/memoize/memoize-tests.factor index d82abe5b07..771c11c130 100644 --- a/basis/memoize/memoize-tests.factor +++ b/basis/memoize/memoize-tests.factor @@ -9,7 +9,7 @@ MEMO: fib ( m -- n ) [ 89 ] [ 10 fib ] unit-test -[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval( -- ) ] must-fail +[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1 + ] 4 ndip ;" eval( -- ) ] must-fail MEMO: see-test ( a -- b ) reverse ; diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor index 0cf7556bcd..1d56c59fc0 100755 --- a/basis/mime/multipart/multipart.factor +++ b/basis/mime/multipart/multipart.factor @@ -46,7 +46,7 @@ ERROR: end-of-stream multipart ; dup bytes>> length 256 < [ fill-bytes ] when ; : split-bytes ( bytes separator -- leftover-bytes safe-to-dump ) - dupd [ length ] bi@ 1- - short cut-slice swap ; + dupd [ length ] bi@ 1 - - short cut-slice swap ; : dump-until-separator ( multipart -- multipart ) dup diff --git a/basis/models/arrow/arrow-tests.factor b/basis/models/arrow/arrow-tests.factor index 6984e0e750..d7900f1dbd 100644 --- a/basis/models/arrow/arrow-tests.factor +++ b/basis/models/arrow/arrow-tests.factor @@ -4,7 +4,7 @@ IN: models.arrow.tests 3 "x" set "x" get [ 2 * ] dup "z" set -[ 1+ ] "y" set +[ 1 + ] "y" set [ ] [ "y" get activate-model ] unit-test [ t ] [ "z" get "x" get connections>> memq? ] unit-test [ 7 ] [ "y" get value>> ] unit-test diff --git a/basis/models/models.factor b/basis/models/models.factor index 19b478eaf9..27504bc0fa 100644 --- a/basis/models/models.factor +++ b/basis/models/models.factor @@ -32,10 +32,10 @@ GENERIC: model-activated ( model -- ) M: model model-activated drop ; : ref-model ( model -- n ) - [ 1+ ] change-ref ref>> ; + [ 1 + ] change-ref ref>> ; : unref-model ( model -- n ) - [ 1- ] change-ref ref>> ; + [ 1 - ] change-ref ref>> ; : activate-model ( model -- ) dup ref-model 1 = [ diff --git a/basis/models/product/product-tests.factor b/basis/models/product/product-tests.factor index 84ac738126..f52dc8a3b0 100644 --- a/basis/models/product/product-tests.factor +++ b/basis/models/product/product-tests.factor @@ -24,7 +24,7 @@ IN: models.product.tests TUPLE: an-observer { i integer } ; -M: an-observer model-changed nip [ 1+ ] change-i drop ; +M: an-observer model-changed nip [ 1 + ] change-i drop ; [ 1 0 ] [ [let* | m1 [ 1 ] @@ -42,4 +42,4 @@ M: an-observer model-changed nip [ 1+ ] change-i drop ; o1 i>> o2 i>> ] -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/multiline/multiline-docs.factor b/basis/multiline/multiline-docs.factor index 4782571d4a..fd91c440d7 100644 --- a/basis/multiline/multiline-docs.factor +++ b/basis/multiline/multiline-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax ; +USING: help.markup help.syntax strings ; IN: multiline HELP: STRING: @@ -18,6 +18,34 @@ HELP: /* "" } ; +HELP: HEREDOC: +{ $syntax "HEREDOC: marker\n...text...\nmarker" } +{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } } +{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: HEREDOC: } " until the end of the line containing the " { $link POSTPONE: HEREDOC: } ". Text is captured until a line is found conatining exactly this delimter string." } +{ $warning "Whitespace is significant." } +{ $examples + { $example "USING: multiline prettyprint ;" + "HEREDOC: END\nx\nEND\n." + "\"x\\n\"" + } + { $example "USING: multiline prettyprint sequences ;" + "2 5 HEREDOC: zap\nfoo\nbar\nzap\nsubseq ." + "\"o\\nb\"" + } +} ; + +HELP: DELIMITED: +{ $syntax "DELIMITED: marker\n...text...\nmarker" } +{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } } +{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: DELIMITED: } " until the end of the line containing the " { $link POSTPONE: DELIMITED: } ". Text is captured until the exact delimiter string is found, regardless of where." } +{ $examples + { $example "USING: multiline prettyprint ;" + "DELIMITED: factor blows my mind" +"whoafactor blows my mind ." + "\"whoa\"" + } +} ; + { POSTPONE: <" POSTPONE: STRING: } related-words HELP: parse-multiline-string @@ -29,6 +57,8 @@ ARTICLE: "multiline" "Multiline" "Multiline strings:" { $subsection POSTPONE: STRING: } { $subsection POSTPONE: <" } +{ $subsection POSTPONE: HEREDOC: } +{ $subsection POSTPONE: DELIMITED: } "Multiline comments:" { $subsection POSTPONE: /* } "Writing new multiline parsing words:" diff --git a/basis/multiline/multiline-tests.factor b/basis/multiline/multiline-tests.factor index 153b6cedbe..25610ed660 100644 --- a/basis/multiline/multiline-tests.factor +++ b/basis/multiline/multiline-tests.factor @@ -1,4 +1,4 @@ -USING: multiline tools.test ; +USING: accessors eval multiline tools.test ; IN: multiline.tests STRING: test-it @@ -19,3 +19,73 @@ world"> ] unit-test [ "\nhi" ] [ <" hi"> ] unit-test + + +! HEREDOC: + +[ "foo\nbar\n" ] [ HEREDOC: END +foo +bar +END +] unit-test + +[ "" ] [ HEREDOC: END +END +] unit-test + +[ " END\n" ] [ HEREDOC: END + END +END +] unit-test + +[ "\n" ] [ HEREDOC: END + +END +] unit-test + +[ "x\n" ] [ HEREDOC: END +x +END +] unit-test + +[ "x\n" ] [ HEREDOC: END +x +END +] unit-test + +[ "xyz \n" ] [ HEREDOC: END +xyz +END +] unit-test + +[ "} ! * # \" «\n" ] [ HEREDOC: END +} ! * # " « +END +] unit-test + +[ 21 "foo\nbar\n" " HEREDOC: FOO\n FOO\n" 22 ] [ 21 HEREDOC: X +foo +bar +X +HEREDOC: END + HEREDOC: FOO + FOO +END +22 ] unit-test + +[ "lol\n xyz\n" ] +[ +HEREDOC: xyz +lol + xyz +xyz +] unit-test + + +[ "lol" ] +[ DELIMITED: aol +lolaol ] unit-test + +[ "whoa" ] +[ DELIMITED: factor blows my mind +whoafactor blows my mind ] unit-test diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index 2e8f8eb4c4..4eaafe1f18 100644 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -4,6 +4,8 @@ USING: namespaces make parser lexer kernel sequences words quotations math accessors locals ; IN: multiline +ERROR: bad-heredoc identifier ; + > ; @@ -27,7 +29,7 @@ SYNTAX: STRING: > :> text text [ end text i start* [| j | @@ -35,18 +37,43 @@ SYNTAX: STRING: ] [ text i short tail % CHAR: \n , lexer get next-line - 0 end (parse-multiline-string) + 0 end (scan-multiline-string) ] if* ] [ end unexpected-eof ] if ; +:: (parse-multiline-string) ( end-text skip-n-chars -- str ) + [ + lexer get + [ skip-n-chars + end-text (scan-multiline-string) ] + change-column drop + ] "" make ; + +: rest-of-line ( -- seq ) + lexer get [ line-text>> ] [ column>> ] bi tail ; + +:: advance-same-line ( text -- ) + lexer get [ text length + ] change-column drop ; + +:: (parse-til-line-begins) ( begin-text -- ) + lexer get still-parsing? [ + lexer get line-text>> begin-text sequence= [ + begin-text advance-same-line + ] [ + lexer get line-text>> % "\n" % + lexer get next-line + begin-text (parse-til-line-begins) + ] if + ] [ + begin-text bad-heredoc + ] if ; + +: parse-til-line-begins ( begin-text -- seq ) + [ (parse-til-line-begins) ] "" make ; + PRIVATE> : parse-multiline-string ( end-text -- str ) - [ - lexer get - [ 1+ swap (parse-multiline-string) ] - change-column drop - ] "" make ; + 1 (parse-multiline-string) ; SYNTAX: <" "\">" parse-multiline-string parsed ; @@ -61,3 +88,15 @@ SYNTAX: {" "\"}" parse-multiline-string parsed ; SYNTAX: /* "*/" parse-multiline-string drop ; + +SYNTAX: HEREDOC: + lexer get skip-blank + rest-of-line + lexer get next-line + parse-til-line-begins parsed ; + +SYNTAX: DELIMITED: + lexer get skip-blank + rest-of-line + lexer get next-line + 0 (parse-multiline-string) parsed ; diff --git a/basis/opengl/gl/extensions/extensions.factor b/basis/opengl/gl/extensions/extensions.factor index 9aa4ee429d..6292a683e3 100644 --- a/basis/opengl/gl/extensions/extensions.factor +++ b/basis/opengl/gl/extensions/extensions.factor @@ -25,7 +25,7 @@ reset-gl-function-number-counter : gl-function-number ( -- n ) +gl-function-number-counter+ get-global - dup 1+ +gl-function-number-counter+ set-global ; + dup 1 + +gl-function-number-counter+ set-global ; : gl-function-pointer ( names n -- funptr ) gl-function-context 2array dup +gl-function-pointers+ get-global at diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor index 93f407681e..850b585190 100644 --- a/basis/peg/parsers/parsers.factor +++ b/basis/peg/parsers/parsers.factor @@ -51,7 +51,7 @@ PRIVATE> dup zero? [ 2drop epsilon ] [ - [ exactly-n ] [ 1- at-most-n ] 2bi 2choice + [ exactly-n ] [ 1 - at-most-n ] 2bi 2choice ] if ; : at-least-n ( parser n -- parser' ) diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 12e6d59fc0..42530151be 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -329,7 +329,7 @@ SYMBOL: id : next-id ( -- n ) #! Return the next unique id for a parser id get-global [ - dup 1+ id set-global + dup 1 + id set-global ] [ 1 id set-global 0 ] if* ; diff --git a/basis/persistent/hashtables/config/config.factor b/basis/persistent/hashtables/config/config.factor index a761e2d327..cb2abd8015 100644 --- a/basis/persistent/hashtables/config/config.factor +++ b/basis/persistent/hashtables/config/config.factor @@ -4,5 +4,5 @@ USING: layouts kernel parser math ; IN: persistent.hashtables.config : radix-bits ( -- n ) << cell 4 = 4 5 ? parsed >> ; foldable -: radix-mask ( -- n ) radix-bits 2^ 1- ; foldable -: full-bitmap-mask ( -- n ) radix-bits 2^ 2^ 1- ; inline +: radix-mask ( -- n ) radix-bits 2^ 1 - ; foldable +: full-bitmap-mask ( -- n ) radix-bits 2^ 2^ 1 - ; inline diff --git a/basis/persistent/hashtables/hashtables.factor b/basis/persistent/hashtables/hashtables.factor index 67886312c6..0179216e62 100644 --- a/basis/persistent/hashtables/hashtables.factor +++ b/basis/persistent/hashtables/hashtables.factor @@ -33,7 +33,7 @@ M: persistent-hash pluck-at { { [ 2dup root>> eq? ] [ nip ] } { [ over not ] [ 2drop T{ persistent-hash } ] } - [ count>> 1- persistent-hash boa ] + [ count>> 1 - persistent-hash boa ] } cond ; M: persistent-hash >alist [ root>> >alist% ] { } make ; diff --git a/basis/persistent/hashtables/nodes/bitmap/bitmap.factor b/basis/persistent/hashtables/nodes/bitmap/bitmap.factor index f231043274..4c764eba93 100644 --- a/basis/persistent/hashtables/nodes/bitmap/bitmap.factor +++ b/basis/persistent/hashtables/nodes/bitmap/bitmap.factor @@ -7,7 +7,7 @@ persistent.hashtables.config persistent.hashtables.nodes ; IN: persistent.hashtables.nodes.bitmap -: index ( bit bitmap -- n ) [ 1- ] dip bitand bit-count ; inline +: index ( bit bitmap -- n ) [ 1 - ] dip bitand bit-count ; inline M:: bitmap-node (entry-at) ( key hashcode bitmap-node -- entry ) [let* | shift [ bitmap-node shift>> ] diff --git a/basis/persistent/vectors/vectors.factor b/basis/persistent/vectors/vectors.factor index 5927171aa3..2527959f32 100644 --- a/basis/persistent/vectors/vectors.factor +++ b/basis/persistent/vectors/vectors.factor @@ -55,13 +55,13 @@ M: persistent-vector nth-unsafe [ 1array ] dip node boa ; : 2node ( first second -- node ) - [ 2array ] [ drop level>> 1+ ] 2bi node boa ; + [ 2array ] [ drop level>> 1 + ] 2bi node boa ; : new-child ( new-child node -- node' expansion/f ) dup full? [ tuck level>> 1node ] [ node-add f ] if ; : new-last ( val seq -- seq' ) - [ length 1- ] keep new-nth ; + [ length 1 - ] keep new-nth ; : node-set-last ( child node -- node' ) clone [ new-last ] change-children ; @@ -86,7 +86,7 @@ M: persistent-vector ppush ( val pvec -- pvec' ) clone dup tail>> full? [ ppush-new-tail ] [ ppush-tail ] if - [ 1+ ] change-count ; + [ 1 + ] change-count ; : node-set-nth ( val i node -- node' ) clone [ new-nth ] change-children ; @@ -166,7 +166,7 @@ M: persistent-vector ppop ( pvec -- pvec' ) clone dup tail>> children>> length 1 > [ ppop-tail ] [ ppop-new-tail ] if - ] dip 1- >>count + ] dip 1 - >>count ] } case ; diff --git a/basis/porter-stemmer/porter-stemmer.factor b/basis/porter-stemmer/porter-stemmer.factor index 4765df10d7..2e1a47b951 100644 --- a/basis/porter-stemmer/porter-stemmer.factor +++ b/basis/porter-stemmer/porter-stemmer.factor @@ -7,7 +7,7 @@ IN: porter-stemmer ] [ CHAR: y = [ over zero? - [ 2drop t ] [ [ 1- ] dip consonant? not ] if + [ 2drop t ] [ [ 1 - ] dip consonant? not ] if ] [ 2drop t ] if @@ -15,18 +15,18 @@ IN: porter-stemmer : skip-vowels ( i str -- i str ) 2dup bounds-check? [ - 2dup consonant? [ [ 1+ ] dip skip-vowels ] unless + 2dup consonant? [ [ 1 + ] dip skip-vowels ] unless ] when ; : skip-consonants ( i str -- i str ) 2dup bounds-check? [ - 2dup consonant? [ [ 1+ ] dip skip-consonants ] when + 2dup consonant? [ [ 1 + ] dip skip-consonants ] when ] when ; : (consonant-seq) ( n i str -- n ) skip-vowels 2dup bounds-check? [ - [ 1+ ] [ 1+ ] [ ] tri* skip-consonants [ 1+ ] dip + [ 1 + ] [ 1 + ] [ ] tri* skip-consonants [ 1 + ] dip (consonant-seq) ] [ 2drop @@ -42,7 +42,7 @@ IN: porter-stemmer over 1 < [ 2drop f ] [ - 2dup nth [ over 1- over nth ] dip = [ + 2dup nth [ over 1 - over nth ] dip = [ consonant? ] [ 2drop f @@ -92,7 +92,7 @@ IN: porter-stemmer { [ "bl" ?tail ] [ "ble" append ] } { [ "iz" ?tail ] [ "ize" append ] } { - [ dup length 1- over double-consonant? ] + [ dup length 1 - over double-consonant? ] [ dup "lsz" last-is? [ but-last-slice ] unless ] } { @@ -206,7 +206,7 @@ IN: porter-stemmer : ll->l ( str -- newstr ) { { [ dup last CHAR: l = not ] [ ] } - { [ dup length 1- over double-consonant? not ] [ ] } + { [ dup length 1 - over double-consonant? not ] [ ] } { [ dup consonant-seq 1 > ] [ but-last-slice ] } [ ] } cond ; diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 27416e0f89..247067673e 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -124,29 +124,31 @@ M: pathname pprint* ] if ] if ; inline -: tuple>assoc ( tuple -- assoc ) - [ class all-slots ] [ tuple-slots ] bi zip +: filter-tuple-assoc ( slot,value -- name,value ) [ [ initial>> ] dip = not ] assoc-filter [ [ name>> ] dip ] assoc-map ; +: tuple>assoc ( tuple -- assoc ) + [ class all-slots ] [ tuple-slots ] bi zip filter-tuple-assoc ; + : pprint-slot-value ( name value -- ) ] bi* \ } pprint-word block> ; +: (pprint-tuple) ( opener class slots closer -- ) + ] + [ pprint-word ] + } spread block> ; + +: ?pprint-tuple ( tuple quot -- ) + [ boa-tuples? get [ pprint-object ] ] dip [ check-recursion ] curry if ; inline + : pprint-tuple ( tuple -- ) - boa-tuples? get [ pprint-object ] [ - [ - assoc [ pprint-slot-value ] assoc-each - block> - \ } pprint-word - block> - ] check-recursion - ] if ; + [ [ \ T{ ] dip [ class ] [ tuple>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ; M: tuple pprint* pprint-tuple ; @@ -177,16 +179,17 @@ M: callstack pprint-delims drop \ CS{ \ } ; M: object >pprint-sequence ; M: vector >pprint-sequence ; M: byte-vector >pprint-sequence ; -M: curry >pprint-sequence ; -M: compose >pprint-sequence ; +M: callable >pprint-sequence ; M: hashtable >pprint-sequence >alist ; M: wrapper >pprint-sequence wrapped>> 1array ; M: callstack >pprint-sequence callstack>array ; -M: tuple >pprint-sequence - [ class ] [ tuple-slots ] bi +: class-slot-sequence ( class slots -- sequence ) [ 1array ] [ [ f 2array ] dip append ] if-empty ; +M: tuple >pprint-sequence + [ class ] [ tuple-slots ] bi class-slot-sequence ; + M: object pprint-narrow? drop f ; M: byte-vector pprint-narrow? drop f ; M: array pprint-narrow? drop t ; diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 99913a803a..718de7e84c 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -73,7 +73,7 @@ SYMBOL: -> : remove-breakpoints ( quot pos -- quot' ) over quotation? [ - 1+ cut [ (remove-breakpoints) ] bi@ + 1 + cut [ (remove-breakpoints) ] bi@ [ -> ] glue ] [ drop @@ -109,4 +109,4 @@ SYMBOL: pprint-string-cells? ] each ] with-row ] each - ] tabular-output nl ; \ No newline at end of file + ] tabular-output nl ; diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index 0e0c7afb82..040b6d8f7c 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -44,7 +44,7 @@ TUPLE: pprinter last-newline line-count indent ; line-limit? [ "..." write pprinter get return ] when - pprinter get [ 1+ ] change-line-count drop + pprinter get [ 1 + ] change-line-count drop nl do-indent ] if ; @@ -209,7 +209,7 @@ M: block short-section ( block -- ) TUPLE: text < section string ; : ( string style -- text ) - over length 1+ \ text new-section + over length 1 + \ text new-section swap >>style swap >>string ; @@ -310,8 +310,8 @@ SYMBOL: next : group-flow ( seq -- newseq ) [ dup length [ - 2dup 1- swap ?nth prev set - 2dup 1+ swap ?nth next set + 2dup 1 - swap ?nth prev set + 2dup 1 + swap ?nth next set swap nth dup split-before dup , split-after ] with each ] { } make { t } split harvest ; diff --git a/basis/quoted-printable/quoted-printable.factor b/basis/quoted-printable/quoted-printable.factor index e82789ccbf..53af3a5178 100644 --- a/basis/quoted-printable/quoted-printable.factor +++ b/basis/quoted-printable/quoted-printable.factor @@ -29,7 +29,7 @@ IN: quoted-printable : take-some ( seqs -- seqs seq ) 0 over [ length + dup 76 >= ] find drop nip - [ 1- cut-slice swap ] [ f swap ] if* concat ; + [ 1 - cut-slice swap ] [ f swap ] if* concat ; : divide-lines ( strings -- strings ) [ dup ] [ take-some ] produce nip ; diff --git a/basis/random/dummy/dummy.factor b/basis/random/dummy/dummy.factor index dadf93fd43..e6661dc078 100644 --- a/basis/random/dummy/dummy.factor +++ b/basis/random/dummy/dummy.factor @@ -8,4 +8,4 @@ M: random-dummy seed-random ( seed obj -- ) (>>i) ; M: random-dummy random-32* ( obj -- r ) - [ dup 1+ ] change-i drop ; + [ dup 1 + ] change-i drop ; diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index a02abbb8ac..966c5b2e60 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -17,7 +17,7 @@ CONSTANT: a uint-array{ 0 HEX: 9908b0df } : y ( n seq -- y ) [ nth-unsafe 31 mask-bit ] - [ [ 1+ ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline + [ [ 1 + ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline : mt[k] ( offset n seq -- ) [ @@ -30,16 +30,16 @@ CONSTANT: a uint-array{ 0 HEX: 9908b0df } [ seq>> [ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each ] - [ [ m 1- ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ] + [ [ m 1 - ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ] bi ] [ 0 >>i drop ] bi ; inline : init-mt-formula ( i seq -- f(seq[i]) ) - dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline + dupd nth dup -30 shift bitxor 1812433253 * + 1 + 32 bits ; inline : init-mt-rest ( seq -- ) - n 1- swap '[ - _ [ init-mt-formula ] [ [ 1+ ] dip set-nth ] 2bi + n 1 - swap '[ + _ [ init-mt-formula ] [ [ 1 + ] dip set-nth ] 2bi ] each ; inline : init-mt-seq ( seed -- seq ) @@ -67,7 +67,7 @@ M: mersenne-twister seed-random ( mt seed -- ) M: mersenne-twister random-32* ( mt -- r ) [ next-index ] [ seq>> nth-unsafe mt-temper ] - [ [ 1+ ] change-i drop ] tri ; + [ [ 1 + ] change-i drop ] tri ; [ [ 32 random-bits ] with-system-random diff --git a/basis/random/random.factor b/basis/random/random.factor index 1962857d57..4c94e87928 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -39,7 +39,7 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; byte-array byte-array>bignum ] [ 3 shift 2^ ] bi / * >integer ; @@ -57,7 +57,7 @@ PRIVATE> : randomize ( seq -- seq ) dup length [ dup 1 > ] - [ [ iota random ] [ 1- ] bi [ pick exchange ] keep ] + [ [ iota random ] [ 1 - ] bi [ pick exchange ] keep ] while drop ; : delete-random ( seq -- elt ) diff --git a/basis/regexp/ast/ast.factor b/basis/regexp/ast/ast.factor index 2916ef7c32..90ab3342f2 100644 --- a/basis/regexp/ast/ast.factor +++ b/basis/regexp/ast/ast.factor @@ -56,7 +56,7 @@ M: at-least : to-times ( term n -- ast ) dup zero? [ 2drop epsilon ] - [ dupd 1- to-times 2array ] + [ dupd 1 - to-times 2array ] if ; M: from-to diff --git a/basis/regexp/compiler/compiler.factor b/basis/regexp/compiler/compiler.factor index 5482734865..d8940bb829 100644 --- a/basis/regexp/compiler/compiler.factor +++ b/basis/regexp/compiler/compiler.factor @@ -35,13 +35,13 @@ M: $ question>quot drop [ { [ length = ] [ ?nth "\r\n" member? ] } 2|| ] ; M: ^ question>quot - drop [ { [ drop zero? ] [ [ 1- ] dip ?nth "\r\n" member? ] } 2|| ] ; + drop [ { [ drop zero? ] [ [ 1 - ] dip ?nth "\r\n" member? ] } 2|| ] ; M: $unix question>quot drop [ { [ length = ] [ ?nth CHAR: \n = ] } 2|| ] ; M: ^unix question>quot - drop [ { [ drop zero? ] [ [ 1- ] dip ?nth CHAR: \n = ] } 2|| ] ; + drop [ { [ drop zero? ] [ [ 1 - ] dip ?nth CHAR: \n = ] } 2|| ] ; M: word-break question>quot drop [ word-break-at? ] ; diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 21439640fe..ba4aa47e7b 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -25,7 +25,7 @@ M: lookahead question>quot ! Returns ( index string -- ? ) M: lookbehind question>quot ! Returns ( index string -- ? ) term>> ast>dfa dfa>reverse-shortest-word - '[ [ 1- ] dip f _ execute ] ; + '[ [ 1 - ] dip f _ execute ] ; : check-string ( string -- string ) ! Make this configurable @@ -38,7 +38,7 @@ M: lookbehind question>quot ! Returns ( index string -- ? ) GENERIC: end/start ( string regexp -- end start ) M: regexp end/start drop length 0 ; -M: reverse-regexp end/start drop length 1- -1 swap ; +M: reverse-regexp end/start drop length 1 - -1 swap ; PRIVATE> @@ -53,12 +53,12 @@ PRIVATE> :: (next-match) ( i string regexp quot: ( i string regexp -- j ) reverse? -- i start end ? ) i string regexp quot call dup [| j | j i j - reverse? [ swap [ 1+ ] bi@ ] when + reverse? [ swap [ 1 + ] bi@ ] when string ] [ drop f f f f ] if ; inline : search-range ( i string reverse? -- seq ) - [ drop dup 1+ -1 ] [ length 1 ] if range boa ; inline + [ drop dup 1 + -1 ] [ length 1 ] if range boa ; inline :: next-match ( i string regexp quot: ( i string regexp -- j ) reverse? -- i start end ? ) f f f f @@ -93,7 +93,7 @@ PRIVATE> [ subseq ] map-matches ; : count-matches ( string regexp -- n ) - [ 0 ] 2dip [ 3drop 1+ ] each-match ; + [ 0 ] 2dip [ 3drop 1 + ] each-match ; dup skip-blank [ [ index-from ] 2keep [ swapd subseq ] - [ 2drop 1+ ] 3bi + [ 2drop 1 + ] 3bi ] change-lexer-column ; : parse-noblank-token ( lexer -- str/f ) @@ -220,4 +220,4 @@ USING: vocabs vocabs.loader ; "prettyprint" vocab [ "regexp.prettyprint" require -] when \ No newline at end of file +] when diff --git a/basis/see/see.factor b/basis/see/see.factor index 206bdbb906..1b3bd4bfb5 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -101,6 +101,7 @@ M: object declarations. drop ; M: word declarations. { POSTPONE: delimiter + POSTPONE: deprecated POSTPONE: inline POSTPONE: recursive POSTPONE: foldable @@ -229,4 +230,4 @@ PRIVATE> ] { } make prune ; : see-methods ( word -- ) - methods see-all nl ; \ No newline at end of file + methods see-all nl ; diff --git a/basis/sequences/complex/complex.factor b/basis/sequences/complex/complex.factor index 93f9727f75..730689eb4f 100644 --- a/basis/sequences/complex/complex.factor +++ b/basis/sequences/complex/complex.factor @@ -18,8 +18,8 @@ PRIVATE> M: complex-sequence length seq>> length -1 shift ; M: complex-sequence nth-unsafe - complex@ [ nth-unsafe ] [ [ 1+ ] dip nth-unsafe ] 2bi rect> ; + complex@ [ nth-unsafe ] [ [ 1 + ] dip nth-unsafe ] 2bi rect> ; M: complex-sequence set-nth-unsafe complex@ [ [ real-part ] [ ] [ ] tri* set-nth-unsafe ] - [ [ imaginary-part ] [ 1+ ] [ ] tri* set-nth-unsafe ] 3bi ; + [ [ imaginary-part ] [ 1 + ] [ ] tri* set-nth-unsafe ] 3bi ; diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor index b7e395fa35..2b4294bda4 100644 --- a/basis/serialize/serialize.factor +++ b/basis/serialize/serialize.factor @@ -47,11 +47,11 @@ M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ; ! The last case is needed because a very large number would ! otherwise be confused with a small number. : serialize-cell ( n -- ) - dup zero? [ drop 0 write1 ] [ + [ 0 write1 ] [ dup HEX: 7e <= [ HEX: 80 bitor write1 ] [ - dup log2 8 /i 1+ + dup log2 8 /i 1 + dup HEX: 7f >= [ HEX: ff write1 dup serialize-cell @@ -60,7 +60,7 @@ M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ; ] if >be write ] if - ] if ; + ] if-zero ; : deserialize-cell ( -- n ) read1 { @@ -79,12 +79,12 @@ M: f (serialize) ( obj -- ) drop CHAR: n write1 ; M: integer (serialize) ( obj -- ) - dup zero? [ - drop CHAR: z write1 + [ + CHAR: z write1 ] [ dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1 serialize-cell - ] if ; + ] if-zero ; M: float (serialize) ( obj -- ) CHAR: F write1 @@ -295,4 +295,4 @@ PRIVATE> binary [ deserialize ] with-byte-reader ; : object>bytes ( obj -- bytes ) - binary [ serialize ] with-byte-writer ; \ No newline at end of file + binary [ serialize ] with-byte-writer ; diff --git a/basis/sorting/functor/functor.factor b/basis/sorting/functor/functor.factor index 7f46af4c92..8e9ea6a9ea 100644 --- a/basis/sorting/functor/functor.factor +++ b/basis/sorting/functor/functor.factor @@ -10,7 +10,7 @@ NAME>=< DEFINES ${NAME}>=< WHERE -: NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ; +: NAME<=> ( obj1 obj2 -- <=> ) QUOT compare ; : NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ; ;FUNCTOR diff --git a/basis/sorting/insertion/insertion.factor b/basis/sorting/insertion/insertion.factor index 8bc12e2704..78b1493920 100644 --- a/basis/sorting/insertion/insertion.factor +++ b/basis/sorting/insertion/insertion.factor @@ -4,9 +4,9 @@ IN: sorting.insertion = [ - n n 1- seq exchange - seq quot n 1- insert + n n 1 - [ seq nth quot call ] bi@ >= [ + n n 1 - seq exchange + seq quot n 1 - insert ] unless ] unless ; inline recursive PRIVATE> diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index e7e891fede..b49dfa35e4 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: functors sequences sequences.private kernel words classes math alien alien.c-types byte-arrays accessors -specialized-arrays ; +specialized-arrays prettyprint.custom ; IN: specialized-arrays.direct.functor FUNCTOR: define-direct-array ( T -- ) @@ -10,6 +10,7 @@ FUNCTOR: define-direct-array ( T -- ) A' IS ${T}-array >A' IS >${T}-array IS <${A'}> +A'{ IS ${A'}{ A DEFINES-CLASS direct-${T}-array DEFINES <${A}> @@ -30,6 +31,12 @@ M: A set-nth-unsafe underlying>> SET-NTH call ; M: A like drop dup A instance? [ >A' ] unless ; M: A new-sequence drop ; +M: A pprint-delims drop \ A'{ \ } ; + +M: A >pprint-sequence ; + +M: A pprint* pprint-object ; + INSTANCE: A sequence ;FUNCTOR diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 1c855be1a4..06b9aef17d 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -39,19 +39,19 @@ TUPLE: A dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless swap A boa ; inline -M: A clone [ length>> ] [ underlying>> clone ] bi A boa ; +M: A clone [ length>> ] [ underlying>> clone ] bi A boa ; inline -M: A length length>> ; +M: A length length>> ; inline -M: A nth-unsafe underlying>> NTH call ; +M: A nth-unsafe underlying>> NTH call ; inline -M: A set-nth-unsafe underlying>> SET-NTH call ; +M: A set-nth-unsafe underlying>> SET-NTH call ; inline -: >A ( seq -- specialized-array ) A new clone-like ; inline +: >A ( seq -- specialized-array ) A new clone-like ; -M: A like drop dup A instance? [ >A ] unless ; +M: A like drop dup A instance? [ >A ] unless ; inline -M: A new-sequence drop (A) ; +M: A new-sequence drop (A) ; inline M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ; @@ -60,9 +60,9 @@ M: A resize [ T heap-size * ] [ underlying>> ] bi* resize-byte-array ] 2bi - A boa ; + A boa ; inline -M: A byte-length underlying>> length ; +M: A byte-length underlying>> length ; inline M: A pprint-delims drop \ A{ \ } ; diff --git a/basis/splitting/monotonic/monotonic.factor b/basis/splitting/monotonic/monotonic.factor index 3dec6130de..3641345a3e 100644 --- a/basis/splitting/monotonic/monotonic.factor +++ b/basis/splitting/monotonic/monotonic.factor @@ -29,10 +29,10 @@ PRIVATE> [ length ] [ ] [ 1 over change-circular-start ] tri [ @ not [ , ] [ drop ] if ] 3each ] { } make - dup empty? [ over length 1- prefix ] when -1 prefix 2 clump + dup empty? [ over length 1 - prefix ] when -1 prefix 2 clump swap ] dip - '[ first2 [ 1+ ] bi@ _ _ boa ] map ; inline + '[ first2 [ 1 + ] bi@ _ _ boa ] map ; inline PRIVATE> diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 338b052316..5411c885ad 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -5,7 +5,7 @@ parser sequences strings vectors words quotations effects classes continuations assocs combinators compiler.errors accessors math.order definitions sets hints macros stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values -stack-checker.recursive-state ; +stack-checker.recursive-state summary ; IN: stack-checker.backend : push-d ( obj -- ) meta-d push ; @@ -98,8 +98,10 @@ M: object apply-object push-literal ; : time-bomb ( error -- ) '[ _ throw ] infer-quot-here ; -: bad-call ( -- ) - "call must be given a callable" time-bomb ; +ERROR: bad-call obj ; + +M: bad-call summary + drop "call must be given a callable" ; : infer-literal-quot ( literal -- ) dup recursive-quotation? [ @@ -110,7 +112,7 @@ M: object apply-object push-literal ; [ [ recursion>> ] keep add-local-quotation ] bi infer-quot ] [ - drop bad-call + value>> \ bad-call boa time-bomb ] if ] if ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 6959e32452..ea8f6f5f49 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -134,13 +134,17 @@ M: object infer-call* \ compose [ infer-compose ] "special" set-word-prop +ERROR: bad-executable obj ; + +M: bad-executable summary + drop "execute must be given a word" ; + : infer-execute ( -- ) pop-literal nip dup word? [ apply-object ] [ - drop - "execute must be given a word" time-bomb + \ bad-executable boa time-bomb ] if ; \ execute [ infer-execute ] "special" set-word-prop @@ -149,11 +153,13 @@ M: object infer-call* : infer- ( -- ) \ - peek-d literal value>> second 1+ { tuple } + peek-d literal value>> second 1 + { tuple } apply-word/effect ; \ [ infer- ] "special" set-word-prop +\ t "flushable" set-word-prop + : infer-effect-unsafe ( word -- ) pop-literal nip add-effect-input diff --git a/basis/suffix-arrays/suffix-arrays.factor b/basis/suffix-arrays/suffix-arrays.factor index f4bd563481..931cb36ea9 100755 --- a/basis/suffix-arrays/suffix-arrays.factor +++ b/basis/suffix-arrays/suffix-arrays.factor @@ -17,7 +17,7 @@ IN: suffix-arrays : from-to ( index begin suffix-array -- from/f to/f ) swap '[ _ head? not ] - [ find-last-from drop dup [ 1+ ] when ] + [ find-last-from drop dup [ 1 + ] when ] [ find-from drop ] 3bi ; : ( from/f to/f seq -- slice ) diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor index 79aef90bea..c21e9e0c60 100644 --- a/basis/tools/annotations/annotations-tests.factor +++ b/basis/tools/annotations/annotations-tests.factor @@ -10,7 +10,7 @@ IN: tools.annotations.tests ! erg's bug GENERIC: some-generic ( a -- b ) -M: integer some-generic 1+ ; +M: integer some-generic 1 + ; [ 4 ] [ 3 some-generic ] unit-test @@ -18,7 +18,7 @@ M: integer some-generic 1+ ; [ 4 ] [ 3 some-generic ] unit-test -[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval( -- ) ] unit-test +[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1 - ;" eval( -- ) ] unit-test [ 2 ] [ 3 some-generic ] unit-test @@ -59,4 +59,4 @@ M: object my-generic ; : some-code ( -- ) f my-generic drop ; -[ ] [ some-code ] unit-test \ No newline at end of file +[ ] [ some-code ] unit-test diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index fb664c495c..7b9c8b43bc 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -9,7 +9,7 @@ IN: tools.completion :: (fuzzy) ( accum i full ch -- accum i full ? ) ch i full index-from [ :> i i accum push - accum i 1+ full t + accum i 1 + full t ] [ f -1 full f ] if* ; @@ -23,7 +23,7 @@ IN: tools.completion [ 2dup number= [ drop ] [ nip V{ } clone pick push ] if - 1+ + 1 + ] keep pick last push ] each ; @@ -33,9 +33,9 @@ IN: tools.completion : score-1 ( i full -- n ) { { [ over zero? ] [ 2drop 10 ] } - { [ 2dup length 1- number= ] [ 2drop 4 ] } - { [ 2dup [ 1- ] dip nth Letter? not ] [ 2drop 10 ] } - { [ 2dup [ 1+ ] dip nth Letter? not ] [ 2drop 4 ] } + { [ 2dup length 1 - number= ] [ 2drop 4 ] } + { [ 2dup [ 1 - ] dip nth Letter? not ] [ 2drop 10 ] } + { [ 2dup [ 1 + ] dip nth Letter? not ] [ 2drop 4 ] } [ 2drop 1 ] } cond ; diff --git a/basis/tools/deprecation/authors.txt b/basis/tools/deprecation/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/basis/tools/deprecation/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/basis/tools/deprecation/deprecation-docs.factor b/basis/tools/deprecation/deprecation-docs.factor new file mode 100644 index 0000000000..28d771c170 --- /dev/null +++ b/basis/tools/deprecation/deprecation-docs.factor @@ -0,0 +1,13 @@ +! (c)2009 Joe Groff bsd license +USING: help.markup help.syntax kernel words ; +IN: tools.deprecation + +HELP: :deprecations +{ $description "Prints all deprecation notes." } ; + +ARTICLE: "tools.deprecation" "Deprecation tracking" +"Factor's core syntax defines a " { $link POSTPONE: deprecated } " word that can be applied to words to mark them as deprecated. When the " { $vocab-link "tools.deprecation" } " vocabulary is loaded, notes will be collected and reported by the " { $link "tools.errors" } " mechanism when deprecated words are used to define other words." +{ $subsection POSTPONE: deprecated } +{ $subsection :deprecations } ; + +ABOUT: "tools.deprecation" diff --git a/basis/tools/deprecation/deprecation.factor b/basis/tools/deprecation/deprecation.factor new file mode 100644 index 0000000000..90dba554cb --- /dev/null +++ b/basis/tools/deprecation/deprecation.factor @@ -0,0 +1,73 @@ +! (c)2009 Joe Groff bsd license +USING: accessors arrays assocs compiler.units +debugger init io kernel namespaces prettyprint sequences +source-files.errors summary tools.crossref +tools.crossref.private tools.errors words ; +IN: tools.deprecation + +SYMBOL: +deprecation-note+ +SYMBOL: deprecation-notes + +deprecation-notes [ H{ } clone ] initialize + +TUPLE: deprecation-note < source-file-error ; + +M: deprecation-note error-type drop +deprecation-note+ ; + +TUPLE: deprecated-usages asset usages ; + +: :deprecations ( -- ) + deprecation-notes get-global values errors. ; + +T{ error-type + { type +deprecation-note+ } + { word ":deprecations" } + { plural "deprecated word usages" } + { icon "vocab:ui/tools/error-list/icons/deprecation-note.tiff" } + { quot [ deprecation-notes get values ] } + { forget-quot [ deprecation-notes get delete-at ] } +} define-error-type + +: ( error word -- deprecation-note ) + \ deprecation-note ; + +: deprecation-note ( word usages -- ) + [ deprecated-usages boa ] + [ drop ] + [ drop deprecation-notes get-global set-at ] 2tri ; + +: clear-deprecation-note ( word -- ) + deprecation-notes get-global delete-at ; + +: check-deprecations ( word -- ) + dup "forgotten" word-prop + [ clear-deprecation-note ] [ + dup def>> uses [ deprecated? ] filter + [ clear-deprecation-note ] [ >array deprecation-note ] if-empty + ] if ; + +M: deprecated-usages summary + drop "Deprecated words used" ; + +M: deprecated-usages error. + "The definition of " write + dup asset>> pprint + " uses these deprecated words:" write nl + usages>> [ " " write pprint nl ] each ; + +SINGLETON: deprecation-observer + +: initialize-deprecation-notes ( -- ) + get-crossref [ drop deprecated? ] assoc-filter + values [ keys [ check-deprecations ] each ] each ; + +M: deprecation-observer definitions-changed + drop keys [ word? ] filter + dup [ deprecated? ] filter empty? + [ [ check-deprecations ] each ] + [ drop initialize-deprecation-notes ] if ; + +[ \ deprecation-observer add-definition-observer ] +"tools.deprecation" add-init-hook + +initialize-deprecation-notes diff --git a/basis/tools/deprecation/summary.txt b/basis/tools/deprecation/summary.txt new file mode 100644 index 0000000000..513938d044 --- /dev/null +++ b/basis/tools/deprecation/summary.txt @@ -0,0 +1 @@ +Tracking usage of deprecated words diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor index 761dbd816a..92e7541616 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -54,17 +54,17 @@ TUPLE: CLASS-array [ \ CLASS [ tuple-prototype concat ] [ tuple-arity ] bi ] keep \ CLASS-array boa ; inline -M: CLASS-array length length>> ; +M: CLASS-array length length>> ; inline -M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; +M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; inline -M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; +M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; inline -M: CLASS-array new-sequence drop ; +M: CLASS-array new-sequence drop ; inline : >CLASS-array ( seq -- tuple-array ) 0 clone-like ; -M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; +M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; inline INSTANCE: CLASS-array sequence diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 03a86fe25f..f23989a1e2 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -202,7 +202,7 @@ PRIVATE> lf>crlf [ utf16n string>alien EmptyClipboard win32-error=0/f - GMEM_MOVEABLE over length 1+ GlobalAlloc + GMEM_MOVEABLE over length 1 + GlobalAlloc dup win32-error=0/f dup GlobalLock dup win32-error=0/f diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index aa2b9ca58c..b1b82a0542 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -495,7 +495,7 @@ TUPLE: multiline-editor < editor ; ; +: page-elt ( editor -- editor element ) dup visible-lines 1 - ; PRIVATE> @@ -526,7 +526,7 @@ PRIVATE> : this-line-and-next ( document line -- start end ) [ nip 0 swap 2array ] - [ [ nip 1+ ] [ 1+ swap doc-line length ] 2bi 2array ] + [ [ nip 1 + ] [ 1 + swap doc-line length ] 2bi 2array ] 2bi ; : last-line? ( document line -- ? ) diff --git a/basis/ui/gadgets/frames/frames.factor b/basis/ui/gadgets/frames/frames.factor index 34f4686518..168fb4bb11 100644 --- a/basis/ui/gadgets/frames/frames.factor +++ b/basis/ui/gadgets/frames/frames.factor @@ -23,7 +23,7 @@ M: glue pref-dim* drop { 0 0 } ; [ '[ [ dim>> ] [ gap>> ] [ filled-cell>> ] tri _ tri@ ] dip ] dip call ; inline : available-space ( pref-dim gap dims -- avail ) - length 1+ * [-] ; inline + length 1 + * [-] ; inline : -center) ( pref-dim gap filled-cell dims -- ) [ nip available-space ] 2keep [ remove-nth sum [-] ] 2keep set-nth ; inline @@ -46,4 +46,4 @@ M: frame layout* [ ] dip new-grid ; inline : ( cols rows -- frame ) - frame new-frame ; \ No newline at end of file + frame new-frame ; diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor index ade5c8101e..d7f77d9e54 100644 --- a/basis/ui/gadgets/gadgets-tests.factor +++ b/basis/ui/gadgets/gadgets-tests.factor @@ -78,10 +78,10 @@ TUPLE: mock-gadget < gadget graft-called ungraft-called ; mock-gadget new 0 >>graft-called 0 >>ungraft-called ; M: mock-gadget graft* - [ 1+ ] change-graft-called drop ; + [ 1 + ] change-graft-called drop ; M: mock-gadget ungraft* - [ 1+ ] change-ungraft-called drop ; + [ 1 + ] change-ungraft-called drop ; ! We can't print to output-stream here because that might be a pane ! stream, and our graft-queue rebinding here would be captured @@ -122,7 +122,7 @@ M: mock-gadget ungraft* 3 [ over >>model "g" get over add-gadget drop - swap 1+ number>string set + swap 1 + number>string set ] each ; : status-flags ( -- seq ) diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 0295012584..26d0fee2e3 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -395,4 +395,4 @@ M: f request-focus-on 2drop ; USING: vocabs vocabs.loader ; -"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when \ No newline at end of file +"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when diff --git a/basis/ui/gadgets/line-support/line-support.factor b/basis/ui/gadgets/line-support/line-support.factor index b9fe10c530..3292e3e6c5 100644 --- a/basis/ui/gadgets/line-support/line-support.factor +++ b/basis/ui/gadgets/line-support/line-support.factor @@ -28,10 +28,10 @@ M: line-gadget line-height font>> font-metrics height>> ceiling ; : line>y ( n gadget -- y ) line-height * >integer ; : validate-line ( m gadget -- n ) - control-value [ drop f ] [ length 1- min 0 max ] if-empty ; + control-value [ drop f ] [ length 1 - min 0 max ] if-empty ; : valid-line? ( n gadget -- ? ) - control-value length 1- 0 swap between? ; + control-value length 1 - 0 swap between? ; : visible-line ( gadget quot -- n ) '[ @@ -43,7 +43,7 @@ M: line-gadget line-height font>> font-metrics height>> ceiling ; [ loc>> ] visible-line ; : last-visible-line ( gadget -- n ) - [ [ loc>> ] [ dim>> ] bi v+ ] visible-line 1+ ; + [ [ loc>> ] [ dim>> ] bi v+ ] visible-line 1 + ; : each-slice-index ( from to seq quot -- ) [ [ ] [ drop [a,b) ] 3bi ] dip 2each ; inline @@ -85,4 +85,4 @@ M: line-gadget pref-viewport-dim 2bi 2array ; : visible-lines ( gadget -- n ) - [ visible-dim second ] [ line-height ] bi /i ; \ No newline at end of file + [ visible-dim second ] [ line-height ] bi /i ; diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index 504427827f..ccc5550adb 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -413,10 +413,10 @@ PRIVATE> 0 select-row ; : last-row ( table -- ) - dup control-value length 1- select-row ; + dup control-value length 1 - select-row ; : prev/next-page ( table n -- ) - over visible-lines 1- * prev/next-row ; + over visible-lines 1 - * prev/next-row ; : previous-page ( table -- ) -1 prev/next-page ; @@ -503,4 +503,4 @@ M: table viewport-column-header dup renderer>> column-titles [ ] [ drop f ] if ; -PRIVATE> \ No newline at end of file +PRIVATE> diff --git a/basis/ui/pens/gradient/gradient.factor b/basis/ui/pens/gradient/gradient.factor index 485015b898..042e2d3446 100644 --- a/basis/ui/pens/gradient/gradient.factor +++ b/basis/ui/pens/gradient/gradient.factor @@ -14,7 +14,7 @@ TUPLE: gradient < caching-pen colors last-vertices last-colors ; :: 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 dup 1 - v/n [ v*n ] with map swap [ over v+ 2array ] curry map concat concat >float-array ; @@ -43,4 +43,4 @@ M: gradient draw-interior [ colors>> draw-gradient ] } cleave ; -M: gradient pen-background 2drop transparent ; \ No newline at end of file +M: gradient pen-background 2drop transparent ; diff --git a/basis/ui/text/uniscribe/uniscribe.factor b/basis/ui/text/uniscribe/uniscribe.factor index d56da86b86..d5e836044b 100755 --- a/basis/ui/text/uniscribe/uniscribe.factor +++ b/basis/ui/text/uniscribe/uniscribe.factor @@ -25,7 +25,7 @@ M: uniscribe-renderer draw-string ( font string -- ) M: uniscribe-renderer x>offset ( x font string -- n ) [ 2drop 0 ] [ - cached-script-string x>line-offset 0 = [ 1+ ] unless + cached-script-string x>line-offset 0 = [ 1 + ] unless ] if-empty ; M: uniscribe-renderer offset>x ( n font string -- x ) diff --git a/basis/ui/tools/error-list/error-list-docs.factor b/basis/ui/tools/error-list/error-list-docs.factor index ec96ac4078..07c92224b2 100644 --- a/basis/ui/tools/error-list/error-list-docs.factor +++ b/basis/ui/tools/error-list/error-list-docs.factor @@ -14,6 +14,7 @@ $nl { { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } } { { $image "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } "Help lint failure" { $link "help.lint" } } { { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } } + { { $image "vocab:ui/tools/error-list/icons/deprecation-note.tiff" } "Deprecated words used" { $link "tools.deprecation" } } } ; ABOUT: "ui.tools.error-list" diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index 1193ca237c..a1da59fe39 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -165,8 +165,8 @@ error-display "toolbar" f { { 5 5 } >>gap error-list f track-add error-list source-file-table>> "Source files" 1/4 track-add - error-list error-table>> "Errors" 1/2 track-add - error-list error-display>> "Details" 1/4 track-add + error-list error-table>> "Errors" 1/4 track-add + error-list error-display>> "Details" 1/2 track-add { 5 5 } 1 track-add ; M: error-list-gadget focusable-child* diff --git a/basis/ui/tools/error-list/icons/deprecation-note.tiff b/basis/ui/tools/error-list/icons/deprecation-note.tiff new file mode 100644 index 0000000000..1eef0ef52c Binary files /dev/null and b/basis/ui/tools/error-list/icons/deprecation-note.tiff differ diff --git a/basis/ui/tools/listener/history/history.factor b/basis/ui/tools/listener/history/history.factor index 5e03ab21ad..dae9e26dc8 100644 --- a/basis/ui/tools/listener/history/history.factor +++ b/basis/ui/tools/listener/history/history.factor @@ -10,7 +10,7 @@ TUPLE: history document elements index ; V{ } clone 0 history boa ; : history-add ( history -- input ) - dup elements>> length 1+ >>index + dup elements>> length 1 + >>index [ document>> doc-string [ ] [ empty? ] bi ] keep '[ [ _ elements>> push ] keep ] unless ; @@ -32,7 +32,7 @@ TUPLE: history document elements index ; [ set-doc-string ] [ clear-undo drop ] 2bi ; : change-history-index ( history i -- ) - over elements>> length 1- + over elements>> length 1 - '[ _ + _ min 0 max ] change-index drop ; : history-recall ( history i -- ) diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index e34e354a87..4b9a4a1ef3 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -170,7 +170,7 @@ M: interactor stream-read1 M: interactor dispose drop ; : go-to-error ( interactor error -- ) - [ line>> 1- ] [ column>> ] bi 2array + [ line>> 1 - ] [ column>> ] bi 2array over set-caret mark>caret ; @@ -444,4 +444,4 @@ M: listener-gadget graft* [ call-next-method ] [ restart-listener ] bi ; M: listener-gadget ungraft* - [ com-end ] [ call-next-method ] bi ; \ No newline at end of file + [ com-end ] [ call-next-method ] bi ; diff --git a/basis/ui/traverse/traverse.factor b/basis/ui/traverse/traverse.factor index 9df084210d..11c2a48a2a 100644 --- a/basis/ui/traverse/traverse.factor +++ b/basis/ui/traverse/traverse.factor @@ -35,7 +35,7 @@ TUPLE: node value children ; ] [ [ [ traverse-step traverse-from-path ] - [ tuck children>> swap first 1+ tail-slice % ] 2bi + [ tuck children>> swap first 1 + tail-slice % ] 2bi ] make-node ] if ] if ; @@ -44,7 +44,7 @@ TUPLE: node value children ; traverse-step traverse-from-path ; : (traverse-middle) ( frompath topath gadget -- ) - [ first 1+ ] [ first ] [ children>> ] tri* % ; + [ first 1 + ] [ first ] [ children>> ] tri* % ; : traverse-post ( topath gadget -- ) traverse-step traverse-to-path ; @@ -94,4 +94,4 @@ M: array leaves* '[ _ leaves* ] each ; M: gadget leaves* conjoin ; -: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ; \ No newline at end of file +: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ; diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 2486e701c0..aa3c549cf0 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -26,7 +26,7 @@ SYMBOL: windows #! etc. swap 2array windows get-global push windows get-global dup length 1 > - [ [ length 1- dup 1- ] keep exchange ] [ drop ] if ; + [ [ length 1 - dup 1 - ] keep exchange ] [ drop ] if ; : unregister-window ( handle -- ) windows [ [ first = not ] with filter ] change-global ; diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index ed96842c41..7c7b8a1f50 100644 --- a/basis/unicode/breaks/breaks.factor +++ b/basis/unicode/breaks/breaks.factor @@ -93,7 +93,7 @@ PRIVATE> : first-grapheme ( str -- i ) unclip-slice grapheme-class over [ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop - nip swap length or 1+ ; + nip swap length or 1 + ; : first-grapheme-from ( start str -- i ) over tail-slice first-grapheme + ; @@ -192,13 +192,13 @@ to: word-table swap [ format/extended? not ] find-from drop ; : walk-up ( str i -- j ) - dupd 1+ (walk-up) [ 1+ (walk-up) ] [ drop f ] if* ; + dupd 1 + (walk-up) [ 1 + (walk-up) ] [ drop f ] if* ; : (walk-down) ( str i -- j ) swap [ format/extended? not ] find-last-from drop ; : walk-down ( str i -- j ) - dupd (walk-down) [ 1- (walk-down) ] [ drop f ] if* ; + dupd (walk-down) [ 1 - (walk-down) ] [ drop f ] if* ; : word-break? ( str i table-entry -- ? ) { @@ -226,7 +226,7 @@ PRIVATE> : first-word ( str -- i ) [ unclip-slice word-break-prop over ] keep '[ swap _ word-break-next ] assoc-find 2drop - nip swap length or 1+ ; + nip swap length or 1 + ; : >words ( str -- words ) [ first-word ] >pieces ; @@ -234,7 +234,7 @@ PRIVATE> diff --git a/basis/unicode/normalize/normalize-tests.factor b/basis/unicode/normalize/normalize-tests.factor index cea880c0b0..ff2c808fde 100644 --- a/basis/unicode/normalize/normalize-tests.factor +++ b/basis/unicode/normalize/normalize-tests.factor @@ -27,7 +27,7 @@ IN: unicode.normalize.tests :: assert= ( test spec quot -- ) spec [ [ - [ 1- test nth ] bi@ + [ 1 - test nth ] bi@ [ 1quotation ] [ quot curry ] bi* unit-test ] with each ] assoc-each ; diff --git a/basis/unicode/normalize/normalize.factor b/basis/unicode/normalize/normalize.factor index aca96a5694..b1cba07511 100644 --- a/basis/unicode/normalize/normalize.factor +++ b/basis/unicode/normalize/normalize.factor @@ -108,7 +108,7 @@ HINTS: string-append string string ; ! Normalization -- Composition : initial-medial? ( str i -- ? ) - { [ swap nth initial? ] [ 1+ swap ?nth medial? ] } 2&& ; + { [ swap nth initial? ] [ 1 + swap ?nth medial? ] } 2&& ; : --final? ( str i -- ? ) 2 + swap ?nth final? ; @@ -124,7 +124,7 @@ HINTS: string-append string string ; : compose-jamo ( str i -- str i ) 2dup initial-medial? [ 2dup --final? [ imf, ] [ im, ] if - ] [ 2dup swap nth , 1+ ] if ; + ] [ 2dup swap nth , 1 + ] if ; : pass-combining ( str -- str i ) dup [ non-starter? not ] find drop @@ -136,7 +136,7 @@ TUPLE: compose-state i str char after last-class ; : get-str ( state i -- ch ) swap [ i>> + ] [ str>> ] bi ?nth ; inline : current ( state -- ch ) 0 get-str ; inline -: to ( state -- state ) [ 1+ ] change-i ; inline +: to ( state -- state ) [ 1 + ] change-i ; inline : push-after ( ch state -- state ) [ ?push ] change-after ; inline :: try-compose ( state new-char current-class -- state ) @@ -177,8 +177,8 @@ DEFER: compose-iter :: (compose) ( str i -- ) i str ?nth [ dup jamo? [ drop str i compose-jamo ] [ - i 1+ str ?nth combining-class - [ str i 1+ compose-combining ] [ , str i 1+ ] if + i 1 + str ?nth combining-class + [ str i 1 + compose-combining ] [ , str i 1 + ] if ] if (compose) ] when* ; inline recursive diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index 91feae6471..eba0e4976f 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -64,7 +64,7 @@ PRIVATE> #! first group is -1337, legacy unix code -1337 NGROUPS_MAX [ 4 * ] keep [ getgrouplist io-error ] 2keep - [ 4 tail-slice ] [ *int 1- ] bi* >groups ; + [ 4 tail-slice ] [ *int 1 - ] bi* >groups ; PRIVATE> diff --git a/basis/unix/process/process.factor b/basis/unix/process/process.factor index da8b1e63e3..131d8dda5d 100644 --- a/basis/unix/process/process.factor +++ b/basis/unix/process/process.factor @@ -80,7 +80,7 @@ CONSTANT: WNOWAIT HEX: 1000000 HEX: ff00 bitand -8 shift ; inline : WIFSIGNALED ( status -- ? ) - HEX: 7f bitand 1+ -1 shift 0 > ; inline + HEX: 7f bitand 1 + -1 shift 0 > ; inline : WCOREFLAG ( -- value ) HEX: 80 ; inline diff --git a/basis/unrolled-lists/unrolled-lists.factor b/basis/unrolled-lists/unrolled-lists.factor index bd4a2c1114..9e2c9539c6 100644 --- a/basis/unrolled-lists/unrolled-lists.factor +++ b/basis/unrolled-lists/unrolled-lists.factor @@ -45,7 +45,7 @@ M: unrolled-list clear-deque : ( elt front -- node ) [ unroll-factor 0 - [ unroll-factor 1- swap set-nth ] keep f + [ unroll-factor 1 - swap set-nth ] keep f ] dip [ node boa dup ] keep dup [ (>>prev) ] [ 2drop ] if ; inline @@ -55,12 +55,12 @@ M: unrolled-list clear-deque ] [ dup front>> >>back ] if* drop ; inline : push-front/new ( elt list -- ) - unroll-factor 1- >>front-pos + unroll-factor 1 - >>front-pos [ ] change-front normalize-back ; inline : push-front/existing ( elt list front -- ) - [ [ 1- ] change-front-pos ] dip + [ [ 1 - ] change-front-pos ] dip [ front-pos>> ] [ data>> ] bi* set-nth-unsafe ; inline M: unrolled-list push-front* @@ -81,12 +81,12 @@ M: unrolled-list peek-front : pop-front/existing ( list front -- ) [ dup front-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe - [ 1+ ] change-front-pos + [ 1 + ] change-front-pos drop ; inline M: unrolled-list pop-front* dup front>> [ empty-unrolled-list ] unless* - over front-pos>> unroll-factor 1- eq? + over front-pos>> unroll-factor 1 - eq? [ pop-front/new ] [ pop-front/existing ] if ; : ( elt back -- node ) @@ -106,8 +106,8 @@ M: unrolled-list pop-front* normalize-front ; inline : push-back/existing ( elt list back -- ) - [ [ 1+ ] change-back-pos ] dip - [ back-pos>> 1- ] [ data>> ] bi* set-nth-unsafe ; inline + [ [ 1 + ] change-back-pos ] dip + [ back-pos>> 1 - ] [ data>> ] bi* set-nth-unsafe ; inline M: unrolled-list push-back* dup [ back>> ] [ back-pos>> unroll-factor eq? not ] bi @@ -116,7 +116,7 @@ M: unrolled-list push-back* M: unrolled-list peek-back dup back>> - [ [ back-pos>> 1- ] dip data>> nth-unsafe ] + [ [ back-pos>> 1 - ] dip data>> nth-unsafe ] [ empty-unrolled-list ] if* ; @@ -126,7 +126,7 @@ M: unrolled-list peek-back dup back>> [ normalize-front ] [ f >>front drop ] if ; inline : pop-back/existing ( list back -- ) - [ [ 1- ] change-back-pos ] dip + [ [ 1 - ] change-back-pos ] dip [ dup back-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe drop ; inline diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor index 8e11dec431..f87c21d2ff 100644 --- a/basis/urls/encoding/encoding.factor +++ b/basis/urls/encoding/encoding.factor @@ -57,7 +57,7 @@ PRIVATE> 2dup length 2 - >= [ 2drop ] [ - [ 1+ dup 2 + ] dip subseq hex> [ , ] when* + [ 1 + dup 2 + ] dip subseq hex> [ , ] when* ] if ; : url-decode-% ( index str -- index str ) @@ -70,7 +70,7 @@ PRIVATE> 2dup nth dup CHAR: % = [ drop url-decode-% [ 3 + ] dip ] [ - , [ 1+ ] dip + , [ 1 + ] dip ] if url-decode-iter ] if ; diff --git a/basis/values/values-tests.factor b/basis/values/values-tests.factor index 6ad5e7dee6..74c63e3d8f 100644 --- a/basis/values/values-tests.factor +++ b/basis/values/values-tests.factor @@ -5,5 +5,5 @@ VALUE: foo [ f ] [ foo ] unit-test [ ] [ 3 to: foo ] unit-test [ 3 ] [ foo ] unit-test -[ ] [ \ foo [ 1+ ] change-value ] unit-test +[ ] [ \ foo [ 1 + ] change-value ] unit-test [ 4 ] [ foo ] unit-test diff --git a/basis/vectors/functor/functor.factor b/basis/vectors/functor/functor.factor index 47a6c2090a..b70c7c5050 100644 --- a/basis/vectors/functor/functor.factor +++ b/basis/vectors/functor/functor.factor @@ -18,11 +18,11 @@ TUPLE: V { underlying A } { length array-capacity } ; M: V like drop dup V instance? [ dup A instance? [ dup length V boa ] [ >V ] if - ] unless ; + ] unless ; inline -M: V new-sequence drop [ ] [ >fixnum ] bi V boa ; +M: V new-sequence drop [ ] [ >fixnum ] bi V boa ; inline -M: A new-resizable drop ; +M: A new-resizable drop ; inline M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; diff --git a/basis/vlists/vlists.factor b/basis/vlists/vlists.factor index ae106cbf93..79870b483f 100644 --- a/basis/vlists/vlists.factor +++ b/basis/vlists/vlists.factor @@ -28,13 +28,13 @@ PRIVATE> M: vlist ppush >vlist< 2dup length = [ unshare ] unless - [ [ 1+ swap ] dip push ] keep vlist boa ; + [ [ 1 + swap ] dip push ] keep vlist boa ; ERROR: empty-vlist-error ; M: vlist ppop [ empty-vlist-error ] - [ [ length>> 1- ] [ vector>> ] bi vlist boa ] if-empty ; + [ [ length>> 1 - ] [ vector>> ] bi vlist boa ] if-empty ; M: vlist clone [ length>> ] [ vector>> >vector ] bi vlist boa ; @@ -65,7 +65,7 @@ M: valist assoc-size vlist>> length 2/ ; : valist-at ( key i array -- value ? ) over 0 >= [ 3dup nth-unsafe = [ - [ 1+ ] dip nth-unsafe nip t + [ 1 + ] dip nth-unsafe nip t ] [ [ 2 - ] dip valist-at ] if diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index 9d52378da9..beac4b6c27 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -28,7 +28,7 @@ unless "windows.com.wrapper.callbacks" create-vocab drop : (next-vtbl-counter) ( -- n ) - +vtbl-counter+ [ 1+ dup ] change ; + +vtbl-counter+ [ 1 + dup ] change ; : com-unwrap ( wrapped -- object ) +wrapped-objects+ get-global at* @@ -59,7 +59,7 @@ unless : (make-add-ref) ( interfaces -- quot ) length "void*" heap-size * '[ _ - [ alien-unsigned-4 1+ dup ] + [ alien-unsigned-4 1 + dup ] [ set-alien-unsigned-4 ] 2bi ] ; @@ -68,7 +68,7 @@ unless length "void*" heap-size * '[ _ [ drop ] - [ alien-unsigned-4 1- dup ] + [ alien-unsigned-4 1 - dup ] [ set-alien-unsigned-4 ] 2tri dup 0 = [ swap (free-wrapped-object) ] [ nip ] if @@ -101,7 +101,7 @@ unless "windows.com.wrapper.callbacks" create ; : (finish-thunk) ( param-count thunk quot -- thunked-quot ) - [ [ drop [ ] ] [ swap 1- '[ _ _ ndip ] ] if-empty ] + [ [ drop [ ] ] [ swap 1 - '[ _ _ ndip ] ] if-empty ] dip compose ; : (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words ) diff --git a/basis/windows/dragdrop-listener/dragdrop-listener.factor b/basis/windows/dragdrop-listener/dragdrop-listener.factor index 4543aa703a..e9c4930b64 100644 --- a/basis/windows/dragdrop-listener/dragdrop-listener.factor +++ b/basis/windows/dragdrop-listener/dragdrop-listener.factor @@ -7,7 +7,7 @@ IN: windows.dragdrop-listener : filenames-from-hdrop ( hdrop -- filenames ) dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files [ - 2dup f 0 DragQueryFile 1+ ! get size of filename buffer + 2dup f 0 DragQueryFile 1 + ! get size of filename buffer dup "WCHAR" [ swap DragQueryFile drop ] keep alien>u16-string diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index d180cb20e7..8bdbb9f1e9 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -713,11 +713,7 @@ ERROR: error-message-failed id ; GetLastError n>win32-error-string ; : (win32-error) ( n -- ) - dup zero? [ - drop - ] [ - win32-error-string throw - ] if ; + [ win32-error-string throw ] unless-zero ; : win32-error ( -- ) GetLastError (win32-error) ; diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor index 864700cb0f..d6a08325d9 100755 --- a/basis/windows/ole32/ole32.factor +++ b/basis/windows/ole32/ole32.factor @@ -1,5 +1,5 @@ USING: alien alien.syntax alien.c-types alien.strings math -kernel sequences windows.errors windows.types debugger io +kernel sequences windows.errors windows.types io accessors math.order namespaces make math.parser windows.kernel32 combinators locals specialized-arrays.direct.uchar ; IN: windows.ole32 @@ -116,11 +116,10 @@ FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ; : succeeded? ( hresult -- ? ) 0 HEX: 7FFFFFFF between? ; -TUPLE: ole32-error error-code ; -C: ole32-error +TUPLE: ole32-error code message ; -M: ole32-error error. - "COM method failed: " print error-code>> n>win32-error-string print ; +: ( code -- error ) + dup n>win32-error-string \ ole32-error boa ; : ole32-error ( hresult -- ) dup succeeded? [ drop ] [ throw ] if ; diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index feb0bef7a8..7c5c26c2da 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -12,7 +12,7 @@ TUPLE: script-string font string metrics ssa size image disposed ; : line-offset>x ( n script-string -- x ) 2dup string>> length = [ ssa>> ! ssa - swap 1- ! icp + swap 1 - ! icp TRUE ! fTrailing ] [ ssa>> diff --git a/basis/xml/syntax/syntax.factor b/basis/xml/syntax/syntax.factor index 7561d67482..5b2a0bcfb4 100644 --- a/basis/xml/syntax/syntax.factor +++ b/basis/xml/syntax/syntax.factor @@ -140,7 +140,7 @@ MACRO: interpolate-xml ( xml -- quot ) : number<-> ( doc -- dup ) 0 over [ dup var>> [ - over >>var [ 1+ ] dip + over >>var [ 1 + ] dip ] unless drop ] each-interpolated drop ; diff --git a/basis/xml/tokenize/tokenize.factor b/basis/xml/tokenize/tokenize.factor index 052cab15c2..b0dbdf22ac 100644 --- a/basis/xml/tokenize/tokenize.factor +++ b/basis/xml/tokenize/tokenize.factor @@ -13,7 +13,7 @@ IN: xml.tokenize swap [ version-1.0?>> over text? not ] [ check>> ] bi and [ - spot get [ 1+ ] change-column drop + spot get [ 1 + ] change-column drop disallowed-char ] [ drop ] if ] [ drop ] if* ; @@ -23,7 +23,7 @@ HINTS: assure-good-char { spot fixnum } ; : record ( spot char -- spot ) over char>> [ CHAR: \n = - [ [ 1+ ] change-line -1 ] [ dup column>> 1+ ] if + [ [ 1 + ] change-line -1 ] [ dup column>> 1 + ] if >>column ] [ drop ] if ; @@ -91,7 +91,7 @@ HINTS: next* { spot } ; : take-string ( match -- string ) dup length spot get '[ 2dup _ string-matches? ] take-until nip - dup length rot length 1- - head + dup length rot length 1 - - head get-char [ missing-close ] unless next ; : expect ( string -- ) diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index febfc2b40f..d3a4f1e9a2 100755 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -257,7 +257,7 @@ M: mark-previous-rule handle-rule-start drop seen-whitespace-end? get [ - position get 1+ whitespace-end set + position get 1 + whitespace-end set ] unless (check-word-break) diff --git a/basis/xmode/marker/state/state.factor b/basis/xmode/marker/state/state.factor index 44d3a0285e..3e7e697baa 100644 --- a/basis/xmode/marker/state/state.factor +++ b/basis/xmode/marker/state/state.factor @@ -28,7 +28,7 @@ SYMBOLS: line last-offset position context : next-token, ( len id -- ) [ position get 2dup + ] dip token, - position get + dup 1- position set last-offset set ; + position get + dup 1 - position set last-offset set ; : push-context ( rules -- ) context [ ] change ; diff --git a/build-support/factor.sh b/build-support/factor.sh index d5b8bd5411..b179811bda 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -487,12 +487,12 @@ update_bootstrap() { } refresh_image() { - ./$FACTOR_BINARY -script -e="USE: vocabs.loader USE: system refresh-all USE: memory save 0 exit" + ./$FACTOR_BINARY -script -e="USING: vocabs.loader system memory ; refresh-all USE: memory save 0 exit" check_ret factor } make_boot_image() { - ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: system USE: bootstrap.image make-image save 0 exit" + ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USING: system bootstrap.image memory ; make-image save 0 exit" check_ret factor } diff --git a/core/alien/alien.factor b/core/alien/alien.factor index ec38e3be5b..d98ea3d103 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -20,11 +20,11 @@ UNION: pinned-c-ptr GENERIC: >c-ptr ( obj -- c-ptr ) -M: c-ptr >c-ptr ; +M: c-ptr >c-ptr ; inline SLOT: underlying -M: object >c-ptr underlying>> ; +M: object >c-ptr underlying>> ; inline GENERIC: expired? ( c-ptr -- ? ) flushable diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor index 4a998a1ebb..fa4d4b2f69 100644 --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -4,17 +4,17 @@ USING: accessors kernel kernel.private math math.private sequences sequences.private ; IN: arrays -M: array clone (clone) ; -M: array length length>> ; -M: array nth-unsafe [ >fixnum ] dip array-nth ; -M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; -M: array resize resize-array ; +M: array clone (clone) ; inline +M: array length length>> ; inline +M: array nth-unsafe [ >fixnum ] dip array-nth ; inline +M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; inline +M: array resize resize-array ; inline : >array ( seq -- array ) { } clone-like ; -M: object new-sequence drop 0 ; +M: object new-sequence drop 0 ; inline -M: f new-sequence drop dup zero? [ drop f ] [ 0 ] if ; +M: f new-sequence drop [ f ] [ 0 ] if-zero ; inline M: array equal? over array? [ sequence= ] [ 2drop f ] if ; diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 3c5ac31d23..9e36f9f00c 100644 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -1,7 +1,7 @@ -IN: assocs.tests USING: kernel math namespaces make tools.test vectors sequences sequences.private hashtables io prettyprint assocs continuations specialized-arrays.double ; +IN: assocs.tests [ t ] [ H{ } dup assoc-subset? ] unit-test [ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test @@ -149,4 +149,4 @@ unit-test H{ { 1 3 } { 2 5 } } H{ { 1 7 } { 5 6 } } } assoc-refine -] unit-test \ No newline at end of file +] unit-test diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 8b6809236c..e633a54843 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -17,7 +17,7 @@ GENERIC: assoc-like ( assoc exemplar -- newassoc ) GENERIC: assoc-clone-like ( assoc exemplar -- newassoc ) GENERIC: >alist ( assoc -- newassoc ) -M: assoc assoc-like drop ; +M: assoc assoc-like drop ; inline : ?at ( key assoc -- value/key ? ) 2dup at* [ 2nip t ] [ 2drop f ] if ; inline @@ -87,7 +87,7 @@ PRIVATE> M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) [ dup assoc-size ] dip new-assoc - [ [ set-at ] with-assoc assoc-each ] keep ; + [ [ set-at ] with-assoc assoc-each ] keep ; inline : keys ( assoc -- keys ) [ drop ] { } assoc>map ; @@ -189,48 +189,48 @@ M: sequence set-at [ 2nip set-second ] [ drop [ swap 2array ] dip push ] if ; -M: sequence new-assoc drop ; +M: sequence new-assoc drop ; inline -M: sequence clear-assoc delete-all ; +M: sequence clear-assoc delete-all ; inline M: sequence delete-at [ nip ] [ search-alist nip ] 2bi [ swap delete-nth ] [ drop ] if* ; -M: sequence assoc-size length ; +M: sequence assoc-size length ; inline M: sequence assoc-clone-like - [ >alist ] dip clone-like ; + [ >alist ] dip clone-like ; inline M: sequence assoc-like - [ >alist ] dip like ; + [ >alist ] dip like ; inline -M: sequence >alist ; +M: sequence >alist ; inline ! Override sequence => assoc instance for f -M: f clear-assoc drop ; +M: f clear-assoc drop ; inline -M: f assoc-like drop dup assoc-empty? [ drop f ] when ; +M: f assoc-like drop dup assoc-empty? [ drop f ] when ; inline INSTANCE: sequence assoc -TUPLE: enum seq ; +TUPLE: enum { seq read-only } ; C: enum M: enum at* seq>> 2dup bounds-check? - [ nth t ] [ 2drop f f ] if ; + [ nth t ] [ 2drop f f ] if ; inline -M: enum set-at seq>> set-nth ; +M: enum set-at seq>> set-nth ; inline -M: enum delete-at seq>> delete-nth ; +M: enum delete-at seq>> delete-nth ; inline M: enum >alist ( enum -- alist ) - seq>> [ length ] keep zip ; + seq>> [ length ] keep zip ; inline -M: enum assoc-size seq>> length ; +M: enum assoc-size seq>> length ; inline -M: enum clear-assoc seq>> delete-all ; +M: enum clear-assoc seq>> delete-all ; inline INSTANCE: enum assoc diff --git a/core/bootstrap/syntax-docs.factor b/core/bootstrap/syntax-docs.factor deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index f5182a0210..906b73934e 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -67,6 +67,7 @@ IN: bootstrap.syntax "M\\" "]" "delimiter" + "deprecated" "f" "flushable" "foldable" diff --git a/core/byte-arrays/byte-arrays-tests.factor b/core/byte-arrays/byte-arrays-tests.factor index 1c3e4d3bdf..e28083b2db 100644 --- a/core/byte-arrays/byte-arrays-tests.factor +++ b/core/byte-arrays/byte-arrays-tests.factor @@ -1,5 +1,5 @@ +USING: tools.test byte-arrays sequences kernel math ; IN: byte-arrays.tests -USING: tools.test byte-arrays sequences kernel ; [ 6 B{ 1 2 3 } ] [ 6 B{ 1 2 3 } resize-byte-array @@ -10,4 +10,8 @@ USING: tools.test byte-arrays sequences kernel ; [ -10 B{ } resize-byte-array ] must-fail -[ B{ 123 } ] [ 123 1byte-array ] unit-test \ No newline at end of file +[ B{ 123 } ] [ 123 1byte-array ] unit-test + +[ B{ 123 } ] [ 123 0 B{ 0 } [ set-nth ] keep ] unit-test + +[ B{ 123 } ] [ 123 >bignum 0 B{ 0 } [ set-nth ] keep ] unit-test \ No newline at end of file diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index 72989ac447..3c89a5f63e 100644 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -4,18 +4,18 @@ USING: accessors kernel kernel.private alien.accessors sequences sequences.private math ; IN: byte-arrays -M: byte-array clone (clone) ; -M: byte-array length length>> ; -M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; -M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; +M: byte-array clone (clone) ; inline +M: byte-array length length>> ; inline +M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; inline +M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; inline : >byte-array ( seq -- byte-array ) B{ } clone-like ; inline -M: byte-array new-sequence drop (byte-array) ; +M: byte-array new-sequence drop (byte-array) ; inline M: byte-array equal? over byte-array? [ sequence= ] [ 2drop f ] if ; M: byte-array resize - resize-byte-array ; + resize-byte-array ; inline INSTANCE: byte-array sequence diff --git a/core/byte-vectors/byte-vectors-tests.factor b/core/byte-vectors/byte-vectors-tests.factor index bd7510c95f..fdf4ab6aca 100644 --- a/core/byte-vectors/byte-vectors-tests.factor +++ b/core/byte-vectors/byte-vectors-tests.factor @@ -1,6 +1,6 @@ -IN: byte-vectors.tests USING: tools.test byte-vectors vectors sequences kernel prettyprint ; +IN: byte-vectors.tests [ 0 ] [ 123 length ] unit-test diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index fc3d9501c7..287e972405 100644 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -18,15 +18,15 @@ M: byte-vector like drop dup byte-vector? [ dup byte-array? [ dup length byte-vector boa ] [ >byte-vector ] if - ] unless ; + ] unless ; inline M: byte-vector new-sequence - drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ; + drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ; inline M: byte-vector equal? over byte-vector? [ sequence= ] [ 2drop f ] if ; -M: byte-vector contract 2drop ; +M: byte-vector contract 2drop ; inline M: byte-array like #! If we have an byte-array, we're done. @@ -39,8 +39,8 @@ M: byte-array like 2dup length eq? [ nip ] [ resize-byte-array ] if ] [ >byte-array ] if - ] unless ; + ] unless ; inline -M: byte-array new-resizable drop ; +M: byte-array new-resizable drop ; inline INSTANCE: byte-vector growable diff --git a/core/checksums/checksums-tests.factor b/core/checksums/checksums-tests.factor deleted file mode 100644 index 8ba09d8e91..0000000000 --- a/core/checksums/checksums-tests.factor +++ /dev/null @@ -1,3 +0,0 @@ -IN: checksums.tests -USING: checksums tools.test ; - diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 6bfc94d79a..df4f8f2563 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -202,9 +202,11 @@ M: anonymous-complement (classes-intersect?) : class= ( first second -- ? ) [ class<= ] [ swap class<= ] 2bi and ; +ERROR: topological-sort-failed ; + : largest-class ( seq -- n elt ) dup [ [ class< ] with any? not ] curry find-last - [ "Topological sort failed" throw ] unless* ; + [ topological-sort-failed ] unless* ; : sort-classes ( seq -- newseq ) [ name>> ] sort-with >vector diff --git a/core/classes/builtin/builtin-tests.factor b/core/classes/builtin/builtin-tests.factor index 6f990d0d62..c6ce302c26 100755 --- a/core/classes/builtin/builtin-tests.factor +++ b/core/classes/builtin/builtin-tests.factor @@ -1,5 +1,5 @@ -IN: classes.builtin.tests USING: tools.test words sequences kernel memory accessors ; +IN: classes.builtin.tests [ f ] [ [ word? ] instances diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index c74c8f3b50..8eeb4ce357 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -20,9 +20,9 @@ PREDICATE: hi-tag-class < builtin-class class>type 7 > ; : bootstrap-type>class ( n -- class ) builtins get nth ; -M: hi-tag class hi-tag type>class ; +M: hi-tag class hi-tag type>class ; inline -M: object class tag type>class ; +M: object class tag type>class ; inline M: builtin-class rank-class drop 0 ; diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index d7fba97977..1c1db09cf4 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -110,6 +110,12 @@ USE: multiline "class-intersect-no-method-c" parse-stream drop ] unit-test +! Forget the above crap +[ + { "classes.test.a" "classes.test.b" "classes.test.c" "classes.test.d" } + [ forget-vocab ] each +] with-compilation-unit + TUPLE: forgotten-predicate-test ; [ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 72457ff974..4ee31936a9 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -1,7 +1,7 @@ -IN: classes.tuple.parser.tests USING: accessors classes.tuple.parser lexer words classes sequences math kernel slots tools.test parser compiler.units arrays classes.tuple eval multiline ; +IN: classes.tuple.parser.tests TUPLE: test-1 ; @@ -141,4 +141,4 @@ TUPLE: parsing-corner-case x ; "USE: classes.tuple.parser.tests T{ parsing-corner-case {" " x 3 }" } "\n" join eval( -- tuple ) -] [ error>> unexpected-eof? ] must-fail-with \ No newline at end of file +] [ error>> unexpected-eof? ] must-fail-with diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 6b106e48d9..7ba850f744 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -87,22 +87,24 @@ ERROR: bad-literal-tuple ; : parse-slot-values ( -- values ) [ (parse-slot-values) ] { } make ; -: boa>tuple ( class slots -- tuple ) +GENERIC# boa>object 1 ( class slots -- tuple ) + +M: tuple-class boa>object swap prefix >tuple ; -: assoc>tuple ( class slots -- tuple ) - [ [ ] [ initial-values ] [ all-slots ] tri ] dip - swap [ [ slot-named offset>> 2 - ] curry dip ] curry assoc-map - [ dup ] dip update boa>tuple ; +: assoc>object ( class slots values -- tuple ) + [ [ [ initial>> ] map ] keep ] dip + swap [ [ slot-named* drop ] curry dip ] curry assoc-map + [ dup ] dip update boa>object ; -: parse-tuple-literal-slots ( class -- tuple ) +: parse-tuple-literal-slots ( class slots -- tuple ) scan { { f [ unexpected-eof ] } - { "f" [ \ } parse-until boa>tuple ] } - { "{" [ parse-slot-values assoc>tuple ] } - { "}" [ new ] } + { "f" [ drop \ } parse-until boa>object ] } + { "{" [ parse-slot-values assoc>object ] } + { "}" [ drop new ] } [ bad-literal-tuple ] } case ; : parse-tuple-literal ( -- tuple ) - scan-word parse-tuple-literal-slots ; + scan-word dup all-slots parse-tuple-literal-slots ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 8e49e2f5f4..0a437a3d69 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -29,7 +29,7 @@ PREDICATE: immutable-tuple-class < tuple-class ( class -- ? ) : layout-of ( tuple -- layout ) 1 slot { array } declare ; inline -M: tuple class layout-of 2 slot { word } declare ; +M: tuple class layout-of 2 slot { word } declare ; inline : tuple-size ( tuple -- size ) layout-of 3 slot { fixnum } declare ; inline @@ -323,7 +323,7 @@ M: tuple-class (classes-intersect?) [ swap classes-intersect? ] } cond ; -M: tuple clone (clone) ; +M: tuple clone (clone) ; inline M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ; diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor index 3eb9273859..37d4fd1195 100644 --- a/core/effects/effects-tests.factor +++ b/core/effects/effects-tests.factor @@ -1,5 +1,5 @@ -IN: effects.tests USING: effects tools.test prettyprint accessors sequences ; +IN: effects.tests [ t ] [ 1 1 2 2 effect<= ] unit-test [ f ] [ 1 0 2 2 effect<= ] unit-test @@ -22,4 +22,4 @@ USING: effects tools.test prettyprint accessors sequences ; [ t ] [ (( -- )) (( -- )) compose-effects (( -- )) effect= ] unit-test [ t ] [ (( -- * )) (( -- )) compose-effects (( -- * )) effect= ] unit-test -[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test \ No newline at end of file +[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index c8ed6da2aa..66179c5e52 100644 --- a/core/effects/parser/parser.factor +++ b/core/effects/parser/parser.factor @@ -24,9 +24,11 @@ ERROR: bad-effect ; : parse-effect-tokens ( end -- tokens ) [ parse-effect-token dup ] curry [ ] produce nip ; +ERROR: stack-effect-omits-dashes effect ; + : parse-effect ( end -- effect ) parse-effect-tokens { "--" } split1 dup - [ ] [ "Stack effect declaration must contain --" throw ] if ; + [ ] [ drop stack-effect-omits-dashes ] if ; : complete-effect ( -- effect ) "(" expect ")" parse-effect ; diff --git a/core/generic/math/math-tests.factor b/core/generic/math/math-tests.factor index 51e122431c..2279fd019c 100644 --- a/core/generic/math/math-tests.factor +++ b/core/generic/math/math-tests.factor @@ -1,5 +1,5 @@ -IN: generic.math.tests USING: generic.math math tools.test kernel ; +IN: generic.math.tests ! Test math-combination [ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test diff --git a/core/generic/single/single-tests.factor b/core/generic/single/single-tests.factor index 61ae4e1ba1..f59268b770 100644 --- a/core/generic/single/single-tests.factor +++ b/core/generic/single/single-tests.factor @@ -1,10 +1,10 @@ -IN: generic.single.tests USING: tools.test math math.functions math.constants generic.standard generic.single strings sequences arrays kernel accessors words specialized-arrays.double byte-arrays bit-arrays parser namespaces make quotations stack-checker vectors growable hashtables sbufs prettyprint byte-vectors bit-vectors specialized-vectors.double definitions generic sets graphs assocs grouping see eval ; +IN: generic.single.tests GENERIC: lo-tag-test ( obj -- obj' ) @@ -279,4 +279,4 @@ M: growable call-next-hooker call-next-method "growable " prepend ; ! Corner case [ "IN: generic.single.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ] [ error>> bad-dispatch-position? ] -must-fail-with \ No newline at end of file +must-fail-with diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 88387abd5c..8a53368062 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -208,9 +208,11 @@ SYMBOL: predicate-engines : keep-going? ( assoc -- ? ) assumed get swap second first class<= ; +ERROR: unreachable ; + : prune-redundant-predicates ( assoc -- default assoc' ) { - { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } + { [ dup empty? ] [ drop [ unreachable ] { } ] } { [ dup length 1 = ] [ first second { } ] } { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] } [ [ first second ] [ rest-slice ] bi ] diff --git a/core/growable/growable.factor b/core/growable/growable.factor index 754a3293d1..68a8de3d43 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -9,9 +9,9 @@ MIXIN: growable SLOT: length SLOT: underlying -M: growable length length>> ; -M: growable nth-unsafe underlying>> nth-unsafe ; -M: growable set-nth-unsafe underlying>> set-nth-unsafe ; +M: growable length length>> ; inline +M: growable nth-unsafe underlying>> nth-unsafe ; inline +M: growable set-nth-unsafe underlying>> set-nth-unsafe ; inline : capacity ( seq -- n ) underlying>> length ; inline @@ -49,21 +49,21 @@ M: growable set-length ( n seq -- ) [ >fixnum ] dip ] if ; inline -M: growable set-nth ensure set-nth-unsafe ; +M: growable set-nth ensure set-nth-unsafe ; inline -M: growable clone (clone) [ clone ] change-underlying ; +M: growable clone (clone) [ clone ] change-underlying ; inline M: growable lengthen ( n seq -- ) 2dup length > [ 2dup capacity > [ over new-size over expand ] when 2dup (>>length) - ] when 2drop ; + ] when 2drop ; inline M: growable shorten ( n seq -- ) growable-check 2dup length < [ 2dup contract 2dup (>>length) - ] when 2drop ; + ] when 2drop ; inline INSTANCE: growable sequence diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index 004b543c7f..54e58c0282 100644 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -1,7 +1,7 @@ -IN: hashtables.tests USING: kernel math namespaces make tools.test vectors sequences sequences.private hashtables io prettyprint assocs continuations ; +IN: hashtables.tests [ f ] [ "hi" V{ 1 2 3 } at ] unit-test @@ -178,4 +178,4 @@ H{ } "x" set [ 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 \ No newline at end of file +[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 03bc3e01fd..8547f53a0e 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -112,7 +112,7 @@ M: hashtable delete-at ( key hash -- ) ] if ; M: hashtable assoc-size ( hash -- n ) - [ count>> ] [ deleted>> ] bi - ; + [ count>> ] [ deleted>> ] bi - ; inline : rehash ( hash -- ) dup >alist [ @@ -150,7 +150,7 @@ M: hashtable >alist ] keep { } like ; M: hashtable clone - (clone) [ clone ] change-array ; + (clone) [ clone ] change-array ; inline M: hashtable equal? over hashtable? [ @@ -159,15 +159,15 @@ M: hashtable equal? ] [ 2drop f ] if ; ! Default method -M: assoc new-assoc drop ; +M: assoc new-assoc drop ; inline -M: f new-assoc drop ; +M: f new-assoc drop ; inline : >hashtable ( assoc -- hashtable ) H{ } assoc-clone-like ; M: hashtable assoc-like - drop dup hashtable? [ >hashtable ] unless ; + drop dup hashtable? [ >hashtable ] unless ; inline : ?set-at ( value key assoc/f -- assoc ) [ [ set-at ] keep ] [ associate ] if* ; diff --git a/core/io/backend/backend-tests.factor b/core/io/backend/backend-tests.factor index c3d7e8e89b..7d668eeab1 100644 --- a/core/io/backend/backend-tests.factor +++ b/core/io/backend/backend-tests.factor @@ -1,4 +1,4 @@ -IN: io.backend.tests USING: tools.test io.backend kernel ; +IN: io.backend.tests [ ] [ "a" normalize-path drop ] unit-test diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index 4846b06f32..2911385c09 100755 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -40,7 +40,7 @@ SINGLETON: utf8 dup stream-read1 dup [ begin-utf8 ] when nip ; inline M: utf8 decode-char - drop decode-utf8 ; + drop decode-utf8 ; inline ! Encoding UTF-8 @@ -73,14 +73,14 @@ M: utf8 encode-char PRIVATE> : code-point-length ( n -- x ) - dup zero? [ drop 1 ] [ + [ 1 ] [ log2 { { [ dup 0 6 between? ] [ 1 ] } { [ dup 7 10 between? ] [ 2 ] } { [ dup 11 15 between? ] [ 3 ] } { [ dup 16 20 between? ] [ 4 ] } } cond nip - ] if ; + ] if-zero ; : code-point-offsets ( string -- indices ) 0 [ code-point-length + ] accumulate swap suffix ; diff --git a/core/io/streams/byte-array/byte-array-tests.factor b/core/io/streams/byte-array/byte-array-tests.factor index 43a8373232..3a08dd10d9 100644 --- a/core/io/streams/byte-array/byte-array-tests.factor +++ b/core/io/streams/byte-array/byte-array-tests.factor @@ -1,5 +1,5 @@ USING: tools.test io.streams.byte-array io.encodings.binary -io.encodings.utf8 io kernel arrays strings namespaces ; +io.encodings.utf8 io kernel arrays strings namespaces math ; [ B{ } ] [ B{ } binary [ contents ] with-byte-reader ] unit-test [ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test @@ -28,3 +28,8 @@ io.encodings.utf8 io kernel arrays strings namespaces ; read1 ] with-byte-reader ] unit-test + +! Overly aggressive compiler optimizations +[ B{ 123 } ] [ + binary [ 123 >bignum write1 ] with-byte-writer +] unit-test \ No newline at end of file diff --git a/core/io/streams/memory/memory.factor b/core/io/streams/memory/memory.factor index ad5453af61..e7b4338388 100644 --- a/core/io/streams/memory/memory.factor +++ b/core/io/streams/memory/memory.factor @@ -12,4 +12,4 @@ M: memory-stream stream-element-type drop +byte+ ; M: memory-stream stream-read1 [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ] - [ [ 1+ ] change-index drop ] bi ; + [ [ 1 + ] change-index drop ] bi ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index d6350e0420..838d877a40 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -192,19 +192,19 @@ UNION: boolean POSTPONE: t POSTPONE: f ; ! Object protocol GENERIC: hashcode* ( depth obj -- code ) -M: object hashcode* 2drop 0 ; +M: object hashcode* 2drop 0 ; inline -M: f hashcode* 2drop 31337 ; +M: f hashcode* 2drop 31337 ; inline : hashcode ( obj -- code ) 3 swap hashcode* ; inline GENERIC: equal? ( obj1 obj2 -- ? ) -M: object equal? 2drop f ; +M: object equal? 2drop f ; inline TUPLE: identity-tuple ; -M: identity-tuple equal? 2drop f ; +M: identity-tuple equal? 2drop f ; inline : = ( obj1 obj2 -- ? ) 2dup eq? [ 2drop t ] [ @@ -213,9 +213,9 @@ M: identity-tuple equal? 2drop f ; GENERIC: clone ( obj -- cloned ) -M: object clone ; +M: object clone ; inline -M: callstack clone (clone) ; +M: callstack clone (clone) ; inline ! Tuple construction GENERIC: new ( class -- tuple ) diff --git a/core/layouts/layouts-tests.factor b/core/layouts/layouts-tests.factor index b0c5d8cfda..5a39f24627 100644 --- a/core/layouts/layouts-tests.factor +++ b/core/layouts/layouts-tests.factor @@ -1,5 +1,5 @@ -IN: system.tests USING: layouts math tools.test ; +IN: system.tests [ t ] [ cell integer? ] unit-test [ t ] [ bootstrap-cell integer? ] unit-test diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index 42898fc085..5738c2ec99 100644 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -78,6 +78,6 @@ M: bignum >integer M: real >integer dup most-negative-fixnum most-positive-fixnum between? - [ >fixnum ] [ >bignum ] if ; + [ >fixnum ] [ >bignum ] if ; inline UNION: immediate fixnum POSTPONE: f ; diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index 036c7d9721..b3bd3cacdb 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -49,7 +49,7 @@ M: lexer skip-word ( lexer -- ) ] change-lexer-column ; : still-parsing? ( lexer -- ? ) - [ line>> ] [ text>> ] bi length <= ; + [ line>> ] [ text>> length ] bi <= ; : still-parsing-line? ( lexer -- ? ) [ column>> ] [ line-length>> ] bi < ; diff --git a/core/math/floats/floats-docs.factor b/core/math/floats/floats-docs.factor index 1305f2a18d..ed4947e1f5 100644 --- a/core/math/floats/floats-docs.factor +++ b/core/math/floats/floats-docs.factor @@ -10,21 +10,21 @@ HELP: >float HELP: bits>double ( n -- x ) { $values { "n" "a 64-bit integer representing an IEEE 754 double-precision float" } { "x" float } } -{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ; +{ $description "Creates a " { $link float } " object from a 64-bit binary representation. This word is usually used to reconstruct floats read from streams." } ; { bits>double bits>float double>bits float>bits } related-words HELP: bits>float ( n -- x ) { $values { "n" "a 32-bit integer representing an IEEE 754 single-precision float" } { "x" float } } -{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ; +{ $description "Creates a " { $link float } " object from a 32-bit binary representation. This word is usually used to reconstruct floats read from streams." } ; HELP: double>bits ( x -- n ) { $values { "x" float } { "n" "a 64-bit integer representing an IEEE 754 double-precision float" } } -{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ; +{ $description "Creates a 64-bit binary representation of a " { $link float } " object. This can be used in the process of writing a float to a stream." } ; HELP: float>bits ( x -- n ) { $values { "x" float } { "n" "a 32-bit integer representing an IEEE 754 single-precision float" } } -{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ; +{ $description "Creates a 32-bit binary representation of a " { $link float } " object. This can be used in the process of writing a float to a stream." } ; ! Unsafe primitives HELP: float+ ( x y -- z ) diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index 2a22dc4330..661bccd88c 100644 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -1,30 +1,64 @@ -! Copyright (C) 2004, 2006 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.private ; IN: math.floats.private -M: fixnum >float fixnum>float ; -M: bignum >float bignum>float ; +M: fixnum >float fixnum>float ; inline +M: bignum >float bignum>float ; inline -M: float >fixnum float>fixnum ; -M: float >bignum float>bignum ; -M: float >float ; +M: float >fixnum float>fixnum ; inline +M: float >bignum float>bignum ; inline +M: float >float ; inline -M: float hashcode* nip float>bits ; -M: float equal? over float? [ float= ] [ 2drop f ] if ; -M: float number= float= ; +M: float hashcode* nip float>bits ; inline +M: float equal? over float? [ float= ] [ 2drop f ] if ; inline +M: float number= float= ; inline -M: float < float< ; -M: float <= float<= ; -M: float > float> ; -M: float >= float>= ; +M: float < float< ; inline +M: float <= float<= ; inline +M: float > float> ; inline +M: float >= float>= ; inline -M: float + float+ ; -M: float - float- ; -M: float * float* ; -M: float / float/f ; -M: float /f float/f ; -M: float /i float/f >integer ; -M: float mod float-mod ; +M: float + float+ ; inline +M: float - float- ; inline +M: float * float* ; inline +M: float / float/f ; inline +M: float /f float/f ; inline +M: float /i float/f >integer ; inline +M: float mod float-mod ; inline -M: real abs dup 0 < [ neg ] when ; +M: real abs dup 0 < [ neg ] when ; inline + +M: float fp-special? + double>bits -52 shift HEX: 7ff [ bitand ] keep = ; inline + +M: float fp-nan-payload + double>bits 52 2^ 1 - bitand ; inline + +M: float fp-nan? + dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline + +M: float fp-qnan? + dup fp-nan? [ fp-nan-payload 51 2^ bitand zero? not ] [ drop f ] if ; inline + +M: float fp-snan? + dup fp-nan? [ fp-nan-payload 51 2^ bitand zero? ] [ drop f ] if ; inline + +M: float fp-infinity? + dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline + +M: float next-float ( m -- n ) + double>bits + dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero + dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero + 1 + bits>double ! positive + ] if + ] if ; inline + +M: float prev-float ( m -- n ) + double>bits + dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative + dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero + 1 - bits>double ! positive non-zero + ] if + ] if ; inline diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index bb7fc107b2..75abd8087e 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -5,79 +5,79 @@ USING: kernel kernel.private sequences sequences.private math math.private combinators ; IN: math.integers.private -M: integer numerator ; -M: integer denominator drop 1 ; +M: integer numerator ; inline +M: integer denominator drop 1 ; inline -M: fixnum >fixnum ; -M: fixnum >bignum fixnum>bignum ; -M: fixnum >integer ; +M: fixnum >fixnum ; inline +M: fixnum >bignum fixnum>bignum ; inline +M: fixnum >integer ; inline -M: fixnum hashcode* nip ; -M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ; -M: fixnum number= eq? ; +M: fixnum hashcode* nip ; inline +M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ; inline +M: fixnum number= eq? ; inline -M: fixnum < fixnum< ; -M: fixnum <= fixnum<= ; -M: fixnum > fixnum> ; -M: fixnum >= fixnum>= ; +M: fixnum < fixnum< ; inline +M: fixnum <= fixnum<= ; inline +M: fixnum > fixnum> ; inline +M: fixnum >= fixnum>= ; inline -M: fixnum + fixnum+ ; -M: fixnum - fixnum- ; -M: fixnum * fixnum* ; -M: fixnum /i fixnum/i ; -M: fixnum /f [ >float ] dip >float float/f ; +M: fixnum + fixnum+ ; inline +M: fixnum - fixnum- ; inline +M: fixnum * fixnum* ; inline +M: fixnum /i fixnum/i ; inline +M: fixnum /f [ >float ] dip >float float/f ; inline -M: fixnum mod fixnum-mod ; +M: fixnum mod fixnum-mod ; inline -M: fixnum /mod fixnum/mod ; +M: fixnum /mod fixnum/mod ; inline -M: fixnum bitand fixnum-bitand ; -M: fixnum bitor fixnum-bitor ; -M: fixnum bitxor fixnum-bitxor ; -M: fixnum shift >fixnum fixnum-shift ; +M: fixnum bitand fixnum-bitand ; inline +M: fixnum bitor fixnum-bitor ; inline +M: fixnum bitxor fixnum-bitxor ; inline +M: fixnum shift >fixnum fixnum-shift ; inline -M: fixnum bitnot fixnum-bitnot ; +M: fixnum bitnot fixnum-bitnot ; inline -M: fixnum bit? neg shift 1 bitand 0 > ; +M: fixnum bit? neg shift 1 bitand 0 > ; inline : fixnum-log2 ( x -- n ) 0 swap [ dup 1 eq? ] [ [ 1 + ] [ 2/ ] bi* ] until drop ; -M: fixnum (log2) fixnum-log2 ; +M: fixnum (log2) fixnum-log2 ; inline -M: bignum >fixnum bignum>fixnum ; -M: bignum >bignum ; +M: bignum >fixnum bignum>fixnum ; inline +M: bignum >bignum ; inline M: bignum hashcode* nip >fixnum ; M: bignum equal? over bignum? [ bignum= ] [ swap dup fixnum? [ >bignum bignum= ] [ 2drop f ] if - ] if ; + ] if ; inline -M: bignum number= bignum= ; +M: bignum number= bignum= ; inline -M: bignum < bignum< ; -M: bignum <= bignum<= ; -M: bignum > bignum> ; -M: bignum >= bignum>= ; +M: bignum < bignum< ; inline +M: bignum <= bignum<= ; inline +M: bignum > bignum> ; inline +M: bignum >= bignum>= ; inline -M: bignum + bignum+ ; -M: bignum - bignum- ; -M: bignum * bignum* ; -M: bignum /i bignum/i ; -M: bignum mod bignum-mod ; +M: bignum + bignum+ ; inline +M: bignum - bignum- ; inline +M: bignum * bignum* ; inline +M: bignum /i bignum/i ; inline +M: bignum mod bignum-mod ; inline -M: bignum /mod bignum/mod ; +M: bignum /mod bignum/mod ; inline -M: bignum bitand bignum-bitand ; -M: bignum bitor bignum-bitor ; -M: bignum bitxor bignum-bitxor ; -M: bignum shift >fixnum bignum-shift ; +M: bignum bitand bignum-bitand ; inline +M: bignum bitor bignum-bitor ; inline +M: bignum bitxor bignum-bitxor ; inline +M: bignum shift >fixnum bignum-shift ; inline -M: bignum bitnot bignum-bitnot ; -M: bignum bit? bignum-bit? ; -M: bignum (log2) bignum-log2 ; +M: bignum bitnot bignum-bitnot ; inline +M: bignum bit? bignum-bit? ; inline +M: bignum (log2) bignum-log2 ; inline ! Converting ratios to floats. Based on FLOAT-RATIO from ! sbcl/src/code/float.lisp, which has the following license: @@ -121,14 +121,14 @@ M: bignum (log2) bignum-log2 ; over zero? [ 2drop 0.0 ] [ - dup zero? [ - 2drop 1/0. + [ + drop 1/0. ] [ pre-scale /f-loop over odd? [ zero? [ 1 + ] unless ] [ drop ] if post-scale - ] if + ] if-zero ] if ; inline M: bignum /f ( m n -- f ) diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 55a50cd5d7..853aca5969 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -151,7 +151,7 @@ HELP: bitnot { $description "Computes the bitwise complement of the input; that is, each bit in the input number is flipped." } { $notes "This word implements bitwise not, so applying it to booleans will throw an error. Boolean not is the " { $link not } " word." $nl -"Due to the two's complement representation of signed integers, the following two lines are equivalent:" { $code "bitnot" "neg 1-" } } ; +"Due to the two's complement representation of signed integers, the following two lines are equivalent:" { $code "bitnot" "neg 1 -" } } ; HELP: bit? { $values { "x" integer } { "n" integer } { "?" "a boolean" } } @@ -163,22 +163,6 @@ HELP: log2 { $description "Outputs the largest integer " { $snippet "n" } " such that " { $snippet "2^n" } " is less than or equal to " { $snippet "x" } "." } { $errors "Throws an error if " { $snippet "x" } " is zero or negative." } ; -HELP: 1+ -{ $values { "x" number } { "y" number } } -{ $description - "Increments a number by 1. The following two lines are equivalent:" - { $code "1+" "1 +" } - "There is no difference in behavior or efficiency." -} ; - -HELP: 1- -{ $values { "x" number } { "y" number } } -{ $description - "Decrements a number by 1. The following two lines are equivalent:" - { $code "1-" "1 -" } - "There is no difference in behavior or efficiency." -} ; - HELP: ?1+ { $values { "x" { $maybe number } } { "y" number } } { $description "If the input is not " { $link f } ", adds one. Otherwise, outputs a " { $snippet "0" } "." } ; @@ -213,9 +197,9 @@ HELP: sgn { $description "Outputs one of the following:" { $list - "-1 if " { $snippet "x" } " is negative" - "0 if " { $snippet "x" } " is equal to 0" - "1 if " { $snippet "x" } " is positive" + { "-1 if " { $snippet "x" } " is negative" } + { "0 if " { $snippet "x" } " is equal to 0" } + { "1 if " { $snippet "x" } " is positive" } } } ; @@ -237,6 +221,49 @@ HELP: zero? { $values { "x" number } { "?" "a boolean" } } { $description "Tests if the number is equal to zero." } ; +HELP: if-zero +{ $values { "n" number } { "quot1" quotation } { "quot2" quotation } } +{ $description "Makes an implicit check if the number is zero. A zero is dropped and " { $snippet "quot1" } " is called. Otherwise, if the number is not zero, " { $snippet "quot2" } " is called on it." } +{ $example + "USING: kernel math prettyprint sequences ;" + "3 [ \"zero\" ] [ sq ] if-zero ." + "9" +} ; + +HELP: when-zero +{ $values + { "n" number } { "quot" "the first quotation of an " { $link if-zero } } } +{ $description "Makes an implicit check if the sequence is empty. A zero is dropped and the " { $snippet "quot" } " is called." } +{ $examples "This word is equivalent to " { $link if-zero } " with an empty second quotation:" + { $example + "USING: math prettyprint ;" + "0 [ 4 ] [ ] if-zero ." + "4" + } + { $example + "USING: math prettyprint ;" + "0 [ 4 ] when-zero ." + "4" + } +} ; + +HELP: unless-zero +{ $values + { "n" number } { "quot" "the second quotation of an " { $link if-empty } } } +{ $description "Makes an implicit check if the number is zero. A zero is dropped. Otherwise, the " { $snippet "quot" } " is called on the number." } +{ $examples "This word is equivalent to " { $link if-zero } " with an empty first quotation:" + { $example + "USING: sequences math prettyprint ;" + "3 [ ] [ sq ] if-empty ." + "9" + } + { $example + "USING: sequences math prettyprint ;" + "3 [ sq ] unless-zero ." + "9" + } +} ; + HELP: times { $values { "n" integer } { "quot" quotation } } { $description "Calls the quotation " { $snippet "n" } " times." } diff --git a/core/math/math.factor b/core/math/math.factor index 28efbaa26e..e6c34c112c 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -48,16 +48,16 @@ GENERIC: (log2) ( x -- n ) foldable PRIVATE> +ERROR: log2-expects-positive x ; + : log2 ( x -- n ) dup 0 <= [ - "log2 expects positive inputs" throw + log2-expects-positive ] [ (log2) ] if ; inline : zero? ( x -- ? ) 0 number= ; inline -: 1+ ( x -- y ) 1 + ; inline -: 1- ( x -- y ) 1 - ; inline : 2/ ( x -- y ) -1 shift ; inline : sq ( x -- y ) dup * ; inline : neg ( x -- -x ) -1 * ; inline @@ -69,6 +69,13 @@ PRIVATE> : even? ( n -- ? ) 1 bitand zero? ; : odd? ( n -- ? ) 1 bitand 1 number= ; +: if-zero ( n quot1 quot2 -- ) + [ dup zero? ] [ [ drop ] prepose ] [ ] tri* if ; inline + +: when-zero ( n quot -- ) [ ] if-zero ; inline + +: unless-zero ( n quot -- ) [ ] swap if-zero ; inline + UNION: integer fixnum bignum ; TUPLE: ratio { numerator integer read-only } { denominator integer read-only } ; @@ -90,55 +97,18 @@ GENERIC: fp-snan? ( x -- ? ) GENERIC: fp-infinity? ( x -- ? ) GENERIC: fp-nan-payload ( x -- bits ) -M: object fp-special? - drop f ; -M: object fp-nan? - drop f ; -M: object fp-qnan? - drop f ; -M: object fp-snan? - drop f ; -M: object fp-infinity? - drop f ; -M: object fp-nan-payload - drop f ; - -M: float fp-special? - double>bits -52 shift HEX: 7ff [ bitand ] keep = ; - -M: float fp-nan-payload - double>bits HEX: fffffffffffff bitand ; foldable flushable - -M: float fp-nan? - dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; - -M: float fp-qnan? - dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ; - -M: float fp-snan? - dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ; - -M: float fp-infinity? - dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; +M: object fp-special? drop f ; inline +M: object fp-nan? drop f ; inline +M: object fp-qnan? drop f ; inline +M: object fp-snan? drop f ; inline +M: object fp-infinity? drop f ; inline +M: object fp-nan-payload drop f ; inline : ( payload -- nan ) - HEX: 7ff0000000000000 bitor bits>double ; foldable flushable + HEX: 7ff0000000000000 bitor bits>double ; inline -: next-float ( m -- n ) - double>bits - dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero - dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero - 1 + bits>double ! positive - ] if - ] if ; foldable flushable - -: prev-float ( m -- n ) - double>bits - dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative - dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero - 1 - bits>double ! positive non-zero - ] if - ] if ; foldable flushable +GENERIC: next-float ( m -- n ) +GENERIC: prev-float ( m -- n ) : next-power-of-2 ( m -- n ) dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline diff --git a/core/math/order/order.factor b/core/math/order/order.factor index 435eec9b96..707dc02af2 100644 --- a/core/math/order/order.factor +++ b/core/math/order/order.factor @@ -15,24 +15,24 @@ GENERIC: <=> ( obj1 obj2 -- <=> ) : >=< ( obj1 obj2 -- >=< ) <=> invert-comparison ; inline -M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; +M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; inline GENERIC: before? ( obj1 obj2 -- ? ) GENERIC: after? ( obj1 obj2 -- ? ) GENERIC: before=? ( obj1 obj2 -- ? ) GENERIC: after=? ( obj1 obj2 -- ? ) -M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ; -M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ; -M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ; -M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ; +M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ; inline +M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ; inline +M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ; inline +M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ; inline -M: real before? ( obj1 obj2 -- ? ) < ; -M: real after? ( obj1 obj2 -- ? ) > ; -M: real before=? ( obj1 obj2 -- ? ) <= ; -M: real after=? ( obj1 obj2 -- ? ) >= ; +M: real before? ( obj1 obj2 -- ? ) < ; inline +M: real after? ( obj1 obj2 -- ? ) > ; inline +M: real before=? ( obj1 obj2 -- ? ) <= ; inline +M: real after=? ( obj1 obj2 -- ? ) >= ; inline -: min ( x y -- z ) [ before? ] most ; inline +: min ( x y -- z ) [ before? ] most ; inline : max ( x y -- z ) [ after? ] most ; inline : clamp ( x min max -- y ) [ max ] dip min ; inline diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index c655965e35..2b440b24d4 100644 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -25,6 +25,14 @@ unit-test [ "e" string>number ] unit-test +[ 100000 ] +[ "100,000" string>number ] +unit-test + +[ 100000.0 ] +[ "100,000.0" string>number ] +unit-test + [ "100.0" ] [ "1.0e2" string>number number>string ] unit-test diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 437308d53f..21062baf4b 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -28,13 +28,16 @@ IN: math.parser { CHAR: d 13 } { CHAR: e 14 } { CHAR: f 15 } - } at 255 or ; inline + { CHAR: , f } + } at* [ drop 255 ] unless ; inline : string>digits ( str -- digits ) [ digit> ] B{ } map-as ; inline : (digits>integer) ( valid? accum digit radix -- valid? accum ) - 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline + over [ + 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if + ] [ 2drop ] if ; inline : each-digit ( seq radix quot -- n/f ) [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline @@ -80,6 +83,7 @@ SYMBOL: negative? ] if ; inline : string>float ( str -- n/f ) + [ CHAR: , eq? not ] filter >byte-array 0 suffix (string>float) ; PRIVATE> @@ -131,7 +135,7 @@ M: ratio >base [ dup 0 < negative? set abs 1 /mod - [ dup zero? [ drop "" ] [ (>base) sign append ] if ] + [ [ "" ] [ (>base) sign append ] if-zero ] [ [ numerator (>base) ] [ denominator (>base) ] bi diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor index 0b2c170c1e..49b6ec1374 100644 --- a/core/sbufs/sbufs.factor +++ b/core/sbufs/sbufs.factor @@ -11,24 +11,24 @@ TUPLE: sbuf : ( n -- sbuf ) 0 0 sbuf boa ; inline M: sbuf set-nth-unsafe - [ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ; + [ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ; inline M: sbuf new-sequence - drop [ 0 ] [ >fixnum ] bi sbuf boa ; + drop [ 0 ] [ >fixnum ] bi sbuf boa ; inline : >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline M: sbuf like drop dup sbuf? [ dup string? [ dup length sbuf boa ] [ >sbuf ] if - ] unless ; + ] unless ; inline -M: sbuf new-resizable drop ; +M: sbuf new-resizable drop ; inline M: sbuf equal? over sbuf? [ sequence= ] [ 2drop f ] if ; -M: string new-resizable drop ; +M: string new-resizable drop ; inline M: string like #! If we have a string, we're done. @@ -41,6 +41,6 @@ M: string like 2dup length eq? [ nip dup reset-string-hashcode ] [ resize-string ] if ] [ >string ] if - ] unless ; + ] unless ; inline INSTANCE: sbuf growable diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 71d42705a2..258b484764 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -123,8 +123,6 @@ HELP: unless-empty } } ; -{ if-empty when-empty unless-empty } related-words - HELP: delete-all { $values { "seq" "a resizable sequence" } } { $description "Resizes the sequence to zero length, removing all elements. Not all sequences are resizable." } @@ -1214,7 +1212,7 @@ HELP: follow { $examples "Get random numbers until zero is reached:" { $unchecked-example "USING: random sequences prettyprint math ;" - "100 [ random dup zero? [ drop f ] when ] follow ." + "100 [ random [ f ] when-zero ] follow ." "{ 100 86 34 32 24 11 7 2 }" } } ; @@ -1393,6 +1391,14 @@ $nl $nl "More elaborate counted loops can be performed with " { $link "math.ranges" } "." ; +ARTICLE: "sequences-if" "Control flow with sequences" +"To reduce the boilerplate of checking if a sequence is empty, several combinators are provided." +$nl +"Checking if a sequence is empty:" +{ $subsection if-empty } +{ $subsection when-empty } +{ $subsection unless-empty } ; + ARTICLE: "sequences-access" "Accessing sequence elements" { $subsection ?nth } "Concise way of extracting one of the first four elements:" @@ -1658,6 +1664,8 @@ $nl "Using sequences for looping:" { $subsection "sequences-integers" } { $subsection "math.ranges" } +"Using sequences for control flow:" +{ $subsection "sequences-if" } "For inner loops:" { $subsection "sequences-unsafe" } ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index f0dc6d36c7..031d5f7b4a 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -18,14 +18,14 @@ GENERIC: clone-like ( seq exemplar -- newseq ) flushable : new-like ( len exemplar quot -- seq ) over [ [ new-sequence ] dip call ] dip like ; inline -M: sequence like drop ; +M: sequence like drop ; inline GENERIC: lengthen ( n seq -- ) GENERIC: shorten ( n seq -- ) -M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; +M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; inline -M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; +M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; inline : empty? ( seq -- ? ) length 0 = ; inline @@ -82,25 +82,25 @@ GENERIC: resize ( n seq -- newseq ) flushable GENERIC: nth-unsafe ( n seq -- elt ) flushable GENERIC: set-nth-unsafe ( elt n seq -- ) -M: sequence nth bounds-check nth-unsafe ; -M: sequence set-nth bounds-check set-nth-unsafe ; +M: sequence nth bounds-check nth-unsafe ; inline +M: sequence set-nth bounds-check set-nth-unsafe ; inline -M: sequence nth-unsafe nth ; -M: sequence set-nth-unsafe set-nth ; +M: sequence nth-unsafe nth ; inline +M: sequence set-nth-unsafe set-nth ; inline : change-nth-unsafe ( i seq quot -- ) [ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline ! The f object supports the sequence protocol trivially -M: f length drop 0 ; -M: f nth-unsafe nip ; -M: f like drop [ f ] when-empty ; +M: f length drop 0 ; inline +M: f nth-unsafe nip ; inline +M: f like drop [ f ] when-empty ; inline INSTANCE: f immutable-sequence ! Integers support the sequence protocol -M: integer length ; -M: integer nth-unsafe drop ; +M: integer length ; inline +M: integer nth-unsafe drop ; inline INSTANCE: integer immutable-sequence @@ -113,8 +113,8 @@ TUPLE: iota { n integer read-only } ; > ; -M: iota nth-unsafe drop ; +M: iota length n>> ; inline +M: iota nth-unsafe drop ; inline INSTANCE: iota immutable-sequence @@ -185,12 +185,12 @@ MIXIN: virtual-sequence GENERIC: virtual-seq ( seq -- seq' ) GENERIC: virtual@ ( n seq -- n' seq' ) -M: virtual-sequence nth virtual@ nth ; -M: virtual-sequence set-nth virtual@ set-nth ; -M: virtual-sequence nth-unsafe virtual@ nth-unsafe ; -M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ; -M: virtual-sequence like virtual-seq like ; -M: virtual-sequence new-sequence virtual-seq new-sequence ; +M: virtual-sequence nth virtual@ nth ; inline +M: virtual-sequence set-nth virtual@ set-nth ; inline +M: virtual-sequence nth-unsafe virtual@ nth-unsafe ; inline +M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ; inline +M: virtual-sequence like virtual-seq like ; inline +M: virtual-sequence new-sequence virtual-seq new-sequence ; inline INSTANCE: virtual-sequence sequence @@ -199,11 +199,9 @@ TUPLE: reversed { seq read-only } ; C: reversed -M: reversed virtual-seq seq>> ; - -M: reversed virtual@ seq>> [ length swap - 1 - ] keep ; - -M: reversed length seq>> length ; +M: reversed virtual-seq seq>> ; inline +M: reversed virtual@ seq>> [ length swap - 1 - ] keep ; inline +M: reversed length seq>> length ; inline INSTANCE: reversed virtual-sequence @@ -233,11 +231,11 @@ TUPLE: slice-error from to seq reason ; check-slice slice boa ; inline -M: slice virtual-seq seq>> ; +M: slice virtual-seq seq>> ; inline -M: slice virtual@ [ from>> + ] [ seq>> ] bi ; +M: slice virtual@ [ from>> + ] [ seq>> ] bi ; inline -M: slice length [ to>> ] [ from>> ] bi - ; +M: slice length [ to>> ] [ from>> ] bi - ; inline : short ( seq n -- seq n' ) over length min ; inline @@ -260,16 +258,18 @@ TUPLE: repetition { len read-only } { elt read-only } ; C: repetition -M: repetition length len>> ; -M: repetition nth-unsafe nip elt>> ; +M: repetition length len>> ; inline +M: repetition nth-unsafe nip elt>> ; inline INSTANCE: repetition immutable-sequence (copy) drop ; inline M: sequence clone-like - [ dup length ] dip new-sequence [ 0 swap copy ] keep ; + [ dup length ] dip new-sequence [ 0 swap copy ] keep ; inline -M: immutable-sequence clone-like like ; +M: immutable-sequence clone-like like ; inline : push-all ( src dest -- ) [ length ] [ copy ] bi ; diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor index 1365e81524..957b525cb3 100644 --- a/core/slots/slots-tests.factor +++ b/core/slots/slots-tests.factor @@ -1,6 +1,6 @@ -IN: slots.tests USING: math accessors slots strings generic.single kernel tools.test generic words parser eval math.functions ; +IN: slots.tests TUPLE: r/w-test foo ; @@ -18,23 +18,6 @@ TUPLE: hello length ; [ "xyz" 4 >>length ] [ no-method? ] must-fail-with -[ t ] [ r/o-test \ foo>> method "foldable" word-prop ] unit-test -[ t ] [ r/o-test \ foo>> method "flushable" word-prop ] unit-test - -[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test -[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test - -! See if declarations are cleared on redefinition -[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval( -- ) ] unit-test - -[ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test -[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test - -[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval( -- ) ] unit-test - -[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test -[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test - ! Test protocol slots SLOT: my-protocol-slot-test @@ -49,3 +32,10 @@ M: protocol-slot-test-tuple (>>my-protocol-slot-test) [ sqrt ] dip (>>x) ; T{ protocol-slot-test-tuple { x 3 } } clone [ 7 + ] change-my-protocol-slot-test x>> ] unit-test + +UNION: comme-ci integer float ; +UNION: comme-ca integer float ; +comme-ca 25.5 "initial-value" set-word-prop + +[ 0 ] [ comme-ci initial-value ] unit-test +[ 25.5 ] [ comme-ca initial-value ] unit-test diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 9215857018..95a854f493 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -24,7 +24,8 @@ PREDICATE: writer-method < method-body "writing" word-prop ; [ create-method ] 2dip [ [ props>> ] [ drop ] [ ] tri* update ] [ drop define ] - 3bi ; + [ 2drop make-inline ] + 3tri ; GENERIC# reader-quot 1 ( class slot-spec -- quot ) @@ -41,11 +42,7 @@ M: object reader-quot dup t "reader" set-word-prop ; : reader-props ( slot-spec -- assoc ) - [ - [ "reading" set ] - [ read-only>> [ t "foldable" set ] when ] bi - t "flushable" set - ] H{ } make-assoc ; + "reading" associate ; : define-reader-generic ( name -- ) reader-word (( object -- value )) define-simple-generic ; @@ -169,6 +166,7 @@ M: class initial-value* no-initial-value ; : initial-value ( class -- object ) { + { [ dup "initial-value" word-prop ] [ dup "initial-value" word-prop ] } { [ \ f bootstrap-word over class<= ] [ f ] } { [ \ array-capacity bootstrap-word over class<= ] [ 0 ] } { [ float bootstrap-word over class<= ] [ 0.0 ] } @@ -236,5 +234,8 @@ M: slot-spec make-slot : finalize-slots ( specs base -- specs ) over length iota [ + ] with map [ >>offset ] 2map ; +: slot-named* ( name specs -- offset spec/f ) + [ name>> = ] with find ; + : slot-named ( name specs -- spec/f ) - [ name>> = ] with find nip ; + slot-named* nip ; diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 5ec396e5ba..7aae30f20b 100644 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -58,7 +58,7 @@ PRIVATE> : (split) ( separators n seq -- ) 3dup rot [ member? ] curry find-from drop [ [ swap subseq , ] 2keep 1 + swap (split) ] - [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive + [ swap [ tail ] unless-zero , drop ] if* ; inline recursive : split, ( seq separators -- ) 0 rot (split) ; diff --git a/core/strings/strings.factor b/core/strings/strings.factor index ffcefab78b..8ab0409318 100644 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -37,24 +37,24 @@ M: string hashcode* [ ] [ dup rehash-string string-hashcode ] ?if ; M: string length - length>> ; + length>> ; inline M: string nth-unsafe - [ >fixnum ] dip string-nth ; + [ >fixnum ] dip string-nth ; inline M: string set-nth-unsafe dup reset-string-hashcode - [ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ; + [ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ; inline M: string clone - (clone) [ clone ] change-aux ; + (clone) [ clone ] change-aux ; inline -M: string resize resize-string ; +M: string resize resize-string ; inline : 1string ( ch -- str ) 1 swap ; : >string ( seq -- str ) "" clone-like ; -M: string new-sequence drop 0 ; +M: string new-sequence drop 0 ; inline INSTANCE: string sequence diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 70905ceda9..a988e57365 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -191,6 +191,10 @@ HELP: delimiter { $syntax ": foo ... ; delimiter" } { $description "Declares the most recently defined word as a delimiter. Delimiters are words which are only ever valid as the end of a nested block to be read by " { $link parse-until } ". An unpaired occurrence of a delimiter is a parse error." } ; +HELP: deprecated +{ $syntax ": foo ... ; deprecated" } +{ $description "Declares the most recently defined word as deprecated. If the " { $vocab-link "tools.deprecation" } " vocabulary is loaded, usages of deprecated words will be noted as they are made." } ; + HELP: SYNTAX: { $syntax "SYNTAX: foo ... ;" } { $description "Defines a parsing word." } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 7b9a0d36ef..f01f90c027 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -111,6 +111,7 @@ IN: bootstrap.syntax "foldable" [ word make-foldable ] define-core-syntax "flushable" [ word make-flushable ] define-core-syntax "delimiter" [ word t "delimiter" set-word-prop ] define-core-syntax + "deprecated" [ word make-deprecated ] define-core-syntax "SYNTAX:" [ CREATE-WORD parse-definition define-syntax diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor index 1bdda7b69d..4bbc787294 100644 --- a/core/vectors/vectors.factor +++ b/core/vectors/vectors.factor @@ -15,10 +15,10 @@ TUPLE: vector M: vector like drop dup vector? [ dup array? [ dup length vector boa ] [ >vector ] if - ] unless ; + ] unless ; inline M: vector new-sequence - drop [ f ] [ >fixnum ] bi vector boa ; + drop [ f ] [ >fixnum ] bi vector boa ; inline M: vector equal? over vector? [ sequence= ] [ 2drop f ] if ; @@ -34,9 +34,9 @@ M: array like 2dup length eq? [ nip ] [ resize-array ] if ] [ >array ] if - ] unless ; + ] unless ; inline -M: sequence new-resizable drop ; +M: sequence new-resizable drop ; inline INSTANCE: vector growable diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 806d09bf9e..b756c0b681 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -294,6 +294,16 @@ HELP: delimiter? { $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." } { $notes "Outputs " { $link f } " if the object is not a word." } ; +HELP: deprecated? +{ $values { "obj" object } { "?" "a boolean" } } +{ $description "Tests if an object is " { $link POSTPONE: deprecated } "." } +{ $notes "Outputs " { $link f } " if the object is not a word." } ; + +HELP: make-deprecated +{ $values { "word" word } } +{ $description "Declares a word as " { $link POSTPONE: deprecated } "." } +{ $side-effects "word" } ; + HELP: make-flushable { $values { "word" word } } { $description "Declares a word as " { $link POSTPONE: flushable } "." } diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 0ecf7b65f0..c3dacbaf14 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -122,6 +122,6 @@ DEFER: x [ all-words [ "compiled-uses" word-prop - keys [ "forgotten" word-prop ] any? - ] filter + keys [ "forgotten" word-prop ] filter + ] map harvest ] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index 2ebdb8b7a8..df5bc84ede 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -12,7 +12,7 @@ IN: words M: word execute (execute) ; -M: word ?execute execute( -- value ) ; +M: word ?execute execute( -- value ) ; inline M: word <=> [ [ name>> ] [ vocabulary>> ] bi 2array ] compare ; @@ -123,6 +123,9 @@ M: word subwords drop f ; : define-declared ( word def effect -- ) [ nip swap set-stack-effect ] [ drop define ] 3bi ; +: make-deprecated ( word -- ) + t "deprecated" set-word-prop ; + : make-inline ( word -- ) dup inline? [ drop ] [ [ t "inline" set-word-prop ] @@ -148,7 +151,7 @@ M: word reset-word { "unannotated-def" "parsing" "inline" "recursive" "foldable" "flushable" "reading" "writing" "reader" - "writer" "delimiter" + "writer" "delimiter" "deprecated" } reset-props ; : reset-generic ( word -- ) @@ -200,6 +203,9 @@ M: parsing-word definer drop \ SYNTAX: \ ; ; : delimiter? ( obj -- ? ) dup word? [ "delimiter" word-prop ] [ drop f ] if ; +: deprecated? ( obj -- ? ) + dup word? [ "deprecated" word-prop ] [ drop f ] if ; + ! Definition protocol M: word where "loc" word-prop ; @@ -213,8 +219,8 @@ M: word forget* ] if ; M: word hashcode* - nip 1 slot { fixnum } declare ; foldable + nip 1 slot { fixnum } declare ; inline foldable M: word literalize ; -INSTANCE: word definition \ No newline at end of file +INSTANCE: word definition diff --git a/extra/adsoda/adsoda.factor b/extra/adsoda/adsoda.factor index c659e109ce..cc09ad5281 100755 --- a/extra/adsoda/adsoda.factor +++ b/extra/adsoda/adsoda.factor @@ -57,7 +57,7 @@ t to: remove-hidden-solids? : with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline -: dimension ( array -- x ) length 1- ; inline +: dimension ( array -- x ) length 1 - ; inline : change-last ( seq quot -- ) [ [ dimension ] keep ] dip change-nth ; inline @@ -99,7 +99,7 @@ TUPLE: light name { direction array } color ; : point-inside-or-on-halfspace? ( halfspace v -- ? ) position-point VERY-SMALL-NUM neg > ; : project-vector ( seq -- seq ) - pv> [ head ] [ 1+ tail ] 2bi append ; + pv> [ head ] [ 1 + tail ] 2bi append ; : get-intersection ( matrice -- seq ) [ 1 tail* ] map flip first ; @@ -336,7 +336,7 @@ TUPLE: solid dimension silhouettes : compute-adjacencies ( solid -- solid ) dup dimension>> [ >= ] curry [ keep swap ] curry MAX-FACE-PER-CORNER swap - [ [ test-faces-combinaisons ] 2keep 1- ] while drop ; + [ [ test-faces-combinaisons ] 2keep 1 - ] while drop ; : find-adjacencies ( solid -- solid ) erase-old-adjacencies @@ -435,7 +435,7 @@ TUPLE: space name dimension solids ambient-color lights ; [ [ non-empty-solid? ] filter ] change-solids ; : projected-space ( space solids -- space ) - swap dimension>> 1- + swap dimension>> 1 - swap >>dimension swap >>solids ; : get-silhouette ( solid -- silhouette ) diff --git a/extra/adsoda/combinators/combinators.factor b/extra/adsoda/combinators/combinators.factor index 4e4bbff72d..d00eebc976 100755 --- a/extra/adsoda/combinators/combinators.factor +++ b/extra/adsoda/combinators/combinators.factor @@ -13,7 +13,7 @@ IN: adsoda.combinators ! { [ dup 0 = ] [ 2drop { { } } ] } ! { [ over empty? ] [ 2drop { } ] } ! { [ t ] [ -! [ [ 1- (combinations) ] [ drop first ] 2bi prefix-each ] +! [ [ 1 - (combinations) ] [ drop first ] 2bi prefix-each ] ! [ (combinations) ] 2bi append ! ] } ! } cond ; @@ -26,7 +26,7 @@ IN: adsoda.combinators { [ over 1 = ] [ 3drop columnize ] } { [ over 0 = ] [ 2drop 2drop { } ] } { [ 2dup < ] [ 2drop [ 1 cut ] dip - [ 1- among [ append ] with map ] + [ 1 - among [ append ] with map ] [ among append ] 2bi ] } { [ 2dup = ] [ 3drop 1array ] } diff --git a/extra/adsoda/solution2/solution2.factor b/extra/adsoda/solution2/solution2.factor index 3e0648128d..fa73120df3 100755 --- a/extra/adsoda/solution2/solution2.factor +++ b/extra/adsoda/solution2/solution2.factor @@ -66,7 +66,7 @@ SYMBOL: matrix : do-row ( exchange-with row# -- ) [ exchange-rows ] keep [ first-col ] keep - dup 1+ rows-from clear-col ; + dup 1 + rows-from clear-col ; : find-row ( row# quot -- i elt ) [ rows-from ] dip find ; inline @@ -76,8 +76,8 @@ SYMBOL: matrix : (echelon) ( col# row# -- ) over cols < over rows < and [ - 2dup pivot-row [ over do-row 1+ ] when* - [ 1+ ] dip (echelon) + 2dup pivot-row [ over do-row 1 + ] when* + [ 1 + ] dip (echelon) ] [ 2drop ] if ; diff --git a/extra/annotations/annotations-tests.factor b/extra/annotations/annotations-tests.factor index d5a13e48d8..48fd281c6c 100644 --- a/extra/annotations/annotations-tests.factor +++ b/extra/annotations/annotations-tests.factor @@ -10,7 +10,7 @@ IN: annotations.tests : four ( -- x ) !BROKEN this code is broken - 2 2 + 1+ ; + 2 2 + 1 + ; : five ( -- x ) !TODO return 5 diff --git a/extra/benchmark/beust2/beust2.factor b/extra/benchmark/beust2/beust2.factor index 6b3fd41575..14ebcb1c5b 100755 --- a/extra/benchmark/beust2/beust2.factor +++ b/extra/benchmark/beust2/beust2.factor @@ -15,7 +15,7 @@ IN: benchmark.beust2 remaining 1 <= [ listener call f ] [ - remaining 1- + remaining 1 - 0 value' 10 * used mask bitor @@ -29,12 +29,12 @@ IN: benchmark.beust2 ] any? ; inline recursive :: count-numbers ( max listener -- ) - 10 iota [ 1+ 1 1 0 max listener (count-numbers) ] any? drop ; + 10 iota [ 1 + 1 1 0 max listener (count-numbers) ] any? drop ; inline :: beust ( -- ) [let | i! [ 0 ] | - 5000000000 [ i 1+ i! ] count-numbers + 5000000000 [ i 1 + i! ] count-numbers i number>string " unique numbers." append print ] ; diff --git a/extra/benchmark/chameneos-redux/authors.txt b/extra/benchmark/chameneos-redux/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/benchmark/chameneos-redux/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/benchmark/chameneos-redux/chameneos-redux.factor b/extra/benchmark/chameneos-redux/chameneos-redux.factor new file mode 100644 index 0000000000..afd2f8830a --- /dev/null +++ b/extra/benchmark/chameneos-redux/chameneos-redux.factor @@ -0,0 +1,106 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators +concurrency.mailboxes fry io kernel make math math.parser +math.text.english sequences threads ; +IN: benchmark.chameneos-redux + +SYMBOLS: red yellow blue ; + +ERROR: bad-color-pair pair ; + +TUPLE: creature n color count self-count mailbox ; + +TUPLE: meeting-place count mailbox ; + +: ( count -- meeting-place ) + meeting-place new + swap >>count + >>mailbox ; + +: ( n color -- creature ) + creature new + swap >>color + swap >>n + 0 >>count + 0 >>self-count + >>mailbox ; + +: make-creatures ( colors -- seq ) + [ length iota ] [ ] bi [ ] 2map ; + +: complement-color ( color1 color2 -- color3 ) + 2dup = [ drop ] [ + 2array { + { { red yellow } [ blue ] } + { { red blue } [ yellow ] } + { { yellow red } [ blue ] } + { { yellow blue } [ red ] } + { { blue red } [ yellow ] } + { { blue yellow } [ red ] } + [ bad-color-pair ] + } case + ] if ; + +: color-string ( color1 color2 -- string ) + [ + [ [ name>> ] bi@ " + " glue % " -> " % ] + [ complement-color name>> % ] 2bi + ] "" make ; + +: print-color-table ( -- ) + { blue red yellow } dup + '[ _ '[ color-string print ] with each ] each ; + +: try-meet ( meeting-place creature -- ) + over count>> 0 < [ + 2drop + ] [ + [ swap mailbox>> mailbox-put ] + [ nip mailbox>> mailbox-get drop ] + [ try-meet ] 2tri + ] if ; + +: creature-meeting ( seq -- ) + first2 { + [ [ [ 1 + ] change-count ] bi@ 2drop ] + [ 2dup = [ [ 1 + ] change-self-count ] when 2drop ] + [ [ [ color>> ] bi@ complement-color ] [ [ (>>color) ] bi-curry@ bi ] 2bi ] + [ [ mailbox>> f swap mailbox-put ] bi@ ] + } 2cleave ; + +: run-meeting-place ( meeting-place -- ) + [ 1 - ] change-count + dup count>> 0 < [ + mailbox>> mailbox-get-all + [ f swap mailbox>> mailbox-put ] each + ] [ + [ mailbox>> 2 swap '[ _ mailbox-get ] replicate creature-meeting ] + [ run-meeting-place ] bi + ] if ; + +: number>chameneos-string ( n -- string ) + number>string string>digits [ number>text ] { } map-as " " join ; + +: chameneos-redux ( n colors -- ) + [ ] [ make-creatures ] bi* + { + [ nip nl bl [ bl ] [ color>> name>> write ] interleave nl ] + [ [ '[ _ _ try-meet ] in-thread ] with each ] + [ drop run-meeting-place ] + + [ nip [ [ count>> number>string write bl ] [ self-count>> number>text write nl ] bi ] each ] + [ nip 0 [ count>> + ] reduce bl number>chameneos-string print ] + } 2cleave ; + +! 6000000 for shootout, too slow right now + +: chameneos-redux-main ( -- ) + print-color-table + 60000 [ + { blue red yellow } chameneos-redux + ] [ + { blue red yellow red yellow blue red yellow red blue } chameneos-redux + ] bi ; + +MAIN: chameneos-redux-main diff --git a/extra/benchmark/fannkuch/fannkuch.factor b/extra/benchmark/fannkuch/fannkuch.factor index a69c53852d..63e635f3de 100644 --- a/extra/benchmark/fannkuch/fannkuch.factor +++ b/extra/benchmark/fannkuch/fannkuch.factor @@ -7,7 +7,7 @@ IN: benchmark.fannkuch : count ( quot: ( -- ? ) -- n ) #! Call quot until it returns false, return number of times #! it was true - [ 0 ] dip '[ _ dip swap [ [ 1+ ] when ] keep ] loop ; inline + [ 0 ] dip '[ _ dip swap [ [ 1 + ] when ] keep ] loop ; inline : count-flips ( perm -- flip# ) '[ @@ -19,12 +19,12 @@ IN: benchmark.fannkuch [ CHAR: 0 + write1 ] each nl ; inline : fannkuch-step ( counter max-flips perm -- counter max-flips ) - pick 30 < [ [ 1+ ] [ ] [ dup write-permutation ] tri* ] when + pick 30 < [ [ 1 + ] [ ] [ dup write-permutation ] tri* ] when count-flips max ; inline : fannkuch ( n -- ) [ - [ 0 0 ] dip [ 1+ ] B{ } map-as + [ 0 0 ] dip [ 1 + ] B{ } map-as [ fannkuch-step ] each-permutation nip ] keep "Pfannkuchen(" write pprint ") = " write . ; diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index f457b90c30..c1d554a5a3 100755 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -63,7 +63,7 @@ CONSTANT: homo-sapiens :: split-lines ( n quot -- ) n line-length /mod [ [ line-length quot call ] times ] dip - dup zero? [ drop ] quot if ; inline + quot unless-zero ; inline : write-random-fasta ( seed n chars floats desc id -- seed ) write-description diff --git a/extra/benchmark/fib4/fib4.factor b/extra/benchmark/fib4/fib4.factor index c988e5722e..fa49503797 100644 --- a/extra/benchmark/fib4/fib4.factor +++ b/extra/benchmark/fib4/fib4.factor @@ -9,10 +9,10 @@ C: box dup i>> 1 <= [ drop 1 ] [ - i>> 1- + i>> 1 - dup tuple-fib swap - i>> 1- + i>> 1 - tuple-fib swap i>> swap i>> + ] if ; inline recursive diff --git a/extra/benchmark/fib6/fib6.factor b/extra/benchmark/fib6/fib6.factor index f81b6a21a2..7ddd58468a 100755 --- a/extra/benchmark/fib6/fib6.factor +++ b/extra/benchmark/fib6/fib6.factor @@ -1,10 +1,10 @@ -IN: benchmark.fib6 USING: math kernel alien ; +IN: benchmark.fib6 : fib ( x -- y ) "int" { "int" } "cdecl" [ dup 1 <= [ drop 1 ] [ - 1- dup fib swap 1- fib + + 1 - dup fib swap 1 - fib + ] if ] alien-callback "int" { "int" } "cdecl" alien-indirect ; diff --git a/extra/benchmark/gc1/gc1.factor b/extra/benchmark/gc1/gc1.factor index d201a08ecf..8b0a3e6a43 100644 --- a/extra/benchmark/gc1/gc1.factor +++ b/extra/benchmark/gc1/gc1.factor @@ -3,6 +3,6 @@ USING: math sequences kernel ; IN: benchmark.gc1 -: gc1 ( -- ) 6000000 [ >bignum 1+ ] map drop ; +: gc1 ( -- ) 6000000 [ >bignum 1 + ] map drop ; -MAIN: gc1 \ No newline at end of file +MAIN: gc1 diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index 99b0ee15f4..fb4f17cca5 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -23,12 +23,12 @@ IN: benchmark.knucleotide : tally ( x exemplar -- b ) clone tuck [ - [ [ 1+ ] [ 1 ] if* ] change-at + [ [ 1 + ] [ 1 ] if* ] change-at ] curry each ; : small-groups ( x n -- b ) swap - [ length swap - 1+ ] 2keep + [ length swap - 1 + ] 2keep [ [ over + ] dip subseq ] 2curry map ; : handle-table ( inputs n -- ) diff --git a/extra/benchmark/mandel/colors/colors.factor b/extra/benchmark/mandel/colors/colors.factor index 9e0f2472e2..0300538ce1 100644 --- a/extra/benchmark/mandel/colors/colors.factor +++ b/extra/benchmark/mandel/colors/colors.factor @@ -12,7 +12,7 @@ CONSTANT: val 0.85 : ( nb-cols -- map ) dup [ - 360 * swap 1+ / sat val + 360 * swap 1 + / sat val 1 >rgba scale-rgb ] with map ; diff --git a/extra/benchmark/nbody/nbody.factor b/extra/benchmark/nbody/nbody.factor index f72ceb4629..983da88821 100644 --- a/extra/benchmark/nbody/nbody.factor +++ b/extra/benchmark/nbody/nbody.factor @@ -59,7 +59,7 @@ TUPLE: nbody-system { bodies array read-only } ; :: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- ) bodies [| body i | body each-quot call - bodies i 1+ tail-slice [ + bodies i 1 + tail-slice [ body pair-quot call ] each ] each-index ; inline diff --git a/extra/benchmark/nsieve-bits/nsieve-bits.factor b/extra/benchmark/nsieve-bits/nsieve-bits.factor index 246a962a55..9ccc2d8616 100644 --- a/extra/benchmark/nsieve-bits/nsieve-bits.factor +++ b/extra/benchmark/nsieve-bits/nsieve-bits.factor @@ -1,6 +1,6 @@ -IN: benchmark.nsieve-bits USING: math math.parser sequences sequences.private kernel bit-arrays make io ; +IN: benchmark.nsieve-bits : clear-flags ( step i seq -- ) 2dup length >= [ @@ -13,14 +13,14 @@ bit-arrays make io ; 2dup length < [ 2dup nth-unsafe [ over dup 2 * pick clear-flags - rot 1+ -rot ! increment count - ] when [ 1+ ] dip (nsieve-bits) + rot 1 + -rot ! increment count + ] when [ 1 + ] dip (nsieve-bits) ] [ 2drop ] if ; inline recursive : nsieve-bits ( m -- count ) - 0 2 rot 1+ dup set-bits (nsieve-bits) ; + 0 2 rot 1 + dup set-bits (nsieve-bits) ; : nsieve-bits. ( m -- ) [ "Primes up to " % dup # " " % nsieve-bits # ] "" make @@ -28,7 +28,7 @@ bit-arrays make io ; : nsieve-bits-main ( n -- ) dup 2^ 10000 * nsieve-bits. - dup 1- 2^ 10000 * nsieve-bits. + dup 1 - 2^ 10000 * nsieve-bits. 2 - 2^ 10000 * nsieve-bits. ; : nsieve-bits-main* ( -- ) 11 nsieve-bits-main ; diff --git a/extra/benchmark/nsieve-bytes/nsieve-bytes.factor b/extra/benchmark/nsieve-bytes/nsieve-bytes.factor index bbeccf750b..15c0f9ee0b 100644 --- a/extra/benchmark/nsieve-bytes/nsieve-bytes.factor +++ b/extra/benchmark/nsieve-bytes/nsieve-bytes.factor @@ -13,14 +13,14 @@ byte-arrays make io ; 2dup length < [ 2dup nth-unsafe 0 > [ over dup 2 * pick clear-flags - rot 1+ -rot ! increment count - ] when [ 1+ ] dip (nsieve) + rot 1 + -rot ! increment count + ] when [ 1 + ] dip (nsieve) ] [ 2drop ] if ; inline recursive : nsieve ( m -- count ) - 0 2 rot 1+ dup [ drop 1 ] change-each (nsieve) ; + 0 2 rot 1 + dup [ drop 1 ] change-each (nsieve) ; : nsieve. ( m -- ) [ "Primes up to " % dup # " " % nsieve # ] "" make print ; diff --git a/extra/benchmark/nsieve/nsieve.factor b/extra/benchmark/nsieve/nsieve.factor index 6fbc144e80..646c98f3a4 100644 --- a/extra/benchmark/nsieve/nsieve.factor +++ b/extra/benchmark/nsieve/nsieve.factor @@ -1,6 +1,6 @@ -IN: benchmark.nsieve USING: math math.parser sequences sequences.private kernel arrays make io ; +IN: benchmark.nsieve : clear-flags ( step i seq -- ) 2dup length >= [ @@ -13,14 +13,14 @@ arrays make io ; 2dup length < [ 2dup nth-unsafe [ over dup 2 * pick clear-flags - rot 1+ -rot ! increment count - ] when [ 1+ ] dip (nsieve) + rot 1 + -rot ! increment count + ] when [ 1 + ] dip (nsieve) ] [ 2drop ] if ; inline recursive : nsieve ( m -- count ) - 0 2 rot 1+ t (nsieve) ; + 0 2 rot 1 + t (nsieve) ; : nsieve. ( m -- ) [ "Primes up to " % dup # " " % nsieve # ] "" make print ; diff --git a/extra/benchmark/partial-sums/partial-sums.factor b/extra/benchmark/partial-sums/partial-sums.factor index 7c7c68b12d..023f5de5c2 100644 --- a/extra/benchmark/partial-sums/partial-sums.factor +++ b/extra/benchmark/partial-sums/partial-sums.factor @@ -5,21 +5,21 @@ 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 ] 2dip '[ 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 +: -1^ ( n -- -1/1 ) 2 mod 2 * 1 - ; inline ! The functions -: 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1- ^ ] summing-floats ; inline +: 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1 - ^ ] summing-floats ; inline : k^-0.5 ( n -- y ) [ -0.5 ^ ] summing-floats ; inline -: 1/k(k+1) ( n -- y ) [ dup 1+ * recip ] summing-floats ; inline +: 1/k(k+1) ( n -- y ) [ dup 1 + * recip ] summing-floats ; inline : flint-hills ( n -- y ) [ [ cube ] [ sin sq ] bi * recip ] summing-floats ; inline : cookson-hills ( n -- y ) [ [ cube ] [ cos sq ] bi * recip ] summing-floats ; inline : harmonic ( n -- y ) [ recip ] summing-floats ; inline : riemann-zeta ( n -- y ) [ sq recip ] summing-floats ; inline : alternating-harmonic ( n -- y ) [ [ -1^ ] keep /f ] summing-integers ; inline -: gregory ( n -- y ) [ [ -1^ ] [ 2.0 * 1- ] bi / ] summing-integers ; inline +: gregory ( n -- y ) [ [ -1^ ] [ 2.0 * 1 - ] bi / ] summing-integers ; inline : partial-sums ( n -- results ) [ diff --git a/extra/benchmark/recursive/recursive.factor b/extra/benchmark/recursive/recursive.factor index 128ec571f2..219c73ae0a 100755 --- a/extra/benchmark/recursive/recursive.factor +++ b/extra/benchmark/recursive/recursive.factor @@ -7,18 +7,18 @@ IN: benchmark.recursive : ack ( m n -- x ) { - { [ over zero? ] [ nip 1+ ] } - { [ dup zero? ] [ drop 1- 1 ack ] } - [ [ drop 1- ] [ 1- ack ] 2bi ack ] + { [ over zero? ] [ nip 1 + ] } + { [ dup zero? ] [ drop 1 - 1 ack ] } + [ [ drop 1 - ] [ 1 - ack ] 2bi ack ] } cond ; inline recursive : tak ( x y z -- t ) 2over <= [ 2nip ] [ - [ rot 1- -rot tak ] - [ -rot 1- -rot tak ] - [ 1- -rot tak ] + [ rot 1 - -rot tak ] + [ -rot 1 - -rot tak ] + [ 1 - -rot tak ] 3tri tak ] if ; inline recursive @@ -26,7 +26,7 @@ IN: benchmark.recursive : recursive ( n -- ) [ 3 swap ack . flush ] [ 27.0 + fib . flush ] - [ 1- [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri + [ 1 - [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri 3 fib . flush 3.0 2.0 1.0 tak . flush ; diff --git a/extra/benchmark/tuple-arrays/tuple-arrays.factor b/extra/benchmark/tuple-arrays/tuple-arrays.factor index 483311d4f4..bd9a7139b3 100644 --- a/extra/benchmark/tuple-arrays/tuple-arrays.factor +++ b/extra/benchmark/tuple-arrays/tuple-arrays.factor @@ -11,10 +11,10 @@ TUPLE-ARRAY: point : tuple-array-benchmark ( -- ) 100 [ drop 5000 [ - [ 1+ ] change-x - [ 1- ] change-y - [ 1+ 2 / ] change-z + [ 1 + ] change-x + [ 1 - ] change-y + [ 1 + 2 / ] change-z ] map [ z>> ] sigma ] sigma . ; -MAIN: tuple-array-benchmark \ No newline at end of file +MAIN: tuple-array-benchmark diff --git a/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor b/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor index ca57de822f..9562e42c4e 100644 --- a/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor +++ b/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor @@ -36,8 +36,7 @@ C-STRUCT: yuv_buffer 255 min 0 max ; inline : stride ( line yuv -- uvy yy ) - [ yuv_buffer-uv_stride swap 2/ * >fixnum ] - [ yuv_buffer-y_stride * >fixnum ] 2bi ; inline + [ yuv_buffer-uv_stride swap 2/ * ] [ yuv_buffer-y_stride * ] 2bi ; inline : compute-y ( yuv uvy yy x -- y ) + >fixnum nip swap yuv_buffer-y swap alien-unsigned-1 16 - ; inline @@ -74,16 +73,16 @@ C-STRUCT: yuv_buffer drop ; inline : yuv>rgb-pixel ( index rgb yuv uvy yy x -- index ) - compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline + compute-yuv compute-rgb store-rgb 3 + ; inline : yuv>rgb-row ( index rgb yuv y -- index ) over stride - pick yuv_buffer-y_width >fixnum + pick yuv_buffer-y_width [ yuv>rgb-pixel ] with with with with each ; inline : yuv>rgb ( rgb yuv -- ) [ 0 ] 2dip - dup yuv_buffer-y_height >fixnum + dup yuv_buffer-y_height [ yuv>rgb-row ] with with each drop ; diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index 620f737fe3..b7400c4acb 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -11,7 +11,7 @@ TUPLE: bunny-world < demo-world model-triangles geom draw-seq draw-n ; : next-draw ( gadget -- ) dup [ draw-seq>> ] [ draw-n>> ] bi - 1+ swap length mod + 1 + swap length mod >>draw-n relayout-1 ; : make-draws ( gadget -- draw-seq ) diff --git a/extra/central/central-tests.factor b/extra/central/central-tests.factor index 3dbcbf32fc..17c5ee901f 100644 --- a/extra/central/central-tests.factor +++ b/extra/central/central-tests.factor @@ -9,11 +9,11 @@ CENTRAL: test-central TUPLE: test-disp-cent value disposed ; ! A phony destructor that adds 1 to the value so we can make sure it got called. -M: test-disp-cent dispose* dup value>> 1+ >>value drop ; +M: test-disp-cent dispose* dup value>> 1 + >>value drop ; DISPOSABLE-CENTRAL: t-d-c : test-t-d-c ( -- n ) test-disp-cent new 3 >>value [ t-d-c ] with-t-d-c value>> ; -[ 4 ] [ test-t-d-c ] unit-test \ No newline at end of file +[ 4 ] [ test-t-d-c ] unit-test diff --git a/extra/classes/c-types/c-types-docs.factor b/extra/classes/c-types/c-types-docs.factor new file mode 100644 index 0000000000..58ebf7a063 --- /dev/null +++ b/extra/classes/c-types/c-types-docs.factor @@ -0,0 +1,72 @@ +! (c)Joe Groff bsd license +USING: alien arrays classes help.markup help.syntax kernel math +specialized-arrays.direct ; +IN: classes.c-types + +HELP: c-type-class +{ $class-description "This metaclass encompasses the " { $link "classes.c-types" } "." } ; + +HELP: char +{ $class-description "A signed one-byte integer quantity." } ; + +HELP: direct-array-of +{ $values + { "alien" c-ptr } { "len" integer } { "class" c-type-class } + { "array" "a direct array" } +} +{ $description "Constructs one of the " { $link "specialized-arrays.direct" } " over " { $snippet "len" } " elements of type " { $snippet "class" } " located at the referenced location in raw memory." } ; + +HELP: int +{ $class-description "A signed four-byte integer quantity." } ; + +HELP: long +{ $class-description "A signed integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ; + +HELP: longlong +{ $class-description "A signed eight-byte integer quantity." } ; + +HELP: short +{ $class-description "A signed two-byte integer quantity." } ; + +HELP: single-complex +{ $class-description "A single-precision complex floating point quantity." } ; + +HELP: single-float +{ $class-description "A single-precision floating point quantity." } ; + +HELP: uchar +{ $class-description "An unsigned one-byte integer quantity." } ; + +HELP: uint +{ $class-description "An unsigned four-byte integer quantity." } ; + +HELP: ulong +{ $class-description "An unsigned integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ; + +HELP: ulonglong +{ $class-description "An unsigned eight-byte integer quantity." } ; + +HELP: ushort +{ $class-description "An unsigned two-byte integer quantity." } ; + +ARTICLE: "classes.c-types" "C type classes" +"The " { $vocab-link "classes.c-types" } " vocabulary defines Factor classes that correspond to C types in the FFI." +{ $subsection char } +{ $subsection uchar } +{ $subsection short } +{ $subsection ushort } +{ $subsection int } +{ $subsection uint } +{ $subsection long } +{ $subsection ulong } +{ $subsection longlong } +{ $subsection ulonglong } +{ $subsection single-float } +{ $subsection float } +{ $subsection single-complex } +{ $subsection complex } +{ $subsection pinned-c-ptr } +"The vocabulary also provides a word for constructing " { $link "specialized-arrays.direct" } " of C types over raw memory:" +{ $subsection direct-array-of } ; + +ABOUT: "classes.c-types" diff --git a/extra/classes/c-types/c-types.factor b/extra/classes/c-types/c-types.factor new file mode 100644 index 0000000000..e53a813825 --- /dev/null +++ b/extra/classes/c-types/c-types.factor @@ -0,0 +1,118 @@ +! (c)Joe Groff bsd license +USING: alien alien.c-types classes classes.predicate kernel +math math.bitwise math.order namespaces sequences words +specialized-arrays.direct.alien +specialized-arrays.direct.bool +specialized-arrays.direct.char +specialized-arrays.direct.complex-double +specialized-arrays.direct.complex-float +specialized-arrays.direct.double +specialized-arrays.direct.float +specialized-arrays.direct.int +specialized-arrays.direct.long +specialized-arrays.direct.longlong +specialized-arrays.direct.short +specialized-arrays.direct.uchar +specialized-arrays.direct.uint +specialized-arrays.direct.ulong +specialized-arrays.direct.ulonglong +specialized-arrays.direct.ushort ; +IN: classes.c-types + +PREDICATE: char < fixnum + HEX: -80 HEX: 7f between? ; + +PREDICATE: uchar < fixnum + HEX: 0 HEX: ff between? ; + +PREDICATE: short < fixnum + HEX: -8000 HEX: 7fff between? ; + +PREDICATE: ushort < fixnum + HEX: 0 HEX: ffff between? ; + +PREDICATE: int < integer + HEX: -8000,0000 HEX: 7fff,ffff between? ; + +PREDICATE: uint < integer + HEX: 0 HEX: ffff,ffff between? ; + +PREDICATE: longlong < integer + HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ; + +PREDICATE: ulonglong < integer + HEX: 0 HEX: ffff,ffff,ffff,ffff between? ; + +UNION: single-float float ; +UNION: single-complex complex ; + +SYMBOLS: long ulong long-bits ; + +<< + "long" heap-size 8 = + [ + \ long integer [ HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ] define-predicate-class + \ ulong integer [ HEX: 0 HEX: ffff,ffff,ffff,ffff between? ] define-predicate-class + 64 \ long-bits set-global + ] [ + \ long integer [ HEX: -8000,0000 HEX: 7fff,ffff between? ] define-predicate-class + \ ulong integer [ HEX: 0 HEX: ffff,ffff between? ] define-predicate-class + 32 \ long-bits set-global + ] if +>> + +: set-class-c-type ( class initial c-type -- ) + [ "initial-value" set-word-prop ] + [ c-type "class-c-type" set-word-prop ] + [ "class-direct-array" set-word-prop ] tri-curry* tri ; + +: class-c-type ( class -- c-type ) + "class-c-type" word-prop ; +: class-direct-array ( class -- ) + "class-direct-array" word-prop ; + +\ f f "void*" \ set-class-c-type +pinned-c-ptr f "void*" \ set-class-c-type +boolean f "bool" \ set-class-c-type +char 0 "char" \ set-class-c-type +uchar 0 "uchar" \ set-class-c-type +short 0 "short" \ set-class-c-type +ushort 0 "ushort" \ set-class-c-type +int 0 "int" \ set-class-c-type +uint 0 "uint" \ set-class-c-type +long 0 "long" \ set-class-c-type +ulong 0 "ulong" \ set-class-c-type +longlong 0 "longlong" \ set-class-c-type +ulonglong 0 "ulonglong" \ set-class-c-type +float 0.0 "double" \ set-class-c-type +single-float 0.0 "float" \ set-class-c-type +complex C{ 0.0 0.0 } "complex-double" \ set-class-c-type +single-complex C{ 0.0 0.0 } "complex-float" \ set-class-c-type + +char [ 8 bits 8 >signed ] "coercer" set-word-prop +uchar [ 8 bits ] "coercer" set-word-prop +short [ 16 bits 16 >signed ] "coercer" set-word-prop +ushort [ 16 bits ] "coercer" set-word-prop +int [ 32 bits 32 >signed ] "coercer" set-word-prop +uint [ 32 bits ] "coercer" set-word-prop +long [ [ bits ] [ >signed ] ] long-bits get-global prefix "coercer" set-word-prop +ulong [ bits ] long-bits get-global prefix "coercer" set-word-prop +longlong [ 64 bits 64 >signed ] "coercer" set-word-prop +ulonglong [ 64 bits ] "coercer" set-word-prop + +PREDICATE: c-type-class < class + "class-c-type" word-prop ; + +GENERIC: direct-array-of ( alien len class -- array ) inline + +M: c-type-class direct-array-of + class-direct-array execute( alien len -- array ) ; inline + +M: c-type-class c-type class-c-type ; +M: c-type-class c-type-align class-c-type c-type-align ; +M: c-type-class c-type-getter class-c-type c-type-getter ; +M: c-type-class c-type-setter class-c-type c-type-setter ; +M: c-type-class c-type-boxer-quot class-c-type c-type-boxer-quot ; +M: c-type-class c-type-unboxer-quot class-c-type c-type-unboxer-quot ; +M: c-type-class heap-size class-c-type heap-size ; + diff --git a/extra/classes/struct/prettyprint/prettyprint.factor b/extra/classes/struct/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..6bf62f694c --- /dev/null +++ b/extra/classes/struct/prettyprint/prettyprint.factor @@ -0,0 +1,31 @@ +! (c)Joe Groff bsd license +USING: accessors assocs classes classes.struct kernel math +prettyprint.backend prettyprint.custom prettyprint.sections +see.private sequences words ; +IN: classes.struct.prettyprint + += + [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ] + [ drop \ STRUCT: ] if ; + +: struct>assoc ( struct -- assoc ) + [ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ; + +PRIVATE> + +M: struct-class see-class* + pprint-; block> ; + +M: struct pprint-delims + drop \ S{ \ } ; + +M: struct >pprint-sequence + [ class ] [ struct-slot-values ] bi class-slot-sequence ; + +M: struct pprint* + [ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ; diff --git a/extra/classes/struct/struct-docs.factor b/extra/classes/struct/struct-docs.factor new file mode 100644 index 0000000000..83d5859f7c --- /dev/null +++ b/extra/classes/struct/struct-docs.factor @@ -0,0 +1,89 @@ +! (c)Joe Groff bsd license +USING: alien classes help.markup help.syntax kernel libc +quotations slots ; +IN: classes.struct + +HELP: +{ $values + { "class" class } +} +{ $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ; + +HELP: +{ $values + { "class" class } + { "struct" struct } +} +{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized with the initial values specified in the struct definition." } ; + +{ malloc-struct memory>struct } related-words + +HELP: STRUCT: +{ $syntax "STRUCT: class { slot type } { slot type } ... ;" } +{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } } +{ $description "Defines a new " { $link struct } " type. The syntax is nearly identical to " { $link POSTPONE: TUPLE: } "; however, there are some additional restrictions on struct types:" +{ $list +{ "Struct classes cannot have a superclass defined." } +{ "The slots of a struct must all have a type declared. The type must be either another struct class, or one of the " { $link "classes.c-types" } "." } +{ { $link read-only } " slots on structs are not enforced, though they may be declared." } +} } ; + +HELP: S{ +{ $syntax "S{ class slots... }" } +{ $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } } +{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ; + +HELP: UNION-STRUCT: +{ $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" } +{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } } +{ $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ; + +HELP: define-struct-class +{ $values + { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" } +} +{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ; + +HELP: define-union-struct-class +{ $values + { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" } +} +{ $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ; + +HELP: malloc-struct +{ $values + { "class" class } + { "struct" struct } +} +{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized. The struct should be " { $link free } "d when it is no longer needed." } ; + +HELP: memory>struct +{ $values + { "ptr" c-ptr } { "class" class } + { "struct" struct } +} +{ $description "Constructs a new " { $link struct } " of the specified " { $snippet "class" } " at the memory location referenced by " { $snippet "ptr" } ". The referenced memory is unchanged." } ; + +HELP: struct +{ $class-description "The parent class of all struct types." } ; + +{ struct POSTPONE: STRUCT: POSTPONE: UNION-STRUCT: } related-words + +HELP: struct-class +{ $class-description "The metaclass of all " { $link struct } " classes." } ; + +ARTICLE: "classes.struct" "Struct classes" +{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:" +{ $subsection POSTPONE: STRUCT: } +"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:" +{ $subsection } +{ $subsection } +{ $subsection malloc-struct } +{ $subsection memory>struct } +"Structs have literal syntax like tuples:" +{ $subsection POSTPONE: S{ } +"Union structs are also supported, which behave like structs but share the same memory for all the type's slots." +{ $subsection POSTPONE: UNION-STRUCT: } +; + +ABOUT: "classes.struct" diff --git a/extra/classes/struct/struct-tests.factor b/extra/classes/struct/struct-tests.factor new file mode 100644 index 0000000000..912d33c7bc --- /dev/null +++ b/extra/classes/struct/struct-tests.factor @@ -0,0 +1,112 @@ +! (c)Joe Groff bsd license +USING: accessors alien.c-types alien.structs.fields classes.c-types +classes.struct combinators io.streams.string kernel libc literals math +multiline namespaces prettyprint prettyprint.config see tools.test ; +IN: classes.struct.tests + +STRUCT: struct-test-foo + { x char } + { y int initial: 123 } + { z boolean } ; + +STRUCT: struct-test-bar + { w ushort initial: HEX: ffff } + { foo struct-test-foo } ; + +[ 12 ] [ struct-test-foo heap-size ] unit-test +[ 16 ] [ struct-test-bar heap-size ] unit-test +[ 123 ] [ struct-test-foo y>> ] unit-test +[ 123 ] [ struct-test-bar foo>> y>> ] unit-test + +[ 1 2 3 t ] [ + 1 2 3 t struct-test-foo struct-test-bar + { + [ w>> ] + [ foo>> x>> ] + [ foo>> y>> ] + [ foo>> z>> ] + } cleave +] unit-test + +[ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test +[ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test + +UNION-STRUCT: struct-test-float-and-bits + { f single-float } + { bits uint } ; + +[ 1.0 ] [ struct-test-float-and-bits 1.0 float>bits >>bits f>> ] unit-test +[ 4 ] [ struct-test-float-and-bits heap-size ] unit-test + +[ ] [ struct-test-foo malloc-struct free ] unit-test + +[ "S{ struct-test-foo { y 7654 } }" ] +[ + f boa-tuples? + [ struct-test-foo 7654 >>y [ pprint ] with-string-writer ] + with-variable +] unit-test + +[ "S{ struct-test-foo f 0 7654 f }" ] +[ + t boa-tuples? + [ struct-test-foo 7654 >>y [ pprint ] with-string-writer ] + with-variable +] unit-test + +[ <" USING: classes.c-types classes.struct kernel ; +IN: classes.struct.tests +STRUCT: struct-test-foo + { x char initial: 0 } { y int initial: 123 } + { z boolean initial: f } ; +"> ] +[ [ struct-test-foo see ] with-string-writer ] unit-test + +[ <" USING: classes.c-types classes.struct ; +IN: classes.struct.tests +UNION-STRUCT: struct-test-float-and-bits + { f single-float initial: 0.0 } { bits uint initial: 0 } ; +"> ] +[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test + +[ { + T{ field-spec + { name "x" } + { offset 0 } + { type $[ char c-type ] } + { reader x>> } + { writer (>>x) } + } + T{ field-spec + { name "y" } + { offset 4 } + { type $[ int c-type ] } + { reader y>> } + { writer (>>y) } + } + T{ field-spec + { name "z" } + { offset 8 } + { type $[ boolean c-type ] } + { reader z>> } + { writer (>>z) } + } +} ] [ "struct-test-foo" c-type fields>> ] unit-test + +[ { + T{ field-spec + { name "f" } + { offset 0 } + { type $[ single-float c-type ] } + { reader f>> } + { writer (>>f) } + } + T{ field-spec + { name "bits" } + { offset 0 } + { type $[ uint c-type ] } + { reader bits>> } + { writer (>>bits) } + } +} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test + diff --git a/extra/classes/struct/struct.factor b/extra/classes/struct/struct.factor new file mode 100644 index 0000000000..3d4ffe138b --- /dev/null +++ b/extra/classes/struct/struct.factor @@ -0,0 +1,213 @@ +! (c)Joe Groff bsd license +USING: accessors alien alien.c-types alien.structs alien.structs.fields arrays +byte-arrays classes classes.c-types classes.parser classes.tuple +classes.tuple.parser classes.tuple.private combinators +combinators.smart fry generalizations generic.parser kernel +kernel.private libc macros make math math.order parser +quotations sequences slots slots.private struct-arrays words ; +FROM: slots => reader-word writer-word ; +IN: classes.struct + +! struct class + +TUPLE: struct + { (underlying) c-ptr read-only } ; + +PREDICATE: struct-class < tuple-class + \ struct subclass-of? ; + +: struct-slots ( struct -- slots ) + "struct-slots" word-prop ; + +! struct allocation + +M: struct >c-ptr + 2 slot { c-ptr } declare ; inline + +: memory>struct ( ptr class -- struct ) + over c-ptr? [ swap \ c-ptr bad-slot-value ] unless + tuple-layout [ 2 set-slot ] keep ; + +: malloc-struct ( class -- struct ) + [ heap-size malloc ] keep memory>struct ; inline + +: (struct) ( class -- struct ) + [ heap-size ] keep memory>struct ; inline + +: ( class -- struct ) + dup "prototype" word-prop + [ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline + +MACRO: ( class -- quot: ( ... -- struct ) ) + [ + [ \ (struct) [ ] 2sequence ] + [ + struct-slots + [ length \ ndip ] + [ [ name>> setter-word 1quotation ] map \ spread ] bi + ] bi + ] [ ] output>sequence ; + +: pad-struct-slots ( values class -- values' class ) + [ struct-slots [ initial>> ] map over length tail append ] keep ; + +: (reader-quot) ( slot -- quot ) + [ class>> c-type-getter-boxer ] + [ offset>> [ >c-ptr ] swap suffix ] bi prepend ; + +: (writer-quot) ( slot -- quot ) + [ class>> c-setter ] + [ offset>> [ >c-ptr ] swap suffix ] bi prepend ; + +: (boxer-quot) ( class -- quot ) + '[ _ memory>struct ] ; + +: (unboxer-quot) ( class -- quot ) + drop [ >c-ptr ] ; + +M: struct-class boa>object + swap pad-struct-slots + [ (struct) ] [ struct-slots ] bi + [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ; + +! Struct slot accessors + +GENERIC: struct-slot-values ( struct -- sequence ) + +M: struct-class reader-quot + nip (reader-quot) ; + +M: struct-class writer-quot + nip (writer-quot) ; + +: struct-slot-values-quot ( class -- quot ) + struct-slots + [ name>> reader-word 1quotation ] map + \ cleave [ ] 2sequence + \ output>array [ ] 2sequence ; + +: (define-struct-slot-values-method) ( class -- ) + [ \ struct-slot-values create-method-in ] + [ struct-slot-values-quot ] bi define ; + +! Struct as c-type + +: slot>field ( slot -- field ) + field-spec new swap { + [ name>> >>name ] + [ offset>> >>offset ] + [ class>> c-type >>type ] + [ name>> reader-word >>reader ] + [ name>> writer-word >>writer ] + } cleave ; + +: define-struct-for-class ( class -- ) + [ + { + [ name>> ] + [ "struct-size" word-prop ] + [ "struct-align" word-prop ] + [ struct-slots [ slot>field ] map ] + } cleave + (define-struct) + ] [ + [ name>> c-type ] + [ (unboxer-quot) >>unboxer-quot ] + [ (boxer-quot) >>boxer-quot ] tri drop + ] bi ; + +: align-offset ( offset class -- offset' ) + c-type-align align ; + +: struct-offsets ( slots -- size ) + 0 [ + [ class>> align-offset ] keep + [ (>>offset) ] [ class>> heap-size + ] 2bi + ] reduce ; + +: union-struct-offsets ( slots -- size ) + [ 0 >>offset class>> heap-size ] [ max ] map-reduce ; + +: struct-align ( slots -- align ) + [ class>> c-type-align ] [ max ] map-reduce ; + +M: struct-class c-type + name>> c-type ; + +M: struct-class c-type-align + "struct-align" word-prop ; + +M: struct-class c-type-getter + drop [ swap ] ; + +M: struct-class c-type-setter + [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri + '[ @ swap @ _ memcpy ] ; + +M: struct-class c-type-boxer-quot + (boxer-quot) ; + +M: struct-class c-type-unboxer-quot + (unboxer-quot) ; + +M: struct-class heap-size + "struct-size" word-prop ; + +M: struct-class direct-array-of + ; + +! class definition + +: struct-prototype ( class -- prototype ) + [ heap-size ] + [ memory>struct ] + [ struct-slots ] tri + [ + [ initial>> ] + [ (writer-quot) ] bi + over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if + ] each ; + +: (struct-word-props) ( class slots size align -- ) + [ + [ "struct-slots" set-word-prop ] + [ define-accessors ] 2bi + ] + [ "struct-size" set-word-prop ] + [ "struct-align" set-word-prop ] tri-curry* + [ tri ] 3curry + [ dup struct-prototype "prototype" set-word-prop ] + [ (define-struct-slot-values-method) ] tri ; + +: check-struct-slots ( slots -- ) + [ class>> c-type drop ] each ; + +: (define-struct-class) ( class slots offsets-quot -- ) + [ drop struct f define-tuple-class ] + swap '[ + make-slots dup + [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri + (struct-word-props) + ] + [ drop define-struct-for-class ] 2tri ; inline + +: define-struct-class ( class slots -- ) + [ struct-offsets ] (define-struct-class) ; + +: define-union-struct-class ( class slots -- ) + [ union-struct-offsets ] (define-struct-class) ; + +: parse-struct-definition ( -- class slots ) + CREATE-CLASS [ parse-tuple-slots ] { } make ; + +SYNTAX: STRUCT: + parse-struct-definition define-struct-class ; +SYNTAX: UNION-STRUCT: + parse-struct-definition define-union-struct-class ; + +USING: vocabs vocabs.loader ; + +"prettyprint" vocab [ "classes.struct.prettyprint" require ] when + +SYNTAX: S{ + scan-word dup struct-slots parse-tuple-literal-slots parsed ; diff --git a/extra/coroutines/coroutines-tests.factor b/extra/coroutines/coroutines-tests.factor index f4ac97354d..90e88f64fb 100644 --- a/extra/coroutines/coroutines-tests.factor +++ b/extra/coroutines/coroutines-tests.factor @@ -7,7 +7,7 @@ USING: coroutines kernel sequences prettyprint tools.test math ; [ drop 1 coyield* 2 coyield* 3 coterminate ] cocreate ; : test2 ( -- co ) - [ 1+ coyield* ] cocreate ; + [ 1 + coyield* ] cocreate ; test1 dup *coresume . dup *coresume . dup *coresume . dup *coresume 2drop [ test2 42 over coresume . dup *coresume . drop ] must-fail @@ -18,4 +18,4 @@ test1 dup *coresume . dup *coresume . dup *coresume . dup *coresume 2drop { "c" "b" "a" } [ test3 { "a" "b" "c" } over coresume [ dup *coresume [ *coresume ] dip ] dip ] unit-test -{ 4+2/3 } [ [ 1+ coyield 2 * coyield 3 / coreset ] cocreate 1 5 [ over coresume ] times nip ] unit-test \ No newline at end of file +{ 4+2/3 } [ [ 1 + coyield 2 * coyield 3 / coreset ] cocreate 1 5 [ over coresume ] times nip ] unit-test diff --git a/extra/crypto/barrett/barrett.factor b/extra/crypto/barrett/barrett.factor index 9d5c65aa94..10f99058b5 100644 --- a/extra/crypto/barrett/barrett.factor +++ b/extra/crypto/barrett/barrett.factor @@ -6,5 +6,5 @@ IN: crypto.barrett : barrett-mu ( n size -- mu ) #! Calculates Barrett's reduction parameter mu #! size = word size in bits (8, 16, 32, 64, ...) - [ [ log2 1+ ] [ / 2 * ] bi* ] + [ [ log2 1 + ] [ / 2 * ] bi* ] [ 2^ rot ^ swap /i ] 2bi ; diff --git a/extra/crypto/passwd-md5/passwd-md5.factor b/extra/crypto/passwd-md5/passwd-md5.factor index 286a313fda..30650c1e40 100644 --- a/extra/crypto/passwd-md5/passwd-md5.factor +++ b/extra/crypto/passwd-md5/passwd-md5.factor @@ -11,7 +11,7 @@ IN: crypto.passwd-md5 "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" nth ; inline : to64 ( v n -- string ) - [ [ -6 shift ] [ 6 2^ 1- bitand lookup-table ] bi ] + [ [ -6 shift ] [ 6 2^ 1 - bitand lookup-table ] bi ] replicate nip ; inline PRIVATE> diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor index f4ef4687b5..917e98a6ee 100644 --- a/extra/crypto/rsa/rsa.factor +++ b/extra/crypto/rsa/rsa.factor @@ -26,7 +26,7 @@ CONSTANT: public-key 65537 : modulus-phi ( numbits -- n phi ) #! Loop until phi is not divisible by the public key. dup rsa-primes [ * ] 2keep - [ 1- ] bi@ * + [ 1 - ] bi@ * dup public-key gcd nip 1 = [ rot drop ] [ diff --git a/extra/ctags/etags/etags.factor b/extra/ctags/etags/etags.factor index 40c0b791cf..615b38daf6 100644 --- a/extra/ctags/etags/etags.factor +++ b/extra/ctags/etags/etags.factor @@ -29,7 +29,7 @@ IN: ctags.etags H{ } clone swap [ swap [ etag-add ] keep ] each ; : lines>bytes ( seq n -- bytes ) - head 0 [ length 1+ + ] reduce ; + head 0 [ length 1 + + ] reduce ; : file>lines ( path -- lines ) ascii file-lines ; @@ -40,7 +40,7 @@ IN: ctags.etags 1 HEX: 7f % second dup number>string % 1 CHAR: , % - 1- lines>bytes number>string % + 1 - lines>bytes number>string % ] "" make ; : etag-length ( vector -- n ) @@ -72,4 +72,4 @@ IN: ctags.etags [ etag-strings ] dip ascii set-file-lines ; : etags ( path -- ) - [ (ctags) sort-values etag-hash >alist ] dip etags-write ; \ No newline at end of file + [ (ctags) sort-values etag-hash >alist ] dip etags-write ; diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor index dc08656f7e..77defb081d 100644 --- a/extra/cursors/cursors.factor +++ b/extra/cursors/cursors.factor @@ -68,7 +68,7 @@ M: from-sequence cursor-get-unsafe >from-sequence< nth-unsafe ; M: from-sequence cursor-advance - [ 1+ ] change-n drop ; + [ 1 + ] change-n drop ; : >input ( seq -- cursor ) 0 from-sequence boa ; inline diff --git a/extra/descriptive/descriptive-tests.factor b/extra/descriptive/descriptive-tests.factor index 755c57ceda..6630d2addb 100755 --- a/extra/descriptive/descriptive-tests.factor +++ b/extra/descriptive/descriptive-tests.factor @@ -1,16 +1,34 @@ -USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see ; +USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see +math.ratios ; IN: descriptive.tests DESCRIPTIVE: divide ( num denom -- fraction ) / ; [ 3 ] [ 9 3 divide ] unit-test -[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide } ] [ [ 3 0 divide ] [ ] recover ] unit-test -[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] [ \ divide [ see ] with-string-writer ] unit-test +[ + T{ descriptive-error f + { { "num" 3 } { "denom" 0 } } + T{ division-by-zero f 3 } + divide + } +] [ + [ 3 0 divide ] [ ] recover +] unit-test + +[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] +[ \ divide [ see ] with-string-writer ] unit-test DESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ; [ 3 ] [ 9 3 divide* ] unit-test -[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide* } ] [ [ 3 0 divide* ] [ ] recover ] unit-test + +[ + T{ descriptive-error f + { { "num" 3 } { "denom" 0 } } + T{ division-by-zero f 3 } + divide* + } +] [ [ 3 0 divide* ] [ ] recover ] unit-test [ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\n" ] [ \ divide* [ see ] with-string-writer ] unit-test diff --git a/extra/dns/misc/misc.factor b/extra/dns/misc/misc.factor index af080f61eb..72f553c0f7 100644 --- a/extra/dns/misc/misc.factor +++ b/extra/dns/misc/misc.factor @@ -16,7 +16,7 @@ IN: dns.misc ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ; +: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor index 644533d3a2..773fe31ea6 100644 --- a/extra/dns/server/server.factor +++ b/extra/dns/server/server.factor @@ -120,7 +120,7 @@ DEFER: query->rrs ! have-delegates? ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ; +: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ; : is-soa? ( name -- ? ) SOA IN query boa matching-rrs empty? not ; diff --git a/extra/ecdsa/ecdsa.factor b/extra/ecdsa/ecdsa.factor index d76b93a4d7..1000bb9d71 100644 --- a/extra/ecdsa/ecdsa.factor +++ b/extra/ecdsa/ecdsa.factor @@ -57,7 +57,7 @@ PRIVATE> KEY EC_KEY_get0_public_key dup [| PUB | KEY EC_KEY_get0_group :> GROUP - GROUP EC_GROUP_get_degree bits>bytes 1+ :> LEN + GROUP EC_GROUP_get_degree bits>bytes 1 + :> LEN LEN :> BIN GROUP PUB POINT_CONVERSION_COMPRESSED BIN LEN f EC_POINT_point2oct ssl-error @@ -72,4 +72,4 @@ PRIVATE> LEN *uint SIG resize ; : ecdsa-verify ( dgst sig -- ? ) - ec-key-handle [ 0 -rot [ dup length ] bi@ ] dip ECDSA_verify 0 > ; \ No newline at end of file + ec-key-handle [ 0 -rot [ dup length ] bi@ ] dip ECDSA_verify 0 > ; diff --git a/extra/game-loop/game-loop.factor b/extra/game-loop/game-loop.factor index 982319541b..5f78c6770c 100644 --- a/extra/game-loop/game-loop.factor +++ b/extra/game-loop/game-loop.factor @@ -1,5 +1,6 @@ USING: accessors calendar continuations destructors kernel math -math.order namespaces system threads ui ui.gadgets.worlds ; +math.order namespaces system threads ui ui.gadgets.worlds +sequences ; IN: game-loop TUPLE: game-loop @@ -40,23 +41,23 @@ TUPLE: game-loop-error game-loop error ; > ] bi draw* ; : tick ( loop -- ) delegate>> tick* ; : increment-tick ( loop -- ) - [ 1+ ] change-tick-number + [ 1 + ] change-tick-number dup tick-length>> [ + ] curry change-last-tick drop ; : ?tick ( loop count -- ) - dup zero? [ drop millis >>last-tick drop ] [ + [ millis >>last-tick drop ] [ over [ since-last-tick ] [ tick-length>> ] bi >= - [ [ drop increment-tick ] [ drop tick ] [ 1- ?tick ] 2tri ] + [ [ drop increment-tick ] [ drop tick ] [ 1 - ?tick ] 2tri ] [ 2drop ] if - ] if ; + ] if-zero ; : (run-loop) ( loop -- ) dup running?>> diff --git a/extra/hashcash/hashcash.factor b/extra/hashcash/hashcash.factor index a77ebf2577..2f94f3f2d6 100755 --- a/extra/hashcash/hashcash.factor +++ b/extra/hashcash/hashcash.factor @@ -69,7 +69,7 @@ M: hashcash string>> : (mint) ( tuple counter -- tuple ) 2dup set-suffix checksummed-bits pick - valid-guess? [ drop ] [ 1+ (mint) ] if ; + valid-guess? [ drop ] [ 1 + (mint) ] if ; PRIVATE> diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 02b45ee939..d206ae5f45 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -16,7 +16,7 @@ TUPLE: link attributes clickable ; : find-nth ( seq quot n -- i elt ) [ >alist ] 2dip -rot - '[ _ [ second @ ] find-from rot drop swap 1+ ] + '[ _ [ second @ ] find-from rot drop swap 1 + ] [ f 0 ] 2dip times drop first2 ; inline : find-first-name ( vector string -- i/f tag/f ) @@ -29,7 +29,7 @@ TUPLE: link attributes clickable ; : find-between* ( vector i/f tag/f -- vector ) over integer? [ [ tail-slice ] [ name>> ] bi* - dupd find-matching-close drop dup [ 1+ ] when + dupd find-matching-close drop dup [ 1 + ] when [ head ] [ first ] if* ] [ 3drop V{ } clone diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 6d9b778ee8..38aa291a3a 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -104,7 +104,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] 0 [ [ 7 shift ] dip bitor ] reduce ; : synchsafe>seq ( n -- seq ) - dup 1+ log2 1+ 7 / ceiling + dup 1 + log2 1 + 7 / ceiling [ [ -7 shift ] keep HEX: 7f bitand ] replicate nip reverse ; : filter-text-data ( data -- filtered ) diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor index b065dfe2f0..6ce851e7dd 100644 --- a/extra/irc/client/internals/internals.factor +++ b/extra/irc/client/internals/internals.factor @@ -10,7 +10,7 @@ IN: irc.client.internals : do-connect ( server port quot: ( host port -- stream ) attempts -- stream/f ) dup 0 > [ [ drop call( host port -- stream ) ] - [ drop 15 sleep 1- do-connect ] + [ drop 15 sleep 1 - do-connect ] recover ] [ 2drop 2drop f ] if ; diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 986574ee91..ac5be9df2e 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -13,7 +13,7 @@ TUPLE: segment < oint number color radius ; C: segment : segment-number++ ( segment -- ) - [ number>> 1+ ] keep (>>number) ; + [ number>> 1 + ] keep (>>number) ; : clamp-length ( n seq -- n' ) 0 swap length clamp ; @@ -31,7 +31,7 @@ CONSTANT: random-rotation-angle $[ pi 20 / ] : (random-segments) ( segments n -- segments ) dup 0 > [ - [ dup last random-segment over push ] dip 1- (random-segments) + [ dup last random-segment over push ] dip 1 - (random-segments) ] [ drop ] if ; CONSTANT: default-segment-radius 1 @@ -78,7 +78,7 @@ CONSTANT: default-segment-radius 1 rot dup length swap find-nearest-segment ; : nearest-segment-backward ( segments oint start -- segment ) - swapd 1+ 0 spin find-nearest-segment ; + swapd 1 + 0 spin find-nearest-segment ; : nearest-segment ( segments oint start-segment -- segment ) #! find the segment nearest to 'oint', and return it. @@ -91,10 +91,10 @@ CONSTANT: default-segment-radius 1 over clamp-length swap nth ; : next-segment ( segments current-segment -- segment ) - number>> 1+ get-segment ; + number>> 1 + get-segment ; : previous-segment ( segments current-segment -- segment ) - number>> 1- get-segment ; + number>> 1 - get-segment ; : heading-segment ( segments current-segment heading -- segment ) #! the next segment on the given heading diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index 1ecd56d416..59efec1c02 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -75,7 +75,7 @@ SYMBOL: terms : inversions ( seq -- n ) 0 swap [ length ] keep [ - [ nth ] 2keep swap 1+ tail-slice (inversions) + + [ nth ] 2keep swap 1 + tail-slice (inversions) + ] curry each ; : duplicates? ( seq -- ? ) @@ -141,7 +141,7 @@ DEFER: (d) ! Computing a basis : graded ( seq -- seq ) - dup 0 [ length max ] reduce 1+ [ V{ } clone ] replicate + dup 0 [ length max ] reduce 1 + [ V{ } clone ] replicate [ dup length pick nth push ] reduce ; : nth-basis-elt ( generators n -- elt ) @@ -176,7 +176,7 @@ DEFER: (d) ! Graded by degree : (graded-ker/im-d) ( n seq -- null/rank ) #! d: C(n) ---> C(n+1) - [ ?nth ] [ [ 1+ ] dip ?nth ] 2bi + [ ?nth ] [ [ 1 + ] dip ?nth ] 2bi dim-im/ker-d ; : graded-ker/im-d ( graded-basis -- seq ) @@ -240,7 +240,7 @@ DEFER: (d) ] if ; : graded-triple ( seq n -- triple ) - 3 [ 1- + ] with map swap [ ?nth ] curry map ; + 3 [ 1 - + ] with map swap [ ?nth ] curry map ; : graded-triples ( seq -- triples ) dup length [ graded-triple ] with map ; diff --git a/extra/math/analysis/analysis.factor b/extra/math/analysis/analysis.factor index a1fc0bd07b..39d6450ba0 100755 --- a/extra/math/analysis/analysis.factor +++ b/extra/math/analysis/analysis.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman, Slava Pestov, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.short-circuit kernel math math.constants math.functions - math.vectors sequences ; +USING: combinators.short-circuit kernel math math.constants +math.functions math.vectors sequences ; IN: math.analysis : stirling-fact ( n -- fact ) [ pi 2 * * sqrt ] [ [ e / ] keep ^ ] - [ 12 * recip 1+ ] tri * * ; + [ 12 * recip 1 + ] tri * * ; diff --git a/extra/math/dual/dual.factor b/extra/math/dual/dual.factor index 3e0e5437b4..55789778af 100644 --- a/extra/math/dual/dual.factor +++ b/extra/math/dual/dual.factor @@ -45,7 +45,7 @@ MACRO: duals>nweave ( n -- ) MACRO: chain-rule ( word -- e ) [ input-length '[ _ duals>nweave ] ] [ "derivative" word-prop ] - [ input-length 1+ '[ _ nspread ] ] + [ input-length 1 + '[ _ nspread ] ] tri '[ [ @ _ @ ] sum-outputs ] ; @@ -80,4 +80,4 @@ MACRO: dual-op ( word -- ) ! Specialize math functions to operate on dual numbers. [ all-words [ "derivative" word-prop ] filter - [ define-dual ] each ] with-compilation-unit \ No newline at end of file + [ define-dual ] each ] with-compilation-unit diff --git a/extra/math/finance/finance.factor b/extra/math/finance/finance.factor index 4823e358b0..5954b08c9b 100644 --- a/extra/math/finance/finance.factor +++ b/extra/math/finance/finance.factor @@ -7,10 +7,10 @@ IN: math.finance diff --git a/extra/math/primes/lists/lists.factor b/extra/math/primes/lists/lists.factor index 13f314f6ba..c2733058b3 100644 --- a/extra/math/primes/lists/lists.factor +++ b/extra/math/primes/lists/lists.factor @@ -6,4 +6,4 @@ IN: math.primes.lists : lprimes ( -- list ) 2 [ next-prime ] lfrom-by ; : lprimes-from ( n -- list ) - dup 3 < [ drop lprimes ] [ 1- next-prime [ next-prime ] lfrom-by ] if ; + dup 3 < [ drop lprimes ] [ 1 - next-prime [ next-prime ] lfrom-by ] if ; diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor index 492453450b..422036d5cc 100755 --- a/extra/math/text/english/english.factor +++ b/extra/math/text/english/english.factor @@ -87,7 +87,7 @@ SYMBOL: and-needed? ] if ; : (number>text) ( n -- str ) - [ negative-text ] [ abs 3digit-groups recombine ] bi append ; + [ negative-text ] [ abs 3 digit-groups recombine ] bi append ; PRIVATE> diff --git a/extra/math/text/french/french.factor b/extra/math/text/french/french.factor index f8b97103eb..8d313b9197 100644 --- a/extra/math/text/french/french.factor +++ b/extra/math/text/french/french.factor @@ -73,7 +73,7 @@ MEMO: units ( -- seq ) ! up to 10^99 } cond ; : over-1000000 ( n -- str ) - 3digit-groups [ 1+ units nth n-units ] map-index sift + 3 digit-groups [ 1 + units nth n-units ] map-index sift reverse " " join ; : decompose ( n -- str ) 1000000 /mod [ over-1000000 ] dip complete ; diff --git a/extra/math/text/utils/utils-docs.factor b/extra/math/text/utils/utils-docs.factor old mode 100644 new mode 100755 index e1d1a005d3..2352ab9488 --- a/extra/math/text/utils/utils-docs.factor +++ b/extra/math/text/utils/utils-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax ; IN: math.text.utils -HELP: 3digit-groups -{ $values { "n" "a positive integer" } { "seq" "a sequence" } } -{ $description "Decompose a number into 3 digits groups and return them in a sequence, starting with the units, then the tenths, etc." } ; +HELP: digit-groups +{ $values { "n" "a positive integer" } { "k" "a positive integer" } { "seq" "a sequence" } } +{ $description "Decompose a number into groups of " { $snippet "k" } " digits and return them in a sequence starting with the least significant grouped digits first." } ; diff --git a/extra/math/text/utils/utils-tests.factor b/extra/math/text/utils/utils-tests.factor old mode 100644 new mode 100755 index d14bb06a2a..04fbcdc1a7 --- a/extra/math/text/utils/utils-tests.factor +++ b/extra/math/text/utils/utils-tests.factor @@ -1,3 +1,3 @@ USING: math.text.utils tools.test ; -[ { 1 999 2 } ] [ 2999001 3digit-groups ] unit-test +[ { 1 999 2 } ] [ 2999001 3 digit-groups ] unit-test diff --git a/extra/math/text/utils/utils.factor b/extra/math/text/utils/utils.factor old mode 100644 new mode 100755 index 422a79a1f3..13551f19e4 --- a/extra/math/text/utils/utils.factor +++ b/extra/math/text/utils/utils.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007, 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences ; +USING: kernel fry math.functions math sequences ; IN: math.text.utils -: 3digit-groups ( n -- seq ) - [ dup 0 > ] [ 1000 /mod ] produce nip ; +: digit-groups ( n k -- seq ) + [ dup 0 > ] swap '[ _ 10^ /mod ] produce nip ; diff --git a/extra/memory/piles/authors.txt b/extra/memory/piles/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/memory/piles/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/memory/piles/piles-docs.factor b/extra/memory/piles/piles-docs.factor new file mode 100644 index 0000000000..c2bc29af1c --- /dev/null +++ b/extra/memory/piles/piles-docs.factor @@ -0,0 +1,49 @@ +! (c)2009 Joe Groff bsd license +USING: alien destructors help.markup help.syntax kernel math ; +IN: memory.piles + +HELP: +{ $values + { "size" integer } + { "pile" pile } +} +{ $description "Allocates " { $snippet "size" } " bytes of raw memory for a new " { $link pile } ". The pile should be " { $link dispose } "d when it is no longer needed." } ; + +HELP: not-enough-pile-space +{ $values + { "pile" pile } +} +{ $description "This error is thrown by " { $link pile-alloc } " when the " { $link pile } " does not have enough remaining space for the requested allocation." } ; + +HELP: pile +{ $class-description "A " { $snippet "pile" } " is a block of raw memory that can be apportioned out in constant time. A pile is allocated using the " { $link } " word. Blocks of memory can be requested from the pile using " { $link pile-alloc } ", and all the pile's memory can be reclaimed with " { $link pile-empty } "." } ; + +HELP: pile-align +{ $values + { "pile" pile } { "align" "a power of two" } + { "pile" pile } +} +{ $description "Adjusts a " { $link pile } "'s internal state so that the next call to " { $link pile-alloc } " will return a pointer aligned to " { $snippet "align" } " bytes relative to the pile's initial offset." } ; + +HELP: pile-alloc +{ $values + { "pile" pile } { "size" integer } + { "alien" alien } +} +{ $description "Requests " { $snippet "size" } " bytes from a " { $link pile } ". If the pile does not have enough space to satisfy the request, a " { $link not-enough-pile-space } " error is thrown." } ; + +HELP: pile-empty +{ $values + { "pile" pile } +} +{ $description "Reclaims all the memory allocated out of a " { $link pile } ". Allocations will resume from the beginning of the pile." } ; + +ARTICLE: "memory.piles" "Piles" +"A " { $link pile } " is a block of raw memory. Portions of its memory can be allocated from the beginning of the pile in constant time, and the pile can be emptied and its pointer reset to the beginning." +{ $subsection } +{ $subsection pile-alloc } +{ $subsection pile-align } +{ $subsection pile-empty } +"An example of the utility of piles is in video games. For example, the game Abuse was scripted with a Lisp dialect. In order to avoid stalls from traditional GC or heap-based allocators, the Abuse Lisp VM would allocate values from a preallocated pile over the course of a frame, and release the entire pile at the end of the frame." ; + +ABOUT: "memory.piles" diff --git a/extra/memory/piles/piles-tests.factor b/extra/memory/piles/piles-tests.factor new file mode 100644 index 0000000000..4bb9cc20b3 --- /dev/null +++ b/extra/memory/piles/piles-tests.factor @@ -0,0 +1,47 @@ +! (c)2009 Joe Groff bsd license +USING: accessors alien destructors kernel math +memory.piles tools.test ; +IN: memory.piles.tests + +[ 25 ] [ + [ + 100 &dispose + [ 25 pile-alloc ] [ 50 pile-alloc ] bi + swap [ alien-address ] bi@ - + ] with-destructors +] unit-test + +[ 32 ] [ + [ + 100 &dispose + [ 25 pile-alloc ] [ 8 pile-align 50 pile-alloc ] bi + swap [ alien-address ] bi@ - + ] with-destructors +] unit-test + +[ 75 ] [ + [ + 100 &dispose + dup 25 pile-alloc drop + dup 50 pile-alloc drop + offset>> + ] with-destructors +] unit-test + +[ 100 ] [ + [ + 100 &dispose + dup 25 pile-alloc drop + dup 75 pile-alloc drop + offset>> + ] with-destructors +] unit-test + +[ + [ + 100 &dispose + dup 25 pile-alloc drop + dup 76 pile-alloc drop + ] with-destructors +] [ not-enough-pile-space? ] must-fail-with + diff --git a/extra/memory/piles/piles.factor b/extra/memory/piles/piles.factor new file mode 100644 index 0000000000..b8a79b4824 --- /dev/null +++ b/extra/memory/piles/piles.factor @@ -0,0 +1,33 @@ +! (c)2009 Joe Groff bsd license +USING: accessors alien destructors kernel libc math ; +IN: memory.piles + +TUPLE: pile + { underlying c-ptr } + { size integer } + { offset integer } ; + +ERROR: not-enough-pile-space pile ; + +M: pile dispose + [ [ free ] when* f ] change-underlying drop ; + +: ( size -- pile ) + [ malloc ] keep 0 pile boa ; + +: pile-empty ( pile -- ) + 0 >>offset drop ; + +: pile-alloc ( pile size -- alien ) + [ + [ [ ] [ size>> ] [ offset>> ] tri ] dip + + < [ not-enough-pile-space ] [ drop ] if + ] [ + drop [ offset>> ] [ underlying>> ] bi + ] [ + [ + ] curry change-offset drop + ] 2tri ; + +: pile-align ( pile align -- pile ) + [ align ] curry change-offset ; + diff --git a/extra/memory/piles/summary.txt b/extra/memory/piles/summary.txt new file mode 100644 index 0000000000..f217f30294 --- /dev/null +++ b/extra/memory/piles/summary.txt @@ -0,0 +1 @@ +Preallocated raw memory blocks diff --git a/extra/memory/pools/authors.txt b/extra/memory/pools/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/memory/pools/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/memory/pools/pools-docs.factor b/extra/memory/pools/pools-docs.factor new file mode 100644 index 0000000000..a2cc5d7dad --- /dev/null +++ b/extra/memory/pools/pools-docs.factor @@ -0,0 +1,76 @@ +! (c)2009 Joe Groff bsd license +USING: classes help.markup help.syntax kernel math ; +IN: memory.pools + +HELP: +{ $values + { "size" integer } { "class" class } + { "pool" pool } +} +{ $description "Creates a " { $link pool } " of " { $snippet "size" } " objects of " { $snippet "class" } "." } ; + +HELP: POOL: +{ $syntax "POOL: class size" } +{ $description "Creates a " { $link pool } " of " { $snippet "size" } " objects of " { $snippet "class" } ", and associates it with the class using " { $link set-class-pool } "." } ; + +HELP: class-pool +{ $values + { "class" class } + { "pool" pool } +} +{ $description "Returns the " { $link pool } " associated with " { $snippet "class" } ", or " { $link f } " if no pool is associated." } ; + +HELP: free-to-pool +{ $values + { "object" object } +} +{ $description "Frees an object from the " { $link pool } " it was allocated from. The object must have been allocated by " { $link new-from-pool } "." } ; + +HELP: new-from-pool +{ $values + { "class" class } + { "object" object } +} +{ $description "Allocates an object from the " { $link pool } " associated with " { $snippet "class" } ". If the pool is exhausted, " { $link f } " is returned." } ; + +{ POSTPONE: POOL: class-pool set-class-pool new-from-pool free-to-pool } related-words + +HELP: pool +{ $class-description "A " { $snippet "pool" } " contains a fixed-size set of preallocated tuple objects. Once the pool has been allocated, its objects can be allocated with " { $link pool-new } " and freed with " { $link pool-free } " in constant time. A pool can also be associated with its class with the " { $link POSTPONE: POOL: } " syntax or the " { $link set-class-pool } " word, after which the words " { $link new-from-pool } " and " { $link free-to-pool } " can be used with the class name to allocate and free objects." } ; + +HELP: pool-free +{ $values + { "object" object } { "pool" pool } +} +{ $description "Frees an object back into " { $link pool } "." } ; + +HELP: pool-size +{ $values + { "pool" pool } + { "size" integer } +} +{ $description "Returns the number of unallocated objects inside a " { $link pool } "." } ; + +HELP: pool-new +{ $values + { "pool" pool } + { "object" object } +} +{ $description "Returns an unallocated object out of a " { $link pool } ". If the pool is exhausted, " { $link f } " is returned." } ; + +{ pool pool-new pool-free pool-size } related-words + +HELP: set-class-pool +{ $values + { "class" class } { "pool" pool } +} +{ $description "Associates a " { $link pool } " with " { $snippet "class" } "." } ; + +ARTICLE: "memory.pools" "Pools" +"The " { $vocab-link "memory.pools" } " vocabulary provides " { $link pool } " objects which manage preallocated collections of objects." +{ $subsection pool } +{ $subsection POSTPONE: POOL: } +{ $subsection new-from-pool } +{ $subsection free-to-pool } ; + +ABOUT: "memory.pools" diff --git a/extra/memory/pools/pools-tests.factor b/extra/memory/pools/pools-tests.factor new file mode 100644 index 0000000000..29f99a5a11 --- /dev/null +++ b/extra/memory/pools/pools-tests.factor @@ -0,0 +1,28 @@ +! (c)2009 Joe Groff bsd license +USING: kernel memory.pools tools.test ; +IN: memory.pools.tests + +TUPLE: foo x ; + +[ 1 ] [ + foo 2 foo set-class-pool + + foo new-from-pool drop + foo class-pool pool-size +] unit-test + +[ T{ foo } T{ foo } f ] [ + foo 2 foo set-class-pool + + foo new-from-pool + foo new-from-pool + foo new-from-pool +] unit-test + +[ f ] [ + foo 2 foo set-class-pool + + foo new-from-pool + foo new-from-pool + eq? +] unit-test diff --git a/extra/memory/pools/pools.factor b/extra/memory/pools/pools.factor new file mode 100644 index 0000000000..33d1fbedcb --- /dev/null +++ b/extra/memory/pools/pools.factor @@ -0,0 +1,54 @@ +! (c)2009 Joe Groff bsd license +USING: accessors arrays bit-arrays classes +classes.tuple.private fry kernel locals parser +sequences sequences.private vectors words ; +IN: memory.pools + +TUPLE: pool + prototype + { objects vector } ; + +: ( size class -- pool ) + [ nip new ] + [ [ iota ] dip '[ _ new ] V{ } replicate-as ] 2bi + pool boa ; + +: pool-size ( pool -- size ) + objects>> length ; + + size + size [| n | n from array-nth n to set-array-nth ] each + to ; inline + +: (pool-new) ( pool -- object ) + objects>> [ f ] [ pop ] if-empty ; + +: (pool-init) ( pool object -- object ) + [ prototype>> ] dip copy-tuple ; inline + +PRIVATE> + +: pool-new ( pool -- object ) + dup (pool-new) [ (pool-init) ] [ drop f ] if* ; inline + +: pool-free ( object pool -- ) + objects>> push ; + +: class-pool ( class -- pool ) + "pool" word-prop ; + +: set-class-pool ( class pool -- ) + "pool" set-word-prop ; + +: new-from-pool ( class -- object ) + class-pool pool-new ; + +: free-to-pool ( object -- ) + dup class class-pool pool-free ; + +SYNTAX: POOL: + scan-word scan-word '[ _ swap ] [ swap set-class-pool ] bi ; + diff --git a/extra/memory/pools/summary.txt b/extra/memory/pools/summary.txt new file mode 100644 index 0000000000..e9e83c307c --- /dev/null +++ b/extra/memory/pools/summary.txt @@ -0,0 +1 @@ +Preallocated pools of tuple objects diff --git a/extra/monads/monads-tests.factor b/extra/monads/monads-tests.factor index 0f1eb8edda..5504633bb6 100644 --- a/extra/monads/monads-tests.factor +++ b/extra/monads/monads-tests.factor @@ -78,7 +78,7 @@ IN: monads.tests ] unit-test LAZY: nats-from ( n -- list ) - dup 1+ nats-from cons ; + dup 1 + nats-from cons ; : nats ( -- list ) 0 nats-from ; diff --git a/extra/money/money.factor b/extra/money/money.factor index 994d214335..36dedb2a65 100644 --- a/extra/money/money.factor +++ b/extra/money/money.factor @@ -28,6 +28,6 @@ ERROR: not-an-integer x ; [ [ dup string>number [ nip ] [ not-an-integer ] if* ] bi@ ] keep length - 10 swap ^ / + swap [ neg ] when ; + 10^ / + swap [ neg ] when ; SYNTAX: DECIMAL: scan parse-decimal parsed ; diff --git a/unmaintained/multi-methods/authors.txt b/extra/multi-methods/authors.txt similarity index 100% rename from unmaintained/multi-methods/authors.txt rename to extra/multi-methods/authors.txt diff --git a/unmaintained/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor similarity index 98% rename from unmaintained/multi-methods/multi-methods.factor rename to extra/multi-methods/multi-methods.factor index 17f0de120e..d3e1d443aa 100755 --- a/unmaintained/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -21,7 +21,7 @@ SYMBOL: total : canonicalize-specializer-1 ( specializer -- specializer' ) [ [ class? ] filter - [ length [ 1+ neg ] map ] keep zip + [ length [ 1 + neg ] map ] keep zip [ length args [ max ] change ] keep ] [ @@ -104,7 +104,7 @@ SYMBOL: total { 0 [ [ dup ] ] } { 1 [ [ over ] ] } { 2 [ [ pick ] ] } - [ 1- picker [ dip swap ] curry ] + [ 1 - picker [ dip swap ] curry ] } case ; : (multi-predicate) ( class picker -- quot ) diff --git a/unmaintained/multi-methods/summary.txt b/extra/multi-methods/summary.txt similarity index 100% rename from unmaintained/multi-methods/summary.txt rename to extra/multi-methods/summary.txt diff --git a/unmaintained/multi-methods/tags.txt b/extra/multi-methods/tags.txt similarity index 100% rename from unmaintained/multi-methods/tags.txt rename to extra/multi-methods/tags.txt diff --git a/unmaintained/multi-methods/tests/canonicalize.factor b/extra/multi-methods/tests/canonicalize.factor similarity index 100% rename from unmaintained/multi-methods/tests/canonicalize.factor rename to extra/multi-methods/tests/canonicalize.factor index 91982de95c..6ddd5d63ce 100644 --- a/unmaintained/multi-methods/tests/canonicalize.factor +++ b/extra/multi-methods/tests/canonicalize.factor @@ -1,6 +1,6 @@ -IN: multi-methods.tests USING: multi-methods tools.test math sequences namespaces system kernel strings ; +IN: multi-methods.tests [ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test diff --git a/unmaintained/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor similarity index 95% rename from unmaintained/multi-methods/tests/definitions.factor rename to extra/multi-methods/tests/definitions.factor index aa66f41d8d..a483a492b3 100644 --- a/unmaintained/multi-methods/tests/definitions.factor +++ b/extra/multi-methods/tests/definitions.factor @@ -1,9 +1,10 @@ -IN: multi-methods.tests USING: multi-methods tools.test math sequences namespaces system kernel strings words compiler.units quotations ; +IN: multi-methods.tests DEFER: fake \ fake H{ } clone "multi-methods" set-word-prop +<< (( -- )) \ fake set-stack-effect >> [ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test diff --git a/unmaintained/multi-methods/tests/legacy.factor b/extra/multi-methods/tests/legacy.factor similarity index 100% rename from unmaintained/multi-methods/tests/legacy.factor rename to extra/multi-methods/tests/legacy.factor index b6d732643f..28bfa286b9 100644 --- a/unmaintained/multi-methods/tests/legacy.factor +++ b/extra/multi-methods/tests/legacy.factor @@ -1,5 +1,5 @@ -IN: multi-methods.tests USING: math strings sequences tools.test ; +IN: multi-methods.tests GENERIC: legacy-test ( a -- b ) diff --git a/unmaintained/multi-methods/tests/syntax.factor b/extra/multi-methods/tests/syntax.factor similarity index 76% rename from unmaintained/multi-methods/tests/syntax.factor rename to extra/multi-methods/tests/syntax.factor index cc073099d8..afe6037adc 100644 --- a/unmaintained/multi-methods/tests/syntax.factor +++ b/extra/multi-methods/tests/syntax.factor @@ -1,9 +1,10 @@ -IN: multi-methods.tests USING: multi-methods tools.test math sequences namespaces system kernel strings definitions prettyprint debugger arrays hashtables continuations classes assocs accessors see ; +RENAME: GENERIC: multi-methods => multi-methods:GENERIC: +IN: multi-methods.tests -GENERIC: first-test ( -- ) +multi-methods:GENERIC: first-test ( -- ) [ t ] [ \ first-test generic? ] unit-test @@ -13,14 +14,14 @@ SINGLETON: paper INSTANCE: paper thing SINGLETON: scissors INSTANCE: scissors thing SINGLETON: rock INSTANCE: rock thing -GENERIC: beats? ( obj1 obj2 -- ? ) +multi-methods:GENERIC: beats? ( obj1 obj2 -- ? ) -METHOD: beats? { paper scissors } t ; -METHOD: beats? { scissors rock } t ; -METHOD: beats? { rock paper } t ; -METHOD: beats? { thing thing } f ; +METHOD: beats? { paper scissors } 2drop t ; +METHOD: beats? { scissors rock } 2drop t ; +METHOD: beats? { rock paper } 2drop t ; +METHOD: beats? { thing thing } 2drop f ; -: play ( obj1 obj2 -- ? ) beats? 2nip ; +: play ( obj1 obj2 -- ? ) beats? ; [ { } 3 play ] must-fail [ t ] [ error get no-method? ] unit-test @@ -34,7 +35,7 @@ METHOD: beats? { thing thing } f ; SYMBOL: some-var -GENERIC: hook-test ( -- obj ) +multi-methods:GENERIC: hook-test ( obj -- obj ) METHOD: hook-test { array { some-var array } } reverse ; METHOD: hook-test { { some-var array } } class ; @@ -57,7 +58,7 @@ TUPLE: busted-1 ; TUPLE: busted-2 ; INSTANCE: busted-2 busted TUPLE: busted-3 ; -GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 ) +multi-methods:GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 ) METHOD: busted-sort { busted-1 busted-2 } ; METHOD: busted-sort { busted-2 busted-3 } ; diff --git a/unmaintained/multi-methods/tests/topological-sort.factor b/extra/multi-methods/tests/topological-sort.factor similarity index 100% rename from unmaintained/multi-methods/tests/topological-sort.factor rename to extra/multi-methods/tests/topological-sort.factor diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index e627a745cd..2c7258bb68 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -3,7 +3,7 @@ namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.gadgets.worlds ui.render accessors combinators literals ; IN: opengl.demo-support -CONSTANT: FOV $[ 2.0 sqrt 1+ ] +CONSTANT: FOV $[ 2.0 sqrt 1 + ] CONSTANT: MOUSE-MOTION-SCALE 0.5 CONSTANT: KEY-ROTATE-STEP 10.0 diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 814821fba9..7a73561e56 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -339,7 +339,7 @@ LAZY: surrounded-by ( parser start end -- parser' ) 2drop epsilon ] [ 2dup exactly-n - -rot 1- at-most-n <|> + -rot 1 - at-most-n <|> ] if ; : at-least-n ( parser n -- parser' ) diff --git a/extra/peg-lexer/peg-lexer.factor b/extra/peg-lexer/peg-lexer.factor index eff0043ac3..dcde55c91a 100644 --- a/extra/peg-lexer/peg-lexer.factor +++ b/extra/peg-lexer/peg-lexer.factor @@ -11,8 +11,8 @@ CONSULT: assoc-protocol lex-hash hash>> ; :: prepare-pos ( v i -- c l ) [let | n [ i v head-slice ] | - v CHAR: \n n last-index -1 or 1+ - - n [ CHAR: \n = ] count 1+ + v CHAR: \n n last-index -1 or 1 + - + n [ CHAR: \n = ] count 1 + ] ; : store-pos ( v a -- ) @@ -25,12 +25,12 @@ M: lex-hash set-at [ swap hash>> set-at ] } case ; -:: at-pos ( t l c -- p ) t l head-slice [ length ] map sum l 1- + c + ; +:: at-pos ( t l c -- p ) t l head-slice [ length ] map sum l 1 - + c + ; M: lex-hash at* swap { { input [ drop lexer get text>> "\n" join t ] } - { pos [ drop lexer get [ text>> ] [ line>> 1- ] [ column>> 1+ ] tri at-pos t ] } + { pos [ drop lexer get [ text>> ] [ line>> 1 - ] [ column>> 1 + ] tri at-pos t ] } [ swap hash>> at* ] } case ; @@ -61,4 +61,4 @@ space = " " | "\n" | "\t" spaces = space* => [[ drop ignore ]] chunk = (!(space) .)+ => [[ >string ]] expr = spaces chunk -;EBNF \ No newline at end of file +;EBNF diff --git a/extra/prettyprint/callables/authors.txt b/extra/prettyprint/callables/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/prettyprint/callables/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/prettyprint/callables/callables-docs.factor b/extra/prettyprint/callables/callables-docs.factor new file mode 100644 index 0000000000..9865f0eaee --- /dev/null +++ b/extra/prettyprint/callables/callables-docs.factor @@ -0,0 +1,6 @@ +USING: help help.markup help.syntax kernel quotations ; +IN: prettyprint.callables + +HELP: simplify-callable +{ $values { "quot" callable } { "quot'" callable } } +{ $description "Converts " { $snippet "quot" } " into an equivalent quotation by simplifying usages of " { $link dip } ", " { $link call } ", " { $link curry } ", and " { $link compose } " with literal parameters. This word is used when callable objects are prettyprinted." } ; diff --git a/extra/prettyprint/callables/callables-tests.factor b/extra/prettyprint/callables/callables-tests.factor new file mode 100644 index 0000000000..9d9abb3305 --- /dev/null +++ b/extra/prettyprint/callables/callables-tests.factor @@ -0,0 +1,15 @@ +! (c) 2009 Joe Groff bsd license +USING: kernel math prettyprint prettyprint.callables +tools.test ; +IN: prettyprint.callables.tests + +[ [ dip ] ] [ [ dip ] simplify-callable ] unit-test +[ [ [ + ] dip ] ] [ [ [ + ] dip ] simplify-callable ] unit-test +[ [ + 5 ] ] [ [ 5 [ + ] dip ] simplify-callable ] unit-test +[ [ + ] ] [ [ [ + ] call ] simplify-callable ] unit-test +[ [ call ] ] [ [ call ] simplify-callable ] unit-test +[ [ 5 + ] ] [ [ 5 [ + ] curry call ] simplify-callable ] unit-test +[ [ 4 5 + ] ] [ [ 4 5 [ + ] 2curry call ] simplify-callable ] unit-test +[ [ 4 5 6 + ] ] [ [ 4 5 6 [ + ] 3curry call ] simplify-callable ] unit-test +[ [ + . ] ] [ [ [ + ] [ . ] compose call ] simplify-callable ] unit-test +[ [ . + ] ] [ [ [ + ] [ . ] prepose call ] simplify-callable ] unit-test diff --git a/extra/prettyprint/callables/callables.factor b/extra/prettyprint/callables/callables.factor new file mode 100644 index 0000000000..195a6ce48b --- /dev/null +++ b/extra/prettyprint/callables/callables.factor @@ -0,0 +1,75 @@ +! (c) 2009 Joe Groff bsd license +USING: combinators combinators.short-circuit generalizations +kernel macros math math.ranges prettyprint.custom quotations +sequences words ; +IN: prettyprint.callables + += [ ] 3sequence ] 2bi + prefix \ 2&& [ ] 2sequence ; + +: end-len>from-to ( seq end len -- from to seq ) + [ - ] [ drop 1 + ] 2bi rot ; + +: slice-change ( seq end len quot -- seq' ) + [ end-len>from-to ] dip + [ [ subseq ] dip call ] curry + [ replace-slice ] 3bi ; inline + +: when-slice-match ( seq i criteria quot -- seq' ) + [ [ 2dup ] dip slice-match? ] dip [ drop ] if ; inline + +: simplify-dip ( quot i -- quot' ) + { [ literal? ] [ callable? ] } + [ 2 [ first2 swap suffix ] slice-change ] when-slice-match ; + +: simplify-call ( quot i -- quot' ) + { [ callable? ] } + [ 1 [ first ] slice-change ] when-slice-match ; + +: simplify-curry ( quot i -- quot' ) + { [ literal? ] [ callable? ] } + [ 2 [ first2 swap prefix 1quotation ] slice-change ] when-slice-match ; + +: simplify-2curry ( quot i -- quot' ) + { [ literal? ] [ literal? ] [ callable? ] } + [ 3 [ [ 2 head ] [ third ] bi append 1quotation ] slice-change ] when-slice-match ; + +: simplify-3curry ( quot i -- quot' ) + { [ literal? ] [ literal? ] [ literal? ] [ callable? ] } + [ 4 [ [ 3 head ] [ fourth ] bi append 1quotation ] slice-change ] when-slice-match ; + +: simplify-compose ( quot i -- quot' ) + { [ callable? ] [ callable? ] } + [ 2 [ first2 append 1quotation ] slice-change ] when-slice-match ; + +: simplify-prepose ( quot i -- quot' ) + { [ callable? ] [ callable? ] } + [ 2 [ first2 swap append 1quotation ] slice-change ] when-slice-match ; + +: (simplify-callable) ( quot -- quot' ) + dup [ simple-combinators member? ] find { + { \ dip [ simplify-dip ] } + { \ call [ simplify-call ] } + { \ curry [ simplify-curry ] } + { \ 2curry [ simplify-2curry ] } + { \ 3curry [ simplify-3curry ] } + { \ compose [ simplify-compose ] } + { \ prepose [ simplify-prepose ] } + [ 2drop ] + } case ; + +PRIVATE> + +: simplify-callable ( quot -- quot' ) + [ (simplify-callable) ] to-fixed-point ; + +M: callable >pprint-sequence simplify-callable ; diff --git a/extra/prettyprint/callables/summary.txt b/extra/prettyprint/callables/summary.txt new file mode 100644 index 0000000000..870a5fa64d --- /dev/null +++ b/extra/prettyprint/callables/summary.txt @@ -0,0 +1 @@ +Quotation simplification for prettyprinting automatically-constructed callable objects diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor index 204527418b..d59b910344 100644 --- a/extra/project-euler/001/001.factor +++ b/extra/project-euler/001/001.factor @@ -23,7 +23,7 @@ IN: project-euler.001 diff --git a/extra/project-euler/012/012.factor b/extra/project-euler/012/012.factor index d2679f6309..223404b9d6 100644 --- a/extra/project-euler/012/012.factor +++ b/extra/project-euler/012/012.factor @@ -34,7 +34,7 @@ IN: project-euler.012 ! -------- : euler012 ( -- answer ) - 8 [ dup nth-triangle tau* 500 < ] [ 1+ ] while nth-triangle ; + 8 [ dup nth-triangle tau* 500 < ] [ 1 + ] while nth-triangle ; ! [ euler012 ] 10 ave-time ! 6573 ms ave run time - 346.27 SD (10 trials) diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor index b0305d5c39..49680177d5 100644 --- a/extra/project-euler/014/014.factor +++ b/extra/project-euler/014/014.factor @@ -36,7 +36,7 @@ IN: project-euler.014 [ drop ] [ nip ] if ; @@ -59,7 +59,7 @@ PRIVATE> diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor index 1b675d41c4..b548591b5e 100644 --- a/extra/project-euler/022/022.factor +++ b/extra/project-euler/022/022.factor @@ -32,7 +32,7 @@ IN: project-euler.022 ascii file-contents [ quotable? ] filter "," split ; : name-scores ( seq -- seq ) - [ 1+ swap alpha-value * ] map-index ; + [ 1 + swap alpha-value * ] map-index ; PRIVATE> diff --git a/extra/project-euler/025/025.factor b/extra/project-euler/025/025.factor index 5dfe7b9f56..e381e323d1 100644 --- a/extra/project-euler/025/025.factor +++ b/extra/project-euler/025/025.factor @@ -44,7 +44,7 @@ MEMO: fib ( m -- n ) string length > [ 1+ (digit-fib) ] [ nip ] if ; + 2dup fib number>string length > [ 1 + (digit-fib) ] [ nip ] if ; : digit-fib ( n -- term ) 1 (digit-fib) ; @@ -68,7 +68,7 @@ PRIVATE> integer ; + 1 - 5 log10 2 / + phi log10 / ceiling >integer ; PRIVATE> diff --git a/extra/project-euler/026/026.factor b/extra/project-euler/026/026.factor index 8e0cf37fa2..4f4466c395 100644 --- a/extra/project-euler/026/026.factor +++ b/extra/project-euler/026/026.factor @@ -37,7 +37,7 @@ IN: project-euler.026 1 1000 (a,b) [ prime? ] filter [ 1 swap / ] map ; : (mult-order) ( n a m -- k ) - 3dup ^ swap mod 1 = [ 2nip ] [ 1+ (mult-order) ] if ; + 3dup ^ swap mod 1 = [ 2nip ] [ 1 + (mult-order) ] if ; PRIVATE> diff --git a/extra/project-euler/027/027.factor b/extra/project-euler/027/027.factor index f7bffbf665..f97d8e9e0d 100644 --- a/extra/project-euler/027/027.factor +++ b/extra/project-euler/027/027.factor @@ -53,7 +53,7 @@ IN: project-euler.027 dup sq -rot * + + ; : (consecutive-primes) ( b a n -- m ) - 3dup quadratic prime? [ 1+ (consecutive-primes) ] [ 2nip ] if ; + 3dup quadratic prime? [ 1 + (consecutive-primes) ] [ 2nip ] if ; : consecutive-primes ( a b -- m ) swap 0 (consecutive-primes) ; diff --git a/extra/project-euler/030/030.factor b/extra/project-euler/030/030.factor index 2a75336a0d..b689df50bb 100644 --- a/extra/project-euler/030/030.factor +++ b/extra/project-euler/030/030.factor @@ -38,7 +38,7 @@ IN: project-euler.030 PRIVATE> : euler030 ( -- answer ) - 325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1- ; + 325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1 - ; ! [ euler030 ] 100 ave-time ! 1700 ms ave run time - 64.84 SD (100 trials) diff --git a/extra/project-euler/035/035.factor b/extra/project-euler/035/035.factor index 3784618423..7d98de62b1 100755 --- a/extra/project-euler/035/035.factor +++ b/extra/project-euler/035/035.factor @@ -39,13 +39,13 @@ IN: project-euler.035 : (circular?) ( seq n -- ? ) dup 0 > [ 2dup rotate 10 digits>integer - prime? [ 1- (circular?) ] [ 2drop f ] if + prime? [ 1 - (circular?) ] [ 2drop f ] if ] [ 2drop t ] if ; : circular? ( seq -- ? ) - dup length 1- (circular?) ; + dup length 1 - (circular?) ; PRIVATE> diff --git a/extra/project-euler/038/038.factor b/extra/project-euler/038/038.factor index 3c6e2eac02..dd70051082 100755 --- a/extra/project-euler/038/038.factor +++ b/extra/project-euler/038/038.factor @@ -39,7 +39,7 @@ IN: project-euler.038 pick length 8 > [ 2drop 10 digits>integer ] [ - [ * number>digits over push-all ] 2keep 1+ (concat-product) + [ * number>digits over push-all ] 2keep 1 + (concat-product) ] if ; : concat-product ( n -- m ) diff --git a/extra/project-euler/039/039.factor b/extra/project-euler/039/039.factor index dee3f9804c..1ad163d507 100755 --- a/extra/project-euler/039/039.factor +++ b/extra/project-euler/039/039.factor @@ -37,8 +37,8 @@ SYMBOL: p-count p-count get length ; : adjust-p-count ( n -- ) - max-p 1- over p-count get - [ [ 1+ ] change-nth ] curry each ; + max-p 1 - over p-count get + [ [ 1 + ] change-nth ] curry each ; : (count-perimeters) ( seq -- ) dup sum max-p < [ diff --git a/extra/project-euler/040/040.factor b/extra/project-euler/040/040.factor index 86fb34629e..a60714357e 100755 --- a/extra/project-euler/040/040.factor +++ b/extra/project-euler/040/040.factor @@ -28,7 +28,7 @@ IN: project-euler.040 : (concat-upto) ( n limit str -- str ) 2dup length > [ - pick number>string over push-all rot 1+ -rot (concat-upto) + pick number>string over push-all rot 1 + -rot (concat-upto) ] [ 2nip ] if ; @@ -37,7 +37,7 @@ IN: project-euler.040 SBUF" " clone 1 -rot (concat-upto) ; : nth-integer ( n str -- m ) - [ 1- ] dip nth 1string string>number ; + [ 1 - ] dip nth 1string string>number ; PRIVATE> diff --git a/extra/project-euler/042/042.factor b/extra/project-euler/042/042.factor index 8c74cc9b31..e531ba848f 100644 --- a/extra/project-euler/042/042.factor +++ b/extra/project-euler/042/042.factor @@ -35,7 +35,7 @@ IN: project-euler.042 : (triangle-upto) ( limit n -- ) 2dup nth-triangle > [ - dup nth-triangle , 1+ (triangle-upto) + dup nth-triangle , 1 + (triangle-upto) ] [ 2drop ] if ; @@ -61,7 +61,7 @@ PRIVATE> diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor index 75241499e1..bea7313abd 100644 --- a/extra/project-euler/043/043.factor +++ b/extra/project-euler/043/043.factor @@ -36,7 +36,7 @@ IN: project-euler.043 integer swap divisor? ; + [ 1 - dup 3 + ] dip subseq 10 digits>integer swap divisor? ; : interesting? ( seq -- ? ) { diff --git a/extra/project-euler/044/044.factor b/extra/project-euler/044/044.factor index 8fc979e8bc..4c2306c480 100644 --- a/extra/project-euler/044/044.factor +++ b/extra/project-euler/044/044.factor @@ -29,7 +29,7 @@ IN: project-euler.044 diff --git a/extra/project-euler/046/046.factor b/extra/project-euler/046/046.factor index 0aa9eafe58..13e39c815c 100755 --- a/extra/project-euler/046/046.factor +++ b/extra/project-euler/046/046.factor @@ -37,7 +37,7 @@ IN: project-euler.046 dup perfect-squares [ 2 * - ] with map [ prime? ] any? ; : next-odd-composite ( n -- m ) - dup odd? [ 2 + ] [ 1+ ] if dup prime? [ next-odd-composite ] when ; + dup odd? [ 2 + ] [ 1 + ] if dup prime? [ next-odd-composite ] when ; : disprove-conjecture ( n -- m ) dup fits-conjecture? [ next-odd-composite disprove-conjecture ] when ; diff --git a/extra/project-euler/047/047.factor b/extra/project-euler/047/047.factor index e251045cd4..e7b585bf0d 100644 --- a/extra/project-euler/047/047.factor +++ b/extra/project-euler/047/047.factor @@ -36,8 +36,8 @@ IN: project-euler.047 swap - nip ] [ dup prime? [ [ drop 0 ] 2dip ] [ - 2dup unique-factors length = [ [ 1+ ] 2dip ] [ [ drop 0 ] 2dip ] if - ] if 1+ (consecutive) + 2dup unique-factors length = [ [ 1 + ] 2dip ] [ [ drop 0 ] 2dip ] if + ] if 1 + (consecutive) ] if ; : consecutive ( goal test -- n ) @@ -69,10 +69,10 @@ SYMBOL: sieve sieve get nth 0 = ; : multiples ( n -- seq ) - sieve get length 1- over ; + sieve get length 1 - over ; : increment-counts ( n -- ) - multiples [ sieve get [ 1+ ] change-nth ] each ; + multiples [ sieve get [ 1 + ] change-nth ] each ; : prime-tau-upto ( limit -- seq ) dup initialize-sieve 2 swap [a,b) [ diff --git a/extra/project-euler/048/048.factor b/extra/project-euler/048/048.factor index 640a3a68f6..fde3fa6026 100644 --- a/extra/project-euler/048/048.factor +++ b/extra/project-euler/048/048.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions math.ranges project-euler.common sequences ; +USING: kernel math math.functions math.ranges +project-euler.common sequences ; IN: project-euler.048 ! http://projecteuler.net/index.php?section=problems&id=48 @@ -17,7 +18,7 @@ IN: project-euler.048 ! -------- : euler048 ( -- answer ) - 1000 [1,b] [ dup ^ ] sigma 10 10 ^ mod ; + 1000 [1,b] [ dup ^ ] sigma 10 10^ mod ; ! [ euler048 ] 100 ave-time ! 276 ms run / 1 ms GC ave time - 100 trials diff --git a/extra/project-euler/049/049.factor b/extra/project-euler/049/049.factor index 9ecf942ef6..8b6f635ee4 100644 --- a/extra/project-euler/049/049.factor +++ b/extra/project-euler/049/049.factor @@ -27,7 +27,7 @@ IN: project-euler.049 : count-digits ( n -- byte-array ) 10 [ - '[ 10 /mod _ [ 1+ ] change-nth dup 0 > ] loop drop + '[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop ] keep ; HINTS: count-digits fixnum ; diff --git a/extra/project-euler/050/050.factor b/extra/project-euler/050/050.factor index 0c5b288b65..6176ac81d2 100644 --- a/extra/project-euler/050/050.factor +++ b/extra/project-euler/050/050.factor @@ -66,7 +66,7 @@ IN: project-euler.050 2dup [ first ] bi@ > [ drop ] [ nip ] if ; : continue? ( pair seq -- ? ) - [ first ] [ length 1- ] bi* < ; + [ first ] [ length 1 - ] bi* < ; : (find-longest) ( best seq limit -- best ) [ longest-prime longest ] 2keep 2over continue? [ diff --git a/extra/project-euler/052/052.factor b/extra/project-euler/052/052.factor index c25b1adcc0..037cc87288 100644 --- a/extra/project-euler/052/052.factor +++ b/extra/project-euler/052/052.factor @@ -24,7 +24,7 @@ IN: project-euler.052 digits natural-sort ] map all-equal? ; @@ -35,9 +35,9 @@ IN: project-euler.052 : next-all-same ( x n -- n ) dup candidate? [ 2dup swap map-nx all-same-digits? - [ nip ] [ 1+ next-all-same ] if + [ nip ] [ 1 + next-all-same ] if ] [ - 1+ next-all-same + 1 + next-all-same ] if ; PRIVATE> diff --git a/extra/project-euler/055/055.factor b/extra/project-euler/055/055.factor index 07525fe6a4..09663d241f 100644 --- a/extra/project-euler/055/055.factor +++ b/extra/project-euler/055/055.factor @@ -50,7 +50,7 @@ IN: project-euler.055 : (lychrel?) ( n iteration -- ? ) dup 50 < [ [ add-reverse ] dip over palindrome? - [ 2drop f ] [ 1+ (lychrel?) ] if + [ 2drop f ] [ 1 + (lychrel?) ] if ] [ 2drop t ] if ; diff --git a/extra/project-euler/058/058.factor b/extra/project-euler/058/058.factor index 133175f2a8..6edf2ad22a 100644 --- a/extra/project-euler/058/058.factor +++ b/extra/project-euler/058/058.factor @@ -43,13 +43,13 @@ CONSTANT: PERCENT_PRIME 0.1 ! (n-2)² + 4(n-1) = odd squares, no need to calculate : prime-corners ( n -- m ) - 3 [1,b] swap '[ _ [ 1- * ] keep 2 - sq + prime? ] count ; + 3 [1,b] swap '[ _ [ 1 - * ] keep 2 - sq + prime? ] count ; : total-corners ( n -- m ) - 1- 2 * ; foldable + 1 - 2 * ; foldable : ratio-below? ( count length -- ? ) - total-corners 1+ / PERCENT_PRIME < ; + total-corners 1 + / PERCENT_PRIME < ; : next-layer ( count length -- count' length' ) 2 + [ prime-corners + ] keep ; diff --git a/extra/project-euler/069/069.factor b/extra/project-euler/069/069.factor index 3a59d66522..5094dcd674 100644 --- a/extra/project-euler/069/069.factor +++ b/extra/project-euler/069/069.factor @@ -70,7 +70,7 @@ PRIVATE> } cond product ; : primorial-upto ( limit -- m ) - 1 swap '[ dup primorial _ <= ] [ 1+ dup primorial ] produce + 1 swap '[ dup primorial _ <= ] [ 1 + dup primorial ] produce nip penultimate ; PRIVATE> diff --git a/extra/project-euler/075/075.factor b/extra/project-euler/075/075.factor index 5f54d8508e..7285078bcf 100755 --- a/extra/project-euler/075/075.factor +++ b/extra/project-euler/075/075.factor @@ -50,8 +50,8 @@ SYMBOL: p-count p-count get length ; : adjust-p-count ( n -- ) - max-p 1- over p-count get - [ [ 1+ ] change-nth ] curry each ; + max-p 1 - over p-count get + [ [ 1 + ] change-nth ] curry each ; : (count-perimeters) ( seq -- ) dup sum max-p < [ diff --git a/extra/project-euler/076/076.factor b/extra/project-euler/076/076.factor index e6ed9035d2..8615a272ae 100644 --- a/extra/project-euler/076/076.factor +++ b/extra/project-euler/076/076.factor @@ -35,7 +35,7 @@ IN: project-euler.076 over zero? [ 3drop ] [ - [ [ 1- 2array ] dip at ] + [ [ 1 - 2array ] dip at ] [ [ use 2array ] dip at + ] [ [ 2array ] dip set-at ] 3tri ] if ; @@ -46,7 +46,7 @@ IN: project-euler.076 : (euler076) ( n -- m ) dup init [ [ ways ] curry each-subproblem ] - [ [ dup 2array ] dip at 1- ] 2bi ; + [ [ dup 2array ] dip at 1 - ] 2bi ; PRIVATE> diff --git a/extra/project-euler/092/092.factor b/extra/project-euler/092/092.factor index 4901eae342..9f22460b3c 100644 --- a/extra/project-euler/092/092.factor +++ b/extra/project-euler/092/092.factor @@ -38,7 +38,7 @@ IN: project-euler.092 567 [1,b] [ chain-ending ] map ; : fast-chain-ending ( seq n -- m ) - dup 567 > [ next-link ] when 1- swap nth ; + dup 567 > [ next-link ] when 1 - swap nth ; PRIVATE> diff --git a/extra/project-euler/097/097.factor b/extra/project-euler/097/097.factor index a8895c215a..35c3629035 100644 --- a/extra/project-euler/097/097.factor +++ b/extra/project-euler/097/097.factor @@ -23,7 +23,7 @@ IN: project-euler.097 ! -------- : euler097 ( -- answer ) - 2 7830457 10 10 ^ ^mod 28433 * 10 10 ^ mod 1+ ; + 2 7830457 10 10 ^ ^mod 28433 * 10 10 ^ mod 1 + ; ! [ euler097 ] 100 ave-time ! 0 ms ave run timen - 0.22 SD (100 trials) diff --git a/extra/project-euler/099/099.factor b/extra/project-euler/099/099.factor index 30bf52bebb..36fe7783fe 100644 --- a/extra/project-euler/099/099.factor +++ b/extra/project-euler/099/099.factor @@ -39,7 +39,7 @@ IN: project-euler.099 flip first2 swap [ log ] map v* ; : solve ( seq -- index ) - simplify [ supremum ] keep index 1+ ; + simplify [ supremum ] keep index 1 + ; PRIVATE> diff --git a/extra/project-euler/100/100.factor b/extra/project-euler/100/100.factor index 6f05eb7120..72584d833e 100644 --- a/extra/project-euler/100/100.factor +++ b/extra/project-euler/100/100.factor @@ -25,7 +25,7 @@ IN: project-euler.100 : euler100 ( -- answer ) 1 1 - [ dup dup 1- * 2 * 10 24 ^ <= ] + [ dup dup 1 - * 2 * 10 24 ^ <= ] [ tuck 6 * swap - 2 - ] while nip ; ! TODO: solution needs generalization diff --git a/extra/project-euler/116/116.factor b/extra/project-euler/116/116.factor index 2766322323..43eb30c9f6 100644 --- a/extra/project-euler/116/116.factor +++ b/extra/project-euler/116/116.factor @@ -38,13 +38,13 @@ IN: project-euler.116 base7 ( x -- y ) [ dup 0 > ] [ 7 /mod ] produce nip ; : (use-digit) ( prev x index -- next ) - [ [ 1+ * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ; + [ [ 1 + * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ; : (euler148) ( x -- y ) >base7 0 [ (use-digit) ] reduce-index ; diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor index eeb4b0c315..a54b7d1db0 100644 --- a/extra/project-euler/150/150.factor +++ b/extra/project-euler/150/150.factor @@ -56,10 +56,10 @@ IN: project-euler.150 :: (euler150) ( m -- n ) [let | table [ sums-triangle ] | m [| x | - x 1+ [| y | + x 1 + [| y | m x - [0,b) [| z | x z + table nth-unsafe - [ y z + 1+ swap nth-unsafe ] + [ y z + 1 + swap nth-unsafe ] [ y swap nth-unsafe ] bi - ] map partial-sum-infimum ] map-infimum diff --git a/extra/project-euler/151/151-tests.factor b/extra/project-euler/151/151-tests.factor new file mode 100644 index 0000000000..beea8e3645 --- /dev/null +++ b/extra/project-euler/151/151-tests.factor @@ -0,0 +1,4 @@ +USING: project-euler.151 tools.test ; +IN: project-euler.151.tests + +[ 12138569781349/26138246400000 ] [ euler151 ] unit-test diff --git a/extra/project-euler/151/151.factor b/extra/project-euler/151/151.factor index 66c5a6301e..ccdb76d80e 100644 --- a/extra/project-euler/151/151.factor +++ b/extra/project-euler/151/151.factor @@ -39,11 +39,11 @@ SYMBOL: table : (pick-sheet) ( seq i -- newseq ) [ - <=> sgn + <=> { - { -1 [ ] } - { 0 [ 1- ] } - { 1 [ 1+ ] } + { +lt+ [ ] } + { +eq+ [ 1 - ] } + { +gt+ [ 1 + ] } } case ] curry map-index ; @@ -59,9 +59,9 @@ DEFER: (euler151) : (euler151) ( x -- y ) table get [ { { { 0 0 0 1 } [ 0 ] } - { { 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+ ] } + { { 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 / ] } case ] cache ; @@ -71,8 +71,6 @@ DEFER: (euler151) { 1 1 1 1 } (euler151) ] with-scope ; -! TODO: doesn't work currently, problem in area of 'with map' in (euler151) - ! [ euler151 ] 100 ave-time ! ? ms run time - 100 trials diff --git a/extra/project-euler/169/169.factor b/extra/project-euler/169/169.factor index 5f0b853f0d..efd1c8ee60 100644 --- a/extra/project-euler/169/169.factor +++ b/extra/project-euler/169/169.factor @@ -30,7 +30,7 @@ MEMO: fn ( n -- x ) { { [ dup 2 < ] [ drop 1 ] } { [ dup odd? ] [ 2/ fn ] } - [ 2/ [ fn ] [ 1- fn ] bi + ] + [ 2/ [ fn ] [ 1 - fn ] bi + ] } cond ; : euler169 ( -- result ) diff --git a/extra/project-euler/175/175.factor b/extra/project-euler/175/175.factor index c99d670808..3473d9327c 100644 --- a/extra/project-euler/175/175.factor +++ b/extra/project-euler/175/175.factor @@ -42,7 +42,7 @@ IN: project-euler.175 : compute ( vec ratio -- ) { - { [ dup integer? ] [ 1- 0 add-bits ] } + { [ dup integer? ] [ 1 - 0 add-bits ] } { [ dup 1 < ] [ 1 over - / dupd compute 1 1 add-bits ] } [ [ 1 mod compute ] 2keep >integer 0 add-bits ] } cond ; diff --git a/extra/project-euler/186/186.factor b/extra/project-euler/186/186.factor index a9e62ec3a9..ed4f03dda1 100644 --- a/extra/project-euler/186/186.factor +++ b/extra/project-euler/186/186.factor @@ -58,7 +58,7 @@ IN: project-euler.186 pick [ next ] [ next ] bi [ = ] [ pick equate - [ 1+ ] dip + [ 1 + ] dip ] 2unless? (p186) ] [ drop nip diff --git a/extra/project-euler/190/190.factor b/extra/project-euler/190/190.factor index ec52af0415..19ff2c253c 100644 --- a/extra/project-euler/190/190.factor +++ b/extra/project-euler/190/190.factor @@ -43,7 +43,7 @@ IN: project-euler.190 PRIVATE> :: P_m ( m -- P_m ) - m [1,b] [| i | 2 i * m 1+ / i ^ ] PI ; + m [1,b] [| i | 2 i * m 1 + / i ^ ] PI ; : euler190 ( -- answer ) 2 15 [a,b] [ P_m truncate ] sigma ; diff --git a/extra/project-euler/203/203.factor b/extra/project-euler/203/203.factor index 2f165f6548..806098b865 100644 --- a/extra/project-euler/203/203.factor +++ b/extra/project-euler/203/203.factor @@ -45,7 +45,7 @@ IN: project-euler.203 [ 0 prefix ] [ 0 suffix ] bi [ + ] 2map ; : generate ( n -- seq ) - 1- { 1 } [ (generate) ] iterate concat prune ; + 1 - { 1 } [ (generate) ] iterate concat prune ; : squarefree ( n -- ? ) factors all-unique? ; diff --git a/extra/project-euler/215/215.factor b/extra/project-euler/215/215.factor index 30c42cc4be..1006b7a4cf 100644 --- a/extra/project-euler/215/215.factor +++ b/extra/project-euler/215/215.factor @@ -72,14 +72,14 @@ M: end h2 dup failure? [ ] unless ; : first-row ( n -- t ) [ ] dip - 1- [| a b c | b c a b ] times 2drop ; + 1 - [| a b c | b c a b ] times 2drop ; GENERIC: total ( t -- n ) M: block total [ total ] dup choice + ; M: end total ways>> ; : solve ( width height -- ways ) - [ first-row ] dip 1- [ next-row ] times total ; + [ first-row ] dip 1 - [ next-row ] times total ; PRIVATE> diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor index a7762836f1..dc521d4d70 100644 --- a/extra/project-euler/ave-time/ave-time.factor +++ b/extra/project-euler/ave-time/ave-time.factor @@ -1,11 +1,11 @@ ! Copyright (c) 2007, 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: continuations fry io kernel make math math.functions math.parser - math.statistics memory tools.time ; +USING: continuations fry io kernel make math math.functions +math.parser math.statistics memory tools.time ; IN: project-euler.ave-time : nth-place ( x n -- y ) - 10 swap ^ [ * round >integer ] keep /f ; + 10^ [ * round >integer ] keep /f ; : collect-benchmarks ( quot n -- seq ) [ @@ -14,7 +14,7 @@ IN: project-euler.ave-time '[ _ gc benchmark 1000 / , ] tuck '[ _ _ with-datastack drop ] ] - [ 1- ] tri* swap times call + [ 1 - ] tri* swap times call ] { } make ; inline : ave-time ( quot n -- ) diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 497fc31de7..4119f8205c 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -39,7 +39,7 @@ IN: project-euler.common : alpha-value ( str -- n ) - >lower [ CHAR: a - 1+ ] sigma ; + >lower [ CHAR: a - 1 + ] sigma ; : cartesian-product ( seq1 seq2 -- seq1xseq2 ) [ [ 2array ] with map ] curry map concat ; -: log10 ( m -- n ) - log 10 log / ; - : mediant ( a/c b/d -- (a+b)/(c+d) ) 2>fraction [ + ] 2bi@ / ; @@ -79,13 +76,13 @@ PRIVATE> [ dup 0 = not ] [ 10 /mod ] produce reverse nip ; : number-length ( n -- m ) - log10 floor 1+ >integer ; + log10 floor 1 + >integer ; : nth-prime ( n -- n ) - 1- lprimes lnth ; + 1 - lprimes lnth ; : nth-triangle ( n -- n ) - dup 1+ * 2 / ; + dup 1 + * 2 / ; : palindrome? ( n -- ? ) number>string dup reverse = ; @@ -94,7 +91,7 @@ PRIVATE> number>string natural-sort >string "123456789" = ; : pentagonal? ( n -- ? ) - dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ; + dup 0 > [ 24 * 1 + sqrt 1 + 6 / 1 mod zero? ] [ drop f ] if ; : penultimate ( seq -- elt ) dup length 2 - swap nth ; @@ -122,11 +119,11 @@ PRIVATE> ! The divisor function, counts the number of divisors : tau ( m -- n ) - group-factors flip second 1 [ 1+ * ] reduce ; + group-factors flip second 1 [ 1 + * ] reduce ; ! Optimized brute-force, is often faster than prime factorization : tau* ( m -- n ) - factor-2s dup [ 1+ ] + factor-2s dup [ 1 + ] [ perfect-square? -1 0 ? ] [ dup sqrt >fixnum [1,b] ] tri* [ dupd divisor? [ [ 2 + ] dip ] when diff --git a/extra/rpn/authors.txt b/extra/rpn/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/rpn/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/rpn/rpn.factor b/extra/rpn/rpn.factor new file mode 100644 index 0000000000..7175746862 --- /dev/null +++ b/extra/rpn/rpn.factor @@ -0,0 +1,45 @@ +! Copyright (C) 2009 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators io kernel lists math math.parser +sequences splitting ; +IN: rpn + +SINGLETONS: add-insn sub-insn mul-insn div-insn ; +TUPLE: push-insn value ; + +GENERIC: eval-insn ( stack insn -- stack ) + +: binary-op ( stack quot: ( x y -- z ) -- stack ) + [ uncons uncons ] dip dip cons ; inline + +M: add-insn eval-insn drop [ + ] binary-op ; +M: sub-insn eval-insn drop [ - ] binary-op ; +M: mul-insn eval-insn drop [ * ] binary-op ; +M: div-insn eval-insn drop [ / ] binary-op ; +M: push-insn eval-insn value>> swons ; + +: rpn-tokenize ( string -- string' ) + " " split harvest sequence>list ; + +: rpn-parse ( string -- tokens ) + rpn-tokenize [ + { + { "+" [ add-insn ] } + { "-" [ sub-insn ] } + { "*" [ mul-insn ] } + { "/" [ div-insn ] } + [ string>number push-insn boa ] + } case + ] lmap ; + +: print-stack ( list -- ) + [ number>string print ] leach ; + +: rpn-eval ( tokens -- ) + nil [ eval-insn ] foldl print-stack ; + +: rpn ( -- ) + "RPN> " write flush + readln [ rpn-parse rpn-eval rpn ] when* ; + +MAIN: rpn diff --git a/extra/rpn/summary.txt b/extra/rpn/summary.txt new file mode 100644 index 0000000000..e6b4fe239b --- /dev/null +++ b/extra/rpn/summary.txt @@ -0,0 +1 @@ +Simple RPN calculator diff --git a/extra/rpn/tags.txt b/extra/rpn/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/rpn/tags.txt @@ -0,0 +1 @@ +demos diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor index 0a6f3ef0db..d14a77057f 100644 --- a/extra/sequence-parser/sequence-parser.factor +++ b/extra/sequence-parser/sequence-parser.factor @@ -88,7 +88,7 @@ TUPLE: sequence-parser sequence n ; ] take-until :> found growing sequence sequence= [ found dup length - growing length 1- - head + growing length 1 - - head sequence-parser [ growing length - 1 + ] change-n drop ! sequence-parser advance drop ] [ diff --git a/extra/sequences/product/product.factor b/extra/sequences/product/product.factor index 665d43f0cd..9291fad3c0 100644 --- a/extra/sequences/product/product.factor +++ b/extra/sequences/product/product.factor @@ -23,11 +23,11 @@ M: product-sequence length lengths>> product ; [ lengths>> ns ] [ nip sequences>> ] 2bi ; :: (carry-n) ( ns lengths i -- ) - ns length i 1+ = [ + ns length i 1 + = [ i ns nth i lengths nth = [ 0 i ns set-nth - i 1+ ns [ 1+ ] change-nth - ns lengths i 1+ (carry-n) + i 1 + ns [ 1 + ] change-nth + ns lengths i 1 + (carry-n) ] when ] unless ; @@ -35,7 +35,7 @@ M: product-sequence length lengths>> product ; 0 (carry-n) ; : product-iter ( ns lengths -- ) - [ 0 over [ 1+ ] change-nth ] dip carry-ns ; + [ 0 over [ 1 + ] change-nth ] dip carry-ns ; : start-product-iter ( sequence-product -- ns lengths ) [ [ drop 0 ] map ] [ [ length ] map ] bi ; @@ -57,7 +57,7 @@ M: product-sequence nth 0 :> i! sequences [ length ] [ * ] map-reduce sequences [| result | - sequences [ quot call i result set-nth i 1+ i! ] product-each + sequences [ quot call i result set-nth i 1 + i! ] product-each result ] new-like ; inline diff --git a/extra/slides/slides.factor b/extra/slides/slides.factor index 29367a2b2b..32ceb3b677 100755 --- a/extra/slides/slides.factor +++ b/extra/slides/slides.factor @@ -90,7 +90,7 @@ TUPLE: slides < book ; [ first3 ] dip head 3array ; : strip-tease ( data -- seq ) - dup third length 1- [ + dup third length 1 - [ 2 + (strip-tease) ] with map ; diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor index 2eeee30692..0c1a5c07d1 100644 --- a/extra/smalltalk/compiler/compiler.factor +++ b/extra/smalltalk/compiler/compiler.factor @@ -123,7 +123,7 @@ M: ast-block compile-ast [ lexenv self>> suffix ] dip ; : compile-method-body ( lexenv block -- quot ) - [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] 2keep + [ [ (compile-method-body) ] [ arguments>> length 1 + ] bi ] 2keep make-return ; : compile-method ( lexenv ast-method -- ) @@ -154,4 +154,4 @@ M: ast-foreign compile-ast : compile-smalltalk ( statement -- quot ) [ empty-lexenv ] dip [ compile-sequence nip 0 ] - 2keep make-return ; \ No newline at end of file + 2keep make-return ; diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index 17e91473c3..9d3aa6c651 100644 --- a/extra/spider/spider.factor +++ b/extra/spider/spider.factor @@ -52,10 +52,10 @@ fetched-in parsed-html links processed-in fetched-at ; [ host>> = ] with partition ; : add-spidered ( spider spider-result -- ) - [ [ 1+ ] change-count ] dip + [ [ 1 + ] change-count ] dip 2dup [ spidered>> ] [ dup url>> ] bi* rot set-at [ filter-base-links ] 2keep - depth>> 1+ swap + depth>> 1 + swap [ add-nonmatching ] [ tuck [ apply-filters ] 2dip add-todo ] 2bi ; diff --git a/extra/sudoku/sudoku.factor b/extra/sudoku/sudoku.factor index 1554d3df20..555f1e632a 100755 --- a/extra/sudoku/sudoku.factor +++ b/extra/sudoku/sudoku.factor @@ -25,7 +25,7 @@ SYMBOL: board DEFER: search : assume ( n x y -- ) - [ >board ] 2keep [ [ 1+ ] dip search ] 2keep f>board ; + [ >board ] 2keep [ [ 1 + ] dip search ] 2keep f>board ; : attempt ( n x y -- ) { @@ -35,7 +35,7 @@ DEFER: search [ assume ] } cond ; -: solve ( x y -- ) 9 [ 1+ 2over attempt ] each 2drop ; +: solve ( x y -- ) 9 [ 1 + 2over attempt ] each 2drop ; : board. ( board -- ) standard-table-style [ @@ -59,9 +59,9 @@ DEFER: search : search ( x y -- ) { - { [ over 9 = ] [ [ drop 0 ] dip 1+ search ] } + { [ over 9 = ] [ [ drop 0 ] dip 1 + search ] } { [ over 0 = over 9 = and ] [ 2drop solution. ] } - { [ 2dup board> ] [ [ 1+ ] dip search ] } + { [ 2dup board> ] [ [ 1 + ] dip search ] } [ solve ] } cond ; diff --git a/extra/svg/svg.factor b/extra/svg/svg.factor index 2ed5d21707..2d2d38314a 100644 --- a/extra/svg/svg.factor +++ b/extra/svg/svg.factor @@ -11,7 +11,7 @@ XML-NS: inkscape-name http://www.inkscape.org/namespaces/inkscape : svg-string>number ( string -- number ) { { CHAR: E CHAR: e } } substitute "e" split1 - [ string>number ] [ [ string>number 10 swap ^ ] [ 1 ] if* ] bi* * + [ string>number ] [ [ string>number 10^ ] [ 1 ] if* ] bi* * >float ; : degrees ( deg -- rad ) pi * 180.0 / ; diff --git a/extra/system-info/windows/nt/nt.factor b/extra/system-info/windows/nt/nt.factor index 5be2dc89e2..3e0cffe71d 100755 --- a/extra/system-info/windows/nt/nt.factor +++ b/extra/system-info/windows/nt/nt.factor @@ -36,7 +36,7 @@ M: winnt available-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailVirtual ; : computer-name ( -- string ) - MAX_COMPUTERNAME_LENGTH 1+ + MAX_COMPUTERNAME_LENGTH 1 + [ dup ] keep GetComputerName win32-error=0/f alien>native-string ; diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 42aa7e903a..4304ba3432 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -11,7 +11,7 @@ math.affine-transforms noise ui.gestures combinators.short-circuit destructors grid-meshes ; IN: terrain -CONSTANT: FOV $[ 2.0 sqrt 1+ ] +CONSTANT: FOV $[ 2.0 sqrt 1 + ] CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ] CONSTANT: FAR-PLANE 2.0 CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 } diff --git a/extra/tetris/game/game.factor b/extra/tetris/game/game.factor index 00b5bb6c41..e1b5867f64 100644 --- a/extra/tetris/game/game.factor +++ b/extra/tetris/game/game.factor @@ -32,10 +32,10 @@ CONSTANT: default-height 20 [ not ] change-paused? drop ; : level>> ( tetris -- level ) - rows>> 1+ 10 / ceiling ; + rows>> 1 + 10 / ceiling ; : update-interval ( tetris -- interval ) - level>> 1- 60 * 1000 swap - ; + level>> 1 - 60 * 1000 swap - ; : add-block ( tetris block -- ) over board>> spin current-piece tetromino>> colour>> set-block ; @@ -57,7 +57,7 @@ CONSTANT: default-height 20 { 2 [ 100 ] } { 3 [ 300 ] } { 4 [ 1200 ] } - } case swap 1+ * ; + } case swap 1 + * ; : add-score ( tetris n-rows -- tetris ) over level>> swap rows-score swap [ + ] change-score ; diff --git a/extra/tetris/tetromino/tetromino.factor b/extra/tetris/tetromino/tetromino.factor index 68f8e85a4a..510daaec41 100644 --- a/extra/tetris/tetromino/tetromino.factor +++ b/extra/tetris/tetromino/tetromino.factor @@ -104,7 +104,7 @@ SYMBOL: tetrominoes tetrominoes get random ; : blocks-max ( blocks quot -- max ) - map [ 1+ ] [ max ] map-reduce ; inline + map [ 1 + ] [ max ] map-reduce ; inline : blocks-width ( blocks -- width ) [ first ] blocks-max ; diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index 4efea6ae42..62f4d8fce4 100755 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -41,9 +41,9 @@ CONSTANT: right 1 : go-left? ( -- ? ) current-side get left eq? ; -: inc-count ( tree -- ) [ 1+ ] change-count drop ; +: inc-count ( tree -- ) [ 1 + ] change-count drop ; -: dec-count ( tree -- ) [ 1- ] change-count drop ; +: dec-count ( tree -- ) [ 1 - ] change-count drop ; : node-link@ ( node ? -- node ) go-left? xor [ left>> ] [ right>> ] if ; diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor index 5ff5bb3879..8730c0acc4 100644 --- a/extra/ui/gadgets/lists/lists.factor +++ b/extra/ui/gadgets/lists/lists.factor @@ -23,7 +23,7 @@ TUPLE: list < pack index presenter color hook ; list-theme ; : calc-bounded-index ( n list -- m ) - control-value length 1- min 0 max ; + control-value length 1 - min 0 max ; : bound-index ( list -- ) dup index>> over calc-bounded-index >>index drop ; @@ -83,10 +83,10 @@ M: list focusable-child* drop t ; ] if ; : select-previous ( list -- ) - [ index>> 1- ] keep select-index ; + [ index>> 1 - ] keep select-index ; : select-next ( list -- ) - [ index>> 1+ ] keep select-index ; + [ index>> 1 + ] keep select-index ; : invoke-value-action ( list -- ) dup list-empty? [ diff --git a/extra/wordtimer/wordtimer.factor b/extra/wordtimer/wordtimer.factor index e02701b690..abf6a53657 100644 --- a/extra/wordtimer/wordtimer.factor +++ b/extra/wordtimer/wordtimer.factor @@ -14,7 +14,7 @@ SYMBOL: *calling* *wordtimes* get-global [ drop { 0 0 } ] cache first2 ; : update-times ( utime current-utime current-numinvokes -- utime' invokes' ) - rot [ + ] curry [ 1+ ] bi* ; + rot [ + ] curry [ 1 + ] bi* ; : register-time ( utime word -- ) name>> diff --git a/misc/vim/syntax/factor.vim b/misc/vim/syntax/factor.vim index 1d89c1c10e..00b4a4e9f7 100644 --- a/misc/vim/syntax/factor.vim +++ b/misc/vim/syntax/factor.vim @@ -50,7 +50,7 @@ syn keyword factorCompileDirective inline foldable recursive syn keyword factorKeyword or tuck 2bi 2tri while wrapper nip 4dip wrapper? bi* callstack>array both? hashcode die dupd callstack callstack? 3dup tri@ pick curry build ?execute 3bi prepose >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep clear 2dup when not tuple? dup 2bi* 2tri* call tri-curry object bi@ do unless* if* loop bi-curry* drop when* assert= retainstack assert? -rot execute 2bi@ 2tri@ boa with either? 3drop bi curry? datastack until 3dip over 3curry roll tri-curry* swap tri-curry@ 2nip and throw set-retainstack bi-curry (clone) hashcode* compose spin 2dip if 3tri unless compose? tuple keep 2curry equal? set-datastack assert tri 2drop most boolean? identity-tuple? null new set-callstack dip bi-curry@ rot -roll xor identity-tuple boolean syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect assoc-refine update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map assoc assoc-map enum value-at* remove-all assoc-map-as >alist assoc-filter-as substitute-here clear-assoc assoc-stack maybe-set-at substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? unzip syn keyword factorKeyword case execute-effect no-cond no-case? 3cleave>quot 2cleave cond>quot wrong-values? no-cond? cleave>quot no-case case>quot 3cleave wrong-values to-fixed-point alist>quot case-find cond cleave call-effect 2cleave>quot recursive-hashcode linear-case-quot spread spread>quot -syn keyword factorKeyword byte-array>bignum sgn >bignum next-float number= each-integer next-power-of-2 ?1+ fp-special? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum fp-snan? fp-infinity? denominator (all-integers?) times find-last-integer (each-integer) bit? * + fp-bitwise= - fp-qnan? / power-of-2? >= bitand find-integer complex < log2 > integer? real number bits>double double>bits bitor 2/ zero? rem fp-nan-payload all-integers? (find-integer) real-part prev-float align bits>float float? shift float 1+ 1- fp-nan? abs bitxor ratio? even? <= /mod odd? >integer ratio rational? bitnot real? >fixnum complex? /i numerator /f +syn keyword factorKeyword byte-array>bignum sgn >bignum next-float number= each-integer next-power-of-2 ?1+ fp-special? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum fp-snan? fp-infinity? denominator (all-integers?) times find-last-integer (each-integer) bit? * + fp-bitwise= - fp-qnan? / power-of-2? >= bitand find-integer complex < log2 > integer? real number bits>double double>bits bitor 2/ zero? rem fp-nan-payload all-integers? (find-integer) real-part prev-float align bits>float float? shift float fp-nan? abs bitxor ratio? even? <= /mod odd? >integer ratio rational? bitnot real? >fixnum complex? /i numerator /f syn keyword factorKeyword append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as filter-here last-index-from reversed index-from cut* pad-tail (indices) concat-as remq but-last snip trim-tail nths nth 2pusher sequence slice? partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length delq drop-prefix unclip iota unclip-last-slice bounds-error? sequence-hashcode-step map start midpoint@ rest-slice prepend fourth sift delete sigma new-sequence follow like delete-nth first4 1sequence reverse slice unless-empty padding virtual@ repetition? set-last index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? 2sequence map-integers delete-all start* indices snip-slice check-slice sequence? head map-find reduce append-as reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check harvest immutable find produce remove pad-head last replicate set-fourth shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulate each pusher cut-slice new-resizable each-index head-slice* 2reverse-each sequence-hashcode memq? pop set-nth ?nth second change-each join when-empty accumulator immutable-sequence? all? 3append-as virtual-sequence subseq? push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum glue slice-error subseq replace-slice push repetition map-index trim-head unclip-last mismatch trim syn keyword factorKeyword global +@ change set-namestack change-global init-namespaces on off set-global namespace set with-scope bind with-variable inc dec counter initialize namestack get get-global make-assoc syn keyword factorKeyword 2array 3array pair >array 1array 4array pair? array resize-array array?