New alien.destructors vocab defines a functor which generalizes &CFRelease; flesh out core-graphics and core-text bindings

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,27 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: functors destructors accessors kernel lexer words ;
+IN: alien.destructors
+
+FUNCTOR: define-destructor ( F -- )
+
+F IS ${F}
+F-destructor DEFINES ${F}-destructor
+&F DEFINES &${F}
+|F DEFINES |${F}
+
+WHERE
+
+TUPLE: F-destructor alien disposed ;
+
+M: F-destructor dispose* alien>> F execute ;
+
+: &F ( alien -- alien )
+    dup f F-destructor boa &dispose drop ; inline
+
+: |F ( alien -- alien )
+    dup f F-destructor boa |dispose drop ; inline
+
+;FUNCTOR
+
+: DESTRUCTOR: scan 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/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.destructors accessors kernel ;
 IN: core-foundation
 
 TYPEDEF: void* CFTypeRef
@@ -20,12 +20,4 @@ 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-graphics/core-graphics-tests.factor

@@ -0,0 +1,6 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-graphics kernel ;
+IN: core-graphics.tests
+
+[ ] [ 100 200 [ drop ] with-bitmap-context ] unit-test

basis/core-graphics/core-graphics.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax math ;
+USING: alien.syntax alien.c-types alien.destructors math
+locals fry sequences destructors kernel ;
 IN: core-graphics
 
 TYPEDEF: void* CGColorSpaceRef
@@ -42,6 +43,12 @@ FUNCTION: CGContextRef CGBitmapContextCreate (
 
 FUNCTION: void CGColorSpaceRelease ( CGColorSpaceRef ref ) ;
 
+DESTRUCTOR: CGColorSpaceRelease
+
+FUNCTION: void CGContextRelease ( CGContextRef ref ) ;
+
+DESTRUCTOR: CGContextRelease
+
 FUNCTION: void CGContextSetRGBStrokeColor (
    CGContextRef c,
    CGFloat red,
@@ -63,3 +70,16 @@ FUNCTION: void CGContextSetTextPosition (
    CGFloat x,
    CGFloat y
 ) ;
+
+:: <CGBitmapContext> ( data w h -- context )
+    [
+        data w h 8 w 4 *
+        CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease
+        kCGImageAlphaPremultipliedLast CGBitmapContextCreate
+    ] with-destructors ;
+
+: with-bitmap-context ( w h quot -- data )
+    '[
+        [ * "uint" <c-array> ] 2keep
+        [ <CGBitmapContext> &CGContextRelease @ ] [ 2drop ] 3bi
+    ] with-destructors ; inline

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

@@ -1,4 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-text ;
+USING: tools.test core-text core-foundation ;
 IN: core-text.tests
+
+[ ] [ "Helvetica" 12 <CTFont> CFRelease ] unit-test

basis/core-text/core-text.factor

@@ -1,9 +1,42 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax core-foundation.attributed-strings ;
+USING: alien alien.c-types alien.syntax kernel destructors
+parser accessors fry words
+core-foundation core-foundation.strings
+core-foundation.attributed-strings ;
 IN: core-text
 
 TYPEDEF: void* CTLineRef
+TYPEDEF: void* CTFontRef
+
+FUNCTION: CTFontRef CTFontCreateWithName (
+   CFStringRef name,
+   CGFloat size,
+   CGAffineTransform* matrix
+) ;
+
+: <CTFont> ( name size -- font )
+    [
+        [ <CFString> &CFRelease ] dip f CTFontCreateWithName
+    ] with-destructors ;
+
+<<
+
+: C-GLOBAL:
+    CREATE-WORD
+    dup name>> '[ _ f dlsym *void* ]
+    (( -- value )) define-declared ; parsing
+
+>>
+
+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 ) ;