← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/cmp/cmpmain.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Albin Tonnerre
  • Date: 2008-06-20 18:00:19 UTC
  • mfrom: (1.1.4 upstream)
  • Revision ID: james.westby@ubuntu.com-20080620180019-7fbz1ln5444vtkkr
Tags: 0.9j-20080306-2ubuntu1
* Enabled unicode support. (Closes: LP #123530)
* Modify Maintainer value to match the DebianMaintainerField specification.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/cmp/cmpmain.lsp
 
1
;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
 
2
;;;;
1
3
;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
2
4
;;;;  Copyright (c) 1990, Giuseppe Attardi.
 
5
;;;;  Copyright (c) 2001, Juan Jose Garcia Ripoll
3
6
;;;;
4
7
;;;;    This program is free software; you can redistribute it and/or
5
8
;;;;    modify it under the terms of the GNU Library General Public
12
15
 
13
16
(in-package "COMPILER")
14
17
 
 
18
#-threads
 
19
(defmacro with-lock ((lock) &body body)
 
20
  `(progn ,@body))
 
21
 
15
22
(defun safe-system (string)
16
 
  (cmpnote "Invoking external command:~%;;; ~A~%" string)
 
23
  (cmpnote "Invoking external command:~%;;; ~A" string)
17
24
  (let ((result (si:system string)))
18
25
    (unless (zerop result)
19
26
      (cerror "Continues anyway."
21
28
              string result))
22
29
    result))
23
30
 
24
 
(defun compile-file-pathname (name &key (output-file name) (type :fasl))
 
31
(defun compile-file-pathname (name &key (output-file name) (type :fasl)
 
32
                              verbose print c-file h-file data-file shared-data-file
 
33
                              system-p load)
25
34
  (let ((format '())
26
35
        (extension '()))
27
36
    (case type
56
65
(push #'(lambda () (mapc #'delete-file *files-to-be-deleted*))
57
66
      si::*exit-hooks*)
58
67
 
 
68
#-mingw32
 
69
(defmacro fix-for-mingw (directory-namestring)
 
70
  directory-namestring)
 
71
 
 
72
#+mingw32
 
73
(defun fix-for-mingw (directory-namestring)
 
74
  (let ((x (string-right-trim '(#\\ #\/) directory-namestring)))
 
75
    (if (zerop (length x)) "/" x)))
 
76
 
59
77
(defun linker-cc (o-pathname &rest options)
60
78
  (safe-system
61
79
   (format nil
62
80
           *ld-format*
63
 
           *cc*
 
81
           *ld*
64
82
           (si::coerce-to-filename o-pathname)
65
 
           (ecl-library-directory)
 
83
           (fix-for-mingw (ecl-library-directory))
66
84
           options
67
 
           *ld-flags* (ecl-library-directory))))
 
85
           *ld-flags* (fix-for-mingw (ecl-library-directory)))))
68
86
 
69
87
#+dlopen
70
88
(defun shared-cc (o-pathname &rest options)
72
90
  (safe-system
73
91
   (format nil
74
92
           *ld-format*
75
 
           *cc*
 
93
           *ld*
76
94
           (si::coerce-to-filename o-pathname)
77
 
           (ecl-library-directory)
 
95
           (fix-for-mingw (ecl-library-directory))
78
96
           options
79
 
           *ld-shared-flags* (ecl-library-directory)))
 
97
           *ld-shared-flags* (fix-for-mingw (ecl-library-directory))))
80
98
  #+(or mingw32)
81
99
  (let ((lib-file (compile-file-pathname o-pathname :type :lib)))
82
100
    (safe-system
83
101
     (format nil
84
102
             "dllwrap --export-all-symbols -o ~S -L~S ~{~S ~} ~@?"
85
103
             (si::coerce-to-filename o-pathname)
86
 
             (ecl-library-directory)
 
104
             (fix-for-mingw (ecl-library-directory))
87
105
             options
88
106
             *ld-shared-flags*
89
 
             (ecl-library-directory)))))
 
107
             (fix-for-mingw (ecl-library-directory))))))
90
108
 
91
109
#+dlopen
92
110
(defun bundle-cc (o-pathname init-name &rest options)
94
112
  (safe-system
95
113
   (format nil
96
114
           *ld-format*
97
 
           *cc*
 
115
           *ld*
98
116
           (si::coerce-to-filename o-pathname)
99
 
           (ecl-library-directory)
 
117
           (fix-for-mingw (ecl-library-directory))
100
118
           options
101
119
           #-msvc *ld-bundle-flags*
102
120
           #+msvc (concatenate 'string *ld-bundle-flags* " /EXPORT:"
107
125
   (format nil
108
126
           "dllwrap -o ~A --export-all-symbols -L~S ~{~S ~} ~@?"
109
127
           (si::coerce-to-filename o-pathname)
110
 
           (ecl-library-directory)
 
128
           (fix-for-mingw (ecl-library-directory))
111
129
           options
112
130
           *ld-bundle-flags*
113
 
           (ecl-library-directory))))
 
131
           (fix-for-mingw (ecl-library-directory)))))
114
132
 
115
133
(defconstant +lisp-program-header+ "
116
134
#include <ecl/ecl.h>
190
208
        ~A
191
209
}")
192
210
 
193
 
(defun init-function-name (s &key ((:prefix si::*init-function-prefix*) si::*init-function-prefix*)
194
 
                           (kind :object))
 
211
(defun init-function-name (s &key (kind :object))
195
212
  (flet ((translate-char (c)
196
213
           (cond ((and (char>= c #\a) (char<= c #\z))
197
214
                  (char-upcase c))
210
227
         (disambiguation (c)
211
228
           (case kind
212
229
             (:object "")
 
230
             (:program "exe_")
213
231
             ((:fasl :fas) "fas_")
214
 
             ((:shared-library :dll :static-library :lib) "lib_")
 
232
             ((:library :shared-library :dll :static-library :lib) "lib_")
215
233
             (otherwise (error "Not a valid argument to INIT-FUNCTION-NAME: kind = ~S"
216
234
                               kind)))))
217
235
    (setq s (map 'string #'translate-char (string s)))
218
236
    (concatenate 'string
219
237
                 "init_"
220
238
                 (disambiguation kind)
221
 
                 (if si::*init-function-prefix*
222
 
                     (concatenate 'string si::*init-function-prefix* "_")
223
 
                     "")
224
239
                 (map 'string #'translate-char (string s)))))
225
240
 
226
241
(defun guess-kind (pathname)
241
256
                pathname)
242
257
          :object))))
243
258
 
244
 
(defun guess-name-and-flags (pathname &key (prefix si::*init-function-prefix*)
245
 
                             (kind (guess-kind pathname)))
246
 
  "Given a file name, guess whether it is an object file or a library, and what
247
 
is the name of the initialization function in this file."
248
 
  (let ((filename (pathname-name pathname))
249
 
        name flags)
250
 
    (case kind
251
 
      ((:object :c)
252
 
       (setf name filename
253
 
             flags (si::coerce-to-filename pathname)))
254
 
      ((:fasl :fas)
255
 
       (setf name "CODE"
256
 
             flags ""))
257
 
      ((:static-library :lib)
258
 
       (setf name (if (zerop (search +static-library-prefix+ filename))
259
 
                      (subseq filename (length +static-library-prefix+) nil)
260
 
                      filename)
261
 
             flags (if (probe-file pathname)
262
 
                       (si::coerce-to-filename pathname)
263
 
                       (concatenate 'string "-l" name))))
264
 
      ((:shared-library :dll)
265
 
       (setf name (if (zerop (search +shared-library-prefix+ filename))
266
 
                      (subseq filename (length +shared-library-prefix+) nil)
267
 
                      filename)
268
 
             flags (if (probe-file pathname)
269
 
                       (si::coerce-to-filename pathname)
270
 
                       (concatenate 'string "-l" name))))
271
 
      ((:program)
272
 
       (setf name "ECL_PROGRAM"
273
 
             flags nil))
274
 
      (otherwise
275
 
       (error "C::BUILDER cannot accept files of kind ~s" kind)))
276
 
    (values (init-function-name name :kind kind :prefix prefix) flags)))
 
259
(defun guess-ld-flags (pathname &key (kind (guess-kind pathname)))
 
260
  "Given a file name, return the compiler command line argument to link this file in."
 
261
  (case kind
 
262
    ((:object :c)
 
263
     (si::coerce-to-filename pathname))
 
264
    ((:fasl :fas)
 
265
     nil)
 
266
    ((:static-library :lib)
 
267
     (si::coerce-to-filename pathname))
 
268
    ((:shared-library :dll)
 
269
     (si::coerce-to-filename pathname))
 
270
    ((:program)
 
271
     nil)
 
272
    (otherwise
 
273
     (error "C::BUILDER cannot accept files of kind ~s" kind))))
277
274
 
278
275
(defun system-ld-flag (library)
279
276
  "Given a symbol, try to find a library that matches it, either by looking in the
287
284
                 (first (asdfcall :output-files build system))))
288
285
             (existing-system-output (system type)
289
286
               (let ((o (system-output system type)))
290
 
                 (and o (probe-file o))))
 
287
                 (and o (setf o (probe-file o)) (namestring o))))
291
288
             (find-archive (system)
292
289
                 (or (existing-system-output system :library)
293
290
                     (existing-system-output system :shared-library)))
353
350
           (unless (member kind '(:shared-library :dll :static-library :lib
354
351
                                  :object :c))
355
352
             (error "C::BUILDER does not accept a file ~s of kind ~s" item kind))
356
 
           (multiple-value-bind (init-fn flags)
357
 
               (guess-name-and-flags (parse-namestring item))
 
353
           (let* ((path (parse-namestring item))
 
354
                  (init-fn (guess-init-name path))
 
355
                  (flags (guess-ld-flags path)))
 
356
             ;; We should give a warning that we cannot link this module in
358
357
             (when flags (push flags ld-flags))
359
358
             (push init-fn submodules))))))
360
359
    (setq c-file (open c-name :direction :output))
361
 
    (format c-file +lisp-program-header+
362
 
            #-(or :win32 :mingw32 :darwin) (if (eq :fasl target) nil submodules)
363
 
            #+(or :win32 :mingw32 :darwin) submodules)
 
360
    (format c-file +lisp-program-header+ submodules)
364
361
    (cond (shared-data-file
365
362
           (data-init shared-data-file)
366
363
           (format c-file "
382
379
    (when (or (symbolp output-name) (stringp output-name))
383
380
      (setf output-name (compile-file-pathname output-name :type target)))
384
381
    (unless init-name
385
 
      (setf init-name (guess-name-and-flags output-name :prefix nil)))
 
382
      (setf init-name (guess-init-name output-name :kind target)))
386
383
    (ecase target
387
384
      (:program
388
385
       (format c-file +lisp-program-init+ init-name "" shared-data-file
423
420
       (apply #'shared-cc output-name o-name ld-flags))
424
421
      #+dlopen
425
422
      (:fasl
426
 
       #-(or :win32 :mingw32 :darwin)
427
 
       (setf submodules
428
 
             (mapcar #'(lambda (sm)
429
 
                         (format nil "((ecl_init_function_t) ecl_library_symbol(Cblock, \"~A\", 0))" sm))
430
 
                     submodules))
431
423
       (format c-file +lisp-program-init+ init-name prologue-code shared-data-file
432
424
               submodules epilogue-code)
433
425
       (close c-file)
559
551
 
560
552
      (when (zerop *error-count*)
561
553
        (when *compile-verbose* (format t "~&;;; End of Pass 1.  "))
562
 
        (setf init-name (guess-name-and-flags output-file :kind
563
 
                                              (if system-p :object :fasl)))
 
554
        (setf init-name (guess-init-name output-file :kind
 
555
                                         (if system-p :object :fasl)))
564
556
        (compiler-pass2 c-pathname h-pathname data-pathname system-p
565
557
                        init-name
566
558
                        shared-data-file))
690
682
        (h-pathname (compile-file-pathname data-pathname :type :h))
691
683
        (o-pathname (compile-file-pathname data-pathname :type :object))
692
684
        (so-pathname (compile-file-pathname data-pathname))
693
 
        (init-name (guess-name-and-flags so-pathname :kind :fasl)))
 
685
        (init-name (guess-init-name so-pathname :kind :fasl)))
694
686
 
695
687
    (with-lock (+load-compile-lock+)
696
688
      (init-env)
698
690
      (t1expr form)
699
691
      (when (zerop *error-count*)
700
692
        (when *compile-verbose* (format t "~&;;; End of Pass 1.  "))
701
 
        (let (#+(or mingw32 msvc)(*self-destructing-fasl* t))
 
693
        (let (#+(or mingw32 msvc cygwin)(*self-destructing-fasl* t))
702
694
          (compiler-pass2 c-pathname h-pathname data-pathname nil
703
695
                          init-name nil)))
704
696
      (setf *compiler-constants* (data-dump data-pathname))
719
711
          (cmp-delete-file data-pathname)
720
712
          (cond ((probe-file so-pathname)
721
713
                 (load so-pathname :verbose nil)
722
 
                 #-(or mingw32 msvc)(cmp-delete-file so-pathname)
 
714
                 #-(or mingw32 msvc cygwin)(cmp-delete-file so-pathname)
723
715
                 #+msvc (delete-msvc-generated-files so-pathname)
724
716
                 (when *compile-verbose* (print-compiler-info))
725
717
                 (setf name (or name (symbol-value 'GAZONK)))
796
788
             (t1expr disassembled-form)
797
789
             (if (zerop *error-count*)
798
790
                 (catch *cmperr-tag*
799
 
                   (ctop-write (guess-name-and-flags "foo" :kind :fasl)
 
791
                   (ctop-write (guess-init-name "foo" :kind :fasl)
800
792
                               (if h-file h-file "")
801
793
                               (if data-file data-file "")))
802
794
                 (setq *error-p* t))
846
838
   (format nil
847
839
           *cc-format*
848
840
           *cc* *cc-flags* (>= *speed* 2) *cc-optimize*
849
 
           (ecl-include-directory)
 
841
           (fix-for-mingw (ecl-include-directory))
850
842
           (si::coerce-to-filename c-pathname)
851
843
           (si::coerce-to-filename o-pathname))
852
844
; Since the SUN4 assembler loops with big files, you might want to use this:
860
852
   ))
861
853
 
862
854
(defun print-compiler-info ()
863
 
  (format t "~&;;; OPTIMIZE levels: Safety=~d, Space=~d, Speed=~d~%"
864
 
          *safety* *space* *speed*))
 
855
  (format t "~&;;; OPTIMIZE levels: Safety=~d, Space=~d, Speed=~d, Debug=~d~%"
 
856
          *safety* *space* *speed* *debug*))
865
857
 
866
858
(defmacro with-compilation-unit (options &rest body)
867
859
  `(progn ,@body))