home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmpmain.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  23.3 KB  |  683 lines
  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. #+(and bsd (not seq) (not sgi) (not convex)) (pushnew 'buggy-cc *features*)
  49. #+ibmrt (pushnew 'buggy-cc *features*)
  50.  
  51. ;; Let the user write dump c-file etc to  /dev/null.
  52. (defun get-output-pathname (file ext name &optional (dir (pathname-directory *default-pathname-defaults*)))
  53.   (cond #+unix
  54.     ((equal file "/dev/null") (pathname file))
  55.     #+aix3
  56.     ((and (equal name "float")
  57.           (equal ext "h"))
  58.      (get-output-pathname file ext "Float" ))
  59.     (t
  60.       (make-pathname :directory (or (and (not (null file))
  61.                          (not (eq file t))
  62.                          (pathname-directory file))
  63.                     dir)
  64.              :name (or (and (not (null file))
  65.                     (not (eq file t))
  66.                     (pathname-name file))
  67.                    name)
  68.              :type ext))))
  69.  
  70. #+unix
  71. (defun safe-system (string)
  72.   (let ((result (system string)))
  73.     (unless (zerop result)
  74.       (cerror "Continues anyway."
  75.               "(SYSTEM ~S) returned a non-zero value ~D."
  76.               string
  77.               result)
  78.       (setq *error-p* t))
  79.     (values result)))
  80.  
  81. ;; If this is t we use fasd-data on all but system-p files.   If it
  82. ;; is :system-p we use it on all files.   If nil use it on none.
  83. (defvar *fasd-data* t)
  84. (defvar *data* nil)
  85.  
  86. ;;  (list section-length split-file-names next-section-start-file-position)
  87. ;;  Many c compilers cannot handle the large C files resulting from large lisp files.
  88. ;;  If *split-files* is a number then, separate compilations for sections
  89. ;;  *split-files* long, with the 
  90. ;;  will be performed for separate chunks of the lisp files.
  91. (defvar *split-files* nil)  ;; if 
  92.  
  93. (defun check-end (form eof)
  94.   (cond  ((eq form eof)
  95.       (setf (third *split-files*) nil))
  96.      ((> (file-position *compiler-input*)
  97.          (car *split-files*))
  98.       (setf (third *split-files*)(file-position *compiler-input*)))))
  99.       
  100.  
  101. (defun compile-file  (&rest args
  102.                 &aux (*print-pretty* nil)
  103.                 (*package* *package*) (*split-files* *split-files*)
  104.                 (*PRINT-CIRCLE* NIL)
  105.                 (*PRINT-RADIX* NIL)
  106.                 (*PRINT-ARRAY* T)
  107.                 (*PRINT-LEVEL* NIL)
  108.                 (*PRINT-PRETTY* T)
  109.                 (*PRINT-LENGTH* NIL)
  110.                 (*PRINT-GENSYM* T)
  111.                 (*PRINT-CASE* :UPCASE)
  112.                 (*PRINT-BASE* 10)
  113.                 (*PRINT-ESCAPE* T)
  114.                 (section-length *split-files*)
  115.                 tem)
  116.   (loop 
  117.    (compiler::init-env)
  118.    (setq tem (apply 'compiler::compile-file1 args))
  119.    (cond ((atom *split-files*)(return tem))
  120.      ((and (consp *split-files*)
  121.            (null (third *split-files*)))
  122.       (let ((gaz (let ((*DEFAULT-PATHNAME-DEFAULTS* (car args)))
  123.                                 (gazonk-name)))
  124.         (*readtable* (si::standard-readtable)))
  125.         (setq gaz (get-output-pathname gaz "lsp" (car args)))
  126.         (with-open-file (st gaz :direction :output)
  127.           (print
  128.            `(eval-when (load eval)
  129.                (dolist (v ',(nreverse (second *split-files*)))
  130.                    (load (merge-pathnames v si::*load-pathname*))))
  131.            st))
  132.         (setq *split-files* nil)
  133.         (or (member :output-file args)
  134.         (setq args (append args (list :output-file (car args)))))
  135.         (return 
  136.          (prog1 (apply 'compile-file gaz (cdr args))
  137.            (delete-file gaz)))
  138.         ))
  139.      (t nil))
  140.    (if (consp *split-files*)
  141.        (setf (car *split-files*) (+ (third *split-files*) section-length)))
  142.    ))
  143.  
  144.  
  145. (defun compile-file1 (input-pathname
  146.                       &key (output-file input-pathname)
  147.                            #+aosvs (fasl-file t)
  148.                            #+unix (o-file t)
  149.                            (c-file nil)
  150.                            (h-file nil)
  151.                            (data-file nil)
  152.                (c-debug nil)
  153.                            #+aosvs (ob-file nil)
  154.                            (system-p nil)
  155.                (print nil)
  156.                            (load nil)
  157.                       &aux (*standard-output* *standard-output*)
  158.                            (*error-output* *error-output*)
  159.                            (*compiler-in-use* *compiler-in-use*)
  160.                (*c-debug* c-debug)
  161.                (*compile-print* (or print *compile-print*))
  162.                            (*package* *package*)
  163.                (*DEFAULT-PATHNAME-DEFAULTS* #"")
  164.                (*data* (list (make-array 50 :fill-pointer 0
  165.                              :adjustable t
  166.                              )
  167.                      nil ;inits
  168.                      nil
  169.                      ))
  170.                *init-name*     
  171.                (*fasd-data* *fasd-data*)
  172.                            (*error-count* 0))
  173.   (declare (special *c-debug* *init-name*))
  174.  
  175.   (cond (*compiler-in-use*
  176.          (format t "~&The compiler was called recursively.~%~
  177. Cannot compile ~a."
  178.                  (namestring (merge-pathnames input-pathname #".lsp")))
  179.          (setq *error-p* t)
  180.          (return-from compile-file1 (values)))
  181.         (t (setq *error-p* nil)
  182.            (setq *compiler-in-use* t)))  
  183.  
  184.   (unless (probe-file (merge-pathnames input-pathname #".lsp"))
  185.     (format t "~&The source file ~a is not found.~%"
  186.             (namestring (merge-pathnames input-pathname #".lsp")))
  187.     (setq *error-p* t)
  188.     (return-from compile-file1 (values)))
  189.  
  190.   (when *compile-verbose*
  191.     (format t "~&Compiling ~a."
  192.             (namestring (merge-pathnames input-pathname #".lsp"))))
  193.  
  194.   (and *record-call-info* (clear-call-table))
  195.  
  196.   (with-open-file
  197.           (*compiler-input* (merge-pathnames input-pathname #".lsp"))
  198.  
  199.  
  200.     (cond ((numberp *split-files*)
  201.        (if (< (file-length *compiler-input*) *split-files*)
  202.            (setq *split-files* nil)
  203.          ;;*split-files* = ( section-length split-file-names next-section-start-file-position
  204.          ;;                           package-ops)
  205.          (setq *split-files* (list *split-files* nil 0 nil)))))
  206.  
  207.     (cond ((consp *split-files*)
  208.        (file-position *compiler-input* (third *split-files*))
  209.        (setq output-file
  210.          (make-pathname :directory (pathname-directory output-file)
  211.                 :name (format nil "~a~a"
  212.                           (length (second *split-files*))
  213.                           (pathname-name (pathname output-file)))
  214.                 :type "o"))
  215.        
  216.        (push (pathname-name output-file)   (second *split-files*))
  217.        ))
  218.        
  219.     
  220.      
  221.     
  222.   (let* ((eof (cons nil nil))
  223.          (dir (or (and (not (null output-file))
  224.                        (pathname-directory output-file))
  225.                   (pathname-directory input-pathname)))
  226.          (name (or (and (not (null output-file))
  227.                         (pathname-name output-file))
  228.                    (pathname-name input-pathname)))
  229.          #+aosvs (fasl-pathname (get-output-pathname fasl-file "fasl" name dir))
  230.          #+unix (o-pathname (get-output-pathname o-file "o" name dir))
  231.          (c-pathname (get-output-pathname c-file "c" name dir))
  232.          #+buggy-cc
  233.          (s-pathname (merge-pathnames ".s" (pathname-name c-pathname) name))
  234.          (h-pathname (get-output-pathname h-file "h" name dir))
  235.          (data-pathname (get-output-pathname data-file "data" name dir))
  236.      (i-pathname  (get-output-pathname data-file "i" name dir))
  237.          #+aosvs (ob-pathname (get-output-pathname ob-file "ob" name dir))
  238.          )
  239.     (declare (special dir name))
  240.  
  241.     (init-env)
  242.  
  243.     (and (boundp 'si::*gcl-version*)
  244.      (add-init `(si::warn-version ,si::*gcl-version*)))
  245.  
  246.     (when (probe-file #+unix "./cmpinit.lsp" #+aosvs "=cmpinit.lsp")
  247.       (load #+unix "./cmpinit.lsp" #+aosvs "=cmpinit.lsp"
  248.             :verbose *compile-verbose*))
  249.  
  250.     (with-open-file (*compiler-output-data*
  251.                      #+unix data-pathname #+aosvs fasl-pathname
  252.                      :direction :output)
  253.     (progn 
  254.       (setq *fasd-data*                    
  255.         (cond  ((if system-p (eq *fasd-data* :system-p)
  256.               *fasd-data*)
  257.             (list
  258.              (si::open-fasd *compiler-output-data* :output nil nil)
  259.              ;(si::open-fasd *compiler-output-i* :output nil nil)
  260.              ))))
  261.  
  262.       (wt-data-begin)
  263.  
  264.       (let* ((rtb *readtable*)
  265.                (prev (and (eq (get-macro-character #\# rtb)
  266.                               (get-macro-character
  267.                                 #\# (si:standard-readtable)))
  268.                           (get-dispatch-macro-character #\# #\, rtb))))
  269.           (if (and prev (eq prev (get-dispatch-macro-character
  270.                                    #\# #\, (si:standard-readtable))))
  271.               (set-dispatch-macro-character #\# #\,
  272.                 'si:sharp-comma-reader-for-compiler rtb)
  273.               (setq prev nil))
  274.       
  275.       ;; t1expr the package ops again..
  276.       (if (consp *split-files*)
  277.           (dolist (v (fourth *split-files*)) (t1expr v)))
  278.           (unwind-protect
  279.             (do ((form (read *compiler-input* nil eof)
  280.                        (read *compiler-input* nil eof))
  281.          (load-flag (or (eq :defaults *eval-when-defaults*)
  282.                 (member 'load *eval-when-defaults*))))
  283.                 (nil)
  284.               (cond
  285.            ((eq form eof))
  286.            (load-flag (t1expr form))
  287.            ((maybe-eval nil form)))
  288.           (cond
  289.            ((and *split-files* (check-end form eof))
  290.         (setf (fourth *split-files*) (reverse (third *data*)))
  291.         (return nil))
  292.            ((eq form eof) (return nil)))
  293.           )
  294.         
  295.  
  296.             (when prev (set-dispatch-macro-character #\# #\, prev rtb)))))
  297.  
  298.          (setq *init-name*
  299.           (substitute #\_ #\-
  300.               (if system-p    
  301.                   #-aosvs (pathname-name input-pathname)
  302.                   #+aosvs (string-downcase
  303.                        (pathname-name input-pathname))
  304.                   "code")))
  305.  
  306.       (when (zerop *error-count*)
  307.         (when *compile-verbose* (format t "~&End of Pass 1.  "))
  308.         (compiler-pass2 c-pathname h-pathname system-p ))
  309.     
  310.  
  311.       (wt-data-end)
  312.  
  313.       ) ;;; *compiler-output-data* closed.
  314.  
  315.     (init-env)
  316.  
  317.     (if (zerop *error-count*)
  318.  
  319.         #+aosvs
  320.         (progn
  321.           (when *compile-verbose* (format t "~&End of Pass 2.  "))
  322.           (when data-file
  323.             (with-open-file (in fasl-pathname)
  324.               (with-open-file (out data-pathname :direction :output)
  325.                 (si:copy-stream in out))))
  326.           (cond ((or fasl-file ob-file)
  327.                  (compiler-cc c-pathname ob-pathname)
  328.                  (cond ((probe-file ob-pathname)
  329.                         (when fasl-file
  330.                               (compiler-build ob-pathname fasl-pathname)
  331.                               (when load (load fasl-pathname)))
  332.                         (unless ob-file (delete-file ob-pathname))
  333.                         (when *compile-verbose*
  334.                               (print-compiler-info)
  335.                               (format t "~&Finished compiling ~a." (namestring output-file))
  336.                   ))
  337.                        (t (format t "~&Your C compiler failed to compile the intermediate file.~%")
  338.                           (setq *error-p* t))))
  339.                 (*compile-verbose*
  340.                  (print-compiler-info)
  341.                  (format t "~&Finished compiling ~a." (namestring output-file)
  342.              )))
  343.           (unless c-file (delete-file c-pathname))
  344.           (unless h-file (delete-file h-pathname))
  345.           (unless fasl-file (delete-file fasl-pathname)))
  346.  
  347.         #+unix
  348.         (progn
  349.           (when *compile-verbose* (format t "~&End of Pass 2.  "))
  350.       (cond (*record-call-info*
  351.          (dump-fn-data (get-output-pathname output-file "fn" name dir))))
  352.           (cond (o-file
  353.                  (compiler-cc c-pathname o-pathname #+buggy-cc s-pathname )
  354.                  (cond ((probe-file o-pathname)
  355.                         (compiler-build o-pathname data-pathname)
  356.                         (when load (load o-pathname))
  357.                         #+buggy-cc (and (probe-file s-pathname)
  358.                                     (delete-file s-pathname))
  359.                         (when *compile-verbose*
  360.                               (print-compiler-info)
  361.                               (format t "~&Finished compiling ~a." (namestring output-file)
  362.                       )))
  363.                        (t #+buggy-cc (when (probe-file s-pathname)
  364.                                            (delete-file s-pathname))
  365.                           (format t "~&Your C compiler failed to compile the intermediate file.~%")
  366.                           (setq *error-p* t))))
  367.                  (*compile-verbose*
  368.                   (print-compiler-info)
  369.                   (format t "~&Finished compiling ~a." (namestring output-file)
  370.               )))
  371.           (unless c-file (delete-file c-pathname))
  372.           (unless h-file (delete-file h-pathname))
  373.           (unless (or data-file #+ld-not-accept-data system-p) (delete-file data-pathname))
  374.       o-pathname)
  375.  
  376.         (progn
  377.           (when (probe-file c-pathname) (delete-file c-pathname))
  378.           (when (probe-file h-pathname) (delete-file h-pathname))
  379.           #+aosvs
  380.           (when (probe-file fasl-pathname) (delete-file fasl-pathname))
  381.           #+unix
  382.           (when (probe-file data-pathname) (delete-file data-pathname))
  383.           (format t "~&No FASL generated.~%")
  384.           (setq *error-p* t)
  385.       (values)
  386.       ))))))
  387.  
  388. (defun gazonk-name ( &aux tem)
  389.   (dotimes (i 1000)
  390.        (unless (probe-file (setq tem (merge-pathnames (format nil "gazonk~d.lsp" i))))
  391.           (return-from gazonk-name (pathname tem))))
  392.   (error "1000 gazonk names used already!"))
  393.  
  394. (defun prin1-cmp (form strm)
  395.   (let ((*compiler-output-data* strm)
  396.     (*fasd-data* nil))
  397.     (wt-data1 form)  ;; this binds all the print stuff
  398.     ))
  399.  
  400.  
  401. (defun compile (name &optional def &aux tem gaz (*default-pathname-defaults* #"."))
  402.   (cond ((not(symbolp name)) (error "Must be a name"))
  403.     ((and (consp def)
  404.           (member (car def) '(lambda )))
  405.      (or name (setf name 'cmp-anon))
  406.      (setf (symbol-function name)
  407.            def)
  408.      (compile name))
  409.     (def (error "def not a lambda expression"))
  410.     ((setq tem(macro-function name))
  411.      (setf (symbol-function 'cmp-anon) tem)
  412.      (compile 'cmp-anon)
  413.      (setf (macro-function name) (macro-function name))
  414.      name)
  415.     ((and (setq tem (symbol-function name))
  416.           (consp tem))
  417.      (let ((na (if (symbol-package name) name 'cmp-anon)))
  418.        (with-open-file
  419.            (st (setq gaz (gazonk-name)) :direction :output)
  420.          (prin1-cmp `(defun ,na ,@ (ecase (car tem)
  421.                      (lambda (cdr tem))
  422.                      (lambda-block (cddr tem))
  423.                      ))       st))
  424.        (let ((fi (compile-file gaz)))
  425.          (load fi)
  426.          (delete-file fi)
  427.          (delete-file gaz)
  428.          (or (eq na name) (setf (symbol-function name) (symbol-function na)))
  429.          (symbol-function name)
  430.          )))
  431.     (t (error "can't compile ~a" name))))
  432.  
  433. (defun disassemble (name &aux tem form)
  434.   (cond ((and (consp name)
  435.           (eq (car name) 'lambda))
  436.      (eval `(defun cmp-anon ,@ (cdr name)))
  437.      (disassemble 'cmp-anon))
  438.     ((not(symbolp name)) (error "Not a lambda or a name"))
  439.     ((setq tem(macro-function name))
  440.      (setf (symbol-function 'cmp-tmp-macro) tem)
  441.      (disassemble 'cmp-tmp-macro)
  442.      (setf (macro-function name) (macro-function name))
  443.      name)
  444.     ((and (setq tem (symbol-function name))
  445.           (consp tem)
  446.           (eq (car tem) 'lambda-block))
  447.      (with-open-file
  448.          (st (setq gaz (gazonk-name)) :direction :output)
  449.        (prin1-cmp `(defun ,name ,@ (cddr tem))       st))
  450.      (let ((fi (compile-file gaz :h-file t
  451.                   :system-p 'disassemble
  452.                  :data-file t :o-file nil)))
  453.        (with-open-file (st (get-output-pathname gaz "data" gaz ))
  454.          (si::copy-stream st *standard-output*)(delete-file st))
  455.        (with-open-file (st (get-output-pathname gaz "h" gaz ))
  456.          (si::copy-stream st *standard-output*)(delete-file st))
  457.        (delete-file gaz)
  458.        ))
  459.     (t (error "can't disassemble ~a" name))))
  460.      
  461.  
  462. (defun compiler-pass2 (c-pathname h-pathname system-p )
  463.   (with-open-file (st c-pathname :direction :output)
  464.     (let ((*compiler-output1* (if (eq system-p 'disassemble) *standard-output*
  465.                 st)))
  466.       (declare (special *compiler-output1*))
  467.     (with-open-file (*compiler-output2* h-pathname :direction :output)
  468.       (cond ((and 
  469.           (stringp *cmpinclude-string*)
  470.           (not system-p)
  471.           (si::fwrite *cmpinclude-string* 0
  472.               (length *cmpinclude-string*) *compiler-output1*)))
  473.         (t (wt-nl1 "#include " *cmpinclude*)))
  474.       (wt-nl1 "#include \""
  475.               #-buggy-cc   (namestring h-pathname)
  476.           #+buggy-cc
  477.           (namestring
  478.             (make-pathname :name
  479.               (pathname-name h-pathname)
  480.                :type (pathname-type h-pathname)))
  481.  
  482.               #+aosvs (string-downcase (namestring h-pathname))
  483.               "\"")
  484.  
  485.       (catch *cmperr-tag* (ctop-write *init-name*))
  486.  
  487.       (terpri *compiler-output1*)
  488.       ;; write ctl-z at end to make sure preprocessor stops!
  489.       #+dos (write-char (code-char 26) *compiler-output1*)
  490.       (terpri *compiler-output2*)))))
  491.  
  492. #+aosvs
  493. (defun compiler-cc (c-pathname ob-pathname)
  494.   (process "cc.pr" ; or ":usr:dgc:cc.pr"
  495.            (format nil "cc/opt=~d/noextl/e=@null/o=~a,~a"
  496.                    *speed* (namestring ob-pathname) (namestring c-pathname))
  497.            :block t :ioc t)
  498.   (when (string/= (princ (last-termination-message)) "") (terpri)))
  499.  
  500. (defvar *cc* "cc")
  501. #+buggy-cc 
  502. (defvar *use-buggy* nil)
  503. #+buggy-cc
  504. (defun  compiler-command (&rest args &aux na )
  505.   (declare (special *c-debug*))
  506.   (setq na  (namestring
  507.           (make-pathname :name
  508.                  (pathname-name (first args))
  509.                  :type (pathname-type(first args)))))
  510.   (cond (*use-buggy*
  511.      "~a ~@[~*-O ~]-S -I. -w ~a ; as -J -o ~A ~A")
  512.     (t
  513.      (format nil #-dos "(cd ~a ;~a ~a ~@[~*-O ~]-c -I. ~a ~a)"
  514.          #+dos "~a ~a ~@[~*-O ~]-c -I. ~a ~a"
  515.               
  516.         #-dos (let ((dir      (pathname-directory (first args))))
  517.            (cond (dir (namestring (make-pathname :directory dir)))
  518.              (t ".")))
  519.         *cc*
  520.                  (if (and (boundp '*c-debug*) *c-debug*) " -g " "")
  521.          (if (or (= *speed* 2) (= *speed* 3)) t nil)
  522.           na
  523.           (prog1
  524.               #+aix3
  525.             (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"
  526.                           *init-name*
  527.                     (setq na (namestring (get-output-pathname na "o" nil)))
  528.                     na na na na na)    
  529.                 
  530.             #+bsd "-w"
  531.             #-(or aix3 bsd) " 2> /dev/null ")
  532.          
  533.          ))))
  534.         
  535. #+unix
  536. (defun compiler-cc (c-pathname o-pathname #+buggy-cc s-pathname )
  537.   #+e15
  538.   (let ((C (namestring
  539.             (make-pathname
  540.              :directory (pathname-directory c-pathname)
  541.              :name (pathname-name c-pathname)
  542.              :type "C")))
  543.         (H (namestring
  544.             (make-pathname
  545.              :directory (pathname-directory h-pathname)
  546.              :name (pathname-name h-pathname)
  547.              :type "H"))))
  548.     (system (format nil "mv ~A ~A" (namestring c-pathname) C))
  549.     (system (format nil "mv ~A ~A" (namestring h-pathname) H))
  550.     (system (format nil "~Atrans < ~A > ~A"
  551.               (namestring si:*system-directory*) C (namestring c-pathname)))
  552.     (system (format nil "~Atrans < ~A > ~A"
  553.               (namestring si:*system-directory*) H (namestring h-pathname)))
  554.     (delete-file C)
  555.     (delete-file H))
  556.  
  557.   (safe-system
  558.     (format nil
  559.             #-(or system-v e15 dgux sgi )
  560.               #+buggy-cc
  561.                 #+vax"~a ~@[~*-O ~]-S -I. -w ~a ; as -J -W -o ~A ~A"
  562.         #-vax (compiler-command c-pathname o-pathname s-pathname)
  563.               #-buggy-cc "~a ~@[~*-O ~]-c -I. -w ~a"
  564.             #+(or system-v e15 dgux sgi ) "~a ~@[~*-O ~]-c -I. ~a 2> /dev/null"
  565.           *cc*
  566.             (if (or (= *speed* 2) (= *speed* 3)) t nil)
  567.             (namestring c-pathname)
  568.             #+buggy-cc (namestring o-pathname)
  569.             #+buggy-cc (namestring s-pathname)
  570.             ))
  571.   #-buggy-cc
  572.   (let ((cname (pathname-name c-pathname))
  573.         (odir (pathname-directory o-pathname))
  574.         (oname (pathname-name o-pathname)))
  575.     (unless (and (equalp (truename "./")
  576.                          (truename (make-pathname :directory odir)))
  577.                  (equal cname oname))
  578.             (safe-system
  579.              (format nil "mv ~A.o ~A" cname (namestring o-pathname))))))
  580.  
  581. #+aosvs
  582. (defun compiler-build (ob-pathname fasl-pathname)
  583.   (process
  584.     (namestring
  585.       (merge-pathnames si:*system-directory* "build_fasl.pr"))
  586.     (si:string-concatenate
  587.       "build_fasl," (namestring fasl-pathname) ","
  588.       (namestring ob-pathname))
  589.     :block t :ioc t)
  590.   (when (string/= (last-termination-message) "")
  591.     (setq *error-p* t)
  592.     (princ (last-termination-message))
  593.     (terpri)))
  594.  
  595.  
  596. #+unix
  597. (defun compiler-build (o-pathname data-pathname)
  598.   #+(and system-v (not e15))
  599.   (safe-system (format nil "echo \"\\000\\000\\000\\000\" >> ~A"
  600.                        (namestring o-pathname)))
  601.     #+(or hp-ux sun sgi)
  602.     (with-open-file (o-file
  603.             (namestring o-pathname)
  604.             :direction :output
  605.             :if-exists :append)
  606.       ; we could do a safe-system, but forking is slow on the Iris
  607.     #+(or hp-ux sgi)  
  608.     (dotimes (i 12)
  609.       (write-char #\^@ o-file))
  610.     #+sun  ; we could do a safe-system, but forking is slow on the Iris
  611.     (dolist (v '(0 0 4 16 0 0 0 0))
  612.           (write-byte v o-file))
  613.  
  614.     )
  615.   #-ld-not-accept-data  
  616.   (when (probe-file o-pathname)
  617.     #+dos (nconc-files o-pathname data-pathname)
  618.     #-dos
  619.     (safe-system (format nil
  620.              "cat ~a  >> ~A"
  621.              (namestring data-pathname)
  622.              (namestring o-pathname)))))
  623.  
  624. (defun print-compiler-info ()
  625.   (format t "~&OPTIMIZE levels: Safety=~d~:[ (No runtime error checking)~;~], Space=~d, Speed=~d~%"
  626.           (cond ((null *compiler-check-args*) 0)
  627.                 ((null *safe-compile*) 1)
  628.                 ((null *compiler-push-events*) 2)
  629.                 (t 3))
  630.           *safe-compile* *space* *speed*))
  631.  
  632. #+dos
  633. (progn
  634. (defun directory (x &aux ans)
  635.   (let* ((pa (pathname x))
  636.      (temp "XXDIR")
  637.      tem
  638.      (name (pathname-name pa)))
  639.     (setq pa (make-pathname :directory (pathname-directory pa)
  640.                 :name (or (pathname-name pa) :wild)
  641.                 :type (pathname-type pa)))
  642.     (setq name (namestring pa))
  643.     (system (format nil "ls -d ~a > ~a" name temp))
  644.     (with-open-file (st temp)
  645.         (loop (setq tem (read-line st nil nil))
  646.           (if (and tem (setq tem (probe-file tem)))
  647.               (push tem ans) (return))))
  648.     ans))
  649.  
  650. (defvar *old-compile-file* #'compile-file) 
  651. (defun compile-file (f &rest l)
  652.   (let* ((p (pathname f)) dir pwd)
  653.     (setq dir (pathname-directory p))
  654.     (when dir
  655.       (setq dir (namestring (make-pathname :directory dir
  656.                            :name ".")))
  657.       (setq pwd (namestring (truename ".")))
  658.       )
  659.     (unwind-protect
  660.     (progn (if dir (si::chdir dir))
  661.            (apply *old-compile-file* f l))
  662.       (if pwd (si::chdir pwd)))))
  663.  
  664. (defun user-homedir-pathname ()
  665.   (or (si::getenv "HOME") "/"))
  666.  
  667.  
  668. (defun nconc-files (a b)
  669.   (let* ((n 256)
  670.      (tem (make-string n))
  671.      (m 0))
  672.     (with-open-file (st-a a :direction :output :if-exists :append)
  673.       (with-open-file (st-b b )
  674.     (sloop::sloop
  675.        do (setq m (si::fread tem 0 n st-b))
  676.        while (and m (> m 0))
  677.        do (si::fwrite tem 0 m st-a))))))
  678.     
  679.  
  680.  
  681. )
  682.  
  683.