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.

.gitignore

@@ -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
 \#*#

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
+mes.environment.h mes.environment.i mes.symbols.i: mes.c build-aux/mes-snarf.scm
-	( echo '#if MES_C'; echo '#if MES_FULL' 1>&2;\
+	build-aux/mes-snarf.scm $<
-	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
 
 check: all guile-check mes-check
 

build-aux/mes-snarf.scm

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

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.environment.h"
-#include "mes.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)
+unsyntax (scm *x) ///((no-environment))
-{
-  return cons (&symbol_quasisyntax, x);
-}
-
-scm *
-unsyntax (scm *x) //int must not add to 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);
+#endif // BUILTIN_QUASIQUOTE
-scm scm_unsyntax_splicing = {FUNCTION1, .name="unsyntax-splicing", .function1=&unsyntax_splicing};
-
 
 //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 "mes.environment.i"
-#include "environment.i"
+
-#else
-  a = add_environment (a, "display", &scm_display);
-  a = add_environment (a, "newline", &scm_newline);
-#endif
   a = cons (cons (&scm_closure, a), a);
   return a;
 }