;; guile-inline
;; Copyright (C) 2011 
;; NalaGinrut <address@hidden>

;; This library is free software; you can redistribute it and/or modify
;; it under the terms of the GNU Lesser General Public License as
;; published by the Free Software Foundation; either version 3 of the
;; License, or (at your option) any later version.
;;                                                                  
;; This library 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
;; Lesser General Public License for more details.
;;                                                                  
;; You should have received a copy of the GNU Lesser General Public
;; License along with this program; if not, contact:
;;
;; Free Software Foundation           Voice:  +1-617-542-5942
;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
;; Boston, MA  02111-1307,  USA       address@hidden



(define-module (inline inline)
  #:use-module (oop goops)
  #:use-module (ice-9 regex)
  #:use-module (system foreign)

  #:export (<inline>
	    inline:eat-code
	    inline:get
	    )
  )

(define type-regexp "([A-Za-z0-9_]+) ([A-Za-z0-9_]+)\\(([A-Z0-9a-z_ ,]*)\\)")
(define arg-type-regexp "([a-zA-Z0-9_]+) [a-zA-Z0-9_]+")
(define func-type 1)
(define func-name 2)
(define args 3)

(define fname 0)
(define fargs 1)
(define ftype 2)
(define fargs-types 3)

(define match-decl
  (lambda (decl)
    (lambda (which)
      (match:substring 
       (string-match type-regexp decl)
       which))))

(define get-args-type-list
  (lambda (args)
    (let* ((al (string-split args #\,))
	   (sl (map (lambda (x)
		      (string->type
		       (match:substring (string-match arg-type-regexp x) 1)))
		    al))
	   )
      sl
      )))

(define string->type
  (lambda (str)
    (eval (string->symbol str) (current-module))))

(define gen-load-path
  (lambda ()
    (string-append %compile-fallback-path (getcwd) "/")))

(define-class <inline> ()
  ;; this name will be the .so file name
  (name #:init-value "example" #:init-keyword #:name)
  
  (so-path #:init-form (gen-load-path) #:init-keyword #:so-path)
  (tmp-path #:init-value "/tmp/")

  ;; target name with complete path
  (target #:init-value #f #:accessor inline:target)

  ;; func is C-side function info
  (info #:init-value #f #:accessor inline:info)

  ;; keep the code string in case we need regenerate .so
  (code #:init-value #f #:accessor inline:code)

  ;; this is dynamic FFI
  (ffi #:init-value #f #:accessor inline:ffi)
  )

(define-method (inline:gen-so (in <inline>))
  (let* (;; NOTE: I chose -fpic which implies -msmall-data
	 ;;       And I think inline code must be smart.So
	 ;;       please take care of this.
	 (name (slot-ref in 'name))
	 (c-name (string-append 
		  (slot-ref in 'tmp-path) name ".c"))
	 (so-name (string-append 
		   (slot-ref in 'so-path) (basename (car (command-line))) "." name ".so"))
	 (cc-cmd (string-append
		  "cc -shared -fpic "
		  c-name " -o" so-name))
	 (code (inline:code in))
	 (output (open-file c-name "w"))
	 )

    ;; write C code to a tmp file
    (format output "~a~%" code)
    (close output)
    
    (if
     (eqv? (system cc-cmd) 0)
     (set! (inline:target in) so-name)
     (error inline:gen-so "compile inline function error")
     )))    

(define-method (inline:update-code (in <inline>) (code <string>))
  (if (not (inline:code in))
      (set! (inline:code in) code)))

(define-method (inline:update-info (in <inline>) (info <list>))
  (if (not (inline:code in))
      (set! (inline:info in) info)))
 
(define-method (inline:update-ffi (in <inline>))
  (let* ((so-file (inline:target in))
	 (dso (dynamic-link so-file))
	 (info (inline:info in))
	 (fn (list-ref info fname))
	 (args (list-ref info fargs))
	 (ft (list-ref info ftype))
	 (at (list-ref info fargs-types))
	 (ffi
	  (pointer->procedure ft
			      (dynamic-func fn dso)
			      at
			      ))
	 )
    
    (set! (inline:ffi in) ffi)
    ))
	
		
(define-method (inline:eat-code (in <inline>) (code <string>))
  (let* ((decl (string-copy code 0 (string-index code #\{)))
	 (match-type (match-decl decl))
	 (ft (string->type (match-type func-type)))
	 (args (match-type args))
	 (at (get-args-type-list args))
	 (fn (match-type func-name))
	 (info (list fn args ft at))
	 )
    (inline:update-info in info)
    (inline:update-code in code)
    ;; generate .so file
    (inline:gen-so in)
    (inline:update-ffi in)
    ))

(define-method (inline:get (in <inline>))
  (let* ((target (inline:target in))
	 (code (inline:code in))
	 (status #f)
	 )
    ;; if target isn't exist, re-generate it.
    (if (not target) 
	(inline:eat-code in code))

    (set! status (stat target))

    ;; if target is newer than last accession,
    ;; update the ffi.
    (if (> (stat:mtime status) (stat:atime status))
	(inline:update-ffi in))
    
    ;; return ffi
    (inline:ffi in)
    ))