diff --git a/.gitignore b/.gitignore index 4653093b..98fbcf10 100644 --- a/.gitignore +++ b/.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 \#*# diff --git a/GNUmakefile b/GNUmakefile index 6cd71811..bdb31617 100644 --- a/GNUmakefile +++ b/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 diff --git a/build-aux/mes-snarf.scm b/build-aux/mes-snarf.scm new file mode 100755 index 00000000..04891754 --- /dev/null +++ b/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 +;;; +;;; 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 . + +(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 () + (name #:accessor .name #:init-keyword #:name) + (content #:accessor .content #:init-keyword #:content)) + +(define-class () + (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 + #: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 + #:name (string-append base-name ".environment.h") + #:content (string-join (map function->header functions)))) + (environment (make + #:name (string-append base-name ".environment.i") + #:content (string-join (map function->source (filter (negate no-environment?) functions))))) + (symbols (make + #: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)) + diff --git a/mes.c b/mes.c index bff85adf..ca446bf1 100644 --- a/mes.c +++ b/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; @@ -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; }