-(defun natural-string< (string1 string2
- &key (start1 0) (end1 nil)
- (start2 0) (end2 nil))
- "Answer whether STRING1 precedes STRING2 in a vaguely natural ordering.
-
- In particular, digit sequences are handled in a moderately sensible way.
- Split the strings into maximally long alternating sequences of non-numeric
- and numeric characters, such that the non-numeric sequences are
- non-empty. Compare these lexicographically; numeric sequences order
- according to their integer values, non-numeric sequences in the usual
- lexicographic ordering.
-
- Returns two values: whether STRING1 strictly precedes STRING2, and whether
- STRING1 strictly follows STRING2."
-
- (let ((end1 (or end1 (length string1)))
- (end2 (or end2 (length string2))))
- (loop
- (cond ((>= start1 end1)
- (let ((eqp (>= start2 end2)))
- (return (values (not eqp) nil))))
- ((>= start2 end2)
- (return (values nil t)))
- ((and (digit-char-p (char string1 start1))
- (digit-char-p (char string2 start2)))
- (let* ((lim1 (or (position-if-not #'digit-char-p string1
- :start start1 :end end1)
- end1))
- (n1 (parse-integer string1 :start start1 :end lim1))
- (lim2 (or (position-if-not #'digit-char-p string2
- :start start2 :end end2)
- end2))
- (n2 (parse-integer string2 :start start2 :end lim2)))
- (cond ((< n1 n2) (return (values t nil)))
- ((> n1 n2) (return (values nil t))))
- (setf start1 lim1
- start2 lim2)))
- (t
- (let ((lim1 (or (position-if #'digit-char-p string1
- :start start1 :end end1)
- end1))
- (lim2 (or (position-if #'digit-char-p string2
- :start start2 :end end2)
- end2)))
- (cond ((string< string1 string2
- :start1 start1 :end1 lim1
- :start2 start2 :end2 lim2)
- (return (values t nil)))
- ((string> string1 string2
- :start1 start1 :end1 lim1
- :start2 start2 :end2 lim2)
- (return (values nil t))))
- (setf start1 lim1
- start2 lim2)))))))
-
-(defun domain-name< (name-a name-b)
- "Answer whether NAME-A precedes NAME-B in an ordering of domain names.
-
- Split the names into labels at the dots, and then lexicographically
- compare the sequences of labels, right to left, using `natural-string<'.
-
- Returns two values: whether NAME-A strictly precedes NAME-B, and whether
- NAME-A strictly follows NAME-B."
- (let ((pos-a (length name-a))
- (pos-b (length name-b)))
- (loop (let ((dot-a (or (position #\. name-a
- :from-end t :end pos-a)
- -1))
- (dot-b (or (position #\. name-b
- :from-end t :end pos-b)
- -1)))
- (multiple-value-bind (precp follp)
- (natural-string< name-a name-b
- :start1 (1+ dot-a) :end1 pos-a
- :start2 (1+ dot-b) :end2 pos-b)
- (cond (precp
- (return (values t nil)))
- (follp
- (return (values nil t)))
- ((= dot-a -1)
- (let ((eqp (= dot-b -1)))
- (return (values (not eqp) nil))))
- ((= dot-b -1)
- (return (values nil t)))
- (t
- (setf pos-a dot-a
- pos-b dot-b))))))))
+(defmacro defenum (name (&key export) &body values)
+ "Set up symbol properties for manifest constants.
+
+ The VALUES are a list of (TAG VALUE) pairs. Each TAG is a symbol; we set
+ the NAME property on TAG to VALUE, and export TAG. There are also handy
+ hash-tables mapping in the forward and reverse directions, in the name
+ symbol's `enum-forward' and `enum-reverse' properties."
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ ,(let*/gensyms (export)
+ (with-gensyms (forward reverse valtmp)
+ `(let ((,forward (make-hash-table))
+ (,reverse (make-hash-table)))
+ (when ,export (export ',name))
+ ,@(mapcar (lambda (item)
+ (destructuring-bind (tag value) item
+ (let ((constant
+ (intern (concatenate 'string
+ (symbol-name name)
+ "/"
+ (symbol-name tag)))))
+ `(let ((,valtmp ,value))
+ (when ,export
+ (export ',constant)
+ (when (eq (symbol-package ',tag) *package*)
+ (export ',tag)))
+ (defconstant ,constant ,valtmp)
+ (setf (get ',tag ',name) ,value
+ (gethash ',tag ,forward) ,valtmp
+ (gethash ,valtmp ,reverse) ',tag)))))
+ values)
+ (setf (get ',name 'enum-forward) ,forward
+ (get ',name 'enum-reverse) ,reverse))))))
+
+(defun lookup-enum (name tag &key min max)
+ "Look up a TAG in an enumeration.
+
+ If TAG is a symbol, check its NAME property; if it's a fixnum then take it
+ as it is. Make sure that it's between MIN and MAX, if they're not nil."
+ (let ((value (etypecase tag
+ (fixnum tag)
+ (symbol (or (get tag name)
+ (error "~S is not a known ~A" tag name))))))
+ (unless (and (or (null min) (<= min value))
+ (or (null max) (<= value max)))
+ (error "Value ~S out of range for ~A" value name))
+ value))
+
+(defun reverse-enum (name value)
+ "Reverse-lookup of a VALUE in enumeration NAME.
+
+ If a tag for the VALUE is found, return it and `t'; otherwise return VALUE
+ unchanged and `nil'."
+ (multiple-value-bind (tag foundp) (gethash value (get name 'enum-reverse))
+ (if foundp
+ (values tag t)
+ (values value nil))))
+
+(defun mapenum (func name)
+ "Call FUNC on TAG/VALUE pairs from the enumeration called NAME."
+ (maphash func (get name 'enum-forward)))