#!/bin/sh
exec scsh -o srfi-37 -e main -s "$0" "$@"
!#
(define (mb->heap-words m)
(let ((mb (/ (* 1024 1024) 4)))
(* m mb)))
(define (raise-error msg info)
(for-each
(lambda (t) (display t (error-output-port)))
(list "ERROR: " msg " (" info ")\n"))
(exit 1))
(define (required-args-given? args-alist)
(fold-right
(lambda (arg r) (and r (assoc arg args-alist)))
#t
'(image bin scshvm)))
(define usage-message
(let ((begin-bold "\033[1m")
(end-bold "\033[m")
(begin-underline "\033[4m")
(end-underline "\033[m"))
(format #f
"~AUsage:~A
~Abuild-scsh-script~A ~Arequired-arguments~A [~Aheap-size-option~A]
~Arequired-arguments:~A
--image=FILE Image file to use
--bin=FILE Name of the binary to create
--scshvm=FILE Location of scshvm
~Aheap-size-option:~A
--heap-mb=SIZE Heap size in Megabytes
--heap-words=WORDS Heap size in Words
~AExample:~A
build-scsh-script --image=foo.image --bin=foo --scshvm=/usr/local/scsh/lib/scshvm --heap-mb=64~%"
begin-bold end-bold
begin-underline end-underline
begin-underline end-underline
begin-underline end-underline
begin-bold end-bold
begin-bold end-bold
begin-bold end-bold)))
(define (raise-usage-error msg info)
(for-each
(lambda (t) (display t (error-output-port)))
(list "USAGE ERROR: " msg " (" info ")\n"))
(display usage-message)
(exit 2))
(define (parse-arguments args)
(let ((help-option
(option '(#\h "help") #f #f
(lambda (option name arg ops)
(display usage-message)
(newline)
(exit 3))))
(image-option
(option '(#\i "image") #t #f
(lambda (option name arg ops)
(cons (cons 'image arg) ops))))
(bin-option
(option '(#\b "bin") #t #f
(lambda (option name arg ops)
(cons (cons 'bin arg) ops))))
(scshvm-option
(option '(#\s "scshvm") #t #f
(lambda (option name arg ops)
(cons (cons 'scshvm arg) ops))))
(heap-mb-option
(option '(#\m "heap-mb") #t #f
(lambda (option name arg ops)
(cond
((string->number arg)
=> (lambda (num)
(cons (cons 'heap (mb->heap-words num)) ops)))
(else
(raise-usage-error "Wrong number syntax" arg))))))
(heap-words-option
(option '(#\w "heap-words") #t #f
(lambda (option name arg ops)
(cond
((string->number arg)
=> (lambda (num) (cons (cons 'heap num) ops)))
(else
(raise-usage-error "Wrong number syntax" arg)))))))
(let ((args-alist (args-fold
args
(list help-option
image-option bin-option scshvm-option
heap-mb-option heap-words-option)
(lambda (option name arg operands)
(raise-usage-error "Unrecognized argument" name))
(lambda (op ops)
(cons op ops))
'())))
(if (required-args-given? args-alist)
args-alist
(raise-usage-error
"Some required argument are missing." "")))))
(define (make-scsh-image-header scshvm heap)
(let ((pre (string-append "#!" scshvm " \\\n"))
(post (string-append "-i\n")))
(if heap
(string-append pre "-h " (number->string heap) " " post)
(string-append pre post))))
(define (write-temp-header-file args-alist)
(let ((temp-file-name (create-temp-file)))
(call-with-output-file temp-file-name
(lambda (port)
(let* ((scshvm (cdr (assoc 'scshvm args-alist)))
(write-header (lambda (header) (display header port))))
(write-header
(cond
((assoc 'heap args-alist)
=> (lambda (p) (make-scsh-image-header scshvm (cdr p))))
(else (make-scsh-image-header scshvm #f)))))))
temp-file-name))
(define (main args)
(let ((args-alist (parse-arguments (cdr args))))
(let ((header-file (write-temp-header-file args-alist))
(image-file (cdr (assoc 'image args-alist)))
(bin-file (cdr (assoc 'bin args-alist))))
(if (zero? (run (cat ,header-file ,image-file) (> ,bin-file)))
(begin
(set-file-mode bin-file #o755)
(delete-file header-file))
(raise-error "Error running cat")))))
;;; Local Variables:
;;; mode:scheme
;;; End:
