From a89d6c82e981fec7d6e4c975e083d2b9e04467ad Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Mon, 1 May 2023 07:56:42 -0700
Subject: Rewrite most of the compiler.

This represents a major step back in terms of functionality, and amount
of code. The latter I think constitutes a major win. Next steps are to
reimplement syntax-rules, call/cc, and call-with-values.
---
 lib/csc/flag.csc | 120 -------------------------------------------------------
 1 file changed, 120 deletions(-)
 delete mode 100644 lib/csc/flag.csc

(limited to 'lib/csc/flag.csc')

diff --git a/lib/csc/flag.csc b/lib/csc/flag.csc
deleted file mode 100644
index c26fa90..0000000
--- a/lib/csc/flag.csc
+++ /dev/null
@@ -1,120 +0,0 @@
-(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 (scheme process-context)
-            command-line)
-          (only (csc hash-map)
-            compare-strings
-            insert
-            key-not-found-error?
-            lookup
-            make-map)
-          (only (csc loop)
-            loop)
-          (only (csc match)
-            match)
-          (only (csc strings)
-            contains?
-            has-prefix?
-            split))
-  (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 (add-parser flag bool? setter)
-      (set! *parsers* (insert *parsers* flag
-                        (make-flag bool? setter))))
-
-
-    (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)
-          (begin
-            (define name default)
-            (add-parser flag (eq? type bool-flag)
-                        (lambda (x) (set! name (type x))))))))
-
-
-    (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 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
-                ((flag-setter flag) value)
-                ((flag-setter flag) "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-error "flag needs an argument" s)))
-                ((flag-setter flag) value)))
-            #t)))
-      (loop while (parse-one))
-      (set! *args* args))))
-- 
cgit v1.3.1