suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

minor relop-length and assertion-violationf improvements

Browse Source 
- zero?, fxzero?, positive?, fxpositive?, etc., now go through
  (a suitably modified) relop-length so that, for example,
  (zero? (length x)) results in the same code as (null? x).  added
  correctness tests for these and all of the other predicates that
  go through relop-length.
    cpnanopass.ss, 5_2.ms
- assertion-violationf and friends now show the who, message, and
  irritants in the original call when who or message is found not to
  be of the right type.
    exceptions.ss

original commit: 9cdc8733cbde4046fd404eefbca6433aabebcef9
This commit is contained in:
dyb 2019-04-19 20:22:09 -07:00
parent a4d8f42835
commit 7e4ed70f72
4 changed files with 242 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
LOG
View File

@ -1343,3 +1343,13 @@
the reduction was dropping the possible side effect expressions the reduction was dropping the possible side effect expressions
in this case the (newline). in this case the (newline).
cp0.ss cp0.ss
- zero?, fxzero?, positive?, fxpositive?, etc., now go through
(a suitably modified) relop-length so that, for example,
(zero? (length x)) results in the same code as (null? x). added
correctness tests for these and all of the other predicates that
go through relop-length.
cpnanopass.ss, 5_2.ms
- assertion-violationf and friends now show the who, message, and
irritants in the original call when who or message is found not to
be of the right type.
exceptions.ss

91
mats/5_2.ms
View File

