mirror of
https://github.com/KevinMidboe/linguist.git
synced 2025-10-29 17:50:22 +00:00
Add samples for .l.
array.l by NANRI southly; MIT license. simul.l by Alexander Burger; MIT license.
This commit is contained in:
Lars Brinkhoff
164
samples/Common Lisp/array.l
Normal file
164
samples/Common Lisp/array.l
Normal file
@@ -0,0 +1,164 @@
|
||||
;;; -*- 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)))))
|
||||
Reference in New Issue
Block a user