home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / link / hp_link.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  8.4 KB  |  235 lines
  1. (herald hp300link (env t (link defs)))
  2.  
  3. ;;; Look at a Unix a.out description and template.doc
  4.  
  5. (define (link modules out-spec)
  6.   (really-link modules 'mo out-spec 'o))
  7.  
  8. (define-constant %%d-ieee-size 53)
  9. (define-constant %%d-ieee-excess 1023)
  10.  
  11. (define (write-double-float stream float)
  12.   (receive (sign mantissa exponent)
  13.            (normalized-float-parts float
  14.                                    %%d-ieee-size 
  15.                                    %%d-ieee-excess 
  16.                                    t)
  17.     (write-int stream header/double-float)
  18.     (write-half stream (fx+ (fixnum-ashl sign 15)
  19.                             (fx+ (fixnum-ashl exponent 4)
  20.                                  (bignum-bit-field mantissa 48 4))))
  21.     (write-half stream (bignum-bit-field mantissa 32 16)) 
  22.     (write-half stream (bignum-bit-field mantissa 16 16)) 
  23.     (write-half stream (bignum-bit-field mantissa 0 16))))
  24.   
  25. (define (write-vcell-header var stream)
  26.   (write-half stream 0)
  27.   (write-byte stream (if (fx= (vector-length (var-node-refs var))
  28.                   0)
  29.              0
  30.              -1))
  31.   (write-byte stream (if (eq? (var-node-defined var) 'define)
  32.              (fx+ header/vcell 128)
  33.              header/vcell)))
  34.  
  35. (define (write-template stream tmplt)
  36.   (write-byte stream (cit-pointer tmplt))
  37.   (write-byte stream (cit-scratch tmplt))
  38.   (write-half stream (cit-unit-offset tmplt))
  39.   (write-byte stream (cit-header/nary? tmplt))
  40.   (write-byte stream (cit-nargs tmplt))
  41.   (write-half stream M68-JUMP-ABSOLUTE)
  42.   (write-int  stream 
  43.               (fx+ (heap-offset (table-entry *reloc-table* (cit-code-vec tmplt)))
  44.                           (fx+ CELL (cit-aux-offset tmplt))))) ;; for header
  45.  
  46.  
  47. ;;; fetch the template store slots out of the closure-internal-template's
  48. ;;; auxiliary template.                  
  49.  
  50. (define (set-template-store-slots ts code index offset)
  51.   (set (cit-unit-offset ts) (fx* (fx+ offset 1) CELL))
  52.   (set (cit-pointer ts) (bref-8 code (fx- index 6)))
  53.   (set (cit-scratch ts) (bref-8 code (fx- index 5)))
  54.   (set (cit-nargs ts)   (bref-8 code (fx- index 1)))
  55.   (set (cit-header/nary? ts) (bref-8 code (fx- index 2)))
  56.   (set (cit-code-vec ts) code)
  57.   (set (cit-aux-offset ts) index))
  58.  
  59.  
  60. (define-constant RELOC-SIZE 8)
  61. (define-constant CYMBOL-SIZE 8)
  62. (define-constant N_TEXT #o2)
  63. (define-constant N_DATA #o3)
  64. (define-constant N_UNDF 0)
  65. (define-constant N_EXT #o40)         
  66. (define-constant R_TEXT (fx+ (fixnum-ashl 0 8) 2))  ; 0 for text, 2 for long
  67. (define-constant R_DATA (fx+ (fixnum-ashl 1 8) 2))  ; 1 for data, 2 for long
  68. (define-constant R_UNDF (fx+ (fixnum-ashl 3 8) 2))  ; 3 for undf, 2 for long
  69.  
  70. (define (vgc-copy-foreign foreign)
  71.   (let* ((heap (lstate-impure *lstate*))
  72.          (addr (area-frontier heap))
  73.          (name (foreign-object-name foreign))
  74.          (desc (object nil
  75.                  ((heap-stored self) (lstate-impure *lstate*))
  76.                  ((heap-offset self) addr)
  77.                  ((write-descriptor self stream)
  78.                   (write-data stream (fx+ addr tag/extend)))
  79.                  ((write-store self stream)
  80.                   (write-int stream header/foreign)
  81.                   (write-slot name stream)
  82.                   (write-int stream 0)))))
  83.     (set (area-frontier heap) (fx+ addr 12))
  84.     (set-table-entry *reloc-table* foreign desc)
  85.     (generate-slot-relocation name (fx+ addr 4))
  86.     (push (area-objects heap) desc)                
  87.     (cymbol-thunk (symbol->string name) (fixnum-logior N_UNDF N_EXT) 0)
  88.     (reloc-thunk (fx+ addr 8) (lstate-symbol-count *lstate*) R_UNDF)
  89.     (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))
  90.     desc))
  91.  
  92. (define (relocate-unit-variable var addr external?)
  93.   (let ((type (var-value-type var)))
  94.    (cond (type
  95.     (cond ((and external? (neq? (var-node-value var) NONVALUE))
  96.            (cymbol-thunk (string-downcase! (symbol->string (var-node-name var)))
  97.                          (fixnum-logior type N_EXT)
  98.                          (unit-var-value (var-node-value var)))
  99.            (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))))
  100.     (if (fx= type N_DATA)
  101.         (reloc-thunk addr 0 R_DATA)
  102.         (reloc-thunk addr 0 R_TEXT))))))
  103.  
  104.  
  105.  
  106. (define (var-value-type var)
  107.   (let ((value (var-node-value var)))
  108.     (cond ((eq? value NONVALUE) 
  109.            (vgc (var-node-name var))
  110.            nil)
  111.           ((unit-loc? value) N_DATA)
  112.           (else
  113.            (let ((desc (vgc value)))
  114.              (if (eq? (heap-stored desc) (lstate-impure *lstate*))
  115.                  N_DATA                                                                
  116.                  N_TEXT))))))
  117.  
  118. (define (generate-slot-relocation obj slot-address)
  119.   (cond ((or (fixnum? obj) (char? obj) (eq? obj '#t)))
  120.         ((eq? (heap-stored (vgc obj)) (lstate-impure *lstate*))
  121.          (reloc-thunk slot-address 0 R_DATA))
  122.         (else
  123.          (reloc-thunk slot-address 0 R_TEXT))))
  124.             
  125. (define (text-relocation addr)
  126.   (reloc-thunk addr 0 R_TEXT))
  127.  
  128. (define (data-relocation addr)
  129.   (reloc-thunk addr 0 R_DATA))
  130.  
  131. (define (reloc-thunk address symbolnum type)
  132.   (push (lstate-data-reloc *lstate*) 
  133.         (cons address (fx+ (fixnum-ashl symbolnum 16) type))))
  134.  
  135. (define (write-slot obj stream)
  136.   (cond ((table-entry *reloc-table* obj)
  137.          => (lambda (desc) (write-descriptor desc stream)))
  138.         ((fixnum? obj)
  139.          (write-fixnum stream obj))
  140.         ((char? obj)
  141.          (write-int stream (fx+ (fixnum-ashl (char->ascii obj) 8)
  142.                                  header/char)))
  143.         ((eq? obj '#t)
  144.          (write-int stream header/true))
  145.         (else
  146.          (error "bad immediate type ~s" obj))))
  147.  
  148. (define-integrable (write-int stream int)
  149.   (write-half stream (fixnum-ashr int 16))
  150.   (write-half stream int))
  151.  
  152. (define (write-half stream int)
  153.   (write-byte stream (fixnum-ashr int 8))
  154.   (write-byte stream int))
  155.  
  156. (define-integrable (write-byte stream n)
  157.   (writec stream (ascii->char (fixnum-logand n 255))))
  158.                                  
  159. (define-integrable (write-fixnum stream fixnum)
  160.   (write-half stream (fixnum-ashr fixnum 14))
  161.   (write-half stream (fixnum-ashl fixnum 2)))
  162.  
  163. (define (cymbol-thunk string type value)
  164.  (push (lstate-symbols *lstate*)              
  165.    (let ((len (string-length string)))
  166.      (object (lambda (stream)     
  167.                (if (fx= value 0)
  168.                    (write-int stream 0)
  169.                    (write-data stream value))
  170.                (write-byte stream type)
  171.                (write-byte stream len)
  172.                (write-int stream 0)
  173.                (write-string stream string))
  174.              ((cymbol-thunk.length self) len)))))
  175.  
  176. (define-operation (cymbol-thunk.length thunk))
  177.  
  178. (define (compute-cymbol-table-size)
  179.   (do ((cyms (lstate-symbols *lstate*) (cdr cyms))
  180.        (size 0 (fx+ size (fx+ 10 (cymbol-thunk.length (car cyms))))))
  181.       ((null? cyms) size)))                                            
  182.  
  183.  
  184. (define-integrable (write-data stream int)
  185.   (write-int stream (fx+ (lstate-pure-size *lstate*) int)))
  186.  
  187. (define (write-zeroes stream n)
  188.   (do ((i 0 (fx+ i 1)))
  189.       ((fx= i n) t)
  190.     (write-int stream 0)))
  191.  
  192. (define (write-link-file stream)
  193.   (write-header     stream)
  194.   (write-area       stream (lstate-pure *lstate*))
  195.   (write-area       stream (lstate-impure *lstate*))
  196.   (write-cymbol-table stream (reverse (lstate-symbols *lstate*)))
  197.   (write-relocation stream (lstate-data-reloc *lstate*)))  
  198.  
  199. (define (write-header stream)
  200.   (let* ((text-size (area-frontier (lstate-pure *lstate*)))
  201.          (data-size (area-frontier (lstate-impure *lstate*))))
  202.     (write-half stream #x20C)                 ; system-id
  203.     (write-half stream #x106)                 ; file format
  204.     (write-zeroes stream 2)
  205.     (write-int stream text-size)              ;text segment size
  206.     (write-int stream data-size)              ;data segment size
  207.     (write-zeroes stream 2)                      ;bss  segment size
  208.     (write-int stream (fx* (length (lstate-data-reloc *lstate*)) RELOC-SIZE))
  209.     (write-int stream 0)
  210.     (write-int stream (compute-cymbol-table-size))
  211.     (write-zeroes stream 6))) 
  212.  
  213. (define (write-area stream area)
  214.   (walk (lambda (x) (write-store x stream))
  215.         (reverse! (area-objects area))))
  216.  
  217.  
  218. (define (write-relocation stream items)
  219.   (walk (lambda (reloc) 
  220.           (write-int stream (car reloc))   ; address
  221.           (write-int stream (cdr reloc)))
  222.         (sort-list! items 
  223.                     (lambda (x y)      
  224.                       (fx< (car x) (car y))))))
  225.  
  226.  
  227.                              
  228. (define (write-map-entry stream name value) 
  229.   (ignore stream name value))
  230.  
  231. (define (write-cymbol-table stream cyms)
  232.   (walk (lambda (thunk) (thunk stream)) cyms))
  233.  
  234.  
  235.