source: trunk/abcl/contrib/abcl-build/build/deprecated.lisp

Last change on this file was 15537, checked in by Mark Evenson, 3 years ago

abcl-build: correct deprecated JAVA-COMPILE-FILE

File size: 18.9 KB
Line 
1;;;; Historic cross platform build infrastructure
2;;;; N.b. currently unused in favor of canonicalizing build.xml
3
4(in-package :abcl/build)
5
6(defun chop-end-from-char (string char)
7  "Chops off the character at the end of `string' if it matches char"
8  (let ((len (length string)))
9    (if (eql char (char string (1- len)))
10        (subseq string 0 (1- len))
11        string)))
12
13(defun safe-namestring (pathname)
14  (let ((string (namestring pathname)))
15    (when (position #\space string)
16      (setf string (concatenate 'string "\""
17                                (chop-end-from-char string #\\)
18                                "\"")))
19    string))
20
21(defun child-pathname (pathname parent)
22  "Returns `pathname' relative to `parent', assuming that it
23is infact a child of it while being rooted at the same root as `parent'."
24  (let ((path-dir (pathname-directory pathname))
25        (parent-dir (pathname-directory parent)))
26    (do ((p1 path-dir (cdr p1))
27         (p2 parent-dir (cdr p2)))
28        ((or (endp p2) (not (equal (car p1) (car p2))))
29         (when (endp p2)
30           (make-pathname :directory (cons :relative p1)
31                          :defaults pathname))))))
32
33
34(defun file-newer (orig artifact)
35  "Compares file date/time of `orig' and `artifact', returning
36`NIL' if `orig' is newer than `artifact'."
37  (or (null (probe-file artifact))
38      (> (file-write-date orig)
39         (file-write-date artifact))))
40
41(defparameter *file-separator-char*
42  (if (uiop:os-windows-p) #\\ #\/))
43
44(defparameter *path-separator-char*
45  (if (uiop:os-windows-p) #\; #\:))
46
47(defparameter *tree-root*
48  (make-pathname :device (pathname-device *load-truename*)
49                 :directory (pathname-directory *load-truename*)))
50(defparameter *build-root*
51  (merge-pathnames "build/classes/" *tree-root*))
52(defparameter *source-root*
53  (merge-pathnames "src/" *tree-root*))
54(defparameter *dist-root*
55  (merge-pathnames "dist/" *tree-root*))
56
57(defparameter *customizations-file*
58  (merge-pathnames "customizations.lisp" *tree-root*))
59
60(defparameter *abcl-dir*
61  (merge-pathnames "src/org/armedbear/lisp/" *tree-root*))
62
63(defparameter *jdk*           nil)
64(defparameter *java-compiler* nil)
65(defparameter *javac-options* nil)
66(defparameter *jikes-options* nil)
67(defparameter *jar*           nil)
68
69(defvar *classpath*)
70(defvar *java*)
71(defvar *java-compiler-options*)
72(defvar *java-compiler-command-line-prefix*)
73
74(defun initialize-build ()
75  ;;; FIXME:  highly breakable; user shouldn't be reading
76  (load (asdf:system-relative-pathname :build-abcl
77                                       "src/org/abcl/lisp/build/customizations-default.lisp"))
78  (setf *java*
79        (introspect-path-for "java"))
80
81  (unless *java*
82    (error "Can't find Java executable."))
83  (unless *java-compiler*
84    (setf *java-compiler* (introspect-path-for "java")))
85  (unless *jar*
86    (setf *jar* (introspect-path-for "jar")))
87  (let ((classpath-components (list *source-root*
88                                    (if (uiop:os-macosx-p)
89                                        #p"/System/Library/Frameworks/JavaVM.framework/Classes/classes.jar"
90                                        (merge-pathnames "jre/lib/rt.jar" *jdk*)))))
91    (setf *classpath*
92          (with-output-to-string (s)
93            (do* ((components classpath-components (cdr components))
94                  (component (car components) (car components)))
95                 ((null components))
96              (princ (safe-namestring component) s)
97              (unless (null (cdr components))
98                (write-char *path-separator-char* s))))))
99  (let ((prefix (concatenate 'string
100                             (safe-namestring *java-compiler*)
101                             " -classpath " *classpath*)))
102    (setf *java-compiler-options*
103          (if (string-equal (pathname-name (pathname *java-compiler*)) "jikes")
104              *jikes-options*
105              *javac-options*))
106    (setf prefix
107          (if *java-compiler-options*
108              (concatenate 'string prefix " " *java-compiler-options* " ")
109              (concatenate 'string prefix " ")))
110    (setf *java-compiler-command-line-prefix* prefix)))
111
112(defun substitute-in-string (string substitutions-alist)
113  (dolist (entry substitutions-alist)
114    (loop named replace
115         for index = (search (car entry) string :test #'string=)
116         do
117         (unless index
118           (return-from replace))
119         (setf string (concatenate 'string
120                                   (subseq string 0 index)
121                                   (cdr entry)
122                                   (subseq string (+ index (length (car entry))))))))
123  string)
124
125(defun copy-with-substitutions (source-file target-file substitutions-alist)
126  (with-open-file (in source-file :direction :input)
127    (with-open-file (out target-file :direction :output :if-exists :supersede)
128      (loop
129        (let ((string (read-line in nil)))
130          (when (null string)
131            (return))
132          (write-line (substitute-in-string string substitutions-alist) out))))))
133
134(defun build-javac-command-line (source-file)
135  (concatenate 'string
136               *java-compiler-command-line-prefix*
137               " -d "
138               (safe-namestring *build-root*)
139               " "
140               (namestring source-file)))
141
142(defun java-compile-file (source-file)
143  (let ((command-line (build-javac-command-line source-file)))
144
145          ;; TODO: detect failure of invocation
146          (values
147           (uiop:run-program command-line
148                                   :directory *abcl-dir*
149                                   :output :string))
150           command-line))
151
152(defun do-compile-classes (force batch)
153  (let* ((source-files
154          (remove-if-not
155           #'(lambda (name)
156               (let ((output-name
157                      (merge-pathnames
158                       (make-pathname :type "class"
159                                      :defaults (child-pathname name
160                                                                *source-root*))
161                       *build-root*)))
162                 (or force
163                     (file-newer name output-name))))
164           (directory (merge-pathnames "**/*.java" *source-root*)))))
165    (format t "~&JDK: ~A~%" *jdk*)
166    (format t "Java compiler: ~A~%" *java-compiler*)
167    (format t "Compiler options: ~A~%~%" (if *java-compiler-options* *java-compiler-options* ""))
168    (format t "~&Compiling Java sources...")
169    (finish-output)
170    (cond ((null source-files)
171           (format t "Classes are up to date.~%")
172           (finish-output)
173           t)
174          (t
175           (cond (batch
176                  (ensure-directories-exist *build-root*)
177                  (let* ((cmdline (with-output-to-string (s)
178                                    (princ *java-compiler-command-line-prefix* s)
179                                    (princ " -d " s)
180                                    (princ (safe-namestring *build-root*) s)
181                                    (princ #\Space s)
182                                    (dolist (source-file source-files)
183                                      (princ (safe-namestring (namestring source-file)) s)
184                                      (princ #\space s))))
185                         (status (run-shell-command cmdline :directory *tree-root*)))
186                    (format t "  done.~%")
187                    (equal 0 status)))
188                 (t
189                  (ensure-directories-exist *build-root*)
190                  (dolist (source-file source-files t)
191                    (unless (java-compile-file (safe-namestring source-file))
192                      (format t "Build failed.~%")
193                      (return nil)))))))))
194
195(defun make-jar ()
196  (let ((*default-pathname-defaults* *tree-root*)
197        (jar-namestring (namestring *jar*)))
198    (when (position #\space jar-namestring)
199      (setf jar-namestring (concatenate 'string "\"" jar-namestring "\"")))
200    (let ((substitutions-alist (acons "@JAR@" jar-namestring nil))
201          (source-file (if (uiop:os-windows-p) "make-jar.bat.in" "make-jar.in"))
202          (target-file (if (uiop:os-windows-p) "make-jar.bat"    "make-jar"))
203          (command     (if (uiop:os-windows-p) "make-jar.bat"    "sh make-jar")))
204      (copy-with-substitutions source-file target-file substitutions-alist)
205      (ensure-directories-exist *dist-root*)
206      (let ((status (run-shell-command command :directory *tree-root*)))
207        (unless (equal 0 status)
208          (format t "~A returned ~S~%" command status))
209        status))))
210
211(defun do-compile-system (&key (zip t))
212  (format t "~&Compiling Lisp sources...")
213  (terpri)
214  (finish-output)
215  (let* ((java-namestring (safe-namestring *java*))
216         status
217         (abcl-home (substitute-in-string
218                     (namestring *abcl-dir*)
219                     (when (uiop:os-windows-p)
220                       '(("\\" . "/")
221                         ("/" . "\\\\")))))
222         (output-path (substitute-in-string
223                       (namestring
224                        (merge-pathnames "build/classes/org/armedbear/lisp/"
225                                         *tree-root*))
226                       (when (uiop:os-windows-p)
227                         '(("\\" . "/")))))
228         (cmdline (format nil
229                          "~A -cp build/classes -Dabcl.home=\"~A\" ~
230org.armedbear.lisp.Main --noinit --nosystem ~
231--eval \"(compile-system :zip ~A :quit t :output-path \\\"~A\\\")\"~%"
232                          java-namestring
233                          abcl-home
234                          (not (not zip)) ;; because that ensures T or NIL
235                          output-path)))
236    (ensure-directories-exist output-path)
237    (setf status (run-shell-command cmdline :directory *tree-root*))
238    (format t " done.~%")
239    status))
240
241
242;; abcl/abcl.bat
243(defun make-launch-script ()
244  ;; Use the -Xss4M and -Xmx256M flags so that the default launch script can be
245  ;; used to build sbcl.
246  (cond ((uiop:os-windows-p)
247         (with-open-file (s
248                          (merge-pathnames "abcl.bat" *tree-root*)
249                          :direction :output
250                          :if-exists :supersede)
251           (format s "~A -Xss4M -Xmx256M -cp \"~A\" org.armedbear.lisp.Main %1 %2 %3 %4 %5 %6 %7 %8 %9~%"
252                   (safe-namestring *java*)
253                   (namestring (merge-pathnames "dist\\abcl.jar" *tree-root*)))))
254        (t
255         (let ((pathname (merge-pathnames "abcl" *tree-root*)))
256           (with-open-file (s pathname :direction :output :if-exists :supersede)
257             (format s "#!/bin/sh~%exec ~A -Xss4M -Xmx256M -cp ~A org.armedbear.lisp.Main \"$@\"~%"
258                     (safe-namestring *java*)
259                     (safe-namestring (merge-pathnames "abcl.jar" *dist-root*))))
260           (run-shell-command (format nil "chmod +x ~A" (safe-namestring pathname))
261                              :directory *tree-root*)))))
262
263(defun build-stamp ()
264  (multiple-value-bind
265      (second minute hour date month year day daylight-p zone)
266      (decode-universal-time (get-universal-time))
267    (declare (ignore daylight-p))
268    (setf day (nth day '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")))
269    (setf month (nth (1- month) '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
270                                  "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
271    (setf zone (* zone 100)) ;; FIXME
272    (format nil "~A ~A ~D ~D ~2,'0D:~2,'0D:~2,'0D -~4,'0D"
273            day month date year hour minute second zone)))
274
275(defun make-build-stamp ()
276  (with-open-file (s
277                   (merge-pathnames (make-pathname :name "build"
278                                                   :defaults *abcl-dir*))
279                   :direction :output
280                   :if-exists :supersede)
281    (format s "~A" (build-stamp))))
282
283(defun delete-files (pathnames)
284  (dolist (pathname pathnames)
285    (let ((truename (probe-file pathname)))
286      (when truename
287        (delete-file truename)))))
288
289(defun clean ()
290  (format t "~&Cleaning compilation results.")
291  (dolist (f (list (list *tree-root* "abcl.jar" "abcl.bat" "make-jar.bat"
292                         "compile-system.bat")
293                   ;; as of 0.14 'compile-system.bat' isn't created anymore
294                   ;; as of 0.14 'abcl.jar' is always created in dist/
295                   (list *abcl-dir* "*.class" "*.abcl" "*.cls"
296                                    "native.h" "libabcl.so" "build")
297                   ;; as of 0.14, native.h and libabcl.so have been removed
298                   (list (merge-pathnames "util/" *abcl-dir*) "*.class")
299                   (list (merge-pathnames "build/classes/org/armedbear/lisp/"
300                                          *tree-root*)
301                                    "*.class" "*.abcl" "*.cls"
302                                    "native.h" "libabcl.so" "build")
303                   (list (merge-pathnames
304                          "build/classes/org/armedbear/lisp/util/"
305                          *tree-root*)
306                                    "*.class" "*.abcl" "*.cls")
307                   (list *dist-root* "*.jar" "*.class" "*.abcl" "*.cls")
308                  (list (merge-pathnames "java/awt/" *abcl-dir*)
309                         "*.class")))
310    (let ((default (car f)))
311      (when (probe-directory default)
312        (delete-files (mapcan #'(lambda (name)
313                                  (directory (merge-pathnames name default)))
314                              (cdr f)))))))
315#+(or)
316(defun build-abcl (&key force
317                        (batch t)
318                        compile-system
319                        jar
320                        clean
321                        full)
322  (let ((start (get-internal-real-time)))
323
324    #+lispworks
325    (when (uiop:os-windows-p)
326      (setf batch nil))
327
328    (initialize-build)
329    (format t "~&Platform: ~A~%" (software-type))
330    (finish-output)
331    ;; clean
332    (when clean
333      (clean))
334    ;; Compile Java source into classes
335    (unless (do-compile-classes force batch)
336      (format t "Build failed.~%")
337      (return-from build-abcl nil))
338    ;; COMPILE-SYSTEM
339    (when (or full compile-system)
340      (let* ((zip    (if (or full jar) nil t))
341             (status (do-compile-system :zip zip)))
342        (unless (equal 0 status)
343          (format t "Build failed.~%")
344          (return-from build-abcl nil))))
345    ;; abcl.jar
346    (when (or full jar)
347      (let ((status (make-jar)))
348        (unless (equal 0 status)
349          (format t "Build failed.~%")
350          (return-from build-abcl nil))))
351    ;; abcl/abcl.bat
352    (make-launch-script)
353    (make-build-stamp)
354    (let ((end (get-internal-real-time)))
355      (format t "Build completed successfully in ~A seconds.~%"
356              (/ (float (- end start)) internal-time-units-per-second)))
357    t))
358
359(defun build-abcl-executable ()
360  (let* ((*default-pathname-defaults* *abcl-dir*)
361         (source-files (directory "*.java"))
362         (cmdline (with-output-to-string (s)
363                    (princ "gcj -g -O0 " s)
364                    (dolist (source-file source-files)
365                      (unless (string= (pathname-name source-file) "Native")
366                        (princ (pathname-name source-file) s)
367                        (princ ".java" s)
368                        (princ #\space s)))
369                    (princ "--main=org.armedbear.lisp.Main -o lisp" s)))
370         (result (run-shell-command cmdline :directory *abcl-dir*)))
371    (equal 0 result)))
372
373(defvar *copy-verbose* nil)
374
375(defun copy-file (source target)
376  (when *copy-verbose*
377    (format t "~A -> ~A~%" source target))
378  (let ((buffer (make-array 4096 :element-type '(unsigned-byte 8))))
379    (with-open-file (in source :direction :input :element-type '(unsigned-byte 8))
380      (with-open-file (out target :direction :output :element-type '(unsigned-byte 8)
381                           :if-exists :supersede)
382        (loop
383          (let ((end (read-sequence buffer in)))
384            (when (zerop end)
385              (return))
386            (write-sequence buffer out :end end)))))))
387
388(defun copy-files (files source-dir target-dir)
389  (ensure-directories-exist target-dir)
390  (dolist (file files)
391    (copy-file (merge-pathnames file source-dir)
392               (merge-pathnames file target-dir))))
393
394(defun make-dist-dir (version-string)
395  (unless (uiop:os-unix-p)
396    (error "MAKE-DIST is only supported on Unices."))
397  (let ((target-root (pathname (concatenate 'string "/var/tmp/" version-string "/"))))
398    (when (probe-directory target-root)
399      (error "Target directory ~S already exists." target-root))
400    (let* ((source-dir *tree-root*)
401           (target-dir target-root)
402           (files (list "README"
403                        "COPYING"
404                        "build-abcl.lisp"
405                        "customizations.lisp"
406                        "make-jar.bat.in"
407                        "make-jar.in")))
408      (copy-files files source-dir target-dir))
409    (let* ((source-dir (merge-pathnames "examples/" *tree-root*))
410           (target-dir (merge-pathnames "examples/" target-root))
411           (files '("hello.java")))
412      (copy-files files source-dir target-dir))
413    (let* ((target-dir (merge-pathnames "src/" target-root))
414           (files '("manifest-abcl")))
415      (copy-files files *source-root* target-dir))
416    (let* ((source-dir *abcl-dir*)
417           (target-dir (merge-pathnames "src/org/armedbear/lisp/" target-root))
418           (*default-pathname-defaults* source-dir)
419           (files (mapcar #'file-namestring (append (directory "*.java")
420                                                    (directory "*.lisp")
421                                                    (list "LICENSE" "native.c")))))
422      (copy-files files source-dir target-dir))
423    (let* ((source-dir (merge-pathnames "tests/" *abcl-dir*))
424           (target-dir (merge-pathnames "src/org/armedbear/lisp/tests/" target-root))
425           (*default-pathname-defaults* source-dir)
426           (files (append (mapcar #'file-namestring (directory "*.lisp"))
427                          (list "jl-config.cl"))))
428      (copy-files files source-dir target-dir))
429    (let* ((source-dir (merge-pathnames "java/awt/" *abcl-dir*))
430           (target-dir (merge-pathnames "src/org/armedbear/lisp/java/awt/" target-root))
431           (*default-pathname-defaults* source-dir)
432           (files (mapcar #'file-namestring (directory "*.java"))))
433      (copy-files files source-dir target-dir))
434    target-root))
435
436#+(or)
437(defun make-dist (version-string)
438  (let* ((dist-dir (make-dist-dir version-string))
439         (parent-dir (merge-pathnames (make-pathname :directory '(:relative :back))
440                                      dist-dir)))
441    (let* ((command (format nil "tar czf ~A~A.tar.gz ~A"
442                            (namestring parent-dir)
443                            version-string version-string))
444           (status (run-shell-command command :directory parent-dir)))
445      (unless (equal 0 status)
446        (format t "~A returned ~S~%" command status)))
447    (let* ((command (format nil "zip -q -r ~A~A.zip ~A"
448                            (namestring parent-dir)
449                            version-string version-string))
450           (status (run-shell-command command :directory parent-dir)))
451      (unless (equal 0 status)
452        (format t "~A returned ~S~%" command status)))))
Note: See TracBrowser for help on using the repository browser.