1: ;;
    2: ;; test for system related procedures
    3: ;;
    4: 
    5: (use gauche.test)
    6: (use srfi-1)
    7: (use srfi-11)                           ;let-values
    8: (use srfi-13)
    9: 
   10: (test-start "system")
   11: 
   12: ;;-------------------------------------------------------------------
   13: (test-section "system")
   14: ;; test this first, so that we can use system commands to verify our results.
   15: 
   16: (test* "system" #t (begin (sys-system ":") #t))
   17: (test* "system" #t (begin (sys-system "") #t))
   18: 
   19: ;; shorthand of normalizing pathname.  this doesn't do anything on
   20: ;; unix, but on Windows the separator in PATHNAME is replaced.
   21: (define (n pathname) (sys-normalize-pathname pathname))
   22: 
   23: ;; some common operations via command
   24: (define (cmd-rmrf dir)
   25:   (cond-expand
   26:    (gauche.os.windows
   27:     (sys-system #`"rmdir /q /s ,(n dir) > NUL 2>&1")
   28:     (sys-system #`"del /q ,(n dir) > NUL 2>&1"))
   29:    (else
   30:     (sys-system #`"rm -rf ,dir > /dev/null"))))
   31: 
   32: (define (cmd-mkdir dir)
   33:   (cond-expand
   34:    (gauche.os.windows (sys-system #`"mkdir ,(n dir)"))
   35:    (else (sys-system #`"mkdir ,dir"))))
   36: 
   37: (define (cmd-touch path)
   38:   (cond-expand
   39:    (gauche.os.windows (sys-system #`"echo \"\" > ,(n path)"))
   40:    (else (sys-system #`"touch ,path"))))
   41: 
   42: (define (get-command-output command)
   43:   (cmd-rmrf "test.out")
   44:   (sys-system (format #f "~a > test.out" command))
   45:   (call-with-input-file "test.out"
   46:     (lambda (in)
   47:       (let loop ((line (read-line in)) (lines '()))
   48:         (if (eof-object? line)
   49:             (begin (close-input-port in)
   50:                    (cmd-rmrf "test.out")
   51:                    (string-join (reverse lines) " "))
   52:             (loop (read-line in) (cons line lines)))))))
   53: 
   54: (define (get-lsmode file)
   55:   (string-take (get-command-output (format #f "ls -ld ~a" file)) 10))
   56: 
   57: (define (get-pwd-via-pwd)
   58:   ;; use pwd command to get pwd.  avoid using shell's built-in pwd,
   59:   ;; for it may be confused by symlinks.
   60:   (cond-expand
   61:    (gauche.os.windows (get-command-output "cd"))
   62:    (else
   63:     (cond
   64:      ((sys-access "/bin/pwd" |X_OK|) (get-command-output "/bin/pwd"))
   65:      ((sys-access "/usr/bin/pwd" |X_OK|) (get-command-output "/usr/bin/pwd"))
   66:      ((sys-access "/sbin/pwd" |X_OK|) (get-command-output "/sbin/pwd"))
   67:      (else (get-command-output "pwd"))))))
   68: 
   69: 
   70: ;;-------------------------------------------------------------------
   71: (test-section "environment")
   72: 
   73: (test* "getenv"
   74:        (string-trim-both
   75:         (get-command-output (cond-expand
   76:                              (gauche.os.windows "echo %PATH%")
   77:                              (else "echo $PATH"))))
   78:        (sys-getenv "PATH"))
   79: 
   80: (test* "getcwd" (get-pwd-via-pwd)
   81:        (sys-getcwd))
   82: 
   83: ;;-------------------------------------------------------------------
   84: (test-section "pathnames")
   85: 
   86: (test* "basename" "ghi.jkl" (sys-basename "/abc/def/ghi.jkl"))
   87: (test* "dirname"  "/abc/def" (sys-dirname "/abc/def/ghi.jkl"))
   88: (test* "basename" "ghi.jkl" (sys-basename "/abc/def/ghi.jkl/"))
   89: (test* "dirname"  "/abc/def" (sys-dirname "/abc/def/ghi.jkl/"))
   90: (test* "basename" "ghi.jkl" (sys-basename "/abc//def//ghi.jkl//"))
   91: (test* "dirname"  "/abc//def" (sys-dirname "/abc//def//ghi.jkl//"))
   92: (test* "basename" "ghi.jkl" (sys-basename "ghi.jkl"))
   93: (test* "dirname" "." (sys-dirname "ghi.jkl"))
   94: 
   95: (test* "basename" "" (sys-basename ""))
   96: (test* "dirname"  "." (sys-dirname ""))
   97: (test* "basename" "" (sys-basename "/"))
   98: (test* "dirname"  (n "/") (sys-dirname "/"))
   99: (test* "basename" "" (sys-basename "//"))
  100: (test* "dirname"  (n "/") (sys-dirname "//"))
  101: (test* "basename" "abc"   (sys-basename "/abc"))
  102: (test* "dirname"  (n "/") (sys-dirname  "/abc"))
  103: (test* "basename" "abc"   (sys-basename "//abc"))
  104: (test* "dirname"  (n "/") (sys-dirname  "//abc"))
  105: 
  106: (test* "basename" ".." (sys-basename "../"))
  107: (test* "dirname"  "." (sys-dirname "../"))
  108: (test* "basename" ".." (sys-basename "../.."))
  109: (test* "dirname"  ".." (sys-dirname "../.."))
  110: 
  111: (cond-expand
  112:  (gauche.os.windows
  113:   ;; test with a drive letter
  114:   (test* "dirname"  "d:\\" (sys-dirname  "d:"))
  115:   (test* "basename" ""     (sys-basename "d:"))
  116:   (test* "dirname"  "d:\\" (sys-dirname  "d:/"))
  117:   (test* "basename" ""     (sys-basename "d:/"))
  118:   (test* "dirname"  "d:\\" (sys-dirname  "d:/z"))
  119:   (test* "basename" "z"    (sys-basename "d:/z"))
  120:   (test* "dirname"  "d:/z" (sys-dirname  "d:/z/y"))
  121:   (test* "basename" "y"    (sys-basename "d:/z/y"))
  122:   (test* "dirname"  "d:."  (sys-dirname  "d:z"))
  123:   (test* "basename" "z"    (sys-basename "d:z"))
  124:   (test* "dirname"  "d:z"  (sys-dirname  "d:z/y"))
  125:   (test* "basename" "y"    (sys-basename "d:z/y"))
  126:   )
  127:  (else #f))
  128: 
  129: (test* "normalize" (n (string-append (get-pwd-via-pwd) "/."))
  130:        (sys-normalize-pathname "." :absolute #t))
  131: (test* "normalize" (n (string-append (get-pwd-via-pwd) "/"))
  132:        (sys-normalize-pathname "" :absolute #t))
  133: (cond-expand
  134:  (gauche.os.windows #t)
  135:  (else
  136:   (test* "normalize"
  137:          (n (string-append (get-command-output "echo $HOME") "/abc"))
  138:          (sys-normalize-pathname "~/abc" :expand #t))))
  139: 
  140: (test* "normalize" (n "/a/b/c/d/e")
  141:        (sys-normalize-pathname "/a/b//.///c//d/./e"
  142:                                :canonicalize #t))
  143: (test* "normalize" (n "/a/b/c/d/e/")
  144:        (sys-normalize-pathname "/a/b//.///c//d/./e/"
  145:                                :canonicalize #t))
  146: (test* "normalize" (n "/a/b/c/d/e/")
  147:        (sys-normalize-pathname "/a/B//./../c/d/../../b//c/d/e/f/.."
  148:                                :canonicalize #t))
  149: (test* "normalize" (n "/a/b/")
  150:        (sys-normalize-pathname "/a/b/c/d/../.."
  151:                                :canonicalize #t))
  152: (test* "normalize" (n "/c/d/")
  153:        (sys-normalize-pathname "/c/d/e/f/../../"
  154:                                :canonicalize #t))
  155: (test* "normalize" (n "/e/f/")
  156:        (sys-normalize-pathname "/e/f/g/h/../../."
  157:                                :canonicalize #t))
  158: 
  159: (test* "normalize" ""
  160:        (sys-normalize-pathname ""
  161:                                :canonicalize #t))
  162: (test* "normalize" (n "../..")
  163:        (sys-normalize-pathname "a/b/c/../../../../.."
  164:                                :canonicalize #t))
  165: (test* "normalize" (n "../../x/y")
  166:        (sys-normalize-pathname "a/b/c/../../../../../x/y"
  167:                                :canonicalize #t))
  168: 
  169: ;;-------------------------------------------------------------------
  170: (test-section "filesystem")
  171: 
  172: (cmd-rmrf "test.dir")
  173: 
  174: (test* "access" '(#f #f #f #f)
  175:        (map (lambda (flag) (sys-access "test.dir" flag))
  176:             (list |F_OK| |R_OK| |W_OK| |X_OK|)))
  177: 
  178: (cmd-touch "test.dir")
  179: 
  180: (test* "unlink" #f
  181:        (begin
  182:          (sys-unlink "test.dir") (sys-access "test.dir" |F_OK|)))
  183: 
  184: (cond-expand
  185:  (gauche.os.windows
  186:   ;; we need entirey different scheme here, but for the time being we
  187:   ;; just omit the test.
  188:   (sys-mkdir "test.dir" #o750)
  189:   )
  190:  (else
  191:   (test* "mkdir" #/drw[sx]r-[sx]---/
  192:          (begin
  193:            (sys-mkdir "test.dir" #o750)
  194:            (get-lsmode "test.dir"))
  195:          rxmatch)
  196: 
  197:   (test* "chmod" #/drw[sx]r-[sx]r-x/
  198:          (begin
  199:            (sys-chmod "test.dir" #o755)
  200:            (get-lsmode "test.dir"))
  201:          rxmatch)
  202: 
  203:   (test* "fchmod" #/drw[sx]r-[sx]---/
  204:          (begin
  205:            (call-with-input-file "test.dir"
  206:              (cut sys-fchmod <> #o750))
  207:            (get-lsmode "test.dir"))
  208:          rxmatch)
  209:   ))
  210: 
  211: (define *fs-test-str* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")
  212: 
  213: (with-output-to-file "test.dir/xyzzy"
  214:   (lambda () (display *fs-test-str*)))
  215: 
  216: (test* "rename" '(#f #t)
  217:        (begin
  218:          (sys-rename "test.dir/xyzzy" "test.dir/zzZzz")
  219:          (list (sys-access "test.dir/xyzzy" |F_OK|)
  220:                (sys-access "test.dir/zzZzz" |F_OK|))))
  221: 
  222: (test* "readdir" '("." ".." "zzZzz")
  223:        (sort (sys-readdir "test.dir")))
  224: 
  225: (test* "link" '("." ".." "xyzzy" "zzZzz")
  226:        (begin
  227:          (sys-link "test.dir/zzZzz" "test.dir/xyzzy")
  228:          (sort (sys-readdir "test.dir"))))
  229: 
  230: (test* "unlink" '("." ".." "xyzzy")
  231:        (begin
  232:          (sys-unlink "test.dir/zzZzz")
  233:          (sort (sys-readdir "test.dir"))))
  234: 
  235: (test* "rename" '("." ".." "zzZzz")
  236:        (begin
  237:          (sys-rename "test.dir/xyzzy" "test.dir/zzZzz")
  238:          (sort (sys-readdir "test.dir"))))
  239: 
  240: (test* "truncate" "abcdefghijklmno"
  241:        (begin
  242:          (sys-truncate "test.dir/zzZzz" 15)
  243:          (call-with-input-file "test.dir/zzZzz" read-line)))
  244: 
  245: (test* "ftruncate" "abcde"
  246:        (begin
  247:          (call-with-output-file "test.dir/zzZzz"
  248:            (cut sys-ftruncate <> 5)
  249:            :if-exists :append)
  250:          (call-with-input-file "test.dir/zzZzz" read-line)))
  251: 
  252: (test* "rmdir" #f
  253:        (begin
  254:          (sys-unlink "test.dir/zzZzz")
  255:          (sys-rmdir "test.dir")
  256:          (sys-access "test.dir" |F_OK|)))
  257: 
  258: 
  259: 
  260: ;;-------------------------------------------------------------------
  261: (test-section "stat")
  262: 
  263: (let ()
  264:   (define (mask unix win)
  265:     (cond-expand
  266:      (gauche.os.windows win)
  267:      (else unix)))
  268: 
  269:   (cmd-rmrf "test.dir")
  270:   (with-output-to-file "test.dir" (lambda () (display "01234")))
  271:   (sys-chmod "test.dir" #o654)
  272: 
  273: 
  274:   (test* "stat" `(,(mask #o654 #o666) regular 5)
  275:          (let ((s (sys-stat "test.dir")))
  276:            (list (logand #o777 (sys-stat->mode s))
  277:                  (sys-stat->file-type s)
  278:                  (sys-stat->size s))))
  279: 
  280:   (test* "fstat" `(,(mask #o654 #o666) regular 5)
  281:          (call-with-input-file "test.dir"
  282:            (lambda (p)
  283:              (let ((s (sys-fstat p)))
  284:                (list (logand #o777 (sys-stat->mode s))
  285:                      (sys-stat->file-type s)
  286:                      (sys-stat->size s))))))
  287: 
  288:   (sys-unlink "test.dir")
  289:   (sys-mkdir "test.dir" #o700)
  290: 
  291:   (test* "stat" `(,(mask #o700 #o777) directory)
  292:          (let ((s (sys-stat "test.dir")))
  293:            (list (logand #o777 (sys-stat->mode s))
  294:                  (sys-stat->file-type s))))
  295: 
  296:   ;; on windows you cannot use open-input-file on a directory.
  297:   (cond-expand
  298:    (gauche.os.windows)
  299:    (else
  300:     (test* "fstat" `(,(mask #o700 #o777) directory)
  301:            (call-with-input-file "test.dir"
  302:              (lambda (p)
  303:                (let ((s (sys-fstat p)))
  304:                  (list (logand #o777 (sys-stat->mode s))
  305:                        (sys-stat->file-type s))))))))
  306:   )
  307: 
  308: (sys-rmdir "test.dir")
  309: 
  310: ;;-------------------------------------------------------------------
  311: (test-section "pipe")
  312: 
  313: (test* "pipe" "abc"
  314:        (receive (in out) (sys-pipe)
  315:          (display "abc\n" out) (flush out)
  316:          (let1 r (read-line in)
  317:            (close-input-port in)
  318:            (close-output-port out)
  319:            r)))
  320: 
  321: (test* "pipe and char-ready? (none)" '(#f #t #f)
  322:        (receive (in out) (sys-pipe :buffering :none)
  323:          (display "a" out) (read-char in)
  324:          (let1 f1 (char-ready? in)
  325:            (display "bc" out) (read-char in)
  326:            (let1 f2 (char-ready? in)
  327:              (read-char in)
  328:              (let1 f3 (char-ready? in)
  329:                (close-input-port in) (close-output-port out)
  330:                (list f1 f2 f3))))))
  331: 
  332: (test* "pipe and char-ready? (line)" '(#f #t #t)
  333:        (receive (in out) (sys-pipe :buffering :line)
  334:          (display "a" out)
  335:          (let1 f1 (char-ready? in)
  336:            (display "\n" out)
  337:            (let1 f2 (char-ready? in)
  338:              (read-char in)
  339:              (let1 f3 (char-ready? in)
  340:                (close-input-port in) (close-output-port out)
  341:                (list f1 f2 f3))))))
  342: 
  343: (test* "pipe and char-ready? (full)" '(#f #f #t)
  344:        (receive (in out) (sys-pipe :buffering :full)
  345:          (display "a" out)
  346:          (let1 f1 (char-ready? in)
  347:            (display "\n" out)
  348:            (let1 f2 (char-ready? in)
  349:              (flush out) (read-char in)
  350:              (let1 f3 (char-ready? in)
  351:                (close-input-port in) (close-output-port out)
  352:                (list f1 f2 f3))))))
  353: 
  354: ;; Kludge: MinGW32 seems not to support :none, :line buffering,
  355: ;; so we flush and close the output pipe before reading from it.
  356: 
  357: (test* "pipe and read-block(none)" 2
  358:        (receive (in out) (sys-pipe :buffering :none)
  359:          (display "ab" out)
  360:          (cond-expand (gauche.os.windows (close-output-port out)) (else))
  361:          (let1 r (string-size (read-block 1000 in))
  362:            (close-input-port in)
  363:            (cond-expand ((not gauche.os.windows) (close-output-port out))
  364:                         (else))
  365:            r)))
  366: 
  367: (test* "pipe and read-block(line)" 2
  368:        (receive (in out) (sys-pipe :buffering :line)
  369:          (display "a\n" out)
  370:          (cond-expand (gauche.os.windows (close-output-port out)) (else))
  371:          (let1 r (string-size (read-block 1000 in))
  372:            (close-input-port in)
  373:            (cond-expand ((not gauche.os.windows) (close-output-port out))
  374:                         (else))
  375:            r)))
  376: 
  377: ;;-------------------------------------------------------------------
  378: (test-section "fork&exec")
  379: 
  380: (define (nap)
  381:   (cond-expand
  382:    (gauche.sys.nanosleep (sys-nanosleep 200000000))  ;0.2s
  383:    (else (sys-sleep 1))))
  384: 
  385: (cond-expand
  386:  ((not gauche.os.windows)  ;; win32 doesn't support fork at all.
  387:   (test* "fork & wait" #t
  388:          (let ((pid (sys-fork)))
  389:            (if (= pid 0)
  390:              (sys-exit 5)
  391:              (receive (rpid code) (sys-wait)
  392:                (and (= rpid pid)
  393:                     (sys-wait-exited? code)
  394:                     (= (sys-wait-exit-status code) 5))))))
  395: 
  396:   (test* "fork & waitpid" #t
  397:          (let ((pid (sys-fork)))
  398:            (if (= pid 0)
  399:              (sys-exit 10)
  400:              (receive (rpid code) (sys-waitpid pid)
  401:                (and (= rpid pid)
  402:                     (sys-wait-exited? code)
  403:                     (= (sys-wait-exit-status code) 10))))))
  404: 
  405:   (test* "fork, wait & kill" #t
  406:          (let ((pid (sys-fork)))
  407:            (if (= pid 0)
  408:              (begin (sys-pause) (sys-exit 0))
  409:              (begin 
  410:                (sys-kill pid |SIGKILL|)
  411:                (receive (rpid code) (sys-wait)
  412:                  (and (= rpid pid)
  413:                       (sys-wait-signaled? code)
  414:                       (= (sys-wait-termsig code) |SIGKILL|)))))))
  415: 
  416:   (test* "fork, wait, kill & sleep" #t
  417:          (let1 pid (sys-fork)
  418:            (if (= pid 0)
  419:              (begin (nap) (sys-exit 0))
  420:              (begin 
  421:                (sys-kill pid |SIGSTOP|) 
  422:                (receive (rpid code) (sys-waitpid pid :untraced #t)
  423:                  (and (= rpid pid)
  424:                       (sys-wait-stopped? code)
  425:                       (= (sys-wait-stopsig code) |SIGSTOP|)
  426:                       (begin (sys-kill pid |SIGCONT|)
  427:                              (receive (rpid code) (sys-wait)
  428:                                (and (= rpid pid)
  429:                                     (sys-wait-exited? code)
  430:                                     (= (sys-wait-exit-status code) 0)
  431:                                     )))
  432:                       )))
  433:              ))
  434:          )
  435: 
  436:   (test* "fork & pipe" 70000
  437:          (receive (in out) (sys-pipe)
  438:            (let1 pid (sys-fork)
  439:              (if (= pid 0)
  440:                (begin (close-input-port in)
  441:                       (display (make-string 69999) out)
  442:                       (with-error-handler
  443:                           (lambda (e) (sys-exit 0))
  444:                         (lambda ()
  445:                           (newline out)
  446:                           (close-output-port out)
  447:                           (sys-pause))))
  448:                (let loop ((toread 70000)
  449:                           (nread  0))
  450:                  (let1 r (string-size (read-block toread in))
  451:                    (if (>= (+ nread r) 70000)
  452:                      (begin (sys-kill pid SIGTERM)
  453:                             (sys-waitpid pid)
  454:                             (+ nread r))
  455:                      (loop (- toread r) (+ nread r)))))
  456:                ))))
  457: 
  458:   (test* "fork, exec and signal mask" #t
  459:          (let ((nmask (make <sys-sigset>))
  460:                (cmask (make <sys-sigset>)))
  461:            (sys-sigset-fill! nmask)
  462:            (let ((omask (sys-sigmask SIG_SETMASK nmask))
  463:                  (zero  (open-input-file "/dev/zero")))
  464:              (receive (in out) (sys-pipe :buffering :none)
  465:                (let1 pid
  466:                    (sys-fork-and-exec "cat" '("cat")
  467:                                       :iomap `((0 . ,zero) (1 . ,out))
  468:                                       :sigmask cmask)
  469:                  (read-byte in) ;; make sure 'cat' is started
  470:                  (sys-kill pid SIGINT)
  471:                  (sys-sigmask SIG_SETMASK omask)
  472:                  (sys-waitpid pid)
  473:                  #t)))))
  474:   ) ; !gauche.os.windows
  475:  (else))
  476: 
  477: ;;-------------------------------------------------------------------
  478: (test-section "select")
  479: 
  480: (cond-expand
  481:  (gauche.sys.select
  482:   (test* "fdset" '(3 #t #f #t #t #f)
  483:          (let ((fdset (make <sys-fdset>)))
  484:            (set! (sys-fdset-ref fdset (current-input-port)) #t)
  485:            (sys-fdset-set! fdset (current-error-port) #t)
  486:            (sys-fdset-set! fdset 3 #t)
  487:            (sys-fdset-set! fdset 4 #f)
  488:            (cons (sys-fdset-max-fd fdset)
  489:                  (map (lambda (i) (sys-fdset-ref fdset i)) (iota 5)))))
  490: 
  491:   (test* "fdset" '(-1 7 7 4 10 10 -1)
  492:          (let ((fdset (make <sys-fdset>))
  493:                (result '()))
  494:            (define (push-result)
  495:              (set! result (cons (sys-fdset-max-fd fdset) result)))
  496:            (push-result)
  497:            (sys-fdset-set! fdset 7 #t)
  498:            (push-result)
  499:            (sys-fdset-set! fdset 4 #t)
  500:            (push-result)
  501:            (sys-fdset-set! fdset 7 #f)
  502:            (push-result)
  503:            (sys-fdset-set! fdset 10 #t)
  504:            (push-result)
  505:            (sys-fdset-set! fdset 4 #f)
  506:            (push-result)
  507:            (sys-fdset-set! fdset 10 #f)
  508:            (push-result)
  509:            (reverse result)))
  510: 
  511:   (test* "sys-fdset" `(,(port-file-number (current-input-port)) 9 10)
  512:          (sys-fdset->list (sys-fdset 9 (current-input-port) 10)))
  513:   (test* "list->sys-fdset" '(1 3 5 7 9)
  514:          (sys-fdset->list (list->sys-fdset (list (sys-fdset 3 9)
  515:                                                  7
  516:                                                  (sys-fdset 1 3 5)))))
  517:   (test* "sys-fdset-copy!" '(2 4 5)
  518:          (let1 dst (make <sys-fdset>)
  519:            (sys-fdset-copy! dst (sys-fdset 5 4 2))
  520:            (sys-fdset->list dst)))
  521: 
  522:   (test* "sys-fdset-clear!" '()
  523:          (sys-fdset->list (sys-fdset-clear! (sys-fdset 1 2 3))))
  524: 
  525:   (test* "select" '(0 #f #f #f #f 1 #t #f #f #t #\x)
  526:          (let*-values (((in out) (sys-pipe))
  527:                        ((pid) (sys-fork)))
  528:            (if (= pid 0)
  529:              (begin (sys-select #f #f #f 100000)
  530:                     (display "x" out)
  531:                     (close-output-port out)
  532:                     (sys-exit 0))
  533:              (let ((rfds (make <sys-fdset>)))
  534:                (sys-fdset-set! rfds in #t)
  535:                (receive (an ar aw ae)
  536:                    (sys-select rfds #f #f 0)
  537:                  (receive (bn br bw be)
  538:                      (sys-select! rfds #f #f #f)
  539:                    (begin0
  540:                     (list an (eq? ar rfds) aw ae
  541:                           (sys-fdset-ref ar in)
  542:                           bn (eq? br rfds) bw be
  543:                           (sys-fdset-ref rfds in)
  544:                           (read-char in))
  545:                     (sys-waitpid pid)))))
  546:              ))
  547:          )
  548:   )
  549:  (else)) ; cond-expand gauche.sys.select
  550: 
  551: ;;-------------------------------------------------------------------
  552: (test-section "signal handling")
  553: 
  554: (cond-expand
  555:  ((not gauche.os.windows)
  556: 
  557:   (test* "sigalrm1" SIGALRM
  558:          (call/cc
  559:           (lambda (k)
  560:             (with-signal-handlers
  561:              ((SIGALRM => k)
  562:               (#t (k 0)))
  563:              (lambda ()
  564:                (sys-alarm 1)
  565:                (sys-pause))))))
  566: 
  567:   (test* "sigalrm2" 0
  568:          (call/cc
  569:           (lambda (k)
  570:             (with-signal-handlers
  571:              ((#t (k 0))
  572:               (SIGALRM => k))
  573:              (lambda ()
  574:                (sys-alarm 1)
  575:                (sys-pause))))))
  576: 
  577:   (test* "sigalrm3