"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:"
"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" } ;
--- /dev/null
+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
-! 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 ;
[ [ 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
[ 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
-! 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 ;
: 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 )
: 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
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
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 ;
#! in the EBNF syntax itself.\r
[\r
{\r
- [ dup blank? ]\r
- [ dup CHAR: " = ]\r
- [ dup CHAR: ' = ]\r
- [ dup CHAR: | = ]\r
- [ dup CHAR: { = ]\r
- [ dup CHAR: } = ]\r
- [ dup CHAR: = = ]\r
- [ dup CHAR: ) = ]\r
- [ dup CHAR: ( = ]\r
- [ dup CHAR: ] = ]\r
- [ dup CHAR: [ = ]\r
- [ dup CHAR: . = ]\r
- [ dup CHAR: ! = ]\r
- [ dup CHAR: & = ]\r
- [ dup CHAR: * = ]\r
- [ dup CHAR: + = ]\r
- [ dup CHAR: ? = ]\r
- [ dup CHAR: : = ]\r
- [ dup CHAR: ~ = ]\r
- [ dup CHAR: < = ]\r
- [ dup CHAR: > = ]\r
- } 0|| not nip \r
+ [ blank? ]\r
+ [ CHAR: " = ]\r
+ [ CHAR: ' = ]\r
+ [ CHAR: | = ]\r
+ [ CHAR: { = ]\r
+ [ CHAR: } = ]\r
+ [ CHAR: = = ]\r
+ [ CHAR: ) = ]\r
+ [ CHAR: ( = ]\r
+ [ CHAR: ] = ]\r
+ [ CHAR: [ = ]\r
+ [ CHAR: . = ]\r
+ [ CHAR: ! = ]\r
+ [ CHAR: & = ]\r
+ [ CHAR: * = ]\r
+ [ CHAR: + = ]\r
+ [ CHAR: ? = ]\r
+ [ CHAR: : = ]\r
+ [ CHAR: ~ = ]\r
+ [ CHAR: < = ]\r
+ [ CHAR: > = ]\r
+ } 1|| not\r
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;\r
\r
: 'terminal' ( -- parser )\r
#! Parse a valid foreign parser name\r
[\r
{\r
- [ dup blank? ]\r
- [ dup CHAR: > = ]\r
- } 0|| not nip \r
+ [ blank? ]\r
+ [ CHAR: > = ]\r
+ } 1|| not\r
] satisfy repeat1 [ >string ] action ;\r
\r
: 'foreign' ( -- parser )\r
! 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
[ \ IN: pprint-word pprint-vocab ] with-pprint ;
: in. ( vocab -- )
- [ write-in nl ] when* ;
+ [ write-in ] when* ;
: use. ( seq -- )
[
\ 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
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
[ [ ] 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
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
-! 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
: words. ( vocab -- )
last-element off
- [ require ] [ words $words ] bi ;
+ [ require ] [ words $words ] bi nl ;
: describe-metadata ( vocab -- )
[
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>
popup>> focusable-child resend-gesture ;
: show-popup ( owner popup visible-rect -- )
- [ <popup> ] dip
- [ drop dup owner>> (>>popup) ]
- [ [ [ owner>> ] keep ] dip show-glass ]
- 2bi ;
\ No newline at end of file
+ [ [ dup dup popup>> [ hide-glass ] when* ] dip <popup> ] dip
+ [ drop >>popup drop ] [ show-glass ] 3bi ;
\ No newline at end of file
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
{ "gl" "opengl32.dll" "stdcall" }
{ "glu" "glu32.dll" "stdcall" }
{ "ole32" "ole32.dll" "stdcall" }
+ { "usp10" "usp10.dll" "stdcall" }
} [ first3 add-library ] each
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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
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
-USING: math tools.test classes.algebra ;
+USING: math tools.test classes.algebra words kernel sequences assocs ;
IN: classes.predicate
PREDICATE: negative < integer 0 < ;
[ 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
: 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 -- )
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 ;
[ 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 ;
[ 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
: 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
[ 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
! more xref buggery
[ f ] [
GENERIC: xyzzle ( x -- x )
- : a ; \ a
+ : a ( -- ) ; \ a
M: integer xyzzle a ;
FORGET: a
M: object xyzzle ;
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 ;
projects / factor.git / commitdiff