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/blume-private-devel/src/system/Basis/Implementation/Posix/posix-process.sml
ViewVC logotype

Annotation of /sml/branches/blume-private-devel/src/system/Basis/Implementation/Posix/posix-process.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1401 - (view) (download)

1 : monnier 416 (* posix-process.sml
2 :     *
3 :     * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
4 :     *
5 :     * Structure for POSIX 1003.1 process submodule
6 :     *
7 :     *)
8 :    
9 :     local
10 :     structure SysWord = SysWordImp
11 :     structure Word8 = Word8Imp
12 :     structure Time = TimeImp
13 :     structure Int = IntImp
14 :     in
15 :     structure POSIX_Process =
16 :     struct
17 :    
18 :     structure Sig = POSIX_Signal
19 :    
20 :     val ++ = SysWord.orb
21 :     val & = SysWord.andb
22 :     infix ++ &
23 :    
24 :     type word = SysWord.word
25 :     type s_int = SysInt.int
26 :    
27 :     type signal = Sig.signal
28 :     datatype pid = PID of s_int
29 :     fun pidToWord (PID i) = SysWord.fromInt i
30 :     fun wordToPid w = PID (SysWord.toInt w)
31 :    
32 :     fun cfun x = CInterface.c_function "POSIX-Process" x
33 :     val osval : string -> s_int = cfun "osval"
34 :     val w_osval = SysWord.fromInt o osval
35 :    
36 :     val sysconf : string -> SysWord.word =
37 :     CInterface.c_function "POSIX-ProcEnv" "sysconf"
38 :    
39 :     val fork' : unit -> s_int = cfun "fork"
40 :     fun fork () =
41 :     case fork' () of
42 :     0 => NONE
43 :     | child_pid => SOME(PID child_pid)
44 :    
45 :     fun exec (x: string * string list) : 'a = cfun "exec" x
46 :     fun exece (x: string * string list * string list) : 'a = cfun "exece" x
47 :     fun execp (x: string * string list): 'a = cfun "execp" x
48 :    
49 :     datatype waitpid_arg
50 :     = W_ANY_CHILD
51 :     | W_CHILD of pid
52 :     | W_SAME_GROUP
53 :     | W_GROUP of pid
54 :    
55 :     datatype killpid_arg
56 :     = K_PROC of pid
57 :     | K_SAME_GROUP
58 :     | K_GROUP of pid
59 :    
60 :     datatype exit_status
61 :     = W_EXITED
62 :     | W_EXITSTATUS of Word8.word
63 :     | W_SIGNALED of signal
64 :     | W_STOPPED of signal
65 :    
66 :     (* (pid',status,status_val) = waitpid' (pid,options) *)
67 :     val waitpid' : s_int * word -> s_int * s_int * s_int = cfun "waitpid"
68 :    
69 :     fun argToInt W_ANY_CHILD = ~1
70 :     | argToInt (W_CHILD (PID pid)) = pid
71 :     | argToInt (W_SAME_GROUP) = 0
72 :     | argToInt (W_GROUP (PID pid)) = ~pid
73 :    
74 :     (* The exit status from wait is encoded as a pair of integers.
75 :     * If the first integer is 0, the child exited normally, and
76 :     * the second integer gives its exit value.
77 :     * If the first integer is 1, the child exited due to an uncaught
78 :     * signal, and the second integer gives the signal value.
79 :     * Otherwise, the child is stopped and the second integer
80 :     * gives the signal value that caused the child to stop.
81 :     *)
82 :     fun mkExitStatus (0,0) = W_EXITED
83 :     | mkExitStatus (0,v) = W_EXITSTATUS(Word8.fromInt v)
84 :     | mkExitStatus (1,s) = W_SIGNALED (Sig.SIG s)
85 :     | mkExitStatus (_,s) = W_STOPPED (Sig.SIG s)
86 :    
87 :    
88 :     val wnohang = w_osval "WNOHANG"
89 :     structure W =
90 :     struct
91 :     datatype flags = WF of word
92 :    
93 :     fun fromWord w = WF w
94 :     fun toWord (WF w) = w
95 :    
96 :     fun flags ms = WF(List.foldl (fn (WF m,acc) => m ++ acc) 0w0 ms)
97 :     fun anySet (WF m, WF m') = (m & m') <> 0w0
98 :     fun allSet (WF m, WF m') = (m & m') = m
99 :    
100 :     fun orF (WF f,acc) = f ++ acc
101 :    
102 :     val untraced =
103 :     WF(sysconf "JOB_CONTROL"; w_osval "WUNTRACED") handle _ => WF 0w0
104 :     end
105 :    
106 :     fun waitpid (arg,flags) = let
107 :     val (pid,status,sv) = waitpid'(argToInt arg, List.foldl W.orF 0w0 flags)
108 :     in
109 :     (PID pid, mkExitStatus(status,sv))
110 :     end
111 :    
112 :     fun waitpid_nh (arg,flags) =
113 :     case waitpid'(argToInt arg, List.foldl W.orF wnohang flags) of
114 :     (0,_,_) => NONE
115 :     | (pid,status,sv) => SOME(PID pid, mkExitStatus(status,sv))
116 :    
117 :     fun wait () = waitpid(W_ANY_CHILD,[])
118 :    
119 :     fun exit (x: Word8.word) : 'a = cfun "exit" x
120 :    
121 :     val kill' : s_int * s_int -> unit = cfun "kill"
122 :     fun kill (K_PROC (PID pid),Sig.SIG s) = kill'(pid, s)
123 :     | kill (K_SAME_GROUP,Sig.SIG s) = kill'(~1, s)
124 :     | kill (K_GROUP (PID pid),Sig.SIG s) = kill'(~pid, s)
125 :    
126 :     local
127 :     fun wrap f t =
128 :     Time.fromSeconds(Int.toLarge(f(Int.fromLarge(Time.toSeconds t))))
129 :     val alarm' : int -> int = cfun "alarm"
130 :     val sleep' : int -> int = cfun "sleep"
131 :     in
132 :     val alarm = wrap alarm'
133 :     val sleep = wrap sleep'
134 :     end
135 :    
136 :     val pause : unit -> unit = cfun "pause"
137 :    
138 :    
139 :     end (* structure POSIX_Process *)
140 :     end
141 :    

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