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