From ba16e3158320cfe58ad7b1da9224a67940fbbd78 Mon Sep 17 00:00:00 2001
From: Carl Eastlund <cce@racket-lang.org>
Date: Mon, 6 Nov 2006 22:38:08 +0000
Subject: [PATCH] Added tests of tail-call behavior in object methods: - simple
 method calls - (inner ...) calls, default case - (inner ...) calls, augmented
 case - overridden methods - (super ...) calls in overridden methods

svn: r4797
---
 collects/tests/mzscheme/object.ss | 62 +++++++++++++++++++++++++++++++
 1 file changed, 62 insertions(+)

diff --git a/collects/tests/mzscheme/object.ss b/collects/tests/mzscheme/object.ss
index e8fe3cbba8..a0a66daaf7 100644
--- a/collects/tests/mzscheme/object.ss
+++ b/collects/tests/mzscheme/object.ss
@@ -1281,6 +1281,68 @@
       (define/public (get-fld) fld)))
   (test (list add1 4 (void) 12) 'send-fld (send (new c% [the-local-name add1]) get-fld)))
 
+;; ----------------------------------------
+;; Tail position behavior:
+
+(let* ([callee
+        (lambda ()
+          (with-continuation-mark
+           'tail 'callee
+           (continuation-mark-set->list
+            (current-continuation-marks)
+            'tail)))]
+       [superclass%
+        (class object%
+          (super-new)
+          (public-final simple-tail-method)
+          (pubment unaugmented-tail-method augmented-tail-method)
+          (public overridden-tail-method supercall-tail-method)
+
+          (define (simple-tail-method)
+            (callee))
+
+          (define (unaugmented-tail-method)
+            (inner (callee) unaugmented-tail-method))
+
+          (define (augmented-tail-method)
+            (inner (void) augmented-tail-method))
+
+          (define (overridden-tail-method)
+            (void))
+
+          (define (supercall-tail-method)
+            (callee)))]
+       [subclass%
+        (class superclass%
+          (super-new)
+          (augment augmented-tail-method)
+          (override overridden-tail-method supercall-tail-method)
+
+          (define (augmented-tail-method)
+            (callee))
+
+          (define (overridden-tail-method)
+            (callee))
+
+          (define (supercall-tail-method)
+            (super supercall-tail-method)))])
+
+  (define-syntax (test-call stx)
+    (syntax-case stx ()
+      [(form method)
+       (syntax/loc stx
+         (test '(callee)
+               'method
+               (with-continuation-mark
+                'tail 'caller
+                (send (new subclass%) method))))]))
+
+  (test-call simple-tail-method)
+  (test-call unaugmented-tail-method)
+  (test-call augmented-tail-method)
+  (test-call overridden-tail-method)
+  (test-call supercall-tail-method))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)