Newer
Older
;;; the problem with writing a defsystem replacement is bootstrapping:
;;; we can't use defsystem to compile it. Hence, all in one file
(defpackage #:asdf
(:export #:defsystem #:oos #:find-system #:run-shell-command
#:find-component ; miscellaneous
#:compile-op #:load-op #:test-system-version
#:operation ; operations
#:output-files #:perform ; operation methods
#:operation-done-p #:explain
#:component #:module #:source-file
#:c-source-file #:cl-source-file #:java-source-file
#:module ; components
#:unix-dso
#:module-components ; component accessors
#:component-pathname
#:component-relative-pathname
#:component-name
#:component-version
#:component-depends-on
#:*component-parent-pathname* ; variables
#:*central-registry*
#:operation-error #:compile-failed #:compile-warned
#:system-definition-error #:system-not-found
#:circular-dependency ; errors
(in-package #:asdf)
(proclaim '(optimize (debug 3)))
(declaim (optimize (debug 3)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utility stuff
(defmacro aif (test then else) `(let ((it ,test)) (if it ,then ,else)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; problems
(define-condition system-definition-error (error)
((format-control :initarg :format-control :reader format-control)
(format-arguments :initarg :format-arguments :reader format-arguments))
(:report (lambda (c s)
(apply #'format s (format-control c) (format-arguments c)))))
(defun sysdef-error (format &rest arguments)
(error 'system-definition-error :format-control format :format-arguments arguments))
(define-condition circular-dependency (system-definition-error)
((components :initarg :components)))
(define-condition missing-dependency (system-definition-error)
((requires :initarg :requires :reader requires)
(required-by :initarg :required-by :reader required-by))
(:report (lambda (c s)
(format s "unsatisfied dependency: component ~S requires ~S"
(required-by c) (requires c)))))
(define-condition system-not-found (system-definition-error)
((name :initform "(unnamed)" :reader system-name :initarg :name))
(:report (lambda (c s)
(format s "System ~S not found"
(system-name c)))))
(define-condition operation-error (error)
((component :reader error-component :initarg :component)
(operation :reader error-operation :initarg :operation))
(:report (lambda (c s)
(format s "Erred while invoking ~A on ~A"
(error-operation c) (error-component c)))))
(define-condition compile-failed (operation-error) ())
(define-condition compile-warned (operation-error) ())
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; components
(defclass component ()
((name :type string :accessor component-name :initarg :name :documentation
"Component name, restricted to portable pathname characters")
(version :accessor component-version :initarg :version)
(in-order-to :initform nil :initarg :in-order-to)
;; no direct accessor for pathname, we do this as a method to allow
;; it to default in funky ways if not supplied
;; (:pathname is actually a really bad choice of name for this slot,
;; because quite often that's not what we actually use it for)
(defun string-unix-common-casify (string &key (start 0) end)
"Converts a string assumed local to a Unix filesystem into its
:common :case partner."
(unless end
(setf end (length string)))
(let ((result (copy-seq string)))
(cond
((every (lambda (x) (or (upper-case-p x) (not (alpha-char-p x)))) (subseq string start end))
(nstring-downcase result :start start :end end))
((every (lambda (x) (or (lower-case-p x) (not (alpha-char-p x)))) (subseq string start end))
(nstring-upcase result :start start :end end))
(t result))))
(defgeneric component-pathname (component)
(:documentation "Extracts the pathname applicable for a particular component."))
(defmethod component-pathname ((component component))
(let ((*default-pathname-defaults* *component-parent-pathname*))
(if (slot-boundp component 'pathname)
(let ((p (slot-value component 'pathname)))
(cond ((pathnamep p)
(merge-pathnames p))
((and (stringp p) (> (length p) 0))
((and (stringp p) (= (length p) 0))
*component-parent-pathname*)
(t
(warn ":pathname argument to ~A is not a pathname designator. Ignoring it" component)
(merge-pathnames (component-relative-pathname component)))))
(merge-pathnames (component-relative-pathname component)))))
(defmethod print-object ((c component) stream)
(print-unreadable-object (c stream :type t :identity t)
(ignore-errors
(prin1 (component-name c) stream))))
(defclass module (component)
((components :accessor module-components :initarg :components)
(default-component-class :accessor module-default-component-class
:initform 'cl-source-file :initarg :default-component-class)))
(defmethod component-relative-pathname ((component module))
(make-pathname :directory `(:relative ,(component-name component))
:host (pathname-host *component-parent-pathname*)))
(defgeneric find-component (module name)
(:documentation "Finds the component with name NAME present in the
MODULE module; if MODULE is nil, then the component is assumed to be a
system."))
(defmethod find-component ((module module) name)
(if (slot-boundp module 'components)
(find name (module-components module)
:test #'equal :key #'component-name)))
;;; a component with no parent is a system
(defmethod find-component ((module (eql nil)) name)
(find-system name))
(defclass source-file (component) ())
(defclass cl-source-file (source-file) ())
;;; a reversible registry that lets us query class <-> extension
(defvar *known-extensions*
'(("lisp" . cl-source-file)
("c" . c-source-file)
("java" . java-source-file)))
(defmethod component-relative-pathname ((component source-file))
(make-pathname :name (string-unix-common-casify (component-name component))
:type (string-unix-common-casify (car (rassoc (class-name (class-of component))
*known-extensions*)))
:case :common))
(defclass c-source-file (source-file) ())
(defclass java-source-file (source-file) ())
;;; XXX we don't need the first of these if we have the second, probably
(defvar *component-parent-pathname*)
(defvar *component-parent*)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; operations
;;; one of these is instantiated whenever (operate ) is called
(defclass operation ()
((forced-p :initform nil :initarg :force :accessor operation-forced-p )))
(defgeneric perform (operation system))
(defgeneric operation-done-p (operation system))
(defgeneric explain (operation system))
(defgeneric output-files (operation system))
(defvar *visited-nodes* nil)
(defvar *visiting-nodes* nil)
(defun node-for (o c)
(cons (class-name (class-of o)) c))
(defmethod visit-component ((o operation) (c component))
(pushnew (node-for o c) *visited-nodes* :test 'equal))
(defmethod component-visited-p ((o operation) (c component))
(member (node-for o c) *visited-nodes* :test 'equal))
(defmethod (setf visiting-component) (new-value (o operation) (c component))
(let ((node (node-for o c)))
(if new-value
(pushnew node *visiting-nodes* :test 'equal)
(setf *visiting-nodes* (remove node *visiting-nodes* :test 'equal)))))
(defmethod component-visiting-p ((o operation) (c component))
(let ((node (cons o c)))
(member node *visiting-nodes* :test 'equal)))
;;; this needs a new name. should be operation-needs-doing-p
(defmethod operation-done-p ((o operation) (c source-file))
(let ((binaries (output-files o c))
(source-write-date
(and (probe-file (component-pathname c))
(file-write-date (component-pathname c)))))
(and source-write-date binaries
(every (lambda (b)
(and (probe-file b)
(> (file-write-date b) source-write-date)))
binaries))))
(defmethod operation-done-p ((o operation) (c component))
;;; can't tell easily
nil)
(defgeneric component-depends-on (operation component))
(defmethod component-depends-on ((o operation) (c component))
(let ((raw-form
(cdr (assoc (class-name (class-of o))
(slot-value c 'in-order-to)))))
(loop for (op . components) in raw-form
append (mapcar (lambda (x) (list op x)) components))))
;;; So you look at this code and think "why isn't it a bunch of
;;; methods". And the answer is, because standard method combination
;;; runs :before methods most->least-specific, which is back to front
;;; for our purposes. And CLISP doesn't have non-standard method
;;; combinations, so let's keep it simple and aspire to portability
Christophe Rhodes
committed
;;; we enforce that function is a symbol to allow us to specialize on
;;; (eql 'perform) and (eql 'explain) for :before and :after
(defmethod traverse ((operation operation) (c component) (function symbol))
;; dependencies
(if (component-visiting-p operation c)
(error 'circular-dependency :components (list c)))
(setf (visiting-component operation c) t)
(loop for (prereq-op prereq-c) in
(component-depends-on operation c)
do (let ((op (if (subtypep (type-of operation) prereq-op)
operation
(make-instance prereq-op :force
(operation-forced-p operation))))
(dep-c (or (find-component *component-parent* prereq-c)
(error 'missing-dependency :required-by c
:requires prereq-c))))
(traverse op dep-c function)))
(let ((*component-parent-pathname* (component-pathname c))
(*component-parent* c))
(mapc (lambda (c) (traverse operation c function))
(module-components c))))
;; now the thing itself
(unless (component-visited-p operation c)
(if (or (operation-forced-p operation)
(not (operation-done-p operation c)))
(loop
(restart-case
(progn (funcall function operation c)
(return))
(retry-component ())
(skip-component () (return)))))
(setf (visiting-component operation c) nil)
(visit-component operation c)))
(defmethod perform ((operation operation) (c source-file))
"Required method PERFORM not implemented for operation ~A, component ~A"
(class-of operation) (class-of c)))
(defmethod perform ((operation operation) (c module))
nil)
(defmethod explain ((operation operation) (component component))
(format *trace-output* "~&;;; ~A on ~A~%"
operation component))
(defmethod output-files ((operation operation) (c component))
(sysdef-error "Required method OUTPUT-FILES not implemented for operation ~A"
(defclass compile-op (operation)
((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
(fail-on-error-p :initarg :fail-on-error
:accessor operation-fail-on-error-p :initform t)
(fail-on-warning-p :initarg :fail-on-warning
:accessor operation-fail-on-warning-p :initform nil)))
(defmethod perform ((operation compile-op) (c cl-source-file))
(let ((source-file (component-pathname c)))
(multiple-value-bind (output warnings-p failure-p)
(compile-file source-file)
(when (and warnings-p (operation-fail-on-warning-p operation))
(error 'compile-warned :component c :operation operation))
(when (and failure-p (operation-fail-on-error-p operation))
Christophe Rhodes
committed
(error 'compile-failed :component c :operation operation)))))
(defmethod output-files ((operation compile-op) (c cl-source-file))
(list (compile-file-pathname (component-pathname c))))
(defclass load-op (operation) ())
(defmethod perform ((o load-op) (c cl-source-file))
(let ((co (make-instance 'compile-op)))
(mapc nil #'load (output-files co c))))
(defmethod output-files ((operation load-op) (c component))
;;; compile-and-load-op
(defclass compile-and-load-op (load-op) ())
(defmethod component-depends-on ((operation compile-and-load-op) (c source-file))
(cons (list 'compile-op (component-name c))
(call-next-method)))
;;; test-system-version
(defclass test-system-version (operation)
((minimum :initarg :minimum :initform ""
:accessor test-system-version-minimum)))
;;; with apologies to christophe rhodes ...
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
(defun split (string &optional max (ws '(#\Space #\Tab)))
(flet ((is-ws (char) (find char ws)))
(nreverse
(let ((list nil) (start 0) (words 0) end)
(loop
(when (and max (>= words (1- max)))
(return (cons (subseq string start) list)))
(setf end (position-if #'is-ws string :start start))
(push (subseq string start end) list)
(incf words)
(unless end (return list))
(setf start (1+ end)))))))
(defmethod perform ((operation test-system-version) (c component))
(let ((x (mapcar #'parse-integer
(split (component-version c) nil '(#\.))))
(y (mapcar #'parse-integer
(split
(test-system-version-minimum operation) nil '(#\.)))))
(labels ((bigger (x y)
(cond ((not y) t)
((not x) nil)
((> (car x) (car y)) t)
((= (car x) (car y))
(bigger (cdr x) (cdr y))))))
(and (= (car x) (car y))
(or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; invoking operations
(defun oos (operation-class system &rest args)
(let ((op (apply #'make-instance operation-class args))
(*component-parent-pathname* *default-pathname-defaults*)
(*visiting-nodes* nil)
(*visited-nodes* nil)
(*component-parent* nil)
(system (if (typep system 'component) system (find-system system))))
(traverse op system 'perform)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; finding systems
(defvar *defined-systems* (make-hash-table :test 'equal))
(defparameter *central-registry*
'(*default-pathname-defaults*
"/home/dan/src/sourceforge/cclan/asdf/systems/"
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
"telent:asdf;systems;"))
(defun find-system (name)
(let* ((name (if (symbolp name) (symbol-name name) name))
(in-memory (gethash name *defined-systems*))
(on-disk
(dolist (dir *central-registry*)
(let* ((defaults (eval dir))
(file (merge-pathnames
(make-pathname
:case :common :name name :type "SYSTEM"
:defaults defaults)
defaults)))
(if (probe-file file) (return file)))) ))
(when (and on-disk
(or (not in-memory)
(< (car in-memory) (file-write-date on-disk))))
(let ((*package* (make-package (gensym (package-name #.*package*))
:use '("CL" "ASDF"))))
(format t ";;; Loading system definition from ~A into ~A~%"
on-disk *package*)
(load on-disk)))
(let ((in-memory (gethash name *defined-systems*)))
(if in-memory
(progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
(cdr in-memory))
(error 'system-not-found :name name)))))
(defun register-system (name system)
(format t "Registering ~A as ~A ~%" system name)
(setf (gethash (if (symbolp name) (symbol-name name) name) *defined-systems*)
(cons (get-universal-time) system)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; syntax
(defmacro defsystem (name &body options)
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
(destructuring-bind (&key pathname &allow-other-keys) options
`(register-system (quote ,name)
(parse-component-form nil '(:module ,name
:pathname
,(or pathname
*load-truename*
*default-pathname-defaults*)
,@options)))))
(defun class-for-type (parent type)
(let ((class (find-class (intern (symbol-name type) *package*) nil)))
(or class
(and (eq type :file)
(or (module-default-component-class parent)
(find-class 'cl-source-file)))
(sysdef-error "Don't recognize component type ~A" type))))
(defun maybe-add-tree (tree op1 op2 c)
"Add the node C at /OP1/OP2 in TREE, unless it's there already.
Returns the new tree (which probably shares structure with the old one)"
(let ((first-op-tree (assoc op1 tree)))
(if first-op-tree
(progn
(aif (assoc op2 (cdr first-op-tree))
(if (find c (cdr it))
nil
(setf (cdr it) (cons c (cdr it))))
(setf (cdr first-op-tree)
(acons op2 (list c) (cdr first-op-tree))))
tree)
(acons op1 (list (list op2 c)) tree))))
(defun union-of-dependencies (&rest deps)
(let ((new-tree nil))
(dolist (dep deps)
(dolist (op-tree dep)
(dolist (op (cdr op-tree))
(dolist (c (cdr op))
(setf new-tree
(maybe-add-tree new-tree (car op-tree) (car op) c))))))
new-tree))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *option-names*
'(components pathname default-component-class
perform explain output-files operation-done-p
depends-on serialize in-order-to)))
(defun remove-keys (key-names args)
(loop for ( name val ) on args by #'cddr
unless (member (symbol-name name) key-names
:key #'symbol-name :test 'equal)
append (list name val)))
(defun parse-component-form (parent options)
(destructuring-bind
#.`(type name &rest rest &key ,@*option-names*
&allow-other-keys) options
(declare (ignore serialize))
;; XXX add dependencies for serialized subcomponents
;; XXX reuse existing component instead of creating new one
(let* ((other-args (remove-keys *option-names* rest))
(ret
(apply
#'make-instance (class-for-type parent type)
:name name
:pathname pathname
:in-order-to (union-of-dependencies
in-order-to
`((compile-op (load-op ,@depends-on))))
other-args)))
(when (typep ret 'module)
(setf (module-default-component-class ret)
(or default-component-class
(and (typep parent 'module)
(module-default-component-class parent)))))
(when components
(setf (module-components ret)
(mapcar (lambda (x) (parse-component-form ret x)) components)))
;; XXX need to remove old methods
(loop for (n v) in `((perform ,perform) (explain ,explain)
(output-files ,output-files)
(operation-done-p ,operation-done-p))
when v
do (destructuring-bind (op qual (o c) &body body) v
(eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
,@body))))
ret)))
;;; run-shell-command functions for other lisp implementations will be
;;; gratefully accepted, if they do the same thing. If the docstring
;;; is ambiguous, send a bug report
#+sbcl
(defun run-shell-command (control-string &rest args)
"Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell, with
output to *trace-output*. Returns the shell's exit code."
(let ((command (apply #'format nil control-string args)))
(format *trace-output* "; $ ~A~%" command)
(sb-impl::process-exit-code
(sb-ext:run-program
"/bin/sh"
(list "-c" command)
:input nil :output *trace-output*))))