gcl.git - GNU Common Lisp

diff --git a/gcl/h/386-macosx.h b/gcl/h/386-macosx.h
index d6447f45d..67416998c 100644
--- a/gcl/h/386-macosx.h
+++ b/gcl/h/386-macosx.h

@@ -170,7 +170,7 @@ int main(void)

#undef LISTEN_FOR_INPUT

#define LISTEN_FOR_INPUT(fp) \

do {int c=0; \

- if ((fp)->_r <=0 && (c=0, ioctl((fp)->_file, FIONREAD, &c), c<=0)) \

+ if (((FILE *)fp)->_r <=0 && (c=0, ioctl(((FILE *)fp)->_file, FIONREAD, &c), c<=0)) \

return(FALSE); \

} while (0)

@@ -196,3 +196,27 @@ if (realpath (buf, fub) == 0) { \

#else

#define RELOC_H "mach32_i386_reloc.h"

#endif

+

+#define UC(a_) ((ucontext_t *)a_)

+#define SF(a_) ((siginfo_t *)a_)

+

+#define FPE_CODE(i_,v_) make_fixnum(FFN(fSfpe_code)(*(fixnum *)&UC(v_)->uc_mcontext->__fs.__fpu_fsw,UC(v_)->uc_mcontext->__fs.__fpu_mxcsr))

+#define FPE_ADDR(i_,v_) make_fixnum(UC(v_)->uc_mcontext->__fs.__fpu_fop ? UC(v_)->uc_mcontext->__fs.__fpu_ip : (fixnum)SF(i_)->si_addr)

+#define FPE_CTXT(v_) list(3,make_fixnum((fixnum)&UC(v_)->uc_mcontext->__ss), \

+ make_fixnum((fixnum)&UC(v_)->uc_mcontext->__fs.__fpu_stmm0), \

+ make_fixnum((fixnum)&UC(v_)->uc_mcontext->__fs.__fpu_xmm0))

+

+

+#define MC(b_) v.uc_mcontext->b_

+#define REG_LIST(a_,b_) MMcons(make_fixnum(a_*sizeof(b_)),make_fixnum(sizeof(b_)))

+#define MCF(b_) ((MC(__fs)).b_)

+

+#ifdef __x86_64__

+#define FPE_RLST "RAX RBX RCX RDX RDI RSI RBP RSP R8 R9 R10 R11 R12 R13 R14 R15 RIP RFLAGS CS FS GS"

+#else

+#error Missing reg list

+#endif

+

+#define FPE_INIT ({ucontext_t v;list(3,MMcons(make_simple_string(({const char *s=FPE_RLST;s;})),REG_LIST(21,MC(__ss))), \

+ REG_LIST(8,MCF(__fpu_stmm0)),REG_LIST(16,MCF(__fpu_xmm0)));})

+

diff --git a/gcl/h/att_ext.h b/gcl/h/att_ext.h
index 8d2d46ca7..40458e08a 100755
--- a/gcl/h/att_ext.h
+++ b/gcl/h/att_ext.h

@@ -23,7 +23,6 @@ Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

#endif

/* alloc.c */

-void *alloc_page();

object alloc_object();

void *malloc(size_t);

void *realloc(void *,size_t);

diff --git a/gcl/h/compbas.h b/gcl/h/compbas.h
index f55400e22..12d55c7f1 100755
--- a/gcl/h/compbas.h
+++ b/gcl/h/compbas.h

@@ -3,3 +3,10 @@

#include <setjmp.h>

+#ifndef INLINE

+#if (defined(__GNUC__) && __GNUC__ <= 4) && !defined __clang__

+#define INLINE extern inline

+#else

+#define INLINE inline

+#endif

+#endif

diff --git a/gcl/h/error.h b/gcl/h/error.h
new file mode 100644
index 000000000..66cd3808e
--- /dev/null
+++ b/gcl/h/error.h

@@ -0,0 +1,199 @@

+#define Icall_error_handler(a_,b_,c_,d_...) \

