Back to index

texmacs  1.0.7.15
Classes | Defines | Typedefs | Enumerations | Functions | Variables
scheme.c File Reference
#include "scheme-private.h"
#include <unistd.h>
#include <math.h>
#include <limits.h>
#include <float.h>
#include <ctype.h>
#include <strings.h>
#include <string.h>
#include <stdlib.h>
#include "opdefines.h"

Go to the source code of this file.

Classes

struct  op_code_info

Defines

#define STANDALONE   0
#define _SCHEME_SOURCE
#define stricmp   strcasecmp
#define INTERFACE
#define TOK_EOF   (-1)
#define TOK_LPAREN   0
#define TOK_RPAREN   1
#define TOK_DOT   2
#define TOK_ATOM   3
#define TOK_QUOTE   4
#define TOK_COMMENT   5
#define TOK_DQUOTE   6
#define TOK_BQUOTE   7
#define TOK_COMMA   8
#define TOK_ATMARK   9
#define TOK_SHARP   10
#define TOK_SHARP_CONST   11
#define TOK_VEC   12
#define BACKQUOTE   '`'
#define banner   "TinyScheme 1.39"
#define prompt   "ts> "
#define InitFile   "init.scm"
#define FIRST_CELLSEGS   3
#define ADJ   32
#define TYPE_BITS   5
#define T_MASKTYPE   31 /* 0000000000011111 */
#define T_SYNTAX   4096 /* 0001000000000000 */
#define T_IMMUTABLE   8192 /* 0010000000000000 */
#define T_ATOM   16384 /* 0100000000000000 */ /* only for gc */
#define CLRATOM   49151 /* 1011111111111111 */ /* only for gc */
#define MARK   32768 /* 1000000000000000 */
#define UNMARK   32767 /* 0111111111111111 */
#define typeflag(p)   ((p)->_flag)
#define type(p)   (typeflag(p)&T_MASKTYPE)
#define strvalue(p)   ((p)->_object._string._svalue)
#define strlength(p)   ((p)->_object._string._length)
#define ivalue_unchecked(p)   ((p)->_object._number.value.ivalue)
#define rvalue_unchecked(p)   ((p)->_object._number.value.rvalue)
#define set_num_integer(p)   (p)->_object._number.is_fixnum=1;
#define set_num_real(p)   (p)->_object._number.is_fixnum=0;
#define car(p)   ((p)->_object._cons._car)
#define cdr(p)   ((p)->_object._cons._cdr)
#define procnum(p)   ivalue(p)
#define cont_dump(p)   cdr(p)
#define setenvironment(p)   typeflag(p) = T_ENVIRONMENT
#define is_atom(p)   (typeflag(p)&T_ATOM)
#define setatom(p)   typeflag(p) |= T_ATOM
#define clratom(p)   typeflag(p) &= CLRATOM
#define is_mark(p)   (typeflag(p)&MARK)
#define setmark(p)   typeflag(p) |= MARK
#define clrmark(p)   typeflag(p) &= UNMARK
#define caar(p)   car(car(p))
#define cadr(p)   car(cdr(p))
#define cdar(p)   cdr(car(p))
#define cddr(p)   cdr(cdr(p))
#define cadar(p)   car(cdr(car(p)))
#define caddr(p)   car(cdr(cdr(p)))
#define cdaar(p)   cdr(car(car(p)))
#define cadaar(p)   car(cdr(car(car(p))))
#define cadddr(p)   car(cdr(cdr(cdr(p))))
#define cddddr(p)   cdr(cdr(cdr(cdr(p))))
#define num_ivalue(n)   (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
#define num_rvalue(n)   (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
#define BLOCK_SIZE   256
#define ok_abbrev(x)   (is_pair(x) && cdr(x) == sc->NIL)
#define is_true(p)   ((p) != sc->F)
#define is_false(p)   ((p) == sc->F)
#define Error_1(sc, s, a)   return _Error_1(sc,s,a)
#define Error_0(sc, s)   return _Error_1(sc,s,0)
#define BEGIN   do {
#define END   } while (0)
#define s_goto(sc, a)
#define s_return(sc, a)   return _s_return(sc,a)
#define s_retbool(tf)   s_return(sc,(tf) ? sc->T : sc->F)
#define TST_NONE   0
#define TST_ANY   "\001"
#define TST_STRING   "\002"
#define TST_SYMBOL   "\003"
#define TST_PORT   "\004"
#define TST_INPORT   "\005"
#define TST_OUTPORT   "\006"
#define TST_ENVIRONMENT   "\007"
#define TST_PAIR   "\010"
#define TST_LIST   "\011"
#define TST_CHAR   "\012"
#define TST_VECTOR   "\013"
#define TST_NUMBER   "\014"
#define TST_INTEGER   "\015"
#define TST_NATURAL   "\016"
#define INF_ARG   0xffff
#define _OP_DEF(A, B, C, D, E, OP)   {A,B,C,D,E},

Typedefs

typedef cell_ptr(* dispatch_func )(scheme *, enum scheme_opcodes)
typedef int(* test_predicate )(cell_ptr)

Enumerations

enum  scheme_types {
  T_STRING = 1, T_NUMBER = 2, T_SYMBOL = 3, T_PROC = 4,
  T_PAIR = 5, T_CLOSURE = 6, T_CONTINUATION = 7, T_FOREIGN = 8,
  T_CHARACTER = 9, T_PORT = 10, T_VECTOR = 11, T_MACRO = 12,
  T_PROMISE = 13, T_ENVIRONMENT = 14, T_BLACKBOX = 15, T_LAST_SYSTEM_TYPE = 15
}

Functions

static const char * strlwr (char *s)
static num num_add (num a, num b)
static num num_mul (num a, num b)
static num num_div (num a, num b)
static num num_intdiv (num a, num b)
static num num_sub (num a, num b)
static num num_rem (num a, num b)
static num num_mod (num a, num b)
static int num_eq (num a, num b)
static int num_gt (num a, num b)
static int num_ge (num a, num b)
static int num_lt (num a, num b)
static int num_le (num a, num b)
static double round_per_R5RS (double x)
static int is_zero_double (double x)
static INLINE int num_is_integer (cell_ptr p)
INTERFACE INLINE int is_string (cell_ptr p)
static INTERFACE int is_list (scheme *sc, cell_ptr p)
INTERFACE INLINE int is_vector (cell_ptr p)
static INTERFACE void fill_vector (cell_ptr vec, cell_ptr obj)
static INTERFACE cell_ptr vector_elem (cell_ptr vec, int ielem)
static INTERFACE cell_ptr set_vector_elem (cell_ptr vec, int ielem, cell_ptr a)
INTERFACE INLINE int is_number (cell_ptr p)
INTERFACE INLINE int is_integer (cell_ptr p)
INTERFACE INLINE int is_real (cell_ptr p)
INTERFACE INLINE int is_character (cell_ptr p)
INTERFACE INLINE char * string_value (cell_ptr p)
INTERFACE INLINE int string_length (cell_ptr p)
INLINE num nvalue (cell_ptr p)
INTERFACE long ivalue (cell_ptr p)
INTERFACE double rvalue (cell_ptr p)
INTERFACE long charvalue (cell_ptr p)
INTERFACE INLINE int is_port (cell_ptr p)
INTERFACE INLINE int is_inport (cell_ptr p)
INTERFACE INLINE int is_outport (cell_ptr p)
INTERFACE INLINE int is_pair (cell_ptr p)
INTERFACE INLINE int is_blackbox (cell_ptr p)
INTERFACE cell_ptr pair_car (cell_ptr p)
INTERFACE cell_ptr pair_cdr (cell_ptr p)
INTERFACE cell_ptr set_car (cell_ptr p, cell_ptr q)
INTERFACE cell_ptr set_cdr (cell_ptr p, cell_ptr q)
INTERFACE INLINE void * blackboxvalue (cell_ptr p)
INTERFACE INLINE int is_symbol (cell_ptr p)
INTERFACE INLINE char * symname (cell_ptr p)
INTERFACE INLINE int symlen (cell_ptr p)
INTERFACE INLINE int is_syntax (cell_ptr p)
INTERFACE INLINE int is_proc (cell_ptr p)
INTERFACE INLINE int is_foreign (cell_ptr p)
INTERFACE INLINE char * syntaxname (cell_ptr p)
static const char * procname (cell_ptr x)
INTERFACE INLINE int is_closure (cell_ptr p)
INTERFACE INLINE int is_macro (cell_ptr p)
INTERFACE INLINE cell_ptr closure_code (cell_ptr p)
INTERFACE INLINE cell_ptr closure_env (cell_ptr p)
INTERFACE INLINE int is_continuation (cell_ptr p)
INTERFACE INLINE int is_promise (cell_ptr p)
INTERFACE INLINE int is_environment (cell_ptr p)
INTERFACE INLINE int is_immutable (cell_ptr p)
INTERFACE INLINE void setimmutable (cell_ptr p)
static INLINE int Cisalpha (int c)
static INLINE int Cisdigit (int c)
static INLINE int Cisspace (int c)
static INLINE int Cisupper (int c)
static INLINE int Cislower (int c)
static int is_ascii_name (const char *name, int *pc)
static int file_push (scheme *sc, const char *fname)
static void file_pop (scheme *sc)
static int file_interactive (scheme *sc)
static INLINE int is_one_of (char *s, int c)
static int alloc_cellseg (scheme *sc, int n)
static long binary_decode (const char *s)
static INLINE cell_ptr get_cell (scheme *sc, cell_ptr a, cell_ptr b)
static cell_ptr _get_cell (scheme *sc, cell_ptr a, cell_ptr b)
static cell_ptr reserve_cells (scheme *sc, int n)
static cell_ptr get_consecutive_cells (scheme *sc, int n)
static cell_ptr find_consecutive_cells (scheme *sc, int n)
static void finalize_cell (scheme *sc, cell_ptr a)
static int count_consecutive_cells (cell_ptr x, int needed)
static cell_ptr find_slot_in_env (scheme *sc, cell_ptr env, cell_ptr sym, int all)
static cell_ptr mk_number (scheme *sc, num n)
static char * store_string (scheme *sc, int len, const char *str, char fill)
static cell_ptr mk_vector (scheme *sc, int len)
static cell_ptr mk_atom (scheme *sc, char *q)
static cell_ptr mk_sharp_const (scheme *sc, char *name)
static cell_ptr mk_port (scheme *sc, port *p)
static cell_ptr port_from_filename (scheme *sc, const char *fn, int prop)
static cell_ptr port_from_file (scheme *sc, FILE *, int prop)
static cell_ptr port_from_string (scheme *sc, char *start, char *past_the_end, int prop)
static portport_rep_from_filename (scheme *sc, const char *fn, int prop)
static portport_rep_from_file (scheme *sc, FILE *, int prop)
static portport_rep_from_string (scheme *sc, char *start, char *past_the_end, int prop)
static void port_close (scheme *sc, cell_ptr p, int flag)
static void mark (cell_ptr a)
static void gc (scheme *sc, cell_ptr a, cell_ptr b)
static int basic_inchar (port *pt)
static int inchar (scheme *sc)
static void backchar (scheme *sc, int c)
static char * readstr_upto (scheme *sc, char *delim)
static cell_ptr readstrexp (scheme *sc)
static INLINE int skipspace (scheme *sc)
static int token (scheme *sc)
static void printslashstring (scheme *sc, char *s, int len)
static void atom2str (scheme *sc, cell_ptr l, int f, char **pp, int *plen)
static void printatom (scheme *sc, cell_ptr l, int f)
static cell_ptr mk_proc (scheme *sc, enum scheme_opcodes op)
static cell_ptr mk_closure (scheme *sc, cell_ptr c, cell_ptr e)
static cell_ptr mk_continuation (scheme *sc, cell_ptr d)
static cell_ptr reverse (scheme *sc, cell_ptr a)
static cell_ptr reverse_in_place (scheme *sc, cell_ptr term, cell_ptr list)
static cell_ptr append (scheme *sc, cell_ptr a, cell_ptr b)
static void dump_stack_mark (scheme *)
static cell_ptr opexe_0 (scheme *sc, enum scheme_opcodes op)
static cell_ptr opexe_1 (scheme *sc, enum scheme_opcodes op)
static cell_ptr opexe_2 (scheme *sc, enum scheme_opcodes op)
static cell_ptr opexe_3 (scheme *sc, enum scheme_opcodes op)
static cell_ptr opexe_4 (scheme *sc, enum scheme_opcodes op)
static cell_ptr opexe_5 (scheme *sc, enum scheme_opcodes op)
static cell_ptr opexe_6 (scheme *sc, enum scheme_opcodes op)
static void Eval_Cycle (scheme *sc, enum scheme_opcodes op)
static void assign_syntax (scheme *sc, char *name)
static int syntaxnum (cell_ptr p)
static void assign_proc (scheme *sc, enum scheme_opcodes, char *name)
static INLINE cell_ptr get_cell_x (scheme *sc, cell_ptr a, cell_ptr b)
static void push_recent_alloc (scheme *sc, cell_ptr recent, cell_ptr extra)
static cell_ptr get_vector_object (scheme *sc, int len, cell_ptr init)
static INLINE void ok_to_freely_gc (scheme *sc)
cell_ptr _cons (scheme *sc, cell_ptr a, cell_ptr b, int immutable)
static int hash_fn (const char *key, int table_size)
static cell_ptr oblist_initial_value (scheme *sc)
static cell_ptr oblist_add_by_name (scheme *sc, const char *name)
static INLINE cell_ptr oblist_find_by_name (scheme *sc, const char *name)
static cell_ptr oblist_all_symbols (scheme *sc)
cell_ptr mk_foreign_func (scheme *sc, foreign_func f)
INTERFACE cell_ptr mk_character (scheme *sc, int c)
INTERFACE cell_ptr mk_integer (scheme *sc, long num)
INTERFACE cell_ptr mk_real (scheme *sc, double n)
INTERFACE cell_ptr mk_string (scheme *sc, const char *str)
INTERFACE cell_ptr mk_counted_string (scheme *sc, const char *str, int len)
INTERFACE cell_ptr mk_empty_string (scheme *sc, int len, char fill)
INTERFACE cell_ptr mk_blackbox (scheme *sc, void *blackbox)
INTERFACE cell_ptr mk_symbol (scheme *sc, const char *name)
INTERFACE cell_ptr gensym (scheme *sc)
static portport_rep_from_scratch (scheme *sc)
static cell_ptr port_from_scratch (scheme *sc)
static int realloc_port_string (scheme *sc, port *p)
INTERFACE void putstr (scheme *sc, const char *s)
static void putchars (scheme *sc, const char *s, int len)
INTERFACE void putcharacter (scheme *sc, int c)
static cell_ptr list_star (scheme *sc, cell_ptr d)
int eqv (cell_ptr a, cell_ptr b)
static void new_frame_in_env (scheme *sc, cell_ptr old_env)
static INLINE void new_slot_spec_in_env (scheme *sc, cell_ptr env, cell_ptr variable, cell_ptr value)
static INLINE void new_slot_in_env (scheme *sc, cell_ptr variable, cell_ptr value)
static INLINE void set_slot_in_env (scheme *sc, cell_ptr slot, cell_ptr value)
static INLINE cell_ptr slot_value_in_env (cell_ptr slot)
static cell_ptr _Error_1 (scheme *sc, const char *s, cell_ptr a)
static INLINE void dump_stack_reset (scheme *sc)
static INLINE void dump_stack_initialize (scheme *sc)
static void dump_stack_free (scheme *sc)
static cell_ptr _s_return (scheme *sc, cell_ptr a)
static void s_save (scheme *sc, enum scheme_opcodes op, cell_ptr args, cell_ptr code)
int list_length (scheme *sc, cell_ptr a)
static int is_any (cell_ptr p)
static int is_nonneg (cell_ptr p)
schemescheme_init_new ()
schemescheme_init_new_custom_alloc (func_alloc malloc, func_dealloc free)
int scheme_init (scheme *sc)
int scheme_init_custom_alloc (scheme *sc, func_alloc malloc, func_dealloc free)
void scheme_set_input_port_file (scheme *sc, FILE *fin)
void scheme_set_input_port_string (scheme *sc, char *start, char *past_the_end)
void scheme_set_output_port_file (scheme *sc, FILE *fout)
void scheme_set_output_port_string (scheme *sc, char *start, char *past_the_end)
void scheme_set_external_data (scheme *sc, void *p)
void scheme_deinit (scheme *sc)
void scheme_load_file (scheme *sc, FILE *fin)
void scheme_load_named_file (scheme *sc, FILE *fin, const char *filename)
void scheme_load_string (scheme *sc, const char *cmd)
void scheme_define (scheme *sc, cell_ptr envir, cell_ptr symbol, cell_ptr value)
int main (int argc, char **argv)

