123 lines
3.2 KiB
Scheme
123 lines
3.2 KiB
Scheme




(library (ikarus control)


(export call/cf call/cc callwithcurrentcontinuation dynamicwind exit)


(import


(ikarus system $stack)


(except (ikarus) call/cf call/cc callwithcurrentcontinuation


dynamicwind exit listtail))




(define primitivecall/cf


(lambda (f)


(if ($fpatbase)


(f ($currentframe))


($sealframeandcall f))))




(define call/cf


(lambda (f)


(if (procedure? f)


(primitivecall/cf f)


(error 'call/cf "~s is not a procedure" f))))




(define primitivecall/cc


(lambda (f)


(primitivecall/cf


(lambda (frm)


(f ($frame>continuation frm))))))




(define winders '())




(define len


(lambda (ls n)


(if (null? ls)


n


(len (cdr ls) (fxadd1 n)))))




(define listtail


(lambda (ls n)


(if (fxzero? n)


ls


(listtail (cdr ls) (fxsub1 n)))))




(define dropuncommonheads


(lambda (x y)


(if (eq? x y)


x


(dropuncommonheads (cdr x) (cdr y)))))




(define commontail


(lambda (x y)


(let ([lx (len x 0)] [ly (len y 0)])


(let ([x (if (fx> lx ly) (listtail x (fx lx ly)) x)]


[y (if (fx> ly lx) (listtail y (fx ly lx)) y)])


(if (eq? x y)


x


(dropuncommonheads (cdr x) (cdr y)))))))




(define unwind*


(lambda (ls tail)


(unless (eq? ls tail)


(set! winders (cdr ls))


((cdar ls))


(unwind* (cdr ls) tail))))




(define rewind*


(lambda (ls tail)


(unless (eq? ls tail)


(rewind* (cdr ls) tail)


((caar ls))


(set! winders ls))))




(define dowind


(lambda (new)


(let ([tail (commontail new winders)])


(unwind* winders tail)


(rewind* new tail))))




(define call/cc


(lambda (f)


(unless (procedure? f)


(error 'call/cc "~s is not a procedure" f))


(primitivecall/cc


(lambda (k)


(let ([save winders])


(f (caselambda


[(v) (unless (eq? save winders) (dowind save)) (k v)]


[() (unless (eq? save winders) (dowind save)) (k)]


[(v1 v2 . v*)


(unless (eq? save winders) (dowind save))


(apply k v1 v2 v*)])))))))




(define callwithcurrentcontinuation


(lambda (f)


(unless (procedure? f)


(error 'callwithcurrentcontinuation


"~s is not a procedure" f))


(call/cc f)))




(define dynamicwind


(lambda (in body out)


(unless (procedure? in)


(error 'dynamicwind "~s is not a procedure" in))


(unless (procedure? body)


(error 'dynamicwind "~s is not a procedure" body))


(unless (procedure? out)


(error 'dynamicwind "~s is not a procedure" out))


(in)


(set! winders (cons (cons in out) winders))


(callwithvalues


body


(caselambda


[(v) (set! winders (cdr winders)) (out) v]


[() (set! winders (cdr winders)) (out) (values)]


[(v1 v2 . v*)


(set! winders (cdr winders))


(out)


(apply values v1 v2 v*)]))))




(define exit


(caselambda


[() (exit 0)]


[(status) (foreigncall "exit" status)]))


)