@ -165,6 +165,97 @@
(mat length (mat length
(= (length '(1 2 3 4 5)) 5) (= (length '(1 2 3 4 5)) 5)
(= (length '()) 0) (= (length '()) 0)
; check that expand-primitives doesn't generate incorrect code.
; we don't check that it optimizes, however.
(let ([ls* (map make-list '(0 1 2 3 4 5 8 9 10 99 100 101 1000))])
(define-syntax test1
(syntax-rules ()
[(_ prim)
(let ()
(define (f x)
(and
(prim (#3%length x))
(prim (#3%length x))))
(andmap
(lambda (x)
(let ([n (length x)])
(equal?
(f x)
(prim n))))
ls*))]))
(define-syntax test2
(syntax-rules ()
[(_ prim)
(let ()
(define (f x)
(and
(prim (#3%length x) 0)
(prim 0 (#3%length x))
(prim (#3%length x) 1)
(prim 1 (#3%length x))
(prim (#3%length x) 4)
(prim 4 (#3%length x))
(prim (#3%length x) 9)
(prim 9 (#3%length x))
(prim (#3%length x) 100)
(prim 100 (#3%length x))))
(andmap
(lambda (x)
(let ([n (length x)])
(equal?
(f x)
(and
(prim n 0)
(prim 0 n)
(prim n 1)
(prim 1 n)
(prim n 4)
(prim 4 n)
(prim n 9)
(prim 9 n)
(prim n 100)
(prim 100 n)))))
ls*))]))
(and
(test1 zero?)
(test1 positive?)
(test1 nonnegative?)
(test1 negative?)
(test1 nonpositive?)
(test1 fxzero?)
(test1 fxpositive?)
(test1 fxnonnegative?)
(test1 fxnegative?)
(test1 fxnonpositive?)
(test2 eq?)
(test2 eqv?)
(test2 equal?)
(test2 <)
(test2 <=)
(test2 =)
(test2 >=)
(test2 >)
(test2 r6rs:<)
(test2 r6rs:<=)
(test2 r6rs:=)
(test2 r6rs:>=)
(test2 r6rs:>)
(test2 r6rs:<)
(test2 r6rs:<=)
(test2 r6rs:=)
(test2 r6rs:>=)
(test2 r6rs:>)
(test2 fx<)
(test2 fx<=)
(test2 fx=)
(test2 fx>=)
(test2 fx>)
(test2 fx<?)
(test2 fx<=?)
(test2 fx=?)
(test2 fx>=?)
(test2 fx>?)
(test2 #%$fxu<)))
) )
(mat list-ref (mat list-ref

254
s/cpnanopass.ss
View File

@ -3714,61 +3714,65 @@
(if (null? e*) (if (null? e*)
e e
(reduce #f (moi src sexpr (list e (car e*))) (cdr e*))))))))) (reduce #f (moi src sexpr (list e (car e*))) (cdr e*)))))))))
(define-who relop-length (module (relop-length RELOP< RELOP<= RELOP= RELOP>= RELOP>)
(lambda (op e1 e2) (define RELOP< -2)
(define (mirror op) (define RELOP<= -1)
(case op (define RELOP= 0)
[(<) '>] (define RELOP>= 2)
[(<=) '>=] (define RELOP> 1)
[(>=) '<=] (define (mirror op) (fx- op))
[(>) '<] (define go
[else op])) (lambda (op e n)
(define go (let f ([n n] [e e])
(lambda (n e r?) (if (fx= n 0)
(define op-error (cond
(lambda (op) [(or (eqv? op RELOP=) (eqv? op RELOP<=)) (build-null? e)]
(sorry! who "unexpected op ~s" op))) [(eqv? op RELOP<) `(seq ,e (quote #f))]
(let ([op (if r? (mirror op) op)]) [(eqv? op RELOP>) (build-not (build-null? e))]
(let f ([n n] [e e]) [(eqv? op RELOP>=) `(seq ,e (quote #t))]
(if (fx= n 0) [else (sorry! 'relop-length "unexpected op ~s" op)])
(case op (cond
[(= <=) (build-null? e)] [(or (eqv? op RELOP=) (eqv? op RELOP>))
[(<) `(seq ,e (quote #f))] (bind #t (e)
[(>) (build-not (build-null? e))] (build-and
[(>=) `(seq ,e (quote #t))] (build-not (build-null? e))
[else (op-error op)]) (f (fx- n 1) (build-cdr e))))]
(case op [(eqv? op RELOP<)
[(= >) (bind #t (e) (if (fx= n 1)
(build-and (build-null? e)
(build-not (build-null? e)) (bind #t (e)
(f (fx- n 1) (build-cdr e))))] (build-simple-or
[(<) (if (fx= n 1) (build-null? e)
(build-null? e) (f (fx- n 1) (build-cdr e)))))]
(bind #t (e) [(eqv? op RELOP<=)
(build-simple-or (bind #t (e)
(build-null? e) (build-simple-or
(f (fx- n 1) (build-cdr e)))))] (build-null? e)
[(<=) (bind #t (e) (f (fx- n 1) (build-cdr e))))]
(build-simple-or [(eqv? op RELOP>=)
(build-null? e) (if (fx= n 1)
(f (fx- n 1) (build-cdr e))))] (build-not (build-null? e))
[(>=) (if (fx= n 1) (bind #t (e)
(build-not (build-null? e)) (build-and
(bind #t (e) (build-not (build-null? e))
(build-and (f (fx- n 1) (build-cdr e)))))]
(build-not (build-null? e)) [else (sorry! 'relop-length "unexpected op ~s" op)])))))
(f (fx- n 1) (build-cdr e)))))] (define relop-length1
[else (op-error op)])))))) (lambda (op e n)
(define try (nanopass-case (L7 Expr) e
(lambda (e1 e2 r?) [(call ,info ,mdcl ,pr ,e)
(nanopass-case (L7 Expr) e1 (guard (and (eq? (primref-name pr) 'length) (all-set? (prim-mask unsafe) (primref-flags pr))))
[(call ,info ,mdcl ,pr ,e) (go op e n)]
(guard (and (eq? (primref-name pr) 'length) (all-set? (prim-mask unsafe) (primref-flags pr)))) [else #f])))
(nanopass-case (L7 Expr) e2 (define relop-length2
[(quote ,d) (and (fixnum? d) (fx<= 0 d 4) (go d e r?))] (lambda (op e1 e2)
[else #f])] (nanopass-case (L7 Expr) e2
[else #f]))) [(quote ,d) (and (fixnum? d) (fx<= 0 d 4) (relop-length1 op e1 d))]
(or (try e1 e2 #f) (try e2 e1 #t)))) [else #f])))
(define relop-length
(case-lambda
[(op e) (relop-length1 op e 0)]
[(op e1 e2) (or (relop-length2 op e1 e2) (relop-length2 (mirror op) e1 e2))])))
(define make-ftype-pointer-equal? (define make-ftype-pointer-equal?
(lambda (e1 e2) (lambda (e1 e2)
(bind #f (e1 e2) (bind #f (e1 e2)
@ -3808,7 +3812,9 @@
[(e) e] [(e) e]
[e* `(values ,(make-info-call src sexpr #f #f #f) ,e* ...)]) [e* `(values ,(make-info-call src sexpr #f #f #f) ,e* ...)])
(define-inline 2 eq? (define-inline 2 eq?
[(e1 e2) (%inline eq? ,e1 ,e2)]) [(e1 e2)
(or (relop-length RELOP= e1 e2)
(%inline eq? ,e1 ,e2))])
(define-inline 2 $keep-live (define-inline 2 $keep-live
[(e) (%seq ,(%inline keep-live ,e) ,(%constant svoid))]) [(e) (%seq ,(%inline keep-live ,e) ,(%constant svoid))])
(let () (let ()
@ -3821,7 +3827,7 @@
(build-libcall #t src sexpr fx=? e1 e2) (build-libcall #t src sexpr fx=? e1 e2)
(build-libcall #t src sexpr fx= e1 e2))))) (build-libcall #t src sexpr fx= e1 e2)))))
(define (go src sexpr e1 e2 r6rs?) (define (go src sexpr e1 e2 r6rs?)
(or (relop-length '= e1 e2) (or (relop-length RELOP= e1 e2)
(cond (cond
[(constant? (lambda (x) (eqv? x 0)) e1) [(constant? (lambda (x) (eqv? x 0)) e1)
(bind #t (e2) (zgo src sexpr e2 e1 e2 r6rs?))] (bind #t (e2) (zgo src sexpr e2 e1 e2 r6rs?))]
@ -3845,7 +3851,7 @@
[(_ op r6rs:op length-op inline-op) [(_ op r6rs:op length-op inline-op)
(let () (let ()
(define (go src sexpr e1 e2 r6rs?) (define (go src sexpr e1 e2 r6rs?)
(or (relop-length 'length-op e1 e2) (or (relop-length length-op e1 e2)
(bind #t (e1 e2) (bind #t (e1 e2)
`(if ,(build-fixnums? (list e1 e2)) `(if ,(build-fixnums? (list e1 e2))
,(%inline inline-op ,e1 ,e2) ,(%inline inline-op ,e1 ,e2)
@ -3862,17 +3868,17 @@
; TODO: 3-operand case requires 3-operand library routine ; TODO: 3-operand case requires 3-operand library routine
#; [(e1 e2 e3) (go3 src sexpr e1 e2 e3 #t)] #; [(e1 e2 e3) (go3 src sexpr e1 e2 e3 #t)]
[(e1 e2 . e*) #f]))])) [(e1 e2 . e*) #f]))]))
(fx-pred fx< fx<? < <) (fx-pred fx< fx<? RELOP< <)
(fx-pred fx<= fx<=? <= <=) (fx-pred fx<= fx<=? RELOP<= <=)
(fx-pred fx>= fx>=? >= >=) (fx-pred fx>= fx>=? RELOP>= >=)
(fx-pred fx> fx>? > >)) (fx-pred fx> fx>? RELOP> >))
(let () ; level 3 fx=, fx=?, etc. (let () ; level 3 fx=, fx=?, etc.
(define-syntax fx-pred (define-syntax fx-pred
(syntax-rules () (syntax-rules ()
[(_ op r6rs:op length-op inline-op) [(_ op r6rs:op length-op inline-op)
(let () (let ()
(define (go e1 e2) (define (go e1 e2)
(or (relop-length 'length-op e1 e2) (or (relop-length length-op e1 e2)
(%inline inline-op ,e1 ,e2))) (%inline inline-op ,e1 ,e2)))
(define reducer (define reducer
(if (eq? 'inline-op 'eq?) (if (eq? 'inline-op 'eq?)
@ -3885,11 +3891,11 @@
(define-inline 3 r6rs:op (define-inline 3 r6rs:op
[(e1 e2) (go e1 e2)] [(e1 e2) (go e1 e2)]
[(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)]))])) [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)]))]))
(fx-pred fx< fx<? < <) (fx-pred fx< fx<? RELOP< <)
(fx-pred fx<= fx<=? <= <=) (fx-pred fx<= fx<=? RELOP<= <=)
(fx-pred fx= fx=? = eq?) (fx-pred fx= fx=? RELOP= eq?)
(fx-pred fx>= fx>=? >= >=) (fx-pred fx>= fx>=? RELOP>= >=)
(fx-pred fx> fx>? > >)) (fx-pred fx> fx>? RELOP> >))
(let () ; level 3 fxlogand, ... (let () ; level 3 fxlogand, ...
(define-syntax fxlogop (define-syntax fxlogop
(syntax-rules () (syntax-rules ()
@ -3990,7 +3996,7 @@
(fxlognotop fxlognot) (fxlognotop fxlognot)
(fxlognotop fxnot)) (fxlognotop fxnot))
(define-inline 3 $fxu< (define-inline 3 $fxu<
[(e1 e2) (or (relop-length '< e1 e2) [(e1 e2) (or (relop-length RELOP< e1 e2)
(%inline u< ,e1 ,e2))]) (%inline u< ,e1 ,e2))])
(define-inline 3 fx+ (define-inline 3 fx+
[() `(immediate 0)] [() `(immediate 0)]
@ -4434,15 +4440,15 @@
(build-libcall #t src sexpr fxcopy-bit e1 e2)))] (build-libcall #t src sexpr fxcopy-bit e1 e2)))]
[else #f]))])) [else #f]))]))
(define-inline 3 fxzero? (define-inline 3 fxzero?
[(e) (%inline eq? ,e (immediate 0))]) [(e) (or (relop-length RELOP= e) (%inline eq? ,e (immediate 0)))])
(define-inline 3 fxpositive? (define-inline 3 fxpositive?
[(e) (%inline > ,e (immediate 0))]) [(e) (or (relop-length RELOP> e) (%inline > ,e (immediate 0)))])
(define-inline 3 fxnonnegative? (define-inline 3 fxnonnegative?
[(e) (%inline >= ,e (immediate 0))]) [(e) (or (relop-length RELOP>= e) (%inline >= ,e (immediate 0)))])
(define-inline 3 fxnegative? (define-inline 3 fxnegative?
[(e) (%inline < ,e (immediate 0))]) [(e) (or (relop-length RELOP< e) (%inline < ,e (immediate 0)))])
(define-inline 3 fxnonpositive? (define-inline 3 fxnonpositive?
[(e) (%inline <= ,e (immediate 0))]) [(e) (or (relop-length RELOP<= e) (%inline <= ,e (immediate 0)))])
(define-inline 3 fxeven? (define-inline 3 fxeven?
[(e) (%inline eq? [(e) (%inline eq?
,(%inline logand ,e (immediate ,(fix 1))) ,(%inline logand ,e (immediate ,(fix 1)))
@ -4453,32 +4459,37 @@
(immediate ,(fix 1)))]) (immediate ,(fix 1)))])
(define-inline 2 fxzero? (define-inline 2 fxzero?
[(e) (bind #t (e) [(e) (or (relop-length RELOP= e)
(build-simple-or (bind #t (e)
(%inline eq? ,e (immediate 0)) (build-simple-or
`(if ,(build-fixnums? (list e)) (%inline eq? ,e (immediate 0))
,(%constant sfalse) `(if ,(build-fixnums? (list e))
,(build-libcall #t src sexpr fxzero? e))))]) ,(%constant sfalse)
,(build-libcall #t src sexpr fxzero? e)))))])
(define-inline 2 fxpositive? (define-inline 2 fxpositive?
[(e) (bind #t (e) [(e) (or (relop-length RELOP> e)
`(if ,(build-fixnums? (list e)) (bind #t (e)
,(%inline > ,e (immediate 0)) `(if ,(build-fixnums? (list e))
,(build-libcall #t src sexpr fxpositive? e)))]) ,(%inline > ,e (immediate 0))
,(build-libcall #t src sexpr fxpositive? e))))])
(define-inline 2 fxnonnegative? (define-inline 2 fxnonnegative?
[(e) (bind #t (e) [(e) (or (relop-length RELOP>= e)
`(if ,(build-fixnums? (list e)) (bind #t (e)
,(%inline >= ,e (immediate 0)) `(if ,(build-fixnums? (list e))
,(build-libcall #t src sexpr fxnonnegative? e)))]) ,(%inline >= ,e (immediate 0))
,(build-libcall #t src sexpr fxnonnegative? e))))])
(define-inline 2 fxnegative? (define-inline 2 fxnegative?
[(e) (bind #t (e) [(e) (or (relop-length RELOP< e)
`(if ,(build-fixnums? (list e)) (bind #t (e)
,(%inline < ,e (immediate 0)) `(if ,(build-fixnums? (list e))
,(build-libcall #t src sexpr fxnegative? e)))]) ,(%inline < ,e (immediate 0))
,(build-libcall #t src sexpr fxnegative? e))))])
(define-inline 2 fxnonpositive? (define-inline 2 fxnonpositive?
[(e) (bind #t (e) [(e) (or (relop-length RELOP<= e)
`(if ,(build-fixnums? (list e)) (bind #t (e)
,(%inline <= ,e (immediate 0)) `(if ,(build-fixnums? (list e))
,(build-libcall #t src sexpr fxnonpositive? e)))]) ,(%inline <= ,e (immediate 0))
,(build-libcall #t src sexpr fxnonpositive? e))))])
(define-inline 2 fxeven? (define-inline 2 fxeven?
[(e) (bind #t (e) [(e) (bind #t (e)
`(if ,(build-fixnums? (list e)) `(if ,(build-fixnums? (list e))
@ -5719,6 +5730,7 @@
(define eqvok? (e*ok? eqvok-help?)) (define eqvok? (e*ok? eqvok-help?))
(define-inline 2 eqv? (define-inline 2 eqv?
[(e1 e2) (or (eqvop-null-fptr e1 e2) [(e1 e2) (or (eqvop-null-fptr e1 e2)
(relop-length RELOP= e1 e2)
(if (or (eqok? e1) (eqok? e2)) (if (or (eqok? e1) (eqok? e2))
(build-eq? e1 e2) (build-eq? e1 e2)
(build-eqv? src sexpr e1 e2)))]) (build-eqv? src sexpr e1 e2)))])
@ -5747,6 +5759,7 @@
[else #f]))) [else #f])))
(define-inline 2 equal? (define-inline 2 equal?
[(e1 e2) (or (eqvop-null-fptr e1 e2) [(e1 e2) (or (eqvop-null-fptr e1 e2)
(relop-length RELOP= e1 e2)
(xform-equal? src sexpr e1 e2) (xform-equal? src sexpr e1 e2)
(xform-equal? src sexpr e2 e1))])) (xform-equal? src sexpr e2 e1))]))
(let () (let ()
@ -6211,7 +6224,7 @@
,(build-libcall #t src sexpr = e1 e2)))) ,(build-libcall #t src sexpr = e1 e2))))
(define (go src sexpr e1 e2) (define (go src sexpr e1 e2)
(or (eqvop-null-fptr e1 e2) (or (eqvop-null-fptr e1 e2)
(relop-length '= e1 e2) (relop-length RELOP= e1 e2)
(cond (cond
[(constant? (lambda (x) (eqv? x 0)) e1) [(constant? (lambda (x) (eqv? x 0)) e1)
(bind #t (e2) (zgo src sexpr e2 e1 e2))] (bind #t (e2) (zgo src sexpr e2 e1 e2))]
@ -6234,7 +6247,7 @@
(let () (let ()
(define builder (define builder
(lambda (e1 e2 libcall) (lambda (e1 e2 libcall)
(or (relop-length 'relop e1 e2) (or (relop-length relop e1 e2)
(bind #t (e1 e2) (bind #t (e1 e2)
`(if ,(build-fixnums? (list e1 e2)) `(if ,(build-fixnums? (list e1 e2))
,(%inline op ,e1 ,e2) ,(%inline op ,e1 ,e2)
@ -6251,33 +6264,38 @@
(lambda (e1 e2) (build-libcall #t src sexpr name e1 e2)))] (lambda (e1 e2) (build-libcall #t src sexpr name e1 e2)))]
; TODO: handle 3-operand case w/3-operand library routine ; TODO: handle 3-operand case w/3-operand library routine
[(e1 e2 . e*) #f]))])) [(e1 e2 . e*) #f]))]))
(define-relop-inline < r6rs:< < <) (define-relop-inline < r6rs:< RELOP< <)
(define-relop-inline <= r6rs:<= <= <=) (define-relop-inline <= r6rs:<= RELOP<= <=)
(define-relop-inline >= r6rs:>= >= >=) (define-relop-inline >= r6rs:>= RELOP>= >=)
(define-relop-inline > r6rs:> > >)) (define-relop-inline > r6rs:> RELOP> >))
(define-inline 3 positive? ; 3 so opt-level 2 errors come from positive? (define-inline 3 positive? ; 3 so opt-level 2 errors come from positive?
[(e) (handle-prim src sexpr 3 '> (list e `(quote 0)))]) [(e) (handle-prim src sexpr 3 '> (list e `(quote 0)))])
(define-inline 3 nonnegative? ; 3 so opt-level 2 errors come from positive? (define-inline 3 nonnegative? ; 3 so opt-level 2 errors come from nonnegative?
[(e) (handle-prim src sexpr 3 '>= (list e `(quote 0)))]) [(e) (handle-prim src sexpr 3 '>= (list e `(quote 0)))])
(define-inline 3 negative? ; 3 so opt-level 2 errors come from positive? (define-inline 3 negative? ; 3 so opt-level 2 errors come from negative?
[(e) (handle-prim src sexpr 3 '< (list e `(quote 0)))]) [(e) (handle-prim src sexpr 3 '< (list e `(quote 0)))])
(define-inline 3 nonpositive? ; 3 so opt-level 2 errors come from positive? (define-inline 3 nonpositive? ; 3 so opt-level 2 errors come from nonpositive?
[(e) (handle-prim src sexpr 3 '<= (list e `(quote 0)))]) [(e) (handle-prim src sexpr 3 '<= (list e `(quote 0)))])
(define-inline 2 zero? (define-inline 2 zero?
[(e) [(e)
(nanopass-case (L7 Expr) e (or (relop-length RELOP= e)
[(call ,info ,mdcl ,pr ,e) (nanopass-case (L7 Expr) e
(guard [(call ,info ,mdcl ,pr ,e)
(eq? (primref-name pr) 'ftype-pointer-address) (guard
(all-set? (prim-mask unsafe) (primref-flags pr))) (eq? (primref-name pr) 'ftype-pointer-address)
(make-ftype-pointer-null? e)] (all-set? (prim-mask unsafe) (primref-flags pr)))
[else (make-ftype-pointer-null? e)]
(bind #t (e) [else
(build-simple-or (bind #t (e)
(%inline eq? ,e (immediate ,(fix 0))) (build-simple-or
`(if ,(%type-check mask-fixnum type-fixnum ,e) (%inline eq? ,e (immediate ,(fix 0)))
,(%constant sfalse) `(if ,(%type-check mask-fixnum type-fixnum ,e)
,(build-libcall #t src sexpr zero? e))))])]) ,(%constant sfalse)
,(build-libcall #t src sexpr zero? e))))]))])
(define-inline 2 positive? [(e) (relop-length RELOP> e)])
(define-inline 2 nonnegative? [(e) (relop-length RELOP>= e)])
(define-inline 2 negative? [(e) (relop-length RELOP< e)])
(define-inline 2 nonpositive? [(e) (relop-length RELOP<= e)])
(let () (let ()
(define-syntax define-logorop-inline (define-syntax define-logorop-inline
(syntax-rules () (syntax-rules ()

8
s/exceptions.ss
View File

@ -608,9 +608,9 @@ TODO:
(define (error-help warning? who whoarg message irritants basecond) (define (error-help warning? who whoarg message irritants basecond)
(unless (or (eq? whoarg #f) (string? whoarg) (symbol? whoarg)) (unless (or (eq? whoarg #f) (string? whoarg) (symbol? whoarg))
($oops who "invalid who argument ~s" whoarg)) ($oops who "invalid who argument ~s (message = ~s, irritants = ~s)" whoarg message irritants))
(unless (string? message) (unless (string? message)
($oops who "invalid message argument ~s" message)) ($oops who "invalid message argument ~s (who = ~s, irritants = ~s)" message whoarg irritants))
(let ([c (if whoarg (let ([c (if whoarg
(if irritants (if irritants
(condition basecond (condition basecond
@ -640,7 +640,9 @@ TODO:
(lambda (whoarg message . irritants) (lambda (whoarg message . irritants)
(error-help #f who whoarg message irritants favcond))) (error-help #f who whoarg message irritants favcond)))
(set! $oops assertion-violationf) (set-who! $oops
(lambda (whoarg message . irritants)
(error-help #f who whoarg message irritants favcond)))
(set-who! $oops/c (set-who! $oops/c
(lambda (whoarg basecond message . irritants) (lambda (whoarg basecond message . irritants)