Skip to content

Instantly share code, notes, and snippets.

@Hamayama Hamayama/dynamic-test.scm
Last active Nov 13, 2019

Embed
What would you like to do?
Emulate dynamic-wind and reset/shift on Gauche
;;
;; dynamic-test.scm
;; 2019-8-4 v1.15
;;
;; Emulate dynamic-wind and reset/shift on Gauche
;;
;; (emu-dynamic-wind before thunk after)
;; before is (^[] expr ...)
;; thunk is (^[] expr ...)
;; after is (^[] expr ...)
;;
;; (emu-call/cc proc)
;; proc is (^[k] expr ...) and k is full continuation
;;
;; (emu-call/pc proc)
;; proc is (^[k] expr ...) and k is partial continuation
;;
;; (emu-reset expr ...)
;;
;; (emu-shift k expr ...)
;; this is equivalent to (emu-call/pc (^[k] expr ...))
;;
;; (emu-parameterize ((param val) ...) body ...)
;; param is parameter
;;
(use gauche.partcont)
(use gauche.parameter)
(use gauche.test)
(define *dynamic-chain* '()) ; list of dynamic-point
(define *reset-chain* '()) ; list of reset-point
(define-class <reset-point> () ((dynamic-chain)))
(define *dbg-level* 1) ; (=0:none, =1:waning, =3:verbose, =4:special)
(define (dbg-print dbg-level . args)
(when (logtest *dbg-level* dbg-level)
(apply format (current-error-port) args)))
(define (dbg-print-dc-rc dbg-level)
(dbg-print dbg-level " d-chain=~s~%" (map (^[dp] (list-ref dp 2)) *dynamic-chain*))
(dbg-print dbg-level " r-point-length=~s~%" (length *reset-chain*)))
(define (emu-dynamic-wind before thunk after :optional (dbg-name "emu-dynamic-wind"))
(letrec* ([dc-old *dynamic-chain*]
[count1 0]
[count2 0]
[dbg-id (gensym)]
[before1 (^[] (inc! count1)
(dbg-print 2 "~a~s before ~s~%" dbg-name dbg-id count1)
(before))]
[after1 (^[] (inc! count2)
(dbg-print 2 "~a~s after ~s~%" dbg-name dbg-id count2)
(when (> count2 count1)
(dbg-print 1 "warning emu-dynamic-wind ~a (~s ~s)~%" dbg-name count1 count2)
(dbg-print-dc-rc 1))
(after))]
[winder (list before1 after1 dbg-name)])
;; run before -> thunk -> after
(before1)
(push! *dynamic-chain* winder)
(receive ret (thunk)
;(pop! *dynamic-chain*)
(set! *dynamic-chain* dc-old)
(after1)
(apply values ret))))
(define (%travel dp-from dp-to)
(define (common-tail x y)
(let ([lx (length x)] [ly (length y)])
(let loop ([x (if (> lx ly) (list-tail x (- lx ly)) x)]
[y (if (> ly lx) (list-tail y (- ly lx)) y)])
(if (eq? x y)
x
(loop (cdr x) (cdr y))))))
(let ([tail (common-tail dp-from dp-to)])
;; call afters and update *dynamic-chain*
(let loop ([dp dp-from])
(unless (eq? dp tail)
(set! *dynamic-chain* (cdr dp))
(dbg-print 2 "travel after: ")
((cadr (car dp)))
(loop (cdr dp))))
;; call befores and update *dynamic-chain*
(let loop ([dp dp-to])
(unless (eq? dp tail)
(loop (cdr dp))
(dbg-print 2 "travel before: ")
((car (car dp)))
(set! *dynamic-chain* dp)))))
(define (%dc-cut dp-from dp-to)
(let loop ([ret '()] [dc dp-to])
(if (or (null? dc) (eq? dc dp-from))
(reverse ret)
(loop (cons (car dc) ret) (cdr dc)))))
(define (emu-call/cc proc)
(let ([dp-cc *dynamic-chain*])
(call/cc
(^[real-k]
(let ([emu-k (^ args (%travel *dynamic-chain* dp-cc)
(apply real-k args))])
(proc emu-k))))))
(define (%emu-reset thunk :optional (dbg-name "%emu-reset"))
(let ([rp (make <reset-point>)])
(emu-dynamic-wind
(^[] (push! *reset-chain* rp))
(^[] (set! (~ rp 'dynamic-chain) *dynamic-chain*)
(reset(thunk)))
(^[] (pop! *reset-chain*))
"%emu-reset")))
(define-syntax emu-reset
(syntax-rules (:name)
[(_ :name dbg-name expr ...)
(%emu-reset (^[] expr ...) dbg-name)]
[(_ expr ...)
(%emu-reset (^[] expr ...))]))
(define (emu-call/pc proc)
(when (null? *reset-chain*) (error "reset missing."))
(let* ([rp (car *reset-chain*)]
[dp-reset (~ rp 'dynamic-chain)]
[dp-pc *dynamic-chain*]
[dc-part (%dc-cut dp-reset dp-pc)])
((with-module gauche.internal %call/pc)
(^[real-k]
(let ([emu-k (^ args (emu-dynamic-wind
(^[] (%travel *dynamic-chain* (append dc-part *dynamic-chain*)))
(^[] (emu-reset :name "emu-reset-1"
(apply real-k args)))
(^[] )
"emu-k"))])
(emu-dynamic-wind
(^[] )
(^[] (proc emu-k))
(^[] (%travel *dynamic-chain* dp-reset))
"emu-call/pc"))))))
(define-syntax emu-shift
(syntax-rules ()
[(_ k expr ...)
(emu-call/pc (^[k] expr ...))]))
(define-syntax emu-parameterize
(syntax-rules ()
[(_ ((param val) ...) body ...)
(let ([params (list param ...)]
[vals1 (list val ...)]
[vals2 (list val ...)])
(emu-dynamic-wind
(^[] (set! vals2 (map (^[p v] (p v)) params vals1)))
(^[] body ...)
(^[] (set! vals1 (map (^[p v] (p v)) params vals2)))
"emu-parameterize"))]))
;; ***** test - parameterize *****
(when #t
(test* "parameterize 1"
"[p01][p02][p01]"
(with-output-to-string
(^[]
(define p (make-parameter "[p01]"))
(display (p))
(emu-parameterize ([p "[p02]"])
(display (p)))
(display (p)))))
(dbg-print-dc-rc 4)
)
;; ***** test - reset/shift *****
(when #t
(test* "reset/shift 1"
10
(+ 1 (emu-reset
(+ 2 (emu-shift k (+ 3 (k 4)))))))
(dbg-print-dc-rc 4)
(test* "reset/shift 2"
'(1 2)
(emu-reset
(emu-shift k1 (cons 1 (k1)))
(emu-shift k2 (cons 2 (k2)))
'()))
(dbg-print-dc-rc 4)
(test* "reset/shift 3"
1000
(begin
(define k1 #f)
(emu-reset
(emu-shift k (set! k1 k))
(emu-shift k 1000))
(k1)))
(dbg-print-dc-rc 4)
(test* "dynamic-wind + reset/shift 1"
"[d01][d02][d03][d04]"
(with-output-to-string
(^[]
(emu-reset
(emu-shift
k
(emu-dynamic-wind
(^[] (display "[d01]"))
(^[] (display "[d02]")
(k)
(display "[d03]"))
(^[] (display "[d04]"))))))))
(dbg-print-dc-rc 4)
(test* "dynamic-wind + reset/shift 2"
"[d01][d02][d04][d01][d03][d04]"
(with-output-to-string
(^[]
(define k1 #f)
(emu-reset
(emu-dynamic-wind
(^[] (display "[d01]"))
(^[] (display "[d02]")
(emu-shift k (set! k1 k))
(display "[d03]"))
(^[] (display "[d04]"))))
(k1))))
(dbg-print-dc-rc 4)
(test* "dynamic-wind + reset/shift 3"
"[d01][d02][d11][d12][d13][d14][d03][d04]"
(with-output-to-string
(^[]
(emu-reset
(emu-shift
k
(emu-dynamic-wind
(^[] (display "[d01]"))
(^[] (display "[d02]")
(emu-dynamic-wind
(^[] (display "[d11]"))
(^[] (display "[d12]")
(k)
(display "[d13]"))
(^[] (display "[d14]")))
(display "[d03]"))
(^[] (display "[d04]"))))))))
(dbg-print-dc-rc 4)
(test* "dynamic-wind + reset/shift 4"
"[d01][d02][d11][d12][d14][d04][d01][d11][d13][d14][d03][d04]"
(with-output-to-string
(^[]
(define k1 #f)
(emu-reset
(emu-dynamic-wind
(^[] (display "[d01]"))
(^[] (display "[d02]")
(emu-dynamic-wind
(^[] (display "[d11]"))
(^[] (display "[d12]")
(emu-shift k (set! k1 k))
(display "[d13]"))
(^[] (display "[d14]")))
(display "[d03]"))
(^[] (display "[d04]"))))
(k1))))
(dbg-print-dc-rc 4)
(test* "dynamic-wind + reset/shift 5"
"[d01][d02][d04][d11][d12][d01][d03][d04][d13][d14]"
(with-output-to-string
(^[]
(define k1 #f)
(emu-reset
(emu-dynamic-wind
(^[] (display "[d01]"))
(^[] (display "[d02]")
(emu-shift k (set! k1 k))
(display "[d03]"))
(^[] (display "[d04]"))))
(emu-dynamic-wind
(^[] (display "[d11]"))
(^[] (display "[d12]")
(k1)
(display "[d13]"))
(^[] (display "[d14]"))))))
(dbg-print-dc-rc 4)
)
;; ***** test - call/cc *****
(when #t
(test* "dynamic-wind"
"[d01][d02][d03][d04]"
(with-output-to-string
(^[]
(emu-dynamic-wind
(^[] (display "[d01]"))
(^[] (display "[d02]")
(display "[d03]"))
(^[] (display "[d04]"))))))
(dbg-print-dc-rc 4)
(test* "dynamic-wind + call/cc 1"
"[d01][d02][d04]"
(with-output-to-string
(^[]
(emu-call/cc
(^[k]
(emu-dynamic-wind
(^[] (display "[d01]"))
(^[] (display "[d02]")
(k)
(display "[d03]"))
(^[] (display "[d04]"))))))))
(dbg-print-dc-rc 4)
(test* "dynamic-wind + call/cc 2"
"[d01][d02][d03][d04][d01][d03][d04]"
(with-output-to-string
(^[]
(define k1 #f)
(define first-flag #t)
(emu-dynamic-wind
(^[] (display "[d01]"))
(^[] (display "[d02]")
(emu-call/cc (^[k] (set! k1 k)))
(display "[d03]"))
(^[] (display "[d04]")))
(when first-flag
(set! first-flag #f)
(k1)))))
(dbg-print-dc-rc 4)
(test* "dynamic-wind + call/cc 3"
"[d01][d02][d11][d12][d14][d04]"
(with-output-to-string
(^[]
(emu-call/cc
(^[k]
(emu-dynamic-wind
(^[] (display "[d01]"))
(^[] (display "[d02]")
(emu-dynamic-wind
(^[] (display "[d11]"))
(^[] (display "[d12]")
(k)
(display "[d13]"))
(^[] (display "[d14]")))
(display "[d03]"))
(^[] (display "[d04]"))))))))
(dbg-print-dc-rc 4)
(test* "dynamic-wind + call/cc 4"
"[d01][d02][d11][d12][d13][d14][d03][d04][d01][d11][d13][d14][d03][d04]"
(with-output-to-string
(^[]
(define k1 #f)
(define first-flag #t)
(emu-dynamic-wind
(^[] (display "[d01]"))
(^[] (display "[d02]")
(emu-dynamic-wind
(^[] (display "[d11]"))
(^[] (display "[d12]")
(emu-call/cc (^[k] (set! k1 k)))
(display "[d13]"))
(^[] (display "[d14]")))
(display "[d03]"))
(^[] (display "[d04]")))
(when first-flag
(set! first-flag #f)
(k1)))))
(dbg-print-dc-rc 4)
(test* "dynamic-wind + call/cc 5"
"[d01][d02][d03][d04][d11][d12][d14][d01][d03][d04][d11][d12][d13][d14]"
(with-output-to-string
(^[]
(define k1 #f)
(define first-flag #t)
(emu-dynamic-wind
(^[] (display "[d01]"))
(^[] (display "[d02]")
(emu-call/cc (^[k] (set! k1 k)))
(display "[d03]"))
(^[] (display "[d04]")))
(emu-dynamic-wind
(^[] (display "[d11]"))
(^[] (display "[d12]")
(when first-flag
(set! first-flag #f)
(k1))
(display "[d13]"))
(^[] (display "[d14]"))))))
(dbg-print-dc-rc 4)
)
;; summary
(format (current-error-port) "~%~a" ((with-module gauche.test format-summary)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.