Generate C header and includes using snarfing.

* mes.c: Move specific renames and n-args to alist annotation.
* build-aux/mes-snarf.scm: New file.
* GNUmakefile (mes.environment.h): Use it.
  (mes.h): Remove.
  (clean): Update.
  (mes.o): New dependency rule.
* .gitignore: Update.
This commit is contained in:
Jan Nieuwenhuizen 2016-10-21 22:44:50 +02:00
parent 18aa0beaa9
commit 3e03a12a4d
4 changed files with 195 additions and 103 deletions

20
.gitignore vendored
View File

@ -1,18 +1,18 @@
*-
*.cat
*.environment.h
*.environment.i
*.go
*.o
*.symbols.i
*~
.#*
/.config.make
/a.out
/mes
/mes.h
/environment.i
/symbols.i
/*.cat
?
?.mes
/out
/.tarball-version
/ChangeLog
.#*
/a.out
/mes
/out
?
?.mes
\#*#

View File

@ -22,40 +22,16 @@ include make/install.make
all: mes
mes: mes.c mes.h
mes.o: mes.c mes.environment.h mes.symbols.i mes.environment.i
clean:
rm -f mes environment.i symbols.i mes.h *.cat a.out
rm -f mes mes.o mes.environment.i mes.symbols.i mes.environment.h *.cat a.out
distclean: clean
rm -f .config.make
mes.h: mes.c GNUmakefile
( echo '#if MES_C'; echo '#if MES_FULL' 1>&2;\
grep -E '^(scm [*])*[a-z0-9_]+ \(.*\)( {|$$)' $< | grep -Ev '\(.*(char |bool |int )' | sed -e 's,^scm [*],,' | sort |\
while read f; do\
fun=$$(echo $$f | sed -e 's,^scm [*],,' -e 's,{.*,,');\
name=$$(echo $$fun | sed -e 's,^scm [\*],,' | grep -o '^[^ ]*');\
builtin=scm_$$name\
scm_name=$$(echo $$name | sed -e 's,_to_,->,' -e 's,_p$$,?,' -e 's,_x$$,!,' -e 's,^builtin_,,' -re 's,(.*)_$$,c:\1,' | sed \
-e 's,^divide$$,/,'\
-e 's,^is?$$,=,'\
-e 's,^greater?$$,>,'\
-e 's,^less?$$,<,'\
-e 's,^minus$$,-,'\
-e 's,^multiply$$,*,'\
-e 's,^plus$$,+,'\
-e 's,_,-,g');\
args=$$(echo $$fun | grep -o 'scm [\*]' | wc -l);\
[ "$$(echo $$fun | fgrep -o ... )" = "..." ] && args=n;\
echo "scm *$$fun;";\
echo "scm $$builtin = {FUNCTION$$args, .name=\"$$scm_name\", .function$$args=&$$name};";\
echo "a = add_environment (a, \"$$scm_name\", &$$builtin);" 1>&2;\
done; echo '#endif'; echo '#endif' 1>&2) > $@ 2>environment.i
grep -oE '^scm ([a-z_0-9]+) = {(SCM|SYMBOL),' mes.c | cut -d' ' -f 2 |\
while read f; do\
echo "symbols = cons (&$$f, symbols);";\
done > symbols.i
mes.environment.h mes.environment.i mes.symbols.i: mes.c build-aux/mes-snarf.scm
build-aux/mes-snarf.scm $<
check: all guile-check mes-check

130
build-aux/mes-snarf.scm Executable file
View File

@ -0,0 +1,130 @@
#! /bin/sh
# -*- scheme -*-
exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e '(@@ (mes-snarf) main)' -s "$0" ${1+"$@"}
!#
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; mes-snarf.scm: This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
(define-module (mes-snarf)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 curried-definitions)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (oop goops))
(define ((regexp-replace regexp replace) string)
(or (and=> (string-match regexp string)
(cut regexp-substitute #f <> 'pre replace 'post))
string))
;; (define-record-type function (make-function name formals annotation)
;; function?
;; (name .name)
;; (formals .formals)
;; (annotation .annotation))
(define-class <file> ()
(name #:accessor .name #:init-keyword #:name)
(content #:accessor .content #:init-keyword #:content))
(define-class <function> ()
(name #:accessor .name #:init-keyword #:name)
(formals #:accessor .formals #:init-keyword #:formals)
(annotation #:accessor .annotation #:init-keyword #:annotation))
(define (function-scm-name f)
(or (assoc-ref (.annotation f) 'name)
((compose
(regexp-replace "_" "-")
(regexp-replace "_" "-")
(regexp-replace "_" "-")
(regexp-replace "_" "-")
(regexp-replace "^builtin_" "")
(regexp-replace "_to_" "->")
(regexp-replace "_x$" "!")
(regexp-replace "_p$" "?"))
(.name f))))
(define (function-builtin-name f)
(string-append %builtin-prefix% (.name f)))
(define (function->source f)
(format #f "a = add_environment (a, ~S, &~a);\n" (function-scm-name f) (function-builtin-name f)))
(define (symbol->source s)
(format #f "symbols = cons (&~a, symbols);\n" s))
(define %builtin-prefix% "scm_")
(define (function->header f)
(let* ((n (or (assoc-ref (.annotation f) 'args)
(if (string-null? (.formals f)) 0
(length (string-split (.formals f) #\,))))))
(string-append (format #f "scm *~a (~a);\n" (.name f) (.formals f))
(format #f "scm ~a = {FUNCTION~a, .name=~S, .function~a=&~a};\n" (function-builtin-name f) n (function-scm-name f) n (.name f)))))
(define (snarf-symbols string)
(let* ((matches (list-matches "\nscm ([a-z_0-9]+) = [{](SCM|SYMBOL)," string)))
(map (cut match:substring <> 1) matches)))
(define (snarf-functions string)
(let* ((matches (list-matches
"\nscm [*]\n?([a-z0-9_]+) [(]((scm *[^,)]+|, )*)[)][^\n(]*([^\n]*)"
string)))
(map (lambda (m)
(make <function>
#:name (match:substring m 1)
#:formals (match:substring m 2)
#:annotation (with-input-from-string (match:substring m 4) read)))
matches)))
(define (internal? f)
((compose (cut assoc-ref <> 'internal) .annotation) f))
(define (no-environment? f)
((compose (cut assoc-ref <> 'no-environment) .annotation) f))
(define (generate-includes file-name)
(let* ((string (with-input-from-file file-name read-string))
(functions (snarf-functions string))
(functions (delete-duplicates functions (lambda (a b) (equal? (.name a) (.name b)))))
(functions (sort functions (lambda (a b) (string< (.name a) (.name b)))))
(functions (filter (negate internal?) functions))
(symbols (snarf-symbols string))
(base-name (basename file-name ".c"))
(header (make <file>
#:name (string-append base-name ".environment.h")
#:content (string-join (map function->header functions))))
(environment (make <file>
#:name (string-append base-name ".environment.i")
#:content (string-join (map function->source (filter (negate no-environment?) functions)))))
(symbols (make <file>
#:name (string-append base-name ".symbols.i")
#:content (string-join (map symbol->source symbols)))))
(list header environment symbols)))
(define (file-write file)
(with-output-to-file (.name file) (lambda () (display (.content file)))))
(define (main args)
(let* ((files (cdr args)))
(map file-write (append-map generate-includes files))))
;;(define string (with-input-from-file "../mes.c" read-string))

116
mes.c
View File

@ -30,7 +30,6 @@
#define DEBUG 0
#define BUILTIN_QUASIQUOTE 1 // 6x speedup for mescc
#define MES_FULL 1
enum type {CHAR, MACRO, NUMBER, PAIR, SCM, STRING, SYMBOL, VALUES, VECTOR,
FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn};
@ -63,10 +62,9 @@ typedef struct scm_t {
scm temp_number = {NUMBER, .name="nul", .value=0};
#define MES_C 1
#include "mes.h"
#include "mes.environment.h"
scm *display_ (FILE* f, scm *x); //internal
scm *display_ (FILE* f, scm *x);
scm *display_helper (FILE*, scm*, bool, char const*, bool);
scm scm_nil = {SCM, "()"};
@ -215,23 +213,25 @@ quasiquote (scm *x)
return cons (&symbol_quasiquote, x);
}
scm *
quasisyntax (scm *x)
{
return cons (&symbol_quasisyntax, x);
}
#if BUILTIN_QUASIQUOTE
scm *
unquote (scm *x) //int must not add to environment
unquote (scm *x) ///((no-environment))
{
return cons (&symbol_unquote, x);
}
scm *unquote (scm *x);
scm scm_unquote = {FUNCTION1, .name="unquote", .function1=&unquote};
scm *
unquote_splicing (scm *x) //int must not add to environment
unquote_splicing (scm *x) ///((no-environment))
{
return cons (&symbol_unquote_splicing, x);
}
scm *unquote_splicing (scm *x);
scm scm_unquote_splicing = {FUNCTION1, .name="unquote-splicing", .function1=&unquote_splicing};
#endif // BUILTIN_QUASIQUOTE
scm *
syntax (scm *x)
{
@ -239,27 +239,17 @@ syntax (scm *x)
}
scm *
quasisyntax (scm *x)
{
return cons (&symbol_quasisyntax, x);
}
scm *
unsyntax (scm *x) //int must not add to environment
unsyntax (scm *x) ///((no-environment))
{
return cons (&symbol_unsyntax, x);
}
scm *unsyntax (scm *x);
scm scm_unsyntax = {FUNCTION1, .name="unsyntax", .function1=&unsyntax};
scm *
unsyntax_splicing (scm *x) //int must not add to environment
unsyntax_splicing (scm *x) ///((no-environment))
{
return cons (&symbol_unsyntax_splicing, x);
}
scm *unsyntax_splicing (scm *x);
scm scm_unsyntax_splicing = {FUNCTION1, .name="unsyntax-splicing", .function1=&unsyntax_splicing};
#endif // BUILTIN_QUASIQUOTE
//Library functions
@ -300,7 +290,7 @@ assq (scm *x, scm *a)
#if !ENV_CACHE
scm *
assq_ref_cache (scm *x, scm *a) //internal
assq_ref_cache (scm *x, scm *a)
{
x = assq (x, a);
if (x == &scm_f) return &scm_f;
@ -622,7 +612,7 @@ vector_p (scm *x)
}
scm *
display (scm *x/*...*/)
display (scm *x) ///((args . n))
{
scm *e = car (x);
scm *p = cdr (x);
@ -633,7 +623,7 @@ display (scm *x/*...*/)
}
scm *
display_ (FILE* f, scm *x) //internal
display_ (FILE* f, scm *x) ///((internal))
{
return display_helper (f, x, false, "", false);
}
@ -665,7 +655,7 @@ append2 (scm *x, scm *y)
}
scm *
append (scm *x/*...*/)
append (scm *x) ///((args . n))
{
if (x == &scm_nil) return &scm_nil;
return append2 (car (x), append (cdr (x)));
@ -749,7 +739,7 @@ make_vector (scm *n)
}
scm *
string (scm *x/*...*/)
string (scm *x) ///((args . n))
{
char buf[STRING_MAX] = "";
char *p = buf;
@ -764,7 +754,7 @@ string (scm *x/*...*/)
}
scm *
string_append (scm *x/*...*/)
string_append (scm *x) ///((args . n))
{
char buf[STRING_MAX] = "";
@ -810,7 +800,7 @@ string_ref (scm *x, scm *k)
}
scm *
substring (scm *x/*...*/)
substring (scm *x) ///((args . n))
{
assert (x->type == PAIR);
assert (x->car->type == STRING);
@ -852,13 +842,13 @@ last_pair (scm *x)
}
scm *
builtin_list (scm *x/*...*/)
builtin_list (scm *x) ///((args . n))
{
return x;
}
scm *
values (scm *x/*...*/)
values (scm *x) ///((args . n))
{
scm *v = cons (0, x);
v->type = VALUES;
@ -936,7 +926,7 @@ lookup_char (int c, scm *a)
}
char const *
list2str (scm *l) // char*
list2str (scm *l)
{
static char buf[STRING_MAX];
char *p = buf;
@ -950,7 +940,7 @@ list2str (scm *l) // char*
return buf;
}
scm*
scm *
list_to_vector (scm *x)
{
temp_number.value = length (x)->value;
@ -964,21 +954,21 @@ list_to_vector (scm *x)
return v;
}
scm*
scm *
integer_to_char (scm *x)
{
assert (x->type == NUMBER);
return make_char (x->value);
}
scm*
scm *
char_to_integer (scm *x)
{
assert (x->type == CHAR);
return make_number (x->value);
}
scm*
scm *
number_to_string (scm *x)
{
assert (x->type == NUMBER);
@ -987,28 +977,28 @@ number_to_string (scm *x)
return make_string (buf);
}
scm*
scm *
builtin_exit (scm *x)
{
assert (x->type == NUMBER);
exit (x->value);
}
scm*
scm *
string_to_symbol (scm *x)
{
assert (x->type == STRING);
return make_symbol (x->name);
}
scm*
scm *
symbol_to_string (scm *x)
{
assert (x->type == SYMBOL);
return make_string (x->name);
}
scm*
scm *
vector_to_list (scm *v)
{
scm *x = &scm_nil;
@ -1018,7 +1008,7 @@ vector_to_list (scm *v)
}
scm *
newline (scm *p/*...*/)
newline (scm *p) ///((args . n))
{
int fd = 1;
if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
@ -1028,7 +1018,7 @@ newline (scm *p/*...*/)
}
scm *
force_output (scm *p/*...*/)
force_output (scm *p) ///((args . n))
{
int fd = 1;
if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
@ -1098,20 +1088,20 @@ display_helper (FILE* f, scm *x, bool cont, char const *sep, bool quote)
// READ
int
ungetchar (int c) //int
ungetchar (int c)
{
return ungetc (c, stdin);
}
int
peekchar () //int
peekchar ()
{
int c = getchar ();
ungetchar (c);
return c;
}
scm*
scm *
peek_char ()
{
return make_char (peekchar ());
@ -1124,7 +1114,7 @@ read_char ()
}
scm *
write_char (scm *x/*...*/)
write_char (scm *x) ///((args . n))
{
scm *c = car (x);
scm *p = cdr (x);
@ -1136,7 +1126,7 @@ write_char (scm *x/*...*/)
return c;
}
scm*
scm *
unget_char (scm *c)
{
assert (c->type == NUMBER || c->type == CHAR);
@ -1309,7 +1299,7 @@ read_env (scm *a)
}
scm *
greater_p (scm *x/*...*/)
greater_p (scm *x) ///((name . ">") (args . n))
{
int n = INT_MAX;
while (x != &scm_nil)
@ -1323,7 +1313,7 @@ greater_p (scm *x/*...*/)
}
scm *
less_p (scm *x/*...*/)
less_p (scm *x) ///((name . "<") (args . n))
{
int n = INT_MIN;
while (x != &scm_nil)
@ -1337,7 +1327,7 @@ less_p (scm *x/*...*/)
}
scm *
is_p (scm *x/*...*/)
is_p (scm *x) ///((name . "=") (args . n))
{
if (x == &scm_nil) return &scm_t;
assert (x->car->type == NUMBER);
@ -1352,7 +1342,7 @@ is_p (scm *x/*...*/)
}
scm *
minus (scm *x/*...*/)
minus (scm *x) ///((name . "-") (args . n))
{
scm *a = car (x);
assert (a->type == NUMBER);
@ -1370,7 +1360,7 @@ minus (scm *x/*...*/)
}
scm *
plus (scm *x/*...*/)
plus (scm *x) ///((name . "+") (args . n))
{
int n = 0;
while (x != &scm_nil)
@ -1383,7 +1373,7 @@ plus (scm *x/*...*/)
}
scm *
divide (scm *x/*...*/)
divide (scm *x) ///((name . "/") (args . n))
{
int n = 1;
if (x != &scm_nil) {
@ -1409,7 +1399,7 @@ modulo (scm *a, scm *b)
}
scm *
multiply (scm *x/*...*/)
multiply (scm *x) ///((name . "*") (args . n))
{
int n = 1;
while (x != &scm_nil)
@ -1422,7 +1412,7 @@ multiply (scm *x/*...*/)
}
scm *
logior (scm *x/*...*/)
logior (scm *x) ///((args . n))
{
int n = 0;
while (x != &scm_nil)
@ -1461,11 +1451,11 @@ add_environment (scm *a, char const *name, scm *x)
}
scm *
mes_environment ()
mes_environment () ///((internal))
{
scm *a = &scm_nil;
#include "symbols.i"
#include "mes.symbols.i"
#if BOOT
symbols = cons (&scm_label, symbols);
@ -1480,12 +1470,8 @@ mes_environment ()
a = cons (cons (&symbol_quote, &scm_quote), a);
a = cons (cons (&symbol_syntax, &scm_syntax), a);
#if MES_FULL
#include "environment.i"
#else
a = add_environment (a, "display", &scm_display);
a = add_environment (a, "newline", &scm_newline);
#endif
#include "mes.environment.i"
a = cons (cons (&scm_closure, a), a);
return a;
}