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
parent
18aa0beaa9
commit
3e03a12a4d
20
.gitignore
vendored
20
.gitignore
vendored
|
|
@ -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
|
||||
\#*#
|
||||
|
|
|
|||
32
GNUmakefile
32
GNUmakefile
|
|
@ -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
130
build-aux/mes-snarf.scm
Executable 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))
|
||||
|
||||
96
mes.c
96
mes.c
|
|
@ -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;
|
||||
|
|
@ -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,13 +1088,13 @@ 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);
|
||||
|
|
@ -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);
|
||||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in a new issue