GopherProxy

	tcffi-scl.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-scl.lisp (11099B)
	---
	1 ;;;; -- Mode: lisp; indent-tabs-mode: nil --
	2 ;;;
	3 ;;; cffi-scl.lisp --- CFFI-SYS implementation for the Scieneer Common Li…
	4 ;;;
	5 ;;; Copyright (C) 2005-2006, James Bielman <[email protected]>
	6 ;;; Copyright (C) 2006-2007, Scieneer Pty Ltd.
	7 ;;;
	8 ;;; Permission is hereby granted, free of charge, to any person
	9 ;;; obtaining a copy of this software and associated documentation
	10 ;;; files (the "Software"), to deal in the Software without
	11 ;;; restriction, including without limitation the rights to use, copy,
	12 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
	13 ;;; of the Software, and to permit persons to whom the Software is
	14 ;;; furnished to do so, subject to the following conditions:
	15 ;;;
	16 ;;; The above copyright notice and this permission notice shall be
	17 ;;; included in all copies or substantial portions of the Software.
	18 ;;;
	19 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
	20 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
	21 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
	22 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
	23 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
	24 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
	25 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
	26 ;;; DEALINGS IN THE SOFTWARE.
	27 ;;;
	28
	29 ;;;# Administrivia
	30
	31 (defpackage #:cffi-sys
	32 (:use #:common-lisp #:alien #:c-call)
	33 (:import-from #:alexandria #:once-only #:with-unique-names)
	34 (:export
	35 #:canonicalize-symbol-name-case
	36 #:foreign-pointer
	37 #:pointerp
	38 #:pointer-eq
	39 #:null-pointer
	40 #:null-pointer-p
	41 #:inc-pointer
	42 #:make-pointer
	43 #:pointer-address
	44 #:%foreign-alloc
	45 #:foreign-free
	46 #:with-foreign-pointer
	47 #:%foreign-funcall
	48 #:%foreign-funcall-pointer
	49 #:%foreign-type-alignment
	50 #:%foreign-type-size
	51 #:%load-foreign-library
	52 #:%close-foreign-library
	53 #:native-namestring
	54 #:%mem-ref
	55 #:%mem-set
	56 #:make-shareable-byte-vector
	57 #:with-pointer-to-vector-data
	58 #:%foreign-symbol-pointer
	59 #:%defcallback
	60 #:%callback))
	61
	62 (in-package #:cffi-sys)
	63
	64 ;;;# Mis-features
	65
	66 (pushnew 'flat-namespace features)
	67
	68 ;;;# Symbol Case
	69
	70 (defun canonicalize-symbol-name-case (name)
	71 (declare (string name))
	72 (if (eq ext:case-mode :upper)
	73 (string-upcase name)
	74 (string-downcase name)))
	75
	76 ;;;# Basic Pointer Operations
	77
	78 (deftype foreign-pointer ()
	79 'sys:system-area-pointer)
	80
	81 (declaim (inline pointerp))
	82 (defun pointerp (ptr)
	83 "Return true if 'ptr is a foreign pointer."
	84 (sys:system-area-pointer-p ptr))
	85
	86 (declaim (inline pointer-eq))
	87 (defun pointer-eq (ptr1 ptr2)
	88 "Return true if 'ptr1 and 'ptr2 point to the same address."
	89 (sys:sap= ptr1 ptr2))
	90
	91 (declaim (inline null-pointer))
	92 (defun null-pointer ()
	93 "Construct and return a null pointer."
	94 (sys:int-sap 0))
	95
	96 (declaim (inline null-pointer-p))
	97 (defun null-pointer-p (ptr)
	98 "Return true if 'ptr is a null pointer."
	99 (zerop (sys:sap-int ptr)))
	100
	101 (declaim (inline inc-pointer))
	102 (defun inc-pointer (ptr offset)
	103 "Return a pointer pointing 'offset bytes past 'ptr."
	104 (sys:sap+ ptr offset))
	105
	106 (declaim (inline make-pointer))
	107 (defun make-pointer (address)
	108 "Return a pointer pointing to 'address."
	109 (sys:int-sap address))
	110
	111 (declaim (inline pointer-address))
	112 (defun pointer-address (ptr)
	113 "Return the address pointed to by 'ptr."
	114 (sys:sap-int ptr))
	115
	116 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
	117 "Bind 'var to 'size bytes of foreign memory during 'body. The
	118 pointer in 'var is invalid beyond the dynamic extent of 'body, and
	119 may be stack-allocated if supported by the implementation. If
	120 'size-var is supplied, it will be bound to 'size during 'body."
	121 (unless size-var
	122 (setf size-var (gensym (symbol-name '#:size))))
	123 ;; If the size is constant we can stack-allocate.
	124 (cond ((constantp size)
	125 (let ((alien-var (gensym (symbol-name '#:alien))))
	126 `(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))
	127 (let ((,size-var ,size)
	128 (,var (alien-sap ,alien-var)))
	129 (declare (ignorable ,size-var))
	130 ,@body))))
	131 (t
	132 `(let ((,size-var ,size))
	133 (alien:with-bytes (,var ,size-var)
	134 ,@body)))))
	135
	136 ;;;# Allocation
	137 ;;;
	138 ;;; Functions and macros for allocating foreign memory on the stack and …
	139 ;;; heap. The main CFFI package defines macros that wrap 'foreign-alloc…
	140 ;;; 'foreign-free in 'unwind-protect for the common usage when the memor…
	141 ;;; dynamic extent.
	142
	143 (defun %foreign-alloc (size)
	144 "Allocate 'size bytes on the heap and return a pointer."
	145 (declare (type (unsigned-byte #-64bit 32 #+64bit 64) size))
	146 (alien-funcall (extern-alien "malloc"
	147 (function system-area-pointer unsigned))
	148 size))
	149
	150 (defun foreign-free (ptr)
	151 "Free a 'ptr allocated by 'foreign-alloc."
	152 (declare (type system-area-pointer ptr))
	153 (alien-funcall (extern-alien "free"
	154 (function (values) system-area-pointer))
	155 ptr))
	156
	157 ;;;# Shareable Vectors
	158
	159 (defun make-shareable-byte-vector (size)
	160 "Create a Lisp vector of 'size bytes that can passed to
	161 'with-pointer-to-vector-data."
	162 (make-array size :element-type '(unsigned-byte 8)))
	163
	164 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
	165 "Bind 'ptr-var to a foreign pointer to the data in 'vector."
	166 (let ((vector-var (gensym (symbol-name '#:vector))))
	167 `(let ((,vector-var ,vector))
	168 (ext:with-pinned-object (,vector-var)
	169 (let ((,ptr-var (sys:vector-sap ,vector-var)))
	170 ,@body)))))
	171
	172 ;;;# Dereferencing
	173
	174 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
	175 ;;; macros that optimize the case where the type keyword is constant
	176 ;;; at compile-time.
	177 (defmacro define-mem-accessors (&body pairs)
	178 `(progn
	179 (defun %mem-ref (ptr type &optional (offset 0))
	180 (ecase type
	181 ,@(loop for (keyword fn) in pairs
	182 collect `(,keyword (,fn ptr offset)))))
	183 (defun %mem-set (value ptr type &optional (offset 0))
	184 (ecase type
	185 ,@(loop for (keyword fn) in pairs
	186 collect `(,keyword (setf (,fn ptr offset) value)))))
	187 (define-compiler-macro %mem-ref
	188 (&whole form ptr type &optional (offset 0))
	189 (if (constantp type)
	190 (ecase (eval type)
	191 ,@(loop for (keyword fn) in pairs
	192 collect `(,keyword `(,',fn ,ptr ,offset))))
	193 form))
	194 (define-compiler-macro %mem-set
	195 (&whole form value ptr type &optional (offset 0))
	196 (if (constantp type)
	197 (once-only (value)
	198 (ecase (eval type)
	199 ,@(loop for (keyword fn) in pairs
	200 collect `(,keyword `(setf (,',fn ,ptr ,offset)
	201 ,value)))))
	202 form))))
	203
	204 (define-mem-accessors
	205 (:char sys:signed-sap-ref-8)
	206 (:unsigned-char sys:sap-ref-8)
	207 (:short sys:signed-sap-ref-16)
	208 (:unsigned-short sys:sap-ref-16)
	209 (:int sys:signed-sap-ref-32)
	210 (:unsigned-int sys:sap-ref-32)
	211 (:long #-64bit sys:signed-sap-ref-32 #+64bit sys:signed-sap-ref-64)
	212 (:unsigned-long #-64bit sys:sap-ref-32 #+64bit sys:sap-ref-64)
	213 (:long-long sys:signed-sap-ref-64)
	214 (:unsigned-long-long sys:sap-ref-64)
	215 (:float sys:sap-ref-single)
	216 (:double sys:sap-ref-double)
	217 #+long-float (:long-double sys:sap-ref-long)
	218 (:pointer sys:sap-ref-sap))
	219
	220 ;;;# Calling Foreign Functions
	221
	222 (defun convert-foreign-type (type-keyword)
	223 "Convert a CFFI type keyword to an ALIEN type."
	224 (ecase type-keyword
	225 (:char 'char)
	226 (:unsigned-char 'unsigned-char)
	227 (:short 'short)
	228 (:unsigned-short 'unsigned-short)
	229 (:int 'int)
	230 (:unsigned-int 'unsigned-int)
	231 (:long 'long)
	232 (:unsigned-long 'unsigned-long)
	233 (:long-long '(signed 64))
	234 (:unsigned-long-long '(unsigned 64))
	235 (:float 'single-float)
	236 (:double 'double-float)
	237 #+long-float
	238 (:long-double 'long-float)
	239 (:pointer 'system-area-pointer)
	240 (:void 'void)))
	241
	242 (defun %foreign-type-size (type-keyword)
	243 "Return the size in bytes of a foreign type."
	244 (values (truncate (alien-internals:alien-type-bits
	245 (alien-internals:parse-alien-type
	246 (convert-foreign-type type-keyword)))
	247 8)))
	248
	249 (defun %foreign-type-alignment (type-keyword)
	250 "Return the alignment in bytes of a foreign type."
	251 (values (truncate (alien-internals:alien-type-alignment
	252 (alien-internals:parse-alien-type
	253 (convert-foreign-type type-keyword)))
	254 8)))
	255
	256 (defun foreign-funcall-type-and-args (args)
	257 "Return an 'alien function type for 'args."
	258 (let ((return-type nil))
	259 (loop for (type arg) on args by #'cddr
	260 if arg collect (convert-foreign-type type) into types
	261 and collect arg into fargs
	262 else do (setf return-type (convert-foreign-type type))
	263 finally (return (values types fargs return-type)))))
	264
	265 (defmacro %%foreign-funcall (name types fargs rettype)
	266 "Internal guts of '%foreign-funcall."
	267 `(alien-funcall (extern-alien ,name (function ,rettype ,@types))
	268 ,@fargs))
	269
	270 (defmacro %foreign-funcall (name args &key library convention)
	271 "Perform a foreign function call, document it more later."
	272 (declare (ignore library convention))
	273 (multiple-value-bind (types fargs rettype)
	274 (foreign-funcall-type-and-args args)
	275 `(%%foreign-funcall ,name ,types ,fargs ,rettype)))
	276
	277 (defmacro %foreign-funcall-pointer (ptr args &key convention)
	278 "Funcall a pointer to a foreign function."
	279 (declare (ignore convention))
	280 (multiple-value-bind (types fargs rettype)
	281 (foreign-funcall-type-and-args args)
	282 (with-unique-names (function)
	283 `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))
	284 (alien-funcall ,function ,@fargs)))))
	285
	286 ;;; Callbacks
	287
	288 (defmacro %defcallback (name rettype arg-names arg-types body
	289 &key convention)
	290 (declare (ignore convention))
	291 `(alien:defcallback ,name
	292 (,(convert-foreign-type rettype)
	293 ,@(mapcar (lambda (sym type)
	294 (list sym (convert-foreign-type type)))
	295 arg-names arg-types))
	296 ,body))
	297
	298 (declaim (inline %callback))
	299 (defun %callback (name)
	300 (alien:callback-sap name))
	301
	302 ;;;# Loading and Closing Foreign Libraries
	303
	304 (defun %load-foreign-library (name path)
	305 "Load the foreign library 'name."
	306 (declare (ignore name))
	307 (ext:load-dynamic-object path))
	308
	309 (defun %close-foreign-library (name)
	310 "Closes the foreign library 'name."
	311 (ext:close-dynamic-object name))
	312
	313 (defun native-namestring (pathname)
	314 (ext:unix-namestring pathname nil))
	315
	316 ;;;# Foreign Globals
	317
	318 (defun %foreign-symbol-pointer (name library)
	319 "Returns a pointer to a foreign symbol 'name."
	320 (declare (ignore library))
	321 (let ((sap (sys:foreign-symbol-address name)))
	322 (if (zerop (sys:sap-int sap)) nil sap)))