GopherProxy

	tcffi-gcl.lisp - clic - Clic is an command line interactive client for gopher w…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tcffi-gcl.lisp (10297B)
	---
	1 ;;;; -- Mode: lisp; indent-tabs-mode: nil --
	2 ;;;
	3 ;;; cffi-gcl.lisp --- CFFI-SYS implementation for GNU Common Lisp.
	4 ;;;
	5 ;;; Copyright (C) 2005-2006, Luis Oliveira <loliveira(@)common-lisp.net>
	6 ;;;
	7 ;;; Permission is hereby granted, free of charge, to any person
	8 ;;; obtaining a copy of this software and associated documentation
	9 ;;; files (the "Software"), to deal in the Software without
	10 ;;; restriction, including without limitation the rights to use, copy,
	11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
	12 ;;; of the Software, and to permit persons to whom the Software is
	13 ;;; furnished to do so, subject to the following conditions:
	14 ;;;
	15 ;;; The above copyright notice and this permission notice shall be
	16 ;;; included in all copies or substantial portions of the Software.
	17 ;;;
	18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
	19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
	20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
	21 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
	22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
	23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
	24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
	25 ;;; DEALINGS IN THE SOFTWARE.
	26 ;;;
	27
	28 ;;; GCL specific notes:
	29 ;;;
	30 ;;; On ELF systems, a library can be loaded with the help of this:
	31 ;;; http://www.copyleft.de/lisp/gcl-elf-loader.html
	32 ;;;
	33 ;;; Another way is to link the library when creating a new image:
	34 ;;; (compiler::link nil "new_image" "" "-lfoo")
	35 ;;;
	36 ;;; As GCL's FFI is not dynamic, CFFI declarations will only work
	37 ;;; after compiled and loaded.
	38
	39 ;;; * this port is broken *
	40 ;;; gcl doesn't compile the rest of CFFI anyway..
	41
	42 ;;;# Administrivia
	43
	44 (defpackage #:cffi-sys
	45 (:use #:common-lisp #:alexandria)
	46 (:export
	47 #:canonicalize-symbol-name-case
	48 #:pointerp
	49 #:%foreign-alloc
	50 #:foreign-free
	51 #:with-foreign-ptr
	52 #:null-ptr
	53 #:null-ptr-p
	54 #:inc-ptr
	55 #:%mem-ref
	56 #:%mem-set
	57 #:%foreign-funcall
	58 #:%foreign-type-alignment
	59 #:%foreign-type-size
	60 #:%load-foreign-library
	61 ;#:make-shareable-byte-vector
	62 ;#:with-pointer-to-vector-data
	63 #:foreign-var-ptr
	64 #:make-callback))
	65
	66 (in-package #:cffi-sys)
	67
	68 ;;;# Mis-features
	69 (eval-when (:compile-toplevel :load-toplevel :execute)
	70 (pushnew :cffi/no-foreign-funcall features))
	71
	72 ;;; Symbol case.
	73
	74 (defun canonicalize-symbol-name-case (name)
	75 (declare (string name))
	76 (string-upcase name))
	77
	78 ;;;# Allocation
	79 ;;;
	80 ;;; Functions and macros for allocating foreign memory on the stack
	81 ;;; and on the heap. The main CFFI package defines macros that wrap
	82 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
	83 ;;; usage when the memory has dynamic extent.
	84
	85 (defentry %foreign-alloc (int) (int "malloc"))
	86
	87 ;(defun foreign-alloc (size)
	88 ; "Allocate SIZE bytes on the heap and return a pointer."
	89 ; (%foreign-alloc size))
	90
	91 (defentry foreign-free (int) (void "free"))
	92
	93 ;(defun foreign-free (ptr)
	94 ; "Free a PTR allocated by FOREIGN-ALLOC."
	95 ; (%free ptr))
	96
	97 (defmacro with-foreign-ptr ((var size &optional size-var) &body body)
	98 "Bind VAR to SIZE bytes of foreign memory during BODY. The
	99 pointer in VAR is invalid beyond the dynamic extent of BODY, and
	100 may be stack-allocated if supported by the implementation. If
	101 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
	102 (unless size-var
	103 (setf size-var (gensym "SIZE")))
	104 `(let* ((,size-var ,size)
	105 (,var (foreign-alloc ,size-var)))
	106 (unwind-protect
	107 (progn ,@body)
	108 (foreign-free ,var))))
	109
	110 ;;;# Misc. Pointer Operations
	111
	112 (defun pointerp (ptr)
	113 "Return true if PTR is a foreign pointer."
	114 (integerp ptr))
	115
	116 (defun null-ptr ()
	117 "Construct and return a null pointer."
	118 0)
	119
	120 (defun null-ptr-p (ptr)
	121 "Return true if PTR is a null pointer."
	122 (= ptr 0))
	123
	124 (defun inc-ptr (ptr offset)
	125 "Return a pointer OFFSET bytes past PTR."
	126 (+ ptr offset))
	127
	128 ;;;# Shareable Vectors
	129 ;;;
	130 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
	131 ;;; should be defined to perform a copy-in/copy-out if the Lisp
	132 ;;; implementation can't do this.
	133
	134 ;(defun make-shareable-byte-vector (size)
	135 ; "Create a Lisp vector of SIZE bytes that can passed to
	136 ;WITH-POINTER-TO-VECTOR-DATA."
	137 ; (make-array size :element-type '(unsigned-byte 8)))
	138
	139 ;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
	140 ; "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
	141 ; `(ccl:with-pointer-to-ivector (,ptr-var ,vector)
	142 ; ,@body))
	143
	144 ;;;# Dereferencing
	145
	146 (defmacro define-mem-ref/set (type gcl-type &optional c-name)
	147 (unless c-name
	148 (setq c-name (substitute #\_ #\Space type)))
	149 (let ((ref-fn (concatenate 'string "ref_" c-name))
	150 (set-fn (concatenate 'string "set_" c-name)))
	151 `(progn
	152 ;; ref
	153 (defcfun ,(format nil "~A ~A(~A *ptr)" type ref-fn type)
	154 0 "return *ptr;")
	155 (defentry ,(intern (string-upcase (substitute #\- #\_ ref-fn)))
	156 (int) (,gcl-type ,ref-fn))
	157 ;; set
	158 (defcfun ,(format nil "void ~A(~A *ptr, ~A value)" set-fn type ty…
	159 0 "*ptr = value;")
	160 (defentry ,(intern (string-upcase (substitute #\- #\_ set-fn)))
	161 (int ,gcl-type) (void ,set-fn)))))
	162
	163 (define-mem-ref/set "char" char)
	164 (define-mem-ref/set "unsigned char" char)
	165 (define-mem-ref/set "short" int)
	166 (define-mem-ref/set "unsigned short" int)
	167 (define-mem-ref/set "int" int)
	168 (define-mem-ref/set "unsigned int" int)
	169 (define-mem-ref/set "long" int)
	170 (define-mem-ref/set "unsigned long" int)
	171 (define-mem-ref/set "float" float)
	172 (define-mem-ref/set "double" double)
	173 (define-mem-ref/set "void *" int "ptr")
	174
	175 (defun %mem-ref (ptr type &optional (offset 0))
	176 "Dereference an object of TYPE at OFFSET bytes from PTR."
	177 (unless (zerop offset)
	178 (incf ptr offset))
	179 (ecase type
	180 (:char (ref-char ptr))
	181 (:unsigned-char (ref-unsigned-char ptr))
	182 (:short (ref-short ptr))
	183 (:unsigned-short (ref-unsigned-short ptr))
	184 (:int (ref-int ptr))
	185 (:unsigned-int (ref-unsigned-int ptr))
	186 (:long (ref-long ptr))
	187 (:unsigned-long (ref-unsigned-long ptr))
	188 (:float (ref-float ptr))
	189 (:double (ref-double ptr))
	190 (:pointer (ref-ptr ptr))))
	191
	192 (defun %mem-set (value ptr type &optional (offset 0))
	193 (unless (zerop offset)
	194 (incf ptr offset))
	195 (ecase type
	196 (:char (set-char ptr value))
	197 (:unsigned-char (set-unsigned-char ptr value))
	198 (:short (set-short ptr value))
	199 (:unsigned-short (set-unsigned-short ptr value))
	200 (:int (set-int ptr value))
	201 (:unsigned-int (set-unsigned-int ptr value))
	202 (:long (set-long ptr value))
	203 (:unsigned-long (set-unsigned-long ptr value))
	204 (:float (set-float ptr value))
	205 (:double (set-double ptr value))
	206 (:pointer (set-ptr ptr value)))
	207 value)
	208
	209 ;;;# Calling Foreign Functions
	210
	211 ;; TODO: figure out if these type conversions make any sense...
	212 (defun convert-foreign-type (type-keyword)
	213 "Convert a CFFI type keyword to a GCL type."
	214 (ecase type-keyword
	215 (:char 'char)
	216 (:unsigned-char 'char)
	217 (:short 'int)
	218 (:unsigned-short 'int)
	219 (:int 'int)
	220 (:unsigned-int 'int)
	221 (:long 'int)
	222 (:unsigned-long 'int)
	223 (:float 'float)
	224 (:double 'double)
	225 (:pointer 'int)
	226 (:void 'void)))
	227
	228 (defparameter +cffi-types+
	229 '(:char :unsigned-char :short :unsigned-short :int :unsigned-int
	230 :long :unsigned-long :float :double :pointer))
	231
	232 (defcfun "int size_of(int type)" 0
	233 "switch (type) {
	234 case 0: return sizeof(char);
	235 case 1: return sizeof(unsigned char);
	236 case 2: return sizeof(short);
	237 case 3: return sizeof(unsigned short);
	238 case 4: return sizeof(int);
	239 case 5: return sizeof(unsigned int);
	240 case 6: return sizeof(long);
	241 case 7: return sizeof(unsigned long);
	242 case 8: return sizeof(float);
	243 case 9: return sizeof(double);
	244 case 10: return sizeof(void *);
	245 default: return -1;
	246 }")
	247
	248 (defentry size-of (int) (int "size_of"))
	249
	250 ;; TODO: all this is doable inside the defcfun; figure that out..
	251 (defun %foreign-type-size (type-keyword)
	252 "Return the size in bytes of a foreign type."
	253 (size-of (position type-keyword +cffi-types+)))
	254
	255 (defcfun "int align_of(int type)" 0
	256 "switch (type) {
	257 case 0: return __alignof__(char);
	258 case 1: return __alignof__(unsigned char);
	259 case 2: return __alignof__(short);
	260 case 3: return __alignof__(unsigned short);
	261 case 4: return __alignof__(int);
	262 case 5: return __alignof__(unsigned int);
	263 case 6: return __alignof__(long);
	264 case 7: return __alignof__(unsigned long);
	265 case 8: return __alignof__(float);
	266 case 9: return __alignof__(double);
	267 case 10: return __alignof__(void *);
	268 default: return -1;
	269 }")
	270
	271 (defentry align-of (int) (int "align_of"))
	272
	273 ;; TODO: like %foreign-type-size
	274 (defun %foreign-type-alignment (type-keyword)
	275 "Return the alignment in bytes of a foreign type."
	276 (align-of (position type-keyword +cffi-types+)))
	277
	278 #+ignore
	279 (defun convert-external-name (name)
	280 "Add an underscore to NAME if necessary for the ABI."
	281 #+darwinppc-target (concatenate 'string "_" name)
	282 #-darwinppc-target name)
	283
	284 (defmacro %foreign-funcall (function-name &rest args)
	285 "Perform a foreign function all, document it more later."
	286 `(format t "~&;; Calling ~A with args ~S.~%" ,name ',args))
	287
	288 (defun defcfun-helper-forms (name rettype args types)
	289 "Return 2 values for DEFCFUN. A prelude form and a caller form."
	290 (let ((ff-name (intern (format nil "%foreign-function/TildeA:~A" name)…
	291 (values
	292 `(defentry ,ff-name ,(mapcar #'convert-foreign-type types)
	293 (,(convert-foreign-type rettype) ,name))
	294 `(,ff-name ,@args))))
	295
	296 ;;;# Callbacks
	297
	298 ;;; XXX unimplemented
	299 (defmacro make-callback (name rettype arg-names arg-types body-form)
	300 0)
	301
	302 ;;;# Loading Foreign Libraries
	303
	304 (defun %load-foreign-library (name)
	305 "_Won't_ load the foreign library NAME."
	306 (declare (ignore name)))
	307
	308 ;;;# Foreign Globals
	309
	310 ;;; XXX unimplemented
	311 (defmacro foreign-var-ptr (name)
	312 "Return a pointer pointing to the foreign symbol NAME."
	313 0)