Changeset 35329 in project


Ignore:
Timestamp:
03/24/18 20:57:36 (9 months ago)
Author:
kon
Message:

add types, deprecate '/' style identifiers, use moremacros define-warning-parameter, reflow

Location:
release/4/remote-mailbox/trunk
Files:
8 edited

Legend:

Unmodified
Added
Removed
  • release/4/remote-mailbox/trunk/remote-mailbox-adapter.scm

    r34113 r35329  
    55
    66(;export
    7   ;;
    8   serializer
    9   deserializer
    10   serializer-output
    11   serialize
    12   deserialize
    13   )
     7  serializer deserializer
     8  serializer-output deserializer-input
     9  serialize deserialize)
    1410
    1511(import scheme chicken)
    16 
    17 (import (prefix s11n s11n::))
    18 (require-library s11n)
    19 
    20 (import (only type-errors warning-argument-type))
    21 (require-library type-errors)
    22 
    23 (use miscmacros condition-utils)
     12(use
     13  (prefix s11n s11n::)
     14  (only moremacros define-warning-parameter)
     15  (only type-errors warning-argument-type)
     16  condition-utils)
    2417
    2518;;;
     
    2720;;
    2821
    29 (define-parameter serializer s11n::serialize
    30   (lambda (x)
    31         (cond
    32           ((procedure? x)   x)
    33       ((not x)          s11n::serialize)
    34       (else
    35         (warning-argument-type 'remote-mailbox-adapter::serializer x 'procedure)
    36         (serializer))) ) )
     22(define (serializer? x)
     23  (or (not x) (procedure? x)) )
    3724
    38 (define-parameter deserializer s11n::deserialize
    39   (lambda (x)
    40         (cond
    41           ((procedure? x)   x)
    42       ((not x)          s11n::deserialize)
    43       (else
    44         (warning-argument-type 'remote-mailbox-adapter::deserializer x 'procedure)
    45         (deserializer) ) ) ) )
     25(: serializer (#!optional (or boolean procedure) -> procedure))
     26;
     27(define-warning-parameter serializer s11n::serialize serializer
     28  ;ugh, automagic identifier injection
     29  (unless obj (set! obj s11n::serialize)) )
    4630
    47 (define +default-deserializer-input+ (current-input-port))
    48 (define +default-serializer-output+ (current-output-port))
     31(define (deserializer? x)
     32  (or (not x) (procedure? x)) )
    4933
    50 (define-parameter deserializer-input +default-deserializer-input+
    51   (lambda (x)
    52         (cond
    53           ((input-port? x)  x)
    54       ((not x)          +default-deserializer-input+)
    55       (else
    56         (warning-argument-type 'remote-mailbox-adapter::deserializer-input x 'input-port)
    57         (deserializer-input) ) ) ) )
     34(: deserializer (#!optional (or boolean procedure) -> procedure))
     35;
     36(define-warning-parameter deserializer s11n::deserialize deserializer
     37  ;ugh, automagic identifier injection
     38  (unless obj (set! obj s11n::deserialize)) )
    5839
    59 (define-parameter serializer-output +default-serializer-output+
    60   (lambda (x)
    61         (cond
    62           ((output-port? x)  x)
    63       ((not x)          +default-serializer-output+)
    64       (else
    65         (warning-argument-type 'remote-mailbox-adapter::serializer-output x 'output-port)
    66         (serializer-output) ) ) ) )
     40(define DEFAULT-DESERIALIZER-INPUT (current-input-port))
     41(define DEFAULT-SERIALIZER-OUTPUT (current-output-port))
     42
     43(define (deserializer-input? x)
     44  (or (not x) (input-port? x)) )
     45
     46(: deserializer-input (#!optional (or boolean input-port) -> input-port))
     47;
     48(define-warning-parameter deserializer-input DEFAULT-DESERIALIZER-INPUT deserializer-input
     49  ;ugh, automagic identifier injection
     50  (unless obj (set! obj DEFAULT-DESERIALIZER-INPUT)) )
     51
     52(define (serializer-output? x)
     53  (or (not x) (output-port? x)) )
     54
     55(: serializer-output (#!optional (or boolean output-port) -> output-port))
     56;
     57(define-warning-parameter serializer-output DEFAULT-SERIALIZER-OUTPUT serializer-output
     58  ;ugh, automagic identifier injection
     59  (unless obj (set! obj DEFAULT-SERIALIZER-OUTPUT)) )
    6760
    6861;;
    6962
     63(: serialize (* #!optional output-port -> void))
     64;
    7065(define (serialize x #!optional (port (serializer-output)))
    7166  ((serializer) x port) )
    7267
     68(: deserialize (#!optional input-port -> *))
     69;
    7370(define (deserialize #!optional (port (deserializer-input)))
    7471  ((deserializer) port) )
  • release/4/remote-mailbox/trunk/remote-mailbox-client.scm

    r34761 r35329  
    1111  ;;common
    1212  ;parameters
    13   default-remote-mailbox-tcp-port
     13  default-remote-mailbox-tcp-port-no
    1414  default-remote-mailbox-hostname
    1515  ;;client
     
    2929
    3030(import scheme chicken)
    31 
    32 (import
     31(use
    3332  tcp
    3433  (only srfi-18 make-mutex mutex-name)
    3534  (only data-structures conc)
    36   (only miscmacros define-parameter)
     35  (only moremacros ->boolean define-warning-parameter)
     36  (only type-errors warning-argument-type)
    3737  mailbox
    3838  synch
    3939  lookup-table-synch
    4040  (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
    4941  remote-mailbox-adapter
    5042  remote-mailbox-packet
     
    5345;;; Utilities
    5446
    55 (define (->boolean x) (and x #t))
    56 
    5747;;; Support
    5848
     49(define-type remote-mailbox (struct remote-mailbox))
     50(define-type mailbox-name symbol)
     51(define-type hostname string)
     52
     53(: remote-mailbox-name (remote-mailbox -> mailbox-name))
     54(: remote-mailbox-hostname (remote-mailbox -> hostname))
     55;
    5956(define-record-type remote-mailbox
    6057  (*make-remote-mailbox name hstnam prtnum serializer connect mutex input output)
     
    10299    ;else make a connection
    103100    (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) ) ) ) )
     101      ((in out)
     102        (let (
     103          (connect (remote-mailbox-connect rmb))
     104          (tcp-port (remote-mailbox-tcp-port rmb)) )
     105          ;Allow hostname to carry service/portno
     106          (if (not tcp-port)
     107            (connect (remote-mailbox-hostname rmb))
     108            (connect (remote-mailbox-hostname rmb) tcp-port) ) ) ) )
    111109      (remote-mailbox-input-port-set! rmb in)
    112110      (remote-mailbox-output-port-set! rmb out)
     
    126124      (remote-mailbox-key rmb)) ) )
    127125
    128 (define-check+error-type remote-mailbox)
    129 
    130126;;; Exported
    131127
    132128;; Parameters
    133129
    134 (define-parameter default-remote-mailbox-connect tcp-connect
    135   (lambda (x)
    136     (cond
    137       ((procedure? x)   x )
    138       ((not x)          tcp-connect )
    139       (else
    140         (warning-argument-type 'default-remote-mailbox-connect x 'procedure)
    141         (default-remote-mailbox-connect) ) ) ) )
     130(define (remote-mailbox-connector? x)
     131  (or (not x) (procedure? x)) )
     132
     133(: default-remote-mailbox-connect (#!optional (or boolean procedure) -> procedure))
     134;
     135(define-warning-parameter default-remote-mailbox-connect tcp-connect remote-mailbox-connector
     136  ;ugh, automagic identifier injection
     137  (unless obj (set! obj tcp-connect)) )
    142138
    143139;; Operations
    144140
     141(: remote-mailbox (mailbox-name #!rest -> remote-mailbox))
     142;
    145143(define (remote-mailbox name
    146144          #!key
    147145          (hostname (default-remote-mailbox-hostname))
    148           (tcp-port (default-remote-mailbox-tcp-port))
     146          (tcp-port (default-remote-mailbox-tcp-port-no))
    149147          (connect (default-remote-mailbox-connect)))
    150148  (*remote-mailbox
    151149    (check-mailbox-name 'remote-mailbox name 'name)
    152150    (check-hostname 'remote-mailbox hostname 'hostname)
    153     (or tcp-port (check-tcp-port 'remote-mailbox tcp-port 'tcp-port))
     151    (or tcp-port (check-tcp-port-no 'remote-mailbox tcp-port 'tcp-port))
    154152    (check-procedure 'remote-mailbox connect 'connect)) )
    155153
     154(: remote-mailbox? (* -> boolean : remote-mailbox))
     155;
    156156(define (remote-mailbox? obj)
    157157  (and (*remote-mailbox? obj) (valid-remote-mailbox? obj)) )
    158158
     159(define-check+error-type remote-mailbox)
     160
     161(: remote-mailbox-connected? (remote-mailbox -> boolean))
     162;
    159163(define (remote-mailbox-connected? rmb)
    160164  (*remote-mailbox-connected? (check-remote-mailbox 'remote-mailbox-connected? rmb)) )
    161165
     166(: remote-mailboxes (-> (list-of remote-mailbox)))
     167;
    162168(define (remote-mailboxes)
    163169  (dict-values/synch +remote-mailbox-key->remote-mailbox+) )
    164170
     171(: drop-remote-mailbox! (remote-mailbox -> void))
     172;
    165173(define (drop-remote-mailbox! rmb)
    166174  (*drop-remote-mailbox! (check-remote-mailbox 'drop-remote-mailbox! rmb)) )
    167175
     176(: drop-remote-mailboxes! (-> void))
     177;
    168178(define (drop-remote-mailboxes!)
    169179  (for-each (cut *drop-remote-mailbox! <>) (remote-mailboxes)) )
    170180
     181(: remote-mailbox-send! (remote-mailbox * -> void))
     182;
    171183(define (remote-mailbox-send! rmb val)
    172184  (record/synch remote-mailbox (check-remote-mailbox 'remote-mailbox-send! rmb)
    173     (let ((out (connection/remote-mailbox rmb))
    174           (req (make-remote-mailbox-packet (remote-mailbox-name rmb) val)) )
     185    (let (
     186      (out (connection/remote-mailbox rmb))
     187      (req (make-remote-mailbox-packet (remote-mailbox-name rmb) val)) )
    175188      (parameterize ((serializer (remote-mailbox-serializer rmb)))
    176189        (serialize req out) ) ) ) )
  • release/4/remote-mailbox/trunk/remote-mailbox-common.scm

    r34761 r35329  
    1414  ;DEPRECATED
    1515  default-remote-mailbox-tcp-port
    16   tcp-port?
    17   check-tcp-port
    18   error-tcp-port
    19 )
     16  tcp-port? check-tcp-port error-tcp-port)
    2017
    2118(import scheme chicken)
    22 
    23 (import
     19(use
    2420  (only srfi-13 string-null?)
    25   (only miscmacros define-parameter)
     21  (only moremacros define-warning-parameter)
    2622  (only type-errors warning-argument-type)
    2723  (only type-checks define-check+error-type))
    28 (require-library srfi-13 miscmacros type-errors type-checks)
    2924
    3025;;;
     
    4136;;;
    4237
     38(define-type mailbox-name symbol)
     39(define-type tcp-port-no fixnum)
     40(define-type hostname string)
     41
     42(: mailbox-name? (* -> boolean : mailbox-name))
     43;
    4344(define mailbox-name? symbol?)
    4445
     46(: tcp-port-no? (* -> boolean : tcp-port-no))
     47;
    4548(define (tcp-port-no? obj)
    4649  (and
    4750    (fixnum? obj)
    48     (and (fx< 0 obj) (fx< obj 65536))) )
     51    (and (fx< 0 obj) (fx<= obj 65535))) )
    4952
    50 (define tcp-port? tcp-port-no?)
    51 
     53(: hostname? (* -> boolean : hostname))
     54;
    5255(define (hostname? obj)
    5356  (and
     
    5861
    5962(define-check+error-type mailbox-name)
     63(define-check+error-type tcp-port-no)
    6064(define-check+error-type hostname)
    61 (define-check+error-type tcp-port)
    6265
    6366;;; Parameters
    6467
    65 (define-parameter default-remote-mailbox-tcp-port-no *tcp-port-no*
    66         (lambda (x)
    67                 (cond
    68                   ((tcp-port-no? x)  x )
    69                   ((not x)        *tcp-port-no* )
    70       (else
    71         (warning-argument-type 'default-remote-mailbox-tcp-port-no x 'procedure)
    72         (default-remote-mailbox-tcp-port-no) ) ) ) )
     68(define (remote-mailbox-tcp-port-no? x)
     69  (or (not x) (tcp-port-no? x)) )
    7370
     71(: default-remote-mailbox-tcp-port-no (#!optional (or boolean fixnum) -> fixnum))
     72;
     73(define-warning-parameter default-remote-mailbox-tcp-port-no *tcp-port-no* remote-mailbox-tcp-port-no
     74  ;ugh, automagic identifier injection
     75  (unless obj (set! obj *tcp-port-no*)) )
     76
     77(define (remote-mailbox-hostname? x)
     78  (or (not x) (hostname? x)) )
     79
     80(: default-remote-mailbox-hostname (#!optional (or boolean string) -> string))
     81;
     82(define-warning-parameter default-remote-mailbox-hostname *hostname* remote-mailbox-hostname
     83  ;ugh, automagic identifier injection
     84  (unless obj (set! obj *hostname*)) )
     85
     86;;DEPRECATED
     87
     88(: default-remote-mailbox-tcp-port (deprecated default-remote-mailbox-tcp-port-no))
    7489(define default-remote-mailbox-tcp-port default-remote-mailbox-tcp-port-no)
    7590
    76 (define-parameter default-remote-mailbox-hostname *hostname*
    77         (lambda (x)
    78                 (cond
    79                   ((hostname? x)  x )
    80                   ((not x)        *hostname* )
    81       (else
    82         (warning-argument-type 'default-remote-mailbox-hostname x 'procedure)
    83         (default-remote-mailbox-hostname) ) ) ) )
     91(: tcp-port? (deprecated tcp-port-no?))
     92(define tcp-port? tcp-port-no?)
     93
     94(: check-tcp-port (deprecated check-tcp-port-no))
     95(: error-tcp-port (deprecated error-tcp-port-no))
     96#|
     97Warning: in toplevel procedure `remote-mailbox-common#check-tcp-port':
     98  use of deprecated `remote-mailbox-common#tcp-port?' - consider `tcp-port-no?'
     99
     100Warning: in toplevel procedure `remote-mailbox-common#check-tcp-port':
     101  use of deprecated `remote-mailbox-common#error-tcp-port' - consider `error-tcp-port-no'
     102|#
     103(define-check+error-type tcp-port)
    84104
    85105) ;module remote-mailbox-common
  • release/4/remote-mailbox/trunk/remote-mailbox-packet.scm

    r34481 r35329  
    1111  remote-mailbox-packet-value )
    1212
    13 (import scheme)
    14 
    15 (import chicken)
     13(import scheme chicken)
    1614
    1715;;; Remote Mailbox Packet
     
    2523        (and
    2624          (vector? obj)
    27     (= 3 (vector-length obj))
     25    (fx= 3 (vector-length obj))
    2826    (eq? +remote-mailbox-tag+ (vector-ref obj 0))) )
    2927
  • release/4/remote-mailbox/trunk/remote-mailbox-server.scm

    r34761 r35329  
    1515  default-remote-mailbox-tcp-port-no
    1616  default-remote-mailbox-hostname
    17   ;DEPRECATED
    18   default-remote-mailbox-tcp-port
    1917  ;; Server
    2018  ; Parameters
     
    2422  make-remote-mailbox-server
    2523  make-remote-mailbox-server-thread
    26   local-mailbox/server
    27   drop-local-mailbox!/server
    28   local-mailbox-names/server
     24  local-mailbox-for-server
     25  drop-local-mailbox!-for-server
     26  local-mailbox-names-for-server
    2927  remote-mailbox-server-run!
    3028  remote-mailbox-server-start!
     
    4139  local-mailbox-thread
    4240  local-mailbox-start!
    43   local-mailbox)
     41  local-mailbox
     42  ;;DEPERCATED
     43  default-remote-mailbox-tcp-port
     44  local-mailbox/server
     45  drop-local-mailbox!/server
     46  local-mailbox-names/server)
    4447
    4548(import scheme chicken)
    46 
    47 (import
     49(use
    4850  (only srfi-18 make-thread thread-start! mutex-name thread-join!)
    4951  (only data-structures identity)
    5052  tcp
    5153  (only miscmacros define-parameter while)
     54  (only moremacros define-warning-parameter)
    5255  tcp-server
    5356  mailbox
     
    5962  remote-mailbox-packet
    6063  remote-mailbox-common)
    61 (require-library
    62   srfi-18 data-structures tcp
    63   tcp-server mailbox miscmacros lookup-table-synch type-checks
    64   condition-utils
    65   remote-mailbox-adapter
    66   remote-mailbox-packet
    67   remote-mailbox-common)
     64
     65;;;
     66
     67(define-type mailbox (struct mailbox))
     68(define-type mailbox-name symbol)
     69(define-type tcp-port-no fixnum)
     70(define-type hostname string)
     71
     72(define-type remote-mailbox-server (struct remote-mailbox-server))
    6873
    6974;;; Conditions
    7075
     76(: make-remote-mailbox-server-condition (string remote-mailbox-server list (or condition symbol list) -> condition))
     77;
    7178(define (make-remote-mailbox-server-condition msg rmbs args kind)
    7279  (make-exn-condition+
     
    8693;;
    8794
     95(: remote-mailbox-server? (* -> boolean : remote-mailbox-server))
     96(: remote-mailbox-server-name (remote-mailbox-server -> *))
     97(: remote-mailbox-server-auto-create? (remote-mailbox-server -> boolean))
     98(: remote-mailbox-server-listener (remote-mailbox-server -> tcp-listener))
     99(: remote-mailbox-server-request-limit (remote-mailbox-server -> fixnum))
     100(: remote-mailbox-server-debug (remote-mailbox-server -> *))
     101;
    88102(define-record-type remote-mailbox-server
    89103  (*make-remote-mailbox-server dctm nm autof desrl srvr thread lstnr rlim dbg thrd)
     
    99113  (dbg remote-mailbox-server-debug) )
    100114
     115(define-check+error-type remote-mailbox-server)
     116
    101117;; Parameters
    102118
    103 (define-constant default-request-count-limit 10000)
    104 
    105 (define-parameter default-remote-mailbox-listen tcp-listen
    106   (lambda (x)
    107     (cond
    108       ((procedure? x)
    109         x )
    110       ((not x)
    111         tcp-listen )
    112       (else
    113         (warning-argument-type 'default-remote-mailbox-listen x 'procedure)
    114         (default-remote-mailbox-listen) ) ) ) )
    115 
     119(define-constant DEFAULT-REQUEST-COUNT-LIMIT 10000)
     120
     121(define (remote-mailbox-listener? x)
     122  (or (not x) (procedure? x)) )
     123
     124(: default-remote-mailbox-listen (#!optional (or boolean procedure) -> procedure))
     125;
     126(define-warning-parameter default-remote-mailbox-listen tcp-listen remote-mailbox-listener
     127  ;ugh, automagic identifier injection
     128  (unless obj (set! obj tcp-listen)) )
     129
     130(: default-remote-mailbox-auto-create? (#!optional boolean -> boolean))
     131;
    116132(define-parameter default-remote-mailbox-auto-create? #t identity)
    117133
    118134;; Support
    119135
    120 (define-check+error-type remote-mailbox-server)
    121 
    122 (define (*local-mailbox/server rmbs name create?)
     136(: *local-mailbox-for-server (remote-mailbox-server * boolean -> mailbox))
     137;
     138(define (*local-mailbox-for-server rmbs name create?)
    123139  (dict-indempotent-ref!/synch
    124140    (remote-mailbox-server-dict/synch rmbs)
     
    126142    (lambda (def) (if create? (make-mailbox name) def))) )
    127143
     144(: make-remote-mailbox-server-thunk (remote-mailbox-server #!optional input-port -> procedure))
     145;
    128146(define ((make-remote-mailbox-server-thunk rmbs) #!optional (inp (current-input-port)))
    129147  (while (not (eof-object? (peek-char inp)))
    130     (let ((req
    131             (parameterize ((deserializer (remote-mailbox-server-deserializer rmbs)))
    132               (deserialize inp))))
     148    (let (
     149      (req
     150        (parameterize ((deserializer (remote-mailbox-server-deserializer rmbs)))
     151          (deserialize inp))) )
    133152      (cond
    134153        ((eq? (void) req)
     
    136155          )
    137156        ((remote-mailbox-packet? req)
    138           (let* ((nam
    139                   (remote-mailbox-packet-key req))
    140                  (lmb
    141                   (*local-mailbox/server
    142                     rmbs nam (remote-mailbox-server-auto-create? rmbs))) )
     157          (let* (
     158            (nam
     159              (remote-mailbox-packet-key req))
     160            (lmb
     161              (*local-mailbox-for-server
     162                rmbs nam (remote-mailbox-server-auto-create? rmbs))) )
    143163            (if lmb
    144164              (mailbox-send! lmb (remote-mailbox-packet-value req))
     
    172192;; Exported
    173193
     194(: make-remote-mailbox-server (#!rest -> remote-mailbox-server))
     195;
    174196(define (make-remote-mailbox-server
    175197          #!key
     
    178200          (name (gensym 'remote-mailbox-server:))
    179201          (auto-create? (default-remote-mailbox-auto-create?))
    180           (request-limit default-request-count-limit)
     202          (request-limit DEFAULT-REQUEST-COUNT-LIMIT)
    181203          debug)
    182204  (check-tcp-port-no 'make-remote-mailbox-server tcp-port-no 'tcp-port-no)
    183205  (check-procedure 'make-remote-mailbox-server listen 'listen)
    184206  (check-fixnum 'make-remote-mailbox-server request-limit 'request-limit)
    185   (let* ((rmbs
    186           (*make-remote-mailbox-server
    187             (make-dict/synch)
    188             name
    189             auto-create?
    190             (deserializer)
    191             #f #f
    192             (listen tcp-port-no)
    193             request-limit
    194             debug #f))
    195          (tcps
    196           (make-tcp-server
    197             (remote-mailbox-server-listener rmbs)
    198             (make-remote-mailbox-server-thunk rmbs)
    199             (remote-mailbox-server-request-limit rmbs))) )
     207  (let* (
     208    (rmbs
     209      (*make-remote-mailbox-server
     210        (make-dict/synch)
     211        name
     212        auto-create?
     213        (deserializer)
     214        #f #f
     215        (listen tcp-port-no)
     216        request-limit
     217        debug #f))
     218    (tcps
     219      (make-tcp-server
     220        (remote-mailbox-server-listener rmbs)
     221        (make-remote-mailbox-server-thunk rmbs)
     222        (remote-mailbox-server-request-limit rmbs))) )
    200223    (remote-mailbox-server-tcp-server-set! rmbs tcps)
    201224    rmbs ) )
    202225
     226(: make-remote-mailbox-server-thread (remote-mailbox-server -> thread))
     227;
    203228(define (make-remote-mailbox-server-thread rmbs)
    204229  (*make-remote-mailbox-server-thread
     
    207232;;
    208233
     234(: remote-mailbox-server-run! (remote-mailbox-server -> void))
     235;
    209236(define (remote-mailbox-server-run! rmbs)
    210237  (*remote-mailbox-server-run!
    211238    (check-remote-mailbox-server 'remote-mailbox-server-run! rmbs)) )
    212239
     240(: remote-mailbox-server-start! (remote-mailbox-server -> thread))
     241;
    213242(define (remote-mailbox-server-start! rmbs)
    214243  (*remote-mailbox-server-start!
    215244    (check-remote-mailbox-server 'remote-mailbox-server-start! rmbs)) )
    216245
     246(: remote-mailbox-server-stop! (remote-mailbox-server -> void))
     247;
    217248(define (remote-mailbox-server-stop! rmbs)
    218249  (*remote-mailbox-server-stop!
     
    221252;;
    222253
    223 (define (local-mailbox/server rmbs name #!optional (create? (remote-mailbox-server-auto-create? rmbs)))
    224   (*local-mailbox/server
    225     (check-remote-mailbox-server 'local-mailbox/server rmbs)
    226     (check-mailbox-name 'local-mailbox/server name) create?) )
    227 
    228 (define (drop-local-mailbox!/server rmbs name)
     254(: local-mailbox-for-server (remote-mailbox-server mailbox-name -> mailbox))
     255;
     256(define (local-mailbox-for-server rmbs name #!optional (create? (remote-mailbox-server-auto-create? rmbs)))
     257  (*local-mailbox-for-server
     258    (check-remote-mailbox-server 'local-mailbox-for-server rmbs)
     259    (check-mailbox-name 'local-mailbox-for-server name) create?) )
     260
     261(: drop-local-mailbox!-for-server (remote-mailbox-server mailbox-name -> void))
     262;
     263(define (drop-local-mailbox!-for-server rmbs name)
    229264  (dict-delete!/synch
    230265    (remote-mailbox-server-dict/synch
    231       (check-remote-mailbox-server 'drop-local-mailbox!/server rmbs))
    232     (check-mailbox-name 'drop-local-mailbox!/server name)) )
    233 
    234 (define (local-mailbox-names/server rmbs)
     266      (check-remote-mailbox-server 'drop-local-mailbox!-for-server rmbs))
     267    (check-mailbox-name 'drop-local-mailbox!-for-server name)) )
     268
     269(: local-mailbox-names-for-server (remote-mailbox-server -> (list-of string)))
     270;
     271(define (local-mailbox-names-for-server rmbs)
    235272  (dict-keys/synch
    236273    (remote-mailbox-server-dict/synch
     
    242279(define +thrd+ #f)
    243280
     281(: local-mailbox-start! (#!optional * -> void))
     282;
    244283(define (local-mailbox-start! #!optional debug)
    245284  (unless +rmbs+
     
    247286    (set! +thrd+ (*remote-mailbox-server-start! +rmbs+)) ) )
    248287
     288(: local-mailbox-server (-> remote-mailbox-server))
     289;
    249290(define (local-mailbox-server)
    250291  +rmbs+ )
    251292
     293(: local-mailbox-thread (-> thread))
     294;
    252295(define (local-mailbox-thread)
    253296  +thrd+ )
    254297
    255 ;(: local-mailbox (symbol #!optional * ->
     298(: local-mailbox (mailbox-name #!optional * -> mailbox))
     299;
    256300(define (local-mailbox name #!optional debug)
    257301  (unless +rmbs+ (local-mailbox-start! debug))
    258   (*local-mailbox/server +rmbs+ (check-mailbox-name 'local-mailbox name) #t) )
     302  (*local-mailbox-for-server +rmbs+ (check-mailbox-name 'local-mailbox name) #t) )
     303
     304;;DEPRECATED
     305
     306(: local-mailbox/server deprecated)
     307(define local-mailbox/server local-mailbox-for-server)
     308
     309(: drop-local-mailbox!/server deprecated)
     310(define drop-local-mailbox!/server drop-local-mailbox!-for-server)
     311
     312(: local-mailbox-names/server (deprecated local-mailbox-names-for-server))
     313(define local-mailbox-names/server local-mailbox-names-for-server)
     314
     315;(: default-remote-mailbox-tcp-port (deprecated default-remote-mailbox-tcp-port-no))
    259316
    260317) ;module remote-mailbox-server
  • release/4/remote-mailbox/trunk/remote-mailbox.meta

    r34481 r35329  
    1313        (mailbox "2.1.2")
    1414        (miscmacros "2.91")
     15        (moremacros "1.5.0")
    1516        (lookup-table "1.13.1")
    1617        (check-errors "1.12.0")
  • release/4/remote-mailbox/trunk/remote-mailbox.setup

    r34761 r35329  
    66
    77(setup-shared-extension-module 'remote-mailbox-common (extension-version "2.2.0")
     8  #:inline? #t
     9  #:types? #t
    810  #:compile-options '(
    911    -scrutinize
     
    1315
    1416(setup-shared-extension-module 'remote-mailbox-packet (extension-version "2.2.0")
     17  #:inline? #t
     18  #:types? #t
    1519  #:compile-options '(
    1620    -scrutinize
     
    2024
    2125(setup-shared-extension-module 'remote-mailbox-adapter (extension-version "2.2.0")
     26  #:inline? #t
     27  #:types? #t
    2228  #:compile-options '(
    2329    -scrutinize
     
    2733
    2834(setup-shared-extension-module 'remote-mailbox-client (extension-version "2.2.0")
     35  #:inline? #t
     36  #:types? #t
    2937  #:compile-options '(
    3038    -scrutinize
     
    3442
    3543(setup-shared-extension-module 'remote-mailbox-server (extension-version "2.2.0")
     44  #:inline? #t
     45  #:types? #t
    3646  #:compile-options '(
    3747    -scrutinize
  • release/4/remote-mailbox/trunk/tests/remote-mailbox-test.scm

    r34486 r35329  
    1717(define (sender)
    1818  (print "* Sending " NUM-MSG " messages")
    19         (let ((rmb (remote-mailbox MB-NAM)))
    20                 (dotimes (n NUM-MSG)
    21                               ;a message can be any object
    22                   (let ((msg (vector 'message `(recipient ,RCV-NAM) `(id ,n))))
     19  (let ((rmb (remote-mailbox MB-NAM)))
     20    (dotimes (n NUM-MSG)
     21      (let (
     22        ;a message can be any object
     23        (msg (vector 'message `(recipient ,RCV-NAM) `(id ,n))) )
    2324        (printf "Sending ~S to ~S~%" msg MB-NAM)
    2425        (remote-mailbox-send! rmb msg) )
    25                         ; Semblance of computation
    26                         #;(repeat 10000)
    27                         (thread-sleep! 1) )
    28                 #;(close-output-port (serializer-output))
    29                 (begin
    30                   (print "Send quit")
    31                   (remote-mailbox-send! rmb 'quit)) ) )
     26      ;Semblance of computation
     27      #;(repeat 10000)
     28      (thread-sleep! 1) )
     29    #;(close-output-port (serializer-output))
     30    (begin
     31      (print "Send quit")
     32      (remote-mailbox-send! rmb 'quit)) ) )
    3233
    3334(define (receiver)
     
    4950      (print "* Receiving messages until 'quit")
    5051      (let receive-loop ()
    51         (let ((msg (mailbox-receive! (local-mailbox/server rmbs MB-NAM))))
     52        (let ((msg (mailbox-receive! (local-mailbox-for-server rmbs MB-NAM))))
    5253          (printf "Received ~S from ~S~%" msg MB-NAM)
    5354          (unless (eq? 'quit msg)
     
    7273
    7374(define operation
    74         (let ((args (command-line-arguments)))
    75                 (and
    76                   (pair? args)
     75  (let ((args (command-line-arguments)))
     76    (and
     77      (pair? args)
    7778      (string->symbol (car args))) ) )
    7879
Note: See TracChangeset for help on using the changeset viewer.