65 lines
2.1 KiB
Scheme
65 lines
2.1 KiB
Scheme
;; PRED-LIST contains list of predicates that recognizes optional
|
|
;; leading parameters. FURTHER-ATTRIBUTES is the optional parameter
|
|
;; list as got by procedure call. TYPED-OPTIONALS returns two values:
|
|
;; a list of the same length as PRED-LIST and a list containing the
|
|
;; left arguments that did not fit the predicates.
|
|
;;
|
|
;; With the help of TYPED-OPTIONALS you can define a function
|
|
;; like `make-submit-button [string] [further-attributes]' this way:
|
|
;; (define (make-submit-button . args)
|
|
;; (receive (params rest-args)
|
|
;; (prefix-optionals (list string? xml-attribute?) args)
|
|
;; (if (pair? rest-args)
|
|
;; (error "too many arguments to make-submit-button))
|
|
;; (let ((value (first params))
|
|
;; (attributes (second params)))
|
|
;; ...))))
|
|
;;
|
|
(define (typed-optionals pred-list args)
|
|
(let loop ((results '())
|
|
(pred-list pred-list)
|
|
(args args))
|
|
(cond
|
|
((null? pred-list)
|
|
(values (reverse results) args))
|
|
((null? args)
|
|
(values (rev-append results (make-list (length pred-list) #f)) '()))
|
|
(((car pred-list) (car args))
|
|
(loop (cons (car args) results)
|
|
(cdr pred-list)
|
|
(cdr args)))
|
|
(else
|
|
(loop (cons #f results)
|
|
(cdr pred-list)
|
|
args)))))
|
|
|
|
|
|
(define-syntax optionals
|
|
(lambda (exp rename compare)
|
|
(let ((%receive (rename 'receive))
|
|
(%typed-optionals (rename 'typed-optionals))
|
|
(%list (rename 'list))
|
|
(%if (rename 'if))
|
|
(%pair? (rename 'pair?))
|
|
(%error (rename 'error))
|
|
(%let (rename 'let))
|
|
(%list-ref (rename 'list-ref))
|
|
|
|
(args (cadr exp))
|
|
(var-list (caddr exp))
|
|
(body (cadddr exp)))
|
|
`(,%receive (params rest-args)
|
|
(,%typed-optionals (,%list ,@(map cadr var-list)) ,args)
|
|
(,%if (pair? rest-args)
|
|
(,%error "optionals: too many arguments and/or argument type mismatch"
|
|
rest-args)
|
|
(,%let (,@(let loop ((counter 0)
|
|
(var-list var-list))
|
|
(if (null? var-list)
|
|
'()
|
|
(cons (cons (caar var-list) `((,%list-ref params ,counter)))
|
|
(loop (+ 1 counter)
|
|
(cdr var-list))))))
|
|
,body))))))
|
|
|