126 lines
2.8 KiB
Racket
126 lines
2.8 KiB
Racket
#lang racket/load
|
|
|
|
#| This file is an attempt to show a different style of monitor
|
|
that doesn't record the event trace, but rather records the
|
|
pertinent information.
|
|
|#
|
|
|
|
(module lock racket
|
|
(require unstable/temp-c/monitor)
|
|
(define (use-resource f)
|
|
(define (protect label g)
|
|
(contract (monitor/c monitor label (-> void)) g
|
|
'pos 'neg))
|
|
|
|
(define locked? #f)
|
|
(define returned? #f)
|
|
(define (monitor evt)
|
|
(match evt
|
|
[(monitor:return 'user _ _ app _ _ _ _)
|
|
(set! returned? #t)]
|
|
[(monitor:return 'lock p _ _ _ _ _ _)
|
|
(set! locked? #t)]
|
|
[(monitor:return 'unlock p _ _ _ _ _ _)
|
|
(set! locked? #f)]
|
|
[_
|
|
(void)])
|
|
(and
|
|
(match evt
|
|
; Must not lock or unlock twice
|
|
[(monitor:call 'lock p _ _ _ _ _)
|
|
(not locked?)]
|
|
[(monitor:call 'unlock p _ _ _ _ _)
|
|
locked?]
|
|
; Must not use resource unless locked
|
|
[(monitor:call 'use p _ _ _ _ _)
|
|
locked?]
|
|
; Otherwise, okay
|
|
[_
|
|
#t])
|
|
; Must not use anything after return
|
|
(match evt
|
|
[(monitor:call 'lock p _ _ _ _ _)
|
|
(not returned?)]
|
|
[(monitor:call 'unlock p _ _ _ _ _)
|
|
(not returned?)]
|
|
[(monitor:call 'use p _ _ _ _ _)
|
|
(not returned?)]
|
|
; Otherwise, okay
|
|
[_
|
|
#t])))
|
|
|
|
((contract (monitor/c monitor 'user any/c) f
|
|
'pos 'neg)
|
|
(protect 'lock (λ () (void)))
|
|
(protect 'use (λ () (void)))
|
|
(protect 'unlock (λ () (void)))))
|
|
|
|
(provide/contract
|
|
[use-resource
|
|
(-> (-> (-> void) (-> void) (-> void)
|
|
any/c)
|
|
any/c)]))
|
|
|
|
(module tester racket
|
|
(require tests/eli-tester
|
|
'lock)
|
|
(test
|
|
(use-resource
|
|
(λ (lock use unlock)
|
|
(lock) (use) (unlock)
|
|
(lock) (use) (use) (unlock)))
|
|
=>
|
|
(void)
|
|
|
|
(use-resource
|
|
(λ (lock use unlock)
|
|
(lock) (use) (unlock)
|
|
(use-resource
|
|
(λ (lock1 use1 unlock1)
|
|
; Note out of order unlocking
|
|
(lock1) (lock)
|
|
(use) (use1)
|
|
(unlock1) (unlock)))
|
|
(lock) (use) (use) (unlock)))
|
|
=>
|
|
(void)
|
|
|
|
(use-resource
|
|
(λ (lock use unlock)
|
|
(use)))
|
|
=error>
|
|
"disallowed"
|
|
|
|
(use-resource
|
|
(λ (lock use unlock)
|
|
(lock) (use) (unlock) (unlock)))
|
|
=error>
|
|
"disallowed"
|
|
|
|
(use-resource
|
|
(λ (lock use unlock)
|
|
(lock) (lock)))
|
|
=error>
|
|
"disallowed"
|
|
|
|
(use-resource
|
|
(λ (lock use unlock)
|
|
(lock) (unlock) (use)))
|
|
=error>
|
|
"disallowed"
|
|
|
|
((use-resource (λ (lock use unlock) lock)))
|
|
=error>
|
|
"disallowed"
|
|
|
|
((use-resource (λ (lock use unlock) use)))
|
|
=error>
|
|
"disallowed"
|
|
|
|
((use-resource (λ (lock use unlock) unlock)))
|
|
=error>
|
|
"disallowed"
|
|
))
|
|
|
|
(require 'tester)
|