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 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 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 +> [ [ 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 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 ; 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 ) diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 7ef15b9a2f..2286417dd1 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/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 > 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 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 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/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 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 -- ) [ 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 -- ) - [ ] dip - [ drop dup owner>> (>>popup) ] - [ [ [ owner>> ] keep ] dip show-glass ] - 2bi ; \ No newline at end of file + [ [ dup dup popup>> [ hide-glass ] when* ] dip ] dip + [ drop >>popup drop ] [ show-glass ] 3bi ; \ No newline at end of file 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 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..64e5a60019 --- /dev/null +++ b/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 +) ; \ 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/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 ;" "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 ; 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 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 ;