PasteRack.org
Paste # 42230
2017-03-29 10:49:36

Fork as a new paste.

Paste viewed 252 times.


Embed:

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

=>