Skip to content
Snippets Groups Projects
Commit cc1db98b authored by Daniel Barlow's avatar Daniel Barlow
Browse files

- (:use "CL"))

 +  (:use :cl))
may help people with odd read/print case (or ACL "modern" mode users)
 -    "telent:asdf;systems;"))
 +    #+nil "telent:asdf;systems;"))
clisp objects to this
fix pathname merging in internal-find-system so it works with CMUCL's
rather odd *default-pathname-defaults*
add a run-shell-command dfefintion for cmucl
parent 371749bf
No related branches found
No related tags found
No related merge requests found
...@@ -35,7 +35,7 @@ ...@@ -35,7 +35,7 @@
#:missing-dependency #:missing-dependency
#:circular-dependency ; errors #:circular-dependency ; errors
) )
(:use "CL")) (:use :cl))
(in-package #:asdf) (in-package #:asdf)
...@@ -56,14 +56,15 @@ and NIL NAME and TYPE components" ...@@ -56,14 +56,15 @@ and NIL NAME and TYPE components"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; problems ;; problems
(define-condition system-definition-error (error) (define-condition system-definition-error (error))
(define-condition formatted-system-definition-error (system-definition-error)
((format-control :initarg :format-control :reader format-control) ((format-control :initarg :format-control :reader format-control)
(format-arguments :initarg :format-arguments :reader format-arguments)) (format-arguments :initarg :format-arguments :reader format-arguments))
(:report (lambda (c s) (:report (lambda (c s)
(apply #'format s (format-control c) (format-arguments c))))) (apply #'format s (format-control c) (format-arguments c)))))
(defun sysdef-error (format &rest arguments) (defun sysdef-error (format &rest arguments)
(error 'system-definition-error :format-control format :format-arguments arguments)) (error 'formatted-system-definition-error :format-control format :format-arguments arguments))
(define-condition circular-dependency (system-definition-error) (define-condition circular-dependency (system-definition-error)
((components :initarg :components))) ((components :initarg :components)))
...@@ -440,7 +441,7 @@ system.")) ...@@ -440,7 +441,7 @@ system."))
(defparameter *central-registry* (defparameter *central-registry*
'(*default-pathname-defaults* '(*default-pathname-defaults*
"/home/dan/src/sourceforge/cclan/asdf/systems/" "/home/dan/src/sourceforge/cclan/asdf/systems/"
"telent:asdf;systems;")) #+nil "telent:asdf;systems;"))
(defun internal-find-system (name) (defun internal-find-system (name)
...@@ -449,11 +450,10 @@ system.")) ...@@ -449,11 +450,10 @@ system."))
(on-disk (on-disk
(dolist (dir *central-registry*) (dolist (dir *central-registry*)
(let* ((defaults (eval dir)) (let* ((defaults (eval dir))
(file (merge-pathnames (file (make-pathname
(make-pathname :case :common :name name :type "ASD"
:case :common :name name :type "ASD" :defaults defaults
:defaults defaults) :version :newest)))
defaults)))
(if (probe-file file) (return file)))) )) (if (probe-file file) (return file)))) ))
(when (and on-disk (when (and on-disk
(or (not in-memory) (or (not in-memory)
...@@ -539,11 +539,6 @@ Returns the new tree (which probably shares structure with the old one)" ...@@ -539,11 +539,6 @@ Returns the new tree (which probably shares structure with the old one)"
(maybe-add-tree new-tree (car op-tree) (car op) c)))))) (maybe-add-tree new-tree (car op-tree) (car op) c))))))
new-tree)) new-tree))
;;; ew
#.(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) (defun remove-keys (key-names args)
(loop for ( name val ) on args by #'cddr (loop for ( name val ) on args by #'cddr
...@@ -553,15 +548,15 @@ Returns the new tree (which probably shares structure with the old one)" ...@@ -553,15 +548,15 @@ Returns the new tree (which probably shares structure with the old one)"
(defun parse-component-form (parent options) (defun parse-component-form (parent options)
(destructuring-bind (destructuring-bind
#.`(type name &rest rest &key (type name &rest rest &key
;; the following list of keywords is reproduced below in the ;; the following list of keywords is reproduced below in the
;; remove-keys frm. important to keep them in sync ;; remove-keys form. important to keep them in sync
components pathname default-component-class components pathname default-component-class
perform explain output-files operation-done-p perform explain output-files operation-done-p
depends-on serialize in-order-to depends-on serialize in-order-to
;; list ends ;; list ends
&allow-other-keys) options &allow-other-keys) options
(declare (ignore serialize)) (declare (ignore serialize))
;; XXX add dependencies for serialized subcomponents ;; XXX add dependencies for serialized subcomponents
(let* ((other-args (remove-keys (let* ((other-args (remove-keys
'(components pathname default-component-class '(components pathname default-component-class
...@@ -624,4 +619,17 @@ output to *trace-output*. Returns the shell's exit code." ...@@ -624,4 +619,17 @@ output to *trace-output*. Returns the shell's exit code."
(list "-c" command) (list "-c" command)
:input nil :output *trace-output*)))) :input nil :output *trace-output*))))
#+cmu
(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)
(ext:process-exit-code
(ext:run-program
"/bin/sh"
(list "-c" command)
:input nil :output *trace-output*))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment