Permalink
Browse files

Add optional :clause-kinds :clause-keywords :clauses-alist returns fo…

…r PARSE. TODO: equivalents for UNPARSE.
  • Loading branch information...
1 parent 1fde962 commit db68ad86fdbdb15aa4c7e3980be425045e6fe107 @Hexstream committed Oct 17, 2012
Showing with 60 additions and 30 deletions.
  1. +60 −30 main.lisp
View
@@ -1,11 +1,20 @@
(in-package #:parse-number-range)
-(defun parse (range &aux
+(defun parse (range &key
+ (extrasp t)
+ (clause-kinds-p extrasp)
+ (clause-keywords-p extrasp)
+ (clauses-alist-p extrasp)
+ &aux
(from 0) from-p
(to nil) to-p
(by 1) by-p
- direction (limit-kind :unbounded))
- '(values from to limit-kind by direction)
+ direction
+ (limit-kind :unbounded)
+ clause-kinds
+ clause-keywords
+ clauses-alist)
+ '(values from to limit-kind by direction &key order keywords)
(flet ((direction (new-direction)
(if direction
(unless (eq direction new-direction)
@@ -22,35 +31,56 @@
(error "Duplicate ~A specification in range ~S."
type range)))
(do ((tail range (cddr tail)))
- ((endp tail) (values from to limit-kind by (or direction '+)))
+ ((endp tail)
+ (multiple-value-call #'values
+ (values from to limit-kind by (or direction '+))
+ (if clause-kinds-p
+ (values :clause-kinds (nreverse clause-kinds))
+ (values))
+ (if clause-keywords-p
+ (values :clause-keywords (nreverse clause-keywords))
+ (values))
+ (if clauses-alist-p
+ (values :clauses-alist (nreverse clauses-alist))
+ (values))))
(destructuring-bind (key value &rest rest) tail
(declare (ignore rest))
- (ecase key
- ((:from :downfrom :upfrom)
- (when from-p
- (duplicate "FROM"))
- (setf from value
- from-p t)
- (ecase key
- (:from)
- (:downfrom (direction '-))
- (:upfrom (direction '+))))
- ((:to :downto :upto :below :above)
- (when to-p
- (duplicate "TO"))
- (setf to value
- to-p t)
- (ecase key
- (:to (limit-kind :inclusive))
- (:downto (direction '-) (limit-kind :inclusive))
- (:upto (direction '+) (limit-kind :inclusive))
- (:below (direction '+) (limit-kind :exclusive))
- (:above (direction '-) (limit-kind :exclusive))))
- (:by
- (when by-p
- (duplicate "BY"))
- (setf by value
- by-p t)))))))
+ (let ((keyword
+ (ecase key
+ ((:from :downfrom :upfrom)
+ (prog1 :from
+ (when from-p
+ (duplicate "FROM"))
+ (setf from value
+ from-p t)
+ (ecase key
+ (:from)
+ (:downfrom (direction '-))
+ (:upfrom (direction '+)))))
+ ((:to :downto :upto :below :above)
+ (prog1 :to
+ (when to-p
+ (duplicate "TO"))
+ (setf to value
+ to-p t)
+ (ecase key
+ (:to (limit-kind :inclusive))
+ (:downto (direction '-) (limit-kind :inclusive))
+ (:upto (direction '+) (limit-kind :inclusive))
+ (:below (direction '+) (limit-kind :exclusive))
+ (:above (direction '-) (limit-kind :exclusive)))))
+ (:by
+ (prog1 :by
+ (when by-p
+ (duplicate "BY"))
+ (setf by value
+ by-p t))))))
+ (when clause-kinds-p
+ (push keyword clause-kinds))
+ (when clause-keywords-p
+ (push key clause-keywords))
+ (when clauses-alist-p
+ (push (cons keyword key) clauses-alist)))))))
(defun %direction/limit-to-keywords (direction limit-kind)
'(values from-keyword to-keyword)

0 comments on commit db68ad8

Please sign in to comment.