Add various array operations.

8 files changed, 131 insertions, 1 deletions

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 <http://www.gnu.org/licenses/>.
+
+
+(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))))