Sorted out section classification.

[cl-elf.git] / elf-rw.lisp

;;;; Silly emacs, this is -*- Lisp -*-

(in-package :cl-elf)

(defmacro with-gensyms ((&rest names) &body body)
  `(let ,(loop for n in names collect `(,n (make-symbol ,(string n))))
     ,@body))

;; length of elf magic bytes
(defconstant +EI_NIDENT+ 16)

;; These constants are for the segment types stored in the image headers 
(defconstant +PT_NULL+    0)
(defconstant +PT_LOAD+    1)
(defconstant +PT_DYNAMIC+ 2)
(defconstant +PT_INTERP+  3)
(defconstant +PT_NOTE+    4)
(defconstant +PT_SHLIB+   5)
(defconstant +PT_PHDR+    6)
(defconstant +PT_TLS+     7)          ;; Thread local storage segment 
(defconstant +PT_LOOS+    #X60000000) ;; OS-specific 
(defconstant +PT_HIOS+    #X6fffffff) ;; OS-specific 
(defconstant +PT_LOPROC+  #X70000000)
(defconstant +PT_HIPROC+  #X7fffffff)
(defconstant +PT_GNU_EH_FRAME+  #X6474e550)

(defconstant +PT_GNU_STACK+ (+ +PT_LOOS+  #X474e551))

;; These constants define the different elf file types 
(defconstant +ET_NONE+   0)
(defconstant +ET_REL+    1)
(defconstant +ET_EXEC+   2)
(defconstant +ET_DYN+    3)
(defconstant +ET_CORE+   4)
(defconstant +ET_LOPROC+ #xff00)
(defconstant +ET_HIPROC+ #xffff)

;; These constants define the various ELF target machines 
(defconstant +EM_NONE+  0)
(defconstant +EM_M32+   1)
(defconstant +EM_SPARC+ 2)
(defconstant +EM_386+   3)
(defconstant +EM_68K+   4)
(defconstant +EM_88K+   5)
(defconstant +EM_486+   6) ;; Perhaps disused 
(defconstant +EM_860+   7)
(defconstant +EM_MIPS+          8) ;; MIPS R3000 (officially, big-endian only) 
(defconstant +EM_MIPS_RS4_BE+ 10)  ;; MIPS R4000 big-endian 
(defconstant +EM_PARISC+      15)  ;; HPPA 
(defconstant +EM_SPARC32PLUS+ 18)  ;; Sun's "v8plus" 
(defconstant +EM_PPC+          20) ;; PowerPC 
(defconstant +EM_PPC64+       21)  ;; PowerPC64 
(defconstant +EM_SH+           42) ;; SuperH 
(defconstant +EM_SPARCV9+     43)  ;; SPARC v9 64-bit 
(defconstant +EM_IA_64+ 50)        ;; HP/Intel IA-64 
(defconstant +EM_X86_64+        62)    ;; AMD x86-64 
(defconstant +EM_S390+          22)    ;; IBM S/390 
(defconstant +EM_CRIS+         76) ;; Axis Communications 32-bit embedded processor 
(defconstant +EM_V850+          87)    ;; NEC v850 

(defconstant +EM_M32R+          88)     ;; Renesas M32R 

(defconstant +EM_H8_300+       46) ;; Renesas H8/300,300H,H8S 

;;
;; This is an interim value that we will use until the committee comes
;; up with a final number.
 
(defconstant +EM_ALPHA+ #x9026)

;; Bogus old v850 magic number, used by old tools.  
(defconstant +EM_CYGNUS_V850+   #x9080)

;; Bogus old m32r magic number, used by old tools.  
(defconstant +EM_CYGNUS_M32R+   #x9041)

;;
;; This is the old interim value for S/390 architecture
 
(defconstant +EM_S390_OLD+     #xA390)

(defconstant +EM_FRV+           #x5441) ;; Fujitsu FR-V 

;; Legal values for sh_type (section type).  

(defconstant +SHT_NULL+       0) ;; Section header table entry unused 
(defconstant +SHT_PROGBITS+       1) ;; Program data 
(defconstant +SHT_SYMTAB+         2) ;; Symbol table 
(defconstant +SHT_STRTAB+         3) ;; String table 
(defconstant +SHT_RELA+       4) ;; Relocation entries with addends 
(defconstant +SHT_HASH+       5) ;; Symbol hash table 
(defconstant +SHT_DYNAMIC+        6) ;; Dynamic linking information 
(defconstant +SHT_NOTE+       7) ;; Notes 
(defconstant +SHT_NOBITS+         8) ;; Program space with no data (bss) 
(defconstant +SHT_REL+            9) ;; Relocation entries, no addends 
(defconstant +SHT_SHLIB+          10)     ;; Reserved 
(defconstant +SHT_DYNSYM+         11)     ;; Dynamic linker symbol table 
(defconstant +SHT_INIT_ARRAY+     14) ;; Array of constructors 
(defconstant +SHT_FINI_ARRAY+     15) ;; Array of destructors 
(defconstant +SHT_PREINIT_ARRAY+ 16)  ;; Array of pre-constructors 
(defconstant +SHT_GROUP+          17)     ;; Section group 
(defconstant +SHT_SYMTAB_SHNDX+  18)  ;; Extended section indeces 
(defconstant +SHT_NUM+            19)     ;; Number of defined types.  
(defconstant +SHT_LOOS+   #X60000000) ;; Start OS-specific 
(defconstant +SHT_GNU_LIBLIST+    #X6ffffff7) ;; Prelink library list 
(defconstant +SHT_CHECKSUM+       #X6ffffff8) ;; Checksum for DSO content.  
(defconstant +SHT_LOSUNW+         #X6ffffffa) ;; Sun-specific low bound.  
(defconstant +SHT_SUNW_MOVE+      #X6ffffffa)
(defconstant +SHT_SUNW_COMDAT+   #X6ffffffb)
(defconstant +SHT_SUNW_SYMINFO+  #X6ffffffc)
(defconstant +SHT_GNU_VERDEF+     #X6ffffffd) ;; Version definition section.  
(defconstant +SHT_GNU_VERNEED+    #X6ffffffe) ;; Version needs section.  
(defconstant +SHT_GNU_VERSYM+     #X6fffffff) ;; Version symbol table.  
(defconstant +SHT_HISUNW+         #X6fffffff) ;; Sun-specific high bound.  
(defconstant +SHT_HIOS+   #X6fffffff)     ;; End OS-specific type 
(defconstant +SHT_LOPROC+         #X70000000) ;; Start of processor-specific 
(defconstant +SHT_HIPROC+         #X7fffffff) ;; End of processor-specific 
(defconstant +SHT_LOUSER+         #X80000000) ;; Start of application-specific 
(defconstant +SHT_HIUSER+         #X8fffffff) ;; End of application-specific 

;; This is the info that is needed to parse the dynamic section of the file 
(defconstant +DT_NULL+          0)
(defconstant +DT_NEEDED+        1)
(defconstant +DT_PLTRELSZ+      2)
(defconstant +DT_PLTGOT+        3)
(defconstant +DT_HASH+          4)
(defconstant +DT_STRTAB+        5)
(defconstant +DT_SYMTAB+        6)
(defconstant +DT_RELA+          7)
(defconstant +DT_RELASZ+        8)
(defconstant +DT_RELAENT+       9)
(defconstant +DT_STRSZ+         10)
(defconstant +DT_SYMENT+        11)
(defconstant +DT_INIT+          12)
(defconstant +DT_FINI+          13)
(defconstant +DT_SONAME+        14)
(defconstant +DT_RPATH+         15)
(defconstant +DT_SYMBOLIC+      16)
(defconstant +DT_REL+           17)
(defconstant +DT_RELSZ+         18)
(defconstant +DT_RELENT+        19)
(defconstant +DT_PLTREL+        20)
(defconstant +DT_DEBUG+         21)
(defconstant +DT_TEXTREL+       22)
(defconstant +DT_JMPREL+        23)
(defconstant +DT_LOPROC+        #x70000000)
(defconstant +DT_HIPROC+        #x7fffffff)

;; This info is needed when parsing the symbol table 
(defconstant +STB_LOCAL+  0)
(defconstant +STB_GLOBAL+ 1)
(defconstant +STB_WEAK+   2)

(defconstant +STT_NOTYPE+  0)
(defconstant +STT_OBJECT+  1)
(defconstant +STT_FUNC+    2)
(defconstant +STT_SECTION+ 3)
(defconstant +STT_FILE+    4)
(defconstant +STT_COMMON+  5)
(defconstant +STT_TLS+     6)

;; Legal values for sh_flags (section flags).  

(defparameter +SHF_WRITE+            (ASH 1 0)) ;; Writable 
(defparameter +SHF_ALLOC+            (ASH 1 1)) ;; Occupies memory during execution 
(defparameter +SHF_EXECINSTR+        (ASH 1 2)) ;; Executable 
(defparameter +SHF_MERGE+            (ASH 1 4))     ;; Might be merged 
(defparameter +SHF_STRINGS+          (ASH 1 5)) ;; Contains nul-terminated strings 
(defparameter +SHF_INFO_LINK+        (ASH 1 6)) ;; `sh_info' contains SHT index 
(defparameter +SHF_LINK_ORDER+       (ASH 1 7)) ;; Preserve order after combining 
(defparameter +SHF_OS_NONCONFORMING+ (ASH 1 8)) ;; Non-standard OS specific handling  required 
(defparameter +SHF_GROUP+            (ASH 1 9)) ;; Section is member of a group.  
(defparameter +SHF_TLS+              (ASH 1 10)) ;; Section hold thread-local data.  
(defparameter +SHF_MASKOS+           #xff00000)  ;; OS-specific.  
(defparameter +SHF_MASKPROC+         #xf0000000) ;; Processor-specific 
(defparameter +SHF_ORDERED+          (ASH 1 30)) ;; Special ordering requirement   (Solaris).  
(defparameter +SHF_EXCLUDE+          (ASH 1 31)) ;; Section is excluded unless  referenced or allocated (Solaris).

;; Intel 80386 specific definitions.  

;; i386 relocs.  

(defconstant +R_386_NONE+           0)  ; No reloc 
(defconstant +R_386_32+         1)  ; Direct 32 bit  
(defconstant +R_386_PC32+           2)  ; PC relative 32 bit 
(defconstant +R_386_GOT32+          3)  ; 32 bit GOT entry 
(defconstant +R_386_PLT32+          4)  ; 32 bit PLT address 
(defconstant +R_386_COPY+           5)  ; Copy symbol at runtime 
(defconstant +R_386_GLOB_DAT+   6)  ; Create GOT entry 
(defconstant +R_386_JMP_SLOT+   7)  ; Create PLT entry 
(defconstant +R_386_RELATIVE+   8)  ; Adjust by program base 
(defconstant +R_386_GOTOFF+         9)  ; 32 bit offset to GOT 
(defconstant +R_386_GOTPC+          10) ; 32 bit PC relative offset to GOT 
(defconstant +R_386_32PLT+          11)
(defconstant +R_386_TLS_TPOFF+  14)             ; Offset in static TLS block 
(defconstant +R_386_TLS_IE+         15) ; Address of GOT entry for static TLS block offset 
(defconstant +R_386_TLS_GOTIE+  16) ; GOT entry for static TLS block  offset 
(defconstant +R_386_TLS_LE+         17) ; Offset relative to static TLS   block 
(defconstant +R_386_TLS_GD+         18) ; Direct 32 bit for GNU version of  general dynamic thread local data 
(defconstant +R_386_TLS_LDM+    19) ; Direct 32 bit for GNU version of  local dynamic thread local data in LE code 
(defconstant +R_386_16+         20)
(defconstant +R_386_PC16+           21)
(defconstant +R_386_8+              22)
(defconstant +R_386_PC8+            23)
(defconstant +R_386_TLS_GD_32+    24) ; Direct 32 bit for general dynamic  thread local data 
(defconstant +R_386_TLS_GD_PUSH+  25) ; Tag for pushl in GD TLS code 
(defconstant +R_386_TLS_GD_CALL+  26) ; Relocation for call to  __tls_get_addr() 
(defconstant +R_386_TLS_GD_POP+   27) ; Tag for popl in GD TLS code 
(defconstant +R_386_TLS_LDM_32+   28) ; Direct 32 bit for local dynamic  thread local data in LE code 
(defconstant +R_386_TLS_LDM_PUSH+ 29) ; Tag for pushl in LDM TLS code 
(defconstant +R_386_TLS_LDM_CALL+ 30) ; Relocation for call to  __tls_get_addr() in LDM code 
(defconstant +R_386_TLS_LDM_POP+  31) ; Tag for popl in LDM TLS code 
(defconstant +R_386_TLS_LDO_32+   32) ; Offset relative to TLS block 
(defconstant +R_386_TLS_IE_32+     33) ; GOT entry for negated static TLS block offset 
(defconstant +R_386_TLS_LE_32+     34) ; Negated offset relative to static  TLS block 
(defconstant +R_386_TLS_DTPMOD32+ 35) ; ID of module containing symbol 
(defconstant +R_386_TLS_DTPOFF32+ 36) ; Offset in TLS block 
(defconstant +R_386_TLS_TPOFF32+  37) ; Negated offset in static TLS block 
                                        ; Keep this the last entry.  
(defconstant +R_386_NUM+           38)

(defconstant +null+ (code-char 0))

(defun read-file-to-usb8-array (filepath)
  "Opens a reads a file. Returns the contents as single unsigned-byte array"
  (with-open-file (in filepath :direction :input :element-type '(unsigned-byte 8))
    (let* ((file-len (file-length in))
           (usb8 (make-array file-len :element-type '(unsigned-byte 8)))
           (pos (read-sequence usb8 in)))
      (unless (= file-len pos)
        (error "Length read (~D) doesn't match file length (~D)~%" pos file-len))
      usb8)))

(defun write-usb8-array-to-file (usb8 file)
  "Opens a reads a file. Returns the contents as single unsigned-byte array"
  (with-open-file (out file :direction :output 
                       :if-exists :supersede 
                       :if-does-not-exist :create 
                       :element-type '(unsigned-byte 8))
    (let* ((pos (length (write-sequence usb8 out)))
           (file-len (file-length out)))
      (unless (= file-len pos)
        (error "Length written (~D) doesn't match file length (~D)~%" pos file-len))
      usb8)))

(defclass buffered-data-mixin ()
  ((buffered-data :accessor buffered-data-of :initform nil)
   (buffer-pos :accessor buffer-pos-of :initform 0)))

(defgeneric advance-data-pointer (buffer advance))

(defmethod advance-data-pointer ((buffer buffered-data-mixin) advance)
  (let
      ((pos 
        (buffer-pos-of buffer)))
    (setf (buffer-pos-of buffer)
          (+ pos advance))))


(defmethod read-buffered-data ((self buffered-data-mixin) &key filepath)
  (format t "Reading buffered data from ~A ~%" filepath)
  (setf (buffered-data-of self)
        (read-file-to-usb8-array filepath)))

(defgeneric     write-buffered-data (data &key filepath)
  (:documentation "Write the buffered data to the elf file"))
                       
(defmethod  write-buffered-data ((self buffered-data-mixin) &key filepath)
  (write-usb8-array-to-file (buffered-data-of self)  filepath))

 
(defgeneric read-value (type buffered-data-mixin &key &allow-other-keys)
  (:documentation "Read a value of the given type from the file."))


(defmethod read-value ((type (eql 'u8)) (self buffered-data-mixin) &key)
  (let ((result (aref  (buffered-data-of self) (buffer-pos-of self)))) 
    (incf (buffer-pos-of self))
    result))

(defmethod read-value ((type (eql 's8)) (self buffered-data-mixin) &key)
  (let ((u8 (read-value 'u8 self)))
    (if (> u8 #X7F)
        (- u8 #X100)
        u8)))

(defmethod read-value ((type (eql 'u16)) (self buffered-data-mixin) &key)
  (let ((u16 0))
    (setf (ldb (byte 8 0) u16) (read-value 'u8 self))
    (setf (ldb (byte 8 8) u16) (read-value 'u8 self))
    u16))

(defmethod read-value ((type (eql 's16)) (self buffered-data-mixin) &key)
  (let ((u16 (read-value 'u16 self)))
    (if (> u16 #X7FFFF)
        (- u16 #X10000))))

(defmethod read-value ((type (eql 'u32)) (self buffered-data-mixin) &key)
  (let ((u32 0))
    (setf (ldb (byte 8 0) u32) (read-value 'u8 self))
    (setf (ldb (byte 8 8) u32) (read-value 'u8 self))
    (setf (ldb (byte 8 16) u32) (read-value 'u8 self))
    (setf (ldb (byte 8 24) u32) (read-value 'u8 self))
    u32))

(defmethod read-value ((type (eql 's32)) (self buffered-data-mixin) &key)
  (let ((u32 (read-value 'u32 self)))
    (if (> u32 #X7FFFF)
        (- u32 #X100000000)
        u32)))

(defgeneric align-for-read (buffered-data-mixin alignment))

(defmethod align-for-read ((self buffered-data-mixin) alignment)
  (loop
     until (zerop (logand (buffer-pos-of self) (1- alignment)))
     do
     (incf (buffer-pos-of self))))


(defmacro def-read-elf-value (type base-type alignment)
  `(defmethod read-value ((type (eql ',type)) (self buffered-data-mixin) &key)
     (progn 
       (align-for-read self ,alignment)
       (read-value ',base-type self))))

(def-read-elf-value elf32-addr  u32 4)
(def-read-elf-value elf32-half  u16 2)
(def-read-elf-value elf32-off   u32 4)
(def-read-elf-value elf32-sword s32 4)
(def-read-elf-value elf32-word  u32 4)

(defmethod read-value ((type (eql 'asciiz)) (self buffered-data-mixin) &key)
  (with-output-to-string (s)
    (loop for char = (code-char (read-value 'u8 self))
       until (char= char +null+) do (write-char char s))))  

(defmethod read-value ((type (eql 'usb8-array)) (self buffered-data-mixin) &key length)
  (let ((usb8-array (make-array (list length) :element-type '(unsigned-byte 8))))
    (loop
       for index from 0 below length
       do
       (setf (aref usb8-array index) (read-value 'u8 self)))
    usb8-array))
    
;; -- writing to elf files -----------------------------------------
  
(defgeneric write-value (type buffered-data-mixin value &key &allow-other-keys)
  (:documentation "Read a value of the given type from the file."))

(defmethod write-value ((type (eql 'u8)) (self buffered-data-mixin) value &key)
  (vector-push-extend value  (buffered-data-of self)))

(defmethod write-value ((type (eql 's8)) (self buffered-data-mixin) value &key)
  (vector-push-extend value (buffered-data-of self)))

(defmethod write-value ((type (eql 'u16)) (self buffered-data-mixin) value &key)
  (vector-push-extend (ldb (byte 8 0) value) 
                      (buffered-data-of self))
  (vector-push-extend (ldb (byte 8 8) value) 
                      (buffered-data-of self)))

(defmethod write-value ((type (eql 's16)) (self buffered-data-mixin) value &key)
  (vector-push-extend (ldb (byte 8 0) value) 
                      (buffered-data-of self))
  (vector-push-extend (ldb (byte 8 8) value) 
                      (buffered-data-of self)))

(defmethod write-value ((type (eql 'u32)) (self buffered-data-mixin) value &key)
  (vector-push-extend (ldb (byte 8 0) value) (buffered-data-of self))
  (vector-push-extend (ldb (byte 8 8) value) (buffered-data-of self))
  (vector-push-extend (ldb (byte 8 16) value) (buffered-data-of self))
  (vector-push-extend (ldb (byte 8 24) value) (buffered-data-of self)))

(defmethod write-value ((type (eql 's32)) (self buffered-data-mixin) value &key)
  (vector-push-extend (ldb (byte 8 0) value) (buffered-data-of self))
  (vector-push-extend (ldb (byte 8 8) value) (buffered-data-of self))
  (vector-push-extend (ldb (byte 8 16) value) (buffered-data-of self))
  (vector-push-extend (ldb (byte 8 24) value) (buffered-data-of self)))

(defmethod write-value ((type (eql 'asciiz)) (self buffered-data-mixin) string &key)
  (loop 
     for char across string
     do (vector-push-extend
         (char-code char) 
         (buffered-data-of self))
     (vector-push-extend (char-code +null+) (buffered-data-of self))))

(defgeneric align-for-write (buffered-data-mixin alignment))

(defmethod align-for-write ((self buffered-data-mixin) alignment)
  (loop
     until (zerop (logand (length (buffered-data-of self)) (1- alignment)))
     do
     (vector-push-extend 0 (buffered-data-of self))))

(defmacro def-write-elf-value (type base-type alignment)
  `(defmethod write-value ((type (eql ',type)) (self buffered-data-mixin) value &key)
     (progn 
       (align-for-read self ,alignment)
       (write-value ',base-type self value))))

(def-write-elf-value elf32-addr  u32 4)
(def-write-elf-value elf32-half  u16 2)
(def-write-elf-value elf32-off   u32 4)
(def-write-elf-value elf32-sword s32 4)
(def-write-elf-value elf32-word  u32 4)

(defmethod write-value ((type (eql 'usb8-array)) 
                        (self buffered-data-mixin) usb8-array &key length)
  (loop
     for index from 0 below length 
     do
     (vector-push-extend (aref usb8-array index) (buffered-data-of self))))


;; define-elf-class ------------------------------------------------------
;; Heavily influenced by (stolen, really) from Practical Common Lisp

(defun as-keyword (sym) 
  (intern (string sym) :keyword))

(defun as-accessor (sym) 
  (intern (concatenate 'string (string sym) "-OF")))


(defun slot->defclass-slot (spec)
  "Map a define-elf-class slot spec to a clos slot spec"
  (let ((name (first spec)))
    `(,name :initarg ,(as-keyword name) :accessor ,(as-accessor name))))

(defun mklist (x) 
  "Return the argument as a list if it isn't already"
  (if (listp x) x (list x)))

(defun normalize-slot-spec (spec)
  (list (first spec) (mklist (second spec))))

(defun slot->read-value (spec elf-data)
  (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec)
    `(setf ,name (read-value ',type ,elf-data ,@args))))

(defun slot->write-value (spec elf-data)
  (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec)
    `(write-value ',type ,elf-data ,name ,@args)))

(defun normalize-slot-description (spec)
  (list (first spec)
        (mklist (second spec))))

(defmacro define-elf-class (name slots)
  (with-gensyms (typevar objectvar elf-data-var) 
    `(progn
       ;; generate a defclass form
       (defclass ,name ()
         ,(mapcar #'slot->defclass-slot slots))
       ;; generate a method to read all slots
       (defmethod read-value ((,typevar (eql ',name)) ,elf-data-var &key)
         (let ((,objectvar (make-instance ',name)))
           (with-slots ,(mapcar #'first slots) ,objectvar
             ,@(mapcar #'(lambda (x) (slot->read-value x elf-data-var)) slots))
           ,objectvar))
       ;; generate a method to write all slots
       (defmethod write-value ((,typevar (eql ',name)) ,elf-data-var ,objectvar &key)
         (with-slots ,(mapcar #'first slots) ,objectvar
           ,@(mapcar #'(lambda (x) (slot->write-value x elf-data-var)) slots))))))