BINARY = f
IMAGE = factor.image
BUNDLE = Factor.app
-DISK_IMAGE_DIR = Factor-0.81
-DISK_IMAGE = Factor-0.81.dmg
+DISK_IMAGE_DIR = Factor-0.83
+DISK_IMAGE = Factor-0.83.dmg
ifdef DEBUG
- DEFAULT_CFLAGS = -g
+ CFLAGS = -g
STRIP = touch
else
- DEFAULT_CFLAGS = -Wall -O3 -ffast-math -fomit-frame-pointer $(SITE_CFLAGS)
+ CFLAGS = -Wall -O3 -ffast-math -fomit-frame-pointer $(SITE_CFLAGS)
STRIP = strip
endif
-DEFAULT_LIBS = -lm
-
ifdef NO_UI
- UNIX_UI_LIBS =
+ X11_UI_LIBS =
else
- UNIX_UI_LIBS = -lfreetype -lGL -lGLU -L/usr/X11R6/lib -lX11
+ X11_UI_LIBS = -lfreetype -lGL -lGLU -L/usr/X11R6/lib -lX11
endif
-WINDOWS_OBJS = vm/windows/ffi.o \
- vm/windows/file.o \
- vm/windows/misc.o \
- vm/windows/run.o \
- vm/windows/memory.o
-
-UNIX_OBJS = vm/unix/file.o \
- vm/unix/signal.o \
- vm/unix/ffi.o \
- vm/unix/memory.o \
- vm/unix/icache.o
-
-MACOSX_OBJS = $(UNIX_OBJS) \
- vm/macosx/run.o \
- vm/macosx/mach_signal.o
-
-GENERIC_UNIX_OBJS = $(UNIX_OBJS) \
- vm/unix/run.o
-
-ifdef WINDOWS
- PLAF_OBJS = $(WINDOWS_OBJS)
- PLAF_SUFFIX = .exe
-else
- ifdef MACOSX
- PLAF_OBJS = $(MACOSX_OBJS)
- else
- PLAF_OBJS = $(GENERIC_UNIX_OBJS)
- endif
+ifdef CONFIG
+ include $(CONFIG)
endif
-OBJS = $(PLAF_OBJS) vm/array.o vm/bignum.o \
- vm/s48_bignum.o \
- vm/complex.o vm/error.o \
- vm/factor.o vm/fixnum.o \
- vm/float.o vm/gc.o \
- vm/image.o vm/memory.o \
- vm/misc.o vm/primitives.o \
- vm/ratio.o vm/relocate.o \
- vm/run.o \
- vm/sbuf.o vm/stack.o \
- vm/string.o vm/cards.o vm/vector.o \
- vm/word.o vm/compiler.o \
- vm/alien.o vm/dll.o \
- vm/boolean.o \
+OBJS = $(PLAF_OBJS) \
+ vm/alien.o \
+ vm/bignum.o \
vm/debug.o \
- vm/hashtable.o \
+ vm/factor.o \
+ vm/ffi_test.o \
+ vm/image.o \
vm/io.o \
- vm/wrapper.o \
- vm/ffi_test.o
+ vm/math.o \
+ vm/memory.o \
+ vm/primitives.o \
+ vm/run.o \
+ vm/stack.o \
+ vm/types.o
default:
@echo "Run 'make' with one of the following parameters:"
@echo ""
- @echo "bsd"
- @echo "linux"
+ @echo "freebsd"
+ @echo "linux-x86"
+ @echo "linux-amd64"
@echo "linux-ppc"
- @echo "macosx"
+ @echo "macosx-x86"
+ @echo "macosx-ppc"
@echo "solaris"
@echo "windows"
@echo ""
@echo ""
@echo "export SITE_CFLAGS=\"-march=pentium4 -ffast-math\""
-bsd:
- $(MAKE) $(BINARY) \
- CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic -pthread" \
- LIBS="$(DEFAULT_LIBS) $(UI_LIBS)"
+freebsd:
+ $(MAKE) $(BINARY) CONFIG=vm/Config.freebsd
+
+macosx-ppc:
+ $(MAKE) $(BINARY) CONFIG=vm/Config.macosx.ppc
+
+macosx-x86:
+ $(MAKE) $(BINARY) CONFIG=vm/Config.macosx
+
+linux linux-x86 linux-amd64:
+ $(MAKE) $(BINARY) CONFIG=vm/Config.linux
$(STRIP) $(BINARY)
-macosx:
- $(MAKE) $(BINARY) \
- CFLAGS="$(DEFAULT_CFLAGS)" \
- LIBS="$(DEFAULT_LIBS) -framework Cocoa -framework OpenGL -L/usr/X11R6/lib/ -lfreetype" \
- MACOSX=y
+linux-ppc:
+ $(MAKE) $(BINARY) CONFIG=vm/Config.linux.ppc
+ $(STRIP) $(BINARY)
+
+solaris solaris-x86 solaris-amd64:
+ $(MAKE) $(BINARY) CONFIG=vm/Config.solaris
+ $(STRIP) $(BINARY)
+
+windows:
+ $(MAKE) $(BINARY) CONFIG=vm/Config.windows
macosx.app:
cp $(BINARY) $(BUNDLE)/Contents/MacOS/Factor
hdiutil create -srcfolder "$(DISK_IMAGE_DIR)" -fs HFS+ \
-volname "$(DISK_IMAGE_DIR)" "$(DISK_IMAGE)"
-linux linux-x86 linux-amd64:
- $(MAKE) $(BINARY) \
- CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic" \
- LIBS="-ldl $(DEFAULT_LIBS) $(UNIX_UI_LIBS)"
- $(STRIP) $(BINARY)
-
-linux-ppc:
- $(MAKE) $(BINARY) \
- CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic -mregnames" \
- LIBS="-ldl $(DEFAULT_LIBS) $(UNIX_UI_LIBS)"
- $(STRIP) $(BINARY)
-
-solaris solaris-x86:
- $(MAKE) $(BINARY) \
- CFLAGS="$(DEFAULT_CFLAGS) -D_STDC_C99 -Drestrict=\"\" " \
- LIBS="-ldl -lsocket -lnsl $(DEFAULT_LIBS) -R/opt/PM/lib -R/opt/csw/lib -R/usr/local/lib -R/usr/sfw/lib -R/usr/X11R6/lib -R/opt/sfw/lib $(UNIX_UI_LIBS)"
- $(STRIP) $(BINARY)
-
-windows:
- $(MAKE) $(BINARY) \
- CFLAGS="$(DEFAULT_CFLAGS) -DWINDOWS" \
- LIBS="$(DEFAULT_LIBS)" WINDOWS=y
-
f: $(OBJS)
$(CC) $(LIBS) $(CFLAGS) -o $@$(PLAF_SUFFIX) $(OBJS)
.m.o:
$(CC) -c $(CFLAGS) -o $@ $<
-
-boot:
- echo "USE: image \"$(ARCH)\" make-image bye" | ./f factor.image
- ./f boot.image.$(ARCH) $(BOOTSTRAP_FLAGS)
-
Linux/x86
Linux/AMD64
+ Mac OS X/x86
Mac OS X/PowerPC
The following platforms should work, but are not tested on a
Solaris/x86
Solaris/AMD64
Linux/PowerPC
- Microsoft Windows 2000 or later
Please donate time or hardware if you wish to see Factor running on
other platforms.
Run 'make' (or 'gmake' on non-Linux platforms) with one of the following
parameters to build the Factor runtime:
- bsd
- linux
+ freebsd
+ linux-x86
+ linux-amd64
linux-ppc
- macosx
+ macosx-x86
+ macosx-ppc
solaris
- windows
The following options can be given to make:
Factor.app runs the UI when double-clicked and can be transported
between PowerPC Macs.
-* Running Factor on Windows
-
-On Windows, double-clicking f.exe will start running the Win32-based UI
-with the factor.image in the same directory as the executable.
-
-Bootstrap runs in a Windows command prompt, however there is no
-terminal listener and after bootstrapping only the UI can be used.
-
* Source organization
doc/ - the developer's handbook, and various other bits and pieces
- roundoff is still not quite right with tracks
- httpd search tools
-tathi: hrm. wish I knew more about OpenGL.
[2:45pm] tathi: Factor's text display is a bit odd sometimes, until you mouse over (or click, if there's no "live" text)
-[2:46pm] tathi: but the text display code looks good as far as I can tell
[2:48pm] tathi: it appears to be using the font metrics from the sprite tuple, but re-using the texture from the previous letter
-[2:48pm] tathi: very odd
[2:59pm] tathi: hmm...and it looks like it's only be happening the first time you use a given character (from a given font face)
+ io:
This directory contains Factor code that is not part of the core
library, but is useful enough to ship with the Factor distribution.
-You can load these modules by typing:
+Modules can be loaded from the listener:
-REQUIRE: modulename
+ "modulename" require
-in the listener.
+Credits:
- aim -- AOL Instant Messenger client library (Doug Coleman)
- automata -- Graphics demo for the UI (Eduardo Cavazos)
--- /dev/null
+include vm/Config.unix
+PLAF_OBJS += vm/genunix.o
+CFLAGS += -export-dynamic -pthread
+LIBS = -ldl -lm $(X11_UI_LIBS)
--- /dev/null
+include vm/Config.unix
+PLAF_OBJS += vm/genunix.o
+CFLAGS += -export-dynamic
+LIBS = -ldl -lm $(X11_UI_LIBS)
--- /dev/null
+include vm/Config.linux
+include vm/Config.ppc
+CFLAGS += -mregnames
--- /dev/null
+include vm/Config.unix
+PLAF_OBJS += vm/os-macosx.o vm/mach_signal.o
+LIBS= -lm -framework Cocoa -framework OpenGL -LFactor.app/Contents/Frameworks/ -lfreetype
--- /dev/null
+include vm/Config.macosx
+include vm/Config.ppc
--- /dev/null
+PLAF_OBJS += vm/cpu-ppc.o
--- /dev/null
+CFLAGS += -D_STDC_C99 -Drestrict=""
+LIBS += -ldl -lsocket -lnsl -lm -R/opt/PM/lib -R/opt/csw/lib \
+ -R/usr/local/lib -R/usr/sfw/lib -R/usr/X11R6/lib \
+ -R/opt/sfw/lib $(X11_UI_LIBS)
--- /dev/null
+PLAF_OBJS = vm/os-unix.o
--- /dev/null
+CFLAGS += -DWINDOWS
+LIBS = -lm
+PLAF_SUFFIX = .exe
put(AREF(array,1),y);
dpush(tag_object(array));
}
+
+void primitive_dlopen(void)
+{
+ DLL* dll;
+ F_STRING* path;
+
+ maybe_gc(sizeof(DLL));
+
+ path = untag_string(dpop());
+ dll = allot_object(DLL_TYPE,sizeof(DLL));
+ dll->path = tag_object(path);
+ ffi_dlopen(dll,true);
+
+ dpush(tag_object(dll));
+}
+
+void primitive_dlsym(void)
+{
+ CELL dll;
+ F_STRING *sym;
+ DLL *d;
+
+ maybe_gc(0);
+
+ dll = dpop();
+ sym = untag_string(dpop());
+
+ if(dll == F)
+ d = NULL;
+ else
+ {
+ d = untag_dll(dll);
+ if(d->dll == NULL)
+ general_error(ERROR_EXPIRED,dll,F,true);
+ }
+
+ dpush(tag_cell((CELL)ffi_dlsym(d,sym,true)));
+}
+
+void primitive_dlclose(void)
+{
+ ffi_dlclose(untag_dll(dpop()));
+}
+
+void fixup_dll(DLL* dll)
+{
+ data_fixup(&dll->path);
+ ffi_dlopen(dll,false);
+}
+
+void collect_dll(DLL* dll)
+{
+ copy_handle(&dll->path);
+}
-typedef struct {
- CELL header;
- CELL alien;
- CELL displacement;
- bool expired;
-} ALIEN;
-
INLINE ALIEN* untag_alien_fast(CELL tagged)
{
return (ALIEN*)UNTAG(tagged);
DLLEXPORT void unbox_value_struct(void *dest, CELL size);
DLLEXPORT void box_value_struct(void *src, CELL size);
DLLEXPORT void box_value_pair(CELL x, CELL y);
+
+INLINE DLL *untag_dll(CELL tagged)
+{
+ type_check(DLL_TYPE,tagged);
+ return (DLL*)UNTAG(tagged);
+}
+
+void primitive_dlopen(void);
+void primitive_dlsym(void);
+void primitive_dlclose(void);
+
+void fixup_dll(DLL* dll);
+void collect_dll(DLL* dll);
+++ /dev/null
-#include "factor.h"
-
-/* the array is full of undefined data, and must be correctly filled before the
-next GC. size is in cells */
-F_ARRAY *allot_array(CELL type, F_FIXNUM capacity)
-{
- F_ARRAY *array;
-
- if(capacity < 0)
- general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),F,true);
-
- array = allot_object(type,array_size(capacity));
- array->capacity = tag_fixnum(capacity);
- return array;
-}
-
-/* make a new array with an initial element */
-F_ARRAY *array(CELL type, F_FIXNUM capacity, CELL fill)
-{
- int i;
- F_ARRAY* array = allot_array(type, capacity);
- for(i = 0; i < capacity; i++)
- put(AREF(array,i),fill);
- return array;
-}
-
-/* size is in bytes this time */
-F_ARRAY *byte_array(F_FIXNUM size)
-{
- F_FIXNUM byte_size = (size + sizeof(CELL) - 1) / sizeof(CELL);
- return array(BYTE_ARRAY_TYPE,byte_size,0);
-}
-
-/* push a new array on the stack */
-void primitive_array(void)
-{
- CELL initial;
- F_FIXNUM size;
- maybe_gc(0);
- initial = dpop();
- size = to_fixnum(dpop());
- dpush(tag_object(array(ARRAY_TYPE,size,initial)));
-}
-
-/* push a new tuple on the stack */
-void primitive_tuple(void)
-{
- CELL class;
- F_FIXNUM size;
- F_ARRAY *tuple;
- maybe_gc(0);
- size = to_fixnum(dpop());
- class = dpop();
- tuple = array(TUPLE_TYPE,size,F);
- put(AREF(tuple,0),class);
- dpush(tag_object(tuple));
-}
-
-/* push a new byte on the stack */
-void primitive_byte_array(void)
-{
- F_FIXNUM size = to_fixnum(dpop());
- maybe_gc(0);
- dpush(tag_object(byte_array(size)));
-}
-
-/* push a new quotation on the stack */
-void primitive_quotation(void)
-{
- F_FIXNUM size;
- maybe_gc(0);
- size = to_fixnum(dpop());
- dpush(tag_object(array(QUOTATION_TYPE,size,F)));
-}
-
-CELL make_array_2(CELL v1, CELL v2)
-{
- F_ARRAY *a = array(ARRAY_TYPE,2,F);
- put(AREF(a,0),v1);
- put(AREF(a,1),v2);
- return tag_object(a);
-}
-
-CELL make_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
-{
- F_ARRAY *a = array(ARRAY_TYPE,4,F);
- put(AREF(a,0),v1);
- put(AREF(a,1),v2);
- put(AREF(a,2),v3);
- put(AREF(a,3),v4);
- return tag_object(a);
-}
-
-F_ARRAY* resize_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill)
-{
- int i;
- F_ARRAY* new_array;
-
- CELL to_copy = array_capacity(array);
- if(capacity < to_copy)
- to_copy = capacity;
-
- new_array = allot_array(untag_header(array->header),capacity);
-
- memcpy(new_array + 1,array + 1,to_copy * CELLS);
-
- for(i = to_copy; i < capacity; i++)
- put(AREF(new_array,i),fill);
-
- return new_array;
-}
-
-void primitive_resize_array(void)
-{
- F_ARRAY* array;
- F_FIXNUM capacity = to_fixnum(dpeek2());
- maybe_gc(array_size(capacity));
- array = untag_array(dpop());
- drepl(tag_object(resize_array(array,capacity,F)));
-}
-
-void primitive_array_to_tuple(void)
-{
- CELL array = dpeek();
- type_check(ARRAY_TYPE,array);
- array = clone(array);
- put(SLOT(UNTAG(array),0),tag_header(TUPLE_TYPE));
- drepl(array);
-}
-
-void primitive_tuple_to_array(void)
-{
- CELL tuple = dpeek();
- type_check(TUPLE_TYPE,tuple);
- tuple = clone(tuple);
- put(SLOT(UNTAG(tuple),0),tag_header(ARRAY_TYPE));
- drepl(tuple);
-}
-
-/* image loading */
-void fixup_array(F_ARRAY* array)
-{
- int i = 0; CELL capacity = array_capacity(array);
- for(i = 0; i < capacity; i++)
- data_fixup((void*)AREF(array,i));
-}
-
-/* GC */
-void collect_array(F_ARRAY* array)
-{
- int i = 0; CELL capacity = array_capacity(array);
- for(i = 0; i < capacity; i++)
- copy_handle((void*)AREF(array,i));
-}
+++ /dev/null
-typedef struct {
- CELL header;
- /* tagged */
- CELL capacity;
-} F_ARRAY;
-
-INLINE F_ARRAY* untag_array_fast(CELL tagged)
-{
- return (F_ARRAY*)UNTAG(tagged);
-}
-
-INLINE F_ARRAY* untag_array(CELL tagged)
-{
- type_check(ARRAY_TYPE,tagged);
- return untag_array_fast(tagged);
-}
-
-INLINE F_ARRAY* untag_byte_array_fast(CELL tagged)
-{
- return (F_ARRAY*)UNTAG(tagged);
-}
-
-INLINE CELL array_size(CELL size)
-{
- return align8(sizeof(F_ARRAY) + size * CELLS);
-}
-
-F_ARRAY *allot_array(CELL type, F_FIXNUM capacity);
-F_ARRAY *array(CELL type, F_FIXNUM capacity, CELL fill);
-F_ARRAY *byte_array(F_FIXNUM size);
-
-CELL make_array_2(CELL v1, CELL v2);
-CELL make_array_4(CELL v1, CELL v2, CELL v3, CELL v4);
-
-void primitive_array(void);
-void primitive_tuple(void);
-void primitive_byte_array(void);
-void primitive_quotation(void);
-
-F_ARRAY *resize_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill);
-void primitive_resize_array(void);
-void primitive_array_to_tuple(void);
-void primitive_tuple_to_array(void);
-
-#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
-#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS)
-
-INLINE CELL array_capacity(F_ARRAY* array)
-{
- return untag_fixnum_fast(array->capacity);
-}
-
-void fixup_array(F_ARRAY* array);
-void collect_array(F_ARRAY* array);
+/* :tabSize=2:indentSize=2:noTabs=true:
+
+$Id: s48_bignum.c,v 1.12 2005/12/21 02:36:52 spestov Exp $
+
+Copyright (c) 1989-94 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy and modify this software, to
+redistribute either the original software or a modified version, and
+to use this software for any purpose is granted, subject to the
+following restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Changes for Scheme 48:
+ * - Converted to ANSI.
+ * - Added bitwise operations.
+ * - Added s48_ to the beginning of all externally visible names.
+ * - Cached the bignum representations of -1, 0, and 1.
+ */
+
+/* Changes for Factor:
+ * - Add s48_ prefix to file names
+ * - Adapt s48_bignumint.h for Factor memory manager
+ * - Add more bignum <-> C type conversions
+ */
+
#include "factor.h"
+#include <limits.h>
+#include <stdio.h>
+#include <stdlib.h> /* abort */
+#include <math.h>
-CELL to_cell(CELL x)
+/* Exports */
+
+int
+s48_bignum_equal_p(bignum_type x, bignum_type y)
{
- switch(type_of(x))
- {
- case FIXNUM_TYPE:
- return untag_fixnum_fast(x);
- case BIGNUM_TYPE:
- return s48_bignum_to_fixnum(untag_bignum_fast(x));
- default:
- type_error(BIGNUM_TYPE,x);
- return 0;
- }
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? (BIGNUM_ZERO_P (y))
+ : ((! (BIGNUM_ZERO_P (y)))
+ && ((BIGNUM_NEGATIVE_P (x))
+ ? (BIGNUM_NEGATIVE_P (y))
+ : (! (BIGNUM_NEGATIVE_P (y))))
+ && (bignum_equal_p_unsigned (x, y))));
}
-F_ARRAY* to_bignum(CELL tagged)
+enum bignum_comparison
+s48_bignum_test(bignum_type bignum)
{
- F_RATIO* r;
- F_ARRAY* x;
- F_ARRAY* y;
- F_FLOAT* f;
+ return
+ ((BIGNUM_ZERO_P (bignum))
+ ? bignum_comparison_equal
+ : (BIGNUM_NEGATIVE_P (bignum))
+ ? bignum_comparison_less
+ : bignum_comparison_greater);
+}
- switch(type_of(tagged))
- {
- case FIXNUM_TYPE:
- return s48_fixnum_to_bignum(untag_fixnum_fast(tagged));
- case BIGNUM_TYPE:
- return (F_ARRAY*)UNTAG(tagged);
- case RATIO_TYPE:
- r = (F_RATIO*)UNTAG(tagged);
- x = to_bignum(r->numerator);
- y = to_bignum(r->denominator);
- return s48_bignum_quotient(x,y);
- case FLOAT_TYPE:
- f = (F_FLOAT*)UNTAG(tagged);
- return s48_double_to_bignum(f->n);
- default:
- type_error(BIGNUM_TYPE,tagged);
- return NULL; /* can't happen */
- }
+enum bignum_comparison
+s48_bignum_compare(bignum_type x, bignum_type y)
+{
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? ((BIGNUM_ZERO_P (y))
+ ? bignum_comparison_equal
+ : (BIGNUM_NEGATIVE_P (y))
+ ? bignum_comparison_greater
+ : bignum_comparison_less)
+ : (BIGNUM_ZERO_P (y))
+ ? ((BIGNUM_NEGATIVE_P (x))
+ ? bignum_comparison_less
+ : bignum_comparison_greater)
+ : (BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_compare_unsigned (y, x))
+ : (bignum_comparison_less))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_comparison_greater)
+ : (bignum_compare_unsigned (x, y))));
}
-void primitive_to_bignum(void)
+bignum_type
+s48_bignum_add(bignum_type x, bignum_type y)
{
- maybe_gc(0);
- drepl(tag_bignum(to_bignum(dpeek())));
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? (BIGNUM_MAYBE_COPY (y))
+ : (BIGNUM_ZERO_P (y))
+ ? (BIGNUM_MAYBE_COPY (x))
+ : ((BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_add_unsigned (x, y, 1))
+ : (bignum_subtract_unsigned (y, x)))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_subtract_unsigned (x, y))
+ : (bignum_add_unsigned (x, y, 0)))));
}
-#define GC_AND_POP_BIGNUMS(x,y) \
- F_ARRAY *x, *y; \
- maybe_gc(0); \
- y = untag_bignum_fast(dpop()); \
- x = untag_bignum_fast(dpop());
+bignum_type
+s48_bignum_subtract(bignum_type x, bignum_type y)
+{
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? ((BIGNUM_ZERO_P (y))
+ ? (BIGNUM_MAYBE_COPY (y))
+ : (bignum_new_sign (y, (! (BIGNUM_NEGATIVE_P (y))))))
+ : ((BIGNUM_ZERO_P (y))
+ ? (BIGNUM_MAYBE_COPY (x))
+ : ((BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_subtract_unsigned (y, x))
+ : (bignum_add_unsigned (x, y, 1)))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_add_unsigned (x, y, 0))
+ : (bignum_subtract_unsigned (x, y))))));
+}
-void primitive_bignum_eq(void)
+bignum_type
+s48_bignum_negate(bignum_type x)
{
- GC_AND_POP_BIGNUMS(x,y);
- box_boolean(s48_bignum_equal_p(x,y));
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? (BIGNUM_MAYBE_COPY (x))
+ : (bignum_new_sign (x, (! (BIGNUM_NEGATIVE_P (x))))));
}
-void primitive_bignum_add(void)
+bignum_type
+s48_bignum_multiply(bignum_type x, bignum_type y)
{
- GC_AND_POP_BIGNUMS(x,y);
- dpush(tag_bignum(s48_bignum_add(x,y)));
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+ int negative_p =
+ ((BIGNUM_NEGATIVE_P (x))
+ ? (! (BIGNUM_NEGATIVE_P (y)))
+ : (BIGNUM_NEGATIVE_P (y)));
+ if (BIGNUM_ZERO_P (x))
+ return (BIGNUM_MAYBE_COPY (x));
+ if (BIGNUM_ZERO_P (y))
+ return (BIGNUM_MAYBE_COPY (y));
+ if (x_length == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (x, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (y, negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ return (bignum_multiply_unsigned_small_factor (y, digit, negative_p));
+ }
+ if (y_length == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (y, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (x, negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ return (bignum_multiply_unsigned_small_factor (x, digit, negative_p));
+ }
+ return (bignum_multiply_unsigned (x, y, negative_p));
}
-void primitive_bignum_subtract(void)
+void
+s48_bignum_divide(bignum_type numerator, bignum_type denominator,
+ bignum_type * quotient, bignum_type * remainder)
{
- GC_AND_POP_BIGNUMS(x,y);
- dpush(tag_bignum(s48_bignum_subtract(x,y)));
+ if (BIGNUM_ZERO_P (denominator))
+ {
+ raise(SIGFPE);
+ return;
+ }
+ if (BIGNUM_ZERO_P (numerator))
+ {
+ (*quotient) = (BIGNUM_MAYBE_COPY (numerator));
+ (*remainder) = (BIGNUM_MAYBE_COPY (numerator));
+ }
+ else
+ {
+ int r_negative_p = (BIGNUM_NEGATIVE_P (numerator));
+ int q_negative_p =
+ ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p);
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ {
+ (*quotient) = (BIGNUM_ONE (q_negative_p));
+ (*remainder) = (BIGNUM_ZERO ());
+ break;
+ }
+ case bignum_comparison_less:
+ {
+ (*quotient) = (BIGNUM_ZERO ());
+ (*remainder) = (BIGNUM_MAYBE_COPY (numerator));
+ break;
+ }
+ case bignum_comparison_greater:
+ {
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ {
+ (*quotient) =
+ (bignum_maybe_new_sign (numerator, q_negative_p));
+ (*remainder) = (BIGNUM_ZERO ());
+ break;
+ }
+ else if (digit < BIGNUM_RADIX_ROOT)
+ {
+ bignum_divide_unsigned_small_denominator
+ (numerator, digit,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ else
+ {
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ }
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ }
+ }
}
-void primitive_bignum_multiply(void)
+bignum_type
+s48_bignum_quotient(bignum_type numerator, bignum_type denominator)
{
- GC_AND_POP_BIGNUMS(x,y);
- dpush(tag_bignum(s48_bignum_multiply(x,y)));
+ if (BIGNUM_ZERO_P (denominator))
+ {
+ raise(SIGFPE);
+ return (BIGNUM_OUT_OF_BAND);
+ }
+ if (BIGNUM_ZERO_P (numerator))
+ return (BIGNUM_MAYBE_COPY (numerator));
+ {
+ int q_negative_p =
+ ((BIGNUM_NEGATIVE_P (denominator))
+ ? (! (BIGNUM_NEGATIVE_P (numerator)))
+ : (BIGNUM_NEGATIVE_P (numerator)));
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ONE (q_negative_p));
+ case bignum_comparison_less:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_greater:
+ default: /* to appease gcc -Wall */
+ {
+ bignum_type quotient;
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (numerator, q_negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ bignum_divide_unsigned_small_denominator
+ (numerator, digit,
+ ("ient), ((bignum_type *) 0),
+ q_negative_p, 0);
+ else
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ ("ient), ((bignum_type *) 0),
+ q_negative_p, 0);
+ }
+ else
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ ("ient), ((bignum_type *) 0),
+ q_negative_p, 0);
+ return (quotient);
+ }
+ }
+ }
}
-void primitive_bignum_divint(void)
+bignum_type
+s48_bignum_remainder(bignum_type numerator, bignum_type denominator)
{
- GC_AND_POP_BIGNUMS(x,y);
- dpush(tag_bignum(s48_bignum_quotient(x,y)));
+ if (BIGNUM_ZERO_P (denominator))
+ {
+ raise(SIGFPE);
+ return (BIGNUM_OUT_OF_BAND);
+ }
+ if (BIGNUM_ZERO_P (numerator))
+ return (BIGNUM_MAYBE_COPY (numerator));
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_less:
+ return (BIGNUM_MAYBE_COPY (numerator));
+ case bignum_comparison_greater:
+ default: /* to appease gcc -Wall */
+ {
+ bignum_type remainder;
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ return (BIGNUM_ZERO ());
+ if (digit < BIGNUM_RADIX_ROOT)
+ return
+ (bignum_remainder_unsigned_small_denominator
+ (numerator, digit, (BIGNUM_NEGATIVE_P (numerator))));
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ ((bignum_type *) 0), (&remainder),
+ 0, (BIGNUM_NEGATIVE_P (numerator)));
+ }
+ else
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ ((bignum_type *) 0), (&remainder),
+ 0, (BIGNUM_NEGATIVE_P (numerator)));
+ return (remainder);
+ }
+ }
}
-void primitive_bignum_divfloat(void)
+#define FOO_TO_BIGNUM(name,type,utype) \
+ bignum_type s48_##name##_to_bignum(type n) \
+ { \
+ int negative_p; \
+ bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \
+ bignum_digit_type * end_digits = result_digits; \
+ /* Special cases win when these small constants are cached. */ \
+ if (n == 0) return (BIGNUM_ZERO ()); \
+ if (n == 1) return (BIGNUM_ONE (0)); \
+ if (n == -1) return (BIGNUM_ONE (1)); \
+ { \
+ utype accumulator = ((negative_p = (n < 0)) ? (-n) : n); \
+ do \
+ { \
+ (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \
+ accumulator >>= BIGNUM_DIGIT_LENGTH; \
+ } \
+ while (accumulator != 0); \
+ } \
+ { \
+ bignum_type result = \
+ (bignum_allocate ((end_digits - result_digits), negative_p)); \
+ bignum_digit_type * scan_digits = result_digits; \
+ bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \
+ while (scan_digits < end_digits) \
+ (*scan_result++) = (*scan_digits++); \
+ return (result); \
+ } \
+ }
+
+FOO_TO_BIGNUM(cell,CELL,CELL)
+FOO_TO_BIGNUM(fixnum,F_FIXNUM,CELL)
+FOO_TO_BIGNUM(long,long,unsigned long)
+FOO_TO_BIGNUM(ulong,unsigned long,unsigned long)
+FOO_TO_BIGNUM(long_long,s64,u64)
+FOO_TO_BIGNUM(ulong_long,u64,u64)
+
+/* this is inefficient; its only used for fixnum multiplication overflow so
+it probaly does not matter */
+bignum_type s48_fixnum_pair_to_bignum(CELL x, F_FIXNUM y)
{
- GC_AND_POP_BIGNUMS(x,y);
- dpush(tag_float(
- s48_bignum_to_double(x) /
- s48_bignum_to_double(y)));
+ return s48_bignum_add(
+ s48_bignum_arithmetic_shift(
+ s48_fixnum_to_bignum(y),
+ sizeof(unsigned long) * 8),
+ s48_cell_to_bignum(x));
}
-void primitive_bignum_divmod(void)
+#define BIGNUM_TO_FOO(name,type,utype) \
+ type s48_bignum_to_##name(bignum_type bignum) \
+ { \
+ if (BIGNUM_ZERO_P (bignum)) \
+ return (0); \
+ { \
+ utype accumulator = 0; \
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \
+ while (start < scan) \
+ accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \
+ return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \
+ } \
+ }
+
+BIGNUM_TO_FOO(cell,CELL,CELL);
+BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL);
+BIGNUM_TO_FOO(long,long,unsigned long)
+BIGNUM_TO_FOO(ulong,unsigned long,unsigned long)
+BIGNUM_TO_FOO(long_long,s64,u64)
+BIGNUM_TO_FOO(ulong_long,u64,u64)
+
+double
+s48_bignum_to_double(bignum_type bignum)
{
- F_ARRAY *q, *r;
- GC_AND_POP_BIGNUMS(x,y);
- s48_bignum_divide(x,y,&q,&r);
- dpush(tag_bignum(q));
- dpush(tag_bignum(r));
+ if (BIGNUM_ZERO_P (bignum))
+ return (0);
+ {
+ double accumulator = 0;
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ while (start < scan)
+ accumulator = ((accumulator * BIGNUM_RADIX) + (*--scan));
+ return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator);
+ }
+}
+
+#define DTB_WRITE_DIGIT(factor) \
+{ \
+ significand *= (factor); \
+ digit = ((bignum_digit_type) significand); \
+ (*--scan) = digit; \
+ significand -= ((double) digit); \
}
-void primitive_bignum_mod(void)
+bignum_type
+s48_double_to_bignum(double x)
{
- GC_AND_POP_BIGNUMS(x,y);
- dpush(tag_bignum(s48_bignum_remainder(x,y)));
+ int exponent;
+ double significand = (frexp (x, (&exponent)));
+ if (exponent <= 0) return (BIGNUM_ZERO ());
+ if (exponent == 1) return (BIGNUM_ONE (x < 0));
+ if (significand < 0) significand = (-significand);
+ {
+ bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent));
+ bignum_type result = (bignum_allocate (length, (x < 0)));
+ bignum_digit_type * start = (BIGNUM_START_PTR (result));
+ bignum_digit_type * scan = (start + length);
+ bignum_digit_type digit;
+ int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH);
+ if (odd_bits > 0)
+ DTB_WRITE_DIGIT (1L << odd_bits);
+ while (start < scan)
+ {
+ if (significand == 0)
+ {
+ while (start < scan)
+ (*--scan) = 0;
+ break;
+ }
+ DTB_WRITE_DIGIT (BIGNUM_RADIX);
+ }
+ return (result);
+ }
}
-void primitive_bignum_and(void)
+#undef DTB_WRITE_DIGIT
+
+int
+s48_bignum_fits_in_word_p(bignum_type bignum, long word_length,
+ int twos_complement_p)
{
- GC_AND_POP_BIGNUMS(x,y);
- dpush(tag_bignum(s48_bignum_bitwise_and(x,y)));
+ unsigned int n_bits = (twos_complement_p ? (word_length - 1) : word_length);
+ BIGNUM_ASSERT (n_bits > 0);
+ {
+ bignum_length_type length = (BIGNUM_LENGTH (bignum));
+ bignum_length_type max_digits = (BIGNUM_BITS_TO_DIGITS (n_bits));
+ bignum_digit_type msd, max;
+ return
+ ((length < max_digits) ||
+ ((length == max_digits) &&
+ ((((msd = (BIGNUM_REF (bignum, (length - 1)))) <
+ (max = (1L << (n_bits - ((length - 1) * BIGNUM_DIGIT_LENGTH))))) ||
+ (twos_complement_p &&
+ (msd == max) &&
+ (BIGNUM_NEGATIVE_P (bignum)))))));
+ }
}
-void primitive_bignum_or(void)
+bignum_type
+s48_bignum_length_in_bits(bignum_type bignum)
{
- GC_AND_POP_BIGNUMS(x,y);
- dpush(tag_bignum(s48_bignum_bitwise_ior(x,y)));
+ if (BIGNUM_ZERO_P (bignum))
+ return (BIGNUM_ZERO ());
+ {
+ bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1);
+ bignum_digit_type digit = (BIGNUM_REF (bignum, index));
+ bignum_type result = (bignum_allocate (2, 0));
+ (BIGNUM_REF (result, 0)) = index;
+ (BIGNUM_REF (result, 1)) = 0;
+ bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH);
+ while (digit > 0)
+ {
+ bignum_destructive_add (result, ((bignum_digit_type) 1));
+ digit >>= 1;
+ }
+ return (bignum_trim (result));
+ }
}
-void primitive_bignum_xor(void)
+bignum_type
+s48_bignum_length_upper_limit(void)
{
- GC_AND_POP_BIGNUMS(x,y);
- dpush(tag_bignum(s48_bignum_bitwise_xor(x,y)));
+ bignum_type result = (bignum_allocate (2, 0));
+ (BIGNUM_REF (result, 0)) = 0;
+ (BIGNUM_REF (result, 1)) = BIGNUM_DIGIT_LENGTH;
+ return (result);
}
-void primitive_bignum_shift(void)
+bignum_type
+s48_digit_stream_to_bignum(unsigned int n_digits,
+ unsigned int *producer(bignum_procedure_context),
+ bignum_procedure_context context,
+ unsigned int radix,
+ int negative_p)
{
- F_FIXNUM y;
- F_ARRAY* x;
- maybe_gc(0);
- y = to_fixnum(dpop());
- x = to_bignum(dpop());
- dpush(tag_bignum(s48_bignum_arithmetic_shift(x,y)));
+ BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT));
+ if (n_digits == 0)
+ return (BIGNUM_ZERO ());
+ if (n_digits == 1)
+ {
+ long digit = ((long) ((*producer) (context)));
+ return (s48_long_to_bignum (negative_p ? (- digit) : digit));
+ }
+ {
+ bignum_length_type length;
+ {
+ unsigned int radix_copy = radix;
+ unsigned int log_radix = 0;
+ while (radix_copy > 0)
+ {
+ radix_copy >>= 1;
+ log_radix += 1;
+ }
+ /* This length will be at least as large as needed. */
+ length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix));
+ }
+ {
+ bignum_type result = (bignum_allocate_zeroed (length, negative_p));
+ while ((n_digits--) > 0)
+ {
+ bignum_destructive_scale_up (result, ((bignum_digit_type) radix));
+ bignum_destructive_add
+ (result, ((bignum_digit_type) ((*producer) (context))));
+ }
+ return (bignum_trim (result));
+ }
+ }
}
-void primitive_bignum_less(void)
+long
+s48_bignum_max_digit_stream_radix(void)
{
- GC_AND_POP_BIGNUMS(x,y);
- box_boolean(s48_bignum_compare(x,y) == bignum_comparison_less);
+ return (BIGNUM_RADIX_ROOT);
}
-void primitive_bignum_lesseq(void)
+/* Comparisons */
+
+int
+bignum_equal_p_unsigned(bignum_type x, bignum_type y)
{
- GC_AND_POP_BIGNUMS(x,y);
- switch(s48_bignum_compare(x,y))
- {
- case bignum_comparison_less:
- case bignum_comparison_equal:
- dpush(T);
- break;
- case bignum_comparison_greater:
- dpush(F);
- break;
- default:
- critical_error("s48_bignum_compare returns bogus value",0);
- break;
- }
+ bignum_length_type length = (BIGNUM_LENGTH (x));
+ if (length != (BIGNUM_LENGTH (y)))
+ return (0);
+ else
+ {
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_x = (scan_x + length);
+ while (scan_x < end_x)
+ if ((*scan_x++) != (*scan_y++))
+ return (0);
+ return (1);
+ }
}
-void primitive_bignum_greater(void)
+enum bignum_comparison
+bignum_compare_unsigned(bignum_type x, bignum_type y)
{
- GC_AND_POP_BIGNUMS(x,y);
- box_boolean(s48_bignum_compare(x,y) == bignum_comparison_greater);
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+ if (x_length < y_length)
+ return (bignum_comparison_less);
+ if (x_length > y_length)
+ return (bignum_comparison_greater);
+ {
+ bignum_digit_type * start_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_x = (start_x + x_length);
+ bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length);
+ while (start_x < scan_x)
+ {
+ bignum_digit_type digit_x = (*--scan_x);
+ bignum_digit_type digit_y = (*--scan_y);
+ if (digit_x < digit_y)
+ return (bignum_comparison_less);
+ if (digit_x > digit_y)
+ return (bignum_comparison_greater);
+ }
+ }
+ return (bignum_comparison_equal);
}
-void primitive_bignum_greatereq(void)
+/* Addition */
+
+bignum_type
+bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p)
{
- GC_AND_POP_BIGNUMS(x,y);
- switch(s48_bignum_compare(x,y))
- {
- case bignum_comparison_less:
- dpush(F);
- break;
- case bignum_comparison_equal:
- case bignum_comparison_greater:
- dpush(T);
- break;
- default:
- critical_error("s48_bignum_compare returns bogus value",0);
- break;
- }
+ if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
+ {
+ bignum_type z = x;
+ x = y;
+ y = z;
+ }
+ {
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_type r = (bignum_allocate ((x_length + 1), negative_p));
+ bignum_digit_type sum;
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
+ {
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
+ while (scan_y < end_y)
+ {
+ sum = ((*scan_x++) + (*scan_y++) + carry);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*scan_r++) = sum;
+ carry = 0;
+ }
+ else
+ {
+ (*scan_r++) = (sum - BIGNUM_RADIX);
+ carry = 1;
+ }
+ }
+ }
+ {
+ bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
+ if (carry != 0)
+ while (scan_x < end_x)
+ {
+ sum = ((*scan_x++) + 1);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*scan_r++) = sum;
+ carry = 0;
+ break;
+ }
+ else
+ (*scan_r++) = (sum - BIGNUM_RADIX);
+ }
+ while (scan_x < end_x)
+ (*scan_r++) = (*scan_x++);
+ }
+ if (carry != 0)
+ {
+ (*scan_r) = 1;
+ return (r);
+ }
+ return (bignum_shorten_length (r, x_length));
+ }
}
-void primitive_bignum_not(void)
+/* Subtraction */
+
+bignum_type
+bignum_subtract_unsigned(bignum_type x, bignum_type y)
{
- maybe_gc(0);
- drepl(tag_bignum(s48_bignum_bitwise_not(
- untag_bignum_fast(dpeek()))));
+ int negative_p;
+ switch (bignum_compare_unsigned (x, y))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_less:
+ {
+ bignum_type z = x;
+ x = y;
+ y = z;
+ }
+ negative_p = 1;
+ break;
+ case bignum_comparison_greater:
+ negative_p = 0;
+ break;
+ }
+ {
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_type r = (bignum_allocate (x_length, negative_p));
+ bignum_digit_type difference;
+ bignum_digit_type borrow = 0;
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
+ {
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
+ while (scan_y < end_y)
+ {
+ difference = (((*scan_x++) - (*scan_y++)) - borrow);
+ if (difference < 0)
+ {
+ (*scan_r++) = (difference + BIGNUM_RADIX);
+ borrow = 1;
+ }
+ else
+ {
+ (*scan_r++) = difference;
+ borrow = 0;
+ }
+ }
+ }
+ {
+ bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
+ if (borrow != 0)
+ while (scan_x < end_x)
+ {
+ difference = ((*scan_x++) - borrow);
+ if (difference < 0)
+ (*scan_r++) = (difference + BIGNUM_RADIX);
+ else
+ {
+ (*scan_r++) = difference;
+ borrow = 0;
+ break;
+ }
+ }
+ BIGNUM_ASSERT (borrow == 0);
+ while (scan_x < end_x)
+ (*scan_r++) = (*scan_x++);
+ }
+ return (bignum_trim (r));
+ }
}
-void box_signed_cell(F_FIXNUM integer)
+/* Multiplication
+ Maximum value for product_low or product_high:
+ ((R * R) + (R * (R - 2)) + (R - 1))
+ Maximum value for carry: ((R * (R - 1)) + (R - 1))
+ where R == BIGNUM_RADIX_ROOT */
+
+bignum_type
+bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p)
{
- dpush(tag_integer(integer));
+ if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
+ {
+ bignum_type z = x;
+ x = y;
+ y = z;
+ }
+ {
+ bignum_digit_type carry;
+ bignum_digit_type y_digit_low;
+ bignum_digit_type y_digit_high;
+ bignum_digit_type x_digit_low;
+ bignum_digit_type x_digit_high;
+ bignum_digit_type product_low;
+ bignum_digit_type * scan_r;
+ bignum_digit_type * scan_y;
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+ bignum_type r =
+ (bignum_allocate_zeroed ((x_length + y_length), negative_p));
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * end_x = (scan_x + x_length);
+ bignum_digit_type * start_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (start_y + y_length);
+ bignum_digit_type * start_r = (BIGNUM_START_PTR (r));
+#define x_digit x_digit_high
+#define y_digit y_digit_high
+#define product_high carry
+ while (scan_x < end_x)
+ {
+ x_digit = (*scan_x++);
+ x_digit_low = (HD_LOW (x_digit));
+ x_digit_high = (HD_HIGH (x_digit));
+ carry = 0;
+ scan_y = start_y;
+ scan_r = (start_r++);
+ while (scan_y < end_y)
+ {
+ y_digit = (*scan_y++);
+ y_digit_low = (HD_LOW (y_digit));
+ y_digit_high = (HD_HIGH (y_digit));
+ product_low =
+ ((*scan_r) +
+ (x_digit_low * y_digit_low) +
+ (HD_LOW (carry)));
+ product_high =
+ ((x_digit_high * y_digit_low) +
+ (x_digit_low * y_digit_high) +
+ (HD_HIGH (product_low)) +
+ (HD_HIGH (carry)));
+ (*scan_r++) =
+ (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
+ carry =
+ ((x_digit_high * y_digit_high) +
+ (HD_HIGH (product_high)));
+ }
+ (*scan_r) += carry;
+ }
+ return (bignum_trim (r));
+#undef x_digit
+#undef y_digit
+#undef product_high
+ }
}
-F_FIXNUM unbox_signed_cell(void)
+bignum_type
+bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y,
+ int negative_p)
{
- return to_fixnum(dpop());
+ bignum_length_type length_x = (BIGNUM_LENGTH (x));
+ bignum_type p = (bignum_allocate ((length_x + 1), negative_p));
+ bignum_destructive_copy (x, p);
+ (BIGNUM_REF (p, length_x)) = 0;
+ bignum_destructive_scale_up (p, y);
+ return (bignum_trim (p));
}
-void box_unsigned_cell(CELL cell)
+void
+bignum_destructive_scale_up(bignum_type bignum, bignum_digit_type factor)
{
- dpush(tag_cell(cell));
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type two_digits;
+ bignum_digit_type product_low;
+#define product_high carry
+ bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum)));
+ BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT));
+ while (scan < end)
+ {
+ two_digits = (*scan);
+ product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry)));
+ product_high =
+ ((factor * (HD_HIGH (two_digits))) +
+ (HD_HIGH (product_low)) +
+ (HD_HIGH (carry)));
+ (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
+ carry = (HD_HIGH (product_high));
+ }
+ /* A carry here would be an overflow, i.e. it would not fit.
+ Hopefully the callers allocate enough space that this will
+ never happen.
+ */
+ BIGNUM_ASSERT (carry == 0);
+ return;
+#undef product_high
}
-F_FIXNUM unbox_unsigned_cell(void)
+void
+bignum_destructive_add(bignum_type bignum, bignum_digit_type n)
{
- return to_cell(dpop());
+ bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type digit;
+ digit = ((*scan) + n);
+ if (digit < BIGNUM_RADIX)
+ {
+ (*scan) = digit;
+ return;
+ }
+ (*scan++) = (digit - BIGNUM_RADIX);
+ while (1)
+ {
+ digit = ((*scan) + 1);
+ if (digit < BIGNUM_RADIX)
+ {
+ (*scan) = digit;
+ return;
+ }
+ (*scan++) = (digit - BIGNUM_RADIX);
+ }
}
-void box_signed_4(s32 n)
+/* Division */
+
+/* For help understanding this algorithm, see:
+ Knuth, Donald E., "The Art of Computer Programming",
+ volume 2, "Seminumerical Algorithms"
+ section 4.3.1, "Multiple-Precision Arithmetic". */
+
+void
+bignum_divide_unsigned_large_denominator(bignum_type numerator,
+ bignum_type denominator,
+ bignum_type * quotient,
+ bignum_type * remainder,
+ int q_negative_p,
+ int r_negative_p)
{
- dpush(tag_bignum(s48_long_to_bignum(n)));
+ bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1);
+ bignum_length_type length_d = (BIGNUM_LENGTH (denominator));
+ bignum_type q =
+ ((quotient != ((bignum_type *) 0))
+ ? (bignum_allocate ((length_n - length_d), q_negative_p))
+ : BIGNUM_OUT_OF_BAND);
+ bignum_type u = (bignum_allocate (length_n, r_negative_p));
+ int shift = 0;
+ BIGNUM_ASSERT (length_d > 1);
+ {
+ bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1)));
+ while (v1 < (BIGNUM_RADIX / 2))
+ {
+ v1 <<= 1;
+ shift += 1;
+ }
+ }
+ if (shift == 0)
+ {
+ bignum_destructive_copy (numerator, u);
+ (BIGNUM_REF (u, (length_n - 1))) = 0;
+ bignum_divide_unsigned_normalized (u, denominator, q);
+ }
+ else
+ {
+ bignum_type v = (bignum_allocate (length_d, 0));
+ bignum_destructive_normalization (numerator, u, shift);
+ bignum_destructive_normalization (denominator, v, shift);
+ bignum_divide_unsigned_normalized (u, v, q);
+ BIGNUM_DEALLOCATE (v);
+ if (remainder != ((bignum_type *) 0))
+ bignum_destructive_unnormalization (u, shift);
+ }
+ if (quotient != ((bignum_type *) 0))
+ (*quotient) = (bignum_trim (q));
+ if (remainder != ((bignum_type *) 0))
+ (*remainder) = (bignum_trim (u));
+ else
+ BIGNUM_DEALLOCATE (u);
+ return;
}
-s32 unbox_signed_4(void)
+void
+bignum_divide_unsigned_normalized(bignum_type u, bignum_type v, bignum_type q)
{
- return to_fixnum(dpop());
+ bignum_length_type u_length = (BIGNUM_LENGTH (u));
+ bignum_length_type v_length = (BIGNUM_LENGTH (v));
+ bignum_digit_type * u_start = (BIGNUM_START_PTR (u));
+ bignum_digit_type * u_scan = (u_start + u_length);
+ bignum_digit_type * u_scan_limit = (u_start + v_length);
+ bignum_digit_type * u_scan_start = (u_scan - v_length);
+ bignum_digit_type * v_start = (BIGNUM_START_PTR (v));
+ bignum_digit_type * v_end = (v_start + v_length);
+ bignum_digit_type * q_scan = NULL;
+ bignum_digit_type v1 = (v_end[-1]);
+ bignum_digit_type v2 = (v_end[-2]);
+ bignum_digit_type ph; /* high half of double-digit product */
+ bignum_digit_type pl; /* low half of double-digit product */
+ bignum_digit_type guess;
+ bignum_digit_type gh; /* high half-digit of guess */
+ bignum_digit_type ch; /* high half of double-digit comparand */
+ bignum_digit_type v2l = (HD_LOW (v2));
+ bignum_digit_type v2h = (HD_HIGH (v2));
+ bignum_digit_type cl; /* low half of double-digit comparand */
+#define gl ph /* low half-digit of guess */
+#define uj pl
+#define qj ph
+ bignum_digit_type gm; /* memory loc for reference parameter */
+ if (q != BIGNUM_OUT_OF_BAND)
+ q_scan = ((BIGNUM_START_PTR (q)) + (BIGNUM_LENGTH (q)));
+ while (u_scan_limit < u_scan)
+ {
+ uj = (*--u_scan);
+ if (uj != v1)
+ {
+ /* comparand =
+ (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2);
+ guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */
+ cl = (u_scan[-2]);
+ ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm)));
+ guess = gm;
+ }
+ else
+ {
+ cl = (u_scan[-2]);
+ ch = ((u_scan[-1]) + v1);
+ guess = (BIGNUM_RADIX - 1);
+ }
+ while (1)
+ {
+ /* product = (guess * v2); */
+ gl = (HD_LOW (guess));
+ gh = (HD_HIGH (guess));
+ pl = (v2l * gl);
+ ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl)));
+ pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))));
+ ph = ((v2h * gh) + (HD_HIGH (ph)));
+ /* if (comparand >= product) */
+ if ((ch > ph) || ((ch == ph) && (cl >= pl)))
+ break;
+ guess -= 1;
+ /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */
+ ch += v1;
+ /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */
+ if (ch >= BIGNUM_RADIX)
+ break;
+ }
+ qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start)));
+ if (q != BIGNUM_OUT_OF_BAND)
+ (*--q_scan) = qj;
+ }
+ return;
+#undef gl
+#undef uj
+#undef qj
}
-void box_unsigned_4(u32 n)
+bignum_digit_type
+bignum_divide_subtract(bignum_digit_type * v_start,
+ bignum_digit_type * v_end,
+ bignum_digit_type guess,
+ bignum_digit_type * u_start)
{
- dpush(tag_bignum(s48_ulong_to_bignum(n)));
+ bignum_digit_type * v_scan = v_start;
+ bignum_digit_type * u_scan = u_start;
+ bignum_digit_type carry = 0;
+ if (guess == 0) return (0);
+ {
+ bignum_digit_type gl = (HD_LOW (guess));
+ bignum_digit_type gh = (HD_HIGH (guess));
+ bignum_digit_type v;
+ bignum_digit_type pl;
+ bignum_digit_type vl;
+#define vh v
+#define ph carry
+#define diff pl
+ while (v_scan < v_end)
+ {
+ v = (*v_scan++);
+ vl = (HD_LOW (v));
+ vh = (HD_HIGH (v));
+ pl = ((vl * gl) + (HD_LOW (carry)));
+ ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry)));
+ diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))));
+ if (diff < 0)
+ {
+ (*u_scan++) = (diff + BIGNUM_RADIX);
+ carry = ((vh * gh) + (HD_HIGH (ph)) + 1);
+ }
+ else
+ {
+ (*u_scan++) = diff;
+ carry = ((vh * gh) + (HD_HIGH (ph)));
+ }
+ }
+ if (carry == 0)
+ return (guess);
+ diff = ((*u_scan) - carry);
+ if (diff < 0)
+ (*u_scan) = (diff + BIGNUM_RADIX);
+ else
+ {
+ (*u_scan) = diff;
+ return (guess);
+ }
+#undef vh
+#undef ph
+#undef diff
+ }
+ /* Subtraction generated carry, implying guess is one too large.
+ Add v back in to bring it back down. */
+ v_scan = v_start;
+ u_scan = u_start;
+ carry = 0;
+ while (v_scan < v_end)
+ {
+ bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*u_scan++) = sum;
+ carry = 0;
+ }
+ else
+ {
+ (*u_scan++) = (sum - BIGNUM_RADIX);
+ carry = 1;
+ }
+ }
+ if (carry == 1)
+ {
+ bignum_digit_type sum = ((*u_scan) + carry);
+ (*u_scan) = ((sum < BIGNUM_RADIX) ? sum : (sum - BIGNUM_RADIX));
+ }
+ return (guess - 1);
}
-u32 unbox_unsigned_4(void)
+void
+bignum_divide_unsigned_medium_denominator(bignum_type numerator,
+ bignum_digit_type denominator,
+ bignum_type * quotient,
+ bignum_type * remainder,
+ int q_negative_p,
+ int r_negative_p)
{
- return to_cell(dpop());
+ bignum_length_type length_n = (BIGNUM_LENGTH (numerator));
+ bignum_length_type length_q;
+ bignum_type q;
+ int shift = 0;
+ /* Because `bignum_digit_divide' requires a normalized denominator. */
+ while (denominator < (BIGNUM_RADIX / 2))
+ {
+ denominator <<= 1;
+ shift += 1;
+ }
+ if (shift == 0)
+ {
+ length_q = length_n;
+ q = (bignum_allocate (length_q, q_negative_p));
+ bignum_destructive_copy (numerator, q);
+ }
+ else
+ {
+ length_q = (length_n + 1);
+ q = (bignum_allocate (length_q, q_negative_p));
+ bignum_destructive_normalization (numerator, q, shift);
+ }
+ {
+ bignum_digit_type r = 0;
+ bignum_digit_type * start = (BIGNUM_START_PTR (q));
+ bignum_digit_type * scan = (start + length_q);
+ bignum_digit_type qj;
+ if (quotient != ((bignum_type *) 0))
+ {
+ while (start < scan)
+ {
+ r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
+ (*scan) = qj;
+ }
+ (*quotient) = (bignum_trim (q));
+ }
+ else
+ {
+ while (start < scan)
+ r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
+ BIGNUM_DEALLOCATE (q);
+ }
+ if (remainder != ((bignum_type *) 0))
+ {
+ if (shift != 0)
+ r >>= shift;
+ (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
+ }
+ }
+ return;
}
-void box_signed_8(s64 n)
+void
+bignum_destructive_normalization(bignum_type source, bignum_type target,
+ int shift_left)
{
- dpush(tag_bignum(s48_long_long_to_bignum(n)));
+ bignum_digit_type digit;
+ bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
+ bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source)));
+ bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target)));
+ int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left);
+ bignum_digit_type mask = ((1L << shift_right) - 1);
+ while (scan_source < end_source)
+ {
+ digit = (*scan_source++);
+ (*scan_target++) = (((digit & mask) << shift_left) | carry);
+ carry = (digit >> shift_right);
+ }
+ if (scan_target < end_target)
+ (*scan_target) = carry;
+ else
+ BIGNUM_ASSERT (carry == 0);
+ return;
}
-s64 unbox_signed_8(void)
+void
+bignum_destructive_unnormalization(bignum_type bignum, int shift_right)
{
- return s48_bignum_to_long_long(to_bignum(dpop()));
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ bignum_digit_type digit;
+ bignum_digit_type carry = 0;
+ int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right);
+ bignum_digit_type mask = ((1L << shift_right) - 1);
+ while (start < scan)
+ {
+ digit = (*--scan);
+ (*scan) = ((digit >> shift_right) | carry);
+ carry = ((digit & mask) << shift_left);
+ }
+ BIGNUM_ASSERT (carry == 0);
+ return;
}
-void box_unsigned_8(u64 n)
+/* This is a reduced version of the division algorithm, applied to the
+ case of dividing two bignum digits by one bignum digit. It is
+ assumed that the numerator, denominator are normalized. */
+
+#define BDD_STEP(qn, j) \
+{ \
+ uj = (u[j]); \
+ if (uj != v1) \
+ { \
+ uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \
+ guess = (uj_uj1 / v1); \
+ comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \
+ } \
+ else \
+ { \
+ guess = (BIGNUM_RADIX_ROOT - 1); \
+ comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \
+ } \
+ while ((guess * v2) > comparand) \
+ { \
+ guess -= 1; \
+ comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \
+ if (comparand >= BIGNUM_RADIX) \
+ break; \
+ } \
+ qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \
+}
+
+bignum_digit_type
+bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul,
+ bignum_digit_type v,
+ bignum_digit_type * q) /* return value */
{
- dpush(tag_bignum(s48_ulong_long_to_bignum(n)));
+ bignum_digit_type guess;
+ bignum_digit_type comparand;
+ bignum_digit_type v1 = (HD_HIGH (v));
+ bignum_digit_type v2 = (HD_LOW (v));
+ bignum_digit_type uj;
+ bignum_digit_type uj_uj1;
+ bignum_digit_type q1;
+ bignum_digit_type q2;
+ bignum_digit_type u [4];
+ if (uh == 0)
+ {
+ if (ul < v)
+ {
+ (*q) = 0;
+ return (ul);
+ }
+ else if (ul == v)
+ {
+ (*q) = 1;
+ return (0);
+ }
+ }
+ (u[0]) = (HD_HIGH (uh));
+ (u[1]) = (HD_LOW (uh));
+ (u[2]) = (HD_HIGH (ul));
+ (u[3]) = (HD_LOW (ul));
+ v1 = (HD_HIGH (v));
+ v2 = (HD_LOW (v));
+ BDD_STEP (q1, 0);
+ BDD_STEP (q2, 1);
+ (*q) = (HD_CONS (q1, q2));
+ return (HD_CONS ((u[2]), (u[3])));
}
-u64 unbox_unsigned_8(void)
+#undef BDD_STEP
+
+#define BDDS_MULSUB(vn, un, carry_in) \
+{ \
+ product = ((vn * guess) + carry_in); \
+ diff = (un - (HD_LOW (product))); \
+ if (diff < 0) \
+ { \
+ un = (diff + BIGNUM_RADIX_ROOT); \
+ carry = ((HD_HIGH (product)) + 1); \
+ } \
+ else \
+ { \
+ un = diff; \
+ carry = (HD_HIGH (product)); \
+ } \
+}
+
+#define BDDS_ADD(vn, un, carry_in) \
+{ \
+ sum = (vn + un + carry_in); \
+ if (sum < BIGNUM_RADIX_ROOT) \
+ { \
+ un = sum; \
+ carry = 0; \
+ } \
+ else \
+ { \
+ un = (sum - BIGNUM_RADIX_ROOT); \
+ carry = 1; \
+ } \
+}
+
+bignum_digit_type
+bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2,
+ bignum_digit_type guess, bignum_digit_type * u)
+{
+ {
+ bignum_digit_type product;
+ bignum_digit_type diff;
+ bignum_digit_type carry;
+ BDDS_MULSUB (v2, (u[2]), 0);
+ BDDS_MULSUB (v1, (u[1]), carry);
+ if (carry == 0)
+ return (guess);
+ diff = ((u[0]) - carry);
+ if (diff < 0)
+ (u[0]) = (diff + BIGNUM_RADIX);
+ else
+ {
+ (u[0]) = diff;
+ return (guess);
+ }
+ }
+ {
+ bignum_digit_type sum;
+ bignum_digit_type carry;
+ BDDS_ADD(v2, (u[2]), 0);
+ BDDS_ADD(v1, (u[1]), carry);
+ if (carry == 1)
+ (u[0]) += 1;
+ }
+ return (guess - 1);
+}
+
+#undef BDDS_MULSUB
+#undef BDDS_ADD
+
+void
+bignum_divide_unsigned_small_denominator(bignum_type numerator,
+ bignum_digit_type denominator,
+ bignum_type * quotient,
+ bignum_type * remainder,
+ int q_negative_p,
+ int r_negative_p)
{
- return s48_bignum_to_ulong_long(to_bignum(dpop()));
+ bignum_type q = (bignum_new_sign (numerator, q_negative_p));
+ bignum_digit_type r = (bignum_destructive_scale_down (q, denominator));
+ (*quotient) = (bignum_trim (q));
+ if (remainder != ((bignum_type *) 0))
+ (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
+ return;
}
+
+/* Given (denominator > 1), it is fairly easy to show that
+ (quotient_high < BIGNUM_RADIX_ROOT), after which it is easy to see
+ that all digits are < BIGNUM_RADIX. */
+
+bignum_digit_type
+bignum_destructive_scale_down(bignum_type bignum, bignum_digit_type denominator)
+{
+ bignum_digit_type numerator;
+ bignum_digit_type remainder = 0;
+ bignum_digit_type two_digits;
+#define quotient_high remainder
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ BIGNUM_ASSERT ((denominator > 1) && (denominator < BIGNUM_RADIX_ROOT));
+ while (start < scan)
+ {
+ two_digits = (*--scan);
+ numerator = (HD_CONS (remainder, (HD_HIGH (two_digits))));
+ quotient_high = (numerator / denominator);
+ numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits))));
+ (*scan) = (HD_CONS (quotient_high, (numerator / denominator)));
+ remainder = (numerator % denominator);
+ }
+ return (remainder);
+#undef quotient_high
+}
+
+bignum_type
+bignum_remainder_unsigned_small_denominator(
+ bignum_type n, bignum_digit_type d, int negative_p)
+{
+ bignum_digit_type two_digits;
+ bignum_digit_type * start = (BIGNUM_START_PTR (n));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n)));
+ bignum_digit_type r = 0;
+ BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT));
+ while (start < scan)
+ {
+ two_digits = (*--scan);
+ r =
+ ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d),
+ (HD_LOW (two_digits))))
+ % d);
+ }
+ return (bignum_digit_to_bignum (r, negative_p));
+}
+
+bignum_type
+bignum_digit_to_bignum(bignum_digit_type digit, int negative_p)
+{
+ if (digit == 0)
+ return (BIGNUM_ZERO ());
+ else
+ {
+ bignum_type result = (bignum_allocate (1, negative_p));
+ (BIGNUM_REF (result, 0)) = digit;
+ return (result);
+ }
+}
+
+/* Allocation */
+
+bignum_type
+bignum_allocate(bignum_length_type length, int negative_p)
+{
+ BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
+ {
+ bignum_type result = (BIGNUM_ALLOCATE (length));
+ BIGNUM_SET_NEGATIVE_P (result, negative_p);
+ return (result);
+ }
+}
+
+bignum_type
+bignum_allocate_zeroed(bignum_length_type length, int negative_p)
+{
+ BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
+ {
+ bignum_type result = (BIGNUM_ALLOCATE (length));
+ bignum_digit_type * scan = (BIGNUM_START_PTR (result));
+ bignum_digit_type * end = (scan + length);
+ BIGNUM_SET_NEGATIVE_P (result, negative_p);
+ while (scan < end)
+ (*scan++) = 0;
+ return (result);
+ }
+}
+
+bignum_type
+bignum_shorten_length(bignum_type bignum, bignum_length_type length)
+{
+ bignum_length_type current_length = (BIGNUM_LENGTH (bignum));
+ BIGNUM_ASSERT ((length >= 0) || (length <= current_length));
+ if (length < current_length)
+ {
+ BIGNUM_REDUCE_LENGTH (bignum, bignum, length);
+ BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
+ }
+ return (bignum);
+}
+
+bignum_type
+bignum_trim(bignum_type bignum)
+{
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum)));
+ bignum_digit_type * scan = end;
+ while ((start <= scan) && ((*--scan) == 0))
+ ;
+ scan += 1;
+ if (scan < end)
+ {
+ bignum_length_type length = (scan - start);
+ BIGNUM_REDUCE_LENGTH (bignum, bignum, length);
+ BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
+ }
+ return (bignum);
+}
+
+/* Copying */
+
+bignum_type
+bignum_copy(bignum_type source)
+{
+ bignum_type target =
+ (bignum_allocate ((BIGNUM_LENGTH (source)), (BIGNUM_NEGATIVE_P (source))));
+ bignum_destructive_copy (source, target);
+ return (target);
+}
+
+bignum_type
+bignum_new_sign(bignum_type bignum, int negative_p)
+{
+ bignum_type result =
+ (bignum_allocate ((BIGNUM_LENGTH (bignum)), negative_p));
+ bignum_destructive_copy (bignum, result);
+ return (result);
+}
+
+bignum_type
+bignum_maybe_new_sign(bignum_type bignum, int negative_p)
+{
+#ifndef BIGNUM_FORCE_NEW_RESULTS
+ if ((BIGNUM_NEGATIVE_P (bignum)) ? negative_p : (! negative_p))
+ return (bignum);
+ else
+#endif /* not BIGNUM_FORCE_NEW_RESULTS */
+ {
+ bignum_type result =
+ (bignum_allocate ((BIGNUM_LENGTH (bignum)), negative_p));
+ bignum_destructive_copy (bignum, result);
+ return (result);
+ }
+}
+
+void
+bignum_destructive_copy(bignum_type source, bignum_type target)
+{
+ bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
+ bignum_digit_type * end_source =
+ (scan_source + (BIGNUM_LENGTH (source)));
+ bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
+ while (scan_source < end_source)
+ (*scan_target++) = (*scan_source++);
+ return;
+}
+
+/* Unused
+void
+bignum_destructive_zero(bignum_type bignum)
+{
+ bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum)));
+ while (scan < end)
+ (*scan++) = 0;
+ return;
+}
+*/
+
+/*
+ * Added bitwise operations (and oddp).
+ */
+
+int
+s48_bignum_oddp (bignum_type bignum)
+{
+ return (BIGNUM_LENGTH (bignum) > 0) && (BIGNUM_REF (bignum, 0) & 1);
+}
+
+bignum_type
+s48_bignum_bitwise_not(bignum_type x)
+{
+ return s48_bignum_subtract(BIGNUM_ONE(1), x);
+}
+
+bignum_type
+s48_bignum_arithmetic_shift(bignum_type arg1, long n)
+{
+ if (BIGNUM_NEGATIVE_P(arg1) && n < 0)
+ return
+ s48_bignum_bitwise_not(bignum_magnitude_ash(s48_bignum_bitwise_not(arg1),
+ n));
+ else
+ return bignum_magnitude_ash(arg1, n);
+}
+
+/*
+ * This uses a `long'-returning bignum_length_in_bits() which we don't have.
+long
+s48_bignum_integer_length(bignum_type arg1)
+{
+ return((BIGNUM_NEGATIVE_P (arg1))
+ ? bignum_length_in_bits (s48_bignum_bitwise_not (arg1))
+ : bignum_length_in_bits (arg1));
+}
+*/
+
+long
+s48_bignum_bit_count(bignum_type arg1)
+{
+ return((BIGNUM_NEGATIVE_P (arg1))
+ ? bignum_unsigned_logcount (s48_bignum_bitwise_not (arg1))
+ : bignum_unsigned_logcount (arg1));
+}
+
+#define AND_OP 0
+#define IOR_OP 1
+#define XOR_OP 2
+
+bignum_type
+s48_bignum_bitwise_and(bignum_type arg1, bignum_type arg2)
+{
+ return(
+ (BIGNUM_NEGATIVE_P (arg1))
+ ? (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_negneg_bitwise_op(AND_OP, arg1, arg2)
+ : bignum_posneg_bitwise_op(AND_OP, arg2, arg1)
+ : (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_posneg_bitwise_op(AND_OP, arg1, arg2)
+ : bignum_pospos_bitwise_op(AND_OP, arg1, arg2)
+ );
+}
+
+bignum_type
+s48_bignum_bitwise_ior(bignum_type arg1, bignum_type arg2)
+{
+ return(
+ (BIGNUM_NEGATIVE_P (arg1))
+ ? (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_negneg_bitwise_op(IOR_OP, arg1, arg2)
+ : bignum_posneg_bitwise_op(IOR_OP, arg2, arg1)
+ : (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_posneg_bitwise_op(IOR_OP, arg1, arg2)
+ : bignum_pospos_bitwise_op(IOR_OP, arg1, arg2)
+ );
+}
+
+bignum_type
+s48_bignum_bitwise_xor(bignum_type arg1, bignum_type arg2)
+{
+ return(
+ (BIGNUM_NEGATIVE_P (arg1))
+ ? (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_negneg_bitwise_op(XOR_OP, arg1, arg2)
+ : bignum_posneg_bitwise_op(XOR_OP, arg2, arg1)
+ : (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_posneg_bitwise_op(XOR_OP, arg1, arg2)
+ : bignum_pospos_bitwise_op(XOR_OP, arg1, arg2)
+ );
+}
+
+/* ash for the magnitude */
+/* assume arg1 is a big number, n is a long */
+bignum_type
+bignum_magnitude_ash(bignum_type arg1, long n)
+{
+ bignum_type result = NULL;
+ bignum_digit_type *scan1;
+ bignum_digit_type *scanr;
+ bignum_digit_type *end;
+
+ long digit_offset,bit_offset;
+
+ if (BIGNUM_ZERO_P (arg1)) return (arg1);
+
+ if (n > 0) {
+ digit_offset = n / BIGNUM_DIGIT_LENGTH;
+ bit_offset = n % BIGNUM_DIGIT_LENGTH;
+
+ result = bignum_allocate_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1,
+ BIGNUM_NEGATIVE_P(arg1));
+
+ scanr = BIGNUM_START_PTR (result) + digit_offset;
+ scan1 = BIGNUM_START_PTR (arg1);
+ end = scan1 + BIGNUM_LENGTH (arg1);
+
+ while (scan1 < end) {
+ *scanr = *scanr | (*scan1 & BIGNUM_DIGIT_MASK) << bit_offset;
+ *scanr = *scanr & BIGNUM_DIGIT_MASK;
+ scanr++;
+ *scanr = *scan1++ >> (BIGNUM_DIGIT_LENGTH - bit_offset);
+ *scanr = *scanr & BIGNUM_DIGIT_MASK;
+ }
+ }
+ else if (n < 0
+ && (-n >= (BIGNUM_LENGTH (arg1) * (bignum_length_type) BIGNUM_DIGIT_LENGTH)))
+ result = BIGNUM_ZERO ();
+
+ else if (n < 0) {
+ digit_offset = -n / BIGNUM_DIGIT_LENGTH;
+ bit_offset = -n % BIGNUM_DIGIT_LENGTH;
+
+ result = bignum_allocate_zeroed (BIGNUM_LENGTH (arg1) - digit_offset,
+ BIGNUM_NEGATIVE_P(arg1));
+
+ scanr = BIGNUM_START_PTR (result);
+ scan1 = BIGNUM_START_PTR (arg1) + digit_offset;
+ end = scanr + BIGNUM_LENGTH (result) - 1;
+
+ while (scanr < end) {
+ *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
+ *scanr = (*scanr |
+ *scan1 << (BIGNUM_DIGIT_LENGTH - bit_offset)) & BIGNUM_DIGIT_MASK;
+ scanr++;
+ }
+ *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
+ }
+ else if (n == 0) result = arg1;
+
+ return (bignum_trim (result));
+}
+
+bignum_type
+bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
+{
+ bignum_type result;
+ bignum_length_type max_length;
+
+ bignum_digit_type *scan1, *end1, digit1;
+ bignum_digit_type *scan2, *end2, digit2;
+ bignum_digit_type *scanr, *endr;
+
+ max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
+ ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2);
+
+ result = bignum_allocate(max_length, 0);
+
+ scanr = BIGNUM_START_PTR(result);
+ scan1 = BIGNUM_START_PTR(arg1);
+ scan2 = BIGNUM_START_PTR(arg2);
+ endr = scanr + max_length;
+ end1 = scan1 + BIGNUM_LENGTH(arg1);
+ end2 = scan2 + BIGNUM_LENGTH(arg2);
+
+ while (scanr < endr) {
+ digit1 = (scan1 < end1) ? *scan1++ : 0;
+ digit2 = (scan2 < end2) ? *scan2++ : 0;
+ /*
+ fprintf(stderr, "[pospos op = %d, i = %ld, d1 = %lx, d2 = %lx]\n",
+ op, endr - scanr, digit1, digit2);
+ */
+ *scanr++ = (op == 0) ? digit1 & digit2 :
+ (op == 1) ? digit1 | digit2 :
+ digit1 ^ digit2;
+ }
+ return bignum_trim(result);
+}
+
+bignum_type
+bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
+{
+ bignum_type result;
+ bignum_length_type max_length;
+
+ bignum_digit_type *scan1, *end1, digit1;
+ bignum_digit_type *scan2, *end2, digit2, carry2;
+ bignum_digit_type *scanr, *endr;
+
+ char neg_p = op == IOR_OP || op == XOR_OP;
+
+ max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2) + 1)
+ ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2) + 1;
+
+ result = bignum_allocate(max_length, neg_p);
+
+ scanr = BIGNUM_START_PTR(result);
+ scan1 = BIGNUM_START_PTR(arg1);
+ scan2 = BIGNUM_START_PTR(arg2);
+ endr = scanr + max_length;
+ end1 = scan1 + BIGNUM_LENGTH(arg1);
+ end2 = scan2 + BIGNUM_LENGTH(arg2);
+
+ carry2 = 1;
+
+ while (scanr < endr) {
+ digit1 = (scan1 < end1) ? *scan1++ : 0;
+ digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK)
+ + carry2;
+
+ if (digit2 < BIGNUM_RADIX)
+ carry2 = 0;
+ else
+ {
+ digit2 = (digit2 - BIGNUM_RADIX);
+ carry2 = 1;
+ }
+
+ *scanr++ = (op == AND_OP) ? digit1 & digit2 :
+ (op == IOR_OP) ? digit1 | digit2 :
+ digit1 ^ digit2;
+ }
+
+ if (neg_p)
+ bignum_negate_magnitude(result);
+
+ return bignum_trim(result);
+}
+
+bignum_type
+bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
+{
+ bignum_type result;
+ bignum_length_type max_length;
+
+ bignum_digit_type *scan1, *end1, digit1, carry1;
+ bignum_digit_type *scan2, *end2, digit2, carry2;
+ bignum_digit_type *scanr, *endr;
+
+ char neg_p = op == AND_OP || op == IOR_OP;
+
+ max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
+ ? BIGNUM_LENGTH(arg1) + 1 : BIGNUM_LENGTH(arg2) + 1;
+
+ result = bignum_allocate(max_length, neg_p);
+
+ scanr = BIGNUM_START_PTR(result);
+ scan1 = BIGNUM_START_PTR(arg1);
+ scan2 = BIGNUM_START_PTR(arg2);
+ endr = scanr + max_length;
+ end1 = scan1 + BIGNUM_LENGTH(arg1);
+ end2 = scan2 + BIGNUM_LENGTH(arg2);
+
+ carry1 = 1;
+ carry2 = 1;
+
+ while (scanr < endr) {
+ digit1 = (~((scan1 < end1) ? *scan1++ : 0) & BIGNUM_DIGIT_MASK) + carry1;
+ digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK) + carry2;
+
+ if (digit1 < BIGNUM_RADIX)
+ carry1 = 0;
+ else
+ {
+ digit1 = (digit1 - BIGNUM_RADIX);
+ carry1 = 1;
+ }
+
+ if (digit2 < BIGNUM_RADIX)
+ carry2 = 0;
+ else
+ {
+ digit2 = (digit2 - BIGNUM_RADIX);
+ carry2 = 1;
+ }
+
+ *scanr++ = (op == 0) ? digit1 & digit2 :
+ (op == 1) ? digit1 | digit2 :
+ digit1 ^ digit2;
+ }
+
+ if (neg_p)
+ bignum_negate_magnitude(result);
+
+ return bignum_trim(result);
+}
+
+void
+bignum_negate_magnitude(bignum_type arg)
+{
+ bignum_digit_type *scan;
+ bignum_digit_type *end;
+ bignum_digit_type digit;
+ bignum_digit_type carry;
+
+ scan = BIGNUM_START_PTR(arg);
+ end = scan + BIGNUM_LENGTH(arg);
+
+ carry = 1;
+
+ while (scan < end) {
+ digit = (~*scan & BIGNUM_DIGIT_MASK) + carry;
+
+ if (digit < BIGNUM_RADIX)
+ carry = 0;
+ else
+ {
+ digit = (digit - BIGNUM_RADIX);
+ carry = 1;
+ }
+
+ *scan++ = digit;
+ }
+}
+
+long
+bignum_unsigned_logcount(bignum_type arg)
+{
+
+ bignum_digit_type *scan;
+ bignum_digit_type *end;
+ bignum_digit_type digit;
+
+ /* sufficient for any reasonable big number */
+ long result;
+ int i;
+
+ if (BIGNUM_ZERO_P (arg)) return (0L);
+
+ scan = BIGNUM_START_PTR (arg);
+ end = scan + BIGNUM_LENGTH (arg);
+ result = 0L;
+
+ while (scan < end) {
+ digit = *scan++ & BIGNUM_DIGIT_MASK;
+ for (i = 0; i++ < BIGNUM_DIGIT_LENGTH; digit = digit >> 1L)
+ result += digit & 1L;
+ }
+
+ return (result);
+}
+
+int
+bignum_logbitp(int shift, bignum_type arg)
+{
+ return((BIGNUM_NEGATIVE_P (arg))
+ ? !bignum_unsigned_logbitp (shift, s48_bignum_bitwise_not (arg))
+ : bignum_unsigned_logbitp (shift,arg));
+}
+
+int
+bignum_unsigned_logbitp(int shift, bignum_type bignum)
+{
+ bignum_length_type len = (BIGNUM_LENGTH (bignum));
+ bignum_digit_type digit;
+ int index = shift / BIGNUM_DIGIT_LENGTH;
+ int p;
+ if (index >= len)
+ return 0;
+ digit = (BIGNUM_REF (bignum, index));
+ p = shift % BIGNUM_DIGIT_LENGTH;
+ return digit & (1 << p);
+}
+
-CELL bignum_zero;
-CELL bignum_pos_one;
-CELL bignum_neg_one;
+/* -*-C-*-
-INLINE F_ARRAY* untag_bignum_fast(CELL tagged)
-{
- return (F_ARRAY*)UNTAG(tagged);
-}
+$Id: s48_bignum.h,v 1.13 2005/12/21 02:36:52 spestov Exp $
-INLINE CELL tag_bignum(F_ARRAY* bignum)
-{
- return RETAG(bignum,BIGNUM_TYPE);
-}
-
-CELL to_cell(CELL x);
-F_ARRAY* to_bignum(CELL tagged);
-void primitive_to_bignum(void);
-void primitive_bignum_eq(void);
-void primitive_bignum_add(void);
-void primitive_bignum_subtract(void);
-void primitive_bignum_multiply(void);
-void primitive_bignum_divint(void);
-void primitive_bignum_divfloat(void);
-void primitive_bignum_divmod(void);
-void primitive_bignum_mod(void);
-void primitive_bignum_and(void);
-void primitive_bignum_or(void);
-void primitive_bignum_xor(void);
-void primitive_bignum_shift(void);
-void primitive_bignum_less(void);
-void primitive_bignum_lesseq(void);
-void primitive_bignum_greater(void);
-void primitive_bignum_greatereq(void);
-void primitive_bignum_not(void);
-
-INLINE CELL tag_integer(F_FIXNUM x)
-{
- if(x < FIXNUM_MIN || x > FIXNUM_MAX)
- return tag_bignum(s48_fixnum_to_bignum(x));
- else
- return tag_fixnum(x);
-}
+Copyright (c) 1989-1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy and modify this software, to
+redistribute either the original software or a modified version, and
+to use this software for any purpose is granted, subject to the
+following restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* External Interface to Bignum Code */
+
+/* The `unsigned long' type is used for the conversion procedures
+ `bignum_to_long' and `long_to_bignum'. Older implementations of C
+ don't support this type; if you have such an implementation you can
+ disable these procedures using the following flag (alternatively
+ you could write alternate versions that don't require this type). */
+/* #define BIGNUM_NO_ULONG */
+
+typedef F_ARRAY * bignum_type;
+#define BIGNUM_OUT_OF_BAND ((bignum_type) 0)
-INLINE CELL tag_cell(CELL x)
+enum bignum_comparison
{
- if(x > FIXNUM_MAX)
- return tag_bignum(s48_cell_to_bignum(x));
- else
- return tag_fixnum(x);
-}
+ bignum_comparison_equal = 0,
+ bignum_comparison_less = -1,
+ bignum_comparison_greater = 1
+};
-/* FFI calls this */
-DLLEXPORT void box_signed_cell(F_FIXNUM integer);
-DLLEXPORT F_FIXNUM unbox_signed_cell(void);
+typedef void * bignum_procedure_context;
+int s48_bignum_equal_p(bignum_type, bignum_type);
+enum bignum_comparison s48_bignum_test(bignum_type);
+enum bignum_comparison s48_bignum_compare(bignum_type, bignum_type);
+bignum_type s48_bignum_add(bignum_type, bignum_type);
+bignum_type s48_bignum_subtract(bignum_type, bignum_type);
+bignum_type s48_bignum_negate(bignum_type);
+bignum_type s48_bignum_multiply(bignum_type, bignum_type);
+void
+s48_bignum_divide(bignum_type numerator, bignum_type denominator,
+ bignum_type * quotient, bignum_type * remainder);
+bignum_type s48_bignum_quotient(bignum_type, bignum_type);
+bignum_type s48_bignum_remainder(bignum_type, bignum_type);
+DLLEXPORT bignum_type s48_fixnum_to_bignum(F_FIXNUM);
+DLLEXPORT bignum_type s48_cell_to_bignum(CELL);
+DLLEXPORT bignum_type s48_long_to_bignum(long);
+DLLEXPORT bignum_type s48_long_long_to_bignum(s64 n);
+DLLEXPORT bignum_type s48_ulong_long_to_bignum(u64 n);
+DLLEXPORT bignum_type s48_ulong_to_bignum(unsigned long);
+DLLEXPORT bignum_type s48_fixnum_pair_to_bignum(CELL x, F_FIXNUM y);
+F_FIXNUM s48_bignum_to_fixnum(bignum_type);
+CELL s48_bignum_to_cell(bignum_type);
+long s48_bignum_to_long(bignum_type);
+unsigned long s48_bignum_to_ulong(bignum_type);
+s64 s48_bignum_to_long_long(bignum_type);
+u64 s48_bignum_to_ulong_long(bignum_type);
+bignum_type s48_double_to_bignum(double);
+double s48_bignum_to_double(bignum_type);
+int s48_bignum_fits_in_word_p(bignum_type, long word_length,
+ int twos_complement_p);
+bignum_type s48_bignum_length_in_bits(bignum_type);
+bignum_type s48_bignum_length_upper_limit(void);
+bignum_type s48_digit_stream_to_bignum
+ (unsigned int n_digits,
+ unsigned int (*producer(bignum_procedure_context)),
+ bignum_procedure_context context,
+ unsigned int radix,
+ int negative_p);
+long s48_bignum_max_digit_stream_radix(void);
-DLLEXPORT void box_unsigned_cell(CELL cell);
-DLLEXPORT F_FIXNUM unbox_unsigned_cell(void);
+/* Added bitwise operators. */
-DLLEXPORT void box_signed_4(s32 n);
-DLLEXPORT s32 unbox_signed_4(void);
+DLLEXPORT bignum_type s48_bignum_bitwise_not(bignum_type),
+ s48_bignum_arithmetic_shift(bignum_type, long),
+ s48_bignum_bitwise_and(bignum_type, bignum_type),
+ s48_bignum_bitwise_ior(bignum_type, bignum_type),
+ s48_bignum_bitwise_xor(bignum_type, bignum_type);
-DLLEXPORT void box_unsigned_4(u32 n);
-DLLEXPORT u32 unbox_unsigned_4(void);
+int s48_bignum_oddp(bignum_type);
+long s48_bignum_bit_count(bignum_type);
-DLLEXPORT void box_signed_8(s64 n);
-DLLEXPORT s64 unbox_signed_8(void);
+/* Forward references */
+int bignum_equal_p_unsigned(bignum_type, bignum_type);
+enum bignum_comparison bignum_compare_unsigned(bignum_type, bignum_type);
+bignum_type bignum_add_unsigned(bignum_type, bignum_type, int);
+bignum_type bignum_subtract_unsigned(bignum_type, bignum_type);
+bignum_type bignum_multiply_unsigned(bignum_type, bignum_type, int);
+bignum_type bignum_multiply_unsigned_small_factor
+ (bignum_type, bignum_digit_type, int);
+void bignum_destructive_scale_up(bignum_type, bignum_digit_type);
+void bignum_destructive_add(bignum_type, bignum_digit_type);
+void bignum_divide_unsigned_large_denominator
+ (bignum_type, bignum_type, bignum_type *, bignum_type *, int, int);
+void bignum_destructive_normalization(bignum_type, bignum_type, int);
+void bignum_destructive_unnormalization(bignum_type, int);
+void bignum_divide_unsigned_normalized(bignum_type, bignum_type, bignum_type);
+bignum_digit_type bignum_divide_subtract
+ (bignum_digit_type *, bignum_digit_type *, bignum_digit_type,
+ bignum_digit_type *);
+void bignum_divide_unsigned_medium_denominator
+ (bignum_type, bignum_digit_type, bignum_type *, bignum_type *, int, int);
+bignum_digit_type bignum_digit_divide
+ (bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *);
+bignum_digit_type bignum_digit_divide_subtract
+ (bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *);
+void bignum_divide_unsigned_small_denominator
+ (bignum_type, bignum_digit_type, bignum_type *, bignum_type *, int, int);
+bignum_digit_type bignum_destructive_scale_down
+ (bignum_type, bignum_digit_type);
+bignum_type bignum_remainder_unsigned_small_denominator
+ (bignum_type, bignum_digit_type, int);
+bignum_type bignum_digit_to_bignum(bignum_digit_type, int);
+bignum_type bignum_allocate(bignum_length_type, int);
+bignum_type bignum_allocate_zeroed(bignum_length_type, int);
+bignum_type bignum_shorten_length(bignum_type, bignum_length_type);
+bignum_type bignum_trim(bignum_type);
+bignum_type bignum_copy(bignum_type);
+bignum_type bignum_new_sign(bignum_type, int);
+bignum_type bignum_maybe_new_sign(bignum_type, int);
+void bignum_destructive_copy(bignum_type, bignum_type);
+/* Unused
+void bignum_destructive_zero(bignum_type);
+*/
-DLLEXPORT void box_unsigned_8(u64 n);
-DLLEXPORT u64 unbox_unsigned_8(void);
+/* Added for bitwise operations. */
+bignum_type bignum_magnitude_ash(bignum_type arg1, long n);
+bignum_type bignum_pospos_bitwise_op(int op, bignum_type, bignum_type);
+bignum_type bignum_posneg_bitwise_op(int op, bignum_type, bignum_type);
+bignum_type bignum_negneg_bitwise_op(int op, bignum_type, bignum_type);
+void bignum_negate_magnitude(bignum_type);
+long bignum_unsigned_logcount(bignum_type arg);
+int bignum_unsigned_logbitp(int shift, bignum_type bignum);
--- /dev/null
+/* -*-C-*-
+
+$Id: s48_bignumint.h,v 1.14 2005/12/21 02:36:52 spestov Exp $
+
+Copyright (c) 1989-1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy and modify this software, to
+redistribute either the original software or a modified version, and
+to use this software for any purpose is granted, subject to the
+following restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Internal Interface to Bignum Code */
+#undef BIGNUM_ZERO_P
+#undef BIGNUM_NEGATIVE_P
+
+/* The memory model is based on the following definitions, and on the
+ definition of the type `bignum_type'. The only other special
+ definition is `CHAR_BIT', which is defined in the Ansi C header
+ file "limits.h". */
+
+typedef F_FIXNUM bignum_digit_type;
+typedef F_FIXNUM bignum_length_type;
+
+/* BIGNUM_ALLOCATE allocates a (length + 1)-element array of
+ `bignum_digit_type'; deallocation is the responsibility of the
+ user (in Factor, the garbage collector handles this). */
+#define BIGNUM_ALLOCATE(length_in_digits) \
+ allot_array(BIGNUM_TYPE,length_in_digits + 1)
+
+/* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */
+#define BIGNUM_TO_POINTER(bignum) ((CELL*)AREF(bignum,0))
+
+/* BIGNUM_REDUCE_LENGTH allows the memory system to reclaim some
+ space when a bignum's length is reduced from its original value. */
+#define BIGNUM_REDUCE_LENGTH(target, source, length) \
+ target = resize_array(source, length + 1,0)
+
+/* BIGNUM_DEALLOCATE is called when disposing of bignums which are
+ created as intermediate temporaries; Scheme doesn't need this. */
+#define BIGNUM_DEALLOCATE(bignum)
+
+/* If BIGNUM_FORCE_NEW_RESULTS is defined, all bignum-valued operations
+ return freshly-allocated results. This is useful for some kinds of
+ memory deallocation strategies. */
+/* #define BIGNUM_FORCE_NEW_RESULTS */
+
+/* BIGNUM_EXCEPTION is invoked to handle assertion violations. */
+#define BIGNUM_EXCEPTION abort
+
+
+#define BIGNUM_DIGIT_LENGTH (((sizeof (bignum_digit_type)) * CHAR_BIT) - 2)
+#define BIGNUM_HALF_DIGIT_LENGTH (BIGNUM_DIGIT_LENGTH / 2)
+#define BIGNUM_RADIX (((CELL) 1) << BIGNUM_DIGIT_LENGTH)
+#define BIGNUM_RADIX_ROOT (((CELL) 1) << BIGNUM_HALF_DIGIT_LENGTH)
+#define BIGNUM_DIGIT_MASK (BIGNUM_RADIX - 1)
+#define BIGNUM_HALF_DIGIT_MASK (BIGNUM_RADIX_ROOT - 1)
+
+#define BIGNUM_START_PTR(bignum) \
+ ((BIGNUM_TO_POINTER (bignum)) + 1)
+
+#define BIGNUM_LENGTH(bignum) (untag_fixnum_fast((bignum)->capacity) - 1)
+
+#define BIGNUM_NEGATIVE_P(bignum) (get(AREF(bignum,0)) != 0)
+#define BIGNUM_SET_NEGATIVE_P(bignum,neg) put(AREF(bignum,0),neg)
+
+#define BIGNUM_ZERO_P(bignum) \
+ ((BIGNUM_LENGTH (bignum)) == 0)
+
+#define BIGNUM_REF(bignum, index) \
+ (* ((BIGNUM_START_PTR (bignum)) + (index)))
+
+#ifdef BIGNUM_FORCE_NEW_RESULTS
+#define BIGNUM_MAYBE_COPY bignum_copy
+#else
+#define BIGNUM_MAYBE_COPY(bignum) bignum
+#endif
+
+/* These definitions are here to facilitate caching of the constants
+ 0, 1, and -1. */
+#define BIGNUM_ZERO() (F_ARRAY*)UNTAG(bignum_zero)
+#define BIGNUM_ONE(neg_p) \
+ (F_ARRAY*)UNTAG(neg_p ? bignum_neg_one : bignum_pos_one)
+
+#define BIGNUM_ONE_P(bignum,negative_p) ((bignum) == BIGNUM_ONE(negative_p))
+
+#define HD_LOW(digit) ((digit) & BIGNUM_HALF_DIGIT_MASK)
+#define HD_HIGH(digit) ((digit) >> BIGNUM_HALF_DIGIT_LENGTH)
+#define HD_CONS(high, low) (((high) << BIGNUM_HALF_DIGIT_LENGTH) | (low))
+
+#define BIGNUM_BITS_TO_DIGITS(n) \
+ (((n) + (BIGNUM_DIGIT_LENGTH - 1)) / BIGNUM_DIGIT_LENGTH)
+
+#define BIGNUM_DIGITS_FOR(type) \
+ (BIGNUM_BITS_TO_DIGITS ((sizeof (type)) * CHAR_BIT))
+
+#ifndef BIGNUM_DISABLE_ASSERTION_CHECKS
+
+#define BIGNUM_ASSERT(expression) \
+{ \
+ if (! (expression)) \
+ BIGNUM_EXCEPTION (); \
+}
+
+#endif /* not BIGNUM_DISABLE_ASSERTION_CHECKS */
+++ /dev/null
-#include "factor.h"
-
-/* FFI calls this */
-void box_boolean(bool value)
-{
- dpush(value ? T : F);
-}
-
-/* FFI calls this */
-bool unbox_boolean(void)
-{
- return (dpop() != F);
-}
+++ /dev/null
-INLINE CELL tag_boolean(CELL untagged)
-{
- return (untagged == false ? F : T);
-}
-
-DLLEXPORT void box_boolean(bool value);
-DLLEXPORT bool unbox_boolean(void);
+++ /dev/null
-#include "factor.h"
-
-/* scan all the objects in the card */
-INLINE void collect_card(CARD *ptr, CELL here)
-{
- CARD c = *ptr;
- CELL offset = (c & CARD_BASE_MASK);
- CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
- CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
-
- if(offset == 0x7f)
- {
- if(c == 0xff)
- critical_error("bad card",(CELL)ptr);
- else
- return;
- }
-
- while(card_scan < card_end && card_scan < here)
- card_scan = collect_next(card_scan);
-
- cards_scanned++;
-}
-
-INLINE void collect_gen_cards(CELL gen)
-{
- CARD *ptr = ADDR_TO_CARD(generations[gen].base);
- CELL here = generations[gen].here;
- CARD *last_card = ADDR_TO_CARD(here);
-
- if(generations[gen].here == generations[gen].limit)
- last_card--;
-
- for(; ptr <= last_card; ptr++)
- {
- if(card_marked(*ptr))
- collect_card(ptr,here);
- }
-}
-
-void unmark_cards(CELL from, CELL to)
-{
- CARD *ptr = ADDR_TO_CARD(generations[from].base);
- CARD *last_card = ADDR_TO_CARD(generations[to].here);
- if(generations[to].here == generations[to].limit)
- last_card--;
- for(; ptr <= last_card; ptr++)
- unmark_card(ptr);
-}
-
-void clear_cards(CELL from, CELL to)
-{
- /* NOTE: reverse order due to heap layout. */
- CARD *last_card = ADDR_TO_CARD(generations[from].limit);
- CARD *ptr = ADDR_TO_CARD(generations[to].base);
- for(; ptr < last_card; ptr++)
- clear_card(ptr);
-}
-
-/* scan cards in all generations older than the one being collected */
-void collect_cards(CELL gen)
-{
- int i;
- for(i = gen + 1; i < gen_count; i++)
- collect_gen_cards(i);
-}
+++ /dev/null
-CELL heap_start;
-CELL heap_end;
-
-/* card marking write barrier. a card is a byte storing a mark flag,
-and the offset (in cells) of the first object in the card.
-
-the mark flag is set by the write barrier when an object in the
-card has a slot written to.
-
-the offset of the first object is set by the allocator.
-*/
-#define CARD_MARK_MASK 0x80
-#define CARD_BASE_MASK 0x7f
-typedef u8 CARD;
-
-CARD *cards;
-CARD *cards_end;
-
-/* A card is 16 bytes (128 bits), 5 address bits per card.
-it is important that 7 bits is sufficient to represent every
-offset within the card */
-#define CARD_SIZE 128
-#define CARD_BITS 7
-#define ADDR_CARD_MASK (CARD_SIZE-1)
-
-INLINE CARD card_marked(CARD c)
-{
- return c & CARD_MARK_MASK;
-}
-
-INLINE void unmark_card(CARD *c)
-{
- *c &= CARD_BASE_MASK;
-}
-
-INLINE void clear_card(CARD *c)
-{
- *c = CARD_BASE_MASK; /* invalid value */
-}
-
-INLINE u8 card_base(CARD c)
-{
- return c & CARD_BASE_MASK;
-}
-
-#define ADDR_TO_CARD(a) (CARD*)(((CELL)a >> CARD_BITS) + cards_offset)
-#define CARD_TO_ADDR(c) (CELL*)(((CELL)c - cards_offset)<<CARD_BITS)
-
-/* this is an inefficient write barrier. compiled definitions use a more
-efficient one hand-coded in assembly. the write barrier must be called
-any time we are potentially storing a pointer from an older generation
-to a younger one */
-INLINE void write_barrier(CELL address)
-{
- CARD *c = ADDR_TO_CARD(address);
- *c |= CARD_MARK_MASK;
-}
-
-/* we need to remember the first object allocated in the card */
-INLINE void allot_barrier(CELL address)
-{
- CARD *ptr = ADDR_TO_CARD(address);
- CARD c = *ptr;
- CELL b = card_base(c);
- CELL a = (address & ADDR_CARD_MASK);
- *ptr = (card_marked(c) | ((b < a) ? b : a));
-}
-
-void unmark_cards(CELL from, CELL to);
-void clear_cards(CELL from, CELL to);
-void collect_cards(CELL gen);
+++ /dev/null
-#include "factor.h"
-
-void init_compiler(CELL size)
-{
- compiling.base = compiling.here = (CELL)(alloc_bounded_block(size)->start);
- if(compiling.base == 0)
- fatal_error("Cannot allocate code heap",size);
- compiling.limit = compiling.base + size;
- last_flush = compiling.base;
-}
-
-void primitive_compiled_offset(void)
-{
- box_unsigned_cell(compiling.here);
-}
-
-void primitive_set_compiled_offset(void)
-{
- CELL offset = unbox_unsigned_cell();
- compiling.here = offset;
- if(compiling.here >= compiling.limit)
- {
- fprintf(stderr,"Code space exhausted\n");
- factorbug();
- }
-}
-
-void primitive_add_literal(void)
-{
- CELL object = dpeek();
- CELL offset = literal_top;
- put(literal_top,object);
- literal_top += CELLS;
- if(literal_top >= literal_max)
- critical_error("Too many compiled literals",literal_top);
- drepl(tag_cell(offset));
-}
-
-void primitive_flush_icache(void)
-{
- flush_icache((void*)last_flush,compiling.here - last_flush);
- last_flush = compiling.here;
-}
-
-void collect_literals(void)
-{
- CELL i;
- for(i = compiling.base; i < literal_top; i += CELLS)
- copy_handle((CELL*)i);
-}
+++ /dev/null
-/* The compiled code heap is structured into blocks. */
-typedef struct
-{
- CELL header; /* = COMPILED_HEADER */
- CELL code_length;
- CELL reloc_length; /* see relocate.h */
-} F_COMPILED;
-
-#define COMPILED_HEADER 0x01c3babe
-
-ZONE compiling;
-
-CELL literal_top;
-CELL literal_max;
-
-void init_compiler(CELL size);
-void primitive_compiled_offset(void);
-void primitive_set_compiled_offset(void);
-void primitive_add_literal(void);
-void collect_literals(void);
-
-#ifdef FACTOR_PPC
-void flush_icache(void *start, int len);
-#else
-INLINE void flush_icache(void *start, int len) {}
-#endif
-
-CELL last_flush;
-
-void primitive_flush_icache(void);
+++ /dev/null
-#include "factor.h"
-
-void primitive_from_rect(void)
-{
- CELL real, imaginary;
- F_COMPLEX* complex;
-
- maybe_gc(sizeof(F_COMPLEX));
-
- imaginary = dpop();
- real = dpop();
- complex = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX));
- complex->real = real;
- complex->imaginary = imaginary;
- dpush(RETAG(complex,COMPLEX_TYPE));
-}
-
-void fixup_complex(F_COMPLEX* complex)
-{
- data_fixup(&complex->real);
- data_fixup(&complex->imaginary);
-}
-
-void collect_complex(F_COMPLEX* complex)
-{
- copy_handle(&complex->real);
- copy_handle(&complex->imaginary);
-}
+++ /dev/null
-typedef struct {
- CELL header;
- CELL real;
- CELL imaginary;
-} F_COMPLEX;
-
-void primitive_from_rect(void);
-void fixup_complex(F_COMPLEX* complex);
-void collect_complex(F_COMPLEX* complex);
--- /dev/null
+#define FACTOR_CPU_STRING "amd64"
+
+register CELL ds asm("r14");
+register CELL rs asm("r15");
+register CELL cards_offset asm("r13");
+
+INLINE void flush_icache(void *start, int len) {}
--- /dev/null
+#define FACTOR_CPU_STRING "ppc"
+
+register CELL ds asm("r14");
+register CELL rs asm("r15");
+register CELL cards_offset asm("r16");
+
+void flush_icache(void *start, int len);
--- /dev/null
+#define FACTOR_CPU_STRING "ppc"
+
+register CELL ds asm("esi");
+register CELL rs asm("edi");
+CELL cards_offset;
+
+INLINE void flush_icache(void *start, int len) {}
void factorbug(void)
{
-#ifndef WIN32
- fcntl(0,F_SETFL,0);
- fcntl(1,F_SETFL,0);
-#endif
+ reset_stdio();
- fprintf(stderr," Front end processor commands:\n");
+ fprintf(stderr,"A fatal error has occurred and Factor cannot continue.\n");
+ fprintf(stderr,"The low-level debugger has been started to help diagnose the problem.\n");
+ fprintf(stderr," Basic commands:\n");
fprintf(stderr,"t -- throw exception in Factor\n");
fprintf(stderr,"q -- continue executing Factor\n");
fprintf(stderr,"im -- save image to fep.image\n");
{
char cmd[1024];
- fprintf(stderr,"fep> ");
+ fprintf(stderr,"READY\n");
fflush(stdout);
if(scanf("%1000s",cmd) <= 0)
+++ /dev/null
-#include "factor.h"
-
-void primitive_dlopen(void)
-{
- DLL* dll;
- F_STRING* path;
-
- maybe_gc(sizeof(DLL));
-
- path = untag_string(dpop());
- dll = allot_object(DLL_TYPE,sizeof(DLL));
- dll->path = tag_object(path);
- ffi_dlopen(dll,true);
-
- dpush(tag_object(dll));
-}
-
-void primitive_dlsym(void)
-{
- CELL dll;
- F_STRING *sym;
- DLL *d;
-
- maybe_gc(0);
-
- dll = dpop();
- sym = untag_string(dpop());
-
- if(dll == F)
- d = NULL;
- else
- {
- d = untag_dll(dll);
- if(d->dll == NULL)
- general_error(ERROR_EXPIRED,dll,F,true);
- }
-
- dpush(tag_cell((CELL)ffi_dlsym(d,sym,true)));
-}
-
-void primitive_dlclose(void)
-{
- ffi_dlclose(untag_dll(dpop()));
-}
-
-void fixup_dll(DLL* dll)
-{
- data_fixup(&dll->path);
- ffi_dlopen(dll,false);
-}
-
-void collect_dll(DLL* dll)
-{
- copy_handle(&dll->path);
-}
+++ /dev/null
-typedef struct {
- CELL header;
- /* tagged string */
- CELL path;
- /* OS-specific handle */
- void* dll;
-} DLL;
-
-INLINE DLL *untag_dll(CELL tagged)
-{
- type_check(DLL_TYPE,tagged);
- return (DLL*)UNTAG(tagged);
-}
-
-void init_ffi(void);
-
-void ffi_dlopen(DLL *dll, bool error);
-void *ffi_dlsym(DLL *dll, F_STRING *symbol, bool error);
-void ffi_dlclose(DLL *dll);
-
-void primitive_dlopen(void);
-void primitive_dlsym(void);
-void primitive_dlclose(void);
-
-void fixup_dll(DLL* dll);
-void collect_dll(DLL* dll);
+++ /dev/null
-#include "factor.h"
-
-void fatal_error(char* msg, CELL tagged)
-{
- fprintf(stderr,"Fatal error: %s %ld\n",msg,tagged);
- exit(1);
-}
-
-void critical_error(char* msg, CELL tagged)
-{
- fprintf(stderr,"Critical error: %s %ld\n",msg,tagged);
- factorbug();
-}
-
-void early_error(CELL error)
-{
- if(userenv[BREAK_ENV] == F)
- {
- /* Crash at startup */
- fprintf(stderr,"Error during startup: ");
- print_obj(error);
- fprintf(stderr,"\n");
- factorbug();
- }
-}
-
-void throw_error(CELL error, bool keep_stacks)
-{
- early_error(error);
-
- throwing = true;
- thrown_error = error;
- thrown_keep_stacks = keep_stacks;
- thrown_ds = ds;
- thrown_rs = rs;
-
- /* Return to run() method */
- LONGJMP(stack_chain->toplevel,1);
-}
-
-void primitive_throw(void)
-{
- throw_error(dpop(),true);
-}
-
-void primitive_die(void)
-{
- factorbug();
-}
-
-void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, bool keep_stacks)
-{
- throw_error(make_array_4(userenv[ERROR_ENV],
- tag_fixnum(error),arg1,arg2),keep_stacks);
-}
-
-/* It is not safe to access 'ds' from a signal handler, so we just not
-touch it */
-void signal_error(int signal)
-{
- general_error(ERROR_SIGNAL,tag_fixnum(signal),F,false);
-}
-
-void type_error(CELL type, CELL tagged)
-{
- general_error(ERROR_TYPE,tag_fixnum(type),tagged,true);
-}
+++ /dev/null
-typedef enum
-{
- ERROR_EXPIRED,
- ERROR_IO,
- ERROR_UNDEFINED_WORD,
- ERROR_TYPE,
- ERROR_SIGNAL,
- ERROR_NEGATIVE_ARRAY_SIZE,
- ERROR_C_STRING,
- ERROR_FFI,
- ERROR_HEAP_SCAN,
- ERROR_UNDEFINED_SYMBOL,
- ERROR_USER_INTERRUPT,
- ERROR_DS_UNDERFLOW,
- ERROR_DS_OVERFLOW,
- ERROR_RS_UNDERFLOW,
- ERROR_RS_OVERFLOW,
- ERROR_CS_UNDERFLOW,
- ERROR_CS_OVERFLOW,
- ERROR_OBJECTIVE_C
-} F_ERRORTYPE;
-
-/* Are we throwing an error? */
-bool throwing;
-/* When throw_error throws an error, it sets this global and
-longjmps back to the top-level. */
-CELL thrown_error;
-CELL thrown_keep_stacks;
-/* Since longjmp restores registers, we must save all these values. */
-CELL thrown_ds;
-CELL thrown_rs;
-
-void fatal_error(char* msg, CELL tagged);
-void critical_error(char* msg, CELL tagged);
-void throw_error(CELL error, bool keep_stacks);
-void early_error(CELL error);
-void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, bool keep_stacks);
-void signal_error(int signal);
-void type_error(CELL type, CELL tagged);
-void primitive_throw(void);
-void primitive_die(void);
return false;
}
-void usage(void)
-{
- printf("Usage: factor <image file> [ parameters ... ]\n");
- printf("Runtime options -- n is a number:\n");
- printf(" -D=n Data stack size, kilobytes\n");
- printf(" -R=n Retain stack size, kilobytes\n");
- printf(" -C=n Call stack size, kilobytes\n");
- printf(" -G=n Number of generations, must be >= 2\n");
- printf(" -Y=n Size of n-1 youngest generations, megabytes\n");
- printf(" -A=n Size of tenured and semi-spaces, megabytes\n");
- printf(" -X=n Code heap size, megabytes\n");
- printf("Other options are handled by the Factor library.\n");
- printf("See the documentation for details.\n");
- printf("Send bug reports to Slava Pestov <slava@factorcode.org>.\n");
-}
-
int main(int argc, char** argv)
{
const char *image = NULL;
if(factor_arg(argv[i],"-A=%d",&aging_size)) continue;
if(factor_arg(argv[i],"-X=%d",&code_size)) continue;
- if(strncmp(argv[i],"+",1) == 0)
- {
- printf("Unknown option: %s\n",argv[i]);
- usage();
- return 1;
- }
-
if(strncmp(argv[i],"-",1) != 0 && image == NULL)
image = argv[1];
}
#ifndef __FACTOR_H__
#define __FACTOR_H__
-#include "platform.h"
-
-#ifdef _WIN64
- typedef long long F_FIXNUM;
- typedef unsigned long long CELL;
-#else
- typedef long F_FIXNUM;
- typedef unsigned long CELL;
-#endif
-
-#define CELLS ((signed)sizeof(CELL))
-
-#define WORD_SIZE (CELLS*8)
-#define HALF_WORD_SIZE (CELLS*4)
-#define HALF_WORD_MASK (((unsigned long)1<<HALF_WORD_SIZE)-1)
-
-#define FIXNUM_MAX (((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)) - 1)
-#define FIXNUM_MIN (-((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)))
-
-/* must always be 16 bits */
-#define CHARS ((signed)sizeof(u16))
-
-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;
-
-CELL cs;
-
-#if defined(FACTOR_X86)
- register CELL ds asm("esi");
- register CELL rs asm("edi");
- CELL cards_offset;
-#elif defined(FACTOR_PPC)
- register CELL ds asm("r14");
- register CELL rs asm("r15");
- register CELL cards_offset asm("r16");
-#elif defined(FACTOR_AMD64)
- register CELL ds asm("r14");
- register CELL rs asm("r15");
- register CELL cards_offset asm("r13");
-#else
- CELL ds;
- CELL rs;
- CELL cards_offset;
-#endif
-
-/* TAGGED currently executing quotation */
-CELL callframe;
-
-/* UNTAGGED currently executing word in quotation */
-CELL callframe_scan;
-
-/* UNTAGGED end of quotation */
-CELL callframe_end;
-
#include <errno.h>
#include <fcntl.h>
#include <limits.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
-
#include <sys/param.h>
-#ifdef WIN32
- #include <windows.h>
- #include <ctype.h>
-
- /* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
- #define EPOCH_OFFSET 0x019db1ded53e8000LL
-#else
- #include <dirent.h>
- #include <sys/mman.h>
- #include <sys/types.h>
- #include <sys/stat.h>
- #include <unistd.h>
- #include <sys/time.h>
- #include <dlfcn.h>
-#endif
-
+#include "layouts.h"
+#include "platform.h"
#include "debug.h"
-#include "error.h"
-#include "cards.h"
-#include "memory.h"
-#include "gc.h"
-#include "boolean.h"
-#include "word.h"
#include "run.h"
-#include "signal.h"
-#include "fixnum.h"
-#include "array.h"
-#include "s48_bignumint.h"
-#include "s48_bignum.h"
+#include "memory.h"
+#include "bignumint.h"
#include "bignum.h"
-#include "ratio.h"
-#include "float.h"
-#include "complex.h"
-#include "string.h"
-#include "misc.h"
-#include "sbuf.h"
+#include "math.h"
+#include "types.h"
#include "io.h"
-#include "file.h"
#include "image.h"
#include "primitives.h"
-#include "vector.h"
-#include "hashtable.h"
#include "stack.h"
-#include "compiler.h"
-#include "relocate.h"
#include "alien.h"
-#include "dll.h"
-#include "wrapper.h"
-
-void usage(void);
-
-void early_init(void);
-
-const char *default_image_path(void);
#endif /* __FACTOR_H__ */
+++ /dev/null
-#define FILE_MODE 0600
-
-void primitive_open_file(void);
-void primitive_stat(void);
-void primitive_read_dir(void);
-void primitive_cwd(void);
-void primitive_cd(void);
+++ /dev/null
-#include "factor.h"
-
-F_FIXNUM to_fixnum(CELL tagged)
-{
- F_RATIO* r;
- F_ARRAY* x;
- F_ARRAY* y;
- F_FLOAT* f;
-
- switch(TAG(tagged))
- {
- case FIXNUM_TYPE:
- return untag_fixnum_fast(tagged);
- case BIGNUM_TYPE:
- return (F_FIXNUM)s48_bignum_to_fixnum((F_ARRAY*)UNTAG(tagged));
- case RATIO_TYPE:
- r = (F_RATIO*)UNTAG(tagged);
- x = to_bignum(r->numerator);
- y = to_bignum(r->denominator);
- return to_fixnum(tag_bignum(s48_bignum_quotient(x,y)));
- case FLOAT_TYPE:
- f = (F_FLOAT*)UNTAG(tagged);
- return (F_FIXNUM)f->n;
- default:
- type_error(FIXNUM_TYPE,tagged);
- return -1; /* can't happen */
- }
-}
-
-void primitive_to_fixnum(void)
-{
- drepl(tag_fixnum(to_fixnum(dpeek())));
-}
-
-#define POP_FIXNUMS(x,y) \
- F_FIXNUM x, y; \
- y = untag_fixnum_fast(dpop()); \
- x = untag_fixnum_fast(dpop());
-
-/* The fixnum arithmetic operations defined in C are relatively slow.
-The Factor compiler has optimized assembly intrinsics for all these
-operations. */
-void primitive_fixnum_add(void)
-{
- POP_FIXNUMS(x,y)
- box_signed_cell(x + y);
-}
-
-void primitive_fixnum_add_fast(void)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x + y));
-}
-
-void primitive_fixnum_subtract(void)
-{
- POP_FIXNUMS(x,y)
- box_signed_cell(x - y);
-}
-
-void primitive_fixnum_subtract_fast(void)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x - y));
-}
-
-/**
- * Multiply two integers, and trap overflow.
- * Thanks to David Blaikie (The_Vulture from freenode #java) for the hint.
- */
-void primitive_fixnum_multiply(void)
-{
- POP_FIXNUMS(x,y)
-
- if(x == 0 || y == 0)
- dpush(tag_fixnum(0));
- else
- {
- F_FIXNUM prod = x * y;
- /* if this is not equal, we have overflow */
- if(prod / x == y)
- box_signed_cell(prod);
- else
- {
- dpush(tag_bignum(
- s48_bignum_multiply(
- s48_fixnum_to_bignum(x),
- s48_fixnum_to_bignum(y))));
- }
- }
-}
-
-void primitive_fixnum_divint(void)
-{
- POP_FIXNUMS(x,y)
- box_signed_cell(x / y);
-}
-
-void primitive_fixnum_divfloat(void)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_float((double)x / (double)y));
-}
-
-void primitive_fixnum_divmod(void)
-{
- POP_FIXNUMS(x,y)
- box_signed_cell(x / y);
- box_signed_cell(x % y);
-}
-
-void primitive_fixnum_mod(void)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x % y));
-}
-
-void primitive_fixnum_and(void)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x & y));
-}
-
-void primitive_fixnum_or(void)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x | y));
-}
-
-void primitive_fixnum_xor(void)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x ^ y));
-}
-
-/*
- * Note the hairy overflow check.
- * If we're shifting right by n bits, we won't overflow as long as none of the
- * high WORD_SIZE-TAG_BITS-n bits are set.
- */
-void primitive_fixnum_shift(void)
-{
- POP_FIXNUMS(x,y)
-
- if(x == 0 || y == 0)
- {
- dpush(tag_fixnum(x));
- return;
- }
- else if(y < 0)
- {
- if(y <= -WORD_SIZE)
- dpush(x < 0 ? tag_fixnum(-1) : tag_fixnum(0));
- else
- dpush(tag_fixnum(x >> -y));
- return;
- }
- else if(y < WORD_SIZE - TAG_BITS)
- {
- F_FIXNUM mask = -(1 << (WORD_SIZE - 1 - TAG_BITS - y));
- if((x > 0 && (x & mask) == 0) || (x & mask) == mask)
- {
- dpush(tag_fixnum(x << y));
- return;
- }
- }
-
- dpush(tag_bignum(s48_bignum_arithmetic_shift(
- s48_fixnum_to_bignum(x),y)));
-}
-
-void primitive_fixnum_less(void)
-{
- POP_FIXNUMS(x,y)
- box_boolean(x < y);
-}
-
-void primitive_fixnum_lesseq(void)
-{
- POP_FIXNUMS(x,y)
- box_boolean(x <= y);
-}
-
-void primitive_fixnum_greater(void)
-{
- POP_FIXNUMS(x,y)
- box_boolean(x > y);
-}
-
-void primitive_fixnum_greatereq(void)
-{
- POP_FIXNUMS(x,y)
- box_boolean(x >= y);
-}
-
-void primitive_fixnum_not(void)
-{
- drepl(tag_fixnum(~untag_fixnum_fast(dpeek())));
-}
-
-#define DEFBOX(name,type) \
-void name (type integer) \
-{ \
- dpush(tag_integer(integer)); \
-}
-
-#define DEFUNBOX(name,type) \
-type name(void) \
-{ \
- return to_fixnum(dpop()); \
-}
-
-DEFBOX(box_signed_1, signed char)
-DEFBOX(box_signed_2, signed short)
-DEFBOX(box_unsigned_1, unsigned char)
-DEFBOX(box_unsigned_2, unsigned short)
-DEFUNBOX(unbox_signed_1, signed char)
-DEFUNBOX(unbox_signed_2, signed short)
-DEFUNBOX(unbox_unsigned_1, unsigned char)
-DEFUNBOX(unbox_unsigned_2, unsigned short)
+++ /dev/null
-INLINE F_FIXNUM untag_fixnum_fast(CELL tagged)
-{
- return ((F_FIXNUM)tagged) >> TAG_BITS;
-}
-
-INLINE CELL tag_fixnum(F_FIXNUM untagged)
-{
- return RETAG(untagged << TAG_BITS,FIXNUM_TYPE);
-}
-
-F_FIXNUM to_fixnum(CELL tagged);
-void primitive_to_fixnum(void);
-
-void primitive_fixnum_add(void);
-void primitive_fixnum_subtract(void);
-void primitive_fixnum_add_fast(void);
-void primitive_fixnum_subtract_fast(void);
-void primitive_fixnum_multiply(void);
-void primitive_fixnum_divint(void);
-void primitive_fixnum_divfloat(void);
-void primitive_fixnum_divmod(void);
-void primitive_fixnum_mod(void);
-void primitive_fixnum_and(void);
-void primitive_fixnum_or(void);
-void primitive_fixnum_xor(void);
-void primitive_fixnum_shift(void);
-void primitive_fixnum_less(void);
-void primitive_fixnum_lesseq(void);
-void primitive_fixnum_greater(void);
-void primitive_fixnum_greatereq(void);
-void primitive_fixnum_not(void);
-DLLEXPORT void box_signed_1(signed char integer);
-DLLEXPORT void box_signed_2(signed short integer);
-DLLEXPORT void box_unsigned_1(unsigned char integer);
-DLLEXPORT void box_unsigned_2(unsigned short integer);
-DLLEXPORT signed char unbox_signed_1(void);
-DLLEXPORT signed short unbox_signed_2(void);
-DLLEXPORT unsigned char unbox_unsigned_1(void);
-DLLEXPORT unsigned short unbox_unsigned_2(void);
+++ /dev/null
-#include "factor.h"
-
-double to_float(CELL tagged)
-{
- F_RATIO* r;
- double x;
- double y;
-
- switch(TAG(tagged))
- {
- case FIXNUM_TYPE:
- return (double)untag_fixnum_fast(tagged);
- case BIGNUM_TYPE:
- return s48_bignum_to_double((F_ARRAY*)UNTAG(tagged));
- case RATIO_TYPE:
- r = (F_RATIO*)UNTAG(tagged);
- x = to_float(r->numerator);
- y = to_float(r->denominator);
- return x / y;
- case FLOAT_TYPE:
- return ((F_FLOAT*)UNTAG(tagged))->n;
- default:
- type_error(FLOAT_TYPE,tagged);
- return 0.0; /* can't happen */
- }
-}
-
-void primitive_to_float(void)
-{
- maybe_gc(sizeof(F_FLOAT));
- drepl(tag_float(to_float(dpeek())));
-}
-
-void primitive_str_to_float(void)
-{
- F_STRING* str;
- char *c_str, *end;
- double f;
-
- maybe_gc(sizeof(F_FLOAT));
-
- str = untag_string(dpeek());
- c_str = to_char_string(str,true);
- end = c_str;
- f = strtod(c_str,&end);
- if(end != c_str + string_capacity(str))
- drepl(F);
- else
- drepl(tag_float(f));
-}
-
-void primitive_float_to_str(void)
-{
- char tmp[33];
-
- maybe_gc(sizeof(F_FLOAT));
-
- snprintf(tmp,32,"%.16g",to_float(dpop()));
- tmp[32] = '\0';
- box_char_string(tmp);
-}
-
-#define GC_AND_POP_FLOATS(x,y) \
- double x, y; \
- maybe_gc(sizeof(F_FLOAT)); \
- y = untag_float_fast(dpop()); \
- x = untag_float_fast(dpop());
-
-void primitive_float_add(void)
-{
- GC_AND_POP_FLOATS(x,y);
- dpush(tag_float(x + y));
-}
-
-void primitive_float_subtract(void)
-{
- GC_AND_POP_FLOATS(x,y);
- dpush(tag_float(x - y));
-}
-
-void primitive_float_multiply(void)
-{
- GC_AND_POP_FLOATS(x,y);
- dpush(tag_float(x * y));
-}
-
-void primitive_float_divfloat(void)
-{
- GC_AND_POP_FLOATS(x,y);
- dpush(tag_float(x / y));
-}
-
-void primitive_float_mod(void)
-{
- GC_AND_POP_FLOATS(x,y);
- dpush(tag_float(fmod(x,y)));
-}
-
-void primitive_float_less(void)
-{
- GC_AND_POP_FLOATS(x,y);
- box_boolean(x < y);
-}
-
-void primitive_float_lesseq(void)
-{
- GC_AND_POP_FLOATS(x,y);
- box_boolean(x <= y);
-}
-
-void primitive_float_greater(void)
-{
- GC_AND_POP_FLOATS(x,y);
- box_boolean(x > y);
-}
-
-void primitive_float_greatereq(void)
-{
- GC_AND_POP_FLOATS(x,y);
- box_boolean(x >= y);
-}
-
-void primitive_facos(void)
-{
- maybe_gc(sizeof(F_FLOAT));
- drepl(tag_float(acos(to_float(dpeek()))));
-}
-
-void primitive_fasin(void)
-{
- maybe_gc(sizeof(F_FLOAT));
- drepl(tag_float(asin(to_float(dpeek()))));
-}
-
-void primitive_fatan(void)
-{
- maybe_gc(sizeof(F_FLOAT));
- drepl(tag_float(atan(to_float(dpeek()))));
-}
-
-void primitive_fatan2(void)
-{
- double x, y;
- maybe_gc(sizeof(F_FLOAT));
- y = to_float(dpop());
- x = to_float(dpop());
- dpush(tag_float(atan2(x,y)));
-}
-
-void primitive_fcos(void)
-{
- maybe_gc(sizeof(F_FLOAT));
- drepl(tag_float(cos(to_float(dpeek()))));
-}
-
-void primitive_fexp(void)
-{
- maybe_gc(sizeof(F_FLOAT));
- drepl(tag_float(exp(to_float(dpeek()))));
-}
-
-void primitive_fcosh(void)
-{
- maybe_gc(sizeof(F_FLOAT));
- drepl(tag_float(cosh(to_float(dpeek()))));
-}
-
-void primitive_flog(void)
-{
- maybe_gc(sizeof(F_FLOAT));
- drepl(tag_float(log(to_float(dpeek()))));
-}
-
-void primitive_fpow(void)
-{
- double x, y;
- maybe_gc(sizeof(F_FLOAT));
- y = to_float(dpop());
- x = to_float(dpop());
- dpush(tag_float(pow(x,y)));
-}
-
-void primitive_fsin(void)
-{
- maybe_gc(sizeof(F_FLOAT));
- drepl(tag_float(sin(to_float(dpeek()))));
-}
-
-void primitive_fsinh(void)
-{
- maybe_gc(sizeof(F_FLOAT));
- drepl(tag_float(sinh(to_float(dpeek()))));
-}
-
-void primitive_fsqrt(void)
-{
- maybe_gc(sizeof(F_FLOAT));
- drepl(tag_float(sqrt(to_float(dpeek()))));
-}
-
-void primitive_float_bits(void)
-{
- FLOAT_BITS b;
- b.x = (float)to_float(dpeek());
- drepl(tag_cell(b.y));
-}
-
-void primitive_bits_float(void)
-{
- FLOAT_BITS b;
- b.y = unbox_unsigned_4();
- dpush(tag_float(b.x));
-}
-
-void primitive_double_bits(void)
-{
- DOUBLE_BITS b;
- b.x = to_float(dpop());
- box_unsigned_8(b.y);
-}
-
-void primitive_bits_double(void)
-{
- DOUBLE_BITS b;
- b.y = unbox_unsigned_8();
- dpush(tag_float(b.x));
-}
-
-#define DEFBOX(name,type) \
-void name (type flo) \
-{ \
- dpush(tag_float(flo)); \
-}
-
-#define DEFUNBOX(name,type) \
-type name(void) \
-{ \
- return to_float(dpop()); \
-}
-
-DEFBOX(box_float,float)
-DEFUNBOX(unbox_float,float)
-DEFBOX(box_double,double)
-DEFUNBOX(unbox_double,double)
+++ /dev/null
-typedef struct {
-/* C sucks. */
- union {
- CELL header;
- long long padding;
- };
- double n;
-} F_FLOAT;
-
-/* for punning */
-typedef union {
- double x;
- u64 y;
-} DOUBLE_BITS;
-
-typedef union {
- float x;
- u32 y;
-} FLOAT_BITS;
-
-INLINE F_FLOAT* make_float(double n)
-{
- F_FLOAT* flo = allot_object(FLOAT_TYPE,sizeof(F_FLOAT));
- flo->n = n;
- return flo;
-}
-
-INLINE double untag_float_fast(CELL tagged)
-{
- return ((F_FLOAT*)UNTAG(tagged))->n;
-}
-
-INLINE CELL tag_float(double flo)
-{
- return RETAG(make_float(flo),FLOAT_TYPE);
-}
-
-double to_float(CELL tagged);
-void primitive_to_float(void);
-void primitive_str_to_float(void);
-void primitive_float_to_str(void);
-void primitive_float_to_bits(void);
-
-void primitive_float_add(void);
-void primitive_float_subtract(void);
-void primitive_float_multiply(void);
-void primitive_float_divfloat(void);
-void primitive_float_mod(void);
-void primitive_float_less(void);
-void primitive_float_lesseq(void);
-void primitive_float_greater(void);
-void primitive_float_greatereq(void);
-
-void primitive_facos(void);
-void primitive_fasin(void);
-void primitive_fatan(void);
-void primitive_fatan2(void);
-void primitive_fcos(void);
-void primitive_fexp(void);
-void primitive_fcosh(void);
-void primitive_flog(void);
-void primitive_fpow(void);
-void primitive_fsin(void);
-void primitive_fsinh(void);
-void primitive_fsqrt(void);
-
-void primitive_float_bits(void);
-void primitive_bits_float(void);
-void primitive_double_bits(void);
-void primitive_bits_double(void);
-
-DLLEXPORT void box_float(float flo);
-DLLEXPORT float unbox_float(void);
-DLLEXPORT void box_double(double flo);
-DLLEXPORT double unbox_double(void);
+++ /dev/null
-#include "factor.h"
-
-/* Generational copying garbage collector */
-
-CELL init_zone(ZONE *z, CELL size, CELL base)
-{
- z->base = z->here = base;
- z->limit = z->base + size;
- z->alarm = z->base + (size * 3) / 4;
- return z->limit;
-}
-
-/* update this global variable. since it is stored in a non-volatile register,
-we need to save its contents and re-initialize it when entering a callback,
-and restore its contents when leaving the callback. see stack.c */
-void update_cards_offset(void)
-{
- cards_offset = (CELL)cards - (heap_start >> CARD_BITS);
-}
-
-/* input parameters must be 8 byte aligned */
-/* the heap layout is important:
-- two semispaces: tenured and prior
-- younger generations follow
-there are two reasons for this:
-- we can easily check if a pointer is in some generation or a younger one
-- the nursery grows into the guard page, so allot() does not have to
-check for out of memory, whereas allot_zone() (used by the GC) longjmp()s
-back to collecting a higher generation */
-void init_arena(CELL gens, CELL young_size, CELL aging_size)
-{
- int i;
- CELL alloter;
-
- CELL total_size = (gens - 1) * young_size + 2 * aging_size;
- CELL cards_size = total_size / CARD_SIZE;
-
- gen_count = gens;
- generations = safe_malloc(sizeof(ZONE) * gen_count);
-
- heap_start = (CELL)(alloc_bounded_block(total_size)->start);
- heap_end = heap_start + total_size;
-
- cards = safe_malloc(cards_size);
- cards_end = cards + cards_size;
- update_cards_offset();
-
- alloter = heap_start;
-
- alloter = init_zone(&tenured,aging_size,alloter);
- alloter = init_zone(&prior,aging_size,alloter);
-
- for(i = gen_count - 2; i >= 0; i--)
- alloter = init_zone(&generations[i],young_size,alloter);
-
- clear_cards(NURSERY,TENURED);
-
- if(alloter != heap_start + total_size)
- fatal_error("Oops",alloter);
-
- heap_scan = false;
- gc_time = 0;
- minor_collections = 0;
- cards_scanned = 0;
-}
-
-void collect_callframe_triple(CELL *callframe,
- CELL *callframe_scan, CELL *callframe_end)
-{
- *callframe_scan -= *callframe;
- *callframe_end -= *callframe;
- copy_handle(callframe);
- *callframe_scan += *callframe;
- *callframe_end += *callframe;
-}
-
-void collect_stack(BOUNDED_BLOCK *region, CELL top)
-{
- CELL bottom = region->start;
- CELL ptr;
-
- for(ptr = bottom; ptr <= top; ptr += CELLS)
- copy_handle((CELL*)ptr);
-}
-
-void collect_callstack(BOUNDED_BLOCK *region, CELL top)
-{
- CELL bottom = region->start;
- CELL ptr;
-
- for(ptr = bottom; ptr <= top; ptr += CELLS * 3)
- collect_callframe_triple((CELL*)ptr,
- (CELL*)ptr + 1, (CELL*)ptr + 2);
-}
-
-void collect_roots(void)
-{
- int i;
- STACKS *stacks;
-
- copy_handle(&T);
- copy_handle(&bignum_zero);
- copy_handle(&bignum_pos_one);
- copy_handle(&bignum_neg_one);
- collect_callframe_triple(&callframe,&callframe_scan,&callframe_end);
-
- save_stacks();
- stacks = stack_chain;
-
- while(stacks)
- {
- collect_stack(stacks->data_region,stacks->data);
- collect_stack(stacks->retain_region,stacks->retain);
-
- collect_callstack(stacks->call_region,stacks->call);
-
- if(stacks->next != NULL)
- {
- collect_callframe_triple(&stacks->callframe,
- &stacks->callframe_scan,&stacks->callframe_end);
- }
-
- copy_handle(&stacks->catch_save);
-
- stacks = stacks->next;
- }
-
- for(i = 0; i < USER_ENV; i++)
- copy_handle(&userenv[i]);
-}
-
-/* Given a pointer to oldspace, copy it to newspace. */
-INLINE void *copy_untagged_object(void *pointer, CELL size)
-{
- void *newpointer;
- if(newspace->here + size >= newspace->limit)
- longjmp(gc_jmp,1);
- newpointer = allot_zone(newspace,size);
- memcpy(newpointer,pointer,size);
- return newpointer;
-}
-
-INLINE CELL copy_object_impl(CELL pointer)
-{
- CELL newpointer = (CELL)copy_untagged_object((void*)UNTAG(pointer),
- object_size(pointer));
-
- /* install forwarding pointer */
- put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED));
-
- return newpointer;
-}
-
-/* follow a chain of forwarding pointers */
-CELL resolve_forwarding(CELL untagged, CELL tag)
-{
- CELL header = get(untagged);
- /* another forwarding pointer */
- if(TAG(header) == GC_COLLECTED)
- return resolve_forwarding(UNTAG(header),tag);
- /* we've found the destination */
- else
- {
- CELL pointer = RETAG(untagged,tag);
- if(should_copy(untagged))
- pointer = RETAG(copy_object_impl(pointer),tag);
- return pointer;
- }
-}
-
-/*
-Given a pointer to a tagged pointer to oldspace, copy it to newspace.
-If the object has already been copied, return the forwarding
-pointer address without copying anything; otherwise, install
-a new forwarding pointer.
-*/
-CELL copy_object(CELL pointer)
-{
- CELL tag;
- CELL header;
-
- if(pointer == F)
- return F;
-
- tag = TAG(pointer);
-
- if(tag == FIXNUM_TYPE)
- return pointer;
-
- header = get(UNTAG(pointer));
- if(TAG(header) == GC_COLLECTED)
- return resolve_forwarding(UNTAG(header),tag);
- else
- return RETAG(copy_object_impl(pointer),tag);
-}
-
-INLINE void collect_object(CELL scan)
-{
- switch(untag_header(get(scan)))
- {
- case RATIO_TYPE:
- collect_ratio((F_RATIO*)scan);
- break;
- case COMPLEX_TYPE:
- collect_complex((F_COMPLEX*)scan);
- break;
- case WORD_TYPE:
- collect_word((F_WORD*)scan);
- break;
- case ARRAY_TYPE:
- case TUPLE_TYPE:
- case QUOTATION_TYPE:
- collect_array((F_ARRAY*)scan);
- break;
- case HASHTABLE_TYPE:
- collect_hashtable((F_HASHTABLE*)scan);
- break;
- case VECTOR_TYPE:
- collect_vector((F_VECTOR*)scan);
- break;
- case SBUF_TYPE:
- collect_sbuf((F_SBUF*)scan);
- break;
- case DLL_TYPE:
- collect_dll((DLL*)scan);
- break;
- case ALIEN_TYPE:
- collect_alien((ALIEN*)scan);
- break;
- case WRAPPER_TYPE:
- collect_wrapper((F_WRAPPER*)scan);
- break;
- }
-}
-
-CELL collect_next(CELL scan)
-{
- CELL size = untagged_object_size(scan);
- collect_object(scan);
- return scan + size;
-}
-
-void reset_generations(CELL from, CELL to)
-{
- CELL i;
- for(i = from; i <= to; i++)
- generations[i].here = generations[i].base;
- clear_cards(from,to);
-}
-
-void begin_gc(CELL gen)
-{
- collecting_gen = gen;
- collecting_gen_start = generations[gen].base;
-
- if(gen == TENURED)
- {
- /* when collecting the oldest generation, rotate it
- with the semispace */
- ZONE z = generations[gen];
- generations[gen] = prior;
- prior = z;
- generations[gen].here = generations[gen].base;
- newspace = &generations[gen];
- clear_cards(TENURED,TENURED);
- }
- else
- {
- /* when collecting a younger generation, we copy
- reachable objects to the next oldest generation,
- so we set the newspace so the next generation. */
- newspace = &generations[gen + 1];
- }
-}
-
-void end_gc(CELL gen)
-{
- if(gen == TENURED)
- {
- /* we did a full collection; no more
- old-to-new pointers remain since everything
- is in tenured space */
- unmark_cards(TENURED,TENURED);
- /* all generations except tenured space are
- now empty */
- reset_generations(NURSERY,TENURED - 1);
-
- fprintf(stderr,"*** Major GC (%ld minor, %ld cards)\n",
- minor_collections,cards_scanned);
- minor_collections = 0;
- cards_scanned = 0;
- }
- else
- {
- /* we collected a younger generation. so the
- next-oldest generation no longer has any
- pointers into the younger generation (the
- younger generation is empty!) */
- unmark_cards(gen + 1,gen + 1);
- /* all generations up to and including the one
- collected are now empty */
- reset_generations(NURSERY,gen);
-
- minor_collections++;
- }
-}
-
-/* collect gen and all younger generations */
-void garbage_collection(CELL gen)
-{
- s64 start = current_millis();
- CELL scan;
-
- if(heap_scan)
- critical_error("GC disabled during heap scan",gen);
-
- /* we come back here if a generation is full */
- if(setjmp(gc_jmp))
- {
- if(gen == TENURED)
- {
- /* oops, out of memory */
- critical_error("Out of memory",0);
- }
- else
- gen++;
- }
-
- begin_gc(gen);
-
- /* initialize chase pointer */
- scan = newspace->here;
-
- /* collect objects referenced from stacks and environment */
- collect_roots();
-
- /* collect objects referenced from older generations */
- collect_cards(gen);
-
- /* collect literal objects referenced from compiled code */
- collect_literals();
-
- while(scan < newspace->here)
- scan = collect_next(scan);
-
- end_gc(gen);
-
- gc_time += (current_millis() - start);
-}
-
-void primitive_gc(void)
-{
- CELL gen = to_fixnum(dpop());
- if(gen <= NURSERY)
- gen = NURSERY;
- else if(gen >= TENURED)
- gen = TENURED;
- garbage_collection(gen);
-}
-
-/* WARNING: only call this from a context where all local variables
-are also reachable via the GC roots. */
-void maybe_gc(CELL size)
-{
- if(nursery.here + size > nursery.alarm)
- {
- CELL gen = NURSERY;
- while(gen < TENURED)
- {
- ZONE *z = &generations[gen + 1];
- if(z->here < z->alarm)
- break;
- gen++;
- }
-
- garbage_collection(gen);
- }
-}
-
-void simple_gc(void)
-{
- maybe_gc(0);
-}
-
-void primitive_gc_time(void)
-{
- simple_gc();
- dpush(tag_bignum(s48_long_long_to_bignum(gc_time)));
-}
+++ /dev/null
-/* generational copying GC divides memory into zones */
-typedef struct {
- /* start of zone */
- CELL base;
- /* allocation pointer */
- CELL here;
- /* only for nursery: when it gets this full, call GC */
- CELL alarm;
- /* end of zone */
- CELL limit;
-} ZONE;
-
-/* total number of generations. */
-CELL gen_count;
-
-/* the 0th generation is where new objects are allocated. */
-#define NURSERY 0
-/* the oldest generation */
-#define TENURED (gen_count-1)
-
-DLLEXPORT ZONE *generations;
-
-/* used during garbage collection only */
-ZONE *newspace;
-
-#define tenured generations[TENURED]
-#define nursery generations[NURSERY]
-
-/* spare semi-space; rotates with tenured. */
-ZONE prior;
-
-INLINE bool in_zone(ZONE* z, CELL pointer)
-{
- return pointer >= z->base && pointer < z->limit;
-}
-
-CELL init_zone(ZONE *z, CELL size, CELL base);
-
-void init_arena(CELL gen_count, CELL young_size, CELL aging_size);
-
-/* statistics */
-s64 gc_time;
-CELL minor_collections;
-CELL cards_scanned;
-
-/* only meaningful during a GC */
-CELL collecting_gen;
-CELL collecting_gen_start;
-
-/* test if the pointer is in generation being collected, or a younger one.
-init_arena() arranges things so that the older generations are first,
-so we have to check that the pointer occurs after the beginning of
-the requested generation. */
-#define COLLECTING_GEN(ptr) (collecting_gen_start <= ptr)
-
-INLINE bool should_copy(CELL untagged)
-{
- if(collecting_gen == TENURED)
- return !in_zone(newspace,untagged);
- else
- return(in_zone(&prior,untagged) || COLLECTING_GEN(untagged));
-}
-
-CELL copy_object(CELL pointer);
-#define COPY_OBJECT(lvalue) if(should_copy(lvalue)) lvalue = copy_object(lvalue)
-
-INLINE void copy_handle(CELL *handle)
-{
- COPY_OBJECT(*handle);
-}
-
-/* in case a generation fills up in the middle of a gc, we jump back
-up to try collecting the next generation. */
-jmp_buf gc_jmp;
-
-/* A heap walk allows useful things to be done, like finding all
-references to an object for debugging purposes. */
-CELL heap_scan_ptr;
-
-/* GC is off during heap walking */
-bool heap_scan;
-
-INLINE void *allot_zone(ZONE *z, CELL a)
-{
- CELL h = z->here;
- z->here = h + align8(a);
- if(z->here > z->limit)
- {
- fprintf(stderr,"Nursery space exhausted\n");
- factorbug();
- }
-
- allot_barrier(h);
- return (void*)h;
-}
-
-INLINE void *allot(CELL a)
-{
- return allot_zone(&nursery,a);
-}
-
-/*
- * It is up to the caller to fill in the object's fields in a meaningful
- * fashion!
- */
-INLINE void* allot_object(CELL type, CELL length)
-{
- CELL* object = allot(length);
- *object = tag_header(type);
- return object;
-}
-
-void update_cards_offset(void);
-CELL collect_next(CELL scan);
-void garbage_collection(CELL gen);
-void primitive_gc(void);
-void maybe_gc(CELL size);
-DLLEXPORT void simple_gc(void);
-void primitive_gc_time(void);
+++ /dev/null
-#include "factor.h"
-
-void primitive_hashtable(void)
-{
- F_HASHTABLE* hash;
- maybe_gc(0);
- hash = allot_object(HASHTABLE_TYPE,sizeof(F_HASHTABLE));
- hash->count = F;
- hash->deleted = F;
- hash->array = F;
- dpush(tag_object(hash));
-}
-
-void fixup_hashtable(F_HASHTABLE* hashtable)
-{
- data_fixup(&hashtable->count);
- data_fixup(&hashtable->deleted);
- data_fixup(&hashtable->array);
-}
-
-void collect_hashtable(F_HASHTABLE* hashtable)
-{
- copy_handle(&hashtable->count);
- copy_handle(&hashtable->deleted);
- copy_handle(&hashtable->array);
-}
+++ /dev/null
-typedef struct {
- /* always tag_header(HASHTABLE_TYPE) */
- CELL header;
- /* tagged */
- CELL count;
- /* tagged */
- CELL deleted;
- /* tagged */
- CELL array;
-} F_HASHTABLE;
-
-void primitive_hashtable(void);
-void fixup_hashtable(F_HASHTABLE* hashtable);
-void collect_hashtable(F_HASHTABLE* hashtable);
{
fprintf(stderr,"Cannot open image file: %s\n",filename);
fprintf(stderr,"%s\n",strerror(errno));
- usage();
exit(1);
}
filename = untag_string(dpop());
save_image(to_char_string(filename,true));
}
+
+void relocate_object(CELL relocating)
+{
+ switch(untag_header(get(relocating)))
+ {
+ case RATIO_TYPE:
+ fixup_ratio((F_RATIO*)relocating);
+ break;
+ case COMPLEX_TYPE:
+ fixup_complex((F_COMPLEX*)relocating);
+ break;
+ case WORD_TYPE:
+ fixup_word((F_WORD*)relocating);
+ break;
+ case ARRAY_TYPE:
+ case TUPLE_TYPE:
+ case QUOTATION_TYPE:
+ fixup_array((F_ARRAY*)relocating);
+ break;
+ case HASHTABLE_TYPE:
+ fixup_hashtable((F_HASHTABLE*)relocating);
+ break;
+ case VECTOR_TYPE:
+ fixup_vector((F_VECTOR*)relocating);
+ break;
+ case STRING_TYPE:
+ rehash_string((F_STRING*)relocating);
+ break;
+ case SBUF_TYPE:
+ fixup_sbuf((F_SBUF*)relocating);
+ break;
+ case DLL_TYPE:
+ fixup_dll((DLL*)relocating);
+ break;
+ case ALIEN_TYPE:
+ fixup_alien((ALIEN*)relocating);
+ break;
+ case WRAPPER_TYPE:
+ fixup_wrapper((F_WRAPPER*)relocating);
+ break;
+ }
+}
+
+void relocate_data()
+{
+ CELL relocating;
+
+ data_fixup(&userenv[BOOT_ENV]);
+ data_fixup(&userenv[GLOBAL_ENV]);
+ data_fixup(&T);
+ data_fixup(&bignum_zero);
+ data_fixup(&bignum_pos_one);
+ data_fixup(&bignum_neg_one);
+
+ for(relocating = tenured.base;
+ relocating < tenured.here;
+ relocating += untagged_object_size(relocating))
+ {
+ allot_barrier(relocating);
+ relocate_object(relocating);
+ }
+
+ for(relocating = compiling.base;
+ relocating < literal_top;
+ relocating += CELLS)
+ {
+ data_fixup((CELL*)relocating);
+ }
+}
+
+void undefined_symbol(void)
+{
+ general_error(ERROR_UNDEFINED_SYMBOL,F,F,true);
+}
+
+CELL get_rel_symbol(F_REL* rel)
+{
+ CELL arg = REL_ARGUMENT(rel);
+ F_ARRAY *pair = untag_array(get(compiling.base + arg * CELLS));
+ F_STRING *symbol = untag_string(get(AREF(pair,0)));
+ CELL library = get(AREF(pair,1));
+ DLL *dll = (library == F ? NULL : untag_dll(library));
+ CELL sym;
+
+ if(dll != NULL && !dll->dll)
+ return (CELL)undefined_symbol;
+
+ sym = (CELL)ffi_dlsym(dll,symbol,false);
+
+ if(!sym)
+ return (CELL)undefined_symbol;
+
+ return sym;
+}
+
+INLINE CELL compute_code_rel(F_REL *rel, CELL original)
+{
+ switch(REL_TYPE(rel))
+ {
+ case F_PRIMITIVE:
+ return primitive_to_xt(REL_ARGUMENT(rel));
+ case F_DLSYM:
+ return get_rel_symbol(rel);
+ case F_ABSOLUTE:
+ return original + (compiling.base - code_relocation_base);
+ case F_CARDS:
+ return cards_offset;
+ default:
+ critical_error("Unsupported rel type",rel->type);
+ return -1;
+ }
+}
+
+INLINE CELL relocate_code_next(CELL relocating)
+{
+ F_COMPILED* compiled = (F_COMPILED*)relocating;
+
+ F_REL* rel = (F_REL*)(
+ relocating + sizeof(F_COMPILED)
+ + compiled->code_length);
+
+ F_REL* rel_end = (F_REL*)(
+ relocating + sizeof(F_COMPILED)
+ + compiled->code_length
+ + compiled->reloc_length);
+
+ if(compiled->header != COMPILED_HEADER)
+ critical_error("Wrong compiled header",relocating);
+
+ while(rel < rel_end)
+ {
+ CELL original;
+ CELL new_value;
+
+ code_fixup(&rel->offset);
+
+ switch(REL_CLASS(rel))
+ {
+ case REL_ABSOLUTE_CELL:
+ original = get(rel->offset);
+ break;
+ case REL_ABSOLUTE:
+ original = *(u32*)rel->offset;
+ break;
+ case REL_RELATIVE:
+ original = *(u32*)rel->offset - (rel->offset + sizeof(u32));
+ break;
+ case REL_2_2:
+ original = reloc_get_2_2(rel->offset);
+ break;
+ default:
+ critical_error("Unsupported rel class",REL_CLASS(rel));
+ return -1;
+ }
+
+ /* to_c_string can fill up the heap */
+ maybe_gc(0);
+ new_value = compute_code_rel(rel,original);
+
+ switch(REL_CLASS(rel))
+ {
+ case REL_ABSOLUTE_CELL:
+ put(rel->offset,new_value);
+ break;
+ case REL_ABSOLUTE:
+ *(u32*)rel->offset = new_value;
+ break;
+ case REL_RELATIVE:
+ *(u32*)rel->offset = new_value - (rel->offset + CELLS);
+ break;
+ case REL_2_2:
+ reloc_set_2_2(rel->offset,new_value);
+ break;
+ default:
+ critical_error("Unsupported rel class",REL_CLASS(rel));
+ return -1;
+ }
+
+ rel++;
+ }
+
+ return (CELL)rel_end;
+}
+
+void relocate_code()
+{
+ /* start relocating from the end of the space reserved for literals */
+ CELL relocating = literal_max;
+ while(relocating < compiling.here)
+ relocating = relocate_code_next(relocating);
+}
void load_image(const char* file, int literal_size);
bool save_image(const char* file);
void primitive_save_image(void);
+
+/* relocation base of currently loaded image's data heap */
+CELL data_relocation_base;
+
+INLINE void data_fixup(CELL *cell)
+{
+ if(TAG(*cell) != FIXNUM_TYPE && *cell != F)
+ *cell += (tenured.base - data_relocation_base);
+}
+
+typedef enum {
+ /* arg is a primitive number */
+ F_PRIMITIVE,
+ /* arg is a pointer in the literal table hodling a cons where the
+ car is a symbol string, and the cdr is a dll */
+ F_DLSYM,
+ /* relocate an address to start of code heap */
+ F_ABSOLUTE,
+ /* store the offset of the card table from the data heap base */
+ F_CARDS
+} F_RELTYPE;
+
+#define REL_ABSOLUTE_CELL 0
+#define REL_ABSOLUTE 1
+#define REL_RELATIVE 2
+#define REL_2_2 3
+
+/* the rel type is built like a cell to avoid endian-specific code in
+the compiler */
+#define REL_TYPE(r) ((r)->type & 0x000000ff)
+#define REL_CLASS(r) (((r)->type & 0x0000ff00) >> 8)
+#define REL_ARGUMENT(r) (((r)->type & 0xffff0000) >> 16)
+
+/* code relocation consists of a table of entries for each fixup */
+typedef struct {
+ CELL type;
+ CELL offset;
+} F_REL;
+
+CELL code_relocation_base;
+
+INLINE void code_fixup(CELL *cell)
+{
+ *cell += (compiling.base - code_relocation_base);
+}
+
+void relocate_data();
+void relocate_code();
+
+/* on PowerPC, return the 32-bit literal being loaded at the code at the
+given address */
+INLINE CELL reloc_get_2_2(CELL cell)
+{
+ return ((get(cell - CELLS) & 0xffff) << 16) | (get(cell) & 0xffff);
+}
+
+INLINE void reloc_set_2_2(CELL cell, CELL value)
+{
+ put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff)));
+ put(cell,((get(cell) & ~0xffff) | (value & 0xffff)));
+}
--- /dev/null
+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;
+
+#ifdef _WIN64
+ typedef long long F_FIXNUM;
+ typedef unsigned long long CELL;
+#else
+ typedef long F_FIXNUM;
+ typedef unsigned long CELL;
+#endif
+
+#define CELLS ((signed)sizeof(CELL))
+
+/* must always be 16 bits */
+#define CHARS ((signed)sizeof(u16))
+
+#define WORD_SIZE (CELLS*8)
+#define HALF_WORD_SIZE (CELLS*4)
+#define HALF_WORD_MASK (((unsigned long)1<<HALF_WORD_SIZE)-1)
+
+#define TAG_MASK 7
+#define TAG_BITS 3
+#define TAG(cell) ((CELL)(cell) & TAG_MASK)
+#define RETAG(cell,tag) ((CELL)(cell) | (tag))
+#define UNTAG(cell) ((CELL)(cell) & ~TAG_MASK)
+
+/*** Tags ***/
+#define FIXNUM_TYPE 0
+#define BIGNUM_TYPE 1
+#define WORD_TYPE 2
+#define OBJECT_TYPE 3
+#define RATIO_TYPE 4
+#define FLOAT_TYPE 5
+#define COMPLEX_TYPE 6
+#define WRAPPER_TYPE 7
+
+#define HEADER_TYPE 7 /* anything less than or equal to this is a tag */
+#define GC_COLLECTED 0 /* See gc.c */
+
+/*** Header types ***/
+#define ARRAY_TYPE 8
+
+/* Canonical F object */
+#define F_TYPE 9
+#define F RETAG(0,OBJECT_TYPE)
+
+#define HASHTABLE_TYPE 10
+#define VECTOR_TYPE 11
+#define STRING_TYPE 12
+#define SBUF_TYPE 13
+#define QUOTATION_TYPE 14
+#define DLL_TYPE 15
+#define ALIEN_TYPE 16
+#define TUPLE_TYPE 17
+#define BYTE_ARRAY_TYPE 18
+
+#define TYPE_COUNT 19
+
+typedef struct {
+ CELL header;
+ /* tagged */
+ CELL capacity;
+} F_ARRAY;
+
+typedef struct {
+ /* always tag_header(VECTOR_TYPE) */
+ CELL header;
+ /* tagged */
+ CELL top;
+ /* tagged */
+ CELL array;
+} F_VECTOR;
+
+typedef struct {
+ CELL header;
+ /* tagged num of chars */
+ CELL length;
+ /* tagged */
+ CELL hashcode;
+} F_STRING;
+
+typedef struct {
+ /* always tag_header(SBUF_TYPE) */
+ CELL header;
+ /* tagged */
+ CELL top;
+ /* tagged */
+ CELL string;
+} F_SBUF;
+
+typedef struct {
+ /* always tag_header(HASHTABLE_TYPE) */
+ CELL header;
+ /* tagged */
+ CELL count;
+ /* tagged */
+ CELL deleted;
+ /* tagged */
+ CELL array;
+} F_HASHTABLE;
+
+typedef struct {
+ /* TAGGED header */
+ CELL header;
+ /* TAGGED hashcode */
+ CELL hashcode;
+ /* TAGGED word name */
+ CELL name;
+ /* TAGGED word vocabulary */
+ CELL vocabulary;
+ /* TAGGED on-disk primitive number */
+ CELL primitive;
+ /* TAGGED parameter to xt; used for colon definitions */
+ CELL def;
+ /* TAGGED property hash for library code */
+ CELL props;
+ /* UNTAGGED execution token: jump here to execute word */
+ CELL xt;
+} F_WORD;
+
+typedef struct {
+ CELL header;
+ CELL object;
+} F_WRAPPER;
+
+typedef struct {
+ CELL header;
+ CELL numerator;
+ CELL denominator;
+} F_RATIO;
+
+typedef struct {
+/* C sucks. */
+ union {
+ CELL header;
+ long long padding;
+ };
+ double n;
+} F_FLOAT;
+
+typedef struct {
+ CELL header;
+ CELL real;
+ CELL imaginary;
+} F_COMPLEX;
+
+typedef struct {
+ CELL header;
+ CELL alien;
+ CELL displacement;
+ bool expired;
+} ALIEN;
+
+typedef struct {
+ CELL header;
+ /* tagged string */
+ CELL path;
+ /* OS-specific handle */
+ void* dll;
+} DLL;
--- /dev/null
+/* Fault handler information. MacOSX version.
+Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
+Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
+
+Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
+2005-03-10
+
+see http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html */
+
+#include "factor.h"
+
+/* The following sources were used as a *reference* for this exception handling
+ code:
+ 1. Apple's mach/xnu documentation
+ 2. Timothy J. Wood's "Mach Exception Handlers 101" post to the
+ omnigroup's macosx-dev list.
+ www.omnigroup.com/mailman/archive/macosx-dev/2000-June/002030.html */
+
+/* The exception port on which our thread listens. */
+static mach_port_t our_exception_port;
+
+/* Communication area for the exception state and thread state. */
+static SIGSEGV_THREAD_STATE_TYPE save_thread_state;
+
+/* A handler that is called in the faulting thread. It terminates the thread. */
+static void
+terminating_handler ()
+{
+ raise (SIGSEGV);
+ abort ();
+}
+
+
+/* Handle an exception by invoking the user's fault handler and/or forwarding
+ the duty to the previously installed handlers. */
+kern_return_t
+catch_exception_raise (mach_port_t exception_port,
+ mach_port_t thread,
+ mach_port_t task,
+ exception_type_t exception,
+ exception_data_t code,
+ mach_msg_type_number_t code_count)
+{
+ SIGSEGV_EXC_STATE_TYPE exc_state;
+ SIGSEGV_THREAD_STATE_TYPE thread_state;
+ mach_msg_type_number_t state_count;
+ unsigned long sp;
+
+ /* See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_get_state.html. */
+ state_count = SIGSEGV_EXC_STATE_COUNT;
+ if (thread_get_state (thread, SIGSEGV_EXC_STATE_FLAVOR,
+ (void *) &exc_state, &state_count)
+ != KERN_SUCCESS)
+ {
+ /* The thread is supposed to be suspended while the exception handler
+ is called. This shouldn't fail. */
+ return KERN_FAILURE;
+ }
+
+ state_count = SIGSEGV_THREAD_STATE_COUNT;
+ if (thread_get_state (thread, SIGSEGV_THREAD_STATE_FLAVOR,
+ (void *) &thread_state, &state_count)
+ != KERN_SUCCESS)
+ {
+ /* The thread is supposed to be suspended while the exception handler
+ is called. This shouldn't fail. */
+ return KERN_FAILURE;
+ }
+
+ sp = (unsigned long) (SIGSEGV_STACK_POINTER (thread_state));
+
+#ifdef __i386__
+ if ((sp & 0xf) != 0)
+ sp -= (sp & 0xf);
+
+ sp -= 4;
+#endif
+
+ save_thread_state = thread_state;
+
+ SIGSEGV_PROGRAM_COUNTER (thread_state) = (unsigned long) terminating_handler;
+ SIGSEGV_STACK_POINTER (thread_state) = sp;
+
+ /* See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_set_state.html. */
+ if (thread_set_state (thread, SIGSEGV_THREAD_STATE_FLAVOR,
+ (void *) &thread_state, state_count)
+ != KERN_SUCCESS)
+ {
+ return KERN_FAILURE;
+ }
+ return KERN_SUCCESS;
+}
+
+
+/* The main function of the thread listening for exceptions. */
+static void *
+mach_exception_thread (void *arg)
+{
+ for (;;)
+ {
+ /* These two structures contain some private kernel data. We don't need
+ to access any of it so we don't bother defining a proper struct. The
+ correct definitions are in the xnu source code. */
+ /* Buffer for a message to be received. */
+ struct
+ {
+ mach_msg_header_t head;
+ mach_msg_body_t msgh_body;
+ char data[1024];
+ }
+ msg;
+ /* Buffer for a reply message. */
+ struct
+ {
+ mach_msg_header_t head;
+ char data[1024];
+ }
+ reply;
+
+ mach_msg_return_t retval;
+
+ /* Wait for a message on the exception port. */
+ retval = mach_msg (&msg.head, MACH_RCV_MSG | MACH_RCV_LARGE, 0,
+ sizeof (msg), our_exception_port,
+ MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL);
+ if (retval != MACH_MSG_SUCCESS)
+ {
+ abort ();
+ }
+
+ /* Handle the message: Call exc_server, which will call
+ catch_exception_raise and produce a reply message. */
+ exc_server (&msg.head, &reply.head);
+
+ /* Send the reply. */
+ if (mach_msg (&reply.head, MACH_SEND_MSG, reply.head.msgh_size,
+ 0, MACH_PORT_NULL,
+ MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL)
+ != MACH_MSG_SUCCESS)
+ {
+ abort ();
+ }
+ }
+}
+
+
+/* Initialize the Mach exception handler thread.
+ Return 0 if OK, -1 on error. */
+int mach_initialize ()
+{
+ mach_port_t self;
+ exception_mask_t mask;
+ pthread_attr_t attr;
+ pthread_t thread;
+
+ self = mach_task_self ();
+
+ /* Allocate a port on which the thread shall listen for exceptions. */
+ if (mach_port_allocate (self, MACH_PORT_RIGHT_RECEIVE, &our_exception_port)
+ != KERN_SUCCESS)
+ return -1;
+
+ /* See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/mach_port_insert_right.html. */
+ if (mach_port_insert_right (self, our_exception_port, our_exception_port,
+ MACH_MSG_TYPE_MAKE_SEND)
+ != KERN_SUCCESS)
+ return -1;
+
+ /* The exceptions we want to catch. Only EXC_BAD_ACCESS is interesting
+ for us (see above in function catch_exception_raise). */
+ mask = EXC_MASK_BAD_ACCESS;
+
+ /* Create the thread listening on the exception port. */
+ if (pthread_attr_init (&attr) != 0)
+ return -1;
+ if (pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED) != 0)
+ return -1;
+ if (pthread_create (&thread, &attr, mach_exception_thread, NULL) != 0)
+ return -1;
+ pthread_attr_destroy (&attr);
+
+ /* Replace the exception port info for these exceptions with our own.
+ Note that we replace the exception port for the entire task, not only
+ for a particular thread. This has the effect that when our exception
+ port gets the message, the thread specific exception port has already
+ been asked, and we don't need to bother about it.
+ See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/task_set_exception_ports.html. */
+ if (task_set_exception_ports (self, mask, our_exception_port,
+ EXCEPTION_DEFAULT, MACHINE_THREAD_STATE)
+ != KERN_SUCCESS)
+ return -1;
+
+ return 0;
+}
--- /dev/null
+#include <stdio.h>
+#include <stdlib.h>
+#include <errno.h>
+#include <signal.h>
+
+#include <mach/mach.h>
+#include <mach/mach_error.h>
+#include <mach/thread_status.h>
+#include <mach/exception.h>
+#include <mach/task.h>
+#include <pthread.h>
+
+/* For MacOSX. */
+#ifndef SS_DISABLE
+#define SS_DISABLE SA_DISABLE
+#endif
+
+/* This is not defined in any header, although documented. */
+
+/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/exc_server.html says:
+ The exc_server function is the MIG generated server handling function
+ to handle messages from the kernel relating to the occurrence of an
+ exception in a thread. Such messages are delivered to the exception port
+ set via thread_set_exception_ports or task_set_exception_ports. When an
+ exception occurs in a thread, the thread sends an exception message to its
+ exception port, blocking in the kernel waiting for the receipt of a reply.
+ The exc_server function performs all necessary argument handling for this
+ kernel message and calls catch_exception_raise, catch_exception_raise_state
+ or catch_exception_raise_state_identity, which should handle the exception.
+ If the called routine returns KERN_SUCCESS, a reply message will be sent,
+ allowing the thread to continue from the point of the exception; otherwise,
+ no reply message is sent and the called routine must have dealt with the
+ exception thread directly. */
+extern boolean_t
+ exc_server (mach_msg_header_t *request_msg,
+ mach_msg_header_t *reply_msg);
+
+
+/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/catch_exception_raise.html
+ These functions are defined in this file, and called by exc_server.
+ FIXME: What needs to be done when this code is put into a shared library? */
+kern_return_t
+catch_exception_raise (mach_port_t exception_port,
+ mach_port_t thread,
+ mach_port_t task,
+ exception_type_t exception,
+ exception_data_t code,
+ mach_msg_type_number_t code_count);
+kern_return_t
+catch_exception_raise_state (mach_port_t exception_port,
+ exception_type_t exception,
+ exception_data_t code,
+ mach_msg_type_number_t code_count,
+ thread_state_flavor_t *flavor,
+ thread_state_t in_state,
+ mach_msg_type_number_t in_state_count,
+ thread_state_t out_state,
+ mach_msg_type_number_t *out_state_count);
+kern_return_t
+catch_exception_raise_state_identity (mach_port_t exception_port,
+ mach_port_t thread,
+ mach_port_t task,
+ exception_type_t exception,
+ exception_data_t code,
+ mach_msg_type_number_t codeCnt,
+ thread_state_flavor_t *flavor,
+ thread_state_t in_state,
+ mach_msg_type_number_t in_state_count,
+ thread_state_t out_state,
+ mach_msg_type_number_t *out_state_count);
+
+int mach_initialize ();
+++ /dev/null
-/* Fault handler information. MacOSX version.
-Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
-Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
-
-Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
-2005-03-10
-
-see http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html */
-
-#ifdef __APPLE__
-
-#include "mach_signal.h"
-
-/* The following sources were used as a *reference* for this exception handling
- code:
- 1. Apple's mach/xnu documentation
- 2. Timothy J. Wood's "Mach Exception Handlers 101" post to the
- omnigroup's macosx-dev list.
- www.omnigroup.com/mailman/archive/macosx-dev/2000-June/002030.html */
-
-/* The exception port on which our thread listens. */
-static mach_port_t our_exception_port;
-
-/* Communication area for the exception state and thread state. */
-static SIGSEGV_THREAD_STATE_TYPE save_thread_state;
-
-/* A handler that is called in the faulting thread. It terminates the thread. */
-static void
-terminating_handler ()
-{
- raise (SIGSEGV);
- abort ();
-}
-
-
-/* Handle an exception by invoking the user's fault handler and/or forwarding
- the duty to the previously installed handlers. */
-kern_return_t
-catch_exception_raise (mach_port_t exception_port,
- mach_port_t thread,
- mach_port_t task,
- exception_type_t exception,
- exception_data_t code,
- mach_msg_type_number_t code_count)
-{
-#ifdef SIGSEGV_EXC_STATE_TYPE
- SIGSEGV_EXC_STATE_TYPE exc_state;
-#endif
- SIGSEGV_THREAD_STATE_TYPE thread_state;
- mach_msg_type_number_t state_count;
- unsigned long sp;
-
- /* See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_get_state.html. */
-#ifdef SIGSEGV_EXC_STATE_TYPE
- state_count = SIGSEGV_EXC_STATE_COUNT;
- if (thread_get_state (thread, SIGSEGV_EXC_STATE_FLAVOR,
- (void *) &exc_state, &state_count)
- != KERN_SUCCESS)
- {
- /* The thread is supposed to be suspended while the exception handler
- is called. This shouldn't fail. */
- return KERN_FAILURE;
- }
-#endif
-
- state_count = SIGSEGV_THREAD_STATE_COUNT;
- if (thread_get_state (thread, SIGSEGV_THREAD_STATE_FLAVOR,
- (void *) &thread_state, &state_count)
- != KERN_SUCCESS)
- {
- /* The thread is supposed to be suspended while the exception handler
- is called. This shouldn't fail. */
- return KERN_FAILURE;
- }
-
- sp = (unsigned long) (SIGSEGV_STACK_POINTER (thread_state));
-
-#ifdef __i386__
- if ((sp & 0xf) != 0)
- sp -= (sp & 0xf);
-
- sp -= 4;
-#endif
-
- save_thread_state = thread_state;
-
- SIGSEGV_PROGRAM_COUNTER (thread_state) = (unsigned long) terminating_handler;
- SIGSEGV_STACK_POINTER (thread_state) = sp;
-
- /* See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_set_state.html. */
- if (thread_set_state (thread, SIGSEGV_THREAD_STATE_FLAVOR,
- (void *) &thread_state, state_count)
- != KERN_SUCCESS)
- {
- return KERN_FAILURE;
- }
- return KERN_SUCCESS;
-}
-
-
-/* The main function of the thread listening for exceptions. */
-static void *
-mach_exception_thread (void *arg)
-{
- for (;;)
- {
- /* These two structures contain some private kernel data. We don't need
- to access any of it so we don't bother defining a proper struct. The
- correct definitions are in the xnu source code. */
- /* Buffer for a message to be received. */
- struct
- {
- mach_msg_header_t head;
- mach_msg_body_t msgh_body;
- char data[1024];
- }
- msg;
- /* Buffer for a reply message. */
- struct
- {
- mach_msg_header_t head;
- char data[1024];
- }
- reply;
-
- mach_msg_return_t retval;
-
- /* Wait for a message on the exception port. */
- retval = mach_msg (&msg.head, MACH_RCV_MSG | MACH_RCV_LARGE, 0,
- sizeof (msg), our_exception_port,
- MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL);
- if (retval != MACH_MSG_SUCCESS)
- {
- abort ();
- }
-
- /* Handle the message: Call exc_server, which will call
- catch_exception_raise and produce a reply message. */
- exc_server (&msg.head, &reply.head);
-
- /* Send the reply. */
- if (mach_msg (&reply.head, MACH_SEND_MSG, reply.head.msgh_size,
- 0, MACH_PORT_NULL,
- MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL)
- != MACH_MSG_SUCCESS)
- {
- abort ();
- }
- }
-}
-
-
-/* Initialize the Mach exception handler thread.
- Return 0 if OK, -1 on error. */
-int mach_initialize ()
-{
- mach_port_t self;
- exception_mask_t mask;
- pthread_attr_t attr;
- pthread_t thread;
-
- self = mach_task_self ();
-
- /* Allocate a port on which the thread shall listen for exceptions. */
- if (mach_port_allocate (self, MACH_PORT_RIGHT_RECEIVE, &our_exception_port)
- != KERN_SUCCESS)
- return -1;
-
- /* See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/mach_port_insert_right.html. */
- if (mach_port_insert_right (self, our_exception_port, our_exception_port,
- MACH_MSG_TYPE_MAKE_SEND)
- != KERN_SUCCESS)
- return -1;
-
- /* The exceptions we want to catch. Only EXC_BAD_ACCESS is interesting
- for us (see above in function catch_exception_raise). */
- mask = EXC_MASK_BAD_ACCESS;
-
- /* Create the thread listening on the exception port. */
- if (pthread_attr_init (&attr) != 0)
- return -1;
- if (pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED) != 0)
- return -1;
- if (pthread_create (&thread, &attr, mach_exception_thread, NULL) != 0)
- return -1;
- pthread_attr_destroy (&attr);
-
- /* Replace the exception port info for these exceptions with our own.
- Note that we replace the exception port for the entire task, not only
- for a particular thread. This has the effect that when our exception
- port gets the message, the thread specific exception port has already
- been asked, and we don't need to bother about it.
- See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/task_set_exception_ports.html. */
- if (task_set_exception_ports (self, mask, our_exception_port,
- EXCEPTION_DEFAULT, MACHINE_THREAD_STATE)
- != KERN_SUCCESS)
- return -1;
-
- return 0;
-}
-
-#endif
+++ /dev/null
-#ifdef __APPLE__
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <errno.h>
-#include <signal.h>
-
-#include <mach/mach.h>
-#include <mach/mach_error.h>
-#include <mach/thread_status.h>
-#include <mach/exception.h>
-#include <mach/task.h>
-#include <pthread.h>
-
-/* For MacOSX. */
-#ifndef SS_DISABLE
-#define SS_DISABLE SA_DISABLE
-#endif
-
-/* This is not defined in any header, although documented. */
-
-/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/exc_server.html says:
- The exc_server function is the MIG generated server handling function
- to handle messages from the kernel relating to the occurrence of an
- exception in a thread. Such messages are delivered to the exception port
- set via thread_set_exception_ports or task_set_exception_ports. When an
- exception occurs in a thread, the thread sends an exception message to its
- exception port, blocking in the kernel waiting for the receipt of a reply.
- The exc_server function performs all necessary argument handling for this
- kernel message and calls catch_exception_raise, catch_exception_raise_state
- or catch_exception_raise_state_identity, which should handle the exception.
- If the called routine returns KERN_SUCCESS, a reply message will be sent,
- allowing the thread to continue from the point of the exception; otherwise,
- no reply message is sent and the called routine must have dealt with the
- exception thread directly. */
-extern boolean_t
- exc_server (mach_msg_header_t *request_msg,
- mach_msg_header_t *reply_msg);
-
-
-/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/catch_exception_raise.html
- These functions are defined in this file, and called by exc_server.
- FIXME: What needs to be done when this code is put into a shared library? */
-kern_return_t
-catch_exception_raise (mach_port_t exception_port,
- mach_port_t thread,
- mach_port_t task,
- exception_type_t exception,
- exception_data_t code,
- mach_msg_type_number_t code_count);
-kern_return_t
-catch_exception_raise_state (mach_port_t exception_port,
- exception_type_t exception,
- exception_data_t code,
- mach_msg_type_number_t code_count,
- thread_state_flavor_t *flavor,
- thread_state_t in_state,
- mach_msg_type_number_t in_state_count,
- thread_state_t out_state,
- mach_msg_type_number_t *out_state_count);
-kern_return_t
-catch_exception_raise_state_identity (mach_port_t exception_port,
- mach_port_t thread,
- mach_port_t task,
- exception_type_t exception,
- exception_data_t code,
- mach_msg_type_number_t codeCnt,
- thread_state_flavor_t *flavor,
- thread_state_t in_state,
- mach_msg_type_number_t in_state_count,
- thread_state_t out_state,
- mach_msg_type_number_t *out_state_count);
-
-#ifdef __i386__
- #define SIGSEGV_EXC_STATE_TYPE i386_exception_state_t
- #define SIGSEGV_EXC_STATE_FLAVOR i386_EXCEPTION_STATE
- #define SIGSEGV_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT
- #define SIGSEGV_THREAD_STATE_TYPE i386_thread_state_t
- #define SIGSEGV_THREAD_STATE_FLAVOR i386_THREAD_STATE
- #define SIGSEGV_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT
- #define SIGSEGV_STACK_POINTER(thr_state) (thr_state).esp
- #define SIGSEGV_PROGRAM_COUNTER(thr_state) (thr_state).eip
-#else
- #define SIGSEGV_EXC_STATE_TYPE ppc_exception_state_t
- #define SIGSEGV_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE
- #define SIGSEGV_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT
- #define SIGSEGV_THREAD_STATE_TYPE ppc_thread_state_t
- #define SIGSEGV_THREAD_STATE_FLAVOR PPC_THREAD_STATE
- #define SIGSEGV_THREAD_STATE_COUNT PPC_THREAD_STATE_COUNT
- #define SIGSEGV_STACK_POINTER(thr_state) (thr_state).r1
- #define SIGSEGV_PROGRAM_COUNTER(thr_state) (thr_state).srr0
-#endif
-
-int mach_initialize ();
-
-#endif
+++ /dev/null
-/* Cocoa exception handling and default image path for Mac OS X */
-
-#include "../factor.h"
-#import "Foundation/NSAutoreleasePool.h"
-#import "Foundation/NSBundle.h"
-#import "Foundation/NSException.h"
-#import "Foundation/NSString.h"
-
-static CELL error;
-
-/* This code is convoluted because Cocoa places restrictions on longjmp and
-exception handling. In particular, a longjmp can never cross an NS_DURING,
-NS_HANDLER or NS_ENDHANDLER. */
-void platform_run()
-{
- error = F;
-
- for(;;)
- {
-NS_DURING
- SETJMP(stack_chain->toplevel);
- handle_error();
-
- if(error != F)
- {
- CELL e = error;
- error = F;
- general_error(ERROR_OBJECTIVE_C,e,F,true);
- }
-
- run();
- NS_VOIDRETURN;
-NS_HANDLER
- error = tag_object(make_alien(F,(CELL)localException));
-NS_ENDHANDLER
- }
-}
-
-void early_init(void)
-{
- [[NSAutoreleasePool alloc] init];
-}
-
-const char *default_image_path(void)
-{
- NSBundle *bundle = [NSBundle mainBundle];
- NSString *image = [[bundle resourcePath] stringByAppendingString:@"/factor.image"];
- return [image cString];
-}
--- /dev/null
+#include "factor.h"
+
+/* Fixnums */
+
+F_FIXNUM to_fixnum(CELL tagged)
+{
+ F_RATIO* r;
+ F_ARRAY* x;
+ F_ARRAY* y;
+ F_FLOAT* f;
+
+ switch(TAG(tagged))
+ {
+ case FIXNUM_TYPE:
+ return untag_fixnum_fast(tagged);
+ case BIGNUM_TYPE:
+ return (F_FIXNUM)s48_bignum_to_fixnum((F_ARRAY*)UNTAG(tagged));
+ case RATIO_TYPE:
+ r = (F_RATIO*)UNTAG(tagged);
+ x = to_bignum(r->numerator);
+ y = to_bignum(r->denominator);
+ return to_fixnum(tag_bignum(s48_bignum_quotient(x,y)));
+ case FLOAT_TYPE:
+ f = (F_FLOAT*)UNTAG(tagged);
+ return (F_FIXNUM)f->n;
+ default:
+ type_error(FIXNUM_TYPE,tagged);
+ return -1; /* can't happen */
+ }
+}
+
+void primitive_to_fixnum(void)
+{
+ drepl(tag_fixnum(to_fixnum(dpeek())));
+}
+
+#define POP_FIXNUMS(x,y) \
+ F_FIXNUM x, y; \
+ y = untag_fixnum_fast(dpop()); \
+ x = untag_fixnum_fast(dpop());
+
+/* The fixnum arithmetic operations defined in C are relatively slow.
+The Factor compiler has optimized assembly intrinsics for all these
+operations. */
+void primitive_fixnum_add(void)
+{
+ POP_FIXNUMS(x,y)
+ box_signed_cell(x + y);
+}
+
+void primitive_fixnum_add_fast(void)
+{
+ POP_FIXNUMS(x,y)
+ dpush(tag_fixnum(x + y));
+}
+
+void primitive_fixnum_subtract(void)
+{
+ POP_FIXNUMS(x,y)
+ box_signed_cell(x - y);
+}
+
+void primitive_fixnum_subtract_fast(void)
+{
+ POP_FIXNUMS(x,y)
+ dpush(tag_fixnum(x - y));
+}
+
+/**
+ * Multiply two integers, and trap overflow.
+ * Thanks to David Blaikie (The_Vulture from freenode #java) for the hint.
+ */
+void primitive_fixnum_multiply(void)
+{
+ POP_FIXNUMS(x,y)
+
+ if(x == 0 || y == 0)
+ dpush(tag_fixnum(0));
+ else
+ {
+ F_FIXNUM prod = x * y;
+ /* if this is not equal, we have overflow */
+ if(prod / x == y)
+ box_signed_cell(prod);
+ else
+ {
+ dpush(tag_bignum(
+ s48_bignum_multiply(
+ s48_fixnum_to_bignum(x),
+ s48_fixnum_to_bignum(y))));
+ }
+ }
+}
+
+void primitive_fixnum_divint(void)
+{
+ POP_FIXNUMS(x,y)
+ box_signed_cell(x / y);
+}
+
+void primitive_fixnum_divfloat(void)
+{
+ POP_FIXNUMS(x,y)
+ dpush(tag_float((double)x / (double)y));
+}
+
+void primitive_fixnum_divmod(void)
+{
+ POP_FIXNUMS(x,y)
+ box_signed_cell(x / y);
+ box_signed_cell(x % y);
+}
+
+void primitive_fixnum_mod(void)
+{
+ POP_FIXNUMS(x,y)
+ dpush(tag_fixnum(x % y));
+}
+
+void primitive_fixnum_and(void)
+{
+ POP_FIXNUMS(x,y)
+ dpush(tag_fixnum(x & y));
+}
+
+void primitive_fixnum_or(void)
+{
+ POP_FIXNUMS(x,y)
+ dpush(tag_fixnum(x | y));
+}
+
+void primitive_fixnum_xor(void)
+{
+ POP_FIXNUMS(x,y)
+ dpush(tag_fixnum(x ^ y));
+}
+
+/*
+ * Note the hairy overflow check.
+ * If we're shifting right by n bits, we won't overflow as long as none of the
+ * high WORD_SIZE-TAG_BITS-n bits are set.
+ */
+void primitive_fixnum_shift(void)
+{
+ POP_FIXNUMS(x,y)
+
+ if(x == 0 || y == 0)
+ {
+ dpush(tag_fixnum(x));
+ return;
+ }
+ else if(y < 0)
+ {
+ if(y <= -WORD_SIZE)
+ dpush(x < 0 ? tag_fixnum(-1) : tag_fixnum(0));
+ else
+ dpush(tag_fixnum(x >> -y));
+ return;
+ }
+ else if(y < WORD_SIZE - TAG_BITS)
+ {
+ F_FIXNUM mask = -(1 << (WORD_SIZE - 1 - TAG_BITS - y));
+ if((x > 0 && (x & mask) == 0) || (x & mask) == mask)
+ {
+ dpush(tag_fixnum(x << y));
+ return;
+ }
+ }
+
+ dpush(tag_bignum(s48_bignum_arithmetic_shift(
+ s48_fixnum_to_bignum(x),y)));
+}
+
+void primitive_fixnum_less(void)
+{
+ POP_FIXNUMS(x,y)
+ box_boolean(x < y);
+}
+
+void primitive_fixnum_lesseq(void)
+{
+ POP_FIXNUMS(x,y)
+ box_boolean(x <= y);
+}
+
+void primitive_fixnum_greater(void)
+{
+ POP_FIXNUMS(x,y)
+ box_boolean(x > y);
+}
+
+void primitive_fixnum_greatereq(void)
+{
+ POP_FIXNUMS(x,y)
+ box_boolean(x >= y);
+}
+
+void primitive_fixnum_not(void)
+{
+ drepl(tag_fixnum(~untag_fixnum_fast(dpeek())));
+}
+
+#define INT_DEFBOX(name,type) \
+void name (type integer) \
+{ \
+ dpush(tag_integer(integer)); \
+}
+
+#define INT_DEFUNBOX(name,type) \
+type name(void) \
+{ \
+ return to_fixnum(dpop()); \
+}
+
+INT_DEFBOX(box_signed_1, signed char)
+INT_DEFBOX(box_signed_2, signed short)
+INT_DEFBOX(box_unsigned_1, unsigned char)
+INT_DEFBOX(box_unsigned_2, unsigned short)
+INT_DEFUNBOX(unbox_signed_1, signed char)
+INT_DEFUNBOX(unbox_signed_2, signed short)
+INT_DEFUNBOX(unbox_unsigned_1, unsigned char)
+INT_DEFUNBOX(unbox_unsigned_2, unsigned short)
+
+/* Bignums */
+
+CELL to_cell(CELL x)
+{
+ switch(type_of(x))
+ {
+ case FIXNUM_TYPE:
+ return untag_fixnum_fast(x);
+ case BIGNUM_TYPE:
+ return s48_bignum_to_fixnum(untag_bignum_fast(x));
+ default:
+ type_error(BIGNUM_TYPE,x);
+ return 0;
+ }
+}
+
+F_ARRAY* to_bignum(CELL tagged)
+{
+ F_RATIO* r;
+ F_ARRAY* x;
+ F_ARRAY* y;
+ F_FLOAT* f;
+
+ switch(type_of(tagged))
+ {
+ case FIXNUM_TYPE:
+ return s48_fixnum_to_bignum(untag_fixnum_fast(tagged));
+ case BIGNUM_TYPE:
+ return (F_ARRAY*)UNTAG(tagged);
+ case RATIO_TYPE:
+ r = (F_RATIO*)UNTAG(tagged);
+ x = to_bignum(r->numerator);
+ y = to_bignum(r->denominator);
+ return s48_bignum_quotient(x,y);
+ case FLOAT_TYPE:
+ f = (F_FLOAT*)UNTAG(tagged);
+ return s48_double_to_bignum(f->n);
+ default:
+ type_error(BIGNUM_TYPE,tagged);
+ return NULL; /* can't happen */
+ }
+}
+
+void primitive_to_bignum(void)
+{
+ maybe_gc(0);
+ drepl(tag_bignum(to_bignum(dpeek())));
+}
+
+#define GC_AND_POP_BIGNUMS(x,y) \
+ F_ARRAY *x, *y; \
+ maybe_gc(0); \
+ y = untag_bignum_fast(dpop()); \
+ x = untag_bignum_fast(dpop());
+
+void primitive_bignum_eq(void)
+{
+ GC_AND_POP_BIGNUMS(x,y);
+ box_boolean(s48_bignum_equal_p(x,y));
+}
+
+void primitive_bignum_add(void)
+{
+ GC_AND_POP_BIGNUMS(x,y);
+ dpush(tag_bignum(s48_bignum_add(x,y)));
+}
+
+void primitive_bignum_subtract(void)
+{
+ GC_AND_POP_BIGNUMS(x,y);
+ dpush(tag_bignum(s48_bignum_subtract(x,y)));
+}
+
+void primitive_bignum_multiply(void)
+{
+ GC_AND_POP_BIGNUMS(x,y);
+ dpush(tag_bignum(s48_bignum_multiply(x,y)));
+}
+
+void primitive_bignum_divint(void)
+{
+ GC_AND_POP_BIGNUMS(x,y);
+ dpush(tag_bignum(s48_bignum_quotient(x,y)));
+}
+
+void primitive_bignum_divfloat(void)
+{
+ GC_AND_POP_BIGNUMS(x,y);
+ dpush(tag_float(
+ s48_bignum_to_double(x) /
+ s48_bignum_to_double(y)));
+}
+
+void primitive_bignum_divmod(void)
+{
+ F_ARRAY *q, *r;
+ GC_AND_POP_BIGNUMS(x,y);
+ s48_bignum_divide(x,y,&q,&r);
+ dpush(tag_bignum(q));
+ dpush(tag_bignum(r));
+}
+
+void primitive_bignum_mod(void)
+{
+ GC_AND_POP_BIGNUMS(x,y);
+ dpush(tag_bignum(s48_bignum_remainder(x,y)));
+}
+
+void primitive_bignum_and(void)
+{
+ GC_AND_POP_BIGNUMS(x,y);
+ dpush(tag_bignum(s48_bignum_bitwise_and(x,y)));
+}
+
+void primitive_bignum_or(void)
+{
+ GC_AND_POP_BIGNUMS(x,y);
+ dpush(tag_bignum(s48_bignum_bitwise_ior(x,y)));
+}
+
+void primitive_bignum_xor(void)
+{
+ GC_AND_POP_BIGNUMS(x,y);
+ dpush(tag_bignum(s48_bignum_bitwise_xor(x,y)));
+}
+
+void primitive_bignum_shift(void)
+{
+ F_FIXNUM y;
+ F_ARRAY* x;
+ maybe_gc(0);
+ y = to_fixnum(dpop());
+ x = to_bignum(dpop());
+ dpush(tag_bignum(s48_bignum_arithmetic_shift(x,y)));
+}
+
+void primitive_bignum_less(void)
+{
+ GC_AND_POP_BIGNUMS(x,y);
+ box_boolean(s48_bignum_compare(x,y) == bignum_comparison_less);
+}
+
+void primitive_bignum_lesseq(void)
+{
+ GC_AND_POP_BIGNUMS(x,y);
+ switch(s48_bignum_compare(x,y))
+ {
+ case bignum_comparison_less:
+ case bignum_comparison_equal:
+ dpush(T);
+ break;
+ case bignum_comparison_greater:
+ dpush(F);
+ break;
+ default:
+ critical_error("s48_bignum_compare returns bogus value",0);
+ break;
+ }
+}
+
+void primitive_bignum_greater(void)
+{
+ GC_AND_POP_BIGNUMS(x,y);
+ box_boolean(s48_bignum_compare(x,y) == bignum_comparison_greater);
+}
+
+void primitive_bignum_greatereq(void)
+{
+ GC_AND_POP_BIGNUMS(x,y);
+ switch(s48_bignum_compare(x,y))
+ {
+ case bignum_comparison_less:
+ dpush(F);
+ break;
+ case bignum_comparison_equal:
+ case bignum_comparison_greater:
+ dpush(T);
+ break;
+ default:
+ critical_error("s48_bignum_compare returns bogus value",0);
+ break;
+ }
+}
+
+void primitive_bignum_not(void)
+{
+ maybe_gc(0);
+ drepl(tag_bignum(s48_bignum_bitwise_not(
+ untag_bignum_fast(dpeek()))));
+}
+
+void box_signed_cell(F_FIXNUM integer)
+{
+ dpush(tag_integer(integer));
+}
+
+F_FIXNUM unbox_signed_cell(void)
+{
+ return to_fixnum(dpop());
+}
+
+void box_unsigned_cell(CELL cell)
+{
+ dpush(tag_cell(cell));
+}
+
+F_FIXNUM unbox_unsigned_cell(void)
+{
+ return to_cell(dpop());
+}
+
+void box_signed_4(s32 n)
+{
+ dpush(tag_bignum(s48_long_to_bignum(n)));
+}
+
+s32 unbox_signed_4(void)
+{
+ return to_fixnum(dpop());
+}
+
+void box_unsigned_4(u32 n)
+{
+ dpush(tag_bignum(s48_ulong_to_bignum(n)));
+}
+
+u32 unbox_unsigned_4(void)
+{
+ return to_cell(dpop());
+}
+
+void box_signed_8(s64 n)
+{
+ dpush(tag_bignum(s48_long_long_to_bignum(n)));
+}
+
+s64 unbox_signed_8(void)
+{
+ return s48_bignum_to_long_long(to_bignum(dpop()));
+}
+
+void box_unsigned_8(u64 n)
+{
+ dpush(tag_bignum(s48_ulong_long_to_bignum(n)));
+}
+
+u64 unbox_unsigned_8(void)
+{
+ return s48_bignum_to_ulong_long(to_bignum(dpop()));
+}
+
+/* Ratios */
+
+/* Does not reduce to lowest terms, so should only be used by math
+library implementation, to avoid breaking invariants. */
+void primitive_from_fraction(void)
+{
+ CELL numerator, denominator;
+ F_RATIO* ratio;
+
+ maybe_gc(0);
+
+ denominator = dpop();
+ numerator = dpop();
+ ratio = allot_object(RATIO_TYPE,sizeof(F_RATIO));
+ ratio->numerator = numerator;
+ ratio->denominator = denominator;
+ dpush(RETAG(ratio,RATIO_TYPE));
+}
+
+void fixup_ratio(F_RATIO* ratio)
+{
+ data_fixup(&ratio->numerator);
+ data_fixup(&ratio->denominator);
+}
+
+void collect_ratio(F_RATIO* ratio)
+{
+ copy_handle(&ratio->numerator);
+ copy_handle(&ratio->denominator);
+}
+
+/* Floats */
+
+double to_float(CELL tagged)
+{
+ F_RATIO* r;
+ double x;
+ double y;
+
+ switch(TAG(tagged))
+ {
+ case FIXNUM_TYPE:
+ return (double)untag_fixnum_fast(tagged);
+ case BIGNUM_TYPE:
+ return s48_bignum_to_double((F_ARRAY*)UNTAG(tagged));
+ case RATIO_TYPE:
+ r = (F_RATIO*)UNTAG(tagged);
+ x = to_float(r->numerator);
+ y = to_float(r->denominator);
+ return x / y;
+ case FLOAT_TYPE:
+ return ((F_FLOAT*)UNTAG(tagged))->n;
+ default:
+ type_error(FLOAT_TYPE,tagged);
+ return 0.0; /* can't happen */
+ }
+}
+
+void primitive_to_float(void)
+{
+ maybe_gc(sizeof(F_FLOAT));
+ drepl(tag_float(to_float(dpeek())));
+}
+
+void primitive_str_to_float(void)
+{
+ F_STRING* str;
+ char *c_str, *end;
+ double f;
+
+ maybe_gc(sizeof(F_FLOAT));
+
+ str = untag_string(dpeek());
+ c_str = to_char_string(str,true);
+ end = c_str;
+ f = strtod(c_str,&end);
+ if(end != c_str + string_capacity(str))
+ drepl(F);
+ else
+ drepl(tag_float(f));
+}
+
+void primitive_float_to_str(void)
+{
+ char tmp[33];
+
+ maybe_gc(sizeof(F_FLOAT));
+
+ snprintf(tmp,32,"%.16g",to_float(dpop()));
+ tmp[32] = '\0';
+ box_char_string(tmp);
+}
+
+#define GC_AND_POP_FLOATS(x,y) \
+ double x, y; \
+ maybe_gc(sizeof(F_FLOAT)); \
+ y = untag_float_fast(dpop()); \
+ x = untag_float_fast(dpop());
+
+void primitive_float_add(void)
+{
+ GC_AND_POP_FLOATS(x,y);
+ dpush(tag_float(x + y));
+}
+
+void primitive_float_subtract(void)
+{
+ GC_AND_POP_FLOATS(x,y);
+ dpush(tag_float(x - y));
+}
+
+void primitive_float_multiply(void)
+{
+ GC_AND_POP_FLOATS(x,y);
+ dpush(tag_float(x * y));
+}
+
+void primitive_float_divfloat(void)
+{
+ GC_AND_POP_FLOATS(x,y);
+ dpush(tag_float(x / y));
+}
+
+void primitive_float_mod(void)
+{
+ GC_AND_POP_FLOATS(x,y);
+ dpush(tag_float(fmod(x,y)));
+}
+
+void primitive_float_less(void)
+{
+ GC_AND_POP_FLOATS(x,y);
+ box_boolean(x < y);
+}
+
+void primitive_float_lesseq(void)
+{
+ GC_AND_POP_FLOATS(x,y);
+ box_boolean(x <= y);
+}
+
+void primitive_float_greater(void)
+{
+ GC_AND_POP_FLOATS(x,y);
+ box_boolean(x > y);
+}
+
+void primitive_float_greatereq(void)
+{
+ GC_AND_POP_FLOATS(x,y);
+ box_boolean(x >= y);
+}
+
+void primitive_facos(void)
+{
+ maybe_gc(sizeof(F_FLOAT));
+ drepl(tag_float(acos(to_float(dpeek()))));
+}
+
+void primitive_fasin(void)
+{
+ maybe_gc(sizeof(F_FLOAT));
+ drepl(tag_float(asin(to_float(dpeek()))));
+}
+
+void primitive_fatan(void)
+{
+ maybe_gc(sizeof(F_FLOAT));
+ drepl(tag_float(atan(to_float(dpeek()))));
+}
+
+void primitive_fatan2(void)
+{
+ double x, y;
+ maybe_gc(sizeof(F_FLOAT));
+ y = to_float(dpop());
+ x = to_float(dpop());
+ dpush(tag_float(atan2(x,y)));
+}
+
+void primitive_fcos(void)
+{
+ maybe_gc(sizeof(F_FLOAT));
+ drepl(tag_float(cos(to_float(dpeek()))));
+}
+
+void primitive_fexp(void)
+{
+ maybe_gc(sizeof(F_FLOAT));
+ drepl(tag_float(exp(to_float(dpeek()))));
+}
+
+void primitive_fcosh(void)
+{
+ maybe_gc(sizeof(F_FLOAT));
+ drepl(tag_float(cosh(to_float(dpeek()))));
+}
+
+void primitive_flog(void)
+{
+ maybe_gc(sizeof(F_FLOAT));
+ drepl(tag_float(log(to_float(dpeek()))));
+}
+
+void primitive_fpow(void)
+{
+ double x, y;
+ maybe_gc(sizeof(F_FLOAT));
+ y = to_float(dpop());
+ x = to_float(dpop());
+ dpush(tag_float(pow(x,y)));
+}
+
+void primitive_fsin(void)
+{
+ maybe_gc(sizeof(F_FLOAT));
+ drepl(tag_float(sin(to_float(dpeek()))));
+}
+
+void primitive_fsinh(void)
+{
+ maybe_gc(sizeof(F_FLOAT));
+ drepl(tag_float(sinh(to_float(dpeek()))));
+}
+
+void primitive_fsqrt(void)
+{
+ maybe_gc(sizeof(F_FLOAT));
+ drepl(tag_float(sqrt(to_float(dpeek()))));
+}
+
+void primitive_float_bits(void)
+{
+ FLOAT_BITS b;
+ b.x = (float)to_float(dpeek());
+ drepl(tag_cell(b.y));
+}
+
+void primitive_bits_float(void)
+{
+ FLOAT_BITS b;
+ b.y = unbox_unsigned_4();
+ dpush(tag_float(b.x));
+}
+
+void primitive_double_bits(void)
+{
+ DOUBLE_BITS b;
+ b.x = to_float(dpop());
+ box_unsigned_8(b.y);
+}
+
+void primitive_bits_double(void)
+{
+ DOUBLE_BITS b;
+ b.y = unbox_unsigned_8();
+ dpush(tag_float(b.x));
+}
+
+#define FLO_DEFBOX(name,type) \
+void name (type flo) \
+{ \
+ dpush(tag_float(flo)); \
+}
+
+#define FLO_DEFUNBOX(name,type) \
+type name(void) \
+{ \
+ return to_float(dpop()); \
+}
+
+FLO_DEFBOX(box_float,float)
+FLO_DEFUNBOX(unbox_float,float)
+FLO_DEFBOX(box_double,double)
+FLO_DEFUNBOX(unbox_double,double)
+
+/* Complex numbers */
+
+void primitive_from_rect(void)
+{
+ CELL real, imaginary;
+ F_COMPLEX* complex;
+
+ maybe_gc(sizeof(F_COMPLEX));
+
+ imaginary = dpop();
+ real = dpop();
+ complex = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX));
+ complex->real = real;
+ complex->imaginary = imaginary;
+ dpush(RETAG(complex,COMPLEX_TYPE));
+}
+
+void fixup_complex(F_COMPLEX* complex)
+{
+ data_fixup(&complex->real);
+ data_fixup(&complex->imaginary);
+}
+
+void collect_complex(F_COMPLEX* complex)
+{
+ copy_handle(&complex->real);
+ copy_handle(&complex->imaginary);
+}
--- /dev/null
+#define FIXNUM_MAX (((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)) - 1)
+#define FIXNUM_MIN (-((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)))
+
+INLINE F_FIXNUM untag_fixnum_fast(CELL tagged)
+{
+ return ((F_FIXNUM)tagged) >> TAG_BITS;
+}
+
+INLINE CELL tag_fixnum(F_FIXNUM untagged)
+{
+ return RETAG(untagged << TAG_BITS,FIXNUM_TYPE);
+}
+
+F_FIXNUM to_fixnum(CELL tagged);
+void primitive_to_fixnum(void);
+
+void primitive_fixnum_add(void);
+void primitive_fixnum_subtract(void);
+void primitive_fixnum_add_fast(void);
+void primitive_fixnum_subtract_fast(void);
+void primitive_fixnum_multiply(void);
+void primitive_fixnum_divint(void);
+void primitive_fixnum_divfloat(void);
+void primitive_fixnum_divmod(void);
+void primitive_fixnum_mod(void);
+void primitive_fixnum_and(void);
+void primitive_fixnum_or(void);
+void primitive_fixnum_xor(void);
+void primitive_fixnum_shift(void);
+void primitive_fixnum_less(void);
+void primitive_fixnum_lesseq(void);
+void primitive_fixnum_greater(void);
+void primitive_fixnum_greatereq(void);
+void primitive_fixnum_not(void);
+DLLEXPORT void box_signed_1(signed char integer);
+DLLEXPORT void box_signed_2(signed short integer);
+DLLEXPORT void box_unsigned_1(unsigned char integer);
+DLLEXPORT void box_unsigned_2(unsigned short integer);
+DLLEXPORT signed char unbox_signed_1(void);
+DLLEXPORT signed short unbox_signed_2(void);
+DLLEXPORT unsigned char unbox_unsigned_1(void);
+DLLEXPORT unsigned short unbox_unsigned_2(void);
+
+CELL bignum_zero;
+CELL bignum_pos_one;
+CELL bignum_neg_one;
+
+INLINE F_ARRAY* untag_bignum_fast(CELL tagged)
+{
+ return (F_ARRAY*)UNTAG(tagged);
+}
+
+INLINE CELL tag_bignum(F_ARRAY* bignum)
+{
+ return RETAG(bignum,BIGNUM_TYPE);
+}
+
+CELL to_cell(CELL x);
+F_ARRAY* to_bignum(CELL tagged);
+void primitive_to_bignum(void);
+void primitive_bignum_eq(void);
+void primitive_bignum_add(void);
+void primitive_bignum_subtract(void);
+void primitive_bignum_multiply(void);
+void primitive_bignum_divint(void);
+void primitive_bignum_divfloat(void);
+void primitive_bignum_divmod(void);
+void primitive_bignum_mod(void);
+void primitive_bignum_and(void);
+void primitive_bignum_or(void);
+void primitive_bignum_xor(void);
+void primitive_bignum_shift(void);
+void primitive_bignum_less(void);
+void primitive_bignum_lesseq(void);
+void primitive_bignum_greater(void);
+void primitive_bignum_greatereq(void);
+void primitive_bignum_not(void);
+
+INLINE CELL tag_integer(F_FIXNUM x)
+{
+ if(x < FIXNUM_MIN || x > FIXNUM_MAX)
+ return tag_bignum(s48_fixnum_to_bignum(x));
+ else
+ return tag_fixnum(x);
+}
+
+INLINE CELL tag_cell(CELL x)
+{
+ if(x > FIXNUM_MAX)
+ return tag_bignum(s48_cell_to_bignum(x));
+ else
+ return tag_fixnum(x);
+}
+
+/* FFI calls this */
+DLLEXPORT void box_signed_cell(F_FIXNUM integer);
+DLLEXPORT F_FIXNUM unbox_signed_cell(void);
+
+DLLEXPORT void box_unsigned_cell(CELL cell);
+DLLEXPORT F_FIXNUM unbox_unsigned_cell(void);
+
+DLLEXPORT void box_signed_4(s32 n);
+DLLEXPORT s32 unbox_signed_4(void);
+
+DLLEXPORT void box_unsigned_4(u32 n);
+DLLEXPORT u32 unbox_unsigned_4(void);
+
+DLLEXPORT void box_signed_8(s64 n);
+DLLEXPORT s64 unbox_signed_8(void);
+
+DLLEXPORT void box_unsigned_8(u64 n);
+DLLEXPORT u64 unbox_unsigned_8(void);
+
+void primitive_from_fraction(void);
+void fixup_ratio(F_RATIO* ratio);
+void collect_ratio(F_RATIO* ratio);
+
+/* for punning */
+typedef union {
+ double x;
+ u64 y;
+} DOUBLE_BITS;
+
+typedef union {
+ float x;
+ u32 y;
+} FLOAT_BITS;
+
+INLINE F_FLOAT* make_float(double n)
+{
+ F_FLOAT* flo = allot_object(FLOAT_TYPE,sizeof(F_FLOAT));
+ flo->n = n;
+ return flo;
+}
+
+INLINE double untag_float_fast(CELL tagged)
+{
+ return ((F_FLOAT*)UNTAG(tagged))->n;
+}
+
+INLINE CELL tag_float(double flo)
+{
+ return RETAG(make_float(flo),FLOAT_TYPE);
+}
+
+double to_float(CELL tagged);
+void primitive_to_float(void);
+void primitive_str_to_float(void);
+void primitive_float_to_str(void);
+void primitive_float_to_bits(void);
+
+void primitive_float_add(void);
+void primitive_float_subtract(void);
+void primitive_float_multiply(void);
+void primitive_float_divfloat(void);
+void primitive_float_mod(void);
+void primitive_float_less(void);
+void primitive_float_lesseq(void);
+void primitive_float_greater(void);
+void primitive_float_greatereq(void);
+
+void primitive_facos(void);
+void primitive_fasin(void);
+void primitive_fatan(void);
+void primitive_fatan2(void);
+void primitive_fcos(void);
+void primitive_fexp(void);
+void primitive_fcosh(void);
+void primitive_flog(void);
+void primitive_fpow(void);
+void primitive_fsin(void);
+void primitive_fsinh(void);
+void primitive_fsqrt(void);
+
+void primitive_float_bits(void);
+void primitive_bits_float(void);
+void primitive_double_bits(void);
+void primitive_bits_double(void);
+
+DLLEXPORT void box_float(float flo);
+DLLEXPORT float unbox_float(void);
+DLLEXPORT void box_double(double flo);
+DLLEXPORT double unbox_double(void);
+
+void primitive_from_rect(void);
+void fixup_complex(F_COMPLEX* complex);
+void collect_complex(F_COMPLEX* complex);
#include "factor.h"
+void *safe_malloc(size_t size)
+{
+ void *ptr = malloc(size);
+ if(ptr == 0)
+ fatal_error("malloc() failed", 0);
+ return ptr;
+}
+
CELL object_size(CELL tagged)
{
if(tagged == F)
{
heap_scan = false;
}
+
+/* scan all the objects in the card */
+INLINE void collect_card(CARD *ptr, CELL here)
+{
+ CARD c = *ptr;
+ CELL offset = (c & CARD_BASE_MASK);
+ CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
+ CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
+
+ if(offset == 0x7f)
+ {
+ if(c == 0xff)
+ critical_error("bad card",(CELL)ptr);
+ else
+ return;
+ }
+
+ while(card_scan < card_end && card_scan < here)
+ card_scan = collect_next(card_scan);
+
+ cards_scanned++;
+}
+
+INLINE void collect_gen_cards(CELL gen)
+{
+ CARD *ptr = ADDR_TO_CARD(generations[gen].base);
+ CELL here = generations[gen].here;
+ CARD *last_card = ADDR_TO_CARD(here);
+
+ if(generations[gen].here == generations[gen].limit)
+ last_card--;
+
+ for(; ptr <= last_card; ptr++)
+ {
+ if(card_marked(*ptr))
+ collect_card(ptr,here);
+ }
+}
+
+void unmark_cards(CELL from, CELL to)
+{
+ CARD *ptr = ADDR_TO_CARD(generations[from].base);
+ CARD *last_card = ADDR_TO_CARD(generations[to].here);
+ if(generations[to].here == generations[to].limit)
+ last_card--;
+ for(; ptr <= last_card; ptr++)
+ unmark_card(ptr);
+}
+
+void clear_cards(CELL from, CELL to)
+{
+ /* NOTE: reverse order due to heap layout. */
+ CARD *last_card = ADDR_TO_CARD(generations[from].limit);
+ CARD *ptr = ADDR_TO_CARD(generations[to].base);
+ for(; ptr < last_card; ptr++)
+ clear_card(ptr);
+}
+
+/* scan cards in all generations older than the one being collected */
+void collect_cards(CELL gen)
+{
+ int i;
+ for(i = gen + 1; i < gen_count; i++)
+ collect_gen_cards(i);
+}
+
+/* Generational copying garbage collector */
+
+CELL init_zone(ZONE *z, CELL size, CELL base)
+{
+ z->base = z->here = base;
+ z->limit = z->base + size;
+ z->alarm = z->base + (size * 3) / 4;
+ return z->limit;
+}
+
+/* update this global variable. since it is stored in a non-volatile register,
+we need to save its contents and re-initialize it when entering a callback,
+and restore its contents when leaving the callback. see stack.c */
+void update_cards_offset(void)
+{
+ cards_offset = (CELL)cards - (heap_start >> CARD_BITS);
+}
+
+/* input parameters must be 8 byte aligned */
+/* the heap layout is important:
+- two semispaces: tenured and prior
+- younger generations follow
+there are two reasons for this:
+- we can easily check if a pointer is in some generation or a younger one
+- the nursery grows into the guard page, so allot() does not have to
+check for out of memory, whereas allot_zone() (used by the GC) longjmp()s
+back to collecting a higher generation */
+void init_arena(CELL gens, CELL young_size, CELL aging_size)
+{
+ int i;
+ CELL alloter;
+
+ CELL total_size = (gens - 1) * young_size + 2 * aging_size;
+ CELL cards_size = total_size / CARD_SIZE;
+
+ gen_count = gens;
+ generations = safe_malloc(sizeof(ZONE) * gen_count);
+
+ heap_start = (CELL)(alloc_bounded_block(total_size)->start);
+ heap_end = heap_start + total_size;
+
+ cards = safe_malloc(cards_size);
+ cards_end = cards + cards_size;
+ update_cards_offset();
+
+ alloter = heap_start;
+
+ alloter = init_zone(&tenured,aging_size,alloter);
+ alloter = init_zone(&prior,aging_size,alloter);
+
+ for(i = gen_count - 2; i >= 0; i--)
+ alloter = init_zone(&generations[i],young_size,alloter);
+
+ clear_cards(NURSERY,TENURED);
+
+ if(alloter != heap_start + total_size)
+ fatal_error("Oops",alloter);
+
+ heap_scan = false;
+ gc_time = 0;
+ minor_collections = 0;
+ cards_scanned = 0;
+}
+
+void collect_callframe_triple(CELL *callframe,
+ CELL *callframe_scan, CELL *callframe_end)
+{
+ *callframe_scan -= *callframe;
+ *callframe_end -= *callframe;
+ copy_handle(callframe);
+ *callframe_scan += *callframe;
+ *callframe_end += *callframe;
+}
+
+void collect_stack(BOUNDED_BLOCK *region, CELL top)
+{
+ CELL bottom = region->start;
+ CELL ptr;
+
+ for(ptr = bottom; ptr <= top; ptr += CELLS)
+ copy_handle((CELL*)ptr);
+}
+
+void collect_callstack(BOUNDED_BLOCK *region, CELL top)
+{
+ CELL bottom = region->start;
+ CELL ptr;
+
+ for(ptr = bottom; ptr <= top; ptr += CELLS * 3)
+ collect_callframe_triple((CELL*)ptr,
+ (CELL*)ptr + 1, (CELL*)ptr + 2);
+}
+
+void collect_roots(void)
+{
+ int i;
+ STACKS *stacks;
+
+ copy_handle(&T);
+ copy_handle(&bignum_zero);
+ copy_handle(&bignum_pos_one);
+ copy_handle(&bignum_neg_one);
+ collect_callframe_triple(&callframe,&callframe_scan,&callframe_end);
+
+ save_stacks();
+ stacks = stack_chain;
+
+ while(stacks)
+ {
+ collect_stack(stacks->data_region,stacks->data);
+ collect_stack(stacks->retain_region,stacks->retain);
+
+ collect_callstack(stacks->call_region,stacks->call);
+
+ if(stacks->next != NULL)
+ {
+ collect_callframe_triple(&stacks->callframe,
+ &stacks->callframe_scan,&stacks->callframe_end);
+ }
+
+ copy_handle(&stacks->catch_save);
+
+ stacks = stacks->next;
+ }
+
+ for(i = 0; i < USER_ENV; i++)
+ copy_handle(&userenv[i]);
+}
+
+/* Given a pointer to oldspace, copy it to newspace. */
+INLINE void *copy_untagged_object(void *pointer, CELL size)
+{
+ void *newpointer;
+ if(newspace->here + size >= newspace->limit)
+ longjmp(gc_jmp,1);
+ newpointer = allot_zone(newspace,size);
+ memcpy(newpointer,pointer,size);
+ return newpointer;
+}
+
+INLINE CELL copy_object_impl(CELL pointer)
+{
+ CELL newpointer = (CELL)copy_untagged_object((void*)UNTAG(pointer),
+ object_size(pointer));
+
+ /* install forwarding pointer */
+ put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED));
+
+ return newpointer;
+}
+
+/* follow a chain of forwarding pointers */
+CELL resolve_forwarding(CELL untagged, CELL tag)
+{
+ CELL header = get(untagged);
+ /* another forwarding pointer */
+ if(TAG(header) == GC_COLLECTED)
+ return resolve_forwarding(UNTAG(header),tag);
+ /* we've found the destination */
+ else
+ {
+ CELL pointer = RETAG(untagged,tag);
+ if(should_copy(untagged))
+ pointer = RETAG(copy_object_impl(pointer),tag);
+ return pointer;
+ }
+}
+
+/*
+Given a pointer to a tagged pointer to oldspace, copy it to newspace.
+If the object has already been copied, return the forwarding
+pointer address without copying anything; otherwise, install
+a new forwarding pointer.
+*/
+CELL copy_object(CELL pointer)
+{
+ CELL tag;
+ CELL header;
+
+ if(pointer == F)
+ return F;
+
+ tag = TAG(pointer);
+
+ if(tag == FIXNUM_TYPE)
+ return pointer;
+
+ header = get(UNTAG(pointer));
+ if(TAG(header) == GC_COLLECTED)
+ return resolve_forwarding(UNTAG(header),tag);
+ else
+ return RETAG(copy_object_impl(pointer),tag);
+}
+
+INLINE void collect_object(CELL scan)
+{
+ switch(untag_header(get(scan)))
+ {
+ case RATIO_TYPE:
+ collect_ratio((F_RATIO*)scan);
+ break;
+ case COMPLEX_TYPE:
+ collect_complex((F_COMPLEX*)scan);
+ break;
+ case WORD_TYPE:
+ collect_word((F_WORD*)scan);
+ break;
+ case ARRAY_TYPE:
+ case TUPLE_TYPE:
+ case QUOTATION_TYPE:
+ collect_array((F_ARRAY*)scan);
+ break;
+ case HASHTABLE_TYPE:
+ collect_hashtable((F_HASHTABLE*)scan);
+ break;
+ case VECTOR_TYPE:
+ collect_vector((F_VECTOR*)scan);
+ break;
+ case SBUF_TYPE:
+ collect_sbuf((F_SBUF*)scan);
+ break;
+ case DLL_TYPE:
+ collect_dll((DLL*)scan);
+ break;
+ case ALIEN_TYPE:
+ collect_alien((ALIEN*)scan);
+ break;
+ case WRAPPER_TYPE:
+ collect_wrapper((F_WRAPPER*)scan);
+ break;
+ }
+}
+
+CELL collect_next(CELL scan)
+{
+ CELL size = untagged_object_size(scan);
+ collect_object(scan);
+ return scan + size;
+}
+
+void reset_generations(CELL from, CELL to)
+{
+ CELL i;
+ for(i = from; i <= to; i++)
+ generations[i].here = generations[i].base;
+ clear_cards(from,to);
+}
+
+void begin_gc(CELL gen)
+{
+ collecting_gen = gen;
+ collecting_gen_start = generations[gen].base;
+
+ if(gen == TENURED)
+ {
+ /* when collecting the oldest generation, rotate it
+ with the semispace */
+ ZONE z = generations[gen];
+ generations[gen] = prior;
+ prior = z;
+ generations[gen].here = generations[gen].base;
+ newspace = &generations[gen];
+ clear_cards(TENURED,TENURED);
+ }
+ else
+ {
+ /* when collecting a younger generation, we copy
+ reachable objects to the next oldest generation,
+ so we set the newspace so the next generation. */
+ newspace = &generations[gen + 1];
+ }
+}
+
+void end_gc(CELL gen)
+{
+ if(gen == TENURED)
+ {
+ /* we did a full collection; no more
+ old-to-new pointers remain since everything
+ is in tenured space */
+ unmark_cards(TENURED,TENURED);
+ /* all generations except tenured space are
+ now empty */
+ reset_generations(NURSERY,TENURED - 1);
+
+ fprintf(stderr,"*** Major GC (%ld minor, %ld cards)\n",
+ minor_collections,cards_scanned);
+ minor_collections = 0;
+ cards_scanned = 0;
+ }
+ else
+ {
+ /* we collected a younger generation. so the
+ next-oldest generation no longer has any
+ pointers into the younger generation (the
+ younger generation is empty!) */
+ unmark_cards(gen + 1,gen + 1);
+ /* all generations up to and including the one
+ collected are now empty */
+ reset_generations(NURSERY,gen);
+
+ minor_collections++;
+ }
+}
+
+/* collect gen and all younger generations */
+void garbage_collection(CELL gen)
+{
+ s64 start = current_millis();
+ CELL scan;
+
+ if(heap_scan)
+ critical_error("GC disabled during heap scan",gen);
+
+ /* we come back here if a generation is full */
+ if(setjmp(gc_jmp))
+ {
+ if(gen == TENURED)
+ {
+ /* oops, out of memory */
+ critical_error("Out of memory",0);
+ }
+ else
+ gen++;
+ }
+
+ begin_gc(gen);
+
+ /* initialize chase pointer */
+ scan = newspace->here;
+
+ /* collect objects referenced from stacks and environment */
+ collect_roots();
+
+ /* collect objects referenced from older generations */
+ collect_cards(gen);
+
+ /* collect literal objects referenced from compiled code */
+ collect_literals();
+
+ while(scan < newspace->here)
+ scan = collect_next(scan);
+
+ end_gc(gen);
+
+ gc_time += (current_millis() - start);
+}
+
+void primitive_gc(void)
+{
+ CELL gen = to_fixnum(dpop());
+ if(gen <= NURSERY)
+ gen = NURSERY;
+ else if(gen >= TENURED)
+ gen = TENURED;
+ garbage_collection(gen);
+}
+
+/* WARNING: only call this from a context where all local variables
+are also reachable via the GC roots. */
+void maybe_gc(CELL size)
+{
+ if(nursery.here + size > nursery.alarm)
+ {
+ CELL gen = NURSERY;
+ while(gen < TENURED)
+ {
+ ZONE *z = &generations[gen + 1];
+ if(z->here < z->alarm)
+ break;
+ gen++;
+ }
+
+ garbage_collection(gen);
+ }
+}
+
+void simple_gc(void)
+{
+ maybe_gc(0);
+}
+
+void primitive_gc_time(void)
+{
+ simple_gc();
+ dpush(tag_bignum(s48_long_long_to_bignum(gc_time)));
+}
+void *safe_malloc(size_t size);
+
typedef struct {
CELL start;
CELL size;
return (a + 7) & ~7;
}
-#define TAG_MASK 7
-#define TAG_BITS 3
-#define TAG(cell) ((CELL)(cell) & TAG_MASK)
-#define RETAG(cell,tag) ((CELL)(cell) | (tag))
-#define UNTAG(cell) ((CELL)(cell) & ~TAG_MASK)
-
-/*** Tags ***/
-#define FIXNUM_TYPE 0
-#define BIGNUM_TYPE 1
-#define WORD_TYPE 2
-#define OBJECT_TYPE 3
-#define RATIO_TYPE 4
-#define FLOAT_TYPE 5
-#define COMPLEX_TYPE 6
-#define WRAPPER_TYPE 7
-
-#define HEADER_TYPE 7 /* anything less than or equal to this is a tag */
-#define GC_COLLECTED 0 /* See gc.c */
-
-/*** Header types ***/
-#define ARRAY_TYPE 8
-
-/* Canonical F object */
-#define F_TYPE 9
-#define F RETAG(0,OBJECT_TYPE)
-
-#define HASHTABLE_TYPE 10
-#define VECTOR_TYPE 11
-#define STRING_TYPE 12
-#define SBUF_TYPE 13
-#define QUOTATION_TYPE 14
-#define DLL_TYPE 15
-#define ALIEN_TYPE 16
-#define TUPLE_TYPE 17
-#define BYTE_ARRAY_TYPE 18
-
-#define TYPE_COUNT 19
-
/* Canonical T object. It's just a word */
CELL T;
void primitive_begin_scan(void);
void primitive_next_object(void);
void primitive_end_scan(void);
+
+CELL heap_start;
+CELL heap_end;
+
+/* card marking write barrier. a card is a byte storing a mark flag,
+and the offset (in cells) of the first object in the card.
+
+the mark flag is set by the write barrier when an object in the
+card has a slot written to.
+
+the offset of the first object is set by the allocator.
+*/
+#define CARD_MARK_MASK 0x80
+#define CARD_BASE_MASK 0x7f
+typedef u8 CARD;
+
+CARD *cards;
+CARD *cards_end;
+
+/* A card is 16 bytes (128 bits), 5 address bits per card.
+it is important that 7 bits is sufficient to represent every
+offset within the card */
+#define CARD_SIZE 128
+#define CARD_BITS 7
+#define ADDR_CARD_MASK (CARD_SIZE-1)
+
+INLINE CARD card_marked(CARD c)
+{
+ return c & CARD_MARK_MASK;
+}
+
+INLINE void unmark_card(CARD *c)
+{
+ *c &= CARD_BASE_MASK;
+}
+
+INLINE void clear_card(CARD *c)
+{
+ *c = CARD_BASE_MASK; /* invalid value */
+}
+
+INLINE u8 card_base(CARD c)
+{
+ return c & CARD_BASE_MASK;
+}
+
+#define ADDR_TO_CARD(a) (CARD*)(((CELL)a >> CARD_BITS) + cards_offset)
+#define CARD_TO_ADDR(c) (CELL*)(((CELL)c - cards_offset)<<CARD_BITS)
+
+/* this is an inefficient write barrier. compiled definitions use a more
+efficient one hand-coded in assembly. the write barrier must be called
+any time we are potentially storing a pointer from an older generation
+to a younger one */
+INLINE void write_barrier(CELL address)
+{
+ CARD *c = ADDR_TO_CARD(address);
+ *c |= CARD_MARK_MASK;
+}
+
+/* we need to remember the first object allocated in the card */
+INLINE void allot_barrier(CELL address)
+{
+ CARD *ptr = ADDR_TO_CARD(address);
+ CARD c = *ptr;
+ CELL b = card_base(c);
+ CELL a = (address & ADDR_CARD_MASK);
+ *ptr = (card_marked(c) | ((b < a) ? b : a));
+}
+
+void unmark_cards(CELL from, CELL to);
+void clear_cards(CELL from, CELL to);
+void collect_cards(CELL gen);
+
+/* generational copying GC divides memory into zones */
+typedef struct {
+ /* start of zone */
+ CELL base;
+ /* allocation pointer */
+ CELL here;
+ /* only for nursery: when it gets this full, call GC */
+ CELL alarm;
+ /* end of zone */
+ CELL limit;
+} ZONE;
+
+/* total number of generations. */
+CELL gen_count;
+
+/* the 0th generation is where new objects are allocated. */
+#define NURSERY 0
+/* the oldest generation */
+#define TENURED (gen_count-1)
+
+DLLEXPORT ZONE *generations;
+
+/* used during garbage collection only */
+ZONE *newspace;
+
+#define tenured generations[TENURED]
+#define nursery generations[NURSERY]
+
+/* spare semi-space; rotates with tenured. */
+ZONE prior;
+
+/* compiled code */
+ZONE compiling;
+
+INLINE bool in_zone(ZONE* z, CELL pointer)
+{
+ return pointer >= z->base && pointer < z->limit;
+}
+
+CELL init_zone(ZONE *z, CELL size, CELL base);
+
+void init_arena(CELL gen_count, CELL young_size, CELL aging_size);
+
+/* statistics */
+s64 gc_time;
+CELL minor_collections;
+CELL cards_scanned;
+
+/* only meaningful during a GC */
+CELL collecting_gen;
+CELL collecting_gen_start;
+
+/* test if the pointer is in generation being collected, or a younger one.
+init_arena() arranges things so that the older generations are first,
+so we have to check that the pointer occurs after the beginning of
+the requested generation. */
+#define COLLECTING_GEN(ptr) (collecting_gen_start <= ptr)
+
+INLINE bool should_copy(CELL untagged)
+{
+ if(collecting_gen == TENURED)
+ return !in_zone(newspace,untagged);
+ else
+ return(in_zone(&prior,untagged) || COLLECTING_GEN(untagged));
+}
+
+CELL copy_object(CELL pointer);
+#define COPY_OBJECT(lvalue) if(should_copy(lvalue)) lvalue = copy_object(lvalue)
+
+INLINE void copy_handle(CELL *handle)
+{
+ COPY_OBJECT(*handle);
+}
+
+/* in case a generation fills up in the middle of a gc, we jump back
+up to try collecting the next generation. */
+jmp_buf gc_jmp;
+
+/* A heap walk allows useful things to be done, like finding all
+references to an object for debugging purposes. */
+CELL heap_scan_ptr;
+
+/* GC is off during heap walking */
+bool heap_scan;
+
+INLINE void *allot_zone(ZONE *z, CELL a)
+{
+ CELL h = z->here;
+ z->here = h + align8(a);
+ if(z->here > z->limit)
+ {
+ fprintf(stderr,"Nursery space exhausted\n");
+ factorbug();
+ }
+
+ allot_barrier(h);
+ return (void*)h;
+}
+
+INLINE void *allot(CELL a)
+{
+ return allot_zone(&nursery,a);
+}
+
+/*
+ * It is up to the caller to fill in the object's fields in a meaningful
+ * fashion!
+ */
+INLINE void* allot_object(CELL type, CELL length)
+{
+ CELL* object = allot(length);
+ *object = tag_header(type);
+ return object;
+}
+
+void update_cards_offset(void);
+CELL collect_next(CELL scan);
+void garbage_collection(CELL gen);
+void primitive_gc(void);
+void maybe_gc(CELL size);
+DLLEXPORT void simple_gc(void);
+void primitive_gc_time(void);
+++ /dev/null
-#include "factor.h"
-
-void *safe_malloc(size_t size)
-{
- void *ptr = malloc(size);
- if(ptr == 0)
- fatal_error("malloc() failed", 0);
- return ptr;
-}
-
-void primitive_exit(void)
-{
- exit(to_fixnum(dpop()));
-}
-
-void primitive_os_env(void)
-{
- char *name, *value;
-
- maybe_gc(0);
-
- name = pop_char_string();
- value = getenv(name);
- if(value == NULL)
- dpush(F);
- else
- box_char_string(getenv(name));
-}
-
-void primitive_eq(void)
-{
- box_boolean(dpop() == dpop());
-}
-
-#ifdef WIN32
-s64 current_millis(void)
-{
- FILETIME t;
- GetSystemTimeAsFileTime(&t);
- return (((s64)t.dwLowDateTime | (s64)t.dwHighDateTime<<32) - EPOCH_OFFSET)
- / 10000;
-}
-#else
-s64 current_millis(void)
-{
- struct timeval t;
- gettimeofday(&t,NULL);
- return (s64)t.tv_sec * 1000 + t.tv_usec/1000;
-}
-#endif
-
-void primitive_millis(void)
-{
- maybe_gc(0);
- dpush(tag_bignum(s48_long_long_to_bignum(current_millis())));
-}
-
-#ifdef WIN32
-// frees memory allocated by win32 api calls
-char *buffer_to_c_string(char *buffer)
-{
- int capacity = strlen(buffer);
- F_STRING *_c_str = allot_string(capacity / CHARS + 1);
- u8 *c_str = (u8*)(_c_str + 1);
- strcpy(c_str, buffer);
- LocalFree(buffer);
- return (char*)c_str;
-}
-
-F_STRING *get_error_message()
-{
- DWORD id = GetLastError();
- return from_c_string(error_message(id));
-}
-
-char *error_message(DWORD id)
-{
- char *buffer;
- int index;
-
- FormatMessage(
- FORMAT_MESSAGE_ALLOCATE_BUFFER |
- FORMAT_MESSAGE_FROM_SYSTEM,
- NULL,
- id,
- MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
- (LPTSTR) &buffer,
- 0, NULL);
-
- // strip whitespace from end
- index = strlen(buffer) - 1;
- while(index >= 0 && isspace(buffer[index]))
- buffer[index--] = 0;
-
- return buffer_to_c_string(buffer);
-}
-#endif
+++ /dev/null
-void *safe_malloc(size_t size);
-void primitive_exit(void);
-void primitive_os_env(void);
-void primitive_eq(void);
-s64 current_millis(void);
-void primitive_millis(void);
-#ifdef WIN32
-char *buffer_to_c_string(char *buffer);
-F_STRING *get_error_message(void);
-DLLEXPORT char *error_message(DWORD id);
-#endif
--- /dev/null
+#define FACTOR_OS_STRING "freebsd"
--- /dev/null
+#include "factor.h"
+
+void platform_run(void)
+{
+ run_toplevel();
+}
+
+const char *default_image_path(void)
+{
+ return "factor.image";
+}
+
+void init_signals(void)
+{
+ unix_init_signals();
+}
--- /dev/null
+void init_signals(void);
+INLINE void early_init(void) {}
+const char *default_image_path(void);
--- /dev/null
+#define FACTOR_OS_STRING "linux"
--- /dev/null
+#define SIGSEGV_EXC_STATE_TYPE ppc_exception_state_t
+#define SIGSEGV_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE
+#define SIGSEGV_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT
+#define SIGSEGV_THREAD_STATE_TYPE ppc_thread_state_t
+#define SIGSEGV_THREAD_STATE_FLAVOR PPC_THREAD_STATE
+#define SIGSEGV_THREAD_STATE_COUNT PPC_THREAD_STATE_COUNT
+#define SIGSEGV_STACK_POINTER(thr_state) (thr_state).r1
+#define SIGSEGV_PROGRAM_COUNTER(thr_state) (thr_state).srr0
--- /dev/null
+#define SIGSEGV_EXC_STATE_TYPE i386_exception_state_t
+#define SIGSEGV_EXC_STATE_FLAVOR i386_EXCEPTION_STATE
+#define SIGSEGV_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT
+#define SIGSEGV_THREAD_STATE_TYPE i386_thread_state_t
+#define SIGSEGV_THREAD_STATE_FLAVOR i386_THREAD_STATE
+#define SIGSEGV_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT
+#define SIGSEGV_STACK_POINTER(thr_state) (thr_state).esp
+#define SIGSEGV_PROGRAM_COUNTER(thr_state) (thr_state).eip
--- /dev/null
+#define FACTOR_OS_STRING "macosx"
+void init_signals(void);
+void early_init(void);
+const char *default_image_path(void);
--- /dev/null
+#include "factor.h"
+
+#import "Foundation/NSAutoreleasePool.h"
+#import "Foundation/NSBundle.h"
+#import "Foundation/NSException.h"
+#import "Foundation/NSString.h"
+
+static CELL error;
+
+/* This code is convoluted because Cocoa places restrictions on longjmp and
+exception handling. In particular, a longjmp can never cross an NS_DURING,
+NS_HANDLER or NS_ENDHANDLER. */
+void platform_run()
+{
+ error = F;
+
+ for(;;)
+ {
+NS_DURING
+ SETJMP(stack_chain->toplevel);
+ handle_error();
+
+ if(error != F)
+ {
+ CELL e = error;
+ error = F;
+ general_error(ERROR_OBJECTIVE_C,e,F,true);
+ }
+
+ run();
+ NS_VOIDRETURN;
+NS_HANDLER
+ error = tag_object(make_alien(F,(CELL)localException));
+NS_ENDHANDLER
+ }
+}
+
+void early_init(void)
+{
+ [[NSAutoreleasePool alloc] init];
+}
+
+const char *default_image_path(void)
+{
+ NSBundle *bundle = [NSBundle mainBundle];
+ NSString *image = [[bundle resourcePath] stringByAppendingString:@"/factor.image"];
+ return [image cString];
+}
+
+void init_signals(void)
+{
+ unix_init_signals();
+ mach_initialize();
+}
--- /dev/null
+#define FACTOR_OS_STRING "solaris"
--- /dev/null
+#include "factor.h"
+
+static void *null_dll;
+
+s64 current_millis(void)
+{
+ struct timeval t;
+ gettimeofday(&t,NULL);
+ return (s64)t.tv_sec * 1000 + t.tv_usec/1000;
+}
+
+void init_ffi(void)
+{
+ null_dll = dlopen(NULL,RTLD_LAZY);
+}
+
+void ffi_dlopen(DLL *dll, bool error)
+{
+ void *dllptr = dlopen(to_char_string(untag_string(dll->path),true), RTLD_LAZY);
+
+ if(dllptr == NULL)
+ {
+ if(error)
+ {
+ general_error(ERROR_FFI,tag_object(
+ from_char_string(dlerror())),F,true);
+ }
+ else
+ dll->dll = NULL;
+
+ return;
+ }
+
+ dll->dll = dllptr;
+}
+
+void *ffi_dlsym(DLL *dll, F_STRING *symbol, bool error)
+{
+ void *handle = (dll == NULL ? null_dll : dll->dll);
+ void *sym = dlsym(handle,to_char_string(symbol,true));
+ if(sym == NULL)
+ {
+ if(error)
+ {
+ general_error(ERROR_FFI,tag_object(
+ from_char_string(dlerror())),F,true);
+ }
+
+ return NULL;
+ }
+ return sym;
+}
+
+void ffi_dlclose(DLL *dll)
+{
+ if(dlclose(dll->dll))
+ {
+ general_error(ERROR_FFI,tag_object(
+ from_char_string(dlerror())),F,true);
+ }
+ dll->dll = NULL;
+}
+
+void primitive_stat(void)
+{
+ struct stat sb;
+ F_STRING* path;
+
+ maybe_gc(0);
+
+ path = untag_string(dpop());
+ if(stat(to_char_string(path,true),&sb) < 0)
+ dpush(F);
+ else
+ {
+ CELL dirp = tag_boolean(S_ISDIR(sb.st_mode));
+ CELL mode = tag_fixnum(sb.st_mode & ~S_IFMT);
+ CELL size = tag_bignum(s48_long_long_to_bignum(sb.st_size));
+ CELL mtime = tag_integer(sb.st_mtime);
+ dpush(make_array_4(dirp,mode,size,mtime));
+ }
+}
+
+void primitive_read_dir(void)
+{
+ F_STRING *path;
+ DIR* dir;
+ F_ARRAY *result;
+ CELL result_count = 0;
+
+ maybe_gc(0);
+
+ result = array(ARRAY_TYPE,100,F);
+
+ path = untag_string(dpop());
+ dir = opendir(to_char_string(path,true));
+ if(dir != NULL)
+ {
+ struct dirent* file;
+
+ while((file = readdir(dir)) != NULL)
+ {
+ CELL name = tag_object(from_char_string(file->d_name));
+ if(result_count == array_capacity(result))
+ {
+ result = resize_array(result,
+ result_count * 2,F);
+ }
+
+ put(AREF(result,result_count),name);
+ result_count++;
+ }
+
+ closedir(dir);
+ }
+
+ result = resize_array(result,result_count,F);
+
+ dpush(tag_object(result));
+}
+
+void primitive_cwd(void)
+{
+ char wd[MAXPATHLEN];
+ maybe_gc(0);
+ if(getcwd(wd,MAXPATHLEN) == NULL)
+ io_error();
+ box_char_string(wd);
+}
+
+void primitive_cd(void)
+{
+ maybe_gc(0);
+ chdir(pop_char_string());
+}
+
+BOUNDED_BLOCK *alloc_bounded_block(CELL size)
+{
+ int pagesize = getpagesize();
+
+ char *array = mmap((void*)0,pagesize + size + pagesize,
+ PROT_READ | PROT_WRITE | PROT_EXEC,
+ MAP_ANON | MAP_PRIVATE,-1,0);
+
+ if(array == NULL)
+ fatal_error("Cannot allocate memory region",0);
+
+ if(mprotect(array,pagesize,PROT_NONE) == -1)
+ fatal_error("Cannot protect low guard page",(CELL)array);
+
+ if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
+ fatal_error("Cannot protect high guard page",(CELL)array);
+
+ BOUNDED_BLOCK *retval = safe_malloc(sizeof(BOUNDED_BLOCK));
+
+ retval->start = (CELL)(array + pagesize);
+ retval->size = size;
+
+ return retval;
+}
+
+void dealloc_bounded_block(BOUNDED_BLOCK *block)
+{
+ int pagesize = getpagesize();
+
+ int retval = munmap((void*)(block->start - pagesize),
+ pagesize + block->size + pagesize);
+
+ if(retval)
+ fatal_error("Failed to unmap region",0);
+
+ free(block);
+}
+
+// this function tests if a given faulting location is in a poison page. The
+// page address is taken from area + round_up_to_page_size(area_size) +
+// pagesize*offset
+static bool in_page(void *fault, void *i_area, CELL area_size, int offset)
+{
+ const int pagesize = getpagesize();
+ intptr_t area = (intptr_t) i_area;
+ area += pagesize * ((area_size + (pagesize - 1)) / pagesize);
+ area += offset * pagesize;
+
+ const int page = area / pagesize;
+ const int fault_page = (intptr_t)fault / pagesize;
+ return page == fault_page;
+}
+
+void signal_handler(int signal, siginfo_t* siginfo, void* uap)
+{
+ if(in_page(siginfo->si_addr, (void *) ds_bot, 0, -1))
+ general_error(ERROR_DS_UNDERFLOW,F,F,false);
+ else if(in_page(siginfo->si_addr, (void *) ds_bot, ds_size, 0))
+ general_error(ERROR_DS_OVERFLOW,F,F,false);
+ else if(in_page(siginfo->si_addr, (void *) rs_bot, 0, -1))
+ general_error(ERROR_RS_UNDERFLOW,F,F,false);
+ else if(in_page(siginfo->si_addr, (void *) rs_bot, rs_size, 0))
+ general_error(ERROR_RS_OVERFLOW,F,F,false);
+ else if(in_page(siginfo->si_addr, (void *) cs_bot, 0, -1))
+ general_error(ERROR_CS_UNDERFLOW,F,F,false);
+ else if(in_page(siginfo->si_addr, (void *) cs_bot, cs_size, 0))
+ general_error(ERROR_CS_OVERFLOW,F,F,false);
+ else
+ signal_error(signal);
+}
+
+static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact)
+{
+ int ret;
+ do
+ {
+ ret = sigaction(signum, act, oldact);
+ } while(ret == -1 && errno == EINTR);
+}
+
+void unix_init_signals(void)
+{
+ struct sigaction custom_sigaction;
+ struct sigaction ign_sigaction;
+
+ sigemptyset(&custom_sigaction.sa_mask);
+ custom_sigaction.sa_sigaction = signal_handler;
+ custom_sigaction.sa_flags = SA_SIGINFO;
+ sigaction_safe(SIGABRT,&custom_sigaction,NULL);
+ sigaction_safe(SIGFPE,&custom_sigaction,NULL);
+ sigaction_safe(SIGBUS,&custom_sigaction,NULL);
+ sigaction_safe(SIGQUIT,&custom_sigaction,NULL);
+ sigaction_safe(SIGSEGV,&custom_sigaction,NULL);
+ sigaction_safe(SIGILL,&custom_sigaction,NULL);
+
+ sigemptyset(&ign_sigaction.sa_mask);
+ ign_sigaction.sa_handler = SIG_IGN;
+ sigaction_safe(SIGPIPE,&ign_sigaction,NULL);
+}
+
+void reset_stdio(void)
+{
+ fcntl(0,F_SETFL,0);
+ fcntl(1,F_SETFL,0);
+}
--- /dev/null
+#include <dirent.h>
+#include <sys/mman.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+#include <sys/time.h>
+#include <dlfcn.h>
+
+#define DLLEXPORT
+#define SETJMP(jmpbuf) sigsetjmp(jmpbuf,1)
+#define LONGJMP siglongjmp
+#define JMP_BUF sigjmp_buf
+
+void init_ffi(void);
+void ffi_dlopen(DLL *dll, bool error);
+void *ffi_dlsym(DLL *dll, F_STRING *symbol, bool error);
+void ffi_dlclose(DLL *dll);
+
+void unix_init_signals(void);
+void signal_handler(int signal, siginfo_t* siginfo, void* uap);
+void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
+
+void primitive_open_file(void);
+void primitive_stat(void);
+void primitive_read_dir(void);
+void primitive_cwd(void);
+void primitive_cd(void);
+
+s64 current_millis(void);
+
+void reset_stdio(void);
--- /dev/null
+#include "factor.h"
+
+// frees memory allocated by win32 api calls
+char *buffer_to_c_string(char *buffer)
+{
+ int capacity = strlen(buffer);
+ F_STRING *_c_str = allot_string(capacity / CHARS + 1);
+ u8 *c_str = (u8*)(_c_str + 1);
+ strcpy(c_str, buffer);
+ LocalFree(buffer);
+ return (char*)c_str;
+}
+
+F_STRING *get_error_message()
+{
+ DWORD id = GetLastError();
+ return from_c_string(error_message(id));
+}
+
+char *error_message(DWORD id)
+{
+ char *buffer;
+ int index;
+
+ FormatMessage(
+ FORMAT_MESSAGE_ALLOCATE_BUFFER |
+ FORMAT_MESSAGE_FROM_SYSTEM,
+ NULL,
+ id,
+ MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
+ (LPTSTR) &buffer,
+ 0, NULL);
+
+ // strip whitespace from end
+ index = strlen(buffer) - 1;
+ while(index >= 0 && isspace(buffer[index]))
+ buffer[index--] = 0;
+
+ return buffer_to_c_string(buffer);
+}
+
+s64 current_millis(void)
+{
+ FILETIME t;
+ GetSystemTimeAsFileTime(&t);
+ return (((s64)t.dwLowDateTime | (s64)t.dwHighDateTime<<32) - EPOCH_OFFSET)
+ / 10000;
+}
+
+void ffi_dlopen (DLL *dll, bool error)
+{
+ HMODULE module;
+ char *path = to_c_string(untag_string(dll->path),true);
+
+ module = LoadLibrary(path);
+
+ if (!module)
+ {
+ dll->dll = NULL;
+ if(error)
+ general_error(ERROR_FFI, tag_object(get_error_message()),true);
+ else
+ return;
+ }
+
+ dll->dll = module;
+}
+
+void *ffi_dlsym (DLL *dll, F_STRING *symbol, bool error)
+{
+ void *sym = GetProcAddress(dll ? (HMODULE)dll->dll : GetModuleHandle(NULL),
+ to_c_string(symbol,true));
+
+ if (!sym)
+ {
+ if(error)
+ general_error(ERROR_FFI, tag_object(get_error_message()),true);
+ else
+ return NULL;
+ }
+
+ return sym;
+}
+
+void ffi_dlclose (DLL *dll)
+{
+ FreeLibrary((HMODULE)dll->dll);
+ dll->dll = NULL;
+}
+
+void primitive_stat(void)
+{
+ F_STRING *path;
+ WIN32_FILE_ATTRIBUTE_DATA st;
+
+ maybe_gc(0);
+ path = untag_string(dpop());
+
+ if(!GetFileAttributesEx(to_c_string(path,true), GetFileExInfoStandard, &st))
+ {
+ dpush(F);
+ }
+ else
+ {
+ CELL dirp = tag_boolean(st.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
+ CELL size = tag_bignum(s48_long_long_to_bignum(
+ (s64)st.nFileSizeLow | (s64)st.nFileSizeHigh << 32));
+ CELL mtime = tag_integer((int)
+ ((*(s64*)&st.ftLastWriteTime - EPOCH_OFFSET) / 10000000));
+ dpush(make_array_4(dirp,tag_fixnum(0),size,mtime));
+ }
+}
+
+void primitive_read_dir(void)
+{
+ F_STRING *path;
+ HANDLE dir;
+ WIN32_FIND_DATA find_data;
+ F_ARRAY *result;
+ CELL result_count = 0;
+
+ maybe_gc(0);
+
+ result = array(ARRAY_TYPE,100,F);
+
+ path = untag_string(dpop());
+ if (INVALID_HANDLE_VALUE != (dir = FindFirstFile(".\\*", &find_data)))
+ {
+ do
+ {
+ CELL name = tag_object(from_c_string(
+ find_data.cFileName));
+
+ if(result_count == array_capacity(result))
+ {
+ result = resize_array(result,
+ result_count * 2,F);
+ }
+
+ put(AREF(result,result_count),name);
+ result_count++;
+ }
+ while (FindNextFile(dir, &find_data));
+ CloseHandle(dir);
+ }
+
+ result = resize_array(result,result_count,F);
+
+ dpush(tag_object(result));
+}
+
+void primitive_cwd(void)
+{
+ char buf[MAX_PATH];
+
+ maybe_gc(0);
+ if(!GetCurrentDirectory(MAX_PATH, buf))
+ io_error();
+
+ box_c_string(buf);
+}
+
+void primitive_cd(void)
+{
+ maybe_gc(0);
+ SetCurrentDirectory(pop_c_string());
+}
+
+BOUNDED_BLOCK *alloc_bounded_block(CELL size)
+{
+ SYSTEM_INFO si;
+ char *mem;
+ DWORD ignore;
+
+ GetSystemInfo(&si);
+ if((mem = (char *)VirtualAlloc(NULL, si.dwPageSize*2 + size, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0)
+ fatal_error("VirtualAlloc() failed in alloc_bounded_block()",0);
+
+ if (!VirtualProtect(mem, si.dwPageSize, PAGE_NOACCESS, &ignore))
+ fatal_error("Cannot allocate low guard page", (CELL)mem);
+
+ if (!VirtualProtect(mem+size+si.dwPageSize, si.dwPageSize, PAGE_NOACCESS, &ignore))
+ fatal_error("Cannot allocate high guard page", (CELL)mem);
+
+ BOUNDED_BLOCK *block = safe_malloc(sizeof(BOUNDED_BLOCK));
+
+ block->start = (int)mem + si.dwPageSize;
+ block->size = size;
+
+ return block;
+}
+
+void dealloc_bounded_block(BOUNDED_BLOCK *block)
+{
+ SYSTEM_INFO si;
+ GetSystemInfo(&si);
+ if(!VirtualFree((void*)(block->start - si.dwPageSize), 0, MEM_RELEASE))
+ fatal_error("VirtualFree() failed",0);
+ free(block);
+}
+
+/* SEH support. Proceed with caution. */
+typedef long exception_handler_t(
+ void *rec, void *frame, void *context, void *dispatch);
+
+typedef struct exception_record {
+ struct exception_record *next_handler;
+ void *handler_func;
+} exception_record_t;
+
+void seh_call(void (*func)(), exception_handler_t *handler)
+{
+ exception_record_t record;
+ asm("mov %%fs:0, %0" : "=r" (record.next_handler));
+ asm("mov %0, %%fs:0" : : "r" (&record));
+ record.handler_func = handler;
+ func();
+ asm("mov %0, %%fs:0" : "=r" (record.next_handler));
+}
+
+static long exception_handler(void *rec, void *frame, void *ctx, void *dispatch)
+{
+ signal_error(SIGSEGV);
+}
+
+void platform_run(void)
+{
+ seh_call(run_toplevel, exception_handler);
+}
+
+const char *default_image_path(void)
+{
+ return "factor.image";
+}
--- /dev/null
+#include <windows.h>
+#include <ctype.h>
+
+#define FACTOR_OS_STRING "windows"
+
+#define DLLEXPORT __declspec(dllexport)
+#define SETJMP setjmp
+#define LONGJMP longjmp
+#define JMP_BUF jmp_buf
+
+/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
+#define EPOCH_OFFSET 0x019db1ded53e8000LL
+
+char *buffer_to_c_string(char *buffer);
+F_STRING *get_error_message(void);
+DLLEXPORT char *error_message(DWORD id);
+
+INLINE void init_ffi(void) {}
+void ffi_dlopen(DLL *dll, bool error);
+void *ffi_dlsym(DLL *dll, F_STRING *symbol, bool error);
+void ffi_dlclose(DLL *dll);
+
+void primitive_open_file(void);
+void primitive_stat(void);
+void primitive_read_dir(void);
+void primitive_cwd(void);
+void primitive_cd(void);
+
+INLINE void init_signals(void) {}
+INLINE void early_init(void) {}
+const char *default_image_path(void);
+
+s64 current_millis(void);
+
+INLINE void reset_stdio(void) {}
+#define INLINE inline static
+
#if defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32)
#define FACTOR_X86
#elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC)
#define FACTOR_AMD64
#endif
-#ifdef __APPLE__
- /* Horray for Mach-O */
- #define MANGLE(sym) _##sym
+#ifdef WINDOWS
+ #include "os-windows.h"
#else
- #define MANGLE(sym) sym
+ #include "os-unix.h"
+
+ #ifdef __APPLE__
+ #include "os-macosx.h"
+ #include "mach_signal.h"
+
+ #ifdef FACTOR_X86
+ #include "os-macosx-x86.h"
+ #elif defined(FACTOR_PPC)
+ #include "os-macosx-ppc.h"
+ #endif
+ #else
+ #include "os-genunix.h"
+ #ifdef __FreeBSD__
+ #include "os-freebsd.h"
+ #elif defined(linux)
+ #include "os-linux.h"
+ #elif defined(__sun)
+ #include "os-solaris.h"
+ #else
+ #error "Unsupported OS"
+ #endif
+ #endif
#endif
-#if defined(FACTOR_X86)
- #define FACTOR_CPU_STRING "x86"
+#ifdef FACTOR_X86
+ #include "cpu-x86.h"
#elif defined(FACTOR_PPC)
- #define FACTOR_CPU_STRING "ppc"
+ #include "cpu-ppc.h"
#elif defined(FACTOR_AMD64)
- #define FACTOR_CPU_STRING "amd64"
+ #include "cpu-amd64.h"
#else
- #define FACTOR_CPU_STRING "unknown"
+ #error "Unsupported CPU"
#endif
-
-#ifdef WINDOWS
- #define FACTOR_OS_STRING "windows"
-#elif defined(__FreeBSD__)
- #define FACTOR_OS_STRING "freebsd"
-#elif defined(linux)
- #define FACTOR_OS_STRING "linux"
-#elif defined(__APPLE__)
- #define FACTOR_OS_STRING "macosx"
-#elif defined(__sun)
- #define FACTOR_OS_STRING "solaris"
-#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
+++ /dev/null
-#include "factor.h"
-
-/* Does not reduce to lowest terms, so should only be used by math
-library implementation, to avoid breaking invariants. */
-void primitive_from_fraction(void)
-{
- CELL numerator, denominator;
- F_RATIO* ratio;
-
- maybe_gc(0);
-
- denominator = dpop();
- numerator = dpop();
- ratio = allot_object(RATIO_TYPE,sizeof(F_RATIO));
- ratio->numerator = numerator;
- ratio->denominator = denominator;
- dpush(RETAG(ratio,RATIO_TYPE));
-}
-
-void fixup_ratio(F_RATIO* ratio)
-{
- data_fixup(&ratio->numerator);
- data_fixup(&ratio->denominator);
-}
-
-void collect_ratio(F_RATIO* ratio)
-{
- copy_handle(&ratio->numerator);
- copy_handle(&ratio->denominator);
-}
+++ /dev/null
-typedef struct {
- CELL header;
- CELL numerator;
- CELL denominator;
-} F_RATIO;
-
-void primitive_from_fraction(void);
-void fixup_ratio(F_RATIO* ratio);
-void collect_ratio(F_RATIO* ratio);
+++ /dev/null
-#include "factor.h"
-
-void relocate_object(CELL relocating)
-{
- switch(untag_header(get(relocating)))
- {
- case RATIO_TYPE:
- fixup_ratio((F_RATIO*)relocating);
- break;
- case COMPLEX_TYPE:
- fixup_complex((F_COMPLEX*)relocating);
- break;
- case WORD_TYPE:
- fixup_word((F_WORD*)relocating);
- break;
- case ARRAY_TYPE:
- case TUPLE_TYPE:
- case QUOTATION_TYPE:
- fixup_array((F_ARRAY*)relocating);
- break;
- case HASHTABLE_TYPE:
- fixup_hashtable((F_HASHTABLE*)relocating);
- break;
- case VECTOR_TYPE:
- fixup_vector((F_VECTOR*)relocating);
- break;
- case STRING_TYPE:
- rehash_string((F_STRING*)relocating);
- break;
- case SBUF_TYPE:
- fixup_sbuf((F_SBUF*)relocating);
- break;
- case DLL_TYPE:
- fixup_dll((DLL*)relocating);
- break;
- case ALIEN_TYPE:
- fixup_alien((ALIEN*)relocating);
- break;
- case WRAPPER_TYPE:
- fixup_wrapper((F_WRAPPER*)relocating);
- break;
- }
-}
-
-void relocate_data()
-{
- CELL relocating;
-
- data_fixup(&userenv[BOOT_ENV]);
- data_fixup(&userenv[GLOBAL_ENV]);
- data_fixup(&T);
- data_fixup(&bignum_zero);
- data_fixup(&bignum_pos_one);
- data_fixup(&bignum_neg_one);
-
- for(relocating = tenured.base;
- relocating < tenured.here;
- relocating += untagged_object_size(relocating))
- {
- allot_barrier(relocating);
- relocate_object(relocating);
- }
-
- for(relocating = compiling.base;
- relocating < literal_top;
- relocating += CELLS)
- {
- data_fixup((CELL*)relocating);
- }
-}
-
-void undefined_symbol(void)
-{
- general_error(ERROR_UNDEFINED_SYMBOL,F,F,true);
-}
-
-CELL get_rel_symbol(F_REL* rel)
-{
- CELL arg = REL_ARGUMENT(rel);
- F_ARRAY *pair = untag_array(get(compiling.base + arg * CELLS));
- F_STRING *symbol = untag_string(get(AREF(pair,0)));
- CELL library = get(AREF(pair,1));
- DLL *dll = (library == F ? NULL : untag_dll(library));
- CELL sym;
-
- if(dll != NULL && !dll->dll)
- return (CELL)undefined_symbol;
-
- sym = (CELL)ffi_dlsym(dll,symbol,false);
-
- if(!sym)
- return (CELL)undefined_symbol;
-
- return sym;
-}
-
-INLINE CELL compute_code_rel(F_REL *rel, CELL original)
-{
- switch(REL_TYPE(rel))
- {
- case F_PRIMITIVE:
- return primitive_to_xt(REL_ARGUMENT(rel));
- case F_DLSYM:
- return get_rel_symbol(rel);
- case F_ABSOLUTE:
- return original + (compiling.base - code_relocation_base);
- case F_CARDS:
- return cards_offset;
- default:
- critical_error("Unsupported rel type",rel->type);
- return -1;
- }
-}
-
-INLINE CELL relocate_code_next(CELL relocating)
-{
- F_COMPILED* compiled = (F_COMPILED*)relocating;
-
- F_REL* rel = (F_REL*)(
- relocating + sizeof(F_COMPILED)
- + compiled->code_length);
-
- F_REL* rel_end = (F_REL*)(
- relocating + sizeof(F_COMPILED)
- + compiled->code_length
- + compiled->reloc_length);
-
- if(compiled->header != COMPILED_HEADER)
- critical_error("Wrong compiled header",relocating);
-
- while(rel < rel_end)
- {
- CELL original;
- CELL new_value;
-
- code_fixup(&rel->offset);
-
- switch(REL_CLASS(rel))
- {
- case REL_ABSOLUTE_CELL:
- original = get(rel->offset);
- break;
- case REL_ABSOLUTE:
- original = *(u32*)rel->offset;
- break;
- case REL_RELATIVE:
- original = *(u32*)rel->offset - (rel->offset + sizeof(u32));
- break;
- case REL_2_2:
- original = reloc_get_2_2(rel->offset);
- break;
- default:
- critical_error("Unsupported rel class",REL_CLASS(rel));
- return -1;
- }
-
- /* to_c_string can fill up the heap */
- maybe_gc(0);
- new_value = compute_code_rel(rel,original);
-
- switch(REL_CLASS(rel))
- {
- case REL_ABSOLUTE_CELL:
- put(rel->offset,new_value);
- break;
- case REL_ABSOLUTE:
- *(u32*)rel->offset = new_value;
- break;
- case REL_RELATIVE:
- *(u32*)rel->offset = new_value - (rel->offset + CELLS);
- break;
- case REL_2_2:
- reloc_set_2_2(rel->offset,new_value);
- break;
- default:
- critical_error("Unsupported rel class",REL_CLASS(rel));
- return -1;
- }
-
- rel++;
- }
-
- return (CELL)rel_end;
-}
-
-void relocate_code()
-{
- /* start relocating from the end of the space reserved for literals */
- CELL relocating = literal_max;
- while(relocating < compiling.here)
- relocating = relocate_code_next(relocating);
-}
+++ /dev/null
-/* relocation base of currently loaded image's data heap */
-CELL data_relocation_base;
-
-INLINE void data_fixup(CELL *cell)
-{
- if(TAG(*cell) != FIXNUM_TYPE && *cell != F)
- *cell += (tenured.base - data_relocation_base);
-}
-
-typedef enum {
- /* arg is a primitive number */
- F_PRIMITIVE,
- /* arg is a pointer in the literal table hodling a cons where the
- car is a symbol string, and the cdr is a dll */
- F_DLSYM,
- /* relocate an address to start of code heap */
- F_ABSOLUTE,
- /* store the offset of the card table from the data heap base */
- F_CARDS
-} F_RELTYPE;
-
-#define REL_ABSOLUTE_CELL 0
-#define REL_ABSOLUTE 1
-#define REL_RELATIVE 2
-#define REL_2_2 3
-
-/* the rel type is built like a cell to avoid endian-specific code in
-the compiler */
-#define REL_TYPE(r) ((r)->type & 0x000000ff)
-#define REL_CLASS(r) (((r)->type & 0x0000ff00) >> 8)
-#define REL_ARGUMENT(r) (((r)->type & 0xffff0000) >> 16)
-
-/* code relocation consists of a table of entries for each fixup */
-typedef struct {
- CELL type;
- CELL offset;
-} F_REL;
-
-CELL code_relocation_base;
-
-INLINE void code_fixup(CELL *cell)
-{
- *cell += (compiling.base - code_relocation_base);
-}
-
-void relocate_data();
-void relocate_code();
-
-/* on PowerPC, return the 32-bit literal being loaded at the code at the
-given address */
-INLINE CELL reloc_get_2_2(CELL cell)
-{
- return ((get(cell - CELLS) & 0xffff) << 16) | (get(cell) & 0xffff);
-}
-
-INLINE void reloc_set_2_2(CELL cell, CELL value)
-{
- put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff)));
- put(cell,((get(cell) & ~0xffff) | (value & 0xffff)));
-}
CELL value = dpop();
userenv[e] = value;
}
+
+void primitive_exit(void)
+{
+ exit(to_fixnum(dpop()));
+}
+
+void primitive_os_env(void)
+{
+ char *name, *value;
+
+ maybe_gc(0);
+
+ name = pop_char_string();
+ value = getenv(name);
+ if(value == NULL)
+ dpush(F);
+ else
+ box_char_string(getenv(name));
+}
+
+void primitive_eq(void)
+{
+ box_boolean(dpop() == dpop());
+}
+
+void primitive_millis(void)
+{
+ maybe_gc(0);
+ dpush(tag_bignum(s48_long_long_to_bignum(current_millis())));
+}
+
+void fatal_error(char* msg, CELL tagged)
+{
+ fprintf(stderr,"Fatal error: %s %ld\n",msg,tagged);
+ exit(1);
+}
+
+void critical_error(char* msg, CELL tagged)
+{
+ fprintf(stderr,"Critical error: %s %ld\n",msg,tagged);
+ factorbug();
+}
+
+void early_error(CELL error)
+{
+ if(userenv[BREAK_ENV] == F)
+ {
+ /* Crash at startup */
+ fprintf(stderr,"Error during startup: ");
+ print_obj(error);
+ fprintf(stderr,"\n");
+ factorbug();
+ }
+}
+
+void throw_error(CELL error, bool keep_stacks)
+{
+ early_error(error);
+
+ throwing = true;
+ thrown_error = error;
+ thrown_keep_stacks = keep_stacks;
+ thrown_ds = ds;
+ thrown_rs = rs;
+
+ /* Return to run() method */
+ LONGJMP(stack_chain->toplevel,1);
+}
+
+void primitive_throw(void)
+{
+ throw_error(dpop(),true);
+}
+
+void primitive_die(void)
+{
+ factorbug();
+}
+
+void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, bool keep_stacks)
+{
+ throw_error(make_array_4(userenv[ERROR_ENV],
+ tag_fixnum(error),arg1,arg2),keep_stacks);
+}
+
+/* It is not safe to access 'ds' from a signal handler, so we just not
+touch it */
+void signal_error(int signal)
+{
+ general_error(ERROR_SIGNAL,tag_fixnum(signal),F,false);
+}
+
+void type_error(CELL type, CELL tagged)
+{
+ general_error(ERROR_TYPE,tag_fixnum(type),tagged,true);
+}
+
+void init_compiler(CELL size)
+{
+ compiling.base = compiling.here = (CELL)(alloc_bounded_block(size)->start);
+ if(compiling.base == 0)
+ fatal_error("Cannot allocate code heap",size);
+ compiling.limit = compiling.base + size;
+ last_flush = compiling.base;
+}
+
+void primitive_compiled_offset(void)
+{
+ box_unsigned_cell(compiling.here);
+}
+
+void primitive_set_compiled_offset(void)
+{
+ CELL offset = unbox_unsigned_cell();
+ compiling.here = offset;
+ if(compiling.here >= compiling.limit)
+ {
+ fprintf(stderr,"Code space exhausted\n");
+ factorbug();
+ }
+}
+
+void primitive_add_literal(void)
+{
+ CELL object = dpeek();
+ CELL offset = literal_top;
+ put(literal_top,object);
+ literal_top += CELLS;
+ if(literal_top >= literal_max)
+ critical_error("Too many compiled literals",literal_top);
+ drepl(tag_cell(offset));
+}
+
+void primitive_flush_icache(void)
+{
+ flush_icache((void*)last_flush,compiling.here - last_flush);
+ last_flush = compiling.here;
+}
+
+void collect_literals(void)
+{
+ CELL i;
+ for(i = compiling.base; i < literal_top; i += CELLS)
+ copy_handle((CELL*)i);
+}
+/* Callstack top pointer */
+CELL cs;
+
+/* TAGGED currently executing quotation */
+CELL callframe;
+
+/* UNTAGGED currently executing word in quotation */
+CELL callframe_scan;
+
+/* UNTAGGED end of quotation */
+CELL callframe_end;
+
#define USER_ENV 32
#define CARD_OFF_ENV 1 /* for compiling set-slot */
/* TAGGED user environment data; see getenv/setenv prims */
DLLEXPORT CELL userenv[USER_ENV];
-INLINE CELL dpop(void)
-{
- CELL value = get(ds);
- ds -= CELLS;
- return value;
-}
-
-INLINE void drepl(CELL top)
-{
- put(ds,top);
-}
-
-INLINE void dpush(CELL top)
-{
- ds += CELLS;
- put(ds,top);
-}
-
-INLINE CELL dpeek(void)
-{
- return get(ds);
-}
-
-INLINE CELL dpeek2(void)
-{
- return get(ds - CELLS);
-}
-
-INLINE CELL cpop(void)
-{
- CELL value = get(cs);
- cs -= CELLS;
- return value;
-}
-
-INLINE void cpush(CELL top)
-{
- cs += CELLS;
- put(cs,top);
-}
-
-INLINE CELL rpop(void)
-{
- CELL value = get(rs);
- rs -= CELLS;
- return value;
-}
-
-INLINE void rpush(CELL top)
-{
- rs += CELLS;
- put(rs,top);
-}
-
void call(CELL quot);
void handle_error();
void primitive_dispatch(void);
void primitive_getenv(void);
void primitive_setenv(void);
+void primitive_exit(void);
+void primitive_os_env(void);
+void primitive_eq(void);
+void primitive_millis(void);
+
+/* Runtime errors */
+typedef enum
+{
+ ERROR_EXPIRED,
+ ERROR_IO,
+ ERROR_UNDEFINED_WORD,
+ ERROR_TYPE,
+ ERROR_SIGNAL,
+ ERROR_NEGATIVE_ARRAY_SIZE,
+ ERROR_C_STRING,
+ ERROR_FFI,
+ ERROR_HEAP_SCAN,
+ ERROR_UNDEFINED_SYMBOL,
+ ERROR_USER_INTERRUPT,
+ ERROR_DS_UNDERFLOW,
+ ERROR_DS_OVERFLOW,
+ ERROR_RS_UNDERFLOW,
+ ERROR_RS_OVERFLOW,
+ ERROR_CS_UNDERFLOW,
+ ERROR_CS_OVERFLOW,
+ ERROR_OBJECTIVE_C
+} F_ERRORTYPE;
+
+/* Are we throwing an error? */
+bool throwing;
+/* When throw_error throws an error, it sets this global and
+longjmps back to the top-level. */
+CELL thrown_error;
+CELL thrown_keep_stacks;
+/* Since longjmp restores registers, we must save all these values. */
+CELL thrown_ds;
+CELL thrown_rs;
+
+void fatal_error(char* msg, CELL tagged);
+void critical_error(char* msg, CELL tagged);
+void throw_error(CELL error, bool keep_stacks);
+void early_error(CELL error);
+void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, bool keep_stacks);
+void signal_error(int signal);
+void type_error(CELL type, CELL tagged);
+void primitive_throw(void);
+void primitive_die(void);
+
+/* The compiled code heap is structured into blocks. */
+typedef struct
+{
+ CELL header; /* = COMPILED_HEADER */
+ CELL code_length;
+ CELL reloc_length; /* see relocate.h */
+} F_COMPILED;
+
+#define COMPILED_HEADER 0x01c3babe
+
+CELL literal_top;
+CELL literal_max;
+
+void init_compiler(CELL size);
+void primitive_compiled_offset(void);
+void primitive_set_compiled_offset(void);
+void primitive_add_literal(void);
+void collect_literals(void);
+
+CELL last_flush;
+
+void primitive_flush_icache(void);
+++ /dev/null
-/* :tabSize=2:indentSize=2:noTabs=true:
-
-$Id: s48_bignum.c,v 1.12 2005/12/21 02:36:52 spestov Exp $
-
-Copyright (c) 1989-94 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy and modify this software, to
-redistribute either the original software or a modified version, and
-to use this software for any purpose is granted, subject to the
-following restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* Changes for Scheme 48:
- * - Converted to ANSI.
- * - Added bitwise operations.
- * - Added s48_ to the beginning of all externally visible names.
- * - Cached the bignum representations of -1, 0, and 1.
- */
-
-/* Changes for Factor:
- * - Add s48_ prefix to file names
- * - Adapt s48_bignumint.h for Factor memory manager
- * - Add more bignum <-> C type conversions
- */
-
-#include "factor.h"
-#include <limits.h>
-#include <stdio.h>
-#include <stdlib.h> /* abort */
-#include <math.h>
-
-/* Exports */
-
-int
-s48_bignum_equal_p(bignum_type x, bignum_type y)
-{
- return
- ((BIGNUM_ZERO_P (x))
- ? (BIGNUM_ZERO_P (y))
- : ((! (BIGNUM_ZERO_P (y)))
- && ((BIGNUM_NEGATIVE_P (x))
- ? (BIGNUM_NEGATIVE_P (y))
- : (! (BIGNUM_NEGATIVE_P (y))))
- && (bignum_equal_p_unsigned (x, y))));
-}
-
-enum bignum_comparison
-s48_bignum_test(bignum_type bignum)
-{
- return
- ((BIGNUM_ZERO_P (bignum))
- ? bignum_comparison_equal
- : (BIGNUM_NEGATIVE_P (bignum))
- ? bignum_comparison_less
- : bignum_comparison_greater);
-}
-
-enum bignum_comparison
-s48_bignum_compare(bignum_type x, bignum_type y)
-{
- return
- ((BIGNUM_ZERO_P (x))
- ? ((BIGNUM_ZERO_P (y))
- ? bignum_comparison_equal
- : (BIGNUM_NEGATIVE_P (y))
- ? bignum_comparison_greater
- : bignum_comparison_less)
- : (BIGNUM_ZERO_P (y))
- ? ((BIGNUM_NEGATIVE_P (x))
- ? bignum_comparison_less
- : bignum_comparison_greater)
- : (BIGNUM_NEGATIVE_P (x))
- ? ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_compare_unsigned (y, x))
- : (bignum_comparison_less))
- : ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_comparison_greater)
- : (bignum_compare_unsigned (x, y))));
-}
-
-bignum_type
-s48_bignum_add(bignum_type x, bignum_type y)
-{
- return
- ((BIGNUM_ZERO_P (x))
- ? (BIGNUM_MAYBE_COPY (y))
- : (BIGNUM_ZERO_P (y))
- ? (BIGNUM_MAYBE_COPY (x))
- : ((BIGNUM_NEGATIVE_P (x))
- ? ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_add_unsigned (x, y, 1))
- : (bignum_subtract_unsigned (y, x)))
- : ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_subtract_unsigned (x, y))
- : (bignum_add_unsigned (x, y, 0)))));
-}
-
-bignum_type
-s48_bignum_subtract(bignum_type x, bignum_type y)
-{
- return
- ((BIGNUM_ZERO_P (x))
- ? ((BIGNUM_ZERO_P (y))
- ? (BIGNUM_MAYBE_COPY (y))
- : (bignum_new_sign (y, (! (BIGNUM_NEGATIVE_P (y))))))
- : ((BIGNUM_ZERO_P (y))
- ? (BIGNUM_MAYBE_COPY (x))
- : ((BIGNUM_NEGATIVE_P (x))
- ? ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_subtract_unsigned (y, x))
- : (bignum_add_unsigned (x, y, 1)))
- : ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_add_unsigned (x, y, 0))
- : (bignum_subtract_unsigned (x, y))))));
-}
-
-bignum_type
-s48_bignum_negate(bignum_type x)
-{
- return
- ((BIGNUM_ZERO_P (x))
- ? (BIGNUM_MAYBE_COPY (x))
- : (bignum_new_sign (x, (! (BIGNUM_NEGATIVE_P (x))))));
-}
-
-bignum_type
-s48_bignum_multiply(bignum_type x, bignum_type y)
-{
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
- bignum_length_type y_length = (BIGNUM_LENGTH (y));
- int negative_p =
- ((BIGNUM_NEGATIVE_P (x))
- ? (! (BIGNUM_NEGATIVE_P (y)))
- : (BIGNUM_NEGATIVE_P (y)));
- if (BIGNUM_ZERO_P (x))
- return (BIGNUM_MAYBE_COPY (x));
- if (BIGNUM_ZERO_P (y))
- return (BIGNUM_MAYBE_COPY (y));
- if (x_length == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (x, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (y, negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- return (bignum_multiply_unsigned_small_factor (y, digit, negative_p));
- }
- if (y_length == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (y, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (x, negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- return (bignum_multiply_unsigned_small_factor (x, digit, negative_p));
- }
- return (bignum_multiply_unsigned (x, y, negative_p));
-}
-
-void
-s48_bignum_divide(bignum_type numerator, bignum_type denominator,
- bignum_type * quotient, bignum_type * remainder)
-{
- if (BIGNUM_ZERO_P (denominator))
- {
- raise(SIGFPE);
- return;
- }
- if (BIGNUM_ZERO_P (numerator))
- {
- (*quotient) = (BIGNUM_MAYBE_COPY (numerator));
- (*remainder) = (BIGNUM_MAYBE_COPY (numerator));
- }
- else
- {
- int r_negative_p = (BIGNUM_NEGATIVE_P (numerator));
- int q_negative_p =
- ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p);
- switch (bignum_compare_unsigned (numerator, denominator))
- {
- case bignum_comparison_equal:
- {
- (*quotient) = (BIGNUM_ONE (q_negative_p));
- (*remainder) = (BIGNUM_ZERO ());
- break;
- }
- case bignum_comparison_less:
- {
- (*quotient) = (BIGNUM_ZERO ());
- (*remainder) = (BIGNUM_MAYBE_COPY (numerator));
- break;
- }
- case bignum_comparison_greater:
- {
- if ((BIGNUM_LENGTH (denominator)) == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
- if (digit == 1)
- {
- (*quotient) =
- (bignum_maybe_new_sign (numerator, q_negative_p));
- (*remainder) = (BIGNUM_ZERO ());
- break;
- }
- else if (digit < BIGNUM_RADIX_ROOT)
- {
- bignum_divide_unsigned_small_denominator
- (numerator, digit,
- quotient, remainder,
- q_negative_p, r_negative_p);
- break;
- }
- else
- {
- bignum_divide_unsigned_medium_denominator
- (numerator, digit,
- quotient, remainder,
- q_negative_p, r_negative_p);
- break;
- }
- }
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
- quotient, remainder,
- q_negative_p, r_negative_p);
- break;
- }
- }
- }
-}
-
-bignum_type
-s48_bignum_quotient(bignum_type numerator, bignum_type denominator)
-{
- if (BIGNUM_ZERO_P (denominator))
- {
- raise(SIGFPE);
- return (BIGNUM_OUT_OF_BAND);
- }
- if (BIGNUM_ZERO_P (numerator))
- return (BIGNUM_MAYBE_COPY (numerator));
- {
- int q_negative_p =
- ((BIGNUM_NEGATIVE_P (denominator))
- ? (! (BIGNUM_NEGATIVE_P (numerator)))
- : (BIGNUM_NEGATIVE_P (numerator)));
- switch (bignum_compare_unsigned (numerator, denominator))
- {
- case bignum_comparison_equal:
- return (BIGNUM_ONE (q_negative_p));
- case bignum_comparison_less:
- return (BIGNUM_ZERO ());
- case bignum_comparison_greater:
- default: /* to appease gcc -Wall */
- {
- bignum_type quotient;
- if ((BIGNUM_LENGTH (denominator)) == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (numerator, q_negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- bignum_divide_unsigned_small_denominator
- (numerator, digit,
- ("ient), ((bignum_type *) 0),
- q_negative_p, 0);
- else
- bignum_divide_unsigned_medium_denominator
- (numerator, digit,
- ("ient), ((bignum_type *) 0),
- q_negative_p, 0);
- }
- else
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
- ("ient), ((bignum_type *) 0),
- q_negative_p, 0);
- return (quotient);
- }
- }
- }
-}
-
-bignum_type
-s48_bignum_remainder(bignum_type numerator, bignum_type denominator)
-{
- if (BIGNUM_ZERO_P (denominator))
- {
- raise(SIGFPE);
- return (BIGNUM_OUT_OF_BAND);
- }
- if (BIGNUM_ZERO_P (numerator))
- return (BIGNUM_MAYBE_COPY (numerator));
- switch (bignum_compare_unsigned (numerator, denominator))
- {
- case bignum_comparison_equal:
- return (BIGNUM_ZERO ());
- case bignum_comparison_less:
- return (BIGNUM_MAYBE_COPY (numerator));
- case bignum_comparison_greater:
- default: /* to appease gcc -Wall */
- {
- bignum_type remainder;
- if ((BIGNUM_LENGTH (denominator)) == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
- if (digit == 1)
- return (BIGNUM_ZERO ());
- if (digit < BIGNUM_RADIX_ROOT)
- return
- (bignum_remainder_unsigned_small_denominator
- (numerator, digit, (BIGNUM_NEGATIVE_P (numerator))));
- bignum_divide_unsigned_medium_denominator
- (numerator, digit,
- ((bignum_type *) 0), (&remainder),
- 0, (BIGNUM_NEGATIVE_P (numerator)));
- }
- else
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
- ((bignum_type *) 0), (&remainder),
- 0, (BIGNUM_NEGATIVE_P (numerator)));
- return (remainder);
- }
- }
-}
-
-#define FOO_TO_BIGNUM(name,type,utype) \
- bignum_type s48_##name##_to_bignum(type n) \
- { \
- int negative_p; \
- bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \
- bignum_digit_type * end_digits = result_digits; \
- /* Special cases win when these small constants are cached. */ \
- if (n == 0) return (BIGNUM_ZERO ()); \
- if (n == 1) return (BIGNUM_ONE (0)); \
- if (n == -1) return (BIGNUM_ONE (1)); \
- { \
- utype accumulator = ((negative_p = (n < 0)) ? (-n) : n); \
- do \
- { \
- (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \
- accumulator >>= BIGNUM_DIGIT_LENGTH; \
- } \
- while (accumulator != 0); \
- } \
- { \
- bignum_type result = \
- (bignum_allocate ((end_digits - result_digits), negative_p)); \
- bignum_digit_type * scan_digits = result_digits; \
- bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \
- while (scan_digits < end_digits) \
- (*scan_result++) = (*scan_digits++); \
- return (result); \
- } \
- }
-
-FOO_TO_BIGNUM(cell,CELL,CELL)
-FOO_TO_BIGNUM(fixnum,F_FIXNUM,CELL)
-FOO_TO_BIGNUM(long,long,unsigned long)
-FOO_TO_BIGNUM(ulong,unsigned long,unsigned long)
-FOO_TO_BIGNUM(long_long,s64,u64)
-FOO_TO_BIGNUM(ulong_long,u64,u64)
-
-/* this is inefficient; its only used for fixnum multiplication overflow so
-it probaly does not matter */
-bignum_type s48_fixnum_pair_to_bignum(CELL x, F_FIXNUM y)
-{
- return s48_bignum_add(
- s48_bignum_arithmetic_shift(
- s48_fixnum_to_bignum(y),
- sizeof(unsigned long) * 8),
- s48_cell_to_bignum(x));
-}
-
-#define BIGNUM_TO_FOO(name,type,utype) \
- type s48_bignum_to_##name(bignum_type bignum) \
- { \
- if (BIGNUM_ZERO_P (bignum)) \
- return (0); \
- { \
- utype accumulator = 0; \
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \
- while (start < scan) \
- accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \
- return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \
- } \
- }
-
-BIGNUM_TO_FOO(cell,CELL,CELL);
-BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL);
-BIGNUM_TO_FOO(long,long,unsigned long)
-BIGNUM_TO_FOO(ulong,unsigned long,unsigned long)
-BIGNUM_TO_FOO(long_long,s64,u64)
-BIGNUM_TO_FOO(ulong_long,u64,u64)
-
-double
-s48_bignum_to_double(bignum_type bignum)
-{
- if (BIGNUM_ZERO_P (bignum))
- return (0);
- {
- double accumulator = 0;
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
- while (start < scan)
- accumulator = ((accumulator * BIGNUM_RADIX) + (*--scan));
- return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator);
- }
-}
-
-#define DTB_WRITE_DIGIT(factor) \
-{ \
- significand *= (factor); \
- digit = ((bignum_digit_type) significand); \
- (*--scan) = digit; \
- significand -= ((double) digit); \
-}
-
-bignum_type
-s48_double_to_bignum(double x)
-{
- int exponent;
- double significand = (frexp (x, (&exponent)));
- if (exponent <= 0) return (BIGNUM_ZERO ());
- if (exponent == 1) return (BIGNUM_ONE (x < 0));
- if (significand < 0) significand = (-significand);
- {
- bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent));
- bignum_type result = (bignum_allocate (length, (x < 0)));
- bignum_digit_type * start = (BIGNUM_START_PTR (result));
- bignum_digit_type * scan = (start + length);
- bignum_digit_type digit;
- int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH);
- if (odd_bits > 0)
- DTB_WRITE_DIGIT (1L << odd_bits);
- while (start < scan)
- {
- if (significand == 0)
- {
- while (start < scan)
- (*--scan) = 0;
- break;
- }
- DTB_WRITE_DIGIT (BIGNUM_RADIX);
- }
- return (result);
- }
-}
-
-#undef DTB_WRITE_DIGIT
-
-int
-s48_bignum_fits_in_word_p(bignum_type bignum, long word_length,
- int twos_complement_p)
-{
- unsigned int n_bits = (twos_complement_p ? (word_length - 1) : word_length);
- BIGNUM_ASSERT (n_bits > 0);
- {
- bignum_length_type length = (BIGNUM_LENGTH (bignum));
- bignum_length_type max_digits = (BIGNUM_BITS_TO_DIGITS (n_bits));
- bignum_digit_type msd, max;
- return
- ((length < max_digits) ||
- ((length == max_digits) &&
- ((((msd = (BIGNUM_REF (bignum, (length - 1)))) <
- (max = (1L << (n_bits - ((length - 1) * BIGNUM_DIGIT_LENGTH))))) ||
- (twos_complement_p &&
- (msd == max) &&
- (BIGNUM_NEGATIVE_P (bignum)))))));
- }
-}
-
-bignum_type
-s48_bignum_length_in_bits(bignum_type bignum)
-{
- if (BIGNUM_ZERO_P (bignum))
- return (BIGNUM_ZERO ());
- {
- bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1);
- bignum_digit_type digit = (BIGNUM_REF (bignum, index));
- bignum_type result = (bignum_allocate (2, 0));
- (BIGNUM_REF (result, 0)) = index;
- (BIGNUM_REF (result, 1)) = 0;
- bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH);
- while (digit > 0)
- {
- bignum_destructive_add (result, ((bignum_digit_type) 1));
- digit >>= 1;
- }
- return (bignum_trim (result));
- }
-}
-
-bignum_type
-s48_bignum_length_upper_limit(void)
-{
- bignum_type result = (bignum_allocate (2, 0));
- (BIGNUM_REF (result, 0)) = 0;
- (BIGNUM_REF (result, 1)) = BIGNUM_DIGIT_LENGTH;
- return (result);
-}
-
-bignum_type
-s48_digit_stream_to_bignum(unsigned int n_digits,
- unsigned int *producer(bignum_procedure_context),
- bignum_procedure_context context,
- unsigned int radix,
- int negative_p)
-{
- BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT));
- if (n_digits == 0)
- return (BIGNUM_ZERO ());
- if (n_digits == 1)
- {
- long digit = ((long) ((*producer) (context)));
- return (s48_long_to_bignum (negative_p ? (- digit) : digit));
- }
- {
- bignum_length_type length;
- {
- unsigned int radix_copy = radix;
- unsigned int log_radix = 0;
- while (radix_copy > 0)
- {
- radix_copy >>= 1;
- log_radix += 1;
- }
- /* This length will be at least as large as needed. */
- length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix));
- }
- {
- bignum_type result = (bignum_allocate_zeroed (length, negative_p));
- while ((n_digits--) > 0)
- {
- bignum_destructive_scale_up (result, ((bignum_digit_type) radix));
- bignum_destructive_add
- (result, ((bignum_digit_type) ((*producer) (context))));
- }
- return (bignum_trim (result));
- }
- }
-}
-
-long
-s48_bignum_max_digit_stream_radix(void)
-{
- return (BIGNUM_RADIX_ROOT);
-}
-
-/* Comparisons */
-
-int
-bignum_equal_p_unsigned(bignum_type x, bignum_type y)
-{
- bignum_length_type length = (BIGNUM_LENGTH (x));
- if (length != (BIGNUM_LENGTH (y)))
- return (0);
- else
- {
- bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_x = (scan_x + length);
- while (scan_x < end_x)
- if ((*scan_x++) != (*scan_y++))
- return (0);
- return (1);
- }
-}
-
-enum bignum_comparison
-bignum_compare_unsigned(bignum_type x, bignum_type y)
-{
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
- bignum_length_type y_length = (BIGNUM_LENGTH (y));
- if (x_length < y_length)
- return (bignum_comparison_less);
- if (x_length > y_length)
- return (bignum_comparison_greater);
- {
- bignum_digit_type * start_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_x = (start_x + x_length);
- bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length);
- while (start_x < scan_x)
- {
- bignum_digit_type digit_x = (*--scan_x);
- bignum_digit_type digit_y = (*--scan_y);
- if (digit_x < digit_y)
- return (bignum_comparison_less);
- if (digit_x > digit_y)
- return (bignum_comparison_greater);
- }
- }
- return (bignum_comparison_equal);
-}
-
-/* Addition */
-
-bignum_type
-bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p)
-{
- if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
- {
- bignum_type z = x;
- x = y;
- y = z;
- }
- {
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
- bignum_type r = (bignum_allocate ((x_length + 1), negative_p));
- bignum_digit_type sum;
- bignum_digit_type carry = 0;
- bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
- {
- bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
- while (scan_y < end_y)
- {
- sum = ((*scan_x++) + (*scan_y++) + carry);
- if (sum < BIGNUM_RADIX)
- {
- (*scan_r++) = sum;
- carry = 0;
- }
- else
- {
- (*scan_r++) = (sum - BIGNUM_RADIX);
- carry = 1;
- }
- }
- }
- {
- bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
- if (carry != 0)
- while (scan_x < end_x)
- {
- sum = ((*scan_x++) + 1);
- if (sum < BIGNUM_RADIX)
- {
- (*scan_r++) = sum;
- carry = 0;
- break;
- }
- else
- (*scan_r++) = (sum - BIGNUM_RADIX);
- }
- while (scan_x < end_x)
- (*scan_r++) = (*scan_x++);
- }
- if (carry != 0)
- {
- (*scan_r) = 1;
- return (r);
- }
- return (bignum_shorten_length (r, x_length));
- }
-}
-
-/* Subtraction */
-
-bignum_type
-bignum_subtract_unsigned(bignum_type x, bignum_type y)
-{
- int negative_p;
- switch (bignum_compare_unsigned (x, y))
- {
- case bignum_comparison_equal:
- return (BIGNUM_ZERO ());
- case bignum_comparison_less:
- {
- bignum_type z = x;
- x = y;
- y = z;
- }
- negative_p = 1;
- break;
- case bignum_comparison_greater:
- negative_p = 0;
- break;
- }
- {
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
- bignum_type r = (bignum_allocate (x_length, negative_p));
- bignum_digit_type difference;
- bignum_digit_type borrow = 0;
- bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
- {
- bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
- while (scan_y < end_y)
- {
- difference = (((*scan_x++) - (*scan_y++)) - borrow);
- if (difference < 0)
- {
- (*scan_r++) = (difference + BIGNUM_RADIX);
- borrow = 1;
- }
- else
- {
- (*scan_r++) = difference;
- borrow = 0;
- }
- }
- }
- {
- bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
- if (borrow != 0)
- while (scan_x < end_x)
- {
- difference = ((*scan_x++) - borrow);
- if (difference < 0)
- (*scan_r++) = (difference + BIGNUM_RADIX);
- else
- {
- (*scan_r++) = difference;
- borrow = 0;
- break;
- }
- }
- BIGNUM_ASSERT (borrow == 0);
- while (scan_x < end_x)
- (*scan_r++) = (*scan_x++);
- }
- return (bignum_trim (r));
- }
-}
-
-/* Multiplication
- Maximum value for product_low or product_high:
- ((R * R) + (R * (R - 2)) + (R - 1))
- Maximum value for carry: ((R * (R - 1)) + (R - 1))
- where R == BIGNUM_RADIX_ROOT */
-
-bignum_type
-bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p)
-{
- if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
- {
- bignum_type z = x;
- x = y;
- y = z;
- }
- {
- bignum_digit_type carry;
- bignum_digit_type y_digit_low;
- bignum_digit_type y_digit_high;
- bignum_digit_type x_digit_low;
- bignum_digit_type x_digit_high;
- bignum_digit_type product_low;
- bignum_digit_type * scan_r;
- bignum_digit_type * scan_y;
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
- bignum_length_type y_length = (BIGNUM_LENGTH (y));
- bignum_type r =
- (bignum_allocate_zeroed ((x_length + y_length), negative_p));
- bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * end_x = (scan_x + x_length);
- bignum_digit_type * start_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_y = (start_y + y_length);
- bignum_digit_type * start_r = (BIGNUM_START_PTR (r));
-#define x_digit x_digit_high
-#define y_digit y_digit_high
-#define product_high carry
- while (scan_x < end_x)
- {
- x_digit = (*scan_x++);
- x_digit_low = (HD_LOW (x_digit));
- x_digit_high = (HD_HIGH (x_digit));
- carry = 0;
- scan_y = start_y;
- scan_r = (start_r++);
- while (scan_y < end_y)
- {
- y_digit = (*scan_y++);
- y_digit_low = (HD_LOW (y_digit));
- y_digit_high = (HD_HIGH (y_digit));
- product_low =
- ((*scan_r) +
- (x_digit_low * y_digit_low) +
- (HD_LOW (carry)));
- product_high =
- ((x_digit_high * y_digit_low) +
- (x_digit_low * y_digit_high) +
- (HD_HIGH (product_low)) +
- (HD_HIGH (carry)));
- (*scan_r++) =
- (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
- carry =
- ((x_digit_high * y_digit_high) +
- (HD_HIGH (product_high)));
- }
- (*scan_r) += carry;
- }
- return (bignum_trim (r));
-#undef x_digit
-#undef y_digit
-#undef product_high
- }
-}
-
-bignum_type
-bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y,
- int negative_p)
-{
- bignum_length_type length_x = (BIGNUM_LENGTH (x));
- bignum_type p = (bignum_allocate ((length_x + 1), negative_p));
- bignum_destructive_copy (x, p);
- (BIGNUM_REF (p, length_x)) = 0;
- bignum_destructive_scale_up (p, y);
- return (bignum_trim (p));
-}
-
-void
-bignum_destructive_scale_up(bignum_type bignum, bignum_digit_type factor)
-{
- bignum_digit_type carry = 0;
- bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
- bignum_digit_type two_digits;
- bignum_digit_type product_low;
-#define product_high carry
- bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum)));
- BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT));
- while (scan < end)
- {
- two_digits = (*scan);
- product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry)));
- product_high =
- ((factor * (HD_HIGH (two_digits))) +
- (HD_HIGH (product_low)) +
- (HD_HIGH (carry)));
- (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
- carry = (HD_HIGH (product_high));
- }
- /* A carry here would be an overflow, i.e. it would not fit.
- Hopefully the callers allocate enough space that this will
- never happen.
- */
- BIGNUM_ASSERT (carry == 0);
- return;
-#undef product_high
-}
-
-void
-bignum_destructive_add(bignum_type bignum, bignum_digit_type n)
-{
- bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
- bignum_digit_type digit;
- digit = ((*scan) + n);
- if (digit < BIGNUM_RADIX)
- {
- (*scan) = digit;
- return;
- }
- (*scan++) = (digit - BIGNUM_RADIX);
- while (1)
- {
- digit = ((*scan) + 1);
- if (digit < BIGNUM_RADIX)
- {
- (*scan) = digit;
- return;
- }
- (*scan++) = (digit - BIGNUM_RADIX);
- }
-}
-
-/* Division */
-
-/* For help understanding this algorithm, see:
- Knuth, Donald E., "The Art of Computer Programming",
- volume 2, "Seminumerical Algorithms"
- section 4.3.1, "Multiple-Precision Arithmetic". */
-
-void
-bignum_divide_unsigned_large_denominator(bignum_type numerator,
- bignum_type denominator,
- bignum_type * quotient,
- bignum_type * remainder,
- int q_negative_p,
- int r_negative_p)
-{
- bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1);
- bignum_length_type length_d = (BIGNUM_LENGTH (denominator));
- bignum_type q =
- ((quotient != ((bignum_type *) 0))
- ? (bignum_allocate ((length_n - length_d), q_negative_p))
- : BIGNUM_OUT_OF_BAND);
- bignum_type u = (bignum_allocate (length_n, r_negative_p));
- int shift = 0;
- BIGNUM_ASSERT (length_d > 1);
- {
- bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1)));
- while (v1 < (BIGNUM_RADIX / 2))
- {
- v1 <<= 1;
- shift += 1;
- }
- }
- if (shift == 0)
- {
- bignum_destructive_copy (numerator, u);
- (BIGNUM_REF (u, (length_n - 1))) = 0;
- bignum_divide_unsigned_normalized (u, denominator, q);
- }
- else
- {
- bignum_type v = (bignum_allocate (length_d, 0));
- bignum_destructive_normalization (numerator, u, shift);
- bignum_destructive_normalization (denominator, v, shift);
- bignum_divide_unsigned_normalized (u, v, q);
- BIGNUM_DEALLOCATE (v);
- if (remainder != ((bignum_type *) 0))
- bignum_destructive_unnormalization (u, shift);
- }
- if (quotient != ((bignum_type *) 0))
- (*quotient) = (bignum_trim (q));
- if (remainder != ((bignum_type *) 0))
- (*remainder) = (bignum_trim (u));
- else
- BIGNUM_DEALLOCATE (u);
- return;
-}
-
-void
-bignum_divide_unsigned_normalized(bignum_type u, bignum_type v, bignum_type q)
-{
- bignum_length_type u_length = (BIGNUM_LENGTH (u));
- bignum_length_type v_length = (BIGNUM_LENGTH (v));
- bignum_digit_type * u_start = (BIGNUM_START_PTR (u));
- bignum_digit_type * u_scan = (u_start + u_length);
- bignum_digit_type * u_scan_limit = (u_start + v_length);
- bignum_digit_type * u_scan_start = (u_scan - v_length);
- bignum_digit_type * v_start = (BIGNUM_START_PTR (v));
- bignum_digit_type * v_end = (v_start + v_length);
- bignum_digit_type * q_scan = NULL;
- bignum_digit_type v1 = (v_end[-1]);
- bignum_digit_type v2 = (v_end[-2]);
- bignum_digit_type ph; /* high half of double-digit product */
- bignum_digit_type pl; /* low half of double-digit product */
- bignum_digit_type guess;
- bignum_digit_type gh; /* high half-digit of guess */
- bignum_digit_type ch; /* high half of double-digit comparand */
- bignum_digit_type v2l = (HD_LOW (v2));
- bignum_digit_type v2h = (HD_HIGH (v2));
- bignum_digit_type cl; /* low half of double-digit comparand */
-#define gl ph /* low half-digit of guess */
-#define uj pl
-#define qj ph
- bignum_digit_type gm; /* memory loc for reference parameter */
- if (q != BIGNUM_OUT_OF_BAND)
- q_scan = ((BIGNUM_START_PTR (q)) + (BIGNUM_LENGTH (q)));
- while (u_scan_limit < u_scan)
- {
- uj = (*--u_scan);
- if (uj != v1)
- {
- /* comparand =
- (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2);
- guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */
- cl = (u_scan[-2]);
- ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm)));
- guess = gm;
- }
- else
- {
- cl = (u_scan[-2]);
- ch = ((u_scan[-1]) + v1);
- guess = (BIGNUM_RADIX - 1);
- }
- while (1)
- {
- /* product = (guess * v2); */
- gl = (HD_LOW (guess));
- gh = (HD_HIGH (guess));
- pl = (v2l * gl);
- ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl)));
- pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))));
- ph = ((v2h * gh) + (HD_HIGH (ph)));
- /* if (comparand >= product) */
- if ((ch > ph) || ((ch == ph) && (cl >= pl)))
- break;
- guess -= 1;
- /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */
- ch += v1;
- /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */
- if (ch >= BIGNUM_RADIX)
- break;
- }
- qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start)));
- if (q != BIGNUM_OUT_OF_BAND)
- (*--q_scan) = qj;
- }
- return;
-#undef gl
-#undef uj
-#undef qj
-}
-
-bignum_digit_type
-bignum_divide_subtract(bignum_digit_type * v_start,
- bignum_digit_type * v_end,
- bignum_digit_type guess,
- bignum_digit_type * u_start)
-{
- bignum_digit_type * v_scan = v_start;
- bignum_digit_type * u_scan = u_start;
- bignum_digit_type carry = 0;
- if (guess == 0) return (0);
- {
- bignum_digit_type gl = (HD_LOW (guess));
- bignum_digit_type gh = (HD_HIGH (guess));
- bignum_digit_type v;
- bignum_digit_type pl;
- bignum_digit_type vl;
-#define vh v
-#define ph carry
-#define diff pl
- while (v_scan < v_end)
- {
- v = (*v_scan++);
- vl = (HD_LOW (v));
- vh = (HD_HIGH (v));
- pl = ((vl * gl) + (HD_LOW (carry)));
- ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry)));
- diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))));
- if (diff < 0)
- {
- (*u_scan++) = (diff + BIGNUM_RADIX);
- carry = ((vh * gh) + (HD_HIGH (ph)) + 1);
- }
- else
- {
- (*u_scan++) = diff;
- carry = ((vh * gh) + (HD_HIGH (ph)));
- }
- }
- if (carry == 0)
- return (guess);
- diff = ((*u_scan) - carry);
- if (diff < 0)
- (*u_scan) = (diff + BIGNUM_RADIX);
- else
- {
- (*u_scan) = diff;
- return (guess);
- }
-#undef vh
-#undef ph
-#undef diff
- }
- /* Subtraction generated carry, implying guess is one too large.
- Add v back in to bring it back down. */
- v_scan = v_start;
- u_scan = u_start;
- carry = 0;
- while (v_scan < v_end)
- {
- bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry);
- if (sum < BIGNUM_RADIX)
- {
- (*u_scan++) = sum;
- carry = 0;
- }
- else
- {
- (*u_scan++) = (sum - BIGNUM_RADIX);
- carry = 1;
- }
- }
- if (carry == 1)
- {
- bignum_digit_type sum = ((*u_scan) + carry);
- (*u_scan) = ((sum < BIGNUM_RADIX) ? sum : (sum - BIGNUM_RADIX));
- }
- return (guess - 1);
-}
-
-void
-bignum_divide_unsigned_medium_denominator(bignum_type numerator,
- bignum_digit_type denominator,
- bignum_type * quotient,
- bignum_type * remainder,
- int q_negative_p,
- int r_negative_p)
-{
- bignum_length_type length_n = (BIGNUM_LENGTH (numerator));
- bignum_length_type length_q;
- bignum_type q;
- int shift = 0;
- /* Because `bignum_digit_divide' requires a normalized denominator. */
- while (denominator < (BIGNUM_RADIX / 2))
- {
- denominator <<= 1;
- shift += 1;
- }
- if (shift == 0)
- {
- length_q = length_n;
- q = (bignum_allocate (length_q, q_negative_p));
- bignum_destructive_copy (numerator, q);
- }
- else
- {
- length_q = (length_n + 1);
- q = (bignum_allocate (length_q, q_negative_p));
- bignum_destructive_normalization (numerator, q, shift);
- }
- {
- bignum_digit_type r = 0;
- bignum_digit_type * start = (BIGNUM_START_PTR (q));
- bignum_digit_type * scan = (start + length_q);
- bignum_digit_type qj;
- if (quotient != ((bignum_type *) 0))
- {
- while (start < scan)
- {
- r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
- (*scan) = qj;
- }
- (*quotient) = (bignum_trim (q));
- }
- else
- {
- while (start < scan)
- r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
- BIGNUM_DEALLOCATE (q);
- }
- if (remainder != ((bignum_type *) 0))
- {
- if (shift != 0)
- r >>= shift;
- (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
- }
- }
- return;
-}
-
-void
-bignum_destructive_normalization(bignum_type source, bignum_type target,
- int shift_left)
-{
- bignum_digit_type digit;
- bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
- bignum_digit_type carry = 0;
- bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
- bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source)));
- bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target)));
- int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left);
- bignum_digit_type mask = ((1L << shift_right) - 1);
- while (scan_source < end_source)
- {
- digit = (*scan_source++);
- (*scan_target++) = (((digit & mask) << shift_left) | carry);
- carry = (digit >> shift_right);
- }
- if (scan_target < end_target)
- (*scan_target) = carry;
- else
- BIGNUM_ASSERT (carry == 0);
- return;
-}
-
-void
-bignum_destructive_unnormalization(bignum_type bignum, int shift_right)
-{
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
- bignum_digit_type digit;
- bignum_digit_type carry = 0;
- int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right);
- bignum_digit_type mask = ((1L << shift_right) - 1);
- while (start < scan)
- {
- digit = (*--scan);
- (*scan) = ((digit >> shift_right) | carry);
- carry = ((digit & mask) << shift_left);
- }
- BIGNUM_ASSERT (carry == 0);
- return;
-}
-
-/* This is a reduced version of the division algorithm, applied to the
- case of dividing two bignum digits by one bignum digit. It is
- assumed that the numerator, denominator are normalized. */
-
-#define BDD_STEP(qn, j) \
-{ \
- uj = (u[j]); \
- if (uj != v1) \
- { \
- uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \
- guess = (uj_uj1 / v1); \
- comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \
- } \
- else \
- { \
- guess = (BIGNUM_RADIX_ROOT - 1); \
- comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \
- } \
- while ((guess * v2) > comparand) \
- { \
- guess -= 1; \
- comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \
- if (comparand >= BIGNUM_RADIX) \
- break; \
- } \
- qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \
-}
-
-bignum_digit_type
-bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul,
- bignum_digit_type v,
- bignum_digit_type * q) /* return value */
-{
- bignum_digit_type guess;
- bignum_digit_type comparand;
- bignum_digit_type v1 = (HD_HIGH (v));
- bignum_digit_type v2 = (HD_LOW (v));
- bignum_digit_type uj;
- bignum_digit_type uj_uj1;
- bignum_digit_type q1;
- bignum_digit_type q2;
- bignum_digit_type u [4];
- if (uh == 0)
- {
- if (ul < v)
- {
- (*q) = 0;
- return (ul);
- }
- else if (ul == v)
- {
- (*q) = 1;
- return (0);
- }
- }
- (u[0]) = (HD_HIGH (uh));
- (u[1]) = (HD_LOW (uh));
- (u[2]) = (HD_HIGH (ul));
- (u[3]) = (HD_LOW (ul));
- v1 = (HD_HIGH (v));
- v2 = (HD_LOW (v));
- BDD_STEP (q1, 0);
- BDD_STEP (q2, 1);
- (*q) = (HD_CONS (q1, q2));
- return (HD_CONS ((u[2]), (u[3])));
-}
-
-#undef BDD_STEP
-
-#define BDDS_MULSUB(vn, un, carry_in) \
-{ \
- product = ((vn * guess) + carry_in); \
- diff = (un - (HD_LOW (product))); \
- if (diff < 0) \
- { \
- un = (diff + BIGNUM_RADIX_ROOT); \
- carry = ((HD_HIGH (product)) + 1); \
- } \
- else \
- { \
- un = diff; \
- carry = (HD_HIGH (product)); \
- } \
-}
-
-#define BDDS_ADD(vn, un, carry_in) \
-{ \
- sum = (vn + un + carry_in); \
- if (sum < BIGNUM_RADIX_ROOT) \
- { \
- un = sum; \
- carry = 0; \
- } \
- else \
- { \
- un = (sum - BIGNUM_RADIX_ROOT); \
- carry = 1; \
- } \
-}
-
-bignum_digit_type
-bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2,
- bignum_digit_type guess, bignum_digit_type * u)
-{
- {
- bignum_digit_type product;
- bignum_digit_type diff;
- bignum_digit_type carry;
- BDDS_MULSUB (v2, (u[2]), 0);
- BDDS_MULSUB (v1, (u[1]), carry);
- if (carry == 0)
- return (guess);
- diff = ((u[0]) - carry);
- if (diff < 0)
- (u[0]) = (diff + BIGNUM_RADIX);
- else
- {
- (u[0]) = diff;
- return (guess);
- }
- }
- {
- bignum_digit_type sum;
- bignum_digit_type carry;
- BDDS_ADD(v2, (u[2]), 0);
- BDDS_ADD(v1, (u[1]), carry);
- if (carry == 1)
- (u[0]) += 1;
- }
- return (guess - 1);
-}
-
-#undef BDDS_MULSUB
-#undef BDDS_ADD
-
-void
-bignum_divide_unsigned_small_denominator(bignum_type numerator,
- bignum_digit_type denominator,
- bignum_type * quotient,
- bignum_type * remainder,
- int q_negative_p,
- int r_negative_p)
-{
- bignum_type q = (bignum_new_sign (numerator, q_negative_p));
- bignum_digit_type r = (bignum_destructive_scale_down (q, denominator));
- (*quotient) = (bignum_trim (q));
- if (remainder != ((bignum_type *) 0))
- (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
- return;
-}
-
-/* Given (denominator > 1), it is fairly easy to show that
- (quotient_high < BIGNUM_RADIX_ROOT), after which it is easy to see
- that all digits are < BIGNUM_RADIX. */
-
-bignum_digit_type
-bignum_destructive_scale_down(bignum_type bignum, bignum_digit_type denominator)
-{
- bignum_digit_type numerator;
- bignum_digit_type remainder = 0;
- bignum_digit_type two_digits;
-#define quotient_high remainder
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
- BIGNUM_ASSERT ((denominator > 1) && (denominator < BIGNUM_RADIX_ROOT));
- while (start < scan)
- {
- two_digits = (*--scan);
- numerator = (HD_CONS (remainder, (HD_HIGH (two_digits))));
- quotient_high = (numerator / denominator);
- numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits))));
- (*scan) = (HD_CONS (quotient_high, (numerator / denominator)));
- remainder = (numerator % denominator);
- }
- return (remainder);
-#undef quotient_high
-}
-
-bignum_type
-bignum_remainder_unsigned_small_denominator(
- bignum_type n, bignum_digit_type d, int negative_p)
-{
- bignum_digit_type two_digits;
- bignum_digit_type * start = (BIGNUM_START_PTR (n));
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n)));
- bignum_digit_type r = 0;
- BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT));
- while (start < scan)
- {
- two_digits = (*--scan);
- r =
- ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d),
- (HD_LOW (two_digits))))
- % d);
- }
- return (bignum_digit_to_bignum (r, negative_p));
-}
-
-bignum_type
-bignum_digit_to_bignum(bignum_digit_type digit, int negative_p)
-{
- if (digit == 0)
- return (BIGNUM_ZERO ());
- else
- {
- bignum_type result = (bignum_allocate (1, negative_p));
- (BIGNUM_REF (result, 0)) = digit;
- return (result);
- }
-}
-
-/* Allocation */
-
-bignum_type
-bignum_allocate(bignum_length_type length, int negative_p)
-{
- BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
- {
- bignum_type result = (BIGNUM_ALLOCATE (length));
- BIGNUM_SET_NEGATIVE_P (result, negative_p);
- return (result);
- }
-}
-
-bignum_type
-bignum_allocate_zeroed(bignum_length_type length, int negative_p)
-{
- BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
- {
- bignum_type result = (BIGNUM_ALLOCATE (length));
- bignum_digit_type * scan = (BIGNUM_START_PTR (result));
- bignum_digit_type * end = (scan + length);
- BIGNUM_SET_NEGATIVE_P (result, negative_p);
- while (scan < end)
- (*scan++) = 0;
- return (result);
- }
-}
-
-bignum_type
-bignum_shorten_length(bignum_type bignum, bignum_length_type length)
-{
- bignum_length_type current_length = (BIGNUM_LENGTH (bignum));
- BIGNUM_ASSERT ((length >= 0) || (length <= current_length));
- if (length < current_length)
- {
- BIGNUM_REDUCE_LENGTH (bignum, bignum, length);
- BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
- }
- return (bignum);
-}
-
-bignum_type
-bignum_trim(bignum_type bignum)
-{
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum)));
- bignum_digit_type * scan = end;
- while ((start <= scan) && ((*--scan) == 0))
- ;
- scan += 1;
- if (scan < end)
- {
- bignum_length_type length = (scan - start);
- BIGNUM_REDUCE_LENGTH (bignum, bignum, length);
- BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
- }
- return (bignum);
-}
-
-/* Copying */
-
-bignum_type
-bignum_copy(bignum_type source)
-{
- bignum_type target =
- (bignum_allocate ((BIGNUM_LENGTH (source)), (BIGNUM_NEGATIVE_P (source))));
- bignum_destructive_copy (source, target);
- return (target);
-}
-
-bignum_type
-bignum_new_sign(bignum_type bignum, int negative_p)
-{
- bignum_type result =
- (bignum_allocate ((BIGNUM_LENGTH (bignum)), negative_p));
- bignum_destructive_copy (bignum, result);
- return (result);
-}
-
-bignum_type
-bignum_maybe_new_sign(bignum_type bignum, int negative_p)
-{
-#ifndef BIGNUM_FORCE_NEW_RESULTS
- if ((BIGNUM_NEGATIVE_P (bignum)) ? negative_p : (! negative_p))
- return (bignum);
- else
-#endif /* not BIGNUM_FORCE_NEW_RESULTS */
- {
- bignum_type result =
- (bignum_allocate ((BIGNUM_LENGTH (bignum)), negative_p));
- bignum_destructive_copy (bignum, result);
- return (result);
- }
-}
-
-void
-bignum_destructive_copy(bignum_type source, bignum_type target)
-{
- bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
- bignum_digit_type * end_source =
- (scan_source + (BIGNUM_LENGTH (source)));
- bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
- while (scan_source < end_source)
- (*scan_target++) = (*scan_source++);
- return;
-}
-
-/* Unused
-void
-bignum_destructive_zero(bignum_type bignum)
-{
- bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
- bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum)));
- while (scan < end)
- (*scan++) = 0;
- return;
-}
-*/
-
-/*
- * Added bitwise operations (and oddp).
- */
-
-int
-s48_bignum_oddp (bignum_type bignum)
-{
- return (BIGNUM_LENGTH (bignum) > 0) && (BIGNUM_REF (bignum, 0) & 1);
-}
-
-bignum_type
-s48_bignum_bitwise_not(bignum_type x)
-{
- return s48_bignum_subtract(BIGNUM_ONE(1), x);
-}
-
-bignum_type
-s48_bignum_arithmetic_shift(bignum_type arg1, long n)
-{
- if (BIGNUM_NEGATIVE_P(arg1) && n < 0)
- return
- s48_bignum_bitwise_not(bignum_magnitude_ash(s48_bignum_bitwise_not(arg1),
- n));
- else
- return bignum_magnitude_ash(arg1, n);
-}
-
-/*
- * This uses a `long'-returning bignum_length_in_bits() which we don't have.
-long
-s48_bignum_integer_length(bignum_type arg1)
-{
- return((BIGNUM_NEGATIVE_P (arg1))
- ? bignum_length_in_bits (s48_bignum_bitwise_not (arg1))
- : bignum_length_in_bits (arg1));
-}
-*/
-
-long
-s48_bignum_bit_count(bignum_type arg1)
-{
- return((BIGNUM_NEGATIVE_P (arg1))
- ? bignum_unsigned_logcount (s48_bignum_bitwise_not (arg1))
- : bignum_unsigned_logcount (arg1));
-}
-
-#define AND_OP 0
-#define IOR_OP 1
-#define XOR_OP 2
-
-bignum_type
-s48_bignum_bitwise_and(bignum_type arg1, bignum_type arg2)
-{
- return(
- (BIGNUM_NEGATIVE_P (arg1))
- ? (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_negneg_bitwise_op(AND_OP, arg1, arg2)
- : bignum_posneg_bitwise_op(AND_OP, arg2, arg1)
- : (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_posneg_bitwise_op(AND_OP, arg1, arg2)
- : bignum_pospos_bitwise_op(AND_OP, arg1, arg2)
- );
-}
-
-bignum_type
-s48_bignum_bitwise_ior(bignum_type arg1, bignum_type arg2)
-{
- return(
- (BIGNUM_NEGATIVE_P (arg1))
- ? (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_negneg_bitwise_op(IOR_OP, arg1, arg2)
- : bignum_posneg_bitwise_op(IOR_OP, arg2, arg1)
- : (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_posneg_bitwise_op(IOR_OP, arg1, arg2)
- : bignum_pospos_bitwise_op(IOR_OP, arg1, arg2)
- );
-}
-
-bignum_type
-s48_bignum_bitwise_xor(bignum_type arg1, bignum_type arg2)
-{
- return(
- (BIGNUM_NEGATIVE_P (arg1))
- ? (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_negneg_bitwise_op(XOR_OP, arg1, arg2)
- : bignum_posneg_bitwise_op(XOR_OP, arg2, arg1)
- : (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_posneg_bitwise_op(XOR_OP, arg1, arg2)
- : bignum_pospos_bitwise_op(XOR_OP, arg1, arg2)
- );
-}
-
-/* ash for the magnitude */
-/* assume arg1 is a big number, n is a long */
-bignum_type
-bignum_magnitude_ash(bignum_type arg1, long n)
-{
- bignum_type result = NULL;
- bignum_digit_type *scan1;
- bignum_digit_type *scanr;
- bignum_digit_type *end;
-
- long digit_offset,bit_offset;
-
- if (BIGNUM_ZERO_P (arg1)) return (arg1);
-
- if (n > 0) {
- digit_offset = n / BIGNUM_DIGIT_LENGTH;
- bit_offset = n % BIGNUM_DIGIT_LENGTH;
-
- result = bignum_allocate_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1,
- BIGNUM_NEGATIVE_P(arg1));
-
- scanr = BIGNUM_START_PTR (result) + digit_offset;
- scan1 = BIGNUM_START_PTR (arg1);
- end = scan1 + BIGNUM_LENGTH (arg1);
-
- while (scan1 < end) {
- *scanr = *scanr | (*scan1 & BIGNUM_DIGIT_MASK) << bit_offset;
- *scanr = *scanr & BIGNUM_DIGIT_MASK;
- scanr++;
- *scanr = *scan1++ >> (BIGNUM_DIGIT_LENGTH - bit_offset);
- *scanr = *scanr & BIGNUM_DIGIT_MASK;
- }
- }
- else if (n < 0
- && (-n >= (BIGNUM_LENGTH (arg1) * (bignum_length_type) BIGNUM_DIGIT_LENGTH)))
- result = BIGNUM_ZERO ();
-
- else if (n < 0) {
- digit_offset = -n / BIGNUM_DIGIT_LENGTH;
- bit_offset = -n % BIGNUM_DIGIT_LENGTH;
-
- result = bignum_allocate_zeroed (BIGNUM_LENGTH (arg1) - digit_offset,
- BIGNUM_NEGATIVE_P(arg1));
-
- scanr = BIGNUM_START_PTR (result);
- scan1 = BIGNUM_START_PTR (arg1) + digit_offset;
- end = scanr + BIGNUM_LENGTH (result) - 1;
-
- while (scanr < end) {
- *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
- *scanr = (*scanr |
- *scan1 << (BIGNUM_DIGIT_LENGTH - bit_offset)) & BIGNUM_DIGIT_MASK;
- scanr++;
- }
- *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
- }
- else if (n == 0) result = arg1;
-
- return (bignum_trim (result));
-}
-
-bignum_type
-bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
-{
- bignum_type result;
- bignum_length_type max_length;
-
- bignum_digit_type *scan1, *end1, digit1;
- bignum_digit_type *scan2, *end2, digit2;
- bignum_digit_type *scanr, *endr;
-
- max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
- ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2);
-
- result = bignum_allocate(max_length, 0);
-
- scanr = BIGNUM_START_PTR(result);
- scan1 = BIGNUM_START_PTR(arg1);
- scan2 = BIGNUM_START_PTR(arg2);
- endr = scanr + max_length;
- end1 = scan1 + BIGNUM_LENGTH(arg1);
- end2 = scan2 + BIGNUM_LENGTH(arg2);
-
- while (scanr < endr) {
- digit1 = (scan1 < end1) ? *scan1++ : 0;
- digit2 = (scan2 < end2) ? *scan2++ : 0;
- /*
- fprintf(stderr, "[pospos op = %d, i = %ld, d1 = %lx, d2 = %lx]\n",
- op, endr - scanr, digit1, digit2);
- */
- *scanr++ = (op == 0) ? digit1 & digit2 :
- (op == 1) ? digit1 | digit2 :
- digit1 ^ digit2;
- }
- return bignum_trim(result);
-}
-
-bignum_type
-bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
-{
- bignum_type result;
- bignum_length_type max_length;
-
- bignum_digit_type *scan1, *end1, digit1;
- bignum_digit_type *scan2, *end2, digit2, carry2;
- bignum_digit_type *scanr, *endr;
-
- char neg_p = op == IOR_OP || op == XOR_OP;
-
- max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2) + 1)
- ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2) + 1;
-
- result = bignum_allocate(max_length, neg_p);
-
- scanr = BIGNUM_START_PTR(result);
- scan1 = BIGNUM_START_PTR(arg1);
- scan2 = BIGNUM_START_PTR(arg2);
- endr = scanr + max_length;
- end1 = scan1 + BIGNUM_LENGTH(arg1);
- end2 = scan2 + BIGNUM_LENGTH(arg2);
-
- carry2 = 1;
-
- while (scanr < endr) {
- digit1 = (scan1 < end1) ? *scan1++ : 0;
- digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK)
- + carry2;
-
- if (digit2 < BIGNUM_RADIX)
- carry2 = 0;
- else
- {
- digit2 = (digit2 - BIGNUM_RADIX);
- carry2 = 1;
- }
-
- *scanr++ = (op == AND_OP) ? digit1 & digit2 :
- (op == IOR_OP) ? digit1 | digit2 :
- digit1 ^ digit2;
- }
-
- if (neg_p)
- bignum_negate_magnitude(result);
-
- return bignum_trim(result);
-}
-
-bignum_type
-bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
-{
- bignum_type result;
- bignum_length_type max_length;
-
- bignum_digit_type *scan1, *end1, digit1, carry1;
- bignum_digit_type *scan2, *end2, digit2, carry2;
- bignum_digit_type *scanr, *endr;
-
- char neg_p = op == AND_OP || op == IOR_OP;
-
- max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
- ? BIGNUM_LENGTH(arg1) + 1 : BIGNUM_LENGTH(arg2) + 1;
-
- result = bignum_allocate(max_length, neg_p);
-
- scanr = BIGNUM_START_PTR(result);
- scan1 = BIGNUM_START_PTR(arg1);
- scan2 = BIGNUM_START_PTR(arg2);
- endr = scanr + max_length;
- end1 = scan1 + BIGNUM_LENGTH(arg1);
- end2 = scan2 + BIGNUM_LENGTH(arg2);
-
- carry1 = 1;
- carry2 = 1;
-
- while (scanr < endr) {
- digit1 = (~((scan1 < end1) ? *scan1++ : 0) & BIGNUM_DIGIT_MASK) + carry1;
- digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK) + carry2;
-
- if (digit1 < BIGNUM_RADIX)
- carry1 = 0;
- else
- {
- digit1 = (digit1 - BIGNUM_RADIX);
- carry1 = 1;
- }
-
- if (digit2 < BIGNUM_RADIX)
- carry2 = 0;
- else
- {
- digit2 = (digit2 - BIGNUM_RADIX);
- carry2 = 1;
- }
-
- *scanr++ = (op == 0) ? digit1 & digit2 :
- (op == 1) ? digit1 | digit2 :
- digit1 ^ digit2;
- }
-
- if (neg_p)
- bignum_negate_magnitude(result);
-
- return bignum_trim(result);
-}
-
-void
-bignum_negate_magnitude(bignum_type arg)
-{
- bignum_digit_type *scan;
- bignum_digit_type *end;
- bignum_digit_type digit;
- bignum_digit_type carry;
-
- scan = BIGNUM_START_PTR(arg);
- end = scan + BIGNUM_LENGTH(arg);
-
- carry = 1;
-
- while (scan < end) {
- digit = (~*scan & BIGNUM_DIGIT_MASK) + carry;
-
- if (digit < BIGNUM_RADIX)
- carry = 0;
- else
- {
- digit = (digit - BIGNUM_RADIX);
- carry = 1;
- }
-
- *scan++ = digit;
- }
-}
-
-long
-bignum_unsigned_logcount(bignum_type arg)
-{
-
- bignum_digit_type *scan;
- bignum_digit_type *end;
- bignum_digit_type digit;
-
- /* sufficient for any reasonable big number */
- long result;
- int i;
-
- if (BIGNUM_ZERO_P (arg)) return (0L);
-
- scan = BIGNUM_START_PTR (arg);
- end = scan + BIGNUM_LENGTH (arg);
- result = 0L;
-
- while (scan < end) {
- digit = *scan++ & BIGNUM_DIGIT_MASK;
- for (i = 0; i++ < BIGNUM_DIGIT_LENGTH; digit = digit >> 1L)
- result += digit & 1L;
- }
-
- return (result);
-}
-
-int
-bignum_logbitp(int shift, bignum_type arg)
-{
- return((BIGNUM_NEGATIVE_P (arg))
- ? !bignum_unsigned_logbitp (shift, s48_bignum_bitwise_not (arg))
- : bignum_unsigned_logbitp (shift,arg));
-}
-
-int
-bignum_unsigned_logbitp(int shift, bignum_type bignum)
-{
- bignum_length_type len = (BIGNUM_LENGTH (bignum));
- bignum_digit_type digit;
- int index = shift / BIGNUM_DIGIT_LENGTH;
- int p;
- if (index >= len)
- return 0;
- digit = (BIGNUM_REF (bignum, index));
- p = shift % BIGNUM_DIGIT_LENGTH;
- return digit & (1 << p);
-}
-
+++ /dev/null
-/* -*-C-*-
-
-$Id: s48_bignum.h,v 1.13 2005/12/21 02:36:52 spestov Exp $
-
-Copyright (c) 1989-1992 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy and modify this software, to
-redistribute either the original software or a modified version, and
-to use this software for any purpose is granted, subject to the
-following restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* External Interface to Bignum Code */
-
-/* The `unsigned long' type is used for the conversion procedures
- `bignum_to_long' and `long_to_bignum'. Older implementations of C
- don't support this type; if you have such an implementation you can
- disable these procedures using the following flag (alternatively
- you could write alternate versions that don't require this type). */
-/* #define BIGNUM_NO_ULONG */
-
-typedef F_ARRAY * bignum_type;
-#define BIGNUM_OUT_OF_BAND ((bignum_type) 0)
-
-enum bignum_comparison
-{
- bignum_comparison_equal = 0,
- bignum_comparison_less = -1,
- bignum_comparison_greater = 1
-};
-
-typedef void * bignum_procedure_context;
-int s48_bignum_equal_p(bignum_type, bignum_type);
-enum bignum_comparison s48_bignum_test(bignum_type);
-enum bignum_comparison s48_bignum_compare(bignum_type, bignum_type);
-bignum_type s48_bignum_add(bignum_type, bignum_type);
-bignum_type s48_bignum_subtract(bignum_type, bignum_type);
-bignum_type s48_bignum_negate(bignum_type);
-bignum_type s48_bignum_multiply(bignum_type, bignum_type);
-void
-s48_bignum_divide(bignum_type numerator, bignum_type denominator,
- bignum_type * quotient, bignum_type * remainder);
-bignum_type s48_bignum_quotient(bignum_type, bignum_type);
-bignum_type s48_bignum_remainder(bignum_type, bignum_type);
-DLLEXPORT bignum_type s48_fixnum_to_bignum(F_FIXNUM);
-DLLEXPORT bignum_type s48_cell_to_bignum(CELL);
-DLLEXPORT bignum_type s48_long_to_bignum(long);
-DLLEXPORT bignum_type s48_long_long_to_bignum(s64 n);
-DLLEXPORT bignum_type s48_ulong_long_to_bignum(u64 n);
-DLLEXPORT bignum_type s48_ulong_to_bignum(unsigned long);
-DLLEXPORT bignum_type s48_fixnum_pair_to_bignum(CELL x, F_FIXNUM y);
-F_FIXNUM s48_bignum_to_fixnum(bignum_type);
-CELL s48_bignum_to_cell(bignum_type);
-long s48_bignum_to_long(bignum_type);
-unsigned long s48_bignum_to_ulong(bignum_type);
-s64 s48_bignum_to_long_long(bignum_type);
-u64 s48_bignum_to_ulong_long(bignum_type);
-bignum_type s48_double_to_bignum(double);
-double s48_bignum_to_double(bignum_type);
-int s48_bignum_fits_in_word_p(bignum_type, long word_length,
- int twos_complement_p);
-bignum_type s48_bignum_length_in_bits(bignum_type);
-bignum_type s48_bignum_length_upper_limit(void);
-bignum_type s48_digit_stream_to_bignum
- (unsigned int n_digits,
- unsigned int (*producer(bignum_procedure_context)),
- bignum_procedure_context context,
- unsigned int radix,
- int negative_p);
-long s48_bignum_max_digit_stream_radix(void);
-
-/* Added bitwise operators. */
-
-DLLEXPORT bignum_type s48_bignum_bitwise_not(bignum_type),
- s48_bignum_arithmetic_shift(bignum_type, long),
- s48_bignum_bitwise_and(bignum_type, bignum_type),
- s48_bignum_bitwise_ior(bignum_type, bignum_type),
- s48_bignum_bitwise_xor(bignum_type, bignum_type);
-
-int s48_bignum_oddp(bignum_type);
-long s48_bignum_bit_count(bignum_type);
-
-/* Forward references */
-int bignum_equal_p_unsigned(bignum_type, bignum_type);
-enum bignum_comparison bignum_compare_unsigned(bignum_type, bignum_type);
-bignum_type bignum_add_unsigned(bignum_type, bignum_type, int);
-bignum_type bignum_subtract_unsigned(bignum_type, bignum_type);
-bignum_type bignum_multiply_unsigned(bignum_type, bignum_type, int);
-bignum_type bignum_multiply_unsigned_small_factor
- (bignum_type, bignum_digit_type, int);
-void bignum_destructive_scale_up(bignum_type, bignum_digit_type);
-void bignum_destructive_add(bignum_type, bignum_digit_type);
-void bignum_divide_unsigned_large_denominator
- (bignum_type, bignum_type, bignum_type *, bignum_type *, int, int);
-void bignum_destructive_normalization(bignum_type, bignum_type, int);
-void bignum_destructive_unnormalization(bignum_type, int);
-void bignum_divide_unsigned_normalized(bignum_type, bignum_type, bignum_type);
-bignum_digit_type bignum_divide_subtract
- (bignum_digit_type *, bignum_digit_type *, bignum_digit_type,
- bignum_digit_type *);
-void bignum_divide_unsigned_medium_denominator
- (bignum_type, bignum_digit_type, bignum_type *, bignum_type *, int, int);
-bignum_digit_type bignum_digit_divide
- (bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *);
-bignum_digit_type bignum_digit_divide_subtract
- (bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *);
-void bignum_divide_unsigned_small_denominator
- (bignum_type, bignum_digit_type, bignum_type *, bignum_type *, int, int);
-bignum_digit_type bignum_destructive_scale_down
- (bignum_type, bignum_digit_type);
-bignum_type bignum_remainder_unsigned_small_denominator
- (bignum_type, bignum_digit_type, int);
-bignum_type bignum_digit_to_bignum(bignum_digit_type, int);
-bignum_type bignum_allocate(bignum_length_type, int);
-bignum_type bignum_allocate_zeroed(bignum_length_type, int);
-bignum_type bignum_shorten_length(bignum_type, bignum_length_type);
-bignum_type bignum_trim(bignum_type);
-bignum_type bignum_copy(bignum_type);
-bignum_type bignum_new_sign(bignum_type, int);
-bignum_type bignum_maybe_new_sign(bignum_type, int);
-void bignum_destructive_copy(bignum_type, bignum_type);
-/* Unused
-void bignum_destructive_zero(bignum_type);
-*/
-
-/* Added for bitwise operations. */
-bignum_type bignum_magnitude_ash(bignum_type arg1, long n);
-bignum_type bignum_pospos_bitwise_op(int op, bignum_type, bignum_type);
-bignum_type bignum_posneg_bitwise_op(int op, bignum_type, bignum_type);
-bignum_type bignum_negneg_bitwise_op(int op, bignum_type, bignum_type);
-void bignum_negate_magnitude(bignum_type);
-long bignum_unsigned_logcount(bignum_type arg);
-int bignum_unsigned_logbitp(int shift, bignum_type bignum);
+++ /dev/null
-/* -*-C-*-
-
-$Id: s48_bignumint.h,v 1.14 2005/12/21 02:36:52 spestov Exp $
-
-Copyright (c) 1989-1992 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy and modify this software, to
-redistribute either the original software or a modified version, and
-to use this software for any purpose is granted, subject to the
-following restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* Internal Interface to Bignum Code */
-#undef BIGNUM_ZERO_P
-#undef BIGNUM_NEGATIVE_P
-
-/* The memory model is based on the following definitions, and on the
- definition of the type `bignum_type'. The only other special
- definition is `CHAR_BIT', which is defined in the Ansi C header
- file "limits.h". */
-
-typedef F_FIXNUM bignum_digit_type;
-typedef F_FIXNUM bignum_length_type;
-
-/* BIGNUM_ALLOCATE allocates a (length + 1)-element array of
- `bignum_digit_type'; deallocation is the responsibility of the
- user (in Factor, the garbage collector handles this). */
-#define BIGNUM_ALLOCATE(length_in_digits) \
- allot_array(BIGNUM_TYPE,length_in_digits + 1)
-
-/* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */
-#define BIGNUM_TO_POINTER(bignum) ((CELL*)AREF(bignum,0))
-
-/* BIGNUM_REDUCE_LENGTH allows the memory system to reclaim some
- space when a bignum's length is reduced from its original value. */
-#define BIGNUM_REDUCE_LENGTH(target, source, length) \
- target = resize_array(source, length + 1,0)
-
-/* BIGNUM_DEALLOCATE is called when disposing of bignums which are
- created as intermediate temporaries; Scheme doesn't need this. */
-#define BIGNUM_DEALLOCATE(bignum)
-
-/* If BIGNUM_FORCE_NEW_RESULTS is defined, all bignum-valued operations
- return freshly-allocated results. This is useful for some kinds of
- memory deallocation strategies. */
-/* #define BIGNUM_FORCE_NEW_RESULTS */
-
-/* BIGNUM_EXCEPTION is invoked to handle assertion violations. */
-#define BIGNUM_EXCEPTION abort
-
-
-#define BIGNUM_DIGIT_LENGTH (((sizeof (bignum_digit_type)) * CHAR_BIT) - 2)
-#define BIGNUM_HALF_DIGIT_LENGTH (BIGNUM_DIGIT_LENGTH / 2)
-#define BIGNUM_RADIX (((CELL) 1) << BIGNUM_DIGIT_LENGTH)
-#define BIGNUM_RADIX_ROOT (((CELL) 1) << BIGNUM_HALF_DIGIT_LENGTH)
-#define BIGNUM_DIGIT_MASK (BIGNUM_RADIX - 1)
-#define BIGNUM_HALF_DIGIT_MASK (BIGNUM_RADIX_ROOT - 1)
-
-#define BIGNUM_START_PTR(bignum) \
- ((BIGNUM_TO_POINTER (bignum)) + 1)
-
-#define BIGNUM_LENGTH(bignum) (untag_fixnum_fast((bignum)->capacity) - 1)
-
-#define BIGNUM_NEGATIVE_P(bignum) (get(AREF(bignum,0)) != 0)
-#define BIGNUM_SET_NEGATIVE_P(bignum,neg) put(AREF(bignum,0),neg)
-
-#define BIGNUM_ZERO_P(bignum) \
- ((BIGNUM_LENGTH (bignum)) == 0)
-
-#define BIGNUM_REF(bignum, index) \
- (* ((BIGNUM_START_PTR (bignum)) + (index)))
-
-#ifdef BIGNUM_FORCE_NEW_RESULTS
-#define BIGNUM_MAYBE_COPY bignum_copy
-#else
-#define BIGNUM_MAYBE_COPY(bignum) bignum
-#endif
-
-/* These definitions are here to facilitate caching of the constants
- 0, 1, and -1. */
-#define BIGNUM_ZERO() (F_ARRAY*)UNTAG(bignum_zero)
-#define BIGNUM_ONE(neg_p) \
- (F_ARRAY*)UNTAG(neg_p ? bignum_neg_one : bignum_pos_one)
-
-#define BIGNUM_ONE_P(bignum,negative_p) ((bignum) == BIGNUM_ONE(negative_p))
-
-#define HD_LOW(digit) ((digit) & BIGNUM_HALF_DIGIT_MASK)
-#define HD_HIGH(digit) ((digit) >> BIGNUM_HALF_DIGIT_LENGTH)
-#define HD_CONS(high, low) (((high) << BIGNUM_HALF_DIGIT_LENGTH) | (low))
-
-#define BIGNUM_BITS_TO_DIGITS(n) \
- (((n) + (BIGNUM_DIGIT_LENGTH - 1)) / BIGNUM_DIGIT_LENGTH)
-
-#define BIGNUM_DIGITS_FOR(type) \
- (BIGNUM_BITS_TO_DIGITS ((sizeof (type)) * CHAR_BIT))
-
-#ifndef BIGNUM_DISABLE_ASSERTION_CHECKS
-
-#define BIGNUM_ASSERT(expression) \
-{ \
- if (! (expression)) \
- BIGNUM_EXCEPTION (); \
-}
-
-#endif /* not BIGNUM_DISABLE_ASSERTION_CHECKS */
+++ /dev/null
-#include "factor.h"
-
-F_SBUF* sbuf(F_FIXNUM capacity)
-{
- F_SBUF* sbuf;
- if(capacity < 0)
- general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),F,true);
- sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF));
- sbuf->top = tag_fixnum(0);
- sbuf->string = tag_object(string(capacity,'\0'));
- return sbuf;
-}
-
-void primitive_sbuf(void)
-{
- CELL size = to_fixnum(dpeek());
- maybe_gc(sizeof(F_SBUF) + string_size(size));
- drepl(tag_object(sbuf(size)));
-}
-
-void fixup_sbuf(F_SBUF* sbuf)
-{
- data_fixup(&sbuf->string);
-}
-
-void collect_sbuf(F_SBUF* sbuf)
-{
- copy_handle(&sbuf->string);
-}
+++ /dev/null
-typedef struct {
- /* always tag_header(SBUF_TYPE) */
- CELL header;
- /* tagged */
- CELL top;
- /* tagged */
- CELL string;
-} F_SBUF;
-
-F_SBUF* sbuf(F_FIXNUM capacity);
-void primitive_sbuf(void);
-void fixup_sbuf(F_SBUF* sbuf);
-void collect_sbuf(F_SBUF* sbuf);
+++ /dev/null
-#ifndef WIN32
-void signal_handler(int signal, siginfo_t* siginfo, void* uap);
-void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
-#endif
-void init_signals(void);
+INLINE CELL dpop(void)
+{
+ CELL value = get(ds);
+ ds -= CELLS;
+ return value;
+}
+
+INLINE void drepl(CELL top)
+{
+ put(ds,top);
+}
+
+INLINE void dpush(CELL top)
+{
+ ds += CELLS;
+ put(ds,top);
+}
+
+INLINE CELL dpeek(void)
+{
+ return get(ds);
+}
+
+INLINE CELL dpeek2(void)
+{
+ return get(ds - CELLS);
+}
+
+INLINE CELL cpop(void)
+{
+ CELL value = get(cs);
+ cs -= CELLS;
+ return value;
+}
+
+INLINE void cpush(CELL top)
+{
+ cs += CELLS;
+ put(cs,top);
+}
+
+INLINE CELL rpop(void)
+{
+ CELL value = get(rs);
+ rs -= CELLS;
+ return value;
+}
+
+INLINE void rpush(CELL top)
+{
+ rs += CELLS;
+ put(rs,top);
+}
+
typedef struct _STACKS {
/* current datastack top pointer */
CELL data;
+++ /dev/null
-#include "factor.h"
-
-/* untagged */
-F_STRING* allot_string(F_FIXNUM capacity)
-{
- F_STRING* string;
-
- if(capacity < 0)
- general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),F,true);
-
- string = allot_object(STRING_TYPE,
- sizeof(F_STRING) + (capacity + 1) * CHARS);
- /* strings are null-terminated in memory, even though they also
- have a length field. The null termination allows us to add
- the sizeof(F_STRING) to a Factor string to get a C-style
- UTF16 string for C library calls. */
- cput(SREF(string,capacity),(u16)'\0');
- string->length = tag_fixnum(capacity);
- string->hashcode = F;
- return string;
-}
-
-/* call this after constructing a string */
-void rehash_string(F_STRING* str)
-{
- s32 hash = 0;
- CELL i;
- CELL capacity = string_capacity(str);
- for(i = 0; i < capacity; i++)
- hash = (31*hash + string_nth(str,i));
- str->hashcode = (s32)tag_fixnum(hash);
-}
-
-void primitive_rehash_string(void)
-{
- rehash_string(untag_string(dpop()));
-}
-
-/* untagged */
-F_STRING *string(F_FIXNUM capacity, CELL fill)
-{
- CELL i;
-
- F_STRING* string = allot_string(capacity);
-
- for(i = 0; i < capacity; i++)
- cput(SREF(string,i),fill);
-
- rehash_string(string);
-
- return string;
-}
-
-void primitive_string(void)
-{
- CELL initial = to_cell(dpop());
- F_FIXNUM length = to_fixnum(dpop());
- maybe_gc(string_size(length));
- dpush(tag_object(string(length,initial)));
-}
-
-F_STRING* resize_string(F_STRING* string, F_FIXNUM capacity, u16 fill)
-{
- /* later on, do an optimization: if end of array is here, just grow */
- CELL i;
- CELL to_copy = string_capacity(string);
-
- if(capacity < to_copy)
- to_copy = capacity;
-
- F_STRING* new_string = allot_string(capacity);
-
- memcpy(new_string + 1,string + 1,to_copy * CHARS);
-
- for(i = to_copy; i < capacity; i++)
- cput(SREF(new_string,i),fill);
-
- return new_string;
-}
-
-void primitive_resize_string(void)
-{
- F_STRING* string;
- CELL capacity = to_fixnum(dpeek2());
- maybe_gc(string_size(capacity));
- string = untag_string_fast(dpop());
- drepl(tag_object(resize_string(string,capacity,0)));
-}
-
-/* Some ugly macros to prevent a 2x code duplication */
-
-#define MEMORY_TO_STRING(type,utype) \
- F_STRING *memory_to_##type##_string(const type *string, CELL length) \
- { \
- F_STRING* s = allot_string(length); \
- CELL i; \
- for(i = 0; i < length; i++) \
- { \
- cput(SREF(s,i),(utype)*string); \
- string++; \
- } \
- rehash_string(s); \
- return s; \
- } \
- void primitive_memory_to_##type##_string(void) \
- { \
- CELL length = unbox_unsigned_cell(); \
- type *string = (type*)unbox_unsigned_cell(); \
- dpush(tag_object(memory_to_##type##_string(string,length))); \
- } \
- F_STRING *from_##type##_string(const type *str) \
- { \
- CELL length = 0; \
- type *scan = str; \
- while(*scan++) length++; \
- return memory_to_##type##_string((type*)str,length); \
- } \
- void box_##type##_string(const type *str) \
- { \
- dpush(str ? tag_object(from_##type##_string(str)) : F); \
- } \
- void primitive_alien_to_##type##_string(void) \
- { \
- maybe_gc(0); \
- drepl(tag_object(from_##type##_string(alien_offset(dpeek())))); \
- }
-
-MEMORY_TO_STRING(char,u8)
-MEMORY_TO_STRING(u16,u16)
-
-void check_string(F_STRING *s, CELL max)
-{
- CELL capacity = string_capacity(s);
- CELL i;
- for(i = 0; i < capacity; i++)
- {
- u16 ch = string_nth(s,i);
- if(ch == '\0' || ch >= (1 << (max * 8)))
- general_error(ERROR_C_STRING,tag_object(s),F,true);
- }
-}
-
-F_ARRAY *allot_c_string(CELL capacity, CELL size)
-{
- return allot_array(BYTE_ARRAY_TYPE,capacity * size / CELLS + 1);
-}
-
-#define STRING_TO_MEMORY(type) \
- void type##_string_to_memory(F_STRING *s, type *string) \
- { \
- CELL i; \
- CELL capacity = string_capacity(s); \
- for(i = 0; i < capacity; i++) \
- string[i] = string_nth(s,i); \
- } \
- void primitive_##type##_string_to_memory(void) \
- { \
- type *address = (type*)unbox_unsigned_cell(); \
- F_STRING *str = untag_string(dpop()); \
- type##_string_to_memory(str,address); \
- } \
- F_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \
- { \
- CELL capacity = string_capacity(s); \
- F_ARRAY *_c_str; \
- if(check) check_string(s,sizeof(type)); \
- _c_str = allot_c_string(capacity,sizeof(type)); \
- type *c_str = (type*)(_c_str + 1); \
- type##_string_to_memory(s,c_str); \
- c_str[capacity] = 0; \
- return _c_str; \
- } \
- type *to_##type##_string(F_STRING *s, bool check) \
- { \
- if(sizeof(type) == sizeof(u16)) \
- { \
- if(check) check_string(s,sizeof(type)); \
- return (type*)(s + 1); \
- } \
- else \
- return (type*)(string_to_##type##_alien(s,check) + 1); \
- } \
- type *pop_##type##_string(void) \
- { \
- return to_##type##_string(untag_string(dpop()),true); \
- } \
- type *unbox_##type##_string(void) \
- { \
- if(type_of(dpeek()) == STRING_TYPE) \
- return pop_##type##_string(); \
- else \
- return unbox_alien(); \
- } \
- void primitive_string_to_##type##_alien(void) \
- { \
- CELL string, t; \
- maybe_gc(0); \
- string = dpeek(); \
- t = type_of(string); \
- if(t != ALIEN_TYPE && t != BYTE_ARRAY_TYPE && t != F_TYPE) \
- drepl(tag_object(string_to_##type##_alien(untag_string(string),true))); \
- }
-
-STRING_TO_MEMORY(char);
-STRING_TO_MEMORY(u16);
-
-void primitive_char_slot(void)
-{
- F_STRING* string = untag_string_fast(dpop());
- CELL index = untag_fixnum_fast(dpop());
- dpush(tag_fixnum(string_nth(string,index)));
-}
-
-void primitive_set_char_slot(void)
-{
- F_STRING* string = untag_string_fast(dpop());
- CELL index = untag_fixnum_fast(dpop());
- CELL value = untag_fixnum_fast(dpop());
- set_string_nth(string,index,value);
-}
+++ /dev/null
-typedef struct {
- CELL header;
- /* tagged num of chars */
- CELL length;
- /* tagged */
- CELL hashcode;
-} F_STRING;
-
-#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + index * CHARS)
-
-INLINE F_STRING* untag_string_fast(CELL tagged)
-{
- return (F_STRING*)UNTAG(tagged);
-}
-
-INLINE F_STRING* untag_string(CELL tagged)
-{
- type_check(STRING_TYPE,tagged);
- return untag_string_fast(tagged);
-}
-
-INLINE CELL string_capacity(F_STRING* str)
-{
- return untag_fixnum_fast(str->length);
-}
-
-INLINE CELL string_size(CELL size)
-{
- return align8(sizeof(F_STRING) + (size + 1) * CHARS);
-}
-
-F_STRING* allot_string(F_FIXNUM capacity);
-void rehash_string(F_STRING* str);
-void primitive_rehash_string(void);
-F_STRING* string(F_FIXNUM capacity, CELL fill);
-void primitive_string(void);
-F_STRING *resize_string(F_STRING *string, F_FIXNUM capacity, u16 fill);
-void primitive_resize_string(void);
-
-F_STRING *memory_to_char_string(const char *string, CELL length);
-void primitive_memory_to_char_string(void);
-F_STRING *from_char_string(const char *c_string);
-DLLEXPORT void box_char_string(const char *c_string);
-void primitive_alien_to_char_string(void);
-
-F_STRING *memory_to_u16_string(const u16 *string, CELL length);
-void primitive_memory_to_u16_string(void);
-F_STRING *from_u16_string(const u16 *c_string);
-DLLEXPORT void box_u16_string(const u16 *c_string);
-void primitive_alien_to_u16_string(void);
-
-void char_string_to_memory(F_STRING *s, char *string);
-void primitive_char_string_to_memory(void);
-F_ARRAY *string_to_char_alien(F_STRING *s, bool check);
-char* to_char_string(F_STRING *s, bool check);
-char *pop_char_string(void);
-DLLEXPORT char *unbox_char_string(void);
-void primitive_string_to_char_alien(void);
-
-void u16_string_to_memory(F_STRING *s, u16 *string);
-void primitive_u16_string_to_memory(void);
-F_ARRAY *string_to_u16_alien(F_STRING *s, bool check);
-u16* to_u16_string(F_STRING *s, bool check);
-u16 *pop_u16_string(void);
-DLLEXPORT u16 *unbox_u16_string(void);
-void primitive_string_to_u16_alien(void);
-
-/* untagged & unchecked */
-INLINE CELL string_nth(F_STRING* string, CELL index)
-{
- return cget(SREF(string,index));
-}
-
-/* untagged & unchecked */
-INLINE void set_string_nth(F_STRING* string, CELL index, u16 value)
-{
- cput(SREF(string,index),value);
-}
-
-void primitive_char_slot(void);
-void primitive_set_char_slot(void);
--- /dev/null
+#include "factor.h"
+
+/* FFI calls this */
+void box_boolean(bool value)
+{
+ dpush(value ? T : F);
+}
+
+/* FFI calls this */
+bool unbox_boolean(void)
+{
+ return (dpop() != F);
+}
+
+/* the array is full of undefined data, and must be correctly filled before the
+next GC. size is in cells */
+F_ARRAY *allot_array(CELL type, F_FIXNUM capacity)
+{
+ F_ARRAY *array;
+
+ if(capacity < 0)
+ general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),F,true);
+
+ array = allot_object(type,array_size(capacity));
+ array->capacity = tag_fixnum(capacity);
+ return array;
+}
+
+/* make a new array with an initial element */
+F_ARRAY *array(CELL type, F_FIXNUM capacity, CELL fill)
+{
+ int i;
+ F_ARRAY* array = allot_array(type, capacity);
+ for(i = 0; i < capacity; i++)
+ put(AREF(array,i),fill);
+ return array;
+}
+
+/* size is in bytes this time */
+F_ARRAY *byte_array(F_FIXNUM size)
+{
+ F_FIXNUM byte_size = (size + sizeof(CELL) - 1) / sizeof(CELL);
+ return array(BYTE_ARRAY_TYPE,byte_size,0);
+}
+
+/* push a new array on the stack */
+void primitive_array(void)
+{
+ CELL initial;
+ F_FIXNUM size;
+ maybe_gc(0);
+ initial = dpop();
+ size = to_fixnum(dpop());
+ dpush(tag_object(array(ARRAY_TYPE,size,initial)));
+}
+
+/* push a new tuple on the stack */
+void primitive_tuple(void)
+{
+ CELL class;
+ F_FIXNUM size;
+ F_ARRAY *tuple;
+ maybe_gc(0);
+ size = to_fixnum(dpop());
+ class = dpop();
+ tuple = array(TUPLE_TYPE,size,F);
+ put(AREF(tuple,0),class);
+ dpush(tag_object(tuple));
+}
+
+/* push a new byte on the stack */
+void primitive_byte_array(void)
+{
+ F_FIXNUM size = to_fixnum(dpop());
+ maybe_gc(0);
+ dpush(tag_object(byte_array(size)));
+}
+
+/* push a new quotation on the stack */
+void primitive_quotation(void)
+{
+ F_FIXNUM size;
+ maybe_gc(0);
+ size = to_fixnum(dpop());
+ dpush(tag_object(array(QUOTATION_TYPE,size,F)));
+}
+
+CELL make_array_2(CELL v1, CELL v2)
+{
+ F_ARRAY *a = array(ARRAY_TYPE,2,F);
+ put(AREF(a,0),v1);
+ put(AREF(a,1),v2);
+ return tag_object(a);
+}
+
+CELL make_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
+{
+ F_ARRAY *a = array(ARRAY_TYPE,4,F);
+ put(AREF(a,0),v1);
+ put(AREF(a,1),v2);
+ put(AREF(a,2),v3);
+ put(AREF(a,3),v4);
+ return tag_object(a);
+}
+
+F_ARRAY* resize_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill)
+{
+ int i;
+ F_ARRAY* new_array;
+
+ CELL to_copy = array_capacity(array);
+ if(capacity < to_copy)
+ to_copy = capacity;
+
+ new_array = allot_array(untag_header(array->header),capacity);
+
+ memcpy(new_array + 1,array + 1,to_copy * CELLS);
+
+ for(i = to_copy; i < capacity; i++)
+ put(AREF(new_array,i),fill);
+
+ return new_array;
+}
+
+void primitive_resize_array(void)
+{
+ F_ARRAY* array;
+ F_FIXNUM capacity = to_fixnum(dpeek2());
+ maybe_gc(array_size(capacity));
+ array = untag_array(dpop());
+ drepl(tag_object(resize_array(array,capacity,F)));
+}
+
+void primitive_array_to_tuple(void)
+{
+ CELL array = dpeek();
+ type_check(ARRAY_TYPE,array);
+ array = clone(array);
+ put(SLOT(UNTAG(array),0),tag_header(TUPLE_TYPE));
+ drepl(array);
+}
+
+void primitive_tuple_to_array(void)
+{
+ CELL tuple = dpeek();
+ type_check(TUPLE_TYPE,tuple);
+ tuple = clone(tuple);
+ put(SLOT(UNTAG(tuple),0),tag_header(ARRAY_TYPE));
+ drepl(tuple);
+}
+
+/* image loading */
+void fixup_array(F_ARRAY* array)
+{
+ int i = 0; CELL capacity = array_capacity(array);
+ for(i = 0; i < capacity; i++)
+ data_fixup((void*)AREF(array,i));
+}
+
+/* GC */
+void collect_array(F_ARRAY* array)
+{
+ int i = 0; CELL capacity = array_capacity(array);
+ for(i = 0; i < capacity; i++)
+ copy_handle((void*)AREF(array,i));
+}
+
+F_VECTOR* vector(F_FIXNUM capacity)
+{
+ F_VECTOR* vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
+ vector->top = tag_fixnum(0);
+ vector->array = tag_object(array(ARRAY_TYPE,capacity,F));
+ return vector;
+}
+
+void primitive_vector(void)
+{
+ CELL size = to_fixnum(dpeek());
+ maybe_gc(array_size(size) + sizeof(F_VECTOR));
+ drepl(tag_object(vector(size)));
+}
+
+void primitive_array_to_vector(void)
+{
+ F_ARRAY *array;
+ F_VECTOR *vector;
+ maybe_gc(sizeof(F_VECTOR));
+ array = untag_array(dpeek());
+ vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
+ vector->top = array->capacity;
+ vector->array = tag_object(array);
+ drepl(tag_object(vector));
+}
+
+void fixup_vector(F_VECTOR* vector)
+{
+ data_fixup(&vector->array);
+}
+
+void collect_vector(F_VECTOR* vector)
+{
+ copy_handle(&vector->array);
+}
+
+/* untagged */
+F_STRING* allot_string(F_FIXNUM capacity)
+{
+ F_STRING* string;
+
+ if(capacity < 0)
+ general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),F,true);
+
+ string = allot_object(STRING_TYPE,
+ sizeof(F_STRING) + (capacity + 1) * CHARS);
+ /* strings are null-terminated in memory, even though they also
+ have a length field. The null termination allows us to add
+ the sizeof(F_STRING) to a Factor string to get a C-style
+ UTF16 string for C library calls. */
+ cput(SREF(string,capacity),(u16)'\0');
+ string->length = tag_fixnum(capacity);
+ string->hashcode = F;
+ return string;
+}
+
+/* call this after constructing a string */
+void rehash_string(F_STRING* str)
+{
+ s32 hash = 0;
+ CELL i;
+ CELL capacity = string_capacity(str);
+ for(i = 0; i < capacity; i++)
+ hash = (31*hash + string_nth(str,i));
+ str->hashcode = (s32)tag_fixnum(hash);
+}
+
+void primitive_rehash_string(void)
+{
+ rehash_string(untag_string(dpop()));
+}
+
+/* untagged */
+F_STRING *string(F_FIXNUM capacity, CELL fill)
+{
+ CELL i;
+
+ F_STRING* string = allot_string(capacity);
+
+ for(i = 0; i < capacity; i++)
+ cput(SREF(string,i),fill);
+
+ rehash_string(string);
+
+ return string;
+}
+
+void primitive_string(void)
+{
+ CELL initial = to_cell(dpop());
+ F_FIXNUM length = to_fixnum(dpop());
+ maybe_gc(string_size(length));
+ dpush(tag_object(string(length,initial)));
+}
+
+F_STRING* resize_string(F_STRING* string, F_FIXNUM capacity, u16 fill)
+{
+ /* later on, do an optimization: if end of array is here, just grow */
+ CELL i;
+ CELL to_copy = string_capacity(string);
+
+ if(capacity < to_copy)
+ to_copy = capacity;
+
+ F_STRING* new_string = allot_string(capacity);
+
+ memcpy(new_string + 1,string + 1,to_copy * CHARS);
+
+ for(i = to_copy; i < capacity; i++)
+ cput(SREF(new_string,i),fill);
+
+ return new_string;
+}
+
+void primitive_resize_string(void)
+{
+ F_STRING* string;
+ CELL capacity = to_fixnum(dpeek2());
+ maybe_gc(string_size(capacity));
+ string = untag_string_fast(dpop());
+ drepl(tag_object(resize_string(string,capacity,0)));
+}
+
+/* Some ugly macros to prevent a 2x code duplication */
+
+#define MEMORY_TO_STRING(type,utype) \
+ F_STRING *memory_to_##type##_string(const type *string, CELL length) \
+ { \
+ F_STRING* s = allot_string(length); \
+ CELL i; \
+ for(i = 0; i < length; i++) \
+ { \
+ cput(SREF(s,i),(utype)*string); \
+ string++; \
+ } \
+ rehash_string(s); \
+ return s; \
+ } \
+ void primitive_memory_to_##type##_string(void) \
+ { \
+ CELL length = unbox_unsigned_cell(); \
+ type *string = (type*)unbox_unsigned_cell(); \
+ dpush(tag_object(memory_to_##type##_string(string,length))); \
+ } \
+ F_STRING *from_##type##_string(const type *str) \
+ { \
+ CELL length = 0; \
+ type *scan = str; \
+ while(*scan++) length++; \
+ return memory_to_##type##_string((type*)str,length); \
+ } \
+ void box_##type##_string(const type *str) \
+ { \
+ dpush(str ? tag_object(from_##type##_string(str)) : F); \
+ } \
+ void primitive_alien_to_##type##_string(void) \
+ { \
+ maybe_gc(0); \
+ drepl(tag_object(from_##type##_string(alien_offset(dpeek())))); \
+ }
+
+MEMORY_TO_STRING(char,u8)
+MEMORY_TO_STRING(u16,u16)
+
+void check_string(F_STRING *s, CELL max)
+{
+ CELL capacity = string_capacity(s);
+ CELL i;
+ for(i = 0; i < capacity; i++)
+ {
+ u16 ch = string_nth(s,i);
+ if(ch == '\0' || ch >= (1 << (max * 8)))
+ general_error(ERROR_C_STRING,tag_object(s),F,true);
+ }
+}
+
+F_ARRAY *allot_c_string(CELL capacity, CELL size)
+{
+ return allot_array(BYTE_ARRAY_TYPE,capacity * size / CELLS + 1);
+}
+
+#define STRING_TO_MEMORY(type) \
+ void type##_string_to_memory(F_STRING *s, type *string) \
+ { \
+ CELL i; \
+ CELL capacity = string_capacity(s); \
+ for(i = 0; i < capacity; i++) \
+ string[i] = string_nth(s,i); \
+ } \
+ void primitive_##type##_string_to_memory(void) \
+ { \
+ type *address = (type*)unbox_unsigned_cell(); \
+ F_STRING *str = untag_string(dpop()); \
+ type##_string_to_memory(str,address); \
+ } \
+ F_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \
+ { \
+ CELL capacity = string_capacity(s); \
+ F_ARRAY *_c_str; \
+ if(check) check_string(s,sizeof(type)); \
+ _c_str = allot_c_string(capacity,sizeof(type)); \
+ type *c_str = (type*)(_c_str + 1); \
+ type##_string_to_memory(s,c_str); \
+ c_str[capacity] = 0; \
+ return _c_str; \
+ } \
+ type *to_##type##_string(F_STRING *s, bool check) \
+ { \
+ if(sizeof(type) == sizeof(u16)) \
+ { \
+ if(check) check_string(s,sizeof(type)); \
+ return (type*)(s + 1); \
+ } \
+ else \
+ return (type*)(string_to_##type##_alien(s,check) + 1); \
+ } \
+ type *pop_##type##_string(void) \
+ { \
+ return to_##type##_string(untag_string(dpop()),true); \
+ } \
+ type *unbox_##type##_string(void) \
+ { \
+ if(type_of(dpeek()) == STRING_TYPE) \
+ return pop_##type##_string(); \
+ else \
+ return unbox_alien(); \
+ } \
+ void primitive_string_to_##type##_alien(void) \
+ { \
+ CELL string, t; \
+ maybe_gc(0); \
+ string = dpeek(); \
+ t = type_of(string); \
+ if(t != ALIEN_TYPE && t != BYTE_ARRAY_TYPE && t != F_TYPE) \
+ drepl(tag_object(string_to_##type##_alien(untag_string(string),true))); \
+ }
+
+STRING_TO_MEMORY(char);
+STRING_TO_MEMORY(u16);
+
+void primitive_char_slot(void)
+{
+ F_STRING* string = untag_string_fast(dpop());
+ CELL index = untag_fixnum_fast(dpop());
+ dpush(tag_fixnum(string_nth(string,index)));
+}
+
+void primitive_set_char_slot(void)
+{
+ F_STRING* string = untag_string_fast(dpop());
+ CELL index = untag_fixnum_fast(dpop());
+ CELL value = untag_fixnum_fast(dpop());
+ set_string_nth(string,index,value);
+}
+
+F_SBUF* sbuf(F_FIXNUM capacity)
+{
+ F_SBUF* sbuf;
+ if(capacity < 0)
+ general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),F,true);
+ sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF));
+ sbuf->top = tag_fixnum(0);
+ sbuf->string = tag_object(string(capacity,'\0'));
+ return sbuf;
+}
+
+void primitive_sbuf(void)
+{
+ CELL size = to_fixnum(dpeek());
+ maybe_gc(sizeof(F_SBUF) + string_size(size));
+ drepl(tag_object(sbuf(size)));
+}
+
+void fixup_sbuf(F_SBUF* sbuf)
+{
+ data_fixup(&sbuf->string);
+}
+
+void collect_sbuf(F_SBUF* sbuf)
+{
+ copy_handle(&sbuf->string);
+}
+
+void primitive_hashtable(void)
+{
+ F_HASHTABLE* hash;
+ maybe_gc(0);
+ hash = allot_object(HASHTABLE_TYPE,sizeof(F_HASHTABLE));
+ hash->count = F;
+ hash->deleted = F;
+ hash->array = F;
+ dpush(tag_object(hash));
+}
+
+void fixup_hashtable(F_HASHTABLE* hashtable)
+{
+ data_fixup(&hashtable->count);
+ data_fixup(&hashtable->deleted);
+ data_fixup(&hashtable->array);
+}
+
+void collect_hashtable(F_HASHTABLE* hashtable)
+{
+ copy_handle(&hashtable->count);
+ copy_handle(&hashtable->deleted);
+ copy_handle(&hashtable->array);
+}
+
+/* When a word is executed we jump to the value of the xt field. However this
+ value is an unportable function pointer, so in the image we store a primitive
+ number that indexes a list of xts. */
+void update_xt(F_WORD* word)
+{
+ word->xt = primitive_to_xt(to_fixnum(word->primitive));
+}
+
+/* <word> ( name vocabulary -- word ) */
+void primitive_word(void)
+{
+ F_WORD *word;
+ CELL name, vocabulary;
+
+ maybe_gc(sizeof(F_WORD));
+
+ vocabulary = dpop();
+ name = dpop();
+ word = allot_object(WORD_TYPE,sizeof(F_WORD));
+ word->hashcode = tag_fixnum((CELL)word); /* initial address */
+ word->name = name;
+ word->vocabulary = vocabulary;
+ word->primitive = tag_fixnum(0);
+ word->def = F;
+ word->props = F;
+ word->xt = (CELL)undefined;
+ dpush(tag_word(word));
+}
+
+void primitive_update_xt(void)
+{
+ update_xt(untag_word(dpop()));
+}
+
+void primitive_word_compiledp(void)
+{
+ F_WORD* word = untag_word(dpop());
+ box_boolean(word->xt != (CELL)docol && word->xt != (CELL)dosym);
+}
+
+void fixup_word(F_WORD* word)
+{
+ data_fixup(&word->primitive);
+
+ /* If this is a compiled word, relocate the code pointer. Otherwise,
+ reset it based on the primitive number of the word. */
+ if(word->xt >= code_relocation_base
+ && word->xt < code_relocation_base
+ - compiling.base + compiling.limit)
+ code_fixup(&word->xt);
+ else
+ update_xt(word);
+
+ data_fixup(&word->name);
+ data_fixup(&word->vocabulary);
+ data_fixup(&word->def);
+ data_fixup(&word->props);
+}
+
+void collect_word(F_WORD* word)
+{
+ copy_handle(&word->name);
+ copy_handle(&word->vocabulary);
+ copy_handle(&word->def);
+ copy_handle(&word->props);
+}
+
+void primitive_wrapper(void)
+{
+ F_WRAPPER *wrapper;
+
+ maybe_gc(sizeof(F_WRAPPER));
+
+ wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
+ wrapper->object = dpeek();
+ drepl(tag_wrapper(wrapper));
+}
+
+void fixup_wrapper(F_WRAPPER *wrapper)
+{
+ data_fixup(&wrapper->object);
+}
+
+void collect_wrapper(F_WRAPPER *wrapper)
+{
+ copy_handle(&wrapper->object);
+}
--- /dev/null
+INLINE CELL tag_boolean(CELL untagged)
+{
+ return (untagged == false ? F : T);
+}
+
+DLLEXPORT void box_boolean(bool value);
+DLLEXPORT bool unbox_boolean(void);
+
+INLINE F_ARRAY* untag_array_fast(CELL tagged)
+{
+ return (F_ARRAY*)UNTAG(tagged);
+}
+
+INLINE F_ARRAY* untag_array(CELL tagged)
+{
+ type_check(ARRAY_TYPE,tagged);
+ return untag_array_fast(tagged);
+}
+
+INLINE F_ARRAY* untag_byte_array_fast(CELL tagged)
+{
+ return (F_ARRAY*)UNTAG(tagged);
+}
+
+INLINE CELL array_size(CELL size)
+{
+ return align8(sizeof(F_ARRAY) + size * CELLS);
+}
+
+F_ARRAY *allot_array(CELL type, F_FIXNUM capacity);
+F_ARRAY *array(CELL type, F_FIXNUM capacity, CELL fill);
+F_ARRAY *byte_array(F_FIXNUM size);
+
+CELL make_array_2(CELL v1, CELL v2);
+CELL make_array_4(CELL v1, CELL v2, CELL v3, CELL v4);
+
+void primitive_array(void);
+void primitive_tuple(void);
+void primitive_byte_array(void);
+void primitive_quotation(void);
+
+F_ARRAY *resize_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill);
+void primitive_resize_array(void);
+void primitive_array_to_tuple(void);
+void primitive_tuple_to_array(void);
+
+#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
+#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS)
+
+INLINE CELL array_capacity(F_ARRAY* array)
+{
+ return untag_fixnum_fast(array->capacity);
+}
+
+void fixup_array(F_ARRAY* array);
+void collect_array(F_ARRAY* array);
+
+INLINE F_VECTOR* untag_vector(CELL tagged)
+{
+ type_check(VECTOR_TYPE,tagged);
+ return (F_VECTOR*)UNTAG(tagged);
+}
+
+F_VECTOR* vector(F_FIXNUM capacity);
+
+void primitive_vector(void);
+void primitive_array_to_vector(void);
+void fixup_vector(F_VECTOR* vector);
+void collect_vector(F_VECTOR* vector);
+
+#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + index * CHARS)
+
+INLINE F_STRING* untag_string_fast(CELL tagged)
+{
+ return (F_STRING*)UNTAG(tagged);
+}
+
+INLINE F_STRING* untag_string(CELL tagged)
+{
+ type_check(STRING_TYPE,tagged);
+ return untag_string_fast(tagged);
+}
+
+INLINE CELL string_capacity(F_STRING* str)
+{
+ return untag_fixnum_fast(str->length);
+}
+
+INLINE CELL string_size(CELL size)
+{
+ return align8(sizeof(F_STRING) + (size + 1) * CHARS);
+}
+
+F_STRING* allot_string(F_FIXNUM capacity);
+void rehash_string(F_STRING* str);
+void primitive_rehash_string(void);
+F_STRING* string(F_FIXNUM capacity, CELL fill);
+void primitive_string(void);
+F_STRING *resize_string(F_STRING *string, F_FIXNUM capacity, u16 fill);
+void primitive_resize_string(void);
+
+F_STRING *memory_to_char_string(const char *string, CELL length);
+void primitive_memory_to_char_string(void);
+F_STRING *from_char_string(const char *c_string);
+DLLEXPORT void box_char_string(const char *c_string);
+void primitive_alien_to_char_string(void);
+
+F_STRING *memory_to_u16_string(const u16 *string, CELL length);
+void primitive_memory_to_u16_string(void);
+F_STRING *from_u16_string(const u16 *c_string);
+DLLEXPORT void box_u16_string(const u16 *c_string);
+void primitive_alien_to_u16_string(void);
+
+void char_string_to_memory(F_STRING *s, char *string);
+void primitive_char_string_to_memory(void);
+F_ARRAY *string_to_char_alien(F_STRING *s, bool check);
+char* to_char_string(F_STRING *s, bool check);
+char *pop_char_string(void);
+DLLEXPORT char *unbox_char_string(void);
+void primitive_string_to_char_alien(void);
+
+void u16_string_to_memory(F_STRING *s, u16 *string);
+void primitive_u16_string_to_memory(void);
+F_ARRAY *string_to_u16_alien(F_STRING *s, bool check);
+u16* to_u16_string(F_STRING *s, bool check);
+u16 *pop_u16_string(void);
+DLLEXPORT u16 *unbox_u16_string(void);
+void primitive_string_to_u16_alien(void);
+
+/* untagged & unchecked */
+INLINE CELL string_nth(F_STRING* string, CELL index)
+{
+ return cget(SREF(string,index));
+}
+
+/* untagged & unchecked */
+INLINE void set_string_nth(F_STRING* string, CELL index, u16 value)
+{
+ cput(SREF(string,index),value);
+}
+
+void primitive_char_slot(void);
+void primitive_set_char_slot(void);
+
+F_SBUF* sbuf(F_FIXNUM capacity);
+void primitive_sbuf(void);
+void fixup_sbuf(F_SBUF* sbuf);
+void collect_sbuf(F_SBUF* sbuf);
+
+void primitive_hashtable(void);
+void fixup_hashtable(F_HASHTABLE* hashtable);
+void collect_hashtable(F_HASHTABLE* hashtable);
+
+typedef void (*XT)(F_WORD *word);
+
+INLINE F_WORD *untag_word_fast(CELL tagged)
+{
+ return (F_WORD*)UNTAG(tagged);
+}
+
+INLINE F_WORD *untag_word(CELL tagged)
+{
+ type_check(WORD_TYPE,tagged);
+ return untag_word_fast(tagged);
+}
+
+INLINE CELL tag_word(F_WORD *word)
+{
+ return RETAG(word,WORD_TYPE);
+}
+
+void update_xt(F_WORD* word);
+void primitive_word(void);
+void primitive_update_xt(void);
+void primitive_word_compiledp(void);
+void fixup_word(F_WORD* word);
+void collect_word(F_WORD* word);
+
+INLINE F_WRAPPER *untag_wrapper_fast(CELL tagged)
+{
+ return (F_WRAPPER*)UNTAG(tagged);
+}
+
+INLINE CELL tag_wrapper(F_WRAPPER *wrapper)
+{
+ return RETAG(wrapper,WRAPPER_TYPE);
+}
+
+void primitive_wrapper(void);
+void fixup_wrapper(F_WRAPPER *wrapper);
+void collect_wrapper(F_WRAPPER *wrapper);
+++ /dev/null
-#include "../factor.h"
-
-static void *null_dll;
-
-void init_ffi(void)
-{
- null_dll = dlopen(NULL,RTLD_LAZY);
-}
-
-void ffi_dlopen(DLL *dll, bool error)
-{
- void *dllptr = dlopen(to_char_string(untag_string(dll->path),true), RTLD_LAZY);
-
- if(dllptr == NULL)
- {
- if(error)
- {
- general_error(ERROR_FFI,tag_object(
- from_char_string(dlerror())),F,true);
- }
- else
- dll->dll = NULL;
-
- return;
- }
-
- dll->dll = dllptr;
-}
-
-void *ffi_dlsym(DLL *dll, F_STRING *symbol, bool error)
-{
- void *handle = (dll == NULL ? null_dll : dll->dll);
- void *sym = dlsym(handle,to_char_string(symbol,true));
- if(sym == NULL)
- {
- if(error)
- {
- general_error(ERROR_FFI,tag_object(
- from_char_string(dlerror())),F,true);
- }
-
- return NULL;
- }
- return sym;
-}
-
-void ffi_dlclose(DLL *dll)
-{
- if(dlclose(dll->dll))
- {
- general_error(ERROR_FFI,tag_object(
- from_char_string(dlerror())),F,true);
- }
- dll->dll = NULL;
-}
+++ /dev/null
-#include "../factor.h"
-
-void primitive_stat(void)
-{
- struct stat sb;
- F_STRING* path;
-
- maybe_gc(0);
-
- path = untag_string(dpop());
- if(stat(to_char_string(path,true),&sb) < 0)
- dpush(F);
- else
- {
- CELL dirp = tag_boolean(S_ISDIR(sb.st_mode));
- CELL mode = tag_fixnum(sb.st_mode & ~S_IFMT);
- CELL size = tag_bignum(s48_long_long_to_bignum(sb.st_size));
- CELL mtime = tag_integer(sb.st_mtime);
- dpush(make_array_4(dirp,mode,size,mtime));
- }
-}
-
-void primitive_read_dir(void)
-{
- F_STRING *path;
- DIR* dir;
- F_ARRAY *result;
- CELL result_count = 0;
-
- maybe_gc(0);
-
- result = array(ARRAY_TYPE,100,F);
-
- path = untag_string(dpop());
- dir = opendir(to_char_string(path,true));
- if(dir != NULL)
- {
- struct dirent* file;
-
- while((file = readdir(dir)) != NULL)
- {
- CELL name = tag_object(from_char_string(file->d_name));
- if(result_count == array_capacity(result))
- {
- result = resize_array(result,
- result_count * 2,F);
- }
-
- put(AREF(result,result_count),name);
- result_count++;
- }
-
- closedir(dir);
- }
-
- result = resize_array(result,result_count,F);
-
- dpush(tag_object(result));
-}
-
-void primitive_cwd(void)
-{
- char wd[MAXPATHLEN];
- maybe_gc(0);
- if(getcwd(wd,MAXPATHLEN) == NULL)
- io_error();
- box_char_string(wd);
-}
-
-void primitive_cd(void)
-{
- maybe_gc(0);
- chdir(pop_char_string());
-}
-
+++ /dev/null
-#include "../platform.h"
-
-/* Thanks to Joshua Grams for this code.
-
-On PowerPC processors, we must flush the instruction cache manually
-after writing to the code heap.
-
-Callable from C as
-void flush_icache(void *start, int len)
-
-This function is called from compiler.c. */
-
-#ifdef FACTOR_PPC
-
-/* IN: 3 = start, 4 = len */
-
- .globl MANGLE(flush_icache)
-MANGLE(flush_icache):
- /* compute number of cache lines to flush */
- add r4,r4,r3
- clrrwi r3,r3,5 /* align addr to next lower cache line boundary */
- sub r4,r4,r3 /* then n_lines = (len + 0x1f) / 0x20 */
- addi r4,r4,0x1f
- srwi. r4,r4,5 /* note '.' suffix */
- beqlr /* if n_lines == 0, just return. */
- mtctr r4 /* flush cache lines */
-0: dcbf 0,r3 /* for each line... */
- sync
- icbi 0,r3
- addi r3,r3,0x20
- bdnz 0b
- sync /* finish up */
- isync
- blr
-
-#endif
+++ /dev/null
-#include "../factor.h"
-
-BOUNDED_BLOCK *alloc_bounded_block(CELL size)
-{
- int pagesize = getpagesize();
-
- char *array = mmap((void*)0,pagesize + size + pagesize,
- PROT_READ | PROT_WRITE | PROT_EXEC,
- MAP_ANON | MAP_PRIVATE,-1,0);
-
- if(array == NULL)
- fatal_error("Cannot allocate memory region",0);
-
- if(mprotect(array,pagesize,PROT_NONE) == -1)
- fatal_error("Cannot protect low guard page",(CELL)array);
-
- if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
- fatal_error("Cannot protect high guard page",(CELL)array);
-
- BOUNDED_BLOCK *retval = safe_malloc(sizeof(BOUNDED_BLOCK));
-
- retval->start = (CELL)(array + pagesize);
- retval->size = size;
-
- return retval;
-}
-
-void dealloc_bounded_block(BOUNDED_BLOCK *block)
-{
- int pagesize = getpagesize();
-
- int retval = munmap((void*)(block->start - pagesize),
- pagesize + block->size + pagesize);
-
- if(retval)
- fatal_error("Failed to unmap region",0);
-
- free(block);
-}
+++ /dev/null
-#include "../factor.h"
-
-void platform_run(void)
-{
- run_toplevel();
-}
-
-void early_init(void) {}
-
-const char *default_image_path(void)
-{
- return "factor.image";
-}
+++ /dev/null
-#include "../factor.h"
-#include "../macosx/mach_signal.h"
-
-// this function tests if a given faulting location is in a poison page. The
-// page address is taken from area + round_up_to_page_size(area_size) +
-// pagesize*offset
-static bool in_page(void *fault, void *i_area, CELL area_size, int offset)
-{
- const int pagesize = getpagesize();
- intptr_t area = (intptr_t) i_area;
- area += pagesize * ((area_size + (pagesize - 1)) / pagesize);
- area += offset * pagesize;
-
- const int page = area / pagesize;
- const int fault_page = (intptr_t)fault / pagesize;
- return page == fault_page;
-}
-
-void signal_handler(int signal, siginfo_t* siginfo, void* uap)
-{
- if(in_page(siginfo->si_addr, (void *) ds_bot, 0, -1))
- general_error(ERROR_DS_UNDERFLOW,F,F,false);
- else if(in_page(siginfo->si_addr, (void *) ds_bot, ds_size, 0))
- general_error(ERROR_DS_OVERFLOW,F,F,false);
- else if(in_page(siginfo->si_addr, (void *) rs_bot, 0, -1))
- general_error(ERROR_RS_UNDERFLOW,F,F,false);
- else if(in_page(siginfo->si_addr, (void *) rs_bot, rs_size, 0))
- general_error(ERROR_RS_OVERFLOW,F,F,false);
- else if(in_page(siginfo->si_addr, (void *) cs_bot, 0, -1))
- general_error(ERROR_CS_UNDERFLOW,F,F,false);
- else if(in_page(siginfo->si_addr, (void *) cs_bot, cs_size, 0))
- general_error(ERROR_CS_OVERFLOW,F,F,false);
- else
- signal_error(signal);
-}
-
-static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact)
-{
- int ret;
- do
- {
- ret = sigaction(signum, act, oldact);
- } while(ret == -1 && errno == EINTR);
-}
-
-void init_signals(void)
-{
- struct sigaction custom_sigaction;
- struct sigaction ign_sigaction;
-
- sigemptyset(&custom_sigaction.sa_mask);
- custom_sigaction.sa_sigaction = signal_handler;
- custom_sigaction.sa_flags = SA_SIGINFO;
- sigaction_safe(SIGABRT,&custom_sigaction,NULL);
- sigaction_safe(SIGFPE,&custom_sigaction,NULL);
- sigaction_safe(SIGBUS,&custom_sigaction,NULL);
- sigaction_safe(SIGQUIT,&custom_sigaction,NULL);
- sigaction_safe(SIGSEGV,&custom_sigaction,NULL);
- sigaction_safe(SIGILL,&custom_sigaction,NULL);
-
- sigemptyset(&ign_sigaction.sa_mask);
- ign_sigaction.sa_handler = SIG_IGN;
- sigaction_safe(SIGPIPE,&ign_sigaction,NULL);
-
-#ifdef __APPLE__
- mach_initialize();
-#endif
-}
+++ /dev/null
-#include "factor.h"
-
-F_VECTOR* vector(F_FIXNUM capacity)
-{
- F_VECTOR* vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
- vector->top = tag_fixnum(0);
- vector->array = tag_object(array(ARRAY_TYPE,capacity,F));
- return vector;
-}
-
-void primitive_vector(void)
-{
- CELL size = to_fixnum(dpeek());
- maybe_gc(array_size(size) + sizeof(F_VECTOR));
- drepl(tag_object(vector(size)));
-}
-
-void primitive_array_to_vector(void)
-{
- F_ARRAY *array;
- F_VECTOR *vector;
- maybe_gc(sizeof(F_VECTOR));
- array = untag_array(dpeek());
- vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
- vector->top = array->capacity;
- vector->array = tag_object(array);
- drepl(tag_object(vector));
-}
-
-void fixup_vector(F_VECTOR* vector)
-{
- data_fixup(&vector->array);
-}
-
-void collect_vector(F_VECTOR* vector)
-{
- copy_handle(&vector->array);
-}
+++ /dev/null
-typedef struct {
- /* always tag_header(VECTOR_TYPE) */
- CELL header;
- /* tagged */
- CELL top;
- /* tagged */
- CELL array;
-} F_VECTOR;
-
-INLINE F_VECTOR* untag_vector(CELL tagged)
-{
- type_check(VECTOR_TYPE,tagged);
- return (F_VECTOR*)UNTAG(tagged);
-}
-
-F_VECTOR* vector(F_FIXNUM capacity);
-
-void primitive_vector(void);
-void primitive_array_to_vector(void);
-void fixup_vector(F_VECTOR* vector);
-void collect_vector(F_VECTOR* vector);
+++ /dev/null
-#include "../factor.h"
-
-void init_ffi (void)
-{
-}
-
-void ffi_dlopen (DLL *dll, bool error)
-{
- HMODULE module;
- char *path = to_c_string(untag_string(dll->path),true);
-
- module = LoadLibrary(path);
-
- if (!module)
- {
- dll->dll = NULL;
- if(error)
- general_error(ERROR_FFI, tag_object(get_error_message()),true);
- else
- return;
- }
-
- dll->dll = module;
-}
-
-void *ffi_dlsym (DLL *dll, F_STRING *symbol, bool error)
-{
- void *sym = GetProcAddress(dll ? (HMODULE)dll->dll : GetModuleHandle(NULL),
- to_c_string(symbol,true));
-
- if (!sym)
- {
- if(error)
- general_error(ERROR_FFI, tag_object(get_error_message()),true);
- else
- return NULL;
- }
-
- return sym;
-}
-
-void ffi_dlclose (DLL *dll)
-{
- FreeLibrary((HMODULE)dll->dll);
- dll->dll = NULL;
-}
+++ /dev/null
-#include "../factor.h"
-
-void primitive_stat(void)
-{
- F_STRING *path;
- WIN32_FILE_ATTRIBUTE_DATA st;
-
- maybe_gc(0);
- path = untag_string(dpop());
-
- if(!GetFileAttributesEx(to_c_string(path,true), GetFileExInfoStandard, &st))
- {
- dpush(F);
- }
- else
- {
- CELL dirp = tag_boolean(st.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
- CELL size = tag_bignum(s48_long_long_to_bignum(
- (s64)st.nFileSizeLow | (s64)st.nFileSizeHigh << 32));
- CELL mtime = tag_integer((int)
- ((*(s64*)&st.ftLastWriteTime - EPOCH_OFFSET) / 10000000));
- dpush(make_array_4(dirp,tag_fixnum(0),size,mtime));
- }
-}
-
-void primitive_read_dir(void)
-{
- F_STRING *path;
- HANDLE dir;
- WIN32_FIND_DATA find_data;
- F_ARRAY *result;
- CELL result_count = 0;
-
- maybe_gc(0);
-
- result = array(ARRAY_TYPE,100,F);
-
- path = untag_string(dpop());
- if (INVALID_HANDLE_VALUE != (dir = FindFirstFile(".\\*", &find_data)))
- {
- do
- {
- CELL name = tag_object(from_c_string(
- find_data.cFileName));
-
- if(result_count == array_capacity(result))
- {
- result = resize_array(result,
- result_count * 2,F);
- }
-
- put(AREF(result,result_count),name);
- result_count++;
- }
- while (FindNextFile(dir, &find_data));
- CloseHandle(dir);
- }
-
- result = resize_array(result,result_count,F);
-
- dpush(tag_object(result));
-}
-
-void primitive_cwd(void)
-{
- char buf[MAX_PATH];
-
- maybe_gc(0);
- if(!GetCurrentDirectory(MAX_PATH, buf))
- io_error();
-
- box_c_string(buf);
-}
-
-void primitive_cd(void)
-{
- maybe_gc(0);
- SetCurrentDirectory(pop_c_string());
-}
\ No newline at end of file
+++ /dev/null
-#include "../factor.h"
-
-BOUNDED_BLOCK *alloc_bounded_block(CELL size)
-{
- SYSTEM_INFO si;
- char *mem;
- DWORD ignore;
-
- GetSystemInfo(&si);
- if((mem = (char *)VirtualAlloc(NULL, si.dwPageSize*2 + size, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0)
- fatal_error("VirtualAlloc() failed in alloc_bounded_block()",0);
-
- if (!VirtualProtect(mem, si.dwPageSize, PAGE_NOACCESS, &ignore))
- fatal_error("Cannot allocate low guard page", (CELL)mem);
-
- if (!VirtualProtect(mem+size+si.dwPageSize, si.dwPageSize, PAGE_NOACCESS, &ignore))
- fatal_error("Cannot allocate high guard page", (CELL)mem);
-
- BOUNDED_BLOCK *block = safe_malloc(sizeof(BOUNDED_BLOCK));
-
- block->start = (int)mem + si.dwPageSize;
- block->size = size;
-
- return block;
-}
-
-void dealloc_bounded_block(BOUNDED_BLOCK *block)
-{
- SYSTEM_INFO si;
- GetSystemInfo(&si);
- if(!VirtualFree((void*)(block->start - si.dwPageSize), 0, MEM_RELEASE))
- fatal_error("VirtualFree() failed",0);
- free(block);
-}
-
+++ /dev/null
-#include "../factor.h"
-
-void init_signals() { }
+++ /dev/null
-#include "../factor.h"
-
-/* SEH support. Proceed with caution. */
-typedef long exception_handler_t(
- void *rec, void *frame, void *context, void *dispatch);
-
-typedef struct exception_record {
- struct exception_record *next_handler;
- void *handler_func;
-} exception_record_t;
-
-void seh_call(void (*func)(), exception_handler_t *handler)
-{
- exception_record_t record;
- asm("mov %%fs:0, %0" : "=r" (record.next_handler));
- asm("mov %0, %%fs:0" : : "r" (&record));
- record.handler_func = handler;
- func();
- asm("mov %0, %%fs:0" : "=r" (record.next_handler));
-}
-
-static long exception_handler(void *rec, void *frame, void *ctx, void *dispatch)
-{
- signal_error(SIGSEGV);
-}
-
-void platform_run(void)
-{
- seh_call(run_toplevel, exception_handler);
-}
-
-void early_init(void) {}
-
-const char *default_image_path(void)
-{
- return "factor.image";
-}
+++ /dev/null
-#include "factor.h"
-
-/* When a word is executed we jump to the value of the xt field. However this
- value is an unportable function pointer, so in the image we store a primitive
- number that indexes a list of xts. */
-void update_xt(F_WORD* word)
-{
- word->xt = primitive_to_xt(to_fixnum(word->primitive));
-}
-
-/* <word> ( name vocabulary -- word ) */
-void primitive_word(void)
-{
- F_WORD *word;
- CELL name, vocabulary;
-
- maybe_gc(sizeof(F_WORD));
-
- vocabulary = dpop();
- name = dpop();
- word = allot_object(WORD_TYPE,sizeof(F_WORD));
- word->hashcode = tag_fixnum((CELL)word); /* initial address */
- word->name = name;
- word->vocabulary = vocabulary;
- word->primitive = tag_fixnum(0);
- word->def = F;
- word->props = F;
- word->xt = (CELL)undefined;
- dpush(tag_word(word));
-}
-
-void primitive_update_xt(void)
-{
- update_xt(untag_word(dpop()));
-}
-
-void primitive_word_compiledp(void)
-{
- F_WORD* word = untag_word(dpop());
- box_boolean(word->xt != (CELL)docol && word->xt != (CELL)dosym);
-}
-
-void fixup_word(F_WORD* word)
-{
- data_fixup(&word->primitive);
-
- /* If this is a compiled word, relocate the code pointer. Otherwise,
- reset it based on the primitive number of the word. */
- if(word->xt >= code_relocation_base
- && word->xt < code_relocation_base
- - compiling.base + compiling.limit)
- code_fixup(&word->xt);
- else
- update_xt(word);
-
- data_fixup(&word->name);
- data_fixup(&word->vocabulary);
- data_fixup(&word->def);
- data_fixup(&word->props);
-}
-
-void collect_word(F_WORD* word)
-{
- copy_handle(&word->name);
- copy_handle(&word->vocabulary);
- copy_handle(&word->def);
- copy_handle(&word->props);
-}
+++ /dev/null
-typedef struct {
- /* TAGGED header */
- CELL header;
- /* TAGGED hashcode */
- CELL hashcode;
- /* TAGGED word name */
- CELL name;
- /* TAGGED word vocabulary */
- CELL vocabulary;
- /* TAGGED on-disk primitive number */
- CELL primitive;
- /* TAGGED parameter to xt; used for colon definitions */
- CELL def;
- /* TAGGED property hash for library code */
- CELL props;
- /* UNTAGGED execution token: jump here to execute word */
- CELL xt;
-} F_WORD;
-
-typedef void (*XT)(F_WORD *word);
-
-INLINE F_WORD *untag_word_fast(CELL tagged)
-{
- return (F_WORD*)UNTAG(tagged);
-}
-
-INLINE F_WORD *untag_word(CELL tagged)
-{
- type_check(WORD_TYPE,tagged);
- return untag_word_fast(tagged);
-}
-
-INLINE CELL tag_word(F_WORD *word)
-{
- return RETAG(word,WORD_TYPE);
-}
-
-void update_xt(F_WORD* word);
-void primitive_word(void);
-void primitive_update_xt(void);
-void primitive_word_compiledp(void);
-void fixup_word(F_WORD* word);
-void collect_word(F_WORD* word);
+++ /dev/null
-#include "factor.h"
-
-void primitive_wrapper(void)
-{
- F_WRAPPER *wrapper;
-
- maybe_gc(sizeof(F_WRAPPER));
-
- wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
- wrapper->object = dpeek();
- drepl(tag_wrapper(wrapper));
-}
-
-void fixup_wrapper(F_WRAPPER *wrapper)
-{
- data_fixup(&wrapper->object);
-}
-
-void collect_wrapper(F_WRAPPER *wrapper)
-{
- copy_handle(&wrapper->object);
-}
+++ /dev/null
-typedef struct {
- CELL header;
- CELL object;
-} F_WRAPPER;
-
-INLINE F_WRAPPER *untag_wrapper_fast(CELL tagged)
-{
- return (F_WRAPPER*)UNTAG(tagged);
-}
-
-INLINE CELL tag_wrapper(F_WRAPPER *wrapper)
-{
- return RETAG(wrapper,WRAPPER_TYPE);
-}
-
-void primitive_wrapper(void);
-void fixup_wrapper(F_WRAPPER *wrapper);
-void collect_wrapper(F_WRAPPER *wrapper);
projects / factor.git / commitdiff