andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

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)
(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)

4
guile/mes.mes
View File

@ -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

2
guile/mes.scm
View File

@ -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
View File

@ -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
View File

@ -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);

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)
(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))))

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)))
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))

2
module/mes/mes-0.mes
View File

@ -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
View File

@ -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
View File

@ -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;
}

942
scaffold/mini-mes.c
View File

File diff suppressed because it is too large Load Diff