prg.lisp

   1 ;;; Code to support (simple) linking of object files into GEMDOS PRG
   2 ;;; files.  These are basically A.OUT format.
   3
   4 (in-package :st-linker)
   5
   6 (defparameter *aout-obj-header-length* 32) ; bytes
   7
   8 ;; Object magic is STO^Z
   9 (defun check-magic (stream)
  10   (unless (= (read-big-endian-data stream 32) #x53544F26)
  11     (error "Bad magic.")))
  12
  13
  14 (defstruct module
  15   (name)
  16   (text-base 0)
  17   (text-size)
  18   (data-base 0)
  19   (data-size)
  20   (bss-base 0)
  21   (bss-size)
  22   (symbol-table-size)
  23   (entry-point)
  24   (text-relocations-size)
  25   (data-relocations-size)
  26   (symbols)
  27   (relocs))
  28
  29
  30 (defstruct relocation
  31   (address)
  32   (symbol)
  33   (pc-relative-p)
  34   (length)
  35   (extern-p))
  36
  37 (defstruct linker-symbol
  38   (name)
  39   (value)
  40   (type)
  41   ;; global-p, debug-info
  42   (module))
  43
  44
  45 (defun read-relocations (n-relocations stream)
  46   (let ((table (make-array (list n-relocations)
  47                            :element-type 'linker-symbol)))
  48     (dotimes (i n-relocations)
  49       (let ((address (read-big-endian-data stream 32))
  50             (rest (read-big-endian-data stream 32)))
  51         (setf (aref table i)
  52               (make-relocation :address address
  53                                :symbol (ldb (byte 24 8) rest)
  54                                :pc-relative-p (= 1 (ldb (byte 1 7) rest))
  55                                :length (ldb (byte 2 5) rest)
  56                                :extern-p (= 1 (ldb (byte 1 4) rest))))))
  57     table))
  58
  59 (defun read-symbol-table (n-symbols stream module)
  60   (let ((table (make-array (list n-symbols) :element-type 'relocation)))
  61     (dotimes (i n-symbols)
  62       (let ((name-idx (read-big-endian-data stream 32))
  63             (type (read-big-endian-data stream 32))
  64             (value (read-big-endian-data stream 32)))
  65         (setf (aref table i)
  66               (make-linker-symbol :name name-idx
  67                                   :type (ldb (byte 7 25) type)
  68                                   :value value
  69                                   :module module))))
  70     table))
  71
  72 (defun read-string-table (stream symbols)
  73   (dotimes (i (length symbols))
  74     (setf (linker-symbol-name (aref symbols i))
  75           (read-nul-terminated-string stream))))
  76
  77
  78 (defun link-prg (objects &key (out-name "aout.prg"))
  79   (let ((text-segment-size 0)
  80         (data-segment-size 0)
  81         (bss-size 0)
  82         (modules nil))
  83     (dolist (object objects)
  84       ;; load each object file, figure out sizes of segments
  85       (with-open-file (stream object :element-type 'unsigned-byte)
  86         (check-magic stream)
  87         (let ((text (read-big-endian-data stream 32))
  88               (data (read-big-endian-data stream 32))
  89               (bss (read-big-endian-data stream 32))
  90               (symbol-count (read-big-endian-data stream 32))
  91               (entry (read-big-endian-data stream 32))
  92               (text-reloc (read-big-endian-data stream 32))
  93               (data-reloc (read-big-endian-data stream 32)))
  94           (file-position stream (+ *aout-obj-header-length*
  95                                    text data))
  96           (let ((relocs (read-relocations text-reloc stream))
  97                 (symbols (read-symbol-table symbol-count stream object)))
  98             (read-string-table stream symbols)
  99             (push (make-module :name object :text-size text :data-size data
 100                                :bss-size bss :symbol-table-size symbol-count
 101                                :entry-point entry
 102                                :text-relocations-size text-reloc
 103                                :data-relocations-size data-reloc
 104                                :relocs relocs :symbols symbols)
 105                   modules))
 106           (incf text-segment-size text)
 107           (incf data-segment-size data)
 108           (incf bss-size bss))))
 109
 110     (allocate-module-bases modules text-segment-size data-segment-size)
 111
 112     (with-open-file (prg-stream out-name :direction :output
 113                                 :element-type 'unsigned-byte
 114                                 :if-exists :new-version
 115                                 :if-does-not-exist :create)
 116       ;; start writing header
 117       (write-big-endian-data prg-stream #x601a 16)
 118       (write-big-endian-data prg-stream text-segment-size 32)
 119       (write-big-endian-data prg-stream data-segment-size 32)
 120       (write-big-endian-data prg-stream bss-size 32)
 121       (write-big-endian-data prg-stream 0 32) ; no symbol table
 122       (write-big-endian-data prg-stream 0 (* 2 32)) ; reserved, flags
 123       (write-big-endian-data prg-stream 0 16) ; absflag
 124
 125       (dolist (module modules)
 126         ;; over each object, read text segments
 127         (with-open-file (obj-stream (module-name module)
 128                                     :element-type 'unsigned-byte)
 129           (file-position obj-stream *aout-obj-header-length*) ;start of text segment
 130           (copy-from-stream obj-stream prg-stream
 131                             (module-text-size module))))
 132       (dolist (module modules)
 133         ;; over each object, read data segments
 134         (with-open-file (obj-stream (module-name module)
 135                                     :element-type 'unsigned-byte)
 136           (file-position obj-stream (+ *aout-obj-header-length*
 137                                        (module-text-size module)))
 138           (copy-from-stream obj-stream prg-stream
 139                             (module-data-size module))))
 140
 141       (let ((relocs (process-link-time-relocations prg-stream modules)))
 142         (output-load-time-relocations prg-stream relocs)))))
 143
 144
 145 (defun allocate-module-bases (modules text-segment-size data-segment-size)
 146   (let ((cur-text-base 0)
 147         (cur-data-base text-segment-size)
 148         (cur-bss-base (+ text-segment-size data-segment-size)))
 149     (dolist (module modules)
 150       (setf (module-text-base module) cur-text-base
 151             (module-data-base module) cur-data-base
 152             (module-bss-base module) cur-bss-base)
 153       (format t "~&relocating ~A at ~A, ~A, ~A" (module-name module)
 154               (module-text-base module) (module-data-base module)
 155               (module-bss-base module))
 156       (incf cur-text-base (module-text-size module))
 157       (incf cur-data-base (module-data-size module))
 158       (incf cur-bss-base (module-bss-size module)))))
 159
 160 (defun process-link-time-relocations (stream modules)
 161   (let ((relocs nil))
 162     (dolist (module modules)
 163       ;; for each relocation, try and process.
 164       ;; if it needs to be relocated at load time, adjust for long
 165       ;; relocs, and push it onto the reloc stack.
 166       )))
 167
 168 (defun output-load-time-relocations (stream relocs)
 169   (write-big-endian-data stream 0 32)   ;fixup offset
 170   ;; output relocations in PC order... make sure relocation is on word
 171   ;; boundry, and fix smaller relocs so that they're long (eg, word
 172   ;; fixups need to start two bytes earlier).  if delta from current
 173   ;; position to next fixup > 254, output byte 1 until < 254.  then
 174   ;; output offset of fixup.
 175   (write-byte 0 stream))                ; no more relocs.
 176
 177
 178 ;;;; UTILITIES
 179
 180 (defun copy-from-stream (source destination length
 181                          &key (element-type 'unsigned-byte))
 182   "Copy LENGTH bytes of data from open stream SOURCE to open stream
 183 DESTINATION."
 184   (let ((buffer (make-array '(4096) :element-type element-type)))
 185     (do ((bytes #1=(read-sequence buffer source) #1#)
 186          (length length (- length bytes)))
 187         ((or (= bytes 0) (<= length 0)))
 188       (write-sequence buffer destination :end (if (> bytes length)
 189                                                   length
 190                                                   bytes)))))
 191
 192 (defun read-big-endian-data (stream length)
 193   "Read LENGTH bits of data encoded big-endian from STREAM, returning
 194 an integer.  LENGTH must be a multiple of 8."
 195   (assert (zerop (logand length 7)))
 196   (do ((pos (- length 8) (- pos 8))
 197        (value (read-byte stream) (logior (read-byte stream)
 198                                          (ash value 8))))
 199       ((<= pos 0) value)))
 200
 201 (defun write-big-endian-data (stream data length)
 202   "Write LENGTH bits of the integer DATA to STREAM, in big-endian
 203 order.  LENGTH must be a multiple of 8."
 204   (assert (zerop (logand length 7)))
 205   (do ((pos (- length 8) (- pos 8)))
 206       ((< pos 0))
 207     (write-byte (ldb (byte 8 pos) data) stream)))
 208
 209
 210 (defun read-nul-terminated-string (stream)
 211   (do ((char (read-byte stream) (read-byte stream))
 212        (string (make-array '(0) :element-type 'character :adjustable t
 213                            :fill-pointer 0)))
 214       ((eql char 0) string)
 215     (vector-push-extend (code-char char) string)))