Skip to content
Snippets Groups Projects
Commit 3d5b72d2 authored by Christophe Rhodes's avatar Christophe Rhodes
Browse files

Commit of my sources on general principles

parent a3240393
No related branches found
No related tags found
No related merge requests found
...@@ -84,6 +84,18 @@ ...@@ -84,6 +84,18 @@
;; because quite often that's not what we actually use it for) ;; because quite often that's not what we actually use it for)
(pathname :initarg :pathname))) (pathname :initarg :pathname)))
(defmethod string-unix-common-casify (string &key (start 0) end)
(unless end
(setf end (length string)))
(let ((result (copy-seq string)))
(cond
((every (lambda (x) (and (char>= x #\A) (char<= x #\Z))) (subseq string start end))
(nstring-downcase result :start start :end end))
((every (lambda (x) (and (char>= x #\a) (char<= x #\z))) (subseq string start end))
(nstring-upcase result :start start :end end))
(t result))))
(defmethod component-pathname ((component component)) (defmethod component-pathname ((component component))
(let ((*default-pathname-defaults* *component-parent-pathname*)) (let ((*default-pathname-defaults* *component-parent-pathname*))
(if (slot-boundp component 'pathname) (if (slot-boundp component 'pathname)
...@@ -91,8 +103,7 @@ ...@@ -91,8 +103,7 @@
(cond ((pathnamep p) (cond ((pathnamep p)
(merge-pathnames p)) (merge-pathnames p))
((and (stringp p) (> (length p) 0)) ((and (stringp p) (> (length p) 0))
(destructuring-bind (name type) (split p 2 '(#\.)) (merge-pathnames p))
(merge-pathnames (make-pathname :name name :type type))))
((and (stringp p) (= (length p) 0)) ((and (stringp p) (= (length p) 0))
*component-parent-pathname*) *component-parent-pathname*)
(t (t
...@@ -136,9 +147,10 @@ ...@@ -136,9 +147,10 @@
("java" . java-source-file))) ("java" . java-source-file)))
(defmethod component-relative-pathname ((component source-file)) (defmethod component-relative-pathname ((component source-file))
(make-pathname :name (component-name component) (make-pathname :name (string-unix-common-casify (component-name component))
:type (car (rassoc (class-name (class-of component)) :type (string-unix-common-casify (car (rassoc (class-name (class-of component))
*known-extensions* )))) *known-extensions*)))
:case :common))
(defclass c-source-file (source-file) ()) (defclass c-source-file (source-file) ())
(defclass java-source-file (source-file) ()) (defclass java-source-file (source-file) ())
...@@ -412,10 +424,13 @@ ...@@ -412,10 +424,13 @@
if b append b into bindings if b append b into bindings
finally (return (values initargs bindings)))) finally (return (values initargs bindings))))
;;; process-option returns as its first value a list of initargs that
;;; eventually gets appended to a call to reinitialize instance; its
;;; optional second value is a list of binding clauses suitable for a
;;; let that may be referred to in the initargs.
(defmethod process-option (option value) (defmethod process-option (option value)
(list option value)) (list option value))
#| #|
source-file components defined with (:file "a-string") or "a-string" source-file components defined with (:file "a-string") or "a-string"
will have the string parsed into name and type as if it were a will have the string parsed into name and type as if it were a
...@@ -434,7 +449,7 @@ default constituent type. ...@@ -434,7 +449,7 @@ default constituent type.
(cond ((eq ,keyword :file) (cond ((eq ,keyword :file)
(if extension (if extension
(cdr (assoc extension *known-extensions* :test 'equal)) (cdr (assoc extension *known-extensions* :test 'equal))
(module-default-component-class m))) (module-default-component-class component)))
((eq ,keyword :module) 'module) ((eq ,keyword :module) 'module)
(t (intern (symbol-name ,keyword) *package*))))) (t (intern (symbol-name ,keyword) *package*)))))
;; here's where we use asdf:component. This is probably a ;; here's where we use asdf:component. This is probably a
...@@ -503,8 +518,20 @@ default constituent type. ...@@ -503,8 +518,20 @@ default constituent type.
(defmethod process-option ((option (eql :source-pathname)) value) (defmethod process-option ((option (eql :source-pathname)) value)
(list :pathname value)) (list :pathname value))
(defmethod process-option ((option (eql :source-extension)) value)
;; we currently ignore this; arguably we shouldn't.
nil)
(defmethod process-option ((option (eql :binary-pathname)) value)
;; we currently ignore this
nil)
(defmethod process-option ((option (eql :binary-extension)) value)
;; we currently ignore this
nil)
(defmethod process-option ((option (eql :depends-on)) value) (defmethod process-option ((option (eql :depends-on)) value)
(list :in-order-to `((compile-system (load-system ,@value))))) (list :in-order-to `'((compile-system (load-system ,@value)))))
;;; initially-do (and finally-do) may need to be moved out of ;;; initially-do (and finally-do) may need to be moved out of
;;; mk-compatibility (or maybe renamed first...) ;;; mk-compatibility (or maybe renamed first...)
...@@ -529,3 +556,16 @@ default constituent type. ...@@ -529,3 +556,16 @@ default constituent type.
`((#:ignore `((#:ignore
(defmethod traverse :after ((,op load-system) (,c (eql component)) (,f (eql 'perform))) (defmethod traverse :after ((,op load-system) (,c (eql component)) (,f (eql 'perform)))
,value)))))) ,value))))))
(defmethod process-option ((option (eql :load-only)) value)
(let ((op (gensym "OPERATION"))
(c (gensym "COMPONENT")))
(when value
(values
nil
`((#:ignore
(defmethod perform ((,op compile-system) (,c (eql component)))
nil))
(#:ignore
(defmethod output-files ((,op compile-system) (,c (eql component)))
(list (component-pathname ,c)))))))))
\ No newline at end of file
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