diff --git a/Makefile b/Makefile index 9be68fea81..a346bdfa0a 100644 --- a/Makefile +++ b/Makefile @@ -15,9 +15,11 @@ FFI_TEST_CFLAGS = -fPIC ifdef DEBUG CFLAGS += -g else - CFLAGS += -O3 $(SITE_CFLAGS) + CFLAGS += -O3 endif +CFLAGS += $(SITE_CFLAGS) + ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION) ifdef CONFIG diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor index 256b4e1b42..8d1071122d 100644 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -1,5 +1,5 @@ USING: arrays calendar kernel math sequences tools.test -continuations system math.order threads ; +continuations system math.order threads accessors ; IN: calendar.tests [ f ] [ 2004 12 32 0 0 0 instant valid-timestamp? ] unit-test @@ -163,3 +163,10 @@ IN: calendar.tests [ t ] [ now 50 milliseconds sleep now before? ] unit-test [ t ] [ now 50 milliseconds sleep now swap after? ] unit-test [ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test + +[ 4 12 ] [ 2009 easter [ month>> ] [ day>> ] bi ] unit-test +[ 4 2 ] [ 1961 easter [ month>> ] [ day>> ] bi ] unit-test + +[ f ] [ now dup midnight eq? ] unit-test +[ f ] [ now dup easter eq? ] unit-test +[ f ] [ now dup beginning-of-year eq? ] unit-test diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 7a03fe4408..4b58b1b496 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays classes.tuple combinators combinators.short-circuit - kernel locals math math.functions math.order namespaces sequences strings - summary system threads vocabs.loader ; +USING: accessors arrays classes.tuple combinators +combinators.short-circuit kernel locals math math.functions +math.order sequences summary system threads vocabs.loader ; IN: calendar HOOK: gmt-offset os ( -- hours minutes seconds ) @@ -94,26 +94,50 @@ CONSTANT: day-abbreviations3 :: julian-day-number ( year month day -- n ) #! Returns a composite date number #! Not valid before year -4800 - [let* | a [ 14 month - 12 /i ] - y [ year 4800 + a - ] - m [ month 12 a * + 3 - ] | - day 153 m * 2 + 5 /i + 365 y * + - y 4 /i + y 100 /i - y 400 /i + 32045 - - ] ; + 14 month - 12 /i :> a + year 4800 + a - :> y + month 12 a * + 3 - :> m + + day 153 m * 2 + 5 /i + 365 y * + + y 4 /i + y 100 /i - y 400 /i + 32045 - ; :: julian-day-number>date ( n -- year month day ) #! Inverse of julian-day-number - [let* | a [ n 32044 + ] - b [ 4 a * 3 + 146097 /i ] - c [ a 146097 b * 4 /i - ] - d [ 4 c * 3 + 1461 /i ] - e [ c 1461 d * 4 /i - ] - m [ 5 e * 2 + 153 /i ] | - 100 b * d + 4800 - - m 10 /i + m 3 + - 12 m 10 /i * - - e 153 m * 2 + 5 /i - 1+ - ] ; + n 32044 + :> a + 4 a * 3 + 146097 /i :> b + a 146097 b * 4 /i - :> c + 4 c * 3 + 1461 /i :> d + c 1461 d * 4 /i - :> e + 5 e * 2 + 153 /i :> m + + 100 b * d + 4800 - + m 10 /i + m 3 + + 12 m 10 /i * - + e 153 m * 2 + 5 /i - 1+ ; + +GENERIC: easter ( obj -- obj' ) + +:: easter-month-day ( year -- month day ) + year 19 mod :> a + year 100 /mod :> c :> b + b 4 /mod :> e :> d + b 8 + 25 /i :> f + b f - 1 + 3 /i :> g + 19 a * b + d - g - 15 + 30 mod :> h + c 4 /mod :> k :> i + 32 2 e * + 2 i * + h - k - 7 mod :> l + a 11 h * + 22 l * + 451 /i :> m + + h l + 7 m * - 114 + 31 /mod 1 + :> day :> month + month day ; + +M: integer easter ( year -- timestamp ) + dup easter-month-day ; + +M: timestamp easter ( timestamp -- timestamp ) + clone + dup year>> easter-month-day + swapd >>day swap >>month ; : >date< ( timestamp -- year month day ) [ year>> ] [ month>> ] [ day>> ] tri ; diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index 04c6c2497e..29620b089d 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -14,7 +14,7 @@ IN: checksums.md5 SYMBOLS: a b c d old-a old-b old-c old-d ; : T ( N -- Y ) - sin abs 4294967296 * >integer ; foldable + sin abs 32 2^ * >integer ; foldable : initialize-md5 ( -- ) 0 bytes-read set diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index aa7960539c..9519847810 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -18,6 +18,10 @@ MACRO: input> ] keep '[ _ firstn @ ] ; +MACRO: input> ] keep + '[ _ firstn-unsafe @ ] ; + MACRO: reduce-outputs ( quot operation -- newquot ) [ dup infer out>> 1 [-] ] dip n*quot compose ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 4d7882ad08..42ed90d64a 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -5,7 +5,7 @@ continuations effects namespaces.private io io.streams.string memory system threads tools.test math accessors combinators specialized-arrays.float alien.libraries io.pathnames io.backend ; -IN: compiler.tests +IN: compiler.tests.alien << : libfactor-ffi-tests-path ( -- string ) diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 2e02e5476c..c746fdfb45 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -4,7 +4,7 @@ sequences sequences.private tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io combinators vectors grouping make ; -IN: compiler.tests +IN: compiler.tests.codegen ! Originally, this file did black box testing of templating ! optimization. We now have a different codegen, but the tests @@ -281,4 +281,4 @@ TUPLE: cucumber ; M: cucumber equal? "The cucumber has no equal" throw ; -[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test \ No newline at end of file +[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test diff --git a/basis/compiler/tests/curry.factor b/basis/compiler/tests/curry.factor index 2d1f15b9a8..32611ba87a 100644 --- a/basis/compiler/tests/curry.factor +++ b/basis/compiler/tests/curry.factor @@ -1,6 +1,6 @@ USING: tools.test quotations math kernel sequences assocs namespaces make compiler.units compiler ; -IN: compiler.tests +IN: compiler.tests.curry [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test [ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index b439b5f6a4..1a604dbd8e 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.float USING: compiler.units compiler kernel kernel.private memory math math.private tools.test math.floats.private ; diff --git a/basis/compiler/tests/folding.factor b/basis/compiler/tests/folding.factor index fe2f801de2..5050ce1950 100644 --- a/basis/compiler/tests/folding.factor +++ b/basis/compiler/tests/folding.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel classes.mixin arrays ; -IN: compiler.tests +IN: compiler.tests.folding ! Calls to generic words were not folded away. diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 93860db924..a6e827ea33 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -6,7 +6,7 @@ sbufs strings.private slots.private alien math.order alien.accessors alien.c-types alien.syntax alien.strings namespaces libc sequences.private io.encodings.ascii classes compiler ; -IN: compiler.tests +IN: compiler.tests.intrinsics ! Make sure that intrinsic ops compile to correct code. [ ] [ 1 [ drop ] compile-call ] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 99bdb18812..bd7008f909 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -5,7 +5,7 @@ quotations classes classes.algebra classes.tuple.private continuations growable namespaces hints alien.accessors compiler.tree.builder compiler.tree.optimizer sequences.deep compiler ; -IN: optimizer.tests +IN: compiler.tests.optimizer GENERIC: xyz ( obj -- obj ) M: array xyz xyz ; diff --git a/basis/compiler/tests/peg-regression-2.factor b/basis/compiler/tests/peg-regression-2.factor index 1efadba3aa..7929d9e6f6 100644 --- a/basis/compiler/tests/peg-regression-2.factor +++ b/basis/compiler/tests/peg-regression-2.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.peg-regression-2 USING: peg.ebnf strings tools.test ; GENERIC: ( times -- term' ) @@ -12,4 +12,4 @@ Regexp = Times:t => [[ t ]] ;EBNF -[ "foo" ] [ "a" parse-regexp ] unit-test \ No newline at end of file +[ "foo" ] [ "a" parse-regexp ] unit-test diff --git a/basis/compiler/tests/peg-regression.factor b/basis/compiler/tests/peg-regression.factor index 56a4021eed..e107135305 100644 --- a/basis/compiler/tests/peg-regression.factor +++ b/basis/compiler/tests/peg-regression.factor @@ -5,7 +5,7 @@ ! end of a compilation unit. USING: kernel accessors peg.ebnf ; -IN: compiler.tests +IN: compiler.tests.peg-regression TUPLE: pipeline-expr background ; diff --git a/basis/compiler/tests/redefine0.factor b/basis/compiler/tests/redefine0.factor index 87b63aa029..3d7a05a74b 100644 --- a/basis/compiler/tests/redefine0.factor +++ b/basis/compiler/tests/redefine0.factor @@ -104,4 +104,4 @@ quot global delete-at \ test-11 forget \ quot forget ] with-compilation-unit -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor index a28b183fb6..6bb623cac4 100644 --- a/basis/compiler/tests/redefine1.factor +++ b/basis/compiler/tests/redefine1.factor @@ -1,7 +1,7 @@ USING: accessors compiler compiler.units tools.test math parser kernel sequences sequences.private classes.mixin generic definitions arrays words assocs eval strings ; -IN: compiler.tests +IN: compiler.tests.redefine1 GENERIC: method-redefine-generic-1 ( a -- b ) @@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ; [ 6 ] [ method-redefine-test-1 ] unit-test -[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine1 USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test [ 7 ] [ method-redefine-test-1 ] unit-test @@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ; [ 6 ] [ method-redefine-test-2 ] unit-test -[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine1 USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test [ 7 ] [ method-redefine-test-2 ] unit-test diff --git a/basis/compiler/tests/redefine10.factor b/basis/compiler/tests/redefine10.factor index faae7b8ed1..66edd75097 100644 --- a/basis/compiler/tests/redefine10.factor +++ b/basis/compiler/tests/redefine10.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine10 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/redefine11.factor b/basis/compiler/tests/redefine11.factor index 57f9f9caf0..dbec57e3d5 100644 --- a/basis/compiler/tests/redefine11.factor +++ b/basis/compiler/tests/redefine11.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel classes.mixin arrays ; -IN: compiler.tests +IN: compiler.tests.redefine11 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/redefine15.factor b/basis/compiler/tests/redefine15.factor index 797460a411..33aa080bac 100644 --- a/basis/compiler/tests/redefine15.factor +++ b/basis/compiler/tests/redefine15.factor @@ -17,4 +17,4 @@ DEFER: word-1 [ \ word-3 [ [ 2 + ] bi@ ] (( a b -- c d )) define-declared ] with-compilation-unit -[ 2 3 ] [ 0 word-4 ] unit-test \ No newline at end of file +[ 2 3 ] [ 0 word-4 ] unit-test diff --git a/basis/compiler/tests/redefine2.factor b/basis/compiler/tests/redefine2.factor index 6a7b7a6941..9112a1e1af 100644 --- a/basis/compiler/tests/redefine2.factor +++ b/basis/compiler/tests/redefine2.factor @@ -1,11 +1,11 @@ -IN: compiler.tests +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 ; DEFER: redefine2-test -[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test +[ ] [ "USE: sequences USE: kernel IN: compiler.tests.redefine2 TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test [ t ] [ \ redefine2-test symbol? ] unit-test diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index 87ab100879..51ce33c1bd 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +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 ; @@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ; [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test -[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test [ "wake up" ] [ sheeple-test ] unit-test [ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test diff --git a/basis/compiler/tests/redefine4.factor b/basis/compiler/tests/redefine4.factor index 88b40f0c5a..2320f64af6 100644 --- a/basis/compiler/tests/redefine4.factor +++ b/basis/compiler/tests/redefine4.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.redefine4 USING: io.streams.string kernel tools.test eval ; : declaration-test-1 ( -- a ) 3 ; flushable @@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ; [ "" ] [ [ declaration-test ] with-string-writer ] unit-test -[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine4 USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test [ "X" ] [ [ declaration-test ] with-string-writer ] unit-test diff --git a/basis/compiler/tests/redefine5.factor b/basis/compiler/tests/redefine5.factor index c390f9a1ec..7613987852 100644 --- a/basis/compiler/tests/redefine5.factor +++ b/basis/compiler/tests/redefine5.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine5 ! Regression: if dispatch was eliminated but method was not inlined, ! compiled usage information was not recorded. diff --git a/basis/compiler/tests/redefine6.factor b/basis/compiler/tests/redefine6.factor index 7f1be973e7..fdf3e7edbb 100644 --- a/basis/compiler/tests/redefine6.factor +++ b/basis/compiler/tests/redefine6.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine6 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/redefine7.factor b/basis/compiler/tests/redefine7.factor index d6dfdf20fd..cfe29603f9 100644 --- a/basis/compiler/tests/redefine7.factor +++ b/basis/compiler/tests/redefine7.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine7 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/redefine8.factor b/basis/compiler/tests/redefine8.factor index 3499c5070a..a79bfb5af5 100644 --- a/basis/compiler/tests/redefine8.factor +++ b/basis/compiler/tests/redefine8.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine8 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/redefine9.factor b/basis/compiler/tests/redefine9.factor index 25ed5f15db..2598246472 100644 --- a/basis/compiler/tests/redefine9.factor +++ b/basis/compiler/tests/redefine9.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel generic.math ; -IN: compiler.tests +IN: compiler.tests.redefine9 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/reload.factor b/basis/compiler/tests/reload.factor index b2b65b5868..62c7c31bc2 100644 --- a/basis/compiler/tests/reload.factor +++ b/basis/compiler/tests/reload.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.reload USE: vocabs.loader ! "parser" reload diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index 11b27979d5..82cc97e0f6 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -1,7 +1,7 @@ USING: compiler compiler.units tools.test kernel kernel.private sequences.private math.private math combinators strings alien arrays memory vocabs parser eval ; -IN: compiler.tests +IN: compiler.tests.simple ! Test empty word [ ] [ [ ] compile-call ] unit-test diff --git a/basis/compiler/tests/spilling.factor b/basis/compiler/tests/spilling.factor index 4092352fd5..2ec6fbde95 100644 --- a/basis/compiler/tests/spilling.factor +++ b/basis/compiler/tests/spilling.factor @@ -1,6 +1,6 @@ USING: math.private kernel combinators accessors arrays generalizations tools.test ; -IN: compiler.tests +IN: compiler.tests.spilling : float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b ) { diff --git a/basis/compiler/tests/stack-trace.factor b/basis/compiler/tests/stack-trace.factor index b317ed3eb5..1cb11571ef 100755 --- a/basis/compiler/tests/stack-trace.factor +++ b/basis/compiler/tests/stack-trace.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.stack-trace USING: compiler tools.test namespaces sequences kernel.private kernel math continuations continuations.private words splitting grouping sorting accessors ; diff --git a/basis/compiler/tests/tuples.factor b/basis/compiler/tests/tuples.factor index caa214b70c..fc249d99db 100644 --- a/basis/compiler/tests/tuples.factor +++ b/basis/compiler/tests/tuples.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.tuples USING: kernel tools.test compiler.units compiler ; TUPLE: color red green blue ; diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 7f760650e7..37cc1f05da 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -54,15 +54,16 @@ PRIVATE> #! This slows down compiler.tree.propagation.inlining since then every #! inlined usage of a method has an inline-dependency on the mixin, and #! not the more specific type at the call site. - specialize-method? off - [ - #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d - { - { [ dup not ] [ ] } - { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] } - [ in-d #call out-d>> #copy suffix ] - } cond - ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ; + f specialize-method? [ + [ + #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d + { + { [ dup not ] [ ] } + { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] } + [ in-d #call out-d>> #copy suffix ] + } cond + ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover + ] with-variable ; : contains-breakpoints? ( word -- ? ) def>> [ word? ] filter [ "break?" word-prop ] any? ; diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index 37ec1d3e15..b500d9f5ca 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -63,6 +63,24 @@ WHERE [ 4 ] [ 1 3 blah ] unit-test +<< + +FUNCTOR: symbol-test ( W -- ) + +W DEFINES ${W} + +WHERE + +SYMBOL: W + +;FUNCTOR + +"blorgh" symbol-test + +>> + +[ blorgh ] [ blorgh ] unit-test + GENERIC: some-generic ( a -- b ) ! Does replacing an ordinary word with a functor-generated one work? @@ -72,6 +90,7 @@ GENERIC: some-generic ( a -- b ) TUPLE: some-tuple ; : some-word ( -- ) ; M: some-tuple some-generic ; + SYMBOL: some-symbol "> "functors-test" parse-stream ] unit-test @@ -82,6 +101,7 @@ GENERIC: some-generic ( a -- b ) "some-tuple" "functors.tests" lookup "some-generic" "functors.tests" lookup method >boolean ] unit-test ; + [ t ] [ "some-symbol" "functors.tests" lookup >boolean ] unit-test test-redefinition @@ -90,12 +110,14 @@ FUNCTOR: redefine-test ( W -- ) W-word DEFINES ${W}-word W-tuple DEFINES-CLASS ${W}-tuple W-generic IS ${W}-generic +W-symbol DEFINES ${W}-symbol WHERE TUPLE: W-tuple ; : W-word ( -- ) ; M: W-tuple W-generic ; +SYMBOL: W-symbol ;FUNCTOR @@ -105,4 +127,5 @@ M: W-tuple W-generic ; "> "functors-test" parse-stream ] unit-test -test-redefinition \ No newline at end of file +test-redefinition + diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 309154fb49..ce069ac953 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -5,7 +5,7 @@ words interpolate namespaces sequences io.streams.string fry classes.mixin effects lexer parser classes.tuple.parser effects.parser locals.types locals.parser generic.parser locals.rewrite.closures vocabs.parser classes.parser -arrays accessors ; +arrays accessors words.symbol ; IN: functors ! This is a hack @@ -18,6 +18,8 @@ IN: functors : define-declared* ( word def effect -- ) pick set-word define-declared ; +TUPLE: fake-call-next-method ; + TUPLE: fake-quotation seq ; GENERIC: >fake-quotations ( quot -- fake ) @@ -29,17 +31,25 @@ M: array >fake-quotations [ >fake-quotations ] { } map-as ; M: object >fake-quotations ; -GENERIC: fake-quotations> ( fake -- quot ) +GENERIC: (fake-quotations>) ( fake -- ) -M: fake-quotation fake-quotations> - seq>> [ fake-quotations> ] [ ] map-as ; +: fake-quotations> ( fake -- quot ) + [ (fake-quotations>) ] [ ] make ; -M: array fake-quotations> [ fake-quotations> ] map ; +M: fake-quotation (fake-quotations>) + [ seq>> [ (fake-quotations>) ] each ] [ ] make , ; -M: object fake-quotations> ; +M: array (fake-quotations>) + [ [ (fake-quotations>) ] each ] { } make , ; + +M: fake-call-next-method (fake-quotations>) + drop method-body get literalize , \ (call-next-method) , ; + +M: object (fake-quotations>) , ; : parse-definition* ( accum -- accum ) - parse-definition >fake-quotations parsed \ fake-quotations> parsed ; + parse-definition >fake-quotations parsed + [ fake-quotations> first ] over push-all ; : parse-declared* ( accum -- accum ) complete-effect @@ -64,7 +74,7 @@ SYNTAX: `TUPLE: SYNTAX: `M: scan-param parsed scan-param parsed - \ create-method-in parsed + [ create-method-in dup method-body set ] over push-all parse-definition* \ define* parsed ; @@ -80,6 +90,10 @@ SYNTAX: `: parse-declared* \ define-declared* parsed ; +SYNTAX: `SYMBOL: + scan-param parsed + \ define-symbol parsed ; + SYNTAX: `SYNTAX: scan-param parsed parse-definition* @@ -92,6 +106,8 @@ SYNTAX: `INSTANCE: SYNTAX: `inline [ word make-inline ] over push-all ; +SYNTAX: `call-next-method T{ fake-call-next-method } parsed ; + : (INTERPOLATE) ( accum quot -- accum ) [ scan interpolate-locals ] dip '[ _ with-string-writer @ ] parsed ; @@ -116,7 +132,9 @@ DEFER: ;FUNCTOR delimiter { ":" POSTPONE: `: } { "INSTANCE:" POSTPONE: `INSTANCE: } { "SYNTAX:" POSTPONE: `SYNTAX: } + { "SYMBOL:" POSTPONE: `SYMBOL: } { "inline" POSTPONE: `inline } + { "call-next-method" POSTPONE: `call-next-method } } ; : push-functor-words ( -- ) diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index edee44acc6..139b7a528a 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -26,11 +26,14 @@ MACRO: narray ( n -- ) MACRO: nsum ( n -- ) 1- [ + ] n*quot ; +MACRO: firstn-unsafe ( n -- ) + [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ; + MACRO: firstn ( n -- ) dup zero? [ drop [ drop ] ] [ - [ [ '[ [ _ ] dip nth-unsafe ] ] map ] - [ 1- '[ [ _ ] dip bounds-check 2drop ] ] - bi prefix '[ _ cleave ] + [ 1- swap bounds-check 2drop ] + [ firstn-unsafe ] + bi-curry '[ _ _ bi ] ] if ; MACRO: npick ( n -- ) diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index a988063293..0b86b02e92 100755 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -12,7 +12,7 @@ IN: inverse ERROR: fail ; M: fail summary drop "Matching failed" ; -: assure ( ? -- ) [ fail ] unless ; +: assure ( ? -- ) [ fail ] unless ; inline : =/fail ( obj1 obj2 -- ) = assure ; diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 2202f7aa08..f7d18306f8 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -39,55 +39,55 @@ TUPLE: directory-iterator path bfs queue ; dup directory? [ name>> over push-directory-entries next-directory-entry ] [ nip ] if - ] if ; recursive + ] if ; -:: iterate-directory-entries ( iter quot -- directory-entry/f ) +:: iterate-directory-entries ( iter quot: ( obj -- obj ) -- directory-entry/f ) iter next-directory-entry [ - quot call( obj -- obj ) + quot call [ iter quot iterate-directory-entries ] unless* ] [ f ] if* ; inline recursive : iterate-directory ( iter quot -- path/f ) - [ name>> ] prepose iterate-directory-entries ; + [ name>> ] prepose iterate-directory-entries ; inline : setup-traversal ( path bfs quot -- iterator quot' ) - [ ] dip [ f ] compose ; + [ ] dip [ f ] compose ; inline PRIVATE> : each-file ( path bfs? quot -- ) - setup-traversal iterate-directory drop ; + setup-traversal iterate-directory drop ; inline : each-directory-entry ( path bfs? quot -- ) - setup-traversal iterate-directory-entries drop ; + setup-traversal iterate-directory-entries drop ; inline : recursive-directory-files ( path bfs? -- paths ) - [ ] accumulator [ each-file ] dip ; + [ ] accumulator [ each-file ] dip ; inline -: recursive-directory-entries ( path bfs? -- paths ) - [ ] accumulator [ each-directory-entry ] dip ; +: recursive-directory-entries ( path bfs? -- directory-entries ) + [ ] accumulator [ each-directory-entry ] dip ; inline : find-file ( path bfs? quot -- path/f ) [ ] dip - [ keep and ] curry iterate-directory ; + [ keep and ] curry iterate-directory ; inline : find-all-files ( path quot -- paths/f ) [ f ] dip pusher - [ [ f ] compose iterate-directory drop ] dip ; + [ [ f ] compose iterate-directory drop ] dip ; inline ERROR: file-not-found path bfs? quot ; : find-file-throws ( path bfs? quot -- path ) - 3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; + 3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; inline : find-in-directories ( directories bfs? quot -- path'/f ) '[ _ [ _ _ find-file-throws ] attempt-all ] - [ drop f ] recover ; + [ drop f ] recover ; inline : find-all-in-directories ( directories quot -- paths/f ) - '[ _ find-all-files ] map concat ; + '[ _ find-all-files ] map concat ; inline : link-size/0 ( path -- n ) [ link-info size-on-disk>> ] [ 2drop 0 ] recover ; diff --git a/basis/io/mmap/functor/functor.factor b/basis/io/mmap/functor/functor.factor index 21b3d294c9..a80ce3bc82 100644 --- a/basis/io/mmap/functor/functor.factor +++ b/basis/io/mmap/functor/functor.factor @@ -9,13 +9,14 @@ SLOT: length : mapped-file>direct ( mapped-file type -- alien length ) [ [ address>> ] [ length>> ] bi ] dip - heap-size [ 1- + ] keep /i ; + heap-size [ 1 - + ] keep /i ; FUNCTOR: define-mapped-array ( T -- ) - DEFINES - IS -with-mapped-A-file DEFINES with-mapped-${T}-file + DEFINES + IS +with-mapped-A-file DEFINES with-mapped-${T}-file +with-mapped-A-file-reader DEFINES with-mapped-${T}-file-reader WHERE @@ -25,4 +26,7 @@ WHERE : with-mapped-A-file ( path quot -- ) '[ @ ] with-mapped-file ; inline +: with-mapped-A-file-reader ( path quot -- ) + '[ @ ] with-mapped-file-reader ; inline + ;FUNCTOR diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index f0adb47321..1da82e42e2 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -18,7 +18,13 @@ HELP: HELP: with-mapped-file { $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } } -{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } +{ $contract "Opens a file for read/write access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } +{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." } +{ $errors "Throws an error if a memory mapping could not be established." } ; + +HELP: with-mapped-file-reader +{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } } +{ $contract "Opens a file for read-only access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } { $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." } { $errors "Throws an error if a memory mapping could not be established." } ; diff --git a/basis/io/mmap/mmap-tests.factor b/basis/io/mmap/mmap-tests.factor index a4d55f3c1e..0e1cd1a036 100644 --- a/basis/io/mmap/mmap-tests.factor +++ b/basis/io/mmap/mmap-tests.factor @@ -7,6 +7,7 @@ IN: io.mmap.tests [ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test [ ] [ "mmap-test-file.txt" temp-file [ CHAR: 2 0 pick set-nth drop ] with-mapped-char-file ] unit-test [ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test +[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file-reader ] unit-test [ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor index 1a58471514..e03d5fb30b 100644 --- a/basis/io/mmap/mmap.factor +++ b/basis/io/mmap/mmap.factor @@ -8,14 +8,27 @@ IN: io.mmap TUPLE: mapped-file address handle length disposed ; -HOOK: (mapped-file) os ( path length -- address handle ) +HOOK: (mapped-file-reader) os ( path length -- address handle ) +HOOK: (mapped-file-r/w) os ( path length -- address handle ) ERROR: bad-mmap-size path size ; -: ( path -- mmap ) +> ] bi - dup 0 <= [ bad-mmap-size ] when - [ (mapped-file) ] keep + dup 0 <= [ bad-mmap-size ] when ; + +PRIVATE> + +: ( path -- mmap ) + prepare-mapped-file + [ (mapped-file-reader) ] keep + f mapped-file boa ; + +: ( path -- mmap ) + prepare-mapped-file + [ (mapped-file-r/w) ] keep f mapped-file boa ; HOOK: close-mapped-file io-backend ( mmap -- ) @@ -25,6 +38,9 @@ M: mapped-file dispose* ( mmap -- ) close-mapped-file ; : with-mapped-file ( path quot -- ) [ ] dip with-disposal ; inline +: with-mapped-file-reader ( path quot -- ) + [ ] dip with-disposal ; inline + { { [ os unix? ] [ "io.mmap.unix" require ] } { [ os winnt? ] [ "io.mmap.windows" require ] } diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor index 0fa8e1151f..7d12d52361 100644 --- a/basis/io/mmap/unix/unix.factor +++ b/basis/io/mmap/unix/unix.factor @@ -4,21 +4,23 @@ USING: alien io io.files kernel math math.bitwise system unix io.backend.unix io.ports io.mmap destructors locals accessors ; IN: io.mmap.unix -: open-r/w ( path -- fd ) O_RDWR file-mode open-file ; - -:: mmap-open ( path length prot flags -- alien fd ) +:: mmap-open ( path length prot flags open-mode -- alien fd ) [ f length prot flags - path open-r/w [ |dispose drop ] keep + path open-mode file-mode open-file [ |dispose drop ] keep [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep ] with-destructors ; -M: unix (mapped-file) +M: unix (mapped-file-r/w) { PROT_READ PROT_WRITE } flags { MAP_FILE MAP_SHARED } flags - mmap-open ; + O_RDWR mmap-open ; + +M: unix (mapped-file-reader) + { PROT_READ } flags + { MAP_FILE MAP_SHARED } flags + O_RDONLY mmap-open ; M: unix close-mapped-file ( mmap -- ) [ [ address>> ] [ length>> ] bi munmap io-error ] - [ handle>> close-file ] - bi ; + [ handle>> close-file ] bi ; diff --git a/basis/io/mmap/windows/windows.factor b/basis/io/mmap/windows/windows.factor index fcdf416511..ebd8109d14 100644 --- a/basis/io/mmap/windows/windows.factor +++ b/basis/io/mmap/windows/windows.factor @@ -28,7 +28,7 @@ M: win32-mapped-file dispose C: win32-mapped-file -M: windows (mapped-file) +M: windows (mapped-file-r/w) [ { GENERIC_WRITE GENERIC_READ } flags OPEN_ALWAYS @@ -37,6 +37,15 @@ M: windows (mapped-file) -rot ] with-destructors ; +M: windows (mapped-file-reader) + [ + GENERIC_READ + OPEN_ALWAYS + { PAGE_READONLY SEC_COMMIT } flags + FILE_MAP_READ mmap-open + -rot + ] with-destructors ; + M: windows close-mapped-file ( mapped-file -- ) [ [ handle>> &dispose drop ] diff --git a/basis/math/blas/config/config.factor b/basis/math/blas/config/config.factor index 327c546963..09f736c036 100644 --- a/basis/math/blas/config/config.factor +++ b/basis/math/blas/config/config.factor @@ -18,7 +18,7 @@ blas-fortran-abi [ { [ os netbsd? cpu x86.64? and ] [ g95-abi ] } { [ os windows? cpu x86.64? and ] [ gfortran-abi ] } { [ os freebsd? ] [ gfortran-abi ] } - { [ os linux? cpu x86.32? and ] [ gfortran-abi ] } + { [ os linux? ] [ gfortran-abi ] } [ f2c-abi ] } cond ] initialize diff --git a/basis/math/quaternions/quaternions-docs.factor b/basis/math/quaternions/quaternions-docs.factor index bb34ec8da2..a24011cb7c 100644 --- a/basis/math/quaternions/quaternions-docs.factor +++ b/basis/math/quaternions/quaternions-docs.factor @@ -1,6 +1,16 @@ USING: help.markup help.syntax math math.vectors vectors ; IN: math.quaternions +HELP: q+ +{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u+v" "a quaternion" } } +{ $description "Add quaternions." } +{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q+ ." "{ C{ 0 1 } 1 }" } } ; + +HELP: q- +{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u-v" "a quaternion" } } +{ $description "Subtract quaternions." } +{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q- ." "{ C{ 0 1 } -1 }" } } ; + HELP: q* { $values { "u" "a quaternion" } { "v" "a quaternion" } { "u*v" "a quaternion" } } { $description "Multiply quaternions." } diff --git a/basis/math/quaternions/quaternions-tests.factor b/basis/math/quaternions/quaternions-tests.factor index a6d255e421..3efc417e42 100644 --- a/basis/math/quaternions/quaternions-tests.factor +++ b/basis/math/quaternions/quaternions-tests.factor @@ -24,3 +24,7 @@ math.constants ; [ t ] [ qk q>v v>q qk = ] unit-test [ t ] [ 1 c>q q1 = ] unit-test [ t ] [ C{ 0 1 } c>q qi = ] unit-test +[ t ] [ qi qi q+ qi 2 q*n = ] unit-test +[ t ] [ qi qi q- q0 = ] unit-test +[ t ] [ qi qj q+ qj qi q+ = ] unit-test +[ t ] [ qi qj q- qj qi q- -1 q*n = ] unit-test diff --git a/basis/math/quaternions/quaternions.factor b/basis/math/quaternions/quaternions.factor index f2c2c6d226..b713f44ebd 100755 --- a/basis/math/quaternions/quaternions.factor +++ b/basis/math/quaternions/quaternions.factor @@ -20,6 +20,12 @@ IN: math.quaternions PRIVATE> +: q+ ( u v -- u+v ) + v+ ; + +: q- ( u v -- u-v ) + v- ; + : q* ( u v -- u*v ) [ q*a ] [ q*b ] 2bi 2array ; diff --git a/basis/tuple-arrays/authors.txt b/basis/tuple-arrays/authors.txt index f990dd0ed2..d4f5d6b3ae 100644 --- a/basis/tuple-arrays/authors.txt +++ b/basis/tuple-arrays/authors.txt @@ -1 +1 @@ -Daniel Ehrenberg +Slava Pestov \ No newline at end of file diff --git a/basis/tuple-arrays/summary.txt b/basis/tuple-arrays/summary.txt deleted file mode 100644 index ac05ae9bcc..0000000000 --- a/basis/tuple-arrays/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Packed homogeneous tuple arrays diff --git a/basis/tuple-arrays/tags.txt b/basis/tuple-arrays/tags.txt deleted file mode 100644 index 42d711b32b..0000000000 --- a/basis/tuple-arrays/tags.txt +++ /dev/null @@ -1 +0,0 @@ -collections diff --git a/basis/tuple-arrays/tuple-arrays-docs.factor b/basis/tuple-arrays/tuple-arrays-docs.factor deleted file mode 100644 index 18f5547e7f..0000000000 --- a/basis/tuple-arrays/tuple-arrays-docs.factor +++ /dev/null @@ -1,13 +0,0 @@ -USING: help.syntax help.markup splitting kernel sequences ; -IN: tuple-arrays - -HELP: tuple-array -{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. To convert a sequence to a tuple array, use the word " { $link >tuple-array } "." } ; - -HELP: -{ $values { "class" "a tuple class" } { "length" "a non-negative integer" } { "tuple-array" tuple-array } } -{ $description "Creates an instance of the " { $link } " class with the given length and containing the given tuple class." } ; - -HELP: >tuple-array -{ $values { "seq" sequence } { "tuple-array" tuple-array } } -{ $description "Converts a sequence into a homogeneous unboxed tuple array of the type indicated by the first element." } ; diff --git a/basis/tuple-arrays/tuple-arrays-tests.factor b/basis/tuple-arrays/tuple-arrays-tests.factor index 7aa49b880f..2eeae20aa1 100644 --- a/basis/tuple-arrays/tuple-arrays-tests.factor +++ b/basis/tuple-arrays/tuple-arrays-tests.factor @@ -5,17 +5,28 @@ IN: tuple-arrays.tests SYMBOL: mat TUPLE: foo bar ; C: foo -[ 2 ] [ 2 foo dup mat set length ] unit-test +TUPLE-ARRAY: foo + +[ 2 ] [ 2 dup mat set length ] unit-test [ T{ foo } ] [ mat get first ] unit-test [ T{ foo f 2 } ] [ T{ foo f 2 } 0 mat get [ set-nth ] keep first ] unit-test -[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test +[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >foo-array dup mat set foo-array? ] unit-test [ T{ foo f 3 } t ] -[ mat get [ bar>> 2 + ] map [ first ] keep tuple-array? ] unit-test +[ mat get [ bar>> 2 + ] map [ first ] keep foo-array? ] unit-test -[ 2 ] [ 2 foo dup mat set length ] unit-test +[ 2 ] [ 2 dup mat set length ] unit-test [ T{ foo } ] [ mat get first ] unit-test [ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test TUPLE: baz { bing integer } bong ; -[ 0 ] [ 1 baz first bing>> ] unit-test -[ f ] [ 1 baz first bong>> ] unit-test +TUPLE-ARRAY: baz + +[ 0 ] [ 1 first bing>> ] unit-test +[ f ] [ 1 first bong>> ] unit-test + +TUPLE: broken x ; +: broken ( -- ) ; + +TUPLE-ARRAY: broken + +[ 100 ] [ 100 length ] unit-test \ No newline at end of file diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor index af62c0b0d7..35d771416c 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -1,34 +1,73 @@ -! Copyright (C) 2007 Daniel Ehrenberg. +! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: splitting grouping classes.tuple classes math kernel -sequences arrays accessors ; +USING: accessors arrays combinators.smart fry functors kernel +kernel.private macros sequences combinators sequences.private +stack-checker parser math classes.tuple.private ; +FROM: inverse => undo ; IN: tuple-arrays -TUPLE: tuple-array { seq read-only } { class read-only } ; + ( length class -- tuple-array ) - [ - new tuple>array 1 tail - [ concat ] [ length ] bi - ] [ ] bi tuple-array boa ; +MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ ] ; -M: tuple-array nth - [ seq>> nth ] [ class>> ] bi prefix >tuple ; +MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ; -M: tuple-array set-nth ( elt n seq -- ) - [ tuple>array 1 tail ] 2dip seq>> set-nth ; +: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline -M: tuple-array new-sequence - class>> ; +: smart-tuple>array ( tuple class -- array ) + '[ [ _ boa ] undo ] output>array ; inline -: >tuple-array ( seq -- tuple-array ) - dup empty? [ - 0 over first class clone-like - ] unless ; +: tuple-prototype ( class -- array ) + [ new ] [ smart-tuple>array ] bi ; inline -M: tuple-array like - drop dup tuple-array? [ >tuple-array ] unless ; +: tuple-slice ( n seq -- slice ) + [ n>> [ * dup ] keep + ] [ seq>> ] bi { array } declare slice boa ; inline -M: tuple-array length seq>> length ; +: read-tuple ( slice class -- tuple ) + '[ _ boa-unsafe ] input [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ] + bi '[ _ dip @ ] ; + +PRIVATE> + +FUNCTOR: define-tuple-array ( CLASS -- ) + +CLASS IS ${CLASS} + +CLASS-array DEFINES-CLASS ${CLASS}-array +CLASS-array? IS ${CLASS-array}? + + DEFINES <${CLASS}-array> +>CLASS-array DEFINES >${CLASS}-array + +WHERE + +TUPLE: CLASS-array +{ seq array read-only } +{ n array-capacity read-only } +{ length array-capacity read-only } ; + +: ( length -- tuple-array ) + [ \ CLASS [ tuple-prototype concat ] [ tuple-arity ] bi ] keep + \ CLASS-array boa ; inline + +M: CLASS-array length length>> ; + +M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; + +M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; + +M: CLASS-array new-sequence drop ; + +: >CLASS-array ( seq -- tuple-array ) 0 clone-like ; + +M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; + +INSTANCE: CLASS-array sequence + +;FUNCTOR + +SYNTAX: TUPLE-ARRAY: scan-word define-tuple-array ; diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 5e12322a48..85a6249dd3 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -89,11 +89,14 @@ ERROR: bad-literal-tuple ; swap [ [ slot-named offset>> 2 - ] curry dip ] curry assoc-map [ dup ] dip update boa>tuple ; -: parse-tuple-literal ( -- tuple ) - scan-word scan { +: parse-tuple-literal-slots ( class -- tuple ) + scan { { f [ unexpected-eof ] } { "f" [ \ } parse-until boa>tuple ] } { "{" [ parse-slot-values assoc>tuple ] } { "}" [ new ] } [ bad-literal-tuple ] } case ; + +: parse-tuple-literal ( -- tuple ) + scan-word parse-tuple-literal-slots ; diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index 2ae5ada8a1..f457b90c30 100755 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -46,8 +46,8 @@ CONSTANT: homo-sapiens } : make-cumulative ( freq -- chars floats ) - dup keys >byte-array - swap values >double-array unclip [ + ] accumulate swap suffix ; + [ keys >byte-array ] + [ values >double-array ] bi unclip [ + ] accumulate swap suffix ; :: select-random ( seed chars floats -- seed elt ) floats seed random -rot @@ -55,7 +55,7 @@ CONSTANT: homo-sapiens chars nth-unsafe ; inline : make-random-fasta ( seed len chars floats -- seed ) - [ rot drop select-random ] 2curry B{ } map-as print ; inline + [ rot drop select-random ] 2curry "" map-as print ; inline : write-description ( desc id -- ) ">" write write bl print ; inline @@ -71,7 +71,7 @@ CONSTANT: homo-sapiens :: make-repeat-fasta ( k len alu -- k' ) [let | kn [ alu length ] | - len [ k + kn mod alu nth-unsafe ] B{ } map-as print + len [ k + kn mod alu nth-unsafe ] "" map-as print k len + ] ; inline diff --git a/extra/benchmark/tuple-arrays/authors.txt b/extra/benchmark/tuple-arrays/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/benchmark/tuple-arrays/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/benchmark/tuple-arrays/tuple-arrays.factor b/extra/benchmark/tuple-arrays/tuple-arrays.factor new file mode 100644 index 0000000000..483311d4f4 --- /dev/null +++ b/extra/benchmark/tuple-arrays/tuple-arrays.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions tuple-arrays accessors fry sequences +prettyprint ; +IN: benchmark.tuple-arrays + +TUPLE: point { x float } { y float } { z float } ; + +TUPLE-ARRAY: point + +: tuple-array-benchmark ( -- ) + 100 [ + drop 5000 [ + [ 1+ ] change-x + [ 1- ] change-y + [ 1+ 2 / ] change-z + ] map [ z>> ] sigma + ] sigma . ; + +MAIN: tuple-array-benchmark \ No newline at end of file diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index a5671a5822..79df00ff5e 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -6,7 +6,7 @@ combinators math.ranges unicode.categories byte-arrays io.encodings.string io.encodings.utf16 assocs math.parser combinators.short-circuit fry namespaces combinators.smart splitting io.encodings.ascii arrays io.files.info unicode.case -io.directories.search literals math.functions ; +io.directories.search literals math.functions continuations ; IN: id3 id3) ( path -- id3v2/f ) +PRIVATE> + +: mp3>id3 ( path -- id3/f ) [ [ ] dip { @@ -213,12 +215,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] [ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ] [ dup id3v2? [ read-v2-tags ] [ drop ] if ] } cleave - ] with-mapped-uchar-file ; - -PRIVATE> - -: mp3>id3 ( path -- id3/f ) - dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; + ] with-mapped-uchar-file-reader ; : find-id3-frame ( id3 name -- obj/f ) swap frames>> at* [ data>> ] when ; @@ -239,8 +236,14 @@ PRIVATE> : find-mp3s ( path -- seq ) [ >lower ".mp3" tail? ] find-all-files ; +ERROR: id3-parse-error path error ; + +: (mp3-paths>id3s) ( seq -- seq' ) + [ dup [ mp3>id3 ] [ \ id3-parse-error boa ] recover ] { } map>assoc ; + : mp3-paths>id3s ( seq -- seq' ) - [ dup mp3>id3 ] { } map>assoc ; + (mp3-paths>id3s) + [ dup second id3-parse-error? [ f over set-second ] when ] map ; : parse-mp3-directory ( path -- seq ) find-mp3s mp3-paths>id3s ; diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index cf9e9c836a..2818c16f9f 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -2,33 +2,26 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors images images.loader io.pathnames kernel namespaces opengl opengl.gl opengl.textures sequences strings ui ui.gadgets -ui.gadgets.panes ui.render ; +ui.gadgets.panes ui.render ui.images ; IN: images.viewer -TUPLE: image-gadget < gadget { image image } ; +TUPLE: image-gadget < gadget image-name ; M: image-gadget pref-dim* - image>> dim>> ; - -: draw-image ( image -- ) - 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom - [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri - glDrawPixels ; + image-name>> image-dim ; M: image-gadget draw-gadget* ( gadget -- ) - image>> draw-image ; + image-name>> draw-image ; -: ( image -- gadget ) +: ( image-name -- gadget ) \ image-gadget new - swap >>image ; + swap >>image-name ; : image-window ( path -- gadget ) - [ load-image dup ] [ open-window ] bi ; + [ dup ] [ open-window ] bi ; GENERIC: image. ( object -- ) -M: string image. ( image -- ) load-image image. ; +M: string image. ( image -- ) gadget. ; -M: pathname image. ( image -- ) load-image image. ; - -M: image image. ( image -- ) gadget. ; +M: pathname image. ( image -- ) gadget. ; diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor index 6bf4ae090d..96e31c4a45 100644 --- a/extra/mason/notify/notify.factor +++ b/extra/mason/notify/notify.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays accessors io io.sockets io.encodings.utf8 io.files io.launcher kernel make mason.config mason.common mason.email -mason.twitter namespaces sequences ; +mason.twitter namespaces sequences prettyprint ; IN: mason.notify : status-notify ( input-file args -- ) @@ -38,7 +38,7 @@ IN: mason.notify f { "test" } status-notify ; : notify-report ( status -- ) - [ "Build finished with status: " write print flush ] + [ "Build finished with status: " write . flush ] [ [ "report" utf8 file-contents ] dip email-report "report" { "report" } status-notify diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index edc8416235..64d31b4368 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -28,7 +28,7 @@ IN: mason.report common-report _ call( -- xml ) [XML <-><-> XML] - pprint-xml + write-xml ] with-file-writer ; inline :: failed-report ( error file what -- status ) diff --git a/extra/morse/morse-tests.factor b/extra/morse/morse-tests.factor index fd52df1c4d..f1da7ce139 100644 --- a/extra/morse/morse-tests.factor +++ b/extra/morse/morse-tests.factor @@ -3,7 +3,7 @@ USING: arrays morse strings tools.test ; IN: morse.tests -[ CHAR: ? ] [ CHAR: \\ ch>morse ] unit-test +[ "?" ] [ CHAR: \\ ch>morse ] unit-test [ "..." ] [ CHAR: s ch>morse ] unit-test [ CHAR: s ] [ "..." morse>ch ] unit-test [ CHAR: \s ] [ "..--..--.." morse>ch ] unit-test @@ -41,3 +41,4 @@ IN: morse.tests MORSE] ] unit-test ! [ ] [ "sos" 0.075 play-as-morse* ] unit-test ! [ ] [ "Factor rocks!" play-as-morse ] unit-test +! [ ] [ "\n" play-as-morse ] unit-test diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index ef4b9d4b88..20989f2f2f 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -3,13 +3,15 @@ USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ; IN: morse +ERROR: no-morse-code ch ; + @@ -74,10 +76,10 @@ CONSTANT: morse-code-table $[ ] : ch>morse ( ch -- morse ) - ch>lower morse-code-table at [ unknown-char ] unless* ; + ch>lower morse-code-table at unknown-char or ; : morse>ch ( str -- ch ) - morse-code-table value-at [ char-gap-char ] unless* ; + morse-code-table value-at char-gap-char or ; > ] bi@ "-" glue ] dip prepend ; + +PAIR-GENERIC: blibble ( a b -- c ) + +PAIR-M: thang thang blibble + "vanilla " class-names ; + +PAIR-M: foom thang blibble + "chocolate " class-names ; + +PAIR-M: barm thang blibble + "strawberry " class-names ; + +PAIR-M: barm zim blibble + "coconut " class-names ; + +[ "vanilla zang-zim" ] [ zim new zang new blibble ] unit-test + +! args automatically swap to match most specific method +[ "chocolate foom-zim" ] [ foom new zim new blibble ] unit-test +[ "chocolate foom-zim" ] [ zim new foom new blibble ] unit-test + +[ "strawberry barm-barm" ] [ barm new barm new blibble ] unit-test +[ "strawberry barm-foom" ] [ barm new foom new blibble ] unit-test +[ "strawberry barm-foom" ] [ foom new barm new blibble ] unit-test + +[ "coconut barm-zang" ] [ zang new barm new blibble ] unit-test +[ "coconut barm-zim" ] [ barm new zim new blibble ] unit-test + +[ 1 2 blibble ] [ no-pair-method? ] must-fail-with diff --git a/extra/pair-methods/pair-methods.factor b/extra/pair-methods/pair-methods.factor new file mode 100644 index 0000000000..d44d5bce78 --- /dev/null +++ b/extra/pair-methods/pair-methods.factor @@ -0,0 +1,57 @@ +! (c)2009 Joe Groff bsd license +USING: arrays assocs classes classes.tuple.private combinators +effects.parser generic.parser kernel math math.order parser +quotations sequences sorting words ; +IN: pair-methods + +ERROR: no-pair-method a b generic ; + +: ?swap ( a b ? -- a/b b/a ) + [ swap ] when ; + +: method-sort-key ( pair -- key ) + first2 [ tuple-layout third ] bi@ + ; + +: pair-match-condition ( pair -- quot ) + first2 [ [ instance? ] swap prefix ] bi@ [ ] 2sequence + [ 2dup ] [ bi* and ] surround ; + +: pair-method-cond ( pair quot -- array ) + [ pair-match-condition ] [ ] bi* 2array ; + +: sorted-pair-methods ( word -- alist ) + "pair-generic-methods" word-prop >alist + [ [ first method-sort-key ] bi@ >=< ] sort ; + +: pair-generic-definition ( word -- def ) + [ sorted-pair-methods [ first2 pair-method-cond ] map ] + [ [ no-pair-method ] curry suffix ] bi 1quotation + [ 2dup [ class ] bi@ <=> +gt+ eq? ?swap ] [ cond ] surround ; + +: make-pair-generic ( word -- ) + dup pair-generic-definition define ; + +: define-pair-generic ( word effect -- ) + [ swap set-stack-effect ] + [ drop H{ } clone "pair-generic-methods" set-word-prop ] + [ drop make-pair-generic ] 2tri ; + +: (PAIR-GENERIC:) ( -- ) + CREATE-GENERIC complete-effect define-pair-generic ; + +SYNTAX: PAIR-GENERIC: (PAIR-GENERIC:) ; + +: define-pair-method ( a b pair-generic definition -- ) + [ 2array ] 2dip swap + [ "pair-generic-methods" word-prop [ swap ] dip set-at ] + [ make-pair-generic ] bi ; + +: ?prefix-swap ( quot ? -- quot' ) + [ \ swap prefix ] when ; + +: (PAIR-M:) ( -- ) + scan-word scan-word 2dup <=> +gt+ eq? [ + ?swap scan-word parse-definition + ] keep ?prefix-swap define-pair-method ; + +SYNTAX: PAIR-M: (PAIR-M:) ; diff --git a/extra/pair-methods/summary.txt b/extra/pair-methods/summary.txt new file mode 100644 index 0000000000..823bc712f6 --- /dev/null +++ b/extra/pair-methods/summary.txt @@ -0,0 +1 @@ +Order-insensitive double dispatch generics diff --git a/extra/pair-rocket/authors.txt b/extra/pair-rocket/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/pair-rocket/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/pair-rocket/pair-rocket-docs.factor b/extra/pair-rocket/pair-rocket-docs.factor new file mode 100644 index 0000000000..d66df62347 --- /dev/null +++ b/extra/pair-rocket/pair-rocket-docs.factor @@ -0,0 +1,15 @@ +! (c)2009 Joe Groff bsd license +USING: help.markup help.syntax multiline ; +IN: pair-rocket + +HELP: => +{ $syntax "a => b" } +{ $description "Constructs a two-element array from the objects immediately before and after the " { $snippet "=>" } ". This syntax can be used inside sequence and assoc literals." } +{ $examples +{ $unchecked-example <" USING: pair-rocket prettyprint ; + +H{ "foo" => 1 "bar" => 2 } . +"> <" H{ { "foo" 1 } { "bar" 2 } } "> } +} +; + diff --git a/extra/pair-rocket/pair-rocket-tests.factor b/extra/pair-rocket/pair-rocket-tests.factor new file mode 100644 index 0000000000..695e50ea7e --- /dev/null +++ b/extra/pair-rocket/pair-rocket-tests.factor @@ -0,0 +1,10 @@ +! (c)2009 Joe Groff bsd license +USING: kernel pair-rocket tools.test ; +IN: pair-rocket.tests + +[ { "a" 1 } ] [ "a" => 1 ] unit-test +[ { { "a" } { 1 } } ] [ { "a" } => { 1 } ] unit-test +[ { drop 1 } ] [ drop => 1 ] unit-test + +[ H{ { "zippity" 5 } { "doo" 2 } { "dah" 7 } } ] +[ H{ "zippity" => 5 "doo" => 2 "dah" => 7 } ] unit-test diff --git a/extra/pair-rocket/pair-rocket.factor b/extra/pair-rocket/pair-rocket.factor new file mode 100644 index 0000000000..3bd8a098f6 --- /dev/null +++ b/extra/pair-rocket/pair-rocket.factor @@ -0,0 +1,6 @@ +! (c)2009 Joe Groff bsd license +USING: arrays kernel parser sequences ; +IN: pair-rocket + +SYNTAX: => dup pop scan-object 2array parsed ; + diff --git a/extra/pair-rocket/summary.txt b/extra/pair-rocket/summary.txt new file mode 100644 index 0000000000..79c8d60149 --- /dev/null +++ b/extra/pair-rocket/summary.txt @@ -0,0 +1 @@ +H{ "foo" => 1 "bar" => 2 } style literal syntax diff --git a/extra/qw/authors.txt b/extra/qw/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/qw/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/qw/qw-docs.factor b/extra/qw/qw-docs.factor new file mode 100644 index 0000000000..4709ef620d --- /dev/null +++ b/extra/qw/qw-docs.factor @@ -0,0 +1,12 @@ +! (c)2009 Joe Groff bsd license +USING: help.markup help.syntax multiline ; +IN: qw + +HELP: qw{ +{ $syntax "qw{ lorem ipsum }" } +{ $description "Marks the beginning of a literal array of strings. Component strings are delimited by whitespace." } +{ $examples +{ $unchecked-example <" USING: prettyprint qw ; +qw{ pop quiz my hive of big wild ex tranny jocks } . "> +<" { "pop" "quiz" "my" "hive" "of" "big" "wild" "ex" "tranny" "jocks" } "> } +} ; diff --git a/extra/qw/qw-tests.factor b/extra/qw/qw-tests.factor new file mode 100644 index 0000000000..c9d9208751 --- /dev/null +++ b/extra/qw/qw-tests.factor @@ -0,0 +1,5 @@ +! (c)2009 Joe Groff bsd license +USING: qw tools.test ; +IN: qw.tests + +[ { "zippity" "doo" "dah" } ] [ qw{ zippity doo dah } ] unit-test diff --git a/extra/qw/qw.factor b/extra/qw/qw.factor new file mode 100644 index 0000000000..ce96587c92 --- /dev/null +++ b/extra/qw/qw.factor @@ -0,0 +1,5 @@ +! (c)2009 Joe Groff bsd license +USING: lexer parser ; +IN: qw + +SYNTAX: qw{ "}" parse-tokens parsed ; diff --git a/extra/qw/summary.txt b/extra/qw/summary.txt new file mode 100644 index 0000000000..8c31961dc8 --- /dev/null +++ b/extra/qw/summary.txt @@ -0,0 +1 @@ +Perlish syntax for literal arrays of whitespace-delimited strings (qw{ foo bar }) diff --git a/extra/roles/authors.txt b/extra/roles/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/roles/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/roles/roles-docs.factor b/extra/roles/roles-docs.factor new file mode 100644 index 0000000000..412a7b8dcb --- /dev/null +++ b/extra/roles/roles-docs.factor @@ -0,0 +1,48 @@ +! (c)2009 Joe Groff bsd license +USING: classes.mixin help.markup help.syntax kernel multiline roles ; +IN: roles + +HELP: ROLE: +{ $syntax <" ROLE: name slots... ; +ROLE: name < role slots... ; +ROLE: name <{ roles... } slots... ; "> } +{ $description "Defines a new " { $link role } ". " { $link tuple } " classes which inherit this role will contain the specified " { $snippet "slots" } " as well as the slots associated with the optional inherited " { $snippet "roles" } "." +$nl +"Slot specifiers take one of the following three forms:" +{ $list + { { $snippet "name" } " - a slot which can hold any object, with no attributes" } + { { $snippet "{ name attributes... }" } " - a slot which can hold any object, with optional attributes" } + { { $snippet "{ name class attributes... }" } " - a slot specialized to a specific class, with optional attributes" } +} +"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } ; + +HELP: TUPLE: +{ $syntax <" TUPLE: name slots ; +TUPLE: name < estate slots ; +TUPLE: name <{ estates... } slots... ; "> } +{ $description "Defines a new " { $link tuple } " class." +$nl +"The list of inherited " { $snippet "estates" } " is optional; a single tuple superclass and/or a set of " { $link role } "s can be specified. If no superclass is provided, it defaults to " { $link tuple } "." +$nl +"Slot specifiers take one of the following three forms:" +{ $list + { { $snippet "name" } " - a slot which can hold any object, with no attributes" } + { { $snippet "{ name attributes... }" } " - a slot which can hold any object, with optional attributes" } + { { $snippet "{ name class attributes... }" } " - a slot specialized to a specific class, with optional attributes" } +} +"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } ; + +{ + POSTPONE: ROLE: + POSTPONE: TUPLE: +} related-words + +HELP: role +{ $class-description "The superclass of all role classes. A " { $snippet "role" } " is a " { $link mixin-class } " that includes a set of slot definitions that can be added to " { $link tuple } " classes alongside other " { $snippet "role" } "s." } ; + +HELP: multiple-inheritance-attempted +{ $class-description "This error is thrown if a " { $link POSTPONE: TUPLE: } " definition attempts to inherit more than one " { $link tuple } " class." } ; + +HELP: role-slot-overlap +{ $class-description "This error is thrown if a " { $link POSTPONE: TUPLE: } " or " { $link POSTPONE: ROLE: } " definition attempts to inherit a set of " { $link role } "s in which more than one attempts to define the same slot." } ; + diff --git a/extra/roles/roles-tests.factor b/extra/roles/roles-tests.factor new file mode 100644 index 0000000000..fcbc20db16 --- /dev/null +++ b/extra/roles/roles-tests.factor @@ -0,0 +1,67 @@ +! (c)2009 Joe Groff bsd license +USING: accessors classes.tuple compiler.units kernel qw roles sequences +tools.test ; +IN: roles.tests + +ROLE: fork tines ; +ROLE: spoon bowl ; +ROLE: instrument tone ; +ROLE: tuning-fork <{ fork instrument } volume ; + +TUPLE: utensil handle ; + +! role consumption and tuple inheritance can be mixed +TUPLE: foon <{ utensil fork spoon } ; +TUPLE: tuning-spork <{ utensil spoon tuning-fork } ; + +! role class testing +[ t ] [ fork role? ] unit-test +[ f ] [ foon role? ] unit-test + +! roles aren't tuple classes by themselves and can't be instantiated +[ f ] [ fork tuple-class? ] unit-test +[ fork new ] must-fail + +! tuples which consume roles fall under their class +[ t ] [ foon new fork? ] unit-test +[ t ] [ foon new spoon? ] unit-test +[ f ] [ foon new tuning-fork? ] unit-test +[ f ] [ foon new instrument? ] unit-test + +[ t ] [ tuning-spork new fork? ] unit-test +[ t ] [ tuning-spork new spoon? ] unit-test +[ t ] [ tuning-spork new tuning-fork? ] unit-test +[ t ] [ tuning-spork new instrument? ] unit-test + +! consumed role slots are placed in tuples in order +[ qw{ handle tines bowl } ] [ foon all-slots [ name>> ] map ] unit-test +[ qw{ handle bowl tines tone volume } ] [ tuning-spork all-slots [ name>> ] map ] unit-test + +! can't combine roles whose slots overlap +ROLE: bong bowl ; +SYMBOL: spong + +[ [ spong { spoon bong } { } define-tuple-class-with-roles ] with-compilation-unit ] +[ role-slot-overlap? ] must-fail-with + +[ [ spong { spoon bong } { } define-role ] with-compilation-unit ] +[ role-slot-overlap? ] must-fail-with + +! can't try to inherit multiple tuple classes +TUPLE: tool blade ; +SYMBOL: knife + +[ knife { utensil tool } { } define-tuple-class-with-roles ] +[ multiple-inheritance-attempted? ] must-fail-with + +! make sure method dispatch works +GENERIC: poke ( pokee poker -- result ) +GENERIC: scoop ( scoopee scooper -- result ) +GENERIC: tune ( tunee tuner -- result ) + +M: fork poke drop " got poked" append ; +M: spoon scoop drop " got scooped" append ; +M: instrument tune drop " got tuned" append ; + +[ "potato got poked" "potato got scooped" "potato got tuned" ] +[ "potato" tuning-spork new [ poke ] [ scoop ] [ tune ] 2tri ] unit-test diff --git a/extra/roles/roles.factor b/extra/roles/roles.factor new file mode 100644 index 0000000000..d54b4339a7 --- /dev/null +++ b/extra/roles/roles.factor @@ -0,0 +1,69 @@ +! (c)2009 Joe Groff bsd license +USING: accessors arrays classes classes.mixin classes.parser +classes.tuple classes.tuple.parser combinators +combinators.short-circuit kernel lexer make parser sequences +sets strings words ; +IN: roles + +ERROR: role-slot-overlap class slots ; +ERROR: multiple-inheritance-attempted classes ; + +PREDICATE: role < mixin-class + "role-slots" word-prop >boolean ; + +: parse-role-definition ( -- class superroles slots ) + CREATE-CLASS scan { + { ";" [ { } { } ] } + { "<" [ scan-word 1array [ parse-tuple-slots ] { } make ] } + { "<{" [ \ } parse-until >array [ parse-tuple-slots ] { } make ] } + [ { } swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ] + } case ; + +: slot-name ( name/array -- name ) + dup string? [ ] [ first ] if ; +: slot-names ( array -- names ) + [ slot-name ] map ; + +: role-slots ( role -- slots ) + [ "superroles" word-prop [ role-slots ] map concat ] + [ "role-slots" word-prop ] bi append ; + +: role-or-tuple-slot-names ( role-or-tuple -- names ) + dup role? + [ role-slots slot-names ] + [ all-slots [ name>> ] map ] if ; + +: check-for-slot-overlap ( class roles-and-superclass slots -- ) + [ [ role-or-tuple-slot-names ] map concat ] [ slot-names ] bi* append + duplicates dup empty? [ 2drop ] [ role-slot-overlap ] if ; + +: roles>slots ( roles-and-superclass slots -- superclass slots' ) + [ + [ role? ] partition + dup length { + { 0 [ drop tuple ] } + { 1 [ first ] } + [ drop multiple-inheritance-attempted ] + } case + swap [ role-slots ] map concat + ] dip append ; + +: add-to-roles ( class roles -- ) + [ add-mixin-instance ] with each ; + +: (define-role) ( class superroles slots -- ) + [ "superroles" set-word-prop ] [ "role-slots" set-word-prop ] bi-curry* + [ define-mixin-class ] tri ; + +: define-role ( class superroles slots -- ) + [ check-for-slot-overlap ] [ (define-role) ] [ drop add-to-roles ] 3tri ; + +: define-tuple-class-with-roles ( class roles-and-superclass slots -- ) + [ check-for-slot-overlap ] + [ roles>slots define-tuple-class ] + [ drop [ role? ] filter add-to-roles ] 3tri ; + +SYNTAX: ROLE: parse-role-definition define-role ; +SYNTAX: TUPLE: parse-role-definition define-tuple-class-with-roles ; + + diff --git a/extra/roles/summary.txt b/extra/roles/summary.txt new file mode 100644 index 0000000000..a14aae4838 --- /dev/null +++ b/extra/roles/summary.txt @@ -0,0 +1 @@ +Mixins for tuples diff --git a/extra/sequences/product/authors.txt b/extra/sequences/product/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/sequences/product/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/sequences/product/product-docs.factor b/extra/sequences/product/product-docs.factor new file mode 100644 index 0000000000..b7dcaa626e --- /dev/null +++ b/extra/sequences/product/product-docs.factor @@ -0,0 +1,61 @@ +! (c)2009 Joe Groff bsd license +USING: help.markup help.syntax multiline quotations sequences sequences.product ; +IN: sequences + +HELP: product-sequence +{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link } " word." } +{ $examples +{ $example <" USING: arrays prettyprint sequences.product ; +{ { 1 2 3 } { "a" "b" "c" } } >array . +"> <" { + { 1 "a" } + { 2 "a" } + { 3 "a" } + { 1 "b" } + { 2 "b" } + { 3 "b" } + { 1 "c" } + { 2 "c" } + { 3 "c" } +}"> } } ; + +HELP: +{ $values { "sequences" sequence } { "product-sequence" product-sequence } } +{ $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." } +{ $examples +{ $example <" USING: arrays prettyprint sequences.product ; +{ { 1 2 3 } { "a" "b" "c" } } >array . +"> <" { + { 1 "a" } + { 2 "a" } + { 3 "a" } + { 1 "b" } + { 2 "b" } + { 3 "b" } + { 1 "c" } + { 2 "c" } + { 3 "c" } +}"> } } ; + +{ product-sequence } related-words + +HELP: product-map +{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- value )" } } { "sequence" sequence } } +{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence." } +{ $notes { $snippet "[ ... ] product-map" } " is equivalent to, but more efficient than, " { $snippet " [ ... ] map" } "." } ; + +HELP: product-each +{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- )" } } } +{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } "." } +{ $notes { $snippet "[ ... ] product-each" } " is equivalent to, but more efficient than, " { $snippet " [ ... ] each" } "." } ; + +{ product-map product-each } related-words + +ARTICLE: "sequences.product" "Product sequences" +"The " { $vocab-link "sequences.product" } " vocabulary provides a virtual sequence and combinators for manipulating the cartesian product of a set of sequences." +{ $subsection product-sequence } +{ $subsection } +{ $subsection product-map } +{ $subsection product-each } ; + +ABOUT: "sequences.product" diff --git a/extra/sequences/product/product-tests.factor b/extra/sequences/product/product-tests.factor index dfabc166ac..5e0997dc2e 100644 --- a/extra/sequences/product/product-tests.factor +++ b/extra/sequences/product/product-tests.factor @@ -1,19 +1,26 @@ -USING: arrays kernel sequences sequences.cartesian-product tools.test ; +! (c)2009 Joe Groff bsd license +USING: arrays kernel make sequences sequences.product tools.test ; IN: sequences.product.tests -[ - { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } -] [ { { 0 1 2 } { "a" "b" } } [ ] cartesian-product-map ] unit-test + +[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ] +[ { { 0 1 2 } { "a" "b" } } >array ] unit-test + +: x ( n s -- sss ) concat ; + +[ { "a" "aa" "aaa" "b" "bb" "bbb" } ] +[ { { 1 2 3 } { "a" "b" } } [ first2 x ] product-map ] unit-test [ { { 0 "a" t } { 1 "a" t } { 2 "a" t } { 0 "b" t } { 1 "b" t } { 2 "b" t } { 0 "a" f } { 1 "a" f } { 2 "a" f } { 0 "b" f } { 1 "b" f } { 2 "b" f } } -] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] cartesian-product-map ] unit-test - -[ - { "012012" "aaabbb" } -] [ { { "0" "1" "2" } { "a" "b" } } [ [ first2 ] bi* [ append ] bi@ 2array ] cartesian-product-each ] unit-test - +] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] product-map ] unit-test +[ "a1b1c1a2b2c2" ] [ + [ + { { "a" "b" "c" } { "1" "2" } } + [ [ % ] each ] product-each + ] "" make +] unit-test diff --git a/extra/sequences/product/product.factor b/extra/sequences/product/product.factor new file mode 100644 index 0000000000..665d43f0cd --- /dev/null +++ b/extra/sequences/product/product.factor @@ -0,0 +1,63 @@ +! (c)2009 Joe Groff bsd license +USING: accessors arrays kernel locals math sequences ; +IN: sequences.product + +TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ; + +: ( sequences -- product-sequence ) + >array dup [ length ] map product-sequence boa ; + +INSTANCE: product-sequence sequence + +M: product-sequence length lengths>> product ; + +> ns ] [ nip sequences>> ] 2bi ; + +:: (carry-n) ( ns lengths i -- ) + 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) + ] when + ] unless ; + +: carry-ns ( ns lengths -- ) + 0 (carry-n) ; + +: product-iter ( ns lengths -- ) + [ 0 over [ 1+ ] change-nth ] dip carry-ns ; + +: start-product-iter ( sequence-product -- ns lengths ) + [ [ drop 0 ] map ] [ [ length ] map ] bi ; + +: end-product-iter? ( ns lengths -- ? ) + [ 1 tail* first ] bi@ = ; + +PRIVATE> + +M: product-sequence nth + product@ nths ; + +:: product-each ( sequences quot -- ) + sequences start-product-iter :> lengths :> ns + [ ns lengths end-product-iter? ] + [ ns sequences nths quot call ns lengths product-iter ] until ; inline + +:: product-map ( sequences quot -- sequence ) + 0 :> i! + sequences [ length ] [ * ] map-reduce sequences + [| result | + sequences [ quot call i result set-nth i 1+ i! ] product-each + result + ] new-like ; inline + diff --git a/extra/sequences/product/summary.txt b/extra/sequences/product/summary.txt new file mode 100644 index 0000000000..c234c84a94 --- /dev/null +++ b/extra/sequences/product/summary.txt @@ -0,0 +1 @@ +Cartesian products of sequences diff --git a/vm/code_gc.c b/vm/code_gc.c index c3c5bc9a10..1405daa93f 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -1,5 +1,10 @@ #include "master.h" +static void clear_free_list(F_HEAP *heap) +{ + memset(&heap->free,0,sizeof(F_HEAP_FREE_LIST)); +} + /* This malloc-style heap code is reasonably generic. Maybe in the future, it will be used for the data heap too, if we ever get incremental mark/sweep/compact GC. */ @@ -8,17 +13,23 @@ void new_heap(F_HEAP *heap, CELL size) heap->segment = alloc_segment(align_page(size)); if(!heap->segment) fatal_error("Out of memory in new_heap",size); - heap->free_list = NULL; + + clear_free_list(heap); } -/* If there is no previous block, next_free becomes the head of the free list, -else its linked in */ -INLINE void update_free_list(F_HEAP *heap, F_FREE_BLOCK *prev, F_FREE_BLOCK *next_free) +void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block) { - if(prev) - prev->next_free = next_free; + if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) + { + int index = block->block.size / BLOCK_SIZE_INCREMENT; + block->next_free = heap->free.small_blocks[index]; + heap->free.small_blocks[index] = block; + } else - heap->free_list = next_free; + { + block->next_free = heap->free.large_blocks; + heap->free.large_blocks = block; + } } /* Called after reading the code heap from the image file, and after code GC. @@ -28,7 +39,11 @@ compiling.limit. */ void build_free_list(F_HEAP *heap, CELL size) { F_BLOCK *prev = NULL; - F_FREE_BLOCK *prev_free = NULL; + + clear_free_list(heap); + + size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1); + F_BLOCK *scan = first_block(heap); F_FREE_BLOCK *end = (F_FREE_BLOCK *)(heap->segment->start + size); @@ -38,8 +53,7 @@ void build_free_list(F_HEAP *heap, CELL size) switch(scan->status) { case B_FREE: - update_free_list(heap,prev_free,(F_FREE_BLOCK *)scan); - prev_free = (F_FREE_BLOCK *)scan; + add_to_free_list(heap,(F_FREE_BLOCK *)scan); break; case B_ALLOCATED: break; @@ -58,10 +72,9 @@ void build_free_list(F_HEAP *heap, CELL size) { end->block.status = B_FREE; end->block.size = heap->segment->end - (CELL)end; - end->next_free = NULL; /* add final free block */ - update_free_list(heap,prev_free,end); + add_to_free_list(heap,end); } /* This branch is taken if the newly loaded image fits exactly, or after code GC */ @@ -70,63 +83,88 @@ void build_free_list(F_HEAP *heap, CELL size) /* even if there's no room at the end of the heap for a new free block, we might have to jigger it up by a few bytes in case prev + prev->size */ - if(prev) - prev->size = heap->segment->end - (CELL)prev; - - /* this is the last free block */ - update_free_list(heap,prev_free,NULL); + if(prev) prev->size = heap->segment->end - (CELL)prev; } } +static void assert_free_block(F_FREE_BLOCK *block) +{ + if(block->block.status != B_FREE) + critical_error("Invalid block in free list",(CELL)block); +} + +F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) +{ + CELL attempt = size; + + while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) + { + int index = attempt / BLOCK_SIZE_INCREMENT; + F_FREE_BLOCK *block = heap->free.small_blocks[index]; + if(block) + { + assert_free_block(block); + heap->free.small_blocks[index] = block->next_free; + return block; + } + + attempt *= 2; + } + + F_FREE_BLOCK *prev = NULL; + F_FREE_BLOCK *block = heap->free.large_blocks; + + while(block) + { + assert_free_block(block); + if(block->block.size >= size) + { + if(prev) + prev->next_free = block->next_free; + else + heap->free.large_blocks = block->next_free; + return block; + } + + prev = block; + block = block->next_free; + } + + return NULL; +} + +F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL size) +{ + if(block->block.size != size ) + { + /* split the block in two */ + F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)block + size); + split->block.status = B_FREE; + split->block.size = block->block.size - size; + split->next_free = block->next_free; + block->block.size = size; + add_to_free_list(heap,split); + } + + return block; +} + /* Allocate a block of memory from the mark and sweep GC heap */ F_BLOCK *heap_allot(F_HEAP *heap, CELL size) { - F_FREE_BLOCK *prev = NULL; - F_FREE_BLOCK *scan = heap->free_list; + size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1); - size = (size + 31) & ~31; - - while(scan) + F_FREE_BLOCK *block = find_free_block(heap,size); + if(block) { - if(scan->block.status != B_FREE) - critical_error("Invalid block in free list",(CELL)scan); + block = split_free_block(heap,block,size); - if(scan->block.size < size) - { - prev = scan; - scan = scan->next_free; - continue; - } - - /* we found a candidate block */ - F_FREE_BLOCK *next_free; - - if(scan->block.size - size <= sizeof(F_BLOCK) * 2) - { - /* too small to be split */ - next_free = scan->next_free; - } - else - { - /* split the block in two */ - F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)scan + size); - split->block.status = B_FREE; - split->block.size = scan->block.size - size; - split->next_free = scan->next_free; - scan->block.size = size; - next_free = split; - } - - /* update the free list */ - update_free_list(heap,prev,next_free); - - /* this is our new block */ - scan->block.status = B_ALLOCATED; - return &scan->block; + block->block.status = B_ALLOCATED; + return &block->block; } - - return NULL; + else + return NULL; } void mark_block(F_BLOCK *block) @@ -162,8 +200,10 @@ void unmark_marked(F_HEAP *heap) /* After code GC, all referenced code blocks have status set to B_MARKED, so any which are allocated and not marked can be reclaimed. */ -void free_unmarked(F_HEAP *heap) +void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter) { + clear_free_list(heap); + F_BLOCK *prev = NULL; F_BLOCK *scan = first_block(heap); @@ -183,10 +223,15 @@ void free_unmarked(F_HEAP *heap) case B_FREE: if(prev && prev->status == B_FREE) prev->size += scan->size; + else + prev = scan; break; case B_MARKED: + if(prev && prev->status == B_FREE) + add_to_free_list(heap,(F_FREE_BLOCK *)prev); scan->status = B_ALLOCATED; prev = scan; + iter(scan); break; default: critical_error("Invalid scan->status",(CELL)scan); @@ -195,7 +240,8 @@ void free_unmarked(F_HEAP *heap) scan = next_block(heap,scan); } - build_free_list(heap,heap->segment->size); + if(prev && prev->status == B_FREE) + add_to_free_list(heap,(F_FREE_BLOCK *)prev); } /* Compute total sum of sizes of free blocks, and size of largest free block */ diff --git a/vm/code_gc.h b/vm/code_gc.h old mode 100644 new mode 100755 index cc2c42f120..d71dee29c5 --- a/vm/code_gc.h +++ b/vm/code_gc.h @@ -1,14 +1,24 @@ +#define FREE_LIST_COUNT 16 +#define BLOCK_SIZE_INCREMENT 32 + +typedef struct { + F_FREE_BLOCK *small_blocks[FREE_LIST_COUNT]; + F_FREE_BLOCK *large_blocks; +} F_HEAP_FREE_LIST; + typedef struct { F_SEGMENT *segment; - F_FREE_BLOCK *free_list; + F_HEAP_FREE_LIST free; } F_HEAP; +typedef void (*HEAP_ITERATOR)(F_BLOCK *compiled); + void new_heap(F_HEAP *heap, CELL size); void build_free_list(F_HEAP *heap, CELL size); F_BLOCK *heap_allot(F_HEAP *heap, CELL size); void mark_block(F_BLOCK *block); void unmark_marked(F_HEAP *heap); -void free_unmarked(F_HEAP *heap); +void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter); void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free); CELL heap_size(F_HEAP *heap); CELL compute_heap_forwarding(F_HEAP *heap); diff --git a/vm/data_gc.c b/vm/data_gc.c index 0b210310a2..872358d362 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -330,7 +330,7 @@ CELL copy_next_from_tenured(CELL scan) void copy_reachable_objects(CELL scan, CELL *end) { - if(HAVE_NURSERY_P && collecting_gen == NURSERY) + if(collecting_gen == NURSERY) { while(scan < *end) scan = copy_next_from_nursery(scan); @@ -405,7 +405,7 @@ void end_gc(CELL gc_elapsed) if(collecting_gen != NURSERY) reset_generations(NURSERY,collecting_gen - 1); } - else if(HAVE_NURSERY_P && collecting_gen == NURSERY) + else if(collecting_gen == NURSERY) { nursery.here = nursery.start; } @@ -416,13 +416,6 @@ void end_gc(CELL gc_elapsed) reset_generations(NURSERY,collecting_gen); } - if(collecting_gen == TENURED) - { - /* now that all reachable code blocks have been marked, - deallocate the rest */ - free_unmarked(&code_heap); - } - collecting_aging_again = false; } @@ -491,7 +484,7 @@ void garbage_collection(CELL gen, code_heap_scans++; if(collecting_gen == TENURED) - update_code_heap_roots(); + free_unmarked(&code_heap,(HEAP_ITERATOR)update_literal_references); else copy_code_heap_roots(); diff --git a/vm/data_gc.h b/vm/data_gc.h index b59cb0eb9e..a1184d53d4 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -58,7 +58,7 @@ INLINE bool should_copy(CELL untagged) return true; else if(HAVE_AGING_P && collecting_gen == AGING) return !in_zone(&data_heap->generations[TENURED],untagged); - else if(HAVE_NURSERY_P && collecting_gen == NURSERY) + else if(collecting_gen == NURSERY) return in_zone(&nursery,untagged); else { @@ -78,6 +78,11 @@ allocation (which does not call GC because of possible roots in volatile registers) does not run out of memory */ #define ALLOT_BUFFER_ZONE 1024 +/* If this is defined, we GC every 100 allocations. This catches missing local roots */ +#ifdef GC_DEBUG +int gc_count; +#endif + /* * It is up to the caller to fill in the object's fields in a meaningful * fashion! @@ -85,10 +90,18 @@ registers) does not run out of memory */ int count; INLINE void *allot_object(CELL type, CELL a) { - if(!gc_off) { if(count++ % 100 == 0) { printf("!\n"); gc(); } } +#ifdef GC_DEBUG + if(!gc_off) + { + if(gc_count++ % 1000 == 0) + gc(); + + } +#endif + CELL *object; - if(HAVE_NURSERY_P && nursery.size - ALLOT_BUFFER_ZONE > a) + if(nursery.size - ALLOT_BUFFER_ZONE > a) { /* If there is insufficient room, collect the nursery */ if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end) diff --git a/vm/data_heap.h b/vm/data_heap.h index a7f44e73f8..5836967295 100644 --- a/vm/data_heap.h +++ b/vm/data_heap.h @@ -37,7 +37,6 @@ F_DATA_HEAP *data_heap; /* the 0th generation is where new objects are allocated. */ #define NURSERY 0 -#define HAVE_NURSERY_P (data_heap->gen_count>1) /* where objects hang around */ #define AGING (data_heap->gen_count-2) #define HAVE_AGING_P (data_heap->gen_count>2)