home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1993 #3 / NN_1993_3.iso / spool / vmsnet / sources / 509 < prev    next >
Encoding:
Internet Message Format  |  1993-01-28  |  12.8 KB
  1. Path: sparky!uunet!stanford.edu!agate!spool.mu.edu!howland.reston.ans.net!usc!sol.ctr.columbia.edu!hamblin.math.byu.edu!arizona.edu!mvb.saic.com!vmsnet-sources
  2. Newsgroups: vmsnet.sources
  3. Subject: Control-C handler for Fortran, part 01/01
  4. Message-ID: <10360095@MVB.SAIC.COM>
  5. From: ewilts@galaxy.gov.bc.ca (Ed Wilts)
  6. Date: Wed, 27 Jan 1993 21:50:04 GMT
  7. Followup-To: vmsnet.sources.d
  8. Organization: BC Systems Corporation
  9. Summary: ^C enable/disable/trap
  10. Approved: Mark.Berryman@Mvb.Saic.Com
  11. Lines: 358
  12.  
  13. Submitted-by: ewilts@galaxy.gov.bc.ca (Ed Wilts)
  14. Posting-number: Volume 4, Issue 54
  15. Archive-name: fortran_control-c_handler/part01
  16.  
  17. This archive consists of two Fortran modules to simply Control-C handling, one
  18. of which is merely a test program.
  19.  
  20. By calling the Control C handler, a high-level application can easily detect if
  21. a ^C has been issued by the terminal and take appropriate action.
  22.  
  23. Note that I am not the original author and am only making it availalbe since
  24. somebody asked...
  25.  
  26. $! ------------------ CUT HERE -----------------------
  27. $ v='f$verify(f$trnlnm("SHARE_UNPACK_VERIFY"))'
  28. $!
  29. $! This archive created by VMS_SHARE Version 8.1
  30. $!   On 12-JAN-1993 08:15:23.86   By user EWILTS       (Ed Wilts)
  31. $!
  32. $! The VMS_SHARE software that created this archive
  33. $!    was written by  Andy Harper, Kings College London UK
  34. $!    -- September 1992
  35. $!
  36. $! Credit is due to these people for their original ideas:
  37. $!    James Gray, Michael Bednarek 
  38. $!
  39. $! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER
  40. $! AND EXECUTE AS A COMMAND PROCEDURE  (  @name  )
  41. $!
  42. $! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING:
  43. $!       1. CONTROL_C_TRAPS.FOR;1
  44. $!       2. TEST_CONTROL_C.FOR;1
  45. $!
  46. $set="set"
  47. $set symbol/scope=(nolocal,noglobal)
  48. $f=f$parse("SHARE_UNPACK_TEMP","SYS$SCRATCH:."+f$getjpi("","PID"))
  49. $e="write sys$error  ""%UNPACK"", "
  50. $w="write sys$output ""%UNPACK"", "
  51. $ if .not. f$trnlnm("SHARE_UNPACK_LOG") then $ w = "!"
  52. $ ve=f$getsyi("version")
  53. $ if ve-f$extract(0,1,ve) .ges. "4.4" then $ goto start
  54. $ e "-E-OLDVER, Must run at least VMS 4.4"
  55. $ v=f$verify(v)
  56. $ exit 44
  57. $unpack: subroutine ! P1=filename, P2=checksum, P3=attributes
  58. $ if f$search(P1) .eqs. "" then $ goto file_absent
  59. $ e "-W-EXISTS, File ''P1' exists. Skipped."
  60. $ delete 'f'*
  61. $ exit
  62. $file_absent:
  63. $ if f$parse(P1) .nes. "" then $ goto dirok
  64. $ dn=f$parse(P1,,,"DIRECTORY")
  65. $ w "-I-CREDIR, Creating directory ''dn'"
  66. $ create/dir 'dn'
  67. $ if $status then $ goto dirok
  68. $ e "-E-CREDIRFAIL, Unable to create ''dn' File skipped."
  69. $ delete 'f'*
  70. $ exit
  71. $dirok:
  72. $ w "-I-UNPACK, Unpacking file ''P1'"
  73. $ n=P1
  74. $ if P3 .nes. "" then $ n=f
  75. $ if .not. f$verify() then $ define/user sys$output nl:
  76. $ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='n'
  77. PROCEDURE GetHex LOCAL x1,x2;x1:=INDEX(t,ERASE_CHARACTER(1))-1;x2:=INDEX(t,
  78. ERASE_CHARACTER(1))-1;RETURN 16*x1+x2;ENDPROCEDURE;
  79. PROCEDURE SkipPartsep LOOP EXITIF INDEX(ERASE_LINE,"-+-+-+-+-+-+-+-+")=1;
  80. ENDLOOP;ENDPROCEDURE;
  81. PROCEDURE ExpandChar CASE CURRENT_CHARACTER FROM ' ' TO 'z' ["`"]
  82. :ERASE_CHARACTER(1);COPY_TEXT(ASCII(GetHex));[" "]:ERASE_CHARACTER(1);[
  83. OUTRANGE,INRANGE]:MOVE_HORIZONTAL(1);ENDCASE;ENDPROCEDURE;
  84. PROCEDURE ProcessLine s:=ERASE_CHARACTER(1);LOOP EXITIF CURRENT_OFFSET>=LENGTH(
  85. CURRENT_LINE);ExpandChar;ENDLOOP;IF s="V" THEN APPEND_LINE;ENDIF;ENDPROCEDURE;
  86. PROCEDURE AdvanceLine MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);
  87. ENDPROCEDURE;PROCEDURE Decode POSITION(BEGINNING_OF(b));LOOP EXITIF MARK(NONE)=
  88. END_OF(b);IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+-")=1 THEN SkipPartSep;
  89. ELSE ProcessLine;AdvanceLine;ENDIF;ENDLOOP;ENDPROCEDURE;SET(FACILITY_NAME,
  90. "UNPACK");SET(SUCCESS,OFF);SET(INFORMATIONAL,OFF);t:="0123456789ABCDEF";f:=
  91. GET_INFO(COMMAND_LINE,"file_name");b:=CREATE_BUFFER(f,f);Decode;WRITE_FILE(b,
  92. GET_INFO(COMMAND_LINE,"output_file"));QUIT;
  93. $ if p3 .eqs. "" then $ goto dl
  94. $ open/write fdl &f
  95. $ write fdl "RECORD"
  96. $ write fdl P3
  97. $ close fdl
  98. $ w "-I-CONVRFM, Converting record format to ", P3
  99. $ convert/fdl=&f &f-1 &P1
  100. $dl: delete 'f'*
  101. $ if P2 .eqs. "" then $ goto ckskip
  102. $ checksum 'P1'
  103. $ if checksum$checksum .nes. P2 then $ -
  104.   e "-E-CHKSMFAIL, Checksum of ''P1' failed."
  105. $ exit
  106. $ckskip: e "-W-CHKSUMSKIP, checksum validation unavailable for ''P1'"
  107. $ endsubroutine
  108. $start:
  109. $!
  110. $ create 'f'
  111. XCLast`20Modified:`20`204-JAN-1990`2010:12:56`20by`20WILTS`20:`20CONTROL_C_TRAP
  112. VS.FOR
  113. Xc****************************************************************************
  114. Xc`20Control_c.for`20--`20FJM`20--`2011/14/85
  115. Xc****************************************************************************
  116. Xc
  117. Xc`20Modified`20History:
  118. Xc
  119. Xc`0911/11/88`20--`20FJM`20--`20Insure`20that`20multiple`20calls`20to`20enable_
  120. Vcontrol_C_asts,
  121. Xc`09`09`09`20`20`20with`20or`20without`20intervening`20call`20to
  122. Xc`09`09`09`20`20`20disable_control_C_asts,`20leave`20routine
  123. Xc`09`09`09`20`20`20Control_c_was_seen`20in`20the`20.FALSE.`20state.
  124. Xc
  125. Xc****************************************************************************
  126. Xc
  127. Xc`20These`20routines`20allow`20a`20user`20to`20enable`20a`20device`20to`20resp
  128. Vond`20to`20control-c
  129. Xc`20asts.`20To`20do`20this`20the`20user`20calls:
  130. Xc
  131. Xc`09`09status`20=`20enable_control_c_asts(device)
  132. Xc
  133. Xc`20where`20"device"`20is`20the`20device`20the`20control_c`20interrupt`20decte
  134. Vction`20is`20to`20be
  135. Xc`20enabled`20for.`20If`20the`20device`20string`20is`20blank,`20or`20the`20dev
  136. Vice`20is`20not`20a`20terminal
  137. Xc`20device`20(ie.`20a`20CRT,`20Hardcopy`20terminal,`20etc.)`20then`20the`20rou
  138. Vtine`20assumes`20that
  139. Xc`20the`20call`20was`20made`20in`20batch`20or`20detached`20mode,`20and`20does
  140. V`20not`20establish`20an
  141. Xc`20ast`20handler.`20In`20this`20case`20the`20status`20returned`20is`20SS$_NOR
  142. VMAL.`20In`20all`20other
  143. Xc`20cases,`20control_c`20ast's`20are`20enabled,`20and`20the`20status`20returne
  144. Vd`20is`20that`20of
  145. Xc`20the`20system`20calls`20to`20establish`20the`20ast.
  146. Xc
  147. Xc`20To`20detect`20the`20presence`20of`20a`20typed`20Control_c,`20the`20user
  148. V`20calls`20the`20function
  149. Xc
  150. Xc`09control_c_was_seen()
  151. Xc
  152. Xc`20This`20function`20returns`20.true.`20if`20a`20control_c`20was`20typed`20si
  153. Vnce`20the`20last`20time
  154. Xc`20control_c_was_seen`20was`20called.
  155. Xc
  156. Xc`20Example:
  157. Xc
  158. Xc`09`09if(`20control_c_was_seen()`20)`20then
  159. Xc`09`09`09`09.
  160. Xc`09`09`09`09.
  161. Xc`09`09`09`09.
  162. Xc`09`09`20`20`09`20`20`20`20`20end`20if
  163. Xc
  164. Xc`20Calling`20Enable_Control_c_Asts`20also`20has`20the`20effect`20of`20clearin
  165. Vg`20the
  166. Xc`20Control_c_Was_Seen`20Flag.`20Thus`20a`20control_c_Was_Seen`20call`20is`20g
  167. Vuaranteed`20to
  168. Xc`20return`20.TRUE.`20only`20if`20the`20control_c`20occurs`20between`20after
  169. V`20the`20last`20time
  170. Xc`20the`20Enable_Control_c_Asts`20routine`20is`20called.`20Note`20that`20in
  171. V`20general,`20through,
  172. Xc`20the`20intent`20is`20to`20call`20the`20Enable_Control_c_Ast`20routine`20onl
  173. Vy`20once,`20at`20the
  174. Xc`20beginning`20of`20the`20program.
  175. Xc
  176. Xc`20To`20stop`20the`20effect`20of`20the`20control_c`20interrupt,`20and`20remov
  177. Ve`20the`20ast`20handler,
  178. Xc`20the`20user`20may`20call`20the`20routine:
  179. Xc
  180. Xc`09`09status`20=`20disable_control_c_asts()
  181. Xc
  182. Xc`20Note`20that`20these`20routines`20are`20non-deterministic`20in`20that`20if
  183. V`20more`20than`20one
  184. Xc`20control_c`20is`20typed`20before`20"control_c_was_seen"`20is`20called,`20th
  185. Ve`20"extra"
  186. Xc`20control_c's`20are`20thrown`20out,`20not`20queued`20for`20delivery.`20Also
  187. V`20note`20that`20the
  188. Xc`20routines`20only`20support`20one`20device`20at`20a`20time,`20thus`20the`20r
  189. Voutine
  190. Xc`20"enable_control_c_asts"`20may`20only`20be`20called`20once`20within`20a`20p
  191. Vrogram
  192. Xc`20(unless`20the`20user`20calls`20disable_control_c_asts).`20If`20called`20mo
  193. Vre`20than
  194. Xc`20once`20without`20calling`20disable_control_c_asts,`20no`20action`20is`20ta
  195. Vken,
  196. Xc`20other`20then`20the`20above`20mentioned`20clearing`20of`20the`20control_c_w
  197. Vas_Seen`20flag,
  198. Xc`20and`20the`20status`20code`20of`20ss$_normal`20is`20returned`20(as`20contro
  199. Vl_c`20ast's`20are
  200. Xc`20still`20enabled).
  201. Xc
  202. Xc****************************************************************************
  203. X`20
  204. X`09integer*4`20function`20`20Enable_control_c_asts(device)
  205. Xc
  206. X`09implicit`09none
  207. X`20
  208. X`09character*(*)`09device
  209. X`09integer*4`09i,`20length,`20status,`20devtype
  210. X`09integer*4`09channel`09`09/0/
  211. X`09integer*4`20`09sys$qiow,`20sys$assign,`20sys$dassgn
  212. X`09integer*4`20`09lib$getdvi
  213. X`09integer*4`20`09reenable_control_c_ast
  214. X`09integer*4`20`09disable_control_c_asts
  215. X`09integer*4`20`09control_c_was_seen
  216. X`20
  217. X`09external`09dc$_term
  218. X`09external`09ss$_normal,`20ss$_abort
  219. X`09external`09dvi$_devclass
  220. X`09external`09io$_setmode
  221. X`09external`09io$m_ctrlcast
  222. X`09external`09control_c_ast_handler
  223. X`20
  224. X`09save`09`09channel
  225. X`20
  226. Xc`20Insure`20the`20routine`20Control_c_Was_Seen`20is`20in`20a`20known`20state
  227. V`20(.false.)
  228. Xc`20by`20eating`20any`20value`20it`20currently`20has.
  229. X`20
  230. X`09status`20=`20Control_c_Was_Seen()
  231. X`20
  232. Xc`20If`20we`20have`20already`20established`20a`20control_c`20handler,`20channe
  233. Vl`20will`20be
  234. Xc`20non-zero,`20so`20do`20nothing`20more`20than`20return.
  235. X`20
  236. X`09enable_control_c_asts`20=`20%loc(ss$_normal)
  237. X`09if(`20channel`20.ne.`200)`20then
  238. X`09`20`20return
  239. X`09`20`20end`20if
  240. X`20
  241. Xc`20return`20with`20no`20action`20if`20the`20device`20string`20is`20blank,`20o
  242. Vr`20if`20the
  243. Xc`20device`20is`20not`20a`20terminal.`20This`20allows`20programs`20to`20run
  244. V`20okay`20from
  245. Xc`20batch`20mode`20and`20detached`20mode.
  246. X`20
  247. X`09do`20i`20=`20len(device),1,-1
  248. X`09`20`20if(device(i:i).gt.'`20')go`20to`2010
  249. X`09`20`20end`20do
  250. X`09return
  251. X10`09length`20=`20i
  252. X`20
  253. X`09status`20=`20lib$getdvi(%loc(dvi$_devclass),,device(1:length),devtype)
  254. X`09if(`20.not.`20status`20)`20then
  255. X`09`20`20enable_control_c_asts`20=`20status
  256. X`09`20`20return
  257. X`09`20`20end`20if
  258. X`20
  259. X`09if(`20devtype`20.ne.`20%loc(dc$_term))`20return
  260. X`20
  261. Xc`20if`20we`20got`20here,`20we`20have`20a`20terminal`20device.`20Assign`20the
  262. V`20channel
  263. X`20
  264. X`09status`20=`20sys$assign(device(1:length),channel,,)
  265. X`09if`20(.not.status)`20then
  266. X`09`20`20enable_control_c_asts`20=`20status
  267. X`09`20`20return
  268. X`09`20`20end`20if
  269. X`20
  270. Xc`20and`20establish`20the`20interrupt`20handler.
  271. X`20
  272. X`09status`20=`20sys$qiow(%val(0),%val(channel),
  273. X`091`09`20`20%val(%loc(io$_setmode)`20.or.`20%loc(io$m_ctrlcast)),
  274. X`092`09`20`20,,,control_c_ast_handler,,,,,)
  275. X`09enable_control_c_asts`20=`20status
  276. X`09return
  277. X`20
  278. Xc`20This`20is`20the`20entry`20point`20for`20removing`20the`20control_c`20asts
  279. X`20
  280. X`09entry`09disable_control_c_asts
  281. X`20
  282. X`09disable_control_c_asts`20=`20sys$dassgn(%val(channel))
  283. X`09channel`20=`200
  284. X`20
  285. Xc`20`20`20`20`20call`20the`20detection`20routine.`20This`20insures`20that`20co
  286. Vntrol_c_was_seen
  287. Xc`20`20`20`20`20is`20left`20in`20the`20.false.`20state,`20if`20the`20user`20ca
  288. Vlls`20it`20again`20after`20this.
  289. X`20
  290. X`09status`20=`20control_c_was_seen()
  291. X`09return
  292. X`20
  293. Xc`20this`20is`20the`20entry`20point`20which`20re_enables`20the`20control_c`20a
  294. Vsts
  295. Xc`20when`20it`20is`20read`20out.`20It`20is`20needed`20here`20since`20FORTRAN
  296. V`20requires`20that
  297. Xc`20no`20external`20reference`20can`20be`20made`20to`20"control_c_ast_handler"
  298. V
  299. Xc`20from`20within`20that`20subroutine.`20(ie.`20the`20compiler`20thinks`20it
  300. V`20is`20detecting
  301. Xc`20recursion).`20Thus`20we`20trick`20it`20by`20indirection.`20(It`20also`20sa
  302. Vves`20having
  303. Xc`20to`20pass`20"channel"`20around`20anyway.
  304. X`20
  305. X`09entry`20reenable_control_c_ast
  306. X`09status`20=`20sys$qiow(%val(0),%val(channel),
  307. X`091`09`20`20%val(%loc(io$_setmode)`20.or.`20%loc(io$m_ctrlcast)),
  308. X`092`09`20`20,,,control_c_ast_handler,,,,,)
  309. X`09if(`20.not.`20status)`20call`20lib$signal(%val(status))
  310. X`09reenable_control_c_ast`20=`20status
  311. X`09return
  312. X`20
  313. X`09end
  314. X`20
  315. Xc`20function`20control_c_was_seen()
  316. Xc
  317. Xc`20This`20function`20is`20called`20by`20the`20user`20to`20test`20if`20a`20con
  318. Vtrol_c`20asts
  319. Xc`20has`20occured`20since`20the`20last`20call`20to`20control_c_was_seen.`20The
  320. V`20routine
  321. Xc`20returns`20.true.`20or`20.false.`20as`20appropriate,`20and`20then`20re-enab
  322. Vles`20the`20control-y
  323. Xc`20asts.
  324. X`20
  325. X`09logical*4`20function`20control_c_was_seen
  326. X`20
  327. X`09logical*4`09was_seen`09/.false./
  328. X`09volatile`09was_seen
  329. X`09save`09`09was_seen
  330. X`20
  331. X`09control_c_was_seen`20=`20was_seen
  332. X`09if(`20was_seen`20)`20then
  333. X`09`20`20was_seen`20=`20.false.
  334. X`09`20`20end`20if
  335. X`09return
  336. X`20
  337. Xc`20This`20entry`20point`20is`20the`20control_c`20asts`20handler
  338. X`20
  339. X`09entry`20control_c_ast_handler
  340. X`20
  341. X`09call`20reenable_control_c_ast
  342. X`09was_seen`20=`20.true.
  343. X`09return
  344. X`09end
  345. $ call unpack CONTROL_C_TRAPS.FOR;1 1549371480 ""
  346. $!
  347. $ create 'f'
  348. XCLast`20Modified:`20`204-JAN-1990`2010:26:55`20by`20WILTS`20:`20TEST.FOR
  349. X`09logical`20`09loop_flag/.true./,
  350. X`091`09`09control_c_was_seen
  351. X
  352. X`09call`20enable_control_c_asts('tt')
  353. X
  354. X`09do`20while`20(loop_flag)
  355. X`09`09type`20*,'looping....'
  356. X`09`09if`20(control_c_was_seen())`20then`20
  357. X`09`09`09loop_flag`20=`20.false.
  358. X`09`09`09type`20*,'setting`20loop_flag`20false'`09
  359. X`09`09endif
  360. X`09end`20do
  361. X
  362. X`09call`20exit
  363. X`09end
  364. $ call unpack TEST_CONTROL_C.FOR;1 739779678 ""
  365. $ v=f$verify(v)
  366. $ exit
  367.  
  368. -- 
  369. Ed Wilts, BC Systems, 4000 Seymour Place, Victoria, B.C., Canada, V8X 4S8
  370. EWilts@Galaxy.Gov.BC.CA     Office:  (604) 389-3430   Fax: (604) 389-3412
  371.