Coverage report: /home/ellis/.stash/quicklisp/dists/quicklisp/software/alexandria-20241012-git/alexandria-1/lists.lisp

Kind	Covered	All	%
expression	4	342	1.2
branch	1	58	1.7

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

(in-package :alexandria)

2

3

(declaim (inline safe-endp))

4

(defun safe-endp (x)

5

(declare (optimize safety))

6

(endp x))

7

8

(defun alist-plist (alist)

9

"Returns a property list containing the same keys and values as the

10

association list ALIST in the same order."

11

(let (plist)

12

(dolist (pair alist)

13

(push (car pair) plist)

14

(push (cdr pair) plist))

15

(nreverse plist)))

16

17

(defun plist-alist (plist)

18

"Returns an association list containing the same keys and values as the

19

property list PLIST in the same order."

20

(let (alist)

21

(do ((tail plist (cddr tail)))

22

((safe-endp tail) (nreverse alist))

23

(push (cons (car tail) (cadr tail)) alist))))

24

25

(declaim (inline racons))

26

(defun racons (key value ralist)

27

(acons value key ralist))

28

29

(macrolet

30

((define-alist-get (name get-entry get-value-from-entry add doc)

31

`(progn

32

(declaim (inline ,name))

33

(defun ,name (alist key &key (test 'eql))

34

,doc

35

(let ((entry (,get-entry key alist :test test)))

36

(values (,get-value-from-entry entry) entry)))

37

(define-setf-expander ,name (place key &key (test ''eql)

38

&environment env)

39

(multiple-value-bind

40

(temporary-variables initforms newvals setter getter)

41

(get-setf-expansion place env)

42

(when (cdr newvals)

43

(error "~A cannot store multiple values in one place" ',name))

44

(with-unique-names (new-value key-val test-val alist entry)

45

(values

46

(append temporary-variables

47

(list alist

48

key-val

49

test-val

50

entry))

51

(append initforms

52

(list getter

53

key

54

test

55

`(,',get-entry ,key-val ,alist :test ,test-val)))

56

`(,new-value)

57

`(cond

58

(,entry

59

(setf (,',get-value-from-entry ,entry) ,new-value))

60

(t

61

(let ,newvals

62

(setf ,(first newvals) (,',add ,key ,new-value ,alist))

63

,setter

64

,new-value)))

65

`(,',get-value-from-entry ,entry))))))))

66

(define-alist-get assoc-value assoc cdr acons

67

"ASSOC-VALUE is an alist accessor very much like ASSOC, but it can

68

be used with SETF.")

69

(define-alist-get rassoc-value rassoc car racons

70

"RASSOC-VALUE is an alist accessor very much like RASSOC, but it can

71

be used with SETF."))

72

73

(defun malformed-plist (plist)

74

(error "Malformed plist: ~S" plist))

75

76

(defmacro doplist ((key val plist &optional values) &body body)

77

"Iterates over elements of PLIST. BODY can be preceded by

78

declarations, and is like a TAGBODY. RETURN may be used to terminate

79

the iteration early. If RETURN is not used, returns VALUES."

80

(multiple-value-bind (forms declarations) (parse-body body)

81

(with-gensyms (tail loop results)

82

`(block nil

83

(flet ((,results ()

84

(let (,key ,val)

85

(declare (ignorable ,key ,val))

86

(return ,values))))

87

(let* ((,tail ,plist)

88

(,key (if ,tail

89

(pop ,tail)

90

(,results)))

91

(,val (if ,tail

92

(pop ,tail)

93

(malformed-plist ',plist))))

94

(declare (ignorable ,key ,val))

95

,@declarations

96

(tagbody

97

,loop

98

,@forms

99

(setf ,key (if ,tail

100

(pop ,tail)

101

(,results))

102

,val (if ,tail

103

(pop ,tail)

104

(malformed-plist ',plist)))

105

(go ,loop))))))))

106

107

(define-modify-macro appendf (&rest lists) append

108

"Modify-macro for APPEND. Appends LISTS to the place designated by the first

109

argument.")

110

111

(define-modify-macro nconcf (&rest lists) nconc

112

"Modify-macro for NCONC. Concatenates LISTS to place designated by the first

113

argument.")

114

115

(define-modify-macro unionf (list &rest args) union

116

"Modify-macro for UNION. Saves the union of LIST and the contents of the

117

place designated by the first argument to the designated place.")

118

119

(define-modify-macro nunionf (list &rest args) nunion

120

"Modify-macro for NUNION. Saves the union of LIST and the contents of the

121

place designated by the first argument to the designated place. May modify

122

either argument.")

123

124

(define-modify-macro reversef () reverse

125

"Modify-macro for REVERSE. Copies and reverses the list stored in the given

126

place and saves back the result into the place.")

127

128

(define-modify-macro nreversef () nreverse

129

"Modify-macro for NREVERSE. Reverses the list stored in the given place by

130

destructively modifying it and saves back the result into the place.")

131

132

(defun circular-list (&rest elements)

133

"Creates a circular list of ELEMENTS."

134

(let ((cycle (copy-list elements)))

135

(nconc cycle cycle)))

136

137

(defun circular-list-p (object)

138

"Returns true if OBJECT is a circular list, NIL otherwise."

139

(and (listp object)

140

(do ((fast object (cddr fast))

141

(slow (cons (car object) (cdr object)) (cdr slow)))

142

(nil)

143

(unless (and (consp fast) (listp (cdr fast)))

144

(return nil))

145

(when (eq fast slow)

146

(return t)))))

147

148

(defun circular-tree-p (object)

149

"Returns true if OBJECT is a circular tree, NIL otherwise."

150

(labels ((circularp (object seen)

151

(and (consp object)

152

(do ((fast (cons (car object) (cdr object)) (cddr fast))

153

(slow object (cdr slow)))

154

(nil)

155

(when (or (eq fast slow) (member slow seen))

156

(return-from circular-tree-p t))

157

(when (or (not (consp fast)) (not (consp (cdr slow))))

158

(return

159

(do ((tail object (cdr tail)))

160

((not (consp tail))

161

nil)

162

(let ((elt (car tail)))

163

(circularp elt (cons object seen))))))))))

164

(circularp object nil)))

165

166

(defun proper-list-p (object)

167

"Returns true if OBJECT is a proper list."

168

(cond ((not object)

169

t)

170

((consp object)

171

(do ((fast object (cddr fast))

172

(slow (cons (car object) (cdr object)) (cdr slow)))

173

(nil)

174

(unless (and (listp fast) (consp (cdr fast)))

175

(return (and (listp fast) (not (cdr fast)))))

176

(when (eq fast slow)

177

(return nil))))

178

(t

179

nil)))

180

181

(deftype proper-list ()

182

"Type designator for proper lists. Implemented as a SATISFIES type, hence

183

not recommended for performance intensive use. Main usefullness as a type

184

designator of the expected type in a TYPE-ERROR."

185

`(and list (satisfies proper-list-p)))

186

187

(defun circular-list-error (list)

188

(error 'type-error

189

:datum list

190

:expected-type '(and list (not circular-list))))

191

192

(macrolet ((def (name lambda-list doc step declare ret1 ret2)

193

(assert (member 'list lambda-list))

194

`(defun ,name ,lambda-list

195

,doc

196

(unless (listp list)

197

(error 'type-error :datum list :expected-type 'list))

198

(do ((last list fast)

199

(fast list (cddr fast))

200

(slow (cons (car list) (cdr list)) (cdr slow))

201

,@(when step (list step)))

202

(nil)

203

(declare (dynamic-extent slow) ,@(when declare (list declare))

204

(ignorable last))

205

(when (safe-endp fast)

206

(return ,ret1))

207

(when (safe-endp (cdr fast))

208

(return ,ret2))

209

(when (eq fast slow)

210

(circular-list-error list))))))

211

(def proper-list-length (list)

212

"Returns length of LIST, signalling an error if it is not a proper list."

213

(n 1 (+ n 2))

214

;; KLUDGE: Most implementations don't actually support lists with bignum

215

;; elements -- and this is WAY faster on most implementations then declaring

216

;; N to be an UNSIGNED-BYTE.

217

(fixnum n)

218

(1- n)

219

n)

220

221

(def lastcar (list)

222

"Returns the last element of LIST. Signals a type-error if LIST is not a

223

proper list."

224

nil

225

nil

226

(cadr last)

227

(car fast))

228

229

(def (setf lastcar) (object list)

230

"Sets the last element of LIST. Signals a type-error if LIST is not a proper

231

list."

232

nil

233

nil

234

(setf (cadr last) object)

235

(setf (car fast) object)))

236

237

(defun make-circular-list (length &key initial-element)

238

"Creates a circular list of LENGTH with the given INITIAL-ELEMENT."

239

(let ((cycle (make-list length :initial-element initial-element)))

240

(nconc cycle cycle)))

241

242

(deftype circular-list ()

243

"Type designator for circular lists. Implemented as a SATISFIES type, so not

244

recommended for performance intensive use. Main usefullness as the

245

expected-type designator of a TYPE-ERROR."

246

`(satisfies circular-list-p))

247

248

(defun ensure-car (thing)

249

"If THING is a CONS, its CAR is returned. Otherwise THING is returned."

250

(if (consp thing)

251

(car thing)

252

thing))

253

254

(defun ensure-cons (cons)

255

"If CONS is a cons, it is returned. Otherwise returns a fresh cons with CONS

256

in the car, and NIL in the cdr."

257

(if (consp cons)

258

cons

259

(cons cons nil)))

260

261

(defun ensure-list (list)

262

"If LIST is a list, it is returned. Otherwise returns the list designated by LIST."

263

(if (listp list)

264

list

265

(list list)))

266

267

(defun remove-from-plist (plist &rest keys)

268

"Returns a property-list with same keys and values as PLIST, except that keys

269

in the list designated by KEYS and values corresponding to them are removed.

270

The returned property-list may share structure with the PLIST, but PLIST is

271

not destructively modified. Keys are compared using EQ."

272

(declare (optimize (speed 3)))

273

;; FIXME: possible optimization: (remove-from-plist '(:x 0 :a 1 :b 2) :a)

274

;; could return the tail without consing up a new list.

275

(loop for (key . rest) on plist by #'cddr

276

do (assert rest () "Expected a proper plist, got ~S" plist)

277

unless (member key keys :test #'eq)

278

collect key and collect (first rest)))

279

280

(defun delete-from-plist (plist &rest keys)

281

"Just like REMOVE-FROM-PLIST, but this version may destructively modify the

282

provided PLIST."

283

(declare (optimize speed))

284

(loop with head = plist

285

with tail = nil ; a nil tail means an empty result so far

286

for (key . rest) on plist by #'cddr

287

do (assert rest () "Expected a proper plist, got ~S" plist)

288

(if (member key keys :test #'eq)

289

;; skip over this pair

290

(let ((next (cdr rest)))

291

(if tail

292

(setf (cdr tail) next)

293

(setf head next)))

294

;; keep this pair

295

(setf tail rest))

296

finally (return head)))

297

298

(define-modify-macro remove-from-plistf (&rest keys) remove-from-plist

299

"Modify macro for REMOVE-FROM-PLIST.")

300

(define-modify-macro delete-from-plistf (&rest keys) delete-from-plist

301

"Modify macro for DELETE-FROM-PLIST.")

302

303

(declaim (inline sans))

304

(defun sans (plist &rest keys)

305

"Alias of REMOVE-FROM-PLIST for backward compatibility."

306

(apply #'remove-from-plist plist keys))

307

308

(defun mappend (function &rest lists)

309

"Applies FUNCTION to respective element(s) of each LIST, appending all the

310

all the result list to a single list. FUNCTION must return a list."

311

(loop for results in (apply #'mapcar function lists)

312

append results))

313

314

(defun setp (object &key (test #'eql) (key #'identity))

315

"Returns true if OBJECT is a list that denotes a set, NIL otherwise. A list

316

denotes a set if each element of the list is unique under KEY and TEST."

317

(and (listp object)

318

(let (seen)

319

(dolist (elt object t)

320

(let ((key (funcall key elt)))

321

(if (member key seen :test test)

322

(return nil)

323

(push key seen)))))))

324

325

(defun set-equal (list1 list2 &key (test #'eql) (key nil keyp))

326

"Returns true if every element of LIST1 matches some element of LIST2 and

327

every element of LIST2 matches some element of LIST1. Otherwise returns false."

328

(let ((keylist1 (if keyp (mapcar key list1) list1))

329

(keylist2 (if keyp (mapcar key list2) list2)))

330

(and (dolist (elt keylist1 t)

331

(or (member elt keylist2 :test test)

332

(return nil)))

333

(dolist (elt keylist2 t)

334

(or (member elt keylist1 :test test)

335

(return nil))))))

336

337

(defun map-product (function list &rest more-lists)

338

"Returns a list containing the results of calling FUNCTION with one argument

339

from LIST, and one from each of MORE-LISTS for each combination of arguments.

340

In other words, returns the product of LIST and MORE-LISTS using FUNCTION.

341

342

Example:

343

344

(map-product 'list '(1 2) '(3 4) '(5 6))

345

=> ((1 3 5) (1 3 6) (1 4 5) (1 4 6)

346

(2 3 5) (2 3 6) (2 4 5) (2 4 6))

347

"

348

(labels ((%map-product (f lists)

349

(let ((more (cdr lists))

350

(one (car lists)))

351

(if (not more)

352

(mapcar f one)

353

(mappend (lambda (x)

354

(%map-product (curry f x) more))

355

one)))))

356

(%map-product (ensure-function function) (cons list more-lists))))

357

358

(defun flatten (tree)

359

"Traverses the tree in order, collecting non-null leaves into a list."

360

(let (list)

361

(labels ((traverse (subtree)

362

(when subtree

363

(if (consp subtree)

364

(progn

365

(traverse (car subtree))

366

(traverse (cdr subtree)))

367

(push subtree list)))))

368

(traverse tree))

369

(nreverse list)))