diff --git a/asdf-ecl.lisp b/asdf-ecl.lisp index 6332f5d6216386190d7509e95fe11e9024bd38a7..7fd2c8fb1636348c079617828fea2f643e9d48fd 100644 --- a/asdf-ecl.lisp +++ b/asdf-ecl.lisp @@ -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 diff --git a/asdf-install.lisp b/asdf-install.lisp index 6c127cba09d8fafc748268e92872962ccec4ae1b..9813f29c893837576abdbb574e8b843b34f83288 100644 --- a/asdf-install.lisp +++ b/asdf-install.lisp @@ -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) diff --git a/asdf.lisp b/asdf.lisp index b1076afd477a44ec1cf38b7e49627ead19611640..9631a1695bb1d67f92e5c8d877adc242f7b9ca22 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -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. diff --git a/asdf.texinfo b/asdf.texinfo index 34d053867bfc9e1521563c1a3d55c647c89e4163..cae82501e7e16079da49cb91ff253783da6f4345 100644 --- a/asdf.texinfo +++ b/asdf.texinfo @@ -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 diff --git a/bin/make-helper.lisp b/bin/make-helper.lisp index ea4c1dcf91e8e0ccd93aa1dd6aa4623f20c689c1..a23f68a3801f0493dd73037ca5f8668234186f2b 100644 --- a/bin/make-helper.lisp +++ b/bin/make-helper.lisp @@ -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)) - ;; %A - Full weekday name - ((char= char #\A) (day->string (time-day-of-week date) :long)) + ;; %A - Full weekday name + ((char= char #\A) (day->string (time-day-of-week date) :long)) - ;; %b - Abbreviated month name - ((char= char #\b) (month->string (time-month date) :short)) + ;; %b - Abbreviated month name + ((char= char #\b) (month->string (time-month date) :short)) - ;; %B - Full month name - ((char= char #\B) (month->string (time-month date) :long)) + ;; %B - Full month name + ((char= char #\B) (month->string (time-month date) :long)) - ;; %d - Day of the month as a decimal number [01-31] - ((char= char #\d) (format nil "~2,'0D" (time-date date))) + ;; %d - Day of the month as a decimal number [01-31] + ((char= char #\d) (format nil "~2,'0D" (time-date date))) - ;; %e - Same as %d but does not print the leading 0 for days 1 through 9 - ;; Unlike strftime, does not print a leading space - ((char= char #\e) (format nil "~D" (time-date date))) + ;; %e - Same as %d but does not print the leading 0 for days 1 through 9 + ;; Unlike strftime, does not print a leading space + ((char= char #\e) (format nil "~D" (time-date date))) - ;; %H - Hour based on a 24-hour clock as a decimal number [00-23] - ((char= char #\H) (format nil "~2,'0D" (time-hour date))) + ;; %H - Hour based on a 24-hour clock as a decimal number [00-23] + ((char= char #\H) (format nil "~2,'0D" (time-hour date))) - ;; %I - Hour based on a 12-hour clock as a decimal number [01-12] - ((char= char #\I) (format nil "~2,'0D" (1+ (mod (time-hour date) 12)))) + ;; %I - Hour based on a 12-hour clock as a decimal number [01-12] + ((char= char #\I) (format nil "~2,'0D" (1+ (mod (time-hour date) 12)))) - ;; %j - Day of the year as a decimal number [001-366] - ((char= char #\j) (format nil "~3,'0D" (day-of-year date))) + ;; %j - Day of the year as a decimal number [001-366] + ((char= char #\j) (format nil "~3,'0D" (day-of-year date))) - ;; %m - Month as a decimal number [01-12] - ((char= char #\m) (format nil "~2,'0D" (time-month date))) + ;; %m - Month as a decimal number [01-12] + ((char= char #\m) (format nil "~2,'0D" (time-month date))) - ;; %M - Minute as a decimal number [00-59] - ((char= char #\M) (format nil "~2,'0D" (time-minute date))) + ;; %M - Minute as a decimal number [00-59] + ((char= char #\M) (format nil "~2,'0D" (time-minute date))) - ;; %S - Second as a decimal number [00-59] - ((char= char #\S) (format nil "~2,'0D" (time-second date))) + ;; %S - Second as a decimal number [00-59] + ((char= char #\S) (format nil "~2,'0D" (time-second date))) - ;; %w - Weekday as a decimal number [0-6], where Sunday is 0 - ((char= char #\w) (format nil "~D" (time-day-of-week date))) + ;; %w - Weekday as a decimal number [0-6], where Sunday is 0 + ((char= char #\w) (format nil "~D" (time-day-of-week date))) - ;; %y - Year without century [00-99] - ((char= char #\y) - (let ((year-string (format nil "~,2A" (time-year date)))) - (subseq year-string (- (length year-string) 2)))) + ;; %y - Year without century [00-99] + ((char= char #\y) + (let ((year-string (format nil "~,2A" (time-year date)))) + (subseq year-string (- (length year-string) 2)))) - ;; %Y - Year with century [such as 1990] - ((char= char #\Y) (format nil "~D" (time-year date))) + ;; %Y - Year with century [such as 1990] + ((char= char #\Y) (format nil "~D" (time-year date))) - (t - (error "Ouch - unknown formatter '%~c" char)))) - (t char))))))) + (t + (error "Ouch - unknown formatter '%~c" char)))) + (t char))))))) ;;; metatilites-base (defun extract-summary (pathname stream) (with-open-file (in pathname :direction :input - :if-does-not-exist :error) + :if-does-not-exist :error) (let ((start nil)) (loop for line = (read-line in nil :eof) - until (eq line :eof) do - (when (and (> (length line) 5) (string-equal "-#---" (subseq line 0 5))) - (setf start t)) - (when start - (format stream "~&~a~%" line)))))) + until (eq line :eof) do + (when (and (> (length line) 5) (string-equal "-#---" (subseq line 0 5))) + (setf start t)) + (when start + (format stream "~&~a~%" line)))))) (defun html-header (stream title style-sheet) (format stream "~&<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" @@ -207,29 +207,29 @@ None of %c, %F, %p, %x, %X, %Z, %z are implemented." (unless (search ".css" style-sheet) (setf style-sheet (concatenate 'string style-sheet ".css"))) (format stream "~&<link type='text/css' href='~a' rel='stylesheet' />" - style-sheet)) + style-sheet)) (format stream "~&</head>~&<body>")) (defun html-footer (stream) (format stream "<div id=\"footer\">") (format stream "~&generated on ~a" - (format-date "%B %d, %Y" (get-universal-time))) + (format-date "%B %d, %Y" (get-universal-time))) (format stream "</div>") (format stream "~&</body></html>")) (defun build-web-page (input-directory output-file &key (if-exists :error) - (title "ASDF test report") (style-sheet "styles.css")) + (title "ASDF test report") (style-sheet "styles.css")) (with-open-file (stream output-file - :direction :output - :if-exists if-exists - :if-does-not-exist :create) + :direction :output + :if-exists if-exists + :if-does-not-exist :create) (html-header stream title style-sheet) (format stream "~&~%<h1>ASDF Test results</h1>~%") (dolist (pathname (directory - (merge-pathnames (make-pathname :name :wild :type "text") - input-directory))) + (merge-pathnames (make-pathname :name :wild :type "text") + input-directory))) (print pathname) (format stream "~&~%<h2>~a</h2>~%" (pathname-name pathname)) (format stream "~&<pre>~%") @@ -240,31 +240,31 @@ None of %c, %F, %p, %x, %X, %Z, %z are implemented." (defun extract-license (input-pathname output-pathname) (with-open-file (in input-pathname :direction :input - :if-does-not-exist :error) + :if-does-not-exist :error) (with-open-file (out output-pathname - :direction :output - :if-does-not-exist :create - :if-exists :error) + :direction :output + :if-does-not-exist :create + :if-exists :error) (let* ((state nil) - (flag ";;; -- LICENSE") - (flag-length (length flag))) - (loop for line = (read-line in nil :eof) - until (eq line :eof) do - (when (and (> (length line) flag-length) - (string-equal flag (subseq line 0 flag-length))) - (if (eq state :running) - (return) - (setf state :starting))) - (when (eq state :running) - (format out "~&~a~%" (subseq line (min (length line) 4)))) - (when (eq state :starting) - (setf state :running))))))) + (flag ";;; -- LICENSE") + (flag-length (length flag))) + (loop for line = (read-line in nil :eof) + until (eq line :eof) do + (when (and (> (length line) flag-length) + (string-equal flag (subseq line 0 flag-length))) + (if (eq state :running) + (return) + (setf state :starting))) + (when (eq state :running) + (format out "~&~a~%" (subseq line (min (length line) 4)))) + (when (eq state :starting) + (setf state :running))))))) (defun rewrite-license () (let* ((*default-pathname-defaults* - (make-pathname :name nil :type nil :defaults *make-helper-home*)) - (output (merge-pathnames (make-pathname :name "LICENSE" - :directory '(:relative :up))))) + (make-pathname :name nil :type nil :defaults *make-helper-home*)) + (output (merge-pathnames (make-pathname :name "LICENSE" + :directory '(:relative :up))))) (when (probe-file output) (delete-file output)) (extract-license @@ -274,14 +274,14 @@ None of %c, %F, %p, %x, %X, %Z, %z are implemented." (defun write-test-web-pages () (let* ((*default-pathname-defaults* - (make-pathname :name nil :type nil :defaults *make-helper-home*)) - (source (merge-pathnames - (make-pathname - :directory '(:relative :up "test" "results")))) - (output (merge-pathnames (make-pathname - :directory '(:relative :up "website" "output") - :name "test-results" - :type "html")))) + (make-pathname :name nil :type nil :defaults *make-helper-home*)) + (source (merge-pathnames + (make-pathname + :directory '(:relative :up "test" "results")))) + (output (merge-pathnames (make-pathname + :directory '(:relative :up "website" "output") + :name "test-results" + :type "html")))) (print (list source output)) (build-web-page source output :if-exists :supersede))) diff --git a/cclan-package.lisp b/cclan-package.lisp index d993e94a842a50befa1c6cc2c749d3815495127e..a00d604025f7e97c92dd807dc1ec11ad6e264e0b 100644 --- a/cclan-package.lisp +++ b/cclan-package.lisp @@ -1,5 +1,5 @@ (in-package :cl-user) (defpackage :cclan (:use #:cl #:asdf) - (:export #:all-components #:write-package)) + (:export #:all-components #:write-package)) diff --git a/cclan.asd b/cclan.asd index 7c0b9a65a913520c0c606e71414c0650cadbf8e6..7f0c3b0fbaa888288f84805673e3432e9da97d06 100644 --- a/cclan.asd +++ b/cclan.asd @@ -5,4 +5,4 @@ (defsystem cclan :version "0.1" :components ((:file "cclan-package") - (:file "cclan" :depends-on ("cclan-package")))) + (:file "cclan" :depends-on ("cclan-package")))) diff --git a/cclan.lisp b/cclan.lisp index a80d96582c72519941e2c02f6ec87d2ce648036f..9b31fb45c6ce680a4dd46904a1fe47cb6b77d394 100644 --- a/cclan.lisp +++ b/cclan.lisp @@ -27,14 +27,14 @@ (defun cvs-tag-name (system) (let* ((system (find-system system)) - (version (component-version system))) + (version (component-version system))) (format nil "release_~A" (substitute #\_ #\. version)))) (defun cvs-tag (system) (let* ((system (find-system system)) - (directory (component-pathname system))) + (directory (component-pathname system))) (run-shell-command "cd ~A && cvs tag -F ~A" - (namestring directory) (cvs-tag-name system)))) + (namestring directory) (cvs-tag-name system)))) (defun write-readme-file (stream suggested-registry system-name) @@ -56,42 +56,42 @@ at your own peril.~%" suggested-registry suggested-registry system-name suggeste (defun write-package (system) (let* ((parent-dir - (parse-namestring - (format nil "/tmp/~A.~A/" - #+sbcl (sb-unix:unix-getpid) - #-sbcl (random 1000000) - (get-internal-run-time)))) - (system (find-system system)) - (sub-dir-name - (format nil "~A_~A" - (component-name system) (component-version system))) - (cvsroot-file - (merge-pathnames "CVS/Root" (component-pathname system))) - (old-pwd *default-pathname-defaults*) - (*default-pathname-defaults* parent-dir)) + (parse-namestring + (format nil "/tmp/~A.~A/" + #+sbcl (sb-unix:unix-getpid) + #-sbcl (random 1000000) + (get-internal-run-time)))) + (system (find-system system)) + (sub-dir-name + (format nil "~A_~A" + (component-name system) (component-version system))) + (cvsroot-file + (merge-pathnames "CVS/Root" (component-pathname system))) + (old-pwd *default-pathname-defaults*) + (*default-pathname-defaults* parent-dir)) (ensure-directories-exist parent-dir) (cvs-tag system) (and (zerop (asdf:run-shell-command - "cd ~A && cvs -d `cat ~A` checkout -d ~A -r ~A -kv ~A" - (namestring parent-dir) - (namestring cvsroot-file) - sub-dir-name - (cvs-tag-name system) - (component-name system))) + "cd ~A && cvs -d `cat ~A` checkout -d ~A -r ~A -kv ~A" + (namestring parent-dir) + (namestring cvsroot-file) + sub-dir-name + (cvs-tag-name system) + (component-name system))) (with-open-file (o (format nil "~A/INSTALL.asdf" sub-dir-name) - :direction :output) + :direction :output) (write-readme-file o "$HOME/lisp/systems/" (component-name system)) t) (zerop (asdf:run-shell-command "cd ~A && tar cf ~A~A.tar ~A" - (namestring parent-dir) - (namestring old-pwd) sub-dir-name - sub-dir-name)) + (namestring parent-dir) + (namestring old-pwd) sub-dir-name + sub-dir-name)) (zerop (asdf:run-shell-command - "gzip -f9 ~A~A.tar" - (namestring old-pwd) sub-dir-name)) + "gzip -f9 ~A~A.tar" + (namestring old-pwd) sub-dir-name)) (format t "Now run~% gpg -b -a ~A~A.tar.gz~%in a shell with a tty" - (namestring old-pwd) sub-dir-name)))) + (namestring old-pwd) sub-dir-name)))) (defun class-name-of (x) (class-name (class-of x))) diff --git a/test/compile-asdf.lisp b/test/compile-asdf.lisp index 67694063ea46b2bab7c7adecedc0c4ab2bc0c7dd..60bca6d2e53efe29e3f8d276a3c3206937efae52 100644 --- a/test/compile-asdf.lisp +++ b/test/compile-asdf.lisp @@ -4,15 +4,15 @@ (cond ((probe-file "asdf.lisp") (multiple-value-bind (result warnings-p errors-p) - (compile-file "asdf.lisp") - (declare (ignore result)) - (cond (warnings-p - (leave-lisp "Testuite failed: ASDF compiled with warnings" 1)) - (errors-p - (leave-lisp "Testuite failed: ASDF compiled with ERRORS" 2)) - (t - (leave-lisp "ASDF compiled cleanly" 0))))) + (compile-file "asdf.lisp") + (declare (ignore result)) + (cond (warnings-p + (leave-lisp "Testuite failed: ASDF compiled with warnings" 1)) + (errors-p + (leave-lisp "Testuite failed: ASDF compiled with ERRORS" 2)) + (t + (leave-lisp "ASDF compiled cleanly" 0))))) (t (leave-lisp "Testsuite failed: unable to find ASDF source" 3))) - \ No newline at end of file + \ No newline at end of file diff --git a/test/dweinreb-tests.lisp b/test/dweinreb-tests.lisp index 034a0e6eacd0ccee58053889d1ec2a6195b080bc..ba0585558f600129a72978b287f0cf2fceb6b054 100644 --- a/test/dweinreb-tests.lisp +++ b/test/dweinreb-tests.lisp @@ -16,15 +16,15 @@ http://ilc2009.scheming.org/ (expected :initarg :expected :reader test-expected))) (defmacro define-test (test-name system-name - &key operation-name already-compiled expected) + &key operation-name already-compiled expected) `(progn (push ',test-name *all-tests*) (setf (get ',test-name 'test) - (make-instance 'test - :system-name ',system-name - :operation-name ',operation-name - :already-compiled ',already-compiled - :expected ',expected)))) + (make-instance 'test + :system-name ',system-name + :operation-name ',operation-name + :already-compiled ',already-compiled + :expected ',expected)))) (defclass test-file (asdf:component) ()) @@ -35,7 +35,7 @@ http://ilc2009.scheming.org/ (defmethod asdf:operation-done-p ((o asdf:compile-op) (c test-file)) (declare (ignorable o)) (member (asdf:component-name c) (test-already-compiled *test*) - :test #'string=)) + :test #'string=)) (defmethod asdf:operation-done-p ((o asdf:operation) (c test-file)) (declare (ignorable o c)) @@ -51,58 +51,58 @@ http://ilc2009.scheming.org/ (defun run-unit-test (test-name) (let ((*test* (get test-name 'test)) - (*steps* nil) - (succeeded t)) + (*steps* nil) + (succeeded t)) (flet ((fail (format-string &rest format-args) - (setq succeeded nil) - (format t "Error in test ~S: " test-name) - (apply #'format t format-string format-args) - (terpri))) + (setq succeeded nil) + (format t "Error in test ~S: " test-name) + (apply #'format t format-string format-args) + (terpri))) (let ((system-name (test-system-name *test*)) - (operation-name (test-operation-name *test*))) - (check-type system-name symbol) - (check-type operation-name symbol) - (asdf:operate operation-name system-name)) + (operation-name (test-operation-name *test*))) + (check-type system-name symbol) + (check-type operation-name symbol) + (asdf:operate operation-name system-name)) (setq *steps* (nreverse *steps*)) (loop for steps on *steps* do - (when (member (first steps) (rest steps) :test #'equal) - (fail "The step ~S happened more than once: ~S" - (first steps) *steps*))) + (when (member (first steps) (rest steps) :test #'equal) + (fail "The step ~S happened more than once: ~S" + (first steps) *steps*))) ;(format t "~2%STEPS: ~S~3%" *steps*) (dolist (expectation (test-expected *test*)) - (destructuring-bind (op file &rest at) - expectation - ;(format t "~2%Expectation: ~S~3%" expectation) - (check-type file string) - (ecase op - ((:compiled :loaded) - (let ((pos (position (cons op file) *steps* :test #'equal))) - (if (null pos) - (fail "~S was not ~A" file op) - (loop for (relationship file2) on at by #'cddr do - (check-type file2 string) - (let* ((op2 (ecase relationship - (:after-loading :loaded) - (:after-compiling :compiled))) - (pos2 (position (cons op2 file2) *steps* - :test #'equal))) - (cond ((null pos2) - (fail "~S was not ~A at all, after ~A was ~A" - file2 op2 file op)) - ((< pos pos2) - (fail "Wrong order between ~A of ~S and ~A of ~S" - op file op2 file2)))))))) - (:did-not-compile - (when (member (cons :compiled file) *steps*) - (fail "~A compiled but should not have" file))) - (:did-not-load - (when (member (cons :loaded file) *steps*) - (fail "~A loaded but should not have" file))))))) + (destructuring-bind (op file &rest at) + expectation + ;(format t "~2%Expectation: ~S~3%" expectation) + (check-type file string) + (ecase op + ((:compiled :loaded) + (let ((pos (position (cons op file) *steps* :test #'equal))) + (if (null pos) + (fail "~S was not ~A" file op) + (loop for (relationship file2) on at by #'cddr do + (check-type file2 string) + (let* ((op2 (ecase relationship + (:after-loading :loaded) + (:after-compiling :compiled))) + (pos2 (position (cons op2 file2) *steps* + :test #'equal))) + (cond ((null pos2) + (fail "~S was not ~A at all, after ~A was ~A" + file2 op2 file op)) + ((< pos pos2) + (fail "Wrong order between ~A of ~S and ~A of ~S" + op file op2 file2)))))))) + (:did-not-compile + (when (member (cons :compiled file) *steps*) + (fail "~A compiled but should not have" file))) + (:did-not-load + (when (member (cons :loaded file) *steps*) + (fail "~A loaded but should not have" file))))))) succeeded)) (defun run-all-unit-tests () (let ((n-tests 0) - (n-succeeded 0)) + (n-succeeded 0)) (dolist (test-name *all-tests*) (incf n-tests) (when (run-unit-test test-name) @@ -112,133 +112,133 @@ http://ilc2009.scheming.org/ (asdf:defsystem system-1 :components ((:test-file "a") - (:test-file "b") - (:test-file "c" :depends-on ("b")) - (:test-file "d"))) + (:test-file "b") + (:test-file "c" :depends-on ("b")) + (:test-file "d"))) (define-test test-1 system-1 :operation-name asdf:load-op :already-compiled ("b") :expected ((:compiled "a") - (:loaded "a" :after-compiling "a") - (:did-not-compile "b") - (:loaded "b") - (:compiled "c" :after-loading "b") - (:loaded "c" :after-loading "b" :after-compiling "c") - (:compiled "d") - (:loaded "d" :after-compiling "d"))) + (:loaded "a" :after-compiling "a") + (:did-not-compile "b") + (:loaded "b") + (:compiled "c" :after-loading "b") + (:loaded "c" :after-loading "b" :after-compiling "c") + (:compiled "d") + (:loaded "d" :after-compiling "d"))) (asdf:defsystem system-2 :components ((:test-file "a" :depends-on ("g" "k")) - (:test-file "b") - (:test-file "c" :depends-on ("b")) - (:test-file "d" :depends-on ("e")) - (:test-file "e") - (:test-file "f" :depends-on ("c")) - (:test-file "g" :depends-on ("h")) - (:test-file "h") - (:test-file "i" :depends-on ("f" "b")) - (:test-file "j" :depends-on ("f" "c")) - (:test-file "k") - (:test-file "l" :depends-on ("d")))) + (:test-file "b") + (:test-file "c" :depends-on ("b")) + (:test-file "d" :depends-on ("e")) + (:test-file "e") + (:test-file "f" :depends-on ("c")) + (:test-file "g" :depends-on ("h")) + (:test-file "h") + (:test-file "i" :depends-on ("f" "b")) + (:test-file "j" :depends-on ("f" "c")) + (:test-file "k") + (:test-file "l" :depends-on ("d")))) (define-test test-2 system-2 :operation-name asdf:load-op :already-compiled () :expected ((:compiled "a" :after-compiling "g" :after-compiling "k" - :after-compiling "h" :after-loading "g" - :after-loading "k" :after-loading "h") - (:loaded "a" :after-compiling "a") - (:compiled "b") - (:loaded "b" :after-compiling "b") - (:compiled "c" :after-compiling "b" :after-loading "b") - (:loaded "c" :after-compiling "b" :after-loading "b" - :after-compiling "c") - (:compiled "d" :after-compiling "e") - (:compiled "e") - (:compiled "f" :after-compiling "c" :after-compiling "b") - (:compiled "g" :after-compiling "h") - (:compiled "h") - (:compiled "i" :after-compiling "f" :after-compiling "b") - (:compiled "j" :after-compiling "f" :after-compiling "b" - :after-compiling "c") - (:compiled "i" :after-compiling "f" :after-compiling "b" - :after-compiling "c") - (:compiled "j" :after-compiling "f" :after-compiling "b" - :after-compiling "c") - (:compiled "k") - (:compiled "l" :after-compiling "d" :after-compiling "e"))) + :after-compiling "h" :after-loading "g" + :after-loading "k" :after-loading "h") + (:loaded "a" :after-compiling "a") + (:compiled "b") + (:loaded "b" :after-compiling "b") + (:compiled "c" :after-compiling "b" :after-loading "b") + (:loaded "c" :after-compiling "b" :after-loading "b" + :after-compiling "c") + (:compiled "d" :after-compiling "e") + (:compiled "e") + (:compiled "f" :after-compiling "c" :after-compiling "b") + (:compiled "g" :after-compiling "h") + (:compiled "h") + (:compiled "i" :after-compiling "f" :after-compiling "b") + (:compiled "j" :after-compiling "f" :after-compiling "b" + :after-compiling "c") + (:compiled "i" :after-compiling "f" :after-compiling "b" + :after-compiling "c") + (:compiled "j" :after-compiling "f" :after-compiling "b" + :after-compiling "c") + (:compiled "k") + (:compiled "l" :after-compiling "d" :after-compiling "e"))) (asdf:defsystem system-3 :components ((:test-file "a") - (:test-file "b" :depends-on ("a")))) + (:test-file "b" :depends-on ("a")))) (define-test test-3 system-3 :operation-name asdf:compile-op :already-compiled ("b") :expected ((:compiled "a") - (:loaded "a" :after-compiling "a") - (:compiled "b" :after-compiling "a" :after-loading "a") - (:did-not-load "b"))) + (:loaded "a" :after-compiling "a") + (:compiled "b" :after-compiling "a" :after-loading "a") + (:did-not-load "b"))) (define-test test-3-a system-3 :operation-name asdf:compile-op :already-compiled ("a" "b") :expected ((:did-not-compile "a") - (:did-not-load "a") - (:did-not-compile "b") - (:did-not-load "b"))) + (:did-not-load "a") + (:did-not-compile "b") + (:did-not-load "b"))) (define-test test-3-b system-3 :operation-name asdf:compile-op :already-compiled () :expected ((:compiled "a") - (:loaded "a" :after-compiling "a") - (:compiled "b" :after-compiling "a" :after-loading "a") - (:did-not-load "b"))) + (:loaded "a" :after-compiling "a") + (:compiled "b" :after-compiling "a" :after-loading "a") + (:did-not-load "b"))) (asdf:defsystem system-4 :components ((:test-file "a") - (:test-file "b" :depends-on ("a")))) + (:test-file "b" :depends-on ("a")))) (define-test test-4 system-4 :operation-name asdf:compile-op :already-compiled ("a" "b") :expected ((:did-not-compile "a") - (:did-not-load "a") - (:did-not-compile "b") - (:did-not-load "b"))) + (:did-not-load "a") + (:did-not-compile "b") + (:did-not-load "b"))) (asdf:defsystem system-5 :components ((:test-file "a") - (:test-file "b" :depends-on ("a") - :in-order-to ((asdf:compile-op - (asdf:load-op "a")))))) + (:test-file "b" :depends-on ("a") + :in-order-to ((asdf:compile-op + (asdf:load-op "a")))))) (define-test test-5 system-5 :operation-name asdf:compile-op :already-compiled ("a" "b") :expected ((:did-not-compile "a") - (:loaded "a") - (:did-not-compile "b") - (:did-not-load "b"))) + (:loaded "a") + (:did-not-compile "b") + (:did-not-load "b"))) (asdf:defsystem system-6 :components ((:test-file "a") - (:test-file "b" - :in-order-to ((asdf:compile-op (asdf:compile-op "a")) - (asdf:load-op (asdf:load-op "a"))) - :do-first ((asdf:compile-op (asdf:load-op "a")))))) + (:test-file "b" + :in-order-to ((asdf:compile-op (asdf:compile-op "a")) + (asdf:load-op (asdf:load-op "a"))) + :do-first ((asdf:compile-op (asdf:load-op "a")))))) (define-test test-6 system-6 :operation-name asdf:compile-op :already-compiled ("a" "b") :expected ((:did-not-compile "a") - (:did-not-load "a") - (:did-not-compile "b") - (:did-not-load "b"))) + (:did-not-load "a") + (:did-not-compile "b") + (:did-not-load "b"))) ;; Should be just like test-3-b, but a does not get loaded. Why not? ;; Because you can't really specify :do-first because it clobbers @@ -247,24 +247,24 @@ http://ilc2009.scheming.org/ :operation-name asdf:compile-op :already-compiled () :expected ((:compiled "a") - (:loaded "a" :after-compiling "a") - (:compiled "b" :after-compiling "a" :after-loading "a") - (:did-not-load "b"))) + (:loaded "a" :after-compiling "a") + (:compiled "b" :after-compiling "a" :after-loading "a") + (:did-not-load "b"))) (asdf:defsystem system-7 :components ((:test-file "a") - (:test-file "b" - :in-order-to ((asdf:compile-op (asdf:compile-op "a")) - (asdf:load-op (asdf:load-op "a")) - (asdf:compile-op (asdf:load-op "a")))))) + (:test-file "b" + :in-order-to ((asdf:compile-op (asdf:compile-op "a")) + (asdf:load-op (asdf:load-op "a")) + (asdf:compile-op (asdf:load-op "a")))))) (define-test test-7 system-7 :operation-name asdf:compile-op :already-compiled ("a" "b") :expected ((:did-not-compile "a") - (:loaded "a") - (:did-not-compile "b") - (:did-not-load "b"))) + (:loaded "a") + (:did-not-compile "b") + (:did-not-load "b"))) diff --git a/test/graveyard/test6.script b/test/graveyard/test6.script index f86c870ecf5b0dca6f731b5865598c677977f186..5cc6c6d8a46a59f5cbb4a0a4674295e731c1ebb9 100644 --- a/test/graveyard/test6.script +++ b/test/graveyard/test6.script @@ -10,8 +10,8 @@ (exit-on-error (setf asdf:*central-registry* '(*default-pathname-defaults*)) (defmethod asdf:preference-file-for-system/operation - ((system (eql (asdf:find-system 'test1))) operation) - (merge-pathnames (make-pathname :name "test1" :type "preferences"))) + ((system (eql (asdf:find-system 'test1))) operation) + (merge-pathnames (make-pathname :name "test1" :type "preferences"))) (asdf:operate 'asdf:load-op 'test1) (assert (null *test6*))) diff --git a/test/graveyard/test7.script b/test/graveyard/test7.script index 5793d50d32b1f12541c9d72530f2fc324d3b74da..5f2e89cf057e605d68e04556b94c2232cfe7bec9 100644 --- a/test/graveyard/test7.script +++ b/test/graveyard/test7.script @@ -10,8 +10,8 @@ (exit-on-error (setf asdf:*central-registry* '(*default-pathname-defaults*)) (defmethod asdf:preference-file-for-system/operation - ((system (eql (asdf:find-system 'test1))) operation) - (merge-pathnames (make-pathname :name "test1" :type "preferences"))) + ((system (eql (asdf:find-system 'test1))) operation) + (merge-pathnames (make-pathname :name "test1" :type "preferences"))) (setf asdf::*load-preference-files* t) (asdf:operate 'asdf:load-op 'test1) (assert (eq *test6* :yes))) diff --git a/test/in-progress.lisp b/test/in-progress.lisp index 85837cd79322454fa0dd554cedbd4386fce2b9cb..fbfd9e88f20dd27c49fd8a5be11a6554b825a2c4 100644 --- a/test/in-progress.lisp +++ b/test/in-progress.lisp @@ -3,12 +3,12 @@ (assert (equalp (let ((*system-definition-search-functions* - '(sysdef-central-registry-search)) + '(sysdef-central-registry-search)) (*central-registry* (list "/tmp/ok-1/" "/tmp/bad" "/tmp/ok-2/"))) (handler-bind ((error (lambda (c) - (when (find-restart 'remove-entry-from-registry) - (invoke-restart 'remove-entry-from-registry))))) + (when (find-restart 'remove-entry-from-registry) + (invoke-restart 'remove-entry-from-registry))))) (find-system "a" nil)) *central-registry*) (list "/tmp/ok-1/" "/tmp/ok-2/")) @@ -17,12 +17,12 @@ (assert (equalp (let ((*system-definition-search-functions* - '(sysdef-central-registry-search)) + '(sysdef-central-registry-search)) (*central-registry* (list "/tmp/ok-1/" "/tmp/bad" "/tmp/ok-2/"))) (handler-bind ((error (lambda (c) - (when (find-restart 'coerce-entry-to-directory) - (invoke-restart 'coerce-entry-to-directory))))) + (when (find-restart 'coerce-entry-to-directory) + (invoke-restart 'coerce-entry-to-directory))))) (find-system "a" nil)) *central-registry*) (list "/tmp/ok-1/" #p"/tmp/bad/" "/tmp/ok-2/")) diff --git a/test/script-support.lisp b/test/script-support.lisp index b82b3dab127e14e206694d16b30756a421f6bc4e..af482dc3a9462d715ddce43f621e1be517cb34be 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -33,7 +33,7 @@ (defmacro quit-on-error (&body body) `(handler-case (progn ,@body - (leave-lisp "~&Script succeeded~%" 0)) + (leave-lisp "~&Script succeeded~%" 0)) (error (c) (format *error-output* "~a" c) (leave-lisp "~&Script failed~%" 1)))) diff --git a/test/test-module-pathnames.asd b/test/test-module-pathnames.asd index f2581182df8f1aaf19eef54036cc03a7abe95d11..c154c81b5a252ef04face5f33f5ab046d9808950 100644 --- a/test/test-module-pathnames.asd +++ b/test/test-module-pathnames.asd @@ -4,9 +4,9 @@ :components ((:module "sources/level1" :serial t - :components - ((:file "file1") - (:file "level2/file2") - (:static-file "level2/static.file") - (:static-file "test-tmp.cl"))))) + :components + ((:file "file1") + (:file "level2/file2") + (:static-file "level2/static.file") + (:static-file "test-tmp.cl"))))) diff --git a/test/test-module-pathnames.script b/test/test-module-pathnames.script index dcdd1fd99f748d50c498a96103d94f86fbae07d0..310c94aa09a0e0fde93806123afbf3a075557b23 100644 --- a/test/test-module-pathnames.script +++ b/test/test-module-pathnames.script @@ -25,34 +25,34 @@ nil "Didn't get the name of static.file right"))) (assert (find-package :test-package) nil - "package test-package not found") + "package test-package not found") (assert (find-symbol (symbol-name '*file-tmp*) :test-package) nil - "symbol `*file-tmp*` not found") + "symbol `*file-tmp*` not found") (assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package)) - nil "symbol `*file-tmp*` has wrong value") + nil "symbol `*file-tmp*` has wrong value") #| ; must be adapted to ABL (assert (probe-file (merge-pathnames - (make-pathname - :name "file1" - :type (pathname-type (compile-file-pathname "x")) - :directory '(:relative "sources" "level1")))) - nil "compiled file not found") + (make-pathname + :name "file1" + :type (pathname-type (compile-file-pathname "x")) + :directory '(:relative "sources" "level1")))) + nil "compiled file not found") |# (assert (find-symbol (symbol-name '*file-tmp2*) :test-package) nil - "symbol `*file-tmp2*` not found") + "symbol `*file-tmp2*` not found") (assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package)) - nil "symbol `*file-tmp2*` has wrong value") + nil "symbol `*file-tmp2*` has wrong value") #| ; must be adapted to ABL (assert (probe-file (merge-pathnames - (make-pathname - :name "file2" - :type (pathname-type (compile-file-pathname "x")) - :directory '(:relative "sources" "level1" "level2")))) - nil "compiled file not found") + (make-pathname + :name "file2" + :type (pathname-type (compile-file-pathname "x")) + :directory '(:relative "sources" "level1" "level2")))) + nil "compiled file not found") |# ) diff --git a/test/test-modules-serial.asd b/test/test-modules-serial.asd index bf855bed318a325741b08490501c9587bf87c049..6100dbe09c8249ee3355ac2beabc75f307fa30aa 100644 --- a/test/test-modules-serial.asd +++ b/test/test-modules-serial.asd @@ -3,13 +3,13 @@ :serial t :components ((:module "a" - :serial t - :pathname "." - :components - ((:file "file1") - (:file "file2"))) + :serial t + :pathname "." + :components + ((:file "file1") + (:file "file2"))) (:module "b" - :pathname "b" - :components - ((:file "file3"))))) + :pathname "b" + :components + ((:file "file3"))))) diff --git a/test/test-modules.asd b/test/test-modules.asd index 801261c9b351f1e5032d504f72b26789e1d3011c..6b14c2256a8b674b4dcaa944c474f3d392507da0 100644 --- a/test/test-modules.asd +++ b/test/test-modules.asd @@ -2,12 +2,12 @@ (asdf:defsystem test-modules :components ((:module "a" - :pathname "." - :components - ((:file "file1"))) + :pathname "." + :components + ((:file "file1"))) (:module "b" - :pathname "b" - :depends-on ("a") - :components - ((:file "file2"))))) + :pathname "b" + :depends-on ("a") + :components + ((:file "file2"))))) diff --git a/test/test-nested-components-1.asd b/test/test-nested-components-1.asd index e296fa735805b16ad6a753df26162b1fce3b0168..fad0ef4e67316d2b1675f4aff7d3264b02313726 100644 --- a/test/test-nested-components-1.asd +++ b/test/test-nested-components-1.asd @@ -23,15 +23,15 @@ (in-package #:common-lisp-user) (defpackage #:test-nested-components.system - (:use #:common-lisp #:asdf)) + (:use #:common-lisp #:asdf)) (in-package #:test-nested-components.system) (defsystem test-nested-components-a :components ((:module "nested-components" - :pathname "" - :components ((:file "test-nested-1"))))) + :pathname "" + :components ((:file "test-nested-1"))))) (defsystem test-nested-components-b :pathname "" @@ -41,7 +41,7 @@ (defsystem db-agraph-preflight :components ((:module "preflight-checks" - :components ((:file "preflight"))))) + :components ((:file "preflight"))))) (defsystem db-agraph-preflight-2 :pathname "preflight-checks" diff --git a/test/test-nested-components.script b/test/test-nested-components.script index 0ec92eb1992ccd53c2a9500943c51c612deaa48c..7e16b5abf77a47d899f9e0e6c0608e2333a7e2f5 100644 --- a/test/test-nested-components.script +++ b/test/test-nested-components.script @@ -13,14 +13,14 @@ (list :a (asdf::traverse (make-instance 'asdf:compile-op) - (asdf:find-system 'test-nested-components-a)) + (asdf:find-system 'test-nested-components-a)) (asdf::traverse (make-instance 'asdf:compile-op) - (asdf:find-system 'test-nested-components-b)) + (asdf:find-system 'test-nested-components-b)) :x (asdf::traverse (make-instance 'asdf:compile-op) - (asdf:find-system 'db-agraph-preflight)) + (asdf:find-system 'db-agraph-preflight)) (asdf::traverse (make-instance 'asdf:compile-op) - (asdf:find-system 'db-agraph-preflight-2)) + (asdf:find-system 'db-agraph-preflight-2)) )) #| @@ -31,9 +31,9 @@ (print (list (asdf::traverse (make-instance 'asdf:load-op) - (asdf:find-system 'test-nested-components-a)) + (asdf:find-system 'test-nested-components-a)) (asdf::traverse (make-instance 'asdf:load-op) - (asdf:find-system 'test-nested-components-b)))) + (asdf:find-system 'test-nested-components-b)))) |# diff --git a/test/test-retry-loading-component-1.script b/test/test-retry-loading-component-1.script index 6f2aff23cdb97afdb6759e9b8f879f4e43f5ec55..0975bb1a61e716d6ae42f033c214702a43b6c390 100644 --- a/test/test-retry-loading-component-1.script +++ b/test/test-retry-loading-component-1.script @@ -12,21 +12,21 @@ (quit-on-error (when (probe-file "try-reloading-dependency.asd") (asdf:run-shell-command "rm -f ~A" - (namestring "try-reloading-dependency.asd"))) + (namestring "try-reloading-dependency.asd"))) (setf asdf:*central-registry* '(*default-pathname-defaults*)) (setf asdf::*defined-systems* (asdf::make-defined-systems-table)) (handler-bind ((error (lambda (c) - (format t "~&Caught error ~s" c) - (setf *caught-error* t) - (asdf:run-shell-command - "cp try-reloading-dependency.hidden try-reloading-dependency.asd") - (multiple-value-bind (name mode) - (find-symbol (symbol-name 'retry) :asdf) - (assert (eq mode :external) nil "Mode of ~s was not external" name) - (let ((restart (find-restart name c))) - (assert restart) + (format t "~&Caught error ~s" c) + (setf *caught-error* t) + (asdf:run-shell-command + "cp try-reloading-dependency.hidden try-reloading-dependency.asd") + (multiple-value-bind (name mode) + (find-symbol (symbol-name 'retry) :asdf) + (assert (eq mode :external) nil "Mode of ~s was not external" name) + (let ((restart (find-restart name c))) + (assert restart) (format t "~&restart: ~S~&" restart) - (when restart (invoke-restart restart))))))) + (when restart (invoke-restart restart))))))) (asdf:oos 'asdf:load-op 'try-reloading-1)) (assert *caught-error*) ) diff --git a/test/test-touch-system-1.script b/test/test-touch-system-1.script index 356c7a912cf5ad35372fce56fd4322c8af491a41..0ddeefd597bede224484668676494c5baf78b7ef 100644 --- a/test/test-touch-system-1.script +++ b/test/test-touch-system-1.script @@ -7,13 +7,13 @@ (load "../asdf") (quit-on-error (flet ((system-load-time (name) - (let ((data (asdf::system-registered-p name))) - (when data - (car data))))) + (let ((data (asdf::system-registered-p name))) + (when data + (car data))))) (setf asdf:*central-registry* '(*default-pathname-defaults*)) (asdf:find-system :test1) (let ((date1 (system-load-time :test1)) - (file (namestring (merge-pathnames "test1.asd")))) + (file (namestring (merge-pathnames "test1.asd")))) (assert date1) (assert file) (sleep 1) diff --git a/test/test-touch-system-2.script b/test/test-touch-system-2.script index 56d5d829b8a9cdee430d14b607a2bebd196cc37a..82717fbaca41c5d3df1d6106d878850113e4c2a0 100644 --- a/test/test-touch-system-2.script +++ b/test/test-touch-system-2.script @@ -7,14 +7,14 @@ (load "../asdf") (quit-on-error (flet ((system-load-time (name) - (let ((data (asdf::system-registered-p name))) - (when data - (car data))))) + (let ((data (asdf::system-registered-p name))) + (when data + (car data))))) (setf asdf:*central-registry* nil) (load (merge-pathnames "test1.asd")) (assert (asdf:find-system :test1)) (let ((date1 (system-load-time :test1)) - (file (namestring (merge-pathnames "test1.asd")))) + (file (namestring (merge-pathnames "test1.asd")))) (assert date1) (assert file) (sleep 1) diff --git a/test/test-try-recompiling-1.script b/test/test-try-recompiling-1.script index 5ee2ccb173921498f49a8dfd197b55f8567ee70f..9dbc9a974ae5b98bd179085183c14cbd98cdf2d8 100644 --- a/test/test-try-recompiling-1.script +++ b/test/test-try-recompiling-1.script @@ -8,22 +8,22 @@ (quit-on-error (asdf:run-shell-command "rm -f ~A" - (namestring - (compile-file-pathname "try-recompiling-1"))) + (namestring + (compile-file-pathname "try-recompiling-1"))) (setf asdf:*central-registry* '(*default-pathname-defaults*)) (handler-bind ((error (lambda (c) - (setf *caught-error* t) - (multiple-value-bind (name mode) - (find-symbol - (symbol-name 'try-recompiling) - :asdf) - (assert (eq mode :external)) - (let ((restart (find-restart name c))) - #+(or) - ;; debug - (print (list c restart (compute-restarts c))) - (when restart - (invoke-restart restart))))))) + (setf *caught-error* t) + (multiple-value-bind (name mode) + (find-symbol + (symbol-name 'try-recompiling) + :asdf) + (assert (eq mode :external)) + (let ((restart (find-restart name c))) + #+(or) + ;; debug + (print (list c restart (compute-restarts c))) + (when restart + (invoke-restart restart))))))) (asdf:oos 'asdf:load-op 'try-recompiling-1)) (assert *caught-error*) ) diff --git a/test/test-version.script b/test/test-version.script index 5b4497c1c87c6a928146e647429d12f4090d5fcb..783cec887414e47d0cc6b4bf677c71bfc15346a7 100644 --- a/test/test-version.script +++ b/test/test-version.script @@ -22,8 +22,8 @@ :version "1.2") (flet ((test (name v &optional (true t)) - (or (eq true (asdf::version-satisfies (find-system name) v)) - (error "no satisfaction: ~S version ~A not ~A" name v true)))) + (or (eq true (asdf::version-satisfies (find-system name) v)) + (error "no satisfaction: ~S version ~A not ~A" name v true)))) (test :versioned-system-1 "1.0") (test :versioned-system-2 "1.0") (test :versioned-system-3 "2.0" nil)) diff --git a/test/test1.asd b/test/test1.asd index 423d7962efbe35338697e350937ce8906f21678a..6d50d3c1a59766b91feedfd234ccb47e774e275f 100644 --- a/test/test1.asd +++ b/test/test1.asd @@ -1,7 +1,7 @@ ;;; -*- Lisp -*- -(asdf:defsystem test1 +(asdf:defsystem test1 :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")))) - (:file "file1"))) + (:file "file1"))) #| 1) from clean, check that all fasl files build and that some function diff --git a/test/test1.script b/test/test1.script index b6f2fc9e7ee00aaaea46ed8cd5afe3e8c6a1e33d..7708ce483ed50ec622496ce3586e527058b1af56 100644 --- a/test/test1.script +++ b/test/test1.script @@ -20,7 +20,7 @@ (sleep 1) ; mtime has 1-second granularity, so pause here for fast machines (asdf::run-shell-command "rm -f ~A" - (namestring (compile-file-pathname "file2"))) + (namestring (compile-file-pathname "file2"))) (asdf:operate 'asdf:load-op 'test1) (assert (= file1-date (file-write-date (compile-file-pathname "file1")))) (assert (file-write-date (compile-file-pathname "file2"))) diff --git a/test/test2.asd b/test/test2.asd index 344d17f1b5883e55148e4f047767a4de97d6414d..31135f099dd68c014139a4d8a425b52f3a6a25f8 100644 --- a/test/test2.asd +++ b/test/test2.asd @@ -2,7 +2,7 @@ (asdf:defsystem test2b :version "1.0" :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")))) - (:file "file1")) + (:file "file1")) :depends-on (version 'test2a "1.1")) diff --git a/test/test2.script b/test/test2.script index 781fd3178266946a869fb4ff07a69162cc20b1ac..dda94476a5a95afe16a7b49dc1bace8c60d43a3a 100644 --- a/test/test2.script +++ b/test/test2.script @@ -3,12 +3,12 @@ (load "../asdf") (quit-on-error (setf asdf:*central-registry* '(*default-pathname-defaults*)) - ;(trace asdf::perform) - ;(trace asdf::find-component) - ;(trace asdf::traverse) + ;(trace asdf::perform) + ;(trace asdf::find-component) + ;(trace asdf::traverse) (asdf:oos 'asdf:load-op 'test2b1) (assert (and (probe-file (compile-file-pathname "file3")) - (probe-file (compile-file-pathname "file4")))) + (probe-file (compile-file-pathname "file4")))) (handler-case (asdf:oos 'asdf:load-op 'test2b2) (asdf:missing-dependency (c) diff --git a/test/test2a.asd b/test/test2a.asd index 0e031dbbc63777f9fcd7e8e20b54f01cd22ffcbb..c9de77ee98c1e0862476f84f1a2354f4e95c762c 100644 --- a/test/test2a.asd +++ b/test/test2a.asd @@ -2,7 +2,7 @@ (asdf:defsystem test2a :version "1.1" :components ((:file "file4" :in-order-to ((compile-op (load-op "file3")))) - (:file "file3"))) + (:file "file3"))) #| this system is referenced by test2b[12] |# diff --git a/test/test2b1.asd b/test/test2b1.asd index 985b352657eec8d90a941cb3cd71d46426e4f686..21b8fc09ffaf9d2efccf1691748aa7742aeb0bd7 100644 --- a/test/test2b1.asd +++ b/test/test2b1.asd @@ -2,7 +2,7 @@ (asdf:defsystem test2b1 :version "1.0" :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")))) - (:file "file1")) + (:file "file1")) :in-order-to ((load-op (load-op (version test2a "1.1"))))) diff --git a/test/test2b2.asd b/test/test2b2.asd index 3344fcd66182ed82390a54158b1eacec17d81ab4..6b294c30ed0fc52d3498c9ba010a878e82facc5b 100644 --- a/test/test2b2.asd +++ b/test/test2b2.asd @@ -2,7 +2,7 @@ (asdf:defsystem test2b2 :version "1.0" :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")))) - (:file "file1")) + (:file "file1")) :in-order-to ((load-op (load-op (version test2a "1.2"))))) diff --git a/test/test2b3.asd b/test/test2b3.asd index 36771cc896fc51f8dc03bebd38a4e3c58e201a55..9bc997fdc2a44e8cbb6f9b35a6a77f2de24d0344 100644 --- a/test/test2b3.asd +++ b/test/test2b3.asd @@ -2,7 +2,7 @@ (asdf:defsystem test2b3 :version "1.0" :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")))) - (:file "file1")) + (:file "file1")) :depends-on (bet-you-cant-find-this)) diff --git a/test/test3.asd b/test/test3.asd index 10f82c9c3b9bc21d73a4bc5eb00b034db62c242d..23848d6584ba9aa8a176a22250dec53730a8ebea 100644 --- a/test/test3.asd +++ b/test/test3.asd @@ -3,9 +3,9 @@ :properties ((:prop1 . "value")) :components ((:module "deps" - :if-component-dep-fails :try-next - :pathname "." - :components - ((:file "file1" :in-order-to ((compile-op (feature :f1)))) - (:file "file2" :in-order-to ((compile-op (feature :f2)))))))) + :if-component-dep-fails :try-next + :pathname "." + :components + ((:file "file1" :in-order-to ((compile-op (feature :f1)))) + (:file "file2" :in-order-to ((compile-op (feature :f2)))))))) diff --git a/test/test3.script b/test/test3.script index 3020fdac4952a534e56663f6cfa33383cc3e6d8a..d2a2b44d5adbef83cb7e9d4706d53c1c63889dea 100644 --- a/test/test3.script +++ b/test/test3.script @@ -8,16 +8,16 @@ (let ((fasl1 (compile-file-pathname (merge-pathnames "file1"))) (fasl2 (compile-file-pathname (merge-pathnames "file2")))) (asdf:run-shell-command "rm -f ~A ~A" - (namestring fasl1) - (namestring fasl2)) + (namestring fasl1) + (namestring fasl2)) (setf asdf:*central-registry* '(*default-pathname-defaults*)) (handler-case - (asdf:oos 'asdf:load-op 'test3) + (asdf:oos 'asdf:load-op 'test3) (asdf:missing-dependency (c) - (format t "first test failed as expected: - ~%~A~%" c)) + (format t "first test failed as expected: - ~%~A~%" c)) (:no-error (c) - (declare (ignore c)) - (error "should have failed, oops"))) + (declare (ignore c)) + (error "should have failed, oops"))) (pushnew :f1 *features*) (asdf:oos 'asdf:load-op 'test3) (assert (probe-file fasl1)) diff --git a/test/test5.asd b/test/test5.asd index a188a00e25f41247889d1d7119656cd745da3027..0f9e74377cf6ad515b22e27db3aeee0c4961197f 100644 --- a/test/test5.asd +++ b/test/test5.asd @@ -2,8 +2,8 @@ (asdf:defsystem test5 :components ((:module "deps" - :pathname "." - :components - ((:file "file1") - (:file "file2" :load-only-p t))))) + :pathname "." + :components + ((:file "file1") + (:file "file2" :load-only-p t)))))