+ Icall_gen_error_handler(Cnil,null_string,a_,b_,c_,##d_)

+#define Icall_continue_error_handler(a_,b_,c_,d_,e_...) \

+ Icall_gen_error_handler(Ct,a_,b_,c_,d_,##e_)

+

+

+extern enum type t_vtype;

+extern int vtypep_fn(object);

+extern void Check_type(object *,int (*)(object),object);

+

+#define PFN(a_) INLINE int Join(a_,_fn)(object x) {return a_(x);}

+

+PFN(integerp)

+PFN(non_negative_integerp)

+PFN(rationalp)

+PFN(floatp)

+PFN(realp)

+PFN(numberp)

+PFN(characterp)

+PFN(symbolp)

+PFN(stringp)

+PFN(string_symbolp)

+PFN(packagep)

+PFN(consp)

+PFN(listp)

+PFN(streamp)

+PFN(pathname_string_symbolp)

+PFN(pathname_string_symbol_streamp)

+PFN(randomp)

+PFN(hashtablep)

+PFN(arrayp)

+PFN(vectorp)

+PFN(readtablep)

+PFN(functionp)

+

+#define TPE(a_,b_,c_) if (!(b_)(*(a_))) FEwrong_type_argument((c_),*(a_))

+

+#define check_type(a_,b_) ({t_vtype=(b_);TPE(&a_,vtypep_fn,type_name(t_vtype));})

+#define check_type_function(a_) TPE(a_,functionp_fn,sLfunction)

+#define check_type_integer(a_) TPE(a_,integerp_fn,sLinteger)

+#define check_type_non_negative_integer(a_) TPE(a_,non_negative_integerp_fn,TSnon_negative_integer)

+#define check_type_rational(a_) TPE(a_,rationalp_fn,sLrational)

+#define check_type_float(a_) TPE(a_,floatp_fn,sLfloat)

+#define check_type_real(a_) TPE(a_,realp_fn,sLreal)

+#define check_type_or_rational_float(a_) TPE(a_,realp_fn,sLreal)

+#define check_type_number(a_) TPE(a_,numberp_fn,sLnumber)

+#define check_type_stream(a_) TPE(a_,streamp_fn,sLstream)

+#define check_type_hash_table(a_) TPE(a_,hashtablep_fn,sLhash_table)

+#define check_type_character(a_) TPE(a_,characterp_fn,sLcharacter)

+#define check_type_sym(a_) TPE(a_,symbolp_fn,sLsymbol)

+#define check_type_string(a_) TPE(a_,stringp_fn,sLstring)

+#define check_type_or_string_symbol(a_) TPE(a_,string_symbolp_fn,TSor_symbol_string)

+#define check_type_or_symbol_string(a_) TPE(a_,string_symbolp_fn,TSor_symbol_string)

+#define check_type_or_pathname_string_symbol_stream(a_) TPE(a_,pathname_string_symbol_streamp_fn,TSor_pathname_string_symbol_stream)

+#define check_type_or_Pathname_string_symbol(a_) TPE(a_,pathname_string_symbolp_fn,TSor_pathname_string_symbol)

+#define check_type_package(a_) TPE(a_,packagep_fn,sLpackage)

+#define check_type_cons(a_) TPE(a_,consp_fn,sLcons)

+#define check_type_list(a_) TPE(a_,listp_fn,sLlist)

+#define check_type_stream(a_) TPE(a_,streamp_fn,sLstream)

+#define check_type_array(a_) TPE(a_,arrayp_fn,sLarray)

+#define check_type_vector(a_) TPE(a_,vectorp_fn,sLvector)

+#define check_type_readtable_no_default(a_) TPE(a_,readtablep_fn,sLreadtable)

+#define check_type_readtable(a_) ({if (*(a_)==Cnil) *(a_)=standard_readtable;TPE(a_,readtablep_fn,sLreadtable);})

+#define check_type_random_state(a_) TPE(a_,randomp_fn,sLrandom_state)

+

+#define stack_string(a_,b_) struct string _s={0};\

+ object a_=(object)&_s;\

+ set_type_of((a_),t_string);\

+ (a_)->st.st_self=(void *)(b_);\

+ (a_)->st.st_dim=(a_)->st.st_fillp=strlen(b_)

+

+#define stack_fixnum(a_,b_) struct fixnum_struct _s={0};\

+ object a_;\

+ if (is_imm_fix(b_)) (a_)=make_fixnum(b_); else {\

+ (a_)=(object)&_s;\

+ set_type_of((a_),t_fixnum);\

+ (a_)->FIX.FIXVAL=(b_);}

+

+/*FIXME the stack stuff is dangerous It works for error handling, but

+ simple errors may evan pass the format tring up the stack as a slot

+ in ansi*/

+/* #define TYPE_ERROR(a_,b_) {stack_string(tp_err,"~S is not of type ~S.");\ */

+/* Icall_error_handler(sKwrong_type_argument,tp_err,2,(a_),(b_));} */

+

+object ihs_top_function_name(ihs_ptr h);

+#define FEerror(a_,b_...) Icall_error_handler(sLerror,null_string,\

+ 4,sKformat_control,make_simple_string(a_),sKformat_arguments,list(b_))

+#define CEerror(a_,b_,c_...) Icall_continue_error_handler(make_simple_string(a_),sLerror,null_string,\

+ 4,sKformat_control,make_simple_string(b_),sKformat_arguments,list(c_))

+

+#define TYPE_ERROR(a_,b_) Icall_error_handler(sLtype_error,null_string,\

+ 4,sKdatum,(a_),sKexpected_type,(b_))

+#define FEwrong_type_argument(a_,b_) TYPE_ERROR(b_,a_)

+#define FEcannot_coerce(a_,b_) TYPE_ERROR(b_,a_)

+#define FEinvalid_function(a_) TYPE_ERROR(a_,sLfunction)

+

+#define CONTROL_ERROR(a_) Icall_error_handler(sLcontrol_error,null_string,4,sKformat_control,make_simple_string(a_),sKformat_arguments,Cnil)

+

+#define PROGRAM_ERROR(a_,b_) Icall_error_handler(sLprogram_error,null_string,4,\

+ sKformat_control,make_simple_string(a_),sKformat_arguments,list(1,(b_)))

+#define FEtoo_few_arguments(a_,b_) \

+ Icall_error_handler(sLprogram_error,null_string,4,\

+ sKformat_control,make_simple_string("~S [or a callee] requires more than ~R argument~:p."),\

+ sKformat_arguments,list(2,ihs_top_function_name(ihs_top),make_fixnum((b_)-(a_))))

+#define FEwrong_no_args(a_,b_) \

+ Icall_error_handler(sLprogram_error,null_string,4,\

+ sKformat_control,make_simple_string(a_),\

+ sKformat_arguments,list(2,ihs_top_function_name(ihs_top),(b_)))

