From 4157d85957b1b89fabf1a55f2896ec58ee6d99d6 Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Sat, 2 Feb 2008 21:50:09 +0100 Subject: Add OBJECTIVE-C-CLASS, a metaclass for Objective-C class wrappers. darcs-hash:edb69af98619671f830ff842fb3e69ca369ee8dd --- Lisp/class-definition.lisp | 142 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 142 insertions(+) create mode 100644 Lisp/class-definition.lisp (limited to 'Lisp/class-definition.lisp') diff --git a/Lisp/class-definition.lisp b/Lisp/class-definition.lisp new file mode 100644 index 0000000..3da1ec2 --- /dev/null +++ b/Lisp/class-definition.lisp @@ -0,0 +1,142 @@ +;;;; Objective-CL, an Objective-C bridge for Common Lisp. +;;;; Copyright (C) 2007 Matthias Andreas Benkard. +;;;; +;;;; This program is free software: you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public License +;;;; as published by the Free Software Foundation, either version 3 of +;;;; the License, or (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, but +;;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this program. If not, see +;;;; . + +(in-package #:mulk.objective-cl) + + +(defclass foreign-slot-definition-mixin () + ((foreign-name :initarg :foreign-name + :initform nil + :accessor slot-definition-foreign-name + :type (or null string)) + (foreign-type :initarg :foreign-type + :initform nil + :accessor slot-definition-foreign-type) + #+(#:unused) + (property :initarg :property + :accessor slot-definition-property-p + :type boolean))) + +(defclass foreign-direct-slot-definition + (foreign-slot-definition-mixin c2mop:standard-direct-slot-definition) + ()) + +(defclass foreign-effectve-slot-definition + (foreign-slot-definition-mixin c2mop:standard-effective-slot-definition) + ()) + +(defclass objective-c-class (standard-class) + ((class-ptr :initarg :class-ptr + :type c-pointer + :accessor pointer-to))) + + +(defmethod c2mop:direct-slot-definition-class ((class objective-c-class) + &rest initargs) + (if (some #'(lambda (symbol) (let ((nada '#:nada)) + (not (eq nada (getf initargs symbol nada))))) + '(:foreign-type :foreign-name)) + (find-class 'foreign-direct-slot-definition) + (find-class 'c2mop:standard-direct-slot-definition))) + + +(defmethod c2mop:effective-slot-definition-class ((class objective-c-class) + &rest initargs) + (if (some #'(lambda (symbol) (let ((nada '#:nada)) + (not (eq nada (getf initargs symbol nada))))) + '(:foreign-type :foreign-name)) + (find-class 'foreign-direct-slot-definition) + (find-class 'c2mop:standard-direct-slot-definition))) + + +(defmethod c2mop:slot-value-using-class ((class objective-c-class) + instance + effective-slot-definition) + (etypecase effective-slot-definition + (standard-effective-slot-definition (call-next-method)) + (foreign-effective-slot-definition + (cerror "FIXME" '())))) + + +(defmethod (setf c2mop:slot-value-using-class) (value + (class objective-c-class) + instance + effective-slot-definition) + (etypecase effective-slot-definition + (standard-effective-slot-definition (call-next-method)) + (foreign-effective-slot-definition + (cerror "FIXME" '())))) + + +(defmethod c2mop:compute-slots ((class objective-c-class)) + ;; FIXME: Maybe add lots of foreign slots here whose presence the + ;; Objective-C runtime tells us. + (call-next-method)) + + +#+(or) +(defmethod make-instance ((class-name (eql 'objective-c-class)) &rest initargs) + (let ((class (call-next-method))) + class)) + +#+(or) +(defmethod initialize-instance ((class objective-c-class) + &key documentation + name + plist + direct-superclasses + direct-slots + direct-default-initargs + class-ptr + wrapped-foreign-class) + (call-next-method)) + +#+(or) +(defmethod reinitialize-instance ((class objective-c-class) + &key documentation + name + plist + direct-superclasses + direct-slots + direct-default-initargs + class-ptr + wrapped-foreign-class) + (call-next-method)) + +#+(or) +(defmethod c2mop:compute-effective-slot-definition ((class objective-c-class) + slot-name + direct-slots) + (call-next-method)) + + +#+(or) +(make-instance 'objective-c-class :wrapped-foreign-class "NSString") +#+(or) +(c2mop:ensure-class 'ns-string + :metaclass 'objective-c-class + :wrapped-foreign-class "NSString") +#+(or) +(defclass ns-string () + ((bla :foreign-type 'string + :foreign-name "_bla" + :accessor ns-string-bla) + (nothing :accessor ns-string-nothing + :initarg :ns-string + :initform 100)) + (:metaclass objective-c-class) + (:wrapped-foreign-class "NSString")) -- cgit v1.2.3