Write the CLI frontend.

3 files changed, 170 insertions, 5 deletions

diff --git a/csc/compiler.csc b/csc/compiler.csc
index 728b8c5..6bdf1ba 100644
--- a/csc/compiler.csc
+++ b/csc/compiler.csc
@@ -1,6 +1,6 @@
 (define-library (csc compiler)
   (export
-    *library-search-dir*
+    *library-search-dirs*
     compile)
   (import (scheme base)
           (only (scheme file)
@@ -63,13 +63,11 @@
             (else 1)))))
 
 
-    (define *library-search-dir* #f)
+    (define *library-search-dirs* '())
 
 
     (define (find-library name)
-      (define library-roots (list *standard-library-dir*))
-      (when *library-search-dir*
-        (set! library-roots (cons *library-search-dir* library-roots)))
+      (define library-roots (cons *standard-library-dir* *library-search-dirs*))
       (loop for dir in library-roots
             for file-path = (loop for part in name
                                   collect (symbol->string part) into path
diff --git a/csc/flag.csc b/csc/flag.csc
new file mode 100644
index 0000000..ea699db
--- /dev/null
+++ b/csc/flag.csc
@@ -0,0 +1,101 @@
+(define-library (csc flag)
+  (export
+    *args*
+    bool-flag
+    define-bool-flag
+    define-flag
+    parse-error-flag
+    parse-error-msg
+    parse-error?
+    parse-flags)
+  (import (scheme base)
+          (only (csc hash-map)
+            compare-strings
+            key-not-found-error?
+            lookup
+            make-map)
+          (only (csc loop)
+            loop)
+          (only (csc strings)
+            prefix?
+            contains?))
+  (begin
+
+
+    (define (bool-flag s)
+      (cond
+        ((member s '("1" "t" "T" "true" "TRUE" "True"))
+          #t)
+        ((member s '("0" "f" "F" "false" "FALSE" "False"))
+          #f)
+        (else (error "Argument could not be parsed as a boolean" s))))
+
+
+    (define *parsers* (make-map compare-strings))
+
+
+    (define-syntax define-flag
+      (syntax-rules ()
+        ((define-flag name flag type default)
+          (define name (begin
+                         (set! *parsers* (insert *parsers* flag (lambda (x) (set! name (type x)))))
+                         default)))))
+
+
+    (define *args* '())
+
+
+    (define-record-type <parse-error>
+      (make-parse-error msg flag)
+      parse-error?
+      (msg parse-error-msg)
+      (flag parse-error-flag))
+
+
+    (define (parse-flags)
+      (define args (cdr (command-line)))
+      ; Is this legal?
+      (define (parse-one)
+        (match args
+          ('() #f)
+          ((s . _) when (or (not (has-prefix? s "-"))
+                            (string=? "-" s))
+            #f)
+          ((s . rest) when (string=? "--" s)
+            (set! args rest)
+            #f)
+          ((s . rest)
+            (define name (if (has-prefix? s "--")
+                           (string-copy s 2)
+                           (string-copy s 1)))
+            (when (or (string=? "" name)
+                      (has-prefix? name "-")
+                      (has-prefix? name "="))
+              (raise (make-parse-error "bad flag syntax" s)))
+            ; It's a flag. Does it have an argument?
+            (set! args rest)
+            (define value (match (split name "=" 2)
+                            ((a b)
+                              (set! name a)
+                              b)
+                            (_ #f)))
+            (define parser (guard (e ((key-not-found-error? e)
+                                       (raise (make-parse-error "flag provided but not defined" s))))
+                             (lookup *parsers* name)))
+            (if (eq? parser bool-flag)  ; Special case: doesn't need an arg.
+              (if value
+                (parser value)
+                (parser "true"))
+              (begin
+                ; It must have a value, which might be the next argument.
+                (when (and (not value)
+                           (not (null? args)))
+                  ; value is the next arg
+                  (set! value (car args))
+                  (set! args (cdr args)))
+                (unless value
+                  (raise (make-parse-flag "flag needs an argument" s)))
+                (parser value)))
+            #t)))
+      (loop while (parse-one))
+      (set! *args* args))))
diff --git a/csc/main.csc b/csc/main.csc
new file mode 100644
index 0000000..a67a511
--- /dev/null
+++ b/csc/main.csc
@@ -0,0 +1,66 @@
+(import (scheme base)
+        (only (scheme read)
+          read)
+        (only (csc compiler)
+          *library-search-dirs*)
+          compile
+        (only (csc flag)
+          *args*
+          bool-flag
+          define-flag
+          parse-error-flag
+          parse-error-msg
+          parse-error?
+          parse-flags)
+        (only (csc format)
+          printf)
+        (only (csc loop)
+          loop))
+
+
+(define-flag *include* "include" (lambda (s) (cons s include)) '())
+(define-flag *output* "output" string-copy "")
+(define-flag *help* "help" bool-flag #f)
+
+
+(define *help-msg*
+  "Usage: csc [OPTION]... [FILE]
+
+  --include DIRECTORY     Search in the given directory for libraries.
+                          This flag can be passed more than once.
+  --output FILE           Write output to the given file. The default is
+                          to immediately execute.
+")
+
+
+(define (read-file f)
+  (call-with-input-file f
+    (lambda (p)
+      (loop for expr = (read p)
+            until (eof-object? expr)
+            collect expr))))
+
+
+(define (write-file f bytes)
+  (call-with-port (open-binary-output-file f)
+    (lambda (p)
+      (write-bytevector bytes p))))
+
+
+(define (main)
+  (guard (e ((parse-error? e)
+              (printf "Error: could not parse flag {}: {}\n{}" (parse-error-flag e) (parse-error-msg e) *help-msg*)
+              (exit 2)))
+    (parse-flags))
+  (when *help*
+    (printf "{}" *help-msg*)
+    (exit 0))
+  (when (string=? "" *output*)
+    (printf "For now, the option --output is required. In the future, we will be able to execute code directly.\n")
+    (exit 2))
+  (define input-file (match *args*
+                       ((file) file)
+                       (_ (printf "Error: must pass exactly one file to csc.\n{}" *help-msg*)
+                          (exit 2))))
+  (set! *library-search-dirs* *include*)
+  (write-file *output* (compile (read-file input-file))))