diff options
| -rw-r--r-- | csc/compiler.csc | 8 | ||||
| -rw-r--r-- | csc/flag.csc | 101 | ||||
| -rw-r--r-- | csc/main.csc | 66 |
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)))) |