1 ;;; Code to support (simple) linking of object files into GEMDOS PRG
2 ;;; files. These are basically A.OUT format.
4 (in-package :st-linker
)
6 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
7 (defparameter *aout-prg-header-length
* 28)) ; bytes
9 (defun link-prg (modules segment-sizes out-name
)
10 (with-open-file (prg-stream out-name
:direction
:io
11 :element-type
'unsigned-byte
13 :if-does-not-exist
:create
)
14 ;; start writing header
15 (write-big-endian-data prg-stream
#x601a
16)
17 (write-big-endian-data prg-stream
18 (cdr (assoc x segment-sizes
))
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
25 (dolist (module modules
)
26 ;; over each object, read text segments
27 (with-open-file (obj-stream (module-name module
)
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
)
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
))))
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
))))
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))
62 (write-byte (- addr delta
) stream
)
64 (write-byte 0 stream
))) ; no more relocs.