home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / link / unvaxsuspend.t < prev   
Encoding:
Text File  |  1988-02-05  |  6.6 KB  |  189 lines
  1. (herald unvaxsuspend (env tsys (link suspend)))
  2.  
  3. ;;; Look at a Unix a.out description and template.doc
  4.  
  5. (define (suspend obj out-spec x?)
  6.   (set (experimental?) x?)
  7.   (really-suspend obj out-spec 'o))
  8.  
  9.  
  10. (define-constant RELOC-SIZE 8)
  11. (define-constant CYMBAL-SIZE 12)
  12. (define-constant OMAGIC #o407)
  13. (define-constant N_TEXT 4)
  14. (define-constant N_DATA 6)
  15. (define-constant N_UNDF 0)
  16. (define-constant N_EXT 1)
  17.  
  18. (define-constant DATA-RELOC (fixnum-logior N_DATA (fixnum-ashl 2 25)))
  19. (define-constant TEXT-RELOC (fixnum-logior N_TEXT (fixnum-ashl 2 25)))
  20. (define-constant UNDEFINED-RELOC (fixnum-logior (fixnum-ashl 2 25)
  21.                                                 (fixnum-ashl 1 27)))
  22. (define-constant DATA-EXTERNAL (fixnum-logior DATA-RELOC N_EXT))
  23.  
  24. (define (vgc-foreign foreign)
  25.   (let* ((heap (lstate-impure *lstate*))
  26.          (addr (+area-frontier heap))
  27.          (name (foreign-name foreign))
  28.          (desc (object nil
  29.                  ((heap-stored self) (lstate-impure *lstate*))
  30.                  ((heap-offset self) addr)
  31.                  ((write-descriptor self stream)
  32.                   (write-data stream (fx+ addr tag/extend)))
  33.                  ((write-store self stream)
  34.                   (write-int stream header/foreign)
  35.                   (write-slot name stream)
  36.                   (write-int stream 0)))))
  37.     (set (+area-frontier heap) (fx+ addr 12))
  38.     (push (+area-objects heap) desc)
  39.     (set-lp-table-entry (lstate-reloc *lstate*) foreign desc)
  40.     (generate-slot-relocation name (fx+ addr 4))
  41.     (cymbal-thunk (symbol->string name) (fixnum-logior N_UNDF N_EXT) 0)
  42.     (reloc-thunk (fixnum-logior (lstate-symbol-count *lstate*) UNDEFINED-RELOC)
  43.                  (fx+ addr 8))
  44.     (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))
  45.     desc))
  46.  
  47.  
  48. (define (generate-slot-relocation obj slot-address)
  49.   (cond ((or (fixnum? obj) (immediate? obj)))
  50.         ((eq? (heap-stored (vgc obj)) (lstate-impure *lstate*))
  51.          (reloc-thunk DATA-RELOC slot-address))
  52.         (else
  53.          (reloc-thunk TEXT-RELOC slot-address))))
  54.  
  55.         
  56.  
  57. (define (reloc-thunk type address)
  58.   (push (lstate-data-reloc *lstate*)
  59.         (cons address type)))
  60.  
  61. (define (text-relocation addr)
  62.   (reloc-thunk TEXT-RELOC addr))
  63.  
  64. (define (data-relocation addr)
  65.   (reloc-thunk DATA-RELOC addr))
  66.         
  67.                          
  68. (define (write-slot obj stream)
  69.   (cond ((fixnum? obj)
  70.          (write-fixnum stream obj))
  71.         ((immediate? obj)
  72.          (write-immediate stream obj))
  73.         ((null? obj)
  74.          (write-descriptor (lstate-null *lstate*) stream))
  75.         ((lp-table-entry (lstate-reloc *lstate*) obj)
  76.          => (lambda (desc) (write-descriptor desc stream)))
  77.         (else
  78.          (error "bad immediate type ~s" obj))))
  79.  
  80.  
  81.  
  82. (define-integrable (write-data stream int)
  83.   (write-int stream (fx+ (lstate-pure-size *lstate*) int)))
  84.  
  85. (define (write-immediate stream imm)
  86.   (let ((int (descriptor->fixnum imm)))
  87.     (write-half stream (fx+ (fixnum-ashl int 2) 1))
  88.     (write-half stream (fixnum-ashr int 14))))
  89.  
  90.  
  91. (define (write-scratch stream obj i)
  92.   (let ((offset (fixnum-ashl i 2)))
  93.     (write-half stream (mref-16-u obj offset))
  94.     (write-half stream (mref-16-u obj (fx+ offset 2)))))
  95.  
  96. (define (write-int stream int)
  97.   (write-half stream int)
  98.   (let ((int (fixnum-ashr int 16)))
  99.     (write-half stream int)))
  100.  
  101. (define (write-half stream int)
  102.   (vm-write-byte stream int)
  103.   (let ((int (fixnum-ashr int 8)))
  104.     (vm-write-byte stream int)))
  105.  
  106. (define (write-fixnum stream fixnum)
  107.   (write-half stream (fixnum-ashl fixnum 2))
  108.   (write-half stream (fixnum-ashr fixnum 14)))
  109.  
  110. (define (cymbal-thunk stryng type value)
  111.  (push (lstate-symbols *lstate*)
  112.   (object (lambda (stream a)
  113.             ;; a is offset into stryng table
  114.             (write-int stream a)
  115.             (vm-write-byte stream type)
  116.             (vm-write-byte stream 0)       ; other
  117.             (write-half stream 0)       ; see <stab.h>                 
  118.             (if (fixnum? value)            ; undefined external (foreign)
  119.                 (write-int stream 0)
  120.                 (write-descriptor value stream)))
  121.           ((cymbal-thunk.stryng self) stryng))))
  122.  
  123. (define-operation (cymbal-thunk.stryng thunk))
  124.  
  125. (define (make-global-cymbal proc name)
  126.   (cond ((lp-table-entry (lstate-reloc *lstate*) proc)
  127.        => (lambda (desc)                                
  128.             (cymbal-thunk (string-downcase! (symbol->string name))
  129.                           (fixnum-logior N_DATA N_EXT)
  130.                           desc)
  131.             (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))))
  132.         (else
  133.          (error "~s not defined" name))))
  134.  
  135.  
  136.  
  137. (define (write-link-file stream)                
  138.   (make-global-cymbal big_bang 'big_bang)
  139.   (make-global-cymbal interrupt_dispatcher 'interrupt_dispatcher)
  140.   (write-header     stream)
  141.   (write-out-area       stream (lstate-pure *lstate*))
  142.   (write-out-area       stream (lstate-impure *lstate*))
  143.   (write-relocation stream (lstate-data-reloc *lstate*))  
  144.   (write-cymbal&stryng-table stream (reverse (lstate-symbols *lstate*))))
  145.  
  146. (define (write-header stream)
  147.   (let* ((text-size (+area-frontier (lstate-pure *lstate*)))
  148.          (data-size (+area-frontier (lstate-impure *lstate*))))
  149.     (write-int stream OMAGIC)                 ;magic number
  150.     (write-int stream text-size)              ;text segment size
  151.     (write-int stream data-size)              ;data segment size
  152.     (write-int stream 0)                      ;bss  segment size
  153.     (write-int stream (fx* CYMBAL-SIZE (lstate-symbol-count *lstate*)))
  154.     (write-int stream 0)                      ;bogus entry point
  155.     (write-int stream 0)                      ; no text relocation
  156.     (write-int stream (fx* (length (lstate-data-reloc *lstate*)) RELOC-SIZE))))
  157.  
  158. (define (write-out-area stream area)
  159.   (walk (lambda (x) (write-store x stream))
  160.         (reverse! (+area-objects area))))
  161.  
  162.  
  163. (define (write-relocation stream items)
  164.   (walk (lambda (item)
  165.           (write-int stream (car item))
  166.           (write-int stream (cdr item)))
  167.         items))
  168.           
  169.                              
  170. (define (write-cymbal&stryng-table stream cyms)
  171.   (let ((z (write-cyms stream cyms))) ; cymbal table
  172.     (write-int stream z)       ; size of stryng table
  173.     (walk (lambda (s)             ; write stryng table
  174.             (write-string stream (cymbal-thunk.stryng s))
  175.             (vm-write-byte stream 0))
  176.            cyms)))
  177.  
  178. (define (write-cyms stream cyms)
  179.   (iterate loop ((a 4)                      ;; 4 bytes for size of stryng table
  180.                  (l cyms))
  181.     (cond ((null? l) a)
  182.           (else
  183.            (let ((e (car l)))
  184.              (e stream a)
  185.              (loop (fx+ (fx+ a (string-length (cymbal-thunk.stryng e))) 1) ;null
  186.                    (cdr l)))))))
  187.  
  188.  
  189.