Variables

static num num_zero
static num num_one
static const char * charnames [32]
struct {
test_predicate fct
const char * kind
tests []
static op_code_info dispatch_table []

Class Documentation

struct op_code_info

Definition at line 4299 of file scheme.c.

Collaboration diagram for op_code_info:
Class Members
char * arg_tests_encoding
dispatch_func func
int max_arity
int min_arity
char * name

Define Documentation

#define _OP_DEF (   A,
  B,
  C,
  D,
  E,
  OP 
)    {A,B,C,D,E},
#define _SCHEME_SOURCE

Definition at line 17 of file scheme.c.

#define ADJ   32

Definition at line 132 of file scheme.c.

#define BACKQUOTE   '`'

Definition at line 61 of file scheme.c.

#define banner   "TinyScheme 1.39"

Definition at line 67 of file scheme.c.

#define BEGIN   do {

Definition at line 2337 of file scheme.c.

#define BLOCK_SIZE   256

Definition at line 1468 of file scheme.c.

#define caar (   p)    car(car(p))

Definition at line 258 of file scheme.c.

#define cadaar (   p)    car(cdr(car(car(p))))

Definition at line 265 of file scheme.c.

#define cadar (   p)    car(cdr(car(p)))

Definition at line 262 of file scheme.c.

#define cadddr (   p)    car(cdr(cdr(cdr(p))))

Definition at line 266 of file scheme.c.

#define caddr (   p)    car(cdr(cdr(p)))

Definition at line 263 of file scheme.c.

#define cadr (   p)    car(cdr(p))

Definition at line 259 of file scheme.c.

#define car (   p)    ((p)->_object._cons._car)

Definition at line 208 of file scheme.c.

#define cdaar (   p)    cdr(car(car(p)))

Definition at line 264 of file scheme.c.

#define cdar (   p)    cdr(car(p))

Definition at line 260 of file scheme.c.

#define cddddr (   p)    cdr(cdr(cdr(cdr(p))))

Definition at line 267 of file scheme.c.

#define cddr (   p)    cdr(cdr(p))

Definition at line 261 of file scheme.c.

#define cdr (   p)    ((p)->_object._cons._cdr)

Definition at line 209 of file scheme.c.

#define CLRATOM   49151 /* 1011111111111111 */ /* only for gc */

Definition at line 138 of file scheme.c.

#define clratom (   p)    typeflag(p) &= CLRATOM

Definition at line 248 of file scheme.c.

#define clrmark (   p)    typeflag(p) &= UNMARK

Definition at line 252 of file scheme.c.

#define cont_dump (   p)    cdr(p)

Definition at line 238 of file scheme.c.

#define END   } while (0)

Definition at line 2338 of file scheme.c.

#define Error_0 (   sc,
 
)    return _Error_1(sc,s,0)

Definition at line 2334 of file scheme.c.

#define Error_1 (   sc,
  s,
 
)    return _Error_1(sc,s,a)

Definition at line 2333 of file scheme.c.

#define FIRST_CELLSEGS   3

Definition at line 109 of file scheme.c.

#define INF_ARG   0xffff

Definition at line 4307 of file scheme.c.

#define InitFile   "init.scm"

Definition at line 105 of file scheme.c.

#define INTERFACE

Definition at line 44 of file scheme.c.

#define is_atom (   p)    (typeflag(p)&T_ATOM)

Definition at line 246 of file scheme.c.

#define is_false (   p)    ((p) == sc->F)

Definition at line 2134 of file scheme.c.

#define is_mark (   p)    (typeflag(p)&MARK)

Definition at line 250 of file scheme.c.

#define is_true (   p)    ((p) != sc->F)

Definition at line 2133 of file scheme.c.

#define ivalue_unchecked (   p)    ((p)->_object._number.value.ivalue)

Definition at line 195 of file scheme.c.

#define MARK   32768 /* 1000000000000000 */

Definition at line 139 of file scheme.c.

#define num_ivalue (   n)    (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)

Definition at line 388 of file scheme.c.

#define num_rvalue (   n)    (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)

Definition at line 389 of file scheme.c.

#define ok_abbrev (   x)    (is_pair(x) && cdr(x) == sc->NIL)

Definition at line 1871 of file scheme.c.

#define procnum (   p)    ivalue(p)

Definition at line 229 of file scheme.c.

#define prompt   "ts> "

Definition at line 101 of file scheme.c.

#define rvalue_unchecked (   p)    ((p)->_object._number.value.rvalue)

Definition at line 196 of file scheme.c.

#define s_goto (   sc,
 
)
Value:
BEGIN                                  \
    sc->op = (int)(a);                                      \
    return sc->T; END

Definition at line 2339 of file scheme.c.

#define s_retbool (   tf)    s_return(sc,(tf) ? sc->T : sc->F)

Definition at line 2470 of file scheme.c.

#define s_return (   sc,
 
)    return _s_return(sc,a)

Definition at line 2343 of file scheme.c.

#define set_num_integer (   p)    (p)->_object._number.is_fixnum=1;

Definition at line 197 of file scheme.c.

#define set_num_real (   p)    (p)->_object._number.is_fixnum=0;

Definition at line 198 of file scheme.c.

#define setatom (   p)    typeflag(p) |= T_ATOM

Definition at line 247 of file scheme.c.

#define setenvironment (   p)    typeflag(p) = T_ENVIRONMENT

Definition at line 244 of file scheme.c.

#define setmark (   p)    typeflag(p) |= MARK

Definition at line 251 of file scheme.c.

#define STANDALONE   0

Definition at line 15 of file scheme.c.

#define stricmp   strcasecmp

Definition at line 39 of file scheme.c.

#define strlength (   p)    ((p)->_object._string._length)

Definition at line 173 of file scheme.c.

#define strvalue (   p)    ((p)->_object._string._svalue)

Definition at line 172 of file scheme.c.

#define T_ATOM   16384 /* 0100000000000000 */ /* only for gc */

Definition at line 137 of file scheme.c.

#define T_IMMUTABLE   8192 /* 0010000000000000 */

Definition at line 136 of file scheme.c.

#define T_MASKTYPE   31 /* 0000000000011111 */

Definition at line 134 of file scheme.c.

#define T_SYNTAX   4096 /* 0001000000000000 */

Definition at line 135 of file scheme.c.

#define TOK_ATMARK   9

Definition at line 56 of file scheme.c.

#define TOK_ATOM   3

Definition at line 50 of file scheme.c.

#define TOK_BQUOTE   7

Definition at line 54 of file scheme.c.

#define TOK_COMMA   8

Definition at line 55 of file scheme.c.

#define TOK_COMMENT   5

Definition at line 52 of file scheme.c.

#define TOK_DOT   2

Definition at line 49 of file scheme.c.

#define TOK_DQUOTE   6

Definition at line 53 of file scheme.c.

#define TOK_EOF   (-1)

Definition at line 46 of file scheme.c.

#define TOK_LPAREN   0

Definition at line 47 of file scheme.c.

#define TOK_QUOTE   4

Definition at line 51 of file scheme.c.

#define TOK_RPAREN   1

Definition at line 48 of file scheme.c.

#define TOK_SHARP   10

Definition at line 57 of file scheme.c.

#define TOK_SHARP_CONST   11

Definition at line 58 of file scheme.c.

#define TOK_VEC   12

Definition at line 59 of file scheme.c.

#define TST_ANY   "\001"

Definition at line 4284 of file scheme.c.

#define TST_CHAR   "\012"

Definition at line 4293 of file scheme.c.

#define TST_ENVIRONMENT   "\007"

Definition at line 4290 of file scheme.c.

#define TST_INPORT   "\005"

Definition at line 4288 of file scheme.c.

#define TST_INTEGER   "\015"

Definition at line 4296 of file scheme.c.

#define TST_LIST   "\011"

Definition at line 4292 of file scheme.c.

#define TST_NATURAL   "\016"

Definition at line 4297 of file scheme.c.

#define TST_NONE   0

Definition at line 4283 of file scheme.c.

#define TST_NUMBER   "\014"

Definition at line 4295 of file scheme.c.

#define TST_OUTPORT   "\006"

Definition at line 4289 of file scheme.c.

#define TST_PAIR   "\010"

Definition at line 4291 of file scheme.c.

#define TST_PORT   "\004"

Definition at line 4287 of file scheme.c.

#define TST_STRING   "\002"

Definition at line 4285 of file scheme.c.

#define TST_SYMBOL   "\003"

Definition at line 4286 of file scheme.c.

#define TST_VECTOR   "\013"

Definition at line 4294 of file scheme.c.

#define type (   p)    (typeflag(p)&T_MASKTYPE)

Definition at line 169 of file scheme.c.

#define TYPE_BITS   5

Definition at line 133 of file scheme.c.

#define typeflag (   p)    ((p)->_flag)

Definition at line 168 of file scheme.c.

#define UNMARK   32767 /* 0111111111111111 */

Definition at line 140 of file scheme.c.


Typedef Documentation

Definition at line 4252 of file scheme.c.

typedef int(* test_predicate)(cell_ptr)

Definition at line 4254 of file scheme.c.


Enumeration Type Documentation

Enumerator:
T_STRING 
T_NUMBER 
T_SYMBOL 
T_PROC 
T_PAIR 
T_CLOSURE 
T_CONTINUATION 
T_FOREIGN 
T_CHARACTER 
T_PORT 
T_VECTOR 
T_MACRO 
T_PROMISE 
T_ENVIRONMENT 
T_BLACKBOX 
T_LAST_SYSTEM_TYPE 

Definition at line 112 of file scheme.c.


Function Documentation

cell_ptr _cons ( scheme sc,
cell_ptr  a,
cell_ptr  b,
int  immutable 
)

Definition at line 813 of file scheme.c.

                                                                  {
  cell_ptr x = get_cell(sc,a, b);

  typeflag(x) = T_PAIR;
  if(immutable) {
    setimmutable(x);
  }
  car(x) = a;
  cdr(x) = b;
  return (x);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr _Error_1 ( scheme sc,
const char *  s,
cell_ptr  a 
) [static]

Definition at line 2281 of file scheme.c.

                                                                {
#if SHOW_ERROR_LINE
     const char *str = s;
     char sbuf[STRBUFFSIZE];

     /* make sure error is not in REPL */
     if(sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
       int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
       const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;

       /* should never happen */
       if(!fname) fname = "<unknown>";

       /* we started from 0 */
       ln++;
       snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);

       str = (const char*)sbuf;
     }
#else
     const char *str = s;
#endif

#if USE_ERROR_HOOK
     cell_ptr x;
     cell_ptr hdl=sc->ERROR_HOOK;

     x=find_slot_in_env(sc,sc->envir,hdl,1);
    if (x != sc->NIL) {
         if(a!=0) {
               sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
         } else {
               sc->code = sc->NIL;
         }
         sc->code = cons(sc, mk_string(sc, str), sc->code);
         setimmutable(car(sc->code));
         sc->code = cons(sc, slot_value_in_env(x), sc->code);
         sc->op = (int)OP_EVAL;
         return sc->T;
    }
#endif

    if(a!=0) {
          sc->args = cons(sc, (a), sc->NIL);
    } else {
          sc->args = sc->NIL;
    }
    sc->args = cons(sc, mk_string(sc, str), sc->args);
    setimmutable(car(sc->args));
    sc->op = (int)OP_ERR0;
    return sc->T;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr _get_cell ( scheme sc,
cell_ptr  a,
cell_ptr  b 
) [static]

Definition at line 633 of file scheme.c.

                                                              {
  cell_ptr x;

  if(sc->no_memory) {
    return sc->sink;
  }

  if (sc->free_cell == sc->NIL) {
    const int min_to_be_recovered = sc->last_cell_seg*8;
    gc(sc,a, b);
    if (sc->fcells < min_to_be_recovered
    || sc->free_cell == sc->NIL) {
      /* if only a few recovered, get more to avoid fruitless gc's */
      if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) {
    sc->no_memory=1;
    return sc->sink;
      }
    }
  }
  x = sc->free_cell;
  sc->free_cell = cdr(x);
  --sc->fcells;
  return (x);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr _s_return ( scheme sc,
cell_ptr  a 
) [static]

Definition at line 2447 of file scheme.c.

                                                  {
    sc->value = (a);
    if(sc->dump==sc->NIL) return sc->NIL;
    sc->op = ivalue(car(sc->dump));
    sc->args = cadr(sc->dump);
    sc->envir = caddr(sc->dump);
    sc->code = cadddr(sc->dump);
    sc->dump = cddddr(sc->dump);
    return sc->T;
}

Here is the call graph for this function:

static int alloc_cellseg ( scheme sc,
int  n 
) [static]

Definition at line 566 of file scheme.c.

                                            {
     cell_ptr newp;
     cell_ptr last;
     cell_ptr p;
     char *cp;
     long i;
     int k;
     int adj=ADJ;

     if(adj<sizeof(struct cell)) {
       adj=sizeof(struct cell);
     }

     for (k = 0; k < n; k++) {
          if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
               return k;
          cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj);
          if (cp == 0)
               return k;
      i = ++sc->last_cell_seg ;
      sc->alloc_seg[i] = cp;
      /* adjust in TYPE_BITS-bit boundary */
      if(((unsigned long)cp)%adj!=0) {
        cp=(char*)(adj*((unsigned long)cp/adj+1));
      }
        /* insert new segment in address order */
      newp=(cell_ptr)cp;
        sc->cell_seg[i] = newp;
        while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) {
              p = sc->cell_seg[i];
            sc->cell_seg[i] = sc->cell_seg[i - 1];
            sc->cell_seg[--i] = p;
        }
          sc->fcells += CELL_SEGSIZE;
        last = newp + CELL_SEGSIZE - 1;
          for (p = newp; p <= last; p++) {
               typeflag(p) = 0;
               cdr(p) = p + 1;
               car(p) = sc->NIL;
          }
        /* insert new cells in address order on free list */
        if (sc->free_cell == sc->NIL || p < sc->free_cell) {
             cdr(last) = sc->free_cell;
             sc->free_cell = newp;
        } else {
              p = sc->free_cell;
              while (cdr(p) != sc->NIL && newp > cdr(p))
                   p = cdr(p);
              cdr(last) = cdr(p);
              cdr(p) = newp;
        }
     }
     return n;
}

Here is the caller graph for this function:

static cell_ptr append ( scheme sc,
cell_ptr  a,
cell_ptr  b 
) [static]

Definition at line 2083 of file scheme.c.

                                                           {
     cell_ptr p = b, q;

     if (a != sc->NIL) {
          a = reverse(sc, a);
          while (a != sc->NIL) {
               q = cdr(a);
               cdr(a) = p;
               p = a;
               a = q;
          }
     }
     return (p);
}

Here is the call graph for this function:

static void assign_proc ( scheme sc,
enum scheme_opcodes  op,
char *  name 
) [static]

