#|
tinyswig - tinybase.scm
A tiny wrapper generator for occam
Copyright (C) 2006-2008 Matthew C. Jadud

 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
 the Free Software Foundation; either version 2 of the License, or
 (at your option) any later version.
 
 This program is distributed in the hope that it will be useful,
 but WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 GNU General Public License for more details.

 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
|#
(module tinybase mzscheme
  (require 
   (lib "contract.ss")
   (lib "pregexp.ss")
   
   (lib "date.ss"))
  
  ;; Pragma prototypes
  (define-struct prototype (name args))
  
  ;; Global script parameters
  (define parameters (make-hash-table))
  
  ;; set-parameter!
  ;; The contract just makes sure that 'p' is a symbol.
  (provide/contract (set-parameter! (symbol? any/c . -> . any/c)))
  (define (set-parameter! p v)
    (hash-table-put! parameters p v))
  
  ;; conditional-set-parameter! 
  ;; Like other parameter functions, the contract 
  ;; simply limits the damage we can do.
  (provide/contract (conditional-set-parameter! (symbol? any/c . -> . any/c)))
  (define (conditional-set-parameter! p v)
    (if (not (get-parameter p))
        (set-parameter! p v)))
  
  ;; get-parameter
  ;; I have a contract here that does little more than make sure
  ;; only symbols come in. 
  (provide/contract (get-parameter (symbol? . -> . any/c)))
  (define (get-parameter p)
    (hash-table-get parameters p (lambda () #f)))
  
  ;; get-basename
  (provide/contract (get-basename (-> string? string?)))
  (define (get-basename filename)
    (let ([fp (string->path filename)])
      (let-values ([(base name d?) (split-path fp)])
        (let ([m (pregexp-match "^(.*)\\.[ch]$" (format "~a" name))])
          (if m 
              (list-ref m 1)
              (raise-user-error 'tinyswig "tinyswig expects a C file or header file ending in '.c' or '.h'~n"))))))
  
  ;; THE LIST OF NAMES
  (define (snoc o ls)
    (append ls (list o)))
  
  (define list-of-names '())
  (define (add-name n)
    (set! list-of-names (snoc n list-of-names)))
  
  (define functions-in-files (make-hash-table))
  (define (add-name-to-file file-name fn-name)
    (hash-table-put! functions-in-files file-name (snoc fn-name (hash-table-get functions-in-files file-name (lambda () '())))))
  
  ;; This has been pulled out for testing purposes.
  (provide/contract (match-line (-> string? (or/c string? boolean?))))
  (define (match-line line)
    (or 
     (pregexp-match "^void\\s+(.*)\\s*\\(int \\*w\\)\\s*;?\\{?\\s*$" line)
     (pregexp-match "^void\\s+(.*)\\s*\\(int w\\[\\]\\)\\s*;?\\{?\\s*$" line)
     (pregexp-match "^void\\s+(.*)\\s*\\(int \\*w\\)\\s*;?\\{?\\s*/\\*\\s*(.*)\\s*\\*/$" line)
     (pregexp-match "^void\\s+(.*)\\s*\\(int w\\[\\]\\)\\s*;?\\{?\\s*/\\*\\s*(.*)\\s*\\*/$" line)))
  
  ;; gather-names-from-file
  (provide/contract (gather-names-from-file (string? . -> . void?)))
  (define (gather-names-from-file file)
    ;; FIXME: open-input-file generates ugly errors atm
    (let ([ip (open-input-file file)])
      (let loop ([line (read-line ip)])
        (unless (eof-object? line)
          (cond
            [(match-line line)
             =>
             (lambda (m)
               (let ([function-name (list-ref m 1)]
		     [prototype (if (> (length m) 2) (list-ref m 2) "")])
		 ;;(printf "Match: ~s~nName: ~a~nPrototypes: ~a~n~n" m function-name prototype)
                 ;;(printf "Found: ~a~n" function-name)
                 (add-name (make-prototype function-name prototype))
                 (add-name-to-file file function-name)
                 ))])
          (loop (read-line ip))))
      (close-input-port ip)))
  
  (provide/contract (list-intersperse (list? any/c . -> . list?)))
  (define (list-intersperse ls o)
    (cond
      [(null? ls) '()]
      [(null? (cdr ls))
       (cons (car ls) (cdr ls))]
      [else
       (cons (car ls)
             (cons o
                   (list-intersperse (cdr ls) o)))]))
  
  (define (tinyswig-c-header)
    (printf "/* File generated by tinyswig on ~a */~n" (date->string (seconds->date (current-seconds)) #t))
    (printf "/* Generated using 'tinyswig ~a' */~n" (apply string-append (list-intersperse (vector->list (current-command-line-arguments)) " ")))
    (printf "/* tinyswig is a part of the Transterpreter toolchain */~n")
    )
   
  ;; output-h-files
  (provide output-h-files)
  (define (output-h-files)
    (hash-table-for-each functions-in-files
                         (lambda (c-filename fns)
                           ;; By default, we're clobbering the file.
                           (let ([header-filename (pregexp-replace "c$" c-filename "h")])
                             (tinycheck header-filename)
                             (let ([op (open-output-file header-filename 'replace)])
                               (parameterize ([current-output-port op])
                                 (tinyswig-c-header)
                                 (for-each (lambda (fn) (printf "void ~a(int w[]);~n" fn)) fns))
                               (close-output-port op)))
                           )))
  
  ;; Check for a good header in the file
  (define (tinycheck file)
    (if (file-exists? file)
        (let ([ip (open-input-file file)]
              [header? #f])
          (let loop ([line (read-line ip)]
                     [count 0])
            (unless (or (eof-object? line)
                        (> count 5))
              ;;(printf "CHK[~a]: ~a~n" count line)
              (if (pregexp-match "generated by tinyswig" line)
                  (set! header? #t)
                  (loop (read-line ip) (add1 count)))))
          (unless header?
            (printf "~n!!! WARNING !!!~n")
            (map (lambda (ls)
                   (apply printf ls))
                 `(("~nTinyswig would like to overwrite the file '~a',~n" ,file)
                   ("but thinks it may belong to you. So, tinyswig has stopped.~n")
                   ("Discretion is always the better part of valor.~n~n")
                   ("~n~nYou may either remove this file, or change the name that tinyswig outputs to~n")
                   ("on the command line; do 'tinyswig -h' for more help.~n~n")
                   ))
            (exit 42)))))
  
  ;; output-c-file
  (provide output-c-file)
  (define (output-c-file)
    
    ;; First, lets make sure the target file is a tinyswig file. If it is, then we
    ;; can clobber it. Otherwise, we probably should bail and let the user know
    ;; that this looks like a bad idea.
    (tinycheck (get-parameter 'c-filename))
    
    (let ([op (open-output-file (get-parameter 'c-filename) 'replace)])
      (parameterize ([current-output-port op])
        (tinyswig-c-header)
        
        (for-each (lambda (header)
                    (printf "#include \"~a\"~n" header))
                  (get-parameter 'c-header-files))
        
        
        (printf "~n/* There are ~a external functions to be hooked in. */~n" 
                (+ (length list-of-names) (get-parameter 'pad)))
        (printf "void *external_function_hooks[] = {~n")
        
        (let* ([max-len (apply max (map string-length (map prototype-name list-of-names)))]
               [pad-string (lambda (str)
                             (make-string (- (+ 5 max-len) (string-length str)) #\space))])
          (let loop ([c 0])
            (unless (= c (get-parameter 'pad))
              (printf "\t~a, ~a /* ~a */~n" "void" (pad-string "void") c)
              (loop (add1 c))))
          
          (let ([c (get-parameter 'pad)])
            (for-each
             (lambda (n)
               (printf "\t~a, ~a /* ~a */~n" 
                       (prototype-name n)
                       (pad-string (prototype-name n))
                       c)
               (set! c (add1 c)))
             list-of-names)))
        
        (printf "};~n~n")
        (printf "void *get_special_hooks()~n{~n")
        (printf "\treturn external_function_hooks;~n}~n")
        (close-output-port op))
      ))
  (define (sanitize-name n)
    (let* ([n (prototype-name n)]
	   [rn (pregexp-replace* "[-_]" n ".")]
	   [the-prefix ""])
      ;; If we're using a prefix, set it here.
      (unless (get-parameter 'no-prefix)
        (let ([pfix (get-parameter 'prefix)])
          (set! the-prefix (format "~a." pfix))))
      
      (let ([pfixrn (format "~a~a" the-prefix rn)]) 
        (printf "Renaming C function '~a' to occam-pi PROC '~a'~n" n pfixrn)
        pfixrn)))
  
  ;; Getting in some poo like
  ;; VAL INT x
  ;; or ...
  ;; VAL INT x, VAL []BYTE y
  ;; So need to split on ',' and then split on spaces, and
  ;; then reverse each sublist and take the last part.
  (define (only-names str)
    ;; We have a bit of a problem with trailing spaces here. They
    ;; are a BAD THING. So, I'm going to strip them before we begin.
    (set! str (pregexp-replace "\\s+$" str ""))
    (let* ([vars-and-types (pregexp-split "\\," str)]
	   [all-bits (map (lambda (s) (pregexp-split " " s)) vars-and-types)]
	   [reversed (map reverse all-bits)]
	   [just-variables (map car reversed)])
      (apply string-append (list-intersperse just-variables ", "))))
  
  (define (multiple-include-guard str)
    (let ([clean (pregexp-replace* "[^a-zA-Z]" str "")]
	  [prefix "GUARD."]
	  [postfix (format ".~a" (current-seconds))])
      (string-append prefix clean postfix)))
  
  ;; output-occam-file
  (provide output-occam-file)
  (define (output-occam-file)
    (let ([occam-filename (get-parameter 'occam-filename)])
      (tinycheck occam-filename)
      
      (let ([op (open-output-file occam-filename 'replace)])
        (fprintf op "-- File generated by tinyswig on ~a ~n"
                 (date->string
                  (seconds->date (current-seconds)) #t))
        (fprintf op "-- tinyswig is a part of the Transterpreter toolchain~n~n")
        (let ([guard (multiple-include-guard (get-parameter 'occam-filename))])
          (fprintf op "#IF NOT DEFINED (~a)~n" guard)
          (fprintf op "#DEFINE ~a TRUE~n~n" guard))
        (let ([c (get-parameter 'pad)])
          (for-each
           (lambda (n)
             (let ([sn (sanitize-name n)])
               (fprintf op "#PRAGMA EXTERNAL \"PROC C.tvmspecial.~a.~a(~a) = 0\"~n" 
                        c sn (prototype-args n))
               (fprintf op "INLINE PROC ~a(~a)~n" sn (prototype-args n))
               (fprintf op "  C.tvmspecial.~a.~a(~a)~n" c sn (only-names (prototype-args n)))
               (fprintf op ":~n~n"))
             (set! c (add1 c)))
           list-of-names))
        (fprintf op "#ENDIF~n")
        (close-output-port op))))
  
  )
