diff --git a/build-aux/mes-snarf.scm b/build-aux/mes-snarf.scm index 63aba942..64a8fc4f 100755 --- a/build-aux/mes-snarf.scm +++ b/build-aux/mes-snarf.scm @@ -1,10 +1,10 @@ #! /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+"$@"} +# -*-scheme-*- +exec ${GUILE-guile} -L $(dirname 0) -e '(mes-snarf)' -s "$0" "$@" !# ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016,2017 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen ;;; ;;; mes-snarf.scm: This file is part of Mes. ;;; @@ -23,57 +23,80 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e (define-module (mes-snarf) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:use-module (srfi srfi-9) #: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)) + #:export (main)) -(define ((regexp-replace regexp replace) string) - (or (and=> (string-match regexp string) - (cut regexp-substitute #f <> 'pre replace 'post)) +(cond-expand + (mes + (define %scheme "mes")) + (guile-2 + (define %scheme "guile") + (define-macro (mes-use-module . rest) #t)) + (guile + (use-modules (ice-9 syncase)) + (define %scheme "guile") + (define-macro (mes-use-module . rest) #t))) + +(mes-use-module (mes guile)) +(mes-use-module (srfi srfi-1)) +(mes-use-module (srfi srfi-8)) +(mes-use-module (srfi srfi-9)) +(mes-use-module (srfi srfi-26)) + +(format (current-error-port) "mes-snarf[~a]...\n" %scheme) + +(define (char->char from to char) + (if (eq? char from) to char)) + +(define (string-replace-char string from to) + (string-map (cut char->char from to <>) string)) + +(define (string-replace-suffix string from to) + (if (string-suffix? from string) + (string-replace string to (- (string-length string) (string-length from))) string)) +(define (string-replace-string string from to) + (cond ((string-contains string from) => (lambda (i) (string-replace string to i (+ i (string-length from))))) + (else string))) + (define %gcc? #t) -;; (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-record-type file (make-file name content) + file? + (name file.name) + (content file.content)) -(define-class () - (name #:accessor .name #:init-keyword #:name) - (formals #:accessor .formals #:init-keyword #:formals) - (annotation #:accessor .annotation #:init-keyword #:annotation)) +(define-record-type function (make-function name formals annotation) + function? + (name function.name) + (formals function.formals) + (annotation function.annotation)) (define (function-scm-name f) - (or (assoc-ref (.annotation f) 'name) + (or (assoc-ref (function.annotation f) 'name) (let ((name ((compose - (regexp-replace "_" "-") - (regexp-replace "_" "-") - (regexp-replace "_" "-") - (regexp-replace "_" "-") - (regexp-replace "_to_" "->") - (regexp-replace "_x$" "!") - (regexp-replace "_x_$" "!-") - (regexp-replace "_p$" "?") - (regexp-replace "___" "***") - (regexp-replace "___" "***")) - (.name f)))) + identity + (cut string-replace-char <> #\_ #\-) + (cut string-replace-string <> "_to_" "->") + (cut string-replace-suffix <> "_x" "!") + (cut string-replace-suffix <> "_x_" "!-") + (cut string-replace-suffix <> "_p" "?") + ) + (function.name f)))) (if (not (string-suffix? "-" name)) name (string-append "core:" (string-drop-right name 1)))))) (define %builtin-prefix% "scm_") (define (function-builtin-name f) - (string-append %builtin-prefix% (.name f))) + (string-append %builtin-prefix% (function.name f))) (define %cell-prefix% "cell_") (define (function-cell-name f) - (string-append %cell-prefix% (.name f))) + (string-append %cell-prefix% (function.name f))) (define %start 1) (define (symbol->header s i) @@ -90,69 +113,99 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e (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) - (if (string-null? (.formals f)) 0 - (length (string-split (.formals f) #\,))))) + (let* ((arity (or (assoc-ref (function.annotation f) 'arity) + (if (string-null? (function.formals f)) 0 + (length (string-split (function.formals f) #\,))))) (n (if (eq? arity 'n) -1 arity))) (string-append - (format #f "SCM ~a (~a);\n" (.name f) (.formals f)) + (format #f "SCM ~a (~a);\n" (function.name f) (function.formals f)) (if %gcc? - (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))) + (format #f "struct function fun_~a = {.function~a=&~a, .arity=~a, .name=~s};\n" (function.name f) arity (function.name f) n (function-scm-name f)) + (format #f "struct function fun_~a = {&~a, ~a, ~s};\n" (function.name f) (function.name f) n (function-scm-name f))) (if %gcc? (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))))) + (format #f "SCM cell_~a;\n\n" (function.name f))))) (define (function->source f i) (string-append (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)))) + (format #f "g_functions[g_function++] = fun_~a;\n" (function.name f)) + (format #f "cell_~a = g_free++;\n" (function.name f)) + (format #f "g_cells[cell_~a] = ~a;\n\n" (function.name f) (function-builtin-name f)))) (define (function->environment f i) (string-append (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))) + (format #f "scm_~a.string = cstring_to_list (fun_~a.name);\n" (function.name f) (function.name f)) + (format #f "scm_~a.car = cstring_to_list (fun_~a.name);\n" (function.name f) (function.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))) + (format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (function.name f) (function.name f)) + (format #f "g_cells[cell_~a].car = MAKE_STRING (scm_~a.car);\n" (function.name f) (function.name f))) (if %gcc? - (format #f "a = acons (lookup_symbol_ (scm_~a.string), ~a, a);\n\n" (.name f) (function-cell-name f)) - (format #f "a = acons (lookup_symbol_ (scm_~a.car), ~a, a);\n\n" (.name f) (function-cell-name f))))) + (format #f "a = acons (lookup_symbol_ (scm_~a.string), ~a, a);\n\n" (function.name f) (function-cell-name f)) + (format #f "a = acons (lookup_symbol_ (scm_~a.car), ~a, a);\n\n" (function.name f) (function-cell-name f))))) + +(define (disjoin . predicates) + (lambda (. arguments) + (any (cut apply <> arguments) predicates))) (define (snarf-symbols string) - (let* ((matches (list-matches "\nstruct scm scm_([a-z_0-9]+) = [{](TSPECIAL|TSYMBOL)," string))) - (map (cut match:substring <> 1) matches))) + (let* ((lines (string-split string #\newline)) + (scm (filter (cut string-prefix? "struct scm scm_" <>) lines)) + (symbols (filter (disjoin (cut string-contains <> "TSPECIAL") (cut string-contains <> "TSYMBOL")) scm))) + (define (line->symbol line) + ((compose + (lambda (s) (string-take s (string-index s #\space))) + (cut string-drop <> (string-length "struct scm scm_"))) + line)) + (map line->symbol symbols))) + +(define (string-split-string string sep) + (cond ((string-contains string sep) => (lambda (i) (list (string-take string i) (string-drop string (+ i (string-length sep)))))) + (else (list string #f)))) (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))) + (let ((lines (string-split string #\newline))) + (filter-map + (lambda (line previous) + (receive (function rest) + (apply values (string-split-string line " ")) + (and function + (equal? (string-trim previous) "SCM") + (not (string-null? function)) + (not (string-prefix? "#" function)) + (not (string-prefix? "/" function)) + rest + (receive (parameter-list annotation) + (apply values (string-split-string rest " ///")) + (let* ((parameters (string-drop parameter-list 1)) + (parameters (string-drop-right parameters 1)) + (formals (if (string-null? parameters) '() + (string-split parameters #\,))) + (formals (map string-trim formals))) + (and parameters + (let* ((non-SCM (filter (negate (cut string-prefix? "SCM" <>)) formals))) + (and (null? non-SCM) + (let ((annotation (and annotation (with-input-from-string annotation read)))) + (make-function function parameters annotation)))))))))) + lines (cons "\n" lines)))) (define (content? f) - ((compose not string-null? .content) f)) + ((compose not string-null? file.content) f)) (define (internal? f) - ((compose (cut assoc-ref <> 'internal) .annotation) f)) + ((compose (cut assoc-ref <> 'internal) function.annotation) f)) (define (no-environment? f) - ((compose (cut assoc-ref <> 'no-environment) .annotation) f)) + ((compose (cut assoc-ref <> 'no-environment) function.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 (delete-duplicates functions (lambda (a b) (equal? (function.name a) (function.name b))))) (functions (filter (negate internal?) functions)) (symbols (snarf-symbols string)) (base-name (basename file-name ".c")) @@ -160,33 +213,32 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e (base-name (string-append dir "/" base-name)) (base-name (if %gcc? base-name (string-append base-name ".mes"))) - (header (make - #:name (string-append base-name ".h") - #:content (string-join (map function->header functions (iota (length functions) (+ %start (length symbols)))) ""))) - (source (make - #:name (string-append base-name ".i") - #:content (string-join (map function->source (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) ""))) - (environment (make - #:name (string-append base-name ".environment.i") - #:content (string-join (map function->environment (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) ""))) - (symbols.h (make - #:name (string-append base-name ".symbols.h") - #:content (string-join (map symbol->header symbols (iota (length symbols) %start)) ""))) - (symbols.i (make - #:name (string-append base-name ".symbols.i") - #:content (string-join (map symbol->source symbols (iota (length symbols))) ""))) - (symbol-names.i (make - #:name (string-append base-name ".symbol-names.i") - #:content (string-join (map symbol->names symbols (iota (length symbols))) "")))) + (header (make-file + (string-append base-name ".h") + (string-join (map function->header functions (iota (length functions) (+ %start (length symbols)))) ""))) + (source (make-file + (string-append base-name ".i") + (string-join (map function->source (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) ""))) + (environment (make-file + (string-append base-name ".environment.i") + (string-join (map function->environment (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) ""))) + (symbols.h (make-file + (string-append base-name ".symbols.h") + (string-join (map symbol->header symbols (iota (length symbols) %start)) ""))) + (symbols.i (make-file + (string-append base-name ".symbols.i") + (string-join (map symbol->source symbols (iota (length symbols))) ""))) + (symbol-names.i (make-file + (string-append base-name ".symbol-names.i") + (string-join (map symbol->names symbols (iota (length symbols))) "")))) (list header source environment symbols.h symbols.i symbol-names.i))) (define (file-write file) - (with-output-to-file (.name file) (lambda () (display (.content file))))) + (with-output-to-file (file.name file) (lambda () (display (file.content file))))) (define (main args) (let* ((files (if (not (and (pair? (cdr args)) (equal? (cadr args) "--mes"))) (cdr args) (begin (set! %gcc? #f) - (cddr args))))) - (map file-write (filter content? (append-map generate-includes files))))) - -;;(define string (with-input-from-file "../mes.c" read-string)) + (cddr args)))) + (files (append-map generate-includes files))) + (map file-write (filter content? files)))) diff --git a/src/mes.c b/src/mes.c index e66f6b00..c33b88d7 100644 --- a/src/mes.c +++ b/src/mes.c @@ -504,7 +504,7 @@ acons (SCM key, SCM value, SCM alist) } int -length__ (SCM x) +length__ (SCM x) ///((internal)) { int n = 0; while (x != cell_nil)