started work on sdl-ttf binding, some-with? combinator

library/assoc.factor

@@ -39,11 +39,7 @@ USE: kernel
 : assoc* ( key alist -- [[ key value ]] )
     #! Looks up the key in an alist. Push the key/value pair.
     #! Most of the time you want to use assoc not assoc*.
-    dup [
+    [ car = ] some-with?  dup [ car ] when ;
-        2dup car car = [ nip car ] [ cdr assoc* ] ifte
-    ] [
-        2drop f
-    ] ifte ;
 
 : assoc ( key alist -- value )
     #! Looks up the key in an alist.
@@ -70,11 +66,7 @@ USE: kernel
     #! corresponding quotation, the value is popped off the
     #! stack.
     swap [
-        unswons rot assoc* dup [
+        unswons rot assoc* dup [ cdr call ] [ 2drop ] ifte
-            cdr call
-        ] [
-            2drop
-        ] ifte
     ] each-with ;
 
 : 2cons ( car1 car2 cdr1 cdr2 -- cons1 cons2 )

library/bootstrap/boot-stage2.factor

@@ -35,10 +35,6 @@ USE: namespaces
 
 "Cold boot in progress..." print
 
-! vocabularies get [
-!     "generic" off
-! ] bind
-
 [
     "/library/generic/generic.factor"
     "/library/generic/object.factor"
@@ -137,6 +133,7 @@ USE: namespaces
     "/library/sdl/sdl-gfx.factor"
     "/library/sdl/sdl-keysym.factor"
     "/library/sdl/sdl-keyboard.factor"
+    "/library/sdl/sdl-ttf.factor"
     "/library/sdl/sdl-utils.factor"
     "/library/sdl/hsv.factor"
 

library/combinators.factor

@@ -54,7 +54,7 @@ IN: kernel
     #! If the condition is not f, execute the 'true' quotation,
     #! with the condition on the stack. Otherwise, pop the
     #! condition and execute the 'false' quotation.
-    pick [ drop call ] [ nip nip call ] ifte ; inline
+    pick [ drop call ] [ 2nip call ] ifte ; inline
 
 : ?ifte ( default cond true false -- )
     #! If cond is true, drop default and apply true

library/compiler/alien-types.factor

@@ -153,6 +153,15 @@ global [ <namespace> "c-types" set ] bind
     "unbox_alien" "unboxer" set
 ] "void*" define-c-type
 
+! FIXME
+[
+    [ alien-4 ] "getter" set
+    [ set-alien-4 ] "setter" set
+    4 "width" set
+    "box_integer" "boxer" set
+    "unbox_integer" "unboxer" set
+] "long" define-c-type
+
 [
     [ alien-4 ] "getter" set
     [ set-alien-4 ] "setter" set

library/compiler/optimizer.factor

@@ -60,7 +60,7 @@ USE: vectors
 : mentions-literal? ( literal list -- ? )
     #! Does the given list of result objects refer to this
     #! literal?
-    [ dupd value= ] some? nip ;
+    [ value= ] some-with? ;
 
 : consumes-literal? ( literal node -- ? )
     #! Does the dataflow node consume the literal?
@@ -148,9 +148,7 @@ SYMBOL: branch-returns
 ] "calls-label" set-word-property
 
 : calls-label? ( label list -- ? )
-    [
+    [ "calls-label" [ 2drop f ] apply-dataflow ] some-with? ;
-        dupd "calls-label" [ 2drop f ] apply-dataflow
-    ] some? nip ;
 
 #label [
     [ node-param get ] bind calls-label?
@@ -161,7 +159,7 @@ SYMBOL: branch-returns
 ] "calls-label" set-word-property
 
 : branches-call-label? ( label list -- ? )
-    [ dupd calls-label? ] some? nip ;
+    [ calls-label? ] some-with? ;
 
 \ ifte [
     [ node-param get ] bind branches-call-label?

library/cons.factor

@@ -123,4 +123,24 @@ PREDICATE: general-list list ( list -- ? )
     ] ifte ; inline
 
 : subset-with ( obj list quot -- list )
