Merge branch 'master' of git://factorcode.org/git/factor

Nmakefile

@@ -0,0 +1,65 @@
+LINK_CLFAGS =
+CL_FLAGS = /O2 /W3
+
+OBJS = vm\main-windows-nt.obj \
+	vm\os-windows-nt.obj \
+	vm\os-windows.obj \
+	vm\aging_collector.obj \
+	vm\alien.obj \
+	vm\arrays.obj \
+	vm\bignum.obj \
+	vm\booleans.obj \
+	vm\byte_arrays.obj \
+	vm\callbacks.obj \
+	vm\callstack.obj \
+	vm\code_blocks.obj \
+	vm\code_heap.obj \
+	vm\compaction.obj \
+	vm\contexts.obj \
+	vm\data_heap.obj \
+	vm\data_heap_checker.obj \
+	vm\debug.obj \
+	vm\dispatch.obj \
+	vm\entry_points.obj \
+	vm\errors.obj \
+	vm\factor.obj \
+	vm\free_list.obj \
+	vm\full_collector.obj \
+	vm\gc.obj \
+	vm\image.obj \
+	vm\inline_cache.obj \
+	vm\instruction_operands.obj \
+	vm\io.obj \
+	vm\jit.obj \
+	vm\math.obj \
+	vm\nursery_collector.obj \
+	vm\object_start_map.obj \
+	vm\objects.obj \
+	vm\primitives.obj \
+	vm\profiler.obj \
+	vm\quotations.obj \
+	vm\run.obj \
+	vm\strings.obj \
+	vm\to_tenured_collector.obj \
+	vm\tuples.obj \
+	vm\utilities.obj \
+        vm\vm.obj \
+	vm\words.obj
+
+.cpp.obj:
+	cl /nologo /EHsc $(CL_FLAGS) /Fo$@ /c $<
+
+all: factor.com factor.exe
+
+factor.com: $(OBJS)
+	link $(LINK_FLAGS) /nologo /out:factor.com /SUBSYSTEM:console $(OBJS)
+
+factor.exe: $(OBJS)
+	link $(LINK_FLAGS) /nologo /out:factor.exe /SUBSYSTEM:windows $(OBJS)
+
+clean:
+	del vm\*.obj
+	del factor.com
+	del factor.exe
+
+.PHONY: clean

basis/compiler/tree/propagation/info/info.factor

@@ -312,16 +312,12 @@ SYMBOL: value-infos
     value-info >literal< ;
 
 : possible-boolean-values ( info -- values )
-    dup literal?>> [
+    class>> {
-        literal>> 1array
+        { [ dup null-class? ] [ { } ] }
-    ] [
+        { [ dup true-class? ] [ { t } ] }
-        class>> {
+        { [ dup false-class? ] [ { f } ] }
-            { [ dup null-class? ] [ { } ] }
+        [ { t f } ]
-            { [ dup true-class? ] [ { t } ] }
+    } cond nip ;
-            { [ dup false-class? ] [ { f } ] }
-            [ { t f } ]
-        } cond nip
-    ] if ;
 
 : node-value-info ( node value -- info )
     swap info>> at* [ drop null-info ] unless ;

basis/compiler/tree/propagation/propagation-tests.factor

@@ -946,3 +946,9 @@ M: tuple-with-read-only-slot clone
 
 [ t ] [ [ { float float } declare max ] { max } inlined? ] unit-test
 [ f ] [ [ { float float } declare max ] { float-max } inlined? ] unit-test
+
+! Propagation should not call equal?, hashcode, etc on literals in user code
+[ V{ } ] [ [ 4 <reversed> [ 2drop ] with each ] final-info ] unit-test
+
+! Reduction
+[ 1 ] [ [ 4 <reversed> [ nth-unsafe ] [ ] unless ] final-info length ] unit-test

basis/io/buffers/buffers-tests.factor

@@ -58,3 +58,7 @@ strings accessors destructors ;
 100 <buffer> "b" set
 [ 1000 "b" get n>buffer >string ] must-fail
 "b" get dispose
+
+"hello world" string>buffer "b" set
+[ "hello" CHAR: \s ] [ " " "b" get buffer-until [ >string ] dip ] unit-test
+"b" get dispose

basis/io/buffers/buffers.factor

@@ -1,5 +1,5 @@
 ! Copyright (C) 2004, 2005 Mackenzie Straight.
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.accessors alien.c-types
 alien.data alien.syntax kernel libc math sequences byte-arrays
@@ -73,7 +73,9 @@ HINTS: >buffer byte-array buffer ;
     bi ; inline
 
 : search-buffer-until ( pos fill ptr separators -- n )
-    [ [ swap alien-unsigned-1 ] dip member-eq? ] 2curry find-from drop ; inline
+    [ iota ] 2dip
+    [ [ swap alien-unsigned-1 ] dip member-eq? ] 2curry
+    find-from drop ; inline
 
 : finish-buffer-until ( buffer n -- byte-array separator )
     [

basis/io/files/info/windows/windows.factor

@@ -162,7 +162,7 @@ M: winnt file-system-info ( path -- file-system-info )
         ret win32-error-string throw
     ] [
         names names-length *uint ushort heap-size * head
-        utf16n alien>string CHAR: \0 split
+        utf16n alien>string { CHAR: \0 } split
     ] if ;
 
 : find-first-volume ( -- string handle )

basis/specialized-arrays/specialized-arrays.factor

@@ -30,7 +30,6 @@ M: bad-byte-array-length summary
 FUNCTOR: define-array ( T -- )
 
 A            DEFINES-CLASS ${T}-array
-S            DEFINES-CLASS ${T}-sequence
 <A>          DEFINES <${A}>
 (A)          DEFINES (${A})
 <direct-A>   DEFINES <direct-${A}>
@@ -46,8 +45,6 @@ SET-NTH      [ T dup c-setter array-accessor ]
 
 WHERE
 
