From 77d45d654ab664282c6ea70e359d4525a9c8b7f0 Mon Sep 17 00:00:00 2001 From: Phil Dawes Date: Tue, 8 Jul 2008 20:01:28 +0100 Subject: [PATCH 01/64] Wordtimer vocab for time-profiling words and vocabs --- extra/wordtimer/authors.txt | 1 + extra/wordtimer/summary.txt | 1 + extra/wordtimer/wordtimer-docs.factor | 34 +++++++++++ extra/wordtimer/wordtimer-tests.factor | 10 ++++ extra/wordtimer/wordtimer.factor | 81 ++++++++++++++++++++++++++ 5 files changed, 127 insertions(+) create mode 100644 extra/wordtimer/authors.txt create mode 100644 extra/wordtimer/summary.txt create mode 100644 extra/wordtimer/wordtimer-docs.factor create mode 100644 extra/wordtimer/wordtimer-tests.factor create mode 100644 extra/wordtimer/wordtimer.factor diff --git a/extra/wordtimer/authors.txt b/extra/wordtimer/authors.txt new file mode 100644 index 0000000000..0be42b2faa --- /dev/null +++ b/extra/wordtimer/authors.txt @@ -0,0 +1 @@ +Phil Dawes diff --git a/extra/wordtimer/summary.txt b/extra/wordtimer/summary.txt new file mode 100644 index 0000000000..efe591da27 --- /dev/null +++ b/extra/wordtimer/summary.txt @@ -0,0 +1 @@ +Microsecond precision code timer/profiler. diff --git a/extra/wordtimer/wordtimer-docs.factor b/extra/wordtimer/wordtimer-docs.factor new file mode 100644 index 0000000000..7d9de34252 --- /dev/null +++ b/extra/wordtimer/wordtimer-docs.factor @@ -0,0 +1,34 @@ +USING: help.syntax help.markup kernel prettyprint sequences ; +IN: wordtimer + +HELP: reset-word-timer +{ $description "resets the global wordtimes datastructure. Must be called before calling any word-timer annotated code" +} ; + +HELP: add-timer +{ $values { "word" "a word" } } +{ $description "annotates the word with timing code which stores timing information globally. You can then view the info with print-word-timings" +} ; + +HELP: add-timers +{ $values { "vocab" "a string" } } +{ $description "annotates all the words in the vocab with timer code. After profiling you can remove the annotations with reset-vocab" +} ; + + +HELP: reset-vocab +{ $values { "vocab" "a string" } } +{ $description "removes the annotations from all the words in the vocab" +} ; + +HELP: print-word-timings +{ $description "Displays the timing information for each word-timer annotated word. Columns are: total time taken in microseconds, number of invocations, wordname" +} ; + +HELP: correct-for-timing-overhead +{ $description "attempts to correct the timings to take into account the overhead of the timing function. This is pretty error-prone but can be handy when you're timing words that only take a handful of milliseconds but are called a lot" } ; + +ARTICLE: "wordtimer" "Word Timer" +"The " { $vocab-link "wordtimer" } " vocabulary measures accumulated execution time for words. You first annotate individual words with the " { $link add-timer } " word or whole vocabularies with " { $link add-timers } ". Then you reset the clock with " { $link reset-word-timer } " and execute your code. Finally you can view the timings with " { $link print-word-timings } ". If you have functions that are quick and called often you may want to " { $link correct-for-timing-overhead } ". To remove all the annotations in the vocab you can use " { $link reset-vocab } "." ; + +ABOUT: "wordtimer" diff --git a/extra/wordtimer/wordtimer-tests.factor b/extra/wordtimer/wordtimer-tests.factor new file mode 100644 index 0000000000..47287179ce --- /dev/null +++ b/extra/wordtimer/wordtimer-tests.factor @@ -0,0 +1,10 @@ +USING: tools.test wordtimer math kernel tools.annotations prettyprint ; +IN: wordtimer.tests + +: testfn ( a b c d -- a+b c+d ) + + [ + ] dip ; + +[ 3 7 ] +[ reset-word-timer + \ testfn [ reset ] [ add-timer ] bi + 1 2 3 4 testfn ] unit-test \ No newline at end of file diff --git a/extra/wordtimer/wordtimer.factor b/extra/wordtimer/wordtimer.factor new file mode 100644 index 0000000000..1ce5f13a81 --- /dev/null +++ b/extra/wordtimer/wordtimer.factor @@ -0,0 +1,81 @@ +USING: kernel sequences namespaces math assocs words arrays tools.annotations vocabs sorting prettyprint io micros math.statistics ; +IN: wordtimer + +SYMBOL: *wordtimes* +SYMBOL: *calling* + +: reset-word-timer ( -- ) + H{ } clone *wordtimes* set-global + H{ } clone *calling* set-global ; + +: lookup-word-time ( wordname -- utime n ) + *wordtimes* get-global [ drop { 0 0 } ] cache first2 ; + +: update-times ( utime current-utime current-numinvokes -- utime' invokes' ) + rot [ + ] curry [ 1+ ] bi* ; + +: register-time ( utime word -- ) + word-name + [ lookup-word-time update-times 2array ] keep *wordtimes* get-global set-at ; + +: calling ( word -- ) + dup *calling* get-global set-at ; inline + +: finished ( word -- ) + *calling* get-global delete-at ; inline + +: called-recursively? ( word -- t/f ) + *calling* get-global at ; inline + +: timed-call ( quot word -- ) + [ calling ] [ >r micro-time r> register-time ] [ finished ] tri ; inline + +: time-unless-recursing ( quot word -- ) + dup called-recursively? not + [ timed-call ] [ drop call ] if ; inline + +: (add-timer) ( word quot -- quot' ) + [ swap time-unless-recursing ] 2curry ; + +: add-timer ( word -- ) + dup [ (add-timer) ] annotate ; + +: add-timers ( vocabspec -- ) + words [ add-timer ] each ; + +: reset-vocab ( vocabspec -- ) + words [ reset ] each ; + +: dummy-word ( -- ) ; + +: time-dummy-word ( -- n ) + [ 100000 [ [ dummy-word ] micro-time , ] times ] { } make median ; + +: subtract-overhead ( {oldtime,n} overhead -- {newtime,n} ) + [ first2 ] dip + swap [ * - ] keep 2array ; + +: change-global ( variable quot -- ) + global swap change-at ; + +: (correct-for-timing-overhead) ( timingshash -- timingshash ) + time-dummy-word [ subtract-overhead ] curry assoc-map ; + +: correct-for-timing-overhead ( -- ) + *wordtimes* [ (correct-for-timing-overhead) ] change-global ; + +: print-word-timings ( -- ) + *wordtimes* get-global [ swap suffix ] { } assoc>map natural-sort reverse pprint ; + + +: profile-vocab ( vocabspec quot -- ) + "annotating vocab..." print flush + over [ reset-vocab ] [ add-timers ] bi + reset-word-timer + "executing quotation..." print flush + [ call ] micro-time >r + "resetting annotations..." print flush + swap reset-vocab + correct-for-timing-overhead + "total time:" write r> pprint + print-word-timings ; \ No newline at end of file From cf342b9a86df0f8e8f69bc5e2ee71472867282f0 Mon Sep 17 00:00:00 2001 From: Phil Dawes Date: Tue, 8 Jul 2008 20:32:34 +0100 Subject: [PATCH 02/64] fixed to use new-style accessor for word-name --- extra/wordtimer/wordtimer.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/wordtimer/wordtimer.factor b/extra/wordtimer/wordtimer.factor index 1ce5f13a81..e9ed0c8cf0 100644 --- a/extra/wordtimer/wordtimer.factor +++ b/extra/wordtimer/wordtimer.factor @@ -1,4 +1,4 @@ -USING: kernel sequences namespaces math assocs words arrays tools.annotations vocabs sorting prettyprint io micros math.statistics ; +USING: kernel sequences namespaces math assocs words arrays tools.annotations vocabs sorting prettyprint io micros math.statistics accessors ; IN: wordtimer SYMBOL: *wordtimes* @@ -15,7 +15,7 @@ SYMBOL: *calling* rot [ + ] curry [ 1+ ] bi* ; : register-time ( utime word -- ) - word-name + name>> [ lookup-word-time update-times 2array ] keep *wordtimes* get-global set-at ; : calling ( word -- ) From 7b5529a290da1fdf4756db8fca58b41dc2bd5abc Mon Sep 17 00:00:00 2001 From: Phil Dawes Date: Tue, 8 Jul 2008 20:50:49 +0100 Subject: [PATCH 03/64] Added doc for profile-vocab --- extra/wordtimer/wordtimer-docs.factor | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/extra/wordtimer/wordtimer-docs.factor b/extra/wordtimer/wordtimer-docs.factor index 7d9de34252..47b85bb007 100644 --- a/extra/wordtimer/wordtimer-docs.factor +++ b/extra/wordtimer/wordtimer-docs.factor @@ -27,8 +27,15 @@ HELP: print-word-timings HELP: correct-for-timing-overhead { $description "attempts to correct the timings to take into account the overhead of the timing function. This is pretty error-prone but can be handy when you're timing words that only take a handful of milliseconds but are called a lot" } ; + +HELP: profile-vocab +{ $values { "vocabspec" "string name of a vocab" } + { "quot" "a quotation to run" } } +{ $description "Annotates the words in the vocab with timing code then runs the quotation. Finally resets the words and prints the timings information." +} ; + ARTICLE: "wordtimer" "Word Timer" -"The " { $vocab-link "wordtimer" } " vocabulary measures accumulated execution time for words. You first annotate individual words with the " { $link add-timer } " word or whole vocabularies with " { $link add-timers } ". Then you reset the clock with " { $link reset-word-timer } " and execute your code. Finally you can view the timings with " { $link print-word-timings } ". If you have functions that are quick and called often you may want to " { $link correct-for-timing-overhead } ". To remove all the annotations in the vocab you can use " { $link reset-vocab } "." ; +"The " { $vocab-link "wordtimer" } " vocabulary measures accumulated execution time for words. If you just want to profile the accumulated time taken by all words in a vocab you can use " { $vocab-link "profile-vocab" } ". If you need more fine grained control then do the following: First annotate individual words with the " { $link add-timer } " word or whole vocabularies with " { $link add-timers } ". Then reset the clock with " { $link reset-word-timer } " and execute your code. Finally you can view the timings with " { $link print-word-timings } ". If you have functions that are quick and called often you may want to " { $link correct-for-timing-overhead } ". To remove all the annotations in the vocab you can use " { $link reset-vocab } ". Alternatively if you just want to time the contents of a vocabulary you can use profile-vocab." ; ABOUT: "wordtimer" From de59a24380f747e116901695a6251a30083247e8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 10 Jul 2008 13:11:43 -0500 Subject: [PATCH 04/64] Rename incorrectly named file --- extra/backtrack/{description.txt => summary.txt} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename extra/backtrack/{description.txt => summary.txt} (100%) diff --git a/extra/backtrack/description.txt b/extra/backtrack/summary.txt similarity index 100% rename from extra/backtrack/description.txt rename to extra/backtrack/summary.txt From b93342298f2d043815df41dd404a27d34793e047 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Thu, 10 Jul 2008 23:59:43 +0200 Subject: [PATCH 05/64] Initial import of etags vocab, that generates an word index in Emacs etags format --- extra/ctags/etags/etags-tests.factor | 47 +++++++++++++++++++ extra/ctags/etags/etags.factor | 68 ++++++++++++++++++++++++++++ 2 files changed, 115 insertions(+) create mode 100644 extra/ctags/etags/etags-tests.factor create mode 100644 extra/ctags/etags/etags.factor diff --git a/extra/ctags/etags/etags-tests.factor b/extra/ctags/etags/etags-tests.factor new file mode 100644 index 0000000000..fbd9a65186 --- /dev/null +++ b/extra/ctags/etags/etags-tests.factor @@ -0,0 +1,47 @@ +USING: kernel ctags.etags tools.test io.backend sequences arrays prettyprint hashtables assocs ; +IN: ctags.etags.tests + + +[ H{ { "path" V{ if { "path" 1 } } } } ] +[ H{ } clone dup V{ if { "path" 1 } } "path" rot set-at ] unit-test + +[ { "path" V{ if { "path" 1 } } } ] +[ H{ } clone dup { "path" V{ if { "path" 1 } } } "path" rot set-at "path" swap at ] unit-test + + +[ V{ if { "path" 1 } } ] +[ "path" H{ { "path" V{ if { "path" 1 } } } } at ] unit-test + +[ "path" ] [ { if { "path" 1 } } ctag-path ] unit-test + +[ V{ } ] +[ "path" H{ } clone ctag-at ] unit-test + +[ V{ if { "path" 1 } } ] +[ "path" H{ { "path" V{ if { "path" 1 } } } } ctag-at ] unit-test + +[ { if 28 } ] +[ { if { "resource:core/kernel/kernel.factor" 28 } } ctag-value ] unit-test + +[ V{ } ] [ { if { "path" 1 } } H{ } clone ctag-hashvalue ] unit-test + +[ V{ if { "path" 1 } } ] +[ { if { "path" 1 } } + { { "path" V{ if { "path" 1 } } } } >hashtable + ctag-hashvalue +] unit-test + +[ H{ { "path" V{ { if 1 } } } } ] +[ { if { "path" 1 } } H{ } clone ctag-add ] unit-test + +[ H{ { "path" V{ { if 1 } } } } ] +[ { { if { "path" 1 } } } ctag-hash ] unit-test + +[ "if28,704" ] +[ "resource:core/kernel/kernel.factor" { if 28 } etag ] unit-test + +! [ V{ " " "resource:core/kernel/kernel.factor,22" "if28,704" "unless31,755" } ] +! [ { { "resource:core/kernel/kernel.factor" +! V{ { if 28 } +! { unless 31 } } } } etag-strings ] unit-test + diff --git a/extra/ctags/etags/etags.factor b/extra/ctags/etags/etags.factor new file mode 100644 index 0000000000..227f146307 --- /dev/null +++ b/extra/ctags/etags/etags.factor @@ -0,0 +1,68 @@ +! Copyright (C) 2008 Alfredo Beaumont +! See http://factorcode.org/license.txt for BSD license. + +! Emacs Etags generator +! Alfredo Beaumont +USING: kernel sequences sorting assocs words prettyprint ctags +io.encodings.ascii io.files math math.parser namespaces strings locals +shuffle io.backend memoize ; +IN: ctags.etags + +: ctag-path ( alist -- path ) + second first ; + +: ctag-at ( key hash -- vector ) + at [ V{ } clone ] unless* ; + +: ctag-hashvalue ( alist hash -- vector ) + [ ctag-path ] dip ctag-at ; + +: ctag-value ( ctag -- seq ) + dup [ first , second second , ] { } make ; + +: ctag-add ( ctag hash -- hash ) + [ ctag-hashvalue ] 2keep [ dup ctag-path [ ctag-value suffix ] dip ] dip [ set-at ] keep ; + +: ctag-hash ( seq -- hash ) + H{ } clone swap [ swap ctag-add ] each ; + +: line>bytes ( n seq -- bytes ) + nth length 1+ ; + +: lines>bytes ( n seq -- bytes ) + over zero? [ line>bytes ] [ [ [ 1 - ] dip lines>bytes ] 2keep line>bytes + ] if ; + +: file>bytes ( n path -- bytes ) + ascii file-lines lines>bytes ; + +SYMBOL: resource +: etag ( path seq -- str ) + [ + dup first ?word-name % + 1 HEX: 7f % + second dup number>string % + 1 CHAR: , % + 2 - swap file>bytes number>string % + ] "" make ; + +: etag-entry ( alist -- alist path ) + [ first ] keep swap ; + +: vector-length ( vector -- n ) + 0 [ length + ] reduce ; + +: etag-header ( n path -- str ) + [ + % + 1 CHAR: , % + number>string % + ] "" make ; + +: etag-strings ( alist -- seq ) + { } swap [ etag-entry resource [ second [ resource get swap etag ] map dup vector-length resource get normalize-path etag-header prefix 1 HEX: 0c prefix ] with-variable append ] each ; + +: etags-write ( alist path -- ) + [ etag-strings ] dip ascii set-file-lines ; + +: etags ( path -- ) + (ctags) sort-values ctag-hash >alist swap etags-write ; \ No newline at end of file From cec5291ed420e98ed8c344e10b91f5e44cef7287 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Fri, 11 Jul 2008 10:32:15 +0200 Subject: [PATCH 06/64] Style improvements --- extra/ctags/etags/etags.factor | 29 ++++++++++++++++++++++++----- 1 file changed, 24 insertions(+), 5 deletions(-) diff --git a/extra/ctags/etags/etags.factor b/extra/ctags/etags/etags.factor index 227f146307..75fe249538 100644 --- a/extra/ctags/etags/etags.factor +++ b/extra/ctags/etags/etags.factor @@ -21,7 +21,9 @@ IN: ctags.etags dup [ first , second second , ] { } make ; : ctag-add ( ctag hash -- hash ) - [ ctag-hashvalue ] 2keep [ dup ctag-path [ ctag-value suffix ] dip ] dip [ set-at ] keep ; + [ ctag-hashvalue ] 2keep [ + dup ctag-path [ ctag-value suffix ] dip + ] dip [ set-at ] keep ; : ctag-hash ( seq -- hash ) H{ } clone swap [ swap ctag-add ] each ; @@ -30,12 +32,16 @@ IN: ctags.etags nth length 1+ ; : lines>bytes ( n seq -- bytes ) - over zero? [ line>bytes ] [ [ [ 1 - ] dip lines>bytes ] 2keep line>bytes + ] if ; + over zero? [ + line>bytes ] [ + [ + [ 1- ] dip lines>bytes + ] 2keep line>bytes + + ] if ; : file>bytes ( n path -- bytes ) ascii file-lines lines>bytes ; -SYMBOL: resource : etag ( path seq -- str ) [ dup first ?word-name % @@ -51,15 +57,28 @@ SYMBOL: resource : vector-length ( vector -- n ) 0 [ length + ] reduce ; -: etag-header ( n path -- str ) +:
( n path -- str ) [ % 1 CHAR: , % number>string % ] "" make ; +: etag-header ( vec1 n resource -- vec2 ) + normalize-path
prefix + 1 HEX: 0c prefix ; + +SYMBOL: resource : etag-strings ( alist -- seq ) - { } swap [ etag-entry resource [ second [ resource get swap etag ] map dup vector-length resource get normalize-path etag-header prefix 1 HEX: 0c prefix ] with-variable append ] each ; + { } swap [ + etag-entry resource [ + second [ + resource get swap etag + ] map dup vector-length + resource get + ] with-variable + etag-header append + ] each ; : etags-write ( alist path -- ) [ etag-strings ] dip ascii set-file-lines ; From 4cb68c4a4df5a3150cfffaff9bb4324af2091780 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Fri, 11 Jul 2008 10:53:51 +0200 Subject: [PATCH 07/64] Open every source file just once. This make code work ~20x faster --- extra/ctags/etags/etags.factor | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/extra/ctags/etags/etags.factor b/extra/ctags/etags/etags.factor index 75fe249538..94928a263e 100644 --- a/extra/ctags/etags/etags.factor +++ b/extra/ctags/etags/etags.factor @@ -5,7 +5,7 @@ ! Alfredo Beaumont USING: kernel sequences sorting assocs words prettyprint ctags io.encodings.ascii io.files math math.parser namespaces strings locals -shuffle io.backend memoize ; +shuffle io.backend arrays ; IN: ctags.etags : ctag-path ( alist -- path ) @@ -39,20 +39,20 @@ IN: ctags.etags ] 2keep line>bytes + ] if ; -: file>bytes ( n path -- bytes ) - ascii file-lines lines>bytes ; +: file>lines ( resource -- lines ) + ascii file-lines ; -: etag ( path seq -- str ) +: etag ( lines seq -- str ) [ dup first ?word-name % 1 HEX: 7f % second dup number>string % 1 CHAR: , % - 2 - swap file>bytes number>string % + 2 - swap lines>bytes number>string % ] "" make ; -: etag-entry ( alist -- alist path ) - [ first ] keep swap ; +: etag-entry ( alist -- alist array ) + [ first ] keep swap [ file>lines ] keep 2array ; : vector-length ( vector -- n ) 0 [ length + ] reduce ; @@ -73,9 +73,9 @@ SYMBOL: resource { } swap [ etag-entry resource [ second [ - resource get swap etag + resource get first swap etag ] map dup vector-length - resource get + resource get second ] with-variable etag-header append ] each ; From 5a1ab1edaed1e93b9d6f436970772579c90c8b22 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Fri, 11 Jul 2008 16:16:01 +0200 Subject: [PATCH 08/64] Some improvements both in elegance and performance in ctags vocab --- extra/ctags/ctags.factor | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/extra/ctags/ctags.factor b/extra/ctags/ctags.factor index 23d9aeb90c..2ec1208df9 100644 --- a/extra/ctags/ctags.factor +++ b/extra/ctags/ctags.factor @@ -19,19 +19,17 @@ IN: ctags ] "" make ; : ctag-strings ( seq1 -- seq2 ) - { } swap [ ctag suffix ] each ; + [ ctag ] map ; : ctags-write ( seq path -- ) [ ctag-strings ] dip ascii set-file-lines ; : (ctags) ( -- seq ) - { } all-words [ + all-words [ dup where [ - 2array suffix - ] [ - drop - ] if* - ] each ; + 2array + ] when* + ] map [ sequence? ] filter ; : ctags ( path -- ) (ctags) sort-keys swap ctags-write ; \ No newline at end of file From dd759b1e1356d5de8ad28419a90fdd5d7f507997 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Sat, 12 Jul 2008 02:47:48 +0200 Subject: [PATCH 09/64] Fix testsuite --- extra/ctags/etags/etags-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ctags/etags/etags-tests.factor b/extra/ctags/etags/etags-tests.factor index fbd9a65186..53e8f99aaf 100644 --- a/extra/ctags/etags/etags-tests.factor +++ b/extra/ctags/etags/etags-tests.factor @@ -38,7 +38,7 @@ IN: ctags.etags.tests [ { { if { "path" 1 } } } ctag-hash ] unit-test [ "if28,704" ] -[ "resource:core/kernel/kernel.factor" { if 28 } etag ] unit-test +[ "resource:core/kernel/kernel.factor" file>lines { if 28 } etag ] unit-test ! [ V{ " " "resource:core/kernel/kernel.factor,22" "if28,704" "unless31,755" } ] ! [ { { "resource:core/kernel/kernel.factor" From ca781ea739dd7426d07d283a7331040f37424aa7 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Sat, 12 Jul 2008 02:48:09 +0200 Subject: [PATCH 10/64] Simplify using iteration --- extra/ctags/etags/etags.factor | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/extra/ctags/etags/etags.factor b/extra/ctags/etags/etags.factor index 94928a263e..f2d7d7e174 100644 --- a/extra/ctags/etags/etags.factor +++ b/extra/ctags/etags/etags.factor @@ -28,16 +28,8 @@ IN: ctags.etags : ctag-hash ( seq -- hash ) H{ } clone swap [ swap ctag-add ] each ; -: line>bytes ( n seq -- bytes ) - nth length 1+ ; - -: lines>bytes ( n seq -- bytes ) - over zero? [ - line>bytes ] [ - [ - [ 1- ] dip lines>bytes - ] 2keep line>bytes + - ] if ; +: lines>bytes ( seq n -- bytes ) + head 0 [ length 1+ + ] reduce ; : file>lines ( resource -- lines ) ascii file-lines ; @@ -48,7 +40,7 @@ IN: ctags.etags 1 HEX: 7f % second dup number>string % 1 CHAR: , % - 2 - swap lines>bytes number>string % + 1- lines>bytes number>string % ] "" make ; : etag-entry ( alist -- alist array ) From 966ef323bca76a3e87c8146a842eb54931555483 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Jul 2008 03:53:34 -0500 Subject: [PATCH 11/64] Expand allocations for simpler intrinsics --- core/classes/tuple/tuple.factor | 12 --- core/cpu/architecture/architecture.factor | 2 - core/cpu/ppc/intrinsics/intrinsics.factor | 13 +-- core/cpu/x86/intrinsics/intrinsics.factor | 17 ++-- core/inference/known-words/known-words.factor | 3 - core/optimizer/allot/allot.factor | 96 +++++++++++++++++++ core/optimizer/known-words/known-words.factor | 33 +------ core/optimizer/optimizer.factor | 5 +- extra/optimizer/debugger/debugger.factor | 1 + 9 files changed, 111 insertions(+), 71 deletions(-) create mode 100644 core/optimizer/allot/allot.factor diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 71c5f3efe6..ff8d2157da 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -22,18 +22,6 @@ ERROR: not-a-tuple object ; primitive. In optimized code, an intrinsic - #! is generated which allocates a tuple but does not set - #! any of its slots. This means that any code that uses - #! (tuple) must fill in the slots before the next - #! call to GC. - #! - #! This word is only used in the expansion of , - #! where this invariant is guaranteed to hold. - ; - : tuple-layout ( class -- layout ) "layout" word-prop ; diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index bd6f639415..56b4630962 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -162,8 +162,6 @@ PREDICATE: small-slot < integer cells small-enough? ; PREDICATE: small-tagged < integer v>operand small-enough? ; -PREDICATE: inline-array < integer 32 < ; - : if-small-struct ( n size true false -- ? ) >r >r over not over struct-small-enough? and [ nip r> call r> drop ] [ r> drop r> call ] if ; diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index c9c4432d52..5a39cbca71 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -450,33 +450,28 @@ IN: cpu.ppc.intrinsics { +output+ { "tuple" } } } define-intrinsic -\ [ +\ (array) [ array "n" get 2 + cells %allot ! Store length "n" operand 12 LI 12 11 cell STW - ! Store initial element - "n" get [ "initial" operand 11 rot 2 + cells STW ] each ! Store tagged ptr in reg "array" get object %store-tagged ] H{ - { +input+ { { [ inline-array? ] "n" } { f "initial" } } } + { +input+ { { [ ] "n" } } } { +scratch+ { { f "array" } } } { +output+ { "array" } } } define-intrinsic -\ [ +\ (byte-array) [ byte-array "n" get 2 cells + %allot ! Store length "n" operand 12 LI 12 11 cell STW - ! Store initial element - 0 12 LI - "n" get cell align cell /i [ 12 11 rot 2 + cells STW ] each ! Store tagged ptr in reg "array" get object %store-tagged ] H{ - { +input+ { { [ inline-array? ] "n" } } } + { +input+ { { [ ] "n" } } } { +scratch+ { { f "array" } } } { +output+ { "array" } } } define-intrinsic diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index d19749ae39..3cf131087e 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -6,8 +6,7 @@ kernel.private math math.private namespaces quotations sequences words generic byte-arrays hashtables hashtables.private generator generator.registers generator.fixup sequences.private sbufs sbufs.private vectors vectors.private layouts system -classes.tuple.private strings.private slots.private -compiler.constants ; +strings.private slots.private compiler.constants optimizer.allot ; IN: cpu.x86.intrinsics ! Type checks @@ -298,37 +297,33 @@ IN: cpu.x86.intrinsics "tuple" get tuple %store-tagged ] %allot ] H{ - { +input+ { { [ tuple-layout? ] "layout" } } } + { +input+ { { [ ] "layout" } } } { +scratch+ { { f "tuple" } { f "scratch" } } } { +output+ { "tuple" } } } define-intrinsic -\ [ +\ (array) [ array "n" get 2 + cells [ ! Store length 1 object@ "n" operand MOV - ! Zero out the rest of the tuple - "n" get [ 2 + object@ "initial" operand MOV ] each ! Store tagged ptr in reg "array" get object %store-tagged ] %allot ] H{ - { +input+ { { [ inline-array? ] "n" } { f "initial" } } } + { +input+ { { [ ] "n" } } } { +scratch+ { { f "array" } } } { +output+ { "array" } } } define-intrinsic -\ [ +\ (byte-array) [ byte-array "n" get 2 cells + [ ! Store length 1 object@ "n" operand MOV - ! Store initial element - "n" get cell align cell /i [ 2 + object@ 0 MOV ] each ! Store tagged ptr in reg "array" get object %store-tagged ] %allot ] H{ - { +input+ { { [ inline-array? ] "n" } } } + { +input+ { { [ ] "n" } } } { +scratch+ { { f "array" } } } { +output+ { "array" } } } define-intrinsic diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 1c9138fe0b..3636a01963 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -540,9 +540,6 @@ set-primitive-effect \ { tuple-layout } { tuple } set-primitive-effect \ make-flushable -\ (tuple) { tuple-layout } { tuple } set-primitive-effect -\ (tuple) make-flushable - \ { word fixnum array fixnum } { tuple-layout } set-primitive-effect \ make-foldable diff --git a/core/optimizer/allot/allot.factor b/core/optimizer/allot/allot.factor new file mode 100644 index 0000000000..d89e3c5f84 --- /dev/null +++ b/core/optimizer/allot/allot.factor @@ -0,0 +1,96 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors sequences sequences.private classes.tuple +classes.tuple.private kernel effects words quotations namespaces +definitions math math.order layouts alien.accessors +slots.private arrays byte-arrays inference.dataflow +inference.known-words inference.state optimizer.inlining +optimizer.backend ; +IN: optimizer.allot + +! Expand memory allocation primitives into simpler constructs +! to simplify the backend. + +: first-input ( #call -- obj ) dup in-d>> first node-literal ; + +: (tuple) ( layout -- tuple ) "BUG: missing (tuple) intrinsic" throw ; + +\ (tuple) { tuple-layout } { tuple } set-primitive-effect +\ (tuple) make-flushable + +! if the input to new is a literal tuple class, we can expand it +: literal-new? ( #call -- ? ) + first-input tuple-class? ; + +: new-quot ( class -- quot ) + dup all-slots 1 tail ! delegate slot + [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ; + +: expand-new ( #call -- node ) + dup first-input + [ +inlined+ depends-on ] [ new-quot ] bi + f splice-quot ; + +\ new { + { [ dup literal-new? ] [ expand-new ] } +} define-optimizers + +: tuple-boa-quot ( layout -- quot ) + [ (tuple) ] + swap size>> 1 - [ 3 + ] map + [ [ set-slot ] curry [ keep ] curry ] map concat + [ f over 2 set-slot ] + 3append ; + +: expand-tuple-boa ( #call -- node ) + dup in-d>> peek value-literal tuple-boa-quot f splice-quot ; + +\ { + { [ t ] [ expand-tuple-boa ] } +} define-optimizers + +: (array) ( n -- array ) "BUG: missing (array) intrinsic" throw ; + +\ (array) { integer } { array } set-primitive-effect +\ (array) make-flushable + +: -quot ( n -- quot ) + [ + [ swap (array) ] % + [ \ 2dup , , [ swap set-array-nth ] % ] each + \ nip , + ] [ ] make ; + +: literal-? ( #call -- ? ) + first-input dup integer? [ 0 32 between? ] [ drop f ] if ; + +: expand- ( #call -- node ) + dup first-input -quot f splice-quot ; + +\ { + { [ dup literal-? ] [ expand- ] } +} define-optimizers + +: (byte-array) ( n -- byte-array ) "BUG: missing (byte-array) intrinsic" throw ; + +\ (byte-array) { integer } { byte-array } set-primitive-effect +\ (byte-array) make-flushable + +: bytes>cells ( m -- n ) cell align cell /i ; + +: -quot ( n -- quot ) + [ + \ (byte-array) , + bytes>cells [ cell * ] map + [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each + ] [ ] make ; + +: literal-? ( #call -- ? ) + first-input dup integer? [ 0 128 between? ] [ drop f ] if ; + +: expand- ( #call -- node ) + dup first-input -quot f splice-quot ; + +\ { + { [ dup literal-? ] [ expand- ] } +} define-optimizers diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 7527199fe9..cd5ec7fda2 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -9,7 +9,7 @@ classes.tuple classes.predicate classes.tuple.private classes classes.algebra sequences.private combinators byte-arrays byte-vectors slots.private inference.dataflow inference.state inference.class optimizer.def-use optimizer.backend -optimizer.pattern-match optimizer.inlining ; +optimizer.pattern-match optimizer.inlining optimizer.allot ; IN: optimizer.known-words { (tuple) } [ @@ -25,37 +25,6 @@ IN: optimizer.known-words dup class? [ drop tuple ] unless 1array f ] "output-classes" set-word-prop -! if the input to new is a literal tuple class, we can expand it -: literal-new? ( #call -- ? ) - dup in-d>> first node-literal tuple-class? ; - -: new-quot ( class -- quot ) - dup all-slots 1 tail ! delegate slot - [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ; - -: expand-new ( #call -- node ) - dup dup in-d>> first node-literal - [ +inlined+ depends-on ] [ new-quot ] bi - f splice-quot ; - -\ new { - { [ dup literal-new? ] [ expand-new ] } -} define-optimizers - -: tuple-boa-quot ( layout -- quot ) - [ (tuple) ] - swap size>> 1 - [ 3 + ] map - [ [ set-slot ] curry [ keep ] curry ] map concat - [ f over 2 set-slot ] - 3append ; - -: expand-tuple-boa ( #call -- node ) - dup in-d>> peek value-literal tuple-boa-quot f splice-quot ; - -\ { - { [ t ] [ expand-tuple-boa ] } -} define-optimizers - ! the output of clone has the same type as the input { clone (clone) } [ [ diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor index 23cba3ea4c..d3c5a3ab91 100755 --- a/core/optimizer/optimizer.factor +++ b/core/optimizer/optimizer.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces optimizer.backend optimizer.def-use -optimizer.known-words optimizer.math optimizer.control -optimizer.collect optimizer.inlining inference.class ; +optimizer.known-words optimizer.math optimizer.allot +optimizer.control optimizer.collect optimizer.inlining +inference.class ; IN: optimizer : optimize-1 ( node -- newnode ? ) diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index 2a79d8977f..fdae538896 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -58,6 +58,7 @@ MATCH-VARS: ?a ?b ?c ; { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] } { { { ?a ?b } { ?a ?b ?a } } [ over ] } { { { ?b ?a } { ?a ?b } } [ swap ] } + { { { ?a ?b } { ?b ?a ?b } } [ tuck ] } { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] } { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] } { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] } From 6c5e73898ff314dd99b57d996d099054ec7cd73f Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Sun, 13 Jul 2008 17:05:41 +0200 Subject: [PATCH 12/64] Added some helper functions that may be used both in ctags and etags --- extra/ctags/ctags.factor | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/extra/ctags/ctags.factor b/extra/ctags/ctags.factor index 2ec1208df9..e8c5608375 100644 --- a/extra/ctags/ctags.factor +++ b/extra/ctags/ctags.factor @@ -9,13 +9,22 @@ io.encodings.ascii math.parser vocabs definitions namespaces words sorting ; IN: ctags +: ctag-word ( ctag -- word ) + first ; + +: ctag-path ( ctag -- path ) + second first ; + +: ctag-lineno ( ctag -- n ) + second second ; + : ctag ( seq -- str ) [ - dup first ?word-name % + dup ctag-word ?word-name % "\t" % - second dup first normalize-path % + dup ctag-path normalize-path % "\t" % - second number>string % + ctag-lineno number>string % ] "" make ; : ctag-strings ( seq1 -- seq2 ) From f05aabdf28d23aa7503c462a1885d0d5e7be8d57 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Sun, 13 Jul 2008 17:11:11 +0200 Subject: [PATCH 13/64] Rework etags vocab. Remove use of local variable shuffle words, use combinators instead. Rename some words and update testsuite accordingly --- extra/ctags/etags/etags-tests.factor | 16 +++++----- extra/ctags/etags/etags.factor | 48 +++++++++++++--------------- 2 files changed, 30 insertions(+), 34 deletions(-) diff --git a/extra/ctags/etags/etags-tests.factor b/extra/ctags/etags/etags-tests.factor index 53e8f99aaf..8d5fc0ee02 100644 --- a/extra/ctags/etags/etags-tests.factor +++ b/extra/ctags/etags/etags-tests.factor @@ -1,4 +1,4 @@ -USING: kernel ctags.etags tools.test io.backend sequences arrays prettyprint hashtables assocs ; +USING: kernel ctags ctags.etags tools.test io.backend sequences arrays prettyprint hashtables assocs ; IN: ctags.etags.tests @@ -15,27 +15,27 @@ IN: ctags.etags.tests [ "path" ] [ { if { "path" 1 } } ctag-path ] unit-test [ V{ } ] -[ "path" H{ } clone ctag-at ] unit-test +[ "path" H{ } clone etag-at ] unit-test [ V{ if { "path" 1 } } ] -[ "path" H{ { "path" V{ if { "path" 1 } } } } ctag-at ] unit-test +[ "path" H{ { "path" V{ if { "path" 1 } } } } etag-at ] unit-test [ { if 28 } ] -[ { if { "resource:core/kernel/kernel.factor" 28 } } ctag-value ] unit-test +[ { if { "resource:core/kernel/kernel.factor" 28 } } etag-pair ] unit-test -[ V{ } ] [ { if { "path" 1 } } H{ } clone ctag-hashvalue ] unit-test +[ V{ } ] [ { if { "path" 1 } } H{ } clone etag-vector ] unit-test [ V{ if { "path" 1 } } ] [ { if { "path" 1 } } { { "path" V{ if { "path" 1 } } } } >hashtable - ctag-hashvalue + etag-vector ] unit-test [ H{ { "path" V{ { if 1 } } } } ] -[ { if { "path" 1 } } H{ } clone ctag-add ] unit-test +[ { if { "path" 1 } } H{ } clone [ etag-add ] keep ] unit-test [ H{ { "path" V{ { if 1 } } } } ] -[ { { if { "path" 1 } } } ctag-hash ] unit-test +[ { { if { "path" 1 } } } etag-hash ] unit-test [ "if28,704" ] [ "resource:core/kernel/kernel.factor" file>lines { if 28 } etag ] unit-test diff --git a/extra/ctags/etags/etags.factor b/extra/ctags/etags/etags.factor index f2d7d7e174..b3ad879481 100644 --- a/extra/ctags/etags/etags.factor +++ b/extra/ctags/etags/etags.factor @@ -8,25 +8,25 @@ io.encodings.ascii io.files math math.parser namespaces strings locals shuffle io.backend arrays ; IN: ctags.etags -: ctag-path ( alist -- path ) - second first ; - -: ctag-at ( key hash -- vector ) +: etag-at ( key hash -- vector ) at [ V{ } clone ] unless* ; -: ctag-hashvalue ( alist hash -- vector ) - [ ctag-path ] dip ctag-at ; +: etag-vector ( alist hash -- vector ) + [ ctag-path ] dip etag-at ; -: ctag-value ( ctag -- seq ) - dup [ first , second second , ] { } make ; +: etag-pair ( ctag -- seq ) + dup [ + first , + second second , + ] { } make ; -: ctag-add ( ctag hash -- hash ) - [ ctag-hashvalue ] 2keep [ - dup ctag-path [ ctag-value suffix ] dip - ] dip [ set-at ] keep ; +: etag-add ( ctag hash -- ) + [ etag-vector ] 2keep [ + [ etag-pair ] [ ctag-path ] bi [ suffix ] dip + ] dip set-at ; -: ctag-hash ( seq -- hash ) - H{ } clone swap [ swap ctag-add ] each ; +: etag-hash ( seq -- hash ) + H{ } clone swap [ swap [ etag-add ] keep ] each ; : lines>bytes ( seq n -- bytes ) head 0 [ length 1+ + ] reduce ; @@ -43,10 +43,7 @@ IN: ctags.etags 1- lines>bytes number>string % ] "" make ; -: etag-entry ( alist -- alist array ) - [ first ] keep swap [ file>lines ] keep 2array ; - -: vector-length ( vector -- n ) +: etag-length ( vector -- n ) 0 [ length + ] reduce ; :
( n path -- str ) @@ -60,15 +57,14 @@ IN: ctags.etags normalize-path
prefix 1 HEX: 0c prefix ; -SYMBOL: resource : etag-strings ( alist -- seq ) { } swap [ - etag-entry resource [ - second [ - resource get first swap etag - ] map dup vector-length - resource get second - ] with-variable + [ + [ first file>lines ] + [ second ] bi + [ etag ] with map + dup etag-length + ] keep first etag-header append ] each ; @@ -76,4 +72,4 @@ SYMBOL: resource [ etag-strings ] dip ascii set-file-lines ; : etags ( path -- ) - (ctags) sort-values ctag-hash >alist swap etags-write ; \ No newline at end of file + [ (ctags) sort-values etag-hash >alist ] dip etags-write ; \ No newline at end of file From a10fc1e00e9298c4c0dffa542a54cd0959b4b3ed Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Sun, 13 Jul 2008 18:33:37 +0200 Subject: [PATCH 14/64] Added documentation and tests for new words --- extra/ctags/ctags-docs.factor | 44 ++++++++++++++++++++++++++++++++-- extra/ctags/ctags-tests.factor | 18 +++++++++++++- 2 files changed, 59 insertions(+), 3 deletions(-) diff --git a/extra/ctags/ctags-docs.factor b/extra/ctags/ctags-docs.factor index 22d811ad3f..32f3e05c6e 100644 --- a/extra/ctags/ctags-docs.factor +++ b/extra/ctags/ctags-docs.factor @@ -1,4 +1,4 @@ -USING: help.syntax help.markup kernel prettyprint sequences strings ; +USING: help.syntax help.markup kernel prettyprint sequences strings words math ; IN: ctags ARTICLE: "ctags" "Ctags file" @@ -6,7 +6,10 @@ ARTICLE: "ctags" "Ctags file" { $subsection ctags } { $subsection ctags-write } { $subsection ctag-strings } -{ $subsection ctag } ; +{ $subsection ctag } +{ $subsection ctag-word } +{ $subsection ctag-path } +{ $subsection ctag-lineno } ; HELP: ctags ( path -- ) { $values { "path" "a pathname string" } } @@ -57,4 +60,41 @@ HELP: ctag ( seq -- str ) } } ; +HELP: ctag-lineno ( ctag -- n ) +{ $values { "ctag" sequence } + { "n" integer } } +{ $description "Provides de line number " { $snippet "n" } " from a sequence in ctag format " } +{ $examples + { $example + "USING: kernel ctags prettyprint ;" + "{ if { \"resource:extra/unix/unix.factor\" 91 } } ctag-lineno ." + "91" + } +} ; + +HELP: ctag-path ( ctag -- path ) +{ $values { "ctag" sequence } + { "path" string } } +{ $description "Provides a path string " { $snippet "path" } " from a sequence in ctag format" } +{ $examples + { $example + "USING: kernel ctags prettyprint ;" + "{ if { \"resource:extra/unix/unix.factor\" 91 } } ctag-path ." + "\"resource:extra/unix/unix.factor\"" + } +} ; + +HELP: ctag-word ( ctag -- word ) +{ $values { "ctag" sequence } + { "word" word } } +{ $description "Provides the " { $snippet "word" } " from a sequence in ctag format " } +{ $examples + { $example + "USING: kernel ctags prettyprint ;" + "{ if { \"resource:extra/unix/unix.factor\" 91 } } ctag-word ." + "if" + } +} ; + + ABOUT: "ctags" \ No newline at end of file diff --git a/extra/ctags/ctags-tests.factor b/extra/ctags/ctags-tests.factor index 6c73b58ecb..700b897657 100644 --- a/extra/ctags/ctags-tests.factor +++ b/extra/ctags/ctags-tests.factor @@ -1,6 +1,21 @@ USING: kernel ctags tools.test io.backend sequences arrays prettyprint ; IN: ctags.tests +[ t ] [ + 91 + { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-lineno = +] unit-test + +[ t ] [ + "resource:extra/unix/unix.factor" + { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-path = +] unit-test + +[ t ] [ + if + { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-word = +] unit-test + [ t ] [ "if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append { if { "resource:extra/unix/unix.factor" 91 } } ctag = @@ -9,4 +24,5 @@ IN: ctags.tests [ t ] [ "if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append 1array { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-strings = -] unit-test \ No newline at end of file +] unit-test + From 222aa829bcdf6ad0520254574f395d787416cf3d Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Sun, 13 Jul 2008 18:35:44 +0200 Subject: [PATCH 15/64] Add authors and summary and documentation files and polish testsuite --- extra/ctags/etags/authors.txt | 1 + extra/ctags/etags/etags-docs.factor | 39 +++++++++++ extra/ctags/etags/etags-tests.factor | 101 +++++++++++++++++---------- extra/ctags/etags/etags.factor | 6 +- extra/ctags/etags/summary.txt | 1 + 5 files changed, 107 insertions(+), 41 deletions(-) create mode 100644 extra/ctags/etags/authors.txt create mode 100644 extra/ctags/etags/etags-docs.factor create mode 100644 extra/ctags/etags/summary.txt diff --git a/extra/ctags/etags/authors.txt b/extra/ctags/etags/authors.txt new file mode 100644 index 0000000000..158cf94ea0 --- /dev/null +++ b/extra/ctags/etags/authors.txt @@ -0,0 +1 @@ +Alfredo Beaumont diff --git a/extra/ctags/etags/etags-docs.factor b/extra/ctags/etags/etags-docs.factor new file mode 100644 index 0000000000..c38404740a --- /dev/null +++ b/extra/ctags/etags/etags-docs.factor @@ -0,0 +1,39 @@ +USING: help.syntax help.markup kernel prettyprint sequences strings words math ; +IN: ctags.etags + +ARTICLE: "etags" "Etags file" +{ $emphasis "Etags" } " generates a index file of every factor word in etags format as supported by emacs and other editors. More information can be found at " { $url "http://en.wikipedia.org/wiki/Ctags#Etags_2" } "." +{ $subsection etags } +{ $subsection etags-write } +{ $subsection etag-strings } +{ $subsection etag-header } + +HELP: etags ( path -- ) +{ $values { "path" string } } +{ $description "Generates a index file in etags format and stores in " { $snippet "path" } "." } +{ $examples + { $unchecked-example + "USING: ctags.etags ;" + "\"ETAGS\" etags" + "" + } +} ; + +HELP: etags-write ( alist path -- ) +{ $values { "alist" sequence } + { "path" string } } +{ $description "Stores a " { $snippet "alist" } " in " { $snippet "path" } ". " { $snippet "alist" } " must be an association list with etags format: its key must be a resource path and its value a vector, containing pairs of words and lines" } +{ $examples + { $unchecked-example + "USING: kernel etags.ctags ;" + "{ { \"resource:extra/unix/unix.factor\" V{ { dup2 91 } } } } \"ETAGS\" etags-write" + "" + } +} ; + +HELP: etag-strings ( alist -- seq ) +{ $values { "alist" sequence } + { "seq" sequence } } +{ $description "Converts an " { $snippet "alist" } " with etag format (a path as key and a vector containing word/line pairs) in a " { $snippet "seq" } " of strings." } + +ABOUT: "etags" \ No newline at end of file diff --git a/extra/ctags/etags/etags-tests.factor b/extra/ctags/etags/etags-tests.factor index 8d5fc0ee02..6ab97e0566 100644 --- a/extra/ctags/etags/etags-tests.factor +++ b/extra/ctags/etags/etags-tests.factor @@ -1,47 +1,72 @@ USING: kernel ctags ctags.etags tools.test io.backend sequences arrays prettyprint hashtables assocs ; IN: ctags.etags.tests - -[ H{ { "path" V{ if { "path" 1 } } } } ] -[ H{ } clone dup V{ if { "path" 1 } } "path" rot set-at ] unit-test - -[ { "path" V{ if { "path" 1 } } } ] -[ H{ } clone dup { "path" V{ if { "path" 1 } } } "path" rot set-at "path" swap at ] unit-test - - -[ V{ if { "path" 1 } } ] -[ "path" H{ { "path" V{ if { "path" 1 } } } } at ] unit-test - -[ "path" ] [ { if { "path" 1 } } ctag-path ] unit-test - -[ V{ } ] -[ "path" H{ } clone etag-at ] unit-test - -[ V{ if { "path" 1 } } ] -[ "path" H{ { "path" V{ if { "path" 1 } } } } etag-at ] unit-test - -[ { if 28 } ] -[ { if { "resource:core/kernel/kernel.factor" 28 } } etag-pair ] unit-test - -[ V{ } ] [ { if { "path" 1 } } H{ } clone etag-vector ] unit-test - -[ V{ if { "path" 1 } } ] -[ { if { "path" 1 } } - { { "path" V{ if { "path" 1 } } } } >hashtable - etag-vector +! etag-at +[ t ] +[ + V{ } + "path" H{ } clone etag-at = ] unit-test -[ H{ { "path" V{ { if 1 } } } } ] -[ { if { "path" 1 } } H{ } clone [ etag-add ] keep ] unit-test +[ t ] +[ + V{ if { "path" 1 } } + "path" H{ { "path" V{ if { "path" 1 } } } } etag-at = +] unit-test -[ H{ { "path" V{ { if 1 } } } } ] -[ { { if { "path" 1 } } } etag-hash ] unit-test +! etag-vector +[ t ] +[ + V{ } + { if { "path" 1 } } H{ } clone etag-vector = +] unit-test -[ "if28,704" ] -[ "resource:core/kernel/kernel.factor" file>lines { if 28 } etag ] unit-test +[ t ] +[ + V{ if { "path" 1 } } + { if { "path" 1 } } + { { "path" V{ if { "path" 1 } } } } >hashtable + etag-vector = +] unit-test -! [ V{ " " "resource:core/kernel/kernel.factor,22" "if28,704" "unless31,755" } ] -! [ { { "resource:core/kernel/kernel.factor" -! V{ { if 28 } -! { unless 31 } } } } etag-strings ] unit-test +! etag-pair +[ t ] +[ + { if 28 } + { if { "resource:core/kernel/kernel.factor" 28 } } etag-pair = +] unit-test +! etag-add +[ t ] +[ + H{ { "path" V{ { if 1 } } } } + { if { "path" 1 } } H{ } clone [ etag-add ] keep = +] unit-test + +! etag-hash +[ t ] +[ + H{ { "path" V{ { if 1 } } } } + { { if { "path" 1 } } } etag-hash = +] unit-test + +! line-bytes (note that for each line implicit \n is counted) +[ t ] +[ + 17 + { "1234567890" "12345" } 2 lines>bytes = +] unit-test + +! etag +[ t ] +[ + "if2,11" + { "1234567890" "12345" } { if 2 } etag = +] unit-test + +! etag-length +[ t ] +[ + 14 + V{ "if2,11" "if2,11" } etag-length = +] unit-test diff --git a/extra/ctags/etags/etags.factor b/extra/ctags/etags/etags.factor index b3ad879481..8cc8c284b1 100644 --- a/extra/ctags/etags/etags.factor +++ b/extra/ctags/etags/etags.factor @@ -31,7 +31,7 @@ IN: ctags.etags : lines>bytes ( seq n -- bytes ) head 0 [ length 1+ + ] reduce ; -: file>lines ( resource -- lines ) +: file>lines ( path -- lines ) ascii file-lines ; : etag ( lines seq -- str ) @@ -46,7 +46,7 @@ IN: ctags.etags : etag-length ( vector -- n ) 0 [ length + ] reduce ; -:
( n path -- str ) +: (etag-header) ( n path -- str ) [ % 1 CHAR: , % @@ -54,7 +54,7 @@ IN: ctags.etags ] "" make ; : etag-header ( vec1 n resource -- vec2 ) - normalize-path
prefix + normalize-path (etag-header) prefix 1 HEX: 0c prefix ; : etag-strings ( alist -- seq ) diff --git a/extra/ctags/etags/summary.txt b/extra/ctags/etags/summary.txt new file mode 100644 index 0000000000..4766e20a87 --- /dev/null +++ b/extra/ctags/etags/summary.txt @@ -0,0 +1 @@ +Etags generator From fa7ab148581a666ab99d63a6a3ca8c85dbb04496 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Sun, 13 Jul 2008 18:44:45 +0200 Subject: [PATCH 16/64] Remove wordtimer vocab, shouldn't be on this branch --- extra/wordtimer/authors.txt | 1 - extra/wordtimer/summary.txt | 1 - extra/wordtimer/wordtimer-docs.factor | 41 ------------- extra/wordtimer/wordtimer-tests.factor | 10 ---- extra/wordtimer/wordtimer.factor | 81 -------------------------- 5 files changed, 134 deletions(-) delete mode 100644 extra/wordtimer/authors.txt delete mode 100644 extra/wordtimer/summary.txt delete mode 100644 extra/wordtimer/wordtimer-docs.factor delete mode 100644 extra/wordtimer/wordtimer-tests.factor delete mode 100644 extra/wordtimer/wordtimer.factor diff --git a/extra/wordtimer/authors.txt b/extra/wordtimer/authors.txt deleted file mode 100644 index 0be42b2faa..0000000000 --- a/extra/wordtimer/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Phil Dawes diff --git a/extra/wordtimer/summary.txt b/extra/wordtimer/summary.txt deleted file mode 100644 index efe591da27..0000000000 --- a/extra/wordtimer/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Microsecond precision code timer/profiler. diff --git a/extra/wordtimer/wordtimer-docs.factor b/extra/wordtimer/wordtimer-docs.factor deleted file mode 100644 index 47b85bb007..0000000000 --- a/extra/wordtimer/wordtimer-docs.factor +++ /dev/null @@ -1,41 +0,0 @@ -USING: help.syntax help.markup kernel prettyprint sequences ; -IN: wordtimer - -HELP: reset-word-timer -{ $description "resets the global wordtimes datastructure. Must be called before calling any word-timer annotated code" -} ; - -HELP: add-timer -{ $values { "word" "a word" } } -{ $description "annotates the word with timing code which stores timing information globally. You can then view the info with print-word-timings" -} ; - -HELP: add-timers -{ $values { "vocab" "a string" } } -{ $description "annotates all the words in the vocab with timer code. After profiling you can remove the annotations with reset-vocab" -} ; - - -HELP: reset-vocab -{ $values { "vocab" "a string" } } -{ $description "removes the annotations from all the words in the vocab" -} ; - -HELP: print-word-timings -{ $description "Displays the timing information for each word-timer annotated word. Columns are: total time taken in microseconds, number of invocations, wordname" -} ; - -HELP: correct-for-timing-overhead -{ $description "attempts to correct the timings to take into account the overhead of the timing function. This is pretty error-prone but can be handy when you're timing words that only take a handful of milliseconds but are called a lot" } ; - -HELP: profile-vocab -{ $values { "vocabspec" "string name of a vocab" } - { "quot" "a quotation to run" } } -{ $description "Annotates the words in the vocab with timing code then runs the quotation. Finally resets the words and prints the timings information." -} ; - - -ARTICLE: "wordtimer" "Word Timer" -"The " { $vocab-link "wordtimer" } " vocabulary measures accumulated execution time for words. If you just want to profile the accumulated time taken by all words in a vocab you can use " { $vocab-link "profile-vocab" } ". If you need more fine grained control then do the following: First annotate individual words with the " { $link add-timer } " word or whole vocabularies with " { $link add-timers } ". Then reset the clock with " { $link reset-word-timer } " and execute your code. Finally you can view the timings with " { $link print-word-timings } ". If you have functions that are quick and called often you may want to " { $link correct-for-timing-overhead } ". To remove all the annotations in the vocab you can use " { $link reset-vocab } ". Alternatively if you just want to time the contents of a vocabulary you can use profile-vocab." ; - -ABOUT: "wordtimer" diff --git a/extra/wordtimer/wordtimer-tests.factor b/extra/wordtimer/wordtimer-tests.factor deleted file mode 100644 index 47287179ce..0000000000 --- a/extra/wordtimer/wordtimer-tests.factor +++ /dev/null @@ -1,10 +0,0 @@ -USING: tools.test wordtimer math kernel tools.annotations prettyprint ; -IN: wordtimer.tests - -: testfn ( a b c d -- a+b c+d ) - + [ + ] dip ; - -[ 3 7 ] -[ reset-word-timer - \ testfn [ reset ] [ add-timer ] bi - 1 2 3 4 testfn ] unit-test \ No newline at end of file diff --git a/extra/wordtimer/wordtimer.factor b/extra/wordtimer/wordtimer.factor deleted file mode 100644 index 5da17e28d5..0000000000 --- a/extra/wordtimer/wordtimer.factor +++ /dev/null @@ -1,81 +0,0 @@ -USING: kernel sequences namespaces math assocs words arrays tools.annotations vocabs sorting prettyprint io micros math.statistics accessors ; -IN: wordtimer - -SYMBOL: *wordtimes* -SYMBOL: *calling* - -: reset-word-timer ( -- ) - H{ } clone *wordtimes* set-global - H{ } clone *calling* set-global ; - -: lookup-word-time ( wordname -- utime n ) - *wordtimes* get-global [ drop { 0 0 } ] cache first2 ; - -: update-times ( utime current-utime current-numinvokes -- utime' invokes' ) - rot [ + ] curry [ 1+ ] bi* ; - -: register-time ( utime word -- ) - name>> - [ lookup-word-time update-times 2array ] keep *wordtimes* get-global set-at ; - -: calling ( word -- ) - dup *calling* get-global set-at ; inline - -: finished ( word -- ) - *calling* get-global delete-at ; inline - -: called-recursively? ( word -- t/f ) - *calling* get-global at ; inline - -: timed-call ( quot word -- ) - [ calling ] [ >r micro-time r> register-time ] [ finished ] tri ; inline - -: time-unless-recursing ( quot word -- ) - dup called-recursively? not - [ timed-call ] [ drop call ] if ; inline - -: (add-timer) ( word quot -- quot' ) - [ swap time-unless-recursing ] 2curry ; - -: add-timer ( word -- ) - dup [ (add-timer) ] annotate ; - -: add-timers ( vocabspec -- ) - words [ add-timer ] each ; - -: reset-vocab ( vocabspec -- ) - words [ reset ] each ; - -: dummy-word ( -- ) ; - -: time-dummy-word ( -- n ) - [ 100000 [ [ dummy-word ] micro-time , ] times ] { } make median ; - -: subtract-overhead ( {oldtime,n} overhead -- {newtime,n} ) - [ first2 ] dip - swap [ * - ] keep 2array ; - -: change-global ( variable quot -- ) - global swap change-at ; - -: (correct-for-timing-overhead) ( timingshash -- timingshash ) - time-dummy-word [ subtract-overhead ] curry assoc-map ; - -: correct-for-timing-overhead ( -- ) - *wordtimes* [ (correct-for-timing-overhead) ] change-global ; - -: print-word-timings ( -- ) - *wordtimes* get-global [ swap suffix ] { } assoc>map natural-sort reverse pprint ; - - -: profile-vocab ( vocabspec quot -- ) - "annotating vocab..." print flush - over [ reset-vocab ] [ add-timers ] bi - reset-word-timer - "executing quotation..." print flush - [ call ] micro-time >r - "resetting annotations..." print flush - reset-vocab - correct-for-timing-overhead - "total time:" write r> pprint - print-word-timings ; \ No newline at end of file From 67216b034223fe5c47b558d211cde12ae100f501 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Sun, 13 Jul 2008 18:46:49 +0200 Subject: [PATCH 17/64] Revert "Remove wordtimer vocab, shouldn't be on this branch" This reverts commit fa7ab148581a666ab99d63a6a3ca8c85dbb04496. --- extra/wordtimer/authors.txt | 1 + extra/wordtimer/summary.txt | 1 + extra/wordtimer/wordtimer-docs.factor | 41 +++++++++++++ extra/wordtimer/wordtimer-tests.factor | 10 ++++ extra/wordtimer/wordtimer.factor | 81 ++++++++++++++++++++++++++ 5 files changed, 134 insertions(+) create mode 100644 extra/wordtimer/authors.txt create mode 100644 extra/wordtimer/summary.txt create mode 100644 extra/wordtimer/wordtimer-docs.factor create mode 100644 extra/wordtimer/wordtimer-tests.factor create mode 100644 extra/wordtimer/wordtimer.factor diff --git a/extra/wordtimer/authors.txt b/extra/wordtimer/authors.txt new file mode 100644 index 0000000000..0be42b2faa --- /dev/null +++ b/extra/wordtimer/authors.txt @@ -0,0 +1 @@ +Phil Dawes diff --git a/extra/wordtimer/summary.txt b/extra/wordtimer/summary.txt new file mode 100644 index 0000000000..efe591da27 --- /dev/null +++ b/extra/wordtimer/summary.txt @@ -0,0 +1 @@ +Microsecond precision code timer/profiler. diff --git a/extra/wordtimer/wordtimer-docs.factor b/extra/wordtimer/wordtimer-docs.factor new file mode 100644 index 0000000000..47b85bb007 --- /dev/null +++ b/extra/wordtimer/wordtimer-docs.factor @@ -0,0 +1,41 @@ +USING: help.syntax help.markup kernel prettyprint sequences ; +IN: wordtimer + +HELP: reset-word-timer +{ $description "resets the global wordtimes datastructure. Must be called before calling any word-timer annotated code" +} ; + +HELP: add-timer +{ $values { "word" "a word" } } +{ $description "annotates the word with timing code which stores timing information globally. You can then view the info with print-word-timings" +} ; + +HELP: add-timers +{ $values { "vocab" "a string" } } +{ $description "annotates all the words in the vocab with timer code. After profiling you can remove the annotations with reset-vocab" +} ; + + +HELP: reset-vocab +{ $values { "vocab" "a string" } } +{ $description "removes the annotations from all the words in the vocab" +} ; + +HELP: print-word-timings +{ $description "Displays the timing information for each word-timer annotated word. Columns are: total time taken in microseconds, number of invocations, wordname" +} ; + +HELP: correct-for-timing-overhead +{ $description "attempts to correct the timings to take into account the overhead of the timing function. This is pretty error-prone but can be handy when you're timing words that only take a handful of milliseconds but are called a lot" } ; + +HELP: profile-vocab +{ $values { "vocabspec" "string name of a vocab" } + { "quot" "a quotation to run" } } +{ $description "Annotates the words in the vocab with timing code then runs the quotation. Finally resets the words and prints the timings information." +} ; + + +ARTICLE: "wordtimer" "Word Timer" +"The " { $vocab-link "wordtimer" } " vocabulary measures accumulated execution time for words. If you just want to profile the accumulated time taken by all words in a vocab you can use " { $vocab-link "profile-vocab" } ". If you need more fine grained control then do the following: First annotate individual words with the " { $link add-timer } " word or whole vocabularies with " { $link add-timers } ". Then reset the clock with " { $link reset-word-timer } " and execute your code. Finally you can view the timings with " { $link print-word-timings } ". If you have functions that are quick and called often you may want to " { $link correct-for-timing-overhead } ". To remove all the annotations in the vocab you can use " { $link reset-vocab } ". Alternatively if you just want to time the contents of a vocabulary you can use profile-vocab." ; + +ABOUT: "wordtimer" diff --git a/extra/wordtimer/wordtimer-tests.factor b/extra/wordtimer/wordtimer-tests.factor new file mode 100644 index 0000000000..47287179ce --- /dev/null +++ b/extra/wordtimer/wordtimer-tests.factor @@ -0,0 +1,10 @@ +USING: tools.test wordtimer math kernel tools.annotations prettyprint ; +IN: wordtimer.tests + +: testfn ( a b c d -- a+b c+d ) + + [ + ] dip ; + +[ 3 7 ] +[ reset-word-timer + \ testfn [ reset ] [ add-timer ] bi + 1 2 3 4 testfn ] unit-test \ No newline at end of file diff --git a/extra/wordtimer/wordtimer.factor b/extra/wordtimer/wordtimer.factor new file mode 100644 index 0000000000..5da17e28d5 --- /dev/null +++ b/extra/wordtimer/wordtimer.factor @@ -0,0 +1,81 @@ +USING: kernel sequences namespaces math assocs words arrays tools.annotations vocabs sorting prettyprint io micros math.statistics accessors ; +IN: wordtimer + +SYMBOL: *wordtimes* +SYMBOL: *calling* + +: reset-word-timer ( -- ) + H{ } clone *wordtimes* set-global + H{ } clone *calling* set-global ; + +: lookup-word-time ( wordname -- utime n ) + *wordtimes* get-global [ drop { 0 0 } ] cache first2 ; + +: update-times ( utime current-utime current-numinvokes -- utime' invokes' ) + rot [ + ] curry [ 1+ ] bi* ; + +: register-time ( utime word -- ) + name>> + [ lookup-word-time update-times 2array ] keep *wordtimes* get-global set-at ; + +: calling ( word -- ) + dup *calling* get-global set-at ; inline + +: finished ( word -- ) + *calling* get-global delete-at ; inline + +: called-recursively? ( word -- t/f ) + *calling* get-global at ; inline + +: timed-call ( quot word -- ) + [ calling ] [ >r micro-time r> register-time ] [ finished ] tri ; inline + +: time-unless-recursing ( quot word -- ) + dup called-recursively? not + [ timed-call ] [ drop call ] if ; inline + +: (add-timer) ( word quot -- quot' ) + [ swap time-unless-recursing ] 2curry ; + +: add-timer ( word -- ) + dup [ (add-timer) ] annotate ; + +: add-timers ( vocabspec -- ) + words [ add-timer ] each ; + +: reset-vocab ( vocabspec -- ) + words [ reset ] each ; + +: dummy-word ( -- ) ; + +: time-dummy-word ( -- n ) + [ 100000 [ [ dummy-word ] micro-time , ] times ] { } make median ; + +: subtract-overhead ( {oldtime,n} overhead -- {newtime,n} ) + [ first2 ] dip + swap [ * - ] keep 2array ; + +: change-global ( variable quot -- ) + global swap change-at ; + +: (correct-for-timing-overhead) ( timingshash -- timingshash ) + time-dummy-word [ subtract-overhead ] curry assoc-map ; + +: correct-for-timing-overhead ( -- ) + *wordtimes* [ (correct-for-timing-overhead) ] change-global ; + +: print-word-timings ( -- ) + *wordtimes* get-global [ swap suffix ] { } assoc>map natural-sort reverse pprint ; + + +: profile-vocab ( vocabspec quot -- ) + "annotating vocab..." print flush + over [ reset-vocab ] [ add-timers ] bi + reset-word-timer + "executing quotation..." print flush + [ call ] micro-time >r + "resetting annotations..." print flush + reset-vocab + correct-for-timing-overhead + "total time:" write r> pprint + print-word-timings ; \ No newline at end of file From fafdb39627b31800e032b1fc6e937aae14a65950 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Sun, 13 Jul 2008 19:11:46 +0200 Subject: [PATCH 18/64] Documentation code fixed --- extra/ctags/etags/etags-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/ctags/etags/etags-docs.factor b/extra/ctags/etags/etags-docs.factor index c38404740a..5bd4e10b54 100644 --- a/extra/ctags/etags/etags-docs.factor +++ b/extra/ctags/etags/etags-docs.factor @@ -34,6 +34,6 @@ HELP: etags-write ( alist path -- ) HELP: etag-strings ( alist -- seq ) { $values { "alist" sequence } { "seq" sequence } } -{ $description "Converts an " { $snippet "alist" } " with etag format (a path as key and a vector containing word/line pairs) in a " { $snippet "seq" } " of strings." } +{ $description "Converts an " { $snippet "alist" } " with etag format (a path as key and a vector containing word/line pairs) in a " { $snippet "seq" } " of strings." } ; -ABOUT: "etags" \ No newline at end of file +ABOUT: "etags" ; \ No newline at end of file From 9df1363d5bbcbdf10caae38bf162682bc924902d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Jul 2008 15:51:20 -0500 Subject: [PATCH 19/64] Convert multiplication by power of 2 into a shift --- core/alien/c-types/c-types.factor | 5 +++-- core/optimizer/math/math.factor | 15 ++++++++++++++- 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 405d679f4a..c553ca5cfb 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -151,8 +151,9 @@ M: byte-array byte-length length ; swap dup length memcpy ; : (define-nth) ( word type quot -- ) - >r heap-size [ rot * >fixnum ] swap prefix - r> append define-inline ; + [ + \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi* + ] [ ] make define-inline ; : nth-word ( name vocab -- word ) >r "-nth" append r> create ; diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index c20cba99cb..2c4e33e183 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -406,7 +406,7 @@ most-negative-fixnum most-positive-fixnum [a,b] : convert-mod-to-and ( #call -- node ) dup - dup node-in-d second node-literal 1- + dup in-d>> second node-literal 1- [ nip bitand ] curry f splice-quot ; \ mod [ @@ -438,6 +438,19 @@ most-negative-fixnum most-positive-fixnum [a,b] } } define-optimizers +: convert-*-to-shift? ( #call -- ? ) + dup in-d>> second node-literal + dup integer? [ power-of-2? ] [ drop f ] if ; + +: convert-*-to-shift ( #call -- ? ) + dup dup in-d>> second node-literal log2 + [ nip fixnum-shift-fast ] curry + f splice-quot ; + +\ fixnum*fast { + { [ dup convert-*-to-shift? ] [ convert-*-to-shift ] } +} define-optimizers + { + - * / } [ { number number } "input-classes" set-word-prop ] each From 34b0fad7046228b53a89133623c11b05b2f274fc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Jul 2008 19:50:37 -0500 Subject: [PATCH 20/64] Move firstn to generalizations, clean it up a bit --- .../generalizations-docs.factor | 19 ++++++++++++++++--- .../generalizations-tests.factor | 4 ++++ extra/generalizations/generalizations.factor | 16 +++++++++++----- extra/geo-ip/geo-ip.factor | 4 +++- extra/namespaces/lib/lib.factor | 2 +- extra/sequences/lib/lib-tests.factor | 5 ----- extra/sequences/lib/lib.factor | 5 ----- extra/usa-cities/usa-cities.factor | 2 +- 8 files changed, 36 insertions(+), 21 deletions(-) diff --git a/extra/generalizations/generalizations-docs.factor b/extra/generalizations/generalizations-docs.factor index d2af13a9c3..a702f452da 100755 --- a/extra/generalizations/generalizations-docs.factor +++ b/extra/generalizations/generalizations-docs.factor @@ -1,9 +1,21 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. USING: help.syntax help.markup kernel sequences quotations -math ; +math arrays ; IN: generalizations +HELP: narray +{ $values { "n" integer } } +{ $description "A generalization of " { $link 1array } ", " +{ $link 2array } ", " { $link 3array } " and " { $link 4array } " " +"that constructs an array from the top " { $snippet "n" } " elements of the stack." +} ; + +HELP: firstn +{ $values { "n" integer } } +{ $description "A generalization of " { $link first } ", " +{ $link first2 } ", " { $link first3 } " and " { $link first4 } " " +"that pushes the first " { $snippet "n" } " elements of a sequence on the stack." +} ; + HELP: npick { $values { "n" integer } } { $description "A generalization of " { $link dup } ", " @@ -119,6 +131,7 @@ ARTICLE: "generalizations" "Generalized shuffle words and combinators" "macros where the arity of the input quotations depends on an " "input parameter." { $subsection narray } +{ $subsection firstn } { $subsection ndup } { $subsection npick } { $subsection nrot } diff --git a/extra/generalizations/generalizations-tests.factor b/extra/generalizations/generalizations-tests.factor index af010e2026..75985c9368 100755 --- a/extra/generalizations/generalizations-tests.factor +++ b/extra/generalizations/generalizations-tests.factor @@ -32,3 +32,7 @@ IN: generalizations.tests [ [ dup 2^ 2array ] 5 napply ] must-infer [ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test + +[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test +[ ] [ { } 0 firstn ] unit-test +[ "a" ] [ { "a" } 1 firstn ] unit-test diff --git a/extra/generalizations/generalizations.factor b/extra/generalizations/generalizations.factor index 6cbb13518e..99fa8795ae 100755 --- a/extra/generalizations/generalizations.factor +++ b/extra/generalizations/generalizations.factor @@ -1,14 +1,20 @@ -! Copyright (C) 2007, 2008 Chris Double, Doug Coleman. +! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo +! Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private namespaces math math.ranges combinators macros quotations fry locals arrays ; IN: generalizations MACRO: narray ( n -- quot ) - dup [ f ] curry - swap [ - [ swap [ set-nth-unsafe ] keep ] curry - ] map concat append ; + [ ] [ '[ , f ] ] bi + [ '[ @ [ , swap set-nth-unsafe ] keep ] ] reduce ; + +MACRO: firstn ( n -- ) + dup zero? [ drop [ drop ] ] [ + [ [ '[ , _ nth-unsafe ] ] map ] + [ 1- '[ , _ bounds-check 2drop ] ] + bi prefix '[ , cleave ] + ] if ; MACRO: npick ( n -- ) 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ; diff --git a/extra/geo-ip/geo-ip.factor b/extra/geo-ip/geo-ip.factor index 62cc659394..aee53f24f5 100644 --- a/extra/geo-ip/geo-ip.factor +++ b/extra/geo-ip/geo-ip.factor @@ -1,5 +1,7 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences io.files io.launcher io.encodings.ascii -io.streams.string http.client sequences.lib combinators +io.streams.string http.client generalizations combinators math.parser math.vectors math.intervals interval-maps memoize csv accessors assocs strings math splitting grouping arrays ; IN: geo-ip diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index 9ad8978bf3..4da3935727 100755 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -2,7 +2,7 @@ ! USING: kernel quotations namespaces sequences assocs.lib ; USING: kernel namespaces namespaces.private quotations sequences - assocs.lib math.parser math sequences.lib locals mirrors ; + assocs.lib math.parser math generalizations locals mirrors ; IN: namespaces.lib diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 4b8114f67f..3744a7217a 100755 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -67,11 +67,6 @@ IN: sequences.lib.tests { 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test [ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test -[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test - -[ ] [ { } 0 firstn ] unit-test -[ "a" ] [ { "a" } 1 firstn ] unit-test - [ "empty" ] [ { } [ "not empty" ] [ "empty" ] if-seq ] unit-test [ { 1 } "not empty" ] [ { 1 } [ "not empty" ] [ "empty" ] if-seq ] unit-test diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 0049320b94..9f8e5be3d5 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -20,11 +20,6 @@ IN: sequences.lib : map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline -MACRO: firstn ( n -- ) - [ [ swap nth ] curry [ keep ] curry ] map - concat >quotation - [ drop ] compose ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : each-percent ( seq quot -- ) diff --git a/extra/usa-cities/usa-cities.factor b/extra/usa-cities/usa-cities.factor index fb392542f3..968bf9d053 100644 --- a/extra/usa-cities/usa-cities.factor +++ b/extra/usa-cities/usa-cities.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files io.encodings.ascii sequences sequences.lib +USING: io.files io.encodings.ascii sequences generalizations math.parser combinators kernel memoize csv symbols summary words accessors math.order sorting ; IN: usa-cities From cf79dc4646395e3a910bc7520a130512d7c4f50e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Jul 2008 19:55:42 -0500 Subject: [PATCH 21/64] generalizations no longer needs locals --- extra/generalizations/generalizations.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/generalizations/generalizations.factor b/extra/generalizations/generalizations.factor index 99fa8795ae..e4d5249a30 100755 --- a/extra/generalizations/generalizations.factor +++ b/extra/generalizations/generalizations.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo ! Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences sequences.private namespaces math math.ranges -combinators macros quotations fry locals arrays ; +USING: kernel sequences sequences.private namespaces math +math.ranges combinators macros quotations fry arrays ; IN: generalizations MACRO: narray ( n -- quot ) @@ -38,7 +38,7 @@ MACRO: ntuck ( n -- ) 2 + [ dupd -nrot ] curry ; MACRO: nrev ( n -- quot ) - 1 [a,b] [ '[ , -nrot ] ] map concat ; + 1 [a,b] [ ] [ '[ @ , -nrot ] ] reduce ; MACRO: ndip ( quot n -- ) dup saver -rot restorer 3append ; @@ -50,11 +50,11 @@ MACRO: nkeep ( n -- ) [ ] [ 1+ ] [ ] tri '[ [ , ndup ] dip , -nrot , nslip ] ; -MACRO: ncurry ( n -- ) [ curry ] n*quot ; +MACRO: ncurry ( n -- ) + [ curry ] n*quot ; -MACRO:: nwith ( quot n -- ) - [let | n' [ n 1+ ] | - [ n' -nrot [ n' nrot quot call ] n ncurry ] ] ; +MACRO: nwith ( n -- ) + [ with ] n*quot ; MACRO: napply ( n -- ) 2 [a,b] From e6f03f9a4eafdbc14fe13fd015116875d2919193 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Jul 2008 19:55:54 -0500 Subject: [PATCH 22/64] Documentation updates --- core/assocs/assocs-docs.factor | 5 +-- core/sequences/sequences-docs.factor | 50 ++++++++++++++++++---------- core/sequences/sequences.factor | 7 ++-- extra/math/ranges/ranges-docs.factor | 4 +-- extra/models/models-docs.factor | 7 +++- 5 files changed, 49 insertions(+), 24 deletions(-) diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 51293955d5..67bd860732 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -44,10 +44,11 @@ ARTICLE: "assocs-protocol" "Associative mapping protocol" { $subsection set-at } { $subsection delete-at } { $subsection clear-assoc } -"The following two words are optional:" +"The following three words are optional:" +{ $subsection value-at* } { $subsection new-assoc } { $subsection assoc-like } -"Assocs should also implement methods on the " { $link clone } ", " { $link equal? } " and " { $link hashcode } " generic words. Two utility words will help with the implementation of the last two:" +"Assocs should also implement methods on the " { $link clone } ", " { $link equal? } " and " { $link hashcode* } " generic words. Two utility words will help with the implementation of the last two:" { $subsection assoc= } { $subsection assoc-hashcode } "Finally, assoc classes should define a word for converting other types of assocs; conventionally, such words are named " { $snippet ">" { $emphasis "class" } } " where " { $snippet { $emphasis "class" } } " is the class name. Such a word can be implemented using a utility:" diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index f67b01e1bf..1bb7666447 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -124,16 +124,28 @@ ARTICLE: "sequences-combinators" "Sequence combinators" { $subsection each } { $subsection reduce } { $subsection interleave } -{ $subsection 2each } -{ $subsection 2reduce } "Mapping:" { $subsection map } -{ $subsection 2map } +{ $subsection map-as } { $subsection accumulate } { $subsection produce } "Filtering:" { $subsection push-if } -{ $subsection filter } ; +{ $subsection filter } +"Testing if a sequence contains elements satisfying a predicate:" +{ $subsection contains? } +{ $subsection all? } +"Testing how elements are related:" +{ $subsection monotonic? } +{ $subsection "sequence-2combinators" } ; + +ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators" +"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." +{ $subsection 2each } +{ $subsection 2reduce } +{ $subsection 2map } +{ $subsection 2map-as } +{ $subsection 2all? } ; ARTICLE: "sequences-tests" "Testing sequences" "Testing for an empty sequence:" @@ -147,12 +159,7 @@ ARTICLE: "sequences-tests" "Testing sequences" { $subsection head? } { $subsection tail? } { $subsection subseq? } -"Testing if a sequence contains elements satisfying a predicate:" -{ $subsection contains? } -{ $subsection all? } -{ $subsection 2all? } "Testing how elements are related:" -{ $subsection monotonic? } { $subsection all-eq? } { $subsection all-equal? } ; @@ -456,6 +463,15 @@ HELP: map { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } } { $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ; +HELP: map-as +{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } { "exemplar" sequence } } +{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as " { $snippet "exemplar" } "." } +{ $examples + "The following example converts a string into an array of one-element strings:" + { $example "USING: prettyprint strings sequences ;" "\"Hello\" [ 1string ] { } map-as ." "{ \"H\" \"e\" \"l\" \"l\" \"o\" }" } + "Note that " { $link map } " could not be used here, because it would create another string to hold results, and one-element strings cannot themselves be elements of strings." +} ; + HELP: change-nth { $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } } { $description "Applies the quotation to the " { $snippet "i" } "th element of the sequence, storing the result back into the sequence." } @@ -478,8 +494,7 @@ HELP: max-length HELP: 2each { $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- )" } } } -{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } -{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ; +{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ; HELP: 2reduce { $values { "seq1" sequence } @@ -488,18 +503,19 @@ HELP: 2reduce { "quot" "a quotation with stack effect " { $snippet "( prev elt1 elt2 -- next )" } } { "result" "the final result" } } -{ $description "Combines successive pairs of elements from the two sequences using a ternary operation. The first input value at each iteration except the first one is the result of the previous iteration. The first input value at the first iteration is " { $snippet "identity" } "." } -{ $notes "If one sequence is shorter than the other, then only the prefix having the length of the minimum of the two is examined." } ; +{ $description "Combines successive pairs of elements from the two sequences using a ternary operation. The first input value at each iteration except the first one is the result of the previous iteration. The first input value at the first iteration is " { $snippet "identity" } "." } ; HELP: 2map { $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } } -{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } -{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ; +{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ; + +HELP: 2map-as +{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } } +{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ; HELP: 2all? { $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- ? )" } } { "?" "a boolean" } } -{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } -{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ; +{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ; HELP: find { $values { "seq" sequence } diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index c433ce4426..11cfb975df 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -383,10 +383,13 @@ PRIVATE> : 2reduce ( seq1 seq2 identity quot -- result ) >r -rot r> 2each ; inline -: 2map ( seq1 seq2 quot -- newseq ) - pick >r (2each) over r> +: 2map-as ( seq1 seq2 quot exemplar -- newseq ) + >r (2each) over r> [ [ collect ] keep ] new-like ; inline +: 2map ( seq1 seq2 quot -- newseq ) + pick 2map-as ; inline + : 2all? ( seq1 seq2 quot -- ? ) (2each) all-integers? ; inline diff --git a/extra/math/ranges/ranges-docs.factor b/extra/math/ranges/ranges-docs.factor index a8783ee410..714fc67c9f 100644 --- a/extra/math/ranges/ranges-docs.factor +++ b/extra/math/ranges/ranges-docs.factor @@ -4,8 +4,8 @@ IN: math.ranges ARTICLE: "ranges" "Ranges" - "A " { $emphasis "range" } " is a virtual sequence with elements " - "ranging from a to b by step." + "A " { $emphasis "range" } " is a virtual sequence with real elements " + "ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "." $nl diff --git a/extra/models/models-docs.factor b/extra/models/models-docs.factor index c31ae3e733..8decf3251c 100755 --- a/extra/models/models-docs.factor +++ b/extra/models/models-docs.factor @@ -134,7 +134,12 @@ $nl "When using models which are not associated with controls (or when unit testing controls), you must activate and deactivate models manually:" { $subsection activate-model } { $subsection deactivate-model } -{ $subsection "models-impl" } ; +{ $subsection "models-impl" } +{ $subsection "models-filter" } +{ $subsection "models-compose" } +{ $subsection "models-history" } +{ $subsection "models-range" } +{ $subsection "models-delay" } ; ARTICLE: "models-impl" "Implementing models" "New types of models can be defined, for example see " { $vocab-link "models.filter" } "." From b887849eb9e8d009d3dd2b03855c8de404b9e46e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Jul 2008 20:46:41 -0500 Subject: [PATCH 23/64] Add duplicates word: finds elements which appear more than once --- core/sets/sets-docs.factor | 8 ++++++++ core/sets/sets.factor | 3 +++ 2 files changed, 11 insertions(+) diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index 57d62f6480..b3fa649dd1 100644 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -8,6 +8,7 @@ $nl { $subsection prune } "Test for duplicates:" { $subsection all-unique? } +{ $subsection duplicates } "Set operations on sequences:" { $subsection diff } { $subsection intersect } @@ -64,6 +65,13 @@ HELP: prune { $example "USING: sets prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" } } ; +HELP: duplicates +{ $values { "seq" "a sequence" } { "newseq" "a sequence" } } +{ $description "Outputs a new sequence consisting of elements which occur more than once in " { $snippet "seq" } "." } +{ $examples + { $example "USING: sets prettyprint ;" "{ 1 2 3 1 2 1 } duplicates ." "{ 1 2 1 }" } +} ; + HELP: all-unique? { $values { "seq" sequence } { "?" "a boolean" } } { $description "Tests whether a sequence contains any repeated elements." } diff --git a/core/sets/sets.factor b/core/sets/sets.factor index d825faf921..c411bfcdcd 100644 --- a/core/sets/sets.factor +++ b/core/sets/sets.factor @@ -16,6 +16,9 @@ IN: sets [ ] [ length ] [ length ] tri [ [ (prune) ] 2curry each ] keep ; +: duplicates ( seq -- newseq ) + H{ } clone [ [ key? ] [ conjoin ] 2bi ] curry filter ; + : gather ( seq quot -- newseq ) map concat prune ; inline From 817035099c13c7b2b922562a226ff8b1cf6c0ad1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Jul 2008 21:06:50 -0500 Subject: [PATCH 24/64] Fix erg's tuple definition bugs --- core/classes/tuple/parser/parser-tests.factor | 53 ++++++++++++++----- core/classes/tuple/parser/parser.factor | 25 ++++++--- core/classes/tuple/tuple-docs.factor | 4 +- core/classes/tuple/tuple-tests.factor | 12 ++--- core/classes/tuple/tuple.factor | 23 ++++---- core/debugger/debugger.factor | 6 +++ core/prettyprint/prettyprint.factor | 21 +++++++- core/slots/slots.factor | 13 +++-- core/words/words-docs.factor | 2 - 9 files changed, 110 insertions(+), 49 deletions(-) diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index d40b71b477..6f7d4af6bc 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -1,35 +1,44 @@ IN: classes.tuple.parser.tests USING: accessors classes.tuple.parser lexer words classes -sequences math kernel slots tools.test parser compiler.units ; +sequences math kernel slots tools.test parser compiler.units +arrays classes.tuple ; TUPLE: test-1 ; -[ t ] [ test-1 "slot-names" word-prop empty? ] unit-test +[ t ] [ test-1 "slots" word-prop empty? ] unit-test TUPLE: test-2 < test-1 ; -[ t ] [ test-2 "slot-names" word-prop empty? ] unit-test +[ t ] [ test-2 "slots" word-prop empty? ] unit-test [ test-1 ] [ test-2 superclass ] unit-test TUPLE: test-3 a ; -[ { "a" } ] [ test-3 "slot-names" word-prop ] unit-test +[ { "a" } ] [ test-3 "slots" word-prop [ name>> ] map ] unit-test [ object ] [ "a" test-3 "slots" word-prop slot-named class>> ] unit-test TUPLE: test-4 < test-3 b ; -[ { "b" } ] [ test-4 "slot-names" word-prop ] unit-test +[ { "b" } ] [ test-4 "slots" word-prop [ name>> ] map ] unit-test TUPLE: test-5 { a integer } ; -[ { { "a" integer } } ] [ test-5 "slot-names" word-prop ] unit-test +[ { { "a" integer } } ] +[ + test-5 "slots" word-prop + [ [ name>> ] [ class>> ] bi 2array ] map +] unit-test TUPLE: test-6 < test-5 { b integer } ; [ integer ] [ "b" test-6 "slots" word-prop slot-named class>> ] unit-test -[ { { "b" integer } } ] [ test-6 "slot-names" word-prop ] unit-test +[ { { "b" integer } } ] +[ + test-6 "slots" word-prop + [ [ name>> ] [ class>> ] bi 2array ] map +] unit-test TUPLE: test-7 { b integer initial: 3 } ; @@ -39,6 +48,8 @@ TUPLE: test-8 { b integer read-only } ; [ t ] [ "b" test-8 "slots" word-prop slot-named read-only>> ] unit-test +DEFER: foo + [ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ] [ error>> invalid-slot-name? ] must-fail-with @@ -51,17 +62,33 @@ must-fail-with [ error>> unexpected-eof? ] must-fail-with -[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ] -[ error>> no-initial-value? ] +2 [ + [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ] + [ error>> no-initial-value? ] + must-fail-with + + [ f ] [ \ foo tuple-class? ] unit-test +] times + +2 [ + [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ] + [ error>> bad-initial-value? ] + must-fail-with + + [ f ] [ \ foo tuple-class? ] unit-test +] times + +[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval ] +[ error>> duplicate-slot-names? ] must-fail-with -[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ] -[ error>> bad-initial-value? ] -must-fail-with +[ f ] [ \ foo tuple-class? ] unit-test [ ] [ [ - { test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 } + { test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 foo } [ dup class? [ forget-class ] [ drop ] if ] each ] with-compilation-unit ] unit-test + + diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index e9919ee992..ded0ca2a72 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -4,10 +4,11 @@ USING: accessors kernel sets namespaces sequences summary parser lexer combinators words classes.parser classes.tuple arrays ; IN: classes.tuple.parser +: slot-names ( slots -- seq ) + [ dup array? [ first ] when ] map ; + : shadowed-slots ( superclass slots -- shadowed ) - [ all-slots [ name>> ] map ] - [ [ dup array? [ first ] when ] map ] - bi* intersect ; + [ all-slots [ name>> ] map ] [ slot-names ] bi* intersect ; : check-slot-shadowing ( class superclass slots -- ) shadowed-slots [ @@ -20,11 +21,19 @@ IN: classes.tuple.parser ] "" make note. ] with each ; +ERROR: duplicate-slot-names names ; + +M: duplicate-slot-names summary + drop "Duplicate slot names" ; + +: check-duplicate-slots ( slots -- ) + slot-names duplicates + dup empty? [ drop ] [ duplicate-slot-names ] if ; + ERROR: invalid-slot-name name ; M: invalid-slot-name summary - drop - "Invalid slot name" ; + drop "Invalid slot name" ; : parse-long-slot-name ( -- ) [ scan , \ } parse-until % ] { } make ; @@ -38,7 +47,7 @@ M: invalid-slot-name summary #! : ... { { [ dup not ] [ unexpected-eof ] } - { [ dup { ":" "(" "<" "\"" } member? ] [ invalid-slot-name ] } + { [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] } { [ dup ";" = ] [ drop f ] } [ dup "{" = [ drop parse-long-slot-name ] when , t ] } cond ; @@ -52,4 +61,6 @@ M: invalid-slot-name summary { ";" [ tuple f ] } { "<" [ scan-word [ parse-tuple-slots ] { } make ] } [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ] - } case 3dup check-slot-shadowing ; + } case + dup check-duplicate-slots + 3dup check-slot-shadowing ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 51c175a282..0cf3091165 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -346,11 +346,9 @@ HELP: tuple $nl "Tuple classes have additional word properties:" { $list - { { $snippet "\"constructor\"" } " - a word for creating instances of this tuple class" } { { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" } { { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" } - { { $snippet "\"slot-names\"" } " - a sequence of strings naming the tuple's slots" } - { { $snippet "\"tuple-size\"" } " - the number of slots" } + { { $snippet "\"tuple-layout\"" } " - a " { $link tuple-layout } " instance" } } } ; HELP: define-tuple-predicate diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index b89abdfd82..35d4149d37 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -443,36 +443,36 @@ TUPLE: redefinition-problem-2 ; ! Hardcore unit tests USE: threads -\ thread slot-names "slot-names" set +\ thread "slots" word-prop "slots" set [ ] [ [ - \ thread tuple { "xxx" } "slot-names" get append + \ thread tuple { "xxx" } "slots" get append define-tuple-class ] with-compilation-unit [ 1337 sleep ] "Test" spawn drop [ - \ thread tuple "slot-names" get + \ thread tuple "slots" get define-tuple-class ] with-compilation-unit ] unit-test USE: vocabs -\ vocab slot-names "slot-names" set +\ vocab "slots" word-prop "slots" set [ ] [ [ - \ vocab tuple { "xxx" } "slot-names" get append + \ vocab tuple { "xxx" } "slots" get append define-tuple-class ] with-compilation-unit all-words drop [ - \ vocab tuple "slot-names" get + \ vocab tuple "slots" get define-tuple-class ] with-compilation-unit ] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index ff8d2157da..17d8e36935 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -74,9 +74,6 @@ M: tuple-class slots>tuple : >tuple ( seq -- tuple ) unclip slots>tuple ; -: slot-names ( class -- seq ) - "slot-names" word-prop ; - ERROR: bad-superclass class ; ; @@ -211,8 +207,9 @@ M: tuple-class update-class } cleave ; : define-new-tuple-class ( class superclass slots -- ) + make-slots [ drop f f tuple-class define-class ] - [ nip "slot-names" set-word-prop ] + [ nip "slots" set-word-prop ] [ 2drop update-classes ] 3tri ; @@ -236,7 +233,7 @@ M: tuple-class update-class 3bi ; : tuple-class-unchanged? ( class superclass slots -- ? ) - rot tuck [ superclass = ] [ slot-names = ] 2bi* and ; + rot tuck [ superclass = ] [ "slots" word-prop = ] 2bi* and ; : valid-superclass? ( class -- ? ) [ tuple-class? ] [ tuple eq? ] bi or ; @@ -281,7 +278,7 @@ M: tuple-class reset-class [ call-next-method ] [ { - "layout" "slots" "slot-names" "boa-check" "prototype" + "layout" "slots" "boa-check" "prototype" } reset-props ] bi ] bi ; diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 6759c43094..151ef3b6e9 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -212,6 +212,12 @@ M: not-a-tuple summary M: bad-superclass summary drop "Tuple classes can only inherit from other tuple classes" ; +M: no-initial-value summary + drop "Initial value must be provided for slots specialized to this class" ; + +M: bad-initial-value summary + drop "Incompatible initial value" ; + M: no-cond summary drop "Fall-through in cond" ; diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index f15106d78b..804895f6c4 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -277,13 +277,32 @@ M: array pprint-slot-name f \ } pprint-word block> ; +: unparse-slot ( slot-spec -- array ) + [ + dup name>> , + dup class>> object eq? [ + dup class>> , + initial: , + dup initial>> , + ] unless + dup read-only>> [ + read-only , + ] when + drop + ] { } make ; + +: pprint-slot ( slot-spec -- ) + unparse-slot + dup length 1 = [ first ] when + pprint-slot-name ; + M: tuple-class see-class* + pprint-; block> ; M: word see-class* drop ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index a5b2e4b3d8..73d674782d 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -188,9 +188,14 @@ M: array make-slot [ dup empty? not ] [ peel-off-attributes ] [ ] while drop check-initial-value ; -: make-slots ( slots base -- specs ) - over length [ + ] with map - [ [ make-slot ] dip >>offset ] 2map ; +M: slot-spec make-slot + check-initial-value ; + +: make-slots ( slots -- specs ) + [ make-slot ] map ; + +: finalize-slots ( specs base -- specs ) + over length [ + ] with map [ >>offset ] 2map ; : slot-named ( name specs -- spec/f ) - [ slot-spec-name = ] with find nip ; + [ name>> = ] with find nip ; diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 2f0d061499..5d053b3b5e 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -140,8 +140,6 @@ $nl { { $snippet "\"constructor\"" } { $link "tuple-constructors" } } - { { $snippet "\"slot-names\"" } { $link "tuples" } } - { { $snippet "\"type\"" } { $link "builtin-classes" } } { { { $snippet "\"superclass\"" } ", " { $snippet "\"predicate-definition\"" } } { $link "predicates" } } From d34d3a6f3122a0cac53cbceba1280e770cd3e272 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Jul 2008 23:26:20 -0500 Subject: [PATCH 25/64] Fix 'hashtable new' --- core/hashtables/hashtables-docs.factor | 5 ----- core/hashtables/hashtables-tests.factor | 13 +++++++++++ core/hashtables/hashtables.factor | 29 +++++++++++++------------ 3 files changed, 28 insertions(+), 19 deletions(-) diff --git a/core/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor index 3cd9ee23af..07517afdf7 100755 --- a/core/hashtables/hashtables-docs.factor +++ b/core/hashtables/hashtables-docs.factor @@ -93,11 +93,6 @@ HELP: hash-deleted+ { $description "Called to increment the deleted entry counter when an entry is removed with " { $link delete-at } } { $side-effects "hash" } ; -HELP: (set-hash) -{ $values { "value" "a value" } { "key" "a key to add" } { "hash" hashtable } { "new?" "a boolean" } } -{ $description "Stores the key/value pair into the hashtable. This word does not grow the hashtable if it exceeds capacity, therefore a hang can result. User code should use " { $link set-at } " instead, which grows the hashtable if necessary." } -{ $side-effects "hash" } ; - HELP: grow-hash { $values { "hash" hashtable } } { $description "Enlarges the capacity of a hashtable. User code does not need to call this word directly." } diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index 4e80ed1f6e..32684b92dc 100755 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -164,3 +164,16 @@ H{ } "x" set [ { "one" "two" 3 } ] [ { 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute ] unit-test + +! We want this to work +[ ] [ hashtable new "h" set ] unit-test + +[ 0 ] [ "h" get assoc-size ] unit-test + +[ f f ] [ "goo" "h" get at* ] unit-test + +[ ] [ 1 2 "h" get set-at ] unit-test + +[ 1 ] [ "h" get assoc-size ] unit-test + +[ 1 ] [ 2 "h" get at ] unit-test diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 3b794d1715..e804bb76fa 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -20,15 +20,18 @@ TUPLE: hashtable : probe ( array i -- array i ) 2 fixnum+fast over wrap ; inline -: (key@) ( key keys i -- array n ? ) +: no-key ( key array -- array n ? ) nip f f ; inline + +: (key@) ( key array i -- array n ? ) 3dup swap array-nth dup ((empty)) eq? - [ 3drop nip f f ] [ + [ 3drop no-key ] [ = [ rot drop t ] [ probe (key@) ] if ] if ; inline : key@ ( key hash -- array n ? ) - array>> 2dup hash@ (key@) ; inline + array>> dup array-capacity 0 eq? + [ no-key ] [ 2dup hash@ (key@) ] if ; inline : ( n -- array ) 1+ next-power-of-2 4 * ((empty)) ; inline @@ -63,25 +66,20 @@ TUPLE: hashtable : hash-deleted+ ( hash -- ) [ 1+ ] change-deleted drop ; inline -: (set-hash) ( value key hash -- new? ) - 2dup new-key@ - [ rot hash-count+ set-nth-pair t ] - [ rot drop set-nth-pair f ] if ; inline - : (rehash) ( hash alist -- ) - swap [ swapd (set-hash) drop ] curry assoc-each ; + swap [ swapd set-at ] curry assoc-each ; inline : hash-large? ( hash -- ? ) - [ count>> 3 fixnum*fast ] - [ array>> array-capacity ] bi > ; + [ count>> 3 fixnum*fast 1 fixnum+fast ] + [ array>> array-capacity ] bi fixnum> ; inline : hash-stale? ( hash -- ? ) - [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; + [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline : grow-hash ( hash -- ) [ dup >alist swap assoc-size 1+ ] keep [ reset-hash ] keep - swap (rehash) ; + swap (rehash) ; inline : ?grow-hash ( hash -- ) dup hash-large? [ @@ -122,7 +120,10 @@ M: hashtable assoc-size ( hash -- n ) r> (rehash) ; M: hashtable set-at ( value key hash -- ) - dup >r (set-hash) [ r> ?grow-hash ] [ r> drop ] if ; + dup ?grow-hash + 2dup new-key@ + [ rot hash-count+ set-nth-pair ] + [ rot drop set-nth-pair ] if ; : associate ( value key -- hash ) 2 [ set-at ] keep ; From 14b5e35a0ebe438953ddef14caebf9c4acbe80b1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Jul 2008 23:26:34 -0500 Subject: [PATCH 26/64] Fix inspector bug --- core/inspector/inspector.factor | 45 ++++++++++++----------- extra/ui/tools/inspector/inspector.factor | 20 +++++----- 2 files changed, 34 insertions(+), 31 deletions(-) diff --git a/core/inspector/inspector.factor b/core/inspector/inspector.factor index 0f925d1ea1..7d7af5d4fd 100755 --- a/core/inspector/inspector.factor +++ b/core/inspector/inspector.factor @@ -33,10 +33,10 @@ SYMBOL: +editable+ : write-value ( mirror key -- ) write-slot-editor ; -: describe-row ( obj key n -- ) +: describe-row ( mirror key n -- ) [ +number-rows+ get [ pprint-cell ] [ drop ] if - 2dup write-key write-value + [ write-key ] [ write-value ] 2bi ] with-row ; : summary. ( obj -- ) [ summary ] keep write-object nl ; @@ -48,21 +48,19 @@ SYMBOL: +editable+ sort-keys values ] [ keys ] if ; -: describe* ( obj flags -- ) - clone [ - dup summary. - make-mirror dup sorted-keys dup empty? [ - 2drop - ] [ - dup enum? [ +sequence+ on ] when - standard-table-style [ - dup length - rot [ -rot describe-row ] curry 2each - ] tabular-output - ] if - ] bind ; +: describe* ( obj mirror keys -- ) + rot summary. + dup empty? [ + 2drop + ] [ + dup enum? [ +sequence+ on ] when + standard-table-style [ + swap [ -rot describe-row ] curry each-index + ] tabular-output + ] if ; -: describe ( obj -- ) H{ } describe* ; +: describe ( obj -- ) + dup make-mirror dup sorted-keys describe* ; M: tuple error. describe ; @@ -78,19 +76,21 @@ M: tuple error. describe ; SYMBOL: inspector-hook -[ H{ { +number-rows+ t } } describe* ] inspector-hook set-global +[ t +number-rows+ [ describe* ] with-variable ] inspector-hook set-global SYMBOL: inspector-stack SYMBOL: me : reinspect ( obj -- ) - dup me set - dup make-mirror dup mirror set keys \ keys set - inspector-hook get call ; + [ me set ] + [ + dup make-mirror dup mirror set dup sorted-keys dup \ keys set + inspector-hook get call + ] bi ; : (inspect) ( obj -- ) - dup inspector-stack get push reinspect ; + [ inspector-stack get push ] [ reinspect ] bi ; : key@ ( n -- key ) \ keys get nth ; @@ -123,6 +123,7 @@ SYMBOL: me "&add ( value key -- ) add new slot" print "&delete ( n -- ) remove a slot" print "&rename ( key n -- ) change a slot's key" print + "&globals ( -- ) inspect global namespace" print "&help -- display this message" print nl ; @@ -133,3 +134,5 @@ SYMBOL: me : inspect ( obj -- ) inspector-stack get [ (inspect) ] [ inspector ] if ; + +: &globals ( -- ) global inspect ; diff --git a/extra/ui/tools/inspector/inspector.factor b/extra/ui/tools/inspector/inspector.factor index 4aaf31881e..1d17de7237 100644 --- a/extra/ui/tools/inspector/inspector.factor +++ b/extra/ui/tools/inspector/inspector.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: ui.tools.workspace inspector kernel ui.commands +USING: accessors ui.tools.workspace inspector kernel ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.slots ui.gadgets.tracks ui.gestures ui.gadgets.buttons namespaces ; @@ -9,8 +9,10 @@ IN: ui.tools.inspector TUPLE: inspector-gadget < track object pane ; : refresh ( inspector -- ) - dup inspector-gadget-object swap inspector-gadget-pane [ - H{ { +editable+ t } { +number-rows+ t } } describe* + [ object>> ] [ pane>> ] bi [ + +editable+ on + +number-rows+ on + describe ] with-pane ; : ( -- gadget ) @@ -20,16 +22,14 @@ TUPLE: inspector-gadget < track object pane ; g-> set-inspector-gadget-pane 1 track, ] make-gadget ; -: inspect-object ( obj inspector -- ) - [ set-inspector-gadget-object ] keep refresh ; +: inspect-object ( obj mirror keys inspector -- ) + 2nip swap >>object refresh ; \ &push H{ { +nullary+ t } { +listener+ t } } define-command \ &back H{ { +nullary+ t } { +listener+ t } } define-command -: globals ( -- ) global inspect ; - -\ globals H{ { +nullary+ t } { +listener+ t } } define-command +\ &globals H{ { +nullary+ t } { +listener+ t } } define-command : inspector-help ( -- ) "ui-inspector" help-window ; @@ -39,7 +39,7 @@ inspector-gadget "toolbar" f { { T{ update-object } refresh } { f &push } { f &back } - { f globals } + { f &globals } { T{ key-down f f "F1" } inspector-help } } define-command-map From aea935638c68a8e645a683dca1f4ed7c72350618 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Jul 2008 23:26:43 -0500 Subject: [PATCH 27/64] Fix bootstrap --- core/bootstrap/primitives.factor | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index d748e063c2..b2b6dc4e59 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -121,7 +121,7 @@ bootstrapping? on [ [ dup pair? [ first2 create ] when ] map ] map ; : define-builtin-slots ( class slots -- ) - prepare-slots 1 make-slots + prepare-slots make-slots 1 finalize-slots [ "slots" set-word-prop ] [ define-accessors ] 2bi ; : define-builtin ( symbol slotspec -- ) @@ -273,18 +273,16 @@ bi { "echelon" { "fixnum" "math" } read-only } } define-builtin -"tuple" "kernel" create { - [ { } define-builtin ] - [ { "delegate" } "slot-names" set-word-prop ] - [ define-tuple-layout ] - [ - { "delegate" } - [ drop ] [ generate-tuple-slots ] 2bi - [ "slots" set-word-prop ] - [ define-accessors ] - 2bi - ] -} cleave +"tuple" "kernel" create +[ { } define-builtin ] +[ define-tuple-layout ] +[ + { "delegate" } make-slots + [ drop ] [ finalize-tuple-slots ] 2bi + [ "slots" set-word-prop ] + [ define-accessors ] + 2bi +] tri ! Create special tombstone values "tombstone" "hashtables.private" create From 4daa358f40443514d03ffda73669978ac4dc4ede Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 13 Jul 2008 23:59:32 -0500 Subject: [PATCH 28/64] ui.tools.walker: Rewrite to remove 'g' --- extra/ui/tools/walker/walker.factor | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor index 3588b44644..e5141fb844 100755 --- a/extra/ui/tools/walker/walker.factor +++ b/extra/ui/tools/walker/walker.factor @@ -61,12 +61,11 @@ M: walker-gadget focusable-child* swap >>continuation swap >>status dup continuation>> >>traceback - [ - toolbar, - g status>> self f track, - g traceback>> 1 track, - ] make-gadget ; + dup f track-add* + dup status>> self f track-add* + dup traceback>> 1 track-add* ; + : walker-help ( -- ) "ui-walker" help-window ; \ walker-help H{ { +nullary+ t } } define-command From f48efe054070b71d85764dbfd99f2505889961c1 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 14 Jul 2008 00:06:15 -0500 Subject: [PATCH 29/64] ui.tools.browser: Refactor to not use 'g' and 'g->' --- extra/ui/tools/browser/browser.factor | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/extra/ui/tools/browser/browser.factor b/extra/ui/tools/browser/browser.factor index 421ffdbaaf..ee427625f5 100755 --- a/extra/ui/tools/browser/browser.factor +++ b/extra/ui/tools/browser/browser.factor @@ -20,13 +20,11 @@ TUPLE: browser-gadget < track pane history ; "handbook" >link >>history drop ; : ( -- gadget ) - { 0 1 } browser-gadget new-track + { 0 1 } browser-gadget new-track dup init-history - [ - toolbar, - g g-> set-browser-gadget-pane - 1 track, - ] make-gadget ; + dup f track-add* + dup >>pane + dup pane>> 1 track-add* ; M: browser-gadget call-tool* show-help ; From 4e5551759ac0f5a88ab510c6fde44be0c9aa5ca0 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 14 Jul 2008 00:39:02 -0500 Subject: [PATCH 30/64] ui.tools.traceback: rewrite --- extra/ui/tools/traceback/traceback.factor | 35 +++++++++++------------ 1 file changed, 17 insertions(+), 18 deletions(-) diff --git a/extra/ui/tools/traceback/traceback.factor b/extra/ui/tools/traceback/traceback.factor index e1743a4bc8..ffea857429 100755 --- a/extra/ui/tools/traceback/traceback.factor +++ b/extra/ui/tools/traceback/traceback.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors continuations kernel models namespaces -prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs -ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes -ui.gadgets.status-bar ui.gadgets.scrollers ui.gestures sequences -hashtables inspector ; + prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs + ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes + ui.gadgets.status-bar ui.gadgets.scrollers ui.gestures sequences + hashtables inspector ; + IN: ui.tools.traceback : ( model -- gadget ) @@ -24,20 +25,18 @@ TUPLE: traceback-gadget < track ; M: traceback-gadget pref-dim* drop { 550 600 } ; : ( model -- gadget ) - { 0 1 } traceback-gadget new-track - swap >>model - [ - g model>> - [ - [ - [ 1/2 track, ] - [ 1/2 track, ] - bi - ] { 1 0 } make-track 1/3 track, - ] - [ 2/3 track, ] bi - toolbar, - ] make-gadget ; + { 0 1 } traceback-gadget new-track + swap >>model + + dup model>> + { 1 0 } + over 1/2 track-add* + swap 1/2 track-add* + 1/3 track-add* + + dup model>> 2/3 track-add* + + dup f track-add* ; : ( model -- gadget ) [ [ continuation-name namestack. ] when* ] From 1c93ac733cc4cd25a45929ccdff52c9f8fa0bc6e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Jul 2008 00:49:09 -0500 Subject: [PATCH 31/64] Two new benchmarks --- extra/benchmark/beust1/beust1.factor | 14 ++++++++++ extra/benchmark/beust2/beust2.factor | 39 ++++++++++++++++++++++++++++ 2 files changed, 53 insertions(+) create mode 100644 extra/benchmark/beust1/beust1.factor create mode 100644 extra/benchmark/beust2/beust2.factor diff --git a/extra/benchmark/beust1/beust1.factor b/extra/benchmark/beust1/beust1.factor new file mode 100644 index 0000000000..9849ac2dbe --- /dev/null +++ b/extra/benchmark/beust1/beust1.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: math.ranges math.parser math.vectors sets sequences +kernel io ; +IN: benchmark.beust1 + +: count-numbers ( max -- n ) + 1 [a,b] [ number>string all-unique? ] count ; inline + +: beust ( -- ) + 10000000 count-numbers + number>string " unique numbers." append print ; + +MAIN: beust diff --git a/extra/benchmark/beust2/beust2.factor b/extra/benchmark/beust2/beust2.factor new file mode 100644 index 0000000000..8f794fb1c2 --- /dev/null +++ b/extra/benchmark/beust2/beust2.factor @@ -0,0 +1,39 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: math math.ranges math.parser sequences kernel io locals ; +IN: benchmark.beust2 + +:: (count-numbers) ( remaining first value used max listener -- ? ) + 10 first - [| i | + [let* | digit [ i first + ] + mask [ digit 2^ ] + value' [ i value + ] | + used mask bitand zero? [ + value max > [ t ] [ + remaining 1 <= [ + listener call f + ] [ + remaining 1- + 0 + value' 10 * + used mask bitor + max + listener + (count-numbers) + ] if + ] if + ] [ f ] if + ] + ] contains? ; inline + +:: count-numbers ( max listener -- ) + 10 [ 1+ 1 1 0 max listener (count-numbers) ] contains? drop ; + inline + +:: beust ( -- ) + [let | i! [ 0 ] | + 10000000000 [ i 1+ i! ] count-numbers + i number>string " unique numbers." append print + ] ; + +MAIN: beust From c23815fe521e76746ce789b1fbf9c768df8cb13f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Jul 2008 00:54:30 -0500 Subject: [PATCH 32/64] Attribution --- extra/benchmark/beust2/beust2.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/benchmark/beust2/beust2.factor b/extra/benchmark/beust2/beust2.factor index 8f794fb1c2..833c1fa77d 100644 --- a/extra/benchmark/beust2/beust2.factor +++ b/extra/benchmark/beust2/beust2.factor @@ -3,6 +3,8 @@ USING: math math.ranges math.parser sequences kernel io locals ; IN: benchmark.beust2 +! http://crazybob.org/BeustSequence.java.html + :: (count-numbers) ( remaining first value used max listener -- ? ) 10 first - [| i | [let* | digit [ i first + ] From 3cea135fae1b10121b152843bbc8c1aa4cc5c2fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Jul 2008 01:57:19 -0500 Subject: [PATCH 33/64] Working on PowerPC port --- core/cpu/ppc/bootstrap.factor | 308 +++++++++++++++++++++++++++------- vm/cpu-ppc.S | 14 -- 2 files changed, 251 insertions(+), 71 deletions(-) diff --git a/core/cpu/ppc/bootstrap.factor b/core/cpu/ppc/bootstrap.factor index cf380d69f1..bb6917cea1 100755 --- a/core/cpu/ppc/bootstrap.factor +++ b/core/cpu/ppc/bootstrap.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: bootstrap.image.private kernel namespaces system -cpu.ppc.assembler generator.fixup compiler.units -compiler.constants math layouts words vocabs ; +USING: bootstrap.image.private kernel kernel.private namespaces +system cpu.ppc.assembler generator.fixup compiler.units +compiler.constants math math.private layouts words words.private +vocabs slots.private ; IN: bootstrap.ppc 4 \ cell set @@ -11,9 +12,7 @@ big-endian on 4 jit-code-format set : ds-reg 14 ; -: quot-reg 3 ; -: temp-reg 6 ; -: aux-reg 11 ; +: rs-reg 15 ; : factor-area-size 4 bootstrap-cells ; @@ -24,86 +23,281 @@ big-endian on : xt-save stack-frame 2 bootstrap-cells - ; [ - ! Load word - 0 temp-reg LOAD32 - temp-reg dup 0 LWZ - ! Bump profiling counter - aux-reg temp-reg profile-count-offset LWZ - aux-reg dup 1 tag-fixnum ADDI - aux-reg temp-reg profile-count-offset STW - ! Load word->code - aux-reg temp-reg word-code-offset LWZ - ! Compute word XT - aux-reg dup compiled-header-size ADDI - ! Jump to XT - aux-reg MTCTR + 0 6 LOAD32 + 6 dup 0 LWZ + 11 6 profile-count-offset LWZ + 11 11 1 tag-fixnum ADDI + 11 6 profile-count-offset STW + 11 6 word-code-offset LWZ + 11 11 compiled-header-size ADDI + 11 MTCTR BCTR ] rc-absolute-ppc-2/2 rt-literal 1 jit-profiling jit-define [ - 0 temp-reg LOAD32 ! load XT - 0 MFLR ! load return address - 1 1 stack-frame neg ADDI ! create stack frame - temp-reg 1 xt-save STW ! save XT - stack-frame temp-reg LI ! load frame size - temp-reg 1 next-save STW ! save frame size - 0 1 lr-save stack-frame + STW ! save return address + 0 6 LOAD32 + 0 MFLR + 1 1 stack-frame SUBI + 6 1 xt-save STW + stack-frame 6 LI + 6 1 next-save STW + 0 1 lr-save stack-frame + STW ] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define [ - 0 temp-reg LOAD32 ! load literal - temp-reg dup 0 LWZ ! indirection - temp-reg ds-reg 4 STWU ! push literal + 0 6 LOAD32 + 6 dup 0 LWZ + 6 ds-reg 4 STWU ] rc-absolute-ppc-2/2 rt-literal 1 jit-push-literal jit-define [ - 0 temp-reg LOAD32 ! load primitive address - 4 1 MR ! pass stack pointer to primitive - temp-reg MTCTR ! jump to primitive + 0 6 LOAD32 + 6 ds-reg 4 STWU +] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define + +[ + 0 6 LOAD32 + 4 1 MR + 6 MTCTR BCTR ] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define -[ - 0 BL -] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define +[ 0 BL ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define -[ - 0 B -] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define +[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define : jit-call-quot ( -- ) - temp-reg quot-reg quot-xt-offset LWZ ! load quotation-xt - temp-reg MTCTR ! jump to quotation-xt + 4 3 quot-xt-offset LWZ + 4 MTCTR BCTR ; [ - 0 quot-reg LOAD32 ! point quot-reg at false branch - temp-reg ds-reg 0 LWZ ! load boolean - 0 temp-reg \ f tag-number CMPI ! compare it with f - 2 BNE ! skip next insn if its not f - quot-reg dup 4 ADDI ! point quot-reg at true branch - quot-reg dup 0 LWZ ! load the branch - ds-reg dup 4 SUBI ! pop boolean + 0 3 LOAD32 + 6 ds-reg 0 LWZ + 0 6 \ f tag-number CMPI + 2 BNE + 3 3 4 ADDI + 3 3 0 LWZ + ds-reg dup 4 SUBI jit-call-quot ] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define [ - 0 quot-reg LOAD32 ! load dispatch array - quot-reg dup 0 LWZ ! indirection - temp-reg ds-reg 0 LWZ ! load index - temp-reg dup 1 SRAWI ! turn it into an array offset - quot-reg dup temp-reg ADD ! compute quotation location - quot-reg dup array-start-offset LWZ ! load quotation - ds-reg dup 4 SUBI ! pop index + 0 3 LOAD32 + 3 3 0 LWZ + 6 ds-reg 0 LWZ + 6 6 1 SRAWI + 3 3 6 ADD + 3 3 array-start-offset LWZ + ds-reg dup 4 SUBI jit-call-quot ] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define [ - 0 1 lr-save stack-frame + LWZ ! load return address - 1 1 stack-frame ADDI ! pop stack frame - 0 MTLR ! get ready to return + 0 1 lr-save stack-frame + LWZ + 1 1 stack-frame ADDI + 0 MTLR ] f f f jit-epilog jit-define [ BLR ] f f f jit-return jit-define +! Sub-primitives + +! Quotations and words +[ + 3 ds-reg 0 LWZ + ds-reg dup 4 SUBI + jit-call-quot +] f f f \ (call) define-sub-primitive + +[ + 3 ds-reg 0 LWZ + ds-reg dup 4 SUBI + 4 3 word-xt-offset LWZ + 4 MTCTR + BCTR +] f f f \ (execute) define-sub-primitive + +! Objects +[ + 3 ds-reg 0 LWZ + 3 3 tag-mask get ANDI + 3 3 tag-bits get SLWI + 3 ds-reg 0 STW +] f f f \ tag define-sub-primitive + +[ + 3 ds-reg 0 LWZ + 4 ds-reg -4 LWZU + 3 3 1 SRAWI + 4 4 0 0 31 tag-bits get - RLWINM + 4 3 3 LWZX + 3 ds-reg 0 STW +] f f f \ slot define-sub-primitive + + +! Shufflers +[ + ds-reg dup 4 SUBI +] f f f \ drop define-sub-primitive + +[ + ds-reg dup 8 SUBI +] f f f \ 2drop define-sub-primitive + +[ + ds-reg dup 12 SUBI +] f f f \ 3drop define-sub-primitive + +[ + 3 ds-reg 0 LWZ + 3 ds-reg 4 STWU +] f f f \ dup define-sub-primitive + +[ + 3 ds-reg 0 LWZ + 4 ds-reg -4 LWZ + ds-reg dup 8 ADDI + 3 ds-reg 0 STW + 4 ds-reg -4 STW +] f f f \ 2dup define-sub-primitive + +[ + 3 ds-reg 0 LWZ + 4 ds-reg -4 LWZ + 5 ds-reg -8 LWZ + ds-reg dup 12 ADDI + 3 ds-reg 0 STW + 4 ds-reg -4 STW + 5 ds-reg -8 STW +] f f f \ 3dup define-sub-primitive + +[ + 3 ds-reg 0 LWZ + ds-reg dup 4 SUBI + 3 ds-reg 0 STW +] f f f \ nip define-sub-primitive + +[ + 3 ds-reg 0 LWZ + ds-reg dup 8 SUBI + 3 ds-reg 0 STW +] f f f \ 2nip define-sub-primitive + +[ + 3 ds-reg -4 LWZ + 3 ds-reg 4 STWU +] f f f \ over define-sub-primitive + +[ + 3 ds-reg -8 LWZ + 3 ds-reg 4 STWU +] f f f \ pick define-sub-primitive + +[ + 3 ds-reg 0 LWZ + 4 ds-reg -4 LWZ + 4 ds-reg 0 STW + 3 ds-reg 4 STWU +] f f f \ dupd define-sub-primitive + +[ + 3 ds-reg 0 LWZ + 4 ds-reg -4 LWZ + 3 ds-reg 4 STWU + 4 ds-reg -4 STW + 3 ds-reg -8 STW +] f f f \ tuck define-sub-primitive + +[ + 3 ds-reg 0 LWZ + 4 ds-reg -4 LWZ + 3 ds-reg -4 STW + 4 ds-reg 0 STW +] f f f \ swap define-sub-primitive + +[ + 3 ds-reg -4 LWZ + 4 ds-reg -8 LWZ + 3 ds-reg -8 STW + 4 ds-reg -4 STW +] f f f \ swapd define-sub-primitive + +[ + 3 ds-reg 0 LWZ + 4 ds-reg -4 LWZ + 5 ds-reg -8 LWZ + 4 ds-reg -8 STW + 3 ds-reg -4 STW + 5 ds-reg 0 STW +] f f f \ rot define-sub-primitive + +[ + 3 ds-reg 0 LWZ + 4 ds-reg -4 LWZ + 5 ds-reg -8 LWZ + 3 ds-reg -8 STW + 5 ds-reg -4 STW + 4 ds-reg 0 STW +] f f f \ -rot define-sub-primitive + +[ + 3 ds-reg 0 LWZ + ds-reg dup 4 SUBI + 3 rs-reg 4 STWU +] f f f \ >r define-sub-primitive + +[ + 3 rs-reg 0 STW + rs-reg dup 4 SUBI + 3 ds-reg 4 STWU +] f f f \ r> define-sub-primitive + +! Comparisons +: jit-compare ( insn -- ) + 0 3 LOAD32 + 3 3 0 LWZ + 4 ds-reg 0 LWZ + 5 ds-reg -4 LWZU + 5 0 4 CMP + 2 swap execute ! magic number + 3 \ f tag-number LI + 3 ds-reg 0 STW ; + +: define-jit-compare ( insn word -- ) + [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-literal 0 ] dip + define-sub-primitive ; + +\ BEQ \ eq? define-jit-compare +\ BGE \ fixnum>= define-jit-compare +\ BLE \ fixnum<= define-jit-compare +\ BGT \ fixnum> define-jit-compare +\ BLT \ fixnum< define-jit-compare + +! Math +: jit-math ( insn -- ) + 3 ds-reg 0 LWZ + 4 ds-reg -4 LWZU + [ 5 3 4 ] dip execute + 5 ds-reg 0 STW ; + +[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive + +[ \ SUBF jit-math ] f f f \ fixnum-fast define-sub-primitive + +[ \ MULLW jit-math ] f f f \ fixnum*fast define-sub-primitive + +[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive + +[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive + +[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive + +[ + 3 ds-reg 0 LWZ + 3 3 NOT + 3 3 tag-mask get XORI + 3 ds-reg 0 STW +] f f f \ fixnum-bitnot define-sub-primitive + [ "bootstrap.ppc" forget-vocab ] with-compilation-unit diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index 55c4f01df0..412e277ea6 100755 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -103,20 +103,6 @@ DEF(void,c_to_factor,(CELL quot)): EPILOGUE blr -/* We must pass the XT to the quotation in r11. */ -DEF(void,primitive_call,(void)): - lwz r3,0(r14) /* load quotation from data stack */ - subi r14,r14,4 /* pop quotation from data stack */ - JUMP_QUOT - -/* We must preserve r4 here in case we're calling a primitive */ -DEF(void,primitive_execute,(void)): - lwz r3,0(r14) /* load word from data stack */ - lwz r11,29(r3) /* load word-xt slot */ - mtctr r11 /* prepare to call XT */ - subi r14,r14,4 /* pop word from data stack */ - bctr /* go */ - /* We pass a function pointer to memcpy in r6 to work around a Mac OS X ABI limitation which would otherwise require us to do a bizzaro PC-relative trampoline to retrieve the function address */ From 6ab000cc527c1cc01c772c4b4e95e77597588242 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Jul 2008 03:06:20 -0500 Subject: [PATCH 34/64] Updating PowerPC backend --- core/cpu/ppc/bootstrap.factor | 15 ++++++++++----- core/cpu/ppc/intrinsics/intrinsics.factor | 19 +++++++++---------- 2 files changed, 19 insertions(+), 15 deletions(-) diff --git a/core/cpu/ppc/bootstrap.factor b/core/cpu/ppc/bootstrap.factor index bb6917cea1..705ddac06d 100755 --- a/core/cpu/ppc/bootstrap.factor +++ b/core/cpu/ppc/bootstrap.factor @@ -135,7 +135,6 @@ big-endian on 3 ds-reg 0 STW ] f f f \ slot define-sub-primitive - ! Shufflers [ ds-reg dup 4 SUBI @@ -248,7 +247,7 @@ big-endian on ] f f f \ >r define-sub-primitive [ - 3 rs-reg 0 STW + 3 rs-reg 0 LWZ rs-reg dup 4 SUBI 3 ds-reg 4 STWU ] f f f \ r> define-sub-primitive @@ -261,11 +260,11 @@ big-endian on 5 ds-reg -4 LWZU 5 0 4 CMP 2 swap execute ! magic number - 3 \ f tag-number LI + \ f tag-number 3 LI 3 ds-reg 0 STW ; : define-jit-compare ( insn word -- ) - [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-literal 0 ] dip + [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-literal 1 ] dip define-sub-primitive ; \ BEQ \ eq? define-jit-compare @@ -285,7 +284,13 @@ big-endian on [ \ SUBF jit-math ] f f f \ fixnum-fast define-sub-primitive -[ \ MULLW jit-math ] f f f \ fixnum*fast define-sub-primitive +[ + 3 ds-reg 0 LWZ + 4 ds-reg -4 LWZU + 4 4 tag-bits get SRAWI + 5 3 4 MULLW + 5 ds-reg 0 STW +] f f f \ fixnum*fast define-sub-primitive [ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 5a39cbca71..4e1c3512af 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -1,14 +1,13 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.accessors alien.c-types arrays cpu.ppc.assembler -cpu.ppc.architecture cpu.ppc.allot cpu.architecture kernel -kernel.private math math.private namespaces sequences words -generic quotations byte-arrays hashtables hashtables.private -generator generator.registers generator.fixup sequences.private -sbufs vectors system layouts math.floats.private -classes classes.tuple classes.tuple.private sbufs.private -vectors.private strings.private slots.private combinators -compiler.constants ; +USING: accessors alien alien.accessors alien.c-types arrays +cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot +cpu.architecture kernel kernel.private math math.private +namespaces sequences words generic quotations byte-arrays +hashtables hashtables.private generator generator.registers +generator.fixup sequences.private sbufs vectors system layouts +math.floats.private classes slots.private combinators +compiler.constants optimizer.allot ; IN: cpu.ppc.intrinsics : %slot-literal-known-tag @@ -445,7 +444,7 @@ IN: cpu.ppc.intrinsics ! Store tagged ptr in reg "tuple" get tuple %store-tagged ] H{ - { +input+ { { [ tuple-layout? ] "layout" } } } + { +input+ { { [ ] "layout" } } } { +scratch+ { { f "tuple" } } } { +output+ { "tuple" } } } define-intrinsic From bfa89708ae274c8ea6c5810d72085abc9427141d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Jul 2008 03:18:24 -0500 Subject: [PATCH 35/64] Workaround optimizer limitation exposed by new optimizer.allot rewrites --- core/optimizer/allot/allot.factor | 18 +++++++++++------- core/optimizer/optimizer-tests.factor | 7 +++++++ 2 files changed, 18 insertions(+), 7 deletions(-) diff --git a/core/optimizer/allot/allot.factor b/core/optimizer/allot/allot.factor index d89e3c5f84..6eae3248c2 100644 --- a/core/optimizer/allot/allot.factor +++ b/core/optimizer/allot/allot.factor @@ -36,11 +36,13 @@ IN: optimizer.allot } define-optimizers : tuple-boa-quot ( layout -- quot ) - [ (tuple) ] - swap size>> 1 - [ 3 + ] map - [ [ set-slot ] curry [ keep ] curry ] map concat - [ f over 2 set-slot ] - 3append ; + [ + dup , + [ nip (tuple) ] % + size>> 1 - [ 3 + ] map + [ [ set-slot ] curry [ keep ] curry % ] each + [ f over 2 set-slot ] % + ] [ ] make ; : expand-tuple-boa ( #call -- node ) dup in-d>> peek value-literal tuple-boa-quot f splice-quot ; @@ -56,7 +58,8 @@ IN: optimizer.allot : -quot ( n -- quot ) [ - [ swap (array) ] % + dup , + [ nip (array) ] % [ \ 2dup , , [ swap set-array-nth ] % ] each \ nip , ] [ ] make ; @@ -80,7 +83,8 @@ IN: optimizer.allot : -quot ( n -- quot ) [ - \ (byte-array) , + dup , + [ nip (byte-array) ] % bytes>cells [ cell * ] map [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each ] [ ] make ; diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 0a3439c65c..ab808d7914 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -384,3 +384,10 @@ PREDICATE: list < improper-list [ 1 [ "hi" + drop ] compile-call ] must-fail [ "hi" f [ drop ] compile-call ] must-fail + +TUPLE: some-tuple x ; + +: allot-regression ( a -- b ) + [ ] curry some-tuple boa ; + +[ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test From 556ab7324686d79f53b0e84c9c140d8244fe99d3 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 14 Jul 2008 01:30:33 -0700 Subject: [PATCH 36/64] Tuple array streamlining --- extra/tuple-arrays/tuple-arrays-docs.factor | 12 +++++++---- extra/tuple-arrays/tuple-arrays-tests.factor | 10 +++++++--- extra/tuple-arrays/tuple-arrays.factor | 21 ++++++++++---------- 3 files changed, 25 insertions(+), 18 deletions(-) diff --git a/extra/tuple-arrays/tuple-arrays-docs.factor b/extra/tuple-arrays/tuple-arrays-docs.factor index d0c86986fd..18f5547e7f 100644 --- a/extra/tuple-arrays/tuple-arrays-docs.factor +++ b/extra/tuple-arrays/tuple-arrays-docs.factor @@ -1,9 +1,13 @@ -USING: help.syntax help.markup splitting kernel ; +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 } ". 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.." } ; +{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link } ". 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: -{ $values { "example" tuple } { "length" "a non-negative integer" } { "tuple-array" tuple-array } } -{ $description "Creates an instance of the " { $link } " class with the given length and containing the given tuple class. The tuple class is specified in the form of an example tuple. If the example tuple has a delegate, the tuple array will store a delegate for each element. Otherwise, the delegate will be assumed to be " { $link f } "." } ; +{ $values { "class" "a tuple class" } { "length" "a non-negative integer" } { "tuple-array" tuple-array } } +{ $description "Creates an instance of the " { $link } " 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." } ; diff --git a/extra/tuple-arrays/tuple-arrays-tests.factor b/extra/tuple-arrays/tuple-arrays-tests.factor index 132a11f4a6..4c288b1c9e 100755 --- a/extra/tuple-arrays/tuple-arrays-tests.factor +++ b/extra/tuple-arrays/tuple-arrays-tests.factor @@ -1,16 +1,20 @@ -USING: tuple-arrays sequences tools.test namespaces kernel math ; +USING: tuple-arrays sequences tools.test namespaces kernel math accessors ; IN: tuple-arrays.tests SYMBOL: mat TUPLE: foo bar ; C: foo -[ 2 ] [ 2 T{ foo } dup mat set length ] unit-test +[ 2 ] [ 2 foo dup mat set length ] unit-test [ T{ foo } ] [ mat get first ] unit-test [ T{ foo 2 1 } ] [ T{ foo 2 1 } 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{ foo f 3 } t ] [ mat get [ foo-bar 2 + ] map [ first ] keep tuple-array? ] unit-test -[ 2 ] [ 2 T{ foo t } dup mat set length ] unit-test +[ 2 ] [ 2 foo dup mat set length ] unit-test [ T{ foo } ] [ mat get first ] unit-test [ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test + +TUPLE: baz { bing integer } bong ; +[ 0 ] [ 1 baz first bing>> ] unit-test +[ f ] [ 1 baz first bong>> ] unit-test diff --git a/extra/tuple-arrays/tuple-arrays.factor b/extra/tuple-arrays/tuple-arrays.factor index 63e7541c95..5da7085773 100644 --- a/extra/tuple-arrays/tuple-arrays.factor +++ b/extra/tuple-arrays/tuple-arrays.factor @@ -4,27 +4,26 @@ USING: splitting grouping classes.tuple classes math kernel sequences arrays accessors ; IN: tuple-arrays -TUPLE: tuple-array seq class ; +TUPLE: tuple-array { seq read-only } { class read-only } ; -: ( length example -- tuple-array ) - [ tuple>array length 1- [ * { } new-sequence ] keep ] - [ class ] bi tuple-array boa ; +: ( length class -- tuple-array ) + [ + new tuple>array 1 tail + [ concat ] [ length ] bi + ] [ ] bi tuple-array boa ; M: tuple-array nth [ seq>> nth ] [ class>> ] bi prefix >tuple ; -: deconstruct ( tuple -- seq ) - tuple>array 1 tail ; - M: tuple-array set-nth ( elt n seq -- ) - >r >r deconstruct r> r> seq>> set-nth ; + >r >r tuple>array 1 tail r> r> seq>> set-nth ; M: tuple-array new-sequence - class>> new ; + class>> ; -: >tuple-array ( seq -- tuple-array/seq ) +: >tuple-array ( seq -- tuple-array ) dup empty? [ - 0 over first clone-like + 0 over first class clone-like ] unless ; M: tuple-array like From 6034e27d781603c39c900b6d30e26b42b0e17c99 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 14 Jul 2008 01:33:13 -0700 Subject: [PATCH 37/64] Removed superfluous mixin in heaps --- core/heaps/heaps.factor | 19 +++++++------------ 1 file changed, 7 insertions(+), 12 deletions(-) diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index fe1fc4e172..1873db67b5 100755 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -5,8 +5,6 @@ USING: kernel math sequences arrays assocs sequences.private growable accessors math.order ; IN: heaps -MIXIN: priority-queue - GENERIC: heap-push* ( value key heap -- entry ) GENERIC: heap-peek ( heap -- value key ) GENERIC: heap-pop* ( heap -- ) @@ -36,13 +34,10 @@ TUPLE: max-heap < heap ; : ( -- max-heap ) max-heap ; -INSTANCE: min-heap priority-queue -INSTANCE: max-heap priority-queue - -M: priority-queue heap-empty? ( heap -- ? ) +M: heap heap-empty? ( heap -- ? ) data>> empty? ; -M: priority-queue heap-size ( heap -- n ) +M: heap heap-size ( heap -- n ) data>> length ; -M: priority-queue heap-push* ( value key heap -- entry ) +M: heap heap-push* ( value key heap -- entry ) [ dup ] keep [ data-push ] keep up-heap ; : heap-push ( value key heap -- ) heap-push* drop ; @@ -163,7 +158,7 @@ M: priority-queue heap-push* ( value key heap -- entry ) : >entry< ( entry -- key value ) [ value>> ] [ key>> ] bi ; -M: priority-queue heap-peek ( heap -- value key ) +M: heap heap-peek ( heap -- value key ) data-first >entry< ; : entry>index ( entry heap -- n ) @@ -172,7 +167,7 @@ M: priority-queue heap-peek ( heap -- value key ) ] unless entry-index ; -M: priority-queue heap-delete ( entry heap -- ) +M: heap heap-delete ( entry heap -- ) [ entry>index ] keep 2dup heap-size 1- = [ nip data-pop* @@ -182,10 +177,10 @@ M: priority-queue heap-delete ( entry heap -- ) down-heap ] if ; -M: priority-queue heap-pop* ( heap -- ) +M: heap heap-pop* ( heap -- ) dup data-first swap heap-delete ; -M: priority-queue heap-pop ( heap -- value key ) +M: heap heap-pop ( heap -- value key ) dup data-first [ swap heap-delete ] keep >entry< ; : heap-pop-all ( heap -- alist ) From a135e13540b20c5059ed3c0b04afb7999a3d1de8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Jul 2008 04:38:10 -0500 Subject: [PATCH 38/64] Fix --- core/optimizer/allot/allot.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/optimizer/allot/allot.factor b/core/optimizer/allot/allot.factor index 6eae3248c2..eff2eafc9b 100644 --- a/core/optimizer/allot/allot.factor +++ b/core/optimizer/allot/allot.factor @@ -59,9 +59,9 @@ IN: optimizer.allot : -quot ( n -- quot ) [ dup , - [ nip (array) ] % + [ (array) ] % [ \ 2dup , , [ swap set-array-nth ] % ] each - \ nip , + \ 2nip , ] [ ] make ; : literal-? ( #call -- ? ) From db0b180498157c07847d8ff8e69bacc8f57923cc Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Mon, 14 Jul 2008 14:53:56 +0200 Subject: [PATCH 39/64] Fix errors in new tests --- extra/ctags/ctags-tests.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/ctags/ctags-tests.factor b/extra/ctags/ctags-tests.factor index 700b897657..c54fe99217 100644 --- a/extra/ctags/ctags-tests.factor +++ b/extra/ctags/ctags-tests.factor @@ -3,17 +3,17 @@ IN: ctags.tests [ t ] [ 91 - { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-lineno = + { if { "resource:extra/unix/unix.factor" 91 } } ctag-lineno = ] unit-test [ t ] [ "resource:extra/unix/unix.factor" - { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-path = + { if { "resource:extra/unix/unix.factor" 91 } } ctag-path = ] unit-test [ t ] [ - if - { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-word = + \ if + { if { "resource:extra/unix/unix.factor" 91 } } ctag-word = ] unit-test [ t ] [ From 880070fede1f38c7b71b7a2e3ac10349f378e014 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 14 Jul 2008 13:28:44 -0500 Subject: [PATCH 40/64] color-picker: fix using --- extra/color-picker/color-picker.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index b5938a7ad7..c786f77e85 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.functions math.parser models -models.filter models.range models.compose sequences ui -ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs -ui.gadgets.sliders ui.render math.geometry.rect ; + models.filter models.range models.compose sequences ui + ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs + ui.gadgets.sliders ui.render math.geometry.rect accessors ; IN: color-picker ! Simple example demonstrating the use of models. From 54fc3316faf1c12665e9841c0b867f08948df9d6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Jul 2008 13:37:24 -0500 Subject: [PATCH 41/64] Fix delegate for slot property change, declarations and inheritance --- extra/benchmark/fannkuch/fannkuch.factor | 1 + extra/delegate/delegate-tests.factor | 12 ++++++++++++ extra/delegate/delegate.factor | 10 ++++++---- 3 files changed, 19 insertions(+), 4 deletions(-) create mode 100644 extra/benchmark/fannkuch/fannkuch.factor diff --git a/extra/benchmark/fannkuch/fannkuch.factor b/extra/benchmark/fannkuch/fannkuch.factor new file mode 100644 index 0000000000..8b13789179 --- /dev/null +++ b/extra/benchmark/fannkuch/fannkuch.factor @@ -0,0 +1 @@ + diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor index ab0ea988ea..bc173ab0c8 100755 --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -79,3 +79,15 @@ CONSULT: beta hey value>> 1- ; [ -1 ] [ 1 four ] unit-test [ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test [ f ] [ hey \ one method ] unit-test + +TUPLE: slot-protocol-test-1 a b ; +TUPLE: slot-protocol-test-2 < slot-protocol-test-1 { c integer } ; + +TUPLE: slot-protocol-test-3 d ; + +CONSULT: slot-protocol-test-2 slot-protocol-test-3 d>> ; + +[ "a" "b" 5 ] [ + T{ slot-protocol-test-3 f T{ slot-protocol-test-2 f "a" "b" 5 } } + [ a>> ] [ b>> ] [ c>> ] tri +] unit-test diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 6cea58058e..fd9b9977e1 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Daniel Ehrenberg +! Copyright (C) 2007, 2008 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: accessors parser generic kernel classes classes.tuple words slots assocs sequences arrays vectors definitions @@ -14,9 +14,11 @@ IN: delegate GENERIC: group-words ( group -- words ) M: tuple-class group-words - "slot-names" word-prop [ - [ reader-word ] [ writer-word ] bi - 2array [ 0 2array ] map + all-slots [ + name>> + [ reader-word 0 2array ] + [ writer-word 0 2array ] bi + 2array ] map concat ; ! Consultation From 2b45f45feb79ba22e8e12083fffbf34a0bf3b8fb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Jul 2008 13:37:37 -0500 Subject: [PATCH 42/64] Oops --- extra/benchmark/fannkuch/fannkuch.factor | 1 - 1 file changed, 1 deletion(-) delete mode 100644 extra/benchmark/fannkuch/fannkuch.factor diff --git a/extra/benchmark/fannkuch/fannkuch.factor b/extra/benchmark/fannkuch/fannkuch.factor deleted file mode 100644 index 8b13789179..0000000000 --- a/extra/benchmark/fannkuch/fannkuch.factor +++ /dev/null @@ -1 +0,0 @@ - From 50e1c47dec1a68387ad945dda34e8ca073eabdf3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 14 Jul 2008 15:11:58 -0500 Subject: [PATCH 43/64] ui.gadgets.packs.tests: fix test --- extra/ui/gadgets/packs/packs-tests.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/extra/ui/gadgets/packs/packs-tests.factor b/extra/ui/gadgets/packs/packs-tests.factor index 4ae84f83df..065267d7be 100644 --- a/extra/ui/gadgets/packs/packs-tests.factor +++ b/extra/ui/gadgets/packs/packs-tests.factor @@ -5,10 +5,8 @@ kernel namespaces tools.test math.parser sequences math.geometry.rect ; [ t ] [ { 0 0 } { 100 100 } clip set - [ - 100 [ number>string