/usr/share/scsh-0.6/big/either.scm is in scsh-common-0.6 0.6.7-8.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 | ; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Nondeterminism, Prolog, or whatever you want to call it. This is
; depth-first search implemented using call/cc.
; The fluid variable $FAIL is bound to a thunk to be called in case of failure.
(define $fail
(make-fluid (make-cell
(lambda ()
(error "call to FAIL outside WITH-NONDETERMINISM")))))
(define (with-nondeterminism thunk)
(let-fluid $fail
(make-cell (lambda ()
(error "nondeterminism ran out of choices")))
thunk))
; Call the current failure function.
(define (fail)
((fluid-cell-ref $fail)))
; 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 ...))))))
; 1. Save the current failure procedure and continuation.
; 2. Install a new failure procedure that restores the old failure procedure
; and continuation and then calls THUNK2.
; 3. Call THUNK1.
(define (%either thunk1 thunk2)
(let ((save (fluid-cell-ref $fail)))
((call-with-current-continuation
(lambda (k)
(fluid-cell-set! $fail
(lambda ()
(fluid-cell-set! $fail save)
(k thunk2)))
thunk1)))))
; (one-value x) is Prolog's CUT operator. X is allowed to return only once.
(define-syntax one-value
(syntax-rules ()
((one-value x) (%one-value (lambda () x)))))
(define (%one-value thunk)
(let ((save (fluid-cell-ref $fail)))
(call-with-values thunk
(lambda args
(fluid-cell-set! $fail save)
(apply values args)))))
; (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))))
|