rexx.pas 25 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771
  1. {
  2. This file is part of the Free Pascal run time library.
  3. A file in Amiga system run time library.
  4. Copyright (c) 1998-2003 by Nils Sjoholm
  5. member of the Amiga RTL development team.
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. {
  13. History:
  14. Added overlay functions for Pchar->Strings, functions
  15. and procedures.
  16. 14 Jul 2000.
  17. Removed amigaoverlays, use smartlink instead.
  18. 05 Nov 2002.
  19. Added the defines use_amiga_smartlink and
  20. use_auto_openlib. Implemented autoopening of
  21. the library.
  22. 14 Jan 2003.
  23. Changed integer > smallint,
  24. cardinal > longword.
  25. 09 Feb 2003.
  26. [email protected]
  27. }
  28. {$I useamigasmartlink.inc}
  29. {$ifdef use_amiga_smartlink}
  30. {$smartlink on}
  31. {$endif use_amiga_smartlink}
  32. UNIT rexx;
  33. INTERFACE
  34. USES exec;
  35. { === rexx/storage.h ==================================================
  36. *
  37. * Copyright (c) 1986, 1987 by William S. Hawes (All Rights Reserved)
  38. *
  39. * =====================================================================
  40. * Header file to define ARexx data structures.
  41. }
  42. { The NexxStr structure is used to maintain the internal strings in REXX.
  43. * It includes the buffer area for the string and associated attributes.
  44. * This is actually a variable-length structure; it is allocated for a
  45. * specific length string, and the length is never modified thereafter
  46. * (since it's used for recycling).
  47. }
  48. Type
  49. pNexxStr = ^tNexxStr;
  50. tNexxStr = record
  51. ns_Ivalue : Longint; { integer value }
  52. ns_Length : Word; { length in bytes (excl null) }
  53. ns_Flags : Byte; { attribute flags }
  54. ns_Hash : Byte; { hash code }
  55. ns_Buff : Array [0..7] of Byte;
  56. { buffer area for strings }
  57. end; { size: 16 bytes (minimum) }
  58. Const
  59. NXADDLEN = 9; { offset plus null byte }
  60. { String attribute flag bit definitions }
  61. NSB_KEEP = 0; { permanent string? }
  62. NSB_STRING = 1; { string form valid? }
  63. NSB_NOTNUM = 2; { non-numeric? }
  64. NSB_NUMBER = 3; { a valid number? }
  65. NSB_BINARY = 4; { integer value saved? }
  66. NSB_FLOAT = 5; { floating point format? }
  67. NSB_EXT = 6; { an external string? }
  68. NSB_SOURCE = 7; { part of the program source? }
  69. { The flag form of the string attributes }
  70. NSF_KEEP = 1;
  71. NSF_STRING = 2;
  72. NSF_NOTNUM = 4;
  73. NSF_NUMBER = 8;
  74. NSF_BINARY = 16;
  75. NSF_FLOAT = 32;
  76. NSF_EXT = 64;
  77. NSF_SOURCE = 128;
  78. { Combinations of flags }
  79. NSF_INTNUM = NSF_NUMBER + NSF_BINARY + NSF_STRING;
  80. NSF_DPNUM = NSF_NUMBER + NSF_FLOAT;
  81. NSF_ALPHA = NSF_NOTNUM + NSF_STRING;
  82. NSF_OWNED = NSF_SOURCE + NSF_EXT + NSF_KEEP;
  83. KEEPSTR = NSF_STRING + NSF_SOURCE + NSF_NOTNUM;
  84. KEEPNUM = NSF_STRING + NSF_SOURCE + NSF_NUMBER + NSF_BINARY;
  85. { The RexxArg structure is identical to the NexxStr structure, but
  86. * is allocated from system memory rather than from internal storage.
  87. * This structure is used for passing arguments to external programs.
  88. * It is usually passed as an "argstring", a pointer to the string buffer.
  89. }
  90. Type
  91. pRexxArg = ^tRexxArg;
  92. tRexxArg = record
  93. ra_Size : Longint; { total allocated length }
  94. ra_Length : Word; { length of string }
  95. ra_Flags : Byte; { attribute flags }
  96. ra_Hash : Byte; { hash code }
  97. ra_Buff : Array [0..7] of Byte;
  98. { buffer area }
  99. end; { size: 16 bytes (minimum) }
  100. { The RexxMsg structure is used for all communications with REXX
  101. * programs. It is an EXEC message with a parameter block appended.
  102. }
  103. pRexxMsg = ^tRexxMsg;
  104. tRexxMsg = record
  105. rm_Node : tMessage; { EXEC message structure }
  106. rm_TaskBlock : Pointer; { global structure (private) }
  107. rm_LibBase : Pointer; { library base (private) }
  108. rm_Action : Longint; { command (action) code }
  109. rm_Result1 : Longint; { primary result (return code) }
  110. rm_Result2 : Longint; { secondary result }
  111. rm_Args : Array [0..15] of STRPTR;
  112. { argument block (ARG0-ARG15) }
  113. rm_PassPort : pMsgPort; { forwarding port }
  114. rm_CommAddr : STRPTR; { host address (port name) }
  115. rm_FileExt : STRPTR; { file extension }
  116. rm_Stdin : Longint; { input stream (filehandle) }
  117. rm_Stdout : Longint; { output stream (filehandle) }
  118. rm_avail : Longint; { future expansion }
  119. end; { size: 128 bytes }
  120. Const
  121. MAXRMARG = 15; { maximum arguments }
  122. { Command (action) codes for message packets }
  123. RXCOMM = $01000000; { a command-level invocation }
  124. RXFUNC = $02000000; { a function call }
  125. RXCLOSE = $03000000; { close the REXX server }
  126. RXQUERY = $04000000; { query for information }
  127. RXADDFH = $07000000; { add a function host }
  128. RXADDLIB = $08000000; { add a function library }
  129. RXREMLIB = $09000000; { remove a function library }
  130. RXADDCON = $0A000000; { add/update a ClipList string }
  131. RXREMCON = $0B000000; { remove a ClipList string }
  132. RXTCOPN = $0C000000; { open the trace console }
  133. RXTCCLS = $0D000000; { close the trace console }
  134. { Command modifier flag bits }
  135. RXFB_NOIO = 16; { suppress I/O inheritance? }
  136. RXFB_RESULT = 17; { result string expected? }
  137. RXFB_STRING = 18; { program is a "string file"? }
  138. RXFB_TOKEN = 19; { tokenize the command line? }
  139. RXFB_NONRET = 20; { a "no-return" message? }
  140. { The flag form of the command modifiers }
  141. RXFF_NOIO = $00010000;
  142. RXFF_RESULT = $00020000;
  143. RXFF_STRING = $00040000;
  144. RXFF_TOKEN = $00080000;
  145. RXFF_NONRET = $00100000;
  146. RXCODEMASK = $FF000000;
  147. RXARGMASK = $0000000F;
  148. { The RexxRsrc structure is used to manage global resources. Each node
  149. * has a name string created as a RexxArg structure, and the total size
  150. * of the node is saved in the "rr_Size" field. The REXX systems library
  151. * provides functions to allocate and release resource nodes. If special
  152. * deletion operations are required, an offset and base can be provided in
  153. * "rr_Func" and "rr_Base", respectively. This "autodelete" function will
  154. * be called with the base in register A6 and the node in A0.
  155. }
  156. Type
  157. pRexxRsrc = ^tRexxRsrc;
  158. tRexxRsrc = record
  159. rr_Node : tNode;
  160. rr_Func : smallint; { "auto-delete" offset }
  161. rr_Base : Pointer; { "auto-delete" base }
  162. rr_Size : Longint; { total size of node }
  163. rr_Arg1 : Longint; { available ... }
  164. rr_Arg2 : Longint; { available ... }
  165. end; { size: 32 bytes }
  166. Const
  167. { Resource node types }
  168. RRT_ANY = 0; { any node type ... }
  169. RRT_LIB = 1; { a function library }
  170. RRT_PORT = 2; { a public port }
  171. RRT_FILE = 3; { a file IoBuff }
  172. RRT_HOST = 4; { a function host }
  173. RRT_CLIP = 5; { a Clip List node }
  174. { The RexxTask structure holds the fields used by REXX to communicate with
  175. * external processes, including the client task. It includes the global
  176. * data structure (and the base environment). The structure is passed to
  177. * the newly-created task in its "wake-up" message.
  178. }
  179. GLOBALSZ = 200; { total size of GlobalData }
  180. Type
  181. pRexxTask = ^tRexxTask;
  182. tRexxTask = record
  183. rt_Global : Array [0..GLOBALSZ-1] of Byte;
  184. { global data structure }
  185. rt_MsgPort : tMsgPort; { global message port }
  186. rt_Flags : Byte; { task flag bits }
  187. rt_SigBit : Shortint; { signal bit }
  188. rt_ClientID : Pointer; { the client's task ID }
  189. rt_MsgPkt : Pointer; { the packet being processed }
  190. rt_TaskID : Pointer; { our task ID }
  191. rt_RexxPort : Pointer; { the REXX public port }
  192. rt_ErrTrap : Pointer; { Error trap address }
  193. rt_StackPtr : Pointer; { stack pointer for traps }
  194. rt_Header1 : tList; { Environment list }
  195. rt_Header2 : tList; { Memory freelist }
  196. rt_Header3 : tList; { Memory allocation list }
  197. rt_Header4 : tList; { Files list }
  198. rt_Header5 : tList; { Message Ports List }
  199. end;
  200. Const
  201. { Definitions for RexxTask flag bits }
  202. RTFB_TRACE = 0; { external trace flag }
  203. RTFB_HALT = 1; { external halt flag }
  204. RTFB_SUSP = 2; { suspend task? }
  205. RTFB_TCUSE = 3; { trace console in use? }
  206. RTFB_WAIT = 6; { waiting for reply? }
  207. RTFB_CLOSE = 7; { task completed? }
  208. { Definitions for memory allocation constants }
  209. MEMQUANT = 16; { quantum of memory space }
  210. MEMMASK = $FFFFFFF0; { mask for rounding the size }
  211. MEMQUICK = 1; { EXEC flags: MEMF_PUBLIC }
  212. MEMCLEAR = $00010000; { EXEC flags: MEMF_CLEAR }
  213. { The SrcNode is a temporary structure used to hold values destined for
  214. * a segment array. It is also used to maintain the memory freelist.
  215. }
  216. Type
  217. pSrcNode = ^tSrcNode;
  218. tSrcNode = record
  219. sn_Succ : pSrcNode; { next node }
  220. sn_Pred : pSrcNode; { previous node }
  221. sn_Ptr : Pointer; { pointer value }
  222. sn_Size : Longint; { size of object }
  223. end; { size: 16 bytes }
  224. { === rexx/rexxio.h ====================================================
  225. *
  226. * Copyright (c) 1986, 1987 by William S. Hawes. All Rights Reserved.
  227. *
  228. * ======================================================================
  229. * Header file for ARexx Input/Output related structures
  230. }
  231. Const
  232. RXBUFFSZ = 204; { buffer length }
  233. {
  234. * The IoBuff is a resource node used to maintain the File List. Nodes
  235. * are allocated and linked into the list whenever a file is opened.
  236. }
  237. Type
  238. pIoBuff = ^tIoBuff;
  239. tIoBuff = record
  240. iobNode : tRexxRsrc; { structure for files/strings }
  241. iobRpt : Pointer; { read/write pointer }
  242. iobRct : Longint; { character count }
  243. iobDFH : Longint; { DOS filehandle }
  244. iobLock : Longint; { DOS lock }
  245. iobBct : Longint; { buffer length }
  246. iobArea : Array [0..RXBUFFSZ-1] of Byte;
  247. { buffer area }
  248. end; { size: 256 bytes }
  249. Const
  250. { Access mode definitions }
  251. RXIO_EXIST = -1; { an external filehandle }
  252. RXIO_STRF = 0; { a "string file" }
  253. RXIO_READ = 1; { read-only access }
  254. RXIO_WRITE = 2; { write mode }
  255. RXIO_APPEND = 3; { append mode (existing file) }
  256. {
  257. * Offset anchors for SeekF()
  258. }
  259. RXIO_BEGIN = -1; { relative to start }
  260. RXIO_CURR = 0; { relative to current position }
  261. RXIO_END = 1; { relative to end }
  262. {
  263. * A message port structure, maintained as a resource node. The ReplyList
  264. * holds packets that have been received but haven't been replied.
  265. }
  266. Type
  267. pRexxMsgPort = ^tRexxMsgPort;
  268. tRexxMsgPort = record
  269. rmp_Node : tRexxRsrc; { linkage node }
  270. rmp_Port : tMsgPort; { the message port }
  271. rmp_ReplyList : tList; { messages awaiting reply }
  272. end;
  273. Const
  274. {
  275. * DOS Device types
  276. }
  277. DT_DEV = 0; { a device }
  278. DT_DIR = 1; { an ASSIGNed directory }
  279. DT_VOL = 2; { a volume }
  280. {
  281. * Private DOS packet types
  282. }
  283. ACTION_STACK = 2002; { stack a line }
  284. ACTION_QUEUE = 2003; { queue a line }
  285. { === rexx/rxslib.h ===================================================
  286. *
  287. * Copyright (c) 1986, 1987, 1989 by William S. Hawes (All Rights Reserved)
  288. *
  289. * =====================================================================
  290. * The header file for the REXX Systems Library
  291. }
  292. { Some macro definitions }
  293. Const
  294. RXSNAME : PChar = 'rexxsyslib.library';
  295. RXSID : PChar = 'rexxsyslib 1.06 (07 MAR 88)';
  296. RXSDIR : PChar = 'REXX';
  297. RXSTNAME : PChar = 'ARexx';
  298. { The REXX systems library structure. This should be considered as }
  299. { semi-private and read-only, except for documented exceptions. }
  300. Type
  301. pRxsLib = ^tRxsLib;
  302. tRxsLib = record
  303. rl_Node : tLibrary; { EXEC library node }
  304. rl_Flags : Byte; { global flags }
  305. rl_pad : Byte;
  306. rl_SysBase : Pointer; { EXEC library base }
  307. rl_DOSBase : Pointer; { DOS library base }
  308. rl_IeeeDPBase : Pointer; { IEEE DP math library base }
  309. rl_SegList : Longint; { library seglist }
  310. rl_NIL : Longint; { global NIL: filehandle }
  311. rl_Chunk : Longint; { allocation quantum }
  312. rl_MaxNest : Longint; { maximum expression nesting }
  313. rl_NULL : pNexxStr; { static string: NULL }
  314. rl_FALSE : pNexxStr; { static string: FALSE }
  315. rl_TRUE : pNexxStr; { static string: TRUE }
  316. rl_REXX : pNexxStr; { static string: REXX }
  317. rl_COMMAND : pNexxStr; { static string: COMMAND }
  318. rl_STDIN : pNexxStr; { static string: STDIN }
  319. rl_STDOUT : pNexxStr; { static string: STDOUT }
  320. rl_STDERR : pNexxStr; { static string: STDERR }
  321. rl_Version : STRPTR; { version/configuration string }
  322. rl_TaskName : STRPTR; { name string for tasks }
  323. rl_TaskPri : Longint; { starting priority }
  324. rl_TaskSeg : Longint; { startup seglist }
  325. rl_StackSize : Longint; { stack size }
  326. rl_RexxDir : STRPTR; { REXX directory }
  327. rl_CTABLE : STRPTR; { character attribute table }
  328. rl_Notice : STRPTR; { copyright notice }
  329. rl_RexxPort : tMsgPort; { REXX public port }
  330. rl_ReadLock : Word; { lock count }
  331. rl_TraceFH : Longint; { global trace console }
  332. rl_TaskList : tList; { REXX task list }
  333. rl_NumTask : smallint; { task count }
  334. rl_LibList : tList; { Library List header }
  335. rl_NumLib : smallint; { library count }
  336. rl_ClipList : tList; { ClipList header }
  337. rl_NumClip : smallint; { clip node count }
  338. rl_MsgList : tList; { pending messages }
  339. rl_NumMsg : smallint; { pending count }
  340. rl_PgmList : tList; { cached programs }
  341. rl_NumPgm : smallint; { program count }
  342. rl_TraceCnt : Word; { usage count for trace console }
  343. rl_avail : smallint;
  344. end;
  345. Const
  346. { Global flag bit definitions for RexxMaster }
  347. RLFB_TRACE = RTFB_TRACE; { interactive tracing? }
  348. RLFB_HALT = RTFB_HALT; { halt execution? }
  349. RLFB_SUSP = RTFB_SUSP; { suspend execution? }
  350. RLFB_STOP = 6; { deny further invocations }
  351. RLFB_CLOSE = 7; { close the master }
  352. RLFMASK = 1 + 2 + 4;
  353. { Initialization constants }
  354. RXSVERS = 34; { main version }
  355. RXSREV = 7; { revision }
  356. RXSALLOC = $800000; { maximum allocation }
  357. RXSCHUNK = 1024; { allocation quantum }
  358. RXSNEST = 32; { expression nesting limit }
  359. RXSTPRI = 0; { task priority }
  360. RXSSTACK = 4096; { stack size }
  361. RXSLISTH = 5; { number of list headers }
  362. { Character attribute flag bits used in REXX. }
  363. CTB_SPACE = 0; { white space characters }
  364. CTB_DIGIT = 1; { decimal digits 0-9 }
  365. CTB_ALPHA = 2; { alphabetic characters }
  366. CTB_REXXSYM = 3; { REXX symbol characters }
  367. CTB_REXXOPR = 4; { REXX operator characters }
  368. CTB_REXXSPC = 5; { REXX special symbols }
  369. CTB_UPPER = 6; { UPPERCASE alphabetic }
  370. CTB_LOWER = 7; { lowercase alphabetic }
  371. { Attribute flags }
  372. CTF_SPACE = 1;
  373. CTF_DIGIT = 2;
  374. CTF_ALPHA = 4;
  375. CTF_REXXSYM = 8;
  376. CTF_REXXOPR = 16;
  377. CTF_REXXSPC = 32;
  378. CTF_UPPER = 64;
  379. CTF_LOWER = 128;
  380. VAR RexxSysBase : pLibrary;
  381. const
  382. REXXSYSLIBNAME : PChar = 'rexxsyslib.library';
  383. PROCEDURE ClearRexxMsg(msgptr : pRexxMsg; count : ULONG);
  384. FUNCTION CreateArgstring(const argstring : pCHAR; length : ULONG) : pCHAR;
  385. FUNCTION CreateRexxMsg(const port : pMsgPort;const extension : pCHAR; host : pCHAR) : pRexxMsg;
  386. PROCEDURE DeleteArgstring(argstring : pCHAR);
  387. PROCEDURE DeleteRexxMsg(packet : pRexxMsg);
  388. FUNCTION FillRexxMsg(msgptr : pRexxMsg; count : ULONG; mask : ULONG) : BOOLEAN;
  389. FUNCTION IsRexxMsg(const msgptr : pRexxMsg) : BOOLEAN;
  390. FUNCTION LengthArgstring(const argstring : pCHAR) : ULONG;
  391. PROCEDURE LockRexxBase(resource : ULONG);
  392. PROCEDURE UnlockRexxBase(resource : ULONG);
  393. FUNCTION CreateArgstring(const argstring : string; length : ULONG) : pCHAR;
  394. FUNCTION CreateRexxMsg(const port : pMsgPort;const extension : string; host : pCHAR) : pRexxMsg;
  395. FUNCTION CreateRexxMsg(const port : pMsgPort;const extension : pCHAR; host : string) : pRexxMsg;
  396. FUNCTION CreateRexxMsg(const port : pMsgPort;const extension : string; host : string) : pRexxMsg;
  397. PROCEDURE DeleteArgstring(argstring : string);
  398. FUNCTION LengthArgstring(const argstring : string) : ULONG;
  399. {Here we read how to compile this unit}
  400. {You can remove this include and use a define instead}
  401. {$I useautoopenlib.inc}
  402. {$ifdef use_init_openlib}
  403. procedure InitREXXSYSLIBLibrary;
  404. {$endif use_init_openlib}
  405. {This is a variable that knows how the unit is compiled}
  406. var
  407. REXXSYSLIBIsCompiledHow : longint;
  408. IMPLEMENTATION
  409. uses
  410. {$ifndef dont_use_openlib}
  411. msgbox,
  412. {$endif dont_use_openlib}
  413. pastoc;
  414. PROCEDURE ClearRexxMsg(msgptr : pRexxMsg; count : ULONG);
  415. BEGIN
  416. ASM
  417. MOVE.L A6,-(A7)
  418. MOVEA.L msgptr,A0
  419. MOVE.L count,D0
  420. MOVEA.L RexxSysBase,A6
  421. JSR -156(A6)
  422. MOVEA.L (A7)+,A6
  423. END;
  424. END;
  425. FUNCTION CreateArgstring(const argstring : pCHAR; length : ULONG) : pCHAR;
  426. BEGIN
  427. ASM
  428. MOVE.L A6,-(A7)
  429. MOVEA.L argstring,A0
  430. MOVE.L length,D0
  431. MOVEA.L RexxSysBase,A6
  432. JSR -126(A6)
  433. MOVEA.L (A7)+,A6
  434. MOVE.L D0,@RESULT
  435. END;
  436. END;
  437. FUNCTION CreateRexxMsg(const port : pMsgPort;const extension : pCHAR; host : pCHAR) : pRexxMsg;
  438. BEGIN
  439. ASM
  440. MOVE.L A6,-(A7)
  441. MOVEA.L port,A0
  442. MOVEA.L extension,A1
  443. MOVE.L host,D0
  444. MOVEA.L RexxSysBase,A6
  445. JSR -144(A6)
  446. MOVEA.L (A7)+,A6
  447. MOVE.L D0,@RESULT
  448. END;
  449. END;
  450. PROCEDURE DeleteArgstring(argstring : pCHAR);
  451. BEGIN
  452. ASM
  453. MOVE.L A6,-(A7)
  454. MOVEA.L argstring,A0
  455. MOVEA.L RexxSysBase,A6
  456. JSR -132(A6)
  457. MOVEA.L (A7)+,A6
  458. END;
  459. END;
  460. PROCEDURE DeleteRexxMsg(packet : pRexxMsg);
  461. BEGIN
  462. ASM
  463. MOVE.L A6,-(A7)
  464. MOVEA.L packet,A0
  465. MOVEA.L RexxSysBase,A6
  466. JSR -150(A6)
  467. MOVEA.L (A7)+,A6
  468. END;
  469. END;
  470. FUNCTION FillRexxMsg(msgptr : pRexxMsg; count : ULONG; mask : ULONG) : BOOLEAN;
  471. BEGIN
  472. ASM
  473. MOVE.L A6,-(A7)
  474. MOVEA.L msgptr,A0
  475. MOVE.L count,D0
  476. MOVE.L mask,D1
  477. MOVEA.L RexxSysBase,A6
  478. JSR -162(A6)
  479. MOVEA.L (A7)+,A6
  480. TST.W D0
  481. BEQ.B @end
  482. MOVEQ #1,D0
  483. @end: MOVE.B D0,@RESULT
  484. END;
  485. END;
  486. FUNCTION IsRexxMsg(const msgptr : pRexxMsg) : BOOLEAN;
  487. BEGIN
  488. ASM
  489. MOVE.L A6,-(A7)
  490. MOVEA.L msgptr,A0
  491. MOVEA.L RexxSysBase,A6
  492. JSR -168(A6)
  493. MOVEA.L (A7)+,A6
  494. TST.W D0
  495. BEQ.B @end
  496. MOVEQ #1,D0
  497. @end: MOVE.B D0,@RESULT
  498. END;
  499. END;
  500. FUNCTION LengthArgstring(const argstring : pCHAR) : ULONG;
  501. BEGIN
  502. ASM
  503. MOVE.L A6,-(A7)
  504. MOVEA.L argstring,A0
  505. MOVEA.L RexxSysBase,A6
  506. JSR -138(A6)
  507. MOVEA.L (A7)+,A6
  508. MOVE.L D0,@RESULT
  509. END;
  510. END;
  511. PROCEDURE LockRexxBase(resource : ULONG);
  512. BEGIN
  513. ASM
  514. MOVE.L A6,-(A7)
  515. MOVE.L resource,D0
  516. MOVEA.L RexxSysBase,A6
  517. JSR -450(A6)
  518. MOVEA.L (A7)+,A6
  519. END;
  520. END;
  521. PROCEDURE UnlockRexxBase(resource : ULONG);
  522. BEGIN
  523. ASM
  524. MOVE.L A6,-(A7)
  525. MOVE.L resource,D0
  526. MOVEA.L RexxSysBase,A6
  527. JSR -456(A6)
  528. MOVEA.L (A7)+,A6
  529. END;
  530. END;
  531. FUNCTION CreateArgstring(const argstring : string; length : ULONG) : pCHAR;
  532. begin
  533. CreateArgstring := CreateArgstring(pas2c(argstring),length);
  534. end;
  535. FUNCTION CreateRexxMsg(const port : pMsgPort;const extension : string; host : pCHAR) : pRexxMsg;
  536. begin
  537. CreateRexxMsg := CreateRexxMsg(port,pas2c(extension),host);
  538. end;
  539. FUNCTION CreateRexxMsg(const port : pMsgPort;const extension : pCHAR; host : string) : pRexxMsg;
  540. begin
  541. CreateRexxMsg := CreateRexxMsg(port,extension,pas2c(host));
  542. end;
  543. FUNCTION CreateRexxMsg(const port : pMsgPort;const extension : string; host : string) : pRexxMsg;
  544. begin
  545. CreateRexxMsg := CreateRexxMsg(port,pas2c(extension),pas2c(host));
  546. end;
  547. PROCEDURE DeleteArgstring(argstring : string);
  548. begin
  549. DeleteArgstring(pas2c(argstring));
  550. end;
  551. FUNCTION LengthArgstring(const argstring : string) : ULONG;
  552. begin
  553. LengthArgstring := LengthArgstring(pas2c(argstring));
  554. end;
  555. const
  556. { Change VERSION and LIBVERSION to proper values }
  557. VERSION : string[2] = '0';
  558. LIBVERSION : longword = 0;
  559. {$ifdef use_init_openlib}
  560. {$Info Compiling initopening of rexxsyslib.library}
  561. {$Info don't forget to use InitREXXSYSLIBLibrary in the beginning of your program}
  562. var
  563. rexxsyslib_exit : Pointer;
  564. procedure CloserexxsyslibLibrary;
  565. begin
  566. ExitProc := rexxsyslib_exit;
  567. if RexxSysBase <> nil then begin
  568. CloseLibrary(RexxSysBase);
  569. RexxSysBase := nil;
  570. end;
  571. end;
  572. procedure InitREXXSYSLIBLibrary;
  573. begin
  574. RexxSysBase := nil;
  575. RexxSysBase := OpenLibrary(REXXSYSLIBNAME,LIBVERSION);
  576. if RexxSysBase <> nil then begin
  577. rexxsyslib_exit := ExitProc;
  578. ExitProc := @CloserexxsyslibLibrary;
  579. end else begin
  580. MessageBox('FPC Pascal Error',
  581. 'Can''t open rexxsyslib.library version ' + VERSION + #10 +
  582. 'Deallocating resources and closing down',
  583. 'Oops');
  584. halt(20);
  585. end;
  586. end;
  587. begin
  588. REXXSYSLIBIsCompiledHow := 2;
  589. {$endif use_init_openlib}
  590. {$ifdef use_auto_openlib}
  591. {$Info Compiling autoopening of rexxsyslib.library}
  592. var
  593. rexxsyslib_exit : Pointer;
  594. procedure CloserexxsyslibLibrary;
  595. begin
  596. ExitProc := rexxsyslib_exit;
  597. if RexxSysBase <> nil then begin
  598. CloseLibrary(RexxSysBase);
  599. RexxSysBase := nil;
  600. end;
  601. end;
  602. begin
  603. RexxSysBase := nil;
  604. RexxSysBase := OpenLibrary(REXXSYSLIBNAME,LIBVERSION);
  605. if RexxSysBase <> nil then begin
  606. rexxsyslib_exit := ExitProc;
  607. ExitProc := @CloserexxsyslibLibrary;
  608. REXXSYSLIBIsCompiledHow := 1;
  609. end else begin
  610. MessageBox('FPC Pascal Error',
  611. 'Can''t open rexxsyslib.library version ' + VERSION + #10 +
  612. 'Deallocating resources and closing down',
  613. 'Oops');
  614. halt(20);
  615. end;
  616. {$endif use_auto_openlib}
  617. {$ifdef dont_use_openlib}
  618. begin
  619. REXXSYSLIBIsCompiledHow := 3;
  620. {$Warning No autoopening of rexxsyslib.library compiled}
  621. {$Warning Make sure you open rexxsyslib.library yourself}
  622. {$endif dont_use_openlib}
  623. END. (* UNIT REXXSYSLIB *)