mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-21 14:49:18 +02:00
initial plan9 work
This commit is contained in:
Alex Shinn
parent
86ce8fbc15
commit
d4f97c40d5
8 changed files with 431 additions and 241 deletions
61
eval.c
61
eval.c
|
|
@ -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;
|
||||
|
||||
#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
|
||||
#include "debug.c"
|
||||
|
|
@ -1298,7 +1298,10 @@ sexp sexp_vm (sexp ctx, sexp proc) {
|
|||
tmp1 = _ARG1;
|
||||
i = 1;
|
||||
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),
|
||||
sexp_make_integer(1), continuation_resumer,
|
||||
tmp2);
|
||||
|
|
@ -1334,10 +1337,8 @@ sexp sexp_vm (sexp ctx, sexp proc) {
|
|||
goto make_call;
|
||||
case OP_CALL:
|
||||
#if USE_CHECK_STACK
|
||||
if (top+16 >= INIT_STACK_SIZE) {
|
||||
fprintf(stderr, "out of stack space\n");
|
||||
exit(70);
|
||||
}
|
||||
if (top+16 >= INIT_STACK_SIZE)
|
||||
errx(70, "out of stack space\n");
|
||||
#endif
|
||||
i = sexp_unbox_integer(_WORD0);
|
||||
tmp1 = _ARG1;
|
||||
|
|
@ -1752,19 +1753,19 @@ sexp sexp_vm (sexp ctx, sexp proc) {
|
|||
break;
|
||||
case OP_DISPLAY:
|
||||
if (sexp_stringp(_ARG1)) {
|
||||
sexp_write_string(sexp_string_data(_ARG1), _ARG2);
|
||||
sexp_write_string(ctx, sexp_string_data(_ARG1), _ARG2);
|
||||
_ARG2 = SEXP_VOID;
|
||||
top--;
|
||||
break;
|
||||
} 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;
|
||||
top--;
|
||||
break;
|
||||
}
|
||||
/* ... FALLTHROUGH ... */
|
||||
case OP_WRITE:
|
||||
sexp_write(_ARG1, _ARG2);
|
||||
sexp_write(ctx, _ARG1, _ARG2);
|
||||
_ARG2 = SEXP_VOID;
|
||||
top--;
|
||||
break;
|
||||
|
|
@ -1774,7 +1775,7 @@ sexp sexp_vm (sexp ctx, sexp proc) {
|
|||
top--;
|
||||
break;
|
||||
case OP_NEWLINE:
|
||||
sexp_write_char('\n', _ARG1);
|
||||
sexp_write_char(ctx, '\n', _ARG1);
|
||||
_ARG1 = SEXP_VOID;
|
||||
break;
|
||||
case OP_FLUSH_OUTPUT:
|
||||
|
|
@ -1787,12 +1788,12 @@ sexp sexp_vm (sexp ctx, sexp proc) {
|
|||
sexp_check_exception();
|
||||
break;
|
||||
case OP_READ_CHAR:
|
||||
i = sexp_read_char(_ARG1);
|
||||
i = sexp_read_char(ctx, _ARG1);
|
||||
_ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i);
|
||||
break;
|
||||
case OP_PEEK_CHAR:
|
||||
i = sexp_read_char(_ARG1);
|
||||
sexp_push_char(i, _ARG1);
|
||||
i = sexp_read_char(ctx, _ARG1);
|
||||
sexp_push_char(ctx, i, _ARG1);
|
||||
_ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i);
|
||||
break;
|
||||
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) {
|
||||
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))
|
||||
free(sexp_port_buf(port));
|
||||
if (sexp_port_stream(port))
|
||||
fclose(sexp_port_stream(port));
|
||||
return SEXP_VOID;
|
||||
}
|
||||
|
||||
|
|
@ -1860,9 +1866,9 @@ void sexp_warn_undefs (sexp from, sexp to, sexp out) {
|
|||
sexp x;
|
||||
for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x))
|
||||
if (sexp_cdar(x) == SEXP_UNDEF) {
|
||||
sexp_write_string("WARNING: reference to undefined variable: ", out);
|
||||
sexp_write(sexp_caar(x), out);
|
||||
sexp_write_char('\n', out);
|
||||
sexp_write_string(ctx, "WARNING: reference to undefined variable: ", out);
|
||||
sexp_write(ctx, sexp_caar(x), 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));
|
||||
}
|
||||
|
||||
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) {
|
||||
sexp_sint_t len1, len2, len, diff;
|
||||
if (! sexp_stringp(str1))
|
||||
|
|
@ -2153,6 +2140,7 @@ sexp sexp_eval (sexp ctx, sexp obj) {
|
|||
return res;
|
||||
}
|
||||
|
||||
#if USE_STRING_STREAMS
|
||||
sexp sexp_eval_string (sexp ctx, char *str) {
|
||||
sexp res;
|
||||
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);
|
||||
return res;
|
||||
}
|
||||
#endif
|
||||
|
||||
void sexp_scheme_init () {
|
||||
sexp ctx;
|
||||
|
|
|
|||
14
gc.c
14
gc.c
|
|
@ -157,10 +157,8 @@ sexp sexp_gc (sexp ctx, size_t *sum_freed) {
|
|||
sexp_heap sexp_make_heap (size_t size) {
|
||||
sexp free, next;
|
||||
sexp_heap h = (sexp_heap) malloc(sizeof(struct sexp_heap) + size);
|
||||
if (! h) {
|
||||
fprintf(stderr, "out of memory allocating %zu byte heap, aborting\n", size);
|
||||
exit(70);
|
||||
}
|
||||
if (! h)
|
||||
errx(70, "out of memory allocating %zu byte heap, aborting\n", size);
|
||||
h->size = size;
|
||||
h->data = (char*) sexp_heap_align((sexp_uint_t)&(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 */
|
||||
sexp_cdr(ls1) = sexp_cdr(ls2);
|
||||
}
|
||||
bzero((void*)ls2, size);
|
||||
memset((void*)ls2, 0, size);
|
||||
return 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_grow_heap(ctx, size);
|
||||
res = sexp_try_alloc(ctx, size);
|
||||
if (! res) {
|
||||
fprintf(stderr, "out of memory allocating %zu bytes, aborting\n", size);
|
||||
exit(70);
|
||||
}
|
||||
if (! res)
|
||||
errx(80, "out of memory allocating %zu bytes, aborting\n", size);
|
||||
}
|
||||
return res;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -42,13 +42,6 @@
|
|||
/* 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__)
|
||||
#define SEXP_BSD 1
|
||||
#else
|
||||
|
|
@ -104,3 +97,24 @@
|
|||
#define USE_CHECK_STACK 0
|
||||
#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
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
#ifndef SEXP_EVAL_H
|
||||
#define SEXP_EVAL_H
|
||||
|
||||
#include "sexp.h"
|
||||
#include "chibi/sexp.h"
|
||||
|
||||
/************************* additional types ***************************/
|
||||
|
||||
|
|
|
|||
|
|
@ -5,17 +5,22 @@
|
|||
#ifndef SEXP_H
|
||||
#define SEXP_H
|
||||
|
||||
#include "config.h"
|
||||
#include "install.h"
|
||||
#include "chibi/config.h"
|
||||
#include "chibi/install.h"
|
||||
|
||||
#include <ctype.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 <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <stdarg.h>
|
||||
#include <sys/types.h>
|
||||
#include <math.h>
|
||||
#endif
|
||||
|
||||
/* tagging system
|
||||
* bits end in 00: pointer
|
||||
|
|
@ -123,7 +128,7 @@ struct sexp_struct {
|
|||
struct {
|
||||
FILE *stream;
|
||||
char *buf;
|
||||
sexp_uint_t line;
|
||||
sexp_uint_t offset, line, openp;
|
||||
size_t size;
|
||||
sexp name;
|
||||
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_name(p) ((p)->value.port.name)
|
||||
#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_buf(p) ((p)->value.port.buf)
|
||||
#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_message(p) ((p)->value.exception.message)
|
||||
|
|
@ -509,13 +516,32 @@ sexp sexp_make_flonum(sexp ctx, double f);
|
|||
|
||||
/***************************** general API ****************************/
|
||||
|
||||
#define sexp_read_char(p) (getc(sexp_port_stream(p)))
|
||||
#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_write_string(s, p) (fputs(s, sexp_port_stream(p)))
|
||||
#define sexp_printf(p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__))
|
||||
#define sexp_scanf(p, ...) (fscanf(sexp_port_stream(p), __VA_ARGS__))
|
||||
#define sexp_flush(p) (fflush(sexp_port_stream(p)))
|
||||
#if USE_STRING_STREAMS
|
||||
|
||||
#define sexp_read_char(x, p) (getc(sexp_port_stream(p)))
|
||||
#define sexp_push_char(x, c, p) (ungetc(c, sexp_port_stream(p)))
|
||||
#define sexp_write_char(x, c, p) (putc(c, sexp_port_stream(p)))
|
||||
#define sexp_write_string(x, s, p) (fputs(s, 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_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_make_string(sexp ctx, sexp len, sexp ch);
|
||||
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_string_to_symbol(sexp ctx, sexp str);
|
||||
sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt);
|
||||
sexp sexp_list_to_vector(sexp ctx, sexp ls);
|
||||
sexp sexp_vector(sexp ctx, int count, ...);
|
||||
void sexp_write(sexp obj, sexp out);
|
||||
/* sexp sexp_vector(sexp ctx, int count, ...); */
|
||||
void sexp_write(sexp ctx, sexp obj, sexp out);
|
||||
sexp sexp_read_string(sexp ctx, sexp in);
|
||||
sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp);
|
||||
sexp sexp_read_number(sexp ctx, sexp in, int base);
|
||||
|
|
|
|||
18
main.c
18
main.c
|
|
@ -2,7 +2,9 @@
|
|||
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
|
||||
/* BSD-style license: http://synthcode.com/license.txt */
|
||||
|
||||
#ifndef PLAN9
|
||||
#include <sys/stat.h>
|
||||
#endif
|
||||
#include "chibi/eval.h"
|
||||
|
||||
char *chibi_module_dir = NULL;
|
||||
|
|
@ -11,13 +13,18 @@ sexp find_module_file (sexp ctx, char *file) {
|
|||
sexp res;
|
||||
int mlen, flen;
|
||||
char *path;
|
||||
#ifndef PLAN9
|
||||
struct stat buf;
|
||||
|
||||
if (! stat(file, &buf))
|
||||
#endif
|
||||
return sexp_c_string(ctx, file, -1);
|
||||
#ifndef PLAN9
|
||||
if (! chibi_module_dir) {
|
||||
#ifndef PLAN9
|
||||
chibi_module_dir = getenv("CHIBI_MODULE_DIR");
|
||||
if (! chibi_module_dir)
|
||||
#endif
|
||||
chibi_module_dir = sexp_module_dir;
|
||||
}
|
||||
mlen = strlen(chibi_module_dir);
|
||||
|
|
@ -33,6 +40,7 @@ sexp find_module_file (sexp ctx, char *file) {
|
|||
res = SEXP_FALSE;
|
||||
free(path);
|
||||
return res;
|
||||
#endif
|
||||
}
|
||||
|
||||
void repl (sexp ctx) {
|
||||
|
|
@ -45,7 +53,7 @@ void repl (sexp ctx) {
|
|||
out = sexp_eval_string(ctx, "(current-output-port)");
|
||||
err = sexp_eval_string(ctx, "(current-error-port)");
|
||||
while (1) {
|
||||
sexp_write_string("> ", out);
|
||||
sexp_write_string(ctx, "> ", out);
|
||||
sexp_flush(out);
|
||||
obj = sexp_read(ctx, in);
|
||||
if (obj == SEXP_EOF)
|
||||
|
|
@ -60,8 +68,8 @@ void repl (sexp ctx) {
|
|||
sexp_warn_undefs(sexp_env_bindings(env), tmp, err);
|
||||
#endif
|
||||
if (res != SEXP_VOID) {
|
||||
sexp_write(res, out);
|
||||
sexp_write_char('\n', out);
|
||||
sexp_write(ctx, res, out);
|
||||
sexp_write_char(ctx, '\n', out);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -92,8 +100,8 @@ void run_main (int argc, char **argv) {
|
|||
if (sexp_exceptionp(res)) {
|
||||
sexp_print_exception(ctx, res, out);
|
||||
} else if (argv[i][1] == 'p') {
|
||||
sexp_write(res, out);
|
||||
sexp_write_char('\n', out);
|
||||
sexp_write(ctx, res, out);
|
||||
sexp_write_char(ctx, '\n', out);
|
||||
}
|
||||
quit=1;
|
||||
i++;
|
||||
|
|
|
|||
37
mkfile
Normal file
37
mkfile
Normal 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
461
sexp.c
|
|
@ -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 ls;
|
||||
sexp_write_string("ERROR", out);
|
||||
sexp_write_string(ctx, "ERROR", out);
|
||||
if (sexp_exceptionp(exn)) {
|
||||
if (sexp_procedurep(sexp_exception_procedure(exn))) {
|
||||
ls = sexp_bytecode_name(
|
||||
sexp_procedure_code(sexp_exception_procedure(exn)));
|
||||
if (sexp_symbolp(ls)) {
|
||||
sexp_write_string(" in ", out);
|
||||
sexp_write(ls, out);
|
||||
sexp_write_string(ctx, " in ", out);
|
||||
sexp_write(ctx, ls, out);
|
||||
}
|
||||
}
|
||||
if (sexp_integerp(sexp_exception_line(exn))
|
||||
&& (sexp_exception_line(exn) > sexp_make_integer(0))) {
|
||||
sexp_write_string(" on line ", out);
|
||||
sexp_write(sexp_exception_line(exn), out);
|
||||
sexp_write_string(ctx, " on line ", out);
|
||||
sexp_write(ctx, sexp_exception_line(exn), out);
|
||||
}
|
||||
if (sexp_stringp(sexp_exception_file(exn))) {
|
||||
sexp_write_string(" of file ", out);
|
||||
sexp_write_string(sexp_string_data(sexp_exception_file(exn)), out);
|
||||
sexp_write_string(ctx, " of file ", out);
|
||||
sexp_write_string(ctx, sexp_string_data(sexp_exception_file(exn)), out);
|
||||
}
|
||||
sexp_write_string(": ", out);
|
||||
sexp_write_string(sexp_string_data(sexp_exception_message(exn)), out);
|
||||
sexp_write_string(ctx, ": ", out);
|
||||
sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out);
|
||||
if (sexp_exception_irritants(exn)
|
||||
&& sexp_pairp(sexp_exception_irritants(exn))) {
|
||||
if (sexp_nullp(sexp_cdr(sexp_exception_irritants(exn)))) {
|
||||
sexp_write_string(": ", out);
|
||||
sexp_write(sexp_car(sexp_exception_irritants(exn)), out);
|
||||
sexp_write_string("\n", out);
|
||||
sexp_write_string(ctx, ": ", out);
|
||||
sexp_write(ctx, sexp_car(sexp_exception_irritants(exn)), out);
|
||||
sexp_write_string(ctx, "\n", out);
|
||||
} else {
|
||||
sexp_write_string("\n", out);
|
||||
sexp_write_string(ctx, "\n", out);
|
||||
for (ls=sexp_exception_irritants(exn);
|
||||
sexp_pairp(ls); ls=sexp_cdr(ls)) {
|
||||
sexp_write_string(" ", out);
|
||||
sexp_write(sexp_car(ls), out);
|
||||
sexp_write_char('\n', out);
|
||||
sexp_write_string(ctx, " ", out);
|
||||
sexp_write(ctx, sexp_car(ls), out);
|
||||
sexp_write_char(ctx, '\n', out);
|
||||
}
|
||||
}
|
||||
} else {
|
||||
sexp_write_char('\n', out);
|
||||
sexp_write_char(ctx, '\n', out);
|
||||
}
|
||||
} else {
|
||||
sexp_write_string(": ", out);
|
||||
sexp_write_string(ctx, ": ", out);
|
||||
if (sexp_stringp(exn))
|
||||
sexp_write_string(sexp_string_data(exn), out);
|
||||
sexp_write_string(ctx, sexp_string_data(exn), out);
|
||||
else
|
||||
sexp_write(exn, out);
|
||||
sexp_write_char('\n', out);
|
||||
sexp_write(ctx, exn, out);
|
||||
sexp_write_char(ctx, '\n', out);
|
||||
}
|
||||
return SEXP_VOID;
|
||||
}
|
||||
|
|
@ -434,6 +434,25 @@ sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end) {
|
|||
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_OFFSET_BASIS 2166136261uL
|
||||
|
||||
|
|
@ -513,19 +532,6 @@ sexp sexp_list_to_vector(sexp ctx, sexp ls) {
|
|||
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 *************************/
|
||||
|
||||
#if USE_STRING_STREAMS
|
||||
|
|
@ -645,6 +651,99 @@ sexp sexp_get_output_string (sexp ctx, sexp port) {
|
|||
|
||||
#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
|
||||
|
||||
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_name(p) = name;
|
||||
sexp_port_line(p) = 0;
|
||||
sexp_port_openp(p) = 1;
|
||||
return p;
|
||||
}
|
||||
|
||||
|
|
@ -661,187 +761,205 @@ sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) {
|
|||
sexp_port_name(p) = name;
|
||||
sexp_port_line(p) = 0;
|
||||
sexp_port_buf(p) = NULL;
|
||||
sexp_port_openp(p) = 1;
|
||||
return p;
|
||||
}
|
||||
|
||||
void sexp_write (sexp obj, sexp out) {
|
||||
void sexp_write (sexp ctx, sexp obj, sexp out) {
|
||||
unsigned long len, c, res;
|
||||
long i=0;
|
||||
double f;
|
||||
sexp x, *elts;
|
||||
char *str=NULL;
|
||||
char *str=NULL, numbuf[20];
|
||||
|
||||
if (! obj) {
|
||||
sexp_write_string("#<null>", out); /* shouldn't happen */
|
||||
sexp_write_string(ctx, "#<null>", out); /* shouldn't happen */
|
||||
} else if (sexp_pointerp(obj)) {
|
||||
switch (sexp_pointer_tag(obj)) {
|
||||
case SEXP_PAIR:
|
||||
sexp_write_char('(', out);
|
||||
sexp_write(sexp_car(obj), out);
|
||||
sexp_write_char(ctx, '(', out);
|
||||
sexp_write(ctx, sexp_car(obj), out);
|
||||
for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) {
|
||||
sexp_write_char(' ', out);
|
||||
sexp_write(sexp_car(x), out);
|
||||
sexp_write_char(ctx, ' ', out);
|
||||
sexp_write(ctx, sexp_car(x), out);
|
||||
}
|
||||
if (! sexp_nullp(x)) {
|
||||
sexp_write_string(" . ", out);
|
||||
sexp_write(x, out);
|
||||
sexp_write_string(ctx, " . ", out);
|
||||
sexp_write(ctx, x, out);
|
||||
}
|
||||
sexp_write_char(')', out);
|
||||
sexp_write_char(ctx, ')', out);
|
||||
break;
|
||||
case SEXP_VECTOR:
|
||||
len = sexp_vector_length(obj);
|
||||
elts = sexp_vector_data(obj);
|
||||
if (len == 0) {
|
||||
sexp_write_string("#()", out);
|
||||
sexp_write_string(ctx, "#()", out);
|
||||
} else {
|
||||
sexp_write_string("#(", out);
|
||||
sexp_write(elts[0], out);
|
||||
sexp_write_string(ctx, "#(", out);
|
||||
sexp_write(ctx, elts[0], out);
|
||||
for (i=1; i<len; i++) {
|
||||
sexp_write_char(' ', out);
|
||||
sexp_write(elts[i], out);
|
||||
sexp_write_char(ctx, ' ', out);
|
||||
sexp_write(ctx, elts[i], out);
|
||||
}
|
||||
sexp_write_char(')', out);
|
||||
sexp_write_char(ctx, ')', out);
|
||||
}
|
||||
break;
|
||||
#if ! USE_IMMEDIATE_FLONUMS
|
||||
case SEXP_FLONUM:
|
||||
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;
|
||||
#endif
|
||||
case SEXP_PROCEDURE:
|
||||
sexp_write_string("#<procedure: ", out);
|
||||
sexp_write(sexp_bytecode_name(sexp_procedure_code(obj)), out);
|
||||
sexp_write_string(">", out);
|
||||
sexp_write_string(ctx, "#<procedure: ", out);
|
||||
sexp_write(ctx, sexp_bytecode_name(sexp_procedure_code(obj)), out);
|
||||
sexp_write_string(ctx, ">", out);
|
||||
break;
|
||||
case SEXP_IPORT:
|
||||
sexp_write_string("#<input-port>", out); break;
|
||||
sexp_write_string(ctx, "#<input-port>", out); break;
|
||||
case SEXP_OPORT:
|
||||
sexp_write_string("#<output-port>", out); break;
|
||||
sexp_write_string(ctx, "#<output-port>", out); break;
|
||||
case SEXP_CORE:
|
||||
sexp_write_string("#<core-form>", out); break;
|
||||
sexp_write_string(ctx, "#<core-form>", out); break;
|
||||
case SEXP_OPCODE:
|
||||
sexp_write_string("#<opcode>", out); break;
|
||||
sexp_write_string(ctx, "#<opcode>", out); break;
|
||||
case SEXP_BYTECODE:
|
||||
sexp_write_string("#<bytecode>", out); break;
|
||||
sexp_write_string(ctx, "#<bytecode>", out); break;
|
||||
case SEXP_ENV:
|
||||
sexp_printf(out, "#<env %p (%p)", obj, sexp_env_parent(obj));
|
||||
x = sexp_env_bindings(obj);
|
||||
if (sexp_unbox_integer(sexp_length(NULL, x)) > 5) {
|
||||
sexp_write_char(' ', out);
|
||||
sexp_write(sexp_caar(x), out);
|
||||
sexp_write_string(": ", out);
|
||||
if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x)))
|
||||
sexp_printf(out, "%p", sexp_cdar(x));
|
||||
else
|
||||
sexp_write(sexp_cdar(x), out);
|
||||
sexp_write_string(" ...", out);
|
||||
} else for ( ; x && sexp_pairp(x); x=sexp_cdr(x)) {
|
||||
sexp_write_char(' ', out);
|
||||
sexp_write(sexp_caar(x), out);
|
||||
sexp_write_string(": ", out);
|
||||
if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x)))
|
||||
sexp_printf(out, "%p", sexp_cdar(x));
|
||||
else
|
||||
sexp_write(sexp_cdar(x), out);
|
||||
}
|
||||
sexp_write_char('>', out);
|
||||
sexp_write_string(ctx, "#<env>", out); break;
|
||||
/* sexp_printf(out, "#<env %p (%p)", obj, sexp_env_parent(obj)); */
|
||||
/* x = sexp_env_bindings(obj); */
|
||||
/* if (sexp_unbox_integer(sexp_length(NULL, x)) > 5) { */
|
||||
/* sexp_write_char(' ', out); */
|
||||
/* sexp_write(sexp_caar(x), out); */
|
||||
/* sexp_write_string(": ", out); */
|
||||
/* if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) */
|
||||
/* sexp_printf(out, "%p", sexp_cdar(x)); */
|
||||
/* else */
|
||||
/* sexp_write(sexp_cdar(x), out); */
|
||||
/* sexp_write_string(" ...", out); */
|
||||
/* } else for ( ; x && sexp_pairp(x); x=sexp_cdr(x)) { */
|
||||
/* sexp_write_char(' ', out); */
|
||||
/* sexp_write(sexp_caar(x), out); */
|
||||
/* sexp_write_string(": ", out); */
|
||||
/* if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) */
|
||||
/* sexp_printf(out, "%p", sexp_cdar(x)); */
|
||||
/* else */
|
||||
/* sexp_write(sexp_cdar(x), out); */
|
||||
/* } */
|
||||
/* sexp_write_char('>', out); */
|
||||
break;
|
||||
case SEXP_EXCEPTION:
|
||||
sexp_write_string("#<exception>", out); break;
|
||||
sexp_write_string(ctx, "#<exception>", out); break;
|
||||
case SEXP_MACRO:
|
||||
sexp_write_string("#<macro>", out); break;
|
||||
sexp_write_string(ctx, "#<macro>", out); break;
|
||||
#if USE_DEBUG
|
||||
case SEXP_LAMBDA:
|
||||
/* sexp_write_string("#<lambda ", out); */
|
||||
sexp_printf(out, "#<lambda %p ", obj);
|
||||
sexp_write(sexp_lambda_params(obj), out);
|
||||
sexp_write_char(' ', out);
|
||||
sexp_write(sexp_lambda_body(obj), out);
|
||||
sexp_write_char('>', out);
|
||||
sexp_write_string(ctx, "#<lambda ", out);
|
||||
/* sexp_printf(out, "#<lambda %p ", obj); */
|
||||
/* sexp_write(sexp_lambda_params(obj), out); */
|
||||
/* sexp_write_char(' ', out); */
|
||||
/* sexp_write(sexp_lambda_body(obj), out); */
|
||||
/* sexp_write_char('>', out); */
|
||||
break;
|
||||
case SEXP_SEQ:
|
||||
sexp_write_string("#<seq ", out);
|
||||
sexp_write(sexp_seq_ls(obj), out);
|
||||
sexp_write_char('>', out);
|
||||
sexp_write_string(ctx, "#<seq ", out);
|
||||
sexp_write(ctx, sexp_seq_ls(obj), out);
|
||||
sexp_write_char(ctx, '>', out);
|
||||
break;
|
||||
case SEXP_CND:
|
||||
sexp_write_string("#<if ", out);
|
||||
sexp_write(sexp_cnd_test(obj), out);
|
||||
sexp_write_char(' ', out);
|
||||
sexp_write(sexp_cnd_pass(obj), out);
|
||||
sexp_write_char(' ', out);
|
||||
sexp_write(sexp_cnd_fail(obj), out);
|
||||
sexp_write_char('>', out);
|
||||
sexp_write_string(ctx, "#<if ", out);
|
||||
sexp_write(ctx, sexp_cnd_test(obj), out);
|
||||
sexp_write_char(ctx, ' ', out);
|
||||
sexp_write(ctx, sexp_cnd_pass(obj), out);
|
||||
sexp_write_char(ctx, ' ', out);
|
||||
sexp_write(ctx, sexp_cnd_fail(obj), out);
|
||||
sexp_write_char(ctx, '>', out);
|
||||
break;
|
||||
case SEXP_REF:
|
||||
sexp_write_string("#<ref: ", out);
|
||||
sexp_write(sexp_ref_name(obj), out);
|
||||
sexp_printf(out, " %p>", sexp_ref_loc(obj));
|
||||
sexp_write_string(ctx, "#<ref>", out);
|
||||
/* sexp_write_string("#<ref: ", out); */
|
||||
/* sexp_write(sexp_ref_name(obj), out); */
|
||||
/* sexp_printf(out, " %p>", sexp_ref_loc(obj)); */
|
||||
break;
|
||||
case SEXP_SET:
|
||||
sexp_write_string("#<set! ", out);
|
||||
sexp_write(sexp_set_var(obj), out);
|
||||
sexp_write_char(' ', out);
|
||||
sexp_write(sexp_set_value(obj), out);
|
||||
sexp_write_string(">", out);
|
||||
sexp_write_string(ctx, "#<set! ", out);
|
||||
sexp_write(ctx, sexp_set_var(obj), out);
|
||||
sexp_write_char(ctx, ' ', out);
|
||||
sexp_write(ctx, sexp_set_value(obj), out);
|
||||
sexp_write_string(ctx, ">", out);
|
||||
break;
|
||||
case SEXP_SYNCLO:
|
||||
sexp_write_string("#<sc ", out);
|
||||
sexp_write(sexp_synclo_expr(obj), out);
|
||||
sexp_write_string(">", out);
|
||||
sexp_write_string(ctx, "#<sc ", out);
|
||||
sexp_write(ctx, sexp_synclo_expr(obj), out);
|
||||
sexp_write_string(ctx, ">", out);
|
||||
break;
|
||||
#endif
|
||||
case SEXP_TYPE:
|
||||
sexp_write_string("#<type ", out);
|
||||
sexp_write_string(sexp_type_name(obj), out);
|
||||
sexp_write_string(">", out);
|
||||
sexp_write_string(ctx, "#<type ", out);
|
||||
sexp_write_string(ctx, sexp_type_name(obj), out);
|
||||
sexp_write_string(ctx, ">", out);
|
||||
break;
|
||||
case SEXP_STRING:
|
||||
sexp_write_char('"', out);
|
||||
sexp_write_char(ctx, '"', out);
|
||||
i = sexp_string_length(obj);
|
||||
str = sexp_string_data(obj);
|
||||
for ( ; i>0; str++, i--) {
|
||||
switch (str[0]) {
|
||||
case '\\': sexp_write_string("\\\\", out); break;
|
||||
case '"': sexp_write_string("\\\"", out); break;
|
||||
case '\n': sexp_write_string("\\n", out); break;
|
||||
case '\r': sexp_write_string("\\r", out); break;
|
||||
case '\t': sexp_write_string("\\t", out); break;
|
||||
default: sexp_write_char(str[0], out);
|
||||
case '\\': sexp_write_string(ctx, "\\\\", out); break;
|
||||
case '"': sexp_write_string(ctx, "\\\"", out); break;
|
||||
case '\n': sexp_write_string(ctx, "\\n", out); break;
|
||||
case '\r': sexp_write_string(ctx, "\\r", out); break;
|
||||
case '\t': sexp_write_string(ctx, "\\t", out); break;
|
||||
default: sexp_write_char(ctx, str[0], out);
|
||||
}
|
||||
}
|
||||
sexp_write_char('"', out);
|
||||
sexp_write_char(ctx, '"', out);
|
||||
break;
|
||||
case SEXP_SYMBOL:
|
||||
i = sexp_string_length(sexp_symbol_string(obj));
|
||||
str = sexp_string_data(sexp_symbol_string(obj));
|
||||
for ( ; i>0; str++, i--) {
|
||||
if ((str[0] == '\\') || is_separator(str[0]))
|
||||
sexp_write_char('\\', out);
|
||||
sexp_write_char(str[0], out);
|
||||
sexp_write_char(ctx, '\\', out);
|
||||
sexp_write_char(ctx, str[0], out);
|
||||
}
|
||||
break;
|
||||
}
|
||||
} 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
|
||||
} else if (sexp_flonump(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
|
||||
} else if (sexp_charp(obj)) {
|
||||
if (obj == sexp_make_character(' '))
|
||||
sexp_write_string("#\\space", out);
|
||||
sexp_write_string(ctx, "#\\space", out);
|
||||
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'))
|
||||
sexp_write_string("#\\return", out);
|
||||
sexp_write_string(ctx, "#\\return", out);
|
||||
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))
|
||||
&& (sexp_unbox_character(obj) < 127))
|
||||
sexp_printf(out, "#\\%c", sexp_unbox_character(obj));
|
||||
else
|
||||
sexp_printf(out, "#\\x%02d", sexp_unbox_character(obj));
|
||||
sexp_write_char(ctx, sexp_unbox_character(obj), out);
|
||||
else {
|
||||
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)) {
|
||||
|
||||
#if USE_HUFF_SYMS
|
||||
|
|
@ -849,7 +967,7 @@ void sexp_write (sexp obj, sexp out) {
|
|||
c = ((sexp_uint_t)obj)>>3;
|
||||
while (c) {
|
||||
#include "opt/sexp-unhuff.c"
|
||||
sexp_write_char(res, out);
|
||||
sexp_write_char(ctx, res, out);
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
|
@ -857,18 +975,18 @@ void sexp_write (sexp obj, sexp out) {
|
|||
} else {
|
||||
switch ((sexp_uint_t) obj) {
|
||||
case (sexp_uint_t) SEXP_NULL:
|
||||
sexp_write_string("()", out); break;
|
||||
sexp_write_string(ctx, "()", out); break;
|
||||
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:
|
||||
sexp_write_string("#f", out); break;
|
||||
sexp_write_string(ctx, "#f", out); break;
|
||||
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_VOID:
|
||||
sexp_write_string("#<undef>", out); break;
|
||||
sexp_write_string(ctx, "#<undef>", out); break;
|
||||
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;
|
||||
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 == '\\') {
|
||||
c = sexp_read_char(in);
|
||||
c = sexp_read_char(ctx, in);
|
||||
switch (c) {case 'n': c = '\n'; break; case 't': c = '\t'; break;}
|
||||
}
|
||||
if (c == EOF) {
|
||||
|
|
@ -892,7 +1010,7 @@ sexp sexp_read_string(sexp ctx, sexp in) {
|
|||
}
|
||||
buf[i++] = c;
|
||||
if (i >= size) { /* expand buffer w/ malloc(), later free() it */
|
||||
tmp = malloc(size*2);
|
||||
tmp = (char*) malloc(size*2);
|
||||
memcpy(tmp, buf, i);
|
||||
if (size != INIT_STRING_BUFFER_SIZE) free(buf);
|
||||
buf = tmp;
|
||||
|
|
@ -915,15 +1033,15 @@ sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp) {
|
|||
if (init != EOF)
|
||||
buf[i++] = init;
|
||||
|
||||
for (c = sexp_read_char(in); c != '"'; c = sexp_read_char(in)) {
|
||||
if (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(ctx, in);
|
||||
if (c == EOF || is_separator(c)) {
|
||||
sexp_push_char(c, in);
|
||||
sexp_push_char(ctx, c, in);
|
||||
break;
|
||||
}
|
||||
buf[i++] = c;
|
||||
if (i >= size) { /* expand buffer w/ malloc(), later free() it */
|
||||
tmp = malloc(size*2);
|
||||
tmp = (char*) malloc(size*2);
|
||||
memcpy(tmp, buf, i);
|
||||
if (size != INIT_STRING_BUFFER_SIZE) free(buf);
|
||||
buf = tmp;
|
||||
|
|
@ -941,9 +1059,11 @@ sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_sint_t whole) {
|
|||
sexp exponent;
|
||||
double res=0.0, scale=0.1, e=0.0;
|
||||
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;
|
||||
sexp_push_char(c, in);
|
||||
sexp_push_char(ctx, c, in);
|
||||
if (c=='e' || c=='E') {
|
||||
exponent = sexp_read_number(ctx, in, 10);
|
||||
if (sexp_exceptionp(exponent)) return exponent;
|
||||
|
|
@ -959,23 +1079,24 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) {
|
|||
sexp f;
|
||||
sexp_sint_t res = 0, negativep = 0, c;
|
||||
|
||||
c = sexp_read_char(in);
|
||||
c = sexp_read_char(ctx, in);
|
||||
if (c == '-')
|
||||
negativep = 1;
|
||||
else if (isdigit(c))
|
||||
res = digit_value(c);
|
||||
|
||||
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);
|
||||
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);
|
||||
|
||||
if (c=='.' || c=='e' || c=='E') {
|
||||
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!='.')
|
||||
sexp_push_char(c, in);
|
||||
sexp_push_char(ctx, c, in);
|
||||
f = sexp_read_float_tail(ctx, in, res);
|
||||
if (! sexp_flonump(f)) return 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;
|
||||
}
|
||||
} else {
|
||||
sexp_push_char(c, in);
|
||||
sexp_push_char(ctx, c, in);
|
||||
if ((c!=EOF) && ! is_separator(c))
|
||||
return sexp_read_error(ctx, "invalid numeric syntax",
|
||||
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);
|
||||
|
||||
scan_loop:
|
||||
switch (c1 = sexp_read_char(in)) {
|
||||
switch (c1 = sexp_read_char(ctx, in)) {
|
||||
case EOF:
|
||||
res = SEXP_EOF;
|
||||
break;
|
||||
case ';':
|
||||
sexp_port_line(in)++;
|
||||
while ((c1 = sexp_read_char(in)) != EOF)
|
||||
while ((c1 = sexp_read_char(ctx, in)) != EOF)
|
||||
if (c1 == '\n')
|
||||
break;
|
||||
/* ... FALLTHROUGH ... */
|
||||
|
|
@ -1035,11 +1156,11 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
|
|||
res = sexp_list2(ctx, the_quasiquote_symbol, res);
|
||||
break;
|
||||
case ',':
|
||||
if ((c1 = sexp_read_char(in)) == '@') {
|
||||
if ((c1 = sexp_read_char(ctx, in)) == '@') {
|
||||
res = sexp_read(ctx, in);
|
||||
res = sexp_list2(ctx, the_unquote_splicing_symbol, res);
|
||||
} else {
|
||||
sexp_push_char(c1, in);
|
||||
sexp_push_char(ctx, c1, in);
|
||||
res = sexp_read(ctx, in);
|
||||
res = sexp_list2(ctx, the_unquote_symbol, res);
|
||||
}
|
||||
|
|
@ -1087,7 +1208,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
|
|||
}
|
||||
break;
|
||||
case '#':
|
||||
switch (c1=sexp_read_char(in)) {
|
||||
switch (c1=sexp_read_char(ctx, in)) {
|
||||
case 'b':
|
||||
res = sexp_read_number(ctx, in, 2); break;
|
||||
case 'o':
|
||||
|
|
@ -1108,10 +1229,10 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
|
|||
break;
|
||||
case 'f':
|
||||
case 't':
|
||||
c2 = sexp_read_char(in);
|
||||
c2 = sexp_read_char(ctx, in);
|
||||
if (c2 == EOF || is_separator(c2)) {
|
||||
res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE);
|
||||
sexp_push_char(c2, in);
|
||||
sexp_push_char(ctx, c2, in);
|
||||
} else {
|
||||
res = sexp_read_error(ctx, "invalid syntax #%c%c",
|
||||
sexp_list2(ctx,
|
||||
|
|
@ -1129,7 +1250,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
|
|||
else
|
||||
goto scan_loop;
|
||||
case '\\':
|
||||
c1 = sexp_read_char(in);
|
||||
c1 = sexp_read_char(ctx, in);
|
||||
res = sexp_read_symbol(ctx, in, c1, 0);
|
||||
if (sexp_stringp(res)) {
|
||||
str = sexp_string_data(res);
|
||||
|
|
@ -1160,7 +1281,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
|
|||
}
|
||||
break;
|
||||
case '(':
|
||||
sexp_push_char(c1, in);
|
||||
sexp_push_char(ctx, c1, in);
|
||||
res = sexp_read(ctx, in);
|
||||
if (sexp_not(sexp_listp(ctx, res))) {
|
||||
if (! sexp_exceptionp(res)) {
|
||||
|
|
@ -1178,14 +1299,14 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
|
|||
}
|
||||
break;
|
||||
case '.':
|
||||
c1 = sexp_read_char(in);
|
||||
c1 = sexp_read_char(ctx, in);
|
||||
if (c1 == EOF || is_separator(c1)) {
|
||||
res = SEXP_RAWDOT;
|
||||
} else if (isdigit(c1)) {
|
||||
sexp_push_char(c1,in );
|
||||
sexp_push_char(ctx, c1, in);
|
||||
res = sexp_read_float_tail(ctx, in, 0);
|
||||
} else {
|
||||
sexp_push_char(c1, in);
|
||||
sexp_push_char(ctx, c1, in);
|
||||
res = sexp_read_symbol(ctx, in, '.', 1);
|
||||
}
|
||||
break;
|
||||
|
|
@ -1194,9 +1315,9 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
|
|||
break;
|
||||
case '+':
|
||||
case '-':
|
||||
c2 = sexp_read_char(in);
|
||||
c2 = sexp_read_char(ctx, in);
|
||||
if (c2 == '.' || isdigit(c2)) {
|
||||
sexp_push_char(c2, in);
|
||||
sexp_push_char(ctx, c2, in);
|
||||
res = sexp_read_number(ctx, in, 10);
|
||||
if ((c1 == '-') && ! sexp_exceptionp(res)) {
|
||||
#if USE_FLONUMS
|
||||
|
|
@ -1211,13 +1332,13 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
|
|||
res = sexp_fx_mul(res, -1);
|
||||
}
|
||||
} else {
|
||||
sexp_push_char(c2, in);
|
||||
sexp_push_char(ctx, c2, in);
|
||||
res = sexp_read_symbol(ctx, in, c1, 1);
|
||||
}
|
||||
break;
|
||||
case '0': case '1': case '2': case '3': case '4':
|
||||
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);
|
||||
break;
|
||||
default:
|
||||
|
|
@ -1238,7 +1359,6 @@ sexp sexp_read (sexp ctx, sexp in) {
|
|||
return res;
|
||||
}
|
||||
|
||||
#if USE_STRING_STREAMS
|
||||
sexp sexp_read_from_string(sexp ctx, char *str) {
|
||||
sexp res;
|
||||
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);
|
||||
return res;
|
||||
}
|
||||
#endif
|
||||
|
||||
void sexp_init() {
|
||||
int i;
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue