This repository has been archived on 2022-08-10. You can view files and clone it, but cannot push or open issues or pull requests.
chez-openbsd/s/cafe.ss
2022-07-29 15:12:07 +02:00

218 lines
8.1 KiB
Scheme

;;; cafe.ss
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
(begin
(define default-prompt-and-read
(lambda (n)
(unless (and (integer? n) (>= n 0))
($oops 'default-prompt-and-read
"~s is not a nonnegative integer"
n))
(let ([prompt (waiter-prompt-string)])
(unless (string=? prompt "")
(do ([n n (- n 1)])
((= n 0)
(write-char #\space (console-output-port))
(flush-output-port (console-output-port)))
(display prompt (console-output-port))))
(let ([x (read (console-input-port))])
(when (and (eof-object? x) (not (string=? prompt "")))
(newline (console-output-port))
(flush-output-port (console-output-port)))
x))))
(define waiter-prompt-and-read
($make-thread-parameter
default-prompt-and-read
(lambda (p)
(unless (procedure? p)
($oops 'waiter-prompt-and-read "~s is not a procedure" p))
p)))
(define waiter-write
($make-thread-parameter
(lambda (x)
(unless (eq? x (void))
(pretty-print x (console-output-port)))
(flush-output-port (console-output-port)))
(lambda (p)
(unless (procedure? p)
($oops 'waiter-write "~s is not a procedure" p))
p)))
(define waiter-prompt-string
($make-thread-parameter
">"
(lambda (s)
(unless (string? s)
($oops 'waiter-prompt-string "~s is not a string" s))
s)))
(define new-cafe)
(let ()
(define-threaded waiter-expr)
(define-threaded waiter-stat1)
(define-threaded waiter-stat2)
(define-threaded waiter-total-stats)
(define sstats-sum
(lambda (a b)
(define sstats-time-add
(lambda (f a b)
(add-duration (f a) (f b))))
(make-sstats
(sstats-time-add sstats-cpu a b)
(sstats-time-add sstats-real a b)
(+ (sstats-bytes a) (sstats-bytes b))
(+ (sstats-gc-count a) (sstats-gc-count b))
(sstats-time-add sstats-gc-cpu a b)
(sstats-time-add sstats-gc-real a b)
(+ (sstats-gc-bytes a) (sstats-gc-bytes b)))))
(define waiter
(lambda (cafe eval)
(let ([x ((waiter-prompt-and-read) cafe)])
(when (eof-object? x) (exit))
(fluid-let ([waiter-total-stats (make-sstats
(make-time 'time-duration 0 0)
(make-time 'time-duration 0 0)
0
0
(make-time 'time-duration 0 0)
(make-time 'time-duration 0 0)
0)]
[waiter-expr x]
[waiter-stat1 (void)]
[waiter-stat2 (void)])
(dynamic-wind #t
(lambda ()
(set! waiter-stat1 (statistics))
(set! waiter-stat2 (statistics)))
(lambda ()
(parameterize ([$interrupt waiter-interrupt])
(top-level eval x)))
(lambda ()
(let ([s (statistics)])
(set! waiter-total-stats
(sstats-sum (sstats-difference
(sstats-difference s waiter-stat2)
(sstats-difference waiter-stat2
waiter-stat1))
waiter-total-stats)))))))
(waiter cafe eval)))
; This marks the "top-level" continuation for the debugger
(define top-level
(lambda (eval x)
(call/cc ; grab continuation & start a new stack segment
(rec new-cafe
(lambda (k)
($current-stack-link $null-continuation) ; toss what's below
(call-with-values
(lambda () (eval x))
(lambda args (for-each (waiter-write) args)))
(k))))))
(define waiter-interrupt
(lambda ()
(call/cc
(lambda (k)
(parameterize ([$interrupt void])
(let ([s (statistics)])
(set! waiter-total-stats
(sstats-sum (sstats-difference
(sstats-difference s waiter-stat2)
(sstats-difference waiter-stat2
waiter-stat1))
waiter-total-stats)))
(clear-input-port (console-input-port))
(let ([waiter (call/cc
(lambda (k)
(rec f (lambda () (k f)))))])
(fprintf (console-output-port) "break> ")
(flush-output-port (console-output-port))
(case (let ([x (parameterize ([$interrupt waiter]
[reset-handler waiter])
(read (console-input-port)))])
(if (eof-object? x)
(begin (newline (console-output-port))
(flush-output-port (console-output-port))
'exit)
x))
[(exit e)
(void)]
[(statistics s)
(parameterize ([print-level 2] [print-length 2])
(fprintf (console-output-port)
"(time ~s)~%"
waiter-expr))
(sstats-print waiter-total-stats (console-output-port))
(flush-output-port (console-output-port))
(waiter)]
[(reset r quit q)
(reset)]
[(abort a)
(abort)]
[(new-cafe n)
(new-cafe)
(waiter)]
[(inspect i)
(inspect k)
(waiter)]
[(?)
(fprintf (console-output-port) "
Type e to exit interrupt handler and continue
r or q to reset scheme
a to abort scheme
n to enter new cafe
i to inspect current continuation
s to display statistics
")
(flush-output-port (console-output-port))
(waiter)]
[else
(fprintf (console-output-port)
"Invalid command. Type ? for options.~%")
(flush-output-port (console-output-port))
(waiter)]))
(set! waiter-stat1 (statistics))
(set! waiter-stat2 (statistics)))))))
(set! $cafe ($make-thread-parameter 0))
(set! new-cafe
(let ()
(rec new-cafe
(case-lambda
[() (new-cafe eval)]
[(eval)
(unless (procedure? eval)
($oops 'new-cafe "~s is not a procedure" eval))
(call/cc
(lambda (k1)
(parameterize ([exit-handler k1] [reset-handler (reset-handler)])
(let ((k2 k1))
(reset-handler (lambda () (k2)))
(call/cc (lambda (k) (set! k2 k)))
(parameterize ([$cafe (+ ($cafe) 1)] [$interrupt reset])
(with-exception-handler
(lambda (c) ((base-exception-handler) c))
(lambda ()
(waiter ($cafe) eval))))))))]))))
)
)