mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +02:00
Code Activity

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

Browse source 
* boot-9.scm: Define options interface procedures here instead.
This commit is contained in:
Mikael Djurfeldt 1997-09-28 20:12:17 +00:00
parent f6a2912315
commit 83b381985d
3 changed files with 94 additions and 89 deletions
Download patch file Download diff file Expand all files Collapse all files

6
ice-9/ChangeLog
View file

@ -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,

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

@ -2198,6 +2198,94 @@
;;; {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)))))))
;;; {Running Repls}
;;;

89
ice-9/debug.scm
View file

@ -22,95 +22,6 @@
(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 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)
;;; {Misc}
;;;