Coverage report: /home/runner/work/geb/geb/src/vampir/vampir.lisp

Kind	Covered	All	%
expression	233	1537	15.2
branch	2	2	100.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

(in-package :geb.vampir)

2

3

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

4

;; Boolean

5

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

6

7

(defparameter *bool*

8

(let ((x-wire (make-wire :var :x))

9

(one (make-constant :const 1)))

10

(make-alias

11

:name :bool

12

:inputs (list :x)

13

:body (list (make-equality

14

:lhs (make-infix :op :*

15

:lhs x-wire

16

                                      :rhs (make-infix :lhs x-wire :rhs one :op :-))

17

:rhs (make-constant :const 0))

18

x-wire))))

19

20

(defun bool (x)

21

(make-application :func :bool :arguments (list x)))

22

23

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

24

;; Next-range definition for an inductive definition of range

25

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

26

27

28

(defun int-range31 (a)

29

(make-application :func :intrange31

30

:arguments (list a)))

31

32

(defun mod32 (a b)

33

(make-application :func :mod32

34

:arguments (list a b)))

35

36

(defun pwless32 (f g p q)

37

(make-application :func :pwless32

38

:arguments (list f g p q)))

39

40

(defun less32 (a b)

41

(make-application :func :less32

42

:arguments (list a b)))

43

44

(defun next-range (range x)

45

(make-application :func :next_range

46

:arguments (list range x)))

47

48

(defun int-range32 (a)

49

(make-application :func :intrange32

50

:arguments (list a)))

51

52

(defun negative32 (a)

53

(make-application

54

:func :negative32

55

:arguments (list a)))

56

57

(defun non-negative32 (a)

58

(make-application :func :nonnegative32

59

:arguments (list a)))

60

61

