From 1b556d9e057c6e3bed4893036d12eed1f3bc238d Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Thu, 7 Aug 2008 14:57:27 +0200 Subject: Add various array operations. --- MLKArray.h | 2 ++ MLKArray.m | 5 +++++ Sacla/array.lisp | 9 ++++++++ Sacla/data-and-control.lisp | 3 +++ array.lisp | 33 +++++++++++++++++++++++++++ control-flow.lisp | 21 ++++++++++++++++++ init.lisp | 5 +++++ numbers.lisp | 54 ++++++++++++++++++++++++++++++++++++++++++++- 8 files changed, 131 insertions(+), 1 deletion(-) create mode 100644 array.lisp diff --git a/MLKArray.h b/MLKArray.h index 4cc7184..4e7d093 100644 --- a/MLKArray.h +++ b/MLKArray.h @@ -32,6 +32,8 @@ -(id) initWithDimensions:(NSArray *)dimensions; +-(NSArray *) dimensions; + // The following methods are like the similarly named // NSArray/NSMutableArray methods but treat nil as just another object. // Where nil would be returned otherwise, these methods throw an diff --git a/MLKArray.m b/MLKArray.m index 65e8930..3500596 100644 --- a/MLKArray.m +++ b/MLKArray.m @@ -50,6 +50,11 @@ return self; } +-(NSArray *) dimensions +{ + return _dimensions; +} + -(id) idAtIndex:(NSUInteger)index { if (index > _size || (_fillPointer != -1 && index > _fillPointer)) diff --git a/Sacla/array.lisp b/Sacla/array.lisp index 4fd0147..23b6c39 100644 --- a/Sacla/array.lisp +++ b/Sacla/array.lisp @@ -27,6 +27,15 @@ ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +(in-package #:common-lisp) + +(export '(aref array-dimenion array-in-bounds-p array-rank + array-row-major-index array-total-size bit-andc1 bit-andc2 + bit-eqv bit-nand bit-nor bit-orc1 bit-orc2 bit-vector-p + simple-bit-vector-p vector vector-pop vector-push + vector-push-extend vectorp )) + + (defun aref (array &rest subscripts) "Access an element of ARRAY specified by SUBSCRIPTS." (row-major-aref array (apply #'array-row-major-index array subscripts))) diff --git a/Sacla/data-and-control.lisp b/Sacla/data-and-control.lisp index cea7493..236440b 100644 --- a/Sacla/data-and-control.lisp +++ b/Sacla/data-and-control.lisp @@ -26,6 +26,9 @@ ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +(in-package #:common-lisp) + + (defun expand-case (keyform clauses &key (test #'eql)) (let ((key (gensym)) (last (car (last clauses)))) diff --git a/array.lisp b/array.lisp new file mode 100644 index 0000000..2676c06 --- /dev/null +++ b/array.lisp @@ -0,0 +1,33 @@ +;;; -*- mode: lisp; coding: utf-8 -*- +;;; Toilet Lisp, a Common Lisp subset for the Étoilé runtime. +;;; Copyright (C) 2008 Matthias Andreas Benkard. +;;; +;;; This program is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU 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 +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see . + + +(in-package #:common-lisp) + +(export '(aref row-major-aref)) + + +(defun row-major-aref (array row-major-index) + (send-by-name array "idAtIndex:" row-major-index)) + +(defun (setf row-major-aref) (new-value array row-major-index) + (send-by-name array "replaceIdAtIndex:withId:" row-major-index new-value)) + +(defun array-dimensions (array) + (send-by-name (find-objc-class "MLKCons") + "listWithArray:" + (send-by-name array "dimensions"))) diff --git a/control-flow.lisp b/control-flow.lisp index a75fe6a..bcd8e23 100644 --- a/control-flow.lisp +++ b/control-flow.lisp @@ -236,3 +236,24 @@ (defun values-list (list) (apply #'values list)) + + +;; FIXME +(defmacro assert (form &optional places datum &rest args) + ) + +;; FIXME +(defmacro check-type (thing type &rest strings) + ) + +;; FIXME +(defmacro defsetf (&rest args) + ) + +;; FIXME +(defun get-setf-expansion (&rest args) + (values nil nil nil `(error "SETF not implemented") `(error "SETF not implemented"))) + +;; FIXME +(defmacro define-setf-expander (&rest args) + ) diff --git a/init.lisp b/init.lisp index 0f7816c..d5a78d5 100644 --- a/init.lisp +++ b/init.lisp @@ -38,6 +38,11 @@ (load "Sacla/share-2.lisp") +(load "Sacla/data-and-control.lisp") + +(load "array.lisp") +(load "Sacla/array.lisp") + (setq *system-initialised-p* t) (in-package #:common-lisp-user) diff --git a/numbers.lisp b/numbers.lisp index 607ccab..af58878 100644 --- a/numbers.lisp +++ b/numbers.lisp @@ -18,7 +18,7 @@ (in-package #:common-lisp) -(export '(1+ 1- =)) +(export '(1+ 1- = mod evenp oddp zerop + - *)) (defun 1+ (n) @@ -39,3 +39,55 @@ (integer (etypecase y (fixnum nil) (integer (%= x y)))))) + +(defun + (x y) + (etypecase x + (fixnum (etypecase y + (fixnum (add-fixnums x y)) + (integer (send-by-name x "add:" y)))) + (integer (etypecase y + (integer (send-by-name x "add:" y)))))) + +(defun - (x y) + (etypecase x + (fixnum (etypecase y + (fixnum (subtract-fixnums x y)) + (integer (send-by-name x "subtract:" y)))) + (integer (etypecase y + (integer (send-by-name x "subtract:" y)))))) + +(defun * (x y) + (etypecase x + (fixnum (etypecase y + (fixnum (multiply-fixnums x y)) + (integer (send-by-name x "multiplyWith:" y)))) + (integer (etypecase y + (integer (send-by-name x "multiplyWith:" y)))))) + +(defun idiv (x y) + (etypecase x + (fixnum (etypecase y + (fixnum (idivide-fixnums x y)) + (integer (send-by-name x "divideBy:" y)))) + (integer (etypecase y + (integer (send-by-name x "divideBy:" y)))))) + +(defun mod (n m) +;; (if (and (typep n 'fixnum) +;; (typep m 'fixnum)) +;; (fixnum-mod n m) +;; (send-by-name n "mod:" m)) + (send-by-name n "mod:" m)) + + +(defun evenp (n) + (etypecase n + (fixnum (zerop (mod n 2))) + (integer (send-by-name n "evenp")))) + +(defun oddp (n) + (not (evenp n))) + +(defun zerop (n) + (etypecase n + (integer (%zerop n)))) -- cgit v1.2.3