1
;;; -*- Mode: Lisp; Package: MAKE; Syntax: Common-Lisp; Base: 10 -*- ;;;;
2
;; Copyright William F. Schelter 1989.
4
;; The author expressly permits copying and alteration of this file,
5
;; provided any modifications are clearly labeled, and this notice is
6
;; preserved. The author provides no warranty and this software is
7
;; provided on an 'as is' basis.
8
(in-package "MAKE" :use '("LISP") #+gcl :external #+gcl 11
9
#+gcl :internal #+gcl 79)
11
(export '(make system-load system-compile))
13
;;; ******* Description of Make Facility ************
14
;; We provide a simple MAKE facility to allow
15
;;compiling and loading of a tree of files
16
;;If the tree is '(a b (d e g h) i)
17
;; a will be loaded before b is compiled,
18
;; b will be loaded before d, e, g, h are compiled
19
;; d e g h will be loaded before i is compiled.
21
;; A record is kept of write dates of loaded compiled files, and a file
22
;;won't be reloaded if it is the same version (unless a force flag is t).
24
;;Thus if you do (make :uinfor) twice in a row, the second one would not
25
;;load anything. NOTE: If you change a, and a macro in it would affect
26
;;b, b still will not be recompiled. You must choose the :recompile t
27
;;option, to force the recompiling if you change macro files.
28
;;Alternately you may specify dependency information (see :depends below).
31
;;****** Sample file which when loaded causes system ALGEBRA
32
;; to be compiled and loaded ******
35
;;(use-package "MAKE")
36
;;(setf (get :algebra :make) '(a b (d e) l))
37
;;(setf (get :algebra :source-path) "/usr2/wfs/algebra/foo.lisp")
38
;;(setf (get :algebra :object-path) "/usr2/wfs/algebra/o/foo.o")
39
;;(make :algebra :compile t)
41
;; More complex systems may need to do some special operations
42
;;at certain points of the make.
43
;;the tree of files may contain some keywords which have special meaning.
44
;;eg. '(a b (:progn (gbc) (if make::*compile*
45
;; (format t "A and B finally compiled")))
49
;;then during the load and compile phases the function (gbc) will be
50
;;called after a and b have been acted on, and during the compile phase
51
;;the message about "A and B finally.." will be printed.
52
;;the lisp files h and i will be loaded after merging the paths with
53
;;the source directory. This feature is extensible: see the definitions
54
;;of :load-source and :progn.
56
;; The keyword feature is extensible, and you may specify what
57
;;happens during the load or compile phase for your favorite keyword.
58
;;To do this look at the definition of :progn, and :load-source
59
;;in the source for make.
64
;; This make NEVER loads or compiles files in an order different from
65
;;that specified by the tree. It will omit loading files which are
66
;;loaded and up to date, but if two files are out of date, the first (in
67
;;the printed representation of the tree), will always be loaded before
68
;;the second. A consequence of this is that circular dependencies can
71
;; If the :make tree contains (a b c d (:depends (c d) (a b))) then c
72
;;and d depend on a and b, so that if a or b need recompilation then c
73
;;and d will also be recompiled. Thus the general form of a :depends
74
;;clause is (:depends later earlier) where LATER and EARLIER are either
75
;;a single file or a list of files. Read it as LATER depends on EARLIER.
76
;;A declaration of a (:depends (c) (d)) would have no effect, since the
77
;;order in the tree already rules out such a dependence.
79
;; An easy way of specifying a linear dependence is by using :serial.
80
;;The tree (a (:serial b c d) e) is completely equivalent to the tree
81
;;(a b c d e (:depends c b)(:depends d (b c))), but with a long list of
82
;;serial files, it is inconvenient to specify them in the
83
;;latter representation.
85
;;A common case is a set of macros whose dependence is serial followed by a set
86
;;of files whose order is unimportant. A conventient way of building that
89
;;(let ((macros '(a b c d))
90
;; (files '(c d e f g)))
91
;; `((:serial ,@ macros)
93
;; (:depends ,files ,macros)))
95
;; The depends clause may occur anywhere within the tree, since
96
;;an initial pass collects all dependency information.
98
;; Make takes a SHOW keyword argument. It is almost impossible to simulate
99
;;all the possible features of make, for show. Nonetheless, it is good
100
;;to get an idea of the compiling and loading sequence for a new system.
101
;;As a byproduct, you could use the output, as a simple sequence of calls
102
;;to compile-file and load, to do the required work, when make is not around
106
;;***** Definitions ********
107
(defvar *files-loaded* nil)
108
(defvar *show-files-loaded* nil) ;only for show option
109
(defvar *load* nil "Will be non nil inside load-files")
110
(defvar *compile* nil "Bound by compile-files to t")
111
(defvar *depends* nil)
112
(defvar *depends-new* nil)
114
(defvar *when-compile* nil "Each compile-file evals things in this list and sets it to nil")
115
#+kcl(defvar *system-p* nil)
116
(defvar *compile-file-function* 'make-compile-file)
117
(defvar *load-function* 'make-load-file)
119
(defvar *cflags* #-kcl nil
120
#+kcl '(:system-p *system-p*))
123
;;this is the main entry point
125
(defun make (system &key recompile compile batch object-path source-path
127
&aux files *depends* *when-compile*
129
#+gcl (*load-fn-too* proclaims)
133
"SYSTEM is a tree of files, or a symbol with :make property. It
134
loads all file files in system. If COMPILE it will try to compile
135
files with newer source versions than object versions, before loading.
136
If RECOMPILE it will recompile all files. This is equivalent to deleting all
137
objects and using :compile t. SOURCE-PATH is merged with the name given
138
in the files list, when looking for a file to compile. OBJECT-PATH is
139
merged with the name in the files list, when looking for a file to
140
load. If SYSTEM is a symbol, then a null OBJECT-PATH would be set to
141
the :object-path property of SYSTEM. Similarly for :source-path"
143
(declare (special object-path source-path show)) batch
144
(cond ((symbolp system)
145
(or object-path (setf object-path (get system :object-path)))
146
(or source-path (setf source-path (get system :source-path)))
147
(setf files (get system :make))
149
(if (get system :files)
150
(error "Use :make property, :files property is obssolet{!")))
152
(t (setf files system)))
153
#+gcl (when proclaims (compiler::emit-fn t) (compiler::setup-sys-proclaims))
154
(let (#+lispm ( si::inhibit-fdefine-warnings
155
(if batch :just-warn si::inhibit-fdefine-warnings)))
156
(let ((*depends* (if (or compile recompile) (get-depends system)))
159
(when (or compile recompile)
160
(compile-files v recompile))
161
(load-files v recompile)))
163
(if proclaims (compiler::write-sys-proclaims))
166
(defun system-load (system-name &rest names)
167
"If :infor is a system, (system-load :uinfor joe betty) will load
168
joe and betty from the object-path for :uinfor"
169
(load-files names t (get system-name :object-path)))
171
(defun system-compile (system-name &rest names)
173
"If :iunfor is a system, (system-compile :uinfor joe) will in the
174
source path for joe and compile him into the object path for :uinfor"
175
(compile-files names t :source-path
176
(get system-name :source-path) :object-path
177
(get system-name :object-path)))
179
(defun get-depends (system-name &aux result)
180
(dolist (v (get system-name :make))
182
((eq (car v) :serial)
183
(do ((w (reverse (cdr v))(cdr w)))
185
(push (list (car w) (cdr w)) result)))
186
((eq (car v) :depends)
187
(push (cdr v) result ))))
191
(setq si::*default-time-zone* 6)
193
(defun print-date (&optional(stream *standard-output*)
194
(time (get-universal-time)))
195
(multiple-value-bind (sec min hr day mon yr wkday)
196
(decode-universal-time time)
197
(format stream "~a ~a ~a ~d:~2,'0d:~2,'0d ~a"
198
(nth wkday '( "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
199
(nth (1- mon) '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
200
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
204
;;This is an awfully roundabout downcase, but some machines
205
;;like symbolics swap cases on the pathname, so we have to do an extra
207
(defun lowcase (na &aux (*print-case* :downcase))
208
(pathname-name (pathname (format nil "~a" na))))
210
(defun our-merge (name path &optional ign ) ign
211
#+lispm (setq name (string-upcase (string name)))
212
(make-pathname :name (string name)
213
:type (pathname-type path)
214
:version (pathname-version path)
215
:host (pathname-host path)
216
:directory (pathname-directory path)))
220
(setf (get :link 'load)
221
#'(lambda (path to-link)
222
(declare (special object-path))
223
(si::faslink (our-merge (lowcase path) object-path)
226
(setf (get :link 'compile)
227
#'(lambda (path to-link)
229
(compile-files path *force*)))
231
(setf (get :progn 'load)
232
#'(lambda (&rest args)
233
(eval (cons 'progn args))))
235
(setf (get :progn 'compile) (get :progn 'load))
237
(setf (get :load-source 'load)
238
#'(lambda (&rest args)
239
(declare (special source-path))
240
(load-files args *force* source-path)))
242
(setf (get :load-source-when-compile 'compile)
243
(get :load-source 'load))
245
;;should nott use :lisp anymore
246
(setf (get :lisp 'load)
247
#'(lambda (x) (error "please replace :lisp by :load-source")))
249
(setf (get :serial 'load) #'(lambda (&rest l)(load-files l)))
250
(setf (get :serial 'compile)
257
(defun load-files (files &optional (*force* *force*) (object-path object-path)
258
&aux path tem (*load* t))
259
(declare (special object-path source-path *force* show))
261
(setq path (object files))
263
(unless (member path *show-files-loaded* :test 'equalp)
264
(push path *show-files-loaded*)
265
(format t "~%(LOAD ~s)" (namestring path))))
266
((null *load-function*))
269
(member path *files-loaded*
270
:test 'equalp :key 'car)))
271
(> (file-write-date path) (cdr (car tem)))))
272
(funcall *load-function* files)
273
(push (cons path (file-write-date path)) *files-loaded*))))
274
((keywordp (car files))
275
(let ((fun (get (car files) 'load)))
276
(cond (fun (apply fun (cdr files))))))
277
(t (dolist (v files) (load-files v *force* object-path)))))
280
(defun file-date (file)
281
(if (probe-file file) (or (file-write-date file) 0) 0))
284
(declare (special source-path))
285
(our-merge (lowcase file) source-path))
288
(declare (special object-path))
289
(our-merge (lowcase file) object-path))
292
;;for lisp machines, and others where checking date is slow, this
293
;;we should try to cache some dates, and then remove them as we do
294
;;things like compile files...
296
(defun file-out-dated (file)
297
(let ((obj-date (file-date (object file))))
298
(or (<= obj-date (file-date (source file)))
299
(dolist (v *depends*)
300
(cond ((or (and (consp (car v))
301
(member file (car v)))
303
(dolist (w (if (consp (second v))
305
(cond ((or (<= obj-date (file-date (source w)))
306
(member w *depends-new*))
307
(return-from file-out-dated t))))))))))
310
(defun make-compile-file ( l)
311
(format t "~&Begin compile ~a at ~a~%" l (print-date nil))
312
(dolist (v *when-compile*) (eval v))
313
(setq *when-compile* nil)
314
;;Franz excl needs pathnames quoted, and some other lisp
315
;;would not allow an apply here. Sad.
316
(eval `(compile-file ',(source l) :output-file ',(object l)
318
(format t "~&End compile ~a at ~a~%" l (print-date nil))
322
(defvar *load-fn-too* nil)
323
(defun make-load-file (l)
324
(let ((na (object l)))
326
(if (and *load-fn-too*
329
(our-merge (lowcase l) (merge-pathnames "foo.fn" na)))))
335
;;these are versions which don't really compile or load files, but
336
;;do create a new "compiled file" and "fake load" to test date mechanism.
338
(defun make-compile-file (file)
339
(format t "~%Fake Compile ~a" (namestring (source file)))
340
(dolist (v *when-compile*) (eval v)) (setq *when-compile* nil)
341
(with-open-file (st (object file) :direction :output)
342
(format st "(print (list 'hi))")))
344
(defun make-load-file (l)
345
(format t "~%Fake loading ~a" (namestring(object l))))
350
(defun compile-files (files &optional (*force* *force*)
351
&key (source-path source-path)
352
(object-path object-path)
355
(declare (special object-path source-path *force* show))
357
(when (or *force* (file-out-dated files))
358
(push files *depends-new*)
361
(format t "~%(COMPILE-FILE ~s)" (namestring (source files))))
363
(and *compile-file-function*
364
(funcall *compile-file-function* files))
366
((keywordp (car files))
367
(let ((fun (get (car files) 'compile)))
368
(if fun (apply fun (cdr files)))))
369
(t (dolist (v files) (compile-files v *force*)))))
371
;;Return the files for SYSTEM
373
(defun system-files (system &aux *files*)
374
(declare (special *files*))
375
(let ((sys (get system :make)))
380
(defun get-files1 (sys)
381
(declare (special *files*))
382
(cond ((and sys (atom sys) )(pushnew sys *files*))
383
((eq (car sys) :serial) (get-files1 (cdr sys)))
384
((keywordp (car sys)))
385
(t (dolist (v sys) (get-files1 v)))))
388
(defmacro make-user-init (files &aux (object-path
389
(if (boundp 'object-path) object-path
391
(declare (special object-path))
393
(clines "void init_or_load1 ();
394
#define init_or_load(fn,file) do {extern int fn(); init_or_load1(fn,file);} while(0)
397
(sloop::sloop for x in files
398
for f = (substitute #\- #\_ (lowcase x))
399
for ff = (namestring (truename (object x)))
401
`(clines ,(Format nil "init_or_load(init_~a,\"~a\");" f ff)))
added
removed
lsp/make.lisp
