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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2009-04-26 21:39:39 -05:00
parent 93be5a84bd 67fd98f42d
commit 91d48f567d
15 changed files with 204 additions and 51 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

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 ;

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

27
basis/functors/functors.factor
View File

@ -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 ;
@ -92,6 +102,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 ;
@ -117,6 +129,7 @@ DEFER: ;FUNCTOR delimiter
{ "INSTANCE:" POSTPONE: `INSTANCE: }
{ "SYNTAX:" POSTPONE: `SYNTAX: }
{ "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 -- )

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

@ -23,3 +23,10 @@ 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

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

@ -1,26 +1,36 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators.smart fry functors grouping
kernel macros sequences sequences.private stack-checker
parser ;
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
<PRIVATE
MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ <tuple-boa> ] ;
MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ;
: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline
: smart-tuple>array ( tuple class -- array )
'[ [ _ boa ] undo ] output>array ; inline
: smart-array>tuple ( array class -- tuple )
'[ _ boa ] input<sequence ; inline
: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline
: tuple-prototype ( class -- array )
[ new ] [ smart-tuple>array ] bi ; inline
: tuple-slice ( n seq -- slice )
[ n>> [ * dup ] keep + ] [ seq>> ] bi { array } declare slice boa ; inline
: read-tuple ( slice class -- tuple )
'[ _ boa-unsafe ] input<sequence-unsafe ; inline
MACRO: write-tuple ( class -- quot )
[ '[ [ _ boa ] undo ] ]
[ tuple-arity <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
bi '[ _ dip @ ] ;
PRIVATE>
FUNCTOR: define-tuple-array ( CLASS -- )
@ -35,31 +45,26 @@ CLASS-array? IS ${CLASS-array}?
WHERE
TUPLE: CLASS-array { seq sliced-groups read-only } ;
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
CLASS tuple-arity <sliced-groups>
CLASS-array boa ;
[ \ CLASS [ tuple-prototype <repetition> concat ] [ tuple-arity ] bi ] keep
\ CLASS-array boa ; inline
M: CLASS-array nth-unsafe
seq>> nth-unsafe CLASS smart-array>tuple ;
M: CLASS-array length length>> ;
M: CLASS-array set-nth-unsafe
[ CLASS smart-tuple>array ] 2dip seq>> set-nth-unsafe ;
M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ;
M: CLASS-array new-sequence
drop <CLASS-array> ;
M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ;
: >CLASS-array ( seq -- tuple-array )
dup empty? [
0 <CLASS-array> clone-like
] unless ;
M: CLASS-array new-sequence drop <CLASS-array> ;
M: CLASS-array like
drop dup CLASS-array? [ >CLASS-array ] unless ;
: >CLASS-array ( seq -- tuple-array ) 0 <CLASS-array> clone-like ;
M: CLASS-array length seq>> length ;
M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ;
INSTANCE: CLASS-array sequence

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

3
vm/code_block.c
View File

@ -224,7 +224,8 @@ void mark_object_code_block(CELL scan)
{
case WORD_TYPE:
word = (F_WORD *)scan;
mark_code_block(word->code);
if(word->code)
mark_code_block(word->code);
if(word->profiling)
mark_code_block(word->profiling);
break;

4
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;
}

20
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,15 +78,31 @@ 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
static int count;
#endif
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
INLINE void *allot_object(CELL type, CELL a)
{
#ifdef GC_DEBUG
if(!gc_off)
{
if(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)