core: Add garbage collector/jam collector experiment.
[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-record-type function (make-function name formals annotation)
38 ;;   function?
39 ;;   (name .name)
40 ;;   (formals .formals)
41 ;;   (annotation .annotation))
42
43 (define-class <file> ()
44   (name #:accessor .name #:init-keyword #:name)
45   (content #:accessor .content #:init-keyword #:content))
46
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))
51
52 (define (function-scm-name f)
53   (or (assoc-ref (.annotation f) 'name)
54       ((compose
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$" "?"))
63        (.name f))))
64
65 (define (function-builtin-name f)
66   (string-append %builtin-prefix% (.name f)))
67
68 (define (function->source f)
69   (format #f "a = add_environment (a, ~S, &~a);\n" (function-scm-name f) (function-builtin-name f)))
70
71 (define (symbol->source s)
72   (format #f "symbols = cons (&~a, symbols);\n" s))
73
74 (define %builtin-prefix% "scm_")
75 (define (function->header f)
76   (let* ((arity (or (assoc-ref (.annotation f) 'arity)
77                     (if (string-null? (.formals f)) 0
78                         (length (string-split (.formals f) #\,)))))
79          (n (if (eq? arity 'n) -1 arity)))
80     (string-append (format #f "scm *~a (~a);\n" (.name f) (.formals f))
81                    (format #f "function fun_~a = {.function~a=&~a, .arity=~a};\n" (.name f) arity (.name f) n)
82                    (format #f "scm ~a = {FUNCTION, .name=~S, .function=&fun_~a};\n" (function-builtin-name f) (function-scm-name f) (.name f)))))
83
84 (define (snarf-symbols string)
85   (let* ((matches (append (list-matches "\nscm ([a-z_0-9]+) = [{](SCM)," string)
86                           (list-matches "\nscm ([a-z_0-9]+) = [{](SYMBOL)," string))))
87     (map (cut match:substring <> 1) matches)))
88
89 (define (snarf-functions string)
90   (let* ((matches (list-matches
91                    "\nscm [*]\n?([a-z0-9_]+) [(]((scm *[^,)]+|, )*)[)][^\n(]*([^\n]*)"
92                    string)))
93     (map (lambda (m)
94            (make <function>
95              #:name (match:substring m 1)
96              #:formals (match:substring m 2)
97              #:annotation (with-input-from-string (match:substring m 4) read)))
98          matches)))
99
100 (define (content? f)
101   ((compose not string-null? .content) f))
102
103 (define (internal? f)
104   ((compose (cut assoc-ref <> 'internal) .annotation) f))
105
106 (define (no-environment? f)
107   ((compose (cut assoc-ref <> 'no-environment) .annotation) f))
108
109 (define (generate-includes file-name)
110   (let* ((string (with-input-from-file file-name read-string))
111          (functions (snarf-functions string))
112          (functions (delete-duplicates functions (lambda (a b) (equal? (.name a) (.name b)))))
113          (functions (sort functions (lambda (a b) (string< (.name a) (.name b)))))
114          (functions (filter (negate internal?) functions))
115          (symbols (snarf-symbols string))
116          (base-name (basename file-name ".c"))
117          (header (make <file>
118                    #:name (string-append base-name ".environment.h")
119                    #:content (string-join (map function->header functions) "")))
120          (environment (make <file>
121                         #:name (string-append base-name ".environment.i")
122                         #:content (string-join (map function->source (filter (negate no-environment?) functions)) "")))
123          (symbols (make <file>
124                     #:name (string-append base-name ".symbols.i")
125                     #:content (string-join (map symbol->source symbols) ""))))
126     (list header environment symbols)))
127
128 (define (file-write file)
129   (with-output-to-file (.name file) (lambda () (display (.content file)))))
130
131 (define (main args)
132   (let* ((files (cdr args)))
133     (map file-write (filter content? (append-map generate-includes files)))))
134
135 ;;(define string (with-input-from-file "../mes.c" read-string))
136