89 lines
2.9 KiB
Scheme
89 lines
2.9 KiB
Scheme
#lang scheme/base
|
|
|
|
(require (for-syntax scheme/base
|
|
r6rs/private/inline-rules))
|
|
|
|
(provide define-inliner
|
|
nocheck
|
|
implementation-restriction)
|
|
|
|
(define-syntax-rule (nocheck v . _)
|
|
v)
|
|
|
|
(define (implementation-restriction who what)
|
|
(raise
|
|
(make-exn:fail:unsupported
|
|
(format "~a: result is out of range: ~e" who what)
|
|
(current-continuation-marks))))
|
|
|
|
(define-syntax-rule (define-inliner define-fx numtype? numtype-str)
|
|
(...
|
|
(begin
|
|
(define-syntax define-an-fx
|
|
(syntax-rules ()
|
|
[(_ orig fx check-result ([(arg ...) (tmp ...)] ...) . rest)
|
|
(begin
|
|
(provide fx)
|
|
(define fx-proc
|
|
(let ([fx (case-lambda
|
|
[(arg ...)
|
|
(unless (numtype? arg)
|
|
(raise-type-error 'fx numtype-str arg))
|
|
...
|
|
(let ([r (orig arg ...)])
|
|
(check-result r (implementation-restriction 'fx r)))]
|
|
...
|
|
. rest)])
|
|
fx))
|
|
(define-syntax fx
|
|
(inline-rules
|
|
fx-proc
|
|
[(_ arg ...)
|
|
(let ([tmp arg] ...)
|
|
(if (and (numtype? tmp) ...)
|
|
(let ([v (orig tmp ...)])
|
|
(check-result v (fx-proc tmp ...)))
|
|
(fx-proc tmp ...)))]
|
|
...)))]))
|
|
|
|
(define-syntax define-an-fx+rest
|
|
(syntax-rules ()
|
|
[(_ orig fx check clauses)
|
|
(define-an-fx orig fx check clauses
|
|
[args (for-each (lambda (arg)
|
|
(unless (numtype? arg)
|
|
(raise-type-error 'fx numtype-str arg)))
|
|
args)
|
|
(let ([r (apply orig args)])
|
|
(check r (implementation-restriction 'fx r))
|
|
r)])]))
|
|
|
|
|
|
(define-syntax define-fx
|
|
(syntax-rules (...)
|
|
[(_ orig fx [(a) (b c)] check)
|
|
(define-an-fx orig fx check
|
|
([(a) (t1)]
|
|
[(b c) (t1 t2)]))]
|
|
[(_ orig fx [(a) (b c (... ...))] check)
|
|
(define-an-fx+rest orig fx check
|
|
([(a) (t1)]
|
|
[(b c) (t1 t2)]))]
|
|
[(_ orig fx (a b c (... ...)) check)
|
|
(define-an-fx+rest orig fx check
|
|
([(a b) (t1 t2)]))]
|
|
[(_ orig fx (a b (... ...)) check)
|
|
(define-an-fx+rest orig fx check
|
|
([(a) (t1)]
|
|
[(a b) (t1 t2)]
|
|
[(a b c) (t1 t2 t3)]))]
|
|
[(_ orig fx (a) check)
|
|
(define-an-fx+rest orig fx check
|
|
([(a) (t1)]))]
|
|
[(_ orig fx (a b) check)
|
|
(define-an-fx orig fx check
|
|
([(a b) (t1 t2)]))]
|
|
[(_ orig fx (a b c) check)
|
|
(define-an-fx orig fx check
|
|
([(a b c) (t1 t2 t3)]))])))))
|