1
/* T I N Y S C H E M E 1 . 3 8
2
* Dimitrios Souflis (dsouflis@acm.org)
3
* Based on MiniScheme (original credits follow)
4
* (MINISCM) coded by Atsushi Moriwaki (11/5/1989)
5
* (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp
6
* (MINISCM) This version has been modified by R.C. Secrist.
8
* (MINISCM) Mini-Scheme is now maintained by Akira KIDA.
10
* (MINISCM) This is a revised and modified version by Akira KIDA.
11
* (MINISCM) current version is 0.85k4 (15 May 1994)
15
/* ******** READ THE FOLLOWING BEFORE MODIFYING THIS FILE! ******** */
16
/* This copy of TinyScheme has been modified to support UTF-8 coded */
17
/* character strings. As a result, the length of a string in bytes */
18
/* may not be the same as the length of a string in characters. You */
19
/* must keep this in mind at all times while making any changes to */
20
/* the routines in this file, or when adding new features. */
22
/* UTF-8 modifications made by Kevin Cozens (kcozens@interlog.com) */
23
/* **************************************************************** */
27
#define _SCHEME_SOURCE
33
# define access(f,a) _access(f,a)
47
#include "scheme-private.h"
49
/* Used for documentation purposes, to signal functions in 'interface' */
64
#define TOK_SHARP_CONST 11
67
# define BACKQUOTE '`'
70
* Basic memory allocation units
73
#define banner "TinyScheme 1.38 (with UTF-8 support)"
77
#define stricmp g_ascii_strcasecmp
80
#define min(a, b) ((a <= b) ? a : b)
84
#error FIXME: Can't just use g_utf8_strdown since it allocates a new string
85
#define strlwr(s) g_utf8_strdown(s, -1)
96
# define InitFile "init.scm"
99
#ifndef FIRST_CELLSEGS
100
# define FIRST_CELLSEGS 3
118
T_LAST_SYSTEM_TYPE=14
121
/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
124
#define T_MASKTYPE 31 /* 0000000000011111 */
125
#define T_SYNTAX 4096 /* 0001000000000000 */
126
#define T_IMMUTABLE 8192 /* 0010000000000000 */
127
#define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */
128
#define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */
129
#define MARK 32768 /* 1000000000000000 */
130
#define UNMARK 32767 /* 0111111111111111 */
132
SCHEME_EXPORT void (*ts_output_routine) (FILE *, char *, int);
134
static num num_add(num a, num b);
135
static num num_mul(num a, num b);
136
static num num_div(num a, num b);
137
static num num_intdiv(num a, num b);
138
static num num_sub(num a, num b);
139
static num num_rem(num a, num b);
140
static num num_mod(num a, num b);
141
static int num_eq(num a, num b);
142
static int num_gt(num a, num b);
143
static int num_ge(num a, num b);
144
static int num_lt(num a, num b);
145
static int num_le(num a, num b);
148
static double round_per_R5RS(double x);
150
static int is_zero_double(double x);
155
/* macros for cell operations */
156
#define typeflag(p) ((p)->_flag)
157
#define type(p) (typeflag(p)&T_MASKTYPE)
159
INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); }
160
#define strvalue(p) ((p)->_object._string._svalue)
161
#define strkey(p) ((p)->_object._string._skey)
162
#define strlength(p) ((p)->_object._string._length)
164
INTERFACE static int is_list(scheme *sc, pointer p);
165
INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); }
166
INTERFACE static void fill_vector(pointer vec, pointer obj);
167
INTERFACE static pointer vector_elem(pointer vec, int ielem);
168
INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a);
169
INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); }
170
INTERFACE INLINE int is_integer(pointer p) {
171
return ((p)->_object._number.is_fixnum);
173
INTERFACE INLINE int is_real(pointer p) {
174
return (!(p)->_object._number.is_fixnum);
177
INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); }
178
INTERFACE INLINE int string_length(pointer p) { return strlength(p); }
179
INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); }
180
INLINE num nvalue(pointer p) { return ((p)->_object._number); }
181
INTERFACE long ivalue(pointer p) { return (is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); }
182
INTERFACE double rvalue(pointer p) { return (!is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); }
183
#define ivalue_unchecked(p) ((p)->_object._number.value.ivalue)
184
#define rvalue_unchecked(p) ((p)->_object._number.value.rvalue)
185
#define set_integer(p) (p)->_object._number.is_fixnum=1;
186
#define set_real(p) (p)->_object._number.is_fixnum=0;
187
INTERFACE gunichar charvalue(pointer p) { return (gunichar)ivalue_unchecked(p); }
189
INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); }
190
#define is_inport(p) (type(p)==T_PORT && p->_object._port->kind&port_input)
191
#define is_outport(p) (type(p)==T_PORT && p->_object._port->kind&port_output)
193
INTERFACE INLINE int is_pair(pointer p) { return (type(p)==T_PAIR); }
194
#define car(p) ((p)->_object._cons._car)
195
#define cdr(p) ((p)->_object._cons._cdr)
196
INTERFACE pointer pair_car(pointer p) { return car(p); }
197
INTERFACE pointer pair_cdr(pointer p) { return cdr(p); }
198
INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; }
199
INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; }
201
INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); }
202
INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); }
203
/* For now, we don't want foreign functions to access a strings key */
204
INLINE char *symkey(pointer p) { return strkey(car(p)); }
206
SCHEME_EXPORT INLINE int hasprop(pointer p) { return (typeflag(p)&T_SYMBOL); }
207
#define symprop(p) cdr(p)
210
INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); }
211
INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); }
212
INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); }
213
INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); }
214
#define procnum(p) ivalue(p)
215
static const char *procname(pointer x);
217
INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); }
218
INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); }
219
INTERFACE INLINE pointer closure_code(pointer p) { return car(p); }
220
INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); }
222
INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); }
223
#define cont_dump(p) cdr(p)
225
/* To do: promise should be forced ONCE only */
226
INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); }
228
INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); }
229
#define setenvironment(p) typeflag(p) = T_ENVIRONMENT
231
#define is_atom(p) (typeflag(p)&T_ATOM)
232
#define setatom(p) typeflag(p) |= T_ATOM
233
#define clratom(p) typeflag(p) &= CLRATOM
235
#define is_mark(p) (typeflag(p)&MARK)
236
#define setmark(p) typeflag(p) |= MARK
237
#define clrmark(p) typeflag(p) &= UNMARK
239
INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); }
240
/*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/
241
INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; }
243
#define caar(p) car(car(p))
244
#define cadr(p) car(cdr(p))
245
#define cdar(p) cdr(car(p))
246
#define cddr(p) cdr(cdr(p))
247
#define cadar(p) car(cdr(car(p)))
248
#define caddr(p) car(cdr(cdr(p)))
249
#define cadaar(p) car(cdr(car(car(p))))
250
#define cadddr(p) car(cdr(cdr(cdr(p))))
251
#define cddddr(p) cdr(cdr(cdr(cdr(p))))
253
#if USE_CHAR_CLASSIFIERS
254
static INLINE int Cisalpha(gunichar c) { return g_unichar_isalpha(c); }
255
static INLINE int Cisdigit(gunichar c) { return g_unichar_isdigit(c); }
256
static INLINE int Cisspace(gunichar c) { return g_unichar_isspace(c); }
257
static INLINE int Cisupper(gunichar c) { return g_unichar_isupper(c); }
258
static INLINE int Cislower(gunichar c) { return g_unichar_islower(c); }
262
static const char *charnames[32]={
297
static int is_ascii_name(const char *name, int *pc) {
299
for(i=0; i<32; i++) {
300
if(stricmp(name,charnames[i])==0) {
305
if(stricmp(name,"del")==0) {
314
static const char utf8_length[128] =
316
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x80-0x8f */
317
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0x90-0x9f */
318
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0xa0-0xaf */
319
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 0xb0-0xbf */
320
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* 0xc0-0xcf */
321
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* 0xd0-0xdf */
322
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, /* 0xe0-0xef */
323
3,3,3,3,3,3,3,3,4,4,4,4,5,5,0,0 /* 0xf0-0xff */
326
static int file_push(scheme *sc, const char *fname);
327
static void file_pop(scheme *sc);
328
static int file_interactive(scheme *sc);
329
static INLINE int is_one_of(char *s, gunichar c);
330
static int alloc_cellseg(scheme *sc, int n);
331
static long binary_decode(const char *s);
332
static INLINE pointer get_cell(scheme *sc, pointer a, pointer b);
333
static pointer _get_cell(scheme *sc, pointer a, pointer b);
334
static pointer reserve_cells(scheme *sc, int n);
335
static pointer get_consecutive_cells(scheme *sc, int n);
336
static pointer find_consecutive_cells(scheme *sc, int n);
337
static void finalize_cell(scheme *sc, pointer a);
338
static int count_consecutive_cells(pointer x, int needed);
339
static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all);
340
static pointer mk_number(scheme *sc, num n);
341
static pointer mk_empty_string(scheme *sc, int len, gunichar fill);
342
static char *store_string(scheme *sc, int len, const char *str, gunichar fill);
343
static pointer mk_vector(scheme *sc, int len);
344
static pointer mk_atom(scheme *sc, char *q);
345
static pointer mk_sharp_const(scheme *sc, char *name);
346
static pointer mk_port(scheme *sc, port *p);
347
static pointer port_from_filename(scheme *sc, const char *fn, int prop);
348
static pointer port_from_file(scheme *sc, FILE *, int prop);
349
static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop);
350
static port *port_rep_from_filename(scheme *sc, const char *fn, int prop);
351
static port *port_rep_from_file(scheme *sc, FILE *, int prop);
352
static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop);
353
static void port_close(scheme *sc, pointer p, int flag);
354
static void mark(pointer a);
355
static void gc(scheme *sc, pointer a, pointer b);
356
static gunichar inchar(scheme *sc);
357
static void backchar(scheme *sc, gunichar c);
358
static char *readstr_upto(scheme *sc, char *delim);
359
static pointer readstrexp(scheme *sc);
360
static INLINE void skipspace(scheme *sc);
361
static int token(scheme *sc);
362
static void printslashstring(scheme *sc, char *s, int len);
363
static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen);
364
static void printatom(scheme *sc, pointer l, int f);
365
static pointer mk_proc(scheme *sc, enum scheme_opcodes op);
366
static pointer mk_closure(scheme *sc, pointer c, pointer e);
367
static pointer mk_continuation(scheme *sc, pointer d);
368
static pointer reverse(scheme *sc, pointer a);
369
static pointer reverse_in_place(scheme *sc, pointer term, pointer list);
370
static pointer append(scheme *sc, pointer a, pointer b);
371
static int list_length(scheme *sc, pointer a);
372
static int eqv(pointer a, pointer b);
373
static INLINE void dump_stack_mark(scheme *);
374
static pointer opexe_0(scheme *sc, enum scheme_opcodes op);
375
static pointer opexe_1(scheme *sc, enum scheme_opcodes op);
376
static pointer opexe_2(scheme *sc, enum scheme_opcodes op);
377
static pointer opexe_3(scheme *sc, enum scheme_opcodes op);
378
static pointer opexe_4(scheme *sc, enum scheme_opcodes op);
379
static pointer opexe_5(scheme *sc, enum scheme_opcodes op);
380
static pointer opexe_6(scheme *sc, enum scheme_opcodes op);
381
static void Eval_Cycle(scheme *sc, enum scheme_opcodes op);
382
static void assign_syntax(scheme *sc, char *name);
383
static int syntaxnum(pointer p);
384
static void assign_proc(scheme *sc, enum scheme_opcodes, char *name);
385
scheme *scheme_init_new(void);
387
void scheme_call(scheme *sc, pointer func, pointer args);
390
#define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
391
#define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
393
static num num_add(num a, num b) {
395
ret.is_fixnum=a.is_fixnum && b.is_fixnum;
397
ret.value.ivalue= a.value.ivalue+b.value.ivalue;
399
ret.value.rvalue=num_rvalue(a)+num_rvalue(b);
404
static num num_mul(num a, num b) {
406
ret.is_fixnum=a.is_fixnum && b.is_fixnum;
408
ret.value.ivalue= a.value.ivalue*b.value.ivalue;
410
ret.value.rvalue=num_rvalue(a)*num_rvalue(b);
415
static num num_div(num a, num b) {
417
ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0;
419
ret.value.ivalue= a.value.ivalue/b.value.ivalue;
421
ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
426
static num num_intdiv(num a, num b) {
428
ret.is_fixnum=a.is_fixnum && b.is_fixnum;
430
ret.value.ivalue= a.value.ivalue/b.value.ivalue;
432
ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
437
static num num_sub(num a, num b) {
439
ret.is_fixnum=a.is_fixnum && b.is_fixnum;
441
ret.value.ivalue= a.value.ivalue-b.value.ivalue;
443
ret.value.rvalue=num_rvalue(a)-num_rvalue(b);
448
static num num_rem(num a, num b) {
451
ret.is_fixnum=a.is_fixnum && b.is_fixnum;
455
/* modulo should have same sign as second operand */
460
} else if (res < 0) {
465
ret.value.ivalue=res;
469
static num num_mod(num a, num b) {
472
ret.is_fixnum=a.is_fixnum && b.is_fixnum;
476
if(res*e2<0) { /* modulo should have same sign as second operand */
484
ret.value.ivalue=res;
488
static int num_eq(num a, num b) {
490
int is_fixnum=a.is_fixnum && b.is_fixnum;
492
ret= a.value.ivalue==b.value.ivalue;
494
ret=num_rvalue(a)==num_rvalue(b);
500
static int num_gt(num a, num b) {
502
int is_fixnum=a.is_fixnum && b.is_fixnum;
504
ret= a.value.ivalue>b.value.ivalue;
506
ret=num_rvalue(a)>num_rvalue(b);
511
static int num_ge(num a, num b) {
515
static int num_lt(num a, num b) {
517
int is_fixnum=a.is_fixnum && b.is_fixnum;
519
ret= a.value.ivalue<b.value.ivalue;
521
ret=num_rvalue(a)<num_rvalue(b);
526
static int num_le(num a, num b) {
531
/* Round to nearest. Round to even if midway */
532
static double round_per_R5RS(double x) {
542
if(fmod(fl,2.0)==0.0) { /* I imagine this holds */
551
static int is_zero_double(double x) {
552
return x<DBL_MIN && x>-DBL_MIN;
555
static long binary_decode(const char *s) {
558
while(*s!=0 && (*s=='1' || *s=='0')) {
567
/* allocate new cell segment */
568
static int alloc_cellseg(scheme *sc, int n) {
577
if(adj<sizeof(struct cell)) {
578
adj=sizeof(struct cell);
581
for (k = 0; k < n; k++) {
582
if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
584
cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj);
587
i = ++sc->last_cell_seg ;
588
sc->alloc_seg[i] = cp;
589
/* adjust in TYPE_BITS-bit boundary */
590
if(((unsigned)cp)%adj!=0) {
591
cp=(char*)(adj*((unsigned long)cp/adj+1));
593
/* insert new segment in address order */
595
sc->cell_seg[i] = newp;
596
while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) {
598
sc->cell_seg[i] = sc->cell_seg[i - 1];
599
sc->cell_seg[--i] = p;
601
sc->fcells += CELL_SEGSIZE;
602
last = newp + CELL_SEGSIZE - 1;
603
for (p = newp; p <= last; p++) {
608
/* insert new cells in address order on free list */
609
if (sc->free_cell == sc->NIL || p < sc->free_cell) {
610
cdr(last) = sc->free_cell;
611
sc->free_cell = newp;
614
while (cdr(p) != sc->NIL && newp > cdr(p))
623
static INLINE pointer get_cell(scheme *sc, pointer a, pointer b) {
624
if (sc->free_cell != sc->NIL) {
625
pointer x = sc->free_cell;
626
sc->free_cell = cdr(x);
630
return _get_cell (sc, a, b);
634
/* get new cell. parameter a, b is marked by gc. */
635
static pointer _get_cell(scheme *sc, pointer a, pointer b) {
642
if (sc->free_cell == sc->NIL) {
644
if (sc->fcells < sc->last_cell_seg*8
645
|| sc->free_cell == sc->NIL) {
646
/* if only a few recovered, get more to avoid fruitless gc's */
647
if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) {
654
sc->free_cell = cdr(x);
659
/* make sure that there is a given number of cells free */
660
static pointer reserve_cells(scheme *sc, int n) {
665
/* Are there enough cells available? */
666
if (sc->fcells < n) {
667
/* If not, try gc'ing some */
668
gc(sc, sc->NIL, sc->NIL);
669
if (sc->fcells < n) {
670
/* If there still aren't, try getting more heap */
671
if (!alloc_cellseg(sc,1)) {
676
if (sc->fcells < n) {
677
/* If all fail, report failure */
685
static pointer get_consecutive_cells(scheme *sc, int n) {
692
/* Are there any cells available? */
693
x=find_consecutive_cells(sc,n);
695
/* If not, try gc'ing some */
696
gc(sc, sc->NIL, sc->NIL);
697
x=find_consecutive_cells(sc,n);
699
/* If there still aren't, try getting more heap */
700
if (!alloc_cellseg(sc,1)) {
705
x=find_consecutive_cells(sc,n);
707
/* If all fail, report failure */
715
static int count_consecutive_cells(pointer x, int needed) {
720
if(n>needed) return n;
725
static pointer find_consecutive_cells(scheme *sc, int n) {
730
while(*pp!=sc->NIL) {
731
cnt=count_consecutive_cells(*pp,n);
743
/* get new cons cell */
744
pointer _cons(scheme *sc, pointer a, pointer b, int immutable) {
745
pointer x = get_cell(sc,a, b);
747
typeflag(x) = T_PAIR;
756
/* ========== oblist implementation ========== */
758
#ifndef USE_OBJECT_LIST
760
static int hash_fn(const char *key, int table_size);
762
static pointer oblist_initial_value(scheme *sc)
764
return mk_vector(sc, 461); /* probably should be bigger */
767
/* returns the new symbol */
768
static pointer oblist_add_by_name(scheme *sc, const char *name)
773
x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
774
typeflag(x) = T_SYMBOL;
775
setimmutable(car(x));
777
location = hash_fn(name, ivalue_unchecked(sc->oblist));
778
set_vector_elem(sc->oblist, location,
779
immutable_cons(sc, x, vector_elem(sc->oblist, location)));
783
static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
790
/* case-insensitive, per R5RS section 2. */
791
s = g_utf8_casefold(name, -1);
792
key = g_utf8_collate_key(s, -1);
795
location = hash_fn(name, ivalue_unchecked(sc->oblist));
796
for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
798
if(strcmp(key, s) == 0) {
807
static pointer oblist_all_symbols(scheme *sc)
811
pointer ob_list = sc->NIL;
813
for (i = 0; i < ivalue_unchecked(sc->oblist); i++) {
814
for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) {
815
ob_list = cons(sc, x, ob_list);
823
static pointer oblist_initial_value(scheme *sc)
828
static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
834
/* case-insensitive, per R5RS section 2. */
835
s = g_utf8_casefold(name, -1);
836
key = g_utf8_collate_key(s, -1);
839
for (x = sc->oblist; x != sc->NIL; x = cdr(x)) {
841
if(strcmp(key, s) == 0) {
850
/* returns the new symbol */
851
static pointer oblist_add_by_name(scheme *sc, const char *name)
855
x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
856
typeflag(x) = T_SYMBOL;
857
setimmutable(car(x));
858
sc->oblist = immutable_cons(sc, x, sc->oblist);
862
static pointer oblist_all_symbols(scheme *sc)
869
static pointer mk_port(scheme *sc, port *p) {
870
pointer x = get_cell(sc, sc->NIL, sc->NIL);
872
typeflag(x) = T_PORT|T_ATOM;
877
pointer mk_foreign_func(scheme *sc, foreign_func f) {
878
pointer x = get_cell(sc, sc->NIL, sc->NIL);
880
typeflag(x) = (T_FOREIGN | T_ATOM);
885
INTERFACE pointer mk_character(scheme *sc, gunichar c) {
886
pointer x = get_cell(sc,sc->NIL, sc->NIL);
888
typeflag(x) = (T_CHARACTER | T_ATOM);
889
ivalue_unchecked(x)= c;
894
/* get number atom (integer) */
895
INTERFACE pointer mk_integer(scheme *sc, long num) {
896
pointer x = get_cell(sc,sc->NIL, sc->NIL);
898
typeflag(x) = (T_NUMBER | T_ATOM);
899
ivalue_unchecked(x)= num;
904
INTERFACE pointer mk_real(scheme *sc, double n) {
905
pointer x = get_cell(sc,sc->NIL, sc->NIL);
907
typeflag(x) = (T_NUMBER | T_ATOM);
908
rvalue_unchecked(x)= n;
913
static pointer mk_number(scheme *sc, num n) {
915
return mk_integer(sc,n.value.ivalue);
917
return mk_real(sc,n.value.rvalue);
921
void set_safe_foreign (scheme *sc, pointer data) {
922
if (sc->safe_foreign == sc->NIL) {
923
fprintf (stderr, "get_safe_foreign called outside a foreign function\n");
925
car (sc->safe_foreign) = data;
930
/* char_cnt is length of string in chars. */
931
/* str points to a NUL terminated string. */
932
/* Only uses fill_char if str is NULL. */
933
static char *store_string(scheme *sc, int char_cnt,
934
const char *str, gunichar fill) {
942
q2 = g_utf8_offset_to_pointer(str, (long)char_cnt);
943
(void)g_utf8_validate(str, -1, (const gchar **)&q);
948
q=(gchar*)sc->malloc(len+1);
951
len = g_unichar_to_utf8(fill, utf8);
952
q=(gchar*)sc->malloc(char_cnt*len+1);
963
for (i = 0; i < char_cnt; ++i)
965
memcpy(q2, utf8, len);
974
INTERFACE pointer mk_string(scheme *sc, const char *str) {
975
return mk_counted_string(sc,str,g_utf8_strlen(str, -1));
978
/* len is the length of str in characters */
979
INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
980
pointer x = get_cell(sc, sc->NIL, sc->NIL);
983
strvalue(x) = store_string(sc,len,str,0);
984
s = g_utf8_casefold(strvalue(x), -1);
985
strkey(x) = g_utf8_collate_key(s, -1);
986
typeflag(x) = (T_STRING | T_ATOM);
992
static pointer mk_empty_string(scheme *sc, int len, gunichar fill) {
993
pointer x = get_cell(sc, sc->NIL, sc->NIL);
996
strvalue(x) = store_string(sc,len,0,fill);
997
s = g_utf8_casefold(strvalue(x), -1);
998
strkey(x) = g_utf8_collate_key(s, -1);
999
typeflag(x) = (T_STRING | T_ATOM);
1005
INTERFACE static pointer mk_vector(scheme *sc, int len) {
1006
pointer x=get_consecutive_cells(sc,len/2+len%2+1);
1007
typeflag(x) = (T_VECTOR | T_ATOM);
1008
ivalue_unchecked(x)=len;
1010
fill_vector(x,sc->NIL);
1014
INTERFACE static void fill_vector(pointer vec, pointer obj) {
1016
int num=ivalue(vec)/2+ivalue(vec)%2;
1017
for(i=0; i<num; i++) {
1018
typeflag(vec+1+i) = T_PAIR;
1019
setimmutable(vec+1+i);
1025
INTERFACE static pointer vector_elem(pointer vec, int ielem) {
1028
return car(vec+1+n);
1030
return cdr(vec+1+n);
1034
INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
1037
return car(vec+1+n)=a;
1039
return cdr(vec+1+n)=a;
1043
/* get new symbol */
1044
INTERFACE pointer mk_symbol(scheme *sc, const char *name) {
1047
/* first check oblist */
1048
x = oblist_find_by_name(sc, name);
1052
x = oblist_add_by_name(sc, name);
1057
INTERFACE pointer gensym(scheme *sc) {
1061
for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
1062
sprintf(name,"gensym-%ld",sc->gensym_cnt);
1064
/* first check oblist */
1065
x = oblist_find_by_name(sc, name);
1070
x = oblist_add_by_name(sc, name);
1078
/* make symbol or number atom from string */
1079
static pointer mk_atom(scheme *sc, char *q) {
1081
int has_dec_point=0;
1085
if((p=strstr(q,"::"))!=0) {
1087
return cons(sc, sc->COLON_HOOK,
1091
cons(sc, mk_atom(sc,p+2), sc->NIL)),
1092
cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL)));
1098
if ((c == '+') || (c == '-')) {
1105
return (mk_symbol(sc, strlwr(q)));
1107
} else if (c == '.') {
1111
return (mk_symbol(sc, strlwr(q)));
1113
} else if (!isdigit(c)) {
1114
return (mk_symbol(sc, strlwr(q)));
1117
for ( ; (c = *p) != 0; ++p) {
1120
if(!has_dec_point) {
1125
else if ((c == 'e') || (c == 'E')) {
1127
has_dec_point = 1; /* decimal point illegal
1130
if ((*p == '-') || (*p == '+') || isdigit(*p)) {
1135
return (mk_symbol(sc, strlwr(q)));
1139
return mk_real(sc,g_ascii_strtod(q,NULL));
1141
return (mk_integer(sc, atol(q)));
1145
static pointer mk_sharp_const(scheme *sc, char *name) {
1149
if (!strcmp(name, "t"))
1151
else if (!strcmp(name, "f"))
1153
else if (*name == 'o') {/* #o (octal) */
1154
sprintf(tmp, "0%s", name+1);
1155
sscanf(tmp, "%lo", &x);
1156
return (mk_integer(sc, x));
1157
} else if (*name == 'd') { /* #d (decimal) */
1158
sscanf(name+1, "%ld", &x);
1159
return (mk_integer(sc, x));
1160
} else if (*name == 'x') { /* #x (hex) */
1161
sprintf(tmp, "0x%s", name+1);
1162
sscanf(tmp, "%lx", &x);
1163
return (mk_integer(sc, x));
1164
} else if (*name == 'b') { /* #b (binary) */
1165
x = binary_decode(name+1);
1166
return (mk_integer(sc, x));
1167
} else if (*name == '\\') { /* #\w (character) */
1169
if(stricmp(name+1,"space")==0) {
1171
} else if(stricmp(name+1,"newline")==0) {
1173
} else if(stricmp(name+1,"return")==0) {
1175
} else if(stricmp(name+1,"tab")==0) {
1177
} else if(name[1]=='x' && name[2]!=0) {
1179
if(sscanf(name+2,"%x",&c1)==1 && c1<256) {
1185
} else if(is_ascii_name(name+1,&c)) {
1188
} else if(name[2]==0) {
1193
return mk_character(sc,c);
1198
/* ========== garbage collector ========== */
1201
* We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1202
* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1205
static void mark(pointer a) {
1213
int num=ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
1214
for(i=0; i<num; i++) {
1215
/* Vector cells will be treated like ordinary cells */
1223
if (q && !is_mark(q)) {
1224
setatom(p); /* a note that we have moved car */
1230
E5: q = cdr(p); /* down cdr */
1231
if (q && !is_mark(q)) {
1237
E6: /* up. Undo the link switching from steps E4 and E5. */
1255
/* garbage collection. parameter a, b is marked. */
1256
static void gc(scheme *sc, pointer a, pointer b) {
1260
if(sc->gc_verbose) {
1261
putstr(sc, "gc...");
1264
/* mark system globals */
1266
mark(sc->global_env);
1268
/* mark current registers */
1272
dump_stack_mark(sc);
1274
mark(sc->safe_foreign);
1276
mark(sc->save_inport);
1280
/* mark variables a, b */
1284
/* garbage collect */
1287
sc->free_cell = sc->NIL;
1288
/* free-list is kept sorted by address so as to maintain consecutive
1289
ranges, if possible, for use with vectors. Here we scan the cells
1290
(which are also kept sorted by address) downwards to build the
1291
free-list in sorted order.
1293
for (i = sc->last_cell_seg; i >= 0; i--) {
1294
p = sc->cell_seg[i] + CELL_SEGSIZE;
1295
while (--p >= sc->cell_seg[i]) {
1300
if (typeflag(p) != 0) {
1301
finalize_cell(sc, p);
1306
cdr(p) = sc->free_cell;
1312
if (sc->gc_verbose) {
1314
sprintf(msg,"done: %ld cells were recovered.\n", sc->fcells);
1319
static void finalize_cell(scheme *sc, pointer a) {
1321
sc->free(strvalue(a));
1322
g_free(strkey(a)); /* mem was allocated via glib */
1323
} else if(is_port(a)) {
1324
if(a->_object._port->kind&port_file
1325
&& a->_object._port->rep.stdio.closeit) {
1326
port_close(sc,a,port_input|port_output);
1328
sc->free(a->_object._port);
1332
/* ========== Routines for Reading ========== */
1334
static int file_push(scheme *sc, const char *fname) {
1335
FILE *fin=fopen(fname,"rb");
1338
sc->load_stack[sc->file_i].kind=port_file|port_input;
1339
sc->load_stack[sc->file_i].rep.stdio.file=fin;
1340
sc->load_stack[sc->file_i].rep.stdio.closeit=1;
1341
sc->nesting_stack[sc->file_i]=0;
1342
sc->loadport->_object._port=sc->load_stack+sc->file_i;
1347
static void file_pop(scheme *sc) {
1348
sc->nesting=sc->nesting_stack[sc->file_i];
1350
port_close(sc,sc->loadport,port_input);
1352
sc->loadport->_object._port=sc->load_stack+sc->file_i;
1353
if(file_interactive(sc)) {
1359
static int file_interactive(scheme *sc) {
1360
return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin
1361
&& sc->inport->_object._port->kind&port_file;
1364
static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {
1368
if(prop==(port_input|port_output)) {
1370
} else if(prop==port_output) {
1379
pt=port_rep_from_file(sc,f,prop);
1380
pt->rep.stdio.closeit=1;
1384
static pointer port_from_filename(scheme *sc, const char *fn, int prop) {
1386
pt=port_rep_from_filename(sc,fn,prop);
1390
return mk_port(sc,pt);
1393
static port *port_rep_from_file(scheme *sc, FILE *f, int prop) {
1396
pt=(port*)sc->malloc(sizeof(port));
1400
if(prop==(port_input|port_output)) {
1402
} else if(prop==port_output) {
1407
pt->kind=port_file|prop;
1408
pt->rep.stdio.file=f;
1409
pt->rep.stdio.closeit=0;
1413
static pointer port_from_file(scheme *sc, FILE *f, int prop) {
1415
pt=port_rep_from_file(sc,f,prop);
1419
return mk_port(sc,pt);
1422
static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
1424
pt=(port*)sc->malloc(sizeof(port));
1428
pt->kind=port_string|prop;
1429
pt->rep.string.start=start;
1430
pt->rep.string.curr=start;
1431
pt->rep.string.past_the_end=past_the_end;
1435
static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
1437
pt=port_rep_from_string(sc,start,past_the_end,prop);
1441
return mk_port(sc,pt);
1444
static void port_close(scheme *sc, pointer p, int flag) {
1445
port *pt=p->_object._port;
1447
if((pt->kind & (port_input|port_output))==0) {
1448
if(pt->kind&port_file) {
1449
fclose(pt->rep.stdio.file);
1455
static gunichar basic_inchar(port *pt) {
1458
if(pt->kind&port_file) {
1463
utf8[0] = fgetc(pt->rep.stdio.file);
1466
len = utf8_length[ utf8[0]&0x7F ];
1468
for (i = 0; i < len; ++i)
1469
*s++ = fgetc(pt->rep.stdio.file);
1470
/* FIXME: Check for bad character and search for next good char. */
1471
return g_utf8_get_char_validated(utf8, len+1);
1473
return (gunichar)utf8[0];
1475
if(*pt->rep.string.curr==0
1476
|| pt->rep.string.curr==pt->rep.string.past_the_end) {
1481
len = pt->rep.string.past_the_end - pt->rep.string.curr;
1482
c = g_utf8_get_char_validated(pt->rep.string.curr, len);
1486
pt->rep.string.curr = g_utf8_find_next_char(pt->rep.string.curr,
1487
pt->rep.string.past_the_end);
1488
if (pt->rep.string.curr == NULL)
1489
pt->rep.string.curr = pt->rep.string.past_the_end;
1494
len = g_unichar_to_utf8(c, NULL);
1495
pt->rep.string.curr += len;
1503
/* get new character from input file */
1504
static gunichar inchar(scheme *sc) {
1508
pt=sc->inport->_object._port;
1509
if(pt->kind&port_file && pt->rep.stdio.file == stdin)
1521
if(c==EOF && sc->inport==sc->loadport && sc->file_i!=0) {
1523
if(sc->nesting!=0) {
1533
/* back character to input buffer */
1534
static void backchar(scheme *sc, gunichar c) {
1539
charlen = g_unichar_to_utf8(c, NULL);
1540
pt=sc->inport->_object._port;
1541
if(pt->kind&port_file) {
1542
if (pt->rep.stdio.file == stdin)
1548
if (ftell(pt->rep.stdio.file) >= (long)charlen)
1549
fseek(pt->rep.stdio.file, 0L-(long)charlen, SEEK_CUR);
1552
if(pt->rep.string.curr!=pt->rep.string.start) {
1553
if(pt->rep.string.curr-pt->rep.string.start >= charlen)
1554
pt->rep.string.curr -= charlen;
1556
pt->rep.string.curr = pt->rep.string.start;
1561
/* len is number of UTF-8 characters in string pointed to by chars */
1562
static void putchars(scheme *sc, const char *chars, int char_cnt) {
1565
port *pt=sc->outport->_object._port;
1571
/* Output characters to console mode (if enabled) */
1572
if (ts_output_routine != NULL) /* Should this be left in?? ~~~~~ */
1573
(*ts_output_routine) (pt->rep.stdio.file, (char *)chars, char_cnt);
1576
char_cnt = g_utf8_offset_to_pointer(chars, (long)char_cnt) - chars;
1578
if (sc->print_error) {
1579
l = strlen(sc->linebuff);
1580
s = &sc->linebuff[l];
1581
memcpy(s, chars, min(char_cnt, LINESIZE-l-1));
1585
if(pt->kind&port_file) {
1586
fwrite(chars,1,char_cnt,pt->rep.stdio.file);
1587
fflush(pt->rep.stdio.file);
1589
l = pt->rep.string.past_the_end - pt->rep.string.curr;
1591
memcpy(pt->rep.string.curr, chars, min(char_cnt, l));
1595
INTERFACE void putcharacter(scheme *sc, gunichar c) {
1598
(void)g_unichar_to_utf8(c, utf8);
1599
putchars(sc, utf8, 1);
1602
INTERFACE void putstr(scheme *sc, const char *s) {
1603
putchars(sc, s, g_utf8_strlen(s, -1));
1606
/* read characters up to delimiter, but cater to character constants */
1607
static char *readstr_upto(scheme *sc, char *delim) {
1608
char *p = sc->strbuff;
1610
gunichar c_prev = 0;
1614
while (!is_one_of(delim, (*p++ = inchar(sc))))
1616
if(p==sc->strbuff+2 && p[-2]=='\\') {
1626
len = g_unichar_to_utf8(c, p);
1628
} while (c && !is_one_of(delim, c));
1630
if(p==sc->strbuff+2 && c_prev=='\\')
1634
backchar(sc,c); /* put back the delimiter */
1641
/* read string expression "xxx...xxx" */
1642
static pointer readstrexp(scheme *sc) {
1643
char *p = sc->strbuff;
1647
enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2, st_oct3 } state=st_ok;
1651
if(c==EOF || p-sc->strbuff>sizeof(sc->strbuff)-1) {
1662
return mk_counted_string(sc,sc->strbuff,p-sc->strbuff);
1664
len = g_unichar_to_utf8(c, p);
1680
c1=g_unichar_digit_value(c);
1704
len = g_unichar_to_utf8(c, p);
1712
if (!g_unichar_isxdigit(c))
1714
c1=(c1<<4)+g_unichar_xdigit_value(c);
1725
if (!g_unichar_isdigit(c) || g_unichar_digit_value(c) > 7)
1736
c1=(c1<<3)+g_unichar_digit_value(c);
1756
/* check c is in chars */
1757
static INLINE int is_one_of(char *s, gunichar c) {
1761
if (g_utf8_strchr(s, -1, c) != NULL)
1767
/* skip white characters */
1768
static INLINE void skipspace(scheme *sc) {
1770
while (g_unichar_isspace(c=inchar(sc)))
1778
static int token(scheme *sc) {
1781
switch (c=inchar(sc)) {
1785
return (TOK_LPAREN);
1787
return (TOK_RPAREN);
1790
if(is_one_of(" \n\t",c)) {
1800
while ((c=inchar(sc)) != '\n' && c!=EOF)
1804
return (TOK_DQUOTE);
1806
if ((c=inchar(sc)) == '"')
1807
return (TOK_DQUOTE);
1811
return (TOK_BQUOTE);
1813
if ((c=inchar(sc)) == '@')
1814
return (TOK_ATMARK);
1823
} else if(c == '!') {
1824
while ((c=inchar(sc)) != '\n' && c!=EOF)
1829
if(is_one_of(" tfodxb\\",c)) {
1830
return TOK_SHARP_CONST;
1841
/* ========== Routines for Printing ========== */
1842
#define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL)
1844
static void printslashstring(scheme *sc, char *p, int len) {
1849
putcharacter(sc,'"');
1850
for (i=0; i<len; i++) {
1851
c = g_utf8_get_char(s);
1852
/* Is a check for a value of 0xff still valid in UTF8?? ~~~~~ */
1853
if(c==0xff || c=='"' || c<' ' || c=='\\') {
1854
putcharacter(sc,'\\');
1857
putcharacter(sc,'"');
1860
putcharacter(sc,'n');
1863
putcharacter(sc,'t');
1866
putcharacter(sc,'r');
1869
putcharacter(sc,'\\');
1872
/* This still needs work ~~~~~ */
1874
putcharacter(sc,'x');
1876
putcharacter(sc,d+'0');
1878
putcharacter(sc,d-10+'A');
1882
putcharacter(sc,d+'0');
1884
putcharacter(sc,d-10+'A');
1891
s = g_utf8_next_char(s);
1893
putcharacter(sc,'"');
1898
static void printatom(scheme *sc, pointer l, int f) {
1901
atom2str(sc,l,f,&p,&len);
1906
/* Uses internal buffer unless string pointer is already available */
1907
static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
1912
} else if (l == sc->T) {
1914
} else if (l == sc->F) {
1916
} else if (l == sc->EOF_OBJ) {
1918
} else if (is_port(l)) {
1920
strcpy(p, "#<PORT>");
1921
} else if (is_number(l)) {
1924
sprintf(p, "%ld", ivalue_unchecked(l));
1926
g_ascii_formatd (p, sizeof (sc->strbuff), "%.10g",
1927
rvalue_unchecked(l));
1929
} else if (is_string(l)) {
1932
} else { /* Hack, uses the fact that printing is needed */
1935
printslashstring(sc, strvalue(l),
1936
g_utf8_strlen(strvalue(l), -1));
1939
} else if (is_character(l)) {
1940
gunichar c=charvalue(l);
1943
int len = g_unichar_to_utf8(c, p);
1948
sprintf(p,"#\\space"); break;
1950
sprintf(p,"#\\newline"); break;
1952
sprintf(p,"#\\return"); break;
1954
sprintf(p,"#\\tab"); break;
1958
strcpy(p,"#\\del"); break;
1960
strcpy(p,"#\\"); strcat(p,charnames[c]); break;
1964
sprintf(p,"#\\x%x",c); break;
1967
sprintf(p,"#\\%c",c); break;
1970
} else if (is_symbol(l)) {
1972
} else if (is_proc(l)) {
1974
sprintf(p, "#<%s PROCEDURE %ld>", procname(l),procnum(l));
1975
} else if (is_macro(l)) {
1977
} else if (is_closure(l)) {
1979
} else if (is_promise(l)) {
1981
} else if (is_foreign(l)) {
1983
sprintf(p, "#<FOREIGN PROCEDURE %ld>", procnum(l));
1984
} else if (is_continuation(l)) {
1985
p = "#<CONTINUATION>";
1990
*plen=g_utf8_strlen(p, -1);
1992
/* ========== Routines for Evaluation Cycle ========== */
1994
/* make closure. c is code. e is environment */
1995
static pointer mk_closure(scheme *sc, pointer c, pointer e) {
1996
pointer x = get_cell(sc, c, e);
1998
typeflag(x) = T_CLOSURE;
2004
/* make continuation. */
2005
static pointer mk_continuation(scheme *sc, pointer d) {
2006
pointer x = get_cell(sc, sc->NIL, d);
2008
typeflag(x) = T_CONTINUATION;
2013
static pointer list_star(scheme *sc, pointer d) {
2015
if(cdr(d)==sc->NIL) {
2018
p=cons(sc,car(d),cdr(d));
2020
while(cdr(cdr(p))!=sc->NIL) {
2021
d=cons(sc,car(p),cdr(p));
2022
if(cdr(cdr(p))!=sc->NIL) {
2030
/* reverse list -- produce new list */
2031
static pointer reverse(scheme *sc, pointer a) {
2032
/* a must be checked by gc */
2033
pointer p = sc->NIL;
2035
for ( ; is_pair(a); a = cdr(a)) {
2036
p = cons(sc, car(a), p);
2041
/* reverse list --- in-place */
2042
static pointer reverse_in_place(scheme *sc, pointer term, pointer list) {
2043
pointer p = list, result = term, q;
2045
while (p != sc->NIL) {
2054
/* append list -- produce new list */
2055
static pointer append(scheme *sc, pointer a, pointer b) {
2060
while (a != sc->NIL) {
2070
/* equivalence of atoms */
2071
static int eqv(pointer a, pointer b) {
2074
return (strvalue(a) == strvalue(b));
2077
} else if (is_number(a)) {
2079
return num_eq(nvalue(a),nvalue(b));
2082
} else if (is_character(a)) {
2083
if (is_character(b))
2084
return charvalue(a)==charvalue(b);
2087
} else if (is_port(a)) {
2092
} else if (is_proc(a)) {
2094
return procnum(a)==procnum(b);
2102
/* true or false value macro */
2103
/* () is #t in R5RS */
2104
#define is_true(p) ((p) != sc->F)
2105
#define is_false(p) ((p) == sc->F)
2107
/* ========== Environment implementation ========== */
2109
#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2112
#warning FIXME: Update hash_fn() to handle UTF-8 coded keys
2114
static int hash_fn(const char *key, int table_size)
2116
unsigned int hashed = 0;
2118
int bits_per_int = sizeof(unsigned int)*8;
2120
for (c = key; *c; c++) {
2121
/* letters have about 5 bits in them */
2122
hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
2125
return hashed % table_size;
2129
#ifndef USE_ALIST_ENV
2132
* In this implementation, each frame of the environment may be
2133
* a hash table: a vector of alists hashed by variable name.
2134
* In practice, we use a vector only for the initial frame;
2135
* subsequent frames are too small and transient for the lookup
2136
* speed to out-weigh the cost of making a new vector.
2139
static void new_frame_in_env(scheme *sc, pointer old_env)
2143
/* The interaction-environment has about 300 variables in it. */
2144
if (old_env == sc->NIL) {
2145
new_frame = mk_vector(sc, 461);
2147
new_frame = sc->NIL;
2150
sc->envir = immutable_cons(sc, new_frame, old_env);
2151
setenvironment(sc->envir);
2154
static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2155
pointer variable, pointer value)
2157
pointer slot = immutable_cons(sc, variable, value);
2159
if (is_vector(car(env))) {
2160
int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
2162
set_vector_elem(car(env), location,
2163
immutable_cons(sc, slot, vector_elem(car(env), location)));
2165
car(env) = immutable_cons(sc, slot, car(env));
2169
static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2174
for (x = env; x != sc->NIL; x = cdr(x)) {
2175
if (is_vector(car(x))) {
2176
location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
2177
y = vector_elem(car(x), location);
2181
for ( ; y != sc->NIL; y = cdr(y)) {
2182
if (caar(y) == hdl) {
2199
#else /* USE_ALIST_ENV */
2201
static INLINE void new_frame_in_env(scheme *sc, pointer old_env)
2203
sc->envir = immutable_cons(sc, sc->NIL, old_env);
2204
setenvironment(sc->envir);
2207
static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2208
pointer variable, pointer value)
2210
car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
2213
static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2216
for (x = env; x != sc->NIL; x = cdr(x)) {
2217
for (y = car(x); y != sc->NIL; y = cdr(y)) {
2218
if (caar(y) == hdl) {
2235
#endif /* USE_ALIST_ENV else */
2237
static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
2239
new_slot_spec_in_env(sc, sc->envir, variable, value);
2242
static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
2247
static INLINE pointer slot_value_in_env(pointer slot)
2252
/* ========== Evaluation Cycle ========== */
2255
static pointer _Error_1(scheme *sc, const char *s, pointer a) {
2258
pointer hdl=sc->ERROR_HOOK;
2260
x=find_slot_in_env(sc,sc->envir,hdl,1);
2263
sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
2267
sc->code = cons(sc, mk_string(sc, (s)), sc->code);
2268
setimmutable(car(sc->code));
2269
sc->code = cons(sc, slot_value_in_env(x), sc->code);
2270
sc->op = (int)OP_EVAL;
2276
sc->args = cons(sc, (a), sc->NIL);
2280
sc->args = cons(sc, mk_string(sc, (s)), sc->args);
2281
setimmutable(car(sc->args));
2282
sc->op = (int)OP_ERR0;
2285
#define Error_1(sc,s,a) return _Error_1(sc,s,a)
2286
#define Error_0(sc,s) return _Error_1(sc,s,0)
2288
/* Too small to turn into function */
2290
# define END } while (0)
2291
#define s_goto(sc,a) BEGIN \
2292
sc->op = (int)(a); \
2295
#define s_return(sc,a) return _s_return(sc,a)
2297
#ifndef USE_SCHEME_STACK
2299
/* this structure holds all the interpreter's registers */
2300
struct dump_stack_frame {
2301
enum scheme_opcodes op;
2307
#define STACK_GROWTH 3
2309
static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code)
2311
int nframes = (int)sc->dump;
2312
struct dump_stack_frame *next_frame;
2314
/* enough room for the next frame? */
2315
if (nframes >= sc->dump_size) {
2316
sc->dump_size += STACK_GROWTH;
2317
/* alas there is no sc->realloc */
2318
sc->dump_base = realloc(sc->dump_base,
2319
sizeof(struct dump_stack_frame) * sc->dump_size);
2321
next_frame = (struct dump_stack_frame *)sc->dump_base + nframes;
2322
next_frame->op = op;
2323
next_frame->args = args;
2324
next_frame->envir = sc->envir;
2325
next_frame->code = code;
2326
sc->dump = (pointer)(nframes+1);
2329
static pointer _s_return(scheme *sc, pointer a)
2331
int nframes = (int)sc->dump;
2332
struct dump_stack_frame *frame;
2339
frame = (struct dump_stack_frame *)sc->dump_base + nframes;
2341
sc->args = frame->args;
2342
sc->envir = frame->envir;
2343
sc->code = frame->code;
2344
sc->dump = (pointer)nframes;
2348
static INLINE void dump_stack_reset(scheme *sc)
2350
/* in this implementation, sc->dump is the number of frames on the stack */
2351
sc->dump = (pointer)0;
2354
static INLINE void dump_stack_initialize(scheme *sc)
2357
sc->dump_base = NULL;
2358
dump_stack_reset(sc);
2361
static void dump_stack_free(scheme *sc)
2363
free(sc->dump_base);
2364
sc->dump_base = NULL;
2365
sc->dump = (pointer)0;
2369
static INLINE void dump_stack_mark(scheme *sc)
2371
int nframes = (int)sc->dump;
2373
for(i=0; i<nframes; i++) {
2374
struct dump_stack_frame *frame;
2375
frame = (struct dump_stack_frame *)sc->dump_base + i;
2384
static INLINE void dump_stack_reset(scheme *sc)
2389
static INLINE void dump_stack_initialize(scheme *sc)
2391
dump_stack_reset(sc);
2394
static void dump_stack_free(scheme *sc)
2399
static pointer _s_return(scheme *sc, pointer a) {
2401
if(sc->dump==sc->NIL) return sc->NIL;
2402
sc->op = ivalue(car(sc->dump));
2403
sc->args = cadr(sc->dump);
2404
sc->envir = caddr(sc->dump);
2405
sc->code = cadddr(sc->dump);
2406
sc->dump = cddddr(sc->dump);
2410
static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
2411
sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
2412
sc->dump = cons(sc, (args), sc->dump);
2413
sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump);
2416
static INLINE void dump_stack_mark(scheme *sc)
2422
#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F)
2424
static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
2428
case OP_LOAD: /* load */
2429
if(file_interactive(sc)) {
2430
fprintf(sc->outport->_object._port->rep.stdio.file,
2431
"Loading %s\n", strvalue(car(sc->args)));
2433
if (!file_push(sc,strvalue(car(sc->args)))) {
2434
Error_1(sc,"unable to open", car(sc->args));
2436
s_goto(sc,OP_T0LVL);
2438
case OP_T0LVL: /* top level */
2439
if(file_interactive(sc)) {
2443
dump_stack_reset(sc);
2444
sc->envir = sc->global_env;
2445
sc->save_inport=sc->inport;
2446
sc->inport = sc->loadport;
2447
s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
2448
s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
2449
s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
2450
if (file_interactive(sc)) {
2453
s_goto(sc,OP_READ_INTERNAL);
2455
case OP_T1LVL: /* top level */
2456
sc->code = sc->value;
2457
sc->inport=sc->save_inport;
2460
case OP_READ_INTERNAL: /* internal read */
2461
sc->tok = token(sc);
2462
if(sc->tok==TOK_EOF) {
2463
if(sc->inport==sc->loadport) {
2467
s_return(sc,sc->EOF_OBJ);
2470
s_goto(sc,OP_RDSEXPR);
2473
s_return(sc, gensym(sc));
2475
case OP_VALUEPRINT: /* print evaluation result */
2476
/* OP_VALUEPRINT is always pushed, because when changing from
2477
non-interactive to interactive mode, it needs to be
2478
already on the stack */
2480
putstr(sc,"\nGives: ");
2482
if(file_interactive(sc) || sc->print_output) {
2484
sc->args = sc->value;
2485
s_goto(sc,OP_P0LIST);
2487
s_return(sc,sc->value);
2490
case OP_EVAL: /* main part of evaluation */
2493
/*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
2494
s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
2496
putstr(sc,"\nEval: ");
2497
s_goto(sc,OP_P0LIST);
2502
if (is_symbol(sc->code)) { /* symbol */
2503
x=find_slot_in_env(sc,sc->envir,sc->code,1);
2505
s_return(sc,slot_value_in_env(x));
2507
Error_1(sc,"eval: unbound variable:", sc->code);
2509
} else if (is_pair(sc->code)) {
2510
if (is_syntax(x = car(sc->code))) { /* SYNTAX */
2511
sc->code = cdr(sc->code);
2512
s_goto(sc,syntaxnum(x));
2513
} else {/* first, eval top element and eval arguments */
2514
s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
2515
/* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
2516
sc->code = car(sc->code);
2520
s_return(sc,sc->code);
2523
case OP_E0ARGS: /* eval arguments */
2524
if (is_macro(sc->value)) { /* macro expansion */
2525
s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
2526
sc->args = cons(sc,sc->code, sc->NIL);
2527
sc->code = sc->value;
2528
s_goto(sc,OP_APPLY);
2530
sc->code = cdr(sc->code);
2531
s_goto(sc,OP_E1ARGS);
2534
case OP_E1ARGS: /* eval arguments */
2535
sc->args = cons(sc, sc->value, sc->args);
2536
if (is_pair(sc->code)) { /* continue */
2537
s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
2538
sc->code = car(sc->code);
2542
sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2543
sc->code = car(sc->args);
2544
sc->args = cdr(sc->args);
2545
s_goto(sc,OP_APPLY);
2551
sc->tracing=ivalue(car(sc->args));
2552
s_return(sc,mk_integer(sc,tr));
2556
case OP_APPLY: /* apply 'code' to 'args' */
2559
s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
2561
/* sc->args=cons(sc,sc->code,sc->args);*/
2562
putstr(sc,"\nApply to: ");
2563
s_goto(sc,OP_P0LIST);
2568
if (is_proc(sc->code)) {
2569
s_goto(sc,procnum(sc->code)); /* PROCEDURE */
2570
} else if (is_foreign(sc->code)) {
2571
sc->safe_foreign = cons (sc, sc->NIL, sc->safe_foreign);
2572
x=sc->code->_object._ff(sc,sc->args);
2573
sc->safe_foreign = cdr (sc->safe_foreign);
2575
} else if (is_closure(sc->code) || is_macro(sc->code)
2576
|| is_promise(sc->code)) { /* CLOSURE */
2577
/* Should not accept promise */
2578
/* make environment */
2579
new_frame_in_env(sc, closure_env(sc->code));
2580
for (x = car(closure_code(sc->code)), y = sc->args;
2581
is_pair(x); x = cdr(x), y = cdr(y)) {
2583
Error_0(sc,"not enough arguments");
2585
new_slot_in_env(sc, car(x), car(y));
2590
* if (y != sc->NIL) {
2591
* Error_0(sc,"too many arguments");
2594
} else if (is_symbol(x))
2595
new_slot_in_env(sc, x, y);
2597
Error_1(sc,"syntax error in closure: not a symbol:", x);
2599
sc->code = cdr(closure_code(sc->code));
2601
s_goto(sc,OP_BEGIN);
2602
} else if (is_continuation(sc->code)) { /* CONTINUATION */
2603
sc->dump = cont_dump(sc->code);
2604
s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
2606
Error_0(sc,"illegal function");
2609
case OP_DOMACRO: /* do macro */
2610
sc->code = sc->value;
2613
case OP_LAMBDA: /* lambda */
2614
s_return(sc,mk_closure(sc, sc->code, sc->envir));
2616
case OP_MKCLOSURE: /* make-closure */
2618
if(car(x)==sc->LAMBDA) {
2621
if(cdr(sc->args)==sc->NIL) {
2626
s_return(sc,mk_closure(sc, x, y));
2628
case OP_QUOTE: /* quote */
2630
s_return(sc,car(sc->code));
2632
case OP_DEF0: /* define */
2633
if(is_immutable(car(sc->code)))
2634
Error_1(sc,"define: unable to alter immutable", car(sc->code));
2635
if (is_pair(car(sc->code))) {
2637
sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
2640
sc->code = cadr(sc->code);
2642
if (!is_symbol(x)) {
2643
Error_0(sc,"variable is not a symbol");
2645
s_save(sc,OP_DEF1, sc->NIL, x);
2648
case OP_DEF1: /* define */
2649
x=find_slot_in_env(sc,sc->envir,sc->code,0);
2651
set_slot_in_env(sc, x, sc->value);
2653
new_slot_in_env(sc, sc->code, sc->value);
2655
s_return(sc,sc->code);
2658
case OP_DEFP: /* defined? */
2660
if(cdr(sc->args)!=sc->NIL) {
2663
s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
2665
case OP_SET0: /* set! */
2666
if(is_immutable(car(sc->code)))
2667
Error_1(sc,"set!: unable to alter immutable variable", car(sc->code));
2668
s_save(sc,OP_SET1, sc->NIL, car(sc->code));
2669
sc->code = cadr(sc->code);
2672
case OP_SET1: /* set! */
2673
y=find_slot_in_env(sc,sc->envir,sc->code,1);
2675
set_slot_in_env(sc, y, sc->value);
2676
s_return(sc,sc->value);
2678
Error_1(sc,"set!: unbound variable:", sc->code);
2681
case OP_BEGIN: /* begin */
2682
if (!is_pair(sc->code)) {
2683
s_return(sc,sc->code);
2685
if (cdr(sc->code) != sc->NIL) {
2686
s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
2688
sc->code = car(sc->code);
2691
case OP_IF0: /* if */
2692
s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
2693
sc->code = car(sc->code);
2696
case OP_IF1: /* if */
2697
if (is_true(sc->value))
2698
sc->code = car(sc->code);
2700
sc->code = cadr(sc->code); /* (if #f 1) ==> () because
2701
* car(sc->NIL) = sc->NIL */
2704
case OP_LET0: /* let */
2706
sc->value = sc->code;
2707
sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
2710
case OP_LET1: /* let (calculate parameters) */
2711
sc->args = cons(sc, sc->value, sc->args);
2712
if (is_pair(sc->code)) { /* continue */
2713
s_save(sc,OP_LET1, sc->args, cdr(sc->code));
2714
sc->code = cadar(sc->code);
2718
sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2719
sc->code = car(sc->args);
2720
sc->args = cdr(sc->args);
2724
case OP_LET2: /* let */
2725
new_frame_in_env(sc, sc->envir);
2726
for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
2727
y != sc->NIL; x = cdr(x), y = cdr(y)) {
2728
new_slot_in_env(sc, caar(x), car(y));
2730
if (is_symbol(car(sc->code))) { /* named let */
2731
for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
2733
sc->args = cons(sc, caar(x), sc->args);
2735
x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
2736
new_slot_in_env(sc, car(sc->code), x);
2737
sc->code = cddr(sc->code);
2740
sc->code = cdr(sc->code);
2743
s_goto(sc,OP_BEGIN);
2745
case OP_LET0AST: /* let* */
2746
if (car(sc->code) == sc->NIL) {
2747
new_frame_in_env(sc, sc->envir);
2748
sc->code = cdr(sc->code);
2749
s_goto(sc,OP_BEGIN);
2751
s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
2752
sc->code = cadaar(sc->code);
2755
case OP_LET1AST: /* let* (make new frame) */
2756
new_frame_in_env(sc, sc->envir);
2757
s_goto(sc,OP_LET2AST);
2759
case OP_LET2AST: /* let* (calculate parameters) */
2760
new_slot_in_env(sc, caar(sc->code), sc->value);
2761
sc->code = cdr(sc->code);
2762
if (is_pair(sc->code)) { /* continue */
2763
s_save(sc,OP_LET2AST, sc->args, sc->code);
2764
sc->code = cadar(sc->code);
2768
sc->code = sc->args;
2770
s_goto(sc,OP_BEGIN);
2773
sprintf(sc->strbuff, "%d: illegal operator", sc->op);
2774
Error_0(sc,sc->strbuff);
2779
static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
2783
case OP_LET0REC: /* letrec */
2784
new_frame_in_env(sc, sc->envir);
2786
sc->value = sc->code;
2787
sc->code = car(sc->code);
2788
s_goto(sc,OP_LET1REC);
2790
case OP_LET1REC: /* letrec (calculate parameters) */
2791
sc->args = cons(sc, sc->value, sc->args);
2792
if (is_pair(sc->code)) { /* continue */
2793
s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
2794
sc->code = cadar(sc->code);
2798
sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2799
sc->code = car(sc->args);
2800
sc->args = cdr(sc->args);
2801
s_goto(sc,OP_LET2REC);
2804
case OP_LET2REC: /* letrec */
2805
for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
2806
new_slot_in_env(sc, caar(x), car(y));
2808
sc->code = cdr(sc->code);
2810
s_goto(sc,OP_BEGIN);
2812
case OP_COND0: /* cond */
2813
if (!is_pair(sc->code)) {
2814
Error_0(sc,"syntax error in cond");
2816
s_save(sc,OP_COND1, sc->NIL, sc->code);
2817
sc->code = caar(sc->code);
2820
case OP_COND1: /* cond */
2821
if (is_true(sc->value)) {
2822
if ((sc->code = cdar(sc->code)) == sc->NIL) {
2823
s_return(sc,sc->value);
2825
if(car(sc->code)==sc->FEED_TO) {
2826
if(!is_pair(cdr(sc->code))) {
2827
Error_0(sc,"syntax error in cond");
2829
x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
2830
sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
2833
s_goto(sc,OP_BEGIN);
2835
if ((sc->code = cdr(sc->code)) == sc->NIL) {
2836
s_return(sc,sc->NIL);
2838
s_save(sc,OP_COND1, sc->NIL, sc->code);
2839
sc->code = caar(sc->code);
2844
case OP_DELAY: /* delay */
2845
x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
2846
typeflag(x)=T_PROMISE;
2849
case OP_AND0: /* and */
2850
if (sc->code == sc->NIL) {
2853
s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
2854
sc->code = car(sc->code);
2857
case OP_AND1: /* and */
2858
if (is_false(sc->value)) {
2859
s_return(sc,sc->value);
2860
} else if (sc->code == sc->NIL) {
2861
s_return(sc,sc->value);
2863
s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
2864
sc->code = car(sc->code);
2868
case OP_OR0: /* or */
2869
if (sc->code == sc->NIL) {
2872
s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
2873
sc->code = car(sc->code);
2876
case OP_OR1: /* or */
2877
if (is_true(sc->value)) {
2878
s_return(sc,sc->value);
2879
} else if (sc->code == sc->NIL) {
2880
s_return(sc,sc->value);
2882
s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
2883
sc->code = car(sc->code);
2887
case OP_C0STREAM: /* cons-stream */
2888
s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
2889
sc->code = car(sc->code);
2892
case OP_C1STREAM: /* cons-stream */
2893
sc->args = sc->value; /* save sc->value to register sc->args for gc */
2894
x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
2895
typeflag(x)=T_PROMISE;
2896
s_return(sc,cons(sc, sc->args, x));
2898
case OP_MACRO0: /* macro */
2899
if (is_pair(car(sc->code))) {
2901
sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
2904
sc->code = cadr(sc->code);
2906
if (!is_symbol(x)) {
2907
Error_0(sc,"variable is not a symbol");
2909
s_save(sc,OP_MACRO1, sc->NIL, x);
2912
case OP_MACRO1: /* macro */
2913
typeflag(sc->value) = T_MACRO;
2914
x = find_slot_in_env(sc, sc->envir, sc->code, 0);
2916
set_slot_in_env(sc, x, sc->value);
2918
new_slot_in_env(sc, sc->code, sc->value);
2920
s_return(sc,sc->code);
2922
case OP_CASE0: /* case */
2923
s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
2924
sc->code = car(sc->code);
2927
case OP_CASE1: /* case */
2928
for (x = sc->code; x != sc->NIL; x = cdr(x)) {
2929
if (!is_pair(y = caar(x))) {
2932
for ( ; y != sc->NIL; y = cdr(y)) {
2933
if (eqv(car(y), sc->value)) {
2942
if (is_pair(caar(x))) {
2944
s_goto(sc,OP_BEGIN);
2946
s_save(sc,OP_CASE2, sc->NIL, cdar(x));
2951
s_return(sc,sc->NIL);
2954
case OP_CASE2: /* case */
2955
if (is_true(sc->value)) {
2956
s_goto(sc,OP_BEGIN);
2958
s_return(sc,sc->NIL);
2961
case OP_PAPPLY: /* apply */
2962
sc->code = car(sc->args);
2963
sc->args = list_star(sc,cdr(sc->args));
2964
/*sc->args = cadr(sc->args);*/
2965
s_goto(sc,OP_APPLY);
2967
case OP_PEVAL: /* eval */
2968
if(cdr(sc->args)!=sc->NIL) {
2969
sc->envir=cadr(sc->args);
2971
sc->code = car(sc->args);
2974
case OP_CONTINUATION: /* call-with-current-continuation */
2975
sc->code = car(sc->args);
2976
sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
2977
s_goto(sc,OP_APPLY);
2980
sprintf(sc->strbuff, "%d: illegal operator", sc->op);
2981
Error_0(sc,sc->strbuff);
2986
static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
2995
case OP_INEX2EX: /* inexact->exact */
2999
} else if(modf(rvalue_unchecked(x),&dd)==0.0) {
3000
s_return(sc,mk_integer(sc,ivalue(x)));
3002
Error_1(sc,"inexact->exact: not integral:",x);
3007
s_return(sc, mk_real(sc, exp(rvalue(x))));
3011
s_return(sc, mk_real(sc, log(rvalue(x))));
3015
s_return(sc, mk_real(sc, sin(rvalue(x))));
3019
s_return(sc, mk_real(sc, cos(rvalue(x))));
3023
s_return(sc, mk_real(sc, tan(rvalue(x))));
3027
s_return(sc, mk_real(sc, asin(rvalue(x))));
3031
s_return(sc, mk_real(sc, acos(rvalue(x))));
3035
if(cdr(sc->args)==sc->NIL) {
3036
s_return(sc, mk_real(sc, atan(rvalue(x))));
3038
pointer y=cadr(sc->args);
3039
s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
3044
s_return(sc, mk_real(sc, sqrt(rvalue(x))));
3048
if(cdr(sc->args)==sc->NIL) {
3049
Error_0(sc,"expt: needs two arguments");
3051
pointer y=cadr(sc->args);
3052
s_return(sc, mk_real(sc, pow(rvalue(x),rvalue(y))));
3057
s_return(sc, mk_real(sc, floor(rvalue(x))));
3061
s_return(sc, mk_real(sc, ceil(rvalue(x))));
3063
case OP_TRUNCATE : {
3064
double rvalue_of_x ;
3066
rvalue_of_x = rvalue(x) ;
3067
if (rvalue_of_x > 0) {
3068
s_return(sc, mk_real(sc, floor(rvalue_of_x)));
3070
s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
3076
s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
3079
case OP_ADD: /* + */
3081
for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3082
v=num_add(v,nvalue(car(x)));
3084
s_return(sc,mk_number(sc, v));
3086
case OP_MUL: /* * */
3088
for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3089
v=num_mul(v,nvalue(car(x)));
3091
s_return(sc,mk_number(sc, v));
3093
case OP_SUB: /* - */
3094
if(cdr(sc->args)==sc->NIL) {
3099
v = nvalue(car(sc->args));
3101
for (; x != sc->NIL; x = cdr(x)) {
3102
v=num_sub(v,nvalue(car(x)));
3104
s_return(sc,mk_number(sc, v));
3106
case OP_DIV: /* / */
3107
if(cdr(sc->args)==sc->NIL) {
3112
v = nvalue(car(sc->args));
3114
for (; x != sc->NIL; x = cdr(x)) {
3115
if (!is_zero_double(rvalue(car(x))))
3116
v=num_div(v,nvalue(car(x)));
3118
Error_0(sc,"/: division by zero");
3121
s_return(sc,mk_number(sc, v));
3123
case OP_INTDIV: /* quotient */
3124
if(cdr(sc->args)==sc->NIL) {
3129
v = nvalue(car(sc->args));
3131
for (; x != sc->NIL; x = cdr(x)) {
3132
if (ivalue(car(x)) != 0)
3133
v=num_intdiv(v,nvalue(car(x)));
3135
Error_0(sc,"quotient: division by zero");
3138
s_return(sc,mk_number(sc, v));
3140
case OP_REM: /* remainder */
3141
v = nvalue(car(sc->args));
3142
if (ivalue(cadr(sc->args)) != 0)
3143
v=num_rem(v,nvalue(cadr(sc->args)));
3145
Error_0(sc,"remainder: division by zero");
3147
s_return(sc,mk_number(sc, v));
3149
case OP_MOD: /* modulo */
3150
v = nvalue(car(sc->args));
3151
if (ivalue(cadr(sc->args)) != 0)
3152
v=num_mod(v,nvalue(cadr(sc->args)));
3154
Error_0(sc,"modulo: division by zero");
3156
s_return(sc,mk_number(sc, v));
3158
case OP_CAR: /* car */
3159
s_return(sc,caar(sc->args));
3161
case OP_CDR: /* cdr */
3162
s_return(sc,cdar(sc->args));
3164
case OP_CONS: /* cons */
3165
cdr(sc->args) = cadr(sc->args);
3166
s_return(sc,sc->args);
3168
case OP_SETCAR: /* set-car! */
3169
if(!is_immutable(car(sc->args))) {
3170
caar(sc->args) = cadr(sc->args);
3171
s_return(sc,car(sc->args));
3173
Error_0(sc,"set-car!: unable to alter immutable pair");
3176
case OP_SETCDR: /* set-cdr! */
3177
if(!is_immutable(car(sc->args))) {
3178
cdar(sc->args) = cadr(sc->args);
3179
s_return(sc,car(sc->args));
3181
Error_0(sc,"set-cdr!: unable to alter immutable pair");
3184
case OP_CHAR2INT: { /* char->integer */
3186
c=ivalue(car(sc->args));
3187
s_return(sc,mk_integer(sc,c));
3190
case OP_INT2CHAR: { /* integer->char */
3192
c=(gunichar)ivalue(car(sc->args));
3193
s_return(sc,mk_character(sc,c));
3196
case OP_CHARUPCASE: {
3198
c=(gunichar)ivalue(car(sc->args));
3199
c=g_unichar_toupper(c);
3200
s_return(sc,mk_character(sc,c));
3203
case OP_CHARDNCASE: {
3205
c=(gunichar)ivalue(car(sc->args));
3206
c=g_unichar_tolower(c);
3207
s_return(sc,mk_character(sc,c));
3210
case OP_STR2SYM: /* string->symbol */
3211
s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));
3213
case OP_STR2ATOM: /* string->atom */ {
3214
char *s=strvalue(car(sc->args));
3216
s_return(sc, mk_sharp_const(sc, s+1));
3218
s_return(sc, mk_atom(sc, s));
3222
case OP_SYM2STR: /* symbol->string */
3223
x=mk_string(sc,symname(car(sc->args)));
3226
case OP_ATOM2STR: /* atom->string */
3228
if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
3231
atom2str(sc,x,0,&p,&len);
3232
s_return(sc,mk_counted_string(sc,p,len));
3234
Error_1(sc, "atom->string: not an atom:", x);
3237
case OP_MKSTRING: { /* make-string */
3241
len=ivalue(car(sc->args));
3243
if(cdr(sc->args)!=sc->NIL) {
3244
fill=charvalue(cadr(sc->args));
3246
s_return(sc,mk_empty_string(sc,len,fill));
3249
case OP_STRLEN: /* string-length */
3250
s_return(sc,mk_integer(sc,g_utf8_strlen(strvalue(car(sc->args)), -1)));
3252
case OP_STRREF: { /* string-ref */
3256
str=strvalue(car(sc->args));
3258
index=ivalue(cadr(sc->args));
3260
if(index>=g_utf8_strlen(strvalue(car(sc->args)), -1)) {
3261
Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
3264
str = g_utf8_offset_to_pointer(str, (long)index);
3265
s_return(sc,mk_character(sc, g_utf8_get_char(str)));
3268
case OP_STRSET: { /* string-set! */
3282
if(is_immutable(a)) {
3283
Error_1(sc,"string-set!: unable to alter immutable string:",a);
3287
index=ivalue(cadr(sc->args));
3288
if(index>=g_utf8_strlen(str, -1)) {
3289
Error_1(sc,"string-set!: out of bounds:",cadr(sc->args));
3292
c=charvalue(caddr(sc->args));
3293
utf8_len = g_unichar_to_utf8(c, utf8);
3295
p1 = g_utf8_offset_to_pointer(str, (long)index);
3296
p2 = g_utf8_offset_to_pointer(str, (long)index+1);
3298
p2_len = strlen(p2);
3300
newlen = p1_len+utf8_len+p2_len;
3301
newstr = (char *)sc->malloc(newlen+1);
3302
if (newstr == NULL) {
3304
Error_1(sc,"string-set!: No memory to alter string:",car(sc->args));
3308
memcpy(newstr, str, p1_len);
3309
memcpy(newstr+p1_len, utf8, utf8_len);
3311
memcpy(newstr+p1_len+utf8_len, p2, p2_len);
3312
newstr[newlen] = '\0';
3315
g_free(strkey(a)); /* mem was allocated via glib */
3317
p1 = g_utf8_casefold(strvalue(a), -1);
3318
strkey(a) = g_utf8_collate_key(p1, -1);
3320
strlength(a)=newlen;
3325
case OP_STRAPPEND: { /* string-append */
3326
/* in 1.29 string-append was in Scheme in init.scm but was too slow */
3332
/* compute needed length for new string */
3333
for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3334
len += strlength(car(x));
3336
newstr = mk_empty_string(sc, len, ' ');
3337
/* store the contents of the argument strings into the new string */
3338
pos = strvalue(newstr);
3339
for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3341
memcpy(pos, strvalue(car_x), strlength(car_x));
3342
pos += strlength(car_x);
3345
s_return(sc, newstr);
3348
case OP_SUBSTR: { /* substring */
3357
str=strvalue(car(sc->args));
3359
index0=ivalue(cadr(sc->args));
3361
if(index0>g_utf8_strlen(str, -1)) {
3362
Error_1(sc,"substring: start out of bounds:",cadr(sc->args));
3365
if(cddr(sc->args)!=sc->NIL) {
3366
index1=ivalue(caddr(sc->args));
3367
if(index1>g_utf8_strlen(str, -1) || index1<index0) {
3368
Error_1(sc,"substring: end out of bounds:",caddr(sc->args));
3371
index1=g_utf8_strlen(str, -1);
3374
beg = g_utf8_offset_to_pointer(str, (long)index0);
3375
end = g_utf8_offset_to_pointer(str, (long)index1);
3377
x=mk_empty_string(sc,len,' ');
3378
memcpy(strvalue(x),beg,len);
3379
strvalue(x)[len] = '\0';
3384
case OP_VECTOR: { /* vector */
3387
int len=list_length(sc,sc->args);
3389
Error_1(sc,"vector: not a proper list:",sc->args);
3391
vec=mk_vector(sc,len);
3392
for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
3393
set_vector_elem(vec,i,car(x));
3398
case OP_MKVECTOR: { /* make-vector */
3399
pointer fill=sc->NIL;
3403
len=ivalue(car(sc->args));
3405
if(cdr(sc->args)!=sc->NIL) {
3406
fill=cadr(sc->args);
3408
vec=mk_vector(sc,len);
3410
fill_vector(vec,fill);
3415
case OP_VECLEN: /* vector-length */
3416
s_return(sc,mk_integer(sc,ivalue(car(sc->args))));
3418
case OP_VECREF: { /* vector-ref */
3421
index=ivalue(cadr(sc->args));
3423
if(index>=ivalue(car(sc->args))) {
3424
Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args));
3427
s_return(sc,vector_elem(car(sc->args),index));
3430
case OP_VECSET: { /* vector-set! */
3433
if(is_immutable(car(sc->args))) {
3434
Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args));
3437
index=ivalue(cadr(sc->args));
3438
if(index>=ivalue(car(sc->args))) {
3439
Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args));
3442
set_vector_elem(car(sc->args),index,caddr(sc->args));
3443
s_return(sc,car(sc->args));
3447
sprintf(sc->strbuff, "%d: illegal operator", sc->op);
3448
Error_0(sc,sc->strbuff);
3453
static int is_list(scheme *sc, pointer a) {
3459
if (fast == sc->NIL)
3464
if (fast == sc->NIL)
3473
/* the fast pointer has looped back around and caught up
3474
with the slow pointer, hence the structure is circular,
3475
not of finite length, and therefore not a list */
3481
static int list_length(scheme *sc, pointer a) {
3488
if (fast == sc->NIL)
3494
if (fast == sc->NIL)
3504
/* the fast pointer has looped back around and caught up
3505
with the slow pointer, hence the structure is circular,
3506
not of finite length, and therefore not a list */
3512
static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
3515
int (*comp_func)(num,num)=0;
3518
case OP_NOT: /* not */
3519
s_retbool(is_false(car(sc->args)));
3520
case OP_BOOLP: /* boolean? */
3521
s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
3522
case OP_EOFOBJP: /* boolean? */
3523
s_retbool(car(sc->args) == sc->EOF_OBJ);
3524
case OP_NULLP: /* null? */
3525
s_retbool(car(sc->args) == sc->NIL);
3526
case OP_NUMEQ: /* = */
3527
case OP_LESS: /* < */
3528
case OP_GRE: /* > */
3529
case OP_LEQ: /* <= */
3530
case OP_GEQ: /* >= */
3532
case OP_NUMEQ: comp_func=num_eq; break;
3533
case OP_LESS: comp_func=num_lt; break;
3534
case OP_GRE: comp_func=num_gt; break;
3535
case OP_LEQ: comp_func=num_le; break;
3536
case OP_GEQ: comp_func=num_ge; break;
3537
default: break; /* Quiet the compiler */
3543
for (; x != sc->NIL; x = cdr(x)) {
3544
if(!comp_func(v,nvalue(car(x)))) {
3550
case OP_SYMBOLP: /* symbol? */
3551
s_retbool(is_symbol(car(sc->args)));
3552
case OP_NUMBERP: /* number? */
3553
s_retbool(is_number(car(sc->args)));
3554
case OP_STRINGP: /* string? */
3555
s_retbool(is_string(car(sc->args)));
3556
case OP_INTEGERP: /* integer? */
3557
s_retbool(is_integer(car(sc->args)));
3558
case OP_REALP: /* real? */
3559
s_retbool(is_number(car(sc->args))); /* All numbers are real */
3560
case OP_CHARP: /* char? */
3561
s_retbool(is_character(car(sc->args)));
3562
#if USE_CHAR_CLASSIFIERS
3563
case OP_CHARAP: /* char-alphabetic? */
3564
s_retbool(Cisalpha(ivalue(car(sc->args))));
3565
case OP_CHARNP: /* char-numeric? */
3566
s_retbool(Cisdigit(ivalue(car(sc->args))));
3567
case OP_CHARWP: /* char-whitespace? */
3568
s_retbool(Cisspace(ivalue(car(sc->args))));
3569
case OP_CHARUP: /* char-upper-case? */
3570
s_retbool(Cisupper(ivalue(car(sc->args))));
3571
case OP_CHARLP: /* char-lower-case? */
3572
s_retbool(Cislower(ivalue(car(sc->args))));
3574
case OP_PORTP: /* port? */
3575
s_retbool(is_port(car(sc->args)));
3576
case OP_INPORTP: /* input-port? */
3577
s_retbool(is_inport(car(sc->args)));
3578
case OP_OUTPORTP: /* output-port? */
3579
s_retbool(is_outport(car(sc->args)));
3580
case OP_PROCP: /* procedure? */
3582
* continuation should be procedure by the example
3583
* (call-with-current-continuation procedure?) ==> #t
3584
* in R^3 report sec. 6.9
3586
s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args))
3587
|| is_continuation(car(sc->args)) || is_foreign(car(sc->args)));
3588
case OP_PAIRP: /* pair? */
3589
s_retbool(is_pair(car(sc->args)));
3590
case OP_LISTP: /* list? */
3591
s_retbool(is_list(sc, car(sc->args)));
3592
case OP_ENVP: /* environment? */
3593
s_retbool(is_environment(car(sc->args)));
3594
case OP_VECTORP: /* vector? */
3595
s_retbool(is_vector(car(sc->args)));
3596
case OP_EQ: /* eq? */
3597
s_retbool(car(sc->args) == cadr(sc->args));
3598
case OP_EQV: /* eqv? */
3599
s_retbool(eqv(car(sc->args), cadr(sc->args)));
3601
sprintf(sc->strbuff, "%d: illegal operator", sc->op);
3602
Error_0(sc,sc->strbuff);
3607
static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
3611
case OP_FORCE: /* force */
3612
sc->code = car(sc->args);
3613
if (is_promise(sc->code)) {
3614
/* Should change type to closure here */
3615
s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
3617
s_goto(sc,OP_APPLY);
3619
s_return(sc,sc->code);
3622
case OP_SAVE_FORCED: /* Save forced value replacing promise */
3623
memcpy(sc->code,sc->value,sizeof(struct cell));
3624
s_return(sc,sc->value);
3626
case OP_WRITE: /* write */
3627
case OP_DISPLAY: /* display */
3628
case OP_WRITE_CHAR: /* write-char */
3629
if(is_pair(cdr(sc->args))) {
3630
if(cadr(sc->args)!=sc->outport) {
3631
x=cons(sc,sc->outport,sc->NIL);
3632
s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
3633
sc->outport=cadr(sc->args);
3636
sc->args = car(sc->args);
3642
s_goto(sc,OP_P0LIST);
3644
case OP_NEWLINE: /* newline */
3645
if(is_pair(sc->args)) {
3646
if(car(sc->args)!=sc->outport) {
3647
x=cons(sc,sc->outport,sc->NIL);
3648
s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
3649
sc->outport=car(sc->args);
3655
case OP_ERR0: /* error */
3657
if (!is_string(car(sc->args))) {
3658
sc->args=cons(sc,mk_string(sc," -- "),sc->args);
3659
setimmutable(car(sc->args));
3661
if (sc->print_error == 0) /* Reset buffer if not already */
3662
sc->linebuff[0] = '\0'; /* in error message output mode*/
3663
sc->print_error = 1;
3664
putstr(sc, "Error: ");
3665
putstr(sc, strvalue(car(sc->args)));
3666
sc->args = cdr(sc->args);
3669
case OP_ERR1: /* error */
3671
if (sc->args != sc->NIL) {
3672
s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL);
3673
sc->args = car(sc->args);
3675
s_goto(sc,OP_P0LIST);
3678
sc->print_error = 0;
3679
if(sc->interactive_repl) {
3680
s_goto(sc,OP_T0LVL);
3686
case OP_REVERSE: /* reverse */
3687
s_return(sc,reverse(sc, car(sc->args)));
3689
case OP_LIST_STAR: /* list* */
3690
s_return(sc,list_star(sc,sc->args));
3692
case OP_APPEND: /* append */
3693
if(sc->args==sc->NIL) {
3694
s_return(sc,sc->NIL);
3697
if(cdr(sc->args)==sc->NIL) {
3698
s_return(sc,sc->args);
3700
for (y = cdr(sc->args); y != sc->NIL; y = cdr(y)) {
3701
x=append(sc,x,car(y));
3706
case OP_PUT: /* put */
3707
if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
3708
Error_0(sc,"illegal use of put");
3710
for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
3716
cdar(x) = caddr(sc->args);
3718
symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)),
3719
symprop(car(sc->args)));
3722
case OP_GET: /* get */
3723
if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
3724
Error_0(sc,"illegal use of get");
3726
for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
3732
s_return(sc,cdar(x));
3734
s_return(sc,sc->NIL);
3736
#endif /* USE_PLIST */
3737
case OP_QUIT: /* quit */
3738
if(is_pair(sc->args)) {
3739
sc->retcode=ivalue(car(sc->args));
3743
case OP_GC: /* gc */
3744
gc(sc, sc->NIL, sc->NIL);
3747
case OP_GCVERB: /* gc-verbose */
3748
{ int was = sc->gc_verbose;
3750
sc->gc_verbose = (car(sc->args) != sc->F);
3754
case OP_NEWSEGMENT: /* new-segment */
3755
if (!is_pair(sc->args) || !is_number(car(sc->args))) {
3756
Error_0(sc,"new-segment: argument must be a number");
3758
alloc_cellseg(sc, (int) ivalue(car(sc->args)));
3761
case OP_OBLIST: /* oblist */
3762
s_return(sc, oblist_all_symbols(sc));
3764
case OP_CURR_INPORT: /* current-input-port */
3765
s_return(sc,sc->inport);
3767
case OP_CURR_OUTPORT: /* current-output-port */
3768
s_return(sc,sc->outport);
3770
case OP_OPEN_INFILE: /* open-input-file */
3771
case OP_OPEN_OUTFILE: /* open-output-file */
3772
case OP_OPEN_INOUTFILE: /* open-input-output-file */ {
3776
case OP_OPEN_INFILE: prop=port_input; break;
3777
case OP_OPEN_OUTFILE: prop=port_output; break;
3778
case OP_OPEN_INOUTFILE: prop=port_input|port_output; break;
3779
default: break; /* Quiet the compiler */
3781
p=port_from_filename(sc,strvalue(car(sc->args)),prop);
3788
#if USE_STRING_PORTS
3789
case OP_OPEN_INSTRING: /* open-input-string */
3790
case OP_OPEN_OUTSTRING: /* open-output-string */
3791
case OP_OPEN_INOUTSTRING: /* open-input-output-string */ {
3795
case OP_OPEN_INSTRING: prop=port_input; break;
3796
case OP_OPEN_OUTSTRING: prop=port_output; break;
3797
case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break;
3798
default: break; /* Quiet the compiler */
3800
p=port_from_string(sc, strvalue(car(sc->args)),
3801
strvalue(car(sc->args))+strlength(car(sc->args)), prop);
3809
case OP_CLOSE_INPORT: /* close-input-port */
3810
port_close(sc,car(sc->args),port_input);
3813
case OP_CLOSE_OUTPORT: /* close-output-port */
3814
port_close(sc,car(sc->args),port_output);
3817
case OP_INT_ENV: /* interaction-environment */
3818
s_return(sc,sc->global_env);
3820
case OP_CURR_ENV: /* current-environment */
3821
s_return(sc,sc->envir);
3824
sprintf(sc->strbuff, "%d: illegal operator", sc->op);
3825
Error_0(sc,sc->strbuff);
3830
static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
3833
if(sc->nesting!=0) {
3837
Error_1(sc,"unmatched parentheses:",mk_integer(sc,n));
3841
/* ========== reading part ========== */
3843
if(!is_pair(sc->args)) {
3844
s_goto(sc,OP_READ_INTERNAL);
3846
if(!is_inport(car(sc->args))) {
3847
Error_1(sc,"read: not an input port:",car(sc->args));
3849
if(car(sc->args)==sc->inport) {
3850
s_goto(sc,OP_READ_INTERNAL);
3853
sc->inport=car(sc->args);
3854
x=cons(sc,x,sc->NIL);
3855
s_save(sc,OP_SET_INPORT, x, sc->NIL);
3856
s_goto(sc,OP_READ_INTERNAL);
3858
case OP_READ_CHAR: /* read-char */
3859
case OP_PEEK_CHAR: /* peek-char */ {
3861
if(is_pair(sc->args)) {
3862
if(car(sc->args)!=sc->inport) {
3864
x=cons(sc,x,sc->NIL);
3865
s_save(sc,OP_SET_INPORT, x, sc->NIL);
3866
sc->inport=car(sc->args);
3871
s_return(sc,sc->EOF_OBJ);
3873
if(sc->op==OP_PEEK_CHAR) {
3876
s_return(sc,mk_character(sc,c));
3879
case OP_CHAR_READY: /* char-ready? */ {
3880
pointer p=sc->inport;
3882
if(is_pair(sc->args)) {
3885
res=p->_object._port->kind&port_string;
3889
case OP_SET_INPORT: /* set-input-port */
3890
sc->inport=car(sc->args);
3891
s_return(sc,sc->value);
3893
case OP_SET_OUTPORT: /* set-output-port */
3894
sc->outport=car(sc->args);
3895
s_return(sc,sc->value);
3900
if(sc->inport==sc->loadport) {
3904
s_return(sc,sc->EOF_OBJ);
3907
* Commented out because we now skip comments in the scanner
3911
while ((c=inchar(sc)) != '\n' && c!=EOF)
3913
sc->tok = token(sc);
3914
s_goto(sc,OP_RDSEXPR);
3918
s_save(sc,OP_RDVEC,sc->NIL,sc->NIL);
3921
sc->tok = token(sc);
3922
if (sc->tok == TOK_RPAREN) {
3923
s_return(sc,sc->NIL);
3924
} else if (sc->tok == TOK_DOT) {
3925
Error_0(sc,"syntax error: illegal dot expression");
3927
sc->nesting_stack[sc->file_i]++;
3928
s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
3929
s_goto(sc,OP_RDSEXPR);
3932
s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
3933
sc->tok = token(sc);
3934
s_goto(sc,OP_RDSEXPR);
3936
sc->tok = token(sc);
3937
if(sc->tok==TOK_VEC) {
3938
s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
3940
s_goto(sc,OP_RDSEXPR);
3942
s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL);
3944
s_goto(sc,OP_RDSEXPR);
3946
s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL);
3947
sc->tok = token(sc);
3948
s_goto(sc,OP_RDSEXPR);
3950
s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL);
3951
sc->tok = token(sc);
3952
s_goto(sc,OP_RDSEXPR);
3954
s_return(sc,mk_atom(sc, readstr_upto(sc, "();\t\n\r ")));
3958
Error_0(sc,"Error reading string");
3963
pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1);
3965
Error_0(sc,"undefined sharp expression");
3967
sc->code=cons(sc,slot_value_in_env(f),sc->NIL);
3971
case TOK_SHARP_CONST:
3972
if ((x = mk_sharp_const(sc, readstr_upto(sc, "();\t\n\r "))) == sc->NIL) {
3973
Error_0(sc,"undefined sharp expression");
3978
sprintf(sc->linebuff, "syntax error: illegal token %d", sc->tok);
3979
Error_0(sc,sc->linebuff);
3984
sc->args = cons(sc, sc->value, sc->args);
3985
sc->tok = token(sc);
3986
/* We now skip comments in the scanner
3987
while (sc->tok == TOK_COMMENT) {
3989
while ((c=inchar(sc)) != '\n' && c!=EOF)
3991
sc->tok = token(sc);
3994
if (sc->tok == TOK_RPAREN) {
3995
gunichar c = inchar(sc);
3996
if (c != '\n') backchar(sc,c);
3997
sc->nesting_stack[sc->file_i]--;
3998
s_return(sc,reverse_in_place(sc, sc->NIL, sc->args));
3999
} else if (sc->tok == TOK_DOT) {
4000
s_save(sc,OP_RDDOT, sc->args, sc->NIL);
4001
sc->tok = token(sc);
4002
s_goto(sc,OP_RDSEXPR);
4004
s_save(sc,OP_RDLIST, sc->args, sc->NIL);
4005
s_goto(sc,OP_RDSEXPR);
4010
if (token(sc) != TOK_RPAREN) {
4011
Error_0(sc,"syntax error: illegal dot expression");
4013
sc->nesting_stack[sc->file_i]--;
4014
s_return(sc,reverse_in_place(sc, sc->value, sc->args));
4018
s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)));
4021
s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)));
4023
case OP_RDQQUOTEVEC:
4024
s_return(sc,cons(sc, mk_symbol(sc,"apply"),
4025
cons(sc, mk_symbol(sc,"vector"),
4026
cons(sc,cons(sc, sc->QQUOTE,
4027
cons(sc,sc->value,sc->NIL)),
4031
s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL)));
4034
s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL)));
4037
/*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
4038
s_goto(sc,OP_EVAL); Cannot be quoted*/
4039
/*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
4040
s_return(sc,x); Cannot be part of pairs*/
4041
/*sc->code=mk_proc(sc,OP_VECTOR);
4043
s_goto(sc,OP_APPLY);*/
4045
s_goto(sc,OP_VECTOR);
4047
/* ========== printing part ========== */
4049
if(is_vector(sc->args)) {
4051
sc->args=cons(sc,sc->args,mk_integer(sc,0));
4052
s_goto(sc,OP_PVECFROM);
4053
} else if(is_environment(sc->args)) {
4054
putstr(sc,"#<ENVIRONMENT>");
4056
} else if (!is_pair(sc->args)) {
4057
printatom(sc, sc->args, sc->print_flag);
4059
} else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) {
4061
sc->args = cadr(sc->args);
4062
s_goto(sc,OP_P0LIST);
4063
} else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) {
4065
sc->args = cadr(sc->args);
4066
s_goto(sc,OP_P0LIST);
4067
} else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) {
4069
sc->args = cadr(sc->args);
4070
s_goto(sc,OP_P0LIST);
4071
} else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) {
4073
sc->args = cadr(sc->args);
4074
s_goto(sc,OP_P0LIST);
4077
s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
4078
sc->args = car(sc->args);
4079
s_goto(sc,OP_P0LIST);
4083
if (is_pair(sc->args)) {
4084
s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
4086
sc->args = car(sc->args);
4087
s_goto(sc,OP_P0LIST);
4088
} else if(is_vector(sc->args)) {
4089
s_save(sc,OP_P1LIST,sc->NIL,sc->NIL);
4091
s_goto(sc,OP_P0LIST);
4093
if (sc->args != sc->NIL) {
4095
printatom(sc, sc->args, sc->print_flag);
4101
int i=ivalue_unchecked(cdr(sc->args));
4102
pointer vec=car(sc->args);
4103
int len=ivalue_unchecked(vec);
4108
pointer elem=vector_elem(vec,i);
4109
ivalue_unchecked(cdr(sc->args))=i+1;
4110
s_save(sc,OP_PVECFROM, sc->args, sc->NIL);
4113
s_goto(sc,OP_P0LIST);
4118
sprintf(sc->strbuff, "%d: illegal operator", sc->op);
4119
Error_0(sc,sc->strbuff);
4125
static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
4130
case OP_LIST_LENGTH: /* length */ /* a.k */
4131
v=list_length(sc,car(sc->args));
4133
Error_1(sc,"length: not a list:",car(sc->args));
4135
s_return(sc,mk_integer(sc, v));
4137
case OP_ASSQ: /* assq */ /* a.k */
4139
for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
4140
if (!is_pair(car(y))) {
4141
Error_0(sc,"unable to handle non pair element");
4147
s_return(sc,car(y));
4153
case OP_GET_CLOSURE: /* get-closure-code */ /* a.k */
4154
sc->args = car(sc->args);
4155
if (sc->args == sc->NIL) {
4157
} else if (is_closure(sc->args)) {
4158
s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
4159
} else if (is_macro(sc->args)) {
4160
s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
4164
case OP_CLOSUREP: /* closure? */
4166
* Note, macro object is also a closure.
4167
* Therefore, (closure? <#MACRO>) ==> #t
4169
s_retbool(is_closure(car(sc->args)));
4170
case OP_MACROP: /* macro? */
4171
s_retbool(is_macro(car(sc->args)));
4173
sprintf(sc->strbuff, "%d: illegal operator", sc->op);
4174
Error_0(sc,sc->strbuff);
4176
return sc->T; /* NOTREACHED */
4179
typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes);
4181
typedef int (*test_predicate)(pointer);
4182
static int is_any(pointer p) { return 1;}
4183
static int is_num_integer(pointer p) {
4184
return is_number(p) && ((p)->_object._number.is_fixnum);
4186
static int is_nonneg(pointer p) {
4187
return is_num_integer(p) && ivalue(p)>=0;
4190
/* Correspond carefully with following defines! */
4197
{is_string, "string"},
4198
{is_symbol, "symbol"},
4202
{is_environment, "environment"},
4205
{is_character, "character"},
4206
{is_vector, "vector"},
4207
{is_number, "number"},
4208
{is_num_integer, "integer"},
4209
{is_nonneg, "non-negative integer"},
4213
#define TST_ANY "\001"
4214
#define TST_STRING "\002"
4215
#define TST_SYMBOL "\003"
4216
#define TST_PORT "\004"
4217
#define TST_INPORT "\005"
4218
#define TST_OUTPORT "\006"
4219
#define TST_ENVIRONMENT "\007"
4220
#define TST_PAIR "\010"
4221
#define TST_LIST "\011"
4222
#define TST_CHAR "\012"
4223
#define TST_VECTOR "\013"
4224
#define TST_NUMBER "\014"
4225
#define TST_INTEGER "\015"
4226
#define TST_NATURAL "\016"
4233
char *arg_tests_encoding;
4236
#define INF_ARG 0xffff
4238
static op_code_info dispatch_table[]= {
4239
#define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E},
4240
#include "opdefines.h"
4244
static const char *procname(pointer x) {
4246
const char *name=dispatch_table[n].name;
4253
/* kernel of this interpreter */
4254
static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
4260
op_code_info *pcd=dispatch_table+sc->op;
4261
if (pcd->name!=0) { /* if built-in function, check arguments */
4264
int n=list_length(sc,sc->args);
4266
/* Check number of arguments */
4267
if(n<pcd->min_arity) {
4269
sprintf(msg,"%s: needs%s %d argument(s)",
4271
pcd->min_arity==pcd->max_arity?"":" at least",
4274
if(ok && n>pcd->max_arity) {
4276
sprintf(msg,"%s: needs%s %d argument(s)",
4278
pcd->min_arity==pcd->max_arity?"":" at most",
4282
if(pcd->arg_tests_encoding!=0) {
4285
const char *t=pcd->arg_tests_encoding;
4286
pointer arglist=sc->args;
4288
pointer arg=car(arglist);
4290
if(j==TST_INPORT[0]) {
4291
if(!is_inport(arg)) break;
4292
} else if(j==TST_OUTPORT[0]) {
4293
if(!is_outport(arg)) break;
4294
} else if(j==TST_LIST[0]) {
4295
if(arg!=sc->NIL && !is_pair(arg)) break;
4297
if(!tests[j].fct(arg)) break;
4300
if(t[1]!=0) {/* last test is replicated as necessary */
4303
arglist=cdr(arglist);
4308
sprintf(msg,"%s: argument %d must be: %s",
4316
if(_Error_1(sc,msg,0)==sc->NIL) {
4319
pcd=dispatch_table+sc->op;
4323
if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) {
4327
fprintf(stderr,"No memory!\n");
4334
/* ========== Initialization of internal keywords ========== */
4336
static void assign_syntax(scheme *sc, char *name) {
4339
x = oblist_add_by_name(sc, name);
4340
typeflag(x) |= T_SYNTAX;
4343
static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) {
4346
x = mk_symbol(sc, name);
4348
new_slot_in_env(sc, x, y);
4351
static pointer mk_proc(scheme *sc, enum scheme_opcodes op) {
4354
y = get_cell(sc, sc->NIL, sc->NIL);
4355
typeflag(y) = (T_PROC | T_ATOM);
4356
ivalue_unchecked(y) = (long) op;
4361
/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
4362
static int syntaxnum(pointer p) {
4363
const char *s=strvalue(car(p));
4364
switch(strlength(car(p))) {
4366
if(s[0]=='i') return OP_IF0; /* if */
4367
else return OP_OR0; /* or */
4369
if(s[0]=='a') return OP_AND0; /* and */
4370
else return OP_LET0; /* let */
4373
case 'e': return OP_CASE0; /* case */
4374
case 'd': return OP_COND0; /* cond */
4375
case '*': return OP_LET0AST; /* let* */
4376
default: return OP_SET0; /* set! */
4380
case 'g': return OP_BEGIN; /* begin */
4381
case 'l': return OP_DELAY; /* delay */
4382
case 'c': return OP_MACRO0; /* macro */
4383
default: return OP_QUOTE; /* quote */
4387
case 'm': return OP_LAMBDA; /* lambda */
4388
case 'f': return OP_DEF0; /* define */
4389
default: return OP_LET0REC; /* letrec */
4392
return OP_C0STREAM; /* cons-stream */
4396
/* initialization of TinyScheme */
4398
INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) {
4399
return cons(sc,a,b);
4401
INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) {
4402
return immutable_cons(sc,a,b);
4405
static struct scheme_interface vtbl ={
4473
scheme *scheme_init_new(void) {
4474
scheme *sc=(scheme*)malloc(sizeof(scheme));
4475
if(!scheme_init(sc)) {
4483
scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) {
4484
scheme *sc=(scheme*)malloc(sizeof(scheme));
4485
if(!scheme_init_custom_alloc(sc,malloc,free)) {
4494
int scheme_init(scheme *sc) {
4495
return scheme_init_custom_alloc(sc,malloc,free);
4498
int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
4499
int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]);
4502
num_zero.is_fixnum=1;
4503
num_zero.value.ivalue=0;
4504
num_one.is_fixnum=1;
4505
num_one.value.ivalue=1;
4513
sc->last_cell_seg = -1;
4514
sc->sink = &sc->_sink;
4515
sc->NIL = &sc->_NIL;
4516
sc->T = &sc->_HASHT;
4517
sc->F = &sc->_HASHF;
4518
sc->EOF_OBJ=&sc->_EOF_OBJ;
4519
sc->free_cell = &sc->_NIL;
4523
sc->outport=sc->NIL;
4524
sc->save_inport=sc->NIL;
4525
sc->loadport=sc->NIL;
4527
sc->interactive_repl=0;
4531
if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) {
4536
dump_stack_initialize(sc);
4540
sc->safe_foreign = sc->NIL;
4543
typeflag(sc->NIL) = (T_ATOM | MARK);
4544
car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
4546
typeflag(sc->T) = (T_ATOM | MARK);
4547
car(sc->T) = cdr(sc->T) = sc->T;
4549
typeflag(sc->F) = (T_ATOM | MARK);
4550
car(sc->F) = cdr(sc->F) = sc->F;
4551
sc->oblist = oblist_initial_value(sc);
4552
/* init global_env */
4553
new_frame_in_env(sc, sc->NIL);
4554
sc->global_env = sc->envir;
4556
x = mk_symbol(sc,"else");
4557
new_slot_in_env(sc, x, sc->T);
4559
assign_syntax(sc, "lambda");
4560
assign_syntax(sc, "quote");
4561
assign_syntax(sc, "define");
4562
assign_syntax(sc, "if");
4563
assign_syntax(sc, "begin");
4564
assign_syntax(sc, "set!");
4565
assign_syntax(sc, "let");
4566
assign_syntax(sc, "let*");
4567
assign_syntax(sc, "letrec");
4568
assign_syntax(sc, "cond");
4569
assign_syntax(sc, "delay");
4570
assign_syntax(sc, "and");
4571
assign_syntax(sc, "or");
4572
assign_syntax(sc, "cons-stream");
4573
assign_syntax(sc, "macro");
4574
assign_syntax(sc, "case");
4576
for(i=0; i<n; i++) {
4577
if(dispatch_table[i].name!=0) {
4578
assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name);
4582
/* initialization of global pointers to special symbols */
4583
sc->LAMBDA = mk_symbol(sc, "lambda");
4584
sc->QUOTE = mk_symbol(sc, "quote");
4585
sc->QQUOTE = mk_symbol(sc, "quasiquote");
4586
sc->UNQUOTE = mk_symbol(sc, "unquote");
4587
sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing");
4588
sc->FEED_TO = mk_symbol(sc, "=>");
4589
sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
4590
sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
4591
sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
4593
return !sc->no_memory;
4596
SCHEME_EXPORT void scheme_set_input_port_file(scheme *sc, FILE *fin) {
4597
sc->inport=port_from_file(sc,fin,port_input);
4600
void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) {
4601
sc->inport=port_from_string(sc,start,past_the_end,port_input);
4604
SCHEME_EXPORT void scheme_set_output_port_file(scheme *sc, FILE *fout) {
4605
sc->outport=port_from_file(sc,fout,port_output);
4608
void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) {
4609
sc->outport=port_from_string(sc,start,past_the_end,port_output);
4612
void scheme_set_external_data(scheme *sc, void *p) {
4616
void scheme_deinit(scheme *sc) {
4620
sc->global_env=sc->NIL;
4621
dump_stack_free(sc);
4626
if(is_port(sc->inport)) {
4627
typeflag(sc->inport) = T_ATOM;
4630
sc->outport=sc->NIL;
4631
if(is_port(sc->save_inport)) {
4632
typeflag(sc->save_inport) = T_ATOM;
4634
sc->save_inport=sc->NIL;
4635
if(is_port(sc->loadport)) {
4636
typeflag(sc->loadport) = T_ATOM;
4638
sc->loadport=sc->NIL;
4640
gc(sc,sc->NIL,sc->NIL);
4642
for(i=0; i<=sc->last_cell_seg; i++) {
4643
sc->free(sc->alloc_seg[i]);
4647
void scheme_load_file(scheme *sc, FILE *fin) {
4648
dump_stack_reset(sc);
4649
sc->envir = sc->global_env;
4651
sc->load_stack[0].kind=port_input|port_file;
4652
sc->load_stack[0].rep.stdio.file=fin;
4653
sc->loadport=mk_port(sc,sc->load_stack);
4656
sc->interactive_repl=1;
4658
sc->inport=sc->loadport;
4659
Eval_Cycle(sc, OP_T0LVL);
4660
typeflag(sc->loadport)=T_ATOM;
4661
if(sc->retcode==0) {
4662
sc->retcode=sc->nesting!=0;
4666
void scheme_load_string(scheme *sc, const char *cmd) {
4667
dump_stack_reset(sc);
4668
sc->envir = sc->global_env;
4670
sc->load_stack[0].kind=port_input|port_string;
4671
sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */
4672
sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd);
4673
sc->load_stack[0].rep.string.curr=(char*)cmd;
4674
sc->loadport=mk_port(sc,sc->load_stack);
4676
sc->interactive_repl=0;
4677
sc->inport=sc->loadport;
4678
Eval_Cycle(sc, OP_T0LVL);
4679
typeflag(sc->loadport)=T_ATOM;
4680
if(sc->retcode==0) {
4681
sc->retcode=sc->nesting!=0;
4685
void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
4688
x=find_slot_in_env(sc,envir,symbol,0);
4690
set_slot_in_env(sc, x, value);
4692
new_slot_spec_in_env(sc, envir, symbol, value);
4697
void scheme_apply0(scheme *sc, const char *procname) {
4698
pointer carx=mk_symbol(sc,procname);
4699
pointer cdrx=sc->NIL;
4701
dump_stack_reset(sc);
4702
sc->envir = sc->global_env;
4703
sc->code = cons(sc,carx,cdrx);
4704
sc->interactive_repl=0;
4706
Eval_Cycle(sc,OP_EVAL);
4709
void scheme_call(scheme *sc, pointer func, pointer args) {
4710
dump_stack_reset(sc);
4711
sc->envir = sc->global_env;
4714
sc->interactive_repl =0;
4716
Eval_Cycle(sc, OP_APPLY);
4720
/* ========== Main ========== */
4724
#if defined(__APPLE__) && !defined (OSX)
4725
int main(int argc, char **argv)
4727
extern MacTS_main(int argc, char **argv);
4729
int argc = ccommand(&argv);
4730
MacTS_main(argc,argv);
4733
int MacTS_main(int argc, char **argv) {
4735
int main(int argc, char **argv) {
4739
char *file_name=InitFile;
4746
if(argc==2 && strcmp(argv[1],"-?")==0) {
4747
printf("Usage: %s [-? | <file1> <file2> ... | -1 <file> <arg1> <arg2> ...]\n\tUse - as filename for stdin.\n",argv[0]);
4750
if(!scheme_init(&sc)) {
4751
fprintf(stderr,"Could not initialize!\n");
4754
scheme_set_input_port_file(&sc, stdin);
4755
scheme_set_output_port_file(&sc, stdout);
4757
scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext));
4760
if(access(file_name,0)!=0) {
4761
char *p=getenv("TINYSCHEMEINIT");
4767
if(strcmp(file_name,"-")==0) {
4769
} else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) {
4770
pointer args=sc.NIL;
4771
isfile=file_name[1]=='1';
4773
if(strcmp(file_name,"-")==0) {
4776
fin=fopen(file_name,"r");
4778
for(;*argv;argv++) {
4779
pointer value=mk_string(&sc,*argv);
4780
args=cons(&sc,value,args);
4782
args=reverse_in_place(&sc,sc.NIL,args);
4783
scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args);
4786
fin=fopen(file_name,"r");
4788
if(isfile && fin==0) {
4789
fprintf(stderr,"Could not open file %s\n",file_name);
4792
scheme_load_file(&sc,fin);
4794
scheme_load_string(&sc,file_name);
4796
if(!isfile || fin!=stdin) {
4798
fprintf(stderr,"Errors encountered reading %s\n",file_name);
4806
} while(file_name!=0);
4808
scheme_load_file(&sc,stdin);
added
removed
plug-ins/script-fu/tinyscheme/scheme.c
