-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.strings arrays assocs
-classes.struct continuations combinators compiler compiler.alien
-stack-checker kernel math namespaces make quotations sequences
-strings words cocoa.runtime io macros memoize io.encodings.utf8
-effects libc libc.private lexer init core-foundation fry
-generalizations specialized-arrays ;
+USING: accessors alien alien.c-types alien.data alien.strings
+arrays assocs classes.struct continuations combinators compiler
+core-graphics.types stack-checker kernel math namespaces make
+quotations sequences strings words cocoa.runtime cocoa.types io
+macros memoize io.encodings.utf8 effects layouts libc lexer init
+core-foundation fry generalizations specialized-arrays ;
+QUALIFIED-WITH: alien.c-types c
IN: cocoa.messages
SPECIALIZED-ARRAY: void*
: super-send ( receiver args... selector -- return... ) t (send) ; inline
! Runtime introspection
-SYMBOL: class-startup-hooks
+SYMBOL: class-init-hooks
-class-startup-hooks [ H{ } clone ] initialize
+class-init-hooks [ H{ } clone ] initialize
: (objc-class) ( name word -- class )
2dup execute dup [ 2nip ] [
- drop over class-startup-hooks get at [ call( -- ) ] when*
+ drop over class-init-hooks get at [ call( -- ) ] when*
2dup execute dup [ 2nip ] [
2drop "No such class: " prepend throw
] if
SYMBOL: objc>alien-types
H{
- { "c" "char" }
- { "i" "int" }
- { "s" "short" }
- { "C" "uchar" }
- { "I" "uint" }
- { "S" "ushort" }
- { "f" "float" }
- { "d" "double" }
- { "B" "bool" }
- { "v" "void" }
- { "*" "char*" }
- { "?" "unknown_type" }
- { "@" "id" }
- { "#" "Class" }
- { ":" "SEL" }
+ { "c" c:char }
+ { "i" c:int }
+ { "s" c:short }
+ { "C" c:uchar }
+ { "I" c:uint }
+ { "S" c:ushort }
+ { "f" c:float }
+ { "d" c:double }
+ { "B" c:bool }
+ { "v" c:void }
+ { "*" c:c-string }
+ { "?" unknown_type }
+ { "@" id }
+ { "#" Class }
+ { ":" SEL }
}
-"ptrdiff_t" heap-size {
+cell {
{ 4 [ H{
- { "l" "long" }
- { "q" "longlong" }
- { "L" "ulong" }
- { "Q" "ulonglong" }
+ { "l" c:long }
+ { "q" c:longlong }
+ { "L" c:ulong }
+ { "Q" c:ulonglong }
} ] }
{ 8 [ H{
- { "l" "long32" }
- { "q" "long" }
- { "L" "ulong32" }
- { "Q" "ulong" }
+ { "l" long32 }
+ { "q" long }
+ { "L" ulong32 }
+ { "Q" ulong }
} ] }
} case
assoc-union objc>alien-types set-global
+SYMBOL: objc>struct-types
+
+H{
+ { "_NSPoint" NSPoint }
+ { "NSPoint" NSPoint }
+ { "CGPoint" NSPoint }
+ { "_NSRect" NSRect }
+ { "NSRect" NSRect }
+ { "CGRect" NSRect }
+ { "_NSSize" NSSize }
+ { "NSSize" NSSize }
+ { "CGSize" NSSize }
+ { "_NSRange" NSRange }
+ { "NSRange" NSRange }
+} objc>struct-types set-global
+
! The transpose of the above map
SYMBOL: alien>objc-types
objc>alien-types get [ swap ] assoc-map
! A hack...
-"ptrdiff_t" heap-size {
+cell {
{ 4 [ H{
- { "NSPoint" "{_NSPoint=ff}" }
- { "NSRect" "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
- { "NSSize" "{_NSSize=ff}" }
- { "NSRange" "{_NSRange=II}" }
- { "NSInteger" "i" }
- { "NSUInteger" "I" }
- { "CGFloat" "f" }
+ { NSPoint "{_NSPoint=ff}" }
+ { NSRect "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
+ { NSSize "{_NSSize=ff}" }
+ { NSRange "{_NSRange=II}" }
+ { NSInteger "i" }
+ { NSUInteger "I" }
+ { CGFloat "f" }
} ] }
{ 8 [ H{
- { "NSPoint" "{CGPoint=dd}" }
- { "NSRect" "{CGRect={CGPoint=dd}{CGSize=dd}}" }
- { "NSSize" "{CGSize=dd}" }
- { "NSRange" "{_NSRange=QQ}" }
- { "NSInteger" "q" }
- { "NSUInteger" "Q" }
- { "CGFloat" "d" }
+ { NSPoint "{CGPoint=dd}" }
+ { NSRect "{CGRect={CGPoint=dd}{CGSize=dd}}" }
+ { NSSize "{CGSize=dd}" }
+ { NSRange "{_NSRange=QQ}" }
+ { NSInteger "q" }
+ { NSUInteger "Q" }
+ { CGFloat "d" }
} ] }
} case
assoc-union alien>objc-types set-global
-: internal-cocoa-type? ( c-type -- ? )
- [ "?" = ] [ first CHAR: _ = ] bi or ;
-
-: warn-c-type ( c-type -- )
- dup internal-cocoa-type?
- [ drop ] [ "Warning: no such C type: " write print ] if ;
-
: objc-struct-type ( i string -- ctype )
[ CHAR: = ] 2keep index-from swap subseq
- dup c-types get key? [ warn-c-type "void*" ] unless ;
+ objc>struct-types get at* [ drop void* ] unless ;
ERROR: no-objc-type name ;
: (parse-objc-type) ( i string -- ctype )
[ [ 1 + ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
- { [ dup CHAR: ^ = ] [ 3drop "void*" ] }
+ { [ dup CHAR: ^ = ] [ 3drop void* ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
- { [ dup CHAR: [ = ] [ 3drop "void*" ] }
+ { [ dup CHAR: [ = ] [ 3drop void* ] }
[ 2nip decode-type ]
} cond ;
(free) ;
: method-arg-types ( method -- args )
- dup method_getNumberOfArguments
+ dup method_getNumberOfArguments iota
[ method-arg-type ] with map ;
: method-return-type ( method -- ctype )
objc-methods get set-at ;
: each-method-in-class ( class quot -- )
- [ 0 <uint> [ class_copyMethodList ] keep *uint ] dip
+ [ { uint } [ class_copyMethodList ] [ ] with-out-parameters ] dip
over 0 = [ 3drop ] [
[ <direct-void*-array> ] dip
[ each ] [ drop (free) ] 2bi
: class-exists? ( string -- class ) objc_getClass >boolean ;
: define-objc-class-word ( quot name -- )
- [ class-startup-hooks get set-at ]
+ [ class-init-hooks get set-at ]
[
[ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
(( -- class )) define-declared
] bi ;
: import-objc-class ( name quot -- )
- over define-objc-class-word
- [ objc-class register-objc-methods ]
- [ objc-meta-class register-objc-methods ] bi ;
+ 2dup swap define-objc-class-word
+ over class-exists? [ drop ] [ call( -- ) ] if
+ dup class-exists? [
+ [ objc_getClass register-objc-methods ]
+ [ objc_getMetaClass register-objc-methods ] bi
+ ] [ drop ] if ;
: root-class ( class -- root )
dup class_getSuperclass [ root-class ] [ ] ?if ;