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

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

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"

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) ] }
+            { +lt+ [ [ (head) ] keep-searching ] }
-            { +gt+ [ dup midpoint@ tail-slice (search) ] }
+            { +gt+ [ [ (tail) ] keep-searching ] }
         } case
     ] if ; inline recursive
 

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
+continuations vocabs assocs dlists definitions math graphs generic
-generic combinators deques search-deques io stack-checker
+combinators deques search-deques macros io stack-checker
-stack-checker.state stack-checker.inlining
+stack-checker.state stack-checker.inlining combinators.short-circuit
-combinators.short-circuit compiler.errors compiler.units
+compiler.errors compiler.units compiler.tree.builder
-compiler.tree.builder compiler.tree.optimizer
+compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
-compiler.cfg.builder compiler.cfg.optimizer
 compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.linear-scan compiler.cfg.stack-frame
+compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
-compiler.codegen compiler.utilities ;
+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 ]

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*

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 -- ? )
     {

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

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 ] [
+    2dup [ not ] either? [ drop ] [
-        [ drop clone ] [ [ interval>> ] bi@ ] 2bi
+        2dup [ class>> null-class? ] either? [ drop ] [
-        generalize-counter-interval >>interval
+            [ 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 )

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

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 ;

basis/peg/ebnf/ebnf.factor

@@ -128,28 +128,28 @@ PEG: escaper ( string -- ast )
   #! in the EBNF syntax itself.
   [
     {
-      [ dup blank?    ]
+      [ blank?    ]
-      [ dup CHAR: " = ]
+      [ CHAR: " = ]
-      [ dup CHAR: ' = ]
+      [ CHAR: ' = ]
-      [ dup CHAR: | = ]
+      [ CHAR: | = ]
-      [ dup CHAR: { = ]
+      [ CHAR: { = ]
-      [ dup CHAR: } = ]
+      [ CHAR: } = ]
-      [ dup CHAR: = = ]
+      [ CHAR: = = ]
-      [ dup CHAR: ) = ]
+      [ CHAR: ) = ]
-      [ dup CHAR: ( = ]
+      [ CHAR: ( = ]
-      [ dup CHAR: ] = ]
+      [ CHAR: ] = ]
-      [ dup CHAR: [ = ]
+      [ CHAR: [ = ]
-      [ dup CHAR: . = ]
+      [ CHAR: . = ]
-      [ dup CHAR: ! = ]
+      [ CHAR: ! = ]
-      [ dup CHAR: & = ]
+      [ CHAR: & = ]
-      [ dup CHAR: * = ]
+      [ CHAR: * = ]
-      [ dup CHAR: + = ]
+      [ CHAR: + = ]
-      [ dup CHAR: ? = ]
+      [ CHAR: ? = ]
-      [ dup CHAR: : = ]
+      [ CHAR: : = ]
-      [ dup CHAR: ~ = ]
+      [ CHAR: ~ = ]
-      [ dup CHAR: < = ]
+      [ CHAR: < = ]
-      [ dup CHAR: > = ]
+      [ CHAR: > = ]
-    } 0|| not nip    
+    } 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?    ]
+      [ blank?    ]
-      [ dup CHAR: > = ]
+      [ CHAR: > = ]
-    } 0|| not nip    
+    } 1|| not
   ] satisfy repeat1 [ >string ] action ;
 
 : 'foreign' ( -- parser )

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 -- )
     [
@@ -52,21 +52,23 @@ IN: prettyprint
     [ [ 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
+    { { font-style bold } { font-name "sans-serif" } } [
-    "To avoid doing this in the future, add the following USING:" print
+        "Restarts were invoked adding vocabularies to the search path." print
-    "and IN: forms at the top of the source file:" print nl
+        "To avoid doing this in the future, add the following USING:" print
-    prelude.
+        "and IN: forms at the top of the source file:" print nl
-    nl
+    ] with-style
+    { { page-color T{ rgba f 0.8 0.8 0.8 1.0 } } } [ 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

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 -- )
     [

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
 

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

basis/windows/usp10/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/windows/usp10/usp10.factor

@@ -0,0 +1,337 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+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
+) ;

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

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 ] 2dip length > "end > sequence" slice-error ]
-    [ drop > "start > end" slice-error ] 3tri ; inline
+    [ drop > "start > end" slice-error ]
+    3tri ; inline
 
 : <slice> ( from to seq -- slice )
     dup slice? [ collapse-slice ] when