aout.lisp

   1 ;;;
   2 ;;; Mostly-a.out object file support for m68k-assembler.
   3 ;;;
   4 ;;; Julian Squires / 2005
   5
   6 (in-package :m68k-assembler)
   7
   8
   9 (defun finalize-object-file (name section-lengths)
  10   "Finalize a.out object file (collect sections, write symbol table,
  11 patch header)."
  12   (with-open-file (output-stream name :direction :output
  13                                  :element-type 'unsigned-byte
  14                                  :if-exists :supersede
  15                                  :if-does-not-exist :create)
  16     ;; revise symbol table/relocs to use numeric indices
  17     (let* ((symbols (serialize-symbol-table)))
  18       (write-big-endian-data output-stream #x53544F26 32) ; Magic
  19       ;; section lengths.
  20       (dolist (x '(text data bss))
  21         (write-big-endian-data output-stream
  22                                (cdr (assoc x section-lengths))
  23                                32))
  24       ;; symbol table
  25       (write-big-endian-data output-stream (length symbols) 32)
  26       ;; entry point
  27       (write-big-endian-data output-stream 0 32)
  28       ;; reloc sizes
  29       (dolist (x '(text data))
  30         (write-big-endian-data output-stream
  31                                (hash-table-count
  32                                 (section-relocations
  33                                  (cdr (assoc x *sections*))))
  34                                32))
  35
  36       ;; actual contents of sections.
  37       (dolist (x '(text data))
  38         (copy-stream-contents (section-object-stream (cdr (assoc x *sections*)))
  39                               output-stream))
  40
  41       ;; output relocations
  42       (dolist (x '(text data))
  43         (output-reloc-table output-stream
  44                             (section-relocations (cdr (assoc x *sections*)))
  45                             symbols))
  46
  47       (output-symbol-table output-stream symbols)
  48       (output-string-table output-stream symbols))))
  49
  50 (defun output-reloc-table (output-stream relocs symbols)
  51   (maphash (lambda (k v)
  52              (declare (ignore k))
  53              ;; address
  54              (write-big-endian-data output-stream
  55                                     (relocation-address v)
  56                                     32)
  57              ;; index|24 pc-rel-p length|2 extern-p spare|4
  58              ;; XXX should use dpb to avoid overflows
  59              (write-big-endian-data
  60               output-stream
  61               (logior (ash (relocation-index-bits v symbols) 8)
  62                       (ash (if (relocation-pc-relative-p v) 1 0) 7)
  63                       (ash (if (relocation-extern-p v) 1 0) 6)
  64                       (ldb (byte 6 0) (relocation-size v)))
  65               32))
  66            relocs))
  67
  68 (defun output-symbol-table (output-stream symbols)
  69   ;; output symbol table
  70   (do ((i 0 (1+ i))
  71        (sym))
  72       ((>= i (length symbols)))
  73     (setf sym (aref symbols i))
  74     (assert (and (asm-symbol-value sym)
  75                  (asm-symbol-type sym)))
  76     (write-big-endian-data output-stream i 32)
  77     (write-big-endian-data
  78      output-stream
  79      (logior (ash (section->bits (asm-symbol-type sym))
  80                   25)
  81              (ash (if (asm-symbol-global-p sym) 1 0) 24)
  82              (aout-munge-debug-info (asm-symbol-debug-info sym)))
  83      32)
  84     (write-big-endian-data output-stream (asm-symbol-value sym) 32)))
  85
  86 (defun section->bits (section)
  87   (position section '(text data bss absolute extern)))
  88
  89 ;;; XXX needs to be fixed.
  90 (defun output-string-table (output-stream symbols)
  91   (dotimes (i (length symbols))
  92     (let ((sym (asm-symbol-name (aref symbols i))))
  93       (write-sequence #+sb-unicode (sb-ext:string-to-octets sym)
  94                       #-sb-unicode (coerce (map 'list #'char-code sym)
  95                                            '(vector unsigned-byte))
  96                       output-stream))
  97     (write-byte 0 output-stream)))
  98
  99 ;;; XXX we could do something much more sophisticated, such as having
 100 ;;; debug info serve as an index into a debugging info table later in
 101 ;;; the file, but who cares for now?
 102 (defun aout-munge-debug-info (debug-info)
 103   (lexer-state-line debug-info))
 104
 105 (defun relocation-index-bits (v symbols)
 106   (if (relocation-extern-p v)
 107       (position (relocation-symbol v) symbols
 108                 :test #'string-equal
 109                 :key #'asm-symbol-name)
 110       (position (relocation-segment v) '(text data bss))))
 111
 112