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 (eval-when (:compile-toplevel :load-toplevel :execute)
   7   (defparameter *aout-prg-header-length* 28)) ; bytes
   8
   9 (defun link-prg (modules segment-sizes out-name)
  10   (with-open-file (prg-stream out-name :direction :io
  11                               :element-type 'unsigned-byte
  12                               :if-exists :supersede
  13                               :if-does-not-exist :create)
  14     ;; start writing header
  15     (write-big-endian-data prg-stream #x601a 16)
  16     (mapcar (lambda (x)
  17               (write-big-endian-data prg-stream
  18                                      (cdr (assoc x segment-sizes))
  19                                      32))
  20             '(text data bss))
  21     (write-big-endian-data prg-stream 0 32) ; no symbol table
  22     (write-big-endian-data prg-stream 0 (* 2 32)) ; reserved, flags
  23     (write-big-endian-data prg-stream 0 16) ; absflag
  24
  25     (dolist (module modules)
  26       ;; over each object, read text segments
  27       (with-open-file (obj-stream (module-name module)
  28                                   :direction :input
  29                                   :element-type 'unsigned-byte)
  30         (file-position obj-stream *aout-obj-header-length*) ;start of text segment
  31         (copy-from-stream obj-stream prg-stream
  32                           (module-segment-size module 'text))))
  33     (dolist (module modules)
  34       ;; over each object, read data segments
  35       (with-open-file (obj-stream (module-name module)
  36                                   :direction :input
  37                                   :element-type 'unsigned-byte)
  38         (file-position obj-stream (+ *aout-obj-header-length*
  39                                      (module-segment-size module 'text)))
  40         (copy-from-stream obj-stream prg-stream
  41                           (module-segment-size module 'data))))
  42
  43     (let* ((*current-header-length* *aout-prg-header-length*)
  44            (fixups (process-link-time-relocations prg-stream modules)))
  45       (output-load-time-relocations prg-stream fixups))))
  46
  47
  48 (defun output-load-time-relocations (stream fixups)
  49   (let ((delta (or (and fixups (first fixups)) 0)))
  50     (write-big-endian-data stream delta 32) ;fixup offset
  51     (format t "~&outputting delta of ~A" delta)
  52     ;; output relocations in PC order... make sure relocation is on word
  53     ;; boundry, and fix smaller relocs so that they're long (eg, word
  54     ;; fixups need to start two bytes earlier).  if delta from current
  55     ;; position to next fixup > 254, output byte 1 until < 254.  then
  56     ;; output offset of fixup.
  57     (dolist (addr (cdr fixups))
  58       (assert (= 0 (mod addr 2)))
  59       (do () ((< (- addr delta) 254))
  60         (write-byte 1 stream)
  61         (incf delta 254))
  62       (write-byte (- addr delta) stream)
  63       (setf delta addr))
  64     (write-byte 0 stream)))             ; no more relocs.