~ubuntu-branches/ubuntu/vivid/cl-asdf/vivid : revision 22

1

;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-

2

;;; This is ASDF 2.014: Another System Definition Facility.

3

;;;

4

;;; Feedback, bug reports, and patches are all welcome:

5

;;; please mail to <asdf-devel@common-lisp.net>.

6

;;; Note first that the canonical source for ASDF is presently

7

;;; <URL:http://common-lisp.net/project/asdf/>.

8

;;;

9

;;; If you obtained this copy from anywhere else, and you experience

10

;;; trouble using it, or find bugs, you may want to check at the

11

;;; location above for a more recent version (and for documentation

12

;;; and test files, if your copy came without them) before reporting

13

;;; bugs. There are usually two "supported" revisions - the git master

14

;;; branch is the latest development version, whereas the git release

15

;;; branch may be slightly older but is considered `stable'

16

17

;;; -- LICENSE START

18

;;; (This is the MIT / X Consortium license as taken from

19

;;; http://www.opensource.org/licenses/mit-license.html on or about

20

;;; Monday; July 13, 2009)

21

;;;

22

23

;;;

24

;;; Permission is hereby granted, free of charge, to any person obtaining

25

;;; a copy of this software and associated documentation files (the

26

;;; "Software"), to deal in the Software without restriction, including

27

;;; without limitation the rights to use, copy, modify, merge, publish,

28

;;; distribute, sublicense, and/or sell copies of the Software, and to

29

;;; permit persons to whom the Software is furnished to do so, subject to

30

;;; the following conditions:

31

;;;

32

;;; The above copyright notice and this permission notice shall be

33

;;; included in all copies or substantial portions of the Software.

34

;;;

35

;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,

36

;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF

37

;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

38

;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE

39

;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION

40

;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION

41

;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

42

;;;

43

;;; -- LICENSE END

44

45

;;; The problem with writing a defsystem replacement is bootstrapping:

46

;;; we can't use defsystem to compile it. Hence, all in one file.

47

48

#+xcvb (module ())

49

50

(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)

51

52

#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this

53

54

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

55

;;; make package if it doesn't exist yet.

56

;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.

57

(unless (find-package :asdf)

58

(make-package :asdf :use '(:common-lisp)))

59

;;; Implementation-dependent tweaks

60

;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.

61

#+allegro

62

(setf excl::*autoload-package-name-alist*

63

(remove "asdf" excl::*autoload-package-name-alist*

64

:test 'equalp :key 'car))

65

#+(and ecl (not ecl-bytecmp)) (require :cmp)

66

#+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)

67

#+(or unix cygwin) (pushnew :asdf-unix *features*))

68

69

(in-package :asdf)

70

71

;;; Strip out formating that is not supported on Genera.

72

(defmacro compatfmt (format)

73

#-genera format

74

#+genera

75

(let ((r '(("~@<" . "")

76

("; ~@;" . "; ")

77

("~3i~_" . "")

78

("~@:>" . "")

79

("~:>" . ""))))

80

(dolist (i r)

81

(loop :for found = (search (car i) format) :while found :do

82

(setf format (concatenate 'simple-string (subseq format 0 found)

83

(cdr i)

84

(subseq format (+ found (length (car i))))))))

85

format))

86

87

;;;; Create packages in a way that is compatible with hot-upgrade.

88

;;;; See https://bugs.launchpad.net/asdf/+bug/485687

89

;;;; See more near the end of the file.

90

91

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

92

(defvar *asdf-version* nil)

93

(defvar *upgraded-p* nil)

94

(let* (;; For bug reporting sanity, please always bump this version when you modify this file.

95

;; Please also modify asdf.asd to reflect this change. The script bin/bump-version

96

;; can help you do these changes in synch (look at the source for documentation).

97

;; Relying on its automation, the version is now redundantly present on top of this file.

98

;; "2.345" would be an official release

99

;; "2.345.6" would be a development version in the official upstream

100

;; "2.345.0.7" would be your seventh local modification of official release 2.345

101

;; "2.345.6.7" would be your seventh local modification of development version 2.345.6

102

(asdf-version "2.014")

103

(existing-asdf (fboundp 'find-system))

104

(existing-version *asdf-version*)

105

(already-there (equal asdf-version existing-version)))

106

(unless (and existing-asdf already-there)

107

(when existing-asdf

108

(format *trace-output*

109

(compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")

110

existing-version asdf-version))

111

(labels

112

((present-symbol-p (symbol package)

113

(member (nth-value 1 (find-sym symbol package)) '(:internal :external)))

114

(present-symbols (package)

115

;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera

116

(let (l)

117

(do-symbols (s package)

118

(when (present-symbol-p s package) (push s l)))

119

(reverse l)))

120

(unlink-package (package)

121

(let ((u (find-package package)))

122

(when u

123

(ensure-unintern u (present-symbols u))

124

(loop :for p :in (package-used-by-list u) :do

125

(unuse-package u p))

126

(delete-package u))))

127

(ensure-exists (name nicknames use)

128

(let ((previous

129

(remove-duplicates

130

(mapcar #'find-package (cons name nicknames))

131

:from-end t)))

132

;; do away with packages with conflicting (nick)names

133

(map () #'unlink-package (cdr previous))

134

;; reuse previous package with same name

135

(let ((p (car previous)))

136

(cond

137

(p

138

(rename-package p name nicknames)

139

(ensure-use p use)

140

p)

141

(t

142

(make-package name :nicknames nicknames :use use))))))

143

(find-sym (symbol package)

144

(find-symbol (string symbol) package))

145

(intern* (symbol package)

146

(intern (string symbol) package))

147

(remove-symbol (symbol package)

148

(let ((sym (find-sym symbol package)))

149

(when sym

150

(unexport sym package)

151

(unintern sym package)

152

sym)))

153

(ensure-unintern (package symbols)

154

(loop :with packages = (list-all-packages)

155

:for sym :in symbols

156

:for removed = (remove-symbol sym package)

157

:when removed :do

158

(loop :for p :in packages :do

159

(when (eq removed (find-sym sym p))

160

(unintern removed p)))))

161

(ensure-shadow (package symbols)

162

(shadow symbols package))

163

(ensure-use (package use)

164

(dolist (used (reverse use))

165

(do-external-symbols (sym used)

166

(unless (eq sym (find-sym sym package))

167

(remove-symbol sym package)))

168

(use-package used package)))

169

(ensure-fmakunbound (package symbols)

170

(loop :for name :in symbols

171

:for sym = (find-sym name package)

172

:when sym :do (fmakunbound sym)))

173

(ensure-export (package export)

174

(let ((formerly-exported-symbols nil)

175

(bothly-exported-symbols nil)

176

(newly-exported-symbols nil))

177

(do-external-symbols (sym package)

178

(if (member sym export :test 'string-equal)

179

(push sym bothly-exported-symbols)

180

(push sym formerly-exported-symbols)))

181

(loop :for sym :in export :do

182

(unless (member sym bothly-exported-symbols :test 'string-equal)

183

(push sym newly-exported-symbols)))

184

(loop :for user :in (package-used-by-list package)

185

:for shadowing = (package-shadowing-symbols user) :do

186

(loop :for new :in newly-exported-symbols

187

:for old = (find-sym new user)

188

:when (and old (not (member old shadowing)))

189

:do (unintern old user)))

190

(loop :for x :in newly-exported-symbols :do

191

(export (intern* x package)))))

192

(ensure-package (name &key nicknames use unintern fmakunbound shadow export)

193

(let* ((p (ensure-exists name nicknames use)))

194

(ensure-unintern p unintern)

195

(ensure-shadow p shadow)

196

(ensure-export p export)

197

(ensure-fmakunbound p fmakunbound)

198

p)))

199

(macrolet

200

((pkgdcl (name &key nicknames use export

201

redefined-functions unintern fmakunbound shadow)

202

`(ensure-package

203

',name :nicknames ',nicknames :use ',use :export ',export

204

:shadow ',shadow

205

:unintern ',(append #-(or gcl ecl) redefined-functions unintern)

206

:fmakunbound ',(append fmakunbound))))

207

(pkgdcl

208

:asdf

209

:nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.

210

:use (:common-lisp)

211

:redefined-functions

212

(#:perform #:explain #:output-files #:operation-done-p

213

#:perform-with-restarts #:component-relative-pathname

214

#:system-source-file #:operate #:find-component #:find-system

215

#:apply-output-translations #:translate-pathname* #:resolve-location

216

#:compile-file*)

217

:unintern

218

(#:*asdf-revision* #:around #:asdf-method-combination

219

#:split #:make-collector

220

#:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function

221

:fmakunbound

222

(#:system-source-file

223

#:component-relative-pathname #:system-relative-pathname

224

#:process-source-registry

225

#:inherit-source-registry #:process-source-registry-directive)

226

:export

227

(#:defsystem #:oos #:operate #:find-system #:run-shell-command

228

#:system-definition-pathname #:find-component ; miscellaneous

229

#:compile-system #:load-system #:test-system #:clear-system

230

#:compile-op #:load-op #:load-source-op

231

#:test-op

232

#:operation ; operations

233

#:feature ; sort-of operation

234

#:version ; metaphorically sort-of an operation

235

#:version-satisfies

236

237

#:input-files #:output-files #:output-file #:perform ; operation methods

238

#:operation-done-p #:explain

239

240

#:component #:source-file

241

#:c-source-file #:cl-source-file #:java-source-file

242

#:static-file

243

#:doc-file

244

#:html-file

245

#:text-file

246

#:source-file-type

247

#:module ; components

248

#:system

249

#:unix-dso

250

251

#:module-components ; component accessors

252

#:module-components-by-name ; component accessors

253

#:component-pathname

254

#:component-relative-pathname

255

#:component-name

256

#:component-version

257

#:component-parent

258

#:component-property

259

#:component-system

260

261

#:component-depends-on

262

263

#:system-description

264

#:system-long-description

265

#:system-author

266

#:system-maintainer

267

#:system-license

268

#:system-licence

269

#:system-source-file

270

#:system-source-directory

271

#:system-relative-pathname

272

#:map-systems

273

274

#:operation-description

275

#:operation-on-warnings

276

#:operation-on-failure

277

#:component-visited-p

278

;;#:*component-parent-pathname*

279

#:*system-definition-search-functions*

280

#:*central-registry* ; variables

281

#:*compile-file-warnings-behaviour*

282

#:*compile-file-failure-behaviour*

283

#:*resolve-symlinks*

284

#:*asdf-verbose*

285

286

#:asdf-version

287

288

#:operation-error #:compile-failed #:compile-warned #:compile-error

289

#:error-name

290

#:error-pathname

291

#:load-system-definition-error

292

#:error-component #:error-operation

293

#:system-definition-error

294

#:missing-component

295

#:missing-component-of-version

296

#:missing-dependency

297

#:missing-dependency-of-version

298

#:circular-dependency ; errors

299

#:duplicate-names

300

301

#:try-recompiling

302

#:retry

303

#:accept ; restarts

304

#:coerce-entry-to-directory

305

#:remove-entry-from-registry

306

307

#:clear-configuration

308

#:*output-translations-parameter*

309

#:initialize-output-translations

310

#:disable-output-translations

311

#:clear-output-translations

312

#:ensure-output-translations

313

#:apply-output-translations

314

#:compile-file*

315

#:compile-file-pathname*

316

#:enable-asdf-binary-locations-compatibility

317

#:*default-source-registries*

318

#:*source-registry-parameter*

319

#:initialize-source-registry

320

#:compute-source-registry

321

#:clear-source-registry

322

#:ensure-source-registry

323

#:process-source-registry

324

#:system-registered-p

325

#:asdf-message

326

327

;; Utilities

328

#:absolute-pathname-p

329

;; #:aif #:it

330

;; #:appendf

331

#:coerce-name

332

#:directory-pathname-p

333

;; #:ends-with

334

#:ensure-directory-pathname

335

#:getenv

336

;; #:get-uid

337

;; #:length=n-p

338

;; #:find-symbol*

339

#:merge-pathnames*

340

#:coerce-pathname

341

#:pathname-directory-pathname

342

#:read-file-forms

343

;; #:remove-keys

344

;; #:remove-keyword

345

#:resolve-symlinks

346

#:split-string

347

#:component-name-to-pathname-components

348

#:split-name-type

349

#:subdirectories

350

#:truenamize

351

#:while-collecting)))

352

#+genera (import 'scl:boolean :asdf)

353

(setf *asdf-version* asdf-version

354

*upgraded-p* (if existing-version

355

(cons existing-version *upgraded-p*)

356

*upgraded-p*))))))

357

358

;;;; -------------------------------------------------------------------------

359

;;;; User-visible parameters

360

;;;;

361

(defun asdf-version ()

362

"Exported interface to the version of ASDF currently installed. A string.

363

You can compare this string with e.g.:

364

(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.013\")."

365

*asdf-version*)

366

367

(defvar *resolve-symlinks* t

368

"Determine whether or not ASDF resolves symlinks when defining systems.

369

370

Defaults to T.")

371

372

(defvar *compile-file-warnings-behaviour*

373

(or #+clisp :ignore :warn)

374

"How should ASDF react if it encounters a warning when compiling a file?

375

Valid values are :error, :warn, and :ignore.")

376

377

(defvar *compile-file-failure-behaviour*

378

(or #+sbcl :error #+clisp :ignore :warn)

379

"How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)

380

when compiling a file? Valid values are :error, :warn, and :ignore.

381

Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")

382

383

(defvar *verbose-out* nil)

384

385

(defvar *asdf-verbose* t)

386

387

(defparameter +asdf-methods+

388

'(perform-with-restarts perform explain output-files operation-done-p))

389

390

#+allegro

391

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

392

(defparameter *acl-warn-save*

393

(when (boundp 'excl:*warn-on-nested-reader-conditionals*)

394

excl:*warn-on-nested-reader-conditionals*))

395

(when (boundp 'excl:*warn-on-nested-reader-conditionals*)

396

(setf excl:*warn-on-nested-reader-conditionals* nil)))

397

398

;;;; -------------------------------------------------------------------------

399

;;;; General Purpose Utilities

400

401

(macrolet

402

((defdef (def* def)

403

`(defmacro ,def* (name formals &rest rest)

404

`(progn

405

#+(or ecl gcl) (fmakunbound ',name)

406

,(when (and #+ecl (symbolp name))

407

`(declaim (notinline ,name))) ; fails for setf functions on ecl

408

(,',def ,name ,formals ,@rest)))))

409

(defdef defgeneric* defgeneric)

410

(defdef defun* defun))

411

412

(defmacro while-collecting ((&rest collectors) &body body)

413

"COLLECTORS should be a list of names for collections. A collector

414

defines a function that, when applied to an argument inside BODY, will

415

add its argument to the corresponding collection. Returns multiple values,

416

a list for each collection, in order.

417

E.g.,

418

$while-collecting \(foo bar$

419

$dolist \(x '\(\(a 1$ $b 2$ $c 3$\)\)

420

$foo \(first x$\)

421

$bar \(second x$\)\)\)

422

Returns two values: $A B C$ and $1 2 3$."

423

(let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))

424

(initial-values (mapcar (constantly nil) collectors)))

425

`(let ,(mapcar #'list vars initial-values)

426

(flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)

427

,@body

428

(values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))

429

430

(defmacro aif (test then &optional else)

431

`(let ((it ,test)) (if it ,then ,else)))

432

433

(defun* pathname-directory-pathname (pathname)

434

"Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,

435

and NIL NAME, TYPE and VERSION components"

436

(when pathname

437

(make-pathname :name nil :type nil :version nil :defaults pathname)))

438

439

(defun* normalize-pathname-directory-component (directory)

440

(cond

441

#-(or cmu sbcl scl)

442

((stringp directory) `(:absolute ,directory) directory)

443

#+gcl

444

((and (consp directory) (stringp (first directory)))

445

`(:absolute ,@directory))

446

((or (null directory)

447

(and (consp directory) (member (first directory) '(:absolute :relative))))

448

directory)

449

(t

450

(error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))

451

452

(defun* merge-pathname-directory-components (specified defaults)

453

(let ((directory (normalize-pathname-directory-component specified)))

454

(ecase (first directory)

455

((nil) defaults)

456

(:absolute specified)

457

(:relative

458

(let ((defdir (normalize-pathname-directory-component defaults))

459

(reldir (cdr directory)))

460

(cond

461

((null defdir)

462

directory)

463

((not (eq :back (first reldir)))

464

(append defdir reldir))

465

(t

466

(loop :with defabs = (first defdir)

467

:with defrev = (reverse (rest defdir))

468

:while (and (eq :back (car reldir))

469

(or (and (eq :absolute defabs) (null defrev))

470

(stringp (car defrev))))

471

:do (pop reldir) (pop defrev)

472

:finally (return (cons defabs (append (reverse defrev) reldir)))))))))))

473

474

(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))

475

"MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname

476

does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.

477

Also, if either argument is NIL, then the other argument is returned unmodified."

478

(when (null specified) (return-from merge-pathnames* defaults))

479

(when (null defaults) (return-from merge-pathnames* specified))

480

#+scl

481

(ext:resolve-pathname specified defaults)

482

#-scl

483

(let* ((specified (pathname specified))

484

(defaults (pathname defaults))

485

(directory (normalize-pathname-directory-component (pathname-directory specified)))

486

(name (or (pathname-name specified) (pathname-name defaults)))

487

(type (or (pathname-type specified) (pathname-type defaults)))

488

(version (or (pathname-version specified) (pathname-version defaults))))

489

(labels ((ununspecific (x)

490

(if (eq x :unspecific) nil x))

491

(unspecific-handler (p)

492

(if (typep p 'logical-pathname) #'ununspecific #'identity)))

493

(multiple-value-bind (host device directory unspecific-handler)

494

(ecase (first directory)

495

((:absolute)

496

(values (pathname-host specified)

497

(pathname-device specified)

498

directory

499

(unspecific-handler specified)))

500

((nil :relative)

501

(values (pathname-host defaults)

502

(pathname-device defaults)

503

(merge-pathname-directory-components directory (pathname-directory defaults))

504

(unspecific-handler defaults))))

505

(make-pathname :host host :device device :directory directory

506

:name (funcall unspecific-handler name)

507

:type (funcall unspecific-handler type)

508

:version (funcall unspecific-handler version))))))

509

510

(defun* pathname-parent-directory-pathname (pathname)

511

"Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,

512

and NIL NAME, TYPE and VERSION components"

513

(when pathname

514

(make-pathname :name nil :type nil :version nil

515

:directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname))

516

:defaults pathname)))

517

518

519

(define-modify-macro appendf (&rest args)

520

append "Append onto list") ;; only to be used on short lists.

521

522

(define-modify-macro orf (&rest args)

523

or "or a flag")

524

525

(defun* first-char (s)

526

(and (stringp s) (plusp (length s)) (char s 0)))

527

528

(defun* last-char (s)

529

(and (stringp s) (plusp (length s)) (char s (1- (length s)))))

530

531

532

(defun* asdf-message (format-string &rest format-args)

533

(declare (dynamic-extent format-args))

534

(apply #'format *verbose-out* format-string format-args))

535

536

(defun* split-string (string &key max (separator '(#\Space #\Tab)))

537

"Split STRING into a list of components separated by

538

any of the characters in the sequence SEPARATOR.

539

If MAX is specified, then no more than max(1,MAX) components will be returned,

540

starting the separation from the end, e.g. when called with arguments

541

\"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."

542

(block nil

543

(let ((list nil) (words 0) (end (length string)))

544

(flet ((separatorp (char) (find char separator))

545

(done () (return (cons (subseq string 0 end) list))))

546

(loop

547

:for start = (if (and max (>= words (1- max)))

548

(done)

549

(position-if #'separatorp string :end end :from-end t)) :do

550

(when (null start)

551

(done))

552

(push (subseq string (1+ start) end) list)

553

(incf words)

554

(setf end start))))))

555

556

(defun* split-name-type (filename)

557

(let ((unspecific

558

;; Giving :unspecific as argument to make-pathname is not portable.

559

;; See CLHS make-pathname and 19.2.2.2.3.

560

;; We only use it on implementations that support it.

561

(or #+(or clozure gcl lispworks sbcl) :unspecific)))

562

(destructuring-bind (name &optional (type unspecific))

563

(split-string filename :max 2 :separator ".")

564

(if (equal name "")

565

(values filename unspecific)

566

(values name type)))))

567

568

(defun* component-name-to-pathname-components (s &key force-directory force-relative)

569

"Splits the path string S, returning three values:

570

A flag that is either :absolute or :relative, indicating

571

how the rest of the values are to be interpreted.

572

A directory path --- a list of strings, suitable for

573

use with MAKE-PATHNAME when prepended with the flag

574

value.

575

A filename with type extension, possibly NIL in the

576

case of a directory pathname.

577

FORCE-DIRECTORY forces S to be interpreted as a directory

578

pathname \(third return value will be NIL, final component

579

of S will be treated as part of the directory path.

580

581

The intention of this function is to support structured component names,

582

e.g., $:file \"foo/bar\"$, which will be unpacked to relative

583

pathnames."

584

(check-type s string)

585

(when (find #\: s)

586

(error (compatfmt "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s))

587

(let* ((components (split-string s :separator "/"))

588

(last-comp (car (last components))))

589

(multiple-value-bind (relative components)

590

(if (equal (first components) "")

591

(if (equal (first-char s) #\/)

592

(progn

593

(when force-relative

594

(error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s))

595

(values :absolute (cdr components)))

596

(values :relative nil))

597

(values :relative components))

598

(setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))

599

(setf components (substitute :back ".." components :test #'equal))

600

(cond

601

((equal last-comp "")

602

(values relative components nil)) ; "" already removed

603

(force-directory

604

(values relative components nil))

605

(t

606

(values relative (butlast components) last-comp))))))

607

608

(defun* remove-keys (key-names args)

609

(loop :for (name val) :on args :by #'cddr

610

:unless (member (symbol-name name) key-names

611

:key #'symbol-name :test 'equal)

612

:append (list name val)))

613

614

(defun* remove-keyword (key args)

615

(loop :for (k v) :on args :by #'cddr

616

:unless (eq k key)

617

:append (list k v)))

618

619

#+mcl

620

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

621

(ccl:define-entry-point (_getenv "getenv") ((name :string)) :string))

622

623

(defun* getenv (x)

624

(declare (ignorable x))

625

#+(or abcl clisp) (ext:getenv x)

626

#+allegro (sys:getenv x)

627

#+clozure (ccl:getenv x)

628

#+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))

629

#+ecl (si:getenv x)

630

#+gcl (system:getenv x)

631

#+genera nil

632

#+lispworks (lispworks:environment-variable x)

633

#+mcl (ccl:with-cstrs ((name x))

634

(let ((value (_getenv name)))

635

(unless (ccl:%null-ptr-p value)

636

(ccl:%get-cstring value))))

637

#+sbcl (sb-ext:posix-getenv x)

638

#-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl)

639

(error "getenv not available on your implementation"))

640

641

(defun* directory-pathname-p (pathname)

642

"Does PATHNAME represent a directory?

643

644

A directory-pathname is a pathname _without_ a filename. The three

645

ways that the filename components can be missing are for it to be NIL,

646

:UNSPECIFIC or the empty string.

647

648

Note that this does _not_ check to see that PATHNAME points to an

649

actually-existing directory."

650

(when pathname

651

(let ((pathname (pathname pathname)))

652

(flet ((check-one (x)

653

(member x '(nil :unspecific "") :test 'equal)))

654

(and (not (wild-pathname-p pathname))

655

(check-one (pathname-name pathname))

656

(check-one (pathname-type pathname))

657

t)))))

658

659

(defun* ensure-directory-pathname (pathspec)

660

"Converts the non-wild pathname designator PATHSPEC to directory form."

661

(cond

662

((stringp pathspec)

663

(ensure-directory-pathname (pathname pathspec)))

664

((not (pathnamep pathspec))

665

(error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))

666

((wild-pathname-p pathspec)

667

(error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))

668

((directory-pathname-p pathspec)

669

pathspec)

670

(t

671

(make-pathname :directory (append (or (pathname-directory pathspec)

672

(list :relative))

673

(list (file-namestring pathspec)))

674

:name nil :type nil :version nil

675

:defaults pathspec))))

676

677

#+genera

678

(unless (fboundp 'ensure-directories-exist)

679

(defun ensure-directories-exist (path)

680

(fs:create-directories-recursively (pathname path))))

681

682

(defun* absolute-pathname-p (pathspec)

683

(and (typep pathspec '(or pathname string))

684

(eq :absolute (car (pathname-directory (pathname pathspec))))))

685

686

(defun* length=n-p (x n) ;is it that (= (length x) n) ?

687

(check-type n (integer 0 *))

688

(loop

689

:for l = x :then (cdr l)

690

:for i :downfrom n :do

691

(cond

692

((zerop i) (return (null l)))

693

((not (consp l)) (return nil)))))

694

695

(defun* ends-with (s suffix)

696

(check-type s string)

697

(check-type suffix string)

698

(let ((start (- (length s) (length suffix))))

699

(and (<= 0 start)

700

(string-equal s suffix :start1 start))))

701

702

(defun* read-file-forms (file)

703

(with-open-file (in file)

704

(loop :with eof = (list nil)

705

:for form = (read in nil eof)

706

:until (eq form eof)

707

:collect form)))

708

709

#+asdf-unix

710

(progn

711

#+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)

712

'(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))

713

(defun* get-uid ()

714

#+allegro (excl.osi:getuid)

715

#+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")

716

:for f = (ignore-errors (read-from-string s))

717

:when f :return (funcall f))

718

#+(or cmu scl) (unix:unix-getuid)

719

#+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)

720

'(ffi:c-inline () () :int "getuid()" :one-liner t)

721

'(ext::getuid))

722

#+sbcl (sb-unix:unix-getuid)

723

#-(or allegro clisp cmu ecl sbcl scl)

724

(let ((uid-string

725

(with-output-to-string (*verbose-out*)

726

(run-shell-command "id -ur"))))

727

(with-input-from-string (stream uid-string)

728

(read-line stream)

729

(handler-case (parse-integer (read-line stream))

730

(error () (error "Unable to find out user ID")))))))

731

732

(defun* pathname-root (pathname)

733

(make-pathname :directory '(:absolute)

734

:name nil :type nil :version nil

735

:defaults pathname ;; host device, and on scl scheme scheme-specific-part port username password

736

. #.(or #+scl '(:parameters nil :query nil :fragment nil))))

737

738

(defun* find-symbol* (s p)

739

(find-symbol (string s) p))

740

741

(defun* probe-file* (p)

742

"when given a pathname P, probes the filesystem for a file or directory

743

with given pathname and if it exists return its truename."

744

(etypecase p

745

(null nil)

746

(string (probe-file* (parse-namestring p)))

747

(pathname (unless (wild-pathname-p p)

748

#.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)

749

#+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))

750

'(ignore-errors (truename p)))))))

751

752

(defun* truenamize (p)

753

"Resolve as much of a pathname as possible"

754

(block nil

755

(when (typep p '(or null logical-pathname)) (return p))

756

(let* ((p (merge-pathnames* p))

757

(directory (pathname-directory p)))

758

(when (typep p 'logical-pathname) (return p))

759

(let ((found (probe-file* p)))

760

(when found (return found)))

761

#-(or cmu sbcl scl) (when (stringp directory) (return p))

762

(when (not (eq :absolute (car directory))) (return p))

763

(let ((sofar (probe-file* (pathname-root p))))

764

(unless sofar (return p))

765

(flet ((solution (directories)

766

(merge-pathnames*

767

(make-pathname :host nil :device nil

768

:directory `(:relative ,@directories)

769

:name (pathname-name p)

770

:type (pathname-type p)

771

:version (pathname-version p))

772

sofar)))

773

(loop :for component :in (cdr directory)

774

:for rest :on (cdr directory)

775

:for more = (probe-file*

776

(merge-pathnames*

777

(make-pathname :directory `(:relative ,component))

778

sofar)) :do

779

(if more

780

(setf sofar more)

781

(return (solution rest)))

782

:finally

783

(return (solution nil))))))))

784

785

(defun* resolve-symlinks (path)

786

#-allegro (truenamize path)

787

#+allegro (if (typep path 'logical-pathname)

788

path

789

(excl:pathname-resolve-symbolic-links path)))

790

791

(defun* default-directory ()

792

(truenamize (pathname-directory-pathname *default-pathname-defaults*)))

793

794

(defun* lispize-pathname (input-file)

795

(make-pathname :type "lisp" :defaults input-file))

796

797

(defparameter *wild-file*

798

(make-pathname :name :wild :type :wild :version :wild :directory nil))

799

(defparameter *wild-directory*

800

(make-pathname :directory '(:relative :wild) :name nil :type nil :version nil))

801

(defparameter *wild-inferiors*

802

(make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))

803

(defparameter *wild-path*

804

(merge-pathnames *wild-file* *wild-inferiors*))

805

806

(defun* wilden (path)

807

(merge-pathnames* *wild-path* path))

808

809

#-scl

810

(defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))

811

(let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))

812

(last-char (namestring foo))))

813

814

#-scl

815

(defun* directorize-pathname-host-device (pathname)

816

(let* ((root (pathname-root pathname))

817

(wild-root (wilden root))

818

(absolute-pathname (merge-pathnames* pathname root))

819

(separator (directory-separator-for-host root))

820

(root-namestring (namestring root))

821

(root-string

822

(substitute-if #\/

823

#'(lambda (x) (or (eql x #\:)

824

(eql x separator)))

825

root-namestring)))

826

(multiple-value-bind (relative path filename)

827

(component-name-to-pathname-components root-string :force-directory t)

828

(declare (ignore relative filename))

829

(let ((new-base

830

(make-pathname :defaults root

831

:directory `(:absolute ,@path))))

832

(translate-pathname absolute-pathname wild-root (wilden new-base))))))

833

834

#+scl

835

(defun* directorize-pathname-host-device (pathname)

836

(let ((scheme (ext:pathname-scheme pathname))

837

(host (pathname-host pathname))

838

(port (ext:pathname-port pathname))

839

(directory (pathname-directory pathname)))

840

(flet ((not-unspecific (component)

841

(and (not (eq component :unspecific)) component)))

842

(cond ((or (not-unspecific port)

843

(and (not-unspecific host) (plusp (length host)))

844

(not-unspecific scheme))

845

(let ((prefix ""))

846

(when (not-unspecific port)

847

(setf prefix (format nil ":~D" port)))

848

(when (and (not-unspecific host) (plusp (length host)))

849

(setf prefix (concatenate 'string host prefix)))

850

(setf prefix (concatenate 'string ":" prefix))

851

(when (not-unspecific scheme)

852

(setf prefix (concatenate 'string scheme prefix)))

853

(assert (and directory (eq (first directory) :absolute)))

854

(make-pathname :directory `(:absolute ,prefix ,@(rest directory))

855

:defaults pathname)))

856

(t

857

pathname)))))

858

859

;;;; -------------------------------------------------------------------------

860

;;;; ASDF Interface, in terms of generic functions.

861

(defgeneric* find-system (system &optional error-p))

862

(defgeneric* perform-with-restarts (operation component))

863

(defgeneric* perform (operation component))

864

(defgeneric* operation-done-p (operation component))

865

(defgeneric* explain (operation component))

866

(defgeneric* output-files (operation component))

867

(defgeneric* input-files (operation component))

868

(defgeneric* component-operation-time (operation component))

869

(defgeneric* operation-description (operation component)

870

(:documentation "returns a phrase that describes performing this operation

871

on this component, e.g. \"loading /a/b/c\".

872

You can put together sentences using this phrase."))

873

874

(defgeneric* system-source-file (system)

875

(:documentation "Return the source file in which system is defined."))

876

877

(defgeneric* component-system (component)

878

(:documentation "Find the top-level system containing COMPONENT"))

879

880

(defgeneric* component-pathname (component)

881

(:documentation "Extracts the pathname applicable for a particular component."))

882

883

(defgeneric* component-relative-pathname (component)

884

(:documentation "Returns a pathname for the component argument intended to be

885

interpreted relative to the pathname of that component's parent.

886

Despite the function's name, the return value may be an absolute

887

pathname, because an absolute pathname may be interpreted relative to

888

another pathname in a degenerate way."))

889

890

(defgeneric* component-property (component property))

891

892

(defgeneric* (setf component-property) (new-value component property))

893

894

(defgeneric* version-satisfies (component version))

895

896

(defgeneric* find-component (base path)

897

(:documentation "Finds the component with PATH starting from BASE module;

898

if BASE is nil, then the component is assumed to be a system."))

899

900

(defgeneric* source-file-type (component system))

901

902

(defgeneric* operation-ancestor (operation)

903

(:documentation

904

"Recursively chase the operation's parent pointer until we get to

905

the head of the tree"))

906

907

(defgeneric* component-visited-p (operation component)

908

(:documentation "Returns the value stored by a call to

909

VISIT-COMPONENT, if that has been called, otherwise NIL.

910

This value stored will be a cons cell, the first element

911

of which is a computed key, so not interesting. The

912

CDR wil be the DATA value stored by VISIT-COMPONENT; recover

913

it as (cdr (component-visited-p op c)).

914

In the current form of ASDF, the DATA value retrieved is

915

effectively a boolean, indicating whether some operations are

916

to be performed in order to do OPERATION X COMPONENT. If the

917

data value is NIL, the combination had been explored, but no

918

operations needed to be performed."))

919

920

(defgeneric* visit-component (operation component data)

921

(:documentation "Record DATA as being associated with OPERATION

922

and COMPONENT. This is a side-effecting function: the association

923

will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the

924

OPERATION\).

925

No evidence that DATA is ever interesting, beyond just being

926

non-NIL. Using the data field is probably very risky; if there is

927

already a record for OPERATION X COMPONENT, DATA will be quietly

928

discarded instead of recorded.

929

Starting with 2.006, TRAVERSE will store an integer in data,

930

so that nodes can be sorted in decreasing order of traversal."))

931

932

933

(defgeneric* (setf visiting-component) (new-value operation component))

934

935

(defgeneric* component-visiting-p (operation component))

936

937

(defgeneric* component-depends-on (operation component)

938

(:documentation

939

"Returns a list of dependencies needed by the component to perform

940

the operation. A dependency has one of the following forms:

941

942

(<operation> <component>*), where <operation> is a class

943

designator and each <component> is a component

944

designator, which means that the component depends on

945

<operation> having been performed on each <component>; or

946

947

(FEATURE <feature>), which means that the component depends

948

on <feature>'s presence in *FEATURES*.

949

950

Methods specialized on subclasses of existing component types

951

should usually append the results of CALL-NEXT-METHOD to the

952

list."))

953

954

(defgeneric* component-self-dependencies (operation component))

955

956

(defgeneric* traverse (operation component)

957

(:documentation

958

"Generate and return a plan for performing OPERATION on COMPONENT.

959

960

The plan returned is a list of dotted-pairs. Each pair is the CONS

961

of ASDF operation object and a COMPONENT object. The pairs will be

962

processed in order by OPERATE."))

963

964

965

;;;; -------------------------------------------------------------------------

966

;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687

967

(when *upgraded-p*

968

(when (find-class 'module nil)

969

(eval

970

`(defmethod update-instance-for-redefined-class :after

971

((m module) added deleted plist &key)

972

(declare (ignorable deleted plist))

973

(when (or *asdf-verbose* *load-verbose*)

974

(asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")

975

m ,(asdf-version)))

976

(when (member 'components-by-name added)

977

(compute-module-components-by-name m))

978

(when (typep m 'system)

979

(when (member 'source-file added)

980

(%set-system-source-file

981

(probe-asd (component-name m) (component-pathname m)) m)

982

(when (equal (component-name m) "asdf")

983

(setf (component-version m) *asdf-version*))))))))

984

985

;;;; -------------------------------------------------------------------------

986

;;;; Classes, Conditions

987

988

(define-condition system-definition-error (error) ()

989

;; [this use of :report should be redundant, but unfortunately it's not.

990

;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function

991

;; over print-object; this is always conditions::%print-condition for

992

;; condition objects, which in turn does inheritance of :report options at

993

;; run-time. fortunately, inheritance means we only need this kludge here in

994

;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]

995

#+cmu (:report print-object))

996

997

(declaim (ftype (function (t) t)

998

format-arguments format-control

999

error-name error-pathname error-condition

1000

duplicate-names-name

1001

error-component error-operation

1002

module-components module-components-by-name

1003

circular-dependency-components

1004

condition-arguments condition-form

1005

condition-format condition-location

1006

coerce-name)

1007

(ftype (function (t t) t) (setf module-components-by-name)))

1008

1009

1010

(define-condition formatted-system-definition-error (system-definition-error)

1011

((format-control :initarg :format-control :reader format-control)

1012

(format-arguments :initarg :format-arguments :reader format-arguments))

1013

(:report (lambda (c s)

1014

(apply #'format s (format-control c) (format-arguments c)))))

1015

1016

(define-condition load-system-definition-error (system-definition-error)

1017

((name :initarg :name :reader error-name)

1018

(pathname :initarg :pathname :reader error-pathname)

1019

(condition :initarg :condition :reader error-condition))

1020

(:report (lambda (c s)

1021

(format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")

1022

(error-name c) (error-pathname c) (error-condition c)))))

1023

1024

(define-condition circular-dependency (system-definition-error)

1025

((components :initarg :components :reader circular-dependency-components))

1026

(:report (lambda (c s)

1027

(format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")

1028

(circular-dependency-components c)))))

1029

1030

(define-condition duplicate-names (system-definition-error)

1031

((name :initarg :name :reader duplicate-names-name))

1032

(:report (lambda (c s)

1033

(format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")

1034

(duplicate-names-name c)))))

1035

1036

(define-condition missing-component (system-definition-error)

1037

((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)

1038

(parent :initform nil :reader missing-parent :initarg :parent)))

1039

1040

(define-condition missing-component-of-version (missing-component)

1041

((version :initform nil :reader missing-version :initarg :version)))

1042

1043

(define-condition missing-dependency (missing-component)

1044

((required-by :initarg :required-by :reader missing-required-by)))

1045

1046

(define-condition missing-dependency-of-version (missing-dependency

1047

missing-component-of-version)

1048

())

1049

1050

(define-condition operation-error (error)

1051

((component :reader error-component :initarg :component)

1052

(operation :reader error-operation :initarg :operation))

1053

(:report (lambda (c s)

1054

(format s (compatfmt "~@<Error while invoking ~A on ~A~@:>")

1055

(error-operation c) (error-component c)))))

1056

(define-condition compile-error (operation-error) ())

1057

(define-condition compile-failed (compile-error) ())

1058

(define-condition compile-warned (compile-error) ())

1059

1060

(define-condition invalid-configuration ()

1061

((form :reader condition-form :initarg :form)

1062

(location :reader condition-location :initarg :location)

1063

(format :reader condition-format :initarg :format)

1064

(arguments :reader condition-arguments :initarg :arguments :initform nil))

1065

(:report (lambda (c s)

1066

(format s (compatfmt "~@<~? (will be skipped)~@:>")

1067

(condition-format c)

1068

(list* (condition-form c) (condition-location c)

1069

(condition-arguments c))))))

1070

(define-condition invalid-source-registry (invalid-configuration warning)

1071

((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))

1072

(define-condition invalid-output-translation (invalid-configuration warning)

1073

((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))

1074

1075

(defclass component ()

1076

((name :accessor component-name :initarg :name :documentation

1077

"Component name: designator for a string composed of portable pathname characters")

1078

(version :accessor component-version :initarg :version)

1079

(description :accessor component-description :initarg :description)

1080

(long-description :accessor component-long-description :initarg :long-description)

1081

;; This one below is used by POIU - http://www.cliki.net/poiu

1082

;; a parallelizing extension of ASDF that compiles in multiple parallel

1083

;; slave processes (forked on demand) and loads in the master process.

1084

;; Maybe in the future ASDF may use it internally instead of in-order-to.

1085

(load-dependencies :accessor component-load-dependencies :initform nil)

1086

;; In the ASDF object model, dependencies exist between *actions*

1087

;; (an action is a pair of operation and component). They are represented

1088

;; alists of operations to dependencies (other actions) in each component.

1089

;; There are two kinds of dependencies, each stored in its own slot:

1090

;; in-order-to and do-first dependencies. These two kinds are related to

1091

;; the fact that some actions modify the filesystem,

1092

;; whereas other actions modify the current image, and

1093

;; this implies a difference in how to interpret timestamps.

1094

;; in-order-to dependencies will trigger re-performing the action

1095

;; when the timestamp of some dependency

1096

;; makes the timestamp of current action out-of-date;

1097

;; do-first dependencies do not trigger such re-performing.

1098

;; Therefore, a FASL must be recompiled if it is obsoleted

1099

;; by any of its FASL dependencies (in-order-to); but

1100

;; it needn't be recompiled just because one of these dependencies

1101

;; hasn't yet been loaded in the current image (do-first).

1102

;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!

1103

;; See our ASDF 2 paper for more complete explanations.

1104

(in-order-to :initform nil :initarg :in-order-to

1105

:accessor component-in-order-to)

1106

(do-first :initform nil :initarg :do-first

1107

:accessor component-do-first)

1108

;; methods defined using the "inline" style inside a defsystem form:

1109

;; need to store them somewhere so we can delete them when the system

1110

;; is re-evaluated

1111

(inline-methods :accessor component-inline-methods :initform nil)

1112

(parent :initarg :parent :initform nil :reader component-parent)

1113

;; no direct accessor for pathname, we do this as a method to allow

1114

;; it to default in funky ways if not supplied

1115

(relative-pathname :initarg :pathname)

1116

(absolute-pathname)

1117

(operation-times :initform (make-hash-table)

1118

:accessor component-operation-times)

1119

;; XXX we should provide some atomic interface for updating the

1120

;; component properties

1121

(properties :accessor component-properties :initarg :properties

1122

:initform nil)))

1123

1124

(defun* component-find-path (component)

1125

(reverse

1126

(loop :for c = component :then (component-parent c)

1127

:while c :collect (component-name c))))

1128

1129

(defmethod print-object ((c component) stream)

1130

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

1131

(format stream "~{~S~^ ~}" (component-find-path c))))

1132

1133

1134

;;;; methods: conditions

1135

1136

(defmethod print-object ((c missing-dependency) s)

1137

(format s (compatfmt "~@<~A, required by ~A~@:>")

1138

(call-next-method c nil) (missing-required-by c)))

1139

1140

(defun* sysdef-error (format &rest arguments)

1141

(error 'formatted-system-definition-error :format-control

1142

format :format-arguments arguments))

1143

1144

;;;; methods: components

1145

1146

(defmethod print-object ((c missing-component) s)

1147

(format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")

1148

(missing-requires c)

1149

(when (missing-parent c)

1150

(coerce-name (missing-parent c)))))

1151

1152

(defmethod print-object ((c missing-component-of-version) s)

1153

(format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>")

1154

(missing-requires c)

1155

(missing-version c)

1156

(when (missing-parent c)

1157

(component-name (missing-parent c)))))

1158

1159

(defmethod component-system ((component component))

1160

(aif (component-parent component)

1161

(component-system it)

1162

component))

1163

1164

(defvar *default-component-class* 'cl-source-file)

1165

1166

(defun* compute-module-components-by-name (module)

1167

(let ((hash (make-hash-table :test 'equal)))

1168

(setf (module-components-by-name module) hash)

1169

(loop :for c :in (module-components module)

1170

:for name = (component-name c)

1171

:for previous = (gethash name (module-components-by-name module))

1172

:do

1173

(when previous

1174

(error 'duplicate-names :name name))

1175

:do (setf (gethash name (module-components-by-name module)) c))

1176

hash))

1177

1178

(defclass module (component)

1179

((components

1180

:initform nil

1181

:initarg :components

1182

:accessor module-components)

1183

(components-by-name

1184

:accessor module-components-by-name)

1185

;; What to do if we can't satisfy a dependency of one of this module's

1186

;; components. This allows a limited form of conditional processing.

1187

(if-component-dep-fails

1188

:initform :fail

1189

:initarg :if-component-dep-fails

1190

:accessor module-if-component-dep-fails)

1191

(default-component-class

1192

:initform *default-component-class*

1193

:initarg :default-component-class

1194

:accessor module-default-component-class)))

1195

1196

(defun* component-parent-pathname (component)

1197

;; No default anymore (in particular, no *default-pathname-defaults*).

1198

;; If you force component to have a NULL pathname, you better arrange

1199

;; for any of its children to explicitly provide a proper absolute pathname

1200

;; wherever a pathname is actually wanted.

1201

(let ((parent (component-parent component)))

1202

(when parent

1203

(component-pathname parent))))

1204

1205

(defmethod component-pathname ((component component))

1206

(if (slot-boundp component 'absolute-pathname)

1207

(slot-value component 'absolute-pathname)

1208

(let ((pathname

1209

(merge-pathnames*

1210

(component-relative-pathname component)

1211

(pathname-directory-pathname (component-parent-pathname component)))))

1212

(unless (or (null pathname) (absolute-pathname-p pathname))

1213

(error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")

1214

pathname (component-find-path component)))

1215

(setf (slot-value component 'absolute-pathname) pathname)

1216

pathname)))

1217

1218

(defmethod component-property ((c component) property)

1219

(cdr (assoc property (slot-value c 'properties) :test #'equal)))

1220

1221

(defmethod (setf component-property) (new-value (c component) property)

1222

(let ((a (assoc property (slot-value c 'properties) :test #'equal)))

1223

(if a

1224

(setf (cdr a) new-value)

1225

(setf (slot-value c 'properties)

1226

(acons property new-value (slot-value c 'properties)))))

1227

new-value)

1228

1229

(defclass system (module)

1230

(;; description and long-description are now available for all component's,

1231

;; but now also inherited from component, but we add the legacy accessor

1232

(description :accessor system-description :initarg :description)

1233

(long-description :accessor system-long-description :initarg :long-description)

1234

(author :accessor system-author :initarg :author)

1235

(maintainer :accessor system-maintainer :initarg :maintainer)

1236

(licence :accessor system-licence :initarg :licence

1237

:accessor system-license :initarg :license)

1238

(source-file :reader system-source-file :initarg :source-file

1239

:writer %set-system-source-file)

1240

(defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))

1241

1242

;;;; -------------------------------------------------------------------------

1243

;;;; version-satisfies

1244

1245

(defmethod version-satisfies ((c component) version)

1246

(unless (and version (slot-boundp c 'version))

1247

(return-from version-satisfies t))

1248

(version-satisfies (component-version c) version))

1249

1250

(defmethod version-satisfies ((cver string) version)

1251

(let ((x (mapcar #'parse-integer

1252

(split-string cver :separator ".")))

1253

(y (mapcar #'parse-integer

1254

(split-string version :separator "."))))

1255

(labels ((bigger (x y)

1256

(cond ((not y) t)

1257

((not x) nil)

1258

((> (car x) (car y)) t)

1259

((= (car x) (car y))

1260

(bigger (cdr x) (cdr y))))))

1261

(and (= (car x) (car y))

1262

(or (not (cdr y)) (bigger (cdr x) (cdr y)))))))

1263

1264

;;;; -------------------------------------------------------------------------

1265

;;;; Finding systems

1266

1267

(defun* make-defined-systems-table ()

1268

(make-hash-table :test 'equal))

1269

1270

(defvar *defined-systems* (make-defined-systems-table)

1271

"This is a hash table whose keys are strings, being the

1272

names of the systems, and whose values are pairs, the first

1273

element of which is a universal-time indicating when the

1274

system definition was last updated, and the second element

1275

of which is a system object.")

1276

1277

(defun* coerce-name (name)

1278

(typecase name

1279

(component (component-name name))

1280

(symbol (string-downcase (symbol-name name)))

1281

(string name)

1282

(t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))

1283

1284

(defun* system-registered-p (name)

1285

(gethash (coerce-name name) *defined-systems*))

1286

1287

(defun* clear-system (name)

1288

"Clear the entry for a system in the database of systems previously loaded.

1289

Note that this does NOT in any way cause the code of the system to be unloaded."

1290

;; There is no "unload" operation in Common Lisp, and a general such operation

1291

;; cannot be portably written, considering how much CL relies on side-effects

1292

;; to global data structures.

1293

(remhash (coerce-name name) *defined-systems*))

1294

1295

(defun* map-systems (fn)

1296

"Apply FN to each defined system.

1297

1298

FN should be a function of one argument. It will be

1299

called with an object of type asdf:system."

1300

(maphash #'(lambda (_ datum)

1301

(declare (ignore _))

1302

(destructuring-bind (_ . def) datum

1303

(declare (ignore _))

1304

(funcall fn def)))

1305

*defined-systems*))

1306

1307

;;; for the sake of keeping things reasonably neat, we adopt a

1308

;;; convention that functions in this list are prefixed SYSDEF-

1309

1310

(defparameter *system-definition-search-functions*

1311

'(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))

1312

1313

(defun* system-definition-pathname (system)

1314

(let ((system-name (coerce-name system)))

1315

(or

1316

(some #'(lambda (x) (funcall x system-name))

1317

*system-definition-search-functions*)

1318

(let ((system-pair (system-registered-p system-name)))

1319

(and system-pair

1320

(system-source-file (cdr system-pair)))))))

1321

1322

(defvar *central-registry* nil

1323

"A list of 'system directory designators' ASDF uses to find systems.

1324

1325

A 'system directory designator' is a pathname or an expression

1326

which evaluates to a pathname. For example:

1327

1328

(setf asdf:*central-registry*

1329

(list '*default-pathname-defaults*

1330

#p\"/home/me/cl/systems/\"

1331

#p\"/usr/share/common-lisp/systems/\"))

1332

1333

This is for backward compatibilily.

1334

Going forward, we recommend new users should be using the source-registry.

1335

")

1336

1337

(defun* probe-asd (name defaults)

1338

(block nil

1339

(when (directory-pathname-p defaults)

1340

(let ((file

1341

(make-pathname

1342

:defaults defaults :version :newest :case :local

1343

:name name

1344

:type "asd")))

1345

(when (probe-file* file)

1346

(return file)))

1347

#+(and asdf-windows (not clisp))

1348

(let ((shortcut

1349

(make-pathname

1350

:defaults defaults :version :newest :case :local

1351

:name (concatenate 'string name ".asd")

1352

:type "lnk")))

1353

(when (probe-file* shortcut)

1354

(let ((target (parse-windows-shortcut shortcut)))

1355

(when target

1356

(return (pathname target)))))))))

1357

1358

(defun* sysdef-central-registry-search (system)

1359

(let ((name (coerce-name system))

1360

(to-remove nil)

1361

(to-replace nil))

1362

(block nil

1363

(unwind-protect

1364

(dolist (dir *central-registry*)

1365

(let ((defaults (eval dir)))

1366

(when defaults

1367

(cond ((directory-pathname-p defaults)

1368

(let ((file (probe-asd name defaults)))

1369

(when file

1370

(return file))))

1371

(t

1372

(restart-case

1373

(let* ((*print-circle* nil)

1374

(message

1375

(format nil

1376

(compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>")

1377

system dir defaults)))

1378

(error message))

1379

(remove-entry-from-registry ()

1380

:report "Remove entry from *central-registry* and continue"

1381

(push dir to-remove))

1382

(coerce-entry-to-directory ()

1383

:report (lambda (s)

1384

(format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")

1385

(ensure-directory-pathname defaults) dir))

1386

(push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))

1387

;; cleanup

1388

(dolist (dir to-remove)

1389

(setf *central-registry* (remove dir *central-registry*)))

1390

(dolist (pair to-replace)

1391

(let* ((current (car pair))

1392

(new (cdr pair))

1393

(position (position current *central-registry*)))

1394

(setf *central-registry*

1395

(append (subseq *central-registry* 0 position)

1396

(list new)

1397

(subseq *central-registry* (1+ position))))))))))

1398

1399

(defun* make-temporary-package ()

1400

(flet ((try (counter)

1401

(ignore-errors

1402

(make-package (format nil "~A~D" :asdf counter)

1403

:use '(:cl :asdf)))))

1404

(do* ((counter 0 (+ counter 1))

1405

(package (try counter) (try counter)))

1406

(package package))))

1407

1408

(defun* safe-file-write-date (pathname)

1409

;; If FILE-WRITE-DATE returns NIL, it's possible that

1410

;; the user or some other agent has deleted an input file.

1411

;; Also, generated files will not exist at the time planning is done

1412

;; and calls operation-done-p which calls safe-file-write-date.

1413

;; So it is very possible that we can't get a valid file-write-date,

1414

;; and we can survive and we will continue the planning

1415

;; as if the file were very old.

1416

;; (or should we treat the case in a different, special way?)

1417

(or (and pathname (probe-file* pathname) (file-write-date pathname))

1418

(progn

1419

(when (and pathname *asdf-verbose*)

1420

(warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>")

1421

pathname))

1422

0)))

1423

1424

(defmethod find-system (name &optional (error-p t))

1425

(find-system (coerce-name name) error-p))

1426

1427

(defun load-sysdef (name pathname)

1428

;; Tries to load system definition with canonical NAME from PATHNAME.

1429

(let ((package (make-temporary-package)))

1430

(unwind-protect

1431

(handler-bind

1432

((error #'(lambda (condition)

1433

(error 'load-system-definition-error

1434

:name name :pathname pathname

1435

:condition condition))))

1436

(let ((*package* package))

1437

(asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")

1438

pathname package)

1439

(load pathname)))

1440

(delete-package package))))

1441

1442

(defmethod find-system ((name string) &optional (error-p t))

1443

(catch 'find-system

1444

(let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk

1445

(on-disk (system-definition-pathname name)))

1446

(when (and on-disk

1447

(or (not in-memory)

1448

;; don't reload if it's already been loaded,

1449

;; or its filestamp is in the future which means some clock is skewed

1450

;; and trying to load might cause an infinite loop.

1451

(< (car in-memory) (safe-file-write-date on-disk) (get-universal-time))))

1452

(load-sysdef name on-disk))

1453

(let ((in-memory (system-registered-p name))) ; try again after loading from disk

1454

(cond

1455

(in-memory

1456

(when on-disk

1457

(setf (car in-memory) (safe-file-write-date on-disk)))

1458

(cdr in-memory))

1459

(error-p

1460

(error 'missing-component :requires name)))))))

1461

1462

(defun* register-system (name system)

1463

(setf name (coerce-name name))

1464

(assert (equal name (component-name system)))

1465

(asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)

1466

(setf (gethash name *defined-systems*) (cons (get-universal-time) system)))

1467

1468

(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)

1469

(setf fallback (coerce-name fallback)

1470

source-file (or source-file

1471

(if *resolve-symlinks*

1472

(or *compile-file-truename* *load-truename*)

1473

(or *compile-file-pathname* *load-pathname*)))

1474

requested (coerce-name requested))

1475

(when (equal requested fallback)

1476

(let* ((registered (cdr (gethash fallback *defined-systems*)))

1477

(system (or registered

1478

(apply 'make-instance 'system

1479

:name fallback :source-file source-file keys))))

1480

(unless registered

1481

(register-system fallback system))

1482

(throw 'find-system system))))

1483

1484

(defun* sysdef-find-asdf (name)

1485

;; Bug: :version *asdf-version* won't be updated when ASDF is updated.

1486

(find-system-fallback name "asdf" :version *asdf-version*))

1487

1488

1489

;;;; -------------------------------------------------------------------------

1490

;;;; Finding components

1491

1492

(defmethod find-component ((base string) path)

1493

(let ((s (find-system base nil)))

1494

(and s (find-component s path))))

1495

1496

(defmethod find-component ((base symbol) path)

1497

(cond

1498

(base (find-component (coerce-name base) path))

1499

(path (find-component path nil))

1500

(t nil)))

1501

1502

(defmethod find-component ((base cons) path)

1503

(find-component (car base) (cons (cdr base) path)))

1504

1505

(defmethod find-component ((module module) (name string))

1506

(unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!

1507

(compute-module-components-by-name module))

1508

(values (gethash name (module-components-by-name module))))

1509

1510

(defmethod find-component ((component component) (name symbol))

1511

(if name

1512

(find-component component (coerce-name name))

1513

component))

1514

1515

(defmethod find-component ((module module) (name cons))

1516

(find-component (find-component module (car name)) (cdr name)))

1517

1518

1519

;;; component subclasses

1520

1521

(defclass source-file (component)

1522

((type :accessor source-file-explicit-type :initarg :type :initform nil)))

1523

1524

(defclass cl-source-file (source-file)

1525

((type :initform "lisp")))

1526

(defclass c-source-file (source-file)

1527

((type :initform "c")))

1528

(defclass java-source-file (source-file)

1529

((type :initform "java")))

1530

(defclass static-file (source-file) ())

1531

(defclass doc-file (static-file) ())

1532

(defclass html-file (doc-file)

1533

((type :initform "html")))

1534

1535

(defmethod source-file-type ((component module) (s module))

1536

(declare (ignorable component s))

1537

:directory)

1538

(defmethod source-file-type ((component source-file) (s module))

1539

(declare (ignorable s))

1540

(source-file-explicit-type component))

1541

1542

(defun* coerce-pathname (name &key type defaults)

1543

"coerce NAME into a PATHNAME.

1544

When given a string, portably decompose it into a relative pathname:

1545

#\\/ separates subdirectories. The last #\\/-separated string is as follows:

1546

if TYPE is NIL, its last #\\. if any separates name and type from from type;

1547

if TYPE is a string, it is the type, and the whole string is the name;

1548

if TYPE is :DIRECTORY, the string is a directory component;

1549

if the string is empty, it's a directory.

1550

Any directory named .. is read as :BACK.

1551

Host, device and version components are taken from DEFAULTS."

1552

;; The defaults are required notably because they provide the default host

1553

;; to the below make-pathname, which may crucially matter to people using

1554

;; merge-pathnames with non-default hosts, e.g. for logical-pathnames.

1555

;; NOTE that the host and device slots will be taken from the defaults,

1556

;; but that should only matter if you later merge relative pathnames with

1557

;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES*

1558

(etypecase name

1559

((or null pathname)

1560

name)

1561

(symbol

1562

(coerce-pathname (string-downcase name) :type type :defaults defaults))

1563

(string

1564

(multiple-value-bind (relative path filename)

1565

(component-name-to-pathname-components name :force-directory (eq type :directory)

1566

:force-relative t)

1567

(multiple-value-bind (name type)

1568

(cond

1569

((or (eq type :directory) (null filename))

1570

(values nil nil))

1571

(type

1572

(values filename type))

1573

(t

1574

(split-name-type filename)))

1575

(make-pathname :directory `(,relative ,@path) :name name :type type

1576

:defaults (or defaults *default-pathname-defaults*)))))))

1577

1578

(defun* merge-component-name-type (name &key type defaults)

1579

;; For backwards compatibility only, for people using internals.

1580

;; Will be removed in a future release, e.g. 2.014.

1581

(coerce-pathname name :type type :defaults defaults))

1582

1583

(defmethod component-relative-pathname ((component component))

1584

(coerce-pathname

1585

(or (slot-value component 'relative-pathname)

1586

(component-name component))

1587

:type (source-file-type component (component-system component))

1588

:defaults (component-parent-pathname component)))

1589

1590

;;;; -------------------------------------------------------------------------

1591

;;;; Operations

1592

1593

;;; one of these is instantiated whenever #'operate is called

1594

1595

(defclass operation ()

1596

(

1597

;; as of danb's 2003-03-16 commit e0d02781, :force can be:

1598

;; T to force the inside of existing system,

1599

;; but not recurse to other systems we depend on.

1600

;; :ALL (or any other atom) to force all systems

1601

;; including other systems we depend on.

1602

;; (SYSTEM1 SYSTEM2 ... SYSTEMN)

1603

;; to force systems named in a given list

1604

;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out.

1605

(forced :initform nil :initarg :force :accessor operation-forced)

1606

(original-initargs :initform nil :initarg :original-initargs

1607

:accessor operation-original-initargs)

1608

(visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)

1609

(visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes)

1610

(parent :initform nil :initarg :parent :accessor operation-parent)))

1611

1612

(defmethod print-object ((o operation) stream)

1613

(print-unreadable-object (o stream :type t :identity t)

1614

(ignore-errors

1615

(prin1 (operation-original-initargs o) stream))))

1616

1617

(defmethod shared-initialize :after ((operation operation) slot-names

1618

&key force

1619

&allow-other-keys)

1620

(declare (ignorable operation slot-names force))

1621

;; empty method to disable initarg validity checking

1622

(values))

1623

1624

(defun* node-for (o c)

1625

(cons (class-name (class-of o)) c))

1626

1627

(defmethod operation-ancestor ((operation operation))

1628

(aif (operation-parent operation)

1629

(operation-ancestor it)

1630

operation))

1631

1632

1633

(defun* make-sub-operation (c o dep-c dep-o)

1634

"C is a component, O is an operation, DEP-C is another

1635

component, and DEP-O, confusingly enough, is an operation

1636

class specifier, not an operation."

1637

(let* ((args (copy-list (operation-original-initargs o)))

1638

(force-p (getf args :force)))

1639

;; note explicit comparison with T: any other non-NIL force value

1640

;; (e.g. :recursive) will pass through

1641

(cond ((and (null (component-parent c))

1642

(null (component-parent dep-c))

1643

(not (eql c dep-c)))

1644

(when (eql force-p t)

1645

(setf (getf args :force) nil))

1646

(apply #'make-instance dep-o

1647

:parent o

1648

:original-initargs args args))

1649

((subtypep (type-of o) dep-o)

1650

o)

1651

(t

1652

(apply #'make-instance dep-o

1653

:parent o :original-initargs args args)))))

1654

1655

1656

(defmethod visit-component ((o operation) (c component) data)

1657

(unless (component-visited-p o c)

1658

(setf (gethash (node-for o c)

1659

(operation-visited-nodes (operation-ancestor o)))

1660

(cons t data))))

1661

1662

(defmethod component-visited-p ((o operation) (c component))

1663

(gethash (node-for o c)

1664

(operation-visited-nodes (operation-ancestor o))))

1665

1666

(defmethod (setf visiting-component) (new-value operation component)

1667

;; MCL complains about unused lexical variables

1668

(declare (ignorable operation component))

1669

new-value)

1670

1671

(defmethod (setf visiting-component) (new-value (o operation) (c component))

1672

(let ((node (node-for o c))

1673

(a (operation-ancestor o)))

1674

(if new-value

1675

(setf (gethash node (operation-visiting-nodes a)) t)

1676

(remhash node (operation-visiting-nodes a)))

1677

new-value))

1678

1679

(defmethod component-visiting-p ((o operation) (c component))

1680

(let ((node (node-for o c)))

1681

(gethash node (operation-visiting-nodes (operation-ancestor o)))))

1682

1683

(defmethod component-depends-on ((op-spec symbol) (c component))

1684

(component-depends-on (make-instance op-spec) c))

1685

1686

(defmethod component-depends-on ((o operation) (c component))

1687

(cdr (assoc (class-name (class-of o))

1688

(component-in-order-to c))))

1689

1690

(defmethod component-self-dependencies ((o operation) (c component))

1691

(let ((all-deps (component-depends-on o c)))

1692

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

1693

(member (component-name c) (cdr x) :test #'string=))

1694

all-deps)))

1695

1696

(defmethod input-files ((operation operation) (c component))

1697

(let ((parent (component-parent c))

1698

(self-deps (component-self-dependencies operation c)))

1699

(if self-deps

1700

(mapcan #'(lambda (dep)

1701

(destructuring-bind (op name) dep

1702

(output-files (make-instance op)

1703

(find-component parent name))))

1704

self-deps)

1705

;; no previous operations needed? I guess we work with the

1706

;; original source file, then

1707

(list (component-pathname c)))))

1708

1709

(defmethod input-files ((operation operation) (c module))

1710

(declare (ignorable operation c))

1711

nil)

1712

1713

(defmethod component-operation-time (o c)

1714

(gethash (type-of o) (component-operation-times c)))

1715

1716

(defmethod operation-done-p ((o operation) (c component))

1717

(let ((out-files (output-files o c))

1718

(in-files (input-files o c))

1719

(op-time (component-operation-time o c)))

1720

(flet ((earliest-out ()

1721

(reduce #'min (mapcar #'safe-file-write-date out-files)))

1722

(latest-in ()

1723

(reduce #'max (mapcar #'safe-file-write-date in-files))))

1724

(cond

1725

((and (not in-files) (not out-files))

1726

;; arbitrary decision: an operation that uses nothing to

1727

;; produce nothing probably isn't doing much.

1728

;; e.g. operations on systems, modules that have no immediate action,

1729

;; but are only meaningful through traversed dependencies

1730

t)

1731

((not out-files)

1732

;; an operation without output-files is probably meant

1733

;; for its side-effects in the current image,

1734

;; assumed to be idem-potent,

1735

;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.

1736

(and op-time (>= op-time (latest-in))))

1737

((not in-files)

1738

;; an operation without output-files and no input-files

1739

;; is probably meant for its side-effects on the file-system,

1740

;; assumed to have to be done everytime.

1741

;; (I don't think there is any such case in ASDF unless extended)

1742

nil)

1743

(t

1744

;; an operation with both input and output files is assumed

1745

;; as computing the latter from the former,

1746

;; assumed to have been done if the latter are all older

1747

;; than the former.

1748

;; e.g. COMPILE-OP of some CL-SOURCE-FILE.

1749

;; We use >= instead of > to play nice with generated files.

1750

;; This opens a race condition if an input file is changed

1751

;; after the output is created but within the same second

1752

;; of filesystem time; but the same race condition exists

1753

;; whenever the computation from input to output takes more

1754

;; than one second of filesystem time (or just crosses the

1755

;; second). So that's cool.

1756

(and

1757

(every #'probe-file* in-files)

1758

(every #'probe-file* out-files)

1759

(>= (earliest-out) (latest-in))))))))

1760

1761

1762

1763

;;; For 1.700 I've done my best to refactor TRAVERSE

1764

;;; by splitting it up in a bunch of functions,

1765

;;; so as to improve the collection and use-detection algorithm. --fare

1766

;;; The protocol is as follows: we pass around operation, dependency,

1767

;;; bunch of other stuff, and a force argument. Return a force flag.

1768

;;; The returned flag is T if anything has changed that requires a rebuild.

1769

;;; The force argument is a list of components that will require a rebuild

1770

;;; if the flag is T, at which point whoever returns the flag has to

1771

;;; mark them all as forced, and whoever recurses again can use a NIL list

1772

;;; as a further argument.

1773

1774

(defvar *forcing* nil

1775

"This dynamically-bound variable is used to force operations in

1776

recursive calls to traverse.")

1777

1778

(defgeneric* do-traverse (operation component collect))

1779

1780

(defun* %do-one-dep (operation c collect required-op required-c required-v)

1781

;; collects a partial plan that results from performing required-op

1782

;; on required-c, possibly with a required-vERSION

1783

(let* ((dep-c (or (let ((d (find-component (component-parent c) required-c)))

1784

(and d (version-satisfies d required-v) d))

1785

(if required-v

1786

(error 'missing-dependency-of-version

1787

:required-by c

1788

:version required-v

1789

:requires required-c)

1790

(error 'missing-dependency

1791

:required-by c

1792

:requires required-c))))

1793

(op (make-sub-operation c operation dep-c required-op)))

1794

(do-traverse op dep-c collect)))

1795

1796

(defun* do-one-dep (operation c collect required-op required-c required-v)

1797

;; this function is a thin, error-handling wrapper around %do-one-dep.

1798

;; Collects a partial plan per that function.

1799

(loop

1800

(restart-case

1801

(return (%do-one-dep operation c collect

1802

required-op required-c required-v))

1803

(retry ()

1804

:report (lambda (s)

1805

(format s "~@<Retry loading component ~3i~_~S.~@:>" required-c))

1806

:test

1807

(lambda (c)

1808

(or (null c)

1809

(and (typep c 'missing-dependency)

1810

(equalp (missing-requires c)

1811

required-c))))))))

1812

1813

(defun* do-dep (operation c collect op dep)

1814

;; type of arguments uncertain:

1815

;; op seems to at least potentially be a symbol, rather than an operation

1816

;; dep is a list of component names

1817

(cond ((eq op 'feature)

1818

(if (member (car dep) *features*)

1819

nil

1820

(error 'missing-dependency

1821

:required-by c

1822

:requires (car dep))))

1823

(t

1824

(let ((flag nil))

1825

(flet ((dep (op comp ver)

1826

(when (do-one-dep operation c collect

1827

op comp ver)

1828

(setf flag t))))

1829

(dolist (d dep)

1830

(if (atom d)

1831

(dep op d nil)

1832

;; structured dependencies --- this parses keywords

1833

;; the keywords could be broken out and cleanly (extensibly)

1834

;; processed by EQL methods

1835

(cond ((eq :version (first d))

1836

;; https://bugs.launchpad.net/asdf/+bug/527788

1837

(dep op (second d) (third d)))

1838

;; This particular subform is not documented and

1839

;; has always been broken in the past.

1840

;; Therefore no one uses it, and I'm cerroring it out,

1841

;; after fixing it

1842

;; See https://bugs.launchpad.net/asdf/+bug/518467

1843

((eq :feature (first d))

1844

(cerror "Continue nonetheless."

1845

"Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")

1846

(when (find (second d) *features* :test 'string-equal)

1847

(dep op (third d) nil)))

1848

(t

1849

(error (compatfmt "~@<Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature> [version]), or a name.~@:>") d))))))

1850

flag))))

1851

1852

(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes

1853

1854

(defun* do-collect (collect x)

1855

(funcall collect x))

1856

1857

(defmethod do-traverse ((operation operation) (c component) collect)

1858

(let ((flag nil)) ;; return value: must we rebuild this and its dependencies?

1859

(labels

1860

((update-flag (x)

1861

(when x

1862

(setf flag t)))

1863

(dep (op comp)

1864

(update-flag (do-dep operation c collect op comp))))

1865

;; Have we been visited yet? If so, just process the result.

1866

(aif (component-visited-p operation c)

1867

(progn

1868

(update-flag (cdr it))

1869

(return-from do-traverse flag)))

1870

;; dependencies

1871

(when (component-visiting-p operation c)

1872

(error 'circular-dependency :components (list c)))

1873

(setf (visiting-component operation c) t)

1874

(unwind-protect

1875

(progn

1876

;; first we check and do all the dependencies for the module.

1877

;; Operations planned in this loop will show up

1878

;; in the results, and are consumed below.

1879

(let ((*forcing* nil))

1880

;; upstream dependencies are never forced to happen just because

1881

;; the things that depend on them are....

1882

(loop

1883

:for (required-op . deps) :in (component-depends-on operation c)

1884

:do (dep required-op deps)))

1885

;; constituent bits

1886

(let ((module-ops

1887

(when (typep c 'module)

1888

(let ((at-least-one nil)

1889

;; This is set based on the results of the

1890

;; dependencies and whether we are in the

1891

;; context of a *forcing* call...

1892

;; inter-system dependencies do NOT trigger

1893

;; building components

1894

(*forcing*

1895

(or *forcing*

1896

(and flag (not (typep c 'system)))))

1897

(error nil))

1898

(while-collecting (internal-collect)

1899

(dolist (kid (module-components c))

1900

(handler-case

1901

(update-flag

1902

(do-traverse operation kid #'internal-collect))

1903

(missing-dependency (condition)

1904

(when (eq (module-if-component-dep-fails c)

1905

:fail)

1906

(error condition))

1907

(setf error condition))

1908

(:no-error (c)

1909

(declare (ignore c))

1910

(setf at-least-one t))))

1911

(when (and (eq (module-if-component-dep-fails c)

1912

:try-next)

1913

(not at-least-one))

1914

(error error)))))))

1915

(update-flag

1916

(or

1917

*forcing*

1918

(not (operation-done-p operation c))

1919

;; For sub-operations, check whether

1920

;; the original ancestor operation was forced,

1921

;; or names us amongst an explicit list of things to force...

1922

;; except that this check doesn't distinguish

1923

;; between all the things with a given name. Sigh.

1924

;; BROKEN!

1925

(let ((f (operation-forced

1926

(operation-ancestor operation))))

1927

(and f (or (not (consp f)) ;; T or :ALL

1928

(and (typep c 'system) ;; list of names of systems to force

1929

(member (component-name c) f

1930

:test #'string=)))))))

1931

(when flag

1932

(let ((do-first (cdr (assoc (class-name (class-of operation))

1933

(component-do-first c)))))

1934

(loop :for (required-op . deps) :in do-first

1935

:do (do-dep operation c collect required-op deps)))

1936

(do-collect collect (vector module-ops))

1937

(do-collect collect (cons operation c)))))

1938

(setf (visiting-component operation c) nil)))

1939

(visit-component operation c (when flag (incf *visit-count*)))

1940

flag))

1941

1942

(defun* flatten-tree (l)

1943

;; You collected things into a list.

1944

;; Most elements are just things to collect again.

1945

;; A (simple-vector 1) indicate that you should recurse into its contents.

1946

;; This way, in two passes (rather than N being the depth of the tree),

1947

;; you can collect things with marginally constant-time append,

1948

;; achieving linear time collection instead of quadratic time.

1949

(while-collecting (c)

1950

(labels ((r (x)

1951

(if (typep x '(simple-vector 1))

1952

(r* (svref x 0))

1953

(c x)))

1954

(r* (l)

1955

(dolist (x l) (r x))))

1956

(r* l))))

1957

1958

(defmethod traverse ((operation operation) (c component))

1959

;; cerror'ing a feature that seems to have NEVER EVER worked

1960

;; ever since danb created it in his 2003-03-16 commit e0d02781.

1961

;; It was both fixed and disabled in the 1.700 rewrite.

1962

(when (consp (operation-forced operation))

1963

(cerror "Continue nonetheless."

1964

"Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")

1965

(setf (operation-forced operation)

1966

(mapcar #'coerce-name (operation-forced operation))))

1967

(flatten-tree

1968

(while-collecting (collect)

1969

(let ((*visit-count* 0))

1970

(do-traverse operation c #'collect)))))

1971

1972

(defmethod perform ((operation operation) (c source-file))

1973

(sysdef-error

1974

(compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")

1975

(class-of operation) (class-of c)))

1976

1977

(defmethod perform ((operation operation) (c module))

1978

(declare (ignorable operation c))

1979

nil)

1980

1981

(defmethod explain ((operation operation) (component component))

1982

(asdf-message "~&;;; ~A~%" (operation-description operation component)))

1983

1984

(defmethod operation-description (operation component)

1985

(format nil (compatfmt "~@<~A on component ~S~@:>")

1986

(class-of operation) (component-find-path component)))

1987

1988

;;;; -------------------------------------------------------------------------

1989

;;;; compile-op

1990

1991

(defclass compile-op (operation)

1992

((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)

1993

(on-warnings :initarg :on-warnings :accessor operation-on-warnings

1994

:initform *compile-file-warnings-behaviour*)

1995

(on-failure :initarg :on-failure :accessor operation-on-failure

1996

:initform *compile-file-failure-behaviour*)

1997

(flags :initarg :flags :accessor compile-op-flags

1998

:initform nil)))

1999

2000

(defun output-file (operation component)

2001

"The unique output file of performing OPERATION on COMPONENT"

2002

(let ((files (output-files operation component)))

2003

(assert (length=n-p files 1))

2004

(first files)))

2005

2006

(defmethod perform :before ((operation compile-op) (c source-file))

2007

(loop :for file :in (asdf:output-files operation c)

2008

:for pathname = (if (typep file 'logical-pathname)

2009

(translate-logical-pathname file)

2010

file)

2011

:do (ensure-directories-exist pathname)))

2012

2013

(defmethod perform :after ((operation operation) (c component))

2014

(setf (gethash (type-of operation) (component-operation-times c))

2015

(get-universal-time)))

2016

2017

(defvar *compile-op-compile-file-function* 'compile-file*

2018

"Function used to compile lisp files.")

2019

2020

;;; perform is required to check output-files to find out where to put

2021

;;; its answers, in case it has been overridden for site policy

2022

(defmethod perform ((operation compile-op) (c cl-source-file))

2023

#-:broken-fasl-loader

2024

(let ((source-file (component-pathname c))

2025

;; on some implementations, there are more than one output-file,

2026

;; but the first one should always be the primary fasl that gets loaded.

2027

(output-file (first (output-files operation c)))

2028

(*compile-file-warnings-behaviour* (operation-on-warnings operation))

2029

(*compile-file-failure-behaviour* (operation-on-failure operation)))

2030

(multiple-value-bind (output warnings-p failure-p)

2031

(apply *compile-op-compile-file-function* source-file :output-file output-file

2032

(compile-op-flags operation))

2033

(when warnings-p

2034

(case (operation-on-warnings operation)

2035

(:warn (warn

2036

(compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")

2037

operation c))

2038

(:error (error 'compile-warned :component c :operation operation))

2039

(:ignore nil)))

2040

(when failure-p

2041

(case (operation-on-failure operation)

2042

(:warn (warn

2043

(compatfmt "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>")

2044

operation c))

2045

(:error (error 'compile-failed :component c :operation operation))

2046

(:ignore nil)))

2047

(unless output

2048

(error 'compile-error :component c :operation operation)))))

2049

2050

(defmethod output-files ((operation compile-op) (c cl-source-file))

2051

(declare (ignorable operation))

2052

(let ((p (lispize-pathname (component-pathname c))))

2053

#-broken-fasl-loader (list (compile-file-pathname p))

2054

#+broken-fasl-loader (list p)))

2055

2056

(defmethod perform ((operation compile-op) (c static-file))

2057

(declare (ignorable operation c))

2058

nil)

2059

2060

(defmethod output-files ((operation compile-op) (c static-file))

2061

(declare (ignorable operation c))

2062

nil)

2063

2064

(defmethod input-files ((operation compile-op) (c static-file))

2065

(declare (ignorable operation c))

2066

nil)

2067

2068

(defmethod operation-description ((operation compile-op) component)

2069

(declare (ignorable operation))

2070

(format nil "compiling component ~S" (component-find-path component)))

2071

2072

;;;; -------------------------------------------------------------------------

2073

;;;; load-op

2074

2075

(defclass basic-load-op (operation) ())

2076

2077

(defclass load-op (basic-load-op) ())

2078

2079

(defmethod perform ((o load-op) (c cl-source-file))

2080

(map () #'load (input-files o c)))

2081

2082

(defmethod perform-with-restarts (operation component)

2083

(perform operation component))

2084

2085

(defmethod perform-with-restarts ((o load-op) (c cl-source-file))

2086

(declare (ignorable o))

2087

(loop :with state = :initial

2088

:until (or (eq state :success)

2089

(eq state :failure)) :do

2090

(case state

2091

(:recompiled

2092

(setf state :failure)

2093

(call-next-method)

2094

(setf state :success))

2095

(:failed-load

2096

(setf state :recompiled)

2097

(perform (make-instance 'compile-op) c))

2098

(t

2099

(with-simple-restart

2100

(try-recompiling "Recompile ~a and try loading it again"

2101

(component-name c))

2102

(setf state :failed-load)

2103

(call-next-method)

2104

(setf state :success))))))

2105

2106

(defmethod perform-with-restarts ((o compile-op) (c cl-source-file))

2107

(loop :with state = :initial

2108

:until (or (eq state :success)

2109

(eq state :failure)) :do

2110

(case state

2111

(:recompiled

2112

(setf state :failure)

2113

(call-next-method)

2114

(setf state :success))

2115

(:failed-compile

2116

(setf state :recompiled)

2117

(perform-with-restarts o c))

2118

(t

2119

(with-simple-restart

2120

(try-recompiling "Try recompiling ~a"

2121

(component-name c))

2122

(setf state :failed-compile)

2123

(call-next-method)

2124

(setf state :success))))))

2125

2126

(defmethod perform ((operation load-op) (c static-file))

2127

(declare (ignorable operation c))

2128

nil)

2129

2130

(defmethod operation-done-p ((operation load-op) (c static-file))

2131

(declare (ignorable operation c))

2132

t)

2133

2134

(defmethod output-files ((operation operation) (c component))

2135

(declare (ignorable operation c))

2136

nil)

2137

2138

(defmethod component-depends-on ((operation load-op) (c component))

2139

(declare (ignorable operation))

2140

(cons (list 'compile-op (component-name c))

2141

(call-next-method)))

2142

2143

(defmethod operation-description ((operation load-op) component)

2144

(declare (ignorable operation))

2145

(format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>")

2146

(component-find-path component)))

2147

2148

2149

;;;; -------------------------------------------------------------------------

2150

;;;; load-source-op

2151

2152

(defclass load-source-op (basic-load-op) ())

2153

2154

(defmethod perform ((o load-source-op) (c cl-source-file))

2155

(declare (ignorable o))

2156

(let ((source (component-pathname c)))

2157

(setf (component-property c 'last-loaded-as-source)

2158

(and (load source)

2159

(get-universal-time)))))

2160

2161

(defmethod perform ((operation load-source-op) (c static-file))

2162

(declare (ignorable operation c))

2163

nil)

2164

2165

(defmethod output-files ((operation load-source-op) (c component))

2166

(declare (ignorable operation c))

2167

nil)

2168

2169

;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.

2170

(defmethod component-depends-on ((o load-source-op) (c component))

2171

(declare (ignorable o))

2172

(let ((what-would-load-op-do (cdr (assoc 'load-op

2173

(component-in-order-to c)))))

2174

(mapcar #'(lambda (dep)

2175

(if (eq (car dep) 'load-op)

2176

(cons 'load-source-op (cdr dep))

2177

dep))

2178

what-would-load-op-do)))

2179

2180

(defmethod operation-done-p ((o load-source-op) (c source-file))

2181

(declare (ignorable o))

2182

(if (or (not (component-property c 'last-loaded-as-source))

2183

(> (safe-file-write-date (component-pathname c))

2184

(component-property c 'last-loaded-as-source)))

2185

nil t))

2186

2187

(defmethod operation-description ((operation load-source-op) component)

2188

(declare (ignorable operation))

2189

(format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>")

2190

(component-find-path component)))

2191

2192

2193

;;;; -------------------------------------------------------------------------

2194

;;;; test-op

2195

2196

(defclass test-op (operation) ())

2197

2198

(defmethod perform ((operation test-op) (c component))

2199

(declare (ignorable operation c))

2200

nil)

2201

2202

(defmethod operation-done-p ((operation test-op) (c system))

2203

"Testing a system is _never_ done."

2204

(declare (ignorable operation c))

2205

nil)

2206

2207

(defmethod component-depends-on :around ((o test-op) (c system))

2208

(declare (ignorable o))

2209

(cons `(load-op ,(component-name c)) (call-next-method)))

2210

2211

2212

;;;; -------------------------------------------------------------------------

2213

;;;; Invoking Operations

2214

2215

(defgeneric* operate (operation-class system &key &allow-other-keys))

2216

2217

(defmethod operate (operation-class system &rest args

2218

&key ((:verbose *asdf-verbose*) *asdf-verbose*) version force

2219

&allow-other-keys)

2220

(declare (ignore force))

2221

(let* ((*package* *package*)

2222

(*readtable* *readtable*)

2223

(op (apply #'make-instance operation-class

2224

:original-initargs args

2225

args))

2226

(*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))

2227

(system (if (typep system 'component) system (find-system system))))

2228

(unless (version-satisfies system version)

2229

(error 'missing-component-of-version :requires system :version version))

2230

(let ((steps (traverse op system)))

2231

(with-compilation-unit ()

2232

(loop :for (op . component) :in steps :do

2233

(loop

2234

(restart-case

2235

(progn

2236

(perform-with-restarts op component)

2237

(return))

2238

(retry ()

2239

:report

2240

(lambda (s)

2241

(format s (compatfmt "~@<Retry ~A.~@:>")

2242

(operation-description op component))))

2243

(accept ()

2244

:report

2245

(lambda (s)

2246

(format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")

2247

(operation-description op component)))

2248

(setf (gethash (type-of op)

2249

(component-operation-times component))

2250

(get-universal-time))

2251

(return))))))

2252

(values op steps))))

2253

2254

(defun* oos (operation-class system &rest args &key force verbose version

2255

&allow-other-keys)

2256

(declare (ignore force verbose version))

2257

(apply #'operate operation-class system args))

2258

2259

(let ((operate-docstring

2260

"Operate does three things:

2261

2262

1. It creates an instance of OPERATION-CLASS using any keyword parameters

2263

as initargs.

2264

2. It finds the asdf-system specified by SYSTEM (possibly loading

2265

it from disk).

2266

3. It then calls TRAVERSE with the operation and system as arguments

2267

2268

The traverse operation is wrapped in WITH-COMPILATION-UNIT and error

2269

handling code. If a VERSION argument is supplied, then operate also

2270

ensures that the system found satisfies it using the VERSION-SATISFIES

2271

method.

2272

2273

Note that dependencies may cause the operation to invoke other

2274

operations on the system or its components: the new operations will be

2275

created with the same initargs as the original one.

2276

"))

2277

(setf (documentation 'oos 'function)

2278

(format nil

2279

"Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"

2280

operate-docstring))

2281

(setf (documentation 'operate 'function)

2282

operate-docstring))

2283

2284

(defun* load-system (system &rest args &key force verbose version

2285

&allow-other-keys)

2286

"Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for

2287

details."

2288

(declare (ignore force verbose version))

2289

(apply #'operate 'load-op system args)

2290

t)

2291

2292

(defun* compile-system (system &rest args &key force verbose version

2293

&allow-other-keys)

2294

"Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE

2295

for details."

2296

(declare (ignore force verbose version))

2297

(apply #'operate 'compile-op system args)

2298

t)

2299

2300

(defun* test-system (system &rest args &key force verbose version

2301

&allow-other-keys)

2302

"Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for

2303

details."

2304

(declare (ignore force verbose version))

2305

(apply #'operate 'test-op system args)

2306

t)

2307

2308

;;;; -------------------------------------------------------------------------

2309

;;;; Defsystem

2310

2311

(defun* load-pathname ()

2312

(let ((pn (or *load-pathname* *compile-file-pathname*)))

2313

(if *resolve-symlinks*

2314

(and pn (resolve-symlinks pn))

2315

pn)))

2316

2317

(defun* determine-system-pathname (pathname pathname-supplied-p)

2318

;; The defsystem macro calls us to determine

2319

;; the pathname of a system as follows:

2320

;; 1. the one supplied,

2321

;; 2. derived from *load-pathname* via load-pathname

2322

;; 3. taken from the *default-pathname-defaults* via default-directory

2323

(let* ((file-pathname (load-pathname))

2324

(directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))

2325

(or (and pathname-supplied-p

2326

(merge-pathnames* (coerce-pathname pathname :type :directory)

2327

directory-pathname))

2328

directory-pathname

2329

(default-directory))))

2330

2331

(defmacro defsystem (name &body options)

2332

(setf name (coerce-name name))

2333

(destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)

2334

defsystem-depends-on &allow-other-keys)

2335

options

2336

(let ((component-options (remove-keys '(:class) options)))

2337

`(progn

2338

;; system must be registered before we parse the body, otherwise

2339

;; we recur when trying to find an existing system of the same name

2340

;; to reuse options (e.g. pathname) from

2341

,@(loop :for system :in defsystem-depends-on

2342

:collect `(load-system ',(coerce-name system)))

2343

(let ((s (system-registered-p ',name)))

2344

(cond ((and s (eq (type-of (cdr s)) ',class))

2345

(setf (car s) (get-universal-time)))

2346

(s

2347

(change-class (cdr s) ',class))

2348

(t

2349

(register-system (quote ,name)

2350

(make-instance ',class :name ',name))))

2351

(%set-system-source-file (load-pathname)

2352

(cdr (system-registered-p ',name))))

2353

(parse-component-form

2354

nil (list*

2355

:module (coerce-name ',name)

2356

:pathname

2357

,(determine-system-pathname pathname pathname-arg-p)

2358

',component-options))))))

2359

2360

(defun* class-for-type (parent type)

2361

(or (loop :for symbol :in (list

2362

type

2363

(find-symbol* type *package*)

2364

(find-symbol* type :asdf))

2365

:for class = (and symbol (find-class symbol nil))

2366

:when (and class (subtypep class 'component))

2367

:return class)

2368

(and (eq type :file)

2369

(or (module-default-component-class parent)

2370

(find-class *default-component-class*)))

2371

(sysdef-error "don't recognize component type ~A" type)))

2372

2373

(defun* maybe-add-tree (tree op1 op2 c)

2374

"Add the node C at /OP1/OP2 in TREE, unless it's there already.

2375

Returns the new tree (which probably shares structure with the old one)"

2376

(let ((first-op-tree (assoc op1 tree)))

2377

(if first-op-tree

2378

(progn

2379

(aif (assoc op2 (cdr first-op-tree))

2380

(if (find c (cdr it))

2381

nil

2382

(setf (cdr it) (cons c (cdr it))))

2383

(setf (cdr first-op-tree)

2384

(acons op2 (list c) (cdr first-op-tree))))

2385

tree)

2386

(acons op1 (list (list op2 c)) tree))))

2387

2388

(defun* union-of-dependencies (&rest deps)

2389

(let ((new-tree nil))

2390

(dolist (dep deps)

2391

(dolist (op-tree dep)

2392

(dolist (op (cdr op-tree))

2393

(dolist (c (cdr op))

2394

(setf new-tree

2395

(maybe-add-tree new-tree (car op-tree) (car op) c))))))

2396

new-tree))

2397

2398

2399

(defvar *serial-depends-on* nil)

2400

2401

(defun* sysdef-error-component (msg type name value)

2402

(sysdef-error (concatenate 'string msg

2403

(compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))

2404

type name value))

2405

2406

(defun* check-component-input (type name weakly-depends-on

2407

depends-on components in-order-to)

2408

"A partial test of the values of a component."

2409

(unless (listp depends-on)

2410

(sysdef-error-component ":depends-on must be a list."

2411

type name depends-on))

2412

(unless (listp weakly-depends-on)

2413

(sysdef-error-component ":weakly-depends-on must be a list."

2414

type name weakly-depends-on))

2415

(unless (listp components)

2416

(sysdef-error-component ":components must be NIL or a list of components."

2417

type name components))

2418

(unless (and (listp in-order-to) (listp (car in-order-to)))

2419

(sysdef-error-component ":in-order-to must be NIL or a list of components."

2420

type name in-order-to)))

2421

2422

(defun* %remove-component-inline-methods (component)

2423

(dolist (name +asdf-methods+)

2424

(map ()

2425

;; this is inefficient as most of the stored

2426

;; methods will not be for this particular gf

2427

;; But this is hardly performance-critical

2428

#'(lambda (m)

2429

(remove-method (symbol-function name) m))

2430

(component-inline-methods component)))

2431

;; clear methods, then add the new ones

2432

(setf (component-inline-methods component) nil))

2433

2434

(defun* %define-component-inline-methods (ret rest)

2435

(dolist (name +asdf-methods+)

2436

(let ((keyword (intern (symbol-name name) :keyword)))

2437

(loop :for data = rest :then (cddr data)

2438

:for key = (first data)

2439

:for value = (second data)

2440

:while data

2441

:when (eq key keyword) :do

2442

(destructuring-bind (op qual (o c) &body body) value

2443

(pushnew

2444

(eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))

2445

,@body))

2446

(component-inline-methods ret)))))))

2447

2448

(defun* %refresh-component-inline-methods (component rest)

2449

(%remove-component-inline-methods component)

2450

(%define-component-inline-methods component rest))

2451

2452

(defun* parse-component-form (parent options)

2453

(destructuring-bind

2454

(type name &rest rest &key

2455

;; the following list of keywords is reproduced below in the

2456

;; remove-keys form. important to keep them in sync

2457

components pathname default-component-class

2458

perform explain output-files operation-done-p

2459

weakly-depends-on

2460

depends-on serial in-order-to

2461

;; list ends

2462

&allow-other-keys) options

2463

(declare (ignorable perform explain output-files operation-done-p))

2464

(check-component-input type name weakly-depends-on depends-on components in-order-to)

2465

2466

(when (and parent

2467

(find-component parent name)

2468

;; ignore the same object when rereading the defsystem

2469

(not

2470

(typep (find-component parent name)

2471

(class-for-type parent type))))

2472

(error 'duplicate-names :name name))

2473

2474

(let* ((other-args (remove-keys

2475

'(components pathname default-component-class

2476

perform explain output-files operation-done-p

2477

weakly-depends-on

2478

depends-on serial in-order-to)

2479

rest))

2480

(ret

2481

(or (find-component parent name)

2482

(make-instance (class-for-type parent type)))))

2483

(when weakly-depends-on

2484

(appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))

2485

(when *serial-depends-on*

2486

(push *serial-depends-on* depends-on))

2487

(apply #'reinitialize-instance ret

2488

:name (coerce-name name)

2489

:pathname pathname

2490

:parent parent

2491

other-args)

2492

(component-pathname ret) ; eagerly compute the absolute pathname

2493

(when (typep ret 'module)

2494

(setf (module-default-component-class ret)

2495

(or default-component-class

2496

(and (typep parent 'module)

2497

(module-default-component-class parent))))

2498

(let ((*serial-depends-on* nil))

2499

(setf (module-components ret)

2500

(loop

2501

:for c-form :in components

2502

:for c = (parse-component-form ret c-form)

2503

:for name = (component-name c)

2504

:collect c

2505

:when serial :do (setf *serial-depends-on* name))))

2506

(compute-module-components-by-name ret))

2507

2508

(setf (component-load-dependencies ret) depends-on) ;; Used by POIU

2509

2510

(setf (component-in-order-to ret)

2511

(union-of-dependencies

2512

in-order-to

2513

`((compile-op (compile-op ,@depends-on))

2514

(load-op (load-op ,@depends-on)))))

2515

(setf (component-do-first ret) `((compile-op (load-op ,@depends-on))))

2516

2517

(%refresh-component-inline-methods ret rest)

2518

ret)))

2519

2520

;;;; ---------------------------------------------------------------------------

2521

;;;; run-shell-command

2522

;;;;

2523

;;;; run-shell-command functions for other lisp implementations will be

2524

;;;; gratefully accepted, if they do the same thing.

2525

;;;; If the docstring is ambiguous, send a bug report.

2526

;;;;

2527

;;;; We probably should move this functionality to its own system and deprecate

2528

;;;; use of it from the asdf package. However, this would break unspecified

2529

;;;; existing software, so until a clear alternative exists, we can't deprecate

2530

;;;; it, and even after it's been deprecated, we will support it for a few

2531

;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01

2532

2533

(defun* run-shell-command (control-string &rest args)

2534

"Interpolate ARGS into CONTROL-STRING as if by FORMAT, and

2535

synchronously execute the result using a Bourne-compatible shell, with

2536

output to *VERBOSE-OUT*. Returns the shell's exit code."

2537

(let ((command (apply #'format nil control-string args)))

2538

(asdf-message "; $ ~A~%" command)

2539

2540

#+abcl

2541

(ext:run-shell-command command :output *verbose-out*)

2542

2543

#+allegro

2544

;; will this fail if command has embedded quotes - it seems to work

2545

(multiple-value-bind (stdout stderr exit-code)

2546

(excl.osi:command-output

2547

(format nil "~a -c \"~a\""

2548

#+mswindows "sh" #-mswindows "/bin/sh" command)

2549

:input nil :whole nil

2550

#+mswindows :show-window #+mswindows :hide)

2551

(asdf-message "~{~&; ~a~%~}~%" stderr)

2552

(asdf-message "~{~&; ~a~%~}~%" stdout)

2553

exit-code)

2554

2555

#+clisp ;XXX not exactly *verbose-out*, I know

2556

(or (ext:run-shell-command command :output :terminal :wait t) 0)

2557

2558

#+clozure

2559

(nth-value 1

2560

(ccl:external-process-status

2561

(ccl:run-program "/bin/sh" (list "-c" command)

2562

:input nil :output *verbose-out*

2563

:wait t)))

2564

2565

#+ecl ;; courtesy of Juan Jose Garcia Ripoll

2566

(si:system command)

2567

2568

#+gcl

2569

(lisp:system command)

2570

2571

#+lispworks

2572

(system:call-system-showing-output

2573

command

2574

:shell-type "/bin/sh"

2575

:show-cmd nil

2576

:prefix ""

2577

:output-stream *verbose-out*)

2578

2579

#+sbcl

2580

(sb-ext:process-exit-code

2581

(apply #'sb-ext:run-program

2582

#+win32 "sh" #-win32 "/bin/sh"

2583

(list "-c" command)

2584

:input nil :output *verbose-out*

2585

#+win32 '(:search t) #-win32 nil))

2586

2587

#+(or cmu scl)

2588

(ext:process-exit-code

2589

(ext:run-program

2590

"/bin/sh"

2591

(list "-c" command)

2592

:input nil :output *verbose-out*))

2593

2594

#-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)

2595

(error "RUN-SHELL-COMMAND not implemented for this Lisp")))

2596

2597

;;;; ---------------------------------------------------------------------------

2598

;;;; system-relative-pathname

2599

2600

(defmethod system-source-file ((system-name string))

2601

(system-source-file (find-system system-name)))

2602

(defmethod system-source-file ((system-name symbol))

2603

(system-source-file (find-system system-name)))

2604

2605

(defun* system-source-directory (system-designator)

2606

"Return a pathname object corresponding to the

2607

directory in which the system specification (.asd file) is

2608

located."

2609

(make-pathname :name nil

2610

:type nil

2611

:defaults (system-source-file system-designator)))

2612

2613

(defun* relativize-directory (directory)

2614

(cond

2615

((stringp directory)

2616

(list :relative directory))

2617

((eq (car directory) :absolute)

2618

(cons :relative (cdr directory)))

2619

(t

2620

directory)))

2621

2622

(defun* relativize-pathname-directory (pathspec)

2623

(let ((p (pathname pathspec)))

2624

(make-pathname

2625

:directory (relativize-directory (pathname-directory p))

2626

:defaults p)))

2627

2628

(defun* system-relative-pathname (system name &key type)

2629

(merge-pathnames*

2630

(coerce-pathname name :type type)

2631

(system-source-directory system)))

2632

2633

2634

;;; ---------------------------------------------------------------------------

2635

;;; implementation-identifier

2636

;;;

2637

;;; produce a string to identify current implementation.

2638

;;; Initially stolen from SLIME's SWANK, hacked since.

2639

2640

(defparameter *implementation-features*

2641

'((:abcl :armedbear)

2642

(:acl :allegro)

2643

(:mcl :digitool) ; before clozure, so it won't get preempted by ccl

2644

(:ccl :clozure)

2645

(:corman :cormanlisp)

2646

(:lw :lispworks)

2647

:clisp :cmu :ecl :gcl :sbcl :scl :symbolics))

2648

2649

(defparameter *os-features*

2650

'((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows

2651

(:solaris :sunos)

2652

(:linux :linux-target) ;; for GCL at least, must appear before :bsd.

2653

(:macosx :darwin :darwin-target :apple)

2654

:freebsd :netbsd :openbsd :bsd

2655

:unix

2656

:genera))

2657

2658

(defparameter *architecture-features*

2659

'((:amd64 :x86-64 :x86_64 :x8664-target)

2660

(:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)

2661

:hppa64

2662

:hppa

2663

(:ppc64 :ppc64-target)

2664

(:ppc32 :ppc32-target :ppc :powerpc)

2665

:sparc64

2666

(:sparc32 :sparc)

2667

(:arm :arm-target)

2668

(:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)

2669

:imach))

2670

2671

(defun* lisp-version-string ()

2672

(let ((s (lisp-implementation-version)))

2673

(declare (ignorable s))

2674

#+allegro (format nil

2675

"~A~A~A~A"

2676

excl::*common-lisp-version-number*

2677

;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox

2678

(if (eq excl:*current-case-mode*

2679

:case-sensitive-lower) "M" "A")

2680

;; Note if not using International ACL

2681

;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm

2682

(excl:ics-target-case

2683

(:-ics "8")

2684

(:+ics ""))

2685

(if (member :64bit *features*) "-64bit" ""))

2686

#+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)

2687

#+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)

2688

#+clozure (format nil "~d.~d-f~d" ; shorten for windows

2689

ccl::*openmcl-major-version*

2690

ccl::*openmcl-minor-version*

2691

(logand ccl::fasl-version #xFF))

2692

#+cmu (substitute #\- #\/ s)

2693

#+ecl (format nil "~A~@[-~A~]" s

2694

(let ((vcs-id (ext:lisp-implementation-vcs-id)))

2695

(when (>= (length vcs-id) 8)

2696

(subseq vcs-id 0 8))))

2697

#+gcl (subseq s (1+ (position #\space s)))

2698

#+genera (multiple-value-bind (major minor) (sct:get-system-version "System")

2699

(format nil "~D.~D" major minor))

2700

#+lispworks (format nil "~A~@[~A~]" s

2701

(when (member :lispworks-64bit *features*) "-64bit"))

2702

;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version

2703

#+mcl (subseq s 8) ; strip the leading "Version "

2704

#+(or cormanlisp sbcl scl) s

2705

#-(or allegro armedbear clisp clozure cmu cormanlisp

2706

ecl gcl genera lispworks mcl sbcl scl) s))

2707

2708

(defun* first-feature (features)

2709

(labels

2710

((fp (thing)

2711

(etypecase thing

2712

(symbol

2713

(let ((feature (find thing *features*)))

2714

(when feature (return-from fp feature))))

2715

;; allows features to be lists of which the first

2716

;; member is the "main name", the rest being aliases

2717

(cons

2718

(dolist (subf thing)

2719

(when (find subf *features*) (return-from fp (first thing))))))

2720

nil))

2721

(loop :for f :in features

2722

:when (fp f) :return :it)))

2723

2724

(defun* implementation-type ()

2725

(first-feature *implementation-features*))

2726

2727

(defun* implementation-identifier ()

2728

(labels

2729

((maybe-warn (value fstring &rest args)

2730

(cond (value)

2731

(t (apply #'warn fstring args)

2732

"unknown"))))

2733

(let ((lisp (maybe-warn (implementation-type)

2734

(compatfmt "~@<No implementation feature found in ~a.~@:>")

2735

*implementation-features*))

2736

(os (maybe-warn (first-feature *os-features*)

2737

(compatfmt "~@<No OS feature found in ~a.~@:>") *os-features*))

2738

(arch (or #-clisp

2739

(maybe-warn (first-feature *architecture-features*)

2740

(compatfmt "~@<No architecture feature found in ~a.~@:>")

2741

*architecture-features*)))

2742

(version (maybe-warn (lisp-version-string)

2743

"Don't know how to get Lisp implementation version.")))

2744

(substitute-if

2745

#\_ #'(lambda (x) (find x " /:\\(){}[]$#`'\""))

2746

(format nil "~(~a~@{~@[-~a~]~}~)" lisp version os arch)))))

2747

2748

2749

;;; ---------------------------------------------------------------------------

2750

;;; Generic support for configuration files

2751

2752

(defparameter *inter-directory-separator*

2753

#+asdf-unix #\:

2754

#-asdf-unix #\;)

2755

2756

(defun* user-homedir ()

2757

(truenamize (pathname-directory-pathname (user-homedir-pathname))))

2758

2759

(defun* try-directory-subpath (x sub &key type)

2760

(let* ((p (and x (ensure-directory-pathname x)))

2761

(tp (and p (probe-file* p)))

2762

(sp (and tp (merge-pathnames* (coerce-pathname sub :type type) p)))

2763

(ts (and sp (probe-file* sp))))

2764

(and ts (values sp ts))))

2765

(defun* user-configuration-directories ()

2766

(remove-if

2767

#'null

2768

(flet ((try (x sub) (try-directory-subpath x sub :type :directory)))

2769

`(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")

2770

,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")

2771

:for dir :in (split-string dirs :separator ":")

2772

:collect (try dir "common-lisp/"))

2773

#+asdf-windows

2774

,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")

2775

;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData

2776

,(try (getenv "APPDATA") "common-lisp/config/"))

2777

,(try (user-homedir) ".config/common-lisp/")))))

2778

(defun* system-configuration-directories ()

2779

(remove-if

2780

#'null

2781

(append

2782

#+asdf-windows

2783

(flet ((try (x sub) (try-directory-subpath x sub :type :directory)))

2784

`(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")

2785

;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData

2786

,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))

2787

#+asdf-unix

2788

(list #p"/etc/common-lisp/"))))

2789

(defun* in-first-directory (dirs x)

2790

(loop :for dir :in dirs

2791

:thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))

2792

(defun* in-user-configuration-directory (x)

2793

(in-first-directory (user-configuration-directories) x))

2794

(defun* in-system-configuration-directory (x)

2795

(in-first-directory (system-configuration-directories) x))

2796

2797

(defun* configuration-inheritance-directive-p (x)

2798

(let ((kw '(:inherit-configuration :ignore-inherited-configuration)))

2799

(or (member x kw)

2800

(and (length=n-p x 1) (member (car x) kw)))))

2801

2802

(defun* report-invalid-form (reporter &rest args)

2803

(etypecase reporter

2804

(null

2805

(apply 'error 'invalid-configuration args))

2806

(function

2807

(apply reporter args))

2808

((or symbol string)

2809

(apply 'error reporter args))

2810

(cons

2811

(apply 'apply (append reporter args)))))

2812

2813

(defvar *ignored-configuration-form* nil)

2814

2815

(defun* validate-configuration-form (form tag directive-validator

2816

&key location invalid-form-reporter)

2817

(unless (and (consp form) (eq (car form) tag))

2818

(setf *ignored-configuration-form* t)

2819

(report-invalid-form invalid-form-reporter :form form :location location)

2820

(return-from validate-configuration-form nil))

2821

(loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)

2822

:for directive :in (cdr form)

2823

:when (cond

2824

((configuration-inheritance-directive-p directive)

2825

(incf inherit) t)

2826

((eq directive :ignore-invalid-entries)

2827

(setf ignore-invalid-p t) t)

2828

((funcall directive-validator directive)

2829

t)

2830

(ignore-invalid-p

2831

nil)

2832

(t

2833

(setf *ignored-configuration-form* t)

2834

(report-invalid-form invalid-form-reporter :form directive :location location)

2835

nil))

2836

:do (push directive x)

2837

:finally

2838

(unless (= inherit 1)

2839

(report-invalid-form invalid-form-reporter

2840

:arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>")

2841

:inherit-configuration :ignore-inherited-configuration)))

2842

(return (nreverse x))))

2843

2844

(defun* validate-configuration-file (file validator &key description)

2845

(let ((forms (read-file-forms file)))

2846

(unless (length=n-p forms 1)

2847

(error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")

2848

description forms))

2849

(funcall validator (car forms) :location file)))

2850

2851

(defun* hidden-file-p (pathname)

2852

(equal (first-char (pathname-name pathname)) #\.))

2853

2854

(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)

2855

(apply 'directory pathname-spec

2856

(append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)

2857

#+clozure '(:follow-links nil)

2858

#+clisp '(:circle t :if-does-not-exist :ignore)

2859

#+(or cmu scl) '(:follow-links nil :truenamep nil)

2860

#+sbcl (when (find-symbol "RESOLVE-SYMLINKS" "SB-IMPL") '(:resolve-symlinks nil))))))

2861

2862

(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)

2863

"Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will

2864

be applied to the results to yield a configuration form. Current

2865

values of TAG include :source-registry and :output-translations."

2866

(let ((files (sort (ignore-errors

2867

(remove-if

2868

'hidden-file-p

2869

(directory* (make-pathname :name :wild :type "conf" :defaults directory))))

2870

#'string< :key #'namestring)))

2871

`(,tag

2872

,@(loop :for file :in files :append

2873

(loop :with ignore-invalid-p = nil

2874

:for form :in (read-file-forms file)

2875

:when (eq form :ignore-invalid-entries)

2876

:do (setf ignore-invalid-p t)

2877

:else

2878

:when (funcall validator form)

2879

:collect form

2880

:else

2881

:when ignore-invalid-p

2882

:do (setf *ignored-configuration-form* t)

2883

:else

2884

:do (report-invalid-form invalid-form-reporter :form form :location file)))

2885

:inherit-configuration)))

2886

2887

2888

;;; ---------------------------------------------------------------------------

2889

;;; asdf-output-translations

2890

;;;

2891

;;; this code is heavily inspired from

2892

;;; asdf-binary-translations, common-lisp-controller and cl-launch.

2893

;;; ---------------------------------------------------------------------------

2894

2895

(defvar *output-translations* ()

2896

"Either NIL (for uninitialized), or a list of one element,

2897

said element itself being a sorted list of mappings.

2898

Each mapping is a pair of a source pathname and destination pathname,

2899

and the order is by decreasing length of namestring of the source pathname.")

2900

2901

(defvar *user-cache*

2902

(flet ((try (x &rest sub) (and x `(,x ,@sub))))

2903

(or

2904

(try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)

2905

#+asdf-windows

2906

(try (getenv "APPDATA") "common-lisp" "cache" :implementation)

2907

'(:home ".cache" "common-lisp" :implementation))))

2908

(defvar *system-cache*

2909

;; No good default, plus there's a security problem

2910

;; with other users messing with such directories.

2911

*user-cache*)

2912

2913

(defun* output-translations ()

2914

(car *output-translations*))

2915

2916

(defun* (setf output-translations) (new-value)

2917

(setf *output-translations*

2918

(list

2919

(stable-sort (copy-list new-value) #'>

2920

:key #'(lambda (x)

2921

(etypecase (car x)

2922

((eql t) -1)

2923

(pathname

2924

(let ((directory (pathname-directory (car x))))

2925

(if (listp directory) (length directory) 0))))))))

2926

new-value)

2927

2928

(defun* output-translations-initialized-p ()

2929

(and *output-translations* t))

2930

2931

(defun* clear-output-translations ()

2932

"Undoes any initialization of the output translations.

2933

You might want to call that before you dump an image that would be resumed

2934

with a different configuration, so the configuration would be re-read then."

2935

(setf *output-translations* '())

2936

(values))

2937

2938

(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))

2939

(values (or null pathname) &optional))

2940

resolve-location))

2941

2942

(defun* resolve-relative-location-component (super x &key directory wilden)

2943

(let* ((r (etypecase x

2944

(pathname x)

2945

(string x)

2946

(cons

2947

(return-from resolve-relative-location-component

2948

(if (null (cdr x))

2949

(resolve-relative-location-component

2950

super (car x) :directory directory :wilden wilden)

2951

(let* ((car (resolve-relative-location-component

2952

super (car x) :directory t :wilden nil))

2953

(cdr (resolve-relative-location-component

2954

(merge-pathnames* car super) (cdr x)

2955

:directory directory :wilden wilden)))

2956

(merge-pathnames* cdr car)))))

2957

((eql :default-directory)

2958

(relativize-pathname-directory (default-directory)))

2959

((eql :*/) *wild-directory*)

2960

((eql :**/) *wild-inferiors*)

2961

((eql :*.*.*) *wild-file*)

2962

((eql :implementation) (implementation-identifier))

2963

((eql :implementation-type) (string-downcase (implementation-type)))

2964

#+asdf-unix

2965

((eql :uid) (princ-to-string (get-uid)))))

2966

(d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))

2967

(s (if (or (pathnamep x) (not wilden)) d (wilden d))))

2968

(when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))

2969

(error (compatfmt "~@<Pathname ~S is not relative to ~S~@:>") s super))

2970

(merge-pathnames* s super)))

2971

2972

(defvar *here-directory* nil

2973

"This special variable is bound to the currect directory during calls to

2974

PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here

2975

directive.")

2976

2977

(defun* resolve-absolute-location-component (x &key directory wilden)

2978

(let* ((r

2979

(etypecase x

2980

(pathname x)

2981

(string (if directory (ensure-directory-pathname x) (parse-namestring x)))

2982

(cons

2983

(return-from resolve-absolute-location-component

2984

(if (null (cdr x))

2985

(resolve-absolute-location-component

2986

(car x) :directory directory :wilden wilden)

2987

(let* ((car (resolve-absolute-location-component

2988

(car x) :directory t :wilden nil))

2989

(cdr (resolve-relative-location-component

2990

car (cdr x) :directory directory :wilden wilden)))

2991

(merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?

2992

((eql :root)

2993

;; special magic! we encode such paths as relative pathnames,

2994

;; but it means "relative to the root of the source pathname's host and device".

2995

(return-from resolve-absolute-location-component

2996

(let ((p (make-pathname :directory '(:relative))))

2997

(if wilden (wilden p) p))))

2998

((eql :home) (user-homedir))

2999

((eql :here)

3000

(resolve-location (or *here-directory*

3001

;; give semantics in the case of use interactively

3002

:default-directory)

3003

:directory t :wilden nil))

3004

((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))

3005

((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))

3006

((eql :default-directory) (default-directory))))

3007

(s (if (and wilden (not (pathnamep x)))

3008

(wilden r)

3009

r)))

3010

(unless (absolute-pathname-p s)

3011

(error (compatfmt "~@<Not an absolute pathname: ~3i~_~S~@:>") s))

3012

s))

3013

3014

(defun* resolve-location (x &key directory wilden)

3015

(if (atom x)

3016

(resolve-absolute-location-component x :directory directory :wilden wilden)

3017

(loop :with path = (resolve-absolute-location-component

3018

(car x) :directory (and (or directory (cdr x)) t)

3019

:wilden (and wilden (null (cdr x))))

3020

:for (component . morep) :on (cdr x)

3021

:for dir = (and (or morep directory) t)

3022

:for wild = (and wilden (not morep))

3023

:do (setf path (resolve-relative-location-component

3024

path component :directory dir :wilden wild))

3025

:finally (return path))))

3026

3027

(defun* location-designator-p (x)

3028

(flet ((absolute-component-p (c)

3029

(typep c '(or string pathname

3030

(member :root :home :here :user-cache :system-cache :default-directory))))

3031

(relative-component-p (c)

3032

(typep c '(or string pathname

3033

(member :default-directory :*/ :**/ :*.*.*

3034

:implementation :implementation-type

3035

#+asdf-unix :uid)))))

3036

(or (typep x 'boolean)

3037

(absolute-component-p x)

3038

(and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))

3039

3040

(defun* location-function-p (x)

3041

(and

3042

(consp x)

3043

(length=n-p x 2)

3044

(or (and (equal (first x) :function)

3045

(typep (second x) 'symbol))

3046

(and (equal (first x) 'lambda)

3047

(cddr x)

3048

(length=n-p (second x) 2)))))

3049

3050

(defun* validate-output-translations-directive (directive)

3051

(or (member directive '(:enable-user-cache :disable-cache nil))

3052

(and (consp directive)

3053

(or (and (length=n-p directive 2)

3054

(or (and (eq (first directive) :include)

3055

(typep (second directive) '(or string pathname null)))

3056

(and (location-designator-p (first directive))

3057

(or (location-designator-p (second directive))

3058

(location-function-p (second directive))))))

3059

(and (length=n-p directive 1)

3060

(location-designator-p (first directive)))))))

3061

3062

(defun* validate-output-translations-form (form &key location)

3063

(validate-configuration-form

3064

form

3065

:output-translations

3066

'validate-output-translations-directive

3067

:location location :invalid-form-reporter 'invalid-output-translation))

3068

3069

(defun* validate-output-translations-file (file)

3070

(validate-configuration-file

3071

file 'validate-output-translations-form :description "output translations"))

3072

3073

(defun* validate-output-translations-directory (directory)

3074

(validate-configuration-directory

3075

directory :output-translations 'validate-output-translations-directive

3076

:invalid-form-reporter 'invalid-output-translation))

3077

3078

(defun* parse-output-translations-string (string &key location)

3079

(cond

3080

((or (null string) (equal string ""))

3081

'(:output-translations :inherit-configuration))

3082

((not (stringp string))

3083

(error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))

3084

((eql (char string 0) #\")

3085

(parse-output-translations-string (read-from-string string) :location location))

3086

((eql (char string 0) #\()

3087

(validate-output-translations-form (read-from-string string) :location location))

3088

(t

3089

(loop

3090

:with inherit = nil

3091

:with directives = ()

3092

:with start = 0

3093

:with end = (length string)

3094

:with source = nil

3095

:for i = (or (position *inter-directory-separator* string :start start) end) :do

3096

(let ((s (subseq string start i)))

3097

(cond

3098

(source

3099

(push (list source (if (equal "" s) nil s)) directives)

3100

(setf source nil))

3101

((equal "" s)

3102

(when inherit

3103

(error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")

3104

string))

3105

(setf inherit t)

3106

(push :inherit-configuration directives))

3107

(t

3108

(setf source s)))

3109

(setf start (1+ i))

3110

(when (> start end)

3111

(when source

3112

(error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")

3113

string))

3114

(unless inherit

3115

(push :ignore-inherited-configuration directives))

3116

(return `(:output-translations ,@(nreverse directives)))))))))

3117

3118

(defparameter *default-output-translations*

3119

'(environment-output-translations

3120

user-output-translations-pathname

3121

user-output-translations-directory-pathname

3122

system-output-translations-pathname

3123

system-output-translations-directory-pathname))

3124

3125

(defun* wrapping-output-translations ()

3126

`(:output-translations

3127

;; Some implementations have precompiled ASDF systems,

3128

;; so we must disable translations for implementation paths.

3129

#+sbcl ,(let ((h (getenv "SBCL_HOME")))

3130

(when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))

3131

#+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system

3132

#+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system

3133

;; All-import, here is where we want user stuff to be:

3134

:inherit-configuration

3135

;; These are for convenience, and can be overridden by the user:

3136

#+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))

3137

#+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))

3138

;; We enable the user cache by default, and here is the place we do:

3139

:enable-user-cache))

3140

3141

(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))

3142

(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))

3143

3144

(defun* user-output-translations-pathname ()

3145

(in-user-configuration-directory *output-translations-file* ))

3146

(defun* system-output-translations-pathname ()

3147

(in-system-configuration-directory *output-translations-file*))

3148

(defun* user-output-translations-directory-pathname ()

3149

(in-user-configuration-directory *output-translations-directory*))

3150

(defun* system-output-translations-directory-pathname ()

3151

(in-system-configuration-directory *output-translations-directory*))

3152

(defun* environment-output-translations ()

3153

(getenv "ASDF_OUTPUT_TRANSLATIONS"))

3154

3155

(defgeneric* process-output-translations (spec &key inherit collect))

3156

(declaim (ftype (function (t &key (:collect (or symbol function))) t)

3157

inherit-output-translations))

3158

(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)

3159

process-output-translations-directive))

3160

3161

(defmethod process-output-translations ((x symbol) &key

3162

(inherit *default-output-translations*)

3163

collect)

3164

(process-output-translations (funcall x) :inherit inherit :collect collect))

3165

(defmethod process-output-translations ((pathname pathname) &key inherit collect)

3166

(cond

3167

((directory-pathname-p pathname)

3168

(process-output-translations (validate-output-translations-directory pathname)

3169

:inherit inherit :collect collect))

3170

((probe-file* pathname)

3171

(process-output-translations (validate-output-translations-file pathname)

3172

:inherit inherit :collect collect))

3173

(t

3174

(inherit-output-translations inherit :collect collect))))

3175

(defmethod process-output-translations ((string string) &key inherit collect)

3176

(process-output-translations (parse-output-translations-string string)

3177

:inherit inherit :collect collect))

3178

(defmethod process-output-translations ((x null) &key inherit collect)

3179

(declare (ignorable x))

3180

(inherit-output-translations inherit :collect collect))

3181

(defmethod process-output-translations ((form cons) &key inherit collect)

3182

(dolist (directive (cdr (validate-output-translations-form form)))

3183

(process-output-translations-directive directive :inherit inherit :collect collect)))

3184

3185

(defun* inherit-output-translations (inherit &key collect)

3186

(when inherit

3187

(process-output-translations (first inherit) :collect collect :inherit (rest inherit))))

3188

3189

(defun* process-output-translations-directive (directive &key inherit collect)

3190

(if (atom directive)

3191

(ecase directive

3192

((:enable-user-cache)

3193

(process-output-translations-directive '(t :user-cache) :collect collect))

3194

((:disable-cache)

3195

(process-output-translations-directive '(t t) :collect collect))

3196

((:inherit-configuration)

3197

(inherit-output-translations inherit :collect collect))

3198

((:ignore-inherited-configuration :ignore-invalid-entries nil)

3199

nil))

3200

(let ((src (first directive))

3201

(dst (second directive)))

3202

(if (eq src :include)

3203

(when dst

3204

(process-output-translations (pathname dst) :inherit nil :collect collect))

3205

(when src

3206

(let ((trusrc (or (eql src t)

3207

(let ((loc (resolve-location src :directory t :wilden t)))

3208

(if (absolute-pathname-p loc) (truenamize loc) loc)))))

3209

(cond

3210

((location-function-p dst)

3211

(funcall collect

3212

(list trusrc

3213

(if (symbolp (second dst))

3214

(fdefinition (second dst))

3215

(eval (second dst))))))

3216

((eq dst t)

3217

(funcall collect (list trusrc t)))

3218

(t

3219

(let* ((trudst (make-pathname

3220

:defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))

3221

(wilddst (merge-pathnames* *wild-file* trudst)))

3222

(funcall collect (list wilddst t))

3223

(funcall collect (list trusrc trudst)))))))))))

3224

3225

(defun* compute-output-translations (&optional parameter)

3226

"read the configuration, return it"

3227

(remove-duplicates

3228

(while-collecting (c)

3229

(inherit-output-translations

3230

`(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))

3231

:test 'equal :from-end t))

3232

3233

(defvar *output-translations-parameter* nil)

3234

3235

(defun* initialize-output-translations (&optional (parameter *output-translations-parameter*))

3236

"read the configuration, initialize the internal configuration variable,

3237

return the configuration"

3238

(setf *output-translations-parameter* parameter

3239

(output-translations) (compute-output-translations parameter)))

3240

3241

(defun* disable-output-translations ()

3242

"Initialize output translations in a way that maps every file to itself,

3243

effectively disabling the output translation facility."

3244

(initialize-output-translations

3245

'(:output-translations :disable-cache :ignore-inherited-configuration)))

3246

3247

;; checks an initial variable to see whether the state is initialized

3248

;; or cleared. In the former case, return current configuration; in

3249

;; the latter, initialize. ASDF will call this function at the start

3250

;; of (asdf:find-system).

3251

(defun* ensure-output-translations ()

3252

(if (output-translations-initialized-p)

3253

(output-translations)

3254

(initialize-output-translations)))

3255

3256

(defun* translate-pathname* (path absolute-source destination &optional root source)

3257

(declare (ignore source))

3258

(cond

3259

((functionp destination)

3260

(funcall destination path absolute-source))

3261

((eq destination t)

3262

path)

3263

((not (pathnamep destination))

3264

(error "Invalid destination"))

3265

((not (absolute-pathname-p destination))

3266

(translate-pathname path absolute-source (merge-pathnames* destination root)))

3267

(root

3268

(translate-pathname (directorize-pathname-host-device path) absolute-source destination))

3269

(t

3270

(translate-pathname path absolute-source destination))))

3271

3272

(defun* apply-output-translations (path)

3273

(etypecase path

3274

(logical-pathname

3275

path)

3276

((or pathname string)

3277

(ensure-output-translations)

3278

(loop :with p = (truenamize path)

3279

:for (source destination) :in (car *output-translations*)

3280

:for root = (when (or (eq source t)

3281

(and (pathnamep source)

3282

(not (absolute-pathname-p source))))

3283

(pathname-root p))

3284

:for absolute-source = (cond

3285

((eq source t) (wilden root))

3286

(root (merge-pathnames* source root))

3287

(t source))

3288

:when (or (eq source t) (pathname-match-p p absolute-source))

3289

:return (translate-pathname* p absolute-source destination root source)

3290

:finally (return p)))))

3291

3292

(defmethod output-files :around (operation component)

3293

"Translate output files, unless asked not to"

3294

(declare (ignorable operation component))

3295

(values

3296

(multiple-value-bind (files fixedp) (call-next-method)

3297

(if fixedp

3298

files

3299

(mapcar #'apply-output-translations files)))

3300

t))

3301

3302

(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)

3303

(or output-file

3304

(apply-output-translations

3305

(apply 'compile-file-pathname

3306

(truenamize (lispize-pathname input-file))

3307

keys))))

3308

3309

(defun* tmpize-pathname (x)

3310

(make-pathname

3311

:name (format nil "ASDF-TMP-~A" (pathname-name x))

3312

:defaults x))

3313

3314

(defun* delete-file-if-exists (x)

3315

(when (and x (probe-file* x))

3316

(delete-file x)))

3317

3318

(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)

3319

(let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))

3320

(tmp-file (tmpize-pathname output-file))

3321

(status :error))

3322

(multiple-value-bind (output-truename warnings-p failure-p)

3323

(apply 'compile-file input-file :output-file tmp-file keys)

3324

(cond

3325

(failure-p

3326

(setf status *compile-file-failure-behaviour*))

3327

(warnings-p

3328

(setf status *compile-file-warnings-behaviour*))

3329

(t

3330

(setf status :success)))

3331

(ecase status

3332

((:success :warn :ignore)

3333

(delete-file-if-exists output-file)

3334

(when output-truename

3335

(rename-file output-truename output-file)

3336

(setf output-truename output-file)))

3337

(:error

3338

(delete-file-if-exists output-truename)

3339

(setf output-truename nil)))

3340

(values output-truename warnings-p failure-p))))

3341

3342

#+abcl

3343

(defun* translate-jar-pathname (source wildcard)

3344

(declare (ignore wildcard))

3345

(let* ((p (pathname (first (pathname-device source))))

3346

(root (format nil "/___jar___file___root___/~@[~A/~]"

3347

(and (find :windows *features*)

3348

(pathname-device p)))))

3349

(apply-output-translations

3350

(merge-pathnames*

3351

(relativize-pathname-directory source)

3352

(merge-pathnames*

3353

(relativize-pathname-directory (ensure-directory-pathname p))

3354

root)))))

3355

3356

;;;; -----------------------------------------------------------------

3357

;;;; Compatibility mode for ASDF-Binary-Locations

3358

3359

(defmethod operate :before (operation-class system &rest args &key &allow-other-keys)

3360

(declare (ignorable operation-class system args))

3361

(when (find-symbol* '#:output-files-for-system-and-operation :asdf)

3362

(error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.

3363

ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,

3364

which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,

3365

and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.

3366

In case you insist on preserving your previous A-B-L configuration, but

3367

do not know how to achieve the same effect with A-O-T, you may use function

3368

ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;

3369

call that function where you would otherwise have loaded and configured A-B-L.")))

3370

3371

(defun* enable-asdf-binary-locations-compatibility

3372

(&key

3373

(centralize-lisp-binaries nil)

3374

(default-toplevel-directory

3375

;; Use ".cache/common-lisp" instead ???

3376

(merge-pathnames* (make-pathname :directory '(:relative ".fasls"))

3377

(user-homedir)))

3378

(include-per-user-information nil)

3379

(map-all-source-files (or #+(or ecl clisp) t nil))

3380

(source-to-target-mappings nil))

3381

#+(or ecl clisp)

3382

(when (null map-all-source-files)

3383

(error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))

3384

(let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))

3385

(mapped-files (if map-all-source-files *wild-file*

3386

(make-pathname :name :wild :version :wild :type fasl-type)))

3387

(destination-directory

3388

(if centralize-lisp-binaries

3389

`(,default-toplevel-directory

3390

,@(when include-per-user-information

3391

(cdr (pathname-directory (user-homedir))))

3392

:implementation ,*wild-inferiors*)

3393

`(:root ,*wild-inferiors* :implementation))))

3394

(initialize-output-translations

3395

`(:output-translations

3396

,@source-to-target-mappings

3397

((:root ,*wild-inferiors* ,mapped-files)

3398

(,@destination-directory ,mapped-files))

3399

(t t)

3400

:ignore-inherited-configuration))))

3401

3402

;;;; -----------------------------------------------------------------

3403

;;;; Windows shortcut support. Based on:

3404

;;;;

3405

;;;; Jesse Hager: The Windows Shortcut File Format.

3406

;;;; http://www.wotsit.org/list.asp?fc=13

3407

3408

#+(and asdf-windows (not clisp))

3409

(progn

3410

(defparameter *link-initial-dword* 76)

3411

(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))

3412

3413

(defun* read-null-terminated-string (s)

3414

(with-output-to-string (out)

3415

(loop :for code = (read-byte s)

3416

:until (zerop code)

3417

:do (write-char (code-char code) out))))

3418

3419

(defun* read-little-endian (s &optional (bytes 4))

3420

(loop

3421

:for i :from 0 :below bytes

3422

:sum (ash (read-byte s) (* 8 i))))

3423

3424

(defun* parse-file-location-info (s)

3425

(let ((start (file-position s))

3426

(total-length (read-little-endian s))

3427

(end-of-header (read-little-endian s))

3428

(fli-flags (read-little-endian s))

3429

(local-volume-offset (read-little-endian s))

3430

(local-offset (read-little-endian s))

3431

(network-volume-offset (read-little-endian s))

3432

(remaining-offset (read-little-endian s)))

3433

(declare (ignore total-length end-of-header local-volume-offset))

3434

(unless (zerop fli-flags)

3435

(cond

3436

((logbitp 0 fli-flags)

3437

(file-position s (+ start local-offset)))

3438

((logbitp 1 fli-flags)

3439

(file-position s (+ start

3440

network-volume-offset

3441

#x14))))

3442

(concatenate 'string

3443

(read-null-terminated-string s)

3444

(progn

3445

(file-position s (+ start remaining-offset))

3446

(read-null-terminated-string s))))))

3447

3448

(defun* parse-windows-shortcut (pathname)

3449

(with-open-file (s pathname :element-type '(unsigned-byte 8))

3450

(handler-case

3451

(when (and (= (read-little-endian s) *link-initial-dword*)

3452

(let ((header (make-array (length *link-guid*))))

3453

(read-sequence header s)

3454

(equalp header *link-guid*)))

3455

(let ((flags (read-little-endian s)))

3456

(file-position s 76) ;skip rest of header

3457

(when (logbitp 0 flags)

3458

;; skip shell item id list

3459

(let ((length (read-little-endian s 2)))

3460

(file-position s (+ length (file-position s)))))

3461

(cond

3462

((logbitp 1 flags)

3463

(parse-file-location-info s))

3464

(t

3465

(when (logbitp 2 flags)

3466

;; skip description string

3467

(let ((length (read-little-endian s 2)))

3468

(file-position s (+ length (file-position s)))))

3469

(when (logbitp 3 flags)

3470

;; finally, our pathname

3471

(let* ((length (read-little-endian s 2))

3472

(buffer (make-array length)))

3473

(read-sequence buffer s)

3474

(map 'string #'code-char buffer)))))))

3475

(end-of-file ()

3476

nil)))))

3477

3478

;;;; -----------------------------------------------------------------

3479

;;;; Source Registry Configuration, by Francois-Rene Rideau

3480

;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918

3481

3482

;; Using ack 1.2 exclusions

3483

(defvar *default-source-registry-exclusions*

3484

'(".bzr" ".cdv"

3485

;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards

3486

".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"

3487

"_sgbak" "autom4te.cache" "cover_db" "_build"

3488

"debian")) ;; debian often build stuff under the debian directory... BAD.

3489

3490

(defvar *source-registry-exclusions* *default-source-registry-exclusions*)

3491

3492

(defvar *source-registry* ()

3493

"Either NIL (for uninitialized), or a list of one element,

3494

said element itself being a list of directory pathnames where to look for .asd files")

3495

3496

(defun* source-registry ()

3497

(car *source-registry*))

3498

3499

(defun* (setf source-registry) (new-value)

3500

(setf *source-registry* (list new-value))

3501

new-value)

3502

3503

(defun* source-registry-initialized-p ()

3504

(and *source-registry* t))

3505

3506

(defun* clear-source-registry ()

3507

"Undoes any initialization of the source registry.

3508

You might want to call that before you dump an image that would be resumed

3509

with a different configuration, so the configuration would be re-read then."

3510

(setf *source-registry* '())

3511

(values))

3512

3513

(defparameter *wild-asd*

3514

(make-pathname :directory nil :name :wild :type "asd" :version :newest))

3515

3516

(defun directory-has-asd-files-p (directory)

3517

(ignore-errors

3518

(and (directory* (merge-pathnames* *wild-asd* directory)) t)))

3519

3520

(defun subdirectories (directory)

3521

(let* ((directory (ensure-directory-pathname directory))

3522

#-(or cormanlisp genera)

3523

(wild (merge-pathnames*

3524

#-(or abcl allegro lispworks scl)

3525

*wild-directory*

3526

#+(or abcl allegro lispworks scl) "*.*"

3527

directory))

3528

(dirs

3529

#-(or cormanlisp genera)

3530

(ignore-errors

3531

(directory* wild . #.(or #+clozure '(:directories t :files nil)

3532

#+mcl '(:directories t))))

3533

#+cormanlisp (cl::directory-subdirs directory)

3534

#+genera (fs:directory-list directory))

3535

#+(or abcl allegro genera lispworks scl)

3536

(dirs (remove-if-not #+abcl #'extensions:probe-directory

3537

#+allegro #'excl:probe-directory

3538

#+lispworks #'lw:file-directory-p

3539

#+genera #'(lambda (x) (getf (cdr x) :directory))

3540

#-(or abcl allegro genera lispworks) #'directory-pathname-p

3541

dirs))

3542

#+genera

3543

(dirs (mapcar #'(lambda (x) (ensure-directory-pathname (first x))) dirs)))

3544

dirs))

3545

3546

(defun collect-sub*directories (directory collectp recursep collector)

3547

(when (funcall collectp directory)

3548

(funcall collector directory))

3549

(dolist (subdir (subdirectories directory))

3550

(when (funcall recursep subdir)

3551

(collect-sub*directories subdir collectp recursep collector))))

3552

3553

(defun collect-sub*directories-with-asd

3554

(directory &key

3555

(exclude *default-source-registry-exclusions*)

3556

collect)

3557

(collect-sub*directories

3558