diff --git a/Factor.app/Contents/Frameworks/libfreetype.6.dylib b/Factor.app/Contents/Frameworks/libfreetype.6.dylib deleted file mode 100755 index 381e74bf18..0000000000 Binary files a/Factor.app/Contents/Frameworks/libfreetype.6.dylib and /dev/null differ diff --git a/Makefile b/Makefile index 3f385ec496..5e63017218 100644 --- a/Makefile +++ b/Makefile @@ -11,6 +11,7 @@ IMAGE = factor.image BUNDLE = Factor.app LIBPATH = -L/usr/X11R6/lib CFLAGS = -Wall +FFI_TEST_CFLAGS = -fPIC ifdef DEBUG CFLAGS += -g @@ -140,9 +141,10 @@ wince-arm: macosx.app: factor mkdir -p $(BUNDLE)/Contents/MacOS + mkdir -p $(BUNDLE)/Contents/Frameworks mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor ln -s Factor.app/Contents/MacOS/factor ./factor - cp $(ENGINE) $(BUNDLE)/Contents/Frameworks + cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE) install_name_tool \ -change libfactor.dylib \ @@ -160,11 +162,11 @@ factor-console: $(DLL_OBJS) $(EXE_OBJS) $(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS) factor-ffi-test: vm/ffi_test.o - $(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(DLL_EXTENSION) $(TEST_OBJS) + $(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS) clean: rm -f vm/*.o - rm -f factor*.dll libfactor.{a,so,dylib} + rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} vm/resources.o: $(WINDRES) vm/factor.rs vm/resources.o diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor old mode 100644 new mode 100755 index c65fed55e2..4d7882ad08 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -9,11 +9,11 @@ IN: compiler.tests << : libfactor-ffi-tests-path ( -- string ) - "resource:" normalize-path + "resource:" (normalize-path) { { [ os winnt? ] [ "libfactor-ffi-test.dll" ] } { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] } - { [ os unix? ] [ "libfactor-ffi-test.a" ] } + { [ os unix? ] [ "libfactor-ffi-test.so" ] } } cond append-path ; "f-cdecl" libfactor-ffi-tests-path "cdecl" add-library @@ -124,8 +124,6 @@ unit-test "int" { "int" "int" "int" "int" } "stdcall" alien-indirect gc ; -LIBRARY: f-stdcall - [ f ] [ "f-stdcall" load-library f = ] unit-test [ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test @@ -166,7 +164,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3, : ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y ) "int" - "f-stdcall" "ffi_test_31" + "f-cdecl" "ffi_test_31" { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } alien-invoke gc 3 ; @@ -174,7 +172,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3, : ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result ) "float" - "f-stdcall" "ffi_test_31_point_5" + "f-cdecl" "ffi_test_31_point_5" { "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" } alien-invoke ; diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 8b6b4fbb11..85bf188bb8 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -659,13 +659,40 @@ M: ppc %callback-value ( ctype -- ) M: ppc small-enough? ( n -- ? ) -32768 32767 between? ; -M: ppc return-struct-in-registers? ( c-type -- ? ) drop f ; +M: ppc return-struct-in-registers? ( c-type -- ? ) + c-type return-in-registers?>> ; -M: ppc %box-small-struct - drop "No small structs" throw ; +M: ppc %box-small-struct ( c-type -- ) + #! Box a <= 16-byte struct returned in r3:r4:r5:r6 + heap-size 7 LI + "box_medium_struct" f %alien-invoke ; -M: ppc %unbox-small-struct - drop "No small structs" throw ; +: %unbox-struct-1 ( -- ) + ! Alien must be in r3. + "alien_offset" f %alien-invoke + 3 3 0 LWZ ; + +: %unbox-struct-2 ( -- ) + ! Alien must be in r3. + "alien_offset" f %alien-invoke + 4 3 4 LWZ + 3 3 0 LWZ ; + +: %unbox-struct-4 ( -- ) + ! Alien must be in r3. + "alien_offset" f %alien-invoke + 6 3 12 LWZ + 5 3 8 LWZ + 4 3 4 LWZ + 3 3 0 LWZ ; + +M: ppc %unbox-small-struct ( size -- ) + #! Alien must be in EAX. + heap-size cell align cell /i { + { 1 [ %unbox-struct-1 ] } + { 2 [ %unbox-struct-2 ] } + { 4 [ %unbox-struct-4 ] } + } case ; USE: vocabs.loader @@ -673,3 +700,5 @@ USE: vocabs.loader { [ os macosx? ] [ "cpu.ppc.macosx" require ] } { [ os linux? ] [ "cpu.ppc.linux" require ] } } cond + +"complex-double" c-type t >>return-in-registers? drop diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index cc379810ac..abee7194a2 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: farkup kernel peg peg.ebnf tools.test namespaces xml -urls.encoding assocs xml.traversal xml.data ; +urls.encoding assocs xml.traversal xml.data sequences random +io continuations math ; IN: farkup.tests relative-link-prefix off @@ -180,3 +181,29 @@ link-no-follow? off [ "

italicsbothafter

" ] [ "_italics*both_after*" convert-farkup ] unit-test [ "
foo|bar
" ] [ "|foo\\|bar|" convert-farkup ] unit-test [ "

" ] [ "\\" convert-farkup ] unit-test + +[ "

[abc]

" ] [ "[abc]" convert-farkup ] unit-test + +: random-markup ( -- string ) + 10 [ + 2 random 1 = [ + { + "[[" + "*" + "_" + "|" + "-" + "[{" + "\n" + } random + ] [ + "abc" + ] if + ] replicate concat ; + +[ t ] [ + 100 [ + drop random-markup + [ convert-farkup drop t ] [ drop print f ] recover + ] all? +] unit-test diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index 23a9023835..c400457c0b 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -75,7 +75,7 @@ DEFER: (parse-paragraph) "|" split1 [ "" like dup simple-link-title ] unless* [ "image:" ?head ] dip swap [ image boa ] [ parse-paragraph link boa ] if - ] dip [ (parse-paragraph) cons ] when* ; + ] dip [ (parse-paragraph) cons ] [ 1list ] if* ; : ?first ( seq -- elt ) 0 swap ?nth ; @@ -121,7 +121,7 @@ DEFER: (parse-paragraph) ] if ] if ; -: take-until ( state delimiter -- string/f state' ) +: take-until ( state delimiter -- string state'/f ) V{ } clone (take-until) ; : count= ( string -- n ) @@ -186,10 +186,12 @@ DEFER: (parse-paragraph) : parse-code ( state -- state' item ) dup 1 look CHAR: [ = - [ unclip-slice make-paragraph ] [ - "{" take-until [ rest ] dip - "}]" take-until - [ code boa ] dip swap + [ take-line make-paragraph ] [ + dup "{" take-until [ + [ nip rest ] dip + "}]" take-until + [ code boa ] dip swap + ] [ drop take-line make-paragraph ] if* ] if ; : parse-item ( state -- state' item ) diff --git a/basis/help/tips/tips-docs.factor b/basis/help/tips/tips-docs.factor index 8d732c5568..750eff7a52 100644 --- a/basis/help/tips/tips-docs.factor +++ b/basis/help/tips/tips-docs.factor @@ -17,7 +17,14 @@ TIP: "You can write documentation for your own code using the " { $link "help" } TIP: "You can write graphical applications using the " { $link "ui" } "." ; TIP: "Power tools: " { $links see edit help about apropos time infer. } ; - + +TIP: "Tips of the day implement the " { $link "definition-protocol" } " and new tips of the day can be defined using the " { $link POSTPONE: TIP: } " parsing word." ; + +HELP: TIP: +{ $syntax "TIP: content ;" } +{ $values { "content" "a markup element" } } +{ $description "Defines a new tip of the day." } ; + ARTICLE: "all-tips-of-the-day" "All tips of the day" { $tips-of-the-day } ; diff --git a/basis/help/tips/tips.factor b/basis/help/tips/tips.factor index 8d173ce533..4685b6c517 100644 --- a/basis/help/tips/tips.factor +++ b/basis/help/tips/tips.factor @@ -1,14 +1,28 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser arrays namespaces sequences random help.markup kernel io -io.styles colors.constants ; +USING: parser arrays namespaces sequences random help.markup help.stylesheet +kernel io io.styles colors.constants definitions accessors ; IN: help.tips SYMBOL: tips tips [ V{ } clone ] initialize -SYNTAX: TIP: parse-definition >array tips get push ; +TUPLE: tip < identity-tuple content loc ; + +M: tip forget* tips get delq ; + +M: tip where loc>> ; + +M: tip set-where (>>loc) ; + +: ( content -- tip ) f tip boa ; + +: add-tip ( tip -- ) tips get push ; + +SYNTAX: TIP: + parse-definition >array + [ save-location ] [ add-tip ] bi ; : a-tip ( -- tip ) tips get random ; @@ -20,13 +34,20 @@ H{ { wrap-margin 500 } } tip-of-the-day-style set-global +: $tip-title ( tip -- ) + [ + heading-style get [ + [ "Tip of the day" ] dip write-object + ] with-style + ] ($block) ; + : $tip-of-the-day ( element -- ) drop [ tip-of-the-day-style get [ last-element off - "Tip of the day" $heading a-tip print-element nl + a-tip [ $tip-title ] [ content>> print-element nl ] bi "— " print-element "all-tips-of-the-day" ($link) ] with-nesting @@ -35,4 +56,6 @@ H{ : tip-of-the-day. ( -- ) { $tip-of-the-day } print-content nl ; : $tips-of-the-day ( element -- ) - drop tips get [ nl nl ] [ print-element ] interleave ; \ No newline at end of file + drop tips get [ nl nl ] [ content>> print-element ] interleave ; + +INSTANCE: tip definition \ No newline at end of file diff --git a/basis/help/topics/topics.factor b/basis/help/topics/topics.factor index 864b030126..a251849e8f 100644 --- a/basis/help/topics/topics.factor +++ b/basis/help/topics/topics.factor @@ -7,8 +7,12 @@ IN: help.topics TUPLE: link name ; +INSTANCE: link definition + MIXIN: topic + INSTANCE: link topic + INSTANCE: word topic GENERIC: >link ( obj -- obj ) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 52684e55f5..597367c353 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -34,16 +34,18 @@ M: object specializer-declaration class ; [ specializer-declaration ] map '[ _ declare ] pick append ] { } map>assoc ; +: specialize-quot ( quot specializer -- quot' ) + specializer-cases alist>quot ; + : method-declaration ( method -- quot ) [ "method-generic" word-prop dispatch# object ] [ "method-class" word-prop ] bi prefix ; : specialize-method ( quot method -- quot' ) - method-declaration '[ _ declare ] prepend ; - -: specialize-quot ( quot specializer -- quot' ) - specializer-cases alist>quot ; + [ method-declaration '[ _ declare ] prepend ] + [ "method-generic" word-prop "specializer" word-prop ] bi + [ specialize-quot ] when* ; : standard-method? ( method -- ? ) dup method-body? [ @@ -52,9 +54,11 @@ M: object specializer-declaration class ; : specialized-def ( word -- quot ) [ def>> ] keep - [ dup standard-method? [ specialize-method ] [ drop ] if ] - [ "specializer" word-prop [ specialize-quot ] when* ] - bi ; + dup generic? [ drop ] [ + [ dup standard-method? [ specialize-method ] [ drop ] if ] + [ "specializer" word-prop [ specialize-quot ] when* ] + bi + ] if ; : specialized-length ( specializer -- n ) dup [ array? ] all? [ first ] when length ; diff --git a/basis/images/images.factor b/basis/images/images.factor index a426c33ddc..08fbdd4e7e 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -1,16 +1,14 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors grouping sequences combinators -math specialized-arrays.direct.uint byte-arrays fry -specialized-arrays.direct.ushort specialized-arrays.uint -specialized-arrays.ushort specialized-arrays.float ; +USING: combinators kernel ; IN: images -SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR +SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ; : bytes-per-pixel ( component-order -- n ) { + { L [ 1 ] } { BGR [ 3 ] } { RGB [ 3 ] } { BGRA [ 4 ] } @@ -31,71 +29,4 @@ TUPLE: image dim component-order upside-down? bitmap ; : ( -- image ) image new ; inline -GENERIC: load-image* ( path tuple -- image ) - -: add-dummy-alpha ( seq -- seq' ) - 3 [ 255 suffix ] map concat ; - -: normalize-floats ( byte-array -- byte-array ) - byte-array>float-array [ 255.0 * >integer ] B{ } map-as ; - -GENERIC: normalize-component-order* ( image component-order -- image ) - -: normalize-component-order ( image -- image ) - dup component-order>> '[ _ normalize-component-order* ] change-bitmap ; - -M: RGBA normalize-component-order* drop ; - -M: R32G32B32A32 normalize-component-order* - drop normalize-floats ; - -M: R32G32B32 normalize-component-order* - drop normalize-floats add-dummy-alpha ; - -: RGB16>8 ( bitmap -- bitmap' ) - byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline - -M: R16G16B16A16 normalize-component-order* - drop RGB16>8 ; - -M: R16G16B16 normalize-component-order* - drop RGB16>8 add-dummy-alpha ; - -: BGR>RGB ( bitmap -- pixels ) - 3 [ ] map B{ } join ; inline - -: BGRA>RGBA ( bitmap -- pixels ) - 4 - [ unclip-last-slice [ ] dip suffix ] map concat ; inline - -M: BGRA normalize-component-order* - drop BGRA>RGBA ; - -M: RGB normalize-component-order* - drop add-dummy-alpha ; - -M: BGR normalize-component-order* - drop BGR>RGB add-dummy-alpha ; - -: ARGB>RGBA ( bitmap -- bitmap' ) - 4 [ unclip suffix ] map B{ } join ; inline - -M: ARGB normalize-component-order* - drop ARGB>RGBA ; - -M: ABGR normalize-component-order* - drop ARGB>RGBA BGRA>RGBA ; - -: normalize-scan-line-order ( image -- image ) - dup upside-down?>> [ - dup dim>> first 4 * '[ - _ reverse concat - ] change-bitmap - f >>upside-down? - ] when ; - -: normalize-image ( image -- image ) - [ >byte-array ] change-bitmap - normalize-component-order - normalize-scan-line-order - RGBA >>component-order ; +GENERIC: load-image* ( path tuple -- image ) \ No newline at end of file diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 6f2ae47c61..b8bafc021f 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: constructors kernel splitting unicode.case combinators -accessors images.bitmap images.tiff images io.backend +accessors images.bitmap images.tiff images images.normalization io.pathnames ; IN: images.loader diff --git a/basis/images/normalization/authors.txt b/basis/images/normalization/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/images/normalization/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/images/normalization/normalization.factor b/basis/images/normalization/normalization.factor new file mode 100644 index 0000000000..bcdf841b42 --- /dev/null +++ b/basis/images/normalization/normalization.factor @@ -0,0 +1,78 @@ +! Copyright (C) 2009 Doug Coleman +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors grouping sequences combinators +math specialized-arrays.direct.uint byte-arrays fry +specialized-arrays.direct.ushort specialized-arrays.uint +specialized-arrays.ushort specialized-arrays.float images ; +IN: images.normalization + + [ 255 suffix ] map concat ; + +: normalize-floats ( byte-array -- byte-array ) + byte-array>float-array [ 255.0 * >integer ] B{ } map-as ; + +GENERIC: normalize-component-order* ( image component-order -- image ) + +: normalize-component-order ( image -- image ) + dup component-order>> '[ _ normalize-component-order* ] change-bitmap ; + +M: RGBA normalize-component-order* drop ; + +M: R32G32B32A32 normalize-component-order* + drop normalize-floats ; + +M: R32G32B32 normalize-component-order* + drop normalize-floats add-dummy-alpha ; + +: RGB16>8 ( bitmap -- bitmap' ) + byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline + +M: R16G16B16A16 normalize-component-order* + drop RGB16>8 ; + +M: R16G16B16 normalize-component-order* + drop RGB16>8 add-dummy-alpha ; + +: BGR>RGB ( bitmap -- pixels ) + 3 [ ] map B{ } join ; inline + +: BGRA>RGBA ( bitmap -- pixels ) + 4 + [ unclip-last-slice [ ] dip suffix ] map concat ; inline + +M: BGRA normalize-component-order* + drop BGRA>RGBA ; + +M: RGB normalize-component-order* + drop add-dummy-alpha ; + +M: BGR normalize-component-order* + drop BGR>RGB add-dummy-alpha ; + +: ARGB>RGBA ( bitmap -- bitmap' ) + 4 [ unclip suffix ] map B{ } join ; inline + +M: ARGB normalize-component-order* + drop ARGB>RGBA ; + +M: ABGR normalize-component-order* + drop ARGB>RGBA BGRA>RGBA ; + +: normalize-scan-line-order ( image -- image ) + dup upside-down?>> [ + dup dim>> first 4 * '[ + _ reverse concat + ] change-bitmap + f >>upside-down? + ] when ; + +PRIVATE> + +: normalize-image ( image -- image ) + [ >byte-array ] change-bitmap + normalize-component-order + normalize-scan-line-order + RGBA >>component-order ; diff --git a/basis/images/tesselation/authors.txt b/basis/images/tesselation/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/images/tesselation/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/images/tesselation/tesselation-tests.factor b/basis/images/tesselation/tesselation-tests.factor new file mode 100644 index 0000000000..2ac8e37ae7 --- /dev/null +++ b/basis/images/tesselation/tesselation-tests.factor @@ -0,0 +1,46 @@ +USING: images accessors kernel tools.test literals math.ranges +byte-arrays ; +IN: images.tesselation + +! Check an invariant we depend on +[ t ] [ + B{ 1 2 3 } >>bitmap dup clone [ bitmap>> ] bi@ eq? +] unit-test + +[ + { + { + T{ image f { 2 2 } L f B{ 1 2 5 6 } } + T{ image f { 2 2 } L f B{ 3 4 7 8 } } + } + { + T{ image f { 2 2 } L f B{ 9 10 13 14 } } + T{ image f { 2 2 } L f B{ 11 12 15 16 } } + } + } +] [ + + 1 16 [a,b] >byte-array >>bitmap + { 4 4 } >>dim + L >>component-order + { 2 2 } tesselate +] unit-test + +[ + { + { + T{ image f { 2 2 } L f B{ 1 2 4 5 } } + T{ image f { 1 2 } L f B{ 3 6 } } + } + { + T{ image f { 2 1 } L f B{ 7 8 } } + T{ image f { 1 1 } L f B{ 9 } } + } + } +] [ + + 1 9 [a,b] >byte-array >>bitmap + { 3 3 } >>dim + L >>component-order + { 2 2 } tesselate +] unit-test \ No newline at end of file diff --git a/basis/images/tesselation/tesselation.factor b/basis/images/tesselation/tesselation.factor new file mode 100644 index 0000000000..694041a28d --- /dev/null +++ b/basis/images/tesselation/tesselation.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: sequences kernel math grouping fry columns locals accessors +images math math.vectors arrays ; +IN: images.tesselation + +: group-rows ( bitmap bitmap-dim -- rows ) + first ; inline + +: tesselate-rows ( bitmap-rows tess-dim -- bitmaps ) + second ; inline + +: tesselate-columns ( bitmap-rows tess-dim -- bitmaps ) + first '[ _ ] map flip ; inline + +: tesselate-bitmap ( bitmap bitmap-dim tess-dim -- bitmap-grid ) + [ group-rows ] dip + [ tesselate-rows ] keep + '[ _ tesselate-columns ] map ; + +: tile-width ( tile-bitmap original-image -- width ) + [ first length ] [ component-order>> bytes-per-pixel ] bi* /i ; + +: ( tile-bitmap original-image -- tile-image ) + clone + swap + [ concat >>bitmap ] + [ [ over tile-width ] [ length ] bi 2array >>dim ] bi ; + +:: tesselate ( image tess-dim -- image-grid ) + image component-order>> bytes-per-pixel :> bpp + image dim>> { bpp 1 } v* :> image-dim' + tess-dim { bpp 1 } v* :> tess-dim' + image bitmap>> image-dim' tess-dim' tesselate-bitmap + [ [ image ] map ] map ; \ No newline at end of file diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index a3db10ffff..6db83ebca6 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -65,9 +65,9 @@ ERROR: file-not-found ; _ [ _ _ find-file [ file-not-found ] unless* ] attempt-all ] [ drop f - ] recover ; + ] recover ; inline : find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f ) - '[ _ _ find-all-files ] map concat ; + '[ _ _ find-all-files ] map concat ; inline os windows? [ "io.directories.search.windows" require ] when diff --git a/basis/io/streams/byte-array/byte-array-tests.factor b/basis/io/streams/byte-array/byte-array-tests.factor index 77a9126740..44290bfb47 100644 --- a/basis/io/streams/byte-array/byte-array-tests.factor +++ b/basis/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 ; +io.encodings.utf8 io kernel arrays strings namespaces ; [ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test [ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test @@ -7,3 +7,23 @@ io.encodings.utf8 io kernel arrays strings ; [ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ] [ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test [ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 contents dup >array swap string? ] unit-test + +[ B{ 121 120 } 0 ] [ + B{ 0 121 120 0 0 0 0 0 0 } binary + [ 1 read drop "\0" read-until ] with-byte-reader +] unit-test + +[ 1 1 4 11 f ] [ + B{ 1 2 3 4 5 6 7 8 9 10 11 12 } binary + [ + read1 + 0 seek-absolute input-stream get stream-seek + read1 + 2 seek-relative input-stream get stream-seek + read1 + -2 seek-end input-stream get stream-seek + read1 + 0 seek-end input-stream get stream-seek + read1 + ] with-byte-reader +] unit-test \ No newline at end of file diff --git a/basis/io/streams/byte-array/byte-array.factor b/basis/io/streams/byte-array/byte-array.factor index 25d879a534..2ffb9b9a63 100644 --- a/basis/io/streams/byte-array/byte-array.factor +++ b/basis/io/streams/byte-array/byte-array.factor @@ -28,7 +28,7 @@ M: byte-reader stream-seek ( n seek-type stream -- ) swap { { seek-absolute [ (>>i) ] } { seek-relative [ [ + ] change-i drop ] } - { seek-end [ dup underlying>> length >>i [ + ] change-i drop ] } + { seek-end [ [ underlying>> length + ] keep (>>i) ] } [ bad-seek-type ] } case ; diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 4f639c02a7..3148567bc0 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -37,7 +37,7 @@ IN: math.bitwise ! flags MACRO: flags ( values -- ) - [ 0 ] [ [ dup word? [ execute ] when bitor ] curry compose ] reduce ; + [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ; ! bitfield > diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor index 82dd035467..2b90bdb0d5 100644 --- a/basis/models/models-docs.factor +++ b/basis/models/models-docs.factor @@ -5,12 +5,13 @@ IN: models HELP: model { $class-description "A mutable cell holding a single value. When the value is changed, a sequence of connected objects are notified. Models have the following slots:" { $list - { { $snippet "value" } " - the value of the model. Use " { $link set-model } " to change the value." } - { { $snippet "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." } - { { $snippet "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." } - { { $snippet "ref" } " - a reference count tracking the number of models which depend on this one." } + { { $slot "value" } " - the value of the model. Use " { $link set-model } " to change the value." } + { { $slot "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." } + { { $slot "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." } + { { $slot "ref" } " - a reference count tracking the number of models which depend on this one." } + { { $slot "locked?" } " - a slot set by " { $link with-locked-model } " to ensure that the model doesn't get changed recursively" } } -"Other classes may delegate to " { $link model } "." +"Other classes may inherit from " { $link model } "." } ; HELP: diff --git a/basis/opengl/opengl-docs.factor b/basis/opengl/opengl-docs.factor index acff2dcd9e..f474c97b73 100644 --- a/basis/opengl/opengl-docs.factor +++ b/basis/opengl/opengl-docs.factor @@ -23,11 +23,11 @@ HELP: gl-line { $description "Draws a line between two points." } ; HELP: gl-fill-rect -{ $values { "dim" "a pair of integers" } } +{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } } { $description "Draws a filled rectangle with the top-left corner at the origin and the given dimensions." } ; HELP: gl-rect -{ $values { "dim" "a pair of integers" } } +{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } } { $description "Draws the outline of a rectangle with the top-left corner at the origin and the given dimensions." } ; HELP: gen-gl-buffer diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index e08a7487ae..0a21f67376 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -3,8 +3,8 @@ ! Portions copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types continuations kernel libc math macros -namespaces math.vectors math.parser opengl.gl opengl.glu -combinators arrays sequences splitting words byte-arrays assocs +namespaces math.vectors math.parser opengl.gl opengl.glu combinators +combinators.smart arrays sequences splitting words byte-arrays assocs colors colors.constants accessors generalizations locals fry specialized-arrays.float specialized-arrays.uint ; IN: opengl @@ -28,7 +28,7 @@ IN: opengl over glEnableClientState dip glDisableClientState ; inline : words>values ( word/value-seq -- value-seq ) - [ dup word? [ execute ] when ] map ; + [ ?execute ] map ; : (all-enabled) ( seq quot -- ) over [ glEnable ] each dip [ glDisable ] each ; inline @@ -67,42 +67,46 @@ MACRO: all-enabled-client-state ( seq quot -- ) : gl-line ( a b -- ) line-vertices GL_LINES 0 2 glDrawArrays ; -: (rect-vertices) ( dim -- vertices ) +:: (rect-vertices) ( loc dim -- vertices ) #! We use GL_LINE_STRIP with a duplicated first vertex #! instead of GL_LINE_LOOP to work around a bug in Apple's #! X3100 driver. - { - [ drop 0.5 0.5 ] - [ first 0.3 - 0.5 ] - [ [ first 0.3 - ] [ second 0.3 - ] bi ] - [ second 0.3 - 0.5 swap ] - [ drop 0.5 0.5 ] - } cleave 10 float-array{ } nsequence ; + loc first2 :> y :> x + dim first2 :> h :> w + [ + x 0.5 + y 0.5 + + x w + 0.3 - y 0.5 + + x w + 0.3 - y h + 0.3 - + x y h + 0.3 - + x 0.5 + y 0.5 + + ] float-array{ } output>sequence ; -: rect-vertices ( dim -- ) +: rect-vertices ( loc dim -- ) (rect-vertices) gl-vertex-pointer ; : (gl-rect) ( -- ) GL_LINE_STRIP 0 5 glDrawArrays ; -: gl-rect ( dim -- ) +: gl-rect ( loc dim -- ) rect-vertices (gl-rect) ; -: (fill-rect-vertices) ( dim -- vertices ) - { - [ drop 0 0 ] - [ first 0 ] - [ first2 ] - [ second 0 swap ] - } cleave 8 float-array{ } nsequence ; +:: (fill-rect-vertices) ( loc dim -- vertices ) + loc first2 :> y :> x + dim first2 :> h :> w + [ + x y + x w + y + x w + y h + + x y h + + ] float-array{ } output>sequence ; -: fill-rect-vertices ( dim -- ) +: fill-rect-vertices ( loc dim -- ) (fill-rect-vertices) gl-vertex-pointer ; : (gl-fill-rect) ( -- ) GL_QUADS 0 4 glDrawArrays ; -: gl-fill-rect ( dim -- ) +: gl-fill-rect ( loc dim -- ) fill-rect-vertices (gl-fill-rect) ; : do-attribs ( bits quot -- ) diff --git a/basis/opengl/textures/textures-tests.factor b/basis/opengl/textures/textures-tests.factor index 7141caa67d..163871028d 100644 --- a/basis/opengl/textures/textures-tests.factor +++ b/basis/opengl/textures/textures-tests.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: tools.test opengl.textures opengl.textures.private -images kernel namespaces ; +opengl.textures.private images kernel namespaces accessors +sequences ; IN: opengl.textures.tests [ ] [ @@ -52,4 +53,17 @@ IN: opengl.textures.tests { component-order R32G32B32 } { bitmap B{ } } } power-of-2-image +] unit-test + +[ + { + { { 0 0 } { 10 0 } } + { { 0 20 } { 10 20 } } + } +] [ + { + { { 10 20 } { 30 20 } } + { { 10 30 } { 30 300 } } + } + [ [ image new swap >>dim ] map ] map image-locs ] unit-test \ No newline at end of file diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index 48cdafb837..810aaa2c9c 100644 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -1,16 +1,15 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs cache colors.constants destructors fry kernel -opengl opengl.gl combinators images grouping specialized-arrays.float -locals sequences math math.vectors generalizations ; +opengl opengl.gl combinators images images.tesselation grouping +specialized-arrays.float locals sequences math math.vectors +math.matrices generalizations fry columns ; IN: opengl.textures : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ; : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ; -TUPLE: texture loc dim texture-coords texture display-list disposed ; - GENERIC: component-order>format ( component-order -- format type ) M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ; @@ -19,8 +18,14 @@ M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ; M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ; M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; +GENERIC: draw-texture ( texture -- ) + +GENERIC: draw-scaled-texture ( dim texture -- ) + format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ; -: draw-textured-rect ( dim texture -- ) +: with-texturing ( quot -- ) GL_TEXTURE_2D [ GL_TEXTURE_BIT [ GL_TEXTURE_COORD_ARRAY [ COLOR: white gl-color - dup loc>> [ - [ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ] - [ init-texture texture-coords>> gl-texture-coord-pointer ] bi - fill-rect-vertices (gl-fill-rect) - GL_TEXTURE_2D 0 glBindTexture - ] with-translation + call ] do-enabled-client-state ] do-attribs - ] do-enabled ; + ] do-enabled ; inline + +: (draw-textured-rect) ( dim texture -- ) + [ loc>> ] + [ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ] + [ init-texture texture-coords>> gl-texture-coord-pointer ] tri + swap gl-fill-rect ; + +: draw-textured-rect ( dim texture -- ) + [ + (draw-textured-rect) + GL_TEXTURE_2D 0 glBindTexture + ] with-texturing ; : texture-coords ( dim -- coords ) [ dup next-power-of-2 /f ] map @@ -92,10 +104,8 @@ M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; : make-texture-display-list ( texture -- dlist ) GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ; -PRIVATE> - -: ( image loc -- texture ) - texture new swap >>loc +: ( image loc -- texture ) + single-texture new swap >>loc swap [ dim>> >>dim ] keep [ dim>> product 0 = ] keep '[ @@ -105,12 +115,59 @@ PRIVATE> dup make-texture-display-list >>display-list ] unless ; -M: texture dispose* +M: single-texture dispose* [ texture>> [ delete-texture ] when* ] [ display-list>> [ delete-dlist ] when* ] bi ; -: draw-texture ( texture -- ) - display-list>> [ glCallList ] when* ; +M: single-texture draw-texture display-list>> [ glCallList ] when* ; -: draw-scaled-texture ( dim texture -- ) - dup texture>> [ draw-textured-rect ] [ 2drop ] if ; \ No newline at end of file +M: single-texture draw-scaled-texture + dup texture>> [ draw-textured-rect ] [ 2drop ] if ; + +TUPLE: multi-texture grid display-list loc disposed ; + +: image-locs ( image-grid -- loc-grid ) + [ first [ dim>> first ] map ] [ 0 [ dim>> second ] map ] bi + [ 0 [ + ] accumulate nip ] bi@ + cross-zip flip ; + +: ( image-grid loc -- grid ) + [ dup image-locs ] dip + '[ [ _ v+ |dispose ] 2map ] 2map ; + +: draw-textured-grid ( grid -- ) + [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ; + +: make-textured-grid-display-list ( grid -- dlist ) + GL_COMPILE [ + [ + [ + [ + [ dim>> ] keep (draw-textured-rect) + ] each + ] each + GL_TEXTURE_2D 0 glBindTexture + ] with-texturing + ] make-dlist ; + +: ( image-grid loc -- multi-texture ) + [ + [ + dup + make-textured-grid-display-list + ] keep + f multi-texture boa + ] with-destructors ; + +M: multi-texture draw-texture display-list>> [ glCallList ] when* ; + +M: multi-texture dispose* grid>> [ [ dispose ] each ] each ; + +CONSTANT: max-texture-size { 256 256 } + +PRIVATE> + +: ( image loc -- texture ) + over dim>> max-texture-size [ <= ] 2all? + [ ] + [ [ max-texture-size tesselate ] dip ] if ; \ No newline at end of file diff --git a/basis/regexp/compiler/compiler.factor b/basis/regexp/compiler/compiler.factor index 6c7896dcca..5482734865 100644 --- a/basis/regexp/compiler/compiler.factor +++ b/basis/regexp/compiler/compiler.factor @@ -84,21 +84,24 @@ C: box { } assoc-like [ first integer? ] partition [ [ literals>cases ] keep ] dip non-literals>dispatch ; -:: step ( last-match index str quot final? direction -- last-index/f ) +: advance ( index backwards? -- index+/-1 ) + -1 1 ? + >fixnum ; inline + +: check ( index string backwards? -- in-bounds? ) + [ drop -1 eq? not ] [ length < ] if ; inline + +:: step ( last-match index str quot final? backwards? -- last-index/f ) final? index last-match ? - index str bounds-check? [ - index direction + str + index str backwards? check [ + index backwards? advance str index str nth-unsafe quot call ] when ; inline -: direction ( -- n ) - backwards? get -1 1 ? ; - : transitions>quot ( transitions final-state? -- quot ) dup shortest? get and [ 2drop [ drop nip ] ] [ - [ split-literals swap case>quot ] dip direction - '[ { array-capacity string } declare _ _ _ step ] + [ split-literals swap case>quot ] dip backwards? get + '[ { fixnum string } declare _ _ _ step ] ] if ; : word>quot ( word dfa -- quot ) @@ -122,10 +125,13 @@ C: box : dfa>main-word ( dfa -- word ) states>words [ states>code ] keep start-state>> ; +: word-template ( quot -- quot' ) + '[ drop [ f ] 2dip over array-capacity? _ [ 2drop ] if ] ; + PRIVATE> : dfa>word ( dfa -- quot ) - dfa>main-word execution-quot '[ drop [ f ] 2dip @ ] + dfa>main-word execution-quot word-template (( start-index string regexp -- i/f )) define-temp ; : dfa>shortest-word ( dfa -- word ) diff --git a/basis/roman/roman-docs.factor b/basis/roman/roman-docs.factor index 4a8197f064..bef0ab90fc 100644 --- a/basis/roman/roman-docs.factor +++ b/basis/roman/roman-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel math ; +USING: help.markup help.syntax kernel math strings ; IN: roman HELP: >roman @@ -39,7 +39,7 @@ HELP: roman> { >roman >ROMAN roman> } related-words HELP: roman+ -{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } } +{ $values { "string" string } { "string" string } { "string" string } } { $description "Adds two Roman numerals." } { $examples { $example "USING: io roman ;" @@ -49,7 +49,7 @@ HELP: roman+ } ; HELP: roman- -{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } } +{ $values { "string" string } { "string" string } { "string" string } } { $description "Subtracts two Roman numerals." } { $examples { $example "USING: io roman ;" @@ -61,7 +61,7 @@ HELP: roman- { roman+ roman- } related-words HELP: roman* -{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } } +{ $values { "string" string } { "string" string } { "string" string } } { $description "Multiplies two Roman numerals." } { $examples { $example "USING: io roman ;" @@ -71,7 +71,7 @@ HELP: roman* } ; HELP: roman/i -{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } } +{ $values { "string" string } { "string" string } { "string" string } } { $description "Computes the integer division of two Roman numerals." } { $examples { $example "USING: io roman ;" @@ -81,7 +81,7 @@ HELP: roman/i } ; HELP: roman/mod -{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } } +{ $values { "string" string } { "string" string } { "string" string } { "string" string } } { $description "Computes the quotient and remainder of two Roman numerals." } { $examples { $example "USING: kernel io roman ;" diff --git a/basis/roman/roman-tests.factor b/basis/roman/roman-tests.factor index 82084e0b1f..a510514e23 100644 --- a/basis/roman/roman-tests.factor +++ b/basis/roman/roman-tests.factor @@ -38,3 +38,9 @@ USING: arrays kernel math roman roman.private sequences tools.test ; [ "iii" "iii" roman- ] must-fail [ 30 ] [ ROMAN: xxx ] unit-test + +[ roman+ ] must-infer +[ roman- ] must-infer +[ roman* ] must-infer +[ roman/i ] must-infer +[ roman/mod ] must-infer diff --git a/basis/roman/roman.factor b/basis/roman/roman.factor index 71343b723d..92202da8ca 100644 --- a/basis/roman/roman.factor +++ b/basis/roman/roman.factor @@ -1,29 +1,33 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs kernel math math.order math.vectors -namespaces make quotations sequences splitting.monotonic -sequences.private strings unicode.case lexer parser -grouping ; +USING: accessors arrays assocs fry generalizations grouping +kernel lexer macros make math math.order math.vectors +namespaces parser quotations sequences sequences.private +splitting.monotonic stack-checker strings unicode.case +words effects ; IN: roman = ; + [ roman-digit-index ] bi@ >= ; : roman>n ( ch -- n ) - 1string roman-digits index roman-values nth ; + roman-digit-index roman-values nth ; : (>roman) ( n -- ) roman-values roman-digits [ @@ -31,47 +35,39 @@ ERROR: roman-range-error n ; ] 2each drop ; : (roman>) ( seq -- n ) - [ [ roman>n ] map ] [ all-eq? ] bi [ - sum - ] [ - first2 swap - - ] if ; + [ [ roman>n ] map ] [ all-eq? ] bi + [ sum ] [ first2 swap - ] if ; PRIVATE> : >roman ( n -- str ) - dup roman-range-check - [ (>roman) ] "" make ; + dup roman-range-check [ (>roman) ] "" make ; : >ROMAN ( n -- str ) >roman >upper ; : roman> ( str -- n ) - >lower [ roman<= ] monotonic-split - [ (roman>) ] sigma ; + >lower [ roman<= ] monotonic-split [ (roman>) ] sigma ; ( str1 str2 -- m n ) - [ roman> ] bi@ ; - -: binary-roman-op ( str1 str2 quot -- str3 ) - [ 2roman> ] dip call >roman ; inline +MACRO: binary-roman-op ( quot -- quot' ) + [ infer in>> ] [ ] [ infer out>> ] tri + '[ [ roman> ] _ napply @ [ >roman ] _ napply ] ; PRIVATE> -: roman+ ( str1 str2 -- str3 ) - [ + ] binary-roman-op ; +<< +SYNTAX: ROMAN-OP: + scan-word [ name>> "roman" prepend create-in ] keep + 1quotation '[ _ binary-roman-op ] + dup infer [ in>> ] [ out>> ] bi + [ "string" ] bi@ define-declared ; +>> -: roman- ( str1 str2 -- str3 ) - [ - ] binary-roman-op ; - -: roman* ( str1 str2 -- str3 ) - [ * ] binary-roman-op ; - -: roman/i ( str1 str2 -- str3 ) - [ /i ] binary-roman-op ; - -: roman/mod ( str1 str2 -- str3 str4 ) - [ /mod ] binary-roman-op [ >roman ] dip ; +ROMAN-OP: + +ROMAN-OP: - +ROMAN-OP: * +ROMAN-OP: /i +ROMAN-OP: /mod SYNTAX: ROMAN: scan roman> parsed ; diff --git a/basis/specialized-vectors/specialized-vectors-tests.factor b/basis/specialized-vectors/specialized-vectors-tests.factor index df077ce189..82def17e44 100644 --- a/basis/specialized-vectors/specialized-vectors-tests.factor +++ b/basis/specialized-vectors/specialized-vectors-tests.factor @@ -1,5 +1,9 @@ IN: specialized-vectors.tests -USING: specialized-vectors.double tools.test kernel sequences ; +USING: specialized-arrays.float +specialized-vectors.float +specialized-vectors.double +tools.test kernel sequences ; [ 3 ] [ double-vector{ 1 2 } 3 over push length ] unit-test +[ t ] [ 10 float-array{ } new-resizable float-vector? ] unit-test \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index dd36c5a82b..c2b348f5f1 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -154,6 +154,15 @@ CONSTANT: bit-member-max 256 dup sequence? [ memq-quot ] [ drop f ] if ] 1 define-transform +! Index search +\ index [ + dup sequence? [ + dup length 4 >= [ + dup length zip >hashtable '[ _ at ] + ] [ drop f ] if + ] [ drop f ] if +] 1 define-transform + ! Shuffling : nths-quot ( indices -- quot ) [ [ '[ _ swap nth ] ] map ] [ length ] bi diff --git a/basis/tools/scaffold/scaffold-docs.factor b/basis/tools/scaffold/scaffold-docs.factor index 4d1240ad38..621933bfa8 100644 --- a/basis/tools/scaffold/scaffold-docs.factor +++ b/basis/tools/scaffold/scaffold-docs.factor @@ -26,7 +26,7 @@ HELP: scaffold-undocumented HELP: scaffold-vocab { $values { "vocab-root" "a vocabulary root string" } { "string" string } } -{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ; +{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file and an authors.txt file." } ; HELP: scaffold-emacs { $description "Touches the .emacs file in your home directory and provides a clickable link to open it in an editor." } ; diff --git a/basis/tools/scaffold/scaffold-tests.factor b/basis/tools/scaffold/scaffold-tests.factor new file mode 100644 index 0000000000..4c8698c114 --- /dev/null +++ b/basis/tools/scaffold/scaffold-tests.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test tools.scaffold unicode.case kernel +multiline tools.scaffold.private io.streams.string ; +IN: tools.scaffold.tests + +: undocumented-word ( obj1 obj2 -- obj3 obj4 ) + [ >lower ] [ >upper ] bi* ; + +[ +<" HELP: undocumented-word +{ $values + { "obj1" object } { "obj2" object } + { "obj3" object } { "obj4" object } +} +{ $description "" } ; +"> +] +[ + [ \ undocumented-word (help.) ] with-string-writer +] unit-test diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 6280f993cc..73e896d5ff 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -134,7 +134,7 @@ ERROR: no-vocab vocab ; vocabulary>> using get [ conjoin ] [ drop ] if* ; : ($values.) ( array -- ) - [ + [ bl ] [ "{ " write dup array? [ first ] when dup lookup-type [ @@ -145,7 +145,7 @@ ERROR: no-vocab vocab ; null add-using ] if " }" write - ] each ; + ] interleave ; : 4bl ( -- ) " " write ; inline diff --git a/basis/ui/gadgets/debug/debug.factor b/basis/ui/gadgets/debug/debug.factor index f8d496c1fc..786a97f689 100644 --- a/basis/ui/gadgets/debug/debug.factor +++ b/basis/ui/gadgets/debug/debug.factor @@ -58,7 +58,7 @@ M: metrics-paint draw-boundary COLOR: red gl-color [ dim>> ] [ >label< line-metrics ] bi [ [ first ] [ ascent>> ] bi* [ nip 0 swap 2array ] [ 2array ] 2bi gl-line ] - [ drop gl-rect ] + [ drop { 0 0 } swap gl-rect ] 2bi ; : ( text font -- gadget ) diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 55622503b6..f5b7f63d22 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -172,11 +172,10 @@ TUPLE: selected-line start end first? last? ; :: draw-selection ( line pair editor -- ) pair [ editor font>> line offset>x ] map :> pair - pair first 0 2array [ - editor selection-color>> gl-color - pair second pair first - round 1 max - editor line-height 2array gl-fill-rect - ] with-translation ; + editor selection-color>> gl-color + pair first 0 2array + pair second pair first - round 1 max editor line-height 2array + gl-fill-rect ; : draw-unselected-line ( line editor -- ) font>> swap draw-text ; diff --git a/basis/ui/gadgets/grids/grids-tests.factor b/basis/ui/gadgets/grids/grids-tests.factor index fb92cd2ac6..b83f1a7003 100644 --- a/basis/ui/gadgets/grids/grids-tests.factor +++ b/basis/ui/gadgets/grids/grids-tests.factor @@ -3,9 +3,6 @@ namespaces math.rectangles accessors ui.gadgets.grids.private ui.gadgets.debug sequences ; IN: ui.gadgets.grids.tests -[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ] -[ { 1 2 } { "a" "b" } cross-zip ] unit-test - [ { 0 0 } ] [ { } pref-dim ] unit-test : 100x100 ( -- gadget ) { 100 100 } >>dim ; diff --git a/basis/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor index 4ab080464b..ddcfa1465d 100644 --- a/basis/ui/gadgets/grids/grids.factor +++ b/basis/ui/gadgets/grids/grids.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.order namespaces make sequences words io +USING: arrays kernel math math.order math.matrices namespaces make sequences words io math.vectors ui.gadgets ui.baseline-alignment columns accessors strings.tables math.rectangles fry ; IN: ui.gadgets.grids @@ -33,9 +33,6 @@ PRIVATE> ( gadget -- cell ) @@ -116,7 +113,7 @@ M: grid layout* [ grid>> ] [ ] bi grid-layout ; M: grid children-on ( rect gadget -- seq ) dup children>> empty? [ 2drop f ] [ - { 0 1 } swap grid>> + [ { 0 1 } ] dip grid>> [ 0 fast-children-on ] keep concat ] if ; diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index 44da013f2c..a6bd5c4e29 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -79,9 +79,7 @@ GENERIC: draw-selection ( loc obj -- ) M: gadget draw-selection ( loc gadget -- ) swap offset-rect [ - dup loc>> [ - dim>> gl-fill-rect - ] with-translation + rect-bounds gl-fill-rect ] if-fits ; M: node draw-selection ( loc node -- ) diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index 7b1befc539..f2ed5b10e0 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -121,16 +121,15 @@ M: table layout* [ [ line-height ] dip * 0 swap 2array ] [ drop [ dim>> first ] [ line-height ] bi 2array ] 2bi ; -: highlight-row ( table row color quot -- ) - [ [ row-rect rect-bounds ] dip gl-color ] dip - '[ _ @ ] with-translation ; inline +: row-bounds ( table row -- loc dim ) + row-rect rect-bounds ; inline : draw-selected-row ( table -- ) { { [ dup selected-index>> not ] [ drop ] } [ - [ ] [ selected-index>> ] [ selection-color>> ] tri - [ gl-fill-rect ] highlight-row + [ ] [ selected-index>> ] [ selection-color>> gl-color ] tri + row-bounds gl-fill-rect ] } cond ; @@ -139,14 +138,15 @@ M: table layout* { [ dup focused?>> not ] [ drop ] } { [ dup selected-index>> not ] [ drop ] } [ - [ ] [ selected-index>> ] [ focus-border-color>> ] tri - [ gl-rect ] highlight-row + [ ] [ selected-index>> ] [ focus-border-color>> gl-color ] tri + row-bounds gl-rect ] } cond ; : draw-moused-row ( table -- ) dup mouse-index>> dup [ - over mouse-color>> [ gl-rect ] highlight-row + over mouse-color>> gl-color + row-bounds gl-rect ] [ 2drop ] if ; : column-line-offsets ( table -- xs ) @@ -279,7 +279,7 @@ PRIVATE> : row-action ( table -- ) dup selected-row - [ swap [ action>> call ] [ dup hook>> call ] bi ] + [ swap [ action>> call( value -- ) ] [ dup hook>> call( table -- ) ] bi ] [ 2drop ] if ; diff --git a/basis/ui/pens/solid/solid.factor b/basis/ui/pens/solid/solid.factor index 950035e773..fe44a8f341 100644 --- a/basis/ui/pens/solid/solid.factor +++ b/basis/ui/pens/solid/solid.factor @@ -9,8 +9,8 @@ TUPLE: solid < caching-pen color interior-vertices boundary-vertices ; M: solid recompute-pen swap dim>> - [ (fill-rect-vertices) >>interior-vertices ] - [ (rect-vertices) >>boundary-vertices ] + [ [ { 0 0 } ] dip (fill-rect-vertices) >>interior-vertices ] + [ [ { 0 0 } ] dip (rect-vertices) >>boundary-vertices ] bi drop ; > gl-fill-rect ; + { 0 0 } clip get dim>> gl-fill-rect ; GENERIC: draw-gadget* ( gadget -- ) diff --git a/basis/ui/tools/browser/browser-docs.factor b/basis/ui/tools/browser/browser-docs.factor index 03a5218e45..b07e72dbce 100644 --- a/basis/ui/tools/browser/browser-docs.factor +++ b/basis/ui/tools/browser/browser-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax ui.commands ; IN: ui.tools.browser ARTICLE: "ui-browser" "UI browser" -"The browser is used to display Factor code, documentation, and vocabularies. The browser is opened when a word or articlelink presentation is clicked. It can also be opened using words:" +"The browser is used to display Factor code, documentation, and vocabularies. The browser is opened when a word or article link presentation is clicked. It can also be opened using words:" { $subsection com-browse } { $subsection browser-window } { $command-map browser-gadget "toolbar" } diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 91448dfe10..7cb3c70cbc 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -263,8 +263,9 @@ M: listener-operation invoke-command ( target command -- ) : listener-run-files ( seq -- ) [ - [ \ listener-run-files ] dip - '[ _ [ run-file ] each ] call-listener + '[ _ [ run-file ] each ] + \ listener-run-files + call-listener ] unless-empty ; : com-end ( listener -- ) diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor index 28781e24bb..c6371ac8aa 100644 --- a/basis/ui/tools/operations/operations.factor +++ b/basis/ui/tools/operations/operations.factor @@ -81,8 +81,6 @@ IN: ui.tools.operations { +listener+ t } } define-operation -UNION: definition word method-spec link vocab vocab-link ; - [ definition? ] \ edit H{ { +keyboard+ T{ key-down f { C+ } "e" } } { +listener+ t } diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index 22d6cddfb9..12314505d9 100644 --- a/basis/unicode/breaks/breaks.factor +++ b/basis/unicode/breaks/breaks.factor @@ -60,7 +60,7 @@ SYMBOL: table : finish-table ( -- table ) table get [ [ 1 = ] map ] map ; -: eval-seq ( seq -- seq ) [ dup word? [ execute ] when ] map ; +: eval-seq ( seq -- seq ) [ ?execute ] map ; : (set-table) ( class1 class2 val -- ) [ table get nth ] dip '[ _ or ] change-nth ; diff --git a/basis/xmode/code2html/code2html-tests.factor b/basis/xmode/code2html/code2html-tests.factor index 241ab7ff75..8d5db4a6e9 100644 --- a/basis/xmode/code2html/code2html-tests.factor +++ b/basis/xmode/code2html/code2html-tests.factor @@ -18,4 +18,12 @@ kernel io.streams.string xml.writer ; <" int x = "hi"; /* a comment */ "> htmlize-stream write-xml +] unit-test + +[ ": foo ;" ] [ + { ": foo ;" } "factor" htmlize-lines xml>string +] unit-test + +[ ":foo" ] [ + { ":foo" } "factor" htmlize-lines xml>string ] unit-test \ No newline at end of file diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index f584756f33..b4c1cd6a48 100755 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -84,7 +84,7 @@ M: string-matcher text-matches? ] keep string>> length and ; M: regexp text-matches? - [ >string ] dip re-contains? ; + [ >string ] dip first-match dup [ to>> ] when ; : rule-start-matches? ( rule -- match-count/f ) dup start>> tuck swap can-match-here? [ diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 434b133b3f..c95c5816ac 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -3,6 +3,8 @@ USING: kernel sequences namespaces assocs graphs math math.order ; IN: definitions +MIXIN: definition + ERROR: no-compilation-unit definition ; SYMBOLS: inlined-dependency flushed-dependency called-dependency ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 8380a41207..c22641d439 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2008 Slava Pestov. +! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors words kernel sequences namespaces make assocs hashtables definitions kernel.private classes classes.private @@ -27,6 +27,8 @@ M: generic definition drop f ; PREDICATE: method-spec < pair first2 generic? swap class? and ; +INSTANCE: method-spec definition + : order ( generic -- seq ) "methods" word-prop keys sort-classes ; diff --git a/core/io/streams/sequence/sequence.factor b/core/io/streams/sequence/sequence.factor index f455512ed3..0f922a37cc 100644 --- a/core/io/streams/sequence/sequence.factor +++ b/core/io/streams/sequence/sequence.factor @@ -15,11 +15,10 @@ SLOT: i [ 1+ ] change-i drop ; inline : sequence-read1 ( stream -- elt/f ) - [ >sequence-stream< ?nth ] - [ next ] bi ; inline + [ >sequence-stream< ?nth ] [ next ] bi ; inline : add-length ( n stream -- i+n ) - [ i>> + ] [ underlying>> length ] bi min ; inline + [ i>> + ] [ underlying>> length ] bi min ; inline : (sequence-read) ( n stream -- seq/f ) [ add-length ] keep @@ -32,8 +31,8 @@ SLOT: i [ (sequence-read) ] [ 2drop f ] if ; inline : find-sep ( seps stream -- sep/f n ) - swap [ >sequence-stream< ] dip - [ memq? ] curry find-from swap ; inline + swap [ >sequence-stream< swap tail-slice ] dip + [ memq? ] curry find swap ; inline : sequence-read-until ( separators stream -- seq sep/f ) [ find-sep ] keep diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 56f19595cb..baccf56059 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -23,6 +23,10 @@ GENERIC: call ( callable -- ) GENERIC: execute ( word -- ) +GENERIC: ?execute ( word -- value ) + +M: object ?execute ; + DEFER: if : ? ( ? true false -- true/false ) diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 6a7e8116cd..df9eb568f6 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -556,18 +556,18 @@ HELP: BIN: { $examples { $example "USE: prettyprint" "BIN: 100 ." "4" } } ; HELP: GENERIC: -{ $syntax "GENERIC: word" "GENERIC: word ( stack -- effect )" } +{ $syntax "GENERIC: word ( stack -- effect )" } { $values { "word" "a new word to define" } } { $description "Defines a new generic word in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } ; HELP: GENERIC# -{ $syntax "GENERIC# word n" "GENERIC# word n ( stack -- effect )" } +{ $syntax "GENERIC# word n ( stack -- effect )" } { $values { "word" "a new word to define" } { "n" "the stack position to dispatch on" } } { $description "Defines a new generic word which dispatches on the " { $snippet "n" } "th most element from the top of the stack in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } { $notes "The following two definitions are equivalent:" - { $code "GENERIC: foo" } - { $code "GENERIC# foo 0" } + { $code "GENERIC: foo ( obj -- )" } + { $code "GENERIC# foo 0 ( obj -- )" } } ; HELP: MATH: @@ -576,7 +576,7 @@ HELP: MATH: { $description "Defines a new generic word which uses the " { $link math-combination } " method combination." } ; HELP: HOOK: -{ $syntax "HOOK: word variable" "HOOK: word variable ( stack -- effect ) " } +{ $syntax "HOOK: word variable ( stack -- effect ) " } { $values { "word" "a new word to define" } { "variable" word } } { $description "Defines a new hook word in the current vocabulary. Hook words are generic words which dispatch on the value of a variable, so methods are defined with " { $link POSTPONE: M: } ". Hook words differ from other generic words in that the dispatch value is removed from the stack before the chosen method is called." } { $examples diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index bcf9decdf3..cb5cdfd5ac 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -138,7 +138,7 @@ IN: bootstrap.syntax ] define-core-syntax "CONSTANT:" [ - CREATE scan-object define-constant + CREATE-WORD scan-object define-constant ] define-core-syntax ":" [ diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index edac418285..2b978e8666 100644 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -108,4 +108,6 @@ SYMBOL: load-vocab-hook ! ( name -- vocab ) : load-vocab ( name -- vocab ) load-vocab-hook get call( name -- vocab ) ; PREDICATE: runnable-vocab < vocab - vocab-main >boolean ; \ No newline at end of file + vocab-main >boolean ; + +INSTANCE: vocab-spec definition \ No newline at end of file diff --git a/core/words/alias/alias-tests.factor b/core/words/alias/alias-tests.factor new file mode 100644 index 0000000000..0278a4d4b9 --- /dev/null +++ b/core/words/alias/alias-tests.factor @@ -0,0 +1,6 @@ +USING: math eval tools.test effects ; +IN: words.alias.tests + +ALIAS: foo + +[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval ] unit-test +[ (( -- value )) ] [ \ foo stack-effect ] unit-test \ No newline at end of file diff --git a/core/words/words.factor b/core/words/words.factor index cfdcd4517f..5b230c1b00 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -12,6 +12,8 @@ IN: words M: word execute (execute) ; +M: word ?execute execute( -- value ) ; + M: word <=> [ [ name>> ] [ vocabulary>> ] bi 2array ] compare ; @@ -260,3 +262,5 @@ M: word hashcode* M: word literalize ; : xref-words ( -- ) all-words [ xref ] each ; + +INSTANCE: word definition \ No newline at end of file diff --git a/extra/cap/cap.factor b/extra/cap/cap.factor index 64696759bb..f43787673a 100644 --- a/extra/cap/cap.factor +++ b/extra/cap/cap.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Doug Coleman, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays byte-arrays kernel math namespaces -opengl.gl sequences math.vectors ui images images.viewer -models ui.gadgets.worlds ui.gadgets fry alien.syntax ; +opengl.gl sequences math.vectors ui images images.normalization +images.viewer models ui.gadgets.worlds ui.gadgets fry alien.syntax ; IN: cap : screenshot-array ( world -- byte-array ) diff --git a/extra/game-input/game-input-tests.factor b/extra/game-input/game-input-tests.factor index 69b40dbec7..2bf923c12b 100644 --- a/extra/game-input/game-input-tests.factor +++ b/extra/game-input/game-input-tests.factor @@ -1,8 +1,12 @@ IN: game-input.tests -USING: game-input tools.test kernel system threads ; +USING: ui game-input tools.test kernel system threads +combinators.short-circuit calendar ; -os windows? os macosx? or [ +{ + [ os windows? ui-running? and ] + [ os macosx? ] +} 0|| [ [ ] [ open-game-input ] unit-test - [ ] [ yield ] unit-test + [ ] [ 1 seconds sleep ] unit-test [ ] [ close-game-input ] unit-test ] when \ No newline at end of file diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor index d171d03798..feb110fab8 100644 --- a/extra/id3/id3-docs.factor +++ b/extra/id3/id3-docs.factor @@ -1,23 +1,113 @@ ! Copyright (C) 2008 Tim Wawrzynczak ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax sequences kernel accessors ; +USING: help.markup help.syntax sequences kernel accessors +id3.private strings ; IN: id3 -HELP: file-id3-tags +HELP: mp3>id3 { $values { "path" "a path string" } { "id3v2-info/f" "a tuple storing ID3v2 metadata or f" } } - { $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Currently, the parser supports the following tags: " - $nl { $link title>> } - $nl { $link artist>> } - $nl { $link album>> } - $nl { $link year>> } - $nl { $link genre>> } - $nl { $link comment>> } } ; + { $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Words to access the ID3v1 information are here:" + { $list + { $link title } + { $link artist } + { $link album } + { $link year } + { $link genre } + { $link comment } + } + "For other fields, use the " { $link find-id3-frame } " word." + } ; + +HELP: album +{ $values + { "id3" id3v2-info } + { "album/f" "string or f" } +} +{ $description "Returns the album, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; + +HELP: artist +{ $values + { "id3" id3v2-info } + { "artist/f" "string or f" } +} +{ $description "Returns the artist, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; + +HELP: comment +{ $values + { "id3" id3v2-info } + { "comment/f" "string or f" } +} +{ $description "Returns the comment, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; + +HELP: genre +{ $values + { "id3" id3v2-info } + { "genre/f" "string or f" } +} +{ $description "Returns the genre, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; + +HELP: title +{ $values + { "id3" id3v2-info } + { "title/f" "string or f" } +} +{ $description "Returns the title, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; + +HELP: year +{ $values + { "id3" id3v2-info } + { "year/f" "string or f" } +} +{ $description "Returns the year, or " { $link f } " if this field is missing, from a parsed id3 tag." } ; + +HELP: find-id3-frame +{ $values + { "id3" id3v2-info } { "name" string } + { "obj/f" "object or f" } +} +{ $description "Returns the " { $slot "data" } " slot of the ID3 frame with the given name, or " { $link f } "." } ; + +HELP: mp3-paths>id3s +{ $values + { "seq" sequence } + { "seq'" sequence } +} +{ $description "From a sequence of pathnames, parses each ID3 header and returns a sequence of key/value pairs of pathnames and ID3 objects." } ; + +HELP: find-mp3s +{ $values + { "path" "a pathname string" } + { "seq" sequence } +} +{ $description "Returns a sequence of MP3 pathnames from a directory and all of its subdirectories." } ; + +HELP: parse-mp3-directory +{ $values + { "path" "a pathname string" } + { "seq" sequence } +} +{ $description "Returns a sequence of key/value pairs where the key is the path of an MP3 and the value is the parsed ID3 header or " { $link f } " recursively for each MP3 file in the directory and all subdirectories." } ; ARTICLE: "id3" "ID3 tags" "The " { $vocab-link "id3" } " vocabulary contains words for parsing " { $emphasis "ID3" } " tags, which are textual fields storing an MP3's title, artist, and other metadata." $nl -"Parsing ID3 tags from an MP3 file:" -{ $subsection file-id3-tags } ; +"Parsing ID3 tags for a directory of MP3s, recursively:" +{ $subsection parse-mp3-directory } +"Finding MP3 files recursively:" +{ $subsection find-mp3s } +"Parsing a sequence of MP3 pathnames:" +{ $subsection mp3-paths>id3s } +"Parsing an MP3 file's ID3 tags:" +{ $subsection mp3>id3 } +"ID3v1 frame tag accessors:" +{ $subsection album } +{ $subsection artist } +{ $subsection comment } +{ $subsection genre } +{ $subsection title } +{ $subsection year } +"Access any frame tag:" +{ $subsection find-id3-frame } ; ABOUT: "id3" diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor index aefbec8550..a8f35e582c 100644 --- a/extra/id3/id3-tests.factor +++ b/extra/id3/id3-tests.factor @@ -5,12 +5,12 @@ IN: id3.tests : id3-params ( id3 -- title artist album year comment genre ) { - [ id3-title ] - [ id3-artist ] - [ id3-album ] - [ id3-year ] - [ id3-comment ] - [ id3-genre ] + [ title ] + [ artist ] + [ album ] + [ year ] + [ comment ] + [ genre ] } cleave ; [ @@ -20,7 +20,7 @@ IN: id3.tests "2009" "COMMENT" "Bluegrass" -] [ "vocab:id3/tests/blah.mp3" file-id3-tags id3-params ] unit-test +] [ "vocab:id3/tests/blah.mp3" mp3>id3 id3-params ] unit-test [ "Anthem of the Trinity" @@ -29,7 +29,7 @@ IN: id3.tests f f "Classical" -] [ "vocab:id3/tests/blah2.mp3" file-id3-tags id3-params ] unit-test +] [ "vocab:id3/tests/blah2.mp3" mp3>id3 id3-params ] unit-test [ "Stormy Weather" @@ -38,5 +38,5 @@ IN: id3.tests f "eng, AG# 08E1C12E" "Big Band" -] [ "vocab:id3/tests/blah3.mp3" file-id3-tags id3-params ] unit-test +] [ "vocab:id3/tests/blah3.mp3" mp3>id3 id3-params ] unit-test diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 3def293771..8e824d689f 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -48,15 +48,14 @@ TUPLE: id3v2-info header frames ; TUPLE: id3v1-info title artist album year comment genre ; -: ( -- object ) id3v1-info new ; +: ( -- object ) id3v1-info new ; inline : ( header frames -- object ) - [ [ frame-id>> ] keep ] H{ } map>assoc - id3v2-info boa ; + [ [ frame-id>> ] keep ] H{ } map>assoc id3v2-info boa ; -:
( -- object ) header new ; +:
( -- object ) header new ; inline -: ( -- object ) frame new ; +: ( -- object ) frame new ; inline : id3v2? ( mmap -- ? ) "ID3" head? ; inline @@ -66,7 +65,7 @@ TUPLE: id3v1-info title artist album year comment genre ; : id3v1-frame ( string key -- frame ) swap >>frame-id - swap >>data ; + swap >>data ; inline : id3v1>id3v2 ( id3v1 -- id3v2 ) [ @@ -78,7 +77,7 @@ TUPLE: id3v1-info title artist album year comment genre ; [ comment>> "COMM" id3v1-frame ] [ genre>> "TCON" id3v1-frame ] } cleave - ] output>array f swap ; + ] output>array f swap ; inline : >28bitword ( seq -- int ) 0 [ [ 7 shift ] dip bitor ] reduce ; inline @@ -104,11 +103,11 @@ TUPLE: id3v1-info title artist album year comment genre ; [ [ 4 8 ] dip subseq >28bitword >>size ] [ [ 8 10 ] dip subseq >byte-array >>flags ] [ read-frame-data decode-text >>data ] - } cleave ; + } cleave ; inline : read-frame ( mmap -- frame/f ) dup 4 head-slice valid-frame-id? - [ (read-frame) ] [ drop f ] if ; + [ (read-frame) ] [ drop f ] if ; inline : remove-frame ( mmap frame -- mmap ) size>> 10 + tail-slice ; inline @@ -116,10 +115,8 @@ TUPLE: id3v1-info title artist album year comment genre ; : read-frames ( mmap -- frames ) [ dup read-frame dup ] [ [ remove-frame ] keep ] - produce 2nip ; + produce 2nip ; inline -! header stuff - : read-v2-header ( seq -- id3header ) [
] dip { @@ -133,8 +130,6 @@ TUPLE: id3v1-info title artist album year comment genre ; [ read-v2-header ] [ read-frames ] bi* ; inline -! v1 information - : skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline : (read-v1-tag-data) ( seq -- mp3-file ) @@ -159,28 +154,7 @@ TUPLE: id3v1-info title artist album year comment genre ; drop ] if ; inline -PRIVATE> - -: frame-named ( id3 name quot -- obj ) - [ swap frames>> at* ] dip - [ data>> ] prepose [ drop f ] if ; inline - -: id3-title ( id3 -- title/f ) "TIT2" [ ] frame-named ; inline - -: id3-artist ( id3 -- artist/f ) "TPE1" [ ] frame-named ; inline - -: id3-album ( id3 -- album/f ) "TALB" [ ] frame-named ; inline - -: id3-year ( id3 -- year/f ) "TYER" [ ] frame-named ; inline - -: id3-comment ( id3 -- comment/f ) "COMM" [ ] frame-named ; inline - -: id3-genre ( id3 -- genre/f ) - "TCON" [ parse-genre ] frame-named ; inline - -: id3-frame ( id3 key -- value/f ) [ ] frame-named ; inline - -: (file-id3-tags) ( path -- id3v2-info/f ) +: (mp3>id3) ( path -- id3v2-info/f ) [ { { [ dup id3v2? ] [ read-v2-tag-data ] } @@ -189,9 +163,36 @@ PRIVATE> } cond ] with-mapped-uchar-file ; -: file-id3-tags ( path -- id3v2-info/f ) - dup file-info size>> 0 <= [ drop f ] [ (file-id3-tags) ] if ; +: (find-id3-frame) ( id3 name quot: ( obj -- obj' ) -- obj' ) + [ swap frames>> at* ] dip + [ data>> ] prepose [ drop f ] if ; inline -: parse-id3s ( path -- seq ) - [ >lower ".mp3" tail? ] find-all-files - [ dup file-id3-tags ] { } map>assoc ; +PRIVATE> + +: mp3>id3 ( path -- id3v2-info/f ) + dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; inline + +: find-id3-frame ( id3 name -- obj/f ) + [ ] (find-id3-frame) ; inline + +: title ( id3 -- title/f ) "TIT2" find-id3-frame ; inline + +: artist ( id3 -- artist/f ) "TPE1" find-id3-frame ; inline + +: album ( id3 -- album/f ) "TALB" find-id3-frame ; inline + +: year ( id3 -- year/f ) "TYER" find-id3-frame ; inline + +: comment ( id3 -- comment/f ) "COMM" find-id3-frame ; inline + +: genre ( id3 -- genre/f ) + "TCON" [ parse-genre ] (find-id3-frame) ; inline + +: find-mp3s ( path -- seq ) + [ >lower ".mp3" tail? ] find-all-files ; inline + +: mp3-paths>id3s ( seq -- seq' ) + [ dup mp3>id3 ] { } map>assoc ; inline + +: parse-mp3-directory ( path -- seq ) + find-mp3s mp3-paths>id3s ; diff --git a/extra/math/matrices/matrices-tests.factor b/extra/math/matrices/matrices-tests.factor index 6f87109ba0..20942356de 100644 --- a/extra/math/matrices/matrices-tests.factor +++ b/extra/math/matrices/matrices-tests.factor @@ -104,3 +104,6 @@ USING: math.matrices math.vectors tools.test math ; [ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test [ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test + +[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ] +[ { 1 2 } { "a" "b" } cross-zip ] unit-test \ No newline at end of file diff --git a/extra/math/matrices/matrices.factor b/extra/math/matrices/matrices.factor index 0088b17372..7c687d753d 100755 --- a/extra/math/matrices/matrices.factor +++ b/extra/math/matrices/matrices.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math math.order math.vectors sequences ; IN: math.matrices @@ -57,3 +57,6 @@ PRIVATE> : norm-gram-schmidt ( seq -- orthonormal ) gram-schmidt [ normalize ] map ; + +: cross-zip ( seq1 seq2 -- seq1xseq2 ) + [ [ 2array ] with map ] curry map ; \ No newline at end of file diff --git a/extra/tetris/gl/gl.factor b/extra/tetris/gl/gl.factor index f8c901ff56..d1f398994e 100644 --- a/extra/tetris/gl/gl.factor +++ b/extra/tetris/gl/gl.factor @@ -8,7 +8,7 @@ IN: tetris.gl #! OpenGL rendering for tetris : draw-block ( block -- ) - [ { 1 1 } gl-fill-rect ] with-translation ; + { 1 1 } gl-fill-rect ; : draw-piece-blocks ( piece -- ) piece-blocks [ draw-block ] each ; diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor index d7301ca042..aa98793c70 100644 --- a/extra/ui/gadgets/lists/lists.factor +++ b/extra/ui/gadgets/lists/lists.factor @@ -57,9 +57,7 @@ M: list draw-gadget* origin get [ dup color>> gl-color selected-rect [ - dup loc>> [ - dim>> gl-fill-rect - ] with-translation + rect-bounds gl-fill-rect ] when* ] with-translation ; diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index bca48ce260..6bdc449dc8 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -20,7 +20,7 @@ - + @@ -58,7 +58,7 @@ - + diff --git a/vm/Config.linux.x86.64 b/vm/Config.linux.x86.64 index a02fcb4d6d..bfd1222496 100644 --- a/vm/Config.linux.x86.64 +++ b/vm/Config.linux.x86.64 @@ -1,4 +1,3 @@ include vm/Config.linux include vm/Config.x86.64 LIBPATH = -L/usr/X11R6/lib64 -L/usr/X11R6/lib -FFI_TEST_CFLAGS = -fPIC diff --git a/vm/Config.macosx b/vm/Config.macosx index 6655d548b7..98d14cfdf4 100644 --- a/vm/Config.macosx +++ b/vm/Config.macosx @@ -4,6 +4,7 @@ CFLAGS += -fPIC PLAF_DLL_OBJS += vm/os-macosx.o vm/mach_signal.o DLL_EXTENSION = .dylib +SHARED_DLL_EXTENSION = .dylib SHARED_FLAG = -dynamiclib diff --git a/vm/Config.unix b/vm/Config.unix index 8f2f140247..339c3c3ffb 100644 --- a/vm/Config.unix +++ b/vm/Config.unix @@ -5,7 +5,7 @@ endif EXE_SUFFIX = DLL_PREFIX = lib DLL_EXTENSION = .a -# DLL_EXTENSION = .so +SHARED_DLL_EXTENSION = .so SHARED_FLAG = -shared PLAF_DLL_OBJS = vm/os-unix.o diff --git a/vm/Config.windows b/vm/Config.windows index 75452a9bb4..cdb72f4e24 100644 --- a/vm/Config.windows +++ b/vm/Config.windows @@ -5,5 +5,6 @@ SHARED_FLAG = -shared EXE_EXTENSION=.exe CONSOLE_EXTENSION=.com DLL_EXTENSION=.dll +SHARED_DLL_EXTENSION=.dll LINKER = $(CC) -shared -mno-cygwin -o LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX) diff --git a/vm/alien.c b/vm/alien.c index 8b7df45e9a..2681579c5d 100755 --- a/vm/alien.c +++ b/vm/alien.c @@ -160,7 +160,7 @@ void box_value_struct(void *src, CELL size) dpush(tag_object(array)); } -/* On OS X, structs <= 8 bytes are returned in registers. */ +/* On some x86 OSes, structs <= 8 bytes are returned in registers. */ void box_small_struct(CELL x, CELL y, CELL size) { CELL data[2]; @@ -169,6 +169,17 @@ void box_small_struct(CELL x, CELL y, CELL size) box_value_struct(data,size); } +/* On OS X/PPC, complex numbers are returned in registers. */ +void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size) +{ + CELL data[4]; + data[0] = x1; + data[1] = x2; + data[2] = x3; + data[3] = x4; + box_value_struct(data,size); +} + /* open a native library and push a handle */ void primitive_dlopen(void) { diff --git a/vm/alien.h b/vm/alien.h index ec1eb08acf..dc76d49810 100755 --- a/vm/alien.h +++ b/vm/alien.h @@ -40,6 +40,7 @@ void primitive_set_alien_cell(void); DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size); DLLEXPORT void box_value_struct(void *src, CELL size); DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size); +void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size); DEFINE_UNTAG(F_DLL,DLL_TYPE,dll) diff --git a/vm/code_block.c b/vm/code_block.c index a9b5277c84..c6ecb2f431 100644 --- a/vm/code_block.c +++ b/vm/code_block.c @@ -195,8 +195,6 @@ void mark_code_block(F_CODE_BLOCK *compiled) copy_handle(&compiled->literals); copy_handle(&compiled->relocation); - - flush_icache_for(compiled); } void mark_stack_frame_step(F_STACK_FRAME *frame)