;;;-*- Mode: Lisp; Package: (FFC) -*-

;; Foreign function compatibility module for MCL, LWW and ACL/Windows
;; Version 0.7
;; (C) Paul Meurer 1999
;; paul.meurer@hit.uib.no
;;
;; You may freely use this code as long as you don't remove the (C) notice.
;; Bug reports and suggestions are highly welcome.
;; Particularly welcome are ports to other Common Lisps.

;; In this file the platform specific code is isolated.
;; The code in this file consists mostly of wrapper functions and macros 
;; around the platform-dependent foreign function interface.

(defpackage "FFC"
  (:use "COMMON-LISP" #+mcl "CCL")
  #+mcl(:import-from "CCL" "WITH-CSTR")
  (:export "*FOREIGN-MODULE*" "DEFINE-FOREIGN-FUNCTION" 
    "MAKE-RECORD"
    "%WITH-TEMPORARY-ALLOCATION" "%WITH-SQL-POINTER" "%GET-CSTRING"
    "%CSTRING-INTO-STRING"
    "%CSTRING-INTO-VECTOR"
    "%GET-CSTRING-LENGTH" "WITH-CSTR" "%GET-PTR" "%NEW-PTR" "%DISPOSE-PTR"
    "%GET-SIGNED-WORD"
    "%GET-UNSIGNED-LONG"
    "%GET-SIGNED-LONG"
    "%GET-SINGLE-FLOAT"
    "%GET-DOUBLE-FLOAT"
    "%GET-WORD"
    "%GET-LONG"
    "%GET-SIGNED-LONG"
    "%PUT-STR"
    "%PUT-WORD"
    "%PUT-SHORT"
    "%PUT-LONG"
    "%NEW-CSTRING" 
    "%NULL-PTR"
    #-mcl "%PTR-EQL"
    #+allegro "SHORT-TO-SIGNED-SHORT"
    "STRING-PTR" "SQL-HANDLE" "SQL-HANDLE-PTR"))

(in-package :ffc)

(eval-when (:load-toplevel :compile-toplevel :execute)
  (defparameter *foreign-module* nil))

;; MCL specific code

#+mcl
(eval-when (:load-toplevel :compile-toplevel :execute)
  (import 'ccl::with-cstr)
  
  (ccl::def-mactype :string-ptr (find-mactype :ptr))
  (ccl::def-mactype :sql-handle (find-mactype :ptr))
  (ccl::def-mactype :sql-handle-ptr (find-mactype :ptr))
  
  ;(setf *foreign-module* "vsi:ODBC$DriverMgr")
  
  (defun mac-to-lisp-type (mac-type)
    (ecase (ccl::make-keyword mac-type)
      ((:ptr :sql-handle :sql-handle-ptr) t)
      (:string-ptr 'string)
      ((:word :short :long) 'fixnum))))

;; Mask the MCL reader macro #_ (Kent Pitman's idea)

#+mcl
(defun %new-ptr (type &optional bytecount)
  (#.(read-from-string "#_NewPtr")
   (if bytecount bytecount (ccl::record-field-length type))))

;(%address-of (%new-ptr :ptr))

#+mcl
(defun %dispose-ptr (p)
  #.(read-from-string "(#_DisposPtr p)"))

#+mcl
(defun %get-cstring-length (pointer)
  (with-pointers ((p pointer))
    (let ((len 0))
      (declare (fixnum len))
      (loop (if (ccl::%izerop (%get-byte p len))
              (return)
              (setq len (ccl::%i+ len 1))))
      len)))

#+mcl
(defmacro %put-str (ptr str &optional length)
 ; can't use name %put-string because of name clash
  (declare (ignore length))
  `(ccl::%cstr-pointer ,str ,ptr))

#+mcl
(defun %%str-pointer (string pointer)
  (multiple-value-bind (s o n) (ccl::dereference-base-string string)
    (declare (fixnum o n))
    (do* ((o o (1+ o))
          (i 0 (1+ i)))
         ((= i n))
      (declare (fixnum o i))
      (setf (%get-byte pointer i) (ccl::%scharcode s o)))))

#+mcl
(defun %cstring-into-string (pointer string start end)
  (let ((delta (- (min (%get-cstring-length pointer) end) start)))
    (with-pointers ((p pointer))
      (ccl::copy-ptr-to-string p string start delta))
    (+ start delta)))

#+mcl-old
(defun %cstring-into-string (pointer string offset size-in-bytes)
  (with-pointers ((p pointer))
    (ccl::copy-ptr-to-string p string offset size-in-bytes))
  (+ offset size-in-bytes))

#+mcl
(defun %cstring-into-vector (pointer vector offset size-in-bytes)
  (with-pointers ((p pointer))
    (let ((pos 0)
          (len offset))
      (declare (fixnum len))
      (loop (let ((code (%get-byte p pos))
                  (end (+ offset size-in-bytes)))
              (if (or (ccl::%izerop code) (= len end))
                (return)
                (setf (aref vector len) (code-char code)
                      len (ccl::%i+ len 1)
                      pos (ccl::%i+ pos 1)))))
      len)))

#+mcl
(defun %cstring-to-keyword (pointer)
  (with-pointers ((p pointer))
    (let* ((len (%get-cstring-length pointer))
           (str (make-string len :element-type 'base-character)))
      (declare (dynamic-extent str))
      (ccl::%copy-ptr-to-ivector p 0 str 0 len)
      (intern str (find-package 'keyword)))))

#+mcl
(defmacro %with-sql-pointer ((ptr-var) &body body)
  `(%stack-block ((,ptr-var #.(ccl::record-field-length :ptr))) 
     ,@body))

;; bindings is a list of (var type &optional size)
#+mcl
(defmacro %with-temporary-allocation (bindings &body body)
  (let ((args ())) 
    (dolist (binding bindings) ; use destructuring-bind to make this clearer!
      (if (cddr binding)
        (push (list (car binding)
                    (caddr binding)) args)
        (push (list (car binding)
                    (ccl::record-field-length (cadr binding)))
              args)))
    `(%stack-block ,args ; need to reverse them here and in other macros?
       ,@body)))

; args is a list of (var type)'s
#+mcl
(defmacro define-foreign-function (c-name args result-type
                                              &key documentation module)
  (declare (ignore documentation))
  (let ((type-list
         (mapcar #'(lambda (var+type)
                     ; var is not used in MCL
                     (let ((type (ccl::make-keyword (cadr var+type))))
                       (list (mac-to-lisp-type type) type)))
                 args)))
    `(define-entry-point (,c-name (,(or module *foreign-module*)))
       ,type-list
       ,result-type)))


;; LispWorks (Windows) specific code

#+lispworks
(defun %get-cstring-length (ptr)
  (loop with size = 0
        until (char= (fli:dereference ptr :index size) #\Null)
        do (incf size)
        finally return size))

#+lispworks
(defun %cstring-into-string (ptr string offset size-in-bytes)
    (dotimes (i size-in-bytes)
      (setf (char string offset)
            (fli:dereference ptr :index i))
      (incf offset))
    offset)

#+lispworks
(defun %cstring-into-vector (ptr vector offset size-in-bytes)
    (dotimes (i size-in-bytes)
      (setf (aref vector offset)
            (fli:dereference ptr :index i))
      (incf offset))
    offset)

#+lispworks
(defmacro with-cstr ((ptr str) &body body)
  `(fli:with-foreign-string (,ptr element-count byte-count
                                  :external-format win32:*multibyte-code-page-ef*)
       ,str
     (declare (ignore element-count byte-count))
     ,@body))

#+lispworks
(defun %cstring-to-keyword (pointer)
  (let* ((len (%get-cstring-length pointer))
         (str (make-string len)))
    (declare (dynamic-extent str))
    (%cstring-into-string pointer str 0 len)
    (intern str (find-package 'keyword))))

#+lispworks
(defun %new-ptr (type &optional bytecount)
  (fli:allocate-foreign-object :type 
                    (if bytecount
                      (list type bytecount)
                      type)))

#+lispworks
(defun %dispose-ptr (p)
  (fli:free-foreign-object p))

#+lispworks
(defmacro %with-sql-pointer ((pointer-var) &body body)
  `(let ((,pointer-var (fli:allocate-foreign-object :pointer-type 'sql-handle-ptr)))
     ,@body))

#+lispworks
(progn
  (defmacro %null-ptr ()
    '(fli:make-pointer :address 0))
  
  (defmacro %ptr-eql (ptr1 ptr2)
    `(= (fli:pointer-address ,ptr1) 
        (fli:pointer-address ,ptr2)))
 
  (defmacro %address-to-pointer (address)
    `(fli:make-pointer :address ,address))
  
  (defmacro %pointer-to-address (pointer)
    `(fli:pointer-address ,pointer))
  
  ;; all the same ...
  (defmacro %get-ptr (ptr) `(fli:dereference ,ptr))
  
  (defmacro %get-short (ptr) `(fli:dereference ,ptr))
  (defmacro %put-short (ptr short) `(setf (%get-ptr ,ptr) ,short))
  
  (defmacro %get-long (ptr) `(fli:dereference ,ptr))
  (defmacro %put-long (ptr long) `(setf (%get-ptr ,ptr) ,long))

  (defmacro %get-signed-word (ptr) `(fli:dereference ,ptr))

  (defmacro %get-word (ptr) `(fli:dereference ,ptr))
  (defmacro %put-word (ptr word) `(setf (%get-ptr ,ptr) ,word))

  (defmacro %get-unsigned-long (ptr) `(fli:dereference ,ptr))

  (defmacro %get-signed-long (ptr) `(fli:dereference ,ptr))

  (defmacro %get-single-float (ptr) `(fli:dereference ,ptr))

  (defmacro %get-double-float (ptr) `(fli:dereference ,ptr))

  #+conses-too-much
  (defun %get-cstring (ptr)
    (fli:convert-from-foreign-string 
     ptr :external-format win32:*multibyte-code-page-ef*))

  (defun %get-cstring (ptr &optional (start 0))
    (let ((size 0))
      (fli:incf-pointer ptr start)
      (loop until (char= (fli:dereference ptr) #\Null)
            do
            (fli:incf-pointer ptr) ; better use offset??
            (incf size))
      (let ((str (make-string size)))
        (loop do 
              (fli:incf-pointer ptr -1)
              (decf size)
              (setf (char str size)
                    (fli:dereference ptr))
              until (zerop size))
        (fli:decf-pointer ptr start)
        str)))

  (defmacro %put-str (ptr string &optional max-length)
    (let ((size (gensym)))
      `(let ((,size (length ,string)))
         (when (and ,max-length (> ,size ,max-length))
           (error "string \"~a\" of length ~d is longer than max-length: ~d"
                  ,string ,size ,max-length))
         (dotimes (i ,size)
           (setf (fli:dereference ,ptr :index i) (char ,string i)))
         (setf (fli:dereference ,ptr :index ,size) 0))))

  (defmacro %new-cstring (byte-count)
    `(fli:allocate-foreign-object :type :char :initial-element #\ø :nelems ,byte-count))
  
  (defmacro make-record (type)
    `(fli:allocate-foreign-object :type ',type))
  
  (fli:register-module "odbc32" :connection-style :automatic)
  
  (fli:define-c-typedef sql-handle (:pointer :void))
  (fli:define-c-typedef sql-handle-ptr (:pointer sql-handle))
  (fli:define-c-typedef string-ptr :pointer))

#+lispworks
(defmacro define-foreign-function (c-name args result-type &key documentation module)
  (let ((name-list (list (intern (string-upcase c-name)) c-name :source)))
    `(fli:define-foreign-function 
         ,name-list
         ,args
       :result-type ,result-type
       :language :ansi-c
       :documentation ,documentation
       :module (or ,module ,*foreign-module*))))

#+lispworks??
(defun allocate-dynamic-string (size)
  (fli:allocate-dynamic-foreign-object
   :type `(:ef-wc-string ,size)
   :initial-element (make-string size :initial-element #\Space)))

#+lispworks
(defun allocate-dynamic-string (size)
  (fli:allocate-dynamic-foreign-object
   :type :char
   :initial-element #\Space
   :nelems size))

#+lispworks
(defmacro %with-temporary-allocation (bindings &body body)
  (let ((simple-types ())
        (strings ())) 
    (dolist (binding bindings)
      (case (cadr binding)
        (:string (push (list (car binding)
                             (list 'allocate-dynamic-string (caddr binding))) strings))
        (otherwise (push (list (car binding) (cadr binding)) simple-types))))
    `(fli:with-dynamic-foreign-objects ,simple-types
       (let ,strings
         ,@body))))

;(fli:allocate-foreign-object :type 'sql-c-timestamp)

;; Allegro specific code

#+allegro
(eval-when (:load-toplevel :compile-toplevel :execute)
 (use-package :ff)
 (require :foreign))

#+allegro
(defun %get-cstring-length (ptr)
   (foreign-strlen ptr))

#+allegro-old
(defun %cstring-into-string (ptr string offset size-in-bytes)
  "Copy C string into Lisp string."
  (declare (optimize (speed 3))
	   (integer ptr))
  (unless (integerp ptr)
    (excl::.type-error ptr 'integer))
   (when (zerop ptr)
      (excl::.error "0 is not a valid character pointer"))
   (dotimes (i size-in-bytes)
      (declare (optimize (safety 0))
        (fixnum i))
      (setf (char string offset)
            (code-char (sys:memref-int ptr 0 i :unsigned-byte)))
      (incf offset))
   offset)

#+allegro
(defun %cstring-into-vector (ptr vector offset size-in-bytes)
  "Copy C string into Lisp vector."
  (declare (optimize (speed 3))
	   (integer ptr))
  (unless (integerp ptr)
    (excl::.type-error ptr 'integer))
   (when (zerop ptr)
      (excl::.error "0 is not a valid character pointer"))
   (dotimes (i size-in-bytes)
      (declare (optimize (safety 0))
        (fixnum i))
      (setf (aref vector offset)
            (code-char (sys:memref-int ptr 0 i :unsigned-byte)))
      (incf offset))
   offset)

#+allegro
(defun %cstring-into-string (ptr string offset size-in-bytes)
   (%cstring-into-vector ptr string offset size-in-bytes))

#+allegro
(defun %new-ptr (type &optional bytecount)
  (allocate-fobject (canonical-to-acl-type type) :c bytecount))

#+allegro
(defun %dispose-ptr (p)
   (free-fobject p))

#+allegro
(defmacro %with-sql-pointer ((pointer-var) &body body)
  `(let ((,pointer-var (allocate-fobject 'sql-handle-ptr :c)))
     ,@body))

#+allegro
(defun allocate-dynamic-string (size)
   (let ((str (make-string size :initial-element #\Space)))
      (string-to-char* str)))

#+allegro
(defun %new-cstring (size)
   (allocate-dynamic-string size))

#+allegro
(defmacro %with-temporary-allocation (bindings &body body)
  (let ((simple-types ())
        (strings ())
        (free-strings ())) 
    (dolist (binding bindings)
      (case (cadr binding)
        (:string 
          (push (list (car binding)
                  (list 'allocate-dynamic-string (caddr binding))) strings)
          (push (list 'excl:aclfree (car binding)) free-strings))
        (:ptr (push (list (car binding) :long) simple-types))
        (otherwise (push (list (car binding) (cadr binding)) simple-types))))
    `(with-stack-fobjects ,simple-types
       (let ,strings
          (unwind-protect
           (progn ,@body)
           ,@free-strings)))))

#+allegro
(defmacro with-cstr ((ptr str) &body body)
   `(let ((,ptr (string-to-char* ,str)))
       (unwind-protect
        (progn ,@body)
        (excl:aclfree ,ptr))))

#+allegro
(progn
 (defun %null-ptr ()
    (make-foreign-pointer :foreign-address 0))
 
 (defmacro %ptr-eql (ptr1 ptr2)
    `(= ,ptr1 ,ptr2)) ;; ??

 (defun %get-ptr (ptr)
    (fslot-value-typed '(* :void) nil ptr))
  
  (defun %get-short (ptr)
    (fslot-value-typed :short nil ptr))
  
  (defun %get-long (ptr)
     (fslot-value-typed :long nil ptr))

  (defmacro %put-long (ptr long) 
     `(setf (fslot-value-typed :long nil ,ptr) ,long))

  (defun %get-signed-word (ptr)
    (fslot-value-typed :short nil ptr))

  (defun %get-word (ptr)
    (fslot-value-typed :unsigned-short nil ptr))

  (defmacro %put-word (ptr word) 
     `(setf (fslot-value-typed :short nil ,ptr) ,word))

  (defun %get-unsigned-long (ptr)
    (fslot-value-typed :unsigned-long nil ptr))

  (defmacro %get-signed-long (ptr)
    `(fslot-value-typed :signed-long nil ,ptr))

  (defmacro %get-single-float (ptr)
     `(fslot-value-typed :float nil ,ptr))

  (defmacro %get-double-float (ptr)
    `(fslot-value-typed :double nil ,ptr))

  (defmacro %get-cstring (ptr &optional (start 0))
     `(char*-to-string (+ ,ptr ,start)))

  (defmacro %put-str (ptr string &optional max-length)
     (declare (ignore max-length))
     `(string-to-char* ,string ,ptr))

  #+lispworks??
  (defmacro %put-str (ptr string &optional max-length)
     (let ((size (gensym)))
        `(let ((,size (length ,string)))
            (when (and ,max-length (> ,size ,max-length))
               (error "string \"~a\" of length ~d is longer than max-length: ~d"
                 ,string ,size ,max-length))
            (dotimes (i ,size)
               (setf (fli:dereference ,ptr :index i) (char ,string i)))
            (setf (fli:dereference ,ptr :index ,size) 0))))
 
 (defmacro make-record (type)
    `(allocate-fobject (canonical-to-acl-type ',type) :c)))

;; There seems to be a bug with signed short integers as return values;
;; they are returned as unsigned shorts. Quick fix.
#+allegro
(defun short-to-signed-short (unsigned-short)
   (if (<= unsigned-short 16384)
      unsigned-short
      (- unsigned-short 65536)))

#+allegro
(defmacro defcstruct-make (name &rest other)
  `(progn
     (ct:defcstruct ,name ,@other)
     (defmacro ,(intern (format nil "~a-~s" :make name))
	 ()
       `(ct:callocate ,',name))))

#+allegro
(def-foreign-type sql-handle (* :void))

#+allegro
(def-foreign-type sql-handle-ptr (* sql-handle))

#+allegro
(def-foreign-type string-ptr (* :char))

#+allegro
(defun c-to-lisp-type (c-type)
   (ecase c-type
     ((:ptr sql-handle sql-handle-ptr) t)
     (string-ptr 'string)
     ((:word :short :signed-short :long) 'fixnum)))

#+allegro
(defun canonical-to-acl-type (type)
   (case type
     (:signed-short :short)
     ;;(string-ptr :long) ; ***
     (:ptr '(* :void))
     (otherwise type)))

#+allegro-35
(defmacro define-foreign-function (c-name args result-type
                                              &key documentation module)
  (declare (ignore documentation))
  (let ((lisp-name (intern (string-upcase c-name)))
        (type-list
         (mapcar #'(lambda (var+type)
                     (let ((type (cadr var+type)))
                        (list (car var+type)
                          (canonical-to-acl-type type)
                          (c-to-lisp-type type) )))
           args)))
     `(ct:defun-dll 
        ,lisp-name
        ,type-list
        :return-type (canonical-to-acl-type ,result-type)
        :library-name ,(or module *foreign-module*)
        :entry-name ,c-name)))

#+allegro
(defun fix-ctype-float (type)
  ;; from aclwffi.cl
  (cond ((eq type :single-float) :float)
	((eq type :double-float) :double)
	(t type)))

#+allegro
(defun make-ffi-args-compatible (arglist)
  ;; from aclwffi.cl
  (let (res)
    (dolist (arg arglist (nreverse res))
      (push
       (if (listp (second arg))
	   (list (first arg) (list '* (fix-ctype-float (first (second arg)))))
	 (list (first arg) (fix-ctype-float (second arg))))
       res))))

#+allegro
(defmacro define-foreign-function (c-name args result-type &key documentation module)
  (declare (ignore documentation))
  (let* ((lisp-name (intern (string-upcase c-name)))
	 (type-list
	  (mapcar (lambda (var+type)
		    (let ((type (cadr var+type)))
		      (list (car var+type)
			    (canonical-to-acl-type type)
			    (c-to-lisp-type type) )))
		  args))
	 (type-list (make-ffi-args-compatible type-list)))
    `(progn
       (eval-when (:compile-toplevel :load-toplevel :execute)
	 (unless (member ,(or module *foreign-module*) (excl::foreign-files)
			 :test (lambda (x y) (equal (namestring x) (namestring y))))
	   (load ,(or module *foreign-module*))))
       (def-foreign-call
	   (,lisp-name ,c-name) ;; ,lisp-name
	   ,type-list
	 :convention :stdcall
	 :returning ,(canonical-to-acl-type result-type)))))