scheme shell

Build Script Deluxe

Here's a convenient program that creates almost standalone scsh program from an heap image:


  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:

BuildScriptDeluxe - raw wiki source | code snippets archive