build: configure: Handle VAR=VALUE. Update help.
[mes.git] / build-aux / mes-snarf.scm
index 53c21f147e1936ed4ce60b21a5e597f1c4f25aa4..ed57bc67af5de79bac1992d7595df272fa230d9c 100755 (executable)
@@ -1,10 +1,10 @@
 #! /bin/sh
-# -*- scheme -*-
-exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e '(@@ (mes-snarf) main)' -s "$0" ${1+"$@"}
+# -*-scheme-*-
+exec ${GUILE-guile} -L $(dirname 0) -e '(mes-snarf)' -s "$0" "$@"
 !#
 
 ;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; mes-snarf.scm: This file is part of Mes.
 ;;;
@@ -23,54 +23,80 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
 
 (define-module (mes-snarf)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-8)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
-  #:use-module (ice-9 curried-definitions)
   #:use-module (ice-9 rdelim)
-  #:use-module (ice-9 regex)
-  #:use-module (oop goops))
-
-(define ((regexp-replace regexp replace) string)
-  (or (and=> (string-match regexp string)
-             (cut regexp-substitute #f <> 'pre replace 'post))
+  #:export (main))
+
+(cond-expand
+ (mes
+  (define %scheme "mes"))
+ (guile-2
+  (define %scheme "guile")
+  (define-macro (mes-use-module . rest) #t))
+ (guile
+  (use-modules (ice-9 syncase))
+  (define %scheme "guile")
+  (define-macro (mes-use-module . rest) #t)))
+
+(mes-use-module (mes guile))
+(mes-use-module (srfi srfi-1))
+(mes-use-module (srfi srfi-8))
+(mes-use-module (srfi srfi-9))
+(mes-use-module (srfi srfi-26))
+
+(format (current-error-port) "mes-snarf[~a]...\n" %scheme)
+
+(define (char->char from to char)
+  (if (eq? char from) to char))
+
+(define (string-replace-char string from to)
+  (string-map (cut char->char from to <>) string))
+
+(define (string-replace-suffix string from to)
+  (if (string-suffix? from string)
+      (string-replace string to (- (string-length string) (string-length from)))
       string))
 
-;; (define-record-type function (make-function name formals annotation)
-;;   function?
-;;   (name .name)
-;;   (formals .formals)
-;;   (annotation .annotation))
+(define (string-replace-string string from to)
+  (cond ((string-contains string from) => (lambda (i) (string-replace string to i (+ i (string-length from)))))
+        (else string)))
+
+(define %gcc? #t)
 
-(define-class <file> ()
-  (name #:accessor .name #:init-keyword #:name)
-  (content #:accessor .content #:init-keyword #:content))
+(define-record-type <file> (make-file name content)
+  file?
+  (name file.name)
+  (content file.content))
 
-(define-class <function> ()
-  (name #:accessor .name #:init-keyword #:name)
-  (formals #:accessor .formals #:init-keyword #:formals)
-  (annotation #:accessor .annotation #:init-keyword #:annotation))
+(define-record-type <function> (make-function name formals annotation)
+  function?
+  (name function.name)
+  (formals function.formals)
+  (annotation function.annotation))
 
 (define (function-scm-name f)
-  (or (assoc-ref (.annotation f) 'name)
+  (or (assoc-ref (function.annotation f) 'name)
       (let ((name ((compose
-                    (regexp-replace "_" "-")
-                    (regexp-replace "_" "-")
-                    (regexp-replace "_" "-")
-                    (regexp-replace "_" "-")
-                    (regexp-replace "^builtin_" "")
-                    (regexp-replace "_to_" "->")
-                    (regexp-replace "_x$" "!")
-                    (regexp-replace "_p$" "?"))
-                   (.name f))))
+                    identity
+                    (cut string-replace-char <> #\_ #\-)
+                    (cut string-replace-string <> "_to_" "->")
+                    (cut string-replace-suffix <> "_x" "!")
+                    (cut string-replace-suffix <> "_x_" "!-")
+                    (cut string-replace-suffix <> "_p" "?")
+                    )
+                   (function.name f))))
         (if (not (string-suffix? "-" name)) name
             (string-append "core:" (string-drop-right name 1))))))
 
 (define %builtin-prefix% "scm_")
 (define (function-builtin-name f)
-  (string-append %builtin-prefix% (.name f)))
+  (string-append %builtin-prefix% (function.name f)))
 
 (define %cell-prefix% "cell_")
 (define (function-cell-name f)
-  (string-append %cell-prefix% (.name f)))
+  (string-append %cell-prefix% (function.name f)))
 
 (define %start 1)
 (define (symbol->header s i)
@@ -78,95 +104,141 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
 
 (define (symbol->source s i)
   (string-append
-   (format #f "g_free.value++;\n")
+   (format #f "g_free++;\n")
    (format #f "g_cells[cell_~a] = scm_~a;\n\n" s s)))
 
 (define (symbol->names s i)
-  (string-append
-   (format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.name);\n" s s)))
+  (if %gcc?
+      (format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.name);\n" s s)
+      (format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.car);\n" s s)))
 
 (define (function->header f i)
-  (let* ((arity (or (assoc-ref (.annotation f) 'arity)
-                    (if (string-null? (.formals f)) 0
-                        (length (string-split (.formals f) #\,)))))
+  (let* ((arity (or (assoc-ref (function.annotation f) 'arity)
+                    (if (string-null? (function.formals f)) 0
+                        (length (string-split (function.formals f) #\,)))))
          (n (if (eq? arity 'n) -1 arity)))
     (string-append
-     (format #f "SCM ~a (~a);\n" (.name f) (.formals f))
-     (format #f "function fun_~a = {.function~a=&~a, .arity=~a};\n" (.name f) arity (.name f) n)
-     (format #f "scm ~a = {FUNCTION, .name=~S, .function=0};\n" (function-builtin-name f) (function-scm-name f))
-     (format #f "SCM cell_~a;\n\n" (.name f)))))
+     (format #f "SCM ~a (~a);\n" (function.name f) (function.formals f))
+     (if %gcc?
+         (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))
+         (format #f "struct function fun_~a = {&~a, ~a, ~s};\n" (function.name f) (function.name f) n (function-scm-name f)))
+     (if %gcc?
+         (format #f "struct scm ~a = {TFUNCTION, .name=0, .function=0};\n" (function-builtin-name f))
+         (format #f "struct scm ~a = {TFUNCTION, 0, 0};\n" (function-builtin-name f)))
+     (format #f "SCM cell_~a;\n\n" (function.name f)))))
 
 (define (function->source f i)
   (string-append
-   (format #f "~a.function = g_function;\n" (function-builtin-name f))
-   (format #f "functions[g_function++] = fun_~a;\n" (.name f))
-   (format #f "cell_~a = g_free.value++;\n" (.name f))
-   (format #f "g_cells[cell_~a] = ~a;\n\n" (.name f) (function-builtin-name f))))
+   (if %gcc?
+       (format #f "~a.function = g_function;\n" (function-builtin-name f))
+       (format #f "~a.cdr = g_function;\n" (function-builtin-name f)))
+   (format #f "g_functions[g_function++] = fun_~a;\n" (function.name f))
+   (format #f "cell_~a = g_free++;\n" (function.name f))
+   (format #f "g_cells[cell_~a] = ~a;\n\n" (function.name f) (function-builtin-name f))))
 
 (define (function->environment f i)
   (string-append
-   (format #f "scm_~a.string = cstring_to_list (scm_~a.name);\n" (.name f) (.name f))
-   (format #f "a = acons (make_symbol (scm_~a.string), ~a, a);\n" (.name f) (function-cell-name f))
-   ;;(format #f "a = add_environment (a, ~S, ~a);\n" (function-scm-name f) (function-cell-name f))
-   ))
+   (if %gcc?
+       (format #f "scm_~a.string = cstring_to_list (fun_~a.name);\n" (function.name f) (function.name f))
+       (format #f "scm_~a.car = cstring_to_list (fun_~a.name);\n" (function.name f) (function.name f)))
+   (if %gcc?
+       (format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (function.name f) (function.name f))
+       (format #f "g_cells[cell_~a].car = MAKE_STRING (scm_~a.car);\n" (function.name f) (function.name f)))
+   (if %gcc?
+       (format #f "a = acons (lookup_symbol_ (scm_~a.string), ~a, a);\n\n" (function.name f) (function-cell-name f))
+       (format #f "a = acons (lookup_symbol_ (scm_~a.car), ~a, a);\n\n" (function.name f) (function-cell-name f)))))
+
+(define (disjoin . predicates)
+  (lambda (. arguments)
+    (any (cut apply <> arguments) predicates)))
 
 (define (snarf-symbols string)
-  (let* ((matches (append (list-matches "\nscm scm_([a-z_0-9]+) = [{](SPECIAL)," string)
-                          (list-matches "\nscm scm_([a-z_0-9]+) = [{](SYMBOL)," string))))
-    (map (cut match:substring <> 1) matches)))
+  (let* ((lines (string-split string #\newline))
+         (scm (filter (cut string-prefix? "struct scm scm_" <>) lines))
+         (symbols (filter (disjoin (cut string-contains <> "TSPECIAL") (cut string-contains <> "TSYMBOL")) scm)))
+    (define (line->symbol line)
+      ((compose
+        (lambda (s) (string-take s (string-index s #\space)))
+        (cut string-drop <> (string-length "struct scm scm_")))
+       line))
+    (map line->symbol symbols)))
+
+(define (string-split-string string sep)
+  (cond ((string-contains string sep) => (lambda (i) (list (string-take string i) (string-drop string (+ i (string-length sep))))))
+        (else (list string #f))))
 
 (define (snarf-functions string)
-  (let* ((matches (list-matches
-                   "\nSCM[ \n]?([a-z0-9_]+) [(]((SCM ?[^,)]+|, )*)[)][^\n(]*([^\n]*)"
-                   string)))
-    (map (lambda (m)
-           (make <function>
-             #:name (match:substring m 1)
-             #:formals (match:substring m 2)
-             #:annotation (with-input-from-string (match:substring m 4) read)))
-         matches)))
+  (let ((lines (string-split string #\newline)))
+    (filter-map
+     (lambda (line previous)
+       (receive (function rest)
+           (apply values (string-split-string line " "))
+         (and function
+              (equal? (string-trim previous) "SCM")
+              (not (string-null? function))
+              (not (string-prefix? "#" function))
+              (not (string-prefix? "/" function))
+              rest
+              (receive (parameter-list annotation)
+                  (apply values (string-split-string rest " ///"))
+                (let* ((parameters (string-drop parameter-list 1))
+                       (parameters (string-drop-right parameters 1))
+                       (formals (if (string-null? parameters) '()
+                                    (string-split parameters #\,)))
+                       (formals (map string-trim formals)))
+                  (and parameters
+                       (let* ((non-SCM (filter (negate (cut string-prefix? "SCM" <>)) formals)))
+                         (and (null? non-SCM)
+                              (let ((annotation (and annotation (with-input-from-string annotation read))))
+                                (make-function function parameters annotation))))))))))
+     lines (cons "\n" lines))))
 
 (define (content? f)
-  ((compose not string-null? .content) f))
+  ((compose not string-null? file.content) f))
 
 (define (internal? f)
-  ((compose (cut assoc-ref <> 'internal) .annotation) f))
+  ((compose (cut assoc-ref <> 'internal) function.annotation) f))
 
 (define (no-environment? f)
-  ((compose (cut assoc-ref <> 'no-environment) .annotation) f))
+  ((compose (cut assoc-ref <> 'no-environment) function.annotation) f))
 
 (define (generate-includes file-name)
   (let* ((string (with-input-from-file file-name read-string))
          (functions (snarf-functions string))
-         (functions (delete-duplicates functions (lambda (a b) (equal? (.name a) (.name b)))))
+         (functions (delete-duplicates functions (lambda (a b) (equal? (function.name a) (function.name b)))))
          (functions (filter (negate internal?) functions))
          (symbols (snarf-symbols string))
          (base-name (basename file-name ".c"))
-         (header (make <file>
-                   #:name (string-append base-name ".h")
-                   #:content (string-join (map function->header functions (iota (length functions) (+ %start (length symbols)))) "")))
-         (source (make <file>
-                        #:name (string-append base-name ".i")
-                        #:content (string-join (map function->source (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) ""))) 
-         (environment (make <file>
-                        #:name (string-append base-name ".environment.i")
-                        #:content (string-join (map function->environment (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
-         (symbols.h (make <file>
-                      #:name (string-append base-name ".symbols.h")
-                      #:content (string-join (map symbol->header symbols (iota (length symbols) %start)) "")))
-         (symbols.i (make <file>
-                      #:name (string-append base-name ".symbols.i")
-                      #:content (string-join (map symbol->source symbols (iota (length symbols))) "")))
-         (symbol-names.i (make <file>
-                          #:name (string-append base-name ".symbol-names.i")
-                          #:content (string-join (map symbol->names symbols (iota (length symbols))) ""))))
+         (dir (or (getenv "OUT") (dirname file-name)))
+         (base-name (string-append dir "/" base-name))
+         (base-name (if %gcc? base-name
+                        (string-append base-name ".mes")))
+         (header (make-file
+                  (string-append base-name ".h")
+                  (string-join (map function->header functions (iota (length functions) (+ %start (length symbols)))) "")))
+         (source (make-file
+                  (string-append base-name ".i")
+                  (string-join (map function->source (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) ""))) 
+         (environment (make-file
+                       (string-append base-name ".environment.i")
+                       (string-join (map function->environment (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
+         (symbols.h (make-file
+                     (string-append base-name ".symbols.h")
+                     (string-join (map symbol->header symbols (iota (length symbols) %start)) "")))
+         (symbols.i (make-file
+                     (string-append base-name ".symbols.i")
+                     (string-join (map symbol->source symbols (iota (length symbols))) "")))
+         (symbol-names.i (make-file
+                          (string-append base-name ".symbol-names.i")
+                          (string-join (map symbol->names symbols (iota (length symbols))) ""))))
     (list header source environment symbols.h symbols.i symbol-names.i)))
 
 (define (file-write file)
-  (with-output-to-file (.name file) (lambda () (display (.content file)))))
+  (with-output-to-file (file.name file) (lambda () (display (file.content file)))))
 
 (define (main args)
-  (let* ((files (cdr args)))
-    (map file-write (filter content? (append-map generate-includes files)))))
-
-;;(define string (with-input-from-file "../mes.c" read-string))
+  (let* ((files (if (not (and (pair? (cdr args)) (equal? (cadr args) "--mes"))) (cdr args)
+                    (begin (set! %gcc? #f)
+                           (cddr args))))
+         (files (append-map generate-includes files)))
+    (map file-write (filter content? files))))