;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; RFFI - Ron's Foreign Function Interface
;;; 

(defun ff-lookup (name) (%REFERENCE-EXTERNAL-ENTRY-POINT (external name)))

(defun ff-load (path) (open-shared-library path))

(defconstant +bytes-per-int+ (ceiling (log most-positive-fixnum 2) 8))

(defconstant +signed-int-type+ (getf '(4 :signed-fullword 8 :signed-doubleword) +bytes-per-int+))
(defconstant +unsigned-int-type+ (getf '(4 :unsigned-fullword 8 :unsigned-doubleword) +bytes-per-int+))

(defun convert-ff-type (type)
  (or (getf '(:int #.+signed-int-type+
              :uint #.+unsigned-int-type+
	      :int64 :signed-doubleword
              :uint64 :unsigned-doubleword
	      :int32 :signed-fullword
	      :uint32 :unsigned-fullword
              :ptr :address
              :cstr :address)
            type)
      type))

(defun safe-get-cstring (ptr)
  (if (%null-ptr-p ptr) nil (%get-cstring ptr)))

; DEFFF = DEFine Foreign Function
;
(defmacro defff (name (&rest argtypes) return-type)
  (let ( (c-name (if (consp name) (first name) name))
         (lisp-name (if (consp name) (second name) (intern (string-upcase name)))) )
    (let ( (args (mapcar (lambda (type) (gensym (symbol-name type))) argtypes)) )
      `(defun ,lisp-name ,args
         (with-cstrs ,(remove nil
                              (mapcar (lambda (arg type)
                                        (if (eq type :cstr) (list arg arg) '()))
                                      args argtypes))
           (,(if (eq return-type :cstr) 'safe-get-cstring 'identity)
            (ccl:ff-call
             ,(ff-lookup c-name)
             ,@(loop for type in argtypes for arg in args
                     collect (convert-ff-type type)
                     collect arg)
             ,(convert-ff-type return-type))))))))

(shadow 'ff-call)

;;; NOTE: The argument format for this FF-CALL is different from the normal
;;; MCL FF_CALL.  The format for this FF-CALL is:
;;;
;;;   (ff-call [return-type] name-or-entry-point [type] arg ...)
;;;
;;; Note that the types are optional.  If you leave them out FF-CALL will do
;;; its best to do the Right Thing.
;;;
;;; Note also that while you can pass an entry point instead of a name that
;;; doesn't save you very much because ff-lookup caches its results.
;;;
;;; In general, using FF-CALL is a bad idea.  Use DEFFF instead.

(defun ff-call (ff &rest args)
  (let ( (return-type :address) )
    (when (keywordp ff)
      (setf return-type (convert-ff-type ff))
      (setf ff (pop args)))
    (unless (fixnump ff) (setf ff (ff-lookup ff)))
    (if (keywordp (first args))
      (apply #'ccl:ff-call ff (append args (list return-type)))
      (let* ( (strings (loop for arg in args if (stringp arg) collect arg))
              (stringvars (mapcar (lambda (arg)
                                    (declare (ignore arg))
                                    (gensym "S"))
                                  strings))
              (args (mapcan (lambda (arg)
                              (etypecase arg
                                (integer (list :signed-doubleword arg))
                                (macptr (list :address arg))
                                (string (list :address
                                              (nth (position arg strings)
                                                   stringvars)))))
                            args)) )
        (eval
         `(with-cstrs ,(mapcar #'list stringvars strings)
            (ccl:ff-call ,ff ,@args ,return-type)))))))

(provide 'rffi)

#|
; Examples:

(defff "popen" (:cstr :cstr) :ptr)
(defff "pclose" (:ptr) :int32)
(defff "fgetc" (:address) :int32)

(defun system (cmd &optional (action #'princ))
  (setf cmd (substitute #\lf #\newline cmd))
  (let ( (fileptr (popen cmd "r")) )
    (unwind-protect
      (progn
        (loop for c = (fgetc fileptr)
              until (< c 0)
              do (let ( (c (code-char c)) )
                   (funcall action (if (eql c #\lf) #\newline c))))
        (values))
      (pclose fileptr))))

(system "ls -l")

; Watch this trick!

(system "cat<<EOF>~/foo.c
int foo(int x, int y) { return x+y; }
EOF")

(system "cd ~; gcc -m64 -bundle -o foo.dylib foo.c")

; open-shared-library doesn't do shell expansion so we have to jump
; through a little hoop

(defun get-homedir ()
  (with-output-to-string (s)
    (system "cd ~;pwd" (lambda (c) (unless (eql c #\newline) (princ c s))))))

(ff-load (concatenate 'string (get-homedir) "/foo.dylib"))

(ff-call :int "foo" 3 4)

|#