Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 14:49:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

initial plan9 work

Browse source
This commit is contained in:
Alex Shinn 2009-06-27 20:28:04 +09:00
parent 86ce8fbc15
commit d4f97c40d5
8 changed files with 431 additions and 241 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

61
eval.c
View file

@ -14,7 +14,7 @@ static sexp the_err_handler_symbol, the_compile_error_symbol;
static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol; static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol;
#define sexp_current_error_port(ctx) env_global_ref(sexp_context_env(ctx),the_cur_out_symbol,SEXP_FALSE) #define sexp_current_error_port(ctx) env_global_ref(sexp_context_env(ctx),the_cur_out_symbol,SEXP_FALSE)
#define sexp_debug(ctx, msg, obj) (sexp_write_string(msg, sexp_current_error_port(ctx)), sexp_write(obj, sexp_current_error_port(ctx)), sexp_write_char('\n', sexp_current_error_port(ctx))) #define sexp_debug(ctx, msg, obj) (sexp_write_string(ctx, msg, sexp_current_error_port(ctx)), sexp_write(ctx, obj, sexp_current_error_port(ctx)), sexp_write_char(ctx, '\n', sexp_current_error_port(ctx)))
#if USE_DEBUG #if USE_DEBUG
#include "debug.c" #include "debug.c"
@ -1298,7 +1298,10 @@ sexp sexp_vm (sexp ctx, sexp proc) {
tmp1 = _ARG1; tmp1 = _ARG1;
i = 1; i = 1;
sexp_context_top(ctx) = top; sexp_context_top(ctx) = top;
tmp2 = sexp_vector(ctx, 1, sexp_save_stack(ctx, stack, top+4)); tmp2 = sexp_make_vector(ctx, sexp_make_integer(1), SEXP_UNDEF);
sexp_vector_set(tmp2,
sexp_make_integer(0),
sexp_save_stack(ctx, stack, top+4));
_ARG1 = sexp_make_procedure(ctx, sexp_make_integer(0), _ARG1 = sexp_make_procedure(ctx, sexp_make_integer(0),
sexp_make_integer(1), continuation_resumer, sexp_make_integer(1), continuation_resumer,
tmp2); tmp2);
@ -1334,10 +1337,8 @@ sexp sexp_vm (sexp ctx, sexp proc) {
goto make_call; goto make_call;
case OP_CALL: case OP_CALL:
#if USE_CHECK_STACK #if USE_CHECK_STACK
if (top+16 >= INIT_STACK_SIZE) { if (top+16 >= INIT_STACK_SIZE)
fprintf(stderr, "out of stack space\n"); errx(70, "out of stack space\n");
exit(70);
}
#endif #endif
i = sexp_unbox_integer(_WORD0); i = sexp_unbox_integer(_WORD0);
tmp1 = _ARG1; tmp1 = _ARG1;
@ -1752,19 +1753,19 @@ sexp sexp_vm (sexp ctx, sexp proc) {
break; break;
case OP_DISPLAY: case OP_DISPLAY:
if (sexp_stringp(_ARG1)) { if (sexp_stringp(_ARG1)) {
sexp_write_string(sexp_string_data(_ARG1), _ARG2); sexp_write_string(ctx, sexp_string_data(_ARG1), _ARG2);
_ARG2 = SEXP_VOID; _ARG2 = SEXP_VOID;
top--; top--;
break; break;
} else if (sexp_charp(_ARG1)) { } else if (sexp_charp(_ARG1)) {
sexp_write_char(sexp_unbox_character(_ARG1), _ARG2); sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2);
_ARG2 = SEXP_VOID; _ARG2 = SEXP_VOID;
top--; top--;
break; break;
} }
/* ... FALLTHROUGH ... */ /* ... FALLTHROUGH ... */
case OP_WRITE: case OP_WRITE:
sexp_write(_ARG1, _ARG2); sexp_write(ctx, _ARG1, _ARG2);
_ARG2 = SEXP_VOID; _ARG2 = SEXP_VOID;
top--; top--;
break; break;
@ -1774,7 +1775,7 @@ sexp sexp_vm (sexp ctx, sexp proc) {
top--; top--;
break; break;
case OP_NEWLINE: case OP_NEWLINE:
sexp_write_char('\n', _ARG1); sexp_write_char(ctx, '\n', _ARG1);
_ARG1 = SEXP_VOID; _ARG1 = SEXP_VOID;
break; break;
case OP_FLUSH_OUTPUT: case OP_FLUSH_OUTPUT:
@ -1787,12 +1788,12 @@ sexp sexp_vm (sexp ctx, sexp proc) {
sexp_check_exception(); sexp_check_exception();
break; break;
case OP_READ_CHAR: case OP_READ_CHAR:
i = sexp_read_char(_ARG1); i = sexp_read_char(ctx, _ARG1);
_ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i);
break; break;
case OP_PEEK_CHAR: case OP_PEEK_CHAR:
i = sexp_read_char(_ARG1); i = sexp_read_char(ctx, _ARG1);
sexp_push_char(i, _ARG1); sexp_push_char(ctx, i, _ARG1);
_ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i);
break; break;
case OP_RET: case OP_RET:
@ -1850,9 +1851,14 @@ static sexp sexp_open_output_file (sexp ctx, sexp path) {
} }
static sexp sexp_close_port (sexp ctx, sexp port) { static sexp sexp_close_port (sexp ctx, sexp port) {
fclose(sexp_port_stream(port)); if (! sexp_portp(port))
return sexp_type_exception(ctx, "not a port", port);
if (! sexp_port_openp(port))
return sexp_user_exception(ctx, SEXP_FALSE, "port already closed", port);
if (sexp_port_buf(port)) if (sexp_port_buf(port))
free(sexp_port_buf(port)); free(sexp_port_buf(port));
if (sexp_port_stream(port))
fclose(sexp_port_stream(port));
return SEXP_VOID; return SEXP_VOID;
} }
@ -1860,9 +1866,9 @@ void sexp_warn_undefs (sexp from, sexp to, sexp out) {
sexp x; sexp x;
for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x)) for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x))
if (sexp_cdar(x) == SEXP_UNDEF) { if (sexp_cdar(x) == SEXP_UNDEF) {
sexp_write_string("WARNING: reference to undefined variable: ", out); sexp_write_string(ctx, "WARNING: reference to undefined variable: ", out);
sexp_write(sexp_caar(x), out); sexp_write(ctx, sexp_caar(x), out);
sexp_write_char('\n', out); sexp_write_char(ctx, '\n', out);
} }
} }
@ -1960,25 +1966,6 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) {
return sexp_make_integer((sexp_sint_t)round(res)); return sexp_make_integer((sexp_sint_t)round(res));
} }
static sexp sexp_string_concatenate (sexp ctx, sexp str_ls) {
sexp res, ls;
sexp_uint_t len=0;
char *p;
for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls))
if (! sexp_stringp(sexp_car(ls)))
return sexp_type_exception(ctx, "not a string", sexp_car(ls));
else
len += sexp_string_length(sexp_car(ls));
res = sexp_make_string(ctx, sexp_make_integer(len), SEXP_VOID);
p = sexp_string_data(res);
for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) {
len = sexp_string_length(sexp_car(ls));
memcpy(p, sexp_string_data(sexp_car(ls)), len);
p += len;
}
return res;
}
static sexp sexp_string_cmp (sexp ctx, sexp str1, sexp str2, sexp ci) { static sexp sexp_string_cmp (sexp ctx, sexp str1, sexp str2, sexp ci) {
sexp_sint_t len1, len2, len, diff; sexp_sint_t len1, len2, len, diff;
if (! sexp_stringp(str1)) if (! sexp_stringp(str1))
@ -2153,6 +2140,7 @@ sexp sexp_eval (sexp ctx, sexp obj) {
return res; return res;
} }
#if USE_STRING_STREAMS
sexp sexp_eval_string (sexp ctx, char *str) { sexp sexp_eval_string (sexp ctx, char *str) {
sexp res; sexp res;
sexp_gc_var(ctx, obj, s_obj); sexp_gc_var(ctx, obj, s_obj);
@ -2162,6 +2150,7 @@ sexp sexp_eval_string (sexp ctx, char *str) {
sexp_gc_release(ctx, obj, s_obj); sexp_gc_release(ctx, obj, s_obj);
return res; return res;
} }
#endif
void sexp_scheme_init () { void sexp_scheme_init () {
sexp ctx; sexp ctx;

14
gc.c
View file

@ -157,10 +157,8 @@ sexp sexp_gc (sexp ctx, size_t *sum_freed) {
sexp_heap sexp_make_heap (size_t size) { sexp_heap sexp_make_heap (size_t size) {
sexp free, next; sexp free, next;
sexp_heap h = (sexp_heap) malloc(sizeof(struct sexp_heap) + size); sexp_heap h = (sexp_heap) malloc(sizeof(struct sexp_heap) + size);
if (! h) { if (! h)
fprintf(stderr, "out of memory allocating %zu byte heap, aborting\n", size); errx(70, "out of memory allocating %zu byte heap, aborting\n", size);
exit(70);
}
h->size = size; h->size = size;
h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data)); h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data));
free = h->free_list = (sexp) h->data; free = h->free_list = (sexp) h->data;
@ -201,7 +199,7 @@ void* sexp_try_alloc (sexp ctx, size_t size) {
} else { /* take the whole chunk */ } else { /* take the whole chunk */
sexp_cdr(ls1) = sexp_cdr(ls2); sexp_cdr(ls1) = sexp_cdr(ls2);
} }
bzero((void*)ls2, size); memset((void*)ls2, 0, size);
return ls2; return ls2;
} }
ls1 = ls2; ls1 = ls2;
@ -225,10 +223,8 @@ void* sexp_alloc (sexp ctx, size_t size) {
&& ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE))) && ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE)))
sexp_grow_heap(ctx, size); sexp_grow_heap(ctx, size);
res = sexp_try_alloc(ctx, size); res = sexp_try_alloc(ctx, size);
if (! res) { if (! res)
fprintf(stderr, "out of memory allocating %zu bytes, aborting\n", size); errx(80, "out of memory allocating %zu bytes, aborting\n", size);
exit(70);
}
} }
return res; return res;
} }

