Merge branch 'master' of git://factorcode.org/git/factor

Factor.app/Contents/Resources/English.lproj/Factor.nib/classes.nib

@@ -1,17 +1,38 @@
-{
+<?xml version="1.0" encoding="UTF-8"?>
-    IBClasses = (
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
-        {
+<plist version="1.0">
-            ACTIONS = {
+<dict>
-                newFactorWorkspace = id; 
+	<key>IBClasses</key>
-                runFactorFile = id; 
+	<array>
-                saveFactorImage = id; 
+		<dict>
-                saveFactorImageAs = id; 
+			<key>ACTIONS</key>
-                showFactorHelp = id; 
+			<dict>
-            }; 
+				<key>factorBrowser</key>
-            CLASS = FirstResponder; 
+				<string>id</string>
-            LANGUAGE = ObjC; 
+				<key>factorListener</key>
-            SUPERCLASS = NSObject; 
+				<string>id</string>
-        }
+				<key>newFactorBrowser</key>
-    ); 
+				<string>id</string>
-    IBVersion = 1; 
+				<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>

Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib

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

README.txt

@@ -153,7 +153,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!
 

basis/alien/destructors/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/alien/destructors/destructors-tests.factor

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

basis/alien/destructors/destructors.factor

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

basis/alien/destructors/summary.txt

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

basis/alien/syntax/syntax.factor

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

basis/bootstrap/ui/tools/tools.factor

@@ -4,8 +4,8 @@ USING: kernel vocabs vocabs.loader sequences system ;
 [ "bootstrap." prepend vocab ] all? [
     "ui.tools" require
 
-    "ui.cocoa" vocab [
+    "ui.backend.cocoa" vocab [
-        "ui.cocoa.tools" require
+        "ui.backend.cocoa.tools" require
     ] when
 
     "ui.tools.walker" require

basis/bootstrap/ui/ui.factor

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

basis/cache/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/cache/cache-tests.factor

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

basis/cache/cache.factor

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

basis/cache/summary.txt

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

basis/cache/tags.txt

@@ -0,0 +1 @@
+collections

basis/cairo/authors.txt

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

basis/cairo/cairo-tests.factor

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

basis/cairo/cairo.factor

@@ -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
+USING: colors fonts cairo.ffi alien alien.c-types kernel accessors
-namespaces fry continuations destructors ;
+sequences namespaces fry continuations destructors math images
+images.memory math.rectangles ;
 IN: cairo
 
-TUPLE: cairo-t alien ;
+ERROR: cairo-error message ;
-C: <cairo-t> cairo-t
-M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
 
-TUPLE: cairo-surface-t alien ;
+: (check-cairo) ( cairo_status_t -- )
-C: <cairo-surface-t> cairo-surface-t
+    dup CAIRO_STATUS_SUCCESS =
-M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
+    [ drop ] [ cairo_status_to_string cairo-error ] if ;
 
-: check-cairo ( cairo_status_t -- )
+: check-cairo ( cairo -- ) cairo_status (check-cairo) ;
-    dup CAIRO_STATUS_SUCCESS = [ drop ]
-    [ cairo_status_to_string "Cairo error: " prepend throw ] if ;
 
-SYMBOL: cairo
+: check-surface ( surface -- ) cairo_surface_status (check-cairo) ;
-: cr ( -- cairo ) cairo get ; inline
 
-: (with-cairo) ( cairo-t quot -- )
+: width>stride ( width -- stride ) "uint" heap-size * ; inline
-    [ alien>> cairo ] dip
-    '[ @ cr cairo_status check-cairo ]
-    with-variable ; inline
 
-: with-cairo ( cairo quot -- )
+: <image-surface> ( data dim -- surface )
-    [ <cairo-t> ] dip '[ _ (with-cairo) ] with-disposal ; inline
+    [ CAIRO_FORMAT_ARGB32 ] dip first2 over width>stride
+    cairo_image_surface_create_for_data
+    dup check-surface ;
 
-: (with-surface) ( cairo-surface-t quot -- )
+: <cairo> ( surface -- cairo ) cairo_create dup check-cairo ; inline
-    [ alien>> ] dip [ cairo_surface_status check-cairo ] bi ; inline
 
-: with-surface ( cairo_surface quot -- )
+: make-bitmap-image ( dim quot -- image )
-    [ <cairo-surface-t> ] dip '[ _ (with-surface) ] with-disposal ; inline
+    '[
+        <image-surface> &cairo_surface_destroy
+        <cairo> &cairo_destroy
+        @
+    ] make-memory-bitmap
+    BGRA >>component-order ; inline
 
-: with-cairo-from-surface ( cairo_surface quot -- )
+: dummy-cairo ( -- cr )
-    '[ cairo_create _ with-cairo ] with-surface ; inline
+    #! 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 ;

basis/cairo/ffi/ffi.factor

@@ -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 
+USING: system combinators alien alien.syntax alien.c-types
-alien.c-types accessors sequences arrays ui.gadgets ;
+alien.destructors kernel accessors sequences arrays ui.gadgets ;
 
 IN: cairo.ffi
-<< "cairo" {
+<< {
-    { [ os winnt? ] [ "libcairo-2.dll" ] }
+    { [ os winnt? ] [ "cairo" "libcairo-2.dll" "cdecl" add-library ] }
-    { [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
+    { [ os macosx? ] [ "cairo" "/opt/local/lib/libcairo.dylib" "cdecl" add-library ] }
-    { [ os unix? ] [ "libcairo.so.2" ] }
+    { [ os unix? ] [ ] }
-} cond "cdecl" add-library >>
+} 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 ) ;
 

basis/cairo/gadgets/gadgets.factor

@@ -26,7 +26,7 @@ GENERIC: render-cairo* ( gadget -- )
 TUPLE: cairo-gadget < gadget ;
 
 : <cairo-gadget> ( dim -- gadget )
-    cairo-gadget new-gadget
+    cairo-gadget new
         swap >>dim ;
 
 M: cairo-gadget draw-gadget*

basis/cocoa/application/application-docs.factor

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

basis/cocoa/application/application.factor

@@ -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
+C-ENUM:
-CONSTANT: NSApplicationDelegateReplyCancel  1
+NSApplicationDelegateReplySuccess
-CONSTANT: NSApplicationDelegateReplyFailure 2
+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: ;

basis/cocoa/cocoa-docs.factor

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

basis/cocoa/cocoa-tests.factor

@@ -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
+[ 1.0 ] [ "x" get CGRect-x ] unit-test
-[ 2.0 ] [ "x" get NSRect-y ] unit-test
+[ 2.0 ] [ "x" get CGRect-y ] unit-test
-[ 101.0 ] [ "x" get NSRect-w ] unit-test
+[ 101.0 ] [ "x" get CGRect-w ] unit-test
-[ 102.0 ] [ "x" get NSRect-h ] 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
+[ 1.0 ] [ "x" get CGRect-x ] unit-test
-[ 2.0 ] [ "x" get NSRect-y ] unit-test
+[ 2.0 ] [ "x" get CGRect-y ] unit-test
-[ 101.0 ] [ "x" get NSRect-w ] unit-test
+[ 101.0 ] [ "x" get CGRect-w ] unit-test
-[ 102.0 ] [ "x" get NSRect-h ] unit-test
+[ 102.0 ] [ "x" get CGRect-h ] unit-test
 
 ! Make sure that we can add methods
 CLASS: {

basis/cocoa/enumeration/enumeration.factor

@@ -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 "id" malloc-array &free
         NS-EACH-BUFFER-SIZE
-        ] dip call
+        @
     ] with-destructors ; inline
 
 :: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )

basis/cocoa/messages/messages.factor

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

basis/cocoa/pasteboard/pasteboard.factor

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

basis/cocoa/plists/plists-tests.factor

@@ -0,0 +1,10 @@
+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
+] with-destructors

