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 2017-03-10 20:56:18 +01:00
parent b43380c8d8
commit 76f1a89cef
13 changed files with 1003 additions and 918 deletions

View file

@ -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 mes.o: reader.c reader.h reader.i reader.environment.i
clean: 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 distclean: clean
rm -f .config.make rm -f .config.make
@ -113,15 +113,15 @@ mescc-check: t-check
chmod +x a.out chmod +x a.out
./a.out ./a.out
mini-mes: scaffold/mini-mes.c GNUmakefile %.h %.i %.environment.i %.symbols.i: scaffold/%.c build-aux/mes-snarf.scm
rm -f $@ build-aux/mes-snarf.scm $<
gcc -nostdlib --std=gnu99 -m32 -g -o $@ '-DVERSION="0.4"' $<
chmod +x $@
# mini-mes: doc/examples/mini-mes.c GNUmakefile mini-mes: mini-mes.h mini-mes.i mini-mes.environment.i mini-mes.symbols.i
# rm -f $@ mini-mes: GNUmakefile
# gcc -nostdlib --std=gnu99 -g -o $@ '-DVERSION="0.4"' $< mini-mes: doc/examples/mini-mes.c
# chmod +x $@ rm -f $@
gcc -nostdlib --std=gnu99 -m32 -g -I. -o $@ '-DVERSION="0.4"' $<
chmod +x $@
cons-mes: scaffold/cons-mes.c GNUmakefile cons-mes: scaffold/cons-mes.c GNUmakefile
rm -f $@ rm -f $@

View file

