source: tags/0.00.5/j/build-abcl.lisp

Last change on this file was 9300, checked in by piso, 19 years ago

LispWorks?

File size: 20.0 KB
Line 
1;;; build-abcl.lisp
2
3(defpackage build-abcl
4  (:use "COMMON-LISP")
5  (:export #:build-abcl)
6  #+abcl (:import-from #:extensions #:run-shell-command #:probe-directory)
7  #+allegro (:import-from #:excl #:probe-directory)
8  )
9
10(in-package #:build-abcl)
11
12(defparameter *platform-is-windows*
13  (let ((software-type (software-type)))
14    (if (and (stringp software-type)
15             (>= (length software-type) 7)
16             (string-equal (subseq software-type 0 7) "Windows"))
17        t
18        nil)))
19
20(defparameter *file-separator-char*
21  (if *platform-is-windows* #\\ #\/))
22
23(defparameter *path-separator-char*
24  (if *platform-is-windows* #\; #\:))
25
26#+armedbear
27(require 'format)
28
29#+sbcl
30(defun run-shell-command (command &key directory (output *standard-output*))
31  (when directory
32    (setf command (concatenate 'string
33                               "\\cd \""
34                               (namestring (pathname directory))
35                               "\" && "
36                               command)))
37  (sb-impl::process-exit-code
38   (sb-ext:run-program
39    "/bin/sh"
40    (list  "-c" command)
41    :input nil :output output)))
42
43#+cmu
44(defun run-shell-command (command &key directory (output *standard-output*))
45  (when directory
46    (setf command (concatenate 'string
47                               "\\cd \""
48                               (namestring (pathname directory))
49                               "\" && "
50                               command)))
51  (ext::process-exit-code
52   (ext:run-program
53    "/bin/sh"
54    (list  "-c" command)
55    :input nil :output output)))
56
57#+lispworks
58(defun run-shell-command (command &key directory (output *standard-output*))
59  (when directory
60    (unless *platform-is-windows*
61      (setf command (concatenate 'string
62                                 "\\cd \""
63                                 (namestring (pathname directory))
64                                 "\" && "
65                                 command))))
66  (system:call-system-showing-output
67   command
68   :shell-type "/bin/sh"
69   :output-stream output))
70
71#+allegro
72(defun run-shell-command (command &key directory (output *standard-output*))
73  (excl:run-shell-command command :directory directory :input nil :output output))
74
75#+(or sbcl cmu)
76(defun probe-directory (pathspec)
77  (let* ((truename (probe-file pathspec))
78         (namestring (and truename (namestring truename))))
79    (and namestring
80         (> (length namestring) 0)
81         (eql (char namestring (1- (length namestring))) *file-separator-char*)
82         truename)))
83
84(defparameter *jdk* nil)
85(defparameter *java-compiler* nil)
86(defparameter *javac-options* nil)
87(defparameter *jikes-options* nil)
88(defparameter *jar* nil)
89
90(defparameter *build-root*
91  (make-pathname :device (pathname-device *load-truename*)
92                 :directory (pathname-directory *load-truename*)))
93
94(defparameter *customizations-file*
95  (merge-pathnames "customizations.lisp" *build-root*))
96
97(defparameter *abcl-dir*
98  (merge-pathnames "src/org/armedbear/lisp/" *build-root*))
99
100(defparameter *substitutions-alist* nil)
101
102(defvar *classpath*)
103(defvar *java*)
104(defvar *java-compiler-options*)
105(defvar *java-compiler-command-line-prefix*)
106
107(defun initialize-build ()
108  (load *customizations-file*)
109  (setf *java* (probe-file (merge-pathnames (if *platform-is-windows*
110                                                "bin/java.exe"
111                                                "bin/java")
112                                            *jdk*)))
113  (unless *java*
114    (error "Can't find Java executable."))
115  (unless *java-compiler*
116    (setf *java-compiler* (merge-pathnames (if *platform-is-windows*
117                                               "bin/javac.exe"
118                                               "bin/javac")
119                                           *jdk*)))
120  (unless *jar*
121    (setf *jar* (merge-pathnames (if *platform-is-windows*
122                                     "bin/jar.exe"
123                                     "bin/jar")
124                                 *jdk*)))
125  (let ((classpath-components (list (merge-pathnames "src" *build-root*)
126                                    (merge-pathnames "jre/lib/rt.jar" *jdk*))))
127    (setf *classpath*
128          (with-output-to-string (s)
129            (do* ((components classpath-components (cdr components))
130                  (component (car components) (car components)))
131                 ((null components))
132              (princ #\" s)
133              (princ (namestring component) s)
134              (princ #\" s)
135              (unless (null (cdr components))
136                (write-char *path-separator-char* s))))))
137  (let ((prefix (concatenate 'string
138                             (namestring *java-compiler*)
139                             " -classpath " *classpath*)))
140    (setf *java-compiler-options*
141          (if (string-equal (pathname-name (pathname *java-compiler*)) "jikes")
142              *jikes-options*
143              *javac-options*))
144    (setf prefix
145          (if *java-compiler-options*
146              (concatenate 'string prefix " " *java-compiler-options* " ")
147              (concatenate 'string prefix " ")))
148    (setf *java-compiler-command-line-prefix* prefix)))
149
150(defun substitute-in-string (string substitutions-alist)
151  (dolist (entry substitutions-alist)
152    (let ((index (search (car entry) string :test #'string=)))
153      (when index
154        (setf string (concatenate 'string
155                                  (subseq string 0 index)
156                                  (cdr entry)
157                                  (subseq string (+ index (length (car entry)))))))))
158  string)
159
160(defun copy-with-substitutions (source-file target-file substitutions-alist)
161  (with-open-file (in source-file :direction :input)
162    (with-open-file (out target-file :direction :output :if-exists :supersede)
163      (loop
164        (let ((string (read-line in nil)))
165          (when (null string)
166            (return))
167          (write-line (substitute-in-string string substitutions-alist) out))))))
168
169(defun build-stamp ()
170  (multiple-value-bind
171    (second minute hour date month year day daylight-p zone)
172    (decode-universal-time (get-universal-time))
173    (declare (ignore daylight-p))
174    (setf day (nth day '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")))
175    (setf month (nth (1- month) '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
176                                  "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
177    (setf zone (* zone 100)) ;; FIXME
178    (format nil "~A ~A ~D ~D ~2,'0D:~2,'0D:~2,'0D -~4,'0D"
179            day month date year hour minute second zone)))
180
181(defun build-javac-command-line (source-file)
182  (concatenate 'string
183               *java-compiler-command-line-prefix*
184               (namestring source-file)))
185
186(defun java-compile-file (source-file)
187  (let ((cmdline (build-javac-command-line source-file)))
188    (zerop (run-shell-command cmdline :directory *abcl-dir*))))
189
190(defun make-jar ()
191  (let ((*default-pathname-defaults* *build-root*)
192        (jar-namestring (namestring *jar*)))
193    (when (position #\space jar-namestring)
194      (setf jar-namestring (concatenate 'string "\"" jar-namestring "\"")))
195    (let ((substitutions-alist (acons "@JAR@" jar-namestring nil))
196          (source-file (if *platform-is-windows* "make-jar.bat.in" "make-jar.in"))
197          (target-file (if *platform-is-windows* "make-jar.bat" "make-jar"))
198          (command (if *platform-is-windows* "make-jar.bat" "sh make-jar")))
199      (copy-with-substitutions source-file target-file substitutions-alist)
200      (let ((status (run-shell-command command :directory *build-root*)))
201        (unless (zerop status)
202          (format t "~A returned ~S~%" command status))
203        status))))
204
205(defun delete-files (pathnames)
206  (dolist (pathname pathnames)
207    ;; SBCL signals an error if the file doesn't exist.
208    (when (probe-file pathname)
209      (delete-file pathname))))
210
211(defun clean ()
212  (let ((*default-pathname-defaults* *abcl-dir*))
213    (delete-files (directory "*.class"))
214    (delete-files (directory "*.abcl"))
215    (delete-files (directory "*.cls"))
216    (delete-files '("native.h" "libabcl.so" "build")))
217  (let ((*default-pathname-defaults* (merge-pathnames "java/awt/" *abcl-dir*)))
218    (delete-files (directory "*.class"))))
219
220(defun safe-namestring (pathname)
221  (let ((string (namestring pathname)))
222    (when (position #\space string)
223      (setf string (concatenate 'string "\"" string "\"")))
224    string))
225
226(defun build-abcl (&key force
227                        (batch (if *platform-is-windows* nil t))
228                        compile-system
229                        jar
230                        clean
231                        libabcl
232                        full)
233  #+lispworks (setf batch nil)
234  (let ((start (get-internal-real-time))
235        end)
236    (initialize-build)
237    (when clean
238      (clean))
239    (let* ((source-files (append (let ((*default-pathname-defaults* *abcl-dir*))
240                                   (directory "*.java"))
241                                 (let ((*default-pathname-defaults*
242                                        (merge-pathnames "java/awt/" *abcl-dir*)))
243                                   (directory "*.java"))))
244           (to-do ()))
245      (if force
246          (setf to-do source-files)
247          (dolist (source-file source-files)
248            (let ((class-file (merge-pathnames (make-pathname :type "class"
249                                                              :defaults source-file))))
250              (when (or (null (probe-file class-file))
251                        (>= (file-write-date source-file)
252                            (file-write-date class-file)))
253                (push source-file to-do)))))
254      (cond ((null to-do)
255             (format t "~&Classes are up to date.~%"))
256            (t
257             (format t "~&JDK: ~A~%" *jdk*)
258             (format t "Java compiler: ~A~%" *java-compiler*)
259             (format t "Options: ~A~%" (if *java-compiler-options* *java-compiler-options* ""))
260             (cond (batch
261                    (let* ((dir (pathname-directory *abcl-dir*))
262                           (cmdline (with-output-to-string (s)
263                                      (princ *java-compiler-command-line-prefix* s)
264                                      (dolist (source-file to-do)
265                                        (princ
266                                         (if (equal (pathname-directory source-file) dir)
267                                             (file-namestring source-file)
268                                             (namestring source-file))
269                                         s)
270                                        (princ #\space s))))
271                           (status (run-shell-command cmdline :directory *abcl-dir*)))
272                      (unless (zerop status)
273                        (format t "Build failed.~%")
274                        (return-from build-abcl nil))))
275                   (t
276                    (dolist (source-file to-do)
277                      (unless (java-compile-file source-file)
278                        (format t "Build failed.~%")
279                        (return-from build-abcl nil)))))))
280      (when (or compile-system full)
281        (let* ((java-namestring (safe-namestring *java*))
282               status)
283          (cond (*platform-is-windows*
284                 (with-open-file (stream
285                                  (merge-pathnames "compile-system.bat" *build-root*)
286                                  :direction :output
287                                  :if-exists :supersede)
288                   (princ java-namestring stream)
289                   (write-string " -cp " stream)
290                   (princ "src" stream)
291                   (write-char #\space stream)
292                   (write-string "org.armedbear.lisp.Main --eval \"(compile-system :quit t)\"" stream))
293                 (setf status
294                       (run-shell-command "compile-system.bat"
295                                          :directory *build-root*)))
296                (t ; Linux
297                 (let ((cmdline
298                        (with-output-to-string (s)
299                          (princ java-namestring s)
300                          (write-string " -cp " s)
301                          (princ "src" s)
302                          (write-char #\space s)
303                          (write-string "org.armedbear.lisp.Main --eval \"(compile-system :quit t)\"" s))))
304                   (setf status
305                         (run-shell-command cmdline
306                                            :directory *build-root*)))))
307          (unless (zerop status)
308            (format t "Build failed.~%")
309            (return-from build-abcl nil))))
310
311      (when (or jar full)
312        (let ((status (make-jar)))
313          (unless (zerop status)
314            (format t "Build failed.~%")
315            (return-from build-abcl nil))))
316
317      (when (and (or full libabcl)
318                 (or (string= (software-type) "Linux")
319                     (string= (software-type) "SunOS")))
320        (and (let* ((javah-namestring (namestring (probe-file (merge-pathnames "bin/javah" *jdk*))))
321                    (command
322                     (format nil "~A -o org/armedbear/lisp/native.h org.armedbear.lisp.Native"
323                             javah-namestring))
324                    (status
325                     (run-shell-command command :directory (merge-pathnames "src/" *build-root*))))
326               (unless (zerop status)
327                 (format t "~A returned ~S~%" command status))
328               (zerop status))
329             (let* ((jdk-namestring (namestring *jdk*))
330                    (command
331                     (format nil "gcc -shared -o libabcl.so -O -D_REENTRANT -fpic -I~Ainclude -I~Ainclude/~A native.c"
332                             jdk-namestring jdk-namestring
333                             (cond ((string= (software-type) "Linux")
334                                    "linux")
335                                   ((string= (software-type) "SunOS")
336                                    "solaris"))))
337                    (status
338                     (run-shell-command command :directory *abcl-dir*)))
339               (unless (zerop status)
340                 (format t "~A returned ~S~%" command status))
341               (zerop status))))
342      ;; Success!
343
344      ;; abcl/abcl.bat
345      (cond (*platform-is-windows*
346             (with-open-file (s
347                              (merge-pathnames "abcl.bat" *build-root*)
348                              :direction :output
349                              :if-exists :supersede)
350               (format s "~A -cp ~A;~A org.armedbear.lisp.Main %1 %2 %3 %4 %5 %6 %7 %8 %9~%"
351                       (safe-namestring *java*)
352                       (safe-namestring (merge-pathnames "src" *build-root*))
353                       (safe-namestring (merge-pathnames "abcl.jar" *build-root*)))))
354            (t
355             (let ((pathname (merge-pathnames "abcl" *build-root*)))
356               (with-open-file (s pathname :direction :output :if-exists :supersede)
357                 (if (string= (software-type) "Linux")
358                     (format s "#!/bin/sh~%exec ~A -Xrs -Djava.library.path=~A -cp ~A:~A org.armedbear.lisp.Main \"$@\"~%"
359                             (safe-namestring *java*)
360                             (safe-namestring *abcl-dir*)
361                             (safe-namestring (merge-pathnames "src" *build-root*))
362                             (safe-namestring (merge-pathnames "abcl.jar" *build-root*)))
363                     ;; Not Linux.
364                     (format s "#!/bin/sh~%exec ~A -cp ~A:~A org.armedbear.lisp.Main \"$@\"~%"
365                             (safe-namestring *java*)
366                             (safe-namestring (merge-pathnames "src" *build-root*))
367                             (safe-namestring (merge-pathnames "abcl.jar" *build-root*)))))
368               (run-shell-command (format nil "chmod +x ~A" (safe-namestring pathname))
369                                  :directory *build-root*))))
370
371      (with-open-file (s
372                       (merge-pathnames (make-pathname :name "build"
373                                                       :defaults *abcl-dir*))
374                       :direction :output
375                       :if-exists :supersede)
376        (format s "~A" (build-stamp)))
377      (setf end (get-internal-real-time))
378      (format t "Build completed successfully in ~A seconds.~%"
379              (/ (float (- end start)) internal-time-units-per-second))
380      t)))
381
382(defun build-abcl-executable ()
383  (let* ((*default-pathname-defaults* *abcl-dir*)
384         (source-files (directory "*.java"))
385         (cmdline (with-output-to-string (s)
386                    (princ "gcj -O2 " s)
387                    (dolist (source-file source-files)
388                      (unless (string= (pathname-name source-file) "ControlC")
389                        (princ (pathname-name source-file) s)
390                        (princ ".java" s)
391                        (princ #\space s)))
392                    (princ "--main=org.armedbear.lisp.Main -o lisp" s)))
393         (result (run-shell-command cmdline :directory *abcl-dir*))
394         )
395    (zerop result)))
396
397(defvar *copy-verbose* nil)
398
399(defun copy-file (source target)
400  (when *copy-verbose*
401    (format t "~A -> ~A~%" source target))
402  (let ((buffer (make-array 4096 :element-type '(unsigned-byte 8))))
403    (with-open-file (in source :direction :input :element-type '(unsigned-byte 8))
404      (with-open-file (out target :direction :output :element-type '(unsigned-byte 8)
405                           :if-exists :supersede)
406        (loop
407          (let ((end (read-sequence buffer in)))
408            (when (zerop end)
409              (return))
410            (write-sequence buffer out :end end)))))))
411
412(defun copy-files (files source-dir target-dir)
413  (dolist (file files)
414    (copy-file (merge-pathnames file source-dir)
415               (merge-pathnames file target-dir))))
416
417(defun make-dist-dir (version-string)
418  (unless (string= (software-type) "Linux")
419    (error "MAKE-DIST is only supported on Linux."))
420  (let ((target-root (pathname (concatenate 'string "/var/tmp/" version-string "/"))))
421    (when (probe-directory target-root)
422      (error "Target directory ~S already exists." target-root))
423    (ensure-directories-exist
424     (merge-pathnames "src/org/armedbear/lisp/java/awt/" target-root))
425    (let* ((source-dir *build-root*)
426           (target-dir target-root)
427           (files (list "README"
428                        "COPYING"
429                        "build-abcl.lisp"
430                        "customizations.lisp"
431                        "make-jar.bat.in"
432                        "make-jar.in")))
433      (copy-files files source-dir target-dir))
434    (let* ((source-dir (merge-pathnames "src/" *build-root*))
435           (target-dir (merge-pathnames "src/" target-root))
436           (files (list "manifest-abcl")))
437      (copy-files files source-dir target-dir))
438    (let* ((source-dir *abcl-dir*)
439           (target-dir (merge-pathnames "src/org/armedbear/lisp/" target-root))
440           (*default-pathname-defaults* source-dir)
441           (files (mapcar #'file-namestring
442                          (append (directory "*.java") (directory "*.lisp") (list "LICENSE" "native.c")))))
443      (copy-files files source-dir target-dir))
444    (let* ((source-dir (merge-pathnames "java/awt/" *abcl-dir*))
445           (target-dir (merge-pathnames "src/org/armedbear/lisp/java/awt/" target-root))
446           (*default-pathname-defaults* source-dir)
447           (files (mapcar #'file-namestring (directory "*.java"))))
448      (copy-files files source-dir target-dir))
449    target-root))
450
451(defun make-dist (version-string)
452  (let* ((dist-dir (make-dist-dir version-string))
453         (parent-dir (merge-pathnames (make-pathname :directory '(:relative :back))
454                                      dist-dir)))
455    (let* ((command (format nil "tar czf ~A~A.tar.gz ~A"
456                            (namestring parent-dir)
457                            version-string version-string))
458           (status (run-shell-command command :directory parent-dir)))
459      (unless (zerop status)
460        (format t "~A returned ~S~%" command status)))
461    (let* ((command (format nil "zip -q -r ~A~A.zip ~A"
462                            (namestring parent-dir)
463                            version-string version-string))
464           (status (run-shell-command command :directory parent-dir)))
465      (unless (zerop status)
466        (format t "~A returned ~S~%" command status)))))
Note: See TracBrowser for help on using the repository browser.