home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / arraylib.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  9.7 KB  |  322 lines
  1. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  2.  
  3. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  4. ;;
  5. ;; GCL is free software; you can redistribute it and/or modify it under
  6. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  7. ;; the Free Software Foundation; either version 2, or (at your option)
  8. ;; any later version.
  9. ;; 
  10. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  11. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  13. ;; License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Library General Public License 
  16. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  17. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.  
  20. ;;;;    arraylib.lsp
  21. ;;;;
  22. ;;;;                            array routines
  23.  
  24.  
  25. (in-package 'lisp)
  26.  
  27.  
  28. (export '(make-array vector
  29.           array-element-type array-rank array-dimension
  30.           array-dimensions
  31.           array-in-bounds-p array-row-major-index
  32.           adjustable-array-p
  33.           bit sbit
  34.           bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor
  35.           bit-andc1 bit-andc2 bit-orc1 bit-orc2 bit-not
  36.           array-has-fill-pointer-p fill-pointer
  37.           vector-push vector-push-extend vector-pop
  38.           adjust-array))
  39.  
  40.  
  41. (in-package 'system)
  42.  
  43.  
  44. (proclaim '(optimize (safety 2) (space 3)))
  45.  
  46. (defun best-array-element-type (type)
  47.   (cond ((or (eql t type) (null type))
  48.      t)
  49.     ((memq type '(bit unsigned-char signed-char
  50.                     unsigned-short
  51.                     signed-short fixnum))
  52.            type)
  53.     ((subtypep type 'fixnum)
  54.      (dolist (v '(bit unsigned-char signed-char
  55.                     unsigned-short
  56.                     signed-short)
  57.             'fixnum)
  58.          (cond ((subtypep type v)
  59.             (return v)))))
  60.     ((eql type 'character) 'string-char)
  61.     (t (or (dolist (v '(string-char bit short-float
  62.                     long-float))
  63.            (cond ((subtypep type v)
  64.               (return v))))
  65.            t))))
  66.      
  67.  
  68. (defun make-array (dimensions
  69.            &key (element-type t)
  70.             (initial-element nil)
  71.             (initial-contents nil initial-contents-supplied-p)
  72.             adjustable fill-pointer
  73.             displaced-to (displaced-index-offset 0)
  74.             static)
  75.   (when (integerp dimensions) (setq dimensions (list dimensions)))
  76.   (setq element-type (best-array-element-type element-type))
  77.   (cond ((= (length dimensions) 1)
  78.      (let ((x (si:make-vector element-type (car dimensions)
  79.                               adjustable fill-pointer
  80.                               displaced-to displaced-index-offset
  81.                               static initial-element)))
  82.        (when initial-contents-supplied-p
  83.          (do ((n (car dimensions))
  84.               (i 0 (1+ i)))
  85.              ((>= i n))
  86.            (declare (fixnum n i))
  87.            (si:aset x i (elt initial-contents i))))
  88.        x))
  89.         (t
  90.      (let ((x
  91.         (apply #'si:make-pure-array
  92.                element-type adjustable 
  93.                displaced-to displaced-index-offset
  94.                static initial-element
  95.                dimensions)))
  96.        (if fill-pointer (error "fill pointer for 1 dimensional arrays only"))
  97.            (unless (member 0 dimensions)
  98.        (when initial-contents-supplied-p
  99.          (do ((cursor
  100.                (make-list (length dimensions)
  101.                           :initial-element 0)))
  102.              (nil)
  103.              (declare (:dynamic-extent cursor))
  104.            (aset-by-cursor x
  105.                        (sequence-cursor initial-contents
  106.                                         cursor)
  107.                    cursor)
  108.            (when (increment-cursor cursor dimensions)
  109.                           (return nil)))))
  110.             x))))
  111.  
  112.  
  113. (defun increment-cursor (cursor dimensions)
  114.   (if (null cursor)
  115.       t
  116.       (let ((carry (increment-cursor (cdr cursor) (cdr dimensions))))
  117.     (if carry
  118.         (cond ((>= (the fixnum (1+ (the fixnum (car cursor))))
  119.                    (the fixnum (car dimensions)))
  120.            (rplaca cursor 0)
  121.            t)
  122.           (t
  123.            (rplaca cursor
  124.                    (the fixnum (1+ (the fixnum (car cursor)))))
  125.            nil))
  126.         nil))))
  127.  
  128.  
  129. (defun sequence-cursor (sequence cursor)
  130.   (if (null cursor)
  131.       sequence
  132.       (sequence-cursor (elt sequence (the fixnum (car cursor)))
  133.                        (cdr cursor))))
  134.  
  135.  
  136. (defun vector (&rest objects &aux (l (list (length objects))))
  137.   (declare (:dynamic-extent objects l))
  138.   (make-array l
  139.           :element-type t
  140.           :initial-contents objects))
  141.  
  142.  
  143. (defun array-dimensions (array)
  144.   (do ((i (array-rank array))
  145.        (d nil))
  146.       ((= i 0) d)
  147.     (setq i (1- i))
  148.     (setq d (cons (array-dimension array i) d))))
  149.  
  150.  
  151. (defun array-in-bounds-p (array &rest indices &aux (r (array-rank array)))
  152.   (declare (:dynamic-extent indices))
  153.   (when (/= r (length indices))
  154.         (error "The rank of the array is ~R,~%~
  155.                ~7@Tbut ~R ~:*~[indices are~;index is~:;indices are~] ~
  156.                supplied."
  157.                r (length indices)))
  158.   (do ((i 0 (1+ i))
  159.        (s indices (cdr s)))
  160.       ((>= i r) t)
  161.     (when (or (< (car s) 0)
  162.               (>= (car s) (array-dimension array i)))
  163.           (return nil))))
  164.  
  165.  
  166. (defun array-row-major-index (array &rest indices)
  167.   (declare (:dynamic-extent indices))
  168.   (do ((i 0 (1+ i))
  169.        (j 0 (+ (* j (array-dimension array i)) (car s)))
  170.        (s indices (cdr s)))
  171.       ((null s) j)))
  172.  
  173.  
  174. (defun bit (bit-array &rest indices)
  175.   (declare (:dynamic-extent indices))
  176.   (apply #'aref bit-array indices))
  177.  
  178.  
  179. (defun sbit (bit-array &rest indices)
  180.   (declare (:dynamic-extent indices))
  181.   (apply #'aref bit-array indices))
  182.  
  183.  
  184. (defun bit-and (bit-array1 bit-array2 &optional result-bit-array)
  185.   (bit-array-op boole-and bit-array1 bit-array2 result-bit-array))
  186.  
  187.  
  188. (defun bit-ior (bit-array1 bit-array2 &optional result-bit-array)
  189.   (bit-array-op boole-ior bit-array1 bit-array2 result-bit-array))
  190.  
  191.  
  192. (defun bit-xor (bit-array1 bit-array2 &optional result-bit-array)
  193.   (bit-array-op boole-xor bit-array1 bit-array2 result-bit-array))
  194.  
  195.  
  196. (defun bit-eqv (bit-array1 bit-array2 &optional result-bit-array)
  197.   (bit-array-op boole-eqv bit-array1 bit-array2 result-bit-array))
  198.  
  199.     
  200. (defun bit-nand (bit-array1 bit-array2 &optional result-bit-array)
  201.   (bit-array-op boole-nand bit-array1 bit-array2 result-bit-array))
  202.  
  203.     
  204. (defun bit-nor (bit-array1 bit-array2 &optional result-bit-array)
  205.   (bit-array-op boole-nor bit-array1 bit-array2 result-bit-array))
  206.  
  207.     
  208. (defun bit-andc1 (bit-array1 bit-array2 &optional result-bit-array)
  209.   (bit-array-op boole-andc1 bit-array1 bit-array2 result-bit-array))
  210.  
  211.     
  212. (defun bit-andc2 (bit-array1 bit-array2 &optional result-bit-array)
  213.   (bit-array-op boole-andc2 bit-array1 bit-array2 result-bit-array))
  214.  
  215.     
  216. (defun bit-orc1 (bit-array1 bit-array2 &optional result-bit-array)
  217.   (bit-array-op boole-orc1 bit-array1 bit-array2 result-bit-array))
  218.  
  219.     
  220. (defun bit-orc2 (bit-array1 bit-array2 &optional result-bit-array)
  221.   (bit-array-op boole-orc2 bit-array1 bit-array2 result-bit-array))
  222.  
  223.     
  224. (defun bit-not (bit-array &optional result-bit-array)
  225.   (bit-array-op boole-c1 bit-array bit-array result-bit-array))
  226.  
  227.  
  228. (defun vector-push (new-element vector)
  229.   (let ((fp (fill-pointer vector)))
  230.     (declare (fixnum fp))
  231.     (cond ((< fp (the fixnum (array-dimension vector 0)))
  232.            (si:aset vector fp new-element)
  233.            (si:fill-pointer-set vector (the fixnum (1+ fp)))
  234.        fp)
  235.       (t nil))))
  236.  
  237.  
  238. (defun vector-push-extend (new-element vector &optional extension)
  239.   (let ((fp (fill-pointer vector)))
  240.     (declare (fixnum fp))
  241.     (cond ((< fp (the fixnum (array-dimension vector 0)))
  242.        (si:aset vector fp new-element)
  243.        (si:fill-pointer-set vector (the fixnum (1+ fp)))
  244.        fp)
  245.       (t
  246.        (adjust-array vector
  247.                      (list (+ (array-dimension vector 0)
  248.                   (or extension
  249.                       (if (> (array-dimension vector 0)  0)
  250.                       (array-dimension vector 0)
  251.                     5))))
  252.                      :element-type (array-element-type vector)
  253.              :fill-pointer fp)
  254.        (si:aset vector fp new-element)
  255.        (si:fill-pointer-set vector (the fixnum (1+ fp)))
  256.        fp))))
  257.  
  258.  
  259. (defun vector-pop (vector)
  260.   (let ((fp (fill-pointer vector)))
  261.     (declare (fixnum fp))
  262.     (when (= fp 0)
  263.           (error "The fill pointer of the vector ~S zero." vector))
  264.     (si:fill-pointer-set vector (the fixnum (1- fp)))
  265.     (aref vector (the fixnum (1- fp)))))
  266.  
  267.  
  268. (defun adjust-array (array new-dimensions
  269.                      &rest r
  270.              &key element-type
  271.               initial-element
  272.               initial-contents
  273.               fill-pointer
  274.               displaced-to
  275.               displaced-index-offset
  276.               static)
  277.   (declare (ignore 
  278.                    initial-element
  279.                    initial-contents
  280.                    fill-pointer
  281.                    displaced-to
  282.                    displaced-index-offset
  283.                    static))
  284.   (declare (:dynamic-extent r new-dimensions))
  285.   (when (integerp new-dimensions)
  286.         (setq new-dimensions (list new-dimensions)))
  287.   (if (member :fill-pointer r)
  288.       (unless (array-has-fill-pointer-p array)
  289.           (error ":fill-pointer specified for array with no fill pointer"))
  290.     (when (array-has-fill-pointer-p array)
  291.       (push (fill-pointer array) r) (push :fill-pointer r)))
  292.  
  293.   (setq element-type (array-element-type array))
  294.   (unless (eq element-type t) (push element-type r)
  295.       (push :element-type r))
  296.   (let ((x (apply #'make-array new-dimensions :adjustable t r)))
  297.     (cond ((or (null (cdr new-dimensions))
  298.            (and (equal (cdr new-dimensions)
  299.                (cdr (array-dimensions array)))
  300.             (or (not (eq element-type 'bit))
  301.             (eql 0 (the fixnum
  302.                     (mod
  303.                       (the fixnum (car (last new-dimensions)))
  304.                       char-size))))))
  305.        (copy-array-portion array   x
  306.                    0 0
  307.                    (min (array-total-size x)
  308.                     (array-total-size array))))
  309.       (t
  310.         (do ((cursor (make-list (length new-dimensions)
  311.                     :initial-element 0)))
  312.         (nil)
  313.         (declare (:dynamic-extent cursor))
  314.         (when (apply #'array-in-bounds-p array cursor)
  315.               (aset-by-cursor x
  316.                       (apply #'aref array cursor)
  317.                       cursor))
  318.         (when (increment-cursor cursor new-dimensions)
  319.               (return nil)))))
  320.     (si:replace-array array x)
  321.     ))
  322.