added sdl-gfx

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:
 

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 ;

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 ;

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 )

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 <namespace> 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 ;

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

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 ;

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 ;

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 ;

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 ;

library/test/namespaces/namespaces.factor

@@ -42,3 +42,14 @@ unit-test
 [ f ]
 [ <namespace> [ 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

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"