Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

165 lines (152 sloc) 5.042 kb
;;; -*- Mode: Lisp; Package: LISP -*-
;;;
;;; This file is part of xyzzy.
;;;
(provide "array")
(in-package "lisp")
(export '(make-vector make-array vector array-dimensions array-in-bounds-p
upgraded-array-element-type adjust-array))
(defun upgraded-array-element-type (type)
(cond ((or (eq type 't)
(null type))
't)
((member type '(character base-character standard-char
extended-character) :test #'eq)
'character)
(t
(setq type (car (si:canonicalize-type type)))
(cond ((or (eq type 't)
(null type))
't)
((member type '(character base-character standard-char
extended-character) :test #'eq)
'character)
(t 't)))))
(defun check-array-initialize-option (ies-p ics-p displaced-to)
(let ((x 0))
(and ies-p (incf x))
(and ics-p (incf x))
(and displaced-to (incf x))
(when (> x 1)
(error ":initial-element, :initial-contents, :displaced-toは同時に指定できません"))))
(defun make-vector (length &key
(element-type t)
(initial-element nil ies-p)
(initial-contents nil ics-p)
fill-pointer
adjustable
displaced-to
(displaced-index-offset 0))
(setq element-type (upgraded-array-element-type element-type))
(check-array-initialize-option ies-p ics-p displaced-to)
(let ((vector (si:*make-vector length element-type initial-element adjustable
fill-pointer displaced-to displaced-index-offset)))
(when ics-p
(si:*copy-into-seq vector initial-contents))
vector))
(defun make-array (dimensions &rest rest
&key
(element-type t)
(initial-element nil ies-p)
(initial-contents nil ics-p)
fill-pointer
adjustable
displaced-to
(displaced-index-offset 0))
(cond ((integerp dimensions)
(apply #'make-vector dimensions rest))
((= (length dimensions) 1)
(apply #'make-vector (car dimensions) rest))
(t
(setq element-type (upgraded-array-element-type element-type))
(check-array-initialize-option ies-p ics-p displaced-to)
(when fill-pointer
(error ":fill-pointerはベクタ以外には指定できません"))
(let ((array (si:*make-array dimensions element-type
initial-element adjustable
displaced-to displaced-index-offset)))
(when ics-p
(let ((dims (make-list (array-rank array)
:initial-element 0))
(stack (list initial-contents))
(rank (1- (array-rank array))))
(dolist (x dims)
(push (elt (car stack) 0) stack))
(dotimes (i (array-total-size array))
(setf (row-major-aref array i) (car stack))
(do ((x dims (cdr x))
(j rank (1- j)))
((null x))
(pop stack)
(incf (car x))
(when (< (car x) (array-dimension array j))
(do ((r (- rank j) (1- r)))
((< r 0))
(push (elt (car stack) (nth r dims)) stack))
(return))
(setf (car x) 0)))))
array))))
(defun vector (&rest list)
(make-vector (length list) :element-type t :initial-contents list))
(defun array-dimensions (array)
(do ((i (1- (array-rank array)) (1- i))
(dims '()))
((minusp i) dims)
(push (array-dimension array i) dims)))
(defun array-in-bounds-p (array &rest subscripts)
(let ((r (array-rank array)))
(when (/= r (length subscripts))
(error "subscriptsの個数が配列のランクと異なります: ~S" subscripts))
(do ((i 0 (1+ i))
(s subscripts (cdr s)))
((= i r) t)
(unless (<= 0 (car s) (1- (array-dimension array i)))
(return nil)))))
(defun adjust-array (old-array
dimensions
&rest rest
&key
(element-type nil ets-p)
initial-element
(initial-contents nil ics-p)
(fill-pointer nil fps-p)
displaced-to
displaced-index-offset)
(when (/= (length dimensions) (array-rank old-array))
(error "配列のランクが異なります"))
(unless ets-p
(push (array-element-type old-array) rest)
(push :element-type rest))
(when (adjustable-array-p old-array)
(push t rest)
(push :adjustable rest))
(cond (fps-p
(unless (array-has-fill-pointer-p old-array)
(error "フィルポインタを持たない配列にフィルポインタが指定されました")))
(t
(when (array-has-fill-pointer-p old-array)
(push (fill-pointer old-array) rest)
(push :fill-pointer rest))))
(when (eq old-array displaced-to)
(error "自分自身を共有することはできません"))
(let ((new-array (apply #'make-array dimensions rest)))
(or ics-p displaced-to
(copy-array-partially old-array new-array))
(cond ((adjustable-array-p old-array)
(si:*replace-array old-array new-array)
old-array)
(t
new-array))))
(defun copy-array-partially (src dst)
(let* ((dims (mapcar #'min (array-dimensions src) (array-dimensions dst)))
(r (array-rank src))
(s (make-list r :initial-element 0)))
(setq r (1- r))
(dotimes (x (apply #'* dims))
(setf (apply #'aref dst s) (apply #'aref src s))
(do ((i r (1- i)))
((minusp i))
(incf (nth i s))
(when (< (nth i s) (nth i dims))
(return))
(setf (nth i s) 0)))))
Jump to Line
Something went wrong with that request. Please try again.