steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix conflict from master

db4
Slava Pestov 2009-04-27 17:09:09 -05:00
parent 63fff0a832 4cc48dcb12
commit bba30dc284
93 changed files with 1021 additions and 283 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile
View File

@ -15,9 +15,11 @@ FFI_TEST_CFLAGS = -fPIC
ifdef DEBUG
CFLAGS += -g
else
CFLAGS += -O3 $(SITE_CFLAGS)
CFLAGS += -O3
endif
CFLAGS += $(SITE_CFLAGS)
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
ifdef CONFIG

9
basis/calendar/calendar-tests.factor
View File

@ -1,5 +1,5 @@
USING: arrays calendar kernel math sequences tools.test
continuations system math.order threads ;
continuations system math.order threads accessors ;
IN: calendar.tests
[ f ] [ 2004 12 32 0 0 0 instant <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 swap after? ] unit-test
[ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
[ 4 12 ] [ 2009 easter [ month>> ] [ day>> ] bi ] unit-test
[ 4 2 ] [ 1961 easter [ month>> ] [ day>> ] bi ] unit-test
[ f ] [ now dup midnight eq? ] unit-test
[ f ] [ now dup easter eq? ] unit-test
[ f ] [ now dup beginning-of-year eq? ] unit-test

64
basis/calendar/calendar.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.tuple combinators combinators.short-circuit
kernel locals math math.functions math.order namespaces sequences strings
summary system threads vocabs.loader ;
USING: accessors arrays classes.tuple combinators
combinators.short-circuit kernel locals math math.functions
math.order sequences summary system threads vocabs.loader ;
IN: calendar
HOOK: gmt-offset os ( -- hours minutes seconds )
@ -94,26 +94,50 @@ CONSTANT: day-abbreviations3
:: julian-day-number ( year month day -- n )
#! Returns a composite date number
#! Not valid before year -4800
[let* | a [ 14 month - 12 /i ]
y [ year 4800 + a - ]
m [ month 12 a * + 3 - ] |
day 153 m * 2 + 5 /i + 365 y * +
y 4 /i + y 100 /i - y 400 /i + 32045 -
] ;
14 month - 12 /i :> a
year 4800 + a - :> y
month 12 a * + 3 - :> m
day 153 m * 2 + 5 /i + 365 y * +
y 4 /i + y 100 /i - y 400 /i + 32045 - ;
:: julian-day-number>date ( n -- year month day )
#! Inverse of julian-day-number
[let* | a [ n 32044 + ]
b [ 4 a * 3 + 146097 /i ]
c [ a 146097 b * 4 /i - ]
d [ 4 c * 3 + 1461 /i ]
e [ c 1461 d * 4 /i - ]
m [ 5 e * 2 + 153 /i ] |
100 b * d + 4800 -
m 10 /i + m 3 +
12 m 10 /i * -
e 153 m * 2 + 5 /i - 1+
] ;
n 32044 + :> a
4 a * 3 + 146097 /i :> b
a 146097 b * 4 /i - :> c
4 c * 3 + 1461 /i :> d
c 1461 d * 4 /i - :> e
5 e * 2 + 153 /i :> m
100 b * d + 4800 -
m 10 /i + m 3 +
12 m 10 /i * -
e 153 m * 2 + 5 /i - 1+ ;
GENERIC: easter ( obj -- obj' )
:: easter-month-day ( year -- month day )
year 19 mod :> a
year 100 /mod :> c :> b
b 4 /mod :> e :> d
b 8 + 25 /i :> f
b f - 1 + 3 /i :> g
19 a * b + d - g - 15 + 30 mod :> h
c 4 /mod :> k :> i
32 2 e * + 2 i * + h - k - 7 mod :> l
a 11 h * + 22 l * + 451 /i :> m
h l + 7 m * - 114 + 31 /mod 1 + :> day :> month
month day ;
M: integer easter ( year -- timestamp )
dup easter-month-day <date> ;
M: timestamp easter ( timestamp -- timestamp )
clone
dup year>> easter-month-day
swapd >>day swap >>month ;
: >date< ( timestamp -- year month day )
[ year>> ] [ month>> ] [ day>> ] tri ;

2
basis/checksums/md5/md5.factor
View File

@ -14,7 +14,7 @@ IN: checksums.md5
SYMBOLS: a b c d old-a old-b old-c old-d ;
: T ( N -- Y )
sin abs 4294967296 * >integer ; foldable
sin abs 32 2^ * >integer ; foldable
: initialize-md5 ( -- )
0 bytes-read set

4
basis/combinators/smart/smart.factor
View File

@ -18,6 +18,10 @@ MACRO: input<sequence ( quot -- newquot )
[ infer in>> ] keep
'[ _ firstn @ ] ;
MACRO: input<sequence-unsafe ( quot -- newquot )
[ infer in>> ] keep
'[ _ firstn-unsafe @ ] ;
MACRO: reduce-outputs ( quot operation -- newquot )
[ dup infer out>> 1 [-] ] dip n*quot compose ;

2
basis/compiler/tests/alien.factor
View File

@ -5,7 +5,7 @@ continuations effects namespaces.private io io.streams.string
memory system threads tools.test math accessors combinators
specialized-arrays.float alien.libraries io.pathnames
io.backend ;
IN: compiler.tests
IN: compiler.tests.alien
<<
: libfactor-ffi-tests-path ( -- string )

4
basis/compiler/tests/codegen.factor
View File

@ -4,7 +4,7 @@ sequences sequences.private tools.test namespaces.private
slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make ;
IN: compiler.tests
IN: compiler.tests.codegen
! Originally, this file did black box testing of templating
! optimization. We now have a different codegen, but the tests
@ -281,4 +281,4 @@ TUPLE: cucumber ;
M: cucumber equal? "The cucumber has no equal" throw ;
[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test

2
basis/compiler/tests/curry.factor
View File

@ -1,6 +1,6 @@
USING: tools.test quotations math kernel sequences
assocs namespaces make compiler.units compiler ;
IN: compiler.tests
IN: compiler.tests.curry
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test

2
basis/compiler/tests/float.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.float
USING: compiler.units compiler kernel kernel.private memory math
math.private tools.test math.floats.private ;

2
basis/compiler/tests/folding.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel classes.mixin arrays ;
IN: compiler.tests
IN: compiler.tests.folding
! Calls to generic words were not folded away.

2
basis/compiler/tests/intrinsics.factor
View File

@ -6,7 +6,7 @@ sbufs strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings
namespaces libc sequences.private io.encodings.ascii
classes compiler ;
IN: compiler.tests
IN: compiler.tests.intrinsics
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test

2
basis/compiler/tests/optimizer.factor
View File

@ -5,7 +5,7 @@ quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer sequences.deep
compiler ;
IN: optimizer.tests
IN: compiler.tests.optimizer
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;

4
basis/compiler/tests/peg-regression-2.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.peg-regression-2
USING: peg.ebnf strings tools.test ;
GENERIC: <times> ( times -- term' )
@ -12,4 +12,4 @@ Regexp = Times:t => [[ t <times> ]]
;EBNF
[ "foo" ] [ "a" parse-regexp ] unit-test
[ "foo" ] [ "a" parse-regexp ] unit-test

2
basis/compiler/tests/peg-regression.factor
View File

@ -5,7 +5,7 @@
! end of a compilation unit.
USING: kernel accessors peg.ebnf ;
IN: compiler.tests
IN: compiler.tests.peg-regression
TUPLE: pipeline-expr background ;

2
basis/compiler/tests/redefine0.factor
View File

@ -104,4 +104,4 @@ quot global delete-at
\ test-11 forget
\ quot forget
] with-compilation-unit
] unit-test
] unit-test

6
basis/compiler/tests/redefine1.factor
View File

@ -1,7 +1,7 @@
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval strings ;
IN: compiler.tests
IN: compiler.tests.redefine1
GENERIC: method-redefine-generic-1 ( a -- b )
@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ;
[ 6 ] [ method-redefine-test-1 ] unit-test
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
[ ] [ "IN: compiler.tests.redefine1 USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test
@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ;
[ 6 ] [ method-redefine-test-2 ] unit-test
[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
[ ] [ "IN: compiler.tests.redefine1 USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-2 ] unit-test

2
basis/compiler/tests/redefine10.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine10
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine11.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel classes.mixin arrays ;
IN: compiler.tests
IN: compiler.tests.redefine11
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine15.factor
View File

@ -17,4 +17,4 @@ DEFER: word-1
[ \ word-3 [ [ 2 + ] bi@ ] (( a b -- c d )) define-declared ] with-compilation-unit
[ 2 3 ] [ 0 word-4 ] unit-test
[ 2 3 ] [ 0 word-4 ] unit-test

4
basis/compiler/tests/redefine2.factor
View File

@ -1,11 +1,11 @@
IN: compiler.tests
IN: compiler.tests.redefine2
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs eval words.symbol ;
DEFER: redefine2-test
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
[ ] [ "USE: sequences USE: kernel IN: compiler.tests.redefine2 TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
[ t ] [ \ redefine2-test symbol? ] unit-test

4
basis/compiler/tests/redefine3.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.redefine3
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval ;
@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ;
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
[ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
[ "wake up" ] [ sheeple-test ] unit-test
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

4
basis/compiler/tests/redefine4.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.redefine4
USING: io.streams.string kernel tools.test eval ;
: declaration-test-1 ( -- a ) 3 ; flushable
@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test
[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
[ ] [ "IN: compiler.tests.redefine4 USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test

2
basis/compiler/tests/redefine5.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine5
! Regression: if dispatch was eliminated but method was not inlined,
! compiled usage information was not recorded.

2
basis/compiler/tests/redefine6.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine6
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine7.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine7
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine8.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine8
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine9.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel generic.math ;
IN: compiler.tests
IN: compiler.tests.redefine9
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/reload.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.reload
USE: vocabs.loader
! "parser" reload

2
basis/compiler/tests/simple.factor
View File

@ -1,7 +1,7 @@
USING: compiler compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings alien
arrays memory vocabs parser eval ;
IN: compiler.tests
IN: compiler.tests.simple
! Test empty word
[ ] [ [ ] compile-call ] unit-test

2
basis/compiler/tests/spilling.factor
View File

@ -1,6 +1,6 @@
USING: math.private kernel combinators accessors arrays
generalizations tools.test ;
IN: compiler.tests
IN: compiler.tests.spilling
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
{

2
basis/compiler/tests/stack-trace.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.stack-trace
USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private
words splitting grouping sorting accessors ;

2
basis/compiler/tests/tuples.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.tuples
USING: kernel tools.test compiler.units compiler ;
TUPLE: color red green blue ;

19
basis/compiler/tree/builder/builder.factor
View File

@ -54,15 +54,16 @@ PRIVATE>
#! This slows down compiler.tree.propagation.inlining since then every
#! inlined usage of a method has an inline-dependency on the mixin, and
#! not the more specific type at the call site.
specialize-method? off
[
#call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
{
{ [ dup not ] [ ] }
{ [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
[ in-d #call out-d>> #copy suffix ]
} cond
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ;
f specialize-method? [
[
#call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
{
{ [ dup not ] [ ] }
{ [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
[ in-d #call out-d>> #copy suffix ]
} cond
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
] with-variable ;
: contains-breakpoints? ( word -- ? )
def>> [ word? ] filter [ "break?" word-prop ] any? ;

25
basis/functors/functors-tests.factor
View File

@ -63,6 +63,24 @@ WHERE
[ 4 ] [ 1 3 blah ] unit-test
<<
FUNCTOR: symbol-test ( W -- )
W DEFINES ${W}
WHERE
SYMBOL: W
;FUNCTOR
"blorgh" symbol-test
>>
[ blorgh ] [ blorgh ] unit-test
GENERIC: some-generic ( a -- b )
! Does replacing an ordinary word with a functor-generated one work?
@ -72,6 +90,7 @@ GENERIC: some-generic ( a -- b )
TUPLE: some-tuple ;
: some-word ( -- ) ;
M: some-tuple some-generic ;
SYMBOL: some-symbol
"> <string-reader> "functors-test" parse-stream
] unit-test
@ -82,6 +101,7 @@ GENERIC: some-generic ( a -- b )
"some-tuple" "functors.tests" lookup
"some-generic" "functors.tests" lookup method >boolean
] unit-test ;
[ t ] [ "some-symbol" "functors.tests" lookup >boolean ] unit-test
test-redefinition
@ -90,12 +110,14 @@ FUNCTOR: redefine-test ( W -- )
W-word DEFINES ${W}-word
W-tuple DEFINES-CLASS ${W}-tuple
W-generic IS ${W}-generic
W-symbol DEFINES ${W}-symbol
WHERE
TUPLE: W-tuple ;
: W-word ( -- ) ;
M: W-tuple W-generic ;
SYMBOL: W-symbol
;FUNCTOR
@ -105,4 +127,5 @@ M: W-tuple W-generic ;
"> <string-reader> "functors-test" parse-stream
] unit-test
test-redefinition
test-redefinition

34
basis/functors/functors.factor
View File

@ -5,7 +5,7 @@ words interpolate namespaces sequences io.streams.string fry
classes.mixin effects lexer parser classes.tuple.parser
effects.parser locals.types locals.parser generic.parser
locals.rewrite.closures vocabs.parser classes.parser
arrays accessors ;
arrays accessors words.symbol ;
IN: functors
! This is a hack
@ -18,6 +18,8 @@ IN: functors
: define-declared* ( word def effect -- ) pick set-word define-declared ;
TUPLE: fake-call-next-method ;
TUPLE: fake-quotation seq ;
GENERIC: >fake-quotations ( quot -- fake )
@ -29,17 +31,25 @@ M: array >fake-quotations [ >fake-quotations ] { } map-as ;
M: object >fake-quotations ;
GENERIC: fake-quotations> ( fake -- quot )
GENERIC: (fake-quotations>) ( fake -- )
M: fake-quotation fake-quotations>
seq>> [ fake-quotations> ] [ ] map-as ;
: fake-quotations> ( fake -- quot )
[ (fake-quotations>) ] [ ] make ;
M: array fake-quotations> [ fake-quotations> ] map ;
M: fake-quotation (fake-quotations>)
[ seq>> [ (fake-quotations>) ] each ] [ ] make , ;
M: object fake-quotations> ;
M: array (fake-quotations>)
[ [ (fake-quotations>) ] each ] { } make , ;
M: fake-call-next-method (fake-quotations>)
drop method-body get literalize , \ (call-next-method) , ;
M: object (fake-quotations>) , ;
: parse-definition* ( accum -- accum )
parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
parse-definition >fake-quotations parsed
[ fake-quotations> first ] over push-all ;
: parse-declared* ( accum -- accum )
complete-effect
@ -64,7 +74,7 @@ SYNTAX: `TUPLE:
SYNTAX: `M:
scan-param parsed
scan-param parsed
\ create-method-in parsed
[ create-method-in dup method-body set ] over push-all
parse-definition*
\ define* parsed ;
@ -80,6 +90,10 @@ SYNTAX: `:
parse-declared*
\ define-declared* parsed ;
SYNTAX: `SYMBOL:
scan-param parsed
\ define-symbol parsed ;
SYNTAX: `SYNTAX:
scan-param parsed
parse-definition*
@ -92,6 +106,8 @@ SYNTAX: `INSTANCE:
SYNTAX: `inline [ word make-inline ] over push-all ;
SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
: (INTERPOLATE) ( accum quot -- accum )
[ scan interpolate-locals ] dip
'[ _ with-string-writer @ ] parsed ;
@ -116,7 +132,9 @@ DEFER: ;FUNCTOR delimiter
{ ":" POSTPONE: `: }
{ "INSTANCE:" POSTPONE: `INSTANCE: }
{ "SYNTAX:" POSTPONE: `SYNTAX: }
{ "SYMBOL:" POSTPONE: `SYMBOL: }
{ "inline" POSTPONE: `inline }
{ "call-next-method" POSTPONE: `call-next-method }
} ;
: push-functor-words ( -- )

9
basis/generalizations/generalizations.factor
View File

@ -26,11 +26,14 @@ MACRO: narray ( n -- )
MACRO: nsum ( n -- )
1- [ + ] n*quot ;
MACRO: firstn-unsafe ( n -- )
[ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
[ [ '[ [ _ ] dip nth-unsafe ] ] map ]
[ 1- '[ [ _ ] dip bounds-check 2drop ] ]
bi prefix '[ _ cleave ]
[ 1- swap bounds-check 2drop ]
[ firstn-unsafe ]
bi-curry '[ _ _ bi ]
] if ;
MACRO: npick ( n -- )

2
basis/inverse/inverse.factor
View File

@ -12,7 +12,7 @@ IN: inverse
ERROR: fail ;
M: fail summary drop "Matching failed" ;
: assure ( ? -- ) [ fail ] unless ;
: assure ( ? -- ) [ fail ] unless ; inline
: =/fail ( obj1 obj2 -- ) = assure ;

30
basis/io/directories/search/search.factor
View File

@ -39,55 +39,55 @@ TUPLE: directory-iterator path bfs queue ;
dup directory?
[ name>> over push-directory-entries next-directory-entry ]
[ nip ] if
] if ; recursive
] if ;
:: iterate-directory-entries ( iter quot -- directory-entry/f )
:: iterate-directory-entries ( iter quot: ( obj -- obj ) -- directory-entry/f )
iter next-directory-entry [
quot call( obj -- obj )
quot call
[ iter quot iterate-directory-entries ] unless*
] [
f
] if* ; inline recursive
: iterate-directory ( iter quot -- path/f )
[ name>> ] prepose iterate-directory-entries ;
[ name>> ] prepose iterate-directory-entries ; inline
: setup-traversal ( path bfs quot -- iterator quot' )
[ <directory-iterator> ] dip [ f ] compose ;
[ <directory-iterator> ] dip [ f ] compose ; inline
PRIVATE>
: each-file ( path bfs? quot -- )
setup-traversal iterate-directory drop ;
setup-traversal iterate-directory drop ; inline
: each-directory-entry ( path bfs? quot -- )
setup-traversal iterate-directory-entries drop ;
setup-traversal iterate-directory-entries drop ; inline
: recursive-directory-files ( path bfs? -- paths )
[ ] accumulator [ each-file ] dip ;
[ ] accumulator [ each-file ] dip ; inline
: recursive-directory-entries ( path bfs? -- paths )
[ ] accumulator [ each-directory-entry ] dip ;
: recursive-directory-entries ( path bfs? -- directory-entries )
[ ] accumulator [ each-directory-entry ] dip ; inline
: find-file ( path bfs? quot -- path/f )
[ <directory-iterator> ] dip
[ keep and ] curry iterate-directory ;
[ keep and ] curry iterate-directory ; inline
: find-all-files ( path quot -- paths/f )
[ 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 ;
: find-file-throws ( path bfs? quot -- path )
3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ;
3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; inline
: find-in-directories ( directories bfs? quot -- path'/f )
'[ _ [ _ _ find-file-throws ] attempt-all ]
[ drop f ] recover ;
[ drop f ] recover ; inline
: find-all-in-directories ( directories quot -- paths/f )
'[ _ find-all-files ] map concat ;
'[ _ find-all-files ] map concat ; inline
: link-size/0 ( path -- n )
[ link-info size-on-disk>> ] [ 2drop 0 ] recover ;

12
basis/io/mmap/functor/functor.factor
View File

@ -9,13 +9,14 @@ SLOT: length
: mapped-file>direct ( mapped-file type -- alien length )
[ [ address>> ] [ length>> ] bi ] dip
heap-size [ 1- + ] keep /i ;
heap-size [ 1 - + ] keep /i ;
FUNCTOR: define-mapped-array ( T -- )
<mapped-A> DEFINES <mapped-${T}-array>
<A> IS <direct-${T}-array>
with-mapped-A-file DEFINES with-mapped-${T}-file
<mapped-A> DEFINES <mapped-${T}-array>
<A> IS <direct-${T}-array>
with-mapped-A-file DEFINES with-mapped-${T}-file
with-mapped-A-file-reader DEFINES with-mapped-${T}-file-reader
WHERE
@ -25,4 +26,7 @@ WHERE
: with-mapped-A-file ( path quot -- )
'[ <mapped-A> @ ] with-mapped-file ; inline
: with-mapped-A-file-reader ( path quot -- )
'[ <mapped-A> @ ] with-mapped-file-reader ; inline
;FUNCTOR

8
basis/io/mmap/mmap-docs.factor
View File

@ -18,7 +18,13 @@ HELP: <mapped-file>
HELP: with-mapped-file
{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
{ $contract "Opens a file for read/write access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
HELP: with-mapped-file-reader
{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
{ $contract "Opens a file for read-only access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." }
{ $errors "Throws an error if a memory mapping could not be established." } ;

1
basis/io/mmap/mmap-tests.factor
View File

@ -7,6 +7,7 @@ IN: io.mmap.tests
[ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test
[ ] [ "mmap-test-file.txt" temp-file [ CHAR: 2 0 pick set-nth drop ] with-mapped-char-file ] unit-test
[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test
[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file-reader ] unit-test
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors

24
basis/io/mmap/mmap.factor
View File

@ -8,14 +8,27 @@ IN: io.mmap
TUPLE: mapped-file address handle length disposed ;
HOOK: (mapped-file) os ( path length -- address handle )
HOOK: (mapped-file-reader) os ( path length -- address handle )
HOOK: (mapped-file-r/w) os ( path length -- address handle )
ERROR: bad-mmap-size path size ;
: <mapped-file> ( path -- mmap )
<PRIVATE
: prepare-mapped-file ( path -- path' n )
[ normalize-path ] [ file-info size>> ] bi
dup 0 <= [ bad-mmap-size ] when
[ (mapped-file) ] keep
dup 0 <= [ bad-mmap-size ] when ;
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 ;
HOOK: close-mapped-file io-backend ( mmap -- )
@ -25,6 +38,9 @@ M: mapped-file dispose* ( mmap -- ) close-mapped-file ;
: with-mapped-file ( path quot -- )
[ <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 winnt? ] [ "io.mmap.windows" require ] }

18
basis/io/mmap/unix/unix.factor
View File

@ -4,21 +4,23 @@ USING: alien io io.files kernel math math.bitwise system unix
io.backend.unix io.ports io.mmap destructors locals accessors ;
IN: io.mmap.unix
: open-r/w ( path -- fd ) O_RDWR file-mode open-file ;
:: mmap-open ( path length prot flags -- alien fd )
:: mmap-open ( path length prot flags open-mode -- alien fd )
[
f length prot flags
path open-r/w [ <fd> |dispose drop ] keep
path open-mode file-mode open-file [ <fd> |dispose drop ] keep
[ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep
] with-destructors ;
M: unix (mapped-file)
M: unix (mapped-file-r/w)
{ PROT_READ PROT_WRITE } flags
{ MAP_FILE MAP_SHARED } flags
mmap-open ;
O_RDWR mmap-open ;
M: unix (mapped-file-reader)
{ PROT_READ } flags
{ MAP_FILE MAP_SHARED } flags
O_RDONLY mmap-open ;
M: unix close-mapped-file ( mmap -- )
[ [ address>> ] [ length>> ] bi munmap io-error ]
[ handle>> close-file ]
bi ;
[ handle>> close-file ] bi ;

11
basis/io/mmap/windows/windows.factor
View File

@ -28,7 +28,7 @@ M: win32-mapped-file dispose
C: <win32-mapped-file> win32-mapped-file
M: windows (mapped-file)
M: windows (mapped-file-r/w)
[
{ GENERIC_WRITE GENERIC_READ } flags
OPEN_ALWAYS
@ -37,6 +37,15 @@ M: windows (mapped-file)
-rot <win32-mapped-file>
] 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 -- )
[
[ handle>> &dispose drop ]

2
basis/math/blas/config/config.factor
View File

@ -18,7 +18,7 @@ blas-fortran-abi [
{ [ os netbsd? cpu x86.64? and ] [ g95-abi ] }
{ [ os windows? cpu x86.64? and ] [ gfortran-abi ] }
{ [ os freebsd? ] [ gfortran-abi ] }
{ [ os linux? cpu x86.32? and ] [ gfortran-abi ] }
{ [ os linux? ] [ gfortran-abi ] }
[ f2c-abi ]
} cond
] initialize

10
basis/math/quaternions/quaternions-docs.factor
View File

@ -1,6 +1,16 @@
USING: help.markup help.syntax math math.vectors vectors ;
IN: math.quaternions
HELP: q+
{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u+v" "a quaternion" } }
{ $description "Add quaternions." }
{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q+ ." "{ C{ 0 1 } 1 }" } } ;
HELP: q-
{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u-v" "a quaternion" } }
{ $description "Subtract quaternions." }
{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q- ." "{ C{ 0 1 } -1 }" } } ;
HELP: q*
{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u*v" "a quaternion" } }
{ $description "Multiply quaternions." }

4
basis/math/quaternions/quaternions-tests.factor
View File

@ -24,3 +24,7 @@ math.constants ;
[ t ] [ qk q>v v>q qk = ] unit-test
[ t ] [ 1 c>q q1 = ] unit-test
[ t ] [ C{ 0 1 } c>q qi = ] unit-test
[ t ] [ qi qi q+ qi 2 q*n = ] unit-test
[ t ] [ qi qi q- q0 = ] unit-test
[ t ] [ qi qj q+ qj qi q+ = ] unit-test
[ t ] [ qi qj q- qj qi q- -1 q*n = ] unit-test

6
basis/math/quaternions/quaternions.factor
View File

@ -20,6 +20,12 @@ IN: math.quaternions
PRIVATE>
: q+ ( u v -- u+v )
v+ ;
: q- ( u v -- u-v )
v- ;
: q* ( u v -- u*v )
[ q*a ] [ q*b ] 2bi 2array ;

2
basis/tuple-arrays/authors.txt
View File

@ -1 +1 @@
Daniel Ehrenberg
Slava Pestov

1
basis/tuple-arrays/summary.txt
View File

@ -1 +0,0 @@
Packed homogeneous tuple arrays

1
basis/tuple-arrays/tags.txt
View File

@ -1 +0,0 @@
collections

13
basis/tuple-arrays/tuple-arrays-docs.factor
View File

@ -1,13 +0,0 @@
USING: help.syntax help.markup splitting kernel sequences ;
IN: tuple-arrays
HELP: tuple-array
{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. To convert a sequence to a tuple array, use the word " { $link >tuple-array } "." } ;
HELP: <tuple-array>
{ $values { "class" "a tuple class" } { "length" "a non-negative integer" } { "tuple-array" tuple-array } }
{ $description "Creates an instance of the " { $link <tuple-array> } " class with the given length and containing the given tuple class." } ;
HELP: >tuple-array
{ $values { "seq" sequence } { "tuple-array" tuple-array } }
{ $description "Converts a sequence into a homogeneous unboxed tuple array of the type indicated by the first element." } ;

23
basis/tuple-arrays/tuple-arrays-tests.factor
View File

@ -5,17 +5,28 @@ IN: tuple-arrays.tests
SYMBOL: mat
TUPLE: foo bar ;
C: <foo> foo
[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
TUPLE-ARRAY: foo
[ 2 ] [ 2 <foo-array> dup mat set length ] unit-test
[ T{ foo } ] [ mat get first ] unit-test
[ T{ foo f 2 } ] [ T{ foo f 2 } 0 mat get [ set-nth ] keep first ] unit-test
[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test
[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >foo-array dup mat set foo-array? ] unit-test
[ T{ foo f 3 } t ]
[ mat get [ bar>> 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test
[ mat get [ bar>> 2 + <foo> ] map [ first ] keep foo-array? ] unit-test
[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
[ 2 ] [ 2 <foo-array> dup mat set length ] unit-test
[ T{ foo } ] [ mat get first ] unit-test
[ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test
TUPLE: baz { bing integer } bong ;
[ 0 ] [ 1 baz <tuple-array> first bing>> ] unit-test
[ f ] [ 1 baz <tuple-array> first bong>> ] unit-test
TUPLE-ARRAY: baz
[ 0 ] [ 1 <baz-array> first bing>> ] unit-test
[ f ] [ 1 <baz-array> first bong>> ] unit-test
TUPLE: broken x ;
: broken ( -- ) ;
TUPLE-ARRAY: broken
[ 100 ] [ 100 <broken-array> length ] unit-test

85
basis/tuple-arrays/tuple-arrays.factor
View File

@ -1,34 +1,73 @@
! Copyright (C) 2007 Daniel Ehrenberg.
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: splitting grouping classes.tuple classes math kernel
sequences arrays accessors ;
USING: accessors arrays combinators.smart fry functors kernel
kernel.private macros sequences combinators sequences.private
stack-checker parser math classes.tuple.private ;
FROM: inverse => undo ;
IN: tuple-arrays
TUPLE: tuple-array { seq read-only } { class read-only } ;
<PRIVATE
: <tuple-array> ( length class -- tuple-array )
[
new tuple>array 1 tail
[ <repetition> concat ] [ length ] bi <sliced-groups>
] [ ] bi tuple-array boa ;
MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ <tuple-boa> ] ;
M: tuple-array nth
[ seq>> nth ] [ class>> ] bi prefix >tuple ;
MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ;
M: tuple-array set-nth ( elt n seq -- )
[ tuple>array 1 tail ] 2dip seq>> set-nth ;
: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline
M: tuple-array new-sequence
class>> <tuple-array> ;
: smart-tuple>array ( tuple class -- array )
'[ [ _ boa ] undo ] output>array ; inline
: >tuple-array ( seq -- tuple-array )
dup empty? [
0 over first class <tuple-array> clone-like
] unless ;
: tuple-prototype ( class -- array )
[ new ] [ smart-tuple>array ] bi ; inline
M: tuple-array like
drop dup tuple-array? [ >tuple-array ] unless ;
: tuple-slice ( n seq -- slice )
[ n>> [ * dup ] keep + ] [ seq>> ] bi { array } declare slice boa ; inline
M: tuple-array length seq>> length ;
: read-tuple ( slice class -- tuple )
'[ _ boa-unsafe ] input<sequence-unsafe ; inline
INSTANCE: tuple-array sequence
MACRO: write-tuple ( class -- quot )
[ '[ [ _ boa ] undo ] ]
[ tuple-arity <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
bi '[ _ dip @ ] ;
PRIVATE>
FUNCTOR: define-tuple-array ( CLASS -- )
CLASS IS ${CLASS}
CLASS-array DEFINES-CLASS ${CLASS}-array
CLASS-array? IS ${CLASS-array}?
<CLASS-array> DEFINES <${CLASS}-array>
>CLASS-array DEFINES >${CLASS}-array
WHERE
TUPLE: CLASS-array
{ seq array read-only }
{ n array-capacity read-only }
{ length array-capacity read-only } ;
: <CLASS-array> ( length -- tuple-array )
[ \ CLASS [ tuple-prototype <repetition> concat ] [ tuple-arity ] bi ] keep
\ CLASS-array boa ; inline
M: CLASS-array length length>> ;
M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ;
M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ;
M: CLASS-array new-sequence drop <CLASS-array> ;
: >CLASS-array ( seq -- tuple-array ) 0 <CLASS-array> clone-like ;
M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ;
INSTANCE: CLASS-array sequence
;FUNCTOR
SYNTAX: TUPLE-ARRAY: scan-word define-tuple-array ;

7
core/classes/tuple/parser/parser.factor
View File

@ -89,11 +89,14 @@ ERROR: bad-literal-tuple ;
swap [ [ slot-named offset>> 2 - ] curry dip ] curry assoc-map
[ dup <enum> ] dip update boa>tuple ;
: parse-tuple-literal ( -- tuple )
scan-word scan {
: parse-tuple-literal-slots ( class -- tuple )
scan {
{ f [ unexpected-eof ] }
{ "f" [ \ } parse-until boa>tuple ] }
{ "{" [ parse-slot-values assoc>tuple ] }
{ "}" [ new ] }
[ bad-literal-tuple ]
} case ;
: parse-tuple-literal ( -- tuple )
scan-word parse-tuple-literal-slots ;

8
extra/benchmark/fasta/fasta.factor
View File

@ -46,8 +46,8 @@ CONSTANT: homo-sapiens
}
: make-cumulative ( freq -- chars floats )
dup keys >byte-array
swap values >double-array unclip [ + ] accumulate swap suffix ;
[ keys >byte-array ]
[ values >double-array ] bi unclip [ + ] accumulate swap suffix ;
:: select-random ( seed chars floats -- seed elt )
floats seed random -rot
@ -55,7 +55,7 @@ CONSTANT: homo-sapiens
chars nth-unsafe ; inline
: make-random-fasta ( seed len chars floats -- seed )
[ rot drop select-random ] 2curry B{ } map-as print ; inline
[ rot drop select-random ] 2curry "" map-as print ; inline
: write-description ( desc id -- )
">" write write bl print ; inline
@ -71,7 +71,7 @@ CONSTANT: homo-sapiens
:: make-repeat-fasta ( k len alu -- k' )
[let | kn [ alu length ] |
len [ k + kn mod alu nth-unsafe ] B{ } map-as print
len [ k + kn mod alu nth-unsafe ] "" map-as print
k len +
] ; inline

1
extra/benchmark/tuple-arrays/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

20
extra/benchmark/tuple-arrays/tuple-arrays.factor Normal file
View File

@ -0,0 +1,20 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions tuple-arrays accessors fry sequences
prettyprint ;
IN: benchmark.tuple-arrays
TUPLE: point { x float } { y float } { z float } ;
TUPLE-ARRAY: point
: tuple-array-benchmark ( -- )
100 [
drop 5000 <point-array> [
[ 1+ ] change-x
[ 1- ] change-y
[ 1+ 2 / ] change-z
] map [ z>> ] sigma
] sigma . ;
MAIN: tuple-array-benchmark

21
extra/id3/id3.factor
View File

@ -6,7 +6,7 @@ combinators math.ranges unicode.categories byte-arrays
io.encodings.string io.encodings.utf16 assocs math.parser
combinators.short-circuit fry namespaces combinators.smart
splitting io.encodings.ascii arrays io.files.info unicode.case
io.directories.search literals math.functions ;
io.directories.search literals math.functions continuations ;
IN: id3
<PRIVATE
@ -205,7 +205,9 @@ CONSTANT: id3v1+-offset $[ 128 227 + ]
drop
] if ;
: (mp3>id3) ( path -- id3v2/f )
PRIVATE>
: mp3>id3 ( path -- id3/f )
[
[ <id3> ] dip
{
@ -213,12 +215,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ]
[ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ]
[ dup id3v2? [ read-v2-tags ] [ drop ] if ]
} cleave
] with-mapped-uchar-file ;
PRIVATE>
: mp3>id3 ( path -- id3/f )
dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ;
] with-mapped-uchar-file-reader ;
: find-id3-frame ( id3 name -- obj/f )
swap frames>> at* [ data>> ] when ;
@ -239,8 +236,14 @@ PRIVATE>
: find-mp3s ( path -- seq )
[ >lower ".mp3" tail? ] find-all-files ;
ERROR: id3-parse-error path error ;
: (mp3-paths>id3s) ( seq -- seq' )
[ dup [ mp3>id3 ] [ \ id3-parse-error boa ] recover ] { } map>assoc ;
: mp3-paths>id3s ( seq -- seq' )
[ dup mp3>id3 ] { } map>assoc ;
(mp3-paths>id3s)
[ dup second id3-parse-error? [ f over set-second ] when ] map ;
: parse-mp3-directory ( path -- seq )
find-mp3s mp3-paths>id3s ;

25
extra/images/viewer/viewer.factor
View File

@ -2,33 +2,26 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors images images.loader io.pathnames kernel namespaces
opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
ui.gadgets.panes ui.render ;
ui.gadgets.panes ui.render ui.images ;
IN: images.viewer
TUPLE: image-gadget < gadget { image image } ;
TUPLE: image-gadget < gadget image-name ;
M: image-gadget pref-dim*
image>> dim>> ;
: draw-image ( image -- )
0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
[ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
glDrawPixels ;
image-name>> image-dim ;
M: image-gadget draw-gadget* ( gadget -- )
image>> draw-image ;
image-name>> draw-image ;
: <image-gadget> ( image -- gadget )
: <image-gadget> ( image-name -- gadget )
\ image-gadget new
swap >>image ;
swap >>image-name ;
: image-window ( path -- gadget )
[ load-image <image-gadget> dup ] [ open-window ] bi ;
[ <image-name> <image-gadget> dup ] [ open-window ] bi ;
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: image image. ( image -- ) <image-gadget> gadget. ;
M: pathname image. ( image -- ) <image-name> <image-gadget> gadget. ;

4
extra/mason/notify/notify.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors io io.sockets io.encodings.utf8 io.files
io.launcher kernel make mason.config mason.common mason.email
mason.twitter namespaces sequences ;
mason.twitter namespaces sequences prettyprint ;
IN: mason.notify
: status-notify ( input-file args -- )
@ -38,7 +38,7 @@ IN: mason.notify
f { "test" } status-notify ;
: notify-report ( status -- )
[ "Build finished with status: " write print flush ]
[ "Build finished with status: " write . flush ]
[
[ "report" utf8 file-contents ] dip email-report
"report" { "report" } status-notify

2
extra/mason/report/report.factor
View File

@ -28,7 +28,7 @@ IN: mason.report
common-report
_ call( -- xml )
[XML <html><body><-><-></body></html> XML]
pprint-xml
write-xml
] with-file-writer ; inline
:: failed-report ( error file what -- status )

3
extra/morse/morse-tests.factor
View File

@ -3,7 +3,7 @@
USING: arrays morse strings tools.test ;
IN: morse.tests
[ CHAR: ? ] [ CHAR: \\ ch>morse ] unit-test
[ "?" ] [ CHAR: \\ ch>morse ] unit-test
[ "..." ] [ CHAR: s ch>morse ] unit-test
[ CHAR: s ] [ "..." morse>ch ] unit-test
[ CHAR: \s ] [ "..--..--.." morse>ch ] unit-test
@ -41,3 +41,4 @@ IN: morse.tests
MORSE] ] unit-test
! [ ] [ "sos" 0.075 play-as-morse* ] unit-test
! [ ] [ "Factor rocks!" play-as-morse ] unit-test
! [ ] [ "\n" play-as-morse ] unit-test

11
extra/morse/morse.factor
View File

@ -3,13 +3,15 @@
USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ;
IN: morse
ERROR: no-morse-code ch ;
<PRIVATE
CONSTANT: dot-char CHAR: .
CONSTANT: dash-char CHAR: -
CONSTANT: char-gap-char CHAR: \s
CONSTANT: word-gap-char CHAR: /
CONSTANT: unknown-char CHAR: ?
CONSTANT: unknown-char "?"
PRIVATE>
@ -74,10 +76,10 @@ CONSTANT: morse-code-table $[
]
: ch>morse ( ch -- morse )
ch>lower morse-code-table at [ unknown-char ] unless* ;
ch>lower morse-code-table at unknown-char or ;
: morse>ch ( str -- ch )
morse-code-table value-at [ char-gap-char ] unless* ;
morse-code-table value-at char-gap-char or ;
<PRIVATE
@ -148,12 +150,13 @@ CONSTANT: beep-freq 880
source get source-play
] with-scope ; inline
: play-char ( ch -- )
: play-char ( string -- )
[ intra-char-gap ] [
{
{ dot-char [ dot ] }
{ dash-char [ dash ] }
{ word-gap-char [ intra-char-gap ] }
[ drop intra-char-gap ]
} case
] interleave ;

1
extra/pair-methods/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

43
extra/pair-methods/pair-methods-tests.factor Normal file
View File

@ -0,0 +1,43 @@
! (c)2009 Joe Groff bsd license
USING: accessors pair-methods classes kernel sequences tools.test ;
IN: pair-methods.tests
TUPLE: thang ;
TUPLE: foom < thang ;
TUPLE: barm < foom ;
TUPLE: zim < thang ;
TUPLE: zang < zim ;
: class-names ( a b prefix -- string )
[ [ class name>> ] bi@ "-" glue ] dip prepend ;
PAIR-GENERIC: blibble ( a b -- c )
PAIR-M: thang thang blibble
"vanilla " class-names ;
PAIR-M: foom thang blibble
"chocolate " class-names ;
PAIR-M: barm thang blibble
"strawberry " class-names ;
PAIR-M: barm zim blibble
"coconut " class-names ;
[ "vanilla zang-zim" ] [ zim new zang new blibble ] unit-test
! args automatically swap to match most specific method
[ "chocolate foom-zim" ] [ foom new zim new blibble ] unit-test
[ "chocolate foom-zim" ] [ zim new foom new blibble ] unit-test
[ "strawberry barm-barm" ] [ barm new barm new blibble ] unit-test
[ "strawberry barm-foom" ] [ barm new foom new blibble ] unit-test
[ "strawberry barm-foom" ] [ foom new barm new blibble ] unit-test
[ "coconut barm-zang" ] [ zang new barm new blibble ] unit-test
[ "coconut barm-zim" ] [ barm new zim new blibble ] unit-test
[ 1 2 blibble ] [ no-pair-method? ] must-fail-with

57
extra/pair-methods/pair-methods.factor Normal file
View File

@ -0,0 +1,57 @@
! (c)2009 Joe Groff bsd license
USING: arrays assocs classes classes.tuple.private combinators
effects.parser generic.parser kernel math math.order parser
quotations sequences sorting words ;
IN: pair-methods
ERROR: no-pair-method a b generic ;
: ?swap ( a b ? -- a/b b/a )
[ swap ] when ;
: method-sort-key ( pair -- key )
first2 [ tuple-layout third ] bi@ + ;
: pair-match-condition ( pair -- quot )
first2 [ [ instance? ] swap prefix ] bi@ [ ] 2sequence
[ 2dup ] [ bi* and ] surround ;
: pair-method-cond ( pair quot -- array )
[ pair-match-condition ] [ ] bi* 2array ;
: sorted-pair-methods ( word -- alist )
"pair-generic-methods" word-prop >alist
[ [ first method-sort-key ] bi@ >=< ] sort ;
: pair-generic-definition ( word -- def )
[ sorted-pair-methods [ first2 pair-method-cond ] map ]
[ [ no-pair-method ] curry suffix ] bi 1quotation
[ 2dup [ class ] bi@ <=> +gt+ eq? ?swap ] [ cond ] surround ;
: make-pair-generic ( word -- )
dup pair-generic-definition define ;
: define-pair-generic ( word effect -- )
[ swap set-stack-effect ]
[ drop H{ } clone "pair-generic-methods" set-word-prop ]
[ drop make-pair-generic ] 2tri ;
: (PAIR-GENERIC:) ( -- )
CREATE-GENERIC complete-effect define-pair-generic ;
SYNTAX: PAIR-GENERIC: (PAIR-GENERIC:) ;
: define-pair-method ( a b pair-generic definition -- )
[ 2array ] 2dip swap
[ "pair-generic-methods" word-prop [ swap ] dip set-at ]
[ make-pair-generic ] bi ;
: ?prefix-swap ( quot ? -- quot' )
[ \ swap prefix ] when ;
: (PAIR-M:) ( -- )
scan-word scan-word 2dup <=> +gt+ eq? [
?swap scan-word parse-definition
] keep ?prefix-swap define-pair-method ;
SYNTAX: PAIR-M: (PAIR-M:) ;

1
extra/pair-methods/summary.txt Normal file
View File

@ -0,0 +1 @@
Order-insensitive double dispatch generics

1
extra/pair-rocket/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

15
extra/pair-rocket/pair-rocket-docs.factor Normal file
View File

@ -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 } } "> }
}
;

10
extra/pair-rocket/pair-rocket-tests.factor Normal file
View File

@ -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

6
extra/pair-rocket/pair-rocket.factor Normal file
View File

@ -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 ;

1
extra/pair-rocket/summary.txt Normal file
View File

@ -0,0 +1 @@
H{ "foo" => 1 "bar" => 2 } style literal syntax

1
extra/qw/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

12
extra/qw/qw-docs.factor Normal file
View File

@ -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" } "> }
} ;

5
extra/qw/qw-tests.factor Normal file
View File

@ -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

5
extra/qw/qw.factor Normal file
View File

@ -0,0 +1,5 @@
! (c)2009 Joe Groff bsd license
USING: lexer parser ;
IN: qw
SYNTAX: qw{ "}" parse-tokens parsed ;

1
extra/qw/summary.txt Normal file
View File

@ -0,0 +1 @@
Perlish syntax for literal arrays of whitespace-delimited strings (qw{ foo bar })

1
extra/roles/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

48
extra/roles/roles-docs.factor Normal file
View File

@ -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." } ;

67
extra/roles/roles-tests.factor Normal file
View File

@ -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

69
extra/roles/roles.factor Normal file
View File

@ -0,0 +1,69 @@
! (c)2009 Joe Groff bsd license
USING: accessors arrays classes classes.mixin classes.parser
classes.tuple classes.tuple.parser combinators
combinators.short-circuit kernel lexer make parser sequences
sets strings words ;
IN: roles
ERROR: role-slot-overlap class slots ;
ERROR: multiple-inheritance-attempted classes ;
PREDICATE: role < mixin-class
"role-slots" word-prop >boolean ;
: parse-role-definition ( -- class superroles slots )
CREATE-CLASS scan {
{ ";" [ { } { } ] }
{ "<" [ scan-word 1array [ parse-tuple-slots ] { } make ] }
{ "<{" [ \ } parse-until >array [ parse-tuple-slots ] { } make ] }
[ { } swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
} case ;
: slot-name ( name/array -- name )
dup string? [ ] [ first ] if ;
: slot-names ( array -- names )
[ slot-name ] map ;
: role-slots ( role -- slots )
[ "superroles" word-prop [ role-slots ] map concat ]
[ "role-slots" word-prop ] bi append ;
: role-or-tuple-slot-names ( role-or-tuple -- names )
dup role?
[ role-slots slot-names ]
[ all-slots [ name>> ] map ] if ;
: check-for-slot-overlap ( class roles-and-superclass slots -- )
[ [ role-or-tuple-slot-names ] map concat ] [ slot-names ] bi* append
duplicates dup empty? [ 2drop ] [ role-slot-overlap ] if ;
: roles>slots ( roles-and-superclass slots -- superclass slots' )
[
[ role? ] partition
dup length {
{ 0 [ drop tuple ] }
{ 1 [ first ] }
[ drop multiple-inheritance-attempted ]
} case
swap [ role-slots ] map concat
] dip append ;
: add-to-roles ( class roles -- )
[ add-mixin-instance ] with each ;
: (define-role) ( class superroles slots -- )
[ "superroles" set-word-prop ] [ "role-slots" set-word-prop ] bi-curry*
[ define-mixin-class ] tri ;
: define-role ( class superroles slots -- )
[ check-for-slot-overlap ] [ (define-role) ] [ drop add-to-roles ] 3tri ;
: define-tuple-class-with-roles ( class roles-and-superclass slots -- )
[ check-for-slot-overlap ]
[ roles>slots define-tuple-class ]
[ drop [ role? ] filter add-to-roles ] 3tri ;
SYNTAX: ROLE: parse-role-definition define-role ;
SYNTAX: TUPLE: parse-role-definition define-tuple-class-with-roles ;

1
extra/roles/summary.txt Normal file
View File

@ -0,0 +1 @@
Mixins for tuples

1
extra/sequences/product/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

61
extra/sequences/product/product-docs.factor Normal file
View File

@ -0,0 +1,61 @@
! (c)2009 Joe Groff bsd license
USING: help.markup help.syntax multiline quotations sequences sequences.product ;
IN: sequences
HELP: product-sequence
{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link <product-sequence> } " word." }
{ $examples
{ $example <" USING: arrays prettyprint sequences.product ;
{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
"> <" {
{ 1 "a" }
{ 2 "a" }
{ 3 "a" }
{ 1 "b" }
{ 2 "b" }
{ 3 "b" }
{ 1 "c" }
{ 2 "c" }
{ 3 "c" }
}"> } } ;
HELP: <product-sequence>
{ $values { "sequences" sequence } { "product-sequence" product-sequence } }
{ $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." }
{ $examples
{ $example <" USING: arrays prettyprint sequences.product ;
{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
"> <" {
{ 1 "a" }
{ 2 "a" }
{ 3 "a" }
{ 1 "b" }
{ 2 "b" }
{ 3 "b" }
{ 1 "c" }
{ 2 "c" }
{ 3 "c" }
}"> } } ;
{ product-sequence <product-sequence> } related-words
HELP: product-map
{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- value )" } } { "sequence" sequence } }
{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence." }
{ $notes { $snippet "[ ... ] product-map" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] map" } "." } ;
HELP: product-each
{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- )" } } }
{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } "." }
{ $notes { $snippet "[ ... ] product-each" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] each" } "." } ;
{ product-map product-each } related-words
ARTICLE: "sequences.product" "Product sequences"
"The " { $vocab-link "sequences.product" } " vocabulary provides a virtual sequence and combinators for manipulating the cartesian product of a set of sequences."
{ $subsection product-sequence }
{ $subsection <product-sequence> }
{ $subsection product-map }
{ $subsection product-each } ;
ABOUT: "sequences.product"

27
extra/sequences/product/product-tests.factor
View File

@ -1,19 +1,26 @@
USING: arrays kernel sequences sequences.cartesian-product tools.test ;
! (c)2009 Joe Groff bsd license
USING: arrays kernel make sequences sequences.product tools.test ;
IN: sequences.product.tests
[
{ { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } }
] [ { { 0 1 2 } { "a" "b" } } [ ] cartesian-product-map ] unit-test
[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
[ { { 0 1 2 } { "a" "b" } } <product-sequence> >array ] unit-test
: x ( n s -- sss ) <repetition> concat ;
[ { "a" "aa" "aaa" "b" "bb" "bbb" } ]
[ { { 1 2 3 } { "a" "b" } } [ first2 x ] product-map ] unit-test
[
{
{ 0 "a" t } { 1 "a" t } { 2 "a" t } { 0 "b" t } { 1 "b" t } { 2 "b" t }
{ 0 "a" f } { 1 "a" f } { 2 "a" f } { 0 "b" f } { 1 "b" f } { 2 "b" f }
}
] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] cartesian-product-map ] unit-test
[
{ "012012" "aaabbb" }
] [ { { "0" "1" "2" } { "a" "b" } } [ [ first2 ] bi* [ append ] bi@ 2array ] cartesian-product-each ] unit-test
] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] product-map ] unit-test
[ "a1b1c1a2b2c2" ] [
[
{ { "a" "b" "c" } { "1" "2" } }
[ [ % ] each ] product-each
] "" make
] unit-test

63
extra/sequences/product/product.factor Normal file
View File

@ -0,0 +1,63 @@
! (c)2009 Joe Groff bsd license
USING: accessors arrays kernel locals math sequences ;
IN: sequences.product
TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
: <product-sequence> ( sequences -- product-sequence )
>array dup [ length ] map product-sequence boa ;
INSTANCE: product-sequence sequence
M: product-sequence length lengths>> product ;
<PRIVATE
: ns ( n lengths -- ns )
[ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ;
: nths ( ns seqs -- nths )
[ nth ] { } 2map-as ;
: product@ ( n product-sequence -- ns seqs )
[ lengths>> ns ] [ nip sequences>> ] 2bi ;
:: (carry-n) ( ns lengths i -- )
ns length i 1+ = [
i ns nth i lengths nth = [
0 i ns set-nth
i 1+ ns [ 1+ ] change-nth
ns lengths i 1+ (carry-n)
] when
] unless ;
: carry-ns ( ns lengths -- )
0 (carry-n) ;
: product-iter ( ns lengths -- )
[ 0 over [ 1+ ] change-nth ] dip carry-ns ;
: start-product-iter ( sequence-product -- ns lengths )
[ [ drop 0 ] map ] [ [ length ] map ] bi ;
: end-product-iter? ( ns lengths -- ? )
[ 1 tail* first ] bi@ = ;
PRIVATE>
M: product-sequence nth
product@ nths ;
:: product-each ( sequences quot -- )
sequences start-product-iter :> lengths :> ns
[ ns lengths end-product-iter? ]
[ ns sequences nths quot call ns lengths product-iter ] until ; inline
:: product-map ( sequences quot -- sequence )
0 :> i!
sequences [ length ] [ * ] map-reduce sequences
[| result |
sequences [ quot call i result set-nth i 1+ i! ] product-each
result
] new-like ; inline

1
extra/sequences/product/summary.txt Normal file
View File

@ -0,0 +1 @@
Cartesian products of sequences

166
vm/code_gc.c
View File

@ -1,5 +1,10 @@
#include "master.h"
static void clear_free_list(F_HEAP *heap)
{
memset(&heap->free,0,sizeof(F_HEAP_FREE_LIST));
}
/* This malloc-style heap code is reasonably generic. Maybe in the future, it
will be used for the data heap too, if we ever get incremental
mark/sweep/compact GC. */
@ -8,17 +13,23 @@ void new_heap(F_HEAP *heap, CELL size)
heap->segment = alloc_segment(align_page(size));
if(!heap->segment)
fatal_error("Out of memory in new_heap",size);
heap->free_list = NULL;
clear_free_list(heap);
}
/* If there is no previous block, next_free becomes the head of the free list,
else its linked in */
INLINE void update_free_list(F_HEAP *heap, F_FREE_BLOCK *prev, F_FREE_BLOCK *next_free)
void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block)
{
if(prev)
prev->next_free = next_free;
if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
{
int index = block->block.size / BLOCK_SIZE_INCREMENT;
block->next_free = heap->free.small_blocks[index];
heap->free.small_blocks[index] = block;
}
else
heap->free_list = next_free;
{
block->next_free = heap->free.large_blocks;
heap->free.large_blocks = block;
}
}
/* Called after reading the code heap from the image file, and after code GC.
@ -28,7 +39,11 @@ compiling.limit. */
void build_free_list(F_HEAP *heap, CELL size)
{
F_BLOCK *prev = NULL;
F_FREE_BLOCK *prev_free = NULL;
clear_free_list(heap);
size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
F_BLOCK *scan = first_block(heap);
F_FREE_BLOCK *end = (F_FREE_BLOCK *)(heap->segment->start + size);
@ -38,8 +53,7 @@ void build_free_list(F_HEAP *heap, CELL size)
switch(scan->status)
{
case B_FREE:
update_free_list(heap,prev_free,(F_FREE_BLOCK *)scan);
prev_free = (F_FREE_BLOCK *)scan;
add_to_free_list(heap,(F_FREE_BLOCK *)scan);
break;
case B_ALLOCATED:
break;
@ -58,10 +72,9 @@ void build_free_list(F_HEAP *heap, CELL size)
{
end->block.status = B_FREE;
end->block.size = heap->segment->end - (CELL)end;
end->next_free = NULL;
/* add final free block */
update_free_list(heap,prev_free,end);
add_to_free_list(heap,end);
}
/* This branch is taken if the newly loaded image fits exactly, or
after code GC */
@ -70,63 +83,88 @@ void build_free_list(F_HEAP *heap, CELL size)
/* even if there's no room at the end of the heap for a new
free block, we might have to jigger it up by a few bytes in
case prev + prev->size */
if(prev)
prev->size = heap->segment->end - (CELL)prev;
/* this is the last free block */
update_free_list(heap,prev_free,NULL);
if(prev) prev->size = heap->segment->end - (CELL)prev;
}
}
static void assert_free_block(F_FREE_BLOCK *block)
{
if(block->block.status != B_FREE)
critical_error("Invalid block in free list",(CELL)block);
}
F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size)
{
CELL attempt = size;
while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
{
int index = attempt / BLOCK_SIZE_INCREMENT;
F_FREE_BLOCK *block = heap->free.small_blocks[index];
if(block)
{
assert_free_block(block);
heap->free.small_blocks[index] = block->next_free;
return block;
}
attempt *= 2;
}
F_FREE_BLOCK *prev = NULL;
F_FREE_BLOCK *block = heap->free.large_blocks;
while(block)
{
assert_free_block(block);
if(block->block.size >= size)
{
if(prev)
prev->next_free = block->next_free;
else
heap->free.large_blocks = block->next_free;
return block;
}
prev = block;
block = block->next_free;
}
return NULL;
}
F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL size)
{
if(block->block.size != size )
{
/* split the block in two */
F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)block + size);
split->block.status = B_FREE;
split->block.size = block->block.size - size;
split->next_free = block->next_free;
block->block.size = size;
add_to_free_list(heap,split);
}
return block;
}
/* Allocate a block of memory from the mark and sweep GC heap */
F_BLOCK *heap_allot(F_HEAP *heap, CELL size)
{
F_FREE_BLOCK *prev = NULL;
F_FREE_BLOCK *scan = heap->free_list;
size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
size = (size + 31) & ~31;
while(scan)
F_FREE_BLOCK *block = find_free_block(heap,size);
if(block)
{
if(scan->block.status != B_FREE)
critical_error("Invalid block in free list",(CELL)scan);
block = split_free_block(heap,block,size);
if(scan->block.size < size)
{
prev = scan;
scan = scan->next_free;
continue;
}
/* we found a candidate block */
F_FREE_BLOCK *next_free;
if(scan->block.size - size <= sizeof(F_BLOCK) * 2)
{
/* too small to be split */
next_free = scan->next_free;
}
else
{
/* split the block in two */
F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)scan + size);
split->block.status = B_FREE;
split->block.size = scan->block.size - size;
split->next_free = scan->next_free;
scan->block.size = size;
next_free = split;
}
/* update the free list */
update_free_list(heap,prev,next_free);
/* this is our new block */
scan->block.status = B_ALLOCATED;
return &scan->block;
block->block.status = B_ALLOCATED;
return &block->block;
}
return NULL;
else
return NULL;
}
void mark_block(F_BLOCK *block)
@ -162,8 +200,10 @@ void unmark_marked(F_HEAP *heap)
/* After code GC, all referenced code blocks have status set to B_MARKED, so any
which are allocated and not marked can be reclaimed. */
void free_unmarked(F_HEAP *heap)
void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter)
{
clear_free_list(heap);
F_BLOCK *prev = NULL;
F_BLOCK *scan = first_block(heap);
@ -183,10 +223,15 @@ void free_unmarked(F_HEAP *heap)
case B_FREE:
if(prev && prev->status == B_FREE)
prev->size += scan->size;
else
prev = scan;
break;
case B_MARKED:
if(prev && prev->status == B_FREE)
add_to_free_list(heap,(F_FREE_BLOCK *)prev);
scan->status = B_ALLOCATED;
prev = scan;
iter(scan);
break;
default:
critical_error("Invalid scan->status",(CELL)scan);
@ -195,7 +240,8 @@ void free_unmarked(F_HEAP *heap)
scan = next_block(heap,scan);
}
build_free_list(heap,heap->segment->size);
if(prev && prev->status == B_FREE)
add_to_free_list(heap,(F_FREE_BLOCK *)prev);
}
/* Compute total sum of sizes of free blocks, and size of largest free block */

14
vm/code_gc.h Normal file → Executable file
View File

@ -1,14 +1,24 @@
#define FREE_LIST_COUNT 16
#define BLOCK_SIZE_INCREMENT 32
typedef struct {
F_FREE_BLOCK *small_blocks[FREE_LIST_COUNT];
F_FREE_BLOCK *large_blocks;
} F_HEAP_FREE_LIST;
typedef struct {
F_SEGMENT *segment;
F_FREE_BLOCK *free_list;
F_HEAP_FREE_LIST free;
} F_HEAP;
typedef void (*HEAP_ITERATOR)(F_BLOCK *compiled);
void new_heap(F_HEAP *heap, CELL size);
void build_free_list(F_HEAP *heap, CELL size);
F_BLOCK *heap_allot(F_HEAP *heap, CELL size);
void mark_block(F_BLOCK *block);
void unmark_marked(F_HEAP *heap);
void free_unmarked(F_HEAP *heap);
void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter);
void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free);
CELL heap_size(F_HEAP *heap);
CELL compute_heap_forwarding(F_HEAP *heap);

13
vm/data_gc.c
View File

@ -330,7 +330,7 @@ CELL copy_next_from_tenured(CELL scan)
void copy_reachable_objects(CELL scan, CELL *end)
{
if(HAVE_NURSERY_P && collecting_gen == NURSERY)
if(collecting_gen == NURSERY)
{
while(scan < *end)
scan = copy_next_from_nursery(scan);
@ -405,7 +405,7 @@ void end_gc(CELL gc_elapsed)
if(collecting_gen != NURSERY)
reset_generations(NURSERY,collecting_gen - 1);
}
else if(HAVE_NURSERY_P && collecting_gen == NURSERY)
else if(collecting_gen == NURSERY)
{
nursery.here = nursery.start;
}
@ -416,13 +416,6 @@ void end_gc(CELL gc_elapsed)
reset_generations(NURSERY,collecting_gen);
}
if(collecting_gen == TENURED)
{
/* now that all reachable code blocks have been marked,
deallocate the rest */
free_unmarked(&code_heap);
}
collecting_aging_again = false;
}
@ -491,7 +484,7 @@ void garbage_collection(CELL gen,
code_heap_scans++;
if(collecting_gen == TENURED)
update_code_heap_roots();
free_unmarked(&code_heap,(HEAP_ITERATOR)update_literal_references);
else
copy_code_heap_roots();

19
vm/data_gc.h
View File

@ -58,7 +58,7 @@ INLINE bool should_copy(CELL untagged)
return true;
else if(HAVE_AGING_P && collecting_gen == AGING)
return !in_zone(&data_heap->generations[TENURED],untagged);
else if(HAVE_NURSERY_P && collecting_gen == NURSERY)
else if(collecting_gen == NURSERY)
return in_zone(&nursery,untagged);
else
{
@ -78,6 +78,11 @@ allocation (which does not call GC because of possible roots in volatile
registers) does not run out of memory */
#define ALLOT_BUFFER_ZONE 1024
/* If this is defined, we GC every 100 allocations. This catches missing local roots */
#ifdef GC_DEBUG
int gc_count;
#endif
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
@ -85,10 +90,18 @@ registers) does not run out of memory */
int count;
INLINE void *allot_object(CELL type, CELL a)
{
if(!gc_off) { if(count++ % 100 == 0) { printf("!\n"); gc(); } }
#ifdef GC_DEBUG
if(!gc_off)
{
if(gc_count++ % 1000 == 0)
gc();
}
#endif
CELL *object;
if(HAVE_NURSERY_P && nursery.size - ALLOT_BUFFER_ZONE > a)
if(nursery.size - ALLOT_BUFFER_ZONE > a)
{
/* If there is insufficient room, collect the nursery */
if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end)

1
vm/data_heap.h
View File

@ -37,7 +37,6 @@ F_DATA_HEAP *data_heap;
/* the 0th generation is where new objects are allocated. */
#define NURSERY 0
#define HAVE_NURSERY_P (data_heap->gen_count>1)
/* where objects hang around */
#define AGING (data_heap->gen_count-2)
#define HAVE_AGING_P (data_heap->gen_count>2)