-    swap [ with rot ] subset nip nip ; inline
+    swap [ with rot ] subset 2nip ; inline
+
+: some? ( list pred -- ? )
+    #! Apply predicate with stack effect ( elt -- ? ) to each
+    #! element, return remainder of list from first occurrence
+    #! where it is true, or return f.
+    over [
+        dup >r over >r >r car r> call [
+            r> r> drop
+        ] [
+            r> cdr r> some?
+        ] ifte
+    ] [
+        2drop f
+    ] ifte ; inline
+
+: some-with? ( obj list pred -- ? )
+    #! Apply predicate with stack effect ( obj elt -- ? ) to
+    #! each element, return remainder of list from first
+    #! occurrence where it is true, or return f.
+    swap [ with rot ] some? 2nip ; inline

library/lists.factor

@@ -42,22 +42,9 @@ USE: math
 : append ( [ list1 ] [ list2 ] -- [ list1 list2 ] )
     over [ >r uncons r> append cons ] [ nip ] ifte ;
 
-: some? ( list pred -- ? )
-    #! Apply predicate to each element ,return remainder of list
-    #! from first occurrence where it is true, or return f.
-    over [
-        dup >r over >r >r car r> call [
-            r> r> drop
-        ] [
-            r> cdr r> some?
-        ] ifte
-    ] [
-        2drop f
-    ] ifte ; inline
-
 : contains? ( element list -- ? )
     #! Test if a list contains an element.
-    [ over = ] some? >boolean nip ;
+    [ = ] some-with? >boolean ;
 
 : partition-add ( obj ? ret1 ret2 -- ret1 ret2 )
     rot [ swapd cons ] [ >r cons r> ] ifte ;
@@ -128,7 +115,7 @@ DEFER: tree-contains?
     #! Push each element of a proper list in turn, and collect
     #! return values of applying a quotation with effect
     #! ( obj elt -- obj ) to each element into a new list.
-    swap [ with rot ] map nip nip ; inline
+    swap [ with rot ] map 2nip ; inline
 
 : remove ( obj list -- list )
     #! Remove all occurrences of the object from the list.

library/random.factor

@@ -37,7 +37,7 @@ USE: math
     3dup - + 1 < [
         2drop (random-int) 2dup swap mod (random-int-0)
     ] [
-        nip nip
+        2nip
     ] ifte ;
 
 : random-int-0 ( max -- n )

library/sdl/sdl-ttf.factor