-MIXIN: S
-
 TUPLE: A
 { underlying c-ptr read-only }
 { length array-capacity read-only } ;

basis/specialized-vectors/specialized-vectors.factor

@@ -15,7 +15,6 @@ FUNCTOR: define-vector ( T -- )
 V   DEFINES-CLASS ${T}-vector
 
 A   IS      ${T}-array
-S   IS      ${T}-sequence
 <A> IS      <${A}>
 
 >V  DEFERS >${V}
@@ -38,7 +37,6 @@ M: V pprint* pprint-object ;
 SYNTAX: V{ \ } [ >V ] parse-literal ;
 
 INSTANCE: V growable
-INSTANCE: V S
 
 ;FUNCTOR
 

basis/ui/gadgets/search-tables/search-tables-tests.factor

@@ -1,3 +1,7 @@
 IN: ui.gadgets.search-tables.tests
-USING: ui.gadgets.search-tables sequences tools.test ;
+USING: ui.gadgets.search-tables ui.gadgets.tables ui.gadgets models
+arrays sequences tools.test ;
+
 [ [ second ] <search-table> ] must-infer
+
+[ t ] [ f <model> trivial-renderer [ second ] <search-table> pref-dim pair? ] unit-test

basis/ui/gadgets/search-tables/search-tables.factor

@@ -51,7 +51,6 @@ renderer
 action
 hook
 font
-gap
 selection-color
 focus-border-color
 mouse-color

build-support/cleanup

@@ -3,6 +3,7 @@ temp
 logs
 .git
 .gitignore
-Makefile
+GNUmakefile
+Nmakefile
 unmaintained
 build-support

build-support/factor.sh

