;; This code is intended for an embedded binary with an "archive" of
;; files appended to it. The appended archive is marked by a array of
;; 40 "x", and consists by archive elements the format of
;; "pathname\nsize\nbytes[size]".
;;
;; When there is an in-core archive, then the first member will be
;; invoked as "main script".
;;
;; archives:archives is a hashmap for loadable files
;; core:core is the running binary file
;;
;; The "archive" context holds utility code.
;; archive:main is the name of the first in-core member.
;; archive:incore is the byte position into core for the archive.
;;
;; Use (archives member pathname) to register that the file "member"
;; should be looked up in the ar style archive of the given pathname.
;;
;; Use (archive pathname) to register all members of the nominated ar
;; style archive.

(new Tree 'archives)

(define core:core (read-file "/proc/self/exe"))

(context 'archive)

(setf main nil)

(constant 'AR "/usr/bin/ar")

(define (archive:archive PATH)
  ;;(write-line 2 (string (list 'archive PATH)))
  (map (fn (F) (archives F PATH) F)
       (exec (format "%s t %s" AR PATH))))

(define (get-ar PATH MEMBER)
  ;;(write-line 2 (string (list 'get-ar PATH MEMBER)))
  (let ((I (pipe)) (O (pipe)) (DATA "") (ALL "")
        (SUB (fn (I O)
               (close (I 1)) (close (O 0)) (close 0)
               (process (format "%s p %s %s" AR PATH MEMBER) (I 0) (O 1)))))
    (fork (SUB I O))
    (close (O 1)) (close (I 0)) (close (I 1))
    (while (> (or (read (O 0) DATA 1000000) 0)) (extend ALL DATA))
    (close (I 0))
    ALL))

(define (get PATH MEMBER)
  (if (list? PATH) ((PATH 0) (PATH 1) core)
    (ends-with PATH ".a") (get-ar PATH MEMBER)))

;; Discover and load an in-core archive by means of a marker row of 40
;; "x", and then a series of pathname\nsize\nbytes[size] members.
(if (find (dup "x" 40) core nil 391704)
    (let ((P (+ $it 41))) ; skip marker and newline
      (constant 'incore P)
      (while (regex "([^\n]+)\n([^\n]+)\n" core 0 P)
        (let ((N $1) (S (int $2)) (L (length $0)))
          (inc P L)
          (unless main (setf main N))
          (archives N (list P S))
          (inc P S))))
  (write-line 2 (string "not packed")))

(context MAIN)

(constant
   'load
   (letex ((LOAD load) (CTX '(or (and (1 (args)) (args 1)) MAIN)))
     (fn () (if (archives (args 0))
                (eval-string (archive:get $it (args 0)) CTX)
              (LOAD (args 0) CTX))))
   'read-file
   (letex (READ-FILE read-file)
     (fn ()
       (if (archives (args 0)) (archive:get $it (args 0))
         (READ-FILE (args 0)))))
   'file?
   (letex (FILE? file?)
     (fn () (if (archives (args 0)) true (FILE? (args 0)))))
   )

(when archive:main (load archive:main) (exit 0))