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 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                     )
  90                    (function.name f))))
  91         (if (not (string-suffix? "-" name)) name
  92             (string-append "core:" (string-drop-right name 1))))))
  93
  94 (define %builtin-prefix% "scm_")
  95 (define (function-builtin-name f)
  96   (string-append %builtin-prefix% (function.name f)))
  97
  98 (define %cell-prefix% "cell_")
  99 (define (function-cell-name f)
 100   (string-append %cell-prefix% (function.name f)))
 101
 102 (define %start 1)
 103 (define (symbol->header s i)
 104   (format #f "#define cell_~a ~a\n" s i))
 105
 106 (define (symbol->source s i)
 107   (string-append
 108    (format #f "g_free++;\n")
 109    (format #f "g_cells[cell_~a] = scm_~a;\n\n" s s)))
 110
 111 (define (symbol->names s i)
 112   (if %gcc?
 113       (format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.name);\n" s s)
 114       (format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.car);\n" s s)))
 115
 116 (define (function->header f i)
 117   (let* ((arity (or (assoc-ref (function.annotation f) 'arity)
 118                     (if (string-null? (function.formals f)) 0
 119                         (length (string-split (function.formals f) #\,)))))
 120          (n (if (eq? arity 'n) -1 arity)))
 121     (string-append
 122      (format #f "SCM ~a (~a);\n" (function.name f) (function.formals f))
 123      (if %gcc?
 124          (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))
 125          (format #f "struct function fun_~a = {&~a, ~a, ~s};\n" (function.name f) (function.name f) n (function-scm-name f)))
 126      (if %gcc?
 127          (format #f "struct scm ~a = {TFUNCTION, .name=0, .function=0};\n" (function-builtin-name f))
 128          (format #f "struct scm ~a = {TFUNCTION, 0, 0};\n" (function-builtin-name f)))
 129      (format #f "SCM cell_~a;\n\n" (function.name f)))))
 130
 131 (define (function->source f i)
 132   (string-append
 133    (if %gcc?
 134        (format #f "~a.function = g_function;\n" (function-builtin-name f))
 135        (format #f "~a.cdr = g_function;\n" (function-builtin-name f)))
 136    (format #f "g_functions[g_function++] = fun_~a;\n" (function.name f))
 137    (format #f "cell_~a = g_free++;\n" (function.name f))
 138    (format #f "g_cells[cell_~a] = ~a;\n\n" (function.name f) (function-builtin-name f))))
 139
 140 (define (function->environment f i)
 141   (string-append
 142    (if %gcc?
 143        (format #f "scm_~a.string = cstring_to_list (fun_~a.name);\n" (function.name f) (function.name f))
 144        (format #f "scm_~a.car = cstring_to_list (fun_~a.name);\n" (function.name f) (function.name f)))
 145    (if %gcc?
 146        (format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (function.name f) (function.name f))
 147        (format #f "g_cells[cell_~a].car = MAKE_STRING (scm_~a.car);\n" (function.name f) (function.name f)))
 148    (if %gcc?
 149        (format #f "a = acons (make_symbol (scm_~a.string), ~a, a);\n\n" (function.name f) (function-cell-name f))
 150        (format #f "a = acons (make_symbol (scm_~a.car), ~a, a);\n\n" (function.name f) (function-cell-name f)))))
 151
 152 (define (disjoin . predicates)
 153   (lambda (. arguments)
 154     (any (cut apply <> arguments) predicates)))
 155
 156 (define (snarf-symbols string)
 157   (let* ((lines (string-split string #\newline))
 158          (scm (filter (cut string-prefix? "struct scm scm_" <>) lines))
 159          (symbols (filter (disjoin (cut string-contains <> "TSPECIAL") (cut string-contains <> "TSYMBOL")) scm)))
 160     (define (line->symbol line)
 161       ((compose
 162         (lambda (s) (string-take s (string-index s #\space)))
 163         (cut string-drop <> (string-length "struct scm scm_")))
 164        line))
 165     (map line->symbol symbols)))
 166
 167 (define (string-split-string string sep)
 168   (cond ((string-contains string sep) => (lambda (i) (list (string-take string i) (string-drop string (+ i (string-length sep))))))
 169         (else (list string #f))))
 170
 171 (define (snarf-functions string)
 172   (let ((lines (string-split string #\newline)))
 173     (filter-map
 174      (lambda (line previous)
 175        (receive (function rest)
 176            (apply values (string-split-string line " "))
 177          (and function
 178               (equal? (string-trim previous) "SCM")
 179               (not (string-null? function))
 180               (not (string-prefix? "#" function))
 181               (not (string-prefix? "/" function))
 182               rest
 183               (receive (parameter-list annotation)
 184                   (apply values (string-split-string rest " ///"))
 185                 (let* ((parameters (string-drop parameter-list 1))
 186                        (parameters (string-drop-right parameters 1))
 187                        (formals (if (string-null? parameters) '()
 188                                     (string-split parameters #\,)))
 189                        (formals (map string-trim formals)))
 190                   (and parameters
 191                        (let* ((non-SCM (filter (negate (cut string-prefix? "SCM" <>)) formals)))
 192                          (and (null? non-SCM)
 193                               (let ((annotation (and annotation (with-input-from-string annotation read))))
 194                                 (make-function function parameters annotation))))))))))
 195      lines (cons "\n" lines))))
 196
 197 (define (content? f)
 198   ((compose not string-null? file.content) f))
 199
 200 (define (internal? f)
 201   ((compose (cut assoc-ref <> 'internal) function.annotation) f))
 202
 203 (define (no-environment? f)
 204   ((compose (cut assoc-ref <> 'no-environment) function.annotation) f))
 205
 206 (define (generate-includes file-name)
 207   (let* ((srcdest (or (getenv "srcdest") ""))
 208          (string (with-input-from-file (string-append srcdest file-name) read-string))
 209          (functions (snarf-functions string))
 210          (functions (delete-duplicates functions (lambda (a b) (equal? (function.name a) (function.name b)))))
 211          (functions (filter (negate internal?) functions))
 212          (symbols (snarf-symbols string))
 213          (base-name (basename file-name ".c"))
 214          (dir (string-append (dirname file-name)))
 215          (base-name (string-append dir "/" base-name))
 216          (base-name (if %gcc? base-name
 217                         (string-append base-name ".mes")))
 218          (header (make-file
 219                   (string-append base-name ".h")
 220                   (string-join (map function->header functions (iota (length functions) (+ %start (length symbols)))) "")))
 221          (source (make-file
 222                   (string-append base-name ".i")
 223                   (string-join (map function->source (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
 224          (environment (make-file
 225                        (string-append base-name ".environment.i")
 226                        (string-join (map function->environment (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
 227          (symbols.h (make-file
 228                      (string-append base-name ".symbols.h")
 229                      (string-join (map symbol->header symbols (iota (length symbols) %start)) "")))
 230          (symbols.i (make-file
 231                      (string-append base-name ".symbols.i")
 232                      (string-join (map symbol->source symbols (iota (length symbols))) "")))
 233          (symbol-names.i (make-file
 234                           (string-append base-name ".symbol-names.i")
 235                           (string-join (map symbol->names symbols (iota (length symbols))) ""))))
 236     (list header source environment symbols.h symbols.i symbol-names.i)))
 237
 238 (define (file-write file)
 239   (system* "mkdir" "-p" (dirname (file.name file)))
 240   (with-output-to-file (file.name file) (lambda () (display (file.content file)))))
 241
 242 (define (main args)
 243   (let* ((files (if (not (and (pair? (cdr args)) (equal? (cadr args) "--mes"))) (cdr args)
 244                     (begin (set! %gcc? #f)
 245                            (cddr args))))
 246          (files (append-map generate-includes files)))
 247     (map file-write (filter content? files))))