Merge branch 'master' of git://factorcode.org/git/factor
commit
cc44597ea7
|
@ -1,5 +1,5 @@
|
||||||
USING: arrays calendar kernel math sequences tools.test
|
USING: arrays calendar kernel math sequences tools.test
|
||||||
continuations system math.order threads ;
|
continuations system math.order threads accessors ;
|
||||||
IN: calendar.tests
|
IN: calendar.tests
|
||||||
|
|
||||||
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||||
|
@ -163,3 +163,10 @@ IN: calendar.tests
|
||||||
[ t ] [ now 50 milliseconds sleep now before? ] unit-test
|
[ t ] [ now 50 milliseconds sleep now before? ] unit-test
|
||||||
[ t ] [ now 50 milliseconds sleep now swap after? ] unit-test
|
[ t ] [ now 50 milliseconds sleep now swap after? ] unit-test
|
||||||
[ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
|
[ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
|
||||||
|
|
||||||
|
[ 4 12 ] [ 2009 easter [ month>> ] [ day>> ] bi ] unit-test
|
||||||
|
[ 4 2 ] [ 1961 easter [ month>> ] [ day>> ] bi ] unit-test
|
||||||
|
|
||||||
|
[ f ] [ now dup midnight eq? ] unit-test
|
||||||
|
[ f ] [ now dup easter eq? ] unit-test
|
||||||
|
[ f ] [ now dup beginning-of-year eq? ] unit-test
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2007 Doug Coleman.
|
! Copyright (C) 2007 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors arrays classes.tuple combinators combinators.short-circuit
|
USING: accessors arrays classes.tuple combinators
|
||||||
kernel locals math math.functions math.order namespaces sequences strings
|
combinators.short-circuit kernel locals math math.functions
|
||||||
summary system threads vocabs.loader ;
|
math.order sequences summary system threads vocabs.loader ;
|
||||||
IN: calendar
|
IN: calendar
|
||||||
|
|
||||||
HOOK: gmt-offset os ( -- hours minutes seconds )
|
HOOK: gmt-offset os ( -- hours minutes seconds )
|
||||||
|
@ -94,26 +94,50 @@ CONSTANT: day-abbreviations3
|
||||||
:: julian-day-number ( year month day -- n )
|
:: julian-day-number ( year month day -- n )
|
||||||
#! Returns a composite date number
|
#! Returns a composite date number
|
||||||
#! Not valid before year -4800
|
#! Not valid before year -4800
|
||||||
[let* | a [ 14 month - 12 /i ]
|
14 month - 12 /i :> a
|
||||||
y [ year 4800 + a - ]
|
year 4800 + a - :> y
|
||||||
m [ month 12 a * + 3 - ] |
|
month 12 a * + 3 - :> m
|
||||||
day 153 m * 2 + 5 /i + 365 y * +
|
|
||||||
y 4 /i + y 100 /i - y 400 /i + 32045 -
|
day 153 m * 2 + 5 /i + 365 y * +
|
||||||
] ;
|
y 4 /i + y 100 /i - y 400 /i + 32045 - ;
|
||||||
|
|
||||||
:: julian-day-number>date ( n -- year month day )
|
:: julian-day-number>date ( n -- year month day )
|
||||||
#! Inverse of julian-day-number
|
#! Inverse of julian-day-number
|
||||||
[let* | a [ n 32044 + ]
|
n 32044 + :> a
|
||||||
b [ 4 a * 3 + 146097 /i ]
|
4 a * 3 + 146097 /i :> b
|
||||||
c [ a 146097 b * 4 /i - ]
|
a 146097 b * 4 /i - :> c
|
||||||
d [ 4 c * 3 + 1461 /i ]
|
4 c * 3 + 1461 /i :> d
|
||||||
e [ c 1461 d * 4 /i - ]
|
c 1461 d * 4 /i - :> e
|
||||||
m [ 5 e * 2 + 153 /i ] |
|
5 e * 2 + 153 /i :> m
|
||||||
100 b * d + 4800 -
|
|
||||||
m 10 /i + m 3 +
|
100 b * d + 4800 -
|
||||||
12 m 10 /i * -
|
m 10 /i + m 3 +
|
||||||
e 153 m * 2 + 5 /i - 1+
|
12 m 10 /i * -
|
||||||
] ;
|
e 153 m * 2 + 5 /i - 1+ ;
|
||||||
|
|
||||||
|
GENERIC: easter ( obj -- obj' )
|
||||||
|
|
||||||
|
:: easter-month-day ( year -- month day )
|
||||||
|
year 19 mod :> a
|
||||||
|
year 100 /mod :> c :> b
|
||||||
|
b 4 /mod :> e :> d
|
||||||
|
b 8 + 25 /i :> f
|
||||||
|
b f - 1 + 3 /i :> g
|
||||||
|
19 a * b + d - g - 15 + 30 mod :> h
|
||||||
|
c 4 /mod :> k :> i
|
||||||
|
32 2 e * + 2 i * + h - k - 7 mod :> l
|
||||||
|
a 11 h * + 22 l * + 451 /i :> m
|
||||||
|
|
||||||
|
h l + 7 m * - 114 + 31 /mod 1 + :> day :> month
|
||||||
|
month day ;
|
||||||
|
|
||||||
|
M: integer easter ( year -- timestamp )
|
||||||
|
dup easter-month-day <date> ;
|
||||||
|
|
||||||
|
M: timestamp easter ( timestamp -- timestamp )
|
||||||
|
clone
|
||||||
|
dup year>> easter-month-day
|
||||||
|
swapd >>day swap >>month ;
|
||||||
|
|
||||||
: >date< ( timestamp -- year month day )
|
: >date< ( timestamp -- year month day )
|
||||||
[ year>> ] [ month>> ] [ day>> ] tri ;
|
[ year>> ] [ month>> ] [ day>> ] tri ;
|
||||||
|
|
|
@ -14,7 +14,7 @@ IN: checksums.md5
|
||||||
SYMBOLS: a b c d old-a old-b old-c old-d ;
|
SYMBOLS: a b c d old-a old-b old-c old-d ;
|
||||||
|
|
||||||
: T ( N -- Y )
|
: T ( N -- Y )
|
||||||
sin abs 4294967296 * >integer ; foldable
|
sin abs 32 2^ * >integer ; foldable
|
||||||
|
|
||||||
: initialize-md5 ( -- )
|
: initialize-md5 ( -- )
|
||||||
0 bytes-read set
|
0 bytes-read set
|
||||||
|
|
|
@ -5,7 +5,7 @@ continuations effects namespaces.private io io.streams.string
|
||||||
memory system threads tools.test math accessors combinators
|
memory system threads tools.test math accessors combinators
|
||||||
specialized-arrays.float alien.libraries io.pathnames
|
specialized-arrays.float alien.libraries io.pathnames
|
||||||
io.backend ;
|
io.backend ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests.alien
|
||||||
|
|
||||||
<<
|
<<
|
||||||
: libfactor-ffi-tests-path ( -- string )
|
: libfactor-ffi-tests-path ( -- string )
|
||||||
|
|
|
@ -4,7 +4,7 @@ sequences sequences.private tools.test namespaces.private
|
||||||
slots.private sequences.private byte-arrays alien
|
slots.private sequences.private byte-arrays alien
|
||||||
alien.accessors layouts words definitions compiler.units io
|
alien.accessors layouts words definitions compiler.units io
|
||||||
combinators vectors grouping make ;
|
combinators vectors grouping make ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests.codegen
|
||||||
|
|
||||||
! Originally, this file did black box testing of templating
|
! Originally, this file did black box testing of templating
|
||||||
! optimization. We now have a different codegen, but the tests
|
! optimization. We now have a different codegen, but the tests
|
||||||
|
@ -281,4 +281,4 @@ TUPLE: cucumber ;
|
||||||
|
|
||||||
M: cucumber equal? "The cucumber has no equal" throw ;
|
M: cucumber equal? "The cucumber has no equal" throw ;
|
||||||
|
|
||||||
[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
|
[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: tools.test quotations math kernel sequences
|
USING: tools.test quotations math kernel sequences
|
||||||
assocs namespaces make compiler.units compiler ;
|
assocs namespaces make compiler.units compiler ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests.curry
|
||||||
|
|
||||||
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
|
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
|
||||||
[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test
|
[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
IN: compiler.tests
|
IN: compiler.tests.float
|
||||||
USING: compiler.units compiler kernel kernel.private memory math
|
USING: compiler.units compiler kernel kernel.private memory math
|
||||||
math.private tools.test math.floats.private ;
|
math.private tools.test math.floats.private ;
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: eval tools.test compiler.units vocabs multiline words
|
USING: eval tools.test compiler.units vocabs multiline words
|
||||||
kernel classes.mixin arrays ;
|
kernel classes.mixin arrays ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests.folding
|
||||||
|
|
||||||
! Calls to generic words were not folded away.
|
! Calls to generic words were not folded away.
|
||||||
|
|
||||||
|
|
|
@ -6,7 +6,7 @@ sbufs strings.private slots.private alien math.order
|
||||||
alien.accessors alien.c-types alien.syntax alien.strings
|
alien.accessors alien.c-types alien.syntax alien.strings
|
||||||
namespaces libc sequences.private io.encodings.ascii
|
namespaces libc sequences.private io.encodings.ascii
|
||||||
classes compiler ;
|
classes compiler ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests.intrinsics
|
||||||
|
|
||||||
! Make sure that intrinsic ops compile to correct code.
|
! Make sure that intrinsic ops compile to correct code.
|
||||||
[ ] [ 1 [ drop ] compile-call ] unit-test
|
[ ] [ 1 [ drop ] compile-call ] unit-test
|
||||||
|
|
|
@ -5,7 +5,7 @@ quotations classes classes.algebra classes.tuple.private
|
||||||
continuations growable namespaces hints alien.accessors
|
continuations growable namespaces hints alien.accessors
|
||||||
compiler.tree.builder compiler.tree.optimizer sequences.deep
|
compiler.tree.builder compiler.tree.optimizer sequences.deep
|
||||||
compiler ;
|
compiler ;
|
||||||
IN: optimizer.tests
|
IN: compiler.tests.optimizer
|
||||||
|
|
||||||
GENERIC: xyz ( obj -- obj )
|
GENERIC: xyz ( obj -- obj )
|
||||||
M: array xyz xyz ;
|
M: array xyz xyz ;
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
IN: compiler.tests
|
IN: compiler.tests.peg-regression-2
|
||||||
USING: peg.ebnf strings tools.test ;
|
USING: peg.ebnf strings tools.test ;
|
||||||
|
|
||||||
GENERIC: <times> ( times -- term' )
|
GENERIC: <times> ( times -- term' )
|
||||||
|
@ -12,4 +12,4 @@ Regexp = Times:t => [[ t <times> ]]
|
||||||
|
|
||||||
;EBNF
|
;EBNF
|
||||||
|
|
||||||
[ "foo" ] [ "a" parse-regexp ] unit-test
|
[ "foo" ] [ "a" parse-regexp ] unit-test
|
||||||
|
|
|
@ -5,7 +5,7 @@
|
||||||
! end of a compilation unit.
|
! end of a compilation unit.
|
||||||
|
|
||||||
USING: kernel accessors peg.ebnf ;
|
USING: kernel accessors peg.ebnf ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests.peg-regression
|
||||||
|
|
||||||
TUPLE: pipeline-expr background ;
|
TUPLE: pipeline-expr background ;
|
||||||
|
|
||||||
|
|
|
@ -104,4 +104,4 @@ quot global delete-at
|
||||||
\ test-11 forget
|
\ test-11 forget
|
||||||
\ quot forget
|
\ quot forget
|
||||||
] with-compilation-unit
|
] with-compilation-unit
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
USING: accessors compiler compiler.units tools.test math parser
|
USING: accessors compiler compiler.units tools.test math parser
|
||||||
kernel sequences sequences.private classes.mixin generic
|
kernel sequences sequences.private classes.mixin generic
|
||||||
definitions arrays words assocs eval strings ;
|
definitions arrays words assocs eval strings ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests.redefine1
|
||||||
|
|
||||||
GENERIC: method-redefine-generic-1 ( a -- b )
|
GENERIC: method-redefine-generic-1 ( a -- b )
|
||||||
|
|
||||||
|
@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ;
|
||||||
|
|
||||||
[ 6 ] [ method-redefine-test-1 ] unit-test
|
[ 6 ] [ method-redefine-test-1 ] unit-test
|
||||||
|
|
||||||
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
|
[ ] [ "IN: compiler.tests.redefine1 USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ 7 ] [ method-redefine-test-1 ] unit-test
|
[ 7 ] [ method-redefine-test-1 ] unit-test
|
||||||
|
|
||||||
|
@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ;
|
||||||
|
|
||||||
[ 6 ] [ method-redefine-test-2 ] unit-test
|
[ 6 ] [ method-redefine-test-2 ] unit-test
|
||||||
|
|
||||||
[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
|
[ ] [ "IN: compiler.tests.redefine1 USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ 7 ] [ method-redefine-test-2 ] unit-test
|
[ 7 ] [ method-redefine-test-2 ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: eval tools.test compiler.units vocabs multiline words
|
USING: eval tools.test compiler.units vocabs multiline words
|
||||||
kernel ;
|
kernel ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests.redefine10
|
||||||
|
|
||||||
! Mixin redefinition did not recompile all necessary words.
|
! Mixin redefinition did not recompile all necessary words.
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: eval tools.test compiler.units vocabs multiline words
|
USING: eval tools.test compiler.units vocabs multiline words
|
||||||
kernel classes.mixin arrays ;
|
kernel classes.mixin arrays ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests.redefine11
|
||||||
|
|
||||||
! Mixin redefinition did not recompile all necessary words.
|
! Mixin redefinition did not recompile all necessary words.
|
||||||
|
|
||||||
|
|
|
@ -17,4 +17,4 @@ DEFER: word-1
|
||||||
|
|
||||||
[ \ word-3 [ [ 2 + ] bi@ ] (( a b -- c d )) define-declared ] with-compilation-unit
|
[ \ word-3 [ [ 2 + ] bi@ ] (( a b -- c d )) define-declared ] with-compilation-unit
|
||||||
|
|
||||||
[ 2 3 ] [ 0 word-4 ] unit-test
|
[ 2 3 ] [ 0 word-4 ] unit-test
|
||||||
|
|
|
@ -1,11 +1,11 @@
|
||||||
IN: compiler.tests
|
IN: compiler.tests.redefine2
|
||||||
USING: compiler compiler.units tools.test math parser kernel
|
USING: compiler compiler.units tools.test math parser kernel
|
||||||
sequences sequences.private classes.mixin generic definitions
|
sequences sequences.private classes.mixin generic definitions
|
||||||
arrays words assocs eval words.symbol ;
|
arrays words assocs eval words.symbol ;
|
||||||
|
|
||||||
DEFER: redefine2-test
|
DEFER: redefine2-test
|
||||||
|
|
||||||
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
|
[ ] [ "USE: sequences USE: kernel IN: compiler.tests.redefine2 TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ t ] [ \ redefine2-test symbol? ] unit-test
|
[ t ] [ \ redefine2-test symbol? ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
IN: compiler.tests
|
IN: compiler.tests.redefine3
|
||||||
USING: accessors compiler compiler.units tools.test math parser
|
USING: accessors compiler compiler.units tools.test math parser
|
||||||
kernel sequences sequences.private classes.mixin generic
|
kernel sequences sequences.private classes.mixin generic
|
||||||
definitions arrays words assocs eval ;
|
definitions arrays words assocs eval ;
|
||||||
|
@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ;
|
||||||
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
||||||
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
||||||
|
|
||||||
[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
|
[ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ "wake up" ] [ sheeple-test ] unit-test
|
[ "wake up" ] [ sheeple-test ] unit-test
|
||||||
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
IN: compiler.tests
|
IN: compiler.tests.redefine4
|
||||||
USING: io.streams.string kernel tools.test eval ;
|
USING: io.streams.string kernel tools.test eval ;
|
||||||
|
|
||||||
: declaration-test-1 ( -- a ) 3 ; flushable
|
: declaration-test-1 ( -- a ) 3 ; flushable
|
||||||
|
@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
|
||||||
|
|
||||||
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test
|
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test
|
||||||
|
|
||||||
[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
|
[ ] [ "IN: compiler.tests.redefine4 USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test
|
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: eval tools.test compiler.units vocabs multiline words
|
USING: eval tools.test compiler.units vocabs multiline words
|
||||||
kernel ;
|
kernel ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests.redefine5
|
||||||
|
|
||||||
! Regression: if dispatch was eliminated but method was not inlined,
|
! Regression: if dispatch was eliminated but method was not inlined,
|
||||||
! compiled usage information was not recorded.
|
! compiled usage information was not recorded.
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: eval tools.test compiler.units vocabs multiline words
|
USING: eval tools.test compiler.units vocabs multiline words
|
||||||
kernel ;
|
kernel ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests.redefine6
|
||||||
|
|
||||||
! Mixin redefinition did not recompile all necessary words.
|
! Mixin redefinition did not recompile all necessary words.
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: eval tools.test compiler.units vocabs multiline words
|
USING: eval tools.test compiler.units vocabs multiline words
|
||||||
kernel ;
|
kernel ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests.redefine7
|
||||||
|
|
||||||
! Mixin redefinition did not recompile all necessary words.
|
! Mixin redefinition did not recompile all necessary words.
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: eval tools.test compiler.units vocabs multiline words
|
USING: eval tools.test compiler.units vocabs multiline words
|
||||||
kernel ;
|
kernel ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests.redefine8
|
||||||
|
|
||||||
! Mixin redefinition did not recompile all necessary words.
|
! Mixin redefinition did not recompile all necessary words.
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: eval tools.test compiler.units vocabs multiline words
|
USING: eval tools.test compiler.units vocabs multiline words
|
||||||
kernel generic.math ;
|
kernel generic.math ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests.redefine9
|
||||||
|
|
||||||
! Mixin redefinition did not recompile all necessary words.
|
! Mixin redefinition did not recompile all necessary words.
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
IN: compiler.tests
|
IN: compiler.tests.reload
|
||||||
USE: vocabs.loader
|
USE: vocabs.loader
|
||||||
|
|
||||||
! "parser" reload
|
! "parser" reload
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
USING: compiler compiler.units tools.test kernel kernel.private
|
USING: compiler compiler.units tools.test kernel kernel.private
|
||||||
sequences.private math.private math combinators strings alien
|
sequences.private math.private math combinators strings alien
|
||||||
arrays memory vocabs parser eval ;
|
arrays memory vocabs parser eval ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests.simple
|
||||||
|
|
||||||
! Test empty word
|
! Test empty word
|
||||||
[ ] [ [ ] compile-call ] unit-test
|
[ ] [ [ ] compile-call ] unit-test
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: math.private kernel combinators accessors arrays
|
USING: math.private kernel combinators accessors arrays
|
||||||
generalizations tools.test ;
|
generalizations tools.test ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests.spilling
|
||||||
|
|
||||||
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
|
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
|
||||||
{
|
{
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
IN: compiler.tests
|
IN: compiler.tests.stack-trace
|
||||||
USING: compiler tools.test namespaces sequences
|
USING: compiler tools.test namespaces sequences
|
||||||
kernel.private kernel math continuations continuations.private
|
kernel.private kernel math continuations continuations.private
|
||||||
words splitting grouping sorting accessors ;
|
words splitting grouping sorting accessors ;
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
IN: compiler.tests
|
IN: compiler.tests.tuples
|
||||||
USING: kernel tools.test compiler.units compiler ;
|
USING: kernel tools.test compiler.units compiler ;
|
||||||
|
|
||||||
TUPLE: color red green blue ;
|
TUPLE: color red green blue ;
|
||||||
|
|
|
@ -39,55 +39,55 @@ TUPLE: directory-iterator path bfs queue ;
|
||||||
dup directory?
|
dup directory?
|
||||||
[ name>> over push-directory-entries next-directory-entry ]
|
[ name>> over push-directory-entries next-directory-entry ]
|
||||||
[ nip ] if
|
[ nip ] if
|
||||||
] if ; recursive
|
] if ;
|
||||||
|
|
||||||
:: iterate-directory-entries ( iter quot -- directory-entry/f )
|
:: iterate-directory-entries ( iter quot: ( obj -- obj ) -- directory-entry/f )
|
||||||
iter next-directory-entry [
|
iter next-directory-entry [
|
||||||
quot call( obj -- obj )
|
quot call
|
||||||
[ iter quot iterate-directory-entries ] unless*
|
[ iter quot iterate-directory-entries ] unless*
|
||||||
] [
|
] [
|
||||||
f
|
f
|
||||||
] if* ; inline recursive
|
] if* ; inline recursive
|
||||||
|
|
||||||
: iterate-directory ( iter quot -- path/f )
|
: iterate-directory ( iter quot -- path/f )
|
||||||
[ name>> ] prepose iterate-directory-entries ;
|
[ name>> ] prepose iterate-directory-entries ; inline
|
||||||
|
|
||||||
: setup-traversal ( path bfs quot -- iterator quot' )
|
: setup-traversal ( path bfs quot -- iterator quot' )
|
||||||
[ <directory-iterator> ] dip [ f ] compose ;
|
[ <directory-iterator> ] dip [ f ] compose ; inline
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: each-file ( path bfs? quot -- )
|
: each-file ( path bfs? quot -- )
|
||||||
setup-traversal iterate-directory drop ;
|
setup-traversal iterate-directory drop ; inline
|
||||||
|
|
||||||
: each-directory-entry ( path bfs? quot -- )
|
: each-directory-entry ( path bfs? quot -- )
|
||||||
setup-traversal iterate-directory-entries drop ;
|
setup-traversal iterate-directory-entries drop ; inline
|
||||||
|
|
||||||
: recursive-directory-files ( path bfs? -- paths )
|
: recursive-directory-files ( path bfs? -- paths )
|
||||||
[ ] accumulator [ each-file ] dip ;
|
[ ] accumulator [ each-file ] dip ; inline
|
||||||
|
|
||||||
: recursive-directory-entries ( path bfs? -- paths )
|
: recursive-directory-entries ( path bfs? -- directory-entries )
|
||||||
[ ] accumulator [ each-directory-entry ] dip ;
|
[ ] accumulator [ each-directory-entry ] dip ; inline
|
||||||
|
|
||||||
: find-file ( path bfs? quot -- path/f )
|
: find-file ( path bfs? quot -- path/f )
|
||||||
[ <directory-iterator> ] dip
|
[ <directory-iterator> ] dip
|
||||||
[ keep and ] curry iterate-directory ;
|
[ keep and ] curry iterate-directory ; inline
|
||||||
|
|
||||||
: find-all-files ( path quot -- paths/f )
|
: find-all-files ( path quot -- paths/f )
|
||||||
[ f <directory-iterator> ] dip pusher
|
[ f <directory-iterator> ] dip pusher
|
||||||
[ [ f ] compose iterate-directory drop ] dip ;
|
[ [ f ] compose iterate-directory drop ] dip ; inline
|
||||||
|
|
||||||
ERROR: file-not-found path bfs? quot ;
|
ERROR: file-not-found path bfs? quot ;
|
||||||
|
|
||||||
: find-file-throws ( path bfs? quot -- path )
|
: find-file-throws ( path bfs? quot -- path )
|
||||||
3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ;
|
3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; inline
|
||||||
|
|
||||||
: find-in-directories ( directories bfs? quot -- path'/f )
|
: find-in-directories ( directories bfs? quot -- path'/f )
|
||||||
'[ _ [ _ _ find-file-throws ] attempt-all ]
|
'[ _ [ _ _ find-file-throws ] attempt-all ]
|
||||||
[ drop f ] recover ;
|
[ drop f ] recover ; inline
|
||||||
|
|
||||||
: find-all-in-directories ( directories quot -- paths/f )
|
: find-all-in-directories ( directories quot -- paths/f )
|
||||||
'[ _ find-all-files ] map concat ;
|
'[ _ find-all-files ] map concat ; inline
|
||||||
|
|
||||||
: link-size/0 ( path -- n )
|
: link-size/0 ( path -- n )
|
||||||
[ link-info size-on-disk>> ] [ 2drop 0 ] recover ;
|
[ link-info size-on-disk>> ] [ 2drop 0 ] recover ;
|
||||||
|
|
|
@ -9,13 +9,14 @@ SLOT: length
|
||||||
|
|
||||||
: mapped-file>direct ( mapped-file type -- alien length )
|
: mapped-file>direct ( mapped-file type -- alien length )
|
||||||
[ [ address>> ] [ length>> ] bi ] dip
|
[ [ address>> ] [ length>> ] bi ] dip
|
||||||
heap-size [ 1- + ] keep /i ;
|
heap-size [ 1 - + ] keep /i ;
|
||||||
|
|
||||||
FUNCTOR: define-mapped-array ( T -- )
|
FUNCTOR: define-mapped-array ( T -- )
|
||||||
|
|
||||||
<mapped-A> DEFINES <mapped-${T}-array>
|
<mapped-A> DEFINES <mapped-${T}-array>
|
||||||
<A> IS <direct-${T}-array>
|
<A> IS <direct-${T}-array>
|
||||||
with-mapped-A-file DEFINES with-mapped-${T}-file
|
with-mapped-A-file DEFINES with-mapped-${T}-file
|
||||||
|
with-mapped-A-file-reader DEFINES with-mapped-${T}-file-reader
|
||||||
|
|
||||||
WHERE
|
WHERE
|
||||||
|
|
||||||
|
@ -25,4 +26,7 @@ WHERE
|
||||||
: with-mapped-A-file ( path quot -- )
|
: with-mapped-A-file ( path quot -- )
|
||||||
'[ <mapped-A> @ ] with-mapped-file ; inline
|
'[ <mapped-A> @ ] with-mapped-file ; inline
|
||||||
|
|
||||||
|
: with-mapped-A-file-reader ( path quot -- )
|
||||||
|
'[ <mapped-A> @ ] with-mapped-file-reader ; inline
|
||||||
|
|
||||||
;FUNCTOR
|
;FUNCTOR
|
||||||
|
|
|
@ -18,7 +18,13 @@ HELP: <mapped-file>
|
||||||
|
|
||||||
HELP: with-mapped-file
|
HELP: with-mapped-file
|
||||||
{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
|
{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
|
||||||
{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
|
{ $contract "Opens a file for read/write access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
|
||||||
|
{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." }
|
||||||
|
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||||
|
|
||||||
|
HELP: with-mapped-file-reader
|
||||||
|
{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
|
||||||
|
{ $contract "Opens a file for read-only access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
|
||||||
{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." }
|
{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." }
|
||||||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||||
|
|
||||||
|
|
|
@ -7,6 +7,7 @@ IN: io.mmap.tests
|
||||||
[ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test
|
[ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test
|
||||||
[ ] [ "mmap-test-file.txt" temp-file [ CHAR: 2 0 pick set-nth drop ] with-mapped-char-file ] unit-test
|
[ ] [ "mmap-test-file.txt" temp-file [ CHAR: 2 0 pick set-nth drop ] with-mapped-char-file ] unit-test
|
||||||
[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test
|
[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test
|
||||||
|
[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file-reader ] unit-test
|
||||||
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
|
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
|
||||||
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
|
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
|
||||||
|
|
||||||
|
|
|
@ -8,14 +8,27 @@ IN: io.mmap
|
||||||
|
|
||||||
TUPLE: mapped-file address handle length disposed ;
|
TUPLE: mapped-file address handle length disposed ;
|
||||||
|
|
||||||
HOOK: (mapped-file) os ( path length -- address handle )
|
HOOK: (mapped-file-reader) os ( path length -- address handle )
|
||||||
|
HOOK: (mapped-file-r/w) os ( path length -- address handle )
|
||||||
|
|
||||||
ERROR: bad-mmap-size path size ;
|
ERROR: bad-mmap-size path size ;
|
||||||
|
|
||||||
: <mapped-file> ( path -- mmap )
|
<PRIVATE
|
||||||
|
|
||||||
|
: prepare-mapped-file ( path -- path' n )
|
||||||
[ normalize-path ] [ file-info size>> ] bi
|
[ normalize-path ] [ file-info size>> ] bi
|
||||||
dup 0 <= [ bad-mmap-size ] when
|
dup 0 <= [ bad-mmap-size ] when ;
|
||||||
[ (mapped-file) ] keep
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: <mapped-file-reader> ( path -- mmap )
|
||||||
|
prepare-mapped-file
|
||||||
|
[ (mapped-file-reader) ] keep
|
||||||
|
f mapped-file boa ;
|
||||||
|
|
||||||
|
: <mapped-file> ( path -- mmap )
|
||||||
|
prepare-mapped-file
|
||||||
|
[ (mapped-file-r/w) ] keep
|
||||||
f mapped-file boa ;
|
f mapped-file boa ;
|
||||||
|
|
||||||
HOOK: close-mapped-file io-backend ( mmap -- )
|
HOOK: close-mapped-file io-backend ( mmap -- )
|
||||||
|
@ -25,6 +38,9 @@ M: mapped-file dispose* ( mmap -- ) close-mapped-file ;
|
||||||
: with-mapped-file ( path quot -- )
|
: with-mapped-file ( path quot -- )
|
||||||
[ <mapped-file> ] dip with-disposal ; inline
|
[ <mapped-file> ] dip with-disposal ; inline
|
||||||
|
|
||||||
|
: with-mapped-file-reader ( path quot -- )
|
||||||
|
[ <mapped-file-reader> ] dip with-disposal ; inline
|
||||||
|
|
||||||
{
|
{
|
||||||
{ [ os unix? ] [ "io.mmap.unix" require ] }
|
{ [ os unix? ] [ "io.mmap.unix" require ] }
|
||||||
{ [ os winnt? ] [ "io.mmap.windows" require ] }
|
{ [ os winnt? ] [ "io.mmap.windows" require ] }
|
||||||
|
|
|
@ -4,21 +4,23 @@ USING: alien io io.files kernel math math.bitwise system unix
|
||||||
io.backend.unix io.ports io.mmap destructors locals accessors ;
|
io.backend.unix io.ports io.mmap destructors locals accessors ;
|
||||||
IN: io.mmap.unix
|
IN: io.mmap.unix
|
||||||
|
|
||||||
: open-r/w ( path -- fd ) O_RDWR file-mode open-file ;
|
:: mmap-open ( path length prot flags open-mode -- alien fd )
|
||||||
|
|
||||||
:: mmap-open ( path length prot flags -- alien fd )
|
|
||||||
[
|
[
|
||||||
f length prot flags
|
f length prot flags
|
||||||
path open-r/w [ <fd> |dispose drop ] keep
|
path open-mode file-mode open-file [ <fd> |dispose drop ] keep
|
||||||
[ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep
|
[ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
M: unix (mapped-file)
|
M: unix (mapped-file-r/w)
|
||||||
{ PROT_READ PROT_WRITE } flags
|
{ PROT_READ PROT_WRITE } flags
|
||||||
{ MAP_FILE MAP_SHARED } flags
|
{ MAP_FILE MAP_SHARED } flags
|
||||||
mmap-open ;
|
O_RDWR mmap-open ;
|
||||||
|
|
||||||
|
M: unix (mapped-file-reader)
|
||||||
|
{ PROT_READ } flags
|
||||||
|
{ MAP_FILE MAP_SHARED } flags
|
||||||
|
O_RDONLY mmap-open ;
|
||||||
|
|
||||||
M: unix close-mapped-file ( mmap -- )
|
M: unix close-mapped-file ( mmap -- )
|
||||||
[ [ address>> ] [ length>> ] bi munmap io-error ]
|
[ [ address>> ] [ length>> ] bi munmap io-error ]
|
||||||
[ handle>> close-file ]
|
[ handle>> close-file ] bi ;
|
||||||
bi ;
|
|
||||||
|
|
|
@ -28,7 +28,7 @@ M: win32-mapped-file dispose
|
||||||
|
|
||||||
C: <win32-mapped-file> win32-mapped-file
|
C: <win32-mapped-file> win32-mapped-file
|
||||||
|
|
||||||
M: windows (mapped-file)
|
M: windows (mapped-file-r/w)
|
||||||
[
|
[
|
||||||
{ GENERIC_WRITE GENERIC_READ } flags
|
{ GENERIC_WRITE GENERIC_READ } flags
|
||||||
OPEN_ALWAYS
|
OPEN_ALWAYS
|
||||||
|
@ -37,6 +37,15 @@ M: windows (mapped-file)
|
||||||
-rot <win32-mapped-file>
|
-rot <win32-mapped-file>
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
|
M: windows (mapped-file-reader)
|
||||||
|
[
|
||||||
|
GENERIC_READ
|
||||||
|
OPEN_ALWAYS
|
||||||
|
{ PAGE_READONLY SEC_COMMIT } flags
|
||||||
|
FILE_MAP_READ mmap-open
|
||||||
|
-rot <win32-mapped-file>
|
||||||
|
] with-destructors ;
|
||||||
|
|
||||||
M: windows close-mapped-file ( mapped-file -- )
|
M: windows close-mapped-file ( mapped-file -- )
|
||||||
[
|
[
|
||||||
[ handle>> &dispose drop ]
|
[ handle>> &dispose drop ]
|
||||||
|
|
|
@ -62,6 +62,8 @@ SYMBOL: max-stack-items
|
||||||
|
|
||||||
SYMBOL: error-summary?
|
SYMBOL: error-summary?
|
||||||
|
|
||||||
|
t error-summary? set-global
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: title. ( string -- )
|
: title. ( string -- )
|
||||||
|
|
|
@ -18,7 +18,7 @@ blas-fortran-abi [
|
||||||
{ [ os netbsd? cpu x86.64? and ] [ g95-abi ] }
|
{ [ os netbsd? cpu x86.64? and ] [ g95-abi ] }
|
||||||
{ [ os windows? cpu x86.64? and ] [ gfortran-abi ] }
|
{ [ os windows? cpu x86.64? and ] [ gfortran-abi ] }
|
||||||
{ [ os freebsd? ] [ gfortran-abi ] }
|
{ [ os freebsd? ] [ gfortran-abi ] }
|
||||||
{ [ os linux? cpu x86.32? and ] [ gfortran-abi ] }
|
{ [ os linux? ] [ gfortran-abi ] }
|
||||||
[ f2c-abi ]
|
[ f2c-abi ]
|
||||||
} cond
|
} cond
|
||||||
] initialize
|
] initialize
|
||||||
|
|
|
@ -46,8 +46,8 @@ CONSTANT: homo-sapiens
|
||||||
}
|
}
|
||||||
|
|
||||||
: make-cumulative ( freq -- chars floats )
|
: make-cumulative ( freq -- chars floats )
|
||||||
dup keys >byte-array
|
[ keys >byte-array ]
|
||||||
swap values >double-array unclip [ + ] accumulate swap suffix ;
|
[ values >double-array ] bi unclip [ + ] accumulate swap suffix ;
|
||||||
|
|
||||||
:: select-random ( seed chars floats -- seed elt )
|
:: select-random ( seed chars floats -- seed elt )
|
||||||
floats seed random -rot
|
floats seed random -rot
|
||||||
|
@ -55,7 +55,7 @@ CONSTANT: homo-sapiens
|
||||||
chars nth-unsafe ; inline
|
chars nth-unsafe ; inline
|
||||||
|
|
||||||
: make-random-fasta ( seed len chars floats -- seed )
|
: make-random-fasta ( seed len chars floats -- seed )
|
||||||
[ rot drop select-random ] 2curry B{ } map-as print ; inline
|
[ rot drop select-random ] 2curry "" map-as print ; inline
|
||||||
|
|
||||||
: write-description ( desc id -- )
|
: write-description ( desc id -- )
|
||||||
">" write write bl print ; inline
|
">" write write bl print ; inline
|
||||||
|
@ -71,7 +71,7 @@ CONSTANT: homo-sapiens
|
||||||
|
|
||||||
:: make-repeat-fasta ( k len alu -- k' )
|
:: make-repeat-fasta ( k len alu -- k' )
|
||||||
[let | kn [ alu length ] |
|
[let | kn [ alu length ] |
|
||||||
len [ k + kn mod alu nth-unsafe ] B{ } map-as print
|
len [ k + kn mod alu nth-unsafe ] "" map-as print
|
||||||
k len +
|
k len +
|
||||||
] ; inline
|
] ; inline
|
||||||
|
|
||||||
|
|
|
@ -6,7 +6,7 @@ combinators math.ranges unicode.categories byte-arrays
|
||||||
io.encodings.string io.encodings.utf16 assocs math.parser
|
io.encodings.string io.encodings.utf16 assocs math.parser
|
||||||
combinators.short-circuit fry namespaces combinators.smart
|
combinators.short-circuit fry namespaces combinators.smart
|
||||||
splitting io.encodings.ascii arrays io.files.info unicode.case
|
splitting io.encodings.ascii arrays io.files.info unicode.case
|
||||||
io.directories.search literals math.functions ;
|
io.directories.search literals math.functions continuations ;
|
||||||
IN: id3
|
IN: id3
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
@ -205,7 +205,9 @@ CONSTANT: id3v1+-offset $[ 128 227 + ]
|
||||||
drop
|
drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: (mp3>id3) ( path -- id3v2/f )
|
PRIVATE>
|
||||||
|
|
||||||
|
: mp3>id3 ( path -- id3/f )
|
||||||
[
|
[
|
||||||
[ <id3> ] dip
|
[ <id3> ] dip
|
||||||
{
|
{
|
||||||
|
@ -213,12 +215,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ]
|
||||||
[ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ]
|
[ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ]
|
||||||
[ dup id3v2? [ read-v2-tags ] [ drop ] if ]
|
[ dup id3v2? [ read-v2-tags ] [ drop ] if ]
|
||||||
} cleave
|
} cleave
|
||||||
] with-mapped-uchar-file ;
|
] with-mapped-uchar-file-reader ;
|
||||||
|
|
||||||
PRIVATE>
|
|
||||||
|
|
||||||
: mp3>id3 ( path -- id3/f )
|
|
||||||
dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ;
|
|
||||||
|
|
||||||
: find-id3-frame ( id3 name -- obj/f )
|
: find-id3-frame ( id3 name -- obj/f )
|
||||||
swap frames>> at* [ data>> ] when ;
|
swap frames>> at* [ data>> ] when ;
|
||||||
|
@ -239,8 +236,14 @@ PRIVATE>
|
||||||
: find-mp3s ( path -- seq )
|
: find-mp3s ( path -- seq )
|
||||||
[ >lower ".mp3" tail? ] find-all-files ;
|
[ >lower ".mp3" tail? ] find-all-files ;
|
||||||
|
|
||||||
|
ERROR: id3-parse-error path error ;
|
||||||
|
|
||||||
|
: (mp3-paths>id3s) ( seq -- seq' )
|
||||||
|
[ dup [ mp3>id3 ] [ \ id3-parse-error boa ] recover ] { } map>assoc ;
|
||||||
|
|
||||||
: mp3-paths>id3s ( seq -- seq' )
|
: mp3-paths>id3s ( seq -- seq' )
|
||||||
[ dup mp3>id3 ] { } map>assoc ;
|
(mp3-paths>id3s)
|
||||||
|
[ dup second id3-parse-error? [ f over set-second ] when ] map ;
|
||||||
|
|
||||||
: parse-mp3-directory ( path -- seq )
|
: parse-mp3-directory ( path -- seq )
|
||||||
find-mp3s mp3-paths>id3s ;
|
find-mp3s mp3-paths>id3s ;
|
||||||
|
|
|
@ -2,33 +2,26 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors images images.loader io.pathnames kernel namespaces
|
USING: accessors images images.loader io.pathnames kernel namespaces
|
||||||
opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
|
opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
|
||||||
ui.gadgets.panes ui.render ;
|
ui.gadgets.panes ui.render ui.images ;
|
||||||
IN: images.viewer
|
IN: images.viewer
|
||||||
|
|
||||||
TUPLE: image-gadget < gadget { image image } ;
|
TUPLE: image-gadget < gadget image-name ;
|
||||||
|
|
||||||
M: image-gadget pref-dim*
|
M: image-gadget pref-dim*
|
||||||
image>> dim>> ;
|
image-name>> image-dim ;
|
||||||
|
|
||||||
: draw-image ( image -- )
|
|
||||||
0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
|
|
||||||
[ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
|
|
||||||
glDrawPixels ;
|
|
||||||
|
|
||||||
M: image-gadget draw-gadget* ( gadget -- )
|
M: image-gadget draw-gadget* ( gadget -- )
|
||||||
image>> draw-image ;
|
image-name>> draw-image ;
|
||||||
|
|
||||||
: <image-gadget> ( image -- gadget )
|
: <image-gadget> ( image-name -- gadget )
|
||||||
\ image-gadget new
|
\ image-gadget new
|
||||||
swap >>image ;
|
swap >>image-name ;
|
||||||
|
|
||||||
: image-window ( path -- gadget )
|
: image-window ( path -- gadget )
|
||||||
[ load-image <image-gadget> dup ] [ open-window ] bi ;
|
[ <image-name> <image-gadget> dup ] [ open-window ] bi ;
|
||||||
|
|
||||||
GENERIC: image. ( object -- )
|
GENERIC: image. ( object -- )
|
||||||
|
|
||||||
M: string image. ( image -- ) load-image image. ;
|
M: string image. ( image -- ) <image-name> <image-gadget> gadget. ;
|
||||||
|
|
||||||
M: pathname image. ( image -- ) load-image image. ;
|
M: pathname image. ( image -- ) <image-name> <image-gadget> gadget. ;
|
||||||
|
|
||||||
M: image image. ( image -- ) <image-gadget> gadget. ;
|
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays accessors io io.sockets io.encodings.utf8 io.files
|
USING: arrays accessors io io.sockets io.encodings.utf8 io.files
|
||||||
io.launcher kernel make mason.config mason.common mason.email
|
io.launcher kernel make mason.config mason.common mason.email
|
||||||
mason.twitter namespaces sequences ;
|
mason.twitter namespaces sequences prettyprint ;
|
||||||
IN: mason.notify
|
IN: mason.notify
|
||||||
|
|
||||||
: status-notify ( input-file args -- )
|
: status-notify ( input-file args -- )
|
||||||
|
@ -38,7 +38,7 @@ IN: mason.notify
|
||||||
f { "test" } status-notify ;
|
f { "test" } status-notify ;
|
||||||
|
|
||||||
: notify-report ( status -- )
|
: notify-report ( status -- )
|
||||||
[ "Build finished with status: " write print flush ]
|
[ "Build finished with status: " write . flush ]
|
||||||
[
|
[
|
||||||
[ "report" utf8 file-contents ] dip email-report
|
[ "report" utf8 file-contents ] dip email-report
|
||||||
"report" { "report" } status-notify
|
"report" { "report" } status-notify
|
||||||
|
|
|
@ -28,7 +28,7 @@ IN: mason.report
|
||||||
common-report
|
common-report
|
||||||
_ call( -- xml )
|
_ call( -- xml )
|
||||||
[XML <html><body><-><-></body></html> XML]
|
[XML <html><body><-><-></body></html> XML]
|
||||||
pprint-xml
|
write-xml
|
||||||
] with-file-writer ; inline
|
] with-file-writer ; inline
|
||||||
|
|
||||||
:: failed-report ( error file what -- status )
|
:: failed-report ( error file what -- status )
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
USING: arrays morse strings tools.test ;
|
USING: arrays morse strings tools.test ;
|
||||||
IN: morse.tests
|
IN: morse.tests
|
||||||
|
|
||||||
[ CHAR: ? ] [ CHAR: \\ ch>morse ] unit-test
|
[ "?" ] [ CHAR: \\ ch>morse ] unit-test
|
||||||
[ "..." ] [ CHAR: s ch>morse ] unit-test
|
[ "..." ] [ CHAR: s ch>morse ] unit-test
|
||||||
[ CHAR: s ] [ "..." morse>ch ] unit-test
|
[ CHAR: s ] [ "..." morse>ch ] unit-test
|
||||||
[ CHAR: \s ] [ "..--..--.." morse>ch ] unit-test
|
[ CHAR: \s ] [ "..--..--.." morse>ch ] unit-test
|
||||||
|
@ -41,3 +41,4 @@ IN: morse.tests
|
||||||
MORSE] ] unit-test
|
MORSE] ] unit-test
|
||||||
! [ ] [ "sos" 0.075 play-as-morse* ] unit-test
|
! [ ] [ "sos" 0.075 play-as-morse* ] unit-test
|
||||||
! [ ] [ "Factor rocks!" play-as-morse ] unit-test
|
! [ ] [ "Factor rocks!" play-as-morse ] unit-test
|
||||||
|
! [ ] [ "\n" play-as-morse ] unit-test
|
||||||
|
|
|
@ -3,13 +3,15 @@
|
||||||
USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ;
|
USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ;
|
||||||
IN: morse
|
IN: morse
|
||||||
|
|
||||||
|
ERROR: no-morse-code ch ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
CONSTANT: dot-char CHAR: .
|
CONSTANT: dot-char CHAR: .
|
||||||
CONSTANT: dash-char CHAR: -
|
CONSTANT: dash-char CHAR: -
|
||||||
CONSTANT: char-gap-char CHAR: \s
|
CONSTANT: char-gap-char CHAR: \s
|
||||||
CONSTANT: word-gap-char CHAR: /
|
CONSTANT: word-gap-char CHAR: /
|
||||||
CONSTANT: unknown-char CHAR: ?
|
CONSTANT: unknown-char "?"
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
@ -74,10 +76,10 @@ CONSTANT: morse-code-table $[
|
||||||
]
|
]
|
||||||
|
|
||||||
: ch>morse ( ch -- morse )
|
: ch>morse ( ch -- morse )
|
||||||
ch>lower morse-code-table at [ unknown-char ] unless* ;
|
ch>lower morse-code-table at unknown-char or ;
|
||||||
|
|
||||||
: morse>ch ( str -- ch )
|
: morse>ch ( str -- ch )
|
||||||
morse-code-table value-at [ char-gap-char ] unless* ;
|
morse-code-table value-at char-gap-char or ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
|
@ -148,12 +150,13 @@ CONSTANT: beep-freq 880
|
||||||
source get source-play
|
source get source-play
|
||||||
] with-scope ; inline
|
] with-scope ; inline
|
||||||
|
|
||||||
: play-char ( ch -- )
|
: play-char ( string -- )
|
||||||
[ intra-char-gap ] [
|
[ intra-char-gap ] [
|
||||||
{
|
{
|
||||||
{ dot-char [ dot ] }
|
{ dot-char [ dot ] }
|
||||||
{ dash-char [ dash ] }
|
{ dash-char [ dash ] }
|
||||||
{ word-gap-char [ intra-char-gap ] }
|
{ word-gap-char [ intra-char-gap ] }
|
||||||
|
[ drop intra-char-gap ]
|
||||||
} case
|
} case
|
||||||
] interleave ;
|
] interleave ;
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Joe Groff
|
|
@ -0,0 +1,15 @@
|
||||||
|
! (c)2009 Joe Groff bsd license
|
||||||
|
USING: help.markup help.syntax multiline ;
|
||||||
|
IN: pair-rocket
|
||||||
|
|
||||||
|
HELP: =>
|
||||||
|
{ $syntax "a => b" }
|
||||||
|
{ $description "Constructs a two-element array from the objects immediately before and after the " { $snippet "=>" } ". This syntax can be used inside sequence and assoc literals." }
|
||||||
|
{ $examples
|
||||||
|
{ $unchecked-example <" USING: pair-rocket prettyprint ;
|
||||||
|
|
||||||
|
H{ "foo" => 1 "bar" => 2 } .
|
||||||
|
"> <" H{ { "foo" 1 } { "bar" 2 } } "> }
|
||||||
|
}
|
||||||
|
;
|
||||||
|
|
|
@ -0,0 +1,10 @@
|
||||||
|
! (c)2009 Joe Groff bsd license
|
||||||
|
USING: kernel pair-rocket tools.test ;
|
||||||
|
IN: pair-rocket.tests
|
||||||
|
|
||||||
|
[ { "a" 1 } ] [ "a" => 1 ] unit-test
|
||||||
|
[ { { "a" } { 1 } } ] [ { "a" } => { 1 } ] unit-test
|
||||||
|
[ { drop 1 } ] [ drop => 1 ] unit-test
|
||||||
|
|
||||||
|
[ H{ { "zippity" 5 } { "doo" 2 } { "dah" 7 } } ]
|
||||||
|
[ H{ "zippity" => 5 "doo" => 2 "dah" => 7 } ] unit-test
|
|
@ -0,0 +1,6 @@
|
||||||
|
! (c)2009 Joe Groff bsd license
|
||||||
|
USING: arrays kernel parser sequences ;
|
||||||
|
IN: pair-rocket
|
||||||
|
|
||||||
|
SYNTAX: => dup pop scan-object 2array parsed ;
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
H{ "foo" => 1 "bar" => 2 } style literal syntax
|
|
@ -0,0 +1 @@
|
||||||
|
Joe Groff
|
|
@ -0,0 +1,12 @@
|
||||||
|
! (c)2009 Joe Groff bsd license
|
||||||
|
USING: help.markup help.syntax multiline ;
|
||||||
|
IN: qw
|
||||||
|
|
||||||
|
HELP: qw{
|
||||||
|
{ $syntax "qw{ lorem ipsum }" }
|
||||||
|
{ $description "Marks the beginning of a literal array of strings. Component strings are delimited by whitespace." }
|
||||||
|
{ $examples
|
||||||
|
{ $unchecked-example <" USING: prettyprint qw ;
|
||||||
|
qw{ pop quiz my hive of big wild ex tranny jocks } . ">
|
||||||
|
<" { "pop" "quiz" "my" "hive" "of" "big" "wild" "ex" "tranny" "jocks" } "> }
|
||||||
|
} ;
|
|
@ -0,0 +1,5 @@
|
||||||
|
! (c)2009 Joe Groff bsd license
|
||||||
|
USING: qw tools.test ;
|
||||||
|
IN: qw.tests
|
||||||
|
|
||||||
|
[ { "zippity" "doo" "dah" } ] [ qw{ zippity doo dah } ] unit-test
|
|
@ -0,0 +1,5 @@
|
||||||
|
! (c)2009 Joe Groff bsd license
|
||||||
|
USING: lexer parser ;
|
||||||
|
IN: qw
|
||||||
|
|
||||||
|
SYNTAX: qw{ "}" parse-tokens parsed ;
|
|
@ -0,0 +1 @@
|
||||||
|
Perlish syntax for literal arrays of whitespace-delimited strings (qw{ foo bar })
|
|
@ -0,0 +1 @@
|
||||||
|
Joe Groff
|
|
@ -0,0 +1,48 @@
|
||||||
|
! (c)2009 Joe Groff bsd license
|
||||||
|
USING: classes.mixin help.markup help.syntax kernel multiline roles ;
|
||||||
|
IN: roles
|
||||||
|
|
||||||
|
HELP: ROLE:
|
||||||
|
{ $syntax <" ROLE: name slots... ;
|
||||||
|
ROLE: name < role slots... ;
|
||||||
|
ROLE: name <{ roles... } slots... ; "> }
|
||||||
|
{ $description "Defines a new " { $link role } ". " { $link tuple } " classes which inherit this role will contain the specified " { $snippet "slots" } " as well as the slots associated with the optional inherited " { $snippet "roles" } "."
|
||||||
|
$nl
|
||||||
|
"Slot specifiers take one of the following three forms:"
|
||||||
|
{ $list
|
||||||
|
{ { $snippet "name" } " - a slot which can hold any object, with no attributes" }
|
||||||
|
{ { $snippet "{ name attributes... }" } " - a slot which can hold any object, with optional attributes" }
|
||||||
|
{ { $snippet "{ name class attributes... }" } " - a slot specialized to a specific class, with optional attributes" }
|
||||||
|
}
|
||||||
|
"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } ;
|
||||||
|
|
||||||
|
HELP: TUPLE:
|
||||||
|
{ $syntax <" TUPLE: name slots ;
|
||||||
|
TUPLE: name < estate slots ;
|
||||||
|
TUPLE: name <{ estates... } slots... ; "> }
|
||||||
|
{ $description "Defines a new " { $link tuple } " class."
|
||||||
|
$nl
|
||||||
|
"The list of inherited " { $snippet "estates" } " is optional; a single tuple superclass and/or a set of " { $link role } "s can be specified. If no superclass is provided, it defaults to " { $link tuple } "."
|
||||||
|
$nl
|
||||||
|
"Slot specifiers take one of the following three forms:"
|
||||||
|
{ $list
|
||||||
|
{ { $snippet "name" } " - a slot which can hold any object, with no attributes" }
|
||||||
|
{ { $snippet "{ name attributes... }" } " - a slot which can hold any object, with optional attributes" }
|
||||||
|
{ { $snippet "{ name class attributes... }" } " - a slot specialized to a specific class, with optional attributes" }
|
||||||
|
}
|
||||||
|
"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } ;
|
||||||
|
|
||||||
|
{
|
||||||
|
POSTPONE: ROLE:
|
||||||
|
POSTPONE: TUPLE:
|
||||||
|
} related-words
|
||||||
|
|
||||||
|
HELP: role
|
||||||
|
{ $class-description "The superclass of all role classes. A " { $snippet "role" } " is a " { $link mixin-class } " that includes a set of slot definitions that can be added to " { $link tuple } " classes alongside other " { $snippet "role" } "s." } ;
|
||||||
|
|
||||||
|
HELP: multiple-inheritance-attempted
|
||||||
|
{ $class-description "This error is thrown if a " { $link POSTPONE: TUPLE: } " definition attempts to inherit more than one " { $link tuple } " class." } ;
|
||||||
|
|
||||||
|
HELP: role-slot-overlap
|
||||||
|
{ $class-description "This error is thrown if a " { $link POSTPONE: TUPLE: } " or " { $link POSTPONE: ROLE: } " definition attempts to inherit a set of " { $link role } "s in which more than one attempts to define the same slot." } ;
|
||||||
|
|
|
@ -0,0 +1,67 @@
|
||||||
|
! (c)2009 Joe Groff bsd license
|
||||||
|
USING: accessors classes.tuple compiler.units kernel qw roles sequences
|
||||||
|
tools.test ;
|
||||||
|
IN: roles.tests
|
||||||
|
|
||||||
|
ROLE: fork tines ;
|
||||||
|
ROLE: spoon bowl ;
|
||||||
|
ROLE: instrument tone ;
|
||||||
|
ROLE: tuning-fork <{ fork instrument } volume ;
|
||||||
|
|
||||||
|
TUPLE: utensil handle ;
|
||||||
|
|
||||||
|
! role consumption and tuple inheritance can be mixed
|
||||||
|
TUPLE: foon <{ utensil fork spoon } ;
|
||||||
|
TUPLE: tuning-spork <{ utensil spoon tuning-fork } ;
|
||||||
|
|
||||||
|
! role class testing
|
||||||
|
[ t ] [ fork role? ] unit-test
|
||||||
|
[ f ] [ foon role? ] unit-test
|
||||||
|
|
||||||
|
! roles aren't tuple classes by themselves and can't be instantiated
|
||||||
|
[ f ] [ fork tuple-class? ] unit-test
|
||||||
|
[ fork new ] must-fail
|
||||||
|
|
||||||
|
! tuples which consume roles fall under their class
|
||||||
|
[ t ] [ foon new fork? ] unit-test
|
||||||
|
[ t ] [ foon new spoon? ] unit-test
|
||||||
|
[ f ] [ foon new tuning-fork? ] unit-test
|
||||||
|
[ f ] [ foon new instrument? ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ tuning-spork new fork? ] unit-test
|
||||||
|
[ t ] [ tuning-spork new spoon? ] unit-test
|
||||||
|
[ t ] [ tuning-spork new tuning-fork? ] unit-test
|
||||||
|
[ t ] [ tuning-spork new instrument? ] unit-test
|
||||||
|
|
||||||
|
! consumed role slots are placed in tuples in order
|
||||||
|
[ qw{ handle tines bowl } ] [ foon all-slots [ name>> ] map ] unit-test
|
||||||
|
[ qw{ handle bowl tines tone volume } ] [ tuning-spork all-slots [ name>> ] map ] unit-test
|
||||||
|
|
||||||
|
! can't combine roles whose slots overlap
|
||||||
|
ROLE: bong bowl ;
|
||||||
|
SYMBOL: spong
|
||||||
|
|
||||||
|
[ [ spong { spoon bong } { } define-tuple-class-with-roles ] with-compilation-unit ]
|
||||||
|
[ role-slot-overlap? ] must-fail-with
|
||||||
|
|
||||||
|
[ [ spong { spoon bong } { } define-role ] with-compilation-unit ]
|
||||||
|
[ role-slot-overlap? ] must-fail-with
|
||||||
|
|
||||||
|
! can't try to inherit multiple tuple classes
|
||||||
|
TUPLE: tool blade ;
|
||||||
|
SYMBOL: knife
|
||||||
|
|
||||||
|
[ knife { utensil tool } { } define-tuple-class-with-roles ]
|
||||||
|
[ multiple-inheritance-attempted? ] must-fail-with
|
||||||
|
|
||||||
|
! make sure method dispatch works
|
||||||
|
GENERIC: poke ( pokee poker -- result )
|
||||||
|
GENERIC: scoop ( scoopee scooper -- result )
|
||||||
|
GENERIC: tune ( tunee tuner -- result )
|
||||||
|
|
||||||
|
M: fork poke drop " got poked" append ;
|
||||||
|
M: spoon scoop drop " got scooped" append ;
|
||||||
|
M: instrument tune drop " got tuned" append ;
|
||||||
|
|
||||||
|
[ "potato got poked" "potato got scooped" "potato got tuned" ]
|
||||||
|
[ "potato" tuning-spork new [ poke ] [ scoop ] [ tune ] 2tri ] unit-test
|
|
@ -0,0 +1,69 @@
|
||||||
|
! (c)2009 Joe Groff bsd license
|
||||||
|
USING: accessors arrays classes classes.mixin classes.parser
|
||||||
|
classes.tuple classes.tuple.parser combinators
|
||||||
|
combinators.short-circuit kernel lexer make parser sequences
|
||||||
|
sets strings words ;
|
||||||
|
IN: roles
|
||||||
|
|
||||||
|
ERROR: role-slot-overlap class slots ;
|
||||||
|
ERROR: multiple-inheritance-attempted classes ;
|
||||||
|
|
||||||
|
PREDICATE: role < class
|
||||||
|
{ [ mixin-class? ] [ "role-slots" word-prop >boolean ] } 1&& ;
|
||||||
|
|
||||||
|
: parse-role-definition ( -- class superroles slots )
|
||||||
|
CREATE-CLASS scan {
|
||||||
|
{ ";" [ { } { } ] }
|
||||||
|
{ "<" [ scan-word 1array [ parse-tuple-slots ] { } make ] }
|
||||||
|
{ "<{" [ \ } parse-until >array [ parse-tuple-slots ] { } make ] }
|
||||||
|
[ { } swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
: slot-name ( name/array -- name )
|
||||||
|
dup string? [ ] [ first ] if ;
|
||||||
|
: slot-names ( array -- names )
|
||||||
|
[ slot-name ] map ;
|
||||||
|
|
||||||
|
: role-slots ( role -- slots )
|
||||||
|
[ "superroles" word-prop [ role-slots ] map concat ]
|
||||||
|
[ "role-slots" word-prop ] bi append ;
|
||||||
|
|
||||||
|
: role-or-tuple-slot-names ( role-or-tuple -- names )
|
||||||
|
dup role?
|
||||||
|
[ role-slots slot-names ]
|
||||||
|
[ all-slots [ name>> ] map ] if ;
|
||||||
|
|
||||||
|
: check-for-slot-overlap ( class roles-and-superclass slots -- )
|
||||||
|
[ [ role-or-tuple-slot-names ] map concat ] [ slot-names ] bi* append
|
||||||
|
duplicates dup empty? [ 2drop ] [ role-slot-overlap ] if ;
|
||||||
|
|
||||||
|
: roles>slots ( roles-and-superclass slots -- superclass slots' )
|
||||||
|
[
|
||||||
|
[ role? ] partition
|
||||||
|
dup length {
|
||||||
|
{ 0 [ drop tuple ] }
|
||||||
|
{ 1 [ first ] }
|
||||||
|
[ drop multiple-inheritance-attempted ]
|
||||||
|
} case
|
||||||
|
swap [ role-slots ] map concat
|
||||||
|
] dip append ;
|
||||||
|
|
||||||
|
: add-to-roles ( class roles -- )
|
||||||
|
[ add-mixin-instance ] with each ;
|
||||||
|
|
||||||
|
: (define-role) ( class superroles slots -- )
|
||||||
|
[ "superroles" set-word-prop ] [ "role-slots" set-word-prop ] bi-curry*
|
||||||
|
[ define-mixin-class ] tri ;
|
||||||
|
|
||||||
|
: define-role ( class superroles slots -- )
|
||||||
|
[ check-for-slot-overlap ] [ (define-role) ] [ drop add-to-roles ] 3tri ;
|
||||||
|
|
||||||
|
: define-tuple-class-with-roles ( class roles-and-superclass slots -- )
|
||||||
|
[ check-for-slot-overlap ]
|
||||||
|
[ roles>slots define-tuple-class ]
|
||||||
|
[ drop [ role? ] filter add-to-roles ] 3tri ;
|
||||||
|
|
||||||
|
SYNTAX: ROLE: parse-role-definition define-role ;
|
||||||
|
SYNTAX: TUPLE: parse-role-definition define-tuple-class-with-roles ;
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Mixins for tuples
|
Loading…
Reference in New Issue