;; Utility to "compile" a list of lsp files into a self-contained
;; binary, which is an embedded newlisp binary with the same embedding
;; script as binnl itself.
;;
;; Usage: [ -r ] binary ( -a archive | member )*
;;
;; The script processes the arguments from left to right to form then
;; named binary with the named members appended.
;;
;; Use '-a archive' to make the nominated ar style archive members
;; available subsequently for embedding.
;;
;; Use '-A archive' to embed all members of the nominated ar style
;; archive.
;;
;; Use '-r' to overwrite an existing binary

;; The first embedded member will be the "main script".
;;

(constant
 'OPTIONS
 '(("-w" ?) ; write new file
   ("-u" ? ?) ; unpack members to given directory
   ("-t" ?) ; merely list packed members of
   ))

(load "main-args.lsp")

(define (compile-file M (D (read-file M)))
  (unless D
    (write-line 2 (format "*** Mising %s .. aborting" M))
    (exit 1))
  (append-file BINARY (format "%s\n%d\n" M (length D)))
  (append-file BINARY D))

(define (compile-ar A M)
  (let ((MEMBERS (archive M)))
    (if (= A "-A") (dolist (M MEMBERS) (compile-file M)))))

(define (compile BINARY MEMBERS)
  (write-file BINARY (0 archive:incore core)) ; includes the marker
  (exec (format "chmod a+x %s" BINARY))
  (let ((A nil))
    (dolist (M MEMBERS)
      ;;(write-line 1 (string "[" M "]" (archives)))
      (case M
        ("-a" (setf A "-a"))
        ("-A" (setf A "-A"))
        (true (if A (compile-ar A M) (compile-file M))
              (setf A nil))))
    ))

(define (decompile BINARY DIR)
  (let ((D (read-file BINARY)))
    (when D
      (let ((P (find (dup "x" 40) D)))
        (when P
          (inc P 41)
          (while (regex "([^\n]+)\n([^\n]+)\n" D 0 P)
            (let ((N $1) (S (int $2)) (L (length $0)))
              (inc P L)
              (if DIR (write-file (string DIR "/" N) (P S D)) (println N))
              (inc P S))))))))

;; clear the compiler index
;; Drop the compile members from the index
(dolist (M (map first (archives))) (archives M nil))

(when (or (!= 1 (length (clean null? OPTIONS)))
          (!= 2 (length ((clean null? OPTIONS) 0))))
  (write-line 2 "Please use one of -w -u or -t")
  (exit 1))

(cond
 ((OPTIONS 0) (compile (OPTIONS 0 1 0) ARGS))
 ((OPTIONS 1) (decompile (OPTIONS 1 1 0) (OPTIONS 1 1 1)))
 ((OPTIONS 2) (decompile (OPTIONS 2 1 0) nil)))

(exit 0)