| 1 | ;;;; synch.scm |
|---|
| 2 | ;;;; Kon Lovett, Mar '06 |
|---|
| 3 | |
|---|
| 4 | (declare |
|---|
| 5 | (usual-integrations) |
|---|
| 6 | (disable-interrupts) |
|---|
| 7 | (inline) |
|---|
| 8 | (fixnum) |
|---|
| 9 | (local) |
|---|
| 10 | (no-procedure-checks) |
|---|
| 11 | (no-bound-checks) ) |
|---|
| 12 | |
|---|
| 13 | ;;; |
|---|
| 14 | |
|---|
| 15 | (require-library srfi-18) |
|---|
| 16 | |
|---|
| 17 | ;;; |
|---|
| 18 | |
|---|
| 19 | (module synch ( |
|---|
| 20 | make-object/synch |
|---|
| 21 | object?/synch |
|---|
| 22 | set-object!/synch |
|---|
| 23 | synch |
|---|
| 24 | synch-with |
|---|
| 25 | call/synch |
|---|
| 26 | call-with/synch |
|---|
| 27 | apply/synch |
|---|
| 28 | apply-with/synch |
|---|
| 29 | let/synch |
|---|
| 30 | set!/synch |
|---|
| 31 | synch/lock |
|---|
| 32 | synch/unlock |
|---|
| 33 | object/synch |
|---|
| 34 | record/synch |
|---|
| 35 | record-synch/lock |
|---|
| 36 | record-synch/unlock |
|---|
| 37 | %synch-mutex* |
|---|
| 38 | %synch-mutex-with* |
|---|
| 39 | %synch |
|---|
| 40 | %synch-with |
|---|
| 41 | %call/synch |
|---|
| 42 | %call-with/synch |
|---|
| 43 | %apply/synch |
|---|
| 44 | %apply-with/synch |
|---|
| 45 | %let/synch |
|---|
| 46 | %set!/synch |
|---|
| 47 | %synch/lock |
|---|
| 48 | %synch/unlock |
|---|
| 49 | %object/synch |
|---|
| 50 | %record/synch |
|---|
| 51 | %record-synch/lock |
|---|
| 52 | %record-synch/unlock) |
|---|
| 53 | |
|---|
| 54 | (import |
|---|
| 55 | scheme |
|---|
| 56 | (only chicken |
|---|
| 57 | unless |
|---|
| 58 | warning |
|---|
| 59 | gensym |
|---|
| 60 | constantly |
|---|
| 61 | dynamic-wind) |
|---|
| 62 | (only srfi-18 |
|---|
| 63 | thread? |
|---|
| 64 | make-mutex |
|---|
| 65 | mutex? |
|---|
| 66 | mutex-specific mutex-specific-set! |
|---|
| 67 | mutex-lock! mutex-unlock! |
|---|
| 68 | mutex-state) ) |
|---|
| 69 | |
|---|
| 70 | ;;; |
|---|
| 71 | |
|---|
| 72 | (define-for-syntax (recmuxnam nam) |
|---|
| 73 | (string->symbol (conc nam #\- 'mutex)) ) |
|---|
| 74 | |
|---|
| 75 | ;;; |
|---|
| 76 | |
|---|
| 77 | (define (make-object/synch obj #!optional (name '(synchobj))) |
|---|
| 78 | (let ([mutex (make-mutex (if (pair? name) (gensym (car name)) name))]) |
|---|
| 79 | (mutex-specific-set! mutex obj) |
|---|
| 80 | mutex ) ) |
|---|
| 81 | |
|---|
| 82 | (define object?/synch |
|---|
| 83 | (let ([tpred (constantly #t)]) |
|---|
| 84 | (lambda (obj #!optional (pred tpred)) |
|---|
| 85 | (and (mutex? obj) |
|---|
| 86 | (let ([ms (mutex-specific obj)]) |
|---|
| 87 | (and (not (eq? (void) ms)) |
|---|
| 88 | (pred ms)) ) ) ) ) ) |
|---|
| 89 | |
|---|
| 90 | ;;; Synonyms |
|---|
| 91 | |
|---|
| 92 | (define-syntax set-object!/synch |
|---|
| 93 | (syntax-rules () |
|---|
| 94 | [(_ ?mutex ?obj) (mutex-specific-set! ?mutex ?obj) ] ) ) |
|---|
| 95 | |
|---|
| 96 | ;;; Protected |
|---|
| 97 | |
|---|
| 98 | (define-syntax synch |
|---|
| 99 | (syntax-rules () |
|---|
| 100 | [(_ ?mtx ?body ...) |
|---|
| 101 | (let ([mtx ?mtx]) |
|---|
| 102 | (dynamic-wind |
|---|
| 103 | (lambda () (mutex-lock! mtx)) |
|---|
| 104 | (lambda () ?body ...) |
|---|
| 105 | (lambda () (mutex-unlock! mtx)) ) ) ] ) ) |
|---|
| 106 | |
|---|
| 107 | (define-syntax synch-with |
|---|
| 108 | (lambda (form r c) |
|---|
| 109 | (##sys#check-syntax 'synch-with form '(_ _ variable . #(_ 0))) |
|---|
| 110 | (let ([$dynamic-wind (r 'dynamic-wind)] |
|---|
| 111 | [$let (r 'let)] |
|---|
| 112 | [$lambda (r 'lambda)] |
|---|
| 113 | [$mutex-unlock! (r 'mutex-unlock!)] |
|---|
| 114 | [$mutex-specific (r 'mutex-specific)] |
|---|
| 115 | [$mutex-lock! (r 'mutex-lock!)] |
|---|
| 116 | [mtxvar (r (gensym))]) |
|---|
| 117 | (let ([?mtx (cadr form)] [?var (caddr form)] [?body (cdddr form)]) |
|---|
| 118 | `(,$let ([,mtxvar ,?mtx]) |
|---|
| 119 | (,$let ([,?var (,$mutex-specific ,mtxvar)]) |
|---|
| 120 | (,$dynamic-wind |
|---|
| 121 | (,$lambda () (,$mutex-lock! ,mtxvar)) |
|---|
| 122 | (,$lambda () ,@?body) |
|---|
| 123 | (,$lambda () (,$mutex-unlock! ,mtxvar)) ) ) ) ) ) ) ) |
|---|
| 124 | |
|---|
| 125 | (define-syntax call/synch |
|---|
| 126 | (syntax-rules () |
|---|
| 127 | [(_ ?mtx ?proc ?arg0 ...) |
|---|
| 128 | (let ([mtx ?mtx]) |
|---|
| 129 | (dynamic-wind |
|---|
| 130 | (lambda () (mutex-lock! mtx)) |
|---|
| 131 | (lambda () (?proc ?arg0 ...)) |
|---|
| 132 | (lambda () (mutex-unlock! mtx)) ) ) ] ) ) |
|---|
| 133 | |
|---|
| 134 | (define-syntax call-with/synch |
|---|
| 135 | (syntax-rules () |
|---|
| 136 | [(_ ?mtx ?proc ?arg0 ...) |
|---|
| 137 | (let ([mtx ?mtx]) |
|---|
| 138 | (dynamic-wind |
|---|
| 139 | (lambda () (mutex-lock! mtx)) |
|---|
| 140 | (lambda () (?proc (mutex-specific mtx) ?arg0 ...)) |
|---|
| 141 | (lambda () (mutex-unlock! mtx)) ) ) ] ) ) |
|---|
| 142 | |
|---|
| 143 | (define-syntax apply/synch |
|---|
| 144 | (syntax-rules () |
|---|
| 145 | [(_ ?mtx ?proc ?arg0 ...) |
|---|
| 146 | (let ([mtx ?mtx]) |
|---|
| 147 | (dynamic-wind |
|---|
| 148 | (lambda () (mutex-lock! mtx)) |
|---|
| 149 | (lambda () (apply ?proc ?arg0 ...)) |
|---|
| 150 | (lambda () (mutex-unlock! mtx)) ) ) ] ) ) |
|---|
| 151 | |
|---|
| 152 | (define-syntax apply-with/synch |
|---|
| 153 | (syntax-rules () |
|---|
| 154 | [(_ ?mtx ?proc ?arg0 ...) |
|---|
| 155 | (let ([mtx ?mtx]) |
|---|
| 156 | (dynamic-wind |
|---|
| 157 | (lambda () (mutex-lock! mtx)) |
|---|
| 158 | (lambda () (apply ?proc (mutex-specific mtx) ?arg0 ...)) |
|---|
| 159 | (lambda () (mutex-unlock! mtx)) ) ) ] ) ) |
|---|
| 160 | |
|---|
| 161 | (define-syntax let/synch |
|---|
| 162 | (lambda (form r c) |
|---|
| 163 | (##sys#check-syntax 'let/synch form '(_ list . _)) |
|---|
| 164 | (let ([$synch-with (r 'synch-with)]) |
|---|
| 165 | (let ([?body (cddr form)]) |
|---|
| 166 | (car |
|---|
| 167 | (let loop ([?bnds (cadr form)]) |
|---|
| 168 | (if (not (null? ?bnds)) |
|---|
| 169 | (let ([bnd (car ?bnds)]) |
|---|
| 170 | (##sys#check-syntax 'let/synch bnd '(variable _)) |
|---|
| 171 | `((,$synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) ) |
|---|
| 172 | ?body ) ) ) ) ) ) ) |
|---|
| 173 | |
|---|
| 174 | (define-syntax set!/synch |
|---|
| 175 | (lambda (form r c) |
|---|
| 176 | (##sys#check-syntax 'set!/synch form '(_ pair . _)) |
|---|
| 177 | (let ([$synch-with (r 'synch-with)] |
|---|
| 178 | [$mutex-specific (r 'mutex-specific)] |
|---|
| 179 | [$mutex-specific-set! (r 'mutex-specific-set!)] |
|---|
| 180 | [$begin (r 'begin)]) |
|---|
| 181 | (let ([?bnd (cadr form)] [?body (cddr form)]) |
|---|
| 182 | (let ([?var (car ?bnd)] [?mtx (cadr ?bnd)]) |
|---|
| 183 | `(,$synch-with ,?mtx ,?var |
|---|
| 184 | (,$mutex-specific-set! ,?mtx (,$begin ,@?body)) |
|---|
| 185 | (,$mutex-specific ,?mtx) ) ) ) ) ) ) |
|---|
| 186 | |
|---|
| 187 | #; ;Since not capturing anything shouldn't need to do this |
|---|
| 188 | (define-syntax synch/lock |
|---|
| 189 | (lambda (form r c) |
|---|
| 190 | (##sys#check-syntax 'synch/lock form '(_ _ . _)) |
|---|
| 191 | (let ([$dynamic-wind (r 'dynamic-wind)] |
|---|
| 192 | [$unless (r 'unless)] |
|---|
| 193 | [$begin (r 'begin)] |
|---|
| 194 | [$let (r 'let)] |
|---|
| 195 | [$set! (r 'set!)] |
|---|
| 196 | [$lambda (r 'lambda)] |
|---|
| 197 | [$mutex-unlock! (r 'mutex-unlock!)] |
|---|
| 198 | [$mutex-specific (r 'mutex-specific)] |
|---|
| 199 | [$mutex-lock! (r 'mutex-lock!)] |
|---|
| 200 | [mtxvar (r (gensym))] |
|---|
| 201 | [okvar (r (gensym))] |
|---|
| 202 | [resvar (r (gensym))]) |
|---|
| 203 | (let ([?mtx (cadr form)] [?body (cddr form)]) |
|---|
| 204 | `(,$let ([,mtxvar ,?mtx] [,okvar #f]) |
|---|
| 205 | (,$dynamic-wind |
|---|
| 206 | (,$lambda () (,$mutex-lock! ,mtxvar)) |
|---|
| 207 | (,$lambda () (,$let ([,resvar (,$begin ,@?body)]) (,$set! ,okvar #t) ,resvar)) |
|---|
| 208 | (,$lambda () (,$unless ,okvar (,$mutex-unlock! ,mtxvar))) ) ) ) ) ) ) |
|---|
| 209 | |
|---|
| 210 | (define-syntax synch/lock |
|---|
| 211 | (syntax-rules () |
|---|
| 212 | [(_ ?mtx ?body ...) |
|---|
| 213 | (let ([mtx ?mtx] [ok? #f]) |
|---|
| 214 | (mutex-lock! mtx) |
|---|
| 215 | (dynamic-wind |
|---|
| 216 | (lambda () (mutex-lock! mtx)) |
|---|
| 217 | (lambda () (let ([res (begin ?body ...)]) (set! ok? #t) res)) |
|---|
| 218 | (lambda () (unless ok? (mutex-unlock! mtx)))) ) ] ) ) |
|---|
| 219 | |
|---|
| 220 | (define-syntax synch/unlock |
|---|
| 221 | (syntax-rules () |
|---|
| 222 | [(_ ?mtx ?body ...) |
|---|
| 223 | (let ([mtx ?mtx]) |
|---|
| 224 | (dynamic-wind |
|---|
| 225 | (lambda () |
|---|
| 226 | (unless (thread? (mutex-state mtx)) |
|---|
| 227 | (warning 'synch/unlock "mutex is not locked - locking") |
|---|
| 228 | (mutex-lock! mtx))) |
|---|
| 229 | (lambda () ?body ...) |
|---|
| 230 | (lambda () (mutex-unlock! mtx)) ) ) ] ) ) |
|---|
| 231 | |
|---|
| 232 | (define-syntax object/synch |
|---|
| 233 | (lambda (form r c) |
|---|
| 234 | (##sys#check-syntax 'object/synch form '(_ _ . _)) |
|---|
| 235 | (let ([$synch-with (r 'synch-with)] |
|---|
| 236 | [$>< (r '><)] |
|---|
| 237 | [var (r (gensym))] |
|---|
| 238 | [mtx (cadr form)]) |
|---|
| 239 | (let body-loop ([unparsed (cddr form)] [parsed '()]) |
|---|
| 240 | (if (not (null? unparsed)) |
|---|
| 241 | (let ([expr (car unparsed)] |
|---|
| 242 | [next (cdr unparsed)]) |
|---|
| 243 | (let expr-loop ([rest expr] [parsedexpr '()]) |
|---|
| 244 | (cond [(null? rest) |
|---|
| 245 | (body-loop next (cons (reverse parsedexpr) parsed))] |
|---|
| 246 | [(pair? rest) |
|---|
| 247 | (let ([arg (car rest)] |
|---|
| 248 | [next (cdr rest)]) |
|---|
| 249 | (if (c $>< arg) |
|---|
| 250 | (expr-loop next (cons var parsedexpr)) |
|---|
| 251 | (expr-loop next (cons arg parsedexpr)) ) )] |
|---|
| 252 | [(c $>< rest) |
|---|
| 253 | (body-loop next (cons var parsed))] |
|---|
| 254 | [else |
|---|
| 255 | (body-loop next (cons rest parsed))] ) ) ) |
|---|
| 256 | `(,$synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) |
|---|
| 257 | |
|---|
| 258 | (define-syntax record/synch |
|---|
| 259 | (lambda (form r c) |
|---|
| 260 | (##sys#check-syntax 'record/synch form '(_ variable _ . _)) |
|---|
| 261 | (let ([$synch (r 'synch)]) |
|---|
| 262 | (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)]) |
|---|
| 263 | `(,$synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) |
|---|
| 264 | |
|---|
| 265 | (define-syntax record-synch/lock |
|---|
| 266 | (lambda (form r c) |
|---|
| 267 | (##sys#check-syntax 'record-synch/lock form '(_ variable _ . _)) |
|---|
| 268 | (let ([$synch/lock (r 'synch/lock)]) |
|---|
| 269 | (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)]) |
|---|
| 270 | `(,$synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) |
|---|
| 271 | |
|---|
| 272 | (define-syntax record-synch/unlock |
|---|
| 273 | (lambda (form r c) |
|---|
| 274 | (##sys#check-syntax 'record-synch/unlock form '(_ variable _ . _)) |
|---|
| 275 | (let ([$synch/unlock (r 'synch/unlock)]) |
|---|
| 276 | (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)]) |
|---|
| 277 | `(,$synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) |
|---|
| 278 | |
|---|
| 279 | ;;; Unprotected |
|---|
| 280 | |
|---|
| 281 | (define-syntax %synch-mutex* |
|---|
| 282 | (syntax-rules () |
|---|
| 283 | [(_ ?mtx ?body ...) |
|---|
| 284 | (let ([mtx ?mtx]) |
|---|
| 285 | (mutex-lock! mtx) |
|---|
| 286 | (call-with-values |
|---|
| 287 | (lambda () ?body ...) |
|---|
| 288 | (lambda ret |
|---|
| 289 | (mutex-unlock! mtx) |
|---|
| 290 | (apply values ret))) ) ] ) ) |
|---|
| 291 | |
|---|
| 292 | (define-syntax %synch-mutex-with* |
|---|
| 293 | (lambda (form r c) |
|---|
| 294 | (##sys#check-syntax '%synch-mutex-with* form '(_ _ variable . _)) |
|---|
| 295 | (let ([$call-with-values (r 'call-with-values)] |
|---|
| 296 | [$mutex-specific (r 'mutex-specific)] |
|---|
| 297 | [$mutex-lock! (r 'mutex-lock!)] |
|---|
| 298 | [$mutex-unlock! (r 'mutex-unlock!)] |
|---|
| 299 | [$let (r 'let)] |
|---|
| 300 | [$apply (r 'apply)] |
|---|
| 301 | [$values (r 'values)] |
|---|
| 302 | [$lambda (r 'lambda)] |
|---|
| 303 | [$ret (r 'ret)] |
|---|
| 304 | [mtxvar (r (gensym))]) |
|---|
| 305 | (let ([?mtx (cadr form)] [?var (caddr form)] [?body (cdddr form)]) |
|---|
| 306 | `(,$let ([,mtxvar ,?mtx]) |
|---|
| 307 | (,$let ([,?var (,$mutex-specific ,mtxvar)]) |
|---|
| 308 | (,$mutex-lock! ,mtxvar) |
|---|
| 309 | (,$call-with-values |
|---|
| 310 | (,$lambda () ,@?body) |
|---|
| 311 | (,$lambda ,$ret |
|---|
| 312 | (,$mutex-unlock! ,mtxvar) |
|---|
| 313 | (,$apply ,$values ,$ret)) ) ) ) ) ) ) ) |
|---|
| 314 | |
|---|
| 315 | (define-syntax %synch |
|---|
| 316 | (syntax-rules () |
|---|
| 317 | [(_ ?mtx ?body ...) (%synch-mutex* ?mtx ?body ...) ] ) ) |
|---|
| 318 | |
|---|
| 319 | (define-syntax %synch-with |
|---|
| 320 | (syntax-rules () |
|---|
| 321 | [(_ ?mtx ?var ?body ...) (%synch-mutex-with* ?mtx ?var ?body ...) ] ) ) |
|---|
| 322 | |
|---|
| 323 | (define-syntax %call/synch |
|---|
| 324 | (syntax-rules () |
|---|
| 325 | [(_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (?proc ?arg0 ...)) ] ) ) |
|---|
| 326 | |
|---|
| 327 | (define-syntax %call-with/synch |
|---|
| 328 | (syntax-rules () |
|---|
| 329 | [(_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (?proc var ?arg0 ...)) ] ) ) |
|---|
| 330 | |
|---|
| 331 | (define-syntax %apply/synch |
|---|
| 332 | (syntax-rules () |
|---|
| 333 | [(_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (apply ?proc ?arg0 ...)) ] ) ) |
|---|
| 334 | |
|---|
| 335 | (define-syntax %apply-with/synch |
|---|
| 336 | (syntax-rules () |
|---|
| 337 | [(_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (apply ?proc var ?arg0 ...)) ] ) ) |
|---|
| 338 | |
|---|
| 339 | (define-syntax %let/synch |
|---|
| 340 | (lambda (form r c) |
|---|
| 341 | (##sys#check-syntax '%let/synch form '(_ list . _)) |
|---|
| 342 | (let ([$%synch-with (r '%synch-with)]) |
|---|
| 343 | (let ([?body (cddr form)]) |
|---|
| 344 | (car |
|---|
| 345 | (let loop ([?bnds (cadr form)]) |
|---|
| 346 | (if (not (null? ?bnds)) |
|---|
| 347 | (let ([bnd (car ?bnds)]) |
|---|
| 348 | (##sys#check-syntax '%let/synch bnd '(variable _)) |
|---|
| 349 | `((,$%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) ) |
|---|
| 350 | ?body ) ) ) ) ) ) ) |
|---|
| 351 | |
|---|
| 352 | (define-syntax %set!/synch |
|---|
| 353 | (lambda (form r c) |
|---|
| 354 | (##sys#check-syntax '%set!/synch form '(_ pair . _)) |
|---|
| 355 | (let ([$%synch-with (r '%synch-with)] |
|---|
| 356 | [$mutex-specific (r 'mutex-specific)] |
|---|
| 357 | [$mutex-specific-set! (r 'mutex-specific-set!)] |
|---|
| 358 | [$let (r 'let)] |
|---|
| 359 | [$begin (r 'begin)] |
|---|
| 360 | [mtxvar (r (gensym))]) |
|---|
| 361 | (let ([?bnd (cadr form)] [?body (cddr form)]) |
|---|
| 362 | (let ([?var (car ?bnd)] [?mtx (cadr ?bnd)]) |
|---|
| 363 | `(,$let ([,mtxvar ,?mtx]) |
|---|
| 364 | (,$%synch-with ,mtxvar ,?var |
|---|
| 365 | (,$mutex-specific-set! ,mtxvar (,$begin ,@?body)) |
|---|
| 366 | (,$mutex-specific ,mtxvar) ) ) ) ) ) ) ) |
|---|
| 367 | |
|---|
| 368 | (define-syntax %synch/lock |
|---|
| 369 | (syntax-rules () |
|---|
| 370 | [(_ ?mtx ?body ...) |
|---|
| 371 | (let ([mtx ?mtx] [ok? #f]) |
|---|
| 372 | (mutex-lock! mtx) |
|---|
| 373 | (call-with-values |
|---|
| 374 | (lambda () (let ([res (begin ?body ...)]) (set! ok? #t) res)) |
|---|
| 375 | (lambda ret |
|---|
| 376 | (unless ok? (mutex-unlock! mtx)) |
|---|
| 377 | (apply values ret))) ) ] ) ) |
|---|
| 378 | |
|---|
| 379 | (define-syntax %synch/unlock |
|---|
| 380 | (syntax-rules () |
|---|
| 381 | [(_ ?mtx ?body ...) |
|---|
| 382 | (let ([mtx ?mtx]) |
|---|
| 383 | (unless (thread? (mutex-state mtx)) |
|---|
| 384 | (warning '%synch/unlock "mutex is not locked - locking") |
|---|
| 385 | (mutex-lock! mtx)) |
|---|
| 386 | (call-with-values |
|---|
| 387 | (lambda () ?body ...) |
|---|
| 388 | (lambda ret |
|---|
| 389 | (mutex-unlock! mtx) |
|---|
| 390 | (apply values ret)) ) ) ] ) ) |
|---|
| 391 | |
|---|
| 392 | (define-syntax %object/synch |
|---|
| 393 | (lambda (form r c) |
|---|
| 394 | (##sys#check-syntax '%object/synch form '(_ _ . _)) |
|---|
| 395 | (let ([$%synch-with (r '%synch-with)] |
|---|
| 396 | [$>< (r '><)] |
|---|
| 397 | [var (r (gensym))] |
|---|
| 398 | [mtx (cadr form)]) |
|---|
| 399 | (let body-loop ([unparsed (cddr form)] [parsed '()]) |
|---|
| 400 | (if (not (null? unparsed)) |
|---|
| 401 | (let ([expr (car unparsed)] |
|---|
| 402 | [next (cdr unparsed)]) |
|---|
| 403 | (let expr-loop ([rest expr] [parsedexpr '()]) |
|---|
| 404 | (cond [(null? rest) |
|---|
| 405 | (body-loop next (cons (reverse parsedexpr) parsed))] |
|---|
| 406 | [(pair? rest) |
|---|
| 407 | (let ([arg (car rest)] |
|---|
| 408 | [next (cdr rest)]) |
|---|
| 409 | (if (c $>< arg) |
|---|
| 410 | (expr-loop next (cons var parsedexpr)) |
|---|
| 411 | (expr-loop next (cons arg parsedexpr)) ) )] |
|---|
| 412 | [(c $>< rest) |
|---|
| 413 | (body-loop next (cons var parsed))] |
|---|
| 414 | [else |
|---|
| 415 | (body-loop next (cons rest parsed))] ) ) ) |
|---|
| 416 | `(,$%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) |
|---|
| 417 | |
|---|
| 418 | (define-syntax %record/synch |
|---|
| 419 | (lambda (form r c) |
|---|
| 420 | (##sys#check-syntax '%record/synch form '(_ variable _ . _)) |
|---|
| 421 | (let ([$%synch (r '%synch)]) |
|---|
| 422 | (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)]) |
|---|
| 423 | `(,$%synch (,(recmuxnam ?sym) ,?rec) ?body ...) ) ) ) ) |
|---|
| 424 | |
|---|
| 425 | (define-syntax %record-synch/lock |
|---|
| 426 | (lambda (form r c) |
|---|
| 427 | (##sys#check-syntax '%record-synch/lock form '(_ variable _ . _)) |
|---|
| 428 | (let ([$%synch/lock (r '%synch/lock)]) |
|---|
| 429 | (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)]) |
|---|
| 430 | `(,$%synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) |
|---|
| 431 | |
|---|
| 432 | (define-syntax %record-synch/unlock |
|---|
| 433 | (lambda (form r c) |
|---|
| 434 | (##sys#check-syntax '%record-synch/unlock form '(_ variable _ . _)) |
|---|
| 435 | (let ([$%synch/unlock (r '%synch/unlock)]) |
|---|
| 436 | (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)]) |
|---|
| 437 | `(,$%synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) |
|---|
| 438 | |
|---|
| 439 | ) ;module synch |
|---|
