Coverage report: /home/ellis/comp/core/std/array.lisp

Kind	Covered	All	%
expression	0	309	0.0
branch	0	30	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; std/array.lisp --- Standard Arrays

2

3

;;

4

5

;;; Code:

6

(in-package :std/array)

7

8

;; NOTE 2025-04-27: probably not a good idea

9

(declaim (optimize (safety 0) (speed 3)))

10

11

(declaim (ftype (function (array) array) copy-array)

12

(maybe-inline copy-array))

13

(defun copy-array (array)

14

"Make a new copy of ARRAY and return it."

15

(let ((new-array

16

(make-array (array-dimensions array)

17

:element-type (array-element-type array)

18

:adjustable (adjustable-array-p array)

19

:fill-pointer (and (array-has-fill-pointer-p array)

20

(fill-pointer array)))))

21

(loop for i below (array-total-size array)

22

do (setf (row-major-aref new-array i)

23

(row-major-aref array i)))

24

new-array))

25

26

;; from petalisp

27

(defun simplify-array (array)

28

"Returns an array with the same shape and elements as ARRAY, but that is

29

guaranteed to be simple."

30

(if (typep array 'simple-array)

31

array

32

(let ((copy (make-array (array-dimensions array)

33

:element-type (array-element-type array))))

34

(loop for index below (array-total-size array) do

35

(setf (row-major-aref copy index)

36

(row-major-aref array index)))

37

copy)))

38

39

(deftype signed-array-length ()

40

"A (possibly negated) array length."

41

'#.(let ((limit (1- array-dimension-limit)))

42

`(integer ,(- limit) ,limit)))

43

44

;; From Shinmera's PIPING

45

(defun array-shift (array &key (n 1) (from 0) (to (length array)) (adjust t) (fill nil f-p))

46

"Shift a subset of array elements by a specified amount.

47

Optionally extend the array and fill empty space with a specified element.

48

49

N --- The amount to be moved. Positive for right-shift, negative for left-shift.

50

FROM --- region start point.

51

TO --- region end point.

52

ADJUST --- Whether to adjust the fill pointer and the array bounds.

53

FILL --- If provided, any empty space will be filled with this element."

54

(when (and adjust (array-has-fill-pointer-p array))

55

(unless (array-in-bounds-p array (+ (fill-pointer array) n))

56

(adjust-array array (+ (fill-pointer array) n)))

57

(incf (fill-pointer array) n))

58

(if (< 0 n)

59

(progn

60

(loop repeat (- to from)

61

for cursor downfrom (1- to)

62

do (setf (aref array (+ cursor n))

63

(aref array cursor)))

64

(when f-p

65

(loop repeat n

66

for cursor from from below to

67

do (setf (aref array cursor) fill))))

68

(progn

69

(loop repeat (- to from)

70

for cursor from (+ from n)

71

do (setf (aref array cursor)

72

(aref array (- cursor n))))

73

(when f-p

74

(loop repeat (- n)

75

for cursor downfrom (1- to) to from

76

do (setf (aref array cursor) fill)))))

77

array)

78

79

(declaim (inline vector-push-extend-position vector-pop-position))

80

(defun vector-push-extend-position (element vector position)

81

"Push the element into the specified position and shift-right to make

82

space. This is potentially very costly as all elements after the given

83

position need to be shifted as per ARRAY-SHIFT."

84

(array-shift vector :from position)

85

(setf (aref vector position) element)

86

(fill-pointer vector))

87

88

(defun vector-pop-position (vector position)

89

"Pop the element at the given position off the vector and return it.

90

This is potentially very costly as all elements after the given position

91

need to be shifted back as per ARRAY-SHIFT."

92

(let ((el (aref vector position)))

93

(array-shift vector :n -1 :from (1+ position))

94

el))

95

96

;; Matlisp

97

(declaim (inline vectorify))

98

(defun vectorify (seq n &optional (element-type t))

99

(declare (type (or vector list) seq))

100

(etypecase seq

101

(cons

102

(let ((ret (make-array n element-type element-type)))

103

(loop for i of-type fixnum from 0 below n

104

for lst = seq then (cdr lst)

105

do (setf (aref ret i) (car lst))

106

finally (return ret))))

107

(vector

108

(let ((ret (make-array n element-type element-type)))

109

(loop for i of-type fixnum from 0 below n

110

for ele across seq

111

do (setf (aref ret i) ele)

112

finally (return ret))))))

113

114

(defmacro make-array-allocator (allocator-name type init &optional doc)

115

`(eval-when (:compile-toplevel :load-toplevel :execute)

116

(definline ,allocator-name (size &optional (initial-element ,init))

117

,@(unless (null doc)

118

`(,doc))

119

(make-array size

120

:element-type ,type :initial-element initial-element))))

121

122

(definline vector-foldl (func vec)

123

(declare (type vector))

124

(loop

125

for i of-type fixnum from 0 below (length vec)

126

for ret = (aref vec 0) then (funcall func ret (aref vec i))

127

finally (return ret)))

128

129

(definline vector-foldr (func vec)

130

(declare (type vector))

131

(loop

132

for i of-type fixnum downfrom (1- (length vec)) to 0

133

for ret = (aref vec (1- (length vec))) then (funcall func (aref vec i) ret)

134

finally (return ret)))

135

136

(definline vector-map-foldl (func vec)

137

(declare (type vector))

138

(loop

139

for i of-type fixnum from 0 below (length vec)

140

for ret = (aref vec 0) then (funcall func (aref vec i) ret)

141

do (setf (aref vec i) ret)

142

finally (return (values ret vec))))

143

144

(definline vector-map-foldr (func vec)

145

(declare (type vector))

146

(loop

147

for i of-type fixnum downfrom (1- (length vec)) to 0

148

for ret = (aref vec (1- (length vec))) then (funcall func (aref vec i) ret)

149

do (setf (aref vec i) ret)

150

finally (return (values ret vec))))

151

152

(definline vector-max (vec)

153

(declare (type vector vec))

154

(loop for ele across vec

155

for idx of-type fixnum = 0 then (+ idx 1)

156

with max of-type fixnum = (aref vec 0)

157

with max-idx of-type fixnum = 0

158

do (when (> ele max)

159

(setf max ele

160

max-idx idx))

161

finally (return (values max max-idx))))

162

163

(definline vector-min (vec)

164

(declare (type vector vec))

165

(loop for ele across vec

166

for idx of-type fixnum = 0 then (+ idx 1)

167

with min of-type fixnum = (aref vec 0)

168

with min-idx of-type fixnum = 0

169

do (when (< ele min)

170

(setf min ele

171

min-idx idx))

172

finally (return (values min min-idx))))

173

174

(definline vector-eq (va vb &optional (test #'eq))

175

(declare (type vector va vb))

176

(let ((la (length va))

177

(lb (length vb)))

178

(if (/= la lb) nil

179

(loop

180

for ele-a across va

181

for ele-b across vb

182

unless (funcall test ele-a ele-b)

183

do (return nil)

184

finally (return t)))))

185

186

(definline vector-to-list (va)

187

(declare (type vector va))

188

(loop for ele across va

189

collect ele))

190

191

(definline copy-vector-to-list (va la)

192

(declare (type vector va)

193

(type list la))

194

(loop

195

for ele across va

196

for lst = la then (cdr lst)

197

do (setf (car lst) ele))

198

la)

199

200

;; array indexing utils

201

(definline modproj (i d &optional openp def)

202

(cond

203

((not i) def)

204

((not d) i)

205

     (t (assert (if openp (<= (- (1+ d)) i d) (< (- (1+ d)) i d)) nil 'std/condition:invalid-argument)

206

(if (< i 0) (if (and openp (= i (- (1+ d)))) -1 (mod i d)) i))))