Merge git://factorcode.org/git/factor

core/bootstrap/image/image.factor

@@ -136,7 +136,7 @@ SYMBOL: undefined-quot
 : here-as ( tag -- pointer ) here swap bitor ;
 
 : align-here ( -- )
-    here 8 mod 4 = [ 0 emit ] when ;
+    here 8 mod 4 = [ heap-size drop 0 emit ] when ;
 
 : emit-fixnum ( n -- ) tag-fixnum emit ;
 
@@ -177,6 +177,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
@@ -214,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 -- )
@@ -385,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
@@ -400,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
 
@@ -411,28 +412,23 @@ M: curry '
         [ >le write ] curry each
     ] if ;
 
-: write-image ( image filename -- )
+: write-image ( image -- )
-    "Writing image to " write dup write "..." print flush
+    "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
-        begin-image
+        bootstrapping? on
+        load-help? off
         "resource:/core/bootstrap/stage1.factor" run-file
-        end-image
+        build-image
-        image get
-        architecture get boot-image-name resource-path
         write-image
-    ] with-variable ;
+    ] with-scope ;
 
 : make-images ( -- )
     images [ make-image ] each ;

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

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{

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

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

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) %

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
+M: lapse set-timeout set-lapse-timeout ;
-    2dup
-    duplex-stream-in set-timeout
-    duplex-stream-out set-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 -- ? )

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 ;

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
+    [ [ log-error ] curry ] keep
-    [ >r log-error r> ndrop ] 2curry
+    [ stack-effect ] keep stack-balancer compose
     [ recover ] 2curry ;
 
 : add-error-logging ( word level -- )

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) ] }

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

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 ;
 

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 ;
 

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 ;
 

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>
+    dup 0 <column> swap 1 <column>
-    swap [ fetch-feed ] parallel-map
+    [ 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/" }

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;
+void find_data_references(CELL look_for)
-CELL look_for;
-
-void find_references_step(CELL *scan)
 {
-	if(look_for == *scan)
+	CELL obj;
+
+	void find_references_step(CELL *scan)
 	{
-		printf("%lx ",obj);
+		if(look_for == *scan)
-		print_nested_obj(obj,1);
+		{
-		printf("\n");
+			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)
-	while((obj_ = next_object()) != F)
+		do_slots(UNTAG(obj),find_references_step);
-	{
-		obj = obj_;
-		do_slots(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

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

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();