Commit 7f4d19be authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Release 1.373. Remove tabs in all lisp files.

parent faa8b05b
......@@ -33,7 +33,7 @@
;; Note how we use OUTPUT-FILES to find the binary locations
;; This allows the user to override the names.
(let* ((input (output-files o c))
(output (compile-file-pathname (first input) :type :fasl)))
(output (compile-file-pathname (first input) :type :fasl)))
(c:build-fasl output :lisp-files (remove "fas" input :key #'pathname-type :test #'string=))))
(defmethod perform ((o load-op) (c cl-source-file))
......@@ -83,11 +83,11 @@
((type :initform :program)))
(defmethod initialize-instance :after ((instance bundle-op) &rest initargs
&key (name-suffix nil name-suffix-p)
&allow-other-keys)
&key (name-suffix nil name-suffix-p)
&allow-other-keys)
(unless name-suffix-p
(setf (slot-value instance 'name-suffix)
(if (bundle-op-monolithic-p instance) "-mono" "")))
(if (bundle-op-monolithic-p instance) "-mono" "")))
(when (typep instance 'monolithic-bundle-op)
(destructuring-bind (&rest original-initargs
&key prologue-code epilogue-code &allow-other-keys)
......@@ -97,8 +97,8 @@
(monolithic-op-prologue-code instance) prologue-code
(monolithic-op-epilogue-code instance) epilogue-code)))
(setf (bundle-op-build-args instance)
(remove-keys '(type monolithic name-suffix)
(slot-value instance 'original-initargs))))
(remove-keys '(type monolithic name-suffix)
(slot-value instance 'original-initargs))))
(defvar *force-load-p* nil)
......@@ -114,12 +114,12 @@
(tree (traverse (make-instance 'load-op) system)))
(append
(loop for (op . component) in tree
when (and (typep op 'load-op)
(typep component filter-type)
(or (not filter-system) (eq (component-system component) filter-system)))
collect (progn
(when (eq component system) (setf include-self nil))
(cons operation component)))
when (and (typep op 'load-op)
(typep component filter-type)
(or (not filter-system) (eq (component-system component) filter-system)))
collect (progn
(when (eq component system) (setf include-self nil))
(cons operation component)))
(and include-self (list (cons operation system))))))
;;;
......@@ -150,8 +150,8 @@
;;;
(defmethod bundle-sub-operations ((o lib-op) c)
(gather-components 'compile-op c
:filter-system (and (not (bundle-op-monolithic-p o)) c)
:filter-type '(not system)))
:filter-system (and (not (bundle-op-monolithic-p o)) c)
:filter-type '(not system)))
;;;
;;; SHARED LIBRARIES
;;;
......@@ -173,7 +173,7 @@
(loop for (op . dep) in (bundle-sub-operations o c)
when (typep dep 'system)
collect (list (class-name (class-of op))
(component-name dep))))
(component-name dep))))
(defmethod component-depends-on ((o lib-op) (c system))
(list (list 'compile-op (component-name c))))
......@@ -187,9 +187,9 @@
(defmethod output-files ((o bundle-op) (c system))
(let ((name (concatenate 'base-string (component-name c)
(slot-value o 'name-suffix))))
(slot-value o 'name-suffix))))
(list (merge-pathnames (compile-file-pathname name :type (bundle-op-type o))
(component-relative-pathname c)))))
(component-relative-pathname c)))))
(defmethod output-files ((o fasl-op) (c system))
(loop for file in (call-next-method)
......@@ -203,10 +203,10 @@
(defmethod perform ((o bundle-op) (c system))
(let* ((object-files (remove "fas" (input-files o c) :key #'pathname-type :test #'string=))
(output (output-files o c)))
(output (output-files o c)))
(ensure-directories-exist (first output))
(apply #'c::builder (bundle-op-type o) (first output) :lisp-files object-files
(append (bundle-op-build-args o)
(append (bundle-op-build-args o)
(when (and (typep o 'monolithic-bundle-op)
(monolithic-op-prologue-code o))
`(:prologue-code ,(monolithic-op-prologue-code o)))
......@@ -229,8 +229,8 @@
(defun make-build (system &rest args &key (monolithic nil) (type :fasl)
&allow-other-keys)
(apply #'operate (select-operation monolithic type)
system
(remove-keys '(monolithic type) args)))
system
(remove-keys '(monolithic type) args)))
;;;
;;; LOAD-FASL-OP
......
......@@ -40,7 +40,7 @@ an immediate concern
(defpackage :asdf-install
(:use "CL" "SB-EXT" "SB-BSD-SOCKETS")
(:export #:*proxy* #:*cclan-mirror* #:*sbcl-home*
#:*verify-gpg-signatures* #:*locations*))
#:*verify-gpg-signatures* #:*locations*))
(defpackage :asdf-install-customize
(:use "CL" "SB-EXT" "SB-BSD-SOCKETS" "ASDF-INSTALL"))
......@@ -57,16 +57,16 @@ an immediate concern
;; want a directory
(let ((path (pathname name)))
(if (pathname-name path)
(merge-pathnames
(make-pathname :directory `(:relative ,(pathname-name path))
:name "")
path)
path)))
(merge-pathnames
(make-pathname :directory `(:relative ,(pathname-name path))
:name "")
path)
path)))
(defvar *sbcl-home* (directorify (posix-getenv "SBCL_HOME")))
(defvar *dot-sbcl*
(merge-pathnames (make-pathname :directory '(:relative ".sbcl"))
(user-homedir-pathname)))
(user-homedir-pathname)))
(defvar *verify-gpg-signatures* t)
......@@ -80,28 +80,28 @@ an immediate concern
(let* ((*package* (find-package :asdf-install-customize))
(file (probe-file (merge-pathnames
(make-pathname :name ".asdf-install")
(user-homedir-pathname)))))
(make-pathname :name ".asdf-install")
(user-homedir-pathname)))))
(when file (load file)))
(define-condition download-error (error)
((url :initarg :url :reader download-url)
(response :initarg :response :reader download-response))
(:report (lambda (c s)
(format s "Server responded ~A for GET ~A"
(download-response c) (download-url c)))))
(format s "Server responded ~A for GET ~A"
(download-response c) (download-url c)))))
(define-condition signature-error (error)
((cause :initarg :cause :reader signature-error-cause))
(:report (lambda (c s)
(format s "Cannot verify package signature: ~A"
(signature-error-cause c)))))
(format s "Cannot verify package signature: ~A"
(signature-error-cause c)))))
(defun url-host (url)
(assert (string-equal url "http://" :end1 7))
(let* ((port-start (position #\: url :start 7))
(host-end (min (or (position #\/ url :start 7) (length url))
(or port-start (length url)))))
(host-end (min (or (position #\/ url :start 7) (length url))
(or port-start (length url)))))
(subseq url 7 host-end)))
(defun url-port (url)
......@@ -111,8 +111,8 @@ an immediate concern
(defun url-connection (url)
(let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
(host (url-host url))
(port (url-port url)))
(host (url-host url))
(port (url-port url)))
(socket-connect
s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url)))))
(url-port (or *proxy* url)))
......@@ -120,90 +120,90 @@ an immediate concern
;; we are exceedingly unportable about proper line-endings here.
;; Anyone wishing to run this under non-SBCL should take especial care
(format stream "GET ~A HTTP/1.0~%Host: ~A~%Cookie: CCLAN-SITE=~A~%~%"
url host *cclan-mirror*)
url host *cclan-mirror*)
(force-output stream)
(list
(let* ((l (read-line stream))
(space (position #\Space l)))
(parse-integer l :start (1+ space) :junk-allowed t))
(space (position #\Space l)))
(parse-integer l :start (1+ space) :junk-allowed t))
(loop for line = (read-line stream nil nil)
until (or (null line) (eql (elt line 0) (code-char 13)))
collect
(let ((colon (position #\: line)))
(cons (intern (string-upcase (subseq line 0 colon)) :keyword)
(string-trim (list #\Space (code-char 13))
(subseq line (1+ colon))))))
until (or (null line) (eql (elt line 0) (code-char 13)))
collect
(let ((colon (position #\: line)))
(cons (intern (string-upcase (subseq line 0 colon)) :keyword)
(string-trim (list #\Space (code-char 13))
(subseq line (1+ colon))))))
stream))))
(defun download (package-name-or-url file-name)
(let ((url
(if (= (mismatch package-name-or-url "http://") 7)
package-name-or-url
(format nil "http://www.cliki.net/~A?download"
package-name-or-url))))
(if (= (mismatch package-name-or-url "http://") 7)
package-name-or-url
(format nil "http://www.cliki.net/~A?download"
package-name-or-url))))
(destructuring-bind (response headers stream)
(block got
(loop
(destructuring-bind (response headers stream) (url-connection url)
(unless (member response '(301 302))
(return-from got (list response headers stream)))
(close stream)
(setf url (cdr (assoc :location headers))))))
(block got
(loop
(destructuring-bind (response headers stream) (url-connection url)
(unless (member response '(301 302))
(return-from got (list response headers stream)))
(close stream)
(setf url (cdr (assoc :location headers))))))
(if (>= response 400)
(error 'download-error :url url :response response))
(error 'download-error :url url :response response))
(let ((length (parse-integer
(or (cdr (assoc :content-length headers)) "")
:junk-allowed t)))
(format t "Downloading ~A bytes from ~A ..."
(if length length "some unknown number of") url)
(force-output)
(with-open-file (o file-name :direction :output)
(if length
(let ((buf (make-array length
:element-type
(stream-element-type stream) )))
(read-sequence buf stream)
(write-sequence buf o))
(sb-executable:copy-stream stream o))))
(or (cdr (assoc :content-length headers)) "")
:junk-allowed t)))
(format t "Downloading ~A bytes from ~A ..."
(if length length "some unknown number of") url)
(force-output)
(with-open-file (o file-name :direction :output)
(if length
(let ((buf (make-array length
:element-type
(stream-element-type stream) )))
(read-sequence buf stream)
(write-sequence buf o))
(sb-executable:copy-stream stream o))))
(close stream)
(terpri)
;; seems to have worked. let's try for a detached gpg signature too
(when *verify-gpg-signatures*
(verify-gpg-signature url file-name)))))
(verify-gpg-signature url file-name)))))
(defun verify-gpg-signature (url file-name)
(destructuring-bind (response headers stream)
(url-connection (concatenate 'string url ".asc"))
(declare (ignore headers))
(unwind-protect
(if (= response 200)
;; sadly, we can't pass the stream directly to run-program,
;; because (at least in sbcl 0.8) that ignores existing buffered
;; data and only reads new fresh data direct from the file
;; descriptor
(let ((data (make-string (parse-integer
(cdr (assoc :content-length headers))
:junk-allowed t))))
(read-sequence data stream)
(let ((ret
(process-exit-code
(sb-ext:run-program "/usr/bin/gpg"
(list "--verify" "-"
(namestring file-name))
:output t
:input (make-string-input-stream data)
:wait t))))
(unless (zerop ret)
(error 'signature-error
:cause (make-condition
'simple-error
:format-control "GPG returned exit status ~A"
:format-arguments (list ret))))))
(error 'signature-error
:cause
(make-condition
'download-error :url (concatenate 'string url ".asc")
:response response)))
(if (= response 200)
;; sadly, we can't pass the stream directly to run-program,
;; because (at least in sbcl 0.8) that ignores existing buffered
;; data and only reads new fresh data direct from the file
;; descriptor
(let ((data (make-string (parse-integer
(cdr (assoc :content-length headers))
:junk-allowed t))))
(read-sequence data stream)
(let ((ret
(process-exit-code
(sb-ext:run-program "/usr/bin/gpg"
(list "--verify" "-"
(namestring file-name))
:output t
:input (make-string-input-stream data)
:wait t))))
(unless (zerop ret)
(error 'signature-error
:cause (make-condition
'simple-error
:format-control "GPG returned exit status ~A"
:format-arguments (list ret))))))
(error 'signature-error
:cause
(make-condition
'download-error :url (concatenate 'string url ".asc")
:response response)))
(close stream))))
......@@ -212,9 +212,9 @@ an immediate concern
(defun where ()
(format t "Install where?~%")
(loop for (source system name) in *locations*
for i from 1
do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%"
i name system source))
for i from 1
do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%"
i name system source))
(format t " --> ") (force-output)
(let ((response (read)))
(when (> response 0)
......@@ -225,36 +225,36 @@ an immediate concern
(ensure-directories-exist source )
(ensure-directories-exist system )
(let* ((tar
(with-output-to-string (o)
(or
(sb-ext:run-program "/bin/tar"
(list "-C" (namestring source)
"-xzvf" (namestring packagename))
:output o
:wait t)
(error "can't untar"))))
(dummy (princ tar))
(pos-slash (position #\/ tar))
(*default-pathname-defaults*
(merge-pathnames
(make-pathname :directory
`(:relative ,(subseq tar 0 pos-slash)))
source)))
(with-output-to-string (o)
(or
(sb-ext:run-program "/bin/tar"
(list "-C" (namestring source)
"-xzvf" (namestring packagename))
:output o
:wait t)
(error "can't untar"))))
(dummy (princ tar))
(pos-slash (position #\/ tar))
(*default-pathname-defaults*
(merge-pathnames
(make-pathname :directory
`(:relative ,(subseq tar 0 pos-slash)))
source)))
(loop for asd in (directory
(make-pathname :name :wild :type "asd"))
do (let ((target (merge-pathnames
(make-pathname :name (pathname-name asd)
:type (pathname-type asd))
system)))
(when (probe-file target)
(sb-posix:unlink target))
(sb-posix:symlink asd target))
collect (pathname-name asd))))
(make-pathname :name :wild :type "asd"))
do (let ((target (merge-pathnames
(make-pathname :name (pathname-name asd)
:type (pathname-type asd))
system)))
(when (probe-file target)
(sb-posix:unlink target))
(sb-posix:symlink asd target))
collect (pathname-name asd))))
(defvar *temporary-files*)
(defun temp-file-name (p)
(let* ((pos-slash (position #\/ p :from-end t))
(pos-dot (position #\. p :start (or pos-slash 0))))
(pos-dot (position #\. p :start (or pos-slash 0))))
(merge-pathnames
(make-pathname
:name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot)
......@@ -265,32 +265,32 @@ an immediate concern
(defun run (&optional (packages (cdr *posix-argv*)))
(destructuring-bind (source system name) (where)
(labels ((one-iter (packages)
(dolist (asd
(loop for p in packages
unless (probe-file p)
do (let ((tmp (temp-file-name p)))
(pushnew tmp *temporary-files*)
(download p tmp)
(setf p tmp))
end
do (format t "Installing ~A in ~A,~A~%" p source system)
append (install source system p)))
(handler-case
(asdf:operate 'asdf:load-op asd)
(asdf:missing-dependency (c)
(format t "Downloading package ~A, required by ~A~%"
(asdf::missing-requires c)
(asdf:component-name (asdf::missing-required-by c)))
(one-iter (list
(symbol-name (asdf::missing-requires c)))))))))
(dolist (asd
(loop for p in packages
unless (probe-file p)
do (let ((tmp (temp-file-name p)))
(pushnew tmp *temporary-files*)
(download p tmp)
(setf p tmp))
end
do (format t "Installing ~A in ~A,~A~%" p source system)
append (install source system p)))
(handler-case
(asdf:operate 'asdf:load-op asd)
(asdf:missing-dependency (c)
(format t "Downloading package ~A, required by ~A~%"
(asdf::missing-requires c)
(asdf:component-name (asdf::missing-required-by c)))
(one-iter (list
(symbol-name (asdf::missing-requires c)))))))))
(one-iter packages))))
(handler-case
(let ((*temporary-files* nil))
(unwind-protect
(run)
(dolist (l *temporary-files*)
(when (probe-file l) (delete-file l)))))
(run)
(dolist (l *temporary-files*)
(when (probe-file l) (delete-file l)))))
(error (c)
(princ "Install failed due to error:") (terpri)
(princ c) (terpri)
......
......@@ -163,7 +163,7 @@
;;;;
(defvar *asdf-revision*
;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
(subseq "REVISION:1.372" (1+ (length "REVISION"))))
(subseq "REVISION:1.373" (1+ (length "REVISION"))))
(defvar *resolve-symlinks* t
"Determine whether or not ASDF resolves symlinks when defining systems.
......
......@@ -418,19 +418,19 @@ slightly convoluted example:
The method-form tokens need explaining: essentially, this part:
@lisp
:perform (compile-op :after (op c)
(do-something c))
:explain (compile-op :after (op c)
(explain-something c))
:perform (compile-op :after (op c)
(do-something c))
:explain (compile-op :after (op c)
(explain-something c))
@end lisp
has the effect of
@lisp
(defmethod perform :after ((op compile-op) (c (eql ...)))
(do-something c))
(do-something c))
(defmethod explain :after ((op compile-op) (c (eql ...)))
(explain-something c))
(explain-something c))
@end lisp
where @code{...} is the component in question; note that although this
......@@ -452,10 +452,10 @@ option := :components component-list
| :default-component-class
| :perform method-form
| :explain method-form
| :output-files method-form
| :output-files method-form
| :operation-done-p method-form
| :depends-on ( {dependency-def}* )
| :serial [ t | nil ]
| :serial [ t | nil ]
| :in-order-to ( {dependency}+ )
component-list := ( {component-def}* )
......@@ -497,8 +497,8 @@ is equivalent to
@lisp
:components ((:file "a")
(:file "b" :depends-on ("a"))
(:file "c" :depends-on ("a" "b")))
(:file "b" :depends-on ("a"))
(:file "c" :depends-on ("a" "b")))
@end lisp
......@@ -706,13 +706,13 @@ libraries and test techniques in use in the community.
@c @lisp
@c (defun version-satisfies (x y)
@c (labels ((bigger (x y)
@c (cond ((not y) t)
@c ((not x) nil)
@c ((> (car x) (car y)) t)
@c ((= (car x) (car y))
@c (bigger (cdr x) (cdr y))))))
@c (cond ((not y) t)
@c ((not x) nil)
@c ((> (car x) (car y)) t)
@c ((= (car x) (car y))
@c (bigger (cdr x) (cdr y))))))
@c (and (= (car x) (car y))
@c (or (not (cdr y)) (bigger (cdr x) (cdr y))))))
@c (or (not (cdr y)) (bigger (cdr x) (cdr y))))))
@c @end lisp
@c If that doesn't work for your system, you can override it. I hope
......@@ -883,7 +883,7 @@ initargs for the component, you can say
@lisp
:in-order-to ((compile-op (load-op "a" "b") (compile-op "c"))
(load-op (load-op "foo")))
(load-op (load-op "foo")))
@end lisp
This means the following things:
......@@ -1381,7 +1381,7 @@ so should be.
*** Propagation of the :force option. ``I notice that
(oos 'compile-op :araneida :force t)
(oos 'compile-op :araneida :force t)
also forces compilation of every other system the :araneida system
depends on. This is rarely useful to me; usually, when I want to force
......
......@@ -12,7 +12,7 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro generate-time-part-function (part-name position)
(let ((function-name (intern (concatenate 'string
(symbol-name 'time) "-" (symbol-name part-name)))))
(symbol-name 'time) "-" (symbol-name part-name)))))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(export ',function-name)
(defun ,function-name
......@@ -73,8 +73,8 @@ is divisible by four but not by 100 or if it is divisible by 400."
(check-type format (member :long :short))
(nth day-of-the-week
(case format
(:long (nth +longer-format-index+ +dow-output-list))
(:short (nth +shorter-format-index+ +dow-output-list)))))
(:long (nth +longer-format-index+ +dow-output-list))
(:short (nth +shorter-format-index+ +dow-output-list)))))
(defun month->string (month &optional (format :long))
"Returns the name \(in English\) of the month. Format can be :long or :short."
......@@ -82,8 +82,8 @@ is divisible by four but not by 100 or if it is divisible by 400."
(check-type format (member :long :short))
(nth (1- month)
(case format
(:long (nth +longer-format-index+ +month-output-list+))
(:short (nth +shorter-format-index+ +month-output-list+)))))
(:long (nth +longer-format-index+ +month-output-list+))
(:short (nth +shorter-format-index+ +month-output-list+)))))
(defun format-date (format date &optional stream time-zone)
"Formats universal dates using the same format specifiers as NSDateFormatter. The format is:
......@@ -122,80 +122,80 @@ None of %c, %F, %p, %x, %X, %Z, %z are implemented."
(format
stream "~{~A~}"
(loop for index = 0 then (1+ index)
while (< index format-length) collect
(let ((char (aref format index)))
(cond
((char= #\% char)
(setf char (aref format (incf index)))
(cond
;; %% - A '%' character
((char= char #\%) #\%)
while (< index format-length) collect
(let ((char (aref format index)))
(cond
((char= #\% char)
(setf char (aref format (incf index)))
(cond
;; %% - A '%' character
((char= char #\%) #\%)
;; %a - Abbreviated weekday name
((char= char #\a) (day->string (time-day-of-week date) :short))
;; %a - Abbreviated weekday name
((char= char #\a) (day->string (time-day-of-week date) :short))