factor/library/cocoa/utilities.factor

187 lines
5.1 KiB
Factor
Raw Normal View History

2006-01-10 23:56:00 -05:00
! Copyright (C) 2006 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
2006-02-06 21:51:04 -05:00
IN: objc
2006-05-15 01:01:47 -04:00
USING: alien arrays errors hashtables kernel math
2006-03-10 22:57:57 -05:00
namespaces parser sequences strings words ;
2006-01-10 23:56:00 -05:00
TUPLE: selector name object ;
C: selector ( name -- sel ) [ set-selector-name ] keep ;
: selector ( selector -- alien )
2006-02-09 22:11:22 -05:00
dup selector-object expired? [
2006-01-10 23:56:00 -05:00
dup selector-name sel_registerName
dup rot set-selector-object
2006-02-09 22:11:22 -05:00
] [
selector-object
2006-01-10 23:56:00 -05:00
] if ;
: objc-classes ( -- seq )
f 0 objc_getClassList
[ "void*" <c-array> dup ] keep objc_getClassList
[ swap void*-nth objc-class-name ] map-with ;
2006-02-06 21:51:04 -05:00
: method-arg-type ( method i -- type )
f <void*> 0 <int> over
>r method_getArgumentInfo drop
r> *char* ;
SYMBOL: objc>alien-types
H{
2006-03-10 22:57:57 -05:00
{ "c" "char" }
{ "i" "int" }
{ "s" "short" }
{ "l" "long" }
{ "q" "longlong" }
{ "C" "uchar" }
{ "I" "uint" }
{ "S" "ushort" }
{ "L" "ulong" }
{ "Q" "ulonglong" }
{ "f" "float" }
{ "d" "double" }
{ "B" "bool" }
{ "v" "void" }
{ "*" "char*" }
{ "@" "id" }
{ "#" "id" }
{ ":" "SEL" }
2006-03-09 01:44:17 -05:00
} objc>alien-types set-global
SYMBOL: alien>objc-types
objc>alien-types get hash>alist [ reverse ] map alist>hash
2006-03-15 00:57:02 -05:00
! A hack...
2006-03-10 22:57:57 -05:00
H{
{ "NSPoint" "{_NSPoint=ff}" }
{ "NSRect" "{_NSRect=ffff}" }
{ "NSSize" "{_NSSize=ff}" }
} hash-union alien>objc-types set-global
2006-02-06 21:51:04 -05:00
: objc-struct-type ( i string -- ctype )
2dup CHAR: = -rot index* swap subseq ;
: (parse-objc-type) ( i string -- ctype )
2dup nth >r >r 1+ r> r> {
2006-02-06 22:58:18 -05:00
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
2006-02-06 21:51:04 -05:00
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
{ [ dup CHAR: [ = ] [ 3drop "void*" ] }
2006-03-10 22:57:57 -05:00
{ [ t ] [ 2nip ch>string objc>alien-types get hash ] }
2006-02-06 21:51:04 -05:00
} cond ;
: parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
: method-arg-types ( method -- args )
dup method_getNumberOfArguments
[ method-arg-type parse-objc-type ] map-with ;
: method-return-type ( method -- ctype )
#! Undocumented hack! Apple does not support this feature!
objc-method-types parse-objc-type ;
: objc-method-info ( method -- { return name args } )
[ method-return-type ] keep
[ objc-method-name sel_getName ] keep
method-arg-types 3array ;
2006-03-09 17:43:38 -05:00
: method-list@ ( ptr -- ptr )
"objc-method-list" c-size swap <displaced-alien> ;
2006-01-10 23:56:00 -05:00
: method-list>seq ( method-list -- seq )
2006-03-09 17:43:38 -05:00
dup method-list@ swap objc-method-list-count
[ swap objc-method-nth objc-method-info ] map-with ;
2006-01-10 23:56:00 -05:00
: (objc-methods) ( objc-class iterator -- )
2006-02-06 21:51:04 -05:00
2dup class_nextMethodList
[ method-list>seq % (objc-methods) ] [ 2drop ] if* ;
2006-01-10 23:56:00 -05:00
: objc-methods ( class -- seq )
2006-02-06 21:51:04 -05:00
[ f <void*> (objc-methods) ] { } make ;
2006-03-08 16:06:13 -05:00
: (objc-class) ( string word -- class )
dupd execute
[ ] [ "No such class: " swap append throw ] ?if ; inline
: objc-class ( string -- class )
\ objc_getClass (objc-class) ;
: objc-meta-class ( string -- class )
\ objc_getMetaClass (objc-class) ;
: class-exists? ( string -- class )
objc_getClass >boolean ;
2006-02-06 21:51:04 -05:00
: instance-methods ( classname -- seq )
2006-03-08 16:06:13 -05:00
objc-class objc-methods ;
2006-02-06 21:51:04 -05:00
: class-methods ( classname -- seq )
2006-03-08 16:06:13 -05:00
objc-meta-class objc-methods ;
2006-01-10 23:56:00 -05:00
: <super> ( receiver class -- super )
"objc-super" <c-object>
[ set-objc-super-class ] keep
[ set-objc-super-receiver ] keep ;
: SUPER-> \ SUPER-> on ; inline
: ?super ( obj -- class )
objc-object-isa \ SUPER-> [ f ] change
[ objc-class-super-class ] when ; inline
: selector-quot ( string -- )
[
2006-03-21 00:49:02 -05:00
[ dup ?super <super> ] % <selector> , \ selector ,
] [ ] make ;
: make-objc-invoke
[
>r over length 2 - make-dip % r> call \ alien-invoke ,
2006-01-10 23:56:00 -05:00
] [ ] make ;
: make-objc-send ( returns args selector -- )
selector-quot
[ swap , [ f "objc_msgSendSuper" ] % , ] make-objc-invoke ;
: make-objc-send-stret ( returns args selector -- )
>r swap [ <c-object> dup ] curry 1 make-dip r>
selector-quot append [
"void" ,
[ f "objc_msgSendSuper_stret" ] %
{ "void*" } swap append ,
] make-objc-invoke ;
: make-objc-method ( returns args selector -- )
pick c-struct?
[ make-objc-send-stret ] [ make-objc-send ] if ;
: import-objc-method ( returns types selector -- )
2006-02-06 21:51:04 -05:00
[ make-objc-method "[" ] keep "]" append3 create-in
2006-01-10 23:56:00 -05:00
swap define-compound ;
: import-objc-methods ( seq -- )
[ first3 swap import-objc-method ] each ;
2006-02-06 21:51:04 -05:00
: unless-defined ( class quot -- )
>r class-exists? r> unless ; inline
2006-02-06 21:51:04 -05:00
: define-objc-class-word ( name quot -- )
2006-02-06 21:51:04 -05:00
[
over , , \ unless-defined , dup , \ objc-class ,
] [ ] make >r create-in r> define-compound ;
: import-objc-class ( name quot -- )
#! The quotation is prepended to the class word. It should
#! "regenerate" the class as appropriate (by loading a
#! framework or defining the class in some manner).
2dup unless-defined [
"objc-" pick append in set
dupd define-objc-class-word
dup instance-methods import-objc-methods
class-methods import-objc-methods
2006-02-06 21:51:04 -05:00
] with-scope ;
: root-class ( class -- class )
dup objc-class-super-class [ root-class ] [ ] ?if ;