From bbc3c01a8b6586289deedb4cca5514c3b5cd2489 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 29 Jul 2008 19:53:00 -0700
Subject: [PATCH 01/10] clean up game-input.backend init so that loading a
backend does not ruin the game-input-backend var and so that client code does
not need to explicitly load game-input.backend itself
---
extra/game-input/backend/backend.factor | 21 ++++++++++++++-----
extra/game-input/backend/dinput/dinput.factor | 9 ++++++--
extra/game-input/backend/iokit/iokit.factor | 6 ++++--
extra/game-input/game-input.factor | 14 ++++++++++---
extra/joystick-demo/joystick-demo.factor | 2 +-
extra/key-caps/key-caps.factor | 2 +-
6 files changed, 40 insertions(+), 14 deletions(-)
diff --git a/extra/game-input/backend/backend.factor b/extra/game-input/backend/backend.factor
index 451bbf1c34..a31b9d6649 100644
--- a/extra/game-input/backend/backend.factor
+++ b/extra/game-input/backend/backend.factor
@@ -1,8 +1,19 @@
-USING: kernel system combinators parser ;
+USING: multiline system parser combinators ;
IN: game-input.backend
-<< {
- { [ os macosx? ] [ "game-input.backend.iokit" use+ ] }
- { [ os windows? ] [ "game-input.backend.dinput" use+ ] }
+STRING: set-backend-for-macosx
+USING: namespaces game-input.backend.iokit game-input ;
+iokit-game-input-backend game-input-backend set-global
+;
+
+STRING: set-backend-for-windows
+USING: namespaces game-input.backend.dinput game-input ;
+dinput-game-input-backend game-input-backend set-global
+;
+
+{
+ { [ os macosx? ] [ set-backend-for-macosx eval ] }
+ { [ os windows? ] [ set-backend-for-windows eval ] }
{ [ t ] [ ] }
-} cond >>
+} cond
+
diff --git a/extra/game-input/backend/dinput/dinput.factor b/extra/game-input/backend/dinput/dinput.factor
index 69b2d41962..73c9f511a1 100755
--- a/extra/game-input/backend/dinput/dinput.factor
+++ b/extra/game-input/backend/dinput/dinput.factor
@@ -206,6 +206,13 @@ M: dinput-game-input-backend (close-game-input)
close-device-change-window
delete-dinput ;
+M: dinput-game-input-backend (reset-game-input)
+ {
+ +dinput+ +keyboard-device+ +keyboard-state+
+ +controller-devices+ +controller-guids+
+ +device-change-window+ +device-change-handle+
+ } [ f swap set-global ] each ;
+
M: dinput-game-input-backend get-controllers
+controller-devices+ get
[ drop controller boa ] { } assoc>map ;
@@ -278,5 +285,3 @@ M: dinput-game-input-backend read-keyboard
+keyboard-device+ get
[ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
[ ] [ f ] with-acquisition ;
-
-dinput-game-input-backend game-input-backend set-global
diff --git a/extra/game-input/backend/iokit/iokit.factor b/extra/game-input/backend/iokit/iokit.factor
index 1871569227..dcdfa6d192 100755
--- a/extra/game-input/backend/iokit/iokit.factor
+++ b/extra/game-input/backend/iokit/iokit.factor
@@ -231,6 +231,10 @@ M: iokit-game-input-backend (open-game-input)
]
} cleave ;
+M: iokit-game-input-backend (reset-game-input)
+ { +hid-manager+ +keyboard-state+ +controller-states+ }
+ [ f swap set-global ] each ;
+
M: iokit-game-input-backend (close-game-input)
+hid-manager+ get-global [
+hid-manager+ global [
@@ -271,5 +275,3 @@ M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
M: iokit-game-input-backend calibrate-controller ( controller -- )
drop ;
-
-iokit-game-input-backend game-input-backend set-global
diff --git a/extra/game-input/game-input.factor b/extra/game-input/game-input.factor
index 4d25b06ead..208c8476fc 100755
--- a/extra/game-input/game-input.factor
+++ b/extra/game-input/game-input.factor
@@ -1,26 +1,34 @@
USING: arrays accessors continuations kernel symbols
-combinators.lib sequences namespaces init ;
+combinators.lib sequences namespaces init vocabs ;
IN: game-input
SYMBOLS: game-input-backend game-input-opened ;
HOOK: (open-game-input) game-input-backend ( -- )
HOOK: (close-game-input) game-input-backend ( -- )
+HOOK: (reset-game-input) game-input-backend ( -- )
: game-input-opened? ( -- ? )
game-input-opened get ;
<PRIVATE
+M: f (reset-game-input) ;
+
: reset-game-input ( -- )
- game-input-opened off ;
+ game-input-opened off
+ (reset-game-input) ;
+
+: load-game-input-backend ( -- )
+ game-input-backend get
+ [ "game-input.backend" load-vocab drop ] unless ;
[ reset-game-input ] "game-input" add-init-hook
PRIVATE>
-
: open-game-input ( -- )
+ load-game-input-backend
game-input-opened? [
(open-game-input)
game-input-opened on
diff --git a/extra/joystick-demo/joystick-demo.factor b/extra/joystick-demo/joystick-demo.factor
index c39a4b0b1c..b5289dbcbf 100755
--- a/extra/joystick-demo/joystick-demo.factor
+++ b/extra/joystick-demo/joystick-demo.factor
@@ -1,6 +1,6 @@
USING: ui ui.gadgets sequences kernel arrays math colors
ui.render math.vectors accessors fry ui.gadgets.packs game-input
-game-input.backend ui.gadgets.labels ui.gadgets.borders alarms
+ui.gadgets.labels ui.gadgets.borders alarms
calendar locals combinators.lib strings ui.gadgets.buttons
combinators math.parser assocs threads ;
IN: joystick-demo
diff --git a/extra/key-caps/key-caps.factor b/extra/key-caps/key-caps.factor
index 4161b94908..cb946a1062 100755
--- a/extra/key-caps/key-caps.factor
+++ b/extra/key-caps/key-caps.factor
@@ -1,4 +1,4 @@
-USING: game-input game-input.backend game-input.scancodes
+USING: game-input game-input.scancodes
kernel ui.gadgets ui.gadgets.buttons sequences accessors
words arrays assocs math calendar fry alarms ui
ui.gadgets.borders ui.gestures ;
From b42cb5434e2b7176746a2349d0b94c1aa31b5c0c Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 29 Jul 2008 21:02:37 -0700
Subject: [PATCH 02/10] Rebuild windows.com.wrapper objects on image init
---
extra/windows/com/wrapper/wrapper.factor | 53 +++++++++++++++++-------
1 file changed, 39 insertions(+), 14 deletions(-)
diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor
index 40c61dfbe7..782ebae516 100755
--- a/extra/windows/com/wrapper/wrapper.factor
+++ b/extra/windows/com/wrapper/wrapper.factor
@@ -1,11 +1,11 @@
-USING: alien alien.c-types windows.com.syntax
+USING: alien alien.c-types windows.com.syntax init
windows.com.syntax.private windows.com continuations kernel
namespaces windows.ole32 libc vocabs assocs accessors arrays
sequences quotations combinators math words compiler.units
-destructors fry math.parser generalizations ;
+destructors fry math.parser generalizations sets ;
IN: windows.com.wrapper
-TUPLE: com-wrapper vtbls disposed ;
+TUPLE: com-wrapper callbacks vtbls disposed ;
<PRIVATE
@@ -14,6 +14,11 @@ SYMBOL: +wrapped-objects+
[ H{ } +wrapped-objects+ set-global ]
unless
+SYMBOL: +live-wrappers+
++live-wrappers+ get-global
+[ V{ } +live-wrappers+ set-global ]
+unless
+
SYMBOL: +vtbl-counter+
+vtbl-counter+ get-global
[ 0 +vtbl-counter+ set-global ]
@@ -82,13 +87,12 @@ unless
[ '[ , [ swap 2array ] curry map ] ] bi bi*
swap append ;
-: compile-alien-callback ( word return parameters abi quot -- alien )
+: compile-alien-callback ( word return parameters abi quot -- word )
'[ , , , , alien-callback ]
[ [ (( -- alien )) define-declared ] pick slip ]
- with-compilation-unit
- execute ;
+ with-compilation-unit ;
-: (byte-array-to-malloced-buffer) ( byte-array -- alien )
+: byte-array>malloc ( byte-array -- alien )
[ byte-length malloc ] [ over byte-array>memory ] bi ;
: (callback-word) ( function-name interface-name counter -- word )
@@ -99,7 +103,7 @@ unless
[ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ]
dip compose ;
-: (make-vtbl) ( interface-name quots iunknown-methods n -- vtbl )
+: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words )
(thunk) (thunked-quots)
swap [ find-com-interface-definition family-tree-functions ]
keep (next-vtbl-counter) '[
@@ -114,12 +118,12 @@ unless
first2 (finish-thunk)
] bi*
"stdcall" swap compile-alien-callback
- ] 2map >c-void*-array
- (byte-array-to-malloced-buffer) ;
+ ] 2map ;
-: (make-vtbls) ( implementations -- vtbls )
+: (make-callbacks) ( implementations -- sequence )
dup [ first ] map (make-iunknown-methods)
- [ >r >r first2 r> r> swap (make-vtbl) ] curry map-index ;
+ [ >r >r first2 r> r> swap (make-interface-callbacks) ]
+ curry map-index ;
: (malloc-wrapped-object) ( wrapper -- wrapped-object )
vtbls>> length "void*" heap-size *
@@ -127,13 +131,34 @@ unless
over <displaced-alien>
1 0 rot set-ulong-nth ;
+: (callbacks>vtbl) ( callbacks -- vtbl )
+ [ execute ] map >c-void*-array byte-array>malloc ;
+: (callbacks>vtbls) ( callbacks -- vtbls )
+ [ (callbacks>vtbl) ] map ;
+
+: (allocate-wrapper) ( wrapper -- )
+ dup callbacks>> (callbacks>vtbls) >>vtbls
+ f >>disposed drop ;
+
+: (init-hook) ( -- )
+ +live-wrappers+ get-global [ (allocate-wrapper) ] each
+ H{ } +wrapped-objects+ set-global ;
+
+[ (init-hook) ] "windows.com.wrapper" add-init-hook
+
PRIVATE>
+: allocate-wrapper ( wrapper -- )
+ [ (allocate-wrapper) ]
+ [ +live-wrappers+ get adjoin ] bi ;
+
: <com-wrapper> ( implementations -- wrapper )
- (make-vtbls) f com-wrapper boa ;
+ (make-callbacks) f f com-wrapper boa
+ dup allocate-wrapper ;
M: com-wrapper dispose*
- vtbls>> [ free ] each ;
+ [ [ free ] each f ] change-vtbls
+ +live-wrappers+ get-global delete ;
: com-wrap ( object wrapper -- wrapped-object )
[ vtbls>> ] [ (malloc-wrapped-object) ] bi
From 393d8ba0a73dd2314c08f1b4ddd599eae77506cb Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 29 Jul 2008 21:23:47 -0700
Subject: [PATCH 03/10] typo
---
basis/windows/com/com-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/windows/com/com-tests.factor b/basis/windows/com/com-tests.factor
index cd67fd19d2..289581a929 100755
--- a/basis/windows/com/com-tests.factor
+++ b/basis/windows/com/com-tests.factor
@@ -45,7 +45,7 @@ C: <test-implementation> test-implementation
} }
{ "IUnrelated" {
[ swap x>> + ] ! IUnrelated::xPlus
- [ spin x>> * + ] ! IUnrealted::xMulAdd
+ [ spin x>> * + ] ! IUnrelated::xMulAdd
} }
} <com-wrapper>
dup +test-wrapper+ set [
From 101065e74f8e7f6c9e29b193dee288cf60fad848 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 31 Jul 2008 21:37:39 -0700
Subject: [PATCH 04/10] Executable images
---
core/bootstrap/primitives.factor | 1 +
core/memory/memory-docs.factor | 5 +++
core/memory/memory.factor | 4 ++
vm/factor.c | 13 ++----
vm/factor.h | 3 --
vm/image.c | 75 ++++++++++++++++++++++++++------
vm/image.h | 9 +++-
vm/primitives.c | 1 +
8 files changed, 85 insertions(+), 26 deletions(-)
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 5d7d5e0d2c..24c1da41de 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -532,6 +532,7 @@ tuple
{ "dll-valid?" "alien" }
{ "unimplemented" "kernel.private" }
{ "gc-reset" "memory" }
+ { "(save-image*)" "memory" }
}
[ >r first2 r> make-primitive ] each-index
diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor
index 1213245863..b8aabd10cf 100755
--- a/core/memory/memory-docs.factor
+++ b/core/memory/memory-docs.factor
@@ -5,6 +5,7 @@ ARTICLE: "images" "Images"
"The current image can be saved; the image contains a complete dump of all data and code in the current Factor instance:"
{ $subsection save }
{ $subsection save-image }
+{ $subsection save-image* }
{ $subsection save-image-and-exit }
"To start Factor with a custom image, use the " { $snippet "-i=" { $emphasis "image" } } " command line switch; see " { $link "runtime-cli-args" } "."
{ $see-also "tools.memory" } ;
@@ -56,6 +57,10 @@ HELP: save-image ( path -- )
{ $values { "path" "a pathname string" } }
{ $description "Saves a snapshot of the heap to the given file, overwriting the file if it already exists." } ;
+HELP: save-image* ( path arguments -- )
+{ $values { "path" "a pathname string" } { "arguments" "a commandline string" } }
+{ $description "Saves a snapshot of the heap to the given file, overwriting the file if it already exists. The image is formatted so that Unix systems can execute the image directly using the shellscript #! syntax. The saved image will start the current VM with the given commandline arguments when executed." } ;
+
HELP: save-image-and-exit ( path -- )
{ $values { "path" "a pathname string" } }
{ $description "Saves a snapshot of the heap to the given file, overwriting the file if it already exists. This word compacts the code heap and immediately exits Factor, since the Factor VM cannot continue executing after compiled code blocks have been moved around." } ;
diff --git a/core/memory/memory.factor b/core/memory/memory.factor
index cb5c5bf7e4..2a702097f4 100644
--- a/core/memory/memory.factor
+++ b/core/memory/memory.factor
@@ -13,3 +13,7 @@ IN: memory
pusher [ each-object ] dip >array ; inline
: save ( -- ) image save-image ;
+
+: save-image* ( path args -- )
+ "#!" vm append swap "-shebang\n" 3array " " join
+ (save-image*) ; inline
diff --git a/vm/factor.c b/vm/factor.c
index e81152bd99..8bdf67ec18 100755
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -140,13 +140,8 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
CELL i;
- posix_argc = argc;
- posix_argv = safe_malloc(argc * sizeof(F_CHAR*));
- posix_argv[0] = safe_strdup(argv[0]);
-
for(i = 1; i < argc; i++)
{
- posix_argv[i] = safe_strdup(argv[i]);
if(factor_arg(argv[i],STR_FORMAT("-datastack=%d"),&p.ds_size));
else if(factor_arg(argv[i],STR_FORMAT("-retainstack=%d"),&p.rs_size));
else if(factor_arg(argv[i],STR_FORMAT("-generations=%d"),&p.gen_count));
@@ -160,6 +155,10 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
p.fep = true;
else if(STRNCMP(argv[i],STR_FORMAT("-i="),3) == 0)
p.image = argv[i] + 3;
+ else if(STRCMP(argv[i],STR_FORMAT("-shebang")) == 0 && i < argc)
+ {
+ p.image = argv[--argc];
+ }
else if(STRCMP(argv[i],STR_FORMAT("-console")) == 0)
p.console = true;
else if(STRCMP(argv[i],STR_FORMAT("-no-stack-traces")) == 0)
@@ -194,10 +193,6 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
c_to_factor_toplevel(userenv[BOOT_ENV]);
unnest_stacks();
-
- for(i = 0; i < argc; i++)
- free(posix_argv[i]);
- free(posix_argv);
}
char *factor_eval_string(char *string)
diff --git a/vm/factor.h b/vm/factor.h
index a0632c3138..3117e054d3 100644
--- a/vm/factor.h
+++ b/vm/factor.h
@@ -1,6 +1,3 @@
-int posix_argc;
-F_CHAR **posix_argv;
-
DLLEXPORT void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded);
DLLEXPORT char *factor_eval_string(char *string);
DLLEXPORT void factor_eval_free(char *result);
diff --git a/vm/image.c b/vm/image.c
index a0fa48d504..d6436573b4 100755
--- a/vm/image.c
+++ b/vm/image.c
@@ -80,6 +80,12 @@ void load_image(F_PARAMETERS *p)
F_HEADER h;
fread(&h,sizeof(F_HEADER),1,file);
+ if(h.magic_bytes[0] == '#' && h.magic_bytes[1] == '!')
+ {
+ fseek(file,IMAGE_SHEBANG_BLOCK_SIZE,SEEK_SET);
+ fread(&h,sizeof(F_HEADER),1,file);
+ }
+
if(h.magic != IMAGE_MAGIC)
fatal_error("Bad image: magic number check failed",h.magic);
@@ -101,21 +107,10 @@ void load_image(F_PARAMETERS *p)
}
/* Save the current image to disk */
-bool save_image(const F_CHAR *filename)
+static bool save_image_to_file(FILE *file)
{
- FILE* file;
- F_HEADER h;
-
- FPRINTF(stderr,"*** Saving %s...\n",filename);
-
- file = OPEN_WRITE(filename);
- if(file == NULL)
- {
- fprintf(stderr,"Cannot open image file: %s\n",strerror(errno));
- return false;
- }
-
F_ZONE *tenured = &data_heap->generations[TENURED];
+ F_HEADER h;
h.magic = IMAGE_MAGIC;
h.version = IMAGE_VERSION;
@@ -161,6 +156,49 @@ bool save_image(const F_CHAR *filename)
return true;
}
+bool save_image(const F_CHAR *filename)
+{
+ FILE* file;
+
+ FPRINTF(stderr,"*** Saving %s...\n",filename);
+
+ file = OPEN_WRITE(filename);
+ if(file == NULL)
+ {
+ fprintf(stderr,"Cannot open image file: %s\n",strerror(errno));
+ return false;
+ }
+
+
+ return save_image_to_file(file);
+}
+
+bool save_image_shebang(const F_CHAR *filename, const char *shebang)
+{
+ FILE* file;
+
+ FPRINTF(stderr,"*** Saving %s...\n",filename);
+
+ file = OPEN_WRITE(filename);
+ if(file == NULL)
+ {
+ fprintf(stderr,"Cannot open image file: %s\n",strerror(errno));
+ return false;
+ }
+
+ unsigned char shebang_block[IMAGE_SHEBANG_BLOCK_SIZE];
+ strncpy(shebang_block,shebang,IMAGE_SHEBANG_BLOCK_SIZE-1);
+ shebang_block[IMAGE_SHEBANG_BLOCK_SIZE-1] = 0;
+
+ if(fwrite(shebang_block,IMAGE_SHEBANG_BLOCK_SIZE,1,file) != 1)
+ {
+ fprintf(stderr,"Save #! block failed: %s\n",strerror(errno));
+ return false;
+ }
+
+ return save_image_to_file(file);
+}
+
DEFINE_PRIMITIVE(save_image)
{
/* do a full GC to push everything into tenured space */
@@ -169,6 +207,17 @@ DEFINE_PRIMITIVE(save_image)
save_image(unbox_native_string());
}
+DEFINE_PRIMITIVE(save_image_shebang)
+{
+ /* do a full GC to push everything into tenured space */
+ gc();
+
+ char *shebang = unbox_char_string();
+ F_CHAR *path = unbox_native_string();
+
+ save_image_shebang(path, shebang);
+}
+
DEFINE_PRIMITIVE(save_image_and_exit)
{
F_CHAR *path = unbox_native_string();
diff --git a/vm/image.h b/vm/image.h
index 9e582fc6c6..8393f73a6c 100755
--- a/vm/image.h
+++ b/vm/image.h
@@ -1,8 +1,13 @@
#define IMAGE_MAGIC 0x0f0e0d0c
#define IMAGE_VERSION 4
+#define IMAGE_SHEBANG_BLOCK_SIZE 512
+
typedef struct {
- CELL magic;
+ union {
+ CELL magic;
+ char magic_bytes[sizeof(CELL)];
+ };
CELL version;
/* all pointers in the image file are relocated from
relocation_base to here when the image is loaded */
@@ -39,8 +44,10 @@ typedef struct {
void load_image(F_PARAMETERS *p);
void init_objects(F_HEADER *h);
bool save_image(const F_CHAR *file);
+bool save_image_shebang(const F_CHAR *file, const char *shebang);
DECLARE_PRIMITIVE(save_image);
+DECLARE_PRIMITIVE(save_image_shebang);
DECLARE_PRIMITIVE(save_image_and_exit);
/* relocation base of currently loaded image's data heap */
diff --git a/vm/primitives.c b/vm/primitives.c
index b5d9403342..91f6eea0e4 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -149,4 +149,5 @@ void *primitives[] = {
primitive_dll_validp,
primitive_unimplemented,
primitive_gc_reset,
+ primitive_save_image_shebang,
};
From c6d1bd6b256b6547dbdc2ad467e351d5abc588db Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 1 Aug 2008 06:40:30 -0700
Subject: [PATCH 05/10] Revert "Executable images"
This reverts commit 101065e74f8e7f6c9e29b193dee288cf60fad848.
---
core/bootstrap/primitives.factor | 1 -
core/memory/memory-docs.factor | 5 ---
core/memory/memory.factor | 4 --
vm/factor.c | 13 ++++--
vm/factor.h | 3 ++
vm/image.c | 75 ++++++--------------------------
vm/image.h | 9 +---
vm/primitives.c | 1 -
8 files changed, 26 insertions(+), 85 deletions(-)
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 24c1da41de..5d7d5e0d2c 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -532,7 +532,6 @@ tuple
{ "dll-valid?" "alien" }
{ "unimplemented" "kernel.private" }
{ "gc-reset" "memory" }
- { "(save-image*)" "memory" }
}
[ >r first2 r> make-primitive ] each-index
diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor
index b8aabd10cf..1213245863 100755
--- a/core/memory/memory-docs.factor
+++ b/core/memory/memory-docs.factor
@@ -5,7 +5,6 @@ ARTICLE: "images" "Images"
"The current image can be saved; the image contains a complete dump of all data and code in the current Factor instance:"
{ $subsection save }
{ $subsection save-image }
-{ $subsection save-image* }
{ $subsection save-image-and-exit }
"To start Factor with a custom image, use the " { $snippet "-i=" { $emphasis "image" } } " command line switch; see " { $link "runtime-cli-args" } "."
{ $see-also "tools.memory" } ;
@@ -57,10 +56,6 @@ HELP: save-image ( path -- )
{ $values { "path" "a pathname string" } }
{ $description "Saves a snapshot of the heap to the given file, overwriting the file if it already exists." } ;
-HELP: save-image* ( path arguments -- )
-{ $values { "path" "a pathname string" } { "arguments" "a commandline string" } }
-{ $description "Saves a snapshot of the heap to the given file, overwriting the file if it already exists. The image is formatted so that Unix systems can execute the image directly using the shellscript #! syntax. The saved image will start the current VM with the given commandline arguments when executed." } ;
-
HELP: save-image-and-exit ( path -- )
{ $values { "path" "a pathname string" } }
{ $description "Saves a snapshot of the heap to the given file, overwriting the file if it already exists. This word compacts the code heap and immediately exits Factor, since the Factor VM cannot continue executing after compiled code blocks have been moved around." } ;
diff --git a/core/memory/memory.factor b/core/memory/memory.factor
index 2a702097f4..cb5c5bf7e4 100644
--- a/core/memory/memory.factor
+++ b/core/memory/memory.factor
@@ -13,7 +13,3 @@ IN: memory
pusher [ each-object ] dip >array ; inline
: save ( -- ) image save-image ;
-
-: save-image* ( path args -- )
- "#!" vm append swap "-shebang\n" 3array " " join
- (save-image*) ; inline
diff --git a/vm/factor.c b/vm/factor.c
index 8bdf67ec18..e81152bd99 100755
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -140,8 +140,13 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
CELL i;
+ posix_argc = argc;
+ posix_argv = safe_malloc(argc * sizeof(F_CHAR*));
+ posix_argv[0] = safe_strdup(argv[0]);
+
for(i = 1; i < argc; i++)
{
+ posix_argv[i] = safe_strdup(argv[i]);
if(factor_arg(argv[i],STR_FORMAT("-datastack=%d"),&p.ds_size));
else if(factor_arg(argv[i],STR_FORMAT("-retainstack=%d"),&p.rs_size));
else if(factor_arg(argv[i],STR_FORMAT("-generations=%d"),&p.gen_count));
@@ -155,10 +160,6 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
p.fep = true;
else if(STRNCMP(argv[i],STR_FORMAT("-i="),3) == 0)
p.image = argv[i] + 3;
- else if(STRCMP(argv[i],STR_FORMAT("-shebang")) == 0 && i < argc)
- {
- p.image = argv[--argc];
- }
else if(STRCMP(argv[i],STR_FORMAT("-console")) == 0)
p.console = true;
else if(STRCMP(argv[i],STR_FORMAT("-no-stack-traces")) == 0)
@@ -193,6 +194,10 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
c_to_factor_toplevel(userenv[BOOT_ENV]);
unnest_stacks();
+
+ for(i = 0; i < argc; i++)
+ free(posix_argv[i]);
+ free(posix_argv);
}
char *factor_eval_string(char *string)
diff --git a/vm/factor.h b/vm/factor.h
index 3117e054d3..a0632c3138 100644
--- a/vm/factor.h
+++ b/vm/factor.h
@@ -1,3 +1,6 @@
+int posix_argc;
+F_CHAR **posix_argv;
+
DLLEXPORT void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded);
DLLEXPORT char *factor_eval_string(char *string);
DLLEXPORT void factor_eval_free(char *result);
diff --git a/vm/image.c b/vm/image.c
index d6436573b4..a0fa48d504 100755
--- a/vm/image.c
+++ b/vm/image.c
@@ -80,12 +80,6 @@ void load_image(F_PARAMETERS *p)
F_HEADER h;
fread(&h,sizeof(F_HEADER),1,file);
- if(h.magic_bytes[0] == '#' && h.magic_bytes[1] == '!')
- {
- fseek(file,IMAGE_SHEBANG_BLOCK_SIZE,SEEK_SET);
- fread(&h,sizeof(F_HEADER),1,file);
- }
-
if(h.magic != IMAGE_MAGIC)
fatal_error("Bad image: magic number check failed",h.magic);
@@ -107,11 +101,22 @@ void load_image(F_PARAMETERS *p)
}
/* Save the current image to disk */
-static bool save_image_to_file(FILE *file)
+bool save_image(const F_CHAR *filename)
{
- F_ZONE *tenured = &data_heap->generations[TENURED];
+ FILE* file;
F_HEADER h;
+ FPRINTF(stderr,"*** Saving %s...\n",filename);
+
+ file = OPEN_WRITE(filename);
+ if(file == NULL)
+ {
+ fprintf(stderr,"Cannot open image file: %s\n",strerror(errno));
+ return false;
+ }
+
+ F_ZONE *tenured = &data_heap->generations[TENURED];
+
h.magic = IMAGE_MAGIC;
h.version = IMAGE_VERSION;
h.data_relocation_base = tenured->start;
@@ -156,49 +161,6 @@ static bool save_image_to_file(FILE *file)
return true;
}
-bool save_image(const F_CHAR *filename)
-{
- FILE* file;
-
- FPRINTF(stderr,"*** Saving %s...\n",filename);
-
- file = OPEN_WRITE(filename);
- if(file == NULL)
- {
- fprintf(stderr,"Cannot open image file: %s\n",strerror(errno));
- return false;
- }
-
-
- return save_image_to_file(file);
-}
-
-bool save_image_shebang(const F_CHAR *filename, const char *shebang)
-{
- FILE* file;
-
- FPRINTF(stderr,"*** Saving %s...\n",filename);
-
- file = OPEN_WRITE(filename);
- if(file == NULL)
- {
- fprintf(stderr,"Cannot open image file: %s\n",strerror(errno));
- return false;
- }
-
- unsigned char shebang_block[IMAGE_SHEBANG_BLOCK_SIZE];
- strncpy(shebang_block,shebang,IMAGE_SHEBANG_BLOCK_SIZE-1);
- shebang_block[IMAGE_SHEBANG_BLOCK_SIZE-1] = 0;
-
- if(fwrite(shebang_block,IMAGE_SHEBANG_BLOCK_SIZE,1,file) != 1)
- {
- fprintf(stderr,"Save #! block failed: %s\n",strerror(errno));
- return false;
- }
-
- return save_image_to_file(file);
-}
-
DEFINE_PRIMITIVE(save_image)
{
/* do a full GC to push everything into tenured space */
@@ -207,17 +169,6 @@ DEFINE_PRIMITIVE(save_image)
save_image(unbox_native_string());
}
-DEFINE_PRIMITIVE(save_image_shebang)
-{
- /* do a full GC to push everything into tenured space */
- gc();
-
- char *shebang = unbox_char_string();
- F_CHAR *path = unbox_native_string();
-
- save_image_shebang(path, shebang);
-}
-
DEFINE_PRIMITIVE(save_image_and_exit)
{
F_CHAR *path = unbox_native_string();
diff --git a/vm/image.h b/vm/image.h
index 8393f73a6c..9e582fc6c6 100755
--- a/vm/image.h
+++ b/vm/image.h
@@ -1,13 +1,8 @@
#define IMAGE_MAGIC 0x0f0e0d0c
#define IMAGE_VERSION 4
-#define IMAGE_SHEBANG_BLOCK_SIZE 512
-
typedef struct {
- union {
- CELL magic;
- char magic_bytes[sizeof(CELL)];
- };
+ CELL magic;
CELL version;
/* all pointers in the image file are relocated from
relocation_base to here when the image is loaded */
@@ -44,10 +39,8 @@ typedef struct {
void load_image(F_PARAMETERS *p);
void init_objects(F_HEADER *h);
bool save_image(const F_CHAR *file);
-bool save_image_shebang(const F_CHAR *file, const char *shebang);
DECLARE_PRIMITIVE(save_image);
-DECLARE_PRIMITIVE(save_image_shebang);
DECLARE_PRIMITIVE(save_image_and_exit);
/* relocation base of currently loaded image's data heap */
diff --git a/vm/primitives.c b/vm/primitives.c
index 91f6eea0e4..b5d9403342 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -149,5 +149,4 @@ void *primitives[] = {
primitive_dll_validp,
primitive_unimplemented,
primitive_gc_reset,
- primitive_save_image_shebang,
};
From f04c5f9c7fa91ccd1ce38c792fd18d180e0e6271 Mon Sep 17 00:00:00 2001
From: William Schlieper <schlieper@unc.edu>
Date: Sun, 3 Aug 2008 20:29:53 -0400
Subject: [PATCH 06/10] irc.ui: Fixed userlist sorting bug
---
extra/irc/ui/ui.factor | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)
diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor
index 0c9fdee6e0..e9b098a67c 100755
--- a/extra/irc/ui/ui.factor
+++ b/extra/irc/ui/ui.factor
@@ -125,8 +125,11 @@ M: irc-message write-irc
GENERIC: handle-inbox ( tab message -- )
+: lower-<=> ( x y -- <=> )
+ [ >lower ] bi@ <=> ;
+
: value-labels ( assoc val -- seq )
- '[ nip , = ] assoc-filter keys [ >lower <=> ] sort [ <label> ] map ;
+ '[ nip , = ] assoc-filter keys [ lower-<=> ] sort [ <label> ] map ;
: add-gadget-color ( pack seq color -- pack )
'[ , >>color add-gadget ] each ;
From cbb4a67560352f7d9535749324208c8578ff5a5a Mon Sep 17 00:00:00 2001
From: William Schlieper <schlieper@unc.edu>
Date: Sun, 3 Aug 2008 20:35:23 -0400
Subject: [PATCH 07/10] irc.ui: Userlist sorting now uses Unicode Collation
Algorithm
---
extra/irc/ui/ui.factor | 7 ++-----
1 file changed, 2 insertions(+), 5 deletions(-)
diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor
index e9b098a67c..f712e17afe 100755
--- a/extra/irc/ui/ui.factor
+++ b/extra/irc/ui/ui.factor
@@ -3,7 +3,7 @@
USING: accessors kernel threads combinators concurrency.mailboxes
sequences strings hashtables splitting fry assocs hashtables colors
- sorting qualified unicode.case math.order
+ sorting qualified unicode.collation math.order
ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels
@@ -125,11 +125,8 @@ M: irc-message write-irc
GENERIC: handle-inbox ( tab message -- )
-: lower-<=> ( x y -- <=> )
- [ >lower ] bi@ <=> ;
-
: value-labels ( assoc val -- seq )
- '[ nip , = ] assoc-filter keys [ lower-<=> ] sort [ <label> ] map ;
+ '[ nip , = ] assoc-filter keys [ string<=> ] sort [ <label> ] map ;
: add-gadget-color ( pack seq color -- pack )
'[ , >>color add-gadget ] each ;
From af80e5c97f32627ad575ce0343bd063f93de1d1c Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 3 Aug 2008 17:41:21 -0700
Subject: [PATCH 08/10] retool with-gl-program -- preserving the program object
and using cleave is more flexible than the hardcoded pattern
---
extra/bunny/cel-shaded/cel-shaded.factor | 18 ++++++++++--------
extra/bunny/outlined/outlined.factor | 15 ++++++++-------
extra/opengl/shaders/shaders-docs.factor | 15 ++-------------
extra/opengl/shaders/shaders.factor | 20 +++-----------------
extra/spheres/spheres.factor | 16 ++++++++--------
5 files changed, 31 insertions(+), 53 deletions(-)
diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor
index 8285cd776f..e481b47161 100644
--- a/extra/bunny/cel-shaded/cel-shaded.factor
+++ b/extra/bunny/cel-shaded/cel-shaded.factor
@@ -1,6 +1,6 @@
USING: arrays bunny.model continuations destructors kernel
multiline opengl opengl.shaders opengl.capabilities opengl.gl
-sequences sequences.lib accessors ;
+sequences sequences.lib accessors combinators ;
IN: bunny.cel-shaded
STRING: vertex-shader-source
@@ -78,13 +78,15 @@ TUPLE: bunny-cel-shaded program ;
] [ f ] if ;
: (draw-cel-shaded-bunny) ( geom program -- )
- {
- { "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] }
- { "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] }
- { "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] }
- { "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] }
- { "shininess" [ 100.0 glUniform1f ] }
- } [ bunny-geom ] with-gl-program ;
+ [
+ {
+ [ "light_direction" glGetUniformLocation 1.0 -1.0 1.0 glUniform3f ]
+ [ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ]
+ [ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ]
+ [ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ]
+ [ "shininess" glGetUniformLocation 100.0 glUniform1f ]
+ } cleave bunny-geom
+ ] with-gl-program ;
M: bunny-cel-shaded draw-bunny
program>> (draw-cel-shaded-bunny) ;
diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor
index fcba98a0e9..bf757c4fb3 100755
--- a/extra/bunny/outlined/outlined.factor
+++ b/extra/bunny/outlined/outlined.factor
@@ -220,13 +220,14 @@ TUPLE: bunny-outlined
[ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ]
[ depth-texture>> GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ]
[
- pass2-program>> {
- { "colormap" [ 0 glUniform1i ] }
- { "normalmap" [ 1 glUniform1i ] }
- { "depthmap" [ 2 glUniform1i ] }
- { "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] }
- } [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ]
- with-gl-program
+ pass2-program>> [
+ {
+ [ "colormap" glGetUniformLocation 0 glUniform1i ]
+ [ "normalmap" glGetUniformLocation 1 glUniform1i ]
+ [ "depthmap" glGetUniformLocation 2 glUniform1i ]
+ [ "line_color" glGetUniformLocation 0.1 0.0 0.1 1.0 glUniform4f ]
+ } cleave { -1.0 -1.0 } { 1.0 1.0 } rect-vertices
+ ] with-gl-program
]
} cleave ;
diff --git a/extra/opengl/shaders/shaders-docs.factor b/extra/opengl/shaders/shaders-docs.factor
index 93251627f4..1a10071ddf 100644
--- a/extra/opengl/shaders/shaders-docs.factor
+++ b/extra/opengl/shaders/shaders-docs.factor
@@ -95,18 +95,7 @@ HELP: delete-gl-program
{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ;
HELP: with-gl-program
-{ $values { "program" "A " { $link gl-program } " object" } { "uniforms" "An " { $link assoc } " between uniform parameter names and quotations with effect " { $snippet "( uniform-location -- )" } } { "quot" "A quotation" } }
-{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } ". Before calling " { $snippet "quot" } ", calls " { $link glGetUniformLocation } " on each key of " { $snippet "uniforms" } " to get the address of the uniform parameter, which is then placed on top of the stack as the associated quotation is called.\n\nExample:" }
-{ $code <"
-! From bunny.cel-shaded
-: (draw-cel-shaded-bunny) ( geom program -- )
- {
- { "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] }
- { "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] }
- { "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] }
- { "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] }
- { "shininess" [ 100.0 glUniform1f ] }
- } [ bunny-geom ] with-gl-program ;
-"> } ;
+{ $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation with stack effect " { $snippet "( program -- )" } } }
+{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". " { $snippet "program" } " is left on the top of the stack when " { $snippet "quot" } " is called. The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ;
ABOUT: "gl-utilities"
diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor
index c05e180c11..d52e55417f 100755
--- a/extra/opengl/shaders/shaders.factor
+++ b/extra/opengl/shaders/shaders.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
assocs alien alien.strings libc opengl math sequences combinators
-combinators.lib macros arrays io.encodings.ascii ;
+combinators.lib macros arrays io.encodings.ascii fry ;
IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- )
@@ -107,22 +107,8 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
2dup detach-gl-program-shader delete-gl-shader
] each delete-gl-program-only ;
-: (with-gl-program) ( program quot -- )
- swap glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
-
-: (with-gl-program-uniforms) ( uniforms -- quot )
- [ [ swap , \ glGetUniformLocation , % ] [ ] make ]
- { } assoc>map ;
-: (make-with-gl-program) ( uniforms quot -- q )
- [
- \ dup ,
- [ swap (with-gl-program-uniforms) , \ cleave , % ]
- [ ] make ,
- \ (with-gl-program) ,
- ] [ ] make ;
-
-MACRO: with-gl-program ( uniforms quot -- )
- (make-with-gl-program) ;
+: with-gl-program ( program quot -- )
+ over glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
PREDICATE: gl-program < integer (gl-program?) ;
diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor
index 9607f6d201..84621f8e18 100755
--- a/extra/spheres/spheres.factor
+++ b/extra/spheres/spheres.factor
@@ -194,10 +194,9 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
: sphere-scene ( gadget -- )
GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
[
- solid-sphere-program>> dup {
- { "light_position" [ 0.0 0.0 100.0 glUniform3f ] }
- } [
+ solid-sphere-program>> [
{
+ [ "light_position" glGetUniformLocation 0.0 0.0 100.0 glUniform3f ]
[ { 7.0 0.0 0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ]
[ { -7.0 0.0 0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-sphere) ]
[ { 0.0 0.0 7.0 } 1.0 { 0.0 0.0 1.0 1.0 } (draw-sphere) ]
@@ -207,7 +206,8 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
} cleave
] with-gl-program
] [
- plane-program>> { } [
+ plane-program>> [
+ drop
GL_QUADS [
-1000.0 -30.0 1000.0 glVertex3f
-1000.0 -30.0 -1000.0 glVertex3f
@@ -269,10 +269,10 @@ M: spheres-gadget draw-gadget* ( gadget -- )
[ sphere-scene ]
[ reflection-texture>> GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit ]
[
- texture-sphere-program>> dup {
- { "surface_texture" [ 0 glUniform1i ] }
- } [
- { 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere)
+ texture-sphere-program>> [
+ [ "surface_texture" glGetUniformLocation 0 glUniform1i ]
+ [ { 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ]
+ bi
] with-gl-program
]
} cleave ;
From e253fe06d4dd961b7667e0fa07bb5b5f418d066c Mon Sep 17 00:00:00 2001
From: William Schlieper <schlieper@unc.edu>
Date: Mon, 4 Aug 2008 15:44:40 -0400
Subject: [PATCH 09/10] Kick messages now supported
---
extra/irc/ui/ui.factor | 10 +++++++++-
1 file changed, 9 insertions(+), 1 deletion(-)
diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor
index f712e17afe..a524168d54 100755
--- a/extra/irc/ui/ui.factor
+++ b/extra/irc/ui/ui.factor
@@ -76,6 +76,14 @@ M: quit write-irc
" has left IRC" dark-red write-color
trailing>> dot-or-parens dark-red write-color ;
+M: kick write-irc
+ "* " dark-red write-color
+ [ prefix>> parse-name write ] keep
+ " has kicked " dark-red write-color
+ [ who>> write ] keep
+ " from the channel" dark-red write-color
+ trailing>> dot-or-parens dark-red write-color ;
+
: full-mode ( message -- mode )
parameters>> rest " " sjoin ;
@@ -126,7 +134,7 @@ M: irc-message write-irc
GENERIC: handle-inbox ( tab message -- )
: value-labels ( assoc val -- seq )
- '[ nip , = ] assoc-filter keys [ string<=> ] sort [ <label> ] map ;
+ '[ nip , = ] assoc-filter keys sort-strings [ <label> ] map ;
: add-gadget-color ( pack seq color -- pack )
'[ , >>color add-gadget ] each ;
From 6dff5fcc6afe1601ecbe6931a24be7957766a2c2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 4 Aug 2008 15:03:54 -0500
Subject: [PATCH 10/10] Cleanup
---
extra/html/streams/streams.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/html/streams/streams.factor b/extra/html/streams/streams.factor
index 76719b6ffa..d21c743dcd 100755
--- a/extra/html/streams/streams.factor
+++ b/extra/html/streams/streams.factor
@@ -50,8 +50,8 @@ TUPLE: html-sub-stream < html-stream style parent ;
] [ call ] if* ; inline
: hex-color, ( color -- )
- { [ red>> ] [ green>> ] [ blue>> ] } cleave 3array
- [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
+ [ red>> ] [ green>> ] [ blue>> ] tri
+ [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] tri@ ;
: fg-css, ( color -- )
"color: #" % hex-color, "; " % ;