28
include/chibi/config.h
View file

@ -42,13 +42,6 @@
/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ /* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */
/************************************************************************/ /************************************************************************/
#if HAVE_ERR_H
#include <err.h>
#else
/* requires msg be a string literal, and at least one argument */
#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code))
#endif
#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) #if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__)
#define SEXP_BSD 1 #define SEXP_BSD 1
#else #else
@ -104,3 +97,24 @@
#define USE_CHECK_STACK 0 #define USE_CHECK_STACK 0
#endif #endif
#ifdef PLAN9
#define errx(code, msg, ...) exits(msg)
#define exit_normally() exits(NULL)
#define strcasecmp cistrcmp
#define strncasecmp cistrncmp
/* XXXX these are wrong */
#define trunc floor
#define round(x) floor(x+0.5)
#else
#define exit_normally() exit(0)
#if HAVE_ERR_H
#include <err.h>
#else
/* requires msg be a string literal, and at least one argument */
#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code))
#endif
#endif

2
include/chibi/eval.h
View file

@ -5,7 +5,7 @@
#ifndef SEXP_EVAL_H #ifndef SEXP_EVAL_H
#define SEXP_EVAL_H #define SEXP_EVAL_H
#include "sexp.h" #include "chibi/sexp.h"
/************************* additional types ***************************/ /************************* additional types ***************************/

51
include/chibi/sexp.h
View file

@ -5,17 +5,22 @@
#ifndef SEXP_H #ifndef SEXP_H
#define SEXP_H #define SEXP_H
#include "config.h" #include "chibi/config.h"
#include "install.h" #include "chibi/install.h"
#include <ctype.h> #include <ctype.h>
#include <stdio.h> #include <stdio.h>
#ifdef PLAN9
typedef unsigned long size_t;
#define offsetof(st, m) ((size_t) ((char*)&((st*)(0))->m - (char*)0))
#else
#include <stddef.h> #include <stddef.h>
#include <stdlib.h> #include <stdlib.h>
#include <string.h> #include <string.h>
#include <stdarg.h> #include <stdarg.h>
#include <sys/types.h> #include <sys/types.h>
#include <math.h> #include <math.h>
#endif
/* tagging system /* tagging system
* bits end in 00: pointer * bits end in 00: pointer
@ -123,7 +128,7 @@ struct sexp_struct {
struct { struct {
FILE *stream; FILE *stream;
char *buf; char *buf;
sexp_uint_t line; sexp_uint_t offset, line, openp;
size_t size; size_t size;
sexp name; sexp name;
sexp cookie; sexp cookie;
@ -366,9 +371,11 @@ sexp sexp_make_flonum(sexp ctx, double f);
#define sexp_port_stream(p) ((p)->value.port.stream) #define sexp_port_stream(p) ((p)->value.port.stream)
#define sexp_port_name(p) ((p)->value.port.name) #define sexp_port_name(p) ((p)->value.port.name)
#define sexp_port_line(p) ((p)->value.port.line) #define sexp_port_line(p) ((p)->value.port.line)
#define sexp_port_openp(p) ((p)->value.port.openp)
#define sexp_port_cookie(p) ((p)->value.port.cookie) #define sexp_port_cookie(p) ((p)->value.port.cookie)
#define sexp_port_buf(p) ((p)->value.port.buf) #define sexp_port_buf(p) ((p)->value.port.buf)
#define sexp_port_size(p) ((p)->value.port.size) #define sexp_port_size(p) ((p)->value.port.size)
#define sexp_port_offset(p) ((p)->value.port.offset)
#define sexp_exception_kind(p) ((p)->value.exception.kind) #define sexp_exception_kind(p) ((p)->value.exception.kind)
#define sexp_exception_message(p) ((p)->value.exception.message) #define sexp_exception_message(p) ((p)->value.exception.message)
@ -509,13 +516,32 @@ sexp sexp_make_flonum(sexp ctx, double f);
/***************************** general API ****************************/ /***************************** general API ****************************/
#define sexp_read_char(p) (getc(sexp_port_stream(p))) #if USE_STRING_STREAMS
#define sexp_push_char(c, p) (ungetc(c, sexp_port_stream(p)))
#define sexp_write_char(c, p) (putc(c, sexp_port_stream(p))) #define sexp_read_char(x, p) (getc(sexp_port_stream(p)))
#define sexp_write_string(s, p) (fputs(s, sexp_port_stream(p))) #define sexp_push_char(x, c, p) (ungetc(c, sexp_port_stream(p)))
#define sexp_printf(p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__)) #define sexp_write_char(x, c, p) (putc(c, sexp_port_stream(p)))
#define sexp_scanf(p, ...) (fscanf(sexp_port_stream(p), __VA_ARGS__)) #define sexp_write_string(x, s, p) (fputs(s, sexp_port_stream(p)))
#define sexp_flush(p) (fflush(sexp_port_stream(p))) #define sexp_printf(x, p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__))
#define sexp_flush(x, p) (fflush(sexp_port_stream(p)))
#else
#define sexp_read_char(x, p) ((sexp_port_offset(p) < sexp_port_size(p)) ? sexp_port_buf(p)[sexp_port_offset(p)++] : sexp_buffered_read_char(x, p))
#define sexp_push_char(x, c, p) (sexp_port_buf(p)[--sexp_port_offset(p)] = ((char)(c)))
#define sexp_write_char(x, c, p) ((sexp_port_offset(p) < sexp_port_size(p)) ? (((sexp_port_buf(p))[sexp_port_offset(p)++]) = ((char)(c))) : sexp_buffered_write_char(x, c, p))
#define sexp_write_string(x, s, p) sexp_buffered_write_string(x, s, p)
#define sexp_flush(x, p) sexp_buffered_flush(x, p)
int sexp_buffered_read_char (sexp ctx, sexp p);
sexp sexp_buffered_write_char (sexp ctx, int c, sexp p);
sexp sexp_buffered_write_string_n (sexp ctx, char *str, int len, sexp p);
sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p);
sexp sexp_buffered_flush (sexp ctx, sexp p);
#endif
#define sexp_newline(p) sexp_write_char('\n', (p))
sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag);
sexp sexp_cons(sexp ctx, sexp head, sexp tail); sexp sexp_cons(sexp ctx, sexp head, sexp tail);
@ -531,12 +557,13 @@ sexp sexp_length(sexp ctx, sexp ls);
sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen); sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen);
sexp sexp_make_string(sexp ctx, sexp len, sexp ch); sexp sexp_make_string(sexp ctx, sexp len, sexp ch);
sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end);
sexp sexp_string_concatenate (sexp ctx, sexp str_ls);
sexp sexp_intern(sexp ctx, char *str); sexp sexp_intern(sexp ctx, char *str);
sexp sexp_string_to_symbol(sexp ctx, sexp str); sexp sexp_string_to_symbol(sexp ctx, sexp str);
sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt);
sexp sexp_list_to_vector(sexp ctx, sexp ls); sexp sexp_list_to_vector(sexp ctx, sexp ls);
sexp sexp_vector(sexp ctx, int count, ...); /* sexp sexp_vector(sexp ctx, int count, ...); */
void sexp_write(sexp obj, sexp out); void sexp_write(sexp ctx, sexp obj, sexp out);
sexp sexp_read_string(sexp ctx, sexp in); sexp sexp_read_string(sexp ctx, sexp in);
sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp); sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp);
sexp sexp_read_number(sexp ctx, sexp in, int base); sexp sexp_read_number(sexp ctx, sexp in, int base);

