factor: trim using lists

[factor.git] / basis / cocoa / subclassing / subclassing.factor

diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor
index 08963126702a657407d3a7efe83ee91341bf3bcc..ad735cb98dace4ade593d678de3647febe219a14 100644 (file)
--- a/basis/cocoa/subclassing/subclassing.factor
+++ b/basis/cocoa/subclassing/subclassing.factor
@@ -1,14 +1,14 @@
-! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff.
+! Copyright (C) 2006, 2010 Slava Pestov, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings arrays assocs
-combinators compiler hashtables kernel libc math namespaces
-parser sequences words cocoa.messages cocoa.runtime locals
-compiler.units io.encodings.utf8 continuations make fry ;
+USING: accessors alien alien.parser alien.strings arrays assocs
+cocoa.messages cocoa.runtime combinators compiler.units fry
+io.encodings.utf8 kernel lexer locals.parser locals.types
+make namespaces parser sequences words ;
 IN: cocoa.subclassing
 
 : init-method ( method -- sel imp types )
     first3 swap
-    [ sel_registerName ] [ execute ] [ utf8 string>alien ]
+    [ sel_registerName ] [ execute( -- xt ) ] [ utf8 string>alien ]
     tri* ;
 
 : throw-if-false ( obj what -- )
@@ -27,54 +27,82 @@ IN: cocoa.subclassing
 : add-protocols ( protocols class -- )
     '[ [ _ ] dip objc-protocol add-protocol ] each ;
 
-: (define-objc-class) ( imeth protocols superclass name -- )
+: (define-objc-class) ( methods protocols superclass name -- )
     [ objc-class ] dip 0 objc_allocateClassPair
     [ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
     tri ;
 
+: encode-type ( type -- encoded )
+    dup alien>objc-types get at [ ] [ no-objc-type ] ?if ;
+
 : encode-types ( return types -- encoding )
-    swap prefix [
-        alien>objc-types get at "0" append
-    ] map concat ;
+    swap prefix [ encode-type "0" append ] map concat ;
 
 : prepare-method ( ret types quot -- type imp )
     [ [ encode-types ] 2keep ] dip
-    '[ _ _ "cdecl" _ alien-callback ]
-    (( -- callback )) define-temp ;
+    '[ _ _ cdecl _ alien-callback ]
+    ( -- callback ) define-temp ;
 
 : prepare-methods ( methods -- methods )
     [
         [ first4 prepare-method 3array ] map
-    ] with-compilation-unit ;
+    ] with-nested-compilation-unit ;
 
 :: (redefine-objc-method) ( class method -- )
-    method init-method [| sel imp types |
-        class sel class_getInstanceMethod [
-            imp method_setImplementation drop
-        ] [
-            class sel imp types add-method
-        ] if*
-    ] call ;
-    
-: redefine-objc-methods ( imeth name -- )
+    method init-method :> ( sel imp types )
+
+    class sel class_getInstanceMethod [
+        imp method_setImplementation drop
+    ] [
+        class sel imp types add-method
+    ] if* ;
+
+: redefine-objc-methods ( methods name -- )
     dup class-exists? [
         objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
     ] [ 2drop ] if ;
 
-SYMBOL: +name+
-SYMBOL: +protocols+
-SYMBOL: +superclass+
-
-: define-objc-class ( imeth hash -- )
-    clone [
-        prepare-methods
-        +name+ get "cocoa.classes" create drop
-        +name+ get 2dup redefine-objc-methods swap
-        +protocols+ get +superclass+ get +name+ get
-        '[ _ _ _ _ (define-objc-class) ]
-        import-objc-class
-    ] bind ;
-
-: CLASS:
-    parse-definition unclip
-    >hashtable define-objc-class ; parsing
+:: define-objc-class ( name superclass protocols methods -- )
+    methods prepare-methods :> methods
+    name "cocoa.classes" create-word drop
+    methods name redefine-objc-methods
+    name [ methods protocols superclass name (define-objc-class) ] import-objc-class ;
+
+TUPLE: cocoa-protocol name ;
+C: <cocoa-protocol> cocoa-protocol
+
+SYNTAX: COCOA-PROTOCOL:
+    scan-token <cocoa-protocol> suffix! ;
+
+SYMBOL: ;CLASS>
+
+SYNTAX: <CLASS:
+    scan-token
+    "<" expect
+    scan-token
+    \ ;CLASS> parse-until [ cocoa-protocol? ] partition
+    [ [ name>> ] map ] dip define-objc-class ;
+
+: (parse-selector) ( -- )
+    scan-token {
+        { [ dup "[" = ] [ drop ] }
+        { [ dup ":" tail? ] [ scan-c-type scan-token 3array , (parse-selector) ] }
+        [ f f 3array , "[" expect ]
+    } cond ;
+
+: parse-selector ( -- selector types names )
+    [ (parse-selector) ] { } make
+    flip first3
+    [ concat ]
+    [ sift { id SEL } prepend ]
+    [ sift { "self" "selector" } prepend ] tri* ;
+
+: parse-method-body ( names -- quot )
+    [ [ make-local ] map ] H{ } make
+    (parse-lambda) <lambda> ?rewrite-closures first ;
+
+SYNTAX: METHOD:
+    scan-c-type
+    parse-selector
+    parse-method-body [ swap ] 2dip 4array ";" expect
+    suffix! ;