From 60f51421433a6a725058ea31fd9ce4efd7b3b740 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Fri, 26 Sep 2008 04:11:18 -0400 Subject: [PATCH] Added a Cocoa library exporting some useful Cocoa stuff. --- lab/objc/Cocoa.ss | 52 +++++++++++++++++++++++++++++++++++++++++ lab/objc/hello-cocoa.ss | 47 ++++++++++++++----------------------- lab/objc/objc.ss | 50 ++++++++++++++++++++++++++++++++++++++- 3 files changed, 119 insertions(+), 30 deletions(-) create mode 100755 lab/objc/Cocoa.ss diff --git a/lab/objc/Cocoa.ss b/lab/objc/Cocoa.ss new file mode 100755 index 0000000..2b573c6 --- /dev/null +++ b/lab/objc/Cocoa.ss @@ -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 */ + + )) + diff --git a/lab/objc/hello-cocoa.ss b/lab/objc/hello-cocoa.ss index b9d8b49..b4c9f86 100755 --- a/lab/objc/hello-cocoa.ss +++ b/lab/objc/hello-cocoa.ss @@ -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] - - diff --git a/lab/objc/objc.ss b/lab/objc/objc.ss index b3a7e5b..32a624b 100644 --- a/lab/objc/objc.ss +++ b/lab/objc/objc.ss @@ -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)])]))