Definition at line 4406 of file scheme.c.

                                                                        {
     cell_ptr x, y;

     x = mk_symbol(sc, name);
     y = mk_proc(sc,op);
     new_slot_in_env(sc, x, y);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void assign_syntax ( scheme sc,
char *  name 
) [static]

Definition at line 4399 of file scheme.c.

                                                  {
     cell_ptr x;

     x = oblist_add_by_name(sc, name);
     typeflag(x) |= T_SYNTAX;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void atom2str ( scheme sc,
cell_ptr  l,
int  f,
char **  pp,
int *  plen 
) [static]

Definition at line 1931 of file scheme.c.

                                                                          {
     char *p;

     if (l == sc->NIL) {
          p = "()";
     } else if (l == sc->T) {
          p = "#t";
     } else if (l == sc->F) {
          p = "#f";
     } else if (l == sc->EOF_OBJ) {
          p = "#<EOF>";
     } else if (is_port(l)) {
          p = sc->strbuff;
          snprintf(p, STRBUFFSIZE, "#<PORT>");
     } else if (is_number(l)) {
          p = sc->strbuff;
          if(num_is_integer(l)) {
        snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
          } else {
               snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
          }
     } else if (is_string(l)) {
          if (!f) {
               p = strvalue(l);
          } else { /* Hack, uses the fact that printing is needed */
               *pp=sc->strbuff;
           *plen=0;
               printslashstring(sc, strvalue(l), strlength(l));
           return;
          }
     } else if (is_character(l)) {
          int c=charvalue(l);
          p = sc->strbuff;
          if (!f) {
               p[0]=c;
               p[1]=0;
          } else {
               switch(c) {
               case ' ':
                    snprintf(p,STRBUFFSIZE,"#\\space"); break;
               case '\n':
                    snprintf(p,STRBUFFSIZE,"#\\newline"); break;
               case '\r':
                    snprintf(p,STRBUFFSIZE,"#\\return"); break;
               case '\t':
                    snprintf(p,STRBUFFSIZE,"#\\tab"); break;
               default:
#if USE_ASCII_NAMES
                    if(c==127) {
                         snprintf(p,STRBUFFSIZE, "#\\del");
             break;
                    } else if(c<32) {
                         snprintf(p, STRBUFFSIZE, "#\\%s", charnames[c]);
             break;
                    }
#else
            if(c<32) {
              snprintf(p,STRBUFFSIZE,"#\\x%x",c); break;
          break;
            }
#endif
                    snprintf(p,STRBUFFSIZE,"#\\%c",c); break;
            break;
               }
          }
     } else if (is_symbol(l)) {
          p = symname(l);
     } else if (is_proc(l)) {
          p = sc->strbuff;
          snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l));
     } else if (is_macro(l)) {
          p = "#<MACRO>";
     } else if (is_closure(l)) {
          p = "#<CLOSURE>";
     } else if (is_promise(l)) {
          p = "#<PROMISE>";
     } else if (is_foreign(l)) {
          p = sc->strbuff;
          snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
     } else if (is_continuation(l)) {
          p = "#<CONTINUATION>";
     } else if (is_blackbox(l)) {
               p = "#<BLACKBOX>";
     } else {
          p = "#<ERROR>";
     }
     *pp=p;
     *plen=strlen(p);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void backchar ( scheme sc,
int  c 
) [static]

Definition at line 1553 of file scheme.c.

                                        {
  port *pt;
  if(c==EOF) return;
  pt=sc->inport->_object._port;
  if(pt->kind&port_file) {
    ungetc(c,pt->rep.stdio.file);
  } else {
    if(pt->rep.string.curr!=pt->rep.string.start) {
      --pt->rep.string.curr;
    }
  }
}

Here is the caller graph for this function:

static int basic_inchar ( port pt) [static]

Definition at line 1539 of file scheme.c.

                                  {
  if(pt->kind & port_file) {
    return fgetc(pt->rep.stdio.file);
  } else {
    if(*pt->rep.string.curr == 0 ||
       pt->rep.string.curr == pt->rep.string.past_the_end) {
      return EOF;
    } else {
      return *pt->rep.string.curr++;
    }
  }
}

Here is the caller graph for this function:

static long binary_decode ( const char *  s) [static]

Definition at line 553 of file scheme.c.

                                         {
 long x=0;

 while(*s!=0 && (*s=='1' || *s=='0')) {
     x<<=1;
     x+=*s-'0';
     s++;
 }

 return x;
}

Here is the caller graph for this function:

Definition at line 215 of file scheme.c.

{ return car(p); }

Here is the caller graph for this function:

Definition at line 199 of file scheme.c.

{ return ivalue_unchecked(p); }

Here is the caller graph for this function:

static INLINE int Cisalpha ( int  c) [static]

Definition at line 270 of file scheme.c.

{ return isascii(c) && isalpha(c); }

Here is the caller graph for this function:

static INLINE int Cisdigit ( int  c) [static]

Definition at line 271 of file scheme.c.

{ return isascii(c) && isdigit(c); }

Here is the caller graph for this function:

static INLINE int Cislower ( int  c) [static]

Definition at line 274 of file scheme.c.

{ return isascii(c) && islower(c); }

Here is the caller graph for this function:

static INLINE int Cisspace ( int  c) [static]

Definition at line 272 of file scheme.c.

{ return isascii(c) && isspace(c); }

Here is the caller graph for this function:

static INLINE int Cisupper ( int  c) [static]

Definition at line 273 of file scheme.c.

{ return isascii(c) && isupper(c); }

Here is the caller graph for this function:

Definition at line 234 of file scheme.c.

{ return car(p); }

Here is the caller graph for this function:

Definition at line 235 of file scheme.c.

{ return cdr(p); }

Here is the caller graph for this function:

static int count_consecutive_cells ( cell_ptr  x,
int  needed 
) [static]

Definition at line 713 of file scheme.c.

                                                           {
 int n=1;
 while(cdr(x)==x+1) {
     x=cdr(x);
     n++;
     if(n>needed) return n;
 }
 return n;
}

Here is the caller graph for this function:

static void dump_stack_free ( scheme sc) [static]

Definition at line 2442 of file scheme.c.

{
  sc->dump = sc->NIL;
}

Here is the caller graph for this function:

static INLINE void dump_stack_initialize ( scheme sc) [static]

Definition at line 2437 of file scheme.c.

Here is the call graph for this function:

Here is the caller graph for this function:

static INLINE void dump_stack_mark ( scheme sc) [static]

Definition at line 2464 of file scheme.c.

{
  mark(sc->dump);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static INLINE void dump_stack_reset ( scheme sc) [static]

Definition at line 2432 of file scheme.c.

{
  sc->dump = sc->NIL;
}

Here is the caller graph for this function:

int eqv ( cell_ptr  a,
cell_ptr  b 
)

Definition at line 2099 of file scheme.c.

                                {
     if (is_string(a)) {
          if (is_string(b))
               return (strvalue(a) == strvalue(b));
          else
               return (0);
     } else if (is_number(a)) {
          if (is_number(b)) {
               if (num_is_integer(a) == num_is_integer(b))
                    return num_eq(nvalue(a),nvalue(b));
          }
          return (0);
     } else if (is_character(a)) {
          if (is_character(b))
               return charvalue(a)==charvalue(b);
          else
               return (0);
     } else if (is_port(a)) {
          if (is_port(b))
               return a==b;
          else
               return (0);
     } else if (is_proc(a)) {
          if (is_proc(b))
               return procnum(a)==procnum(b);
          else
               return (0);
     } else {
          return (a == b);
     }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void Eval_Cycle ( scheme sc,
enum scheme_opcodes  op 
) [static]

Definition at line 4325 of file scheme.c.

                                                           {
  sc->op = op;
  for (;;) {
    op_code_info *pcd=dispatch_table+sc->op;
    if (pcd->name!=0) { /* if built-in function, check arguments */
      char msg[STRBUFFSIZE];
      int ok=1;
      int n=list_length(sc,sc->args);

      /* Check number of arguments */
      if(n<pcd->min_arity) {
    ok=0;
    snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
        pcd->name,
        pcd->min_arity==pcd->max_arity?"":" at least",
        pcd->min_arity);
      }
      if(ok && n>pcd->max_arity) {
    ok=0;
    snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
        pcd->name,
        pcd->min_arity==pcd->max_arity?"":" at most",
        pcd->max_arity);
      }
      if(ok) {
    if(pcd->arg_tests_encoding!=0) {
      int i=0;
      int j;
      const char *t=pcd->arg_tests_encoding;
      cell_ptr arglist=sc->args;
      do {
        cell_ptr arg=car(arglist);
        j=(int)t[0];
        if(j==TST_LIST[0]) {
              if(arg!=sc->NIL && !is_pair(arg)) break;
        } else {
          if(!tests[j].fct(arg)) break;
        }

        if(t[1]!=0) {/* last test is replicated as necessary */
          t++;
        }
        arglist=cdr(arglist);
        i++;
      } while(i<n);
      if(i<n) {
        ok=0;
        snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s",
            pcd->name,
            i+1,
            tests[j].kind);
      }
    }
      }
      if(!ok) {
    if(_Error_1(sc,msg,0)==sc->NIL) {
      return;
    }
    pcd=dispatch_table+sc->op;
      }
    }
    ok_to_freely_gc(sc);
    if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) {
      return;
    }
    if(sc->no_memory) {
      fprintf(stderr,"No memory!\n");
      return;
    }
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int file_interactive ( scheme sc) [static]

Definition at line 1382 of file scheme.c.

                                        {
 return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin
     && sc->inport->_object._port->kind&port_file;
}

Here is the caller graph for this function:

static void file_pop ( scheme sc) [static]

Definition at line 1373 of file scheme.c.

                                 {
 if(sc->file_i != 0) {
   sc->nesting=sc->nesting_stack[sc->file_i];
   port_close(sc,sc->loadport,port_input);
   sc->file_i--;
   sc->loadport->_object._port=sc->load_stack+sc->file_i;
 }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int file_push ( scheme sc,
const char *  fname 
) [static]

Definition at line 1349 of file scheme.c.

                                                    {
  FILE *fin = NULL;

  if (sc->file_i == MAXFIL-1)
     return 0;
  fin=fopen(fname,"r");
  if(fin!=0) {
    sc->file_i++;
    sc->load_stack[sc->file_i].kind=port_file|port_input;
    sc->load_stack[sc->file_i].rep.stdio.file=fin;
    sc->load_stack[sc->file_i].rep.stdio.closeit=1;
    sc->nesting_stack[sc->file_i]=0;
    sc->loadport->_object._port=sc->load_stack+sc->file_i;

#if SHOW_ERROR_LINE
    sc->load_stack[sc->file_i].rep.stdio.curr_line = 0;
    if(fname)
      sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0);
#endif

  }
  return fin!=0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static INTERFACE void fill_vector ( cell_ptr  vec,
cell_ptr  obj 
) [static]

Definition at line 1024 of file scheme.c.

                                                              {
     int i;
     int num=ivalue(vec)/2+ivalue(vec)%2;
     for(i=0; i<num; i++) {
          typeflag(vec+1+i) = T_PAIR;
          setimmutable(vec+1+i);
          car(vec+1+i)=obj;
          cdr(vec+1+i)=obj;
     }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void finalize_cell ( scheme sc,
cell_ptr  a 
) [static]

Definition at line 1333 of file scheme.c.

                                                  {
  if(is_string(a)) {
    sc->free(strvalue(a));
  } else if(is_port(a)) {
    if(a->_object._port->kind&port_file
       && a->_object._port->rep.stdio.closeit) {
      port_close(sc,a,port_input|port_output);
    }
    sc->free(a->_object._port);
  } else if(is_blackbox(a)) {
         finalize_blackbox(car(a));
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr find_consecutive_cells ( scheme sc,
int  n 
) [static]

Definition at line 723 of file scheme.c.

                                                          {
  cell_ptr *pp;
  int cnt;

  pp=&sc->free_cell;
  while(*pp!=sc->NIL) {
    cnt=count_consecutive_cells(*pp,n);
    if(cnt>=n) {
      cell_ptr x=*pp;
      *pp=cdr(*pp+n-1);
      sc->fcells -= n;
      return x;
    }
    pp=&cdr(*pp+cnt-1);
  }
  return sc->NIL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr find_slot_in_env ( scheme sc,
cell_ptr  env,
cell_ptr  sym,
int  all 
) [static]

Definition at line 2195 of file scheme.c.

{
  cell_ptr x,y;
  int location;

  for (x = env; x != sc->NIL; x = cdr(x)) {
    if (is_vector(car(x))) {
      location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
      y = vector_elem(car(x), location);
    } else {
      y = car(x);
    }
    for ( ; y != sc->NIL; y = cdr(y)) {
              if (caar(y) == hdl) {
                   break;
              }
         }
         if (y != sc->NIL) {
              break;
         }
         if(!all) {
           return sc->NIL;
         }
    }
    if (x != sc->NIL) {
          return car(y);
    }
    return sc->NIL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void gc ( scheme sc,
cell_ptr  a,
cell_ptr  b 
) [static]

Definition at line 1266 of file scheme.c.

                                                   {
  cell_ptr p;
  int i;

  if(sc->gc_verbose) {
    putstr(sc, "gc...");
  }

  /* mark system globals */
  mark(sc->oblist);
  mark(sc->global_env);

  /* mark current registers */
  mark(sc->args);
  mark(sc->envir);
  mark(sc->code);
  dump_stack_mark(sc);
  mark(sc->value);
  mark(sc->inport);
  mark(sc->save_inport);
  mark(sc->outport);
  mark(sc->loadport);

  /* Mark recent objects the interpreter doesn't know about yet. */
  mark(car(sc->sink));
  /* Mark any older stuff above nested C calls */
  mark(sc->c_nest);

  /* mark variables a, b */
  mark(a);
  mark(b);

  /* garbage collect */
  clrmark(sc->NIL);
  sc->fcells = 0;
  sc->free_cell = sc->NIL;
  /* free-list is kept sorted by address so as to maintain consecutive
     ranges, if possible, for use with vectors. Here we scan the cells
     (which are also kept sorted by address) downwards to build the
     free-list in sorted order.
  */
  for (i = sc->last_cell_seg; i >= 0; i--) {
    p = sc->cell_seg[i] + CELL_SEGSIZE;
    while (--p >= sc->cell_seg[i]) {
      if (is_mark(p)) {
    clrmark(p);
      } else {
    /* reclaim cell */
        if (typeflag(p) != 0) {
          finalize_cell(sc, p);
          typeflag(p) = 0;
          car(p) = sc->NIL;
        }
        ++sc->fcells;
        cdr(p) = sc->free_cell;
        sc->free_cell = p;
      }
    }
  }

  if (sc->gc_verbose) {
    char msg[80];
    snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells);
    putstr(sc,msg);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 1067 of file scheme.c.

                                      {
     cell_ptr x;
     char name[40];

     for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
          snprintf(name,40,"gensym-%ld",sc->gensym_cnt);

          /* first check oblist */
          x = oblist_find_by_name(sc, name);

          if (x != sc->NIL) {
               continue;
          } else {
               x = oblist_add_by_name(sc, name);
               return (x);
          }
     }

     return sc->NIL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr get_cell ( scheme sc,
cell_ptr  a,
cell_ptr  b 
) [static]

Definition at line 754 of file scheme.c.

{
  cell_ptr cell   = get_cell_x(sc, a, b);
  /* For right now, include "a" and "b" in "cell" so that gc doesn't
     think they are garbage. */
  /* Tentatively record it as a pair so gc understands it. */
  typeflag(cell) = T_PAIR;
  car(cell) = a;
  cdr(cell) = b;
  push_recent_alloc(sc, cell, sc->NIL);
  return cell;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static INLINE cell_ptr get_cell_x ( scheme sc,
cell_ptr  a,
cell_ptr  b 
) [static]

Definition at line 621 of file scheme.c.

                                                                      {
  if (sc->free_cell != sc->NIL) {
    cell_ptr x = sc->free_cell;
    sc->free_cell = cdr(x);
    --sc->fcells;
    return (x);
  }
  return _get_cell (sc, a, b);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr get_consecutive_cells ( scheme sc,
int  n 
) [static]

Definition at line 684 of file scheme.c.

                                                         {
  cell_ptr x;

  if(sc->no_memory) { return sc->sink; }

  /* Are there any cells available? */
  x=find_consecutive_cells(sc,n);
  if (x != sc->NIL) { return x; }

  /* If not, try gc'ing some */
  gc(sc, sc->NIL, sc->NIL);
  x=find_consecutive_cells(sc,n);
  if (x != sc->NIL) { return x; }

  /* If there still aren't, try getting more heap */
  if (!alloc_cellseg(sc,1))
    {
      sc->no_memory=1;
      return sc->sink;
    }

  x=find_consecutive_cells(sc,n);
  if (x != sc->NIL) { return x; }

  /* If all fail, report failure */
  sc->no_memory=1;
  return sc->sink;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr get_vector_object ( scheme sc,
int  len,
cell_ptr  init 
) [static]

Definition at line 767 of file scheme.c.

{
  cell_ptr cells = get_consecutive_cells(sc,len/2+len%2+1);
  if(sc->no_memory) { return sc->sink; }
  /* Record it as a vector so that gc understands it. */
  typeflag(cells) = (T_VECTOR | T_ATOM);
  ivalue_unchecked(cells)=len;
  set_num_integer(cells);
  fill_vector(cells,init);
  push_recent_alloc(sc, cells, sc->NIL);
  return cells;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int hash_fn ( const char *  key,
int  table_size 
) [static]

Definition at line 2140 of file scheme.c.

{
  unsigned int hashed = 0;
  const char *c;
  int bits_per_int = sizeof(unsigned int)*8;

  for (c = key; *c; c++) {
    /* letters have about 5 bits in them */
    hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
    hashed ^= *c;
  }
  return hashed % table_size;
}

Here is the caller graph for this function:

static int inchar ( scheme sc) [static]

Definition at line 1520 of file scheme.c.

                              {
  int c;
  port *pt;

  pt = sc->inport->_object._port;
  if(pt->kind & port_saw_EOF)
    { return EOF; }
  c = basic_inchar(pt);
  if(c == EOF && sc->inport == sc->loadport) {
    /* Instead, set port_saw_EOF */
    pt->kind |= port_saw_EOF;

    /* file_pop(sc); */
    return EOF;
    /* NOTREACHED */
  }
  return c;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int is_any ( cell_ptr  p) [static]

Definition at line 4255 of file scheme.c.

{ return 1;}
static int is_ascii_name ( const char *  name,
int *  pc 
) [static]

Definition at line 313 of file scheme.c.

                                                    {
  int i;
  for(i=0; i<32; i++) {
     if(stricmp(name,charnames[i])==0) {
          *pc=i;
          return 1;
     }
  }
  if(stricmp(name,"del")==0) {
     *pc=127;
     return 1;
  }
  return 0;
}

Here is the caller graph for this function:

Definition at line 206 of file scheme.c.

{ return (type(p)==T_BLACKBOX); }

Here is the caller graph for this function:

Definition at line 189 of file scheme.c.

{ return (type(p)==T_CHARACTER); }

Here is the caller graph for this function:

Definition at line 232 of file scheme.c.

{ return (type(p)==T_CLOSURE); }

Here is the caller graph for this function:

Definition at line 237 of file scheme.c.

{ return (type(p)==T_CONTINUATION); }

Here is the caller graph for this function:

Definition at line 243 of file scheme.c.

{ return (type(p)==T_ENVIRONMENT); }

Here is the caller graph for this function:

Definition at line 227 of file scheme.c.

{ return (type(p)==T_FOREIGN); }

Here is the caller graph for this function:

Definition at line 254 of file scheme.c.

{ return (typeflag(p)&T_IMMUTABLE); }

Here is the caller graph for this function:

Definition at line 202 of file scheme.c.

{ return is_port(p) && p->_object._port->kind & port_input; }

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 181 of file scheme.c.

                                            {
  return is_number(p) && ((p)->_object._number.is_fixnum);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int is_list ( scheme sc,
cell_ptr  p 
) [static]

Definition at line 3513 of file scheme.c.

{ return list_length(sc,a) >= 0; }

Here is the call graph for this function:

Definition at line 233 of file scheme.c.

{ return (type(p)==T_MACRO); }

Here is the caller graph for this function:

static int is_nonneg ( cell_ptr  p) [static]

Definition at line 4257 of file scheme.c.

                                 {
  return is_integer(p) && ivalue(p)>=0;
}

Here is the call graph for this function:

Definition at line 180 of file scheme.c.

{ return (type(p)==T_NUMBER); }

Here is the caller graph for this function:

static INLINE int is_one_of ( char *  s,
int  c 
) [static]

Definition at line 1759 of file scheme.c.

                                            {
     if(c==EOF) return 1;
     while (*s)
          if (*s++ == c)
               return (1);
     return (0);
}

Here is the caller graph for this function:

Definition at line 203 of file scheme.c.

{ return is_port(p) && p->_object._port->kind & port_output; }

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 205 of file scheme.c.

{ return (type(p)==T_PAIR); }

Here is the caller graph for this function:

Definition at line 201 of file scheme.c.

{ return (type(p)==T_PORT); }

Here is the caller graph for this function:

Definition at line 226 of file scheme.c.

{ return (type(p)==T_PROC); }

Here is the caller graph for this function:

Definition at line 241 of file scheme.c.

{ return (type(p)==T_PROMISE); }

Here is the caller graph for this function:

Definition at line 185 of file scheme.c.

                                         {
  return is_number(p) && (!(p)->_object._number.is_fixnum);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 171 of file scheme.c.

{ return (type(p)==T_STRING); }

Definition at line 217 of file scheme.c.

{ return (type(p)==T_SYMBOL); }

Definition at line 225 of file scheme.c.

{ return (typeflag(p)&T_SYNTAX); }

Here is the caller graph for this function:

Definition at line 176 of file scheme.c.

{ return (type(p)==T_VECTOR); }

Here is the caller graph for this function:

static int is_zero_double ( double  x) [static]

Definition at line 549 of file scheme.c.

                                    {
 return x<DBL_MIN && x>-DBL_MIN;
}

Here is the caller graph for this function:

INTERFACE long ivalue ( cell_ptr  p)

Definition at line 193 of file scheme.c.

{ return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); }

Here is the call graph for this function:

Here is the caller graph for this function:

int list_length ( scheme sc,
cell_ptr  a 
)

Definition at line 3522 of file scheme.c.

                                        {
    int i=0;
    cell_ptr slow, fast;

    slow = fast = a;
    while (1)
    {
        if (fast == sc->NIL)
                return i;
        if (!is_pair(fast))
                return -2 - i;
        fast = cdr(fast);
        ++i;
        if (fast == sc->NIL)
                return i;
        if (!is_pair(fast))
                return -2 - i;
        ++i;
        fast = cdr(fast);

        /* Safe because we would have already returned if `fast'
           encountered a non-pair. */
        slow = cdr(slow);
        if (fast == slow)
        {
            /* the fast pointer has looped back around and caught up
               with the slow pointer, hence the structure is circular,
               not of finite length, and therefore not a list */
            return -1;
        }
    }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr list_star ( scheme sc,
cell_ptr  d 
) [static]

Definition at line 2041 of file scheme.c.

                                                  {
  cell_ptr p, q;
  if(cdr(d)==sc->NIL) {
    return car(d);
  }
  p=cons(sc,car(d),cdr(d));
  q=p;
  while(cdr(cdr(p))!=sc->NIL) {
    d=cons(sc,car(p),cdr(p));
    if(cdr(cdr(p))!=sc->NIL) {
      p=cdr(d);
    }
  }
  cdr(p)=car(cdr(p));
  return q;
}

Here is the caller graph for this function:

int main ( int  argc,
char **  argv 
)

Definition at line 4876 of file scheme.c.

                                {
#endif
  scheme sc;
  FILE *fin;
  char *file_name=InitFile;
  int retcode;
  int isfile=1;

  if(argc==1) {
    printf(banner);
  }
  if(argc==2 && strcmp(argv[1],"-?")==0) {
    printf("Usage: tinyscheme -?\n");
    printf("or:    tinyscheme [<file1> <file2> ...]\n");
    printf("followed by\n");
    printf("          -1 <file> [<arg1> <arg2> ...]\n");
    printf("          -c <Scheme commands> [<arg1> <arg2> ...]\n");
    printf("assuming that the executable is named tinyscheme.\n");
    printf("Use - as filename for stdin.\n");
    return 1;
  }
  if(!scheme_init(&sc)) {
    fprintf(stderr,"Could not initialize!\n");
    return 2;
  }
  scheme_set_input_port_file(&sc, stdin);
  scheme_set_output_port_file(&sc, stdout);
#if USE_DL
  scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext));
#endif
  argv++;
  if(access(file_name,0)!=0) {
    char *p=getenv("TINYSCHEMEINIT");
    if(p!=0) {
      file_name=p;
    }
  }
  do {
    if(strcmp(file_name,"-")==0) {
      fin=stdin;
    } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) {
      cell_ptr args=sc.NIL;
      isfile=file_name[1]=='1';
      file_name=*argv++;
      if(strcmp(file_name,"-")==0) {
    fin=stdin;
      } else if(isfile) {
    fin=fopen(file_name,"r");
      }
      for(;*argv;argv++) {
    cell_ptr value=mk_string(&sc,*argv);
    args=cons(&sc,value,args);
      }
      args=reverse_in_place(&sc,sc.NIL,args);
      scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args);

    } else {
      fin=fopen(file_name,"r");
    }
    if(isfile && fin==0) {
      fprintf(stderr,"Could not open file %s\n",file_name);
    } else {
      if(isfile) {
        scheme_load_named_file(&sc,fin,file_name);
      } else {
        scheme_load_string(&sc,file_name);
      }
      if(!isfile || fin!=stdin) {
    if(sc.retcode!=0) {
      fprintf(stderr,"Errors encountered reading %s\n",file_name);
    }
    if(isfile) {
      fclose(fin);
    }
      }
    }
    file_name=*argv++;
  } while(file_name!=0);
  if(argc==1) {
    scheme_load_named_file(&sc,stdin,0);
  }
  retcode=sc.retcode;
  scheme_deinit(&sc);

  return retcode;
}

Here is the call graph for this function:

static void mark ( cell_ptr  a) [static]

Definition at line 1215 of file scheme.c.

                             {
     cell_ptr t, q, p;

     t = (cell_ptr) 0;
     p = a;
E2:  setmark(p);
     if(is_vector(p)) {
          int i;
          int num=ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
          for(i=0; i<num; i++) {
               /* Vector cells will be treated like ordinary cells */
               mark(p+1+i);
          }
     }
     if (is_atom(p))
          goto E6;
     /* E4: down car */
     q = car(p);
     if (q && !is_mark(q)) {
          setatom(p);  /* a note that we have moved car */
          car(p) = t;
          t = p;
          p = q;
          goto E2;
     }
 E5:  q = cdr(p); /* down cdr */
     if (q && !is_mark(q)) {
          cdr(p) = t;
          t = p;
          p = q;
          goto E2;
     }
E6:   /* up.  Undo the link switching from steps E4 and E5. */
     if (!t)
          return;
     q = t;
     if (is_atom(q)) {
          clratom(q);
          t = car(q);
          car(q) = p;
          p = q;
          goto E5;
     } else {
          t = cdr(q);
          cdr(q) = p;
          p = q;
          goto E6;
     }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr mk_atom ( scheme sc,
char *  q 
) [static]

Definition at line 1089 of file scheme.c.

                                             {
     char    c, *p;
     int has_dec_point=0;
     int has_fp_exp = 0;

#if USE_COLON_HOOK
     if((p=strstr(q,"::"))!=0) {
          *p=0;
          return cons(sc, sc->COLON_HOOK,
                          cons(sc,
                              cons(sc,
                                   sc->QUOTE,
                                   cons(sc, mk_atom(sc,p+2), sc->NIL)),
                              cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL)));
     }
#endif

     p = q;
     c = *p++;
     if ((c == '+') || (c == '-')) {
       c = *p++;
       if (c == '.') {
         has_dec_point=1;
     c = *p++;
       }
       if (!isdigit(c)) {
     return (mk_symbol(sc, strlwr(q)));
       }
     } else if (c == '.') {
       has_dec_point=1;
       c = *p++;
       if (!isdigit(c)) {
     return (mk_symbol(sc, strlwr(q)));
       }
     } else if (!isdigit(c)) {
       return (mk_symbol(sc, strlwr(q)));
     }

     for ( ; (c = *p) != 0; ++p) {
          if (!isdigit(c)) {
               if(c=='.') {
                    if(!has_dec_point) {
                         has_dec_point=1;
                         continue;
                    }
               }
               else if ((c == 'e') || (c == 'E')) {
                       if(!has_fp_exp) {
                          has_dec_point = 1; /* decimal point illegal
                                                from now on */
                          p++;
                          if ((*p == '-') || (*p == '+') || isdigit(*p)) {
                             continue;
                          }
                       }
               }
               return (mk_symbol(sc, strlwr(q)));
          }
     }
     if(has_dec_point) {
          return mk_real(sc,atof(q));
     }
     return (mk_integer(sc, atol(q)));
}

Here is the call graph for this function:

Here is the caller graph for this function:

INTERFACE cell_ptr mk_blackbox ( scheme sc,
void *  blackbox 
)

Definition at line 1014 of file scheme.c.

                                                           {
       cell_ptr x = get_cell(sc, sc->NIL, sc->NIL);
       typeflag(x) = (T_BLACKBOX | T_ATOM);
       car(x) = blackbox;
       return (x);
}

Here is the call graph for this function:

Here is the caller graph for this function:

INTERFACE cell_ptr mk_character ( scheme sc,
int  c 
)

Definition at line 939 of file scheme.c.

                                                   {
  cell_ptr x = get_cell(sc,sc->NIL, sc->NIL);

  typeflag(x) = (T_CHARACTER | T_ATOM);
  ivalue_unchecked(x)= c;
  set_num_integer(x);
  return (x);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr mk_closure ( scheme sc,
cell_ptr  c,
cell_ptr  e 
) [static]

Definition at line 2023 of file scheme.c.

                                                               {
     cell_ptr x = get_cell(sc, c, e);

     typeflag(x) = T_CLOSURE;
     car(x) = c;
     cdr(x) = e;
     return (x);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr mk_continuation ( scheme sc,
cell_ptr  d 
) [static]

Definition at line 2033 of file scheme.c.

                                                        {
     cell_ptr x = get_cell(sc, sc->NIL, d);

     typeflag(x) = T_CONTINUATION;
     cont_dump(x) = d;
     return (x);
}

Here is the call graph for this function:

Here is the caller graph for this function:

INTERFACE cell_ptr mk_counted_string ( scheme sc,
const char *  str,
int  len 
)

Definition at line 998 of file scheme.c.

                                                                           {
     cell_ptr x = get_cell(sc, sc->NIL, sc->NIL);
     typeflag(x) = (T_STRING | T_ATOM);
     strvalue(x) = store_string(sc,len,str,0);
     strlength(x) = len;
     return (x);
}

Here is the call graph for this function:

Here is the caller graph for this function:

INTERFACE cell_ptr mk_empty_string ( scheme sc,
int  len,
char  fill 
)

Definition at line 1006 of file scheme.c.

                                                                   {
     cell_ptr x = get_cell(sc, sc->NIL, sc->NIL);
     typeflag(x) = (T_STRING | T_ATOM);
     strvalue(x) = store_string(sc,len,0,fill);
     strlength(x) = len;
     return (x);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 931 of file scheme.c.

                                                     {
  cell_ptr x = get_cell(sc, sc->NIL, sc->NIL);

  typeflag(x) = (T_FOREIGN | T_ATOM);
  x->_object._ff=f;
  return (x);
}

Here is the call graph for this function:

Here is the caller graph for this function:

INTERFACE cell_ptr mk_integer ( scheme sc,
long  num 
)

Definition at line 949 of file scheme.c.

                                                    {
  cell_ptr x = get_cell(sc,sc->NIL, sc->NIL);

  typeflag(x) = (T_NUMBER | T_ATOM);
  ivalue_unchecked(x)= num;
  set_num_integer(x);
  return (x);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr mk_number ( scheme sc,
num  n 
) [static]

Definition at line 967 of file scheme.c.

                                             {
 if(n.is_fixnum) {
     return mk_integer(sc,n.value.ivalue);
 } else {
     return mk_real(sc,n.value.rvalue);
 }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr mk_port ( scheme sc,
port p 
) [static]

Definition at line 923 of file scheme.c.

                                             {
  cell_ptr x = get_cell(sc, sc->NIL, sc->NIL);

  typeflag(x) = T_PORT|T_ATOM;
  x->_object._port=p;
  return (x);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr mk_proc ( scheme sc,
enum scheme_opcodes  op 
) [static]

Definition at line 4414 of file scheme.c.

                                                            {
     cell_ptr y;

     y = get_cell(sc, sc->NIL, sc->NIL);
     typeflag(y) = (T_PROC | T_ATOM);
     ivalue_unchecked(y) = (long) op;
     set_num_integer(y);
     return y;
}

Here is the call graph for this function:

Here is the caller graph for this function:

INTERFACE cell_ptr mk_real ( scheme sc,
double  n 
)

Definition at line 958 of file scheme.c.

                                                 {
  cell_ptr x = get_cell(sc,sc->NIL, sc->NIL);

  typeflag(x) = (T_NUMBER | T_ATOM);
  rvalue_unchecked(x)= n;
  set_num_real(x);
  return (x);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr mk_sharp_const ( scheme sc,
char *  name 
) [static]

Definition at line 1155 of file scheme.c.

                                                       {
     long    x;
     char    tmp[STRBUFFSIZE];

     if (!strcmp(name, "t"))
          return (sc->T);
     else if (!strcmp(name, "f"))
          return (sc->F);
     else if (*name == 'o') {/* #o (octal) */
          snprintf(tmp, STRBUFFSIZE, "0%s", name+1);
          sscanf(tmp, "%lo", &x);
          return (mk_integer(sc, x));
     } else if (*name == 'd') {    /* #d (decimal) */
          sscanf(name+1, "%ld", &x);
          return (mk_integer(sc, x));
     } else if (*name == 'x') {    /* #x (hex) */
          snprintf(tmp, STRBUFFSIZE, "0x%s", name+1);
          sscanf(tmp, "%lx", &x);
          return (mk_integer(sc, x));
     } else if (*name == 'b') {    /* #b (binary) */
          x = binary_decode(name+1);
          return (mk_integer(sc, x));
     } else if (*name == '\\') { /* #\w (character) */
          int c=0;
          if(stricmp(name+1,"space")==0) {
               c=' ';
          } else if(stricmp(name+1,"newline")==0) {
               c='\n';
          } else if(stricmp(name+1,"return")==0) {
               c='\r';
          } else if(stricmp(name+1,"tab")==0) {
               c='\t';
     } else if(name[1]=='x' && name[2]!=0) {
          int c1=0;
          if(sscanf(name+2,"%x",&c1)==1 && c1 < UCHAR_MAX) {
               c=c1;
          } else {
               return sc->NIL;
     }
#if USE_ASCII_NAMES
          } else if(is_ascii_name(name+1,&c)) {
               /* nothing */
#endif
          } else if(name[2]==0) {
               c=name[1];
          } else {
               return sc->NIL;
          }
          return mk_character(sc,c);
     } else
          return (sc->NIL);
}

Here is the call graph for this function:

Here is the caller graph for this function:

INTERFACE cell_ptr mk_string ( scheme sc,
const char *  str 
)

Definition at line 994 of file scheme.c.

                                                          {
     return mk_counted_string(sc,str,strlen(str));
}

Here is the call graph for this function:

Here is the caller graph for this function:

INTERFACE cell_ptr mk_symbol ( scheme sc,
const char *  name 
)

Definition at line 1054 of file scheme.c.

                                                           {
     cell_ptr x;

     /* first check oblist */
     x = oblist_find_by_name(sc, name);
     if (x != sc->NIL) {
          return (x);
     } else {
          x = oblist_add_by_name(sc, name);
          return (x);
     }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static INTERFACE cell_ptr mk_vector ( scheme sc,
int  len 
) [static]

Definition at line 1021 of file scheme.c.

{ return get_vector_object(sc,len,sc->NIL); }

Here is the call graph for this function:

Here is the caller graph for this function:

static void new_frame_in_env ( scheme sc,
cell_ptr  old_env 
) [static]

Definition at line 2165 of file scheme.c.

{
  cell_ptr new_frame;

  /* The interaction-environment has about 300 variables in it. */
  if (old_env == sc->NIL) {
    new_frame = mk_vector(sc, 461);
  } else {
    new_frame = sc->NIL;
  }

  sc->envir = immutable_cons(sc, new_frame, old_env);
  setenvironment(sc->envir);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static INLINE void new_slot_in_env ( scheme sc,
cell_ptr  variable,
cell_ptr  value 
) [static]

Definition at line 2263 of file scheme.c.

{
  new_slot_spec_in_env(sc, sc->envir, variable, value);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static INLINE void new_slot_spec_in_env ( scheme sc,
cell_ptr  env,
cell_ptr  variable,
cell_ptr  value 
) [static]

Definition at line 2180 of file scheme.c.

{
  cell_ptr slot = immutable_cons(sc, variable, value);

  if (is_vector(car(env))) {
    int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));

    set_vector_elem(car(env), location,
                    immutable_cons(sc, slot, vector_elem(car(env), location)));
  } else {
    car(env) = immutable_cons(sc, slot, car(env));
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static num num_add ( num  a,
num  b 
) [static]

Definition at line 391 of file scheme.c.

                                 {
 num ret;
 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
 if(ret.is_fixnum) {
     ret.value.ivalue= a.value.ivalue+b.value.ivalue;
 } else {
     ret.value.rvalue=num_rvalue(a)+num_rvalue(b);
 }
 return ret;
}

Here is the caller graph for this function:

static num num_div ( num  a,
num  b 
) [static]

Definition at line 413 of file scheme.c.

                                 {
 num ret;
 ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0;
 if(ret.is_fixnum) {
     ret.value.ivalue= a.value.ivalue/b.value.ivalue;
 } else {
     ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
 }
 return ret;
}

Here is the caller graph for this function:

static int num_eq ( num  a,
num  b 
) [static]

Definition at line 486 of file scheme.c.

                                {
 int ret;
 int is_fixnum=a.is_fixnum && b.is_fixnum;
 if(is_fixnum) {
     ret= a.value.ivalue==b.value.ivalue;
 } else {
     ret=num_rvalue(a)==num_rvalue(b);
 }
 return ret;
}

Here is the caller graph for this function:

static int num_ge ( num  a,
num  b 
) [static]

Definition at line 509 of file scheme.c.

                                {
 return !num_lt(a,b);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int num_gt ( num  a,
num  b 
) [static]

Definition at line 498 of file scheme.c.

                                {
 int ret;
 int is_fixnum=a.is_fixnum && b.is_fixnum;
 if(is_fixnum) {
     ret= a.value.ivalue>b.value.ivalue;
 } else {
     ret=num_rvalue(a)>num_rvalue(b);
 }
 return ret;
}

Here is the caller graph for this function:

static num num_intdiv ( num  a,
num  b 
) [static]

Definition at line 424 of file scheme.c.

                                    {
 num ret;
 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
 if(ret.is_fixnum) {
     ret.value.ivalue= a.value.ivalue/b.value.ivalue;
 } else {
     ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
 }
 return ret;
}

Here is the caller graph for this function:

static INLINE int num_is_integer ( cell_ptr  p) [static]

Definition at line 160 of file scheme.c.

                                             {
  return ((p)->_object._number.is_fixnum);
}

Here is the caller graph for this function:

static int num_le ( num  a,
num  b 
) [static]

Definition at line 524 of file scheme.c.

                                {
 return !num_gt(a,b);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int num_lt ( num  a,
num  b 
) [static]

Definition at line 513 of file scheme.c.

                                {
 int ret;
 int is_fixnum=a.is_fixnum && b.is_fixnum;
 if(is_fixnum) {
     ret= a.value.ivalue<b.value.ivalue;
 } else {
     ret=num_rvalue(a)<num_rvalue(b);
 }
 return ret;
}

Here is the caller graph for this function:

static num num_mod ( num  a,
num  b 
) [static]

Definition at line 467 of file scheme.c.

                                 {
 num ret;
 long e1, e2, res;
 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
 e1=num_ivalue(a);
 e2=num_ivalue(b);
 res=e1%e2;
 if(res*e2<0) {    /* modulo should have same sign as second operand */
     e2=labs(e2);
     if(res>0) {
          res-=e2;
     } else {
          res+=e2;
     }
 }
 ret.value.ivalue=res;
 return ret;
}

Here is the caller graph for this function:

static num num_mul ( num  a,
num  b 
) [static]

Definition at line 402 of file scheme.c.

                                 {
 num ret;
 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
 if(ret.is_fixnum) {
     ret.value.ivalue= a.value.ivalue*b.value.ivalue;
 } else {
     ret.value.rvalue=num_rvalue(a)*num_rvalue(b);
 }
 return ret;
}

Here is the caller graph for this function:

static num num_rem ( num  a,
num  b 
) [static]

Definition at line 446 of file scheme.c.

                                 {
 num ret;
 long e1, e2, res;
 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
 e1=num_ivalue(a);
 e2=num_ivalue(b);
 res=e1%e2;
 /* modulo should have same sign as second operand */
 if (res > 0) {
     if (e1 < 0) {
        res -= labs(e2);
     }
 } else if (res < 0) {
     if (e1 > 0) {
         res += labs(e2);
     }
 }
 ret.value.ivalue=res;
 return ret;
}

Here is the caller graph for this function:

static num num_sub ( num  a,
num  b 
) [static]

Definition at line 435 of file scheme.c.

                                 {
 num ret;
 ret.is_fixnum=a.is_fixnum && b.is_fixnum;
 if(ret.is_fixnum) {
     ret.value.ivalue= a.value.ivalue-b.value.ivalue;
 } else {
     ret.value.rvalue=num_rvalue(a)-num_rvalue(b);
 }
 return ret;
}

Here is the caller graph for this function:

Definition at line 192 of file scheme.c.

{ return ((p)->_object._number); }

Here is the caller graph for this function:

static cell_ptr oblist_add_by_name ( scheme sc,
const char *  name 
) [static]

Definition at line 837 of file scheme.c.

{
  cell_ptr x;
  int location;

  x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
  typeflag(x) = T_SYMBOL;
  setimmutable(car(x));

  location = hash_fn(name, ivalue_unchecked(sc->oblist));
  set_vector_elem(sc->oblist, location,
                  immutable_cons(sc, x, vector_elem(sc->oblist, location)));
  return x;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr oblist_all_symbols ( scheme sc) [static]

Definition at line 869 of file scheme.c.

{
  int i;
  cell_ptr x;
  cell_ptr ob_list = sc->NIL;

  for (i = 0; i < ivalue_unchecked(sc->oblist); i++) {
    for (x  = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) {
      ob_list = cons(sc, x, ob_list);
    }
  }
  return ob_list;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static INLINE cell_ptr oblist_find_by_name ( scheme sc,
const char *  name 
) [static]

Definition at line 852 of file scheme.c.

{
  int location;
  cell_ptr x;
  char *s;

  location = hash_fn(name, ivalue_unchecked(sc->oblist));
  for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
    s = symname(car(x));
    /* case-insensitive, per R5RS section 2. */
    if(stricmp(name, s) == 0) {
      return car(x);
    }
  }
  return sc->NIL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr oblist_initial_value ( scheme sc) [static]

Definition at line 831 of file scheme.c.

{
  return mk_vector(sc, 461); /* probably should be bigger */
}

Here is the call graph for this function:

Here is the caller graph for this function:

static INLINE void ok_to_freely_gc ( scheme sc) [static]

Definition at line 780 of file scheme.c.

{
  car(sc->sink) = sc->NIL;
}

Here is the caller graph for this function:

static cell_ptr opexe_0 ( scheme sc,
enum scheme_opcodes  op 
) [static]

Definition at line 2472 of file scheme.c.

                                                            {
     cell_ptr x, y;

     switch (op) {
     case OP_LOAD:       /* load */
          if(file_interactive(sc)) {
               fprintf(sc->outport->_object._port->rep.stdio.file,
               "Loading %s\n", strvalue(car(sc->args)));
          }
          if (!file_push(sc,strvalue(car(sc->args)))) {
               Error_1(sc,"unable to open", car(sc->args));
          }
      else
        {
          sc->args = mk_integer(sc,sc->file_i);
          s_goto(sc,OP_T0LVL);
        }

     case OP_T0LVL: /* top level */
       /* If we reached the end of file, this loop is done. */
       if(sc->loadport->_object._port->kind & port_saw_EOF)
     {
       if(sc->file_i == 0)
         {
           sc->args=sc->NIL;
           s_goto(sc,OP_QUIT);
         }
       else
         {
           file_pop(sc);
           s_return(sc,sc->value);
         }
       /* NOTREACHED */
     }

       /* If interactive, be nice to user. */
       if(file_interactive(sc))
     {
       sc->envir = sc->global_env;
       dump_stack_reset(sc);
       putstr(sc,"\n");
       putstr(sc,prompt);
     }

       /* Set up another iteration of REPL */
       sc->nesting=0;
       sc->save_inport=sc->inport;
       sc->inport = sc->loadport;
       s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
       s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
       s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
       s_goto(sc,OP_READ_INTERNAL);

     case OP_T1LVL: /* top level */
          sc->code = sc->value;
          sc->inport=sc->save_inport;
          s_goto(sc,OP_EVAL);

     case OP_READ_INTERNAL:       /* internal read */
          sc->tok = token(sc);
          if(sc->tok==TOK_EOF)
        { s_return(sc,sc->EOF_OBJ); }
          s_goto(sc,OP_RDSEXPR);

     case OP_GENSYM:
          s_return(sc, gensym(sc));

     case OP_VALUEPRINT: /* print evaluation result */
          /* OP_VALUEPRINT is always pushed, because when changing from
             non-interactive to interactive mode, it needs to be
             already on the stack */
       if(sc->tracing) {
     putstr(sc,"\nGives: ");
       }
       if(file_interactive(sc)) {
     sc->print_flag = 1;
     sc->args = sc->value;
     s_goto(sc,OP_P0LIST);
       } else {
     s_return(sc,sc->value);
       }

     case OP_EVAL:       /* main part of evaluation */
#if USE_TRACING
       if(sc->tracing) {
     /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
     s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
     sc->args=sc->code;
     putstr(sc,"\nEval: ");
     s_goto(sc,OP_P0LIST);
       }
       /* fall through */
     case OP_REAL_EVAL:
#endif
          if (is_symbol(sc->code)) {    /* symbol */
               x=find_slot_in_env(sc,sc->envir,sc->code,1);
               if (x != sc->NIL) {
                    s_return(sc,slot_value_in_env(x));
               } else {
                    Error_1(sc,"eval: unbound variable:", sc->code);
               }
          } else if (is_pair(sc->code)) {
               if (is_syntax(x = car(sc->code))) {     /* SYNTAX */
                    sc->code = cdr(sc->code);
                    s_goto(sc,syntaxnum(x));
               } else {/* first, eval top element and eval arguments */
                    s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
                    /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
                    sc->code = car(sc->code);
                    s_goto(sc,OP_EVAL);
               }
          } else {
               s_return(sc,sc->code);
          }

     case OP_E0ARGS:     /* eval arguments */
          if (is_macro(sc->value)) {    /* macro expansion */
               s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
               sc->args = cons(sc,sc->code, sc->NIL);
               sc->code = sc->value;
               s_goto(sc,OP_APPLY);
          } else {
               sc->code = cdr(sc->code);
               s_goto(sc,OP_E1ARGS);
          }

     case OP_E1ARGS:     /* eval arguments */
          sc->args = cons(sc, sc->value, sc->args);
          if (is_pair(sc->code)) { /* continue */
               s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
               sc->code = car(sc->code);
               sc->args = sc->NIL;
               s_goto(sc,OP_EVAL);
          } else {  /* end */
               sc->args = reverse_in_place(sc, sc->NIL, sc->args);
               sc->code = car(sc->args);
               sc->args = cdr(sc->args);
               s_goto(sc,OP_APPLY);
          }

#if USE_TRACING
     case OP_TRACING: {
       int tr=sc->tracing;
       sc->tracing=ivalue(car(sc->args));
       s_return(sc,mk_integer(sc,tr));
     }
#endif

     case OP_APPLY:      /* apply 'code' to 'args' */
#if USE_TRACING
       if(sc->tracing) {
     s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
     sc->print_flag = 1;
     /*  sc->args=cons(sc,sc->code,sc->args);*/
         putstr(sc,"\nApply to: ");
     s_goto(sc,OP_P0LIST);
       }
       /* fall through */
     case OP_REAL_APPLY:
#endif
          if (is_proc(sc->code)) {
               s_goto(sc,procnum(sc->code));   /* PROCEDURE */
          } else if (is_foreign(sc->code))
            {
              /* Keep nested calls from GC'ing the arglist */
              push_recent_alloc(sc,sc->args,sc->NIL);
               x=sc->code->_object._ff(sc,sc->args);
               s_return(sc,x);
          } else if (is_closure(sc->code) || is_macro(sc->code)
             || is_promise(sc->code)) { /* CLOSURE */
        /* Should not accept promise */
               /* make environment */
               new_frame_in_env(sc, closure_env(sc->code));
               for (x = car(closure_code(sc->code)), y = sc->args;
                    is_pair(x); x = cdr(x), y = cdr(y)) {
                    if (y == sc->NIL) {
                         Error_0(sc,"not enough arguments");
                    } else {
                         new_slot_in_env(sc, car(x), car(y));
                    }
               }
               if (x == sc->NIL) {
                    /*--
                     * if (y != sc->NIL) {
                     *   Error_0(sc,"too many arguments");
                     * }
                     */
               } else if (is_symbol(x))
                    new_slot_in_env(sc, x, y);
               else {
                    Error_1(sc,"syntax error in closure: not a symbol:", x);
               }
               sc->code = cdr(closure_code(sc->code));
               sc->args = sc->NIL;
               s_goto(sc,OP_BEGIN);
          } else if (is_continuation(sc->code)) { /* CONTINUATION */
               sc->dump = cont_dump(sc->code);
               s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
          } else {
               Error_0(sc,"illegal function");
          }

     case OP_DOMACRO:    /* do macro */
          sc->code = sc->value;
          s_goto(sc,OP_EVAL);

#if 1
     case OP_LAMBDA:     /* lambda */
          /* If the hook is defined, apply it to sc->code, otherwise
             set sc->value fall thru */
          {
               cell_ptr f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
               if(f==sc->NIL) {
                    sc->value = sc->code;
                    /* Fallthru */
               } else {
                    s_save(sc,OP_LAMBDA1,sc->args,sc->code);
                    sc->args=cons(sc,sc->code,sc->NIL);
                    sc->code=slot_value_in_env(f);
                    s_goto(sc,OP_APPLY);
               }
          }

     case OP_LAMBDA1:
          s_return(sc,mk_closure(sc, sc->value, sc->envir));

#else
     case OP_LAMBDA:     /* lambda */
          s_return(sc,mk_closure(sc, sc->code, sc->envir));

#endif

     case OP_MKCLOSURE: /* make-closure */
       x=car(sc->args);
       if(car(x)==sc->LAMBDA) {
     x=cdr(x);
       }
       if(cdr(sc->args)==sc->NIL) {
     y=sc->envir;
       } else {
     y=cadr(sc->args);
       }
       s_return(sc,mk_closure(sc, x, y));

     case OP_QUOTE:      /* quote */
          x=car(sc->code);
          s_return(sc,car(sc->code));

     case OP_DEF0:  /* define */
          if(is_immutable(car(sc->code)))
            Error_1(sc,"define: unable to alter immutable", car(sc->code));

          if (is_pair(car(sc->code))) {
               x = caar(sc->code);
               sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
          } else {
               x = car(sc->code);
               sc->code = cadr(sc->code);
          }
          if (!is_symbol(x)) {
               Error_0(sc,"variable is not a symbol");
          }
          s_save(sc,OP_DEF1, sc->NIL, x);
          s_goto(sc,OP_EVAL);

     case OP_DEF1:  /* define */
       x=find_slot_in_env(sc,sc->envir,sc->code,0);
          if (x != sc->NIL) {
               set_slot_in_env(sc, x, sc->value);
          } else {
               new_slot_in_env(sc, sc->code, sc->value);
          }
          s_return(sc,sc->code);


     case OP_DEFP:  /* defined? */
          x=sc->envir;
          if(cdr(sc->args)!=sc->NIL) {
               x=cadr(sc->args);
          }
          s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);

     case OP_SET0:       /* set! */
          if(is_immutable(car(sc->code)))
                Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
          s_save(sc,OP_SET1, sc->NIL, car(sc->code));
          sc->code = cadr(sc->code);
          s_goto(sc,OP_EVAL);

     case OP_SET1:       /* set! */
       y=find_slot_in_env(sc,sc->envir,sc->code,1);
          if (y != sc->NIL) {
               set_slot_in_env(sc, y, sc->value);
               s_return(sc,sc->value);
          } else {
               Error_1(sc,"set!: unbound variable:", sc->code);
          }


     case OP_BEGIN:      /* begin */
          if (!is_pair(sc->code)) {
               s_return(sc,sc->code);
          }
          if (cdr(sc->code) != sc->NIL) {
               s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
          }
          sc->code = car(sc->code);
          s_goto(sc,OP_EVAL);

     case OP_IF0:        /* if */
          s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
          sc->code = car(sc->code);
          s_goto(sc,OP_EVAL);

     case OP_IF1:        /* if */
          if (is_true(sc->value))
               sc->code = car(sc->code);
          else
               sc->code = cadr(sc->code);  /* (if #f 1) ==> () because
                               * car(sc->NIL) = sc->NIL */
          s_goto(sc,OP_EVAL);

     case OP_LET0:       /* let */
          sc->args = sc->NIL;
          sc->value = sc->code;
          sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
          s_goto(sc,OP_LET1);

     case OP_LET1:       /* let (calculate parameters) */
          sc->args = cons(sc, sc->value, sc->args);
          if (is_pair(sc->code)) { /* continue */
               if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
                    Error_1(sc, "Bad syntax of binding spec in let :",
                            car(sc->code));
               }
               s_save(sc,OP_LET1, sc->args, cdr(sc->code));
               sc->code = cadar(sc->code);
               sc->args = sc->NIL;
               s_goto(sc,OP_EVAL);
          } else {  /* end */
               sc->args = reverse_in_place(sc, sc->NIL, sc->args);
               sc->code = car(sc->args);
               sc->args = cdr(sc->args);
               s_goto(sc,OP_LET2);
          }

     case OP_LET2:       /* let */
          new_frame_in_env(sc, sc->envir);
          for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
               y != sc->NIL; x = cdr(x), y = cdr(y)) {
               new_slot_in_env(sc, caar(x), car(y));
          }
          if (is_symbol(car(sc->code))) {    /* named let */
               for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
                    if (!is_pair(x))
                        Error_1(sc, "Bad syntax of binding in let :", x);
                    if (!is_list(sc, car(x)))
                        Error_1(sc, "Bad syntax of binding in let :", car(x));
                    sc->args = cons(sc, caar(x), sc->args);
               }
               x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
               new_slot_in_env(sc, car(sc->code), x);
               sc->code = cddr(sc->code);
               sc->args = sc->NIL;
          } else {
               sc->code = cdr(sc->code);
               sc->args = sc->NIL;
          }
          s_goto(sc,OP_BEGIN);

     case OP_LET0AST:    /* let* */
          if (car(sc->code) == sc->NIL) {
               new_frame_in_env(sc, sc->envir);
               sc->code = cdr(sc->code);
               s_goto(sc,OP_BEGIN);
          }
          if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
               Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
          }
          s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
          sc->code = cadaar(sc->code);
          s_goto(sc,OP_EVAL);

     case OP_LET1AST:    /* let* (make new frame) */
          new_frame_in_env(sc, sc->envir);
          s_goto(sc,OP_LET2AST);

     case OP_LET2AST:    /* let* (calculate parameters) */
          new_slot_in_env(sc, caar(sc->code), sc->value);
          sc->code = cdr(sc->code);
          if (is_pair(sc->code)) { /* continue */
               s_save(sc,OP_LET2AST, sc->args, sc->code);
               sc->code = cadar(sc->code);
               sc->args = sc->NIL;
               s_goto(sc,OP_EVAL);
          } else {  /* end */
               sc->code = sc->args;
               sc->args = sc->NIL;
               s_goto(sc,OP_BEGIN);
          }
     default:
          snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
          Error_0(sc,sc->strbuff);
     }
     return sc->T;
}

Here is the call graph for this function:

static cell_ptr opexe_1 ( scheme sc,
enum scheme_opcodes  op 
) [static]

Definition at line 2879 of file scheme.c.

                                                            {
     cell_ptr x, y;

     switch (op) {
     case OP_LET0REC:    /* letrec */
          new_frame_in_env(sc, sc->envir);
          sc->args = sc->NIL;
          sc->value = sc->code;
          sc->code = car(sc->code);
          s_goto(sc,OP_LET1REC);

     case OP_LET1REC:    /* letrec (calculate parameters) */
          sc->args = cons(sc, sc->value, sc->args);
          if (is_pair(sc->code)) { /* continue */
               if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
                    Error_1(sc, "Bad syntax of binding spec in letrec :",
                            car(sc->code));
               }
               s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
               sc->code = cadar(sc->code);
               sc->args = sc->NIL;
               s_goto(sc,OP_EVAL);
          } else {  /* end */
               sc->args = reverse_in_place(sc, sc->NIL, sc->args);
               sc->code = car(sc->args);
               sc->args = cdr(sc->args);
               s_goto(sc,OP_LET2REC);
          }

     case OP_LET2REC:    /* letrec */
          for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
               new_slot_in_env(sc, caar(x), car(y));
          }
          sc->code = cdr(sc->code);
          sc->args = sc->NIL;
          s_goto(sc,OP_BEGIN);

     case OP_COND0:      /* cond */
          if (!is_pair(sc->code)) {
               Error_0(sc,"syntax error in cond");
          }
          s_save(sc,OP_COND1, sc->NIL, sc->code);
          sc->code = caar(sc->code);
          s_goto(sc,OP_EVAL);

     case OP_COND1:      /* cond */
          if (is_true(sc->value)) {
               if ((sc->code = cdar(sc->code)) == sc->NIL) {
                    s_return(sc,sc->value);
               }
               if(car(sc->code)==sc->FEED_TO) {
                    if(!is_pair(cdr(sc->code))) {
                         Error_0(sc,"syntax error in cond");
                    }
                    x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
                    sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
                    s_goto(sc,OP_EVAL);
               }
               s_goto(sc,OP_BEGIN);
          } else {
               if ((sc->code = cdr(sc->code)) == sc->NIL) {
                    s_return(sc,sc->NIL);
               } else {
                    s_save(sc,OP_COND1, sc->NIL, sc->code);
                    sc->code = caar(sc->code);
                    s_goto(sc,OP_EVAL);
               }
          }

     case OP_DELAY:      /* delay */
          x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
          typeflag(x)=T_PROMISE;
          s_return(sc,x);

     case OP_AND0:       /* and */
          if (sc->code == sc->NIL) {
               s_return(sc,sc->T);
          }
          s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
          sc->code = car(sc->code);
          s_goto(sc,OP_EVAL);

     case OP_AND1:       /* and */
          if (is_false(sc->value)) {
               s_return(sc,sc->value);
          } else if (sc->code == sc->NIL) {
               s_return(sc,sc->value);
          } else {
               s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
               sc->code = car(sc->code);
               s_goto(sc,OP_EVAL);
          }

     case OP_OR0:        /* or */
          if (sc->code == sc->NIL) {
               s_return(sc,sc->F);
          }
          s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
          sc->code = car(sc->code);
          s_goto(sc,OP_EVAL);

     case OP_OR1:        /* or */
          if (is_true(sc->value)) {
               s_return(sc,sc->value);
          } else if (sc->code == sc->NIL) {
               s_return(sc,sc->value);
          } else {
               s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
               sc->code = car(sc->code);
               s_goto(sc,OP_EVAL);
          }

     case OP_C0STREAM:   /* cons-stream */
          s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
          sc->code = car(sc->code);
          s_goto(sc,OP_EVAL);

     case OP_C1STREAM:   /* cons-stream */
          sc->args = sc->value;  /* save sc->value to register sc->args for gc */
          x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
          typeflag(x)=T_PROMISE;
          s_return(sc,cons(sc, sc->args, x));

     case OP_MACRO0:     /* macro */
          if (is_pair(car(sc->code))) {
               x = caar(sc->code);
               sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
          } else {
               x = car(sc->code);
               sc->code = cadr(sc->code);
          }
          if (!is_symbol(x)) {
               Error_0(sc,"variable is not a symbol");
          }
          s_save(sc,OP_MACRO1, sc->NIL, x);
          s_goto(sc,OP_EVAL);

     case OP_MACRO1:     /* macro */
          typeflag(sc->value) = T_MACRO;
          x = find_slot_in_env(sc, sc->envir, sc->code, 0);
          if (x != sc->NIL) {
               set_slot_in_env(sc, x, sc->value);
          } else {
               new_slot_in_env(sc, sc->code, sc->value);
          }
          s_return(sc,sc->code);

     case OP_CASE0:      /* case */
          s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
          sc->code = car(sc->code);
          s_goto(sc,OP_EVAL);

     case OP_CASE1:      /* case */
          for (x = sc->code; x != sc->NIL; x = cdr(x)) {
               if (!is_pair(y = caar(x))) {
                    break;
               }
               for ( ; y != sc->NIL; y = cdr(y)) {
                    if (eqv(car(y), sc->value)) {
                         break;
                    }
               }
               if (y != sc->NIL) {
                    break;
               }
          }
          if (x != sc->NIL) {
               if (is_pair(caar(x))) {
                    sc->code = cdar(x);
                    s_goto(sc,OP_BEGIN);
               } else {/* else */
                    s_save(sc,OP_CASE2, sc->NIL, cdar(x));
                    sc->code = caar(x);
                    s_goto(sc,OP_EVAL);
               }
          } else {
               s_return(sc,sc->NIL);
          }

     case OP_CASE2:      /* case */
          if (is_true(sc->value)) {
               s_goto(sc,OP_BEGIN);
          } else {
               s_return(sc,sc->NIL);
          }

     case OP_PAPPLY:     /* apply */
          sc->code = car(sc->args);
      sc->args = list_star(sc,cdr(sc->args));
          /*sc->args = cadr(sc->args);*/
          s_goto(sc,OP_APPLY);

     case OP_PEVAL: /* eval */
          if(cdr(sc->args)!=sc->NIL) {
               sc->envir=cadr(sc->args);
          }
          sc->code = car(sc->args);
          s_goto(sc,OP_EVAL);

     case OP_CONTINUATION:    /* call-with-current-continuation */
          sc->code = car(sc->args);
          sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
          s_goto(sc,OP_APPLY);

     default:
          snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
          Error_0(sc,sc->strbuff);
     }
     return sc->T;
}

Here is the call graph for this function:

static cell_ptr opexe_2 ( scheme sc,
enum scheme_opcodes  op 
) [static]

Definition at line 3090 of file scheme.c.

                                                            {
     cell_ptr x;
     num v;
#if USE_MATH
     double dd;
#endif

     switch (op) {
#if USE_MATH
     case OP_INEX2EX:    /* inexact->exact */
          x=car(sc->args);
          if(num_is_integer(x)) {
               s_return(sc,x);
          } else if(modf(rvalue_unchecked(x),&dd)==0.0) {
               s_return(sc,mk_integer(sc,ivalue(x)));
          } else {
               Error_1(sc,"inexact->exact: not integral:",x);
          }

     case OP_EXP:
          x=car(sc->args);
          s_return(sc, mk_real(sc, exp(rvalue(x))));

     case OP_LOG:
          x=car(sc->args);
          s_return(sc, mk_real(sc, log(rvalue(x))));

     case OP_SIN:
          x=car(sc->args);
          s_return(sc, mk_real(sc, sin(rvalue(x))));

     case OP_COS:
          x=car(sc->args);
          s_return(sc, mk_real(sc, cos(rvalue(x))));

     case OP_TAN:
          x=car(sc->args);
          s_return(sc, mk_real(sc, tan(rvalue(x))));

     case OP_ASIN:
          x=car(sc->args);
          s_return(sc, mk_real(sc, asin(rvalue(x))));

     case OP_ACOS:
          x=car(sc->args);
          s_return(sc, mk_real(sc, acos(rvalue(x))));

     case OP_ATAN:
          x=car(sc->args);
          if(cdr(sc->args)==sc->NIL) {
               s_return(sc, mk_real(sc, atan(rvalue(x))));
          } else {
               cell_ptr y=cadr(sc->args);
               s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
          }

     case OP_SQRT:
          x=car(sc->args);
          s_return(sc, mk_real(sc, sqrt(rvalue(x))));

     case OP_EXPT:
          x=car(sc->args);
          if(cdr(sc->args)==sc->NIL) {
               Error_0(sc,"expt: needs two arguments");
          } else {
               cell_ptr y=cadr(sc->args);
               s_return(sc, mk_real(sc, pow(rvalue(x),rvalue(y))));
          }

     case OP_FLOOR:
          x=car(sc->args);
      s_return(sc, mk_real(sc, floor(rvalue(x))));

     case OP_CEILING:
          x=car(sc->args);
      s_return(sc, mk_real(sc, ceil(rvalue(x))));

     case OP_TRUNCATE : {
      double rvalue_of_x ;
          x=car(sc->args);
      rvalue_of_x = rvalue(x) ;
      if (rvalue_of_x > 0) {
        s_return(sc, mk_real(sc, floor(rvalue_of_x)));
      } else {
        s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
      }
     }

     case OP_ROUND:
       x=car(sc->args);
       s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
#endif

     case OP_ADD:        /* + */
       v=num_zero;
       for (x = sc->args; x != sc->NIL; x = cdr(x)) {
     v=num_add(v,nvalue(car(x)));
       }
       s_return(sc,mk_number(sc, v));

     case OP_MUL:        /* * */
       v=num_one;
       for (x = sc->args; x != sc->NIL; x = cdr(x)) {
     v=num_mul(v,nvalue(car(x)));
       }
       s_return(sc,mk_number(sc, v));

     case OP_SUB:        /* - */
       if(cdr(sc->args)==sc->NIL) {
     x=sc->args;
     v=num_zero;
       } else {
     x = cdr(sc->args);
     v = nvalue(car(sc->args));
       }
       for (; x != sc->NIL; x = cdr(x)) {
     v=num_sub(v,nvalue(car(x)));
       }
       s_return(sc,mk_number(sc, v));

     case OP_DIV:        /* / */
       if(cdr(sc->args)==sc->NIL) {
     x=sc->args;
     v=num_one;
       } else {
     x = cdr(sc->args);
     v = nvalue(car(sc->args));
       }
       for (; x != sc->NIL; x = cdr(x)) {
     if (!is_zero_double(rvalue(car(x))))
       v=num_div(v,nvalue(car(x)));
     else {
       Error_0(sc,"/: division by zero");
     }
       }
       s_return(sc,mk_number(sc, v));

     case OP_INTDIV:        /* quotient */
          if(cdr(sc->args)==sc->NIL) {
               x=sc->args;
               v=num_one;
          } else {
               x = cdr(sc->args);
               v = nvalue(car(sc->args));
          }
          for (; x != sc->NIL; x = cdr(x)) {
               if (ivalue(car(x)) != 0)
                    v=num_intdiv(v,nvalue(car(x)));
               else {
                    Error_0(sc,"quotient: division by zero");
               }
          }
          s_return(sc,mk_number(sc, v));

     case OP_REM:        /* remainder */
          v = nvalue(car(sc->args));
          if (ivalue(cadr(sc->args)) != 0)
               v=num_rem(v,nvalue(cadr(sc->args)));
          else {
               Error_0(sc,"remainder: division by zero");
          }
          s_return(sc,mk_number(sc, v));

     case OP_MOD:        /* modulo */
          v = nvalue(car(sc->args));
          if (ivalue(cadr(sc->args)) != 0)
               v=num_mod(v,nvalue(cadr(sc->args)));
          else {
               Error_0(sc,"modulo: division by zero");
          }
          s_return(sc,mk_number(sc, v));

     case OP_CAR:        /* car */
       s_return(sc,caar(sc->args));

     case OP_CDR:        /* cdr */
       s_return(sc,cdar(sc->args));

     case OP_CONS:       /* cons */
          cdr(sc->args) = cadr(sc->args);
          s_return(sc,sc->args);

     case OP_SETCAR:     /* set-car! */
       if(!is_immutable(car(sc->args))) {
     caar(sc->args) = cadr(sc->args);
     s_return(sc,car(sc->args));
       } else {
     Error_0(sc,"set-car!: unable to alter immutable pair");
       }

     case OP_SETCDR:     /* set-cdr! */
       if(!is_immutable(car(sc->args))) {
     cdar(sc->args) = cadr(sc->args);
     s_return(sc,car(sc->args));
       } else {
     Error_0(sc,"set-cdr!: unable to alter immutable pair");
       }

     case OP_CHAR2INT: { /* char->integer */
          char c;
          c=(char)ivalue(car(sc->args));
          s_return(sc,mk_integer(sc,(unsigned char)c));
     }

     case OP_INT2CHAR: { /* integer->char */
          unsigned char c;
          c=(unsigned char)ivalue(car(sc->args));
          s_return(sc,mk_character(sc,(char)c));
     }

     case OP_CHARUPCASE: {
          unsigned char c;
          c=(unsigned char)ivalue(car(sc->args));
          c=toupper(c);
          s_return(sc,mk_character(sc,(char)c));
     }

     case OP_CHARDNCASE: {
          unsigned char c;
          c=(unsigned char)ivalue(car(sc->args));
          c=tolower(c);
          s_return(sc,mk_character(sc,(char)c));
     }

     case OP_STR2SYM:  /* string->symbol */
          s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));

     case OP_STR2ATOM: /* string->atom */ {
       char *s=strvalue(car(sc->args));
       if(*s=='#') {
     s_return(sc, mk_sharp_const(sc, s+1));
       } else {
     s_return(sc, mk_atom(sc, s));
       }
     }

     case OP_SYM2STR: /* symbol->string */
          x=mk_string(sc,symname(car(sc->args)));
          setimmutable(x);
          s_return(sc,x);
     case OP_ATOM2STR: /* atom->string */
       x=car(sc->args);
       if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
     char *p;
     int len;
     atom2str(sc,x,0,&p,&len);
     s_return(sc,mk_counted_string(sc,p,len));
       } else {
     Error_1(sc, "atom->string: not an atom:", x);
       }

     case OP_MKSTRING: { /* make-string */
          int fill=' ';
          int len;

          len=ivalue(car(sc->args));

          if(cdr(sc->args)!=sc->NIL) {
               fill=charvalue(cadr(sc->args));
          }
          s_return(sc,mk_empty_string(sc,len,(char)fill));
     }

     case OP_STRLEN:  /* string-length */
          s_return(sc,mk_integer(sc,strlength(car(sc->args))));

     case OP_STRREF: { /* string-ref */
          char *str;
          int index;

          str=strvalue(car(sc->args));

          index=ivalue(cadr(sc->args));

          if(index>=strlength(car(sc->args))) {
               Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
          }

          s_return(sc,mk_character(sc,((unsigned char*)str)[index]));
     }

     case OP_STRSET: { /* string-set! */
          char *str;
          int index;
          int c;

          if(is_immutable(car(sc->args))) {
               Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args));
          }
          str=strvalue(car(sc->args));

          index=ivalue(cadr(sc->args));
          if(index>=strlength(car(sc->args))) {
               Error_1(sc,"string-set!: out of bounds:",cadr(sc->args));
          }

          c=charvalue(caddr(sc->args));

          str[index]=(char)c;
          s_return(sc,car(sc->args));
     }

     case OP_STRAPPEND: { /* string-append */
       /* in 1.29 string-append was in Scheme in init.scm but was too slow */
       int len = 0;
       cell_ptr newstr;
       char *pos;

       /* compute needed length for new string */
       for (x = sc->args; x != sc->NIL; x = cdr(x)) {
          len += strlength(car(x));
       }
       newstr = mk_empty_string(sc, len, ' ');
       /* store the contents of the argument strings into the new string */
       for (pos = strvalue(newstr), x = sc->args; x != sc->NIL;
           pos += strlength(car(x)), x = cdr(x)) {
           memcpy(pos, strvalue(car(x)), strlength(car(x)));
       }
       s_return(sc, newstr);
     }

     case OP_SUBSTR: { /* substring */
          char *str;
          int index0;
          int index1;
          int len;

          str=strvalue(car(sc->args));

          index0=ivalue(cadr(sc->args));

          if(index0>strlength(car(sc->args))) {
               Error_1(sc,"substring: start out of bounds:",cadr(sc->args));
          }

          if(cddr(sc->args)!=sc->NIL) {
               index1=ivalue(caddr(sc->args));
               if(index1>strlength(car(sc->args)) || index1<index0) {
                    Error_1(sc,"substring: end out of bounds:",caddr(sc->args));
               }
          } else {
               index1=strlength(car(sc->args));
          }

          len=index1-index0;
          x=mk_empty_string(sc,len,' ');
          memcpy(strvalue(x),str+index0,len);
          strvalue(x)[len]=0;

          s_return(sc,x);
     }

     case OP_VECTOR: {   /* vector */
          int i;
          cell_ptr vec;
          int len=list_length(sc,sc->args);
          if(len<0) {
               Error_1(sc,"vector: not a proper list:",sc->args);
          }
          vec=mk_vector(sc,len);
          if(sc->no_memory) { s_return(sc, sc->sink); }
          for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
               set_vector_elem(vec,i,car(x));
          }
          s_return(sc,vec);
     }

     case OP_MKVECTOR: { /* make-vector */
          cell_ptr fill=sc->NIL;
          int len;
          cell_ptr vec;

          len=ivalue(car(sc->args));

          if(cdr(sc->args)!=sc->NIL) {
               fill=cadr(sc->args);
          }
          vec=mk_vector(sc,len);
      if(sc->no_memory) { s_return(sc, sc->sink); }
          if(fill!=sc->NIL) {
               fill_vector(vec,fill);
          }
          s_return(sc,vec);
     }

     case OP_VECLEN:  /* vector-length */
          s_return(sc,mk_integer(sc,ivalue(car(sc->args))));

     case OP_VECREF: { /* vector-ref */
          int index;

          index=ivalue(cadr(sc->args));

          if(index>=ivalue(car(sc->args))) {
               Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args));
          }

          s_return(sc,vector_elem(car(sc->args),index));
     }

     case OP_VECSET: {   /* vector-set! */
          int index;

          if(is_immutable(car(sc->args))) {
               Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args));
          }

          index=ivalue(cadr(sc->args));
          if(index>=ivalue(car(sc->args))) {
               Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args));
          }

          set_vector_elem(car(sc->args),index,caddr(sc->args));
          s_return(sc,car(sc->args));
     }

     default:
          snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
          Error_0(sc,sc->strbuff);
     }
     return sc->T;
}
static cell_ptr opexe_3 ( scheme sc,
enum scheme_opcodes  op 
) [static]

Definition at line 3555 of file scheme.c.

                                                            {
     cell_ptr x;
     num v;
     int (*comp_func)(num,num)=0;

     switch (op) {
     case OP_NOT:        /* not */
          s_retbool(is_false(car(sc->args)));
     case OP_BOOLP:       /* boolean? */
          s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
     case OP_EOFOBJP:       /* boolean? */
          s_retbool(car(sc->args) == sc->EOF_OBJ);
     case OP_NULLP:       /* null? */
          s_retbool(car(sc->args) == sc->NIL);
     case OP_NUMEQ:      /* = */
     case OP_LESS:       /* < */
     case OP_GRE:        /* > */
     case OP_LEQ:        /* <= */
     case OP_GEQ:        /* >= */
          switch(op) {
               case OP_NUMEQ: comp_func=num_eq; break;
               case OP_LESS:  comp_func=num_lt; break;
               case OP_GRE:   comp_func=num_gt; break;
               case OP_LEQ:   comp_func=num_le; break;
               case OP_GEQ:   comp_func=num_ge; break;
          }
          x=sc->args;
          v=nvalue(car(x));
          x=cdr(x);

          for (; x != sc->NIL; x = cdr(x)) {
               if(!comp_func(v,nvalue(car(x)))) {
                    s_retbool(0);
               }
           v=nvalue(car(x));
          }
          s_retbool(1);
     case OP_SYMBOLP:     /* symbol? */
          s_retbool(is_symbol(car(sc->args)));
     case OP_NUMBERP:     /* number? */
          s_retbool(is_number(car(sc->args)));
     case OP_STRINGP:     /* string? */
          s_retbool(is_string(car(sc->args)));
     case OP_INTEGERP:     /* integer? */
          s_retbool(is_integer(car(sc->args)));
     case OP_REALP:     /* real? */
          s_retbool(is_number(car(sc->args))); /* All numbers are real */
     case OP_CHARP:     /* char? */
          s_retbool(is_character(car(sc->args)));
#if USE_CHAR_CLASSIFIERS
     case OP_CHARAP:     /* char-alphabetic? */
          s_retbool(Cisalpha(ivalue(car(sc->args))));
     case OP_CHARNP:     /* char-numeric? */
          s_retbool(Cisdigit(ivalue(car(sc->args))));
     case OP_CHARWP:     /* char-whitespace? */
          s_retbool(Cisspace(ivalue(car(sc->args))));
     case OP_CHARUP:     /* char-upper-case? */
          s_retbool(Cisupper(ivalue(car(sc->args))));
     case OP_CHARLP:     /* char-lower-case? */
          s_retbool(Cislower(ivalue(car(sc->args))));
#endif
     case OP_PORTP:     /* port? */
          s_retbool(is_port(car(sc->args)));
     case OP_INPORTP:     /* input-port? */
          s_retbool(is_inport(car(sc->args)));
     case OP_OUTPORTP:     /* output-port? */
          s_retbool(is_outport(car(sc->args)));
     case OP_PROCP:       /* procedure? */
          /*--
              * continuation should be procedure by the example
              * (call-with-current-continuation procedure?) ==> #t
                 * in R^3 report sec. 6.9
              */
          s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args))
                 || is_continuation(car(sc->args)) || is_foreign(car(sc->args)));
     case OP_PAIRP:       /* pair? */
          s_retbool(is_pair(car(sc->args)));
     case OP_LISTP:       /* list? */
       s_retbool(list_length(sc,car(sc->args)) >= 0);

     case OP_ENVP:        /* environment? */
          s_retbool(is_environment(car(sc->args)));
     case OP_VECTORP:     /* vector? */
          s_retbool(is_vector(car(sc->args)));
     case OP_EQ:         /* eq? */
          s_retbool(car(sc->args) == cadr(sc->args));
     case OP_EQV:        /* eqv? */
          s_retbool(eqv(car(sc->args), cadr(sc->args)));
     default:
          snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
          Error_0(sc,sc->strbuff);
     }
     return sc->T;
}

Here is the call graph for this function:

static cell_ptr opexe_4 ( scheme sc,
enum scheme_opcodes  op 
) [static]

Definition at line 3650 of file scheme.c.

                                                            {
     cell_ptr x, y;

     switch (op) {
     case OP_FORCE:      /* force */
          sc->code = car(sc->args);
          if (is_promise(sc->code)) {
               /* Should change type to closure here */
               s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
               sc->args = sc->NIL;
               s_goto(sc,OP_APPLY);
          } else {
               s_return(sc,sc->code);
          }

     case OP_SAVE_FORCED:     /* Save forced value replacing promise */
          memcpy(sc->code,sc->value,sizeof(struct cell));
          s_return(sc,sc->value);

     case OP_WRITE:      /* write */
     case OP_DISPLAY:    /* display */
     case OP_WRITE_CHAR: /* write-char */
          if(is_pair(cdr(sc->args))) {
               if(cadr(sc->args)!=sc->outport) {
                    x=cons(sc,sc->outport,sc->NIL);
                    s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
                    sc->outport=cadr(sc->args);
               }
          }
          sc->args = car(sc->args);
          if(op==OP_WRITE) {
               sc->print_flag = 1;
          } else {
               sc->print_flag = 0;
          }
          s_goto(sc,OP_P0LIST);

     case OP_NEWLINE:    /* newline */
          if(is_pair(sc->args)) {
               if(car(sc->args)!=sc->outport) {
                    x=cons(sc,sc->outport,sc->NIL);
                    s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
                    sc->outport=car(sc->args);
               }
          }
          putstr(sc, "\n");
          s_return(sc,sc->T);

     case OP_ERR0:  /* error */
          sc->retcode=-1;
          if (!is_string(car(sc->args))) {
               sc->args=cons(sc,mk_string(sc," -- "),sc->args);
               setimmutable(car(sc->args));
          }
          putstr(sc, "Error: ");
          putstr(sc, strvalue(car(sc->args)));
          sc->args = cdr(sc->args);
          s_goto(sc,OP_ERR1);

     case OP_ERR1:  /* error */
          putstr(sc, " ");
          if (sc->args != sc->NIL) {
               s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL);
               sc->args = car(sc->args);
               sc->print_flag = 1;
               s_goto(sc,OP_P0LIST);
          } else {
               putstr(sc, "\n");
               if(sc->interactive_repl) {
                    s_goto(sc,OP_T0LVL);
               } else {
                    return sc->NIL;
               }
          }

     case OP_REVERSE:    /* reverse */
          s_return(sc,reverse(sc, car(sc->args)));

     case OP_LIST_STAR: /* list* */
       s_return(sc,list_star(sc,sc->args));

     case OP_APPEND:     /* append */
          if(sc->args==sc->NIL) {
               s_return(sc,sc->NIL);
          }
          x=car(sc->args);
          if(cdr(sc->args)==sc->NIL) {
        s_return(sc,sc->args);
      }
          for (y = cdr(sc->args); y != sc->NIL; y = cdr(y)) {
               x=append(sc,x,car(y));
          }
          s_return(sc,x);

#if USE_PLIST
     case OP_PUT:        /* put */
          if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
               Error_0(sc,"illegal use of put");
          }
          for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
               if (caar(x) == y) {
                    break;
               }
          }
          if (x != sc->NIL)
               cdar(x) = caddr(sc->args);
          else
               symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)),
                                symprop(car(sc->args)));
          s_return(sc,sc->T);

     case OP_GET:        /* get */
          if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
               Error_0(sc,"illegal use of get");
          }
          for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
               if (caar(x) == y) {
                    break;
               }
          }
          if (x != sc->NIL) {
               s_return(sc,cdar(x));
          } else {
               s_return(sc,sc->NIL);
          }