+#define FEtoo_few_argumentsF(a_) \

+ Icall_error_handler(sLprogram_error,null_string,4,\

+ sKformat_control,make_simple_string("Too few arguments."),\

+ sKformat_arguments,list(2,ihs_top_function_name(ihs_top),(a_)))

+

+#define FEtoo_many_arguments(a_,b_) \

+ Icall_error_handler(sLprogram_error,null_string,4,\

+ sKformat_control,make_simple_string("~S [or a callee] requires less than ~R argument~:p."),\

+ sKformat_arguments,list(2,ihs_top_function_name(ihs_top),make_fixnum((b_)-(a_))))

+#define FEtoo_many_argumentsF(a_) \

+ Icall_error_handler(sLprogram_error,null_string,4,\

+ sKformat_control,make_simple_string("Too many arguments."),\

+ sKformat_arguments,list(2,ihs_top_function_name(ihs_top),(a_)))

+#define FEinvalid_macro_call() \

+ Icall_error_handler(sLprogram_error,null_string,4,\

+ sKformat_control,make_simple_string("Invalid macro call to ~S."),\

+ sKformat_arguments,list(1,ihs_top_function_name(ihs_top)))

+#define FEunexpected_keyword(a_) \

+ Icall_error_handler(sLprogram_error,null_string,4,\

+ sKformat_control,make_simple_string("~S does not allow the keyword ~S."),\

+ sKformat_arguments,list(2,ihs_top_function_name(ihs_top),(a_)))

+#define FEinvalid_form(a_,b_) \

+ Icall_error_handler(sLprogram_error,null_string,4,\

+ sKformat_control,make_simple_string(a_),\

+ sKformat_arguments,list(1,(b_)))

+#define FEinvalid_variable(a_,b_) FEinvalid_form(a_,b_)

+

+#define PARSE_ERROR(a_) Icall_error_handler(sLparse_error,null_string,4,\

+ sKformat_control,make_simple_string(a_),sKformat_arguments,Cnil)

+#define STREAM_ERROR(a_,b_) Icall_error_handler(sLstream_error,null_string,6,\

+ sKstream,a_,\

+ sKformat_control,make_simple_string(b_),sKformat_arguments,Cnil)

+#define READER_ERROR(a_,b_) Icall_error_handler(sLreader_error,null_string,6,\

+ sKstream,a_,\

+ sKformat_control,make_simple_string(b_),sKformat_arguments,Cnil)

+#define FILE_ERROR(a_,b_) Icall_error_handler(sLfile_error,null_string,6,\

+ sKpathname,a_,\

+ sKformat_control,make_simple_string(b_),sKformat_arguments,Cnil)

+#define END_OF_FILE(a_) Icall_error_handler(sLend_of_file,null_string,2,sKstream,a_)

+#define PACKAGE_ERROR(a_,b_) Icall_error_handler(sLpackage_error,null_string,6,\

+ sKpackage,a_,\

+ sKformat_control,make_simple_string(b_),sKformat_arguments,Cnil)

+#define FEpackage_error(a_,b_) PACKAGE_ERROR(a_,b_)

+#define PACKAGE_CERROR(a_,b_,c_,d_...) \

+ Icall_continue_error_handler(make_simple_string(b_),\

+ sLpackage_error,null_string,6,\

+ sKpackage,a_,\

+ sKformat_control,make_simple_string(c_),sKformat_arguments,list(d_))

+#define NEW_INPUT(a_) (a_)=Ieval1(read_object(sLAstandard_inputA->s.s_dbind))

+

+

+#define CELL_ERROR(a_,b_) Icall_error_handler(sLcell_error,null_string,6,\

+ sKname,a_,\

+ sKformat_control,make_simple_string(b_),sKformat_arguments,Cnil)

+#define UNBOUND_VARIABLE(a_) Icall_error_handler(sLunbound_variable,null_string,2,sKname,a_)

+#define FEunbound_variable(a_) UNBOUND_VARIABLE(a_)

+

+#define UNBOUND_SLOT(a_,b_) Icall_error_handler(sLunbound_slot,null_string,4,sKname,a_,sKinstance,b_)

+#define UNDEFINED_FUNCTION(a_) Icall_error_handler(sLundefined_function,null_string,2,sKname,a_)

+#define FEundefined_function(a_) UNDEFINED_FUNCTION(a_)

+

+#define ARITHMETIC_ERROR(a_,b_) Icall_error_handler(sLarithmetic_error,null_string,4,sKoperation,a_,sKoperands,b_)

+#define DIVISION_BY_ZERO(a_,b_) Icall_error_handler(sLdivision_by_zero,null_string,4,sKoperation,a_,sKoperands,b_)

+#define FLOATING_POINT_OVERFLOW(a_,b_) Icall_error_handler(sLfloating_point_overflow,null_string,4,sKoperation,a_,sKoperands,b_)

+#define FLOATING_POINT_UNDERFLOW(a_,b_) Icall_error_handler(sLfloating_point_underflow,null_string,4,sKoperation,a_,sKoperands,b_)

+#define FLOATING_POINT_INEXACT(a_,b_) Icall_error_handler(sLfloating_point_inexact,null_string,4,sKoperation,a_,sKoperands,b_)

