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

Eliminate with-class<cache combinator in favor of a class<map that is always kept up to date

slava 2006-08-18 03:50:59 +00:00
parent 2e01391105
commit 816f60a6e7
10 changed files with 90 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
library/bootstrap/boot-stage2.factor
View File

@ -5,8 +5,8 @@ kernel-internals listener math memory namespaces optimizer
parser sequences sequences-internals words ;
[
! Wrap everything in a catch which starts a listener so you can
! see what went wrong, instead of dealing with a fep
! Wrap everything in a catch which starts a listener so you
! can see what went wrong, instead of dealing with a fep
[
"Cross-referencing..." print flush
H{ } clone changed-words set-global
@ -20,11 +20,28 @@ parser sequences sequences-internals words ;
] when
"compile" get [
\ number= compile
\ + compile
\ nth compile
\ set-nth compile
\ = compile
! Load UI backend
"cocoa" get [
"/library/compiler/alien/objc/load.factor" run-resource
"/library/ui/cocoa/load.factor" run-resource
] when
"x11" get [
"/library/ui/x11/load.factor" run-resource
] when
windows? [
"/library/windows/load.factor" run-resource
"/library/ui/windows/load.factor" run-resource
] when
! Load native I/O code
"native-io" get [
unix? [
"/library/io/unix/load.factor" run-resource
@ -36,35 +53,11 @@ parser sequences sequences-internals words ;
parse-command-line
"Compiling base..." print flush
[
\ number= compile
\ + compile
\ nth compile
\ set-nth compile
\ = compile
{ "kernel" "sequences" "assembler" } compile-vocabs
"Compiling system..." print flush
compile-all
] with-class<cache
"cocoa" get [
"/library/compiler/alien/objc/load.factor" run-resource
"/library/ui/cocoa/load.factor" run-resource
] when
"x11" get [
"/library/ui/x11/load.factor" run-resource
] when
"Recompiling just in case..." print flush
recompile
compile-all
"Initializing native I/O..." print flush
"native-io" get [ init-io ] when
! We only do this if we are compiled, otherwise it
! takes too long.
"Building online help search index..." print flush

1
library/bootstrap/image.factor
View File

@ -292,6 +292,7 @@ M: hashtable '
{
vocabularies typemap builtins c-types crossref
articles parent-graph term-index changed-words
class<map
} [ dup get swap bootstrap-word set ] each
] make-hash '
global-offset fixup ;

1
library/bootstrap/primitives.factor
View File

@ -17,6 +17,7 @@ H{ } clone c-types set
"syntax" vocab
H{ } clone vocabularies set
H{ } clone class<map set
vocabularies get [ "syntax" set ] bind

8
library/compiler/compiler.factor
View File

@ -24,8 +24,7 @@ words ;
dup [ f "no-effect" set-word-prop ] each
[ try-compile ] each ;
: compile-all ( -- )
[ vocabs compile-vocabs ] with-class<cache ;
: compile-all ( -- ) vocabs compile-vocabs ;
: compile-quot ( quot -- word )
define-temp "compile" get [ dup compile ] when ;
@ -33,11 +32,8 @@ words ;
: compile-1 ( quot -- ) compile-quot execute ;
: recompile ( -- )
#! If we are recompiling a lot of words, we can save time
#! with the class<cache.
changed-words get [
dup hash-keys [ [ try-compile ] each clear-hash ]
over length 20 > [ with-class<cache ] [ call ] if
dup hash-keys [ try-compile ] each clear-hash
] when* ;
[ recompile ] parse-hook set

49
library/generic/classes.factor
View File

@ -7,11 +7,12 @@ vectors math parser ;
PREDICATE: word class ( obj -- ? ) "class" word-prop ;
: classes ( -- seq ) [ class? ] word-subset ;
SYMBOL: typemap
SYMBOL: class<map
SYMBOL: builtins
: classes ( -- seq ) class<map get hash-keys ;
: type>class ( n -- class ) builtins get nth ;
: predicate-word ( word -- predicate )
@ -31,7 +32,7 @@ SYMBOL: builtins
: superclass ( class -- super ) "superclass" word-prop ;
: members "members" word-prop ;
: members ( class -- seq ) "members" word-prop ;
: (flatten-class) ( class -- )
dup members [ [ (flatten-class) ] each ] [ dup set ] ?if ;
@ -69,22 +70,8 @@ DEFER: (class<)
{ [ t ] [ union-class< ] }
} cond ;
SYMBOL: class<cache
: class< ( class1 class2 -- ? )
class<cache get [ hash hash-member? ] [ (class<) ] if* ;
: smaller-classes ( class seq -- )
[ swap (class<) ] subset-with ;
: make-class<cache ( -- hash )
classes dup [
2dup swap smaller-classes [ dup ] map>hash
] map>hash nip ;
: with-class<cache ( quot -- )
[ make-class<cache class<cache set call ] with-scope ;
inline
class<map get hash hash-member? ;
: class-compare ( class1 class2 -- n )
2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] if ;
@ -125,9 +112,24 @@ SYMBOL: class<cache
tuck [ class< ] all-with? [ peek ] [ drop f ] if
] if ;
: smaller-classes ( class -- seq )
classes [ swap (class<) ] subset-with ;
: smaller-classes+ ( class -- )
[ smaller-classes [ dup ] map>hash ] keep
class<map get set-hash ;
: bigger-classes ( class -- seq )
classes [ (class<) ] subset-with ;
: bigger-classes+ ( class -- )
dup bigger-classes
[ dupd class<map get hash set-hash ] each-with ;
: define-class ( class -- )
dup t "class" set-word-prop
dup flatten-class typemap get set-hash ;
dup dup flatten-class typemap get set-hash
dup smaller-classes+ bigger-classes+ ;
! Predicate classes for generalized predicate dispatch.
: define-predicate-class ( class predicate definition -- )
@ -154,8 +156,15 @@ PREDICATE: class predicate "definition" word-prop ;
PREDICATE: class union members ;
! Definition protocol
: smaller-classes- ( class -- )
class<map get remove-hash ;
: bigger-classes- ( class -- )
classes [ class<map get hash remove-hash ] each-with ;
: forget-class ( class -- )
dup "predicate" word-prop [ forget ] each
dup flatten-class typemap get remove-hash forget-word ;
dup dup flatten-class typemap get remove-hash forget-word
dup smaller-classes- bigger-classes- ;
M: class forget forget-class ;

