meta-create-c-binding.scm

(use-modules (ice-9 textual-ports))
(use-modules (ice-9 format))
(use-modules (srfi srfi-1))

(define comma-separator ", ")

(define functions-file (car (cdr (command-line))))

(define (read-lines port lines)
  (let ((line (get-line port)))
    (if (eof-object? line)
        lines
        (read-lines port (cons line lines)))))

(define (read-specifications path port)
  (let* ((port (open-input-file path))
         (results (read-lines port '())))
    (close-port port)
    (reverse results)))

(define header
  (list
   "/*\n"
   " * This code was automatically generated by meta-create-c-binding.scm.\n"
   " * Do not edit directly\n"
   " */\n"
   "\n"))

(define (write-lines lines . rest)
  (let ((port (if (null? rest) #t (car rest))))
   (map (lambda (line)
          (format port "~a" line))
        lines)))

(define generate-function-lines)

(define (call-argument-from-index index)
  (format #f "call_arg_~d" index))

(define (get-check-function-for-type type)
  (case type
    ((int) "scm_exact_integer_p")
    ((char*) "scm_string_p")
    ((PyObject*) "pyobject_type_p")
    ((longlong) "scm_integer_p")
    ((double) "scm_real_p")))

(define (expand-check-value arguments)
  (let ((error-location (car arguments))
        (variable-name (cadr arguments))
        (type (list-ref arguments 2)))
    (list
     (format #f "if(!~a(~a)) {\n" (get-check-function-for-type type) variable-name)
     (format #f "\treturn raise_error(~s, \"Invalid value provided\");\n" error-location)
     (format #f "}\n"))))

(define (get-convert-function-for-type type)
  (case type
    ((int) "convert_to_int")
    ((char*) "convert_to_allocated_string")
    ((PyObject*) "convert_to_pyobject")
    ((longlong) "convert_to_longlong")
    ((double) "scm_to_double")))

(define (get-type-from-type-name type-name)
  (case type-name
    ((int) "int")
    ((char*) "char*")
    ((PyObject*) "PyObject*")
    ((longlong) "long long")
    ((double) "double")))

(define (expand-convert-from-scheme arguments)
  (let ((input-name (car arguments))
        (result-name (cadr arguments))
        (type (list-ref arguments 2)))
    (list
     (format #f "~a ~a = ~a(~a);\n\n" (get-type-from-type-name type) result-name (get-convert-function-for-type type) input-name))))

(define (expand-return arguments)
  (list
   (format #f "return ~a;\n" (car arguments))))

(define (expand-group arguments)
  (let ((group-pseudocodes (car arguments)))
    (append '("{\n")
            (map (lambda (string) (string-append "\t" string))
                 (generate-function-lines group-pseudocodes))
            '("}\n\n"))))

(define (expand-convert-to-scheme arguments)
  (let ((input-name (car arguments))
        (result-name (cadr arguments))
        (type (list-ref arguments 2)))
    (list
     (case type
       ((int) (format #f "SCM ~a = scm_from_int(~a);\n" result-name input-name))
       ((char*) (error "not implemented!")) ; TODO/FIXME
       ((PyObject*) (format #f "SCM ~a = checked_pyobject_to_scheme(~a);\n" result-name input-name))
       ((longlong) (format #f "SCM ~a = scm_from_long_long(~a);\n" result-name input-name))
       ((double) (format #f "SCM ~a = scm_from_double(~a);\n" result-name input-name))))))

(define (create-call-arguments-list arg-names)
  (string-join (map (lambda (name)
                        (format #f "~a" name))
                    arg-names)
               comma-separator))

(define (expand-function-execute arguments)
  (let ((return-type (car arguments))
        (function-name (cadr arguments))
        (arguments-names (list-ref arguments 2))
        (return-variable (list-ref arguments 3)))
    (list
     (format #f "~a ~a;\n" (get-type-from-type-name return-type) return-variable)
     (format #f "WITH_PYTHON_LOCK(~a = ~a(~a));\n\n" return-variable function-name (create-call-arguments-list arguments-names)))))

(define (expand-sub-execute arguments)
  (let ((function-name (car arguments))
        (arguments-names (cadr arguments)))
    (list
     (format #f "WITH_PYTHON_LOCK(~a(~a));\n" function-name (create-call-arguments-list arguments-names)))))

(define (function-argument-from-index index)
  (format #f "scm_arg_~d" index))

(define (create-function-arguments-list n-arguments)
  (string-join (map (lambda (index)
                      (format #f "SCM ~a" (function-argument-from-index index)))
                    (iota n-arguments))
               comma-separator))

(define (expand-header arguments)
  (let ((wrapper-name (cadr arguments))
        (n-arguments (list-ref arguments 2)))
   (list
    (format #f "SCM ~a(~a)\n" wrapper-name (create-function-arguments-list n-arguments)))))

(define (expand-comment arguments)
  arguments)

(define (expand-free arguments)
  (let ((var-name (car arguments)))
    (list
     (format #f "free(~a);\n" var-name))))

(define (get-expansion-function type) ;; TODO/FIXME convert to a case!
  (cond
   ((eqv? type ':comment)
    expand-comment)
   ((eqv? type ':header)
    expand-header)
   ((eqv? type ':sub-execute)
    expand-sub-execute)
   ((eqv? type ':function-execute)
    expand-function-execute)
   ((eqv? type ':convert-to-scheme)
    expand-convert-to-scheme)
   ((eqv? type ':return)
    expand-return)
   ((eqv? type ':group)
    expand-group)
   ((eqv? type ':check-value)
    expand-check-value )
   ((eqv? type ':convert-from-scheme)
    expand-convert-from-scheme)
   ((eqv? type ':free)
    expand-free)))

(define (expand-pseudo-instruction pseudocode)
  (let ((type (car pseudocode))
        (arguments (cdr pseudocode)))
    (apply (get-expansion-function type) (list arguments))))

(define (generate-function-lines pseudocodes)
  (fold (lambda (pseudo-instruction previous)
          (append previous (expand-pseudo-instruction pseudo-instruction)))
        '()
        pseudocodes))

(define (froobzo index function-name type)
  (let ((function-arg (function-argument-from-index index))
        (call-arg (call-argument-from-index index)))
   `((:check-value ,(format #f "Argument ~d for ~a" index function-name)
                   ,function-arg
                   ,type)
     (:convert-from-scheme ,function-arg ,call-arg ,type))))

(define (create-arguments-pseudocode-blocks function-name arguments)
  (fold append '()  (map (lambda (index type)
                          (froobzo index function-name type))
                        (iota (length arguments))
                        arguments)))

(define (create-free-operations args-range args)
  (map (lambda (index)
         `(:free ,(call-argument-from-index index)))
       (map car
            (filter (lambda (pair)
                      (eq? 'char* (cdr pair)))
                    (map cons args-range args)))))

(define (python-c-name-to-c-wrapper-name python-name)
  (format #f "~a_wrapper" python-name))

(define (create-pseudocode specification)
  (let ((return-value (car specification))
        (name (list-ref specification 1))
        (args (list-ref specification 2)))
    (let* ((args-range (iota (length args)))
           (function-arguments (map function-argument-from-index args-range))
           (call-arguments (map call-argument-from-index args-range))
           (free-operations (create-free-operations args-range args)))
      `((:comment ,(format #f "// ~a\n" name))
        (:header ,return-value ,(python-c-name-to-c-wrapper-name name) ,(length args))
        (:group
         (,@(create-arguments-pseudocode-blocks name args)
          ,@(if (eq? return-value 'void)
                `((:sub-execute ,name ,call-arguments)
                  ,@free-operations
                  (:return SCM_UNSPECIFIED))
                `((:function-execute ,return-value ,name ,call-arguments result) ;;; ADDED AN ARGUMENT
                  ,@free-operations
                  (:convert-to-scheme result scm_result ,return-value)
                  (:return scm_result)))))))))

(define (translate-specification raw-specification)
  (eval-string
   (string-append "'(" raw-specification ")")))

;;;TODO/FIXME this one only uses the first function and ignores the other!
(define-macro (broken-> value . functions)
  (let ((input (make-symbol "result")))
    `(let ((,input ,value))
       (,(car functions) ,input))))

(define (write-functions-wrappers-to-port path-to-templates port)
  (write-lines header port)
    (map (lambda (lines) (write-lines lines port))
         (map generate-function-lines
              (map create-pseudocode
                   (map translate-specification
                        (read-specifications path-to-templates port))))))

(define (write-functions-wrappers path-to-templates)
  (let ((port (open-output-file "auto-wrappers.c")))
    (write-functions-wrappers-to-port path-to-templates port)
    (close-port port)))

(define (camel-to-kebab name)
  (apply string (reverse (fold append '()
                       (map (lambda (char)
                              (if (char-upper-case? char)
                                  (list (char-downcase char) #\-)
                                  (list char)))
                            (string->list name))))))

(define (string-all-upcase? string)
  (eqv? 0 (length (filter char-lower-case? (string->list string)))))

(define (python-c-name-to-scheme-name c-name)
  (let* ((tokens (string-split c-name #\_))
         (head (string-downcase (car tokens)))
         (raw-tail (cadr tokens))
         (tail (if (string-all-upcase? raw-tail)
                   (string-append "-" (string-downcase raw-tail))
                   (camel-to-kebab raw-tail))))
    (string-append head tail)))

(define (specification-to-gsubr specification)
  (let ((python-c-name (symbol->string (list-ref specification 1)))
        (arguments (list-ref specification 2)))
    (let ((scheme-name (python-c-name-to-scheme-name python-c-name))
          (wrapper-name (python-c-name-to-c-wrapper-name python-c-name))
          (n-args (length arguments)))
      (format #f "scm_c_define_gsubr(\"~a\", ~d, 0, 0, ~a);\n"
              scheme-name n-args wrapper-name))))

;; TODO/FIXME factorize the line reading
(define (write-gsubr-definitions-to-port path-to-templates port)
  (let ((lines (map specification-to-gsubr
                    (map translate-specification
                         (read-specifications path-to-templates port)))))    
    (write-lines lines port)))

;; TODO/FIXME duplicated code
(define (write-gsubr-definitions path-to-templates)
  (let ((port (open-output-file "auto-define-gsubr.c")))
    (write-gsubr-definitions-to-port path-to-templates port)
    (close-port port)))

(define (specification-to-scheme-function specification)
  (format #f "(export ~a)\n" (python-c-name-to-scheme-name
                     (symbol->string
                      (cadr specification)))))

(define (write-exported-definitions-to-port path-to-templates port)
  (let ((lines (map specification-to-scheme-function
                    (map translate-specification
                         (read-specifications path-to-templates port)))))    
    (write-lines lines port)))

(define (write-exported-definitions path-to-templates)
  (let ((port (open-output-file "auto-exported.txt")))
    (write-exported-definitions-to-port path-to-templates port)
    (close-port port)))

(write-functions-wrappers functions-file)
(write-gsubr-definitions functions-file)
(write-exported-definitions functions-file)