home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / link / sun_link.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  8.5 KB  |  237 lines
  1. (herald sunlink (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-constant RELOC-SIZE 8)
  36. (define-constant CYMBAL-SIZE 12)
  37. (define-constant OMAGIC #o407)
  38. (define-constant N_TEXT 4)
  39. (define-constant N_DATA 6)
  40. (define-constant N_UNDF 0)
  41. (define-constant N_EXT 1)
  42.  
  43. (define (write-template stream tmplt)
  44.   (write-byte stream (cit-pointer tmplt))
  45.   (write-byte stream (cit-scratch tmplt))
  46.   (write-half stream (cit-unit-offset tmplt))
  47.   (write-byte stream (cit-header/nary? tmplt))
  48.   (write-byte stream (cit-nargs tmplt))
  49.   (write-half stream M68-JUMP-ABSOLUTE)
  50.   (write-int  stream 
  51.               (fx+ (heap-offset (table-entry *reloc-table* (cit-code-vec tmplt)))
  52.                           (fx+ CELL (cit-aux-offset tmplt))))) ;; for header
  53.  
  54.  
  55. ;;; fetch the template store slots out of the closure-internal-template's
  56. ;;; auxiliary template.                  
  57.  
  58. (define (set-template-store-slots ts code index offset)
  59.   (set (cit-unit-offset ts) (fx* (fx+ offset 1) CELL))
  60.   (set (cit-pointer ts) (bref-8 code (fx- index 6)))
  61.   (set (cit-scratch ts) (bref-8 code (fx- index 5)))
  62.   (set (cit-nargs ts)   (bref-8 code (fx- index 1)))
  63.   (set (cit-header/nary? ts) (bref-8 code (fx- index 2)))
  64.   (set (cit-code-vec ts) code)
  65.   (set (cit-aux-offset ts) index))
  66.  
  67. (define (vgc-copy-foreign foreign)
  68.   (let* ((heap (lstate-impure *lstate*))
  69.          (addr (area-frontier heap))
  70.          (name (foreign-object-name foreign))
  71.          (desc (object nil
  72.                  ((heap-stored self) (lstate-impure *lstate*))
  73.                  ((heap-offset self) addr)
  74.                  ((write-descriptor self stream)
  75.                   (write-data stream (fx+ addr tag/extend)))
  76.                  ((write-store self stream)
  77.                   (write-int stream header/foreign)
  78.                   (write-slot name stream)
  79.                   (write-int stream 0)))))
  80.     (set (area-frontier heap) (fx+ addr 12))
  81.     (set-table-entry *reloc-table* foreign desc)
  82.     (generate-slot-relocation name (fx+ addr 4))
  83.     (push (area-objects heap) desc)                
  84.     (cymbal-thunk (symbol->string name) (fixnum-logior N_UNDF N_EXT) 0)
  85.     (reloc-thunk (fixnum-logior (fixnum-ashl (lstate-symbol-count *lstate*) 8)
  86.                                 #x50)
  87.                  (fx+ addr 8))
  88.     (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))
  89.     desc))
  90.  
  91. (define (relocate-unit-variable var addr external?)
  92.   (let ((area (lstate-impure *lstate*))
  93.         (type (var-value-type var)))
  94.    (cond (type
  95.     (cond ((and external? (neq? (var-node-value var) NONVALUE))
  96.            (cymbal-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 #x740 addr)
  102.         (reloc-thunk #x540 addr))))))
  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 #x640 slot-address))
  122.         (else
  123.          (reloc-thunk #x440 slot-address))))
  124.  
  125. (define (text-relocation addr)
  126.   (reloc-thunk #x440 addr))
  127.  
  128. (define (data-relocation addr)
  129.   (reloc-thunk #x640 addr))
  130.         
  131.  
  132. (define (reloc-thunk type address)
  133.   (push (lstate-data-reloc *lstate*)
  134.         (cons address type)))
  135.  
  136. (define (cymbal-thunk stryng type value)
  137.  (push (lstate-symbols *lstate*)
  138.   (object (lambda (stream a)
  139.             ;; a is offset into stryng table
  140.             (write-int stream a)
  141.             (write-byte stream type)
  142.             (write-byte stream 0)       ; other
  143.             (write-half stream 0)       ; see <stab.h>                 
  144.             (if (fx= type 1)            ; undefined external (foreign)
  145.                 (write-int stream 0)
  146.                 (write-data stream value)))
  147.           ((cymbal-thunk.stryng self) stryng))))
  148.  
  149. (define-operation (cymbal-thunk.stryng thunk))
  150.  
  151.  
  152. (define (write-slot obj stream)
  153.   (cond ((table-entry *reloc-table* obj)
  154.          => (lambda (desc) (write-descriptor desc stream)))
  155.         ((fixnum? obj)
  156.          (write-fixnum stream obj))
  157.         ((char? obj)
  158.          (write-int stream (fx+ (fixnum-ashl (char->ascii obj) 8)
  159.                                  header/char)))
  160.         ((eq? obj '#t)
  161.          (write-int stream header/true))
  162.         (else
  163.          (error "bad immediate type ~s" obj))))
  164.  
  165. (define-integrable (write-data stream int)
  166.   (write-int stream (fx+ (lstate-pure-size *lstate*) int)))
  167.  
  168. (define-integrable (write-int stream int)
  169.   (write-half stream (fixnum-ashr int 16))
  170.   (write-half stream int))
  171.  
  172. (define (write-half stream int)
  173.   (write-byte stream (fixnum-ashr int 8))
  174.   (write-byte stream int))
  175.  
  176. (define-integrable (write-byte stream n)
  177.   (writec stream (ascii->char (fixnum-logand n 255))))
  178.                                  
  179. (define-integrable (write-fixnum stream fixnum)
  180.   (write-half stream (fixnum-ashr fixnum 14))
  181.   (write-half stream (fixnum-ashl fixnum 2)))
  182.  
  183.  
  184. (define (write-link-file stream)
  185.   (write-header     stream)
  186.   (write-area       stream (lstate-pure *lstate*))
  187.   (write-area       stream (lstate-impure *lstate*))
  188.   (write-relocation stream (lstate-data-reloc *lstate*))  
  189.   (write-cymbal&stryng-table stream (reverse (lstate-symbols *lstate*))))
  190.  
  191. (define (write-header stream)
  192.   (let* ((text-size (area-frontier (lstate-pure *lstate*)))
  193.          (data-size (area-frontier (lstate-impure *lstate*))))
  194.     (write-half stream 2)                     ; only on mc68020
  195.     (write-half stream OMAGIC)                ;magic number
  196.     (write-int stream text-size)              ;text segment size
  197.     (write-int stream data-size)              ;data segment size
  198.     (write-int stream 0)                      ;bss  segment size
  199.     (write-int stream (fx* CYMBAL-SIZE (lstate-symbol-count *lstate*)))
  200.     (write-int stream 0)                      ;bogus entry point
  201.     (write-int stream 0)                      ; no text relocation
  202.     (write-int stream (fx* (length (lstate-data-reloc *lstate*)) RELOC-SIZE))))
  203.  
  204. (define (write-area stream area)
  205.   (walk (lambda (x) (write-store x stream))
  206.         (reverse! (area-objects area))))
  207.  
  208.  
  209. (define (write-relocation stream items)
  210.   (walk (lambda (item)
  211.           (write-int stream (car item))
  212.           (write-int stream (cdr item)))
  213.         items))
  214.           
  215.                              
  216. (define (write-map-entry stream name value) nil)
  217.  
  218. (define (write-cymbal&stryng-table stream cyms)
  219.   (let ((z (write-cyms stream cyms))) ; cymbal table
  220.     (write-int stream z)       ; size of stryng table
  221.     (walk (lambda (s)             ; write stryng table
  222.             (write-string stream (cymbal-thunk.stryng s))
  223.             (write-byte stream 0))
  224.            cyms)))
  225.  
  226. (define (write-cyms stream cyms)
  227.   (iterate loop ((a 4)                      ;; 4 bytes for size of stryng table
  228.                  (l cyms))
  229.     (cond ((null? l) a)
  230.           (else
  231.            (let ((e (car l)))
  232.              (e stream a)
  233.              (loop (fx+ (fx+ a (string-length (cymbal-thunk.stryng e))) 1) ;null
  234.                    (cdr l)))))))
  235.  
  236.  
  237.