@@ -406,9 +406,9 @@ backup_factor() {
 }
 
 check_makefile_exists() {
-    if [[ ! -e "Makefile" ]] ; then
+    if [[ ! -e "GNUmakefile" ]] ; then
         echo ""
-        echo "***Makefile not found***"
+        echo "***GNUmakefile not found***"
         echo "You are likely in the wrong directory."
         echo "Run this script from your factor directory:"
         echo "     ./build-support/factor.sh"

core/classes/tuple/tuple-tests.factor

@@ -6,7 +6,7 @@ io.streams.string kernel kernel.private math math.constants
 math.order namespaces parser parser.notes prettyprint
 quotations random see sequences sequences.private slots
 slots.private splitting strings summary threads tools.test
-vectors vocabs words words.symbol fry ;
+vectors vocabs words words.symbol fry literals ;
 IN: classes.tuple.tests
 
 TUPLE: rect x y w h ;
@@ -577,8 +577,31 @@ unit-test
 [ T{ bad-slot-value f "hi" fixnum } = ]
 must-fail-with
 
-[ T{ declared-types f 0 "hi" } ]
+! Check fixnum coercer
-[ 0.0 "hi" declared-types boa ] unit-test
+[ 0 ] [ 0.0 "hi" declared-types boa n>> ] unit-test
+
+[ 0 ] [ declared-types new 0.0 >>n n>> ] unit-test
+
+! Check bignum coercer
+TUPLE: bignum-coercer { n bignum initial: $[ 0 >bignum ] } ;
+
+[ 13 bignum ] [ 13.5 bignum-coercer boa n>> dup class ] unit-test
+
+[ 13 bignum ] [ bignum-coercer new 13.5 >>n n>> dup class ] unit-test
+
+! Check float coercer
+TUPLE: float-coercer { n float } ;
+
+[ 13.0 float ] [ 13 float-coercer boa n>> dup class ] unit-test
+
+[ 13.0 float ] [ float-coercer new 13 >>n n>> dup class ] unit-test
+
+! Check integer coercer
+TUPLE: integer-coercer { n integer } ;
+
+[ 13 fixnum ] [ 13.5 integer-coercer boa n>> dup class ] unit-test
+
+[ 13 fixnum ] [ integer-coercer new 13.5 >>n n>> dup class ] unit-test
 
 : foo ( a b -- c ) declared-types boa ;
 

core/classes/tuple/tuple.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays definitions hashtables kernel kernel.private math
 namespaces make sequences sequences.private strings vectors
@@ -121,25 +121,6 @@ ERROR: bad-superclass class ;
 : class-size ( class -- n )
     superclasses [ "slots" word-prop length ] map-sum ;
 
-: (instance-check-quot) ( class -- quot )
-    [
-        \ dup ,
-        [ "predicate" word-prop % ]
-        [ [ literalize , \ bad-slot-value , ] [ ] make , ] bi
-        \ unless ,
-    ] [ ] make ;
-
-: (fixnum-check-quot) ( class -- quot )
-    (instance-check-quot) fixnum "coercer" word-prop prepend ;
-
-: instance-check-quot ( class -- quot )
-    {
-        { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
-        { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
-        { [ dup \ fixnum class<= ] [ (fixnum-check-quot) ] }
-        [ (instance-check-quot) ]
-    } cond ;
-
 : boa-check-quot ( class -- quot )
     all-slots [ class>> instance-check-quot ] map spread>quot
     f like ;

core/io/files/files-tests.factor

@@ -1,8 +1,8 @@
 USING: arrays debugger.threads destructors io io.directories
-io.encodings.ascii io.encodings.binary
+io.encodings.ascii io.encodings.binary io.encodings.string
-io.files io.files.private io.files.temp io.files.unique kernel
+io.encodings.8-bit.latin1 io.files io.files.private
-make math sequences system threads tools.test generic.single
+io.files.temp io.files.unique kernel make math sequences system
-io.encodings.8-bit.latin1 ;
+threads tools.test generic.single ;
 IN: io.files.tests
 
 [ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
@@ -23,6 +23,20 @@ IN: io.files.tests
     [ read1 ] with-file-reader >fixnum
 ] unit-test
 
+[
+    "This" CHAR: \s
+] [
+    "vocab:io/test/read-until-test.txt" ascii
+    [ " " read-until ] with-file-reader
+] unit-test
+
+[
+    "This" CHAR: \s
+] [
+    "vocab:io/test/read-until-test.txt" binary
+    [ " " read-until [ ascii decode ] dip ] with-file-reader
+] unit-test
+
 [ ] [
     "It seems Jobs has lost his grasp on reality again.\n"
     "separator-test.txt" temp-file latin1 set-file-contents

core/io/test/read-until-test.txt

@@ -0,0 +1 @@
+This is a text file

core/slots/slots-tests.factor

@@ -1,5 +1,5 @@
 USING: math accessors slots strings generic.single kernel
-tools.test generic words parser eval math.functions ;
+tools.test generic words parser eval math.functions arrays ;
 IN: slots.tests
 
 TUPLE: r/w-test foo ;
@@ -8,9 +8,9 @@ TUPLE: r/o-test { foo read-only } ;
 
 [ r/o-test new 123 >>foo ] [ no-method? ] must-fail-with
 
-TUPLE: decl-test { foo integer } ;
+TUPLE: decl-test { foo array } ;
 
-[ decl-test new 1.0 >>foo ] [ bad-slot-value? ] must-fail-with
+[ decl-test new "" >>foo ] [ bad-slot-value? ] must-fail-with
 
 TUPLE: hello length ;
 

core/slots/slots.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays byte-arrays kernel kernel.private math namespaces
 make sequences strings effects generic generic.standard
@@ -64,39 +64,29 @@ M: object reader-quot
 
 ERROR: bad-slot-value value class ;
 
-: writer-quot/object ( slot-spec -- )
+: (instance-check-quot) ( class -- quot )
-    offset>> , \ set-slot , ;
-
-: writer-quot/coerce ( slot-spec -- )
-    [ class>> "coercer" word-prop [ dip ] curry % ]
-    [ offset>> , \ set-slot , ]
-    bi ;
-
-: writer-quot/check ( slot-spec -- )
-    [ offset>> , ]
     [
-        \ pick ,
+        \ dup ,
-        dup class>> "predicate" word-prop %
+        [ "predicate" word-prop % ]
-        [ set-slot ] ,
+        [ [ bad-slot-value ] curry , ] bi
-        class>> [ 2nip bad-slot-value ] curry [ ] like ,
+        \ unless ,
-        \ if ,
+    ] [ ] make ;
-    ]
-    bi ;
 
-: writer-quot/fixnum ( slot-spec -- )
+: instance-check-quot ( class -- quot )
-    [ [ >fixnum ] dip ] % writer-quot/check ;
+    {
+        { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
+        { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
+        { [ dup integer bootstrap-word eq? ] [ drop [ >integer ] ] }
+        [ (instance-check-quot) ]
+    } cond ;
 
 GENERIC# writer-quot 1 ( class slot-spec -- quot )
 
 M: object writer-quot
-    nip [
+    nip
-        {
+    [ class>> instance-check-quot dup empty? [ [ dip ] curry ] unless ]
-            { [ dup class>> object bootstrap-word eq? ] [ writer-quot/object ] }
+    [ offset>> [ set-slot ] curry ]
-            { [ dup class>> "coercer" word-prop ] [ writer-quot/coerce ] }
+    bi append ;
-            { [ dup class>> fixnum bootstrap-word class<= ] [ writer-quot/fixnum ] }
-            [ writer-quot/check ]
-        } cond
-    ] [ ] make ;
 
 : writer-props ( slot-spec -- assoc )
     "writing" associate ;

extra/furnace/mongodb/mongodb.factor

@@ -1,5 +1,5 @@
 USING: accessors http.server http.server.filters io.pools kernel
-mongodb.driver mongodb.connection namespaces unix destructors continuations ;
+mongodb.driver mongodb.connection namespaces ;
 
 IN: furnace.mongodb
 

vm/alien.cpp

@@ -109,7 +109,7 @@ void *factor_vm::alien_pointer()
 	PRIMITIVE(set_alien_##name) \
 	{ \
 		type *ptr = (type *)parent->alien_pointer(); \
-		type value = to(parent->ctx->pop(),parent); \
+		type value = (type)to(parent->ctx->pop(),parent); \
 		*ptr = value; \
 	}
 
@@ -151,7 +151,7 @@ void factor_vm::primitive_dlsym()
 	{
 		dll *d = untag_check<dll>(library.value());
 
-		if(d->dll == NULL)
+		if(d->handle == NULL)
 			ctx->push(false_object);
 		else
 			ctx->push(allot_alien(ffi_dlsym(d,sym)));
@@ -164,7 +164,7 @@ void factor_vm::primitive_dlsym()
 void factor_vm::primitive_dlclose()
 {
 	dll *d = untag_check<dll>(ctx->pop());
-	if(d->dll != NULL)
+	if(d->handle != NULL)
 		ffi_dlclose(d);
 }
 
@@ -172,7 +172,7 @@ void factor_vm::primitive_dll_validp()
 {
 	cell library = ctx->pop();
 	if(to_boolean(library))
-		ctx->push(tag_boolean(untag_check<dll>(library)->dll != NULL));
+		ctx->push(tag_boolean(untag_check<dll>(library)->handle != NULL));
 	else
 		ctx->push(true_object);
 }

vm/bitwise_hacks.hpp

@@ -4,8 +4,18 @@ namespace factor
 inline cell log2(cell x)
 {
 	cell n;
-#if defined(FACTOR_X86) || defined(FACTOR_AMD64)
+#if defined(FACTOR_X86)
-	asm ("bsr %1, %0;":"=r"(n):"r"(x));
+	#if defined(_MSC_VER)
+		_BitScanReverse(&n,x);
+	#else
+		asm ("bsr %1, %0;":"=r"(n):"r"(x));
+	#endif
+#elif defined(FACTOR_AMD64)
+	#if defined(_MSC_VER)
+		_BitScanReverse64(&n,x);
+	#else
+		asm ("bsr %1, %0;":"=r"(n):"r"(x));
+	#endif
 #elif defined(FACTOR_PPC)
 	asm ("cntlzw %1, %0;":"=r"(n):"r"(x));
 	n = (31 - n);
@@ -22,7 +32,7 @@ inline cell rightmost_clear_bit(cell x)
 
 inline cell rightmost_set_bit(cell x)
 {
-	return log2(x & -x);
+	return log2(x & (~x + 1));
 }
 
 inline cell popcount(cell x)

vm/code_blocks.cpp

@@ -159,7 +159,7 @@ cell factor_vm::compute_dlsym_address(array *literals, cell index)
 
 	dll *d = (to_boolean(library) ? untag<dll>(library) : NULL);
 
-	if(d != NULL && !d->dll)
+	if(d != NULL && !d->handle)
 		return (cell)factor::undefined_symbol;
 
 	switch(tagged<object>(symbol).type())

vm/compaction.cpp

@@ -168,7 +168,7 @@ void factor_vm::update_code_roots_for_compaction()
 	for(; iter < end; iter++)
 	{
 		code_root *root = *iter;
-		code_block *block = (code_block *)(root->value & -data_alignment);
+		code_block *block = (code_block *)(root->value & (~data_alignment + 1));
 
 		/* Offset of return address within 16-byte allocation line */
 		cell offset = root->value - (cell)block;

vm/factor.cpp

@@ -3,7 +3,6 @@
 namespace factor
 {
 
-factor_vm *vm;
 std::map<THREADHANDLE, factor_vm*> thread_vms;
 
 void init_globals()
@@ -31,11 +30,7 @@ void factor_vm::default_parameters(vm_parameters *p)
 #ifdef WINDOWS
 	p->console = false;
 #else
-	if (this == vm)
+	p->console = true;
-		p->console = true;
-	else		
-		p->console = false;
-	
 #endif
 
 	p->callback_size = 256;
@@ -120,7 +115,7 @@ void factor_vm::init_factor(vm_parameters *p)
 	if(p->image_path == NULL)
 		p->image_path = default_image_path();
 
-	srand(system_micros());
+	srand((unsigned int)system_micros());
 	init_ffi();
 	init_stacks(p->ds_size,p->rs_size);
 	init_callbacks(p->callback_size);
@@ -225,7 +220,7 @@ factor_vm *new_factor_vm()
 }
 
 // arg must be new'ed because we're going to delete it!
-void* start_standalone_factor_thread(void *arg) 
+void *start_standalone_factor_thread(void *arg) 
 {
 	factor_vm *newvm = new_factor_vm();
 	startargs *args = (startargs*) arg;
@@ -238,7 +233,6 @@ void* start_standalone_factor_thread(void *arg)
 VM_C_API void start_standalone_factor(int argc, vm_char **argv)
 {
 	factor_vm *newvm = new_factor_vm();
-	vm = newvm;
 	return newvm->start_standalone_factor(argc,argv);
 }
 

vm/factor.hpp

@@ -2,7 +2,7 @@ namespace factor
 {
 
 VM_C_API void init_globals();
-
 VM_C_API void start_standalone_factor(int argc, vm_char **argv);
 VM_C_API THREADHANDLE start_standalone_factor_in_new_thread(int argc, vm_char **argv);
+
 }

vm/free_list.hpp

@@ -32,7 +32,7 @@ struct free_heap_block
 };
 
 struct block_size_compare {
-	bool operator()(free_heap_block *a, free_heap_block *b)
+	bool operator()(free_heap_block *a, free_heap_block *b) const
 	{
 		return a->size() < b->size();
 	}

vm/gc.cpp

@@ -29,7 +29,7 @@ void gc_event::ended_card_scan(cell cards_scanned_, cell decks_scanned_)
 {
 	cards_scanned += cards_scanned_;
 	decks_scanned += decks_scanned_;
-	card_scan_time = (nano_count() - temp_time);
+	card_scan_time = (cell)(nano_count() - temp_time);
 }
 
 void gc_event::started_code_scan()
@@ -40,7 +40,7 @@ void gc_event::started_code_scan()
 void gc_event::ended_code_scan(cell code_blocks_scanned_)
 {
 	code_blocks_scanned += code_blocks_scanned_;
-	code_scan_time = (nano_count() - temp_time);
+	code_scan_time = (cell)(nano_count() - temp_time);
 }
 
 void gc_event::started_data_sweep()
@@ -50,7 +50,7 @@ void gc_event::started_data_sweep()
 
 void gc_event::ended_data_sweep()
 {
-	data_sweep_time = (nano_count() - temp_time);
+	data_sweep_time = (cell)(nano_count() - temp_time);
 }
 
 void gc_event::started_code_sweep()
@@ -60,7 +60,7 @@ void gc_event::started_code_sweep()
 
 void gc_event::ended_code_sweep()
 {
-	code_sweep_time = (nano_count() - temp_time);
+	code_sweep_time = (cell)(nano_count() - temp_time);
 }
 
 void gc_event::started_compaction()
@@ -70,14 +70,14 @@ void gc_event::started_compaction()
 
 void gc_event::ended_compaction()
 {
-	compaction_time = (nano_count() - temp_time);
+	compaction_time = (cell)(nano_count() - temp_time);
 }
 
 void gc_event::ended_gc(factor_vm *parent)
 {
 	data_heap_after = parent->data_room();
 	code_heap_after = parent->code_room();
-	total_time = nano_count() - start_time;
+	total_time = (cell)(nano_count() - start_time);
 }
 
 gc_state::gc_state(gc_op op_, factor_vm *parent) : op(op_), start_time(nano_count())

vm/instruction_operands.cpp

@@ -122,7 +122,7 @@ void instruction_operand::store_value(fixnum absolute_value)
 		store_value_masked(relative_value - sizeof(cell),rel_indirect_arm_mask,0);
 		break;
 	case RC_ABSOLUTE_2:
-		*(u16 *)(pointer - sizeof(u16)) = absolute_value;
+		*(u16 *)(pointer - sizeof(u16)) = (u16)absolute_value;
 		break;
 	default:
 		critical_error("Bad rel class",rel.rel_class());

vm/layouts.hpp

@@ -298,7 +298,7 @@ struct dll : public object {
 	/* tagged byte array holding a C string */
 	cell path;
 	/* OS-specific handle */
-	void *dll;
+	void *handle;
 };
 
 struct stack_frame {

vm/main-windows-ce.cpp

@@ -1,134 +1,17 @@
 #include "master.hpp"
 
-/* 
+int WINAPI WinMain(
-	Windows CE argument parsing ported to work on
-	int main(int argc, wchar_t **argv).
-
-	This would not be necessary if Windows CE had CommandLineToArgvW.
-
-	Based on MinGW's public domain char** version.
-
-*/
-
-int __argc;
-wchar_t **__argv;
-
-static int
-parse_tokens(wchar_t* string, wchar_t*** tokens, int length)
-{
-	/* Extract whitespace- and quotes- delimited tokens from the given string
-	   and put them into the tokens array. Returns number of tokens
-	   extracted. Length specifies the current size of tokens[].
-	   THIS METHOD MODIFIES string.  */
-
-	const wchar_t* whitespace = L" \t\r\n";
-	wchar_t* tokenEnd = 0;
-	const wchar_t* quoteCharacters = L"\"\'";
-	wchar_t *end = string + wcslen(string);
-
-	if (string == NULL)
-		return length;
-
-	while (1)
-	{
-		const wchar_t* q;
-		/* Skip over initial whitespace.  */
-		string += wcsspn(string, whitespace);
-		if (*string == '\0')
-			break;
-
-		for (q = quoteCharacters; *q; ++q)
-		{
-			if (*string == *q)
-				break;
-		}
-		if (*q)
-		{
-			/* Token is quoted.  */
-			wchar_t quote = *string++;
-			tokenEnd = wcschr(string, quote);
-			/* If there is no endquote, the token is the rest of the string.  */
-			if (!tokenEnd)
-				tokenEnd = end;
-		}
-		else
-		{
-			tokenEnd = string + wcscspn(string, whitespace);
-		}
-
-		*tokenEnd = '\0';
-
-		{
-			wchar_t** new_tokens;
-			int newlen = length + 1;
-			new_tokens = realloc (*tokens, sizeof (wchar_t**) * newlen);
-			if (!new_tokens)
-			{
-				/* Out of memory.  */
-				return -1;
-			}
-
-			*tokens = new_tokens;
-			(*tokens)[length] = string;
-			length = newlen;
-		}
-		if (tokenEnd == end)
-			break;
-		string = tokenEnd + 1;
-	}
-	return length;
-}
-
-static void
-parse_args(int *argc, wchar_t ***argv, wchar_t *cmdlinePtrW)
-{
-	wchar_t cmdnameBufW[MAX_UNICODE_PATH];
-	int cmdlineLen = 0;
-	int modlen;
-
-	/* argv[0] is the path of invoked program - get this from CE.  */
-	cmdnameBufW[0] = 0;
-	modlen = GetModuleFileNameW(NULL, cmdnameBufW, sizeof (cmdnameBufW)/sizeof (cmdnameBufW[0]));
-
-	if (!cmdlinePtrW)
-		cmdlineLen = 0;
-	else
-		cmdlineLen = wcslen(cmdlinePtrW);
-
-	/* gets realloc()'d later */
-	*argv = malloc (sizeof (wchar_t**) * 1);
-	if (!*argv)
-		ExitProcess(-1);
-
-	(*argv)[0] = wcsdup(cmdnameBufW);
-	if(!(*argv[0]))
-		ExitProcess(-1);
-	/* Add one to account for argv[0] */
-	(*argc)++;
-
-	if (cmdlineLen > 0)
-	{
-		wchar_t* argv1 = (*argv)[0] + wcslen((*argv)[0]) + 1;
-		argv1 = wcsdup(cmdlinePtrW);
-		if(!argv1)
-			ExitProcess(-1);
-		*argc = parse_tokens(argv1, argv, 1);
-		if (*argc < 0)
-			ExitProcess(-1);
-	}
-	(*argv)[*argc] = 0;
-	return;
-}
-
-int WINAPI
-WinMain(
 	HINSTANCE hInstance,
 	HINSTANCE hPrevInstance,
 	LPWSTR lpCmdLine,
 	int nCmdShow)
 {
-	parse_args(&__argc, &__argv, lpCmdLine);
+	int __argc;
+	wchar_t **__argv;
+	factor::parse_args(&__argc, &__argv, lpCmdLine);
+	factor::init_globals();
 	factor::start_standalone_factor(__argc,(LPWSTR*)__argv);
+
 	// memory leak from malloc, wcsdup
 	return 0;
 }

vm/main-windows-nt.cpp

@@ -1,30 +1,30 @@
 #include "master.hpp"
 
+VM_C_API int wmain(int argc, wchar_t **argv)
+{
+	factor::init_globals();
+#ifdef FACTOR_MULTITHREADED
+	factor::THREADHANDLE thread = factor::start_standalone_factor_in_new_thread(argv,argc);
+	WaitForSingleObject(thread, INFINITE);
+#else
+	factor::start_standalone_factor(argc,argv);
+#endif
+	return 0;
+}
+
 int WINAPI WinMain(
 	HINSTANCE hInstance,
 	HINSTANCE hPrevInstance,
 	LPSTR lpCmdLine,
 	int nCmdShow)
 {
-	LPWSTR *szArglist;
+	int argc;
-	int nArgs;
+	wchar_t **argv;
 
-	szArglist = CommandLineToArgvW(GetCommandLineW(), &nArgs);
+	factor::parse_args(&argc, &argv, (wchar_t *)GetCommandLine());
-	if(NULL == szArglist)
-	{
-		puts("CommandLineToArgvW failed");
-		return 1;
-	}
 
-	factor::init_globals();
+	wmain(argc,argv);
-  #ifdef FACTOR_MULTITHREADED
-	factor::THREADHANDLE thread = factor::start_standalone_factor_in_new_thread(nArgs,szArglist);
-	WaitForSingleObject(thread, INFINITE);
-  #else
-	factor::start_standalone_factor(nArgs,szArglist);
-  #endif
-
-	LocalFree(szArglist);
 
+	// memory leak from malloc, wcsdup
 	return 0;
 }

vm/master.hpp

@@ -16,7 +16,6 @@
 #include <fcntl.h>
 #include <limits.h>
 #include <math.h>
-#include <stdbool.h>
 #include <setjmp.h>
 #include <stdio.h>
 #include <stdlib.h>
@@ -36,7 +35,7 @@
 #elif defined(__amd64__) || defined(__x86_64__)
 	#define FACTOR_AMD64
 	#define FACTOR_64
-#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32)
+#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32) || defined(_MSC_VER)
 	#define FACTOR_X86
 #elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC)
 	#define FACTOR_PPC
@@ -44,8 +43,15 @@
 	#error "Unsupported architecture"
 #endif
 
-#ifdef WIN32
+#if defined(_MSC_VER)
 	#define WINDOWS
+	#define WINNT
+#elif defined(WIN32)
+	#define WINDOWS
+#endif
+
+#ifndef _MSC_VER
+	#include <stdbool.h>
 #endif
 
 /* Forward-declare this since it comes up in function prototypes */

vm/math.cpp

@@ -277,7 +277,7 @@ void factor_vm::primitive_str_to_float()
 void factor_vm::primitive_float_to_str()
 {
 	byte_array *array = allot_byte_array(33);
-	snprintf((char *)(array + 1),32,"%.16g",untag_float_check(ctx->pop()));
+	SNPRINTF((char *)(array + 1),32,"%.16g",untag_float_check(ctx->pop()));
 	ctx->push(tag<byte_array>(array));
 }
 
@@ -347,7 +347,7 @@ void factor_vm::primitive_float_greatereq()
 
 void factor_vm::primitive_float_bits()
 {
-	ctx->push(from_unsigned_4(float_bits(untag_float_check(ctx->pop()))));
+	ctx->push(from_unsigned_4(float_bits((float)untag_float_check(ctx->pop()))));
 }
 
 void factor_vm::primitive_bits_float()
@@ -480,7 +480,7 @@ cell factor_vm::from_signed_8(s64 n)
 	if(n < fixnum_min || n > fixnum_max)
 		return tag<bignum>(long_long_to_bignum(n));
 	else
-		return tag_fixnum(n);
+		return tag_fixnum((fixnum)n);
 }
 
 VM_C_API cell from_signed_8(s64 n, factor_vm *parent)
@@ -513,7 +513,7 @@ cell factor_vm::from_unsigned_8(u64 n)
 	if(n > (u64)fixnum_max)
 		return tag<bignum>(ulong_long_to_bignum(n));
 	else
-		return tag_fixnum(n);
+		return tag_fixnum((fixnum)n);
 }
 
 VM_C_API cell from_unsigned_8(u64 n, factor_vm *parent)
@@ -549,7 +549,7 @@ VM_C_API cell from_float(float flo, factor_vm *parent)
 /* Cannot allocate */
 float factor_vm::to_float(cell value)
 {
-	return untag_float_check(value);
+	return (float)untag_float_check(value);
 }
 
 VM_C_API float to_float(cell value, factor_vm *parent)

vm/object_start_map.cpp

@@ -70,7 +70,7 @@ void object_start_map::update_card_for_sweep(cell index, u16 mask)
 		else
 		{
 			/* Move the object start forward if necessary */
-			object_start_offsets[index] = offset + (rightmost_set_bit(mask) * data_alignment);
+			object_start_offsets[index] = (card)(offset + (rightmost_set_bit(mask) * data_alignment));
 		}
 	}
 }

vm/os-unix.cpp

@@ -73,20 +73,20 @@ void factor_vm::init_ffi()
 
 void factor_vm::ffi_dlopen(dll *dll)
 {
-	dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY);
+	dll->handle = dlopen(alien_offset(dll->path), RTLD_LAZY);
 }
 
 void *factor_vm::ffi_dlsym(dll *dll, symbol_char *symbol)
 {
-	void *handle = (dll == NULL ? null_dll : dll->dll);
+	void *handle = (dll == NULL ? null_dll : dll->handle);
 	return dlsym(handle,symbol);
 }
 
 void factor_vm::ffi_dlclose(dll *dll)
 {
-	if(dlclose(dll->dll))
+	if(dlclose(dll->handle))
 		general_error(ERROR_FFI,false_object,false_object,NULL);
-	dll->dll = NULL;
+	dll->handle = NULL;
 }
 
 void factor_vm::primitive_existsp()

vm/os-unix.hpp

@@ -22,6 +22,7 @@ typedef char symbol_char;
 #define STRCMP strcmp
 #define STRNCMP strncmp
 #define STRDUP strdup
+#define SNPRINTF snprintf
 
 #define FTELL ftello
 #define FSEEK fseeko

vm/os-windows-ce.hpp

@@ -12,7 +12,6 @@ typedef wchar_t symbol_char;
 
 #define FACTOR_OS_STRING "wince"
 #define FACTOR_DLL L"factor-ce.dll"
-#define FACTOR_DLL_NAME "factor-ce.dll"
 
 int errno;
 char *strerror(int err);

vm/os-windows-nt.cpp

@@ -112,7 +112,7 @@ LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe)
 	return EXCEPTION_CONTINUE_EXECUTION;
 }
 
-FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe)
+FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe)
 {
 	return tls_vm()->exception_handler(pe);
 }

vm/os-windows-nt.hpp

@@ -8,18 +8,27 @@
 #include <windows.h>
 #include <shellapi.h>
 
+#ifdef _MSC_VER
+	#undef min
+	#undef max
+#endif
+
 namespace factor
 {
 
 typedef char symbol_char;
 
 #define FACTOR_OS_STRING "winnt"
-#define FACTOR_DLL L"factor.dll"
-#define FACTOR_DLL_NAME "factor.dll"
 
-#define FACTOR_STDCALL __attribute__((stdcall))
+#ifdef _MSC_VER
+	#define FACTOR_DLL NULL
+	#define FACTOR_STDCALL(return_type) return_type __stdcall
+#else
+	#define FACTOR_DLL L"factor.dll"
+	#define FACTOR_STDCALL(return_type) __attribute__((stdcall)) return_type
+#endif
 
-FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe);
+FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe);
 
 // SSE traps raise these exception codes, which are defined in internal NT headers
 // but not winbase.h

vm/os-windows.cpp

@@ -9,26 +9,26 @@ void factor_vm::init_ffi()
 {
 	hFactorDll = GetModuleHandle(FACTOR_DLL);
 	if(!hFactorDll)
-		fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0);
+		fatal_error("GetModuleHandle() failed", 0);
 }
 
 void factor_vm::ffi_dlopen(dll *dll)
 {
-	dll->dll = LoadLibraryEx((WCHAR *)alien_offset(dll->path), NULL, 0);
+	dll->handle = LoadLibraryEx((WCHAR *)alien_offset(dll->path), NULL, 0);
 }
 
 void *factor_vm::ffi_dlsym(dll *dll, symbol_char *symbol)
 {
-	return (void *)GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol);
+	return (void *)GetProcAddress(dll ? (HMODULE)dll->handle : hFactorDll, symbol);
 }
 
 void factor_vm::ffi_dlclose(dll *dll)
 {
-	FreeLibrary((HMODULE)dll->dll);
+	FreeLibrary((HMODULE)dll->handle);
-	dll->dll = NULL;
+	dll->handle = NULL;
 }
 
