2006-03-08 15:15:12 -05:00
|
|
|
! Copyright (C) 2006 Slava Pestov
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
|
|
IN: objc
|
2006-03-09 01:44:17 -05:00
|
|
|
USING: alien arrays compiler hashtables kernel kernel-internals
|
|
|
|
libc math namespaces sequences strings ;
|
2006-03-08 15:15:12 -05:00
|
|
|
|
2006-03-09 01:44:17 -05:00
|
|
|
: encode-types ( return types -- encoding )
|
|
|
|
>r 1array r> append
|
|
|
|
[ alien>objc-types get hash ] map >string ;
|
|
|
|
|
|
|
|
: prepare-method ( { name return types quot } -- sel type imp )
|
|
|
|
[ first3 encode-types >r sel_registerName r> ] keep
|
|
|
|
[ % \ alien-callback , ] [ ] make compile-1 ;
|
|
|
|
|
|
|
|
: init-method ( method alien -- )
|
|
|
|
>r prepare-method r>
|
|
|
|
[ set-objc-method-imp ] keep
|
|
|
|
[ set-objc-method-types ] keep
|
|
|
|
set-objc-method-name ;
|
|
|
|
|
|
|
|
: <empty-method-list> ( n -- alien )
|
|
|
|
"objc-method-list" c-size
|
|
|
|
"objc-method" c-size rot * + 1 calloc ;
|
|
|
|
|
|
|
|
: <method-list> ( methods -- alien )
|
|
|
|
dup length dup <empty-method-list> -rot
|
|
|
|
[ pick objc-method-nth init-method ] 2each ;
|
|
|
|
|
|
|
|
: <method-lists> ( methods -- lists )
|
|
|
|
<method-list> alien-address
|
|
|
|
"void*" <malloc-object> [ 0 set-alien-unsigned-cell ] keep ;
|
2006-03-08 16:07:17 -05:00
|
|
|
|
|
|
|
: <objc-class> ( name info -- class )
|
|
|
|
"objc-class" <malloc-object>
|
|
|
|
[ set-objc-class-info ] keep
|
2006-03-09 01:44:17 -05:00
|
|
|
[ >r <malloc-string> r> set-objc-class-name ] keep ;
|
2006-03-08 16:07:17 -05:00
|
|
|
|
2006-03-09 01:44:17 -05:00
|
|
|
! The Objective C object model is a bit funny.
|
2006-03-08 16:07:17 -05:00
|
|
|
! Every class has a metaclass.
|
|
|
|
|
|
|
|
! The superclass of the metaclass of X is the metaclass of the
|
|
|
|
! superclass of X.
|
|
|
|
|
|
|
|
! The metaclass of the metaclass of X is the metaclass of the
|
|
|
|
! root class of X.
|
|
|
|
: meta-meta-class ( class -- class ) root-class objc-class-isa ;
|
|
|
|
|
2006-03-09 01:44:17 -05:00
|
|
|
: <meta-class> ( methods superclass name -- class )
|
2006-03-08 16:07:17 -05:00
|
|
|
CLS_META <objc-class>
|
|
|
|
[ >r dup objc-class-isa r> set-objc-class-super-class ] keep
|
2006-03-09 01:44:17 -05:00
|
|
|
[ >r meta-meta-class r> set-objc-class-isa ] keep
|
|
|
|
[ >r <method-lists> r> set-objc-class-methodLists ] keep ;
|
2006-03-08 16:07:17 -05:00
|
|
|
|
2006-03-09 01:44:17 -05:00
|
|
|
: <new-class> ( methods metaclass superclass name -- class )
|
2006-03-08 16:07:17 -05:00
|
|
|
CLS_CLASS <objc-class>
|
|
|
|
[ set-objc-class-super-class ] keep
|
2006-03-09 01:44:17 -05:00
|
|
|
[ set-objc-class-isa ] keep
|
|
|
|
[ >r <method-lists> r> set-objc-class-methodLists ] keep ;
|
2006-03-08 16:07:17 -05:00
|
|
|
|
2006-03-09 01:44:17 -05:00
|
|
|
: (define-objc-class) ( imeth cmeth superclass name -- class )
|
2006-03-08 16:07:17 -05:00
|
|
|
>r objc-class r> [ <meta-class> ] 2keep <new-class>
|
|
|
|
dup objc_addClass ;
|
|
|
|
|
2006-03-09 01:44:17 -05:00
|
|
|
: define-objc-class ( imeth cmeth superclass name -- class )
|
2006-03-08 16:07:17 -05:00
|
|
|
dup class-exists?
|
2006-03-09 01:44:17 -05:00
|
|
|
[ >r 3drop r> objc-class ] [ (define-objc-class) ] if ;
|