From 7bbcb569d403a44de2c99d061f873e1ea5dd3c41 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 12 Mar 2009 17:01:44 -0500
Subject: [PATCH 01/20] fix find-in-directories and add unit tests
---
basis/io/directories/search/search-tests.factor | 10 ++++++++++
basis/io/directories/search/search.factor | 4 ++--
2 files changed, 12 insertions(+), 2 deletions(-)
diff --git a/basis/io/directories/search/search-tests.factor b/basis/io/directories/search/search-tests.factor
index ba1b9cdbe1..5281ca9c2b 100644
--- a/basis/io/directories/search/search-tests.factor
+++ b/basis/io/directories/search/search-tests.factor
@@ -8,3 +8,13 @@ IN: io.directories.search.tests
current-temporary-directory get [ ] find-all-files
] with-unique-directory drop [ natural-sort ] bi@ =
] unit-test
+
+[ f ] [
+ { "omg you shoudnt have a directory called this" "or this" }
+ t
+ [ "asdfasdfasdfasdfasdf" tail? ] find-in-directories
+] unit-test
+
+[ f ] [
+ { } t [ "asdfasdfasdfasdfasdf" tail? ] find-in-directories
+] unit-test
diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor
index ee8fd129a7..a3db10ffff 100755
--- a/basis/io/directories/search/search.factor
+++ b/basis/io/directories/search/search.factor
@@ -61,8 +61,8 @@ PRIVATE>
ERROR: file-not-found ;
: find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path'/f )
- [
- '[ _ _ find-file [ file-not-found ] unless* ] attempt-all
+ '[
+ _ [ _ _ find-file [ file-not-found ] unless* ] attempt-all
] [
drop f
] recover ;
From 4fdb5d05576c326b13f3a189fdfc7348573505bf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Mar 2009 17:30:24 -0500
Subject: [PATCH 02/20] Fix infinite fixed point iteration bug found by
littledan; generalize-counter-interval wasn't called in all the right places
---
.../tree/propagation/info/info.factor | 2 +-
.../tree/propagation/propagation-tests.factor | 33 +++++++++++++++++++
.../propagation/recursive/recursive.factor | 11 +++++--
3 files changed, 42 insertions(+), 4 deletions(-)
diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index 7b1723620b..c56db570b2 100644
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@@ -238,7 +238,7 @@ DEFER: (value-info-union)
: value-infos-union ( infos -- info )
[ null-info ]
- [ dup first [ value-info-union ] reduce ] if-empty ;
+ [ unclip-slice [ value-info-union ] reduce ] if-empty ;
: literals<= ( info1 info2 -- ? )
{
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 52ae83eb12..5dd647ae89 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -655,3 +655,36 @@ MIXIN: empty-mixin
! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
+
+! generalize-counter-interval wasn't being called in all the right places.
+! bug found by littledan
+
+TUPLE: littledan-1 { a read-only } ;
+
+: (littledan-1-test) ( a -- ) a>> 1+ littledan-1 boa (littledan-1-test) ; inline recursive
+
+: littledan-1-test ( -- ) 0 littledan-1 boa (littledan-1-test) ; inline
+
+[ ] [ [ littledan-1-test ] final-classes drop ] unit-test
+
+TUPLE: littledan-2 { from read-only } { to read-only } ;
+
+: (littledan-2-test) ( x -- i elt )
+ [ from>> ] [ to>> ] bi + dup littledan-2 boa (littledan-2-test) ; inline recursive
+
+: littledan-2-test ( x -- i elt )
+ [ 0 ] dip { array-capacity } declare littledan-2 boa (littledan-2-test) ; inline
+
+[ ] [ [ littledan-2-test ] final-classes drop ] unit-test
+
+: (littledan-3-test) ( x -- )
+ length 1+ f <array> (littledan-3-test) ; inline recursive
+
+: littledan-3-test ( x -- )
+ 0 f <array> (littledan-3-test) ; inline
+
+[ ] [ [ littledan-3-test ] final-classes drop ] unit-test
+
+[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
+
+[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor
index ff9f262d28..1bcd36f6b0 100644
--- a/basis/compiler/tree/propagation/recursive/recursive.factor
+++ b/basis/compiler/tree/propagation/recursive/recursive.factor
@@ -34,9 +34,14 @@ IN: compiler.tree.propagation.recursive
} cond interval-union nip ;
: generalize-counter ( info' initial -- info )
- 2dup [ class>> null-class? ] either? [ drop ] [
- [ drop clone ] [ [ interval>> ] bi@ ] 2bi
- generalize-counter-interval >>interval
+ 2dup [ not ] either? [ drop ] [
+ 2dup [ class>> null-class? ] either? [ drop ] [
+ [ clone ] dip
+ [ [ drop ] [ [ interval>> ] bi@ generalize-counter-interval ] 2bi >>interval ]
+ [ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ]
+ [ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ]
+ tri
+ ] if
] if ;
: unify-recursive-stacks ( stacks initial -- infos )
From 80e719ba5bf3746ce505e616432f4823256d6bb5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Mar 2009 17:30:33 -0500
Subject: [PATCH 03/20] Remove stupid commented out code
---
basis/compiler/tree/finalization/finalization.factor | 3 ---
1 file changed, 3 deletions(-)
diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor
index ecd5429baf..0e72deb6fa 100644
--- a/basis/compiler/tree/finalization/finalization.factor
+++ b/basis/compiler/tree/finalization/finalization.factor
@@ -46,9 +46,6 @@ M: predicate finalize-word
[ drop ]
} cond ;
-! M: math-partial finalize-word
-! dup primitive? [ drop ] [ nip cached-expansion ] if ;
-
M: word finalize-word drop ;
M: #call finalize*
From 2f85a1a9ebf418c596c017d3d9ca5074b3b59732 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Mar 2009 17:30:41 -0500
Subject: [PATCH 04/20] Don't report inference warnings for inline words
---
basis/compiler/compiler.factor | 21 ++++++++++++---------
1 file changed, 12 insertions(+), 9 deletions(-)
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index d6da95408d..24ce3debeb 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -1,15 +1,14 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io words fry
-continuations vocabs assocs dlists definitions math graphs
-generic combinators deques search-deques io stack-checker
-stack-checker.state stack-checker.inlining
-combinators.short-circuit compiler.errors compiler.units
-compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.builder compiler.cfg.optimizer
+continuations vocabs assocs dlists definitions math graphs generic
+combinators deques search-deques macros io stack-checker
+stack-checker.state stack-checker.inlining combinators.short-circuit
+compiler.errors compiler.units compiler.tree.builder
+compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.linear-scan compiler.cfg.stack-frame
-compiler.codegen compiler.utilities ;
+compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
+compiler.utilities ;
IN: compiler
SYMBOL: compile-queue
@@ -50,8 +49,12 @@ SYMBOLS: +optimized+ +unoptimized+ ;
H{ } clone generic-dependencies set
f swap compiler-error ;
+: ignore-error? ( word error -- ? )
+ [ [ inline? ] [ macro? ] bi or ]
+ [ compiler-error-type +warning+ eq? ] bi* and ;
+
: fail ( word error -- * )
- [ swap compiler-error ]
+ [ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
[
drop
[ compiled-unxref ]
From 7cefd48884df79a0a1eeecd054b23d7dd8fb632a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Mar 2009 17:48:46 -0500
Subject: [PATCH 05/20] Tweak pane layout for better baseline alignment
---
basis/ui/gadgets/panes/panes.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor
index bf166f993a..28dc7e3ead 100644
--- a/basis/ui/gadgets/panes/panes.factor
+++ b/basis/ui/gadgets/panes/panes.factor
@@ -66,7 +66,7 @@ M: pane gadget-selection ( pane -- string/f )
selection-color >>selection-color ; inline
: init-last-line ( pane -- pane )
- horizontal <track>
+ horizontal <track> 0 >>fill +baseline+ >>align
[ >>last-line ] [ 1 track-add ] bi
dup prepare-last-line ; inline
From a6b57c495fa2c9c1458308f82f14b7608cd9d43a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Mar 2009 20:37:26 -0500
Subject: [PATCH 06/20] Fix check-slice
---
core/sequences/sequences-tests.factor | 4 ++++
core/sequences/sequences.factor | 5 +++--
2 files changed, 7 insertions(+), 2 deletions(-)
diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor
index dbbf49ef36..da495f410f 100644
--- a/core/sequences/sequences-tests.factor
+++ b/core/sequences/sequences-tests.factor
@@ -13,6 +13,10 @@ IN: sequences.tests
[ V{ 4 5 } ] [ { 1 2 3 4 5 } 2 tail-slice* >vector ] unit-test
[ V{ 3 4 } ] [ 2 4 1 10 dup <slice> subseq >vector ] unit-test
[ V{ 3 4 } ] [ 0 2 2 4 1 10 dup <slice> <slice> subseq >vector ] unit-test
+[ 0 10 "hello" <slice> ] must-fail
+[ -10 3 "hello" <slice> ] must-fail
+[ 2 1 "hello" <slice> ] must-fail
+
[ "cba" ] [ "abcdef" 3 head-slice reverse ] unit-test
[ 5040 ] [ [ 1 2 3 4 5 6 7 ] 1 [ * ] reduce ] unit-test
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index c5ff787768..144b417f04 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -221,8 +221,9 @@ TUPLE: slice-error from to seq reason ;
: check-slice ( from to seq -- from to seq )
3dup
[ 2drop 0 < "start < 0" slice-error ]
- [ nip length > "end > sequence" slice-error ]
- [ drop > "start > end" slice-error ] 3tri ; inline
+ [ [ drop ] 2dip length > "end > sequence" slice-error ]
+ [ drop > "start > end" slice-error ]
+ 3tri ; inline
: <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when
From 91e51f038ced93a739b752cb34fdfc72e0a1dc2b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Mar 2009 20:43:44 -0500
Subject: [PATCH 07/20] Slightly faster binary-search
---
basis/binary-search/binary-search.factor | 11 ++++++++---
1 file changed, 8 insertions(+), 3 deletions(-)
diff --git a/basis/binary-search/binary-search.factor b/basis/binary-search/binary-search.factor
index f29e05c023..aba3cfbfe5 100644
--- a/basis/binary-search/binary-search.factor
+++ b/basis/binary-search/binary-search.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private accessors math
math.order combinators hints arrays ;
@@ -16,14 +16,19 @@ IN: binary-search
[ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
[ drop ] [ dup ] [ ] tri* nth ; inline
+DEFER: (search)
+
+: keep-searching ( seq quot -- slice )
+ [ dup midpoint@ ] dip call collapse-slice slice boa (search) ; inline
+
: (search) ( quot: ( elt -- <=> ) seq -- i elt )
dup length 1 <= [
finish
] [
decide {
{ +eq+ [ finish ] }
- { +lt+ [ dup midpoint@ head-slice (search) ] }
- { +gt+ [ dup midpoint@ tail-slice (search) ] }
+ { +lt+ [ [ (head) ] keep-searching ] }
+ { +gt+ [ [ (tail) ] keep-searching ] }
} case
] if ; inline recursive
From 06e8468c40d3388f0abedeaea5236d8a229babdd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Mar 2009 20:48:22 -0500
Subject: [PATCH 08/20] Document alien.destructors
---
basis/alien/c-types/c-types-docs.factor | 4 +++
.../alien/destructors/destructors-docs.factor | 30 +++++++++++++++++++
2 files changed, 34 insertions(+)
create mode 100644 basis/alien/destructors/destructors-docs.factor
diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor
index dc29ea9bb3..46afc05e2d 100644
--- a/basis/alien/c-types/c-types-docs.factor
+++ b/basis/alien/c-types/c-types-docs.factor
@@ -217,6 +217,8 @@ $nl
"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
{ $subsection &free }
{ $subsection |free }
+"The " { $link &free } " and " { $link |free } " words are generated using " { $link "alien.destructors" } "."
+$nl
"You can unsafely copy a range of bytes from one memory location to another:"
{ $subsection memcpy }
"You can copy a range of bytes from memory into a byte array:"
@@ -243,4 +245,6 @@ $nl
"New C types can be defined:"
{ $subsection "c-structs" }
{ $subsection "c-unions" }
+"A utility for defining " { $link "destructors" } " for deallocating memory:"
+{ $subsection "alien.destructors" }
{ $see-also "aliens" } ;
diff --git a/basis/alien/destructors/destructors-docs.factor b/basis/alien/destructors/destructors-docs.factor
new file mode 100644
index 0000000000..bc08dc7486
--- /dev/null
+++ b/basis/alien/destructors/destructors-docs.factor
@@ -0,0 +1,30 @@
+IN: alien.destructors
+USING: help.markup help.syntax alien destructors ;
+
+HELP: DESTRUCTOR:
+{ $syntax "DESTRUCTOR: word" }
+{ $description "Defines four things:"
+ { $list
+ { "a tuple named " { $snippet "word" } " with a single slot holding a " { $link c-ptr } }
+ { "a " { $link dispose } " method on the tuple which calls " { $snippet "word" } " with the " { $link c-ptr } }
+ { "a pair of words, " { $snippet "&word" } " and " { $snippet "|word" } ", which call " { $link &dispose } " and " { $link |dispose } " with a new instance of the tuple" }
+ }
+ "The " { $snippet "word" } " must be defined in the current vocabulary, and must have stack effect " { $snippet "( c-ptr -- )" } "."
+}
+{ $examples
+ "Suppose you are writing a binding to the GLib library, which as a " { $snippet "g_object_unref" } " function. Then you can define the function and destructor like so,"
+ { $code
+ "FUNCTION: void g_object_unref ( gpointer object ) ;"
+ "DESTRUCTOR: g_object_unref"
+ }
+ "Now, memory management becomes easier:"
+ { $code
+ "[ g_new_foo &g_object_unref ... ] with-destructors"
+ }
+} ;
+
+ARTICLE: "alien.destructors" "Alien destructors"
+"The " { $vocab-link "alien.destructors" } " vocabulary defines a utility parsing word for defining new disposable classes."
+{ $subsection POSTPONE: DESTRUCTOR: } ;
+
+ABOUT: "alien.destructors"
\ No newline at end of file
From bb5c6f78b805abe90b1712858156912001bd15a9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Mar 2009 20:50:07 -0500
Subject: [PATCH 09/20] words. emits a newline after
---
basis/tools/vocabs/browser/browser.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor
index 70588d5f21..6a3f2df8a3 100644
--- a/basis/tools/vocabs/browser/browser.factor
+++ b/basis/tools/vocabs/browser/browser.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.builtin
classes.intersection classes.mixin classes.predicate
@@ -224,7 +224,7 @@ C: <vocab-author> vocab-author
: words. ( vocab -- )
last-element off
- [ require ] [ words $words ] bi ;
+ [ require ] [ words $words ] bi nl ;
: describe-metadata ( vocab -- )
[
From 9696661ef544c6d813fd7f99e8afefe6f238fcf4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Mar 2009 21:21:32 -0500
Subject: [PATCH 10/20] Use 1|| instead of 0|| where appropriate in peg.ebnf to
remove some stack shuffling
---
basis/peg/ebnf/ebnf.factor | 50 +++++++++++++++++++-------------------
1 file changed, 25 insertions(+), 25 deletions(-)
diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor
index ca97886235..399b5b0fc9 100644
--- a/basis/peg/ebnf/ebnf.factor
+++ b/basis/peg/ebnf/ebnf.factor
@@ -128,28 +128,28 @@ PEG: escaper ( string -- ast )
#! in the EBNF syntax itself.
[
{
- [ dup blank? ]
- [ dup CHAR: " = ]
- [ dup CHAR: ' = ]
- [ dup CHAR: | = ]
- [ dup CHAR: { = ]
- [ dup CHAR: } = ]
- [ dup CHAR: = = ]
- [ dup CHAR: ) = ]
- [ dup CHAR: ( = ]
- [ dup CHAR: ] = ]
- [ dup CHAR: [ = ]
- [ dup CHAR: . = ]
- [ dup CHAR: ! = ]
- [ dup CHAR: & = ]
- [ dup CHAR: * = ]
- [ dup CHAR: + = ]
- [ dup CHAR: ? = ]
- [ dup CHAR: : = ]
- [ dup CHAR: ~ = ]
- [ dup CHAR: < = ]
- [ dup CHAR: > = ]
- } 0|| not nip
+ [ blank? ]
+ [ CHAR: " = ]
+ [ CHAR: ' = ]
+ [ CHAR: | = ]
+ [ CHAR: { = ]
+ [ CHAR: } = ]
+ [ CHAR: = = ]
+ [ CHAR: ) = ]
+ [ CHAR: ( = ]
+ [ CHAR: ] = ]
+ [ CHAR: [ = ]
+ [ CHAR: . = ]
+ [ CHAR: ! = ]
+ [ CHAR: & = ]
+ [ CHAR: * = ]
+ [ CHAR: + = ]
+ [ CHAR: ? = ]
+ [ CHAR: : = ]
+ [ CHAR: ~ = ]
+ [ CHAR: < = ]
+ [ CHAR: > = ]
+ } 1|| not
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
: 'terminal' ( -- parser )
@@ -161,9 +161,9 @@ PEG: escaper ( string -- ast )
#! Parse a valid foreign parser name
[
{
- [ dup blank? ]
- [ dup CHAR: > = ]
- } 0|| not nip
+ [ blank? ]
+ [ CHAR: > = ]
+ } 1|| not
] satisfy repeat1 [ >string ] action ;
: 'foreign' ( -- parser )
From e18e99acc3da1b6e8e8996bc9de220817cce5658 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Mar 2009 21:21:48 -0500
Subject: [PATCH 11/20] Auto-use output omits duplicate vocabulary names, and
the current vocabulary's private vocab
---
basis/prettyprint/prettyprint.factor | 24 +++++++++++++-----------
1 file changed, 13 insertions(+), 11 deletions(-)
diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor
index 7ef15b9a2f..2bdf3fb0ef 100644
--- a/basis/prettyprint/prettyprint.factor
+++ b/basis/prettyprint/prettyprint.factor
@@ -4,7 +4,7 @@ USING: accessors assocs colors combinators grouping io
io.streams.string io.styles kernel make math math.parser namespaces
parser prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections quotations sequences sorting strings vocabs
-vocabs.parser words ;
+vocabs.parser words sets ;
IN: prettyprint
<PRIVATE
@@ -32,7 +32,7 @@ IN: prettyprint
[ \ IN: pprint-word pprint-vocab ] with-pprint ;
: in. ( vocab -- )
- [ write-in nl ] when* ;
+ [ write-in ] when* ;
: use. ( seq -- )
[
@@ -40,33 +40,35 @@ IN: prettyprint
\ USING: pprint-word
[ pprint-vocab ] each
\ ; pprint-word
- ] with-pprint nl
+ ] with-pprint
] unless-empty ;
: use/in. ( in use -- )
dupd remove [ { "syntax" "scratchpad" } member? not ] filter
- use. in. ;
+ use. nl in. ;
: vocab-names ( words -- vocabs )
dictionary get
[ [ words>> eq? nip ] with assoc-find 2drop ] curry map sift ;
: prelude. ( -- )
- in get use get vocab-names use/in. ;
+ in get use get vocab-names prune in get ".private" append swap remove use/in. ;
[
nl
- "Restarts were invoked adding vocabularies to the search path." print
- "To avoid doing this in the future, add the following USING:" print
- "and IN: forms at the top of the source file:" print nl
- prelude.
- nl
+ { { font-style bold } { font-name "sans-serif" } } [
+ "Restarts were invoked adding vocabularies to the search path." print
+ "To avoid doing this in the future, add the following USING:" print
+ "and IN: forms at the top of the source file:" print nl
+ ] with-style
+ { { page-color COLOR: light-gray } } [ prelude. ] with-nesting
+ nl nl
] print-use-hook set-global
PRIVATE>
: with-use ( obj quot -- )
- make-pprint use/in. do-pprint ; inline
+ make-pprint use/in. nl do-pprint ; inline
: with-in ( obj quot -- )
make-pprint drop [ write-in bl ] when* do-pprint ; inline
From effec0469c2d41bde94ad6fab9678037cdc640b0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Mar 2009 21:25:33 -0500
Subject: [PATCH 12/20] Don't use colors.constants in prettyprint
---
basis/prettyprint/prettyprint.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor
index 2bdf3fb0ef..5eb04c9510 100644
--- a/basis/prettyprint/prettyprint.factor
+++ b/basis/prettyprint/prettyprint.factor
@@ -40,12 +40,12 @@ IN: prettyprint
\ USING: pprint-word
[ pprint-vocab ] each
\ ; pprint-word
- ] with-pprint
+ ] with-pprint nl
] unless-empty ;
: use/in. ( in use -- )
dupd remove [ { "syntax" "scratchpad" } member? not ] filter
- use. nl in. ;
+ use. in. ;
: vocab-names ( words -- vocabs )
dictionary get
@@ -61,7 +61,7 @@ IN: prettyprint
"To avoid doing this in the future, add the following USING:" print
"and IN: forms at the top of the source file:" print nl
] with-style
- { { page-color COLOR: light-gray } } [ prelude. ] with-nesting
+ { { page-color T{ rgba f 0.8 0.8 0.8 1.0 } } } [ prelude. ] with-nesting
nl nl
] print-use-hook set-global
From 39ce205f754ede6979bbe14f5dda78e972aa6a6b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 12 Mar 2009 21:52:45 -0500
Subject: [PATCH 13/20] add a binding to part or all of uniscribe
---
basis/windows/nt/nt.factor | 1 +
basis/windows/usp10/authors.txt | 1 +
basis/windows/usp10/usp10.factor | 337 +++++++++++++++++++++++++++++++
3 files changed, 339 insertions(+)
create mode 100755 basis/windows/usp10/authors.txt
create mode 100755 basis/windows/usp10/usp10.factor
diff --git a/basis/windows/nt/nt.factor b/basis/windows/nt/nt.factor
index 85aa991857..24d0032c5b 100644
--- a/basis/windows/nt/nt.factor
+++ b/basis/windows/nt/nt.factor
@@ -12,4 +12,5 @@ USING: alien sequences ;
{ "gl" "opengl32.dll" "stdcall" }
{ "glu" "glu32.dll" "stdcall" }
{ "ole32" "ole32.dll" "stdcall" }
+ { "usp10" "usp10.dll" "stdcall" }
} [ first3 add-library ] each
diff --git a/basis/windows/usp10/authors.txt b/basis/windows/usp10/authors.txt
new file mode 100755
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/basis/windows/usp10/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/basis/windows/usp10/usp10.factor b/basis/windows/usp10/usp10.factor
new file mode 100755
index 0000000000..6ad149b4f0
--- /dev/null
+++ b/basis/windows/usp10/usp10.factor
@@ -0,0 +1,337 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http:
+USING: alien.syntax ;
+IN: windows.usp10
+
+LIBRARY: usp10
+
+C-STRUCT: SCRIPT_CONTROL
+ { "DWORD" "flags" } ;
+
+C-STRUCT: SCRIPT_STATE
+ { "WORD" "flags" } ;
+
+C-STRUCT: SCRIPT_ANALYSIS
+ { "WORD" "flags" }
+ { "SCRIPT_STATE" "s" } ;
+
+C-STRUCT: SCRIPT_ITEM
+ { "int" "iCharPos" }
+ { "SCRIPT_ANALYSIS" "a" } ;
+
+FUNCTION: HRESULT ScriptItemize (
+ WCHAR* pwcInChars,
+ int cInChars,
+ int cMaxItems,
+ SCRIPT_CONTROL* psControl,
+ SCRIPT_STATE* psState,
+ SCRIPT_ITEM* pItems,
+ int* pcItems
+) ;
+
+FUNCTION: HRESULT ScriptLayout (
+ int cRuns,
+ BYTE* pbLevel,
+ int* piVisualToLogical,
+ int* piLogicalToVisual
+) ;
+
+C-ENUM: SCRIPT_JUSTIFY_NONE
+SCRIPT_JUSTIFY_ARABIC_BLANK
+SCRIPT_JUSTIFY_CHARACTER
+SCRIPT_JUSTIFY_RESERVED1
+SCRIPT_JUSTIFY_BLANK
+SCRIPT_JUSTIFY_RESERVED2
+SCRIPT_JUSTIFY_RESERVED3
+SCRIPT_JUSTIFY_ARABIC_NORMAL
+SCRIPT_JUSTIFY_ARABIC_KASHIDA
+SCRIPT_JUSTIFY_ALEF
+SCRIPT_JUSTIFY_HA
+SCRIPT_JUSTIFY_RA
+SCRIPT_JUSTIFY_BA
+SCRIPT_JUSTIFY_BARA
+SCRIPT_JUSTIFY_SEEN
+SCRIPT_JUSTIFFY_RESERVED4 ;
+
+C-STRUCT: SCRIPT_VISATTR
+ { "WORD" "flags" } ;
+
+FUNCTION: HRESULT ScriptShape (
+ HDC hdc,
+ SCRIPT_CACHE* psc,
+ WCHAR* pwcChars,
+ int cChars,
+ int cMaxGlyphs,
+ SCRIPT_ANALYSIS* psa,
+ WORD* pwOutGlyphs,
+ WORD* pwLogClust,
+ SCRIPT_VISATTR* psva,
+ int* pcGlyphs
+) ;
+
+C-STRUCT: GOFFSET
+ { "LONG" "du" }
+ { "LONG" "dv" } ;
+
+FUNCTION: HRESULT ScriptPlace (
+ HDC hdc,
+ SCRIPT_CACHE* psc,
+ WORD* pwGlyphs,
+ int cGlyphs,
+ SCRIPT_VISATTR* psva,
+ SCRIPT_ANALYSIS* psa,
+ int* piAdvance,
+ GOFFSET* pGoffset,
+ ABC* pABC
+) ;
+
+FUNCTION: HRESULT ScriptTextOut (
+ HDC hdc,
+ SCRIPT_CACHE* psc,
+ int x,
+ int y,
+ UINT fuOptions,
+ RECT* lprc,
+ SCRIPT_ANALYSIS* psa,
+ WCHAR* pwcReserved,
+ int iReserved,
+ WORD* pwGlyphs,
+ int cGlyphs,
+ int* piAdvance,
+ int* piJustify,
+ GOFFSET* pGoffset
+) ;
+
+FUNCTION: HRESULT ScriptJustify (
+ SCRIPT_VISATTR* psva,
+ int* piAdvance,
+ int cGlyphs,
+ int iDx,
+ int iMinKashida,
+ int* piJustify
+) ;
+
+C-STRUCT: SCRIPT_LOGATTR
+ { "BYTE" "flags" } ;
+
+FUNCTION: HRESULT ScriptBreak (
+ WCHAR* pwcChars,
+ int cChars,
+ SCRIPT_ANALYSIS* psa,
+ SCRIPT_LOGATTR* psla
+) ;
+
+FUNCTION: HRESULT ScriptCPtoX (
+ int iCP,
+ BOOL fTrailing,
+ int cChars,
+ int cGlyphs,
+ WORD* pwLogClust,
+ SCRIPT_VISATTR* psva,
+ int* piAdvance,
+ SCRIPT_ANALYSIS* psa,
+ int* piX
+) ;
+
+FUNCTION: HRESULT ScriptXtoCP (
+ int iCP,
+ BOOL fTrailing,
+ int cChars,
+ int cGlyphs,
+ WORD* pwLogClust,
+ SCRIPT_VISATTR* psva,
+ int* piAdvance,
+ SCRIPT_ANALYSIS* psa,
+ int* piCP,
+ int* piTrailing
+) ;
+
+FUNCTION: HRESULT ScriptGetLogicalWidths (
+ SCRIPT_ANALYSIS* psa,
+ int cChars,
+ int cGlyphs,
+ int* piGlyphWidth,
+ WORD* pwLogClust,
+ SCRIPT_VISATTR* psva,
+ int* piDx
+) ;
+
+FUNCTION: HRESULT ScriptApplyLogicalWidth (
+ int* piDx,
+ int cChars,
+ int cGlyphs,
+ WORD* pwLogClust,
+ SCRIPT_VISATTR* psva,
+ int* piAdvance,
+ SCRIPT_ANALYSIS* psa,
+ ABC* pABC,
+ int* piJustify
+) ;
+
+FUNCTION: HRESULT ScriptGetCMap (
+ HDC hdc,
+ SCRIPT_CACHE* psc,
+ WCHAR* pwcInChars,
+ int cChars,
+ DWORD dwFlags,
+ WORD* pwOutGlyphs
+) ;
+
+FUNCTION: HRESULT ScriptGetGlyphABCWidth (
+ HDC hdc,
+ SCRIPT_CACHE* psc,
+ WORD wGlyph,
+ ABC* pABC
+) ;
+
+C-STRUCT: SCRIPT_PROPERTIES
+ { "DWORD" "flags" } ;
+
+FUNCTION: HRESULT ScriptGetProperties (
+ SCRIPT_PROPERTIES*** ppSp,
+ int* piNumScripts
+) ;
+
+C-STRUCT: SCRIPT_FONTPROPERTIES
+ { "int" "cBytes" }
+ { "WORD" "wgBlank" }
+ { "WORD" "wgDefault" }
+ { "WORD" "wgInvalid" }
+ { "WORD" "wgKashida" }
+ { "int" "iKashidaWidth" } ;
+
+FUNCTION: HRESULT ScriptGetFontProperties (
+ HDC hdc,
+ SCRIPT_CACHE* psc,
+ SCRIPT_FONTPROPERTIES* sfp
+) ;
+
+FUNCTION: HRESULT ScriptCacheGetHeight (
+ HDC hdc,
+ SCRIPT_CACHE* psc,
+ long* tmHeight
+) ;
+
+CONSTANT: SSA_PASSWORD HEX: 00000001
+CONSTANT: SSA_TAB HEX: 00000002
+CONSTANT: SSA_CLIP HEX: 00000004
+CONSTANT: SSA_FIT HEX: 00000008
+CONSTANT: SSA_DZWG HEX: 00000010
+CONSTANT: SSA_FALLBACK HEX: 00000020
+CONSTANT: SSA_BREAK HEX: 00000040
+CONSTANT: SSA_GLYPHS HEX: 00000080
+CONSTANT: SSA_RTL HEX: 00000100
+CONSTANT: SSA_GCP HEX: 00000200
+CONSTANT: SSA_HOTKEY HEX: 00000400
+CONSTANT: SSA_METAFILE HEX: 00000800
+CONSTANT: SSA_LINK HEX: 00001000
+CONSTANT: SSA_HIDEHOTKEY HEX: 00002000
+CONSTANT: SSA_HOTKEYONLY HEX: 00002400
+CONSTANT: SSA_FULLMEASURE HEX: 04000000
+CONSTANT: SSA_LPKANSIFALLBACK HEX: 08000000
+CONSTANT: SSA_PIDX HEX: 10000000
+CONSTANT: SSA_LAYOUTRTL HEX: 20000000
+CONSTANT: SSA_DONTGLYPH HEX: 40000000
+CONSTANT: SSA_NOKASHIDA HEX: 80000000
+
+C-STRUCT: SCRIPT_TABDEF
+ { "int" "cTabStops" }
+ { "int" "iScale" }
+ { "int*" "pTabStops" }
+ { "int" "iTabOrigin" } ;
+
+TYPEDEF: void* SCRIPT_STRING_ANALYSIS
+
+FUNCTION: HRESULT ScriptStringAnalyse (
+ HDC hdc,
+ void* pString,
+ int cString,
+ int cGlyphs,
+ int iCharset,
+ DWORD dwFlags,
+ int iReqWidth,
+ SCRIPT_CONTROL* psControl,
+ SCRIPT_STATE* psState,
+ int* piDx,
+ SCRIPT_TABDEF* pTabDef,
+ BYTE* pbInClass,
+ SCRIPT_STRING_ANALYSIS* pssa
+) ;
+
+FUNCTION: HRESULT ScriptStringFree (
+ SCRIPT_STRING_ANALYSIS* pssa
+) ;
+
+FUNCTION: SIZE* ScriptString_pSize ( SCRIPT_STRING_ANALYSIS ssa ) ;
+
+FUNCTION: int* ScriptString_pcOutChars ( SCRIPT_STRING_ANALYSIS ssa ) ;
+
+FUNCTION: SCRIPT_LOGATTR* ScriptString_pLogAttr ( SCRIPT_STRING_ANALYSIS ssa ) ;
+
+FUNCTION: HRESULT ScriptStringGetOrder (
+ SCRIPT_STRING_ANALYSIS ssa,
+ UINT* puOrder
+) ;
+
+FUNCTION: HRESULT ScriptStringCPtoX (
+ SCRIPT_STRING_ANALYSIS ssa,
+ int icp,
+ BOOL fTrailing,
+ int* pX
+) ;
+
+FUNCTION: HRESULT ScriptStringXtoCP (
+ SCRIPT_STRING_ANALYSIS ssa,
+ int iX,
+ int* piCh,
+ int* piTrailing
+) ;
+
+FUNCTION: HRESULT ScriptStringGetLogicalWidths (
+ SCRIPT_STRING_ANALYSIS ssa,
+ int* piDx
+) ;
+
+FUNCTION: HRESULT ScriptStringValidate (
+ SCRIPT_STRING_ANALYSIS ssa
+) ;
+
+FUNCTION: HRESULT ScriptStringOut (
+ SCRIPT_STRING_ANALYSIS ssa,
+ int iX,
+ int iY,
+ UINT uOptions,
+ RECT* prc,
+ int iMinSel,
+ int iMaxSel,
+ BOOL fDisabled
+) ;
+
+CONSTANT: SIC_COMPLEX 1
+CONSTANT: SIC_ASCIIDIGIT 2
+CONSTANT: SIC_NEUTRAL 4
+
+FUNCTION: HRESULT ScriptIsComplex (
+ WCHAR* pwcInChars,
+ int cInChars,
+ DWORD dwFlags
+) ;
+
+C-STRUCT: SCRIPT_DIGITSUBSTITUTE
+ { "DWORD" "flags" } ;
+
+FUNCTION: HRESULT ScriptRecordDigitSubstitution (
+ LCID Locale,
+ SCRIPT_DIGITSUBSTITUTE* psds
+) ;
+
+CONSTANT: SCRIPT_DIGITSUBSTITUTE_CONTEXT 0
+CONSTANT: SCRIPT_DIGITSUBSTITUTE_NONE 1
+CONSTANT: SCRIPT_DIGITSUBSTITUTE_NATIONAL 2
+CONSTANT: SCRIPT_DIGITSUBSTITUTE_TRADITIONAL 3
+
+FUNCTION: HRESULT ScriptApplyDigitSubstitution (
+ SCRIPT_DIGITSUBSTITUTE* psds,
+ SCRIPT_CONTROL* psc,
+ SCRIPT_STATE* pss
+) ;
\ No newline at end of file
From aeaeca193d9cd28097b77ec315ec14f27c88602e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 12 Mar 2009 21:57:09 -0500
Subject: [PATCH 14/20] fix the copyright header
---
basis/windows/usp10/usp10.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/windows/usp10/usp10.factor b/basis/windows/usp10/usp10.factor
index 6ad149b4f0..64e5a60019 100755
--- a/basis/windows/usp10/usp10.factor
+++ b/basis/windows/usp10/usp10.factor
@@ -1,5 +1,5 @@
! Copyright (C) 2009 Doug Coleman.
-! See http:
+! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ;
IN: windows.usp10
From 8f1240cf966edb5ec627cb2d56462b900ec95a94 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Mar 2009 00:40:18 -0500
Subject: [PATCH 15/20] Forgetting a word doesn't call reset-word anymore,
fixing an issue where a word calling a forgotten word wouldn't compile
because the 'declared-effect' word prop was not set
---
basis/stack-checker/stack-checker-tests.factor | 11 +++++++++--
core/classes/classes.factor | 5 ++++-
core/words/words-tests.factor | 14 +++++++-------
core/words/words.factor | 2 +-
4 files changed, 21 insertions(+), 11 deletions(-)
diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor
index c881ccee11..3d8c2cdd8c 100644
--- a/basis/stack-checker/stack-checker-tests.factor
+++ b/basis/stack-checker/stack-checker-tests.factor
@@ -7,7 +7,7 @@ sorting assocs definitions prettyprint io inspector
classes.tuple classes.union classes.predicate debugger
threads.private io.streams.string io.timeouts io.thread
sequences.private destructors combinators eval locals.backend
-system ;
+system compiler.units ;
IN: stack-checker.tests
\ infer. must-infer
@@ -580,4 +580,11 @@ DEFER: eee'
[ [ ] debugging-curry-folding ] must-infer
-[ [ exit ] [ 1 2 3 ] if ] must-infer
\ No newline at end of file
+[ [ exit ] [ 1 2 3 ] if ] must-infer
+
+! Stack effects are required now but FORGET: clears them...
+: forget-test ( -- ) ;
+
+[ forget-test ] must-infer
+[ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
+[ forget-test ] must-infer
\ No newline at end of file
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 8145730f40..888eac7645 100644
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -42,8 +42,11 @@ PREDICATE: class < word "class" word-prop ;
PREDICATE: predicate < word "predicating" word-prop >boolean ;
+M: predicate forget*
+ [ call-next-method ] [ f "predicating" set-word-prop ] bi ;
+
M: predicate reset-word
- [ call-next-method ] [ { "predicating" } reset-props ] bi ;
+ [ call-next-method ] [ f "predicating" set-word-prop ] bi ;
: define-predicate ( class quot -- )
[ "predicate" word-prop first ] dip
diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor
index a22b6a5b97..52a20ba48a 100755
--- a/core/words/words-tests.factor
+++ b/core/words/words-tests.factor
@@ -55,18 +55,18 @@ GENERIC: testing
[ f ] [ \ testing generic? ] unit-test
-: forgotten ;
-: another-forgotten ;
+: forgotten ( -- ) ;
+: another-forgotten ( -- ) ;
FORGET: forgotten
FORGET: another-forgotten
-: another-forgotten ;
+: another-forgotten ( -- ) ;
! I forgot remove-crossref calls!
-: fee ;
-: foe fee ;
-: fie foe ;
+: fee ( -- ) ;
+: foe ( -- ) fee ;
+: fie ( -- ) foe ;
[ t ] [ \ fee usage [ word? ] filter empty? ] unit-test
[ t ] [ \ foe usage empty? ] unit-test
@@ -97,7 +97,7 @@ DEFER: calls-a-gensym
! more xref buggery
[ f ] [
GENERIC: xyzzle ( x -- x )
- : a ; \ a
+ : a ( -- ) ; \ a
M: integer xyzzle a ;
FORGET: a
M: object xyzzle ;
diff --git a/core/words/words.factor b/core/words/words.factor
index c27ea4fd8f..cd11fb2db1 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -248,7 +248,7 @@ M: word forget*
dup "forgotten" word-prop [ drop ] [
[ delete-xref ]
[ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
- [ [ reset-word ] [ t "forgotten" set-word-prop ] bi ]
+ [ t "forgotten" set-word-prop ]
tri
] if ;
From 4c51d8524d74902d1ffa27e98d57008c7412871c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Mar 2009 02:58:09 -0500
Subject: [PATCH 16/20] Fix prettyprinting of method definitions and classes
---
basis/prettyprint/prettyprint.factor | 14 +++++++++-----
1 file changed, 9 insertions(+), 5 deletions(-)
diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor
index 5eb04c9510..2286417dd1 100644
--- a/basis/prettyprint/prettyprint.factor
+++ b/basis/prettyprint/prettyprint.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs colors combinators grouping io
+USING: arrays accessors assocs colors combinators grouping io
io.streams.string io.styles kernel make math math.parser namespaces
parser prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections quotations sequences sorting strings vocabs
@@ -40,12 +40,15 @@ IN: prettyprint
\ USING: pprint-word
[ pprint-vocab ] each
\ ; pprint-word
- ] with-pprint nl
+ ] with-pprint
] unless-empty ;
: use/in. ( in use -- )
- dupd remove [ { "syntax" "scratchpad" } member? not ] filter
- use. in. ;
+ over "syntax" 2array diff
+ [ nip use. ]
+ [ empty? not and [ nl ] when ]
+ [ drop in. ]
+ 2tri ;
: vocab-names ( words -- vocabs )
dictionary get
@@ -68,7 +71,8 @@ IN: prettyprint
PRIVATE>
: with-use ( obj quot -- )
- make-pprint use/in. nl do-pprint ; inline
+ make-pprint [ use/in. ] [ empty? not or [ nl ] when ] 2bi
+ do-pprint ; inline
: with-in ( obj quot -- )
make-pprint drop [ write-in bl ] when* do-pprint ; inline
From a23a6a28707dd8a23402f37fd714273b16f369bf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Mar 2009 04:22:16 -0500
Subject: [PATCH 17/20] Forgetting a predicate class now updates
predicate-instance? word
---
core/classes/predicate/predicate-tests.factor | 8 +++++++-
core/classes/predicate/predicate.factor | 10 +++++-----
core/classes/union/union-tests.factor | 4 ++++
3 files changed, 16 insertions(+), 6 deletions(-)
diff --git a/core/classes/predicate/predicate-tests.factor b/core/classes/predicate/predicate-tests.factor
index 3de073f774..d4c929a69b 100644
--- a/core/classes/predicate/predicate-tests.factor
+++ b/core/classes/predicate/predicate-tests.factor
@@ -1,4 +1,4 @@
-USING: math tools.test classes.algebra ;
+USING: math tools.test classes.algebra words kernel sequences assocs ;
IN: classes.predicate
PREDICATE: negative < integer 0 < ;
@@ -19,3 +19,9 @@ M: positive abs ;
[ 10 ] [ -10 abs ] unit-test
[ 10 ] [ 10 abs ] unit-test
[ 0 ] [ 0 abs ] unit-test
+
+PREDICATE: blah < word blah eq? ;
+
+[ f ] [ \ predicate-instance? "compiled-uses" word-prop keys \ blah swap memq? ] unit-test
+
+FORGET: blah
\ No newline at end of file
diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor
index 4ba93acae4..7d757772f4 100644
--- a/core/classes/predicate/predicate.factor
+++ b/core/classes/predicate/predicate.factor
@@ -25,8 +25,9 @@ DEFER: predicate-instance? ( object class -- ? )
: predicate-quot ( class -- quot )
[
\ dup ,
- dup superclass "predicate" word-prop %
- "predicate-definition" word-prop , [ drop f ] , \ if ,
+ [ superclass "predicate" word-prop % ]
+ [ "predicate-definition" word-prop , ] bi
+ [ drop f ] , \ if ,
] [ ] make ;
: define-predicate-class ( class superclass definition -- )
@@ -42,9 +43,8 @@ DEFER: predicate-instance? ( object class -- ? )
update-predicate-instance ;
M: predicate-class reset-class
- [ call-next-method ]
- [ { "predicate-definition" } reset-props ]
- bi ;
+ [ call-next-method ] [ { "predicate-definition" } reset-props ] bi
+ update-predicate-instance ;
M: predicate-class rank-class drop 1 ;
diff --git a/core/classes/union/union-tests.factor b/core/classes/union/union-tests.factor
index 0802c0a2d9..57b742595f 100644
--- a/core/classes/union/union-tests.factor
+++ b/core/classes/union/union-tests.factor
@@ -70,10 +70,14 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
[ t ] [ "blah" "classes.union.tests" lookup union-class? ] unit-test
+[ t ] [ "foo?" "classes.union.tests" lookup predicate? ] unit-test
+
[ ] [ "IN: classes.union.tests USE: math UNION: blah integer ;" <string-reader> "union-reset-test" parse-stream drop ] unit-test
[ t ] [ "blah" "classes.union.tests" lookup union-class? ] unit-test
+[ f ] [ "foo?" "classes.union.tests" lookup predicate? ] unit-test
+
GENERIC: test-generic ( x -- y )
TUPLE: a-tuple ;
From 06f29ab7e459f9f4b335802bbc70239dc8f899ad Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Mar 2009 04:28:24 -0500
Subject: [PATCH 18/20] give-up-transform now uses a cached stack effect.
Slight performance improvement when compiling calls to member? with a
non-literal quotation
---
basis/stack-checker/transforms/transforms.factor | 9 +++++----
1 file changed, 5 insertions(+), 4 deletions(-)
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index 791e0e65c1..ecc2365cf9 100755
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -10,10 +10,11 @@ stack-checker.recursive-state ;
IN: stack-checker.transforms
: give-up-transform ( word -- )
- dup recursive-word?
- [ call-recursive-word ]
- [ dup infer-word apply-word/effect ]
- if ;
+ {
+ { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
+ { [ dup recursive-word? ] [ call-recursive-word ] }
+ [ dup infer-word apply-word/effect ]
+ } cond ;
:: ((apply-transform)) ( word quot values stack rstate -- )
rstate recursive-state
From da254e4621e1e31e165d0b10f091dae296e7b96a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Mar 2009 04:47:56 -0500
Subject: [PATCH 19/20] Opening a second popup if one is already visible hides
the first
---
basis/ui/gadgets/glass/glass.factor | 9 ++++-----
1 file changed, 4 insertions(+), 5 deletions(-)
diff --git a/basis/ui/gadgets/glass/glass.factor b/basis/ui/gadgets/glass/glass.factor
index af169235b4..945e16150d 100644
--- a/basis/ui/gadgets/glass/glass.factor
+++ b/basis/ui/gadgets/glass/glass.factor
@@ -63,7 +63,8 @@ TUPLE: popup < wrapper owner ;
swap >>owner ; inline
M: popup hide-glass-hook
- owner>> f >>popup request-focus ;
+ dup owner>> 2dup popup>> eq?
+ [ f >>popup request-focus drop ] [ 2drop ] if ;
PRIVATE>
@@ -75,7 +76,5 @@ popup H{
popup>> focusable-child resend-gesture ;
: show-popup ( owner popup visible-rect -- )
- [ <popup> ] dip
- [ drop dup owner>> (>>popup) ]
- [ [ [ owner>> ] keep ] dip show-glass ]
- 2bi ;
\ No newline at end of file
+ [ [ dup dup popup>> [ hide-glass ] when* ] dip <popup> ] dip
+ [ drop >>popup drop ] [ show-glass ] 3bi ;
\ No newline at end of file
From 1648a54655e5890f0e3f9870a8ec759bfba5e908 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Mar 2009 07:01:43 -0500
Subject: [PATCH 20/20] Add inline caching for execute( -- regex-dna is now
only 1% slower if regexp uses execute( rather than execute-unsafe(
---
basis/call/call-tests.factor | 18 +++++++++----
basis/call/call.factor | 50 ++++++++++++++++++++++++------------
2 files changed, 47 insertions(+), 21 deletions(-)
diff --git a/basis/call/call-tests.factor b/basis/call/call-tests.factor
index 002478fb82..4e45c3cf8f 100644
--- a/basis/call/call-tests.factor
+++ b/basis/call/call-tests.factor
@@ -14,12 +14,20 @@ IN: call.tests
[ 1 2 \ + execute( x y -- z a ) ] must-fail
[ \ + execute( x y -- z ) ] must-infer
+: compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ;
+
+[ t ] [ \ compile-execute(-test-1 optimized>> ] unit-test
+[ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test
+
+: compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ;
+
+[ t ] [ \ compile-execute(-test-2 optimized>> ] unit-test
+[ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test
+[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
+[ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test
+[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
+
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
-
-: compile-execute(-test ( a b -- c ) \ + execute( a b -- c ) ;
-
-[ t ] [ \ compile-execute(-test optimized>> ] unit-test
-[ 4 ] [ 1 3 compile-execute(-test ] unit-test
\ No newline at end of file
diff --git a/basis/call/call.factor b/basis/call/call.factor
index 0ccc774ce0..0c1b5bbfbf 100644
--- a/basis/call/call.factor
+++ b/basis/call/call.factor
@@ -1,7 +1,8 @@
-! Copyright (C) 2009 Daniel Ehrenberg.
+! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel macros fry summary sequences generalizations accessors
-continuations effects effects.parser parser words ;
+USING: kernel macros fry summary sequences sequences.private
+generalizations accessors continuations effects effects.parser
+parser words ;
IN: call
ERROR: wrong-values values quot length-required ;
@@ -14,17 +15,9 @@ M: wrong-values summary
: firstn-safe ( array quot n -- ... )
3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline
-: execute-effect-unsafe ( word effect -- )
- drop execute ;
-
-: execute-effect-unsafe? ( word effect -- ? )
- swap dup optimized>> [ stack-effect swap effect<= ] [ 2drop f ] if ; inline
-
: parse-call( ( accum word -- accum )
[ ")" parse-effect parsed ] dip parsed ;
-: execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing
-
PRIVATE>
MACRO: call-effect ( effect -- quot )
@@ -33,10 +26,35 @@ MACRO: call-effect ( effect -- quot )
: call( \ call-effect parse-call( ; parsing
-: execute-effect ( word effect -- )
- 2dup execute-effect-unsafe?
- [ execute-effect-unsafe ]
- [ [ [ execute ] curry ] dip call-effect ]
- if ; inline
+<PRIVATE
+
+: execute-effect-unsafe ( word effect -- )
+ drop execute ;
+
+: execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing
+
+: execute-effect-slow ( word effect -- )
+ [ [ execute ] curry ] dip call-effect ; inline
+
+: cache-hit? ( word ic -- ? ) first-unsafe eq? ; inline
+
+: cache-hit ( word effect ic -- ) drop execute-effect-unsafe ; inline
+
+: execute-effect-unsafe? ( word effect -- ? )
+ over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
+
+: cache-miss ( word effect ic -- )
+ [ 2dup execute-effect-unsafe? ] dip
+ '[ [ drop _ set-first ] [ execute-effect-unsafe ] 2bi ]
+ [ execute-effect-slow ] if ; inline
+
+: execute-effect-ic ( word effect ic -- )
+ #! ic is a mutable cell { effect }
+ 3dup nip cache-hit? [ cache-hit ] [ cache-miss ] if ; inline
+
+PRIVATE>
+
+MACRO: execute-effect ( effect -- )
+ { f } clone '[ _ _ execute-effect-ic ] ;
: execute( \ execute-effect parse-call( ; parsing