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,2017 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? #t)
  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 "_to_" "->")
  61                     (regexp-replace "_x$" "!")
  62                     (regexp-replace "_p$" "?")
  63                     (regexp-replace "___" "***")
  64                     (regexp-replace "___" "***"))
  65                    (.name f))))
  66         (if (not (string-suffix? "-" name)) name
  67             (string-append "core:" (string-drop-right name 1))))))
  68
  69 (define %builtin-prefix% "scm_")
  70 (define (function-builtin-name f)
  71   (string-append %builtin-prefix% (.name f)))
  72
  73 (define %cell-prefix% "cell_")
  74 (define (function-cell-name f)
  75   (string-append %cell-prefix% (.name f)))
  76
  77 (define %start 1)
  78 (define (symbol->header s i)
  79   (format #f "#define cell_~a ~a\n" s i))
  80
  81 (define (symbol->source s i)
  82   (string-append
  83    (format #f "g_free++;\n")
  84    (format #f "g_cells[cell_~a] = scm_~a;\n\n" s s)))
  85
  86 (define (symbol->names s i)
  87   (if %gcc?
  88       (format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.name);\n" s s)
  89       (format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.car);\n" s s)))
  90
  91 (define (function->header f i)
  92   (let* ((arity (or (assoc-ref (.annotation f) 'arity)
  93                     (if (string-null? (.formals f)) 0
  94                         (length (string-split (.formals f) #\,)))))
  95          (n (if (eq? arity 'n) -1 arity)))
  96     (string-append
  97      (format #f "SCM ~a (~a);\n" (.name f) (.formals f))
  98      (if %gcc?
  99          (format #f "struct function fun_~a = {.function~a=&~a, .arity=~a, .name=~s};\n" (.name f) arity (.name f) n (function-scm-name f))
 100          (format #f "struct function fun_~a = {&~a, ~a, ~s};\n" (.name f) (.name f) n (function-scm-name f)))
 101      (if %gcc?
 102          (format #f "struct scm ~a = {TFUNCTION, .name=0, .function=0};\n" (function-builtin-name f))
 103          (format #f "struct scm ~a = {TFUNCTION, 0, 0};\n" (function-builtin-name f)))
 104      (format #f "SCM cell_~a;\n\n" (.name f)))))
 105
 106 (define (function->source f i)
 107   (string-append
 108    (if %gcc?
 109        (format #f "~a.function = g_function;\n" (function-builtin-name f))
 110        (format #f "~a.cdr = g_function;\n" (function-builtin-name f)))
 111    (format #f "g_functions[g_function++] = fun_~a;\n" (.name f))
 112    (format #f "cell_~a = g_free++;\n" (.name f))
 113    (format #f "g_cells[cell_~a] = ~a;\n\n" (.name f) (function-builtin-name f))))
 114
 115 (define (function->environment f i)
 116   (string-append
 117    (if %gcc?
 118        (format #f "scm_~a.string = cstring_to_list (fun_~a.name);\n" (.name f) (.name f))
 119        (format #f "scm_~a.car = cstring_to_list (fun_~a.name);\n" (.name f) (.name f)))
 120    (if %gcc?
 121        (format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (.name f) (.name f))
 122        (format #f "g_cells[cell_~a].car = MAKE_STRING (scm_~a.car);\n" (.name f) (.name f)))
 123    (if %gcc?
 124        (format #f "a = acons (lookup_symbol_ (scm_~a.string), ~a, a);\n\n" (.name f) (function-cell-name f))
 125        (format #f "a = acons (lookup_symbol_ (scm_~a.car), ~a, a);\n\n" (.name f) (function-cell-name f)))))
 126
 127 (define (snarf-symbols string)
 128   (let* ((matches (list-matches "\nstruct scm scm_([a-z_0-9]+) = [{](TSPECIAL|TSYMBOL)," string)))
 129     (map (cut match:substring <> 1) matches)))
 130
 131 (define (snarf-functions string)
 132   (let* ((matches (list-matches
 133                    "\nSCM[ \n]?([a-z0-9_]+) [(]((SCM ?[^,)]+|, )*)[)][^\n(]*([^\n]*)"
 134                    string)))
 135     (map (lambda (m)
 136            (make <function>
 137              #:name (match:substring m 1)
 138              #:formals (match:substring m 2)
 139              #:annotation (with-input-from-string (match:substring m 4) read)))
 140          matches)))
 141
 142 (define (content? f)
 143   ((compose not string-null? .content) f))
 144
 145 (define (internal? f)
 146   ((compose (cut assoc-ref <> 'internal) .annotation) f))
 147
 148 (define (no-environment? f)
 149   ((compose (cut assoc-ref <> 'no-environment) .annotation) f))
 150
 151 (define (generate-includes file-name)
 152   (let* ((string (with-input-from-file file-name read-string))
 153          (functions (snarf-functions string))
 154          (functions (delete-duplicates functions (lambda (a b) (equal? (.name a) (.name b)))))
 155          (functions (filter (negate internal?) functions))
 156          (symbols (snarf-symbols string))
 157          (base-name (basename file-name ".c"))
 158          (dir (or (getenv "OUT") "out"))
 159          (base-name (string-append dir "/" base-name))
 160          (base-name (if %gcc? base-name
 161                         (string-append base-name ".mes")))
 162          (header (make <file>
 163                    #:name (string-append base-name ".h")
 164                    #:content (string-join (map function->header functions (iota (length functions) (+ %start (length symbols)))) "")))
 165          (source (make <file>
 166                         #:name (string-append base-name ".i")
 167                         #:content (string-join (map function->source (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
 168          (environment (make <file>
 169                         #:name (string-append base-name ".environment.i")
 170                         #:content (string-join (map function->environment (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
 171          (symbols.h (make <file>
 172                       #:name (string-append base-name ".symbols.h")
 173                       #:content (string-join (map symbol->header symbols (iota (length symbols) %start)) "")))
 174          (symbols.i (make <file>
 175                       #:name (string-append base-name ".symbols.i")
 176                       #:content (string-join (map symbol->source symbols (iota (length symbols))) "")))
 177          (symbol-names.i (make <file>
 178                           #:name (string-append base-name ".symbol-names.i")
 179                           #:content (string-join (map symbol->names symbols (iota (length symbols))) ""))))
 180     (list header source environment symbols.h symbols.i symbol-names.i)))
 181
 182 (define (file-write file)
 183   (with-output-to-file (.name file) (lambda () (display (.content file)))))
 184
 185 (define (main args)
 186   (let* ((files (if (not (and (pair? (cdr args)) (equal? (cadr args) "--mes"))) (cdr args)
 187                     (begin (set! %gcc? #f)
 188                            (cddr args)))))
 189     (map file-write (filter content? (append-map generate-includes files)))))
 190
 191 ;;(define string (with-input-from-file "../mes.c" read-string))