10
library/generic/classes.facts
View File

@ -70,16 +70,6 @@ HELP: class<
{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
HELP: make-class<cache
{ $values { "hash" "a hashtable" } }
{ $description "Constructs a hashtable mapping classes to hashtables of classes which are smaller than them under " { $link class< } "." }
{ $notes "This word should not be called directly. Instead, use " { $link with-class<cache } "." } ;
HELP: with-class<cache
{ $values { "quot" "a quotation" } }
{ $description "Calls the quotation in a new dynamic scope where the " { $link class<cache } " variable is bound to a hashtable output by " { $link make-class<cache } ". When this variable is bound, " { $link class< } " can be performed much more quickly than usual." }
{ $notes "Calls to compile large numbers of words can be wrapped in this combinator to reduce compile time." } ;
HELP: class-compare
{ $values { "class1" "a class" } { "class2" "a class" } { "n" "an integer" } }
{ $description "Compares two classes, with the sign of the result indicating their sort order." }

7
library/test/collections/hashtables.factor
View File

@ -12,7 +12,7 @@ USE: prettyprint
[ "hi" V{ 1 2 3 } hash ] unit-test-fails
[ H{ } ] [ { } [ ] map>hash ] unit-test
[ H{ } ] [ { } [ dup ] map>hash ] unit-test
[ ] [ 1000 [ dup sq ] map>hash "testhash" set ] unit-test
@ -199,11 +199,6 @@ H{ } clone "cache-test" set
[ { 1 3 } ] [ H{ { 2 2 } } { 1 2 3 } remove-all ] unit-test
[ H{ } ] [ { } hash-concat ] unit-test
[ H{ } ] [ { H{ } } hash-concat ] unit-test
[ H{ { 1 2 } } ] [ { H{ { 1 2 } } } hash-concat ] unit-test
[ H{ { 1 2 } { 3 4 } } ] [ { H{ { 1 2 } } H{ { 3 4 } } } hash-concat ] unit-test
! Resource leak...
H{ } "x" set
100 [ drop "x" get clear-hash ] each

51
library/test/generic.factor
View File

@ -56,33 +56,28 @@ M: very-funny gooey sq ;
[ 1/4 ] [ 1/2 gooey ] unit-test
: class<tests
[ object ] [ object object class-and ] unit-test
[ fixnum ] [ fixnum object class-and ] unit-test
[ fixnum ] [ object fixnum class-and ] unit-test
[ fixnum ] [ fixnum fixnum class-and ] unit-test
[ fixnum ] [ fixnum integer class-and ] unit-test
[ fixnum ] [ integer fixnum class-and ] unit-test
[ null ] [ vector fixnum class-and ] unit-test
[ number ] [ number object class-and ] unit-test
[ number ] [ object number class-and ] unit-test
[ t ] [ \ fixnum \ integer class< ] unit-test
[ t ] [ \ fixnum \ fixnum class< ] unit-test
[ f ] [ \ integer \ fixnum class< ] unit-test
[ t ] [ \ integer \ object class< ] unit-test
[ f ] [ \ integer \ null class< ] unit-test
[ t ] [ \ null \ object class< ] unit-test
[ t ] [ \ generic \ compound class< ] unit-test
[ f ] [ \ compound \ generic class< ] unit-test
[ f ] [ \ reversed \ slice class< ] unit-test
[ f ] [ \ slice \ reversed class< ] unit-test ;
[ object ] [ object object class-and ] unit-test
[ fixnum ] [ fixnum object class-and ] unit-test
[ fixnum ] [ object fixnum class-and ] unit-test
[ fixnum ] [ fixnum fixnum class-and ] unit-test
[ fixnum ] [ fixnum integer class-and ] unit-test
[ fixnum ] [ integer fixnum class-and ] unit-test
[ null ] [ vector fixnum class-and ] unit-test
[ number ] [ number object class-and ] unit-test
[ number ] [ object number class-and ] unit-test
class<tests
[ t ] [ \ fixnum \ integer class< ] unit-test
[ t ] [ \ fixnum \ fixnum class< ] unit-test
[ f ] [ \ integer \ fixnum class< ] unit-test
[ t ] [ \ integer \ object class< ] unit-test
[ f ] [ \ integer \ null class< ] unit-test
[ t ] [ \ null \ object class< ] unit-test
[ class<tests ] with-class<cache
[ t ] [ \ generic \ compound class< ] unit-test
[ f ] [ \ compound \ generic class< ] unit-test
[ f ] [ \ reversed \ slice class< ] unit-test
[ f ] [ \ slice \ reversed class< ] unit-test
PREDICATE: word no-docs "documentation" word-prop not ;
@ -182,3 +177,9 @@ TUPLE: delegating ;
[ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test
[ number ] [ \ number \ float math-class-max ] unit-test
[ float ] [ \ real \ float math-class-max ] unit-test
TUPLE: forget-class-test ;
[ t ] [ forget-class-test tuple class<map get hash hash-member? ] unit-test
[ ] [ forget-class-test forget ] unit-test
[ f ] [ forget-class-test class<map get hash-member? ] unit-test
[ f ] [ forget-class-test tuple class<map get hash hash-member? ] unit-test

12
library/test/prettyprint.factor
View File

@ -1,5 +1,5 @@
USING: alien io definitions kernel math prettyprint sequences
test words inference namespaces vectors ;
USING: alien definitions inference io kernel math namespaces
parser prettyprint sequences test vectors words ;
IN: temporary
[ "4" ] [ 4 unparse ] unit-test
@ -43,19 +43,19 @@ unit-test
[ [ \ bar see ] string-out ] unit-test
[ "( a b -- c d )" ] [
{ { "a" "b" } { "c" "d" } } effect>string
{ "a" "b" } { "c" "d" } <effect> effect>string
] unit-test
[ "( -- c d )" ] [
{ { } { "c" "d" } } effect>string
{ } { "c" "d" } <effect> effect>string
] unit-test
[ "( a b -- )" ] [
{ { "a" "b" } { } } effect>string
{ "a" "b" } { } <effect> effect>string
] unit-test
[ "( -- )" ] [
{ { } { } } effect>string
{ } { } <effect> effect>string
] unit-test
[ ] [ \ fixnum see ] unit-test

4
library/test/redefine.factor
View File

@ -2,8 +2,8 @@ USING: compiler definitions generic hashtables inference math
namespaces parser test words ;
IN: temporary
DEFER: foo
DEFER: bar
DEFER: foo \ foo reset-generic
DEFER: bar \ bar reset-generic
[ ] [ \ foo [ 1 2 ] define-compound ] unit-test
[ { 0 2 } ] [ [ foo ] infer ] unit-test