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:
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
|
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 $@
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
64
lib.c
|
@ -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
28
math.c
|
@ -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);
|
||||||
|
|
|
@ -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))))
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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
65
posix.c
|
@ -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
26
reader.c
|
@ -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
Loading…
Reference in a new issue