Merge branch 'master' of git://factorcode.org/git/factor into clean-linux-x86-32

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/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

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
+USING: kernel macros fry summary sequences sequences.private
-continuations effects effects.parser parser words ;
+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 -- )
+<PRIVATE
-    2dup execute-effect-unsafe?
+
-    [ execute-effect-unsafe ]
+: execute-effect-unsafe ( word effect -- )
-    [ [ [ execute ] curry ] dip call-effect ]
+    drop execute ;
-    if ; inline
+
+: 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

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

@@ -1,10 +1,10 @@
 ! 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
-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,39 @@ 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
+    over "syntax" 2array diff
-    use. in. ;
+    [ nip use. ]
+    [ empty? not and [ nl ] when ]
+    [ drop in. ]
+    2tri ;
 
 : 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
+    { { 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
-    prelude.
+    ] with-style
-    nl
+    { { 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. ] [ empty? not or [ nl ] when ] 2bi
+    do-pprint ; inline
 
 : with-in ( obj quot -- )
     make-pprint drop [ write-in bl ] when* do-pprint ; inline

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
@@ -581,3 +581,10 @@ DEFER: eee'
 [ [ ] debugging-curry-folding ] must-infer
 
 [ [ 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

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 "inferred-effect" word-prop ] [ cached-infer ] }
+        { [ dup recursive-word? ] [ call-recursive-word ] }
         [ dup infer-word apply-word/effect ]
-    if ;
+    } cond ;
 
 :: ((apply-transform)) ( word quot values stack rstate -- )
     rstate recursive-state

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/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
+    [ [ dup dup popup>> [ hide-glass ] when* ] dip <popup> ] dip
-    [ drop dup owner>> (>>popup) ]
+    [ drop >>popup drop ] [ show-glass ] 3bi ;
-    [ [ [ owner>> ] keep ] dip show-glass ]
-    2bi ;

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/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

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

core/classes/predicate/predicate.factor

@@ -25,8 +25,9 @@ DEFER: predicate-instance? ( object class -- ? )
 : predicate-quot ( class -- quot )
     [
         \ dup ,
-        dup superclass "predicate" word-prop %
+        [ superclass "predicate" word-prop % ]
-        "predicate-definition" word-prop , [ drop f ] , \ if ,
+        [ "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 ]
+    [ call-next-method ] [ { "predicate-definition" } reset-props ] bi
-    [ { "predicate-definition" } reset-props ]
+    update-predicate-instance ;
-    bi ;
 
 M: predicate-class rank-class drop 1 ;
 

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 ;

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

core/words/words-tests.factor

@@ -55,18 +55,18 @@ GENERIC: testing
 
 [ f ] [ \ testing generic? ] unit-test
 
-: forgotten ;
+: forgotten ( -- ) ;
-: another-forgotten ;
+: another-forgotten ( -- ) ;
 
 FORGET: forgotten
 
 FORGET: another-forgotten
-: another-forgotten ;
+: another-forgotten ( -- ) ;
 
 ! I forgot remove-crossref calls!
-: fee ;
+: fee ( -- ) ;
-: foe fee ;
+: foe ( -- ) fee ;
-: fie foe ;
+: 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 ;

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 ;