From 8fc3997b73e98416f64b78f2814711b6d1439755 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Fri, 29 Jul 2022 17:03:03 -0700
Subject: Fig bugs in the flag library.

Now bool flags are handled properly. We have a compiler!!
---
 csc/flag.csc | 32 ++++++++++++++++++++++----------
 csc/main.csc | 10 +++++++++-
 2 files changed, 31 insertions(+), 11 deletions(-)

(limited to 'csc')

diff --git a/csc/flag.csc b/csc/flag.csc
index c328dcf..c0a28a8 100644
--- a/csc/flag.csc
+++ b/csc/flag.csc
@@ -38,14 +38,26 @@
 
 
     (define *parsers* (make-map compare-strings))
+    ; I'm working around a Guile bug, which wrongly concludes
+    ; that *parsers* is immutable.
+    (set! *parsers* *parsers*)
+
+
+    (define-record-type <flag>
+      (make-flag bool? setter)
+      flag?
+      (bool? flag-bool?)
+      (setter flag-setter))
 
 
     (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)))))
+          (begin
+            (define name default)
+            (set! *parsers* (insert *parsers* flag
+                              (make-flag (eq? type bool-flag)
+                                         (lambda (x) (set! name (type x))))))))))
 
 
     (define *args* '())
@@ -85,13 +97,13 @@
                               (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.
+            (define flag (guard (e ((key-not-found-error? e)
+                                     (raise (make-parse-error "flag provided but not defined" s))))
+                           (lookup *parsers* name)))
+            (if (flag-bool? flag)  ; Special case: doesn't need an arg.
               (if value
-                (parser value)
-                (parser "true"))
+                ((flag-setter flag) value)
+                ((flag-setter flag) "true"))
               (begin
                 ; It must have a value, which might be the next argument.
                 (when (and (not value)
@@ -101,7 +113,7 @@
                   (set! args (cdr args)))
                 (unless value
                   (raise (make-parse-error "flag needs an argument" s)))
-                (parser value)))
+                ((flag-setter flag) value)))
             #t)))
       (loop while (parse-one))
       (set! *args* args))))
diff --git a/csc/main.csc b/csc/main.csc
index 1e2cde1..9dae75f 100644
--- a/csc/main.csc
+++ b/csc/main.csc
@@ -1,4 +1,6 @@
 (import (scheme base)
+        (only (scheme file)
+          open-binary-output-file)
         (only (scheme read)
           read)
         (only (csc compiler)
@@ -23,6 +25,7 @@
 (define-flag *include* "include" (lambda (s) (cons s *include*)) '())
 (define-flag *output* "output" string-copy "")
 (define-flag *help* "help" bool-flag #f)
+(define-flag *h* "h" bool-flag #f)
 
 
 (define *help-msg*
@@ -32,6 +35,8 @@
                           This flag can be passed more than once.
   --output FILE           Write output to the given file. The default is
                           to immediately execute.
+
+  --help,-h               Print the usage message.
 ")
 
 
@@ -54,7 +59,7 @@
               (printf "Error: could not parse flag {}: {}\n{}" (parse-error-flag e) (parse-error-msg e) *help-msg*)
               (exit 2)))
     (parse-flags))
-  (when *help*
+  (when (or *help* *h*)
     (printf "{}" *help-msg*)
     (exit 0))
   (when (string=? "" *output*)
@@ -66,3 +71,6 @@
                           (exit 2))))
   (set! *library-search-dirs* *include*)
   (write-file *output* (compile (read-file input-file))))
+
+
+(main)
-- 
cgit v1.3.1