added test of let* unwinding, moved shared.rkt unit tests out here

collects/tests/stepper/automatic-tests.rkt

@@ -1,5 +1,10 @@
 #lang scheme
 
+
+;; run shared.rkt unit tests:
+(require "shared-unit-tests.rkt")
+
+;; now, the rest:
 (require "through-tests.ss" 
          "test-engine.ss")
 

collects/tests/stepper/shared-unit-tests.rkt

@@ -0,0 +1,62 @@
+#lang racket
+
+(require rackunit
+         stepper/private/shared)
+  
+; test cases taken from shared.rkt
+;
+(define (lifted-name sym) 
+  (syntax->datum (get-lifted-var sym)))
+(define cd-stx 
+  (datum->syntax #f 'cd))
+
+(check-equal? (lifted-name (datum->syntax #f 'ab)) 'lifter-ab-0)
+(check-equal? (lifted-name cd-stx) 'lifter-cd-1)
+(check-equal? (lifted-name (datum->syntax #f 'ef)) 'lifter-ef-2)
+(check-equal? (lifted-name cd-stx) 'lifter-cd-1)
+
+(check-equal? (map syntax-e (arglist->ilist #'(a b c))) '(a b c))
+(check-equal? (map syntax-e (arglist->ilist #'(a . (b c)))) '(a b c))
+(check-equal? (syntax-e (arglist->ilist #'a)) 'a)
+(let ([result (arglist->ilist #' (a b . c))])
+  (check-equal? (syntax-e (car result)) 'a)
+  (check-equal? (syntax-e (cadr result)) 'b)
+  (check-equal? (syntax-e (cddr result)) 'c))
+(check-equal? (map syntax-e (arglist-flatten #'(a b c))) '(a b c))
+(check-equal? (map syntax-e (arglist-flatten #'(a . (b c)))) '(a b c))
+(check-equal? (map syntax-e (arglist-flatten #'(a b . c))) '(a b c))
+(check-equal? (map syntax-e (arglist-flatten #'a)) '(a))
+
+(define new-queue (make-queue))
+(check-equal? (queue-push new-queue 1) (void))
+(check-equal? (queue-push new-queue 2) (void))
+(check-equal? (queue-pop new-queue) 1)
+(check-equal? (queue-push new-queue 3) (void))
+(check-equal? (queue-pop new-queue) 2)
+(check-equal? (queue-pop new-queue) 3)
+(check-exn exn:fail? (lambda () (queue-pop new-queue)))
+
+(check-equal?
+ (call-with-values (lambda ()
+                     (values-map (lambda (a b) (values (+ a b) (- a b)))
+                                 `(1 2 3 4 5)
+                                 `(9 8 7 6 5)))
+                   (lambda (sums diffs)
+                     (list sums diffs)))
+ `((10 10 10 10 10)
+   (-8 -6 -4 -2 0)))
+
+(check-exn exn:fail? (lambda () (stepper-syntax-property #`13 'boozle)))
+(check-exn exn:fail? (lambda () (stepper-syntax-property #`13 'boozle #t)))
+(check-equal? (stepper-syntax-property #`13 'stepper-hint) #f)
+(check-equal? (stepper-syntax-property (stepper-syntax-property #`13 'stepper-hint 'yes)
+                                       'stepper-hint) 'yes)
+(check-equal? 
+ (stepper-syntax-property (stepper-syntax-property (stepper-syntax-property #`13 
+                                                                            'stepper-hint
+                                                                            'no)
+                                                   'stepper-hint 'yes)
+                          'stepper-hint)
+ 'yes)
+(check-equal? (stepper-syntax-property (stepper-syntax-property (stepper-syntax-property #`13 'stepper-hint 'yes) 'stepper-black-box-expr 'arg) 'stepper-hint) 'yes)
+(check-equal? (syntax->datum (stepper-syntax-property (stepper-syntax-property #`13 'stepper-hint 'yes) 'stepper-black-box-expr 'arg)) 13)

collects/tests/stepper/through-tests.rkt

@@ -721,6 +721,14 @@
                     ((define a_0 9) (define b_1 6) (hilite 9)))
       (finished-stepping)))
 
+(let ([def '(define (f x) (let* ([a 13] [b 14]) (let* ([c 15] [d 16]) (+ a b c d))))])
+  (t1 'nested-let-unwinding
+      m:both-intermediates 
+      "(define (f x) (let* ([a 13] [b 14]) (let* ([c 15] [d 16]) (+ a b c d)))) (+ 3 4)"
+      `((before-after (,def (hilite (+ 3 4)))
+                      (,def (hilite 7)))
+        (finished-stepping))))
+
 ;;;;;;;;;;;;;
 ;;
 ;;  LETREC
@@ -762,6 +770,7 @@
           (before-after (,@defs (define gprime (hilite (letrec ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))
                         (,@defs (hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0))))
           (finished-stepping))))
+  
       ;;;;;;;;;;;;;
       ;;
       ;;  RECUR
@@ -2205,5 +2214,6 @@
                                   check-error check-error-bad))
       #;(run-tests '(teachpack-universe))
       #;(run-all-tests)
-      (run-test 'require-test)
+      #;(run-test 'let-lifting1)
+      (run-test 'nested-let-unwinding)
       ))