/[cl-xml]/trunk/define-system.lisp
ViewVC logotype

Contents of /trunk/define-system.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2 - (show annotations)
Wed Feb 8 23:56:10 2006 UTC (8 years, 2 months ago) by banderson
File size: 8283 byte(s)
initial checkin of 0.918 codebase
1 ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: cl-user; -*-
2
3 #|
4 this defines a micro system definition function to support the
5 minimal system composition spec used for cl-http
6
7 (define-system ((<name symbol> &optional <documentation string>)
8 <operations (list (member :probe :compile :compile-load :compile-load-always :load))>
9 &rest <files (list string)>) )
10
11 |#
12
13 (in-package "CL-USER")
14
15 #+(or ALLEGRO LispWorks CormanLisp)
16 (unless (boundp '*.lisp-pathname*)
17 (defParameter *.lisp-pathname* (make-pathname :type "lisp")))
18
19 (defMacro define-system ((name &key description) (&rest operations) &body files)
20 `(execute-system-operations (register-system ',name :description ,description :files ',files)
21 ',operations))
22
23 #-(or ALLEGRO LispWorks) ;; this is here for convenience, but allegro already has a definition in EXCL
24 (defMacro defsystem (name &key source-pathname components &aux module-names)
25 `(progn
26 ,@(mapcar #'(lambda (module-spec)
27 (destructuring-bind (op name &key components) module-spec
28 (push name module-names)
29 (ecase op
30 (:module `(define-system (,name) ()
31 ,@(mapcar #'(lambda (file-spec)
32 (destructuring-bind (&key file) file-spec
33 (merge-pathnames file source-pathname)))
34 components))))))
35 components)
36 (define-system (,name) () ,@(reverse module-names))))
37
38 (defun call-with-src-and-bin (function filename)
39 (let ((src-pathname (merge-pathnames filename *.lisp-pathname*))
40 (bin-pathname (make-pathname :type "bin" :defaults filename)))
41 (funcall function filename src-pathname bin-pathname
42 (probe-file src-pathname) (probe-file bin-pathname))))
43
44 (defun conditional-compile-file (filename &key always)
45 (call-with-src-and-bin
46 #'(lambda (filename src bin probed-src probed-bin)
47 (cond (probed-src
48 (cond ((or always (null probed-bin) (> (file-write-date probed-src) (file-write-date probed-bin)))
49 (when *load-verbose*
50 (format *trace-output* "~%;Compiling ~s -> ~s..." src bin))
51 (compile-file probed-src :output-file (or probed-bin bin)))
52 (*load-verbose*
53 (format *trace-output* "~%;Skipped Compiling ~s." src))))
54 (t
55 (warn "file missing: ~s." filename))))
56 filename))
57
58 (defun conditional-load-file (filename)
59 (call-with-src-and-bin
60 #'(lambda (filename src bin probed-src probed-bin)
61 (declare (ignore src bin))
62 (cond ((and probed-bin (or (null probed-src) (>= (file-write-date probed-bin) (file-write-date probed-src))))
63 (when *load-verbose*
64 (format *trace-output* "~%;loading bin, ~:[no source~;newer~]." probed-src))
65 (load probed-bin))
66 (probed-src
67 (when *load-verbose*
68 (format *trace-output* "~%;loading source, ~:[no bin~;newer~]." probed-bin))
69 (load probed-src))
70 (t
71 (error "neither source nor binary file not found: ~s." filename))))
72 filename))
73
74 (defGeneric print-universal-time (stream time opt arg)
75 (:method ((stream t) (time integer) (opt t) (arg t))
76 (multiple-value-bind (second minute hour day month year) (decode-universal-time time)
77 (format stream "~4,'0d.~2,'0d.~2,'0dT~2,'0d:~2,'0d:~2,'0d" year month day hour minute second)))
78 (:method ((stream t) (time t) (opt t) (arg t))
79 (write-string "****.**.**T**:**:**" stream)))
80
81 (defun probe-file-src-and-bin (filename)
82 (call-with-src-and-bin
83 #'(lambda (filename src bin probed-src probed-bin)
84 (if probed-src
85 (when *load-verbose*
86 (format *trace-output*
87 "~%; ~s~@[ (@ ~/print-universal-time/)~] -> ~s~@[ (@ ~/print-universal-time/)~]..."
88 probed-src (file-write-date probed-src) bin (when probed-bin (file-write-date probed-bin))))
89 (warn "file missing: ~s (= ~s)." filename src)))
90 filename))
91
92 (defun find-system-named (name &rest options)
93 (etypecase name
94 (symbol
95 (unless (keywordp name) (setf name (intern (string-upcase name) "KEYWORD")))
96 (destructuring-bind (&key (if-does-not-exist nil) (if-exists name)) options
97 (cond ((eq name (get name :system-keyword))
98 (case if-exists
99 (:error
100 (error "Existing system named ~s found." name))
101 (t
102 if-exists)))
103 (t
104 (ecase if-does-not-exist
105 (:error
106 (error "No system named ~s found." name))
107 (:create
108 (setf (get name :system-keyword) name))
109 ((nil)
110 nil))))))
111 (string
112 (apply #'find-system-named (intern (string-upcase name) "KEYWORD") options))))
113
114 (defun system-property (system property &rest options &key (if-does-not-exist nil))
115 (when (setf system (apply #'find-system-named system :if-does-not-exist if-does-not-exist options))
116 (get system property)))
117
118 (defun (setf system-property) (new-value system property &rest options
119 &key (if-does-not-exist :error))
120 (when (setf system (apply #'find-system-named system :if-does-not-exist if-does-not-exist options))
121 (setf (get system property) new-value)))
122
123 (defun system-loaded-p (system)
124 (system-property system :system-load-time))
125
126 (defun register-system-definition (system pathname)
127 (setf (system-property system :system-pathname :if-does-not-exist :create) pathname))
128
129 (defun register-system (name &key description files)
130 (let ((system-keyword (find-system-named name :if-does-not-exist :create)))
131 (setf (system-property system-keyword :system-files) files)
132 (setf (system-property system-keyword :system-description) description)
133 (when (and (symbolp name) (not (keywordp name)))
134 (setf (get name :system-keyword) system-keyword))
135 system-keyword))
136
137 (defun execute-system-operations (system operations &aux files pathname)
138 (etypecase operations
139 (null system)
140 (cons
141 ;; if the system is not yet defined, but is registered, the load the definition
142 (unless (setf files (system-property system :system-files :if-does-not-exist :error))
143 (when (setf pathname (system-property system :system-pathname))
144 (conditional-load-file pathname))
145 (setf files (system-property system :system-files)))
146 (cond (files
147 (map nil #'(lambda (name)
148 (typecase name
149 ((or string pathname)
150 (dolist (op operations)
151 (when (functionp op)
152 (funcall op name))
153 (when (eq op :probe)
154 (probe-file-src-and-bin name))
155 (when (member op '(:compile :compile-load :compile-load-always))
156 (conditional-compile-file name :always (eq op :compile-load-always)))
157 (when (member op '(:load :compile-load :compile-load-always))
158 (conditional-load-file name))))
159 (symbol ; skip successive crossloads
160 (unless (and (system-loaded-p name)
161 (not (or (find :probe operations)
162 (find-if #'functionp operations))))
163 (execute-system-operations name operations)))))
164 files)
165 (when (intersection operations '(:load :compile-load :compile-load-always))
166 (setf (system-property system :system-load-time) (get-universal-time)))
167 system)
168 (t
169 (warn "no components present in system: ~s." system))))
170 (symbol
171 (execute-system-operations system (list operations)))
172 (function
173 (execute-system-operations system (list operations)))))
174
175
176 :EOF
177
178

  ViewVC Help
Powered by ViewVC 1.1.5