Coverage report: /home/ellis/comp/core/std/named-readtables.lisp

Kind	Covered	All	%
expression	365	1084	33.7
branch	42	122	34.4

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; named-readtables.lisp --- named-readtables

2

3

;; The standard readtable is controlled by the Lisp implementation and

4

;; generally shouldn't be touched. There can be problems with

5

;; 'stacking' multiple read-macros as can be seen in this SO post:

6

;; https://stackoverflow.com/questions/73346051/how-can-i-modify-the-and-readtable-macros-in-lisp

7

8

;; Instead, if you really want to change standard readtable behavior,

9

;; it is better to define your own readtables and be aware of the

10

;; context in which they are enabled. For example, loading a system

11

;; definition before enabling the readtable may cause divergent

12

;; behavior (using standard) versus your source code (custom).

13

14

;;; Code:

15

(defpackage :std/named-readtables

16

(:use :cl)

17

(:export

18

:defreadtable

19

:with-readtable

20

:in-readtable

21

:make-readtable

22

:merge-readtables-into

23

:find-readtable

24

:ensure-readtable

25

:rename-readtable

26

:readtable-name

27

:register-readtable

28

:unregister-readtable

29

:copy-named-readtable

30

:list-all-named-readtables

31

;; Types

32

:named-readtable-designator

33

;; Conditions

34

:readtable-error

35

:reader-macro-conflict

36

:readtable-does-already-exist

37

:readtable-does-not-exist

38

:parse-body))

39

40

(in-package :std/named-readtables)

41

(pushnew :named-readtables *features*)

42

43

