steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Maxim Savchenko 2009-03-13 13:48:51 -04:00
parent 719080b0b4 1648a54655
commit c63a08ae95
25 changed files with 540 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/alien/c-types/c-types-docs.factor
View File

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

30
basis/alien/destructors/destructors-docs.factor Normal file
View File

@ -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"

11
basis/binary-search/binary-search.factor
View File

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

18
basis/call/call-tests.factor
View File

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

50
basis/call/call.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel macros fry summary sequences generalizations accessors
continuations effects effects.parser parser words ;
USING: kernel macros fry summary sequences sequences.private
generalizations accessors continuations effects effects.parser
parser words ;
IN: call
ERROR: wrong-values values quot length-required ;
@ -14,17 +15,9 @@ M: wrong-values summary
: firstn-safe ( array quot n -- ... )
3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline
: execute-effect-unsafe ( word effect -- )
drop execute ;
: execute-effect-unsafe? ( word effect -- ? )
swap dup optimized>> [ stack-effect swap effect<= ] [ 2drop f ] if ; inline
: parse-call( ( accum word -- accum )
[ ")" parse-effect parsed ] dip parsed ;
: execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing
PRIVATE>
MACRO: call-effect ( effect -- quot )
@ -33,10 +26,35 @@ MACRO: call-effect ( effect -- quot )
: call( \ call-effect parse-call( ; parsing
: execute-effect ( word effect -- )
2dup execute-effect-unsafe?
[ execute-effect-unsafe ]
[ [ [ execute ] curry ] dip call-effect ]
if ; inline
<PRIVATE
: execute-effect-unsafe ( word effect -- )
drop execute ;
: execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing
: execute-effect-slow ( word effect -- )
[ [ execute ] curry ] dip call-effect ; inline
: cache-hit? ( word ic -- ? ) first-unsafe eq? ; inline
: cache-hit ( word effect ic -- ) drop execute-effect-unsafe ; inline
: execute-effect-unsafe? ( word effect -- ? )
over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
: cache-miss ( word effect ic -- )
[ 2dup execute-effect-unsafe? ] dip
'[ [ drop _ set-first ] [ execute-effect-unsafe ] 2bi ]
[ execute-effect-slow ] if ; inline
: execute-effect-ic ( word effect ic -- )
#! ic is a mutable cell { effect }
3dup nip cache-hit? [ cache-hit ] [ cache-miss ] if ; inline
PRIVATE>
MACRO: execute-effect ( effect -- )
{ f } clone '[ _ _ execute-effect-ic ] ;
: execute( \ execute-effect parse-call( ; parsing

10
basis/io/directories/search/search-tests.factor
View File

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

4
basis/io/directories/search/search.factor
View File

@ -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 ;

50
basis/peg/ebnf/ebnf.factor
View File

@ -128,28 +128,28 @@ PEG: escaper ( string -- ast )
#! in the EBNF syntax itself.
[
{
[ dup blank? ]
[ dup CHAR: " = ]
[ dup CHAR: ' = ]
[ dup CHAR: | = ]
[ dup CHAR: { = ]
[ dup CHAR: } = ]
[ dup CHAR: = = ]
[ dup CHAR: ) = ]
[ dup CHAR: ( = ]
[ dup CHAR: ] = ]
[ dup CHAR: [ = ]
[ dup CHAR: . = ]
[ dup CHAR: ! = ]
[ dup CHAR: & = ]
[ dup CHAR: * = ]
[ dup CHAR: + = ]
[ dup CHAR: ? = ]
[ dup CHAR: : = ]
[ dup CHAR: ~ = ]
[ dup CHAR: < = ]
[ dup CHAR: > = ]
} 0|| not nip
[ blank? ]
[ CHAR: " = ]
[ CHAR: ' = ]
[ CHAR: | = ]
[ CHAR: { = ]
[ CHAR: } = ]
[ CHAR: = = ]
[ CHAR: ) = ]
[ CHAR: ( = ]
[ CHAR: ] = ]
[ CHAR: [ = ]
[ CHAR: . = ]
[ CHAR: ! = ]
[ CHAR: & = ]
[ CHAR: * = ]
[ CHAR: + = ]
[ CHAR: ? = ]
[ CHAR: : = ]
[ CHAR: ~ = ]
[ CHAR: < = ]
[ CHAR: > = ]
} 1|| not
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
: 'terminal' ( -- parser )
@ -161,9 +161,9 @@ PEG: escaper ( string -- ast )
#! Parse a valid foreign parser name
[
{
[ dup blank? ]
[ dup CHAR: > = ]
} 0|| not nip
[ blank? ]
[ CHAR: > = ]
} 1|| not
] satisfy repeat1 [ >string ] action ;
: 'foreign' ( -- parser )

32
basis/prettyprint/prettyprint.factor
View File

@ -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
use. in. ;
over "syntax" 2array diff
[ 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
"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

11
basis/stack-checker/stack-checker-tests.factor
View File

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

9
basis/stack-checker/transforms/transforms.factor
View File

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

4
basis/tools/vocabs/browser/browser.factor
View File

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

9
basis/ui/gadgets/glass/glass.factor
View File

@ -63,7 +63,8 @@ TUPLE: popup < wrapper owner ;
swap >>owner ; inline
M: popup hide-glass-hook
owner>> f >>popup request-focus ;
dup owner>> 2dup popup>> eq?
[ f >>popup request-focus drop ] [ 2drop ] if ;
PRIVATE>
@ -75,7 +76,5 @@ popup H{
popup>> focusable-child resend-gesture ;
: show-popup ( owner popup visible-rect -- )
[ <popup> ] dip
[ drop dup owner>> (>>popup) ]
[ [ [ owner>> ] keep ] dip show-glass ]
2bi ;
[ [ dup dup popup>> [ hide-glass ] when* ] dip <popup> ] dip
[ drop >>popup drop ] [ show-glass ] 3bi ;

2
basis/ui/gadgets/panes/panes.factor
View File

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

1
basis/windows/nt/nt.factor
View File

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

1
basis/windows/usp10/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

337
basis/windows/usp10/usp10.factor Executable file
View File

@ -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
) ;

5
core/classes/classes.factor
View File

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

8
core/classes/predicate/predicate-tests.factor
View File

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

10
core/classes/predicate/predicate.factor
View File

@ -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 ;

4
core/classes/union/union-tests.factor
View File

@ -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 ;

4
core/sequences/sequences-tests.factor
View File

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

5
core/sequences/sequences.factor
View File

@ -221,8 +221,9 @@ TUPLE: slice-error from to seq reason ;
: check-slice ( from to seq -- from to seq )
3dup
[ 2drop 0 < "start < 0" slice-error ]
[ nip length > "end > sequence" slice-error ]
[ drop > "start > end" slice-error ] 3tri ; inline
[ [ drop ] 2dip length > "end > sequence" slice-error ]
[ drop > "start > end" slice-error ]
3tri ; inline
: <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when

14
core/words/words-tests.factor
View File

@ -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 ;

2
core/words/words.factor
View File

@ -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 ;