core+mini-mes: Replace manual snippets by snarfed includes.
* build-aux/mes-snarf.scm (symbol->source, function->header, function->source, function->environment): Add workarounds to avoid struct-copy initializers. * GNUmakefile (mini-mes): Snarf symbols and functions. * scaffold/mini-mes.c: Include mini-mes.h, mini-mes.symbols.h, mini-mes.symbols.i, mini-mes.i, mini-mes.environment.i. Add snarfable symbol/special definitions. (type_t): Prefix all types with `T', update users. (assert_defined, gc_push_frame, gc_peek_frame, gc_init_cells): Mark as internal. * mes.c (type_t): Prefix all types with `T', update users. * scaffold/mini-mes.c (eq_p, type_, car_, cdr_, list_of_char_equal_p, lookup_macro, write_byte): New functions (from mes.c). (assq): Add debugging, workaround.
This commit is contained in:
Jan Nieuwenhuizen
parent
b43380c8d8
commit
76f1a89cef
18
GNUmakefile
18
GNUmakefile
|
|
@ -36,7 +36,7 @@ mes.o: posix.c posix.h posix.i posix.environment.i
|
|||
mes.o: reader.c reader.h reader.i reader.environment.i
|
||||
|
||||
clean:
|
||||
rm -f mes mes.o *.environment.i *.symbols.i *.environment.h *.cat a.out
|
||||
rm -f mes *.o *.environment.i *.symbols.i *.environment.h *.cat a.out
|
||||
|
||||
distclean: clean
|
||||
rm -f .config.make
|
||||
|
|
@ -113,15 +113,15 @@ mescc-check: t-check
|
|||
chmod +x a.out
|
||||
./a.out
|
||||
|
||||
mini-mes: scaffold/mini-mes.c GNUmakefile
|
||||
rm -f $@
|
||||
gcc -nostdlib --std=gnu99 -m32 -g -o $@ '-DVERSION="0.4"' $<
|
||||
chmod +x $@
|
||||
%.h %.i %.environment.i %.symbols.i: scaffold/%.c build-aux/mes-snarf.scm
|
||||
build-aux/mes-snarf.scm $<
|
||||
|
||||
# mini-mes: doc/examples/mini-mes.c GNUmakefile
|
||||
# rm -f $@
|
||||
# gcc -nostdlib --std=gnu99 -g -o $@ '-DVERSION="0.4"' $<
|
||||
# chmod +x $@
|
||||
mini-mes: mini-mes.h mini-mes.i mini-mes.environment.i mini-mes.symbols.i
|
||||
mini-mes: GNUmakefile
|
||||
mini-mes: doc/examples/mini-mes.c
|
||||
rm -f $@
|
||||
gcc -nostdlib --std=gnu99 -m32 -g -I. -o $@ '-DVERSION="0.4"' $<
|
||||
chmod +x $@
|
||||
|
||||
cons-mes: scaffold/cons-mes.c GNUmakefile
|
||||
rm -f $@
|
||||
|
|
|
|||
|
|
@ -84,7 +84,9 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
|
|||
|
||||
(define (symbol->names s i)
|
||||
(string-append
|
||||
(format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.name);\n" s s)))
|
||||
(if GCC?
|
||||
(format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.name);\n" s s)
|
||||
(format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.car);\n" s s))))
|
||||
|
||||
(define (function->header f i)
|
||||
(let* ((arity (or (assoc-ref (.annotation f) 'arity)
|
||||
|
|
@ -94,28 +96,36 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
|
|||
(string-append
|
||||
(format #f "SCM ~a (~a);\n" (.name f) (.formals f))
|
||||
(if GCC?
|
||||
(format #f "function_t fun_~a = {.function~a=&~a, .arity=~a, .name=~s};\n" (.name f) arity (.name f) n (function-scm-name f))
|
||||
(format #f "function_t fun_~a = {&~a, ~a, ~s};\n" (.name f) (.name f) n (function-scm-name f)))
|
||||
(format #f "struct function fun_~a = {.function~a=&~a, .arity=~a, .name=~s};\n" (.name f) arity (.name f) n (function-scm-name f))
|
||||
(format #f "struct function fun_~a = {&~a, ~a, ~s};\n" (.name f) (.name f) n (function-scm-name f)))
|
||||
(if GCC?
|
||||
(format #f "scm ~a = {FUNCTION, .name=0, .function=0};\n" (function-builtin-name f))
|
||||
(format #f "scm ~a = {FUNCTION, 0, 0};\n" (function-builtin-name f)))
|
||||
(format #f "struct scm ~a = {TFUNCTION, .name=0, .function=0};\n" (function-builtin-name f))
|
||||
(format #f "struct scm ~a = {TFUNCTION, 0, 0};\n" (function-builtin-name f)))
|
||||
(format #f "SCM cell_~a;\n\n" (.name f)))))
|
||||
|
||||
(define (function->source f i)
|
||||
(string-append
|
||||
(format #f "~a.function = g_function;\n" (function-builtin-name f))
|
||||
(if GCC?
|
||||
(format #f "~a.function = g_function;\n" (function-builtin-name f))
|
||||
(format #f "~a.cdr = g_function;\n" (function-builtin-name f)))
|
||||
(format #f "g_functions[g_function++] = fun_~a;\n" (.name f))
|
||||
(format #f "cell_~a = g_free++;\n" (.name f))
|
||||
(format #f "g_cells[cell_~a] = ~a;\n\n" (.name f) (function-builtin-name f))))
|
||||
|
||||
(define (function->environment f i)
|
||||
(string-append
|
||||
(format #f "scm_~a.string = cstring_to_list (fun_~a.name);\n" (.name f) (.name f))
|
||||
(format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (.name f) (.name f))
|
||||
(format #f "a = acons (make_symbol (scm_~a.string), ~a, a);\n\n" (.name f) (function-cell-name f))))
|
||||
(if GCC?
|
||||
(format #f "scm_~a.string = cstring_to_list (fun_~a.name);\n" (.name f) (.name f))
|
||||
(format #f "scm_~a.car = cstring_to_list (fun_~a.name);\n" (.name f) (.name f)))
|
||||
(if GCC?
|
||||
(format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (.name f) (.name f))
|
||||
(format #f "g_cells[cell_~a].car = MAKE_STRING (scm_~a.car);\n" (.name f) (.name f)))
|
||||
(if GCC?
|
||||
(format #f "a = acons (make_symbol (scm_~a.string), ~a, a);\n\n" (.name f) (function-cell-name f))
|
||||
(format #f "a = acons (make_symbol (scm_~a.car), ~a, a);\n\n" (.name f) (function-cell-name f)))))
|
||||
|
||||
(define (snarf-symbols string)
|
||||
(let* ((matches (list-matches "\nscm scm_([a-z_0-9]+) = [{](SPECIAL|SYMBOL)," string)))
|
||||
(let* ((matches (list-matches "\nstruct scm scm_([a-z_0-9]+) = [{](TSPECIAL|TSYMBOL)," string)))
|
||||
(map (cut match:substring <> 1) matches)))
|
||||
|
||||
(define (snarf-functions string)
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@
|
|||
((eq? (caar a) x) (car a))
|
||||
(#t (assq x (cdr a)))))
|
||||
|
||||
(define (assq-ref-cache x a)
|
||||
(define (assq-ref-env x a)
|
||||
(let ((e (assq x a)))
|
||||
(if (eq? e #f) '*undefined* (cdr e))))
|
||||
|
||||
|
|
@ -92,7 +92,7 @@
|
|||
(define (eval-expand e a)
|
||||
(cond
|
||||
((eq? e '*undefined*) e)
|
||||
((symbol? e) (assq-ref-cache e a))
|
||||
((symbol? e) (assq-ref-env e a))
|
||||
((atom? e) e)
|
||||
((atom? (car e))
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -179,7 +179,7 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
|
|||
(evcon . evcon)
|
||||
(pairlis . pairlis)
|
||||
(assq . assq)
|
||||
(assq-ref-cache . assq-ref-cache)
|
||||
(assq-ref-env . assq-ref-env)
|
||||
|
||||
(eval-env . eval-env)
|
||||
(apply-env . apply-env)
|
||||
|
|
|
|||
64
lib.c
64
lib.c
|
|
@ -18,11 +18,6 @@
|
|||
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||
*/
|
||||
|
||||
SCM caar (SCM x) {return car (car (x));}
|
||||
SCM cadr (SCM x) {return car (cdr (x));}
|
||||
SCM cdar (SCM x) {return cdr (car (x));}
|
||||
SCM cddr (SCM x) {return cdr (cdr (x));}
|
||||
|
||||
SCM
|
||||
xassq (SCM x, SCM a) ///for speed in core only
|
||||
{
|
||||
|
|
@ -37,7 +32,7 @@ length (SCM x)
|
|||
while (x != cell_nil)
|
||||
{
|
||||
n++;
|
||||
if (TYPE (x) != PAIR) return MAKE_NUMBER (-1);
|
||||
if (TYPE (x) != TPAIR) return MAKE_NUMBER (-1);
|
||||
x = cdr (x);
|
||||
}
|
||||
return MAKE_NUMBER (n);
|
||||
|
|
@ -52,30 +47,39 @@ list (SCM x) ///((arity . n))
|
|||
SCM
|
||||
exit_ (SCM x) ///((name . "exit"))
|
||||
{
|
||||
assert (TYPE (x) == NUMBER);
|
||||
assert (TYPE (x) == TNUMBER);
|
||||
exit (VALUE (x));
|
||||
}
|
||||
|
||||
char const*
|
||||
string_to_cstring (SCM s)
|
||||
SCM
|
||||
append (SCM x) ///((arity . n))
|
||||
{
|
||||
static char buf[1024];
|
||||
char *p = buf;
|
||||
s = STRING (s);
|
||||
while (s != cell_nil)
|
||||
{
|
||||
*p++ = VALUE (car (s));
|
||||
s = cdr (s);
|
||||
}
|
||||
*p = 0;
|
||||
return buf;
|
||||
if (x == cell_nil) return cell_nil;
|
||||
if (cdr (x) == cell_nil) return car (x);
|
||||
return append2 (car (x), append (cdr (x)));
|
||||
}
|
||||
|
||||
//MINI_MES
|
||||
// char const*
|
||||
// string_to_cstring (SCM s)
|
||||
// {
|
||||
// static char buf[1024];
|
||||
// char *p = buf;
|
||||
// s = STRING (s);
|
||||
// while (s != cell_nil)
|
||||
// {
|
||||
// *p++ = VALUE (car (s));
|
||||
// s = cdr (s);
|
||||
// }
|
||||
// *p = 0;
|
||||
// return buf;
|
||||
// }
|
||||
|
||||
SCM
|
||||
error (SCM key, SCM x)
|
||||
{
|
||||
SCM throw;
|
||||
if ((throw = assq_ref_cache (cell_symbol_throw, r0)) != cell_undefined)
|
||||
if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
|
||||
return apply (throw, cons (key, cons (x, cell_nil)), r0);
|
||||
assert (!"error");
|
||||
}
|
||||
|
|
@ -90,7 +94,7 @@ assert_defined (SCM x, SCM e)
|
|||
SCM
|
||||
check_formals (SCM f, SCM formals, SCM args)
|
||||
{
|
||||
int flen = (TYPE (formals) == NUMBER) ? VALUE (formals) : VALUE (length (formals));
|
||||
int flen = (TYPE (formals) == TNUMBER) ? VALUE (formals) : VALUE (length (formals));
|
||||
int alen = VALUE (length (args));
|
||||
if (alen != flen && alen != -1 && flen != -1)
|
||||
{
|
||||
|
|
@ -110,9 +114,9 @@ check_apply (SCM f, SCM e)
|
|||
if (f == cell_nil) type = "nil";
|
||||
if (f == cell_unspecified) type = "*unspecified*";
|
||||
if (f == cell_undefined) type = "*undefined*";
|
||||
if (TYPE (f) == CHAR) type = "char";
|
||||
if (TYPE (f) == NUMBER) type = "number";
|
||||
if (TYPE (f) == STRING) type = "string";
|
||||
if (TYPE (f) == TCHAR) type = "char";
|
||||
if (TYPE (f) == TNUMBER) type = "number";
|
||||
if (TYPE (f) == TSTRING) type = "string";
|
||||
|
||||
if (type)
|
||||
{
|
||||
|
|
@ -174,19 +178,19 @@ dump ()
|
|||
CAR (9) = 0x2d2d2d2d;
|
||||
CDR (9) = 0x3e3e3e3e;
|
||||
|
||||
TYPE (10) = PAIR;
|
||||
TYPE (10) = TPAIR;
|
||||
CAR (10) = 11;
|
||||
CDR (10) = 12;
|
||||
|
||||
TYPE (11) = CHAR;
|
||||
TYPE (11) = TCHAR;
|
||||
CAR (11) = 0x58585858;
|
||||
CDR (11) = 65;
|
||||
|
||||
TYPE (12) = PAIR;
|
||||
TYPE (12) = TPAIR;
|
||||
CAR (12) = 13;
|
||||
CDR (12) = 1;
|
||||
|
||||
TYPE (13) = CHAR;
|
||||
TYPE (13) = TCHAR;
|
||||
CAR (11) = 0x58585858;
|
||||
CDR (13) = 66;
|
||||
|
||||
|
|
@ -196,7 +200,7 @@ dump ()
|
|||
|
||||
g_free = 15;
|
||||
}
|
||||
for (int i=0; i<g_free * sizeof(scm); i++)
|
||||
for (int i=0; i<g_free * sizeof(struct scm); i++)
|
||||
fputc (*p++, stdout);
|
||||
return 0;
|
||||
}
|
||||
|
|
@ -240,7 +244,7 @@ bload_env (SCM a) ///((internal))
|
|||
*p++ = c;
|
||||
c = getchar ();
|
||||
}
|
||||
g_free = (p-(char*)g_cells) / sizeof (scm);
|
||||
g_free = (p-(char*)g_cells) / sizeof (struct scm);
|
||||
gc_peek_frame ();
|
||||
g_symbols = r1;
|
||||
g_stdin = stdin;
|
||||
|
|
|
|||
28
math.c
28
math.c
|
|
@ -24,7 +24,7 @@ greater_p (SCM x) ///((name . ">") (arity . n))
|
|||
int n = INT_MAX;
|
||||
while (x != cell_nil)
|
||||
{
|
||||
assert (TYPE (car (x)) == NUMBER);
|
||||
assert (TYPE (car (x)) == TNUMBER);
|
||||
if (VALUE (car (x)) >= n) return cell_f;
|
||||
n = VALUE (car (x));
|
||||
x = cdr (x);
|
||||
|
|
@ -38,7 +38,7 @@ less_p (SCM x) ///((name . "<") (arity . n))
|
|||
int n = INT_MIN;
|
||||
while (x != cell_nil)
|
||||
{
|
||||
assert (TYPE (car (x)) == NUMBER);
|
||||
assert (TYPE (car (x)) == TNUMBER);
|
||||
if (VALUE (car (x)) <= n) return cell_f;
|
||||
n = VALUE (car (x));
|
||||
x = cdr (x);
|
||||
|
|
@ -50,7 +50,7 @@ SCM
|
|||
is_p (SCM x) ///((name . "=") (arity . n))
|
||||
{
|
||||
if (x == cell_nil) return cell_t;
|
||||
assert (TYPE (car (x)) == NUMBER);
|
||||
assert (TYPE (car (x)) == TNUMBER);
|
||||
int n = VALUE (car (x));
|
||||
x = cdr (x);
|
||||
while (x != cell_nil)
|
||||
|
|
@ -65,14 +65,14 @@ SCM
|
|||
minus (SCM x) ///((name . "-") (arity . n))
|
||||
{
|
||||
SCM a = car (x);
|
||||
assert (TYPE (a) == NUMBER);
|
||||
assert (TYPE (a) == TNUMBER);
|
||||
int n = VALUE (a);
|
||||
x = cdr (x);
|
||||
if (x == cell_nil)
|
||||
n = -n;
|
||||
while (x != cell_nil)
|
||||
{
|
||||
assert (TYPE (car (x)) == NUMBER);
|
||||
assert (TYPE (car (x)) == TNUMBER);
|
||||
n -= VALUE (car (x));
|
||||
x = cdr (x);
|
||||
}
|
||||
|
|
@ -85,7 +85,7 @@ plus (SCM x) ///((name . "+") (arity . n))
|
|||
int n = 0;
|
||||
while (x != cell_nil)
|
||||
{
|
||||
assert (TYPE (car (x)) == NUMBER);
|
||||
assert (TYPE (car (x)) == TNUMBER);
|
||||
n += VALUE (car (x));
|
||||
x = cdr (x);
|
||||
}
|
||||
|
|
@ -97,13 +97,13 @@ divide (SCM x) ///((name . "/") (arity . n))
|
|||
{
|
||||
int n = 1;
|
||||
if (x != cell_nil) {
|
||||
assert (TYPE (car (x)) == NUMBER);
|
||||
assert (TYPE (car (x)) == TNUMBER);
|
||||
n = VALUE (car (x));
|
||||
x = cdr (x);
|
||||
}
|
||||
while (x != cell_nil)
|
||||
{
|
||||
assert (TYPE (car (x)) == NUMBER);
|
||||
assert (TYPE (car (x)) == TNUMBER);
|
||||
n /= VALUE (car (x));
|
||||
x = cdr (x);
|
||||
}
|
||||
|
|
@ -113,8 +113,8 @@ divide (SCM x) ///((name . "/") (arity . n))
|
|||
SCM
|
||||
modulo (SCM a, SCM b)
|
||||
{
|
||||
assert (TYPE (a) == NUMBER);
|
||||
assert (TYPE (b) == NUMBER);
|
||||
assert (TYPE (a) == TNUMBER);
|
||||
assert (TYPE (b) == TNUMBER);
|
||||
int x = VALUE (a);
|
||||
while (x < 0) x += VALUE (b);
|
||||
return MAKE_NUMBER (x % VALUE (b));
|
||||
|
|
@ -126,7 +126,7 @@ multiply (SCM x) ///((name . "*") (arity . n))
|
|||
int n = 1;
|
||||
while (x != cell_nil)
|
||||
{
|
||||
assert (TYPE (car (x)) == NUMBER);
|
||||
assert (TYPE (car (x)) == TNUMBER);
|
||||
n *= VALUE (car (x));
|
||||
x = cdr (x);
|
||||
}
|
||||
|
|
@ -139,7 +139,7 @@ logior (SCM x) ///((arity . n))
|
|||
int n = 0;
|
||||
while (x != cell_nil)
|
||||
{
|
||||
assert (TYPE (car (x)) == NUMBER);
|
||||
assert (TYPE (car (x)) == TNUMBER);
|
||||
n |= VALUE (car (x));
|
||||
x = cdr (x);
|
||||
}
|
||||
|
|
@ -149,8 +149,8 @@ logior (SCM x) ///((arity . n))
|
|||
SCM
|
||||
ash (SCM n, SCM count)
|
||||
{
|
||||
assert (TYPE (n) == NUMBER);
|
||||
assert (TYPE (count) == NUMBER);
|
||||
assert (TYPE (n) == TNUMBER);
|
||||
assert (TYPE (count) == TNUMBER);
|
||||
int cn = VALUE (n);
|
||||
int ccount = VALUE (count);
|
||||
return MAKE_NUMBER ((ccount < 0) ? cn >> -ccount : cn << ccount);
|
||||
|
|
|
|||
|
|
@ -2041,6 +2041,7 @@
|
|||
(define (initzer->data info functions globals ta t d o)
|
||||
(pmatch o
|
||||
((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
|
||||
((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
|
||||
((initzer (ref-to (p-expr (ident ,name))))
|
||||
;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions))))
|
||||
(int->bv32 (+ ta (function-offset name functions))))
|
||||
|
|
|
|||
|
|
@ -93,16 +93,22 @@
|
|||
(if (and prefix (or (equal? name "exit") (> offset 0))) (set! cache (assoc-set! cache name offset)))
|
||||
offset)))))
|
||||
|
||||
(define (label-offset function label functions)
|
||||
(let ((prefix (function-prefix function functions)))
|
||||
(if (not prefix) 0
|
||||
(let ((function-entry (car prefix)))
|
||||
(let loop ((text (cdr function-entry)))
|
||||
(if (or (equal? (car text) label) (null? text)) 0
|
||||
(let* ((l/l (car text))
|
||||
(t ((lambda/label->list '() '() 0 0 0) l/l))
|
||||
(n (length t)))
|
||||
(+ (loop (cdr text)) n))))))))
|
||||
(define label-offset
|
||||
(let ((cache '()))
|
||||
(lambda (function label functions)
|
||||
(or (assoc-ref cache (cons function label))
|
||||
(let ((prefix (function-prefix function functions)))
|
||||
(if (not prefix) 0
|
||||
(let* ((function-entry (car prefix))
|
||||
(offset (let loop ((text (cdr function-entry)))
|
||||
(if (or (equal? (car text) label) (null? text)) 0
|
||||
(let* ((l/l (car text))
|
||||
(t ((lambda/label->list '() '() 0 0 0) l/l))
|
||||
(n (length t)))
|
||||
(+ (loop (cdr text)) n))))))
|
||||
(when (> offset 0)
|
||||
(set! cache (assoc-set! cache (cons function label) offset)))
|
||||
offset)))))))
|
||||
|
||||
(define (globals->data globals)
|
||||
(append-map (compose global:value cdr) globals))
|
||||
|
|
|
|||
|
|
@ -104,7 +104,7 @@
|
|||
|
||||
(define (eval-expand e a)
|
||||
(cond
|
||||
((symbol? e) (assq-ref-cache e a))
|
||||
((symbol? e) (assq-ref-env e a))
|
||||
((atom? e) e)
|
||||
((atom? (car e))
|
||||
(cond
|
||||
|
|
|
|||
65
posix.c
65
posix.c
|
|
@ -20,6 +20,39 @@
|
|||
|
||||
#include <fcntl.h>
|
||||
|
||||
//MINI_MES
|
||||
// SCM
|
||||
// write_byte (SCM x) ///((arity . n))
|
||||
// {
|
||||
// SCM c = car (x);
|
||||
// SCM p = cdr (x);
|
||||
// int fd = 1;
|
||||
// if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p));
|
||||
// FILE *f = fd == 1 ? stdout : stderr;
|
||||
// assert (TYPE (c) == TNUMBER || TYPE (c) == TCHAR);
|
||||
// fputc (VALUE (c), f);
|
||||
// return c;
|
||||
// }
|
||||
|
||||
char const* string_to_cstring (SCM);
|
||||
|
||||
// SCM
|
||||
// stderr_ (SCM x)
|
||||
// {
|
||||
// SCM write;
|
||||
// if (TYPE (x) == TSTRING)
|
||||
// fprintf (stderr, string_to_cstring (x));
|
||||
// else if ((write = assq_ref_env (cell_symbol_write, r0)) != cell_undefined)
|
||||
// apply (assq_ref_env (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0);
|
||||
// else if (TYPE (x) == TSPECIAL || TYPE (x) == TSTRING || TYPE (x) == TSYMBOL)
|
||||
// fprintf (stderr, string_to_cstring (x));
|
||||
// else if (TYPE (x) == TNUMBER)
|
||||
// fprintf (stderr, "%d", VALUE (x));
|
||||
// else
|
||||
// fprintf (stderr, "display: undefined\n");
|
||||
// return cell_unspecified;
|
||||
// }
|
||||
|
||||
int
|
||||
getchar ()
|
||||
{
|
||||
|
|
@ -66,41 +99,11 @@ unread_byte (SCM i)
|
|||
return i;
|
||||
}
|
||||
|
||||
SCM
|
||||
write_byte (SCM x) ///((arity . n))
|
||||
{
|
||||
SCM c = car (x);
|
||||
SCM p = cdr (x);
|
||||
int fd = 1;
|
||||
if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = VALUE (car (p));
|
||||
FILE *f = fd == 1 ? stdout : stderr;
|
||||
assert (TYPE (c) == NUMBER || TYPE (c) == CHAR);
|
||||
fputc (VALUE (c), f);
|
||||
return c;
|
||||
}
|
||||
|
||||
SCM
|
||||
stderr_ (SCM x)
|
||||
{
|
||||
SCM write;
|
||||
if (TYPE (x) == STRING)
|
||||
fprintf (stderr, string_to_cstring (x));
|
||||
else if ((write = assq_ref_cache (cell_symbol_write, r0)) != cell_undefined)
|
||||
apply (assq_ref_cache (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0);
|
||||
else if (TYPE (x) == SPECIAL || TYPE (x) == STRING || TYPE (x) == SYMBOL)
|
||||
fprintf (stderr, string_to_cstring (x));
|
||||
else if (TYPE (x) == NUMBER)
|
||||
fprintf (stderr, "%d", VALUE (x));
|
||||
else
|
||||
fprintf (stderr, "display: undefined\n");
|
||||
return cell_unspecified;
|
||||
}
|
||||
|
||||
SCM
|
||||
force_output (SCM p) ///((arity . n))
|
||||
{
|
||||
int fd = 1;
|
||||
if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = VALUE (car (p));
|
||||
if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p));
|
||||
FILE *f = fd == 1 ? stdout : stderr;
|
||||
fflush (f);
|
||||
return cell_unspecified;
|
||||
|
|
|
|||
26
reader.c
26
reader.c
|
|
@ -30,7 +30,7 @@ SCM
|
|||
read_input_file_env (SCM a)
|
||||
{
|
||||
r0 = a;
|
||||
if (assq_ref_cache (cell_symbol_read_input_file, r0) != cell_undefined)
|
||||
if (assq_ref_env (cell_symbol_read_input_file, r0) != cell_undefined)
|
||||
return apply (cell_symbol_read_input_file, cell_nil, r0);
|
||||
return read_input_file_env_ (read_env (r0), r0);
|
||||
}
|
||||
|
|
@ -108,27 +108,3 @@ lookup_ (SCM s, SCM a)
|
|||
SCM x = lookup_symbol_ (s);
|
||||
return x ? x : make_symbol_ (s);
|
||||
}
|
||||
|
||||
SCM
|
||||
list_of_char_equal_p (SCM a, SCM b)
|
||||
{
|
||||
while (a != cell_nil && b != cell_nil && VALUE (car (a)) == VALUE (car (b))) {
|
||||
assert (TYPE (car (a)) == CHAR);
|
||||
assert (TYPE (car (b)) == CHAR);
|
||||
a = cdr (a);
|
||||
b = cdr (b);
|
||||
}
|
||||
return (a == cell_nil && b == cell_nil) ? cell_t : cell_f;
|
||||
}
|
||||
|
||||
SCM
|
||||
lookup_symbol_ (SCM s)
|
||||
{
|
||||
SCM x = g_symbols;
|
||||
while (x) {
|
||||
if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break;
|
||||
x = cdr (x);
|
||||
}
|
||||
if (x) x = car (x);
|
||||
return x;
|
||||
}
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
Loading…
Reference in a new issue