fix powerpc relocation bug

CHANGES.html

@@ -27,6 +27,7 @@
 <li>Added expandable outliners. Used by the inspector, <code>.s</code>, <code>usage.</code>, <code>uses.</code>, <code>vocabs.</code>, and various other words.</li>
 <li>Added word completion to the listener pane; press <code>TAB</code>.</li>
 <li>Added word navigation shortcuts to the listener pane; press <code>C+LEFT</code> and <code>C+RIGHT</code> to move a word at a time, and <code>C+BACKSPACE</code> and <code>C+DELETE</code> to delete the previous and next word, respectively.</li>
+<lI>Added mouse-over help for presentations</lI>
 </ul>
 
 </li>
@@ -103,7 +104,7 @@ However, most uses of <code>catch</code> can be replaced by <code>cleanup</code>
 
 <li>Intel 8080 CPU and Space Invaders emulator in <code>contrib/space-invaders</code> (Chris Double)</li>
 <li>AOL Instant Messenger chat client library in <code>contrib/aim</code> (Doug Coleman)</li>
-
+<li>Cairo graphics library binding in <code>contrib/cairo</code> (Sampo Vuori)</li>
 </ul>
 
 </li>

Makefile

@@ -7,16 +7,7 @@ else
 	STRIP = strip
 endif
 
-ifdef STATIC
+DEFAULT_LIBS = -lm
-	DEFAULT_LIBS = -lm -Wl,-static -Wl,-whole-archive \
-		-Wl,-export-dynamic \
-		-lSDL -lSDL_gfx -lSDL_ttf \
-		-Wl,-no-whole-archive \
-		-lfreetype -lz -L/usr/X11R6/lib -lX11 -lXext \
-		-Wl,-Bdynamic
-else
-	DEFAULT_LIBS = -lm
-endif
 
 UNIX_OBJS = native/unix/file.o \
 	native/unix/signal.o \
@@ -64,6 +55,7 @@ default:
 	@echo "linux"
 	@echo "linux-ppc"
 	@echo "macosx"
+	@echo "macosx-sdl -- if you wish to use the Factor GUI on Mac OS X"
 	@echo "windows"
 	@echo ""
 	@echo "Also, you might want to set the SITE_CFLAGS environment"
@@ -83,6 +75,11 @@ macosx:
 		CFLAGS="$(DEFAULT_CFLAGS)" \
 		LIBS="$(DEFAULT_LIBS)" 
 
+macosx-sdl:
+	$(MAKE) f \
+		CFLAGS="$(DEFAULT_CFLAGS) -DFACTOR_SDL" \
+		LIBS="$(DEFAULT_LIBS) -lSDL -lSDLmain -framework Cocoa -framework OpenGL -lSDL_ttf -lSDL_gfx" 
+
 linux:
 	$(MAKE) f \
 		CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic" \

contrib/crypto/mt.factor

@@ -1,66 +0,0 @@
-! Copyright (C) 2005 Doug Coleman.
-! See http://factor.sf.net/license.txt for BSD license.
-
-! mersenne twister based on 
-! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
-! usage:   1000 [ drop genrand . ] each
-! initializes to seed 5489 automatically
-
-IN: crypto
-USING: kernel math namespaces sequences arrays ;
-
-: mt-n 624 ; inline
-: mt-m 397 ; inline
-: mt-a HEX: 9908b0df ; inline
-: mt-hi HEX: 80000000 ; inline
-: mt-lo HEX: 7fffffff ; inline
-
-SYMBOL: mt
-SYMBOL: mti
-
-: mt-nth ( n -- nth )
-    mt get nth ; inline
-
-: mt-formula ( mt mti -- mt[mti] )
-    dup rot nth dup -30 shift bitxor 1812433253 * + HEX: ffffffff bitand ; inline
-
-: mt-y ( i0 i1 -- y )
-    mt-nth mt-lo bitand >r mt-nth mt-hi bitand r> bitor ; inline
-    
-: set-mt-ith ( yi0 yi1 mt-set mt-get -- )
-    >r >r mt-y r> r> mt-nth rot dup odd? mt-a 0 ? swap -1 shift bitxor bitxor swap mt get set-nth ; inline
-
-: mt-temper ( y -- yt )
-    dup -11 shift bitxor
-    dup 7 shift HEX: 9d2c5680 bitand bitxor
-    dup 15 shift HEX: efc60000 bitand bitxor
-    dup -18 shift bitxor ; inline
-
-: generate-new-mt
-    mt-n mt-m - [ dup 2dup >r 1+ r> dup mt-m + set-mt-ith ] repeat
-    mt-m 1- [ dup 227 + dup 2dup >r 1+ r> dup mt-m mt-n - + set-mt-ith drop ] repeat
-    mt-n 1- 0 mt-n 1- mt-m 1- set-mt-ith
-    0 mti set ;
-
-: init-random ( seed -- )
-    mt-n zero-array swap
-    HEX: ffffffff bitand 0 pick set-nth
-    mt-n 1- [ 2dup mt-formula 1+ pick pick 1+ swap set-nth ] repeat
-    mt set 0 mti set
-    generate-new-mt ;
-
-: genrand ( -- rand )
-    mti get dup mt-n < [ drop generate-new-mt 0 ] unless
-    mt get nth mt-temper mti inc ;
-
-USE: compiler
-USE: test
-
-: million-genrand 1000000 [ drop genrand drop ] each ;
-: test-genrand \ million-genrand compile [ million-genrand ] time ;
-
-[ 4123659995 ] [ 5489 init-random 9999 [ drop genrand drop ] each genrand millis init-random ] unit-test
-
-! test-genrand
-! 5987 ms run / 56 ms GC time
-

library/bootstrap/boot-stage2.factor