-bool factor_vm::windows_stat(vm_char *path)
+BOOL factor_vm::windows_stat(vm_char *path)
 {
 	BY_HANDLE_FILE_INFORMATION bhfi;
 	HANDLE h = CreateFileW(path,
@@ -50,15 +50,14 @@ bool factor_vm::windows_stat(vm_char *path)
 		FindClose(h);
 		return true;
 	}
-	bool ret;
+	BOOL ret = GetFileInformationByHandle(h, &bhfi);
-	ret = GetFileInformationByHandle(h, &bhfi);
 	CloseHandle(h);
 	return ret;
 }
 
 void factor_vm::windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length)
 {
-	snwprintf(temp_path, length-1, L"%s.image", full_path); 
+	SNWPRINTF(temp_path, length-1, L"%s.image", full_path); 
 	temp_path[length - 1] = 0;
 }
 
@@ -75,7 +74,7 @@ const vm_char *factor_vm::default_image_path()
 	if((ptr = wcsrchr(full_path, '.')))
 		*ptr = 0;
 
-	snwprintf(temp_path, MAX_UNICODE_PATH-1, L"%s.image", full_path); 
+	SNWPRINTF(temp_path, MAX_UNICODE_PATH-1, L"%s.image", full_path); 
 	temp_path[MAX_UNICODE_PATH - 1] = 0;
 
 	return safe_strdup(temp_path);
