ed57bc67af5de79bac1992d7595df272fa230d9c
[mes.git] / build-aux / mes-snarf.scm
1 #! /bin/sh
2 # -*-scheme-*-
3 exec ${GUILE-guile} -L $(dirname 0) -e '(mes-snarf)' -s "$0" "$@"
4 !#
5
6 ;;; Mes --- Maxwell Equations of Software
7 ;;; Copyright © 2016,2017,2018 Jan (janneke) 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-8)
27   #:use-module (srfi srfi-9)
28   #:use-module (srfi srfi-26)
29   #:use-module (ice-9 rdelim)
30   #:export (main))
31
32 (cond-expand
33  (mes
34   (define %scheme "mes"))
35  (guile-2
36   (define %scheme "guile")
37   (define-macro (mes-use-module . rest) #t))
38  (guile
39   (use-modules (ice-9 syncase))
40   (define %scheme "guile")
41   (define-macro (mes-use-module . rest) #t)))
42
43 (mes-use-module (mes guile))
44 (mes-use-module (srfi srfi-1))
45 (mes-use-module (srfi srfi-8))
46 (mes-use-module (srfi srfi-9))
47 (mes-use-module (srfi srfi-26))
48
49 (format (current-error-port) "mes-snarf[~a]...\n" %scheme)
50
51 (define (char->char from to char)
52   (if (eq? char from) to char))
53
54 (define (string-replace-char string from to)
55   (string-map (cut char->char from to <>) string))
56
57 (define (string-replace-suffix string from to)
58   (if (string-suffix? from string)
59       (string-replace string to (- (string-length string) (string-length from)))
60       string))
61
62 (define (string-replace-string string from to)
63   (cond ((string-contains string from) => (lambda (i) (string-replace string to i (+ i (string-length from)))))
64         (else string)))
65
66 (define %gcc? #t)
67
68 (define-record-type <file> (make-file name content)
69   file?
70   (name file.name)
71   (content file.content))
72
73 (define-record-type <function> (make-function name formals annotation)
74   function?
75   (name function.name)
76   (formals function.formals)
77   (annotation function.annotation))
78
79 (define (function-scm-name f)
80   (or (assoc-ref (function.annotation f) 'name)
81       (let ((name ((compose
82                     identity
83                     (cut string-replace-char <> #\_ #\-)
84                     (cut string-replace-string <> "_to_" "->")
85                     (cut string-replace-suffix <> "_x" "!")
86                     (cut string-replace-suffix <> "_x_" "!-")
87                     (cut string-replace-suffix <> "_p" "?")
88                     )
89                    (function.name f))))
90         (if (not (string-suffix? "-" name)) name
91             (string-append "core:" (string-drop-right name 1))))))
92
93 (define %builtin-prefix% "scm_")
94 (define (function-builtin-name f)
95   (string-append %builtin-prefix% (function.name f)))
96
97 (define %cell-prefix% "cell_")
98 (define (function-cell-name f)
99   (string-append %cell-prefix% (function.name f)))
100
101 (define %start 1)
102 (define (symbol->header s i)
103   (format #f "#define cell_~a ~a\n" s i))
104
105 (define (symbol->source s i)
106   (string-append
107    (format #f "g_free++;\n")
108    (format #f "g_cells[cell_~a] = scm_~a;\n\n" s s)))
109
110 (define (symbol->names s i)
111   (if %gcc?
112       (format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.name);\n" s s)
113       (format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.car);\n" s s)))
114
115 (define (function->header f i)
116   (let* ((arity (or (assoc-ref (function.annotation f) 'arity)
117                     (if (string-null? (function.formals f)) 0
118                         (length (string-split (function.formals f) #\,)))))
119          (n (if (eq? arity 'n) -1 arity)))
120     (string-append
121      (format #f "SCM ~a (~a);\n" (function.name f) (function.formals f))
122      (if %gcc?
123          (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))
124          (format #f "struct function fun_~a = {&~a, ~a, ~s};\n" (function.name f) (function.name f) n (function-scm-name f)))
125      (if %gcc?
126          (format #f "struct scm ~a = {TFUNCTION, .name=0, .function=0};\n" (function-builtin-name f))
127          (format #f "struct scm ~a = {TFUNCTION, 0, 0};\n" (function-builtin-name f)))
128      (format #f "SCM cell_~a;\n\n" (function.name f)))))
129
130 (define (function->source f i)
131   (string-append
132    (if %gcc?
133        (format #f "~a.function = g_function;\n" (function-builtin-name f))
134        (format #f "~a.cdr = g_function;\n" (function-builtin-name f)))
135    (format #f "g_functions[g_function++] = fun_~a;\n" (function.name f))
136    (format #f "cell_~a = g_free++;\n" (function.name f))
137    (format #f "g_cells[cell_~a] = ~a;\n\n" (function.name f) (function-builtin-name f))))
138
139 (define (function->environment f i)
140   (string-append
141    (if %gcc?
142        (format #f "scm_~a.string = cstring_to_list (fun_~a.name);\n" (function.name f) (function.name f))
143        (format #f "scm_~a.car = cstring_to_list (fun_~a.name);\n" (function.name f) (function.name f)))
144    (if %gcc?
145        (format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (function.name f) (function.name f))
146        (format #f "g_cells[cell_~a].car = MAKE_STRING (scm_~a.car);\n" (function.name f) (function.name f)))
147    (if %gcc?
148        (format #f "a = acons (lookup_symbol_ (scm_~a.string), ~a, a);\n\n" (function.name f) (function-cell-name f))
149        (format #f "a = acons (lookup_symbol_ (scm_~a.car), ~a, a);\n\n" (function.name f) (function-cell-name f)))))
150
151 (define (disjoin . predicates)
152   (lambda (. arguments)
153     (any (cut apply <> arguments) predicates)))
154
155 (define (snarf-symbols string)
156   (let* ((lines (string-split string #\newline))
157          (scm (filter (cut string-prefix? "struct scm scm_" <>) lines))
158          (symbols (filter (disjoin (cut string-contains <> "TSPECIAL") (cut string-contains <> "TSYMBOL")) scm)))
159     (define (line->symbol line)
160       ((compose
161         (lambda (s) (string-take s (string-index s #\space)))
162         (cut string-drop <> (string-length "struct scm scm_")))
163        line))
164     (map line->symbol symbols)))
165
166 (define (string-split-string string sep)
167   (cond ((string-contains string sep) => (lambda (i) (list (string-take string i) (string-drop string (+ i (string-length sep))))))
168         (else (list string #f))))
169
170 (define (snarf-functions string)
171   (let ((lines (string-split string #\newline)))
172     (filter-map
173      (lambda (line previous)
174        (receive (function rest)
175            (apply values (string-split-string line " "))
176          (and function
177               (equal? (string-trim previous) "SCM")
178               (not (string-null? function))
179               (not (string-prefix? "#" function))
180               (not (string-prefix? "/" function))
181               rest
182               (receive (parameter-list annotation)
183                   (apply values (string-split-string rest " ///"))
184                 (let* ((parameters (string-drop parameter-list 1))
185                        (parameters (string-drop-right parameters 1))
186                        (formals (if (string-null? parameters) '()
187                                     (string-split parameters #\,)))
188                        (formals (map string-trim formals)))
189                   (and parameters
190                        (let* ((non-SCM (filter (negate (cut string-prefix? "SCM" <>)) formals)))
191                          (and (null? non-SCM)
192                               (let ((annotation (and annotation (with-input-from-string annotation read))))
193                                 (make-function function parameters annotation))))))))))
194      lines (cons "\n" lines))))
195
196 (define (content? f)
197   ((compose not string-null? file.content) f))
198
199 (define (internal? f)
200   ((compose (cut assoc-ref <> 'internal) function.annotation) f))
201
202 (define (no-environment? f)
203   ((compose (cut assoc-ref <> 'no-environment) function.annotation) f))
204
205 (define (generate-includes file-name)
206   (let* ((string (with-input-from-file file-name read-string))
207          (functions (snarf-functions string))
208          (functions (delete-duplicates functions (lambda (a b) (equal? (function.name a) (function.name b)))))
209          (functions (filter (negate internal?) functions))
210          (symbols (snarf-symbols string))
211          (base-name (basename file-name ".c"))
212          (dir (or (getenv "OUT") (dirname file-name)))
213          (base-name (string-append dir "/" base-name))
214          (base-name (if %gcc? base-name
215                         (string-append base-name ".mes")))
216          (header (make-file
217                   (string-append base-name ".h")
218                   (string-join (map function->header functions (iota (length functions) (+ %start (length symbols)))) "")))
219          (source (make-file
220                   (string-append base-name ".i")
221                   (string-join (map function->source (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) ""))) 
222          (environment (make-file
223                        (string-append base-name ".environment.i")
224                        (string-join (map function->environment (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
225          (symbols.h (make-file
226                      (string-append base-name ".symbols.h")
227                      (string-join (map symbol->header symbols (iota (length symbols) %start)) "")))
228          (symbols.i (make-file
229                      (string-append base-name ".symbols.i")
230                      (string-join (map symbol->source symbols (iota (length symbols))) "")))
231          (symbol-names.i (make-file
232                           (string-append base-name ".symbol-names.i")
233                           (string-join (map symbol->names symbols (iota (length symbols))) ""))))
234     (list header source environment symbols.h symbols.i symbol-names.i)))
235
236 (define (file-write file)
237   (with-output-to-file (file.name file) (lambda () (display (file.content file)))))
238
239 (define (main args)
240   (let* ((files (if (not (and (pair? (cdr args)) (equal? (cadr args) "--mes"))) (cdr args)
241                     (begin (set! %gcc? #f)
242                            (cddr args))))
243          (files (append-map generate-includes files)))
244     (map file-write (filter content? files))))