@@ -35,14 +35,10 @@ cpu "ppc" = [
 "statically-linked" get [
     unix? [
         os "macosx" = [
-            "sdl"     "libSDL.dylib"     "cdecl" add-library
-            "sdl-gfx" "libSDL_gfx.dylib" "cdecl" add-library
-            "sdl-ttf" "libSDL_ttf.dylib" "cdecl" add-library
-        ] [
             "sdl"     "libSDL.so"     "cdecl" add-library
             "sdl-gfx" "libSDL_gfx.so" "cdecl" add-library
             "sdl-ttf" "libSDL_ttf.so" "cdecl" add-library
-        ] if
+        ] unless
     ] when
     
     win32? [

library/compiler/ppc/generator.factor

@@ -26,7 +26,7 @@ M: %call-label generate-node ( vop -- )
     #! Near calling convention for inlined recursive combinators
     #! Note: length of instruction sequence is hard-coded.
     vop-label
-    0 1 rel-address  compiled-offset 20 + 18 LOAD32
+    compiled-offset 20 + 18 LOAD32  0 1 rel-address
     1 1 -16 STWU
     18 1 20 STW
     B ;
@@ -75,7 +75,7 @@ M: %dispatch generate-node ( vop -- )
     3 3 1 SRAWI
     ! The value 24 is a magic number. It is the length of the
     ! instruction sequence that follows to be generated.
-    0 1 rel-address  compiled-offset 24 + 4 LOAD32
+    compiled-offset 24 + 4 LOAD32  0 1 rel-address
     3 3 4 ADD
     3 3 0 LWZ
     3 MTLR

library/compiler/relocate.factor

@@ -26,11 +26,7 @@ SYMBOL: relocation-table
     over 1 = [ 2drop ] [ 2 rel-type, relocating 0 rel, ] if ;
 
 : rel-word ( word rel/abs 16/16 -- )
-    pick primitive? [
+    pick primitive? [ rel-primitive ] [ rel-address drop ] if ;
-        rel-primitive
-    ] [
-        rot drop rel-address
-    ] if ;
 
 : rel-userenv ( n 16/16 -- )
     0 swap 3 rel-type, relocating rel, ;

library/sdl/sdl-utils.factor

@@ -74,10 +74,11 @@ SYMBOL: open-fonts
 : make-color ( r g b -- color )
     #! Make an SDL_Color struct. This will go away soon in favor
     #! of pass-by-value support in the FFI.
-    255 24 shift
+    <sdl-color>
-    swap 16 shift bitor
+    [ set-sdl-color-b ] keep
-    swap 8 shift bitor
+    [ set-sdl-color-g ] keep
-    swap bitor ;
+    [ set-sdl-color-r ] keep
+    0 alien-unsigned-4 ;
 
 : make-rect ( x y w h -- rect )
     <sdl-rect>
@@ -105,7 +106,7 @@ SYMBOL: open-fonts
     ] if ;
 
 : lock-surface ( -- )
-    surface get SDL_LockSurface sdl-error ;
+    surface get SDL_LockSurface drop ;
 
 : unlock-surface ( -- )
     surface get SDL_UnlockSurface ;

native/debug.c

@@ -45,6 +45,7 @@ void print_string(F_STRING* str)
 void print_obj(CELL obj)
 {
 	F_ARRAY *array;
+	CELL class;
 
 	switch(type_of(obj))
 	{
@@ -66,7 +67,11 @@ void print_obj(CELL obj)
 	case TUPLE_TYPE:
 		array = (F_ARRAY*)UNTAG(obj);
 		fprintf(stderr,"<< ");
-		print_word(untag_word(get(AREF(array,0))));
+		class = get(AREF(array,0));
+		if(type_of(class) == WORD_TYPE)
+			print_word(untag_word(class));
+		else
+			fprintf(stderr," corrupt tuple: %lx ",class);
 		fprintf(stderr," %lx >>",obj);
 		break;
 	default:
@@ -209,13 +214,13 @@ void factorbug(void)
 			fprintf(stderr,"\n");
 		}
 		else if(strcmp(cmd,"s") == 0)
-			dump_memory(ds_bot,(ds + CELLS));
+			dump_memory(ds_bot,ds);
 		else if(strcmp(cmd,"r") == 0)
-			dump_memory(cs_bot,(cs + CELLS));
+			dump_memory(cs_bot,cs);
 		else if(strcmp(cmd,".s") == 0)
-			print_objects(ds_bot,(ds + CELLS));
+			print_objects(ds_bot,ds);
 		else if(strcmp(cmd,".r") == 0)
-			print_objects(cs_bot,(cs + CELLS));
+			print_objects(cs_bot,cs);
 		else if(strcmp(cmd,"i") == 0)
 		{
 			fprintf(stderr,"Call frame:\n");
@@ -229,7 +234,7 @@ void factorbug(void)
 		{
 			int i;
 			for(i = 0; i < USER_ENV; i++)
-				dump_cell(userenv[i]);
+				dump_cell((CELL)&userenv[i]);
 		}
 		else if(strcmp(cmd,"g") == 0)
 			dump_generations();

native/error.c

@@ -42,11 +42,7 @@ void throw_error(CELL error, bool keep_stacks)
 	thrown_executing = executing;
 
 	/* Return to run() method */
-#ifdef WIN32
+	LONGJMP(toplevel,1);
-	longjmp(toplevel,1);
-#else
-	siglongjmp(toplevel,1);
-#endif
 }
 
 void primitive_throw(void)

native/factor.c

@@ -5,8 +5,6 @@ void init_factor(char* image, CELL ds_size, CELL cs_size,
 	CELL young_size, CELL aging_size,
 	CELL code_size, CELL literal_size)
 {
-	/* initialize random number generator */
-	srand((unsigned)time(NULL));
 	init_ffi();
 	init_arena(gen_count,young_size,aging_size);
 	init_compiler(code_size);
@@ -104,5 +102,7 @@ int main(int argc, char** argv)
 
 	platform_run();
 
+	critical_error("run() returned due to empty callstack",0);
+
 	return 0;
 }

native/factor.h

@@ -3,15 +3,33 @@
 
 #include "platform.h"
 
-#if defined(WIN32)
+#define FIXNUM_MAX (LONG_MAX >> TAG_BITS)
-	#define DLLEXPORT __declspec(dllexport)
+#define FIXNUM_MIN (LONG_MIN >> TAG_BITS)
-#else
+
-	#define DLLEXPORT
+#define F_FIXNUM long int /* unboxed */
-#endif
+
+#define WORD_SIZE (CELLS*8)
+#define HALF_WORD_SIZE (CELLS*4)
+#define HALF_WORD_MASK (((unsigned long)1<<HALF_WORD_SIZE)-1)
+
+/* must always be 16 bits */
+#define CHARS ((signed)sizeof(u16))
 
 typedef unsigned long int CELL;
 #define CELLS ((signed)sizeof(CELL))
 
+typedef unsigned char u8; 	 
+typedef unsigned short u16; 	 
+typedef unsigned int u32; 	 
+typedef unsigned long long u64; 	 
+typedef signed char s8; 	 
+typedef signed short s16; 	 
+typedef signed int s32; 	 
+typedef signed long long s64;
+
+/* must always be 8 bits */
+typedef unsigned char BYTE;
+
 /* raw pointer to datastack bottom */
 CELL ds_bot;
 
@@ -54,14 +72,9 @@ CELL executing;
 #include <string.h>
 #include <time.h>
 
-typedef unsigned char u8; 	 
+#ifdef FACTOR_SDL
-typedef unsigned short u16; 	 
+#include "SDL/SDL.h"
-typedef unsigned int u32; 	 
+#endif
-typedef unsigned long long u64; 	 
-typedef signed char s8; 	 
-typedef signed short s16; 	 
-typedef signed int s32; 	 
-typedef signed long long s64;
 
 #include <sys/param.h>
 
@@ -78,29 +91,9 @@ typedef signed long long s64;
 	#include <sys/stat.h>
 	#include <unistd.h>
 	#include <sys/time.h>
+    #include <dlfcn.h>
 #endif
 
-#if !defined(WIN32)
-#include <dlfcn.h>
-#endif
-
-#define INLINE inline static
-
-#define FIXNUM_MAX (LONG_MAX >> TAG_BITS)
-#define FIXNUM_MIN (LONG_MIN >> TAG_BITS)
-
-#define F_FIXNUM long int /* unboxed */
-
-#define WORD_SIZE (CELLS*8)
-#define HALF_WORD_SIZE (CELLS*4)
-#define HALF_WORD_MASK (((unsigned long)1<<HALF_WORD_SIZE)-1)
-
-/* must always be 16 bits */
-#define CHARS ((signed)sizeof(u16))
-
-/* must always be 8 bits */
-typedef unsigned char BYTE;
-
 #include "error.h"
 #include "cards.h"
 #include "memory.h"

native/platform.h

@@ -30,3 +30,17 @@
 #else
 	#define FACTOR_OS_STRING "unix"
 #endif
+
+#if defined(WIN32)
+	#define DLLEXPORT __declspec(dllexport)
+    #define SETJMP setjmp
+    #define LONGJMP longjmp
+    #define JMP_BUF jmp_buf
+#else
+	#define DLLEXPORT
+    #define SETJMP(jmpbuf) sigsetjmp(jmpbuf,1)
+    #define LONGJMP siglongjmp
+    #define JMP_BUF sigjmp_buf
+#endif
+
+#define INLINE inline static

native/run.c

@@ -9,12 +9,11 @@ void run(void)
 {
 	CELL next;
 
+	CELL height = cs - cs_bot;
+
 	/* Error handling. */
-#ifdef WIN32
+	SETJMP(toplevel);
-	setjmp(toplevel);
+
-#else
-	sigsetjmp(toplevel, 1);
-#endif
 	if(throwing)
 	{
 		interrupt = false;
@@ -48,7 +47,10 @@ void run(void)
 				factorbug();
 				interrupt = false;
 			}
-	
+
+			if(cs - cs_bot < height)
+				return;
+
 			callframe = cpop();
 			executing = cpop();
 			continue;

native/run.h

@@ -24,15 +24,7 @@ DLLEXPORT CELL userenv[USER_ENV];
 DLLEXPORT bool interrupt;
 
 /* Error handlers restore this */
-#ifdef WIN32
+JMP_BUF toplevel;
-jmp_buf toplevel;
-#else
-sigjmp_buf toplevel;
-#endif
-
-/* Call stack depth to start profile counter from */
-/* This ensures that words in the user's interpreter do not count */
-CELL profile_depth;
 
 INLINE CELL dpop(void)
 {
@@ -89,7 +81,6 @@ INLINE void call(CELL quot)
 	callframe = quot;
 }
 
-void call_into_factor(F_WORD *word, XT xt);
 void run(void);
 void platform_run(void);
 void undefined(F_WORD *word);