From f58eef8582c0f23f7e075b962ea34fba9850d0a6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 31 May 2010 15:19:22 -0600 Subject: [PATCH] adjust mred/private/syntax for gracket2 original commit: bcb075543c4523b126ae9f5cb3f444045772ac30 --- collects/mred/private/syntax.rkt | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/syntax.rkt b/collects/mred/private/syntax.rkt index 21b0b231..b4cc868a 100644 --- a/collects/mred/private/syntax.rkt +++ b/collects/mred/private/syntax.rkt @@ -5,8 +5,9 @@ (provide defclass defclass* def/public def/public-final def/override def/override-final define/top case-args + def/public-unimplemented define-unimplemented maybe-box? any? bool? nonnegative-real? make-or-false make-box make-list make-alts - make-literal symbol-in make-procedure + make-literal symbol-in integer-in real-in make-procedure method-name init-name let-boxes properties field-properties init-properties @@ -100,6 +101,17 @@ (define-syntax-rule (symbol-in sym ...) (make-symbol '(sym ...))) +(define (integer-in lo hi) + (make-named-pred (lambda (v) (and (exact-integer? v) + (<= lo v hi))) + (lambda () + (format "exact integer in [~a, ~a]" lo hi)))) +(define (real-in lo hi) + (make-named-pred (lambda (v) (and (real? v) + (<= lo v hi))) + (lambda () + (format "real in [~a, ~a]" lo hi)))) + (define (make-procedure arity) (make-named-pred (lambda (p) (and (procedure? p) @@ -273,3 +285,15 @@ (define-syntax-rule (assert e) (void)) ; (define-syntax-rule (assert e) (unless e (error 'assert "failed: ~s" 'e))) + +(define (unimplemented c m args) (error (if c (method-name c m) m) "unimplemented; args were ~e" + args)) + +(define-syntax (def/public-unimplemented stx) + (syntax-case stx () + [(_ id) + (with-syntax ([cname (syntax-parameter-value #'class-name)]) + #'(define/public (id . args) (unimplemented 'cname 'id args)))])) + +(define-syntax-rule (define-unimplemented id) + (define (id . args) (unimplemented #f 'id args)))