#endif /* USE_PLIST */
     case OP_QUIT:       /* quit */
          if(is_pair(sc->args)) {
               sc->retcode=ivalue(car(sc->args));
          }
          return (sc->NIL);

     case OP_GC:         /* gc */
          gc(sc, sc->NIL, sc->NIL);
          s_return(sc,sc->T);

     case OP_GCVERB:          /* gc-verbose */
     {    int  was = sc->gc_verbose;

          sc->gc_verbose = (car(sc->args) != sc->F);
          s_retbool(was);
     }

     case OP_NEWSEGMENT: /* new-segment */
          if (!is_pair(sc->args) || !is_number(car(sc->args))) {
               Error_0(sc,"new-segment: argument must be a number");
          }
          alloc_cellseg(sc, (int) ivalue(car(sc->args)));
          s_return(sc,sc->T);

     case OP_OBLIST: /* oblist */
          s_return(sc, oblist_all_symbols(sc));

     case OP_CURR_INPORT: /* current-input-port */
          s_return(sc,sc->inport);

     case OP_CURR_OUTPORT: /* current-output-port */
          s_return(sc,sc->outport);

     case OP_OPEN_INFILE: /* open-input-file */
     case OP_OPEN_OUTFILE: /* open-output-file */
     case OP_OPEN_INOUTFILE: /* open-input-output-file */ {
          int prop=0;
          cell_ptr p;
          switch(op) {
               case OP_OPEN_INFILE:     prop=port_input; break;
               case OP_OPEN_OUTFILE:    prop=port_output; break;
               case OP_OPEN_INOUTFILE: prop=port_input|port_output; break;
          }
          p=port_from_filename(sc,strvalue(car(sc->args)),prop);
          if(p==sc->NIL) {
               s_return(sc,sc->F);
          }
          s_return(sc,p);
     }