18
main.c
View file

@ -2,7 +2,9 @@
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */ /* BSD-style license: http://synthcode.com/license.txt */
#ifndef PLAN9
#include <sys/stat.h> #include <sys/stat.h>
#endif
#include "chibi/eval.h" #include "chibi/eval.h"
char *chibi_module_dir = NULL; char *chibi_module_dir = NULL;
@ -11,13 +13,18 @@ sexp find_module_file (sexp ctx, char *file) {
sexp res; sexp res;
int mlen, flen; int mlen, flen;
char *path; char *path;
#ifndef PLAN9
struct stat buf; struct stat buf;
if (! stat(file, &buf)) if (! stat(file, &buf))
#endif
return sexp_c_string(ctx, file, -1); return sexp_c_string(ctx, file, -1);
#ifndef PLAN9
if (! chibi_module_dir) { if (! chibi_module_dir) {
#ifndef PLAN9
chibi_module_dir = getenv("CHIBI_MODULE_DIR"); chibi_module_dir = getenv("CHIBI_MODULE_DIR");
if (! chibi_module_dir) if (! chibi_module_dir)
#endif
chibi_module_dir = sexp_module_dir; chibi_module_dir = sexp_module_dir;
} }
mlen = strlen(chibi_module_dir); mlen = strlen(chibi_module_dir);
@ -33,6 +40,7 @@ sexp find_module_file (sexp ctx, char *file) {
res = SEXP_FALSE; res = SEXP_FALSE;
free(path); free(path);
return res; return res;
#endif
} }
void repl (sexp ctx) { void repl (sexp ctx) {
@ -45,7 +53,7 @@ void repl (sexp ctx) {
out = sexp_eval_string(ctx, "(current-output-port)"); out = sexp_eval_string(ctx, "(current-output-port)");
err = sexp_eval_string(ctx, "(current-error-port)"); err = sexp_eval_string(ctx, "(current-error-port)");
while (1) { while (1) {
sexp_write_string("> ", out); sexp_write_string(ctx, "> ", out);
sexp_flush(out); sexp_flush(out);
obj = sexp_read(ctx, in); obj = sexp_read(ctx, in);
if (obj == SEXP_EOF) if (obj == SEXP_EOF)
@ -60,8 +68,8 @@ void repl (sexp ctx) {
sexp_warn_undefs(sexp_env_bindings(env), tmp, err); sexp_warn_undefs(sexp_env_bindings(env), tmp, err);
#endif #endif
if (res != SEXP_VOID) { if (res != SEXP_VOID) {
sexp_write(res, out); sexp_write(ctx, res, out);
sexp_write_char('\n', out); sexp_write_char(ctx, '\n', out);
} }
} }
} }
@ -92,8 +100,8 @@ void run_main (int argc, char **argv) {
if (sexp_exceptionp(res)) { if (sexp_exceptionp(res)) {
sexp_print_exception(ctx, res, out); sexp_print_exception(ctx, res, out);
} else if (argv[i][1] == 'p') { } else if (argv[i][1] == 'p') {
sexp_write(res, out); sexp_write(ctx, res, out);
sexp_write_char('\n', out); sexp_write_char(ctx, '\n', out);
} }
quit=1; quit=1;
i++; i++;

37
mkfile Normal file
View file

@ -0,0 +1,37 @@
</$objtype/mkfile
BIN=/$objtype/bin
TARG=chibi-scheme
MODDIR=/sys/lib/chibi-scheme
#CC=pcc
CPPFLAGS= -Iinclude -DPLAN9 -DUSE_STRING_STREAMS=0
CFLAGS= -c -B $CPPFLAGS
OFILES=sexp.$O eval.$O main.$O
HFILES=include/chibi/sexp.h include/chibi/eval.h include/chibi/config.h
include/chibi/install.h: mkfile
echo '#define sexp_module_dir "'$MODDIR'"' > include/chibi/install.h
%.i: %.c include/chibi/install.h $HFILES
cpp $CPPFLAGS $stem.c > $target
sexp.$O: sexp.i
$CC $CFLAGS -c -o $target sexp.i
eval.$O: eval.i
$CC $CFLAGS -c -o $target eval.i
main.$O: main.i
$CC $CFLAGS -c -o $target main.i
chibi-scheme: sexp.$O eval.$O main.$O
$LD -o $target -l $prereq
#</sys/src/cmd/mkone
install:
mkdir $MODDIR
cp init.scm $MODDIR

461
sexp.c
View file

@ -162,52 +162,52 @@ sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) {
sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) { sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) {
sexp ls; sexp ls;
sexp_write_string("ERROR", out); sexp_write_string(ctx, "ERROR", out);
if (sexp_exceptionp(exn)) { if (sexp_exceptionp(exn)) {
if (sexp_procedurep(sexp_exception_procedure(exn))) { if (sexp_procedurep(sexp_exception_procedure(exn))) {
ls = sexp_bytecode_name( ls = sexp_bytecode_name(
sexp_procedure_code(sexp_exception_procedure(exn))); sexp_procedure_code(sexp_exception_procedure(exn)));
if (sexp_symbolp(ls)) { if (sexp_symbolp(ls)) {
sexp_write_string(" in ", out); sexp_write_string(ctx, " in ", out);
sexp_write(ls, out); sexp_write(ctx, ls, out);
} }
} }
if (sexp_integerp(sexp_exception_line(exn)) if (sexp_integerp(sexp_exception_line(exn))
&& (sexp_exception_line(exn) > sexp_make_integer(0))) { && (sexp_exception_line(exn) > sexp_make_integer(0))) {
sexp_write_string(" on line ", out); sexp_write_string(ctx, " on line ", out);
sexp_write(sexp_exception_line(exn), out); sexp_write(ctx, sexp_exception_line(exn), out);
} }
if (sexp_stringp(sexp_exception_file(exn))) { if (sexp_stringp(sexp_exception_file(exn))) {
sexp_write_string(" of file ", out); sexp_write_string(ctx, " of file ", out);
sexp_write_string(sexp_string_data(sexp_exception_file(exn)), out); sexp_write_string(ctx, sexp_string_data(sexp_exception_file(exn)), out);
} }
sexp_write_string(": ", out); sexp_write_string(ctx, ": ", out);
sexp_write_string(sexp_string_data(sexp_exception_message(exn)), out); sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out);
if (sexp_exception_irritants(exn) if (sexp_exception_irritants(exn)
&& sexp_pairp(sexp_exception_irritants(exn))) { && sexp_pairp(sexp_exception_irritants(exn))) {
if (sexp_nullp(sexp_cdr(sexp_exception_irritants(exn)))) { if (sexp_nullp(sexp_cdr(sexp_exception_irritants(exn)))) {
sexp_write_string(": ", out); sexp_write_string(ctx, ": ", out);
sexp_write(sexp_car(sexp_exception_irritants(exn)), out); sexp_write(ctx, sexp_car(sexp_exception_irritants(exn)), out);
sexp_write_string("\n", out); sexp_write_string(ctx, "\n", out);
} else { } else {
sexp_write_string("\n", out); sexp_write_string(ctx, "\n", out);
for (ls=sexp_exception_irritants(exn); for (ls=sexp_exception_irritants(exn);
sexp_pairp(ls); ls=sexp_cdr(ls)) { sexp_pairp(ls); ls=sexp_cdr(ls)) {
sexp_write_string(" ", out); sexp_write_string(ctx, " ", out);
sexp_write(sexp_car(ls), out); sexp_write(ctx, sexp_car(ls), out);
sexp_write_char('\n', out); sexp_write_char(ctx, '\n', out);
} }
} }
} else { } else {
sexp_write_char('\n', out); sexp_write_char(ctx, '\n', out);
} }
} else { } else {
sexp_write_string(": ", out); sexp_write_string(ctx, ": ", out);
if (sexp_stringp(exn)) if (sexp_stringp(exn))
sexp_write_string(sexp_string_data(exn), out); sexp_write_string(ctx, sexp_string_data(exn), out);
else else
sexp_write(exn, out); sexp_write(ctx, exn, out);
sexp_write_char('\n', out); sexp_write_char(ctx, '\n', out);
} }
return SEXP_VOID; return SEXP_VOID;
} }
@ -434,6 +434,25 @@ sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end) {
return res; return res;
} }
sexp sexp_string_concatenate (sexp ctx, sexp str_ls) {
sexp res, ls;
sexp_uint_t len=0;
char *p;
for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls))
if (! sexp_stringp(sexp_car(ls)))
return sexp_type_exception(ctx, "not a string", sexp_car(ls));
else
len += sexp_string_length(sexp_car(ls));
res = sexp_make_string(ctx, sexp_make_integer(len), SEXP_VOID);
p = sexp_string_data(res);
for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) {
len = sexp_string_length(sexp_car(ls));
memcpy(p, sexp_string_data(sexp_car(ls)), len);
p += len;
}
return res;
}
#define FNV_PRIME 16777619 #define FNV_PRIME 16777619
#define FNV_OFFSET_BASIS 2166136261uL #define FNV_OFFSET_BASIS 2166136261uL
@ -513,19 +532,6 @@ sexp sexp_list_to_vector(sexp ctx, sexp ls) {
return vec; return vec;
} }
sexp sexp_vector(sexp ctx, int count, ...) {
sexp vec = sexp_make_vector(ctx, sexp_make_integer(count), SEXP_VOID);
sexp *elts = sexp_vector_data(vec);
va_list ap;
int i;
va_start(ap, count);
for (i=0; i<count; i++)
elts[i] = va_arg(ap, sexp);
va_end(ap);
return vec;
}
/************************ reading and writing *************************/ /************************ reading and writing *************************/
#if USE_STRING_STREAMS #if USE_STRING_STREAMS
@ -645,6 +651,99 @@ sexp sexp_get_output_string (sexp ctx, sexp port) {
#endif #endif
#else
#define SEXP_PORT_BUFFER_SIZE 4096
int sexp_buffered_read_char (sexp ctx, sexp p) {
if (sexp_port_offset(p) < sexp_port_size(p)) {
return sexp_port_buf(p)[sexp_port_offset(p)++];
} else if (! sexp_port_stream(p)) {
return EOF;
} else {
sexp_port_size(p)
= fread(sexp_port_buf(p), 1, SEXP_PORT_BUFFER_SIZE, sexp_port_stream(p));
sexp_port_offset(p) = 0;
return ((sexp_port_offset(p) < sexp_port_size(p))
? sexp_port_buf(p)[sexp_port_offset(p)++] : EOF);
}
}
sexp sexp_buffered_write_char (sexp ctx, int c, sexp p) {
if (sexp_port_offset(p) >= sexp_port_size(p))
sexp_buffered_flush(ctx, p);
sexp_port_buf(p)[sexp_port_offset(p)++] = (c);
return SEXP_VOID;
}
sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p) {
if (sexp_port_offset(p) >= sexp_port_size(p))
sexp_buffered_flush(ctx, p);
memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, len);
sexp_port_offset(p) += len;
return SEXP_VOID;
}
sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p) {
return sexp_buffered_write_string_n(str, strlen(str), p);
}
sexp sexp_buffered_flush (sexp ctx, sexp p) {
sexp_gc_var(ctx, tmp, s_tmp);
sexp_gc_preserve(ctx, tmp, s_tmp);
/* if (! sexp_oportp(p)) */
/* return sexp_type_exception(); */
/* else if (! sexp_port_openp(p)) */
/* return sexp_make_exception(); */
/* else { */
if (sexp_port_stream(p)) {
fwrite(sexp_port_buf(p), 1, sexp_port_offset(p), sexp_port_stream(p));
sexp_port_offset(p) = 0;
fflush(sexp_port_stream(p));
} else if (sexp_port_offset(p) > 0) {
tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p));
sexp_push(ctx, sexp_port_cookie(p), tmp);
sexp_port_offset(p) = 0;
}
sexp_gc_release(ctx, tmp, s_tmp);
return SEXP_VOID;
/* } */
}
sexp sexp_make_input_string_port (sexp ctx, sexp str) {
sexp res = sexp_make_input_port(ctx, NULL, SEXP_FALSE);
sexp_port_cookie(res) = str;
sexp_port_buf(res) = sexp_string_data(str);
sexp_port_offset(res) = 0;
sexp_port_size(res) = sexp_string_length(str);
return res;
}
sexp sexp_make_output_string_port (sexp ctx) {
sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE);
sexp_port_buf(res) = (char*) malloc(SEXP_PORT_BUFFER_SIZE);
sexp_port_size(res) = SEXP_PORT_BUFFER_SIZE;
sexp_port_offset(res) = 0;
sexp_port_cookie(res) = SEXP_NULL;
return res;
}
sexp sexp_get_output_string (sexp ctx, sexp out) {
sexp res;
sexp_gc_var(ctx, tmp, s_tmp);
sexp_gc_preserve(ctx, tmp, s_tmp);
tmp = ((sexp_port_offset(out) > 0)
? sexp_cons(ctx,
tmp=sexp_c_string(ctx,
sexp_port_buf(out),
sexp_port_offset(out)),
sexp_port_cookie(out))
: sexp_port_cookie(out));
res = sexp_string_concatenate(ctx, tmp);
sexp_gc_release(ctx, tmp, s_tmp);
return res;
}
#endif #endif
sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) {
@ -652,6 +751,7 @@ sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) {
sexp_port_stream(p) = in; sexp_port_stream(p) = in;
sexp_port_name(p) = name; sexp_port_name(p) = name;
sexp_port_line(p) = 0; sexp_port_line(p) = 0;
sexp_port_openp(p) = 1;
return p; return p;
} }
@ -661,187 +761,205 @@ sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) {
sexp_port_name(p) = name; sexp_port_name(p) = name;
sexp_port_line(p) = 0; sexp_port_line(p) = 0;
sexp_port_buf(p) = NULL; sexp_port_buf(p) = NULL;
sexp_port_openp(p) = 1;
return p; return p;
} }
void sexp_write (sexp obj, sexp out) { void sexp_write (sexp ctx, sexp obj, sexp out) {
unsigned long len, c, res; unsigned long len, c, res;
long i=0; long i=0;
double f; double f;
sexp x, *elts; sexp x, *elts;
char *str=NULL; char *str=NULL, numbuf[20];
if (! obj) { if (! obj) {
sexp_write_string("#<null>", out); /* shouldn't happen */ sexp_write_string(ctx, "#<null>", out); /* shouldn't happen */
} else if (sexp_pointerp(obj)) { } else if (sexp_pointerp(obj)) {
switch (sexp_pointer_tag(obj)) { switch (sexp_pointer_tag(obj)) {
case SEXP_PAIR: case SEXP_PAIR:
sexp_write_char('(', out); sexp_write_char(ctx, '(', out);
sexp_write(sexp_car(obj), out); sexp_write(ctx, sexp_car(obj), out);
for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) { for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) {
sexp_write_char(' ', out); sexp_write_char(ctx, ' ', out);
sexp_write(sexp_car(x), out); sexp_write(ctx, sexp_car(x), out);
} }
if (! sexp_nullp(x)) { if (! sexp_nullp(x)) {
sexp_write_string(" . ", out); sexp_write_string(ctx, " . ", out);
sexp_write(x, out); sexp_write(ctx, x, out);
} }
sexp_write_char(')', out); sexp_write_char(ctx, ')', out);
break; break;
case SEXP_VECTOR: case SEXP_VECTOR:
len = sexp_vector_length(obj); len = sexp_vector_length(obj);
elts = sexp_vector_data(obj); elts = sexp_vector_data(obj);
if (len == 0) { if (len == 0) {
sexp_write_string("#()", out); sexp_write_string(ctx, "#()", out);
} else { } else {
sexp_write_string("#(", out); sexp_write_string(ctx, "#(", out);
sexp_write(elts[0], out); sexp_write(ctx, elts[0], out);
for (i=1; i<len; i++) { for (i=1; i<len; i++) {
sexp_write_char(' ', out); sexp_write_char(ctx, ' ', out);
sexp_write(elts[i], out); sexp_write(ctx, elts[i], out);
} }
sexp_write_char(')', out); sexp_write_char(ctx, ')', out);
} }
break; break;
#if ! USE_IMMEDIATE_FLONUMS
case SEXP_FLONUM: case SEXP_FLONUM:
f = sexp_flonum_value(obj); f = sexp_flonum_value(obj);
sexp_printf(out, "%.15g%s", f, (f == trunc(f)) ? ".0" : ""); i = sprintf(numbuf, "%.15g", f);
if (f == trunc(f)) {
numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0';
}
sexp_write_string(ctx, numbuf, out);
break; break;
#endif
case SEXP_PROCEDURE: case SEXP_PROCEDURE:
sexp_write_string("#<procedure: ", out); sexp_write_string(ctx, "#<procedure: ", out);
sexp_write(sexp_bytecode_name(sexp_procedure_code(obj)), out); sexp_write(ctx, sexp_bytecode_name(sexp_procedure_code(obj)), out);
sexp_write_string(">", out); sexp_write_string(ctx, ">", out);
break; break;
case SEXP_IPORT: case SEXP_IPORT:
sexp_write_string("#<input-port>", out); break; sexp_write_string(ctx, "#<input-port>", out); break;
case SEXP_OPORT: case SEXP_OPORT:
sexp_write_string("#<output-port>", out); break; sexp_write_string(ctx, "#<output-port>", out); break;
case SEXP_CORE: case SEXP_CORE:
sexp_write_string("#<core-form>", out); break; sexp_write_string(ctx, "#<core-form>", out); break;
case SEXP_OPCODE: case SEXP_OPCODE:
sexp_write_string("#<opcode>", out); break; sexp_write_string(ctx, "#<opcode>", out); break;
case SEXP_BYTECODE: case SEXP_BYTECODE:
sexp_write_string("#<bytecode>", out); break; sexp_write_string(ctx, "#<bytecode>", out); break;
case SEXP_ENV: case SEXP_ENV:
sexp_printf(out, "#<env %p (%p)", obj, sexp_env_parent(obj)); sexp_write_string(ctx, "#<env>", out); break;
x = sexp_env_bindings(obj); /* sexp_printf(out, "#<env %p (%p)", obj, sexp_env_parent(obj)); */
if (sexp_unbox_integer(sexp_length(NULL, x)) > 5) { /* x = sexp_env_bindings(obj); */
sexp_write_char(' ', out); /* if (sexp_unbox_integer(sexp_length(NULL, x)) > 5) { */
sexp_write(sexp_caar(x), out); /* sexp_write_char(' ', out); */
sexp_write_string(": ", out); /* sexp_write(sexp_caar(x), out); */
if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) /* sexp_write_string(": ", out); */
sexp_printf(out, "%p", sexp_cdar(x)); /* if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) */
else /* sexp_printf(out, "%p", sexp_cdar(x)); */
sexp_write(sexp_cdar(x), out); /* else */
sexp_write_string(" ...", out); /* sexp_write(sexp_cdar(x), out); */
} else for ( ; x && sexp_pairp(x); x=sexp_cdr(x)) { /* sexp_write_string(" ...", out); */
sexp_write_char(' ', out); /* } else for ( ; x && sexp_pairp(x); x=sexp_cdr(x)) { */
sexp_write(sexp_caar(x), out); /* sexp_write_char(' ', out); */
sexp_write_string(": ", out); /* sexp_write(sexp_caar(x), out); */
if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) /* sexp_write_string(": ", out); */
sexp_printf(out, "%p", sexp_cdar(x)); /* if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) */
else /* sexp_printf(out, "%p", sexp_cdar(x)); */
sexp_write(sexp_cdar(x), out); /* else */
} /* sexp_write(sexp_cdar(x), out); */
sexp_write_char('>', out); /* } */
/* sexp_write_char('>', out); */
break; break;
case SEXP_EXCEPTION: case SEXP_EXCEPTION:
sexp_write_string("#<exception>", out); break; sexp_write_string(ctx, "#<exception>", out); break;
case SEXP_MACRO: case SEXP_MACRO:
sexp_write_string("#<macro>", out); break; sexp_write_string(ctx, "#<macro>", out); break;
#if USE_DEBUG #if USE_DEBUG
case SEXP_LAMBDA: case SEXP_LAMBDA:
/* sexp_write_string("#<lambda ", out); */ sexp_write_string(ctx, "#<lambda ", out);
sexp_printf(out, "#<lambda %p ", obj); /* sexp_printf(out, "#<lambda %p ", obj); */
sexp_write(sexp_lambda_params(obj), out); /* sexp_write(sexp_lambda_params(obj), out); */
sexp_write_char(' ', out); /* sexp_write_char(' ', out); */
sexp_write(sexp_lambda_body(obj), out); /* sexp_write(sexp_lambda_body(obj), out); */
sexp_write_char('>', out); /* sexp_write_char('>', out); */
break; break;
case SEXP_SEQ: case SEXP_SEQ:
sexp_write_string("#<seq ", out); sexp_write_string(ctx, "#<seq ", out);
sexp_write(sexp_seq_ls(obj), out); sexp_write(ctx, sexp_seq_ls(obj), out);
sexp_write_char('>', out); sexp_write_char(ctx, '>', out);
break; break;
case SEXP_CND: case SEXP_CND:
sexp_write_string("#<if ", out); sexp_write_string(ctx, "#<if ", out);
sexp_write(sexp_cnd_test(obj), out); sexp_write(ctx, sexp_cnd_test(obj), out);
sexp_write_char(' ', out); sexp_write_char(ctx, ' ', out);
sexp_write(sexp_cnd_pass(obj), out); sexp_write(ctx, sexp_cnd_pass(obj), out);
sexp_write_char(' ', out); sexp_write_char(ctx, ' ', out);
sexp_write(sexp_cnd_fail(obj), out); sexp_write(ctx, sexp_cnd_fail(obj), out);
sexp_write_char('>', out); sexp_write_char(ctx, '>', out);
break; break;
case SEXP_REF: case SEXP_REF:
sexp_write_string("#<ref: ", out); sexp_write_string(ctx, "#<ref>", out);
sexp_write(sexp_ref_name(obj), out); /* sexp_write_string("#<ref: ", out); */
sexp_printf(out, " %p>", sexp_ref_loc(obj)); /* sexp_write(sexp_ref_name(obj), out); */
/* sexp_printf(out, " %p>", sexp_ref_loc(obj)); */
break; break;
case SEXP_SET: case SEXP_SET:
sexp_write_string("#<set! ", out); sexp_write_string(ctx, "#<set! ", out);
sexp_write(sexp_set_var(obj), out); sexp_write(ctx, sexp_set_var(obj), out);
sexp_write_char(' ', out); sexp_write_char(ctx, ' ', out);
sexp_write(sexp_set_value(obj), out); sexp_write(ctx, sexp_set_value(obj), out);
sexp_write_string(">", out); sexp_write_string(ctx, ">", out);
break; break;
case SEXP_SYNCLO: case SEXP_SYNCLO:
sexp_write_string("#<sc ", out); sexp_write_string(ctx, "#<sc ", out);
sexp_write(sexp_synclo_expr(obj), out); sexp_write(ctx, sexp_synclo_expr(obj), out);
sexp_write_string(">", out); sexp_write_string(ctx, ">", out);
break; break;
#endif #endif
case SEXP_TYPE: case SEXP_TYPE:
sexp_write_string("#<type ", out); sexp_write_string(ctx, "#<type ", out);
sexp_write_string(sexp_type_name(obj), out); sexp_write_string(ctx, sexp_type_name(obj), out);
sexp_write_string(">", out); sexp_write_string(ctx, ">", out);
break; break;
case SEXP_STRING: case SEXP_STRING:
sexp_write_char('"', out); sexp_write_char(ctx, '"', out);
i = sexp_string_length(obj); i = sexp_string_length(obj);
str = sexp_string_data(obj); str = sexp_string_data(obj);
for ( ; i>0; str++, i--) { for ( ; i>0; str++, i--) {
switch (str[0]) { switch (str[0]) {
case '\\': sexp_write_string("\\\\", out); break; case '\\': sexp_write_string(ctx, "\\\\", out); break;
case '"': sexp_write_string("\\\"", out); break; case '"': sexp_write_string(ctx, "\\\"", out); break;
case '\n': sexp_write_string("\\n", out); break; case '\n': sexp_write_string(ctx, "\\n", out); break;
case '\r': sexp_write_string("\\r", out); break; case '\r': sexp_write_string(ctx, "\\r", out); break;
case '\t': sexp_write_string("\\t", out); break; case '\t': sexp_write_string(ctx, "\\t", out); break;
default: sexp_write_char(str[0], out); default: sexp_write_char(ctx, str[0], out);
} }
} }
sexp_write_char('"', out); sexp_write_char(ctx, '"', out);
break; break;
case SEXP_SYMBOL: case SEXP_SYMBOL:
i = sexp_string_length(sexp_symbol_string(obj)); i = sexp_string_length(sexp_symbol_string(obj));
str = sexp_string_data(sexp_symbol_string(obj)); str = sexp_string_data(sexp_symbol_string(obj));
for ( ; i>0; str++, i--) { for ( ; i>0; str++, i--) {
if ((str[0] == '\\') || is_separator(str[0])) if ((str[0] == '\\') || is_separator(str[0]))
sexp_write_char('\\', out); sexp_write_char(ctx, '\\', out);
sexp_write_char(str[0], out); sexp_write_char(ctx, str[0], out);
} }
break; break;
} }
} else if (sexp_integerp(obj)) { } else if (sexp_integerp(obj)) {
sexp_printf(out, "%ld", sexp_unbox_integer(obj)); sprintf(numbuf, "%ld", sexp_unbox_integer(obj));
sexp_write_string(ctx, numbuf, out);
#if USE_IMMEDIATE_FLONUMS #if USE_IMMEDIATE_FLONUMS
} else if (sexp_flonump(obj)) { } else if (sexp_flonump(obj)) {
f = sexp_flonum_value(obj); f = sexp_flonum_value(obj);
sexp_printf(out, "%.15g%s", f, (f == trunc(f)) ? ".0" : ""); i = sprintf(numbuf, "%.15g", f);
if (f == trunc(f)) {
numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0';
}
sexp_write_string(ctx, numbuf, out);
#endif #endif
} else if (sexp_charp(obj)) { } else if (sexp_charp(obj)) {
if (obj == sexp_make_character(' ')) if (obj == sexp_make_character(' '))
sexp_write_string("#\\space", out); sexp_write_string(ctx, "#\\space", out);
else if (obj == sexp_make_character('\n')) else if (obj == sexp_make_character('\n'))
sexp_write_string("#\\newline", out); sexp_write_string(ctx, "#\\newline", out);
else if (obj == sexp_make_character('\r')) else if (obj == sexp_make_character('\r'))
sexp_write_string("#\\return", out); sexp_write_string(ctx, "#\\return", out);
else if (obj == sexp_make_character('\t')) else if (obj == sexp_make_character('\t'))
sexp_write_string("#\\tab", out); sexp_write_string(ctx, "#\\tab", out);
else if ((33 <= sexp_unbox_character(obj)) else if ((33 <= sexp_unbox_character(obj))
&& (sexp_unbox_character(obj) < 127)) && (sexp_unbox_character(obj) < 127))
sexp_printf(out, "#\\%c", sexp_unbox_character(obj)); sexp_write_char(ctx, sexp_unbox_character(obj), out);
else else {
sexp_printf(out, "#\\x%02d", sexp_unbox_character(obj)); sexp_write_string(ctx, "#\\x", out);
if (sexp_unbox_character(obj) < 16)
sexp_write_char(ctx, '0', out);
sexp_write(ctx, sexp_make_integer(sexp_unbox_character(obj)), out);
}
} else if (sexp_symbolp(obj)) { } else if (sexp_symbolp(obj)) {
#if USE_HUFF_SYMS #if USE_HUFF_SYMS
@ -849,7 +967,7 @@ void sexp_write (sexp obj, sexp out) {
c = ((sexp_uint_t)obj)>>3; c = ((sexp_uint_t)obj)>>3;
while (c) { while (c) {
#include "opt/sexp-unhuff.c" #include "opt/sexp-unhuff.c"
sexp_write_char(res, out); sexp_write_char(ctx, res, out);
} }
} }
#endif #endif
@ -857,18 +975,18 @@ void sexp_write (sexp obj, sexp out) {
} else { } else {
switch ((sexp_uint_t) obj) { switch ((sexp_uint_t) obj) {
case (sexp_uint_t) SEXP_NULL: case (sexp_uint_t) SEXP_NULL:
sexp_write_string("()", out); break; sexp_write_string(ctx, "()", out); break;
case (sexp_uint_t) SEXP_TRUE: case (sexp_uint_t) SEXP_TRUE:
sexp_write_string("#t", out); break; sexp_write_string(ctx, "#t", out); break;
case (sexp_uint_t) SEXP_FALSE: case (sexp_uint_t) SEXP_FALSE:
sexp_write_string("#f", out); break; sexp_write_string(ctx, "#f", out); break;
case (sexp_uint_t) SEXP_EOF: case (sexp_uint_t) SEXP_EOF:
sexp_write_string("#<eof>", out); break; sexp_write_string(ctx, "#<eof>", out); break;
case (sexp_uint_t) SEXP_UNDEF: case (sexp_uint_t) SEXP_UNDEF:
case (sexp_uint_t) SEXP_VOID: case (sexp_uint_t) SEXP_VOID:
sexp_write_string("#<undef>", out); break; sexp_write_string(ctx, "#<undef>", out); break;
default: default:
sexp_printf(out, "#<invalid: %p>", obj); sexp_write_string(ctx, "#<undef>", out);
} }
} }
} }
@ -881,9 +999,9 @@ sexp sexp_read_string(sexp ctx, sexp in) {
char *buf=initbuf, *tmp; char *buf=initbuf, *tmp;
sexp res; sexp res;
for (c = sexp_read_char(in); c != '"'; c = sexp_read_char(in)) { for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) {
if (c == '\\') { if (c == '\\') {
c = sexp_read_char(in); c = sexp_read_char(ctx, in);
switch (c) {case 'n': c = '\n'; break; case 't': c = '\t'; break;} switch (c) {case 'n': c = '\n'; break; case 't': c = '\t'; break;}
} }
if (c == EOF) { if (c == EOF) {
@ -892,7 +1010,7 @@ sexp sexp_read_string(sexp ctx, sexp in) {
} }
buf[i++] = c; buf[i++] = c;
if (i >= size) { /* expand buffer w/ malloc(), later free() it */ if (i >= size) { /* expand buffer w/ malloc(), later free() it */
tmp = malloc(size*2); tmp = (char*) malloc(size*2);
memcpy(tmp, buf, i); memcpy(tmp, buf, i);
if (size != INIT_STRING_BUFFER_SIZE) free(buf); if (size != INIT_STRING_BUFFER_SIZE) free(buf);
buf = tmp; buf = tmp;
@ -915,15 +1033,15 @@ sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp) {
if (init != EOF) if (init != EOF)
buf[i++] = init; buf[i++] = init;
for (c = sexp_read_char(in); c != '"'; c = sexp_read_char(in)) { for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) {
if (c == '\\') c = sexp_read_char(in); if (c == '\\') c = sexp_read_char(ctx, in);
if (c == EOF || is_separator(c)) { if (c == EOF || is_separator(c)) {
sexp_push_char(c, in); sexp_push_char(ctx, c, in);
break; break;
} }
buf[i++] = c; buf[i++] = c;
if (i >= size) { /* expand buffer w/ malloc(), later free() it */ if (i >= size) { /* expand buffer w/ malloc(), later free() it */
tmp = malloc(size*2); tmp = (char*) malloc(size*2);
memcpy(tmp, buf, i); memcpy(tmp, buf, i);
if (size != INIT_STRING_BUFFER_SIZE) free(buf); if (size != INIT_STRING_BUFFER_SIZE) free(buf);
buf = tmp; buf = tmp;
@ -941,9 +1059,11 @@ sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_sint_t whole) {
sexp exponent; sexp exponent;
double res=0.0, scale=0.1, e=0.0; double res=0.0, scale=0.1, e=0.0;
int c; int c;
for (c=sexp_read_char(in); isdigit(c); c=sexp_read_char(in), scale*=0.1) for (c=sexp_read_char(ctx, in);
isdigit(c);
c=sexp_read_char(ctx, in), scale*=0.1)
res += digit_value(c)*scale; res += digit_value(c)*scale;
sexp_push_char(c, in); sexp_push_char(ctx, c, in);
if (c=='e' || c=='E') { if (c=='e' || c=='E') {
exponent = sexp_read_number(ctx, in, 10); exponent = sexp_read_number(ctx, in, 10);
if (sexp_exceptionp(exponent)) return exponent; if (sexp_exceptionp(exponent)) return exponent;
@ -959,23 +1079,24 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) {
sexp f; sexp f;
sexp_sint_t res = 0, negativep = 0, c; sexp_sint_t res = 0, negativep = 0, c;
c = sexp_read_char(in); c = sexp_read_char(ctx, in);
if (c == '-') if (c == '-')
negativep = 1; negativep = 1;
else if (isdigit(c)) else if (isdigit(c))
res = digit_value(c); res = digit_value(c);
if (base == 16) if (base == 16)
for (c=sexp_read_char(in); isxdigit(c); c=sexp_read_char(in)) for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in))
res = res * base + digit_value(c); res = res * base + digit_value(c);
for (c=sexp_read_char(in); isdigit(c); c=sexp_read_char(in)) for (c=sexp_read_char(ctx, in); isdigit(c); c=sexp_read_char(ctx, in))
res = res * base + digit_value(c); res = res * base + digit_value(c);
if (c=='.' || c=='e' || c=='E') { if (c=='.' || c=='e' || c=='E') {
if (base != 10) if (base != 10)
return sexp_read_error(ctx, "decimal found in non-base 10", SEXP_NULL, in); return
sexp_read_error(ctx, "decimal found in non-base 10", SEXP_NULL, in);
if (c!='.') if (c!='.')
sexp_push_char(c, in); sexp_push_char(ctx, c, in);
f = sexp_read_float_tail(ctx, in, res); f = sexp_read_float_tail(ctx, in, res);
if (! sexp_flonump(f)) return f; if (! sexp_flonump(f)) return f;
if ((c!='.') && (sexp_flonum_value(f) == round(sexp_flonum_value(f)))) { if ((c!='.') && (sexp_flonum_value(f) == round(sexp_flonum_value(f)))) {
@ -990,7 +1111,7 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) {
return f; return f;
} }
} else { } else {
sexp_push_char(c, in); sexp_push_char(ctx, c, in);
if ((c!=EOF) && ! is_separator(c)) if ((c!=EOF) && ! is_separator(c))
return sexp_read_error(ctx, "invalid numeric syntax", return sexp_read_error(ctx, "invalid numeric syntax",
sexp_list1(ctx, sexp_make_character(c)), in); sexp_list1(ctx, sexp_make_character(c)), in);
@ -1009,13 +1130,13 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
sexp_gc_preserve(ctx, tmp, s_tmp); sexp_gc_preserve(ctx, tmp, s_tmp);
scan_loop: scan_loop:
switch (c1 = sexp_read_char(in)) { switch (c1 = sexp_read_char(ctx, in)) {
case EOF: case EOF:
res = SEXP_EOF; res = SEXP_EOF;
break; break;
case ';': case ';':
sexp_port_line(in)++; sexp_port_line(in)++;
while ((c1 = sexp_read_char(in)) != EOF) while ((c1 = sexp_read_char(ctx, in)) != EOF)
if (c1 == '\n') if (c1 == '\n')
break; break;
/* ... FALLTHROUGH ... */ /* ... FALLTHROUGH ... */
@ -1035,11 +1156,11 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
res = sexp_list2(ctx, the_quasiquote_symbol, res); res = sexp_list2(ctx, the_quasiquote_symbol, res);
break; break;
case ',': case ',':
if ((c1 = sexp_read_char(in)) == '@') { if ((c1 = sexp_read_char(ctx, in)) == '@') {
res = sexp_read(ctx, in); res = sexp_read(ctx, in);
res = sexp_list2(ctx, the_unquote_splicing_symbol, res); res = sexp_list2(ctx, the_unquote_splicing_symbol, res);
} else { } else {
sexp_push_char(c1, in); sexp_push_char(ctx, c1, in);
res = sexp_read(ctx, in); res = sexp_read(ctx, in);
res = sexp_list2(ctx, the_unquote_symbol, res); res = sexp_list2(ctx, the_unquote_symbol, res);
} }
@ -1087,7 +1208,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
} }
break; break;
case '#': case '#':
switch (c1=sexp_read_char(in)) { switch (c1=sexp_read_char(ctx, in)) {
case 'b': case 'b':
res = sexp_read_number(ctx, in, 2); break; res = sexp_read_number(ctx, in, 2); break;
case 'o': case 'o':
@ -1108,10 +1229,10 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
break; break;
case 'f': case 'f':
case 't': case 't':
c2 = sexp_read_char(in); c2 = sexp_read_char(ctx, in);
if (c2 == EOF || is_separator(c2)) { if (c2 == EOF || is_separator(c2)) {
res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE); res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE);
sexp_push_char(c2, in); sexp_push_char(ctx, c2, in);
} else { } else {
res = sexp_read_error(ctx, "invalid syntax #%c%c", res = sexp_read_error(ctx, "invalid syntax #%c%c",
sexp_list2(ctx, sexp_list2(ctx,
@ -1129,7 +1250,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
else else
goto scan_loop; goto scan_loop;
case '\\': case '\\':
c1 = sexp_read_char(in); c1 = sexp_read_char(ctx, in);
res = sexp_read_symbol(ctx, in, c1, 0); res = sexp_read_symbol(ctx, in, c1, 0);
if (sexp_stringp(res)) { if (sexp_stringp(res)) {
str = sexp_string_data(res); str = sexp_string_data(res);
@ -1160,7 +1281,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
} }
break; break;
case '(': case '(':
sexp_push_char(c1, in); sexp_push_char(ctx, c1, in);
res = sexp_read(ctx, in); res = sexp_read(ctx, in);
if (sexp_not(sexp_listp(ctx, res))) { if (sexp_not(sexp_listp(ctx, res))) {
if (! sexp_exceptionp(res)) { if (! sexp_exceptionp(res)) {
@ -1178,14 +1299,14 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
} }
break; break;
case '.': case '.':
c1 = sexp_read_char(in); c1 = sexp_read_char(ctx, in);
if (c1 == EOF || is_separator(c1)) { if (c1 == EOF || is_separator(c1)) {
res = SEXP_RAWDOT; res = SEXP_RAWDOT;
} else if (isdigit(c1)) { } else if (isdigit(c1)) {
sexp_push_char(c1,in ); sexp_push_char(ctx, c1, in);
res = sexp_read_float_tail(ctx, in, 0); res = sexp_read_float_tail(ctx, in, 0);
} else { } else {
sexp_push_char(c1, in); sexp_push_char(ctx, c1, in);
res = sexp_read_symbol(ctx, in, '.', 1); res = sexp_read_symbol(ctx, in, '.', 1);
} }
break; break;
@ -1194,9 +1315,9 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
break; break;
case '+': case '+':
case '-': case '-':
c2 = sexp_read_char(in); c2 = sexp_read_char(ctx, in);
if (c2 == '.' || isdigit(c2)) { if (c2 == '.' || isdigit(c2)) {
sexp_push_char(c2, in); sexp_push_char(ctx, c2, in);
res = sexp_read_number(ctx, in, 10); res = sexp_read_number(ctx, in, 10);
if ((c1 == '-') && ! sexp_exceptionp(res)) { if ((c1 == '-') && ! sexp_exceptionp(res)) {
#if USE_FLONUMS #if USE_FLONUMS
@ -1211,13 +1332,13 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
res = sexp_fx_mul(res, -1); res = sexp_fx_mul(res, -1);
} }
} else { } else {
sexp_push_char(c2, in); sexp_push_char(ctx, c2, in);
res = sexp_read_symbol(ctx, in, c1, 1); res = sexp_read_symbol(ctx, in, c1, 1);
} }
break; break;
case '0': case '1': case '2': case '3': case '4': case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '5': case '6': case '7': case '8': case '9':
sexp_push_char(c1, in); sexp_push_char(ctx, c1, in);
res = sexp_read_number(ctx, in, 10); res = sexp_read_number(ctx, in, 10);
break; break;
default: default:
@ -1238,7 +1359,6 @@ sexp sexp_read (sexp ctx, sexp in) {
return res; return res;
} }
#if USE_STRING_STREAMS
sexp sexp_read_from_string(sexp ctx, char *str) { sexp sexp_read_from_string(sexp ctx, char *str) {
sexp res; sexp res;
sexp_gc_var(ctx, s, s_s); sexp_gc_var(ctx, s, s_s);
@ -1251,7 +1371,6 @@ sexp sexp_read_from_string(sexp ctx, char *str) {
sexp_gc_release(ctx, s, s_s); sexp_gc_release(ctx, s, s_s);
return res; return res;
} }
#endif
void sexp_init() { void sexp_init() {
int i; int i;