Changeset 35091 in project


Ignore:
Timestamp:
01/30/18 20:20:50 (7 months ago)
Author:
kon
Message:

add format-synch ex , growl idents , dep slashers

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

Legend:

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

    r26757 r35091  
    1010        (setup-helper "1.5.2")
    1111        (check-errors "1.12.1"))
    12 (test-depends miscmacros)
    13 (files "synch.release-info" "synch.meta" "synch.setup" "synch.scm" "tests/run.scm") )
     12(test-depends test miscmacros)
     13(files
     14  "synch.meta" "synch.setup"
     15  "synch.scm"
     16  "tests/synch-test.scm" "tests/run.scm") )
  • release/4/synch/trunk/synch.scm

    r34225 r35091  
    11;;;; synch.scm
     2;;;; Kon Lovett, Jan '18
    23;;;; Kon Lovett, May '17
    34;;;; Kon Lovett, Mar '06
     
    1314  synch
    1415  synch-with
     16  call-synch
     17  call-synch-with
     18  apply-synch
     19  apply-synch-with
     20  let-synch
     21  set!-synch
     22  synch-lock
     23  synch-unlock
     24  object-synch-cut-with
     25  record-synch
     26  record-synch-lock
     27  record-synch-unlock
     28  ;;
     29  %synch
     30  %synch-with
     31  %call-synch
     32  %call-synch-with
     33  %apply-synch
     34  %apply-synch-with
     35  %let-synch
     36  %set!-synch
     37  %synch-lock
     38  %synch-unlock
     39  %object-synch-cut-with
     40  %record-synch
     41  %record-synch-lock
     42  %record-synch-unlock
     43  ;;
     44  make-object-synch
     45  object?-synch
     46  define-constructor-synch
     47  define-predicate-synch
     48  (define-operation-synch check-mutex+object)
     49  define-operation-%synch
     50  ;;DEPRECATED
    1551  call/synch
    1652  call-with/synch
     
    2561  record-synch/lock
    2662  record-synch/unlock
    27   ;;
    28   %synch
    29   %synch-with
    3063  %call/synch
    3164  %call-with/synch
     
    4073  %record-synch/lock
    4174  %record-synch/unlock
    42   ;;
    4375  make-object/synch
    4476  object?/synch
    45   ;;
    4677  define-constructor/synch
    4778  define-predicate/synch
     
    4980  define-operation/%synch)
    5081
    51 (import scheme)
    52 
    5382(import
     83  scheme
    5484  (only chicken
     85    use
    5586    declare
    5687    define-for-syntax optional
    57     void unless warning gensym dynamic-wind)
    58   (only data-structures any?)
     88    void unless warning gensym dynamic-wind) )
     89(use
    5990  (only srfi-18
    6091    thread?
     
    6293    mutex-specific mutex-specific-set!
    6394    mutex-lock! mutex-unlock!
    64     mutex-state) )
    65 
    66 (import-for-syntax (only data-structures conc))
    67 
    68 (import (only type-checks define-check+error-type) )
    69 (require-library type-checks)
     95    mutex-state)
     96  (only type-checks define-check+error-type) )
    7097
    7198;;;
    7299
    73100(define-for-syntax (record-mutex-name nam)
    74   (string->symbol (conc nam #\- 'mutex)) )
     101  (string->symbol (string-append (symbol->string nam) "-" "mutex")) )
    75102
    76103;;; Protected
     
    124151                     (,_lambda () (,_mutex-unlock! ,mtxvar ,@?unlock-args)) ) ) ) ) ) ) ) ) ) )
    125152
    126 (define-syntax call/synch
     153(define-for-syntax  call-synch-transformer
    127154        (syntax-rules ()
    128155    ;
     
    135162    ;
    136163                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
    137                   (call/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
     164                  (call-synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    138165    ;
    139166                ((_ ?mtx ?proc ?arg0 ...)
    140                   (call/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
    141 
    142 (define-syntax call-with/synch
     167                  (call-synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
     168
     169(define-syntax call-synch call-synch-transformer)
     170;DEPRECATED
     171(define-syntax call/synch call-synch-transformer)
     172
     173(define-for-syntax  call-synch-with-transformer
    143174        (syntax-rules ()
    144175    ;
     
    151182    ;
    152183                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
    153                   (call-with/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
     184                  (call-synch-with (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    154185    ;
    155186                ((_ ?mtx ?proc ?arg0 ...)
    156                   (call-with/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
    157 
    158 (define-syntax apply/synch
     187                  (call-synch-with (?mtx () ()) ?proc ?arg0 ...) ) ) )
     188
     189(define-syntax call-synch-with call-synch-with-transformer)
     190;DEPRECATED
     191(define-syntax call-with/synch call-synch-with-transformer)
     192
     193(define-for-syntax  apply-synch-transformer
    159194        (syntax-rules ()
    160195          ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
     
    165200                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
    166201          ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
    167                   (apply/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
     202                  (apply-synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    168203    ;
    169204                ((_ ?mtx ?proc ?arg0 ...)
    170                   (apply/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
    171 
    172 (define-syntax apply-with/synch
     205                  (apply-synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
     206
     207(define-syntax apply-synch apply-synch-transformer)
     208;DEPRECATED
     209(define-syntax apply/synch apply-synch-transformer)
     210
     211(define-for-syntax  apply-synch-with-transformer
    173212        (syntax-rules ()
    174213    ;
     
    181220    ;
    182221                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
    183                   (apply-with/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
     222                  (apply-synch-with (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    184223    ;
    185224                ((_ ?mtx ?proc ?arg0 ...)
    186                   (apply-with/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
    187 
    188 (define-syntax let/synch
    189   (er-macro-transformer
    190     (lambda (frm rnm cmp)
    191       (##sys#check-syntax 'let/synch frm '(_ list . _))
     225                  (apply-synch-with (?mtx () ()) ?proc ?arg0 ...) ) ) )
     226
     227(define-syntax apply-synch-with apply-synch-with-transformer)
     228;DEPRECATED
     229(define-syntax apply-with/synch apply-synch-with-transformer)
     230
     231(define-for-syntax  let-synch-transformer
     232  (er-macro-transformer
     233    (lambda (frm rnm cmp)
     234      (##sys#check-syntax 'let-synch frm '(_ list . _))
    192235      (let ((_synch-with (rnm 'synch-with)))
    193236        (let* ((?body (cddr frm))
     
    197240                    ?body
    198241                    (let ((?bnd (car bnds)))
    199                       (##sys#check-syntax 'let/synch ?bnd '(variable . _))
     242                      (##sys#check-syntax 'let-synch ?bnd '(variable . _))
    200243                      `((,_synch-with ,(cadr ?bnd) ,(car ?bnd) ,@(loop (cdr bnds)))) ) ) ) ) )
    201244          (car res) ) ) ) ) )
    202245
    203 (define-syntax set!/synch
    204   (er-macro-transformer
    205     (lambda (frm rnm cmp)
    206       (##sys#check-syntax 'set!/synch frm '(_ pair . _))
     246(define-syntax let-synch let-synch-transformer)
     247;DEPRECATED
     248(define-syntax let/synch let-synch-transformer)
     249
     250(define-for-syntax  set!-synch-transformer
     251  (er-macro-transformer
     252    (lambda (frm rnm cmp)
     253      (##sys#check-syntax 'set!-synch frm '(_ pair . _))
    207254      (let ((_synch-with (rnm 'synch-with))
    208255            (_mutex-specific (rnm 'mutex-specific))
     
    217264               (,_mutex-specific ,?mtx) ) ) ) ) ) ) )
    218265
    219 ;;
    220 
    221 (define-syntax synch/lock
     266(define-syntax set!-synch set!-synch-transformer)
     267;DEPRECATED
     268(define-syntax set!/synch set!-synch-transformer)
     269
     270;;
     271
     272(define-for-syntax  synch-lock-transformer
    222273        (syntax-rules ()
    223274    ;
     
    231282    ;
    232283                ((_ ?mtx ?body ...)
    233                   (synch/lock (?mtx ()) ?body ...) ) ) )
    234 
    235 (define-syntax synch/unlock
     284                  (synch-lock (?mtx ()) ?body ...) ) ) )
     285
     286(define-syntax synch-lock synch-lock-transformer)
     287;DEPRECATED
     288(define-syntax synch/lock synch-lock-transformer)
     289
     290(define-for-syntax  synch-unlock-transformer
    236291        (syntax-rules ()
    237292    ;
     
    241296                                  (lambda ()
    242297                                          (unless (thread? (mutex-state mtx))
    243                                                   (warning 'synch/unlock "mutex is not locked - locking")
     298                                                  (warning 'synch-unlock "mutex is not locked - locking")
    244299                                                  (mutex-lock! mtx)))
    245300                                  (lambda () ?body ...)
     
    247302    ;
    248303                ((_ ?mtx ?body ...)
    249                   (synch/unlock (?mtx ()) ?body ...) ) ) )
    250 
    251 ;;
    252 
    253 (define-syntax object/synch
    254   (er-macro-transformer
    255     (lambda (frm rnm cmp)
    256       (##sys#check-syntax 'object/synch frm '(_ _ . _))
     304                  (synch-unlock (?mtx ()) ?body ...) ) ) )
     305
     306(define-syntax synch-unlock synch-unlock-transformer)
     307;DEPRECATED
     308(define-syntax synch/unlock synch-unlock-transformer)
     309
     310;;
     311
     312(define-for-syntax  object-synch-cut-with-transformer
     313  (er-macro-transformer
     314    (lambda (frm rnm cmp)
     315      (##sys#check-syntax 'object-synch-cut-with frm '(_ _ . _))
    257316      (let ((_synch-with (rnm 'synch-with))
    258317            (_>< (rnm '><))
     
    279338            `(,_synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
    280339
    281 ;;
    282 
    283 (define-syntax record/synch
    284   (er-macro-transformer
    285     (lambda (frm rnm cmp)
    286       (##sys#check-syntax 'record/synch frm '(_ symbol _ . _))
     340(define-syntax object-synch-cut-with object-synch-cut-with-transformer)
     341;DEPRECATED
     342(define-syntax object/synch object-synch-cut-with-transformer)
     343
     344;;
     345
     346(define-for-syntax  record-synch-transformer
     347  (er-macro-transformer
     348    (lambda (frm rnm cmp)
     349      (##sys#check-syntax 'record-synch frm '(_ symbol _ . _))
    287350      (let ((_synch (rnm 'synch)))
    288351        (let ((?sym (cadr frm))
     
    291354          `(,_synch (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    292355
    293 (define-syntax record-synch/lock
    294   (er-macro-transformer
    295     (lambda (frm rnm cmp)
    296       (##sys#check-syntax 'record-synch/lock frm '(_ symbol _ . _))
    297       (let ((_synch/lock (rnm 'synch/lock)))
     356(define-syntax record-synch record-synch-transformer)
     357;DEPRECATED
     358(define-syntax record/synch record-synch-transformer)
     359
     360(define-for-syntax  record-synch-lock-transformer
     361  (er-macro-transformer
     362    (lambda (frm rnm cmp)
     363      (##sys#check-syntax 'record-synch-lock frm '(_ symbol _ . _))
     364      (let ((_synch-lock (rnm 'synch-lock)))
    298365        (let ((?sym (cadr frm))
    299366              (?rec (caddr frm))
    300367              (?body (cdddr frm)))
    301           `(,_synch/lock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    302 
    303 (define-syntax record-synch/unlock
    304   (er-macro-transformer
    305     (lambda (frm rnm cmp)
    306       (##sys#check-syntax 'record-synch/unlock frm '(_ symbol _ . _))
    307       (let ((_synch/unlock (rnm 'synch/unlock)))
     368          `(,_synch-lock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
     369
     370(define-syntax record-synch-lock record-synch-lock-transformer)
     371;DEPRECATED
     372(define-syntax record-synch/lock record-synch-lock-transformer)
     373
     374(define-for-syntax  record-synch-unlock-transformer
     375  (er-macro-transformer
     376    (lambda (frm rnm cmp)
     377      (##sys#check-syntax 'record-synch-unlock frm '(_ symbol _ . _))
     378      (let ((_synch-unlock (rnm 'synch-unlock)))
    308379        (let ((?sym (cadr frm))
    309380              (?rec (caddr frm))
    310381              (?body (cdddr frm)))
    311           `(,_synch/unlock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    312 
     382          `(,_synch-unlock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
     383
     384(define-syntax record-synch-unlock record-synch-unlock-transformer)
     385;DEPRECATED
     386(define-syntax record-synch/unlock record-synch-unlock-transformer)
    313387
    314388;;; Unprotected
     
    379453                  (%*synch-with ?mtx ?var ?body ...) ) ) )
    380454
    381 (define-syntax %call/synch
     455(define-for-syntax  %call-synch-transformer
    382456        (syntax-rules ()
    383457                ((_ ?mtx ?proc ?arg0 ...)
    384458                  (%*synch ?mtx (?proc ?arg0 ...)) ) ) )
    385459
    386 (define-syntax %call-with/synch
     460(define-syntax %call-synch %call-synch-transformer)
     461;DEPRECATED
     462(define-syntax %call/synch %call-synch-transformer)
     463
     464(define-for-syntax  %call-synch-with-transformer
    387465        (syntax-rules ()
    388466                ((_ ?mtx ?proc ?arg0 ...)
    389467                  (%*synch-with ?mtx var (?proc var ?arg0 ...)) ) ) )
    390468
    391 (define-syntax %apply/synch
     469(define-syntax %call-synch-with %call-synch-with-transformer)
     470;DEPRECATED
     471(define-syntax %call-with/synch %call-synch-with-transformer)
     472
     473(define-for-syntax  %apply-synch-transformer
    392474        (syntax-rules ()
    393475                ((_ ?mtx ?proc ?arg0 ...)
    394476                  (%*synch ?mtx (apply ?proc ?arg0 ...)) ) ) )
    395477
    396 (define-syntax %apply-with/synch
     478(define-syntax %apply-synch %apply-synch-transformer)
     479;DEPRECATED
     480(define-syntax %apply/synch %apply-synch-transformer)
     481
     482(define-for-syntax  %apply-synch-with-transformer
    397483        (syntax-rules ()
    398484                ((_ ?mtx ?proc ?arg0 ...)
    399485                  (%*synch-with ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
    400486
    401 (define-syntax %let/synch
    402   (er-macro-transformer
    403     (lambda (frm rnm cmp)
    404       (##sys#check-syntax '%let/synch frm '(_ list . _))
     487(define-syntax %apply-synch-with %apply-synch-with-transformer)
     488;DEPRECATED
     489(define-syntax %apply-with/synch %apply-synch-with-transformer)
     490
     491(define-for-syntax  %let-synch-transformer
     492  (er-macro-transformer
     493    (lambda (frm rnm cmp)
     494      (##sys#check-syntax '%let-synch frm '(_ list . _))
    405495      (let ((_%synch-with (rnm '%synch-with)))
    406496        (let ((?body (cddr frm)))
     
    410500                ?body
    411501                (let ((bnd (car ?bnds)))
    412                   (##sys#check-syntax '%let/synch bnd '(variable _))
     502                  (##sys#check-syntax '%let-synch bnd '(variable _))
    413503                  `((,_%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) ) ) ) ) ) ) ) ) )
    414504
    415 (define-syntax %set!/synch
    416   (er-macro-transformer
    417     (lambda (frm rnm cmp)
    418       (##sys#check-syntax '%set!/synch frm '(_ pair . _))
     505(define-syntax %let-synch %let-synch-transformer)
     506;DEPRECATED
     507(define-syntax %let/synch %let-synch-transformer)
     508
     509(define-for-syntax  %set!-synch-transformer
     510  (er-macro-transformer
     511    (lambda (frm rnm cmp)
     512      (##sys#check-syntax '%set!-synch frm '(_ pair . _))
    419513      (let ((_%synch-with (rnm '%synch-with))
    420514            (_mutex-specific (rnm 'mutex-specific))
     
    432526                 (,_mutex-specific ,mtxvar) ) ) ) ) ) ) ) )
    433527
    434 ;;
    435 
    436 (define-syntax %synch/lock
     528(define-syntax %set!-synch %set!-synch-transformer)
     529;DEPRECATED
     530(define-syntax %set!/synch %set!-synch-transformer)
     531
     532;;
     533
     534(define-for-syntax  %synch-lock-transformer
    437535        (syntax-rules ()
    438536    ;
     
    447545    ;
    448546                ((_ ?mtx ?body ...)
    449                   (%synch/lock (?mtx ()) ?body ...) ) ) )
    450 
    451 (define-syntax %synch/unlock
     547                  (%synch-lock (?mtx ()) ?body ...) ) ) )
     548
     549(define-syntax %synch-lock %synch-lock-transformer)
     550;DEPRECATED
     551(define-syntax %synch/lock %synch-lock-transformer)
     552
     553(define-for-syntax  %synch-unlock-transformer
    452554        (syntax-rules ()
    453555    ;
     
    455557      (let ((mtx ?mtx))
    456558        (unless (thread? (mutex-state mtx))
    457           (warning '%synch/unlock "mutex is not locked - locking")
     559          (warning '%synch-unlock "mutex is not locked - locking")
    458560          (mutex-lock! mtx))
    459561        (call-with-values
     
    464566    ;
    465567                ((_ ?mtx ?body ...)
    466       (%synch/unlock (?mtx ()) ?body ...) ) ) )
    467 
    468 ;;
    469 
    470 (define-syntax %object/synch
    471   (er-macro-transformer
    472     (lambda (frm rnm cmp)
    473       (##sys#check-syntax '%object/synch frm '(_ _ . _))
     568      (%synch-unlock (?mtx ()) ?body ...) ) ) )
     569
     570(define-syntax %synch-unlock %synch-unlock-transformer)
     571;DEPRECATED
     572(define-syntax %synch/unlock %synch-unlock-transformer)
     573
     574;;
     575
     576(define-for-syntax  %object-synch-cut-with-transformer
     577  (er-macro-transformer
     578    (lambda (frm rnm cmp)
     579      (##sys#check-syntax '%object-synch-cut-with frm '(_ _ . _))
    474580      (let ((_%synch-with (rnm '%synch-with))
    475581            (_>< (rnm '><))
     
    496602            `(,_%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
    497603
    498 ;;
    499 
    500 (define-syntax %record/synch
    501   (er-macro-transformer
    502     (lambda (frm rnm cmp)
    503       (##sys#check-syntax '%record/synch frm '(_ symbol _ . _))
     604(define-syntax %object-synch-cut-with %object-synch-cut-with-transformer)
     605;DEPRECATED
     606(define-syntax %object/synch %object-synch-cut-with-transformer)
     607
     608;;
     609
     610(define-for-syntax  %record-synch-transformer
     611  (er-macro-transformer
     612    (lambda (frm rnm cmp)
     613      (##sys#check-syntax '%record-synch frm '(_ symbol _ . _))
    504614      (let ((_%synch (rnm '%synch)))
    505615        (let ((?sym (cadr frm))
     
    508618          `(,_%synch (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    509619
    510 (define-syntax %record-synch/lock
     620(define-syntax %record-synch %record-synch-transformer)
     621;DEPRECATED
     622(define-syntax %record/synch %record-synch-transformer)
     623
     624(define-for-syntax  %record-synch-lock-transformer
    511625  (er-macro-transformer
    512626  (lambda (frm rnm cmp)
    513     (##sys#check-syntax '%record-synch/lock frm '(_ symbol _ . _))
    514     (let ((_%synch/lock (rnm '%synch/lock)))
     627    (##sys#check-syntax '%record-synch-lock frm '(_ symbol _ . _))
     628    (let ((_%synch-lock (rnm '%synch-lock)))
    515629      (let ((?sym (cadr frm))
    516630            (?rec (caddr frm))
    517631            (?body (cdddr frm)))
    518         `(,_%synch/lock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    519 
    520 (define-syntax %record-synch/unlock
    521   (er-macro-transformer
    522     (lambda (frm rnm cmp)
    523       (##sys#check-syntax '%record-synch/unlock frm '(_ symbol _ . _))
    524       (let ((_%synch/unlock (rnm '%synch/unlock)))
     632        `(,_%synch-lock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
     633
     634(define-syntax %record-synch-lock %record-synch-lock-transformer)
     635;DEPRECATED
     636(define-syntax %record-synch/lock %record-synch-lock-transformer)
     637
     638(define-for-syntax  %record-synch-unlock-transformer
     639  (er-macro-transformer
     640    (lambda (frm rnm cmp)
     641      (##sys#check-syntax '%record-synch-unlock frm '(_ symbol _ . _))
     642      (let ((_%synch-unlock (rnm '%synch-unlock)))
    525643        (let ((?sym (cadr frm))
    526644              (?rec (caddr frm))
    527645              (?body (cdddr frm)))
    528           `(,_%synch/unlock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
    529 
     646          `(,_%synch-unlock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
     647
     648(define-syntax %record-synch-unlock %object-synch-cut-with-transformer)
     649;DEPRECATED
     650(define-syntax %record-synch/unlock %record-synch-unlock-transformer)
    530651
    531652;;; Synch Object
     653
     654(define (any? _)
     655  #t )
    532656
    533657(define (mutex+object? obj)
     
    540664;;
    541665
    542 (define (make-object/synch obj #!optional (name '(object/synch-)))
     666(define (make-object-synch obj #!optional (name '(object-synch-)))
    543667  (let ((mutex (make-mutex (if (pair? name) (gensym (car name)) name))))
    544668    (mutex-specific-set! mutex obj)
    545669    mutex ) )
    546670
    547 (define (object?/synch obj #!optional (pred any?))
     671(define (object?-synch obj #!optional (pred any?))
    548672  (and
    549673    (mutex+object? obj)
    550      (pred (mutex-specific obj))) )
    551 
    552 ;;
     674    (pred (mutex-specific obj))) )
    553675
    554676(define-for-syntax (synch-wrapper-name sym)
    555         (string->symbol (string-append (symbol->string sym) "/synch")) )
    556 
    557 (define-syntax define-constructor/synch
    558   (er-macro-transformer
    559     (lambda (frm rnm cmp)
    560       (##sys#check-syntax 'define-constructor/synch frm '(_ symbol . _))
     677        (string->symbol (string-append (symbol->string sym) "-" "synch")) )
     678
     679(define-syntax define-constructor-synch
     680  (er-macro-transformer
     681    (lambda (frm rnm cmp)
     682      (##sys#check-syntax 'define-constructor-synch frm '(_ symbol . _))
    561683      (let ((_define (rnm 'define))
    562684            (_apply (rnm 'apply))
    563685            (_args (rnm (gensym 'args)))
    564             (_make-object/synch (rnm 'make-object/synch)) )
     686            (_make-object-synch (rnm 'make-object-synch)) )
    565687        (let* ((prcnam (cadr frm))
    566688               (id (if (not (null? (cddr frm))) `('(,(caddr frm))) '()))
    567689               (newnam (synch-wrapper-name prcnam)) )
    568690          `(,_define (,newnam . ,_args)
    569              (,_make-object/synch (,_apply ,prcnam ,_args) ,@id)) ) ) ) ) )
    570 
    571 (define-syntax define-predicate/synch
    572   (er-macro-transformer
    573     (lambda (frm rnm cmp)
    574       (##sys#check-syntax 'define-predicate/synch frm '(_ symbol))
     691             (,_make-object-synch (,_apply ,prcnam ,_args) ,@id)) ) ) ) ) )
     692
     693(define-syntax define-predicate-synch
     694  (er-macro-transformer
     695    (lambda (frm rnm cmp)
     696      (##sys#check-syntax 'define-predicate-synch frm '(_ symbol))
    575697      (let ((_define (rnm 'define))
    576698            (_obj (rnm (gensym 'obj)))
    577             (_object?/synch (rnm 'object?/synch)) )
     699            (_object?-synch (rnm 'object?-synch)) )
    578700        (let* ((prcnam (cadr frm))
    579701               (newnam (synch-wrapper-name prcnam)) )
    580           `(,_define (,newnam ,_obj) (,_object?/synch ,_obj ,prcnam)) ) ) ) ) )
     702          `(,_define (,newnam ,_obj) (,_object?-synch ,_obj ,prcnam)) ) ) ) ) )
    581703
    582704;operand must be the 1st argument
    583 (define-syntax define-operation/synch
    584   (er-macro-transformer
    585     (lambda (frm rnm cmp)
    586       (##sys#check-syntax 'define-operation/synch frm '(_ symbol))
     705(define-syntax define-operation-synch
     706  (er-macro-transformer
     707    (lambda (frm rnm cmp)
     708      (##sys#check-syntax 'define-operation-synch frm '(_ symbol))
    587709      (let ((_define (rnm 'define))
    588710            (_apply (rnm 'apply))
     
    603725          `(,_define (,newnam ,_mtx+obj . ,_args)
    604726             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
    605                (,_check-mutex+object ',newnam ,_mtx 'object/synch)
     727               (,_check-mutex+object ',newnam ,_mtx 'object-synch)
    606728               (,_synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args))) ) ) ) ) ) )
    607729
    608 ;;
    609 
    610730;operand must be the 1st argument
    611 (define-syntax define-operation/%synch
     731(define-syntax define-operation-%synch
    612732  (er-macro-transformer
    613733    (lambda (frm rnm cmp)
    614734      ;
    615735      (define (%synch-wrapper-name sym)
    616         (string->symbol (string-append (symbol->string sym) "/%synch")) )
     736        (string->symbol (string-append (symbol->string sym) "-" "%synch")) )
    617737      ;
    618       (##sys#check-syntax 'define-operation/%synch frm '(_ symbol))
     738      (##sys#check-syntax 'define-operation-%synch frm '(_ symbol))
    619739      (let ((_define (rnm 'define))
    620740            (_apply (rnm 'apply))
     
    634754          `(,_define (,newnam ,_mtx+obj . ,_args)
    635755             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
     756               (,_check-mutex+object ',newnam ,_mtx 'object-synch)
     757                                                         (,_%synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args)) ) ) ) ) ) ) )
     758
     759;; ;DEPRECATED
     760
     761(define make-object/synch make-object-synch)
     762
     763(define object?/synch object?-synch)
     764
     765(define-for-syntax (synch/wrapper-name sym)
     766        (string->symbol (string-append (symbol->string sym) "/" "synch")) )
     767
     768(define-syntax define-constructor/synch
     769  (er-macro-transformer
     770    (lambda (frm rnm cmp)
     771      (##sys#check-syntax 'define-constructor/synch frm '(_ symbol . _))
     772      (let ((_define (rnm 'define))
     773            (_apply (rnm 'apply))
     774            (_args (rnm (gensym 'args)))
     775            (_make-object/synch (rnm 'make-object/synch)) )
     776        (let* ((prcnam (cadr frm))
     777               (id (if (not (null? (cddr frm))) `('(,(caddr frm))) '()))
     778               (newnam (synch/wrapper-name prcnam)) )
     779          `(,_define (,newnam . ,_args)
     780             (,_make-object/synch (,_apply ,prcnam ,_args) ,@id)) ) ) ) ) )
     781
     782(define-syntax define-predicate/synch
     783  (er-macro-transformer
     784    (lambda (frm rnm cmp)
     785      (##sys#check-syntax 'define-predicate/synch frm '(_ symbol))
     786      (let ((_define (rnm 'define))
     787            (_obj (rnm (gensym 'obj)))
     788            (_object?/synch (rnm 'object?/synch)) )
     789        (let* ((prcnam (cadr frm))
     790               (newnam (synch/wrapper-name prcnam)) )
     791          `(,_define (,newnam ,_obj) (,_object?/synch ,_obj ,prcnam)) ) ) ) ) )
     792
     793;operand must be the 1st argument
     794(define-syntax define-operation/synch
     795  (er-macro-transformer
     796    (lambda (frm rnm cmp)
     797      (##sys#check-syntax 'define-operation/synch frm '(_ symbol))
     798      (let ((_define (rnm 'define))
     799            (_apply (rnm 'apply))
     800            (_let (rnm 'let))
     801            (_car (rnm 'car))
     802            (_cdr (rnm 'cdr))
     803            (_if (rnm 'if))
     804            (_pair? (rnm 'pair?))
     805            (_synch-with (rnm 'synch-with))
     806            (_check-mutex+object (rnm 'check-mutex+object))
     807            (_mutex-specific (rnm 'mutex-specific))
     808            (_mtx+obj (rnm (gensym 'mtx+obj)))
     809            (_args (rnm (gensym 'args)))
     810            (_obj (rnm (gensym 'obj)))
     811            (_mtx (rnm (gensym 'mtx))) )
     812        (let* ((prcnam  (cadr frm))
     813               (newnam (synch/wrapper-name prcnam)) )
     814          `(,_define (,newnam ,_mtx+obj . ,_args)
     815             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
     816               (,_check-mutex+object ',newnam ,_mtx 'object/synch)
     817               (,_synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args))) ) ) ) ) ) )
     818
     819;operand must be the 1st argument
     820(define-syntax define-operation/%synch
     821  (er-macro-transformer
     822    (lambda (frm rnm cmp)
     823      ;
     824      (define (%synch/wrapper-name sym)
     825        (string->symbol (string-append (symbol->string sym) "/" "%synch")) )
     826      ;
     827      (##sys#check-syntax 'define-operation/%synch frm '(_ symbol))
     828      (let ((_define (rnm 'define))
     829            (_apply (rnm 'apply))
     830            (_let (rnm 'let))
     831            (_car (rnm 'car))
     832            (_cdr (rnm 'cdr))
     833            (_if (rnm 'if))
     834            (_pair? (rnm 'pair?))
     835            (_%synch-with (rnm '%synch-with))
     836            (_check-mutex+object (rnm 'check-mutex+object))
     837            (_mtx+obj (rnm (gensym 'mtx+obj)))
     838            (_args (rnm (gensym 'args)))
     839            (_obj (rnm (gensym 'obj)))
     840            (_mtx (rnm (gensym 'mtx))) )
     841        (let* ((prcnam (cadr frm))
     842               (newnam (%synch/wrapper-name prcnam)) )
     843          `(,_define (,newnam ,_mtx+obj . ,_args)
     844             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
    636845               (,_check-mutex+object ',newnam ,_mtx 'object/synch)
    637846                                                         (,_%synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args)) ) ) ) ) ) ) )
  • release/4/synch/trunk/synch.setup

    r34225 r35091  
    55(verify-extension-name 'synch)
    66
    7 (setup-shared-extension-module 'synch (extension-version "2.1.4")
     7(setup-shared-extension-module 'synch (extension-version "2.2.0")
    88  #:inline? #t
    99  #:types? #t
    1010  #:compile-options '(
    1111    -optimize-level 3 -debug-level 2))
     12
     13(setup-shared-extension-module 'format-synch (extension-version "2.2.0")
     14  #:inline? #t
     15  #:types? #t
     16  #:compile-options '(
     17    -optimize-level 3 -debug-level 2))
  • release/4/synch/trunk/tests/run.scm

    r34225 r35091  
    1 ;;;; synch test
    21
    3 (use srfi-18 srfi-69 synch miscmacros)
     2(define EGG-NAME "synch")
    43
    5 ;;
     4;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    65
    7 (define-syntax define-thread
    8         (syntax-rules ()
    9           ((_ ?ident ?body ...)
    10             (define ?ident
    11         (make-thread
    12           (lambda () ?body ...)
    13           '?ident) ) ) ) )
     6(use files)
     7
     8;no -disable-interrupts
     9(define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
     10
     11(define *args* (argv))
     12
     13(define (test-name #!optional (eggnam EGG-NAME))
     14  (string-append eggnam "-test") )
     15
     16(define (egg-name #!optional (def EGG-NAME))
     17  (cond
     18    ((<= 4 (length *args*))
     19      (cadddr *args*) )
     20    (def
     21      def )
     22    (else
     23      (error 'test "cannot determine egg-name") ) ) )
    1424
    1525;;;
    1626
    17 (define-record-type <foo>
    18   (make-<foo> x y mtx)
    19   <foo>?
    20   (x <foo>-x)
    21   (y <foo>-y)
    22   (mtx <foo>-mutex))
     27(set! EGG-NAME (egg-name))
    2328
    24 (define tfoo (make-<foo> 1 2 (make-mutex)))
    25 (print "*** prints 1 2 ***")
    26 (record/synch <foo> tfoo (print (<foo>-x tfoo) " " (<foo>-y tfoo)))
    27 (newline)
     29(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
     30  (let ((tstnam (test-name eggnam)))
     31    (print "*** csi ***")
     32    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
     33    (newline)
     34    (print "*** csc (" cscopts ") ***")
     35    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
     36    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
    2837
    29 ;;; Synchronize thread access to an object
     38(define (run-tests eggnams #!optional (cscopts *csc-options*))
     39  (for-each (cut run-test <> cscopts) eggnams) )
    3040
    31 ;;
     41;;;
    3242
    33 (define (hash-table-count ht)
    34   (##sys#check-structure ht 'hash-table 'hash-table-count)
    35   (hash-table-fold ht (lambda (k v a) (fx+ a 1)) 0) )
    36 
    37 ;;
    38 
    39 (define-constructor/synch make-hash-table hash-table/synch:)
    40 (define-predicate/synch hash-table?)
    41 (define-operation/synch hash-table-count)
    42 (define-operation/synch hash-table-set!)
    43 
    44 ;;
    45 
    46 (define +tht+ (make-hash-table/synch = number-hash))
    47 
    48 (define-constant READER-THREAD-LIMIT 20)
    49 
    50 (define-constant THREAD-SLEEP-MS 0 #;2000)
    51 
    52 ;; Greedy Reader
    53 
    54 (define-thread reader-thread
    55   (do ((n (hash-table-count/synch +tht+) (hash-table-count/synch +tht+)))
    56       ((fx= READER-THREAD-LIMIT n)
    57         (print "test hash-table count = " n " so quit"))
    58     (print "test hash-table count = " n)
    59     (thread-sleep! THREAD-SLEEP-MS) ) )
    60 
    61 ;; Cooperative Writer
    62 
    63 (define-thread writer-thread
    64   (repeat* 10
    65     (hash-table-set!/synch +tht+ it (number->string it))
    66     (hash-table-set!/synch +tht+ (* it 11) (number->string it))
    67     (thread-sleep! THREAD-SLEEP-MS)
    68     (thread-yield!) ) )
    69 
    70 ;;
    71 
    72 (thread-start! writer-thread)
    73 (thread-start! reader-thread)
    74 
    75 (thread-join! writer-thread)
    76 (thread-join! reader-thread)
     43(run-test)
Note: See TracChangeset for help on using the changeset viewer.