#if USE_STRING_PORTS
     case OP_OPEN_INSTRING: /* open-input-string */
     case OP_OPEN_INOUTSTRING: /* open-input-output-string */ {
          int prop=0;
          cell_ptr p;
          switch(op) {
               case OP_OPEN_INSTRING:     prop=port_input; break;
               case OP_OPEN_INOUTSTRING:  prop=port_input|port_output; break;
          }
          p=port_from_string(sc, strvalue(car(sc->args)),
                 strvalue(car(sc->args))+strlength(car(sc->args)), prop);
          if(p==sc->NIL) {
               s_return(sc,sc->F);
          }
          s_return(sc,p);
     }
     case OP_OPEN_OUTSTRING: /* open-output-string */ {
          cell_ptr p;
      if(car(sc->args)==sc->NIL) {
               p=port_from_scratch(sc);
               if(p==sc->NIL) {
                    s_return(sc,sc->F);
               }
      } else {
               p=port_from_string(sc, strvalue(car(sc->args)),
                      strvalue(car(sc->args))+strlength(car(sc->args)),
                          port_output);
               if(p==sc->NIL) {
                    s_return(sc,sc->F);
               }
      }
          s_return(sc,p);
     }
     case OP_GET_OUTSTRING: /* get-output-string */ {
          port *p;

      if ((p=car(sc->args)->_object._port)->kind&port_string) {
           off_t size;
           char *str;

           size=p->rep.string.curr-p->rep.string.start+1;
           str=sc->malloc(size);
           if(str != NULL) {
                cell_ptr s;

                memcpy(str,p->rep.string.start,size-1);
                str[size-1]='\0';
                s=mk_string(sc,str);
                sc->free(str);
                s_return(sc,s);
           }
      }
          s_return(sc,sc->F);
     }
