/[gcl]/gcl/cmpnew/gcl_cmpmain.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmpmain.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:33 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:01 2003 UTC
# Line 0  Line 1 
1    ;;; CMPMAIN  Compiler main program.
2    ;;;
3    ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
4    
5    ;; This file is part of GNU Common Lisp, herein referred to as GCL
6    ;;
7    ;; GCL is free software; you can redistribute it and/or modify it under
8    ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
9    ;; the Free Software Foundation; either version 2, or (at your option)
10    ;; any later version.
11    ;;
12    ;; GCL is distributed in the hope that it will be useful, but WITHOUT
13    ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14    ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public
15    ;; License for more details.
16    ;;
17    ;; You should have received a copy of the GNU Library General Public License
18    ;; along with GCL; see the file COPYING.  If not, write to the Free Software
19    ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
20    
21    
22    ;;;             **** Caution ****
23    ;;;     This file is machine/OS dependant.
24    ;;;             *****************
25    
26    
27    (in-package 'compiler)
28    
29    
30    (export '(*compile-print* *compile-verbose*))
31    
32    #+linux   (push :ld-not-accept-data  *features*)
33    (defvar *compiler-in-use* nil)
34    (defvar *compiler-input*)
35    (defvar *compiler-output1*)
36    (defvar *compiler-output2*)
37    (defvar *compiler-output-data*)
38    (defvar *compiler-output-i*)
39    
40    (defvar *error-p* nil)
41    
42    (defvar *compile-print* nil)
43    (defvar *compile-verbose* t)
44    (defvar *cmpinclude* "\"cmpinclude.h\"")
45    ;;If the following is a string, then it is inserted instead of
46    ;; the include file cmpinclude.h, EXCEPT for system-p calls.
47    (defvar *cmpinclude-string* t)
48    (defvar *compiler-default-type* #p".lsp")
49    (defvar *compiler-normal-type* #p".lsp")
50    
51    (defun compiler-default-type (pname)
52      "Set the default file extension (type) for compilable file names."
53      (setf *compiler-default-type* (if (pathnamep pname)
54                                        pname
55                                      (make-pathname :type (string-left-trim "." pname)))))
56    
57    (defun compiler-reset-type ()
58      "Set the default file extension (type) to <.lsp>."
59      (compiler-default-type *compiler-normal-type*))
60    
61    ;; Let the user write dump c-file etc to  /dev/null.
62    (defun get-output-pathname (file ext name &optional (dir (pathname-directory *default-pathname-defaults*)))
63      (cond
64            ((equal file "/dev/null") (pathname file))
65            #+aix3
66            ((and (equal name "float")
67                  (equal ext "h"))
68             (get-output-pathname file ext "Float" ))
69            (t
70             (make-pathname :directory (or (and (not (null file))
71                                                (not (eq file t))
72                                                (pathname-directory file))
73                                           dir)
74                            :name (or (and (not (null file))
75                                           (not (eq file t))
76                                           (pathname-name file))
77                                      name)
78                            :type ext))))
79    
80    
81    (defun safe-system (string)
82     (multiple-value-bind
83      (code result) (system string)
84        (unless (and (zerop code) (zerop result))
85          (cerror "Continues anyway."
86                  "(SYSTEM ~S) returned a non-zero value ~D."
87                  string
88                  result)
89          (setq *error-p* t))
90        (values result)))
91    
92    ;; If this is t we use fasd-data on all but system-p files.   If it
93    ;; is :system-p we use it on all files.   If nil use it on none.
94    (defvar *fasd-data* t)
95    (defvar *data* nil)
96    (defvar *default-system-p* nil)
97    (defvar *default-c-file* nil)
98    (defvar *default-h-file* nil)
99    (defvar *default-data-file* nil)
100    (defvar *keep-gaz* nil)
101    
102    ;;  (list section-length split-file-names next-section-start-file-position)
103    ;;  Many c compilers cannot handle the large C files resulting from large lisp files.
104    ;;  If *split-files* is a number then, separate compilations for sections
105    ;;  *split-files* long, with the
106    ;;  will be performed for separate chunks of the lisp files.
107    (defvar *split-files* nil)  ;; if
108    
109    (defun check-end (form eof)
110      (cond  ((eq form eof)
111              (setf (third *split-files*) nil))
112             ((> (file-position *compiler-input*)
113                 (car *split-files*))
114              (setf (third *split-files*)(file-position *compiler-input*)))))
115              
116    
117    (defun compile-file  (&rest args
118                                &aux (*print-pretty* nil)
119                                (*package* *package*) (*split-files* *split-files*)
120                                (*PRINT-CIRCLE* NIL)
121                                (*PRINT-RADIX* NIL)
122                                (*PRINT-ARRAY* T)
123                                (*PRINT-LEVEL* NIL)
124                                (*PRINT-PRETTY* T)
125                                (*PRINT-LENGTH* NIL)
126                                (*PRINT-GENSYM* T)
127                                (*PRINT-CASE* :UPCASE)
128                                (*PRINT-BASE* 10)
129                                (*PRINT-ESCAPE* T)
130                                (section-length *split-files*)
131                                tem)
132      (loop
133       (compiler::init-env)
134       (setq tem (apply 'compiler::compile-file1 args))
135       (cond ((atom *split-files*)(return tem))
136             ((and (consp *split-files*)
137                   (null (third *split-files*)))
138              (let ((gaz (let ((*DEFAULT-PATHNAME-DEFAULTS* (car args)))
139                                                        (gazonk-name)))
140                    (*readtable* (si::standard-readtable)))
141                (setq gaz (get-output-pathname gaz "lsp" (car args)))
142                (with-open-file (st gaz :direction :output)
143                  (print
144                   `(eval-when (load eval)
145                               (dolist (v ',(nreverse (second *split-files*)))
146                                       (load (merge-pathnames v si::*load-pathname*))))
147                   st))
148                (setq *split-files* nil)
149                (or (member :output-file args)
150                    (setq args (append args (list :output-file (car args)))))
151                (return
152                 (prog1 (apply 'compile-file gaz (cdr args))
153                   (unless *keep-gaz* (delete-file gaz))))
154                ))
155             (t nil))
156       (if (consp *split-files*)
157           (setf (car *split-files*) (+ (third *split-files*) section-length)))
158       ))
159    
160    
161    (defun compile-file1 (input-pathname
162                          &key (output-file input-pathname)
163                               (o-file t)
164                               (c-file *default-c-file*)
165                               (h-file *default-h-file*)
166                               (data-file *default-data-file*)
167                               (c-debug nil)
168                               #+aosvs (ob-file nil)
169                               (system-p *default-system-p*)
170                               (print nil)
171                               (load nil)
172                          &aux (*standard-output* *standard-output*)
173                               (*error-output* *error-output*)
174                               (*compiler-in-use* *compiler-in-use*)
175                               (*c-debug* c-debug)
176                               (*compile-print* (or print *compile-print*))
177                               (*package* *package*)
178                               (*DEFAULT-PATHNAME-DEFAULTS* #"")
179                               (*data* (list (make-array 50 :fill-pointer 0
180                                                         :adjustable t
181                                                         )
182                                             nil ;inits
183                                             nil
184                                             ))
185                               *init-name*  
186                               (*fasd-data* *fasd-data*)
187                               (*error-count* 0))
188      (declare (special *c-debug* *init-name* system-p))
189    
190      (cond (*compiler-in-use*
191             (format t "~&The compiler was called recursively.~%~
192    Cannot compile ~a.~%"
193                     (namestring (merge-pathnames input-pathname *compiler-default-type*)))
194             (setq *error-p* t)
195             (return-from compile-file1 (values)))
196            (t (setq *error-p* nil)
197               (setq *compiler-in-use* t)))  
198    
199      (unless (probe-file (merge-pathnames input-pathname *compiler-default-type*))
200        (format t "~&The source file ~a is not found.~%"
201                (namestring (merge-pathnames input-pathname *compiler-default-type*)))
202        (setq *error-p* t)
203        (return-from compile-file1 (values)))
204    
205      (when *compile-verbose*
206        (format t "~&Compiling ~a.~%"
207                (namestring (merge-pathnames input-pathname *compiler-default-type*))))
208    
209      (and *record-call-info* (clear-call-table))
210    
211      (with-open-file
212              (*compiler-input* (merge-pathnames input-pathname *compiler-default-type*))
213    
214    
215        (cond ((numberp *split-files*)
216               (if (< (file-length *compiler-input*) *split-files*)
217                   (setq *split-files* nil)
218                 ;;*split-files* = ( section-length split-file-names next-section-start-file-position
219                 ;;                           package-ops)
220                 (setq *split-files* (list *split-files* nil 0 nil)))))
221    
222        (cond ((consp *split-files*)
223               (file-position *compiler-input* (third *split-files*))
224               (setq output-file
225                     (make-pathname :directory (pathname-directory output-file)
226                                    :name (format nil "~a~a"
227                                                  (length (second *split-files*))
228                                                  (pathname-name (pathname output-file)))
229                                    :type "o"))
230              
231               (push (pathname-name output-file)   (second *split-files*))
232               ))
233              
234        
235            
236        
237      (let* ((eof (cons nil nil))
238             (dir (or (and (not (null output-file))
239                           (pathname-directory output-file))
240                      (pathname-directory input-pathname)))
241             (name (or (and (not (null output-file))
242                            (pathname-name output-file))
243                       (pathname-name input-pathname)))
244    
245             (o-pathname (get-output-pathname o-file "o" name dir))
246             (c-pathname (get-output-pathname c-file "c" name dir))
247             (h-pathname (get-output-pathname h-file "h" name dir))
248             (data-pathname (get-output-pathname data-file "data" name dir))
249    ;        (i-pathname  (get-output-pathname data-file "i" name dir))
250             #+aosvs (ob-pathname (get-output-pathname ob-file "ob" name dir))
251             )
252        (declare (special dir name ))
253    
254        (init-env)
255    
256        (and (boundp 'si::*gcl-version*)
257             (not system-p)
258             (add-init `(si::warn-version ,si::*gcl-version* ,si::*gcl-major-version*)))
259    
260        (when (probe-file "./cmpinit.lsp")
261          (load  "./cmpinit.lsp"
262                :verbose *compile-verbose*))
263    
264        (with-open-file (*compiler-output-data*
265                          data-pathname
266                         :direction :output)
267        (progn
268          (setq *fasd-data*                      
269                (cond  ((if system-p (eq *fasd-data* :system-p)
270                          *fasd-data*)
271                        (list
272                         (si::open-fasd *compiler-output-data* :output nil nil)
273                         ;(si::open-fasd *compiler-output-i* :output nil nil)
274                         ))))
275    
276          (wt-data-begin)
277    
278          (let* ((rtb *readtable*)
279                   (prev (and (eq (get-macro-character #\# rtb)
280                                  (get-macro-character
281                                    #\# (si:standard-readtable)))
282                              (get-dispatch-macro-character #\# #\, rtb))))
283              (if (and prev (eq prev (get-dispatch-macro-character
284                                       #\# #\, (si:standard-readtable))))
285                  (set-dispatch-macro-character #\# #\,
286                    'si:sharp-comma-reader-for-compiler rtb)
287                  (setq prev nil))
288              
289              ;; t1expr the package ops again..
290              (if (consp *split-files*)
291                  (dolist (v (fourth *split-files*)) (t1expr v)))
292              (unwind-protect
293                (do ((form (read *compiler-input* nil eof)
294                           (read *compiler-input* nil eof))
295                     (load-flag (or (eq :defaults *eval-when-defaults*)
296                                    (member 'load *eval-when-defaults*))))
297                    (nil)
298                  (cond
299                   ((eq form eof))
300                   (load-flag (t1expr form))
301                   ((maybe-eval nil form)))
302                  (cond
303                   ((and *split-files* (check-end form eof))
304                    (setf (fourth *split-files*) (reverse (third *data*)))
305                    (return nil))
306                   ((eq form eof) (return nil)))
307                  )
308                
309    
310                (when prev (set-dispatch-macro-character #\# #\, prev rtb)))))
311    
312            (setq *init-name*
313                  (substitute #\_ #\-
314                              (if system-p  
315                                  #-aosvs (pathname-name input-pathname)
316                                  #+aosvs (string-downcase
317                                           (pathname-name input-pathname))
318                                  "code")))
319    
320          (when (zerop *error-count*)
321            (when *compile-verbose* (format t "~&End of Pass 1.  ~%"))
322            (compiler-pass2 c-pathname h-pathname system-p ))
323            
324    
325          (wt-data-end)
326    
327          ) ;;; *compiler-output-data* closed.
328    
329        (init-env)
330    
331        (if (zerop *error-count*)
332    
333            #+aosvs
334            (progn
335              (when *compile-verbose* (format t "~&End of Pass 2.  ~%"))
336              (when data-file
337                (with-open-file (in fasl-pathname)
338                  (with-open-file (out data-pathname :direction :output)
339                    (si:copy-stream in out))))
340              (cond ((or fasl-file ob-file)
341                     (compiler-cc c-pathname ob-pathname)
342                     (cond ((probe-file ob-pathname)
343                            (when fasl-file
344                                  (compiler-build ob-pathname fasl-pathname)
345                                  (when load (load fasl-pathname)))
346                            (unless ob-file (delete-file ob-pathname))
347                            (when *compile-verbose*
348                                  (print-compiler-info)
349                                  (format t "~&Finished compiling ~a.~%" (namestring output-file))
350                                  ))
351                           (t (format t "~&Your C compiler failed to compile the intermediate file.~%")
352                              (setq *error-p* t))))
353                    (*compile-verbose*
354                     (print-compiler-info)
355                     (format t "~&Finished compiling ~a.~%" (namestring output-file)
356                             )))
357              (unless c-file (delete-file c-pathname))
358              (unless h-file (delete-file h-pathname))
359              (unless fasl-file (delete-file fasl-pathname)))
360    
361    
362            (progn
363              (when *compile-verbose* (format t "~&End of Pass 2.  ~%"))
364              (cond (*record-call-info*
365                     (dump-fn-data (get-output-pathname output-file "fn" name dir))))
366              (cond (o-file
367                     (compiler-cc c-pathname o-pathname  )
368                     (cond ((probe-file o-pathname)
369                            (compiler-build o-pathname data-pathname)
370                            (when load (load o-pathname))
371                           (when *compile-verbose*
372                                  (print-compiler-info)
373                                  (format t "~&Finished compiling ~a.~%" (namestring output-file)
374                                          )))
375                           (t
376                              (format t "~&Your C compiler failed to compile the intermediate file.~%")
377                              (setq *error-p* t))))
378                     (*compile-verbose*
379                      (print-compiler-info)
380                      (format t "~&Finished compiling ~a.~%" (namestring output-file)
381                              )))
382              (unless c-file (delete-file c-pathname))
383              (unless h-file (delete-file h-pathname))
384              (unless (or data-file #+ld-not-accept-data t system-p) (delete-file data-pathname))
385              o-pathname)
386    
387            (progn
388              (when (probe-file c-pathname) (delete-file c-pathname))
389              (when (probe-file h-pathname) (delete-file h-pathname))
390              (when (probe-file data-pathname) (delete-file data-pathname))
391              (format t "~&No FASL generated.~%")
392              (setq *error-p* t)
393              (values)
394              ))))))
395    
396    (defun gazonk-name ( &aux tem)
397      (dotimes (i 1000)
398               (unless (probe-file (setq tem (merge-pathnames (format nil "gazonk~d.lsp" i))))
399                      (return-from gazonk-name (pathname tem))))
400      (error "1000 gazonk names used already!"))
401    
402    (defun prin1-cmp (form strm)
403      (let ((*compiler-output-data* strm)
404            (*fasd-data* nil))
405        (wt-data1 form)  ;; this binds all the print stuff
406        ))
407    
408    
409    (defun compile (name &optional def &aux tem gaz (*default-pathname-defaults* #"."))
410    
411      (cond ((not(symbolp name)) (error "Must be a name"))
412            ((and (consp def)
413                  (member (car def) '(lambda )))
414             (or name (setf name 'cmp-anon))
415             (setf (symbol-function name)
416                   def)
417             (compile name))
418            (def (error "def not a lambda expression"))
419            ((setq tem (macro-function name))
420             (setf (symbol-function 'cmp-anon) tem)
421             (compile 'cmp-anon)
422             (setf (macro-function name) (macro-function name))
423             name)
424            ((and (setq tem (symbol-function name))
425                  (consp tem))
426             (let ((na (if (symbol-package name) name 'cmp-anon)))
427               (unless (and (fboundp 'si::init-cmp-anon) (or (si::init-cmp-anon) (fmakunbound 'si::init-cmp-anon)))
428                 (with-open-file
429                  (st (setq gaz (gazonk-name)) :direction :output)
430                  (prin1-cmp `(defun ,na ,@ (ecase (car tem)
431                                                   (lambda (cdr tem))
432                                                   (lambda-block (cddr tem))
433                                                   ))       st))
434                 (let ((fi (compile-file gaz)))
435                   (load fi)
436                   (delete-file fi))
437                 (unless *keep-gaz* (delete-file gaz)))
438               (or (eq na name) (setf (symbol-function name) (symbol-function na)))
439               (symbol-function name)
440               ))
441            (t (error "can't compile ~a" name))))
442    
443    (defun disassemble (name &aux tem)
444      (cond ((and (consp name)
445                  (eq (car name) 'lambda))
446             (eval `(defun cmp-anon ,@ (cdr name)))
447             (disassemble 'cmp-anon))
448            ((not(symbolp name)) (error "Not a lambda or a name"))
449            ((setq tem(macro-function name))
450             (setf (symbol-function 'cmp-tmp-macro) tem)
451             (disassemble 'cmp-tmp-macro)
452             (setf (macro-function name) (macro-function name))
453             name)
454            ((and (setq tem (symbol-function name))
455                  (consp tem)
456                  (eq (car tem) 'lambda-block))
457             (let ((gaz (gazonk-name)))
458               (with-open-file
459                 (st gaz :direction :output)
460                 (prin1-cmp `(defun ,name ,@ (cddr tem))       st))
461             (compile-file gaz
462    ;                      :c-debug t
463                           :h-file t
464                           :c-file t
465                           :system-p 't
466                           :data-file t
467                           :o-file t)
468             (let ((cn (get-output-pathname gaz "c" gaz ))
469                   (dn (get-output-pathname gaz "data" gaz ))
470                   (hn (get-output-pathname gaz "h" gaz ))
471                   (on (get-output-pathname gaz "o" gaz )))
472               (with-open-file (st cn)
473                 (si::copy-stream st *standard-output*))
474               (with-open-file (st dn)
475                 (si::copy-stream st *standard-output*))
476               (with-open-file (st hn)
477                 (si::copy-stream st *standard-output*))
478               (system (si::string-concatenate "objdump -d -l "
479                                               (namestring on)))
480               (delete-file cn)
481               (delete-file dn)
482               (delete-file hn)
483               (delete-file on)
484               (unless *keep-gaz* (delete-file gaz)))))
485            (t (error "can't disassemble ~a" name))))
486            
487    
488    (defun compiler-pass2 (c-pathname h-pathname system-p )
489      (with-open-file (st c-pathname :direction :output)
490        (let ((*compiler-output1* (if (eq system-p 'disassemble) *standard-output*
491                                    st)))
492          (declare (special *compiler-output1*))
493        (with-open-file (*compiler-output2* h-pathname :direction :output)
494          (cond ((and
495                  (stringp *cmpinclude-string*)
496                  (not system-p)
497                  (si::fwrite *cmpinclude-string* 0
498                              (length *cmpinclude-string*) *compiler-output1*)))
499                (t (wt-nl1 "#include " *cmpinclude*)))
500          (wt-nl1 "#include \""
501                  (namestring
502                    (make-pathname :name
503                      (pathname-name h-pathname)
504                       :type (pathname-type h-pathname)))
505    
506                  #+aosvs (string-downcase (namestring h-pathname))
507                  "\"")
508    
509          (catch *cmperr-tag* (ctop-write *init-name*))
510          (if system-p
511              (wt
512               "
513    
514    #ifdef SYSTEM_SPECIAL_INIT
515    SYSTEM_SPECIAL_INIT
516    #endif
517    "))
518    
519          (terpri *compiler-output1*)
520          ;; write ctl-z at end to make sure preprocessor stops!
521          #+dos (write-char (code-char 26) *compiler-output1*)
522          (terpri *compiler-output2*)))))
523    
524    
525    (defvar *cc* "cc")
526    (defvar *ld* "ld")
527    (defvar *ld-libs* "ld-libs")
528    (defvar *opt-three* "")
529    (defvar *opt-two* "")
530    (defvar *init-lsp* "init-lsp")
531    
532    (defvar *use-buggy* nil)
533    
534    (defun  compiler-command (&rest args &aux na )
535      (declare (special *c-debug*))
536      (let ((dirlist (pathname-directory (first args)))
537            (name (pathname-name (first args)))
538            dir
539            )
540        (cond (dirlist (setq dir (namestring (make-pathname :directory dirlist))))
541              (t (setq dir ".")))
542         (setq na  (namestring
543                    (make-pathname :name name :type (pathname-type(first args)))))
544       #+(or dos winnt)
545          (format nil "~a -I~a ~a ~a -c -w ~a -o ~a"
546                  *cc*
547                  (concatenate 'string si::*system-directory* "../h")
548                  (if (and (boundp '*c-debug*) *c-debug*) " -g " "")
549                  (case *speed*
550                        (3 *opt-three* )
551                        (2 *opt-two*)
552                        (t ""))    
553    ;              (case *speed*
554    ;                   (3 #+broken_o4_opt "-O2" #-broken_o4_opt"-O4")
555    ;                   (2 "-O") (t ""))
556                  (namestring (make-pathname  :type "c" :defaults (first args)))
557                  (namestring (make-pathname  :type "o" :defaults (first args)))
558                  )
559    
560       #-(or dos winnt)
561       (format nil  "(cd ~a ;~a -I~a ~a ~a -c ~a ~a)"
562               dir *cc*
563               (concatenate 'string si::*system-directory* "../h")
564               (if (and (boundp '*c-debug*) *c-debug*) " -g " "")
565    ;           (case *speed*
566    ;                (3 #+broken_o4_opt "-O" #-broken_o4_opt"-O4")
567    ;                (2 "-O") (t ""))      
568               (case *speed*
569                     (3 *opt-three* )
570                     (2 *opt-two*)
571                     (t ""))        
572               na
573               (prog1
574                   #+aix3
575                 (format nil " -w ;ar x /lib/libc.a fsavres.o  ; ar qc XXXfsave fsavres.o ; echo init_~a > XXexp ; mv  ~a  XXX~a ; ld -r -D-1 -bexport:XXexp -bgc XXX~a -o ~a XXXfsave ; rm -f XXX~a XXexp XXXfsave fsavres.o"
576                         *init-name*
577                         (setq na (namestring (get-output-pathname na "o" nil)))
578                         na na na na na)
579                 #+(or dlopen irix5)
580                 (if (not system-p)
581                     (format nil
582                             " -w ; mv ~a XX~a ; ld  ~a -shared XX~a  -o ~a -lc ; rm -f XX~a"  
583                             (setq na (namestring (get-output-pathname na "o" nil)))                            na
584                             #+ignore-unresolved "-ignore_unresolved"
585                             #+expect-unresolved "-expect_unresolved '*'"
586                             na na na))    
587                                
588                 #+bsd "-w"
589                 #-(or aix3 bsd irix3) " 2> /dev/null ")
590                      
591                    
592               )
593       )
594      )
595            
596    
597    (defun compiler-cc (c-pathname o-pathname  )
598      (safe-system
599        (format
600         nil
601         (prog1
602             #+irix5 (compiler-command c-pathname o-pathname )
603             #+vax "~a ~@[~*-O ~]-S -I. -w ~a ; as -J -W -o ~A ~A"
604             #+(or system-v e15 dgux sgi ) "~a ~@[~*-O ~]-c -I. ~a 2> /dev/null"
605            (compiler-command c-pathname o-pathname ))
606         *cc*
607         (if (or (= *speed* 2) (= *speed* 3)) t nil)
608                (namestring c-pathname)
609                 (namestring o-pathname)
610      
611                ))
612      
613      #+dont_need
614      (let ((cname (pathname-name c-pathname))
615            (odir (pathname-directory o-pathname))
616            (oname (pathname-name o-pathname)))
617        (unless (and (equalp (truename "./")
618                             (truename (make-pathname :directory odir)))
619                     (equal cname oname))
620            (rename-file (make-pathname :name cname :type "o")
621                                      o-pathname)
622    )))
623    
624    
625    (defun compiler-build (o-pathname data-pathname)
626      #+(and system-v (not e15))
627      (safe-system (format nil "echo \"\\000\\000\\000\\000\" >> ~A"
628                           (namestring o-pathname)))
629        #+(or hp-ux sun sgi)
630        (with-open-file (o-file
631                        (namestring o-pathname)
632                        :direction :output
633                        :if-exists :append)
634          ; we could do a safe-system, but forking is slow on the Iris
635        #+(or hp-ux (and sgi (not irix5)))
636        (dotimes (i 12)
637          (write-char #\^@ o-file))
638        #+sun  ; we could do a safe-system, but forking is slow on the Iris
639        (dolist (v '(0 0 4 16 0 0 0 0))
640                  (write-byte v o-file))
641    
642        )
643      #-ld-not-accept-data  
644      (when (probe-file o-pathname)
645         (nconc-files o-pathname data-pathname)
646        #+never
647        (safe-system (format nil
648                             "cat ~a  >> ~A"
649                             (namestring data-pathname)
650                             (namestring o-pathname)))))
651    
652    (defun print-compiler-info ()
653      (format t "~&OPTIMIZE levels: Safety=~d~:[ (No runtime error checking)~;~], Space=~d, Speed=~d~%"
654              (cond ((null *compiler-check-args*) 0)
655                    ((null *safe-compile*) 1)
656                    ((null *compiler-push-events*) 2)
657                    (t 3))
658              *safe-compile* *space* *speed*))
659    
660    (defun nconc-files (a b)
661      (let* ((n 256)
662             (tem (make-string n))
663             (m 0))
664        (with-open-file (st-a a :direction :output :if-exists :append)
665          (with-open-file (st-b b )
666            (sloop::sloop
667               do (setq m (si::fread tem 0 n st-b))
668               while (and m (> m 0))
669               do (si::fwrite tem 0 m st-a))))))
670    
671    #+dos
672    (progn
673    (defun directory (x &aux ans)
674      (let* ((pa (pathname x))
675             (temp "XXDIR")
676             tem
677             (name (pathname-name pa)))
678        (setq pa (make-pathname :directory (pathname-directory pa)
679                                :name (or (pathname-name pa) :wild)
680                                :type (pathname-type pa)))
681        (setq name (namestring pa))
682        (system (format nil "ls -d ~a > ~a" name temp))
683        (with-open-file (st temp)
684                (loop (setq tem (read-line st nil nil))
685                      (if (and tem (setq tem (probe-file tem)))
686                          (push tem ans) (return))))
687        ans))
688    
689    (defvar *old-compile-file* #'compile-file)
690    (defun compile-file (f &rest l)
691      (let* ((p (pathname f)) dir pwd)
692        (setq dir (pathname-directory p))
693        (when dir
694              (setq dir (namestring (make-pathname :directory dir
695                                                   :name ".")))
696              (setq pwd (namestring (truename ".")))
697              )
698        (unwind-protect
699            (progn (if dir (si::chdir dir))
700                   (apply *old-compile-file* f l))
701          (if pwd (si::chdir pwd)))))
702    
703    (defun user-homedir-pathname ()
704      (or (si::getenv "HOME") "/"))
705    
706    )
707    
708    ;
709    ;  These functions are added to build custom images requiring
710    ;  the loading of binary objects on systems relocating with dlopen.
711    ;
712    
713    (defun make-user-init (files out &aux tem)
714      
715      (setq tem (concatenate 'string out ".c"))
716      (with-open-file (st tem :direction :output)
717                      (format st "#include <string.h>~%")
718                      (format st "#include ~a~%~%" *cmpinclude*)
719    
720                      (format st "#define load2(a) do {")
721                      (format st "printf(\"Loading %s...\\n\",(a));")
722                      (format st "load(a);")
723                      (format st "printf(\"Finished %s...\\n\",(a));} while(0)~%~%")
724    
725                      (let ((p nil))
726                        (dolist (tem files)
727                          (when (equal (pathname-type tem) "o")
728                            (push (list (substitute #\_ #\- (pathname-name tem)) tem) p)))
729    
730                        (setq p (nreverse p))
731    
732                        (dolist (tem p)
733                          (format st "extern void init_~a(void);~%" (car tem)))
734                        (format st "~%")
735    
736                        (format st "typedef struct {void (*fn)(void);char *s;} Fnlst;~%")
737                        (format st "#define NF ~a~%" (length p))
738                        (format st "static Fnlst my_fnlst[NF]={")
739                        (dolist (tem p)
740                          (when (not (eq tem (car p)))
741                            (format st ",~%"))
742                          (format st "{init_~a,\"~a\"}" (car tem) (cadr tem)))
743                        (format st "};~%~%")
744                        
745                        (format st "object user_init(void) {~%")
746                        (dolist (tem files)
747                          (cond ((equal (cadr (car p)) tem)
748                                 (format st "gcl_init_or_load1(init_~a,\"~a\");~%" (car (car p)) (cadr (car p)))
749                                 (setq p (cdr p)))
750                                (t
751                                 (format st "load2(\"~a\");~%" tem))))
752                        (format st "return Cnil;}~%~%")
753    
754                        (format st "int user_match(const char *s,int n) {~%")
755                        (format st "  const Fnlst *f;~%")
756                        (format st "  for (f=my_fnlst;f<my_fnlst+NF;f++){~%")
757                        (format st "     if (!strncmp(s,f->s,n)) {~%")
758                        (format st "        gcl_init_or_load1(f->fn,f->s);~%")
759                        (format st "        return 1;~%")
760                        (format st "     }~%")
761                        (format st "  }~%")
762                        (format st "  return 0;~%")
763                        (format st "}~%~%")))
764                        
765      (compiler-cc tem (concatenate 'string out ".o"))
766    ;  (system (format nil "~a ~a" *cc* tem))
767      (delete-file tem)
768      
769    )
770    
771    (defun link (files image &optional post extra-libs (run-user-init t) &aux raw init)
772    
773      (make-user-init files "user-init")
774      (setq raw (format nil "raw_~a" (pathname-name image)))
775      (setq init (format nil "init_~a.lsp" (pathname-name image)))
776    
777      (system
778       (format nil "~a ~a user-init.o ~a -L~a ~a ~a"
779               *ld*
780               raw
781               (let ((sfiles ""))
782                              (dolist (tem files)
783                                      (if (equal (pathname-type tem) "o")
784                                      (setq sfiles (concatenate 'string sfiles " " tem))))
785                              sfiles)
786               si::*system-directory*
787               *ld-libs*
788               (if (stringp extra-libs) extra-libs "")))
789    
790      (delete-file "user-init.o")
791    
792      (with-open-file (st init :direction :output)
793                      (unless run-user-init
794                        (format st "(fmakunbound 'si::user-init)~%"))
795                      (format st "(setq si::*no-init* '(")
796                      (dolist (tem files)
797                              (format st " \"~a\"" (pathname-name tem)))
798                      (format st "))~%")
799                      (with-open-file (st1
800                                       (format nil "~a~a" si::*system-directory* *init-lsp*))
801                                      (si::copy-stream st1 st))
802                      (if (stringp post) (format st "~a~%" post))
803                      (format st "(si::save-system \"~a\")~%" image))
804    
805      (system (format nil "./~a ~a < ~a"
806                      raw
807                      si::*system-directory*
808                      init))
809    
810      (delete-file raw)
811      (delete-file init)
812    
813    )

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26