build: Fix configure crashing when no compiler is present.
[mes.git] / build-aux / mes-snarf.scm
1 #! /bin/sh
2 # -*-scheme-*-
3 exec ${GUILE-guile} --no-auto-compile -L $(dirname $0) -C $(dirname $0) -e '(mes-snarf)' -s "$0" "$@"
4 !#
5
6 ;;; GNU Mes --- Maxwell Equations of Software
7 ;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
8 ;;;
9 ;;; mes-snarf.scm: This file is part of GNU Mes.
10 ;;;
11 ;;; GNU 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 ;;; GNU 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 GNU 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 (when (and=> (getenv "V") (lambda (v) (> (string->number v) 1)))
50   (format (current-error-port) "mes-snarf[~a]...\n" %scheme))
51
52 (define (char->char from to char)
53   (if (eq? char from) to char))
54
55 (define (string-replace-char string from to)
56   (string-map (cut char->char from to <>) string))
57
58 (define (string-replace-suffix string from to)
59   (if (string-suffix? from string)
60       (string-replace string to (- (string-length string) (string-length from)))
61       string))
62
63 (define (string-replace-string string from to)
64   (cond ((string-contains string from) => (lambda (i) (string-replace string to i (+ i (string-length from)))))
65         (else string)))
66
67 (define %gcc? #t)
68
69 (define-record-type <file> (make-file name content)
70   file?
71   (name file.name)
72   (content file.content))
73
74 (define-record-type <function> (make-function name formals annotation)
75   function?
76   (name function.name)
77   (formals function.formals)
78   (annotation function.annotation))
79
80 (define (function-scm-name f)
81   (or (assoc-ref (function.annotation f) 'name)
82       (let ((name ((compose
83                     identity
84                     (cut string-replace-char <> #\_ #\-)
85                     (cut string-replace-string <> "_to_" "->")
86                     (cut string-replace-suffix <> "_x" "!")
87                     (cut string-replace-suffix <> "_x_" "!-")
88                     (cut string-replace-suffix <> "_p" "?"))
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   (string-append
104    (format #f "// CONSTANT ~a ~a\n" s i)
105    (format #f "#define ~a ~a\n" s i)))
106
107 (define (symbol->header s i)
108   (let ((c (string-upcase s)))
109     (string-append
110      (format #f "\n// CONSTANT ~a ~a\n" c i)
111      (format #f "#define ~a ~a\n" c i)
112      (format #f "struct scm *~a; /* ~a */\n" s i))))
113
114 (define (function->header f i)
115   (let* ((arity (or (assoc-ref (function.annotation f) 'arity)
116                     (if (string-null? (function.formals f)) 0
117                         (length (string-split (function.formals f) #\,)))))
118          (n (if (eq? arity 'n) -1 arity)))
119     (format #f "struct scm *~a (~a);\n" (function.name f) (function.formals f))))
120
121 (define (function->source f i)
122   (let* ((arity (or (assoc-ref (function.annotation f) 'arity)
123                     (if (string-null? (function.formals f)) 0
124                         (length (string-split (function.formals f) #\,)))))
125          (n (if (eq? arity 'n) -1 arity)))
126     (format #f "  a = init_builtin (builtin_type, ~s, ~a, &~a, a);\n" (function-scm-name f) n (function.name f))))
127
128 (define (disjoin . predicates)
129   (lambda (. arguments)
130     (any (cut apply <> arguments) predicates)))
131
132 (define (snarf-symbols string)
133   (let* ((lines (string-split string #\newline))
134          (symbols (filter (cut string-contains <> " = init_symbol (") lines)))
135     (define (line->symbol line)
136       ((compose
137         string-trim-both
138         (lambda (s) (string-take s (string-index s #\=))))
139        line))
140     (map line->symbol symbols)))
141
142 (define (string-split-string string sep)
143   (cond ((string-contains string sep) => (lambda (i) (list (string-take string i) (string-drop string (+ i (string-length sep))))))
144         (else (list string #f))))
145
146 (define (snarf-functions string)
147   (let ((lines (string-split string #\newline)))
148     (filter-map
149      (lambda (line previous)
150        (receive (function rest)
151            (apply values (string-split-string line " "))
152          (and function
153               (or (equal? (string-trim previous) "struct scm*")
154                   (equal? (string-trim previous) "struct scm *"))
155               (not (string-null? function))
156               (not (string-prefix? "#" function))
157               (not (string-prefix? "/" function))
158               rest
159               (receive (parameter-list annotation)
160                   (apply values (string-split-string rest " /*:"))
161                 (let* ((parameters (string-trim-both parameter-list))
162                        (parameters (string-drop parameters 1))
163                        (parameters (string-drop-right parameters 1))
164                        (annotation (if (string? annotation) (string-trim-both annotation)
165                                        annotation))
166                        (annotation (if (and (string? annotation)
167                                             (string-suffix? "*/" annotation))
168                                        (string-drop-right annotation 2)
169                                        annotation))
170                        (formals (if (string-null? parameters) '()
171                                     (string-split parameters #\,)))
172                        (formals (map string-trim formals)))
173                   (and parameters
174                        (let* ((non-SCM (filter (negate (cut string-prefix? "struct scm" <>)) formals)))
175                          (and (null? non-SCM)
176                               (let ((annotation (and annotation (with-input-from-string annotation read))))
177                                 (make-function function parameters annotation))))))))))
178      lines (cons "\n" lines))))
179
180 (define (content? f)
181   ((compose not string-null? file.content) f))
182
183 (define (internal? f)
184   ((compose (cut assoc-ref <> 'internal) function.annotation) f))
185
186 (define (no-environment? f)
187   ((compose (cut assoc-ref <> 'no-environment) function.annotation) f))
188
189 (define (generate-includes file-name)
190   (let* ((srcdest (or (getenv "srcdest") ""))
191          (string (with-input-from-file (string-append srcdest file-name) read-string))
192          (functions (snarf-functions string))
193          (functions (delete-duplicates functions (lambda (a b) (equal? (function.name a) (function.name b)))))
194          (functions (filter (negate internal?) functions))
195          (symbols (snarf-symbols string))
196          (base-name (basename file-name ".c"))
197          (dir (string-append (dirname file-name)))
198          (base-name (string-append dir "/" base-name))
199          (base-name (if %gcc? base-name
200                         (string-append base-name ".mes")))
201          (header (make-file
202                   (string-append base-name ".h")
203                   (string-join (map function->header functions (iota (length functions) (+ %start (length symbols)))) "")))
204          (source (make-file
205                   (string-append base-name ".i")
206                   (string-join (map function->source (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
207          (symbols.h (make-file
208                      (string-append base-name ".symbols.h")
209                      (string-join (map symbol->header symbols (iota (length symbols) %start)) ""))))
210     (list header source symbols.h)))
211
212 (define (file-write file)
213   (system* "mkdir" "-p" (dirname (file.name file)))
214   (with-output-to-file (file.name file) (lambda () (display (file.content file)))))
215
216 (define (main args)
217   (let* ((files (cdr args))
218          (files (append-map generate-includes files)))
219     (for-each file-write (filter content? files))))