home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Club Amiga de Montreal - CAM
/
CAM_CD_1.iso
/
files
/
310.lha
/
Rexx_4th
/
fancydemo.4th
< prev
next >
Wrap
Text File
|
1980-12-10
|
10KB
|
359 lines
\ /****************************************************************************
\ 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<<dos_reply_port->mp_SigBit) | (1L<<rexx_port->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