\ /**************************************************************************** \ fancydemo.4th -- converted from ..... \ fancydemo.c - A fancy rexx host that can send and receive messages. \ \ Author - Gary Samad & Bill Hawes \ \ Revisions: \ 7-Mar-88 Original version. \ 16-Mar-88 Added result string return (WSH) \ \ This is truly Public Domain!! \ \ Converted to CSI MultiForth 10/15/89 by Kerry Zimmerman [71470,1340] \ ****************************************************************************/ 10000 minimum.vocab 6000 minimum.object include" libraries/dos.f" include" libraries/dosextens.f" include" rexx/rexxcalls.4th" anew fancymark : createport() compile createport ; immediate : deleteport() compile deleteport ; immediate : putmsg() compile eputmsg ; immediate : getmsg() compile egetmsg ; immediate : ReplyMsg() compile ereplymsg ; immediate : Wait() compile eWait ; immediate : forbid() exec 22 ; : permit() exec 23 ; : findport() !A1 exec@ 65 ; 1 constant YES \ #define YES 1 0 constant NO \ #define NO 0 0 constant OK \ #define OK 0 1 constant NOTOK \ #define NOTOK 1 0 constant EOS \ #define EOS '\0' : NO_REXX_MSG ." Rexx is not active. Please run 'rexxmast' from another CLI." cr ; \ : STARTUP_MSG ." Type commands to rexx. Type EOF (^\) to end." cr ; : STARTUP_MSG 0" Type commands to rexx. Type EOF (^\) to end." ; : CLOSING_MSG ." Ok, we're closing (after all rexx messages have returned)." cr ; : WINDOW_SPEC 0" CON:0/10/600/60/Fancy Demo Input Window/c" ; : HOST_PORT_NAME 0" FancyDemo" ; : REXX_EXTENSION 0" rexx" ; : RXSDIR 0" REXX" ; 100 constant BUFFLEN \ #define BUFFLEN 100 global outstanding_rexx_commands 0 to outstanding_rexx_commands global window_file_handle 0 to window_file_handle global dos_reply_port 0 to dos_reply_port global dos_message 0 to dos_message global rexx_port 0 to rexx_port BUFFLEN 1 1array buff \ used for reading user input : close_window() ( file_handle -- ) Close ; : shutdown_rexx_port() ( rexx_port -- ) DeletePort() ; : shutdown_dos_reply_port() ( dos_reply_port -- ) DeletePort ; : free_dos_message() ( dos_message -- ) to.heap ; : close_up_shop() ( value -- ) window_file_handle ?dup if close_window() then dos_reply_port ?dup if shutdown_dos_reply_port() then rexx_port ?dup if shutdown_rexx_port() then dos_message ?dup if free_dos_message() then ( value ) ." exit value = " . cr abort ; \ /**** These are dos functions for getting and displaying user input ****/ : open_window() ( -- file_handle ) WINDOW_SPEC new.file dup to window_file_handle ; : setup_dos_reply_port() ( -- port ) NULL 0 CreatePort ; : setup_dos_message() ( -- new_packet ) 0 locals| new_packet | \ /* get a packet */ StandardPacket from.heap dup to new_packet if \ /* required AmigaDOS Kludge */ new_packet @ +spPkt new_packet @ +spMsg +mnNode +lnName ! new_packet @ +spMsg new_packet @ +spPkt +dpLink ! then new_packet ; : send_read_packet() ( dos_message\window_file_handle\dos_reply_port\buff -- ) 0 locals| ]file_handle ]buff ]dos_reply_port ]window_file_handle ]dos_message | \ /* change a BPTR to a REAL pointer */ ]window_file_handle 2 scale to ]file_handle \ /* setup the packet for reading */ ]file_handle +fhArgs @ ]dos_message +spPkt +dpArg1 ! ]buff ]dos_message +spPkt +dpArg2 ! BUFFLEN ]dos_message +spPkt +dpArg3 ! ACTION_READ ]dos_message +spPkt +dpType ! ]dos_reply_port ]dos_message +spPkt +dpPort ! ]dos_reply_port ]dos_message +spMsg +mnReplyPort ! \ /* now send it */ ]file_handle +fhType @ ]dos_message PutMsg() ; \ /******** This is the REXX stuff ********/ : setup_rexx_port() ( -- the_port ) locals| the_port | Forbid() \ /* look for someone else that looks just like us! */ HOST_PORT_NAME FindPort() if Permit() ." A public port called " HOST_PORT_NAME dup 0$len type ." already exists!" cr 0 to the_port else \ /* allocate the port */ HOST_PORT_NAME 0 CreatePort() to the_port Permit() then the_port ; : send_rexx_command() ( buff -- result ) 0 0 locals| rexx_command_message rexxport buff | \ /* lock things temporarily */ Forbid() \ /* if rexx is not active, just return NOTOK */ RXSDIR FindPort() dup to rexxport 0= if Permit() NOTOK exit then \ /* allocate a message packet for our command */ \ /* note that this is a very important call. Much flexibility is */ \ /* available to you here by using multiple host port names, etc. */ rexx_port REXX_EXTENSION rexx_port +mpNode +lnName @ CreateRexxMsg dup to rexx_command_message 0= if Permit() NOTOK exit then \ /* create an argument string and install it in the message */ buff dup strlen CreateArgstring dup rexx_command_message +rm_Args ! 0= if DeleteRexxMsg Permit() NOTOK exit then \ /* tell rexx that this is a COMMAND, not a FUNCTION, etc. */ RXCOMM rexx_command_message +rm_Action ! \ /* and now the EASY part! */ rexxport rexx_command_message PutMsg() \ /* keep a count of outstanding messages for graceful cleanup */ outstanding_rexx_commands 1+ to outstanding_rexx_commands \ /* we're done hogging */ Permit() \ /* successful, finally... */ OK ; : free_rexx_command() ( rexxmessage -- ) \ /* delete the argument that we originally sent */ dup ( rexxmessage ) +rm_Args @ DeleteArgstring \ /* delete the extended message */ DeleteRexxMsg \ /* decrement the count of outstanding messages */ outstanding_rexx_commands 1- to outstanding_rexx_commands ; \ /* Replies a REXX message, filling in the appropriate codes. If the macro \ * program has requested a result string, the return argstring is allocated \ * and installed in the rm_Result2 slot. \ * \ * A result is returned ONLY IF REQUESTED AND THE PRIMARY RESULT == 0. \ */ : reply_rexx_command() ( rexxmessage\primary\secondary\result -- ) locals| result secondary primary rexxmessage | \ /* set an error code */ primary 0= rexxmessage +rm_Action @ 1 RXFB_RESULT scale and and if result if result dup strlen CreateArgString else 0 then to secondary then primary rexxmessage +rm_Result1 ! secondary rexxmessage +rm_Result2 ! rexxmessage ReplyMsg() ; : execute_command() ( rexxmessage -- ) 0 0 locals| primary secondary rexxmessage | ." got " rexxmessage +rm_Args @ dup 0$len type ." from rexx" cr rexxmessage +rm_Args @ 0" BAD" 3 StrcmpN 0= if 10 to primary then rexxmessage primary secondary 0" A Test" reply_rexx_command() ; : main NO 0 NO locals| packet_out rexxmessage close_down | \ /* open a window to talk to the user through */ open_window() 0= if ." sorry, couldn't open a CON: window" cr 10 close_up_shop() then \ /* set up a port for dos replys */ setup_dos_reply_port() dup to dos_reply_port 0= if ." sorry, couldn't set up a dos_reply_port" cr 11 close_up_shop() then \ /* set up a public port for rexx to talk to us later */ setup_rexx_port() dup to rexx_port 0= if ." sorry, couldn't set up our public rexx port" cr 12 close_up_shop() then \ /* set up a dos packet for the asynchronous read from the window */ setup_dos_message() dup to dos_message 0= if ." sorry, not enough memory for a dos packet" cr 13 close_up_shop() then \ /* write instructions to user in the input window */ STARTUP_MSG dup strlen window_file_handle write CRLF 1+ 1 window_file_handle write \ /* loop until quit and no messages outstanding */ begin close_down NO = outstanding_rexx_commands or while \ /* if the packet (for user input) has not been sent out, send it */ packet_out NO = close_down NO = and if \ /* send a packet to dos asking for user keyboard input */ dos_message @ window_file_handle dos_reply_port 0 buff send_read_packet() YES to packet_out then \ /* now wait for something to come from the user or from rexx */ \ Wait((1L<mp_SigBit) | (1L<mp_SigBit)); 1 dos_reply_port +mpSigBit c@ scale 1 rexx_port +mpSigBit c@ scale or Wait() \ /* got something!! */ \ /* is it a command from the user? */ dos_reply_port Getmsg() if \ /* not out any more */ NO to packet_out \ /* if EOF (either the close gadget was hit or ^\) */ dos_message @ +spPkt +dpRes1 @ 0= if YES to close_down CLOSING_MSG else \ /* NULL terminate the string (thanks again DOS!) */ EOS dos_message @ +spPkt +dpRes1 @ 1- buff c! \ /* send the command directly to rexx */ 0 buff send_rexx_command() OK = NOT if NO_REXX_MSG then then then \ /* did we get something from rexx? */ begin rexx_port GetMsg() dup to rexxmessage while \ /* is this a reply to a previous message? */ rexxmessage +rm_Node +mnNode +lnType c@ NT_REPLYMSG = if ." the command " rexxmessage +rm_Args @ dup 0$len type ." has terminated with code " rexxmessage +rm_Result1 @ . ." , " rexxmessage +rm_Result2 @ . cr rexxmessage free_rexx_command() else \ /* a rexx macro has sent us a command, deal with it */ \ /* THE MESSAGE WILL HAVE BEEN REPLIED INSIDE OF execute_command */ rexxmessage execute_command() then repeat \ while get rexxmessage repeat \ while (!close_down || outstanding_rexx_commands) \ /* clean up */ 0 close_up_shop() ; : cleanup 0 close_up_shop() ; openrexxlib drop ." done compiling" cr cr ." enter MAIN to begin" cr abort