conservatory
/
elk
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

elk (3.0-9) unstable; urgency=low 

* New maintainer.
  * Packaging updates:
    + Fixed spelling in the package description (Closes: #161056).
    + Updated standards version to 3.5.9.0.
    + Changed SCM_DIR from /usr/lib/elk/scm to /usr/share/elk/scm because
      scheme scripts are platform-independent.
  * Massive code cleanups:
    + Added -Wall to the build rules to make error spotting easier, and fixed
      all compilation warnings in the main program.
    + Replaced sys_errlist with strerror, bcopy with memcpy, bzero with memset.
    + Fixed many uninitialized variables.
  * Fixed some pointer/integer type confusions which caused elk to crash
    on alpha (Closes: #59893) and probably ia64.
  * Fixed a read overflow in heap-gen.c:AllocPage() that was corrupting the
    internal heap (Closes: #57621).
  * Fixed a missing memory area initialization in heap-gen.c:ExpandHeap() that
    was causing garbage collector crashes.
  * Fixed an integer sign issue in main.c:Max_Stack (Closes: #176190).
  * Made `quit' an alias for `exit' in toplevel.scm.
 -- Samuel Hocevar <sam@zoy.org>  Tue,  1 Apr 2003 11:33:23 +0200


git-svn-id: svn://svn.zoy.org/elk/trunk@3 55e467fa-43c5-0310-a8a2-de718669efc6
This commit is contained in:
sam 2003-08-19 19:24:23 +00:00
parent f37781fa62
commit d51c970c8d
71 changed files with 1748 additions and 1459 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
BUGS
View File

@ -33,3 +33,11 @@ Generational/Incremental Garbage Collector
(a broken-heart is passed to Memoize_Frame() after an ExpandHeap()).
o The percentage displayed at the end of a GC run is sometimes wrong.
o This simple test causes a valgrind error after the first GC run:
(define (fact x) (if (> x 1) (* x (fact (- x 1))) 1))
(fact 100)
(fact 1000)
(fact 1000)

2
config/system
View File

@ -295,7 +295,7 @@ ld=ld
# The C compiler flags used for all files.
cflags='-O2 -I/usr/include/libelf'
cflags='-Wall -O2 -I/usr/include/libelf'
# Are extra C compiler flags (such as -D_NO_PROTO) required to compile

7
debian/README.Debian vendored
View File

@ -18,7 +18,9 @@ $install_dir/bin/scheme /usr/bin/scheme
$install_dir/include/ /usr/include/elk/
$install_dir/runtime/{scm,obj}/ /usr/lib/elk/{scm,obj}/
$install_dir/runtime/scm/ /usr/share/elk/scm/
$install_dir/runtime/obj/ /usr/lib/elk/obj/
$install_dir/lib/*.o /usr/lib/elk/*.o
@ -27,4 +29,5 @@ $install_dir/lib/{linkscheme,makedl} /usr/bin/{linkscheme,makedl}
$install_dir/lib/ldflags /usr/bin/ldflags-elk
-- Enrique Zanardi <ezanard@debian.org>, Mon, 26 Mar 2001 20:19:04 +0100
-- Enrique Zanardi <ezanard@debian.org> Mon, 26 Mar 2001 20:19:04 +0100
-- Samuel Hocevar <sam@zoy.org> Mon, 31 Mar 2003 15:00:23 +0200

28
debian/changelog vendored
View File

@ -1,11 +1,26 @@
elk (3.0-8.1) unstable; urgency=low
elk (3.0-9) unstable; urgency=low
* New maintainer.
* Fixed spelling in the package description (Closes: #161056).
* Updated standards version to 3.5.9.0.
* Replaced sys_errlist usage with strerror calls, and mktemp with mkstemp.
* Packaging updates:
+ Fixed spelling in the package description (Closes: #161056).
+ Updated standards version to 3.5.9.0.
+ Changed SCM_DIR from /usr/lib/elk/scm to /usr/share/elk/scm because
scheme scripts are platform-independent.
* Massive code cleanups:
+ Added -Wall to the build rules to make error spotting easier, and fixed
all compilation warnings in the main program.
+ Replaced sys_errlist with strerror, bcopy with memcpy, bzero with memset.
+ Fixed many uninitialized variables.
* Fixed some pointer/integer type confusions which caused elk to crash
on alpha (Closes: #59893) and probably ia64.
* Fixed a read overflow in heap-gen.c:AllocPage() that was corrupting the
internal heap (Closes: #57621).
* Fixed a missing memory area initialization in heap-gen.c:ExpandHeap() that
was causing garbage collector crashes.
* Fixed an integer sign issue in main.c:Max_Stack (Closes: #176190).
* Made `quit' an alias for `exit' in toplevel.scm.
-- Samuel Hocevar <sam@zoy.org> Fri, 28 Mar 2003 10:30:34 +0100
-- Samuel Hocevar <sam@zoy.org> Tue, 1 Apr 2003 11:33:23 +0200
elk (3.0-8.1) unstable; urgency=low
@ -85,6 +100,3 @@ elk (3.0-1) unstable; urgency=low
-- Enrique Zanardi <ezanardi@molec1.dfis.ull.es> Wed, 30 Oct 1996 13:05:48 +0000
Local variables:
mode: debian-changelog
End:

2
debian/elk.ini vendored
View File

@ -47,7 +47,7 @@
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
(define (implementation-vicinity) "/usr/lib/elk/scm")
(define (implementation-vicinity) "/usr/share/elk/scm")
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.

6
debian/rules vendored
View File

@ -21,9 +21,9 @@ build-stamp:
# Add here commands to compile the package.
ifeq ($(shell dpkg-architecture -qDEB_BUILD_ARCH),alpha)
echo "cflags='-O0 -I/usr/include/libelf'" > debian/arch-config
echo 'cflags=`echo $${cflags} | sed s/-O./-O0/`' > debian/arch-config
else
echo "# empty" > debian/arch-config
echo '# empty' > debian/arch-config
endif
$(MAKE) SUBDIRS='include scripts src scm lib/misc lib/unix\
lib/xlib lib/xt lib/xaw lib/xm lib/xm/xt'
@ -54,7 +54,7 @@ install: build
mv $(CURDIR)/debian/elk/usr/bin/scheme \
$(CURDIR)/debian/elk/usr/bin/scheme-elk
install -m 755 debian/scheme-warning-elk $(CURDIR)/debian/elk/usr/bin/
install -m 644 debian/elk.ini $(CURDIR)/debian/elk/usr/lib/elk/scm
install -m 644 debian/elk.ini $(CURDIR)/debian/elk/usr/share/elk/scm
# dh_movefiles
# Build architecture-independent files here.

2
include/build-config
View File

@ -321,7 +321,7 @@ $def_bcopy
$def_bzero
$def_bcmp
#define AOUT_H $aout_h
#define SCM_DIR "$final_dir/lib/elk/scm"
#define SCM_DIR "$final_dir/share/elk/scm"
#define OBJ_DIR "$final_dir/lib/elk/obj"
#define HEAP_SIZE $default_heap_size
#define FIND_AOUT defined(USE_LD) || defined(CAN_DUMP)\\

4
include/cstring.h
View File

@ -6,7 +6,7 @@
Check_Type(_from, T_String);\
_len = STRING(_from)->size;\
Alloca ((_to), char*, _len+1);\
bcopy (STRING(_from)->data, (_to), _len);\
memcpy ((_to), STRING(_from)->data, _len);\
(_to)[_len] = '\0';\
}
@ -18,6 +18,6 @@
Wrong_Type_Combination ((_from), "string or symbol");\
_len = STRING(_from)->size;\
Alloca ((_to), char*, _len+1);\
bcopy (STRING(_from)->data, (_to), _len);\
memcpy ((_to), STRING(_from)->data, _len);\
(_to)[_len] = '\0';\
}

77
include/extern.h
View File

@ -11,7 +11,7 @@ extern Object P_Autoload P_((Object, Object));
/* Bignums
*/
extern Object Make_Uninitialized_Bignum P_((int));
extern Bignum_Normalize_In_Place P_((struct S_Bignum *));
extern void Bignum_Normalize_In_Place P_((struct S_Bignum *));
/* Boolean operators
*/
@ -82,10 +82,10 @@ extern Object The_Environment, Global_Environment;
/* Error handling
*/
extern Primitive_Error P_((ELLIPSIS));
extern Fatal_Error P_((ELLIPSIS));
extern Range_Error P_((Object));
extern Panic P_((const char*));
extern void Primitive_Error P_((ELLIPSIS)) __attribute__ ((__noreturn__));
extern void Fatal_Error P_((ELLIPSIS)) __attribute__ ((__noreturn__));
extern void Range_Error P_((Object));
extern void Panic P_((const char*));
extern Object P_Error P_((int, Object*));
extern Object P_Reset P_((void));
extern const char *Error_Tag; /* will be removed in the near future */
@ -110,8 +110,8 @@ extern Object P_Require P_((int, Object*));
*/
extern int GC_Debug;
extern Object Alloc_Object P_((int, int, int));
extern Register_Before_GC P_((void (*)(void)));
extern Register_After_GC P_((void (*)(void)));
extern void Register_Before_GC P_((void (*)(void)));
extern void Register_After_GC P_((void (*)(void)));
extern Object P_Collect P_((void));
extern Object P_Garbage_Collect_Status P_((int, Object *));
#ifdef GENERATIONAL_GC
@ -122,7 +122,7 @@ extern Object P_Garbage_Collect_Status P_((int, Object *));
*/
extern Object Curr_Input_Port, Curr_Output_Port;
extern Object Standard_Input_Port, Standard_Output_Port;
extern Reset_IO P_((int));
extern void Reset_IO P_((int));
extern Object P_Current_Input_Port P_((void));
extern Object P_Current_Output_Port P_((void));
extern Object P_Input_Portp P_((Object));
@ -182,7 +182,7 @@ extern Object P_Caaaar P_((Object));
extern Object P_Caaadr P_((Object));
extern Object P_Caadar P_((Object));
extern Object P_Caaddr P_((Object));
extern Object P_Cadaar P_((Object));
extern Object P_Cadaar P_((Object));
extern Object P_Cadadr P_((Object));
extern Object P_Caddar P_((Object));
extern Object P_Cadddr P_((Object));
@ -220,15 +220,15 @@ extern void Elk_Init P_((int, char **av, int, char *));
/* malloc() and realloc()
*/
extern char *Safe_Malloc P_((unsigned));
extern char *Safe_Realloc P_((char*, unsigned));
extern char *Safe_Malloc P_((unsigned int));
extern char *Safe_Realloc P_((char*, unsigned int));
/* Numbers
*/
extern Object Make_Integer P_((int));
extern Object Make_Unsigned P_((unsigned));
extern Object Make_Long P_((long));
extern Object Make_Unsigned_Long P_((unsigned long));
extern Object Make_Unsigned P_((unsigned int));
extern Object Make_Long P_((long int));
extern Object Make_Unsigned_Long P_((unsigned long int));
extern Object Make_Reduced_Flonum P_((double));
extern Object Make_Flonum P_((double));
extern Object P_Numberp P_((Object));
@ -281,23 +281,23 @@ extern Object P_Random P_((void));
extern Object P_Srandom P_((Object));
extern Object P_Number_To_String P_((int, Object*));
extern double Get_Double P_((Object));
extern Get_Integer P_((Object));
extern unsigned Get_Unsigned P_((Object));
extern long Get_Long P_((Object));
extern unsigned long Get_Unsigned_Long P_((Object));
extern Get_Exact_Integer P_((Object));
extern unsigned Get_Exact_Unsigned P_((Object));
extern long Get_Exact_Long P_((Object));
extern unsigned long Get_Exact_Unsigned_Long P_((Object));
extern int Get_Integer P_((Object));
extern unsigned int Get_Unsigned P_((Object));
extern long int Get_Long P_((Object));
extern unsigned long int Get_Unsigned_Long P_((Object));
extern int Get_Exact_Integer P_((Object));
extern unsigned int Get_Exact_Unsigned P_((Object));
extern long int Get_Exact_Long P_((Object));
extern unsigned long int Get_Exact_Unsigned_Long P_((Object));
/* Onfork handlers
*/
extern Register_Onfork P_((void (*)(void)));
extern void Register_Onfork P_((void (*)(void)));
extern void Call_Onfork P_((void));
/* Define_Primitive()
*/
extern Define_Primitive P_((Object (*)(ELLIPSIS), const char*, int, int,
extern void Define_Primitive P_((Object (*)(ELLIPSIS), const char*, int, int,
enum discipline));
/* Output
@ -311,12 +311,12 @@ extern Object P_Clear_Output_Port P_((int, Object*));
extern Object P_Flush_Output_Port P_((int, Object*));
extern Object P_Print P_((int, Object*));
extern Object P_Get_Output_String P_((Object));
extern Check_Output_Port P_((Object));
extern Discard_Output P_((Object));
extern Printf P_((ELLIPSIS));
extern Print_Object P_((Object, Object, int, int, int));
extern General_Print_Object P_((Object, Object, int));
extern Format P_((Object, const char*, int, int, Object*));
extern void Check_Output_Port P_((Object));
extern void Discard_Output P_((Object));
extern void Printf P_((ELLIPSIS));
extern void Print_Object P_((Object, Object, int, int, int));
extern void General_Print_Object P_((Object, Object, int));
extern void Format P_((Object, const char*, int, int, Object*));
extern int Saved_Errno;
/* Evaluator, procedures, macros
@ -337,7 +337,7 @@ extern Object P_Macro_Expand P_((Object));
extern Object P_Primitivep P_((Object));
extern Object P_Compoundp P_((Object));
extern Object P_Macrop P_((Object));
extern Check_Procedure P_((Object));
extern void Check_Procedure P_((Object));
/* Delay and force
*/
@ -356,8 +356,8 @@ extern Object P_Unread_Char P_((int, Object*));
extern Object P_Read_String P_((int, Object*));
extern Object P_Clear_Input_Port P_((int, Object*));
extern Object General_Read P_((Object, int));
extern Check_Input_Port P_((Object));
extern Discard_Input P_((Object));
extern void Check_Input_Port P_((Object));
extern void Discard_Input P_((Object));
extern void Define_Reader P_((int, READFUN));
/* Special forms
@ -426,8 +426,8 @@ extern Object Sym_Else;
extern Object Var_Get P_((Object));
extern void Var_Set P_((Object, Object));
extern int Var_Is_True P_((Object));
extern unsigned long Symbols_To_Bits P_((Object, int, SYMDESCR*));
extern Object Bits_To_Symbols P_((unsigned long, int, SYMDESCR*));
extern unsigned long int Symbols_To_Bits P_((Object, int, SYMDESCR*));
extern Object Bits_To_Symbols P_((unsigned long int, int, SYMDESCR*));
/* Termination functions
*/
@ -441,9 +441,10 @@ extern void Terminate_Type P_((int));
*/
extern TYPEDESCR *Types;
extern Object P_Type P_((Object));
extern Wrong_Type P_((Object, int));
extern Wrong_Type_Combination P_((Object, const char*));
extern Define_Type P_((int, const char*, int (*)(Object), int,
extern void Wrong_Type P_((Object, int)) __attribute__ ((__noreturn__));
extern void Wrong_Type_Combination P_((Object, const char*))
__attribute__ ((__noreturn__));
extern int Define_Type P_((int, const char*, int (*)(Object), int,
int (*)(Object, Object), int (*)(Object, Object),
int (*)(Object, Object, int, int, int),
int (*)(Object*, int (*)(Object*)) ));

2
include/gc.h
View File

@ -88,7 +88,7 @@ extern GCNODE *GC_List;
#define GC_Unlink (GC_List = gc1.next)
C_LINKAGE_BEGIN
extern Func_Global_GC_Link P_((Object*));
extern void Func_Global_GC_Link P_((Object*));
C_LINKAGE_END
#define Global_GC_Link(x) Func_Global_GC_Link(&x)

14
include/intern.h
View File

@ -33,11 +33,11 @@ extern unsigned long Bignum_To_Unsigned_Long P_((Object));
extern long Bignum_To_Long P_((Object));
extern Object Bignum_To_String P_((Object, int));
extern double Bignum_To_Double P_((Object));
extern Bignum_Equal P_((Object, Object));
extern Bignum_Greater P_((Object, Object));
extern Bignum_Less P_((Object, Object));
extern Bignum_Eq_Less P_((Object, Object));
extern Bignum_Eq_Greater P_((Object, Object));
extern int Bignum_Equal P_((Object, Object));
extern int Bignum_Greater P_((Object, Object));
extern int Bignum_Less P_((Object, Object));
extern int Bignum_Eq_Less P_((Object, Object));
extern int Bignum_Eq_Greater P_((Object, Object));
/* cont.c
*/
@ -105,7 +105,7 @@ extern char *Flonum_To_String P_((Object));
/* proc.c
*/
extern Object Sym_Lambda, Sym_Macro;
extern Funcall_Control_Point P_((Object, Object, int));
extern void Funcall_Control_Point P_((Object, Object, int));
extern Object Make_Primitive
P_((Object(*)(ELLIPSIS), const char*, int, int, enum discipline));
@ -137,7 +137,7 @@ extern Object Unbound, Special, Zero, One;
/* type.c
*/
extern Num_Types, Max_Type;
extern int Num_Types, Max_Type;
/* vector.c
*/

2
include/misc.h
View File

@ -50,7 +50,7 @@ extern Object False2;
/* Used in special forms: */
extern int Tail_Call;
#define TC_Prolog register _t = Tail_Call
#define TC_Prolog register int _t = Tail_Call
#define TC_Disable Tail_Call = 0
#define TC_Enable Tail_Call = _t

5
include/object.h
View File

@ -45,7 +45,7 @@ typedef struct {
extern gcspace_t *space;
extern gcspace_t current_space;
C_LINKAGE_BEGIN
extern Visit P_((Object*)); /* required for REVIVE_OBJ below */
extern int Visit P_((Object*)); /* required for REVIVE_OBJ below */
C_LINKAGE_END
# ifdef ARRAY_BROKEN
@ -64,6 +64,9 @@ typedef struct {
(space[OBJ_TO_PAGE(obj)] == current_space))
# define REVIVE_OBJ(obj) Visit (&obj);
#else
C_LINKAGE_BEGIN
extern int Visit P_((Object*)); /* required in heap.c */
C_LINKAGE_END
# define IS_ALIVE(obj) WAS_FORWARDED(obj)
# define REVIVE_OBJ(obj)
#endif

4
include/type.h
View File

@ -10,14 +10,14 @@
}
#define Check_Number(x) {\
register t = TYPE(x);\
register int t = TYPE(x);\
if (!Numeric (t)) Wrong_Type_Combination (x, "number");\
}
/* This should be renamed; it checks whether x is an *exact* integer.
*/
#define Check_Integer(x) {\
register t = TYPE(x);\
register int t = TYPE(x);\
if (t != T_Fixnum && t != T_Bignum) Wrong_Type (x, T_Fixnum);\
}

18
lib/misc/bitstring.c
View File

@ -15,15 +15,15 @@ static int masks2[] = { 0, 0x1, 0x3, 0x7, 0xF, 0x1F, 0x3F, 0x7F, 0xFF };
int T_Bitstring;
static Object P_Bitstringp(x) Object x; {
static Object P_Bitstringp(Object x) {
return TYPE(x) == T_Bitstring ? True : False;
}
static int Bitstring_Size(b) Object b; {
static int Bitstring_Size(Object b) {
return sizeof(struct S_Bitstring) + bits_to_bytes(BITSTRING(b)->len) - 1;
}
static Bitstring_Equal(b1, b2) Object b1, b2; {
static Bitstring_Equal(Object b1, Object b2) {
struct S_Bitstring *a = BITSTRING(b1), *b = BITSTRING(b2);
if (a->len != b->len)
@ -31,11 +31,11 @@ static Bitstring_Equal(b1, b2) Object b1, b2; {
return !bcmp(a->data, b->data, bits_to_bytes(a->len));
}
static Object P_Bitstring_Equalp(a, b) Object a, b; {
static Object P_Bitstring_Equalp(Object a, Object b) {
return Bitstring_Equal(a, b) ? True : False;
}
static char *Digits(c, n) unsigned char c; int n; {
static char *Digits(unsigned char c, int n) {
static char buf[9];
int i = 0;
@ -47,7 +47,7 @@ static char *Digits(c, n) unsigned char c; int n; {
/* Print starting with MSB
*/
static Bitstring_Print(x, port, raw, depth, length) Object x, port; {
static Bitstring_Print(Object x, Object port, int raw, int depth, int length) {
int i, rem;
struct S_Bitstring *b = BITSTRING(x);
GC_Node2;
@ -62,7 +62,7 @@ static Bitstring_Print(x, port, raw, depth, length) Object x, port; {
GC_Unlink;
}
static Object Make_Bitstring(len) unsigned len; {
static Object Make_Bitstring(unsigned int len) {
Object b;
int nbytes = bits_to_bytes(len);
@ -73,7 +73,7 @@ static Object Make_Bitstring(len) unsigned len; {
return b;
}
static void Fill_Bitstring(bs, fill) Object bs; int fill; {
static void Fill_Bitstring(Object bs, int fill) {
struct S_Bitstring *b = BITSTRING(bs);
int i, rem;
unsigned char val = fill ? ~0 : 0;
@ -85,7 +85,7 @@ static void Fill_Bitstring(bs, fill) Object bs; int fill; {
b->data[i] = val;
}
static Object P_Make_Bitstring(len, init) Object len, init; {
static Object P_Make_Bitstring(Object len, Object init) {
Object ret;
int n, fill;

2
lib/misc/newhandler.c
View File

@ -10,7 +10,7 @@ static void New_Handler_Proc () {
(void)Funcall (New_Handler, Null, 0);
}
static Object P_Set_New_Handler (p) Object p; {
static Object P_Set_New_Handler (Object p) {
Object old;
Check_Procedure (p);

2
lib/unix/fdescr.c
View File

@ -249,7 +249,7 @@ static Object P_Ttyname(fd) Object fd; {
return ret ? Make_String(ret, strlen(ret)) : False;
}
elk_init_unix_fdescr() {
void elk_init_unix_fdescr() {
Def_Prim(P_Close, "unix-close", 1, 1, EVAL);
Def_Prim(P_Close_On_Exec, "unix-close-on-exec", 1, 2, VARARGS);
Def_Prim(P_Dup, "unix-dup", 1, 2, VARARGS);

10
lib/xlib/xlib.h
View File

@ -136,7 +136,7 @@ extern Pixmap Get_Pixmap P_((Object));
extern Time Get_Time P_((Object));
extern Window Get_Window P_((Object));
extern XColor *Get_Color P_((Object));
extern unsigned long Get_Pixel P_((Object));
extern unsigned long int Get_Pixel P_((Object));
extern void Destroy_Event_Args P_((Object));
extern int Encode_Event P_((Object));
extern int Match_X_Obj P_((ELLIPSIS));
@ -150,7 +150,7 @@ extern Object Make_Display P_((int, Display*));
extern Object Make_Font P_((Display*, Object, Font, XFontStruct*));
extern Object Make_Font_Foreign P_((Display*, Object, Font, XFontStruct*));
extern Object Make_Gc P_((int, Display*, GC));
extern Object Make_Pixel P_((unsigned long));
extern Object Make_Pixel P_((unsigned long int));
extern Object Make_Pixmap P_((Display*, Pixmap));
extern Object Make_Pixmap_Foreign P_((Display*, Pixmap));
extern Object Make_Window P_((int, Display*, Window));
@ -163,8 +163,8 @@ extern Object P_Free_Gc P_((Object));
extern Object P_Free_Pixmap P_((Object));
extern Object P_Window_Unique_Id P_((Object));
extern Object Record_To_Vector
P_((RECORD*, int, Object, Display*, unsigned long));
extern unsigned long Vector_To_Record P_((Object, int, Object, RECORD*));
P_((RECORD*, int, Object, Display*, unsigned long int));
extern unsigned long int Vector_To_Record P_((Object, int, Object, RECORD*));
C_LINKAGE_END
@ -178,7 +178,7 @@ extern XCharStruct CI;
extern XWMHints WMH;
extern XSizeHints SZH;
extern Set_Attr_Size, Conf_Size, GC_Size, Geometry_Size, Win_Attr_Size,
extern int Set_Attr_Size, Conf_Size, GC_Size, Geometry_Size, Win_Attr_Size,
Font_Info_Size, Char_Info_Size, Wm_Hints_Size, Size_Hints_Size;
extern RECORD Set_Attr_Rec[], Conf_Rec[], GC_Rec[], Geometry_Rec[],
Win_Attr_Rec[], Font_Info_Rec[], Char_Info_Rec[], Wm_Hints_Rec[],

22
scm/build
View File

@ -43,22 +43,22 @@ siteinfo.scm: ../config/system ../config/site
\$(SHELL) ./build-siteinfo
install: \$(TARGETS)
-@if [ ! -d $install_dir/lib ]; then \\
echo mkdir $install_dir/lib; \\
mkdir $install_dir/lib; \\
-@if [ ! -d $install_dir/share ]; then \\
echo mkdir $install_dir/share; \\
mkdir $install_dir/share; \\
fi
-@if [ ! -d $install_dir/lib/elk ]; then \\
echo mkdir $install_dir/lib/elk; \\
mkdir $install_dir/lib/elk; \\
-@if [ ! -d $install_dir/share/elk ]; then \\
echo mkdir $install_dir/share/elk; \\
mkdir $install_dir/share/elk; \\
fi
-@if [ ! -d $install_dir/lib/elk/scm ]; then \\
echo mkdir $install_dir/lib/elk/scm; \\
mkdir $install_dir/lib/elk/scm; \\
-@if [ ! -d $install_dir/share/elk/scm ]; then \\
echo mkdir $install_dir/share/elk/scm; \\
mkdir $install_dir/share/elk/scm; \\
fi
@for i in \$(FILES) ;\\
do \\
echo cp \$\$i $install_dir/lib/elk/scm; \\
cp \$\$i $install_dir/lib/elk/scm; \\
echo cp \$\$i $install_dir/share/elk/scm; \\
cp \$\$i $install_dir/share/elk/scm; \\
done
lint:

2
scm/initscheme.scm
View File

@ -33,6 +33,8 @@
(define call/cc call-with-current-continuation)
(define quit exit)
;;; Backwards compatibility. These procedures are really obsolete;
;;; please do not use them any longer.

6
src/autoload.c
View File

@ -2,11 +2,11 @@
Object V_Autoload_Notifyp;
Init_Auto () {
void Init_Auto (void) {
Define_Variable (&V_Autoload_Notifyp, "autoload-notify?", True);
}
Object P_Autoload (sym, files) Object sym, files; {
Object P_Autoload (Object sym, Object files) {
Object al, ret;
GC_Node3;
@ -24,7 +24,7 @@ Object P_Autoload (sym, files) Object sym, files; {
return ret;
}
Object Do_Autoload (sym, al) Object sym, al; {
Object Do_Autoload (Object sym, Object al) {
Object val, a[1];
GC_Node;

261
src/bignum.c
View File

@ -1,11 +1,16 @@
#include <math.h>
#include <ctype.h>
#include <string.h>
#include "kernel.h"
Object Make_Uninitialized_Bignum (size) {
static void Bignum_Mult_In_Place (register struct S_Bignum *, int);
static void Bignum_Add_In_Place (register struct S_Bignum *, int);
static int Bignum_Div_In_Place (register struct S_Bignum *, int);
Object Make_Uninitialized_Bignum (int size) {
Object big;
big = Alloc_Object ((sizeof (struct S_Bignum) - sizeof (gran_t)) +
(size * sizeof (gran_t)), T_Bignum, 0);
BIGNUM(big)->minusp = False;
@ -14,43 +19,41 @@ Object Make_Uninitialized_Bignum (size) {
return big;
}
Object Copy_Bignum (x) Object x; {
Object Copy_Bignum (Object x) {
Object big;
register size;
register int size;
GC_Node;
GC_Link (x);
big = Make_Uninitialized_Bignum (size = BIGNUM(x)->usize);
BIGNUM(big)->minusp = BIGNUM(x)->minusp;
BIGNUM(big)->usize = size;
bcopy ((char *)BIGNUM(x)->data, (char *)BIGNUM(big)->data,
size * sizeof (gran_t));
memcpy (BIGNUM(big)->data, BIGNUM(x)->data, size * sizeof (gran_t));
GC_Unlink;
return big;
}
Object Copy_S_Bignum (s) struct S_Bignum *s; {
Object Copy_S_Bignum (struct S_Bignum *s) {
Object big;
register size;
register int size;
big = Make_Uninitialized_Bignum (size = s->usize);
BIGNUM(big)->minusp = s->minusp;
BIGNUM(big)->usize = size;
bcopy ((char *)s->data, (char *)BIGNUM(big)->data,
size * sizeof (gran_t));
memcpy (BIGNUM(big)->data, s->data, size * sizeof (gran_t));
return big;
}
Object Make_Bignum (buf, neg, radix) const char *buf; {
Object Make_Bignum (char const *buf, int neg, int radix) {
Object big;
register const char *p;
register c;
register size = (strlen (buf) + 4) / 4;
register char const *p;
register int c;
register int size = (strlen (buf) + 4) / 4;
big = Make_Uninitialized_Bignum (size);
BIGNUM(big)->minusp = neg ? True : False;
p = buf;
while (c = *p++) {
while ((c = *p++)) {
Bignum_Mult_In_Place (BIGNUM(big), radix);
if (radix == 16) {
if (isupper (c))
@ -64,32 +67,32 @@ Object Make_Bignum (buf, neg, radix) const char *buf; {
return big;
}
Object Reduce_Bignum (x) Object x; {
unsigned ret = 0;
Object Reduce_Bignum (Object x) {
unsigned int ret = 0;
int i, shift = 0, size = BIGNUM(x)->usize;
int digits = sizeof(int)/2;
if (size > digits)
return x;
for (i = 0; i < digits && i < size; i++, shift += 16)
ret |= (unsigned)BIGNUM(x)->data[i] << shift;
ret |= (unsigned int)BIGNUM(x)->data[i] << shift;
if (Truep (BIGNUM(x)->minusp)) {
if (ret > (~(unsigned)0 >> 1) + 1)
if (ret > (~(unsigned int)0 >> 1) + 1)
return x;
return Make_Integer (-ret);
} else {
if (ret > ~(unsigned)0 >> 1)
if (ret > ~(unsigned int)0 >> 1)
return x;
return Make_Integer (ret);
}
}
Bignum_Mult_In_Place (x, n) register struct S_Bignum *x; {
register i = x->usize;
static void Bignum_Mult_In_Place (register struct S_Bignum *x, int n) {
register int i = x->usize;
register gran_t *p = x->data;
register j;
register unsigned k = 0;
register int j;
register unsigned int k = 0;
for (j = 0; j < i; ++j) {
k += n * *p;
*p++ = k;
@ -103,11 +106,11 @@ Bignum_Mult_In_Place (x, n) register struct S_Bignum *x; {
}
}
Bignum_Add_In_Place (x, n) register struct S_Bignum *x; {
register i = x->usize;
static void Bignum_Add_In_Place (register struct S_Bignum *x, int n) {
register int i = x->usize;
register gran_t *p = x->data;
register j = 0;
register unsigned k = n;
register int j = 0;
register unsigned int k = n;
if (i == 0) goto extend;
k += *p;
@ -126,10 +129,10 @@ Bignum_Add_In_Place (x, n) register struct S_Bignum *x; {
}
}
Bignum_Div_In_Place (x, n) register struct S_Bignum *x; {
register i = x->usize;
static int Bignum_Div_In_Place (register struct S_Bignum *x, int n) {
register int i = x->usize;
register gran_t *p = x->data + i;
register unsigned k = 0;
register unsigned int k = 0;
for ( ; i; --i) {
k <<= 16;
k += *--p;
@ -140,8 +143,8 @@ Bignum_Div_In_Place (x, n) register struct S_Bignum *x; {
return k;
}
Bignum_Normalize_In_Place (x) register struct S_Bignum *x; {
register i = x->usize;
void Bignum_Normalize_In_Place (register struct S_Bignum *x) {
register int i = x->usize;
register gran_t *p = x->data + i;
while (i && !*--p)
--i;
@ -150,18 +153,18 @@ Bignum_Normalize_In_Place (x) register struct S_Bignum *x; {
x->minusp = False;
}
Print_Bignum (port, x) Object port, x; {
void Print_Bignum (Object port, Object x) {
register char *p;
char *buf;
register size;
register int size;
struct S_Bignum *big;
Alloca_Begin;
if (Bignum_Zero (x)) {
Printf (port, "0");
return;
}
size = BIGNUM(x)->usize * 5 + 3;
Alloca (buf, char*, size + 1);
p = buf + size;
@ -170,11 +173,11 @@ Print_Bignum (port, x) Object port, x; {
size = (sizeof (struct S_Bignum) - sizeof (gran_t))
+ BIGNUM(x)->usize * sizeof (gran_t);
Alloca (big, struct S_Bignum*, size);
bcopy ((char *)POINTER(x), (char *)big, size);
memcpy (big, POINTER(x), size);
big->size = BIGNUM(x)->usize;
while (big->usize) {
register unsigned bigdig = Bignum_Div_In_Place (big, 10000);
register unsigned int bigdig = Bignum_Div_In_Place (big, 10000);
*--p = '0' + bigdig % 10;
bigdig /= 10;
*--p = '0' + bigdig % 10;
@ -191,17 +194,17 @@ Print_Bignum (port, x) Object port, x; {
Alloca_End;
}
Object Bignum_To_String (x, radix) Object x; {
Object Bignum_To_String (Object x, int radix) {
register char *p;
char *buf;
register unsigned div, ndig, size;
register unsigned int div, ndig, size;
struct S_Bignum *big;
Object ret;
Alloca_Begin;
if (Bignum_Zero (x))
return Make_String ("0", 1);
size = BIGNUM(x)->usize * (radix == 2 ? 17 : 6) + 3;
Alloca (buf, char*, size + 1);
p = buf + size;
@ -210,7 +213,7 @@ Object Bignum_To_String (x, radix) Object x; {
size = (sizeof (struct S_Bignum) - sizeof (gran_t))
+ BIGNUM(x)->usize * sizeof (gran_t);
Alloca (big, struct S_Bignum*, size);
bcopy ((char *)POINTER(x), (char *)big, size);
memcpy (big, POINTER(x), size);
big->size = BIGNUM(x)->usize;
switch (radix) {
@ -221,12 +224,13 @@ Object Bignum_To_String (x, radix) Object x; {
case 10:
div = 10000; ndig = 4; break;
case 16:
default: /* Just to avoid compiler warnings */
div = 65536; ndig = 4; break;
}
while (big->usize) {
register unsigned bigdig = Bignum_Div_In_Place (big, div);
register i;
register unsigned int bigdig = Bignum_Div_In_Place (big, div);
register int i;
for (i = 0; i < ndig; i++) {
*--p = '0' + bigdig % radix;
if (*p > '9')
@ -243,8 +247,8 @@ Object Bignum_To_String (x, radix) Object x; {
return ret;
}
Bignum_To_Integer (x) Object x; {
unsigned ret = 0;
int Bignum_To_Integer (Object x) {
unsigned int ret = 0;
int i, shift = 0, size = BIGNUM(x)->usize;
int digits = sizeof(int)/2;
@ -252,32 +256,32 @@ Bignum_To_Integer (x) Object x; {
err:
Primitive_Error ("integer out of range: ~s", x);
for (i = 0; i < digits && i < size; i++, shift += 16)
ret |= (unsigned)BIGNUM(x)->data[i] << shift;
ret |= (unsigned int)BIGNUM(x)->data[i] << shift;
if (Truep (BIGNUM(x)->minusp)) {
if (ret > (~(unsigned)0 >> 1) + 1)
if (ret > (~(unsigned int)0 >> 1) + 1)
goto err;
return -ret;
} else {
if (ret > ~(unsigned)0 >> 1)
if (ret > ~(unsigned int)0 >> 1)
goto err;
return ret;
}
}
unsigned Bignum_To_Unsigned (x) Object x; {
unsigned ret = 0;
unsigned int Bignum_To_Unsigned (Object x) {
unsigned int ret = 0;
int i, shift = 0, size = BIGNUM(x)->usize;
int digits = sizeof(int)/2;
if (size > digits || Truep (BIGNUM(x)->minusp))
Primitive_Error ("integer out of range: ~s", x);
for (i = 0; i < digits && i < size; i++, shift += 16)
ret |= (unsigned)BIGNUM(x)->data[i] << shift;
ret |= (unsigned int)BIGNUM(x)->data[i] << shift;
return ret;
}
long Bignum_To_Long (x) Object x; {
unsigned long ret = 0;
long Bignum_To_Long (Object x) {
unsigned long int ret = 0;
int i, shift = 0, size = BIGNUM(x)->usize;
int digits = sizeof(long)/2;
@ -285,34 +289,34 @@ long Bignum_To_Long (x) Object x; {
err:
Primitive_Error ("integer out of range: ~s", x);
for (i = 0; i < digits && i < size; i++, shift += 16)
ret |= (unsigned long)BIGNUM(x)->data[i] << shift;
ret |= (unsigned long int)BIGNUM(x)->data[i] << shift;
if (Truep (BIGNUM(x)->minusp)) {
if (ret > (~(unsigned long)0 >> 1) + 1)
if (ret > (~(unsigned long int)0 >> 1) + 1)
goto err;
return -ret;
} else {
if (ret > ~(unsigned long)0 >> 1)
if (ret > ~(unsigned long int)0 >> 1)
goto err;
return ret;
}
}
unsigned long Bignum_To_Unsigned_Long (x) Object x; {
unsigned long ret = 0;
unsigned long int Bignum_To_Unsigned_Long (Object x) {
unsigned long int ret = 0;
int i, shift = 0, size = BIGNUM(x)->usize;
int digits = sizeof(long)/2;
if (size > digits || Truep (BIGNUM(x)->minusp))
Primitive_Error ("integer out of range: ~s", x);
for (i = 0; i < digits && i < size; i++, shift += 16)
ret |= (unsigned long)BIGNUM(x)->data[i] << shift;
ret |= (unsigned long int)BIGNUM(x)->data[i] << shift;
return ret;
}
Object Integer_To_Bignum (i) {
Object Integer_To_Bignum (int i) {
int k, digits = sizeof(int)/2;
Object big;
unsigned n = i;
Object big;
unsigned int n = i;
big = Make_Uninitialized_Bignum (digits);
if (i < 0) {
@ -326,10 +330,10 @@ Object Integer_To_Bignum (i) {
return big;
}
Object Unsigned_To_Bignum (i) unsigned i; {
Object Unsigned_To_Bignum (unsigned int i) {
int k, digits = sizeof(int)/2;
Object big;
big = Make_Uninitialized_Bignum (digits);
for (k = 0; k < digits; k++, i >>= 16)
BIGNUM(big)->data[k] = i & 0xffff;
@ -338,10 +342,10 @@ Object Unsigned_To_Bignum (i) unsigned i; {
return big;
}
Object Long_To_Bignum (i) long i; {
Object Long_To_Bignum (long i) {
int k, digits = sizeof(long)/2;
Object big;
unsigned long n = i;
unsigned long int n = i;
big = Make_Uninitialized_Bignum (digits);
if (i < 0) {
@ -355,10 +359,10 @@ Object Long_To_Bignum (i) long i; {
return big;
}
Object Unsigned_Long_To_Bignum (i) unsigned long i; {
Object Unsigned_Long_To_Bignum (unsigned long int i) {
int k, digits = sizeof(long)/2;
Object big;
big = Make_Uninitialized_Bignum (digits);
for (k = 0; k < digits; k++, i >>= 16)
BIGNUM(big)->data[k] = i & 0xffff;
@ -367,12 +371,12 @@ Object Unsigned_Long_To_Bignum (i) unsigned long i; {
return big;
}
Object Double_To_Bignum (d) double d; { /* Truncates the double */
Object Double_To_Bignum (double d) { /* Truncates the double */
Object big;
int expo, size;
double mantissa = frexp (d, &expo);
register gran_t *p;
if (expo <= 0 || mantissa == 0.0)
return Make_Uninitialized_Bignum (0);
size = (expo + (16-1)) / 16;
@ -383,7 +387,7 @@ Object Double_To_Bignum (d) double d; { /* Truncates the double */
mantissa = -mantissa;
}
p = BIGNUM(big)->data;
bzero ((char *)p, size * sizeof (gran_t));
memset (p, 0, size * sizeof (gran_t));
p += size;
if (expo &= (16-1))
mantissa = ldexp (mantissa, expo - 16);
@ -398,9 +402,9 @@ Object Double_To_Bignum (d) double d; { /* Truncates the double */
return Reduce_Bignum (big);
}
double Bignum_To_Double (x) Object x; { /* error if it ain't fit */
double Bignum_To_Double (Object x) { /* error if it ain't fit */
double rx = 0.0;
register i = BIGNUM(x)->usize;
register int i = BIGNUM(x)->usize;
register gran_t *p = BIGNUM(x)->data + i;
for (i = BIGNUM(x)->usize; --i >= 0; ) {
@ -414,23 +418,23 @@ double Bignum_To_Double (x) Object x; { /* error if it ain't fit */
return rx;
}
Bignum_Zero (x) Object x; {
int Bignum_Zero (Object x) {
return BIGNUM(x)->usize == 0;
}
Bignum_Negative (x) Object x; {
int Bignum_Negative (Object x) {
return Truep (BIGNUM(x)->minusp);
}
Bignum_Positive (x) Object x; {
int Bignum_Positive (Object x) {
return !Truep (BIGNUM(x)->minusp) && BIGNUM(x)->usize != 0;
}
Bignum_Even (x) Object x; {
int Bignum_Even (Object x) {
return BIGNUM(x)->usize == 0 || (BIGNUM(x)->data[0] & 1) == 0;
}
Object Bignum_Abs (x) Object x; {
Object Bignum_Abs (Object x) {
Object big;
big = Copy_Bignum (x);
@ -438,8 +442,9 @@ Object Bignum_Abs (x) Object x; {
return big;
}
Bignum_Mantissa_Cmp (x, y) register struct S_Bignum *x, *y; {
register i = x->usize;
int Bignum_Mantissa_Cmp (register struct S_Bignum *x,
register struct S_Bignum *y) {
register int i = x->usize;
if (i < y->usize)
return -1;
else if (i > y->usize)
@ -448,17 +453,17 @@ Bignum_Mantissa_Cmp (x, y) register struct S_Bignum *x, *y; {
register gran_t *xbuf = x->data + i;
register gran_t *ybuf = y->data + i;
for ( ; i; --i) {
register n;
if (n = (int)*--xbuf - (int)*--ybuf)
register int n;
if ((n = (int)*--xbuf - (int)*--ybuf))
return n;
}
return 0;
}
}
Bignum_Cmp (x, y) register struct S_Bignum *x, *y; {
register xm = Truep (x->minusp);
register ym = Truep (y->minusp);
int Bignum_Cmp (register struct S_Bignum *x, register struct S_Bignum *y) {
register int xm = Truep (x->minusp);
register int ym = Truep (y->minusp);
if (xm) {
if (ym)
return -Bignum_Mantissa_Cmp (x, y);
@ -470,27 +475,27 @@ Bignum_Cmp (x, y) register struct S_Bignum *x, *y; {
}
}
Bignum_Equal (x, y) Object x, y; {
int Bignum_Equal (Object x, Object y) {
return Bignum_Cmp (BIGNUM(x), BIGNUM(y)) == 0;
}
Bignum_Less (x, y) Object x, y; {
int Bignum_Less (Object x, Object y) {
return Bignum_Cmp (BIGNUM(x), BIGNUM(y)) < 0;
}
Bignum_Greater (x, y) Object x, y; {
int Bignum_Greater (Object x, Object y) {
return Bignum_Cmp (BIGNUM(x), BIGNUM(y)) > 0;
}
Bignum_Eq_Less (x, y) Object x, y; {
int Bignum_Eq_Less (Object x, Object y) {
return Bignum_Cmp (BIGNUM(x), BIGNUM(y)) <= 0;
}
Bignum_Eq_Greater (x, y) Object x, y; {
int Bignum_Eq_Greater (Object x, Object y) {
return Bignum_Cmp (BIGNUM(x), BIGNUM(y)) >= 0;
}
Object General_Bignum_Plus_Minus (x, y, neg) Object x, y; {
Object General_Bignum_Plus_Minus (Object x, Object y, int neg) {
Object big;
int size, xsize, ysize, xminusp, yminusp;
GC_Node2;
@ -511,8 +516,8 @@ Object General_Bignum_Plus_Minus (x, y, neg) Object x, y; {
if (xminusp == yminusp) {
/* Add x and y */
register unsigned k = 0;
register i;
register unsigned int k = 0;
register int i;
register gran_t *xbuf = BIGNUM(x)->data;
register gran_t *ybuf = BIGNUM(y)->data;
register gran_t *zbuf = BIGNUM(big)->data;
@ -527,7 +532,7 @@ Object General_Bignum_Plus_Minus (x, y, neg) Object x, y; {
} else {
if (Bignum_Mantissa_Cmp (BIGNUM(x), BIGNUM(y)) < 0) {
Object temp;
temp = x; x = y; y = temp;
xsize = ysize;
ysize = BIGNUM(y)->usize;
@ -535,8 +540,8 @@ Object General_Bignum_Plus_Minus (x, y, neg) Object x, y; {
}
/* Subtract y from x */
{
register unsigned k = 1;
register i;
register unsigned int k = 1;
register int i;
register gran_t *xbuf = BIGNUM(x)->data;
register gran_t *ybuf = BIGNUM(y)->data;
register gran_t *zbuf = BIGNUM(big)->data;
@ -557,22 +562,22 @@ Object General_Bignum_Plus_Minus (x, y, neg) Object x, y; {
return Reduce_Bignum (big);
}
Object Bignum_Plus (x, y) Object x, y; { /* bignum + bignum */
Object Bignum_Plus (Object x, Object y) { /* bignum + bignum */
return General_Bignum_Plus_Minus (x, y, 0);
}
Object Bignum_Minus (x, y) Object x, y; { /* bignum - bignum */
Object Bignum_Minus (Object x, Object y) { /* bignum - bignum */
return General_Bignum_Plus_Minus (x, y, 1);
}
Object Bignum_Fixnum_Multiply (x, y) Object x, y; { /* bignum * fixnum */
Object Bignum_Fixnum_Multiply (Object x, Object y) { /* bignum * fixnum */
Object big;
register size, xsize, i;
register int size, xsize, i;
register gran_t *xbuf, *zbuf;
int fix = FIXNUM(y);
register unsigned yl, yh;
register unsigned int yl, yh;
GC_Node;
GC_Link (x);
xsize = BIGNUM(x)->usize;
size = xsize + 2;
@ -580,7 +585,7 @@ Object Bignum_Fixnum_Multiply (x, y) Object x, y; { /* bignum * fixnum */
BIGNUM(big)->usize = size;
if (Truep (BIGNUM(x)->minusp) != (fix < 0))
BIGNUM(big)->minusp = True;
bzero ((char *)BIGNUM(big)->data, size * sizeof (gran_t));
memset (BIGNUM(big)->data, 0, size * sizeof (gran_t));
xbuf = BIGNUM(x)->data;
if (fix < 0)
fix = -fix;
@ -588,8 +593,8 @@ Object Bignum_Fixnum_Multiply (x, y) Object x, y; { /* bignum * fixnum */
yh = fix >> 16;
zbuf = BIGNUM(big)->data;
for (i = 0; i < xsize; ++i) {
register unsigned xf = xbuf[i];
register unsigned k = 0;
register unsigned int xf = xbuf[i];
register unsigned int k = 0;
register gran_t *r = zbuf + i;
k += xf * yl + *r;
*r++ = k;
@ -604,12 +609,12 @@ Object Bignum_Fixnum_Multiply (x, y) Object x, y; { /* bignum * fixnum */
return Reduce_Bignum (big);
}
Object Bignum_Multiply (x, y) Object x, y; { /* bignum * bignum */
Object Bignum_Multiply (Object x, Object y) { /* bignum * bignum */
Object big;
register size, xsize, ysize, i, j;
register int size, xsize, ysize, i, j;
register gran_t *xbuf, *ybuf, *zbuf;
GC_Node2;
GC_Link2 (x, y);
xsize = BIGNUM(x)->usize;
ysize = BIGNUM(y)->usize;
@ -618,13 +623,13 @@ Object Bignum_Multiply (x, y) Object x, y; { /* bignum * bignum */
BIGNUM(big)->usize = size;
if (!EQ(BIGNUM(x)->minusp, BIGNUM(y)->minusp))
BIGNUM(big)->minusp = True;
bzero ((char *)BIGNUM(big)->data, size * sizeof (gran_t));
memset (BIGNUM(big)->data, 0, size * sizeof (gran_t));
xbuf = BIGNUM(x)->data;
ybuf = BIGNUM(y)->data;
zbuf = BIGNUM(big)->data;
for (i = 0; i < xsize; ++i) {
register unsigned xf = xbuf[i];
register unsigned k = 0;
register unsigned int xf = xbuf[i];
register unsigned int k = 0;
register gran_t *p = ybuf;
register gran_t *r = zbuf + i;
for (j = 0; j < ysize; ++j) {
@ -641,13 +646,13 @@ Object Bignum_Multiply (x, y) Object x, y; { /* bignum * bignum */
/* Returns cons cell (quotient . remainder); cdr is a fixnum
*/
Object Bignum_Fixnum_Divide (x, y) Object x, y; { /* bignum / fixnum */
Object Bignum_Fixnum_Divide (Object x, Object y) { /* bignum / fixnum */
Object big;
register xsize, i;
register int xsize, i;
register gran_t *xbuf, *zbuf;
int fix = FIXNUM(y);
int xminusp, yminusp = 0;
register unsigned rem;
register unsigned int rem;
GC_Node;
GC_Link (x);
@ -684,10 +689,10 @@ Object Bignum_Fixnum_Divide (x, y) Object x, y; { /* bignum / fixnum */
/* Returns cons cell (quotient . remainder); cdr is a fixnum
*/
Object Bignum_Divide (x, y) Object x, y; { /* bignum / bignum */
Object Bignum_Divide (Object x, Object y) { /* bignum / bignum */
struct S_Bignum *dend, *dor;
int quotsize, dendsize, dorsize, scale;
unsigned dor1, dor2;
unsigned int dor1, dor2;
Object quot, rem;
register gran_t *qp, *dendp;
GC_Node2;
@ -706,7 +711,7 @@ Object Bignum_Divide (x, y) Object x, y; { /* bignum / bignum */
dendsize = (sizeof (struct S_Bignum) - sizeof (gran_t))
+ (BIGNUM(x)->usize + 1) * sizeof (gran_t);
Alloca (dend, struct S_Bignum*, dendsize);
bcopy ((char *)POINTER(x), (char *)dend, dendsize);
memcpy (dend, POINTER(x), dendsize);
dend->size = BIGNUM(x)->usize + 1;
if (quotsize == 0 || Bignum_Mantissa_Cmp (dend, BIGNUM(y)) < 0)
@ -715,7 +720,7 @@ Object Bignum_Divide (x, y) Object x, y; { /* bignum / bignum */
dorsize = (sizeof (struct S_Bignum) - sizeof (gran_t))
+ BIGNUM (y)->usize * sizeof (gran_t);
Alloca (dor, struct S_Bignum*, dorsize);
bcopy ((char *)POINTER(y), (char *)dor, dorsize);
memcpy (dor, POINTER(y), dorsize);
dor->size = dorsize = BIGNUM(y)->usize;
scale = 65536 / (unsigned int)(dor->data[dor->usize - 1] + 1);
@ -729,18 +734,18 @@ Object Bignum_Divide (x, y) Object x, y; { /* bignum / bignum */
dendp = dend->data + dend->usize;
dor1 = dor->data[dor->usize - 1];
dor2 = dor->data[dor->usize - 2];
while (qp > BIGNUM(quot)->data) {
unsigned msw, guess;
unsigned int msw, guess;
int k;
register gran_t *dep, *dop, *edop;
msw = dendp[-1] << 16 | dendp[-2];
guess = msw / dor1;
if (guess >= 65536) /* [65535, 0, 0] / [65535, 65535] */
guess = 65535;
for (;;) {
unsigned d1, d2, d3;
unsigned int d1, d2, d3;
d3 = dor2 * guess;
d2 = dor1 * guess + (d3 >> 16);
d3 &= 0xFFFF;
@ -756,7 +761,7 @@ Object Bignum_Divide (x, y) Object x, y; { /* bignum / bignum */
k = 0;
dep = dendp - dorsize;
for (dop = dor->data, edop = dop + dor->usize; dop < edop; ) {
register unsigned prod = *dop++ * guess;
register unsigned int prod = *dop++ * guess;
k += *dep;
k -= prod & 0xFFFF;
*dep++ = k;
@ -779,7 +784,7 @@ Object Bignum_Divide (x, y) Object x, y; { /* bignum / bignum */
}
*--qp = guess;
}
if (Bignum_Div_In_Place (dend, scale))
Panic ("Bignum_Div scale");
zero:

24
src/bool.c
View File

@ -1,27 +1,31 @@
#include "kernel.h"
Object P_Booleanp (x) Object x; {
#include <string.h>
extern int Generic_Equal (Object, Object);
Object P_Booleanp (Object x) {
return TYPE(x) == T_Boolean ? True : False;
}
Object P_Not (x) Object x; {
Object P_Not (Object x) {
return Truep (x) ? False : True;
}
Object P_Eq (x1, x2) Object x1, x2; {
Object P_Eq (Object x1, Object x2) {
return EQ(x1, x2) ? True : False;
}
Object P_Eqv (x1, x2) Object x1, x2; {
Object P_Eqv (Object x1, Object x2) {
return Eqv (x1, x2) ? True : False;
}
Object P_Equal (x1, x2) Object x1, x2; {
Object P_Equal (Object x1, Object x2) {
return Equal (x1, x2) ? True : False;
}
Eqv (x1, x2) Object x1, x2; {
register t1, t2;
int Eqv (Object x1, Object x2) {
register int t1, t2;
if (EQ(x1, x2))
return 1;
t1 = TYPE(x1);
@ -47,8 +51,8 @@ Eqv (x1, x2) Object x1, x2; {
/*NOTREACHED*/
}
Equal (x1, x2) Object x1, x2; {
register t1, t2, i;
int Equal (Object x1, Object x2) {
register int t1, t2, i;
again:
if (EQ(x1, x2))
@ -104,7 +108,7 @@ again:
/*NOTREACHED*/
}
Object P_Empty_List_Is_False (is_false) Object is_false; {
Object P_Empty_List_Is_False (Object is_false) {
Check_Type (is_false, T_Boolean);
if (Truep (is_false))
False2 = Null;

48
src/char.c
View File

@ -2,69 +2,69 @@
#include "kernel.h"
Object Make_Char (c) register c; {
Object Make_Char (register int c) {
Object ch;
SET(ch, T_Character, (unsigned char)c);
return ch;
}
Object P_Charp (c) Object c; {
Object P_Charp (Object c) {
return TYPE(c) == T_Character ? True : False;
}
Object P_Char_To_Integer (c) Object c; {
Object P_Char_To_Integer (Object c) {
Check_Type (c, T_Character);
return Make_Integer (CHAR(c));
}
Object P_Integer_To_Char (n) Object n; {
register i;
Object P_Integer_To_Char (Object n) {
register int i;
if ((i = Get_Exact_Integer (n)) < 0 || i > 255)
Range_Error (n);
return Make_Char (i);
}
Object P_Char_Upper_Casep (c) Object c; {
Object P_Char_Upper_Casep (Object c) {
Check_Type (c, T_Character);
return isupper (CHAR(c)) ? True : False;
}
Object P_Char_Lower_Casep (c) Object c; {
Object P_Char_Lower_Casep (Object c) {
Check_Type (c, T_Character);
return islower (CHAR(c)) ? True : False;
}
Object P_Char_Alphabeticp (c) Object c; {
Object P_Char_Alphabeticp (Object c) {
Check_Type (c, T_Character);
return isalpha (CHAR(c)) ? True : False;
}
Object P_Char_Numericp (c) Object c; {
Object P_Char_Numericp (Object c) {
Check_Type (c, T_Character);
return isdigit (CHAR(c)) ? True : False;
}
Object P_Char_Whitespacep (c) Object c; {
register x;
Object P_Char_Whitespacep (Object c) {
register int x;
Check_Type (c, T_Character);
x = CHAR(c);
return Whitespace (x) ? True : False;
}
Object P_Char_Upcase (c) Object c; {
Object P_Char_Upcase (Object c) {
Check_Type (c, T_Character);
return islower (CHAR(c)) ? Make_Char (toupper (CHAR(c))) : c;
}
Object P_Char_Downcase (c) Object c; {
Object P_Char_Downcase (Object c) {
Check_Type (c, T_Character);
return isupper (CHAR(c)) ? Make_Char (tolower (CHAR(c))) : c;
}
General_Chrcmp (c1, c2, ci) Object c1, c2; register ci; {
int General_Chrcmp (Object c1, Object c2, register int ci) {
Check_Type (c1, T_Character);
Check_Type (c2, T_Character);
if (ci)
@ -72,42 +72,42 @@ General_Chrcmp (c1, c2, ci) Object c1, c2; register ci; {
return CHAR(c1) - CHAR(c2);
}
Object P_Char_Eq (c1, c2) Object c1, c2; {
Object P_Char_Eq (Object c1, Object c2) {
return General_Chrcmp (c1, c2, 0) ? False : True;
}
Object P_Char_Less (c1, c2) Object c1, c2; {
Object P_Char_Less (Object c1, Object c2) {
return General_Chrcmp (c1, c2, 0) < 0 ? True : False;
}
Object P_Char_Greater (c1, c2) Object c1, c2; {
Object P_Char_Greater (Object c1, Object c2) {
return General_Chrcmp (c1, c2, 0) > 0 ? True : False;
}
Object P_Char_Eq_Less (c1, c2) Object c1, c2; {
Object P_Char_Eq_Less (Object c1, Object c2) {
return General_Chrcmp (c1, c2, 0) <= 0 ? True : False;
}
Object P_Char_Eq_Greater (c1, c2) Object c1, c2; {
Object P_Char_Eq_Greater (Object c1, Object c2) {
return General_Chrcmp (c1, c2, 0) >= 0 ? True : False;
}
Object P_Char_CI_Eq (c1, c2) Object c1, c2; {
Object P_Char_CI_Eq (Object c1, Object c2) {
return General_Chrcmp (c1, c2, 1) ? False : True;
}
Object P_Char_CI_Less (c1, c2) Object c1, c2; {
Object P_Char_CI_Less (Object c1, Object c2) {
return General_Chrcmp (c1, c2, 1) < 0 ? True : False;
}
Object P_Char_CI_Greater (c1, c2) Object c1, c2; {
Object P_Char_CI_Greater (Object c1, Object c2) {
return General_Chrcmp (c1, c2, 1) > 0 ? True : False;
}
Object P_Char_CI_Eq_Less (c1, c2) Object c1, c2; {
Object P_Char_CI_Eq_Less (Object c1, Object c2) {
return General_Chrcmp (c1, c2, 1) <= 0 ? True : False;
}
Object P_Char_CI_Eq_Greater (c1, c2) Object c1, c2; {
Object P_Char_CI_Eq_Greater (Object c1, Object c2) {
return General_Chrcmp (c1, c2, 1) >= 0 ? True : False;
}

49
src/cont.c
View File

@ -3,6 +3,13 @@
#include "kernel.h"
#include <string.h>
extern void Switch_Environment (Object);
void Jump_Cont (struct S_Control *, Object);
void Do_Wind (Object);
/* The C library versions of longjmp on the VAX and the Convex unwind
* the stack. As Jump_Cont below installs a new stack before calling
* longjmp, the standard version cannot be used. The following simplistic
@ -45,7 +52,7 @@
#endif
#if defined(convex) || defined(__convex__)
convex_longjmp (p, i) char *p; {
convex_longjmp (char *p, int i) {
__asm__("ld.w 4(ap),s0");
__asm__("ld.w 0(ap),a1");
__asm__("ld.w 12(a1),a7");
@ -66,7 +73,7 @@ static Object Cont_Value;
static Object Cont_GCsave;
#endif
Check_Stack_Grows_Down () {
int Check_Stack_Grows_Down () {
char foo;
return &foo < stkbase;
@ -82,22 +89,22 @@ unsigned int Stack_Size () {
return Stack_Grows_Down ? stkbase-&foo : &foo-stkbase;
}
Grow_Stack (cp, val) struct S_Control *cp; Object val; {
void Grow_Stack (struct S_Control *cp, Object val) {
char buf[100];
/* Prevent the optimizer from optimizing buf away:
*/
bzero (buf, 1);
memset (buf, 0, 1);
Jump_Cont (cp, val);
}
Jump_Cont (cp, val) struct S_Control *cp; Object val; {
void Jump_Cont (struct S_Control *cp, Object val) {
static struct S_Control *p;
static char *from, *to; /* Must not be allocated on stack */
static i; /* Ditto */
static int i; /* Ditto */
char foo;
/* Reinstall the saved stack contents; take stack direction
* into account. cp must be put into a static variable, as
* variables living on the stack cannot be referenced any
@ -126,18 +133,18 @@ Jump_Cont (cp, val) struct S_Control *cp; Object val; {
}
#ifndef USE_ALLOCA
Object Terminate_Cont (cont) Object cont; {
Object Terminate_Cont (Object cont) {
Free_Mem_Nodes (CONTROL(cont)->memlist);
return Void;
}
#endif
Object P_Control_Pointp (x) Object x; {
Object P_Control_Pointp (Object x) {
return TYPE(x) == T_Control_Point ? True : False;
}
Object P_Call_With_Current_Continuation (proc) Object proc; {
register t;
Object P_Call_With_Current_Continuation (Object proc) {
register int t;
t = TYPE(proc);
if (t != T_Primitive && t != T_Compound && t != T_Control_Point)
@ -145,11 +152,11 @@ Object P_Call_With_Current_Continuation (proc) Object proc; {
return Internal_Call_CC (0, proc);
}
Object Internal_Call_CC (from_dump, proc) int from_dump; Object proc; {
Object Internal_Call_CC (int from_dump, Object proc) {
Object control, ret, gcsave;
register struct S_Control *cp;
register char *p, *to;
register size;
register int size;
GC_Node3;
control = gcsave = Null;
@ -182,7 +189,7 @@ Object Internal_Call_CC (from_dump, proc) int from_dump; Object proc; {
*/
p = Stack_Grows_Down ? stkbase - cp->size : stkbase;
to = cp->stack;
bcopy (p, to, cp->size);
memcpy (to, p, cp->size);
cp->delta = to - p;
#ifndef USE_ALLOCA
Register_Object (control, (GENERIC)0, Terminate_Cont, 0);
@ -212,11 +219,11 @@ Object Internal_Call_CC (from_dump, proc) int from_dump; Object proc; {
return ret;
}
Funcall_Control_Point (control, argl, eval) Object control, argl; {
void Funcall_Control_Point (Object control, Object argl, int eval) {
Object val, len;
register struct S_Control *cp;
register WIND *w, *wp, *cwp, *p;
register delta = 0;
register int delta = 0;
GC_Node3;
if (GC_In_Progress)
@ -264,7 +271,7 @@ Funcall_Control_Point (control, argl, eval) Object control, argl; {
/*NOTREACHED*/
}
Do_Wind (w) Object w; {
void Do_Wind (Object w) {
Object oldenv, b, tmp;
if (TYPE(w) == T_Vector) { /* fluid-let */
@ -284,7 +291,7 @@ Do_Wind (w) Object w; {
}
}
Add_Wind (w, in, out) register WIND *w; Object in, out; {
void Add_Wind (register WIND *w, Object in, Object out) {
Object inout;
GC_Node2;
@ -301,7 +308,7 @@ Add_Wind (w, in, out) register WIND *w; Object in, out; {
GC_Unlink;
}
Object P_Dynamic_Wind (in, body, out) Object in, body, out; {
Object P_Dynamic_Wind (Object in, Object body, Object out) {
WIND w, *first = First_Wind;
Object ret;
GC_Node4;
@ -315,14 +322,14 @@ Object P_Dynamic_Wind (in, body, out) Object in, body, out; {
(void)Funcall (in, Null, 0);
ret = Funcall (body, Null, 0);
(void)Funcall (out, Null, 0);
if (Last_Wind = w.prev)
if ((Last_Wind = w.prev))
Last_Wind->next = 0;
First_Wind = first;
GC_Unlink;
return ret;
}
Object P_Control_Point_Environment (c) Object c; {
Object P_Control_Point_Environment (Object c) {
Check_Type (c, T_Control_Point);
return CONTROL(c)->env;
}

12
src/cstring.c
View File

@ -11,21 +11,23 @@
#include "kernel.h"
#include <string.h>
static char *heapstr[NUMSTRBUFS];
static int heaplen[NUMSTRBUFS];
static int nextstr;
Init_Cstring() { /* Preallocate memory to avoid fragmentation */
void Init_Cstring() { /* Preallocate memory to avoid fragmentation */
int i;
for (i = 0; i < NUMSTRBUFS; i++)
heapstr[i] = Safe_Malloc (heaplen[i] = 512);
}
char *Get_String (str) Object str; {
char *Get_String (Object str) {
char **pp = &heapstr[nextstr];
int len;
Check_Type (str, T_String);
if ((len = STRING(str)->size+1) > heaplen[nextstr]) {
Disable_Interrupts;
@ -33,13 +35,13 @@ char *Get_String (str) Object str; {
heaplen[nextstr] = len;
Enable_Interrupts;
}
bcopy (STRING(str)->data, *pp, --len);
memcpy (*pp, STRING(str)->data, --len);
(*pp)[len] = '\0';
if (++nextstr == NUMSTRBUFS) nextstr = 0;
return *pp;
}
char *Get_Strsym (str) Object str; {
char *Get_Strsym (Object str) {
if (TYPE(str) == T_Symbol)
str = SYMBOL(str)->name;
else if (TYPE(str) != T_String)

4
src/debug.c
View File

@ -3,9 +3,9 @@
#include "kernel.h"
Object P_Backtrace_List (argc, argv) Object *argv; {
Object P_Backtrace_List (int argc, Object *argv) {
register GCNODE *p, *gp = GC_List;
register delta = 0;
register int delta = 0;
Object cp, list, tail, cell, vec;
GC_Node3;

6
src/dump-ecoff.c
View File

@ -25,12 +25,12 @@ extern char *sbrk();
#define MAX_SECTS 20
Object P_Dump (ofile) Object ofile; {
Object P_Dump (Object ofile) {
struct filehdr fhdr;
struct aouthdr ahdr;
struct scnhdr sect[MAX_SECTS];
struct scnhdr *sp, *datap;
unsigned long data_start, data_end, delta;
unsigned long int data_start, data_end, delta;
int mask, n;
HDRR shdr;
char buf[4096];
@ -64,7 +64,7 @@ Object P_Dump (ofile) Object ofile; {
*/
data_start = datap->s_vaddr;
mask = getpagesize () - 1;
data_end = (unsigned long)sbrk (0) + mask & ~mask;
data_end = (unsigned long int)sbrk (0) + mask & ~mask;
delta = data_end - data_start - datap->s_size;
ahdr.dsize = data_end - ahdr.data_start;

21
src/dump-elf.c
View File

@ -3,6 +3,7 @@
#include <stdio.h>
#include <unistd.h>
#include <fcntl.h>
#include <malloc.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <sys/mman.h>
@ -11,7 +12,7 @@
*/
#define FIND_SECTHDR(name,ndx) {\
char err[100];\
unsigned _i;\
unsigned int _i;\
for (_i = 0; _i < ohdr->e_shnum; _i++)\
if (strcmp (sectstr+osecthdr[_i].sh_name, (name)) == 0) break;\
if (_i == ohdr->e_shnum) {\
@ -43,7 +44,7 @@
/* Bug: the mmapped regions are never munmapped again.
*/
Object P_Dump (ofile) Object ofile; {
Object P_Dump (Object ofile) {
/*
* ELF header, section header table, program header table of running
* a.out and new a.out
@ -54,7 +55,7 @@ Object P_Dump (ofile) Object ofile; {
/*
* .bss section index and section header pointer of running a.out
*/
unsigned obssndx;
unsigned int obssndx;
Elf32_Shdr *obssp;
/*
* .mdebug section index
@ -80,7 +81,7 @@ Object P_Dump (ofile) Object ofile; {
char *oaddr, *naddr;
struct stat st;
unsigned i;
unsigned int i;
int sect_created = !Was_Dumped;
Dump_Prolog;
@ -120,7 +121,7 @@ Object P_Dump (ofile) Object ofile; {
Primitive_Error ("sbrk(0) failed: ~E");
}
ndata = obssp->sh_addr;
ndatasize = (Elf32_Addr)Brk_On_Dump - ndata;
ndatasize = (Elf32_Addr)((ptrdiff_t)Brk_On_Dump - (ptrdiff_t)ndata);
ndataoff = obssp->sh_offset;
/* mmap new a.out file, setup pointers to ELF header, section header
@ -162,9 +163,9 @@ Object P_Dump (ofile) Object ofile; {
#define max(a,b) ((a) > (b) ? (a) : (b))
for (i = 0; i < nhdr->e_phnum; i++) {
Elf32_Phdr *pp = nproghdr+i;
unsigned mask = max(pp->p_align, obssp->sh_addralign) - 1;
Elf32_Addr ends_at = pp->p_vaddr + pp->p_filesz + mask & ~mask;
Elf32_Addr bssend = obssp->sh_addr + mask & ~mask;
unsigned int mask = max(pp->p_align, obssp->sh_addralign) - 1;
Elf32_Addr ends_at = (pp->p_vaddr + pp->p_filesz + mask) & ~mask;
Elf32_Addr bssend = (obssp->sh_addr + mask) & ~mask;
#ifndef __sgi
if (pp->p_vaddr + pp->p_filesz > obssp->sh_addr) {
Dump_Finalize;
@ -241,14 +242,14 @@ Object P_Dump (ofile) Object ofile; {
"memory" : "file"); (void)fflush (stdout);
#endif
if ((sp->sh_flags & (SHF_ALLOC|SHF_WRITE)) == (SHF_ALLOC|SHF_WRITE))
from = (void *)sp->sh_addr;
from = (void *)(ptrdiff_t)sp->sh_addr;
else
from = (void *)(oaddr + sp->sh_offset);
if (sp != ndatap && sp->sh_offset >= ndataoff)
sp->sh_offset += ndatasize;
if (sp->sh_type != SHT_NULL && sp->sh_type != SHT_NOBITS) {
#ifdef DEBUG_DUMP
printf (" copy from %x to %x size %x", from, naddr+sp->sh_offset,
printf (" copy from %p to %p size %x", from, naddr+sp->sh_offset,
sp->sh_size); (void)fflush (stdout);
#endif
memcpy ((void *)(naddr + sp->sh_offset), from, sp->sh_size);

10
src/dump-hp9k.c
View File

@ -36,10 +36,10 @@
}\
}
Object P_Dump (ofile) Object ofile; {
Object P_Dump (Object ofile) {
struct header hdr;
struct som_exec_auxhdr auxhdr;
unsigned data_size;
unsigned int data_size;
int delta;
struct stat stat;
extern void *sbrk();
@ -72,7 +72,7 @@ Object P_Dump (ofile) Object ofile; {
copy (afd, ofd, auxhdr.exec_dfile);
#ifdef HPSHLIB
/* Save data segments of shared libraries
/* Save data segments of shared libraries
*/
Save_Shared_Data ();
#endif
@ -178,7 +178,7 @@ Save_Shared_Data () {
sprintf (Z, " copy data seg from %x to %x len %d\n",
sp->oldaddr, sp->saved, sp->desc.dend - sp->desc.dstart); W;
#endif
bcopy (sp->oldaddr, sp->saved, sp->desc.dend - sp->desc.dstart);
memcpy (sp->saved, sp->oldaddr, sp->desc.dend - sp->desc.dstart);
}
}
@ -230,7 +230,7 @@ Restore_Shared_Data () {
sprintf (Z, " copy data seg from %x to %x len %d\n", sp->saved,
sp->oldaddr, sp->desc.dend-sp->desc.dstart); W;
#endif
bcopy (sp->saved, sp->oldaddr, sp->desc.dend - sp->desc.dstart);
memcpy (sp->oldaddr, sp->saved, sp->desc.dend - sp->desc.dstart);
/*
* Initial break must be set as soon as data segment of
* C library is restored

26
src/dump-vanilla.c
View File

@ -18,23 +18,23 @@ static int getpagesize () {
}
#endif
Object P_Dump (ofile) Object ofile; {
Object P_Dump (Object ofile) {
#ifdef COFF
static struct scnhdr thdr, dhdr, bhdr, scn;
static struct filehdr hdr;
static struct aouthdr ohdr;
unsigned bias;
unsigned lnno_start, syms_start;
unsigned text_scn_start, data_scn_start;
unsigned data_end;
unsigned int bias;
unsigned int lnno_start, syms_start;
unsigned int text_scn_start, data_scn_start;
unsigned int data_end;
int pagemask = COFF_PAGESIZE-1;
#else
struct exec hdr, shdr;
unsigned data_start, data_end;
unsigned int data_start, data_end;
int pagemask = getpagesize () - 1;
#endif
char *afn;
register n;
register int n;
char buf[BUFSIZ];
Dump_Prolog;
@ -48,7 +48,7 @@ badaout:
Primitive_Error ("corrupt a.out file");
}
#ifdef COFF
data_end = ((unsigned)sbrk (0) + pagemask) & ~pagemask;
data_end = ((unsigned int)sbrk (0) + pagemask) & ~pagemask;
syms_start = sizeof (hdr);
if (hdr.f_opthdr > 0) {
if (read (afd, (char *)&ohdr, sizeof (ohdr)) != sizeof (ohdr))
@ -120,7 +120,7 @@ badwrite:
#endif
data_start = (data_start + SEG_SIZ-1) & ~(SEG_SIZ-1);
#endif
data_end = (unsigned)sbrk (0);
data_end = (unsigned int)sbrk (0);
#if !defined(__bsdi__)
data_end = (data_end + pagemask) & ~pagemask;
#endif
@ -168,7 +168,7 @@ badwrite:
#else
if (Heap_Start > Free_Start) {
n = (unsigned)Free_Start - data_start;
n = (unsigned int)Free_Start - data_start;
if (write (ofd, (char *)data_start, n) != n)
goto badwrite;
(void)lseek (ofd, (off_t)(Free_End - Free_Start), 1);
@ -176,15 +176,15 @@ badwrite:
if (write (ofd, Heap_Start, n) != n)
goto badwrite;
(void)lseek (ofd, (off_t)(Heap_End - Hp), 1);
n = data_end - (unsigned)Heap_End;
n = data_end - (unsigned int)Heap_End;
if (write (ofd, Heap_End, n) != n)
goto badwrite;
} else {
n = (unsigned)Hp - data_start;
n = (unsigned int)Hp - data_start;
if (write (ofd, (char *)data_start, n) != n)
goto badwrite;
(void)lseek (ofd, (off_t)(Free_End - Hp), 1);
n = data_end - (unsigned)Free_End;
n = data_end - (unsigned int)Free_End;
if (write (ofd, Free_End, n) != n)
goto badwrite;
}

17
src/dump.c
View File

@ -11,11 +11,18 @@
# define O_BINARY 0
#endif
extern void Check_If_Dump_Works ();
extern void Flush_Output (Object);
extern void Close_All_Files ();
extern void Generational_GC_Finalize ();
extern int errno;
void Set_File_Executable (int, char *);
Object Dump_Control_Point;
Init_Dump () {
void Init_Dump () {
Dump_Control_Point = Null;
Global_GC_Link (Dump_Control_Point);
}
@ -60,7 +67,7 @@ Init_Dump () {
}
#define Dump_Finalize Saved_Errno = errno; close (afd); close (ofd)
#define Dump_Epilog {\
close (afd);\
@ -85,16 +92,16 @@ Init_Dump () {
#endif
/*ARGSUSED1*/
Set_File_Executable (fd, fn) int fd; char *fn; {
void Set_File_Executable (int fd, char *fn) {
struct stat st;
if (fstat (fd, &st) != -1) {
int omask = umask (0);
(void)umask (omask);
#ifdef FCHMOD_BROKEN
(void)chmod (fn, st.st_mode & 0777 | 0111 & ~omask);
(void)chmod (fn, (st.st_mode & 0777) | (0111 & ~omask));
#else
(void)fchmod (fd, st.st_mode & 0777 | 0111 & ~omask);
(void)fchmod (fd, (st.st_mode & 0777) | (0111 & ~omask));
#endif
}
}

45
src/env.c
View File

@ -3,6 +3,11 @@
#include "kernel.h"
void Set_Name (Object, Object);
void Memoize_Frame (Object);
void Memoize_Frames (Object, Object);
void Forget_Frame (Object);
#define Env_To_List(env, list) SET((list), T_Pair, POINTER(env))
#define List_To_Env(list, env) SET((env), T_Environment, POINTER(list))
@ -10,14 +15,14 @@ Object The_Environment, Global_Environment;
Object General_Define();
Init_Env () {
void Init_Env () {
List_To_Env (Cons (Null, Null), Global_Environment);
The_Environment = Global_Environment;
Global_GC_Link (Global_Environment);
Global_GC_Link (The_Environment);
}
Object P_Environment_To_List (env) Object env; {
Object P_Environment_To_List (Object env) {
Object e;
Check_Type (env, T_Environment);
@ -25,11 +30,11 @@ Object P_Environment_To_List (env) Object env; {
return Copy_List (e);
}
Object P_Environmentp (x) Object x; {
Object P_Environmentp (Object x) {
return TYPE(x) == T_Environment ? True : False;
}
Push_Frame (frame) Object frame; {
void Push_Frame (Object frame) {
Object e;
Memoize_Frame (frame);
@ -37,15 +42,15 @@ Push_Frame (frame) Object frame; {
List_To_Env (Cons (frame, e), The_Environment);
}
Pop_Frame () {
void Pop_Frame () {
Object e;
Env_To_List (The_Environment, e);
List_To_Env (Cdr (e), The_Environment);
Forget_Frame (Car (e));
}
Switch_Environment (to) Object to; {
void Switch_Environment (Object to) {
Object old, new, n;
if (EQ(The_Environment,to))
@ -64,14 +69,14 @@ Switch_Environment (to) Object to; {
The_Environment = to;
}
Memoize_Frames (this, last) Object this, last; {
void Memoize_Frames (Object this, Object last) {
if (Nullp (this) || EQ(this,last))
return;
Memoize_Frames (Cdr (this), last);
Memoize_Frame (Car (this));
}
Memoize_Frame (frame) Object frame; {
void Memoize_Frame (Object frame) {
Object binding;
for (; !Nullp (frame); frame = Cdr (frame)) {
@ -80,12 +85,12 @@ Memoize_Frame (frame) Object frame; {
}
}
Forget_Frame (frame) Object frame; {
void Forget_Frame (Object frame) {
for (; !Nullp (frame); frame = Cdr (frame))
SYMBOL(Car (Car (frame)))->value = Unbound;
}
Object Add_Binding (frame, sym, val) Object frame, sym, val; {
Object Add_Binding (Object frame, Object sym, Object val) {
Object b;
GC_Node;
@ -95,7 +100,7 @@ Object Add_Binding (frame, sym, val) Object frame, sym, val; {
return Cons (b, frame);
}
Object Lookup_Symbol (sym, err) Object sym; {
Object Lookup_Symbol (Object sym, int err) {
Object p, f, b;
Env_To_List (The_Environment, p);
@ -115,7 +120,7 @@ Object P_The_Environment () { return The_Environment; }
Object P_Global_Environment () { return Global_Environment; }
Object Define_Procedure (form, body, sym) Object form, body, sym; {
Object Define_Procedure (Object form, Object body, Object sym) {
Object ret;
GC_Node3;
@ -129,7 +134,7 @@ Object Define_Procedure (form, body, sym) Object form, body, sym; {
return ret;
}
Object General_Define (argl, sym) Object argl, sym; {
Object General_Define (Object argl, Object sym) {
Object val, var, frame, binding;
GC_Node3;
TC_Prolog;
@ -165,15 +170,15 @@ Object General_Define (argl, sym) Object argl, sym; {
/*NOTREACHED*/
}
Object P_Define (argl) Object argl; {
Object P_Define (Object argl) {
return General_Define (argl, Sym_Lambda);
}
Object P_Define_Macro (argl) Object argl; {
Object P_Define_Macro (Object argl) {
return General_Define (argl, Sym_Macro);
}
Object P_Set (argl) Object argl; {
Object P_Set (Object argl) {
Object val, var, binding, old;
GC_Node3;
TC_Prolog;
@ -194,8 +199,8 @@ Object P_Set (argl) Object argl; {
return old;
}
Set_Name (var, val) Object var, val; {
register t;
void Set_Name (Object var, Object val) {
register int t;
t = TYPE(val);
if (t == T_Compound) {
@ -207,7 +212,7 @@ Set_Name (var, val) Object var, val; {
}
}
Object P_Boundp (x) Object x; {
Object P_Boundp (Object x) {
Check_Type (x, T_Symbol);
return Nullp (Lookup_Symbol (x, 0)) ? False : True;
}

38
src/error.c
View File

@ -1,8 +1,12 @@
#include <ctype.h>
#include <varargs.h>
#include <stdlib.h>
#include "kernel.h"
void Reset () __attribute__ ((__noreturn__));
void Err_Handler () __attribute__ ((__noreturn__));
Object Arg_True;
static Object V_Error_Handler, V_Top_Level_Control_Point;
@ -12,11 +16,11 @@ static Object V_Error_Handler, V_Top_Level_Control_Point;
* the variable was manipulated directly, therefore it will remain global
* for some time for backwards compatibility.
*/
const char *Error_Tag;
char const *Error_Tag;
char *appname;
Init_Error () {
void Init_Error () {
Arg_True = Cons (True, Null);
Global_GC_Link (Arg_True);
Define_Variable (&V_Error_Handler, "error-handler", Null);
@ -24,26 +28,26 @@ Init_Error () {
Null);
}
const char *Get_Error_Tag () {
char const *Get_Error_Tag () {
return Error_Tag;
}
void Set_Error_Tag (tag) const char *tag; {
void Set_Error_Tag (char const *tag) {
Error_Tag = tag;
}
void Set_App_Name (name) char *name; {
void Set_App_Name (char *name) {
appname = name;
}
#ifdef lint
/*VARARGS1*/
Fatal_Error (foo) char *foo; { foo = foo; }
void Fatal_Error (char *foo) { foo = foo; }
#else
Fatal_Error (va_alist) va_dcl {
void Fatal_Error (va_alist) va_dcl {
va_list args;
char *fmt;
Disable_Interrupts;
va_start (args);
fmt = va_arg (args, char *);
@ -59,7 +63,7 @@ Fatal_Error (va_alist) va_dcl {
}
#endif
Panic (msg) const char *msg; {
void Panic (char const *msg) {
Disable_Interrupts;
(void)fflush (stdout);
if (appname)
@ -70,7 +74,7 @@ Panic (msg) const char *msg; {
abort ();
}
Uncatchable_Error (errmsg) char *errmsg; {
void Uncatchable_Error (char *errmsg) {
Disable_Interrupts;
Reset_IO (0);
/*
@ -87,12 +91,12 @@ Uncatchable_Error (errmsg) char *errmsg; {
#ifdef lint
/*VARARGS1*/
Primitive_Error (foo) char *foo; { foo = foo; }
void Primitive_Error (char *foo) { foo = foo; }
#else
Primitive_Error (va_alist) va_dcl {
void Primitive_Error (va_alist) va_dcl {
va_list args;
register char *p, *fmt;
register i, n;
register int i, n;
Object msg, sym, argv[10];
GC_Node; GCNODE gcv;
@ -116,13 +120,13 @@ Primitive_Error (va_alist) va_dcl {
}
#endif
Object P_Error (argc, argv) Object *argv; {
Object P_Error (int argc, Object *argv) {
Check_Type (argv[1], T_String);
Err_Handler (argv[0], argv[1], argc-2, argv+2);
/*NOTREACHED*/
}
Err_Handler (sym, fmt, argc, argv) Object sym, fmt, *argv; {
void Err_Handler (Object sym, Object fmt, int argc, Object *argv) {
Object fun, args, a[1];
GC_Node3;
@ -145,7 +149,7 @@ Err_Handler (sym, fmt, argc, argv) Object sym, fmt, *argv; {
/*NOTREACHED*/
}
Reset () {
void Reset () {
Object cp;
cp = Var_Get (V_Top_Level_Control_Point);
@ -161,6 +165,6 @@ Object P_Reset () {
/*NOTREACHED*/
}
Range_Error (i) Object i; {
void Range_Error (Object i) {
Primitive_Error ("argument out of range: ~s", i);
}

12
src/exception.c
View File

@ -1,7 +1,11 @@
#include "kernel.h"
#include <stdlib.h>
extern void Reset () __attribute__ ((__noreturn__));
int Intr_Was_Ignored;
unsigned long Intr_Level;
unsigned long int Intr_Level;
#ifdef POSIX_SIGNALS
sigset_t Sigset_Old, Sigset_Block;
@ -16,12 +20,12 @@ static Object V_Interrupt_Handler;
/* Make sure temp files are removed on hangup and broken pipe.
*/
/*ARGSUSED*/
void Signal_Exit (sig) int sig; {
void Signal_Exit (int sig) {
Exit_Handler ();
exit (1);
}
Init_Exception () {
void Init_Exception () {
Define_Variable (&V_Interrupt_Handler, "interrupt-handler", Null);
#ifdef POSIX_SIGNALS
sigemptyset (&Sigset_Block);
@ -38,7 +42,7 @@ Init_Exception () {
}
/*ARGSUSED*/
void Intr_Handler (sig) int sig; {
void Intr_Handler (int sig) {
Object fun;
#ifndef BSD_SIGNALS

16
src/feature.c
View File

@ -3,9 +3,11 @@
#include "kernel.h"
#include <string.h>
static Object Features;
Init_Features () {
void Init_Features () {
Features = Null;
Global_GC_Link (Features);
#ifdef CAN_DUMP
@ -20,7 +22,7 @@ Object P_Features () {
return Features;
}
Object P_Featurep (sym) Object sym; {
Object P_Featurep (Object sym) {
Object member;
Check_Type (sym, T_Symbol);
@ -28,7 +30,7 @@ Object P_Featurep (sym) Object sym; {
return Truep (member) ? True : False;
}
Object P_Provide (sym) Object sym; {
Object P_Provide (Object sym) {
Object member;
Check_Type (sym, T_Symbol);
@ -38,7 +40,7 @@ Object P_Provide (sym) Object sym; {
return Void;
}
static Object Feature_Filename (str) Object str; {
static Object Feature_Filename (Object str) {
struct S_String *sp = STRING(str);
int len = sp->size;
char *p;
@ -51,13 +53,13 @@ static Object Feature_Filename (str) Object str; {
return str;
GC_Link (str);
s = Make_String ((char *)0, len+4);
bcopy (STRING(str)->data, STRING(s)->data, len);
bcopy (".scm", STRING(s)->data+len, 4);
memcpy (STRING(s)->data, STRING(str)->data, len);
memcpy (STRING(s)->data+len, ".scm", 4);
GC_Unlink;
return s;
}
Object P_Require (argc, argv) Object *argv; {
Object P_Require (int argc, Object *argv) {
Object sym, a[1], isfeature;
GC_Node;

343
src/heap-gen.c
View File

@ -9,10 +9,15 @@
*/
#include <limits.h>
#include <stdlib.h>
#include <string.h>
#include <sys/types.h>
#ifdef HAS_MPROTECT
# include <sys/mman.h>
#endif
#ifdef GETPAGESIZE
# define SYSCONF_PAGESIZE
#endif
#ifdef SYSCONF_PAGESIZE
# define link FOO
# include <unistd.h>
@ -49,7 +54,7 @@ int tuneable_force_expand = 20; /* % stable to force heap expansion
defined in object.h:
typedef int gcspace_t; // type used for space and type arrays
typedef unsigned gcptr_t; // type used for pointers
typedef unsigned int gcptr_t; // type used for pointers
------------------------------------------------------------------------ */
@ -70,6 +75,7 @@ static pageno_t logical_pages, spanning_pages, physical_pages;
static pageno_t firstpage, lastpage;
static char *saved_heap_ptr;
gcspace_t *space;
static gcspace_t *type, *pmap;
static pageno_t *link;
@ -141,8 +147,8 @@ static void TerminateGC ();
#endif
#define MAKE_HEADER(obj,words,type) (SET(obj, type, words))
#define HEADER_TO_TYPE(header) ((unsigned)TYPE(header))
#define HEADER_TO_WORDS(header) ((unsigned)FIXNUM(header))
#define HEADER_TO_TYPE(header) ((unsigned int)TYPE(header))
#define HEADER_TO_WORDS(header) ((unsigned int)FIXNUM(header))
/* some conversion stuff. PHYSPAGE converts a logical page number into the
* start address of the physical page the logical page lies on.
@ -168,7 +174,9 @@ static void TerminateGC ();
#define IS_CLUSTER(a,b) (SAME_PHYSPAGE (PAGE_TO_ADDR ((a)), \
PAGE_TO_ADDR ((b))) || \
(type[(a)&hp_per_pp_mask] == OBJECTPAGE && \
(space[(a)&hp_per_pp_mask] == \
space[((b)&hp_per_pp_mask)+hp_per_pp] && \
type[(a)&hp_per_pp_mask] == OBJECTPAGE && \
type[((b)&hp_per_pp_mask)+hp_per_pp] == OBJECTPAGE))
/* check whether the (physical) page starting at address addr is protected
@ -227,13 +235,13 @@ static void SetupDirtyList () {
dirtylist = (struct dirty_rec *) malloc (sizeof (struct dirty_rec));
if (dirtylist == (struct dirty_rec *)0)
Fatal_Error ("SetupDirtyList: unable to allocate memory");
bzero ((char *)dirtylist->pages, sizeof (dirtylist->pages));
memset (dirtylist->pages, 0, sizeof (dirtylist->pages));
dirtylist->next = (struct dirty_rec *)0;
dirtyhead = dirtylist;
dirtyentries = 0;
}
static void AddDirty (addr) pageno_t addr; {
static void AddDirty (pageno_t addr) {
struct dirty_rec *p;
if (dirtyentries != 0 &&
@ -246,7 +254,7 @@ static void AddDirty (addr) pageno_t addr; {
p = (struct dirty_rec *) malloc (sizeof (struct dirty_rec));
if (p == (struct dirty_rec *)0)
Fatal_Error ("AddDirty: unable to allocate memory");
bzero ((char *)p->pages, sizeof (p->pages));
memset (p->pages, 0, sizeof (p->pages));
p->next = (struct dirty_rec *)0;
dirtylist->next = p;
dirtylist = p;
@ -275,7 +283,7 @@ static void ReprotectDirty () {
* to remember pages, set a flag to rescan the whole scan region.
*/
static void RegisterPage (page) pageno_t page; {
static void RegisterPage (pageno_t page) {
if (allscan)
return;
@ -294,7 +302,7 @@ static void RegisterPage (page) pageno_t page; {
* Note that these parameters are value-result parameters !
*/
static void DetermineCluster (addr, len) gcptr_t *addr; int *len; {
static void DetermineCluster (gcptr_t *addr, int *len) {
gcptr_t addr1;
*len = 1;
@ -319,7 +327,7 @@ static void DetermineCluster (addr, len) gcptr_t *addr; int *len; {
* is 0, DetermineCluster is called to set length accordingly.
*/
static void ProtectCluster (addr, len) gcptr_t addr; {
static void ProtectCluster (gcptr_t addr, int len) {
if (!len) DetermineCluster (&addr, &len);
if (len > 1) {
while (len) {
@ -343,7 +351,7 @@ static void ProtectCluster (addr, len) gcptr_t addr; {
}
static void UnprotectCluster (addr, len) gcptr_t addr; {
static void UnprotectCluster (gcptr_t addr, int len) {
if (!len) DetermineCluster (&addr, &len);
MPROTECT (addr, len << pp_shift, PROT_RW);
while (len--) {
@ -355,7 +363,7 @@ static void UnprotectCluster (addr, len) gcptr_t addr; {
/* add one page to the stable set queue */
static void AddQueue (page) pageno_t page; {
static void AddQueue (pageno_t page) {
if (stable_queue != (pageno_t)-1)
link[stable_tail] = page;
@ -375,7 +383,7 @@ static void PromoteStableQueue () {
Object *p;
int pcount, size;
pageno_t start;
while (stable_queue != (pageno_t)-1) {
p = PAGE_TO_OBJ (stable_queue);
#ifdef ALIGN_8BYTE
@ -383,7 +391,7 @@ static void PromoteStableQueue () {
#endif
size = HEADER_TO_WORDS (*p);
pcount = NEEDED_PAGES (size);
start = stable_queue;
while (pcount--)
space[start++] = current_space;
@ -396,7 +404,7 @@ static void PromoteStableQueue () {
/* calculate the logarithm (base 2) for arguments == 2**n
*/
static Logbase2 (psize) addrarith_t psize; {
static int Logbase2 (addrarith_t psize) {
int shift = 0;
#if LONG_BITS-64 == 0
@ -419,7 +427,7 @@ static Logbase2 (psize) addrarith_t psize; {
/* return next heap page number, wrap around at the end of the heap. */
static pageno_t next (page) pageno_t page; {
static pageno_t next (pageno_t page) {
return ((page < lastpage) ? page+1 : firstpage);
}
@ -427,7 +435,7 @@ static pageno_t next (page) pageno_t page; {
#ifdef MPROTECT_MMAP
static char *heapmalloc (s) {
static char *heapmalloc (int s) {
char *ret = mmap (0, s, PROT_READ|PROT_WRITE, MAP_ANON, -1, 0);
if (ret == (char*)-1)
@ -446,24 +454,24 @@ static char *heapmalloc (s) {
* make a heap of size kilobytes. It is divided into heappages of
* PAGEBYTES byte and is aligned at a physical page boundary. The
* heapsize is rounded up to the nearest multiple of the physical
* pagesize.
* pagesize. Checked by sam@zoy.org on Apr 1, 2003.
*/
Make_Heap (size) {
void Make_Heap (int size) {
addrarith_t heapsize = size * 2 * 1024;
char *heap_ptr, *aligned_heap_ptr;
Object heap_obj;
pageno_t i;
#ifdef HAS_MPROTECT
InstallHandler ();
#endif
/* calculate number of logical heappages and of used physical pages.
* First, round up to the nearest multiple of the physical pagesize,
* then calculate the resulting number of heap pages.
*/
#ifdef SYSCONF_PAGESIZE
if ((bytes_per_pp = sysconf (_SC_PAGESIZE)) == -1)
Fatal_Error ("sysconf(_SC_PAGESIZE) failed; can't get pagesize");
@ -486,26 +494,28 @@ Make_Heap (size) {
pp_shift = Logbase2 (bytes_per_pp);
heap_ptr = heapmalloc (logical_pages*PAGEBYTES+bytes_per_pp-1);
/* FIXME: add heap_ptr to a list of pointers to free */
saved_heap_ptr = heap_ptr;
if (heap_ptr == NULL)
Fatal_Error ("cannot allocate heap (%u KBytes)", size);
/* Align heap at a memory page boundary */
if ((gcptr_t)heap_ptr & (bytes_per_pp-1))
aligned_heap_ptr = (char*)(((gcptr_t)heap_ptr+bytes_per_pp)
aligned_heap_ptr = (char*)(((gcptr_t)heap_ptr+bytes_per_pp-1)
& ~(bytes_per_pp-1));
else
aligned_heap_ptr = heap_ptr;
SET(heap_obj, 0, aligned_heap_ptr);
#ifdef ARRAY_BROKEN
#ifdef ARRAY_BROKEN
pagebase = ((gcptr_t)POINTER (heap_obj)) / PAGEBYTES;
#endif
firstpage = OBJ_TO_PAGE (heap_obj);
lastpage = firstpage+logical_pages-1;
space = (gcspace_t *)malloc (logical_pages*sizeof (gcspace_t));
type = (gcspace_t *)malloc ((logical_pages + 1)*sizeof (gcspace_t));
pmap = (gcspace_t *)malloc (physical_pages*sizeof (gcspace_t));
@ -519,9 +529,9 @@ Make_Heap (size) {
Fatal_Error ("cannot allocate heap maps");
}
bzero ((char *)type, (logical_pages + 1)*sizeof (gcspace_t));
bzero ((char *)pmap, physical_pages*sizeof (gcspace_t));
bzero ((char *)link, logical_pages*sizeof (unsigned));
memset (type, 0, (logical_pages + 1)*sizeof (gcspace_t));
memset (pmap, 0, physical_pages*sizeof (gcspace_t));
memset (link, 0, logical_pages*sizeof (unsigned int));
space -= firstpage; /* to index the arrays with the heap page number */
type -= firstpage;
type[lastpage+1] = OBJECTPAGE;
@ -545,10 +555,10 @@ Make_Heap (size) {
}
/*
* increment the heap by 1024 KB.
* increment the heap by 1024 KB. Checked by sam@zoy.org on Apr 1, 2003.
*/
static int ExpandHeap (reason) char *reason; {
static int ExpandHeap (char *reason) {
int increment = (1024 * 1024 + bytes_per_pp - 1) / bytes_per_pp;
int incpages = increment * hp_per_pp;
addrarith_t heapinc = incpages * PAGEBYTES;
@ -567,22 +577,23 @@ static int ExpandHeap (reason) char *reason; {
#else
# define offset 0
#endif
heap_ptr = heapmalloc (heapinc+bytes_per_pp-1);
/* FIXME: this pointer is lost */
heap_ptr = heapmalloc (heapinc+bytes_per_pp/*-1*/);
if (heap_ptr == NULL) {
if (Var_Is_True (V_Garbage_Collect_Notifyp)) {
char buf[243];
sprintf(buf, "[Heap expansion failed (%s)]~%%", reason);
Format (Standard_Output_Port, buf,
strlen(buf), 0, (Object *)0);
Format (Standard_Output_Port, buf,
strlen(buf), 0, (Object *)0);
(void)fflush (stdout);
}
return (0);
}
/* Align heap at a memory page boundary */
if ((gcptr_t)heap_ptr & (bytes_per_pp-1))
aligned_heap_ptr = (char*)(((gcptr_t)heap_ptr+bytes_per_pp-1)
& ~(bytes_per_pp-1));
@ -590,7 +601,7 @@ static int ExpandHeap (reason) char *reason; {
aligned_heap_ptr = heap_ptr;
SET(heap_obj, 0, aligned_heap_ptr);
new_first = firstpage;
new_last = lastpage;
@ -623,7 +634,7 @@ static int ExpandHeap (reason) char *reason; {
new_spanpages = new_last-new_first+1;
#endif
new_physpages = new_spanpages / hp_per_pp;
new_space = (gcspace_t *)malloc (new_spanpages*sizeof (gcspace_t));
new_type = (gcspace_t *)malloc ((new_spanpages + 1)*sizeof (gcspace_t));
new_pmap = (gcspace_t *)malloc (new_physpages*sizeof (gcspace_t));
@ -635,23 +646,29 @@ static int ExpandHeap (reason) char *reason; {
if (new_pmap) free ((char*)new_pmap);
if (new_link) free ((char*)new_link);
if (Var_Is_True (V_Garbage_Collect_Notifyp)) {
Format (Standard_Output_Port, "[Heap expansion failed]~%",
25, 0, (Object *)0);
Format (Standard_Output_Port, "[Heap expansion failed]~%",
25, 0, (Object *)0);
(void)fflush (stdout);
}
return (0);
}
/* new_first will be 0 if ARRAY_BROKEN is defined. */
new_space -= new_first;
new_type -= new_first;
new_link -= new_first;
bzero ((char*)new_pmap, new_physpages * sizeof (gcspace_t));
memset (new_pmap, 0, new_physpages * sizeof (gcspace_t));
#ifndef ARRAY_BROKEN
new_pmap -= (PHYSPAGE (new_first) >> pp_shift);
#endif
memset (new_type+inc_first+offset, 0, (incpages+1)*sizeof (gcspace_t));
memset (new_link+inc_first+offset, 0, incpages*sizeof (unsigned int));
/* FIXME: memmove! */
for (i = firstpage; i <= lastpage; i++) {
new_link[i + offset] = link[i] + offset;
new_type[i + offset] = type[i];
@ -661,7 +678,7 @@ static int ExpandHeap (reason) char *reason; {
new_pmap[((addr - PAGE_TO_ADDR(0)) >> pp_shift) + offset] =
IS_PROTECTED (addr);
}
#ifdef ARRAY_BROKEN
for (i = 0; i < new_spanpages; i++) new_space[i] = UNALLOCATED_PAGE;
for (i = firstpage; i <= lastpage; i++) new_space[i+offset] = space[i];
@ -671,7 +688,7 @@ static int ExpandHeap (reason) char *reason; {
#else
for (i = new_first; i < firstpage; i++) new_space[i] = UNALLOCATED_PAGE;
for (i = firstpage; i <= lastpage; i++) new_space[i] = space[i];
for (i = lastpage+1; i <= new_last; i++) new_space[i] = UNALLOCATED_PAGE;
for (i = inc_first; i <= inc_last; i++) new_space[i] = FREE_PAGE;
new_type[new_last+1] = OBJECTPAGE;
@ -684,7 +701,7 @@ static int ExpandHeap (reason) char *reason; {
free ((char*)(link+firstpage));
free ((char*)(type+firstpage));
free ((char*)(space+firstpage));
#ifndef ARRAY_BROKEN
free ((char*)(pmap+(PAGE_TO_ADDR (firstpage) >> pp_shift)));
#else
@ -700,9 +717,9 @@ static int ExpandHeap (reason) char *reason; {
logical_pages = new_logpages;
spanning_pages = new_spanpages;
physical_pages = new_physpages;
if (Var_Is_True (V_Garbage_Collect_Notifyp)) {
int a = (logical_pages * PAGEBYTES) >> 10;
int a = (logical_pages * PAGEBYTES) >> 10;
char buf[243];
sprintf(buf, "[Heap expanded to %dK (%s)]~%%", a, reason);
@ -713,12 +730,30 @@ static int ExpandHeap (reason) char *reason; {
}
/*
* free the heap.
*/
void Free_Heap () {
free (saved_heap_ptr);
free ((char*)(link+firstpage));
free ((char*)(type+firstpage));
free ((char*)(space+firstpage));
#ifndef ARRAY_BROKEN
free ((char*)(pmap+(PAGE_TO_ADDR (firstpage) >> pp_shift)));
#else
free ((char*)pmap);
#endif
}
/* allocate new logical heappages. npg is the number of pages to allocate.
* If there is not enough space left, the heap will be expanded if possible.
* The new page is allocated in current space.
*/
static int ProtectedInRegion (start, npages) pageno_t start, npages; {
static int ProtectedInRegion (pageno_t start, pageno_t npages) {
gcptr_t beginpage = PHYSPAGE (start);
gcptr_t endpage = PHYSPAGE (start+npages-1);
@ -731,11 +766,11 @@ static int ProtectedInRegion (start, npages) pageno_t start, npages; {
return (0);
}
static void AllocPage (npg) pageno_t npg; {
pageno_t first_freepage; /* first free heap page */
static void AllocPage (pageno_t npg) {
pageno_t first_freepage = 0;/* first free heap page */
pageno_t cont_free; /* contiguous free pages */
pageno_t n, p;
if (current_space != forward_space) {
(void)Scanner ((pageno_t)1);
if (!protected_pages)
@ -749,27 +784,32 @@ static void AllocPage (npg) pageno_t npg; {
P_Collect ();
}
}
/* now look for a cluster of npg free pages. cont_free counts the
* number of free pages found, first_freepage is the number of the
* first free heap page in the cluster.
*/
for (p = spanning_pages, cont_free = 0; p; p--) {
if (space[current_freepage] < previous_space
&& !STABLE (current_freepage)) {
if (!(cont_free++)) {
if (IS_CLUSTER (current_freepage, current_freepage+npg-1))
if (cont_free == 0) {
/* This is our first free page, first check that we have a
* continuous cluster of pages (we'll check later that they
* are free). Otherwise, go to the next free page */
if (current_freepage+npg-1 <= lastpage
&& IS_CLUSTER (current_freepage, current_freepage+npg-1))
first_freepage = current_freepage;
else {
current_freepage = next (current_freepage -
current_freepage % hp_per_pp +
hp_per_pp-1);
cont_free = 0;
continue;
}
}
cont_free++;
if (cont_free == npg) {
space[first_freepage] = current_space;
type[first_freepage] = OBJECTPAGE;
@ -785,25 +825,27 @@ static void AllocPage (npg) pageno_t npg; {
if (ProtectedInRegion (first_freepage, npg))
(void)ScanCluster (PHYSPAGE (first_freepage));
return;
} else {
current_freepage = next (current_freepage);
if (current_freepage == firstpage) cont_free = 0;
}
/* check the next free page. If we warped, reset cont_free to 0. */
current_freepage = next (current_freepage);
if (current_freepage == firstpage) cont_free = 0;
} else {
current_freepage = next (current_freepage);
cont_free = 0;
}
}
/* no space available, try to expand heap */
if (ExpandHeap ("to allocate new object")) {
AllocPage (npg);
return;
}
Fatal_Error ("unable to allocate %lu bytes in heap", npg*PAGEBYTES);
/*NOTREACHED*/
}
@ -825,22 +867,22 @@ Object Alloc_Object (size, type, konst) {
else
P_Collect ();
}
/* if there is not enough space left on the current page, discard
* the left space and allocate a new page. Space is discarded by
* writing a T_Freespace object.
*/
if (s > current_free) {
if (current_free) {
MAKE_HEADER (*current_freep, current_free, T_Freespace);
current_free = 0;
}
/* If we are about to allocate an object bigger than one heap page,
* set a flag. The space behind big objects is discarded, see below.
*/
#ifdef ALIGN_8BYTE
if (s < PAGEWORDS-1)
AllocPage ((pageno_t)1);
@ -860,12 +902,12 @@ Object Alloc_Object (size, type, konst) {
}
#endif
}
/* now write a header for the object into the heap and update the
* pointer to the next free location and the counter of free words
* in the current heappage.
*/
MAKE_HEADER (*current_freep, s, type);
current_freep++;
*current_freep = Null;
@ -883,7 +925,7 @@ Object Alloc_Object (size, type, konst) {
#endif
if (type == T_Control_Point)
CONTROL(obj)->reloc = 0;
if (konst) SETCONST (obj);
return (obj);
}
@ -894,18 +936,18 @@ Object Alloc_Object (size, type, konst) {
* on the same physical page the referenced object lies on.
*/
static void AllocForwardPage (bad) Object bad; {
static void AllocForwardPage (Object bad) {
Object *badaddr = (Object *)POINTER (bad);
pageno_t whole_heap = spanning_pages;
pageno_t tpage;
while (whole_heap--) {
if (space[forward_freepage] < previous_space
&& !STABLE (forward_freepage)
&& !SAME_PHYSPAGE ((gcptr_t)badaddr,
PAGE_TO_ADDR (forward_freepage))
&& !IN_SCANREGION (PAGE_TO_ADDR (forward_freepage))) {
allocated_pages++;
forwarded_pages++;
space[forward_freepage] = forward_space;
@ -913,7 +955,7 @@ static void AllocForwardPage (bad) Object bad; {
forward_freep = PAGE_TO_OBJ (forward_freepage);
forward_free = PAGEWORDS;
AddQueue (forward_freepage);
tpage = last_forward_freepage;
last_forward_freepage = next (forward_freepage);
forward_freepage = tpage;
@ -922,15 +964,15 @@ static void AllocForwardPage (bad) Object bad; {
forward_freepage = next (forward_freepage);
}
}
if (ExpandHeap ("to allocate forward page")) {
AllocForwardPage (bad);
return;
}
Fatal_Error ("unable to allocate forward page in %lu KBytes heap",
(logical_pages * PAGEBYTES) >> 10);
/*NOTREACHED*/
}
@ -939,7 +981,7 @@ static void AllocForwardPage (bad) Object bad; {
* object must be protected because it is to be scanned later.
*/
Visit (cp) register Object *cp; {
int Visit (register Object *cp) {
register pageno_t page = OBJ_TO_PAGE (*cp);
register Object *obj_ptr = (Object *)POINTER (*cp);
int tag = TYPE (*cp);
@ -948,41 +990,41 @@ Visit (cp) register Object *cp; {
pageno_t objpages, pcount;
gcptr_t ffreep, pageaddr = 0;
int outside;
/* if the Visit function is called via the REVIVE_OBJ macro and we are
* not inside an incremental collection, exit immediately.
*/
if (current_space == forward_space)
return;
return 0;
if (page < firstpage || page > lastpage || STABLE (page)
|| space[page] == current_space || space[page] == UNALLOCATED_PAGE
|| !Types[tag].haspointer)
return;
return 0;
if (space[page] != previous_space) {
char buf[100];
sprintf (buf, "Visit: object not in prev space at 0x%lx ('%s') %d %d",
sprintf (buf, "Visit: object not in prev space at %p ('%s') %d %d",
obj_ptr, Types[tag].name, space[page], previous_space);
Panic (buf);
}
if (!IN_SCANREGION (obj_ptr) && IS_PROTECTED ((gcptr_t)obj_ptr)) {
pageaddr = OBJ_TO_PPADDR (*cp);
UNPROTECT (pageaddr);
}
if (WAS_FORWARDED (*cp)) {
if (pageaddr != 0)
PROTECT (pageaddr);
MAKEOBJ (*cp, tag, POINTER(*obj_ptr));
if (konst)
SETCONST (*cp);
return;
return 0;
}
ffreep = PTR_TO_PPADDR (forward_freep);
ffreep = PTR_TO_PPADDR (forward_freep);
outside = !IN_SCANREGION (forward_freep);
objwords = HEADER_TO_WORDS (*(obj_ptr - 1));
if (objwords >= forward_free) {
@ -1001,17 +1043,17 @@ Visit (cp) register Object *cp; {
RegisterPage (page);
else
ProtectCluster (PHYSPAGE (page), 0);
if (pageaddr != 0)
PROTECT (pageaddr);
return;
return 0;
}
if (forward_free) {
if (outside && IS_PROTECTED (ffreep)
&& !SAME_PHYSPAGE ((gcptr_t)obj_ptr, ffreep)) {
UNPROTECT (ffreep);
MAKE_HEADER (*forward_freep, forward_free, T_Freespace);
forward_free = 0;
@ -1021,7 +1063,7 @@ Visit (cp) register Object *cp; {
forward_free = 0;
}
}
AllocForwardPage (*cp);
outside = !IN_SCANREGION (forward_freep);
ffreep = PTR_TO_PPADDR (forward_freep); /* re-set ffreep ! */
@ -1034,7 +1076,7 @@ Visit (cp) register Object *cp; {
goto do_forward;
#endif
}
if (outside && IS_PROTECTED (ffreep))
UNPROTECT (ffreep);
@ -1045,17 +1087,17 @@ do_forward:
CONTROL (*cp)->reloc =
(char*)(forward_freep + 1) - (char*)obj_ptr;
}
MAKE_HEADER (*forward_freep, objwords, tag);
forward_freep++;
bcopy ((char*)obj_ptr, (char*)forward_freep, (objwords-1)*sizeof(Object));
memcpy (forward_freep, obj_ptr, (objwords-1)*sizeof(Object));
SET (*obj_ptr, T_Broken_Heart, forward_freep);
MAKEOBJ (*cp, tag, forward_freep);
if (konst)
SETCONST (*cp);
forward_freep += (objwords - 1);
forward_free -= objwords;
#ifdef ALIGN_8BYTE
if (!((gcptr_t)forward_freep & 7) && forward_free) {
MAKE_HEADER (*forward_freep, 1, T_Align_8Byte);
@ -1063,38 +1105,38 @@ do_forward:
forward_free--;
}
#endif
if (outside)
PROTECT (ffreep);
if (pageaddr != 0)
PROTECT (pageaddr);
return;
return 0;
}
/* Scan a page and visit all objects referenced by objects lying on the
* page. This will possibly forward the referenced objects.
*/
static void ScanPage (currentp, nextcp) Object *currentp, *nextcp; {
static void ScanPage (Object *currentp, Object *nextcp) {
Object *cp = currentp, obj;
addrarith_t len, m, n;
int t;
while (cp < nextcp && (cp != forward_freep || forward_free == 0)) {
t = HEADER_TO_TYPE (*cp);
len = HEADER_TO_WORDS (*cp);
cp++;
/* cp now points to the real Scheme object in the heap. t denotes
* the type of the object, len its length inclusive header in
* words.
*/
SET(obj, t, cp);
switch (t) {
case T_Symbol:
Visit (&SYMBOL(obj)->next);
@ -1102,27 +1144,27 @@ static void ScanPage (currentp, nextcp) Object *currentp, *nextcp; {
Visit (&SYMBOL(obj)->value);
Visit (&SYMBOL(obj)->plist);
break;
case T_Pair:
case T_Environment:
Visit (&PAIR(obj)->car);
Visit (&PAIR(obj)->cdr);
break;
case T_Vector:
for (n = 0, m = VECTOR(obj)->size; n < m; n++ )
Visit (&VECTOR(obj)->data[n]);
break;
case T_Compound:
Visit (&COMPOUND(obj)->closure);
Visit (&COMPOUND(obj)->env);
Visit (&COMPOUND(obj)->name);
break;
case T_Control_Point:
(CONTROL(obj)->delta) += CONTROL(obj)->reloc;
#ifdef USE_ALLOCA
Visit_GC_List (CONTROL(obj)->gclist, CONTROL(obj)->delta);
#else
@ -1130,45 +1172,45 @@ static void ScanPage (currentp, nextcp) Object *currentp, *nextcp; {
#endif
Visit_Wind (CONTROL(obj)->firstwind,
(CONTROL(obj)->delta) );
Visit (&CONTROL(obj)->env);
break;
case T_Promise:
Visit (&PROMISE(obj)->env);
Visit (&PROMISE(obj)->thunk);
break;
case T_Port:
Visit (&PORT(obj)->name);
break;
case T_Autoload:
Visit (&AUTOLOAD(obj)->files);
Visit (&AUTOLOAD(obj)->env);
break;
case T_Macro:
Visit (&MACRO(obj)->body);
Visit (&MACRO(obj)->name);
break;
default:
default:
if (Types[t].visit)
(Types[t].visit) (&obj, Visit);
}
cp += (len - 1);
}
}
/* rescan all pages remembered by the RegisterPage function. */
static void RescanPages () {
register Object *cp;
register int i;
int pages = rescanpages;
rescanpages = 0;
for (i = 0; i < pages; i++) {
cp = PAGE_TO_OBJ (rescan[i]);
@ -1179,12 +1221,12 @@ static void RescanPages () {
#endif
}
}
static int ScanCluster (addr) gcptr_t addr; {
static int ScanCluster (gcptr_t addr) {
register pageno_t page, lastpage;
pageno_t npages;
int n = 0;
scanning = 1;
DetermineCluster (&addr, &n);
npages = n;
@ -1222,11 +1264,11 @@ static int ScanCluster (addr) gcptr_t addr; {
}
static int Scanner (npages) pageno_t npages; {
static int Scanner (pageno_t npages) {
register gcptr_t addr, lastaddr;
pageno_t spages;
pageno_t scanned = 0;
while (npages > 0 && protected_pages) {
lastaddr = PAGE_TO_ADDR (lastpage);
for (addr = PAGE_TO_ADDR(firstpage); addr < lastaddr && npages > 0;
@ -1256,13 +1298,13 @@ static int Scanner (npages) pageno_t npages; {
#ifdef SIGSEGV_SIGCONTEXT
static void PagefaultHandler (sig, code, scp) struct sigcontext *scp; {
static void PagefaultHandler (int sig, int code, struct sigcontext *scp) {
char *addr = (char *)(scp->sc_badvaddr);
#else
#ifdef SIGSEGV_AIX
static void PagefaultHandler (sig, code, scp) struct sigcontext *scp; {
static void PagefaultHandler (int sig, int code, struct sigcontext *scp) {
char *addr = (char *)scp->sc_jmpbuf.jmp_context.except[3];
/*
* Or should that be .jmp_context.o_vaddr?
@ -1271,19 +1313,19 @@ static void PagefaultHandler (sig, code, scp) struct sigcontext *scp; {
#else
#ifdef SIGSEGV_SIGINFO
static void PagefaultHandler (sig, sip, ucp) siginfo_t *sip; ucontext_t *ucp; {
static void PagefaultHandler (int sig, siginfo_t *sip, ucontext_t *ucp) {
char *addr;
#else
#ifdef SIGSEGV_ARG4
static void PagefaultHandler (sig, code, scp, addr) struct sigcontext *scp;
char *addr; {
static void PagefaultHandler (int sig, int code, struct sigcontext *scp,
char *addr) {
#else
#ifdef SIGSEGV_HPUX
static void PagefaultHandler (sig, code, scp) struct sigcontext *scp; {
static void PagefaultHandler (int sig, int code, struct sigcontext *scp) {
#else
# include "HAS_MPROTECT defined, but missing SIGSEGV_xxx"
@ -1339,7 +1381,7 @@ static void PagefaultHandler (sig, code, scp) struct sigcontext *scp; {
return;
}
InstallHandler () {
void InstallHandler () {
#ifdef SIGSEGV_SIGINFO
struct sigaction sact;
sigset_t mask;
@ -1359,7 +1401,7 @@ InstallHandler () {
static void TerminateGC () {
int save_force_total;
forward_space = current_space;
previous_space = current_space;
@ -1380,9 +1422,9 @@ static void TerminateGC () {
Enable_Interrupts;
if (Var_Is_True (V_Garbage_Collect_Notifyp) && !GC_Debug) {
int foo = percent - HEAPPERCENT (allocated_pages);
Object bar;
int foo = percent - HEAPPERCENT (allocated_pages);
Object bar;
bar = Make_Integer (foo);
if (!incomplete_msg)
Format (Standard_Output_Port, "[", 1, 0, (Object *)0);
@ -1430,7 +1472,7 @@ static void Finish_Collection () {
}
static void General_Collect (initiate) {
static void General_Collect (int initiate) {
pageno_t fpage, free_fpages, i;
pageno_t page;
pageno_t fregion_pages;
@ -1517,7 +1559,7 @@ static void General_Collect (initiate) {
* have been protected, else check whether to expand the heap because
* the stable set has grown too big.
*/
page = stable_queue;
while (page != (pageno_t)-1) {
ProtectCluster (PHYSPAGE (page), 0);
@ -1526,11 +1568,11 @@ static void General_Collect (initiate) {
if (!initiate) {
Finish_Collection ();
} else
} else
if (HEAPPERCENT (forwarded_pages) > tuneable_force_expand)
/* return value should not be ignored here: */
(void)ExpandHeap ("large stable set");
GC_In_Progress = 0;
return;
}
@ -1585,20 +1627,23 @@ Object P_Collect () {
}
}
Generational_GC_Finalize () {
void Generational_GC_Finalize () {
if (current_space != forward_space)
Finish_Collection ();
}
Generational_GC_Reinitialize () {
void Generational_GC_Reinitialize () {
#ifdef HAS_MPROTECT
InstallHandler ();
#endif
}
Object Internal_GC_Status (strat, flags) {
Object list, cell;
Object Internal_GC_Status (int strat, int flags) {
Object list;
#ifdef HAS_MPROTECT
Object cell;
#endif
GC_Node;
list = Cons (Sym_Generational_GC, Null);

42
src/heap-sc.c
View File

@ -1,6 +1,10 @@
/* Stop-and-copy garbage collector
*/
#include <string.h>
extern void Uncatchable_Error (char *);
extern unsigned int Stack_Size ();
extern void *sbrk();
#define Recursive_Visit(p) {\
@ -18,9 +22,9 @@ char *Heap_Start,
static char *To;
Make_Heap (size) {
register unsigned k = 1024 * size;
register unsigned s = 2 * k;
void Make_Heap (int size) {
register unsigned int k = 1024 * size;
register unsigned int s = 2 * k;
if ((Hp = Heap_Start = (char *)sbrk (s)) == (char *)-1)
Fatal_Error ("cannot allocate heap (%u KBytes)", 2*size);
@ -29,7 +33,11 @@ Make_Heap (size) {
Free_End = Free_Start + k;
}
Object Alloc_Object (size, type, konst) {
void Free_Heap () {
/* Do nothing. */
}
Object Alloc_Object (int size, int type, int konst) {
register char *p = Hp;
Object ret;
@ -55,7 +63,7 @@ Object Alloc_Object (size, type, konst) {
Object P_Collect () {
register char *tmp;
register msg = 0;
register int msg = 0;
Object a[2];
if (!Interpreter_Initialized)
@ -93,27 +101,27 @@ Object P_Collect () {
return Void;
}
Visit (p) register Object *p; {
int Visit (register Object *p) {
register Object *tag;
register t, size, reloc;
register int t, size, reloc = 0;
again:
t = TYPE(*p);
if (!Types[t].haspointer)
return;
return 0;
tag = (Object *)POINTER(*p);
if ((char *)tag >= Free_Start && (char *)tag < Free_End)
return;
return 0;
if (TYPE(*tag) == T_Broken_Heart) {
SETPOINTER(*p, POINTER(*tag));
return;
return 0;
}
ALIGN(To);
switch (t) {
case T_Bignum:
size = sizeof (struct S_Bignum) - sizeof (gran_t)
+ BIGNUM(*p)->size * sizeof (gran_t);
bcopy ((char *)tag, To, size);
memcpy (To, tag, size);
break;
case T_Flonum:
size = sizeof (struct S_Flonum);
@ -130,12 +138,12 @@ again:
break;
case T_String:
size = sizeof (struct S_String) + STRING(*p)->size - 1;
bcopy ((char *)tag, To, size);
memcpy (To, tag, size);
break;
case T_Vector:
size = sizeof (struct S_Vector) + (VECTOR(*p)->size - 1) *
sizeof (Object);
bcopy ((char *)tag, To, size);
memcpy (To, tag, size);
break;
case T_Primitive:
size = sizeof (struct S_Primitive);
@ -148,7 +156,7 @@ again:
case T_Control_Point:
size = sizeof (struct S_Control) + CONTROL(*p)->size - 1;
reloc = To - (char *)tag;
bcopy ((char *)tag, To, size);
memcpy (To, tag, size);
break;
case T_Promise:
size = sizeof (struct S_Promise);
@ -175,7 +183,7 @@ again:
size = Types[t].const_size;
else
size = (Types[t].size)(*p);
bcopy ((char *)tag, To, size);
memcpy (To, tag, size);
}
SETPOINTER(*p, To);
SET(*tag, T_Broken_Heart, To);
@ -195,7 +203,7 @@ again:
p = &PAIR(*p)->cdr;
goto again;
case T_Vector: {
register i, n;
register int i, n;
for (i = 0, n = VECTOR(*p)->size; i < n; i++)
Recursive_Visit (&VECTOR(*p)->data[i]);
break;
@ -235,6 +243,8 @@ again:
if (Types[t].visit)
(Types[t].visit)(p, Visit);
}
return 0;
}
Object Internal_GC_Status (strat, flags) {

20
src/heap.c
View File

@ -14,7 +14,7 @@ static FUNCT *Before_GC_Funcs, *After_GC_Funcs;
static Object V_Garbage_Collect_Notifyp;
static Object Sym_Stop_And_Copy_GC, Sym_Generational_GC, Sym_Incremental_GC;
Init_Heap () {
void Init_Heap () {
Define_Variable (&V_Garbage_Collect_Notifyp, "garbage-collect-notify?",
True);
@ -23,7 +23,7 @@ Init_Heap () {
Define_Symbol (&Sym_Incremental_GC, "incremental");
}
Register_Before_GC (f) void (*f)(); {
void Register_Before_GC (void (*f)(void)) {
FUNCT *p;
p = (FUNCT *)Safe_Malloc (sizeof (*p));
@ -32,14 +32,14 @@ Register_Before_GC (f) void (*f)(); {
Before_GC_Funcs = p;
}
Call_Before_GC () {
void Call_Before_GC () {
FUNCT *p;
for (p = Before_GC_Funcs; p; p = p->next)
p->func();
}
Register_After_GC (f) void (*f)(); {
void Register_After_GC (void (*f)(void)) {
FUNCT *p;
p = (FUNCT *)Safe_Malloc (sizeof (*p));
@ -48,16 +48,16 @@ Register_After_GC (f) void (*f)(); {
After_GC_Funcs = p;
}
Call_After_GC () {
void Call_After_GC () {
FUNCT *p;
for (p = After_GC_Funcs; p; p = p->next)
p->func();
}
Visit_GC_List (list, delta) GCNODE *list; {
void Visit_GC_List (GCNODE *list, int delta) {
register GCNODE *gp, *p;
register n;
register int n;
register Object *vec;
for (gp = list; gp; gp = p->next) {
@ -72,7 +72,7 @@ Visit_GC_List (list, delta) GCNODE *list; {
}
}
Visit_Wind (list, delta) WIND *list; unsigned delta; {
void Visit_Wind (WIND *list, unsigned int delta) {
register WIND *wp, *p;
for (wp = list; wp; wp = p->next) {
@ -81,7 +81,7 @@ Visit_Wind (list, delta) WIND *list; unsigned delta; {
}
}
Func_Global_GC_Link (x) Object *x; {
void Func_Global_GC_Link (Object *x) {
GCNODE *p;
p = (GCNODE *)Safe_Malloc (sizeof (*p));
@ -98,7 +98,7 @@ Func_Global_GC_Link (x) Object *x; {
Object Internal_GC_Status();
Object P_Garbage_Collect_Status (argc, argv) Object* argv; {
Object P_Garbage_Collect_Status (int argc, Object* argv) {
int strat = 0, flags = 0;
if (argc > 0) {

82
src/io.c
View File

@ -4,7 +4,9 @@
#include "kernel.h"
#include <errno.h>
#include <stdio.h>
#include <pwd.h>
#include <string.h>
#include <sys/types.h>
#include <sys/param.h>
#include <sys/stat.h>
@ -13,13 +15,15 @@
# include <unistd.h>
#endif
extern void Flush_Output (Object);
extern int errno;
extern char *getenv();
Object Curr_Input_Port, Curr_Output_Port;
Object Standard_Input_Port, Standard_Output_Port;
Init_Io () {
void Init_Io () {
Standard_Input_Port = Make_Port (P_INPUT, stdin, Make_String ("stdin", 5));
Standard_Output_Port = Make_Port (0, stdout, Make_String ("stdout", 6));
Curr_Input_Port = Standard_Input_Port;
@ -30,7 +34,7 @@ Init_Io () {
Global_GC_Link (Curr_Output_Port);
}
Reset_IO (destructive) {
void Reset_IO (int destructive) {
Discard_Input (Curr_Input_Port);
if (destructive)
Discard_Output (Curr_Output_Port);
@ -40,9 +44,8 @@ Reset_IO (destructive) {
Curr_Output_Port = Standard_Output_Port;
}
Object Make_Port (flags, f, name) FILE *f; Object name; {
Object Make_Port (int flags, FILE *f, Object name) {
Object port;
extern fclose();
GC_Node;
GC_Link (name);
@ -57,17 +60,17 @@ Object Make_Port (flags, f, name) FILE *f; Object name; {
return port;
}
Object P_Port_File_Name (p) Object p; {
Object P_Port_File_Name (Object p) {
Check_Type (p, T_Port);
return (PORT(p)->flags & P_STRING) ? False : PORT(p)->name;
}
Object P_Port_Line_Number (p) Object p; {
Object P_Port_Line_Number (Object p) {
Check_Type (p, T_Port);
return Make_Unsigned (PORT(p)->lno);
}
Object P_Eof_Objectp (x) Object x; {
Object P_Eof_Objectp (Object x) {
return TYPE(x) == T_End_Of_File ? True : False;
}
@ -75,11 +78,11 @@ Object P_Current_Input_Port () { return Curr_Input_Port; }
Object P_Current_Output_Port () { return Curr_Output_Port; }
Object P_Input_Portp (x) Object x; {
Object P_Input_Portp (Object x) {
return TYPE(x) == T_Port && IS_INPUT(x) ? True : False;
}
Object P_Output_Portp (x) Object x; {
Object P_Output_Portp (Object x) {
return TYPE(x) == T_Port && IS_OUTPUT(x) ? True : False;
}
@ -91,7 +94,7 @@ int Path_Max () {
return MAXPATHLEN;
#else
#ifdef PATHCONF_PATH_MAX
static r;
static int r;
if (r == 0) {
if ((r = pathconf ("/", _PC_PATH_MAX)) == -1)
r = 1024;
@ -105,8 +108,8 @@ int Path_Max () {
#endif
}
Object Get_File_Name (name) Object name; {
register len;
Object Get_File_Name (Object name) {
register int len;
if (TYPE(name) == T_Symbol)
name = SYMBOL(name)->name;
@ -117,8 +120,8 @@ Object Get_File_Name (name) Object name; {
return name;
}
char *Internal_Tilde_Expand (s, dirp) register char *s, **dirp; {
register char *p;
char *Internal_Tilde_Expand (register char *s, register char **dirp) {
register char *p;
struct passwd *pw, *getpwnam();
if (*s++ != '~')
@ -133,11 +136,11 @@ char *Internal_Tilde_Expand (s, dirp) register char *s, **dirp; {
if ((pw = getpwnam (s)) == 0)
Primitive_Error ("unknown user: ~a", Make_String (s, strlen (s)));
*dirp = pw->pw_dir;
}
}
return p;
}
Object General_File_Operation (s, op) Object s; register op; {
Object General_File_Operation (Object s, register int op) {
register char *r;
Object ret, fn;
Alloca_Begin;
@ -164,36 +167,39 @@ Object General_File_Operation (s, op) Object s; register op; {
ret = stat (r, &st) == 0 ? True : False;
Alloca_End;
return ret;
}
default: {
return Null; /* Just to avoid compiler warnings */
}}
/*NOTREACHED*/
}
Object P_Tilde_Expand (s) Object s; {
Object P_Tilde_Expand (Object s) {
return General_File_Operation (s, 0);
}
Object P_File_Existsp (s) Object s; {
Object P_File_Existsp (Object s) {
return General_File_Operation (s, 1);
}
Close_All_Files () {
void Close_All_Files () {
Terminate_Type (T_Port);
}
Object Terminate_File (port) Object port; {
Object Terminate_File (Object port) {
(void)(PORT(port)->closefun) (PORT(port)->file);
PORT(port)->flags &= ~P_OPEN;
return Void;
}
Object Open_File (name, flags, err) char *name; {
Object Open_File (char *name, int flags, int err) {
register FILE *f;
char *dir, *p;
Object fn, port;
struct stat st;
Alloca_Begin;
if (p = Internal_Tilde_Expand (name, &dir)) {
if ((p = Internal_Tilde_Expand (name, &dir))) {
Alloca (name, char*, strlen (dir) + 1 + strlen (p) + 1);
sprintf (name, "%s/%s", dir, p);
}
@ -220,11 +226,11 @@ Object Open_File (name, flags, err) char *name; {
return port;
}
Object General_Open_File (name, flags, path) Object name, path; {
Object General_Open_File (Object name, int flags, Object path) {
Object port, pref;
char *buf = 0;
register char *fn;
register plen, len, blen = 0, gotpath = 0;
register int plen, len, blen = 0, gotpath = 0;
Alloca_Begin;
name = Get_File_Name (name);
@ -244,10 +250,10 @@ Object General_Open_File (name, flags, path) Object name, path; {
blen = len + plen + 2;
Alloca (buf, char*, blen);
}
bcopy (STRING(pref)->data, buf, plen);
memcpy (buf, STRING(pref)->data, plen);
if (buf[plen-1] != '/')
buf[plen++] = '/';
bcopy (fn, buf+plen, len);
memcpy (buf+plen, fn, len);
buf[len+plen] = '\0';
port = Open_File (buf, flags, 0);
/* No GC has been taken place in Open_File() if it returns Null.
@ -262,27 +268,27 @@ Object General_Open_File (name, flags, path) Object name, path; {
Primitive_Error ("file ~s not found", name);
if (len + 1 > blen)
Alloca (buf, char*, len + 1);
bcopy (fn, buf, len);
memcpy (buf, fn, len);
buf[len] = '\0';
port = Open_File (buf, flags, 1);
Alloca_End;
return port;
}
Object P_Open_Input_File (name) Object name; {
Object P_Open_Input_File (Object name) {
return General_Open_File (name, P_INPUT, Null);
}
Object P_Open_Output_File (name) Object name; {
Object P_Open_Output_File (Object name) {
return General_Open_File (name, 0, Null);
}
Object P_Open_Input_Output_File (name) Object name; {
Object P_Open_Input_Output_File (Object name) {
return General_Open_File (name, P_BIDIR, Null);
}
Object General_Close_Port (port) Object port; {
register flags, err = 0;
Object General_Close_Port (Object port) {
register int flags, err = 0;
FILE *f;
Check_Type (port, T_Port);
@ -303,11 +309,11 @@ Object General_Close_Port (port) Object port; {
return Void;
}
Object P_Close_Input_Port (port) Object port; {
Object P_Close_Input_Port (Object port) {
return General_Close_Port (port);
}
Object P_Close_Output_Port (port) Object port;{
Object P_Close_Output_Port (Object port) {
return General_Close_Port (port);
}
@ -330,7 +336,7 @@ Object P_Close_Output_Port (port) Object port;{
General_With (P_With_Input_From_File, Curr_Input_Port, P_INPUT)
General_With (P_With_Output_To_File, Curr_Output_Port, 0)
Object General_Call_With (name, flags, proc) Object name, proc; {
Object General_Call_With (Object name, int flags, Object proc) {
Object port, ret;
GC_Node2;
@ -344,15 +350,15 @@ Object General_Call_With (name, flags, proc) Object name, proc; {
return ret;
}
Object P_Call_With_Input_File (name, proc) Object name, proc; {
Object P_Call_With_Input_File (Object name, Object proc) {
return General_Call_With (name, P_INPUT, proc);
}
Object P_Call_With_Output_File (name, proc) Object name, proc; {
Object P_Call_With_Output_File (Object name, Object proc) {
return General_Call_With (name, 0, proc);
}
Object P_Open_Input_String (string) Object string; {
Object P_Open_Input_String (Object string) {
Check_Type (string, T_String);
return Make_Port (P_STRING|P_INPUT, (FILE *)0, string);
}

144
src/list.c
View File

@ -1,14 +1,17 @@
#include "kernel.h"
Object Const_Cons (car, cdr) Object car, cdr; {
extern unsigned int Stack_Size ();
extern void Uncatchable_Error (char *);
Object Const_Cons (Object car, Object cdr) {
Object ret;
ret = P_Cons (car, cdr);
SETCONST(ret);
return ret;
}
Object P_Cons (car, cdr) Object car, cdr; {
Object P_Cons (Object car, Object cdr) {
Object cell;
GC_Node2;
@ -38,17 +41,17 @@ Object P_Cons (car, cdr) Object car, cdr; {
return cell;
}
Object P_Car (x) Object x; {
Object P_Car (Object x) {
Check_Type (x, T_Pair);
return Car (x);
}
Object P_Cdr (x) Object x; {
Object P_Cdr (Object x) {
Check_Type (x, T_Pair);
return Cdr (x);
}
Object Cxr (x, pat, len) Object x; register char *pat; register len; {
Object Cxr (Object x, register char *pat, register int len) {
Object ret;
for (ret = x, pat += len; len > 0; len--)
@ -60,38 +63,38 @@ Object Cxr (x, pat, len) Object x; register char *pat; register len; {
return ret;
}
Object P_Cddr (x) Object x; { return Cxr (x, "dd", 2); }
Object P_Cdar (x) Object x; { return Cxr (x, "da", 2); }
Object P_Cadr (x) Object x; { return Cxr (x, "ad", 2); }
Object P_Caar (x) Object x; { return Cxr (x, "aa", 2); }
Object P_Cddr (Object x) { return Cxr (x, "dd", 2); }
Object P_Cdar (Object x) { return Cxr (x, "da", 2); }
Object P_Cadr (Object x) { return Cxr (x, "ad", 2); }
Object P_Caar (Object x) { return Cxr (x, "aa", 2); }
Object P_Cdddr (x) Object x; { return Cxr (x, "ddd", 3); }
Object P_Cddar (x) Object x; { return Cxr (x, "dda", 3); }
Object P_Cdadr (x) Object x; { return Cxr (x, "dad", 3); }
Object P_Cdaar (x) Object x; { return Cxr (x, "daa", 3); }
Object P_Caddr (x) Object x; { return Cxr (x, "add", 3); }
Object P_Cadar (x) Object x; { return Cxr (x, "ada", 3); }
Object P_Caadr (x) Object x; { return Cxr (x, "aad", 3); }
Object P_Caaar (x) Object x; { return Cxr (x, "aaa", 3); }
Object P_Cdddr (Object x) { return Cxr (x, "ddd", 3); }
Object P_Cddar (Object x) { return Cxr (x, "dda", 3); }
Object P_Cdadr (Object x) { return Cxr (x, "dad", 3); }
Object P_Cdaar (Object x) { return Cxr (x, "daa", 3); }
Object P_Caddr (Object x) { return Cxr (x, "add", 3); }
Object P_Cadar (Object x) { return Cxr (x, "ada", 3); }
Object P_Caadr (Object x) { return Cxr (x, "aad", 3); }
Object P_Caaar (Object x) { return Cxr (x, "aaa", 3); }
Object P_Caaaar (x) Object x; { return Cxr (x, "aaaa", 4); }
Object P_Caaadr (x) Object x; { return Cxr (x, "aaad", 4); }
Object P_Caadar (x) Object x; { return Cxr (x, "aada", 4); }
Object P_Caaddr (x) Object x; { return Cxr (x, "aadd", 4); }
Object P_Cadaar (x) Object x; { return Cxr (x, "adaa", 4); }
Object P_Cadadr (x) Object x; { return Cxr (x, "adad", 4); }
Object P_Caddar (x) Object x; { return Cxr (x, "adda", 4); }
Object P_Cadddr (x) Object x; { return Cxr (x, "addd", 4); }
Object P_Cdaaar (x) Object x; { return Cxr (x, "daaa", 4); }
Object P_Cdaadr (x) Object x; { return Cxr (x, "daad", 4); }
Object P_Cdadar (x) Object x; { return Cxr (x, "dada", 4); }
Object P_Cdaddr (x) Object x; { return Cxr (x, "dadd", 4); }
Object P_Cddaar (x) Object x; { return Cxr (x, "ddaa", 4); }
Object P_Cddadr (x) Object x; { return Cxr (x, "ddad", 4); }
Object P_Cdddar (x) Object x; { return Cxr (x, "ddda", 4); }
Object P_Cddddr (x) Object x; { return Cxr (x, "dddd", 4); }
Object P_Caaaar (Object x) { return Cxr (x, "aaaa", 4); }
Object P_Caaadr (Object x) { return Cxr (x, "aaad", 4); }
Object P_Caadar (Object x) { return Cxr (x, "aada", 4); }
Object P_Caaddr (Object x) { return Cxr (x, "aadd", 4); }
Object P_Cadaar (Object x) { return Cxr (x, "adaa", 4); }
Object P_Cadadr (Object x) { return Cxr (x, "adad", 4); }
Object P_Caddar (Object x) { return Cxr (x, "adda", 4); }
Object P_Cadddr (Object x) { return Cxr (x, "addd", 4); }
Object P_Cdaaar (Object x) { return Cxr (x, "daaa", 4); }
Object P_Cdaadr (Object x) { return Cxr (x, "daad", 4); }
Object P_Cdadar (Object x) { return Cxr (x, "dada", 4); }
Object P_Cdaddr (Object x) { return Cxr (x, "dadd", 4); }
Object P_Cddaar (Object x) { return Cxr (x, "ddaa", 4); }
Object P_Cddadr (Object x) { return Cxr (x, "ddad", 4); }
Object P_Cdddar (Object x) { return Cxr (x, "ddda", 4); }
Object P_Cddddr (Object x) { return Cxr (x, "dddd", 4); }
Object P_Cxr (x, pat) Object x, pat; {
Object P_Cxr (Object x, Object pat) {
Check_List (x);
if (TYPE(pat) == T_Symbol)
pat = SYMBOL(pat)->name;
@ -100,17 +103,17 @@ Object P_Cxr (x, pat) Object x, pat; {
return Cxr (x, STRING(pat)->data, STRING(pat)->size);
}
Object P_Nullp (x) Object x; {
Object P_Nullp (Object x) {
return Nullp (x) ? True : False;
}
Object P_Pairp (x) Object x; {
Object P_Pairp (Object x) {
return TYPE(x) == T_Pair ? True : False;
}
Object P_Listp (x) Object x; {
Object P_Listp (Object x) {
Object s;
register f;
register int f;
for (s = x, f = 0; !Nullp (x); f ^= 1) {
if (TYPE(x) != T_Pair)
@ -123,22 +126,22 @@ Object P_Listp (x) Object x; {
return True;
}
Object P_Set_Car (x, new) Object x, new; {
Object P_Set_Car (Object x, Object new) {
Check_Type (x, T_Pair);
Check_Mutable (x);
Car (x) = new;
return new;
}
Object P_Set_Cdr (x, new) Object x, new; {
Object P_Set_Cdr (Object x, Object new) {
Check_Type (x, T_Pair);
Check_Mutable (x);
Cdr (x) = new;
return new;
}
Object General_Member (key, list, comp) Object key, list; register comp; {
register r;
Object General_Member (Object key, Object list, register int comp) {
register int r;
for ( ; !Nullp (list); list = Cdr (list)) {
Check_List (list);
@ -153,21 +156,21 @@ Object General_Member (key, list, comp) Object key, list; register comp; {
return False;
}
Object P_Memq (key, list) Object key, list; {
Object P_Memq (Object key, Object list) {
return General_Member (key, list, 0);
}
Object P_Memv (key, list) Object key, list; {
Object P_Memv (Object key, Object list) {
return General_Member (key, list, 1);
}
Object P_Member (key, list) Object key, list; {
Object P_Member (Object key, Object list) {
return General_Member (key, list, 2);
}
Object General_Assoc (key, alist, comp) Object key, alist; register comp; {
Object General_Assoc (Object key, Object alist, register int comp) {
Object elem;
register r;
register int r;
for ( ; !Nullp (alist); alist = Cdr (alist)) {
Check_List (alist);
@ -185,38 +188,38 @@ Object General_Assoc (key, alist, comp) Object key, alist; register comp; {
return False;
}
Object P_Assq (key, alist) Object key, alist; {
Object P_Assq (Object key, Object alist) {
return General_Assoc (key, alist, 0);
}
Object P_Assv (key, alist) Object key, alist; {
Object P_Assv (Object key, Object alist) {
return General_Assoc (key, alist, 1);
}
Object P_Assoc (key, alist) Object key, alist; {
Object P_Assoc (Object key, Object alist) {
return General_Assoc (key, alist, 2);
}
Fast_Length (list) Object list; {
int Fast_Length (Object list) {
Object tail;
register i;
register int i;
for (i = 0, tail = list; TYPE(tail) == T_Pair; tail = Cdr (tail), i++)
;
return i;
}
Object P_Length (list) Object list; {
Object P_Length (Object list) {
Object tail;
register i;
register int i;
for (i = 0, tail = list; !Nullp (tail); tail = Cdr (tail), i++)
Check_List (tail);
return Make_Integer (i);
}
Object P_Make_List (n, init) Object n, init; {
register len;
Object P_Make_List (Object n, Object init) {
register int len;
Object list;
GC_Node;
@ -230,7 +233,7 @@ Object P_Make_List (n, init) Object n, init; {
return list;
}
Object P_List (argc, argv) Object *argv; {
Object P_List (int argc, Object *argv) {
Object list, tail, cell;
GC_Node2;
@ -246,15 +249,15 @@ Object P_List (argc, argv) Object *argv; {
return list;
}
Object P_Last_Pair (x) Object x; {
Object P_Last_Pair (Object x) {
Check_Type (x, T_Pair);
for ( ; TYPE(Cdr (x)) == T_Pair; x = Cdr (x)) ;
return x;
}
Object P_Append (argc, argv) Object *argv; {
Object P_Append (int argc, Object *argv) {
Object list, last, tail, cell;
register i;
register int i;
GC_Node3;
list = last = Null;
@ -270,17 +273,18 @@ Object P_Append (argc, argv) Object *argv; {
last = cell;
}
}
if (argc)
if (argc) {
if (Nullp (list))
list = argv[i];
else
(void)P_Set_Cdr (last, argv[i]);
}
GC_Unlink;
return list;
}
Object P_Append_Set (argc, argv) Object *argv; {
register i, j;
Object P_Append_Set (int argc, Object *argv) {
register int i, j;
for (i = j = 0; i < argc; i++)
if (!Nullp (argv[i]))
@ -292,7 +296,7 @@ Object P_Append_Set (argc, argv) Object *argv; {
return *argv;
}
Object P_Reverse (x) Object x; {
Object P_Reverse (Object x) {
Object ret;
GC_Node;
@ -305,7 +309,7 @@ Object P_Reverse (x) Object x; {
return ret;
}
Object P_Reverse_Set (x) Object x; {
Object P_Reverse_Set (Object x) {
Object prev, tail;
for (prev = Null; !Nullp (x); prev = x, x = tail) {
@ -316,19 +320,19 @@ Object P_Reverse_Set (x) Object x; {
return prev;
}
Object P_List_Tail (x, num) Object x, num; {
register n;
Object P_List_Tail (Object x, Object num) {
register int n;
for (n = Get_Exact_Integer (num); n > 0 && !Nullp (x); n--, x = P_Cdr (x))
;
return x;
}
Object P_List_Ref (x, num) Object x, num; {
Object P_List_Ref (Object x, Object num) {
return P_Car (P_List_Tail (x, num));
}
Object Copy_List (x) Object x; {
Object Copy_List (Object x) {
Object car, cdr;
GC_Node3;

26
src/load-dl.c
View File

@ -1,10 +1,12 @@
#include <dlfcn.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
extern char *strrchr();
extern char *getenv();
extern void Free_Symbols (SYMTAB *);
extern void Call_Initializers (SYMTAB *, char *, int);
Dlopen_File (fn) char *fn; {
void Dlopen_File (char *fn) {
void *handle;
SYM *sp;
@ -23,23 +25,23 @@ Dlopen_File (fn) char *fn; {
* this can be safely ignored.
*/
for (sp = The_Symbols->first; sp; sp = sp->next)
sp->value = (unsigned long)dlsym (handle, sp->name);
sp->value = (unsigned long int)dlsym (handle, sp->name);
Call_Initializers (The_Symbols, 0, PR_CONSTRUCTOR);
Call_Initializers (The_Symbols, 0, PR_EXTENSION);
}
static char *tempname;
static char *tmpdir;
static tmplen;
static Seq_Num;
static int tmplen;
static int Seq_Num;
char *Temp_Name (seq) int seq; {
char *Temp_Name (int seq) {
if (!tempname) {
if (!(tmpdir = getenv ("TMPDIR")))
tmpdir = "/tmp";
tempname = Safe_Malloc (tmplen = strlen (tmpdir) + 20);
sprintf (tempname, "%s/ldXXXXXX", tmpdir);
(void)mkstemp (tempname);
(void)mktemp (tempname);
strcat (tempname, ".");
}
sprintf (strrchr (tempname, '.'), ".%d", seq);
@ -55,7 +57,7 @@ void Fork_Load () {
Disable_Interrupts;
newtemp = Safe_Malloc (tmplen);
sprintf (newtemp, "%s/ldXXXXXX", tmpdir);
(void)mkstemp (newtemp);
(void)mktemp (newtemp);
strcat (newtemp, ".");
for (i = 0; i < Seq_Num; i++) {
sprintf (strrchr (newtemp, '.'), ".%d", i);
@ -66,7 +68,7 @@ void Fork_Load () {
Enable_Interrupts;
}
Load_Object (names) Object names; {
void Load_Object (Object names) {
Object port, tail, fullnames, libs;
char *lp, *buf, *outfile;
int len, liblen, i;
@ -87,8 +89,10 @@ Load_Object (names) Object names; {
if (TYPE(libs) == T_String) {
liblen = STRING(libs)->size;
lp = STRING(libs)->data;
} else
} else {
liblen = 0;
lp = "";
}
Disable_Interrupts;

13
src/load-ld.c
View File

@ -15,17 +15,20 @@
struct headers {
struct filehdr fhdr;
struct aouthdr aout;
struct scnhdr section[3];
struct scnhdr section[3];
};
#endif
extern void Free_Symbols (SYMTAB *);
extern void Call_Initializers (SYMTAB *, char *, int);
extern void *sbrk();
extern char *getenv();
static char *Loader_Output;
static char *tmpdir;
Load_Object (names) Object names; {
Load_Object (Object names) {
#ifdef ECOFF
struct headers hdr;
#else
@ -33,7 +36,7 @@ Load_Object (names) Object names; {
#endif
register char *brk, *obrk, *lp, *li;
char *buf;
register n, f, len, liblen;
register int n, f, len, liblen;
Object port, tail, fullnames, libs;
FILE *fp;
GC_Node3;
@ -78,7 +81,7 @@ Load_Object (names) Object names; {
#else
sprintf (buf, "%s -N %s -A %s -T %x -o %s ",
#endif
LD_NAME, INC_LDFLAGS, li, (unsigned)brk, Loader_Output);
LD_NAME, INC_LDFLAGS, li, (unsigned int)brk, Loader_Output);
for (tail = fullnames; !Nullp (tail); tail = Cdr (tail)) {
register struct S_String *str = STRING(Car (tail));
@ -117,7 +120,7 @@ err:
close (f);
Primitive_Error ("not enough memory to load object file");
}
bzero (brk, n);
memset (brk, 0, n);
#ifdef ECOFF
n -= hdr.aout.bsize;
(void)lseek (f, (off_t)hdr.section[0].s_scnptr, 0);

9
src/load-rld.c
View File

@ -1,11 +1,14 @@
#include <mach-o/rld.h>
Load_Object (names) Object names; {
extern void Free_Symbols (SYMTAB *);
extern void Call_Initializers (SYMTAB *, char *, int);
Load_Object (Object names) {
long retval;
struct mach_header *hdr;
char **filenames, *libs;
NXStream *err_stream;
register i, n;
register int i, n;
Object port, tail, fullnames;
extern char *strtok();
GC_Node3;
@ -28,7 +31,7 @@ Load_Object (names) Object names; {
Alloca (filenames, char**, (n+1 + strlen (libs)/2) * sizeof (char *));
for (i = 0; i < n; i++, fullnames = Cdr (fullnames)) {
Object s;
s = Car (fullnames);
Get_Strsym_Stack (s, filenames[i]);
}

7
src/load-shl.c
View File

@ -1,9 +1,12 @@
#include <dl.h>
#include <string.h>
extern void Free_Symbols (SYMTAB *);
extern void Call_Initializers (SYMTAB *, char *, int);
extern int errno;
static void Load_Them (names) Object names; {
static void Load_Them (Object names) {
char *fn;
shl_t handle;
SYM *sp;
@ -47,7 +50,7 @@ static void Load_Them (names) Object names; {
Alloca_End;
}
Load_Object (names) Object names; {
Load_Object (Object names) {
Object port, tail, fullnames, str;
char *p, *libs = "";
GC_Node3;

29
src/load.c
View File

@ -10,6 +10,9 @@ Object V_Load_Path, V_Load_Noisilyp, V_Load_Libraries;
char *Loader_Input; /* tmp file name used by load.xx.c */
extern void Switch_Environment (Object);
void Load_Source (Object);
#ifdef CAN_LOAD_OBJ
void Fork_Load();
#endif
@ -30,23 +33,23 @@ char *Loader_Input; /* tmp file name used by load.xx.c */
#endif
#endif
Init_Load () {
void Init_Load () {
Define_Variable (&V_Load_Path, "load-path",
Cons (Make_String (".", 1),
Cons (Make_String (SCM_DIR, sizeof (SCM_DIR) - 1),
Cons (Make_String (OBJ_DIR, sizeof (OBJ_DIR) - 1), Null))));
Define_Variable (&V_Load_Noisilyp, "load-noisily?", False);
Define_Variable (&V_Load_Libraries, "load-libraries",
Define_Variable (&V_Load_Libraries, "load-libraries",
Make_String (Default_Load_Libraries, sizeof Default_Load_Libraries-1));
#ifdef CAN_LOAD_OBJ
Register_Onfork (Fork_Load);
#endif
}
Init_Loadpath (s) char *s; { /* No GC possible here */
void Init_Loadpath (char *s) { /* No GC possible here */
register char *p;
Object path;
path = Null;
if (s[0] == '\0')
return;
@ -61,7 +64,7 @@ Init_Loadpath (s) char *s; { /* No GC possible here */
Var_Set (V_Load_Path, P_Reverse (path));
}
Is_O_File (name) Object name; {
int Is_O_File (Object name) {
register char *p;
register struct S_String *str;
@ -72,9 +75,9 @@ Is_O_File (name) Object name; {
return str->size >= 2 && *--p == 'o' && *--p == '.';
}
void Check_Loadarg (x) Object x; {
void Check_Loadarg (Object x) {
Object tail;
register t = TYPE(x);
register int t = TYPE(x);
if (t == T_Symbol || t == T_String)
return;
@ -82,7 +85,7 @@ void Check_Loadarg (x) Object x; {
Wrong_Type_Combination (x, "string, symbol, or list");
for (tail = x; !Nullp (tail); tail = Cdr (tail)) {
Object f;
f = Car (tail);
if (TYPE(f) != T_Symbol && TYPE(f) != T_String)
Wrong_Type_Combination (f, "string or symbol");
@ -91,7 +94,7 @@ void Check_Loadarg (x) Object x; {
}
}
Object General_Load (what, env) Object what, env; {
Object General_Load (Object what, Object env) {
Object oldenv;
GC_Node;
@ -117,11 +120,11 @@ Object General_Load (what, env) Object what, env; {
return Void;
}
Object P_Load (argc, argv) Object *argv; {
Object P_Load (int argc, Object *argv) {
return General_Load (argv[0], argc == 1 ? The_Environment : argv[1]);
}
void Load_Source_Port (port) Object port; {
void Load_Source_Port (Object port) {
Object val;
GC_Node;
TC_Prolog;
@ -142,7 +145,7 @@ void Load_Source_Port (port) Object port; {
GC_Unlink;
}
Load_Source (name) Object name; {
void Load_Source (Object name) {
Object port;
GC_Node;
@ -155,7 +158,7 @@ Load_Source (name) Object name; {
/* Interface to P_Load() for use by applications.
*/
void Load_File (name) char *name; {
void Load_File (char *name) {
Object arg;
arg = Make_String(name, strlen(name));

77
src/main.c
View File

@ -2,6 +2,9 @@
#include <errno.h>
#include <limits.h>
#include <string.h>
#include <stdlib.h>
#include <malloc.h>
#include <sys/types.h>
#include <sys/stat.h>
@ -18,8 +21,42 @@
# endif
#endif
extern void Call_Initializers (SYMTAB *, char *, int);
extern void Load_Source (Object);
extern void Call_Finalizers ();
extern void Finit_Load ();
extern void Generational_GC_Reinitialize ();
extern int Check_Stack_Grows_Down ();
extern void Make_Heap (int);
extern void Free_Heap ();
extern void Init_Auto (void);
extern void Init_Cstring();
extern void Init_Dump ();
extern void Init_Env ();
extern void Init_Error ();
extern void Init_Exception ();
extern void Init_Features ();
extern void Init_Heap ();
extern void Init_Io ();
extern void Init_Load ();
extern void Init_Loadpath (char *);
extern void Init_Math ();
extern void Init_Prim ();
extern void Init_Print ();
extern void Init_Proc ();
extern void Init_Read ();
extern void Init_Special ();
extern void Init_String ();
extern void Init_Symbol ();
extern void Init_Terminate ();
extern void Init_Type();
extern char *getenv();
void Get_Stack_Limit ();
void Usage ();
void Init_Everything ();
char *stkbase;
int Stack_Grows_Down;
unsigned int Max_Stack;
@ -47,6 +84,7 @@ void Exit_Handler () {
#ifdef CAN_LOAD_OBJ
Finit_Load ();
#endif
Free_Heap ();
}
#ifndef ATEXIT
@ -76,7 +114,7 @@ char *Brk_On_Dump;
* This cannot be fixed without changing Elk_Init() and its use in
* an incompatible way.
*/
Check_If_Dump_Works () {
void Check_If_Dump_Works () {
#ifdef NOMAIN
Primitive_Error ("not yet supported for standalone applications");
#endif
@ -85,18 +123,18 @@ Check_If_Dump_Works () {
#ifdef NOMAIN
void Elk_Init (ac, av, init_objects, toplevel) char **av, *toplevel; {
void Elk_Init (int ac, char **av, int init_objects, char *toplevel) {
#else
main (ac, av) char **av; {
int main (int ac, char **av) {
#endif
/* To avoid that the stack copying code overwrites argv if a dumped
* copy of the interpreter is invoked with more arguments than the
* original a.out, move the stack base INITIAL_STK_OFFSET bytes down.
* The call to bzero() is there to prevent the optimizer from removing
* The call to memset() is there to prevent the optimizer from removing
* the array.
*/
#ifdef CAN_DUMP
@ -107,13 +145,16 @@ main (ac, av) char **av; {
Object file;
struct stat st;
extern int errno;
char foo;
#ifdef CAN_DUMP
#ifdef NOMAIN
# define foo (av[0][0])
#else
char foo;
#endif
#endif
#ifdef CAN_DUMP
bzero (unused, 1); /* see comment above */
memset (unused, 0, 1); /* see comment above */
#endif
if (ac == 0) {
av[0] = "Elk"; ac = 1;
@ -136,12 +177,13 @@ main (ac, av) char **av; {
fprintf (stderr,
"Can't restart dumped interpreter from a different machine architecture\n");
fprintf (stderr,
" (Stack delta = %d bytes).\n", stkbase - &foo);
" (Stack delta = %lld bytes).\n", (long long int)(ptrdiff_t)(stkbase - &foo));
exit (1);
}
/* Check if program break must be reset.
*/
if (Brk_On_Dump && (char *)brk (Brk_On_Dump) == (char *)-1) {
if ((ptrdiff_t)Brk_On_Dump && (ptrdiff_t)brk (Brk_On_Dump)
== (ptrdiff_t)-1) {
perror ("brk"); exit (1);
}
#if defined(HP9K) && defined(CAN_DUMP) && defined(HPSHLIB)
@ -220,7 +262,7 @@ main (ac, av) char **av; {
#endif
if (loadpath || (loadpath = getenv (LOADPATH_ENV)))
Init_Loadpath (loadpath);
/* The following code is sort of a hack. initscheme.scm should not
* be resolved against load-path. However, the .scm-files may not
* have been installed yet (note that the interpreter is already
@ -277,7 +319,7 @@ called",
" [--] End options and begin arguments",
0 };
Usage () {
void Usage () {
char **p;
fprintf (stderr, "Usage: %s [options] [arguments]\n", Argv[0]);
@ -286,7 +328,7 @@ Usage () {
exit (1);
}
Init_Everything () {
void Init_Everything () {
Init_Type ();
Init_Cstring ();
Init_String ();
@ -311,7 +353,7 @@ Init_Everything () {
#endif
}
Get_Stack_Limit () {
void Get_Stack_Limit () {
#ifdef MAX_STACK_SIZE
Max_Stack = MAX_STACK_SIZE;
#else
@ -321,21 +363,20 @@ Get_Stack_Limit () {
perror ("getrlimit");
exit (1);
}
Max_Stack = rl.rlim_cur;
#endif
Max_Stack -= STACK_MARGIN;
}
#ifdef FIND_AOUT
Executable (fn) char *fn; {
int Executable (char *fn) {
struct stat s;
return stat (fn, &s) != -1 && (s.st_mode & S_IFMT) == S_IFREG
&& access (fn, X_OK) != -1;
}
char *Find_Executable (fn) char *fn; {
char *Find_Executable (char *fn) {
char *path, *dir, *getenv();
static char buf[1025]; /* Can't use Path_Max or Safe_Malloc here */
register char *p;
@ -372,14 +413,14 @@ char *Find_Executable (fn) char *fn; {
Object P_Command_Line_Args () {
Object ret, tail;
register i;
register int i;
GC_Node2;
ret = tail = P_Make_List (Make_Integer (Argc-First_Arg), Null);
GC_Link2 (ret, tail);
for (i = First_Arg; i < Argc; i++, tail = Cdr (tail)) {
Object a;
a = Make_String (Argv[i], strlen (Argv[i]));
Car (tail) = a;
}
@ -387,7 +428,7 @@ Object P_Command_Line_Args () {
return ret;
}
Object P_Exit (argc, argv) Object *argv; {
Object P_Exit (int argc, Object *argv) {
exit (argc == 0 ? 0 : Get_Unsigned (argv[0]));
/*NOTREACHED*/
}

14
src/malloc.c
View File

@ -1,31 +1,33 @@
#include "kernel.h"
extern char *malloc(), *realloc();
#include <stdlib.h>
char *Safe_Malloc (size) unsigned size; {
char *Safe_Malloc (unsigned int size) {
char *ret;
Disable_Interrupts;
if ((ret = malloc (size)) == 0)
if ((ret = malloc (size)) == 0) {
if (Interpreter_Initialized)
Primitive_Error ("not enough memory to malloc ~s bytes",
Make_Integer (size));
else
Fatal_Error ("not enough memory to malloc %u bytes", size);
}
Enable_Interrupts;
return ret;
}
char *Safe_Realloc (ptr, size) char *ptr; unsigned size; {
char *Safe_Realloc (char *ptr, unsigned int size) {
char *ret;
Disable_Interrupts;
if ((ret = ptr ? realloc (ptr, size) : malloc (size)) == 0)
if ((ret = ptr ? realloc (ptr, size) : malloc (size)) == 0) {
if (Interpreter_Initialized)
Primitive_Error ("not enough memory to malloc ~s bytes",
Make_Integer (size));
else
Fatal_Error ("not enough memory to malloc %u bytes", size);
}
Enable_Interrupts;
return ret;
}

276
src/math.c
View File

@ -4,14 +4,18 @@
#include <math.h>
#include <errno.h>
#include <limits.h>
#include <stdlib.h>
#include <string.h>
#include <sys/types.h>
#include <unistd.h>
#include "kernel.h"
extern int errno;
extern int Bignum_To_Integer (Object);
Object Generic_Multiply(), Generic_Divide();
Init_Math () {
void Init_Math () {
#ifdef RANDOM
srandom (getpid ());
#else
@ -19,38 +23,38 @@ Init_Math () {
#endif
}
Object Make_Integer (n) register n; {
Object Make_Integer (register int n) {
Object num;
SET(num, T_Fixnum, n);
return num;
}
Object Make_Unsigned (n) register unsigned n; {
Object Make_Unsigned (register unsigned int n) {
if (UFIXNUM_FITS(n))
return Make_Integer (n);
else
return Unsigned_To_Bignum (n);
}
Object Make_Long (n) register long n; {
Object Make_Long (register long int n) {
if (n < 0 ? (n < (long)INT_MIN) : (n > (long)INT_MAX))
return Long_To_Bignum (n);
else
return Make_Integer ((int)n);
}
Object Make_Unsigned_Long (n) register unsigned long n; {
if ((n & ~((unsigned long)SIGNBIT-1)) == 0)
Object Make_Unsigned_Long (register unsigned long int n) {
if ((n & ~((unsigned long int)SIGNBIT-1)) == 0)
return Make_Integer ((int)n);
else
return Unsigned_Long_To_Bignum (n);
}
Object Fixnum_To_String (x, radix) Object x; {
Object Fixnum_To_String (Object x, int radix) {
char buf[32];
register char *p;
register n = FIXNUM(x), neg = 0;
register int n = FIXNUM(x), neg = 0;
if (n == 0)
return Make_String ("0", 1);
@ -71,7 +75,7 @@ Object Fixnum_To_String (x, radix) Object x; {
return Make_String (p, strlen (p));
}
char *Flonum_To_String (x) Object x; {
char *Flonum_To_String (Object x) {
static char buf[32];
char *p;
@ -83,7 +87,7 @@ char *Flonum_To_String (x) Object x; {
return buf;
}
Object P_Number_To_String (argc, argv) Object *argv; {
Object P_Number_To_String (int argc, Object *argv) {
int radix = 10;
Object x;
char *s;
@ -109,11 +113,13 @@ Object P_Number_To_String (argc, argv) Object *argv; {
Primitive_Error ("radix for reals must be 10"); /* bleah! */
s = Flonum_To_String (x);
return Make_String (s, strlen (s));
default: /* Just to avoid compiler warnings */
return Null;
}
/*NOTREACHED*/
}
Get_Integer (x) Object x; {
int Get_Integer (Object x) {
double d;
int expo;
@ -136,7 +142,7 @@ Get_Integer (x) Object x; {
/*NOTREACHED*/
}
unsigned Get_Unsigned (x) Object x; {
unsigned int Get_Unsigned (Object x) {
double d;
int expo;
@ -164,7 +170,7 @@ err:
/*NOTREACHED*/
}
long Get_Long (x) Object x; {
long int Get_Long (Object x) {
double d;
int expo;
@ -187,7 +193,7 @@ long Get_Long (x) Object x; {
/*NOTREACHED*/
}
unsigned long Get_Unsigned_Long (x) Object x; {
unsigned long int Get_Unsigned_Long (Object x) {
double d;
int expo;
@ -195,7 +201,7 @@ unsigned long Get_Unsigned_Long (x) Object x; {
case T_Fixnum:
if (FIXNUM(x) < 0)
goto err;
return (unsigned long)FIXNUM(x);
return (unsigned long int)FIXNUM(x);
case T_Bignum:
return Bignum_To_Unsigned_Long (x);
case T_Flonum:
@ -215,7 +221,7 @@ err:
/*NOTREACHED*/
}
Get_Exact_Integer (x) Object x; {
int Get_Exact_Integer (Object x) {
switch (TYPE(x)) {
case T_Fixnum:
return FIXNUM(x);
@ -227,7 +233,7 @@ Get_Exact_Integer (x) Object x; {
/*NOTREACHED*/
}
unsigned Get_Exact_Unsigned (x) Object x; {
unsigned int Get_Exact_Unsigned (Object x) {
switch (TYPE(x)) {
case T_Fixnum:
if (FIXNUM(x) < 0)
@ -241,7 +247,7 @@ unsigned Get_Exact_Unsigned (x) Object x; {
/*NOTREACHED*/
}
long Get_Exact_Long (x) Object x; {
long int Get_Exact_Long (Object x) {
switch (TYPE(x)) {
case T_Fixnum:
return FIXNUM(x);
@ -253,7 +259,7 @@ long Get_Exact_Long (x) Object x; {
/*NOTREACHED*/
}
unsigned long Get_Exact_Unsigned_Long (x) Object x; {
unsigned long int Get_Exact_Unsigned_Long (Object x) {
switch (TYPE(x)) {
case T_Fixnum:
if (FIXNUM(x) < 0)
@ -267,8 +273,8 @@ unsigned long Get_Exact_Unsigned_Long (x) Object x; {
/*NOTREACHED*/
}
Get_Index (n, obj) Object n, obj; {
register size, i;
int Get_Index (Object n, Object obj) {
register int size, i;
i = Get_Exact_Integer (n);
size = TYPE(obj) == T_Vector ? VECTOR(obj)->size : STRING(obj)->size;
@ -277,7 +283,7 @@ Get_Index (n, obj) Object n, obj; {
return i;
}
Object Make_Flonum (d) double d; {
Object Make_Flonum (double d) {
Object num;
num = Alloc_Object (sizeof (struct S_Flonum), T_Flonum, 0);
@ -286,7 +292,7 @@ Object Make_Flonum (d) double d; {
return num;
}
Object Make_Reduced_Flonum (d) double d; {
Object Make_Reduced_Flonum (double d) {
Object num;
int expo;
@ -303,7 +309,7 @@ Object Make_Reduced_Flonum (d) double d; {
return num;
}
Fixnum_Add (a, b, fits) int *fits; {
int Fixnum_Add (int a, int b, int *fits) {
int ret = a + b;
*fits = 1;
@ -315,7 +321,7 @@ Fixnum_Add (a, b, fits) int *fits; {
return ret;
}
Fixnum_Sub (a, b, fits) int *fits; {
int Fixnum_Sub (int a, int b, int *fits) {
int ret = a - b;
*fits = 1;
@ -332,11 +338,11 @@ Fixnum_Sub (a, b, fits) int *fits; {
* resulting bignum gets reduced to a fixnum (if it fits) anyway.
* (This should be fixed, though...)
*/
Object Fixnum_Multiply (a, b) {
register unsigned aa = a;
register unsigned ab = b;
register unsigned prod, prod2;
register sign = 1;
Object Fixnum_Multiply (int a, int b) {
register unsigned int aa = a;
register unsigned int ab = b;
register unsigned int prod, prod2;
register int sign = 1;
if (a < 0) {
aa = -a;
sign = -1;
@ -358,7 +364,7 @@ Object Fixnum_Multiply (a, b) {
if (prod2 > (1 << (FIXBITS - 1 - 16)) - 1) {
if (sign == 1 || prod2 != (1 << (FIXBITS - 1 - 16)) || prod != 0)
return Null;
return Make_Integer (-(unsigned)SIGNBIT);
return Make_Integer (-(unsigned int)SIGNBIT);
}
prod += prod2 << 16;
if (sign == -1)
@ -366,7 +372,7 @@ Object Fixnum_Multiply (a, b) {
return Make_Integer (prod);
}
Object P_Integerp (x) Object x; {
Object P_Integerp (Object x) {
double d;
switch (TYPE(x)) {
@ -379,34 +385,34 @@ Object P_Integerp (x) Object x; {
return False;
}
Object P_Rationalp (x) Object x; {
Object P_Rationalp (Object x) {
return P_Integerp (x);
}
Object P_Realp (x) Object x; {
register t = TYPE(x);
Object P_Realp (Object x) {
register int t = TYPE(x);
return t == T_Flonum || t == T_Fixnum || t == T_Bignum ? True : False;
}
Object P_Complexp (x) Object x; {
Object P_Complexp (Object x) {
return P_Realp (x);
}
Object P_Numberp (x) Object x; {
Object P_Numberp (Object x) {
return P_Complexp (x);
}
Object P_Exactp (n) Object n; {
Object P_Exactp (Object n) {
Check_Number (n);
return TYPE(n) == T_Flonum ? False : True;
}
Object P_Inexactp (n) Object n; {
Object P_Inexactp (Object n) {
Check_Number (n);
return TYPE(n) == T_Flonum ? True : False;
}
Object P_Exact_To_Inexact (n) Object n; {
Object P_Exact_To_Inexact (Object n) {
Check_Number (n);
switch (TYPE(n)) {
case T_Fixnum:
@ -415,11 +421,13 @@ Object P_Exact_To_Inexact (n) Object n; {
return n;
case T_Bignum:
return Make_Flonum (Bignum_To_Double (n));
default: /* Just to avoid compiler warnings */
return Null;
}
/*NOTREACHED*/
}
Object P_Inexact_To_Exact (n) Object n; {
Object P_Inexact_To_Exact (Object n) {
double d;
int i;
@ -432,12 +440,14 @@ Object P_Inexact_To_Exact (n) Object n; {
d = floor (FLONUM(n)->val + 0.5);
(void)frexp (d, &i);
return (i <= FIXBITS-1) ? Make_Integer ((int)d) : Double_To_Bignum (d);
default: /* Just to avoid compiler warnings */
return Null;
}
/*NOTREACHED*/
}
#define General_Generic_Predicate(prim,op,bigop) Object prim (x) Object x; {\
register ret;\
#define General_Generic_Predicate(prim,op,bigop) Object prim (Object x) {\
register int ret;\
Check_Number (x);\
switch (TYPE(x)) {\
case T_Flonum:\
@ -446,6 +456,8 @@ Object P_Inexact_To_Exact (n) Object n; {
ret = FIXNUM(x) op 0; break;\
case T_Bignum:\
ret = bigop (x); break;\
default: /* Just to avoid compiler warnings */\
return False;\
}\
return ret ? True : False;\
}
@ -454,8 +466,8 @@ General_Generic_Predicate (P_Zerop, ==, Bignum_Zero)
General_Generic_Predicate (P_Negativep, <, Bignum_Negative)
General_Generic_Predicate (P_Positivep, >, Bignum_Positive)
Object P_Evenp (x) Object x; {
register ret;
Object P_Evenp (Object x) {
register int ret;
double d;
switch (TYPE(x)) {
@ -478,14 +490,14 @@ Object P_Evenp (x) Object x; {
return ret ? True : False;
}
Object P_Oddp (x) Object x; {
Object P_Oddp (Object x) {
Object tmp;
tmp = P_Evenp (x);
return EQ(tmp,True) ? False : True;
}
#define General_Generic_Compare(name,op,bigop) name (x, y) Object x, y; {\
Object b; register ret;\
#define General_Generic_Compare(name,op,bigop) int name (Object x, Object y) {\
Object b; register int ret;\
GC_Node;\
\
switch (TYPE(x)) {\
@ -501,6 +513,8 @@ Object P_Oddp (x) Object x; {
ret = bigop (b, y);\
GC_Unlink;\
return ret;\
default: /* Just to avoid compiler warnings */\
return 0;\
}\
case T_Flonum:\
switch (TYPE(y)) {\
@ -510,6 +524,8 @@ Object P_Oddp (x) Object x; {
return FLONUM(x)->val op FLONUM(y)->val;\
case T_Bignum:\
return FLONUM(x)->val op Bignum_To_Double (y);\
default: /* Just to avoid compiler warnings */\
return 0;\
}\
case T_Bignum:\
switch (TYPE(y)) {\
@ -523,7 +539,11 @@ Object P_Oddp (x) Object x; {
return Bignum_To_Double (x) op FLONUM(y)->val;\
case T_Bignum:\
return bigop (x, y);\
default: /* Just to avoid compiler warnings */\
return 0;\
}\
default: /* Just to avoid compiler warnings */\
return 0;\
}\
/*NOTREACHED*/ /* ...but lint never sees it */\
}
@ -534,8 +554,8 @@ General_Generic_Compare (Generic_Greater, >, Bignum_Greater)
General_Generic_Compare (Generic_Eq_Less, <=, Bignum_Eq_Less)
General_Generic_Compare (Generic_Eq_Greater, >=, Bignum_Eq_Greater)
Object General_Compare (argc, argv, op) Object *argv; register (*op)(); {
register i;
Object General_Compare (int argc, Object *argv, register int (*op)()) {
register int i;
Check_Number (argv[0]);
for (i = 1; i < argc; i++) {
@ -546,29 +566,29 @@ Object General_Compare (argc, argv, op) Object *argv; register (*op)(); {
return True;
}
Object P_Generic_Equal (argc, argv) Object *argv; {
Object P_Generic_Equal (int argc, Object *argv) {
return General_Compare (argc, argv, Generic_Equal);
}
Object P_Generic_Less (argc, argv) Object *argv; {
Object P_Generic_Less (int argc, Object *argv) {
return General_Compare (argc, argv, Generic_Less);
}
Object P_Generic_Greater (argc, argv) Object *argv; {
Object P_Generic_Greater (int argc, Object *argv) {
return General_Compare (argc, argv, Generic_Greater);
}
Object P_Generic_Eq_Less (argc, argv) Object *argv; {
Object P_Generic_Eq_Less (int argc, Object *argv) {
return General_Compare (argc, argv, Generic_Eq_Less);
}
Object P_Generic_Eq_Greater (argc, argv) Object *argv; {
Object P_Generic_Eq_Greater (int argc, Object *argv) {
return General_Compare (argc, argv, Generic_Eq_Greater);
}
#define General_Generic_Operator(name,op,fixop,bigop) Object name (x, y)\
Object x, y; {\
Object b1, b2, ret; register i;\
#define General_Generic_Operator(name,op,fixop,bigop) Object name (Object x,\
Object y) {\
Object b1, b2, ret; register int i;\
int fits;\
GC_Node2;\
\
@ -594,6 +614,8 @@ Object P_Generic_Eq_Greater (argc, argv) Object *argv; {
ret = bigop (b1, y);\
GC_Unlink;\
return ret;\
default: /* Just to avoid compiler warnings */\
return False;\
}\
case T_Flonum:\
switch (TYPE(y)) {\
@ -603,6 +625,8 @@ Object P_Generic_Eq_Greater (argc, argv) Object *argv; {
return Make_Flonum (FLONUM(x)->val op FLONUM(y)->val);\
case T_Bignum:\
return Make_Flonum (FLONUM(x)->val op Bignum_To_Double (y));\
default: /* Just to avoid compiler warnings */\
return False;\
}\
case T_Bignum:\
switch (TYPE(y)) {\
@ -616,7 +640,11 @@ Object P_Generic_Eq_Greater (argc, argv) Object *argv; {
return Make_Flonum (Bignum_To_Double (x) op FLONUM(y)->val);\
case T_Bignum:\
return bigop (x, y);\
default: /* Just to avoid compiler warnings */\
return False;\
}\
default: /* Just to avoid compiler warnings */\
return False;\
}\
/*NOTREACHED*/ /* ...but lint never sees it */\
}
@ -624,19 +652,19 @@ Object P_Generic_Eq_Greater (argc, argv) Object *argv; {
General_Generic_Operator (Generic_Plus, +, Fixnum_Add, Bignum_Plus)
General_Generic_Operator (Generic_Minus, -, Fixnum_Sub, Bignum_Minus)
Object P_Inc (x) Object x; {
Object P_Inc (Object x) {
Check_Number (x);
return Generic_Plus (x, One);
}
Object P_Dec (x) Object x; {
Object P_Dec (Object x) {
Check_Number (x);
return Generic_Minus (x, One);
}
Object General_Operator (argc, argv, start, op) Object *argv, start;
register Object (*op)(); {
register i;
Object General_Operator (int argc, Object *argv, Object start,
register Object (*op)()) {
register int i;
Object accum;
if (argc > 0)
@ -656,23 +684,23 @@ Object General_Operator (argc, argv, start, op) Object *argv, start;
return accum;
}
Object P_Generic_Plus (argc, argv) Object *argv; {
Object P_Generic_Plus (int argc, Object *argv) {
return General_Operator (argc, argv, Zero, Generic_Plus);
}
Object P_Generic_Minus (argc, argv) Object *argv; {
Object P_Generic_Minus (int argc, Object *argv) {
return General_Operator (argc, argv, Zero, Generic_Minus);
}
Object P_Generic_Multiply (argc, argv) Object *argv; {
Object P_Generic_Multiply (int argc, Object *argv) {
return General_Operator (argc, argv, One, Generic_Multiply);
}
Object P_Generic_Divide (argc, argv) Object *argv; {
Object P_Generic_Divide (int argc, Object *argv) {
return General_Operator (argc, argv, One, Generic_Divide);
}
Object Generic_Multiply (x, y) Object x, y; {
Object Generic_Multiply (Object x, Object y) {
Object b, ret;
switch (TYPE(x)) {
@ -689,6 +717,8 @@ Object Generic_Multiply (x, y) Object x, y; {
return Make_Flonum (FIXNUM(x) * FLONUM(y)->val);
case T_Bignum:
return Bignum_Fixnum_Multiply (y, x);
default: /* Just to avoid compiler warnings */
return Null;
}
case T_Flonum:
switch (TYPE(y)) {
@ -698,6 +728,8 @@ Object Generic_Multiply (x, y) Object x, y; {
return Make_Flonum (FLONUM(x)->val * FLONUM(y)->val);
case T_Bignum:
return Make_Flonum (FLONUM(x)->val * Bignum_To_Double (y));
default: /* Just to avoid compiler warnings */
return Null;
}
case T_Bignum:
switch (TYPE(y)) {
@ -707,13 +739,17 @@ Object Generic_Multiply (x, y) Object x, y; {
return Make_Flonum (Bignum_To_Double (x) * FLONUM(y)->val);
case T_Bignum:
return Bignum_Multiply (x, y);
default: /* Just to avoid compiler warnings */
return Null;
}
default: /* Just to avoid compiler warnings */
return Null;
}
/*NOTREACHED*/
}
Object Generic_Divide (x, y) Object x, y; {
register t = TYPE(y);
Object Generic_Divide (Object x, Object y) {
register int t = TYPE(y);
Object b, ret;
GC_Node2;
@ -736,6 +772,8 @@ Object Generic_Divide (x, y) Object x, y; {
return Car (ret);
return Make_Reduced_Flonum ((double)FIXNUM(x)
/ Bignum_To_Double (y));
default: /* Just to avoid compiler warnings */
return Null;
}
case T_Flonum:
switch (t) {
@ -745,6 +783,8 @@ Object Generic_Divide (x, y) Object x, y; {
return Make_Flonum (FLONUM(x)->val / FLONUM(y)->val);
case T_Bignum:
return Make_Flonum (FLONUM(x)->val / Bignum_To_Double (y));
default: /* Just to avoid compiler warnings */
return Null;
}
case T_Bignum:
switch (t) {
@ -766,13 +806,17 @@ Object Generic_Divide (x, y) Object x, y; {
return Car (ret);
return Make_Reduced_Flonum (Bignum_To_Double (x)
/ Bignum_To_Double (y));
default: /* Just to avoid compiler warnings */
return Null;
}
default: /* Just to avoid compiler warnings */
return Null;
}
/*NOTREACHED*/
}
Object P_Abs (x) Object x; {
register i;
Object P_Abs (Object x) {
register int i;
Check_Number (x);
switch (TYPE(x)) {
@ -783,12 +827,14 @@ Object P_Abs (x) Object x; {
return Make_Flonum (fabs (FLONUM(x)->val));
case T_Bignum:
return Bignum_Abs (x);
default: /* Just to avoid compiler warnings */
return Null;
}
/*NOTREACHED*/
}
Object General_Integer_Divide (x, y, rem) Object x, y; {
register fx = FIXNUM(x), fy = FIXNUM(y);
Object General_Integer_Divide (Object x, Object y, int rem) {
register int fx = FIXNUM(x), fy = FIXNUM(y);
Object b, ret;
GC_Node;
@ -806,6 +852,8 @@ Object General_Integer_Divide (x, y, rem) Object x, y; {
ret = Bignum_Divide (b, y);
done:
return rem ? Cdr (ret) : Car (ret);
default: /* Just to avoid compiler warnings */
return Null;
}
case T_Bignum:
switch (TYPE(y)) {
@ -815,20 +863,24 @@ done:
case T_Bignum:
ret = Bignum_Divide (x, y);
goto done;
default: /* Just to avoid compiler warnings */
return Null;
}
default: /* Just to avoid compiler warnings */
return Null;
}
/*NOTREACHED*/
}
Object Exact_Quotient (x, y) Object x, y; {
Object Exact_Quotient (Object x, Object y) {
return General_Integer_Divide (x, y, 0);
}
Object Exact_Remainder (x, y) Object x, y; {
Object Exact_Remainder (Object x, Object y) {
return General_Integer_Divide (x, y, 1);
}
Object Exact_Modulo (x, y) Object x, y; {
Object Exact_Modulo (Object x, Object y) {
Object rem, xneg, yneg;
GC_Node2;
@ -842,7 +894,7 @@ Object Exact_Modulo (x, y) Object x, y; {
return rem;
}
Object With_Exact_Ints (x, y, fun) Object x, y, (*fun)(); {
Object With_Exact_Ints (Object x, Object y, Object (*fun)()) {
Object i, ret;
int inex = 0;
GC_Node3;
@ -868,19 +920,19 @@ Object With_Exact_Ints (x, y, fun) Object x, y, (*fun)(); {
return ret;
}
Object P_Quotient (x, y) Object x, y; {
Object P_Quotient (Object x, Object y) {
return With_Exact_Ints (x, y, Exact_Quotient);
}
Object P_Remainder (x, y) Object x, y; {
Object P_Remainder (Object x, Object y) {
return With_Exact_Ints (x, y, Exact_Remainder);
}
Object P_Modulo (x, y) Object x, y; {
Object P_Modulo (Object x, Object y) {
return With_Exact_Ints (x, y, Exact_Modulo);
}
Object Exact_Gcd (x, y) Object x, y; {
Object Exact_Gcd (Object x, Object y) {
Object r, z;
GC_Node2;
@ -904,15 +956,15 @@ Object Exact_Gcd (x, y) Object x, y; {
return r;
}
Object General_Gcd (x, y) Object x, y; {
Object General_Gcd (Object x, Object y) {
return With_Exact_Ints (x, y, Exact_Gcd);
}
Object P_Gcd (argc, argv) Object *argv; {
Object P_Gcd (int argc, Object *argv) {
return P_Abs (General_Operator (argc, argv, Zero, General_Gcd));
}
Object Exact_Lcm (x, y) Object x, y; {
Object Exact_Lcm (Object x, Object y) {
Object ret, p, z;
GC_Node3;
@ -928,15 +980,15 @@ Object Exact_Lcm (x, y) Object x, y; {
return ret;
}
Object General_Lcm (x, y) Object x, y; {
Object General_Lcm (Object x, Object y) {
return With_Exact_Ints (x, y, Exact_Lcm);
}
Object P_Lcm (argc, argv) Object *argv; {
Object P_Lcm (int argc, Object *argv) {
return P_Abs (General_Operator (argc, argv, One, General_Lcm));
}
#define General_Conversion(name,op) Object name (x) Object x; {\
#define General_Conversion(name,op) Object name (Object x) {\
double d, i;\
\
Check_Number (x);\
@ -953,7 +1005,7 @@ General_Conversion (P_Floor, floor)
General_Conversion (P_Ceiling, ceil)
General_Conversion (P_Truncate, trunc)
Object P_Round (x) Object x; {
Object P_Round (Object x) {
double d, y, f;
Object ret, isodd;
@ -972,7 +1024,7 @@ Object P_Round (x) Object x; {
return ret;
}
double Get_Double (x) Object x; {
double Get_Double (Object x) {
Check_Number (x);
switch (TYPE(x)) {
case T_Fixnum:
@ -981,11 +1033,13 @@ double Get_Double (x) Object x; {
return FLONUM(x)->val;
case T_Bignum:
return Bignum_To_Double (x);
default: /* Just to avoid compiler warnings */
return 0.0;
}
/*NOTREACHED*/
}
Object General_Function (x, y, fun) Object x, y; double (*fun)(); {
Object General_Function (Object x, Object y, double (*fun)()) {
double d, ret;
d = Get_Double (x);
@ -999,64 +1053,64 @@ Object General_Function (x, y, fun) Object x, y; double (*fun)(); {
return Make_Flonum (ret);
}
Object P_Sqrt (x) Object x; { return General_Function (x, Null, sqrt); }
Object P_Sqrt (Object x) { return General_Function (x, Null, sqrt); }
Object P_Exp (x) Object x; { return General_Function (x, Null, exp); }
Object P_Exp (Object x) { return General_Function (x, Null, exp); }
Object P_Log (x) Object x; { return General_Function (x, Null, log); }
Object P_Log (Object x) { return General_Function (x, Null, log); }
Object P_Sin (x) Object x; { return General_Function (x, Null, sin); }
Object P_Sin (Object x) { return General_Function (x, Null, sin); }
Object P_Cos (x) Object x; { return General_Function (x, Null, cos); }
Object P_Cos (Object x) { return General_Function (x, Null, cos); }
Object P_Tan (x) Object x; { return General_Function (x, Null, tan); }
Object P_Tan (Object x) { return General_Function (x, Null, tan); }
Object P_Asin (x) Object x; { return General_Function (x, Null, asin); }
Object P_Asin (Object x) { return General_Function (x, Null, asin); }
Object P_Acos (x) Object x; { return General_Function (x, Null, acos); }
Object P_Acos (Object x) { return General_Function (x, Null, acos); }
Object P_Atan (argc, argv) Object *argv; {
register a2 = argc == 2;
return General_Function (argv[0], a2 ? argv[1] : Null, a2 ?
Object P_Atan (int argc, Object *argv) {
register int a2 = argc == 2;
return General_Function (argv[0], a2 ? argv[1] : Null, a2 ?
(double(*)())atan2 : (double(*)())atan);
}
Object Min (x, y) Object x, y; {
Object Min (Object x, Object y) {
Object ret;
ret = Generic_Less (x, y) ? x : y;
if (TYPE(x) == T_Flonum || TYPE(y) == T_Flonum)
ret = P_Exact_To_Inexact (ret);
return ret;
}
Object Max (x, y) Object x, y; {
Object Max (Object x, Object y) {
Object ret;
ret = Generic_Less (x, y) ? y : x;
if (TYPE(x) == T_Flonum || TYPE(y) == T_Flonum)
ret = P_Exact_To_Inexact (ret);
return ret;
}
Object P_Min (argc, argv) Object *argv; {
Object P_Min (int argc, Object *argv) {
return General_Operator (argc, argv, argv[0], Min);
}
Object P_Max (argc, argv) Object *argv; {
Object P_Max (int argc, Object *argv) {
return General_Operator (argc, argv, argv[0], Max);
}
Object P_Random () {
#ifdef RANDOM
extern long random();
extern long int random();
return Make_Long (random ());
#else
return Make_Integer (rand ());
#endif
}
Object P_Srandom (x) Object x; {
Object P_Srandom (Object x) {
#ifdef RANDOM
srandom (Get_Unsigned (x));
#else

2
src/onfork.c
View File

@ -14,7 +14,7 @@
static FUNCT *Onfork_Funcs;
Register_Onfork (f) void (*f)(); {
void Register_Onfork (void (*f)()) {
FUNCT *p;
p = (FUNCT *)Safe_Malloc (sizeof (*p));

568
src/prim.c
View File

@ -3,6 +3,8 @@
#include "kernel.h"
extern void Memoize_Frame (Object);
struct Prim_Init {
Object (*fun)();
char *name;
@ -12,370 +14,370 @@ struct Prim_Init {
/* autoload.c:
*/
P_Autoload, "autoload", 2, 2, EVAL,
{ P_Autoload, "autoload", 2, 2, EVAL },
/* bool.c:
*/
P_Booleanp, "boolean?", 1, 1, EVAL,
P_Not, "not", 1, 1, EVAL,
P_Eq, "eq?", 2, 2, EVAL,
P_Eqv, "eqv?", 2, 2, EVAL,
P_Equal, "equal?", 2, 2, EVAL,
P_Empty_List_Is_False, "empty-list-is-false-for-backward-compatibility",
1, 1, EVAL,
{ P_Booleanp, "boolean?", 1, 1, EVAL },
{ P_Not, "not", 1, 1, EVAL },
{ P_Eq, "eq?", 2, 2, EVAL },
{ P_Eqv, "eqv?", 2, 2, EVAL },
{ P_Equal, "equal?", 2, 2, EVAL },
{ P_Empty_List_Is_False, "empty-list-is-false-for-backward-compatibility",
1, 1, EVAL },
/* char.c:
*/
P_Charp, "char?", 1, 1, EVAL,
P_Char_To_Integer, "char->integer", 1, 1, EVAL,
P_Integer_To_Char, "integer->char", 1, 1, EVAL,
P_Char_Upper_Casep, "char-upper-case?", 1, 1, EVAL,
P_Char_Lower_Casep, "char-lower-case?", 1, 1, EVAL,
P_Char_Alphabeticp, "char-alphabetic?", 1, 1, EVAL,
P_Char_Numericp, "char-numeric?", 1, 1, EVAL,
P_Char_Whitespacep, "char-whitespace?", 1, 1, EVAL,
P_Char_Upcase, "char-upcase", 1, 1, EVAL,
P_Char_Downcase, "char-downcase", 1, 1, EVAL,
P_Char_Eq, "char=?", 2, 2, EVAL,
P_Char_Less, "char<?", 2, 2, EVAL,
P_Char_Greater, "char>?", 2, 2, EVAL,
P_Char_Eq_Less, "char<=?", 2, 2, EVAL,
P_Char_Eq_Greater, "char>=?", 2, 2, EVAL,
P_Char_CI_Eq, "char-ci=?", 2, 2, EVAL,
P_Char_CI_Less, "char-ci<?", 2, 2, EVAL,
P_Char_CI_Greater, "char-ci>?", 2, 2, EVAL,
P_Char_CI_Eq_Less, "char-ci<=?", 2, 2, EVAL,
P_Char_CI_Eq_Greater,"char-ci>=?", 2, 2, EVAL,
{ P_Charp, "char?", 1, 1, EVAL },
{ P_Char_To_Integer, "char->integer", 1, 1, EVAL },
{ P_Integer_To_Char, "integer->char", 1, 1, EVAL },
{ P_Char_Upper_Casep, "char-upper-case?", 1, 1, EVAL },
{ P_Char_Lower_Casep, "char-lower-case?", 1, 1, EVAL },
{ P_Char_Alphabeticp, "char-alphabetic?", 1, 1, EVAL },
{ P_Char_Numericp, "char-numeric?", 1, 1, EVAL },
{ P_Char_Whitespacep, "char-whitespace?", 1, 1, EVAL },
{ P_Char_Upcase, "char-upcase", 1, 1, EVAL },
{ P_Char_Downcase, "char-downcase", 1, 1, EVAL },
{ P_Char_Eq, "char=?", 2, 2, EVAL },
{ P_Char_Less, "char<?", 2, 2, EVAL },
{ P_Char_Greater, "char>?", 2, 2, EVAL },
{ P_Char_Eq_Less, "char<=?", 2, 2, EVAL },
{ P_Char_Eq_Greater, "char>=?", 2, 2, EVAL },
{ P_Char_CI_Eq, "char-ci=?", 2, 2, EVAL },
{ P_Char_CI_Less, "char-ci<?", 2, 2, EVAL },
{ P_Char_CI_Greater, "char-ci>?", 2, 2, EVAL },
{ P_Char_CI_Eq_Less, "char-ci<=?", 2, 2, EVAL },
{ P_Char_CI_Eq_Greater,"char-ci>=?", 2, 2, EVAL },
/* cont.c:
*/
P_Control_Pointp, "control-point?", 1, 1, EVAL,
P_Call_With_Current_Continuation,
"call-with-current-continuation", 1, 1, EVAL,
P_Dynamic_Wind, "dynamic-wind", 3, 3, EVAL,
P_Control_Point_Environment,
"control-point-environment", 1, 1, EVAL,
{ P_Control_Pointp, "control-point?", 1, 1, EVAL },
{ P_Call_With_Current_Continuation,
"call-with-current-continuation", 1, 1, EVAL },
{ P_Dynamic_Wind, "dynamic-wind", 3, 3, EVAL },
{ P_Control_Point_Environment,
"control-point-environment", 1, 1, EVAL },
/* debug.c:
*/
P_Backtrace_List, "backtrace-list", 0, 1, VARARGS,
{ P_Backtrace_List, "backtrace-list", 0, 1, VARARGS },
/* dump.c:
*/
#ifdef CAN_DUMP
P_Dump, "dump", 1, 1, EVAL,
{ P_Dump, "dump", 1, 1, EVAL },
#endif
/* env.c:
*/
P_Environmentp, "environment?", 1, 1, EVAL,
P_The_Environment, "the-environment", 0, 0, EVAL,
P_Global_Environment,"global-environment", 0, 0, EVAL,
P_Define, "define", 1, MANY, NOEVAL,
P_Define_Macro, "define-macro", 1, MANY, NOEVAL,
P_Set, "set!", 2, 2, NOEVAL,
P_Environment_To_List,
"environment->list", 1, 1, EVAL,
P_Boundp, "bound?", 1, 1, EVAL,
{ P_Environmentp, "environment?", 1, 1, EVAL },
{ P_The_Environment, "the-environment", 0, 0, EVAL },
{ P_Global_Environment,"global-environment", 0, 0, EVAL },
{ P_Define, "define", 1, MANY, NOEVAL },
{ P_Define_Macro, "define-macro", 1, MANY, NOEVAL },
{ P_Set, "set!", 2, 2, NOEVAL },
{ P_Environment_To_List,
"environment->list", 1, 1, EVAL },
{ P_Boundp, "bound?", 1, 1, EVAL },
/* error.c:
*/
P_Error, "error", 2, MANY, VARARGS,
P_Reset, "reset", 0, 0, EVAL,
{ P_Error, "error", 2, MANY, VARARGS },
{ P_Reset, "reset", 0, 0, EVAL },
/* exception.c:
*/
P_Disable_Interrupts,"disable-interrupts", 0, 0, EVAL,
P_Enable_Interrupts, "enable-interrupts", 0, 0, EVAL,
{ P_Disable_Interrupts,"disable-interrupts", 0, 0, EVAL },
{ P_Enable_Interrupts, "enable-interrupts", 0, 0, EVAL },
/* feature.c:
*/
P_Features, "features", 0, 0, EVAL,
P_Featurep, "feature?", 1, 1, EVAL,
P_Provide, "provide", 1, 1, EVAL,
P_Require, "require", 1, 3, VARARGS,
{ P_Features, "features", 0, 0, EVAL },
{ P_Featurep, "feature?", 1, 1, EVAL },
{ P_Provide, "provide", 1, 1, EVAL },
{ P_Require, "require", 1, 3, VARARGS },
/* heap.c:
*/
P_Collect, "collect", 0, 0, EVAL,
P_Garbage_Collect_Status, "garbage-collect-status", 0, 2, VARARGS,
{ P_Collect, "collect", 0, 0, EVAL },
{ P_Garbage_Collect_Status, "garbage-collect-status", 0, 2, VARARGS },
#ifdef GENERATIONAL_GC
P_Collect_Incremental, "collect-incremental", 0, 0, EVAL,
{ P_Collect_Incremental, "collect-incremental", 0, 0, EVAL },
#endif
/* io.c:
*/
P_Port_File_Name, "port-file-name", 1, 1, EVAL,
P_Port_Line_Number, "port-line-number", 1, 1, EVAL,
P_Eof_Objectp, "eof-object?", 1, 1, EVAL,
P_Current_Input_Port,
"current-input-port", 0, 0, EVAL,
P_Current_Output_Port,
"current-output-port", 0, 0, EVAL,
P_Input_Portp, "input-port?", 1, 1, EVAL,
P_Output_Portp, "output-port?", 1, 1, EVAL,
P_Open_Input_File, "open-input-file", 1, 1, EVAL,
P_Open_Output_File, "open-output-file", 1, 1, EVAL,
P_Open_Input_Output_File, "open-input-output-file", 1, 1, EVAL,
P_Close_Input_Port, "close-input-port", 1, 1, EVAL,
P_Close_Output_Port, "close-output-port", 1, 1, EVAL,
P_With_Input_From_File, "with-input-from-file", 2, 2, EVAL,
P_With_Output_To_File, "with-output-to-file", 2, 2, EVAL,
P_Call_With_Input_File, "call-with-input-file", 2, 2, EVAL,
P_Call_With_Output_File, "call-with-output-file", 2, 2, EVAL,
P_Open_Input_String, "open-input-string", 1, 1, EVAL,
P_Open_Output_String,"open-output-string", 0, 0, EVAL,
P_Tilde_Expand, "tilde-expand", 1, 1, EVAL,
P_File_Existsp, "file-exists?", 1, 1, EVAL,
{ P_Port_File_Name, "port-file-name", 1, 1, EVAL },
{ P_Port_Line_Number, "port-line-number", 1, 1, EVAL },
{ P_Eof_Objectp, "eof-object?", 1, 1, EVAL },
{ P_Current_Input_Port,
"current-input-port", 0, 0, EVAL },
{ P_Current_Output_Port,
"current-output-port", 0, 0, EVAL },
{ P_Input_Portp, "input-port?", 1, 1, EVAL },
{ P_Output_Portp, "output-port?", 1, 1, EVAL },
{ P_Open_Input_File, "open-input-file", 1, 1, EVAL },
{ P_Open_Output_File, "open-output-file", 1, 1, EVAL },
{ P_Open_Input_Output_File, "open-input-output-file", 1, 1, EVAL },
{ P_Close_Input_Port, "close-input-port", 1, 1, EVAL },
{ P_Close_Output_Port, "close-output-port", 1, 1, EVAL },
{ P_With_Input_From_File, "with-input-from-file", 2, 2, EVAL },
{ P_With_Output_To_File, "with-output-to-file", 2, 2, EVAL },
{ P_Call_With_Input_File, "call-with-input-file", 2, 2, EVAL },
{ P_Call_With_Output_File, "call-with-output-file", 2, 2, EVAL },
{ P_Open_Input_String, "open-input-string", 1, 1, EVAL },
{ P_Open_Output_String,"open-output-string", 0, 0, EVAL },
{ P_Tilde_Expand, "tilde-expand", 1, 1, EVAL },
{ P_File_Existsp, "file-exists?", 1, 1, EVAL },
/* load.c:
*/
P_Load, "load", 1, 2, VARARGS,
{ P_Load, "load", 1, 2, VARARGS },
/* list.c:
*/
P_Cons, "cons", 2, 2, EVAL,
P_Car, "car", 1, 1, EVAL,
P_Cdr, "cdr", 1, 1, EVAL,
P_Caar, "caar", 1, 1, EVAL,
P_Cadr, "cadr", 1, 1, EVAL,
P_Cdar, "cdar", 1, 1, EVAL,
P_Cddr, "cddr", 1, 1, EVAL,
{ P_Cons, "cons", 2, 2, EVAL },
{ P_Car, "car", 1, 1, EVAL },
{ P_Cdr, "cdr", 1, 1, EVAL },
{ P_Caar, "caar", 1, 1, EVAL },
{ P_Cadr, "cadr", 1, 1, EVAL },
{ P_Cdar, "cdar", 1, 1, EVAL },
{ P_Cddr, "cddr", 1, 1, EVAL },
P_Caaar, "caaar", 1, 1, EVAL,
P_Caadr, "caadr", 1, 1, EVAL,
P_Cadar, "cadar", 1, 1, EVAL,
P_Caddr, "caddr", 1, 1, EVAL,
P_Cdaar, "cdaar", 1, 1, EVAL,
P_Cdadr, "cdadr", 1, 1, EVAL,
P_Cddar, "cddar", 1, 1, EVAL,
P_Cdddr, "cdddr", 1, 1, EVAL,
{ P_Caaar, "caaar", 1, 1, EVAL },
{ P_Caadr, "caadr", 1, 1, EVAL },
{ P_Cadar, "cadar", 1, 1, EVAL },
{ P_Caddr, "caddr", 1, 1, EVAL },
{ P_Cdaar, "cdaar", 1, 1, EVAL },
{ P_Cdadr, "cdadr", 1, 1, EVAL },
{ P_Cddar, "cddar", 1, 1, EVAL },
{ P_Cdddr, "cdddr", 1, 1, EVAL },
P_Caaaar, "caaaar", 1, 1, EVAL,
P_Caaadr, "caaadr", 1, 1, EVAL,
P_Caadar, "caadar", 1, 1, EVAL,
P_Caaddr, "caaddr", 1, 1, EVAL,
P_Cadaar, "cadaar", 1, 1, EVAL,
P_Cadadr, "cadadr", 1, 1, EVAL,
P_Caddar, "caddar", 1, 1, EVAL,
P_Cadddr, "cadddr", 1, 1, EVAL,
P_Cdaaar, "cdaaar", 1, 1, EVAL,
P_Cdaadr, "cdaadr", 1, 1, EVAL,
P_Cdadar, "cdadar", 1, 1, EVAL,
P_Cdaddr, "cdaddr", 1, 1, EVAL,
P_Cddaar, "cddaar", 1, 1, EVAL,
P_Cddadr, "cddadr", 1, 1, EVAL,
P_Cdddar, "cdddar", 1, 1, EVAL,
P_Cddddr, "cddddr", 1, 1, EVAL,
{ P_Caaaar, "caaaar", 1, 1, EVAL },
{ P_Caaadr, "caaadr", 1, 1, EVAL },
{ P_Caadar, "caadar", 1, 1, EVAL },
{ P_Caaddr, "caaddr", 1, 1, EVAL },
{ P_Cadaar, "cadaar", 1, 1, EVAL },
{ P_Cadadr, "cadadr", 1, 1, EVAL },
{ P_Caddar, "caddar", 1, 1, EVAL },
{ P_Cadddr, "cadddr", 1, 1, EVAL },
{ P_Cdaaar, "cdaaar", 1, 1, EVAL },
{ P_Cdaadr, "cdaadr", 1, 1, EVAL },
{ P_Cdadar, "cdadar", 1, 1, EVAL },
{ P_Cdaddr, "cdaddr", 1, 1, EVAL },
{ P_Cddaar, "cddaar", 1, 1, EVAL },
{ P_Cddadr, "cddadr", 1, 1, EVAL },
{ P_Cdddar, "cdddar", 1, 1, EVAL },
{ P_Cddddr, "cddddr", 1, 1, EVAL },
P_Cxr, "cxr", 2, 2, EVAL,
P_Nullp, "null?", 1, 1, EVAL,
P_Pairp, "pair?", 1, 1, EVAL,
P_Listp, "list?", 1, 1, EVAL,
P_Set_Car, "set-car!", 2, 2, EVAL,
P_Set_Cdr, "set-cdr!", 2, 2, EVAL,
P_Assq, "assq", 2, 2, EVAL,
P_Assv, "assv", 2, 2, EVAL,
P_Assoc, "assoc", 2, 2, EVAL,
P_Memq, "memq", 2, 2, EVAL,
P_Memv, "memv", 2, 2, EVAL,
P_Member, "member", 2, 2, EVAL,
P_Make_List, "make-list", 2, 2, EVAL,
P_List, "list", 0, MANY, VARARGS,
P_Length, "length", 1, 1, EVAL,
P_Append, "append", 0, MANY, VARARGS,
P_Append_Set, "append!", 0, MANY, VARARGS,
P_Last_Pair, "last-pair", 1, 1, EVAL,
P_Reverse, "reverse", 1, 1, EVAL,
P_Reverse_Set, "reverse!", 1, 1, EVAL,
P_List_Tail, "list-tail", 2, 2, EVAL,
P_List_Ref, "list-ref", 2, 2, EVAL,
{ P_Cxr, "cxr", 2, 2, EVAL },
{ P_Nullp, "null?", 1, 1, EVAL },
{ P_Pairp, "pair?", 1, 1, EVAL },
{ P_Listp, "list?", 1, 1, EVAL },
{ P_Set_Car, "set-car!", 2, 2, EVAL },
{ P_Set_Cdr, "set-cdr!", 2, 2, EVAL },
{ P_Assq, "assq", 2, 2, EVAL },
{ P_Assv, "assv", 2, 2, EVAL },
{ P_Assoc, "assoc", 2, 2, EVAL },
{ P_Memq, "memq", 2, 2, EVAL },
{ P_Memv, "memv", 2, 2, EVAL },
{ P_Member, "member", 2, 2, EVAL },
{ P_Make_List, "make-list", 2, 2, EVAL },
{ P_List, "list", 0, MANY, VARARGS },
{ P_Length, "length", 1, 1, EVAL },
{ P_Append, "append", 0, MANY, VARARGS },
{ P_Append_Set, "append!", 0, MANY, VARARGS },
{ P_Last_Pair, "last-pair", 1, 1, EVAL },
{ P_Reverse, "reverse", 1, 1, EVAL },
{ P_Reverse_Set, "reverse!", 1, 1, EVAL },
{ P_List_Tail, "list-tail", 2, 2, EVAL },
{ P_List_Ref, "list-ref", 2, 2, EVAL },
/* main.c:
*/
P_Command_Line_Args, "command-line-args", 0, 0, EVAL,
P_Exit, "exit", 0, 1, VARARGS,
{ P_Command_Line_Args, "command-line-args", 0, 0, EVAL },
{ P_Exit, "exit", 0, 1, VARARGS },
/* math.c:
*/
P_Number_To_String, "number->string", 1, 2, VARARGS,
P_Numberp, "number?", 1, 1, EVAL,
P_Complexp, "complex?", 1, 1, EVAL,
P_Realp, "real?", 1, 1, EVAL,
P_Rationalp, "rational?", 1, 1, EVAL,
P_Integerp, "integer?", 1, 1, EVAL,
P_Zerop, "zero?", 1, 1, EVAL,
P_Positivep, "positive?", 1, 1, EVAL,
P_Negativep, "negative?", 1, 1, EVAL,
P_Oddp, "odd?", 1, 1, EVAL,
P_Evenp, "even?", 1, 1, EVAL,
P_Exactp, "exact?", 1, 1, EVAL,
P_Inexactp, "inexact?", 1, 1, EVAL,
P_Exact_To_Inexact, "exact->inexact", 1, 1, EVAL,
P_Inexact_To_Exact, "inexact->exact", 1, 1, EVAL,
P_Generic_Less, "<", 1, MANY, VARARGS,
P_Generic_Greater, ">", 1, MANY, VARARGS,
P_Generic_Equal, "=", 1, MANY, VARARGS,
P_Generic_Eq_Less, "<=", 1, MANY, VARARGS,
P_Generic_Eq_Greater,">=", 1, MANY, VARARGS,
P_Inc, "1+", 1, 1, EVAL,
P_Dec, "-1+", 1, 1, EVAL,
P_Dec, "1-", 1, 1, EVAL,
P_Generic_Plus, "+", 0, MANY, VARARGS,
P_Generic_Minus, "-", 1, MANY, VARARGS,
P_Generic_Multiply, "*", 0, MANY, VARARGS,
P_Generic_Divide, "/", 1, MANY, VARARGS,
P_Abs, "abs", 1, 1, EVAL,
P_Quotient, "quotient", 2, 2, EVAL,
P_Remainder, "remainder", 2, 2, EVAL,
P_Modulo, "modulo", 2, 2, EVAL,
P_Gcd, "gcd", 0, MANY, VARARGS,
P_Lcm, "lcm", 0, MANY, VARARGS,
P_Floor, "floor", 1, 1, EVAL,
P_Ceiling, "ceiling", 1, 1, EVAL,
P_Truncate, "truncate", 1, 1, EVAL,
P_Round, "round", 1, 1, EVAL,
P_Sqrt, "sqrt", 1, 1, EVAL,
P_Exp, "exp", 1, 1, EVAL,
P_Log, "log", 1, 1, EVAL,
P_Sin, "sin", 1, 1, EVAL,
P_Cos, "cos", 1, 1, EVAL,
P_Tan, "tan", 1, 1, EVAL,
P_Asin, "asin", 1, 1, EVAL,
P_Acos, "acos", 1, 1, EVAL,
P_Atan, "atan", 1, 2, VARARGS,
P_Min, "min", 1, MANY, VARARGS,
P_Max, "max", 1, MANY, VARARGS,
P_Random, "random", 0, 0, EVAL,
P_Srandom, "srandom", 1, 1, EVAL,
{ P_Number_To_String, "number->string", 1, 2, VARARGS },
{ P_Numberp, "number?", 1, 1, EVAL },
{ P_Complexp, "complex?", 1, 1, EVAL },
{ P_Realp, "real?", 1, 1, EVAL },
{ P_Rationalp, "rational?", 1, 1, EVAL },
{ P_Integerp, "integer?", 1, 1, EVAL },
{ P_Zerop, "zero?", 1, 1, EVAL },
{ P_Positivep, "positive?", 1, 1, EVAL },
{ P_Negativep, "negative?", 1, 1, EVAL },
{ P_Oddp, "odd?", 1, 1, EVAL },
{ P_Evenp, "even?", 1, 1, EVAL },
{ P_Exactp, "exact?", 1, 1, EVAL },
{ P_Inexactp, "inexact?", 1, 1, EVAL },
{ P_Exact_To_Inexact, "exact->inexact", 1, 1, EVAL },
{ P_Inexact_To_Exact, "inexact->exact", 1, 1, EVAL },
{ P_Generic_Less, "<", 1, MANY, VARARGS },
{ P_Generic_Greater, ">", 1, MANY, VARARGS },
{ P_Generic_Equal, "=", 1, MANY, VARARGS },
{ P_Generic_Eq_Less, "<=", 1, MANY, VARARGS },
{ P_Generic_Eq_Greater,">=", 1, MANY, VARARGS },
{ P_Inc, "1+", 1, 1, EVAL },
{ P_Dec, "-1+", 1, 1, EVAL },
{ P_Dec, "1-", 1, 1, EVAL },
{ P_Generic_Plus, "+", 0, MANY, VARARGS },
{ P_Generic_Minus, "-", 1, MANY, VARARGS },
{ P_Generic_Multiply, "*", 0, MANY, VARARGS },
{ P_Generic_Divide, "/", 1, MANY, VARARGS },
{ P_Abs, "abs", 1, 1, EVAL },
{ P_Quotient, "quotient", 2, 2, EVAL },
{ P_Remainder, "remainder", 2, 2, EVAL },
{ P_Modulo, "modulo", 2, 2, EVAL },
{ P_Gcd, "gcd", 0, MANY, VARARGS },
{ P_Lcm, "lcm", 0, MANY, VARARGS },
{ P_Floor, "floor", 1, 1, EVAL },
{ P_Ceiling, "ceiling", 1, 1, EVAL },
{ P_Truncate, "truncate", 1, 1, EVAL },
{ P_Round, "round", 1, 1, EVAL },
{ P_Sqrt, "sqrt", 1, 1, EVAL },
{ P_Exp, "exp", 1, 1, EVAL },
{ P_Log, "log", 1, 1, EVAL },
{ P_Sin, "sin", 1, 1, EVAL },
{ P_Cos, "cos", 1, 1, EVAL },
{ P_Tan, "tan", 1, 1, EVAL },
{ P_Asin, "asin", 1, 1, EVAL },
{ P_Acos, "acos", 1, 1, EVAL },
{ P_Atan, "atan", 1, 2, VARARGS },
{ P_Min, "min", 1, MANY, VARARGS },
{ P_Max, "max", 1, MANY, VARARGS },
{ P_Random, "random", 0, 0, EVAL },
{ P_Srandom, "srandom", 1, 1, EVAL },
/* prim.c:
*/
/* print.c:
*/
P_Write, "write", 1, 2, VARARGS,
P_Display, "display", 1, 2, VARARGS,
P_Write_Char, "write-char", 1, 2, VARARGS,
P_Newline, "newline", 0, 1, VARARGS,
P_Print, "print", 1, 2, VARARGS,
P_Clear_Output_Port, "clear-output-port", 0, 1, VARARGS,
P_Flush_Output_Port, "flush-output-port", 0, 1, VARARGS,
P_Get_Output_String, "get-output-string", 1, 1, EVAL,
P_Format, "format", 2, MANY, VARARGS,
{ P_Write, "write", 1, 2, VARARGS },
{ P_Display, "display", 1, 2, VARARGS },
{ P_Write_Char, "write-char", 1, 2, VARARGS },
{ P_Newline, "newline", 0, 1, VARARGS },
{ P_Print, "print", 1, 2, VARARGS },
{ P_Clear_Output_Port, "clear-output-port", 0, 1, VARARGS },
{ P_Flush_Output_Port, "flush-output-port", 0, 1, VARARGS },
{ P_Get_Output_String, "get-output-string", 1, 1, EVAL },
{ P_Format, "format", 2, MANY, VARARGS },
/* proc.c:
*/
P_Procedurep, "procedure?", 1, 1, EVAL,
P_Primitivep, "primitive?", 1, 1, EVAL,
P_Compoundp, "compound?", 1, 1, EVAL,
P_Macrop, "macro?", 1, 1, EVAL,
P_Eval, "eval", 1, 2, VARARGS,
P_Apply, "apply", 2, MANY, VARARGS,
P_Lambda, "lambda", 2, MANY, NOEVAL,
P_Procedure_Environment,
"procedure-environment", 1, 1, EVAL,
P_Procedure_Lambda, "procedure-lambda", 1, 1, EVAL,
P_Map, "map", 2, MANY, VARARGS,
P_For_Each, "for-each", 2, MANY, VARARGS,
P_Macro, "macro", 2, MANY, NOEVAL,
P_Macro_Body, "macro-body", 1, 1, EVAL,
P_Macro_Expand, "macro-expand", 1, 1, EVAL,
{ P_Procedurep, "procedure?", 1, 1, EVAL },
{ P_Primitivep, "primitive?", 1, 1, EVAL },
{ P_Compoundp, "compound?", 1, 1, EVAL },
{ P_Macrop, "macro?", 1, 1, EVAL },
{ P_Eval, "eval", 1, 2, VARARGS },
{ P_Apply, "apply", 2, MANY, VARARGS },
{ P_Lambda, "lambda", 2, MANY, NOEVAL },
{ P_Procedure_Environment,
"procedure-environment", 1, 1, EVAL },
{ P_Procedure_Lambda, "procedure-lambda", 1, 1, EVAL },
{ P_Map, "map", 2, MANY, VARARGS },
{ P_For_Each, "for-each", 2, MANY, VARARGS },
{ P_Macro, "macro", 2, MANY, NOEVAL },
{ P_Macro_Body, "macro-body", 1, 1, EVAL },
{ P_Macro_Expand, "macro-expand", 1, 1, EVAL },
/* promise.c:
*/
P_Delay, "delay", 1, 1, NOEVAL,
P_Force, "force", 1, 1, EVAL,
P_Promisep, "promise?", 1, 1, EVAL,
P_Promise_Environment,
"promise-environment", 1, 1, EVAL,
{ P_Delay, "delay", 1, 1, NOEVAL },
{ P_Force, "force", 1, 1, EVAL },
{ P_Promisep, "promise?", 1, 1, EVAL },
{ P_Promise_Environment,
"promise-environment", 1, 1, EVAL },
/* read.c:
*/
P_Clear_Input_Port, "clear-input-port", 0, 1, VARARGS,
P_Read, "read", 0, 1, VARARGS,
P_Read_Char, "read-char", 0, 1, VARARGS,
P_Read_String, "read-string", 0, 1, VARARGS,
P_Unread_Char, "unread-char", 1, 2, VARARGS,
P_Peek_Char, "peek-char", 0, 1, VARARGS,
P_Char_Readyp, "char-ready?", 0, 1, VARARGS,
{ P_Clear_Input_Port, "clear-input-port", 0, 1, VARARGS },
{ P_Read, "read", 0, 1, VARARGS },
{ P_Read_Char, "read-char", 0, 1, VARARGS },
{ P_Read_String, "read-string", 0, 1, VARARGS },
{ P_Unread_Char, "unread-char", 1, 2, VARARGS },
{ P_Peek_Char, "peek-char", 0, 1, VARARGS },
{ P_Char_Readyp, "char-ready?", 0, 1, VARARGS },
/* special.c:
*/
P_Quote, "quote", 1, 1, NOEVAL,
P_Quasiquote, "quasiquote", 1, 1, NOEVAL,
P_Begin, "begin", 1, MANY, NOEVAL,
P_Begin1, "begin1", 1, MANY, NOEVAL,
P_If, "if", 2, MANY, NOEVAL,
P_Case, "case", 2, MANY, NOEVAL,
P_Cond, "cond", 1, MANY, NOEVAL,
P_Do, "do", 2, MANY, NOEVAL,
P_Let, "let", 2, MANY, NOEVAL,
P_Letseq, "let*", 2, MANY, NOEVAL,
P_Letrec, "letrec", 2, MANY, NOEVAL,
P_Fluid_Let, "fluid-let", 2, MANY, NOEVAL,
P_And, "and", 0, MANY, NOEVAL,
P_Or, "or", 0, MANY, NOEVAL,
{ P_Quote, "quote", 1, 1, NOEVAL },
{ P_Quasiquote, "quasiquote", 1, 1, NOEVAL },
{ P_Begin, "begin", 1, MANY, NOEVAL },
{ P_Begin1, "begin1", 1, MANY, NOEVAL },
{ P_If, "if", 2, MANY, NOEVAL },
{ P_Case, "case", 2, MANY, NOEVAL },
{ P_Cond, "cond", 1, MANY, NOEVAL },
{ P_Do, "do", 2, MANY, NOEVAL },
{ P_Let, "let", 2, MANY, NOEVAL },
{ P_Letseq, "let*", 2, MANY, NOEVAL },
{ P_Letrec, "letrec", 2, MANY, NOEVAL },
{ P_Fluid_Let, "fluid-let", 2, MANY, NOEVAL },
{ P_And, "and", 0, MANY, NOEVAL },
{ P_Or, "or", 0, MANY, NOEVAL },
/* string.c:
*/
P_String, "string", 0, MANY, VARARGS,
P_Stringp, "string?", 1, 1, EVAL,
P_Make_String, "make-string", 1, 2, VARARGS,
P_String_Length, "string-length", 1, 1, EVAL,
P_String_To_Number, "string->number", 1, 2, VARARGS,
P_String_Ref, "string-ref", 2, 2, EVAL,
P_String_Set, "string-set!", 3, 3, EVAL,
P_Substring, "substring", 3, 3, EVAL,
P_String_Copy, "string-copy", 1, 1, EVAL,
P_String_Append, "string-append", 0, MANY, VARARGS,
P_List_To_String, "list->string", 1, 1, EVAL,
P_String_To_List, "string->list", 1, 1, EVAL,
P_String_Fill, "string-fill!", 2, 2, EVAL,
P_Substring_Fill, "substring-fill!", 4, 4, EVAL,
P_String_Eq, "string=?", 2, 2, EVAL,
P_String_Less, "string<?", 2, 2, EVAL,
P_String_Greater, "string>?", 2, 2, EVAL,
P_String_Eq_Less, "string<=?", 2, 2, EVAL,
P_String_Eq_Greater, "string>=?", 2, 2, EVAL,
P_String_CI_Eq, "string-ci=?", 2, 2, EVAL,
P_String_CI_Less, "string-ci<?", 2, 2, EVAL,
P_String_CI_Greater, "string-ci>?", 2, 2, EVAL,
P_String_CI_Eq_Less, "string-ci<=?", 2, 2, EVAL,
P_String_CI_Eq_Greater,
"string-ci>=?", 2, 2, EVAL,
P_Substringp, "substring?", 2, 2, EVAL,
P_CI_Substringp, "substring-ci?", 2, 2, EVAL,
{ P_String, "string", 0, MANY, VARARGS },
{ P_Stringp, "string?", 1, 1, EVAL },
{ P_Make_String, "make-string", 1, 2, VARARGS },
{ P_String_Length, "string-length", 1, 1, EVAL },
{ P_String_To_Number, "string->number", 1, 2, VARARGS },
{ P_String_Ref, "string-ref", 2, 2, EVAL },
{ P_String_Set, "string-set!", 3, 3, EVAL },
{ P_Substring, "substring", 3, 3, EVAL },
{ P_String_Copy, "string-copy", 1, 1, EVAL },
{ P_String_Append, "string-append", 0, MANY, VARARGS },
{ P_List_To_String, "list->string", 1, 1, EVAL },
{ P_String_To_List, "string->list", 1, 1, EVAL },
{ P_String_Fill, "string-fill!", 2, 2, EVAL },
{ P_Substring_Fill, "substring-fill!", 4, 4, EVAL },
{ P_String_Eq, "string=?", 2, 2, EVAL },
{ P_String_Less, "string<?", 2, 2, EVAL },
{ P_String_Greater, "string>?", 2, 2, EVAL },
{ P_String_Eq_Less, "string<=?", 2, 2, EVAL },
{ P_String_Eq_Greater, "string>=?", 2, 2, EVAL },
{ P_String_CI_Eq, "string-ci=?", 2, 2, EVAL },
{ P_String_CI_Less, "string-ci<?", 2, 2, EVAL },
{ P_String_CI_Greater, "string-ci>?", 2, 2, EVAL },
{ P_String_CI_Eq_Less, "string-ci<=?", 2, 2, EVAL },
{ P_String_CI_Eq_Greater,
"string-ci>=?", 2, 2, EVAL },
{ P_Substringp, "substring?", 2, 2, EVAL },
{ P_CI_Substringp, "substring-ci?", 2, 2, EVAL },
/* symbol.c:
*/
P_String_To_Symbol, "string->symbol", 1, 1, EVAL,
P_Oblist, "oblist", 0, 0, EVAL,
P_Symbolp, "symbol?", 1, 1, EVAL,
P_Symbol_To_String, "symbol->string", 1, 1, EVAL,
P_Put, "put", 2, 3, VARARGS,
P_Get, "get", 2, 2, EVAL,
P_Symbol_Plist, "symbol-plist", 1, 1, EVAL,
{ P_String_To_Symbol, "string->symbol", 1, 1, EVAL },
{ P_Oblist, "oblist", 0, 0, EVAL },
{ P_Symbolp, "symbol?", 1, 1, EVAL },
{ P_Symbol_To_String, "symbol->string", 1, 1, EVAL },
{ P_Put, "put", 2, 3, VARARGS },
{ P_Get, "get", 2, 2, EVAL },
{ P_Symbol_Plist, "symbol-plist", 1, 1, EVAL },
/* type.c:
*/
P_Type, "type", 1, 1, EVAL,
{ P_Type, "type", 1, 1, EVAL },
/* vector.c:
*/
P_Vectorp, "vector?", 1, 1, EVAL,
P_Make_Vector, "make-vector", 1, 2, VARARGS,
P_Vector, "vector", 0, MANY, VARARGS,
P_Vector_Length, "vector-length", 1, 1, EVAL,
P_Vector_Ref, "vector-ref", 2, 2, EVAL,
P_Vector_Set, "vector-set!", 3, 3, EVAL,
P_Vector_To_List, "vector->list", 1, 1, EVAL,
P_List_To_Vector, "list->vector", 1, 1, EVAL,
P_Vector_Fill, "vector-fill!", 2, 2, EVAL,
P_Vector_Copy, "vector-copy", 1, 1, EVAL,
{ P_Vectorp, "vector?", 1, 1, EVAL },
{ P_Make_Vector, "make-vector", 1, 2, VARARGS },
{ P_Vector, "vector", 0, MANY, VARARGS },
{ P_Vector_Length, "vector-length", 1, 1, EVAL },
{ P_Vector_Ref, "vector-ref", 2, 2, EVAL },
{ P_Vector_Set, "vector-set!", 3, 3, EVAL },
{ P_Vector_To_List, "vector->list", 1, 1, EVAL },
{ P_List_To_Vector, "list->vector", 1, 1, EVAL },
{ P_Vector_Fill, "vector-fill!", 2, 2, EVAL },
{ P_Vector_Copy, "vector-copy", 1, 1, EVAL },
0
{ 0 }
};
/* The C-compiler can't initialize unions, thus the primitive procedures
@ -383,7 +385,7 @@ struct Prim_Init {
* provide an intializer for the "tag" component of an S_Primitive).
*/
Init_Prim () {
void Init_Prim () {
register struct Prim_Init *p;
Object frame, prim, sym;
@ -397,8 +399,8 @@ Init_Prim () {
Memoize_Frame (frame);
}
Define_Primitive (fun, name, min, max, disc) Object (*fun)(); const char *name;
enum discipline disc; {
void Define_Primitive (Object (*fun)(), char const *name, int min, int max,
enum discipline disc) {
Object prim, sym, frame;
GC_Node2;

112
src/print.c
View File

@ -16,34 +16,45 @@
#endif
#endif
extern void Print_Bignum (Object, Object);
extern int errno;
void Flush_Output (Object);
void Print_String (Object, register char *, register int);
void Pr_Char (Object, register int);
void Pr_Symbol (Object, Object, int);
void Pr_List (Object, Object, register int, register int, register int);
void Pr_String (Object, Object, int);
void Pr_Vector (Object, Object, register int, register int, register int);
void Print_Special (Object, register int);
int Saved_Errno;
static Object V_Print_Depth, V_Print_Length;
Init_Print () {
void Init_Print () {
Define_Variable (&V_Print_Depth, "print-depth",
Make_Integer (DEF_PRINT_DEPTH));
Define_Variable (&V_Print_Length, "print-length",
Make_Integer (DEF_PRINT_LEN));
}
Print_Length () {
int Print_Length () {
Object pl;
pl = Var_Get (V_Print_Length);
return TYPE(pl) == T_Fixnum ? FIXNUM(pl) : DEF_PRINT_LEN;
}
Print_Depth () {
int Print_Depth () {
Object pd;
pd = Var_Get (V_Print_Depth);
return TYPE(pd) == T_Fixnum ? FIXNUM(pd) : DEF_PRINT_DEPTH;
}
Print_Char (port, c) Object port; register c; {
void Print_Char (Object port, register int c) {
char buf[1];
if (PORT(port)->flags & P_STRING) {
@ -57,8 +68,8 @@ Print_Char (port, c) Object port; register c; {
}
}
Print_String (port, buf, len) Object port; register char *buf; register len; {
register n;
void Print_String (Object port, register char *buf, register int len) {
register int n;
register struct S_Port *p;
Object new;
GC_Node;
@ -73,19 +84,19 @@ Print_String (port, buf, len) Object port; register char *buf; register len; {
new = Make_String ((char *)0, STRING(p->name)->size + n);
p = PORT(port);
GC_Unlink;
bcopy (STRING(p->name)->data, STRING(new)->data, p->ptr);
memcpy (STRING(new)->data, STRING(p->name)->data, p->ptr);
p->name = new;
}
bcopy (buf, STRING(p->name)->data + p->ptr, len);
memcpy (STRING(p->name)->data + p->ptr, buf, len);
p->ptr += len;
}
#ifndef VPRINTF
vfprintf (f, fmt, ap) register FILE *f; register char *fmt; va_list ap; {
void vfprintf (register FILE *f, register char *fmt, va_list ap) {
_doprnt (fmt, ap, f);
}
vsprintf (s, fmt, ap) register char *s, *fmt; va_list ap; {
void vsprintf (register char *s, register char *fmt, va_list ap) {
FILE x;
x._flag = _IOWRT|_IOSTRG;
x._ptr = s;
@ -96,7 +107,7 @@ vsprintf (s, fmt, ap) register char *s, *fmt; va_list ap; {
#endif
/*VARARGS0*/
Printf (va_alist) va_dcl {
void Printf (va_alist) va_dcl {
va_list args;
Object port;
char *fmt;
@ -118,31 +129,31 @@ Printf (va_alist) va_dcl {
va_end (args);
}
Object General_Print (argc, argv, raw) Object *argv; {
Object General_Print (int argc, Object *argv, int raw) {
General_Print_Object (argv[0], argc == 2 ? argv[1] : Curr_Output_Port, raw);
return Void;
}
Object P_Write (argc, argv) Object *argv; {
Object P_Write (int argc, Object *argv) {
return General_Print (argc, argv, 0);
}
Object P_Display (argc, argv) Object *argv; {
Object P_Display (int argc, Object *argv) {
return General_Print (argc, argv, 1);
}
Object P_Write_Char (argc, argv) Object *argv; {
Object P_Write_Char (int argc, Object *argv) {
Check_Type (argv[0], T_Character);
return General_Print (argc, argv, 1);
}
/*VARARGS1*/
Object P_Newline (argc, argv) Object *argv; {
Object P_Newline (int argc, Object *argv) {
General_Print_Object (Newline, argc == 1 ? argv[0] : Curr_Output_Port, 1);
return Void;
}
Object P_Print (argc, argv) Object *argv; {
Object P_Print (int argc, Object *argv) {
Object port;
GC_Node;
@ -155,12 +166,12 @@ Object P_Print (argc, argv) Object *argv; {
return Void;
}
Object P_Clear_Output_Port (argc, argv) Object *argv; {
Object P_Clear_Output_Port (int argc, Object *argv) {
Discard_Output (argc == 1 ? argv[0] : Curr_Output_Port);
return Void;
}
Discard_Output (port) Object port; {
void Discard_Output (Object port) {
register FILE *f;
Check_Output_Port (port);
@ -184,12 +195,12 @@ Discard_Output (port) Object port; {
#endif
}
Object P_Flush_Output_Port (argc, argv) Object *argv; {
Object P_Flush_Output_Port (int argc, Object *argv) {
Flush_Output (argc == 1 ? argv[0] : Curr_Output_Port);
return Void;
}
Flush_Output (port) Object port; {
void Flush_Output (Object port) {
Check_Output_Port (port);
if (PORT(port)->flags & P_STRING)
return;
@ -199,7 +210,7 @@ Flush_Output (port) Object port; {
}
}
Object P_Get_Output_String (port) Object port; {
Object P_Get_Output_String (Object port) {
register struct S_Port *p;
Object str;
GC_Node;
@ -208,13 +219,13 @@ Object P_Get_Output_String (port) Object port; {
GC_Link (port);
str = Make_String ((char *)0, PORT(port)->ptr);
p = PORT(port);
bcopy (STRING(p->name)->data, STRING(str)->data, p->ptr);
memcpy (STRING(str)->data, STRING(p->name)->data, p->ptr);
p->ptr = 0;
GC_Unlink;
return str;
}
Check_Output_Port (port) Object port; {
void Check_Output_Port (Object port) {
Check_Type (port, T_Port);
if (!(PORT(port)->flags & P_OPEN))
Primitive_Error ("port has been closed: ~s", port);
@ -222,14 +233,14 @@ Check_Output_Port (port) Object port; {
Primitive_Error ("not an output port: ~s", port);
}
General_Print_Object (x, port, raw) Object x, port; {
void General_Print_Object (Object x, Object port, int raw) {
Check_Output_Port (port);
Print_Object (x, port, raw, Print_Depth (), Print_Length ());
}
Print_Object (x, port, raw, depth, length) Object x, port;
register raw, depth, length; {
register t;
void Print_Object (Object x, Object port, register int raw, register int depth,
register int length) {
register int t;
GC_Node2;
GC_Link2 (port, x);
@ -341,7 +352,7 @@ Print_Object (x, port, raw, depth, length) Object x, port;
GC_Unlink;
}
Pr_Char (port, c) Object port; register c; {
void Pr_Char (Object port, register int c) {
register char *p = 0;
switch (c) {
@ -372,10 +383,10 @@ Pr_Char (port, c) Object port; register c; {
if (p) Printf (port, p);
}
Pr_List (port, list, raw, depth, length) Object port, list;
register raw, depth, length; {
void Pr_List (Object port, Object list, register int raw, register int depth,
register int length) {
Object tail;
register len;
register int len;
register char *s = 0;
GC_Node2;
@ -427,9 +438,9 @@ Pr_List (port, list, raw, depth, length) Object port, list;
GC_Unlink;
}
Pr_Vector (port, vec, raw, depth, length) Object port, vec;
register raw, depth, length; {
register i, j;
void Pr_Vector (Object port, Object vec, register int raw, register int depth,
register int length) {
register int i, j;
GC_Node2;
if (depth == 0) {
@ -451,9 +462,9 @@ Pr_Vector (port, vec, raw, depth, length) Object port, vec;
GC_Unlink;
}
Pr_Symbol (port, sym, raw) Object port, sym; {
void Pr_Symbol (Object port, Object sym, int raw) {
Object str;
register c, i;
register int c, i;
GC_Node2;
str = SYMBOL(sym)->name;
@ -481,9 +492,9 @@ Pr_Symbol (port, sym, raw) Object port, sym; {
GC_Unlink;
}
Pr_String (port, str, raw) Object port, str; {
void Pr_String (Object port, Object str, int raw) {
register char *p = STRING(str)->data;
register c, i, len = STRING(str)->size;
register int c, i, len = STRING(str)->size;
GC_Node2;
if (raw) {
@ -512,7 +523,7 @@ Pr_String (port, str, raw) Object port, str; {
GC_Unlink;
}
Print_Special (port, c) Object port; register c; {
void Print_Special (Object port, register int c) {
register char *fmt = "\\%c";
switch (c) {
@ -526,9 +537,9 @@ Print_Special (port, c) Object port; register c; {
Printf (port, fmt, (unsigned char)c);
}
Object P_Format (argc, argv) Object *argv; {
Object P_Format (int argc, Object *argv) {
Object port, str;
register stringret = 0;
register int stringret = 0;
GC_Node;
port = argv[0];
@ -550,24 +561,17 @@ Object P_Format (argc, argv) Object *argv; {
return stringret ? P_Get_Output_String (port) : Void;
}
Format (port, fmt, len, argc, argv) Object port; const char *fmt;
int len; Object *argv; {
register const char *s, *ep;
void Format (Object port, char const *fmt, int len, int argc, Object *argv) {
register char const *s, *ep;
char *p;
register c;
register int c;
char buf[256];
extern sys_nerr;
#ifndef __bsdi__
#ifndef __linux__
extern char *sys_errlist[];
#endif
#endif
GC_Node;
Alloca_Begin;
GC_Link (port);
Alloca (p, char*, len);
bcopy (fmt, p, len);
memcpy (p, fmt, len);
for (ep = p + len; p < ep; p++) {
if (*p == '~') {
if (++p == ep) break;

83
src/proc.c
View File

@ -25,6 +25,13 @@
Funcall_Control_Point (func, args, eval);\
} else Primitive_Error ("application of non-procedure: ~s", func);\
extern void Switch_Environment (Object);
extern unsigned int Stack_Size ();
extern void Uncatchable_Error (char *);
extern void Funcall_Control_Point (Object, Object, int)
__attribute__ ((__noreturn__));
extern void Pop_Frame ();
extern void Push_Frame (Object);
/* Tail_Call indicates whether we are executing the last form in a
* sequence of forms. If it is true and we are about to call a compound
@ -40,13 +47,13 @@ static Object tc_fun, tc_argl, tc_env;
Object Macro_Expand(), Funcall_Primitive(), Funcall_Compound();
Init_Proc () {
void Init_Proc () {
Define_Symbol (&Sym_Lambda, "lambda");
Define_Symbol (&Sym_Macro, "macro");
}
Check_Procedure (x) Object x; {
register t = TYPE(x);
void Check_Procedure (Object x) {
register int t = TYPE(x);
if (t != T_Primitive && t != T_Compound)
Wrong_Type_Combination (x, "procedure");
@ -54,21 +61,21 @@ Check_Procedure (x) Object x; {
Primitive_Error ("invalid procedure: ~s", x);
}
Object P_Procedurep (x) Object x; {
register t = TYPE(x);
Object P_Procedurep (Object x) {
register int t = TYPE(x);
return t == T_Primitive || t == T_Compound || t == T_Control_Point
? True : False;
}
Object P_Primitivep (x) Object x; {
Object P_Primitivep (Object x) {
return TYPE(x) == T_Primitive ? True : False;
}
Object P_Compoundp (x) Object x; {
Object P_Compoundp (Object x) {
return TYPE(x) == T_Compound ? True : False;
}
Object P_Macrop (x) Object x; {
Object P_Macrop (Object x) {
return TYPE(x) == T_Macro ? True : False;
}
@ -80,8 +87,8 @@ Object Make_Compound () {
return proc;
}
Object Make_Primitive (fun, name, min, max, disc) Object (*fun)();
const char *name; enum discipline disc; {
Object Make_Primitive (Object (*fun)(), char const *name, int min, int max,
enum discipline disc) {
Object prim;
register struct S_Primitive *pr;
@ -96,11 +103,11 @@ Object Make_Primitive (fun, name, min, max, disc) Object (*fun)();
return prim;
}
Object Eval (form) Object form; {
register t;
Object Eval (Object form) {
register int t;
register struct S_Symbol *sym;
Object fun, binding, ret;
static unsigned tick;
static unsigned int tick;
GC_Node;
TC_Prolog;
@ -150,7 +157,7 @@ again:
/*NOTREACHED*/
}
Object P_Eval (argc, argv) Object *argv; {
Object P_Eval (int argc, Object *argv) {
Object ret, oldenv;
GC_Node;
@ -166,9 +173,9 @@ Object P_Eval (argc, argv) Object *argv; {
return ret;
}
Object P_Apply (argc, argv) Object *argv; {
Object P_Apply (int argc, Object *argv) {
Object ret, list, tail, cell, last;
register i;
register int i;
GC_Node3;
Check_Procedure (argv[0]);
@ -196,11 +203,11 @@ Object P_Apply (argc, argv) Object *argv; {
return ret;
}
Object Funcall_Primitive (fun, argl, eval) Object fun, argl; {
Object Funcall_Primitive (Object fun, Object argl, int eval) {
register struct S_Primitive *prim;
register argc, i;
const char *last_tag;
register Object *argv;
register int argc, i;
char const *last_tag;
register Object *argv = NULL;
Object abuf[MAX_ARGS_ON_STACK], r, e;
GC_Node4; GCNODE gcv;
TC_Prolog;
@ -299,9 +306,9 @@ Object Funcall_Primitive (fun, argl, eval) Object fun, argl; {
frame = Cons (r, frame);\
}
Object Funcall_Compound (fun, argl, eval) Object fun, argl; {
register argc, min, max, i, tail_calling = 0;
register Object *argv;
Object Funcall_Compound (Object fun, Object argl, int eval) {
register int argc, min, max, i, tail_calling = 0;
register Object *argv = NULL;
Object abuf[MAX_ARGS_ON_STACK], rest, r, frame, tail,
tail_call_env, oldenv, newframe;
register GCNODE *p;
@ -386,13 +393,13 @@ again:
return r;
}
Object Funcall (fun, argl, eval) Object fun, argl; {
register t = TYPE(fun);
Object Funcall (Object fun, Object argl, int eval) {
register int t = TYPE(fun);
Funcall_Switch (t, fun, argl, eval);
/*NOTREACHED*/
}
Check_Formals (x, min, max) Object x; int *min, *max; {
void Check_Formals (Object x, int *min, int *max) {
Object s, t1, t2;
*min = *max = 0;
@ -412,7 +419,7 @@ Check_Formals (x, min, max) Object x; int *min, *max; {
Wrong_Type_Combination (t1, "list or symbol");
}
Object P_Lambda (argl) Object argl; {
Object P_Lambda (Object argl) {
Object proc, closure;
GC_Node2;
@ -429,18 +436,18 @@ Object P_Lambda (argl) Object argl; {
return proc;
}
Object P_Procedure_Lambda (p) Object p; {
Object P_Procedure_Lambda (Object p) {
Check_Type (p, T_Compound);
return Copy_List (COMPOUND(p)->closure);
}
Object P_Procedure_Environment (p) Object p; {
Object P_Procedure_Environment (Object p) {
Check_Type (p, T_Compound);
return COMPOUND(p)->env;
}
Object General_Map (argc, argv, accum) Object *argv; register accum; {
register i;
Object General_Map (int argc, Object *argv, register int accum) {
register int i;
Object *args;
Object head, list, tail, cell, arglist, val;
GC_Node2; GCNODE gcv;
@ -480,11 +487,11 @@ Object General_Map (argc, argv, accum) Object *argv; register accum; {
/*NOTREACHED*/
}
Object P_Map (argc, argv) Object *argv; {
Object P_Map (int argc, Object *argv) {
return General_Map (argc, argv, 1);
}
Object P_For_Each (argc, argv) Object *argv; {
Object P_For_Each (int argc, Object *argv) {
return General_Map (argc, argv, 0);
}
@ -496,7 +503,7 @@ Object Make_Macro () {
return mac;
}
Object P_Macro (argl) Object argl; {
Object P_Macro (Object argl) {
Object mac, body;
GC_Node2;
@ -510,13 +517,13 @@ Object P_Macro (argl) Object argl; {
return mac;
}
Object P_Macro_Body (m) Object m; {
Object P_Macro_Body (Object m) {
Check_Type (m, T_Macro);
return Copy_List (MACRO(m)->body);
}
Object Macro_Expand (mac, argl) Object mac, argl; {
register argc, min, max, i;
Object Macro_Expand (Object mac, Object argl) {
register int argc, min, max, i;
Object frame, r, tail;
GC_Node4;
TC_Prolog;
@ -544,7 +551,7 @@ Object Macro_Expand (mac, argl) Object mac, argl; {
return r;
}
Object P_Macro_Expand (form) Object form; {
Object P_Macro_Expand (Object form) {
Object ret, mac;
GC_Node;

8
src/promise.c
View File

@ -3,11 +3,11 @@
#include "kernel.h"
Object P_Promisep (x) Object x; {
Object P_Promisep (Object x) {
return TYPE(x) == T_Promise ? True : False;
}
Object P_Delay (argl) Object argl; {
Object P_Delay (Object argl) {
Object d;
GC_Node;
@ -20,7 +20,7 @@ Object P_Delay (argl) Object argl; {
return d;
}
Object P_Force (d) Object d; {
Object P_Force (Object d) {
Object ret, a[2];
GC_Node;
TC_Prolog;
@ -41,7 +41,7 @@ Object P_Force (d) Object d; {
return ret;
}
Object P_Promise_Environment (p) Object p; {
Object P_Promise_Environment (Object p) {
Check_Type (p, T_Promise);
return PROMISE(p)->env;
}

92
src/read.c
View File

@ -5,6 +5,7 @@
#include <ctype.h>
#include <limits.h>
#include <string.h>
#ifdef FLUSH_TIOCFLUSH
# include <sys/ioctl.h>
@ -18,9 +19,14 @@
# include FIONREAD_H
#endif
extern void Flush_Output (Object);
extern char *index();
extern double atof();
int Skip_Comment (Object);
void Reader_Error (Object, char *) __attribute__ ((__noreturn__));
Object Sym_Quote,
Sym_Quasiquote,
Sym_Unquote,
@ -46,7 +52,7 @@ Object General_Read(), Read_Sequence(), Read_Atom(), Read_Special();
Object Read_String(), Read_Sharp(), Read_True(), Read_False(), Read_Void();
Object Read_Kludge(), Read_Vector(), Read_Radix(), Read_Char();
Init_Read () {
void Init_Read () {
Define_Symbol (&Sym_Quote, "quote");
Define_Symbol (&Sym_Quasiquote, "quasiquote");
Define_Symbol (&Sym_Unquote, "unquote");
@ -69,7 +75,7 @@ Init_Read () {
Read_Buf = Safe_Malloc (Read_Max);
}
String_Getc (port) Object port; {
int String_Getc (Object port) {
register struct S_Port *p;
register struct S_String *s;
@ -82,12 +88,12 @@ String_Getc (port) Object port; {
return p->ptr >= s->size ? EOF : s->data[p->ptr++];
}
String_Ungetc (port, c) Object port; register c; {
void String_Ungetc (Object port, register int c) {
PORT(port)->flags |= P_UNREAD;
PORT(port)->unread = c;
}
Check_Input_Port (port) Object port; {
void Check_Input_Port (Object port) {
Check_Type (port, T_Port);
if (!(PORT(port)->flags & P_OPEN))
Primitive_Error ("port has been closed: ~s", port);
@ -95,12 +101,12 @@ Check_Input_Port (port) Object port; {
Primitive_Error ("not an input port: ~s", port);
}
Object P_Clear_Input_Port (argc, argv) Object *argv; {
Object P_Clear_Input_Port (int argc, Object *argv) {
Discard_Input (argc == 1 ? argv[0] : Curr_Input_Port);
return Void;
}
Discard_Input (port) Object port; {
void Discard_Input (Object port) {
register FILE *f;
Check_Input_Port (port);
@ -124,7 +130,7 @@ Discard_Input (port) Object port; {
#endif
}
Object P_Unread_Char (argc, argv) Object *argv; {
Object P_Unread_Char (int argc, Object *argv) {
Object port, ch;
register struct S_Port *p;
@ -136,7 +142,7 @@ Object P_Unread_Char (argc, argv) Object *argv; {
if (p->flags & P_STRING) {
if (p->flags & P_UNREAD)
Primitive_Error ("cannot push back more than one char");
String_Ungetc (port, CHAR(ch));
String_Ungetc (port, CHAR(ch));
} else {
if (ungetc (CHAR(ch), p->file) == EOF)
Primitive_Error ("failed to push back char");
@ -145,10 +151,10 @@ Object P_Unread_Char (argc, argv) Object *argv; {
return ch;
}
Object P_Read_Char (argc, argv) Object *argv; {
Object P_Read_Char (int argc, Object *argv) {
Object port;
register FILE *f;
register c, str, flags;
register int c, str, flags;
port = argc == 1 ? argv[0] : Curr_Input_Port;
Check_Input_Port (port);
@ -160,7 +166,7 @@ Object P_Read_Char (argc, argv) Object *argv; {
return c == EOF ? Eof : Make_Char (c);
}
Object P_Peek_Char (argc, argv) Object *argv; {
Object P_Peek_Char (int argc, Object *argv) {
Object a[2];
a[0] = P_Read_Char (argc, argv);
@ -173,7 +179,7 @@ Object P_Peek_Char (argc, argv) Object *argv; {
* The following is only an approximation; even if FIONREAD is supported,
* the primitive may return #f although a call to read-char would not block.
*/
Object P_Char_Readyp (argc, argv) Object *argv; {
Object P_Char_Readyp (int argc, Object *argv) {
Object port;
port = argc == 1 ? argv[0] : Curr_Input_Port;
@ -191,10 +197,10 @@ Object P_Char_Readyp (argc, argv) Object *argv; {
return False;
}
Object P_Read_String (argc, argv) Object *argv; {
Object P_Read_String (int argc, Object *argv) {
Object port;
register FILE *f;
register c, str;
register int c, str;
port = argc == 1 ? argv[0] : Curr_Input_Port;
Check_Input_Port (port);
@ -211,13 +217,13 @@ Object P_Read_String (argc, argv) Object *argv; {
return c == EOF ? Eof : Make_String (Read_Buf, Read_Size);
}
Object P_Read (argc, argv) Object *argv; {
Object P_Read (int argc, Object *argv) {
return General_Read (argc == 1 ? argv[0] : Curr_Input_Port, 0);
}
Object General_Read (port, konst) Object port; {
Object General_Read (Object port, int konst) {
register FILE *f;
register c, str;
register int c, str;
Object ret;
Check_Input_Port (port);
@ -256,9 +262,9 @@ comment:
return ret;
}
Skip_Comment (port) Object port; {
int Skip_Comment (Object port) {
register FILE *f;
register c, str;
register int c, str;
f = PORT(port)->file;
str = PORT(port)->flags & P_STRING;
@ -268,7 +274,7 @@ Skip_Comment (port) Object port; {
return c;
}
Object Read_Atom (port, konst) Object port; {
Object Read_Atom (Object port, int konst) {
Object ret;
ret = Read_Special (port, konst);
@ -277,9 +283,9 @@ Object Read_Atom (port, konst) Object port; {
return ret;
}
Object Read_Special (port, konst) Object port; {
Object Read_Special (Object port, int konst) {
Object ret;
register c, str;
register int c, str;
register FILE *f;
#define READ_QUOTE(sym) \
@ -361,7 +367,7 @@ eof:
/*NOTREACHED*/
}
Object Read_Sequence (port, vec, konst) Object port; {
Object Read_Sequence (Object port, int vec, int konst) {
Object ret, e, tail, t;
GC_Node3;
@ -408,9 +414,9 @@ Object Read_Sequence (port, vec, konst) Object port; {
/*NOTREACHED*/
}
Object Read_String (port, konst) Object port; {
Object Read_String (Object port, int konst) {
register FILE *f;
register n, c, oc, str;
register int n, c, oc, str;
Read_Reset ();
f = PORT(port)->file;
@ -448,7 +454,7 @@ eof:
return General_Make_String (Read_Buf, Read_Size, konst);
}
Object Read_Sharp (port, konst) Object port; {
Object Read_Sharp (Object port, int konst) {
int c, str;
FILE *f;
char buf[32];
@ -466,35 +472,35 @@ Object Read_Sharp (port, konst) Object port; {
}
/*ARGSUSED*/
Object Read_True (port, chr, konst) Object port; {
Object Read_True (Object port, int chr, int konst) {
return True;
}
/*ARGSUSED*/
Object Read_False (port, chr, konst) Object port; {
Object Read_False (Object port, int chr, int konst) {
return False;
}
/*ARGSUSED*/
Object Read_Void (port, chr, konst) Object port; {
Object Read_Void (Object port, int chr, int konst) {
Object ret;
ret = Const_Cons (Void, Null);
return Const_Cons (Sym_Quote, ret);
}
/*ARGSUSED*/
Object Read_Kludge (port, chr, konst) Object port; {
Object Read_Kludge (Object port, int chr, int konst) {
return Special;
}
/*ARGSUSED*/
Object Read_Vector (port, chr, konst) Object port; {
Object Read_Vector (Object port, int chr, int konst) {
return List_To_Vector (Read_Sequence (port, 1, konst), konst);
}
/*ARGSUSED*/
Object Read_Radix (port, chr, konst) Object port; {
Object Read_Radix (Object port, int chr, int konst) {
int c, str;
FILE *f;
Object ret;
@ -520,7 +526,7 @@ Object Read_Radix (port, chr, konst) Object port; {
}
/*ARGSUSED*/
Object Read_Char (port, chr, konst) Object port; {
Object Read_Char (Object port, int chr, int konst) {
int c, str;
FILE *f;
char buf[10], *p = buf;
@ -570,18 +576,18 @@ Object Read_Char (port, chr, konst) Object port; {
/*NOTREACHED*/
}
void Define_Reader (c, fun) READFUN fun; {
void Define_Reader (int c, READFUN fun) {
if (Readers[c] && Readers[c] != fun)
Primitive_Error ("reader for `~a' already defined", Make_Char (c));
Readers[c] = fun;
}
Object Parse_Number (port, buf, radix) Object port; const char *buf; {
const char *p;
Object Parse_Number (Object port, char const *buf, int radix) {
char const *p;
int c, i;
int mdigit = 0, edigit = 0, expo = 0, neg = 0, point = 0;
int gotradix = 0, exact = 0, inexact = 0;
unsigned max;
unsigned int max;
int maxdig;
Object ret;
@ -616,7 +622,7 @@ Object Parse_Number (port, buf, radix) Object port; const char *buf; {
p = buf;
if (*p == '+' || (neg = *p == '-'))
p++;
for ( ; c = *p; p++) {
for ( ; (c = *p); p++) {
if (c == '.') {
if (expo || point++)
return Null;
@ -646,10 +652,10 @@ Object Parse_Number (port, buf, radix) Object port; const char *buf; {
*/
return Make_Flonum (atof (buf));
}
max = (neg ? -(unsigned)INT_MIN : INT_MAX);
max = (neg ? -(unsigned int)INT_MIN : INT_MAX);
maxdig = max % radix;
max /= radix;
for (i = 0, p = buf; c = *p; p++) {
for (i = 0, p = buf; (c = *p); p++) {
if (c == '-' || c == '+') {
buf++;
continue;
@ -661,7 +667,7 @@ Object Parse_Number (port, buf, radix) Object port; const char *buf; {
c = '9' + c - 'a' + 1;
}
c -= '0';
if ((unsigned)i > max || (unsigned)i == max && c > maxdig) {
if ((unsigned int)i > max || ((unsigned int)i == max && c > maxdig)) {
ret = Make_Bignum (buf, neg, radix);
return inexact ? Make_Flonum (Bignum_To_Double (ret)) : ret;
}
@ -672,7 +678,7 @@ Object Parse_Number (port, buf, radix) Object port; const char *buf; {
return inexact ? Make_Flonum ((double)i) : Make_Integer (i);
}
Reader_Error (port, msg) Object port; char *msg; {
void Reader_Error (Object port, char *msg) {
char buf[100];
if (PORT(port)->flags & P_STRING) {

55
src/special.c
View File

@ -3,17 +3,22 @@
#include "kernel.h"
extern void Do_Wind (Object);
extern void Pop_Frame ();
extern void Push_Frame (Object);
extern void Add_Wind (register WIND *, Object, Object);
Object Sym_Else;
Init_Special () {
void Init_Special () {
Define_Symbol (&Sym_Else, "else");
}
Object P_Quote (argl) Object argl; {
Object P_Quote (Object argl) {
return Car (argl);
}
Object Quasiquote (x, level) Object x; {
Object Quasiquote (Object x, int level) {
Object form, list, tail, cell, qcar, qcdr, ret;
TC_Prolog;
@ -88,11 +93,11 @@ Object Quasiquote (x, level) Object x; {
}
}
Object P_Quasiquote (argl) Object argl; {
Object P_Quasiquote (Object argl) {
return Quasiquote (Car (argl), 0);
}
Object P_Begin (forms) Object forms; {
Object P_Begin (Object forms) {
GC_Node;
TC_Prolog;
@ -107,8 +112,8 @@ Object P_Begin (forms) Object forms; {
return Eval (Car (forms));
}
Object P_Begin1 (forms) Object forms; {
register n;
Object P_Begin1 (Object forms) {
register int n;
Object r, ret;
GC_Node;
TC_Prolog;
@ -126,7 +131,7 @@ Object P_Begin1 (forms) Object forms; {
return n ? r : ret;
}
Object P_If (argl) Object argl; {
Object P_If (Object argl) {
Object cond, ret;
GC_Node;
TC_Prolog;
@ -153,7 +158,7 @@ Object P_If (argl) Object argl; {
return ret;
}
Object P_Case (argl) Object argl; {
Object P_Case (Object argl) {
Object ret, key, clause, select;
GC_Node;
TC_Prolog;
@ -189,7 +194,7 @@ Object P_Case (argl) Object argl; {
return ret;
}
Object P_Cond (argl) Object argl; {
Object P_Cond (Object argl) {
Object ret, clause, guard;
int else_clause = 0;
GC_Node3;
@ -237,7 +242,7 @@ Object P_Cond (argl) Object argl; {
return ret;
}
Object General_Junction (argl, and) Object argl; register and; {
Object General_Junction (Object argl, register int and) {
Object ret;
GC_Node;
TC_Prolog;
@ -259,17 +264,17 @@ Object General_Junction (argl, and) Object argl; register and; {
return ret;
}
Object P_And (argl) Object argl; {
Object P_And (Object argl) {
return General_Junction (argl, 1);
}
Object P_Or (argl) Object argl; {
Object P_Or (Object argl) {
return General_Junction (argl, 0);
}
Object P_Do (argl) Object argl; {
Object P_Do (Object argl) {
Object tail, b, val, test, frame, newframe, len, ret;
register local_vars;
register int local_vars;
GC_Node6;
TC_Prolog;
@ -292,7 +297,7 @@ Object P_Do (argl) Object argl; {
Primitive_Error ("~s: duplicate variable binding", b);
frame = Add_Binding (frame, b, val);
}
if (local_vars = !Nullp (frame))
if ((local_vars = !Nullp (frame)))
Push_Frame (frame);
test = Car (Cdr (argl));
Check_Type (test, T_Pair);
@ -324,7 +329,7 @@ Object P_Do (argl) Object argl; {
return ret;
}
Object General_Let (argl, disc) Object argl; {
Object General_Let (Object argl, int disc) {
Object frame, b, binding, val, tail, ret;
GC_Node5;
TC_Prolog;
@ -384,7 +389,7 @@ Object General_Let (argl, disc) Object argl; {
return ret;
}
Object Named_Let (argl) Object argl; {
Object Named_Let (Object argl) {
Object b, val, tail, vlist, vtail, flist, ftail, cell;
GC_Node6;
TC_Prolog;
@ -433,22 +438,22 @@ Object Named_Let (argl) Object argl; {
return tail;
}
Object P_Let (argl) Object argl; {
Object P_Let (Object argl) {
if (TYPE(Car (argl)) == T_Symbol)
return Named_Let (argl);
else
else
return General_Let (argl, 0);
}
Object P_Letseq (argl) Object argl; {
Object P_Letseq (Object argl) {
return General_Let (argl, 1);
}
Object P_Letrec (argl) Object argl; {
Object P_Letrec (Object argl) {
return General_Let (argl, 2);
}
Object Internal_Fluid_Let (bindings, argl) Object bindings, argl; {
Object Internal_Fluid_Let (Object bindings, Object argl) {
Object b, sym, val, vec, ret;
WIND w;
GC_Node5;
@ -483,14 +488,14 @@ Object Internal_Fluid_Let (bindings, argl) Object bindings, argl; {
return ret;
}
Object P_Fluid_Let (argl) Object argl; {
Object P_Fluid_Let (Object argl) {
Object ret;
WIND *first = First_Wind, *last = Last_Wind;
TC_Prolog;
TC_Disable;
ret = Internal_Fluid_Let (Car (argl), argl);
if (Last_Wind = last)
if ((Last_Wind = last))
last->next = 0;
First_Wind = first;
TC_Enable;

4
src/stab-bsd.c
View File

@ -9,7 +9,7 @@ extern int errno;
# define O_BINARY 0
#endif
SYMTAB *Snarf_Symbols (f, ep) FILE *f; struct exec *ep; {
SYMTAB *Snarf_Symbols (FILE *f, struct exec *ep) {
SYMTAB *tab;
register SYM *sp, **nextp;
int nsyms, strsiz;
@ -56,7 +56,7 @@ strerr:
return tab;
}
SYMTAB *Open_File_And_Snarf_Symbols (name) char *name; {
SYMTAB *Open_File_And_Snarf_Symbols (char *name) {
struct exec hdr;
int fd;
FILE *fp;

4
src/stab-coff.c
View File

@ -3,7 +3,7 @@
#undef TYPE /* ldfnc.h defines a TYPE macro. */
#include <ldfcn.h>
SYMTAB *Snarf_Symbols (lf, ep) LDFILE *lf; {
SYMTAB *Snarf_Symbols (LDFILE *lf, int ep) {
SYMTAB *tab;
register SYM *sp, **nextp;
SYMENT sym;
@ -40,7 +40,7 @@ SYMTAB *Snarf_Symbols (lf, ep) LDFILE *lf; {
}
#ifdef INIT_OBJECTS
SYMTAB *Open_File_And_Snarf_Symbols (name) char *name; {
SYMTAB *Open_File_And_Snarf_Symbols (char *name) {
LDFILE *f;
SYMTAB *tab;

4
src/stab-convex.c
View File

@ -9,7 +9,7 @@
#include <sys/mman.h>
#ifdef INIT_OBJECTS
SYMTAB *Open_File_And_Snarf_Symbols (name) char *name; {
SYMTAB *Open_File_And_Snarf_Symbols (char *name) {
int f, n, len = 0;
char *base;
struct filehdr *fhp;
@ -33,7 +33,7 @@ SYMTAB *Open_File_And_Snarf_Symbols (name) char *name; {
tab = (SYMTAB *)Safe_Malloc (sizeof (SYMTAB));
tab->first = 0;
tab->strings = Safe_Malloc ((unsigned int)fhp->h_strsiz);
bcopy (base + fhp->h_strptr, tab->strings, (unsigned int)fhp->h_strsiz);
memcpy (tab->strings, base + fhp->h_strptr, (unsigned int)fhp->h_strsiz);
nextp = &tab->first;
ohp = (struct opthdr *)(base + sizeof *fhp);

8
src/stab-ecoff.c
View File

@ -7,7 +7,7 @@
#include AOUT_H
SYMTAB *Snarf_Symbols (fp) FILE *fp; {
SYMTAB *Snarf_Symbols (FILE *fp) {
long fdi; /* a counter for the file desc table */
FDR *file_desc; /* pointer to the filedesc table */
struct filehdr file_hdr; /* pointer to the file header */
@ -74,7 +74,7 @@ symerr:
symi++) {
if (symbol[symi].st == stProc && symbol[symi].sc == scText) {
p = symbol[symi].iss + strbase;
/* Allocate and initialize node in the symbol table list;
* link node into list
*/
@ -92,10 +92,10 @@ symerr:
return tab;
}
SYMTAB *Open_File_And_Snarf_Symbols (name) char *name; {
SYMTAB *Open_File_And_Snarf_Symbols (char *name) {
FILE *fp;
SYMTAB *tab;
if ((fp = fopen (name, "r")) == NULL)
Primitive_Error ("can't open a.out file");
tab = Snarf_Symbols (fp);

23
src/stab-elf.c
View File

@ -2,6 +2,7 @@
#include <sys/stat.h>
#include <fcntl.h>
#include <libelf.h>
#include <unistd.h>
SYMTAB *
Snarf_Symbols (lf)
@ -15,16 +16,16 @@ Snarf_Symbols (lf)
Elf32_Ehdr *elf_ehdr_ptr = NULL;
Elf32_Shdr *elf_shdr_ptr = NULL,
*symtab_ptr = NULL;
size_t elf_str_index, shstrndx;
char *symbol_name, *section_name;
size_t elf_str_index = 0, shstrndx;
char *section_name;
if (elf_version (EV_CURRENT) == EV_NONE)
Primitive_Error ("a.out file Elf version out of date");
if ((elf_ptr = elf_begin (lf, ELF_C_READ, (Elf *)NULL)) == NULL)
Primitive_Error ("can't elf_begin() a.out file");
/*
* get the elf header, so we'll know where to look for the section
/*
* get the elf header, so we'll know where to look for the section
* names.
*/
if ((elf_ehdr_ptr = elf32_getehdr (elf_ptr)) == NULL) {
@ -32,12 +33,12 @@ Snarf_Symbols (lf)
}
shstrndx = elf_ehdr_ptr->e_shstrndx;
/* look for the symbol and string tables */
while (elf_scn_ptr = elf_nextscn (elf_ptr, elf_scn_ptr)) {
while ((elf_scn_ptr = elf_nextscn (elf_ptr, elf_scn_ptr))) {
if ((elf_shdr_ptr = elf32_getshdr (elf_scn_ptr)) == NULL)
Primitive_Error ("can't get section header in a.out file");
if (elf_shdr_ptr->sh_type == SHT_STRTAB) {
/*
* save the index to the string table for later use by
/*
* save the index to the string table for later use by
* elf_strptr().
*/
section_name = elf_strptr (elf_ptr, shstrndx,
@ -57,11 +58,11 @@ Snarf_Symbols (lf)
Primitive_Error ("no symbol table in a.out file");
if (!elf_str_index)
Primitive_Error ("no string table in a.out file");
/*
* we've located the symbol table -- go through it and save the names
/*
* we've located the symbol table -- go through it and save the names
* of the interesting symbols.
*/
while (elf_data_ptr = elf_getdata (symtab_scn_ptr, elf_data_ptr)) {
while ((elf_data_ptr = elf_getdata (symtab_scn_ptr, elf_data_ptr))) {
char *name = NULL;
int symbol_count;
Elf32_Sym *symbol_ptr = elf_data_ptr->d_buf;
@ -99,7 +100,7 @@ Snarf_Symbols (lf)
}
return tab;
}
SYMTAB *
Open_File_And_Snarf_Symbols (name)
char *name;

18
src/stab-hp9k300.c
View File

@ -3,22 +3,22 @@
/* On the HP9000 an nlist entry contains a fixed length
* part consisting of the symbol information, plus a variable
* length part, the name without a '\0' terminator.
* We don't know how much space to allocate for the names
* length part, the name without a '\0' terminator.
* We don't know how much space to allocate for the names
* until we have read them all.
* The solution here is to save all the names on the fly
* in a table that is grown in units of STRING_BLOCK bytes,
* using realloc to expand it on demand.
*/
#define STRING_BLOCK 8192
SYMTAB *Snarf_Symbols (f, ep) FILE *f; struct exec *ep; {
SYMTAB *Snarf_Symbols (FILE *f, struct exec *ep) {
SYMTAB *tab;
register SYM *sp;
register SYM **nextp;
int strsiz = 0; /* running total length of names read, */
/* each '\0' terminated */
/* each '\0' terminated */
int nread = 0; /* running total of bytes read from symbol table */
int max = 0; /* current maximum size of name table */
char *names = 0; /* the name table */
@ -54,7 +54,7 @@ SYMTAB *Snarf_Symbols (f, ep) FILE *f; struct exec *ep; {
Primitive_Error ("corrupt symbol table in object file");
}
else {
nread += nl.n_length;
nread += nl.n_length;
names[ strsiz + nl.n_length ] = '\0';
}
if ((nl.n_type & N_TYPE) != N_TEXT) {
@ -71,15 +71,15 @@ SYMTAB *Snarf_Symbols (f, ep) FILE *f; struct exec *ep; {
}
tab->strings = names;
for (sp = tab->first; sp; sp = sp->next)
sp->name += (unsigned)names;
sp->name += (unsigned int)names;
return tab;
}
#ifdef INIT_OBJECTS
SYMTAB *Open_File_And_Snarf_Symbols (name) char *name; {
SYMTAB *Open_File_And_Snarf_Symbols (char *name) {
struct exec hdr;
FILE *f;
SYMTAB *tab;

6
src/stab-hp9k800.c
View File

@ -1,10 +1,10 @@
#include AOUT_H
#include <sys/types.h>
SYMTAB *Snarf_Symbols (f, hp) FILE *f; struct header *hp; {
SYMTAB *Snarf_Symbols (FILE *f, struct header *hp) {
SYMTAB *tab;
register SYM *sp, **nextp;
register n;
register int n;
struct symbol_dictionary_record r;
tab = (SYMTAB *)Safe_Malloc (sizeof (SYMTAB));
@ -38,7 +38,7 @@ SYMTAB *Snarf_Symbols (f, hp) FILE *f; struct header *hp; {
return tab;
}
SYMTAB *Open_File_And_Snarf_Symbols (name) char *name; {
SYMTAB *Open_File_And_Snarf_Symbols (char *name) {
struct header hdr;
FILE *f;
SYMTAB *tab;

6
src/stab-macho.c
View File

@ -33,7 +33,7 @@ static SYMTAB *Grovel_Over_Nlist (symcmd, nl, strtab, text_sect)
return tab;
}
SYMTAB *Snarf_Symbols (mhdr) struct mach_header *mhdr; {
SYMTAB *Snarf_Symbols (struct mach_header *mhdr) {
struct load_command *ld_cmd;
struct symtab_command *sym_cmd;
struct segment_command *seg_cmd;
@ -71,8 +71,8 @@ SYMTAB *Snarf_Symbols (mhdr) struct mach_header *mhdr; {
}
#ifdef INIT_OBJECTS
SYMTAB *Open_File_And_Snarf_Symbols (name) char *name; {
SYMTAB *Open_File_And_Snarf_Symbols (char *name) {
extern char *_mh_execute_header;
return Snarf_Symbols ((struct mach_header *)&_mh_execute_header);
}
}
#endif /* INIT_OBJECTS */

45
src/stab.c
View File

@ -3,6 +3,11 @@
#include "kernel.h"
#include <string.h>
#include <stdlib.h>
void Free_Symbols (SYMTAB *);
#if defined(CAN_LOAD_OBJ) || defined (INIT_OBJECTS)
#ifdef MACH_O
@ -37,33 +42,33 @@
static SYMPREFIX Ignore_Prefixes[] = {
/* Currently none */
0, 0
{ 0, 0 }
};
static SYMPREFIX Init_Prefixes[] = {
INIT_PREFIX, PR_EXTENSION,
"_GLOBAL_.I.", PR_CONSTRUCTOR, /* SVR4.2/g++ */
"__sti__", PR_CONSTRUCTOR,
"_STI", PR_CONSTRUCTOR,
"_GLOBAL_$I$", PR_CONSTRUCTOR,
0, 0
{ INIT_PREFIX, PR_EXTENSION },
{ "_GLOBAL_.I.", PR_CONSTRUCTOR }, /* SVR4.2/g++ */
{ "__sti__", PR_CONSTRUCTOR },
{ "_STI", PR_CONSTRUCTOR },
{ "_GLOBAL_$I$", PR_CONSTRUCTOR },
{ 0, 0 }
};
static SYMPREFIX Finit_Prefixes[] = {
FINIT_PREFIX, PR_EXTENSION,
"_GLOBAL_.D.", PR_CONSTRUCTOR,
"__std__", PR_CONSTRUCTOR,
"_STD", PR_CONSTRUCTOR,
"_GLOBAL_$D$", PR_CONSTRUCTOR,
0, 0
{ FINIT_PREFIX, PR_EXTENSION },
{ "_GLOBAL_.D.", PR_CONSTRUCTOR },
{ "__std__", PR_CONSTRUCTOR },
{ "_STD", PR_CONSTRUCTOR },
{ "_GLOBAL_$D$", PR_CONSTRUCTOR },
{ 0, 0 }
};
static FUNCT *Finalizers;
static void Call (l) unsigned long l; {
static void Call (unsigned long int l) {
#ifdef XCOFF
unsigned long vec[3];
unsigned long int vec[3];
extern main();
bcopy ((char *)main, (char *)vec, sizeof vec);
memcpy (vec, main, sizeof vec);
vec[0] = (l & ~0xF0000000) + (vec[0] & 0xF0000000);
((void (*)())vec)();
#else
@ -71,7 +76,7 @@ static void Call (l) unsigned long l; {
#endif
}
Call_Initializers (tab, addr, which) SYMTAB *tab; char *addr; {
void Call_Initializers (SYMTAB *tab, char *addr, int which) {
SYM *sp;
char *p;
SYMPREFIX *pp;
@ -125,17 +130,17 @@ next: ;
/* Call the finialization functions and C++ static destructors. Make sure
* that calling exit() from a function doesn't cause endless recursion.
*/
Call_Finalizers () {
void Call_Finalizers () {
while (Finalizers) {
FUNCT *fp = Finalizers;
Finalizers = fp->next;
if (Verb_Init)
printf ("[calling %s]\n", fp->name);
Call ((unsigned long)fp->func);
Call ((unsigned long int)fp->func);
}
}
Free_Symbols (tab) SYMTAB *tab; {
void Free_Symbols (SYMTAB *tab) {
register SYM *sp, *nextp;
for (sp = tab->first; sp; sp = nextp) {

26
src/stkmem.c
View File

@ -9,7 +9,7 @@ extern char *malloc();
MEM_NODE *Mem_List;
char *Mem_Alloc (size) unsigned size; {
char *Mem_Alloc (unsigned int size) {
char *ret;
Disable_Interrupts;
@ -19,7 +19,7 @@ char *Mem_Alloc (size) unsigned size; {
return ret;
}
Free_Mem_Nodes (first) MEM_NODE *first; {
Free_Mem_Nodes (MEM_NODE *first) {
MEM_NODE *p;
Disable_Interrupts;
@ -31,8 +31,8 @@ Free_Mem_Nodes (first) MEM_NODE *first; {
Enable_Interrupts;
}
Save_Mem_Nodes (cont) Object cont; {
unsigned sum = 0;
Save_Mem_Nodes (Object cont) {
unsigned int sum = 0;
char *s;
MEM_NODE *p;
Object str;
@ -46,12 +46,12 @@ Save_Mem_Nodes (cont) Object cont; {
CONTROL(cont)->memsave = str;
GC_Unlink;
for (p = Mem_List, s = STRING(str)->data; p; s += p->len, p = p->next) {
bcopy ((char *)(p+1), s, p->len);
memcpy (s, p+1, p->len);
p->refcnt++;
}
}
Restore_Mem_Nodes (cont) Object cont; {
Restore_Mem_Nodes (Object cont) {
MEM_NODE *p;
char *s;
Object str;
@ -61,13 +61,13 @@ Restore_Mem_Nodes (cont) Object cont; {
str = CONTROL(cont)->memsave;
for (p = Mem_List, s = STRING(str)->data; p; s += p->len, p = p->next) {
p->refcnt++;
bcopy (s, (char *)(p+1), p->len);
memcpy (p+1, s, p->len);
}
}
Object Save_GC_Nodes () {
Object vec;
register unsigned sum = 0, i = 0, n;
register unsigned int sum = 0, i = 0, n;
register GCNODE *p;
for (p = GC_List; p; p = p->next)
@ -75,20 +75,18 @@ Object Save_GC_Nodes () {
vec = Make_Vector (sum, Null);
for (p = GC_List; p; p = p->next, i += n) {
n = p->gclen <= 0 ? 1 : p->gclen-1;
bcopy ((char *)p->gcobj, (char *)&(VECTOR(vec)->data[i]),
n * sizeof (Object));
memcpy (&(VECTOR(vec)->data[i]), p->gcobj, n * sizeof (Object));
}
return vec;
}
Restore_GC_Nodes (vec) Object vec; {
register i = 0, n;
Restore_GC_Nodes (Object vec) {
register int i = 0, n;
register GCNODE *p;
for (p = GC_List; p; p = p->next, i += n) {
n = p->gclen <= 0 ? 1 : p->gclen-1;
bcopy ((char *)&(VECTOR(vec)->data[i]), (char *)p->gcobj,
n * sizeof (Object));
memcpy (p->gcobj, &(VECTOR(vec)->data[i]), n * sizeof (Object));
}
}

103
src/string.c
View File

@ -1,11 +1,14 @@
#include <ctype.h>
#include <string.h>
#include "kernel.h"
extern int Get_Index (Object, Object);
char Char_Map[256];
Init_String () {
register i;
void Init_String () {
register int i;
for (i = 0; i < 256; i++)
Char_Map[i] = i;
@ -13,31 +16,31 @@ Init_String () {
Char_Map[i] = tolower (i);
}
Object General_Make_String (s, len, konst) const char *s; {
Object General_Make_String (char const *s, int len, int konst) {
Object str;
str = Alloc_Object (len + sizeof (struct S_String) - 1, T_String, konst);
STRING(str)->tag = Null;
STRING(str)->size = len;
if (s)
bcopy (s, STRING(str)->data, len);
memcpy (STRING(str)->data, s, len);
return str;
}
Object Make_String (s, len) const char *s; {
Object Make_String (char const *s, int len) {
return General_Make_String (s, len, 0);
}
Object Make_Const_String (s, len) const char *s; {
Object Make_Const_String (char const *s, int len) {
return General_Make_String (s, len, 1);
}
Object P_Stringp (s) Object s; {
Object P_Stringp (Object s) {
return TYPE(s) == T_String ? True : False;
}
Object P_Make_String (argc, argv) Object *argv; {
register len, c = ' ';
Object P_Make_String (int argc, Object *argv) {
register int len, c = ' ';
Object str;
register char *p;
@ -52,9 +55,9 @@ Object P_Make_String (argc, argv) Object *argv; {
return str;
}
Object P_String (argc, argv) Object *argv; {
Object P_String (int argc, Object *argv) {
Object str;
register i;
register int i;
str = Make_String ((char *)0, argc);
for (i = 0; i < argc; i++) {
@ -64,7 +67,7 @@ Object P_String (argc, argv) Object *argv; {
return str;
}
Object P_String_To_Number (argc, argv) Object *argv; {
Object P_String_To_Number (int argc, Object *argv) {
Object ret;
char *b;
register struct S_String *p;
@ -83,25 +86,25 @@ Object P_String_To_Number (argc, argv) Object *argv; {
}
p = STRING(argv[0]);
Alloca (b, char*, p->size+1);
bcopy (p->data, b, p->size);
memcpy (b, p->data, p->size);
b[p->size] = '\0';
ret = Parse_Number (Null, b, radix);
Alloca_End;
return Nullp (ret) ? False : ret;
}
Object P_String_Length (s) Object s; {
Object P_String_Length (Object s) {
Check_Type (s, T_String);
return Make_Integer (STRING(s)->size);
}
Object P_String_Ref (s, n) Object s, n; {
Object P_String_Ref (Object s, Object n) {
Check_Type (s, T_String);
return Make_Char (STRING(s)->data[Get_Index (n, s)]);
}
Object P_String_Set (s, n, new) Object s, n, new; {
register i, old;
Object P_String_Set (Object s, Object n, Object new) {
register int i, old;
Check_Type (s, T_String);
Check_Mutable (s);
@ -111,8 +114,8 @@ Object P_String_Set (s, n, new) Object s, n, new; {
return Make_Char (old);
}
Object P_Substring (s, a, b) Object s, a, b; {
register i, j;
Object P_Substring (Object s, Object a, Object b) {
register int i, j;
Check_Type (s, T_String);
if ((i = Get_Exact_Integer (a)) < 0 || i > STRING(s)->size)
@ -124,13 +127,13 @@ Object P_Substring (s, a, b) Object s, a, b; {
return Make_String (&STRING(s)->data[i], j-i);
}
Object P_String_Copy (s) Object s; {
Object P_String_Copy (Object s) {
Check_Type (s, T_String);
return Make_String (STRING(s)->data, STRING(s)->size);
}
Object P_String_Append (argc, argv) Object *argv; {
register i, len;
Object P_String_Append (int argc, Object *argv) {
register int i, len;
Object s, str;
for (len = i = 0; i < argc; i++) {
@ -140,15 +143,15 @@ Object P_String_Append (argc, argv) Object *argv; {
str = Make_String ((char *)0, len);
for (len = i = 0; i < argc; i++) {
s = argv[i];
bcopy (STRING(s)->data, &STRING(str)->data[len], STRING(s)->size);
memcpy (&STRING(str)->data[len], STRING(s)->data, STRING(s)->size);
len += STRING(s)->size;
}
return str;
}
Object P_List_To_String (list) Object list; {
Object P_List_To_String (Object list) {
Object str, len;
register i;
register int i;
GC_Node;
GC_Link (list);
@ -162,8 +165,8 @@ Object P_List_To_String (list) Object list; {
return str;
}
Object P_String_To_List (s) Object s; {
register i;
Object P_String_To_List (Object s) {
register int i;
Object list, tail, cell;
GC_Node3;
@ -181,8 +184,8 @@ Object P_String_To_List (s) Object s; {
return list;
}
Object P_Substring_Fill (s, a, b, c) Object s, a, b, c; {
register i, j;
Object P_Substring_Fill (Object s, Object a, Object b, Object c) {
register int i, j;
Check_Type (s, T_String);
Check_Mutable (s);
@ -197,21 +200,21 @@ Object P_Substring_Fill (s, a, b, c) Object s, a, b, c; {
return s;
}
Object P_String_Fill (s, c) Object s, c; {
Object P_String_Fill (Object s, Object c) {
Object ret;
GC_Node2;
Check_Type (s, T_String);
Check_Mutable (s);
GC_Link2 (s, c);
ret = P_Substring_Fill (s, Make_Integer (0),
ret = P_Substring_Fill (s, Make_Integer (0),
Make_Integer (STRING(s)->size), c);
GC_Unlink;
return ret;
}
Object General_Substringp (s1, s2, ci) Object s1, s2; register ci; {
register n, l1, l2;
Object General_Substringp (Object s1, Object s2, register int ci) {
register int n, l1, l2;
register char *p1, *p2, *p3, *map;
Check_Type (s1, T_String);
@ -222,7 +225,7 @@ Object General_Substringp (s1, s2, ci) Object s1, s2; register ci; {
for (p2 = STRING(s2)->data; l2 >= l1; p2++, l2--) {
for (p1 = STRING(s1)->data, p3 = p2, n = l1; n; n--, p1++, p3++) {
if (ci) {
if (map[*p1] != map[*p3]) goto fail;
if (map[(int)*p1] != map[(int)*p3]) goto fail;
} else
if (*p1 != *p3) goto fail;
}
@ -232,16 +235,16 @@ fail: ;
return False;
}
Object P_Substringp (s1, s2) Object s1, s2; {
Object P_Substringp (Object s1, Object s2) {
return General_Substringp (s1, s2, 0);
}
Object P_CI_Substringp (s1, s2) Object s1, s2; {
Object P_CI_Substringp (Object s1, Object s2) {
return General_Substringp (s1, s2, 1);
}
General_Strcmp (s1, s2, ci) Object s1, s2; register ci; {
register n, l1, l2;
int General_Strcmp (Object s1, Object s2, register int ci) {
register int n, l1, l2;
register char *p1, *p2, *map;
Check_Type (s1, T_String);
@ -251,51 +254,51 @@ General_Strcmp (s1, s2, ci) Object s1, s2; register ci; {
p1 = STRING(s1)->data; p2 = STRING(s2)->data;
for (map = Char_Map; --n >= 0; p1++, p2++) {
if (ci) {
if (map[*p1] != map[*p2]) break;
if (map[(int)*p1] != map[(int)*p2]) break;
} else
if (*p1 != *p2) break;
}
if (n < 0)
return l1 - l2;
return ci ? map[*p1] - map[*p2] : *p1 - *p2;
return ci ? map[(int)*p1] - map[(int)*p2] : *p1 - *p2;
}
Object P_String_Eq (s1, s2) Object s1, s2; {
Object P_String_Eq (Object s1, Object s2) {
return General_Strcmp (s1, s2, 0) ? False : True;
}
Object P_String_Less (s1, s2) Object s1, s2; {
Object P_String_Less (Object s1, Object s2) {
return General_Strcmp (s1, s2, 0) < 0 ? True : False;
}
Object P_String_Greater (s1, s2) Object s1, s2; {
Object P_String_Greater (Object s1, Object s2) {
return General_Strcmp (s1, s2, 0) > 0 ? True : False;
}
Object P_String_Eq_Less (s1, s2) Object s1, s2; {
Object P_String_Eq_Less (Object s1, Object s2) {
return General_Strcmp (s1, s2, 0) <= 0 ? True : False;
}
Object P_String_Eq_Greater (s1, s2) Object s1, s2; {
Object P_String_Eq_Greater (Object s1, Object s2) {
return General_Strcmp (s1, s2, 0) >= 0 ? True : False;
}
Object P_String_CI_Eq (s1, s2) Object s1, s2; {
Object P_String_CI_Eq (Object s1, Object s2) {
return General_Strcmp (s1, s2, 1) ? False : True;
}
Object P_String_CI_Less (s1, s2) Object s1, s2; {
Object P_String_CI_Less (Object s1, Object s2) {
return General_Strcmp (s1, s2, 1) < 0 ? True : False;
}
Object P_String_CI_Greater (s1, s2) Object s1, s2; {
Object P_String_CI_Greater (Object s1, Object s2) {
return General_Strcmp (s1, s2, 1) > 0 ? True : False;
}
Object P_String_CI_Eq_Less (s1, s2) Object s1, s2; {
Object P_String_CI_Eq_Less (Object s1, Object s2) {
return General_Strcmp (s1, s2, 1) <= 0 ? True : False;
}
Object P_String_CI_Eq_Greater (s1, s2) Object s1, s2; {
Object P_String_CI_Eq_Greater (Object s1, Object s2) {
return General_Strcmp (s1, s2, 1) >= 0 ? True : False;
}

63
src/symbol.c
View File

@ -1,7 +1,10 @@
#include <ctype.h>
#include <string.h>
#include "kernel.h"
int Hash (char const *, int);
Object Obarray;
Object Null,
@ -16,7 +19,7 @@ Object Null,
Zero,
One;
Init_Symbol () {
void Init_Symbol () {
SET(Null, T_Null, 0);
SET(True, T_Boolean, 1);
SET(False, T_Boolean, 0);
@ -32,7 +35,7 @@ Init_Symbol () {
Define_Symbol (&Void, "");
}
Object Make_Symbol (name) Object name; {
Object Make_Symbol (Object name) {
Object sym;
register struct S_Symbol *sp;
GC_Node;
@ -47,17 +50,17 @@ Object Make_Symbol (name) Object name; {
return sym;
}
Object P_Symbolp (x) Object x; {
Object P_Symbolp (Object x) {
return TYPE(x) == T_Symbol ? True : False;
}
Object P_Symbol_To_String (x) Object x; {
Object P_Symbol_To_String (Object x) {
Check_Type (x, T_Symbol);
return SYMBOL(x)->name;
}
Object Obarray_Lookup (str, len) register char *str; register len; {
register h;
Object Obarray_Lookup (register char const *str, register int len) {
register int h;
register struct S_String *s;
register struct S_Symbol *sym;
Object p;
@ -72,10 +75,10 @@ Object Obarray_Lookup (str, len) register char *str; register len; {
return Make_Integer (h);
}
Object CI_Intern (str) const char *str; {
Object CI_Intern (char const *str) {
Object s, *p, sym, ostr;
register len;
register const char *src;
register int len;
register char const *src;
char *dst;
char buf[128];
Alloca_Begin;
@ -83,7 +86,7 @@ Object CI_Intern (str) const char *str; {
len = strlen (str);
if (len > sizeof (buf)) {
Alloca (dst, char*, len);
} else
} else
dst = buf;
src = str;
str = dst;
@ -103,9 +106,9 @@ Object CI_Intern (str) const char *str; {
return sym;
}
Object Intern (str) const char *str; {
Object Intern (char const *str) {
Object s, *p, sym, ostr;
register len;
register int len;
if (Case_Insensitive)
return CI_Intern (str);
@ -121,7 +124,7 @@ Object Intern (str) const char *str; {
return sym;
}
Object P_String_To_Symbol (str) Object str; {
Object P_String_To_Symbol (Object str) {
Object s, *p, sym;
Check_Type (str, T_String);
@ -137,7 +140,7 @@ Object P_String_To_Symbol (str) Object str; {
}
Object P_Oblist () {
register i;
register int i;
Object p, list, bucket;
GC_Node2;
@ -154,7 +157,7 @@ Object P_Oblist () {
return list;
}
Object P_Put (argc, argv) Object *argv; {
Object P_Put (int argc, Object *argv) {
Object sym, key, last, tail, prop;
GC_Node3;
@ -189,7 +192,7 @@ Object P_Put (argc, argv) Object *argv; {
return key;
}
Object P_Get (sym, key) Object sym, key; {
Object P_Get (Object sym, Object key) {
Object prop;
Check_Type (sym, T_Symbol);
@ -205,14 +208,14 @@ Object P_Get (sym, key) Object sym, key; {
return Cdr (prop);
}
Object P_Symbol_Plist (sym) Object sym; {
Object P_Symbol_Plist (Object sym) {
Check_Type (sym, T_Symbol);
return Copy_List (SYMBOL(sym)->plist);
}
Hash (str, len) char *str; {
register h;
register char *p, *ep;
int Hash (char const *str, int len) {
register int h;
register char const *p, *ep;
h = 5 * len;
if (len > 5)
@ -222,12 +225,12 @@ Hash (str, len) char *str; {
return h & 017777777777;
}
void Define_Symbol (sym, name) Object *sym; const char *name; {
void Define_Symbol (Object *sym, char const *name) {
*sym = Intern (name);
Func_Global_GC_Link (sym);
}
void Define_Variable (var, name, init) Object *var, init; const char *name; {
void Define_Variable (Object *var, char const *name, Object init) {
Object frame, sym;
GC_Node;
@ -241,26 +244,26 @@ void Define_Variable (var, name, init) Object *var, init; const char *name; {
GC_Unlink;
}
Object Var_Get (var) Object var; {
Object Var_Get (Object var) {
return Cdr (var);
}
void Var_Set (var, val) Object var, val; {
void Var_Set (Object var, Object val) {
Cdr (var) = val;
SYMBOL (Car (var))->value = val;
}
int Var_Is_True (var) Object var; {
int Var_Is_True (Object var) {
var = Var_Get (var);
return Truep (var);
}
unsigned long Symbols_To_Bits (x, mflag, stab) Object x; SYMDESCR *stab; {
unsigned long int Symbols_To_Bits (Object x, int mflag, SYMDESCR *stab) {
register SYMDESCR *syms;
register unsigned long mask = 0;
register unsigned long int mask = 0;
Object l, s;
register char *p;
register n;
register int n;
if (!mflag) Check_Type (x, T_Symbol);
for (l = x; !Nullp (l); l = Cdr (l)) {
@ -282,7 +285,7 @@ unsigned long Symbols_To_Bits (x, mflag, stab) Object x; SYMDESCR *stab; {
return mask;
}
Object Bits_To_Symbols (x, mflag, stab) unsigned long x; SYMDESCR *stab; {
Object Bits_To_Symbols (unsigned long int x, int mflag, SYMDESCR *stab) {
register SYMDESCR *syms;
Object list, tail, cell;
GC_Node2;
@ -292,7 +295,7 @@ Object Bits_To_Symbols (x, mflag, stab) unsigned long x; SYMDESCR *stab; {
for (list = tail = Null, syms = stab; syms->name; syms++)
if ((x & syms->val) && syms->val != ~0) {
Object z;
z = Intern (syms->name);
cell = Cons (z, Null);
if (Nullp (list))

9
src/terminate.c
View File

@ -2,6 +2,7 @@
*/
#include <varargs.h>
#include <stdlib.h>
#include "kernel.h"
@ -9,7 +10,7 @@ static WEAK_NODE *first;
void Call_Terminators();
Init_Terminate () {
void Init_Terminate () {
Register_After_GC (Call_Terminators);
}
@ -29,7 +30,7 @@ void Register_Object (obj, group, term, leader_flag) Object obj; GENERIC group;
first = p;
}
void Deregister_Object (obj) Object obj; {
void Deregister_Object (Object obj) {
WEAK_NODE *p, **pp;
Disable_Interrupts;
@ -95,7 +96,7 @@ Object Find_Object (va_alist) va_dcl {
/* Terminate all objects belonging to the given group except leaders.
*/
void Terminate_Group (group) GENERIC group; {
void Terminate_Group (GENERIC group) {
WEAK_NODE *p, **pp, *q = 0;
Disable_Interrupts;
@ -120,7 +121,7 @@ void Terminate_Group (group) GENERIC group; {
/* Terminate all objects of a given type.
*/
void Terminate_Type (type) int type; {
void Terminate_Type (int type) {
WEAK_NODE *p, **pp, *q = 0;
Disable_Interrupts;

24
src/type.c
View File

@ -3,6 +3,8 @@
#include "kernel.h"
#include <string.h>
#define TYPE_GROW 10
TYPEDESCR *Types;
@ -20,12 +22,12 @@ char *builtin_types[] = {
0
};
Wrong_Type (x, t) Object x; register t; {
void Wrong_Type (Object x, register int t) {
Wrong_Type_Combination (x, Types[t].name);
}
Wrong_Type_Combination (x, name) Object x; register const char *name; {
register t = TYPE(x);
void Wrong_Type_Combination (Object x, register char const *name) {
register int t = TYPE(x);
char buf[100];
if (t < 0 || t >= Num_Types)
@ -35,17 +37,17 @@ Wrong_Type_Combination (x, name) Object x; register const char *name; {
Primitive_Error (buf);
}
Object P_Type (x) Object x; {
register t = TYPE(x);
Object P_Type (Object x) {
register int t = TYPE(x);
if (t < 0 || t >= Num_Types)
Panic ("bad type2");
return Intern (Types[t].name);
}
Define_Type (t, name, size, const_size, eqv, equal, print, visit) register t;
const char *name;
int (*size)(), (*eqv)(), (*equal)(), (*print)(), (*visit)(); {
int Define_Type (register int t, char const *name,
int (*size)(), int const_size, int (*eqv)(), int (*equal)(),
int (*print)(), int (*visit)()) {
register TYPEDESCR *p;
Set_Error_Tag ("define-type");
@ -70,7 +72,7 @@ Define_Type (t, name, size, const_size, eqv, equal, print, visit) register t;
return Num_Types-1;
}
Init_Type() {
void Init_Type() {
int i, bytes;
char *p;
@ -78,8 +80,8 @@ Init_Type() {
Max_Type = Num_Types + TYPE_GROW;
bytes = Max_Type * sizeof(TYPEDESCR);
Types = (TYPEDESCR *)Safe_Malloc(bytes);
bzero((char *)Types, bytes);
for (i = 0; p = builtin_types[i]; i++) {
memset(Types, 0, bytes);
for (i = 0; (p = builtin_types[i]); i++) {
Types[i].haspointer = *p != '0';
Types[i].name = ++p;
}

48
src/vector.c
View File

@ -1,10 +1,14 @@
#include "kernel.h"
Object General_Make_Vector (len, fill, konst) Object fill; {
#include <string.h>
extern int Get_Index (Object, Object);
Object General_Make_Vector (int len, Object fill, int konst) {
Object vec;
register Object *op;
GC_Node;
GC_Link (fill);
vec = Alloc_Object ((len-1) * sizeof (Object) + sizeof (struct S_Vector),
T_Vector, konst);
@ -16,25 +20,25 @@ Object General_Make_Vector (len, fill, konst) Object fill; {
return vec;
}
Object Make_Vector (len, fill) Object fill; {
Object Make_Vector (int len, Object fill) {
return General_Make_Vector (len, fill, 0);
}
Object Make_Const_Vector (len, fill) Object fill; {
Object Make_Const_Vector (int len, Object fill) {
return General_Make_Vector (len, fill, 1);
}
Object P_Make_Vector (argc, argv) Object *argv; {
register len;
Object P_Make_Vector (int argc, Object *argv) {
register int len;
if ((len = Get_Exact_Integer (argv[0])) < 0)
Range_Error (argv[0]);
return Make_Vector (len, argc == 1 ? Null : argv[1]);
}
Object P_Vector (argc, argv) Object *argv; {
Object P_Vector (int argc, Object *argv) {
Object vec;
register i;
register int i;
vec = Make_Vector (argc, Null);
for (i = 0; i < argc; i++)
@ -42,23 +46,23 @@ Object P_Vector (argc, argv) Object *argv; {
return vec;
}
Object P_Vectorp (x) Object x; {
Object P_Vectorp (Object x) {
return TYPE(x) == T_Vector ? True : False;
}
Object P_Vector_Length (x) Object x; {
Object P_Vector_Length (Object x) {
Check_Type (x, T_Vector);
return Make_Integer (VECTOR(x)->size);
}
Object P_Vector_Ref (vec, n) Object vec, n; {
Object P_Vector_Ref (Object vec, Object n) {
Check_Type (vec, T_Vector);
return VECTOR(vec)->data[Get_Index (n, vec)];
}
Object P_Vector_Set (vec, n, new) Object vec, n, new; {
Object P_Vector_Set (Object vec, Object n, Object new) {
Object old;
register i;
register int i;
Check_Type (vec, T_Vector);
Check_Mutable (vec);
@ -70,8 +74,8 @@ Object P_Vector_Set (vec, n, new) Object vec, n, new; {
/* We cannot simply call P_List with vec->size and vec->data here,
* because the latter can change during GC.
*/
Object P_Vector_To_List (vec) Object vec; {
register i;
Object P_Vector_To_List (Object vec) {
register int i;
Object list, tail, cell;
GC_Node3;
@ -89,9 +93,9 @@ Object P_Vector_To_List (vec) Object vec; {
return list;
}
Object List_To_Vector (list, konst) Object list; {
Object List_To_Vector (Object list, int konst) {
Object vec, len;
register i;
register int i;
GC_Node;
GC_Link (list);
@ -106,12 +110,12 @@ Object List_To_Vector (list, konst) Object list; {
return vec;
}
Object P_List_To_Vector (list) Object list; {
Object P_List_To_Vector (Object list) {
return List_To_Vector (list, 0);
}
Object P_Vector_Fill (vec, fill) Object vec, fill; {
register i;
Object P_Vector_Fill (Object vec, Object fill) {
register int i;
Check_Type (vec, T_Vector);
Check_Mutable (vec);
@ -120,14 +124,14 @@ Object P_Vector_Fill (vec, fill) Object vec, fill; {
return vec;
}
Object P_Vector_Copy (vec) Object vec; {
Object P_Vector_Copy (Object vec) {
Object new;
GC_Node;
Check_Type (vec, T_Vector);
GC_Link (vec);
new = Make_Vector (VECTOR(vec)->size, Null);
bcopy ((char *)POINTER(vec), (char *)POINTER(new),
memcpy (POINTER(new), POINTER(vec),
(VECTOR(vec)->size-1) * sizeof (Object) + sizeof (struct S_Vector));
GC_Unlink;
return new;