scsh-0.6/scheme/misc/either.scm

91 lines
2.1 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Internal variable representing the failure stack.
(define (fail) (*fail*))
(define *fail* (lambda () (error "You didn't do (init).")))
; For the alternation operator, Icon's a | b or McCarthy's (amb a b),
; we write (either a b).
(define-syntax either
(syntax-rules ()
((either) (fail))
((either x) x)
((either x y ...)
(%either (lambda () x) (lambda () (either y ...))))))
(define (%either thunk1 thunk2) ;Macro auxiliary
(saving-failure-state
(lambda (restore)
((call-with-current-continuation
(lambda (k)
(set! *fail*
(lambda ()
(restore)
(k thunk2)))
thunk1))))))
(define (saving-failure-state proc)
(let ((save *fail*))
(proc (lambda () (set! *fail* save)))))
; (one-value x) is Prolog's CUT operator
(define-syntax one-value
(syntax-rules ()
((one-value x) (%one-value (lambda () x)))))
(define (%one-value thunk)
(saving-failure-state
(lambda (restore)
(let ((value (thunk)))
(restore)
value))))
; (all-values a) returns a list of all the possible values of the
; expression a. Prolog calls this "bagof"; I forget what Icon calls it.
(define-syntax all-values
(syntax-rules ()
((all-values x) (%all-values (lambda () x)))))
(define (%all-values thunk)
(let ((results '()))
(either (let ((new-result (thunk)))
(set! results (cons new-result results))
(fail))
(reverse results))))
; Generate all the members of list l. E.g.
; (all-values (+ (member-of '(10 20 30)) (member-of '(1 2 3))))
; => '(11 12 13 21 22 23 31 32 33)
(define (member-of l)
(if (null? l)
(fail)
(either (car l) (member-of (cdr l)))))
; Crufty initialization hack that allows you to type failing
; expressions at the R-E-P loop (if there is an R-E-P loop). E.g. try
; evaluating the sequence
; (either 1 2)
; (fail)
; (+ (fail) 10)
(define (init)
(set! *fail* #f) ;for GC purposes
(either 'initialized
(let loop ()
(either 'failed (loop)))))
(display "Type (init) at the read-eval-print loop.")
(newline)