Coverage report: /home/ellis/comp/core/lib/syn/gen/c/ast.lisp

Kind	Covered	All	%
expression	47	712	6.6
branch	3	104	2.9

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; ast.lisp --- SYN/GEN/C AST Nodes

2

3

;;

4

5

;;; Code:

6

(in-package :syn/gen/c)

7

8

(defnode function-definition () (item parameter body))

9

(defmethod ast ((self function-definition))

10

(list

11

;; params are before the result type (item) in the AST

12

(slot-value self 'item)

13

(slot-value self 'parameter)

14

(slot-value self 'body)))

15

(defnode parameter-list () (parameters))

16

(defmethod ast ((self parameter-list))

17

(ast (slot-value self 'parameters)))

18

;; struct

19

(defnode struct-definition (id) (members))

20

;; union

21

(defnode union-definition (id) (members))

22

;; enum

23

(defnode enum-definition (id) (members))

24

(defmethod ast ((self enum-definition)) (list (id self) (slot-value self 'members)))

25

;; variable declaration

26

(defnode declaration-list () (braces bindings body))

27

(defmethod ast ((self declaration-list))

28

(list (slot-value self 'bindings)

29

(slot-value self 'body)))

30

(defnode declaration-item () (specifier type identifier value))

31

(defmethod ast ((self declaration-item))

32

(list (slot-value self 'type)

33

(slot-value self 'specifier)

34

(slot-value self 'identifier)

35

(slot-value self 'value)))

36

(defnode declaration-value () (value))

37

(defmethod ast ((self declaration-value))

38

(list (slot-value self 'value)))

39

(defmethod val ((self declaration-value))

40

(slot-value self 'value))

41

;; essential bulding blocks

42

(defnode clist () (items))

43

(defnode array-reference () (array indizes))

44

(defnode object-reference () (object component))

45

(defnode pointer-reference () (pointer component))

46

(defnode c-type () (type))

47

(defmethod ast ((self c-type)) (list (slot-value self 'type)))

48

(defnode float-type () (number))

49

(defnode specifier () (specifier))

50

(defmethod ast ((self specifier)) (list (slot-value self 'specifier)))

51

(defnode function-pointer () (identifier parameters))

52

53

;;; Expressions

54

;; = *= /= %= += -= <<= >>= &= ^= \|=

55

(defexpr assignment-expression () (op variable value))

56

(defmethod ast ((self assignment-expression))

57

(list (slot-value self 'variable) (slot-value self 'value)))

58

;; + - / * > < == != += -= >= <= \| \|\| & &= && % << >> or and

59

(defexpr infix-expression () (op members))

60

(defmethod ast ((self infix-expression))

61

(slot-value self 'members))

62

;; - + -- ++ ! * &

63

(defexpr prefix-expression () (op object))

64

;; - + -- ++ *

65

(defexpr postfix-expression () (op object))

66

;; not ('!' defined as prefix)

67

(defexpr not-expression () (value))

68

;; ? :

69

(defexpr conditional-expression () (test then else))

70

;; cast

71

(defexpr cast-expression () (type object))

72

73

;;; Statements

74

;; goto, continue, break return

75

(defstmt jump-statement () (kind members))

76

(defmethod ast ((self jump-statement))

77

(ast (slot-value self 'members)))

78

(defstmt label-statement () (name))

79

(defstmt expression-statement () (force-semicolon expression))

80

(defstmt compound-statement () (braces statements))

81

(defstmt if-statement () (test if-body else-body))

82

83

;;; Loops

84

(defstmt for-statement () (init test step body))

85

(defstmt while-statement () (test body))

86

(defstmt do-statement () (body test))

87

88

;;; comment

89

(defstmt comment () (chars comment linebreak))

90

91

;;; switch

92

(defstmt switch-case-statement () (switch cases))

93

(defnode switch-case-item () (constant body))

94

95

;;; gcc ext

96

(defexpr attribute-expression () (arguments))

97

98

;;; typedef

99

(defstmt typedef () (declaration))

100

;;; special nodes

101

(defnode include () (file))

102

(defmethod ast ((self include)) (list (slot-value self 'file)))

103

;; TODO 2024-12-13:

104

(defnode preprocessor-macro () (name function body))

105

106

;;; Syntax

107

(defmacro c-syntax (tags lambda-list &body body)

108

`(defsyntax ,tags (:c) ,lambda-list ,@body))

109

110

(defmacro make-exprs (list)

111

`(make-nodes ,list

112

;; :prepend (make-instance 'expression-statement)

113

:quoty t))

114

115

(defmacro make-block (list)

116

"Code block with curly braces and indentation."

117

`(make-instance 'compound-statement

118

:braces t

119

:statements (make-exprs ,list)))

120

121

(defmacro make-simple-block (list)

122

"Code block without underlying AST.

123

Used for 'bodys' where implicit progn is required"

124

`(make-instance 'compound-statement

125

:braces t

126

:statements (make-instance 'expression-statement

127

:force-semicolon nil

128

:expression (quoty ,list))))

129

130

(c-syntax block (&body body)

131

"Code block with curly braces and indentation."

132

`(make-block ,body))

133

134

(c-syntax progn (&body body)

135

"Code block without curly braces nor intendation"

136

;; make expressions with ';' delimiter

137

`(make-exprs ,body))

138

139

(c-syntax set (&rest rest)

140

"Assigment operator for multiple inputs"

141

(when (oddp (length rest))

142

(error "Set operator with odd number of elements: ~a" rest))

143

(if (eql (length rest) 2)

144

;; signel assignment

145

`(make-instance 'assignment-expression

146

:op '=

147

:variable (make-node ,(pop rest))

148

:value (make-node ,(pop rest)))

149

;; muliple assignments

150

`(make-exprs

151

;; collect item pairwise and emmit sigle assignments

152

,(loop while rest collect

153

`(make-instance 'assignment-expression

154

:op '=

155

:variable (make-node ,(pop rest))

156

:value (make-node ,(pop rest)))))))

157

158

(c-syntax (= *= /= %= += -= <<= >>= &= ^= \|=) (variable value)

159

"Assignment operators for single inputs"

160

   `(make-instance 'assignment-expression :op ',syn/gen::tag :var (make-node ,variable) :val (make-node ,value)))

161

162

(c-syntax (/ > < == != >= <= \| \|\| % << >> or and ^ &&) (&rest rest)

163

"Infix expressions for multiple inputs"

164

`(make-instance 'infix-expression :op ',syn/gen::tag :members (make-nodes ,rest)))

165

166

(c-syntax (- + * &) (&rest rest)

167

"Infix or prefix version"

168

(if (eql (length rest) 1)

169

`(make-instance 'prefix-expression :op ',syn/gen::tag :object (make-node ,@rest))

170

`(make-instance 'infix-expression :op ',syn/gen::tag :members (make-nodes ,rest))))

171

172

(c-syntax (~ !) (item)

173

"Prefix operators"

174

`(make-instance 'prefix-expression :op ',syn/gen::tag :object (make-node ,item)))

175

176

(c-syntax (addr) (item)

177

"Address-of function (&)"

178

`(make-instance 'prefix-expression :op '& :object (make-node ,item)))

179

180

(c-syntax (deref) (item)

181

"Taget-of or dereferencing pointer"

182

`(make-instance 'prefix-expression :op '* :object (make-node ,item)))

183

184

(c-syntax prefix++ (item)

185

"Prefix operator ++"

186

`(make-instance 'prefix-expression :op '++ :object (make-node ,item)))

187

188

(c-syntax prefix-- (item)

189

"Prefix operator --"

190

`(make-instance 'prefix-expression :op '-- :object (make-node ,item)))

191

192

(c-syntax postfix-- (item)

193

"Postfix operator --"

194

`(make-instance 'postfix-expression :op '-- :object (make-node ,item)))

195

196

(c-syntax postfix++ (item)

197

"Postfix operator ++"

198

`(make-instance 'postfix-expression :op '++ :object (make-node ,item)))

199

200

(c-syntax postfix* (item)

201

"Postfix operator *"

202

`(make-instance 'postfix-expression :op '* :object (make-node ,item)))

203

204

(c-syntax struct (name &body body)

205

"Struct definition"

206

`(make-instance 'struct-definition

207

;; struct name

208

:id (make-node ,name)

209

;; struct body

210

:members

211

,(when body

212

`(make-instance 'compound-statement

213

:braces t

214

;; build subnodes

215

:statements (make-nodes ,body)))))

216

217

(c-syntax union (name &body body)

218

"Syntax for union"

219

`(make-instance 'union-definition

220

;; union name

221

:id (make-node ,name)

222

;; union body

223

:members (make-instance 'compound-statement

224

:braces t

225

:statements (make-nodes ,body))))

226

227

(c-syntax enum (name &rest enum-list)

228

"Syntax for enum"

229

(setf enum-list (mapcar #'(lambda (x)

230

(if (listp x)

231

x

232

(list x)))

233

enum-list))

234

`(make-instance 'enum-definition

235

:id ,(when name

236

`(make-node ,name))

237

:members

238

(make-nodes ,enum-list :prepend decompose-enum)))

239

240

(c-syntax (aref array) (array &rest indizes &environment env)

241

"Array reference"

242

(if (not indizes)

243

(setf indizes '(nil)))

244

;; make array referende

245

`(make-instance 'array-reference

246

;; check if identifier / type / macro

247

:array

248

,(if (listp array)

249

;; check if macro/function or list

250

(let ((first (first array)))

251

(if (and (not (listp first)) (std:fboundp! first env))

252

;; type is macro or function

253

`(make-node ,array)

254

;; type is list with type information

255

`(make-declaration-node (,@array nil))))

256

;; type is single symbol

257

`(make-node ,array))

258

:indizes

259

(make-nodes ,indizes)))

260

261

(c-syntax oref (&rest rest)

262

"Object reference"

263

(let* ((items (reverse rest))

264

(last-item (pop items))

265

(butlast-item (pop items))

266

(oref `(make-instance 'object-reference

267

:component (make-node ,butlast-item)

268

:object (make-node ,last-item))))

269

(loop for item in items do

270

(setf oref `(make-instance 'object-reference

271

:component (make-node ,item)

272

:object ,oref)))

273

oref))

274

275

(c-syntax pref (pointer component)

276

"Pointer reference"

277

`(make-instance 'pointer-reference :pointer (make-node ,pointer) :component (make-node ,component)))

278

279

(c-syntax type (type)

280

"C data type"

281

`(make-instance 'c-type :type (make-node ,type)))

282

283

(c-syntax specifier (specifier)

284

"Type specifier/qualifier"

285

`(make-instance 'specifier :specifier (make-node ,specifier)))

286

287

(c-syntax include (file)

288

"Include for c files"

289

`(make-instance 'include :file (quoty ,file)))

290

291

(c-syntax comment (comment &key (prefix nil) (linebreak t))

292

"Comment with default ('//') or user defined delimiter."

293

`(make-instance 'comment

294

:chars (quoty ,(if prefix prefix "//"))

295

:comment (quoty ,comment)

296

:linebreak ,linebreak))

297

298

(defun decompose-declaration (item)

299

"Decompose declaration item into its SPECIFIERS, TYPE, NAME and INITIALIZER"

300

(if (< 2 (length item))

301

;; decompose arg list with init

302

(let ((specifier (butlast item 3))

303

(type+id+val (last item 3)))

304

(let ((type (second type+id+val))

305

(id (first type+id+val))

306

(init (third type+id+val)))

307

(values specifier type id init)))

308

;; decompose arg list without init

309

(let ((specifier (butlast item 2))

310

(type+id (last item 2)))

311

(let ((type (second type+id))

312

(id (first type+id)))

313

(values specifier type id nil)))))

314

315

(defmacro make-declaration-node (item)

316

"Decompose declaration item and instantiate nodes"

317

(if (eql item '&rest)

318

`(make-node '|...|)

319

(multiple-value-bind (specifier type id init) (decompose-declaration item)

320

`(make-instance 'declaration-item

321

;; set specifiers

322

:specifier

323

,(when specifier

324

`(make-instance 'specifier

325

:specifier (make-nodes ,specifier)))

326

:type (make-instance 'c-type :type (make-node ,type))

327

:identifier (make-node ,id)

328

:value ,(if init

329

`(make-instance 'declaration-value

330

:value (make-node ,init))

331

nil)))))

332

333

(defmacro decompose-type (item)

334

"Decompose type like declaration but without name"

335

`(make-declaration-node (,@item nil)))

336

337

(defmacro decompose-enum (item)

338

"Decompose enum like declaration but without type"

339

`(make-instance 'declaration-item

340

;; no specifier

341

:specifier nil

342

;; no type

343

:specifier nil

344

;; enum name

345

:identifier (make-node ,(first item))

346

;; enum init

347

:value ,(when (second item)

348

`(make-instance 'declaration-value

349

:value (make-node ,(second item))))))

350

351

(c-syntax decl (bindings &body body)

352

"Declare variables"

353

`(make-instance 'declaration-list

354

;; braces t, adjusted later by traverser

355

:braces t

356

;; make single declarations/bindings

357

:bindings

358

(make-nodes

359

,(remove nil bindings) :prepend make-declaration-node)

360

:body

361

,(when body

362

;; make single expression statements

363

`(make-exprs ,body))))

364

365

(c-syntax function (name type parameters &body body &environment env)

366

"Define a C function"

367

`(make-instance 'function-definition

368

;; function name + type

369

:item

370

,(if (listp type)

371

;; check if macro/function or list

372

(let ((first (first type)))

373

(if (and (not (listp first)) (std:fboundp! first env))

374

;; type is macro or function

375

`(make-declaration-node (,type ,name))

376

;; type is list with type information

377

`(make-declaration-node (,@type ,name))))

378

;; type is single symbol

379

`(make-declaration-node (,name ,type)))

380

:parameter

381

(make-instance 'parameter-list

382

:parameters

383

(make-nodes ,parameters :prepend make-declaration-node))

384

:body

385

,(when body

386

`(make-block ,body))))

387

388

(c-syntax fpointer (name &optional parameters)

389

"Define a function pointer"

390

`(make-instance 'function-pointer

391

;; function pointer identifier

392

:identifier (make-node ,name)

393

;; function pointer parameters

394

:parameters (make-instance 'parameter-list

395

:parameters (make-nodes ,parameters :prepend make-declaration-node))))

396

397

(c-syntax for (init &body body)

398

"The c for loop"

399

`(make-instance 'for-statement

400

;; check if initialization present

401

:init

402

,(when (first init)

403

;; set init

404

`(make-declaration-node ,(first init)))

405

:test

406

(make-node ,(second init))

407

:step

408

(make-node ,(third init))

409

:body

410

(make-block ,body)))

411

412

(c-syntax if (test if-body &optional else-body)

413

"The c if expression"

414

`(make-instance 'if-statement

415

;; case test

416

:test (make-node ,test)

417

;; if true:

418

;; TEST 2024-12-14:

419

:if-body (make-simple-block ,(when if-body if-body))

420

;; if else and present

421

:else-body ,(when else-body

422

`(make-simple-block ,else-body))))

423

424

(c-syntax ? (test then else)

425

"The conditinal expression 'test ? then : else'"

426

`(make-instance 'conditional-expression

427

:test (make-node ,test)

428

:then (make-node ,then)

429

:else (make-node ,else)))

430

431

(defmacro make-switch-case-item (item)

432

"switch case item helper"

433

`(make-instance 'switch-case-item

434

:constant

435

;; list of trigger values

436

,(if (eql (first item) t)

437

;; identify default case

438

nil

439

;; normal cases

440

`(make-nodes ,(if (listp (first item))

441

(first item)

442

(list (first item)))

443

:quoty t))

444

:body

445

(make-exprs ,(rest item))))

446

447

(c-syntax switch (expression &rest cases)

448

"Switch-Case"

449

`(make-instance 'switch-case-statement

450

;; set expression

451

:switch

452

(make-node ,expression)

453

:cases

454

(make-instance 'compound-statement

455

:braces t

456

:statements (make-nodes ,cases :prepend make-switch-case-item))))

457

458

(c-syntax while (test &body body)

459

"The c while loop"

460

`(make-instance 'while-statement

461

:test

462

(make-node ,test)

463

:body

464

(make-block ,body)))

465

466

(c-syntax do-while (test &body body)

467

"The c do-whiel loop"

468

`(make-instance 'do-statement

469

:body

470

(make-block ,body)

471

:test

472

(make-node ,test)))

473

474

(c-syntax typedef (&rest rest)

475

"Typedef for c types"

476

`(make-instance 'typedef

477

:declaration

478

(make-declaration-node ,rest)))

479

480

(c-syntax cast (&rest rest)

481

"Cast type"

482

`(make-instance 'cast-expression

483

:type

484

(decompose-type ,(butlast rest))

485

:object

486

(make-node ,(first (last rest)))))

487

488

(c-syntax sizeof (&rest type)

489

"C sizeof function"

490

`(make-instance 'function-call

491

:function

492

(make-node sizeof)

493

:arguments

494

(decompose-type ,type)))

495

496

(c-syntax float-type (item)

497

"Generate 'f' suffixes"

498

`(make-instance 'float-type :number (make-node ,item)))

499

500

(c-syntax (goto continue break return) (&optional item)

501

"Jump statements with optional item"

502

`(make-instance 'jump-statement

503

:kind

504

(make-node ,syn/gen::tag)

505

:members

506

,(when item `(make-node ,item))))

507

508

(c-syntax (label) (name)

509

"Label"

510

`(make-instance 'label-statement :name (make-node ,name)))

511

512

(c-syntax not (item)

513

"Not-expression"

514

`(make-instance 'not-expression :value (make-node ,item)))

515

516

(c-syntax clist (&rest rest)

517

"C style list"

518

`(make-instance 'clist :items (make-nodes ,rest)))

519

520

(c-syntax funcall (function &rest args)

521

"C function call"

522

`(make-instance 'function-call

523

:function (make-node ,function)

524

:arguments (make-nodes ,args)))

525

526

(c-syntax attribute (&rest args)

527

"GCC attribute extension"

528

`(make-instance 'attribute-expression

529

:arguments (make-nodes ,args)))

530

531

(build-context-switches

532

:package :syn/gen/c/sym

533

:symbols *c-symbols*)

534

535

(build-swap-package

536

:package :syn/gen/c/sym

537

:swap-package :syn/gen/c/swap

538

:symbols *c-swap*)

539

540

;;; Traversal

541

;;; A traverser which checks the identifier for c-conformity

542

;;; and automatically solves naming problems.

543

(defclass renamer ()

544

((used-names :initform (make-hash-table :test 'equal))

545

(name-map :initform (make-hash-table :test 'equal))))

546

(defgeneric check-and-get-name (renamer check-name))

547

548

;;; Check if identifier is OK.

549

;;; Store in hash table and correct if necessary.

550

(defmethod check-and-get-name ((item renamer) check-name)

551

(with-slots (used-names name-map) item

552

(if (eql check-name '|...|)

553

;; ignore '...'

554

check-name

555

;; treat hyphen and underscore equally / map hyphen to underscore

556

(let* ((name-string (symbol-name check-name))

557

(identifier (substitute #\_ #\- name-string)))

558

(when (and (not (equal identifier name-string))

559

(find :hyphen *gen-warnings*))

560

(warn "Possible ambiguity through hyphen override of ~s" check-name))

561

(let ((alr-checked (gethash identifier name-map)))

562

(if alr-checked

563

alr-checked

564

(labels ((check-char (x) (alpha-char-p x))

565

(check-underscore (x) (eql #\_ x))

566

(check-tilde (x) (eql #\~ x))

567

(check-num (x) (digit-char-p x))

568

(check-hex (x) (and (eql #\0 (first x))

569

(or (eql #\x (second x))

570

                                                 (eql #\X (second x)))))

571

(check-all (x)

572

(or

573

(check-char x)

574

(check-underscore x)

575

(check-num x)))

576

(check-nall (x)

577

(not (check-all x))))

578

(let* ((identifier-l (concatenate 'list identifier))

579

(changed-l (if (check-tilde (car identifier-l))

580

(concatenate 'list

581

'(#\~)

582

                                          (substitute-if #\_ #'check-nall (rest identifier-l)))

583

                                        (substitute-if #\_ #'check-nall identifier-l)))

584

(changed (concatenate 'string changed-l)))

585

586

(when (and (check-num (first changed-l))

587

(not (check-hex changed-l)))

588

(setf (first changed-l) #\_)

589

(setf changed (concatenate 'string changed-l)))

590

591

(loop while (gethash changed used-names) do

592

(setf changed (format nil "_~a" changed)))

593

(setf (gethash changed used-names) t)

594

(setf changed (intern changed))

595

(setf (gethash identifier name-map) changed)

596

changed))))))))

597

598

;;; Traverses the tree but checks only the identifier nodes.

599

(defmethod traverse ((rn renamer) (item ident) level)

600

(declare (ignore level))

601

(setf (std:val item)

602

(check-and-get-name rn (val item))))

603

604

;;; This Traverser checks whether braces really are necessary.

605

(defclass decl-blocker ()

606

((names :initform `(,(make-hash-table)))

607

(delta-names :initform '(nil))

608

(in-decl :initform '(nil))

609

(in-decl-item :initform '(nil))

610

(make-block :initform '(nil))))

611

612

(defmethod traverse ((db decl-blocker) (item ident) level)

613

"find names, check if in decl-item, save infos on stack in decl-blocker"

614

(declare (ignore level))

615

(with-slots (val) item

616

(with-slots (names delta-names in-decl-item make-block) db

617

(when (first in-decl-item)

618

(if (gethash val (first names))

619

(setf (first make-block) t)

620

(progn (push val (first delta-names))

621

(setf (gethash val (first names)) t)))))))

622

623

(defmethod traverse :before ((db decl-blocker) (item declaration-list) level)

624

"prepare empty lists and a nil-value for further traversing"

625

(declare (ignore level))

626

(with-slots (delta-names make-block in-decl in-decl-item) db

627

(push nil delta-names)

628

(push nil make-block)

629

(push t in-decl)

630

(push nil in-decl-item)))

631

632

(defmethod traverse :after ((db decl-blocker) (item declaration-list) level)

633

"check values in decl-blocker and set braces to 'true' or 'nil'"

634

(declare (ignore level))

635

(with-slots (names delta-names make-block in-decl in-decl-item) db

636

(if (first make-block)

637

(progn

638

(setf (slot-value item 'braces) t)

639

(loop for i in (first delta-names) do

640

(setf (gethash i (first names)) nil)))

641

(if (> (list-length delta-names) 1)

642

(progn

643

(setf (slot-value item 'braces) nil)

644

(loop for i in (first delta-names) do

645

(push i (second delta-names))))))

646

(pop delta-names)

647

(pop make-block)

648

(pop in-decl)

649

(pop in-decl-item)))

650

651

(defmacro prepare-blocker-stacks (node-class)

652

"create method which prepares decl-blocker stacks"

653

`(defmethod traverse :before ((db decl-blocker) (item ,node-class) level)

654

"prepare empty decl-blocker stacks and values"

655

(declare (ignore level))

656

(with-slots (names) db

657

(push (make-hash-table) names))))

658

659

(defmacro clean-blocker-stacks (node-class)

660

"creates method which cleans decl-blocker stacks"

661

`(defmethod traverse :after ((db decl-blocker) (item ,node-class) level)

662

"clean up decl-blocker stack and values"

663

(declare (ignore level))

664

(with-slots (names) db

665

(pop names))))

666

667

(defmacro decl-blocker-extra-nodes (&rest nodes)

668

`(progn .,(loop for i in nodes collect

669

`(progn (eval (prepare-blocker-stacks ,i))

670

(eval (clean-blocker-stacks ,i))))))

671

672

(decl-blocker-extra-nodes function-definition struct-definition for-statement compound-statement)

673

674

;;; This traverser hides "{}" in ifs where possible

675

(defclass if-blocker ()

676

((parent-node :initform '())

677

(statement-count :initform '(0))

678

(first-statement :initform '(nil))

679

(self-else :initform '(nil))

680

(child-else :initform '(nil))

681

(force-braces :initform '(nil))

682

(curr-level :initform '())))

683

684

(defmethod traverse :before ((ib if-blocker) (item compound-statement) level)

685

"prepare stacks, count statements"

686

(with-slots (parent-node statement-count first-statement force-braces curr-level) ib

687

(with-slots (statements) item

688

(push level curr-level)

689

(push t first-statement)

690

(push 'compound-statement parent-node)

691

(push nil force-braces)

692

(push 0 statement-count))))

693

694

(defmethod traverse :after ((ib if-blocker) (item compound-statement) level)

695

"decide wheter to print braces or not"

696

(with-slots (parent-node statement-count first-statement

697

self-else child-else force-braces curr-level)

698

ib

699

(with-slots (statement braces) item

700

(pop parent-node)

701

(pop curr-level)

702

703

(cond ((eql (first parent-node) 'if-body)

704

705

(cond ((and (< (first statement-count) 2)

706

(not (first self-else)))

707

(setf braces nil))

708

((and (< (first statement-count) 2)

709

(first self-else)

710

(first child-else))

711

(setf braces nil))))

712

713

((eql (first parent-node) 'else-body)

714

(if (< (first statement-count) 2)

715

(setf braces nil))))

716

717

(if (first force-braces)

718

(setf braces t))

719

(pop statement-count)

720

(pop first-statement)

721

(pop force-braces))))

722

723

(defmethod traverse :after ((ib if-blocker) (item comment) level)

724

"force braces if comments are present / important for solitary comments"

725

(declare (ignore level))

726

(with-slots (force-braces) ib

727

(setf (first force-braces) t)))

728

729

(defmethod traverse :before ((ib if-blocker) (item declaration-list) level)

730

"set force-braces (to t) if declartion-list found"

731

(declare (ignore level))

732

(with-slots (force-braces) ib

733

(if force-braces

734

(setf (first force-braces) t))))

735

736

(defmethod traverse :before ((ib if-blocker) (item ast) level)

737

"check nodelists that belong to a compound-statement"

738

(with-slots (statement-count first-statement parent-node curr-level) ib

739

(with-slots (ast) item

740

(when (and (first first-statement)

741

(eql (first parent-node) 'compound-statement)

742

(eql (- level (first curr-level)) 2))

743

744

(let ((count (length ast)))

745

(setf (first first-statement) nil)

746

(setf (first statement-count)

747

(max count (first statement-count))))))))

748

749

750

(defmethod traverse :after ((ib if-blocker) (item expression-statement) level)

751

"place semicolon at empty branches"

752

(with-slots (statement-count curr-level force-braces) ib

753

(with-slots (force-semicolon expression) item

754

(if (and

755

;; subnode that can contain no further statements

756

(typep expression 'ast)

757

;; do nothing if a comment is present, see above (if-blocker comment)

758

(not (eql (first force-braces) t))

759

;; specific position in ast, 1st expr-statement in body.

760

(and (first curr-level) ;; curr-level must be set

761

(eql (- level (first curr-level)) 1))

762

;; subtree has no expressions

763

;; this is a :after method, statement-cound already filled

764

(eql (first statement-count) 0))

765

(setf force-semicolon t)))))

766

767

;;; This traveser removes ambiguous nested compound-statements in else-if

768

;;; to reduce indentation.

769

(defclass else-if-traverser ()())

770

771

;;; Remove nested ast (progn (progn (progn ...)))

772

;;; Required for proper placement of curly braces (esp. for if-else)

773

(defclass nested-ast-remover () ())

774

(defmethod traverse :after ((nar nested-ast-remover) (item ast) level)

775

(with-slots (ast) item

776

(when (and (eql (length ast) 1)

777

(typep (first ast) 'expression-statement)

778

(typep (slot-value (first ast) 'expression) 'ast))

779

(setf ast (slot-value (slot-value (first ast) 'expression) 'ast)))))