+#define FLOATING_POINT_INVALID_OPERATION(a_,b_) Icall_error_handler(sLfloating_point_invalid_operation,null_string,4,sKoperation,a_,sKoperands,b_)

+

+#define PATHNAME_ERROR(a_,b_,c_...) Icall_error_handler(sLfile_error,null_string,6,\

+ sKpathname,(a_),\

+ sKformat_control,make_simple_string(b_),\

+ sKformat_arguments,list(c_))

+#define WILD_PATH(a_) ({object _a=(a_);PATHNAME_ERROR(_a,"File ~s is wild",1,_a);})

+

+

+#define NERROR(a_) ({object fmt=make_simple_string(a_ ": line ~a, file ~a, function ~a");\

+ {object line=make_fixnum(__LINE__);\

+ {object file=make_simple_string(__FILE__);\

+ {object function=make_simple_string(__FUNCTION__);\

+ Icall_error_handler(sKerror,fmt,3,line,file,function);}}}})

+

+#define ASSERT(a_) do {if (!(a_)) NERROR("The assertion " #a_ " failed");} while (0)

+

+#define gcl_abort() ({\

+ frame_ptr fr=frs_sch_catch(sSPtop_abort_tagP->s.s_dbind);\

+ vs_base[0]=sSPtop_abort_tagP->s.s_dbind;\

+ vs_top=vs_base+1;\

+ if (fr) unwind(fr,sSPtop_abort_tagP->s.s_dbind);\

+ abort();\

+ })

+

diff --git a/gcl/h/fixnum.h b/gcl/h/fixnum.h
index 091c3c485..9f08d1582 100644
--- a/gcl/h/fixnum.h
+++ b/gcl/h/fixnum.h

@@ -13,7 +13,7 @@

#define is_imm_fix(a_) INT_IN_BITS(a_,LOW_SHFT-1)

#elif defined (IM_FIX_BASE) && defined(IM_FIX_LIM)

#define make_imm_fixnum(a_) ((object)((a_)+(IM_FIX_BASE+(IM_FIX_LIM>>1))))

-#define fix_imm_fixnum(a_) (((fixnum)(a_))-(IM_FIX_BASE+(IM_FIX_LIM>>1)))

+#define fix_imm_fixnum(a_) ((fixnum)(((fixnum)(a_))-(IM_FIX_BASE+(IM_FIX_LIM>>1))))

#define mark_imm_fixnum(a_) ((a_)=((object)(((fixnum)(a_)) | IM_FIX_LIM)))

#define unmark_imm_fixnum(a_) ((a_)=((object)(((fixnum)(a_)) &~ IM_FIX_LIM)))

#define is_imm_fixnum(a_) (((ufixnum)(a_))>=IM_FIX_BASE)

diff --git a/gcl/h/gmp_wrappers.h b/gcl/h/gmp_wrappers.h
index 6fb8db98b..6de28b6b8 100644
--- a/gcl/h/gmp_wrappers.h
+++ b/gcl/h/gmp_wrappers.h

@@ -1,12 +1,5 @@

-#ifndef GMP_EXTERN

-#define GMP_EXTERN extern

-#endif

-#ifndef GMP_EXTERN_INLINE

-#define GMP_EXTERN_INLINE GMP_EXTERN __inline__

-#endif

-

-GMP_EXTERN jmp_buf gmp_jmp;

-GMP_EXTERN int jmp_gmp,gmp_relocatable;

+EXTER jmp_buf gmp_jmp;

+EXTER int jmp_gmp,gmp_relocatable;

#define join(a_,b_) a_ ## b_

#define Join(a_,b_) join(a_,b_)

@@ -179,7 +172,7 @@ GMP_EXTERN int jmp_gmp,gmp_relocatable;

set to -1 otherwise. 20040815 CM*/

#define MEM_GMP_CALL(n_,rt_,a_,s_,b_...) \