@@ -138,4 +137,120 @@ long getpagesize()
 	return g_pagesize;
 }
 
+/* 
+	Windows argument parsing ported to work on
+	int main(int argc, wchar_t **argv).
+
+	Based on MinGW's public domain char** version.
+
+	Used by WinMain() implementation in main-windows-ce.cpp
+	and main-windows-nt.cpp.
+
+*/
+
+VM_C_API int parse_tokens(wchar_t *string, wchar_t ***tokens, int length)
+{
+	/* Extract whitespace- and quotes- delimited tokens from the given string
+	   and put them into the tokens array. Returns number of tokens
+	   extracted. Length specifies the current size of tokens[].
+	   THIS METHOD MODIFIES string.  */
+
+	const wchar_t *whitespace = L" \t\r\n";
+	wchar_t *tokenEnd = 0;
+	const wchar_t *quoteCharacters = L"\"\'";
+	wchar_t *end = string + wcslen(string);
+
+	if (string == NULL)
+		return length;
+
+	while (1)
+	{
+		const wchar_t *q;
+		/* Skip over initial whitespace.  */
+		string += wcsspn(string, whitespace);
+		if (*string == '\0')
+			break;
+
+		for (q = quoteCharacters; *q; ++q)
+		{
+			if (*string == *q)
+				break;
+		}
+		if (*q)
+		{
+			/* Token is quoted.  */
+			wchar_t quote = *string++;
+			tokenEnd = wcschr(string, quote);
+			/* If there is no endquote, the token is the rest of the string.  */
+			if (!tokenEnd)
+				tokenEnd = end;
+		}
+		else
+		{
+			tokenEnd = string + wcscspn(string, whitespace);
+		}
+
+		*tokenEnd = '\0';
+
+		{
+			wchar_t **new_tokens;
+			int newlen = length + 1;
+			new_tokens = (wchar_t **)realloc (*tokens, sizeof (wchar_t**) * newlen);
+			if (!new_tokens)
+			{
+				/* Out of memory.  */
+				return -1;
+			}
+
+			*tokens = new_tokens;
+			(*tokens)[length] = string;
+			length = newlen;
+		}
+		if (tokenEnd == end)
+			break;
+		string = tokenEnd + 1;
+	}
+	return length;
+}
+
+VM_C_API void parse_args(int *argc, wchar_t ***argv, wchar_t *cmdlinePtrW)
+{
+	wchar_t cmdnameBufW[MAX_UNICODE_PATH];
+	int cmdlineLen = 0;
+	int modlen;
+
+	/* argv[0] is the path of invoked program - get this from CE.  */
+	cmdnameBufW[0] = 0;
+	modlen = GetModuleFileNameW(NULL, cmdnameBufW, sizeof (cmdnameBufW)/sizeof (cmdnameBufW[0]));
+
+	if (!cmdlinePtrW)
+		cmdlineLen = 0;
+	else
+		cmdlineLen = wcslen(cmdlinePtrW);
+
+	/* gets realloc()'d later */
+	*argv = (wchar_t **)malloc (sizeof (wchar_t**) * 1);
+	if (!*argv)
+		ExitProcess(1);
+
+	(*argv)[0] = wcsdup(cmdnameBufW);
+	if(!(*argv[0]))
+		ExitProcess(1);
+	/* Add one to account for argv[0] */
+	(*argc)++;
+
+	if (cmdlineLen > 0)
+	{
+		wchar_t *argv1 = (*argv)[0] + wcslen((*argv)[0]) + 1;
+		argv1 = wcsdup(cmdlinePtrW);
+		if(!argv1)
+			ExitProcess(1);
+		*argc = parse_tokens(argv1, argv, 1);
+		if (*argc < 0)
+			ExitProcess(1);
+	}
+	(*argv)[*argc] = 0;
+	return;
+}
+
 }

