[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

extended caller



The <caller> of the current spec of rest-values is only a procedure.  If the
<caller> can be any scheme expression like arg-and(s) macros, the rest-values
will be more useful.
Modifying the spec of rest-values makes it possible:
  from
  (REST-VALUES [<caller>] <rest-list> [<args-number-limit>] <default> ...)
  to
  (REST-VALUES [<caller>] <rest-list> [<args-number-limit> <default> ...])

The following is the modified version of rest-values.  How about this?

(define (rest-values rest-list . default-list)
  (let* ((caller (if (or (null? default-list)
			 (boolean? (car default-list))
			 (number? (car default-list)))
		     '()
		     (if (string? rest-list) rest-list (list rest-list))))
	 (rest (if (null? caller) rest-list (car default-list)))
	 (rest-length (if (list? rest)
			  (length rest)
			  (error "bad rest list" rest
				 `(rest-values ,rest-list ,@default-list))))
	 (default (if (null? caller) default-list (cdr default-list)))
	 (number
	  (and (not (null? default))
	       (let ((d (car default)))
		 (or (and (number? d)
			  (or (and (> rest-length (abs d))
				   (if (string? caller)
				       (error caller rest
					      `(<= (length ,rest) ,(abs d)))
				       (apply error "too many arguments" rest
					      `(<= (length ,rest) ,(abs d))
					      caller)))
			      (and (> (length (cdr default)) (abs d))
				   (error "too many defaults" (cdr default)
					  `(rest-values ,rest-list
							,@default-list)))
			      d))
		     (and (eq? d #f) 'false)
		     (eq? d #t)
		     (error "neither number nor boolean" d
			    `(rest-values ,rest-list ,@default-list))))))
	 (default (if number (cdr default) default))
	 (default-length (length default)))
    (if (or (and (number? number) (> number 0))
	    (eq? number #t))
	(let ((number (min rest-length default-length)))
	  (for-each (lambda (r d)
		      (cond
		       ((list? d)
			(if (not (member r d))
			    (if (string? caller)
				(error caller r `(member ,r ,d))
				(apply error "unmatched argument"
				       r `(member ,r ,d) caller))))
		       ((pair? d)
			(let ((p (cdr d)))
			  (if (procedure? p)
			      (if (not (p r))
				  (if (string? caller)
				      (error caller r `(,p ,r))
				      (apply error "incorrect argument"
					     r `(,p ,r) caller)))
			      (error "bad predicate" p
				     `(rest-values ,rest-list
						   ,@default-list)))))
		       (else
			(error "bad default" d
			       `(rest-values ,rest-list ,@default-list)))))
		    (take rest number) (take default number))
	  (apply values
		 (if (> default-length rest-length)
		     (append rest
			     (map (lambda (x)
				    (if (pair? x)
					(car x)
					(error "bad default" x
					       `(rest-values ,rest-list
							     ,@default-list))))
				  (list-tail default rest-length)))
		     rest)))
	(apply values (if (> default-length rest-length)
			  (append rest (list-tail default rest-length))
			  rest)))))
-- 
INITTERM