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

Patches from Brian Seitz ("Another load patch") and David Lichteblau

("asdf:defsystem class bug")
parent dd2b8fe4
No related branches found
No related tags found
No related merge requests found
...@@ -315,12 +315,16 @@ system.")) ...@@ -315,12 +315,16 @@ system."))
(defclass cl-source-file (source-file) ()) (defclass cl-source-file (source-file) ())
(defclass c-source-file (source-file) ()) (defclass c-source-file (source-file) ())
(defclass java-source-file (source-file) ()) (defclass java-source-file (source-file) ())
(defclass static-file (source-file) ())
(defclass doc-file (static-file) ())
(defclass html-file (doc-file) ())
(defgeneric source-file-type (component system)) (defgeneric source-file-type (component system))
(defmethod source-file-type ((c cl-source-file) (s module)) "lisp") (defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
(defmethod source-file-type ((c c-source-file) (s module)) "c") (defmethod source-file-type ((c c-source-file) (s module)) "c")
(defmethod source-file-type ((c java-source-file) (s module)) "java") (defmethod source-file-type ((c java-source-file) (s module)) "java")
(defmethod source-file-type ((c static-file) (s module)) nil)
(defmethod component-relative-pathname ((component source-file)) (defmethod component-relative-pathname ((component source-file))
(let ((*default-pathname-defaults* (component-parent-pathname component))) (let ((*default-pathname-defaults* (component-parent-pathname component)))
(or (slot-value component 'relative-pathname) (or (slot-value component 'relative-pathname)
...@@ -329,10 +333,6 @@ system.")) ...@@ -329,10 +333,6 @@ system."))
(source-file-type component (source-file-type component
(component-system component)))))) (component-system component))))))
(defclass static-file (source-file) ())
(defclass doc-file (static-file) ())
(defclass html-file (doc-file) ())
(defmethod source-file-type ((c static-file) (s module)) nil)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; operations ;;; operations
...@@ -537,6 +537,7 @@ system.")) ...@@ -537,6 +537,7 @@ system."))
(defmethod perform ((operation compile-op) (c cl-source-file)) (defmethod perform ((operation compile-op) (c cl-source-file))
(let ((source-file (component-pathname c)) (let ((source-file (component-pathname c))
(output-file (car (output-files operation c)))) (output-file (car (output-files operation c))))
(setf (component-property c 'last-compiled) nil)
(multiple-value-bind (output warnings-p failure-p) (multiple-value-bind (output warnings-p failure-p)
(compile-file source-file (compile-file source-file
:output-file output-file) :output-file output-file)
...@@ -571,8 +572,11 @@ system.")) ...@@ -571,8 +572,11 @@ system."))
(defmethod perform ((o load-op) (c cl-source-file)) (defmethod perform ((o load-op) (c cl-source-file))
(let* ((co (make-sub-operation o 'compile-op)) (let* ((co (make-sub-operation o 'compile-op))
(output-files (output-files co c))) (output-files (output-files co c)))
(setf (component-property c 'last-loaded) (file-write-date (car output-files))) (setf (component-property c 'last-loaded)
(map nil #'load output-files))) (if (some #'not (map 'list #'load output-files))
nil
(file-write-date (car output-files))))))
(defmethod perform ((operation load-op) (c static-file)) (defmethod perform ((operation load-op) (c static-file))
nil) nil)
...@@ -591,7 +595,8 @@ system.")) ...@@ -591,7 +595,8 @@ system."))
(defmethod operation-done-p ((o load-op) (c source-file)) (defmethod operation-done-p ((o load-op) (c source-file))
(if (or (not (component-property c 'last-loaded)) (if (or (not (component-property c 'last-loaded))
(> (or (component-property c 'last-compiled) 0) (not (component-property c 'last-compiled))
(> (component-property c 'last-compiled)
(component-property c 'last-loaded))) (component-property c 'last-loaded)))
nil t)) nil t))
...@@ -613,12 +618,14 @@ system.")) ...@@ -613,12 +618,14 @@ system."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; syntax ;;; syntax
(defun remove-keyword (key arglist)
(loop for sublist = arglist then rest until (null sublist)
for (elt arg . rest) = sublist
unless (eq key elt) append (list elt arg)))
(defmacro defsystem (name &body options) (defmacro defsystem (name &body options)
(destructuring-bind (&key pathname (class 'system) &allow-other-keys) options (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options
(let ((component-options (let ((component-options (remove-keyword :class options)))
(if (member :class options)
(remove :class options)
options)))
`(progn `(progn
;; system must be registered before we parse the body, otherwise ;; system must be registered before we parse the body, otherwise
;; we recur when trying to find an existing system of the same name ;; we recur when trying to find an existing system of the same name
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment