Changeset 35162 in project


Ignore:
Timestamp:
02/19/18 21:04:39 (7 months ago)
Author:
kon
Message:

add critical-region , add synchornized procedure

Location:
release/4/synch/trunk
Files:
1 added
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/synch/trunk/synch.meta

    r35091 r35162  
    1313(files
    1414  "synch.meta" "synch.setup"
    15   "synch.scm"
     15  "synch.scm" "critical-region.scm"
    1616  "tests/synch-test.scm" "tests/run.scm") )
  • release/4/synch/trunk/synch.scm

    r35094 r35162  
    4848  (define-operation-synch check-synch-with-object)
    4949  define-operation-%synch
     50  ;
     51  synchonized-procedure
     52  synchonized-procedure?
     53  synchonized-apply
    5054  ;;
    5155  ;DEPRECATED
     
    9599    mutex-lock! mutex-unlock!
    96100    mutex-state)
    97   (only type-checks define-check+error-type) )
     101  (only type-checks
     102    define-check+error-type
     103    check-procedure) )
    98104
    99105;;;
     
    690696;;
    691697
     698(define (synchonized-procedure proc)
     699  (make-synch-with-object proc 'synchonized-procedure) )
     700
     701(define (synchonized-procedure? obj)
     702  (synch-with-object? obj procedure?) )
     703
     704(define (synchonized-apply mtx . rest)
     705  (check-synch-with-object 'apply-synchonized-procedure mtx)
     706  (let-synch-with ((obj mtx))
     707    (let ((proc (check-procedure 'apply-synchonized-procedure obj)))
     708      (apply proc rest) ) ) )
     709
     710;;
     711
    692712;FIXME this API sucks
    693713
     
    783803            (_obj (rnm (gensym 'obj)))
    784804            (_mtx (rnm (gensym 'mtx))) )
    785         (let* ((prcnam (cadr frm))
    786                (newnam (%synch-wrapper-name prcnam)) )
     805        (let* (
     806          (prcnam (cadr frm))
     807          (newnam (%synch-wrapper-name prcnam)) )
     808          ;
    787809          `(,_define (,newnam ,_mtx+obj . ,_args)
    788810             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
     
    806828            (_mutex-specific-set! (rnm 'mutex-specific-set!))
    807829            (_begin (rnm 'begin)))
    808         (let ((?bnd (cadr frm))
    809               (?body (cddr frm)))
    810           (let ((?var (car ?bnd))
    811                 (?mtx (cadr ?bnd)))
     830        (let (
     831          (?bnd (cadr frm))
     832          (?body (cddr frm)) )
     833          (let (
     834            (?var (car ?bnd))
     835            (?mtx (cadr ?bnd)) )
     836            ;
    812837            `(,_synch-with ,?mtx ,?var
    813838               (,_mutex-specific-set! ,?mtx (,_begin ,@?body))
  • release/4/synch/trunk/synch.setup

    r35099 r35162  
    55(verify-extension-name 'synch)
    66
    7 (setup-shared-extension-module 'synch (extension-version "2.2.1")
     7(setup-shared-extension-module 'synch (extension-version "2.3.0")
    88  #:inline? #t
    99  #:types? #t
    1010  #:compile-options '(
    1111    -optimize-level 3 -debug-level 2))
     12
     13(setup-shared-extension-module 'critical-region (extension-version "2.3.0")
     14  #:inline? #t
     15  #:types? #t
     16  #:compile-options '(
     17    -optimize-level 3 -debug-level 2))
  • release/4/synch/trunk/tests/synch-test.scm

    r35094 r35162  
    8787;;
    8888
     89(use critical-region)
     90
     91(test-assert (critical-region #t))
     92
     93;;;
     94
     95(test-exit)
Note: See TracChangeset for help on using the changeset viewer.