Changeset 38608 in project for release


Ignore:
Timestamp:
04/09/20 18:25:25 (3 months ago)
Author:
Kon Lovett
Message:

add make-exchanger (in only module w/ disable-interrupts), strict-types, style, use symbol-append

Location:
release/5/synch/trunk
Files:
2 added
12 edited

Legend:

Unmodified
Added
Removed
  • release/5/synch/trunk/critical-region.scm

    r36985 r38608  
    66;;- your kidding?
    77
    8 #|
    9 (cond-expand
    10   (expose-critical-region #;(or compiling csi)
    11     (test-group "Critical Region"
    12       (import critical-region)
    13       (test-assert "disabled" (critical-region (not (interrupts-enabled?))))
    14       (test-assert "enabled" (interrupts-enabled?))
    15       (test-assert (not (critical-region* (abort 'foo))))
    16       (test-assert "enabled" (interrupts-enabled?))
    17       (test 'expected (critical-region-apply (lambda (x) x) 'expected))
    18       (test-assert (not (critical-region-call* (lambda () (abort 'foo)))))
    19       ) )
    20   (else))
    21 |#
    22 
    23 #|
    24 === Remote Critical Region
    25 
    26 ==== Usage
    27 
    28 <enscript language=scheme>
    29 (import critical-region)
    30 </enscript>
    31 
    32 ==== critical-region-apply
    33 
    34 <procedure>(critical-region-apply PROC ARG0 ...) -> *</procedure>
    35 
    36 Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may exit via
    37 continuation.
    38 
    39 ==== critical-region-call
    40 
    41 <procedure>(critical-region-call PROC) -> *</procedure>
    42 
    43 Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may exit via continuation.
    44 
    45 ==== critical-region-apply*
    46 
    47 <procedure>(critical-region-apply PROC ARG0 ...) -> boolean *</procedure>
    48 
    49 Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may exit via
    50 continuation.
    51 
    52 The first value} indicates whether the 2nd value is, {{#t}}, the
    53 single-valued result, or, {{#f}}, the captured exception condition.
    54 
    55 ==== critical-region-call*
    56 
    57 <procedure>(critical-region-call* PROC) -> boolean *</procedure>
    58 
    59 Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may exit via continuation.
    60 
    61 The first value} indicates whether the 2nd value is, {{#t}}, the
    62 single-valued result, or, {{#f}}, the captured exception condition.
    63 
    64 ==== %critical-region-apply
    65 
    66 <procedure>(%critical-region-apply PROC ARG0 ...) -> *</procedure>
    67 
    68 Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may '''not'''
    69 exit via continuation or raise an exception.
    70 
    71 ==== %critical-region-call
    72 
    73 <procedure>(%critical-region-call PROC) -> *</procedure>
    74 
    75 Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may '''not''' exit via
    76 continuation or raise an exception.
    77 
    78 ==== %critical-region-apply*
    79 
    80 <procedure>(%critical-region-apply* PROC ARG0 ...) -> boolean *</procedure>
    81 
    82 Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may '''not'''
    83 exit via continuation.
    84 
    85 The first value} indicates whether the 2nd value is, {{#t}}, the
    86 single-valued result, or, {{#f}}, the captured exception condition.
    87 
    88 ==== %critical-region-call*
    89 
    90 <procedure>(%critical-region-call* PROC) -> boolean *</procedure>
    91 
    92 Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may '''not''' exit via
    93 continuation.
    94 
    95 The first value} indicates whether the 2nd value is, {{#t}}, the
    96 single-valued result, or, {{#f}}, the captured exception condition.
    97 
    98 === Local Critical Region
    99 
    100 ==== critical-region
    101 
    102 <syntax>(critical-region EXPR ...) -> *</syntax>
    103 
    104 Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may exit via continuation.
    105 
    106 ==== %critical-region
    107 
    108 <syntax>(%critical-region EXPR ...) -> *</syntax>
    109 
    110 Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may '''not''' exit via
    111 continuation.
    112 
    113 ==== critical-region*
    114 
    115 <syntax>(critical-region* EXPR ...) -> *</syntax>
    116 
    117 Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may exit via continuation.
    118 
    119 The first value} indicates whether the 2nd value is, {{#t}}, the
    120 single-valued result, or, {{#f}}, the captured exception condition.
    121 
    122 ==== %critical-region*
    123 
    124 <syntax>(%critical-region* EXPR ...) -> *</syntax>
    125 
    126 Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may '''not''' exit via
    127 continuation or raise an exception.
    128 
    129 The first value} indicates whether the 2nd value is, {{#t}}, the
    130 single-valued result, or, {{#f}}, the captured exception condition.
    131 |#
    132 
    1338(declare (disable-interrupts))
    1349
     
    13611
    13712(;export
     13  make-exchanger
    13814  ;
    13915  interrupts-enabled?
     
    14117  critical-region-call critical-region-apply
    14218  %critical-region-call %critical-region-apply
    143   ;
    14419  critical-region-call* critical-region-apply*
    14520  %critical-region-call* %critical-region-apply*
    146   ;
    14721  (critical-region $disable-interrupts$ $enable-interrupts$)
    14822  (%critical-region $disable-interrupts$ $enable-interrupts$)
    149   ;
    15023  (critical-region* $disable-interrupts$ $enable-interrupts$)
    15124  (%critical-region* $disable-interrupts$ $enable-interrupts$))
    15225
    153 (import scheme (chicken syntax) (chicken condition) (chicken foreign))
     26(import scheme)
     27(import (chicken syntax))
     28(import (chicken condition))
     29(import (chicken foreign))
    15430
    15531;;;
     32
     33;; SRFI-96 Mutual Exclusion
     34
     35(define (make-exchanger v)
     36  (let ((+v+ v))
     37    (lambda (x)
     38      (let ((v +v+))
     39        (set! +v+ x)
     40        v ) ) ) )
     41
     42;;
    15643
    15744(define (interrupts-enabled?) (foreign-value "C_interrupts_enabled" bool))
     
    15946(define $disable-interrupts$ (foreign-lambda* void () "C_disable_interrupts();"))
    16047(define $enable-interrupts$ (foreign-lambda* void () "C_enable_interrupts();"))
    161 
    162 ;;;
    16348
    16449;body can invoke an exit continuation
     
    19479        (res
    19580          (critical-region
    196             (handle-exceptions
    197               exn (begin (set! flag #f) exn)
     81            (handle-exceptions exn
     82              (begin (set! flag #f) (values flag exn))
    19883              body ...))) )
    19984        (values flag res) ) ) ) )
     
    21196          (%critical-region
    21297            (handle-exceptions
    213               exn (begin (set! flag #f) exn)
     98              exn (begin (set! flag #f) (values flag exn))
    21499              body ...))) )
    215100        (values flag res) ) ) ) )
     
    242127
    243128) ;module critical-region
     129
     130#|
     131=== Remote Critical Region
     132
     133==== Usage
     134
     135<enscript language=scheme>
     136(import critical-region)
     137</enscript>
     138
     139==== critical-region-apply
     140
     141<procedure>(critical-region-apply PROC ARG0 ...) -> *</procedure>
     142
     143Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may exit via
     144continuation.
     145
     146==== critical-region-call
     147
     148<procedure>(critical-region-call PROC) -> *</procedure>
     149
     150Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may exit via continuation.
     151
     152==== critical-region-apply*
     153
     154<procedure>(critical-region-apply PROC ARG0 ...) -> boolean *</procedure>
     155
     156Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may exit via
     157continuation.
     158
     159The first value indicates whether the 2nd value is, {{#t}}, the
     160single-valued result, or, {{#f}}, the captured exception condition.
     161
     162==== critical-region-call*
     163
     164<procedure>(critical-region-call* PROC) -> boolean *</procedure>
     165
     166Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may exit via continuation.
     167
     168==== %critical-region-apply
     169
     170<procedure>(%critical-region-apply PROC ARG0 ...) -> *</procedure>
     171
     172Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may '''not'''
     173exit via continuation or raise an exception.
     174
     175==== %critical-region-call
     176
     177<procedure>(%critical-region-call PROC) -> *</procedure>
     178
     179Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may '''not''' exit via
     180continuation or raise an exception.
     181
     182==== %critical-region-apply*
     183
     184<procedure>(%critical-region-apply* PROC ARG0 ...) -> boolean *</procedure>
     185
     186Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may '''not'''
     187exit via continuation.
     188
     189The first value indicates whether the 2nd value is, {{#t}}, the
     190single-valued result, or, {{#f}}, the captured exception condition.
     191
     192==== %critical-region-call*
     193
     194<procedure>(%critical-region-call* PROC) -> boolean *</procedure>
     195
     196Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may '''not''' exit via
     197continuation.
     198
     199The first value indicates whether the 2nd value is, {{#t}}, the
     200single-valued result, or, {{#f}}, the captured exception condition.
     201
     202=== Local Critical Region
     203
     204==== critical-region
     205
     206<syntax>(critical-region EXPR ...) -> *</syntax>
     207
     208Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may exit via continuation.
     209
     210==== %critical-region
     211
     212<syntax>(%critical-region EXPR ...) -> *</syntax>
     213
     214Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may '''not''' exit via
     215continuation.
     216
     217==== critical-region*
     218
     219<syntax>(critical-region* EXPR ...) -> *</syntax>
     220
     221Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may exit via continuation.
     222
     223The first value indicates whether the 2nd value is, {{#t}}, the
     224single-valued result, or, {{#f}}, the captured exception condition.
     225
     226==== %critical-region*
     227
     228<syntax>(%critical-region* EXPR ...) -> *</syntax>
     229
     230Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may '''not''' exit via
     231continuation or raise an exception.
     232
     233The first value indicates whether the 2nd value is, {{#t}}, the
     234single-valued result, or, {{#f}}, the captured exception condition.
     235|#
  • release/5/synch/trunk/format-synch.scm

    r37019 r38608  
    77  format)
    88
    9 (import scheme
    10   (rename format (format egg-format))
    11   (only synch-dynexn synchronized-procedure))
     9(import scheme)
     10(import (rename format (format CL:format)))
     11(import (only synch-dynexn synchronized-procedure))
    1212
    13 (define format (synchronized-procedure egg-format))
     13(define format (synchronized-procedure CL:format))
    1414
    1515) ;format-synch
  • release/5/synch/trunk/synch-dyn.scm

    r37026 r38608  
    4242  synchronized-procedure)
    4343
    44 (import scheme
    45   (chicken base)
    46   (chicken syntax)
    47   (only (srfi 18)
    48     thread?
    49     make-mutex mutex?
    50     mutex-specific mutex-specific-set!
    51     mutex-lock! mutex-unlock!
    52     mutex-state)
    53   synch-object
    54   synch-params)
     44(import scheme)
     45(import (chicken base))
     46(import (chicken syntax))
     47(import (only (srfi 18)
     48  thread?
     49  make-mutex mutex?
     50  mutex-specific mutex-specific-set!
     51  mutex-lock! mutex-unlock!
     52  mutex-state))
     53(import synch-object)
     54(import synch-params)
     55
     56;;; Protected
    5557
    5658;;
     
    138140      (synch-unlock (?mtx ()) ?body ...) ) ) )
    139141
    140 ;;;
     142;;
    141143
    142144(include "synch-incl")
  • release/5/synch/trunk/synch-dynexn.scm

    r37019 r38608  
    4343
    4444
    45 (import scheme
    46   (chicken base)
    47   (chicken syntax)
    48   (chicken condition)
    49   (only (srfi 18)
    50     thread?
    51     make-mutex mutex?
    52     mutex-specific mutex-specific-set!
    53     mutex-lock! mutex-unlock!
    54     mutex-state)
    55   synch-object
    56   synch-params)
     45(import scheme)
     46(import (chicken base))
     47(import (chicken syntax))
     48(import (chicken condition))
     49(import (only (srfi 18)
     50  thread?
     51  make-mutex mutex?
     52  mutex-specific mutex-specific-set!
     53  mutex-lock! mutex-unlock!
     54  mutex-state))
     55(import synch-object)
     56(import synch-params)
    5757
    5858;;; Protected
    59 
    60 ;;
    61 
    62 (define-for-syntax (suffix-symbol sym suf)
    63   (string->symbol (string-append (symbol->string sym) "-" suf)) )
    6459
    6560;;
     
    163158      (synch-unlock (?mtx ()) ?body ...) ) ) )
    164159
    165 ;;;
     160;;
    166161
    167162(include "synch-incl")
  • release/5/synch/trunk/synch-exn.scm

    r36990 r38608  
    3838  synchronized-procedure)
    3939
    40 (import scheme
    41   (chicken base)
    42   (chicken syntax)
    43   (chicken condition)
    44   (only (srfi 18)
    45     thread?
    46     make-mutex mutex?
    47     mutex-specific mutex-specific-set!
    48     mutex-lock! mutex-unlock!
    49     mutex-state)
    50   synch-object
    51   synch-params)
     40(import scheme)
     41(import (chicken base))
     42(import (chicken syntax))
     43(import (chicken condition))
     44(import (only (srfi 18)
     45  thread?
     46  make-mutex mutex?
     47  mutex-specific mutex-specific-set!
     48  mutex-lock! mutex-unlock!
     49  mutex-state))
     50(import synch-object)
     51(import synch-params)
     52
     53;;; Protected
    5254
    5355;;
     
    136138      (synch-unlock (?mtx ()) ?body ...) ) ) )
    137139
    138 ;;;
     140;;
    139141
    140142(include "synch-incl")
  • release/5/synch/trunk/synch-incl.scm

    r37029 r38608  
    77
    88(define-for-syntax (suffix-symbol sym suf)
    9   (string->symbol (string-append (symbol->string sym) "-" suf)) )
     9  (import-for-syntax (only (chicken base) symbol-append))
     10  (symbol-append sym '- suf) )
    1011
    1112;;
     
    159160;;
    160161
    161 (define-for-syntax (record-mutex-name sym) (suffix-symbol sym "mutex"))
     162(define-for-syntax (record-mutex-name sym) (suffix-symbol sym 'mutex))
    162163
    163164;;
     
    220221;FIXME this API sucks
    221222
    222 (define-for-syntax (synch-wrapper-name sym) (suffix-symbol sym "synch"))
     223(define-for-syntax (synch-wrapper-name sym) (suffix-symbol sym 'synch))
    223224
    224225(define-syntax define-constructor-synch
  • release/5/synch/trunk/synch-object.scm

    r36984 r38608  
    1010  synch-with-object? check-synch-with-object error-synch-with-object)
    1111
    12 (import scheme
    13   (chicken base)
    14   (only (srfi 18)
    15     make-mutex mutex?
    16     mutex-specific mutex-specific-set!)
    17   (only type-checks define-check+error-type))
     12(import scheme)
     13(import (chicken base))
     14(import (only (srfi 18)
     15  make-mutex mutex?
     16  mutex-specific mutex-specific-set!))
     17(import (only type-checks define-check+error-type))
     18
     19;;;
    1820
    1921;;
  • release/5/synch/trunk/synch-open.scm

    r38099 r38608  
    2929  define-operation-%synch)
    3030
    31 (import scheme
    32   (chicken base)
    33   (chicken syntax)
    34   (only (srfi 18)
    35     thread?
    36     make-mutex mutex?
    37     mutex-specific mutex-specific-set!
    38     mutex-lock! mutex-unlock!
    39     mutex-state))
     31(import scheme)
     32(import (chicken base))
     33(import (chicken syntax))
     34(import (only (srfi 18)
     35  thread?
     36  make-mutex mutex?
     37  mutex-specific mutex-specific-set!
     38  mutex-lock! mutex-unlock!
     39  mutex-state))
    4040
    4141;;; Unprotected
     
    4444
    4545(define-for-syntax (suffix-symbol sym suf)
    46   (string->symbol (string-append (symbol->string sym) "-" suf)) )
     46  (import-for-syntax (only (chicken base) symbol-append))
     47  (symbol-append sym '- suf) )
    4748
    4849(define-syntax %synch
     
    235236;;
    236237
    237 (define-for-syntax (record-mutex-name sym) (suffix-symbol sym "mutex"))
     238(define-for-syntax (record-mutex-name sym) (suffix-symbol sym 'mutex))
    238239
    239240;;
     
    288289;;
    289290
    290 (define-for-syntax (%synch-wrapper-name sym) (suffix-symbol sym "%synch"))
     291(define-for-syntax (%synch-wrapper-name sym) (suffix-symbol sym '%synch))
    291292
    292293;operand must be the 1st argument
  • release/5/synch/trunk/synch-params.scm

    r36990 r38608  
    1616
    1717
    18 (import scheme
    19   (chicken base)
    20   (chicken condition))
     18(import scheme)
     19(import (chicken base))
     20(import (chicken condition))
    2121
    2222;;; Parameters
     
    2727
    2828(define (warn-synch-raise x)
    29   (if (procedure? x)
    30     x
     29  (if (procedure? x) x
    3130    (begin
    3231      (warning 'current-synch-raise "bad argument type - not a procedure" x)
     
    3433
    3534(define (warn-synch-abandon? x)
    36   (if (boolean? x)
    37     x
     35  (if (boolean? x) x
    3836    (begin
    3937      (warning 'current-synch-abandon? "bad argument type - not a boolean" x)
    4038      (current-synch-abandon?) ) ) )
    4139
    42 (define current-synch-raise (make-parameter synch-raise-warning warn-synch-raise))
    43 (define current-synch-abandon? (make-parameter #f warn-synch-abandon?))
    44 (define current-synch-exit-condition (make-parameter 'synch-exit))
     40(define current-synch-raise           (make-parameter synch-raise-warning warn-synch-raise))
     41(define current-synch-abandon?        (make-parameter #f warn-synch-abandon?))
     42(define current-synch-exit-condition  (make-parameter 'synch-exit))
    4543
    4644) ;module synch-params
  • release/5/synch/trunk/synch.egg

    r38099 r38608  
    44
    55((synopsis "Synchronization Forms")
    6  (version "3.2.2")
     6 (version "3.3.0")
    77 (category hell)
    88 (author "[[kon lovett]]")
     
    1313 (test-dependencies test srfi-18)
    1414 (components
     15  (extension critical-region
     16    (types-file)
     17    (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") )
    1518  (extension synch-object
    16     #;(inline-file)
    1719    (types-file)
    18     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks-for-toplevel-bindings") )
     20    (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") )
    1921  (extension synch-params
    20     #;(inline-file)
    2122    (types-file)
    22     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks-for-toplevel-bindings") )
     23    (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") )
    2324  (extension synch-open
    24     #;(inline-file)
    2525    (types-file)
    26     (csc-options "-O3" "-d1" "-local" "-no-argc-checks" "-no-bound-checks" "-no-procedure-checks") )
     26    (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-argc-checks" "-no-bound-checks" "-no-procedure-checks") )
    2727  (extension synch-dynexn
    28     #;(inline-file)
    2928    (types-file)
    3029    (component-dependencies synch-object synch-params)
    31     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks-for-toplevel-bindings") )
     30    (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") )
    3231  (extension synch-exn
    33     #;(inline-file)
    3432    (types-file)
    3533    (component-dependencies synch-object synch-params)
    36     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks-for-toplevel-bindings") )
     34    (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") )
    3735  (extension synch-dyn
    38     #;(inline-file)
    3936    (types-file)
    4037    (component-dependencies synch-object synch-params)
    41     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks-for-toplevel-bindings") )
     38    (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") )
    4239  (extension synch
    43     #;(inline-file)
    4440    (types-file)
    4541    (component-dependencies synch-open synch-dyn synch-params)
    46     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks-for-toplevel-bindings") ) ) )
     42    (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") ) ) )
  • release/5/synch/trunk/synch.scm

    r37021 r38608  
    77(module synch ()
    88
    9 (import scheme (chicken module))
     9(import scheme)
     10(import (chicken module))
    1011
    1112(import synch-open)
  • release/5/synch/trunk/tests/run.scm

    r38448 r38608  
    99;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    1010
    11 (import (only (chicken pathname) make-pathname))
     11(import (only (chicken pathname)
     12  make-pathname pathname-file pathname-replace-directory pathname-strip-extension))
    1213(import (only (chicken process) system))
    1314(import (only (chicken process-context) argv))
    1415(import (only (chicken format) format))
     16(import (only (chicken file) file-exists? find-files))
     17(import (only (chicken irregex) irregex irregex-match?))
    1518
    16 (define (test-filename test-name)
    17   (string-append test-name "-test") )
     19(define *args* (argv))
    1820
    1921(define (egg-name args #!optional (def EGG-NAME))
    2022  (cond
    21     ((<= 4 (length *args*))
    22       (cadddr *args*) )
    23     (def
    24       def )
     23    ((<= 4 (length *args*)) (cadddr *args*) )
     24    (def                    def )
    2525    (else
    26       (error 'test "cannot determine egg-name") ) ) )
    27 
    28 ;;
    29 
    30 (define *args* (argv))
    31 (define *egg* (egg-name *args*))
    32 (define *tests* `(,*egg*))
     26      (error 'run "cannot determine egg-name") ) ) )
    3327
    3428(define *current-directory* (cond-expand (unix "./") (else #f)))
     29(define *egg* (egg-name *args*))
    3530
    3631;no -disable-interrupts or -no-lambda-info
    3732(define *csc-options* "-inline-global -local -inline \
    3833  -specialize -optimize-leaf-routines -clustering -lfa2 \
    39   -no-trace -unsafe")
     34  -no-trace -unsafe \
     35  -strict-types")
    4036
    41 (define (run-test-evaluated test-name test-source)
    42   (format #t "*** ~A - csi ***~%" test-name)
    43   (system (string-append "csi -s " test-source)) )
     37(define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
     38(define (test-filename name) (string-append name "-test"))
     39(define (test-files) (find-files "." #:test *test-files-rx* #:limit 1))
    4440
    45 (define (run-test-compiled test-name test-source csc-options)
    46   (format #t "*** ~A - csc ~A ***~%" test-name csc-options)
     41(define (ensure-test-source-name name)
     42  (if (irregex-match? *test-files-rx* name)
     43    name
     44    (make-pathname *current-directory* (test-filename name) "scm") ) )
     45
     46(define (run-test-evaluated source)
     47  (format #t "*** ~A - csi ***~%" (pathname-file source))
     48  (system (string-append "csi -s " source)) )
     49
     50(define (run-test-compiled source csc-options)
     51  (format #t "*** ~A - csc ~A ***~%" (pathname-file source) csc-options)
    4752  ;csc output is in current directory
    48   (system (string-append "csc" " " csc-options " " test-source))
    49   (system (make-pathname *current-directory* (test-filename test-name))) )
     53  (system (string-append "csc" " " csc-options " " source))
     54  (system (pathname-replace-directory (pathname-strip-extension source) *current-directory*)) )
    5055
    5156;;;
    5257
    53 (define (run-test #!optional (test-name *egg*) (csc-options *csc-options*))
    54   (let ((test-source (make-pathname #f (test-filename test-name) "scm")))
    55     (run-test-evaluated test-name test-source)
     58(define (run-test #!optional (name *egg*) (csc-options *csc-options*))
     59  (let (
     60    (source (ensure-test-source-name name)) )
     61    (unless (file-exists? source)
     62      (error 'run "no such file" source) )
     63    (run-test-evaluated source)
    5664    (newline)
    57     (run-test-compiled test-name test-source csc-options) ) )
     65    (run-test-compiled source csc-options) ) )
    5866
    59 (define (run-tests #!optional (test-names *tests*) (csc-options *csc-options*))
    60   (for-each (cut run-test <> csc-options) test-names) )
     67(define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))
     68  (for-each (cut run-test <> csc-options) tests) )
    6169
    6270;;; Do Test
    6371
    64 (run-tests '("synch-continuation" "synch-dyn" "synch-dynexn" "synch-exn"))
     72(run-tests)
Note: See TracChangeset for help on using the changeset viewer.