bones-scheme/run at develop · natethern/bones-scheme · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
#!/bin/scheme /grass/16/boot
;; run .scm, .s or .o file -*- Scheme -*-

(require 'sh 'match)


(define compiler "./bones")


(define output-format
  (case (system-software)
    ((Linux) 'elf64)
    ((Darwin) 'macho64)
    (else (error "unknown system"))))


(let ((features '()))
  (let loop ((args (command-line-arguments)))
    (match args
      (("-c" comp . more)
       (set! compiler comp)
       (loop more))
      (("-feature" f . more)
       (push! f features)
       (loop more))
      ((fname . options)
       ;; can it get more crude?
       (when (string=? "scm" (suffix fname))
	 (let ((fname2 (replace-suffix "s" fname)))
	   (run (,compiler ,fname -o ,fname2 -comment
			   ,@(append-map (cut list '-feature <>) features)))
	   (set! fname fname2)))
       (when (string=? "s" (suffix fname))
	 (let ((fname2 (replace-suffix "o" fname)))
	   (run (nasm -f ,output-format -g -F dwarf ,fname -o ,fname2 ,@options))
	   (set! fname fname2)))
       (when (string=? "o" (suffix fname))
	 (let ((fname2 (strip-suffix fname)))
	   (if (member "nolibc" features) ; hack
	       (run (ld ,fname -o ,fname2))
	       (run (gcc ,fname -o ,fname2 -lrt)))
	   (set! fname fname2)))
       (run (memtime ,(string-append "./" fname)))))))