Merge branch 'master' of git://factorcode.org/git/factor
Aaron Schaefer
commit
f8171b51cb
|
|
@ -1,17 +1,38 @@
|
|||
{
|
||||
IBClasses = (
|
||||
{
|
||||
ACTIONS = {
|
||||
newFactorWorkspace = id;
|
||||
runFactorFile = id;
|
||||
saveFactorImage = id;
|
||||
saveFactorImageAs = id;
|
||||
showFactorHelp = id;
|
||||
};
|
||||
CLASS = FirstResponder;
|
||||
LANGUAGE = ObjC;
|
||||
SUPERCLASS = NSObject;
|
||||
}
|
||||
);
|
||||
IBVersion = 1;
|
||||
}
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
|
||||
<plist version="1.0">
|
||||
<dict>
|
||||
<key>IBClasses</key>
|
||||
<array>
|
||||
<dict>
|
||||
<key>ACTIONS</key>
|
||||
<dict>
|
||||
<key>factorBrowser</key>
|
||||
<string>id</string>
|
||||
<key>factorListener</key>
|
||||
<string>id</string>
|
||||
<key>newFactorBrowser</key>
|
||||
<string>id</string>
|
||||
<key>newFactorListener</key>
|
||||
<string>id</string>
|
||||
<key>refreshAll</key>
|
||||
<string>id</string>
|
||||
<key>runFactorFile</key>
|
||||
<string>id</string>
|
||||
<key>saveFactorImage</key>
|
||||
<string>id</string>
|
||||
<key>saveFactorImageAs</key>
|
||||
<string>id</string>
|
||||
</dict>
|
||||
<key>CLASS</key>
|
||||
<string>FirstResponder</string>
|
||||
<key>LANGUAGE</key>
|
||||
<string>ObjC</string>
|
||||
<key>SUPERCLASS</key>
|
||||
<string>NSObject</string>
|
||||
</dict>
|
||||
</array>
|
||||
<key>IBVersion</key>
|
||||
<string>1</string>
|
||||
</dict>
|
||||
</plist>
|
||||
|
|
|
|||
|
|
@ -1,21 +1,18 @@
|
|||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
|
||||
<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
|
||||
<plist version="1.0">
|
||||
<dict>
|
||||
<key>IBDocumentLocation</key>
|
||||
<string>557 119 525 491 0 0 2560 1578 </string>
|
||||
<key>IBEditorPositions</key>
|
||||
<dict>
|
||||
<key>29</key>
|
||||
<string>326 905 270 44 0 0 2560 1578 </string>
|
||||
</dict>
|
||||
<key>IBFramework Version</key>
|
||||
<string>439.0</string>
|
||||
<string>629</string>
|
||||
<key>IBOldestOS</key>
|
||||
<integer>5</integer>
|
||||
<key>IBOpenObjects</key>
|
||||
<array>
|
||||
<integer>29</integer>
|
||||
<integer>305</integer>
|
||||
</array>
|
||||
<key>IBSystem Version</key>
|
||||
<string>8R218</string>
|
||||
<string>9G55</string>
|
||||
<key>targetFramework</key>
|
||||
<string>IBCocoaFramework</string>
|
||||
</dict>
|
||||
</plist>
|
||||
|
|
|
|||
Binary file not shown.
40
README.txt
40
README.txt
|
|
@ -24,7 +24,7 @@ The Factor runtime is written in GNU C99, and is built with GNU make and
|
|||
gcc.
|
||||
|
||||
Factor supports various platforms. For an up-to-date list, see
|
||||
<http://factorcode.org/getfactor.fhtml>.
|
||||
<http://factorcode.org>.
|
||||
|
||||
Factor requires gcc 3.4 or later.
|
||||
|
||||
|
|
@ -36,17 +36,6 @@ arguments for make.
|
|||
|
||||
Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
|
||||
|
||||
Compilation will yield an executable named 'factor' on Unix,
|
||||
'factor.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
|
||||
|
||||
* Libraries needed for compilation
|
||||
|
||||
For X11 support, you need recent development libraries for libc,
|
||||
Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
|
||||
(like Ubuntu), you can use the following line to grab everything:
|
||||
|
||||
sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
|
||||
|
||||
* Bootstrapping the Factor image
|
||||
|
||||
Once you have compiled the Factor runtime, you must bootstrap the Factor
|
||||
|
|
@ -69,6 +58,12 @@ machines.
|
|||
On Unix, Factor can either run a graphical user interface using X11, or
|
||||
a terminal listener.
|
||||
|
||||
For X11 support, you need recent development libraries for libc,
|
||||
Pango, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
|
||||
(like Ubuntu), you can use the following line to grab everything:
|
||||
|
||||
sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev glutg3-dev
|
||||
|
||||
If your DISPLAY environment variable is set, the UI will start
|
||||
automatically:
|
||||
|
||||
|
|
@ -78,14 +73,6 @@ To run an interactive terminal listener:
|
|||
|
||||
./factor -run=listener
|
||||
|
||||
If you're inside a terminal session, you can start the UI with one of
|
||||
the following two commands:
|
||||
|
||||
ui
|
||||
[ ui ] in-thread
|
||||
|
||||
The latter keeps the terminal listener running.
|
||||
|
||||
* Running Factor on Mac OS X - Cocoa UI
|
||||
|
||||
On Mac OS X, a Cocoa UI is available in addition to the terminal
|
||||
|
|
@ -110,7 +97,7 @@ When compiling Factor, pass the X11=1 parameter:
|
|||
|
||||
Then bootstrap with the following switches:
|
||||
|
||||
./factor -i=boot.<cpu>.image -ui-backend=x11
|
||||
./factor -i=boot.<cpu>.image -ui-backend=x11 -ui-text-backend=pango
|
||||
|
||||
Now if $DISPLAY is set, running ./factor will start the UI.
|
||||
|
||||
|
|
@ -126,6 +113,12 @@ the command prompt using the console application:
|
|||
|
||||
factor.com -i=boot.<cpu>.image
|
||||
|
||||
Before bootstrapping, you will need to download the DLLs for the Pango
|
||||
text rendering library. The required DLLs are listed in
|
||||
build-support/dlls.txt and are available from the following location:
|
||||
|
||||
<http://factorcode.org/dlls>
|
||||
|
||||
Once bootstrapped, double-clicking factor.exe or factor.com starts
|
||||
the Factor UI.
|
||||
|
||||
|
|
@ -135,7 +128,9 @@ To run the listener in the command prompt:
|
|||
|
||||
* The Factor FAQ
|
||||
|
||||
The Factor FAQ is available at <http://factorcode.org/faq.fhtml>.
|
||||
The Factor FAQ is available at the following location:
|
||||
|
||||
<http://concatenative.org/wiki/view/Factor/FAQ>
|
||||
|
||||
* Command line usage
|
||||
|
||||
|
|
@ -153,7 +148,6 @@ The Factor source tree is organized as follows:
|
|||
core/ - Factor core library
|
||||
basis/ - Factor basis library, compiler, tools
|
||||
extra/ - more libraries and applications
|
||||
fonts/ - TrueType fonts used by UI
|
||||
misc/ - editor modes, icons, etc
|
||||
unmaintained/ - unmaintained contributions, please help!
|
||||
|
||||
|
|
|
|||
|
|
@ -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" } ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
|
|||
namespaces make parser sequences strings words assocs splitting
|
||||
math.parser cpu.architecture alien alien.accessors quotations
|
||||
layouts system compiler.units io.files io.encodings.binary
|
||||
accessors combinators effects continuations fry call classes ;
|
||||
accessors combinators effects continuations fry classes ;
|
||||
IN: alien.c-types
|
||||
|
||||
DEFER: <int>
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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"
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test alien.destructors ;
|
||||
IN: alien.destructors.tests
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: functors destructors accessors kernel parser words ;
|
||||
IN: alien.destructors
|
||||
|
||||
SLOT: alien
|
||||
|
||||
FUNCTOR: define-destructor ( F -- )
|
||||
|
||||
F-destructor DEFINES-CLASS ${F}-destructor
|
||||
<F-destructor> DEFINES <${F}-destructor>
|
||||
&F DEFINES &${F}
|
||||
|F DEFINES |${F}
|
||||
|
||||
WHERE
|
||||
|
||||
TUPLE: F-destructor alien disposed ;
|
||||
|
||||
: <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline
|
||||
|
||||
M: F-destructor dispose* alien>> F ;
|
||||
|
||||
: &F ( alien -- alien ) dup <F-destructor> &dispose drop ; inline
|
||||
|
||||
: |F ( alien -- alien ) dup <F-destructor> |dispose drop ; inline
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
: DESTRUCTOR: scan-word define-destructor ; parsing
|
||||
|
|
@ -0,0 +1 @@
|
|||
Functor for defining destructors which call a C function to dispose of resources
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov, Alex Chapman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays alien alien.c-types alien.structs
|
||||
alien.arrays alien.strings kernel math namespaces parser
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: ascii
|
|||
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
|
||||
: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
|
||||
: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline
|
||||
: control? ( ch -- ? ) "\0\e\r\n\t\u000008\u00007f" member? ; inline
|
||||
: control? ( ch -- ? ) { [ 0 HEX: 1F between? ] [ HEX: 7F = ] } 1|| ; inline
|
||||
: quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline
|
||||
: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline
|
||||
: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline
|
||||
|
|
@ -20,4 +20,4 @@ IN: ascii
|
|||
: >upper ( str -- upper ) [ ch>upper ] map ;
|
||||
|
||||
HINTS: >lower string ;
|
||||
HINTS: >upper string ;
|
||||
HINTS: >upper string ;
|
||||
|
|
|
|||
|
|
@ -1,25 +1,26 @@
|
|||
USING: kernel tools.test base64 strings sequences ;
|
||||
USING: kernel tools.test base64 strings sequences
|
||||
io.encodings.string io.encodings.ascii ;
|
||||
IN: base64.tests
|
||||
|
||||
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string
|
||||
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" ascii encode >base64 base64> ascii decode
|
||||
] unit-test
|
||||
[ "" ] [ "" >base64 base64> >string ] unit-test
|
||||
[ "a" ] [ "a" >base64 base64> >string ] unit-test
|
||||
[ "ab" ] [ "ab" >base64 base64> >string ] unit-test
|
||||
[ "abc" ] [ "abc" >base64 base64> >string ] unit-test
|
||||
[ "abcde" ] [ "abcde" >base64 3 cut "\r\n" swap 3append base64> >string ] unit-test
|
||||
[ f ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
|
||||
[ "a" ] [ "a" ascii encode >base64 base64> ascii decode ] unit-test
|
||||
[ "ab" ] [ "ab" ascii encode >base64 base64> ascii decode ] unit-test
|
||||
[ "abc" ] [ "abc" ascii encode >base64 base64> ascii decode ] unit-test
|
||||
[ "abcde" ] [ "abcde" ascii encode >base64 3 cut "\r\n" swap 3append base64> ascii decode ] unit-test
|
||||
|
||||
! From http://en.wikipedia.org/wiki/Base64
|
||||
[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
|
||||
[
|
||||
"Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
|
||||
>base64 >string
|
||||
ascii encode >base64 >string
|
||||
] unit-test
|
||||
|
||||
[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlz\r\nIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2Yg\r\ndGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGlu\r\ndWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRo\r\nZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
|
||||
[
|
||||
"Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
|
||||
>base64-lines >string
|
||||
ascii encode >base64-lines >string
|
||||
] unit-test
|
||||
|
||||
\ >base64 must-infer
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators io io.binary io.encodings.binary
|
||||
io.streams.byte-array io.streams.string kernel math namespaces
|
||||
io.streams.byte-array kernel math namespaces
|
||||
sequences strings io.crlf ;
|
||||
IN: base64
|
||||
|
||||
|
|
@ -75,10 +75,10 @@ PRIVATE>
|
|||
} case ;
|
||||
|
||||
: >base64 ( seq -- base64 )
|
||||
binary [ [ encode-base64 ] with-string-reader ] with-byte-writer ;
|
||||
binary [ binary [ encode-base64 ] with-byte-reader ] with-byte-writer ;
|
||||
|
||||
: base64> ( base64 -- seq )
|
||||
[ binary [ decode-base64 ] with-byte-reader ] with-string-writer ;
|
||||
binary [ binary [ decode-base64 ] with-byte-reader ] with-byte-writer ;
|
||||
|
||||
: >base64-lines ( seq -- base64 )
|
||||
binary [ [ encode-base64-lines ] with-string-reader ] with-byte-writer ;
|
||||
binary [ binary [ encode-base64-lines ] with-byte-reader ] with-byte-writer ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -6,17 +6,17 @@ io.streams.byte-array ;
|
|||
IN: bitstreams.tests
|
||||
|
||||
[ 1 t ]
|
||||
[ B{ 254 } <string-reader> <bitstream-reader> read-bit ] unit-test
|
||||
[ B{ 254 } binary <byte-reader> <bitstream-reader> read-bit ] unit-test
|
||||
|
||||
[ 254 8 t ]
|
||||
[ B{ 254 } <string-reader> <bitstream-reader> 8 swap read-bits ] unit-test
|
||||
[ B{ 254 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
|
||||
|
||||
[ 4095 12 t ]
|
||||
[ B{ 255 255 } <string-reader> <bitstream-reader> 12 swap read-bits ] unit-test
|
||||
[ B{ 255 255 } binary <byte-reader> <bitstream-reader> 12 swap read-bits ] unit-test
|
||||
|
||||
[ B{ 254 } ]
|
||||
[
|
||||
<string-writer> <bitstream-writer> 254 8 rot
|
||||
binary <byte-writer> <bitstream-writer> 254 8 rot
|
||||
[ write-bits ] keep stream>> >byte-array
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -446,6 +446,8 @@ M: quotation '
|
|||
quotation type-number object tag-number [
|
||||
emit ! array
|
||||
f ' emit ! compiled
|
||||
f ' emit ! cached-effect
|
||||
f ' emit ! cache-counter
|
||||
0 emit ! xt
|
||||
0 emit ! code
|
||||
] emit-object
|
||||
|
|
@ -515,7 +517,7 @@ M: quotation '
|
|||
20000 <hashtable> objects set
|
||||
emit-header t, 0, 1, -1,
|
||||
"Building generic words..." print flush
|
||||
call-remake-generics-hook
|
||||
remake-generics
|
||||
"Serializing words..." print flush
|
||||
emit-words
|
||||
"Serializing JIT data..." print flush
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ SYMBOL: bootstrap-time
|
|||
[ "bootstrap." prepend require ] each ;
|
||||
|
||||
: count-words ( pred -- )
|
||||
all-words swap count number>string write ;
|
||||
all-words swap count number>string write ; inline
|
||||
|
||||
: print-time ( ms -- )
|
||||
1000 /i
|
||||
|
|
|
|||
|
|
@ -4,8 +4,8 @@ USING: kernel vocabs vocabs.loader sequences system ;
|
|||
[ "bootstrap." prepend vocab ] all? [
|
||||
"ui.tools" require
|
||||
|
||||
"ui.cocoa" vocab [
|
||||
"ui.cocoa.tools" require
|
||||
"ui.backend.cocoa" vocab [
|
||||
"ui.backend.cocoa.tools" require
|
||||
] when
|
||||
|
||||
"ui.tools.walker" require
|
||||
|
|
|
|||
|
|
@ -9,7 +9,13 @@ IN: bootstrap.ui
|
|||
{ [ os windows? ] [ "windows" ] }
|
||||
{ [ os unix? ] [ "x11" ] }
|
||||
} cond
|
||||
] unless* "ui." prepend require
|
||||
] unless* "ui.backend." prepend require
|
||||
|
||||
"ui.freetype" require
|
||||
"ui-text-backend" get [
|
||||
{
|
||||
{ [ os macosx? ] [ "core-text" ] }
|
||||
{ [ os windows? ] [ "pango" ] }
|
||||
{ [ os unix? ] [ "pango" ] }
|
||||
} cond
|
||||
] unless* "ui.text." prepend require
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test cache ;
|
||||
IN: cache.tests
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs math accessors destructors fry sequences ;
|
||||
IN: cache
|
||||
|
||||
TUPLE: cache-assoc assoc max-age disposed ;
|
||||
|
||||
: <cache-assoc> ( -- cache )
|
||||
H{ } clone 10 f cache-assoc boa ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: cache-entry value age ;
|
||||
|
||||
: <cache-entry> ( value -- entry ) 0 cache-entry boa ; inline
|
||||
|
||||
M: cache-entry dispose value>> dispose ;
|
||||
|
||||
M: cache-assoc assoc-size assoc>> assoc-size ;
|
||||
|
||||
M: cache-assoc at* assoc>> at* [ dup [ 0 >>age value>> ] when ] dip ;
|
||||
|
||||
M: cache-assoc set-at
|
||||
[ check-disposed ] keep
|
||||
[ <cache-entry> ] 2dip
|
||||
assoc>> set-at ;
|
||||
|
||||
M: cache-assoc clear-assoc assoc>> clear-assoc ;
|
||||
|
||||
M: cache-assoc >alist assoc>> [ value>> ] { } assoc-map-as ;
|
||||
|
||||
INSTANCE: cache-assoc assoc
|
||||
|
||||
M: cache-assoc dispose*
|
||||
[ values dispose-each ] [ clear-assoc ] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: purge-cache ( cache -- )
|
||||
dup max-age>> '[
|
||||
[ nip [ 1+ ] change-age age>> _ >= ] assoc-partition
|
||||
[ values dispose-each ] dip
|
||||
] change-assoc drop ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
An associative mapping whose entries expire after a while
|
||||
|
|
@ -1,2 +1,3 @@
|
|||
Sampo Vuori
|
||||
Doug Coleman
|
||||
Slava Pestov
|
||||
|
|
|
|||
|
|
@ -0,0 +1,8 @@
|
|||
IN: cairo.tests
|
||||
USING: cairo tools.test math.rectangles accessors ;
|
||||
|
||||
[ { 10 20 } ] [
|
||||
{ 10 20 } [
|
||||
{ 0 1 } { 3 4 } <rect> fill-rect
|
||||
] make-bitmap-image dim>>
|
||||
] unit-test
|
||||
|
|
@ -1,37 +1,52 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: cairo.ffi kernel accessors sequences
|
||||
namespaces fry continuations destructors ;
|
||||
USING: colors fonts cairo.ffi alien alien.c-types kernel accessors
|
||||
sequences namespaces fry continuations destructors math images
|
||||
images.memory math.rectangles ;
|
||||
IN: cairo
|
||||
|
||||
TUPLE: cairo-t alien ;
|
||||
C: <cairo-t> cairo-t
|
||||
M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
|
||||
ERROR: cairo-error message ;
|
||||
|
||||
TUPLE: cairo-surface-t alien ;
|
||||
C: <cairo-surface-t> cairo-surface-t
|
||||
M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
|
||||
: (check-cairo) ( cairo_status_t -- )
|
||||
dup CAIRO_STATUS_SUCCESS =
|
||||
[ drop ] [ cairo_status_to_string cairo-error ] if ;
|
||||
|
||||
: check-cairo ( cairo_status_t -- )
|
||||
dup CAIRO_STATUS_SUCCESS = [ drop ]
|
||||
[ cairo_status_to_string "Cairo error: " prepend throw ] if ;
|
||||
: check-cairo ( cairo -- ) cairo_status (check-cairo) ;
|
||||
|
||||
SYMBOL: cairo
|
||||
: cr ( -- cairo ) cairo get ; inline
|
||||
: check-surface ( surface -- ) cairo_surface_status (check-cairo) ;
|
||||
|
||||
: (with-cairo) ( cairo-t quot -- )
|
||||
[ alien>> cairo ] dip
|
||||
'[ @ cr cairo_status check-cairo ]
|
||||
with-variable ; inline
|
||||
|
||||
: with-cairo ( cairo quot -- )
|
||||
[ <cairo-t> ] dip '[ _ (with-cairo) ] with-disposal ; inline
|
||||
: width>stride ( width -- stride ) "uint" heap-size * ; inline
|
||||
|
||||
: (with-surface) ( cairo-surface-t quot -- )
|
||||
[ alien>> ] dip [ cairo_surface_status check-cairo ] bi ; inline
|
||||
: <image-surface> ( data dim -- surface )
|
||||
[ CAIRO_FORMAT_ARGB32 ] dip first2 over width>stride
|
||||
cairo_image_surface_create_for_data
|
||||
dup check-surface ;
|
||||
|
||||
: with-surface ( cairo_surface quot -- )
|
||||
[ <cairo-surface-t> ] dip '[ _ (with-surface) ] with-disposal ; inline
|
||||
: <cairo> ( surface -- cairo ) cairo_create dup check-cairo ; inline
|
||||
|
||||
: with-cairo-from-surface ( cairo_surface quot -- )
|
||||
'[ cairo_create _ with-cairo ] with-surface ; inline
|
||||
: make-bitmap-image ( dim quot -- image )
|
||||
'[
|
||||
<image-surface> &cairo_surface_destroy
|
||||
<cairo> &cairo_destroy
|
||||
@
|
||||
] make-memory-bitmap
|
||||
BGRA >>component-order ; inline
|
||||
|
||||
: dummy-cairo ( -- cr )
|
||||
#! Sometimes we want a dummy context; eg with Pango, we want
|
||||
#! to measure text dimensions to create a new image context with,
|
||||
#! but we need an existing context to measure text dimensions
|
||||
#! with so we use the dummy.
|
||||
\ dummy-cairo [
|
||||
CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create
|
||||
cairo_create
|
||||
] initialize-alien ;
|
||||
|
||||
: set-source-color ( cr color -- )
|
||||
>rgba-components cairo_set_source_rgba ;
|
||||
|
||||
: fill-rect ( cr rect -- )
|
||||
[ rect-bounds [ first2 ] bi@ cairo_rectangle ]
|
||||
[ drop cairo_fill ]
|
||||
2bi ;
|
||||
|
|
|
|||
|
|
@ -4,15 +4,15 @@
|
|||
! Adapted from cairo.h, version 1.5.14
|
||||
! License: http://factorcode.org/license.txt
|
||||
|
||||
USING: system combinators alien alien.syntax kernel
|
||||
alien.c-types accessors sequences arrays ui.gadgets ;
|
||||
USING: system combinators alien alien.syntax alien.c-types
|
||||
alien.destructors kernel accessors sequences arrays ui.gadgets ;
|
||||
|
||||
IN: cairo.ffi
|
||||
<< "cairo" {
|
||||
{ [ os winnt? ] [ "libcairo-2.dll" ] }
|
||||
{ [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
|
||||
{ [ os unix? ] [ "libcairo.so.2" ] }
|
||||
} cond "cdecl" add-library >>
|
||||
<< {
|
||||
{ [ os winnt? ] [ "cairo" "libcairo-2.dll" "cdecl" add-library ] }
|
||||
{ [ os macosx? ] [ "cairo" "/opt/local/lib/libcairo.dylib" "cdecl" add-library ] }
|
||||
{ [ os unix? ] [ ] }
|
||||
} cond >>
|
||||
|
||||
LIBRARY: cairo
|
||||
|
||||
|
|
@ -94,6 +94,8 @@ cairo_reference ( cairo_t* cr ) ;
|
|||
FUNCTION: void
|
||||
cairo_destroy ( cairo_t* cr ) ;
|
||||
|
||||
DESTRUCTOR: cairo_destroy
|
||||
|
||||
FUNCTION: uint
|
||||
cairo_get_reference_count ( cairo_t* cr ) ;
|
||||
|
||||
|
|
@ -694,6 +696,8 @@ cairo_surface_finish ( cairo_surface_t* surface ) ;
|
|||
FUNCTION: void
|
||||
cairo_surface_destroy ( cairo_surface_t* surface ) ;
|
||||
|
||||
DESTRUCTOR: cairo_surface_destroy
|
||||
|
||||
FUNCTION: uint
|
||||
cairo_surface_get_reference_count ( cairo_surface_t* surface ) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ HELP: month-name
|
|||
{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ;
|
||||
|
||||
HELP: month-abbreviations
|
||||
{ $values { "array" array } }
|
||||
{ $values { "value" array } }
|
||||
{ $description "Returns an array with the English abbreviated names of all the months." }
|
||||
{ $warning "Do not use this array for looking up a month name directly. Use month-abbreviation instead." } ;
|
||||
|
||||
|
|
@ -54,7 +54,7 @@ HELP: day-name
|
|||
{ $description "Looks up the day name and returns it as a string." } ;
|
||||
|
||||
HELP: day-abbreviations2
|
||||
{ $values { "array" array } }
|
||||
{ $values { "value" array } }
|
||||
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ;
|
||||
|
||||
HELP: day-abbreviation2
|
||||
|
|
@ -62,7 +62,7 @@ HELP: day-abbreviation2
|
|||
{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is two characters long." } ;
|
||||
|
||||
HELP: day-abbreviations3
|
||||
{ $values { "array" array } }
|
||||
{ $values { "value" array } }
|
||||
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ;
|
||||
|
||||
HELP: day-abbreviation3
|
||||
|
|
|
|||
|
|
@ -39,8 +39,10 @@ M: not-a-month summary
|
|||
drop "Months are indexed starting at 1" ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: check-month ( n -- n )
|
||||
dup zero? [ not-a-month ] when ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: month-names ( -- array )
|
||||
|
|
@ -52,11 +54,11 @@ PRIVATE>
|
|||
: month-name ( n -- string )
|
||||
check-month 1- month-names nth ;
|
||||
|
||||
: month-abbreviations ( -- array )
|
||||
CONSTANT: month-abbreviations
|
||||
{
|
||||
"Jan" "Feb" "Mar" "Apr" "May" "Jun"
|
||||
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec"
|
||||
} ;
|
||||
}
|
||||
|
||||
: month-abbreviation ( n -- string )
|
||||
check-month 1- month-abbreviations nth ;
|
||||
|
|
@ -70,17 +72,17 @@ CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
|
|||
|
||||
: day-name ( n -- string ) day-names nth ;
|
||||
|
||||
: day-abbreviations2 ( -- array )
|
||||
{ "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
|
||||
CONSTANT: day-abbreviations2
|
||||
{ "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" }
|
||||
|
||||
: day-abbreviation2 ( n -- string )
|
||||
day-abbreviations2 nth ;
|
||||
day-abbreviations2 nth ; inline
|
||||
|
||||
: day-abbreviations3 ( -- array )
|
||||
{ "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
|
||||
CONSTANT: day-abbreviations3
|
||||
{ "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" }
|
||||
|
||||
: day-abbreviation3 ( n -- string )
|
||||
day-abbreviations3 nth ;
|
||||
day-abbreviations3 nth ; inline
|
||||
|
||||
: average-month ( -- ratio ) 30+5/12 ; inline
|
||||
: months-per-year ( -- integer ) 12 ; inline
|
||||
|
|
|
|||
|
|
@ -1,32 +0,0 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax quotations effects words ;
|
||||
IN: call
|
||||
|
||||
ABOUT: "call"
|
||||
|
||||
ARTICLE: "call" "Calling code with known stack effects"
|
||||
"The " { $vocab-link "call" } " vocabulary allows for arbitrary quotations to be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate."
|
||||
{ $subsection POSTPONE: call( }
|
||||
{ $subsection POSTPONE: execute( }
|
||||
{ $subsection call-effect }
|
||||
{ $subsection execute-effect } ;
|
||||
|
||||
HELP: call(
|
||||
{ $syntax "[ ] call( foo -- bar )" }
|
||||
{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ;
|
||||
|
||||
HELP: call-effect
|
||||
{ $values { "quot" quotation } { "effect" effect } }
|
||||
{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ;
|
||||
|
||||
HELP: execute(
|
||||
{ $syntax "word execute( foo -- bar )" }
|
||||
{ $description "Calls the word on the top of the stack, aserting that it has the given stack effect. The word does not need to be known at compile time." } ;
|
||||
|
||||
HELP: execute-effect
|
||||
{ $values { "word" word } { "effect" effect } }
|
||||
{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ;
|
||||
|
||||
{ execute-effect call-effect } related-words
|
||||
{ POSTPONE: call( POSTPONE: execute( } related-words
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math tools.test call kernel ;
|
||||
IN: call.tests
|
||||
|
||||
[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
|
||||
[ 1 2 [ + ] call( -- z ) ] must-fail
|
||||
[ 1 2 [ + ] call( x y -- z a ) ] must-fail
|
||||
[ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test
|
||||
[ [ + ] call( x y -- z ) ] must-infer
|
||||
|
||||
[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test
|
||||
[ 1 2 \ + execute( -- z ) ] must-fail
|
||||
[ 1 2 \ + execute( x y -- z a ) ] must-fail
|
||||
[ \ + execute( x y -- z ) ] must-infer
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel macros fry summary sequences generalizations accessors
|
||||
continuations effects.parser parser words ;
|
||||
IN: call
|
||||
|
||||
ERROR: wrong-values values quot length-required ;
|
||||
|
||||
M: wrong-values summary
|
||||
drop "Wrong number of values returned from quotation" ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: firstn-safe ( array quot n -- ... )
|
||||
3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: call-effect ( effect -- quot )
|
||||
[ in>> length ] [ out>> length ] bi
|
||||
'[ [ _ narray ] dip [ with-datastack ] keep _ firstn-safe ] ;
|
||||
|
||||
: call(
|
||||
")" parse-effect parsed \ call-effect parsed ; parsing
|
||||
|
||||
: execute-effect ( word effect -- )
|
||||
[ [ execute ] curry ] dip call-effect ; inline
|
||||
|
||||
: execute(
|
||||
")" parse-effect parsed \ execute-effect parsed ; parsing
|
||||
|
|
@ -1 +0,0 @@
|
|||
Calling arbitrary quotations and executing arbitrary words with a static stack effect
|
||||
|
|
@ -8,12 +8,6 @@ HELP: <NSString>
|
|||
|
||||
{ <NSString> <CFString> CF>string } related-words
|
||||
|
||||
HELP: <NSArray>
|
||||
{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" alien } }
|
||||
{ $description "Allocates an autoreleased " { $snippet "CFArray" } "." } ;
|
||||
|
||||
{ <NSArray> <CFArray> } related-words
|
||||
|
||||
HELP: with-autorelease-pool
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Sets up a new " { $snippet "NSAutoreleasePool" } ", calls the quotation and frees the pool." } ;
|
||||
|
|
|
|||
|
|
@ -1,27 +1,17 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.syntax io kernel namespaces core-foundation
|
||||
core-foundation.arrays core-foundation.data
|
||||
core-foundation.strings cocoa.messages cocoa cocoa.classes
|
||||
cocoa.runtime sequences threads init summary kernel.private
|
||||
assocs ;
|
||||
IN: cocoa.application
|
||||
|
||||
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
|
||||
: <NSArray> ( seq -- alien ) <CFArray> -> autorelease ;
|
||||
: <NSNumber> ( number -- alien ) <CFNumber> -> autorelease ;
|
||||
: <NSData> ( byte-array -- alien ) <CFData> -> autorelease ;
|
||||
: <NSDictionary> ( assoc -- alien )
|
||||
NSMutableDictionary over assoc-size -> dictionaryWithCapacity:
|
||||
[
|
||||
[
|
||||
spin -> setObject:forKey:
|
||||
] curry assoc-each
|
||||
] keep ;
|
||||
|
||||
CONSTANT: NSApplicationDelegateReplySuccess 0
|
||||
CONSTANT: NSApplicationDelegateReplyCancel 1
|
||||
CONSTANT: NSApplicationDelegateReplyFailure 2
|
||||
C-ENUM:
|
||||
NSApplicationDelegateReplySuccess
|
||||
NSApplicationDelegateReplyCancel
|
||||
NSApplicationDelegateReplyFailure ;
|
||||
|
||||
: with-autorelease-pool ( quot -- )
|
||||
NSAutoreleasePool -> new slip -> release ; inline
|
||||
|
|
@ -45,7 +35,8 @@ FUNCTION: void NSBeep ( ) ;
|
|||
[ NSNotificationCenter -> defaultCenter ] dip
|
||||
-> removeObserver: ;
|
||||
|
||||
: cocoa-app ( quot -- ) [ call NSApp -> run ] with-cocoa ; inline
|
||||
: cocoa-app ( quot -- )
|
||||
[ call NSApp -> run ] with-cocoa ; inline
|
||||
|
||||
: install-delegate ( receiver delegate -- )
|
||||
-> alloc -> init -> setDelegate: ;
|
||||
|
|
|
|||
|
|
@ -44,7 +44,6 @@ $nl
|
|||
{ $subsection "objc-calling" }
|
||||
{ $subsection "objc-subclassing" }
|
||||
"A utility library is built to faciliate the development of Cocoa applications in Factor:"
|
||||
{ $subsection "cocoa-types" }
|
||||
{ $subsection "cocoa-application-utils" }
|
||||
{ $subsection "cocoa-dialogs" }
|
||||
{ $subsection "cocoa-pasteboard-utils" }
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: cocoa.tests
|
||||
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
|
||||
compiler kernel namespaces cocoa.classes tools.test memory
|
||||
compiler.units math ;
|
||||
compiler.units math core-graphics.types ;
|
||||
|
||||
CLASS: {
|
||||
{ +superclass+ "NSObject" }
|
||||
|
|
@ -15,15 +15,15 @@ CLASS: {
|
|||
|
||||
: test-foo
|
||||
Foo -> alloc -> init
|
||||
dup 1.0 2.0 101.0 102.0 <NSRect> -> foo:
|
||||
dup 1.0 2.0 101.0 102.0 <CGRect> -> foo:
|
||||
-> release ;
|
||||
|
||||
test-foo
|
||||
|
||||
[ 1.0 ] [ "x" get NSRect-x ] unit-test
|
||||
[ 2.0 ] [ "x" get NSRect-y ] unit-test
|
||||
[ 101.0 ] [ "x" get NSRect-w ] unit-test
|
||||
[ 102.0 ] [ "x" get NSRect-h ] unit-test
|
||||
[ 1.0 ] [ "x" get CGRect-x ] unit-test
|
||||
[ 2.0 ] [ "x" get CGRect-y ] unit-test
|
||||
[ 101.0 ] [ "x" get CGRect-w ] unit-test
|
||||
[ 102.0 ] [ "x" get CGRect-h ] unit-test
|
||||
|
||||
CLASS: {
|
||||
{ +superclass+ "NSObject" }
|
||||
|
|
@ -41,10 +41,10 @@ Bar [
|
|||
-> release
|
||||
] compile-call
|
||||
|
||||
[ 1.0 ] [ "x" get NSRect-x ] unit-test
|
||||
[ 2.0 ] [ "x" get NSRect-y ] unit-test
|
||||
[ 101.0 ] [ "x" get NSRect-w ] unit-test
|
||||
[ 102.0 ] [ "x" get NSRect-h ] unit-test
|
||||
[ 1.0 ] [ "x" get CGRect-x ] unit-test
|
||||
[ 2.0 ] [ "x" get CGRect-y ] unit-test
|
||||
[ 101.0 ] [ "x" get CGRect-w ] unit-test
|
||||
[ 102.0 ] [ "x" get CGRect-h ] unit-test
|
||||
|
||||
! Make sure that we can add methods
|
||||
CLASS: {
|
||||
|
|
|
|||
|
|
@ -8,12 +8,11 @@ IN: cocoa.enumeration
|
|||
CONSTANT: NS-EACH-BUFFER-SIZE 16
|
||||
|
||||
: with-enumeration-buffers ( quot -- )
|
||||
[
|
||||
[
|
||||
"NSFastEnumerationState" malloc-object &free
|
||||
NS-EACH-BUFFER-SIZE "id" heap-size * malloc-object &free
|
||||
NS-EACH-BUFFER-SIZE
|
||||
] dip call
|
||||
'[
|
||||
"NSFastEnumerationState" malloc-object &free
|
||||
NS-EACH-BUFFER-SIZE "id" malloc-array &free
|
||||
NS-EACH-BUFFER-SIZE
|
||||
@
|
||||
] with-destructors ; inline
|
||||
|
||||
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ continuations combinators compiler compiler.alien stack-checker kernel
|
|||
math namespaces make parser quotations sequences strings words
|
||||
cocoa.runtime io macros memoize io.encodings.utf8 effects libc
|
||||
libc.private parser lexer init core-foundation fry generalizations
|
||||
specialized-arrays.direct.alien call ;
|
||||
specialized-arrays.direct.alien ;
|
||||
IN: cocoa.messages
|
||||
|
||||
: make-sender ( method function -- quot )
|
||||
|
|
@ -167,13 +167,19 @@ assoc-union alien>objc-types set-global
|
|||
drop "void*"
|
||||
] unless ;
|
||||
|
||||
ERROR: no-objc-type name ;
|
||||
|
||||
: decode-type ( ch -- ctype )
|
||||
1string dup objc>alien-types get at
|
||||
[ ] [ no-objc-type ] ?if ;
|
||||
|
||||
: (parse-objc-type) ( i string -- ctype )
|
||||
[ [ 1+ ] dip ] [ nth ] 2bi {
|
||||
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
|
||||
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
|
||||
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
|
||||
{ [ dup CHAR: [ = ] [ 3drop "void*" ] }
|
||||
[ 2nip 1string objc>alien-types get at ]
|
||||
[ 2nip decode-type ]
|
||||
} cond ;
|
||||
|
||||
: parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.accessors arrays kernel cocoa.messages
|
||||
cocoa.classes cocoa.application sequences cocoa core-foundation
|
||||
|
|
@ -15,7 +15,7 @@ CONSTANT: NSStringPboardType "NSStringPboardType"
|
|||
dup [ CF>string ] when ;
|
||||
|
||||
: set-pasteboard-types ( seq pasteboard -- )
|
||||
swap <NSArray> f -> declareTypes:owner: drop ;
|
||||
swap <CFArray> -> autorelease f -> declareTypes:owner: drop ;
|
||||
|
||||
: set-pasteboard-string ( str pasteboard -- )
|
||||
NSStringPboardType <NSString>
|
||||
|
|
|
|||
|
|
@ -0,0 +1,40 @@
|
|||
IN: cocoa.plists.tests
|
||||
USING: tools.test cocoa.plists colors kernel hashtables
|
||||
core-foundation.utilities core-foundation destructors
|
||||
assocs cocoa.enumeration ;
|
||||
|
||||
[
|
||||
[ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test
|
||||
[ V{ "A" } ] [ { "A" } >cf &CFRelease plist> ] unit-test
|
||||
[ H{ { "A" "B" } } ] [ "B" "A" associate >cf &CFRelease plist> ] unit-test
|
||||
[ H{ { "A" "B" } } ] [ "B" "A" associate >cf &CFRelease plist> ] unit-test
|
||||
|
||||
[ t ] [
|
||||
{
|
||||
H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 4 } }
|
||||
H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 5 } }
|
||||
H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 6 } }
|
||||
} [ >cf &CFRelease ] [ >cf &CFRelease ] bi
|
||||
[ plist> ] bi@ =
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
{ "DeviceUsagePage" 1 }
|
||||
[ >cf &CFRelease ] [ >cf &CFRelease ] bi
|
||||
[ plist> ] bi@ =
|
||||
] unit-test
|
||||
|
||||
[ V{ "DeviceUsagePage" "Yes" } ] [
|
||||
{ "DeviceUsagePage" "Yes" }
|
||||
>cf &CFRelease plist>
|
||||
] unit-test
|
||||
|
||||
[ V{ 2.0 1.0 } ] [
|
||||
{ 2.0 1.0 }
|
||||
>cf &CFRelease plist>
|
||||
] unit-test
|
||||
|
||||
[ 3.5 ] [
|
||||
3.5 >cf &CFRelease plist>
|
||||
] unit-test
|
||||
] with-destructors
|
||||
|
|
@ -1,68 +1,60 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: strings arrays hashtables assocs sequences
|
||||
USING: strings arrays hashtables assocs sequences fry macros
|
||||
cocoa.messages cocoa.classes cocoa.application cocoa kernel
|
||||
namespaces io.backend math cocoa.enumeration byte-arrays
|
||||
combinators alien.c-types core-foundation core-foundation.data ;
|
||||
combinators alien.c-types words core-foundation
|
||||
core-foundation.data core-foundation.utilities ;
|
||||
IN: cocoa.plists
|
||||
|
||||
GENERIC: >plist ( value -- plist )
|
||||
|
||||
M: number >plist
|
||||
<NSNumber> ;
|
||||
M: t >plist
|
||||
<NSNumber> ;
|
||||
M: f >plist
|
||||
<NSNumber> ;
|
||||
M: string >plist
|
||||
<NSString> ;
|
||||
M: byte-array >plist
|
||||
<NSData> ;
|
||||
M: hashtable >plist
|
||||
[ [ >plist ] bi@ ] assoc-map <NSDictionary> ;
|
||||
M: sequence >plist
|
||||
[ >plist ] map <NSArray> ;
|
||||
: >plist ( value -- plist ) >cf -> autorelease ;
|
||||
|
||||
: write-plist ( assoc path -- )
|
||||
[ >plist ] [ normalize-path <NSString> ] bi* 0
|
||||
-> writeToFile:atomically:
|
||||
[ >plist ] [ normalize-path <NSString> ] bi* 0 -> writeToFile:atomically:
|
||||
[ "write-plist failed" throw ] unless ;
|
||||
|
||||
DEFER: plist>
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (plist-NSString>) ( NSString -- string )
|
||||
-> UTF8String ;
|
||||
|
||||
: (plist-NSNumber>) ( NSNumber -- number )
|
||||
dup -> doubleValue dup >integer =
|
||||
[ -> longLongValue ]
|
||||
[ -> doubleValue ] if ;
|
||||
[ -> longLongValue ] [ -> doubleValue ] if ;
|
||||
|
||||
: (plist-NSData>) ( NSData -- byte-array )
|
||||
dup -> length <byte-array> [ -> getBytes: ] keep ;
|
||||
|
||||
: (plist-NSArray>) ( NSArray -- vector )
|
||||
[ plist> ] NSFastEnumeration-map ;
|
||||
[ plist> ] NSFastEnumeration-map ;
|
||||
|
||||
: (plist-NSDictionary>) ( NSDictionary -- hashtable )
|
||||
dup [ [ -> valueForKey: ] keep swap [ plist> ] bi@ 2array ] with
|
||||
dup [ [ nip ] [ -> valueForKey: ] 2bi [ plist> ] bi@ 2array ] with
|
||||
NSFastEnumeration-map >hashtable ;
|
||||
|
||||
: plist> ( plist -- value )
|
||||
{
|
||||
{ [ dup NSString -> isKindOfClass: c-bool> ] [ (plist-NSString>) ] }
|
||||
{ [ dup NSNumber -> isKindOfClass: c-bool> ] [ (plist-NSNumber>) ] }
|
||||
{ [ dup NSData -> isKindOfClass: c-bool> ] [ (plist-NSData>) ] }
|
||||
{ [ dup NSArray -> isKindOfClass: c-bool> ] [ (plist-NSArray>) ] }
|
||||
{ [ dup NSDictionary -> isKindOfClass: c-bool> ] [ (plist-NSDictionary>) ] }
|
||||
[ ]
|
||||
} cond ;
|
||||
|
||||
: (read-plist) ( NSData -- id )
|
||||
NSPropertyListSerialization swap kCFPropertyListImmutable f f <void*>
|
||||
[ -> propertyListFromData:mutabilityOption:format:errorDescription: ] keep
|
||||
*void* [ -> release "read-plist failed" throw ] when* ;
|
||||
|
||||
MACRO: objc-class-case ( alist -- quot )
|
||||
[ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: plist> ( plist -- value )
|
||||
{
|
||||
{ NSString [ (plist-NSString>) ] }
|
||||
{ NSNumber [ (plist-NSNumber>) ] }
|
||||
{ NSData [ (plist-NSData>) ] }
|
||||
{ NSArray [ (plist-NSArray>) ] }
|
||||
{ NSDictionary [ (plist-NSDictionary>) ] }
|
||||
{ NSObject [ ] }
|
||||
} objc-class-case ;
|
||||
|
||||
: read-plist ( path -- assoc )
|
||||
normalize-path <NSString>
|
||||
NSData swap -> dataWithContentsOfFile:
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ IN: cocoa.subclassing
|
|||
|
||||
: init-method ( method -- sel imp types )
|
||||
first3 swap
|
||||
[ sel_registerName ] [ execute ] [ utf8 string>alien ]
|
||||
[ sel_registerName ] [ execute( -- xt ) ] [ utf8 string>alien ]
|
||||
tri* ;
|
||||
|
||||
: throw-if-false ( obj what -- )
|
||||
|
|
@ -32,10 +32,11 @@ IN: cocoa.subclassing
|
|||
[ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
|
||||
tri ;
|
||||
|
||||
: encode-type ( type -- encoded )
|
||||
dup alien>objc-types get at [ ] [ no-objc-type ] ?if ;
|
||||
|
||||
: encode-types ( return types -- encoding )
|
||||
swap prefix [
|
||||
alien>objc-types get at "0" append
|
||||
] map concat ;
|
||||
swap prefix [ encode-type "0" append ] map concat ;
|
||||
|
||||
: prepare-method ( ret types quot -- type imp )
|
||||
[ [ encode-types ] 2keep ] dip
|
||||
|
|
|
|||
|
|
@ -1,29 +0,0 @@
|
|||
USING: math help.markup help.syntax ;
|
||||
IN: cocoa.types
|
||||
|
||||
HELP: <NSRect>
|
||||
{ $values { "x" real } { "y" real } { "w" real } { "h" real } { "rect" "an " { $snippet "NSRect" } } }
|
||||
{ $description "Allocates a new " { $snippet "NSRect" } " in the Factor heap." } ;
|
||||
|
||||
HELP: <NSPoint>
|
||||
{ $values { "x" real } { "y" real } { "point" "an " { $snippet "NSPoint" } } }
|
||||
{ $description "Allocates a new " { $snippet "NSPoint" } " in the Factor heap." } ;
|
||||
|
||||
HELP: <NSSize>
|
||||
{ $values { "w" real } { "h" real } { "size" "an " { $snippet "NSSize" } } }
|
||||
{ $description "Allocates a new " { $snippet "NSSize" } " in the Factor heap." } ;
|
||||
|
||||
ARTICLE: "cocoa-types" "Cocoa types"
|
||||
"The Cocoa binding defines some common C structs:"
|
||||
{ $code
|
||||
"NSRect"
|
||||
"NSPoint"
|
||||
"NSSize"
|
||||
}
|
||||
"Some words for working with the above:"
|
||||
{ $subsection <NSRect> }
|
||||
{ $subsection <NSPoint> }
|
||||
{ $subsection <NSSize> } ;
|
||||
|
||||
IN: cocoa.types
|
||||
ABOUT: "cocoa-types"
|
||||
|
|
@ -1,73 +1,20 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov
|
||||
! Copyright (C) 2006, 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types alien.syntax combinators kernel ;
|
||||
USING: alien.c-types alien.syntax combinators kernel layouts
|
||||
core-graphics.types ;
|
||||
IN: cocoa.types
|
||||
|
||||
TYPEDEF: long NSInteger
|
||||
TYPEDEF: ulong NSUInteger
|
||||
<< "ptrdiff_t" heap-size {
|
||||
{ 4 [ "float" ] }
|
||||
{ 8 [ "double" ] }
|
||||
} case "CGFloat" typedef >>
|
||||
|
||||
C-STRUCT: NSPoint
|
||||
{ "CGFloat" "x" }
|
||||
{ "CGFloat" "y" } ;
|
||||
|
||||
TYPEDEF: CGPoint NSPoint
|
||||
TYPEDEF: NSPoint _NSPoint
|
||||
TYPEDEF: NSPoint CGPoint
|
||||
|
||||
: <NSPoint> ( x y -- point )
|
||||
"NSPoint" <c-object>
|
||||
[ set-NSPoint-y ] keep
|
||||
[ set-NSPoint-x ] keep ;
|
||||
|
||||
C-STRUCT: NSSize
|
||||
{ "CGFloat" "w" }
|
||||
{ "CGFloat" "h" } ;
|
||||
|
||||
TYPEDEF: CGSize NSSize
|
||||
TYPEDEF: NSSize _NSSize
|
||||
TYPEDEF: NSSize CGSize
|
||||
|
||||
: <NSSize> ( w h -- size )
|
||||
"NSSize" <c-object>
|
||||
[ set-NSSize-h ] keep
|
||||
[ set-NSSize-w ] keep ;
|
||||
|
||||
C-STRUCT: NSRect
|
||||
{ "NSPoint" "origin" }
|
||||
{ "NSSize" "size" } ;
|
||||
|
||||
TYPEDEF: CGRect NSRect
|
||||
TYPEDEF: NSRect _NSRect
|
||||
TYPEDEF: NSRect CGRect
|
||||
|
||||
: NSRect-x ( NSRect -- x )
|
||||
NSRect-origin NSPoint-x ; inline
|
||||
: NSRect-y ( NSRect -- y )
|
||||
NSRect-origin NSPoint-y ; inline
|
||||
: NSRect-w ( NSRect -- w )
|
||||
NSRect-size NSSize-w ; inline
|
||||
: NSRect-h ( NSRect -- h )
|
||||
NSRect-size NSSize-h ; inline
|
||||
|
||||
: set-NSRect-x ( x NSRect -- )
|
||||
NSRect-origin set-NSPoint-x ; inline
|
||||
: set-NSRect-y ( y NSRect -- )
|
||||
NSRect-origin set-NSPoint-y ; inline
|
||||
: set-NSRect-w ( w NSRect -- )
|
||||
NSRect-size set-NSSize-w ; inline
|
||||
: set-NSRect-h ( h NSRect -- )
|
||||
NSRect-size set-NSSize-h ; inline
|
||||
|
||||
: <NSRect> ( x y w h -- rect )
|
||||
"NSRect" <c-object>
|
||||
[ set-NSRect-h ] keep
|
||||
[ set-NSRect-w ] keep
|
||||
[ set-NSRect-y ] keep
|
||||
[ set-NSRect-x ] keep ;
|
||||
|
||||
: NSRect-x-y ( alien -- origin-x origin-y )
|
||||
[ NSRect-x ] keep NSRect-y ;
|
||||
|
||||
C-STRUCT: NSRange
|
||||
{ "NSUInteger" "location" }
|
||||
|
|
@ -85,14 +32,6 @@ TYPEDEF: void* unknown_type
|
|||
[ set-NSRange-length ] keep
|
||||
[ set-NSRange-location ] keep ;
|
||||
|
||||
C-STRUCT: CGAffineTransform
|
||||
{ "CGFloat" "a" }
|
||||
{ "CGFloat" "b" }
|
||||
{ "CGFloat" "c" }
|
||||
{ "CGFloat" "d" }
|
||||
{ "CGFloat" "tx" }
|
||||
{ "CGFloat" "ty" } ;
|
||||
|
||||
C-STRUCT: NSFastEnumerationState
|
||||
{ "ulong" "state" }
|
||||
{ "id*" "itemsPtr" }
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov
|
||||
! Copyright (C) 2006, 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: specialized-arrays.int arrays kernel math namespaces make
|
||||
cocoa cocoa.messages cocoa.classes cocoa.types sequences
|
||||
continuations accessors ;
|
||||
cocoa cocoa.messages cocoa.classes core-graphics
|
||||
core-graphics.types sequences continuations accessors ;
|
||||
IN: cocoa.views
|
||||
|
||||
CONSTANT: NSOpenGLPFAAllRenderers 1
|
||||
|
|
@ -40,29 +40,29 @@ CONSTANT: NSOpenGLPFAScreenMask 84
|
|||
CONSTANT: NSOpenGLPFAPixelBuffer 90
|
||||
CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
|
||||
CONSTANT: NSOpenGLPFAVirtualScreenCount 128
|
||||
|
||||
CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
|
||||
CONSTANT: NSOpenGLCPSwapInterval 222
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: +software-renderer+
|
||||
SYMBOL: +multisample+
|
||||
SYMBOL: software-renderer?
|
||||
SYMBOL: multisample?
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: with-software-renderer ( quot -- )
|
||||
t +software-renderer+ pick with-variable ; inline
|
||||
[ t software-renderer? ] dip with-variable ; inline
|
||||
|
||||
: with-multisample ( quot -- )
|
||||
t +multisample+ pick with-variable ; inline
|
||||
[ t multisample? ] dip with-variable ; inline
|
||||
|
||||
: <PixelFormat> ( attributes -- pixelfmt )
|
||||
NSOpenGLPixelFormat -> alloc swap [
|
||||
%
|
||||
NSOpenGLPFADepthSize , 16 ,
|
||||
+software-renderer+ get [
|
||||
software-renderer? get [
|
||||
NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
|
||||
] when
|
||||
+multisample+ get [
|
||||
multisample? get [
|
||||
NSOpenGLPFASupersample ,
|
||||
NSOpenGLPFASampleBuffers , 1 ,
|
||||
NSOpenGLPFASamples , 8 ,
|
||||
|
|
@ -73,7 +73,7 @@ PRIVATE>
|
|||
-> autorelease ;
|
||||
|
||||
: <GLView> ( class dim -- view )
|
||||
[ -> alloc 0 0 ] dip first2 <NSRect>
|
||||
[ -> alloc 0 0 ] dip first2 <CGRect>
|
||||
NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array <PixelFormat>
|
||||
-> initWithFrame:pixelFormat:
|
||||
dup 1 -> setPostsBoundsChangedNotifications:
|
||||
|
|
@ -81,26 +81,12 @@ PRIVATE>
|
|||
|
||||
: view-dim ( view -- dim )
|
||||
-> bounds
|
||||
dup NSRect-w >fixnum
|
||||
swap NSRect-h >fixnum 2array ;
|
||||
[ CGRect-w >fixnum ] [ CGRect-h >fixnum ] bi
|
||||
2array ;
|
||||
|
||||
: mouse-location ( view event -- loc )
|
||||
[
|
||||
-> locationInWindow f -> convertPoint:fromView:
|
||||
[ NSPoint-x ] [ NSPoint-y ] bi
|
||||
] [ drop -> frame NSRect-h ] 2bi
|
||||
[ CGPoint-x ] [ CGPoint-y ] bi
|
||||
] [ drop -> frame CGRect-h ] 2bi
|
||||
swap - 2array ;
|
||||
|
||||
USE: opengl.gl
|
||||
USE: alien.syntax
|
||||
|
||||
CONSTANT: NSOpenGLCPSwapInterval 222
|
||||
|
||||
LIBRARY: OpenGL
|
||||
|
||||
TYPEDEF: int CGLError
|
||||
TYPEDEF: void* CGLContextObj
|
||||
TYPEDEF: int CGLContextParameter
|
||||
|
||||
FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,39 @@
|
|||
IN: colors
|
||||
USING: accessors help.markup help.syntax ;
|
||||
|
||||
HELP: color
|
||||
{ $class-description "The class of colors. Implementations include " { $link rgba } ", " { $vocab-link "colors.gray" } " and " { $vocab-link "colors.hsv" } "." } ;
|
||||
|
||||
HELP: rgba
|
||||
{ $class-description "The class of colors with red, green, blue and alpha channel components. The slots store color components, which are real numbers in the range 0 to 1, inclusive." } ;
|
||||
|
||||
HELP: >rgba
|
||||
{ $values { "color" color } { "rgba" rgba } }
|
||||
{ $contract "Converts a color to an RGBA color." } ;
|
||||
|
||||
ARTICLE: "colors.protocol" "Color protocol"
|
||||
"Abstract superclass for colors:"
|
||||
{ $subsection color }
|
||||
"All color objects must are required to implement a method on the " { $link >rgba } " generic word."
|
||||
$nl
|
||||
"Optionally, they can provide methods on the accessors " { $link red>> } ", " { $link green>> } ", " { $link blue>> } " and " { $link alpha>> } ", either by defining slots with the appropriate names, or with methods which calculate the color component values. The accessors should return color components which are real numbers in the range between 0 and 1."
|
||||
$nl
|
||||
"Overriding the accessors is purely an optimization, since the default implementations call " { $link >rgba } " and then extract the appropriate component of the result." ;
|
||||
|
||||
ARTICLE: "colors" "Colors"
|
||||
"The " { $vocab-link "colors" } " vocabulary defines a protocol for colors, with a concrete implementation for RGBA colors. This vocabulary is used by " { $vocab-link "io.styles" } ", " { $vocab-link "ui" } " and other vocabularies, but it is independent of them."
|
||||
$nl
|
||||
"RGBA colors:"
|
||||
{ $subsection rgba }
|
||||
{ $subsection <rgba> }
|
||||
"Converting a color to RGBA:"
|
||||
{ $subsection >rgba }
|
||||
"Extracting RGBA components of colors:"
|
||||
{ $subsection >rgba-components }
|
||||
"Further topics:"
|
||||
{ $subsection "colors.protocol" }
|
||||
{ $subsection "colors.constants" }
|
||||
{ $vocab-subsection "Grayscale colors" "colors.gray" }
|
||||
{ $vocab-subsection "HSV colors" "colors.hsv" } ;
|
||||
|
||||
ABOUT: "colors"
|
||||
|
|
@ -1,33 +1,30 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! Copyright (C) 2003, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008 Eduardo Cavazos.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors ;
|
||||
USING: kernel accessors combinators math ;
|
||||
IN: colors
|
||||
|
||||
TUPLE: color ;
|
||||
|
||||
TUPLE: rgba < color red green blue alpha ;
|
||||
TUPLE: rgba < color
|
||||
{ red read-only }
|
||||
{ green read-only }
|
||||
{ blue read-only }
|
||||
{ alpha read-only } ;
|
||||
|
||||
C: <rgba> rgba
|
||||
|
||||
GENERIC: >rgba ( object -- rgba )
|
||||
GENERIC: >rgba ( color -- rgba )
|
||||
|
||||
M: rgba >rgba ( rgba -- rgba ) ;
|
||||
|
||||
M: color red>> ( color -- red ) >rgba red>> ;
|
||||
M: color red>> ( color -- red ) >rgba red>> ;
|
||||
M: color green>> ( color -- green ) >rgba green>> ;
|
||||
M: color blue>> ( color -- blue ) >rgba blue>> ;
|
||||
M: color blue>> ( color -- blue ) >rgba blue>> ;
|
||||
|
||||
CONSTANT: black T{ rgba f 0.0 0.0 0.0 1.0 }
|
||||
CONSTANT: blue T{ rgba f 0.0 0.0 1.0 1.0 }
|
||||
CONSTANT: cyan T{ rgba f 0 0.941 0.941 1 }
|
||||
CONSTANT: gray T{ rgba f 0.6 0.6 0.6 1.0 }
|
||||
CONSTANT: green T{ rgba f 0.0 1.0 0.0 1.0 }
|
||||
CONSTANT: light-gray T{ rgba f 0.95 0.95 0.95 0.95 }
|
||||
CONSTANT: light-purple T{ rgba f 0.8 0.8 1.0 1.0 }
|
||||
CONSTANT: magenta T{ rgba f 0.941 0 0.941 1 }
|
||||
CONSTANT: orange T{ rgba f 0.941 0.627 0 1 }
|
||||
CONSTANT: purple T{ rgba f 0.627 0 0.941 1 }
|
||||
CONSTANT: red T{ rgba f 1.0 0.0 0.0 1.0 }
|
||||
CONSTANT: white T{ rgba f 1.0 1.0 1.0 1.0 }
|
||||
CONSTANT: yellow T{ rgba f 1.0 1.0 0.0 1.0 }
|
||||
: >rgba-components ( object -- r g b a )
|
||||
>rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline
|
||||
|
||||
: opaque? ( color -- ? ) alpha>> 1 number= ;
|
||||
|
||||
CONSTANT: transparent T{ rgba f 0.0 0.0 0.0 0.0 }
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
IN: colors.constants
|
||||
USING: help.markup help.syntax strings colors ;
|
||||
|
||||
HELP: named-color
|
||||
{ $values { "name" string } { "color" color } }
|
||||
{ $description "Outputs a named color from the " { $snippet "rgb.txt" } " database." }
|
||||
{ $notes "In most cases, " { $link POSTPONE: COLOR: } " should be used instead." }
|
||||
{ $errors "Throws an error if the color is not listed in " { $snippet "rgb.txt" } "." } ;
|
||||
|
||||
HELP: named-colors
|
||||
{ $values { "keys" "a sequence of strings" } }
|
||||
{ $description "Outputs a sequence of all colors in the " { $snippet "rgb.txt" } " database." } ;
|
||||
|
||||
HELP: COLOR:
|
||||
{ $syntax "COLOR: name" }
|
||||
{ $description "Parses as a " { $link color } " object with the given name." }
|
||||
{ $errors "Throws an error if the color is not listed in " { $snippet "rgb.txt" } "." }
|
||||
{ $examples
|
||||
{ $code
|
||||
"USING: colors.constants io.styles ;"
|
||||
"\"Hello!\" { { foreground COLOR: cyan } } format nl"
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "colors.constants" "Standard color database"
|
||||
"The " { $vocab-link "colors.constants" } " vocabulary bundles the X11 " { $snippet "rgb.txt" } " database and provides words for looking up color values."
|
||||
{ $subsection named-color }
|
||||
{ $subsection named-colors }
|
||||
{ $subsection POSTPONE: COLOR: } ;
|
||||
|
||||
ABOUT: "colors.constants"
|
||||
|
|
@ -23,9 +23,11 @@ MEMO: rgb.txt ( -- assoc )
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: named-colors ( -- keys ) rgb.txt keys ;
|
||||
|
||||
ERROR: no-such-color name ;
|
||||
|
||||
: named-color ( name -- rgb )
|
||||
: named-color ( name -- color )
|
||||
dup rgb.txt at [ ] [ no-such-color ] ?if ;
|
||||
|
||||
: COLOR: scan named-color parsed ; parsing
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
USING: help.markup help.syntax accessors ;
|
||||
IN: colors.gray
|
||||
|
||||
ARTICLE: "colors.gray" "Grayscale colors"
|
||||
"The " { $vocab-link "colors.gray" } " vocabulary implements grayscale colors. These colors hold a single value, and respond to " { $link red>> } ", " { $link green>> } ", " { $link blue>> } " with that value. They also have an independent alpha channel, " { $link alpha>> } "."
|
||||
{ $subsection gray }
|
||||
{ $subsection <gray> } ;
|
||||
|
||||
ABOUT: "colors.gray"
|
||||
|
|
@ -3,9 +3,15 @@
|
|||
USING: colors kernel accessors ;
|
||||
IN: colors.gray
|
||||
|
||||
TUPLE: gray < color gray alpha ;
|
||||
TUPLE: gray < color { gray read-only } { alpha read-only } ;
|
||||
|
||||
C: <gray> gray
|
||||
|
||||
M: gray >rgba ( gray -- rgba )
|
||||
[ gray>> dup dup ] [ alpha>> ] bi <rgba> ;
|
||||
|
||||
M: gray red>> gray>> ;
|
||||
|
||||
M: gray green>> gray>> ;
|
||||
|
||||
M: gray blue>> gray>> ;
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
IN: colors.hsv
|
||||
USING: help.markup help.syntax ;
|
||||
|
||||
HELP: hsva
|
||||
{ $class-description "The class of HSV (Hue, Saturation, Value) colors with an alpha channel. The " { $slot "hue" } " slot stores a value in the interval " { $snippet "[0,360]" } " and the remaining slots store values in the interval " { $snippet "[0,1]" } "." } ;
|
||||
|
||||
ARTICLE: "colors.hsv" "HSV colors"
|
||||
"The " { $vocab-link "colors.hsv" } " vocabulary implements colors specified by their hue, saturation, and value, together with an alpha channel."
|
||||
{ $subsection hsva }
|
||||
{ $subsection <hsva> }
|
||||
{ $see-also "colors" } ;
|
||||
|
||||
ABOUT: "colors.hsv"
|
||||
|
|
@ -24,3 +24,5 @@ USING: accessors kernel colors colors.hsv tools.test math ;
|
|||
|
||||
[ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
|
||||
[ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test
|
||||
|
||||
[ 0.5 ] [ 180 0.1 0.2 0.5 <hsva> alpha>> ] unit-test
|
||||
|
|
@ -6,7 +6,7 @@ IN: colors.hsv
|
|||
! h [0,360)
|
||||
! s [0,1]
|
||||
! v [0,1]
|
||||
TUPLE: hsva < color hue saturation value alpha ;
|
||||
TUPLE: hsva < color { hue read-only } { saturation read-only } { value read-only } { alpha read-only } ;
|
||||
|
||||
C: <hsva> hsva
|
||||
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ SYMBOL: main-vocab-hook
|
|||
embedded? [
|
||||
"alien.remote-control"
|
||||
] [
|
||||
main-vocab-hook get [ call ] [ "listener" ] if*
|
||||
main-vocab-hook get [ call( -- vocab ) ] [ "listener" ] if*
|
||||
] if ;
|
||||
|
||||
: default-cli-args ( -- )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes.tuple classes.tuple.parser kernel words
|
||||
make fry sequences parser accessors ;
|
||||
make fry sequences parser accessors effects ;
|
||||
IN: compiler.cfg.instructions.syntax
|
||||
|
||||
: insn-word ( -- word )
|
||||
|
|
@ -11,7 +11,7 @@ IN: compiler.cfg.instructions.syntax
|
|||
"insn" "compiler.cfg.instructions" lookup ;
|
||||
|
||||
: insn-effect ( word -- effect )
|
||||
boa-effect [ but-last ] change-in { } >>out ;
|
||||
boa-effect in>> but-last f <effect> ;
|
||||
|
||||
: INSN:
|
||||
parse-tuple-definition "regs" suffix
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
ds-push ;
|
||||
|
||||
: emit-fixnum-comparison ( node cc -- )
|
||||
[ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi
|
||||
[ ^^compare ] [ ^^compare-imm ] bi-curry
|
||||
emit-fixnum-op ;
|
||||
|
||||
: emit-bignum>fixnum ( -- )
|
||||
|
|
|
|||
|
|
@ -28,15 +28,14 @@ IN: compiler.cfg.intrinsics.slots
|
|||
] [ drop emit-primitive ] if ;
|
||||
|
||||
: (emit-set-slot) ( infos -- obj-reg )
|
||||
[ 3inputs [ tuck ] dip ^^offset>slot ]
|
||||
[ second value-tag ]
|
||||
bi* ^^set-slot ;
|
||||
[ 3inputs ^^offset>slot ] [ second value-tag ] bi*
|
||||
pick [ ^^set-slot ] dip ;
|
||||
|
||||
: (emit-set-slot-imm) ( infos -- obj-reg )
|
||||
ds-drop
|
||||
[ 2inputs tuck ]
|
||||
[ 2inputs ]
|
||||
[ [ third literal>> ] [ second value-tag ] bi ] bi*
|
||||
##set-slot-imm ;
|
||||
pick [ ##set-slot-imm ] dip ;
|
||||
|
||||
: emit-set-slot ( node -- )
|
||||
dup node-input-infos
|
||||
|
|
|
|||
|
|
@ -105,7 +105,7 @@ SYMBOL: spill-counts
|
|||
#! If it has been spilled already, reuse spill location.
|
||||
over reload-from>>
|
||||
[ over vreg>> reg-class>> next-spill-location ] unless*
|
||||
tuck [ >>spill-to ] [ >>reload-from ] 2bi* ;
|
||||
[ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
|
||||
|
||||
: split-and-spill ( new existing -- before after )
|
||||
dup rot start>> split-interval
|
||||
|
|
|
|||
|
|
@ -464,7 +464,7 @@ TUPLE: callback-context ;
|
|||
dup current-callback eq? [
|
||||
drop
|
||||
] [
|
||||
yield-hook get call wait-to-return
|
||||
yield-hook get call( -- ) wait-to-return
|
||||
] if ;
|
||||
|
||||
: do-callback ( quot token -- )
|
||||
|
|
|
|||
|
|
@ -12,8 +12,6 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
|
|||
"Normally, new word definitions are recompiled automatically. This can be changed:"
|
||||
{ $subsection disable-compiler }
|
||||
{ $subsection enable-compiler }
|
||||
"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:"
|
||||
{ $subsection optimized-recompile-hook }
|
||||
"Removing a word's optimized definition:"
|
||||
{ $subsection decompile }
|
||||
"Compiling a single quotation:"
|
||||
|
|
@ -46,9 +44,8 @@ HELP: (compile)
|
|||
{ $description "Compile a single word." }
|
||||
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
|
||||
|
||||
HELP: optimized-recompile-hook
|
||||
{ $values { "words" "a sequence of words" } { "alist" "an association list" } }
|
||||
{ $description "Compile a set of words." }
|
||||
HELP: optimizing-compiler
|
||||
{ $description "Singleton class implementing " { $link recompile } " to call the optimizing compiler." }
|
||||
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
|
||||
|
||||
HELP: compile-call
|
||||
|
|
|
|||
|
|
@ -1,15 +1,14 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces arrays sequences io words fry
|
||||
continuations vocabs assocs dlists definitions math graphs
|
||||
generic combinators deques search-deques io stack-checker
|
||||
stack-checker.state stack-checker.inlining
|
||||
combinators.short-circuit compiler.errors compiler.units
|
||||
compiler.tree.builder compiler.tree.optimizer
|
||||
compiler.cfg.builder compiler.cfg.optimizer
|
||||
continuations vocabs assocs dlists definitions math graphs generic
|
||||
combinators deques search-deques macros io stack-checker
|
||||
stack-checker.state stack-checker.inlining combinators.short-circuit
|
||||
compiler.errors compiler.units compiler.tree.builder
|
||||
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
|
||||
compiler.cfg.linearization compiler.cfg.two-operand
|
||||
compiler.cfg.linear-scan compiler.cfg.stack-frame
|
||||
compiler.codegen compiler.utilities ;
|
||||
compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
|
||||
compiler.utilities ;
|
||||
IN: compiler
|
||||
|
||||
SYMBOL: compile-queue
|
||||
|
|
@ -50,8 +49,12 @@ SYMBOLS: +optimized+ +unoptimized+ ;
|
|||
H{ } clone generic-dependencies set
|
||||
f swap compiler-error ;
|
||||
|
||||
: ignore-error? ( word error -- ? )
|
||||
[ [ inline? ] [ macro? ] bi or ]
|
||||
[ compiler-error-type +warning+ eq? ] bi* and ;
|
||||
|
||||
: fail ( word error -- * )
|
||||
[ swap compiler-error ]
|
||||
[ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
|
||||
[
|
||||
drop
|
||||
[ compiled-unxref ]
|
||||
|
|
@ -108,7 +111,7 @@ t compile-dependencies? set-global
|
|||
] with-return ;
|
||||
|
||||
: compile-loop ( deque -- )
|
||||
[ (compile) yield-hook get call ] slurp-deque ;
|
||||
[ (compile) yield-hook get call( -- ) ] slurp-deque ;
|
||||
|
||||
: decompile ( word -- )
|
||||
f 2array 1array modify-code-heap ;
|
||||
|
|
@ -116,7 +119,9 @@ t compile-dependencies? set-global
|
|||
: compile-call ( quot -- )
|
||||
[ dup infer define-temp ] with-compilation-unit execute ;
|
||||
|
||||
: optimized-recompile-hook ( words -- alist )
|
||||
SINGLETON: optimizing-compiler
|
||||
|
||||
M: optimizing-compiler recompile ( words -- alist )
|
||||
[
|
||||
<hashed-dlist> compile-queue set
|
||||
H{ } clone compiled set
|
||||
|
|
@ -126,10 +131,10 @@ t compile-dependencies? set-global
|
|||
] with-scope ;
|
||||
|
||||
: enable-compiler ( -- )
|
||||
[ optimized-recompile-hook ] recompile-hook set-global ;
|
||||
optimizing-compiler compiler-impl set-global ;
|
||||
|
||||
: disable-compiler ( -- )
|
||||
[ default-recompile-hook ] recompile-hook set-global ;
|
||||
f compiler-impl set-global ;
|
||||
|
||||
: recompile-all ( -- )
|
||||
forget-errors all-words compile ;
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ CONSTANT: deck-bits 18
|
|||
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
|
||||
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
|
||||
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
|
||||
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
|
||||
: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline
|
||||
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
|
||||
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
|
||||
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
|
||||
|
|
|
|||
|
|
@ -1,24 +1,42 @@
|
|||
USING: accessors compiler compiler.units tools.test math parser
|
||||
kernel sequences sequences.private classes.mixin generic
|
||||
definitions arrays words assocs eval ;
|
||||
definitions arrays words assocs eval strings ;
|
||||
IN: compiler.tests
|
||||
|
||||
GENERIC: method-redefine-test ( a -- b )
|
||||
GENERIC: method-redefine-generic-1 ( a -- b )
|
||||
|
||||
M: integer method-redefine-test 3 + ;
|
||||
M: integer method-redefine-generic-1 3 + ;
|
||||
|
||||
: method-redefine-test-1 ( -- b ) 3 method-redefine-test ;
|
||||
: method-redefine-test-1 ( -- b ) 3 method-redefine-generic-1 ;
|
||||
|
||||
[ 6 ] [ method-redefine-test-1 ] unit-test
|
||||
|
||||
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test
|
||||
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval ] unit-test
|
||||
|
||||
[ 7 ] [ method-redefine-test-1 ] unit-test
|
||||
|
||||
[ ] [ [ fixnum \ method-redefine-test method forget ] with-compilation-unit ] unit-test
|
||||
[ ] [ [ fixnum \ method-redefine-generic-1 method forget ] with-compilation-unit ] unit-test
|
||||
|
||||
[ 6 ] [ method-redefine-test-1 ] unit-test
|
||||
|
||||
GENERIC: method-redefine-generic-2 ( a -- b )
|
||||
|
||||
M: integer method-redefine-generic-2 3 + ;
|
||||
|
||||
: method-redefine-test-2 ( -- b ) 3 method-redefine-generic-2 ;
|
||||
|
||||
[ 6 ] [ method-redefine-test-2 ] unit-test
|
||||
|
||||
[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval ] unit-test
|
||||
|
||||
[ 7 ] [ method-redefine-test-2 ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
fixnum string [ \ method-redefine-generic-2 method forget ] bi@
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
! Test ripple-up behavior
|
||||
: hey ( -- ) ;
|
||||
: there ( -- ) hey ;
|
||||
|
|
|
|||
|
|
@ -514,4 +514,9 @@ cell-bits 32 = [
|
|||
[ t ] [
|
||||
[ { fixnum fixnum } declare = ]
|
||||
\ both-fixnums? inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { integer integer } declare + drop ]
|
||||
{ + +-integer-integer } inlined?
|
||||
] unit-test
|
||||
|
|
@ -76,7 +76,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
|
|||
] ;
|
||||
|
||||
: drop-dead-outputs ( node -- #shuffle )
|
||||
dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
|
||||
dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;
|
||||
|
||||
: some-outputs-dead? ( #call -- ? )
|
||||
out-d>> [ live-value? not ] any? ;
|
||||
|
|
|
|||
|
|
@ -46,9 +46,6 @@ M: predicate finalize-word
|
|||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
! M: math-partial finalize-word
|
||||
! dup primitive? [ drop ] [ nip cached-expansion ] if ;
|
||||
|
||||
M: word finalize-word drop ;
|
||||
|
||||
M: #call finalize*
|
||||
|
|
|
|||
|
|
@ -238,7 +238,7 @@ DEFER: (value-info-union)
|
|||
|
||||
: value-infos-union ( infos -- info )
|
||||
[ null-info ]
|
||||
[ dup first [ value-info-union ] reduce ] if-empty ;
|
||||
[ unclip-slice [ value-info-union ] reduce ] if-empty ;
|
||||
|
||||
: literals<= ( info1 info2 -- ? )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel arrays sequences math math.order call
|
||||
USING: accessors kernel arrays sequences math math.order
|
||||
math.partial-dispatch generic generic.standard generic.math
|
||||
classes.algebra classes.union sets quotations assocs combinators
|
||||
words namespaces continuations classes fry combinators.smart
|
||||
|
|
@ -17,8 +17,10 @@ IN: compiler.tree.propagation.inlining
|
|||
! we are more eager to inline
|
||||
SYMBOL: node-count
|
||||
|
||||
: count-nodes ( nodes -- )
|
||||
0 swap [ drop 1+ ] each-node node-count set ;
|
||||
: count-nodes ( nodes -- n )
|
||||
0 swap [ drop 1+ ] each-node ;
|
||||
|
||||
: compute-node-count ( nodes -- ) count-nodes node-count set ;
|
||||
|
||||
! We try not to inline the same word too many times, to avoid
|
||||
! combinatorial explosion
|
||||
|
|
@ -33,9 +35,6 @@ M: word splicing-nodes
|
|||
M: callable splicing-nodes
|
||||
build-sub-tree analyze-recursive normalize ;
|
||||
|
||||
: propagate-body ( #call -- )
|
||||
body>> (propagate) ;
|
||||
|
||||
! Dispatch elimination
|
||||
: eliminate-dispatch ( #call class/f word/quot/f -- ? )
|
||||
dup [
|
||||
|
|
@ -44,7 +43,7 @@ M: callable splicing-nodes
|
|||
2dup splicing-nodes
|
||||
[ >>method ] [ >>body ] bi*
|
||||
] if
|
||||
propagate-body t
|
||||
body>> (propagate) t
|
||||
] [ 2drop f >>method f >>body f >>class drop f ] if ;
|
||||
|
||||
: inlining-standard-method ( #call word -- class/f method/f )
|
||||
|
|
@ -161,10 +160,10 @@ SYMBOL: history
|
|||
: inline-word-def ( #call word quot -- ? )
|
||||
over history get memq? [ 3drop f ] [
|
||||
[
|
||||
swap remember-inlining
|
||||
dupd splicing-nodes >>body
|
||||
propagate-body
|
||||
] with-scope
|
||||
[ remember-inlining ] dip
|
||||
[ drop ] [ splicing-nodes ] 2bi
|
||||
[ >>body drop ] [ count-nodes ] [ (propagate) ] tri
|
||||
] with-scope node-count +@
|
||||
t
|
||||
] if ;
|
||||
|
||||
|
|
@ -177,6 +176,9 @@ SYMBOL: history
|
|||
: always-inline-word? ( word -- ? )
|
||||
{ curry compose } memq? ;
|
||||
|
||||
: never-inline-word? ( word -- ? )
|
||||
[ deferred? ] [ { call execute } memq? ] bi or ;
|
||||
|
||||
: custom-inlining? ( word -- ? )
|
||||
"custom-inlining" word-prop ;
|
||||
|
||||
|
|
@ -199,7 +201,7 @@ SYMBOL: history
|
|||
#! calls the compiler at parse time (doing so is
|
||||
#! discouraged, but it should still work.)
|
||||
{
|
||||
{ [ dup deferred? ] [ 2drop f ] }
|
||||
{ [ dup never-inline-word? ] [ 2drop f ] }
|
||||
{ [ dup \ instance? eq? ] [ inline-instance-check ] }
|
||||
{ [ dup always-inline-word? ] [ inline-word ] }
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
|
|
|
|||
|
|
@ -655,3 +655,36 @@ MIXIN: empty-mixin
|
|||
! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
|
||||
|
||||
! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
|
||||
|
||||
! generalize-counter-interval wasn't being called in all the right places.
|
||||
! bug found by littledan
|
||||
|
||||
TUPLE: littledan-1 { a read-only } ;
|
||||
|
||||
: (littledan-1-test) ( a -- ) a>> 1+ littledan-1 boa (littledan-1-test) ; inline recursive
|
||||
|
||||
: littledan-1-test ( -- ) 0 littledan-1 boa (littledan-1-test) ; inline
|
||||
|
||||
[ ] [ [ littledan-1-test ] final-classes drop ] unit-test
|
||||
|
||||
TUPLE: littledan-2 { from read-only } { to read-only } ;
|
||||
|
||||
: (littledan-2-test) ( x -- i elt )
|
||||
[ from>> ] [ to>> ] bi + dup littledan-2 boa (littledan-2-test) ; inline recursive
|
||||
|
||||
: littledan-2-test ( x -- i elt )
|
||||
[ 0 ] dip { array-capacity } declare littledan-2 boa (littledan-2-test) ; inline
|
||||
|
||||
[ ] [ [ littledan-2-test ] final-classes drop ] unit-test
|
||||
|
||||
: (littledan-3-test) ( x -- )
|
||||
length 1+ f <array> (littledan-3-test) ; inline recursive
|
||||
|
||||
: littledan-3-test ( x -- )
|
||||
0 f <array> (littledan-3-test) ; inline
|
||||
|
||||
[ ] [ [ littledan-3-test ] final-classes drop ] unit-test
|
||||
|
||||
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
|
||||
|
||||
[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
|
||||
|
|
@ -20,5 +20,5 @@ IN: compiler.tree.propagation
|
|||
H{ } clone 1array value-infos set
|
||||
H{ } clone 1array constraints set
|
||||
H{ } clone inlining-count set
|
||||
dup count-nodes
|
||||
dup compute-node-count
|
||||
dup (propagate) ;
|
||||
|
|
|
|||
|
|
@ -34,9 +34,14 @@ IN: compiler.tree.propagation.recursive
|
|||
} cond interval-union nip ;
|
||||
|
||||
: generalize-counter ( info' initial -- info )
|
||||
2dup [ class>> null-class? ] either? [ drop ] [
|
||||
[ drop clone ] [ [ interval>> ] bi@ ] 2bi
|
||||
generalize-counter-interval >>interval
|
||||
2dup [ not ] either? [ drop ] [
|
||||
2dup [ class>> null-class? ] either? [ drop ] [
|
||||
[ clone ] dip
|
||||
[ [ drop ] [ [ interval>> ] bi@ generalize-counter-interval ] 2bi >>interval ]
|
||||
[ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ]
|
||||
[ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ]
|
||||
tri
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: unify-recursive-stacks ( stacks initial -- infos )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax kernel sequences ;
|
||||
USING: alien.syntax kernel sequences fry ;
|
||||
IN: core-foundation.arrays
|
||||
|
||||
TYPEDEF: void* CFArrayRef
|
||||
|
|
@ -17,6 +17,5 @@ FUNCTION: CFIndex CFArrayGetCount ( CFArrayRef array ) ;
|
|||
dup CFArrayGetCount [ CFArrayGetValueAtIndex ] with map ;
|
||||
|
||||
: <CFArray> ( seq -- alien )
|
||||
[ f swap length f CFArrayCreateMutable ] keep
|
||||
[ length ] keep
|
||||
[ [ dupd ] dip CFArraySetValueAtIndex ] 2each ;
|
||||
f over length &: kCFTypeArrayCallBacks CFArrayCreateMutable
|
||||
[ '[ [ _ ] 2dip swap CFArraySetValueAtIndex ] each-index ] keep ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test core-foundation.attributed-strings
|
||||
core-foundation ;
|
||||
IN: core-foundation.attributed-strings.tests
|
||||
|
||||
[ ] [ "Hello world" H{ } <CFAttributedString> CFRelease ] unit-test
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax kernel destructors core-foundation
|
||||
core-foundation.utilities ;
|
||||
IN: core-foundation.attributed-strings
|
||||
|
||||
TYPEDEF: void* CFAttributedStringRef
|
||||
|
||||
FUNCTION: CFAttributedStringRef CFAttributedStringCreate (
|
||||
CFAllocatorRef alloc,
|
||||
CFStringRef str,
|
||||
CFDictionaryRef attributes
|
||||
) ;
|
||||
|
||||
: <CFAttributedString> ( string assoc -- alien )
|
||||
[
|
||||
[ >cf &CFRelease ] bi@
|
||||
[ kCFAllocatorDefault ] 2dip CFAttributedStringCreate
|
||||
] with-destructors ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -1 +1,2 @@
|
|||
unportable
|
||||
bindings
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax destructors accessors kernel ;
|
||||
USING: alien.syntax alien.c-types alien.destructors accessors kernel ;
|
||||
IN: core-foundation
|
||||
|
||||
TYPEDEF: void* CFTypeRef
|
||||
|
|
@ -10,22 +10,27 @@ CONSTANT: kCFAllocatorDefault f
|
|||
|
||||
TYPEDEF: bool Boolean
|
||||
TYPEDEF: long CFIndex
|
||||
TYPEDEF: char UInt8
|
||||
TYPEDEF: int SInt32
|
||||
TYPEDEF: uint UInt32
|
||||
TYPEDEF: ulong CFTypeID
|
||||
TYPEDEF: UInt32 CFOptionFlags
|
||||
TYPEDEF: void* CFUUIDRef
|
||||
|
||||
ALIAS: <CFIndex> <long>
|
||||
ALIAS: *CFIndex *long
|
||||
|
||||
C-STRUCT: CFRange
|
||||
{ "CFIndex" "location" }
|
||||
{ "CFIndex" "length" } ;
|
||||
|
||||
: <CFRange> ( location length -- range )
|
||||
"CFRange" <c-object>
|
||||
[ set-CFRange-length ] keep
|
||||
[ set-CFRange-location ] keep ;
|
||||
|
||||
FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ;
|
||||
|
||||
FUNCTION: void CFRelease ( CFTypeRef cf ) ;
|
||||
|
||||
TUPLE: CFRelease-destructor alien disposed ;
|
||||
|
||||
M: CFRelease-destructor dispose* alien>> CFRelease ;
|
||||
|
||||
: &CFRelease ( alien -- alien )
|
||||
dup f CFRelease-destructor boa &dispose drop ; inline
|
||||
|
||||
: |CFRelease ( alien -- alien )
|
||||
dup f CFRelease-destructor boa |dispose drop ; inline
|
||||
DESTRUCTOR: CFRelease
|
||||
|
|
@ -1,57 +1,20 @@
|
|||
! Copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax alien.c-types sequences kernel math ;
|
||||
USING: alien.c-types alien.syntax core-foundation.numbers kernel math
|
||||
sequences core-foundation.numbers ;
|
||||
IN: core-foundation.data
|
||||
|
||||
TYPEDEF: void* CFDataRef
|
||||
TYPEDEF: void* CFDictionaryRef
|
||||
TYPEDEF: void* CFMutableDictionaryRef
|
||||
TYPEDEF: void* CFNumberRef
|
||||
TYPEDEF: void* CFSetRef
|
||||
|
||||
TYPEDEF: int CFNumberType
|
||||
CONSTANT: kCFNumberSInt8Type 1
|
||||
CONSTANT: kCFNumberSInt16Type 2
|
||||
CONSTANT: kCFNumberSInt32Type 3
|
||||
CONSTANT: kCFNumberSInt64Type 4
|
||||
CONSTANT: kCFNumberFloat32Type 5
|
||||
CONSTANT: kCFNumberFloat64Type 6
|
||||
CONSTANT: kCFNumberCharType 7
|
||||
CONSTANT: kCFNumberShortType 8
|
||||
CONSTANT: kCFNumberIntType 9
|
||||
CONSTANT: kCFNumberLongType 10
|
||||
CONSTANT: kCFNumberLongLongType 11
|
||||
CONSTANT: kCFNumberFloatType 12
|
||||
CONSTANT: kCFNumberDoubleType 13
|
||||
CONSTANT: kCFNumberCFIndexType 14
|
||||
CONSTANT: kCFNumberNSIntegerType 15
|
||||
CONSTANT: kCFNumberCGFloatType 16
|
||||
CONSTANT: kCFNumberMaxType 16
|
||||
|
||||
TYPEDEF: int CFPropertyListMutabilityOptions
|
||||
CONSTANT: kCFPropertyListImmutable 0
|
||||
CONSTANT: kCFPropertyListMutableContainers 1
|
||||
CONSTANT: kCFPropertyListImmutable 0
|
||||
CONSTANT: kCFPropertyListMutableContainers 1
|
||||
CONSTANT: kCFPropertyListMutableContainersAndLeaves 2
|
||||
|
||||
FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
|
||||
|
||||
FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFIndex length ) ;
|
||||
|
||||
FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
|
||||
|
||||
GENERIC: <CFNumber> ( number -- alien )
|
||||
|
||||
M: integer <CFNumber>
|
||||
[ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
|
||||
|
||||
M: float <CFNumber>
|
||||
[ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
|
||||
|
||||
M: t <CFNumber>
|
||||
drop f kCFNumberIntType 1 <int> CFNumberCreate ;
|
||||
|
||||
M: f <CFNumber>
|
||||
drop f kCFNumberIntType 0 <int> CFNumberCreate ;
|
||||
|
||||
: <CFData> ( byte-array -- alien )
|
||||
[ f ] dip dup length CFDataCreate ;
|
||||
[ f ] dip dup length CFDataCreate ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test core-foundation core-foundation.dictionaries
|
||||
arrays destructors core-foundation.strings kernel namespaces ;
|
||||
IN: core-foundation.dictionaries.tests
|
||||
|
||||
[ ] [ { } <CFDictionary> CFRelease ] unit-test
|
||||
|
||||
[ "raps in the back of cars and doesn't afraid of anything" ] [
|
||||
[
|
||||
"cpst" <CFString> &CFRelease dup "key" set
|
||||
"raps in the back of cars and doesn't afraid of anything" <CFString> &CFRelease
|
||||
2array 1array <CFDictionary> &CFRelease
|
||||
"key" get
|
||||
CFDictionaryGetValue
|
||||
dup [ CF>string ] when
|
||||
] with-destructors
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax core-foundation kernel assocs
|
||||
specialized-arrays.alien math sequences accessors ;
|
||||
IN: core-foundation.dictionaries
|
||||
|
||||
TYPEDEF: void* CFDictionaryRef
|
||||
TYPEDEF: void* CFMutableDictionaryRef
|
||||
TYPEDEF: void* CFDictionaryKeyCallBacks*
|
||||
TYPEDEF: void* CFDictionaryValueCallBacks*
|
||||
|
||||
FUNCTION: CFDictionaryRef CFDictionaryCreate (
|
||||
CFAllocatorRef allocator,
|
||||
void** keys,
|
||||
void** values,
|
||||
CFIndex numValues,
|
||||
CFDictionaryKeyCallBacks* keyCallBacks,
|
||||
CFDictionaryValueCallBacks* valueCallBacks
|
||||
) ;
|
||||
|
||||
FUNCTION: void* CFDictionaryGetValue (
|
||||
CFDictionaryRef theDict,
|
||||
void* key
|
||||
) ;
|
||||
|
||||
: <CFDictionary> ( alist -- dictionary )
|
||||
[ kCFAllocatorDefault ] dip
|
||||
unzip [ >void*-array ] bi@
|
||||
[ [ underlying>> ] bi@ ] [ nip length ] 2bi
|
||||
&: kCFTypeDictionaryKeyCallBacks
|
||||
&: kCFTypeDictionaryValueCallBacks
|
||||
CFDictionaryCreate ;
|
||||
|
|
@ -1 +1,2 @@
|
|||
unportable
|
||||
bindings
|
||||
|
|
@ -167,7 +167,7 @@ SYMBOL: event-stream-callbacks
|
|||
eventFlags numEvents <direct-int-array>
|
||||
eventIds numEvents <direct-longlong-array>
|
||||
3array flip
|
||||
info event-stream-callbacks get at [ drop ] or call ;
|
||||
info event-stream-callbacks get at [ drop ] or call( changes -- ) ;
|
||||
|
||||
: master-event-source-callback ( -- alien )
|
||||
"void"
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test core-foundation.numbers ;
|
||||
IN: core-foundation.numbers.tests
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types alien.syntax kernel math core-foundation ;
|
||||
IN: core-foundation.numbers
|
||||
|
||||
TYPEDEF: void* CFNumberRef
|
||||
|
||||
TYPEDEF: int CFNumberType
|
||||
CONSTANT: kCFNumberSInt8Type 1
|
||||
CONSTANT: kCFNumberSInt16Type 2
|
||||
CONSTANT: kCFNumberSInt32Type 3
|
||||
CONSTANT: kCFNumberSInt64Type 4
|
||||
CONSTANT: kCFNumberFloat32Type 5
|
||||
CONSTANT: kCFNumberFloat64Type 6
|
||||
CONSTANT: kCFNumberCharType 7
|
||||
CONSTANT: kCFNumberShortType 8
|
||||
CONSTANT: kCFNumberIntType 9
|
||||
CONSTANT: kCFNumberLongType 10
|
||||
CONSTANT: kCFNumberLongLongType 11
|
||||
CONSTANT: kCFNumberFloatType 12
|
||||
CONSTANT: kCFNumberDoubleType 13
|
||||
CONSTANT: kCFNumberCFIndexType 14
|
||||
CONSTANT: kCFNumberNSIntegerType 15
|
||||
CONSTANT: kCFNumberCGFloatType 16
|
||||
CONSTANT: kCFNumberMaxType 16
|
||||
|
||||
FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
|
||||
|
||||
GENERIC: <CFNumber> ( number -- alien )
|
||||
|
||||
M: integer <CFNumber>
|
||||
[ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
|
||||
|
||||
M: float <CFNumber>
|
||||
[ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
|
||||
|
||||
M: t <CFNumber>
|
||||
drop f kCFNumberIntType 1 <int> CFNumberCreate ;
|
||||
|
||||
M: f <CFNumber>
|
||||
drop f kCFNumberIntType 0 <int> CFNumberCreate ;
|
||||
|
||||
|
|
@ -56,25 +56,17 @@ FUNCTION: void CFRunLoopRemoveTimer (
|
|||
|
||||
: CFRunLoopDefaultMode ( -- alien )
|
||||
#! Ugly, but we don't have static NSStrings
|
||||
\ CFRunLoopDefaultMode get-global dup expired? [
|
||||
drop
|
||||
\ CFRunLoopDefaultMode [
|
||||
"kCFRunLoopDefaultMode" <CFString>
|
||||
dup \ CFRunLoopDefaultMode set-global
|
||||
] when ;
|
||||
] initialize-alien ;
|
||||
|
||||
TUPLE: run-loop fds sources timers ;
|
||||
|
||||
: <run-loop> ( -- run-loop )
|
||||
V{ } clone V{ } clone V{ } clone \ run-loop boa ;
|
||||
|
||||
SYMBOL: expiry-check
|
||||
|
||||
: run-loop ( -- run-loop )
|
||||
\ run-loop get-global not expiry-check get expired? or
|
||||
[
|
||||
31337 <alien> expiry-check set-global
|
||||
<run-loop> dup \ run-loop set-global
|
||||
] [ \ run-loop get-global ] if ;
|
||||
\ run-loop [ <run-loop> ] initialize-alien ;
|
||||
|
||||
: add-source-to-run-loop ( source -- )
|
||||
[ run-loop sources>> push ]
|
||||
|
|
|
|||
|
|
@ -1,9 +1,15 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: core-foundation.strings core-foundation tools.test kernel ;
|
||||
USING: core-foundation.strings core-foundation tools.test kernel
|
||||
strings ;
|
||||
IN: core-foundation
|
||||
|
||||
[ ] [ "Hello" <CFString> CFRelease ] unit-test
|
||||
[ "Hello" ] [ "Hello" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
|
||||
[ "Hello\u003456" ] [ "Hello\u003456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
|
||||
[ "Hello\u013456" ] [ "Hello\u013456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
|
||||
[ ] [ "\0" <CFString> CFRelease ] unit-test
|
||||
[ "\0" ] [ "\0" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
|
||||
|
||||
! This shouldn't fail
|
||||
[ ] [ { HEX: 123456 } >string <CFString> CFRelease ] unit-test
|
||||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax alien.strings kernel sequences byte-arrays
|
||||
io.encodings.utf8 math core-foundation core-foundation.arrays ;
|
||||
USING: alien.syntax alien.strings io.encodings.string kernel
|
||||
sequences byte-arrays io.encodings.utf8 math core-foundation
|
||||
core-foundation.arrays destructors unicode.data ;
|
||||
IN: core-foundation.strings
|
||||
|
||||
TYPEDEF: void* CFStringRef
|
||||
|
|
@ -41,26 +42,44 @@ FUNCTION: Boolean CFStringGetCString (
|
|||
CFStringEncoding encoding
|
||||
) ;
|
||||
|
||||
FUNCTION: CFIndex CFStringGetBytes (
|
||||
CFStringRef theString,
|
||||
CFRange range,
|
||||
CFStringEncoding encoding,
|
||||
UInt8 lossByte,
|
||||
Boolean isExternalRepresentation,
|
||||
UInt8* buffer,
|
||||
CFIndex maxBufLen,
|
||||
CFIndex* usedBufLen
|
||||
) ;
|
||||
|
||||
FUNCTION: CFStringRef CFStringCreateWithCString (
|
||||
CFAllocatorRef alloc,
|
||||
char* cStr,
|
||||
CFStringEncoding encoding
|
||||
) ;
|
||||
|
||||
: prepare-CFString ( string -- byte-array )
|
||||
[
|
||||
dup HEX: 10ffff >
|
||||
[ drop CHAR: replacement-character ] when
|
||||
] map utf8 encode ;
|
||||
|
||||
: <CFString> ( string -- alien )
|
||||
f swap utf8 string>alien kCFStringEncodingUTF8 CFStringCreateWithCString
|
||||
[ "CFStringCreateWithCString failed" throw ] unless* ;
|
||||
[ f ] dip
|
||||
prepare-CFString dup length
|
||||
kCFStringEncodingUTF8 f
|
||||
CFStringCreateWithBytes
|
||||
[ "CFStringCreateWithBytes failed" throw ] unless* ;
|
||||
|
||||
: CF>string ( alien -- string )
|
||||
dup CFStringGetLength 4 * 1 + <byte-array> [
|
||||
dup length
|
||||
kCFStringEncodingUTF8
|
||||
CFStringGetCString
|
||||
[ "CFStringGetCString failed" throw ] unless
|
||||
] keep utf8 alien>string ;
|
||||
dup CFStringGetLength
|
||||
[ 0 swap <CFRange> kCFStringEncodingUTF8 0 f ] keep
|
||||
4 * 1 + <byte-array> [ dup length 0 <CFIndex> [ CFStringGetBytes drop ] keep ] keep
|
||||
swap *CFIndex head-slice utf8 decode ;
|
||||
|
||||
: CF>string-array ( alien -- seq )
|
||||
CF>array [ CF>string ] map ;
|
||||
|
||||
: <CFStringArray> ( seq -- alien )
|
||||
[ <CFString> ] map [ <CFArray> ] [ [ CFRelease ] each ] bi ;
|
||||
[ [ <CFString> &CFRelease ] map <CFArray> ] with-destructors ;
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
Mac OS X CoreFoundation binding
|
||||
Binding to Mac OS X CoreFoundation library
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test core-foundation.utilities ;
|
||||
IN: core-foundation.utilities.tests
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue