mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-03 05:20:16 +02:00
Code Activity

define-option-interface in terms of syntax-rules

Browse source 
* module/ice-9/boot-9.scm (define-option-interface): Rewrite using
  syntax-rules.
This commit is contained in:
Andy Wingo 2010-06-11 13:14:03 +02:00
parent 47aabe86ca
commit 122f296ddc
1 changed files with 36 additions and 52 deletions
Download patch file Download diff file Expand all files Collapse all files

88
module/ice-9/boot-9.scm
View file

@ -2643,58 +2643,42 @@ module '(ice-9 q) '(make-q q-length))}."
;;; {Run-time options} ;;; {Run-time options}
;;; ;;;
(defmacro define-option-interface (option-group) (define-syntax define-option-interface
(let* ((option-name 'car) (syntax-rules ()
(option-value 'cadr) ((_ (interface (options enable disable) (option-set!)))
(option-documentation 'caddr) (begin
(define options
;; Below follow the macros defining the run-time option interfaces. (case-lambda
(() (interface))
(make-options (lambda (interface) ((arg)
`(lambda args (if (list? arg)
(cond ((null? args) (,interface)) (begin (interface arg) (interface))
((list? (car args)) (for-each
(,interface (car args)) (,interface)) (lambda (option)
(else (for-each (apply (lambda (name value documentation)
(lambda (option) (display name)
(display (,option-name option)) (if (< (string-length (symbol->string name)) 8)
(if (< (string-length (display #\tab))
(symbol->string (,option-name option))) (display #\tab)
8) (display value)
(display #\tab)) (display #\tab)
(display #\tab) (display documentation)
(display (,option-value option)) (newline))
(display #\tab) option))
(display (,option-documentation option)) (interface #t))))))
(newline)) (define (enable . flags)
(,interface #t))))))) (interface (append flags (interface)))
(interface))
(make-enable (lambda (interface) (define (disable . flags)
`(lambda flags (let ((options (interface)))
(,interface (append flags (,interface))) (for-each (lambda (flag) (set! options (delq! flag options)))
(,interface)))) flags)
(interface options)
(make-disable (lambda (interface) (interface)))
`(lambda flags (define-syntax option-set!
(let ((options (,interface))) (syntax-rules ()
(for-each (lambda (flag) ((_ opt val)
(set! options (delq! flag options))) (options (append (options) (list 'opt val))))))))))
flags)
(,interface options)
(,interface))))))
(let* ((interface (car option-group))
(options/enable/disable (cadr option-group)))
`(begin
(define ,(car options/enable/disable)
,(make-options interface))
(define ,(cadr options/enable/disable)
,(make-enable interface))
(define ,(caddr options/enable/disable)
,(make-disable interface))
(defmacro ,(caaddr option-group) (opt val)
`(,',(car options/enable/disable)
(append (,',(car options/enable/disable))
(list ',opt ,val))))))))
(define-option-interface (define-option-interface
(eval-options-interface (eval-options-interface