\r
+ ffi:\r
\r
+- figure out how to load an image referring to missing libraries\r
- is signed -vs- unsigned pointers an issue?\r
- bitfields in C structs\r
- SDL_Rect** type\r
\r
+ kernel:\r
\r
+- do partial objects cause problems?\r
- profiler is inaccurate: wrong word on cs\r
- better i/o scheduler\r
- remove sbufs\r
! DeJong attractor renderer.
-! To run this code, start your interpreter like so:
!
-! ./f -libraries:sdl:name=libSDL.so -libraries:sdl-gfx:name=libSDL_gfx.so
+! To run this code, bootstrap Factor like so:
!
-! Then, enter this at the interpreter prompt:
+! ./f boot.image.le32
+! -libraries:sdl:name=libSDL.so
+! -libraries:sdl-gfx:name=libSDL_gfx.
+!
+! (But all on one line)
+!
+! Then, start Factor as usual (./f factor.image) and enter this
+! at the listener:
!
! "examples/dejong.factor" run-file
USE: namespaces
USE: math
USE: kernel
+USE: test
+USE: compiler
SYMBOL: a
SYMBOL: b
<event> event-loop
SDL_Quit
- ] with-screen ;
+ ] with-screen ; compiled
-dejong
+[ dejong ] time
! A simple space shooter.
!
-! To play the game:
+! To run this code, bootstrap Factor like so:
!
-! ./f -libraries:sdl:name=libSDL.so -libraries:sdl-gfx:name=libSDL_gfx.so
+! ./f boot.image.le32
+! -libraries:sdl:name=libSDL.so
+! -libraries:sdl-gfx:name=libSDL_gfx.
+!
+! (But all on one line)
+!
+! Then, start Factor as usual (./f factor.image) and enter this
+! at the listener:
!
! "examples/factoroids.factor" run-file
! Graphical mandelbrot fractal renderer.
-! To run this code, start your interpreter like so:
!
-! ./f -libraries:sdl:name=libSDL.so -libraries:sdl-gfx:name=libSDL_gfx.so
+! To run this code, bootstrap Factor like so:
!
-! Then, enter this at the interpreter prompt:
+! ./f boot.image.le32
+! -libraries:sdl:name=libSDL.so
+! -libraries:sdl-gfx:name=libSDL_gfx.
+!
+! (But all on one line)
+!
+! Then, start Factor as usual (./f factor.image) and enter this
+! at the listener:
!
! "examples/mandel.factor" run-file
nip nip
] [
pred >r sq dupd + r> iter
- ] ifte ; compiled
+ ] ifte ;
: max-color 360 ;
x-inc get * center get real x-inc get width get 2 / * - + >float
r>
y-inc get * center get imaginary y-inc get height get 2 / * - + >float
- rect> ; compiled
+ rect> ;
: render ( -- )
- init-mandel
width get height get [
c 0 nb-iter get iter dup 0 = [
drop 0
] [
cols get [ vector-length mod ] keep vector-nth
] ifte
- ] with-pixels ;
+ ] with-pixels ; compiled
: mandel ( -- )
640 480 32 SDL_HWSURFACE [
0.8 zoom-fact set
-0.65 center set
100 nb-iter set
+ init-mandel
[ render ] time
"Done." print flush
] with-surface
init-random
default-cli-args
parse-command-line
-
- os "win32" = "compile" get and [
- "kernel32" "kernel32.dll" "stdcall" add-library
- "user32" "user32.dll" "stdcall" add-library
- "gdi32" "gdi32.dll" "stdcall" add-library
- "libc" "msvcrt.dll" "cdecl" add-library
- ] when
-
init-smart-terminal
run-user-init ;
default-cli-args
parse-command-line
+os "win32" = "compile" get and [
+ "kernel32" "kernel32.dll" "stdcall" add-library
+ "user32" "user32.dll" "stdcall" add-library
+ "gdi32" "gdi32.dll" "stdcall" add-library
+ "libc" "msvcrt.dll" "cdecl" add-library
+] when
+
"Compiling system..." print
"compile" get [ compile-all ] when
[ "kernel" | "address" ]
[ "alien" | "dlopen" ]
[ "alien" | "dlsym" ]
- [ "alien" | "dlsym-self" ]
[ "alien" | "dlclose" ]
[ "alien" | "<alien>" ]
[ "alien" | "<local-alien>" ]
: library ( name -- object )
dup [ "libraries" get hash ] when ;
-: load-dll ( library -- dll )
- "dll" get dup [
- drop "name" get dlopen dup "dll" set
- ] unless ;
-
+: load-dll ( name -- dll )
+ #! Higher level wrapper around dlopen primitive.
+ library dup [
+ [
+ "dll" get dup [
+ drop "name" get dlopen dup "dll" set
+ ] unless
+ ] bind
+ ] when ;
+
: add-library ( library name abi -- )
"libraries" get [
<namespace> [
: library-abi ( library -- abi )
library [ [ "abi" get ] bind ] [ "cdecl" ] ifte* ;
-: alien-symbol ( function library -- address )
- library [ [ load-dll ] bind dlsym ] [ dlsym-self ] ifte* ;
-
SYMBOL: #alien-invoke
! These are set in the #alien-invoke dataflow IR node.
: linearize-alien ( node -- )
dup linearize-parameters >r
dup [ node-param get ] bind #c-call swons ,
- dup [ node-param get car "stdcall" = ] bind
+ dup [ node-param get car library-abi "stdcall" = ] bind
r> swap [ drop ] [ #cleanup swons , ] ifte
linearize-returns ;
USE: lists
USE: math
-: DS ( -- address ) "ds" dlsym-self ;
+: DS ( -- address ) "ds" f dlsym ;
: absolute-ds ( -- )
#! Add an entry to the relocation table for the 32-bit
#! immediate just compiled.
- "ds" f rel-dlsym-self ;
+ "ds" f f rel-dlsym ;
: POP-DS ( -- )
#! Pop datastack to EAX.
] "generator" set-word-property
#c-call [
- uncons alien-symbol CALL JUMP-FIXUP
+ uncons load-dll 2dup dlsym CALL JUMP-FIXUP t rel-dlsym
] "generator" set-word-property
#unbox [
- dlsym-self CALL JUMP-FIXUP
+ dup f dlsym CALL JUMP-FIXUP f t rel-dlsym
EAX PUSH-R
] "generator" set-word-property
#box [
EAX PUSH-R
- dlsym-self CALL JUMP-FIXUP
+ dup f dlsym CALL JUMP-FIXUP f t rel-dlsym
4 ESP R+I
] "generator" set-word-property
#! If flag is true; relative.
over primitive? [ rel-primitive ] [ 2drop ] ifte ;
-: rel-dlsym-self ( name rel/abs -- )
+: rel-dlsym ( name dll rel/abs -- )
#! If flag is true; relative.
- 2 3 ? rel, relocating intern-literal rel, ;
+ 2 3 ? rel, relocating cons intern-literal rel, ;
: rel-address ( -- )
#! Relocate address just compiled.
nip real succ
] [
nip >rect succ rect>
- ] ifte ;
+ ] ifte ; inline
: 2times<= ( #{ a b } #{ c d } -- ? )
- swap real swap real <= ;
+ swap real swap real <= ; inline
: (2times) ( limit n quot -- )
pick pick 2times<= [
3drop
] [
rot pick dupd 2times-succ pick 3slip (2times)
- ] ifte ;
+ ] ifte ; inline
: 2times* ( #{ w h } quot -- )
#! Apply a quotation to each pair of complex numbers
#! #{ a b } such that a < w, b < h.
- 0 swap (2times) ;
+ 0 swap (2times) ; inline
[ set-literal-top " ptr -- " [ [ integer ] [ ] ] ]
[ address " obj -- ptr " [ [ object ] [ integer ] ] ]
[ dlopen " path -- dll " [ [ string ] [ dll ] ] ]
- [ dlsym " name dll -- ptr " [ [ string dll ] [ integer ] ] ]
- [ dlsym-self " name -- ptr " [ [ string ] [ integer ] ] ]
+ [ dlsym " name dll -- ptr " [ [ string object ] [ integer ] ] ]
[ dlclose " dll -- " [ [ dll ] [ ] ] ]
[ <alien> " ptr -- alien " [ [ integer ] [ alien ] ] ]
[ <local-alien> " len -- alien " [ [ integer ] [ alien ] ] ]
>r 3dup bpp set height set width set r>
SDL_SetVideoMode surface set
r> call SDL_Quit
- ] with-scope ;
+ ] with-scope ; inline
: rgba ( r g b a -- n )
swap 8 shift bitor
: pixel-step ( quot #{ x y } -- )
tuck >r call >r surface get r> r> >rect rot pixelColor ;
+ inline
: with-pixels ( w h quot -- )
- -rot rect> [ over >r pixel-step r> ] 2times* drop ;
+ -rot rect> [ over >r pixel-step r> ] 2times* drop ; inline
: with-surface ( quot -- )
#! Execute a quotation, locking the current surface if it
#! is required (eg, hardware surface).
[
surface get dup must-lock-surface? [
- dup SDL_LockSurface slip dup SDL_UnlockSurface
+ dup SDL_LockSurface drop slip dup SDL_UnlockSurface
] [
slip
] ifte SDL_Flip drop
- ] with-scope ;
+ ] with-scope ; inline
: event-loop ( event -- )
dup SDL_WaitEvent 1 = [
"bool" "sdl" "SDL_FillRect"
[ "surface*" "rect*" "uint" ] alien-invoke ;
-: SDL_LockSurface ( surface -- )
+: SDL_LockSurface ( surface -- ? )
"bool" "sdl" "SDL_LockSurface" [ "surface*" ] alien-invoke ;
: SDL_UnlockSurface ( surface -- )
[ [ 1 | 1 ] ] [ [ get ] infer old-effect ] unit-test
-[ [ 1 | 1 ] ] [ [ str>number ] infer old-effect ] unit-test
+! [ [ 1 | 1 ] ] [ [ str>number ] infer old-effect ] unit-test
! Type inference
: words ( vocab -- list )
#! Push a list of all words in a vocabulary.
#! Filter empty slots.
- vocab hash-values [ ] subset word-sort ;
+ vocab dup [ hash-values [ ] subset word-sort ] when ;
: each-word ( quot -- )
#! Apply a quotation to each word in the image.
: init-search-path ( -- )
! For files
"scratchpad" "file-in" set
- [ "builtins" "syntax" "scratchpad" ] "file-use" set
+ [ "syntax" "scratchpad" ] "file-use" set
! For interactive
"scratchpad" "in" set
[
- "user"
- "arithmetic"
- "builtins"
"compiler"
"debugger"
"errors"
"files"
+ "generic"
"hashtables"
"inference"
- "inferior"
"interpreter"
"jedit"
"kernel"
"prettyprint"
"processes"
"profiler"
- "stack"
"streams"
"stdio"
"strings"
"threads"
"unparser"
"vectors"
- "vocabularies"
"words"
"scratchpad"
] "use" set ;
return (CELL)fixnum;
break;
case BIGNUM_TYPE:
- bignum = to_bignum(dpop());
+ bignum = to_bignum(x);
if(BIGNUM_NEGATIVE_P(bignum))
{
range_error(F,0,tag_object(bignum),FIXNUM_MAX);
return 0;
}
}
+
/* FFI calls this */
CELL unbox_cell(void)
{
void primitive_dlopen(void)
{
+ DLL* dll;
+ F_STRING* path;
+
maybe_garbage_collection();
- dpush(tag_object(ffi_dlopen(untag_string(dpop()))));
+
+ path = untag_string(dpop());
+ dll = allot_object(DLL_TYPE,sizeof(DLL));
+ dll->path = tag_object(path);
+ ffi_dlopen(dll);
+
+ dpush(tag_object(dll));
}
void primitive_dlsym(void)
{
- DLL *dll;
- F_STRING *sym;
+ CELL dll;
+ F_STRING* sym;
maybe_garbage_collection();
- dll = untag_dll(dpop());
+ dll = dpop();
sym = untag_string(dpop());
- dpush(tag_cell(ffi_dlsym(dll, sym)));
+
+ dpush(tag_cell((CELL)ffi_dlsym(
+ dll == F ? NULL : untag_dll(dll),
+ sym)));
}
void primitive_dlclose(void)
ffi_dlclose(untag_dll(dpop()));
}
-void primitive_dlsym_self(void)
-{
- maybe_garbage_collection();
- dpush(tag_cell(ffi_dlsym(NULL, untag_string(dpop()))));
-}
-
DLL* untag_dll(CELL tagged)
{
DLL* dll = (DLL*)UNTAG(tagged);
void fixup_dll(DLL* dll)
{
- dll->dll = NULL;
+ data_fixup(&dll->path);
+ ffi_dlopen(dll);
+}
+
+void collect_dll(DLL* dll)
+{
+ copy_object(&dll->path);
}
void fixup_alien(ALIEN* alien)
typedef struct {
CELL header;
+ /* tagged string */
+ CELL path;
+ /* OS-specific handle */
void* dll;
} DLL;
return (ALIEN*)UNTAG(tagged);
}
-DLL *ffi_dlopen(F_STRING *path);
+void ffi_dlopen(DLL *dll);
void *ffi_dlsym(DLL *dll, F_STRING *symbol);
void ffi_dlclose(DLL *dll);
void primitive_dlopen(void);
void primitive_dlsym(void);
-void primitive_dlsym_self(void);
void primitive_dlclose(void);
void primitive_alien(void);
void primitive_local_alien(void);
case PORT_TYPE:
collect_port((F_PORT*)scan);
break;
+ case ALIEN_TYPE:
+ collect_alien((ALIEN*)scan);
+ break;
+ case DLL_TYPE:
+ collect_dll((ALIEN*)scan);
+ break;
}
}
primitive_address,
primitive_dlopen,
primitive_dlsym,
- primitive_dlsym_self,
primitive_dlclose,
primitive_alien,
primitive_local_alien,
void relocate_dlsym(F_REL* rel, bool relative)
{
- F_STRING* str = untag_string(get(rel->argument));
- put(rel->offset,(CELL)ffi_dlsym(NULL,str)
+ F_CONS* cons = untag_cons(get(rel->argument));
+ F_STRING* symbol = untag_string(cons->car);
+ DLL* dll = (cons->cdr == F ? NULL : untag_dll(cons->cdr));
+ put(rel->offset,(CELL)ffi_dlsym(dll,symbol)
- (relative ? rel->offset + CELLS : 0));
}
case F_ABSOLUTE_PRIMITIVE:
relocate_primitive(rel,false);
break;
- case F_RELATIVE_DLSYM_SELF:
+ case F_RELATIVE_DLSYM:
code_fixup(&rel->argument);
relocate_dlsym(rel,true);
break;
- case F_ABSOLUTE_DLSYM_SELF:
+ case F_ABSOLUTE_DLSYM:
code_fixup(&rel->argument);
relocate_dlsym(rel,false);
break;
/* arg is a primitive number */
F_RELATIVE_PRIMITIVE,
F_ABSOLUTE_PRIMITIVE,
- /* arg is an pointer in the literal table holding a tagged string */
- F_RELATIVE_DLSYM_SELF,
- F_ABSOLUTE_DLSYM_SELF,
+ /* arg is a pointer in the literal table hodling a cons where the
+ car is a symbol string, and the cdr is a dll */
+ F_RELATIVE_DLSYM,
+ F_ABSOLUTE_DLSYM,
/* relocate an address to start of code heap */
F_ABSOLUTE
} F_RELTYPE;
#include "../factor.h"
-DLL *ffi_dlopen(F_STRING *path)
+void ffi_dlopen(DLL* dll)
{
#ifdef FFI
void* dllptr;
- DLL* dll;
- dllptr = dlopen(to_c_string(path), RTLD_LAZY);
+ dllptr = dlopen(to_c_string(untag_string(dll->path)), RTLD_LAZY);
if(dllptr == NULL)
{
from_c_string(dlerror())));
}
- dll = allot_object(DLL_TYPE,sizeof(DLL));
dll->dll = dllptr;
- return dll;
#else
general_error(ERROR_FFI_DISABLED,F);
#endif
projects / factor.git / commitdiff