Emulate dynamic-wind and reset/shift on Gauche

dynamic-test.scm

;;
;; 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)))