#endif

     case OP_CLOSE_INPORT: /* close-input-port */
          port_close(sc,car(sc->args),port_input);
          s_return(sc,sc->T);

     case OP_CLOSE_OUTPORT: /* close-output-port */
          port_close(sc,car(sc->args),port_output);
          s_return(sc,sc->T);

     case OP_INT_ENV: /* interaction-environment */
          s_return(sc,sc->global_env);

     case OP_CURR_ENV: /* current-environment */
          s_return(sc,sc->envir);

     }
     return sc->T;
}

Here is the call graph for this function:

static cell_ptr opexe_5 ( scheme sc,
enum scheme_opcodes  op 
) [static]

Definition at line 3900 of file scheme.c.

                                                            {
     cell_ptr x;

     if(sc->nesting!=0) {
          int n=sc->nesting;
          sc->nesting=0;
          sc->retcode=-1;
          Error_1(sc,"unmatched parentheses:",mk_integer(sc,n));
     }

     switch (op) {
     /* ========== reading part ========== */
     case OP_READ:
          if(!is_pair(sc->args)) {
               s_goto(sc,OP_READ_INTERNAL);
          }
          if(!is_inport(car(sc->args))) {
               Error_1(sc,"read: not an input port:",car(sc->args));
          }
          if(car(sc->args)==sc->inport) {
               s_goto(sc,OP_READ_INTERNAL);
          }
          x=sc->inport;
          sc->inport=car(sc->args);
          x=cons(sc,x,sc->NIL);
          s_save(sc,OP_SET_INPORT, x, sc->NIL);
          s_goto(sc,OP_READ_INTERNAL);

     case OP_READ_CHAR: /* read-char */
     case OP_PEEK_CHAR: /* peek-char */ {
          int c;
          if(is_pair(sc->args)) {
               if(car(sc->args)!=sc->inport) {
                    x=sc->inport;
                    x=cons(sc,x,sc->NIL);
                    s_save(sc,OP_SET_INPORT, x, sc->NIL);
                    sc->inport=car(sc->args);
               }
          }
          c=inchar(sc);
          if(c==EOF) {
               s_return(sc,sc->EOF_OBJ);
          }
          if(sc->op==OP_PEEK_CHAR) {
               backchar(sc,c);
          }
          s_return(sc,mk_character(sc,c));
     }

     case OP_CHAR_READY: /* char-ready? */ {
          cell_ptr p=sc->inport;
          int res;
          if(is_pair(sc->args)) {
               p=car(sc->args);
          }
          res=p->_object._port->kind&port_string;
          s_retbool(res);
     }

     case OP_SET_INPORT: /* set-input-port */
          sc->inport=car(sc->args);
          s_return(sc,sc->value);

     case OP_SET_OUTPORT: /* set-output-port */
          sc->outport=car(sc->args);
          s_return(sc,sc->value);

     case OP_RDSEXPR:
          switch (sc->tok) {
          case TOK_EOF:
        s_return(sc,sc->EOF_OBJ);
        /* NOTREACHED */
/*
 * Commented out because we now skip comments in the scanner
 *
          case TOK_COMMENT: {
               int c;
               while ((c=inchar(sc)) != '\n' && c!=EOF)
                    ;
               sc->tok = token(sc);
               s_goto(sc,OP_RDSEXPR);
          }
*/
          case TOK_VEC:
               s_save(sc,OP_RDVEC,sc->NIL,sc->NIL);
               /* fall through */
          case TOK_LPAREN:
               sc->tok = token(sc);
               if (sc->tok == TOK_RPAREN) {
                    s_return(sc,sc->NIL);
               } else if (sc->tok == TOK_DOT) {
                    Error_0(sc,"syntax error: illegal dot expression");
               } else {
                    sc->nesting_stack[sc->file_i]++;
                    s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
                    s_goto(sc,OP_RDSEXPR);
               }
          case TOK_QUOTE:
               s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
               sc->tok = token(sc);
               s_goto(sc,OP_RDSEXPR);
          case TOK_BQUOTE:
               sc->tok = token(sc);
           if(sc->tok==TOK_VEC) {
         s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
         sc->tok=TOK_LPAREN;
         s_goto(sc,OP_RDSEXPR);
           } else {
         s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL);
           }
               s_goto(sc,OP_RDSEXPR);
          case TOK_COMMA:
               s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL);
               sc->tok = token(sc);
               s_goto(sc,OP_RDSEXPR);
          case TOK_ATMARK:
               s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL);
               sc->tok = token(sc);
               s_goto(sc,OP_RDSEXPR);
          case TOK_ATOM:
               s_return(sc,mk_atom(sc, readstr_upto(sc, "();\t\n\r ")));
          case TOK_DQUOTE:
               x=readstrexp(sc);
           if(x==sc->F) {
         Error_0(sc,"Error reading string");
           }
               setimmutable(x);
               s_return(sc,x);
          case TOK_SHARP: {
               cell_ptr f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1);
               if(f==sc->NIL) {
                    Error_0(sc,"undefined sharp expression");
               } else {
                    sc->code=cons(sc,slot_value_in_env(f),sc->NIL);
                    s_goto(sc,OP_EVAL);
               }
          }
          case TOK_SHARP_CONST:
               if ((x = mk_sharp_const(sc, readstr_upto(sc, "();\t\n\r "))) == sc->NIL) {
                    Error_0(sc,"undefined sharp expression");
               } else {
                    s_return(sc,x);
               }
          default:
               Error_0(sc,"syntax error: illegal token");
          }
          break;

     case OP_RDLIST: {
          sc->args = cons(sc, sc->value, sc->args);
          sc->tok = token(sc);
/* We now skip comments in the scanner

          while (sc->tok == TOK_COMMENT) {
               int c;
               while ((c=inchar(sc)) != '\n' && c!=EOF)
                    ;
               sc->tok = token(sc);
          }
*/
      if(sc->tok == TOK_EOF)
           { s_return(sc,sc->EOF_OBJ); }
      else if (sc->tok == TOK_RPAREN) {
               int c = inchar(sc);
               if (c != '\n')
                 backchar(sc,c);
#if SHOW_ERROR_LINE
               else
                  sc->load_stack[sc->file_i].rep.stdio.curr_line++;
#endif
               sc->nesting_stack[sc->file_i]--;
               s_return(sc,reverse_in_place(sc, sc->NIL, sc->args));
          } else if (sc->tok == TOK_DOT) {
               s_save(sc,OP_RDDOT, sc->args, sc->NIL);
               sc->tok = token(sc);
               s_goto(sc,OP_RDSEXPR);
          } else {
               s_save(sc,OP_RDLIST, sc->args, sc->NIL);;
               s_goto(sc,OP_RDSEXPR);
          }
     }

     case OP_RDDOT:
          if (token(sc) != TOK_RPAREN) {
               Error_0(sc,"syntax error: illegal dot expression");
          } else {
               sc->nesting_stack[sc->file_i]--;
               s_return(sc,reverse_in_place(sc, sc->value, sc->args));
          }

     case OP_RDQUOTE:
          s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)));

     case OP_RDQQUOTE:
          s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)));

     case OP_RDQQUOTEVEC:
       s_return(sc,cons(sc, mk_symbol(sc,"apply"),
            cons(sc, mk_symbol(sc,"vector"),
                 cons(sc,cons(sc, sc->QQUOTE,
                  cons(sc,sc->value,sc->NIL)),
                  sc->NIL))));

     case OP_RDUNQUOTE:
          s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL)));

     case OP_RDUQTSP:
          s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL)));

     case OP_RDVEC:
          /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
          s_goto(sc,OP_EVAL); Cannot be quoted*/
       /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
     s_return(sc,x); Cannot be part of pairs*/
       /*sc->code=mk_proc(sc,OP_VECTOR);
       sc->args=sc->value;
       s_goto(sc,OP_APPLY);*/
       sc->args=sc->value;
       s_goto(sc,OP_VECTOR);

     /* ========== printing part ========== */
     case OP_P0LIST:
          if(is_vector(sc->args)) {
               putstr(sc,"#(");
               sc->args=cons(sc,sc->args,mk_integer(sc,0));
               s_goto(sc,OP_PVECFROM);
          } else if(is_environment(sc->args)) {
               putstr(sc,"#<ENVIRONMENT>");
               s_return(sc,sc->T);
          } else if (!is_pair(sc->args)) {
               printatom(sc, sc->args, sc->print_flag);
               s_return(sc,sc->T);
          } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) {
               putstr(sc, "'");
               sc->args = cadr(sc->args);
               s_goto(sc,OP_P0LIST);
          } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) {
               putstr(sc, "`");
               sc->args = cadr(sc->args);
               s_goto(sc,OP_P0LIST);
          } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) {
               putstr(sc, ",");
               sc->args = cadr(sc->args);
               s_goto(sc,OP_P0LIST);
          } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) {
               putstr(sc, ",@");
               sc->args = cadr(sc->args);
               s_goto(sc,OP_P0LIST);
          } else {
               putstr(sc, "(");
               s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
               sc->args = car(sc->args);
               s_goto(sc,OP_P0LIST);
          }

     case OP_P1LIST:
          if (is_pair(sc->args)) {
        s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
        putstr(sc, " ");
        sc->args = car(sc->args);
        s_goto(sc,OP_P0LIST);
      } else if(is_vector(sc->args)) {
        s_save(sc,OP_P1LIST,sc->NIL,sc->NIL);
        putstr(sc, " . ");
        s_goto(sc,OP_P0LIST);
          } else {
        if (sc->args != sc->NIL) {
          putstr(sc, " . ");
          printatom(sc, sc->args, sc->print_flag);
        }
        putstr(sc, ")");
        s_return(sc,sc->T);
          }
     case OP_PVECFROM: {
          int i=ivalue_unchecked(cdr(sc->args));
          cell_ptr vec=car(sc->args);
          int len=ivalue_unchecked(vec);
          if(i==len) {
               putstr(sc,")");
               s_return(sc,sc->T);
          } else {
               cell_ptr elem=vector_elem(vec,i);
               ivalue_unchecked(cdr(sc->args))=i+1;
               s_save(sc,OP_PVECFROM, sc->args, sc->NIL);
               sc->args=elem;
               putstr(sc," ");
               s_goto(sc,OP_P0LIST);
          }
     }

     default:
          snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
          Error_0(sc,sc->strbuff);

     }
     return sc->T;
}

