Coverage report: /home/ellis/comp/core/std/num/parse.lisp

Kind	Covered	All	%
expression	247	583	42.4
branch	16	48	33.3

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; std/num/parse.lisp --- Number parsing functions

2

3

;;

4

5

;;; Code:

6

(in-package :std/num)

7

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

8

(define-condition invalid-number (parse-error)

9

((value :reader invalid-number-value

10

:initarg :value

11

:initform nil)

12

(reason :reader invalid-number-reason

13

:initarg :reason

14

:initform "Not specified"))

15

(:report (lambda (c s)

16

(format s "Invalid number: ~S [Reason: ~A]"

17

(invalid-number-value c)

18

(invalid-number-reason c))))

19

(:documentation "Error signaled when an invalid number is parsed."))

20

21

(declaim (inline white-space-p))

22

(defun white-space-p (x)

23

"Is the given character a whitespace character?"

24

(declare (optimize (speed 3) (safety 0))

25

(type character x))

26

(and (find x *whitespaces*) t))

27

28

(declaim (inline parse-integer-and-places))

29

(defun parse-integer-and-places (string start end &key (radix 10))

30

"Parse an integer and return a 'parsed-integer'. This is an object

31

whose numerical value can be accessed with the function

32

number-value and whose length can be accessed with the function

33

place."

34

(declare (optimize (speed 3) (safety 1))

35

(type simple-string string)

36

(fixnum start end radix))

37

(multiple-value-bind (integer end-pos)

38

(if (= start end)

39

(values 0 0)

40

(parse-integer string

41

:start start

42

:end end

43

:radix radix))

44

(declare (fixnum integer end-pos))

45

;; cl:parse-integer will consume trailing whitespace, thus end-pos may be

46

;; larger than the number of digits. Instead of trimming whitespace

47

;; beforehand we count it here

48

(let* ((count (loop for pos from (- end-pos 1) downto start

49

while (member (char string pos)

50

*whitespaces*

51

:test 'char=)

52

:count 1))

53

(relevant-digits (the fixnum (- end-pos start count))))

54

(cons integer relevant-digits))))

55

56

(defun parse-integers (string start end splitting-points &key (radix 10))

57

"Parse a string containing multiple integers where SPLITTING-POINTS

58

is a list of locations where each location is inbetween

59

consecutive integers. This will return a list of parsed-integers.

60

The last parsed-integer will have a negative value for its length."

61

(declare (optimize (speed 3) (safety 1))

62

(type simple-string string)

63

(fixnum start end radix)

64

(list splitting-points))

65

(values-list (loop for left = start then (1+ right)

66

for point in splitting-points

67

for right = point

68

collect (parse-integer-and-places string

69

left

70

right

71

                                                        :radix radix)

72

into integers

73

finally (return

74

(nconc integers

75

(list

76

(parse-integer-and-places string

77

                                                                  left

78

end

79

                                                                  :radix radix

80

                                                                  )))))))

81

82

(declaim (inline number-value places))

83

(defun number-value (x) "Get the value of a parsed-integer." (car x))

84

(defun places (x) "Get the length of a parsed-integer." (cdr x))

85

86

;; Numbers which could've been parsed, but intentionally crippled not to:

87

;; #xFF.AA

88

;; #o12e3

89

90

;; Numbers which CL doesn't parse, but this does:

91

;; #10r3.2

92

;; #2r 11

93

(defun parse-number (string &key (start 0) (end nil) (radix 10)

94

((:float-format *read-default-float-format*)

95

*read-default-float-format*))

96

"Given a string, and start, end, and radix parameters, produce a number

97

according to the syntax definitions in the Common Lisp Hyperspec."

98

(declare (type simple-string string))

99

(flet ((invalid-number (reason)

100

(error 'invalid-number

101

:value (subseq string start end)

102

:reason reason)))

103

(let ((end (or end (length string))))

104

(declare (fixnum start end radix))

105

(if (and (eql (char string start) #\#)

106

(member (char string (1+ start)) '(#\C #\c)))

107

(let ((\(-pos (position #\( string :start start :end end))

108

(\)-pos (position #\) string :start start :end end)))

109

(when (or (not \(-pos)

110

(not \)-pos)

111

(position #\( string :start (1+ \(-pos) :end end)

112

(position #\) string :start (1+ \)-pos) :end end))

113

(invalid-number "Mismatched/missing parenthesis"))

114

115

(let ((real-pos (position-if-not #'white-space-p string

116

                                              :start (1+ \(-pos) :end \)-pos)))

117

(unless real-pos

118

(invalid-number "Missing real part"))

119

(let ((delimiting-space (position-if #'white-space-p string

120

                                                    :start (1+ real-pos)

121

:end \)-pos)))

122

(unless delimiting-space

123

(invalid-number "Missing imaginary part"))

124

(let ((img-pos (position-if-not #'white-space-p string

125

                                                 :start (1+ delimiting-space)

126

:end \)-pos)))

127

(unless img-pos

128

(invalid-number "Missing imaginary part"))

129

(let ((img-end-pos (position-if #'white-space-p string

130

                                                   :start (1+ img-pos)

131

:end \)-pos)))

132

(complex (parse-real-number string

133

:start real-pos

134

:end delimiting-space

135

:radix radix)

136

(parse-real-number string

137

:start img-pos

138

:end (or img-end-pos

139

                                                          \)-pos)

140

:radix radix)))))))

141

(parse-real-number string :start start :end end :radix radix)))))

142

143

(defun parse-real-number (string &key (start 0) (end nil) (radix 10)

144

                                       ((:float-format *read-default-float-format*)

145

*read-default-float-format*))

146

"Given a string, and start, end, and radix parameters, produce a number

147

according to the syntax definitions in the Common Lisp Hyperspec -- except for

148

complex numbers."

149

(declare (simple-string string))

150

(let ((end (or end (length string))))

151

(case (char string start)

152

((#\-)

153

(* -1 (the fixnum (parse-positive-real-number string

154

:start (1+ start)

155

:end end

156

:radix radix))))

157

((#\+)

158

(parse-positive-real-number string

159

:start (1+ start)

160

:end end

161

:radix radix))

162

((#\#)

163

(case (char string (1+ start))

164

((#\x #\X)

165

(parse-real-number string

166

:start (+ start 2)

167

:end end

168

:radix 16))

169

((#\b #\B)

170

(parse-real-number string

171

:start (+ start 2)

172

:end end

173

:radix 2))

174

((#\o #\O)

175

(parse-real-number string

176

:start (+ start 2)

177

:end end

178

:radix 8))

179

(t (if (digit-char-p (char string (1+ start)))

180

(let ((r-pos (position #\r string

181

:start (1+ start)

182

:end end

183

:key #'char-downcase)))

184

(unless r-pos

185

(error 'invalid-number

186

:value (subseq string start end)

187

:reason "Missing R in #radixR"))

188

(parse-real-number string

189

:start (1+ r-pos)

190

:end end

191

:radix (parse-integer string

192

                                                            :start (1+ start)

193

                                                            :end r-pos)))))))

194

(t (parse-positive-real-number string

195

:start start

196

:end end

197

:radix radix)))))

198

199

(defun base-for-exponent-marker (char)

200

"Return the base for an exponent-marker."

201

(case char

202

((#\d #\D)

203

10.0d0)

204

((#\e #\E)

205

(coerce 10 *read-default-float-format*))

206

((#\f #\F)

207

10.0f0)

208

((#\s #\S)

209

10.0s0)

210

((#\l #\L)

211

10.0l0)))

212

213

(defun make-float/frac (radix exp-marker whole-place frac-place exp-place)

214

"Create a float using EXP-MARKER as the exponent-marker and the

215

parsed-integers WHOLE-PLACE, FRAC-PLACE, and EXP-PLACE as the integer part,

216

fractional part, and exponent respectively."

217

(declare (fixnum radix))

218

(let* ((base (base-for-exponent-marker exp-marker))

219

(exp (expt base (number-value exp-place))))

220

(+ (* exp (number-value whole-place))

221

(/ (* exp (number-value frac-place))

222

(expt (float radix base)

223

(places frac-place))))))

224

225

(defun make-float/whole (exp-marker whole-place exp-place)

226

"Create a float where EXP-MARKER is the exponent-marker and the

227

parsed-integers WHOLE-PLACE and EXP-PLACE as the integer part and

228

the exponent respectively."

229

(* (number-value whole-place)

230

(expt (base-for-exponent-marker exp-marker)

231

(number-value exp-place))))

232

233

(defun parse-positive-real-number (string &key (start 0) (end nil) (radix 10)

234

                                                ((:float-format *read-default-float-format*)

235

                                                 *read-default-float-format*))

236

"Given a string, and start, end, and radix parameters, produce a number

237

according to the syntax definitions in the Common Lisp Hyperspec -- except for

238

complex numbers and negative numbers."

239

(declare (simple-string string)

240

(fixnum radix))

241

(let ((end (or end (length string)))

242

(first-char (char string start)))

243

(flet ((invalid-number (reason)

244

(error 'invalid-number

245

:value (subseq string start end)

246

:reason reason)))

247

(when (position-if #'white-space-p string

248

:start (or (position-if-not #'white-space-p string

249

                                                      :start start

250

:end end)

251

0)

252

:end (position-if-not #'white-space-p string

253

:start start

254

:end end

255

:from-end t))

256

(invalid-number "Whitespace inside the number"))

257

(case first-char

258

((#\-)

259

(invalid-number "Invalid usage of -"))

260

((#\/)

261

(invalid-number "/ at beginning of number"))

262

((#\d #\D #\e #\E #\l #\L #\f #\F #\s #\S)

263

(when (= radix 10)

264

(invalid-number "Exponent-marker at beginning of number"))))

265

(let (/-pos .-pos exp-pos exp-marker)

266

(loop for index from start below end

267

for char = (char string index)

268

do (case char

269

((#\/)

270

(if /-pos

271

(invalid-number "Multiple /'s in number")

272

(setf /-pos index)))

273

((#\.)

274

(if .-pos

275

(invalid-number "Multiple .'s in number")

276

(setf .-pos index)))

277

((#\e #\E #\f #\F #\s #\S #\l #\L #\d #\D)

278

;; We should only execute this if the base is

279

;; not used for the given radix (ie the digit

280

;; e is valid in base 15 and up).

281

(when (>= (+ 10

282

(- (char-code (char-upcase char))

283

(char-code #\A)))

284

radix)

285

(when exp-pos

286

(invalid-number

287

"Multiple exponent-markers in number"))

288

(setf exp-pos index)

289

(setf exp-marker (char-downcase char)))))

290

when (eql index (1- end))

291

do (case char

292

((#\/)

293

(invalid-number "/ at end of number"))

294

((#\d #\D #\e #\E #\s #\S #\l #\L #\f #\F)

295

(when (= radix 10)

296

(invalid-number "Exponent-marker at end of number")))))

297

(cond ((and /-pos .-pos)

298

(invalid-number "Both . and / cannot be present simultaneously"))

299

((and /-pos exp-pos)

300

                (invalid-number "Both an exponent-marker and / cannot be present simultaneously"))

301

((and .-pos exp-pos)

302

(if (< exp-pos .-pos)

303

(invalid-number "Exponent-markers must occur after . in number")

304

(if (/= radix 10)

305

                        (invalid-number "Only decimal numbers can contain exponent-markers or decimal points")

306

(multiple-value-bind (whole-place frac-place exp-place)

307

(parse-integers string start end

308

(list .-pos exp-pos)

309

:radix radix)

310

                          (make-float/frac radix exp-marker whole-place frac-place exp-place)))))

311

(exp-pos

312

(if (/= radix 10)

313

(invalid-number "Only decimals can contain exponent-markers")

314

(multiple-value-bind (whole-place exp-place)

315

(parse-integers string start end

316

(list exp-pos)

317

:radix radix)

318

(make-float/whole exp-marker whole-place exp-place))))

319

(/-pos

320

(multiple-value-bind (numerator denominator)

321

(parse-integers string start end

322

(list /-pos)

323

:radix radix)

324

(if (>= (number-value denominator) 0)

325

(/ (number-value numerator)

326

(number-value denominator))

327

(invalid-number "Misplaced - sign"))))

328

(.-pos

329

(if (/= radix 10)

330

(invalid-number "Only decimal numbers can contain decimal points")

331

(multiple-value-bind (whole-part frac-part)

332

(parse-integers string start end

333

(list .-pos)

334

:radix 10)

335

(cond

336

((minusp (places frac-part))

337

(if (and (zerop (number-value whole-part))

338

(zerop (places whole-part)))

339

(invalid-number "Only the . is present")

340

(number-value whole-part)))

341

((>= (number-value frac-part) 0)

342

(coerce (+ (number-value whole-part)

343

(/ (number-value frac-part)

344

(expt 10 (places frac-part))))

345

*read-default-float-format*))

346

(t

347

(invalid-number "Misplaced - sign"))))))

348

(t

349

(values (parse-integer string

350

:start start

351

:end end

352

:radix radix))))))))