Changeset 33908 in project


Ignore:
Timestamp:
03/25/17 21:46:49 (2 months ago)
Author:
kon
Message:

mv serialize to adapter module

Location:
release/4/remote-mailbox
Files:
12 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/remote-mailbox/tags/2.1.0/remote-mailbox-client.scm

    r19860 r33908  
    88(module remote-mailbox-client
    99
    10   (;export
    11     ;; Common
    12     ; Parameters
    13     default-remote-mailbox-tcp-port
    14     default-remote-mailbox-hostname
    15     ;; Client
    16     ; Parameters
    17     default-remote-mailbox-connect
    18     default-remote-mailbox-serializer
    19     ; Operations
    20     remote-mailbox
    21     remote-mailbox?
    22     remote-mailbox-name
    23     remote-mailbox-hostname
    24     remote-mailbox-tcp-port
    25     remote-mailbox-connected?
    26     drop-remote-mailbox!
    27     drop-remote-mailboxes!
    28     remote-mailboxes
    29     remote-mailbox-send!)
     10(;export
     11  ;; Common
     12  ; Parameters
     13  default-remote-mailbox-tcp-port
     14  default-remote-mailbox-hostname
     15  ;; Client
     16  ; Parameters
     17  default-remote-mailbox-connect
     18  ; Operations
     19  remote-mailbox
     20  remote-mailbox?
     21  remote-mailbox-name
     22  remote-mailbox-hostname
     23  remote-mailbox-tcp-port
     24  remote-mailbox-connected?
     25  drop-remote-mailbox!
     26  drop-remote-mailboxes!
     27  remote-mailboxes
     28  remote-mailbox-send!)
    3029
    31   (import
    32     scheme
    33     chicken
    34     tcp
    35     (only srfi-18 make-mutex mutex-name)
    36     (only data-structures conc)
    37     (only miscmacros define-parameter)
    38     s11n
    39     mailbox
    40     synch
    41     lookup-table-synch
    42     (only type-checks check-procedure define-check+error-type)
    43     (only type-errors warning-argument-type)
    44     remote-mailbox-common)
     30(import scheme chicken)
    4531
    46   (require-library
    47     tcp srfi-18
    48     miscmacros s11n mailbox synch lookup-table-synch
    49     type-checks type-errors
    50     remote-mailbox-common)
     32(import
     33  tcp
     34  (only srfi-18 make-mutex mutex-name)
     35  (only data-structures conc)
     36  (only miscmacros define-parameter)
     37  mailbox
     38  synch
     39  lookup-table-synch
     40  (only type-checks check-procedure define-check+error-type)
     41  (only type-errors warning-argument-type)
     42  remote-mailbox-adapter
     43  remote-mailbox-packet
     44  remote-mailbox-common)
     45(require-library
     46  tcp srfi-18
     47  miscmacros mailbox synch lookup-table-synch
     48  type-checks type-errors
     49  remote-mailbox-adapter
     50  remote-mailbox-packet
     51  remote-mailbox-common)
    5152
    5253;;; Utilities
     
    5758
    5859(define-record-type remote-mailbox
    59         (*make-remote-mailbox name hstnam prtnum connect mutex input output)
    60         *remote-mailbox?
    61         (name remote-mailbox-name remote-mailbox-name-set!)
    62         (hstnam remote-mailbox-hostname)
    63         (prtnum remote-mailbox-tcp-port)
    64         (connect remote-mailbox-connect)
    65         (mutex remote-mailbox-mutex)
    66         (input remote-mailbox-input-port remote-mailbox-input-port-set!)
    67         (output remote-mailbox-output-port remote-mailbox-output-port-set!) )
     60  (*make-remote-mailbox name hstnam prtnum serializer connect mutex input output)
     61  *remote-mailbox?
     62  (name remote-mailbox-name remote-mailbox-name-set!)
     63  (hstnam remote-mailbox-hostname)
     64  (prtnum remote-mailbox-tcp-port)
     65  (serializer remote-mailbox-serializer)
     66  (connect remote-mailbox-connect)
     67  (mutex remote-mailbox-mutex)
     68  (input remote-mailbox-input-port remote-mailbox-input-port-set!)
     69  (output remote-mailbox-output-port remote-mailbox-output-port-set!) )
    6870
    69 (define (invalidate-remote-mailbox! rmb) (remote-mailbox-name-set! rmb #f))
    70 (define (valid-remote-mailbox? rmb) (->boolean (remote-mailbox-name rmb)))
     71(define (invalidate-remote-mailbox! rmb)
     72  (remote-mailbox-name-set! rmb #f) )
    7173
    72 (define (remote-mailbox-key rmb) (mutex-name (remote-mailbox-mutex rmb)))
     74(define (valid-remote-mailbox? rmb)
     75  (->boolean (remote-mailbox-name rmb)) )
     76
     77(define (remote-mailbox-key rmb)
     78  (mutex-name (remote-mailbox-mutex rmb)) )
    7379
    7480(define +remote-mailbox-key->remote-mailbox+ (make-dict/synch))
    7581
    7682(define (make-remote-mailbox-key name hostname tcp-port)
    77         (conc name #\@ hostname (if tcp-port (conc #\: tcp-port) "")) )
     83  (conc name #\@ hostname (if tcp-port (conc #\: tcp-port) "")) )
    7884
    7985(define (*remote-mailbox name hostname tcp-port connect)
    8086  (let ((key (make-remote-mailbox-key name hostname tcp-port)))
    81     (dict-indempotent-ref!/synch
    82       +remote-mailbox-key->remote-mailbox+
     87    (dict-indempotent-ref!/synch +remote-mailbox-key->remote-mailbox+
    8388      key
    8489      (lambda (def)
    85         (*make-remote-mailbox name hostname tcp-port connect (make-mutex key) #f #f))) ) )
     90        (*make-remote-mailbox
     91          name
     92          hostname tcp-port
     93          (serializer) connect
     94          (make-mutex key) #f #f))) ) )
    8695
    87 (define (*remote-mailbox-connected? rmb) (->boolean (remote-mailbox-output-port rmb)))
     96(define (*remote-mailbox-connected? rmb)
     97  (->boolean (remote-mailbox-output-port rmb)) )
    8898
    8999(define (connection/remote-mailbox rmb)
    90         (if (*remote-mailbox-connected? rmb) (remote-mailbox-output-port rmb)
    91       ; else make a connection
    92       (let-values (((in out)
    93                     (let ((connect (remote-mailbox-connect rmb))
    94                           (tcp-port (remote-mailbox-tcp-port rmb)) )
    95                       ; Allow hostname to carry service/portno
    96                       (if (not tcp-port) (connect (remote-mailbox-hostname rmb))
    97                           (connect (remote-mailbox-hostname rmb) tcp-port) ) ) ) )
    98         (remote-mailbox-input-port-set! rmb in)
    99         (remote-mailbox-output-port-set! rmb out)
    100         out )) )
     100  (if (*remote-mailbox-connected? rmb)
     101    (remote-mailbox-output-port rmb)
     102    ; else make a connection
     103    (let-values (
     104        ((in out)
     105          (let ((connect (remote-mailbox-connect rmb))
     106                (tcp-port (remote-mailbox-tcp-port rmb)) )
     107            ; Allow hostname to carry service/portno
     108            (if (not tcp-port)
     109              (connect (remote-mailbox-hostname rmb))
     110              (connect (remote-mailbox-hostname rmb) tcp-port) ) ) ) )
     111      (remote-mailbox-input-port-set! rmb in)
     112      (remote-mailbox-output-port-set! rmb out)
     113      out )) )
    101114
    102115(define (close-remote-mailbox-connection! rmb)
    103116  (close-input-port (remote-mailbox-input-port rmb))
    104         (remote-mailbox-input-port-set! rmb #f)
    105         (close-output-port (remote-mailbox-output-port rmb))
    106         (remote-mailbox-output-port-set! rmb #f)
    107         (invalidate-remote-mailbox! rmb) )
     117  (remote-mailbox-input-port-set! rmb #f)
     118  (close-output-port (remote-mailbox-output-port rmb))
     119  (remote-mailbox-output-port-set! rmb #f)
     120  (invalidate-remote-mailbox! rmb) )
    108121
    109122(define (*drop-remote-mailbox! rmb)
    110         (record/synch remote-mailbox rmb
     123  (record/synch remote-mailbox rmb
    111124    (close-remote-mailbox-connection! rmb)
    112     (dict-delete!/synch +remote-mailbox-key->remote-mailbox+ (remote-mailbox-key rmb)) ) )
     125    (dict-delete!/synch +remote-mailbox-key->remote-mailbox+
     126      (remote-mailbox-key rmb)) ) )
    113127
    114128(define-check+error-type remote-mailbox)
     
    118132;; Parameters
    119133
    120 (define-parameter default-remote-mailbox-serializer #f
    121   (lambda (x)
    122         (cond
    123           ((procedure? x) x)
    124       ((not x)        #f)
    125       (else
    126         (warning-argument-type 'default-remote-mailbox-serializer x 'procedure)
    127         (default-remote-mailbox-serializer))) ) )
    128 
    129134(define-parameter default-remote-mailbox-connect tcp-connect
    130135  (lambda (x)
    131         (cond
    132           ((procedure? x) x)
     136    (cond
     137      ((procedure? x)
     138        x )
     139      ((not x)
     140        tcp-connect )
    133141      (else
    134142        (warning-argument-type 'default-remote-mailbox-connect x 'procedure)
     
    137145;; Operations
    138146
    139 (define (remote-mailbox name #!key (hostname (default-remote-mailbox-hostname))
    140                                    (tcp-port (default-remote-mailbox-tcp-port))
    141                                    (connect (default-remote-mailbox-connect)))
    142         (check-mailbox-name 'remote-mailbox name 'name)
    143         (check-hostname 'remote-mailbox hostname 'hostname)
    144         (when tcp-port (check-tcp-port 'remote-mailbox tcp-port 'tcp-port))
    145         (check-procedure 'remote-mailbox connect 'connect)
    146         (*remote-mailbox name hostname tcp-port connect) )
     147(define (remote-mailbox name
     148          #!key
     149          (hostname (default-remote-mailbox-hostname))
     150          (tcp-port (default-remote-mailbox-tcp-port))
     151          (connect (default-remote-mailbox-connect)))
     152  (check-mailbox-name 'remote-mailbox name 'name)
     153  (check-hostname 'remote-mailbox hostname 'hostname)
     154  (when tcp-port (check-tcp-port 'remote-mailbox tcp-port 'tcp-port))
     155  (check-procedure 'remote-mailbox connect 'connect)
     156  (*remote-mailbox name hostname tcp-port connect) )
    147157
    148158(define (remote-mailbox? obj)
    149         (and (*remote-mailbox? obj) (valid-remote-mailbox? obj)) )
     159  (and (*remote-mailbox? obj) (valid-remote-mailbox? obj)) )
    150160
    151161(define (remote-mailbox-connected? rmb)
    152         (check-remote-mailbox 'remote-mailbox-connected? rmb)
    153         (*remote-mailbox-connected? rmb) )
     162  (check-remote-mailbox 'remote-mailbox-connected? rmb)
     163  (*remote-mailbox-connected? rmb) )
    154164
    155165(define (remote-mailboxes)
    156         (dict-values/synch +remote-mailbox-key->remote-mailbox+) )
     166  (dict-values/synch +remote-mailbox-key->remote-mailbox+) )
    157167
    158168(define (drop-remote-mailbox! rmb)
    159         (check-remote-mailbox 'drop-remote-mailbox! rmb)
    160         (*drop-remote-mailbox! rmb) )
     169  (check-remote-mailbox 'drop-remote-mailbox! rmb)
     170  (*drop-remote-mailbox! rmb) )
    161171
    162172(define (drop-remote-mailboxes!)
    163173  (for-each (cut *drop-remote-mailbox! <>) (remote-mailboxes)) )
    164174
    165 (define (remote-mailbox-send! rmb val #!optional (serializer (default-remote-mailbox-serializer)))
    166         (check-remote-mailbox 'remote-mailbox-send! rmb)
    167         (when serializer (check-procedure 'remote-mailbox serializer 'serializer))
    168         (record/synch remote-mailbox rmb
    169                 (let ((out (connection/remote-mailbox rmb))
    170                       (req (make-remote-mailbox-packet (remote-mailbox-name rmb) val)) )
    171                         (serialize req out serializer) ) ) )
     175(define (remote-mailbox-send! rmb val)
     176  (check-remote-mailbox 'remote-mailbox-send! rmb)
     177  (record/synch remote-mailbox rmb
     178    (let ((out (connection/remote-mailbox rmb))
     179          (req (make-remote-mailbox-packet (remote-mailbox-name rmb) val)) )
     180      (parameterize ((serializer (remote-mailbox-serializer rmb)))
     181        (serialize req out) ) ) ) )
    172182
    173183) ;module remote-mailbox-client
  • release/4/remote-mailbox/tags/2.1.0/remote-mailbox-common.scm

    r19860 r33908  
    44(module remote-mailbox-common
    55
    6   (;export
    7     ;;
    8     mailbox-name?
    9     tcp-port?
    10     hostname?
    11     error-mailbox-name
    12     error-tcp-port
    13     error-hostname
    14     check-mailbox-name
    15     check-tcp-port
    16     check-hostname
    17     ;;
    18     make-remote-mailbox-packet
    19     remote-mailbox-packet?
    20     remote-mailbox-packet-key
    21     remote-mailbox-packet-value
    22     ;;
    23     default-remote-mailbox-tcp-port
    24     default-remote-mailbox-hostname)
     6(;export
     7  ;;
     8  mailbox-name?
     9  tcp-port?
     10  hostname?
     11  error-mailbox-name
     12  error-tcp-port
     13  error-hostname
     14  check-mailbox-name
     15  check-tcp-port
     16  check-hostname
     17  ;;
     18  default-remote-mailbox-tcp-port
     19  default-remote-mailbox-hostname)
    2520
    26   (import
    27     scheme
    28     chicken
    29     (only srfi-13 string-null?)
    30     (only miscmacros define-parameter)
    31     (only type-checks define-check+error-type))
     21(import scheme chicken)
    3222
    33   (require-library srfi-13 miscmacros type-checks)
     23(import
     24  (only srfi-13 string-null?)
     25  (only miscmacros define-parameter)
     26  (only type-errors warning-argument-type)
     27  (only type-checks define-check+error-type))
     28(require-library srfi-13 miscmacros type-errors type-checks)
     29
     30;;;
     31
     32(define-constant DEFAULT-TCP-PORT 63001)
     33(define-constant DEFAULT-HOSTNAME "localhost")
    3434
    3535;;;
     
    3737(define mailbox-name? symbol?)
    3838
    39 (define (tcp-port? obj) (and (fixnum? obj) (and (fx< 0 obj) (fx< obj 65536))))
     39(define (tcp-port? obj)
     40  (and
     41    (fixnum? obj)
     42    (and (fx< 0 obj) (fx< obj 65536))) )
    4043
    41 (define (hostname? obj) (and (string? obj) (not (string-null? obj))))
     44(define (hostname? obj)
     45  (and
     46    (string? obj)
     47    (not (string-null? obj))) )
    4248
    4349;;;
     
    4753(define-check+error-type tcp-port)
    4854
    49 ;;; Remote Mailbox Packet
    50 
    51 (define +remote-mailbox-tag+ 'rmbtag)
    52 
    53 (define (make-remote-mailbox-packet key val) (vector +remote-mailbox-tag+ key val))
    54 
    55 (define (remote-mailbox-packet? obj)
    56         (and (vector? obj)
    57                          (= 3 (vector-length obj))
    58                          (eq? +remote-mailbox-tag+ (vector-ref obj 0))) )
    59 
    60 (define (remote-mailbox-packet-key rmp) (vector-ref rmp 1))
    61 
    62 (define (remote-mailbox-packet-value rmp) (vector-ref rmp 2))
    63 
    6455;;; Parameters
    6556
    66 (define-parameter default-remote-mailbox-tcp-port 63001
     57(define-parameter default-remote-mailbox-tcp-port DEFAULT-TCP-PORT
    6758        (lambda (x)
    68                 (cond ((tcp-port? x) x)
    69           (else (default-remote-mailbox-tcp-port) ) ) ) )
     59                (cond
     60                  ((tcp-port? x)  x )
     61                  ((not x)        DEFAULT-TCP-PORT )
     62      (else
     63        (warning-argument-type 'default-remote-mailbox-tcp-port x 'procedure)
     64        (default-remote-mailbox-tcp-port) ) ) ) )
    7065
    71 (define-parameter default-remote-mailbox-hostname "localhost"
     66(define-parameter default-remote-mailbox-hostname DEFAULT-HOSTNAME
    7267        (lambda (x)
    73                 (cond ((hostname? x) x)
    74           (else (default-remote-mailbox-hostname) ) ) ) )
     68                (cond
     69                  ((hostname? x)  x )
     70                  ((not x)        DEFAULT-HOSTNAME )
     71      (else
     72        (warning-argument-type 'default-remote-mailbox-hostname x 'procedure)
     73        (default-remote-mailbox-hostname) ) ) ) )
    7574
    7675) ;module remote-mailbox-common
  • release/4/remote-mailbox/tags/2.1.0/remote-mailbox-server.scm

    r19860 r33908  
    99(module remote-mailbox-server
    1010
    11   (;export
    12     ;; Common
    13     ; Parameters
    14     default-remote-mailbox-tcp-port
    15     default-remote-mailbox-hostname
    16     ;; Server
    17     ; Parameters
    18     default-remote-mailbox-deserializer
    19     default-remote-mailbox-listen
    20     default-remote-mailbox-auto-create?
    21     ; Operations
    22     make-remote-mailbox-server
    23     make-remote-mailbox-server-thread
    24     local-mailbox/server
    25     drop-local-mailbox!/server
    26     local-mailbox-names/server
    27     remote-mailbox-server-run!
    28     remote-mailbox-server-start!
    29     ;; Queries
    30     remote-mailbox-server?
    31     remote-mailbox-server-name
    32     remote-mailbox-server-auto-create?
    33     remote-mailbox-server-deserializer
    34     remote-mailbox-server-listener
    35     remote-mailbox-server-request-limit
    36     remote-mailbox-server-debug
    37     ;; Convenience
    38     local-mailbox-server
    39     local-mailbox-thread
    40     local-mailbox-start!
    41     local-mailbox)
    42 
    43   (import
    44     scheme
    45     chicken
    46     (only srfi-18 make-thread thread-start! mutex-name)
    47     (only data-structures identity)
    48     tcp
    49     (only miscmacros define-parameter while)
    50     tcp-server
    51     s11n
    52     mailbox
    53     lookup-table-synch
    54     type-checks
    55     type-errors
    56     condition-utils
    57     remote-mailbox-common)
    58 
    59   (require-library
    60     srfi-18 data-structures tcp
    61     tcp-server s11n mailbox miscmacros lookup-table-synch type-checks
    62     condition-utils
    63     remote-mailbox-common)
     11(;export
     12  ;; Common
     13  ; Parameters
     14  default-remote-mailbox-tcp-port
     15  default-remote-mailbox-hostname
     16  ;; Server
     17  ; Parameters
     18  default-remote-mailbox-listen
     19  default-remote-mailbox-auto-create?
     20  ; Operations
     21  make-remote-mailbox-server
     22  make-remote-mailbox-server-thread
     23  local-mailbox/server
     24  drop-local-mailbox!/server
     25  local-mailbox-names/server
     26  remote-mailbox-server-run!
     27  remote-mailbox-server-start!
     28  remote-mailbox-server-stop!
     29  ;; Queries
     30  remote-mailbox-server?
     31  remote-mailbox-server-name
     32  remote-mailbox-server-auto-create?
     33  remote-mailbox-server-listener
     34  remote-mailbox-server-request-limit
     35  remote-mailbox-server-debug
     36  ;; Convenience
     37  local-mailbox-server
     38  local-mailbox-thread
     39  local-mailbox-start!
     40  local-mailbox)
     41
     42(import scheme chicken)
     43
     44(import
     45  (only srfi-18 make-thread thread-start! mutex-name thread-join!)
     46  (only data-structures identity)
     47  tcp
     48  (only miscmacros define-parameter while)
     49  tcp-server
     50  mailbox
     51  lookup-table-synch
     52  type-checks
     53  type-errors
     54  condition-utils
     55  remote-mailbox-adapter
     56  remote-mailbox-packet
     57  remote-mailbox-common)
     58(require-library
     59  srfi-18 data-structures tcp
     60  tcp-server mailbox miscmacros lookup-table-synch type-checks
     61  condition-utils
     62  remote-mailbox-adapter
     63  remote-mailbox-packet
     64  remote-mailbox-common)
    6465
    6566;;; Conditions
     
    7677
    7778(define (remote-mailbox-server-request-exception rmbs . args)
    78   (abort (make-remote-mailbox-server-condition "unknown remote mailbox client request"  rmbs args 'request)) )
     79  (abort (make-remote-mailbox-server-condition "unknown remote mailbox client request" rmbs args 'request)) )
    7980
    8081;;; Server Side
     
    8384
    8485(define-record-type remote-mailbox-server
    85   (*make-remote-mailbox-server dctm nm autof desrl srvr lstnr rlim dbg thrd)
     86  (*make-remote-mailbox-server dctm nm autof desrl srvr thread lstnr rlim dbg thrd)
    8687  remote-mailbox-server?
    8788  (dctm remote-mailbox-server-dict/synch)
     
    9091  (desrl remote-mailbox-server-deserializer)
    9192  (srvr remote-mailbox-server-tcp-server remote-mailbox-server-tcp-server-set!)
     93  (thread remote-mailbox-server-thread remote-mailbox-server-thread-set!)
    9294  (lstnr remote-mailbox-server-listener)
    9395  (rlim remote-mailbox-server-request-limit)
     
    98100(define-constant default-request-count-limit 10000)
    99101
    100 (define-parameter default-remote-mailbox-deserializer #f
    101   (lambda (x)
    102         (cond
    103           ((procedure? x)   x)
    104       ((not x)          #f)
    105       (else
    106         (warning-argument-type 'default-remote-mailbox-deserializer x 'procedure)
    107         (default-remote-mailbox-deserializer) ) ) ) )
    108 
    109102(define-parameter default-remote-mailbox-listen tcp-listen
    110103  (lambda (x)
    111         (cond
    112           ((procedure? x) x)
     104    (cond
     105      ((procedure? x)
     106        x )
     107      ((not x)
     108        tcp-listen )
    113109      (else
    114110        (warning-argument-type 'default-remote-mailbox-listen x 'procedure)
     
    122118
    123119(define (*local-mailbox/server rmbs name create?)
    124         (dict-indempotent-ref!/synch
     120  (dict-indempotent-ref!/synch
    125121    (remote-mailbox-server-dict/synch rmbs)
    126122    name
    127123    (lambda (def) (if create? (make-mailbox name) def))) )
    128124
    129 (define ((make-remote-mailbox-server-thunk rmbs))
    130   (while (not (eof-object? (peek-char (current-input-port))))
    131     (let ((req (deserialize (current-input-port) (remote-mailbox-server-deserializer rmbs))))
    132       (cond ((eq? (void) req) ) ;ignore void transmissions
    133             ((remote-mailbox-packet? req)
    134               (let* ((nam (remote-mailbox-packet-key req))
    135                      (lmb (*local-mailbox/server rmbs nam (remote-mailbox-server-auto-create? rmbs))) )
    136                 (if lmb (mailbox-send! lmb (remote-mailbox-packet-value req))
    137                     (remote-mailbox-server-mailbox-exception rmbs nam)) ) )
    138             (else
    139               (remote-mailbox-server-request-exception rmbs req) ) ) ) ) )
     125(define ((make-remote-mailbox-server-thunk rmbs) #!optional (inp (current-input-port)))
     126  (while (not (eof-object? (peek-char inp)))
     127    (let ((req
     128            (parameterize ((deserializer (remote-mailbox-server-deserializer rmbs)))
     129              (deserialize inp))))
     130      (cond
     131        ((eq? (void) req)
     132          ;ignore void transmissions
     133          )
     134        ((remote-mailbox-packet? req)
     135          (let* ((nam (remote-mailbox-packet-key req))
     136                 (lmb
     137                  (*local-mailbox/server
     138                    rmbs nam (remote-mailbox-server-auto-create? rmbs))) )
     139            (if lmb
     140              (mailbox-send! lmb (remote-mailbox-packet-value req))
     141              (remote-mailbox-server-mailbox-exception rmbs nam)) ) )
     142        (else
     143          (remote-mailbox-server-request-exception rmbs req) ) ) ) ) )
    140144
    141145(define (*remote-mailbox-server-run! rmbs)
    142         ((remote-mailbox-server-tcp-server rmbs) (remote-mailbox-server-debug rmbs)) )
     146  ((remote-mailbox-server-tcp-server rmbs) (remote-mailbox-server-debug rmbs)) )
    143147
    144148(define (*make-remote-mailbox-server-thread rmbs)
    145   (make-thread (lambda () (*remote-mailbox-server-run! rmbs)) (remote-mailbox-server-name rmbs)) )
     149  (remote-mailbox-server-thread-set! rmbs
     150    (make-thread
     151      (lambda () (*remote-mailbox-server-run! rmbs))
     152      (remote-mailbox-server-name rmbs)))
     153  (remote-mailbox-server-thread rmbs) )
    146154
    147155(define (*remote-mailbox-server-start! rmbs)
    148         (thread-start! (*make-remote-mailbox-server-thread rmbs)) )
     156  (thread-start! (*make-remote-mailbox-server-thread rmbs)) )
     157
     158(define (*remote-mailbox-server-stop! rmbs)
     159  (tcp-close (remote-mailbox-server-listener rmbs))
     160  (handle-exceptions ex
     161     (void)
     162    (thread-join! (remote-mailbox-server-thread rmbs)) ) )
    149163
    150164;; Exported
    151165
    152166(define (make-remote-mailbox-server
    153           #!key (tcp-port (default-remote-mailbox-tcp-port))
    154                 (listen (default-remote-mailbox-listen))
    155                 (deserializer (default-remote-mailbox-deserializer))
    156                 (name (gensym 'remote-mailbox-server:))
    157                 (auto-create? (default-remote-mailbox-auto-create?))
    158                 (request-limit default-request-count-limit)
    159                 debug)
    160         (check-tcp-port 'make-remote-mailbox-server tcp-port 'tcp-port)
    161         (check-procedure 'make-remote-mailbox-server listen 'listen)
    162         (when deserializer (check-procedure 'make-remote-mailbox-server deserializer 'deserializer))
    163         (check-fixnum 'make-remote-mailbox-server request-limit 'request-limit)
    164   (let* ((listener (listen tcp-port))
    165          (rmbs (*make-remote-mailbox-server (make-dict/synch) name auto-create?
    166                                             deserializer #f listener request-limit
    167                                             debug #f))
    168          (tcps (make-tcp-server listener
    169                                 (make-remote-mailbox-server-thunk rmbs)
    170                                 request-limit)) )
     167          #!key
     168          (tcp-port (default-remote-mailbox-tcp-port))
     169          (listen (default-remote-mailbox-listen))
     170          (name (gensym 'remote-mailbox-server:))
     171          (auto-create? (default-remote-mailbox-auto-create?))
     172          (request-limit default-request-count-limit)
     173          debug)
     174  (check-tcp-port 'make-remote-mailbox-server tcp-port 'tcp-port)
     175  (check-procedure 'make-remote-mailbox-server listen 'listen)
     176  (check-fixnum 'make-remote-mailbox-server request-limit 'request-limit)
     177  (let* ((rmbs
     178          (*make-remote-mailbox-server
     179            (make-dict/synch)
     180            name
     181            auto-create?
     182            (deserializer)
     183            #f #f
     184            (listen tcp-port)
     185            request-limit
     186            debug #f))
     187         (tcps
     188          (make-tcp-server
     189            (remote-mailbox-server-listener rmbs)
     190            (make-remote-mailbox-server-thunk rmbs)
     191            (remote-mailbox-server-request-limit rmbs))) )
    171192    (remote-mailbox-server-tcp-server-set! rmbs tcps)
    172193    rmbs ) )
    173194
    174195(define (make-remote-mailbox-server-thread rmbs)
    175         (check-remote-mailbox-server 'make-remote-mailbox-server-thread rmbs)
     196  (check-remote-mailbox-server 'make-remote-mailbox-server-thread rmbs)
    176197  (*make-remote-mailbox-server-thread rmbs) )
    177198
     
    179200
    180201(define (remote-mailbox-server-run! rmbs)
    181         (check-remote-mailbox-server 'remote-mailbox-server-run! rmbs)
    182         (*remote-mailbox-server-run! rmbs) )
     202  (check-remote-mailbox-server 'remote-mailbox-server-run! rmbs)
     203  (*remote-mailbox-server-run! rmbs) )
    183204
    184205(define (remote-mailbox-server-start! rmbs)
    185         (check-remote-mailbox-server 'remote-mailbox-server-start! rmbs)
    186         (*remote-mailbox-server-start! rmbs) )
     206  (check-remote-mailbox-server 'remote-mailbox-server-start! rmbs)
     207  (*remote-mailbox-server-start! rmbs) )
     208
     209(define (remote-mailbox-server-stop! rmbs)
     210  (check-remote-mailbox-server 'remote-mailbox-server-stop! rmbs)
     211  (*remote-mailbox-server-stop! rmbs) )
    187212
    188213;;
    189214
    190215(define (local-mailbox/server rmbs name #!optional (create? (remote-mailbox-server-auto-create? rmbs)))
    191         (check-remote-mailbox-server 'local-mailbox/server rmbs)
    192         (check-mailbox-name 'local-mailbox/server name)
    193         (*local-mailbox/server rmbs name create?) )
     216  (check-remote-mailbox-server 'local-mailbox/server rmbs)
     217  (check-mailbox-name 'local-mailbox/server name)
     218  (*local-mailbox/server rmbs name create?) )
    194219
    195220(define (drop-local-mailbox!/server rmbs name)
    196         (check-remote-mailbox-server 'drop-local-mailbox!/server rmbs)
    197         (check-mailbox-name 'drop-local-mailbox!/server name)
    198         (dict-delete!/synch (remote-mailbox-server-dict/synch rmbs) name) )
     221  (check-remote-mailbox-server 'drop-local-mailbox!/server rmbs)
     222  (check-mailbox-name 'drop-local-mailbox!/server name)
     223  (dict-delete!/synch (remote-mailbox-server-dict/synch rmbs) name) )
    199224
    200225(define (local-mailbox-names/server rmbs)
    201         (check-remote-mailbox-server 'remote-mailbox-server-mailbox-names rmbs)
    202         (dict-keys/synch (remote-mailbox-server-dict/synch rmbs)) )
     226  (check-remote-mailbox-server 'remote-mailbox-server-mailbox-names rmbs)
     227  (dict-keys/synch (remote-mailbox-server-dict/synch rmbs)) )
    203228
    204229;;; Convenience
    205230
    206 (define local-mailbox-start!)
    207 (define local-mailbox-server)
    208 (define local-mailbox-thread)
    209 (define local-mailbox)
    210 (let ((rmbs #f) (thrd #f))
    211 
    212   (set! local-mailbox-start!
    213     (lambda (#!optional debug)
    214       (unless rmbs
    215         (set! rmbs (make-remote-mailbox-server #:name 'default-remote-mailbox-server #:debug debug))
    216         (set! thrd (*remote-mailbox-server-start! rmbs)) ) ) )
    217 
    218   (set! local-mailbox-server (lambda () rmbs))
    219 
    220   (set! local-mailbox-thread (lambda () thrd))
    221 
    222   (set! local-mailbox
    223     (lambda (name #!optional debug)
    224       (check-mailbox-name 'local-mailbox name)
    225       (unless rmbs (local-mailbox-start! debug))
    226       (*local-mailbox/server rmbs name #t) ) ) )
     231(define +rmbs+ #f)
     232(define +thrd+ #f)
     233
     234(define (local-mailbox-start! #!optional debug)
     235  (unless +rmbs+
     236    (set! +rmbs+ (make-remote-mailbox-server #:name 'default-remote-mailbox-server #:debug debug))
     237    (set! +thrd+ (*remote-mailbox-server-start! +rmbs+)) ) )
     238
     239(define (local-mailbox-server)
     240  +rmbs+ )
     241
     242(define (local-mailbox-thread)
     243  +thrd+ )
     244
     245(define (local-mailbox name #!optional debug)
     246  (check-mailbox-name 'local-mailbox name)
     247  (unless +rmbs+ (local-mailbox-start! debug))
     248  (*local-mailbox/server +rmbs+ name #t) )
    227249
    228250) ;module remote-mailbox-server
  • release/4/remote-mailbox/tags/2.1.0/remote-mailbox.meta

    r27656 r33908  
    1616        (check-errors "1.12.0")
    1717        (synch "2.1.1"))
    18  (files "remote-mailbox.meta" "remote-mailbox.release-info" "remote-mailbox-client.scm" "remote-mailbox.setup" "remote-mailbox-common.scm" "remote-mailbox-server.scm" "tests/run.scm" "tests/remote-mailbox-test.scm") )
     18 (files "remote-mailbox.meta" "remote-mailbox.release-info" "remote-mailbox-adapter.scm" "remote-mailbox-packet.scm" "remote-mailbox-client.scm" "remote-mailbox.setup" "remote-mailbox-common.scm" "remote-mailbox-server.scm" "tests/run.scm" "tests/remote-mailbox-test.scm") )
  • release/4/remote-mailbox/tags/2.1.0/remote-mailbox.setup

    r27656 r33908  
    55(verify-extension-name "remote-mailbox")
    66
    7 (setup-shared-extension-module 'remote-mailbox-common (extension-version "2.0.2")
     7(setup-shared-extension-module 'remote-mailbox-common (extension-version "2.1.0")
    88  #:compile-options '(
    99    -scrutinize
     
    1212    -no-procedure-checks))
    1313
    14 (setup-shared-extension-module 'remote-mailbox-client (extension-version "2.0.2")
     14(setup-shared-extension-module 'remote-mailbox-packet (extension-version "2.1.0")
    1515  #:compile-options '(
    1616    -scrutinize
     
    1919    -no-procedure-checks))
    2020
    21 (setup-shared-extension-module 'remote-mailbox-server (extension-version "2.0.2")
     21(setup-shared-extension-module 'remote-mailbox-adapter (extension-version "2.1.0")
    2222  #:compile-options '(
    2323    -scrutinize
     
    2626    -no-procedure-checks))
    2727
    28 (install-extension-tag 'remote-mailbox (extension-version "2.0.2"))
     28(setup-shared-extension-module 'remote-mailbox-client (extension-version "2.1.0")
     29  #:compile-options '(
     30    -scrutinize
     31    -fixnum-arithmetic
     32    -O3 -d1
     33    -no-procedure-checks))
     34
     35(setup-shared-extension-module 'remote-mailbox-server (extension-version "2.1.0")
     36  #:compile-options '(
     37    -scrutinize
     38    -fixnum-arithmetic
     39    -O3 -d1
     40    -no-procedure-checks))
     41
     42(install-extension-tag 'remote-mailbox (extension-version "2.1.0"))
  • release/4/remote-mailbox/tags/2.1.0/tests/remote-mailbox-test.scm

    r16202 r33908  
    11;;;; remote-mailbox-test.scm
    2  
     2
    33; should run multiple senders
    44;
    5 ; should have a better way to terminate the tcp-server loop
     5; doesn't have good shutdown of socket
     6;
     7;X should have a better way to terminate the tcp-server loop
     8; - close the port
    69
    710(use srfi-1 posix srfi-18)
    8 (use remote-mailbox-client remote-mailbox-server mailbox miscmacros)
     11(use remote-mailbox-client remote-mailbox-server remote-mailbox-adapter mailbox miscmacros)
    912
    1013(define-constant NUM-MSG 5)
     
    1619        (let ((rmb (remote-mailbox MB-NAM)))
    1720                (dotimes (n NUM-MSG)
    18                         (print "Sending message number " n " to " RCV-NAM)
    19                         (remote-mailbox-send! rmb (list "to" RCV-NAM ":" n))
     21                              ;a message can be any object
     22                  (let ((msg (vector 'message `(recipient ,RCV-NAM) `(id ,n))))
     23        (printf "Sending ~S to ~S~%" msg MB-NAM)
     24        (remote-mailbox-send! rmb msg) )
    2025                        ; Semblance of computation
    2126                        (thread-sleep! 1) #;(repeat 10000) )
    22                 (print "Send quit")
    23                 (remote-mailbox-send! rmb 'quit) ) )
    24        
     27                #;(close-output-port (serializer-output))
     28                (begin (print "Send quit") (remote-mailbox-send! rmb 'quit)) ) )
     29
    2530(define (receiver)
     31
    2632  (define (server)
    2733    (let ((rmbs (make-remote-mailbox-server #:debug RCV-NAM)))
    2834      (values rmbs (remote-mailbox-server-start! rmbs)) ) )
     35
    2936  (let-values (((rmbs thrd) (server)))
    3037    (print "* Receiving messages until 'quit")
    3138    (let loop ()
    3239      (let ((msg (mailbox-receive! (local-mailbox/server rmbs MB-NAM))))
    33         (print "Received " msg)
    34         (unless (eq? 'quit msg)
    35           (loop) ) ) )
    36     (thread-terminate! thrd)
    37     (handle-exceptions ex
     40        (printf "Received ~S from ~S~%" msg MB-NAM)
     41        (unless (eq? 'quit msg) (loop) )
     42        #;(loop) ) )
     43    #;(thread-terminate! thrd)
     44    #;(handle-exceptions ex
    3845        (print "Performed \"hard\" termination of server thread")
    39       (thread-join! thrd) ) ) )
     46      (thread-join! thrd) )
     47    (print "stopping...") (remote-mailbox-server-stop! rmbs) ) )
    4048
    4149#;
     
    4452  (let loop ()
    4553    (let ((msg (mailbox-receive! (local-mailbox MB-NAM RCV-NAM))))
    46       (print "Received " msg)
     54      (printf "Received ~S from ~S~%" msg MB-NAM)
    4755      (unless (eq? 'quit msg)
    4856        (loop) ) ) )
     
    5462(define operation
    5563        (let ((args (command-line-arguments)))
    56                 (and (pair? args)
    57                      (string->symbol (car args))) ) )
     64                (and
     65                  (pair? args)
     66      (string->symbol (car args))) ) )
    5867
    5968(if operation
     
    6271      ((receiver) (receiver))
    6372      (else
    64         (error 'remote-mailbox-test "Unrecognized operation: " operation) ) ) 
     73        (error 'remote-mailbox-test "Unrecognized operation: " operation) ) )
    6574    ;; The "server" MUST be started before the client!
    6675    (let ((cmd (first (argv))))
  • release/4/remote-mailbox/trunk/remote-mailbox-client.scm

    r19860 r33908  
    88(module remote-mailbox-client
    99
    10   (;export
    11     ;; Common
    12     ; Parameters
    13     default-remote-mailbox-tcp-port
    14     default-remote-mailbox-hostname
    15     ;; Client
    16     ; Parameters
    17     default-remote-mailbox-connect
    18     default-remote-mailbox-serializer
    19     ; Operations
    20     remote-mailbox
    21     remote-mailbox?
    22     remote-mailbox-name
    23     remote-mailbox-hostname
    24     remote-mailbox-tcp-port
    25     remote-mailbox-connected?
    26     drop-remote-mailbox!
    27     drop-remote-mailboxes!
    28     remote-mailboxes
    29     remote-mailbox-send!)
     10(;export
     11  ;; Common
     12  ; Parameters
     13  default-remote-mailbox-tcp-port
     14  default-remote-mailbox-hostname
     15  ;; Client
     16  ; Parameters
     17  default-remote-mailbox-connect
     18  ; Operations
     19  remote-mailbox
     20  remote-mailbox?
     21  remote-mailbox-name
     22  remote-mailbox-hostname
     23  remote-mailbox-tcp-port
     24  remote-mailbox-connected?
     25  drop-remote-mailbox!
     26  drop-remote-mailboxes!
     27  remote-mailboxes
     28  remote-mailbox-send!)
    3029
    31   (import
    32     scheme
    33     chicken
    34     tcp
    35     (only srfi-18 make-mutex mutex-name)
    36     (only data-structures conc)
    37     (only miscmacros define-parameter)
    38     s11n
    39     mailbox
    40     synch
    41     lookup-table-synch
    42     (only type-checks check-procedure define-check+error-type)
    43     (only type-errors warning-argument-type)
    44     remote-mailbox-common)
     30(import scheme chicken)
    4531
    46   (require-library
    47     tcp srfi-18
    48     miscmacros s11n mailbox synch lookup-table-synch
    49     type-checks type-errors
    50     remote-mailbox-common)
     32(import
     33  tcp
     34  (only srfi-18 make-mutex mutex-name)
     35  (only data-structures conc)
     36  (only miscmacros define-parameter)
     37  mailbox
     38  synch
     39  lookup-table-synch
     40  (only type-checks check-procedure define-check+error-type)
     41  (only type-errors warning-argument-type)
     42  remote-mailbox-adapter
     43  remote-mailbox-packet
     44  remote-mailbox-common)
     45(require-library
     46  tcp srfi-18
     47  miscmacros mailbox synch lookup-table-synch
     48  type-checks type-errors
     49  remote-mailbox-adapter
     50  remote-mailbox-packet
     51  remote-mailbox-common)
    5152
    5253;;; Utilities
     
    5758
    5859(define-record-type remote-mailbox
    59         (*make-remote-mailbox name hstnam prtnum connect mutex input output)
    60         *remote-mailbox?
    61         (name remote-mailbox-name remote-mailbox-name-set!)
    62         (hstnam remote-mailbox-hostname)
    63         (prtnum remote-mailbox-tcp-port)
    64         (connect remote-mailbox-connect)
    65         (mutex remote-mailbox-mutex)
    66         (input remote-mailbox-input-port remote-mailbox-input-port-set!)
    67         (output remote-mailbox-output-port remote-mailbox-output-port-set!) )
     60  (*make-remote-mailbox name hstnam prtnum serializer connect mutex input output)
     61  *remote-mailbox?
     62  (name remote-mailbox-name remote-mailbox-name-set!)
     63  (hstnam remote-mailbox-hostname)
     64  (prtnum remote-mailbox-tcp-port)
     65  (serializer remote-mailbox-serializer)
     66  (connect remote-mailbox-connect)
     67  (mutex remote-mailbox-mutex)
     68  (input remote-mailbox-input-port remote-mailbox-input-port-set!)
     69  (output remote-mailbox-output-port remote-mailbox-output-port-set!) )
    6870
    69 (define (invalidate-remote-mailbox! rmb) (remote-mailbox-name-set! rmb #f))
    70 (define (valid-remote-mailbox? rmb) (->boolean (remote-mailbox-name rmb)))
     71(define (invalidate-remote-mailbox! rmb)
     72  (remote-mailbox-name-set! rmb #f) )
    7173
    72 (define (remote-mailbox-key rmb) (mutex-name (remote-mailbox-mutex rmb)))
     74(define (valid-remote-mailbox? rmb)
     75  (->boolean (remote-mailbox-name rmb)) )
     76
     77(define (remote-mailbox-key rmb)
     78  (mutex-name (remote-mailbox-mutex rmb)) )
    7379
    7480(define +remote-mailbox-key->remote-mailbox+ (make-dict/synch))
    7581
    7682(define (make-remote-mailbox-key name hostname tcp-port)
    77         (conc name #\@ hostname (if tcp-port (conc #\: tcp-port) "")) )
     83  (conc name #\@ hostname (if tcp-port (conc #\: tcp-port) "")) )
    7884
    7985(define (*remote-mailbox name hostname tcp-port connect)
    8086  (let ((key (make-remote-mailbox-key name hostname tcp-port)))
    81     (dict-indempotent-ref!/synch
    82       +remote-mailbox-key->remote-mailbox+
     87    (dict-indempotent-ref!/synch +remote-mailbox-key->remote-mailbox+
    8388      key
    8489      (lambda (def)
    85         (*make-remote-mailbox name hostname tcp-port connect (make-mutex key) #f #f))) ) )
     90        (*make-remote-mailbox
     91          name
     92          hostname tcp-port
     93          (serializer) connect
     94          (make-mutex key) #f #f))) ) )
    8695
    87 (define (*remote-mailbox-connected? rmb) (->boolean (remote-mailbox-output-port rmb)))
     96(define (*remote-mailbox-connected? rmb)
     97  (->boolean (remote-mailbox-output-port rmb)) )
    8898
    8999(define (connection/remote-mailbox rmb)
    90         (if (*remote-mailbox-connected? rmb) (remote-mailbox-output-port rmb)
    91       ; else make a connection
    92       (let-values (((in out)
    93                     (let ((connect (remote-mailbox-connect rmb))
    94                           (tcp-port (remote-mailbox-tcp-port rmb)) )
    95                       ; Allow hostname to carry service/portno
    96                       (if (not tcp-port) (connect (remote-mailbox-hostname rmb))
    97                           (connect (remote-mailbox-hostname rmb) tcp-port) ) ) ) )
    98         (remote-mailbox-input-port-set! rmb in)
    99         (remote-mailbox-output-port-set! rmb out)
    100         out )) )
     100  (if (*remote-mailbox-connected? rmb)
     101    (remote-mailbox-output-port rmb)
     102    ; else make a connection
     103    (let-values (
     104        ((in out)
     105          (let ((connect (remote-mailbox-connect rmb))
     106                (tcp-port (remote-mailbox-tcp-port rmb)) )
     107            ; Allow hostname to carry service/portno
     108            (if (not tcp-port)
     109              (connect (remote-mailbox-hostname rmb))
     110              (connect (remote-mailbox-hostname rmb) tcp-port) ) ) ) )
     111      (remote-mailbox-input-port-set! rmb in)
     112      (remote-mailbox-output-port-set! rmb out)
     113      out )) )
    101114
    102115(define (close-remote-mailbox-connection! rmb)
    103116  (close-input-port (remote-mailbox-input-port rmb))
    104         (remote-mailbox-input-port-set! rmb #f)
    105         (close-output-port (remote-mailbox-output-port rmb))
    106         (remote-mailbox-output-port-set! rmb #f)
    107         (invalidate-remote-mailbox! rmb) )
     117  (remote-mailbox-input-port-set! rmb #f)
     118  (close-output-port (remote-mailbox-output-port rmb))
     119  (remote-mailbox-output-port-set! rmb #f)
     120  (invalidate-remote-mailbox! rmb) )
    108121
    109122(define (*drop-remote-mailbox! rmb)
    110         (record/synch remote-mailbox rmb
     123  (record/synch remote-mailbox rmb
    111124    (close-remote-mailbox-connection! rmb)
    112     (dict-delete!/synch +remote-mailbox-key->remote-mailbox+ (remote-mailbox-key rmb)) ) )
     125    (dict-delete!/synch +remote-mailbox-key->remote-mailbox+
     126      (remote-mailbox-key rmb)) ) )
    113127
    114128(define-check+error-type remote-mailbox)
     
    118132;; Parameters
    119133
    120 (define-parameter default-remote-mailbox-serializer #f
    121   (lambda (x)
    122         (cond
    123           ((procedure? x) x)
    124       ((not x)        #f)
    125       (else
    126         (warning-argument-type 'default-remote-mailbox-serializer x 'procedure)
    127         (default-remote-mailbox-serializer))) ) )
    128 
    129134(define-parameter default-remote-mailbox-connect tcp-connect
    130135  (lambda (x)
    131         (cond
    132           ((procedure? x) x)
     136    (cond
     137      ((procedure? x)
     138        x )
     139      ((not x)
     140        tcp-connect )
    133141      (else
    134142        (warning-argument-type 'default-remote-mailbox-connect x 'procedure)
     
    137145;; Operations
    138146
    139 (define (remote-mailbox name #!key (hostname (default-remote-mailbox-hostname))
    140                                    (tcp-port (default-remote-mailbox-tcp-port))
    141                                    (connect (default-remote-mailbox-connect)))
    142         (check-mailbox-name 'remote-mailbox name 'name)
    143         (check-hostname 'remote-mailbox hostname 'hostname)
    144         (when tcp-port (check-tcp-port 'remote-mailbox tcp-port 'tcp-port))
    145         (check-procedure 'remote-mailbox connect 'connect)
    146         (*remote-mailbox name hostname tcp-port connect) )
     147(define (remote-mailbox name
     148          #!key
     149          (hostname (default-remote-mailbox-hostname))
     150          (tcp-port (default-remote-mailbox-tcp-port))
     151          (connect (default-remote-mailbox-connect)))
     152  (check-mailbox-name 'remote-mailbox name 'name)
     153  (check-hostname 'remote-mailbox hostname 'hostname)
     154  (when tcp-port (check-tcp-port 'remote-mailbox tcp-port 'tcp-port))
     155  (check-procedure 'remote-mailbox connect 'connect)
     156  (*remote-mailbox name hostname tcp-port connect) )
    147157
    148158(define (remote-mailbox? obj)
    149         (and (*remote-mailbox? obj) (valid-remote-mailbox? obj)) )
     159  (and (*remote-mailbox? obj) (valid-remote-mailbox? obj)) )
    150160
    151161(define (remote-mailbox-connected? rmb)
    152         (check-remote-mailbox 'remote-mailbox-connected? rmb)
    153         (*remote-mailbox-connected? rmb) )
     162  (check-remote-mailbox 'remote-mailbox-connected? rmb)
     163  (*remote-mailbox-connected? rmb) )
    154164
    155165(define (remote-mailboxes)
    156         (dict-values/synch +remote-mailbox-key->remote-mailbox+) )
     166  (dict-values/synch +remote-mailbox-key->remote-mailbox+) )
    157167
    158168(define (drop-remote-mailbox! rmb)
    159         (check-remote-mailbox 'drop-remote-mailbox! rmb)
    160         (*drop-remote-mailbox! rmb) )
     169  (check-remote-mailbox 'drop-remote-mailbox! rmb)
     170  (*drop-remote-mailbox! rmb) )
    161171
    162172(define (drop-remote-mailboxes!)
    163173  (for-each (cut *drop-remote-mailbox! <>) (remote-mailboxes)) )
    164174
    165 (define (remote-mailbox-send! rmb val #!optional (serializer (default-remote-mailbox-serializer)))
    166         (check-remote-mailbox 'remote-mailbox-send! rmb)
    167         (when serializer (check-procedure 'remote-mailbox serializer 'serializer))
    168         (record/synch remote-mailbox rmb
    169                 (let ((out (connection/remote-mailbox rmb))
    170                       (req (make-remote-mailbox-packet (remote-mailbox-name rmb) val)) )
    171                         (serialize req out serializer) ) ) )
     175(define (remote-mailbox-send! rmb val)
     176  (check-remote-mailbox 'remote-mailbox-send! rmb)
     177  (record/synch remote-mailbox rmb
     178    (let ((out (connection/remote-mailbox rmb))
     179          (req (make-remote-mailbox-packet (remote-mailbox-name rmb) val)) )
     180      (parameterize ((serializer (remote-mailbox-serializer rmb)))
     181        (serialize req out) ) ) ) )
    172182
    173183) ;module remote-mailbox-client
  • release/4/remote-mailbox/trunk/remote-mailbox-common.scm

    r19860 r33908  
    44(module remote-mailbox-common
    55
    6   (;export
    7     ;;
    8     mailbox-name?
    9     tcp-port?
    10     hostname?
    11     error-mailbox-name
    12     error-tcp-port
    13     error-hostname
    14     check-mailbox-name
    15     check-tcp-port
    16     check-hostname
    17     ;;
    18     make-remote-mailbox-packet
    19     remote-mailbox-packet?
    20     remote-mailbox-packet-key
    21     remote-mailbox-packet-value
    22     ;;
    23     default-remote-mailbox-tcp-port
    24     default-remote-mailbox-hostname)
     6(;export
     7  ;;
     8  mailbox-name?
     9  tcp-port?
     10  hostname?
     11  error-mailbox-name
     12  error-tcp-port
     13  error-hostname
     14  check-mailbox-name
     15  check-tcp-port
     16  check-hostname
     17  ;;
     18  default-remote-mailbox-tcp-port
     19  default-remote-mailbox-hostname)
    2520
    26   (import
    27     scheme
    28     chicken
    29     (only srfi-13 string-null?)
    30     (only miscmacros define-parameter)
    31     (only type-checks define-check+error-type))
     21(import scheme chicken)
    3222
    33   (require-library srfi-13 miscmacros type-checks)
     23(import
     24  (only srfi-13 string-null?)
     25  (only miscmacros define-parameter)
     26  (only type-errors warning-argument-type)
     27  (only type-checks define-check+error-type))
     28(require-library srfi-13 miscmacros type-errors type-checks)
     29
     30;;;
     31
     32(define-constant DEFAULT-TCP-PORT 63001)
     33(define-constant DEFAULT-HOSTNAME "localhost")
    3434
    3535;;;
     
    3737(define mailbox-name? symbol?)
    3838
    39 (define (tcp-port? obj) (and (fixnum? obj) (and (fx< 0 obj) (fx< obj 65536))))
     39(define (tcp-port? obj)
     40  (and
     41    (fixnum? obj)
     42    (and (fx< 0 obj) (fx< obj 65536))) )
    4043
    41 (define (hostname? obj) (and (string? obj) (not (string-null? obj))))
     44(define (hostname? obj)
     45  (and
     46    (string? obj)
     47    (not (string-null? obj))) )
    4248
    4349;;;
     
    4753(define-check+error-type tcp-port)
    4854
    49 ;;; Remote Mailbox Packet
    50 
    51 (define +remote-mailbox-tag+ 'rmbtag)
    52 
    53 (define (make-remote-mailbox-packet key val) (vector +remote-mailbox-tag+ key val))
    54 
    55 (define (remote-mailbox-packet? obj)
    56         (and (vector? obj)
    57                          (= 3 (vector-length obj))
    58                          (eq? +remote-mailbox-tag+ (vector-ref obj 0))) )
    59 
    60 (define (remote-mailbox-packet-key rmp) (vector-ref rmp 1))
    61 
    62 (define (remote-mailbox-packet-value rmp) (vector-ref rmp 2))
    63 
    6455;;; Parameters
    6556
    66 (define-parameter default-remote-mailbox-tcp-port 63001
     57(define-parameter default-remote-mailbox-tcp-port DEFAULT-TCP-PORT
    6758        (lambda (x)
    68                 (cond ((tcp-port? x) x)
    69           (else (default-remote-mailbox-tcp-port) ) ) ) )
     59                (cond
     60                  ((tcp-port? x)  x )
     61                  ((not x)        DEFAULT-TCP-PORT )
     62      (else
     63        (warning-argument-type 'default-remote-mailbox-tcp-port x 'procedure)
     64        (default-remote-mailbox-tcp-port) ) ) ) )
    7065
    71 (define-parameter default-remote-mailbox-hostname "localhost"
     66(define-parameter default-remote-mailbox-hostname DEFAULT-HOSTNAME
    7267        (lambda (x)
    73                 (cond ((hostname? x) x)
    74           (else (default-remote-mailbox-hostname) ) ) ) )
     68                (cond
     69                  ((hostname? x)  x )
     70                  ((not x)        DEFAULT-HOSTNAME )
     71      (else
     72        (warning-argument-type 'default-remote-mailbox-hostname x 'procedure)
     73        (default-remote-mailbox-hostname) ) ) ) )
    7574
    7675) ;module remote-mailbox-common
  • release/4/remote-mailbox/trunk/remote-mailbox-server.scm

    r19860 r33908  
    99(module remote-mailbox-server
    1010
    11   (;export
    12     ;; Common
    13     ; Parameters
    14     default-remote-mailbox-tcp-port
    15     default-remote-mailbox-hostname
    16     ;; Server
    17     ; Parameters
    18     default-remote-mailbox-deserializer
    19     default-remote-mailbox-listen
    20     default-remote-mailbox-auto-create?
    21     ; Operations
    22     make-remote-mailbox-server
    23     make-remote-mailbox-server-thread
    24     local-mailbox/server
    25     drop-local-mailbox!/server
    26     local-mailbox-names/server
    27     remote-mailbox-server-run!
    28     remote-mailbox-server-start!
    29     ;; Queries
    30     remote-mailbox-server?
    31     remote-mailbox-server-name
    32     remote-mailbox-server-auto-create?
    33     remote-mailbox-server-deserializer
    34     remote-mailbox-server-listener
    35     remote-mailbox-server-request-limit
    36     remote-mailbox-server-debug
    37     ;; Convenience
    38     local-mailbox-server
    39     local-mailbox-thread
    40     local-mailbox-start!
    41     local-mailbox)
    42 
    43   (import
    44     scheme
    45     chicken
    46     (only srfi-18 make-thread thread-start! mutex-name)
    47     (only data-structures identity)
    48     tcp
    49     (only miscmacros define-parameter while)
    50     tcp-server
    51     s11n
    52     mailbox
    53     lookup-table-synch
    54     type-checks
    55     type-errors
    56     condition-utils
    57     remote-mailbox-common)
    58 
    59   (require-library
    60     srfi-18 data-structures tcp
    61     tcp-server s11n mailbox miscmacros lookup-table-synch type-checks
    62     condition-utils
    63     remote-mailbox-common)
     11(;export
     12  ;; Common
     13  ; Parameters
     14  default-remote-mailbox-tcp-port
     15  default-remote-mailbox-hostname
     16  ;; Server
     17  ; Parameters
     18  default-remote-mailbox-listen
     19  default-remote-mailbox-auto-create?
     20  ; Operations
     21  make-remote-mailbox-server
     22  make-remote-mailbox-server-thread
     23  local-mailbox/server
     24  drop-local-mailbox!/server
     25  local-mailbox-names/server
     26  remote-mailbox-server-run!
     27  remote-mailbox-server-start!
     28  remote-mailbox-server-stop!
     29  ;; Queries
     30  remote-mailbox-server?
     31  remote-mailbox-server-name
     32  remote-mailbox-server-auto-create?
     33  remote-mailbox-server-listener
     34  remote-mailbox-server-request-limit
     35  remote-mailbox-server-debug
     36  ;; Convenience
     37  local-mailbox-server
     38  local-mailbox-thread
     39  local-mailbox-start!
     40  local-mailbox)
     41
     42(import scheme chicken)
     43
     44(import
     45  (only srfi-18 make-thread thread-start! mutex-name thread-join!)
     46  (only data-structures identity)
     47  tcp
     48  (only miscmacros define-parameter while)
     49  tcp-server
     50  mailbox
     51  lookup-table-synch
     52  type-checks
     53  type-errors
     54  condition-utils
     55  remote-mailbox-adapter
     56  remote-mailbox-packet
     57  remote-mailbox-common)
     58(require-library
     59  srfi-18 data-structures tcp
     60  tcp-server mailbox miscmacros lookup-table-synch type-checks
     61  condition-utils
     62  remote-mailbox-adapter
     63  remote-mailbox-packet
     64  remote-mailbox-common)
    6465
    6566;;; Conditions
     
    7677
    7778(define (remote-mailbox-server-request-exception rmbs . args)
    78   (abort (make-remote-mailbox-server-condition "unknown remote mailbox client request"  rmbs args 'request)) )
     79  (abort (make-remote-mailbox-server-condition "unknown remote mailbox client request" rmbs args 'request)) )
    7980
    8081;;; Server Side
     
    8384
    8485(define-record-type remote-mailbox-server
    85   (*make-remote-mailbox-server dctm nm autof desrl srvr lstnr rlim dbg thrd)
     86  (*make-remote-mailbox-server dctm nm autof desrl srvr thread lstnr rlim dbg thrd)
    8687  remote-mailbox-server?
    8788  (dctm remote-mailbox-server-dict/synch)
     
    9091  (desrl remote-mailbox-server-deserializer)
    9192  (srvr remote-mailbox-server-tcp-server remote-mailbox-server-tcp-server-set!)
     93  (thread remote-mailbox-server-thread remote-mailbox-server-thread-set!)
    9294  (lstnr remote-mailbox-server-listener)
    9395  (rlim remote-mailbox-server-request-limit)
     
    98100(define-constant default-request-count-limit 10000)
    99101
    100 (define-parameter default-remote-mailbox-deserializer #f
    101   (lambda (x)
    102         (cond
    103           ((procedure? x)   x)
    104       ((not x)          #f)
    105       (else
    106         (warning-argument-type 'default-remote-mailbox-deserializer x 'procedure)
    107         (default-remote-mailbox-deserializer) ) ) ) )
    108 
    109102(define-parameter default-remote-mailbox-listen tcp-listen
    110103  (lambda (x)
    111         (cond
    112           ((procedure? x) x)
     104    (cond
     105      ((procedure? x)
     106        x )
     107      ((not x)
     108        tcp-listen )
    113109      (else
    114110        (warning-argument-type 'default-remote-mailbox-listen x 'procedure)
     
    122118
    123119(define (*local-mailbox/server rmbs name create?)
    124         (dict-indempotent-ref!/synch
     120  (dict-indempotent-ref!/synch
    125121    (remote-mailbox-server-dict/synch rmbs)
    126122    name
    127123    (lambda (def) (if create? (make-mailbox name) def))) )
    128124
    129 (define ((make-remote-mailbox-server-thunk rmbs))
    130   (while (not (eof-object? (peek-char (current-input-port))))
    131     (let ((req (deserialize (current-input-port) (remote-mailbox-server-deserializer rmbs))))
    132       (cond ((eq? (void) req) ) ;ignore void transmissions
    133             ((remote-mailbox-packet? req)
    134               (let* ((nam (remote-mailbox-packet-key req))
    135                      (lmb (*local-mailbox/server rmbs nam (remote-mailbox-server-auto-create? rmbs))) )
    136                 (if lmb (mailbox-send! lmb (remote-mailbox-packet-value req))
    137                     (remote-mailbox-server-mailbox-exception rmbs nam)) ) )
    138             (else
    139               (remote-mailbox-server-request-exception rmbs req) ) ) ) ) )
     125(define ((make-remote-mailbox-server-thunk rmbs) #!optional (inp (current-input-port)))
     126  (while (not (eof-object? (peek-char inp)))
     127    (let ((req
     128            (parameterize ((deserializer (remote-mailbox-server-deserializer rmbs)))
     129              (deserialize inp))))
     130      (cond
     131        ((eq? (void) req)
     132          ;ignore void transmissions
     133          )
     134        ((remote-mailbox-packet? req)
     135          (let* ((nam (remote-mailbox-packet-key req))
     136                 (lmb
     137                  (*local-mailbox/server
     138                    rmbs nam (remote-mailbox-server-auto-create? rmbs))) )
     139            (if lmb
     140              (mailbox-send! lmb (remote-mailbox-packet-value req))
     141              (remote-mailbox-server-mailbox-exception rmbs nam)) ) )
     142        (else
     143          (remote-mailbox-server-request-exception rmbs req) ) ) ) ) )
    140144
    141145(define (*remote-mailbox-server-run! rmbs)
    142         ((remote-mailbox-server-tcp-server rmbs) (remote-mailbox-server-debug rmbs)) )
     146  ((remote-mailbox-server-tcp-server rmbs) (remote-mailbox-server-debug rmbs)) )
    143147
    144148(define (*make-remote-mailbox-server-thread rmbs)
    145   (make-thread (lambda () (*remote-mailbox-server-run! rmbs)) (remote-mailbox-server-name rmbs)) )
     149  (remote-mailbox-server-thread-set! rmbs
     150    (make-thread
     151      (lambda () (*remote-mailbox-server-run! rmbs))
     152      (remote-mailbox-server-name rmbs)))
     153  (remote-mailbox-server-thread rmbs) )
    146154
    147155(define (*remote-mailbox-server-start! rmbs)
    148         (thread-start! (*make-remote-mailbox-server-thread rmbs)) )
     156  (thread-start! (*make-remote-mailbox-server-thread rmbs)) )
     157
     158(define (*remote-mailbox-server-stop! rmbs)
     159  (tcp-close (remote-mailbox-server-listener rmbs))
     160  (handle-exceptions ex
     161     (void)
     162    (thread-join! (remote-mailbox-server-thread rmbs)) ) )
    149163
    150164;; Exported
    151165
    152166(define (make-remote-mailbox-server
    153           #!key (tcp-port (default-remote-mailbox-tcp-port))
    154                 (listen (default-remote-mailbox-listen))
    155                 (deserializer (default-remote-mailbox-deserializer))
    156                 (name (gensym 'remote-mailbox-server:))
    157                 (auto-create? (default-remote-mailbox-auto-create?))
    158                 (request-limit default-request-count-limit)
    159                 debug)
    160         (check-tcp-port 'make-remote-mailbox-server tcp-port 'tcp-port)
    161         (check-procedure 'make-remote-mailbox-server listen 'listen)
    162         (when deserializer (check-procedure 'make-remote-mailbox-server deserializer 'deserializer))
    163         (check-fixnum 'make-remote-mailbox-server request-limit 'request-limit)
    164   (let* ((listener (listen tcp-port))
    165          (rmbs (*make-remote-mailbox-server (make-dict/synch) name auto-create?
    166                                             deserializer #f listener request-limit
    167                                             debug #f))
    168          (tcps (make-tcp-server listener
    169                                 (make-remote-mailbox-server-thunk rmbs)
    170                                 request-limit)) )
     167          #!key
     168          (tcp-port (default-remote-mailbox-tcp-port))
     169          (listen (default-remote-mailbox-listen))
     170          (name (gensym 'remote-mailbox-server:))
     171          (auto-create? (default-remote-mailbox-auto-create?))
     172          (request-limit default-request-count-limit)
     173          debug)
     174  (check-tcp-port 'make-remote-mailbox-server tcp-port 'tcp-port)
     175  (check-procedure 'make-remote-mailbox-server listen 'listen)
     176  (check-fixnum 'make-remote-mailbox-server request-limit 'request-limit)
     177  (let* ((rmbs
     178          (*make-remote-mailbox-server
     179            (make-dict/synch)
     180            name
     181            auto-create?
     182            (deserializer)
     183            #f #f
     184            (listen tcp-port)
     185            request-limit
     186            debug #f))
     187         (tcps
     188          (make-tcp-server
     189            (remote-mailbox-server-listener rmbs)
     190            (make-remote-mailbox-server-thunk rmbs)
     191            (remote-mailbox-server-request-limit rmbs))) )
    171192    (remote-mailbox-server-tcp-server-set! rmbs tcps)
    172193    rmbs ) )
    173194
    174195(define (make-remote-mailbox-server-thread rmbs)
    175         (check-remote-mailbox-server 'make-remote-mailbox-server-thread rmbs)
     196  (check-remote-mailbox-server 'make-remote-mailbox-server-thread rmbs)
    176197  (*make-remote-mailbox-server-thread rmbs) )
    177198
     
    179200
    180201(define (remote-mailbox-server-run! rmbs)
    181         (check-remote-mailbox-server 'remote-mailbox-server-run! rmbs)
    182         (*remote-mailbox-server-run! rmbs) )
     202  (check-remote-mailbox-server 'remote-mailbox-server-run! rmbs)
     203  (*remote-mailbox-server-run! rmbs) )
    183204
    184205(define (remote-mailbox-server-start! rmbs)
    185         (check-remote-mailbox-server 'remote-mailbox-server-start! rmbs)
    186         (*remote-mailbox-server-start! rmbs) )
     206  (check-remote-mailbox-server 'remote-mailbox-server-start! rmbs)
     207  (*remote-mailbox-server-start! rmbs) )
     208
     209(define (remote-mailbox-server-stop! rmbs)
     210  (check-remote-mailbox-server 'remote-mailbox-server-stop! rmbs)
     211  (*remote-mailbox-server-stop! rmbs) )
    187212
    188213;;
    189214
    190215(define (local-mailbox/server rmbs name #!optional (create? (remote-mailbox-server-auto-create? rmbs)))
    191         (check-remote-mailbox-server 'local-mailbox/server rmbs)
    192         (check-mailbox-name 'local-mailbox/server name)
    193         (*local-mailbox/server rmbs name create?) )
     216  (check-remote-mailbox-server 'local-mailbox/server rmbs)
     217  (check-mailbox-name 'local-mailbox/server name)
     218  (*local-mailbox/server rmbs name create?) )
    194219
    195220(define (drop-local-mailbox!/server rmbs name)
    196         (check-remote-mailbox-server 'drop-local-mailbox!/server rmbs)
    197         (check-mailbox-name 'drop-local-mailbox!/server name)
    198         (dict-delete!/synch (remote-mailbox-server-dict/synch rmbs) name) )
     221  (check-remote-mailbox-server 'drop-local-mailbox!/server rmbs)
     222  (check-mailbox-name 'drop-local-mailbox!/server name)
     223  (dict-delete!/synch (remote-mailbox-server-dict/synch rmbs) name) )
    199224
    200225(define (local-mailbox-names/server rmbs)
    201         (check-remote-mailbox-server 'remote-mailbox-server-mailbox-names rmbs)
    202         (dict-keys/synch (remote-mailbox-server-dict/synch rmbs)) )
     226  (check-remote-mailbox-server 'remote-mailbox-server-mailbox-names rmbs)
     227  (dict-keys/synch (remote-mailbox-server-dict/synch rmbs)) )
    203228
    204229;;; Convenience
    205230
    206 (define local-mailbox-start!)
    207 (define local-mailbox-server)
    208 (define local-mailbox-thread)
    209 (define local-mailbox)
    210 (let ((rmbs #f) (thrd #f))
    211 
    212   (set! local-mailbox-start!
    213     (lambda (#!optional debug)
    214       (unless rmbs
    215         (set! rmbs (make-remote-mailbox-server #:name 'default-remote-mailbox-server #:debug debug))
    216         (set! thrd (*remote-mailbox-server-start! rmbs)) ) ) )
    217 
    218   (set! local-mailbox-server (lambda () rmbs))
    219 
    220   (set! local-mailbox-thread (lambda () thrd))
    221 
    222   (set! local-mailbox
    223     (lambda (name #!optional debug)
    224       (check-mailbox-name 'local-mailbox name)
    225       (unless rmbs (local-mailbox-start! debug))
    226       (*local-mailbox/server rmbs name #t) ) ) )
     231(define +rmbs+ #f)
     232(define +thrd+ #f)
     233
     234(define (local-mailbox-start! #!optional debug)
     235  (unless +rmbs+
     236    (set! +rmbs+ (make-remote-mailbox-server #:name 'default-remote-mailbox-server #:debug debug))
     237    (set! +thrd+ (*remote-mailbox-server-start! +rmbs+)) ) )
     238
     239(define (local-mailbox-server)
     240  +rmbs+ )
     241
     242(define (local-mailbox-thread)
     243  +thrd+ )
     244
     245(define (local-mailbox name #!optional debug)
     246  (check-mailbox-name 'local-mailbox name)
     247  (unless +rmbs+ (local-mailbox-start! debug))
     248  (*local-mailbox/server +rmbs+ name #t) )
    227249
    228250) ;module remote-mailbox-server
  • release/4/remote-mailbox/trunk/remote-mailbox.meta

    r27656 r33908  
    1616        (check-errors "1.12.0")
    1717        (synch "2.1.1"))
    18  (files "remote-mailbox.meta" "remote-mailbox.release-info" "remote-mailbox-client.scm" "remote-mailbox.setup" "remote-mailbox-common.scm" "remote-mailbox-server.scm" "tests/run.scm" "tests/remote-mailbox-test.scm") )
     18 (files "remote-mailbox.meta" "remote-mailbox.release-info" "remote-mailbox-adapter.scm" "remote-mailbox-packet.scm" "remote-mailbox-client.scm" "remote-mailbox.setup" "remote-mailbox-common.scm" "remote-mailbox-server.scm" "tests/run.scm" "tests/remote-mailbox-test.scm") )
  • release/4/remote-mailbox/trunk/remote-mailbox.setup

    r27656 r33908  
    55(verify-extension-name "remote-mailbox")
    66
    7 (setup-shared-extension-module 'remote-mailbox-common (extension-version "2.0.2")
     7(setup-shared-extension-module 'remote-mailbox-common (extension-version "2.1.0")
    88  #:compile-options '(
    99    -scrutinize
     
    1212    -no-procedure-checks))
    1313
    14 (setup-shared-extension-module 'remote-mailbox-client (extension-version "2.0.2")
     14(setup-shared-extension-module 'remote-mailbox-packet (extension-version "2.1.0")
    1515  #:compile-options '(
    1616    -scrutinize
     
    1919    -no-procedure-checks))
    2020
    21 (setup-shared-extension-module 'remote-mailbox-server (extension-version "2.0.2")
     21(setup-shared-extension-module 'remote-mailbox-adapter (extension-version "2.1.0")
    2222  #:compile-options '(
    2323    -scrutinize
     
    2626    -no-procedure-checks))
    2727
    28 (install-extension-tag 'remote-mailbox (extension-version "2.0.2"))
     28(setup-shared-extension-module 'remote-mailbox-client (extension-version "2.1.0")
     29  #:compile-options '(
     30    -scrutinize
     31    -fixnum-arithmetic
     32    -O3 -d1
     33    -no-procedure-checks))
     34
     35(setup-shared-extension-module 'remote-mailbox-server (extension-version "2.1.0")
     36  #:compile-options '(
     37    -scrutinize
     38    -fixnum-arithmetic
     39    -O3 -d1
     40    -no-procedure-checks))
     41
     42(install-extension-tag 'remote-mailbox (extension-version "2.1.0"))
  • release/4/remote-mailbox/trunk/tests/remote-mailbox-test.scm

    r16202 r33908  
    11;;;; remote-mailbox-test.scm
    2  
     2
    33; should run multiple senders
    44;
    5 ; should have a better way to terminate the tcp-server loop
     5; doesn't have good shutdown of socket
     6;
     7;X should have a better way to terminate the tcp-server loop
     8; - close the port
    69
    710(use srfi-1 posix srfi-18)
    8 (use remote-mailbox-client remote-mailbox-server mailbox miscmacros)
     11(use remote-mailbox-client remote-mailbox-server remote-mailbox-adapter mailbox miscmacros)
    912
    1013(define-constant NUM-MSG 5)
     
    1619        (let ((rmb (remote-mailbox MB-NAM)))
    1720                (dotimes (n NUM-MSG)
    18                         (print "Sending message number " n " to " RCV-NAM)
    19                         (remote-mailbox-send! rmb (list "to" RCV-NAM ":" n))
     21                              ;a message can be any object
     22                  (let ((msg (vector 'message `(recipient ,RCV-NAM) `(id ,n))))
     23        (printf "Sending ~S to ~S~%" msg MB-NAM)
     24        (remote-mailbox-send! rmb msg) )
    2025                        ; Semblance of computation
    2126                        (thread-sleep! 1) #;(repeat 10000) )
    22                 (print "Send quit")
    23                 (remote-mailbox-send! rmb 'quit) ) )
    24        
     27                #;(close-output-port (serializer-output))
     28                (begin (print "Send quit") (remote-mailbox-send! rmb 'quit)) ) )
     29
    2530(define (receiver)
     31
    2632  (define (server)
    2733    (let ((rmbs (make-remote-mailbox-server #:debug RCV-NAM)))
    2834      (values rmbs (remote-mailbox-server-start! rmbs)) ) )
     35
    2936  (let-values (((rmbs thrd) (server)))
    3037    (print "* Receiving messages until 'quit")
    3138    (let loop ()
    3239      (let ((msg (mailbox-receive! (local-mailbox/server rmbs MB-NAM))))
    33         (print "Received " msg)
    34         (unless (eq? 'quit msg)
    35           (loop) ) ) )
    36     (thread-terminate! thrd)
    37     (handle-exceptions ex
     40        (printf "Received ~S from ~S~%" msg MB-NAM)
     41        (unless (eq? 'quit msg) (loop) )
     42        #;(loop) ) )
     43    #;(thread-terminate! thrd)
     44    #;(handle-exceptions ex
    3845        (print "Performed \"hard\" termination of server thread")
    39       (thread-join! thrd) ) ) )
     46      (thread-join! thrd) )
     47    (print "stopping...") (remote-mailbox-server-stop! rmbs) ) )
    4048
    4149#;
     
    4452  (let loop ()
    4553    (let ((msg (mailbox-receive! (local-mailbox MB-NAM RCV-NAM))))
    46       (print "Received " msg)
     54      (printf "Received ~S from ~S~%" msg MB-NAM)
    4755      (unless (eq? 'quit msg)
    4856        (loop) ) ) )
     
    5462(define operation
    5563        (let ((args (command-line-arguments)))
    56                 (and (pair? args)
    57                      (string->symbol (car args))) ) )
     64                (and
     65                  (pair? args)
     66      (string->symbol (car args))) ) )
    5867
    5968(if operation
     
    6271      ((receiver) (receiver))
    6372      (else
    64         (error 'remote-mailbox-test "Unrecognized operation: " operation) ) ) 
     73        (error 'remote-mailbox-test "Unrecognized operation: " operation) ) )
    6574    ;; The "server" MUST be started before the client!
    6675    (let ((cmd (first (argv))))
Note: See TracChangeset for help on using the changeset viewer.