From 7bbcb569d403a44de2c99d061f873e1ea5dd3c41 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Mar 2009 17:01:44 -0500 Subject: [PATCH 01/14] 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 Date: Thu, 12 Mar 2009 17:30:24 -0500 Subject: [PATCH 02/14] 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 (littledan-3-test) ; inline recursive + +: littledan-3-test ( x -- ) + 0 f (littledan-3-test) ; inline + +[ ] [ [ littledan-3-test ] final-classes drop ] unit-test + +[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test + +[ V{ 1 } ] [ [ { } length 1+ f 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 Date: Thu, 12 Mar 2009 17:30:33 -0500 Subject: [PATCH 03/14] 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 Date: Thu, 12 Mar 2009 17:30:41 -0500 Subject: [PATCH 04/14] 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 Date: Thu, 12 Mar 2009 17:48:46 -0500 Subject: [PATCH 05/14] 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 + horizontal 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 Date: Thu, 12 Mar 2009 20:37:26 -0500 Subject: [PATCH 06/14] 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 subseq >vector ] unit-test [ V{ 3 4 } ] [ 0 2 2 4 1 10 dup subseq >vector ] unit-test +[ 0 10 "hello" ] must-fail +[ -10 3 "hello" ] must-fail +[ 2 1 "hello" ] 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 : ( from to seq -- slice ) dup slice? [ collapse-slice ] when From 91e51f038ced93a739b752cb34fdfc72e0a1dc2b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Mar 2009 20:43:44 -0500 Subject: [PATCH 07/14] 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 Date: Thu, 12 Mar 2009 20:48:22 -0500 Subject: [PATCH 08/14] 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 Date: Thu, 12 Mar 2009 20:50:07 -0500 Subject: [PATCH 09/14] 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 : 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 Date: Thu, 12 Mar 2009 21:21:32 -0500 Subject: [PATCH 10/14] 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 ] 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 Date: Thu, 12 Mar 2009 21:21:48 -0500 Subject: [PATCH 11/14] 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 > 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 Date: Thu, 12 Mar 2009 21:25:33 -0500 Subject: [PATCH 12/14] 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 Date: Thu, 12 Mar 2009 21:52:45 -0500 Subject: [PATCH 13/14] 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 Date: Thu, 12 Mar 2009 21:57:09 -0500 Subject: [PATCH 14/14] 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