1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
;;;; Copyright (C) 1996 Mikael Djurfeldt
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;;
;;;; The author can be reached at djurfeldt@nada.kth.se
;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
;;;;
(define-module #/ice-9/debug)
;;; {Run-time options}
(define names '((debug-options-interface
(debug-options debug-enable debug-disable)
(debug-set!))
(evaluator-traps-interface
(traps trap-enable trap-disable)
(trap-set!))
(read-options-interface
(read-options read-enable read-disable)
(read-set!))
(print-options-interface
(print-options print-enable print-disable)
(print-set!))
))
(define option-name car)
(define option-value cadr)
(define option-documentation caddr)
(define (print-option 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))
;;; Below follows the macros defining the run-time option interfaces.
;;; *fixme* These should not be macros, but need to be until module
;;; system is improved.
;;;
(define (make-options interface)
`(lambda args
(cond ((null? args) (,interface))
((pair? (car args)) (,interface (car args)) (,interface))
(else (for-each print-option (,interface #t))))))
(define (make-enable interface)
`(lambda flags
(,interface (append (if (pair? flags)
flags
(list flags))
(,interface)))
(,interface)))
(define (make-disable interface)
`(lambda flags
(let ((options (,interface)))
(for-each (lambda (flag)
(set! options (delq! flag options)))
(if (pair? flags) flags (list flags)))
(,interface options)
(,interface))))
(define (make-set! interface)
`((name exp)
(,'quasiquote
(begin (,interface (append (,interface)
(list '(,'unquote name)
(,'unquote exp))))
(,interface)))))
(defmacro define-all ()
(cons 'begin
(apply append
(map (lambda (group)
(let ((interface (car group)))
(append (map (lambda (name constructor)
`(define-public ,name
,(constructor interface)))
(cadr group)
(list make-options
make-enable
make-disable))
(map (lambda (name constructor)
`(defmacro-public ,name
,@(constructor interface)))
(caddr group)
(list make-set!)))))
names))))
(define-all)
|