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

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

db4
Maxim Savchenko 2009-03-10 04:01:10 -04:00
parent 04c29c0a97 073333f245
commit b456ef7ff2
1104 changed files with 76923 additions and 14841 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
Factor.app/Contents/Resources/English.lproj/Factor.nib/classes.nib generated
View File

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

19
Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib generated
View File

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

BIN
Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib generated
View File

Binary file not shown.

40
README.txt
View File

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

1
basis/alien/destructors/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

4
basis/alien/destructors/destructors-tests.factor Normal file
View File

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

29
basis/alien/destructors/destructors.factor Normal file
View File

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

1
basis/alien/destructors/summary.txt Normal file
View File

@ -0,0 +1 @@
Functor for defining destructors which call a C function to dispose of resources

2
basis/alien/syntax/syntax.factor
View File

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

4
basis/ascii/ascii.factor
View File

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

19
basis/base64/base64-tests.factor
View File

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

8
basis/base64/base64.factor
View File

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

8
basis/bitstreams/bitstreams-tests.factor
View File

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

4
basis/bootstrap/ui/tools/tools.factor
View File

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

10
basis/bootstrap/ui/ui.factor Normal file → Executable file
View File

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

1
basis/cache/authors.txt vendored Normal file
View File

@ -0,0 +1 @@
Slava Pestov

4
basis/cache/cache-tests.factor vendored Normal file
View File

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

43
basis/cache/cache.factor vendored Normal file
View File

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

1
basis/cache/summary.txt vendored Normal file
View File

@ -0,0 +1 @@
An associative mapping whose entries expire after a while

0
unmaintained/assocs-lib/tags.txt → basis/cache/tags.txt vendored
View File

1
basis/cairo/authors.txt
View File

@ -1,2 +1,3 @@
Sampo Vuori
Doug Coleman
Slava Pestov

8
basis/cairo/cairo-tests.factor Normal file
View File

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

67
basis/cairo/cairo.factor
View File

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

18
basis/cairo/ffi/ffi.factor
View File

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

31
basis/call/call-docs.factor
View File

