Added a Cocoa library exporting some useful Cocoa stuff.
This commit is contained in:
parent
8c30f0715b
commit
60f5142143
|
@ -0,0 +1,52 @@
|
|||
|
||||
(library (Cocoa)
|
||||
(export) ; below
|
||||
(import (ikarus) (objc))
|
||||
|
||||
(define-syntax define-and-export
|
||||
(syntax-rules ()
|
||||
[(_ (def* name* . rest*) ...)
|
||||
(begin
|
||||
(def* name* . rest*) ...
|
||||
(export name* ...))]))
|
||||
|
||||
(define-and-export
|
||||
(define-framework Cocoa)
|
||||
(define-class NSAutoreleasePool)
|
||||
(define-class NSWindow)
|
||||
(define-class NSApplication)
|
||||
(define-class NSString)
|
||||
(define-object NSApp Cocoa)
|
||||
|
||||
(define NSBorderlessWindowMask #b000000000)
|
||||
(define NSTitledWindowMask #b000000001)
|
||||
(define NSClosableWindowMask #b000000010)
|
||||
(define NSMiniaturizableWindowMask #b000000100)
|
||||
(define NSResizableWindowMask #b000001000)
|
||||
(define NSTexturedBackgroundWindowMask #b100000000)
|
||||
|
||||
(define NSBackingStoreRetained 0)
|
||||
(define NSBackingStoreNonretained 1)
|
||||
(define NSBackingStoreBuffered 2)
|
||||
|
||||
(define NSASCIIStringEncoding 1) ; /* 0..127 only */
|
||||
(define NSNEXTSTEPStringEncoding 2)
|
||||
(define NSJapaneseEUCStringEncoding 3)
|
||||
(define NSUTF8StringEncoding 4)
|
||||
(define NSISOLatin1StringEncoding 5)
|
||||
(define NSSymbolStringEncoding 6)
|
||||
(define NSNonLossyASCIIStringEncoding 7)
|
||||
(define NSShiftJISStringEncoding 8)
|
||||
(define NSISOLatin2StringEncoding 9)
|
||||
(define NSUnicodeStringEncoding 10)
|
||||
(define NSWindowsCP1251StringEncoding 11) ; /* Cyrillic; same as AdobeStandardCyrillic */
|
||||
(define NSWindowsCP1252StringEncoding 12) ; /* WinLatin1 */
|
||||
(define NSWindowsCP1253StringEncoding 13) ; /* Greek */
|
||||
(define NSWindowsCP1254StringEncoding 14) ; /* Turkish */
|
||||
(define NSWindowsCP1250StringEncoding 15) ; /* WinLatin2 */
|
||||
(define NSISO2022JPStringEncoding 21) ; /* ISO 2022 Japanese encoding for e-mail */
|
||||
(define NSMacOSRomanStringEncoding 30)
|
||||
(define NSProprietaryStringEncoding 65536) ; /* Installation-specific encoding */
|
||||
|
||||
))
|
||||
|
|
@ -1,47 +1,36 @@
|
|||
#!/usr/bin/env ikarus --r6rs-script
|
||||
;;; vim:syntax=scheme
|
||||
(import (ikarus) (objc))
|
||||
|
||||
(define-framework Cocoa)
|
||||
(define-class NSAutoreleasePool)
|
||||
(define-class NSWindow)
|
||||
(define-class NSApplication)
|
||||
(define-object NSApp Cocoa)
|
||||
|
||||
(import (ikarus) (objc) (Cocoa))
|
||||
|
||||
(define pool [$ [$ NSAutoreleasePool alloc] init])
|
||||
|
||||
[$ NSApplication sharedApplication]
|
||||
|
||||
(define NSBorderlessWindowMask #b000000000)
|
||||
(define NSTitledWindowMask #b000000001)
|
||||
(define NSClosableWindowMask #b000000010)
|
||||
(define NSMiniaturizableWindowMask #b000000100)
|
||||
(define NSResizableWindowMask #b000001000)
|
||||
(define NSTexturedBackgroundWindowMask #b100000000)
|
||||
|
||||
(define NSBackingStoreRetained 0)
|
||||
(define NSBackingStoreNonretained 1)
|
||||
(define NSBackingStoreBuffered 2)
|
||||
|
||||
(define style
|
||||
(define style
|
||||
(bitwise-ior
|
||||
NSTitledWindowMask
|
||||
NSClosableWindowMask
|
||||
NSResizableWindowMask
|
||||
NSTexturedBackgroundWindowMask
|
||||
NSTitledWindowMask
|
||||
NSMiniaturizableWindowMask))
|
||||
|
||||
(define backing NSBackingStoreBuffered)
|
||||
|
||||
(define win [$ [$ NSWindow alloc]
|
||||
initWithContentRect: '#(#(50 50) #(600 400))
|
||||
styleMask: style
|
||||
backing: backing
|
||||
defer: #f])
|
||||
(define win
|
||||
[$ [$ NSWindow alloc]
|
||||
initWithContentRect: '#(#(50 50) #(600 400))
|
||||
styleMask: style
|
||||
backing: backing
|
||||
defer: #f])
|
||||
|
||||
(define (nsstring x)
|
||||
[$ [$ NSString alloc]
|
||||
initWithCharactersNoCopy: x
|
||||
length: (string-length x)
|
||||
freeWhenDone: #t])
|
||||
|
||||
[$ win setTitle: (nsstring "Hello Ikarus")]
|
||||
|
||||
[$ win makeKeyAndOrderFront: win]
|
||||
|
||||
[$ NSApp run]
|
||||
[$ pool release]
|
||||
|
||||
|
||||
|
|
|
@ -4,6 +4,7 @@
|
|||
define-framework
|
||||
define-class
|
||||
define-object
|
||||
string->char*
|
||||
$)
|
||||
(import
|
||||
(ikarus)
|
||||
|
@ -65,9 +66,36 @@
|
|||
(bytevector-u8-set! bv i (pointer-ref-uchar x i))
|
||||
(f (+ i 1))])))))
|
||||
|
||||
(define (bv->char* x)
|
||||
(let ([n (bytevector-length x)])
|
||||
(let ([p (malloc (+ n 1))])
|
||||
(pointer-set-char p n 0)
|
||||
(let f ([i 0])
|
||||
(cond
|
||||
[(= i n) p]
|
||||
[else
|
||||
(pointer-set-char p i (bytevector-s8-ref x i))
|
||||
(f (+ i 1))])))))
|
||||
|
||||
(define (bv->u8* x)
|
||||
(let ([n (bytevector-length x)])
|
||||
(let ([p (malloc n)])
|
||||
(let f ([i 0])
|
||||
(cond
|
||||
[(= i n) p]
|
||||
[else
|
||||
(pointer-set-char p i (bytevector-s8-ref x i))
|
||||
(f (+ i 1))])))))
|
||||
|
||||
|
||||
(define (char*->string x)
|
||||
(utf8->string (char*->bv x)))
|
||||
|
||||
(define (string->char* x)
|
||||
(let ([bv (string->utf8 x)])
|
||||
(bv->char* bv)))
|
||||
|
||||
|
||||
(define-syntax check
|
||||
(syntax-rules ()
|
||||
[(_ who pred expr)
|
||||
|
@ -293,6 +321,7 @@
|
|||
[(#\f) (values 'float (+ i 1))]
|
||||
[(#\i) (values 'int (+ i 1))]
|
||||
[(#\I) (values 'uint (+ i 1))]
|
||||
[(#\S) (values 'ushort (+ i 1))]
|
||||
[(#\c) (values 'char (+ i 1))]
|
||||
[(#\{) ;;; struct
|
||||
(let ([i (scan (+ i 1) #\=)])
|
||||
|
@ -307,7 +336,12 @@
|
|||
(let-values ([(i ls) (f i)])
|
||||
(values i (cons x ls)))])))])
|
||||
(values (list->vector ls) i)))]
|
||||
[(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
[(#\*) (values 'char* (+ i 1))]
|
||||
[(#\^)
|
||||
(let-values ([(t i) (parse (+ i 1))])
|
||||
(values (cons 'pointer t) i))]
|
||||
[(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
|
||||
#\r)
|
||||
(values 'skip (+ i 1))]
|
||||
[else (error who "invalid char" c str)]))]))
|
||||
(define (cons/skip x y)
|
||||
|
@ -324,6 +358,7 @@
|
|||
(cond
|
||||
[(vector? x)
|
||||
(vector-map objc-type->ikarus-type x)]
|
||||
[(pair? x) 'pointer]
|
||||
[else
|
||||
(case x
|
||||
[(selector) 'pointer]
|
||||
|
@ -333,6 +368,7 @@
|
|||
[(uint) 'uint32]
|
||||
[(int) 'sint32]
|
||||
[(char) 'sint8]
|
||||
[(char*) 'pointer]
|
||||
[else (error 'objc-type->ikarus-type "invalid type" x)])]))
|
||||
|
||||
|
||||
|
@ -352,6 +388,14 @@
|
|||
(error 'convert-outgoing "length mismatch" x t))
|
||||
(vector-map convert-outgoing t x)]
|
||||
[else (error 'convert-output "not a vector" x)])]
|
||||
[(and (pair? t) (eq? (car t) 'pointer))
|
||||
(case (cdr t)
|
||||
[(ushort)
|
||||
(cond
|
||||
[(string? x)
|
||||
(bv->u8* (string->utf16 x 'little))]
|
||||
[else (error 'convert-output "cannot convert to ushort*" x)])]
|
||||
[else (error 'convert-output "dunno how to convert" t)])]
|
||||
[else
|
||||
(case t
|
||||
[(selector)
|
||||
|
@ -374,6 +418,10 @@
|
|||
[(or (fixnum? x) (bignum? x)) x]
|
||||
[(boolean? x) (if x 1 0)]
|
||||
[else (error 'convert-output "cannot convert to int" x)])]
|
||||
[(char*)
|
||||
(cond
|
||||
[(string? x) (string->char* x)]
|
||||
[else (error 'convert-output "cannot convert to char*" x)])]
|
||||
[else (error 'convert-outgoing "invalid type" t)])]))
|
||||
|
||||
|
||||
|
|
Loading…
Reference in New Issue