basis/cocoa/plists/plists.factor

@@ -1,42 +1,29 @@
-! 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 )
+: >plist ( value -- plist ) >cf -> autorelease ;
-
-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> ;
 
 : write-plist ( assoc path -- )
-    [ >plist ] [ normalize-path <NSString> ] bi* 0
+    [ >plist ] [ normalize-path <NSString> ] bi* 0 -> writeToFile:atomically:
-    -> writeToFile:atomically:
     [ "write-plist failed" throw ] unless ;
 
 DEFER: plist>
 
+<PRIVATE
+
 : (plist-NSString>) ( NSString -- string )
     -> UTF8String ;
 
 : (plist-NSNumber>) ( NSNumber -- number )
     dup -> doubleValue dup >integer =
-    [ -> longLongValue ]
+    [ -> longLongValue ] [ -> doubleValue ] if ;
-    [ -> doubleValue ] if ;
 
 : (plist-NSData>) ( NSData -- byte-array )
     dup -> length <byte-array> [ -> getBytes: ] keep ;
@@ -45,24 +32,29 @@ DEFER: plist>
     [ 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:

basis/cocoa/subclassing/subclassing.factor

@@ -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 [
+    swap prefix [ encode-type "0" append ] map concat ;
-        alien>objc-types get at "0" append
-    ] map concat ;
 
 : prepare-method ( ret types quot -- type imp )
     [ [ encode-types ] 2keep ] dip

basis/cocoa/types/types-docs.factor

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

basis/cocoa/types/types.factor

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

basis/cocoa/views/views.factor

@@ -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
+cocoa cocoa.messages cocoa.classes core-graphics
-continuations accessors ;
+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: NSOpenGLCPSwapInterval 222
-CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
 
 <PRIVATE
 
-SYMBOL: +software-renderer+
+SYMBOL: software-renderer?
-SYMBOL: +multisample+
+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
+    [ CGRect-w >fixnum ] [ CGRect-h >fixnum ] bi
-    swap NSRect-h >fixnum 2array ;
+    2array ;
 
 : mouse-location ( view event -- loc )
     [
         -> locationInWindow f -> convertPoint:fromView:
-        [ NSPoint-x ] [ NSPoint-y ] bi
+        [ CGPoint-x ] [ CGPoint-y ] bi
-    ] [ drop -> frame NSRect-h ] 2bi
+    ] [ 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 ) ;
-

