artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

core+mini-mes: Replace manual snippets by snarfed includes.

Browse source 
* 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
Show stats Download patch file Download diff file Expand all files Collapse all files

18
GNUmakefile
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 $@

30
build-aux/mes-snarf.scm
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
(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 "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
(format #f "scm_~a.string = 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 "scm_~a.string = cstring_to_list (fun_~a.name);\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 "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) (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)

4
guile/mes.mes
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

2
guile/mes.scm
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
View file

File diff suppressed because it is too large Load diff

1
module/language/c99/compiler.mes
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))))

26
module/mes/elf-util.mes
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 ((prefix (function-prefix function functions))) (let ((cache '()))
(if (not prefix) 0 (lambda (function label functions)
(let ((function-entry (car prefix))) (or (assoc-ref cache (cons function label))
(let loop ((text (cdr function-entry))) (let ((prefix (function-prefix function functions)))
(if (or (equal? (car text) label) (null? text)) 0 (if (not prefix) 0
(let* ((l/l (car text)) (let* ((function-entry (car prefix))
(t ((lambda/label->list '() '() 0 0 0) l/l)) (offset (let loop ((text (cdr function-entry)))
(n (length t))) (if (or (equal? (car text) label) (null? text)) 0
(+ (loop (cdr text)) n)))))))) (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) (define (globals->data globals)
(append-map (compose global:value cdr) globals)) (append-map (compose global:value cdr) globals))

2
module/mes/mes-0.mes
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;

26
reader.c
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;
}

942
scaffold/mini-mes.c
View file

File diff suppressed because it is too large Load diff