* debug.scm: Moved options interface procedures to boot-9.scm.

* boot-9.scm: Define options interface procedures here instead.

diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog
index a73ef26..abde664 100644 (file)
--- a/ice-9/ChangeLog
+++ b/ice-9/ChangeLog
@@ -1,3 +1,9 @@
+Sun Sep 28 21:40:24 1997  Mikael Djurfeldt  <mdj@mdj.nada.kth.se>
+
+       * debug.scm: Moved options interface procedures to boot-9.scm.
+
+       * boot-9.scm: Define options interface procedures here instead.
+
 Sat Sep 27 20:19:20 1997  Jim Blandy  <jimb@totoro.red-bean.com>
 
        * boot-9.scm (separate-fields-discarding-char,

diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
index 2a2cb00..16d8041 100644 (file)
--- a/ice-9/boot-9.scm
+++ b/ice-9/boot-9.scm
@@ -2198,6 +2198,94 @@
 
 \f
 
+;;; {Run-time options}
+
+((let* ((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!))
+                ))
+       (option-name car)
+       (option-value cadr)
+       (option-documentation caddr)
+
+       (print-option (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)))
+
+       ;; Below follows the macros defining the run-time option interfaces.
+
+       (make-options (lambda (interface)
+                       `(lambda args
+                          (cond ((null? args) (,interface))
+                                ((pair? (car args))
+                                 (,interface (car args)) (,interface))
+                                (else (for-each print-option
+                                                (,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)))))
+
+       (make-set! (lambda (interface)
+                    `((name exp)
+                      (,'quasiquote
+                       (begin (,interface (append (,interface)
+                                                  (list '(,'unquote name)
+                                                        (,'unquote exp))))
+                              (,interface))))))
+       )
+   (procedure->macro
+     (lambda (exp env)
+       (cons 'begin
+            (apply append
+                   (map (lambda (group)
+                          (let ((interface (car group)))
+                            (append (map (lambda (name constructor)
+                                           `(define ,name
+                                              ,(constructor interface)))
+                                         (cadr group)
+                                         (list make-options
+                                               make-enable
+                                               make-disable))
+                                    (map (lambda (name constructor)
+                                           `(defmacro ,name
+                                              ,@(constructor interface)))
+                                         (caddr group)
+                                         (list make-set!)))))
+                        names)))))))
+
+\f
+
 ;;; {Running Repls}
 ;;;
 

diff --git a/ice-9/debug.scm b/ice-9/debug.scm
index 1edd25a..99623a5 100644 (file)
--- a/ice-9/debug.scm
+++ b/ice-9/debug.scm
@@ -23,95 +23,6 @@
 (define-module (ice-9 debug))
 
 \f
-
-;;; {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 flags (,interface)))
-     (,interface)))
-
-(define (make-disable interface)
-  `(lambda flags
-     (let ((options (,interface)))
-       (for-each (lambda (flag)
-                  (set! options (delq! flag options)))
-                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)
-
-\f
 ;;; {Misc}
 ;;;
 (define-public (frame-number->index n)