mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 21:10:27 +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}
;;;
(defmacro define-option-interface (option-group)
(let* ((option-name 'car)
(option-value 'cadr)
(option-documentation 'caddr)
;; Below follow the macros defining the run-time option interfaces.
(make-options (lambda (interface)
`(lambda args
(cond ((null? args) (,interface))
((list? (car args))
(,interface (car args)) (,interface))
(else (for-each
(lambda (option)
(display (,option-name option))
(if (< (string-length
(symbol->string (,option-name option)))
8)
(display #\tab))
(display #\tab)
(display (,option-value option))
(display #\tab)
(display (,option-documentation option))
(newline))
(,interface #t)))))))
(make-enable (lambda (interface)
`(lambda flags
(,interface (append flags (,interface)))
(,interface))))
(make-disable (lambda (interface)
`(lambda flags
(let ((options (,interface)))
(for-each (lambda (flag)
(set! options (delq! flag options)))
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-syntax define-option-interface
(syntax-rules ()
((_ (interface (options enable disable) (option-set!)))
(begin
(define options
(case-lambda
(() (interface))
((arg)
(if (list? arg)
(begin (interface arg) (interface))
(for-each
(lambda (option)
(apply (lambda (name value documentation)
(display name)
(if (< (string-length (symbol->string name)) 8)
(display #\tab))
(display #\tab)
(display value)
(display #\tab)
(display documentation)
(newline))
option))
(interface #t))))))
(define (enable . flags)
(interface (append flags (interface)))
(interface))
(define (disable . flags)
(let ((options (interface)))
(for-each (lambda (flag) (set! options (delq! flag options)))
flags)
(interface options)
(interface)))
(define-syntax option-set!
(syntax-rules ()
((_ opt val)
(options (append (options) (list 'opt val))))))))))
(define-option-interface
(eval-options-interface