Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/branches/dbm-type-blame/system/Basis/Implementation/Win32/os-io.sml
ViewVC logotype

Annotation of /sml/branches/dbm-type-blame/system/Basis/Implementation/Win32/os-io.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3594 - (view) (download)

1 : monnier 416 (* os-io.sml
2 :     *
3 :     * COPYRIGHT (c) 1998 Bell Labs, Lucent Technologies.
4 :     * COPYRIGHT (c) 1996 Bell Laboratories.
5 :     *
6 :     * Replacement OS.IO structure for Win32.
7 :     * It implements a simple type of polling for file objects.
8 :     * This file requires a runtime system supporting polling in Win32-IO.
9 :     *)
10 :    
11 :     local
12 :     structure Word = WordImp
13 :     structure Int = IntImp
14 : mblume 1347 structure Int32 = Int32Imp
15 : monnier 416 structure Time = TimeImp
16 :     in
17 :     structure OS_IO : OS_IO =
18 :     struct
19 :     structure W32G = Win32_General
20 :     structure W32FS = Win32_FileSys
21 :     type word32 = Word32.word
22 :    
23 :     exception SysErr = Assembly.SysErr
24 :    
25 :     type iodesc = OS.IO.iodesc (* IODesc of W32G.hndl ref *)
26 :    
27 :     (* hash: can't assume 32 bits *)
28 :     fun hash (OS.IO.IODesc (ref (0wxffffffff : W32G.hndl))) =
29 :     0wx7fffffff : word
30 :     | hash (OS.IO.IODesc (ref h)) = (Word.fromInt o W32G.Word.toInt) h
31 :    
32 :     fun compare (OS.IO.IODesc (ref wa),OS.IO.IODesc (ref wb)) =
33 :     W32G.Word.compare(wa,wb)
34 :    
35 :     datatype iodesc_kind = K of string
36 :    
37 :     structure Kind =
38 :     struct
39 :     val file = K "FILE"
40 :     val dir = K "DIR"
41 :     val symlink = K "LINK"
42 :     val tty = K "TTY"
43 :     val pipe = K "PIPE"
44 :     val socket = K "SOCK"
45 :     val device = K "DEV"
46 :     end
47 :    
48 :     fun kind (OS.IO.IODesc (ref h)) =
49 :     case W32FS.getFileAttributes' h of
50 :     NONE =>
51 :     K "UNKNOWN"
52 :     | SOME w =>
53 :     if W32FS.isRegularFile h then Kind.file
54 :     else Kind.dir
55 :    
56 :     (* no win32 polling devices for now *)
57 :     val noPolling = "polling not implemented for win32 for this device/type"
58 :    
59 :     type poll_flags = {rd : bool, wr: bool, pri: bool}
60 :     datatype poll_desc = PollDesc of (iodesc * poll_flags)
61 :     datatype poll_info = PollInfo of poll_desc
62 :    
63 :     fun pollDesc id = SOME (PollDesc (id,{rd=false,wr=false,pri=false}))
64 :     fun pollToIODesc (PollDesc (pd,_)) = pd
65 :    
66 :     exception Poll
67 :    
68 :     fun pollIn (PollDesc (iod,{rd,wr,pri})) = PollDesc (iod,{rd=true,wr=wr,pri=pri})
69 :     fun pollOut (PollDesc (iod,{rd,wr,pri})) = PollDesc (iod,{rd=rd,wr=true,pri=pri})
70 :     fun pollPri (PollDesc (iod,{rd,wr,pri})) = PollDesc (iod,{rd=rd,wr=wr,pri=true})
71 :    
72 :     local
73 : dbm 3594 val poll' : ((word32 * word) list * (int * word) list * (Int32.int * int) option -> ((word32 * word) list * (int * word) list)) =
74 : monnier 416 CInterface.c_function "WIN32-IO" "poll"
75 :    
76 :     fun join (false, _, w) = w
77 :     | join (true, b, w) = Word.orb(w, b)
78 :     fun test (w, b) = (Word.andb(w, b) <> 0w0)
79 :     val rdBit = 0w1 and wrBit = 0w2 and priBit = 0w4
80 :    
81 : dbm 3594 fun toPollInfoIO (fd,w) = PollInfo (PollDesc (OS.IO.IODesc (ref fd),{rd= test(w,rdBit),
82 :     wr= test(w,wrBit),
83 :     pri= test(w,priBit)}))
84 : monnier 416 fun toPollInfoSock (i,w) = PollInfo (PollDesc (OS.IO.SockDesc (i),{rd = test(w,rdBit),
85 :     wr = test(w,wrBit),
86 :     pri = test(w,priBit)}))
87 : dbm 3594 fun fromPollDescIO (PollDesc (OS.IO.IODesc (ref w),{rd,wr,pri})) =(w,join (rd,rdBit, join (wr,wrBit, join (pri,priBit,0w0))))
88 :     fun fromPollDescSock (PollDesc (OS.IO.SockDesc (i),{rd,wr,pri})) = (i,join (rd,rdBit, join (wr,wrBit, join (pri,priBit,0w0))))
89 :    
90 :     (* To preserve equality, return the original PollDesc passed to poll.
91 :     * This is cheesy, but restructuring the IODesc to no longer have a ref
92 :     * cell is a substantial amount of work, as much of the Win32 FS basis
93 :     * relies on mutability.
94 :     *)
95 :     fun findPollDescFromIO (pollIOs, (fd,w)) = let
96 :     val desc = List.find (fn (PollDesc (OS.IO.IODesc (ref fd'),_)) => fd'=fd) pollIOs
97 :     in
98 :     case desc
99 :     of SOME f => SOME(PollInfo f)
100 :     | NONE => NONE
101 :     end
102 : monnier 416 in
103 :     fun poll (pdl,t) =
104 : mblume 1347 let val timeout =
105 :     case t of
106 :     SOME (t) =>
107 :     SOME (Int32.fromLarge (Time.toSeconds (t)),
108 :     Int.fromLarge (Time.toMicroseconds t))
109 :     | NONE => NONE
110 : dbm 3594 fun partDesc (PollDesc (OS.IO.IODesc (_),_)) = true
111 :     | partDesc (_) = false
112 :     val (pollIOs, pollSocks) = List.partition partDesc pdl
113 : mblume 1347 val (infoIO,infoSock) =
114 : dbm 3594 poll' (List.map fromPollDescIO pollIOs,
115 :     List.map fromPollDescSock pollSocks,
116 : mblume 1347 timeout)
117 : monnier 416 in
118 : dbm 3594 List.@ (List.mapPartial (fn (p) => findPollDescFromIO(pollIOs,p)) infoIO,
119 : mblume 1347 List.map toPollInfoSock infoSock)
120 : monnier 416 end
121 :     end
122 :    
123 : dbm 3594 fun isIn (PollInfo(PollDesc(_, flgs))) = #rd flgs
124 :     fun isOut (PollInfo(PollDesc(_, flgs))) = #wr flgs
125 :     fun isPri (PollInfo(PollDesc(_, flgs))) = #pri flgs
126 :     fun infoToPollDesc (PollInfo pd) = pd
127 : monnier 416 end
128 :     end
129 :    

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0