Here is the call graph for this function:

static cell_ptr opexe_6 ( scheme sc,
enum scheme_opcodes  op 
) [static]

Definition at line 4198 of file scheme.c.

                                                            {
     cell_ptr x, y;
     long v;

     switch (op) {
     case OP_LIST_LENGTH:     /* length */   /* a.k */
          v=list_length(sc,car(sc->args));
          if(v<0) {
               Error_1(sc,"length: not a list:",car(sc->args));
          }
          s_return(sc,mk_integer(sc, v));

     case OP_ASSQ:       /* assq */     /* a.k */
          x = car(sc->args);
          for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
               if (!is_pair(car(y))) {
                    Error_0(sc,"unable to handle non pair element");
               }
               if (x == caar(y))
                    break;
          }
          if (is_pair(y)) {
               s_return(sc,car(y));
          } else {
               s_return(sc,sc->F);
          }


     case OP_GET_CLOSURE:     /* get-closure-code */   /* a.k */
          sc->args = car(sc->args);
          if (sc->args == sc->NIL) {
               s_return(sc,sc->F);
          } else if (is_closure(sc->args)) {
               s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
          } else if (is_macro(sc->args)) {
               s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
          } else {
               s_return(sc,sc->F);
          }
     case OP_CLOSUREP:        /* closure? */
          /*
           * Note, macro object is also a closure.
           * Therefore, (closure? <#MACRO>) ==> #t
           */
          s_retbool(is_closure(car(sc->args)));
     case OP_MACROP:          /* macro? */
          s_retbool(is_macro(car(sc->args)));
     default:
          snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
          Error_0(sc,sc->strbuff);
     }
     return sc->T; /* NOTREACHED */
}

