Attempt to fix OS_read_char_ready on bsd.
Some changes for VMS.
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/array.h,v 9.21 1987/01/22 14:14:45 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/array.h,v 9.22 1987/04/16 02:06:23 jinx Rel $ */
\f
/* The following two macros determine what kind of arrays we deal with.
Use float to save space for image-processing
\f
#define My_Store_Flonum_Result(Ans, Value_Cell) \
(Value_Cell) = (Allocate_Float( ((double) Ans)));
-/*
-#define Allocate_Float(Ans) \
- Primitive_GC_If_Needed(FLONUM_SIZE + 1); \
- *Free = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, FLONUM_SIZE); \
- Get_Float(C_To_Scheme(Free)) = (Ans); \
- Free += FLONUM_SIZE+1; \
- (Value_Cell) = Make_Pointer(TC_BIG_FLONUM, Free-(1+FLONUM_SIZE));
-*/
-\f
-#define My_Store_Reduced_Flonum_Result(Ans, Value_Cell) \
- { double Number = ((double) Ans); \
- double floor(); \
- Pointer result; \
- if (floor(Number) != Number) \
- { My_Store_Flonum_Result(Number, Value_Cell); \
+
+#define My_Store_Reduced_Flonum_Result(Ans, Value_Cell) \
+{ double Number = ((double) Ans); \
+ double floor(); \
+ Pointer result; \
+ if (floor(Number) != Number) \
+ { My_Store_Flonum_Result(Number, Value_Cell); \
+ } \
+ else if (Number == 0) \
+ (Value_Cell) = Make_Unsigned_Fixnum(0); \
+ if ((floor(Number) == Number) && (Number != 0)) \
+ { int exponent; \
+ double frexp(); \
+ frexp(Number, &exponent); \
+ if (exponent <= FIXNUM_LENGTH) \
+ { double_into_fixnum(Number, result); \
+ (Value_Cell) = result; \
} \
- else if (Number == 0) (Value_Cell) = FIXNUM_0; \
- if ((floor(Number) == Number) && (Number != 0)) \
- { int exponent; \
- double frexp(); \
- frexp(Number, &exponent); \
- if (exponent <= FIXNUM_LENGTH) \
- { double_into_fixnum(Number, result); \
- (Value_Cell) = result; \
- } \
- /* Since the float has no fraction, we will not gain \
- precision if its mantissa has enough bits to support \
- the exponent. */ \
- else if (exponent <= FLONUM_MANTISSA_BITS) \
- { result = Float_To_Big(Number); \
- (Value_Cell) = result; \
- } \
- else if (Number != 0) \
- { My_Store_Flonum_Result( (Ans), (Value_Cell)); \
- } \
+ /* Since the float has no fraction, we will not gain \
+ precision if its mantissa has enough bits to support \
+ the exponent. */ \
+ else if (exponent <= FLONUM_MANTISSA_BITS) \
+ { result = Float_To_Big(Number); \
+ (Value_Cell) = result; \
} \
- }
-
-\f
-
-/* the end */
+ else if (Number != 0) \
+ { My_Store_Flonum_Result( (Ans), (Value_Cell)); \
+ } \
+ } \
+}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.26 1987/02/12 01:19:11 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.27 1987/04/16 02:06:33 jinx Exp $ */
/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
purify, and fasdump, respectively, to provide garbage collection
Not implemented yet.
*/
-NIY(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP")
+Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP", 0x56)
+{
+ Primitive_3_Args();
+
+ Primitive_Error(ERR_UNIMPLEMENTED_PRIMITIVE);
+ /*NOTREACHED*/
+}
\f
/* (DUMP-BAND PROCEDURE FILE-NAME)
- [Primitive number 0xB7]
Saves all of the heap and pure space on FILE-NAME. When the
file is loaded back using BAND_LOAD, PROCEDURE is called with an
argument of NIL.
*/
-Built_In_Primitive(Prim_Band_Dump, 2, "DUMP-BAND")
-{ Pointer Combination, Ext_Prims;
+Built_In_Primitive(Prim_Band_Dump, 2, "DUMP-BAND", 0xB7)
+{
+ Pointer Combination, Ext_Prims;
long Arg1Type;
Primitive_2_Args();
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcl.c,v 9.27 1987/04/03 00:07:27 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcl.c,v 9.28 1987/04/16 02:06:42 jinx Exp $ */
/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
purify, and fasdump, respectively, to provide garbage collection
}
\f
#define relocate_normal_setup() \
-{ Old = Get_Pointer(Temp); \
+{ \
+ Old = Get_Pointer(Temp); \
if (Old >= Low_Constant) continue; \
if (Type_Code(*Old) == TC_BROKEN_HEART) \
{ *Scan = Make_New_Pointer(Type_Code(Temp), *Old); \
continue; \
} \
- New_Address = (BROKEN_HEART_0 + C_To_Scheme(To_Address)); \
+ New_Address = Make_Broken_Heart(C_To_Scheme(To_Address)); \
}
#define relocate_normal_transport(copy_code, length) \
}
else
{ Pointer *Saved_Old = Old;
- New_Address = (BROKEN_HEART_0 + C_To_Scheme(To_Address));
+ New_Address = Make_Broken_Heart(C_To_Scheme(To_Address));
copy_vector();
*Saved_Old = New_Address;
*Scan = Relocate_Compiled(Temp, Get_Pointer(New_Address), Saved_Old);
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.27 1987/04/03 00:07:44 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.28 1987/04/16 02:06:52 jinx Exp $ */
/* Memory management top level. Garbage collection to disk.
void
open_gc_file()
-{ int position;
+{
+ int position;
int flags;
(void) mktemp(gc_default_file_name);
position = Parse_Option("-gcfile", Saved_argc, Saved_argv, true);
if ((position != NOT_THERE) &&
(position != (Saved_argc - 1)))
- { gc_file_name = Saved_argv[position + 1];
+ {
+ gc_file_name = Saved_argv[position + 1];
}
else
- { gc_file_name = gc_default_file_name;
+ {
+ gc_file_name = gc_default_file_name;
flags |= O_EXCL;
}
while(true)
- { gc_file = open(gc_file_name, flags, GC_FILE_MASK);
- if (gc_file != -1) break;
+ {
+ gc_file = open(gc_file_name, flags, GC_FILE_MASK);
+ if (gc_file != -1)
+ break;
if (gc_file_name != gc_default_file_name)
- { fprintf(stderr,
+ {
+ fprintf(stderr,
"%s: GC file \"%s\" cannot be opened; ",
Saved_argv[0]), gc_file_name;
gc_file_name = gc_default_file_name;
void
close_gc_file()
-{ if (close(gc_file) == -1)
+{
+ if (close(gc_file) == -1)
fprintf(stderr,
"%s: Problems closing GC file \"%s\".\n",
Saved_argv[0], gc_file_name);
\f
void
Clear_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size)
-int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
-{ Heap_Top = Heap_Bottom + Our_Heap_Size;
+ int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
+{
+ Heap_Top = Heap_Bottom + Our_Heap_Size;
Set_Mem_Top(Heap_Top - GC_Reserve);
Free = Heap_Bottom;
Free_Constant = Constant_Space;
void
Setup_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size)
-int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
-{ int Real_Stack_Size = Stack_Allocation_Size(Our_Stack_Size);
+ int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
+{
+ int Real_Stack_Size;
+
+ Real_Stack_Size = Stack_Allocation_Size(Our_Stack_Size);
/* Consistency check 1 */
if (Our_Heap_Size == 0)
- { printf("Configuration won't hold initial data.\n");
+ {
+ fprintf(stderr, "Configuration won't hold initial data.\n");
exit(1);
}
/* Consistency check 2 */
if (Heap == NULL)
- { fprintf(stderr, "Not enough memory for this configuration.\n");
+ {
+ fprintf(stderr, "Not enough memory for this configuration.\n");
exit(1);
}
/* Consistency check 3 */
if (((C_To_Scheme(Highest_Allocated_Address)) & TYPE_CODE_MASK) != 0)
- { fprintf(stderr,
+ {
+ fprintf(stderr,
"Largest address does not fit in datum field of Pointer.\n");
fprintf(stderr,
"Allocate less space or re-compile without Heap_In_Low_Memory.\n");
void
Reset_Memory()
-{ close_gc_file();
+{
+ close_gc_file();
return;
}
\f
void
dump_buffer(from, position, nbuffers, name)
-Pointer *from;
-long *position, nbuffers;
-char *name;
-{ long bytes_written;
+ Pointer *from;
+ long *position, nbuffers;
+ char *name;
+{
+ long bytes_written;
if (lseek(gc_file, *position, 0) == -1)
- { fprintf(stderr,
+ {
+ fprintf(stderr,
"\nCould not position GC file to write the %s buffer.\n",
name);
Microcode_Termination(TERM_EXIT);
}
if ((bytes_written = write(gc_file, from, (nbuffers * GC_BUFFER_BYTES))) ==
-1)
- { fprintf(stderr, "\nCould not write out the %s buffer.\n", name);
+ {
+ fprintf(stderr, "\nCould not write out the %s buffer.\n", name);
Microcode_Termination(TERM_EXIT);
/*NOTREACHED*/
}
void
load_buffer(position, to, nbytes, name)
-long position;
-Pointer *to;
-long nbytes;
-char *name;
-{ long bytes_read;
+ long position;
+ Pointer *to;
+ long nbytes;
+ char *name;
+{
+ long bytes_read;
+
if (lseek(gc_file, position, 0) == -1)
- { fprintf(stderr, "\nCould not position GC file to read %s.\n", name);
+ {
+ fprintf(stderr, "\nCould not position GC file to read %s.\n", name);
Microcode_Termination(TERM_EXIT);
/*NOTREACHED*/
}
if ((bytes_read = read(gc_file, to, nbytes)) != nbytes)
- { fprintf(stderr, "\nCould not read into %s.\n", name);
+ {
+ fprintf(stderr, "\nCould not read into %s.\n", name);
Microcode_Termination(TERM_EXIT);
/*NOTREACHED*/
}
void
reload_scan_buffer()
-{ if (scan_position == free_position)
- { scan_buffer_bottom = free_buffer_bottom;
+{
+ if (scan_position == free_position)
+ {
+ scan_buffer_bottom = free_buffer_bottom;
scan_buffer_top = free_buffer_top;
scan_buffer = scan_buffer_bottom;
return;
\f
void
initialize_scan_buffer()
-{ scan_position = 0;
+{
+ scan_position = 0;
reload_scan_buffer();
scan_buffer = scan_buffer_bottom;
return;
*/
void
initialize_free_buffer()
-{ free_position = 0;
+{
+ free_position = 0;
free_buffer_bottom = gc_disk_buffer_1;
free_buffer_top = free_buffer_bottom + GC_DISK_BUFFER_SIZE;
free_buffer = free_buffer_bottom;
return;
}
-Pointer
-*dump_and_reload_scan_buffer(number_to_skip)
-long number_to_skip;
-{ dump_buffer(scan_buffer_bottom, &scan_position, 1, "scan");
+Pointer *
+dump_and_reload_scan_buffer(number_to_skip)
+ long number_to_skip;
+{
+ dump_buffer(scan_buffer_bottom, &scan_position, 1, "scan");
if (number_to_skip != 0)
scan_position += (number_to_skip * GC_BUFFER_BYTES);
reload_scan_buffer();
return scan_buffer_bottom;
}
-Pointer
-*dump_and_reset_free_buffer(overflow)
-fast long overflow;
-{ fast Pointer *into, *from;
+Pointer *
+dump_and_reset_free_buffer(overflow)
+ fast long overflow;
+{
+ fast Pointer *into, *from;
from = free_buffer_top;
if (free_buffer_bottom == scan_buffer_bottom)
- { /* No need to dump now, it will be dumped when scan is dumped.
+ {
+ /* No need to dump now, it will be dumped when scan is dumped.
Does this work?
We may need to dump the buffer anyway so we can dump the next one.
It may not be possible to lseek past the end of file.
void
dump_free_directly(from, nbuffers)
-Pointer *from;
-long nbuffers;
-{ dump_buffer(from, &free_position, nbuffers, "free");
+ Pointer *from;
+ long nbuffers;
+{
+ dump_buffer(from, &free_position, nbuffers, "free");
return;
}
\f
void
initialize_new_space_buffer()
-{ current_buffer_position = -1;
+{
+ current_buffer_position = -1;
return;
}
void
flush_new_space_buffer()
-{ if (current_buffer_position == -1)
+{
+ if (current_buffer_position == -1)
return;
dump_buffer(gc_disk_buffer_1, ¤t_buffer_position,
1, "weak pair buffer");
return;
}
-Pointer
-*guarantee_in_memory(addr)
-Pointer *addr;
-{ long position, offset;
+Pointer *
+guarantee_in_memory(addr)
+ Pointer *addr;
+{
+ long position, offset;
+
position = (addr - Heap_Bottom);
offset = (position % GC_DISK_BUFFER_SIZE);
position = (position / GC_DISK_BUFFER_SIZE);
position *= GC_BUFFER_BYTES;
if (position != current_buffer_position)
- { flush_new_space_buffer();
+ {
+ flush_new_space_buffer();
load_buffer(position, gc_disk_buffer_1,
GC_BUFFER_BYTES, "the weak pair buffer");
current_buffer_position = position;
is on disk. Old space is in memory.
*/
+Pointer Weak_Chain;
+
void
Fix_Weak_Chain()
-{ fast Pointer *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant;
+{
+ fast Pointer *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant;
initialize_new_space_buffer();
Low_Constant = Constant_Space;
while (Weak_Chain != NIL)
- { Old_Weak_Cell = Get_Pointer(Weak_Chain);
+ {
+ Old_Weak_Cell = Get_Pointer(Weak_Chain);
Scan = guarantee_in_memory(Get_Pointer(*Old_Weak_Cell++));
Weak_Chain = *Old_Weak_Cell;
Old_Car = *Scan;
/* Old is still a pointer to old space */
Old = Get_Pointer(Old_Car);
if (Old >= Low_Constant)
- { *Scan = Temp;
+ {
+ *Scan = Temp;
continue;
}
if (Type_Code(*Old) == TC_BROKEN_HEART)
- { *Scan = Make_New_Pointer(Type_Code(Temp), *Old);
+ {
+ *Scan = Make_New_Pointer(Type_Code(Temp), *Old);
continue;
}
*Scan = NIL;
/* Old is still a pointer to old space */
Old = Get_Pointer(Old_Car);
if (Old >= Low_Constant)
- { *Scan = Temp;
+ {
+ *Scan = Temp;
continue;
}
/* Ditto */
Old = Get_Compiled_Block(Old);
if (Type_Code(*Old) == TC_BROKEN_HEART)
- { *Scan = Relocate_Compiled(Temp, Get_Pointer(*Old), Old);
+ {
+ *Scan = Relocate_Compiled(Temp, Get_Pointer(*Old), Old);
continue;
}
*Scan = NIL;
\f
void
GC()
-{ Pointer *Root, *Result, *end_of_constant_area,
+{
+ Pointer *Root, *Result, *end_of_constant_area,
The_Precious_Objects, *Root2;
initialize_free_buffer();
*free_buffer++ = Make_Pointer(TC_HUNK3, History);
*free_buffer++ = Undefined_Externals;
*free_buffer++ = Get_Current_Stacklet();
- *free_buffer++ = ((Previous_Restore_History_Stacklet == NULL) ?
+ *free_buffer++ = ((Prev_Restore_History_Stacklet == NULL) ?
NIL :
Make_Pointer(TC_CONTROL_POINT,
- Previous_Restore_History_Stacklet));
+ Prev_Restore_History_Stacklet));
*free_buffer++ = Current_State_Point;
*free_buffer++ = Fluid_Bindings;
Free += (free_buffer - free_buffer_bottom);
/* The 4 step GC */
Result = GCLoop(Constant_Space, &free_buffer, &Free);
if (Result != end_of_constant_area)
- { fprintf(stderr, "\nGC: Constant Scan ended too early.\n");
+ {
+ fprintf(stderr, "\nGC: Constant Scan ended too early.\n");
Microcode_Termination(TERM_EXIT);
/*NOTREACHED*/
}
initialize_scan_buffer();
Result = GCLoop(scan_buffer, &free_buffer, &Free);
if (free_buffer != Result)
- { fprintf(stderr, "\nGC-1: Heap Scan ended too early.\n");
+ {
+ fprintf(stderr, "\nGC-1: Heap Scan ended too early.\n");
Microcode_Termination(TERM_EXIT);
/*NOTREACHED*/
}
free_buffer = dump_and_reset_free_buffer(free_buffer - free_buffer_top);
Result = GCLoop(Result, &free_buffer, &Free);
if (free_buffer != Result)
- { fprintf(stderr, "\nGC-2: Heap Scan ended too early.\n");
+ {
+ fprintf(stderr, "\nGC-2: Heap Scan ended too early.\n");
Microcode_Termination(TERM_EXIT);
/*NOTREACHED*/
}
Set_Current_Stacklet(*Root);
Root += 1; /* Set_Current_Stacklet is sometimes a No-Op! */
if (*Root == NIL)
- { Previous_Restore_History_Stacklet = NULL;
+ {
+ Prev_Restore_History_Stacklet = NULL;
Root += 1;
}
- else Previous_Restore_History_Stacklet = Get_Pointer(*Root++);
+ else
+ Prev_Restore_History_Stacklet = Get_Pointer(*Root++);
Current_State_Point = *Root++;
Fluid_Bindings = *Root++;
Free_Stacklets = NULL;
}
\f
/* (GARBAGE-COLLECT SLACK)
- [Primitive number 0x3A]
- Requests a garbage collection leaving the specified amount of slack
- for the top of heap check on the next GC. The primitive ends by invoking
- the GC daemon if there is one.
+ Requests a garbage collection leaving the specified amount of slack
+ for the top of heap check on the next GC. The primitive ends by invoking
+ the GC daemon if there is one.
*/
-Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT")
-{ Pointer GC_Daemon_Proc;
+Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT", 0x3A)
+{
+ Pointer GC_Daemon_Proc;
Primitive_1_Arg();
Arg_1_Type(TC_FIXNUM);
if (Free > Heap_Top)
- { fprintf(stderr, "\nGC has been delayed too long, and you are truly out of room!\n");
- fprintf(stderr, "Free=0x%x, MemTop=0x%x, Heap_Top=0x%x\n", Free, MemTop, Heap_Top);
+ {
+ fprintf(stderr,
+ "\nGC has been delayed too long; You are truly out of room!\n");
+ fprintf(stderr,
+ "Free = 0x%x, MemTop = 0x%x, Heap_Top = 0x%x\n",
+ Free, MemTop, Heap_Top);
Microcode_Termination(TERM_NO_SPACE);
/*NOTREACHED*/
}
GC();
IntCode &= ~INT_GC;
if (GC_Check(GC_Space_Needed))
- { fprintf(stderr,
- "\nGC just ended. The free pointer is at 0x%x, the top of this heap\n",
- Free);
+ {
+ fprintf(stderr, "\nGC just ended.\n");
fprintf(stderr,
- "is at 0x%x, and we are trying to cons 0x%x objects. Dead!\n",
- MemTop, GC_Space_Needed);
+ "Free = 0x%x; MemTop = 0x%x; GC_Space_Needed = 0x%x.\n",
+ Free, MemTop, GC_Space_Needed);
Microcode_Termination(TERM_NO_SPACE);
/*NOTREACHED*/
}
GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
if (GC_Daemon_Proc == NIL)
- return FIXNUM_0 + (MemTop - Free);
+ return Make_Unsigned_Fixnum(MemTop - Free);
Pop_Primitive_Frame(1);
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+1));
+ Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1));
Store_Return(RC_NORMAL_GC_DONE);
- Store_Expression(FIXNUM_0 + (MemTop - Free));
+ Store_Expression(Make_Unsigned_Fixnum(MemTop - Free));
Save_Cont();
Push(GC_Daemon_Proc);
Push(STACK_FRAME_HEADER);
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.26 1987/02/12 01:18:37 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.27 1987/04/16 02:07:10 jinx Exp $
*
* This file contains the code for primitives dealing with pure
* and constant space. Garbage collection to disk version.
Pointer
Purify_Pass_2(info)
Pointer info;
-{ fprintf(stderr, "\nPurify_Pass_2 invoked!\n");
+{
+ fprintf(stderr, "\nPurify_Pass_2 invoked!\n");
Microcode_Termination(TERM_EXIT);
/*NOTREACHED*/
}
/* Stub. Make it look as if it had succeeded. */
-Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY")
+Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY", 0xB4)
{
Primitive_2_Args();
+
return TRUTH;
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bignum.c,v 9.22 1987/04/06 12:48:16 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bignum.c,v 9.23 1987/04/16 02:08:22 jinx Rel $
This file contains the procedures for handling BIGNUM Arithmetic.
*/
-\f
+
#include "scheme.h"
#include <math.h>
#include "primitive.h"
#include "bignum.h"
#include "flonum.h"
#include "zones.h"
+\f
+/* General Purpose Utilities */
-/* Bignum Comparison Primitives */
+Pointer
+return_bignum_zero()
+{
+ bigdigit *REG;
+ long Align_0 = Align(0);
+ Primitive_GC_If_Needed(Align_0);
+ REG = BIGNUM(Free);
+ Prepare_Header(REG, 0, POSITIVE);
+ Free += Align_0;
+ return Make_Pointer(TC_BIG_FIXNUM, Free-Align_0);
+}
-/* big_compare() will return either of three cases, determining whether
- * ARG1 is bigger, smaller, or equal to ARG2.
- */
+void
+trim_bignum(ARG)
+ bigdigit *ARG;
+{
+ fast bigdigit *SCAN;
+ fast bigdigit size;
+ bigdigit sign;
-big_compare(ARG1, ARG2)
-bigdigit *ARG1, *ARG2;
-{ switch(Categorize_Sign(ARG1, ARG2))
- { case BOTH_NEGATIVE : return big_compare_unsigned(ARG2, ARG1);
- case BOTH_POSITIVE : return big_compare_unsigned(ARG1, ARG2);
- case ARG1_NEGATIVE : return TWO_BIGGER;
- case ARG2_NEGATIVE : return ONE_BIGGER;
- default: Sign_Error("big_compare()");
+ sign = SIGN(ARG);
+ size = LEN(ARG);
+
+ for (SCAN = Bignum_Top(ARG); ((size != 0) && (*SCAN == 0)); SCAN--)
+ size -= 1;
+
+ if (size == 0)
+ sign = POSITIVE;
+ Prepare_Header(ARG, size, sign);
+ return;
+}
+
+void
+copy_bignum(SOURCE, TARGET)
+ fast bigdigit *SOURCE, *TARGET;
+{
+ fast bigdigit *LIMIT;
+
+ LIMIT = Bignum_Top(SOURCE);
+ while (LIMIT >= SOURCE)
+ *TARGET++ = *SOURCE++;
+ return;
+}
+
+long
+Find_Length(pradix, length)
+ fast long pradix;
+ bigdigit length;
+{
+ fast int log_pradix;
+
+ log_pradix = 0;
+ while (pradix != 1)
+ {
+ pradix = pradix >> 1;
+ log_pradix += 1;
+ }
+ return (((SHIFT / log_pradix) + 1) * length);
+}
+\f
+/* scale() and unscale() used by Division and Listify */
+
+void
+scale(SOURCE, DEST, how_much)
+ fast bigdigit *SOURCE, *DEST;
+ fast long how_much;
+{
+ fast unsigned bigdouble prod = 0;
+ bigdigit *LIMIT;
+
+ if (how_much == 1)
+ {
+ if (SOURCE != DEST)
+ copy_bignum(SOURCE, DEST);
+ Prepare_Header(DEST, (LEN(SOURCE) + 1), SIGN(SOURCE));
+ *Bignum_Top(DEST) = 0;
+ return;
+ }
+
+ /* This must happen before the Prepare_Header if DEST = SOURCE */
+
+ LIMIT = Bignum_Top(SOURCE);
+ Prepare_Header(DEST, (LEN(SOURCE) + 1), SIGN(SOURCE));
+ SOURCE = Bignum_Bottom(SOURCE);
+ DEST = Bignum_Bottom(DEST);
+ while (LIMIT >= SOURCE)
+ {
+ prod = *SOURCE++ * how_much + Get_Carry(prod);
+ *DEST++ = Get_Digit(prod);
+ }
+ *DEST = Get_Carry(prod);
+ return;
+}
+
+/* returns remainder */
+
+long
+unscale(SOURCE, DEST, how_much)
+ bigdigit *SOURCE;
+ fast bigdigit *DEST;
+ fast long how_much;
+{
+ bigdigit carry = 0;
+ fast unsigned bigdouble digits;
+ fast bigdigit *SCAN;
+
+ if (how_much == 1)
+ {
+ if (SOURCE != DEST)
+ copy_bignum(SOURCE, DEST);
+ return 0;
+ }
+ Prepare_Header(DEST, LEN(SOURCE), SIGN(DEST));
+ SCAN = Bignum_Top(SOURCE);
+ DEST = Bignum_Top(DEST);
+ SOURCE = Bignum_Bottom(SOURCE);
+ while (SCAN >= SOURCE)
+ {
+ /* Bug fix by JMiller */
+ fast unsigned bigdouble digits, temp;
+
+ digits = Mul_Radix(carry) + *SCAN--;
+ temp = digits / how_much;
+ *DEST-- = temp;
+ temp = temp * how_much;
+ carry = digits - temp;
}
+ return carry;
}
+\f
+/* Bignum Comparison utilities */
/* big_compare_unsigned() compares the magnitudes of two BIGNUM's.
* Called by big_compare() and minus_unsigned_bignum().
*/
+int
big_compare_unsigned(ARG1, ARG2)
-fast bigdigit *ARG1, *ARG2;
-{ fast bigdigit *LIMIT;
+ fast bigdigit *ARG1, *ARG2;
+{
+ fast bigdigit *LIMIT;
if ((LEN(ARG1)) > (LEN(ARG2))) return ONE_BIGGER;
if ((LEN(ARG1)) < (LEN(ARG2))) return TWO_BIGGER;
}
return EQUAL;
}
-\f
-/* (FIX->BIG FIXNUM)
- Returns its argument if FIXNUM isn't a fixnum. Otherwise
- it returns the corresponding bignum.
-*/
-Built_In_Primitive(Prim_Fix_To_Big, 1, "FIX->BIG")
-{ Primitive_1_Arg();
- Arg_1_Type(TC_FIXNUM);
- return Fix_To_Big(Arg1);
-}
-Pointer Fix_To_Big(Arg1)
-Pointer Arg1;
-{ fast bigdigit *Answer, *SCAN, *size;
+/* big_compare() will return either of three cases, determining whether
+ * ARG1 is bigger, smaller, or equal to ARG2.
+ */
+
+Pointer
+big_compare(ARG1, ARG2)
+ bigdigit *ARG1, *ARG2;
+{
+ switch(Categorize_Sign(ARG1, ARG2))
+ { case BOTH_NEGATIVE : return big_compare_unsigned(ARG2, ARG1);
+ case BOTH_POSITIVE : return big_compare_unsigned(ARG1, ARG2);
+ case ARG1_NEGATIVE : return TWO_BIGGER;
+ case ARG2_NEGATIVE : return ONE_BIGGER;
+ default: Sign_Error("big_compare()");
+ }
+ /*NOTREACHED*/
+}
+\f
+Pointer
+Fix_To_Big(Arg1)
+ Pointer Arg1;
+{
+ fast bigdigit *Answer, *SCAN, *size;
long Length, ARG1;
+
if (Type_Code(Arg1) != TC_FIXNUM) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
if (Get_Integer(Arg1) == 0)
{ long Align_0 = Align(0);
Debug_Test(Free-Length);
return Make_Pointer(TC_BIG_FIXNUM, Free-Length);
}
-
-/* (BIG->FIX BIGNUM)
- When given a bignum, returns the equivalent fixnum if there is
- one. If BIGNUM is out of range, or isn't a bignum, returns
- BIGNUM. */
-
-Built_In_Primitive (Prim_Big_To_Fix, 1, "BIG->FIX")
-{
- Primitive_1_Arg ();
-
- Arg_1_Type (TC_BIG_FIXNUM);
- return (Big_To_Fix (Arg1));
-}
\f
Pointer
Big_To_Fix (bignum_object)
bptr = BIGNUM (Get_Pointer (bignum_object));
Length = LEN (bptr);
if (Length == 0)
- return (FIXNUM_0);
+ return (Make_Unsigned_Fixnum(0));
if (Length > FIXNUM_LENGTH_AS_BIGNUM)
return (bignum_object);
: bignum_object);
}
\f
-Boolean Fits_Into_Flonum(Bignum)
-bigdigit *Bignum;
-{ fast int k;
+Boolean
+Fits_Into_Flonum(Bignum)
+ bigdigit *Bignum;
+{
+ fast int k;
quick bigdigit top_digit;
k = (LEN(Bignum) - 1) * SHIFT;
return false;
}
-Pointer Big_To_Float(Arg1)
-Pointer Arg1;
-{ fast bigdigit *ARG1, *LIMIT;
+Pointer
+Big_To_Float(Arg1)
+ Pointer Arg1;
+{
+ fast bigdigit *ARG1, *LIMIT;
fast double F = 0.0;
ARG1 = BIGNUM(Get_Pointer(Arg1));
#include "missing.c"
#endif
-Pointer Float_To_Big(flonum)
-double flonum;
-{ fast double mantissa;
+Pointer
+Float_To_Big(flonum)
+ double flonum;
+{
+ fast double mantissa;
fast bigdigit *Answer, size;
int exponent;
long Align_size;
- if (flonum == 0.0) return return_bignum_zero();
+
+ if (flonum == 0.0)
+ return return_bignum_zero();
mantissa = frexp(flonum, &exponent);
if (flonum < 0) mantissa = -mantissa;
if (mantissa >= 1.0)
Prepare_Header(Answer, size, (flonum < 0) ? NEGATIVE : POSITIVE);
Answer = Bignum_Top(Answer)+1;
while ((size > 0) && (mantissa != 0))
- {
- long temporary;
-
- mantissa = mantissa * ((double) RADIX);
- /* explicit intermediate required by compiler bug. -- cph */
- temporary = ((long) mantissa);
- *--Answer = ((bigdigit) temporary);
- mantissa = mantissa - ((double) *Answer);
- size -= 1;
- }
+ {
+ long temporary;
+
+ mantissa = mantissa * ((double) RADIX);
+ /* explicit intermediate required by compiler bug. -- cph */
+ temporary = ((long) mantissa);
+ *--Answer = ((bigdigit) temporary);
+ mantissa = mantissa - ((double) *Answer);
+ size -= 1;
+ }
while (size-- != 0) *--Answer = (bigdigit) 0;
Free += Align_size;
Debug_Test(Free-Align_size);
return Make_Pointer(TC_BIG_FIXNUM, Free-Align_size);
}
\f
-/* Addition */
-
-plus_signed_bignum(ARG1, ARG2)
-bigdigit *ARG1, *ARG2;
-{ /* Special Case for answer being zero */
- if (ZERO_BIGNUM(ARG1) && ZERO_BIGNUM(ARG2))
- return return_bignum_zero();
- switch(Categorize_Sign(ARG1, ARG2))
- { case BOTH_POSITIVE : return(plus_unsigned_bignum(ARG1, ARG2, POSITIVE));
- case ARG1_NEGATIVE : return(minus_unsigned_bignum(ARG2, ARG1, POSITIVE));
- case ARG2_NEGATIVE : return(minus_unsigned_bignum(ARG1, ARG2, POSITIVE));
- case BOTH_NEGATIVE : return(plus_unsigned_bignum(ARG1, ARG2, NEGATIVE));
- default : Sign_Error("plus_bignum()");
- }
-}
-
-plus_unsigned_bignum(ARG1,ARG2,sign)
-fast bigdigit *ARG1, *ARG2;
-bigdigit sign;
-{ fast unsigned bigdouble Sum;
+Pointer
+plus_unsigned_bignum(ARG1, ARG2, sign)
+ fast bigdigit *ARG1, *ARG2;
+ bigdigit sign;
+{
+ fast unsigned bigdouble Sum;
long Size;
fast bigdigit *Answer;
fast bigdigit *TOP2, *TOP1;
-/* Swap ARG1 and ARG2 so that ARG1 is always longer */
+ /* Swap ARG1 and ARG2 so that ARG1 is always longer */
if (LEN(ARG1) < LEN(ARG2))
- { Answer = ARG1;
+ {
+ Answer = ARG1;
ARG1 = ARG2;
ARG2 = Answer;
}
-/* Allocate Storage and do GC if needed */
+ /* Allocate Storage and do GC if needed */
Size = Align(LEN(ARG1) + 1);
Primitive_GC_If_Needed(Size);
Answer = BIGNUM(Free);
- Prepare_Header(Answer, LEN(ARG1)+1, sign);
-
-/* plus_unsigned_bignum continues on the next page */
-\f
-/* plus_unsigned_bignum, continued */
+ Prepare_Header(Answer, (LEN(ARG1) + 1), sign);
-/* Prepare Scanning Pointers and delimiters */
+ /* Prepare Scanning Pointers and delimiters */
TOP1 = Bignum_Top(ARG1);
TOP2 = Bignum_Top(ARG2);
ARG2 = Bignum_Bottom(ARG2);
Answer = Bignum_Bottom(Answer);
Sum = 0;
-/* Starts Looping */
+\f
+ /* Starts Looping */
+
while (TOP2 >= ARG2)
- { Sum = *ARG1++ + *ARG2++ + Get_Carry(Sum);
+ {
+ Sum = *ARG1++ + *ARG2++ + Get_Carry(Sum);
*Answer++ = Get_Digit(Sum);
}
-/* Let remaining carry propagate */
+
+ /* Let remaining carry propagate */
+
while ((TOP1 >= ARG1) && (Get_Carry(Sum) != 0))
- { Sum = *ARG1++ + 1;
+ {
+ Sum = *ARG1++ + 1;
*Answer++ = Get_Digit(Sum);
}
-/* Copy rest of ARG1 into Answer */
- while (TOP1 >= ARG1) *Answer++ = *ARG1++;
+
+ /* Copy rest of ARG1 into Answer */
+ while (TOP1 >= ARG1)
+ *Answer++ = *ARG1++;
*Answer = Get_Carry(Sum);
-/* Trims Answer. The trim function is not used because there is at
- * most one leading zero.
- */
+
+ /* Trims Answer. The trim function is not used because there is at
+ * most one leading zero.
+ */
+
if (*Answer == 0)
- { Answer = BIGNUM(Free);
+ {
+ Answer = BIGNUM(Free);
LEN(Answer) -= 1;
*((Pointer *) Answer) = Make_Header(Align(LEN(Answer)));
}
return Make_Pointer(TC_BIG_FIXNUM, Free-Size);
}
\f
-/* Subtraction */
-
-minus_signed_bignum(ARG1, ARG2)
-bigdigit *ARG1, *ARG2;
-{ /* Special Case for answer being zero */
- if (ZERO_BIGNUM(ARG1) && ZERO_BIGNUM(ARG2))
- return return_bignum_zero();
-
-/* Dispatches According to Sign of Args */
-
- switch(Categorize_Sign(ARG1, ARG2))
- { case BOTH_POSITIVE : return(minus_unsigned_bignum(ARG1, ARG2, POSITIVE));
- case ARG1_NEGATIVE : return(plus_unsigned_bignum(ARG1, ARG2, NEGATIVE));
- case ARG2_NEGATIVE : return(plus_unsigned_bignum(ARG1, ARG2, POSITIVE));
- case BOTH_NEGATIVE : return(minus_unsigned_bignum(ARG2, ARG1, POSITIVE));
- default : Sign_Error("minus_bignum()");
- }
-}
-
+Pointer
minus_unsigned_bignum(ARG1, ARG2, sign)
-fast bigdigit *ARG1, *ARG2;
-bigdigit sign;
-{ fast bigdouble Diff;
+ fast bigdigit *ARG1, *ARG2;
+ bigdigit sign;
+{
+ fast bigdouble Diff;
fast bigdigit *Answer, *TOP2, *TOP1;
long Size;
if (big_compare_unsigned(ARG1, ARG2) == TWO_BIGGER)
- { Answer = ARG1;
+ {
+ Answer = ARG1;
ARG1 = ARG2;
ARG2 = Answer;
sign = !sign;
Answer = BIGNUM(Free);
Prepare_Header(Answer, LEN(ARG1), sign);
-/* minus_unsigned_bignum continues on the next page */
-\f
-/* minus_unsigned_bignum, continued */
-
TOP1 = Bignum_Top(ARG1);
TOP2 = Bignum_Top(ARG2);
ARG1 = Bignum_Bottom(ARG1);
Answer = Bignum_Bottom(Answer);
Diff = RADIX;
-/* Main Loops for minus_unsigned_bignum */
+ /* Main loops for minus_unsigned_bignum */
while (TOP2 >= ARG2)
- { Diff = *ARG1++ + (MAX_DIGIT_SIZE - *ARG2++) + Get_Carry(Diff);
+ {
+ Diff = *ARG1++ + (MAX_DIGIT_SIZE - *ARG2++) + Get_Carry(Diff);
*Answer++ = Get_Digit(Diff);
}
+
while ((TOP1 >= ARG1) && (Get_Carry(Diff) == 0))
- { Diff = *ARG1++ + MAX_DIGIT_SIZE;
+ {
+ Diff = *ARG1++ + MAX_DIGIT_SIZE;
*Answer++ = Get_Digit(Diff);
}
- while (TOP1 >= ARG1) *Answer++ = *ARG1++;
+
+ while (TOP1 >= ARG1)
+ *Answer++ = *ARG1++;
trim_bignum((bigdigit *) Free);
Free += Size;
return Make_Pointer(TC_BIG_FIXNUM, Free-Size);
}
\f
-/* Multiplication */
+/* Addition */
-multiply_signed_bignum(ARG1, ARG2)
-bigdigit *ARG1, *ARG2;
-{ if (ZERO_BIGNUM(ARG1) || ZERO_BIGNUM(ARG2))
+Pointer
+plus_signed_bignum(ARG1, ARG2)
+ bigdigit *ARG1, *ARG2;
+{ /* Special Case for answer being zero */
+ if (ZERO_BIGNUM(ARG1) && ZERO_BIGNUM(ARG2))
+ return return_bignum_zero();
+ switch(Categorize_Sign(ARG1, ARG2))
+ { case BOTH_POSITIVE : return(plus_unsigned_bignum(ARG1, ARG2, POSITIVE));
+ case ARG1_NEGATIVE : return(minus_unsigned_bignum(ARG2, ARG1, POSITIVE));
+ case ARG2_NEGATIVE : return(minus_unsigned_bignum(ARG1, ARG2, POSITIVE));
+ case BOTH_NEGATIVE : return(plus_unsigned_bignum(ARG1, ARG2, NEGATIVE));
+ default : Sign_Error("plus_bignum()");
+ }
+ /*NOTREACHED*/
+}
+
+/* Subtraction */
+
+Pointer
+minus_signed_bignum(ARG1, ARG2)
+ bigdigit *ARG1, *ARG2;
+{
+ /* Special Case for answer being zero */
+
+ if (ZERO_BIGNUM(ARG1) && ZERO_BIGNUM(ARG2))
return return_bignum_zero();
- switch(Categorize_Sign(ARG1,ARG2))
- { case BOTH_POSITIVE :
- case BOTH_NEGATIVE :
- return multiply_unsigned_bignum(ARG1, ARG2, POSITIVE);
- case ARG1_NEGATIVE :
- case ARG2_NEGATIVE :
- return multiply_unsigned_bignum(ARG1, ARG2, NEGATIVE);
- default : Sign_Error("multiply_bignum()");
+ /* Dispatches According to Sign of Args */
+
+ switch(Categorize_Sign(ARG1, ARG2))
+ { case BOTH_POSITIVE : return(minus_unsigned_bignum(ARG1, ARG2, POSITIVE));
+ case ARG1_NEGATIVE : return(plus_unsigned_bignum(ARG1, ARG2, NEGATIVE));
+ case ARG2_NEGATIVE : return(plus_unsigned_bignum(ARG1, ARG2, POSITIVE));
+ case BOTH_NEGATIVE : return(minus_unsigned_bignum(ARG2, ARG1, POSITIVE));
+ default : Sign_Error("minus_bignum()");
}
+ /*NOTREACHED*/
}
+\f
+/* Multiplication */
+Pointer
multiply_unsigned_bignum(ARG1, ARG2, sign)
-fast bigdigit *ARG1, *ARG2;
-bigdigit sign;
-{ bigdigit *TOP1, *TOP2;
+ fast bigdigit *ARG1, *ARG2;
+ bigdigit sign;
+{
+ bigdigit *TOP1, *TOP2;
fast bigdigit *Answer;
fast bigdouble Prod;
fast int size;
Prepare_Header(Answer, Prod, sign);
TOP1 = Bignum_Top(Answer);
TOP2 = Bignum_Bottom(Answer);
- while (TOP1 >= TOP2) *TOP2++ = 0;
+ while (TOP1 >= TOP2)
+ *TOP2++ = 0;
-/* multiply_unsigned_bignum continues */
-\f
-/* Main Loops for MULTIPLY */
+ /* Main loops for MULTIPLY */
size = LEN(ARG2);
Answer = Bignum_Bottom(Answer) + size;
TOP1 = Bignum_Top(ARG1);
TOP2 = Bignum_Top(ARG2);
ARG2 = TOP2;
-
+\f
for (ARG1 = Bignum_Bottom(ARG1); TOP1 >= ARG1; ARG1++, Answer++)
- { if (*ARG1 != 0)
- { Prod = 0;
- Answer -= size;
+ {
+ if (*ARG1 != 0)
+ {
+ Prod = 0;
+ Answer -= size;
for (ARG2 = TOP2 - size + 1; TOP2 >= ARG2; ++ARG2)
- { Prod = *ARG1 * *ARG2 + *Answer + Get_Carry(Prod);
+ {
+ Prod = *ARG1 * *ARG2 + *Answer + Get_Carry(Prod);
*Answer++ = Get_Digit(Prod);
}
*Answer = Get_Carry(Prod);
}
}
-/* Trims Answer */
+ /* Trims Answer */
+
Answer = BIGNUM(Free);
if (*(Bignum_Top(Answer)) == 0)
- { LEN(Answer) -= 1;
+ {
+ LEN(Answer) -= 1;
*((Pointer *) Answer) = Make_Header(Align(LEN(Answer)));
}
Free += Size;
return Make_Pointer(TC_BIG_FIXNUM, Free-Size);
}
+
+Pointer
+multiply_signed_bignum(ARG1, ARG2)
+ bigdigit *ARG1, *ARG2;
+{
+ if (ZERO_BIGNUM(ARG1) || ZERO_BIGNUM(ARG2))
+ return return_bignum_zero();
+
+ switch(Categorize_Sign(ARG1,ARG2))
+ { case BOTH_POSITIVE :
+ case BOTH_NEGATIVE :
+ return multiply_unsigned_bignum(ARG1, ARG2, POSITIVE);
+ case ARG1_NEGATIVE :
+ case ARG2_NEGATIVE :
+ return multiply_unsigned_bignum(ARG1, ARG2, NEGATIVE);
+ default : Sign_Error("multiply_bignum()");
+ }
+ /*NOTREACHED*/
+}
\f
-/* (DIVIDE-BIGNUM ONE-BIGNUM ANOTHER_BIGNUM)
- * returns a cons of the bignum quotient and remainder of both arguments.
+/* This is the guts of the division algorithm. The storage
+ * allocation and other hairy prep work is done in the superior
+ * routines. ARG1 and ARG2 are fresh copies, ARG1 will
+ * ultimately become the Remainder. Storage already
+ * allocated for all four parameters.
*/
-Built_In_Primitive(Prim_Divide_Bignum, 2, "DIVIDE-BIGNUM")
-{ Pointer Result, *End_Of_First, *First, *Second, *Orig_Free=Free;
- Primitive_2_Args();
- Arg_1_Type(TC_BIG_FIXNUM);
- Arg_2_Type(TC_BIG_FIXNUM);
- Set_Time_Zone(Zone_Math);
- Result = div_signed_bignum(BIGNUM(Get_Pointer(Arg1)),
- BIGNUM(Get_Pointer(Arg2)));
- if (Bignum_Debug)
- printf("\nResult=0x%x [%x %x]\n",
- Result, Fast_Vector_Ref(Result, 0), Fast_Vector_Ref(Result, 1));
- First = Get_Pointer(Fast_Vector_Ref(Result, CONS_CAR));
- Second = Get_Pointer(Fast_Vector_Ref(Result, CONS_CDR));
- if (Bignum_Debug)
- printf("\nFirst=0x%x [%x %x]; Second=0x%x [%x %x]\n",
- First, First[0], First[1], Second, Second[0], Second[1]);
- if (Consistency_Check)
- { if (First > Second)
- { printf("\nBignum_Divide: results swapped.\n");
- Microcode_Termination(TERM_EXIT);
- }
- else if (First != Orig_Free+2)
- { printf("\nBignum Divide: hole at start\n");
- Microcode_Termination(TERM_EXIT);
- }
- }
- End_Of_First = First+1+Get_Integer(First[0]);
- if (Bignum_Debug) printf("\nEnd_Of_First=0x%x\n", End_Of_First);
- if (End_Of_First != Second)
- { *End_Of_First =
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Second-End_Of_First)-1);
- if (Bignum_Debug) printf("\nGap=0x%x\n", (Second-End_Of_First)-1);
+static Pointer BIG_A[TEMP_SIZE], BIG_B[TEMP_SIZE];
+
+Pointer
+div_internal(ARG1, ARG2, Quotient)
+ bigdigit *ARG1, *ARG2, *Quotient;
+{
+ fast bigdigit *SCAN,*PROD;
+ fast bigdouble Digit, Prod;
+ fast bigdouble guess, dvsr2, dvsr1;
+ fast bigdigit *LIMIT, *QUOT_SCAN;
+ bigdigit *Big_A, *Big_B;
+
+ Big_A = BIGNUM(BIG_A);
+ Big_B = BIGNUM(BIG_B);
+ SCAN = Bignum_Top(ARG2);
+ if (*SCAN == 0)
+ { LEN(ARG2) -= 1;
+ SCAN -= 1;
}
- Free = Second+1+Get_Integer(Second[0]);
- if (Bignum_Debug) printf("\nEnd=0x%x\n", Free);
- return Result;
+ dvsr1 = *SCAN--;
+ dvsr2 = *SCAN;
+
+ Prepare_Header(Quotient, (LEN(ARG1)-LEN(ARG2)), POSITIVE);
+
+ QUOT_SCAN = Bignum_Top(Quotient);
+ ARG1 = Bignum_Top(ARG1);
+ SCAN = ARG1 - LEN(ARG2);
+ Quotient = Bignum_Bottom(Quotient);
+\f
+ /* Main Loop for div_internal() */
+
+ while (QUOT_SCAN >= Quotient)
+ {
+ if (dvsr1 <= *ARG1) guess = RADIX - 1;
+ else
+ { /* This should be
+ * guess = (Mul_Radix(*ARG1) + *(ARG1 - 1)) / dvsr1;
+ * but because of overflow problems ...
+ */
+
+ Prepare_Header(Big_A, 2, POSITIVE);
+ *Bignum_Top(Big_A) = *ARG1;
+ *Bignum_Bottom(Big_A) = *(ARG1-1);
+ unscale(Big_A, Big_A, dvsr1);
+ guess = *Bignum_Bottom(Big_A);
+ }
+ guess += 1; /* To counter first decrementing below. */
+ do
+ {
+ guess -= 1;
+ Prepare_Header(Big_A, 3, POSITIVE);
+ LIMIT = Bignum_Top(Big_A);
+ *LIMIT-- = *ARG1;
+ *LIMIT-- = *(ARG1-1);
+ *LIMIT = *(ARG1-2);
+ Prepare_Header(Big_B, 2, POSITIVE);
+ *Bignum_Top(Big_B) = dvsr1;
+ *Bignum_Bottom(Big_B) = dvsr2;
+ scale(Big_B, Big_B, guess);
+ if ((*Bignum_Top(Big_B)) == 0) LEN(Big_B) -= 1;
+ } while (big_compare_unsigned(Big_B, Big_A) == ONE_BIGGER);
+\f
+ LIMIT = Bignum_Top(ARG2);
+ PROD = Bignum_Bottom(ARG2);
+ Digit = RADIX + *SCAN;
+ while (LIMIT >= PROD)
+ {
+ Prod = *PROD++ * guess;
+ Digit = Digit - Get_Digit(Prod);
+ *SCAN++ = Get_Digit(Digit);
+ Digit = ((*SCAN - Get_Carry(Prod)) +
+ (MAX_DIGIT_SIZE +
+ ((Digit < 0) ? -1 : Get_Carry(Digit))));
+ }
+ *SCAN++ = Get_Digit(Digit);
+
+ if (Get_Carry(Digit) == 0)
+ {
+ /* Guess is one too big, add back. */
+
+ Digit = 0;
+ guess -= 1;
+ LIMIT = Bignum_Top(ARG2);
+ SCAN = SCAN - LEN(ARG2);
+ PROD = Bignum_Bottom(ARG2);
+ while (LIMIT >= PROD)
+ {
+ Digit = *SCAN + *PROD++ + Get_Carry(Digit);
+ *SCAN++ = Get_Digit(Digit);
+ }
+ *SCAN = 0;
+ }
+ *QUOT_SCAN-- = guess;
+ ARG1 -= 1;
+ SCAN = ARG1 - LEN(ARG2);
+ }
}
\f
/* div_signed_bignum() differentiates between all the possible
* any intrmediate storage needed.
*/
+Pointer
div_signed_bignum(ARG1, ARG2)
-bigdigit *ARG1, *ARG2;
-{ bigdigit *SARG2;
+ bigdigit *ARG1, *ARG2;
+{
+ bigdigit *SARG2;
bigdigit *QUOT, *REMD;
Pointer *Cons_Cell;
- if ZERO_BIGNUM(ARG2) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ if (ZERO_BIGNUM(ARG2))
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
Primitive_GC_If_Needed(2);
Cons_Cell = Free;
Free += 2;
if (big_compare_unsigned(ARG1, ARG2) == TWO_BIGGER)
-/* Trivial Solution for ARG1 > ARG2
- * Quotient is zero and the remainder is just a copy of Arg_1.
- */
- { Primitive_GC_If_Needed(Align(0)+Align(LEN(ARG1)));
+ {
+ /* Trivial Solution for ARG1 > ARG2
+ * Quotient is zero and the remainder is just a copy of Arg_1.
+ */
+
+ Primitive_GC_If_Needed(Align(0)+Align(LEN(ARG1)));
QUOT = BIGNUM(Free);
Free += Align(0);
Prepare_Header(QUOT, 0, POSITIVE);
copy_bignum(ARG1, REMD);
}
else if (LEN(ARG2)==1)
- /* Divisor is only one digit long.
- * unscale() is used to divide out Arg_1 and the remainder is the
- * single digit returned by unscale(), coerced to a bignum.
- */
- { Primitive_GC_If_Needed(Align(LEN(ARG1))+Align(1));
+ {
+ /* Divisor is only one digit long.
+ * unscale() is used to divide out Arg_1 and the remainder is the
+ * single digit returned by unscale(), coerced to a bignum.
+ */
+
+ Primitive_GC_If_Needed(Align(LEN(ARG1))+Align(1));
QUOT = BIGNUM(Free);
Free += Align(LEN(ARG1));
REMD = BIGNUM(Free);
}
else
\f
-/* Usual case. div_internal() is called. A normalized copy of Arg_1
- * resides in REMD, which ultimately becomes the remainder. The
- * normalized copy of Arg_2 is in SARG2.
- */
- { bigdouble temp;
+ {
+ /* Usual case. div_internal() is called. A normalized copy of Arg_1
+ * resides in REMD, which ultimately becomes the remainder. The
+ * normalized copy of Arg_2 is in SARG2.
+ */
+
+ bigdouble temp;
+
temp = (Align(LEN(ARG1)-LEN(ARG2)+1) + Align(LEN(ARG1)+1)
+ Align(LEN(ARG2)+1));
Primitive_GC_If_Needed(temp);
break;
case BOTH_POSITIVE : break;
default : Sign_Error("divide_bignum()");
- } /* Glue the two results in a list and return as answer */
+ }
+ /* Glue the two results in a list and return as answer */
Cons_Cell[CONS_CAR] = Make_Pointer(TC_BIG_FIXNUM, (Pointer *) QUOT);
Cons_Cell[CONS_CDR] = Make_Pointer(TC_BIG_FIXNUM, (Pointer *) REMD);
return Make_Pointer(TC_LIST, Cons_Cell);
\f
/* Utility for debugging */
+#ifdef ENABLE_DEBUGGING_TOOLS
+void
print_digits(name, num, how_many)
-char *name;
-bigdigit *num;
-int how_many;
-{ int NDigits = LEN(num);
+ char *name;
+ bigdigit *num;
+ int how_many;
+{
+ int NDigits = LEN(num);
int limit;
+
printf("\n%s = 0x%08x", name, num);
printf("\n Sign: %c, Vector length: %d, # Digits: %d",
((SIGN(num) == NEGATIVE) ? '-' :
((SIGN(num) == POSITIVE) ? '+' : '?')),
Datum(((Pointer *) num)[VECTOR_LENGTH]),
NDigits);
- if (how_many == -1) limit = NDigits;
- else limit = ((how_many < NDigits) ? how_many : NDigits);
+ if (how_many == -1)
+ limit = NDigits;
+ else
+ limit = ((how_many < NDigits) ? how_many : NDigits);
num = Bignum_Bottom(num);
- while (--how_many >= 0) printf("\n 0x%04x", *num++);
- if (limit < NDigits) printf("\n ...");
+ while (--how_many >= 0)
+ printf("\n 0x%04x", *num++);
+ if (limit < NDigits)
+ printf("\n ...");
printf("\n");
return;
}
+#endif
\f
-/* This is the guts of the division algorithm. The storage
- * allocation and other hairy prep work is done in the superior
- * routines. ARG1 and ARG2 are fresh copies, ARG1 will
- * ultimately become the Remainder. Storage already
- * allocated for all four parameters.
- */
-
-static Pointer BIG_A[TEMP_SIZE], BIG_B[TEMP_SIZE];
-
-div_internal(ARG1, ARG2, Quotient)
-bigdigit *ARG1, *ARG2, *Quotient;
-{ fast bigdigit *SCAN,*PROD;
- fast bigdouble Digit, Prod;
- fast bigdouble guess, dvsr2, dvsr1;
- fast bigdigit *LIMIT, *QUOT_SCAN;
- bigdigit *Big_A = BIGNUM(BIG_A);
- bigdigit *Big_B = BIGNUM(BIG_B);
-
- SCAN = Bignum_Top(ARG2);
- if (*SCAN == 0)
- { LEN(ARG2) -= 1;
- SCAN -= 1;
- }
- dvsr1 = *SCAN--;
- dvsr2 = *SCAN;
-
- Prepare_Header(Quotient, (LEN(ARG1)-LEN(ARG2)), POSITIVE);
-
- QUOT_SCAN = Bignum_Top(Quotient);
- ARG1 = Bignum_Top(ARG1);
- SCAN = ARG1 - LEN(ARG2);
- Quotient = Bignum_Bottom(Quotient);
-
-/* div_internal() continues */
-\f
-/* Main Loop for div_internal() */
+/* Top level bignum primitives */
+/* Coercion primitives. */
- while (QUOT_SCAN >= Quotient)
- { if (dvsr1 <= *ARG1) guess = RADIX - 1;
- else
- { /* This should be
- * guess = (Mul_Radix(*ARG1) + *(ARG1 - 1)) / dvsr1;
- * but because of overflow problems ...
- */
+/* (COERCE-FIXNUM-TO-BIGNUM FIXNUM)
+ Returns its argument if FIXNUM isn't a fixnum. Otherwise
+ it returns the corresponding bignum.
+*/
+Built_In_Primitive(Prim_Fix_To_Big, 1, "COERCE-FIXNUM-TO-BIGNUM", 0x67)
+{
+ Primitive_1_Arg();
- Prepare_Header(Big_A, 2, POSITIVE);
- *Bignum_Top(Big_A) = *ARG1;
- *Bignum_Bottom(Big_A) = *(ARG1-1);
- unscale(Big_A, Big_A, dvsr1);
- guess = *Bignum_Bottom(Big_A);
- }
- guess += 1; /* To counter first decrementing below. */
- do
- { guess -= 1;
- Prepare_Header(Big_A, 3, POSITIVE);
- LIMIT = Bignum_Top(Big_A);
- *LIMIT-- = *ARG1;
- *LIMIT-- = *(ARG1-1);
- *LIMIT = *(ARG1-2);
- Prepare_Header(Big_B, 2, POSITIVE);
- *Bignum_Top(Big_B) = dvsr1;
- *Bignum_Bottom(Big_B) = dvsr2;
- scale(Big_B, Big_B, guess);
- if ((*Bignum_Top(Big_B)) == 0) LEN(Big_B) -= 1;
- } while (big_compare_unsigned(Big_B, Big_A) == ONE_BIGGER);
+ Arg_1_Type(TC_FIXNUM);
+ return Fix_To_Big(Arg1);
+}
-/* div_internal() continues */
-\f
-/* div_internal() continued */
+/* (COERCE-BIGNUM-TO-FIXNUM BIGNUM)
+ When given a bignum, returns the equivalent fixnum if there is
+ one. If BIGNUM is out of range, or isn't a bignum, returns
+ BIGNUM. */
- LIMIT = Bignum_Top(ARG2);
- PROD = Bignum_Bottom(ARG2);
- Digit = RADIX + *SCAN;
- while (LIMIT >= PROD)
- { Prod = *PROD++ * guess;
- Digit = Digit - Get_Digit(Prod);
- *SCAN++ = Get_Digit(Digit);
- Digit = ((*SCAN - Get_Carry(Prod)) +
- (MAX_DIGIT_SIZE +
- ((Digit < 0) ? -1 : Get_Carry(Digit))));
- }
- *SCAN++ = Get_Digit(Digit);
+Built_In_Primitive (Prim_Big_To_Fix, 1, "COERCE-BIGNUM-TO-FIXNUM", 0x68)
+{
+ Primitive_1_Arg ();
- if (Get_Carry(Digit) == 0)
- /* Guess is one too big, add back. */
- { Digit = 0;
- guess -= 1;
- LIMIT = Bignum_Top(ARG2);
- SCAN = SCAN - LEN(ARG2);
- PROD = Bignum_Bottom(ARG2);
- while (LIMIT >= PROD)
- { Digit = *SCAN + *PROD++ + Get_Carry(Digit);
- *SCAN++ = Get_Digit(Digit);
- }
- *SCAN = 0;
- }
- *QUOT_SCAN-- = guess;
- ARG1 -= 1;
- SCAN = ARG1 - LEN(ARG2);
- }
+ Arg_1_Type (TC_BIG_FIXNUM);
+ return (Big_To_Fix (Arg1));
}
\f
/* (LISTIFY-BIGNUM BIGNUM RADIX)
Returns a list of numbers, in the range 0 through RADIX-1, which
represent the BIGNUM in that radix.
*/
-Built_In_Primitive(Prim_Listify_Bignum, 2, "LISTIFY-BIGNUM")
-{ fast bigdigit *TOP1, *size;
+Built_In_Primitive(Prim_Listify_Bignum, 2, "LISTIFY-BIGNUM", 0x50)
+{
+ fast bigdigit *TOP1, *size;
quick Pointer *RFree;
fast bigdigit *ARG1;
fast long pradix;
ARG1 = BIGNUM(Get_Pointer(Arg1));
size = &LEN(ARG1);
if (*size == 0)
- { Primitive_GC_If_Needed(2);
- *Free++ = FIXNUM_0;
+ {
+ Primitive_GC_If_Needed(2);
+ *Free++ = Make_Unsigned_Fixnum(0);
*Free++ = NIL;
return Make_Pointer(TC_LIST, Free-2);
}
size = &LEN(ARG1);
TOP1 = Bignum_Top(ARG1);
while (*size > 0)
- { *RFree++ = FIXNUM_0+unscale(ARG1, ARG1, pradix);
+ {
+ *RFree++ = Make_Unsigned_Fixnum(unscale(ARG1, ARG1, pradix));
*RFree = Make_Pointer(TC_LIST, RFree-3);
RFree += 1;
if (*TOP1 == 0)
- { *size -= 1;
+ {
+ *size -= 1;
TOP1--;
}
}
return Make_Pointer(TC_LIST, RFree-2);
}
\f
-/* General Purpose Utilities */
-
-return_bignum_zero()
-{ bigdigit *REG;
- long Align_0 = Align(0);
- Primitive_GC_If_Needed(Align_0);
- REG = BIGNUM(Free);
- Prepare_Header(REG, 0, POSITIVE);
- Free += Align_0;
- return Make_Pointer(TC_BIG_FIXNUM, Free-Align_0);
-}
-
-trim_bignum(ARG)
-bigdigit *ARG;
-{ fast bigdigit *SCAN;
- fast bigdigit size;
- bigdigit sign;
-
- sign = SIGN(ARG);
- size = LEN(ARG);
-
- for (SCAN=Bignum_Top(ARG); ((size!=0)&&(*SCAN==0)); SCAN--)
- size -= 1;
-
- if (size == 0) sign = POSITIVE;
- Prepare_Header(ARG, size, sign);
-}
-
-copy_bignum(SOURCE, TARGET)
-fast bigdigit *SOURCE, *TARGET;
-{ fast bigdigit *LIMIT = Bignum_Top(SOURCE);
- while (LIMIT >= SOURCE) *TARGET++ = *SOURCE++;
-}
-
-Find_Length(pradix, length)
-fast long pradix;
-bigdigit length;
-{ fast int log_pradix = 0;
- while (pradix != 1)
- { pradix = pradix >> 1;
- log_pradix += 1;
- }
- return(((SHIFT / log_pradix) + 1) * length);
-}
-\f
-/* scale() and unscale() used by Division and Listify */
-
-scale(SOURCE, DEST, how_much)
-fast bigdigit *SOURCE, *DEST;
-fast long how_much;
-{ fast unsigned bigdouble prod = 0;
- bigdigit *LIMIT;
-
- if (how_much == 1)
- { if (SOURCE != DEST) copy_bignum(SOURCE, DEST);
- Prepare_Header(DEST, LEN(SOURCE)+1, SIGN(SOURCE));
- *Bignum_Top(DEST) = 0;
- return;
- }
- /* This must happen before the Prepare_Header if DEST = SOURCE */
- LIMIT = Bignum_Top(SOURCE);
- Prepare_Header(DEST, LEN(SOURCE)+1, SIGN(SOURCE));
- SOURCE = Bignum_Bottom(SOURCE);
- DEST = Bignum_Bottom(DEST);
- while (LIMIT >= SOURCE)
- { prod = *SOURCE++ * how_much + Get_Carry(prod);
- *DEST++ = Get_Digit(prod);
- }
- *DEST = Get_Carry(prod);
-}
-
-unscale(SOURCE, DEST, how_much)
-bigdigit *SOURCE;
-fast bigdigit *DEST;
-fast long how_much;
-{ bigdigit carry = 0;
- fast unsigned bigdouble digits;
- fast bigdigit *SCAN;
-
- if (how_much == 1)
- { if (SOURCE != DEST) copy_bignum(SOURCE, DEST);
- return 0;
- }
- Prepare_Header(DEST, LEN(SOURCE), SIGN(DEST));
- SCAN = Bignum_Top(SOURCE);
- DEST = Bignum_Top(DEST);
- SOURCE = Bignum_Bottom(SOURCE);
- while (SCAN >= SOURCE)
- { fast unsigned bigdouble digits, temp; /* Bug fix by JMiller */
- digits = Mul_Radix(carry) + *SCAN--;
- temp = digits / how_much;
- *DEST-- = temp;
- temp = temp * how_much;
- carry = digits - temp;
- }
- return carry; /* returns remainder */
-}
-\f
-/* Top level bignum primitives */
-
-/* All the binary bignum primtives take two arguments and return NIL
+/* All the binary bignum primitives take two arguments and return NIL
if either of them is not a bignum. If both arguments are bignums,
the perform the operation and return the answer.
*/
-#define Binary_Primitive(C_Name, S_Name, Op) \
-Built_In_Primitive(C_Name, 2, S_Name) \
-{ Pointer Result, *Orig_Free=Free; \
+#define Binary_Primitive(Op) \
+{ \
+ Pointer Result, *Orig_Free; \
Primitive_2_Args(); \
- Arg_1_Type(TC_BIG_FIXNUM); \
- Arg_2_Type(TC_BIG_FIXNUM); \
+ \
+ Arg_1_Type(TC_BIG_FIXNUM); \
+ Arg_2_Type(TC_BIG_FIXNUM); \
Set_Time_Zone(Zone_Math); \
+ Orig_Free = Free; \
Result = Op(BIGNUM(Get_Pointer(Arg1)), BIGNUM(Get_Pointer(Arg2))); \
if (Consistency_Check && (Get_Pointer(Result) != Orig_Free)) \
- { printf("\nBignum operation result at 0x%x, Free was 0x%x\n", \
+ { \
+ fprintf(stderr, "\nBignum operation result at 0x%x, Free was 0x%x\n", \
Address(Result), Free); \
Microcode_Termination(TERM_EXIT); \
} \
Free = Nth_Vector_Loc(Result, Vector_Length(Result)+1); \
- if (Consistency_Check && (Free > Heap_Top)) \
- { printf("\nBignum operation result at 0x%x, length 0x%x\n", \
+ if (Consistency_Check && (Free > Heap_Top)) \
+ { \
+ fprintf(stderr, "\nBignum operation result at 0x%x, length 0x%x\n", \
Address(Result), Vector_Length(Result)); \
Microcode_Termination(TERM_EXIT); \
} \
return Result; \
}
-Binary_Primitive(Prim_Plus_Bignum, "PLUS-BIGNUM", plus_signed_bignum);
-Binary_Primitive(Prim_Minus_Bignum, "MINUS-BIGNUM", minus_signed_bignum);
-Binary_Primitive(Prim_Multiply_Bignum,
- "TIMES-BIGNUM",
- multiply_signed_bignum);
+Built_In_Primitive(Prim_Plus_Bignum, 2, "PLUS-BIGNUM", 0x4C)
+Binary_Primitive(plus_signed_bignum)
+
+Built_In_Primitive(Prim_Minus_Bignum, 2, "MINUS-BIGNUM", 0x4D)
+Binary_Primitive(minus_signed_bignum)
+
+Built_In_Primitive(Prim_Multiply_Bignum, 2, "MULTIPLY-BIGNUM", 0x4E)
+Binary_Primitive(multiply_signed_bignum)
+\f
+/* (DIVIDE-BIGNUM ONE-BIGNUM ANOTHER_BIGNUM)
+ * returns a cons of the bignum quotient and remainder of both arguments.
+ */
+
+Built_In_Primitive(Prim_Divide_Bignum, 2, "DIVIDE-BIGNUM", 0x4F)
+{
+ Pointer Result, *End_Of_First, *First, *Second, *Orig_Free=Free;
+ Primitive_2_Args();
+
+ Arg_1_Type(TC_BIG_FIXNUM);
+ Arg_2_Type(TC_BIG_FIXNUM);
+ Set_Time_Zone(Zone_Math);
+ Result = div_signed_bignum(BIGNUM(Get_Pointer(Arg1)),
+ BIGNUM(Get_Pointer(Arg2)));
+ if (Bignum_Debug)
+ printf("\nResult=0x%x [%x %x]\n",
+ Result, Fast_Vector_Ref(Result, 0), Fast_Vector_Ref(Result, 1));
+ First = Get_Pointer(Fast_Vector_Ref(Result, CONS_CAR));
+ Second = Get_Pointer(Fast_Vector_Ref(Result, CONS_CDR));
+ if (Bignum_Debug)
+ printf("\nFirst=0x%x [%x %x]; Second=0x%x [%x %x]\n",
+ First, First[0], First[1], Second, Second[0], Second[1]);
+ if (Consistency_Check)
+ { if (First > Second)
+ {
+ fprintf(stderr, "\nBignum_Divide: results swapped.\n");
+ Microcode_Termination(TERM_EXIT);
+ }
+ else if (First != Orig_Free+2)
+ {
+ fprintf(stderr, "\nBignum Divide: hole at start\n");
+ Microcode_Termination(TERM_EXIT);
+ }
+ }
+ End_Of_First = First + 1 + Get_Integer(First[0]);
+ if (Bignum_Debug)
+ printf("\nEnd_Of_First=0x%x\n", End_Of_First);
+ if (End_Of_First != Second)
+ {
+ *End_Of_First =
+ Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Second-End_Of_First)-1);
+ if (Bignum_Debug)
+ printf("\nGap=0x%x\n", (Second-End_Of_First)-1);
+ }
+ Free = Second + 1 + Get_Integer(Second[0]);
+ if (Bignum_Debug)
+ printf("\nEnd=0x%x\n", Free);
+ return Result;
+}
\f
/* All the unary bignum predicates take one argument and return NIL if
it is not a bignum. Otherwise, they return a fixnum 1 if the
dispatch can detect "inapplicable" as distinct from "false" answer.
*/
-#define Unary_Predicate(C_Name, S_Name, Test) \
-Built_In_Primitive(C_Name, 1, S_Name) \
-{ bigdigit *ARG; \
+#define Unary_Predicate(Test) \
+{ \
+ bigdigit *ARG; \
Primitive_1_Arg(); \
- Arg_1_Type(TC_BIG_FIXNUM); \
+ \
+ Arg_1_Type(TC_BIG_FIXNUM); \
Set_Time_Zone(Zone_Math); \
ARG = BIGNUM(Get_Pointer(Arg1)); \
- return FIXNUM_0 + ((Test) ? 1 : 0); \
+ return Make_Unsigned_Fixnum(((Test) ? 1 : 0)); \
}
-Unary_Predicate(Prim_Zero_Bignum, "ZERO-BIGNUM?", LEN(ARG)==0)
-Unary_Predicate(Prim_Positive_Bignum,
- "POSITIVE-BIGNUM?",
- (LEN(ARG) != 0) && POS_BIGNUM(ARG))
-Unary_Predicate(Prim_Negative_Bignum,
- "NEGATIVE-BIGNUM?",
- (LEN(ARG) != 0) && NEG_BIGNUM(ARG))
+Built_In_Primitive(Prim_Zero_Bignum, 1, "ZERO-BIGNUM?", 0x6F)
+Unary_Predicate(LEN(ARG) == 0)
+
+Built_In_Primitive(Prim_Positive_Bignum, 1, "POSITIVE-BIGNUM?", 0x53)
+Unary_Predicate((LEN(ARG) != 0) && POS_BIGNUM(ARG))
+
+Built_In_Primitive(Prim_Negative_Bignum, 1, "NEGATIVE-BIGNUM?", 0x80)
+Unary_Predicate((LEN(ARG) != 0) && NEG_BIGNUM(ARG))
/* All the binary bignum predicates take two arguments and return NIL
if either of them is not a bignum. Otherwise, they return an
answer as described above for the unary predicates.
*/
-
-#define Binary_Predicate(C_Name, S_Name, Code) \
-Built_In_Primitive(C_Name, 2, S_Name) \
-{ Primitive_2_Args(); \
- Arg_1_Type(TC_BIG_FIXNUM); \
- Arg_2_Type(TC_BIG_FIXNUM); \
+\f
+#define Binary_Predicate(Code) \
+{ \
+ int result; \
+ Primitive_2_Args(); \
+ \
+ Arg_1_Type(TC_BIG_FIXNUM); \
+ Arg_2_Type(TC_BIG_FIXNUM); \
Set_Time_Zone(Zone_Math); \
- return FIXNUM_0 + \
- ((big_compare(BIGNUM(Get_Pointer(Arg1)), \
- BIGNUM(Get_Pointer(Arg2))) == Code) ? 1 : 0); \
+ if (big_compare(BIGNUM(Get_Pointer(Arg1)), \
+ BIGNUM(Get_Pointer(Arg2))) == Code) \
+ result = 1; \
+ else \
+ result = 0; \
+ return Make_Unsigned_Fixnum(result); \
}
-Binary_Predicate(Prim_Equal_Bignum, "EQUAL-BIGNUM?", EQUAL)
-Binary_Predicate(Prim_Greater_Bignum, "GREATER-BIGNUM?", ONE_BIGGER)
-Binary_Predicate(Prim_Less_Bignum, "LESS-BIGNUM?", TWO_BIGGER)
+Built_In_Primitive(Prim_Equal_Bignum, 2, "EQUAL-BIGNUM?", 0x51)
+Binary_Predicate(EQUAL)
+
+Built_In_Primitive(Prim_Greater_Bignum, 2, "GREATER-THAN-BIGNUM?", 0x82)
+Binary_Predicate(ONE_BIGGER)
+
+Built_In_Primitive(Prim_Less_Bignum, 2, "LESS-THAN-BIGNUM?", 0x52)
+Binary_Predicate(TWO_BIGGER)
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.23 1987/04/03 00:05:18 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.24 1987/04/16 02:05:24 jinx Exp $
*
* This File contains the code to translate internal format binary
* files to portable format.
fprintf(Portable_File, s); \
break
+void
print_a_char(c, name)
-fast char c;
-char *name;
-{ switch(c)
+ fast char c;
+ char *name;
+{
+ switch(c)
{ case '\n': OUT("\\n");
case '\t': OUT("\\t");
case '\b': OUT("\\b");
}
\f
#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
+{ \
+ Old_Address += (Rel); \
Old_Contents = *Old_Address; \
if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
Mem_Base[(Scn)] = \
Make_New_Pointer((Code), Old_Contents); \
else \
- { fast long i; \
+ { \
+ fast long i; \
+ \
Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
*Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
(Obj) += 1; \
- *(FObj)++ = STRING_0; \
+ *(FObj)++ = Make_Non_Pointer(TC_STRING, 0); \
*(FObj)++ = Old_Contents; \
i = Get_Integer(Old_Contents); \
NStrings += 1; \
NChars += pointer_to_char(i-1); \
- while(--i >= 0) *(FObj)++ = *Old_Address++; \
+ while(--i >= 0) \
+ *(FObj)++ = *Old_Address++; \
} \
}
+void
print_a_string(from)
-Pointer *from;
+ Pointer *from;
{ fast long len;
fast char *string;
- long maxlen = pointer_to_char((Get_Integer(*from++))-1);
+ long maxlen;
+
+ maxlen = pointer_to_char((Get_Integer(*from++))-1);
len = Get_Integer(*from++);
fprintf(Portable_File, "%02x %ld %ld ",
TC_CHARACTER_STRING,
string = ((char *) from);
if (Shuffle_Bytes)
{ while(len > 0)
- { print_a_char(string[3], "print_a_string");
- if (len > 1) print_a_char(string[2], "print_a_string");
- if (len > 2) print_a_char(string[1], "print_a_string");
- if (len > 3) print_a_char(string[0], "print_a_string");
+ {
+ print_a_char(string[3], "print_a_string");
+ if (len > 1)
+ print_a_char(string[2], "print_a_string");
+ if (len > 2)
+ print_a_char(string[1], "print_a_string");
+ if (len > 3)
+ print_a_char(string[0], "print_a_string");
len -= 4;
string += 4;
}
return;
}
\f
+void
print_a_fixnum(val)
-long val;
-{ fast long size_in_bits;
- fast unsigned long temp = ((val < 0) ? -val : val);
+ long val;
+{
+ fast long size_in_bits;
+ fast unsigned long temp;
+
+ temp = ((val < 0) ? -val : val);
for (size_in_bits = 0; temp != 0; size_in_bits += 1)
temp = temp >> 1;
fprintf(Portable_File, "%02x %c ",
TC_FIXNUM,
(val < 0 ? '-' : '+'));
- if (val == 0) fprintf(Portable_File, "0\n");
+ if (val == 0)
+ fprintf(Portable_File, "0\n");
else
- { fprintf(Portable_File, "%ld ", size_in_bits);
+ {
+ fprintf(Portable_File, "%ld ", size_in_bits);
temp = ((val < 0) ? -val : val);
while (temp != 0)
{ fprintf(Portable_File, "%01lx", (temp % 16));
} \
}
+void
print_a_bignum(from)
-Pointer *from;
-{ fast bigdigit *the_number, *the_top;
+ Pointer *from;
+{
+ fast bigdigit *the_number, *the_top;
fast long size_in_bits;
fast unsigned long temp; /* Potential signed problems */
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.h,v 9.22 1987/04/03 00:08:07 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.h,v 9.23 1987/04/16 02:08:44 jinx Rel $
*
* This file contains breakpoint utilities.
* Disabled when not debugging the interpreter.
typedef struct sp_record *sp_record_list;
#define sp_nil ((sp_record_list) NULL)
-#define debug_maxslots 64
+#define debug_maxslots 100
#define Eval_Ucode_Hook() \
{ \
void Clear_Perfinfo_Data()
{ int i;
- perfinfo_data.nprims = MAX_PRIMITIVE_NUMBER+1;
- for (i=0; i <= MAX_PRIMITIVE_NUMBER; i++) perfinfo_data.primtime[i]=0;
+ perfinfo_data.nprims = MAX_PRIMITIVE + 1;
+ for (i = 0; i <= MAX_PRIMITIVE; i++)
+ perfinfo_data.primtime[i] = 0;
}
#define Metering_Apply_Primitive(Loc, N) \
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.29 1987/04/03 00:08:22 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.30 1987/04/16 02:08:53 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
\f
#include "scheme.h"
#include "primitive.h"
-#include "prims.h"
#include "version.h"
#include "character.h"
#ifndef islower
blocks(Constant_Size));
/* We are reloading from scratch anyway. */
Was_Scheme_Dumped = false;
- Start_Scheme(FASL_It ? PC_FASLOAD : PC_BAND_LOAD, File_Name);
+ Start_Scheme((FASL_It ? BOOT_FASLOAD : BOOT_LOAD_BAND), File_Name);
}
}
if (File_Name == NULL) File_Name = DEFAULT_BAND_NAME;
Setup_Memory(blocks(Heap_Size), blocks(Stack_Size),
blocks(Constant_Size));
compiler_initialize((long) FASL_It);
- Start_Scheme(FASL_It ? PC_FASLOAD : PC_BAND_LOAD, File_Name);
+ Start_Scheme((FASL_It ? BOOT_FASLOAD : BOOT_LOAD_BAND), File_Name);
}
\f
#define Default_Init_Fixed_Objects(Fixed_Objects) \
/* Non Object */ \
Bad_Object = Make_Pointer(TC_LIST, Free); \
*Free++ = NIL; \
- *Free++ = NIL; \
+ *Free++ = NIL; \
/* Initial empty work queue */ \
The_Queue = Make_Pointer(TC_LIST, Free); \
*Free++ = NIL; \
User_Vector_Set(Fixed_Objects, Dummy_History, \
Make_Pointer(TC_HUNK3, Dummy_Hist)); \
User_Vector_Set(Fixed_Objects, State_Space_Tag, TRUTH); \
- User_Vector_Set(Fixed_Objects, Bignum_One, Fix_To_Big(FIXNUM_0+1)); \
+ User_Vector_Set(Fixed_Objects, Bignum_One, \
+ Fix_To_Big(Make_Unsigned_Fixnum(1))); \
User_Vector_Set(Fixed_Objects, Me_Myself, Fixed_Objects); \
User_Vector_Set(Fixed_Objects, The_Work_Queue, The_Queue); \
User_Vector_Set(Fixed_Objects, Utilities_Vector, The_Utilities); \
void
Start_Scheme(Start_Prim, File_Name)
-int Start_Prim;
-char *File_Name;
-{ Pointer FName, Init_Prog, *Fasload_Call;
+ int Start_Prim;
+ char *File_Name;
+{
+ extern Pointer make_primitive();
+ Pointer FName, Init_Prog, *Fasload_Call, prim;
fast long i;
- Boolean I_Am_Master = (Start_Prim != PC_GET_WORK); /* Butterfly test */
+ Boolean I_Am_Master; /* Butterfly test */
+ I_Am_Master = (Start_Prim != BOOT_GET_WORK);
if (I_Am_Master)
printf("Scheme Microcode Version %d.%d\n", VERSION, SUBVERSION);
OS_Init(I_Am_Master);
if (I_Am_Master)
- { for (i=0; i < FILE_CHANNELS; i++) Channels[i] = NULL;
+ {
+ for (i = 0; i < FILE_CHANNELS; i++)
+ {
+ Channels[i] = NULL;
+ }
Init_Fixed_Objects();
}
-
-/* The initial program to execute is
- (SCODE-EVAL (FASLOAD <file-name>) SYSTEM-GLOBAL-ENVIRONMENT)
- if Start_Prim is FASLOAD. Otherwise it is
- (BAND-LOAD <file-name>)
+\f
+/* The initial program to execute is one of
+ (SCODE-EVAL (BINARY-FASLOAD <file-name>) SYSTEM-GLOBAL-ENVIRONMENT),
+ (LOAD-BAND <file-name>), or
+ ((GET-WORK))
+ depending on the value of Start_Prim.
*/
FName = C_String_To_Scheme_String(File_Name);
Fasload_Call = Free;
switch (Start_Prim)
- { case PC_FASLOAD: /* (SCODE-EVAL (FASLOAD <file>) GLOBAL-ENV) */
- *Free++ = Make_Non_Pointer(TC_PRIMITIVE, PC_FASLOAD);
+ {
+ case BOOT_FASLOAD: /* (SCODE-EVAL (BINARY-FASLOAD <file>) GLOBAL-ENV) */
+ *Free++ = make_primitive("BINARY-FASLOAD");
*Free++ = FName;
Init_Prog = Make_Pointer(TC_PCOMB2, Free);
- *Free++ = Make_Non_Pointer(TC_PRIMITIVE, PC_SCODE_EVAL);
+ *Free++ = make_primitive("SCODE-EVAL");
*Free++ = Make_Pointer(TC_PCOMB1, Fasload_Call);
*Free++ = Make_Non_Pointer(GLOBAL_ENV, GO_TO_GLOBAL);
break;
- case PC_BAND_LOAD: /* (BAND-LOAD <file>) */
- *Free++ = Make_Non_Pointer(TC_PRIMITIVE, PC_BAND_LOAD);
+
+ case BOOT_LOAD_BAND: /* (LOAD-BAND <file>) */
+ *Free++ = make_primitive("LOAD-BAND");
*Free++ = FName;
Init_Prog = Make_Pointer(TC_PCOMB1, Fasload_Call);
break;
- case PC_GET_WORK: /* ((GET-WORK)) */
- *Free++ = Make_Non_Pointer(TC_PRIMITIVE, PC_GET_WORK);
+
+ case BOOT_GET_WORK: /* ((GET-WORK)) */
+ *Free++ = make_primitive("GET-WORK");
*Free++ = NIL;
Init_Prog = Make_Pointer(TC_COMBINATION, Free);
*Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, 1);
*Free++ = Make_Non_Pointer(TC_PCOMB1, Fasload_Call);
break;
+
+ default:
+ fprintf(stderr, "Unknown boot time option: %d\n", Start_Prim);
+ Microcode_Termination(TERM_BAD_PRIMITIVE);
+ /*NOTREACHED*/
}
/* Start_Scheme continues on the next page */
Store_Expression(NIL);
Save_Cont();
Pushed();
+
Store_Expression(Init_Prog);
/* Go to it! */
if ((Stack_Pointer <= Stack_Guard) || (Free > MemTop))
- { fprintf(stderr, "Configuration won't hold initial data.\n");
+ {
+ fprintf(stderr, "Configuration won't hold initial data.\n");
Microcode_Termination(TERM_EXIT);
}
Entry_Hook();
Enter_Interpreter();
+ /*NOTREACHED*/
}
Enter_Interpreter()
-{ jmp_buf Orig_Eval_Point;
+{
+ jmp_buf Orig_Eval_Point;
Back_To_Eval = (jmp_buf *) Orig_Eval_Point;
Interpret(Was_Scheme_Dumped);
fprintf(stderr, "\nThe interpreter returned to top level!\n");
Microcode_Termination(TERM_EXIT);
+ /*NOTREACHED*/
}
\f
#define IDENTITY_LENGTH 20 /* Plenty of room */
#define ID_OS_NAME 8 /* OS name (string) */
#define ID_OS_VARIANT 9 /* OS variant (string) */
-Built_In_Primitive (Prim_Microcode_Identify, 0, "MICROCODE-IDENTIFY")
+Built_In_Primitive (Prim_Microcode_Identify, 0, "MICROCODE-IDENTIFY", 0xE5)
{
Pointer *Result;
long i;
}
\f
Built_In_Primitive(Prim_Microcode_Tables_Filename,
- 0, "MICROCODE-TABLES-FILENAME")
+ 0, "MICROCODE-TABLES-FILENAME", 0x180)
{ fast char *From, *To;
char *Prefix, *Suffix;
fast long Count;
}
*To = '\0';
Free += STRING_CHARS + ((Count + sizeof(Pointer)) / sizeof(Pointer));
- Vector_Set(Result, STRING_LENGTH, FIXNUM_0 + Count);
+ Vector_Set(Result, STRING_LENGTH, Make_Unsigned_Fixnum(Count));
Vector_Set(Result, STRING_HEADER,
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Free-Get_Pointer(Result))-1));
+ Make_Non_Pointer(TC_MANIFEST_NM_VECTOR,
+ ((Free - Get_Pointer(Result)) - 1)));
return Result;
}
\f
if (Handler != NIL)
{
Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS +
- ((Err==TERM_NO_ERROR_HANDLER) ? 5 : 4));
+ ((Err == TERM_NO_ERROR_HANDLER) ? 5 : 4));
Store_Return(RC_HALT);
- Store_Expression(FIXNUM_0 + Err);
+ Store_Expression(Make_Unsigned_Fixnum(Err));
Save_Cont();
- if (Err == TERM_NO_ERROR_HANDLER) Push(FIXNUM_0 + Micro_Error);
+ if (Err == TERM_NO_ERROR_HANDLER)
+ Push(Make_Unsigned_Fixnum(Micro_Error));
Push(Val); /* Arg 3 */
Push(Fetch_Env()); /* Arg 2 */
Push(Fetch_Expression()); /* Arg 1 */
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/findprim.c,v 9.22 1987/04/03 00:05:46 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/findprim.c,v 9.23 1987/04/16 02:05:40 jinx Exp $
*
- * Preprocessor to find and declare user defined primitives.
+ * Preprocessor to find and declare defined primitives.
*
- * Searches for a token which is a macro defined in primitive.h.
+ */
+\f
+/*
+ * This program searches for a particular token which tags primitive
+ * definitions. This token is also a macro defined in primitive.h.
* For each macro invocation it creates an entry in the External
- * Primitives descriptor used by Scheme. The entry consists of
- * the C routine implementing the primitive, the (fixed) number of
- * arguments it requires, and the name Scheme uses to refer to it.
+ * Primitives descriptor used by Scheme. The entry consists of the C
+ * routine implementing the primitive, the (fixed) number of arguments
+ * it requires, and the name Scheme uses to refer to it.
+ *
+ * The output is a C source file to be compiled and linked with the
+ * Scheme microcode.
+ *
+ * This program understands the following options (must be given in
+ * this order):
+ *
+ * -o fname
+ * Put the output file in fname. The default is to put it on the
+ * standard output.
+ *
+ * -b n
+ * Produce the built-in primitive table instead. The table should
+ * have size n (in hex).
+ *
+ * Note that some output lines are done in a strange fashion because
+ * some C compilers (the vms C compiler, for example) remove comments
+ * even from within string quotes!!
*
- * The output is a C source file (on stdout, must be redirected)
- * to be compiled and linked with the Scheme microcode.
-*/
-\f
-/* In the following some output lines are done in a strange fashion
- * because some C compilers (the vms C compiler, for example) remove
- * comments even from within string quotes!!
*/
-
-static char The_Token[] = "Define_Primitive";
-
-/* Maximum number of primitives that can be handled. */
-
-#ifndef BUFFER_SIZE
-#define BUFFER_SIZE 200
-#endif
\f
+/* Some utility imports and definitions. */
+
#include <stdio.h>
-/* For macros toupper, isalpha, etc, supposedly on the standard library */
+/* For macros toupper, isalpha, etc,
+ supposedly on the standard library.
+*/
+
#include <ctype.h>
-#ifdef vax
-#ifdef vms
-#define normal_exit() return
-#else /* Vax, but not a VMS */
-#define normal_exit() exit(0)
-#include <strings.h>
-#endif
-#else /* Not a Vax */
-#define normal_exit() exit(0)
-#endif
+extern int strcmp(), strlen();
+typedef int boolean;
#define TRUE 1
#define FALSE 0
-typedef int boolean;
+#ifdef vms
+#define void int
+#define normal_exit() return
+#else
+#define normal_exit() exit(0)
+#endif
+#define error_exit(do_it) \
+{ \
+ if (do_it) \
+ dump(TRUE); \
+ exit(1); \
+}
+\f
#ifdef DEBUGGING
#define dprintf(one, two) fprintf(stderr, one, two)
#else
#define dprintf(one, two)
#endif
+/* Maximum number of primitives that can be handled. */
+
+#ifndef BUFFER_SIZE
+#define BUFFER_SIZE 0x400
+#endif
+
+static boolean Built_in_p;
+static long Built_in_table_size;
+
+static char *The_Token;
+static char Built_in_Token[] = "Built_In_Primitive";
+static char External_Token[] = "Define_Primitive";
+
+static char *The_Table;
+static char Built_in_Table[] = "Primitive";
+static char External_Table[] = "External";
+
+static char *The_Variable;
+static char Built_in_Variable[] = "MAX_PRIMITIVE";
+static char External_Variable[] = "MAX_EXTERNAL_PRIMITIVE";
+
static FILE *input, *output;
static char *name;
static char *file_name;
-#define error_exit(do_it) { if (do_it) dump(TRUE); exit(1); }
-
+static void (*create_entry)();
+\f
main(argc, argv)
-int argc;
-char *argv[];
-{ FILE *fopen();
-
- name = argv[0];
-
- /* Check for specified output file */
-
- if ((argc >= 2) && (strcmp("-o", argv[1])==0))
- { if ((output = fopen(argv[2], "w")) == NULL)
- { fprintf(stderr, "Error: %s can't open %s\n", name, argv[2]);
- error_exit(FALSE);
- }
- argv += 2;
- argc -= 2;
- }
- else output = stdout;
-
- if (argc == 1)
- { dump(FALSE);
- normal_exit();
- }
-
- while (--argc > 0)
- { file_name = *++argv;
- if (strcmp("-", file_name)==0)
- { input = stdin;
- file_name = "stdin";
- dprintf("About to process %s\n", "STDIN");
- process();
- }
- else if ((input = fopen(file_name, "r")) == NULL)
- { fprintf(stderr, "Error: %s can't open %s\n", name, file_name);
- error_exit(TRUE);
- }
- else
- { dprintf("About to process %s\n", file_name);
- process();
- fclose(input);
- }
- }
- dprintf("About to sort %s\n", "");
- sort();
- dprintf("About to dump %s\n", "");
- dump(TRUE);
- if (output != stdout) fclose(output);
- normal_exit();
- }
+ int argc;
+ char *argv[];
+{
+ void process(), sort(), dump();
+ FILE *fopen();
+
+ name = argv[0];
+
+ /* Check for specified output file */
+
+ if ((argc >= 2) && (strcmp("-o", argv[1]) == 0))
+ {
+ if ((output = fopen(argv[2], "w")) == NULL)
+ {
+ fprintf(stderr, "Error: %s can't open %s\n", name, argv[2]);
+ error_exit(FALSE);
+ }
+ argv += 2;
+ argc -= 2;
+ }
+ else
+ output = stdout;
+
+ /* Check whether to produce the built-in table instead.
+ The argument after the option letter is the size of the
+ table to build.
+ */
+
+ if ((argc >= 2) && (strcmp("-b", argv[1]) == 0))
+ {
+ void initialize_builtin();
+
+ initialize_builtin(argv[2]);
+ argv += 2;
+ argc -= 2;
+ }
+ else
+ {
+ void initialize_external();
+
+ initialize_external();
+ }
+\f
+ /* Check whether there are any files left. */
+
+ if (argc == 1)
+ {
+ dump(FALSE);
+ normal_exit();
+ }
+
+ while (--argc > 0)
+ {
+ file_name = *++argv;
+ if (strcmp("-", file_name)==0)
+ {
+ input = stdin;
+ file_name = "stdin";
+ dprintf("About to process %s\n", "STDIN");
+ process();
+ }
+ else if ((input = fopen(file_name, "r")) == NULL)
+ {
+ fprintf(stderr, "Error: %s can't open %s\n", name, file_name);
+ error_exit(TRUE);
+ }
+ else
+ {
+ dprintf("About to process %s\n", file_name);
+ process();
+ fclose(input);
+ }
+ }
+ dprintf("About to sort %s\n", "");
+ sort();
+ dprintf("About to dump %s\n", "");
+ dump(TRUE);
+ if (output != stdout)
+ fclose(output);
+ normal_exit();
+}
\f
#define DONE 0
#define FOUND 1
/* Search for tokens and when found, create primitive entries. */
+void
process()
-{ while ((scan() != DONE))
- { dprintf("Process: place found.%s\n", "");
- create_entry();
+{
+ int scan();
+
+ while ((scan() != DONE))
+ {
+ dprintf("Process: place found.%s\n", "");
+ (*create_entry)();
}
+ return;
}
/* Search for token and stop when found. If you hit open comment
* character, read until you hit close comment character.
- * FIX: It is not a complete C parser, thus it may be fooled,
+ * *** FIX *** : It is not a complete C parser, thus it may be fooled,
* currently the token must always begin a line.
*/
+int
scan()
-{ register char c, *temp;
+{
+ register char c, *temp;
c = '\n';
while(c != EOF)
switch(c)
{ case '/':
if ((c = getc(input)) == '*')
- { c = getc(input);
+ {
+ c = getc(input);
while (TRUE)
{ while (c != '*')
{ if (c == EOF)
return DONE;
}
\f
+boolean
+whitespace(c)
+ char c;
+{
+ switch(c)
+ { case ' ':
+ case '\t':
+ case '\n':
+ case '(':
+ case ')':
+ case ',': return TRUE;
+ default: return FALSE;
+ }
+}
+
+void
+scan_to_token_start()
+{
+ char c;
+
+ while (whitespace(c = getc(input))) {};
+ ungetc(c, input);
+ return;
+}
+
+/* *** FIX *** This should check for field overflow (n too small) */
+
+void
+copy_token(s, cap, Size)
+ char s[];
+ boolean cap;
+ int *Size;
+{
+ register char c;
+ register int n = 0;
+
+ while (!(whitespace(c = getc(input))))
+ s[n++] = ((cap && isalpha(c) && islower(c))? toupper(c) : c);
+ s[n] = '\0';
+ if (n > *Size)
+ *Size = n;
+ return;
+}
+
+void
+copy_string(is, s, cap, Size)
+ register char *is;
+ char s[];
+ boolean cap;
+ int *Size;
+{
+ register char c;
+ register int n = 0;
+
+ while ((c = *is++) != '\0')
+ s[n++] = ((cap && isalpha(c) && islower(c))? toupper(c) : c);
+ s[n] = '\0';
+ if (n > *Size)
+ *Size = n;
+ return;
+}
+\f
#define STRING_SIZE 80
#define ARITY_SIZE 6
{ char C_Name[STRING_SIZE]; /* The C name of the function */
char Arity[ARITY_SIZE]; /* Number of arguments */
char Scheme_Name[STRING_SIZE]; /* Scheme name of the primitive */
+ char File_Name[STRING_SIZE]; /* File where found. */
} descriptor;
-/* FIX: This should really be malloced incrementally,
- * but for the time being ... */
+/*
+ * *** FIX ***
+ * This should really be malloced incrementally, but for the time being ...
+ *
+ */
-descriptor Data_Buffer[BUFFER_SIZE]; /* New Primitives Allowed */
static int buffer_index = 0;
+descriptor Data_Buffer[BUFFER_SIZE];
+descriptor *Result_Buffer[BUFFER_SIZE];
+
+static descriptor Dummy_Entry =
+{ "Dummy_Primitive",
+ "0",
+ "\"DUMMY-PRIMITIVE\"",
+ "Findprim.c"
+};
+
+static char Dummy_Error_String[] =
+ "Microcode_Termination(TERM_BAD_PRIMITIVE)";
+
+static descriptor Inexistent_Entry =
+{ "Prim_Inexistent",
+ "0",
+ "No_Name",
+ "Findprim.c"
+};
+
+static char Inexistent_Real_Name[] =
+ "\"INEXISTENT-PRIMITIVE\"";
+static char Inexistent_Error_String[] =
+ "Primitive_Error(ERR_UNIMPLEMENTED_PRIMITIVE)";
static int C_Size = 0;
static int A_Size = 0;
static int S_Size = 0;
+static int F_Size = 0;
#define DONT_CAP FALSE
#define DO_CAP TRUE
-
-create_entry()
-{ if (buffer_index >= BUFFER_SIZE)
- { fprintf(stderr, "Error: %s cannot handle so many primitives.\n", name);
+\f
+void
+create_external_entry()
+{
+ if (buffer_index >= BUFFER_SIZE)
+ {
+ fprintf(stderr, "Error: %s cannot handle so many primitives.\n", name);
fprintf(stderr, "Recompile %s with BUFFER_SIZE larger than %d.\n",
name, BUFFER_SIZE);
error_exit(FALSE);
copy_token((Data_Buffer[buffer_index]).Arity, DONT_CAP, &A_Size);
scan_to_token_start();
copy_token((Data_Buffer[buffer_index]).Scheme_Name, DO_CAP, &S_Size);
+ copy_string(file_name, (Data_Buffer[buffer_index]).File_Name, DONT_CAP, &F_Size);
+ Result_Buffer[buffer_index] = &Data_Buffer[buffer_index];
buffer_index++;
+ return;
}
-scan_to_token_start()
-{ char c;
- while (whitespace(c = getc(input))) {};
- ungetc(c, input);
+void
+initialize_external()
+{
+ Built_in_p = FALSE;
+ The_Token = &External_Token[0];
+ The_Table = &External_Table[0];
+ The_Variable = &External_Variable[0];
+ create_entry = create_external_entry;
+ return;
}
-/* FIX: This should check for field overflow (n too small) */
+void
+initialize_from_entry(entry)
+ descriptor *entry;
+{
+ C_Size = strlen(entry->C_Name);
+ A_Size = strlen(entry->Arity);
+ S_Size = strlen(entry->Scheme_Name);
+ F_Size = strlen(entry->File_Name);
+ return;
+}
+\f
+int
+read_index(arg)
+ char *arg;
+{
+ int result = 0;
+
+ if ((arg[0] == '0') && (arg[1] == 'x'))
+ sscanf(&arg[2], "%x", &result);
+ else
+ sscanf(&arg[0], "%d", &result);
+ return result;
+}
-copy_token(s, cap, Size)
-char s[];
-boolean cap;
-int *Size;
-{ register char c;
- register int n = 0;
- while (!(whitespace(c = getc(input))))
- s[n++] = ((cap && isalpha(c) && islower(c))? toupper(c) : c);
- s[n] = '\0';
- if (n > *Size) *Size = n;
+void
+create_builtin_entry()
+{
+ static char index_buffer[STRING_SIZE];
+ int index = 0;
+
+ scan_to_token_start();
+ copy_token((Data_Buffer[buffer_index]).C_Name, DONT_CAP, &C_Size);
+ scan_to_token_start();
+ copy_token((Data_Buffer[buffer_index]).Arity, DONT_CAP, &A_Size);
+ scan_to_token_start();
+ copy_token((Data_Buffer[buffer_index]).Scheme_Name, DO_CAP, &S_Size);
+ copy_string(file_name, (Data_Buffer[buffer_index]).File_Name, DONT_CAP, &F_Size);
+ scan_to_token_start();
+ copy_token(index_buffer, DONT_CAP, &index);
+ index = read_index(index_buffer);
+ if (index >= Built_in_table_size)
+ {
+ fprintf(stderr, "%s: Table size = %d; Found Primitive %d.\n",
+ name, Built_in_table_size, index);
+ error_exit(FALSE);
+ }
+ if (Result_Buffer[index] != &Inexistent_Entry)
+ {
+ void print_entry(), initialize_index_size();
+
+ fprintf(stderr, "%s: redefinition of primitive %d.\n", name, index);
+ fprintf(stderr, "previous definition:\n");
+ initialize_index_size();
+ output = stderr,
+ print_entry(index, Result_Buffer[index]);
+ fprintf(stderr, "\n");
+ fprintf(stderr, "new definition:\n");
+ print_entry(index, &Data_Buffer[buffer_index]);
+ fprintf(stderr, "\n");
+ error_exit(FALSE);
+ }
+ Result_Buffer[index] = &Data_Buffer[buffer_index];
+ buffer_index++;
+ return;
}
-whitespace(c)
-char c;
-{ switch(c)
- { case ' ':
- case '(':
- case ')':
- case ',': return TRUE;
- default: return FALSE;
+void
+initialize_builtin(arg)
+ char *arg;
+{
+ register int index;
+
+ Built_in_p = TRUE;
+ Built_in_table_size = read_index(arg);
+ if (Built_in_table_size > BUFFER_SIZE)
+ {
+ fprintf(stderr, "%s: built_in_table_size > BUFFER_SIZE.\n", name);
+ fprintf(stderr, "Recompile with a larger value of BUFFER_SIZE.\n");
+ error_exit(FALSE);
}
+ The_Token = &Built_in_Token[0];
+ The_Table = &Built_in_Table[0];
+ The_Variable = &Built_in_Variable[0];
+ create_entry = create_builtin_entry;
+ for (index = Built_in_table_size; --index >= 0; )
+ Result_Buffer[index] = &Inexistent_Entry;
+ initialize_from_entry(&Inexistent_Entry);
+ return;
}
\f
-/* FIX: No-op for now */
+/* *** FIX *** No-op for now */
+void
sort()
-{ return FALSE;
+{
+ return;
}
\f
+static int max, max_index_size;
+static char index_buffer[STRING_SIZE];
+
+#define find_index_size(index, size) \
+{ \
+ sprintf(index_buffer, "%x", (index)); \
+ size = strlen(index_buffer); \
+}
+
+void
+initialize_index_size()
+{
+ if (Built_in_p)
+ max = Built_in_table_size;
+ else
+ max = buffer_index;
+ find_index_size(max, max_index_size);
+ max -= 1;
+ return;
+}
+\f
+void
print_spaces(how_many)
-register int how_many;
-{ for(; --how_many >= 0;) putc(' ', output);
+ register int how_many;
+{
+ for(; --how_many >= 0;)
+ putc(' ', output);
+ return;
+}
+
+void
+print_entry(index, entry)
+ int index;
+ descriptor *entry;
+{
+ int index_size;
+
+ fprintf(output, " %s ", (entry->C_Name));
+ print_spaces(C_Size - (strlen(entry->C_Name)));
+ fprintf(output, "/%c ", '*');
+ print_spaces(A_Size - (strlen(entry->Arity)));
+ fprintf(output,
+ "%s %s",
+ (entry->Arity),
+ (entry->Scheme_Name));
+ print_spaces(S_Size-(strlen(entry->Scheme_Name)));
+ fprintf(output, " %s ", ((Built_in_p) ? "Primitive" : "External"));
+ find_index_size(index, index_size);
+ print_spaces(max_index_size - index_size);
+ fprintf(output, "0x%x in %s %c/", index, (entry->File_Name), '*');
+ return;
+}
+
+void
+print_procedure(entry, error_string)
+ descriptor *entry;
+ char *error_string;
+{
+ fprintf(output, "Pointer\n");
+ fprintf(output, "%s()\n", (entry->C_Name));
+ fprintf(output, "{\n");
+ fprintf(output, " Primitive_%s_Args();\n", (entry->Arity));
+ fprintf(output, "\n");
+ fprintf(output, " %s;\n", error_string);
+ fprintf(output, "}\n\n");
+ return;
}
+\f
+void
+print_primitives(last)
+ register int last;
+{
-#define print_entry(index) \
-fprintf(output, " %s,", (Data_Buffer[index].C_Name)); \
-print_spaces(1+ \
- (C_Size-(strlen(Data_Buffer[index].C_Name)))+ \
- (A_Size-(strlen(Data_Buffer[index].Arity)))); \
-fprintf(output, "%s", (Data_Buffer[index]).Arity); \
-fprintf(output, ", %s", (Data_Buffer[index]).Scheme_Name); \
-print_spaces(S_Size-(strlen(Data_Buffer[index].Scheme_Name))); \
-fprintf(output, " /%c External %d %c/", '*', index, '*')
+ register int count;
+ /* Print the procedure table. */
+
+ fprintf(output, "Pointer (*(%s_Procedure_Table[]))() = {\n", The_Table);
+
+ for (count = 0; count < last; count++)
+ {
+ print_entry(count, Result_Buffer[count]);
+ fprintf(output, ",\n");
+ }
+ print_entry(last, Result_Buffer[last]);
+ fprintf(output, "\n};\n\n");
+
+ /* Print the arity table. */
+
+ fprintf(output, "int %s_Arity_Table[] = {\n", The_Table);
+
+ for (count = 0; count < last; count++)
+ {
+ fprintf(output, " %s,\n", ((Result_Buffer[count])->Arity));
+ }
+ fprintf(output, " %s\n", ((Result_Buffer[last])->Arity));
+ fprintf(output, "};\n\n");
+
+ /* Print the names table. */
+
+ fprintf(output, "char *%s_Name_Table[] = {\n", The_Table);
+
+ for (count = 0; count < last; count++)
+ {
+ fprintf(output, " %s,\n", ((Result_Buffer[count])->Scheme_Name));
+ }
+ fprintf(output, " %s\n", ((Result_Buffer[last])->Scheme_Name));
+ fprintf(output, "};\n\n");
+
+ return;
+}
+\f
/* Produce C source. */
+void
dump(check)
-boolean check;
-{ register int count;
- int max = buffer_index-1;
+ boolean check;
+{
+ register int count, end;
+
+ initialize_index_size();
/* Print header. */
- fprintf(output, "/%c User defined primitive declarations %c/\n\n",
- '*', '*');
+ fprintf(output, "/%c Emacs: This is -*- C -*- code. %c/\n\n", '*', '*');
+
+ fprintf(output, "/%c %s primitive declarations %c/\n\n",
+ '*', ((Built_in_p) ? "Built in" : "User defined" ), '*');
+
fprintf(output, "#include \"usrdef.h\"\n\n");
+ fprintf(output, "long %s = %d;\n\n", The_Variable, max);
+ if (Built_in_p)
+ fprintf(output,
+ "/%c The number of implemented primitives is %d. %c/\n\n",
+ '*', buffer_index, '*');
+
if (max < 0)
{
- if (check) fprintf(stderr, "No User primitives found!\n");
+ if (check)
+ fprintf(stderr, "No primitives found!\n");
/* C does not understand the empty array, thus it must be faked. */
/* Dummy entry */
- fprintf(output, "Pointer Dummy_Primitive()\n");
- fprintf(output, "{ /%c This should NEVER be called. %c/\n", '*', '*');
- fprintf(output, " Microcode_Termination(TERM_BAD_PRIMITIVE);\n");
- fprintf(output, "}\n\n");
-
- /* Array with Dummy entry */
+ Result_Buffer[0] = &Dummy_Entry;
+ initialize_from_entry(&Dummy_Entry);
+ print_procedure(&Dummy_Entry, &Dummy_Error_String[0]);
- fprintf(output, "External_Descriptor Ext_Prim_Desc[] = {\n");
- fprintf(output, " Dummy_Primitive, 0, \"DUMMY-PRIMITIVE\"\n");
- fprintf(output, "};\n\n");
}
+\f
else
{
- /* Print extern declarations. */
+ /* Print declarations. */
fprintf(output, "extern Pointer\n");
- for (count = 0; count < max; count++)
- fprintf(output, " %s(),\n", Data_Buffer[count].C_Name);
- fprintf(output, " %s();\n\n", Data_Buffer[max].C_Name);
- /* Print structure. */
+ end = (Built_in_p ? buffer_index : max);
+ for (count = 0; count < end; count++)
+ {
+ fprintf(output, " %s(),\n", &(Data_Buffer[count].C_Name)[0]);
+ }
- fprintf(output, "External_Descriptor Ext_Prim_Desc[] = {\n");
+ if (Built_in_p)
+ {
+ fprintf(output, " %s();\n\n", &(Inexistent_Entry.C_Name)[0]);
- for (count = 0; count < max; count++)
- { print_entry(count);
- fprintf(output, ",\n");
+ fprintf(output,
+ "static char %s[] = %s;\n\n",
+ Inexistent_Entry.Scheme_Name,
+ Inexistent_Real_Name);
+ print_procedure(&Inexistent_Entry, &Inexistent_Error_String[0]);
}
- print_entry(max);
-
- fprintf(output, "\n};\n\n");
+ else
+ fprintf(output, " %s();\n\n", &(Data_Buffer[end].C_Name)[0]);
+
}
- fprintf(output, "long MAX_EXTERNAL_PRIMITIVE = %d;\n\n", max);
+ print_primitives((max < 0) ? 0 : max);
return;
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.22 1987/04/03 00:06:48 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.23 1987/04/16 02:06:10 jinx Exp $
*
* This File contains the code to translate portable format binary
* files to internal format.
long digit;
if (size_in_bits > FLONUM_MANTISSA_BITS)
fprintf(stderr,
- "%s: Some precission may be lost.",
+ "%s: Some precision may be lost.",
Program_Name);
getc(Portable_File); /* Space */
for (ndigits = hex_digits(size_in_bits),
Normalization = (1.0 / 16.0);
--ndigits >= 0;
Normalization /= 16.0)
- { fscanf(Portable_File, "%1lx", &digit);
+ {
+ fscanf(Portable_File, "%1lx", &digit);
Result += (((double ) digit) * Normalization);
}
Result = ldexp(Result, ((int) exponent));
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.23 1987/04/03 00:05:18 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.24 1987/04/16 02:05:24 jinx Exp $
*
* This File contains the code to translate internal format binary
* files to portable format.
fprintf(Portable_File, s); \
break
+void
print_a_char(c, name)
-fast char c;
-char *name;
-{ switch(c)
+ fast char c;
+ char *name;
+{
+ switch(c)
{ case '\n': OUT("\\n");
case '\t': OUT("\\t");
case '\b': OUT("\\b");
}
\f
#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
+{ \
+ Old_Address += (Rel); \
Old_Contents = *Old_Address; \
if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
Mem_Base[(Scn)] = \
Make_New_Pointer((Code), Old_Contents); \
else \
- { fast long i; \
+ { \
+ fast long i; \
+ \
Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
*Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
(Obj) += 1; \
- *(FObj)++ = STRING_0; \
+ *(FObj)++ = Make_Non_Pointer(TC_STRING, 0); \
*(FObj)++ = Old_Contents; \
i = Get_Integer(Old_Contents); \
NStrings += 1; \
NChars += pointer_to_char(i-1); \
- while(--i >= 0) *(FObj)++ = *Old_Address++; \
+ while(--i >= 0) \
+ *(FObj)++ = *Old_Address++; \
} \
}
+void
print_a_string(from)
-Pointer *from;
+ Pointer *from;
{ fast long len;
fast char *string;
- long maxlen = pointer_to_char((Get_Integer(*from++))-1);
+ long maxlen;
+
+ maxlen = pointer_to_char((Get_Integer(*from++))-1);
len = Get_Integer(*from++);
fprintf(Portable_File, "%02x %ld %ld ",
TC_CHARACTER_STRING,
string = ((char *) from);
if (Shuffle_Bytes)
{ while(len > 0)
- { print_a_char(string[3], "print_a_string");
- if (len > 1) print_a_char(string[2], "print_a_string");
- if (len > 2) print_a_char(string[1], "print_a_string");
- if (len > 3) print_a_char(string[0], "print_a_string");
+ {
+ print_a_char(string[3], "print_a_string");
+ if (len > 1)
+ print_a_char(string[2], "print_a_string");
+ if (len > 2)
+ print_a_char(string[1], "print_a_string");
+ if (len > 3)
+ print_a_char(string[0], "print_a_string");
len -= 4;
string += 4;
}
return;
}
\f
+void
print_a_fixnum(val)
-long val;
-{ fast long size_in_bits;
- fast unsigned long temp = ((val < 0) ? -val : val);
+ long val;
+{
+ fast long size_in_bits;
+ fast unsigned long temp;
+
+ temp = ((val < 0) ? -val : val);
for (size_in_bits = 0; temp != 0; size_in_bits += 1)
temp = temp >> 1;
fprintf(Portable_File, "%02x %c ",
TC_FIXNUM,
(val < 0 ? '-' : '+'));
- if (val == 0) fprintf(Portable_File, "0\n");
+ if (val == 0)
+ fprintf(Portable_File, "0\n");
else
- { fprintf(Portable_File, "%ld ", size_in_bits);
+ {
+ fprintf(Portable_File, "%ld ", size_in_bits);
temp = ((val < 0) ? -val : val);
while (temp != 0)
{ fprintf(Portable_File, "%01lx", (temp % 16));
} \
}
+void
print_a_bignum(from)
-Pointer *from;
-{ fast bigdigit *the_number, *the_top;
+ Pointer *from;
+{
+ fast bigdigit *the_number, *the_top;
fast long size_in_bits;
fast unsigned long temp; /* Potential signed problems */
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.22 1987/04/03 00:06:48 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.23 1987/04/16 02:06:10 jinx Exp $
*
* This File contains the code to translate portable format binary
* files to internal format.
long digit;
if (size_in_bits > FLONUM_MANTISSA_BITS)
fprintf(stderr,
- "%s: Some precission may be lost.",
+ "%s: Some precision may be lost.",
Program_Name);
getc(Portable_File); /* Space */
for (ndigits = hex_digits(size_in_bits),
Normalization = (1.0 / 16.0);
--ndigits >= 0;
Normalization /= 16.0)
- { fscanf(Portable_File, "%1lx", &digit);
+ {
+ fscanf(Portable_File, "%1lx", &digit);
Result += (((double ) digit) * Normalization);
}
Result = ldexp(Result, ((int) exponent));
projects / mit-scheme.git / commitdiff