vm/os-windows.hpp

@@ -1,8 +1,8 @@
 #include <ctype.h>
 
 #ifndef wcslen
-  /* for cygwin */
+	/* for cygwin */
-  #include <wchar.h>
+	#include <wchar.h>
 #endif
 
 namespace factor
@@ -18,8 +18,18 @@ typedef wchar_t vm_char;
 #define STRCMP wcscmp
 #define STRNCMP wcsncmp
 #define STRDUP _wcsdup
-#define FTELL ftello64
+
-#define FSEEK fseeko64
+#ifdef _MSC_VER
+	#define FTELL ftell
+	#define FSEEK fseek
+	#define SNPRINTF _snprintf
+	#define SNWPRINTF _snwprintf
+#else
+	#define FTELL ftello64
+	#define FSEEK fseeko64
+	#define SNPRINTF snprintf
+	#define SNWPRINTF snwprintf
+#endif
 
 #ifdef WIN64
 	#define CELL_HEX_FORMAT "%Ix"
@@ -41,4 +51,8 @@ u64 nano_count();
 void sleep_nanos(u64 nsec);
 long getpagesize();
 
+/* Used by-main-windows-*.cpp */
+VM_C_API int parse_tokens(wchar_t* string, wchar_t*** tokens, int length);
+VM_C_API void parse_args(int *argc, wchar_t ***argv, wchar_t *cmdlinePtrW);
+
 }

