"/library/sdl/sdl-gfx.factor"\r
"/library/sdl/sdl-keysym.factor"\r
"/library/sdl/sdl-utils.factor"\r
+ "/library/sdl/hsv.factor"\r
\r
"/library/bootstrap/image.factor"\r
"/library/bootstrap/cross-compiler.factor"\r
"/library/tools/jedit.factor"\r
\r
"/library/cli.factor"\r
- "/library/sdl/hsv.factor"\r
] [\r
dup print\r
run-resource\r
! Some code for interfacing with C structures.
+: BEGIN-ENUM:
+ #! C-style enumerations. Their use is not encouraged unless
+ #! it is for C library interfaces. Used like this:
+ #!
+ #! BEGIN-ENUM 0
+ #! ENUM: x
+ #! ENUM: y
+ #! ENUM: z
+ #! END-ENUM
+ #!
+ #! This is the same as : x 0 ; : y 1 ; : z 2 ;.
+ scan str>number ; parsing
+
+: ENUM:
+ dup CREATE swap unit define-compound succ ; parsing
+
+: END-ENUM
+ drop ; parsing
+
: <c-type> ( -- type )
<namespace> [
[ "No setter" throw ] "setter" set
IN: alien
USE: compiler
USE: errors
+USE: inference
+USE: interpreter
USE: kernel
USE: lists
USE: math
USE: parser
USE: words
-: BEGIN-ENUM:
- #! C-style enumerations. Their use is not encouraged unless
- #! it is for C library interfaces. Used like this:
- #!
- #! BEGIN-ENUM 0
- #! ENUM: x
- #! ENUM: y
- #! ENUM: z
- #! END-ENUM
- #!
- #! This is the same as : x 0 ; : y 1 ; : z 2 ;.
- scan str>number ; parsing
-
-: ENUM:
- dup CREATE swap unit define-compound succ ; parsing
-
-: END-ENUM
- drop ; parsing
-
-: alien-call ( ... returns library function parameters -- ... )
- #! Call a C library function.
- #! 'returns' is a type spec, and 'parameters' is a list of
- #! type specs. 'library' is an entry in the "libraries"
- #! namespace.
- "alien-call cannot be interpreted." throw ;
-
: library ( name -- handle )
"libraries" get [
dup get dup dll? [
: alien-function ( function library -- )
[ library dlsym ] [ dlsym-self ] ifte* ;
-! : compile-alien-call
-! pop-literal reverse PARAMETERS >r
-! pop-literal pop-literal alien-function CALL JUMP-FIXUP
-! r> CLEANUP
-! pop-literal RETURNS ;
-!
-! global [ <namespace> "libraries" set ] bind
-!
-! \ alien-call [ compile-alien-call ] "compiling" set-word-property
+SYMBOL: #c-invoke ( C ABI -- Unix and most Windows libs )
+SYMBOL: #cleanup ( unwind stack by parameter )
+
+SYMBOL: #c-call ( jump to raw address )
+
+SYMBOL: #unbox ( move top of datastack to C stack )
+SYMBOL: #box ( move EAX to datastack )
+
+SYMBOL: #std-invoke ( stdcall ABI -- Win32 )
+
+! These are set in the #c-invoke and #std-invoke dataflow IR
+! nodes.
+SYMBOL: alien-returns
+SYMBOL: alien-parameters
+
+: infer-alien ( op -- )
+ >r 4 ensure-d
+ dataflow-drop, pop-d car
+ dataflow-drop, pop-d car
+ dataflow-drop, pop-d car alien-function
+ dataflow-drop, pop-d car swap
+ r> dataflow, [
+ alien-returns set
+ alien-parameters set
+ ] bind ;
+
+: unbox-parameter ( function -- )
+ dlsym-self #unbox swons , ;
+
+: linearize-parameters ( params -- count )
+ #! Generate code for boxing a list of C types.
+ #! Return amount stack must be unwound by.
+ [ alien-parameters get ] bind 0 swap [
+ c-type [
+ "width" get cell align +
+ "unboxer" get
+ ] bind unbox-parameter
+ ] each ;
+
+: box-parameter ( function -- )
+ dlsym-self #box swons , ;
+
+: linearize-returns ( returns -- )
+ [ alien-returns get ] bind dup "void" = [
+ drop
+ ] [
+ c-type [ "boxer" get ] bind box-parameter
+ ] ifte ;
+
+: linearize-alien ( node -- )
+ dup linearize-parameters >r
+ dup [ node-param get ] bind #c-call swons ,
+ dup [ node-op get #c-invoke = ] bind
+ r> swap [ #cleanup swons , ] [ drop ] ifte
+ linearize-returns ;
+
+: c-invoke ( ... returns library function parameters -- ... )
+ #! Call a C library function.
+ #! 'returns' is a type spec, and 'parameters' is a list of
+ #! type specs. 'library' is an entry in the "libraries"
+ #! namespace.
+ "c-invoke cannot be interpreted." throw ;
+
+\ c-invoke [ 4 | 0 ] "infer-effect" set-word-property
+
+\ c-invoke [ #c-invoke infer-alien ] "infer" set-word-property
+
+#c-invoke [ linearize-alien ] "linearizer" set-word-property
+
+: std-invoke ( ... returns library function parameters -- ... )
+ #! Call a C library function with the stdcall ABI (Win32).
+ #! 'returns' is a type spec, and 'parameters' is a list of
+ #! type specs. 'library' is an entry in the "libraries"
+ #! namespace.
+ "std-invoke cannot be interpreted." throw ;
+
+\ std-invoke [ 4 | 0 ] "infer-effect" set-word-property
+
+\ std-invoke [ #std-invoke infer-alien ] "infer" set-word-property
+
+#std-invoke [ linearize-alien ] "linearizer" set-word-property
+
+global [
+ "libraries" get [ <namespace> "libraries" set ] unless
+] bind
END-UNION
: SDL_WaitEvent ( event -- )
- "int" "sdl" "SDL_WaitEvent" [ "event*" ] alien-call ;
+ "int" "sdl" "SDL_WaitEvent" [ "event*" ] c-invoke ;
: SDL_PollEvent ( event -- ? )
- "bool" "sdl" "SDL_PollEvent" [ "event*" ] alien-call ;
+ "bool" "sdl" "SDL_PollEvent" [ "event*" ] c-invoke ;
: pixelColor ( surface x y color -- )
"void" "sdl-gfx" "pixelColor"
[ "surface*" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: hlineColor ( surface x1 x2 y color -- )
"void" "sdl-gfx" "hlineColor"
[ "surface*" "short" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: vlineColor ( surface x y1 y2 color -- )
"void" "sdl-gfx" "vlineColor"
[ "surface*" "short" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: rectangleColor ( surface x1 y1 x2 y2 color -- )
"void" "sdl-gfx" "rectangleColor"
[ "surface*" "short" "short" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: boxColor ( surface x1 y1 x2 y2 color -- )
"void" "sdl-gfx" "boxColor"
[ "surface*" "short" "short" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: lineColor ( surface x1 y1 x2 y2 color -- )
"void" "sdl-gfx" "lineColor"
[ "surface*" "short" "short" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: aalineColor ( surface x1 y1 x2 y2 color -- )
"void" "sdl-gfx" "aalineColor"
[ "surface*" "short" "short" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: circleColor ( surface x y r color -- )
"void" "sdl-gfx" "circleColor"
[ "surface*" "short" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: aacircleColor ( surface x y r color -- )
"void" "sdl-gfx" "aacircleColor"
[ "surface*" "short" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: filledCircleColor ( surface x y r color -- )
"void" "sdl-gfx" "filledCircleColor"
[ "surface*" "short" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: ellipseColor ( surface x y rx ry color -- )
"void" "sdl-gfx" "ellipseColor"
[ "surface*" "short" "short" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: aaellipseColor ( surface x y rx ry color -- )
"void" "sdl-gfx" "aaellipseColor"
[ "surface*" "short" "short" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: filledEllipseColor ( surface x y rx ry color -- )
"void" "sdl-gfx" "filledEllipseColor"
[ "surface*" "short" "short" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: pieColor ( surface x y rad start end color -- )
"void" "sdl-gfx" "pieColor"
[ "surface*" "short" "short" "short" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: filledPieColor ( surface x y rad start end color -- )
"void" "sdl-gfx" "filledPieColor"
[ "surface*" "short" "short" "short" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: trigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
"void" "sdl-gfx" "trigonColor"
[ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: aatrigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
"void" "sdl-gfx" "aatrigonColor"
[ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: filledTrigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
"void" "sdl-gfx" "filledTrigonColor"
[ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
- alien-call ;
+ c-invoke ;
: characterColor ( surface x y c color -- )
"void" "sdl-gfx" "characterColor"
[ "surface*" "short" "short" "char" "uint" ]
- alien-call ;
+ c-invoke ;
: stringColor ( surface x y str color -- )
"void" "sdl-gfx" "stringColor"
[ "surface*" "short" "short" "char*" "uint" ]
- alien-call ;
+ c-invoke ;
: SDL_VideoInit ( driver-name flags -- )
"int" "sdl" "SDL_VideoInit"
- [ "char*" "int" ] alien-call ;
+ [ "char*" "int" ] c-invoke ;
: SDL_VideoQuit ( -- )
- "void" "sdl" "SDL_VideoQuit" [ ] alien-call ;
+ "void" "sdl" "SDL_VideoQuit" [ ] c-invoke ;
! SDL_VideoDriverName -- needs strings as out params.
: SDL_GetVideoSurface ( -- surface )
- "surface*" "sdl" "SDL_GetVideoSurface" [ ] alien-call ;
+ "surface*" "sdl" "SDL_GetVideoSurface" [ ] c-invoke ;
! SDL_GetVideoInfo needs C struct bitfield support
: SDL_VideoModeOK ( width height bpp flags -- )
"int" "sdl" "SDL_VideoModeOK"
- [ "int" "int" "int" "int" ] alien-call ;
+ [ "int" "int" "int" "int" ] c-invoke ;
! SDL_ListModes needs array of structs support
: SDL_SetVideoMode ( width height bpp flags -- )
"surface*" "sdl" "SDL_SetVideoMode"
- [ "int" "int" "int" "int" ] alien-call ;
+ [ "int" "int" "int" "int" ] c-invoke ;
! UpdateRects, UpdateRect
: SDL_Flip ( surface -- )
- "bool" "sdl" "SDL_Flip" [ "surface*" ] alien-call ;
+ "bool" "sdl" "SDL_Flip" [ "surface*" ] c-invoke ;
! SDL_SetGamma: float types
: SDL_FillRect ( surface rect color -- n )
#! If rect is null, fills entire surface.
"bool" "sdl" "SDL_FillRect"
- [ "surface*" "rect*" "uint" ] alien-call ;
+ [ "surface*" "rect*" "uint" ] c-invoke ;
: SDL_LockSurface ( surface -- )
- "bool" "sdl" "SDL_LockSurface" [ "surface*" ] alien-call ;
+ "bool" "sdl" "SDL_LockSurface" [ "surface*" ] c-invoke ;
: SDL_UnlockSurface ( surface -- )
- "void" "sdl" "SDL_UnlockSurface" [ "surface*" ] alien-call ;
+ "void" "sdl" "SDL_UnlockSurface" [ "surface*" ] c-invoke ;
: SDL_MapRGB ( surface r g b -- )
"uint" "sdl" "SDL_MapRGB"
- [ "surface*" "uchar" "uchar" "uchar" ] alien-call ;
+ [ "surface*" "uchar" "uchar" "uchar" ] c-invoke ;
: SDL_WM_SetCaption ( title icon -- )
"void" "sdl" "SDL_WM_SetCaption"
- [ "char*" "char*" ] alien-call ;
+ [ "char*" "char*" ] c-invoke ;
: SDL_INIT_EVERYTHING HEX: 0000FFFF ;
: SDL_Init ( mode -- )
- "int" "sdl" "SDL_Init" [ "int" ] alien-call ;
+ "int" "sdl" "SDL_Init" [ "int" ] c-invoke ;
: SDL_GetError ( -- error )
- "char*" "sdl" "SDL_GetError" [ ] alien-call ;
+ "char*" "sdl" "SDL_GetError" [ ] c-invoke ;
: SDL_Quit ( -- )
- "void" "sdl" "SDL_Quit" [ ] alien-call ;
+ "void" "sdl" "SDL_Quit" [ ] c-invoke ;
projects / factor.git / commitdiff