Changeset 39700 in project


Ignore:
Timestamp:
03/14/21 16:55:30 (5 weeks ago)
Author:
Kon Lovett
Message:

new test runner, remove "primitives", stop variant `check-' proc gen, fix record printers

Location:
release/5/mailbox/trunk
Files:
1 added
2 deleted
8 edited

Legend:

Unmodified
Added
Removed

  • release/5/mailbox/trunk/inline-queue.scm

    r37684 r39700  
    1313;the identifier needs to be defined by somebody
    1414(define queue 'queue)
    15 
    1615(define-record-type-variant queue (unsafe unchecked inline)
    17   (%%make-queue hd tl)
    18   %queue?
     16  (%make-queue hd tl)
     17  (%queue?)
    1918  (hd %queue-first-pair %queue-first-pair-set!)
    2019  (tl %queue-last-pair %queue-last-pair-set!) )
    2120
    22 (define-inline (%make-queue) (%%make-queue '() '()))
     21(define-inline (%make-empty-queue) (%make-queue '() '()))
    2322
    24 (define-inline (%queue-empty? q) ($null? (%queue-first-pair q)))
    25 (define-inline (%queue-count q) ($length (%queue-first-pair q)))
     23(define-inline (%queue-empty? q) (null? (%queue-first-pair q)))
     24(define-inline (%queue-count q) (length (%queue-first-pair q)))
    2625
    2726;; Operations
    … …  
    3029
    3130(define-inline (%queue-add! q datum)
    32   (let ((new-pair ($cons datum '())))
    33     (if ($null? (%queue-first-pair q))
     31  (let ((new-pair (cons datum '())))
     32    (if (null? (%queue-first-pair q))
    3433      (%queue-first-pair-set! q new-pair)
    35       ($set-cdr! (%queue-last-pair q) new-pair) )
     34      (set-cdr! (%queue-last-pair q) new-pair) )
    3635    (%queue-last-pair-set! q new-pair) ) )
    3736
    3837(define-inline (%queue-remove! q)
    3938  (let* ((first-pair (%queue-first-pair q))
    40          (next-pair ($cdr first-pair)))
     39         (next-pair (cdr first-pair)))
    4140    (%queue-first-pair-set! q next-pair)
    42     (when ($null? next-pair) (%queue-last-pair-empty! q) )
    43     ($car first-pair) ) )
     41    (when (null? next-pair) (%queue-last-pair-empty! q) )
     42    (car first-pair) ) )
    4443
    4544(define-inline (%queue-push-back! q item)
    46   (let ((newlist ($cons item (%queue-first-pair q))))
     45  (let ((newlist (cons item (%queue-first-pair q))))
    4746    (%queue-first-pair-set! q newlist)
    48     (when ($null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) ) ) )
     47    (when (null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) ) ) )
    4948
    5049(define-inline (%queue-push-back-list! q itemlist)
    51   (let ((newlist ($append! ($list-copy itemlist) (%queue-first-pair q))))
     50  (let ((newlist (append! (list-copy itemlist) (%queue-first-pair q))))
    5251    (%queue-first-pair-set! q newlist)
    53     (if ($null? newlist)
     52    (if (null? newlist)
    5453      (%queue-last-pair-empty! q)
    55       (%queue-last-pair-set! q ($last-pair newlist) ) ) ) )
     54      (%queue-last-pair-set! q (last-pair newlist) ) ) ) )
    5655
    5756(define-inline (%queue-extract-pair! q targ-pair)
    … …  
    6564        (warning "cannot find queue pair to extract; simultaneous operations?"))
    6665      ;found?
    67       (($eq? this-pair targ-pair)
     66      ((eq? this-pair targ-pair)
    6867        ;so cut out the pair
    69         (let ((next-pair ($cdr this-pair)))
     68        (let ((next-pair (cdr this-pair)))
    7069          ;at the head of the list, or in the body?
    71           (if ($null? prev-pair)
     70          (if (null? prev-pair)
    7271            (%queue-first-pair-set! q next-pair)
    73             ($set-cdr! prev-pair next-pair) )
     72            (set-cdr! prev-pair next-pair) )
    7473          ;when the cut pair is the last item update the last pair ref.
    75           (when ($eq? this-pair (%queue-last-pair q))
     74          (when (eq? this-pair (%queue-last-pair q))
    7675            (%queue-last-pair-set! q prev-pair)) ) )
    7776      ;not found
    7877      (else
    79         (scanning ($cdr this-pair) this-pair) ) ) ) )
     78        (scanning (cdr this-pair) this-pair) ) ) ) )

  • release/5/mailbox/trunk/inline-type-checks.scm

    r36012 r39700  
    1919
    2020  (unsafe
    21  
     21
    2222    (define-syntax define-inline-check-type
    2323      (er-macro-transformer
    … …  
    5656                   (typstr (symbol->string typ))
    5757                   (pred (if (not (null? (cddr frm))) (caddr frm)
    58                            (string->symbol (string-append "%" typstr "?"))))
     58                           (string->symbol (string-append #;"%" typstr "?"))))
    5959                   (nam (string->symbol (string-append "%check-" typstr)))
    6060                   (errnam (string->symbol (string-append "error-" typstr))) )

  • release/5/mailbox/trunk/mailbox.egg

    r39006 r39700  
    1414    (types-file)
    1515    (csc-options
    16       "-feature" "unsafe-operations"
    1716      ;"-feature" "sleep-primordial-thread"
    1817      "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") ) ) )

  • release/5/mailbox/trunk/mailbox.scm

    r39012 r39700  
    66
    77;; Issues
    8 ;;
    9 ;; - When compile-time feature `unsafe-operations' inlined & primitive routines used.
    108;;
    119;; - Has explicit "unspecified" returns in some cases to avoid leaks of internal
    … …  
    6159  mailbox-cursor-extract-and-rewind!)
    6260
    63 (import scheme)
    64 (import (chicken base))
    65 (import (chicken syntax))
    66 (import (chicken condition))
    67 (import (chicken type))
    68 (import (only (chicken port) with-output-to-port))
    69 (import (only (chicken format) printf))
    70 (import (only (chicken string) ->string))
    71 (import (only (srfi 1) append! delete! list-copy last-pair))
    72 (import (only (srfi 18)
    73   time?
    74   current-thread
    75   thread-signal! thread-sleep!
    76   thread-suspend! thread-resume!))
    77 (import record-variants)
     61(import scheme
     62  (chicken base)
     63  (chicken syntax)
     64  (chicken condition)
     65  (chicken type)
     66  (only (chicken port) with-output-to-port)
     67  (only (chicken format) printf)
     68  (only (chicken string) ->string)
     69  (only (srfi 1) append! delete! list-copy last-pair)
     70  (only (srfi 18)
     71    time?
     72    current-thread
     73    thread-signal! thread-sleep!
     74    thread-suspend! thread-resume!)
     75  record-variants)
    7876
    7977;;; Support
    8078
    81 ;;
    82 
    83 (define-inline (->boolean obj) (and obj #t))
    84 
    85 ;;miscmacros, Felix Winkelmann
     79;;miscmacros
    8680
    8781;; evaluates body with an explicit exit continuation
    … …  
    9387        (lambda (k) e0 e1 ...)))))
    9488
    95 ;;
    96 
    97 (define-type srfi-18-time (struct time))
    98 
    99 (define-type mailbox (struct mailbox))
    100 
    101 (define-type mailbox-cursor (struct mailbox-cursor))
    102 
    103 (define-type time-number (or fixnum float))
    104 
    105 (define-type timeout (or time-number srfi-18-time))
    106 
    107 (define-type unique-object (vector-of symbol))
    108 
    109 (: mailbox-timeout-condition? (* -> boolean : condition))
    110 (: make-mailbox (#!optional * -> mailbox))
    111 (: mailbox? (* -> boolean : mailbox))
    112 (: mailbox-name (mailbox --> *))
    113 (: mailbox-empty? (mailbox -> boolean))
    114 (: mailbox-count (mailbox -> fixnum))
    115 (: mailbox-waiting? (mailbox -> boolean))
    116 (: mailbox-waiters (mailbox -> list))
    117 (: mailbox-send! (mailbox * -> void))
    118 (: mailbox-wait! (mailbox #!optional timeout -> void))
    119 (: mailbox-receive! (mailbox #!optional timeout * -> *))
    120 (: mailbox-push-back! (mailbox * -> void))
    121 (: mailbox-push-back-list! (mailbox list -> void))
    122 (: make-mailbox-cursor (mailbox -> mailbox-cursor))
    123 (: mailbox-cursor? (* -> boolean : mailbox-cursor))
    124 (: mailbox-cursor-mailbox (mailbox-cursor --> mailbox))
    125 (: mailbox-cursor-rewound? (mailbox-cursor -> boolean))
    126 (: mailbox-cursor-unwound? (mailbox-cursor -> boolean))
    127 (: mailbox-cursor-rewind (mailbox-cursor -> void))
    128 (: mailbox-cursor-next (mailbox-cursor #!optional timeout * -> *))
    129 (: mailbox-cursor-extract-and-rewind! (mailbox-cursor -> void))
    130 
    13189;;(only type-errors define-error-type)
    13290
    … …  
    148106  (##sys#signal-hook #:type-error loc obj (make-error-type-message 'list argnam) obj) )
    149107
    150 ;;; Primitives
    151 
    152 (include "chicken-primitive-object-inlines")
    153 (include "chicken-thread-object-inlines")
    154 (include "inline-type-checks")
    155 (include "inline-queue")
    156 
    157 (cond-expand
    158   (unsafe-operations
    159     (define-syntax $eq? (syntax-rules () ((_ ?arg0 ...) (%eq? ?arg0 ...))))
    160     (define-syntax $null? (syntax-rules () ((_ ?arg0 ...) (%null? ?arg0 ...))))
    161     (define-syntax $list? (syntax-rules () ((_ ?arg0 ...) (%list? ?arg0 ...))))
    162     (define-syntax $length (syntax-rules () ((_ ?arg0 ...) (%length ?arg0 ...))))
    163     (define-syntax $append! (syntax-rules () ((_ ?arg0 ...) (%append! ?arg0 ...))))
    164     (define-syntax $delq! (syntax-rules () ((_ ?arg0 ...) (%delq! ?arg0 ...))))
    165     (define-syntax $cons (syntax-rules () ((_ ?arg0 ...) (%cons ?arg0 ...))))
    166     (define-syntax $car (syntax-rules () ((_ ?arg0 ...) (%car ?arg0 ...))))
    167     (define-syntax $cdr (syntax-rules () ((_ ?arg0 ...) (%cdr ?arg0 ...))))
    168     (define-syntax $set-car! (syntax-rules () ((_ ?arg0 ...) (%set-car! ?arg0 ...))))
    169     (define-syntax $set-cdr! (syntax-rules () ((_ ?arg0 ...) (%set-cdr! ?arg0 ...))))
    170     (define-syntax $list-copy (syntax-rules () ((_ ?arg0 ...) (%list-copy ?arg0 ...))))
    171     (define-syntax $last-pair (syntax-rules () ((_ ?arg0 ...) (%last-pair ?arg0 ...))))
    172     (define-syntax $current-thread (syntax-rules () ((_ ?arg0 ...) (%current-thread ?arg0 ...))))
    173     (define-syntax $thread-blocked? (syntax-rules () ((_ ?arg0 ...) (%thread-blocked? ?arg0 ...))))
    174     (define-syntax $thread-blocked-for-timeout? (syntax-rules () ((_ ?arg0 ...) (%thread-blocked-for-timeout? ?arg0 ...)))) )
    175   (else
    176     (define-syntax $eq? (syntax-rules () ((_ ?arg0 ...) (eq? ?arg0 ...))))
    177     (define-syntax $null? (syntax-rules () ((_ ?arg0 ...) (null? ?arg0 ...))))
    178     (define-syntax $list? (syntax-rules () ((_ ?arg0 ...) (list? ?arg0 ...))))
    179     (define-syntax $length (syntax-rules () ((_ ?arg0 ...) (length ?arg0 ...))))
    180     (define-syntax $append! (syntax-rules () ((_ ?arg0 ...) (append! ?arg0 ...))))
    181     (define-syntax $delq! (syntax-rules () ((_ ?arg0 ...) (delete! ?arg0 ...))))
    182     (define-syntax $cons (syntax-rules () ((_ ?arg0 ...) (cons ?arg0 ...))))
    183     (define-syntax $car (syntax-rules () ((_ ?arg0 ...) (car ?arg0 ...))))
    184     (define-syntax $cdr (syntax-rules () ((_ ?arg0 ...) (cdr ?arg0 ...))))
    185     (define-syntax $set-car! (syntax-rules () ((_ ?arg0 ...) (set-car! ?arg0 ...))))
    186     (define-syntax $set-cdr! (syntax-rules () ((_ ?arg0 ...) (set-cdr! ?arg0 ...))))
    187     (define-syntax $list-copy (syntax-rules () ((_ ?arg0 ...) (list-copy ?arg0 ...))))
    188     (define-syntax $last-pair (syntax-rules () ((_ ?arg0 ...) (last-pair ?arg0 ...))))
    189     (define-syntax $current-thread (syntax-rules () ((_ ?arg0 ...) (current-thread ?arg0 ...))))
    190     (define ($thread-blocked? th) (eq? 'blocked (##sys#slot th 3)))
    191     (define ($thread-blocked-for-timeout? th) (and (##sys#slot th 4) (not (##sys#slot th 11)))) ) )
    192 
    193 ;;; Mailbox Support
    194 
    195 ;; Mailbox
     108(include-relative "inline-type-checks")
     109
     110;;
     111
     112(define-inline (%delq! x ls0)
     113  ;(assert (proper-list? ls0))
     114  (let find-elm ((ls ls0) (ppr #f))
     115    (cond ((null? ls)
     116           ls0 )
     117          ((eq? x (car ls))
     118           (cond (ppr
     119                  (set-cdr! ppr (cdr ls))
     120                  ls0 )
     121                 (else
     122                  (cdr ls) ) ) )
     123          (else
     124           (find-elm (cdr ls) ls) ) ) ) )
     125
     126(define-inline (%thread-blocked? th) (eq? 'blocked (##sys#slot th 3)))
     127(define-inline (%thread-blocked-for-timeout? th) (and (##sys#slot th 4) (not (##sys#slot th 11))))
     128
     129(define-inline (%->boolean obj) (and obj #t))
     130
     131(define-inline (%make-unique-object #!optional (id 'unique)) (vector id))
     132
     133;; Time Support
     134
     135(define-inline (%time-number? obj)
     136  (or (fixnum? obj) (flonum? obj)) )
     137
     138(define-inline (%timeout? obj)
     139  (or (%time-number? obj) (time? obj)) )
     140
     141(define (error-timeout loc obj #!optional argnam)
     142  (##sys#signal-hook #:type-error loc (make-error-type-message 'timeout argnam) obj) )
     143
     144(define (timeout? obj) (%timeout? obj))
     145
     146(define-inline-check-type timeout)
     147
     148;; Queue Support
     149
     150(include-relative "inline-queue")
     151
     152;;; Typoes
     153
     154(define-type srfi-18-time   (struct time))
     155(define-type mailbox        (struct mailbox))
     156(define-type mailbox-cursor (struct mailbox-cursor))
     157(define-type time-number    (or fixnum float))
     158(define-type timeout        (or time-number srfi-18-time))
     159(define-type unique-object  (vector-of symbol))
     160
     161(: mailbox-timeout-condition?         (* -> boolean : condition))
     162(: make-mailbox                       (#!optional * -> mailbox))
     163(: mailbox?                           (* -> boolean : mailbox))
     164(: mailbox-name                       (mailbox --> *))
     165(: mailbox-empty?                     (mailbox -> boolean))
     166(: mailbox-count                      (mailbox -> fixnum))
     167(: mailbox-waiting?                   (mailbox -> boolean))
     168(: mailbox-waiters                    (mailbox -> list))
     169(: mailbox-send!                      (mailbox * -> void))
     170(: mailbox-wait!                      (mailbox #!optional timeout -> void))
     171(: mailbox-receive!                   (mailbox #!optional timeout * -> *))
     172(: mailbox-push-back!                 (mailbox * -> void))
     173(: mailbox-push-back-list!            (mailbox list -> void))
     174(: make-mailbox-cursor                (mailbox -> mailbox-cursor))
     175(: mailbox-cursor?                    (* -> boolean : mailbox-cursor))
     176(: mailbox-cursor-mailbox             (mailbox-cursor --> mailbox))
     177(: mailbox-cursor-rewound?            (mailbox-cursor -> boolean))
     178(: mailbox-cursor-unwound?            (mailbox-cursor -> boolean))
     179(: mailbox-cursor-rewind              (mailbox-cursor -> void))
     180(: mailbox-cursor-next                (mailbox-cursor #!optional timeout * -> *))
     181(: mailbox-cursor-extract-and-rewind! (mailbox-cursor -> void))
     182
     183;;; Mailbox
    196184
    197185;the identifier needs to be defined by somebody
    198186(define mailbox 'mailbox)
    199 
    200187(define-record-type-variant mailbox (unsafe unchecked inline)
    201188  (%raw-make-mailbox nm qu wt)
    202   %mailbox?
     189  (%mailbox?)
    203190  (nm %mailbox-name)
    204191  (qu %mailbox-queue)
    … …  
    206193
    207194(define-inline (%make-mailbox nm)
    208   (%raw-make-mailbox nm (%make-queue) '()) )
     195  (%raw-make-mailbox nm (%make-empty-queue) '()) )
    209196
    210197(define (error-mailbox loc obj #!optional argnam)
    … …  
    242229
    243230(define-inline (%mailbox-waiters-empty? mb)
    244   ($null? (%mailbox-waiters mb)) )
     231  (null? (%mailbox-waiters mb)) )
    245232
    246233(define-inline (%mailbox-waiters-count mb)
    247   ($length (%mailbox-waiters mb)) )
     234  (length (%mailbox-waiters mb)) )
    248235
    249236(define-inline (%mailbox-waiters-add! mb th)
    250   (%mailbox-waiters-set! mb ($append! (%mailbox-waiters mb) ($cons th '()))) )
     237  (%mailbox-waiters-set! mb (append! (%mailbox-waiters mb) (cons th '()))) )
    251238
    252239(define-inline (%mailbox-waiters-delete! mb th)
    253   (%mailbox-waiters-set! mb ($delq! th (%mailbox-waiters mb))) )
     240  (%mailbox-waiters-set! mb (%delq! th (%mailbox-waiters mb))) )
    254241
    255242(define-inline (%mailbox-waiters-pop! mb)
    256243  (let ((ts (%mailbox-waiters mb)))
    257     (%mailbox-waiters-set! mb ($cdr ts))
    258     ($car ts) ) )
     244    (%mailbox-waiters-set! mb (cdr ts))
     245    (car ts) ) )
    259246
    260247;;; Mailbox Cursor Support
    … …  
    262249;the identifier needs to be defined by somebody
    263250(define mailbox-cursor 'mailbox-cursor)
    264 
    265251(define-record-type-variant mailbox-cursor (unsafe unchecked inline)
    266252  (%raw-make-mailbox-cursor np pp mb)
    267   %mailbox-cursor?
     253  (%mailbox-cursor?)
    268254  (np %mailbox-cursor-next-pair %mailbox-cursor-next-pair-set!)
    269255  (pp %mailbox-cursor-prev-pair %mailbox-cursor-prev-pair-set!)
    … …  
    279265
    280266(define-inline (%mailbox-cursor-winding? mbc)
    281   (->boolean (%mailbox-cursor-prev-pair mbc)) )
     267  (%->boolean (%mailbox-cursor-prev-pair mbc)) )
    282268
    283269(define-inline (%mailbox-cursor-next-pair-empty! mbc)
    … …  
    295281  (and-let* ((prev-pair (%mailbox-cursor-prev-pair mbc)))
    296282    (%queue-extract-pair! (%mailbox-queue (%mailbox-cursor-mailbox mbc)) prev-pair) ) )
    297 
    298 ;; Time Support
    299 
    300 (define-inline (%time-number? obj)
    301   (or (fixnum? obj) (flonum? obj)) )
    302 
    303 (define-inline (%timeout? obj)
    304   (or (%time-number? obj) (time? obj)) )
    305 
    306 (define (error-timeout loc obj #!optional argnam)
    307   (##sys#signal-hook #:type-error loc (make-error-type-message 'timeout argnam) obj) )
    308 
    309 (define-inline-check-type timeout)
    310283
    311284;;;
    … …  
    321294
    322295(define-inline (optional-timeout-value x #!optional (def (void)))
    323   (if ($eq? x NO-TOVAL-TAG) def x) )
     296  (if (eq? x NO-TOVAL-TAG) def x) )
    324297
    325298(define (make-mailbox-timeout-condition loc mb timout timout-value)
    … …  
    344317  (and-let* ((th (%mailbox-waiters-pop!? mb)))
    345318    ;ready the thread based on wait mode
    346     (if (not ($thread-blocked? th))
     319    (if (not (%thread-blocked? th))
    347320      ;then restart
    348321      (thread-resume! th)
    349322      ;else wake early if sleeping
    350323      ;all others dropped on the floor
    351       (when ($thread-blocked-for-timeout? th)
     324      (when (%thread-blocked-for-timeout? th)
    352325        ;ready the thread
    353326        (##sys#thread-unblock! th)
    … …  
    365338    (with-exception-handler
    366339      (lambda (exp)
    367         (if ($eq? unblocked-tag exp)
     340        (if (eq? unblocked-tag exp)
    368341          (return #f)
    369342          ;propagate any "real" exception.
    … …  
    379352  ;no available message due to timeout
    380353  (define (timeout-exit!)
    381     (if (not ($eq? timout-value NO-TOVAL-TAG))
     354    (if (not (eq? timout-value NO-TOVAL-TAG))
    382355      timout-value
    383356      (begin
    384357        (thread-signal!
    385           ($current-thread)
     358          (current-thread)
    386359          (make-mailbox-timeout-condition loc mb timout timout-value))
    387360        SEQ-FAIL-TAG ) ) )
    388361  ;
    389362  ;push current thread on mailbox waiting queue
    390   (%mailbox-waiters-add! mb ($current-thread))
     363  (%mailbox-waiters-add! mb (current-thread))
    391364  ;waiting action
    392365  (cond
    … …  
    400373              ;timed-out, so no message
    401374              ;remove from wait queue
    402               (%mailbox-waiters-delete! mb ($current-thread))
     375              (%mailbox-waiters-delete! mb (current-thread))
    403376              ;indicate no available message
    404377              (timeout-exit!) )
    … …  
    408381        (else
    409382          ;
    410           (if (eq? ($current-thread) ##sys#primordial-thread)
     383          (if (eq? (current-thread) ##sys#primordial-thread)
    411384            (begin
    412               (%mailbox-waiters-delete! mb ($current-thread))
     385              (%mailbox-waiters-delete! mb (current-thread))
    413386              (warning "mailbox attempt to sleep primordial-thread" mb)
    414387              (timeout-exit!) )
    … …  
    417390                ;timed-out, so no message
    418391                ;remove from wait queue
    419                 (%mailbox-waiters-delete! mb ($current-thread))
     392                (%mailbox-waiters-delete! mb (current-thread))
    420393                ;indicate no available message
    421394                (timeout-exit!) )
    … …  
    425398    ;no timeout so suspend until something delivered
    426399    (else
    427       (thread-suspend! ($current-thread))
     400      (thread-suspend! (current-thread))
    428401      ;we're resumed
    429402      UNBLOCKED-TAG ) ) )
    … …  
    441414              (let ((res (wait-mailbox-thread! ?loc _mb _to _tv)))
    442415                ;when a thread ready then check mailbox again, could be empty.
    443                 (if ($eq? UNBLOCKED-TAG res)
     416                (if (eq? UNBLOCKED-TAG res)
    444417                  (waiting)
    445418                  ;else some sort of problem
    … …  
    483456
    484457(define (mailbox-waiting? mb)
    485   (not ($null? (%mailbox-waiters (%check-mailbox 'mailbox-waiting? mb)))) )
     458  (not (null? (%mailbox-waiters (%check-mailbox 'mailbox-waiting? mb)))) )
    486459
    487460(define (mailbox-waiters mb)
    488   ($list-copy (%mailbox-waiters (%check-mailbox 'mailbox-waiters mb))) )
     461  (list-copy (%mailbox-waiters (%check-mailbox 'mailbox-waiters mb))) )
    489462
    490463;; Mailbox Operations
    … …  
    515488  (%mailbox-queue-push-back-list!
    516489    (%check-mailbox 'mailbox-send! mb)
    517     (%check-list ls 'mailbox-send!))
     490    (%check-list 'mailbox-push-back-list! ls 'mailbox-send!))
    518491  (ready-mailbox-thread! mb) )
    519492
    520493;; Read/Print Syntax
    521494
    522 (define-record-printer (mailbox mb out)
     495(define (mailbox-print mb out)
    523496  (with-output-to-port out
    524497    (lambda ()
    … …  
    547520
    548521(define (mailbox-cursor-unwound? mbc)
    549   ($null? (%mailbox-cursor-next-pair (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc))) )
     522  (null? (%mailbox-cursor-next-pair (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc))) )
    550523
    551524;; Mailbox Cursor Operations
    … …  
    564537      (let ((curr-pair (%mailbox-cursor-next-pair mbc)))
    565538        ;anything next?
    566         (if (not ($null? curr-pair))
     539        (if (not (null? curr-pair))
    567540          ;then peek into the queue for the next item
    568           (let ((item ($car curr-pair)))
     541          (let ((item (car curr-pair)))
    569542            (%mailbox-cursor-prev-pair-set! mbc curr-pair)
    570             (%mailbox-cursor-next-pair-set! mbc ($cdr curr-pair))
     543            (%mailbox-cursor-next-pair-set! mbc (cdr curr-pair))
    571544            item )
    572545          ;else wait for something in the mailbox
    … …  
    574547            (cond
    575548              ;continue scanning?
    576               (($eq? UNBLOCKED-TAG res)
     549              ((eq? UNBLOCKED-TAG res)
    577550                (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-last-pair mb))
    578551                (scanning) )
    … …  
    587560;; Read/Print Syntax
    588561
    589 (define-record-printer (mailbox-cursor mbc out)
     562(define (mailbox-cursor-print mbc out)
    590563  (with-output-to-port out
    591564    (lambda ()
    … …  
    594567      (if (%mailbox-cursor-winding? mbc) "winding" "rewound")) ) ) )
    595568
     569;;;
     570
     571(set! (record-printer mailbox) mailbox-print)
     572(set! (record-printer mailbox-cursor) mailbox-cursor-print)
     573
    596574) ;module mailbox

  • release/5/mailbox/trunk/tests/mailbox-cursor-test.scm

    r36192 r39700  
    2727
    2828(define (thread-labeled-print . args)
     29  (apply print (current-thread-name) " - " args)
     30  #; ;only 2 threads!
    2931        (critical-section (apply print (current-thread-name) " - " args) ) )
    3032

  • release/5/mailbox/trunk/tests/mailbox-primordial-test.scm

    r38524 r39700  
    2222
    2323(assert (eq? ##sys#primordial-thread (current-thread)))
    24 (define *primordial-thread* ##sys#primordial-thread)
    25 
    26 ;;
    2724
    2825(define (test-thread)
    2926  (thread-sleep! 1)
    30   (thread-signal! *primordial-thread* 'example) )
     27  (thread-signal! ##sys#primordial-thread 'example) )
    3128
    3229(define test-thread-1 (thread-start! test-thread))
    33 
    34 ;;
    3530
    3631;#; ;this hangs forever and eats all my cycles (with timeout)

  • release/5/mailbox/trunk/tests/reader-writer-test.scm

    r36192 r39700  
    2929
    3030(define (thread-labeled-print . args)
     31  (apply print (current-thread-name) " - " args)
     32  #; ;only 2 threads!
    3133        (critical-section (apply print (current-thread-name) " - " args) ) )
    3234

  • release/5/mailbox/trunk/tests/run.scm

    r38524 r39700  
    33(import scheme)
    44
    5 ;;; Create Egg Const
     5;; Create Egg Const
    66
    7 (define EGG-NAME "mailbox")
     7(include-relative "run-ident")
    88
    99;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    … …  
    1818
    1919(define *args* (argv))
     20(define *current-directory* (cond-expand (unix "./") (else #f)))
     21;no -disable-interrupts or -no-lambda-info
     22(define *csc-init-options* '(-inline-global -local -inline -specialize
     23  -optimize-leaf-routines -clustering -lfa2 -no-trace -unsafe -strict-types))
     24(define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
    2025
    21 (define (egg-name args #!optional (def EGG-NAME))
     26(define (remq obj ls)
     27  (let loop ((curr ls) (prev '()))
     28    (cond
     29      ((null? curr)
     30        ls )
     31      ((eq? obj (car curr))
     32        (if (null? prev)
     33          (cdr ls)
     34          (begin
     35            (set-cdr! prev (cdr curr))
     36            ls ) ) )
     37      (else
     38        (loop (cdr curr) curr) ) ) ) )
     39
     40(define (remqs os ls)
     41  (let loop ((ls ls) (os os))
     42    (cond
     43      ((null? os)
     44        ls )
     45      (else
     46        (loop (remq (car os) ls) (cdr os)) ) ) ) )
     47
     48(define (egg-name #!optional (args *args*) (def EGG-NAME))
    2249  (cond
    2350    ((<= 4 (length *args*)) (cadddr *args*) )
    … …  
    2653      (error 'run "cannot determine egg-name") ) ) )
    2754
    28 (define *current-directory* (cond-expand (unix "./") (else #f)))
    29 (define *egg* (egg-name *args*))
     55(define (as-csc-options ls)
     56  (apply string-append (intersperse (map symbol->string ls) " ")) )
    3057
    31 ;no -disable-interrupts or -no-lambda-info
    32 (define *csc-options* "-inline-global -local -inline \
    33   -specialize -optimize-leaf-routines -clustering -lfa2 \
    34   -no-trace -unsafe \
    35   -strict-types")
     58(define (csc-options)
     59  (as-csc-options (remqs *csc-remv-options* *csc-init-options*)) )
    3660
    37 (define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
    3861(define (test-filename name) (string-append name "-test"))
     62
    3963(define (test-files) (find-files "." #:test *test-files-rx* #:limit 1))
    4064
    … …  
    4367    name
    4468    (make-pathname *current-directory* (test-filename name) "scm") ) )
     69
     70;;
    4571
    4672(define (run-test-evaluated source)
    … …  
    5480  (system (pathname-replace-directory (pathname-strip-extension source) *current-directory*)) )
    5581
    56 ;;;
    57 
    58 (define (run-test #!optional (name *egg*) (csc-options *csc-options*))
     82(define (run-test #!optional (name (egg-name)) (csc-options (csc-options)))
    5983  (let (
    6084    (source (ensure-test-source-name name)) )
    … …  
    6589    (run-test-compiled source csc-options) ) )
    6690
    67 (define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))
     91(define (run-tests #!optional (tests (test-files)) (csc-options (csc-options)))
    6892  (for-each (cut run-test <> csc-options) tests) )
    6993
    70 ;;; Do Test
     94;; Do Test
    7195
    7296(run-tests)
Note: See TracChangeset for help on using the changeset viewer.