From 0069547e908daf030ae1d493995b9fa4073f5993 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Tue, 3 Feb 2009 00:33:04 +0100 Subject: [PATCH 01/60] Fix suboptimal prime number factoring --- basis/math/primes/factors/factors-tests.factor | 1 + basis/math/primes/factors/factors.factor | 6 +++++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/basis/math/primes/factors/factors-tests.factor b/basis/math/primes/factors/factors-tests.factor index f247683c1c..983de51216 100644 --- a/basis/math/primes/factors/factors-tests.factor +++ b/basis/math/primes/factors/factors-tests.factor @@ -6,3 +6,4 @@ USING: math.primes.factors tools.test ; { { 999983 1000003 } } [ 999969000187000867 unique-factors ] unit-test { 999967000236000612 } [ 999969000187000867 totient ] unit-test { 0 } [ 1 totient ] unit-test +{ { 425612003 } } [ 425612003 factors ] unit-test diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor index 05d6b26010..4c36fc0a85 100644 --- a/basis/math/primes/factors/factors.factor +++ b/basis/math/primes/factors/factors.factor @@ -16,7 +16,11 @@ IN: math.primes.factors PRIVATE> : group-factors ( n -- seq ) - [ 2 [ over 1 > ] [ write-factor next-prime ] [ ] while 2drop ] { } make ; + [ + 2 + [ 2dup sq < ] [ write-factor next-prime ] [ ] until + drop dup 2 < [ drop ] [ 1 2array , ] if + ] { } make ; : unique-factors ( n -- seq ) group-factors [ first ] map ; From a1f4f7772f988f7fd0cf84598a378747807acb01 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 5 Feb 2009 23:59:36 -0600 Subject: [PATCH 02/60] make multipart work with sessions --- basis/mime/multipart/multipart.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor index fc3024bd01..eda7849a73 100755 --- a/basis/mime/multipart/multipart.factor +++ b/basis/mime/multipart/multipart.factor @@ -99,7 +99,7 @@ ERROR: end-of-stream multipart ; dup name>> empty-name? [ drop ] [ - [ [ header>> ] [ name>> unquote ] [ name-content>> ] tri mime-variable boa ] + [ name-content>> ] [ name>> unquote ] [ mime-parts>> set-at ] tri ] if ; From f31e19a66669c1c280858755a3a483eededd7490 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 00:01:28 -0600 Subject: [PATCH 03/60] refactoring graphics.bitmap --- extra/graphics/bitmap/bitmap-tests.factor | 15 +++ extra/graphics/bitmap/bitmap.factor | 155 +++++++++------------- extra/graphics/viewer/viewer.factor | 33 ++++- 3 files changed, 108 insertions(+), 95 deletions(-) create mode 100644 extra/graphics/bitmap/bitmap-tests.factor diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor new file mode 100644 index 0000000000..4998427b22 --- /dev/null +++ b/extra/graphics/bitmap/bitmap-tests.factor @@ -0,0 +1,15 @@ +USING: graphics.bitmap ; +IN: graphics.bitmap.tests + +: test-bitmap24 ( -- ) + "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ; + +: test-bitmap8 ( -- ) + "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ; + +: test-bitmap4 ( -- ) + "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ; + +: test-bitmap1 ( -- ) + "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ; + diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index a0212e47de..bd34a9ee41 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays byte-arrays combinators summary -graphics.viewer io io.binary io.files kernel libc math +io io.binary io.files kernel libc math math.functions math.bitwise namespaces opengl opengl.gl prettyprint sequences strings ui ui.gadgets.panes fry io.encodings.binary accessors grouping macros alien.c-types ; @@ -12,10 +12,11 @@ IN: graphics.bitmap ! Handles row-reversed bitmaps (their height is negative) TUPLE: bitmap magic size reserved offset header-length width - height planes bit-count compression size-image - x-pels y-pels color-used color-important rgb-quads color-index array ; +height planes bit-count compression size-image +x-pels y-pels color-used color-important rgb-quads color-index +array ; -: (array-copy) ( bitmap array -- bitmap array' ) +: array-copy ( bitmap array -- bitmap array' ) over size-image>> abs memory>byte-array ; MACRO: (nbits>bitmap) ( bits -- ) @@ -24,7 +25,7 @@ MACRO: (nbits>bitmap) ( bits -- ) 2over * _ * >>size-image swap >>height swap >>width - swap (array-copy) [ >>array ] [ >>color-index ] bi + swap array-copy [ >>array ] [ >>color-index ] bi _ >>bit-count ] ; @@ -45,7 +46,7 @@ MACRO: (nbits>bitmap) ( bits -- ) : raw-bitmap>array ( bitmap -- array ) dup bit-count>> { - { 32 [ "32bit" throw ] } + { 32 [ color-index>> ] } { 24 [ color-index>> ] } { 16 [ "16bit" throw ] } { 8 [ 8bit>array ] } @@ -59,107 +60,75 @@ ERROR: bitmap-magic ; M: bitmap-magic summary drop "First two bytes of bitmap stream must be 'BM'" ; -: parse-file-header ( bitmap -- ) - 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic - 4 read le> >>size - 4 read le> >>reserved - 4 read le> >>offset drop ; +: read2 ( -- n ) 2 read le> ; +: read4 ( -- n ) 4 read le> ; -: parse-bitmap-header ( bitmap -- ) - 4 read le> >>header-length - 4 read signed-le> >>width - 4 read signed-le> >>height - 2 read le> >>planes - 2 read le> >>bit-count - 4 read le> >>compression - 4 read le> >>size-image - 4 read le> >>x-pels - 4 read le> >>y-pels - 4 read le> >>color-used - 4 read le> >>color-important drop ; +: parse-file-header ( bitmap -- bitmap ) + 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic + read4 >>size + read4 >>reserved + read4 >>offset ; + +: parse-bitmap-header ( bitmap -- bitmap ) + read4 >>header-length + read4 >>width + read4 >>height + read2 >>planes + read2 >>bit-count + read4 >>compression + read4 >>size-image + read4 >>x-pels + read4 >>y-pels + read4 >>color-used + read4 >>color-important ; : rgb-quads-length ( bitmap -- n ) - [ offset>> 14 - ] keep header-length>> - ; + [ offset>> 14 - ] [ header-length>> ] bi - ; : color-index-length ( bitmap -- n ) - [ width>> ] keep [ planes>> * ] keep - [ bit-count>> * 31 + 32 /i 4 * ] keep - height>> abs * ; + { + [ width>> ] + [ planes>> * ] + [ bit-count>> * 31 + 32 /i 4 * ] + [ height>> abs * ] + } cleave ; -: parse-bitmap ( bitmap -- ) +: parse-bitmap ( bitmap -- bitmap ) dup rgb-quads-length read >>rgb-quads - dup color-index-length read >>color-index drop ; + dup color-index-length read >>color-index ; : load-bitmap ( path -- bitmap ) binary [ bitmap new - dup parse-file-header - dup parse-bitmap-header - dup parse-bitmap + parse-file-header parse-bitmap-header parse-bitmap ] with-file-reader dup raw-bitmap>array >>array ; +: write2 ( n -- ) 2 >le write ; +: write4 ( n -- ) 4 >le write ; + : save-bitmap ( bitmap path -- ) binary [ - "BM" >byte-array write - dup array>> length 14 + 40 + 4 >le write - 0 4 >le write - 54 4 >le write - - 40 4 >le write - { - [ width>> 4 >le write ] - [ height>> 4 >le write ] - [ planes>> 1 or 2 >le write ] - [ bit-count>> 24 or 2 >le write ] - [ compression>> 0 or 4 >le write ] - [ size-image>> 4 >le write ] - [ x-pels>> 0 or 4 >le write ] - [ y-pels>> 0 or 4 >le write ] - [ color-used>> 0 or 4 >le write ] - [ color-important>> 0 or 4 >le write ] - [ rgb-quads>> write ] - [ color-index>> write ] - } cleave + B{ CHAR: B CHAR: M } write + [ + array>> length 14 + 40 + write4 + 0 write4 + 54 write4 + 40 write4 + ] [ + { + [ width>> write4 ] + [ height>> write4 ] + [ planes>> 1 or write2 ] + [ bit-count>> 24 or write2 ] + [ compression>> 0 or write4 ] + [ size-image>> write4 ] + [ x-pels>> 0 or write4 ] + [ y-pels>> 0 or write4 ] + [ color-used>> 0 or write4 ] + [ color-important>> 0 or write4 ] + [ rgb-quads>> write ] + [ color-index>> write ] + } cleave + ] bi ] with-file-writer ; - -M: bitmap draw-image ( bitmap -- ) - dup height>> 0 < [ - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - ] [ - 0 over height>> abs glRasterPos2i - 1.0 1.0 glPixelZoom - ] if - [ width>> ] keep - [ - [ height>> abs ] keep - bit-count>> { - { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } - { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } - } case - ] keep array>> glDrawPixels ; - -M: bitmap width ( bitmap -- ) width>> ; -M: bitmap height ( bitmap -- ) height>> ; - -: bitmap. ( path -- ) - load-bitmap gadget. ; - -: bitmap-window ( path -- gadget ) - load-bitmap [ "bitmap" open-window ] keep ; - -: test-bitmap24 ( -- ) - "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ; - -: test-bitmap8 ( -- ) - "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ; - -: test-bitmap4 ( -- ) - "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ; - -: test-bitmap1 ( -- ) - "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ; - diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor index 0533ffaf5d..8e0b1ec43c 100644 --- a/extra/graphics/viewer/viewer.factor +++ b/extra/graphics/viewer/viewer.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.functions namespaces opengl -ui.gadgets ui.render accessors ; +USING: accessors arrays combinators graphics.bitmap kernel math +math.functions namespaces opengl opengl.gl ui ui.gadgets +ui.gadgets.panes ui.render ; IN: graphics.viewer TUPLE: graphics-gadget < gadget image ; @@ -19,3 +20,31 @@ M: graphics-gadget draw-gadget* ( gadget -- ) : ( bitmap -- gadget ) \ graphics-gadget new-gadget swap >>image ; + +M: bitmap draw-image ( bitmap -- ) + dup height>> 0 < [ + 0 0 glRasterPos2i + 1.0 -1.0 glPixelZoom + ] [ + 0 over height>> abs glRasterPos2i + 1.0 1.0 glPixelZoom + ] if + [ width>> ] keep + [ + [ height>> abs ] keep + bit-count>> { + { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } + { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } + } case + ] keep array>> glDrawPixels ; + +M: bitmap width ( bitmap -- ) width>> ; +M: bitmap height ( bitmap -- ) height>> ; + +: bitmap. ( path -- ) + load-bitmap gadget. ; + +: bitmap-window ( path -- gadget ) + load-bitmap [ "bitmap" open-window ] keep ; From 4adef7db09688f341283c2081b87faa0cd4b40da Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 02:45:21 -0600 Subject: [PATCH 04/60] Fix functors bug where changing a hand-written method into one generated by a functor would forget the method; also associate functor-generated methods with the source file they're in. Add DEFINES-CLASS, to parallel DEFINES. Update math.blas and specialized-arrays/vectors to use DEFINES-CLASS where appropriate --- basis/functors/functors-tests.factor | 51 +++++++++++++++++-- basis/functors/functors.factor | 11 ++-- basis/math/blas/matrices/matrices.factor | 2 +- basis/math/blas/vectors/vectors.factor | 2 +- .../direct/functor/functor.factor | 2 +- .../specialized-arrays/functor/functor.factor | 2 +- .../functor/functor.factor | 2 +- 7 files changed, 60 insertions(+), 12 deletions(-) diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index a5f3042b38..df008d52bd 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -1,11 +1,12 @@ IN: functors.tests -USING: functors tools.test math words kernel ; +USING: functors tools.test math words kernel multiline parser +io.streams.string generic ; << FUNCTOR: define-box ( T -- ) -B DEFINES ${T}-box +B DEFINES-CLASS ${T}-box DEFINES <${B}> WHERE @@ -62,4 +63,48 @@ WHERE >> -[ 4 ] [ 1 3 blah ] unit-test \ No newline at end of file +[ 4 ] [ 1 3 blah ] unit-test + +GENERIC: some-generic ( a -- b ) + +! Does replacing an ordinary word with a functor-generated one work? +[ [ ] ] [ + <" IN: functors.tests + + TUPLE: some-tuple ; + : some-word ( -- ) ; + M: some-tuple some-generic ; + "> "functors-test" parse-stream +] unit-test + +: test-redefinition ( -- ) + [ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test + [ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test + [ t ] [ + "some-tuple" "functors.tests" lookup + "some-generic" "functors.tests" lookup method >boolean + ] unit-test ; + +test-redefinition + +FUNCTOR: redefine-test ( W -- ) + +W-word DEFINES ${W}-word +W-tuple DEFINES-CLASS ${W}-tuple +W-generic IS ${W}-generic + +WHERE + +TUPLE: W-tuple ; +: W-word ( -- ) ; +M: W-tuple W-generic ; + +;FUNCTOR + +[ [ ] ] [ + <" IN: functors.tests + << "some" redefine-test >> + "> "functors-test" parse-stream +] unit-test + +test-redefinition \ No newline at end of file diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index f4d35b6932..14151692f0 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -3,8 +3,9 @@ USING: kernel quotations classes.tuple make combinators generic words interpolate namespaces sequences io.streams.string fry classes.mixin effects lexer parser classes.tuple.parser -effects.parser locals.types locals.parser -locals.rewrite.closures vocabs.parser arrays accessors ; +effects.parser locals.types locals.parser generic.parser +locals.rewrite.closures vocabs.parser classes.parser +arrays accessors ; IN: functors ! This is a hack @@ -29,7 +30,7 @@ M: object >fake-quotations ; GENERIC: fake-quotations> ( fake -- quot ) M: fake-quotation fake-quotations> - seq>> [ fake-quotations> ] map >quotation ; + seq>> [ fake-quotations> ] [ ] map-as ; M: array fake-quotations> [ fake-quotations> ] map ; @@ -57,7 +58,7 @@ M: object fake-quotations> ; effect off scan-param parsed scan-param parsed - \ create-method parsed + \ create-method-in parsed parse-definition* DEFINE* ; parsing @@ -96,6 +97,8 @@ PRIVATE> : DEFINES [ create-in ] (INTERPOLATE) ; parsing +: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; parsing + DEFER: ;FUNCTOR delimiter DEFINES <${TYPE}-blas-matrix> >MATRIX DEFINES >${TYPE}-blas-matrix XMATRIX{ DEFINES ${T}matrix{ diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 3b7f89f730..4e61f4478e 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -134,7 +134,7 @@ XCOPY IS cblas_${T}copy XSWAP IS cblas_${T}swap IXAMAX IS cblas_i${T}amax -VECTOR DEFINES ${TYPE}-blas-vector +VECTOR DEFINES-CLASS ${TYPE}-blas-vector DEFINES <${TYPE}-blas-vector> >VECTOR DEFINES >${TYPE}-blas-vector diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index ce23186fc6..0c3999db44 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -11,7 +11,7 @@ A' IS ${T}-array >A' IS >${T}-array IS <${A'}> -A DEFINES direct-${T}-array +A DEFINES-CLASS direct-${T}-array DEFINES <${A}> NTH [ T dup c-getter array-accessor ] diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 9a56346be4..3c2c53db31 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -15,7 +15,7 @@ M: bad-byte-array-length summary FUNCTOR: define-array ( T -- ) -A DEFINES ${T}-array +A DEFINES-CLASS ${T}-array DEFINES <${A}> (A) DEFINES (${A}) >A DEFINES >${A} diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index 2410cc284e..9d48a9e79e 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -9,7 +9,7 @@ FUNCTOR: define-vector ( T -- ) A IS ${T}-array IS <${A}> -V DEFINES ${T}-vector +V DEFINES-CLASS ${T}-vector DEFINES <${V}> >V DEFINES >${V} V{ DEFINES ${V}{ From 7bb0e78314e21b1094cbbc3aaa1cd766f5100e0e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:02:00 -0600 Subject: [PATCH 05/60] Add support for C99 complex float and complex double types to FFI They are named complex-float and complex-double in the Factor world --- basis/alien/arrays/arrays.factor | 17 ++++++++--------- basis/alien/c-types/c-types-docs.factor | 2 ++ basis/alien/structs/structs.factor | 11 +++++++++-- basis/compiler/codegen/codegen.factor | 4 ++-- basis/compiler/tests/alien.factor | 7 +++++++ vm/ffi_test.c | 6 +++++- vm/ffi_test.h | 2 ++ vm/master.h | 1 + 8 files changed, 36 insertions(+), 14 deletions(-) diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 727492edb1..c823b614d9 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays alien.c-types alien.structs -sequences math kernel namespaces make libc cpu.architecture ; +sequences math kernel namespaces fry libc cpu.architecture ; IN: alien.arrays UNION: value-type array struct-type ; @@ -10,7 +10,7 @@ M: array c-type ; M: array c-type-class drop object ; -M: array heap-size unclip heap-size [ * ] reduce ; +M: array heap-size unclip [ product ] [ heap-size ] bi* * ; M: array c-type-align first c-type-align ; @@ -26,16 +26,15 @@ M: array box-return drop "void*" box-return ; M: array stack-size drop "void*" stack-size ; +M: array c-type-boxer-quot drop f ; + +M: array c-type-unboxer-quot drop f ; + M: value-type c-type-reg-class drop int-regs ; -M: value-type c-type-boxer-quot drop f ; - -M: value-type c-type-unboxer-quot drop f ; - M: value-type c-type-getter drop [ swap ] ; M: value-type c-type-setter ( type -- quot ) - [ - dup c-type-getter % \ swap , heap-size , \ memcpy , - ] [ ] make ; + [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri + '[ @ swap @ _ memcpy ] ; diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index a2b555b057..dc29ea9bb3 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -178,6 +178,8 @@ $nl { { $snippet "ulonglong" } { } } { { $snippet "float" } { } } { { $snippet "double" } { "same format as " { $link float } " objects" } } + { { $snippet "complex-float" } { "C99 " { $snippet "complex float" } " type, converted to and from " { $link complex } " values" } } + { { $snippet "complex-double" } { "C99 " { $snippet "complex double" } " type, converted to and from " { $link complex } " values" } } } "When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." $nl diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 42923fb28b..d9ed53d0c6 100644 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -5,7 +5,7 @@ math namespaces parser sequences strings words libc fry alien.c-types alien.structs.fields cpu.architecture math.order ; IN: alien.structs -TUPLE: struct-type size align fields ; +TUPLE: struct-type size align fields boxer-quot unboxer-quot getter setter ; M: struct-type heap-size size>> ; @@ -15,6 +15,10 @@ M: struct-type c-type-align align>> ; M: struct-type c-type-stack-align? drop f ; +M: struct-type c-type-boxer-quot boxer-quot>> ; + +M: struct-type c-type-unboxer-quot unboxer-quot>> ; + : if-value-struct ( ctype true false -- ) [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline @@ -40,7 +44,10 @@ M: struct-type stack-size : (define-struct) ( name size align fields -- ) [ [ align ] keep ] dip - struct-type boa + struct-type new + swap >>fields + swap >>align + swap >>size swap typedef ; : make-fields ( name vocab fields -- fields ) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 71d9c36412..d915b29ae5 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -3,8 +3,8 @@ USING: namespaces make math math.order math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs -alien.strings alien.arrays sets libc continuations.private -fry cpu.architecture +alien.strings alien.arrays alien.complex sets libc +continuations.private fry cpu.architecture compiler.errors compiler.alien compiler.cfg diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 1b21e40bac..b1a9853d55 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -558,3 +558,10 @@ FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ; [ ] [ stack-frame-bustage 2drop ] unit-test + +FUNCTION: complex-float ffi_test_45 ( complex-float x, complex-double y ) ; + +[ C{ 4.0 4.0 } ] [ + C{ 1.0 2.0 } + C{ 1.5 1.0 } ffi_test_45 +] unit-test \ No newline at end of file diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 1ec41ac2b9..36147795d1 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -1,6 +1,5 @@ /* This file is linked into the runtime for the sole purpose * of testing FFI code. */ -#include #include "master.h" #include "ffi_test.h" @@ -303,3 +302,8 @@ struct test_struct_14 ffi_test_44(void) retval.x2 = 2.0; return retval; } + +complex float ffi_test_45(complex float x, complex double y) +{ + return x + 2 * y; +} diff --git a/vm/ffi_test.h b/vm/ffi_test.h index 7c51261157..de48d6dc5b 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -88,3 +88,5 @@ struct test_struct_16 { float x; int a; }; DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a); DLLEXPORT struct test_struct_14 ffi_test_44(); + +complex float ffi_test_45(complex float x, complex double y); diff --git a/vm/master.h b/vm/master.h index 86b5223eaa..01b2335841 100644 --- a/vm/master.h +++ b/vm/master.h @@ -8,6 +8,7 @@ #include #include #include +#include #include #include From 7ffbbb13e0ffc533ab7086966cbca975f4f2866d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:36:17 -0600 Subject: [PATCH 06/60] Specialized arrays can now be passed to alien functions directly, without calling underlying>> first --- basis/alien/arrays/arrays.factor | 2 +- basis/alien/c-types/c-types.factor | 9 +++++---- core/alien/alien.factor | 10 +++++++++- 3 files changed, 15 insertions(+), 6 deletions(-) diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index c823b614d9..8253d9458c 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -28,7 +28,7 @@ M: array stack-size drop "void*" stack-size ; M: array c-type-boxer-quot drop f ; -M: array c-type-unboxer-quot drop f ; +M: array c-type-unboxer-quot drop [ >c-ptr ] ; M: value-type c-type-reg-class drop int-regs ; diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index d1354cb04e..ff9d4cefc4 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -201,13 +201,13 @@ M: byte-array byte-length length ; 1 swap malloc-array ; inline : malloc-byte-array ( byte-array -- alien ) - dup length [ nip malloc dup ] 2keep memcpy ; + dup byte-length [ nip malloc dup ] 2keep memcpy ; : memory>byte-array ( alien len -- byte-array ) [ nip (byte-array) dup ] 2keep memcpy ; : byte-array>memory ( byte-array base -- ) - swap dup length memcpy ; + swap dup byte-length memcpy ; : array-accessor ( type quot -- def ) [ @@ -263,7 +263,7 @@ M: long-long-type box-return ( type -- ) ] when ; : malloc-file-contents ( path -- alien len ) - binary file-contents dup malloc-byte-array swap length ; + binary file-contents [ malloc-byte-array ] [ length ] bi ; : if-void ( type true false -- ) pick "void" = [ drop nip call ] [ nip call ] if ; inline @@ -283,9 +283,10 @@ M: long-long-type box-return ( type -- ) c-ptr >>class [ alien-cell ] >>getter - [ set-alien-cell ] >>setter + [ [ >c-ptr ] 2dip set-alien-cell ] >>setter bootstrap-cell >>size bootstrap-cell >>align + [ >c-ptr ] >>unboxer-quot "box_alien" >>boxer "alien_offset" >>unboxer "void*" define-primitive-type diff --git a/core/alien/alien.factor b/core/alien/alien.factor index c97e36e889..93d1a8e306 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel math namespaces sequences system kernel.private byte-arrays arrays init ; @@ -18,6 +18,14 @@ PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ; UNION: pinned-c-ptr pinned-alien POSTPONE: f ; +GENERIC: >c-ptr ( obj -- c-ptr ) + +M: c-ptr >c-ptr ; + +SLOT: underlying + +M: object >c-ptr underlying>> ; + GENERIC: expired? ( c-ptr -- ? ) flushable M: alien expired? expired>> ; From d6aa376ed089ce44364ba47693ab32c7f60c9e28 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:37:28 -0600 Subject: [PATCH 07/60] Removing now-redundant underlying>> calls --- basis/cocoa/messages/messages.factor | 2 +- basis/cocoa/views/views.factor | 2 +- basis/compiler/tests/alien.factor | 4 ++-- basis/db/postgresql/lib/lib.factor | 6 +++--- basis/io/backend/unix/multiplexers/epoll/epoll.factor | 2 +- .../io/backend/unix/multiplexers/kqueue/kqueue.factor | 2 +- .../io/backend/unix/multiplexers/select/select.factor | 4 ++-- basis/io/launcher/windows/windows.factor | 4 ++-- basis/io/pipes/unix/unix.factor | 2 +- basis/libc/libc.factor | 4 ++-- basis/opengl/opengl.factor | 10 +++++----- basis/opengl/shaders/shaders.factor | 2 +- .../specialized-arrays/specialized-arrays-tests.factor | 7 ++++++- basis/struct-arrays/struct-arrays-tests.factor | 4 ++-- basis/unix/utilities/utilities.factor | 4 ++-- basis/windows/com/wrapper/wrapper.factor | 2 +- basis/windows/dinput/constants/constants.factor | 2 +- basis/x11/clipboard/clipboard.factor | 2 +- basis/x11/glx/glx.factor | 2 +- basis/x11/xim/xim.factor | 2 +- 20 files changed, 37 insertions(+), 32 deletions(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index ebe98a2df1..a0b0e89a0d 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -202,7 +202,7 @@ assoc-union alien>objc-types set-global [ 0 [ class_copyMethodList ] keep *uint ] dip over 0 = [ 3drop ] [ [ ] dip - [ each ] [ drop underlying>> (free) ] 2bi + [ each ] [ drop (free) ] 2bi ] if ; inline : register-objc-methods ( class -- ) diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index 03cafd0a0a..e74e912202 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -68,7 +68,7 @@ PRIVATE> NSOpenGLPFASamples , 8 , ] when 0 , - ] int-array{ } make underlying>> + ] int-array{ } make -> initWithAttributes: -> autorelease ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index b1a9853d55..b9c62f1429 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -198,8 +198,8 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; [ 32.0 ] [ - { 1.0 2.0 3.0 } >float-array underlying>> - { 4.0 5.0 6.0 } >float-array underlying>> + { 1.0 2.0 3.0 } >float-array + { 4.0 5.0 6.0 } >float-array ffi_test_23 ] unit-test diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor index 19cf5c5002..05114a4deb 100644 --- a/basis/db/postgresql/lib/lib.factor +++ b/basis/db/postgresql/lib/lib.factor @@ -65,7 +65,7 @@ M: postgresql-result-null summary ( obj -- str ) } case ; : param-types ( statement -- seq ) - in-params>> [ type>> type>oid ] uint-array{ } map-as underlying>> ; + in-params>> [ type>> type>oid ] uint-array{ } map-as ; : malloc-byte-array/length ( byte-array -- alien length ) [ malloc-byte-array &free ] [ length ] bi ; @@ -91,11 +91,11 @@ M: postgresql-result-null summary ( obj -- str ) ] 2map flip [ f f ] [ - first2 [ >void*-array underlying>> ] [ >uint-array underlying>> ] bi* + first2 [ >void*-array ] [ >uint-array ] bi* ] if-empty ; : param-formats ( statement -- seq ) - in-params>> [ type>> type>param-format ] uint-array{ } map-as underlying>> ; + in-params>> [ type>> type>param-format ] uint-array{ } map-as ; : do-postgresql-bound-statement ( statement -- res ) [ diff --git a/basis/io/backend/unix/multiplexers/epoll/epoll.factor b/basis/io/backend/unix/multiplexers/epoll/epoll.factor index a91f62f1df..e1428fee4d 100644 --- a/basis/io/backend/unix/multiplexers/epoll/epoll.factor +++ b/basis/io/backend/unix/multiplexers/epoll/epoll.factor @@ -51,7 +51,7 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq ) ] [ 2drop f ] if ; : wait-event ( mx us -- n ) - [ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi* + [ [ fd>> ] [ events>> ] bi dup length ] [ 1000 /i ] bi* epoll_wait multiplexer-error ; : handle-event ( event mx -- ) diff --git a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor index 2a6648981b..7bd157136a 100644 --- a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor +++ b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor @@ -59,7 +59,7 @@ M: kqueue-mx remove-output-callbacks ( fd mx -- seq ) : wait-kevent ( mx timespec -- n ) [ [ fd>> f 0 ] - [ events>> [ underlying>> ] [ length ] bi ] bi + [ events>> dup length ] bi ] dip kevent multiplexer-error ; : handle-kevent ( mx kevent -- ) diff --git a/basis/io/backend/unix/multiplexers/select/select.factor b/basis/io/backend/unix/multiplexers/select/select.factor index c62101e478..7d0acb4140 100644 --- a/basis/io/backend/unix/multiplexers/select/select.factor +++ b/basis/io/backend/unix/multiplexers/select/select.factor @@ -44,8 +44,8 @@ TUPLE: select-mx < mx read-fdset write-fdset ; : init-fdsets ( mx -- nfds read write except ) [ num-fds ] - [ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] - [ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri + [ read-fdset/tasks [ init-fdset ] keep ] + [ write-fdset/tasks [ init-fdset ] keep ] tri f ; M:: select-mx wait-for-events ( us mx -- ) diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index 0497754aa2..7de6c25a13 100755 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -103,7 +103,7 @@ TUPLE: CreateProcess-args over get-environment [ swap % "=" % % "\0" % ] assoc-each "\0" % - ] ushort-array{ } make underlying>> + ] ushort-array{ } make >>lpEnvironment ] when ; @@ -158,7 +158,7 @@ M: windows kill-process* ( handle -- ) M: windows wait-for-processes ( -- ? ) processes get keys dup [ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as - [ length ] [ underlying>> ] bi 0 0 + [ length ] keep 0 0 WaitForMultipleObjects dup HEX: ffffffff = [ win32-error ] when dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ; diff --git a/basis/io/pipes/unix/unix.factor b/basis/io/pipes/unix/unix.factor index 6a0015084b..f94733ca56 100644 --- a/basis/io/pipes/unix/unix.factor +++ b/basis/io/pipes/unix/unix.factor @@ -7,5 +7,5 @@ QUALIFIED: io.pipes M: unix io.pipes:(pipe) ( -- pair ) 2 - [ underlying>> pipe io-error ] + [ pipe io-error ] [ first2 [ init-fd ] bi@ io.pipes:pipe boa ] bi ; diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index c4d351e6a0..1e751833a2 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -75,14 +75,14 @@ PRIVATE> dup add-malloc ; : realloc ( alien size -- newalien ) + [ >c-ptr ] dip over malloc-exists? [ realloc-error ] unless dupd (realloc) check-ptr swap delete-malloc dup add-malloc ; : free ( alien -- ) - dup delete-malloc - (free) ; + >c-ptr [ delete-malloc ] [ (free) ] bi ; : memcpy ( dst src size -- ) "void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ; diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index f5868ee7a1..6d9ac95965 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -53,16 +53,16 @@ MACRO: all-enabled-client-state ( seq quot -- ) glMatrixMode glPopMatrix ; inline : gl-material ( face pname params -- ) - float-array{ } like underlying>> glMaterialfv ; + float-array{ } like glMaterialfv ; : gl-vertex-pointer ( seq -- ) - [ 2 GL_FLOAT 0 ] dip underlying>> glVertexPointer ; inline + [ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline : gl-color-pointer ( seq -- ) - [ 4 GL_FLOAT 0 ] dip underlying>> glColorPointer ; inline + [ 4 GL_FLOAT 0 ] dip glColorPointer ; inline : gl-texture-coord-pointer ( seq -- ) - [ 2 GL_FLOAT 0 ] dip underlying>> glTexCoordPointer ; inline + [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline : line-vertices ( a b -- ) [ first2 [ 0.5 + ] bi@ ] bi@ 4 float-array{ } nsequence @@ -177,7 +177,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) glActiveTexture swap glBindTexture gl-error ; : (set-draw-buffers) ( buffers -- ) - [ length ] [ >uint-array underlying>> ] bi glDrawBuffers ; + [ length ] [ >uint-array ] bi glDrawBuffers ; MACRO: set-draw-buffers ( buffers -- ) words>values [ (set-draw-buffers) ] curry ; diff --git a/basis/opengl/shaders/shaders.factor b/basis/opengl/shaders/shaders.factor index eb5bbb0ee8..a77d29da2f 100755 --- a/basis/opengl/shaders/shaders.factor +++ b/basis/opengl/shaders/shaders.factor @@ -96,7 +96,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; dup gl-program-shaders-length 0 over - [ underlying>> glGetAttachedShaders ] keep ; + [ glGetAttachedShaders ] keep ; : delete-gl-program-only ( program -- ) glDeleteProgram ; inline diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index 1ca041191e..73e719b806 100644 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -1,7 +1,8 @@ IN: specialized-arrays.tests USING: tools.test specialized-arrays sequences specialized-arrays.int specialized-arrays.bool -specialized-arrays.ushort alien.c-types accessors kernel ; +specialized-arrays.ushort alien.c-types accessors kernel +specialized-arrays.direct.int arrays ; [ t ] [ { 1 2 3 } >int-array int-array? ] unit-test @@ -16,3 +17,7 @@ specialized-arrays.ushort alien.c-types accessors kernel ; ] unit-test [ B{ 210 4 1 } byte-array>ushort-array ] must-fail + +[ { 3 1 3 3 7 } ] [ + int-array{ 3 1 3 3 7 } malloc-byte-array 5 >array +] unit-test \ No newline at end of file diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor index 6f77e66cd2..a8ce98888c 100755 --- a/basis/struct-arrays/struct-arrays-tests.factor +++ b/basis/struct-arrays/struct-arrays-tests.factor @@ -22,7 +22,7 @@ C-STRUCT: test-struct [ 5/4 ] [ [ 2 "test-struct" malloc-struct-array - dup underlying>> &free drop + dup &free drop 1 2 make-point over set-first 3 4 make-point over set-second 0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce @@ -34,6 +34,6 @@ C-STRUCT: test-struct [ ] [ [ 10 "test-struct" malloc-struct-array - underlying>> &free drop + &free drop ] with-destructors ] unit-test \ No newline at end of file diff --git a/basis/unix/utilities/utilities.factor b/basis/unix/utilities/utilities.factor index e2f780cd13..29b137e3de 100644 --- a/basis/unix/utilities/utilities.factor +++ b/basis/unix/utilities/utilities.factor @@ -16,5 +16,5 @@ IN: unix.utilities '[ [ advance ] [ *void* _ alien>string ] bi ] [ ] produce nip ; -: strings>alien ( strings encoding -- alien ) - '[ _ malloc-string ] void*-array{ } map-as f suffix underlying>> ; +: strings>alien ( strings encoding -- array ) + '[ _ malloc-string ] void*-array{ } map-as f suffix ; diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index 813d8315ac..c86cde23d9 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -132,7 +132,7 @@ unless [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ; : (callbacks>vtbl) ( callbacks -- vtbl ) - [ execute ] void*-array{ } map-as underlying>> malloc-byte-array ; + [ execute ] void*-array{ } map-as malloc-byte-array ; : (callbacks>vtbls) ( callbacks -- vtbls ) [ (callbacks>vtbl) ] map ; diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor index 0e9a03f075..314fb167e3 100755 --- a/basis/windows/dinput/constants/constants.factor +++ b/basis/windows/dinput/constants/constants.factor @@ -59,7 +59,7 @@ SYMBOLS: struct args i alien set-nth ] each-index - alien underlying>> + alien ] ; : (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien ) diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor index d3fe0a8447..8375636a72 100644 --- a/basis/x11/clipboard/clipboard.factor +++ b/basis/x11/clipboard/clipboard.factor @@ -51,7 +51,7 @@ TUPLE: x-clipboard atom contents ; "TARGETS" x-atom 32 PropModeReplace { "UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP" - } [ x-atom ] int-array{ } map-as underlying>> + } [ x-atom ] int-array{ } map-as 4 XChangeProperty drop ; : set-timestamp-prop ( evt -- ) diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor index e0b786ce7d..11473d6e83 100644 --- a/basis/x11/glx/glx.factor +++ b/basis/x11/glx/glx.factor @@ -93,7 +93,7 @@ FUNCTION: void* glXGetProcAddressARB ( char* procname ) ; GLX_RGBA , GLX_DEPTH_SIZE , 16 , 0 , - ] int-array{ } make underlying>> + ] int-array{ } make glXChooseVisual [ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ; diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor index 856420af0f..534e47ac37 100644 --- a/basis/x11/xim/xim.factor +++ b/basis/x11/xim/xim.factor @@ -50,7 +50,7 @@ SYMBOL: keysym : lookup-string ( event xic -- string keysym ) [ prepare-lookup - swap keybuf get underlying>> buf-size keysym get 0 + swap keybuf get buf-size keysym get 0 XwcLookupString finish-lookup ] with-scope ; From 242638fc5c20a70cd96a3dd770ed097fb3327824 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:38:31 -0600 Subject: [PATCH 08/60] alien.complex vocabulary implementing support for C99 complex numbers --- basis/alien/complex/authors.txt | 1 + basis/alien/complex/complex-tests.factor | 18 ++++++++++ basis/alien/complex/complex.factor | 6 ++++ basis/alien/complex/functor/authors.txt | 1 + .../complex/functor/functor-tests.factor | 4 +++ basis/alien/complex/functor/functor.factor | 35 +++++++++++++++++++ basis/alien/complex/summary.txt | 1 + 7 files changed, 66 insertions(+) create mode 100644 basis/alien/complex/authors.txt create mode 100644 basis/alien/complex/complex-tests.factor create mode 100644 basis/alien/complex/complex.factor create mode 100644 basis/alien/complex/functor/authors.txt create mode 100644 basis/alien/complex/functor/functor-tests.factor create mode 100644 basis/alien/complex/functor/functor.factor create mode 100644 basis/alien/complex/summary.txt diff --git a/basis/alien/complex/authors.txt b/basis/alien/complex/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/alien/complex/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor new file mode 100644 index 0000000000..bfb2c1137c --- /dev/null +++ b/basis/alien/complex/complex-tests.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test alien.complex kernel alien.c-types alien.syntax +namespaces ; +IN: alien.complex.tests + +C-STRUCT: complex-holder + { "complex-float" "z" } ; + +: ( z -- alien ) + "complex-holder" + [ set-complex-holder-z ] keep ; + +[ ] [ + C{ 1.0 2.0 } "h" set +] unit-test + +[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test \ No newline at end of file diff --git a/basis/alien/complex/complex.factor b/basis/alien/complex/complex.factor new file mode 100644 index 0000000000..60a84b9394 --- /dev/null +++ b/basis/alien/complex/complex.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.complex.functor sequences kernel ; +IN: alien.complex + +<< { "float" "double" } [ dup "complex-" prepend define-complex-type ] each >> \ No newline at end of file diff --git a/basis/alien/complex/functor/authors.txt b/basis/alien/complex/functor/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/alien/complex/functor/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/alien/complex/functor/functor-tests.factor b/basis/alien/complex/functor/functor-tests.factor new file mode 100644 index 0000000000..c2df22be1d --- /dev/null +++ b/basis/alien/complex/functor/functor-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test alien.complex.functor ; +IN: alien.complex.functor.tests diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor new file mode 100644 index 0000000000..1d12bb0ff4 --- /dev/null +++ b/basis/alien/complex/functor/functor.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.structs alien.c-types math math.functions sequences +arrays kernel functors vocabs.parser namespaces accessors +quotations ; +IN: alien.complex.functor + +FUNCTOR: define-complex-type ( N T -- ) + +T-real DEFINES ${T}-real +T-imaginary DEFINES ${T}-imaginary +set-T-real DEFINES set-${T}-real +set-T-imaginary DEFINES set-${T}-imaginary + +>T DEFINES >${T} +T> DEFINES ${T}> + +WHERE + +: >T ( z -- alien ) + >rect T [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline + +: T> ( alien -- z ) + [ T-real ] [ T-imaginary ] bi rect> ; inline + +T in get +{ { N "real" } { N "imaginary" } } +define-struct + +T c-type +T> 1quotation >>boxer-quot +>T 1quotation >>unboxer-quot +drop + +;FUNCTOR \ No newline at end of file diff --git a/basis/alien/complex/summary.txt b/basis/alien/complex/summary.txt new file mode 100644 index 0000000000..76c00c1d65 --- /dev/null +++ b/basis/alien/complex/summary.txt @@ -0,0 +1 @@ +Implementation details for C99 complex float and complex double types From 3166828f755bb8e2a0a1c0d4e34e880210cda393 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:38:54 -0600 Subject: [PATCH 09/60] Fix bug reported by Doug: smart combinators and inline words didn't mix very well in some cases --- basis/combinators/smart/smart-tests.factor | 8 ++++ .../transforms/transforms-tests.factor | 15 ++++++ .../transforms/transforms.factor | 46 ++++++------------- 3 files changed, 38 insertions(+), 31 deletions(-) diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 370dc26960..69a3a821e5 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -37,3 +37,11 @@ IN: combinators.smart.tests [ [ { 1 } { 2 } { 3 } ] B{ } append-outputs-as ] unit-test + +! Test nesting +: nested-smart-combo-test ( -- array ) + [ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ; + +\ nested-smart-combo-test must-infer + +[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index 8ae30dcd97..2e2dccd6c4 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -42,3 +42,18 @@ C: color [ bad-new-test ] must-infer [ bad-new-test ] must-fail + +! Corner case if macro expansion calls 'infer', found by Doug +DEFER: smart-combo ( quot -- ) + +\ smart-combo [ infer [ ] curry ] 1 define-transform + +[ [ "a" "b" "c" ] smart-combo ] must-infer + +[ [ [ "a" "b" ] smart-combo "c" ] smart-combo ] must-infer + +: very-smart-combo ( quot -- ) smart-combo ; inline + +[ [ "a" "b" "c" ] very-smart-combo ] must-infer + +[ [ [ "a" "b" ] very-smart-combo "c" ] very-smart-combo ] must-infer diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 808ea6a141..e5c2f05d72 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors arrays kernel words sequences generic math namespaces make quotations assocs combinators classes.tuple classes.tuple.private effects summary hashtables classes generic -sets definitions generic.standard slots.private continuations +sets definitions generic.standard slots.private continuations locals stack-checker.backend stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state ; @@ -15,48 +15,32 @@ IN: stack-checker.transforms [ dup infer-word apply-word/effect ] if ; -: ((apply-transform)) ( word quot values stack -- ) - rot with-datastack first2 - dup [ - [ - [ drop ] - [ [ length meta-d shorten-by ] [ #drop, ] bi ] bi* - ] 2dip - swap infer-quot - ] [ - 3drop give-up-transform - ] if ; inline +:: ((apply-transform)) ( word quot values stack rstate -- ) + rstate recursive-state + [ stack quot with-datastack first ] with-variable + [ + word inlined-dependency depends-on + values [ length meta-d shorten-by ] [ #drop, ] bi + rstate infer-quot + ] [ word give-up-transform ] if* ; : (apply-transform) ( word quot n -- ) ensure-d dup [ known literal? ] all? [ - dup empty? [ - recursive-state get 1array - ] [ + dup empty? [ dup recursive-state get ] [ [ ] [ [ literal value>> ] map ] [ first literal recursion>> ] tri - prefix ] if ((apply-transform)) ] [ 2drop give-up-transform ] if ; : apply-transform ( word -- ) - [ inlined-dependency depends-on ] [ - [ ] - [ "transform-quot" word-prop ] - [ "transform-n" word-prop ] - tri - (apply-transform) - ] bi ; + [ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri + (apply-transform) ; : apply-macro ( word -- ) - [ inlined-dependency depends-on ] [ - [ ] - [ "macro" word-prop ] - [ "declared-effect" word-prop in>> length ] - tri - (apply-transform) - ] bi ; + [ ] [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] tri + (apply-transform) ; : define-transform ( word quot n -- ) [ drop "transform-quot" set-word-prop ] From f9bc9a31981a415c5d26cdf01b529fa1fa5ef4c2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:53:08 -0600 Subject: [PATCH 10/60] Fix VM compile error --- vm/math.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/vm/math.c b/vm/math.c index f0aa874886..7bff0de387 100644 --- a/vm/math.c +++ b/vm/math.c @@ -530,8 +530,8 @@ void box_double(double flo) void primitive_from_rect(void) { - F_COMPLEX* complex = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX)); - complex->imaginary = dpop(); - complex->real = dpop(); - dpush(RETAG(complex,COMPLEX_TYPE)); + F_COMPLEX* z = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX)); + z->imaginary = dpop(); + z->real = dpop(); + dpush(RETAG(z,COMPLEX_TYPE)); } From 5579de1722a1490a45a6e069069aafd5420fdac0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 05:09:10 -0600 Subject: [PATCH 11/60] Fix load error in graphics.bitmap tests --- extra/graphics/bitmap/bitmap-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor index 4998427b22..15e960084a 100644 --- a/extra/graphics/bitmap/bitmap-tests.factor +++ b/extra/graphics/bitmap/bitmap-tests.factor @@ -1,4 +1,4 @@ -USING: graphics.bitmap ; +USING: graphics.bitmap graphics.viewer ; IN: graphics.bitmap.tests : test-bitmap24 ( -- ) From 33b513fb0538ce9946d861f2b853095a54b0cef0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 10:16:51 -0600 Subject: [PATCH 12/60] byte-length on f outputs 0 --- basis/alien/c-types/c-types.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index ff9d4cefc4..cf5daa1562 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -178,6 +178,8 @@ GENERIC: byte-length ( seq -- n ) flushable M: byte-array byte-length length ; +M: f byte-length drop 0 ; + : c-getter ( name -- quot ) c-type-getter [ [ "Cannot read struct fields with this type" throw ] From 79bb003e6dce8d346032de749f26c791e5be56a8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 10:17:20 -0600 Subject: [PATCH 13/60] io.sockets.secure.openssl: Don't allocate empty password string. Fixes test failures introduced by >c-ptr change --- basis/io/sockets/secure/openssl/openssl.factor | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor index 0326969e4f..f78f61ef3b 100644 --- a/basis/io/sockets/secure/openssl/openssl.factor +++ b/basis/io/sockets/secure/openssl/openssl.factor @@ -46,11 +46,13 @@ TUPLE: openssl-context < secure-context aliens sessions ; [ push ] [ drop ] 2bi ; : set-default-password ( ctx -- ) - [ handle>> password-callback SSL_CTX_set_default_passwd_cb ] - [ - [ handle>> ] [ default-pasword ] bi - SSL_CTX_set_default_passwd_cb_userdata - ] bi ; + dup config>> password>> [ + [ handle>> password-callback SSL_CTX_set_default_passwd_cb ] + [ + [ handle>> ] [ default-pasword ] bi + SSL_CTX_set_default_passwd_cb_userdata + ] bi + ] [ drop ] if ; : use-private-key-file ( ctx -- ) dup config>> key-file>> [ From 53758074a29aa3b5c85ede92199705ee11db2433 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 10:21:55 -0600 Subject: [PATCH 14/60] stack-checker: do constant folding for curry and compose with constant inputs at compile time. Allows macros to expand in more cases, fixing the fry caveat found by Doug --- .../known-words/known-words.factor | 53 ++++++++----------- basis/stack-checker/stack-checker-docs.factor | 8 --- .../stack-checker/stack-checker-tests.factor | 5 ++ .../transforms/transforms-docs.factor | 13 +++-- .../transforms/transforms-tests.factor | 9 ++++ .../transforms/transforms.factor | 4 +- basis/stack-checker/values/values.factor | 30 +++++++++-- 7 files changed, 73 insertions(+), 49 deletions(-) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 7cdce301b5..56aebb20e7 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -89,44 +89,37 @@ M: composed infer-call* M: object infer-call* \ literal-expected inference-warning ; -: infer-slip ( -- ) - 1 infer->r infer-call 1 infer-r> ; +: infer-nslip ( n -- ) + [ infer->r infer-call ] [ infer-r> ] bi ; -: infer-2slip ( -- ) - 2 infer->r infer-call 2 infer-r> ; +: infer-slip ( -- ) 1 infer-nslip ; -: infer-3slip ( -- ) - 3 infer->r infer-call 3 infer-r> ; +: infer-2slip ( -- ) 2 infer-nslip ; -: infer-dip ( -- ) - literals get - [ \ dip def>> infer-quot-here ] - [ pop 1 infer->r infer-quot-here 1 infer-r> ] +: infer-3slip ( -- ) 3 infer-nslip ; + +: infer-ndip ( word n -- ) + [ literals get ] 2dip + [ '[ _ def>> infer-quot-here ] ] + [ '[ _ [ pop ] dip [ infer->r infer-quot-here ] [ infer-r> ] bi ] ] bi* if-empty ; -: infer-2dip ( -- ) - literals get - [ \ 2dip def>> infer-quot-here ] - [ pop 2 infer->r infer-quot-here 2 infer-r> ] - if-empty ; +: infer-dip ( -- ) \ dip 1 infer-ndip ; -: infer-3dip ( -- ) - literals get - [ \ 3dip def>> infer-quot-here ] - [ pop 3 infer->r infer-quot-here 3 infer-r> ] - if-empty ; +: infer-2dip ( -- ) \ 2dip 2 infer-ndip ; -: infer-curry ( -- ) - 2 consume-d - dup first2 make-known - [ push-d ] [ 1array ] bi - \ curry #call, ; +: infer-3dip ( -- ) \ 3dip 3 infer-ndip ; -: infer-compose ( -- ) - 2 consume-d - dup first2 make-known - [ push-d ] [ 1array ] bi - \ compose #call, ; +: infer-builder ( quot word -- ) + [ + [ 2 consume-d ] dip + [ dup first2 ] dip call make-known + [ push-d ] [ 1array ] bi + ] dip #call, ; inline + +: infer-curry ( -- ) [ ] \ curry infer-builder ; + +: infer-compose ( -- ) [ ] \ compose infer-builder ; : infer-execute ( -- ) pop-literal nip diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 5b67cd9adc..5926f08d8c 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -80,13 +80,6 @@ $nl "[ [ 5 ] t foo ] infer." } ; -ARTICLE: "compiler-transforms" "Compiler transforms" -"Compiler transforms can be used to allow words to compile which would otherwise not have a stack effect, and to expand combinators into more efficient code at compile time." -{ $subsection define-transform } -"An example is the " { $link cond } " word. If the association list of quotations it is given is literal, the entire form is expanded into a series of nested calls to " { $link if } "." -$nl -"The " { $vocab-link "macros" } " vocabulary defines some nice syntax sugar which makes compiler transforms easier to work with." ; - ARTICLE: "inference" "Stack effect inference" "The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build the high-level SSA representation on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")." $nl @@ -103,7 +96,6 @@ $nl { $subsection "inference-recursive-combinators" } { $subsection "inference-branches" } { $subsection "inference-errors" } -{ $subsection "compiler-transforms" } { $see-also "effects" } ; ABOUT: "inference" diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 4d7295042c..bc6eb9f092 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -577,3 +577,8 @@ DEFER: eee' [ bogus-error ] must-infer [ [ clear ] infer. ] [ inference-error? ] must-fail-with + +: debugging-curry-folding ( quot -- ) + [ debugging-curry-folding ] curry call ; inline recursive + +[ [ ] debugging-curry-folding ] must-infer \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms-docs.factor b/basis/stack-checker/transforms/transforms-docs.factor index a178669595..de0edc4528 100644 --- a/basis/stack-checker/transforms/transforms-docs.factor +++ b/basis/stack-checker/transforms/transforms-docs.factor @@ -3,12 +3,11 @@ USING: help.markup help.syntax combinators words kernel ; HELP: define-transform { $values { "word" word } { "quot" "a quotation taking " { $snippet "n" } " inputs from the stack and producing another quotation as output" } { "n" "a non-negative integer" } } -{ $description "Defines a compiler transform for the optimizing compiler. When a call to " { $snippet "word" } " is being compiled, the compiler ensures that the top " { $snippet "n" } " stack values are literal; if they are not, compilation fails. The literal values are passed to the quotation, which is expected to produce a new quotation. The call to the word is then replaced by this quotation." } -{ $examples "Here is a word which pops " { $snippet "n" } " values from the stack:" -{ $code ": ndrop ( n -- ) [ drop ] times ;" } -"This word is inefficient; it does not have a static stack effect. This means that words calling " { $snippet "ndrop" } " cannot be compiled by the optimizing compiler, and additionally, a call to this word will always involve a loop with arithmetic, even if the value of " { $snippet "n" } " is known at compile time. A compiler transform can fix this:" -{ $code "\\ ndrop [ \\ drop >quotation ] 1 define-transform" } -"Now, a call like " { $snippet "4 ndrop" } " is replaced with " { $snippet "drop drop drop drop" } " at compile time; the optimizer then ensures that this compiles as a single machine instruction, which is a lot cheaper than an actual call to " { $snippet "ndrop" } "." +{ $description "Defines a compiler transform for the optimizing compiler." + "When a call to " { $snippet "word" } " is being compiled, the compiler first checks that the top " { $snippet "n" } " stack values are literal, and if so, calls the quotation with those inputs at compile time. The quotation can output a new quotation, or " { $link f } "." $nl -"The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":" +"If the quotation outputs " { $link f } ", or if not all inputs are literal, a call to the word is compiled as usual, or compilation fails if the word does not have a static stack effect." +$nl +"Otherwise, if the transform output a new quotation, the quotation replaces the word's call site." } +{ $examples "The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":" { $code "\\ cond [ cond>quot ] 1 define-transform" } } ; diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index 2e2dccd6c4..fe580084c0 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -57,3 +57,12 @@ DEFER: smart-combo ( quot -- ) [ [ "a" "b" "c" ] very-smart-combo ] must-infer [ [ [ "a" "b" ] very-smart-combo "c" ] very-smart-combo ] must-infer + +! Caveat found by Doug +DEFER: curry-folding-test ( quot -- ) + +\ curry-folding-test [ length \ drop >quotation ] 1 define-transform + +{ 3 0 } [ [ 1 2 3 ] curry-folding-test ] must-infer-as +{ 3 0 } [ 1 [ 2 3 ] curry curry-folding-test ] must-infer-as +{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index e5c2f05d72..a2f616480a 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -24,8 +24,10 @@ IN: stack-checker.transforms rstate infer-quot ] [ word give-up-transform ] if* ; +: literals? ( values -- ? ) [ literal-value? ] all? ; + : (apply-transform) ( word quot n -- ) - ensure-d dup [ known literal? ] all? [ + ensure-d dup literals? [ dup empty? [ dup recursive-state get ] [ [ ] [ [ literal value>> ] map ] diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor index 97aa774e55..19db441381 100644 --- a/basis/stack-checker/values/values.factor +++ b/basis/stack-checker/values/values.factor @@ -26,27 +26,51 @@ SYMBOL: known-values : copy-values ( values -- values' ) [ copy-value ] map ; +GENERIC: (literal-value?) ( value -- ? ) + +M: object (literal-value?) drop f ; + +GENERIC: (literal) ( value -- literal ) + ! Literal value TUPLE: literal < identity-tuple value recursion hashcode ; +: literal ( value -- literal ) known (literal) ; + +: literal-value? ( value -- ? ) known (literal-value?) ; + M: literal hashcode* nip hashcode>> ; : ( obj -- value ) recursive-state get over hashcode \ literal boa ; -GENERIC: (literal) ( value -- literal ) +M: literal (literal-value?) drop t ; M: literal (literal) ; -: literal ( value -- literal ) - known (literal) ; +: curried/composed-literal ( input1 input2 quot -- literal ) + [ [ literal ] bi@ ] dip + [ [ [ value>> ] bi@ ] dip call ] [ drop nip recursion>> ] 3bi + over hashcode \ literal boa ; inline ! Result of curry TUPLE: curried obj quot ; C: curried +: >curried< ( curried -- obj quot ) + [ obj>> ] [ quot>> ] bi ; inline + +M: curried (literal-value?) >curried< [ literal-value? ] both? ; +M: curried (literal) >curried< [ curry ] curried/composed-literal ; + ! Result of compose TUPLE: composed quot1 quot2 ; C: composed + +: >composed< ( composed -- quot1 quot2 ) + [ quot1>> ] [ quot2>> ] bi ; inline + +M: composed (literal-value?) >composed< [ literal-value? ] both? ; +M: composed (literal) >composed< [ compose ] curried/composed-literal ; \ No newline at end of file From d1486589efc44be2c58277597dc37e84f70c4017 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 10:22:09 -0600 Subject: [PATCH 15/60] Improving macro docs --- basis/macros/macros-docs.factor | 45 ++++++++++++++++++++++++++------- basis/macros/macros.factor | 4 +++ core/kernel/kernel-docs.factor | 17 +++++++------ 3 files changed, 49 insertions(+), 17 deletions(-) diff --git a/basis/macros/macros-docs.factor b/basis/macros/macros-docs.factor index 704cae459a..acd2c3383f 100644 --- a/basis/macros/macros-docs.factor +++ b/basis/macros/macros-docs.factor @@ -1,27 +1,54 @@ -USING: help.markup help.syntax quotations kernel ; +USING: help.markup help.syntax quotations kernel +stack-checker.transforms sequences ; IN: macros HELP: MACRO: { $syntax "MACRO: word ( inputs... -- ) definition... ;" } -{ $description "Defines a compile-time code transformation. If all inputs to the word are literal and the word calling the macro has a static stack effect, then the macro body is invoked at compile-time to produce a quotation; this quotation is then spliced into the compiled code. If the inputs are not literal, or if the word is invoked from a word which does not have a static stack effect, the macro body will execute every time and the result will be passed to " { $link call } "." -$nl -"The stack effect declaration must be present because it tells the compiler how many literal inputs to expect." -} +{ $description "Defines a code transformation. The definition must have stack effect " { $snippet "( inputs... -- quot )" } "." } { $notes - "Semantically, the following two definitions are equivalent:" + "A call of a macro inside a word definition is replaced with the quotation expansion at compile-time if precisely the following conditions hold:" + { $list + { "All inputs to the macro call are literal" } + { "The word calling the macro has a static stack effect" } + { "The expansion quotation produced by the macro has a static stack effect" } + } + "If any of these conditions fail to hold, the macro will still work, but expansion will be performed at run-time." + $nl + "Other than possible compile-time expansion, the following two definition styles are equivalent:" { $code "MACRO: foo ... ;" } { $code ": foo ... call ;" } - "However, the compiler folds in macro definitions at compile-time where possible; if the macro body performs an expensive calculation, it can lead to a performance boost." + "Conceptually, macros allow computation to be moved from run-time to compile-time, splicing the result of this computation into the generated quotation." +} +{ $examples + "A macro that calls a quotation but preserves any values it consumes off the stack:" + { $code + "USING: fry generalizations ;" + "MACRO: preserving ( quot -- )" + " [ infer in>> length ] keep '[ _ ndup @ ] ;" + } + "Using this macro, we can define a variant of " { $link if } " which takes a predicate quotation instead of a boolean; any values consumed by the predicate quotation are restored immediately after:" + { $code + ": ifte ( pred true false -- ) [ preserving ] 2dip if ; inline" + } + "Note that " { $snippet "ifte" } " is an ordinary word, and it passes one of its inputs to the macro. If another word calls " { $snippet "ifte" } " with all three input quotations literal, then " { $snippet "ifte" } " will be inlined and " { $snippet "preserving" } " will expand at compile-time, and the generated machine code will be exactly the same as if the inputs consumed by the predicate were duplicated by hand." + $nl + "The " { $snippet "ifte" } " combinator presented here has similar semantics to the " { $snippet "ifte" } " combinator of the Joy programming language." } ; HELP: macro { $class-description "Class of words defined with " { $link POSTPONE: MACRO: } "." } ; ARTICLE: "macros" "Macros" -"The " { $vocab-link "macros" } " vocabulary implements macros in the Lisp sense; compile-time code transformers and generators. Macros can be used to calculate lookup tables and generate code at compile time, which can improve performance, the level of abstraction and simplify code." +"The " { $vocab-link "macros" } " vocabulary implements " { $emphasis "macros" } ", which are code transformations that may run at compile-time under the right circumstances." +$nl +"Macros can be used to give static stack effects to combinators that otherwise would not have static stack effects. Macros can be used to calculate lookup tables and generate code at compile time, which can improve performance, the level of abstraction and simplify code." +$nl +"Factor macros are similar to Lisp macros; they are not like C preprocessor macros." $nl "Defining new macros:" { $subsection POSTPONE: MACRO: } -"Macros are really just a very thin layer of syntax sugar over " { $link "compiler-transforms" } "." ; +"A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion." +{ $subsection define-transform } +"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." ; ABOUT: "macros" diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 1481e6eea5..4fba7efba3 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -4,9 +4,13 @@ USING: parser kernel sequences words effects combinators assocs definitions quotations namespaces memoize accessors ; IN: macros +> 1 ; +PRIVATE> + : define-macro ( word definition -- ) [ "macro" set-word-prop ] [ over real-macro-effect memoize-quot [ call ] append define ] diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index d85a51edff..71183093ee 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -949,6 +949,13 @@ ARTICLE: "assertions" "Assertions" { $subsection assert } { $subsection assert= } ; +ARTICLE: "dataflow-combinators" "Data flow combinators" +"Data flow combinators pass values between quotations:" +{ $subsection "slip-keep-combinators" } +{ $subsection "cleave-combinators" } +{ $subsection "spread-combinators" } +{ $subsection "apply-combinators" } ; + ARTICLE: "dataflow" "Data and control flow" { $subsection "evaluator" } { $subsection "words" } @@ -956,16 +963,9 @@ ARTICLE: "dataflow" "Data and control flow" { $subsection "booleans" } { $subsection "shuffle-words" } "A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input." -$nl -"Data flow combinators:" -{ $subsection "slip-keep-combinators" } -{ $subsection "cleave-combinators" } -{ $subsection "spread-combinators" } -{ $subsection "apply-combinators" } -"Control flow combinators:" +{ $subsection "dataflow-combinators" } { $subsection "conditionals" } { $subsection "looping-combinators" } -"Additional combinators:" { $subsection "compositional-combinators" } { $subsection "combinators" } "More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "." @@ -973,6 +973,7 @@ $nl "Advanced topics:" { $subsection "assertions" } { $subsection "implementing-combinators" } +{ $subsection "macros" } { $subsection "errors" } { $subsection "continuations" } ; From 31f976e0e909aff88f122cde1de0e7bb381969fa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 10:22:22 -0600 Subject: [PATCH 16/60] pack: cleanup, write macros in more intuitive style that works now --- basis/pack/pack.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index aec4414c71..3cf7dbab4c 100755 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -113,9 +113,7 @@ CONSTANT: packed-length-table MACRO: pack ( str -- quot ) [ pack-table at '[ _ execute ] ] { } map-as - '[ _ spread ] - '[ _ input @@ -143,7 +141,7 @@ MACRO: unpack ( str -- quot ) [ [ ch>packed-length ] { } map-as start/end ] [ [ unpack-table at '[ @ ] ] { } map-as ] bi [ '[ [ _ _ ] dip @ ] ] 3map - '[ _ cleave ] '[ _ output>array ] ; + '[ [ _ cleave ] output>array ] ; PRIVATE> From 05632b85254fe0bc5968ae934d3629049a2f7f78 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 11:03:52 -0600 Subject: [PATCH 17/60] Don't use complex.h since *BSDs don't have it in latest release versions (gah!); add DLLEXPORT for ffi_test_45 to make it work on Windows --- vm/ffi_test.c | 2 +- vm/ffi_test.h | 2 +- vm/master.h | 1 - 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 36147795d1..c7a9f7d890 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -303,7 +303,7 @@ struct test_struct_14 ffi_test_44(void) return retval; } -complex float ffi_test_45(complex float x, complex double y) +_Complex float ffi_test_45(_Complex float x, _Complex double y) { return x + 2 * y; } diff --git a/vm/ffi_test.h b/vm/ffi_test.h index de48d6dc5b..42ab8d71d1 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -89,4 +89,4 @@ DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a); DLLEXPORT struct test_struct_14 ffi_test_44(); -complex float ffi_test_45(complex float x, complex double y); +DLLEXPORT _Complex float ffi_test_45(_Complex float x, _Complex double y); diff --git a/vm/master.h b/vm/master.h index 01b2335841..86b5223eaa 100644 --- a/vm/master.h +++ b/vm/master.h @@ -8,7 +8,6 @@ #include #include #include -#include #include #include From 173b0ee78d7c659f9205dfee80fca8d8d91ea0b4 Mon Sep 17 00:00:00 2001 From: sheeple Date: Fri, 6 Feb 2009 12:21:53 -0600 Subject: [PATCH 18/60] Add some more tests for complex numbers in FFI --- basis/compiler/tests/alien.factor | 14 +++++++++++--- vm/ffi_test.c | 12 +++++++++++- vm/ffi_test.h | 6 +++++- 3 files changed, 27 insertions(+), 5 deletions(-) diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index b9c62f1429..8830c59b31 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -559,9 +559,17 @@ FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline [ ] [ stack-frame-bustage 2drop ] unit-test -FUNCTION: complex-float ffi_test_45 ( complex-float x, complex-double y ) ; +FUNCTION: complex-float ffi_test_45 ( int x ) ; + +[ C{ 0.0 3.0 } ] [ 3 ffi_test_45 ] unit-test + +FUNCTION: complex-double ffi_test_46 ( int x ) ; + +[ C{ 0.0 3.0 } ] [ 3 ffi_test_46 ] unit-test + +FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ; [ C{ 4.0 4.0 } ] [ C{ 1.0 2.0 } - C{ 1.5 1.0 } ffi_test_45 -] unit-test \ No newline at end of file + C{ 1.5 1.0 } ffi_test_47 +] unit-test diff --git a/vm/ffi_test.c b/vm/ffi_test.c index c7a9f7d890..a5a43cf2ae 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -303,7 +303,17 @@ struct test_struct_14 ffi_test_44(void) return retval; } -_Complex float ffi_test_45(_Complex float x, _Complex double y) +_Complex float ffi_test_45(int x) +{ + return x; +} + +_Complex double ffi_test_46(int x) +{ + return x; +} + +_Complex float ffi_test_47(_Complex float x, _Complex double y) { return x + 2 * y; } diff --git a/vm/ffi_test.h b/vm/ffi_test.h index 42ab8d71d1..f8634b304e 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -89,4 +89,8 @@ DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a); DLLEXPORT struct test_struct_14 ffi_test_44(); -DLLEXPORT _Complex float ffi_test_45(_Complex float x, _Complex double y); +DLLEXPORT _Complex float ffi_test_45(int x); + +DLLEXPORT _Complex double ffi_test_46(int x); + +DLLEXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y); From 01c2e26dfecbd015cdfb6226d0e0efb03f950019 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 12:30:11 -0600 Subject: [PATCH 19/60] Fix alien tests, oops --- basis/compiler/tests/alien.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 8830c59b31..f3c2deb2d8 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -561,11 +561,11 @@ FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline FUNCTION: complex-float ffi_test_45 ( int x ) ; -[ C{ 0.0 3.0 } ] [ 3 ffi_test_45 ] unit-test +[ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test FUNCTION: complex-double ffi_test_46 ( int x ) ; -[ C{ 0.0 3.0 } ] [ 3 ffi_test_46 ] unit-test +[ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ; From 01f6c5a7f646ddd2fb2d969876b83c6b2ef29d2d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 16:40:14 -0600 Subject: [PATCH 20/60] add a test for saving bitmaps, refactor load-bitmap a bit --- extra/graphics/bitmap/bitmap-tests.factor | 30 ++++++++++++++++------- extra/graphics/bitmap/bitmap.factor | 27 ++++++++++++-------- 2 files changed, 38 insertions(+), 19 deletions(-) diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor index 15e960084a..ca8be85e12 100644 --- a/extra/graphics/bitmap/bitmap-tests.factor +++ b/extra/graphics/bitmap/bitmap-tests.factor @@ -1,15 +1,27 @@ -USING: graphics.bitmap graphics.viewer ; +USING: graphics.bitmap graphics.viewer io.encodings.binary +io.files io.files.unique kernel tools.test ; IN: graphics.bitmap.tests -: test-bitmap24 ( -- ) - "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ; +: test-bitmap32-alpha ( -- path ) + "resource:extra/graphics/bitmap/test-images/32alpha.bmp" ; -: test-bitmap8 ( -- ) - "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ; +: test-bitmap24 ( -- path ) + "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" ; -: test-bitmap4 ( -- ) - "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ; +: test-bitmap8 ( -- path ) + "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" ; -: test-bitmap1 ( -- ) - "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ; +: test-bitmap4 ( -- path ) + "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" ; +: test-bitmap1 ( -- path ) + "resource:extra/graphics/bitmap/test-images/1bit.bmp" ; + +[ t ] +[ + test-bitmap24 + [ binary file-contents ] [ load-bitmap ] bi + + "test-bitmap24" unique-file + [ save-bitmap ] [ binary file-contents ] bi = +] unit-test diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index bd34a9ee41..a1cf37c8a1 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -1,11 +1,10 @@ -! Copyright (C) 2007 Doug Coleman. +! Copyright (C) 2007, 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. - -USING: alien arrays byte-arrays combinators summary -io io.binary io.files kernel libc math -math.functions math.bitwise namespaces opengl opengl.gl -prettyprint sequences strings ui ui.gadgets.panes fry -io.encodings.binary accessors grouping macros alien.c-types ; +USING: accessors alien alien.c-types arrays byte-arrays columns +combinators fry grouping io io.binary io.encodings.binary +io.files kernel libc macros math math.bitwise math.functions +namespaces opengl opengl.gl prettyprint sequences strings +summary ui ui.gadgets.panes ; IN: graphics.bitmap ! Currently can only handle 24/32bit bitmaps. @@ -14,6 +13,7 @@ IN: graphics.bitmap TUPLE: bitmap magic size reserved offset header-length width height planes bit-count compression size-image x-pels y-pels color-used color-important rgb-quads color-index +alpha-channel-zero? array ; : array-copy ( bitmap array -- bitmap array' ) @@ -97,12 +97,19 @@ M: bitmap-magic summary dup rgb-quads-length read >>rgb-quads dup color-index-length read >>color-index ; -: load-bitmap ( path -- bitmap ) +: (load-bitmap) ( path -- bitmap ) binary [ bitmap new parse-file-header parse-bitmap-header parse-bitmap - ] with-file-reader - dup raw-bitmap>array >>array ; + ] with-file-reader ; + +: alpha-channel-zero? ( bitmap -- ? ) + array>> 4 3 [ 0 = ] all? ; + +: load-bitmap ( path -- bitmap ) + (load-bitmap) + dup raw-bitmap>array >>array + dup alpha-channel-zero? >>alpha-channel-zero? ; : write2 ( n -- ) 2 >le write ; : write4 ( n -- ) 4 >le write ; From 71d176716bcbc310b0e72536eb30082af0be5625 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 16:53:41 -0600 Subject: [PATCH 21/60] fix 24-game compile error --- extra/24-game/24-game.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor index 126215ab13..f842d5f4cb 100644 --- a/extra/24-game/24-game.factor +++ b/extra/24-game/24-game.factor @@ -15,7 +15,8 @@ SYMBOL: commands { nop rot -rot swap spin swapd } amb-execute ; : makes-24? ( a b c d -- ? ) [ - 2 [ some-rots do-something ] times + some-rots do-something + some-rots do-something maybe-swap do-something 24 = ] @@ -60,4 +61,4 @@ DEFER: check-status : 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ; : set-commands ( -- ) { + - * / rot swap q } commands set ; : play-game ( -- ) set-commands 24-able repeat ; -MAIN: play-game \ No newline at end of file +MAIN: play-game From 3df4cfb65164bed7ca4b4ec68056c367108fe8bf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 16:58:17 -0600 Subject: [PATCH 22/60] fix words help-lint --- core/words/words-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 764df9924c..4dfa2d49bc 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -107,7 +107,7 @@ $nl { { { $snippet "\"help\"" } ", " { $snippet "\"help-loc\"" } ", " { $snippet "\"help-parent\"" } } { "Where word help is stored - " { $link "writing-help" } } } - { { $snippet "\"infer\"" } { $link "compiler-transforms" } } + { { $snippet "\"infer\"" } { $link "macros" } } { { { $snippet "\"inferred-effect\"" } } { $link "inference" } } From e0e333b449e8e1c2609f127e02c9316683361357 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 17:13:47 -0600 Subject: [PATCH 23/60] fix link --- basis/html/templates/chloe/chloe-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index b2259e629e..18e6db66f6 100644 --- a/basis/html/templates/chloe/chloe-docs.factor +++ b/basis/html/templates/chloe/chloe-docs.factor @@ -261,7 +261,7 @@ $nl ARTICLE: "html.templates.chloe.extend.components.example" "An example of a custom Chloe component" "As an example, let's develop a custom Chloe component which renders an image stored in a form value. Since the component does not require any configuration, we can define a singleton class:" { $code "SINGLETON: image" } -"Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "xml.literals" } ":" +"Now we define a method on the " { $link render* } " generic word which renders the image using " { $link { "xml.syntax" "literals" } } ":" { $code "M: image render* 2drop [XML /> XML] ;" } "Finally, we can define a Chloe component:" { $code "COMPONENT: image" } From 89c0dd21ddde9ff339cbd7c7fdbf6420123afba3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 17:14:03 -0600 Subject: [PATCH 24/60] fix furnace.utilities lint --- basis/furnace/utilities/utilities-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor index d2291786df..6defba54d2 100644 --- a/basis/furnace/utilities/utilities-docs.factor +++ b/basis/furnace/utilities/utilities-docs.factor @@ -27,7 +27,7 @@ HELP: hidden-form-field { $example "USING: furnace.utilities io ;" "\"bar\" \"foo\" hidden-form-field nl" - "" + "" } } ; From 4cd8bba92e3f175e464d1cf2c917244db382e5ee Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 17:31:03 -0600 Subject: [PATCH 25/60] better warnings on unsupported bmp formats --- extra/graphics/bitmap/bitmap-tests.factor | 3 +++ extra/graphics/bitmap/bitmap.factor | 12 +++++------- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor index ca8be85e12..f8a125e855 100644 --- a/extra/graphics/bitmap/bitmap-tests.factor +++ b/extra/graphics/bitmap/bitmap-tests.factor @@ -8,6 +8,9 @@ IN: graphics.bitmap.tests : test-bitmap24 ( -- path ) "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" ; +: test-bitmap16 ( -- path ) + "resource:extra/graphics/bitmap/test-images/rgb16bit.bmp" ; + : test-bitmap8 ( -- path ) "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" ; diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index a1cf37c8a1..f8008dc7c1 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -39,20 +39,18 @@ MACRO: (nbits>bitmap) ( bits -- ) [ rgb-quads>> 4 [ 3 head-slice ] map ] [ color-index>> >array ] bi [ swap nth ] with map concat ; -: 4bit>array ( bitmap -- array ) - [ rgb-quads>> 4 [ 3 head-slice ] map ] - [ color-index>> >array ] bi [ swap nth ] with map concat ; +ERROR: bmp-not-supported n ; : raw-bitmap>array ( bitmap -- array ) dup bit-count>> { { 32 [ color-index>> ] } { 24 [ color-index>> ] } - { 16 [ "16bit" throw ] } + { 16 [ bmp-not-supported ] } { 8 [ 8bit>array ] } - { 4 [ 4bit>array ] } - { 2 [ "2bit" throw ] } - { 1 [ "1bit" throw ] } + { 4 [ bmp-not-supported ] } + { 2 [ bmp-not-supported ] } + { 1 [ bmp-not-supported ] } } case >byte-array ; ERROR: bitmap-magic ; From 43a91efde99941c89f5737ca2d17812fa4739e34 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 18:22:28 -0600 Subject: [PATCH 26/60] rename err_no to errno, clear_err_no to clear-errno, move them to libc, update usages --- basis/io/backend/unix/unix.factor | 12 ++++++------ basis/io/sockets/secure/unix/unix.factor | 2 +- basis/io/sockets/unix/unix.factor | 14 +++++++------- basis/libc/libc.factor | 12 ++++++++++-- basis/unix/unix.factor | 9 ++------- 5 files changed, 26 insertions(+), 23 deletions(-) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 4bc8868a3c..d86a72c665 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -84,8 +84,8 @@ M: fd refill fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read { { [ dup 0 >= ] [ swap buffer>> n>buffer f ] } - { [ err_no EINTR = ] [ 2drop +retry+ ] } - { [ err_no EAGAIN = ] [ 2drop +input+ ] } + { [ errno EINTR = ] [ 2drop +retry+ ] } + { [ errno EAGAIN = ] [ 2drop +input+ ] } [ (io-error) ] } cond ; @@ -104,8 +104,8 @@ M: fd drain over buffer>> buffer-consume buffer>> buffer-empty? f +output+ ? ] } - { [ err_no EINTR = ] [ 2drop +retry+ ] } - { [ err_no EAGAIN = ] [ 2drop +output+ ] } + { [ errno EINTR = ] [ 2drop +retry+ ] } + { [ errno EAGAIN = ] [ 2drop +output+ ] } [ (io-error) ] } cond ; @@ -143,7 +143,7 @@ M: stdin dispose* stdin data>> handle-fd buffer buffer-end size read dup 0 < [ drop - err_no EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if + errno EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if ] [ size = [ "Error reading stdin pipe" throw ] unless size buffer n>buffer @@ -177,7 +177,7 @@ TUPLE: mx-port < port mx ; : multiplexer-error ( n -- n ) dup 0 < [ - err_no [ EAGAIN = ] [ EINTR = ] bi or + errno [ EAGAIN = ] [ EINTR = ] bi or [ drop 0 ] [ (io-error) ] if ] when ; diff --git a/basis/io/sockets/secure/unix/unix.factor b/basis/io/sockets/secure/unix/unix.factor index 8419246eb6..f1f39a0559 100644 --- a/basis/io/sockets/secure/unix/unix.factor +++ b/basis/io/sockets/secure/unix/unix.factor @@ -15,7 +15,7 @@ M: ssl-handle handle-fd file>> handle-fd ; ERR_get_error dup zero? [ drop { - { -1 [ err_no ECONNRESET = [ premature-close ] [ (io-error) ] if ] } + { -1 [ errno ECONNRESET = [ premature-close ] [ (io-error) ] if ] } { 0 [ premature-close ] } } case ] [ nip (ssl-error) ] if ; diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index f209df5862..e701874afd 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -37,8 +37,8 @@ M: object (get-remote-address) ( handle local -- sockaddr ) dup handle>> handle-fd f 0 write { { [ 0 = ] [ drop ] } - { [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] } - { [ err_no EINTR = ] [ wait-to-connect ] } + { [ errno EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] } + { [ errno EINTR = ] [ wait-to-connect ] } [ (io-error) ] } cond ; @@ -46,7 +46,7 @@ M: object establish-connection ( client-out remote -- ) [ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi { { [ 0 = ] [ drop ] } - { [ err_no EINPROGRESS = ] [ + { [ errno EINPROGRESS = ] [ [ +output+ wait-for-port ] [ wait-to-connect ] bi ] } [ (io-error) ] @@ -78,8 +78,8 @@ M: object (accept) ( server addrspec -- fd sockaddr ) 2dup do-accept { { [ over 0 >= ] [ [ 2nip init-fd ] dip ] } - { [ err_no EINTR = ] [ 2drop (accept) ] } - { [ err_no EAGAIN = ] [ + { [ errno EINTR = ] [ 2drop (accept) ] } + { [ errno EAGAIN = ] [ 2drop [ drop +input+ wait-for-port ] [ (accept) ] @@ -121,10 +121,10 @@ M: unix (receive) ( datagram -- packet sockaddr ) :: do-send ( packet sockaddr len socket datagram -- ) socket handle-fd packet dup length 0 sockaddr len sendto 0 < [ - err_no EINTR = [ + errno EINTR = [ packet sockaddr len socket datagram do-send ] [ - err_no EAGAIN = [ + errno EAGAIN = [ datagram +output+ wait-for-port packet sockaddr len socket datagram do-send ] [ diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index 1e751833a2..bcfb97750f 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -2,10 +2,18 @@ ! Copyright (C) 2007, 2008 Slava Pestov ! Copyright (C) 2007, 2008 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: alien assocs continuations destructors kernel -namespaces accessors sets summary ; +USING: alien alien.syntax assocs continuations destructors +kernel namespaces accessors sets summary ; IN: libc +LIBRARY: factor + +: errno ( -- int ) + "int" "factor" "err_no" { } alien-invoke ; + +: clear-errno ( -- ) + "void" "factor" "clear_err_no" { } alien-invoke ; + Date: Fri, 6 Feb 2009 18:36:00 -0600 Subject: [PATCH 27/60] unbreak bootstrap --- basis/libc/libc.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index bcfb97750f..c154544f81 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -2,12 +2,10 @@ ! Copyright (C) 2007, 2008 Slava Pestov ! Copyright (C) 2007, 2008 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax assocs continuations destructors +USING: alien assocs continuations destructors kernel namespaces accessors sets summary ; IN: libc -LIBRARY: factor - : errno ( -- int ) "int" "factor" "err_no" { } alien-invoke ; From c8c427ec159b92acf5924e757b5ea3ed95d2e692 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 18:38:41 -0600 Subject: [PATCH 28/60] initial, non-stream-based zlib binding --- basis/zlib/authors.txt | 1 + basis/zlib/ffi/authors.txt | 1 + basis/zlib/ffi/ffi.factor | 30 ++++++++++++++++++++++ basis/zlib/zlib-tests.factor | 9 +++++++ basis/zlib/zlib.factor | 50 ++++++++++++++++++++++++++++++++++++ 5 files changed, 91 insertions(+) create mode 100755 basis/zlib/authors.txt create mode 100755 basis/zlib/ffi/authors.txt create mode 100755 basis/zlib/ffi/ffi.factor create mode 100755 basis/zlib/zlib-tests.factor create mode 100755 basis/zlib/zlib.factor diff --git a/basis/zlib/authors.txt b/basis/zlib/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/zlib/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/zlib/ffi/authors.txt b/basis/zlib/ffi/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/zlib/ffi/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/zlib/ffi/ffi.factor b/basis/zlib/ffi/ffi.factor new file mode 100755 index 0000000000..bda2809f56 --- /dev/null +++ b/basis/zlib/ffi/ffi.factor @@ -0,0 +1,30 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.syntax combinators system ; +IN: zlib.ffi + +<< "zlib" { + { [ os winnt? ] [ "zlib1.dll" ] } + { [ os macosx? ] [ "libz.dylib" ] } + { [ os unix? ] [ "libz.so" ] } +} cond "cdecl" add-library >> + +LIBRARY: zlib + +CONSTANT: Z_OK 0 +CONSTANT: Z_STREAM_END 1 +CONSTANT: Z_NEED_DICT 2 +CONSTANT: Z_ERRNO -1 +CONSTANT: Z_STREAM_ERROR -2 +CONSTANT: Z_DATA_ERROR -3 +CONSTANT: Z_MEM_ERROR -4 +CONSTANT: Z_BUF_ERROR -5 +CONSTANT: Z_VERSION_ERROR -6 + +TYPEDEF: void Bytef +TYPEDEF: ulong uLongf +TYPEDEF: ulong uLong + +FUNCTION: int compress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ; +FUNCTION: int compress2 ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen, int level ) ; +FUNCTION: int uncompress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ; diff --git a/basis/zlib/zlib-tests.factor b/basis/zlib/zlib-tests.factor new file mode 100755 index 0000000000..0ac77277dc --- /dev/null +++ b/basis/zlib/zlib-tests.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel tools.test zlib classes ; +IN: zlib.tests + +: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ; + +[ t ] [ compress-me [ compress uncompress ] keep = ] unit-test +[ t ] [ compress-me compress compressed instance? ] unit-test diff --git a/basis/zlib/zlib.factor b/basis/zlib/zlib.factor new file mode 100755 index 0000000000..d5eed0b35b --- /dev/null +++ b/basis/zlib/zlib.factor @@ -0,0 +1,50 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types alien.syntax byte-arrays combinators +kernel math math.functions sequences system accessors +libc ; +QUALIFIED: zlib.ffi +IN: zlib + +TUPLE: compressed data length ; + +: ( data length -- compressed ) + compressed new + swap >>length + swap >>data ; + +ERROR: zlib-failed n string ; + +: zlib-error-message ( n -- * ) + dup zlib.ffi:Z_ERRNO = [ + drop errno "native libc error" + ] [ + dup { + "no error" "libc_error" + "stream error" "data error" + "memory error" "buffer error" "zlib version error" + } ?nth + ] if zlib-failed ; + +: zlib-error ( n -- ) + dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ; + +! Compressed size is up to .001% larger plus 12 + +: compressed-size ( byte-array -- n ) + length 1001/1000 * ceiling 12 + ; + +: compress ( byte-array -- compressed ) + [ + [ compressed-size dup length ] keep [ + dup length zlib.ffi:compress zlib-error + ] 3keep drop *ulong head + ] keep length ; + +: uncompress ( compressed -- byte-array ) + [ + length>> [ ] keep 2dup + ] [ + data>> dup length + zlib.ffi:uncompress zlib-error + ] bi *ulong head ; From d5dc7f5db51dca61fcb316298e0bc17aa5db38a6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 18:40:41 -0600 Subject: [PATCH 29/60] remove bad comment --- basis/zlib/zlib.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/basis/zlib/zlib.factor b/basis/zlib/zlib.factor index d5eed0b35b..b40d9c2a98 100755 --- a/basis/zlib/zlib.factor +++ b/basis/zlib/zlib.factor @@ -29,8 +29,6 @@ ERROR: zlib-failed n string ; : zlib-error ( n -- ) dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ; -! Compressed size is up to .001% larger plus 12 - : compressed-size ( byte-array -- n ) length 1001/1000 * ceiling 12 + ; From 201296c04043eeb281a28e1b844ca1ee8f9f0147 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 18:46:23 -0600 Subject: [PATCH 30/60] dllexport err_no and clear_err_no --- vm/io.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/vm/io.h b/vm/io.h index 08c9dd7807..dc7d69edee 100755 --- a/vm/io.h +++ b/vm/io.h @@ -1,7 +1,7 @@ void init_c_io(void); void io_error(void); -int err_no(void); -void clear_err_no(void); +DLLEXPORT int err_no(void); +DLLEXPORT void clear_err_no(void); void primitive_fopen(void); void primitive_fgetc(void); From c45b188581a2bcbff8a4d929e82e307bff66d72f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 22:43:11 -0600 Subject: [PATCH 31/60] fix furnace.utilities --- basis/furnace/utilities/utilities-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor index 6defba54d2..3a0d8804ef 100644 --- a/basis/furnace/utilities/utilities-docs.factor +++ b/basis/furnace/utilities/utilities-docs.factor @@ -27,7 +27,7 @@ HELP: hidden-form-field { $example "USING: furnace.utilities io ;" "\"bar\" \"foo\" hidden-form-field nl" - "" + "" } } ; From 0fc6dde17877ff2ff2194339197b7882e382308e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 22:56:46 -0600 Subject: [PATCH 32/60] make sure multipart parsing has enough bytes to compare against --- basis/mime/multipart/multipart.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor index eda7849a73..37d5e13129 100755 --- a/basis/mime/multipart/multipart.factor +++ b/basis/mime/multipart/multipart.factor @@ -42,7 +42,7 @@ ERROR: end-of-stream multipart ; [ t >>end-of-stream? ] if* ; : maybe-fill-bytes ( multipart -- multipart ) - dup bytes>> [ fill-bytes ] unless ; + dup bytes>> length 256 < [ fill-bytes ] when ; : split-bytes ( bytes separator -- leftover-bytes safe-to-dump ) dupd [ length ] bi@ 1- - short cut-slice swap ; @@ -65,6 +65,7 @@ ERROR: end-of-stream multipart ; [ dump-until-separator ] with-string-writer ; : read-header ( multipart -- multipart ) + maybe-fill-bytes dup bytes>> "--\r\n" sequence= [ t >>end-of-stream? ] [ From b073fe5eeebb803a4af2ac01f31b9db15dba7cbf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 23:37:18 -0600 Subject: [PATCH 33/60] the start of an endianness library, used by pack --- basis/endian/authors.txt | 1 + basis/endian/endian-tests.factor | 7 ++++ basis/endian/endian.factor | 67 ++++++++++++++++++++++++++++++++ 3 files changed, 75 insertions(+) create mode 100755 basis/endian/authors.txt create mode 100755 basis/endian/endian-tests.factor create mode 100755 basis/endian/endian.factor diff --git a/basis/endian/authors.txt b/basis/endian/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/endian/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/endian/endian-tests.factor b/basis/endian/endian-tests.factor new file mode 100755 index 0000000000..b066ce6995 --- /dev/null +++ b/basis/endian/endian-tests.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces tools.test endian ; +IN: endian.tests + +[ t ] [ [ endianness get big-endian = ] with-big-endian ] unit-test +[ t ] [ [ endianness get little-endian = ] with-little-endian ] unit-test diff --git a/basis/endian/endian.factor b/basis/endian/endian.factor new file mode 100755 index 0000000000..a832d6c0a2 --- /dev/null +++ b/basis/endian/endian.factor @@ -0,0 +1,67 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types namespaces io.binary fry +kernel math ; +IN: endian + +SINGLETONS: big-endian little-endian ; + +: native-endianness ( -- class ) + 1 *char 0 = big-endian little-endian ? ; + +: >signed ( x n -- y ) + 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; + +native-endianness \ native-endianness set-global + +SYMBOL: endianness + +\ native-endianness get-global endianness set-global + +HOOK: >native-endian native-endianness ( obj n -- str ) + +M: big-endian >native-endian >be ; + +M: little-endian >native-endian >le ; + +HOOK: unsigned-native-endian> native-endianness ( obj -- str ) + +M: big-endian unsigned-native-endian> be> ; + +M: little-endian unsigned-native-endian> le> ; + +: signed-native-endian> ( obj n -- str ) + [ unsigned-native-endian> ] dip >signed ; + +HOOK: >endian endianness ( obj n -- str ) + +M: big-endian >endian >be ; + +M: little-endian >endian >le ; + +HOOK: endian> endianness ( seq -- n ) + +M: big-endian endian> be> ; + +M: little-endian endian> le> ; + +HOOK: unsigned-endian> endianness ( obj -- str ) + +M: big-endian unsigned-endian> be> ; + +M: little-endian unsigned-endian> le> ; + +: signed-endian> ( obj n -- str ) + [ unsigned-endian> ] dip >signed ; + +: with-endianness ( endian quot -- ) + [ endianness ] dip with-variable ; inline + +: with-big-endian ( quot -- ) + big-endian swap with-endianness ; inline + +: with-little-endian ( quot -- ) + little-endian swap with-endianness ; inline + +: with-native-endian ( quot -- ) + \ native-endianness get-global swap with-endianness ; inline From 1979fbc61a1c5edb95b69c3cfd56b6f34fbebff8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 23:37:38 -0600 Subject: [PATCH 34/60] pack uses endian library now --- basis/pack/pack.factor | 38 +++++++------------------------------- 1 file changed, 7 insertions(+), 31 deletions(-) diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index 3cf7dbab4c..9078817206 100755 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -5,33 +5,9 @@ io.binary io.streams.string kernel math math.parser namespaces make parser prettyprint quotations sequences strings vectors words macros math.functions math.bitwise fry generalizations combinators.smart io.streams.byte-array io.encodings.binary -math.vectors combinators multiline ; +math.vectors combinators multiline endian ; IN: pack -SYMBOL: big-endian - -: big-endian? ( -- ? ) - 1 *char zero? ; - - - -: >signed ( x n -- y ) - 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; - -: >endian ( obj n -- str ) - big-endian get [ >be ] [ >le ] if ; inline - -: unsigned-endian> ( obj -- str ) - big-endian get [ be> ] [ le> ] if ; inline - -: signed-endian> ( obj n -- str ) - [ unsigned-endian> ] dip >signed ; - GENERIC: >n-byte-array ( obj n -- byte-array ) M: integer >n-byte-array ( m n -- byte-array ) >endian ; @@ -124,13 +100,13 @@ PRIVATE> [ ch>packed-length ] sigma ; : pack-native ( seq str -- seq ) - [ set-big-endian pack ] with-scope ; inline + '[ _ _ pack ] with-native-endian ; inline : pack-be ( seq str -- seq ) - [ big-endian on pack ] with-scope ; inline + '[ _ _ pack ] with-big-endian ; inline : pack-le ( seq str -- seq ) - [ big-endian off pack ] with-scope ; inline + '[ _ _ pack ] with-little-endian ; inline : unpack-native ( seq str -- seq ) - [ set-big-endian unpack ] with-scope ; inline + '[ _ _ unpack ] with-native-endian ; inline : unpack-be ( seq str -- seq ) - [ big-endian on unpack ] with-scope ; inline + '[ _ _ unpack ] with-big-endian ; inline : unpack-le ( seq str -- seq ) - [ big-endian off unpack ] with-scope ; inline + '[ _ _ unpack ] with-little-endian ; inline ERROR: packed-read-fail str bytes ; From 26f9df982d372c9e628112ba030bca1cd1514ec0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 23:41:59 -0600 Subject: [PATCH 35/60] the start of a tiff library --- extra/graphics/tiff/authors.txt | 1 + extra/graphics/tiff/rgb.tiff | Bin 0 -> 7916 bytes extra/graphics/tiff/tiff-tests.factor | 9 +++++++ extra/graphics/tiff/tiff.factor | 37 ++++++++++++++++++++++++++ 4 files changed, 47 insertions(+) create mode 100755 extra/graphics/tiff/authors.txt create mode 100755 extra/graphics/tiff/rgb.tiff create mode 100755 extra/graphics/tiff/tiff-tests.factor create mode 100755 extra/graphics/tiff/tiff.factor diff --git a/extra/graphics/tiff/authors.txt b/extra/graphics/tiff/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/graphics/tiff/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/graphics/tiff/rgb.tiff b/extra/graphics/tiff/rgb.tiff new file mode 100755 index 0000000000000000000000000000000000000000..71cbaa9d6e807156f7da39a5b116c9edb3b0c9e1 GIT binary patch literal 7916 zcmeHMcT^MWw+#r=t3X6RRC<#hYUoXR4bnxLK!S7xL9Q1Cgh&@qz)BGldhfkA=^#Z! zK)@iqNqZASuUB2~z4iWmzr{LhhA%Uj$#>4#XP|nBx#_MiZEA7RYB3o_UO{CL} z`4T$qJq*th{=a--LJ$twGab&~cKEvCxzs}f`5@Q@BhyF!+F=vt__71{97L%+4=m~D z9hNH{W8PYvFe3@79lyErV~3@*N%(>r?VZKZG6v9RZ*Ra8q*7{>GX|VIe3PpS&ivIS z?^&LeK8z>{n<{)a0r?nEQ~udCf$vVwgS=r^3G-_E+gFv%6EeNwXFF*rvu!upuv%ip*n(QxuB?^&#g&vGP+-HfAYmMg3;dw@dhhE- z7lwbw-s{xtPa_7r)H!eP`Og6gK+u9n01s3Mwe9YxK(>9joB zKdeLc<9)C@<7q0Hep4&BWl`vzmVJm$=HO><-HG59e(!f5if>oVZ3om$S$LU4yFUfB z6l=gYlP)(zSA5i*kFB}`&gj8--?pg!q=9lx+FljysPXB#G^_Z^{Jl=egHLZQq*MH? zz&b1YcLJ@dTns|TBqR4c*JPu(iMM5XZYP`);$PR#kngFaC#sJ^^AU;>)~n*xtyJ8_ zgN8LKgf-rzkuIv|$0MT6L^gz+X{JKj(Z6uh5RYky!n@H76=YN&;B{jqFI3Gn_ns-> zAw9#=76VV-Z^ral&R6F99bBr?r|#!f?Gx%}&eFp}zpivgw~@)XYqp4XMaSU&;ws2# z5J+~KQY~4Mk25G((Th^x1stmt|j!3 zn3?TIU2Z-`Rj)OL3|sh^%W!}nw#+C9n_&)Zl6+=1yy&%BG_v5cbKZ3439PDsAoe%t z#*CG4U{?J7rL!l)Kkw*nibUKm4yda4545WJw0(U_=79*PN46{W?3mDv0TTSwoF_Nt zxRx}mPAdSeBB}1~A4rySZO}MX9%TrnO5;^xeO)D}(L=2q4Yweb`9fnuR;$x_5sY@j zQ)X19O2);=MaLPRSBv3At~M_k2GX}KCVLjO<;}!oDr>#$;OwC8y!F>#zxagnd-|N? zAq#GNxhg*6bn)yDpWIWv)H`bKr1t~5&qp+|tUHoU6EOS^ED7D5XUbBvC3Mj+M}tgT zIwMoSCx+alb2+#uJ*T1aw1|J8o1<8s#a*iNu93(r(8azoEr2oKdCal2S^{+ zTjmlfAs3;83uWe75d|hW_ttk4Iz?d>S?^XMyU-Hm3i6NdZ>Pv|By@e+xVlL%YZatw zxv~`?29;GsA*Q`gy;~OrXCkO44(Fc9B|6nOThCLl zSSY(_wv|;q->`NBA?wKAmtFaq-^-h;L;dedY4C^ zmx~eaXwoylG@^P*wdfSO(GHh*^!AFk)mQgvag}qE@AG$_A#LnZiP$fp>4cL)>eaZB zz3f^s2H_lRd8}&lS8_0EVqG3FAv`K)pg8B=dI*0I>7~)4RnE)eEs(2iVhj*g*nLt|BIWMV+WdGTc5dgoSZ-=&yzFhx<>^Gg0Jc^bAq5qa103 z5%49dqze)%6&njDY1!!S8WOt+Jy)5FDT5LRsyx@2U;k>v9-#R0PnBC&T{-@-PKF6L zHYJNB9_da$Dz`Z8YyY&>1uU^Schk4p+-19*{PcuV{q)VVWf9CjS8hGQ#3yjSUaih~ zPXm;N{pX|vE6;pV$Q#wHAdEl)*QAYJM!`FqBEtB{Z|(hxJ9)cCX(!T9V?^ zzEn}CS#JvN`#q>Zb-wFCHif3val~CudYtpe5kGOXqVk6dCBr;EoovJo451$!=twn> zXd{cvSW7VRipLzyq;j@z^jYFNp^{yZb*Z$*59v?*Q%a~%LvUMD!sJLU#f!~Q@tj+*kO;6TGBYT4MnWKI}*+*BwowPYUChPr0f(W zt0t@D9%<;QB%)~4z|fxNME$+(E*~`c16|rq_5YS_CE8#;aL-ldNbVrOlWyY25n$?}ZY972532(Q(wWr;q zTIKb&^VZeLz(4?;{Q^uMMtBTEx5o2!wX%Z3#lM&yK0VZlC|xLfxL1ED7sX3pV@^m4|G4^YcZtKcK?CN`73|acryP!g9=M+|zHN!Nn_81g1t$JtN3sMo3 z#zwhvetY_A!`fH}yQTqw>V<2m)?Y^K|~ggp&d6t}(CC;y`wqLm_OjV06%O*r;&) zUmZ|inMv^#-r`bi>YBfU%rFV#cI=}Mny%SG7U;xIvI{7q&z{Y=(uR}89HrH13qnZG zCs||;FKjS~+ur7iNpXP;F{S3@_RS6qhpd6cwnxmQ_!@;Rn9 zmX}o(t?$mdmp_RVV%r9z4B>Nq9Cc&s&quQ%sF0!eTiCYH zr;29YNrH)U*&t_T{;R)1g!Wk8$nyRjE7^=80-Rr10EFqZ+=YvJ;C+2Q>M%tXfzV27 zDW*`RRDqq1uq(94E2%4-;9~25XFjg7Z@8QI(WzLX>qso6XWr9e{AmJgG#KgXn-c2a{0K2~%i1*M zX>4qL|5wS$8i(TOnQecEr|67$`HiQacT&cilPcG0ND3PFWk@?%ODhnsUhm3B!5Ks4 z1pHZ(cy4Knl8jBJ~ZoImFYoiuGR?%I}%~henp-PZbe_Kh1MZ!$Rs5> zCy>`EPg9Rcm1UN5HH3w>y6pS1<^I_N*VXXw)PGVO?=~^7acaikUy4(<6SyK0!E^di zEBiOaF+tnTgI@YgfaJ4QyY&(2H4oDG-qeEK3856#68)`%=M&NL4TV?nSZWY6rjr zU7nKWU0Vis?W#BSj3Q*zKSyW#+!j~{U)mf4n2}}qd$T&sj@gbsdfRe%b^nG)RUq@H z{i9k+QoP{OTt?DNXx9b>{wo(0-)RL(BpXqY08a<8BB7bW+XjKf^SyQa(om|#XkN`V zae+#mGfI^H#^6%zMr-=!XtV<@RHtH(QIh|j7+9r`q~@Yp3=idRiowrR=k9Y#ikE)@!e6@(oy!n)bSFp55QYUVS~$r*D4|d-0zeEUfQBVOI=MgK3nGUfx;k z2?ObapK0T1%?eE69z=*cga3%V$)@}?VNF{_F1Z8F3HxOE+d)B7x$7014&cb<>Ac+& zvG+z9??ATLwdQ$&$Bd9zru25pJo?eCNE~$9sE|olFd#)@gTErU!y=;h3ZjxYI4~rA z&~{P!ad+QveeiPO*MnJtv}=pskkz2MaYu^j3%^cRYrU&8BlG!>dMzt{3(_^<1jUtg zUycgdoX_93{z2JWhUfWE9gX0v7yKXBI;$v%8&22cD%>OykBXfosBH^hCU2y|lG5li z$=m4V&j*A#+BWm^q6j$K+1wl{9Nfliq!HsW)ydAby?gN$l}#XxLe%|uiO9e#cLwv%q8tHwzN?1u=F(YQQ>GZFygKdnBAzJUX$D1zi`%<}j7dCHg z(%H%88)v~v?P4bEbH*jeh2zt?;6WD{cy4Z0d_RTh5lhQ^kI~LGNgxh)zJ682yi=NDgZpDccfJmN-73-wOGy3uRUA`qGT){-M zs8b_TUsdQ!-Q})#Gk50dKn4l2p}K9$1nd6{VAi2{c;~6|=nQs<|Ck4%)4dlw8PwJxVzeAI5cDftMNqyvmhbQjRmnZ{WoKSn0j z5aLZ3kVU3WVv=diOFk*uH}yN3PDUmYhyo({2J24=>P2@xhqYQP?n=$6es9N7Tq(~i zSIf!RLe3!ijsdLr?#uqquSPBC+LiOhT-@j_hOn}=gLfrUwG3b7w7W0NqJ4f zRn=*cMVo#T)iaSv6MzQ7y6L zpJN!{>SNF_;+OK&0V9Kn^e zf#b1Kh<0?Fvxwio^{jt5Tt+j(sKZX7*EqZHvglXo>f6uewyDx)fvA~0(w>VJqOD{<4i$%hd~86zvVtfBA0SZxw^a9*n>W8%Y> z>A{g~#_-aECHEuPvzl%1og)4Xe4Gr<|E~EAdrnEI)_*9){IKPkJK=_l;LqbXyR|E+ z!3efw&5VD?5+LnZyK~YCxv@sKWqupKrD-{?`wd?IY5bNt^oC}%>Lr%c*~8w<7XQfg z1Dgyhfa|hpFPJ5NI2pe+Uqd85u-CW7x z`Qg_MUz|)sA(OA-+Lo}nj@8xOZ&bXV9i!6jc6Ib$3gkH^br#ig;1^y~9$%lzxU6%$ zU)lan>eQi(oh3rTQF7QhN33HUV`N=$#ju>p{27dm_HmK=?<2}j*Am*$ z1xbyTdp1EMXk+*t;Q;piNC?9ILI|qD( z0xS-&Bfu5`D+KHfV0QrfejWA*2L4w8>~Fws1C|chbHG>u<2*T*0oM@%hCMm~Yxi(L zAbva$r~w}YswV(}&_uwSkbpqMWFSx|IS3>{0X!41BtTEhrvia?s6ik<8W3oc7FYv= zKvMJ|kkvU5D1-rcPe8w-03Cwxj(-pE0N{t6IzEpAo`iF9J_Rh}0_UfIqbCyxbn0Xs zcmdGqlXKvuKvXz*Am9O@A>bO?lXdJpbig|Bbs%EEz$e%E0oRk literal 0 HcmV?d00001 diff --git a/extra/graphics/tiff/tiff-tests.factor b/extra/graphics/tiff/tiff-tests.factor new file mode 100755 index 0000000000..daee9a5d9e --- /dev/null +++ b/extra/graphics/tiff/tiff-tests.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2009 Your name. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test graphics.tiff ; +IN: graphics.tiff.tests + +: tiff-test-path ( -- path ) + "resource:extra/graphics/tiff/rgb.tiff" ; + + diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor new file mode 100755 index 0000000000..4676ea2748 --- /dev/null +++ b/extra/graphics/tiff/tiff.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators io io.encodings.binary io.files +kernel pack endian ; +IN: graphics.tiff + +TUPLE: tiff +endianness +the-answer +ifd-offset +; + + +ERROR: bad-tiff-magic bytes ; + +: tiff-endianness ( byte-array -- ? ) + { + { B{ CHAR: M CHAR: M } [ big-endian ] } + { B{ CHAR: I CHAR: I } [ little-endian ] } + [ bad-tiff-magic ] + } case ; + +: read-header ( tiff -- tiff ) + 2 read tiff-endianness [ >>endianness ] keep + [ + 2 read endian> >>the-answer + 4 read endian> >>ifd-offset + ] with-endianness ; + +: (load-tiff) ( path -- tiff ) + binary [ + tiff new + read-header + ] with-file-reader ; + +: load-tiff ( path -- tiff ) + (load-tiff) ; From a4b174d04b64df457331dd6e881b4e987d29422f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 00:58:02 -0600 Subject: [PATCH 36/60] spruce up unmaintained/openal -- can maybe go back into extra/ --- unmaintained/openal/macosx/macosx.factor | 6 +- unmaintained/openal/openal.factor | 252 +++++++++++------------ 2 files changed, 128 insertions(+), 130 deletions(-) diff --git a/unmaintained/openal/macosx/macosx.factor b/unmaintained/openal/macosx/macosx.factor index d2a0422d8d..abc0d65fb9 100644 --- a/unmaintained/openal/macosx/macosx.factor +++ b/unmaintained/openal/macosx/macosx.factor @@ -9,6 +9,6 @@ LIBRARY: alut FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ; M: macosx load-wav-file ( path -- format data size frequency ) - 0 f 0 0 - [ alutLoadWAVFile ] 4keep - >r >r >r *int r> *void* r> *int r> *int ; + 0 f 0 0 + [ alutLoadWAVFile ] 4keep + [ [ [ *int ] dip *void* ] dip *int ] dip *int ; diff --git a/unmaintained/openal/openal.factor b/unmaintained/openal/openal.factor index 40593d1e8d..8533308f26 100644 --- a/unmaintained/openal/openal.factor +++ b/unmaintained/openal/openal.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel arrays alien system combinators alien.syntax namespaces - alien.c-types sequences vocabs.loader shuffle combinators.lib + alien.c-types sequences vocabs.loader shuffle openal.backend specialized-arrays.uint ; IN: openal @@ -36,75 +36,75 @@ TYPEDEF: int ALenum TYPEDEF: float ALfloat TYPEDEF: double ALdouble -: AL_INVALID ( -- number ) -1 ; inline -: AL_NONE ( -- number ) 0 ; inline -: AL_FALSE ( -- number ) 0 ; inline -: AL_TRUE ( -- number ) 1 ; inline -: AL_SOURCE_RELATIVE ( -- number ) HEX: 202 ; inline -: AL_CONE_INNER_ANGLE ( -- nmber ) HEX: 1001 ; inline -: AL_CONE_OUTER_ANGLE ( -- number ) HEX: 1002 ; inline -: AL_PITCH ( -- number ) HEX: 1003 ; inline -: AL_POSITION ( -- number ) HEX: 1004 ; inline -: AL_DIRECTION ( -- number ) HEX: 1005 ; inline -: AL_VELOCITY ( -- number ) HEX: 1006 ; inline -: AL_LOOPING ( -- number ) HEX: 1007 ; inline -: AL_BUFFER ( -- number ) HEX: 1009 ; inline -: AL_GAIN ( -- number ) HEX: 100A ; inline -: AL_MIN_GAIN ( -- number ) HEX: 100D ; inline -: AL_MAX_GAIN ( -- number ) HEX: 100E ; inline -: AL_ORIENTATION ( -- number ) HEX: 100F ; inline -: AL_CHANNEL_MASK ( -- number ) HEX: 3000 ; inline -: AL_SOURCE_STATE ( -- number ) HEX: 1010 ; inline -: AL_INITIAL ( -- number ) HEX: 1011 ; inline -: AL_PLAYING ( -- number ) HEX: 1012 ; inline -: AL_PAUSED ( -- number ) HEX: 1013 ; inline -: AL_STOPPED ( -- number ) HEX: 1014 ; inline -: AL_BUFFERS_QUEUED ( -- number ) HEX: 1015 ; inline -: AL_BUFFERS_PROCESSED ( -- number ) HEX: 1016 ; inline -: AL_SEC_OFFSET ( -- number ) HEX: 1024 ; inline -: AL_SAMPLE_OFFSET ( -- number ) HEX: 1025 ; inline -: AL_BYTE_OFFSET ( -- number ) HEX: 1026 ; inline -: AL_SOURCE_TYPE ( -- number ) HEX: 1027 ; inline -: AL_STATIC ( -- number ) HEX: 1028 ; inline -: AL_STREAMING ( -- number ) HEX: 1029 ; inline -: AL_UNDETERMINED ( -- number ) HEX: 1030 ; inline -: AL_FORMAT_MONO8 ( -- number ) HEX: 1100 ; inline -: AL_FORMAT_MONO16 ( -- number ) HEX: 1101 ; inline -: AL_FORMAT_STEREO8 ( -- number ) HEX: 1102 ; inline -: AL_FORMAT_STEREO16 ( -- number ) HEX: 1103 ; inline -: AL_REFERENCE_DISTANCE ( -- number ) HEX: 1020 ; inline -: AL_ROLLOFF_FACTOR ( -- number ) HEX: 1021 ; inline -: AL_CONE_OUTER_GAIN ( -- number ) HEX: 1022 ; inline -: AL_MAX_DISTANCE ( -- number ) HEX: 1023 ; inline -: AL_FREQUENCY ( -- number ) HEX: 2001 ; inline -: AL_BITS ( -- number ) HEX: 2002 ; inline -: AL_CHANNELS ( -- number ) HEX: 2003 ; inline -: AL_SIZE ( -- number ) HEX: 2004 ; inline -: AL_UNUSED ( -- number ) HEX: 2010 ; inline -: AL_PENDING ( -- number ) HEX: 2011 ; inline -: AL_PROCESSED ( -- number ) HEX: 2012 ; inline -: AL_NO_ERROR ( -- number ) AL_FALSE ; inline -: AL_INVALID_NAME ( -- number ) HEX: A001 ; inline -: AL_ILLEGAL_ENUM ( -- number ) HEX: A002 ; inline -: AL_INVALID_ENUM ( -- number ) HEX: A002 ; inline -: AL_INVALID_VALUE ( -- number ) HEX: A003 ; inline -: AL_ILLEGAL_COMMAND ( -- number ) HEX: A004 ; inline -: AL_INVALID_OPERATION ( -- number ) HEX: A004 ; inline -: AL_OUT_OF_MEMORY ( -- number ) HEX: A005 ; inline -: AL_VENDOR ( -- number ) HEX: B001 ; inline -: AL_VERSION ( -- number ) HEX: B002 ; inline -: AL_RENDERER ( -- number ) HEX: B003 ; inline -: AL_EXTENSIONS ( -- number ) HEX: B004 ; inline -: AL_DOPPLER_FACTOR ( -- number ) HEX: C000 ; inline -: AL_DOPPLER_VELOCITY ( -- number ) HEX: C001 ; inline -: AL_SPEED_OF_SOUND ( -- number ) HEX: C003 ; inline -: AL_DISTANCE_MODEL ( -- number ) HEX: D000 ; inline -: AL_INVERSE_DISTANCE ( -- number ) HEX: D001 ; inline -: AL_INVERSE_DISTANCE_CLAMPED ( -- number ) HEX: D002 ; inline -: AL_LINEAR_DISTANCE ( -- number ) HEX: D003 ; inline -: AL_LINEAR_DISTANCE_CLAMPED ( -- number ) HEX: D004 ; inline -: AL_EXPONENT_DISTANCE ( -- number ) HEX: D005 ; inline -: AL_EXPONENT_DISTANCE_CLAMPED ( -- number ) HEX: D006 ; inline +CONSTANT: AL_INVALID -1 +CONSTANT: AL_NONE 0 +CONSTANT: AL_FALSE 0 +CONSTANT: AL_TRUE 1 +CONSTANT: AL_SOURCE_RELATIVE HEX: 202 +CONSTANT: AL_CONE_INNER_ANGLE HEX: 1001 +CONSTANT: AL_CONE_OUTER_ANGLE HEX: 1002 +CONSTANT: AL_PITCH HEX: 1003 +CONSTANT: AL_POSITION HEX: 1004 +CONSTANT: AL_DIRECTION HEX: 1005 +CONSTANT: AL_VELOCITY HEX: 1006 +CONSTANT: AL_LOOPING HEX: 1007 +CONSTANT: AL_BUFFER HEX: 1009 +CONSTANT: AL_GAIN HEX: 100A +CONSTANT: AL_MIN_GAIN HEX: 100D +CONSTANT: AL_MAX_GAIN HEX: 100E +CONSTANT: AL_ORIENTATION HEX: 100F +CONSTANT: AL_CHANNEL_MASK HEX: 3000 +CONSTANT: AL_SOURCE_STATE HEX: 1010 +CONSTANT: AL_INITIAL HEX: 1011 +CONSTANT: AL_PLAYING HEX: 1012 +CONSTANT: AL_PAUSED HEX: 1013 +CONSTANT: AL_STOPPED HEX: 1014 +CONSTANT: AL_BUFFERS_QUEUED HEX: 1015 +CONSTANT: AL_BUFFERS_PROCESSED HEX: 1016 +CONSTANT: AL_SEC_OFFSET HEX: 1024 +CONSTANT: AL_SAMPLE_OFFSET HEX: 1025 +CONSTANT: AL_BYTE_OFFSET HEX: 1026 +CONSTANT: AL_SOURCE_TYPE HEX: 1027 +CONSTANT: AL_STATIC HEX: 1028 +CONSTANT: AL_STREAMING HEX: 1029 +CONSTANT: AL_UNDETERMINED HEX: 1030 +CONSTANT: AL_FORMAT_MONO8 HEX: 1100 +CONSTANT: AL_FORMAT_MONO16 HEX: 1101 +CONSTANT: AL_FORMAT_STEREO8 HEX: 1102 +CONSTANT: AL_FORMAT_STEREO16 HEX: 1103 +CONSTANT: AL_REFERENCE_DISTANCE HEX: 1020 +CONSTANT: AL_ROLLOFF_FACTOR HEX: 1021 +CONSTANT: AL_CONE_OUTER_GAIN HEX: 1022 +CONSTANT: AL_MAX_DISTANCE HEX: 1023 +CONSTANT: AL_FREQUENCY HEX: 2001 +CONSTANT: AL_BITS HEX: 2002 +CONSTANT: AL_CHANNELS HEX: 2003 +CONSTANT: AL_SIZE HEX: 2004 +CONSTANT: AL_UNUSED HEX: 2010 +CONSTANT: AL_PENDING HEX: 2011 +CONSTANT: AL_PROCESSED HEX: 2012 +CONSTANT: AL_NO_ERROR AL_FALSE +CONSTANT: AL_INVALID_NAME HEX: A001 +CONSTANT: AL_ILLEGAL_ENUM HEX: A002 +CONSTANT: AL_INVALID_ENUM HEX: A002 +CONSTANT: AL_INVALID_VALUE HEX: A003 +CONSTANT: AL_ILLEGAL_COMMAND HEX: A004 +CONSTANT: AL_INVALID_OPERATION HEX: A004 +CONSTANT: AL_OUT_OF_MEMORY HEX: A005 +CONSTANT: AL_VENDOR HEX: B001 +CONSTANT: AL_VERSION HEX: B002 +CONSTANT: AL_RENDERER HEX: B003 +CONSTANT: AL_EXTENSIONS HEX: B004 +CONSTANT: AL_DOPPLER_FACTOR HEX: C000 +CONSTANT: AL_DOPPLER_VELOCITY HEX: C001 +CONSTANT: AL_SPEED_OF_SOUND HEX: C003 +CONSTANT: AL_DISTANCE_MODEL HEX: D000 +CONSTANT: AL_INVERSE_DISTANCE HEX: D001 +CONSTANT: AL_INVERSE_DISTANCE_CLAMPED HEX: D002 +CONSTANT: AL_LINEAR_DISTANCE HEX: D003 +CONSTANT: AL_LINEAR_DISTANCE_CLAMPED HEX: D004 +CONSTANT: AL_EXPONENT_DISTANCE HEX: D005 +CONSTANT: AL_EXPONENT_DISTANCE_CLAMPED HEX: D006 FUNCTION: void alEnable ( ALenum capability ) ; FUNCTION: void alDisable ( ALenum capability ) ; @@ -182,34 +182,34 @@ FUNCTION: void alDistanceModel ( ALenum distanceModel ) ; LIBRARY: alut -: ALUT_API_MAJOR_VERSION ( -- number ) 1 ; inline -: ALUT_API_MINOR_VERSION ( -- number ) 1 ; inline -: ALUT_ERROR_NO_ERROR ( -- number ) 0 ; inline -: ALUT_ERROR_OUT_OF_MEMORY ( -- number ) HEX: 200 ; inline -: ALUT_ERROR_INVALID_ENUM ( -- number ) HEX: 201 ; inline -: ALUT_ERROR_INVALID_VALUE ( -- number ) HEX: 202 ; inline -: ALUT_ERROR_INVALID_OPERATION ( -- number ) HEX: 203 ; inline -: ALUT_ERROR_NO_CURRENT_CONTEXT ( -- number ) HEX: 204 ; inline -: ALUT_ERROR_AL_ERROR_ON_ENTRY ( -- number ) HEX: 205 ; inline -: ALUT_ERROR_ALC_ERROR_ON_ENTRY ( -- number ) HEX: 206 ; inline -: ALUT_ERROR_OPEN_DEVICE ( -- number ) HEX: 207 ; inline -: ALUT_ERROR_CLOSE_DEVICE ( -- number ) HEX: 208 ; inline -: ALUT_ERROR_CREATE_CONTEXT ( -- number ) HEX: 209 ; inline -: ALUT_ERROR_MAKE_CONTEXT_CURRENT ( -- number ) HEX: 20A ; inline -: ALUT_ERROR_DESTRY_CONTEXT ( -- number ) HEX: 20B ; inline -: ALUT_ERROR_GEN_BUFFERS ( -- number ) HEX: 20C ; inline -: ALUT_ERROR_BUFFER_DATA ( -- number ) HEX: 20D ; inline -: ALUT_ERROR_IO_ERROR ( -- number ) HEX: 20E ; inline -: ALUT_ERROR_UNSUPPORTED_FILE_TYPE ( -- number ) HEX: 20F ; inline -: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE ( -- number ) HEX: 210 ; inline -: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA ( -- number ) HEX: 211 ; inline -: ALUT_WAVEFORM_SINE ( -- number ) HEX: 100 ; inline -: ALUT_WAVEFORM_SQUARE ( -- number ) HEX: 101 ; inline -: ALUT_WAVEFORM_SAWTOOTH ( -- number ) HEX: 102 ; inline -: ALUT_WAVEFORM_WHITENOISE ( -- number ) HEX: 103 ; inline -: ALUT_WAVEFORM_IMPULSE ( -- number ) HEX: 104 ; inline -: ALUT_LOADER_BUFFER ( -- number ) HEX: 300 ; inline -: ALUT_LOADER_MEMORY ( -- number ) HEX: 301 ; inline +CONSTANT: ALUT_API_MAJOR_VERSION 1 +CONSTANT: ALUT_API_MINOR_VERSION 1 +CONSTANT: ALUT_ERROR_NO_ERROR 0 +CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200 +CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201 +CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202 +CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203 +CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204 +CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205 +CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206 +CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207 +CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208 +CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209 +CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A +CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B +CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C +CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D +CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E +CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F +CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210 +CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211 +CONSTANT: ALUT_WAVEFORM_SINE HEX: 100 +CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101 +CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102 +CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103 +CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104 +CONSTANT: ALUT_LOADER_BUFFER HEX: 300 +CONSTANT: ALUT_LOADER_MEMORY HEX: 301 FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ; FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ; @@ -234,37 +234,37 @@ FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei SYMBOL: init : init-openal ( -- ) - init get-global expired? [ - f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when - 1337 init set-global - ] when ; + init get-global expired? [ + f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when + 1337 init set-global + ] when ; : exit-openal ( -- ) - init get-global expired? [ - alutExit 0 = [ "Could not close OpenAL" throw ] when - f init set-global - ] unless ; + init get-global expired? [ + alutExit 0 = [ "Could not close OpenAL" throw ] when + f init set-global + ] unless ; : ( n -- byte-array ) "ALuint" ; : gen-sources ( size -- seq ) - dup 2dup underlying>> alGenSources swap ; + dup 2dup underlying>> alGenSources swap ; : gen-buffers ( size -- seq ) - dup 2dup underlying>> alGenBuffers swap ; + dup 2dup underlying>> alGenBuffers swap ; : gen-buffer ( -- buffer ) 1 gen-buffers first ; : create-buffer-from-file ( filename -- buffer ) - alutCreateBufferFromFile dup AL_NONE = [ - "create-buffer-from-file failed" throw - ] when ; + alutCreateBufferFromFile dup AL_NONE = [ + "create-buffer-from-file failed" throw + ] when ; os macosx? "openal.macosx" "openal.other" ? require : create-buffer-from-wav ( filename -- buffer ) - gen-buffer dup rot load-wav-file - [ alBufferData ] 4keep alutUnloadWAV ; + gen-buffer dup rot load-wav-file + [ alBufferData ] 4keep alutUnloadWAV ; : queue-buffers ( source buffers -- ) [ length ] [ >uint-array underlying>> ] bi alSourceQueueBuffers ; @@ -273,29 +273,27 @@ os macosx? "openal.macosx" "openal.other" ? require 1array queue-buffers ; : set-source-param ( source param value -- ) - alSourcei ; + alSourcei ; : get-source-param ( source param -- value ) - 0 dup >r alGetSourcei r> *uint ; + 0 dup [ alGetSourcei ] dip *uint ; : set-buffer-param ( source param value -- ) - alBufferi ; + alBufferi ; : get-buffer-param ( source param -- value ) - 0 dup >r alGetBufferi r> *uint ; + 0 dup [ alGetBufferi ] dip *uint ; -: source-play ( source -- ) - alSourcePlay ; +: source-play ( source -- ) alSourcePlay ; -: source-stop ( source -- ) - alSourceStop ; +: source-stop ( source -- ) alSourceStop ; : check-error ( -- ) - alGetError dup ALUT_ERROR_NO_ERROR = [ - drop - ] [ - alGetString throw - ] if ; + alGetError dup ALUT_ERROR_NO_ERROR = [ + drop + ] [ + alGetString throw + ] if ; : source-playing? ( source -- bool ) - AL_SOURCE_STATE get-source-param AL_PLAYING = ; + AL_SOURCE_STATE get-source-param AL_PLAYING = ; From 5f39a714be67c05b9f8a86c64d4a4616af676fe3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 00:59:50 -0600 Subject: [PATCH 37/60] add some constants to unix --- basis/unix/unix.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 76613934af..a6a0147504 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -17,6 +17,10 @@ CONSTANT: MAP_FILE 0 CONSTANT: MAP_SHARED 1 CONSTANT: MAP_PRIVATE 2 +CONSTANT: SEEK_SET 0 +CONSTANT: SEEK_CUR 1 +CONSTANT: SEEK_END 2 + : MAP_FAILED ( -- alien ) -1 ; inline CONSTANT: NGROUPS_MAX 16 From f6f716c4e3a6e6457c9eecfb9e3ab418f5463af4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 01:03:12 -0600 Subject: [PATCH 38/60] unix support for stream seeking --- basis/io/backend/unix/unix.factor | 3 +++ basis/io/buffers/buffers.factor | 3 +++ basis/io/ports/ports.factor | 8 +++++++- core/io/encodings/encodings.factor | 2 ++ core/io/io.factor | 5 ++++- 5 files changed, 19 insertions(+), 2 deletions(-) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index d86a72c665..7340260b2e 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -46,6 +46,9 @@ M: fd cancel-operation ( fd -- ) 2bi ] if ; +M: unix (stream-seek) + handle>> fd>> swap SEEK_SET lseek io-error ; + SYMBOL: +retry+ ! just try the operation again without blocking SYMBOL: +input+ SYMBOL: +output+ diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor index 4df081b17d..11fbbf947c 100644 --- a/basis/io/buffers/buffers.factor +++ b/basis/io/buffers/buffers.factor @@ -27,6 +27,9 @@ M: buffer dispose* ptr>> free ; : buffer-empty? ( buffer -- ? ) fill>> zero? ; inline +: buffer-seek ( n buffer -- ) + (>>pos) ; inline + : buffer-consume ( n buffer -- ) [ + ] change-pos dup [ pos>> ] [ fill>> ] bi < diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 1fe717d5ee..dd95e37d72 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -4,7 +4,7 @@ USING: math kernel io sequences io.buffers io.timeouts generic byte-vectors system io.encodings math.order io.backend continuations classes byte-arrays namespaces splitting grouping dlists assocs io.encodings.binary summary accessors -destructors combinators ; +destructors combinators unix ; IN: io.ports SYMBOL: default-buffer-size @@ -93,6 +93,12 @@ M: input-port stream-read-until ( seps port -- str/f sep/f ) ] [ [ 2drop ] 2dip ] if ] if ; +HOOK: (stream-seek) os ( n stream -- ) + +M: input-port stream-seek ( n stream -- ) + dup check-disposed + 2dup buffer>> buffer-seek (stream-seek) ; + TUPLE: output-port < buffered-port ; : ( handle -- output-port ) diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 94d2115478..4693c672a4 100644 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -50,6 +50,8 @@ M: object f decoder boa ; M: decoder stream-read1 dup >decoder< decode-char fix-read1 ; +M: decoder stream-seek stream>> stream-seek ; + : fix-read ( stream string -- string ) over cr>> [ over cr- diff --git a/core/io/io.factor b/core/io/io.factor index 55cc336ef8..9b606194e0 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -15,6 +15,8 @@ GENERIC: stream-write ( seq stream -- ) GENERIC: stream-flush ( stream -- ) GENERIC: stream-nl ( stream -- ) +GENERIC: stream-seek ( n stream -- ) + : stream-print ( str stream -- ) [ stream-write ] keep stream-nl ; ! Default streams @@ -27,6 +29,7 @@ SYMBOL: error-stream : read ( n -- seq ) input-stream get stream-read ; : read-until ( seps -- seq sep/f ) input-stream get stream-read-until ; : read-partial ( n -- seq ) input-stream get stream-read-partial ; +: seek ( n -- ) input-stream get stream-seek ; : write1 ( elt -- ) output-stream get stream-write1 ; : write ( seq -- ) output-stream get stream-write ; @@ -82,4 +85,4 @@ PRIVATE> : stream-copy ( in out -- ) [ [ [ write ] each-block ] with-output-stream ] - curry with-input-stream ; \ No newline at end of file + curry with-input-stream ; From 790f3b867c7642505a91284fd854da6563ff40d7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 01:12:03 -0600 Subject: [PATCH 39/60] remove bogus unix depenedency, implement seeking on windows --- basis/io/backend/windows/nt/nt.factor | 2 ++ basis/io/ports/ports.factor | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index c6b24a0a11..52ab06e753 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -82,6 +82,8 @@ M: winnt init-io ( -- ) H{ } clone pending-overlapped set-global windows.winsock:init-winsock ; +M: winnt (stream-seek) ( n stream -- ) 2drop ; + : file-error? ( n -- eof? ) zero? [ GetLastError { diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index dd95e37d72..0f2dcc6e21 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -4,7 +4,7 @@ USING: math kernel io sequences io.buffers io.timeouts generic byte-vectors system io.encodings math.order io.backend continuations classes byte-arrays namespaces splitting grouping dlists assocs io.encodings.binary summary accessors -destructors combinators unix ; +destructors combinators ; IN: io.ports SYMBOL: default-buffer-size From ec7356446f275353781b80b31f6235d39d4756df Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 08:59:50 -0600 Subject: [PATCH 40/60] read ifds for tiff files --- extra/graphics/tiff/tiff.factor | 35 ++++++++++++++++++++++++++++++++- 1 file changed, 34 insertions(+), 1 deletion(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index 4676ea2748..34f6c3e4e0 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -1,15 +1,28 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.binary io.files -kernel pack endian ; +kernel pack endian tools.hexdump constructors sequences arrays +sorting.slots math.order ; IN: graphics.tiff TUPLE: tiff endianness the-answer ifd-offset +ifds ; +CONSTRUCTOR: tiff ( -- tiff ) + V{ } clone >>ifds ; + +TUPLE: ifd count ifd-entries ; + +CONSTRUCTOR: ifd ( count ifd-entries -- ifd ) ; + +TUPLE: ifd-entry tag type count offset ; + +CONSTRUCTOR: ifd-entry ( tag type count offset -- ifd-entry ) ; + ERROR: bad-tiff-magic bytes ; @@ -20,6 +33,9 @@ ERROR: bad-tiff-magic bytes ; [ bad-tiff-magic ] } case ; +: with-tiff-endianness ( tiff quot -- tiff ) + [ dup endianness>> ] dip with-endianness ; inline + : read-header ( tiff -- tiff ) 2 read tiff-endianness [ >>endianness ] keep [ @@ -27,10 +43,27 @@ ERROR: bad-tiff-magic bytes ; 4 read endian> >>ifd-offset ] with-endianness ; +: push-ifd ( tiff ifd -- tiff ) + over ifds>> push ; + +: read-ifd ( -- ifd ) + 2 read endian> + 2 read endian> + 4 read endian> + 4 read endian> ; + +: read-ifds ( tiff -- tiff ) + [ + dup ifd-offset>> seek + 2 read endian> + dup [ read-ifd ] replicate >>ifds + ] with-tiff-endianness ; + : (load-tiff) ( path -- tiff ) binary [ tiff new read-header + read-ifds ] with-file-reader ; : load-tiff ( path -- tiff ) From 723f08ca615e9d9f52345230a086956080fa14a8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 09:52:34 -0600 Subject: [PATCH 41/60] fix buffer-seek --- basis/io/buffers/buffers.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor index 11fbbf947c..bfb6c08471 100644 --- a/basis/io/buffers/buffers.factor +++ b/basis/io/buffers/buffers.factor @@ -28,7 +28,7 @@ M: buffer dispose* ptr>> free ; fill>> zero? ; inline : buffer-seek ( n buffer -- ) - (>>pos) ; inline + 0 >>fill 0 >>pos 2drop ; inline : buffer-consume ( n buffer -- ) [ + ] change-pos From 044fd02b5cf2200acd59cbd8bed098993f4be418 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 10:07:41 -0600 Subject: [PATCH 42/60] more work on tiff -- parse all the relevant ifd-entries --- extra/graphics/tiff/tiff.factor | 165 ++++++++++++++++++++++++++++++-- 1 file changed, 159 insertions(+), 6 deletions(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index 34f6c3e4e0..462f75ff79 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.binary io.files kernel pack endian tools.hexdump constructors sequences arrays -sorting.slots math.order ; +sorting.slots math.order math.parser prettyprint ; IN: graphics.tiff TUPLE: tiff @@ -10,20 +10,135 @@ endianness the-answer ifd-offset ifds -; +processed-ifds ; CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; -TUPLE: ifd count ifd-entries ; +TUPLE: ifd count ifd-entries next ; -CONSTRUCTOR: ifd ( count ifd-entries -- ifd ) ; +CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; TUPLE: ifd-entry tag type count offset ; CONSTRUCTOR: ifd-entry ( tag type count offset -- ifd-entry ) ; +TUPLE: photometric-interpretation color ; + +CONSTRUCTOR: photometric-interpretation ( color -- object ) ; + +SINGLETONS: white-is-zero black-is-zero rgb palette-color ; + +ERROR: bad-photometric-interpretation n ; + +: lookup-photometric-interpretation ( n -- singleton ) + { + { 0 [ white-is-zero ] } + { 1 [ black-is-zero ] } + { 2 [ rgb ] } + { 3 [ palette-color ] } + [ bad-photometric-interpretation ] + } case ; + + +TUPLE: compression method ; + +CONSTRUCTOR: compression ( method -- object ) ; + +SINGLETONS: no-compression CCITT-2 pack-bits lzw ; + +ERROR: bad-compression n ; + +: lookup-compression ( n -- compression ) + { + { 1 [ no-compression ] } + { 2 [ CCITT-2 ] } + { 5 [ lzw ] } + { 32773 [ pack-bits ] } + [ bad-compression ] + } case ; + +TUPLE: image-length n ; +CONSTRUCTOR: image-length ( n -- object ) ; + +TUPLE: image-width n ; +CONSTRUCTOR: image-width ( n -- object ) ; + +TUPLE: x-resolution n ; +CONSTRUCTOR: x-resolution ( n -- object ) ; + +TUPLE: y-resolution n ; +CONSTRUCTOR: y-resolution ( n -- object ) ; + +TUPLE: rows-per-strip n ; +CONSTRUCTOR: rows-per-strip ( n -- object ) ; + +TUPLE: strip-offsets n ; +CONSTRUCTOR: strip-offsets ( n -- object ) ; + +TUPLE: strip-byte-counts n ; +CONSTRUCTOR: strip-byte-counts ( n -- object ) ; + +TUPLE: bits-per-sample n ; +CONSTRUCTOR: bits-per-sample ( n -- object ) ; + +TUPLE: samples-per-pixel n ; +CONSTRUCTOR: samples-per-pixel ( n -- object ) ; + +SINGLETONS: no-resolution-unit +inch-resolution-unit +centimeter-resolution-unit ; + +TUPLE: resolution-unit type ; +CONSTRUCTOR: resolution-unit ( type -- object ) ; + +ERROR: bad-resolution-unit n ; + +: lookup-resolution-unit ( n -- object ) + { + { 1 [ no-resolution-unit ] } + { 2 [ inch-resolution-unit ] } + { 3 [ centimeter-resolution-unit ] } + [ bad-resolution-unit ] + } case ; + + +TUPLE: predictor type ; +CONSTRUCTOR: predictor ( type -- object ) ; + +SINGLETONS: no-predictor horizontal-differencing-predictor ; + +ERROR: bad-predictor n ; + +: lookup-predictor ( n -- object ) + { + { 1 [ no-predictor ] } + { 2 [ horizontal-differencing-predictor ] } + [ bad-predictor ] + } case ; + + +TUPLE: planar-configuration type ; +CONSTRUCTOR: planar-configuration ( type -- object ) ; + +SINGLETONS: chunky planar ; + +ERROR: bad-planar-configuration n ; + +: lookup-planar-configuration ( n -- object ) + { + { 1 [ no-predictor ] } + { 2 [ horizontal-differencing-predictor ] } + [ bad-predictor ] + } case ; + + +TUPLE: new-subfile-type n ; +CONSTRUCTOR: new-subfile-type ( n -- object ) ; + + + ERROR: bad-tiff-magic bytes ; : tiff-endianness ( byte-array -- ? ) @@ -56,14 +171,52 @@ ERROR: bad-tiff-magic bytes ; [ dup ifd-offset>> seek 2 read endian> - dup [ read-ifd ] replicate >>ifds + dup [ read-ifd ] replicate + 4 read endian> + [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ] with-tiff-endianness ; +! ERROR: unhandled-ifd-entry data n ; + +: unhandled-ifd-entry ; + +: ifd-entry-value ( ifd-entry -- n ) + dup count>> 1 = [ + offset>> + ] [ + [ offset>> seek ] [ count>> read ] bi + ] if ; + +: process-ifd-entry ( ifd-entry -- object ) + [ ifd-entry-value ] [ tag>> ] bi { + { 254 [ ] } + { 256 [ ] } + { 257 [ ] } + { 258 [ ] } + { 259 [ lookup-compression ] } + { 262 [ lookup-photometric-interpretation ] } + { 273 [ ] } + { 277 [ ] } + { 278 [ ] } + { 279 [ ] } + { 282 [ ] } + { 283 [ ] } + { 284 [ ] } + { 296 [ lookup-resolution-unit ] } + { 317 [ lookup-predictor ] } + [ unhandled-ifd-entry swap 2array ] + } case ; + +: process-ifd ( ifd -- processed-ifd ) + ifd-entries>> [ process-ifd-entry ] map ; + : (load-tiff) ( path -- tiff ) binary [ - tiff new + read-header read-ifds + dup ifds>> [ process-ifd ] map + >>processed-ifds ] with-file-reader ; : load-tiff ( path -- tiff ) From bc0521f88a52b7cef23ed77b75d165107ee36449 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 10:30:51 -0600 Subject: [PATCH 43/60] make seeking support the full lseek options, add seeking on output ports, remove seeking from decoders.. --- basis/io/backend/unix/unix.factor | 9 +++++++-- basis/io/ports/ports.factor | 13 +++++++------ core/io/encodings/encodings.factor | 2 -- core/io/io.factor | 6 ++++-- 4 files changed, 18 insertions(+), 12 deletions(-) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 7340260b2e..e39ae3e7f8 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -46,8 +46,13 @@ M: fd cancel-operation ( fd -- ) 2bi ] if ; -M: unix (stream-seek) - handle>> fd>> swap SEEK_SET lseek io-error ; +M: unix (stream-seek) ( n seek-type stream -- ) + swap { + { io:seek-absolute [ SEEK_SET ] } + { io:seek-relative [ SEEK_CUR ] } + { io:seek-end [ SEEK_END ] } + } case + [ handle>> fd>> swap ] dip lseek io-error ; SYMBOL: +retry+ ! just try the operation again without blocking SYMBOL: +input+ diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 0f2dcc6e21..4b0336ed26 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -93,12 +93,6 @@ M: input-port stream-read-until ( seps port -- str/f sep/f ) ] [ [ 2drop ] 2dip ] if ] if ; -HOOK: (stream-seek) os ( n stream -- ) - -M: input-port stream-seek ( n stream -- ) - dup check-disposed - 2dup buffer>> buffer-seek (stream-seek) ; - TUPLE: output-port < buffered-port ; : ( handle -- output-port ) @@ -126,6 +120,13 @@ M: output-port stream-write HOOK: (wait-to-write) io-backend ( port -- ) +HOOK: (stream-seek) os ( n seek-type stream -- ) + +M: port stream-seek ( n seek-type stream -- ) + dup check-disposed + [ nip buffer>> buffer-seek ] [ (stream-seek) ] 3bi ; + + GENERIC: shutdown ( handle -- ) M: object shutdown drop ; diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 4693c672a4..94d2115478 100644 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -50,8 +50,6 @@ M: object f decoder boa ; M: decoder stream-read1 dup >decoder< decode-char fix-read1 ; -M: decoder stream-seek stream>> stream-seek ; - : fix-read ( stream string -- string ) over cr>> [ over cr- diff --git a/core/io/io.factor b/core/io/io.factor index 9b606194e0..1cfdaf526e 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -15,7 +15,8 @@ GENERIC: stream-write ( seq stream -- ) GENERIC: stream-flush ( stream -- ) GENERIC: stream-nl ( stream -- ) -GENERIC: stream-seek ( n stream -- ) +SINGLETONS: seek-absolute seek-relative seek-end ; +GENERIC: stream-seek ( n seek-type stream -- ) : stream-print ( str stream -- ) [ stream-write ] keep stream-nl ; @@ -29,7 +30,8 @@ SYMBOL: error-stream : read ( n -- seq ) input-stream get stream-read ; : read-until ( seps -- seq sep/f ) input-stream get stream-read-until ; : read-partial ( n -- seq ) input-stream get stream-read-partial ; -: seek ( n -- ) input-stream get stream-seek ; +: seek-input ( n seek-type -- ) input-stream get stream-seek ; +: seek-output ( n seek-type -- ) output-stream get stream-seek ; : write1 ( elt -- ) output-stream get stream-write1 ; : write ( seq -- ) output-stream get stream-write ; From 44a4c20f230920da2b6b6b6fe45535b6dd476d2d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 11:00:16 -0600 Subject: [PATCH 44/60] update stream seeking on windows for new api --- basis/io/backend/windows/nt/nt.factor | 12 +++++++++++- basis/io/buffers/buffers.factor | 6 +++--- basis/io/ports/ports.factor | 2 +- basis/windows/kernel32/kernel32.factor | 2 +- 4 files changed, 16 insertions(+), 6 deletions(-) diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 52ab06e753..7479c0a0bb 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -82,7 +82,17 @@ M: winnt init-io ( -- ) H{ } clone pending-overlapped set-global windows.winsock:init-winsock ; -M: winnt (stream-seek) ( n stream -- ) 2drop ; +ERROR: invalid-file-size n ; + +: handle>file-size ( handle -- n ) + 0 [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ; + +M: winnt (stream-seek) ( n seek-type stream -- ) + swap { + { seek-absolute [ handle>> (>>ptr) ] } + { seek-relative [ handle>> [ + ] change-ptr drop ] } + { seek-end [ handle>> [ handle>> handle>file-size + ] keep (>>ptr) ] } + } case ; : file-error? ( n -- eof? ) zero? [ diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor index bfb6c08471..a647f27dfc 100644 --- a/basis/io/buffers/buffers.factor +++ b/basis/io/buffers/buffers.factor @@ -21,15 +21,15 @@ M: buffer dispose* ptr>> free ; : buffer-reset ( n buffer -- ) swap >>fill 0 >>pos drop ; +: buffer-reset-hard ( buffer -- ) + 0 >>fill 0 >>pos drop ; + : buffer-capacity ( buffer -- n ) [ size>> ] [ fill>> ] bi - ; inline : buffer-empty? ( buffer -- ? ) fill>> zero? ; inline -: buffer-seek ( n buffer -- ) - 0 >>fill 0 >>pos 2drop ; inline - : buffer-consume ( n buffer -- ) [ + ] change-pos dup [ pos>> ] [ fill>> ] bi < diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 4b0336ed26..1f7fc5f115 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -124,7 +124,7 @@ HOOK: (stream-seek) os ( n seek-type stream -- ) M: port stream-seek ( n seek-type stream -- ) dup check-disposed - [ nip buffer>> buffer-seek ] [ (stream-seek) ] 3bi ; + [ buffer>> buffer-reset-hard 2drop ] [ (stream-seek) ] 3bi ; GENERIC: shutdown ( handle -- ) diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index d3e823f844..3494e83e83 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -1235,7 +1235,7 @@ ALIAS: GetFileAttributesEx GetFileAttributesExW FUNCTION: BOOL GetFileInformationByHandle ( HANDLE hFile, LPBY_HANDLE_FILE_INFORMATION lpFileInformation ) ; FUNCTION: DWORD GetFileSize ( HANDLE hFile, LPDWORD lpFileSizeHigh ) ; -! FUNCTION: GetFileSizeEx +FUNCTION: BOOL GetFileSizeEx ( HANDLE hFile, PLARGE_INTEGER lpFileSize ) ; FUNCTION: BOOL GetFileTime ( HANDLE hFile, LPFILETIME lpCreationTime, LPFILETIME lpLastAccessTime, LPFILETIME lpLastWriteTime ) ; FUNCTION: DWORD GetFileType ( HANDLE hFile ) ; ! FUNCTION: GetFirmwareEnvironmentVariableA From 2820b9fc9981c9c6aef47844b858ae7b1e8a7ab9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 11:23:00 -0600 Subject: [PATCH 45/60] better error handling on unix seek, unit tests --- core/io/io-tests.factor | 65 ++++++++++++++++++++++++++++++++++++++++- core/io/io.factor | 1 + 2 files changed, 65 insertions(+), 1 deletion(-) diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 009ba3a9e7..8bfc52432d 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,6 +1,6 @@ USING: arrays io io.files kernel math parser strings system tools.test words namespaces make io.encodings.8-bit -io.encodings.binary sequences ; +io.encodings.binary sequences io.files.unique ; IN: io.tests [ f ] [ @@ -10,3 +10,66 @@ IN: io.tests ! Make sure we use correct to_c_string form when writing [ ] [ "\0" write ] unit-test + +[ B{ 3 2 3 4 5 } ] +[ + "seek-test1" unique-file binary + [ + [ + B{ 1 2 3 4 5 } write flush 0 seek-absolute seek-output + B{ 3 } write + ] with-file-writer + ] [ + file-contents + ] 2bi +] unit-test + +[ B{ 1 2 3 4 3 } ] +[ + "seek-test2" unique-file binary + [ + [ + B{ 1 2 3 4 5 } write flush -1 seek-relative seek-output + B{ 3 } write + ] with-file-writer + ] [ + file-contents + ] 2bi +] unit-test + +[ B{ 1 2 3 4 5 0 3 } ] +[ + "seek-test3" unique-file binary + [ + [ + B{ 1 2 3 4 5 } write flush 1 seek-relative seek-output + B{ 3 } write + ] with-file-writer + ] [ + file-contents + ] 2bi +] unit-test + +[ B{ 3 } ] +[ + B{ 1 2 3 4 5 } "seek-test4" unique-file binary [ + set-file-contents + ] [ + [ + -3 seek-end seek-input 1 read + ] with-file-reader + ] 2bi +] unit-test + +[ B{ 2 } ] +[ + B{ 1 2 3 4 5 } "seek-test5" unique-file binary [ + set-file-contents + ] [ + [ + 3 seek-absolute seek-input + -2 seek-relative seek-input + 1 read + ] with-file-reader + ] 2bi +] unit-test diff --git a/core/io/io.factor b/core/io/io.factor index 1cfdaf526e..11a2a6d1a8 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -15,6 +15,7 @@ GENERIC: stream-write ( seq stream -- ) GENERIC: stream-flush ( stream -- ) GENERIC: stream-nl ( stream -- ) +ERROR: bad-seek-type type ; SINGLETONS: seek-absolute seek-relative seek-end ; GENERIC: stream-seek ( n seek-type stream -- ) From 959ef7a7374de067b21ccfe4d403082641008811 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 11:24:12 -0600 Subject: [PATCH 46/60] better error handling for backends --- basis/io/backend/unix/unix.factor | 1 + basis/io/backend/windows/nt/nt.factor | 1 + 2 files changed, 2 insertions(+) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index e39ae3e7f8..3372f15cd9 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -51,6 +51,7 @@ M: unix (stream-seek) ( n seek-type stream -- ) { io:seek-absolute [ SEEK_SET ] } { io:seek-relative [ SEEK_CUR ] } { io:seek-end [ SEEK_END ] } + [ io:bad-seek-type ] } case [ handle>> fd>> swap ] dip lseek io-error ; diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 7479c0a0bb..7b96e883dd 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -92,6 +92,7 @@ M: winnt (stream-seek) ( n seek-type stream -- ) { seek-absolute [ handle>> (>>ptr) ] } { seek-relative [ handle>> [ + ] change-ptr drop ] } { seek-end [ handle>> [ handle>> handle>file-size + ] keep (>>ptr) ] } + [ bad-seek-type ] } case ; : file-error? ( n -- eof? ) From f499cab2fbc94ce34a98ec0b1de3aacf7acfb1c3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 11:35:13 -0600 Subject: [PATCH 47/60] seek -> new seeking --- extra/graphics/tiff/tiff.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index 462f75ff79..5c1fd4ec65 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -169,7 +169,7 @@ ERROR: bad-tiff-magic bytes ; : read-ifds ( tiff -- tiff ) [ - dup ifd-offset>> seek + dup ifd-offset>> seek-input 2 read endian> dup [ read-ifd ] replicate 4 read endian> @@ -184,7 +184,7 @@ ERROR: bad-tiff-magic bytes ; dup count>> 1 = [ offset>> ] [ - [ offset>> seek ] [ count>> read ] bi + [ offset>> seek-input ] [ count>> read ] bi ] if ; : process-ifd-entry ( ifd-entry -- object ) From 8097b52b12656b0ddd34a4e7b75947742d905acd Mon Sep 17 00:00:00 2001 From: Philipp Bruschweiler Date: Sun, 8 Feb 2009 01:03:35 +0100 Subject: [PATCH 48/60] initial infix vocab --- extra/infix/ast/ast.factor | 8 + extra/infix/infix-docs.factor | 38 ++++ extra/infix/infix-tests.factor | 45 +++++ extra/infix/infix.factor | 99 +++++++++++ extra/infix/parser/parser-tests.factor | 175 +++++++++++++++++++ extra/infix/parser/parser.factor | 30 ++++ extra/infix/tokenizer/tokenizer-tests.factor | 20 +++ extra/infix/tokenizer/tokenizer.factor | 21 +++ 8 files changed, 436 insertions(+) create mode 100644 extra/infix/ast/ast.factor create mode 100644 extra/infix/infix-docs.factor create mode 100644 extra/infix/infix-tests.factor create mode 100644 extra/infix/infix.factor create mode 100644 extra/infix/parser/parser-tests.factor create mode 100644 extra/infix/parser/parser.factor create mode 100644 extra/infix/tokenizer/tokenizer-tests.factor create mode 100644 extra/infix/tokenizer/tokenizer.factor diff --git a/extra/infix/ast/ast.factor b/extra/infix/ast/ast.factor new file mode 100644 index 0000000000..0bc22feeb7 --- /dev/null +++ b/extra/infix/ast/ast.factor @@ -0,0 +1,8 @@ +IN: infix.ast + +TUPLE: ast-number value ; +TUPLE: ast-local name ; +TUPLE: ast-array name index ; +TUPLE: ast-function name arguments ; +TUPLE: ast-op left right op ; +TUPLE: ast-negation term ; diff --git a/extra/infix/infix-docs.factor b/extra/infix/infix-docs.factor new file mode 100644 index 0000000000..7a4febb514 --- /dev/null +++ b/extra/infix/infix-docs.factor @@ -0,0 +1,38 @@ +USING: help.syntax help.markup prettyprint locals ; +IN: infix + +HELP: [infix +{ $syntax "[infix ... infix]" } +{ $description "Parses the infix code inside the brackets, converts it to stack code and executes it." } +{ $examples + { $example + "USING: infix prettyprint ;" + "IN: scratchpad" + "[infix 8+2*3 infix] ." + "14" + } $nl + { $link POSTPONE: [infix } " isn't that useful by itself, as it can only access literal numbers and no variables. It is designed to be used together with locals; for example with " { $link POSTPONE: :: } " :" + { $example + "USING: infix locals math.functions prettyprint ;" + "IN: scratchpad" + ":: quadratic-equation ( a b c -- z- z+ )" + " [infix (-b-sqrt(b*b-4*a*c)) / (2*a) infix]" + " [infix (-b+sqrt(b*b-4*a*c)) / (2*a) infix] ;" + "1 0 -1 quadratic-equation . ." + "1.0\n-1.0" + } +} ; + +HELP: [infix| +{ $syntax "[infix| binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n infix-expression infix]" } +{ $description "Introduces a set of lexical bindings and evaluates the body as a snippet of infix code. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [infix| } " form, as it is based on " { $link POSTPONE: [let } "." } +{ $examples + { $example + "USING: infix prettyprint ;" + "IN: scratchpad" + "[infix| pi [ 3.14 ] r [ 12 ] | r*r*pi infix] ." + "452.16" + } +} ; + +{ POSTPONE: [infix POSTPONE: [infix| } related-words diff --git a/extra/infix/infix-tests.factor b/extra/infix/infix-tests.factor new file mode 100644 index 0000000000..5ee6468131 --- /dev/null +++ b/extra/infix/infix-tests.factor @@ -0,0 +1,45 @@ +USING: infix infix.private kernel locals math math.functions +tools.test ; +IN: infix.tests + +[ 0 ] [ [infix 0 infix] ] unit-test +[ 0.5 ] [ [infix 3.0/6 infix] ] unit-test +[ 1+2/3 ] [ [infix 5/3 infix] ] unit-test +[ 3 ] [ [infix 2*7%3+1 infix] ] unit-test +[ 1 ] [ [infix 2- + 1 + -5* + 0 infix] ] unit-test + +[ 452.16 ] [ [infix| r [ 12 ] pi [ 3.14 ] | + r*r*pi infix] ] unit-test +[ 0 ] [ [infix| a [ 3 ] | 0 infix] ] unit-test +[ 4/5 ] [ [infix| x [ 3 ] f [ 12 ] | f/(f+x) infix] ] unit-test +[ 144 ] [ [infix| a [ 0 ] b [ 12 ] | b*b-a infix] ] unit-test + +[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | a[0] infix] ] unit-test +[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | 3*a[0]*2*a[1] infix] ] unit-test +[ 6 ] [ [infix| a [ { 0 1 2 3 } ] | a[0]+a[10%3]+a[3-1]+a[18/6] infix] ] unit-test +[ -1 ] [ [infix| a [ { 0 1 2 3 } ] | -a[+1] infix] ] unit-test + +[ 0.0 ] [ [infix sin(0) infix] ] unit-test +[ 10 ] [ [infix lcm(2,5) infix] ] unit-test +[ 1.0 ] [ [infix +cos(-0*+3) infix] ] unit-test + +[ f ] [ 2 \ gcd check-word ] unit-test ! multiple return values +[ f ] [ 1 \ drop check-word ] unit-test ! no return value +[ f ] [ 1 \ lcm check-word ] unit-test ! takes 2 args +: no-stack-effect-declared + ; +[ 0 \ no-stack-effect-declared check-word ] must-fail + +: qux ( -- x ) 2 ; +[ t ] [ 0 \ qux check-word ] unit-test +[ 8 ] [ [infix qux()*3+2 infix] ] unit-test +: foobar ( x -- y ) 1 + ; +[ t ] [ 1 \ foobar check-word ] unit-test +[ 4 ] [ [infix foobar(3*5%12) infix] ] unit-test +: stupid_function ( x x x x x -- y ) + + + + ; +[ t ] [ 5 \ stupid_function check-word ] unit-test +[ 10 ] [ [infix stupid_function (0, 1, 2, 3, 4) infix] ] unit-test + +[ -1 ] [ [let | a [ 1 ] | [infix -a infix] ] ] unit-test diff --git a/extra/infix/infix.factor b/extra/infix/infix.factor new file mode 100644 index 0000000000..31cd1cbe1f --- /dev/null +++ b/extra/infix/infix.factor @@ -0,0 +1,99 @@ +USING: accessors assocs combinators combinators.short-circuit +effects fry infix.parser infix.ast kernel locals.parser +locals.types math multiline namespaces parser quotations +sequences summary words ; +IN: infix + +local-word ( string -- word ) + locals get at? [ local-not-defined ] unless ; + +: select-op ( string -- word ) + { + { "+" [ [ + ] ] } + { "-" [ [ - ] ] } + { "*" [ [ * ] ] } + { "/" [ [ / ] ] } + [ drop [ mod ] ] + } case ; + +GENERIC: infix-codegen ( ast -- quot/number ) + +M: ast-number infix-codegen value>> ; + +M: ast-local infix-codegen + name>> >local-word ; + +M: ast-array infix-codegen + [ index>> infix-codegen prepare-operand ] + [ name>> >local-word ] bi '[ @ _ nth ] ; + +M: ast-op infix-codegen + [ left>> infix-codegen ] [ right>> infix-codegen ] + [ op>> select-op ] tri + 2over [ number? ] both? [ call ] [ + [ [ prepare-operand ] bi@ ] dip '[ @ @ @ ] + ] if ; + +M: ast-negation infix-codegen + term>> infix-codegen + { + { [ dup number? ] [ neg ] } + { [ dup callable? ] [ '[ @ neg ] ] } + [ '[ _ neg ] ] ! local word + } cond ; + +ERROR: bad-stack-effect word ; +M: bad-stack-effect summary + drop "Words used in infix must declare a stack effect and return exactly one value" ; + +: check-word ( argcount word -- ? ) + dup stack-effect [ ] [ bad-stack-effect ] ?if + [ in>> length ] [ out>> length ] bi + [ = ] dip 1 = and ; + +: find-and-check ( args argcount string -- quot ) + dup search [ ] [ no-word ] ?if + [ nip ] [ check-word ] 2bi + [ 1quotation compose ] [ bad-stack-effect ] if ; + +: arguments-codegen ( seq -- quot ) + dup empty? [ drop [ ] ] [ + [ infix-codegen prepare-operand ] + [ compose ] map-reduce + ] if ; + +M: ast-function infix-codegen + [ arguments>> [ arguments-codegen ] [ length ] bi ] + [ name>> ] bi find-and-check ; + +: [infix-parse ( end -- result/quot ) + parse-multiline-string build-infix-ast + infix-codegen prepare-operand ; +PRIVATE> + +: [infix + "infix]" [infix-parse parsed \ call parsed ; parsing + + + +: [infix| + "|" parse-bindings "infix]" parse-infix-locals + parsed-lambda ; parsing diff --git a/extra/infix/parser/parser-tests.factor b/extra/infix/parser/parser-tests.factor new file mode 100644 index 0000000000..0a0288c41b --- /dev/null +++ b/extra/infix/parser/parser-tests.factor @@ -0,0 +1,175 @@ +USING: infix.ast infix.parser infix.tokenizer tools.test ; +IN: infix.parser.tests + +\ parse-infix must-infer +\ build-infix-ast must-infer + +[ T{ ast-number { value 1 } } ] [ "1" build-infix-ast ] unit-test +[ T{ ast-negation f T{ ast-number { value 1 } } } ] +[ "-1" build-infix-ast ] unit-test +[ T{ ast-op + { left + T{ ast-op + { left T{ ast-number { value 1 } } } + { right T{ ast-number { value 2 } } } + { op "+" } + } + } + { right T{ ast-number { value 4 } } } + { op "+" } +} ] [ "1+2+4" build-infix-ast ] unit-test + +[ T{ ast-op + { left T{ ast-number { value 1 } } } + { right + T{ ast-op + { left T{ ast-number { value 2 } } } + { right T{ ast-number { value 3 } } } + { op "*" } + } + } + { op "+" } +} ] [ "1+2*3" build-infix-ast ] unit-test + +[ T{ ast-op + { left T{ ast-number { value 1 } } } + { right T{ ast-number { value 2 } } } + { op "+" } +} ] [ "(1+2)" build-infix-ast ] unit-test + +[ T{ ast-local { name "foo" } } ] [ "foo" build-infix-ast ] unit-test +[ "-" build-infix-ast ] must-fail + +[ T{ ast-function + { name "foo" } + { arguments + V{ + T{ ast-op + { left T{ ast-number { value 1 } } } + { right T{ ast-number { value 2 } } } + { op "+" } + } + T{ ast-op + { left T{ ast-number { value 2 } } } + { right T{ ast-number { value 3 } } } + { op "%" } + } + } + } +} ] [ "foo (1+ 2,2%3) " build-infix-ast ] unit-test + +[ T{ ast-op + { left + T{ ast-op + { left + T{ ast-function + { name "bar" } + { arguments V{ } } + } + } + { right + T{ ast-array + { name "baz" } + { index + T{ ast-op + { left + T{ ast-op + { left + T{ ast-number + { value 2 } + } + } + { right + T{ ast-number + { value 3 } + } + } + { op "/" } + } + } + { right + T{ ast-number { value 4 } } + } + { op "+" } + } + } + } + } + { op "+" } + } + } + { right T{ ast-number { value 2 } } } + { op "/" } +} ] [ "(bar() + baz[2/ 3+4 ] )/2" build-infix-ast ] unit-test + +[ T{ ast-op + { left T{ ast-number { value 1 } } } + { right + T{ ast-op + { left T{ ast-number { value 2 } } } + { right T{ ast-number { value 3 } } } + { op "/" } + } + } + { op "+" } +} ] [ "1\n+\n2\r/\t3" build-infix-ast ] unit-test + +[ T{ ast-negation + { term + T{ ast-function + { name "foo" } + { arguments + V{ + T{ ast-number { value 2 } } + T{ ast-negation + { term T{ ast-number { value 3 } } } + } + } + } + } + } +} ] [ "-foo(+2,-3)" build-infix-ast ] unit-test + +[ T{ ast-array + { name "arr" } + { index + T{ ast-op + { left + T{ ast-negation + { term + T{ ast-op + { left + T{ ast-function + { name "foo" } + { arguments + V{ + T{ ast-number + { value 2 } + } + } + } + } + } + { right + T{ ast-negation + { term + T{ ast-number + { value 1 } + } + } + } + } + { op "+" } + } + } + } + } + { right T{ ast-number { value 3 } } } + { op "/" } + } + } +} ] [ "+arr[-(foo(2)+-1)/3]" build-infix-ast ] unit-test + +[ "foo bar baz" build-infix-ast ] must-fail +[ "1+2/4+" build-infix-ast ] must-fail +[ "quaz(2/3,)" build-infix-ast ] must-fail diff --git a/extra/infix/parser/parser.factor b/extra/infix/parser/parser.factor new file mode 100644 index 0000000000..beaf3c335d --- /dev/null +++ b/extra/infix/parser/parser.factor @@ -0,0 +1,30 @@ +USING: infix.ast infix.tokenizer kernel math peg.ebnf sequences +strings vectors ; +IN: infix.parser + +EBNF: parse-infix +Number = . ?[ ast-number? ]? +Identifier = . ?[ string? ]? +Array = Identifier:i "[" Sum:s "]" => [[ i s ast-array boa ]] +Function = Identifier:i "(" FunArgs?:a ")" => [[ i a [ V{ } ] unless* ast-function boa ]] + +FunArgs = FunArgs:a "," Sum:s => [[ s a push a ]] + | Sum:s => [[ s 1vector ]] + +Terminal = ("-"|"+"):op Terminal:term => [[ term op "-" = [ ast-negation boa ] when ]] + | "(" Sum:s ")" => [[ s ]] + | Number | Array | Function + | Identifier => [[ ast-local boa ]] + +Product = Product:p ("*"|"/"|"%"):op Terminal:term => [[ p term op ast-op boa ]] + | Terminal + +Sum = Sum:s ("+"|"-"):op Product:p => [[ s p op ast-op boa ]] + | Product + +End = !(.) +Expression = Sum End +;EBNF + +: build-infix-ast ( string -- ast ) + tokenize-infix parse-infix ; diff --git a/extra/infix/tokenizer/tokenizer-tests.factor b/extra/infix/tokenizer/tokenizer-tests.factor new file mode 100644 index 0000000000..7e1fb005ef --- /dev/null +++ b/extra/infix/tokenizer/tokenizer-tests.factor @@ -0,0 +1,20 @@ +USING: infix.ast infix.tokenizer tools.test ; +IN: infix.tokenizer.tests + +\ tokenize-infix must-infer +[ V{ T{ ast-number f 1 } } ] [ "1" tokenize-infix ] unit-test +[ V{ T{ ast-number f 1.02 } CHAR: * T{ ast-number f 3 } } ] [ "1.02*3" tokenize-infix ] unit-test +[ V{ T{ ast-number f 3 } CHAR: / CHAR: ( T{ ast-number f 3 } CHAR: + T{ ast-number f 4 } CHAR: ) } ] +[ "3/(3+4)" tokenize-infix ] unit-test +[ V{ "foo" CHAR: ( "x" CHAR: , "y" CHAR: , "z" CHAR: ) } ] [ "foo(x,y,z)" tokenize-infix ] unit-test +[ V{ "arr" CHAR: [ "x" CHAR: + T{ ast-number f 3 } CHAR: ] } ] +[ "arr[x+3]" tokenize-infix ] unit-test +[ "1.0.4" tokenize-infix ] must-fail +[ V{ CHAR: + CHAR: ] T{ ast-number f 3.4 } CHAR: , "bar" } ] +[ "+]3.4,bar" tokenize-infix ] unit-test +[ V{ "baz_34c" } ] [ "baz_34c" tokenize-infix ] unit-test +[ V{ T{ ast-number f 34 } "c_baz" } ] [ "34c_baz" tokenize-infix ] unit-test +[ V{ CHAR: ( T{ ast-number f 1 } CHAR: + T{ ast-number f 2 } CHAR: ) } ] +[ "(1+2)" tokenize-infix ] unit-test +[ V{ T{ ast-number f 1 } CHAR: + T{ ast-number f 2 } CHAR: / T{ ast-number f 3 } } ] +[ "1\n+\r2\t/ 3" tokenize-infix ] unit-test diff --git a/extra/infix/tokenizer/tokenizer.factor b/extra/infix/tokenizer/tokenizer.factor new file mode 100644 index 0000000000..8c1a1b4a18 --- /dev/null +++ b/extra/infix/tokenizer/tokenizer.factor @@ -0,0 +1,21 @@ +USING: infix.ast kernel peg peg.ebnf math.parser sequences +strings ; +IN: infix.tokenizer + +EBNF: tokenize-infix +Letter = [a-zA-Z] +Digit = [0-9] +Digits = Digit+ +Number = Digits '.' Digits => [[ concat >string string>number ast-number boa ]] + | Digits => [[ >string string>number ast-number boa ]] +Space = " " | "\n" | "\r" | "\t" +Spaces = Space* => [[ ignore ]] +NameFirst = Letter | "_" => [[ CHAR: _ ]] +NameRest = NameFirst | Digit +Name = NameFirst NameRest* => [[ first2 swap prefix >string ]] +Special = [+*/%(),] | "-" => [[ CHAR: - ]] + | "[" => [[ CHAR: [ ]] | "]" => [[ CHAR: ] ]] +Tok = Spaces (Name | Number | Special ) +End = !(.) +Toks = Tok* Spaces End +;EBNF From 36e5536110a213126cbcee0fd4084b7250799bd0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 7 Feb 2009 20:39:32 -0600 Subject: [PATCH 49/60] Mention string encoding in >string --- core/strings/strings-docs.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/core/strings/strings-docs.factor b/core/strings/strings-docs.factor index d40cd982d8..9a1671b126 100644 --- a/core/strings/strings-docs.factor +++ b/core/strings/strings-docs.factor @@ -53,8 +53,9 @@ HELP: 1string HELP: >string { $values { "seq" "a sequence of characters" } { "str" string } } -{ $description "Outputs a freshly-allocated string with the same elements as a given sequence." } -{ $errors "Throws an error if the sequence contains elements other than real numbers." } ; +{ $description "Outputs a freshly-allocated string with the same elements as a given sequence, by interpreting the sequence elements as Unicode code points." } +{ $notes "This operation is only appropriate if the underlying sequence holds Unicode code points, which is rare unless it is a " { $link slice } " of another string. To convert a sequence of bytes to a string, use the words documented in " { $link "io.encodings.string" } "." } +{ $errors "Throws an error if the sequence contains elements other than integers." } ; HELP: resize-string ( n str -- newstr ) { $values { "n" "a non-negative integer" } { "str" string } { "newstr" string } } From f08c8dd66d0c840558a61e8b8dad1a7da0bb3841 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Feb 2009 21:23:35 -0600 Subject: [PATCH 50/60] fix some compile bugz --- extra/graphics/tiff/tiff.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index 5c1fd4ec65..e66ebcc6bd 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -169,7 +169,7 @@ ERROR: bad-tiff-magic bytes ; : read-ifds ( tiff -- tiff ) [ - dup ifd-offset>> seek-input + dup ifd-offset>> seek-absolute seek-input 2 read endian> dup [ read-ifd ] replicate 4 read endian> @@ -184,7 +184,7 @@ ERROR: bad-tiff-magic bytes ; dup count>> 1 = [ offset>> ] [ - [ offset>> seek-input ] [ count>> read ] bi + [ offset>> seek-absolute seek-input ] [ count>> read ] bi ] if ; : process-ifd-entry ( ifd-entry -- object ) From f36ec3f0c5da15143f2f6bd1ab3ca88006f14255 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 7 Feb 2009 23:04:55 -0600 Subject: [PATCH 51/60] Add nsum, nspread and nweave to generalizations --- .../generalizations-docs.factor | 52 +++++++++++++++---- .../generalizations-tests.factor | 9 ++++ basis/generalizations/generalizations.factor | 19 ++++++- 3 files changed, 67 insertions(+), 13 deletions(-) diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 912f69587e..ac8e14c05a 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -30,6 +30,10 @@ HELP: narray { nsequence narray } related-words +HELP: nsum +{ $values { "n" integer } } +{ $description "Adds the top " { $snippet "n" } " stack values." } ; + HELP: firstn { $values { "n" integer } } { $description "A generalization of " { $link first } ", " @@ -238,6 +242,11 @@ HELP: ncleave } } ; +HELP: nspread +{ $values { "quots" "a sequence of quotations" } { "n" integer } } +{ $description "A generalization of " { $link spread } " that can work for any quotation arity." +} ; + HELP: mnswap { $values { "m" integer } { "n" integer } } { $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." } @@ -250,6 +259,17 @@ HELP: mnswap } } ; +HELP: nweave +{ $values { "n" integer } } +{ $description "Copies the top " { $snippet "n" } " stack elements underneath each one of the " { $snippet "n" } " elements below." } +{ $examples + { $example + "USING: arrays kernel generalizations prettyprint ;" + "\"e1\" \"e2\" \"o1\" \"o2\" 2 nweave [ 3array ] 3dip 3array 2array ." + "{ { \"e1\" \"o1\" \"o2\" } { \"e2\" \"o1\" \"o2\" } }" + } +} ; + HELP: n*quot { $values { "n" integer } { "seq" sequence } @@ -299,18 +319,14 @@ HELP: ntuck } { $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ; -ARTICLE: "generalizations" "Generalized shuffle words and combinators" -"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in " -"macros where the arity of the input quotations depends on an " -"input parameter." -$nl -"Generalized sequence operations:" +ARTICLE: "sequence-generalizations" "Generalized sequence operations" { $subsection narray } { $subsection nsequence } { $subsection firstn } { $subsection nappend } -{ $subsection nappend-as } -"Generated stack shuffle operations:" +{ $subsection nappend-as } ; + +ARTICLE: "shuffle-generalizations" "Generalized shuffle words" { $subsection ndup } { $subsection npick } { $subsection nrot } @@ -319,14 +335,28 @@ $nl { $subsection ndrop } { $subsection ntuck } { $subsection mnswap } -"Generalized combinators:" +{ $subsection nweave } ; + +ARTICLE: "combinator-generalizations" "Generalized combinators" { $subsection ndip } { $subsection nslip } { $subsection nkeep } { $subsection napply } { $subsection ncleave } -"Generalized quotation construction:" +{ $subsection nspread } ; + +ARTICLE: "other-generalizations" "Additional generalizations" { $subsection ncurry } -{ $subsection nwith } ; +{ $subsection nwith } +{ $subsection nsum } ; + +ARTICLE: "generalizations" "Generalized shuffle words and combinators" +"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in " +"macros where the arity of the input quotations depends on an " +"input parameter." +{ $subsection "sequence-generalizations" } +{ $subsection "shuffle-generalizations" } +{ $subsection "combinator-generalizations" } +{ $subsection "other-generalizations" } ; ABOUT: "generalizations" diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 35e02f08b4..7ede271d01 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -53,3 +53,12 @@ IN: generalizations.tests [ 4 nappend ] must-infer [ 4 { } nappend-as ] must-infer + +[ 17 ] [ 3 1 3 3 7 5 nsum ] unit-test +{ 4 1 } [ 4 nsum ] must-infer-as + +[ "e1" "o1" "o2" "e2" "o1" "o2" ] [ "e1" "e2" "o1" "o2" 2 nweave ] unit-test +{ 3 5 } [ 2 nweave ] must-infer-as + +[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ] +[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test \ No newline at end of file diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 4692fd20db..9b2b2456c2 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo +! Copyright (C) 2007, 2009 Chris Double, Doug Coleman, Eduardo ! Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private math combinators @@ -23,6 +23,9 @@ MACRO: nsequence ( n seq -- ) MACRO: narray ( n -- ) '[ _ { } nsequence ] ; +MACRO: nsum ( n -- ) + 1- [ + ] n*quot ; + MACRO: firstn ( n -- ) dup zero? [ drop [ drop ] ] [ [ [ '[ [ _ ] dip nth-unsafe ] ] map ] @@ -70,11 +73,23 @@ MACRO: ncleave ( quots n -- ) [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi compose ; +MACRO: nspread ( quots n -- ) + over empty? [ 2drop [ ] ] [ + [ [ but-last ] dip ] + [ [ peek ] dip ] 2bi + swap + '[ [ _ _ nspread ] _ ndip @ ] + ] if ; + MACRO: napply ( quot n -- ) swap spread>quot ; MACRO: mnswap ( m n -- ) - 1+ '[ _ -nrot ] spread>quot ; + 1+ '[ _ -nrot ] swap '[ _ _ napply ] ; + +MACRO: nweave ( n -- ) + [ dup [ '[ _ _ mnswap ] ] with map ] keep + '[ _ _ ncleave ] ; : nappend-as ( n exemplar -- seq ) [ narray concat ] dip like ; inline From aa6166adf20004d792503fd90e8778047d5f7578 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 8 Feb 2009 00:20:56 -0600 Subject: [PATCH 52/60] Fix typo --- extra/websites/concatenative/concatenative.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index c1d62c6cda..35a1129338 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -65,7 +65,7 @@ SYMBOL: dh-file "concatenative.org" 25 smtp-server set-global "noreply@concatenative.org" lost-password-from set-global "website@concatenative.org" insomniac-sender set-global - "slava@factorcode.org" insomniac-recipients set-global + { "slava@factorcode.org" } insomniac-recipients set-global init-factor-db ; : init-testing ( -- ) From 16312f67111b3954507865cf5cba2aceb379db9d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 10:35:30 -0600 Subject: [PATCH 53/60] clean up stream-seek with some suggestions from slava --- basis/io/backend/unix/unix.factor | 4 ++-- basis/io/backend/windows/nt/nt.factor | 8 ++++---- basis/io/buffers/buffers.factor | 3 --- basis/io/ports/ports.factor | 13 +++++++++---- 4 files changed, 15 insertions(+), 13 deletions(-) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 3372f15cd9..f5e6426859 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -46,14 +46,14 @@ M: fd cancel-operation ( fd -- ) 2bi ] if ; -M: unix (stream-seek) ( n seek-type stream -- ) +M: unix seek-handle ( n seek-type handle -- ) swap { { io:seek-absolute [ SEEK_SET ] } { io:seek-relative [ SEEK_CUR ] } { io:seek-end [ SEEK_END ] } [ io:bad-seek-type ] } case - [ handle>> fd>> swap ] dip lseek io-error ; + [ fd>> swap ] dip lseek io-error ; SYMBOL: +retry+ ! just try the operation again without blocking SYMBOL: +input+ diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 7b96e883dd..107f1902e3 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -87,11 +87,11 @@ ERROR: invalid-file-size n ; : handle>file-size ( handle -- n ) 0 [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ; -M: winnt (stream-seek) ( n seek-type stream -- ) +M: winnt seek-handle ( n seek-type handle -- ) swap { - { seek-absolute [ handle>> (>>ptr) ] } - { seek-relative [ handle>> [ + ] change-ptr drop ] } - { seek-end [ handle>> [ handle>> handle>file-size + ] keep (>>ptr) ] } + { seek-absolute [ (>>ptr) ] } + { seek-relative [ [ + ] change-ptr drop ] } + { seek-end [ [ handle>> handle>file-size + ] keep (>>ptr) ] } [ bad-seek-type ] } case ; diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor index a647f27dfc..4df081b17d 100644 --- a/basis/io/buffers/buffers.factor +++ b/basis/io/buffers/buffers.factor @@ -21,9 +21,6 @@ M: buffer dispose* ptr>> free ; : buffer-reset ( n buffer -- ) swap >>fill 0 >>pos drop ; -: buffer-reset-hard ( buffer -- ) - 0 >>fill 0 >>pos drop ; - : buffer-capacity ( buffer -- n ) [ size>> ] [ fill>> ] bi - ; inline diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 1f7fc5f115..1a58d4200b 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -120,12 +120,17 @@ M: output-port stream-write HOOK: (wait-to-write) io-backend ( port -- ) -HOOK: (stream-seek) os ( n seek-type stream -- ) +HOOK: seek-handle os ( n seek-type handle -- ) -M: port stream-seek ( n seek-type stream -- ) - dup check-disposed - [ buffer>> buffer-reset-hard 2drop ] [ (stream-seek) ] 3bi ; +M: input-port stream-seek ( n seek-type stream -- ) + [ check-disposed ] + [ buffer>> 0 swap buffer-reset ] + [ handle>> seek-handle ] tri ; +M: output-port stream-seek ( n seek-type stream -- ) + [ check-disposed ] + [ stream-flush ] + [ handle>> seek-handle ] tri ; GENERIC: shutdown ( handle -- ) From 69f4899e11cd69c01c572d9acd68e1ed20029cf9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 13:51:02 -0600 Subject: [PATCH 54/60] document stream seeking --- core/io/io-docs.factor | 53 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 52 insertions(+), 1 deletion(-) diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index d7534ddb50..5d8aa6a88f 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -68,6 +68,51 @@ HELP: stream-copy { $description "Copies the contents of one stream into another, closing both streams when done." } $io-error ; + +HELP: stream-seek +{ $values + { "n" integer } { "seek-type" "a seek singleton" } { "stream" "a stream" } +} +{ $description "Moves the pointer associated with a stream's handle to an offset " { $snippet "n" } " bytes from the seek type so that further reading or writing happens at the new location. For output streams, the buffer is flushed before seeking. Seeking past the end of an output stream will pad the difference with zeros once the stream is written to again." $nl + "Three methods of seeking are supported:" + { $list { $link seek-absolute } { $link seek-relative } { $link seek-end } } +} +{ $notes "Stream seeking is not supported on streams that do not have a known length, e.g. TCP/IP streams." } ; + +HELP: seek-absolute +{ $values + + { "value" "a seek singleton" } +} +{ $description "Seeks to an offset from the beginning of the stream." } ; + +HELP: seek-end +{ $values + + { "value" "a seek singleton" } +} +{ $description "Seeks to an offset from the end of the stream. If the offset puts the stream pointer past the end of the data on an output stream, writing to it will pad the difference with zeros." } ; + +HELP: seek-relative +{ $values + + { "value" "a seek singleton" } +} +{ $description "Seeks to an offset from the current position of the stream pointer." } ; + + +HELP: seek-input +{ $values + { "n" integer } { "seek-type" "a seek singleton" } +} +{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link input-stream } "." } ; + +HELP: seek-output +{ $values + { "n" integer } { "seek-type" "a seek singleton" } +} +{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link output-stream } "." } ; + HELP: input-stream { $var-description "Holds an input stream for various implicit stream operations. Rebound using " { $link with-input-stream } " and " { $link with-input-stream* } "." } ; @@ -196,6 +241,8 @@ $nl { $subsection stream-write } "This word is only required for string output streams:" { $subsection stream-nl } +"This word is for streams that allow seeking:" +{ $subsection stream-seek } "For a discussion of the distinction between binary and string streams, see " { $link "stream-elements" } "." { $see-also "io.timeouts" } ; @@ -249,6 +296,8 @@ $nl { $subsection read-partial } "If the default input stream is a string stream (" { $link "stream-elements" } "), lines of text can be read:" { $subsection readln } +"Seeking on the default input stream:" +{ $subsection seek-input } "A pair of combinators for rebinding the " { $link input-stream } " variable:" { $subsection with-input-stream } { $subsection with-input-stream* } @@ -256,7 +305,7 @@ $nl { $subsection output-stream } "Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user." $nl -"Words writing to the default input stream:" +"Words writing to the default output stream:" { $subsection flush } { $subsection write1 } { $subsection write } @@ -265,6 +314,8 @@ $nl { $subsection print } { $subsection nl } { $subsection bl } +"Seeking on the default output stream:" +{ $subsection seek-output } "A pair of combinators for rebinding the " { $link output-stream } " variable:" { $subsection with-output-stream } { $subsection with-output-stream* } From fef602b1857ab649d882461e76522388cefb24a9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 13:58:39 -0600 Subject: [PATCH 55/60] remove superfluous flush from io tests --- core/io/io-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 8bfc52432d..d227ebeadf 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -16,7 +16,7 @@ IN: io.tests "seek-test1" unique-file binary [ [ - B{ 1 2 3 4 5 } write flush 0 seek-absolute seek-output + B{ 1 2 3 4 5 } write 0 seek-absolute seek-output B{ 3 } write ] with-file-writer ] [ @@ -29,7 +29,7 @@ IN: io.tests "seek-test2" unique-file binary [ [ - B{ 1 2 3 4 5 } write flush -1 seek-relative seek-output + B{ 1 2 3 4 5 } write -1 seek-relative seek-output B{ 3 } write ] with-file-writer ] [ @@ -42,7 +42,7 @@ IN: io.tests "seek-test3" unique-file binary [ [ - B{ 1 2 3 4 5 } write flush 1 seek-relative seek-output + B{ 1 2 3 4 5 } write 1 seek-relative seek-output B{ 3 } write ] with-file-writer ] [ From bba15986972c5b3918fc56cbea83b489c533f199 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 13:59:32 -0600 Subject: [PATCH 56/60] move io tests into io.files --- core/io/files/files-tests.factor | 65 ++++++++++++++++++++++++++++++++ core/io/io-tests.factor | 63 ------------------------------- 2 files changed, 65 insertions(+), 63 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index f9702fd133..423eb38144 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -75,3 +75,68 @@ USE: debugger.threads [ t ] [ "quux-test.txt" temp-file exists? ] unit-test [ ] [ "quux-test.txt" temp-file delete-file ] unit-test + +! File seeking tests +[ B{ 3 2 3 4 5 } ] +[ + "seek-test1" unique-file binary + [ + [ + B{ 1 2 3 4 5 } write 0 seek-absolute seek-output + B{ 3 } write + ] with-file-writer + ] [ + file-contents + ] 2bi +] unit-test + +[ B{ 1 2 3 4 3 } ] +[ + "seek-test2" unique-file binary + [ + [ + B{ 1 2 3 4 5 } write -1 seek-relative seek-output + B{ 3 } write + ] with-file-writer + ] [ + file-contents + ] 2bi +] unit-test + +[ B{ 1 2 3 4 5 0 3 } ] +[ + "seek-test3" unique-file binary + [ + [ + B{ 1 2 3 4 5 } write 1 seek-relative seek-output + B{ 3 } write + ] with-file-writer + ] [ + file-contents + ] 2bi +] unit-test + +[ B{ 3 } ] +[ + B{ 1 2 3 4 5 } "seek-test4" unique-file binary [ + set-file-contents + ] [ + [ + -3 seek-end seek-input 1 read + ] with-file-reader + ] 2bi +] unit-test + +[ B{ 2 } ] +[ + B{ 1 2 3 4 5 } "seek-test5" unique-file binary [ + set-file-contents + ] [ + [ + 3 seek-absolute seek-input + -2 seek-relative seek-input + 1 read + ] with-file-reader + ] 2bi +] unit-test + diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index d227ebeadf..9e931279d7 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -10,66 +10,3 @@ IN: io.tests ! Make sure we use correct to_c_string form when writing [ ] [ "\0" write ] unit-test - -[ B{ 3 2 3 4 5 } ] -[ - "seek-test1" unique-file binary - [ - [ - B{ 1 2 3 4 5 } write 0 seek-absolute seek-output - B{ 3 } write - ] with-file-writer - ] [ - file-contents - ] 2bi -] unit-test - -[ B{ 1 2 3 4 3 } ] -[ - "seek-test2" unique-file binary - [ - [ - B{ 1 2 3 4 5 } write -1 seek-relative seek-output - B{ 3 } write - ] with-file-writer - ] [ - file-contents - ] 2bi -] unit-test - -[ B{ 1 2 3 4 5 0 3 } ] -[ - "seek-test3" unique-file binary - [ - [ - B{ 1 2 3 4 5 } write 1 seek-relative seek-output - B{ 3 } write - ] with-file-writer - ] [ - file-contents - ] 2bi -] unit-test - -[ B{ 3 } ] -[ - B{ 1 2 3 4 5 } "seek-test4" unique-file binary [ - set-file-contents - ] [ - [ - -3 seek-end seek-input 1 read - ] with-file-reader - ] 2bi -] unit-test - -[ B{ 2 } ] -[ - B{ 1 2 3 4 5 } "seek-test5" unique-file binary [ - set-file-contents - ] [ - [ - 3 seek-absolute seek-input - -2 seek-relative seek-input - 1 read - ] with-file-reader - ] 2bi -] unit-test From c069add10b86dc8038354e5b91c1b2d3a8da5c87 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 17:34:17 -0600 Subject: [PATCH 57/60] fix using lists --- core/io/files/files-tests.factor | 10 ++++------ core/io/io-tests.factor | 4 +--- 2 files changed, 5 insertions(+), 9 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 423eb38144..d7fc3851e2 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,8 +1,7 @@ -USING: tools.test io.files io.files.private io.files.temp -io.directories io.encodings.8-bit arrays make system -io.encodings.binary io threads kernel continuations -io.encodings.ascii sequences strings accessors -io.encodings.utf8 math destructors namespaces ; +USING: arrays debugger.threads destructors io io.directories +io.encodings.8-bit io.encodings.ascii io.encodings.binary +io.files io.files.private io.files.temp io.files.unique kernel +make math sequences system threads tools.test ; IN: io.files.tests \ exists? must-infer @@ -139,4 +138,3 @@ USE: debugger.threads ] with-file-reader ] 2bi ] unit-test - diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 9e931279d7..cf6b935215 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,6 +1,4 @@ -USING: arrays io io.files kernel math parser strings system -tools.test words namespaces make io.encodings.8-bit -io.encodings.binary sequences io.files.unique ; +USING: io parser tools.test words ; IN: io.tests [ f ] [ From 83252cce04ef5864f6c38eb2343b94e974d5a05c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 17:37:54 -0600 Subject: [PATCH 58/60] working on tiff --- extra/graphics/tiff/tiff.factor | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index e66ebcc6bd..f0b3f9337e 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -2,20 +2,19 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.binary io.files kernel pack endian tools.hexdump constructors sequences arrays -sorting.slots math.order math.parser prettyprint ; +sorting.slots math.order math.parser prettyprint classes ; IN: graphics.tiff TUPLE: tiff endianness the-answer ifd-offset -ifds -processed-ifds ; +ifds ; CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; -TUPLE: ifd count ifd-entries next ; +TUPLE: ifd count ifd-entries next processed-tags strips ; CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; @@ -137,8 +136,6 @@ ERROR: bad-planar-configuration n ; TUPLE: new-subfile-type n ; CONSTRUCTOR: new-subfile-type ( n -- object ) ; - - ERROR: bad-tiff-magic bytes ; : tiff-endianness ( byte-array -- ? ) @@ -176,6 +173,12 @@ ERROR: bad-tiff-magic bytes ; [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ] with-tiff-endianness ; +: read-strips ( ifd -- ifd ) + dup processed-tags>> + [ [ strip-byte-counts instance? ] find nip n>> ] + [ [ strip-offsets instance? ] find nip n>> ] bi + [ seek-absolute seek-input read ] { } 2map-as >>strips ; + ! ERROR: unhandled-ifd-entry data n ; : unhandled-ifd-entry ; @@ -207,17 +210,18 @@ ERROR: bad-tiff-magic bytes ; [ unhandled-ifd-entry swap 2array ] } case ; -: process-ifd ( ifd -- processed-ifd ) - ifd-entries>> [ process-ifd-entry ] map ; +: process-ifd ( ifd -- ifd ) + dup ifd-entries>> [ process-ifd-entry ] map >>processed-tags ; : (load-tiff) ( path -- tiff ) binary [ read-header read-ifds - dup ifds>> [ process-ifd ] map - >>processed-ifds + dup ifds>> [ process-ifd read-strips drop ] each ] with-file-reader ; : load-tiff ( path -- tiff ) (load-tiff) ; + +! TODO: duplicate ifds = error, seeking out of bounds = error From 1818ea5136cd5515772b4c29d6c978378ffae1d2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 18:42:11 -0600 Subject: [PATCH 59/60] update README.txt --- README.txt | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/README.txt b/README.txt index 98616539d2..d60bf03130 100755 --- a/README.txt +++ b/README.txt @@ -116,16 +116,22 @@ Now if $DISPLAY is set, running ./factor will start the UI. * Running Factor on Windows XP/Vista +The Factor runtime is compiled into two binaries: + + factor.com - a Windows console application + factor.exe - a Windows native application, without a console + If you did not download the binary package, you can bootstrap Factor in -the command prompt: +the command prompt using the console application: - factor.exe -i=boot..image + factor.com -i=boot..image -Once bootstrapped, double-clicking factor.exe starts the Factor UI. +Once bootstrapped, double-clicking factor.exe or factor.com starts +the Factor UI. To run the listener in the command prompt: - factor.exe -run=listener + factor.com -run=listener * The Factor FAQ From b529df965234019bfdd98a472636dd875bc910a6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 20:18:30 -0600 Subject: [PATCH 60/60] handle seeking before the file start on windows, add a unit test for this --- basis/io/backend/windows/nt/nt.factor | 11 ++++++++--- core/io/files/files-tests.factor | 6 ++++++ 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 107f1902e3..6f283ac1bb 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -87,11 +87,16 @@ ERROR: invalid-file-size n ; : handle>file-size ( handle -- n ) 0 [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ; +ERROR: seek-before-start n ; + +: set-seek-ptr ( n handle -- ) + [ dup 0 < [ seek-before-start ] when ] dip (>>ptr) ; + M: winnt seek-handle ( n seek-type handle -- ) swap { - { seek-absolute [ (>>ptr) ] } - { seek-relative [ [ + ] change-ptr drop ] } - { seek-end [ [ handle>> handle>file-size + ] keep (>>ptr) ] } + { seek-absolute [ set-seek-ptr ] } + { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] } + { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] } [ bad-seek-type ] } case ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index d7fc3851e2..152d1bb85d 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -138,3 +138,9 @@ USE: debugger.threads ] with-file-reader ] 2bi ] unit-test + +[ + "seek-test6" unique-file binary [ + -10 seek-absolute seek-input + ] with-file-reader +] must-fail