aout.lisp

   1 ;;;
   2 ;;; 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 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 :new-version
  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       ;; Text, Data, BSS
  20       (mapcar (lambda (x)
  21                 (write-big-endian-data output-stream
  22                                        (cdr (assoc x section-lengths))
  23                                        32))
  24               '(text data bss))
  25       ;; symbol table
  26       (write-big-endian-data output-stream (length symbols) 32)
  27       ;; entry point
  28       (write-big-endian-data output-stream 0 32)
  29       ;; text reloc size
  30       (write-big-endian-data output-stream
  31                              (hash-table-count *relocation-table*)
  32                              32)
  33       ;; data reloc size
  34       (write-big-endian-data output-stream
  35                              0
  36                              32)
  37
  38       (copy-stream-contents (cdr (assoc 'text *object-streams*))
  39                             output-stream)
  40       (copy-stream-contents (cdr (assoc 'data *object-streams*))
  41                             output-stream)
  42       ;; output relocations
  43       (maphash (lambda (k v)
  44                  (declare (ignore k))
  45                  ;; address
  46                  (write-big-endian-data output-stream
  47                                         (relocation-address v)
  48                                         32)
  49                  ;; index|24 pc-rel-p length|2 extern-p spare|4
  50                  (write-big-endian-data
  51                   output-stream
  52                   (logior (ash (relocation-index-bits v symbols) 8)
  53                           (ash (if (relocation-pc-relative-p v) 1 0) 7)
  54                           (ash (ceiling (log (relocation-size v) 2)) 5)
  55                           (ash (if (relocation-extern-p v) 1 0) 4))
  56                   32))
  57                *relocation-table*)
  58       ;; output symbol table
  59       (do ((i 0 (1+ i))
  60            (sym))
  61           ((>= i (length symbols)))
  62         (setf sym (aref symbols i))
  63         (write-big-endian-data output-stream i 32)
  64         (write-big-endian-data
  65          output-stream
  66          (logior (ash (position (asm-symbol-type sym)
  67                                 '(text data bss absolute extern))
  68                       25)
  69                  (ash (if (asm-symbol-global-p sym) 1 0) 24)
  70                  (aout-munge-debug-info (asm-symbol-debug-info sym)))
  71          32)
  72         (write-big-endian-data output-stream (asm-symbol-value sym) 32))
  73       ;; output string table
  74       (dotimes (i (length symbols))
  75         (write-string (asm-symbol-name (aref symbols i)) output-stream)
  76         (write-byte 0 output-stream)))))
  77
  78 ;;; XXX we could do something much more sophisticated, such as having
  79 ;;; debug info serve as an index into a debugging info table later in
  80 ;;; the file, but who cares for now?
  81 (defun aout-munge-debug-info (debug-info)
  82   (lexer-state-line debug-info))
  83
  84 (defun relocation-index-bits (v symbols)
  85   (if (relocation-extern-p v)
  86       (position (relocation-symbol v) symbols :test #'string-equal)
  87       (position (relocation-segment v) '(text data bss))))
  88
  89 (defun serialize-symbol-table ()
  90   (let ((table (make-array (list 0))))
  91     (maphash (lambda (k v)
  92                (declare (ignore k))
  93                (when (asm-symbol-global-p v)
  94                  (vector-push-extend v table)))
  95              *symbol-table*)
  96     table))
  97
  98 (defun serialize-reloc-table ()
  99   (let ((table (make-array (list (hash-table-count *relocation-table*)))))
 100     (with-hash-table-iterator (next *relocation-table*)
 101       (dotimes (i (length table))
 102         (multiple-value-bind (more-p k v) (next)
 103           (declare (ignore k))
 104           (assert more-p)
 105           (setf (aref table i) v))))
 106     table))