p

   1 #!/usr/bin/env gsi
   2 ;; -*- scheme -*-
   3
   4 ;; --- library stuff
   5
   6 (define (skip-head-match orig match)
   7   (let lp ((orig* orig)
   8            (match* match))
   9     (if (null? match*)
  10         orig*
  11         (if (null? orig*)
  12             orig
  13             (if (equal? (car orig*)
  14                         (car match*))
  15                 (lp (cdr orig*)
  16                     (cdr match*))
  17                 orig)))))
  18
  19 (define (basepath str)
  20   (list->string
  21    (reverse
  22     (skip-head-match
  23      (reverse (string->list str))
  24      (reverse (string->list ".scm"))))))
  25
  26 ;; quick solution just differentiating between signals and exits.
  27 ;; todo: is even this part portable? probably not.
  28 ;;  (and further explanations are missing anyway)
  29 (define (status->string s)
  30   (cond ((zero? s)
  31          "exited successfully")
  32         ((> s 255)
  33          (string-append "exited with exit code "
  34                         (number->string (arithmetic-shift s -8))))
  35         ((< s 0)
  36          (error "negative status" s))
  37         ((string-append "terminated by signal "
  38                         (number->string s)))))
  39 ;;^ doesn't check for the case where both exit code and signal is non-zero.
  40
  41
  42 (define (run cmd . args)
  43   (let ((p (open-process (list path: (path-expand cmd)
  44                                arguments: args
  45                                stdin-redirection: #f
  46                                stdout-redirection: #f
  47                                stderr-redirection: #f))))
  48     (let ((s (process-status p)))
  49       (close-port p)
  50       (or (= s 0)
  51           ;;(error )
  52           (error (string-append "command "
  53                                 (status->string s)
  54                                 ":")
  55                  cmd
  56                  args)))))
  57
  58 ;; --- / library stuff
  59
  60
  61 (define prog (car (command-line)))
  62 (define args (cdr (command-line)))
  63
  64 (define (usage maybe-err)
  65   (println
  66    (list
  67     (if maybe-err
  68         (list maybe-err "\n\n")
  69         '())
  70     "usage: "prog" path/to/file.scm"))
  71   (newline)
  72   (exit 1))
  73
  74 (if (= (length args) 1)
  75     (let ((base (basepath (car args))))
  76       (run "picobit" (string-append base ".scm"))
  77       (run "picobit-vm" (string-append base ".hex")))
  78     (usage "wrong number of arguments"))
  79