source: trunk/abcl/build-abcl.lisp @ 13039

Last change on this file since 13039 was 13039, checked in by Mark Evenson, 10 years ago

Fix Lisp-based build (reported by Pascal J. Bourguignon).

  • Property svn:eol-style set to native
File size: 23.7 KB
Line 
1;;; build-abcl.lisp
2
3#+abcl
4(require 'format)
5
6(defpackage build-abcl
7  (:use "COMMON-LISP")
8  (:export #:build-abcl #:make-dist)
9  #+abcl (:import-from #:extensions #:run-shell-command #:probe-directory)
10  #+allegro (:import-from #:excl #:probe-directory)
11  #+clisp (:import-from #:ext #:probe-directory)
12  )
13
14(in-package #:build-abcl)
15
16(defun comp (string char)
17  "Chops off the character at the end of `string' if it matches char"
18  (let ((len (length string)))
19    (if (eql char (char string (1- len)))
20        (subseq string 0 (1- len))
21        string)))
22
23(defun safe-namestring (pathname)
24  (let* ((string (namestring pathname))
25         (len (length string)))
26    (when (position #\space string)
27      (setf string (concatenate 'string "\""
28                                (comp string #\\)
29                                "\"")))
30    string))
31
32
33(defun child-pathname (pathname parent)
34  "Returns `pathname' relative to `parent', assuming that it
35is infact a child of it while being rooted at the same root as `parent'."
36  (let ((path-dir (pathname-directory pathname))
37        (parent-dir (pathname-directory parent)))
38    (do ((p1 path-dir (cdr p1))
39         (p2 parent-dir (cdr p2)))
40        ((or (endp p2) (not (equal (car p1) (car p2))))
41         (when (endp p2)
42           (make-pathname :directory (cons :relative p1)
43                          :defaults pathname))))))
44
45
46(defun file-newer (orig artifact)
47  "Compares file date/time of `orig' and `artifact', returning
48`NIL' if `orig' is newer than `artifact'."
49  (or (null (probe-file artifact))
50      (> (file-write-date orig)
51         (file-write-date artifact))))
52
53
54
55;; Platform detection.
56
57(defun platform ()
58  #-clisp
59  (let ((software-type (software-type)))
60    (cond ((search "Linux" software-type)
61           :linux)
62          ((or (search "Mac OS X" software-type) ; abcl
63               (search "Darwin" software-type))  ; sbcl
64           :darwin)
65          ((search "Windows" software-type)
66           :windows)
67          (t
68           :unknown)))
69  #+clisp
70  (cond ((member :win32 *features*)
71         :windows)
72        ((zerop (ext:run-shell-command "uname | grep -i darwin" :output nil))
73         :darwin)
74        ((zerop (ext:run-shell-command "uname | grep -i linux" :output nil))
75         :linux)
76        (t
77         :unknown)))
78
79(defparameter *platform* (platform))
80
81(defparameter *file-separator-char*
82  (if (eq *platform* :windows) #\\ #\/))
83
84(defparameter *path-separator-char*
85  (if (eq *platform* :windows) #\; #\:))
86
87
88#+sbcl
89(defun run-shell-command (command &key directory (output *standard-output*))
90  (when directory
91    (setf command (concatenate 'string
92                               "\\cd \""
93                               (namestring (pathname directory))
94                               "\" && "
95                               command)))
96  (sb-ext:process-exit-code
97   (sb-ext:run-program
98    "/bin/sh"
99    (list  "-c" command)
100    :input nil :output output)))
101
102#+cmu
103(defun run-shell-command (command &key directory (output *standard-output*))
104  (when directory
105    (setf command (concatenate 'string
106                               "\\cd \""
107                               (namestring (pathname directory))
108                               "\" && "
109                               command)))
110  (ext::process-exit-code
111   (ext:run-program
112    "/bin/sh"
113    (list  "-c" command)
114    :input nil :output output)))
115
116#+clisp
117(defun run-shell-command (command &key directory (output *standard-output*))
118  (declare (ignore output)) ;; FIXME
119  (let (status old-directory)
120    (when directory
121      (setf old-directory (ext:cd))
122      (ext:cd directory))
123    (unwind-protect
124        (setf status (ext:shell command))
125      (when old-directory
126        (ext:cd old-directory)))
127    (cond ((numberp status)
128           status)
129          ((or (eq status t) (null status)) ;; clisp 2.47 returns NIL on success
130           0)
131          (t
132           -1))))
133
134#+lispworks
135(defun run-shell-command (command &key directory (output *standard-output*))
136  (when directory
137    (unless (eq *platform* :windows)
138      (setf command (concatenate 'string
139                                 "\\cd \""
140                                 (namestring (pathname directory))
141                                 "\" && "
142                                 command))))
143  (system:call-system-showing-output command
144                                     :shell-type "/bin/sh"
145                                     :output-stream output))
146
147#+allegro
148(defun run-shell-command (command &key directory (output *standard-output*))
149  (excl:run-shell-command command
150                          :directory directory
151                          :input nil
152                          :output #+ide nil #-ide output))
153
154#+openmcl
155(defun run-shell-command (command &key directory (output *standard-output*))
156  (when directory
157    (setf command (concatenate 'string
158                               "\\cd \""
159                               (namestring (pathname directory))
160                               "\" && "
161                               command)))
162  (multiple-value-bind (status exitcode)
163      (ccl:external-process-status
164       (ccl:run-program
165        "/bin/sh"
166        (list  "-c" command)
167        :wait t :input nil :output output))
168    (declare (ignore status))
169    exitcode))
170
171#+(or sbcl cmu lispworks openmcl)
172(defun probe-directory (pathspec)
173  (let* ((truename (probe-file pathspec)) ; TRUENAME is a pathname.
174         (namestring (and truename (namestring truename)))) ; NAMESTRING is a string.
175    (and namestring
176         (> (length namestring) 0)
177         (eql (char namestring (1- (length namestring))) *file-separator-char*)
178         truename)))
179
180(defparameter *tree-root*
181  (make-pathname :device (pathname-device *load-truename*)
182                 :directory (pathname-directory *load-truename*)))
183(defparameter *build-root*
184  (merge-pathnames "build/classes/" *tree-root*))
185(defparameter *source-root*
186  (merge-pathnames "src/" *tree-root*))
187(defparameter *dist-root*
188  (merge-pathnames "dist/" *tree-root*))
189
190
191(defparameter *customizations-file*
192  (merge-pathnames "customizations.lisp" *tree-root*))
193
194(defparameter *abcl-dir*
195  (merge-pathnames "src/org/armedbear/lisp/" *tree-root*))
196
197(defparameter *jdk*           nil)
198(defparameter *java-compiler* nil)
199(defparameter *javac-options* nil)
200(defparameter *jikes-options* nil)
201(defparameter *jar*           nil)
202
203(defvar *classpath*)
204(defvar *java*)
205(defvar *java-compiler-options*)
206(defvar *java-compiler-command-line-prefix*)
207
208(defun initialize-build ()
209  (setf *jdk*           nil
210        *java-compiler* nil
211        *javac-options* nil
212        *jikes-options* nil
213        *jar*           nil)
214  (load *customizations-file*)
215  (setf *java* (probe-file (merge-pathnames (if (eq *platform* :windows)
216                                                "bin\\java.exe"
217                                                "bin/java")
218                                            *jdk*)))
219  (unless *java*
220    (error "Can't find Java executable."))
221  (unless *java-compiler*
222    (setf *java-compiler* (merge-pathnames (if (eq *platform* :windows)
223                                               "bin/javac.exe"
224                                               "bin/javac")
225                                           *jdk*)))
226  (unless *jar*
227    (setf *jar* (merge-pathnames (if (eq *platform* :windows)
228                                     "bin/jar.exe"
229                                     "bin/jar")
230                                 *jdk*)))
231  (let ((classpath-components (list *source-root*
232                                    (if (eq *platform* :darwin)
233                                        #p"/System/Library/Frameworks/JavaVM.framework/Classes/classes.jar"
234                                        (merge-pathnames "jre/lib/rt.jar" *jdk*)))))
235    (setf *classpath*
236          (with-output-to-string (s)
237            (do* ((components classpath-components (cdr components))
238                  (component (car components) (car components)))
239                 ((null components))
240              (princ (safe-namestring component) s)
241              (unless (null (cdr components))
242                (write-char *path-separator-char* s))))))
243  (let ((prefix (concatenate 'string
244                             (safe-namestring *java-compiler*)
245                             " -classpath " *classpath*)))
246    (setf *java-compiler-options*
247          (if (string-equal (pathname-name (pathname *java-compiler*)) "jikes")
248              *jikes-options*
249              *javac-options*))
250    (setf prefix
251          (if *java-compiler-options*
252              (concatenate 'string prefix " " *java-compiler-options* " ")
253              (concatenate 'string prefix " ")))
254    (setf *java-compiler-command-line-prefix* prefix)))
255
256(defun substitute-in-string (string substitutions-alist)
257  (dolist (entry substitutions-alist)
258    (loop named replace
259         for index = (search (car entry) string :test #'string=)
260         do
261         (unless index
262           (return-from replace))
263         (setf string (concatenate 'string
264                                   (subseq string 0 index)
265                                   (cdr entry)
266                                   (subseq string (+ index (length (car entry))))))))
267  string)
268
269(defun copy-with-substitutions (source-file target-file substitutions-alist)
270  (with-open-file (in source-file :direction :input)
271    (with-open-file (out target-file :direction :output :if-exists :supersede)
272      (loop
273        (let ((string (read-line in nil)))
274          (when (null string)
275            (return))
276          (write-line (substitute-in-string string substitutions-alist) out))))))
277
278(defun build-javac-command-line (source-file)
279  (concatenate 'string
280               *java-compiler-command-line-prefix*
281               " -d "
282               (safe-namestring *build-root*)
283               " "
284               (namestring source-file)))
285
286(defun java-compile-file (source-file)
287  (let ((cmdline (build-javac-command-line source-file)))
288    (zerop (run-shell-command cmdline :directory *abcl-dir*))))
289
290(defun make-classes (force batch)
291  (let* ((source-files
292          (remove-if-not
293           #'(lambda (name)
294               (let ((output-name
295                      (merge-pathnames
296                       (make-pathname :type "class"
297                                      :defaults (child-pathname name
298                                                                *source-root*))
299                       *build-root*)))
300                 (or force
301                     (file-newer name output-name))))
302           (mapcan #'(lambda (default)
303                       (directory (merge-pathnames "*.java"
304                                                   default)))
305                   (list *abcl-dir*
306                         (merge-pathnames "util/" *abcl-dir*))))))
307    (format t "~&JDK: ~A~%" *jdk*)
308    (format t "Java compiler: ~A~%" *java-compiler*)
309    (format t "Compiler options: ~A~%~%" (if *java-compiler-options* *java-compiler-options* ""))
310    (finish-output)
311    (cond ((null source-files)
312           (format t "Classes are up to date.~%")
313           (finish-output)
314           t)
315          (t
316           (cond (batch
317                  (ensure-directories-exist *build-root*)
318                  (let* ((dir (pathname-directory *abcl-dir*))
319                         (cmdline (with-output-to-string (s)
320                                    (princ *java-compiler-command-line-prefix* s)
321                                    (princ " -d " s)
322                                    (princ (safe-namestring *build-root*) s)
323                                    (princ #\Space s)
324                                    (dolist (source-file source-files)
325                                      (princ
326                                       (safe-namestring
327                                        (if (equal (pathname-directory source-file) dir)
328                                            (file-namestring source-file)
329                                            (namestring source-file)))
330                                       s)
331                                      (princ #\space s))))
332                         (status (run-shell-command cmdline :directory *abcl-dir*)))
333                    (zerop status)))
334                 (t
335                  (ensure-directories-exist *build-root*)
336                  (dolist (source-file source-files t)
337                    (unless (java-compile-file (safe-namestring source-file))
338                      (format t "Build failed.~%")
339                      (return nil)))))))))
340
341(defun make-jar ()
342  (let ((*default-pathname-defaults* *tree-root*)
343        (jar-namestring (namestring *jar*)))
344    (when (position #\space jar-namestring)
345      (setf jar-namestring (concatenate 'string "\"" jar-namestring "\"")))
346    (let ((substitutions-alist (acons "@JAR@" jar-namestring nil))
347          (source-file (if (eq *platform* :windows) "make-jar.bat.in" "make-jar.in"))
348          (target-file (if (eq *platform* :windows) "make-jar.bat"    "make-jar"))
349          (command     (if (eq *platform* :windows) "make-jar.bat"    "sh make-jar")))
350      (copy-with-substitutions source-file target-file substitutions-alist)
351      (ensure-directories-exist *dist-root*)
352      (let ((status (run-shell-command command :directory *tree-root*)))
353        (unless (zerop status)
354          (format t "~A returned ~S~%" command status))
355        status))))
356
357(defun do-compile-system (&key (zip t))
358  (terpri)
359  (finish-output)
360  (let* ((java-namestring (safe-namestring *java*))
361         status
362         (abcl-home (substitute-in-string
363                     (namestring *abcl-dir*)
364                     (when (eq *platform* :windows)
365                       '(("\\" . "/")
366                         ("/" . "\\\\")))))
367         (output-path (substitute-in-string
368                       (namestring
369                        (merge-pathnames "build/classes/org/armedbear/lisp/"
370                                         *tree-root*))
371                       (when (eq *platform* :windows)
372                         '(("\\" . "/")))))
373         (cmdline (format nil
374                          "~A -cp build/classes -Dabcl.home=\"~A\" ~
375org.armedbear.lisp.Main --noinit --nosystem ~
376--eval \"(compile-system :zip ~A :quit t :output-path \\\"~A\\\")\"~%"
377                          java-namestring
378                          abcl-home
379                          (not (not zip)) ;; because that ensures T or NIL
380                          output-path)))
381    (ensure-directories-exist output-path)
382    (setf status
383          (run-shell-command cmdline
384                             :directory *tree-root*))
385    status))
386
387
388;; abcl/abcl.bat
389(defun make-launch-script ()
390  ;; Use the -Xss4M and -Xmx256M flags so that the default launch script can be
391  ;; used to build sbcl.
392  (cond ((eq *platform* :windows)
393         (with-open-file (s
394                          (merge-pathnames "abcl.bat" *tree-root*)
395                          :direction :output
396                          :if-exists :supersede)
397           (format s "~A -Xss4M -Xmx256M -cp \"~A\" org.armedbear.lisp.Main %1 %2 %3 %4 %5 %6 %7 %8 %9~%"
398                   (safe-namestring *java*)
399                   (namestring (merge-pathnames "dist\\abcl.jar" *tree-root*)))))
400        (t
401         (let ((pathname (merge-pathnames "abcl" *tree-root*)))
402           (with-open-file (s pathname :direction :output :if-exists :supersede)
403             (format s "#!/bin/sh~%exec ~A -Xss4M -Xmx256M -cp ~A org.armedbear.lisp.Main \"$@\"~%"
404                     (safe-namestring *java*)
405                     (safe-namestring (merge-pathnames "abcl.jar" *dist-root*))))
406           (run-shell-command (format nil "chmod +x ~A" (safe-namestring pathname))
407                              :directory *tree-root*)))))
408
409(defun build-stamp ()
410  (multiple-value-bind
411      (second minute hour date month year day daylight-p zone)
412      (decode-universal-time (get-universal-time))
413    (declare (ignore daylight-p))
414    (setf day (nth day '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")))
415    (setf month (nth (1- month) '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
416                                  "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
417    (setf zone (* zone 100)) ;; FIXME
418    (format nil "~A ~A ~D ~D ~2,'0D:~2,'0D:~2,'0D -~4,'0D"
419            day month date year hour minute second zone)))
420
421(defun make-build-stamp ()
422  (with-open-file (s
423                   (merge-pathnames (make-pathname :name "build"
424                                                   :defaults *abcl-dir*))
425                   :direction :output
426                   :if-exists :supersede)
427    (format s "~A" (build-stamp))))
428
429(defun delete-files (pathnames)
430  (dolist (pathname pathnames)
431    (let ((truename (probe-file pathname)))
432      (when truename
433        (delete-file truename)))))
434
435(defun clean ()
436  (dolist (f (list (list *tree-root* "abcl.jar" "abcl.bat" "make-jar.bat"
437                         "compile-system.bat")
438                   ;; as of 0.14 'compile-system.bat' isn't created anymore
439                   ;; as of 0.14 'abcl.jar' is always created in dist/
440                   (list *abcl-dir* "*.class" "*.abcl" "*.cls"
441                                    "native.h" "libabcl.so" "build")
442                   ;; as of 0.14, native.h and libabcl.so have been removed
443                   (list (merge-pathnames "util/" *abcl-dir*) "*.class")
444                   (list (merge-pathnames "build/classes/org/armedbear/lisp/"
445                                          *tree-root*)
446                                    "*.class" "*.abcl" "*.cls"
447                                    "native.h" "libabcl.so" "build")
448                   (list (merge-pathnames
449                          "build/classes/org/armedbear/lisp/util/"
450                          *tree-root*)
451                                    "*.class" "*.abcl" "*.cls")
452                   (list *dist-root* "*.jar" "*.class" "*.abcl" "*.cls")
453                  (list (merge-pathnames "java/awt/" *abcl-dir*)
454                         "*.class")))
455    (let ((default (car f)))
456      (when (probe-directory default)
457        (delete-files (mapcan #'(lambda (name)
458                                  (directory (merge-pathnames name default)))
459                              (cdr f)))))))
460
461(defun build-abcl (&key force
462                        (batch t)
463                        compile-system
464                        jar
465                        clean
466                        full)
467  (let ((start (get-internal-real-time)))
468
469    #+lispworks
470    (when (eq *platform* :windows)
471      (setf batch nil))
472
473    (initialize-build)
474    (format t "~&Platform: ~A~%"
475            (case *platform*
476              (:windows "Windows")
477              (:linux   "Linux")
478              (:darwin  "Mac OS X")
479              (t        (software-type))))
480    (finish-output)
481    ;; clean
482    (when clean
483      (clean))
484    ;; classes
485    (unless (make-classes force batch)
486      (format t "Build failed.~%")
487      (return-from build-abcl nil))
488    ;; COMPILE-SYSTEM
489    (when (or full compile-system)
490      (let* ((zip    (if (or full jar) nil t))
491             (status (do-compile-system :zip zip)))
492        (unless (zerop status)
493          (format t "Build failed.~%")
494          (return-from build-abcl nil))))
495    ;; abcl.jar
496    (when (or full jar)
497      (let ((status (make-jar)))
498        (unless (zerop status)
499          (format t "Build failed.~%")
500          (return-from build-abcl nil))))
501    ;; abcl/abcl.bat
502    (make-launch-script)
503    (make-build-stamp)
504    (let ((end (get-internal-real-time)))
505      (format t "Build completed successfully in ~A seconds.~%"
506              (/ (float (- end start)) internal-time-units-per-second)))
507    t))
508
509(defun build-abcl-executable ()
510  (let* ((*default-pathname-defaults* *abcl-dir*)
511         (source-files (directory "*.java"))
512         (cmdline (with-output-to-string (s)
513                    (princ "gcj -g -O0 " s)
514                    (dolist (source-file source-files)
515                      (unless (string= (pathname-name source-file) "Native")
516                        (princ (pathname-name source-file) s)
517                        (princ ".java" s)
518                        (princ #\space s)))
519                    (princ "--main=org.armedbear.lisp.Main -o lisp" s)))
520         (result (run-shell-command cmdline :directory *abcl-dir*)))
521    (zerop result)))
522
523(defvar *copy-verbose* nil)
524
525(defun copy-file (source target)
526  (when *copy-verbose*
527    (format t "~A -> ~A~%" source target))
528  (let ((buffer (make-array 4096 :element-type '(unsigned-byte 8))))
529    (with-open-file (in source :direction :input :element-type '(unsigned-byte 8))
530      (with-open-file (out target :direction :output :element-type '(unsigned-byte 8)
531                           :if-exists :supersede)
532        (loop
533          (let ((end (read-sequence buffer in)))
534            (when (zerop end)
535              (return))
536            (write-sequence buffer out :end end)))))))
537
538(defun copy-files (files source-dir target-dir)
539  (ensure-directories-exist target-dir)
540  (dolist (file files)
541    (copy-file (merge-pathnames file source-dir)
542               (merge-pathnames file target-dir))))
543
544(defun make-dist-dir (version-string)
545  (unless (eq *platform* :linux)
546    (error "MAKE-DIST is only supported on Linux."))
547  (let ((target-root (pathname (concatenate 'string "/var/tmp/" version-string "/"))))
548    (when (probe-directory target-root)
549      (error "Target directory ~S already exists." target-root))
550    (let* ((source-dir *tree-root*)
551           (target-dir target-root)
552           (files (list "README"
553                        "COPYING"
554                        "build-abcl.lisp"
555                        "customizations.lisp"
556                        "make-jar.bat.in"
557                        "make-jar.in")))
558      (copy-files files source-dir target-dir))
559    (let* ((source-dir (merge-pathnames "examples/" *tree-root*))
560           (target-dir (merge-pathnames "examples/" target-root))
561           (files '("hello.java")))
562      (copy-files files source-dir target-dir))
563    (let* ((target-dir (merge-pathnames "src/" target-root))
564           (files '("manifest-abcl")))
565      (copy-files files *source-root* target-dir))
566    (let* ((source-dir *abcl-dir*)
567           (target-dir (merge-pathnames "src/org/armedbear/lisp/" target-root))
568           (*default-pathname-defaults* source-dir)
569           (files (mapcar #'file-namestring (append (directory "*.java")
570                                                    (directory "*.lisp")
571                                                    (list "LICENSE" "native.c")))))
572      (copy-files files source-dir target-dir))
573    (let* ((source-dir (merge-pathnames "tests/" *abcl-dir*))
574           (target-dir (merge-pathnames "src/org/armedbear/lisp/tests/" target-root))
575           (*default-pathname-defaults* source-dir)
576           (files (append (mapcar #'file-namestring (directory "*.lisp"))
577                          (list "jl-config.cl"))))
578      (copy-files files source-dir target-dir))
579    (let* ((source-dir (merge-pathnames "java/awt/" *abcl-dir*))
580           (target-dir (merge-pathnames "src/org/armedbear/lisp/java/awt/" target-root))
581           (*default-pathname-defaults* source-dir)
582           (files (mapcar #'file-namestring (directory "*.java"))))
583      (copy-files files source-dir target-dir))
584    target-root))
585
586(defun make-dist (version-string)
587  (let* ((dist-dir (make-dist-dir version-string))
588         (parent-dir (merge-pathnames (make-pathname :directory '(:relative :back))
589                                      dist-dir)))
590    (let* ((command (format nil "tar czf ~A~A.tar.gz ~A"
591                            (namestring parent-dir)
592                            version-string version-string))
593           (status (run-shell-command command :directory parent-dir)))
594      (unless (zerop status)
595        (format t "~A returned ~S~%" command status)))
596    (let* ((command (format nil "zip -q -r ~A~A.zip ~A"
597                            (namestring parent-dir)
598                            version-string version-string))
599           (status (run-shell-command command :directory parent-dir)))
600      (unless (zerop status)
601        (format t "~A returned ~S~%" command status)))))
Note: See TracBrowser for help on using the repository browser.