From 4231bdb55849cac662d7d762511f17e833e087cc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 23:13:55 -0800
Subject: [PATCH 01/12] Fix 64-bit port
---
core/cpu/x86/64/64.factor | 3 ++-
core/cpu/x86/architecture/architecture.factor | 2 +-
2 files changed, 3 insertions(+), 2 deletions(-)
diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor
index 745b6efd2d..2996a3feeb 100755
--- a/core/cpu/x86/64/64.factor
+++ b/core/cpu/x86/64/64.factor
@@ -4,7 +4,8 @@ USING: alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture kernel kernel.private math
namespaces sequences generator.registers generator.fixup system
-alien alien.compiler alien.structs slots splitting assocs ;
+alien alien.accessors alien.compiler alien.structs slots
+splitting assocs ;
IN: cpu.x86.64
PREDICATE: x86-backend amd64-backend
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 20564bbde3..49b05ea48f 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -96,7 +96,7 @@ M: x86-backend %dispatch ( -- )
"n" operand "offset" operand ADD
"n" operand HEX: 7f [+] JMP
! Fix up the displacement above
- code-alignment dup bootstrap-cell 8 = 14 9 ? +
+ code-alignment dup bootstrap-cell 8 = 15 9 ? +
building get dup pop* push
align-code
] H{
From ce1602bc2c989fe6257998a61af0cba61624c502 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:34:16 -0600
Subject: [PATCH 02/12] Fix 64-bit bootstrap
---
core/bootstrap/image/image.factor | 11 +++++++----
1 file changed, 7 insertions(+), 4 deletions(-)
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index 7452e31cf8..9fb80da948 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -135,8 +135,10 @@ SYMBOL: undefined-quot
: here-as ( tag -- pointer ) here swap bitor ;
+USE: continuations
+
: align-here ( -- )
- here 8 mod 4 = [ 0 emit ] when ;
+ here 8 mod 4 = [ break heap-size drop 0 emit ] when ;
: emit-fixnum ( n -- ) tag-fixnum emit ;
@@ -177,6 +179,7 @@ GENERIC: ' ( obj -- ptr )
[ dup bignum-bits neg shift swap bignum-radix bitand ]
[ ] unfold nip ;
+USE: continuations
: emit-bignum ( n -- )
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
dup length 1+ emit-fixnum
@@ -215,8 +218,8 @@ M: f '
: -1, -1 >bignum ' -1-offset fixup ;
! Beginning of the image
-
-: begin-image ( -- ) emit-header t, 0, 1, -1, ;
+: begin-image ( -- )
+ emit-header t, 0, 1, -1, ;
! Words
@@ -426,8 +429,8 @@ PRIVATE>
: make-image ( arch -- )
architecture [
prepare-image
- begin-image
"resource:/core/bootstrap/stage1.factor" run-file
+ begin-image
end-image
image get
architecture get boot-image-name resource-path
From 765f9bfb43f122210e93ab27e82a3ceb0141be80 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:34:26 -0600
Subject: [PATCH 03/12] Fix regression
---
core/inference/backend/backend.factor | 1 +
core/inference/inference-tests.factor | 5 +++++
2 files changed, 6 insertions(+)
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index b839b047d6..ba65d2508c 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -370,6 +370,7 @@ TUPLE: effect-error word effect ;
init-inference
dependencies off
dup word-def over dup infer-quot-recursive
+ end-infer
finish-word
current-effect
] with-scope
diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor
index 2691be8c3a..7a4176abfb 100755
--- a/core/inference/inference-tests.factor
+++ b/core/inference/inference-tests.factor
@@ -537,3 +537,8 @@ TUPLE: custom-error ;
! This was a false trigger of the undecidable quotation
! recursion bug
{ 2 1 } [ find-last-sep ] must-infer-as
+
+! Regression
+: missing->r-check >r ;
+
+[ [ missing->r-check ] infer ] must-fail
From 6bf808172b707e8b13a295796db6bdf9f807e335 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:38:51 -0600
Subject: [PATCH 04/12] Add watch-vars
---
extra/tools/annotations/annotations.factor | 13 ++++++++++++-
1 file changed, 12 insertions(+), 1 deletion(-)
diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor
index 6dee51cbc0..eed23e8bc1 100755
--- a/extra/tools/annotations/annotations.factor
+++ b/extra/tools/annotations/annotations.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words parser io inspector quotations sequences
-prettyprint continuations effects definitions compiler.units ;
+prettyprint continuations effects definitions compiler.units
+namespaces assocs ;
IN: tools.annotations
: reset ( word -- )
@@ -49,6 +50,16 @@ IN: tools.annotations
: watch ( word -- )
dup [ (watch) ] annotate ;
+: (watch-vars) ( quot word vars -- newquot )
+ [
+ "--- Entering: " write swap .
+ "--- Variable values:" print
+ [ dup get ] H{ } map>assoc describe
+ ] 2curry swap compose ;
+
+: watch-vars ( word vars -- )
+ dupd [ (watch-vars) ] 2curry annotate ;
+
: breakpoint ( word -- )
[ \ break add* ] annotate ;
From f052852a274092f89cd682e2174b6173004946b2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:38:58 -0600
Subject: [PATCH 05/12] Fix must-fail-with
---
extra/tools/test/test.factor | 8 +-------
1 file changed, 1 insertion(+), 7 deletions(-)
diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor
index 0b5e436e44..5673e41c62 100755
--- a/extra/tools/test/test.factor
+++ b/extra/tools/test/test.factor
@@ -40,14 +40,8 @@ SYMBOL: this-test
dup word? [ 1quotation ] when
[ infer drop ] curry [ ] swap unit-test ;
-TUPLE: expected-error ;
-
-M: expected-error summary
- drop
- "The unit test expected the quotation to throw an error" ;
-
: must-fail-with ( quot pred -- )
- >r [ expected-error construct-empty throw ] compose r>
+ >r [ f ] compose r>
[ recover ] 2curry
[ t ] swap unit-test ;
From b120abcee28427e014800ea50825d66e632fa260 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:39:21 -0600
Subject: [PATCH 06/12] Fix duplex-stream set-timeout
---
extra/io/timeouts/timeouts.factor | 19 ++++++++++++++-----
1 file changed, 14 insertions(+), 5 deletions(-)
diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor
index ddc92a4bdd..001f59368e 100755
--- a/extra/io/timeouts/timeouts.factor
+++ b/extra/io/timeouts/timeouts.factor
@@ -8,15 +8,14 @@ TUPLE: lapse entry timeout cutoff ;
: <lapse> f 0 0 \ lapse construct-boa ;
+! Won't need this with new slot accessors
GENERIC: get-lapse ( obj -- lapse )
+
GENERIC: set-timeout ( ms obj -- )
-M: object set-timeout get-lapse set-lapse-timeout ;
+M: object set-timeout get-lapse set-timeout ;
-M: duplex-stream set-timeout
- 2dup
- duplex-stream-in set-timeout
- duplex-stream-out set-timeout ;
+M: lapse set-timeout set-lapse-timeout ;
: timeout ( obj -- ms ) get-lapse lapse-timeout ;
: entry ( obj -- dlist-node ) get-lapse lapse-entry ;
@@ -24,6 +23,16 @@ M: duplex-stream set-timeout
: cutoff ( obj -- ms ) get-lapse lapse-cutoff ;
: set-cutoff ( ms obj -- ) get-lapse set-lapse-cutoff ;
+! Won't need this with inheritance
+TUPLE: duplex-stream-lapse stream ;
+
+M: duplex-stream-lapse set-timeout
+ duplex-stream-lapse-stream 2dup
+ duplex-stream-in set-timeout
+ duplex-stream-out set-timeout ;
+
+M: duplex-stream get-lapse duplex-stream-lapse construct-boa ;
+
SYMBOL: timeout-queue
: timeout? ( lapse -- ? )
From 619d676af6baae569e33ff4fa981d997bdc130a2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:39:37 -0600
Subject: [PATCH 07/12] logging.server fixes
---
extra/logging/insomniac/insomniac.factor | 2 +-
extra/logging/logging.factor | 10 +++++++---
extra/logging/server/server.factor | 2 +-
3 files changed, 9 insertions(+), 5 deletions(-)
diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor
index d79eca3495..09c6763657 100755
--- a/extra/logging/insomniac/insomniac.factor
+++ b/extra/logging/insomniac/insomniac.factor
@@ -42,7 +42,7 @@ SYMBOL: insomniac-recipients
: email-log-report ( service word-names -- )
"logging.insomniac" [ (email-log-report) ] with-logging ;
-: schedule-insomniac ( alist -- )
+: schedule-insomniac ( service word-names -- )
{ 25 } { 6 } f f f <when> -rot [
[ email-log-report ] assoc-each rotate-logs
] 2curry schedule ;
diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor
index d4f0bd1fbf..fec0c3660f 100755
--- a/extra/logging/logging.factor
+++ b/extra/logging/logging.factor
@@ -4,7 +4,7 @@ USING: logging.server sequences namespaces concurrency
words kernel arrays shuffle tools.annotations
prettyprint.config prettyprint debugger io.streams.string
splitting continuations effects arrays.lib parser strings
-combinators.lib ;
+combinators.lib quotations ;
IN: logging
SYMBOL: DEBUG
@@ -112,9 +112,13 @@ PRIVATE>
: log-critical ( error word -- ) CRITICAL (log-error) ;
+: stack-balancer ( effect word -- quot )
+ >r dup effect-in length r> [ over >r ERROR log-stack r> ndrop ] 2curry
+ swap effect-out length f <repetition> append >quotation ;
+
: error-logging-quot ( quot word -- quot' )
- dup stack-effect effect-in length
- [ >r log-error r> ndrop ] 2curry
+ [ [ log-error ] curry ] keep
+ [ stack-effect ] keep stack-balancer compose
[ recover ] 2curry ;
: add-error-logging ( word level -- )
diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor
index 198ae47a79..05029df1d0 100755
--- a/extra/logging/server/server.factor
+++ b/extra/logging/server/server.factor
@@ -84,7 +84,7 @@ SYMBOL: log-files
(close-logs)
log-root directory [ drop rotate-log ] assoc-each ;
-: log-server-loop
+: log-server-loop ( -- )
[
receive unclip {
{ "log-message" [ (log-message) ] }
From 4514971c7bc8d9d4aa6a40a774ab4c5fcf8de73b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:39:48 -0600
Subject: [PATCH 08/12] webapps.planet fix
---
extra/webapps/planet/planet.factor | 7 ++-----
1 file changed, 2 insertions(+), 5 deletions(-)
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index a9fd443fe6..3e008d049d 100755
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -86,8 +86,8 @@ SYMBOL: last-update
\ fetch-feed DEBUG add-error-logging
: fetch-blogroll ( blogroll -- entries )
- dup 0 <column>
- swap [ fetch-feed ] parallel-map
+ dup 0 <column> swap 1 <column>
+ [ fetch-feed ] parallel-map
[ [ <posting> ] with map ] 2map concat ;
: sort-entries ( entries -- entries' )
@@ -120,9 +120,6 @@ SYMBOL: last-update
{ "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
{ "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
{ "Gavin Harrison" "http://gmh33.blogspot.com/feeds/posts/default" "http://gmh33.blogspot.com/" }
- { "Kevin Marshall"
- "http://blog.botfu.com/?cat=9&feed=atom"
- "http://blog.botfu.com/" }
{ "Kio M. Smallwood"
"http://sekenre.wordpress.com/feed/atom/"
"http://sekenre.wordpress.com/" }
From ab63c7254cf44275f216dc048905158fcc1b3bca Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:40:02 -0600
Subject: [PATCH 09/12] Improved left/right arrow keys in editor gadget
---
extra/ui/gadgets/editors/editors.factor | 16 ++++++++++++++--
1 file changed, 14 insertions(+), 2 deletions(-)
diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor
index e2df6a343b..a6674aef5f 100755
--- a/extra/ui/gadgets/editors/editors.factor
+++ b/extra/ui/gadgets/editors/editors.factor
@@ -363,9 +363,21 @@ editor "clipboard" f {
{ T{ cut-action } cut }
} define-command-map
-: previous-character T{ char-elt } editor-prev ;
+: previous-character ( editor -- )
+ dup gadget-selection? [
+ dup selection-start/end drop
+ over set-caret mark>caret
+ ] [
+ T{ char-elt } editor-prev
+ ] if ;
-: next-character T{ char-elt } editor-next ;
+: next-character ( editor -- )
+ dup gadget-selection? [
+ dup selection-start/end nip
+ over set-caret mark>caret
+ ] [
+ T{ char-elt } editor-next
+ ] if ;
: previous-line T{ line-elt } editor-prev ;
From 2ecd1ba127ab1144448c553aef6984bef89d6219 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:40:17 -0600
Subject: [PATCH 10/12] Improve ratio syntax
---
core/math/parser/parser.factor | 11 +++++++----
extra/math/ratios/ratios-tests.factor | 2 +-
2 files changed, 8 insertions(+), 5 deletions(-)
diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor
index 64ce296a0b..68c4768c87 100755
--- a/core/math/parser/parser.factor
+++ b/core/math/parser/parser.factor
@@ -41,6 +41,9 @@ DEFER: base>
<PRIVATE
SYMBOL: radix
+SYMBOL: negative?
+
+: sign negative? get "-" "+" ? ;
: with-radix ( radix quot -- )
radix swap with-variable ; inline
@@ -48,7 +51,7 @@ SYMBOL: radix
: (base>) ( str -- n ) radix get base> ;
: whole-part ( str -- m n )
- "+" split1 >r (base>) r>
+ sign split1 >r (base>) r>
dup [ (base>) ] [ drop 0 swap ] if ;
: string>ratio ( str -- a/b )
@@ -70,7 +73,7 @@ PRIVATE>
: base> ( str radix -- n/f )
[
- "-" ?head >r
+ "-" ?head dup negative? set >r
{
{ [ CHAR: / over member? ] [ string>ratio ] }
{ [ CHAR: . over member? ] [ string>float ] }
@@ -114,9 +117,9 @@ M: integer >base
M: ratio >base
[
[
- dup 0 < [ "-" % neg ] when
+ dup 0 < dup negative? set [ "-" % neg ] when
1 /mod
- >r dup zero? [ drop ] [ (>base) % "+" % ] if r>
+ >r dup zero? [ drop ] [ (>base) % sign % ] if r>
dup numerator (>base) %
"/" %
denominator (>base) %
diff --git a/extra/math/ratios/ratios-tests.factor b/extra/math/ratios/ratios-tests.factor
index 858a7b0544..4dba49b908 100755
--- a/extra/math/ratios/ratios-tests.factor
+++ b/extra/math/ratios/ratios-tests.factor
@@ -107,6 +107,6 @@ unit-test
unit-test
[ 3 ] [ "1+1/2" string>number 2 * ] unit-test
-[ -3 ] [ "-1+1/2" string>number 2 * ] unit-test
+[ -3 ] [ "-1-1/2" string>number 2 * ] unit-test
[ "2+1/7" ] [ 1 7 / 2 + number>string ] unit-test
[ "1/8" ] [ 1 8 / number>string ] unit-test
From 125e949200e296865587036f3afa154d85714885 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:40:51 -0600
Subject: [PATCH 11/12] Add new "refs" command to FEP, finds references to an
object
---
vm/debug.c | 91 +++++++++++++++++++++++++++++++++++++++--------------
vm/debug.h | 2 +-
vm/factor.c | 4 +--
3 files changed, 70 insertions(+), 27 deletions(-)
mode change 100644 => 100755 vm/debug.h
diff --git a/vm/debug.c b/vm/debug.c
index 01e1ab0f43..a080a6cab2 100755
--- a/vm/debug.c
+++ b/vm/debug.c
@@ -21,7 +21,7 @@ void print_word(F_WORD* word, CELL nesting)
else
{
printf("#<not a string: ");
- print_nested_obj(word->name,nesting - 1);
+ print_nested_obj(word->name,nesting);
printf(">");
}
}
@@ -44,13 +44,13 @@ void print_array(F_ARRAY* array, CELL nesting)
for(i = 0; i < length; i++)
{
printf(" ");
- print_nested_obj(array_nth(array,i),nesting - 1);
+ print_nested_obj(array_nth(array,i),nesting);
}
}
-void print_nested_obj(CELL obj, CELL nesting)
+void print_nested_obj(CELL obj, F_FIXNUM nesting)
{
- if(nesting == 0)
+ if(nesting <= 0)
{
printf(" ... ");
return;
@@ -204,7 +204,7 @@ void dump_objects(F_FIXNUM type)
if(type == -1 || type_of(obj) == type)
{
printf("%lx ",obj);
- print_nested_obj(obj,1);
+ print_nested_obj(obj,2);
printf("\n");
}
}
@@ -213,36 +213,58 @@ void dump_objects(F_FIXNUM type)
gc_off = false;
}
-CELL obj;
-CELL look_for;
-
-void find_references_step(CELL *scan)
+void find_data_references(CELL look_for)
{
- if(look_for == *scan)
+ CELL obj;
+
+ void find_references_step(CELL *scan)
{
- printf("%lx ",obj);
- print_nested_obj(obj,1);
- printf("\n");
+ if(look_for == *scan)
+ {
+ printf("%lx ",obj);
+ print_nested_obj(obj,2);
+ printf("\n");
+ }
}
-}
-
-void find_references(CELL look_for_)
-{
- look_for = look_for_;
begin_scan();
- CELL obj_;
- while((obj_ = next_object()) != F)
- {
- obj = obj_;
- do_slots(obj_,find_references_step);
- }
+ while((obj = next_object()) != F)
+ do_slots(UNTAG(obj),find_references_step);
/* end scan */
gc_off = false;
}
+void find_code_references(CELL look_for)
+{
+ void find_references_step(F_COMPILED *compiled, CELL code_start,
+ CELL reloc_start, CELL literals_start)
+ {
+ CELL scan;
+ CELL literal_end = literals_start + compiled->literals_length;
+
+ for(scan = literals_start; scan < literal_end; scan += CELLS)
+ {
+ CELL code_start = (CELL)(compiled + 1);
+ CELL literal_start = code_start
+ + compiled->code_length
+ + compiled->reloc_length;
+
+ CELL obj = get(literal_start);
+
+ if(look_for == get(scan))
+ {
+ printf("%lx ",obj);
+ print_nested_obj(obj,2);
+ printf("\n");
+ }
+ }
+ }
+
+ iterate_code_heap(find_references_step);
+}
+
void factorbug(void)
{
reset_stdio();
@@ -265,6 +287,9 @@ void factorbug(void)
printf("addr <card> -- print address containing card\n");
printf("data -- data heap dump\n");
printf("words -- words dump\n");
+ printf("tuples -- tuples dump\n");
+ printf("refs <addr> -- find data heap references to object\n");
+ printf("push <addr> -- push object on data stack - NOT SAFE\n");
printf("code -- code heap dump\n");
for(;;)
@@ -335,8 +360,26 @@ void factorbug(void)
save_image(STR_FORMAT("fep.image"));
else if(strcmp(cmd,"data") == 0)
dump_objects(-1);
+ else if(strcmp(cmd,"refs") == 0)
+ {
+ CELL addr;
+ scanf("%lx",&addr);
+ printf("Data heap references:\n");
+ find_data_references(addr);
+ printf("Code heap references:\n");
+ find_code_references(addr);
+ printf("\n");
+ }
else if(strcmp(cmd,"words") == 0)
dump_objects(WORD_TYPE);
+ else if(strcmp(cmd,"tuples") == 0)
+ dump_objects(TUPLE_TYPE);
+ else if(strcmp(cmd,"push") == 0)
+ {
+ CELL addr;
+ scanf("%lx",&addr);
+ dpush(addr);
+ }
else if(strcmp(cmd,"code") == 0)
dump_heap(&code_heap);
else
diff --git a/vm/debug.h b/vm/debug.h
old mode 100644
new mode 100755
index cfd928bb51..ff8075c457
--- a/vm/debug.h
+++ b/vm/debug.h
@@ -1,5 +1,5 @@
void print_obj(CELL obj);
-void print_nested_obj(CELL obj, CELL nesting);
+void print_nested_obj(CELL obj, F_FIXNUM nesting);
void dump_generations(void);
void factorbug(void);
diff --git a/vm/factor.c b/vm/factor.c
index 0754067b95..826ad65324 100755
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -154,6 +154,8 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
init_factor(&p);
+ nest_stacks();
+
F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F);
for(i = 1; i < argc; i++)
@@ -173,8 +175,6 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
userenv[EXECUTABLE_ENV] = tag_object(from_native_string(executable_path));
userenv[EMBEDDED_ENV] = (embedded ? T : F);
- nest_stacks();
-
if(p.console)
open_console();
From d8edd7b0d4e3360ded930d2d8ab78d9aa02b8723 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:49:27 -0600
Subject: [PATCH 12/12] Clean up bootstrap.image
---
core/bootstrap/image/image.factor | 41 +++++++++++++------------------
1 file changed, 17 insertions(+), 24 deletions(-)
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index 9fb80da948..4468ecf7d1 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -135,10 +135,8 @@ SYMBOL: undefined-quot
: here-as ( tag -- pointer ) here swap bitor ;
-USE: continuations
-
: align-here ( -- )
- here 8 mod 4 = [ break heap-size drop 0 emit ] when ;
+ here 8 mod 4 = [ heap-size drop 0 emit ] when ;
: emit-fixnum ( n -- ) tag-fixnum emit ;
@@ -217,10 +215,6 @@ M: f '
: 1, 1 >bignum ' 1-offset fixup ;
: -1, -1 >bignum ' -1-offset fixup ;
-! Beginning of the image
-: begin-image ( -- )
- emit-header t, 0, 1, -1, ;
-
! Words
: emit-word ( word -- )
@@ -388,7 +382,10 @@ M: curry '
: fixup-header ( -- )
heap-size data-heap-size-offset fixup ;
-: end-image ( -- )
+: build-image ( -- image )
+ 800000 <vector> image set
+ 20000 <hashtable> objects set
+ emit-header t, 0, 1, -1,
"Serializing words..." print flush
emit-words
"Serializing JIT data..." print flush
@@ -403,7 +400,8 @@ M: curry '
fixup-header
"Image length: " write image get length .
"Object cache size: " write objects get assoc-size .
- \ word global delete-at ;
+ \ word global delete-at
+ image get ;
! Image output
@@ -414,28 +412,23 @@ M: curry '
[ >le write ] curry each
] if ;
-: write-image ( image filename -- )
- "Writing image to " write dup write "..." print flush
+: write-image ( image -- )
+ "Writing image to " write
+ architecture get boot-image-name resource-path
+ dup write "..." print flush
<file-writer> [ (write-image) ] with-stream ;
-: prepare-image ( -- )
- bootstrapping? on
- load-help? off
- 800000 <vector> image set
- 20000 <hashtable> objects set ;
-
PRIVATE>
: make-image ( arch -- )
- architecture [
- prepare-image
+ [
+ architecture set
+ bootstrapping? on
+ load-help? off
"resource:/core/bootstrap/stage1.factor" run-file
- begin-image
- end-image
- image get
- architecture get boot-image-name resource-path
+ build-image
write-image
- ] with-variable ;
+ ] with-scope ;
: make-images ( -- )
images [ make-image ] each ;