@ -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) (define (symbol->names s i)
(string-append (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) (define (function->header f i)
(let* ((arity (or (assoc-ref (.annotation f) 'arity) (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 (string-append
(format #f "SCM ~a (~a);\n" (.name f) (.formals f)) (format #f "SCM ~a (~a);\n" (.name f) (.formals f))
(if GCC? (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 "struct function 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 = {&~a, ~a, ~s};\n" (.name f) (.name f) n (function-scm-name f)))
(if GCC? (if GCC?
(format #f "scm ~a = {FUNCTION, .name=0, .function=0};\n" (function-builtin-name f)) (format #f "struct scm ~a = {TFUNCTION, .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, 0, 0};\n" (function-builtin-name f)))
(format #f "SCM cell_~a;\n\n" (.name f))))) (format #f "SCM cell_~a;\n\n" (.name f)))))
(define (function->source f i) (define (function->source f i)
(string-append (string-append
(if GCC?
(format #f "~a.function = g_function;\n" (function-builtin-name f)) (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 "g_functions[g_function++] = fun_~a;\n" (.name f))
(format #f "cell_~a = g_free++;\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)))) (format #f "g_cells[cell_~a] = ~a;\n\n" (.name f) (function-builtin-name f))))
(define (function->environment f i) (define (function->environment f i)
(string-append (string-append
(if GCC?
(format #f "scm_~a.string = cstring_to_list (fun_~a.name);\n" (.name f) (.name f)) (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].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)))) (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) (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))) (map (cut match:substring <> 1) matches)))
(define (snarf-functions string) (define (snarf-functions string)

View file

@ -46,7 +46,7 @@
((eq? (caar a) x) (car a)) ((eq? (caar a) x) (car a))
(#t (assq x (cdr a))))) (#t (assq x (cdr a)))))
(define (assq-ref-cache x a) (define (assq-ref-env x a)
(let ((e (assq x a))) (let ((e (assq x a)))
(if (eq? e #f) '*undefined* (cdr e)))) (if (eq? e #f) '*undefined* (cdr e))))
@ -92,7 +92,7 @@
(define (eval-expand e a) (define (eval-expand e a)
(cond (cond
((eq? e '*undefined*) e) ((eq? e '*undefined*) e)
((symbol? e) (assq-ref-cache e a)) ((symbol? e) (assq-ref-env e a))
((atom? e) e) ((atom? e) e)
((atom? (car e)) ((atom? (car e))
(cond (cond

View file

@ -179,7 +179,7 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
(evcon . evcon) (evcon . evcon)
(pairlis . pairlis) (pairlis . pairlis)
(assq . assq) (assq . assq)
(assq-ref-cache . assq-ref-cache) (assq-ref-env . assq-ref-env)
(eval-env . eval-env) (eval-env . eval-env)
(apply-env . apply-env) (apply-env . apply-env)

64
lib.c
View file

@ -18,11 +18,6 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>. * 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 SCM
xassq (SCM x, SCM a) ///for speed in core only xassq (SCM x, SCM a) ///for speed in core only
{ {
@ -37,7 +32,7 @@ length (SCM x)
while (x != cell_nil) while (x != cell_nil)
{ {
n++; n++;
if (TYPE (x) != PAIR) return MAKE_NUMBER (-1); if (TYPE (x) != TPAIR) return MAKE_NUMBER (-1);
x = cdr (x); x = cdr (x);
} }
return MAKE_NUMBER (n); return MAKE_NUMBER (n);
@ -52,30 +47,39 @@ list (SCM x) ///((arity . n))
SCM SCM
exit_ (SCM x) ///((name . "exit")) exit_ (SCM x) ///((name . "exit"))
{ {
assert (TYPE (x) == NUMBER); assert (TYPE (x) == TNUMBER);
exit (VALUE (x)); exit (VALUE (x));
} }
char const* SCM
string_to_cstring (SCM s) append (SCM x) ///((arity . n))
{ {
static char buf[1024]; if (x == cell_nil) return cell_nil;
char *p = buf; if (cdr (x) == cell_nil) return car (x);
s = STRING (s); return append2 (car (x), append (cdr (x)));
while (s != cell_nil)
{
*p++ = VALUE (car (s));
s = cdr (s);
}
*p = 0;
return buf;
} }
//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 SCM
error (SCM key, SCM x) error (SCM key, SCM x)
{ {
SCM throw; 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); return apply (throw, cons (key, cons (x, cell_nil)), r0);
assert (!"error"); assert (!"error");
} }
@ -90,7 +94,7 @@ assert_defined (SCM x, SCM e)
SCM SCM
check_formals (SCM f, SCM formals, SCM args) 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)); int alen = VALUE (length (args));
if (alen != flen && alen != -1 && flen != -1) 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_nil) type = "nil";
if (f == cell_unspecified) type = "*unspecified*"; if (f == cell_unspecified) type = "*unspecified*";
if (f == cell_undefined) type = "*undefined*"; if (f == cell_undefined) type = "*undefined*";
if (TYPE (f) == CHAR) type = "char"; if (TYPE (f) == TCHAR) type = "char";
if (TYPE (f) == NUMBER) type = "number"; if (TYPE (f) == TNUMBER) type = "number";
if (TYPE (f) == STRING) type = "string"; if (TYPE (f) == TSTRING) type = "string";
if (type) if (type)
{ {
@ -174,19 +178,19 @@ dump ()
CAR (9) = 0x2d2d2d2d; CAR (9) = 0x2d2d2d2d;
CDR (9) = 0x3e3e3e3e; CDR (9) = 0x3e3e3e3e;
TYPE (10) = PAIR; TYPE (10) = TPAIR;
CAR (10) = 11; CAR (10) = 11;
CDR (10) = 12; CDR (10) = 12;
TYPE (11) = CHAR; TYPE (11) = TCHAR;
CAR (11) = 0x58585858; CAR (11) = 0x58585858;
CDR (11) = 65; CDR (11) = 65;
TYPE (12) = PAIR; TYPE (12) = TPAIR;
CAR (12) = 13; CAR (12) = 13;
CDR (12) = 1; CDR (12) = 1;
TYPE (13) = CHAR; TYPE (13) = TCHAR;
CAR (11) = 0x58585858; CAR (11) = 0x58585858;
CDR (13) = 66; CDR (13) = 66;
@ -196,7 +200,7 @@ dump ()
g_free = 15; 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); fputc (*p++, stdout);
return 0; return 0;
} }
@ -240,7 +244,7 @@ bload_env (SCM a) ///((internal))
*p++ = c; *p++ = c;
c = getchar (); c = getchar ();
} }
g_free = (p-(char*)g_cells) / sizeof (scm); g_free = (p-(char*)g_cells) / sizeof (struct scm);
gc_peek_frame (); gc_peek_frame ();
g_symbols = r1; g_symbols = r1;
g_stdin = stdin; g_stdin = stdin;

28
math.c
View file

@ -24,7 +24,7 @@ greater_p (SCM x) ///((name . ">") (arity . n))
int n = INT_MAX; int n = INT_MAX;
while (x != cell_nil) while (x != cell_nil)
{ {
assert (TYPE (car (x)) == NUMBER); assert (TYPE (car (x)) == TNUMBER);
if (VALUE (car (x)) >= n) return cell_f; if (VALUE (car (x)) >= n) return cell_f;
n = VALUE (car (x)); n = VALUE (car (x));
x = cdr (x); x = cdr (x);
@ -38,7 +38,7 @@ less_p (SCM x) ///((name . "<") (arity . n))
int n = INT_MIN; int n = INT_MIN;
while (x != cell_nil) while (x != cell_nil)
{ {
assert (TYPE (car (x)) == NUMBER); assert (TYPE (car (x)) == TNUMBER);
if (VALUE (car (x)) <= n) return cell_f; if (VALUE (car (x)) <= n) return cell_f;
n = VALUE (car (x)); n = VALUE (car (x));
x = cdr (x); x = cdr (x);
@ -50,7 +50,7 @@ SCM
is_p (SCM x) ///((name . "=") (arity . n)) is_p (SCM x) ///((name . "=") (arity . n))
{ {
if (x == cell_nil) return cell_t; if (x == cell_nil) return cell_t;
assert (TYPE (car (x)) == NUMBER); assert (TYPE (car (x)) == TNUMBER);
int n = VALUE (car (x)); int n = VALUE (car (x));
x = cdr (x); x = cdr (x);
while (x != cell_nil) while (x != cell_nil)
@ -65,14 +65,14 @@ SCM
minus (SCM x) ///((name . "-") (arity . n)) minus (SCM x) ///((name . "-") (arity . n))
{ {
SCM a = car (x); SCM a = car (x);
assert (TYPE (a) == NUMBER); assert (TYPE (a) == TNUMBER);
int n = VALUE (a); int n = VALUE (a);
x = cdr (x); x = cdr (x);
if (x == cell_nil) if (x == cell_nil)
n = -n; n = -n;
while (x != cell_nil) while (x != cell_nil)
{ {
assert (TYPE (car (x)) == NUMBER); assert (TYPE (car (x)) == TNUMBER);
n -= VALUE (car (x)); n -= VALUE (car (x));
x = cdr (x); x = cdr (x);
} }
@ -85,7 +85,7 @@ plus (SCM x) ///((name . "+") (arity . n))
int n = 0; int n = 0;
while (x != cell_nil) while (x != cell_nil)
{ {
assert (TYPE (car (x)) == NUMBER); assert (TYPE (car (x)) == TNUMBER);
n += VALUE (car (x)); n += VALUE (car (x));
x = cdr (x); x = cdr (x);
} }
@ -97,13 +97,13 @@ divide (SCM x) ///((name . "/") (arity . n))
{ {
int n = 1; int n = 1;
if (x != cell_nil) { if (x != cell_nil) {
assert (TYPE (car (x)) == NUMBER); assert (TYPE (car (x)) == TNUMBER);
n = VALUE (car (x)); n = VALUE (car (x));
x = cdr (x); x = cdr (x);
} }
while (x != cell_nil) while (x != cell_nil)
{ {
assert (TYPE (car (x)) == NUMBER); assert (TYPE (car (x)) == TNUMBER);
n /= VALUE (car (x)); n /= VALUE (car (x));
x = cdr (x); x = cdr (x);
} }
@ -113,8 +113,8 @@ divide (SCM x) ///((name . "/") (arity . n))
SCM SCM
modulo (SCM a, SCM b) modulo (SCM a, SCM b)
{ {
assert (TYPE (a) == NUMBER); assert (TYPE (a) == TNUMBER);
assert (TYPE (b) == NUMBER); assert (TYPE (b) == TNUMBER);
int x = VALUE (a); int x = VALUE (a);
while (x < 0) x += VALUE (b); while (x < 0) x += VALUE (b);
return MAKE_NUMBER (x % VALUE (b)); return MAKE_NUMBER (x % VALUE (b));
@ -126,7 +126,7 @@ multiply (SCM x) ///((name . "*") (arity . n))
int n = 1; int n = 1;
while (x != cell_nil) while (x != cell_nil)
{ {
assert (TYPE (car (x)) == NUMBER); assert (TYPE (car (x)) == TNUMBER);
n *= VALUE (car (x)); n *= VALUE (car (x));
x = cdr (x); x = cdr (x);
} }
@ -139,7 +139,7 @@ logior (SCM x) ///((arity . n))
int n = 0; int n = 0;
while (x != cell_nil) while (x != cell_nil)
{ {
assert (TYPE (car (x)) == NUMBER); assert (TYPE (car (x)) == TNUMBER);
n |= VALUE (car (x)); n |= VALUE (car (x));
x = cdr (x); x = cdr (x);
} }
@ -149,8 +149,8 @@ logior (SCM x) ///((arity . n))
SCM SCM
ash (SCM n, SCM count) ash (SCM n, SCM count)
{ {
assert (TYPE (n) == NUMBER); assert (TYPE (n) == TNUMBER);
assert (TYPE (count) == NUMBER); assert (TYPE (count) == TNUMBER);
int cn = VALUE (n); int cn = VALUE (n);
int ccount = VALUE (count); int ccount = VALUE (count);
return MAKE_NUMBER ((ccount < 0) ? cn >> -ccount : cn << ccount); return MAKE_NUMBER ((ccount < 0) ? cn >> -ccount : cn << ccount);

713
mes.c

File diff suppressed because it is too large Load diff

View file

@ -2041,6 +2041,7 @@
(define (initzer->data info functions globals ta t d o) (define (initzer->data info functions globals ta t d o)
(pmatch o (pmatch o
((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value))) ((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)))) ((initzer (ref-to (p-expr (ident ,name))))
;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions)))) ;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions))))
(int->bv32 (+ ta (function-offset name functions)))) (int->bv32 (+ ta (function-offset name functions))))

View file

@ -93,16 +93,22 @@
(if (and prefix (or (equal? name "exit") (> offset 0))) (set! cache (assoc-set! cache name offset))) (if (and prefix (or (equal? name "exit") (> offset 0))) (set! cache (assoc-set! cache name offset)))
offset))))) offset)))))
(define (label-offset function label functions) (define label-offset
(let ((cache '()))
(lambda (function label functions)
(or (assoc-ref cache (cons function label))
(let ((prefix (function-prefix function functions))) (let ((prefix (function-prefix function functions)))
(if (not prefix) 0 (if (not prefix) 0
(let ((function-entry (car prefix))) (let* ((function-entry (car prefix))
(let loop ((text (cdr function-entry))) (offset (let loop ((text (cdr function-entry)))
(if (or (equal? (car text) label) (null? text)) 0 (if (or (equal? (car text) label) (null? text)) 0
(let* ((l/l (car text)) (let* ((l/l (car text))
(t ((lambda/label->list '() '() 0 0 0) l/l)) (t ((lambda/label->list '() '() 0 0 0) l/l))
(n (length t))) (n (length t)))
(+ (loop (cdr text)) n)))))))) (+ (loop (cdr text)) n))))))
(when (> offset 0)
(set! cache (assoc-set! cache (cons function label) offset)))
offset)))))))
(define (globals->data globals) (define (globals->data globals)
(append-map (compose global:value cdr) globals)) (append-map (compose global:value cdr) globals))

View file

@ -104,7 +104,7 @@
(define (eval-expand e a) (define (eval-expand e a)
(cond (cond
((symbol? e) (assq-ref-cache e a)) ((symbol? e) (assq-ref-env e a))
((atom? e) e) ((atom? e) e)
((atom? (car e)) ((atom? (car e))
(cond (cond

65
posix.c
View file

@ -20,6 +20,39 @@
#include <fcntl.h> #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 int
getchar () getchar ()
{ {
@ -66,41 +99,11 @@ unread_byte (SCM i)
return 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 SCM
force_output (SCM p) ///((arity . n)) force_output (SCM p) ///((arity . n))
{ {
int fd = 1; 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; FILE *f = fd == 1 ? stdout : stderr;
fflush (f); fflush (f);
return cell_unspecified; return cell_unspecified;

View file

@ -30,7 +30,7 @@ SCM
read_input_file_env (SCM a) read_input_file_env (SCM a)
{ {
r0 = 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 apply (cell_symbol_read_input_file, cell_nil, r0);
return read_input_file_env_ (read_env (r0), r0); return read_input_file_env_ (read_env (r0), r0);
} }
@ -108,27 +108,3 @@ lookup_ (SCM s, SCM a)
SCM x = lookup_symbol_ (s); SCM x = lookup_symbol_ (s);
return x ? x : make_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