basis/colors/colors-docs.factor

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

basis/colors/colors.factor

@@ -1,16 +1,20 @@
-! 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 ) ;
 
@@ -18,16 +22,9 @@ M: color red>>   ( color -- red   ) >rgba red>>   ;
 M: color green>> ( color -- green ) >rgba green>> ;
 M: color blue>> ( color -- blue ) >rgba blue>> ;
 
-CONSTANT: black        T{ rgba f 0.0   0.0   0.0   1.0  }
+: >rgba-components ( object -- r g b a )
-CONSTANT: blue         T{ rgba f 0.0   0.0   1.0   1.0  }
+    >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline
-CONSTANT: cyan         T{ rgba f 0     0.941 0.941 1    }
+
-CONSTANT: gray         T{ rgba f 0.6   0.6   0.6   1.0  }
+: opaque? ( color -- ? ) alpha>> 1 number= ;
-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: transparent T{ rgba f 0.0 0.0 0.0 0.0 }
-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  }

basis/colors/constants/constants-docs.factor

@@ -0,0 +1,31 @@
+IN: colors.constants
+USING: help.markup help.syntax strings colors ;
+
+HELP: named-color
+{ $values { "string" 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" 

basis/colors/constants/constants.factor

@@ -23,6 +23,8 @@ MEMO: rgb.txt ( -- assoc )
 
 PRIVATE>
 
+: named-colors ( -- keys ) rgb.txt keys ;
+
 ERROR: no-such-color name ;
 
 : named-color ( name -- rgb )

basis/colors/gray/gray-docs.factor

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

basis/colors/gray/gray.factor

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

basis/colors/hsv/hsv-docs.factor

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

basis/colors/hsv/hsv-tests.factor

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

basis/colors/hsv/hsv.factor

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

basis/compiler/cfg/intrinsics/fixnum/fixnum.factor

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

basis/compiler/cfg/intrinsics/slots/slots.factor

@@ -28,15 +28,14 @@ IN: compiler.cfg.intrinsics.slots
     ] [ drop emit-primitive ] if ;
 
 : (emit-set-slot) ( infos -- obj-reg )
-    [ 3inputs [ tuck ] dip ^^offset>slot ]
+    [ 3inputs ^^offset>slot ] [ second value-tag ] bi*
-    [ second value-tag ]
+    pick [ ^^set-slot ] dip ;
-    bi* ^^set-slot ;
 
 : (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

basis/compiler/cfg/linear-scan/allocation/allocation.factor

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

basis/compiler/tree/dead-code/simple/simple.factor

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

basis/core-foundation/attributed-strings/attributed-strings-tests.factor

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

basis/core-foundation/attributed-strings/attributed-strings.factor

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

basis/core-foundation/attributed-strings/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/core-foundation/core-foundation.factor

@@ -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 ;
+DESTRUCTOR: CFRelease
-
-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

basis/core-foundation/data/data.factor

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

basis/core-foundation/dictionaries/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/core-foundation/dictionaries/dictionaries-tests.factor

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

basis/core-foundation/dictionaries/dictionaries.factor

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

basis/core-foundation/dictionaries/tags.txt

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

basis/core-foundation/numbers/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/core-foundation/numbers/numbers-tests.factor

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

basis/core-foundation/numbers/numbers.factor

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

basis/core-foundation/run-loop/run-loop.factor

@@ -56,25 +56,17 @@ FUNCTION: void CFRunLoopRemoveTimer (
 
 : CFRunLoopDefaultMode ( -- alien )
     #! Ugly, but we don't have static NSStrings
-    \ CFRunLoopDefaultMode get-global dup expired? [
+    \ CFRunLoopDefaultMode [
-        drop
         "kCFRunLoopDefaultMode" <CFString>
-        dup \ CFRunLoopDefaultMode set-global
+    ] initialize-alien ;
-    ] when ;
 
 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
+    \ run-loop [ <run-loop> ] initialize-alien ;
-    [
-        31337 <alien> expiry-check set-global
-        <run-loop> dup \ run-loop set-global
-    ] [ \ run-loop get-global ] if ;
 
 : add-source-to-run-loop ( source -- )
     [ run-loop sources>> push ]

basis/core-foundation/strings/strings-tests.factor

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

basis/core-foundation/strings/strings.factor

@@ -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
+USING: alien.syntax alien.strings io.encodings.string kernel
-io.encodings.utf8 math core-foundation core-foundation.arrays ;
+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
+    [ f ] dip
-    [ "CFStringCreateWithCString failed" throw ] unless* ;
+    prepare-CFString dup length
+    kCFStringEncodingUTF8 f
+    CFStringCreateWithBytes
+    [ "CFStringCreateWithBytes failed" throw ] unless* ;
 
 : CF>string ( alien -- string )
-    dup CFStringGetLength 4 * 1 + <byte-array> [
+    dup CFStringGetLength
-        dup length
+    [ 0 swap <CFRange> kCFStringEncodingUTF8 0 f ] keep
-        kCFStringEncodingUTF8
+    4 * 1 + <byte-array> [ dup length 0 <CFIndex> [ CFStringGetBytes drop ] keep ] keep
-        CFStringGetCString
+    swap *CFIndex head-slice utf8 decode ;
-        [ "CFStringGetCString failed" throw ] unless
-    ] keep utf8 alien>string ;
 
 : 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 ;

basis/core-foundation/summary.txt

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

basis/core-foundation/utilities/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/core-foundation/utilities/utilities-tests.factor

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

basis/core-foundation/utilities/utilities.factor

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

basis/core-graphics/core-graphics-tests.factor

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

basis/core-graphics/core-graphics.factor

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

basis/core-graphics/summary.txt

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

basis/core-graphics/tags.txt

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

basis/core-graphics/types/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/core-graphics/types/types-docs.factor

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

basis/core-graphics/types/types-tests.factor

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

basis/core-graphics/types/types.factor

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

basis/core-text/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/core-text/core-text-tests.factor

@@ -0,0 +1,37 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-text core-foundation
+core-foundation.dictionaries destructors
+arrays kernel generalizations math accessors
+core-foundation.utilities
+combinators hashtables colors ;
+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 white <CTLine> &CFRelease
+        line-typographic-bounds {
+            [ 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

basis/core-text/core-text.factor

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

basis/core-text/fonts/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/core-text/fonts/fonts-tests.factor

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

basis/core-text/fonts/fonts.factor

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

basis/core-text/summary.txt

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

basis/core-text/tags.txt

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

basis/core-text/utilities/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/core-text/utilities/utilities-tests.factor

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

basis/core-text/utilities/utilities.factor

@@ -0,0 +1,9 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: words parser alien alien.c-types kernel fry accessors ;
+IN: core-text.utilities
+
+: C-GLOBAL:
+    CREATE-WORD
+    dup name>> '[ _ f dlsym *void* ]
+    (( -- value )) define-declared ; parsing

basis/debugger/debugger.factor

@@ -252,8 +252,8 @@ M: already-disposed summary drop "Attempting to operate on disposed object" ;
 M: no-current-vocab summary
     drop "Not in a vocabulary; IN: form required" ;
 
-M: no-word-error summary
+M: no-word-error error.
-    drop "Word not found in current vocabulary search path" ;
+    "No word named ``" write name>> write "'' found in current vocabulary search path" print ;
 
 M: staging-violation summary
     drop

basis/definitions/icons/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/definitions/icons/icons-tests.factor

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

basis/definitions/icons/icons.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs classes.predicate fry generic io.pathnames kernel
+macros sequences vocabs words words.symbol words.constant
+lexer parser help.topics ;
+IN: definitions.icons
+
+GENERIC: definition-icon ( definition -- path )
+
+<PRIVATE
+
+: definition-icon-path ( string -- string' )
+    "resource:basis/definitions/icons/" prepend-path ".tiff" append ;
+
+<<
+
+: ICON:
+    scan-word \ definition-icon create-method
+    scan '[ drop _ definition-icon-path ]
+    define ; parsing
+
+>>
+
+ICON: predicate-class class-predicate-word
+ICON: generic generic-word
+ICON: macro macro-word
+ICON: parsing-word parsing-word
+ICON: primitive primitive-word
+ICON: symbol symbol-word
+ICON: constant constant-word
+ICON: word normal-word
+ICON: vocab-link unopen-vocab
+ICON: word-link word-help-article
+ICON: link help-article
+
+PRIVATE>
+
+M: vocab definition-icon
+    vocab-main "runnable-vocab" "open-vocab" ? definition-icon-path ;
+