vm/platform.hpp

@@ -1,16 +1,20 @@
 #if defined(WINDOWS)
 	#if defined(WINCE)
 		#include "os-windows-ce.hpp"
-	#else
+		#include "os-windows.hpp"
+	#elif defined(WINNT)
 		#include "os-windows-nt.hpp"
-	#endif
+		#include "os-windows.hpp"
 
-	#include "os-windows.hpp"
+		#if defined(FACTOR_AMD64)
-
+			#include "os-windows-nt.64.hpp"
-	#if defined(FACTOR_AMD64)
+		#elif defined(FACTOR_X86)
-		#include "os-windows-nt.64.hpp"
+			#include "os-windows-nt.32.hpp"
-	#elif defined(FACTOR_X86)
+		#else
-		#include "os-windows-nt.32.hpp"
+			#error "Unsupported Windows flavor"
+		#endif
+	#else
+		#error "Unsupported Windows flavor"
 	#endif
 #else
 	#include "os-unix.hpp"

vm/strings.cpp

@@ -24,7 +24,7 @@ cell string::nth(cell index) const
 
 void factor_vm::set_string_nth_fast(string *str, cell index, cell ch)
 {
-	str->data()[index] = ch;
+	str->data()[index] = (u8)ch;
 }
 
 void factor_vm::set_string_nth_slow(string *str_, cell index, cell ch)
@@ -51,7 +51,7 @@ void factor_vm::set_string_nth_slow(string *str_, cell index, cell ch)
 		write_barrier(&str->aux);
 	}
 
-	aux->data<u16>()[index] = ((ch >> 7) ^ 1);
+	aux->data<u16>()[index] = (u16)((ch >> 7) ^ 1);
 }
 
 /* allocates memory */

vm/vm.hpp

@@ -267,8 +267,8 @@ struct factor_vm
 
 	inline void write_barrier(object *obj, cell size)
 	{
-		cell start = (cell)obj & -card_size;
+		cell start = (cell)obj & (~card_size + 1);
-		cell end = ((cell)obj + size + card_size - 1) & -card_size;
+		cell end = ((cell)obj + size + card_size - 1) & (~card_size + 1);
 
 		for(cell offset = start; offset < end; offset += card_size)
 			write_barrier((cell *)offset);
@@ -671,7 +671,7 @@ struct factor_vm
 	const vm_char *vm_executable_path();
 	const vm_char *default_image_path();
 	void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length);
-	bool windows_stat(vm_char *path);
+	BOOL windows_stat(vm_char *path);
 
   #if defined(WINNT)
 	void open_console();