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

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

Fix typo in Lisp-based build.

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