d88ac014147ab4376ac4477099eb53d7756722f8
[mes.git] / build-aux / mes-snarf.scm
1 #! /bin/sh
2 # -*- scheme -*-
3 exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e '(@@ (mes-snarf) main)' -s "$0" ${1+"$@"}
4 !#
5
6 ;;; Mes --- Maxwell Equations of Software
7 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
8 ;;;
9 ;;; mes-snarf.scm: This file is part of Mes.
10 ;;;
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.
15 ;;;
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.
20 ;;;
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/>.
23
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))
31
32 (define ((regexp-replace regexp replace) string)
33   (or (and=> (string-match regexp string)
34              (cut regexp-substitute #f <> 'pre replace 'post))
35       string))
36
37 (define GCC? #f)
38 ;; (define-record-type function (make-function name formals annotation)
39 ;;   function?
40 ;;   (name .name)
41 ;;   (formals .formals)
42 ;;   (annotation .annotation))
43
44 (define-class <file> ()
45   (name #:accessor .name #:init-keyword #:name)
46   (content #:accessor .content #:init-keyword #:content))
47
48 (define-class <function> ()
49   (name #:accessor .name #:init-keyword #:name)
50   (formals #:accessor .formals #:init-keyword #:formals)
51   (annotation #:accessor .annotation #:init-keyword #:annotation))
52
53 (define (function-scm-name f)
54   (or (assoc-ref (.annotation f) 'name)
55       (let ((name ((compose
56                     (regexp-replace "_" "-")
57                     (regexp-replace "_" "-")
58                     (regexp-replace "_" "-")
59                     (regexp-replace "_" "-")
60                     (regexp-replace "^builtin_" "")
61                     (regexp-replace "_to_" "->")
62                     (regexp-replace "_x$" "!")
63                     (regexp-replace "_p$" "?"))
64                    (.name f))))
65         (if (not (string-suffix? "-" name)) name
66             (string-append "core:" (string-drop-right name 1))))))
67
68 (define %builtin-prefix% "scm_")
69 (define (function-builtin-name f)
70   (string-append %builtin-prefix% (.name f)))
71
72 (define %cell-prefix% "cell_")
73 (define (function-cell-name f)
74   (string-append %cell-prefix% (.name f)))
75
76 (define %start 1)
77 (define (symbol->header s i)
78   (format #f "#define cell_~a ~a\n" s i))
79
80 (define (symbol->source s i)
81   (string-append
82    (format #f "g_free++;\n")
83    ;; FIXME: g_functions
84    (if GCC?
85        (format #f "g_cells[cell_~a] = scm_~a;\n\n" s s)
86        (string-append
87          (format #f "g_cells[cell_~a].type = scm_~a.type;\n" s s)
88          (format #f "g_cells[cell_~a].car = scm_~a.car;\n" s s)
89          (format #f "g_cells[cell_~a].cdr = scm_~a.cdr;\n\n" s s)))))
90
91 (define (symbol->names s i)
92   (string-append
93    (if GCC?
94        (format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.name);\n" s s)
95        (format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.car);\n" s s))))
96
97 (define (function->header f i)
98   (let* ((arity (or (assoc-ref (.annotation f) 'arity)
99                     (if (string-null? (.formals f)) 0
100                         (length (string-split (.formals f) #\,)))))
101          (n (if (eq? arity 'n) -1 arity)))
102     (string-append
103      (format #f "SCM ~a (~a);\n" (.name f) (.formals f))
104      (if GCC?
105          (format #f "struct function fun_~a = {.function~a=&~a, .arity=~a, .name=~s};\n" (.name f) arity (.name f) n (function-scm-name f))
106          (format #f "struct function fun_~a = {&~a, ~a, ~s};\n" (.name f) (.name f) n (function-scm-name f)))
107      (if GCC?
108          (format #f "struct scm ~a = {TFUNCTION, .name=0, .function=0};\n" (function-builtin-name f))
109          (format #f "struct scm ~a = {TFUNCTION, 0, 0};\n" (function-builtin-name f)))
110      (format #f "SCM cell_~a;\n\n" (.name f)))))
111
112 (define (function->source f i)
113   (string-append
114    (if GCC?
115        (format #f "~a.function = g_function;\n" (function-builtin-name f))
116        (format #f "~a.cdr = g_function;\n" (function-builtin-name f)))
117    (format #f "g_functions[g_function++] = fun_~a;\n" (.name f))
118    (format #f "cell_~a = g_free++;\n" (.name f))
119    ;; FIXME: g_functions
120    (if GCC?
121        (format #f "g_cells[cell_~a] = ~a;\n\n" (.name f) (function-builtin-name f))
122        (string-append
123          (format #f "g_cells[cell_~a].type = ~a.type;\n" (.name f) (function-builtin-name f))
124          (format #f "g_cells[cell_~a].car = ~a.car;\n" (.name f) (function-builtin-name f))
125          ;;(format #f "g_cells[cell_~a].car = MAKE_STRING (~a.car);\n" (.name f) (function-builtin-name f))
126          (format #f "g_cells[cell_~a].cdr = ~a.cdr;\n\n" (.name f) (function-builtin-name f))))))
127
128 (define (function->environment f i)
129   (string-append
130    (if GCC?
131        (format #f "scm_~a.string = cstring_to_list (fun_~a.name);\n" (.name f) (.name f))
132        (format #f "scm_~a.car = cstring_to_list (fun_~a.name);\n" (.name f) (.name f)))
133    (if GCC?
134        (format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (.name f) (.name f))
135        (format #f "g_cells[cell_~a].car = MAKE_STRING (scm_~a.car);\n" (.name f) (.name f)))
136    (if GCC?
137        (format #f "a = acons (make_symbol (scm_~a.string), ~a, a);\n\n" (.name f) (function-cell-name f))
138        (format #f "a = acons (make_symbol (scm_~a.car), ~a, a);\n\n" (.name f) (function-cell-name f)))))
139
140 (define (snarf-symbols string)
141   (let* ((matches (list-matches "\nstruct scm scm_([a-z_0-9]+) = [{](TSPECIAL|TSYMBOL)," string)))
142     (map (cut match:substring <> 1) matches)))
143
144 (define (snarf-functions string)
145   (let* ((matches (list-matches
146                    "\nSCM[ \n]?([a-z0-9_]+) [(]((SCM ?[^,)]+|, )*)[)][^\n(]*([^\n]*)"
147                    string)))
148     (map (lambda (m)
149            (make <function>
150              #:name (match:substring m 1)
151              #:formals (match:substring m 2)
152              #:annotation (with-input-from-string (match:substring m 4) read)))
153          matches)))
154
155 (define (content? f)
156   ((compose not string-null? .content) f))
157
158 (define (internal? f)
159   ((compose (cut assoc-ref <> 'internal) .annotation) f))
160
161 (define (no-environment? f)
162   ((compose (cut assoc-ref <> 'no-environment) .annotation) f))
163
164 (define (generate-includes file-name)
165   (let* ((string (with-input-from-file file-name read-string))
166          (functions (snarf-functions string))
167          (functions (delete-duplicates functions (lambda (a b) (equal? (.name a) (.name b)))))
168          (functions (filter (negate internal?) functions))
169          (symbols (snarf-symbols string))
170          (base-name (basename file-name ".c"))
171          (header (make <file>
172                    #:name (string-append base-name ".h")
173                    #:content (string-join (map function->header functions (iota (length functions) (+ %start (length symbols)))) "")))
174          (source (make <file>
175                         #:name (string-append base-name ".i")
176                         #:content (string-join (map function->source (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) ""))) 
177          (environment (make <file>
178                         #:name (string-append base-name ".environment.i")
179                         #:content (string-join (map function->environment (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
180          (symbols.h (make <file>
181                       #:name (string-append base-name ".symbols.h")
182                       #:content (string-join (map symbol->header symbols (iota (length symbols) %start)) "")))
183          (symbols.i (make <file>
184                       #:name (string-append base-name ".symbols.i")
185                       #:content (string-join (map symbol->source symbols (iota (length symbols))) "")))
186          (symbol-names.i (make <file>
187                           #:name (string-append base-name ".symbol-names.i")
188                           #:content (string-join (map symbol->names symbols (iota (length symbols))) ""))))
189     (list header source environment symbols.h symbols.i symbol-names.i)))
190
191 (define (file-write file)
192   (with-output-to-file (.name file) (lambda () (display (.content file)))))
193
194 (define (main args)
195   (let* ((files (cdr args)))
196     (map file-write (filter content? (append-map generate-includes files)))))
197
198 ;;(define string (with-input-from-file "../mes.c" read-string))