home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / link / hpsuspend.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  6.3 KB  |  176 lines
  1. (herald hpsuspend (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. (define-constant RELOC-SIZE 8)
  10. (define-constant CYMBOL-SIZE 8)
  11. (define-constant N_TEXT #o2)
  12. (define-constant N_DATA #o3)
  13. (define-constant N_UNDF 0)
  14. (define-constant N_EXT #o40)         
  15. (define-constant R_TEXT (fx+ (fixnum-ashl 0 8) 2))  ; 0 for text, 2 for long
  16. (define-constant R_DATA (fx+ (fixnum-ashl 1 8) 2))  ; 1 for data, 2 for long
  17. (define-constant R_UNDF (fx+ (fixnum-ashl 3 8) 2))  ; 3 for undf, 2 for long
  18.  
  19. (define (vgc-foreign foreign)
  20.   (let* ((heap (lstate-impure *lstate*))
  21.          (addr (+area-frontier heap))
  22.          (name (foreign-name foreign))
  23.          (desc (object nil
  24.                  ((heap-stored self) (lstate-impure *lstate*))
  25.                  ((heap-offset self) addr)
  26.                  ((write-descriptor self stream)
  27.                   (write-data stream (fx+ addr tag/extend)))
  28.                  ((write-store self stream)
  29.                   (write-int stream header/foreign)
  30.                   (write-slot name stream)
  31.                   (write-int stream 0)))))
  32.     (set (+area-frontier heap) (fx+ addr 12))
  33.     (push (+area-objects heap) desc)
  34.     (set-lp-table-entry (lstate-reloc *lstate*) foreign desc)
  35.     (generate-slot-relocation name (fx+ addr 4))
  36.     (cymbol-thunk (symbol->string name) (fixnum-logior N_UNDF N_EXT) 0)
  37.     (reloc-thunk (fx+ addr 8) (lstate-symbol-count *lstate*) R_UNDF)
  38.     (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))
  39.     desc))
  40.  
  41. (define (generate-slot-relocation obj slot-address)
  42.   (cond ((or (fixnum? obj) (immediate? obj)))
  43.         ((eq? (heap-stored (vgc obj)) (lstate-impure *lstate*))
  44.          (reloc-thunk slot-address 0 R_DATA))
  45.         (else
  46.          (reloc-thunk slot-address 0 R_TEXT))))
  47.             
  48. (define (text-relocation addr)
  49.   (reloc-thunk addr 0 R_TEXT))
  50.  
  51. (define (data-relocation addr)
  52.   (reloc-thunk addr 0 R_DATA))
  53.  
  54. (define (reloc-thunk address symbolnum type)
  55.   (push (lstate-data-reloc *lstate*) 
  56.         (cons address (fx+ (fixnum-ashl symbolnum 16) type))))
  57.  
  58. (define (write-slot obj stream)
  59.   (cond ((fixnum? obj)
  60.          (write-fixnum stream obj))
  61.         ((immediate? obj)
  62.          (write-immediate stream obj))
  63.         ((null? obj)
  64.          (write-descriptor (lstate-null *lstate*) stream))
  65.         ((lp-table-entry (lstate-reloc *lstate*) obj)
  66.          => (lambda (desc) (write-descriptor desc stream)))
  67.         (else
  68.          (error "bad immediate type ~s" obj))))
  69.  
  70. (define-integrable (write-int stream int)
  71.   (write-half stream (fixnum-ashr int 16))
  72.   (write-half stream int))
  73.                        
  74. (define-integrable (write-immediate stream imm)
  75.   (let ((int (descriptor->fixnum imm)))
  76.     (write-half stream (fixnum-ashr int 14))
  77.     (write-half stream (fx+ (fixnum-ashl int 2) 1))))
  78.                                                      
  79. (define-integrable (write-scratch stream obj i)
  80.   (let ((offset (fixnum-ashl i 2)))
  81.     (write-half stream (mref-16-u obj offset))
  82.     (write-half stream (mref-16-u obj (fx+ offset 2)))))
  83.     
  84. (define-integrable (write-half stream int)
  85.   (vm-write-byte stream (fixnum-ashr int 8))
  86.   (vm-write-byte stream int))
  87.  
  88. ;(define-integrable (write-byte stream n)
  89. ;  (writec stream (ascii->char (fixnum-logand n 255))))
  90.  
  91. (define-integrable (write-fixnum stream fixnum)
  92.   (write-half stream (fixnum-ashr fixnum 14))
  93.   (write-half stream (fixnum-ashl fixnum 2)))
  94.  
  95.  
  96. (define (cymbol-thunk string type value)
  97.  (push (lstate-symbols *lstate*)              
  98.    (let ((len (string-length string)))
  99.      (object (lambda (stream)     
  100.                (if (fixnum? value)
  101.                    (write-int stream 0)
  102.                    (write-descriptor value stream))
  103.                (vm-write-byte stream type)
  104.                (vm-write-byte stream len)
  105.                (write-int stream 0)
  106.                (write-string stream string))
  107.              ((cymbol-thunk.length self) len)))))
  108.  
  109. (define-operation (cymbol-thunk.length thunk))
  110.  
  111. (define (compute-cymbol-table-size)
  112.   (do ((cyms (lstate-symbols *lstate*) (cdr cyms))
  113.        (size 0 (fx+ size (fx+ 10 (cymbol-thunk.length (car cyms))))))
  114.       ((null? cyms) size)))                                            
  115.  
  116.  
  117. (define-integrable (write-data stream int)
  118.   (write-int stream (fx+ (lstate-pure-size *lstate*) int)))
  119.  
  120. (define (write-zeroes stream n)
  121.   (do ((i 0 (fx+ i 1)))
  122.       ((fx= i n) t)
  123.     (write-int stream 0)))
  124.  
  125. (define (make-global-cymbol proc name)
  126.   (cond ((lp-table-entry (lstate-reloc *lstate*) proc)
  127.        => (lambda (desc)                                
  128.             (cymbol-thunk (string-downcase! (symbol->string name))
  129.                           (fixnum-logior N_DATA N_EXT)
  130.                           desc)))
  131.       (else
  132.        (error "~s not defined" name))))
  133.  
  134.  
  135. (define (write-link-file stream)                 
  136.   (make-global-cymbol big_bang 'big_bang)
  137.   (make-global-cymbol interrupt_dispatcher 'interrupt_dispatcher)
  138.   (write-header     stream)
  139.   (write-area       stream (lstate-pure *lstate*))
  140.   (write-area       stream (lstate-impure *lstate*))
  141.   (write-cymbol-table stream (reverse (lstate-symbols *lstate*)))
  142.   (write-relocation stream (lstate-data-reloc *lstate*)))  
  143.  
  144. (define (write-header stream)
  145.   (let* ((text-size (+area-frontier (lstate-pure *lstate*)))
  146.          (data-size (+area-frontier (lstate-impure *lstate*))))
  147.     (write-half stream #x20C)                 ; system-id
  148.     (write-half stream #x106)                 ; file format
  149.     (write-zeroes stream 2)
  150.     (write-int stream text-size)              ;text segment size
  151.     (write-int stream data-size)              ;data segment size
  152.     (write-zeroes stream 2)                      ;bss  segment size
  153.     (write-int stream (fx* (length (lstate-data-reloc *lstate*)) RELOC-SIZE))
  154.     (write-int stream 0)
  155.     (write-int stream (compute-cymbol-table-size))
  156.     (write-zeroes stream 6))) 
  157.  
  158. (define (write-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 (reloc) 
  165.           (write-int stream (car reloc))   ; address
  166.           (write-int stream (cdr reloc)))
  167.         (sort-list! items 
  168.                     (lambda (x y)      
  169.                       (fx< (car x) (car y))))))
  170.  
  171.                              
  172. (define (write-cymbol-table stream cyms)
  173.   (walk (lambda (thunk) (thunk stream)) cyms))
  174.  
  175.  
  176.