77 lines
1.9 KiB
Racket
77 lines
1.9 KiB
Racket
#lang racket
|
|
|
|
(provide % abort call/comp call/cm current-marks
|
|
(rename-out [_call/cc call/cc]
|
|
[_if if]
|
|
[_+ +]
|
|
[_print print]
|
|
[_cons cons]
|
|
[_set! set!]
|
|
[_zero? zero?]))
|
|
|
|
(define tag
|
|
(let ([tags (make-hash)])
|
|
(λ (v)
|
|
(hash-ref tags v
|
|
(λ ()
|
|
(let ([t (make-continuation-prompt-tag)])
|
|
(hash-set! tags v t)
|
|
t))))))
|
|
|
|
(define-syntax-rule (% tag-val expr handler)
|
|
(call-with-continuation-prompt
|
|
(λ () expr)
|
|
(let ([v tag-val])
|
|
(if (let comparable? ([v v])
|
|
(cond [(procedure? v) #f]
|
|
[(list? v) (andmap comparable? v)]
|
|
[else #t]))
|
|
(tag v)
|
|
(raise-type-error '% "non-procedure" v)))
|
|
(let ([h handler])
|
|
(λ (x) (h x)))))
|
|
|
|
(define (abort tag-val result)
|
|
(abort-current-continuation (tag tag-val) result))
|
|
|
|
(define ((force-unary f) x) (f x))
|
|
|
|
(define (_call/cc proc tag-val)
|
|
(call/cc (compose proc force-unary) (tag tag-val)))
|
|
|
|
(define (call/comp proc tag-val)
|
|
(call-with-composable-continuation (compose proc force-unary) (tag tag-val)))
|
|
|
|
(define (call/cm key val thunk)
|
|
(with-continuation-mark key val (thunk)))
|
|
|
|
(define (current-marks key tag-val)
|
|
(continuation-mark-set->list
|
|
(current-continuation-marks (tag tag-val))
|
|
key))
|
|
|
|
(define-syntax-rule (_if e1 e2 e3)
|
|
(let ([v1 e1])
|
|
(case v1
|
|
[(#t) e2]
|
|
[(#f) e3]
|
|
[else (raise-type-error 'if "#t or #f" v1)])))
|
|
|
|
(define (_+ x y) (+ x y))
|
|
|
|
(define-syntax-rule (_set! x e)
|
|
(begin (set! x e) #f))
|
|
|
|
(define (_zero? x)
|
|
(equal? 0 x))
|
|
|
|
(define (_cons x xs)
|
|
(if (list? xs)
|
|
(cons x xs)
|
|
(raise-type-error 'cons "list?" 1 x xs)))
|
|
|
|
(define (_print n)
|
|
(if (number? n)
|
|
(begin (print n) #f)
|
|
(raise-type-error 'print "number" n)))
|