diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 4602784ef3..ecfa1735df 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,6 +1,8 @@ FFI: - is signed -vs- unsigned pointers an issue? +- command line parsing cleanup + - BIN: 2: bad - compile word twice; no more 'cannot compile' error! @@ -128,7 +130,6 @@ FFI: - don't rehash strings on every startup - 'cascading' styles - ditch expand -- set-object-path + httpd: diff --git a/library/compiler/alien.factor b/library/compiler/alien.factor index 776367fc1c..2963003576 100644 --- a/library/compiler/alien.factor +++ b/library/compiler/alien.factor @@ -26,6 +26,7 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: alien +USE: combinators USE: compiler USE: errors USE: lists @@ -62,7 +63,13 @@ USE: words "alien-call cannot be interpreted." throw ; : library ( name -- handle ) - "libraries" get get* ; + "libraries" get [ + dup get dup dll? [ + nip + ] [ + dlopen tuck put + ] ifte + ] bind ; : alien-function ( function library -- ) library dlsym ; diff --git a/library/compiler/compile-all.factor b/library/compiler/compile-all.factor index b5841e5c55..f9fc3f8baa 100644 --- a/library/compiler/compile-all.factor +++ b/library/compiler/compile-all.factor @@ -109,8 +109,11 @@ SYMBOL: compilable-word-list #! Make a list of all words that can be compiled. [, [ dup can-compile? [ , ] [ drop ] ifte ] each-word ,] ; +: cannot-compile ( word -- ) + "verbose-compile" get [ "Cannot compile " write . ] when ; + : init-compiler ( -- ) #! Compile all words. compilable-word-list get [ - [ compile ] [ [ "Cannot compile " write . ] when ] catch + [ compile ] [ cannot-compile ] catch ] each ; diff --git a/library/init.factor b/library/init.factor index 4f7f022145..0ee0997fc9 100644 --- a/library/init.factor +++ b/library/init.factor @@ -57,14 +57,24 @@ USE: words ?run-file ] when ; +: cli-var-param ( name value -- ) + swap ":" split set-object-path ; + : cli-param ( param -- ) #! Handle a command-line argument starting with '-' by #! setting that variable to t, or if the argument is #! prefixed with 'no-', setting the variable to f. - dup "no-" str-head? dup [ - f put drop + #! + #! Arguments containing = are handled differently; they + #! set the object path. + "=" split1 dup [ + cli-var-param ] [ - drop t put + drop dup "no-" str-head? dup [ + f put drop + ] [ + drop t put + ] ifte ] ifte ; : cli-arg ( argument -- argument ) diff --git a/library/namespaces.factor b/library/namespaces.factor index 0c59a67b49..6d5c996c4b 100644 --- a/library/namespaces.factor +++ b/library/namespaces.factor @@ -118,6 +118,20 @@ USE: vectors #! Returns f if any of the objects are not set. this swap (object-path) ; +: (set-object-path) ( name -- namespace ) + dup namespace get* dup [ + nip + ] [ + drop tuck put + ] ifte ; + +: set-object-path ( value list -- ) + unswons over [ + (set-object-path) [ set-object-path ] bind + ] [ + nip set + ] ifte ; + : on ( var -- ) t put ; : off ( var -- ) f put ; : toggle ( var -- ) dup get not put ; diff --git a/library/platform/native/boot-stage2.factor b/library/platform/native/boot-stage2.factor index d61d9a4b7a..c1fbea7dc6 100644 --- a/library/platform/native/boot-stage2.factor +++ b/library/platform/native/boot-stage2.factor @@ -158,6 +158,10 @@ cpu "x86" = [ "/library/compiler/alien-types.factor" "/library/compiler/alien-macros.factor" "/library/compiler/alien.factor" + + "/library/sdl/sdl.factor" + "/library/sdl/sdl-video.factor" + "/library/sdl/sdl-event.factor" ] [ dup print run-resource diff --git a/library/sdl/sdl-event.factor b/library/sdl/sdl-event.factor index ccaf3b3010..fd50d6c225 100644 --- a/library/sdl/sdl-event.factor +++ b/library/sdl/sdl-event.factor @@ -27,7 +27,6 @@ IN: sdl USE: alien -USE: compiler BEGIN-ENUM: 0 ENUM: SDL_NOEVENT ! Unused (do not remove) @@ -69,4 +68,4 @@ BEGIN-STRUCT: event END-STRUCT : SDL_WaitEvent ( event -- ) - "int" "sdl" "SDL_WaitEvent" [ "event*" ] alien-call ; compiled + "int" "sdl" "SDL_WaitEvent" [ "event*" ] alien-call ; diff --git a/library/sdl/sdl-gfx.factor b/library/sdl/sdl-gfx.factor new file mode 100644 index 0000000000..7b2a5ce089 --- /dev/null +++ b/library/sdl/sdl-gfx.factor @@ -0,0 +1,110 @@ +IN: sdl +USE: alien +USE: math +USE: namespaces +USE: stack +USE: compiler +USE: words +USE: parser +USE: kernel +USE: errors +USE: combinators +USE: lists +USE: logic + +! This is a kind of high level wrapper around SDL, and turtle +! graphics, in one messy, undocumented package. Will be improved +! later, and heavily refactored, so don't count on this +! interface remaining unchanged. + +SYMBOL: surface +SYMBOL: pixels +SYMBOL: format +SYMBOL: pen +SYMBOL: angle +SYMBOL: color + +: xy-4 ( #{ x y } -- offset ) + >rect surface get surface-pitch * swap 4 * + ; + +: set-pixel-4 ( color #{ x y } -- ) + xy-4 pixels get swap set-alien-4 ; + +: rgb ( r g b -- value ) + >r >r >r format get r> r> r> SDL_MapRGB ; + +: pixel-4-step ( quot #{ x y } -- ) + dup >r swap call rgb r> set-pixel-4 ; + +: with-pixels-4 ( w h quot -- ) + -rot rect> [ over >r pixel-4-step r> ] 2times* drop ; + +: move ( #{ x y } -- ) + pen +@ ; + +: turn ( angle -- ) + angle +@ ; + +: move-d ( distance -- ) + angle get cis * move ; + +: pixel ( -- ) + color get pen get set-pixel-4 ; + +: sgn ( x -- -1/0/1 ) dup 0 = [ 0 < -1 1 ? ] unless ; + +: line-h-step ( #{ dx dy } #{ px py } p -- p ) + over real fixnum- dup 0 < [ + swap imaginary fixnum+ swap + ] [ + nip swap real + ] ifte move pixel ; + +: line-more-h ( #{ dx dy } #{ px py } -- ) + dup imaginary 2 fixnum/i over imaginary [ + >r 2dup r> line-h-step + ] times 3drop ; + +: line-v-step ( #{ dx dy } #{ px py } p -- p ) + over imaginary fixnum- dup 0 fixnum< [ + swap real fixnum+ swap + ] [ + nip swap imaginary 0 swap rect> + ] ifte move pixel ; + +: line-more-v ( #{ dx dy } #{ px py } -- ) + dup real 2 fixnum/i over real [ + >r 2dup r> line-v-step + ] times 3drop ; + +: line ( #{ x y } -- ) + pixel ( first point ) + dup >r >rect swap sgn swap sgn rect> r> + >rect swap abs swap abs 2dup fixnum< [ + rect> line-more-h + ] [ + rect> line-more-v + ] ifte ; + +: line-d ( distance -- ) + angle get cis * line ; + +: 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 SDL_UnlockSurface + ] [ + drop call + ] ifte surface get SDL_Flip ; + +: event-loop ( event -- ) + dup SDL_WaitEvent 1 = [ + dup event-type SDL_QUIT = [ + drop + ] [ + event-loop + ] ifte + ] [ + drop + ] ifte ; diff --git a/library/sdl/sdl-video.factor b/library/sdl/sdl-video.factor index 2eaccc7fa4..ddd882d7cd 100644 --- a/library/sdl/sdl-video.factor +++ b/library/sdl/sdl-video.factor @@ -108,17 +108,17 @@ END-STRUCT : SDL_SetVideoMode ( width height bpp flags -- ) "int" "sdl" "SDL_SetVideoMode" - [ "int" "int" "int" "int" ] alien-call ; compiled + [ "int" "int" "int" "int" ] alien-call ; : SDL_LockSurface ( surface -- ) - "int" "sdl" "SDL_LockSurface" [ "surface*" ] alien-call ; compiled + "int" "sdl" "SDL_LockSurface" [ "surface*" ] alien-call ; : SDL_UnlockSurface ( surface -- ) - "void" "sdl" "SDL_UnlockSurface" [ "surface*" ] alien-call ; compiled + "void" "sdl" "SDL_UnlockSurface" [ "surface*" ] alien-call ; : SDL_Flip ( surface -- ) - "void" "sdl" "SDL_Flip" [ "surface*" ] alien-call ; compiled + "void" "sdl" "SDL_Flip" [ "surface*" ] alien-call ; : SDL_MapRGB ( surface r g b -- ) "int" "sdl" "SDL_MapRGB" - [ "surface*" "char" "char" "char" ] alien-call ; compiled + [ "surface*" "char" "char" "char" ] alien-call ; diff --git a/library/sdl/sdl.factor b/library/sdl/sdl.factor index 7dbc56493b..04e1839677 100644 --- a/library/sdl/sdl.factor +++ b/library/sdl/sdl.factor @@ -39,10 +39,10 @@ USE: compiler : SDL_INIT_EVERYTHING HEX: 0000FFFF ; : SDL_Init ( mode -- ) - "int" "sdl" "SDL_Init" [ "int" ] alien-call ; compiled + "int" "sdl" "SDL_Init" [ "int" ] alien-call ; : SDL_GetError ( -- error ) - "char*" "sdl" "SDL_GetError" [ ] alien-call ; compiled + "char*" "sdl" "SDL_GetError" [ ] alien-call ; : SDL_Quit ( -- ) - "void" "sdl" "SDL_Quit" [ ] alien-call ; compiled + "void" "sdl" "SDL_Quit" [ ] alien-call ; diff --git a/library/test/namespaces/namespaces.factor b/library/test/namespaces/namespaces.factor index 1fe8d28651..d1c39881f9 100644 --- a/library/test/namespaces/namespaces.factor +++ b/library/test/namespaces/namespaces.factor @@ -42,3 +42,14 @@ unit-test [ f ] [ [ f "some-global" set "some-global" get ] bind ] unit-test + +[ + 5 [ "test" "object" "path" ] set-object-path + [ 5 ] [ [ "test" "object" "path" ] object-path ] unit-test + + 7 [ "test" "object" "pathe" ] set-object-path + [ 7 ] [ [ "test" "object" "pathe" ] object-path ] unit-test + + 9 [ "teste" "object" "pathe" ] set-object-path + [ 9 ] [ [ "teste" "object" "pathe" ] object-path ] unit-test +] with-scope diff --git a/native/factor.h b/native/factor.h index a8c3d88327..3e0f6692b3 100644 --- a/native/factor.h +++ b/native/factor.h @@ -52,10 +52,6 @@ typedef unsigned char BYTE; #define STACK_SIZE 16384 -/* This decreases performance slightly but gives more readable backtraces, -and allows profiling. */ -#define FACTOR_PROFILER - #include "memory.h" #include "error.h" #include "gc.h"