From 2d040307afa009a9de054cd18d78b4ceb3bcd1aa Mon Sep 17 00:00:00 2001 From: Common Lisp at Google Date: Tue, 30 Jun 2026 10:55:18 -0700 Subject: [PATCH] Disallow SYMBOL, KEYWORD as flag types and disallow conjunctions (AND) PiperOrigin-RevId: 940543627 --- flag-test.lisp | 103 ++++-------------------------------------------- flag.lisp | 6 +++ parse-test.lisp | 28 +------------ parse.lisp | 33 ++-------------- 4 files changed, 19 insertions(+), 151 deletions(-) diff --git a/flag-test.lisp b/flag-test.lisp index 51e28d3..d1a28c4 100644 --- a/flag-test.lisp +++ b/flag-test.lisp @@ -39,12 +39,8 @@ (test-define *null* nil "Always null" :type null) -(test-define *keyword* nil "A keyword flag" :type (or null keyword)) - (test-define *member* :a "A member flag" :type (member nil :a :b :c)) -(test-define *implicit-keyword* :a "An implicit keyword flag.") - (test-define *implicit-string* "string" "An implicit string flag.") (test-define *string* nil "A string flag." :type (or null string)) @@ -83,7 +79,7 @@ doc has embedded (test-define *mod* 10 "Modulo 10" :type (mod 16)) -(test-define *plus* 10 "Positive fixnum" :type (and fixnum unsigned-byte)) +;(test-define *plus* 10 "Positive fixnum" :type (and fixnum unsigned-byte)) (test-define *some-flag* nil "A Flag that accepts inf, -inf, nan, or number." :type (or (member nil :inf :-inf :nan) number)) @@ -164,8 +160,6 @@ doc has embedded --implicit-integer Type: INTEGER Value: 10 - --implicit-keyword [An implicit keyword flag.] Type: KEYWORD Value: :A - --implicit-string [An implicit string flag.] Type: STRING Value: \"string\" -i @@ -184,15 +178,6 @@ doc has embedded --intflag [no doc] Type: (INTEGER -10 10) Value: 10 - -K - --key - [Short keyword flag] - Type: (OR NULL KEYWORD) - - --keyword [A keyword flag] Type: (OR NULL KEYWORD) - - --keyflag [no doc] Type: KEYWORD Value: :FOO - --lorem-ipsum [Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, @@ -231,8 +216,6 @@ doc has embedded --parsed-flag [A flag in hex.] Type: INTEGER Value: 0 - --plus [Positive fixnum] Type: (AND FIXNUM UNSIGNED-BYTE) Value: 10 - --print-help-and-newlines [This doc has embedded @@ -257,8 +240,6 @@ doc has embedded --stringflag [no doc] Type: STRING Value: \"foo\" - --symflag [no doc] Type: SYMBOL Value: :BAR - --symbol-macro-flag Type: BOOLEAN --true [Test boolean flag.] Type: BOOLEAN Value: T @@ -307,18 +288,6 @@ doc has embedded (with-flags-binding (:args '("--nointeger")) (expect (null *integer*)))) -(deftest test-keyword-flag () - (multiple-value-bind (type result parsed-p consume-p) - (parse-variable '*keyword* "keyword") - (expect (equal type '(or null keyword))) - (expect (equal result :keyword)) - (expect parsed-p) - (expect consume-p)) - - (with-flags-binding (:args '("--keyword" "keyword")) - (expect (eq *keyword* :keyword)))) - - (deftest test-foo-flag () (multiple-value-bind (type result parsed-p consume-p) (parse-variable '*foo* "F00") @@ -336,9 +305,7 @@ doc has embedded "--notrue" "--nofalse" "--null" "null" - "--keyword" "keyword" "--member" "a" - "--implicit_keyword" "keyword" "--implicit_string" "string" "--string" "abc" "--very_long_doc" "doc" @@ -356,7 +323,6 @@ doc has embedded "--double2" "-nan" "--double3" "-inf" "--mod" "5" - "--plus" "2000" "--some_flag" "nan" "--a-named_flag" "100" "--named_flag2" "200" @@ -376,9 +342,7 @@ doc has embedded (expect (not *true*)) (expect (not *false*)) (expect (not *null*)) - (expect (eq *keyword* :keyword)) (expect (eq *member* :a)) - (expect (eq *implicit-keyword* :keyword)) (expect (equal *implicit-string* "string")) (expect (equal *string* "abc")) (expect (equal *very-long-doc* "doc")) @@ -390,7 +354,6 @@ doc has embedded (expect (number:float-nan-p *double2*)) (expect (= sb-ext:double-float-negative-infinity *double3*)) (expect (= *mod* 5)) - (expect (= *plus* 2000)) (expect (eq *some-flag* :nan)) (expect (= *named-flag* 100)) (expect (= *named-flag2* 200)) @@ -405,9 +368,7 @@ doc has embedded "--notrue" "--nofalse" "--null=null" - "--keyword=keyword" "--member=a" - "--implicit_keyword=keyword" "--implicit_string=string" "--string=abc" "--very_long_doc=doc" @@ -425,7 +386,6 @@ doc has embedded "--double2=-nan" "--double3=-inf" "--mod=5" - "--plus=2000" "--some_flag=nan" "--a-named_flag=100" @@ -446,9 +406,7 @@ doc has embedded (expect (not *true*)) (expect (not *false*)) (expect (not *null*)) - (expect (eq *keyword* :keyword)) (expect (eq *member* :a)) - (expect (eq *implicit-keyword* :keyword)) (expect (equal *implicit-string* "string")) (expect (equal *string* "abc")) (expect (equal *very-long-doc* "doc")) @@ -460,7 +418,6 @@ doc has embedded (expect (number:float-nan-p *double2*)) (expect (= sb-ext:double-float-negative-infinity *double3*)) (expect (= *mod* 5)) - (expect (= *plus* 2000)) (expect (eq *some-flag* :nan)) (expect (= *named-flag* 100)) (expect (= *named-flag2* 200)) @@ -542,9 +499,7 @@ doc has embedded (test-wrong-value "--boolean" ":true") (test-wrong-value "--boolean2" "0") (test-wrong-value "--null" "true") - (test-wrong-value "--keyword" "f:10") (test-wrong-value "--member" "f") - (test-wrong-value "--implicit_keyword" "some:symbol") (test-wrong-value "--implicit_integer" "abc") (test-wrong-value "--integer" "0.0") (test-wrong-value "--number" ":test") @@ -554,7 +509,6 @@ doc has embedded (test-wrong-value "--double2" "#xFFFF") (test-wrong-value "--double3" "nada") (test-wrong-value "--mod" "-10") - (test-wrong-value "--plus" "-2000") (test-wrong-value "--some_flag" "nano")) (defun test-missing-value (&rest args) @@ -562,9 +516,7 @@ doc has embedded (deftest test-missing-values () (test-missing-value "--null") - (test-missing-value "--keyword") (test-missing-value "--member") - (test-missing-value "--implicit_keyword") (test-missing-value "--implicit_integer") (test-missing-value "--integer") (test-missing-value "--number") @@ -573,22 +525,19 @@ doc has embedded (test-missing-value "--double2") (test-missing-value "--double3") (test-missing-value "--mod") - (test-missing-value "--plus") (test-missing-value "--some_flag")) (deftest invalid-names-test () - (expect-macro-warning (flag:define *f* t "na" :name "an_underscore-and-hyphens" :type symbol)) - (expect-macro-warning (flag:define *f* t "na" :name "3rror" :type symbol)) - (expect-macro-warning (flag:define *f* t "na" :names ("a-dash" "3rror") :type symbol)) - (expect-macro-warning (flag:define *.* t "na" :type symbol)) - (expect-macro-warning (flag:define *f.* t "na" :type symbol)) - (expect-macro-warning (flag:define *funny/flag* t "na" :type symbol))) + (expect-macro-warning (flag:define *f* t "na" :name "an_underscore-and-hyphens" :type integer)) + (expect-macro-warning (flag:define *f* t "na" :name "3rror" :type integer)) + (expect-macro-warning (flag:define *f* t "na" :names ("a-dash" "3rror") :type integer)) + (expect-macro-warning (flag:define *.* t "na" :type integer)) + (expect-macro-warning (flag:define *f.* t "na" :type integer)) + (expect-macro-warning (flag:define *funny/flag* t "na" :type integer))) (test-define *boo* t "Short test boolean flag." :names ("boo" "B")) -(test-define *key* nil "Short keyword flag" :type (or null keyword) :names ("key" "K")) - (test-define *mem* :a "Short member flag" :type (member nil :a :b :c) :names ("mem" "M")) (test-define *int* 10 "An short int flag" :type (or (integer -100 100) null) :names ("int" "i")) @@ -600,14 +549,12 @@ doc has embedded (deftest test-short-flags () (with-flags-binding (:args '("-B=false" - "-K" "kEy" "-M" "B" "-i=11" "-I" "22" "-f" "0.0" "-S" "str")) (expect (null *boo*)) - (expect (eq *key* :key)) (expect (eq *mem* :B)) (expect (= *int* 11)) (expect (= *int2* 22)) @@ -687,33 +634,6 @@ doc has embedded (expect-error (parse-command-line* '("--noboolflag" "true"))) (expect-error (parse-command-line* '("--noboolflag" "false"))))) -(test-define *keyword-flag* :foo "no doc" :name "keyflag" :type keyword) - -(deftest keyword-flag () - (expect (eq *keyword-flag* :foo)) - (let ((*keyword-flag* *keyword-flag*)) - (parse-command-line* '("--keyflag" "dog")) - (expect (eq *keyword-flag* :dog)) - (parse-command-line* '("--keyflag=cat")) - (expect (eq *keyword-flag* :cat)) - (parse-command-line* '("--keyflag=")) - (expect (eq *keyword-flag* :||)))) - -(test-define *symbol-flag* :bar "no doc" :name "symflag" :type symbol) - -(deftest symbol-flag () - (expect (eq *symbol-flag* :bar)) - (let ((*symbol-flag* *symbol-flag*)) - (parse-command-line* '("--symflag" "ace.flag:define")) - (expect (eq *symbol-flag* 'ace.flag:define)) - (parse-command-line* '("--symflag=ace.flag-test::unexported-symbol")) - (expect (eq *symbol-flag* 'unexported-symbol)) - (expect-error (parse-command-line* '("--symflag="))) - (expect-error (parse-command-line* '("--symflag" ":bad-colons"))) - (expect-error (parse-command-line* '("--symflag" "more:bad:colons"))) - (expect-error (parse-command-line* '("--symflag" "bad-package:foo"))) - (expect-error (flag:parse-command-line :args '("--symflag"))))) - (test-define *string-flag* "foo" "no doc" :name "stringflag" :type string) (deftest string-flag () @@ -786,12 +706,6 @@ doc has embedded (expect-error (parse-command-line* '("--color=orange"))))) (deftest syntax-errors () - (expect-macro-warning (flag:define *s* t "na" :name s :type symbol)) - (expect-macro-warning (flag:define *s* t "na" :name "" :type symbol)) - (expect-macro-warning (flag:define *s* t "na" :name "s" :type "symbol")) - (expect-macro-error (flag:define *s* t "na" :name "s" :type symbol :help h)) - (expect-macro-warning (flag:define *s* t "na" :name "s" :type symbol :parser "p")) - (expect-macro-warning (flag:define *s* t 'd :name "s" :type symbol)) (expect-macro-warning (flag:define *s* t "na" :name "s" :type vector))) (test-define *no-go* nil "no doc" :name "nogo" :type boolean) @@ -799,8 +713,7 @@ doc has embedded (deftest boolean-semantic-errors () (expect-error (flag:define *b* nil "na" :name "boolflag" :type boolean)) - (expect-error (flag:define *go* nil "na" :name "go" :type boolean)) - (expect-error (flag:define *north* nil "na" :name "north" :type symbol))) + (expect-error (flag:define *go* nil "na" :name "go" :type boolean))) (defvar *symbol-flag* nil) diff --git a/flag.lisp b/flag.lisp index b3c9083..033aabe 100644 --- a/flag.lisp +++ b/flag.lisp @@ -130,6 +130,12 @@ (fail "The flag ~S requires a help string." doc)) (unless type (fail "Flag definition ~S lacks a :TYPE" flag)) + (labels ((treefind (elt tree) + (cond ((atom tree) (eq elt tree)) + (t (or (treefind elt (car tree)) (treefind elt (cdr tree))))))) + (let ((expansion (sb-ext:typexpand type))) + (when (or (treefind 'keyword expansion) (treefind 'symbol expansion)) + (error "Don't parse flag ~S as a symbol. Use string instead" flag)))) (unless (typep type '(or symbol cons)) (fail "The type of flag ~S needs to be a proper type specifier. Provided: ~S." flag type)) (dolist (name names) diff --git a/parse-test.lisp b/parse-test.lisp index af5a102..5a37eb1 100644 --- a/parse-test.lisp +++ b/parse-test.lisp @@ -73,28 +73,6 @@ (test-not-parsed 'null "YES") (test-not-parsed 'null "What-ever")) -(deftest test-parse-type-keyword () - (test-parse-type 'keyword ":keyword" :keyword) - (test-parse-type 'keyword "true" :true) - (test-parse-type 'keyword "False" :false) - (test-parse-type 'keyword "1" :1) - (test-parse-type 'keyword "-1" :-1) - (test-parse-type 'keyword "nil" :nil) - (test-parse-type 'keyword "t" :t)) - -(deftest test-parse-type-symbol () - (test-parse-type 'symbol "ace.flag.parse-test:test-parse-type" 'test-parse-type) - (test-parse-type 'symbol "ace.flag.parse-test::test-parse-type" 'test-parse-type) - (test-parse-type 'symbol ":test-parse-type" :test-parse-type) - - (test-not-parsed 'symbol "test:::test-parse-type") - (test-not-parsed 'symbol "test-parse-type") - (test-not-parsed 'symbol "::test-parse-type") - (test-not-parsed 'symbol ":::test-parse-type") - (test-not-parsed 'symbol "t") - (test-not-parsed 'symbol "nil") - (test-not-parsed 'symbol "0")) - (deftest test-parse-type-string () (test-parse-type 'string "" "") (test-parse-type 'string "A" "A") @@ -223,7 +201,6 @@ (deftest test-parse-type-or () (test-parse-type '(or number boolean) "true" t) - (test-parse-type '(or boolean keyword) "yes" t) (test-parse-type '(or single-float boolean) "t" t) (test-parse-type '(or integer boolean) "True" t) @@ -231,14 +208,11 @@ (test-parse-type '(or null boolean) "T" t) (test-parse-type '(or number string) "True" "True") - (test-parse-type '(or number keyword) "YES" :YES) (test-parse-type '(or boolean boolean) "nil" nil) (test-parse-type '(or null boolean) "no" nil) (test-parse-type '(or null double-float) "nan" double-float-not-a-number) - (test-parse-type '(or boolean keyword) "Null" nil) - (test-parse-type '(or number boolean) "NIL" nil) - (test-parse-type '(or symbol boolean) "NO" nil)) + (test-parse-type '(or number boolean) "NIL" nil)) diff --git a/parse.lisp b/parse.lisp index cec22c2..60064a7 100644 --- a/parse.lisp +++ b/parse.lisp @@ -99,13 +99,8 @@ The TYPE-SELECTOR is the type-specifier itself or the car of the type-specifier. (return (values parsed-value t)))))) (defmethod type ((type-selector (eql 'and)) (value string) &key specifier top) - ; Parses an and type. Iterates through the subtypes. - (assert specifier) - (dolist (sub-type (rest specifier)) - (multiple-value-bind (parsed-value parsed-p) - (type (type-selector sub-type) value :specifier sub-type :top (or top specifier)) - (when (and parsed-p (typep parsed-value (or top specifier))) - (return (values parsed-value t)))))) + (declare (ignore specifier top)) + (error "Unreachable: AND")) (defmethod type ((type-selector (eql 'member)) (value string) &key specifier top) ; Parses a member specifier. Iterates through members. Compares by equalp. @@ -134,30 +129,10 @@ The TYPE-SELECTOR is the type-specifier itself or the car of the type-specifier. (values value (and value t))) (defmethod type ((type-selector (eql 'keyword)) (value string) &key) - ; Interns the value into the keyword package. - (let ((colon (position #\: value :test #'char=))) - (cond ((null colon) - (values (intern (string-upcase value) (find-package "KEYWORD")) t)) - ((= colon 0) - (unless (find #\: value :test #'char= :start 1) - (type 'keyword (subseq value 1)))) - (t - (values nil nil))))) + (error "Unreachable: KEYWORD")) (defmethod type ((type-selector (eql 'symbol)) (value string) &key) - ; Parses a symbol that is prefixed with the package. - (let* ((full-name (string-trim " " (string-upcase value))) - (pos (position #\: full-name :from-end t)) - (package-name - (when (and pos (plusp pos)) - (subseq full-name 0 (if (char= (char full-name (1- pos)) #\:) (1- pos) pos)))) - (package (and package-name (find-package package-name))) - (symbol-name (and pos (subseq full-name (1+ pos)))) - (symbol (cond (package - (find-symbol symbol-name package)) - ((eql pos 0) - (find-symbol symbol-name (find-package "KEYWORD")))))) - (values symbol (and symbol t)))) + (error "Unreachable: SYMBOL")) (defmethod type ((type-selector (eql 'number)) (value string) &key) ; Parses a number.