incore.lsp

   1 ;; This code is intended for an embedded binary with an "archive" of
   2 ;; files appended to it. The appended archive is marked by a array of
   3 ;; 40 "x", and consists by archive elements the format of
   4 ;; "pathname\nsize\nbytes[size]".
   5 ;;
   6 ;; When there is an in-core archive, then the first member will be
   7 ;; invoked as "main script".
   8 ;;
   9 ;; archives:archives is a hashmap for loadable files
  10 ;; core:core is the running binary file
  11 ;; archive:main is the name of the first on-core member
  12 ;; archive:incore is the byte position into core for the archive
  13
  14 (new Tree 'archives)
  15
  16 (define core:core (read-file (main-args 0)))
  17
  18 (context 'archive)
  19
  20 (setf main nil)
  21
  22 (constant 'AR "/usr/bin/ar")
  23
  24 (define (archive:archive PATH)
  25   ;;(write-line 2 (string (list 'archive PATH)))
  26   (map (fn (F) (archives F PATH) F)
  27        (exec (format "%s t %s" AR PATH))))
  28
  29 (define (get-ar PATH MEMBER)
  30   ;;(write-line 2 (string (list 'get-ar PATH MEMBER)))
  31   (let ((I (pipe)) (O (pipe)) (DATA "") (ALL "")
  32         (SUB (fn (I O)
  33                (close (I 1)) (close (O 0)) (close 0)
  34                (process (format "%s p %s %s" AR PATH MEMBER) (I 0) (O 1)))))
  35     (fork (SUB I O))
  36     (close (O 1)) (close (I 0)) (close (I 1))
  37     (while (> (or (read (O 0) DATA 1000000) 0)) (extend ALL DATA))
  38     (close (I 0))
  39     ALL))
  40
  41 (define (get PATH MEMBER)
  42   (if (list? PATH) ((PATH 0) (PATH 1) core)
  43     (ends-with PATH ".a") (get-ar PATH MEMBER)))
  44
  45 ;; Discover and load an in-core archive by means of a marker row of 40
  46 ;; "x", and then a series of pathname\nsize\nbytes[size] members.
  47 (if (find (dup "x" 40) core nil 391704)
  48     (let ((P (+ $it 41))) ; skip marker and newline
  49       (constant 'incore P)
  50       (while (regex "([^\n]+)\n([^\n]+)\n" core 0 P)
  51         (let ((N $1) (S (int $2)) (L (length $0)))
  52           (inc P L)
  53           (unless main (setf main N))
  54           (archives N (list P S))
  55           (inc P S))))
  56   (write-line 2 (string "not packed")))
  57
  58 (context MAIN)
  59
  60 (constant
  61    'load
  62    (letex (LOAD load)
  63      (fn () (if (archives (args 0))
  64                 (eval-string (archive:get $it (args 0)) MAIN)
  65               (LOAD (args 0)))))
  66    'read-file
  67    (letex (READ-FILE read-file)
  68      (fn ()
  69        (if (archives (args 0)) (archive:get $it (args 0))
  70               (READ-FILE (args 0)))))
  71    'file?
  72    (letex (FILE? file?)
  73      (fn () (if (archives (args 0)) true (FILE? (args 0)))))
  74    )
  75
  76 (when archive:main (load archive:main) (exit 0))