Tmux etc
This commit is contained in:
Ian Keane
parent
276853ba84
commit
1cb167b597
361 changed files with 77302 additions and 4 deletions
|
|
@ -0,0 +1,313 @@
|
|||
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
|
||||
;;;
|
||||
;;; cffi-gcl.lisp --- CFFI-SYS implementation for GNU Common Lisp.
|
||||
;;;
|
||||
;;; Copyright (C) 2005-2006, Luis Oliveira <loliveira(@)common-lisp.net>
|
||||
;;;
|
||||
;;; Permission is hereby granted, free of charge, to any person
|
||||
;;; obtaining a copy of this software and associated documentation
|
||||
;;; files (the "Software"), to deal in the Software without
|
||||
;;; restriction, including without limitation the rights to use, copy,
|
||||
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
|
||||
;;; of the Software, and to permit persons to whom the Software is
|
||||
;;; furnished to do so, subject to the following conditions:
|
||||
;;;
|
||||
;;; The above copyright notice and this permission notice shall be
|
||||
;;; included in all copies or substantial portions of the Software.
|
||||
;;;
|
||||
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
||||
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
|
||||
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
|
||||
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
|
||||
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
||||
;;; DEALINGS IN THE SOFTWARE.
|
||||
;;;
|
||||
|
||||
;;; GCL specific notes:
|
||||
;;;
|
||||
;;; On ELF systems, a library can be loaded with the help of this:
|
||||
;;; http://www.copyleft.de/lisp/gcl-elf-loader.html
|
||||
;;;
|
||||
;;; Another way is to link the library when creating a new image:
|
||||
;;; (compiler::link nil "new_image" "" "-lfoo")
|
||||
;;;
|
||||
;;; As GCL's FFI is not dynamic, CFFI declarations will only work
|
||||
;;; after compiled and loaded.
|
||||
|
||||
;;; *** this port is broken ***
|
||||
;;; gcl doesn't compile the rest of CFFI anyway..
|
||||
|
||||
;;;# Administrivia
|
||||
|
||||
(defpackage #:cffi-sys
|
||||
(:use #:common-lisp #:alexandria)
|
||||
(:export
|
||||
#:canonicalize-symbol-name-case
|
||||
#:pointerp
|
||||
#:%foreign-alloc
|
||||
#:foreign-free
|
||||
#:with-foreign-ptr
|
||||
#:null-ptr
|
||||
#:null-ptr-p
|
||||
#:inc-ptr
|
||||
#:%mem-ref
|
||||
#:%mem-set
|
||||
#:%foreign-funcall
|
||||
#:%foreign-type-alignment
|
||||
#:%foreign-type-size
|
||||
#:%load-foreign-library
|
||||
;#:make-shareable-byte-vector
|
||||
;#:with-pointer-to-vector-data
|
||||
#:foreign-var-ptr
|
||||
#:make-callback))
|
||||
|
||||
(in-package #:cffi-sys)
|
||||
|
||||
;;;# Mis-*features*
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(pushnew :cffi/no-foreign-funcall *features*))
|
||||
|
||||
;;; Symbol case.
|
||||
|
||||
(defun canonicalize-symbol-name-case (name)
|
||||
(declare (string name))
|
||||
(string-upcase name))
|
||||
|
||||
;;;# Allocation
|
||||
;;;
|
||||
;;; Functions and macros for allocating foreign memory on the stack
|
||||
;;; and on the heap. The main CFFI package defines macros that wrap
|
||||
;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
|
||||
;;; usage when the memory has dynamic extent.
|
||||
|
||||
(defentry %foreign-alloc (int) (int "malloc"))
|
||||
|
||||
;(defun foreign-alloc (size)
|
||||
; "Allocate SIZE bytes on the heap and return a pointer."
|
||||
; (%foreign-alloc size))
|
||||
|
||||
(defentry foreign-free (int) (void "free"))
|
||||
|
||||
;(defun foreign-free (ptr)
|
||||
; "Free a PTR allocated by FOREIGN-ALLOC."
|
||||
; (%free ptr))
|
||||
|
||||
(defmacro with-foreign-ptr ((var size &optional size-var) &body body)
|
||||
"Bind VAR to SIZE bytes of foreign memory during BODY. The
|
||||
pointer in VAR is invalid beyond the dynamic extent of BODY, and
|
||||
may be stack-allocated if supported by the implementation. If
|
||||
SIZE-VAR is supplied, it will be bound to SIZE during BODY."
|
||||
(unless size-var
|
||||
(setf size-var (gensym "SIZE")))
|
||||
`(let* ((,size-var ,size)
|
||||
(,var (foreign-alloc ,size-var)))
|
||||
(unwind-protect
|
||||
(progn ,@body)
|
||||
(foreign-free ,var))))
|
||||
|
||||
;;;# Misc. Pointer Operations
|
||||
|
||||
(defun pointerp (ptr)
|
||||
"Return true if PTR is a foreign pointer."
|
||||
(integerp ptr))
|
||||
|
||||
(defun null-ptr ()
|
||||
"Construct and return a null pointer."
|
||||
0)
|
||||
|
||||
(defun null-ptr-p (ptr)
|
||||
"Return true if PTR is a null pointer."
|
||||
(= ptr 0))
|
||||
|
||||
(defun inc-ptr (ptr offset)
|
||||
"Return a pointer OFFSET bytes past PTR."
|
||||
(+ ptr offset))
|
||||
|
||||
;;;# Shareable Vectors
|
||||
;;;
|
||||
;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
|
||||
;;; should be defined to perform a copy-in/copy-out if the Lisp
|
||||
;;; implementation can't do this.
|
||||
|
||||
;(defun make-shareable-byte-vector (size)
|
||||
; "Create a Lisp vector of SIZE bytes that can passed to
|
||||
;WITH-POINTER-TO-VECTOR-DATA."
|
||||
; (make-array size :element-type '(unsigned-byte 8)))
|
||||
|
||||
;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
|
||||
; "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
|
||||
; `(ccl:with-pointer-to-ivector (,ptr-var ,vector)
|
||||
; ,@body))
|
||||
|
||||
;;;# Dereferencing
|
||||
|
||||
(defmacro define-mem-ref/set (type gcl-type &optional c-name)
|
||||
(unless c-name
|
||||
(setq c-name (substitute #\_ #\Space type)))
|
||||
(let ((ref-fn (concatenate 'string "ref_" c-name))
|
||||
(set-fn (concatenate 'string "set_" c-name)))
|
||||
`(progn
|
||||
;; ref
|
||||
(defcfun ,(format nil "~A ~A(~A *ptr)" type ref-fn type)
|
||||
0 "return *ptr;")
|
||||
(defentry ,(intern (string-upcase (substitute #\- #\_ ref-fn)))
|
||||
(int) (,gcl-type ,ref-fn))
|
||||
;; set
|
||||
(defcfun ,(format nil "void ~A(~A *ptr, ~A value)" set-fn type type)
|
||||
0 "*ptr = value;")
|
||||
(defentry ,(intern (string-upcase (substitute #\- #\_ set-fn)))
|
||||
(int ,gcl-type) (void ,set-fn)))))
|
||||
|
||||
(define-mem-ref/set "char" char)
|
||||
(define-mem-ref/set "unsigned char" char)
|
||||
(define-mem-ref/set "short" int)
|
||||
(define-mem-ref/set "unsigned short" int)
|
||||
(define-mem-ref/set "int" int)
|
||||
(define-mem-ref/set "unsigned int" int)
|
||||
(define-mem-ref/set "long" int)
|
||||
(define-mem-ref/set "unsigned long" int)
|
||||
(define-mem-ref/set "float" float)
|
||||
(define-mem-ref/set "double" double)
|
||||
(define-mem-ref/set "void *" int "ptr")
|
||||
|
||||
(defun %mem-ref (ptr type &optional (offset 0))
|
||||
"Dereference an object of TYPE at OFFSET bytes from PTR."
|
||||
(unless (zerop offset)
|
||||
(incf ptr offset))
|
||||
(ecase type
|
||||
(:char (ref-char ptr))
|
||||
(:unsigned-char (ref-unsigned-char ptr))
|
||||
(:short (ref-short ptr))
|
||||
(:unsigned-short (ref-unsigned-short ptr))
|
||||
(:int (ref-int ptr))
|
||||
(:unsigned-int (ref-unsigned-int ptr))
|
||||
(:long (ref-long ptr))
|
||||
(:unsigned-long (ref-unsigned-long ptr))
|
||||
(:float (ref-float ptr))
|
||||
(:double (ref-double ptr))
|
||||
(:pointer (ref-ptr ptr))))
|
||||
|
||||
(defun %mem-set (value ptr type &optional (offset 0))
|
||||
(unless (zerop offset)
|
||||
(incf ptr offset))
|
||||
(ecase type
|
||||
(:char (set-char ptr value))
|
||||
(:unsigned-char (set-unsigned-char ptr value))
|
||||
(:short (set-short ptr value))
|
||||
(:unsigned-short (set-unsigned-short ptr value))
|
||||
(:int (set-int ptr value))
|
||||
(:unsigned-int (set-unsigned-int ptr value))
|
||||
(:long (set-long ptr value))
|
||||
(:unsigned-long (set-unsigned-long ptr value))
|
||||
(:float (set-float ptr value))
|
||||
(:double (set-double ptr value))
|
||||
(:pointer (set-ptr ptr value)))
|
||||
value)
|
||||
|
||||
;;;# Calling Foreign Functions
|
||||
|
||||
;; TODO: figure out if these type conversions make any sense...
|
||||
(defun convert-foreign-type (type-keyword)
|
||||
"Convert a CFFI type keyword to a GCL type."
|
||||
(ecase type-keyword
|
||||
(:char 'char)
|
||||
(:unsigned-char 'char)
|
||||
(:short 'int)
|
||||
(:unsigned-short 'int)
|
||||
(:int 'int)
|
||||
(:unsigned-int 'int)
|
||||
(:long 'int)
|
||||
(:unsigned-long 'int)
|
||||
(:float 'float)
|
||||
(:double 'double)
|
||||
(:pointer 'int)
|
||||
(:void 'void)))
|
||||
|
||||
(defparameter +cffi-types+
|
||||
'(:char :unsigned-char :short :unsigned-short :int :unsigned-int
|
||||
:long :unsigned-long :float :double :pointer))
|
||||
|
||||
(defcfun "int size_of(int type)" 0
|
||||
"switch (type) {
|
||||
case 0: return sizeof(char);
|
||||
case 1: return sizeof(unsigned char);
|
||||
case 2: return sizeof(short);
|
||||
case 3: return sizeof(unsigned short);
|
||||
case 4: return sizeof(int);
|
||||
case 5: return sizeof(unsigned int);
|
||||
case 6: return sizeof(long);
|
||||
case 7: return sizeof(unsigned long);
|
||||
case 8: return sizeof(float);
|
||||
case 9: return sizeof(double);
|
||||
case 10: return sizeof(void *);
|
||||
default: return -1;
|
||||
}")
|
||||
|
||||
(defentry size-of (int) (int "size_of"))
|
||||
|
||||
;; TODO: all this is doable inside the defcfun; figure that out..
|
||||
(defun %foreign-type-size (type-keyword)
|
||||
"Return the size in bytes of a foreign type."
|
||||
(size-of (position type-keyword +cffi-types+)))
|
||||
|
||||
(defcfun "int align_of(int type)" 0
|
||||
"switch (type) {
|
||||
case 0: return __alignof__(char);
|
||||
case 1: return __alignof__(unsigned char);
|
||||
case 2: return __alignof__(short);
|
||||
case 3: return __alignof__(unsigned short);
|
||||
case 4: return __alignof__(int);
|
||||
case 5: return __alignof__(unsigned int);
|
||||
case 6: return __alignof__(long);
|
||||
case 7: return __alignof__(unsigned long);
|
||||
case 8: return __alignof__(float);
|
||||
case 9: return __alignof__(double);
|
||||
case 10: return __alignof__(void *);
|
||||
default: return -1;
|
||||
}")
|
||||
|
||||
(defentry align-of (int) (int "align_of"))
|
||||
|
||||
;; TODO: like %foreign-type-size
|
||||
(defun %foreign-type-alignment (type-keyword)
|
||||
"Return the alignment in bytes of a foreign type."
|
||||
(align-of (position type-keyword +cffi-types+)))
|
||||
|
||||
#+ignore
|
||||
(defun convert-external-name (name)
|
||||
"Add an underscore to NAME if necessary for the ABI."
|
||||
#+darwinppc-target (concatenate 'string "_" name)
|
||||
#-darwinppc-target name)
|
||||
|
||||
(defmacro %foreign-funcall (function-name &rest args)
|
||||
"Perform a foreign function all, document it more later."
|
||||
`(format t "~&;; Calling ~A with args ~S.~%" ,name ',args))
|
||||
|
||||
(defun defcfun-helper-forms (name rettype args types)
|
||||
"Return 2 values for DEFCFUN. A prelude form and a caller form."
|
||||
(let ((ff-name (intern (format nil "%foreign-function/TildeA:~A" name))))
|
||||
(values
|
||||
`(defentry ,ff-name ,(mapcar #'convert-foreign-type types)
|
||||
(,(convert-foreign-type rettype) ,name))
|
||||
`(,ff-name ,@args))))
|
||||
|
||||
;;;# Callbacks
|
||||
|
||||
;;; XXX unimplemented
|
||||
(defmacro make-callback (name rettype arg-names arg-types body-form)
|
||||
0)
|
||||
|
||||
;;;# Loading Foreign Libraries
|
||||
|
||||
(defun %load-foreign-library (name)
|
||||
"_Won't_ load the foreign library NAME."
|
||||
(declare (ignore name)))
|
||||
|
||||
;;;# Foreign Globals
|
||||
|
||||
;;; XXX unimplemented
|
||||
(defmacro foreign-var-ptr (name)
|
||||
"Return a pointer pointing to the foreign symbol NAME."
|
||||
0)
|
||||
Loading…
Add table
Add a link
Reference in a new issue