home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / base / crstop.scm < prev    next >
Text File  |  1999-01-02  |  5KB  |  155 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: crstop.scm,v 1.13 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Cross Compiler Top Level.
  23. ;;; This code shares and should be merged with "toplev.scm".
  24. ;;; Many of the procedures only differ in the default extensions.
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define (cross-compile-bin-file input-string #!optional output-string)
  29.   (let ((input-default
  30.      (make-pathname false false false false "bin" 'NEWEST))
  31.     (output-default
  32.      (make-pathname false false false false "moc" false)))
  33.     (compiler-pathnames
  34.      input-string
  35.      (if (not (default-object? output-string))
  36.      output-string
  37.      (merge-pathnames output-default
  38.               (merge-pathnames input-string input-default)))
  39.      input-default
  40.      (lambda (input-pathname output-pathname)
  41.        (maybe-open-file compiler:generate-rtl-files?
  42.             (pathname-new-type output-pathname "rtl")
  43.      (lambda (rtl-output-port)
  44.        (maybe-open-file compiler:generate-lap-files?
  45.                 (pathname-new-type output-pathname "lap")
  46.          (lambda (lap-output-port)
  47.            (cross-compile-scode (compiler-fasload input-pathname)
  48.                     (pathname-new-type output-pathname
  49.                                "fni")
  50.                     rtl-output-port
  51.                     lap-output-port)))))))))
  52.  
  53. (define (cross-compile-bin-file-end input-string #!optional output-string)
  54.   (compiler-pathnames
  55.    input-string
  56.    (and (not (default-object? output-string)) output-string)
  57.    (make-pathname false false false false "moc" 'NEWEST)
  58.    (lambda (input-pathname output-pathname)
  59.      output-pathname            ; ignored
  60.      (cross-compile-scode-end (compiler-fasload input-pathname)))))
  61.  
  62. (define (cross-compile-scode-end cross-compilation)
  63.   (in-compiler
  64.    (lambda ()
  65.      (cross-link-end cross-compilation)
  66.      *result*)))
  67.  
  68. ;;; This should be merged with compile-scode
  69.  
  70. (define (cross-compile-scode scode
  71.                  #!optional
  72.                  info-output-pathname
  73.                  rtl-output-port
  74.                  lap-output-port
  75.                  wrapper)
  76.   (let ((info-output-pathname
  77.      (if (default-object? info-output-pathname)
  78.          false
  79.          info-output-pathname))
  80.     (rtl-output-port
  81.      (if (default-object? rtl-output-port) false rtl-output-port))
  82.     (lap-output-port
  83.      (if (default-object? lap-output-port) false lap-output-port))
  84.     (wrapper
  85.      (if (default-object? wrapper) in-compiler wrapper)))
  86.     (fluid-let ((compiler:compile-by-procedures? false)
  87.         (compiler:cross-compiling? true)
  88.         (compiler:dump-info-file compiler:dump-inf-file)
  89.         (*info-output-filename*
  90.          (if (pathname? info-output-pathname)
  91.              (->namestring info-output-pathname)
  92.              *info-output-filename*))
  93.         (*rtl-output-port* rtl-output-port)
  94.         (*lap-output-port* lap-output-port))
  95.       ((if (default-object? wrapper)
  96.        in-compiler
  97.        wrapper)
  98.        (lambda ()
  99.      (set! *input-scode* scode)
  100.      (phase/fg-generation)
  101.      (phase/fg-optimization)
  102.      (phase/rtl-generation)
  103.      (phase/rtl-optimization)
  104.      (if rtl-output-port
  105.          (phase/rtl-file-output rtl-output-port))
  106.      (phase/lap-generation)
  107.      (phase/lap-linearization)
  108.      (if lap-output-port
  109.          (phase/lap-file-output lap-output-port))
  110.      (phase/assemble)
  111.      ;; Here is were this procedure differs
  112.      ;; from compile-scode
  113.      (if info-output-pathname
  114.          (cross-compiler-phase/info-generation-2 info-output-pathname))
  115.      (cross-compiler-phase/link)
  116.      *result*)))))
  117.  
  118. (define-structure (cc-code-block (type vector)
  119.                  (conc-name cc-code-block/))
  120.   (debugging-info false read-only false)
  121.   (bit-string false read-only true)
  122.   (objects false read-only true)
  123.   (object-width false read-only true))
  124.  
  125. (define-structure (cc-vector (type vector)
  126.                  (constructor cc-vector/make)
  127.                  (conc-name cc-vector/))
  128.   (code-vector false read-only true)
  129.   (entry-label false read-only true)
  130.   (entry-points false read-only true)
  131.   (label-bindings false read-only true)
  132.   (ic-procedure-headers false read-only true))
  133.  
  134. (define (cross-compiler-phase/info-generation-2 pathname)
  135.   (info-generation-2 pathname set-cc-code-block/debugging-info!))
  136.  
  137. (define (cross-compiler-phase/link)
  138.   (compiler-phase
  139.    "Cross Linkification"
  140.    (lambda ()
  141.      (set! *result*
  142.        (cc-vector/make *code-vector*
  143.                (last-reference *entry-label*)
  144.                (last-reference *entry-points*)
  145.                (last-reference *label-bindings*)
  146.                (last-reference *ic-procedure-headers*)))
  147.      unspecific)))
  148.  
  149. (define (cross-link-end cc-vector)
  150.   (set! *code-vector* (cc-vector/code-vector cc-vector))
  151.   (set! *entry-label* (cc-vector/entry-label cc-vector))
  152.   (set! *entry-points* (cc-vector/entry-points cc-vector))
  153.   (set! *label-bindings* (cc-vector/label-bindings cc-vector))
  154.   (set! *ic-procedure-headers* (cc-vector/ic-procedure-headers cc-vector))
  155.   (phase/link))