- GMP_EXTERN_INLINE Join(RF_,rt_) Join(m,a_)(Join(P,n_)(b_)) { \

+ INLINE Join(RF_,rt_) Join(m,a_)(Join(P,n_)(b_)) { \

int j;\

Join(RD_,rt_);\

if (gmp_relocatable) {\

diff --git a/gcl/h/immnum.h b/gcl/h/immnum.h
index 0a7034f85..dd89cb7c9 100644
--- a/gcl/h/immnum.h
+++ b/gcl/h/immnum.h

@@ -19,10 +19,10 @@

#define iif2(x,y) is_imm_fixnum2(x,y)

-EXTER inline fixnum

+INLINE fixnum

lnabs(fixnum x) {return x<0 ? ~x : x;}

-EXTER inline char

+INLINE char

clz(ufixnum x) {

#ifdef HAVE_CLZL

return x ? __builtin_clzl(x) : sizeof(x)*8;

@@ -31,7 +31,7 @@ clz(ufixnum x) {

#endif

}

-EXTER inline char

+INLINE char

ctz(ufixnum x) {

#ifdef HAVE_CTZL

return __builtin_ctzl(x);/*x ? __builtin_clzl(x) : sizeof(x)*8;*/

@@ -40,11 +40,11 @@ ctz(ufixnum x) {

#endif

}

-EXTER inline char

+INLINE char

fixnum_length(fixnum x) {return sizeof(x)*8-clz(lnabs(x));}

-EXTER inline object

-immnum_length(object x) {return iif(x) ? mif(fixnum_length(fif(x))) : integer_length(x);}

+INLINE object

+immnum_length(object x) {return iif(x) ? mif((fixnum)fixnum_length(fif(x))) : integer_length(x);}

#if SIZEOF_LONG == 8

@@ -59,7 +59,7 @@ immnum_length(object x) {return iif(x) ? mif(fixnum_length(fif(x))) : integer_le

#define POPD 0x3F

#endif

-EXTER inline char

+INLINE char

fixnum_popcount(ufixnum x) {

x-=POPA&(x>>1);

x=(x&POPB)+((x>>2)&POPB);

@@ -72,34 +72,34 @@ fixnum_popcount(ufixnum x) {

return x&POPD;

}

-EXTER inline char

+INLINE char

/* fixnum_count(fixnum x) {return __builtin_popcountl(lnabs(x));} */

fixnum_count(fixnum x) {return fixnum_popcount(lnabs(x));}

-EXTER inline object

-immnum_count(object x) {return iif(x) ? mif(fixnum_count(fif(x))) : integer_count(x);}

+INLINE object

+immnum_count(object x) {return iif(x) ? mif((fixnum)fixnum_count(fif(x))) : integer_count(x);}

/*bs=sizeof(long)*8;

lb=bs-clz(labs(x));|x*y|=|x|*|y|<2^(lbx+lby)<2^(bs-1);

0 bounded by 2^0, +-1 by 2^1,mpf by 2^(bs-1), which is sign bit

protect labs from most negative fix, here all immfix ok*/

long int labs(long int j);

-EXTER inline bool

+INLINE bool

fixnum_mul_safe_abs(fixnum x,fixnum y) {return clz(x)+clz(y)>sizeof(x)*8+1;}

-EXTER inline object

+INLINE object

safe_mul_abs(fixnum x,fixnum y) {return fixnum_mul_safe_abs(x,y) ? make_fixnum(x*y) : fixnum_times(x,y);}

-EXTER inline bool

+INLINE bool

fixnum_mul_safe(fixnum x,fixnum y) {return fixnum_mul_safe_abs(labs(x),labs(y));}

-EXTER inline object

+INLINE object

safe_mul(fixnum x,fixnum y) {return fixnum_mul_safe(x,y) ? make_fixnum(x*y) : fixnum_times(x,y);}

-EXTER inline object

+INLINE object

immnum_times(object x,object y) {return iif2(x,y) ? safe_mul(fif(x),fif(y)) : number_times(x,y);}

-EXTER inline object

+INLINE object

immnum_plus(object x,object y) {return iif2(x,y) ? make_fixnum(fif(x)+fif(y)) : number_plus(x,y);}

-EXTER inline object

+INLINE object

immnum_minus(object x,object y) {return iif2(x,y) ? make_fixnum(fif(x)-fif(y)) : number_minus(x,y);}

-EXTER inline object

+INLINE object

immnum_negate(object x) {return iif(x) ? make_fixnum(-fif(x)) : number_negate(x);}

#define BOOLCLR 0

@@ -119,7 +119,7 @@ immnum_negate(object x) {return iif(x) ? make_fixnum(-fif(x)) : number_negate(x)

#define BOOLORC1 015

#define BOOLORC2 013

-EXTER inline fixnum

+INLINE fixnum

fixnum_boole(fixnum op,fixnum x,fixnum y) {

switch(op) {

case BOOLCLR: return 0;

@@ -142,7 +142,7 @@ fixnum_boole(fixnum op,fixnum x,fixnum y) {

return 0;/*FIXME error*/

}

-EXTER inline object

+INLINE object

immnum_boole(fixnum o,object x,object y) {return iif2(x,y) ? mif(fixnum_boole(o,fif(x),fif(y))) : log_op2(o,x,y);}

#define immnum_bool(o,x,y) immnum_boole(fixint(o),x,y)

@@ -159,93 +159,93 @@ immnum_boole(fixnum o,object x,object y) {return iif2(x,y) ? mif(fixnum_boole(o,

#define immnum_orc1(x,y) immnum_boole(BOOLORC1,x,y)

#define immnum_orc2(x,y) immnum_boole(BOOLORC2,x,y)

-EXTER inline fixnum

+INLINE fixnum

fixnum_div(fixnum x,fixnum y,fixnum d) {

fixnum z=x/y;

if (d && x!=y*z && (x*d>0 ? y>0 : y<0))

z+=d;

return z;

}

-EXTER inline fixnum

+INLINE fixnum

fixnum_rem(fixnum x,fixnum y,fixnum d) {

fixnum z=x%y;

if (d && z && (x*d>0 ? y>0 : y<0))

z+=y;

return z;

}

-EXTER inline object

+INLINE object

immnum_truncate(object x,object y) {return iif2(x,y)&&y!=make_fixnum(0) ? mif(fixnum_div(fif(x),fif(y),0)) : (intdivrem(x,y,0,&x,0),x);}

-EXTER inline object

+INLINE object

immnum_floor(object x,object y) {return iif2(x,y)&&y!=make_fixnum(0) ? mif(fixnum_div(fif(x),fif(y),-1)) : (intdivrem(x,y,-1,&x,0),x);}

-EXTER inline object

+INLINE object

immnum_ceiling(object x,object y) {return iif2(x,y)&&y!=make_fixnum(0) ? mif(fixnum_div(fif(x),fif(y),1)) : (intdivrem(x,y,1,&x,0),x);}

-EXTER inline object

+INLINE object

immnum_mod(object x,object y) {return iif2(x,y)&&y!=make_fixnum(0) ? mif(fixnum_rem(fif(x),fif(y),-1)) : (intdivrem(x,y,-1,0,&y),y);}

-EXTER inline object

+INLINE object

immnum_rem(object x,object y) {return iif2(x,y)&&y!=make_fixnum(0) ? mif(fixnum_rem(fif(x),fif(y),0)) : (intdivrem(x,y,0,0,&y),y);}

-EXTER inline fixnum

+INLINE fixnum

fixnum_rshft(fixnum x,fixnum y) {

return y>=sizeof(x)*8 ? (x<0 ? -1 : 0) : x>>y;

}

-EXTER inline object

+INLINE object

fixnum_lshft(fixnum x,fixnum y) {

return clz(labs(x))>y ? make_fixnum(x<<y) : (x ? fixnum_big_shift(x,y) : make_fixnum(0));

}

-EXTER inline object

+INLINE object

fixnum_shft(fixnum x,fixnum y) {

return y<0 ? make_fixnum(fixnum_rshft(x,-y)) : fixnum_lshft(x,y);

}

-EXTER inline object

+INLINE object

immnum_shft(object x,object y) {return iif2(x,y) ? fixnum_shft(fif(x),fif(y)) : integer_shift(x,y);}

-EXTER inline bool

+INLINE bool

fixnum_bitp(fixnum p,fixnum x) {return fixnum_rshft(x,p)&0x1;}

-EXTER inline bool

+INLINE bool

immnum_bitp(object x,object y) {return iif2(x,y) ? fixnum_bitp(fif(x),fif(y)) : integer_bitp(x,y);}

#define immnum_comp(x,y,c) iif2(x,y) ? (x c y) : (number_compare(x,y) c 0)

-EXTER inline bool

+INLINE bool

immnum_lt(object x,object y) {return immnum_comp(x,y,<);}

-EXTER inline bool

+INLINE bool

immnum_le(object x,object y) {return immnum_comp(x,y,<=);}

-EXTER inline bool

+INLINE bool

immnum_eq(object x,object y) {return immnum_comp(x,y,==);}

-EXTER inline bool

+INLINE bool

immnum_ne(object x,object y) {return immnum_comp(x,y,!=);}

-EXTER inline bool

+INLINE bool

immnum_gt(object x,object y) {return immnum_comp(x,y,>);}

-EXTER inline bool

+INLINE bool

immnum_ge(object x,object y) {return immnum_comp(x,y,>=);}

-EXTER inline bool

+INLINE bool

immnum_minusp(object x) {return iif(x) ? ((ufixnum)x)<((ufixnum)make_fixnum(0)) : number_minusp(x);}

-EXTER inline bool

+INLINE bool

immnum_plusp(object x) {return iif(x) ? ((ufixnum)x)>((ufixnum)make_fixnum(0)) : number_plusp(x);}

-EXTER inline bool

+INLINE bool

immnum_zerop(object x) {return iif(x) ? ((ufixnum)x)==((ufixnum)make_fixnum(0)) : number_zerop(x);}

-EXTER inline bool

+INLINE bool

immnum_evenp(object x) {return iif(x) ? !(((ufixnum)x)&0x1) : number_evenp(x);}

-EXTER inline bool

+INLINE bool

immnum_oddp(object x) {return iif(x) ? (((ufixnum)x)&0x1) : number_oddp(x);}

-EXTER inline object

+INLINE object

immnum_signum(object x) {

ufixnum ux=(ufixnum)x,uz=((ufixnum)make_fixnum(0));

return iif(x) ? (ux<uz ? mif(-1) : (ux==uz ? mif(0) : mif(1))) : number_signum(x);

}

-EXTER inline object

+INLINE object

immnum_abs(object x) {return iif(x) ? make_fixnum(labs(fif(x))) : number_abs(x);}

-EXTER inline fixnum

+INLINE fixnum

fixnum_ldb(fixnum s,fixnum p,fixnum i) {

return ((1UL<<s)-1)&fixnum_rshft(i,p);

}

-EXTER inline object

+INLINE object

immnum_ldb(object x,object i) {

if (iif(i))

if (consp(x)) {

@@ -259,7 +259,7 @@ immnum_ldb(object x,object i) {

return number_ldb(x,i);

}

-EXTER inline bool

+INLINE bool

immnum_ldbt(object x,object i) {

if (iif(i))

if (consp(x)) {

@@ -273,13 +273,13 @@ immnum_ldbt(object x,object i) {

return number_ldbt(x,i)!=Cnil;

}

-EXTER inline fixnum

+INLINE fixnum

fixnum_dpb(fixnum s,fixnum p,fixnum n,fixnum i) {

fixnum z=(1UL<<s)-1;

return (i&~(z<<p))|((n&z)<<p);

}

-EXTER inline object

+INLINE object

immnum_dpb(object n,object x,object i) {

if (iif2(n,i))

if (consp(x)) {

@@ -293,13 +293,13 @@ immnum_dpb(object n,object x,object i) {

return number_dpb(n,x,i);

}

-EXTER inline fixnum

+INLINE fixnum

fixnum_dpf(fixnum s,fixnum p,fixnum n,fixnum i) {

fixnum z=((1UL<<s)-1)<<p;

return (i&~z)|(n&z);

}

-EXTER inline object

+INLINE object

immnum_dpf(object n,object x,object i) {

if (iif2(n,i))

if (consp(x)) {

@@ -313,15 +313,15 @@ immnum_dpf(object n,object x,object i) {

return number_dpf(n,x,i);

}

-EXTER inline object

+INLINE object

immnum_max(object x,object y) {return iif2(x,y) ? ((ufixnum)x>=(ufixnum)y ? x : y) : (number_compare(x,y)>=0?x:y);}

-EXTER inline object

+INLINE object

immnum_min(object x,object y) {return iif2(x,y) ? ((ufixnum)x<=(ufixnum)y ? x : y) : (number_compare(x,y)<=0?x:y);}

-EXTER inline bool

+INLINE bool

immnum_logt(object x,object y) {return iif2(x,y) ? fixnum_boole(BOOLAND,fif(x),fif(y))!=0 : !number_zerop(log_op2(BOOLAND,x,y));}

-EXTER inline fixnum

+INLINE fixnum

fixnum_gcd(fixnum x,fixnum y) {

fixnum t;

@@ -346,16 +346,16 @@ fixnum_gcd(fixnum x,fixnum y) {

}

-EXTER inline object

+INLINE object

immnum_gcd(object x,object y) {return iif2(x,y) ? mif(fixnum_gcd(labs(fif(x)),labs(fif(y)))) : get_gcd(x,y);}

-EXTER inline object

+INLINE object

fixnum_lcm(fixnum x,fixnum y) {

fixnum g=fixnum_gcd(x,y);

return g ? safe_mul_abs(x,fixnum_div(y,g,0)) : make_fixnum(0);

}

-EXTER inline object

+INLINE object

immnum_lcm(object x,object y) {return iif2(x,y) ? fixnum_lcm(labs(fif(x)),labs(fif(y))) : get_lcm(x,y);}

#endif

diff --git a/gcl/h/pool.h b/gcl/h/pool.h
new file mode 100644
index 000000000..05434cecb
--- /dev/null
+++ b/gcl/h/pool.h

@@ -0,0 +1,170 @@

+static ufixnum

+data_pages(void) {

+

+ return page(2*(rb_end-rb_start)+((void *)heap_end-data_start));

+

+}

+

+#ifndef NO_FILE_LOCKING

+

+#include <sys/types.h>

+#include <sys/stat.h>

+#include <fcntl.h>

+#include <sys/mman.h>

+#include <errno.h>

+

+static int pool=-1;

+static struct pool {

+ ufixnum pid;

+ ufixnum n;

+ ufixnum s;

+} *Pool;

+

+static struct flock pl;

+

+static const char *gcl_pool="/tmp/gcl_pool";

+

+static int

+set_lock(void) {

+

+ errno=0;

+ if (fcntl(pool,F_SETLKW,&pl)) {

+ if (errno==EINTR)

+ set_lock();

+ return -1;

+ }

+ return 0;

+

+}

+

+static void

+lock_pool(void) {

+

+ pl.l_type=F_WRLCK;

+ massert(!set_lock());

+

+}

+

+static void

+unlock_pool(void) {

+

+ pl.l_type=F_UNLCK;

+ massert(!set_lock());

+

+}

+

+static void

+register_pool(int s) {

+ lock_pool();

+ Pool->n+=s;

+ Pool->s+=s*data_pages();

+ unlock_pool();

+}

+

+static void

+open_pool(void) {

+

+ if (pool==-1) {

+

+ struct flock f;

+

+ massert((pool=open(gcl_pool,O_CREAT|O_RDWR,0644))!=-1);

+ massert(!ftruncate(pool,sizeof(struct pool)));

+ massert((Pool=mmap(NULL,sizeof(struct pool),PROT_READ|PROT_WRITE,MAP_SHARED,pool,0))!=(void *)-1);

+

+ pl.l_type=F_WRLCK;

+ pl.l_whence=SEEK_SET;

+ pl.l_start=sizeof(Pool->pid);;

+ pl.l_len=0;

+

+ f=pl;

+ f.l_start=0;

+ f.l_len=sizeof(Pool->pid);

+

+ if (!fcntl(pool,F_SETLK,&f)) {

+

+ Pool->pid=getpid();

+

+ lock_pool();

+ Pool->n=0;

+ Pool->s=0;

+ unlock_pool();

+

+ f.l_type=F_UNLCK;

+ massert(!fcntl(pool,F_SETLK,&f));

+

+ fprintf(stderr,"Initializing pool\n");

+ fflush(stderr);

+

+ }

+

+ f.l_type=F_RDLCK;

+ massert(!fcntl(pool,F_SETLK,&f));

+

+ register_pool(1);

+ massert(!atexit(close_pool));

+

+ }

+

+}

+#endif

+

+void

+close_pool(void) {

+

+#ifndef NO_FILE_LOCKING

+ if (pool!=-1) {

+ register_pool(-1);

+ massert(!close(pool));

+ massert(!munmap(Pool,sizeof(struct pool)));

+ pool=-1;

+ }

+#endif

+

+}

+

+static void

+update_pool(fixnum val) {

+

+#ifndef NO_FILE_LOCKING

+ if (multiprocess_memory_pool) {

+ open_pool();

+ lock_pool();

+ Pool->s+=val;

+ unlock_pool();

+ }

+#endif

+

+}

+

+static ufixnum

+get_pool(void) {

+

+ ufixnum s;

+

+#ifndef NO_FILE_LOCKING

+ if (multiprocess_memory_pool) {

+

+ open_pool();

+ lock_pool();

+ s=Pool->s;

+ unlock_pool();

+

+ } else

+#endif

+

+ s=data_pages();

+

+ return s;

+

+}

+

+

+static void

+pool_check(void) {

+

+ /* if (pool!=-1) */

+ /* massert(get_pool()==data_pages() */

+ /* ||!fprintf(stderr,"%lu %lu %lu\n",get_pool(),page((void *)heap_end-data_start),page(((rb_end-rb_start))))); */

+

+}

diff --git a/gcl/h/prelink.h b/gcl/h/prelink.h
new file mode 100644
index 000000000..0e2949493
--- /dev/null
+++ b/gcl/h/prelink.h

@@ -0,0 +1,33 @@

+/* prelink support for gcl images:

+ if GCL references variables (as opposed to functions) defined in

+ external shared libraries, ld will place COPY relocations in

+ .rela.dyn pointing to a location in .bss for these references.

+ Unexec will later incorporate this into a second .data section,

+ causing prelink to fail. While one might prelink the raw images,

+ which would then be inherited by the saved images, this is not

+ convenient as part of the build process, so here we isolate the

+ problematic references and compile as position independent code,

+ changing the COPY reloc to some form of GOT.

+ */

+#ifdef NO_PRELINK_UNEXEC_DIVERSION

+#define PRELINK_EXTER

+#else

+#define PRELINK_EXTER extern

+

+#undef stdin

+#define stdin my_stdin

+#undef stdout

+#define stdout my_stdout

+#undef stderr

+#define stderr my_stderr

+

+#endif

+

+PRELINK_EXTER FILE *my_stdin;

+PRELINK_EXTER FILE *my_stdout;

+PRELINK_EXTER FILE *my_stderr;

+

+#ifdef HAVE_READLINE

+PRELINK_EXTER rl_compentry_func_t **my_rl_completion_entry_function_ptr;

+PRELINK_EXTER const char **my_rl_readline_name_ptr;

+#endif

diff --git a/gcl/h/protoize.h b/gcl/h/protoize.h
index c1dc05083..5925612ab 100644
--- a/gcl/h/protoize.h
+++ b/gcl/h/protoize.h

@@ -1,9 +1,9 @@

/* alloc.c:89:OF */ extern void *alloc_page (long n); /* (n) int n; */

-/* alloc.c:149:OF */ inline void add_page_to_freelist (char *p, struct typemanager *tm); /* (p, tm) char *p; struct typemanager *tm; */

+/* alloc.c:149:OF */ void add_page_to_freelist (char *p, struct typemanager *tm); /* (p, tm) char *p; struct typemanager *tm; */

/* alloc.c:196:OF */ extern object type_name (int t); /* (t) int t; */

-/* alloc.c:213:OF */ inline object alloc_object (enum type t); /* (t) enum type t; */

-/* alloc.c:213:OF */ inline void add_pages(struct typemanager *,fixnum);

-/* alloc.c:296:OF */ extern inline object make_cons (object a, object d); /* (a, d) object a; object d; */

+/* alloc.c:213:OF */ object alloc_object (enum type t); /* (t) enum type t; */

+/* alloc.c:213:OF */ void add_pages(struct typemanager *,fixnum);

+/* alloc.c:296:OF */ extern object make_cons (object a, object d); /* (a, d) object a; object d; */

/* alloc.c:364:OF */ extern object on_stack_cons (object x, object y); /* (x, y) object x; object y; */

/* alloc.c:480:OF */ extern void insert_contblock (char *p, int s); /* (p, s) char *p; int s; */

/* alloc.c:480:OF */ extern void insert_maybe_sgc_contblock (char *p, int s); /* (p, s) char *p; int s; */

@@ -1466,27 +1466,27 @@ fixnum elt_size(fixnum);

void init_gmp_rnd_state(__gmp_randstate_struct *);

-inline void set_sgc_bit(struct pageinfo *,void *);

+/* void set_sgc_bit(struct pageinfo *,void *); */

void reinit_gmp(void);

object mod(object,object);

-inline void intdivrem(object,object,fixnum,object *,object *);

+void intdivrem(object,object,fixnum,object *,object *);

-inline object integer_count(object);

+object integer_count(object);

-inline object integer_length(object);

+object integer_length(object);

-inline bool integer_bitp(object,object);

+bool integer_bitp(object,object);

-inline object fixnum_times(fixnum,fixnum);

+object fixnum_times(fixnum,fixnum);

-inline object log_op2(fixnum,object,object);

+object log_op2(fixnum,object,object);

-inline object fixnum_big_shift(fixnum,fixnum);

+object fixnum_big_shift(fixnum,fixnum);

-inline object integer_shift(object,object);

+object integer_shift(object,object);

object number_abs(object);

diff --git a/gcl/h/writable.h b/gcl/h/writable.h
index 42c68996b..0497e5b80 100644
--- a/gcl/h/writable.h
+++ b/gcl/h/writable.h

@@ -1,4 +1,4 @@

-EXTER inline int

+INLINE int

set_writable(fixnum i,fixnum m) {

fixnum j;

@@ -27,7 +27,7 @@ set_writable(fixnum i,fixnum m) {

}

-EXTER inline int

+INLINE int

is_writable(fixnum i) {

fixnum j;