added sdl-gfx

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 4602784ef3bf596ce410ef0e7f6f079c64162f71..ecfa1735dfda89d32bc619e3d216137f8baed00d 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,6 +1,8 @@
 FFI:\r
 - is signed -vs- unsigned pointers an issue?\r
 \r
+- command line parsing cleanup\r
+\r
 - BIN: 2: bad\r
 \r
 - compile word twice; no more 'cannot compile' error!\r
@@ -128,7 +130,6 @@ FFI:
 - don't rehash strings on every startup\r
 - 'cascading' styles\r
 - ditch expand\r
-- set-object-path\r
 \r
 + httpd:\r
 \r

diff --git a/library/compiler/alien.factor b/library/compiler/alien.factor
index 776367fc1cc69f3dcff2522692fdd1a1f7750bb5..296300357622abb7dda200a546e9f5f460331fa5 100644 (file)
--- 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 b5841e5c55e4f9b6a13d9569932a8c263eb3276f..f9fc3f8baa630c45244b6dcf807b298fe69aed4f 100644 (file)
--- 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 4f7f022145fb8ac796ac80ef28b1893afc65aaf4..0ee0997fc9fd7b1933dd06dc8f2a8a7b1ad4aa09 100644 (file)
--- 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 0c59a67b49060df888a92991afe9df0454fd9db6..6d5c996c4b36d70c627457d0ec685ecba807b48d 100644 (file)
--- 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 <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 ;

diff --git a/library/platform/native/boot-stage2.factor b/library/platform/native/boot-stage2.factor
index d61d9a4b7a2ffcd53d1ce86e15395e3586ca2fe8..c1fbea7dc6247dd13b8d07c1deae337c1fd2c446 100644 (file)
--- 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 ccaf3b3010da7ce9ffa85260b57752f3cc583a5e..fd50d6c2256a204508a33aeeeff23bd4fc4135be 100644 (file)
--- 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 (file)
index 0000000..7b2a5ce
--- /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 2eaccc7fa43ed14bb33da8071e4685d4a3c7c067..ddd882d7cdd7b086ed3fc5f61022e81f85d2730b 100644 (file)
--- 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 7dbc56493b04f6691f94415c201bb1e5e4feed14..04e1839677321a2e5cce1f6e4987a6e6cfff8f9f 100644 (file)
--- 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 1fe8d28651fa5f5da12162da83de479961249a32..d1c39881f90e152bb9f4eee4d153208ba43b320e 100644 (file)
--- a/library/test/namespaces/namespaces.factor
+++ b/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

diff --git a/native/factor.h b/native/factor.h
index a8c3d88327d3add14350aa7e39a372ef2303b98a..3e0f6692b39214dba466adf7d3c0113e0f6b1cfe 100644 (file)
--- 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"