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 >
Encoding:
FORTH Source  |  1980-12-10  |  10.0 KB  |  359 lines
  1. \ /****************************************************************************
  2. \    fancydemo.4th   -- converted from .....
  3. \    fancydemo.c - A fancy rexx host that can send and receive messages.
  4. \ 
  5. \    Author - Gary Samad & Bill Hawes
  6. \ 
  7. \    Revisions:
  8. \       7-Mar-88   Original version.
  9. \      16-Mar-88   Added result string return (WSH)
  10. \ 
  11. \    This is truly Public Domain!!
  12. \
  13. \ Converted to CSI MultiForth 10/15/89 by Kerry Zimmerman [71470,1340]
  14. \ ****************************************************************************/
  15. 10000 minimum.vocab
  16. 6000  minimum.object
  17.  
  18. include" libraries/dos.f"
  19. include" libraries/dosextens.f"
  20. include" rexx/rexxcalls.4th"
  21.  
  22. anew fancymark
  23.  
  24. : createport()   compile createport  ; immediate
  25. : deleteport()   compile deleteport  ; immediate
  26. : putmsg()       compile eputmsg     ; immediate
  27. : getmsg()       compile egetmsg     ; immediate
  28. : ReplyMsg()     compile ereplymsg   ; immediate
  29. : Wait()         compile eWait       ; immediate
  30. : forbid()         exec 22 ;
  31. : permit()         exec 23 ;
  32. : findport()     !A1  exec@ 65 ;
  33.  
  34. 1 constant YES \ #define YES      1
  35. 0 constant NO  \ #define NO      0
  36.  
  37. 0 constant OK  \ #define OK      0
  38. 1 constant NOTOK \ #define NOTOK      1
  39.  
  40. 0 constant EOS  \ #define EOS      '\0'
  41.  
  42. : NO_REXX_MSG   
  43.   ." Rexx is not active.  Please run 'rexxmast' from another CLI." cr ;
  44.   
  45. \ : STARTUP_MSG   ." Type commands to rexx.  Type EOF (^\) to end." cr ;
  46. : STARTUP_MSG   0" Type commands to rexx.  Type EOF (^\) to end." ;
  47.  
  48. : CLOSING_MSG   
  49.     ." Ok, we're closing (after all rexx messages have returned)." cr ;
  50.  
  51. : WINDOW_SPEC   0" CON:0/10/600/60/Fancy Demo Input Window/c" ;
  52.  
  53. : HOST_PORT_NAME   0" FancyDemo" ;
  54.  
  55. : REXX_EXTENSION   0" rexx" ;
  56. : RXSDIR           0" REXX" ;
  57.  
  58. 100 constant BUFFLEN    \ #define BUFFLEN      100
  59.  
  60. global outstanding_rexx_commands  0 to outstanding_rexx_commands
  61.  
  62. global window_file_handle  0 to window_file_handle
  63. global dos_reply_port      0 to dos_reply_port
  64. global dos_message         0 to dos_message
  65. global rexx_port           0 to rexx_port
  66.  
  67. BUFFLEN 1 1array buff \ used for reading user input
  68.  
  69. : close_window()  ( file_handle -- )
  70.    Close
  71. ;
  72.  
  73. : shutdown_rexx_port() ( rexx_port -- )
  74.    DeletePort()
  75. ;
  76.  
  77. : shutdown_dos_reply_port()  ( dos_reply_port -- )
  78.    DeletePort
  79. ;
  80.  
  81. : free_dos_message() ( dos_message -- )
  82.    to.heap
  83. ;
  84.  
  85. : close_up_shop() ( value -- )
  86.    window_file_handle ?dup if  close_window()  then
  87.    dos_reply_port  ?dup if shutdown_dos_reply_port() then
  88.    rexx_port  ?dup if  shutdown_rexx_port()  then
  89.    dos_message  ?dup if  free_dos_message()  then
  90.    ( value )  ." exit value = " . cr abort
  91. ;
  92.  
  93. \ /**** These are dos functions for getting and displaying user input ****/
  94. : open_window()  ( -- file_handle )
  95.    WINDOW_SPEC  new.file dup to window_file_handle
  96. ;
  97.  
  98. : setup_dos_reply_port() ( -- port )
  99.    NULL 0 CreatePort
  100. ;
  101.  
  102. : setup_dos_message() ( -- new_packet )
  103.    0 locals| new_packet |
  104.  
  105.    \ /* get a packet */
  106.    StandardPacket from.heap  dup to new_packet  if
  107.      \ /* required AmigaDOS Kludge */
  108.      new_packet @ +spPkt   new_packet @ +spMsg +mnNode +lnName ! 
  109.      new_packet @ +spMsg   new_packet @ +spPkt +dpLink !
  110.    then
  111.  
  112.    new_packet
  113. ;
  114.  
  115. : send_read_packet() ( dos_message\window_file_handle\dos_reply_port\buff -- )
  116.   0
  117.   locals| ]file_handle ]buff ]dos_reply_port ]window_file_handle ]dos_message |
  118.  
  119.    \ /* change a BPTR to a REAL pointer */
  120.    ]window_file_handle  2 scale   to ]file_handle
  121.  
  122.    \ /* setup the packet for reading */
  123.    ]file_handle +fhArgs @   ]dos_message  +spPkt +dpArg1 !
  124.    ]buff                    ]dos_message  +spPkt +dpArg2 !
  125.    BUFFLEN                  ]dos_message  +spPkt +dpArg3 !
  126.    ACTION_READ              ]dos_message  +spPkt +dpType !
  127.    ]dos_reply_port          ]dos_message  +spPkt +dpPort !
  128.    ]dos_reply_port          ]dos_message  +spMsg +mnReplyPort !
  129.  
  130.    \ /* now send it */
  131.    ]file_handle +fhType @   ]dos_message   PutMsg()
  132. ;
  133.  
  134. \ /******** This is the REXX stuff ********/
  135. : setup_rexx_port()  ( -- the_port )
  136.    locals|  the_port  | 
  137.  
  138.    Forbid()
  139.  
  140.    \ /* look for someone else that looks just like us! */
  141.    HOST_PORT_NAME  FindPort()  if
  142.      Permit()
  143.      ." A public port called " 
  144.      HOST_PORT_NAME dup 0$len type 
  145.      ."  already exists!" cr
  146.      0 to the_port
  147.    else
  148.         \ /* allocate the port */
  149.         HOST_PORT_NAME  0  CreatePort()  to the_port
  150.         Permit()
  151.    then
  152.      
  153.    the_port
  154. ;
  155.  
  156. : send_rexx_command()  ( buff -- result )
  157.    0 0 locals|   rexx_command_message  rexxport buff  |
  158.  
  159.    \ /* lock things temporarily */
  160.    Forbid()
  161.  
  162.    \ /* if rexx is not active, just return NOTOK */
  163.    RXSDIR FindPort()  dup to rexxport  0= if
  164.      Permit()
  165.      NOTOK exit
  166.    then
  167.  
  168.    \ /* allocate a message packet for our command */
  169.    \ /* note that this is a very important call.  Much flexibility is */
  170.    \ /* available to you here by using multiple host port names, etc. */
  171.    rexx_port REXX_EXTENSION rexx_port +mpNode +lnName @  CreateRexxMsg
  172.    dup to rexx_command_message  0= if
  173.      Permit()
  174.      NOTOK exit
  175.    then
  176.  
  177.    \ /* create an argument string and install it in the message */
  178.    buff dup strlen  CreateArgstring  dup   rexx_command_message +rm_Args !
  179.    0= if
  180.      DeleteRexxMsg
  181.      Permit()
  182.      NOTOK exit
  183.    then
  184.  
  185.    \ /* tell rexx that this is a COMMAND, not a FUNCTION, etc. */
  186.    RXCOMM   rexx_command_message +rm_Action !
  187.  
  188.    \ /* and now the EASY part! */
  189.    rexxport rexx_command_message   PutMsg()
  190.  
  191.    \ /* keep a count of outstanding messages for graceful cleanup */
  192.    outstanding_rexx_commands  1+  to outstanding_rexx_commands
  193.  
  194.    \ /* we're done hogging */
  195.    Permit()
  196.    
  197.    \ /* successful, finally... */
  198.    OK
  199. ;
  200.  
  201. : free_rexx_command()  ( rexxmessage -- )
  202.    \ /* delete the argument that we originally sent */
  203.    dup ( rexxmessage ) +rm_Args @  DeleteArgstring
  204.  
  205.    \ /* delete the extended message */
  206.    DeleteRexxMsg
  207.  
  208.    \ /* decrement the count of outstanding messages */
  209.    outstanding_rexx_commands 1-  to outstanding_rexx_commands
  210. ;
  211.  
  212. \ /* Replies a REXX message, filling in the appropriate codes.  If the macro
  213. \  * program has requested a result string, the return argstring is allocated
  214. \  * and installed in the rm_Result2 slot.
  215. \  *
  216. \  * A result is returned ONLY IF REQUESTED AND THE PRIMARY RESULT == 0.
  217. \  */
  218.  
  219. : reply_rexx_command()   ( rexxmessage\primary\secondary\result -- )
  220.     locals| result secondary primary rexxmessage |
  221.    
  222.    \ /* set an error code */
  223.    primary 0=     
  224.    rexxmessage +rm_Action @  1 RXFB_RESULT scale   and
  225.    and if
  226.       result if
  227.         result dup strlen CreateArgString
  228.       else
  229.         0
  230.       then
  231.       to secondary
  232.    then
  233.    
  234.    primary    rexxmessage +rm_Result1 !
  235.    secondary  rexxmessage +rm_Result2 !
  236.    
  237.    rexxmessage  ReplyMsg()
  238. ;
  239.  
  240. : execute_command()   ( rexxmessage -- )
  241.    0 0 locals| primary secondary rexxmessage |
  242.  
  243.    ." got "
  244.    rexxmessage +rm_Args @  dup 0$len type
  245.    ."  from rexx" cr
  246.  
  247.    rexxmessage +rm_Args @  0" BAD" 3 StrcmpN 0= if
  248.      10 to primary
  249.    then
  250.  
  251.    rexxmessage primary secondary 0" A Test"  reply_rexx_command()
  252. ;
  253.  
  254. : main
  255.    NO 0 NO 
  256.    locals|  packet_out rexxmessage close_down  |
  257.  
  258.    \ /* open a window to talk to the user through */
  259.    open_window() 0= if
  260.      ." sorry, couldn't open a CON: window" cr
  261.      10 close_up_shop()
  262.    then
  263.  
  264.    \ /* set up a port for dos replys */
  265.    setup_dos_reply_port() dup to dos_reply_port   0= if
  266.      ." sorry, couldn't set up a dos_reply_port" cr
  267.      11 close_up_shop()
  268.    then
  269.    
  270.    \ /* set up a public port for rexx to talk to us later */
  271.    setup_rexx_port() dup to rexx_port   0= if
  272.      ." sorry, couldn't set up our public rexx port" cr
  273.      12 close_up_shop()
  274.    then
  275.    
  276.    \ /* set up a dos packet for the asynchronous read from the window */
  277.    setup_dos_message() dup to dos_message  0= if
  278.      ." sorry, not enough memory for a dos packet" cr
  279.      13 close_up_shop()
  280.    then
  281.    
  282.     \ /* write instructions to user in the input window */
  283.     STARTUP_MSG  dup strlen   window_file_handle  write
  284.     CRLF 1+           1       window_file_handle  write
  285.     
  286.    \ /* loop until quit and no messages outstanding */
  287.    begin
  288.      close_down NO =   outstanding_rexx_commands  or
  289.    while
  290.      
  291.      \ /* if the packet (for user input) has not been sent out, send it */
  292.      packet_out NO =  close_down NO =  and if
  293.        \ /* send a packet to dos asking for user keyboard input */
  294.        dos_message @ window_file_handle dos_reply_port 0 buff 
  295.           send_read_packet()
  296.        YES to packet_out
  297.      then
  298.      
  299.      \ /* now wait for something to come from the user or from rexx */
  300.      \ Wait((1L<<dos_reply_port->mp_SigBit) | (1L<<rexx_port->mp_SigBit));
  301.      1 dos_reply_port +mpSigBit c@ scale 
  302.      1 rexx_port      +mpSigBit c@ scale or  Wait()
  303.  
  304.      \ /* got something!! */
  305.      \ /* is it a command from the user? */
  306.      dos_reply_port  Getmsg() if
  307.        
  308.        \ /* not out any more */
  309.        NO to packet_out
  310.  
  311.        \ /* if EOF (either the close gadget was hit or ^\) */
  312.        dos_message @ +spPkt +dpRes1 @ 0= if
  313.          YES to close_down
  314.          CLOSING_MSG
  315.        else
  316.          \ /* NULL terminate the string (thanks again DOS!) */
  317.          EOS   dos_message @ +spPkt +dpRes1 @ 1- buff c!
  318.  
  319.          \ /* send the command directly to rexx */
  320.          0 buff send_rexx_command()  OK  = NOT if
  321.            NO_REXX_MSG
  322.          then
  323.        then
  324.      then
  325.  
  326.      \ /* did we get something from rexx? */
  327.      begin
  328.         rexx_port GetMsg() dup to rexxmessage
  329.      while
  330.  
  331.        \ /* is this a reply to a previous message? */
  332.        rexxmessage +rm_Node +mnNode +lnType c@  NT_REPLYMSG = if
  333.          ." the command "
  334.          rexxmessage +rm_Args @  dup 0$len type
  335.          ."  has terminated with code "
  336.          rexxmessage +rm_Result1 @ .
  337.          ." , "  rexxmessage +rm_Result2 @ .  cr
  338.          rexxmessage free_rexx_command()
  339.        else
  340.          
  341.          \ /* a rexx macro has sent us a command, deal with it */
  342.          \ /* THE MESSAGE WILL HAVE BEEN REPLIED INSIDE OF execute_command */
  343.          rexxmessage execute_command()
  344.        then
  345.      repeat \ while get rexxmessage
  346.    repeat \ while (!close_down || outstanding_rexx_commands)
  347.  
  348.    \ /* clean up */
  349.    0 close_up_shop()
  350. ;
  351.  
  352. : cleanup  0 close_up_shop() ;
  353.  
  354. openrexxlib drop
  355.  
  356. ." done compiling" cr cr
  357. ." enter  MAIN  to begin" cr
  358. abort
  359.