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* ((n (or (assoc-ref (.annotation f) 'args)
  77                 (if (string-null? (.formals f)) 0
  78                     (length (string-split (.formals f) #\,))))))
  79     (string-append (format #f "scm *~a (~a);\n" (.name f) (.formals f))
  80                    (format #f "scm ~a = {FUNCTION~a, .name=~S, .function~a=&~a};\n" (function-builtin-name f) n (function-scm-name f) n (.name f)))))
  81
  82 (define (snarf-symbols string)
  83   (let* ((matches (list-matches "\nscm ([a-z_0-9]+) = [{](SCM|SYMBOL)," string)))
  84     (map (cut match:substring <> 1) matches)))
  85
  86 (define (snarf-functions string)
  87   (let* ((matches (list-matches
  88                    "\nscm [*]\n?([a-z0-9_]+) [(]((scm *[^,)]+|, )*)[)][^\n(]*([^\n]*)"
  89                    string)))
  90     (map (lambda (m)
  91            (make <function>
  92              #:name (match:substring m 1)
  93              #:formals (match:substring m 2)
  94              #:annotation (with-input-from-string (match:substring m 4) read)))
  95          matches)))
  96
  97 (define (internal? f)
  98   ((compose (cut assoc-ref <> 'internal) .annotation) f))
  99
 100 (define (no-environment? f)
 101   ((compose (cut assoc-ref <> 'no-environment) .annotation) f))
 102
 103 (define (generate-includes file-name)
 104   (let* ((string (with-input-from-file file-name read-string))
 105          (functions (snarf-functions string))
 106          (functions (delete-duplicates functions (lambda (a b) (equal? (.name a) (.name b)))))
 107          (functions (sort functions (lambda (a b) (string< (.name a) (.name b)))))
 108          (functions (filter (negate internal?) functions))
 109          (symbols (snarf-symbols string))
 110          (base-name (basename file-name ".c"))
 111          (header (make <file>
 112                    #:name (string-append base-name ".environment.h")
 113                    #:content (string-join (map function->header functions))))
 114          (environment (make <file>
 115                         #:name (string-append base-name ".environment.i")
 116                         #:content (string-join (map function->source (filter (negate no-environment?) functions)))))
 117          (symbols (make <file>
 118                     #:name (string-append base-name ".symbols.i")
 119                     #:content (string-join (map symbol->source symbols)))))
 120     (list header environment symbols)))
 121
 122 (define (file-write file)
 123   (with-output-to-file (.name file) (lambda () (display (.content file)))))
 124
 125 (define (main args)
 126   (let* ((files (cdr args)))
 127     (map file-write (append-map generate-includes files))))
 128
 129 ;;(define string (with-input-from-file "../mes.c" read-string))
 130