3 exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e '(@@ (mes-snarf) main)' -s "$0" ${1+"$@"}
6 ;;; Mes --- Maxwell Equations of Software
7 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
9 ;;; mes-snarf.scm: This file is part of Mes.
11 ;;; Mes is free software; you can redistribute it and/or modify it
12 ;;; under the terms of the GNU General Public License as published by
13 ;;; the Free Software Foundation; either version 3 of the License, or (at
14 ;;; your option) any later version.
16 ;;; Mes is distributed in the hope that it will be useful, but
17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;;; GNU General Public License for more details.
21 ;;; You should have received a copy of the GNU General Public License
22 ;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
24 (define-module (mes-snarf)
25 #:use-module (srfi srfi-1)
26 #:use-module (srfi srfi-26)
27 #:use-module (ice-9 curried-definitions)
28 #:use-module (ice-9 rdelim)
29 #:use-module (ice-9 regex)
30 #:use-module (oop goops))
32 (define ((regexp-replace regexp replace) string)
33 (or (and=> (string-match regexp string)
34 (cut regexp-substitute #f <> 'pre replace 'post))
37 ;; (define-record-type function (make-function name formals annotation)
41 ;; (annotation .annotation))
43 (define-class <file> ()
44 (name #:accessor .name #:init-keyword #:name)
45 (content #:accessor .content #:init-keyword #:content))
47 (define-class <function> ()
48 (name #:accessor .name #:init-keyword #:name)
49 (formals #:accessor .formals #:init-keyword #:formals)
50 (annotation #:accessor .annotation #:init-keyword #:annotation))
52 (define (function-scm-name f)
53 (or (assoc-ref (.annotation f) 'name)
55 (regexp-replace "_" "-")
56 (regexp-replace "_" "-")
57 (regexp-replace "_" "-")
58 (regexp-replace "_" "-")
59 (regexp-replace "^builtin_" "")
60 (regexp-replace "_to_" "->")
61 (regexp-replace "_x$" "!")
62 (regexp-replace "_p$" "?"))
65 (define %builtin-prefix% "scm_")
66 (define (function-builtin-name f)
67 (string-append %builtin-prefix% (.name f)))
69 (define %cell-prefix% "cell_")
70 (define (function-cell-name f)
71 (string-append %cell-prefix% (.name f)))
74 (define (symbol->header s i)
75 (format #f "SCM cell_~a;\n" s))
77 (define (symbol->source s i)
79 (format #f "cell_~a = g_free.value++;\n" s)
80 (format #f "g_cells[cell_~a] = scm_~a;\n\n" s s)))
82 (define (function->header f i)
83 (let* ((arity (or (assoc-ref (.annotation f) 'arity)
84 (if (string-null? (.formals f)) 0
85 (length (string-split (.formals f) #\,)))))
86 (n (if (eq? arity 'n) -1 arity)))
88 (format #f "SCM ~a (~a);\n" (.name f) (.formals f))
89 (format #f "function fun_~a = {.function~a=&~a, .arity=~a};\n" (.name f) arity (.name f) n)
90 (format #f "scm ~a = {FUNCTION, .name=~S, .function=0};\n" (function-builtin-name f) (function-scm-name f))
91 (format #f "SCM cell_~a;\n\n" (.name f)))))
93 (define (function->source f i)
95 (format #f "~a.function = g_function;\n" (function-builtin-name f))
96 (format #f "functions[g_function++] = fun_~a;\n" (.name f))
97 (format #f "cell_~a = g_free.value++;\n" (.name f))
98 (format #f "g_cells[cell_~a] = ~a;\n\n" (.name f) (function-builtin-name f))))
100 (define (function->environment f i)
102 (format #f "a = add_environment (a, ~S, ~a);\n" (function-scm-name f) (function-cell-name f))))
104 (define (snarf-symbols string)
105 (let* ((matches (append (list-matches "\nscm scm_([a-z_0-9]+) = [{](SPECIAL)," string)
106 (list-matches "\nscm scm_([a-z_0-9]+) = [{](SYMBOL)," string))))
107 (map (cut match:substring <> 1) matches)))
109 (define (snarf-functions string)
110 (let* ((matches (list-matches
111 "\nSCM[ \n]?([a-z0-9_]+) [(]((SCM ?[^,)]+|, )*)[)][^\n(]*([^\n]*)"
115 #:name (match:substring m 1)
116 #:formals (match:substring m 2)
117 #:annotation (with-input-from-string (match:substring m 4) read)))
121 ((compose not string-null? .content) f))
123 (define (internal? f)
124 ((compose (cut assoc-ref <> 'internal) .annotation) f))
126 (define (no-environment? f)
127 ((compose (cut assoc-ref <> 'no-environment) .annotation) f))
129 (define (generate-includes file-name)
130 (let* ((string (with-input-from-file file-name read-string))
131 (functions (snarf-functions string))
132 (functions (delete-duplicates functions (lambda (a b) (equal? (.name a) (.name b)))))
133 (functions (filter (negate internal?) functions))
134 (symbols (snarf-symbols string))
135 (base-name (basename file-name ".c"))
137 #:name (string-append base-name ".h")
138 #:content (string-join (map function->header functions (iota (length functions) (+ %start (length symbols)))) "")))
140 #:name (string-append base-name ".i")
141 #:content (string-join (map function->source (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
142 (environment (make <file>
143 #:name (string-append base-name ".environment.i")
144 #:content (string-join (map function->environment (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
145 (symbols.h (make <file>
146 #:name (string-append base-name ".symbols.h")
147 #:content (string-join (map symbol->header symbols (iota (length symbols) %start)) "")))
148 (symbols.i (make <file>
149 #:name (string-append base-name ".symbols.i")
150 #:content (string-join (map symbol->source symbols (iota (length symbols))) ""))))
151 (list header source environment symbols.h symbols.i)))
153 (define (file-write file)
154 (with-output-to-file (.name file) (lambda () (display (.content file)))))
157 (let* ((files (cdr args)))
158 (map file-write (filter content? (append-map generate-includes files)))))
160 ;;(define string (with-input-from-file "../mes.c" read-string))