Here is the call graph for this function:

Definition at line 210 of file scheme.c.

{ return car(p); }

Here is the caller graph for this function:

Definition at line 211 of file scheme.c.

{ return cdr(p); }

Here is the caller graph for this function:

static void port_close ( scheme sc,
cell_ptr  p,
int  flag 
) [static]

Definition at line 1499 of file scheme.c.

                                                         {
  port *pt=p->_object._port;
  pt->kind&=~flag;
  if((pt->kind & (port_input|port_output))==0) {
    if(pt->kind&port_file) {

#if SHOW_ERROR_LINE
      /* Cleanup is here so (close-*-port) functions could work too */
      pt->rep.stdio.curr_line = 0;

      if(pt->rep.stdio.filename)
        sc->free(pt->rep.stdio.filename);
#endif

      fclose(pt->rep.stdio.file);
    }
    pt->kind=port_free;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr port_from_file ( scheme sc,
FILE *  f,
int  prop 
) [static]

Definition at line 1437 of file scheme.c.

                                                              {
  port *pt;
  pt=port_rep_from_file(sc,f,prop);
  if(pt==0) {
    return sc->NIL;
  }
  return mk_port(sc,pt);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr port_from_filename ( scheme sc,
const char *  fn,
int  prop 
) [static]

Definition at line 1414 of file scheme.c.

                                                                         {
  port *pt;
  pt=port_rep_from_filename(sc,fn,prop);
  if(pt==0) {
    return sc->NIL;
  }
  return mk_port(sc,pt);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr port_from_scratch ( scheme sc) [static]

Definition at line 1490 of file scheme.c.

                                              {
  port *pt;
  pt=port_rep_from_scratch(sc);
  if(pt==0) {
    return sc->NIL;
  }
  return mk_port(sc,pt);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static cell_ptr port_from_string ( scheme sc,
char *  start,
char *  past_the_end,
int  prop 
) [static]

Definition at line 1459 of file scheme.c.

                                                                                        {
  port *pt;
  pt=port_rep_from_string(sc,start,past_the_end,prop);
  if(pt==0) {
    return sc->NIL;
  }
  return mk_port(sc,pt);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static port * port_rep_from_file ( scheme sc,
FILE *  f,
int  prop 
) [static]

Definition at line 1423 of file scheme.c.

{
    port *pt;

    pt = (port *)sc->malloc(sizeof *pt);
    if (pt == NULL) {
        return NULL;
    }
    pt->kind = port_file | prop;
    pt->rep.stdio.file = f;
    pt->rep.stdio.closeit = 0;
    return pt;
}

Here is the caller graph for this function:

static port * port_rep_from_filename ( scheme sc,
const char *  fn,
int  prop 
) [static]

Definition at line 1387 of file scheme.c.

                                                                          {
  FILE *f;