(defun vamp-range (of)

62

(labels ((in-plus (n)

63

(if (= n 0)

64

(make-wire :var :a0)

65

(make-infix :op :+

66

:lhs (in-plus (- n 1))

67

:rhs (make-infix

68

:op :*

69

:lhs (make-constant :const (expt 2 n))

70

:rhs (make-wire

71

:var (intern

72

                                                (format nil "A~a" n) :keyword))))))

73

(in-tuple (i)

74

(make-wire :var (intern (format nil "A~a" i) :keyword))))

75

(make-alias

76

:name (intern (format nil "range~A" of) :keyword)

77

:inputs (list :a)

78

:body

79

(append (mapcar

80

(lambda (i y)

81

(spc:make-bind

82

:names (list (make-wire :var y))

83

:value

84

(bool

85

(make-application

86

:func :fresh

87

:arguments

88

(list

89

(make-infix :op :%

90

:lhs

91

(make-infix :op :\\

92

                                             :rhs (make-constant :const i)

93

:lhs (make-wire :var :A))

94

:rhs (make-constant :const 2)))))))

95

(mapcar (lambda (x) (expt 2 x))

96

(alexandria:iota of))

97

(mapcar (lambda (x) (intern (format nil "A~a" x) :keyword))

98

(alexandria:iota of)))

99

(list

100

(make-equality :lhs (make-wire :var :a)

101

:rhs (in-plus (1- of )))

102

(make-tuples :wires

103

(append (mapcar #'in-tuple (alexandria:iota of))

104

(list (make-wire :var :|()|)))))))))

105

106

(defun range31 (a)

107

(make-application

108

:func :range31

109

:arguments (list a)))

110

111

(defun range32 (a)

112

(make-application

113

:func :range32

114

:arguments (list a)))

115

116

(defun pwmod32 (f g x)

117

(make-application :func :pwmod32

118

:arguments (list f g x)))

119

120

(defun negative31 (a)

121

(make-application

122

:func :negative31

123

:arguments (list a)))

124

125

(defparameter *base-range*

126

(make-alias

127

:name :base_range

128

:inputs (list (make-constant :const 0))

129

:body

130

(list (make-wire :var :[]))))

131

132

(defparameter *next-range*

133

(let ((a-wire (make-wire :var :a)))

134

(make-alias

135

:name :next_range

136

:inputs (list :range :a)

137

:body

138

(list

139

(make-bind

140

:names (list (make-wire :var :a0))

141

:value (make-application

142

:func :bool

143

:arguments (list

144

(make-application

145

:func :fresh

146

:arguments

147

(list

148

(make-infix :op :%

149

:lhs a-wire

150

                                          :rhs (make-constant :const 2)))))))

151

(make-bind :names (list (make-wire :var :a1))

152

:value

153

(make-application :func :fresh

154

:arguments

155

(list

156

(make-infix :op :\\

157

:lhs a-wire

158

                                                 :rhs (make-constant :const 2)))))

159

(make-infix :op :|:|

160

:lhs (make-wire :var :a0)

161

:rhs (make-application :func :range

162

:arguments

163

                                              (list (make-wire :var :a1))))))))

164

(defparameter *range-n*

165

(make-alias

166

:name :range_n

167

:inputs (list :n)

168

:body

169

(list (make-application :func :iter

170

:arguments (list (make-wire :var :n)

171

(make-wire :var :next_range)

172

                                             (make-wire :var :base_range))))))

173

174

(defun range-n (n a)

175

(make-application :func :range_n

176

:arguments (list n

177

a)))

178

179

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

180

;; List operations

181

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

182

183

(defparameter *hd*

184

(make-alias

185

:name :hd

186

:inputs (list :|(h:t)|)

187

:body

188

(list (make-wire :var :h))))

189

190

(defparameter *tl*

191

(make-alias

192

:name :tl

193

:inputs (list :|(h:t)|)

194

:body

195

(list (make-wire :var :t))))

196

197

(defun hd (a)

198

(make-application :func :hd

199

:arguments (list a)))

200

(defun tl (a)

201

(make-application :func :tl

202

:arguments (list a)))

203

204

(defparameter *n-th*

205

(make-alias

206

:name :n_th

207

:inputs (list :lst :n)

208

:body

209

(list

210

(make-application :func :hd

211

:arguments

212

(list (make-application

213

:func :iter

214

:arguments

215

(list (make-wire :var :n)

216

(make-wire :var :tl)

217

(make-wire :var :lst))))))))

218

219

(defun n-th (lst n)

220

(make-application :func :nth

221

:arguments (list lst n)))

222

223

(defparameter *negative*

224

(let ((num (make-wire :var :n)))

225

(make-alias

226

:name :negative

227

:inputs (list :n :a)

228

:body

229

(list (make-application

230

:func :nth

231

:arguments

232

(list (range-n

233

(make-infix :op :+

234

:lhs num

235

:rhs (make-constant :const 1))

236

(make-infix :op :+

237

:lhs (make-wire :var :a)

238

:rhs

239

(make-infix :op :^

240

:lhs (make-constant :const 2)

241

:rhs num)))

242

num))))))

243

244

(defun negative (n a)

245

(make-application :func :negative

246

:arguments (list n a)))

247

248

(defparameter *nonnegative*

249

(make-alias

250

:name :nonnegative

251

:inputs (list :n :a)

252

:body

253

(list (make-infix :op :-

254

:lhs (make-constant :const 1)

255

:rhs (make-application

256

:func :negative

257

:arguments (list (make-constant :const :n)

258

(make-wire :var :a)))))))

259

260

(defun nonnegative (n a)

261

(make-application :func :nonnegative

262

:arguments (list n a)))

263

264

(defparameter *mod-n*

265

(let ((numb (make-constant :const :n))

266

(a-wire (make-wire :var :a))

267

(b-wire (make-wire :var :b))

268

(q-wire (make-wire :var :q))

269

(r-wire (make-wire :var :r)))

270

(make-alias :name :mod32

271

:inputs (list :n :a :b)

272

:body (list

273

(make-equality

274

:lhs (make-application :func :nonnegative

275

                                                :arguments (list numb b-wire))

276

:rhs (make-constant :const 0))

277

(make-bind

278

:names (list q-wire)

279

:value (make-application

280

:func :fresh

281

:arguments (list (make-infix :op :/

282

                                                              :lhs a-wire

283

                                                              :rhs b-wire))))

284

(make-bind

285

:names (list r-wire)

286

:value (make-application

287

:func :fresh

288

:arguments (list (make-infix :op :%

289

                                                              :lhs a-wire

290

                                                              :rhs b-wire))))

291

(make-equality :lhs (make-application

292

:func :nonnegative

293

                                             :arguments (list numb r-wire))

294

:rhs (make-constant :const :0))

295

(make-equality :lhs a-wire

296

:rhs (make-infix

297

:op :+

298

:lhs (make-infix :op :*

299

                                                              :lhs b-wire

300

                                                              :rhs q-wire)

301

:rhs q-wire))

302

(make-equality :lhs (make-application

303

:func :negative

304

:arguments

305

(list numb

306

                                                   (make-infix :op :-

307

                                                               :lhs r-wire

308

                                                               :rhs b-wire)))

309

:rhs (make-constant :const 0))

310

r-wire))))

311

312

(defun mod-n (n a b)

313

(make-application :func :mod-n

314

:arguments (list n a b)))

315

316

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

317

;; Primitive operations with range checks

318

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

319

320

(defparameter *plus-range*

321

(let ((plus (make-infix :op :+

322

:lhs (make-wire :var :x1)

323

:rhs (make-wire :var :x2))))

324

(make-alias

325

:name :plus_range

326

:inputs (list :n :x1 :x2)

327

:body (list (make-application :func :range_n

328

:arguments (list (make-wire :var :n)

329

plus))

330

plus))))

331

332

(defun plus-range (n x1 x2)

333

(make-application :func :plus_range

334

:arguments (list n x1 x2)))

335

336

(defparameter *mult-range*

337

(let ((times (make-infix :op :*

338

:lhs (make-wire :var :x1)

339

:rhs (make-wire :var :x2))))

340

(make-alias

341

:name :mult_range

342

:inputs (list :n :x1 :x2)

343

:body (list (make-application :func :mult_range

344

:arguments (list (make-wire :var :n)

345

times))

346

times))))

347

348

(defun mult-range (n x1 x2)

349

(make-application :func :mult_range

350

:arguments (list n x1 x2)))

351

352

(defparameter *minus-range*

353

(let ((minus (make-infix :op :-

354

:lhs (make-wire :var :x1)

355

:rhs (make-wire :var :x2))))

356

(make-alias

357

:name :minus_range

358

:inputs (list :n :x1 :x2)

359

:body (list (make-equality :lhs (negative (make-wire :var :n)

360

minus)

361

:rhs (make-constant :const 1))

362

minus))))

363

364

(defun minus-range (n x1 x2)

365

(make-application :func :minus_range

366

:arguments (list n x1 x2)))

367

368

(defparameter *isZero*

369

(let ((one (make-constant :const 1))

370

(wire-a (make-wire :var :a))

371

(wire-ai (make-wire :var :ai))

372

(wire-b (make-wire :var :b)))

373

(make-alias

374

:name :isZero

375

:inputs (list :a)

376

:body (list (make-bind :names (list wire-ai)

377

:value (make-application

378

:func :fresh

379

:arguments (list (make-infix :op :\|

380

                                                                  :lhs one

381

                                                                  :rhs wire-a))))

382

(make-bind :names (list wire-b)

383

:value (make-infix :op :-

384

:lhs one

385

                                                :rhs (make-infix :op :*

386

                                                                 :lhs wire-ai

387

                                                                 :rhs wire-a)))

388

(make-equality :lhs (make-infix :op :*

389

:lhs wire-a

390

:rhs wire-b)

391

:rhs (make-constant :const 0))

392

(make-infix :op :-

393

:lhs one

394

:rhs wire-b)))))

395

396

(defun isZero (a)

397

(make-application :func :isZero

398

:arguments (list a)))

399

400

(-> cons-deconstruct (&rest keyword) list)

401

(defun cons-deconstruct (&rest symbols)

402

(list

403

(reduce (lambda (x pattern)

404

(make-infix :lhs (make-wire :var x)

405

:rhs pattern

406

:op :|:|))

407

(butlast symbols)

408

:from-end t

409

:initial-value (make-wire :var (car (last symbols))))))

410

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

411

;; Operations on Lists

412

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

413

414

(defparameter *combine-aux*

415

(make-alias

416

:name :combine-aux

417

:inputs (list :x :y)

418

:body (list (make-infix :op :+

419

:lhs (make-wire :var :x)

420

:rhs (make-infix :op :*

421

                                             :lhs (make-constant :const 2)

422

                                             :rhs (make-wire :var :y))))))

423

424

(defparameter *combine*

425

(make-alias

426

:name :combine

427

:inputs (list :xs)

428

:body (list (make-application :func :fold

429

:arguments (list (make-wire :var :xs)

430

                                                   (make-wire :var :combine_aux)

431

                                                   (make-constant :const 0))))))

432

433

(defun combine (xs)

434

(make-application :func :combine

435

:arguments (list xs)))

436

437

(defparameter *take-base*

438

(make-alias

439

:name :take_base

440

:inputs (list :lst)

441

:body (list (make-brackets))))

442

443

(defparameter *take-ind*

444

(make-alias

445

:name :take_ind

446

:inputs (list :take (cons-deconstruct :h :t))

447

:body (list (make-infix :lhs (make-wire :var :h)

448

:rhs (make-application

449

:func :take

450

:arguments (list (make-wire :var t)))

451

:op :|:|))))

452

453

(defparameter *take*

454

(make-alias

455

:name :take

456

:inputs (list :n)

457

:body (list (make-application :func :iter

458

:arguments (list (make-wire :var :n)

459

                                                   (make-wire :var :take_ind)

460

                                                   (make-wire :var :take_base))))))

461

462

(defparameter *drop-ith-rec*

463

(make-alias

464

:name :drop_ith_rec

465

:inputs (list (cons-deconstruct :h :t))

466

:body (list (make-infix :lhs (make-wire :var :h)

467

:rhs (make-application

468

:func :take

469

:arguments (list (make-wire :var :t)))

470

:op :|:|))))

471

472

(defparameter *drop-ith*

473

(let ((one (make-constant :const 1)))

474

(make-alias

475

:name :drop_ith

476

:inputs (list :n)

477

:body (list (make-application

478

:func :iter

479

:arguments (list (make-wire :var :n)

480

(make-wire :var :drop_ith_rec)

481

(make-application

482

:func :fun

483

:arguments

484

                                     (list (make-infix :lhs (make-wire :var :h)

485

:rhs one

486

:op :|:|)

487

(make-curly :value one)))))))))

488

489

(defun drop-ith (n)

490

(make-application :func :drop_ith

491

:arguments (list n)))

492

493

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

494

;; Range

495

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

496

497

(defparameter *int-range32*

498

(make-alias :name :intrange32

499

:inputs (list :a)

500

:body

501

(list

502

(range32

503

(make-infix

504

:op :+

505

:lhs (make-wire :var :a)

506

:rhs (make-constant :const 2147483648))))))

507

508

509

510

511

(defparameter *negative32*

512

(flet ((wires (num)

513

(make-wire :var (intern (format nil "A~a" num) :keyword))))

514

(make-alias

515

:name :negative32

516

:inputs (list :a)

517

:body

518

(list (make-bind

519

:names (append (mapcar #'wires (alexandria:iota 32))

520

(list (make-wire :var :|()|)))

521

:value (int-range32 (make-wire :var :a)))

522

(make-wire :var :a31)))))

523

524

(defparameter *non-negative32*

525

(make-alias :name :nonnegative32

526

:inputs (list :a)

527

:body (list

528

(make-infix :op :-

529

:lhs (make-constant :const 1)

530

:rhs (negative32 (make-wire :var :a))))))

531

(defparameter *range31*

532

(vamp-range 31))

533

534

(defparameter *range32*

535

(vamp-range 32))

536

537

(defparameter *int-range31*

538

(make-alias :name :intrange31

539

:inputs (list :a)

540

:body (list (range31

541

(make-infix :op :+

542

:lhs (make-wire :var :a)

543

                                        :rhs (make-constant :const (expt 2 30)))))))

544

545

546

(defparameter *negative31*

547

(flet ((wires (num)

548

(make-wire :var (intern (format nil "A~a" num) :keyword))))

549

(make-alias

550

:name :negative31

551

:inputs (list :a)

552

:body

553

(list (make-bind

554

:names (append (mapcar #'wires (alexandria:iota 31))

555

(list (make-wire :var :|()|)))

556

:value (int-range31 (make-wire :var :a)))

557

(make-wire :var :a30)))))

558

559

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

560

;; "Less than"

561

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

562

563

(defparameter *less32*

564

(let ((a-wire (make-wire :var :a))

565

(b-wire (make-wire :var :b)))

566

(make-alias :name :less32

567

:inputs (list :a :b)

568

:body (list

569

(make-application :func :intrange31

570

:arguments (list a-wire))

571

(make-application :func :intrange31

572

:arguments (list b-wire))

573

(make-application :func :negative32

574

:arguments (list

575

                                                      (make-infix :op :-

576

                                                                  :lhs a-wire

577

                                                                  :rhs b-wire)))))))

578

579

(defparameter *pwless32*

580

(let ((t-wire (make-wire :var :t))

581

(p-wire (make-wire :var :p))

582

(q-wire (make-wire :var :q))

583

(f-wire (make-wire :var :f))

584

(g-wire (make-wire :var :g)))

585

(make-alias :name :pwless32

586

:inputs (list :f :g :p :q)

587

:body

588

(list

589

(make-bind :names (list t-wire)

590

:value (less32 f-wire g-wire))

591

(make-infix :op :+

592

:lhs (make-infix :op :*

593

:lhs (make-infix :op :-

594

                                                                :lhs (make-constant :const 1)

595

                                                                :rhs t-wire)

596

:rhs p-wire)

597

:rhs (make-infix :op :*

598

:lhs t-wire

599

:rhs q-wire))))))

600

601

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

602

;; Pointwise modulus

603

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

604

605

(defparameter *mod32*

606

(let ((a-wire (make-wire :var :a))

607

(b-wire (make-wire :var :b))

608

(q-wire (make-wire :var :q))

609

(r-wire (make-wire :var :r)))

610

(make-alias :name :mod32

611

:inputs (list :a :b)

612

:body (list

613

(make-equality :lhs (make-application :func :nonnegative32

614

                                                              :arguments (list b-wire))

615

:rhs (make-constant :const 0))

616

(make-bind :names (list q-wire)

617

:value (make-application

618

:func :fresh

619

                                           :arguments (list (make-infix :op :\\

620

                                                                        :lhs a-wire

621

                                                                        :rhs b-wire))))

622

(make-bind :names (list r-wire)

623

:value (make-application

624

:func :fresh

625

                                           :arguments (list (make-infix :op :%

626

                                                                        :lhs a-wire

627

                                                                        :rhs b-wire))))

628

(make-equality :lhs (make-application

629

:func :nonnegative32

630

:arguments (list r-wire))

631

:rhs (make-constant :const :0))

632

(make-equality :lhs a-wire

633

:rhs (make-infix

634

:op :+

635

:lhs (make-infix :op :*

636

                                                              :lhs b-wire

637

                                                              :rhs q-wire)

638

:rhs q-wire))

639

(make-equality :lhs (make-application :func :less32

640

                                                              :arguments (list r-wire b-wire))

641

:rhs (make-constant :const 0))

642

r-wire))))

643

644

(defparameter *pwmod32*

645

(let ((x-wire (make-wire :var :x)))

646

(make-alias :name :pwmod32

647

:inputs (list :f :g :x)

648

:body

649

(list

650

(make-application

651

:func :mod32

652

:arguments (list (make-application :func :f

653

                                                      :arguments (list x-wire))

654

(make-application :func :g

655

                                                      :arguments (list x-wire))))))))

656

657

658

(defparameter *standard-library*

659

(list

660

*bool*

661

*base-range*

662

*next-range*

663

*range-n*

664

*hd*

665

*tl*

666

*n-th*

667

*negative*

668

*isZero*

669

*combine-aux*

670

*combine*

671

*take-base*

672

*take-ind*

673

*take*

674

*drop-ith-rec*

675

*drop-ith*

676

*nonnegative*

677

*mod-n*))

678

679

(-> extract (list &optional (or null stream)) (or null stream))

680

(defun extract (stmts &optional (stream *standard-output*))

681

(let ((*print-pretty* t)

682

(*print-miser-width* 40))

683

;; don't use the standard library for now

684

(format stream "~{~A~^~%~}" stmts))

685

stream)