From 4714129a8ba875f082f522c07c039fba12395ded Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Fri, 14 Mar 2008 18:16:05 +0100 Subject: Implement the generic sequence protocol for NSArray on SBCL. darcs-hash:af39e2a05a060e7f805e7218ef808c1721edcdd3 --- Lisp/util-sequences.lisp | 61 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 61 insertions(+) create mode 100644 Lisp/util-sequences.lisp (limited to 'Lisp') diff --git a/Lisp/util-sequences.lisp b/Lisp/util-sequences.lisp new file mode 100644 index 0000000..da651dc --- /dev/null +++ b/Lisp/util-sequences.lisp @@ -0,0 +1,61 @@ +;;;; Objective-CL, an Objective-C bridge for Common Lisp. +;;;; Copyright (C) 2007, 2008 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) + + +#+sbcl +(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (find-objc-class "NSArray" t)) + + (defmethod sb-sequence:length ((array ns::ns-array)) + (invoke-by-name array "count")) + + (defmethod sb-sequence:elt ((array ns::ns-array) index) + (invoke-by-name array "objectAtIndex:" index)) + + (defmethod (setf sb-sequence:elt) (new-value (array ns::ns-array) index) + (invoke-by-name array "setObject:atIndex:" new-value index)) + + (defmethod sb-sequence:adjust-sequence ((array ns::ns-array) + length + &key initial-element + initial-contents) + (cond ((< length (sb-sequence:length array)) + (dotimes (i (- (sb-sequence:length array) length)) + (invoke-by-name array "removeLastObject"))) + ((> length (sb-sequence:length array)) + (loop for i from (sb-sequence:length array) below length + do (invoke-by-name array + "addObject:" + (if (> (length initial-contents) i) + (elt initial-contents i) + initial-element))))) + array) + + (defmethod sb-sequence:make-sequence-like ((array ns::ns-array) + length + &key initial-element + initial-contents) + (let ((new-array (invoke-by-name (class-of array) + "arrayWithArray:" + array))) + (sb-sequence:adjust-sequence new-array + length + :initial-element initial-element + :initial-contents initial-contents)))) -- cgit v1.2.3