+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: aggregates.cl
-;;;; Purpose: UFFI source to handle aggregate types
-;;;; Programmers: Kevin M. Rosenberg and John DeSoi
-;;;; Date Started: Feb 2002
-;;;;
-;;;; $Id: aggregates.cl,v 1.1 2002/08/02 14:39:12 kevin Exp $
-;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;; and John DeSoi
-;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
-
-
-
-(defmacro def-enum (enum-name args &key (separator-string "#"))
- "Creates a constants for a C type enum list, symbols are created
-in the created in the current package. The symbol is the concatenation
-of the enum-name name, separator-string, and field-name"
- (let ((counter 0)
- (cmds nil)
- (constants nil))
- (declare (fixnum counter))
- (dolist (arg args)
- (let ((name (if (listp arg) (car arg) arg))
- (value (if (listp arg)
- (prog1
- (setq counter (cadr arg))
- (incf counter))
- (prog1
- counter
- (incf counter)))))
- (setq name (intern (concatenate 'string
- (symbol-name enum-name)
- separator-string
- (symbol-name name))))
- (push `(uffi:def-constant ,name ,value) constants)))
- (setf cmds (append '(progn)
- #+allegro `((ff:def-foreign-type ,enum-name :int))
- #+lispworks `((fli:define-c-typedef ,enum-name :int))
- #+cmu `((alien:def-alien-type ,enum-name alien:signed))
- #+mcl `((def-mcl-type ,enum-name :integer))
- (nreverse constants)))
- cmds))
-
-
-
-(defmacro def-array-pointer (name-array type)
- `(def-mcl-type ,name-array '(:array ,type)))
-
-
-; this is how rref expands array slot access (minus adding the struct offset)
-(defmacro deref-array (obj type i)
- "Returns a field from a row"
- `(,(accessor-symbol type :get) ,obj (* (the fixnum ,i) ,(foreign-object-size type))))
-
-(defmacro deref-array-set (obj type i value)
- `(,(accessor-symbol type :set) ,obj ,value (* (the fixnum ,i) ,(foreign-object-size type))))
-
-(defsetf deref-array deref-array-set)
-
-
-(defun process-struct-fields (name fields variant)
- (let (processed)
- (dolist (field fields)
- (let* ((field-name (car field))
- (type (cadr field))
- (def (append (list field-name)
- (if (eq type :pointer-self)
- #+cmu `((* (alien:struct ,name)))
- #-cmu `((* ,name))
- `(,(convert-from-uffi-type type :struct))))))
- (if variant
- (push (list def) processed)
- (push def processed))))
- (nreverse processed)))
-
-
-(defmacro def-struct (name &rest fields)
- `(ccl:defrecord ,name ,@(process-struct-fields name fields nil)))
-
-
-(defmacro def-union (name &rest fields)
- `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t))))
-
-
-; Assuming everything is pointer based - no support for Mac handles
-(defmacro get-slot-value (obj type slot) ;use setf to set values
- `(ccl:pref ,obj ,(read-from-string (format nil "~a.~a" type slot))))
-
-
-(defmacro get-slot-pointer (obj type slot)
- `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot)))))
-
-
-
-#| a few simple tests
-(def-union union
- (l1 :long)
- (s1 :short))
-
-(def-struct struct
- (s1 :short)
- (l1 :long)
- (u1 :union))
-
-(defvar s (allocate-foreign-object :struct))
-(setf (get-slot-value s :struct :s1) 3)
-(get-slot-value s :struct :s1)
-(setf (get-slot-value s :struct :u1.s1) 5)
-(get-slot-value s :struct :u1.s1)
-
-|#
\ No newline at end of file
projects / uffi.git / blobdiff