(define scheme-start

(make-parameter

(lambda fns (for-each load fns) (new-cafe))

(lambda (p)

(unless (procedure? p)

($oops 'scheme-start "~s is not a procedure" p))

p)))

(define scheme-script

(make-parameter

(lambda (fn . fns)

(command-line (cons fn fns))

(command-line-arguments fns)

(load fn))

(lambda (p)

(unless (procedure? p)

($oops 'scheme-script "~s is not a procedure" p))

p)))

(define scheme-program

(make-parameter

(lambda (fn . fns)

(command-line (cons fn fns))

(command-line-arguments fns)

(load-program fn))

(lambda (p)

(unless (procedure? p)

($oops 'scheme-program "~s is not a procedure" p))

p)))

(define command-line-arguments

(make-parameter

'()

(lambda (x)

(unless (and (list? x) (andmap string? x))

($oops 'command-line-arguments "~s is not a list of strings" x))

x)))

(define command-line

(make-parameter

'("")

(lambda (x)

(unless (and (list? x) (not (null? x)) (andmap string? x))

($oops 'command-line "~s is not a nonempty list of strings" x))

x)))

(define-who #(r6rs: command-line)

(lambda ()

(#2%command-line)))

(define-who bytes-allocated

(let ([ba (foreign-procedure "(cs)bytes_allocated"

(scheme-object scheme-object)

scheme-object)])

(define filter-generation

(lambda (g)

(cond

[(and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) g]

[(eq? g 'static) (constant static-generation)]

[else ($oops who "invalid generation ~s" g)])))

(define filter-space

(lambda (s)

(cond

[(assq s (constant real-space-alist)) => cdr]

[else ($oops who "invalid space ~s" s)])))

(case-lambda

[() (ba -1 -1)]

[(g) (ba (filter-generation g) -1)]

[(g s) (ba (if g (filter-generation g) -1) (if s (filter-space s) -1))])))

(define $spaces (lambda () (map car (constant real-space-alist))))

(define current-memory-bytes (foreign-procedure "(cs)curmembytes" () uptr))

(define maximum-memory-bytes (foreign-procedure "(cs)maxmembytes" () uptr))

(define reset-maximum-memory-bytes! (foreign-procedure "(cs)resetmaxmembytes" () void))

(define-who with-source-path

(lambda (whoarg fn p)

(unless (or (eq? whoarg #f) (string? whoarg) (symbol? whoarg)) ($oops who "invalid who argument ~s" whoarg))

(unless (procedure? p) ($oops who "~s is not a procedure" p))

(unless (string? fn) ($oops whoarg "~s is not a string" fn))

(let ([dirs (source-directories)])

(if (or (equal? dirs '("")) (equal? dirs '(".")) ($fixed-path? fn))

(p fn)

(let loop ([ls dirs])

(if (null? ls)

($oops whoarg "file ~s not found in source directories" fn)

(let ([path (let ([dir (car ls)])

(if (or (string=? dir "") (string=? dir "."))

fn

(format

(if (directory-separator?

(string-ref dir

(fx- (string-length dir) 1)))

"~a~a"

"~a/~a")

dir fn)))])

(if (guard (c [#t #f]) (close-input-port (open-input-file path)) #t)

(p path)

(loop (cdr ls))))))))))

(set! fasl-read

(let ()

(define $fasl-read (foreign-procedure "(cs)fasl_read" (ptr boolean ptr) ptr))

(define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr ptr) ptr))

(define (get-uptr p)

(let ([k (get-u8 p)])

(let f ([k k] [n (fxsrl k 1)])

(if (fxlogbit? 0 k)

(let ([k (get-u8 p)])

(f k (logor (ash n 7) (fxsrl k 1))))

n))))

(define (malformed p) ($oops "malformed fasl-object header found in ~s" p))

(define (check-header p)

(let ([bv (make-bytevector 8 (constant fasl-type-header))])

(unless (and (eqv? (get-bytevector-n! p bv 1 7) 7)

(bytevector=? bv (constant fasl-header)))

(malformed p)))

(let ([n (get-uptr p)])

(unless (= n (constant scheme-version))

($oops 'fasl-read "incompatible fasl-object version ~a found in ~s"

($format-scheme-version n) p)))

(let ([n (get-uptr p)])

(unless (or (= n (constant machine-type-any)) (= n (constant machine-type)))

(cond

[(assv n (constant machine-type-alist)) =>

(lambda (a)

($oops 'fasl-read "incompatible fasl-object machine-type ~s found in ~s"

(cdr a) p))]

[else (malformed p)])))

(unless (and (eqv? (get-u8 p) (char->integer #\()) ;)

(let f ()

(let ([n (get-u8 p)])

(and (not (eof-object? n)) ;(

(or (eqv? n (char->integer #\))) (f))))))

(malformed p)))

(lambda (p)

(unless (and (input-port? p) (binary-port? p))

($oops 'fasl-read "~s is not a binary input port" p))

(if (and ($port-flags-set? p (constant port-flag-file))

(eqv? (binary-port-input-count p) 0))

($fasl-read ($port-info p)

($port-flags-set? p (constant port-flag-compressed))

(port-name p))

(let fasl-entry ()

(let ([ty (get-u8 p)])

(cond

[(eof-object? ty) ty]

[(eqv? ty (constant fasl-type-header))

(check-header p)

(fasl-entry)]

[(eqv? ty (constant fasl-type-fasl-size))

($bv-fasl-read (get-bytevector-n p (get-uptr p)) (port-name p))]

[else (malformed p)])))))))

(define ($compiled-file-header? ip)

(let ([pos (port-position ip)])

(let ([cfh? (let* ([bv (constant fasl-header)] [n (bytevector-length bv)])

(let f ([i 0])

(or (fx= i n)

(and (eqv? (get-u8 ip) (bytevector-u8-ref bv i))

(f (fx+ i 1))))))])

(set-port-position! ip pos)

cfh?)))

(let ()

(define do-load-binary

(lambda (who fn ip situation for-import?)

(module (Lexpand? visit-stuff? visit-stuff-inner revisit-stuff? revisit-stuff-inner

recompile-info? library/ct-info? library/rt-info? program-info?)

(import (nanopass))

(include "base-lang.ss")

(include "expand-lang.ss"))

(define unexpected-value!

(lambda (x)

($oops who "unexpected value ~s read from ~a" x fn)))

(let loop ()

(let ([x (fasl-read ip)])

(define run-inner

(lambda (x)

(cond

[(procedure? x) (x)]

[(library/rt-info? x) ($install-library/rt-desc x for-import? fn)]

[(library/ct-info? x) ($install-library/ct-desc x for-import? fn)]

[(program-info? x) ($install-program-desc x)]

[else (unexpected-value! x)])))

(define run-outer

(lambda (x)

(cond

[(recompile-info? x) (void)]

[(revisit-stuff? x) (when (memq situation '(load revisit)) (run-inner (revisit-stuff-inner x)))]

[(visit-stuff? x) (when (memq situation '(load visit)) (run-inner (visit-stuff-inner x)))]

[else (run-inner x)])))

(cond

[(eof-object? x) (close-port ip)]

[(vector? x) (vector-for-each run-outer x) (loop)]

[(Lexpand? x) ($interpret-backend x situation for-import? fn) (loop)]

[else (run-outer x) (loop)])))))

(define (do-load who fn situation for-import? ksrc)

(let ([ip ($open-file-input-port who fn)])

(on-reset (close-port ip)

(let ([fp (let ([start-pos (port-position ip)])

(if (and (eqv? (get-u8 ip) (char->integer #\#))

(eqv? (get-u8 ip) (char->integer #\!))

(let ([b (get-u8 ip)]) (or (eqv? b (char->integer #\space)) (eqv? b (char->integer #\/)))))

(let loop ([fp 3])

(let ([b (get-u8 ip)])

(if (eof-object? b)

fp

(let ([fp (+ fp 1)])

(if (eqv? b (char->integer #\newline))

fp

(loop fp))))))

(begin (set-port-position! ip start-pos) 0)))])

(port-file-compressed! ip)

(if ($compiled-file-header? ip)

(do-load-binary who fn ip situation for-import?)

(begin

(when ($port-flags-set? ip (constant port-flag-compressed))

($oops who "missing header for compiled file ~s" fn))

(unless ksrc ($oops who "~a is not a compiled file" fn))

(unless (eqv? fp 0) (set-port-position! ip 0))

(let ([sfd ($source-file-descriptor fn ip (eqv? fp 0))])

(unless (eqv? fp 0) (set-port-position! ip fp))

; whack ip so on-reset close-port call above closes the text port

(set! ip (transcoded-port ip (current-transcoder)))

(ksrc ip sfd ($make-read ip sfd fp)))))))))

(set-who! load-program

(rec load-program

(case-lambda

[(fn) (load-program fn eval)]

[(fn ev)

(unless (procedure? ev) ($oops who "~s is not a procedure" ev))

(with-source-path who fn

(lambda (fn)

(do-load who fn 'load #f

(lambda (ip sfd do-read)

($set-port-flags! ip (constant port-flag-r6rs))

(let loop ([x* '()])

(let ([x (do-read)])

(if (eof-object? x)

(begin

(close-port ip)

(ev `(top-level-program ,@(reverse x*)))

(void))

(loop (cons x x*)))))))))])))

(set-who! load-library ; like load, but sets #!r6rs mode

(rec load-library

(case-lambda

[(fn) (load-library fn eval)]

[(fn ev)

(unless (procedure? ev) ($oops who "~s is not a procedure" ev))

(with-source-path who fn

(lambda (fn)

(do-load who fn 'load #f

(lambda (ip sfd do-read)

($set-port-flags! ip (constant port-flag-r6rs))

(let loop ()

(let ([x (do-read)])

(unless (eof-object? x)

(ev x)

(loop))))

(close-port ip)))))])))

(set! $load-library ; for syntax.ss load-library

; like load, but sets #!r6rs mode and does not use with-source-path,

; since syntax.ss load-library has already determined the path.

; adds fn's directory to source-directories

(lambda (fn situation)

(define who 'import)

(let ([fn (let ([host-fn (format "~a.~s" (path-root fn) (machine-type))])

(if (file-exists? host-fn) host-fn fn))])

(do-load who fn situation #t

(lambda (ip sfd do-read)

($set-port-flags! ip (constant port-flag-r6rs))

(parameterize ([source-directories (cons (path-parent fn) (source-directories))])

(let loop ()

(let ([x (do-read)])

(unless (eof-object? x)

(eval x)

(loop)))))

(close-port ip))))))

(set-who! load

(rec load

(case-lambda

[(fn) (load fn eval)]

[(fn ev)

(unless (procedure? ev) ($oops who "~s is not a procedure" ev))

(with-source-path who fn

(lambda (fn)

(do-load who fn 'load #f

(lambda (ip sfd do-read)

(let loop ()

(let ([x (do-read)])

(unless (eof-object? x)

(ev x)

(loop))))

(close-port ip)))))])))

(set! $visit

(lambda (who fn)

(do-load who fn 'visit #t #f)))

(set! $revisit

(lambda (who fn)

(do-load who fn 'revisit #t #f)))

(set-who! visit

(lambda (fn)

(do-load who fn 'visit #f #f)))

(set-who! revisit

(lambda (fn)

(do-load who fn 'revisit #f #f))))

(let ()

(module sstats-record (make-sstats sstats? sstats-cpu sstats-real

sstats-bytes sstats-gc-count sstats-gc-cpu

sstats-gc-real sstats-gc-bytes

set-sstats-cpu! set-sstats-real!

set-sstats-bytes! set-sstats-gc-count!

set-sstats-gc-cpu! set-sstats-gc-real!

set-sstats-gc-bytes!)

(define-record-type (sstats make-sstats sstats?)

(nongenerative #{sstats pfwch3jd8ts96giujpitoverj-0})

(sealed #t)

(fields

(mutable cpu sstats-cpu set-sstats-cpu!)

(mutable real sstats-real set-sstats-real!)

(mutable bytes sstats-bytes set-sstats-bytes!)

(mutable gc-count sstats-gc-count set-sstats-gc-count!)

(mutable gc-cpu sstats-gc-cpu set-sstats-gc-cpu!)

(mutable gc-real sstats-gc-real set-sstats-gc-real!)

(mutable gc-bytes sstats-gc-bytes set-sstats-gc-bytes!))

(protocol

(lambda (new)

(lambda (cpu real bytes gc-count gc-cpu gc-real gc-bytes)

(new cpu real bytes gc-count gc-cpu gc-real gc-bytes))))))

(define exact-integer? (lambda (x) (and (integer? x) (exact? x))))

(set-who! make-sstats

(lambda (cpu real bytes gc-count gc-cpu gc-real gc-bytes)

(define verify-time

(lambda (name x)

(unless (time? x)

($oops who "~s value ~s is not a time record" name x))))

(define verify-exact-integer

(lambda (name x)

(unless (exact-integer? x)

($oops who "~s value ~s is not an exact integer" name x))))

(import sstats-record)

(verify-time 'cpu cpu)

(verify-time 'real real)

(verify-exact-integer 'bytes bytes)

(verify-exact-integer 'gc-count gc-count)

(verify-time 'gc-cpu gc-cpu)

(verify-time 'gc-real gc-real)

(verify-exact-integer 'gc-bytes gc-bytes)

(make-sstats cpu real bytes gc-count gc-cpu gc-real gc-bytes)))

(set! sstats? (lambda (x) (import sstats-record) (sstats? x)))

(let ()

(define verify-sstats

(lambda (who x)

(import sstats-record)

(unless (sstats? x) ($oops who "~s is not an sstats record" x))))

(define verify-exact-integer

(lambda (who x)

(unless (exact-integer? x)

($oops who "~s is not an exact integer" x))))

(define verify-time

(lambda (who x)

(unless (time? x)

($oops who "~s is not a time record" x))))

(define-syntax field

(lambda (x)

(syntax-case x ()

[(_ name verify-arg)

(with-syntax ([sstats-name (construct-name #'sstats-record "sstats-" #'name)]

[set-sstats-name! (construct-name #'sstats-record "set-sstats-" #'name "!")])

#'(begin

(set-who! sstats-name

(lambda (x)

(import sstats-record)

(verify-sstats who x)

(sstats-name x)))

(set-who! set-sstats-name!

(lambda (x n)

(import sstats-record)

(verify-sstats who x)

(verify-arg who n)

(set-sstats-name! x n)))))])))

(field cpu verify-time)

(field real verify-time)

(field bytes verify-exact-integer)

(field gc-count verify-exact-integer)

(field gc-cpu verify-time)

(field gc-real verify-time)

(field gc-bytes verify-exact-integer)))

(define-who sstats-print

(rec sstats-print

(case-lambda

[(s) (sstats-print s (current-output-port))]

[(s port)

(unless (sstats? s)

($oops who "~s is not an sstats record" s))

(unless (and (output-port? port) (textual-port? port))

($oops who "~s is not a textual output port" port))

(let ([collections (sstats-gc-count s)]

[time->string

(lambda (x)

;; based on record-writer for ts in date.ss

(let ([sec (time-second x)] [nsec (time-nanosecond x)])

(if (and (< sec 0) (> nsec 0))

(format "-~d.~9,'0ds" (- -1 sec) (- 1000000000 nsec))

(format "~d.~9,'0ds" sec nsec))))])

(if (zero? collections)

(fprintf port

(time->string (sstats-cpu s))

(time->string (sstats-real s))

(sstats-bytes s))

(fprintf port

collections

(time->string (sstats-cpu s)) (time->string (sstats-gc-cpu s))

(time->string (sstats-real s)) (time->string (sstats-gc-real s))

(sstats-bytes s) (sstats-gc-bytes s))))])))

(define display-statistics

(case-lambda

[() (display-statistics (current-output-port))]

[(p)

(unless (and (output-port? p) (textual-port? p))

($oops 'display-statistics "~s is not a textual output port" p))

(sstats-print (statistics) p)]))

(define-who sstats-difference

(lambda (a b)

(unless (sstats? a)

($oops who "~s is not an sstats record" a))

(unless (sstats? b)

($oops who "~s is not an sstats record" b))

(let ([int-diff (lambda (f a b) (- (f a) (f b)))]

[time-diff (lambda (f a b) (time-difference (f a) (f b)))])

(make-sstats

(time-diff sstats-cpu a b)

(time-diff sstats-real a b)

(int-diff sstats-bytes a b)

(int-diff sstats-gc-count a b)

(time-diff sstats-gc-cpu a b)

(time-diff sstats-gc-real a b)

(int-diff sstats-gc-bytes a b)))))

(define collect-generation-radix

(make-parameter

4

(lambda (v)

(unless (and (fixnum? v) (fx< 0 v))

($oops 'collect-generation-radix "~s is not a positive fixnum" v))

v)))

(define $reset-protect

(lambda (body out)

((call/cc

(lambda (k)

(parameterize ([reset-handler

(lambda ()

(k (lambda ()

(out)

((reset-handler)))))])

(with-exception-handler

(lambda (c)

; would prefer not to burn bridges even for serious condition

; if the exception is continuable, but we have no way to know

; short of grubbing through the continuation

(if (serious-condition? c)

(k (lambda () (out) (raise c)))

(raise-continuable c)))

(lambda ()

(call-with-values body

(case-lambda

[(v) (lambda () v)]

[v* (lambda () (apply values v*))]))))))))))

(define exit-handler)

(define reset-handler)

(define abort-handler)

(let ([c-exit (foreign-procedure "(cs)c_exit" (integer-32) void)])

(define (integer-32? x)

(and (integer? x)

(exact? x)

(<= #x-80000000 x #x7fffffff)))

(set! exit-handler

($make-thread-parameter

(case-lambda

[() (c-exit 0)]

[(x . args) (c-exit (if (eqv? x (void)) 0 (if (integer-32? x) x -1)))])

(lambda (v)

(unless (procedure? v)

($oops 'exit-handler "~s is not a procedure" v))

v)))

(set! reset-handler

($make-thread-parameter

(lambda () (c-exit 0))

(lambda (v)

(unless (procedure? v)

($oops 'reset-handler "~s is not a procedure" v))

v)))

(set! abort-handler

($make-thread-parameter

(case-lambda

[() (c-exit -1)]

[(x) (c-exit (if (eqv? x (void)) 0 (if (integer-32? x) x -1)))])

(lambda (v)

(unless (procedure? v)

($oops 'abort-handler "~s is not a procedure" v))

v))))

(let ()

(define (unexpected-return who)

($oops who (format "unexpected return from ~s handler" who)))

(set-who! exit

(lambda args

(apply (exit-handler) args)

(unexpected-return who)))

(set-who! #(r6rs: exit)

(case-lambda

[() ((exit-handler)) (unexpected-return who)]

[(x) ((exit-handler) x) (unexpected-return who)]))

(set-who! reset

(lambda ()

((reset-handler))

(unexpected-return who)))

(set-who! abort

(case-lambda

[() ((abort-handler)) (unexpected-return who)]

[(x) ((abort-handler) x) (unexpected-return who)])))

(define $interrupt ($make-thread-parameter void))

(define $format-scheme-version

(lambda (n)

(if (= (logand n 255) 0)

(format "~d.~d"

(ash n -16)

(logand (ash n -8) 255))

(format "~d.~d.~d"

(ash n -16)

(logand (ash n -8) 255)

(logand n 255)))))

(define $scheme-version)

(define scheme-version-number

(lambda ()

(let ([n (constant scheme-version)])

(values

(ash n -16)

(logand (ash n -8) 255)

(logand n 255)))))

(define scheme-version

(let ([s #f])

(lambda ()

(unless s

(set! s

(format "~:[Petite ~;~]Chez Scheme Version ~a"

$compiler-is-loaded?

$scheme-version)))

s)))

(define petite?

(lambda ()

(not $compiler-is-loaded?)))

(define threaded?

(lambda ()

(if-feature pthreads #t #f)))

(define get-process-id (foreign-procedure "(cs)getpid" () integer-32))

(set! get-thread-id

(lambda ()

($tc-field 'threadno ($tc))))

(define-who sleep

(let ([fp (foreign-procedure "(cs)nanosleep" (ptr ptr) void)])

(lambda (t)

(unless (and (time? t) (eq? (time-type t) 'time-duration))

($oops who "~s is not a time record of type time-duration" t))

(fp (time-second t) (time-nanosecond t)))))

(define $scheme-greeting

(lambda ()

(format "~a\nCopyright 1984-2016 Cisco Systems, Inc.\n"

(scheme-version))))

(define $session-key #f)

(define $scheme-init)

(define $scheme)

(define $script)

(define $as-time-goes-by)

(define collect)

(define break-handler)

(define debug)

(let ()

(define debug-condition* '())

(module (docollect collect-init)

(define gc-trip 0)

(define gc-cpu (make-time 'time-collector-cpu 0 0))

(define gc-real (make-time 'time-collector-real 0 0))

(define gc-bytes 0)

(define gc-count 0)

(define start-bytes 0)

(define docollect

(let ([do-gc (foreign-procedure "(cs)do_gc" (int int) void)])

(lambda (p)

(with-tc-mutex

(unless (= $active-threads 1)

($oops 'collect "cannot collect when multiple threads are active"))

(let-values ([(trip g gtarget) (p gc-trip)])

(set! gc-trip trip)

(let ([cpu (current-time 'time-thread)] [real (current-time 'time-monotonic)])

(set! gc-bytes (+ gc-bytes (bytes-allocated)))

(when (collect-notify)

(fprintf (console-output-port)

"~%[collecting generation ~s into generation ~s..."

g gtarget)

(flush-output-port (console-output-port)))

(do-gc g gtarget)

($close-resurrected-files)

(when (collect-notify)

(fprintf (console-output-port) "done]~%")

(flush-output-port (console-output-port)))

(set! gc-bytes (- gc-bytes (bytes-allocated)))

(set! gc-cpu (add-duration gc-cpu (time-difference (current-time 'time-thread) cpu)))

(set! gc-real (add-duration gc-real (time-difference (current-time 'time-monotonic) real)))

(set! gc-count (1+ gc-count))))))))

(define collect-init

(lambda ()

(set! gc-trip 0)

(set! gc-cpu (make-time 'time-collector-cpu 0 0))

(set! gc-real (make-time 'time-collector-real 0 0))

(set! gc-count 0)

(set! gc-bytes 0)

(set! start-bytes (bytes-allocated))))

(set! $gc-real-time (lambda () gc-real))

(set! $gc-cpu-time (lambda () gc-cpu))

(set! initial-bytes-allocated (lambda () start-bytes))

(set! bytes-deallocated (lambda () gc-bytes))

(set! collections (lambda () gc-count))

(set! statistics

(lambda ()

(make-sstats

(current-time 'time-thread)

(current-time 'time-monotonic)

(+ (- (bytes-allocated) start-bytes) gc-bytes)

gc-count

gc-cpu

gc-real

gc-bytes))))

(set-who! collect

(let ()

(define collect0

(lambda ()

(docollect

(lambda (gct)

(let ([gct (+ gct 1)])

(let loop ([g (collect-maximum-generation)])

(if (= (modulo gct (expt (collect-generation-radix) g)) 0)

(if (fx= g (collect-maximum-generation))

(values 0 g g)

(values gct g (fx+ g 1)))

(loop (fx- g 1)))))))))

(define collect2

(lambda (g gtarget)

(docollect

(lambda (gct)

(values

; make gc-trip to look like we've just collected generation g

; w/o also having collected generation g+1

(if (fx= g (collect-maximum-generation))

0

(let ([gct (+ gct 1)])

(define (trip g)

(let ([n (expt (collect-generation-radix) g)])

(+ gct (modulo (- n gct) n))))

(let ([next (trip g)] [limit (trip (fx+ g 1))])

(if (< next limit) next (- limit 1)))))

g gtarget)))))

(case-lambda

[() (collect0)]

[(g)

(unless (and (fixnum? g) (fx<= 0 g (collect-maximum-generation)))

($oops who "invalid generation ~s" g))

(collect2 g (if (fx= g (collect-maximum-generation)) g (fx+ g 1)))]

[(g gtarget)

(unless (and (fixnum? g) (fx<= 0 g (collect-maximum-generation)))

($oops who "invalid generation ~s" g))

(unless (if (fx= g (collect-maximum-generation))

(or (eqv? gtarget g) (eq? gtarget 'static))

(or (eqv? gtarget g) (eqv? gtarget (fx+ g 1))))

($oops who "invalid target generation ~s for generation ~s" gtarget g))

(collect2 g (if (eq? gtarget 'static) (constant static-generation) gtarget))])))

(set! keyboard-interrupt-handler

($make-thread-parameter

(lambda ()

(clear-output-port (console-output-port))

(fresh-line (console-output-port))

(flush-output-port (console-output-port))

(($interrupt)))

(lambda (x)

(unless (procedure? x)

($oops 'keyboard-interrupt-handler "~s is not a procedure" x))

x)))

(let ()

(define register-scheme-signal

(foreign-procedure "(cs)register_scheme_signal" (iptr) void))

(define signal-alist '())

(set! register-signal-handler

(lambda (sig handler)

(unless (fixnum? sig)

($oops 'register-signal-handler "~s is not a fixnum" sig))

(unless (procedure? handler)

($oops 'register-signal-handler "~s is not a procedure" handler))

(critical-section

(register-scheme-signal sig)

(let ((a (assq sig signal-alist)))

(if a

(set-cdr! a handler)

(set! signal-alist (cons (cons sig handler) signal-alist)))))))

(set! $signal-interrupt-handler

(lambda (sig)

(let ((a (assq sig signal-alist)))

(unless a

($oops '$signal-interrupt-handler

"unexpected signal number ~d received~%"

sig))

((cdr a) sig)))))

(set! $scheme-init

(lambda ()

(set! debug-condition* '())

(collect-init)

($io-init)

(set! $session-key #f)

($interrupt reset)

($clear-pass-stats)

(enable-interrupts)))

(set! $scheme

(lambda (fns)

(define (go)

(call/cc

(lambda (k)

(parameterize ([abort-handler

(case-lambda [() (k -1)] [(x) (k x)])]

[exit-handler

(case-lambda [() (k (void))] [(x . args) (k x)])]

[reset-handler (lambda () (k -1))])

(apply (scheme-start) fns)))))

(unless (suppress-greeting)

(display ($scheme-greeting) (console-output-port))

(newline (console-output-port))

(flush-output-port (console-output-port)))

(if-feature expeditor

(if ($enable-expeditor) ($expeditor go) (go))

(go))))

(set! $script

(lambda (program? fn fns)

(define (go)

(call/cc

(lambda (k)

(parameterize ([abort-handler

(case-lambda [() (k -1)] [(x) (k x)])]

[exit-handler

(case-lambda [() (k (void))] [(x . args) (k x)])]

[reset-handler (lambda () (k -1))])

(apply (if program? (scheme-program) (scheme-script)) fn fns)))))

(if-feature expeditor

(if ($enable-expeditor) ($expeditor go) (go))

(go))))

(set! $as-time-goes-by

(lambda (e t)

(define sanitize

(lambda (s)

(define sanitize-time

(lambda (t)

(if (< (time-second t) 0)

(make-time 'time-duration 0 0)

t)))

(define sanitize-count

(lambda (n)

(max n 0)))

(make-sstats

(sanitize-time (sstats-cpu s))

(sanitize-time (sstats-real s))

(sanitize-count (sstats-bytes s))

(sanitize-count (sstats-gc-count s))

(sanitize-time (sstats-gc-cpu s))

(sanitize-time (sstats-gc-real s))

(sanitize-count (sstats-gc-bytes s)))))

(define prstats

(lambda (b1 b2)

(let ([a (statistics)])

(parameterize ([print-level 2] [print-length 2])

(fprintf (console-output-port) "(time ~s)~%" e))

(let ([elapsed (sstats-difference a b2)])

(let ([overhead (sstats-difference b2 b1)])

(let ([adjusted (sanitize (sstats-difference elapsed overhead))])

(sstats-print adjusted (console-output-port)))))

(flush-output-port (console-output-port)))))

(let ([b1 (statistics)])

(let ([b2 (statistics)])

(call-with-values t

(case-lambda

[(v) (prstats b1 b2) v]

[(v1 v2) (prstats b1 b2) (values v1 v2)]

[(v1 v2 v3) (prstats b1 b2) (values v1 v2 v3)]

[(v1 v2 v3 v4) (prstats b1 b2) (values v1 v2 v3 v4)]

[r (prstats b1 b2) (apply values r)]))))))

(set! $report-string

(lambda (dest what who msg args)

(let ([what (and (not (equal? what "")) what)]

[who (and (not (equal? who "")) who)])

(parameterize ([print-level 3] [print-length 6])

(format dest "~@[~@(~a~)~]~:[~; in ~]~@[~a~]~:[~;: ~]~@[~?~]"

what

(and what who)

who

(and (or what who) (not (equal? msg "")))

msg

args)))))

(let ()

(define report

(lambda (what who msg args)

(fresh-line (console-output-port))

($report-string (console-output-port) what who msg args)

(newline (console-output-port))

(flush-output-port (console-output-port))))

(set! break-handler

($make-thread-parameter

(case-lambda

[(who msg . args)

(unless (string? msg)

($oops 'default-break-handler "~s is not a string" msg))

(report "break" who msg args)

(($interrupt))]

[(who)

(report "break" who "" '())

(($interrupt))]

[()

(($interrupt))])

(lambda (x)

(unless (procedure? x)

($oops 'break-handler "~s is not a procedure" x))

x)))

)

(set-who! debug-condition

(case-lambda

[() (cond

[(assv ($tc-field 'threadno ($tc)) debug-condition*) => cdr]

[else #f])]

[(c)

(let ([n ($tc-field 'threadno ($tc))])

(with-tc-mutex

(set! debug-condition*

(let ([ls (remp (lambda (a) (eqv? (car a) n)) debug-condition*)])

(if c (cons (cons n c) ls) ls)))))]))

(set! debug

(lambda ()

(define line-limit 74)

(define pad

(lambda (s n p)

(let ([i (string-length s)])

(when (> n i) (display (make-string (- n i) #\space) p))

(display s p)

(max i n))))

(define numbered-line-display

(lambda (point? n c p)

(display (if point? "*" " "))

(let ([s (with-output-to-string (lambda () (display-condition c)))])

(let ([k (- line-limit (+ (pad (number->string n) 4 p) 2))])

(display ": " p)

(let ([i (string-length s)])

(if (> i k)

(fprintf p "~a ...~%" (substring s 0 (- k 4)))

(fprintf p "~a~%" s)))))))

(define unnumbered-line-display

(lambda (c p)

(let ([s (with-output-to-string (lambda () (display-condition c)))])

(let ([k (- line-limit 2)])

(display " " p)

(let ([i (string-length s)])

(if (> i k)

(fprintf p "~a ...~%" (substring s 0 (- k 4)))

(fprintf p "~a~%" s)))))))

(define printem

(lambda (point ls p)

(if (null? (cdr ls))

(let ([x (car ls)])

(unnumbered-line-display (cdr x) p))

(for-each

(lambda (x)

(numbered-line-display (eq? x point) (car x) (cdr x) p))

ls))))

(define debug-cafe

(lambda (point ls)

(parameterize ([$interrupt void])

(clear-input-port (console-input-port))

(let ([waiter (call/cc

(lambda (k)

(rec f (lambda () (k f)))))])

(fprintf (console-output-port) "debug> ")

(flush-output-port (console-output-port))

(let ([x (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))

'e)

x))])

(case x

[(i)

(let ([c (cdr point)])

(if (continuation-condition? c)

(inspect (condition-continuation c))

(display "the raise continuation is not available\n")))

(waiter)]

[(c)

(inspect (cdr point))

(waiter)]

[(q)

(with-tc-mutex

(for-each

(lambda (x) (set! debug-condition* (remq x debug-condition*)))

ls))

(void)]

[(e)

(void)]

[(s)