;;----------------------------------------------------------------------

;; more-scheme : case, do, etc. - remaining syntax

(module more-scheme '#%kernel

(#%require "define-et-al.rkt" "qq-and-or.rkt" "cond.rkt" "define.rkt" '#%paramz "case.rkt" "logger.rkt"

"member.rkt"

(for-syntax '#%kernel "stx.rkt" "define-et-al.rkt" "qq-and-or.rkt" "cond.rkt" "stxcase-scheme.rkt" "qqstx.rkt"))

;; For `old-case`:

(define-syntax case-test

(lambda (x)

(syntax-case x ()

;; For up to 3 elements, inline `eqv?' tests:

[(_ x (k))

(syntax (eqv? x 'k))]

[(_ x (k1 k2))

(syntax (let ([tmp x]) (if (eqv? tmp 'k1) #t (eqv? tmp 'k2))))]

[(_ x (k1 k2 k3))

(syntax (let ([tmp x]) (if (eqv? tmp 'k1) #t (if (eqv? tmp 'k2) #t (eqv? tmp 'k3)))))]

[(_ x (k ...))

(syntax (memv x '(k ...)))])))

;; Mostly from Dybvig:

(define-syntax (old-case x)

(syntax-case* x (else) (let ([else-stx (datum->syntax #f 'else)])

(lambda (a b) (free-identifier=? a else-stx)))

((_ v)

(syntax (#%expression (begin v (void)))))

((_ v (else e1 e2 ...))

(syntax/loc x (#%expression (begin v (let-values () e1 e2 ...)))))

((_ v ((k ...) e1 e2 ...))

(syntax/loc x (if (case-test v (k ...)) (let-values () e1 e2 ...) (void))))

((self v ((k ...) e1 e2 ...) c1 c2 ...)

(syntax/loc x (let ((x v))

(if (case-test x (k ...))

(let-values () e1 e2 ...)

(self x c1 c2 ...)))))

((_ v (bad e1 e2 ...) . rest)

(raise-syntax-error

#f

"bad syntax (not a datum sequence)"

x

(syntax bad)))

((_ v clause . rest)

(raise-syntax-error

#f

"bad syntax (missing expression after datum sequence)"

x

(syntax clause)))

((_ . v)

(not (null? (syntax-e (syntax v))))

(raise-syntax-error

#f

"bad syntax (illegal use of `.')"

x))))

;; From Dybvig:

(define-syntax do

(lambda (orig-x)

(syntax-case orig-x ()

((_ ((var init . step) ...) (e0 e1 ...) c ...)

(with-syntax (((step ...)

(map (lambda (v s)

(syntax-case s ()

(() v)

((e) (syntax e))

(_ (raise-syntax-error

#f

"bad variable syntax"

orig-x))))

(syntax->list (syntax (var ...)))

(syntax->list (syntax (step ...))))))

(syntax/loc orig-x

(let doloop ((var init) ...)

(if e0

(begin (void) e1 ...)

(begin c ... (doloop step ...))))))))))

(define-syntax parameterize

(lambda (stx)

(syntax-case stx ()

[(_ () expr1 expr ...)

(syntax (let () expr1 expr ...))]

[(_ ([param val] ...) expr1 expr ...)

(with-syntax ([(p/v ...)

(apply append

(map list

(syntax->list #'(param ...))

(syntax->list #'(val ...))))])

(syntax-protect

(syntax/loc stx

(with-continuation-mark

parameterization-key

(extend-parameterization

(continuation-mark-set-first #f parameterization-key)

p/v ...)

(let ()

expr1

expr ...)))))])))

(define-syntax parameterize*

(syntax-rules ()

[(_ () body1 body ...)

(let () body1 body ...)]

[(_ ([lhs1 rhs1] [lhs rhs] ...) body1 body ...)

(parameterize ([lhs1 rhs1])

(parameterize* ([lhs rhs] ...)

body1 body ...))]))

(define (current-parameterization)

(continuation-mark-set-first #f parameterization-key))

(define (call-with-parameterization paramz thunk)

(unless (parameterization? paramz)

(raise-argument-error 'call-with-parameterization "parameterization?" 0 paramz thunk))

(unless (and (procedure? thunk)

(procedure-arity-includes? thunk 0))

(raise-argument-error 'call-with-parameterization "(-> any)" 1 paramz thunk))

(with-continuation-mark

parameterization-key

paramz

(thunk)))

(define-syntax parameterize-break

(lambda (stx)

(syntax-case stx ()

[(_ bool-expr expr1 expr ...)

(syntax-protect

(syntax/loc stx

(with-continuation-mark

break-enabled-key

(make-thread-cell (and bool-expr #t))

(begin

(check-for-break)

(let ()

expr1

expr ...)))))])))

(define-values (struct:break-paramz make-break-paramz break-paramz? break-paramz-ref break-paramz-set!)

(make-struct-type 'break-parameterization #f 1 0 #f))

(-define-struct break-parameterization (cell))

(define (current-break-parameterization)

(make-break-paramz (continuation-mark-set-first #f break-enabled-key)))

(define (call-with-break-parameterization paramz thunk)

(unless (break-paramz? paramz)

(raise-argument-error 'call-with-break-parameterization "break-parameterization?" 0 paramz thunk))

(unless (and (procedure? thunk)

(procedure-arity-includes? thunk 0))

(raise-argument-error 'call-with-parameterization "(-> any)" 1 paramz thunk))

(begin0

(with-continuation-mark

break-enabled-key

(break-paramz-ref paramz 0)

(begin

(check-for-break)

(thunk)))

(check-for-break)))

(define (select-handler/no-breaks e bpz l)

(with-continuation-mark

break-enabled-key

;; make a fresh thread cell so that the shared one isn't mutated

(make-thread-cell #f)

(let loop ([l l])

(cond

[(null? l)

(raise e)]

[((caar l) e)

(begin0

((cdar l) e)

(with-continuation-mark

break-enabled-key

bpz

(check-for-break)))]

[else

(loop (cdr l))]))))

(define (select-handler/breaks-as-is e bpz l)

(cond

[(null? l)

(raise e)]

[((caar l) e)

(with-continuation-mark

break-enabled-key

bpz

(begin

(check-for-break)

((cdar l) e)))]

[else

(select-handler/breaks-as-is e bpz (cdr l))]))

(define false-thread-cell (make-thread-cell #f))

(define (check-with-handlers-in-context handler-prompt-key)

(unless (continuation-prompt-available? handler-prompt-key)

(error 'with-handlers

"exception handler used out of context")))

(define handler-prompt-key (make-continuation-prompt-tag 'handler-prompt-tag))

(define (call-handled-body bpz handle-proc body-thunk)

;; Disable breaks here, so that when the exception handler jumps

;; to run a handler, breaks are disabled for the handler

(with-continuation-mark

break-enabled-key

false-thread-cell

(call-with-continuation-prompt

(lambda (bpz body-thunk)

;; Restore the captured break parameterization for

;; evaluating the `with-handlers' body. In this

;; special case, no check for breaks is needed,

;; because bpz is quickly restored past call/ec.

;; Thus, `with-handlers' can evaluate its body in

;; tail position.

(with-continuation-mark

break-enabled-key

bpz

(with-continuation-mark

exception-handler-key

(lambda (e)

;; Deliver the exception to the escape handler:

(abort-current-continuation

handler-prompt-key

e))

(body-thunk))))

handler-prompt-key

handle-proc

bpz body-thunk)))

(define-syntaxes (with-handlers with-handlers*)

(let ([wh

(lambda (disable-break?)

(lambda (stx)

(syntax-case stx ()

[(_ () expr1 expr ...) (syntax/loc stx (let () expr1 expr ...))]

[(_ ([pred handler] ...) expr1 expr ...)

(with-syntax ([(pred-name ...) (generate-temporaries (map (lambda (x) 'with-handlers-predicate)

(syntax->list #'(pred ...))))]

[(handler-name ...) (generate-temporaries (map (lambda (x) 'with-handlers-handler)

(syntax->list #'(handler ...))))])

(syntax-protect

(quasisyntax/loc stx

(let-values ([(pred-name) pred] ...

[(handler-name) handler] ...)

;; Capture current break parameterization, so we can use it to

;; evaluate the body

(let ([bpz (continuation-mark-set-first #f break-enabled-key)])

(call-handled-body

bpz

(lambda (e)

(#,(if disable-break?

#'select-handler/no-breaks

#'select-handler/breaks-as-is)

e bpz

(list (cons pred-name handler-name) ...)))

#,(syntax/loc stx

(lambda ()

expr1 expr ...))))))))])))])

(values (wh #t) (wh #f))))

(define (call-with-exception-handler exnh thunk)

;; The `begin0' ensures that we don't overwrite an enclosing

;; exception handler.

(begin0

(with-continuation-mark

exception-handler-key

exnh

(thunk))

(void)))

(define-syntax set!-values

(lambda (stx)

(syntax-case stx ()

[(_ () expr) (syntax (let-values ([() expr]) (void)))]

[(_ (id) expr) (identifier? (syntax id)) (syntax (set! id expr))]

[(_ (id ...) expr)

(let ([ids (stx->list (syntax (id ...)))])

(for-each

(lambda (id)

(unless (identifier? id)

(raise-syntax-error #f

"not an identifier"

stx

id)))

ids)

(let ([dup (check-duplicate-identifier ids)])

(when dup

(raise-syntax-error #f

"duplicate identifier"

stx

dup))))

(with-syntax ([(temp ...) (generate-temporaries (syntax (id ...)))])

(syntax/loc

stx

(let-values ([(temp ...) expr])

(set! id temp) ...)))])))

(define-values (call/cc) call-with-current-continuation)

(define-syntax let/cc

(lambda (stx)

(syntax-case stx ()

[(_ var body1 body ...)

(syntax/loc stx (call/cc (lambda (var) body1 body ...)))])))

(define-syntax fluid-let

(lambda (stx)

(syntax-case stx ()

[(_ () body1 body ...) (syntax/loc stx (let () body1 body ...))]

[(_ ([name val] ...) body1 body ...)

(with-syntax ([(tmp ...) (generate-temporaries (syntax (name ...)))])

(syntax/loc

stx

(let ([tmp val] ...)

(let ([swap

(lambda ()

(let ([s tmp])

(set! tmp name)

(set! name s))

...)])

(dynamic-wind

swap

(lambda () body1 body ...)

swap)))))])))

(define-syntax time

(lambda (stx)

(syntax-case stx ()

[(_ expr1 expr ...)

(syntax/loc

stx

(let-values ([(v cpu user gc) (time-apply (lambda () expr1 expr ...) null)])

(printf "cpu time: ~s real time: ~s gc time: ~s\n" cpu user gc)

(apply values v)))])))

(define not-there (gensym))

(define (do-hash-update who mut? set ht key xform default)

(unless (variable-reference-from-unsafe? (#%variable-reference))

(unless (and (hash? ht)

(if mut?

(not (immutable? ht))

(immutable? ht)))

(raise-argument-error who (if mut? "(and/c hash? (not/c immutable?))" "(and/c hash? immutable?)") ht))

(unless (and (procedure? xform)

(procedure-arity-includes? xform 1))

(raise-argument-error who "(any/c . -> . any/c)" xform)))

(let ([v (hash-ref ht key default)])

(if (eq? v not-there)

(raise-mismatch-error who "no value found for key: " key)

(set ht key (xform v)))))

(define hash-update

(case-lambda

[(ht key xform default)

(do-hash-update 'hash-update #f hash-set ht key xform default)]

[(ht key xform)

(hash-update ht key xform not-there)]))

(define hash-update!

(case-lambda

[(ht key xform default)

(do-hash-update 'hash-update! #t hash-set! ht key xform default)]

[(ht key xform)

(hash-update! ht key xform not-there)]))

(define (hash-has-key? ht key)

(unless (hash? ht)

(raise-argument-error 'hash-has-key? "hash?" 0 ht key))

(not (eq? not-there (hash-ref ht key not-there))))

(define (hash-ref! ht key new)

(unless (and (hash? ht)

(not (immutable? ht)))

(raise-argument-error 'hash-ref! "(and/c hash? (not/c immutable?))" 0 ht key new))

(let ([v (hash-ref ht key not-there)])

(if (eq? not-there v)

(let ([n (if (procedure? new) (new) new)])

(hash-set! ht key n)

n)

v)))

(#%provide case old-case do

parameterize parameterize* current-parameterization call-with-parameterization

parameterize-break current-break-parameterization call-with-break-parameterization

(rename break-paramz? break-parameterization?)

with-handlers with-handlers* call-with-exception-handler

set!-values

let/cc call/cc fluid-let time

log-fatal log-error log-warning log-info log-debug define-logger

hash-ref! hash-has-key? hash-update hash-update!))