working on sdl binding, remove some combinators
Slava Pestov
parent
0f15cc3fdf
commit
42e15aaede
|
|
@ -1,5 +1,10 @@
|
|||
FFI:
|
||||
- is signed -vs- unsigned pointers an issue?
|
||||
- bitfields in C structs
|
||||
- unsigned types
|
||||
- SDL_Rect** type
|
||||
- struct membres that are not *
|
||||
- float types
|
||||
|
||||
- command line parsing cleanup
|
||||
- > 1 ( ) inside word def
|
||||
|
|
|
|||
|
|
@ -123,56 +123,3 @@ USE: stack
|
|||
#!
|
||||
#! This combinator will not compile.
|
||||
dup slip forever ; interpret-only
|
||||
|
||||
! DEPRECATED
|
||||
|
||||
: 2apply ( x y quot -- )
|
||||
#! First applies the code to x, then to y.
|
||||
#!
|
||||
#! If the quotation compiles, this combinator compiles.
|
||||
2dup >r >r nip call r> r> call ; inline interpret-only
|
||||
|
||||
: cleave ( x quot quot -- )
|
||||
#! Executes each quotation, with x on top of the stack.
|
||||
#!
|
||||
#! If the quotation compiles, this combinator compiles.
|
||||
>r over >r call r> r> call ; inline interpret-only
|
||||
|
||||
: dip ( a [ b ] -- b a )
|
||||
#! Call b as if b was not present on the stack.
|
||||
#!
|
||||
#! If the quotation compiles, this combinator compiles.
|
||||
swap >r call r> ; inline interpret-only
|
||||
|
||||
: 2dip ( a b [ c ] -- c a b )
|
||||
#! Call c as if a and b were not present on the stack.
|
||||
#!
|
||||
#! If the quotation compiles, this combinator compiles.
|
||||
-rot >r >r call r> r> ; inline interpret-only
|
||||
|
||||
: interleave ( X quot -- )
|
||||
#! Evaluate each element of the list with X on top of the
|
||||
#! stack. When done, X is popped off the stack.
|
||||
#!
|
||||
#! To avoid unexpected results, each element of the list
|
||||
#! must have stack effect ( X -- ).
|
||||
#!
|
||||
#! This combinator will not compile.
|
||||
dup [
|
||||
over [ unswons dip ] dip swap interleave
|
||||
] [
|
||||
2drop
|
||||
] ifte ; interpret-only
|
||||
|
||||
: while ( cond body -- )
|
||||
#! Evaluate cond. If it leaves t on the stack, evaluate
|
||||
#! body, and recurse.
|
||||
#!
|
||||
#! In order to compile, the stack effect of
|
||||
#! cond * ( X -- ) * body must consume as many values as
|
||||
#! it produces.
|
||||
2dup >r >r >r call [
|
||||
r> call r> r> while
|
||||
] [
|
||||
r> drop r> drop r> drop
|
||||
] ifte ; inline interpret-only
|
||||
|
|
|
|||
|
|
@ -133,6 +133,14 @@ global [ <namespace> "c-types" set ] bind
|
|||
"unbox_integer" "unboxer" set
|
||||
] "int" define-c-type
|
||||
|
||||
[
|
||||
[ alien-4 ] "getter" set
|
||||
[ set-alien-4 ] "setter" set
|
||||
4 "width" set
|
||||
"box_integer" "boxer" set
|
||||
"unbox_integer" "unboxer" set
|
||||
] "uint" define-c-type
|
||||
|
||||
[
|
||||
[ alien-2 ] "getter" set
|
||||
[ set-alien-2 ] "setter" set
|
||||
|
|
@ -141,6 +149,14 @@ global [ <namespace> "c-types" set ] bind
|
|||
"unbox_integer" "unboxer" set
|
||||
] "short" define-c-type
|
||||
|
||||
[
|
||||
[ alien-2 ] "getter" set
|
||||
[ set-alien-2 ] "setter" set
|
||||
2 "width" set
|
||||
"box_integer" "boxer" set
|
||||
"unbox_integer" "unboxer" set
|
||||
] "ushort" define-c-type
|
||||
|
||||
[
|
||||
[ alien-1 ] "getter" set
|
||||
[ set-alien-1 ] "setter" set
|
||||
|
|
@ -149,6 +165,14 @@ global [ <namespace> "c-types" set ] bind
|
|||
"unbox_integer" "unboxer" set
|
||||
] "char" define-c-type
|
||||
|
||||
[
|
||||
[ alien-1 ] "getter" set
|
||||
[ set-alien-1 ] "setter" set
|
||||
1 "width" set
|
||||
"box_integer" "boxer" set
|
||||
"unbox_integer" "unboxer" set
|
||||
] "uchar" define-c-type
|
||||
|
||||
[
|
||||
[ alien-4 ] "getter" set
|
||||
[ set-alien-4 ] "setter" set
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ USE: words
|
|||
tab-size - ;
|
||||
|
||||
: prettyprint-~<<>>~ ( indent word list -- indent )
|
||||
[ [ prettyprint-~<< ] dip prettyprint-word " " write ] dip
|
||||
>r >r prettyprint-~<< r> prettyprint-word " " write r>
|
||||
[ write " " write ] each
|
||||
prettyprint->>~ ;
|
||||
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ USE: stack
|
|||
#! evaluate the code with the matcher at the top of the
|
||||
#! stack. Otherwise, pop the matcher off the stack and
|
||||
#! push f.
|
||||
[ dup re-matches* ] dip [ drop f ] ifte ;
|
||||
>r dup re-matches* r> [ drop f ] ifte ;
|
||||
|
||||
: re-replace* ( replace matcher -- string )
|
||||
[ "java.lang.String" ] "java.util.regex.Matcher"
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ USE: strings
|
|||
: fcopy ( from to -- )
|
||||
#! Copy the contents of the byte-stream 'from' to the
|
||||
#! byte-stream 'to'.
|
||||
[ [ "in" get ] bind ] dip
|
||||
>r [ "in" get ] bind r>
|
||||
[ "out" get ] bind
|
||||
[ "java.io.InputStream" "java.io.OutputStream" ]
|
||||
"factor.FactorLib" "copy" jinvoke-static ;
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ USE: stack
|
|||
[ ] "factor.FactorInterpreter" jnew ;
|
||||
|
||||
: fork* ( current new -- thread )
|
||||
dup <thread> [ clone-interpreter ] dip ; interpret-only
|
||||
dup <thread> >r clone-interpreter r> ; interpret-only
|
||||
|
||||
: fork ( -- ? )
|
||||
#! Spawn a new thread. In the original thread, push f.
|
||||
|
|
|
|||
|
|
@ -81,7 +81,7 @@ USE: stack
|
|||
: no-name ( list -- word )
|
||||
! Generates an uninternalized word and gives it a compound
|
||||
! definition created from the given list.
|
||||
[ gensym dup dup ] dip <compound> redefine ;
|
||||
>r gensym dup dup r> <compound> redefine ;
|
||||
|
||||
: primitive? ( worddef -- boolean )
|
||||
"factor.FactorPrimitiveDefinition" is ;
|
||||
|
|
|
|||
|
|
@ -56,32 +56,39 @@ USE: stack
|
|||
: SDL_SRCALPHA HEX: 00010000 ; ! Blit uses source alpha blending
|
||||
: SDL_PREALLOC HEX: 01000000 ; ! Surface uses preallocated memory
|
||||
|
||||
BEGIN-STRUCT: rect
|
||||
FIELD: short x
|
||||
FIELD: short y
|
||||
FIELD: ushort w
|
||||
FIELD: ushort h
|
||||
END-STRUCT
|
||||
|
||||
BEGIN-STRUCT: format
|
||||
FIELD: void* palette
|
||||
FIELD: char BitsPerPixel
|
||||
FIELD: char BytesPerPixel
|
||||
FIELD: char Rloss
|
||||
FIELD: char Gloss
|
||||
FIELD: char Bloss
|
||||
FIELD: char Aloss
|
||||
FIELD: char Rshift
|
||||
FIELD: char Gshift
|
||||
FIELD: char Bshift
|
||||
FIELD: char Ashift
|
||||
FIELD: int Rmask
|
||||
FIELD: int Gmask
|
||||
FIELD: int Bmask
|
||||
FIELD: int Amask
|
||||
FIELD: int colorkey
|
||||
FIELD: char alpha
|
||||
FIELD: uchar BitsPerPixel
|
||||
FIELD: uchar BytesPerPixel
|
||||
FIELD: uchar Rloss
|
||||
FIELD: uchar Gloss
|
||||
FIELD: uchar Bloss
|
||||
FIELD: uchar Aloss
|
||||
FIELD: uchar Rshift
|
||||
FIELD: uchar Gshift
|
||||
FIELD: uchar Bshift
|
||||
FIELD: uchar Ashift
|
||||
FIELD: uint Rmask
|
||||
FIELD: uint Gmask
|
||||
FIELD: uint Bmask
|
||||
FIELD: uint Amask
|
||||
FIELD: uint colorkey
|
||||
FIELD: uchar alpha
|
||||
END-STRUCT
|
||||
|
||||
BEGIN-STRUCT: surface
|
||||
FIELD: int flags
|
||||
FIELD: uint flags
|
||||
FIELD: format* format
|
||||
FIELD: int w
|
||||
FIELD: int h
|
||||
FIELD: short pitch
|
||||
FIELD: ushort pitch
|
||||
FIELD: void* pixels
|
||||
FIELD: int offset
|
||||
FIELD: void* hwdata
|
||||
|
|
@ -89,10 +96,10 @@ BEGIN-STRUCT: surface
|
|||
FIELD: short clip-y
|
||||
FIELD: short clip-w
|
||||
FIELD: short clip-h
|
||||
FIELD: int unused1
|
||||
FIELD: int locked
|
||||
FIELD: uint unused1
|
||||
FIELD: uint locked
|
||||
FIELD: int map
|
||||
FIELD: int format_version
|
||||
FIELD: uint format_version
|
||||
FIELD: int refcount
|
||||
END-STRUCT
|
||||
|
||||
|
|
@ -106,19 +113,43 @@ END-STRUCT
|
|||
drop t
|
||||
] ifte ;
|
||||
|
||||
: SDL_VideoInit ( driver-name flags -- )
|
||||
"int" "sdl" "SDL_SetVideoMode"
|
||||
[ "char*" "int" ] alien-call ;
|
||||
|
||||
: SDL_VideoQuit ( -- )
|
||||
"void" "sdl" "SDL_VideoQuit" [ ] alien-call ;
|
||||
|
||||
! SDL_VideoDriverName -- needs strings as out params.
|
||||
|
||||
: SDL_GetVideoSurface ( -- surface )
|
||||
"surface*" "sdl" "SDL_GetVideoSurface" [ ] alien-call ;
|
||||
|
||||
! SDL_GetVideoInfo needs C struct bitfield support
|
||||
|
||||
: SDL_VideoModeOK ( width height bpp flags -- )
|
||||
"int" "sdl" "SDL_VideoModeOK"
|
||||
[ "int" "int" "int" "int" ] alien-call ;
|
||||
|
||||
! SDL_ListModes needs array of structs support
|
||||
|
||||
: SDL_SetVideoMode ( width height bpp flags -- )
|
||||
"int" "sdl" "SDL_SetVideoMode"
|
||||
[ "int" "int" "int" "int" ] alien-call ;
|
||||
|
||||
! UpdateRects, UpdateRect
|
||||
|
||||
: SDL_Flip ( surface -- )
|
||||
"void" "sdl" "SDL_Flip" [ "surface*" ] alien-call ;
|
||||
|
||||
! SDL_SetGamma: float types
|
||||
|
||||
: SDL_LockSurface ( surface -- )
|
||||
"int" "sdl" "SDL_LockSurface" [ "surface*" ] alien-call ;
|
||||
|
||||
: SDL_UnlockSurface ( surface -- )
|
||||
"void" "sdl" "SDL_UnlockSurface" [ "surface*" ] alien-call ;
|
||||
|
||||
: SDL_Flip ( surface -- )
|
||||
"void" "sdl" "SDL_Flip" [ "surface*" ] alien-call ;
|
||||
|
||||
: SDL_MapRGB ( surface r g b -- )
|
||||
"int" "sdl" "SDL_MapRGB"
|
||||
[ "surface*" "char" "char" "char" ] alien-call ;
|
||||
|
|
|
|||
|
|
@ -37,13 +37,6 @@ USE: words
|
|||
|
||||
[ ] [ ] [ while-test ] test-word
|
||||
|
||||
: [while]
|
||||
[ over call ] [ dup 2dip ] while 2drop ; inline
|
||||
|
||||
: [while-test] [ f ] [ ] [while] ; word must-compile
|
||||
|
||||
[ ] [ ] [ [while-test] ] test-word
|
||||
|
||||
: times-test-1 [ nop ] times ; word must-compile
|
||||
: times-test-2 [ succ ] times ; word must-compile
|
||||
: times-test-3 0 10 [ succ ] times ; word must-compile
|
||||
|
|
@ -59,7 +52,7 @@ USE: words
|
|||
[ 3 ] [ t f ] [ nested-ifte ] test-word
|
||||
[ 4 ] [ f f ] [ nested-ifte ] test-word
|
||||
|
||||
: flow-erasure [ 2 2 + ] [ ] dip call ; inline word must-compile
|
||||
: flow-erasure [ 2 2 + ] [ ] swap >r call r> call ; inline word must-compile
|
||||
|
||||
[ 4 ] [ ] [ flow-erasure ] test-word
|
||||
|
||||
|
|
|
|||
|
|
@ -53,7 +53,7 @@ USE: words
|
|||
!: null-rec ( -- )
|
||||
! t [ t null-rec ] unless* drop ; word must-compile test-null-rec
|
||||
|
||||
[ f 1 2 3 ] [ [ [ 2 | 1 ] ] 3 ] [ [ unswons unswons ] dip ] test-word
|
||||
[ f 1 2 3 ] [ [ [ 2 | 1 ] ] 3 ] [ >r unswons unswons r> ] test-word
|
||||
|
||||
[ [ 2 1 0 0 ] ] [ [ >r [ ] [ ] ifte r> ] ] [ balance>list ] test-word
|
||||
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ USE: words
|
|||
[ f ] [ [ 1 2 3 ] ] [ tail-call-2 ] test-word
|
||||
|
||||
: tail-call-3 ( x y -- z )
|
||||
[ dup succ ] dip swap 6 = [
|
||||
>r dup succ r> swap 6 = [
|
||||
+
|
||||
] [
|
||||
swap tail-call-3
|
||||
|
|
|
|||
|
|
@ -0,0 +1,18 @@
|
|||
IN: scratchpad
|
||||
USE: lists
|
||||
USE: kernel
|
||||
USE: styles
|
||||
USE: test
|
||||
|
||||
[ t ] [ default-style assoc? ] unit-test
|
||||
[ t ] [
|
||||
f "fooquux" set-style "fooquux" get-style default-style =
|
||||
] unit-test
|
||||
[ "Sans-Serif" ] [
|
||||
[
|
||||
[ "font" | "Sans-Serif" ]
|
||||
] "fooquux" set-style
|
||||
"font" "fooquux" get-style assoc
|
||||
] unit-test
|
||||
|
||||
f "fooquux" set-style
|
||||
|
|
@ -93,6 +93,7 @@ USE: unparser
|
|||
"unparser"
|
||||
"random"
|
||||
"stream"
|
||||
"styles"
|
||||
"math/bignum"
|
||||
"math/bitops"
|
||||
"math/gcd"
|
||||
|
|
|
|||
Loading…
Reference in New Issue