0. #lang racket/base
1. (require racket/contract/base)
2.  
3. (define nonserial-add1 (lambda (i) "broken"))
4. (define serial-add1
5.   (let ()
6.     (local-require web-server/lang/serial-lambda)
7.     (serial-lambda (i) "broken")))
8.  
9. (define define-clo-add1
10.   (let ()
11.     (local-require web-server/private/define-closure)
12.     (define-closure clo-add1 (i) () "broken")
13.     (make-clo-add1 (λ () (values)))))
14.  
15. (define struct-add1
16.   (let ()
17.     (struct the-struct ()
18.       #:property prop:procedure
19.       (λ (_ i) "broken"))
20.     (the-struct)))
21.  
22. (define manual-clo-add1
23.   (let ()
24.     (define-values
25.       (struct:CLOSURE make-CLOSURE CLOSURE? CLOSURE-ref CLOSURE-set!)
26.       (make-struct-type
27.        'manual-clo-add1 ;; the tag goes here
28.        #f  ; no super type
29.        0
30.        0   ; number of auto-fields
31.        #f  ; auto-v
32.  
33.        ; prop-vals:
34.        (list
35.         (cons prop:procedure
36.               (make-keyword-procedure
37.                (lambda (kws kw-vals clsr . rst)
38.                  (keyword-apply (λ (i) "broken")
39.                                 kws kw-vals
40.                                 rst)))))
41.  
42.        #f  ; inspector
43.  
44.        ;; the struct apply proc:
45.        #f))
46.     (make-CLOSURE)))
47.  
48. (define kwstruct-add1
49.   (let ()
50.     (struct the-struct ()
51.       #:property prop:procedure
52.       (make-keyword-procedure (λ (kws kw-values _ i) "broken")))
53.     (the-struct)))
54.  
55. (define kw-add1
56.   (make-keyword-procedure (λ (kws kw-values i) "broken")))
57.  
58.   (require rackunit)
59.   (define ctc (-> number? number?))
60.   (define (t m f)
61.     (define ctc-f (contract ctc f 'pos 'neg))
62.     (check-equal? (f "bad arg") "broken" (format "~a equal" m))
63.     (check-exn exn:fail? (λ () (ctc-f "bad arg")) (format "~a arg" m))
64.     (check-exn exn:fail? (λ () (ctc-f 1)) (format "~a ret" m)))
65.   (t "serial" serial-add1)
66.   (t "non-serial" nonserial-add1)
67.   (t "define-closure" define-clo-add1)
68.   (t "manual-clo-add1" manual-clo-add1)
69.   (t "struct" struct-add1)
70.   (t "kw struct" kwstruct-add1)
71.   (t "kw-add1" kw-add1)

=>

syntax-local-lift-provide: not expanding in a module

run-time body

syntax-local-lift-provide: not expanding in a module

run-time body

serial-add1: undefined;

cannot reference an identifier before its definition

in module: 'm

define-clo-add1: undefined;

cannot reference an identifier before its definition

in module: 'm

-------------------- FAILURE name:       check-exn location:   eval:10:0 params:     (#<procedure:exn:fail?> #<procedure:temp13>) expression: (check-exn exn:fail? (λ () (ctc-f "bad arg"))) message:    "manual-clo-add1 arg" Check failure -------------------- -------------------- FAILURE name:       check-exn location:   eval:10:0 params:     (#<procedure:exn:fail?> #<procedure:temp18>) expression: (check-exn exn:fail? (λ () (ctc-f 1))) message:    "manual-clo-add1 ret" Check failure --------------------

-------------------- FAILURE name:       check-exn location:   eval:10:0 params:     (#<procedure:exn:fail?> #<procedure:temp13>) expression: (check-exn exn:fail? (λ () (ctc-f "bad arg"))) message:    "kw struct arg" Check failure -------------------- -------------------- FAILURE name:       check-exn location:   eval:10:0 params:     (#<procedure:exn:fail?> #<procedure:temp18>) expression: (check-exn exn:fail? (λ () (ctc-f 1))) message:    "kw struct ret" Check failure --------------------