(defmacro without-package-lock ((&rest package-names) &body body)

44

`(sb-ext:with-unlocked-packages (,@package-names) ,@body))

45

46

;;; Taken from SWANK (which is Public Domain.)

47

48

(defmacro destructure-case (value &body patterns)

49

"Dispatch VALUE to one of PATTERNS.

50

A cross between `case' and `destructuring-bind'.

51

The pattern syntax is:

52

((HEAD . ARGS) . BODY)

53

The list of patterns is searched for a HEAD `eq' to the car of

54

VALUE. If one is found, the BODY is executed with ARGS bound to the

55

corresponding values in the CDR of VALUE."

56

(let ((operator (gensym "op-"))

57

(operands (gensym "rand-"))

58

(tmp (gensym "tmp-")))

59

`(let* ((,tmp ,value)

60

(,operator (car ,tmp))

61

(,operands (cdr ,tmp)))

62

(case ,operator

63

,@(loop for (pattern . body) in patterns collect

64

(if (eq pattern t)

65

`(t ,@body)

66

(destructuring-bind (op &rest rands) pattern

67

`(,op (destructuring-bind ,rands ,operands

68

,@body)))))

69

,@(if (eq (caar (last patterns)) t)

70

'()

71

`((t (error "destructure-case failed: ~S" ,tmp))))))))

72

73

;;; Taken from Alexandria (which is Public Domain, or BSD.)

74

75

(define-condition simple-style-warning (simple-warning style-warning)

76

())

77

78

(defun simple-style-warn (format-control &rest format-args)

79

(warn 'simple-style-warning

80

:format-control format-control

81

:format-arguments format-args))

82

83

(define-condition simple-program-error (simple-error program-error)

84

())

85

86

(defun simple-program-error (message &rest args)

87

(error 'simple-program-error

88

:format-control message

89

:format-arguments args))

90

91

(defun required-argument (&optional name)

92

"Signals an error for a missing argument of NAME. Intended for

93

use as an initialization form for structure and class-slots, and

94

a default value for required keyword arguments."

95

(error "Required argument ~@[~S ~]missing." name))

96

97

(defun ensure-list (list)

98

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

99

designated by LIST."

100

(if (listp list)

101

list

102

(list list)))

103

104

(declaim (inline ensure-function)) ; to propagate return type.

105

(declaim (ftype (function (t) (values function &optional))

106

ensure-function))

107

(defun ensure-function (function-designator)

108

"Returns the function designated by FUNCTION-DESIGNATOR:

109

if FUNCTION-DESIGNATOR is a function, it is returned, otherwise

110

it must be a function name and its FDEFINITION is returned."

111

(if (functionp function-designator)

112

function-designator

113

(fdefinition function-designator)))

114

115

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

116

(defun parse-body (body &key documentation whole)

117

"Parses BODY into (values remaining-forms declarations doc-string).

118

Documentation strings are recognized only if DOCUMENTATION is true.

119

Syntax errors in body are signalled and WHOLE is used in the signal

120

arguments when given."

121

(let ((doc nil)

122

(decls nil)

123

(current nil))

124

(tagbody

125

:declarations

126

(setf current (car body))

127

(when (and documentation (stringp current) (cdr body))

128

(if doc

129

(error "Too many documentation strings in ~S." (or whole body))

130

(setf doc (pop body)))

131

(go :declarations))

132

(when (and (listp current) (eql (first current) 'declare))

133

(push (pop body) decls)

134

(go :declarations)))

135

(values body (nreverse decls) doc)))

136

137

(defun parse-ordinary-lambda-list (lambda-list)

138

"Parses an ordinary lambda-list, returning as multiple values:

139

140

1. Required parameters.

141

2. Optional parameter specifications, normalized into form (NAME INIT SUPPLIEDP)

142

where SUPPLIEDP is NIL if not present.

143

3. Name of the rest parameter, or NIL.

144

4. Keyword parameter specifications, normalized into form ((KEYWORD-NAME NAME) INIT SUPPLIEDP)

145

where SUPPLIEDP is NIL if not present.

146

5. Boolean indicating &ALLOW-OTHER-KEYS presence.

147

6. &AUX parameter specifications, normalized into form (NAME INIT).

148

149

Signals a PROGRAM-ERROR is the lambda-list is malformed."

150

(let ((state :required)

151

(allow-other-keys nil)

152

(auxp nil)

153

(required nil)

154

(optional nil)

155

(rest nil)

156

(keys nil)

157

(aux nil))

158

(labels ((simple-program-error (format-string &rest format-args)

159

(error 'simple-program-error

160

:format-control format-string

161

:format-arguments format-args))

162

(fail (elt)

163

(simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S"

164

elt lambda-list))

165

(check-variable (elt what)

166

(unless (and (symbolp elt) (not (constantp elt)))

167

(simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S"

168

what elt lambda-list)))

169

(check-spec (spec what)

170

(destructuring-bind (init suppliedp) spec

171

(declare (ignore init))

172

(check-variable suppliedp what)))

173

(make-keyword (name)

174

"Interns the string designated by NAME in the KEYWORD package."

175

(intern (string name) :keyword)))

176

(dolist (elt lambda-list)

177

(case elt

178

(&optional

179

(if (eq state :required)

180

(setf state elt)

181

(fail elt)))

182

(&rest

183

(if (member state '(:required &optional))

184

(setf state elt)

185

(progn

186

(break "state=~S" state)

187

(fail elt))))

188

(&key

189

(if (member state '(:required &optional :after-rest))

190

(setf state elt)

191

(fail elt)))

192

(&allow-other-keys

193

(if (eq state '&key)

194

(setf allow-other-keys t

195

state elt)

196

(fail elt)))

197

(&aux

198

(cond ((eq state '&rest)

199

(fail elt))

200

(auxp

201

(simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S"

202

elt lambda-list))

203

(t

204

(setf auxp t

205

state elt))

206

))

207

(otherwise

208

(when (member elt '#.(set-difference lambda-list-keywords

209

                                                 '(&optional &rest &key &allow-other-keys &aux)))

210

(simple-program-error

211

"Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S"

212

elt lambda-list))

213

(case state

214

(:required

215

(check-variable elt "required parameter")

216

(push elt required))

217

(&optional

218

(cond ((consp elt)

219

(destructuring-bind (name &rest tail) elt

220

(check-variable name "optional parameter")

221

(if (cdr tail)

222

(check-spec tail "optional-supplied-p parameter")

223

(setf elt (append elt '(nil))))))

224

(t

225

(check-variable elt "optional parameter")

226

(setf elt (cons elt '(nil nil)))))

227

(push elt optional))

228

(&rest

229

(check-variable elt "rest parameter")

230

(setf rest elt

231

state :after-rest))

232

(&key

233

(cond ((consp elt)

234

(destructuring-bind (var-or-kv &rest tail) elt

235

(cond ((consp var-or-kv)

236

(destructuring-bind (keyword var) var-or-kv

237

(unless (symbolp keyword)

238

                                   (simple-program-error "Invalid keyword name ~S in ordinary ~

239

                                                          lambda-list:~%  ~S"

240

                                                         keyword lambda-list))

241

(check-variable var "keyword parameter")))

242

(t

243

(check-variable var-or-kv "keyword parameter")

244

                               (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv))))

245

(if (cdr tail)

246

(check-spec tail "keyword-supplied-p parameter")

247

(setf tail (append tail '(nil))))

248

(setf elt (cons var-or-kv tail))))

249

(t

250

(check-variable elt "keyword parameter")

251

(setf elt (list (list (make-keyword elt) elt) nil nil))))

252

(push elt keys))

253

(&aux

254

(if (consp elt)

255

(destructuring-bind (var &optional init) elt

256

(declare (ignore init))

257

(check-variable var "&aux parameter"))

258

(check-variable elt "&aux parameter"))

259

(push elt aux))

260

(t

261

(simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list)))))))

262

(values (nreverse required) (nreverse optional) rest (nreverse keys)

263

allow-other-keys (nreverse aux)))))

264

265

(defmacro define-api (name lambda-list type-list &body body)

266

(flet ((parse-type-list (type-list)

267

(let ((pos (position '=> type-list)))

268

(assert pos () "You forgot to specify return type (`=>' missing.)")

269

(values (subseq type-list 0 pos)

270

`(values ,@(nthcdr (1+ pos) type-list) &optional)))))

271

(multiple-value-bind (body decls docstring)

272

(parse-body body :documentation t :whole `(define-api ,name))

273

(multiple-value-bind (arg-typespec value-typespec)

274

(parse-type-list type-list)

275

(multiple-value-bind (reqs opts rest keys)

276

(parse-ordinary-lambda-list lambda-list)

277

(declare (ignorable reqs opts rest keys))

278

`(progn

279

(declaim (ftype (function ,arg-typespec ,value-typespec) ,name))

280

(locally

281

;; Muffle the annoying "&OPTIONAL and &KEY found in

282

;; the same lambda list" style-warning

283

#+sbcl (declare (sb-ext:muffle-conditions style-warning))

284

(defun ,name ,lambda-list

285

,docstring

286

,@decls

287

(locally

288

#+sbcl (declare (sb-ext:unmuffle-conditions style-warning))

289

;; SBCL will interpret the ftype declaration as

290

;; assertion and will insert type checks for us.

291

,@body)))))))))

292

293

(defmacro define-cruft (name lambda-list &body (docstring . alternatives))

294

(assert (typep docstring 'string) (docstring) "Docstring missing!")

295

(assert (not (null alternatives)))

296

`(progn

297

(declaim (inline ,name))

298

(defun ,name ,lambda-list ,docstring ,(first alternatives))))

299

300

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

301

#+sbcl (when (find-symbol "ASSERT-NOT-STANDARD-READTABLE"

302

(find-package "SB-IMPL"))

303

(pushnew :sbcl+safe-standard-readtable *features*)))

304

305

;;;; Mapping between a readtable object and its readtable-name.

306

307

(defvar *readtable-names* (make-hash-table :test 'eq))

308

309

(define-cruft %associate-readtable-with-name (name readtable)

310

"Associate READTABLE with NAME for READTABLE-NAME to work."

311

#+ :common-lisp (setf (gethash readtable *readtable-names*) name))

312

313

(define-cruft %unassociate-readtable-from-name (name readtable)

314

"Remove the association between READTABLE and NAME."

315

#+ :common-lisp (progn (assert (eq name (gethash readtable *readtable-names*)))

316

(remhash readtable *readtable-names*)))

317

318

(define-cruft %readtable-name (readtable)

319

"Return the name associated with READTABLE."

320

#+ :common-lisp (values (gethash readtable *readtable-names*)))

321

322

(define-cruft %list-all-readtable-names ()

323

"Return a list of all available readtable names."

324

#+ :common-lisp (list* :standard :current :modern

325

(loop for name being each hash-value of *readtable-names*

326

collect name)))

327

328

;;;; Mapping READTABLE objects to docstrings.

329

330

(defvar *readtable-to-docstring* (make-hash-table :test 'eq))

331

332

(defun %associate-docstring-with-readtable (readtable docstring)

333

(setf (gethash readtable *readtable-to-docstring*) docstring))

334

335

(defun %unassociate-docstring-from-readtable (readtable)

336

(prog1 (gethash readtable *readtable-to-docstring*)

337

(remhash readtable *readtable-to-docstring*)))

338

339

;;;; Specialized DOCUMENTATION for named readtables.

340

341

;;; Lispworks, at least, forbids defining methods on DOCUMENTATION.

342

;;; Wrapping these forms with WITHOUT-PACKAGE-LOCK (as for PRINT-OBJECT,

343

;;; see below) allows this to compile on Lispworks.

344

345

(without-package-lock (:common-lisp #+lispworks :implementation)

346

347

(defmethod documentation ((name symbol) (doc-type (eql 'readtable)))

348

(let ((readtable (find-readtable name)))

349

(and readtable (gethash readtable *readtable-to-docstring*))))

350

351

(defmethod documentation ((readtable readtable) (doc-type (eql 'readtable)))

352

(gethash readtable *readtable-to-docstring*))

353

354

(defmethod (setf documentation) (docstring (name symbol)

355

                                              (doc-type (eql 'readtable)))

356

(let ((readtable (find-readtable name)))

357

(unless readtable

358

(error 'readtable-does-not-exist :readtable-name name))

359

(setf (gethash readtable *readtable-to-docstring*) docstring)))

360

361

(defmethod (setf documentation) (docstring (readtable readtable)

362

                                              (doc-type (eql 'readtable)))

363

(setf (gethash readtable *readtable-to-docstring*) docstring)))

364

365

;;;; Mapping between a readtable-name and the actual readtable object.

366

367

;;; On Allegro we reuse their named-readtable support so we work

368

;;; nicely on their infrastructure.

369

370

(defvar *named-readtables* (make-hash-table :test 'eq))

371

372

(define-cruft %associate-name-with-readtable (name readtable)

373

"Associate NAME with READTABLE for FIND-READTABLE to work."

374

#+ :common-lisp (setf (gethash name *named-readtables*) readtable))

375

376

(define-cruft %unassociate-name-from-readtable (name readtable)

377

"Remove the association between NAME and READTABLE"

378

#+ :common-lisp (progn (assert (eq readtable (gethash name *named-readtables*)))

379

(remhash name *named-readtables*)))

380

381

(define-cruft %find-readtable (name)

382

"Return the readtable named NAME."

383

#+ :common-lisp (values (gethash name *named-readtables* nil)))

384

385

;;;; Reader-macro related predicates

386

387

;;; CLISP creates new function objects for standard reader macros on

388

;;; each readtable copy.

389

(define-cruft function= (fn1 fn2)

390

"Are reader-macro function-designators FN1 and FN2 the same?"

391

(let ((fn1 (ensure-function fn1))

392

(fn2 (ensure-function fn2)))

393

(or (eq fn1 fn2)

394

;; After SBCL 1.1.18, for dispatch macro characters

395

;; GET-MACRO-CHARACTER returns closures whose name is:

396

;;

397

;; (LAMBDA (STREAM CHAR) :IN SB-IMPL::%MAKE-DISPATCH-MACRO-CHAR)

398

;;

399

;; Treat all these closures equivalent.

400

(flet ((internal-dispatch-macro-closure-name-p (name)

401

(find "SB-IMPL::%MAKE-DISPATCH-MACRO-CHAR" name

402

:key #'prin1-to-string :test #'string-equal)))

403

(let ((n1 (sb-impl::%fun-name fn1))

404

(n2 (sb-impl::%fun-name fn2)))

405

(and (listp n1) (listp n2)

406

(internal-dispatch-macro-closure-name-p n1)

407

(internal-dispatch-macro-closure-name-p n2))))))

408

#+ :common-lisp

409

(eq (ensure-function fn1) (ensure-function fn2)))

410

411

(define-cruft dispatch-macro-char-p (char rt)

412

"Is CHAR a dispatch macro character in RT?"

413

#+ :common-lisp

414

(handler-case (locally

415

(get-dispatch-macro-character char #\x rt)

416

t)

417

(error () nil)))

418

419

;; (defun macro-char-p (char rt)

420

;; (let ((reader-fn (%get-macro-character char rt)))

421

;; (and reader-fn t)))

422

423

;; (defun standard-macro-char-p (char rt)

424

;; (multiple-value-bind (rt-fn rt-flag) (get-macro-character char rt)

425

;; (multiple-value-bind (std-fn std-flag) (get-macro-character char *standard-readtable*)

426

;; (and (eq rt-fn std-fn)

427

;; (eq rt-flag std-flag)))))

428

429

;; (defun standard-dispatch-macro-char-p (disp-char sub-char rt)

430

;; (flet ((non-terminating-p (ch rt) (nth-value 1 (get-macro-character ch rt))))

431

;; (and (eq (non-terminating-p disp-char rt)

432

;; (non-terminating-p disp-char *standard-readtable*))

433

;; (eq (get-dispatch-macro-character disp-char sub-char rt)

434

;; (get-dispatch-macro-character disp-char sub-char *standard-readtable*)))))

435

436

;;;; Readtables Iterators

437

438

(defmacro with-readtable-iterator ((name readtable) &body body)

439

(let ((it (gensym)))

440

`(let ((,it (%make-readtable-iterator ,readtable)))

441

(macrolet ((,name () `(funcall ,',it)))

442

,@body))))

443

444

(defun funcall-or (package-and-name-list &rest args)

445

(loop for (package name) in package-and-name-list

446

do (let ((symbol (find-symbol (string name) package)))

447

(when symbol

448

(return-from funcall-or (apply symbol args))))))

449

450

(defun %make-readtable-iterator (readtable)

451

(let ((char-macro-array (funcall-or '((sb-impl base-char-macro-array)

452

(sb-impl character-macro-array))

453

readtable))

454

(char-macro-ht (funcall-or '((sb-impl extended-char-table)

455

(sb-impl character-macro-hash-table))

456

readtable))

457

(dispatch-tables (sb-impl::dispatch-tables readtable))

458

(char-code 0))

459

(with-hash-table-iterator (ht-iterator char-macro-ht)

460

(labels ((grovel-base-chars ()

461

(if (>= char-code sb-int:base-char-code-limit)

462

(grovel-unicode-chars)

463

(let ((reader-fn (svref char-macro-array char-code))

464

(char (code-char (shiftf char-code (1+ char-code)))))

465

(if reader-fn

466

(yield char)

467

(grovel-base-chars)))))

468

(grovel-unicode-chars ()

469

(multiple-value-bind (more? char) (ht-iterator)

470

(if (not more?)

471

(values nil nil nil nil nil)

472

(yield char))))

473

(yield (char)

474

(let ((disp-fn (get-macro-character char readtable))

475

(disp-ht))

476

(cond

477

((setq disp-ht (cdr (assoc char dispatch-tables)))

478

(let ((sub-char-alist))

479

(maphash (lambda (k v)

480

(push (cons k v) sub-char-alist))

481

disp-ht)

482

(values t char disp-fn t sub-char-alist)))

483

(t

484

(values t char disp-fn nil nil))))))

485

#'grovel-base-chars))))

486

487

(defmacro do-readtable ((entry-designator readtable &optional result)

488

&body body)

489

"Iterate through a readtable's macro characters, and dispatch macro characters."

490

(destructuring-bind (char &optional reader-fn non-terminating-p disp? table)

491

(if (symbolp entry-designator)

492

(list entry-designator)

493

entry-designator)

494

(let ((iter (gensym "ITER+"))

495

(more? (gensym "MORE?+"))

496

(rt (gensym "READTABLE+")))

497

`(let ((,rt ,readtable))

498

(with-readtable-iterator (,iter ,rt)

499

(loop

500

(multiple-value-bind (,more?

501

,char

502

,@(when reader-fn (list reader-fn))

503

,@(when disp? (list disp?))

504

,@(when table (list table)))

505

(,iter)

506

(unless ,more? (return ,result))

507

(let ,(when non-terminating-p

508

;; FIXME: N-T-P should be incorporated in iterators.

509

`((,non-terminating-p

510

(nth-value 1 (get-macro-character ,char ,rt)))))

511

,@body))))))))

512

;;;; Misc

513

514

;;; This should return an implementation's actual standard readtable

515

;;; object only if the implementation makes the effort to guard against

516

;;; modification of that object. Otherwise it should better return a

517

;;; copy.

518

(define-cruft %standard-readtable ()

519

"Return the standard readtable."

520

#+ :sbcl+safe-standard-readtable sb-impl::*standard-readtable*

521

#+ :common-lisp (copy-readtable nil))

522

523

;;; On SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a

524

;;; readtable's dispatch table properly.

525

;;; Same goes for Allegro but that does not seem to provide a

526

;;; setter for their readtable's dispatch tables. Hence this ugly

527

;;; workaround.

528

(define-cruft %clear-readtable (readtable)

529

"Make all macro characters in READTABLE be constituents."

530

(prog1 readtable

531

(do-readtable (char readtable)

532

(set-syntax-from-char char #\A readtable))

533

(setf (sb-impl::dispatch-tables readtable) nil))

534

#+ :common-lisp

535

(do-readtable (char readtable readtable)

536

(set-syntax-from-char char #\A readtable)))

537

538

(define-cruft %get-dispatch-macro-character (char subchar rt)

539

"Ensure ANSI behaviour for GET-DISPATCH-MACRO-CHARACTER."

540

#+ :common-lisp (get-dispatch-macro-character char subchar rt))

541

542

(define-cruft %get-macro-character (char rt)

543

"Ensure ANSI behaviour for GET-MACRO-CHARACTER."

544

#+ :common-lisp (get-macro-character char rt))

545

546

;;;; Specialized PRINT-OBJECT for named readtables.

547

548

;;; As per #19 in CLHS 11.1.2.1.2 defining a method for PRINT-OBJECT

549

;;; that specializes on READTABLE is actually forbidden. It's quite

550

;;; likely to work (modulo package-locks) on most implementations,

551

;;; though.

552

553

(without-package-lock (:common-lisp)

554

(defmethod print-object :around ((rt readtable) stream)

555

(let ((name (readtable-name rt)))

556

(if name

557

(print-unreadable-object (rt stream :type nil :identity t)

558

(format stream "~A ~S" :named-readtable name))

559

(call-next-method)))))

560

561

;;;

562

;;; ``This is enough of a foothold to implement a more elaborate

563

;;; facility for using readtables in a localized way.''

564

;;;

565

;;; (X3J13 Cleanup Issue IN-SYNTAX)

566

;;;

567

568

;;;;;; DEFREADTABLE &c.

569

(defmacro defreadtable (name &body options)

570

"Define a new named readtable, whose name is given by the symbol NAME.

571

Or, if a readtable is already registered under that name, redefine

572

that one.

573

574

The readtable can be populated using the following OPTIONS:

575

576

- If the first element of OPTIONS is a string then it is associated

577

with the readtable as in `(SETF (DOCUMENTATION NAME 'READTABLE)

578

DOCSTRING)`.

579

580

- `(:MERGE READTABLE-DESIGNATORS+)`

581

582

Merge the macro character definitions from the readtables

583

designated into the new readtable being defined as per

584

MERGE-READTABLES-INTO. The copied options are

585

:DISPATCH-MACRO-CHAR, :MACRO-CHAR and :SYNTAX-FROM, but not

586

READTABLE-CASE.

587

588

If no :MERGE clause is given, an empty readtable is used. See

589

MAKE-READTABLE.

590

591

- `(:FUSE READTABLE-DESIGNATORS+)`

592

593

Like :MERGE except:

594

595

Error conditions of type READER-MACRO-CONFLICT that are signaled

596

during the merge operation will be silently _continued_. It

597

follows that reader macros in earlier entries will be

598

overwritten by later ones. For backward compatibility, :FUZE is

599

accepted as an alias of :FUSE.

600

601

- `(:DISPATCH-MACRO-CHAR MACRO-CHAR SUB-CHAR FUNCTION)`

602

603

Define a new sub character `SUB-CHAR` for the dispatching macro

604

character `MACRO-CHAR`, per SET-DISPATCH-MACRO-CHARACTER. You

605

probably have to define `MACRO-CHAR` as a dispatching macro

606

character by the following option first.

607

608

- `(:MACRO-CHAR MACRO-CHAR FUNCTION [NON-TERMINATING-P])`

609

610

Define a new macro character in the readtable, per

611

SET-MACRO-CHARACTER. If [FUNCTION][argument] is the keyword

612

:DISPATCH, `MACRO-CHAR` is made a dispatching macro character,

613

per MAKE-DISPATCH-MACRO-CHARACTER.

614

615

- `(:SYNTAX-FROM FROM-READTABLE-DESIGNATOR FROM-CHAR TO-CHAR)`

616

617

Set the character syntax of TO-CHAR in the readtable being

618

defined to the same syntax as FROM-CHAR as per

619

SET-SYNTAX-FROM-CHAR.

620

621

- `(:CASE CASE-MODE)`

622

623

Defines the _case sensitivity mode_ of the resulting readtable.

624

625

Any number of option clauses may appear. The options are grouped by

626

their type, but in each group the order the options appeared

627

textually is preserved. The following groups exist and are executed

628

in the following order: :MERGE and :FUSE (one group), :CASE,

629

:MACRO-CHAR and :DISPATCH-MACRO-CHAR (one group), finally

630

:SYNTAX-FROM.

631

632

Notes:

633

634

The readtable is defined at load-time. If you want to have it

635

available at compilation time -- say to use its reader-macros in the

636

same file as its definition -- you have to wrap the DEFREADTABLE

637

form in an explicit EVAL-WHEN.

638

639

On redefinition, the target readtable is made empty first before

640

it's refilled according to the clauses.

641

642

NIL, :STANDARD, :COMMON-LISP, :MODERN, and :CURRENT are

643

preregistered readtable names."

644

(check-type name symbol)

645

(when (reserved-readtable-name-p name)

646

(error "~A is the designator for a predefined readtable. ~

647

Not acceptable as a user-specified readtable name." name))

648

(flet ((process-option (option var)

649

(destructure-case option

650

((:merge &rest readtable-designators)

651

`(merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x)

652

                                                      readtable-designators)))

653

((:fuse &rest readtable-designators)

654

`(handler-bind ((reader-macro-conflict #'continue))

655

(merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x)

656

                                                        readtable-designators))))

657

;; alias for :FUSE

658

((:fuze &rest readtable-designators)

659

`(handler-bind ((reader-macro-conflict #'continue))

660

(merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x)

661

                                                        readtable-designators))))

662

((:dispatch-macro-char disp-char sub-char function)

663

`(set-dispatch-macro-character ,disp-char ,sub-char

664

,function ,var))

665

((:macro-char char function &optional non-terminating-p)

666

(if (eq function :dispatch)

667

`(make-dispatch-macro-character ,char ,non-terminating-p ,var)

668

`(set-macro-character ,char ,function

669

,non-terminating-p ,var)))

670

((:syntax-from from-rt-designator from-char to-char)

671

`(set-syntax-from-char ,to-char ,from-char

672

                                      ,var (find-readtable ,from-rt-designator)))

673

((:case mode)

674

`(setf (readtable-case ,var) ,mode))))

675

(remove-clauses (clauses options)

676

(setq clauses (if (listp clauses) clauses (list clauses)))

677

(remove-if-not #'(lambda (x) (member x clauses))

678

options :key #'first)))

679

(let* ((docstring (when (stringp (first options))

680

(pop options)))

681

(merge-clauses (remove-clauses '(:merge :fuze :fuse) options))

682

(case-clauses (remove-clauses :case options))

683

(macro-clauses (remove-clauses '(:macro-char :dispatch-macro-char)

684

options))

685

(syntax-clauses (remove-clauses :syntax-from options))

686

(other-clauses

687

(set-difference options

688

(append merge-clauses case-clauses

689

macro-clauses syntax-clauses))))

690

(cond

691

((not (null other-clauses))

692

(error "Bogus DEFREADTABLE clauses: ~/PPRINT-LINEAR/" other-clauses))

693

(t

694

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

695

;; The (FIND-READTABLE ...) is important for proper

696

;; redefinition semantics, as redefining has to modify the

697

;; already existing readtable object.

698

(let ((readtable (find-readtable ',name)))

699

(cond ((not readtable)

700

(setq readtable (make-readtable ',name)))

701

(t

702

(setq readtable (%clear-readtable readtable))

703

(simple-style-warn

704

"Overwriting already existing readtable ~S."

705

readtable)))

706

(setf (documentation readtable 'readtable) ,docstring)

707

,@(loop for option in merge-clauses

708

collect (process-option option 'readtable))

709

,@(loop for option in case-clauses

710

collect (process-option option 'readtable))

711

,@(loop for option in macro-clauses

712

collect (process-option option 'readtable))

713

,@(loop for option in syntax-clauses

714

collect (process-option option 'readtable))

715

readtable)))))))

716

717

(defmacro in-readtable (name)

718

"Set *READTABLE* to the readtable referred to by the symbol NAME.

719

Return the readtable."

720

(check-type name symbol)

721

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

722

;; NB. The :LOAD-TOPLEVEL is needed for cases like (DEFVAR *FOO*

723

;; (GET-MACRO-CHARACTER #\"))

724

(setf *readtable* (ensure-readtable ',name))

725

(when (find-package :swank)

726

(%frob-swank-readtable-alist *package* *readtable*))

727

*readtable*))

728

729

;;; KLUDGE: [interim solution]

730

;;;

731

;;; We need support for this in Slime itself, because we want IN-READTABLE

732

;;; to work on a per-file basis, and not on a per-package basis.

733

;;;

734

(defun %frob-swank-readtable-alist (package readtable)

735

(let ((readtable-alist (find-symbol (string '#:*readtable-alist*)

736

(find-package :swank))))

737

(when (boundp readtable-alist)

738

(let ((new-item (cons (package-name package) readtable)))

739

(setf (symbol-value readtable-alist)

740

(cons

741

new-item

742

(remove new-item (symbol-value readtable-alist)

743

:test (lambda (entry1 entry2)

744

(string= (car entry1) (car entry2))))))))))

745

746

(deftype readtable-designator ()

747

`(or null readtable))

748

749

(deftype named-readtable-designator ()

750

"Either a symbol or a readtable itself."

751

`(or readtable-designator symbol))

752

753

;;;;; Compiler macros

754

755

;;; Since the :STANDARD readtable is interned, and we can't enforce

756

;;; its immutability, we signal a style-warning for suspicious uses

757

;;; that may result in strange behaviour:

758

759

;;; Modifying the standard readtable would, obviously, lead to a

760

;;; propagation of this change to all places which use the :STANDARD

761

;;; readtable (and thus rendering this readtable to be non-standard,

762

;;; in fact.)

763

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

764

(defun constant-standard-readtable-expression-p (thing)

765

(or (null thing)

766

(eq thing :standard)

767

(and (consp thing)

768

(find thing

769

'((find-readtable nil)

770

(find-readtable :standard)

771

(ensure-readtable nil)

772

(ensure-readtable :standard))

773

:test #'equal))))

774

775

(defun signal-suspicious-registration-warning (name-expr readtable-expr)

776

(when (constant-standard-readtable-expression-p readtable-expr)

777

(simple-style-warn

778

"Caution: ~<You're trying to register the :STANDARD readtable ~

779

under a new name ~S. As modification of the :STANDARD readtable ~

780

is not permitted, subsequent modification of ~S won't be ~

781

permitted either. You probably want to wrap COPY-READTABLE ~

782

around~@:>~% ~S"

783

(list name-expr name-expr) readtable-expr))))

784

785

(define-compiler-macro register-readtable (&whole form name readtable)

786

(signal-suspicious-registration-warning name readtable)

787

form)

788

789

(define-compiler-macro ensure-readtable (&whole form name &optional

790

                                                 (default nil default-p))

791

(when default-p

792

(signal-suspicious-registration-warning name default))

793

form)

794

795

(declaim (special *standard-readtable* *empty-readtable*))

796

797

(define-api make-readtable

798

(&optional (name nil name-supplied-p) &key merge)

799

(&optional named-readtable-designator &key (:merge list) => readtable)

800

"Creates and returns a new readtable under the specified

801

NAME.

802

803

MERGE takes a list of NAMED-READTABLE-DESIGNATORs and specifies the

804

readtables the new readtable is created from. (See the :MERGE clause

805

of DEFREADTABLE for details.)

806

807

If MERGE is NIL, an empty readtable is used instead.

808

809

If NAME is not given, an anonymous empty readtable is returned.

810

811

Notes:

812

813

An empty readtable is a readtable where each character's syntax is

814

the same as in the _standard readtable_ except that each macro

815

character has been made a constituent. Basically: whitespace stays

816

whitespace, everything else is constituent."

817

(cond ((not name-supplied-p)

818

(copy-readtable *empty-readtable*))

819

((reserved-readtable-name-p name)

820

(error "~A is the designator for a predefined readtable. ~

821

Not acceptable as a user-specified readtable name." name))

822

((let ((rt (find-readtable name)))

823

(and rt (prog1 nil

824

(cerror "Overwrite existing entry."

825

'readtable-does-already-exist :readtable-name name)

826

;; Explicitly unregister to make sure that we do

827

;; not hold on of any reference to RT.

828

(unregister-readtable rt)))))

829

(t (let ((result (apply #'merge-readtables-into

830

;; The first readtable specified in

831

;; the :merge list is taken as the

832

;; basis for all subsequent

833

;; (destructive!) modifications (and

834

;; hence it's copied.)

835

(copy-readtable (if merge

836

                                                     (ensure-readtable

837

                                                      (first merge))

838

                                                     *empty-readtable*))

839

(rest merge))))

840

841

(register-readtable name result)))))

842

843

(define-api rename-readtable

844

(old-name new-name)

845

(named-readtable-designator symbol => readtable)

846

"Replaces the associated name of the readtable designated by

847

OLD-NAME with NEW-NAME. If a readtable is already registered under

848

NEW-NAME, an error of type READTABLE-DOES-ALREADY-EXIST is

849

signaled."

850

(when (find-readtable new-name)

851

(cerror "Overwrite existing entry."

852

'readtable-does-already-exist :readtable-name new-name))

853

(let* ((readtable (ensure-readtable old-name))

854

(readtable-name (readtable-name readtable)))

855

;; We use the internal functions directly to omit repeated

856

;; type-checking.

857

(%unassociate-name-from-readtable readtable-name readtable)

858

(%unassociate-readtable-from-name readtable-name readtable)

859

(%associate-name-with-readtable new-name readtable)

860

(%associate-readtable-with-name new-name readtable)

861

(%associate-docstring-with-readtable

862

readtable (%unassociate-docstring-from-readtable readtable))

863

readtable))

864

865

(define-api merge-readtables-into

866

(result-readtable &rest named-readtables)

867

(named-readtable-designator &rest named-readtable-designator => readtable)

868

"Copy macro character definitions of each readtable in

869

NAMED-READTABLES into RESULT-READTABLE.

870

871

If a macro character appears in more than one of the readtables,

872

i.e. if a conflict is discovered during the merge, an error of type

873

READER-MACRO-CONFLICT is signaled.

874

875

The copied options are :DISPATCH-MACRO-CHAR, :MACRO-CHAR and

876

:SYNTAX-FROM, but not READTABLE-CASE."

877

(flet ((merge-into (to from)

878

(do-readtable ((char reader-fn non-terminating-p disp? table) from)

879

(check-reader-macro-conflict from to char)

880

(cond ((not disp?)

881

(set-macro-character char reader-fn non-terminating-p to))

882

(t

883

(ensure-dispatch-macro-character char non-terminating-p to)

884

(loop for (subchar . subfn) in table do

885

(check-reader-macro-conflict from to char subchar)

886

(set-dispatch-macro-character char subchar

887

subfn to)))))

888

to))

889

(let ((result-table (ensure-readtable result-readtable)))

890

(dolist (table (mapcar #'ensure-readtable named-readtables))

891

(merge-into result-table table))

892

result-table)))

893

894

(defun ensure-dispatch-macro-character (char &optional non-terminating-p

895

                                                        (readtable *readtable*))

896

(if (dispatch-macro-char-p char readtable)

897

t

898

(make-dispatch-macro-character char non-terminating-p readtable)))

899

900

(define-api copy-named-readtable

901

(named-readtable)

902

(named-readtable-designator => readtable)

903

"Like COPY-READTABLE but takes a NAMED-READTABLE-DESIGNATOR as argument."

904

(copy-readtable (ensure-readtable named-readtable)))

905

906

(define-api list-all-named-readtables () (=> list)

907

"Returns a list of all registered readtables. The returned list is

908

guaranteed to be fresh, but may contain duplicates."

909

(mapcar #'ensure-readtable (%list-all-readtable-names)))

910

911

(define-condition readtable-error (error) ())

912

913

(define-condition readtable-does-not-exist (readtable-error)

914

((readtable-name :initarg :readtable-name

915

:initform (required-argument)

916

:accessor missing-readtable-name

917

:type named-readtable-designator))

918

(:report (lambda (condition stream)

919

(format stream "A readtable named ~S does not exist."

920

(missing-readtable-name condition)))))

921

922

(define-condition readtable-does-already-exist (readtable-error)

923

((readtable-name :initarg :readtable-name

924

:initform (required-argument)

925

:accessor existing-readtable-name

926

:type named-readtable-designator))

927

(:report (lambda (condition stream)

928

(format stream "A readtable named ~S already exists."

929

(existing-readtable-name condition))))

930

(:documentation "Continuable."))

931

932

(define-condition reader-macro-conflict (readtable-error)

933

((macro-char

934

:initarg :macro-char

935

:initform (required-argument)

936

:accessor conflicting-macro-char

937

:type character)

938

(sub-char

939

:initarg :sub-char

940

:initform nil

941

:accessor conflicting-dispatch-sub-char

942

:type (or null character))

943

(from-readtable

944

:initarg :from-readtable

945

:initform (required-argument)

946

:accessor from-readtable

947

:type readtable)

948

(to-readtable

949

:initarg :to-readtable

950

:initform (required-argument)

951

:accessor to-readtable

952

:type readtable))

953

(:report

954

(lambda (condition stream)

955

(format stream "~@<Reader macro conflict while trying to merge the ~

956

~:[macro character~;dispatch macro characters~] ~

957

~@C~@[ ~@C~] from ~A into ~A.~@:>"

958

(conflicting-dispatch-sub-char condition)

959

(conflicting-macro-char condition)

960

(conflicting-dispatch-sub-char condition)

961

(from-readtable condition)

962

(to-readtable condition))))

963

(:documentation "Continuable.

964

965

This condition is signaled during the merge process if a reader

966

macro (be it a macro character or the sub character of a dispatch

967

macro character) is present in the both source and the target

968

readtable and the two respective reader macro functions differ."))

969

970

(defun check-reader-macro-conflict (from to char &optional subchar)

971

(flet ((conflictp (from-fn to-fn)

972

(assert from-fn ()

973

"Bug in readtable iterators or concurrent access?")

974

(and to-fn (not (function= to-fn from-fn)))))

975

(when (if subchar

976

(conflictp (%get-dispatch-macro-character char subchar from)

977

(%get-dispatch-macro-character char subchar to))

978

(conflictp (%get-macro-character char from)

979

(%get-macro-character char to)))

980

(cerror (format nil "Overwrite ~@C in ~A." char to)

981

'reader-macro-conflict

982

:from-readtable from

983

:to-readtable to

984

:macro-char char

985

:sub-char subchar))))

986

987

;;; Although there is no way to get at the standard readtable in

988

;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make

989

;;; up the perception of its existence by interning a copy of it.

990

;;;

991

;;; We do this for reverse lookup (cf. READTABLE-NAME), i.e. for

992

;;;

993

;;; (equal (readtable-name (find-readtable :standard)) "STANDARD")

994

;;;

995

;;; holding true.

996

;;;

997

;;; We, however, inherit the restriction that the :STANDARD

998

;;; readtable _must not be modified_ (cf. CLHS 2.1.1.2), although it'd

999

;;; technically be feasible (as *STANDARD-READTABLE* will contain a

1000

;;; mutable copy of the implementation-internal standard readtable.)

1001

;;; We cannot enforce this restriction without shadowing

1002

;;; CL:SET-MACRO-CHARACTER and CL:SET-DISPATCH-MACRO-FUNCTION which

1003

;;; is out of scope of this library, though. So we just threaten

1004

;;; with nasal demons.

1005

;;;

1006

(defvar *standard-readtable*

1007

(%standard-readtable))

1008

1009

(defvar *empty-readtable*

1010

(%clear-readtable (copy-readtable nil)))

1011

1012

(defvar *case-preserving-standard-readtable*

1013

(let ((readtable (copy-readtable nil)))

1014

(setf (readtable-case readtable) :preserve)

1015

readtable))

1016

1017

(defparameter *reserved-readtable-names*

1018

'(nil :standard :common-lisp :modern :current))

1019

1020

(defun reserved-readtable-name-p (name)

1021

(and (member name *reserved-readtable-names*) t))

1022

1023

;;; In principle, we could DEFREADTABLE some of these. But we do

1024

;;; reserved readtable lookup seperately, since we can't register a

1025

;;; readtable for :CURRENT anyway.

1026

1027

(defun find-reserved-readtable (reserved-name)

1028

(cond ((eq reserved-name nil) *standard-readtable*)

1029

((eq reserved-name :standard) *standard-readtable*)

1030

((eq reserved-name :common-lisp) *standard-readtable*)

1031

((eq reserved-name :modern) *case-preserving-standard-readtable*)

1032

((eq reserved-name :current) *readtable*)

1033

(t (error "Bug: no such reserved readtable: ~S" reserved-name))))

1034

1035

(define-api find-readtable

1036

(name)

1037

(named-readtable-designator => (or readtable null))

1038

"Looks for the readtable specified by NAME and returns it if it is

1039

found. Returns NIL otherwise."

1040

(cond ((readtablep name) name)

1041

((reserved-readtable-name-p name)

1042

(find-reserved-readtable name))

1043

((%find-readtable name))))

1044

1045

;;; FIXME: This doesn't take a NAMED-READTABLE-DESIGNATOR, but only a

1046

;;; STRING-DESIGNATOR. (When fixing, heed interplay with compiler

1047

;;; macros below.)

1048

(defsetf find-readtable register-readtable)

1049

1050

(define-api ensure-readtable

1051

(name &optional (default nil default-p))

1052

(named-readtable-designator &optional (or named-readtable-designator null)

1053

=> readtable)

1054

"Looks up the readtable specified by NAME and returns it if it's found.

1055

If it is not found, it registers the readtable designated by DEFAULT

1056

under the name represented by NAME; or if no default argument is

1057

given, it signals an error of type READTABLE-DOES-NOT-EXIST

1058

instead."

1059

(cond ((find-readtable name))

1060

((not default-p)

1061

(error 'readtable-does-not-exist :readtable-name name))

1062

(t (setf (find-readtable name) (ensure-readtable default)))))

1063

1064

(define-api register-readtable

1065

(name readtable)

1066

(symbol readtable => readtable)

1067

"Associate READTABLE with NAME. Returns the readtable."

1068

(assert (typep name '(not (satisfies reserved-readtable-name-p))))

1069

(%associate-readtable-with-name name readtable)

1070

(%associate-name-with-readtable name readtable)

1071

readtable)

1072

1073

(define-api unregister-readtable

1074

(named-readtable)

1075

(named-readtable-designator => boolean)

1076

"Remove the association of NAMED-READTABLE. Returns T if successfull,

1077

NIL otherwise."

1078

(let* ((readtable (find-readtable named-readtable))

1079

(readtable-name (and readtable (readtable-name readtable))))

1080

(if (not readtable-name)

1081

nil

1082

(prog1 t

1083

(check-type readtable-name

1084

(not (satisfies reserved-readtable-name-p)))

1085

(%unassociate-readtable-from-name readtable-name readtable)

1086

(%unassociate-name-from-readtable readtable-name readtable)

1087

(%unassociate-docstring-from-readtable readtable)))))

1088

1089

(define-api readtable-name

1090

(named-readtable)

1091

(named-readtable-designator => symbol)

1092

"Returns the name of the readtable designated by NAMED-READTABLE,

1093

or NIL."

1094

(let ((readtable (ensure-readtable named-readtable)))

1095

(cond ((%readtable-name readtable))

1096

((eq readtable *readtable*) :current)

1097

((eq readtable *standard-readtable*) :common-lisp)

1098

((eq readtable *case-preserving-standard-readtable*) :modern)

1099

(t nil))))

1100

1101

(defmacro with-readtable (rt &body body)

1102

(sb-int:with-unique-names (current)

1103

(setf current *readtable*)

1104

`(unwind-protect

1105

(progn

1106

(in-readtable ,rt)

1107

,@body)

1108

(in-readtable ,(readtable-name current)))))

1109

1110

(provide :readtables)