;;; alien.lisp --- foreign alien friends

 ;;; Commentary:

 ;; FFI in Lisp is somewhat different than FFI in other host langs. As

 ;; such, we usually refer to our Lispy FFI interfaces inline with the

 ;; CMUCL terminology: alien interfaces.

 ;; ref: https://www.sbcl.org/manual/#Foreign-Function-Interface for details

 ;; sb-alien is a high-level interface which automatically converts C

 ;; memory pointers to lisp objects and back, but this can be slow for

 ;; large or complex objects.

 ;; The lower-level interface is based on System Area Pointers (or

 ;; SAPs), which provide untyped access to foreign memory.

 ;; Objects which can't be automatically converted into Lisp values are

 ;; represented by objects of type ALIEN-VALUE.

 ;;; Code:

 (in-package :std)

 ;; (reexport-from :sb-vm

 ;;  	       :include

 ;;  	       '(:with-pinned-objects :with-pinned-object-iterator :with-code-pages-pinned

 ;;  		 :sanctify-for-execution))

 (defmacro define-opaque (ty &optional no-export)

   `(prog1

        (define-alien-type ,ty (struct ,(symbolicate ty '-t)))

      ,(unless no-export `(export '(,ty)))))

 (defun setfa (place from) 

   (loop for x across from

 	for i from 0 below (length from)

 	do (setf (deref place i) x)))

 (defun copy-c-string (src dest &aux (index 0))

   (loop (let ((b (sb-sys:sap-ref-8 src index)))

           (when (= b 0)

             (setf (fill-pointer dest) index)

             (return))

           (setf (char dest index) (code-char b))

           (incf index))))

 (defun clone-strings (list)

   (with-alien ((x (* (* char))

                   (make-alien (* char) (length list))))

     (unwind-protect

          (labels ((populate (list index function)

                     (if list

                         (let ((array (sb-ext:string-to-octets (car list) :null-terminate t)))

                           (sb-sys:with-pinned-objects (array)

                             (setf (deref x index) (sap-alien (sb-sys:vector-sap array) (* char)))

                             (populate (cdr list) (1+ index) function)))

                         (funcall function))))

            (populate list 0

                      (lambda ()

                        (loop for i below (length list)

                              do (print (cast (deref x i) c-string))))))

       (free-alien x))))

 (defmacro clone-octets-to-alien (lispa aliena)

   (with-gensyms (i)

     `(loop for ,i from 0 below (length ,lispa)

         do (setf (deref ,aliena ,i)

                  (aref ,lispa ,i)))))

 (defmacro clone-octets-from-alien (aliena lispa len)

   (with-gensyms (i)

     `(loop for ,i from 0 below ,len

            do (setf (aref ,lispa ,i)

                  (deref ,aliena ,i)))))

 (defun foreign-int-to-integer (buffer size)

   "Check SIZE of int BUFFER. return BUFFER."

   (assert (= size (sb-alien:alien-size sb-alien:int :bytes)))

   buffer)

 (defun foreign-int-to-bool (x size)

   (if (zerop (foreign-int-to-integer x size))

       nil

       t))

 (defun bool-to-foreign-int (val)

   (if val 1 0))

 ;;; Bits

 (defun make-bits (length &rest args)

   (apply #'make-array length (nconc '(:element-type bit) args)))

 ;;; Bytes

 ;; (defmacro defbytes (&body bitsets)

 ;;   "For each cons-cell in BITSETS, define a new CAR-byte type for each

 ;; member of CDR."

 ;;   `(loop for set in ',bitsets

 ;; 	 collect

 ;; 	 (let* ((ty (car set))

 ;; 		(pfx

 ;; 		  (cond

 ;; 		    ((eq 'signed-byte ty) "I")

 ;; 		    ((eq 'unsigned-byte ty) "U")

 ;; 		    ((eq 'float ty) "F")

 ;; 		    (t (subseq (symbol-name ty) 0 1))))

 ;; 		(nums (cdr set))

 ;; 		r) ;result

 ;; 	   (setf r

 ;; 		 (mapc

 ;; 		  (lambda (x)

 ;; 		    `(deftype ,(symbolicate pfx (format 'nil "~a" x)) ()

 ;; 		       (cons ,ty ,x)))

 ;; 		       nums))

 ;; 	   (cons ty r))))

 ;; (defbytes

 ;;   (unsigned-byte 1 2 3 4 8 16 24 32 64 128)

 ;;   (signed-byte 2 3 4 8 16 24 32 64 128)

 ;;   (float 16 24 32 64 128))