;; 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: -w binary ( member | -a archive | -A archive | -C dir )*
;;        -t binary
;;        -u binary directory
;;
;; 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 '-C dir' to change source directory
;;
;; Use '-w' 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 "*** Cannot read %s .. aborting" M))
    (when (and (archives M) (not (ends-with (archives M) ".a")))
      (write-line 2 (format "*** (Archive filename %s must end with \".a\")"
                            (archives 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)))
    (dolist (X MEMBERS)
      ;;(write-line 2 (format "including %s from %s" X M))
      (when (= A "-A") (compile-file X))
      )))

(define (compile BINARY MEMBERS)
  (unless (starts-with BINARY "/")
    (setf BINARY (format "%s/%s" (real-path) BINARY)))
  (write-file BINARY (0 archive:incore core)) ; includes the marker
  (exec (format "chmod a+x %s" BINARY))
  (let ((A nil) (C nil))
    (dolist (M MEMBERS)
      (case M
        ("-a" (setf A "-a"))
        ("-A" (setf A "-A"))
        ("-C" (setf C "-C"))
        (true (if A (compile-ar A M)
                C (unless (change-dir M)
                    (write-line 2 (string "** directory is " (real-path)))
                    (write-line 2 (string "Cannot change to " M))
                    (exit 1))
                (compile-file M))
              (setf A nil)
              (setf C 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 archive index, to be used for source archives
(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)