@ -1,19 +1,25 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax quotations effects words ;
USING: help.markup help.syntax quotations effects words call.private ;
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."
$nl
"Quotations:"
{ $subsection POSTPONE: call( }
{ $subsection POSTPONE: execute( }
{ $subsection call-effect }
{ $subsection execute-effect } ;
"Words:"
{ $subsection POSTPONE: execute( }
{ $subsection execute-effect }
"Unsafe calls:"
{ $subsection POSTPONE: execute-unsafe( }
{ $subsection execute-effect-unsafe } ;
HELP: call(
{ $syntax "[ ] call( foo -- bar )" }
{ $syntax "call( stack -- effect )" }
{ $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
@ -21,12 +27,21 @@ HELP: call-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." } ;
{ $syntax "execute( stack -- effect )" }
{ $description "Calls the word on the top of the stack, asserting 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
HELP: execute-unsafe(
{ $syntax "execute-unsafe( stack -- effect )" }
{ $description "Calls the word on the top of the stack, blindly declaring that it has the given stack effect. The word does not need to be known at compile time." }
{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link POSTPONE: execute( } " instead." } ;
HELP: execute-effect-unsafe
{ $values { "word" word } { "effect" effect } }
{ $description "Given a word and a stack effect, executes the word, blindly declaring 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." }
{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link execute-effect-unsafe } " instead." } ;
{ call-effect execute-effect execute-effect-unsafe } related-words
{ POSTPONE: call( POSTPONE: execute( POSTPONE: execute-unsafe( } related-words

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

@ -1,6 +1,6 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math tools.test call kernel ;
USING: math tools.test call call.private kernel accessors ;
IN: call.tests
[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
@ -13,3 +13,13 @@ IN: call.tests
[ 1 2 \ + execute( -- z ) ] must-fail
[ 1 2 \ + execute( x y -- z a ) ] must-fail
[ \ + execute( x y -- z ) ] must-infer
[ 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

24
basis/call/call.factor
View File

@ -1,7 +1,7 @@
! 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 ;
continuations effects effects.parser parser words ;
IN: call
ERROR: wrong-values values quot length-required ;
@ -14,17 +14,29 @@ M: wrong-values summary
: firstn-safe ( array quot n -- ... )
3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline
: execute-effect-unsafe ( word effect -- )
drop execute ;
: execute-effect-unsafe? ( word effect -- ? )
swap dup optimized>> [ stack-effect swap effect<= ] [ 2drop f ] if ; inline
: parse-call( ( accum word -- accum )
[ ")" parse-effect parsed ] dip parsed ;
: execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing
PRIVATE>
MACRO: call-effect ( effect -- quot )
[ in>> length ] [ out>> length ] bi
'[ [ _ narray ] dip [ with-datastack ] keep _ firstn-safe ] ;
: call(
")" parse-effect parsed \ call-effect parsed ; parsing
: call( \ call-effect parse-call( ; parsing
: execute-effect ( word effect -- )
[ [ execute ] curry ] dip call-effect ; inline
2dup execute-effect-unsafe?
[ execute-effect-unsafe ]
[ [ [ execute ] curry ] dip call-effect ]
if ; inline
: execute(
")" parse-effect parsed \ execute-effect parsed ; parsing
: execute( \ execute-effect parse-call( ; parsing

6
basis/cocoa/application/application-docs.factor
View File

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

21
basis/cocoa/application/application.factor
View File

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

1
basis/cocoa/cocoa-docs.factor
View File

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

20
basis/cocoa/cocoa-tests.factor
View File

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

11
basis/cocoa/enumeration/enumeration.factor
View File

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

8
basis/cocoa/messages/messages.factor
View File

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

4
basis/cocoa/pasteboard/pasteboard.factor
View File

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

40
basis/cocoa/plists/plists-tests.factor Normal file
View File

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

62
basis/cocoa/plists/plists.factor
View File

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

7
basis/cocoa/subclassing/subclassing.factor
View File

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

29
basis/cocoa/types/types-docs.factor
View File

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

73
basis/cocoa/types/types.factor
View File

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

46
basis/cocoa/views/views.factor
View File

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

39
basis/colors/colors-docs.factor Normal file
View File

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

35
basis/colors/colors.factor
View File

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

31
basis/colors/constants/constants-docs.factor Normal file
View File

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

4
basis/colors/constants/constants.factor
View File

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

9
basis/colors/gray/gray-docs.factor Normal file
View File

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

8
basis/colors/gray/gray.factor
View File

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

13
basis/colors/hsv/hsv-docs.factor Normal file
View File

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

2
basis/colors/hsv/hsv-tests.factor
View File

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

2
basis/colors/hsv/hsv.factor
View File

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

4
basis/compiler/cfg/instructions/syntax/syntax.factor
View File

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

2
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

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

9
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

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

2
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

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

30
basis/compiler/tests/redefine1.factor
View File

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

2
basis/compiler/tree/dead-code/simple/simple.factor
View File

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

24
basis/compiler/tree/propagation/inlining/inlining.factor
View File

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

2
basis/compiler/tree/propagation/propagation.factor
View File

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

0
extra/rewrite-closures/tags.txt → basis/constructors/tags.txt
View File

9
basis/core-foundation/arrays/arrays.factor
View File

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

7
basis/core-foundation/attributed-strings/attributed-strings-tests.factor Normal file
View File

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

19
basis/core-foundation/attributed-strings/attributed-strings.factor Normal file
View File

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

1
basis/core-foundation/attributed-strings/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
unmaintained/raptor/tags.txt → basis/core-foundation/attributed-strings/tags.txt
View File

@ -1 +1,2 @@
unportable
bindings

25
basis/core-foundation/core-foundation.factor
View File

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

47
basis/core-foundation/data/data.factor
View File

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

1
basis/core-foundation/dictionaries/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

18
basis/core-foundation/dictionaries/dictionaries-tests.factor Normal file
View File

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

32
basis/core-foundation/dictionaries/dictionaries.factor Normal file
View File

@ -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
unmaintained/route/tags.txt → basis/core-foundation/dictionaries/tags.txt
View File

@ -1 +1,2 @@
unportable
bindings

1
basis/core-foundation/numbers/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

4
basis/core-foundation/numbers/numbers-tests.factor Normal file
View File

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

42
basis/core-foundation/numbers/numbers.factor Normal file
View File

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

0
basis/ui/cocoa/tags.txt → basis/core-foundation/numbers/tags.txt
View File

14
basis/core-foundation/run-loop/run-loop.factor
View File

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

8
basis/core-foundation/strings/strings-tests.factor
View File

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

43
basis/core-foundation/strings/strings.factor
View File

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

2
basis/core-foundation/summary.txt
View File

@ -1 +1 @@
Mac OS X CoreFoundation binding
Binding to Mac OS X CoreFoundation library

1
basis/core-foundation/utilities/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

0
basis/ui/cocoa/tools/tags.txt → basis/core-foundation/utilities/tags.txt
View File

4
basis/core-foundation/utilities/utilities-tests.factor Normal file
View File

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

21
basis/core-foundation/utilities/utilities.factor Normal file
View File

@ -0,0 +1,21 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math assocs kernel sequences byte-arrays strings
hashtables alien destructors
core-foundation.numbers core-foundation.strings
core-foundation.arrays core-foundation.dictionaries
core-foundation.data core-foundation ;
IN: core-foundation.utilities
GENERIC: (>cf) ( obj -- cf )
M: number (>cf) <CFNumber> ;
M: t (>cf) <CFNumber> ;
M: f (>cf) <CFNumber> ;
M: string (>cf) <CFString> ;
M: byte-array (>cf) <CFData> ;
M: hashtable (>cf) [ [ (>cf) &CFRelease ] bi@ ] assoc-map <CFDictionary> ;
M: sequence (>cf) [ (>cf) &CFRelease ] map <CFArray> ;
M: alien (>cf) CFRetain ;
: >cf ( obj -- cf ) [ (>cf) ] with-destructors ;

0
basis/freetype/authors.txt → basis/core-graphics/authors.txt
View File

0
basis/core-graphics/core-graphics-docs.factor Normal file
View File

8
basis/core-graphics/core-graphics-tests.factor Normal file
View File

@ -0,0 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test core-graphics kernel images ;
IN: core-graphics.tests
[ t ] [ { 100 200 } [ drop ] make-bitmap-image image? ] unit-test
[ ] [ dummy-context drop ] unit-test

130
basis/core-graphics/core-graphics.factor Normal file
View File

@ -0,0 +1,130 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.destructors alien.syntax accessors
destructors fry kernel math math.bitwise sequences libc colors
images images.memory core-graphics.types core-foundation.utilities ;
IN: core-graphics
! CGImageAlphaInfo
C-ENUM:
kCGImageAlphaNone
kCGImageAlphaPremultipliedLast
kCGImageAlphaPremultipliedFirst
kCGImageAlphaLast
kCGImageAlphaFirst
kCGImageAlphaNoneSkipLast
kCGImageAlphaNoneSkipFirst ;
: kCGBitmapAlphaInfoMask ( -- n ) HEX: 1f ; inline
: kCGBitmapFloatComponents ( -- n ) 1 8 shift ; inline
: kCGBitmapByteOrderMask ( -- n ) HEX: 7000 ; inline
: kCGBitmapByteOrderDefault ( -- n ) 0 12 shift ; inline
: kCGBitmapByteOrder16Little ( -- n ) 1 12 shift ; inline
: kCGBitmapByteOrder32Little ( -- n ) 2 12 shift ; inline
: kCGBitmapByteOrder16Big ( -- n ) 3 12 shift ; inline
: kCGBitmapByteOrder32Big ( -- n ) 4 12 shift ; inline
: kCGBitmapByteOrder16Host ( -- n )
little-endian?
kCGBitmapByteOrder16Little
kCGBitmapByteOrder16Big ? ; foldable
: kCGBitmapByteOrder32Host ( -- n )
little-endian?
kCGBitmapByteOrder32Little
kCGBitmapByteOrder32Big ? ; foldable
FUNCTION: CGColorRef CGColorCreateGenericRGB (
CGFloat red,
CGFloat green,
CGFloat blue,
CGFloat alpha
) ;
: <CGColor> ( color -- CGColor )
>rgba-components CGColorCreateGenericRGB ;
M: color (>cf) <CGColor> ;
FUNCTION: CGColorSpaceRef CGColorSpaceCreateDeviceRGB ( ) ;
FUNCTION: CGContextRef CGBitmapContextCreate (
void* data,
size_t width,
size_t height,
size_t bitsPerComponent,
size_t bytesPerRow,
CGColorSpaceRef colorspace,
CGBitmapInfo bitmapInfo
) ;
FUNCTION: void CGColorSpaceRelease ( CGColorSpaceRef ref ) ;
DESTRUCTOR: CGColorSpaceRelease
FUNCTION: void CGContextRelease ( CGContextRef ref ) ;
DESTRUCTOR: CGContextRelease
FUNCTION: void CGContextSetRGBStrokeColor (
CGContextRef c,
CGFloat red,
CGFloat green,
CGFloat blue,
CGFloat alpha
) ;
FUNCTION: void CGContextSetRGBFillColor (
CGContextRef c,
CGFloat red,
CGFloat green,
CGFloat blue,
CGFloat alpha
) ;
FUNCTION: void CGContextSetTextPosition (
CGContextRef c,
CGFloat x,
CGFloat y
) ;
FUNCTION: void CGContextFillRect (
CGContextRef c,
CGRect rect
) ;
FUNCTION: void CGContextSetShouldSmoothFonts (
CGContextRef c,
bool shouldSmoothFonts
) ;
FUNCTION: void* CGBitmapContextGetData ( CGContextRef c ) ;
CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
<PRIVATE
: bitmap-flags ( -- flags )
{ kCGImageAlphaPremultipliedFirst kCGBitmapByteOrder32Host } flags ;
: bitmap-color-space ( -- color-space )
CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease ;
: <CGBitmapContext> ( data dim -- context )
[ first2 8 ] [ first 4 * ] bi
bitmap-color-space bitmap-flags CGBitmapContextCreate
[ "CGBitmapContextCreate failed" throw ] unless* ;
PRIVATE>
: dummy-context ( -- context )
\ dummy-context [
[ 4 malloc { 1 1 } <CGBitmapContext> ] with-destructors
] initialize-alien ;
: make-bitmap-image ( dim quot -- image )
'[ <CGBitmapContext> &CGContextRelease @ ] make-memory-bitmap
ARGB >>component-order ; inline

1
basis/core-graphics/summary.txt Normal file
View File

@ -0,0 +1 @@
Binding to Mac OS X Core Graphics library

1
unmaintained/sockios/tags.txt → basis/core-graphics/tags.txt
View File

@ -1 +1,2 @@
unportable
bindings

1
basis/core-graphics/types/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

29
basis/core-graphics/types/types-docs.factor Normal file
View File

@ -0,0 +1,29 @@
USING: math help.markup help.syntax ;
IN: core-graphics.types
HELP: <CGRect>
{ $values { "x" real } { "y" real } { "w" real } { "h" real } { "rect" "an " { $snippet "CGRect" } } }
{ $description "Allocates a new " { $snippet "CGRect" } " in the Factor heap." } ;
HELP: <CGPoint>
{ $values { "x" real } { "y" real } { "point" "an " { $snippet "CGPoint" } } }
{ $description "Allocates a new " { $snippet "CGPoint" } " in the Factor heap." } ;
HELP: <CGSize>
{ $values { "w" real } { "h" real } { "size" "an " { $snippet "CGSize" } } }
{ $description "Allocates a new " { $snippet "CGSize" } " in the Factor heap." } ;
ARTICLE: "core-graphics.types" "Core Graphics types"
"The Core Graphics binding defines some common C structs:"
{ $code
"CGRect"
"CGPoint"
"CGSize"
}
"Some words for working with the above:"
{ $subsection <CGRect> }
{ $subsection <CGPoint> }
{ $subsection <CGSize> } ;
IN: core-graphics.types
ABOUT: "core-graphics.types"

4
basis/core-graphics/types/types-tests.factor Normal file
View File

@ -0,0 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test core-graphics.types ;
IN: core-graphics.types.tests

94
basis/core-graphics/types/types.factor Normal file
View File

@ -0,0 +1,94 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax kernel layouts
math math.rectangles arrays ;
IN: core-graphics.types
<< cell 4 = "float" "double" ? "CGFloat" typedef >>
: <CGFloat> ( x -- alien )
cell 4 = [ <float> ] [ <double> ] if ; inline
: *CGFloat ( alien -- x )
cell 4 = [ *float ] [ *double ] if ; inline
C-STRUCT: CGPoint
{ "CGFloat" "x" }
{ "CGFloat" "y" } ;
: <CGPoint> ( x y -- point )
"CGPoint" <c-object>
[ set-CGPoint-y ] keep
[ set-CGPoint-x ] keep ;
C-STRUCT: CGSize
{ "CGFloat" "w" }
{ "CGFloat" "h" } ;
: <CGSize> ( w h -- size )
"CGSize" <c-object>
[ set-CGSize-h ] keep
[ set-CGSize-w ] keep ;
C-STRUCT: CGRect
{ "CGPoint" "origin" }
{ "CGSize" "size" } ;
: CGPoint>loc ( CGPoint -- loc )
[ CGPoint-x ] [ CGPoint-y ] bi 2array ;
: CGSize>dim ( CGSize -- dim )
[ CGSize-w ] [ CGSize-h ] bi 2array ;
: CGRect>rect ( CGRect -- rect )
[ CGRect-origin CGPoint>loc ]
[ CGRect-size CGSize>dim ]
bi <rect> ; inline
: CGRect-x ( CGRect -- x )
CGRect-origin CGPoint-x ; inline
: CGRect-y ( CGRect -- y )
CGRect-origin CGPoint-y ; inline
: CGRect-w ( CGRect -- w )
CGRect-size CGSize-w ; inline
: CGRect-h ( CGRect -- h )
CGRect-size CGSize-h ; inline
: set-CGRect-x ( x CGRect -- )
CGRect-origin set-CGPoint-x ; inline
: set-CGRect-y ( y CGRect -- )
CGRect-origin set-CGPoint-y ; inline
: set-CGRect-w ( w CGRect -- )
CGRect-size set-CGSize-w ; inline
: set-CGRect-h ( h CGRect -- )
CGRect-size set-CGSize-h ; inline
: <CGRect> ( x y w h -- rect )
"CGRect" <c-object>
[ set-CGRect-h ] keep
[ set-CGRect-w ] keep
[ set-CGRect-y ] keep
[ set-CGRect-x ] keep ;
: CGRect-x-y ( alien -- origin-x origin-y )
[ CGRect-x ] [ CGRect-y ] bi ;
: CGRect-top-left ( alien -- x y )
[ CGRect-x ] [ [ CGRect-y ] [ CGRect-h ] bi + ] bi ;
C-STRUCT: CGAffineTransform
{ "CGFloat" "a" }
{ "CGFloat" "b" }
{ "CGFloat" "c" }
{ "CGFloat" "d" }
{ "CGFloat" "tx" }
{ "CGFloat" "ty" } ;
TYPEDEF: void* CGColorRef
TYPEDEF: void* CGColorSpaceRef
TYPEDEF: void* CGContextRef
TYPEDEF: uint CGBitmapInfo
TYPEDEF: int CGLError
TYPEDEF: void* CGLContextObj
TYPEDEF: int CGLContextParameter

1
basis/core-text/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

36
basis/core-text/core-text-tests.factor Normal file
View File

@ -0,0 +1,36 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test core-text core-text.fonts core-foundation
core-foundation.dictionaries destructors arrays kernel generalizations
math accessors core-foundation.utilities combinators hashtables colors
colors.constants ;
IN: core-text.tests
: test-font ( name -- font )
[ >cf &CFRelease 0.0 f CTFontCreateWithName ] with-destructors ;
[ ] [ "Helvetica" test-font CFRelease ] unit-test
[ ] [
[
kCTFontAttributeName "Helvetica" test-font &CFRelease 2array 1array
<CFDictionary> &CFRelease drop
] with-destructors
] unit-test
: test-typographic-bounds ( string font -- ? )
[
test-font &CFRelease tuck COLOR: white <CTLine> &CFRelease
compute-line-metrics {
[ width>> float? ]
[ ascent>> float? ]
[ descent>> float? ]
[ leading>> float? ]
} cleave and and and
] with-destructors ;
[ t ] [ "Hello world" "Helvetica" test-typographic-bounds ] unit-test
[ t ] [ "Hello world" "Chicago" test-typographic-bounds ] unit-test
[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test

145
basis/core-text/core-text.factor Normal file
View File

@ -0,0 +1,145 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.syntax kernel destructors
accessors fry words hashtables strings sequences memoize assocs math
math.vectors math.rectangles math.functions locals init namespaces
combinators fonts colors cache core-foundation core-foundation.strings
core-foundation.attributed-strings core-foundation.utilities
core-graphics core-graphics.types core-text.fonts core-text.utilities ;
IN: core-text
TYPEDEF: void* CTLineRef
C-GLOBAL: kCTFontAttributeName
C-GLOBAL: kCTKernAttributeName
C-GLOBAL: kCTLigatureAttributeName
C-GLOBAL: kCTForegroundColorAttributeName
C-GLOBAL: kCTParagraphStyleAttributeName
C-GLOBAL: kCTUnderlineStyleAttributeName
C-GLOBAL: kCTVerticalFormsAttributeName
C-GLOBAL: kCTGlyphInfoAttributeName
FUNCTION: CTLineRef CTLineCreateWithAttributedString ( CFAttributedStringRef string ) ;
FUNCTION: void CTLineDraw ( CTLineRef line, CGContextRef context ) ;
FUNCTION: CGFloat CTLineGetOffsetForStringIndex ( CTLineRef line, CFIndex charIndex, CGFloat* secondaryOffset ) ;
FUNCTION: CFIndex CTLineGetStringIndexForPosition ( CTLineRef line, CGPoint position ) ;
FUNCTION: double CTLineGetTypographicBounds ( CTLineRef line, CGFloat* ascent, CGFloat* descent, CGFloat* leading ) ;
FUNCTION: CGRect CTLineGetImageBounds ( CTLineRef line, CGContextRef context ) ;
ERROR: not-a-string object ;
: <CTLine> ( string open-font color -- line )
[
[
dup selection? [ string>> ] when
dup string? [ not-a-string ] unless
] 2dip
[
kCTForegroundColorAttributeName set
kCTFontAttributeName set
] H{ } make-assoc <CFAttributedString> &CFRelease
CTLineCreateWithAttributedString
] with-destructors ;
TUPLE: line line metrics image loc dim disposed ;
: typographic-bounds ( line -- width ascent descent leading )
0 <CGFloat> 0 <CGFloat> 0 <CGFloat>
[ CTLineGetTypographicBounds ] 3keep [ *CGFloat ] tri@ ; inline
: store-typographic-bounds ( metrics width ascent descent leading -- metrics )
{
[ >>width ]
[ >>ascent ]
[ >>descent ]
[ >>leading ]
} spread ; inline
: compute-font-metrics ( metrics font -- metrics )
[ CTFontGetCapHeight >>cap-height ]
[ CTFontGetXHeight >>x-height ]
bi ; inline
: compute-line-metrics ( open-font line -- line-metrics )
[ metrics new ] 2dip
[ compute-font-metrics ]
[ typographic-bounds store-typographic-bounds ] bi*
compute-height ;
: metrics>dim ( bounds -- dim )
[ width>> ] [ [ ascent>> ] [ descent>> ] bi + ] bi
[ ceiling >integer ]
bi@ 2array ;
: fill-background ( context font dim -- )
[ background>> >rgba-components CGContextSetRGBFillColor ]
[ [ 0 0 ] dip first2 <CGRect> CGContextFillRect ]
bi-curry* bi ;
: selection-rect ( dim line selection -- rect )
[ start>> ] [ end>> ] bi
[ f CTLineGetOffsetForStringIndex round ] bi-curry@ bi
[ drop nip 0 ] [ swap - swap second ] 3bi <CGRect> ;
: CGRect-translate-x ( CGRect x -- CGRect' )
[ dup CGRect-x ] dip - over set-CGRect-x ;
:: fill-selection-background ( context loc dim line string -- )
string selection? [
context string color>> >rgba-components CGContextSetRGBFillColor
context dim line string selection-rect
loc first CGRect-translate-x
CGContextFillRect
] when ;
: line-rect ( line -- rect )
dummy-context CTLineGetImageBounds ;
: set-text-position ( context loc -- )
first2 [ neg ] bi@ CGContextSetTextPosition ;
:: line-loc ( metrics loc dim -- loc )
loc first
metrics ascent>> ceiling dim second loc second + - 2array ;
:: <line> ( font string -- line )
[
[let* | open-font [ font cache-font ]
line [ string open-font font foreground>> <CTLine> |CFRelease ]
rect [ line line-rect ]
(loc) [ rect CGRect-origin CGPoint>loc ]
(dim) [ rect CGRect-size CGSize>dim ]
(ext) [ (loc) (dim) v+ ]
loc [ (loc) [ floor ] map ]
ext [ (loc) (dim) [ + ceiling ] 2map ]
dim [ ext loc [ - >integer ] 2map ]
metrics [ open-font line compute-line-metrics ] |
line metrics
dim [
{
[ font dim fill-background ]
[ loc dim line string fill-selection-background ]
[ loc set-text-position ]
[ [ line ] dip CTLineDraw ]
} cleave
] make-bitmap-image
metrics loc dim line-loc
metrics metrics>dim
]
f line boa
] with-destructors ;
M: line dispose* line>> CFRelease ;
SYMBOL: cached-lines
: cached-line ( font string -- line )
cached-lines get [ <line> ] 2cache ;
[ <cache-assoc> cached-lines set-global ] "core-text" add-init-hook

1
basis/core-text/fonts/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

4
basis/core-text/fonts/fonts-tests.factor Normal file
View File

@ -0,0 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test core-text.fonts ;
IN: core-text.fonts.tests

129
basis/core-text/fonts/fonts.factor Normal file
View File

@ -0,0 +1,129 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.syntax assocs core-foundation
core-foundation.strings core-text.utilities destructors init
kernel math memoize fonts combinators ;
IN: core-text.fonts
TYPEDEF: void* CTFontRef
TYPEDEF: void* CTFontDescriptorRef
! CTFontSymbolicTraits
: kCTFontItalicTrait ( -- n ) 0 2^ ; inline
: kCTFontBoldTrait ( -- n ) 1 2^ ; inline
: kCTFontExpandedTrait ( -- n ) 5 2^ ; inline
: kCTFontCondensedTrait ( -- n ) 6 2^ ; inline
: kCTFontMonoSpaceTrait ( -- n ) 10 2^ ; inline
: kCTFontVerticalTrait ( -- n ) 11 2^ ; inline
: kCTFontUIOptimizedTrait ( -- n ) 12 2^ ; inline
C-GLOBAL: kCTFontSymbolicTrait
C-GLOBAL: kCTFontWeightTrait
C-GLOBAL: kCTFontWidthTrait
C-GLOBAL: kCTFontSlantTrait
C-GLOBAL: kCTFontNameAttribute
C-GLOBAL: kCTFontDisplayNameAttribute
C-GLOBAL: kCTFontFamilyNameAttribute
C-GLOBAL: kCTFontStyleNameAttribute
C-GLOBAL: kCTFontTraitsAttribute
C-GLOBAL: kCTFontVariationAttribute
C-GLOBAL: kCTFontSizeAttribute
C-GLOBAL: kCTFontMatrixAttribute
C-GLOBAL: kCTFontCascadeListAttribute
C-GLOBAL: kCTFontCharacterSetAttribute
C-GLOBAL: kCTFontLanguagesAttribute
C-GLOBAL: kCTFontBaselineAdjustAttribute
C-GLOBAL: kCTFontMacintoshEncodingsAttribute
C-GLOBAL: kCTFontFeaturesAttribute
C-GLOBAL: kCTFontFeatureSettingsAttribute
C-GLOBAL: kCTFontFixedAdvanceAttribute
C-GLOBAL: kCTFontOrientationAttribute
FUNCTION: CTFontDescriptorRef CTFontDescriptorCreateWithAttributes (
CFDictionaryRef attributes
) ;
FUNCTION: CTFontRef CTFontCreateWithName (
CFStringRef name,
CGFloat size,
CGAffineTransform* matrix
) ;
FUNCTION: CTFontRef CTFontCreateWithFontDescriptor (
CTFontDescriptorRef descriptor,
CGFloat size,
CGAffineTransform* matrix
) ;
FUNCTION: CTFontRef CTFontCreateCopyWithSymbolicTraits (
CTFontRef font,
CGFloat size,
CGAffineTransform* matrix,
uint32_t symTraitValue,
uint32_t symTraitMask
) ;
FUNCTION: CGFloat CTFontGetAscent ( CTFontRef font ) ;
FUNCTION: CGFloat CTFontGetDescent ( CTFontRef font ) ;
FUNCTION: CGFloat CTFontGetLeading ( CTFontRef font ) ;
FUNCTION: CGFloat CTFontGetCapHeight ( CTFontRef font ) ;
FUNCTION: CGFloat CTFontGetXHeight ( CTFontRef font ) ;
CONSTANT: font-names
H{
{ "monospace" "Monaco" }
{ "sans-serif" "Lucida Grande" }
{ "serif" "Times" }
}
: font-name ( string -- string' )
font-names at-default ;
: (bold) ( x -- y ) kCTFontBoldTrait bitor ; inline
: (italic) ( x -- y ) kCTFontItalicTrait bitor ; inline
: font-traits ( font -- n )
[ 0 ] dip
[ bold?>> [ (bold) ] when ]
[ italic?>> [ (italic) ] when ] bi ;
: apply-font-traits ( font style -- font' )
[ drop ] [ [ 0.0 f ] dip font-traits dup ] 2bi
CTFontCreateCopyWithSymbolicTraits
dup [ [ CFRelease ] dip ] [ drop ] if ;
MEMO: (cache-font) ( font -- open-font )
[
[
[ name>> font-name <CFString> &CFRelease ] [ size>> ] bi
f CTFontCreateWithName
] keep apply-font-traits
] with-destructors ;
: cache-font ( font -- open-font )
strip-font-colors (cache-font) ;
MEMO: (cache-font-metrics) ( font -- metrics )
[ metrics new ] dip
(cache-font) {
[ CTFontGetAscent >>ascent ]
[ CTFontGetDescent >>descent ]
[ CTFontGetLeading >>leading ]
[ CTFontGetCapHeight >>cap-height ]
[ CTFontGetXHeight >>x-height ]
} cleave
compute-height ;
: cache-font-metrics ( font -- metrics )
strip-font-colors (cache-font-metrics) ;
[
\ (cache-font) reset-memoized
\ (cache-font-metrics) reset-memoized
] "core-text.fonts" add-init-hook

1
unmaintained/swap/tags.txt → basis/core-text/fonts/tags.txt
View File

@ -1 +1,2 @@
unportable
bindings

1
basis/core-text/summary.txt Normal file
View File

@ -0,0 +1 @@
Binding for Mac OS X Core Text library

2
basis/core-text/tags.txt Normal file
View File

@ -0,0 +1,2 @@
unportable
bindings

Some files were not shown because too many files have changed in this diff Show More