--- cvsroot/microscheme/scheme.c 2015/11/26 23:26:00 1.22 +++ cvsroot/microscheme/scheme.c 2015/11/27 02:06:36 1.23 @@ -30,6 +30,8 @@ # include #endif +#include "ecb.h" + #include #include #include @@ -67,16 +69,6 @@ #define S_SINK (&SCHEME_V->xsink) #define S_EOF (&SCHEME_V->xEOF_OBJ) -/* should use libecb */ -#if __GNUC__ >= 4 -# define ecb_expect(expr,value) __builtin_expect ((expr),(value)) -# define ecb_expect_false(expr) ecb_expect (!!(expr), 0) -# define ecb_expect_true(expr) ecb_expect (!!(expr), 1) -#else -# define ecb_expect_false(expr) !!(expr) -# define ecb_expect_true(expr) !!(expr) -#endif - #if !USE_MULTIPLICITY static scheme sc; #endif @@ -155,9 +147,9 @@ #define tolower(c) xtolower (c) #define isdigit(c) xisdigit (c) -#if USE_STRLWR +#if USE_IGNORECASE static const char * -strlwr (char *s) +xstrlwr (char *s) { const char *p = s; @@ -169,10 +161,14 @@ return p; } -#endif -#define stricmp(a,b) strcmp (a, b) -#define strlwr(s) (s) +#define stricmp(a,b) strcasecmp (a, b) +#define strlwr(s) xstrlwr (s) + +#else +# define stricmp(a,b) strcmp (a, b) +# define strlwr(s) (s) +#endif #ifndef prompt # define prompt "ts> " @@ -225,7 +221,7 @@ #endif static int is_zero_rvalue (RVALUE x); -static INLINE int +ecb_inline int num_is_integer (pointer p) { return num_is_fixnum (p->object.number); @@ -239,7 +235,7 @@ #define set_typeflag(p,v) ((p)->flag = (v)) #define type(p) (typeflag (p) & T_MASKTYPE) -INTERFACE INLINE int +INTERFACE int is_string (pointer p) { return type (p) == T_STRING; @@ -250,7 +246,7 @@ INTERFACE int is_list (SCHEME_P_ pointer p); -INTERFACE INLINE int +INTERFACE int is_vector (pointer p) { return type (p) == T_VECTOR; @@ -269,13 +265,13 @@ return vec->object.vector.length; } -INTERFACE INLINE int +INTERFACE int is_number (pointer p) { return type (p) == T_NUMBER; } -INTERFACE INLINE int +INTERFACE int is_integer (pointer p) { if (!is_number (p)) @@ -287,25 +283,25 @@ return 0; } -INTERFACE INLINE int +INTERFACE int is_real (pointer p) { return is_number (p) && !num_is_fixnum (p->object.number); } -INTERFACE INLINE int +INTERFACE int is_character (pointer p) { return type (p) == T_CHARACTER; } -INTERFACE INLINE char * +INTERFACE char * string_value (pointer p) { return strvalue (p); } -INLINE num +ecb_inline num nvalue (pointer p) { return (p)->object.number; @@ -345,31 +341,32 @@ # define set_num_integer(p) 0 # define set_num_real(p) 0 #endif + INTERFACE long charvalue (pointer p) { return ivalue_unchecked (p); } -INTERFACE INLINE int +INTERFACE int is_port (pointer p) { return type (p) == T_PORT; } -INTERFACE INLINE int +INTERFACE int is_inport (pointer p) { return is_port (p) && p->object.port->kind & port_input; } -INTERFACE INLINE int +INTERFACE int is_outport (pointer p) { return is_port (p) && p->object.port->kind & port_output; } -INTERFACE INLINE int +INTERFACE int is_pair (pointer p) { return type (p) == T_PAIR; @@ -411,20 +408,20 @@ return cdr (p); } -INTERFACE INLINE int +INTERFACE int is_symbol (pointer p) { return type (p) == T_SYMBOL; } -INTERFACE INLINE char * +INTERFACE char * symname (pointer p) { return strvalue (car (p)); } #if USE_PLIST -SCHEME_EXPORT INLINE int +SCHEME_EXPORT int hasprop (pointer p) { return typeflag (p) & T_SYMBOL; @@ -433,25 +430,25 @@ # define symprop(p) cdr(p) #endif -INTERFACE INLINE int +INTERFACE int is_syntax (pointer p) { return typeflag (p) & T_SYNTAX; } -INTERFACE INLINE int +INTERFACE int is_proc (pointer p) { return type (p) == T_PROC; } -INTERFACE INLINE int +INTERFACE int is_foreign (pointer p) { return type (p) == T_FOREIGN; } -INTERFACE INLINE char * +INTERFACE char * syntaxname (pointer p) { return strvalue (car (p)); @@ -460,31 +457,31 @@ #define procnum(p) ivalue (p) static const char *procname (pointer x); -INTERFACE INLINE int +INTERFACE int is_closure (pointer p) { return type (p) == T_CLOSURE; } -INTERFACE INLINE int +INTERFACE int is_macro (pointer p) { return type (p) == T_MACRO; } -INTERFACE INLINE pointer +INTERFACE pointer closure_code (pointer p) { return car (p); } -INTERFACE INLINE pointer +INTERFACE pointer closure_env (pointer p) { return cdr (p); } -INTERFACE INLINE int +INTERFACE int is_continuation (pointer p) { return type (p) == T_CONTINUATION; @@ -494,13 +491,13 @@ #define set_cont_dump(p,v) set_cdr ((p), (v)) /* To do: promise should be forced ONCE only */ -INTERFACE INLINE int +INTERFACE int is_promise (pointer p) { return type (p) == T_PROMISE; } -INTERFACE INLINE int +INTERFACE int is_environment (pointer p) { return type (p) == T_ENVIRONMENT; @@ -516,13 +513,13 @@ #define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) #define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) -INTERFACE INLINE int +INTERFACE int is_immutable (pointer p) { return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; } -INTERFACE INLINE void +INTERFACE void setimmutable (pointer p) { #if USE_ERROR_CHECKING @@ -531,31 +528,31 @@ } #if USE_CHAR_CLASSIFIERS -static INLINE int +ecb_inline int Cisalpha (int c) { return isascii (c) && isalpha (c); } -static INLINE int +ecb_inline int Cisdigit (int c) { return isascii (c) && isdigit (c); } -static INLINE int +ecb_inline int Cisspace (int c) { return isascii (c) && isspace (c); } -static INLINE int +ecb_inline int Cisupper (int c) { return isascii (c) && isupper (c); } -static INLINE int +ecb_inline int Cislower (int c) { return isascii (c) && islower (c); @@ -626,9 +623,9 @@ static int file_push (SCHEME_P_ const char *fname); static void file_pop (SCHEME_P); static int file_interactive (SCHEME_P); -static INLINE int is_one_of (char *s, int c); +ecb_inline int is_one_of (char *s, int c); static int alloc_cellseg (SCHEME_P_ int n); -static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b); +ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); static void finalize_cell (SCHEME_P_ pointer a); static int count_consecutive_cells (pointer x, int needed); static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); @@ -655,7 +652,7 @@ static void backchar (SCHEME_P_ int c); static char *readstr_upto (SCHEME_P_ char *delim); static pointer readstrexp (SCHEME_P); -static INLINE int skipspace (SCHEME_P); +ecb_inline int skipspace (SCHEME_P); static int token (SCHEME_P); static void printslashstring (SCHEME_P_ char *s, int len); static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); @@ -783,7 +780,7 @@ return ret; } -/* this completely disrespects NaNs */ +/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */ static int num_cmp (num a, num b) { @@ -836,11 +833,14 @@ static int is_zero_rvalue (RVALUE x) { + return x == 0; +#if 0 #if USE_REAL return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */ #else return x == 0; #endif +#endif } /* allocate new cell segment */ @@ -921,7 +921,7 @@ } /* get new cell. parameter a, b is marked by gc. */ -static INLINE pointer +ecb_inline pointer get_cell_x (SCHEME_P_ pointer a, pointer b) { if (ecb_expect_false (SCHEME_V->free_cell == NIL)) @@ -1009,7 +1009,7 @@ return v; } -static INLINE void +ecb_inline void ok_to_freely_gc (SCHEME_P) { set_car (S_SINK, NIL); @@ -1083,7 +1083,7 @@ return x; } -static INLINE pointer +ecb_inline pointer oblist_find_by_name (SCHEME_P_ const char *name) { int location; @@ -1126,7 +1126,7 @@ return NIL; } -static INLINE pointer +ecb_inline pointer oblist_find_by_name (SCHEME_P_ const char *name) { pointer x; @@ -2234,7 +2234,7 @@ } /* check c is in chars */ -static INLINE int +ecb_inline int is_one_of (char *s, int c) { if (c == EOF) @@ -2244,7 +2244,7 @@ } /* skip white characters */ -static INLINE int +ecb_inline int skipspace (SCHEME_P) { int c, curr_line = 0; @@ -2825,7 +2825,7 @@ setenvironment (SCHEME_V->envir); } -static INLINE void +ecb_inline void new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) { pointer slot = immutable_cons (variable, value); @@ -2875,14 +2875,14 @@ #else /* USE_ALIST_ENV */ -static INLINE void +ecb_inline void new_frame_in_env (SCHEME_P_ pointer old_env) { SCHEME_V->envir = immutable_cons (NIL, old_env); setenvironment (SCHEME_V->envir); } -static INLINE void +ecb_inline void new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) { set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); @@ -2914,19 +2914,19 @@ #endif /* USE_ALIST_ENV else */ -static INLINE void +ecb_inline void new_slot_in_env (SCHEME_P_ pointer variable, pointer value) { new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); } -static INLINE void +ecb_inline void set_slot_in_env (SCHEME_P_ pointer slot, pointer value) { set_cdr (slot, value); } -static INLINE pointer +ecb_inline pointer slot_value_in_env (pointer slot) { return cdr (slot); @@ -3064,14 +3064,14 @@ return 0; } -static INLINE void +ecb_inline void dump_stack_reset (SCHEME_P) { /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ SCHEME_V->dump = (pointer)+0; } -static INLINE void +ecb_inline void dump_stack_initialize (SCHEME_P) { SCHEME_V->dump_size = 0; @@ -3148,13 +3148,13 @@ #else -static INLINE void +ecb_inline void dump_stack_reset (SCHEME_P) { SCHEME_V->dump = NIL; } -static INLINE void +ecb_inline void dump_stack_initialize (SCHEME_P) { dump_stack_reset (SCHEME_A); @@ -4017,7 +4017,7 @@ v = num_zero; for (x = args; x != NIL; x = cdr (x)) - v = num_op ('+', v, nvalue (car (x))); + v = num_op (NUM_ADD, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); @@ -4025,7 +4025,7 @@ v = num_one; for (x = args; x != NIL; x = cdr (x)) - v = num_op ('*', v, nvalue (car (x))); + v = num_op (NUM_MUL, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); @@ -4042,7 +4042,7 @@ } for (; x != NIL; x = cdr (x)) - v = num_op ('-', v, nvalue (car (x))); + v = num_op (NUM_SUB, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); @@ -4059,12 +4059,10 @@ } for (; x != NIL; x = cdr (x)) - { - if (!is_zero_rvalue (rvalue (car (x)))) - v = num_div (v, nvalue (car (x))); - else - Error_0 ("/: division by zero"); - } + if (!is_zero_rvalue (rvalue (car (x)))) + v = num_div (v, nvalue (car (x))); + else + Error_0 ("/: division by zero"); s_return (mk_number (SCHEME_A_ v)); @@ -4083,7 +4081,7 @@ for (; x != NIL; x = cdr (x)) { if (ivalue (car (x)) != 0) - v = num_op ('/', v, nvalue (car (x))); + v = num_op (NUM_INTDIV, v, nvalue (car (x))); else Error_0 ("quotient: division by zero"); } @@ -4785,10 +4783,7 @@ p = port_from_filename (SCHEME_A_ strvalue (a), prop); - if (p == NIL) - s_return (S_F); - - s_return (p); + s_return (p == NIL ? S_F : p); } # if USE_STRING_PORTS @@ -4813,10 +4808,7 @@ p = port_from_string (SCHEME_A_ strvalue (a), strvalue (a) + strlength (a), prop); - if (p == NIL) - s_return (S_F); - - s_return (p); + s_return (p == NIL ? S_F : p); } case OP_OPEN_OUTSTRING: /* open-output-string */ @@ -4824,22 +4816,12 @@ pointer p; if (a == NIL) - { - p = port_from_scratch (SCHEME_A); - - if (p == NIL) - s_return (S_F); - } + p = port_from_scratch (SCHEME_A); else - { - p = port_from_string (SCHEME_A_ strvalue (a), - strvalue (a) + strlength (a), port_output); - - if (p == NIL) - s_return (S_F); - } + p = port_from_string (SCHEME_A_ strvalue (a), + strvalue (a) + strlength (a), port_output); - s_return (p); + s_return (p == NIL ? S_F : p); } case OP_GET_OUTSTRING: /* get-output-string */ @@ -5403,7 +5385,7 @@ }; /* kernel of this interpreter */ -static void +static void ecb_hot Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) { SCHEME_V->op = op; @@ -5591,7 +5573,7 @@ } #if USE_MULTIPLICITY -scheme * +ecb_cold scheme * scheme_init_new () { scheme *sc = malloc (sizeof (scheme)); @@ -5606,7 +5588,7 @@ } #endif -int +ecb_cold int scheme_init (SCHEME_P) { int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); @@ -5741,7 +5723,7 @@ SCHEME_V->ext_data = p; } -void +ecb_cold void scheme_deinit (SCHEME_P) { int i;