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 / crsend.scm < prev    next >
Text File  |  1999-01-02  |  6KB  |  177 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: crsend.scm,v 1.10 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 End
  23. ;;; This program does not need the rest of the compiler, but should
  24. ;;; match the version of the same name in crstop.scm and toplev.scm
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define (cross-compile-bin-file-end input-string #!optional output-string)
  29.   (compiler-pathnames input-string
  30.               (and (not (default-object? output-string)) output-string)
  31.               (make-pathname false false false false "moc" 'NEWEST)
  32.     (lambda (input-pathname output-pathname)
  33.       output-pathname            ;ignore
  34.       (cross-compile-scode-end (fasload input-pathname)))))
  35.  
  36. (define (compiler-pathnames input-string output-string default transform)
  37.   (let ((kernel
  38.       (lambda (input-string)
  39.         (let ((input-pathname (merge-pathnames input-string default)))
  40.           (let ((output-pathname
  41.              (let ((output-pathname
  42.                 (pathname-new-type input-pathname "com")))
  43.                (if output-string
  44.                (merge-pathnames output-string output-pathname)
  45.                output-pathname))))
  46.         (newline)
  47.         (write-string "Compile File: ")
  48.         (write (enough-namestring input-pathname))
  49.         (write-string " => ")
  50.         (write (enough-namestring output-pathname))
  51.         (fasdump (transform input-pathname output-pathname)
  52.              output-pathname))))))
  53.     (if (pair? input-string)
  54.     (for-each kernel input-string)
  55.     (kernel input-string))))
  56.  
  57. (define (cross-compile-scode-end cross-compilation)
  58.   (let ((compile-by-procedures? (vector-ref cross-compilation 0))
  59.     (expression (cross-link-end (vector-ref cross-compilation 1)))
  60.     (others (map cross-link-end (vector-ref cross-compilation 2))))
  61.     (if (null? others)
  62.     expression
  63.     (scode/make-comment
  64.      (make-dbg-info-vector
  65.       (let ((all-blocks
  66.          (list->vector
  67.           (cons
  68.            (compiled-code-address->block expression)
  69.            others))))
  70.         (if compile-by-procedures?
  71.         (list 'COMPILED-BY-PROCEDURES
  72.               all-blocks
  73.               (list->vector others))
  74.         all-blocks)))
  75.      expression))))
  76.  
  77. (define-structure (cc-code-block (type vector)
  78.                  (conc-name cc-code-block/))
  79.   (debugging-info false read-only false)
  80.   (bit-string false read-only true)
  81.   (objects false read-only true)
  82.   (object-width false read-only true))
  83.  
  84. (define-structure (cc-vector (type vector)
  85.                  (constructor cc-vector/make)
  86.                  (conc-name cc-vector/))
  87.   (code-vector false read-only true)
  88.   (entry-label false read-only true)
  89.   (entry-points false read-only true)
  90.   (label-bindings false read-only true)
  91.   (ic-procedure-headers false read-only true))
  92.  
  93. (define (cross-link-end object)
  94.   (let ((code-vector (cc-vector/code-vector object)))
  95.     (cross-link/process-code-vector
  96.      (cond ((compiled-code-block? code-vector)
  97.         code-vector)
  98.        ((vector? code-vector)
  99.         (let ((new-code-vector (cross-link/finish-assembly
  100.                     (cc-code-block/bit-string code-vector)
  101.                     (cc-code-block/objects code-vector)
  102.                     (cc-code-block/object-width code-vector))))
  103.           (set-compiled-code-block/debugging-info!
  104.            new-code-vector
  105.            (cc-code-block/debugging-info code-vector))
  106.           new-code-vector))
  107.        (else
  108.         (error "cross-link-end: Unexpected code-vector"
  109.            code-vector object)))
  110.      object)))
  111.  
  112. (define (cross-link/process-code-vector code-vector cc-vector)
  113.   (let ((bindings
  114.      (let ((label-bindings (cc-vector/label-bindings cc-vector)))
  115.        (map (lambda (label)
  116.           (cons
  117.            label
  118.            (with-absolutely-no-interrupts
  119.              (lambda ()
  120.                (let-syntax ((ucode-primitive
  121.                      (macro (name)
  122.                        (make-primitive-procedure name)))
  123.                     (ucode-type
  124.                      (macro (name)
  125.                        (microcode-type name))))
  126.              ((ucode-primitive PRIMITIVE-OBJECT-SET-TYPE)
  127.               (ucode-type COMPILED-ENTRY)
  128.               (make-non-pointer-object
  129.                (+ (cdr (or (assq label label-bindings)
  130.                        (error "Missing entry point" label)))
  131.                   (object-datum code-vector)))))))))
  132.         (cc-vector/entry-points cc-vector)))))
  133.     (let ((label->expression
  134.        (lambda (label)
  135.          (cdr (or (assq label bindings)
  136.               (error "Label not defined as entry point" label))))))
  137.       (let ((expression (label->expression (cc-vector/entry-label cc-vector))))
  138.     (for-each (lambda (entry)
  139.             (set-lambda-body! (car entry)
  140.                       (label->expression (cdr entry))))
  141.           (cc-vector/ic-procedure-headers cc-vector))
  142.     expression))))
  143.  
  144. (define (cross-link/finish-assembly code-block objects scheme-object-width)
  145.   (let-syntax ((ucode-primitive
  146.         (macro (name)
  147.           (make-primitive-procedure name)))
  148.            (ucode-type
  149.         (macro (name)
  150.           (microcode-type name))))
  151.     (let* ((bl (quotient (bit-string-length code-block)
  152.              scheme-object-width))
  153.        (non-pointer-length
  154.         ((ucode-primitive make-non-pointer-object) bl))
  155.        (output-block (make-vector (1+ (+ (length objects) bl)))))
  156.       (with-absolutely-no-interrupts
  157.     (lambda ()
  158.       (vector-set! output-block 0
  159.                ((ucode-primitive primitive-object-set-type)
  160.             (ucode-type manifest-nm-vector)
  161.             non-pointer-length))))
  162.       (write-bits! output-block
  163.            ;; After header just inserted.
  164.            (* scheme-object-width 2)
  165.            code-block)
  166.       (insert-objects! output-block objects (1+ bl))
  167.       (object-new-type (ucode-type compiled-code-block)
  168.                output-block))))
  169.  
  170. (define (insert-objects! v objects where)
  171.   (cond ((not (null? objects))
  172.      (vector-set! v where (cadar objects))
  173.      (insert-objects! v (cdr objects) (1+ where)))
  174.     ((not (= where (vector-length v)))
  175.      (error "insert-objects!: object phase error" where))
  176.     (else
  177.      unspecific)))