Artifact 84d59a345748afcb46b6bf7a7ede7a864cf9f394:
- File posix.sls — part of check-in [e0957430e1] at 2016-12-12 16:01:40 on branch trunk — added better errno support (user: aldo size: 4758)
0000: 3b 3b 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 ;;.;; Copyright 0010: 32 30 31 36 20 41 6c 64 6f 20 4e 69 63 6f 6c 61 2016 Aldo Nicola 0020: 73 20 42 72 75 6e 6f 0a 3b 3b 0a 3b 3b 20 4c 69 s Bruno.;;.;; Li 0030: 63 65 6e 73 65 64 20 75 6e 64 65 72 20 74 68 65 censed under the 0040: 20 41 70 61 63 68 65 20 4c 69 63 65 6e 73 65 2c Apache License, 0050: 20 56 65 72 73 69 6f 6e 20 32 2e 30 20 28 74 68 Version 2.0 (th 0060: 65 20 22 4c 69 63 65 6e 73 65 22 29 3b 0a 3b 3b e "License");.;; 0070: 20 79 6f 75 20 6d 61 79 20 6e 6f 74 20 75 73 65 you may not use 0080: 20 74 68 69 73 20 66 69 6c 65 20 65 78 63 65 70 this file excep 0090: 74 20 69 6e 20 63 6f 6d 70 6c 69 61 6e 63 65 20 t in compliance 00a0: 77 69 74 68 20 74 68 65 20 4c 69 63 65 6e 73 65 with the License 00b0: 2e 0a 3b 3b 20 59 6f 75 20 6d 61 79 20 6f 62 74 ..;; You may obt 00c0: 61 69 6e 20 61 20 63 6f 70 79 20 6f 66 20 74 68 ain a copy of th 00d0: 65 20 4c 69 63 65 6e 73 65 20 61 74 0a 3b 3b 0a e License at.;;. 00e0: 3b 3b 20 20 20 20 20 68 74 74 70 3a 2f 2f 77 77 ;; http://ww 00f0: 77 2e 61 70 61 63 68 65 2e 6f 72 67 2f 6c 69 63 w.apache.org/lic 0100: 65 6e 73 65 73 2f 4c 49 43 45 4e 53 45 2d 32 2e enses/LICENSE-2. 0110: 30 0a 3b 3b 0a 3b 3b 20 55 6e 6c 65 73 73 20 72 0.;;.;; Unless r 0120: 65 71 75 69 72 65 64 20 62 79 20 61 70 70 6c 69 equired by appli 0130: 63 61 62 6c 65 20 6c 61 77 20 6f 72 20 61 67 72 cable law or agr 0140: 65 65 64 20 74 6f 20 69 6e 20 77 72 69 74 69 6e eed to in writin 0150: 67 2c 20 73 6f 66 74 77 61 72 65 0a 3b 3b 20 64 g, software.;; d 0160: 69 73 74 72 69 62 75 74 65 64 20 75 6e 64 65 72 istributed under 0170: 20 74 68 65 20 4c 69 63 65 6e 73 65 20 69 73 20 the License is 0180: 64 69 73 74 72 69 62 75 74 65 64 20 6f 6e 20 61 distributed on a 0190: 6e 20 22 41 53 20 49 53 22 20 42 41 53 49 53 2c n "AS IS" BASIS, 01a0: 0a 3b 3b 20 57 49 54 48 4f 55 54 20 57 41 52 52 .;; WITHOUT WARR 01b0: 41 4e 54 49 45 53 20 4f 52 20 43 4f 4e 44 49 54 ANTIES OR CONDIT 01c0: 49 4f 4e 53 20 4f 46 20 41 4e 59 20 4b 49 4e 44 IONS OF ANY KIND 01d0: 2c 20 65 69 74 68 65 72 20 65 78 70 72 65 73 73 , either express 01e0: 20 6f 72 20 69 6d 70 6c 69 65 64 2e 0a 3b 3b 20 or implied..;; 01f0: 53 65 65 20 74 68 65 20 4c 69 63 65 6e 73 65 20 See the License 0200: 66 6f 72 20 74 68 65 20 73 70 65 63 69 66 69 63 for the specific 0210: 20 6c 61 6e 67 75 61 67 65 20 67 6f 76 65 72 6e language govern 0220: 69 6e 67 20 70 65 72 6d 69 73 73 69 6f 6e 73 20 ing permissions 0230: 61 6e 64 0a 3b 3b 20 6c 69 6d 69 74 61 74 69 6f and.;; limitatio 0240: 6e 73 20 75 6e 64 65 72 20 74 68 65 20 4c 69 63 ns under the Lic 0250: 65 6e 73 65 2e 0a 0a 28 6c 69 62 72 61 72 79 20 ense...(library 0260: 28 70 6f 73 69 78 29 0a 20 20 28 65 78 70 6f 72 (posix). (expor 0270: 74 20 73 74 72 65 72 72 6f 72 20 65 72 72 6e 6f t strerror errno 0280: 0a 09 20 20 6d 6b 74 65 6d 70 20 6d 6b 73 74 65 .. mktemp mkste 0290: 6d 70 20 77 69 74 68 2d 6d 6b 74 65 6d 70 20 63 mp with-mktemp c 02a0: 6c 6f 73 65 0a 09 20 20 77 74 65 72 6d 73 69 67 lose.. wtermsig 02b0: 20 77 69 66 65 78 69 74 65 64 20 77 69 66 73 69 wifexited wifsi 02c0: 67 6e 61 6c 65 64 20 77 65 78 69 74 73 74 61 74 gnaled wexitstat 02d0: 75 73 0a 09 20 20 77 61 69 74 2d 66 6c 61 67 0a us.. wait-flag. 02e0: 09 20 20 77 61 69 74 2d 66 6f 72 2d 70 69 64 20 . wait-for-pid 02f0: 66 6f 72 6b 20 64 75 70 20 66 69 6c 65 2d 77 72 fork dup file-wr 0300: 69 74 65 20 66 69 6c 65 2d 72 65 61 64 20 62 79 ite file-read by 0310: 74 65 73 2d 72 65 61 64 79 29 0a 20 20 28 69 6d tes-ready). (im 0320: 70 6f 72 74 20 28 63 68 65 7a 73 63 68 65 6d 65 port (chezscheme 0330: 29 0a 09 20 20 28 6f 6e 6c 79 20 28 74 68 75 6e ).. (only (thun 0340: 64 65 72 2d 75 74 69 6c 73 29 20 62 79 74 65 76 der-utils) bytev 0350: 65 63 74 6f 72 2d 63 6f 70 79 2a 29 0a 09 20 20 ector-copy*).. 0360: 28 66 66 69 2d 75 74 69 6c 73 29 0a 09 20 20 28 (ffi-utils).. ( 0370: 6f 6e 6c 79 20 28 70 6f 73 69 78 20 65 72 72 6e only (posix errn 0380: 6f 29 20 73 74 72 65 72 72 6f 72 20 65 72 72 6e o) strerror errn 0390: 6f 20 45 41 47 41 49 4e 20 45 49 4e 54 52 29 29 o EAGAIN EINTR)) 03a0: 0a 20 20 0a 3b 3b 3b 20 50 4f 53 49 58 20 53 54 . .;;; POSIX ST 03b0: 55 46 46 0a 20 20 28 64 65 66 69 6e 65 20 69 6e UFF. (define in 03c0: 69 74 20 28 6c 6f 61 64 2d 73 68 61 72 65 64 2d it (load-shared- 03d0: 6f 62 6a 65 63 74 20 22 6c 69 62 63 2e 73 6f 2e object "libc.so. 03e0: 36 22 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 6")).. (define 03f0: 28 6d 6b 73 74 65 6d 70 20 74 65 6d 70 6c 61 74 (mkstemp templat 0400: 65 29 0a 20 20 20 20 28 64 65 66 69 6e 65 20 6d e). (define m 0410: 6b 73 74 65 6d 70 2a 20 28 66 6f 72 65 69 67 6e kstemp* (foreign 0420: 2d 70 72 6f 63 65 64 75 72 65 20 22 6d 6b 73 74 -procedure "mkst 0430: 65 6d 70 22 20 28 75 38 2a 29 20 69 6e 74 29 29 emp" (u8*) int)) 0440: 0a 20 20 20 20 28 64 65 66 69 6e 65 20 74 20 28 . (define t ( 0450: 73 74 72 69 6e 67 2d 3e 75 74 66 38 20 74 65 6d string->utf8 tem 0460: 70 6c 61 74 65 29 29 0a 20 20 20 20 0a 20 20 20 plate)). . 0470: 20 28 6c 65 74 20 28 5b 66 64 20 28 6d 6b 73 74 (let ([fd (mkst 0480: 65 6d 70 2a 20 74 29 5d 29 0a 20 20 20 20 20 20 emp* t)]). 0490: 28 77 68 65 6e 20 28 3c 20 66 64 20 30 29 0a 09 (when (< fd 0).. 04a0: 20 20 20 20 28 65 72 72 6f 72 66 20 27 6d 6b 73 (errorf 'mks 04b0: 74 65 6d 70 20 22 66 61 69 6c 65 64 3a 20 7e 61 temp "failed: ~a 04c0: 22 20 28 73 74 72 65 72 72 6f 72 29 29 29 0a 20 " (strerror))). 04d0: 20 20 20 20 20 28 76 61 6c 75 65 73 20 66 64 20 (values fd 04e0: 28 75 74 66 38 2d 3e 73 74 72 69 6e 67 20 74 29 (utf8->string t) 04f0: 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 ))).. (define ( 0500: 6d 6b 74 65 6d 70 20 74 65 6d 70 6c 61 74 65 29 mktemp template) 0510: 0a 20 20 20 20 28 64 65 66 69 6e 65 20 6d 6b 74 . (define mkt 0520: 65 6d 70 2a 20 28 66 6f 72 65 69 67 6e 2d 70 72 emp* (foreign-pr 0530: 6f 63 65 64 75 72 65 20 22 6d 6b 74 65 6d 70 22 ocedure "mktemp" 0540: 20 28 73 74 72 69 6e 67 29 20 73 74 72 69 6e 67 (string) string 0550: 29 29 20 20 20 20 0a 20 20 20 20 28 6c 65 74 20 )) . (let 0560: 28 5b 73 20 28 6d 6b 74 65 6d 70 2a 20 74 65 6d ([s (mktemp* tem 0570: 70 6c 61 74 65 29 5d 29 0a 20 20 20 20 20 20 28 plate)]). ( 0580: 77 68 65 6e 20 28 73 74 72 69 6e 67 3d 3f 20 73 when (string=? s 0590: 20 22 22 29 0a 09 20 20 20 20 28 65 72 72 6f 72 "").. (error 05a0: 66 20 27 6d 6b 74 65 6d 70 20 22 66 61 69 6c 65 f 'mktemp "faile 05b0: 64 3a 20 7e 61 22 20 28 73 74 72 65 72 72 6f 72 d: ~a" (strerror 05c0: 29 29 29 0a 20 20 20 20 20 20 73 29 29 0a 0a 20 ))). s)).. 05d0: 20 28 64 65 66 69 6e 65 20 28 77 69 74 68 2d 6d (define (with-m 05e0: 6b 74 65 6d 70 20 74 65 6d 70 6c 61 74 65 20 66 ktemp template f 05f0: 29 0a 09 20 20 28 64 65 66 69 6e 65 20 66 69 6c ).. (define fil 0600: 65 20 28 6d 6b 74 65 6d 70 20 74 65 6d 70 6c 61 e (mktemp templa 0610: 74 65 29 29 0a 09 20 20 28 64 79 6e 61 6d 69 63 te)).. (dynamic 0620: 2d 77 69 6e 64 0a 09 20 20 20 20 20 20 28 6c 61 -wind.. (la 0630: 6d 62 64 61 20 28 29 20 28 76 6f 69 64 29 29 0a mbda () (void)). 0640: 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda ( 0650: 29 20 28 66 20 66 69 6c 65 29 29 0a 09 20 20 20 ) (f file)).. 0660: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 20 28 64 (lambda () (d 0670: 65 6c 65 74 65 2d 66 69 6c 65 20 66 69 6c 65 29 elete-file file) 0680: 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 ))).. (define ( 0690: 63 6c 6f 73 65 20 66 64 29 0a 20 20 20 20 28 64 close fd). (d 06a0: 65 66 69 6e 65 20 63 6c 6f 73 65 2a 20 28 66 6f efine close* (fo 06b0: 72 65 69 67 6e 2d 70 72 6f 63 65 64 75 72 65 20 reign-procedure 06c0: 22 63 6c 6f 73 65 22 20 28 69 6e 74 29 20 69 6e "close" (int) in 06d0: 74 29 29 0a 20 20 20 20 28 69 66 20 28 3c 20 28 t)). (if (< ( 06e0: 63 6c 6f 73 65 2a 20 66 64 29 20 30 29 0a 09 28 close* fd) 0)..( 06f0: 65 72 72 6f 72 66 20 27 63 6c 6f 73 65 20 22 66 errorf 'close "f 0700: 61 69 6c 65 64 3a 20 7e 61 22 20 28 73 74 72 65 ailed: ~a" (stre 0710: 72 72 6f 72 29 29 29 29 0a 0a 0a 20 20 28 64 65 rror))))... (de 0720: 66 69 6e 65 20 28 77 74 65 72 6d 73 69 67 20 78 fine (wtermsig x 0730: 29 0a 20 20 20 20 28 6c 6f 67 61 6e 64 20 78 20 ). (logand x 0740: 23 78 37 66 29 29 0a 20 20 28 64 65 66 69 6e 65 #x7f)). (define 0750: 20 28 77 69 66 65 78 69 74 65 64 20 78 29 0a 20 (wifexited x). 0760: 20 20 20 28 7a 65 72 6f 3f 20 28 77 74 65 72 6d (zero? (wterm 0770: 73 69 67 20 78 29 29 29 0a 20 20 28 64 65 66 69 sig x))). (defi 0780: 6e 65 20 28 77 69 66 73 69 67 6e 61 6c 65 64 20 ne (wifsignaled 0790: 78 29 0a 20 20 20 20 28 3e 20 28 6c 6f 67 61 6e x). (> (logan 07a0: 64 20 23 78 66 66 20 28 62 69 74 77 69 73 65 2d d #xff (bitwise- 07b0: 61 72 69 74 68 6d 65 74 69 63 2d 73 68 69 66 74 arithmetic-shift 07c0: 2d 72 69 67 68 74 0a 09 09 20 20 20 20 20 28 2b -right... (+ 07d0: 20 31 20 28 77 74 65 72 6d 73 69 67 20 78 29 29 1 (wtermsig x)) 07e0: 0a 09 09 20 20 20 20 20 31 29 29 0a 20 20 20 20 ... 1)). 07f0: 20 20 20 30 29 29 0a 20 20 28 64 65 66 69 6e 65 0)). (define 0800: 20 28 77 65 78 69 74 73 74 61 74 75 73 20 78 29 (wexitstatus x) 0810: 0a 20 20 20 20 28 62 69 74 77 69 73 65 2d 61 72 . (bitwise-ar 0820: 69 74 68 6d 65 74 69 63 2d 73 68 69 66 74 2d 72 ithmetic-shift-r 0830: 69 67 68 74 20 28 6c 6f 67 61 6e 64 20 78 20 23 ight (logand x # 0840: 78 66 66 30 30 29 20 38 29 29 0a 20 20 28 6d 65 xff00) 8)). (me 0850: 74 61 2d 63 6f 6e 64 0a 20 20 20 5b 28 6d 65 6d ta-cond. [(mem 0860: 71 20 28 6d 61 63 68 69 6e 65 2d 74 79 70 65 29 q (machine-type) 0870: 20 27 28 61 36 6c 65 20 74 61 36 6c 65 20 69 33 '(a6le ta6le i3 0880: 6c 65 20 74 69 33 6c 65 29 29 0a 20 20 20 20 28 le ti3le)). ( 0890: 64 65 66 69 6e 65 2d 66 6c 61 67 73 20 77 61 69 define-flags wai 08a0: 74 2d 66 6c 61 67 20 28 6e 6f 68 61 6e 67 20 31 t-flag (nohang 1 08b0: 29 20 28 75 6e 74 72 61 63 65 64 20 32 29 20 28 ) (untraced 2) ( 08c0: 73 74 6f 70 70 65 64 20 32 29 20 28 65 78 69 74 stopped 2) (exit 08d0: 65 64 20 34 29 20 28 63 6f 6e 74 69 6e 75 65 64 ed 4) (continued 08e0: 20 38 29 0a 20 20 20 20 20 20 28 6e 6f 77 61 69 8). (nowai 08f0: 74 20 23 78 30 31 30 30 30 30 30 30 29 20 28 6e t #x01000000) (n 0900: 6f 74 68 72 65 61 64 20 23 78 32 30 30 30 30 30 othread #x200000 0910: 30 30 29 20 28 61 6c 6c 20 23 78 34 30 30 30 30 00) (all #x40000 0920: 30 30 30 29 20 28 63 6c 6f 6e 65 20 23 78 38 30 000) (clone #x80 0930: 30 30 30 30 30 30 29 29 5d 29 0a 0a 20 20 28 64 000000))]).. (d 0940: 65 66 69 6e 65 20 77 61 69 74 2d 66 6f 72 2d 70 efine wait-for-p 0950: 69 64 0a 20 20 20 20 28 63 61 73 65 2d 6c 61 6d id. (case-lam 0960: 62 64 61 0a 20 20 20 20 20 5b 28 70 69 64 29 20 bda. [(pid) 0970: 28 77 61 69 74 2d 66 6f 72 2d 70 69 64 20 70 69 (wait-for-pid pi 0980: 64 20 27 28 29 29 5d 0a 20 20 20 20 20 5b 28 70 d '())]. [(p 0990: 69 64 20 6f 70 74 69 6f 6e 73 29 0a 20 20 20 20 id options). 09a0: 20 20 28 64 65 66 69 6e 65 20 77 61 69 74 70 69 (define waitpi 09b0: 64 2a 20 28 66 6f 72 65 69 67 6e 2d 70 72 6f 63 d* (foreign-proc 09c0: 65 64 75 72 65 20 22 77 61 69 74 70 69 64 22 20 edure "waitpid" 09d0: 28 69 6e 74 20 75 38 2a 20 69 6e 74 29 20 69 6e (int u8* int) in 09e0: 74 29 29 0a 20 20 20 20 20 20 28 64 65 66 69 6e t)). (defin 09f0: 65 20 73 74 61 74 75 73 2a 20 28 6d 61 6b 65 2d e status* (make- 0a00: 62 79 74 65 76 65 63 74 6f 72 20 28 66 6f 72 65 bytevector (fore 0a10: 69 67 6e 2d 73 69 7a 65 6f 66 20 27 69 6e 74 29 ign-sizeof 'int) 0a20: 29 29 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f )). (let lo 0a30: 6f 70 20 28 29 0a 09 28 6c 65 74 20 28 5b 72 20 op ()..(let ([r 0a40: 28 77 61 69 74 70 69 64 2a 20 70 69 64 20 73 74 (waitpid* pid st 0a50: 61 74 75 73 2a 20 28 61 70 70 6c 79 20 77 61 69 atus* (apply wai 0a60: 74 2d 66 6c 61 67 20 6f 70 74 69 6f 6e 73 29 29 t-flag options)) 0a70: 5d 29 0a 09 20 20 28 77 68 65 6e 20 28 3c 20 72 ]).. (when (< r 0a80: 20 30 29 0a 09 09 28 65 72 72 6f 72 66 20 27 77 0)...(errorf 'w 0a90: 61 69 74 2d 66 6f 72 2d 70 69 64 20 22 77 61 69 ait-for-pid "wai 0aa0: 74 70 69 64 20 66 61 69 6c 65 64 3a 20 7e 64 22 tpid failed: ~d" 0ab0: 20 28 73 74 72 65 72 72 6f 72 29 29 29 0a 09 20 (strerror))).. 0ac0: 20 28 6c 65 74 20 28 5b 73 74 61 74 75 73 20 28 (let ([status ( 0ad0: 62 79 74 65 76 65 63 74 6f 72 2d 73 69 6e 74 2d bytevector-sint- 0ae0: 72 65 66 20 73 74 61 74 75 73 2a 20 30 20 28 6e ref status* 0 (n 0af0: 61 74 69 76 65 2d 65 6e 64 69 61 6e 6e 65 73 73 ative-endianness 0b00: 29 20 28 66 6f 72 65 69 67 6e 2d 73 69 7a 65 6f ) (foreign-sizeo 0b10: 66 20 27 69 6e 74 29 29 5d 29 0a 09 20 20 20 20 f 'int))]).. 0b20: 28 63 6f 6e 64 20 5b 28 77 69 66 65 78 69 74 65 (cond [(wifexite 0b30: 64 20 73 74 61 74 75 73 29 20 28 77 65 78 69 74 d status) (wexit 0b40: 73 74 61 74 75 73 20 73 74 61 74 75 73 29 5d 0a status status)]. 0b50: 09 09 20 20 5b 28 77 69 66 73 69 67 6e 61 6c 65 .. [(wifsignale 0b60: 64 20 73 74 61 74 75 73 29 20 23 66 5d 0a 09 09 d status) #f]... 0b70: 20 20 5b 28 6c 6f 6f 70 29 5d 29 29 29 29 5d 29 [(loop)]))))]) 0b80: 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 66 6f ).. (define (fo 0b90: 72 6b 29 0a 20 20 20 20 28 64 65 66 69 6e 65 20 rk). (define 0ba0: 66 6f 72 6b 2a 20 28 66 6f 72 65 69 67 6e 2d 70 fork* (foreign-p 0bb0: 72 6f 63 65 64 75 72 65 20 22 66 6f 72 6b 22 20 rocedure "fork" 0bc0: 28 29 20 69 6e 74 65 67 65 72 2d 33 32 29 29 0a () integer-32)). 0bd0: 20 20 20 20 20 28 6c 65 74 20 28 5b 72 20 28 66 (let ([r (f 0be0: 6f 72 6b 2a 29 5d 29 0a 20 20 20 20 20 20 28 69 ork*)]). (i 0bf0: 66 20 28 3c 20 72 20 30 29 0a 09 20 20 28 65 72 f (< r 0).. (er 0c00: 72 6f 72 66 20 27 64 75 70 32 20 22 66 61 69 6c rorf 'dup2 "fail 0c10: 65 64 3a 20 7e 64 22 20 28 73 74 72 65 72 72 6f ed: ~d" (strerro 0c20: 72 29 29 0a 09 20 20 72 29 29 29 0a 0a 20 20 28 r)).. r))).. ( 0c30: 64 65 66 69 6e 65 20 64 75 70 0a 20 20 20 20 28 define dup. ( 0c40: 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 case-lambda. 0c50: 20 5b 28 66 69 6c 65 64 65 73 20 66 69 6c 65 64 [(filedes filed 0c60: 65 73 32 29 0a 20 20 20 20 20 20 28 64 65 66 69 es2). (defi 0c70: 6e 65 20 64 75 70 32 2a 20 28 66 6f 72 65 69 67 ne dup2* (foreig 0c80: 6e 2d 70 72 6f 63 65 64 75 72 65 20 22 64 75 70 n-procedure "dup 0c90: 32 22 20 28 69 6e 74 20 69 6e 74 29 20 69 6e 74 2" (int int) int 0ca0: 29 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 5b )). (let ([ 0cb0: 72 20 28 64 75 70 32 2a 20 66 69 6c 65 64 65 73 r (dup2* filedes 0cc0: 20 66 69 6c 65 64 65 73 32 29 5d 29 0a 09 28 69 filedes2)])..(i 0cd0: 66 20 28 3c 20 72 20 30 29 0a 09 20 20 20 20 28 f (< r 0).. ( 0ce0: 65 72 72 6f 72 66 20 27 64 75 70 32 20 22 66 61 errorf 'dup2 "fa 0cf0: 69 6c 65 64 3a 20 7e 64 22 20 28 73 74 72 65 72 iled: ~d" (strer 0d00: 72 6f 72 29 29 0a 09 20 20 20 20 72 29 29 5d 0a ror)).. r))]. 0d10: 20 20 20 20 20 5b 28 66 69 6c 65 64 65 73 29 0a [(filedes). 0d20: 20 20 20 20 20 20 28 64 65 66 69 6e 65 20 64 75 (define du 0d30: 70 2a 20 28 66 6f 72 65 69 67 6e 2d 70 72 6f 63 p* (foreign-proc 0d40: 65 64 75 72 65 20 22 64 75 70 22 20 28 69 6e 74 edure "dup" (int 0d50: 29 20 69 6e 74 29 29 0a 20 20 20 20 20 20 28 6c ) int)). (l 0d60: 65 74 20 28 5b 72 20 28 64 75 70 2a 20 66 69 6c et ([r (dup* fil 0d70: 65 64 65 73 29 5d 29 0a 09 28 69 66 20 28 3c 20 edes)])..(if (< 0d80: 72 20 30 29 0a 09 20 20 20 20 28 65 72 72 6f 72 r 0).. (error 0d90: 66 20 27 64 75 70 20 22 66 61 69 6c 65 64 3a 20 f 'dup "failed: 0da0: 7e 64 22 20 28 73 74 72 65 72 72 6f 72 29 29 0a ~d" (strerror)). 0db0: 09 20 20 20 20 72 29 29 5d 29 29 0a 20 20 0a 20 . r))])). . 0dc0: 20 3b 3b 20 74 68 65 73 65 20 73 68 6f 75 6c 64 ;; these should 0dd0: 6e 27 74 20 62 65 20 6e 65 65 64 65 64 2e 2e 20 n't be needed.. 0de0: 75 73 65 20 6a 75 73 74 20 6f 70 65 6e 2d 66 64 use just open-fd 0df0: 2d 69 6e 70 75 74 2d 70 6f 72 74 2c 0a 20 20 3b -input-port,. ; 0e00: 3b 20 6f 70 65 6e 2d 66 64 2d 6f 75 74 70 75 74 ; open-fd-output 0e10: 2d 70 6f 72 74 20 6f 72 20 6f 70 65 6e 2d 66 64 -port or open-fd 0e20: 2d 69 6e 70 75 74 2f 6f 75 74 70 75 74 2d 70 6f -input/output-po 0e30: 72 74 20 61 6e 64 20 74 68 65 6e 20 75 73 65 20 rt and then use 0e40: 74 68 65 20 73 63 68 65 6d 65 0a 20 20 3b 3b 20 the scheme. ;; 0e50: 66 75 6e 63 74 69 6f 6e 73 2e 2e 2e 0a 20 20 0a functions.... . 0e60: 20 20 28 64 65 66 69 6e 65 20 28 66 69 6c 65 2d (define (file- 0e70: 77 72 69 74 65 20 66 64 20 64 61 74 61 29 0a 20 write fd data). 0e80: 20 20 20 28 64 65 66 69 6e 65 20 77 72 69 74 65 (define write 0e90: 2a 20 28 66 6f 72 65 69 67 6e 2d 70 72 6f 63 65 * (foreign-proce 0ea0: 64 75 72 65 20 22 77 72 69 74 65 22 20 28 69 6e dure "write" (in 0eb0: 74 20 75 38 2a 20 73 69 7a 65 5f 74 29 20 73 73 t u8* size_t) ss 0ec0: 69 7a 65 5f 74 29 29 0a 20 20 20 20 28 64 65 66 ize_t)). (def 0ed0: 69 6e 65 20 6e 20 28 62 79 74 65 76 65 63 74 6f ine n (bytevecto 0ee0: 72 2d 6c 65 6e 67 74 68 20 64 61 74 61 29 29 0a r-length data)). 0ef0: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 5b (let loop ([ 0f00: 64 61 74 61 20 64 61 74 61 5d 29 0a 20 20 20 20 data data]). 0f10: 20 20 28 6c 65 74 20 28 5b 6d 20 28 62 79 74 65 (let ([m (byte 0f20: 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 64 61 vector-length da 0f30: 74 61 29 5d 29 0a 09 28 63 6f 6e 64 0a 09 20 5b ta)])..(cond.. [ 0f40: 28 3e 20 6d 20 30 29 0a 09 20 20 28 6c 65 74 20 (> m 0).. (let 0f50: 28 5b 72 20 28 77 72 69 74 65 2a 20 66 64 20 64 ([r (write* fd d 0f60: 61 74 61 20 6d 29 5d 29 0a 09 20 20 20 20 28 63 ata m)]).. (c 0f70: 6f 6e 64 0a 09 20 20 20 20 20 5b 28 3c 20 72 20 ond.. [(< r 0f80: 30 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 6f 0).. (if (o 0f90: 72 20 28 3d 20 28 65 72 72 6e 6f 29 20 45 41 47 r (= (errno) EAG 0fa0: 41 49 4e 29 20 28 3d 20 28 65 72 72 6e 6f 29 20 AIN) (= (errno) 0fb0: 45 49 4e 54 52 29 29 0a 09 09 20 20 28 6c 6f 6f EINTR))... (loo 0fc0: 70 20 64 61 74 61 29 0a 09 09 20 20 28 65 72 72 p data)... (err 0fd0: 6f 72 66 20 27 77 72 69 74 65 20 22 65 72 72 6f orf 'write "erro 0fe0: 72 20 77 72 69 74 69 6e 67 20 64 61 74 61 3a 20 r writing data: 0ff0: 7e 61 3a 20 7e 61 22 20 28 65 72 72 6e 6f 29 20 ~a: ~a" (errno) 1000: 28 73 74 72 65 72 72 6f 72 29 29 29 5d 0a 09 20 (strerror)))].. 1010: 20 20 20 20 5b 65 6c 73 65 0a 09 20 20 20 20 20 [else.. 1020: 20 28 6c 6f 6f 70 20 28 62 79 74 65 76 65 63 74 (loop (bytevect 1030: 6f 72 2d 63 6f 70 79 2a 20 64 61 74 61 20 72 29 or-copy* data r) 1040: 29 5d 29 29 5d 0a 09 20 5b 65 6c 73 65 20 6e 5d )]))].. [else n] 1050: 29 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 )))).. (define 1060: 28 66 69 6c 65 2d 72 65 61 64 20 66 64 20 6e 29 (file-read fd n) 1070: 0a 20 20 20 20 28 64 65 66 69 6e 65 20 72 65 61 . (define rea 1080: 64 2a 20 28 66 6f 72 65 69 67 6e 2d 70 72 6f 63 d* (foreign-proc 1090: 65 64 75 72 65 20 22 72 65 61 64 22 20 28 69 6e edure "read" (in 10a0: 74 20 75 38 2a 20 73 69 7a 65 5f 74 29 20 73 73 t u8* size_t) ss 10b0: 69 7a 65 5f 74 29 29 0a 20 20 20 20 28 64 65 66 ize_t)). (def 10c0: 69 6e 65 20 62 75 66 20 28 6d 61 6b 65 2d 62 79 ine buf (make-by 10d0: 74 65 76 65 63 74 6f 72 20 6e 29 29 0a 20 20 20 tevector n)). 10e0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 20 20 (let loop (). 10f0: 20 20 20 20 28 6c 65 74 20 28 5b 72 20 28 72 65 (let ([r (re 1100: 61 64 2a 20 66 64 20 62 75 66 20 6e 29 5d 29 0a ad* fd buf n)]). 1110: 09 28 63 6f 6e 64 0a 09 20 5b 28 3e 3d 20 72 20 .(cond.. [(>= r 1120: 30 29 20 72 5d 0a 09 20 5b 28 6f 72 20 28 3d 20 0) r].. [(or (= 1130: 28 65 72 72 6e 6f 29 20 45 41 47 41 49 4e 29 20 (errno) EAGAIN) 1140: 28 3d 20 28 65 72 72 6e 6f 29 20 45 49 4e 54 52 (= (errno) EINTR 1150: 29 29 20 2d 31 5d 0a 09 20 5b 65 6c 73 65 20 28 )) -1].. [else ( 1160: 6c 6f 6f 70 29 5d 29 29 29 29 0a 20 20 20 20 28 loop)])))). ( 1170: 64 65 66 69 6e 65 20 46 49 4f 4e 52 45 41 44 20 define FIONREAD 1180: 23 78 35 34 31 42 29 0a 0a 20 20 28 64 65 66 69 #x541B).. (defi 1190: 6e 65 20 28 62 79 74 65 73 2d 72 65 61 64 79 20 ne (bytes-ready 11a0: 66 64 29 0a 20 20 20 20 28 64 65 66 69 6e 65 20 fd). (define 11b0: 69 6f 63 74 6c 2a 20 28 66 6f 72 65 69 67 6e 2d ioctl* (foreign- 11c0: 70 72 6f 63 65 64 75 72 65 20 22 69 6f 63 74 6c procedure "ioctl 11d0: 22 20 28 69 6e 74 20 69 6e 74 20 76 6f 69 64 2a " (int int void* 11e0: 29 20 69 6e 74 29 29 0a 20 20 20 20 28 64 65 66 ) int)). (def 11f0: 69 6e 65 20 6e 2a 20 28 66 6f 72 65 69 67 6e 2d ine n* (foreign- 1200: 61 6c 6c 6f 63 20 28 66 6f 72 65 69 67 6e 2d 73 alloc (foreign-s 1210: 69 7a 65 6f 66 20 27 69 6e 74 29 29 29 0a 20 20 izeof 'int))). 1220: 20 20 28 69 6f 63 74 6c 2a 20 66 64 20 46 49 4f (ioctl* fd FIO 1230: 4e 52 45 41 44 20 6e 2a 29 0a 20 20 20 20 28 6c NREAD n*). (l 1240: 65 74 20 28 5b 6e 20 28 66 6f 72 65 69 67 6e 2d et ([n (foreign- 1250: 72 65 66 20 27 69 6e 74 20 6e 2a 20 30 29 5d 29 ref 'int n* 0)]) 1260: 0a 20 20 20 20 20 20 28 66 6f 72 65 69 67 6e 2d . (foreign- 1270: 66 72 65 65 20 6e 2a 29 0a 20 20 20 20 20 20 6e free n*). n 1280: 29 29 0a 0a 29 20 3b 3b 6c 69 62 72 61 72 79 20 ))..) ;;library 1290: 70 6f 73 69 78 0a posix.