@@ -0,0 +1,100 @@
+! :folding=indent:collapseFolds=1:sidekick.parser=none:
+
+! $Id$
+!
+! Copyright (C) 2005 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: sdl-ttf
+USE: alien
+
+: UNICODE_BOM_NATIVE  HEX: FEFF ;
+: UNICODE_BOM_SWAPPED HEX: FFFE ;
+
+: TTF_ByteSwappedUNICODE ( swapped -- )
+    "void" "sdl-ttf" "TTF_ByteSwappedUNICODE" [ "int" ] alien-invoke ;
+
+: TTF_Init ( swapped -- )
+    "void" "sdl-ttf" "TTF_Init" [ ] alien-invoke ;
+
+: TTF_OpenFont ( file ptsize -- font )
+    "void*" "sdl-ttf" "TTF_OpenFont" [ "char*" "int" ] alien-invoke ;
+
+: TTF_OpenFontIndex ( file ptsize index -- font )
+    "void*" "sdl-ttf" "TTF_OpenFont" [ "char*" "int" "long" ] alien-invoke ;
+
+: TTF_STYLE_NORMAL    HEX: 00 ;
+: TTF_STYLE_BOLD      HEX: 01 ;
+: TTF_STYLE_ITALIC    HEX: 02 ;
+: TTF_STYLE_UNDERLINE HEX: 04 ;
+
+: TTF_GetFontStyle ( font -- style )
+    "int" "sdl-ttf" "TTF_GetFontStyle" [ "void*" ] alien-invoke ;
+
+: TTF_SetFontStyle ( font style -- )
+    "void" "sdl-ttf" "TTF_SetFontStyle" [ "void*" "int" ] alien-invoke ;
+
+: TTF_FontHeight ( font -- n )
+    "int" "sdl-ttf" "TTF_FontHeight" [ "void*" ] alien-invoke ;
+
+: TTF_FontAscent ( font -- n )
+    "int" "sdl-ttf" "TTF_FontAscent" [ "void*" ] alien-invoke ;
+
+: TTF_FontDescent ( font -- n )
+    "int" "sdl-ttf" "TTF_FontDescent" [ "void*" ] alien-invoke ;
+
+: TTF_FontLineSkip ( font -- n )
+    "int" "sdl-ttf" "TTF_FontLineSkip" [ "void*" ] alien-invoke ;
+
+: TTF_FontFaces ( font -- n )
+    "long" "sdl-ttf" "TTF_FontFaces" [ "void*" ] alien-invoke ;
+
+: TTF_FontFaceIsFixedWidth ( font -- ? )
+    "bool" "sdl-ttf" "TTF_FontFaceIsFixedWidth" [ "void*" ] alien-invoke ;
+
+: TTF_FontFaceFamilyName ( font -- n )
+    "char*" "sdl-ttf" "TTF_FontFaceFamilyName" [ "void*" ] alien-invoke ;
+
+: TTF_FontFaceStyleName ( font -- n )
+    "char*" "sdl-ttf" "TTF_FontFaceStyleName" [ "void*" ] alien-invoke ;
+
+: TTF_RenderText_Solid ( font text fg bg -- surface )
+    "surface*" "sdl-ttf" "TTF_RenderText_Solid" [ "void*" "char*" "int" "int" ] alien-invoke ;
+
+: TTF_RenderGlyph_Shaded ( font text fg bg -- surface )
+    "surface*" "sdl-ttf" "TTF_RenderGlyph_Shaded" [ "void*" "ushort" "int" "int" ] alien-invoke ;
+
+: TTF_RenderText_Blended ( font text fg -- surface )
+    "surface*" "sdl-ttf" "TTF_RenderText_Blended" [ "void*" "ushort" "int" "int" ] alien-invoke ;
+
+: TTF_RenderGlyph_Blended ( font text fg -- surface )
+    "surface*" "sdl-ttf" "TTF_RenderGlyph_Blended" [ "void*" "ushort" "int" ] alien-invoke ;
+
+: TTF_CloseFont ( font -- )
+    "void" "sdl-ttf" "TTF_CloseFont" [ "void*" ] alien-invoke ;
+
+: TTF_Quit ( -- )
+    "void" "sdl-ttf" "TTF_CloseFont" [ ] alien-invoke ;
+
+: TTF_WasInit ( -- ? )
+    "bool" "sdl-ttf" "TTF_WasInit" [ ] alien-invoke ;

library/stack.factor

@@ -36,6 +36,7 @@ IN: kernel
 : dupd ( x y -- x x y ) >r dup r> ; inline
 : swapd ( x y z -- y x z ) >r swap r> ; inline
 : nip ( x y -- y ) swap drop ; inline
+: 2nip ( x y z -- z ) >r drop drop r> ; inline
 : tuck ( x y -- y x y ) dup >r swap r> ; inline
 
 : clear ( -- )

library/test/dataflow.factor

@@ -15,19 +15,19 @@ USE: generic
 
 : dataflow-contains-op? ( object list -- ? )
     #! Check if some dataflow node contains a given operation.
-    [ dupd node-op swap hash = ] some? nip ;
+    [ node-op swap hash = ] some-with? ;
 
 : dataflow-contains-param? ( object list -- ? )
     #! Check if some dataflow node contains a given operation.
     [
-        dupd [
+        [
             node-op get #label = [
                 node-param get dataflow-contains-param?
             ] [
                 node-param get =
             ] ifte
         ] bind
-    ] some? nip ;
+    ] some-with? ;
 
 [ t ] [
     \ + [ 2 2 + ] dataflow dataflow-contains-param? >boolean

library/vectors.factor

@@ -126,7 +126,7 @@ BUILTIN: vector 11
     #! first two in a pair.
     over vector-length over vector-length min [
         pick pick >r over >r vector-nth r> r> vector-nth cons
-    ] vector-project nip nip ;
+    ] vector-project 2nip ;
 
 : vector-clone ( vector -- vector )
     #! Shallow copy of a vector.
@@ -172,7 +172,7 @@ M: vector hashcode ( vec -- n )
     #! index upwards.
     2dup vector-length swap - [
         pick + over vector-nth
-    ] project nip nip ;
+    ] project 2nip ;
 
 : vector-tail* ( n vector -- list )
     #! Unlike vector-tail, n is an index from the end of the