home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mod201j.zip / modula2.exe / os2src / myrxdll.mod < prev    next >
Text File  |  1995-08-17  |  5KB  |  171 lines
  1. IMPLEMENTATION MODULE MyRxDLL;
  2.  
  3. (**************************************************************************
  4.   OS/2 2.x/Warp  Modula-2 sample REXX-DLL.
  5.  
  6.   Copyright (c) 1995 by Anthony Busigin. 
  7. **************************************************************************)
  8.  
  9.  
  10. (*$XL+*)
  11.  
  12. IMPORT Conversions, RealConversions, Strings, DOS;
  13.  
  14. FROM OS2DEF IMPORT APIRET;
  15.  
  16. FROM SYSTEM IMPORT ADDRESS, INLINE, ADR;
  17.  
  18. CONST
  19.   RXERROR = 40;
  20.   RXOK    = 0;
  21.   CR        = CHAR(0DH);
  22.  
  23. TYPE
  24.   SZCMD = ARRAY[0..30] OF CHAR;
  25.  
  26.  
  27. PROCEDURE IncAddr ( p : ADDRESS; n : LONGCARD ) : ADDRESS;
  28. BEGIN
  29.   INLINE
  30.   (
  31.   MOV     EAX, p[ EBP ]
  32.   ADD     EAX, n[ EBP ]
  33.   );
  34. END IncAddr;
  35.  
  36.  
  37. PROCEDURE ClipRange(x,xmin,xmax: LONGREAL): LONGREAL;
  38. BEGIN
  39.   IF x < xmin THEN
  40.     RETURN xmin;
  41.   ELSIF x > xmax THEN
  42.     RETURN xmax;
  43.   ELSE
  44.     RETURN x;
  45.   END;
  46. END ClipRange;
  47.  
  48.  
  49. PROCEDURE Caps( VAR sz : ARRAY OF CHAR );
  50. VAR
  51.   i, N : LONGCARD;
  52. BEGIN
  53.   N := Strings.Size( sz );
  54.   IF N > 0 THEN
  55.     FOR i := 0 TO N-1 DO
  56.       sz[i] := CAP( sz[i] );
  57.     END;
  58.   END;
  59. END Caps;
  60.  
  61.  
  62. (*$CDECL+*)
  63.  
  64. (*-------------------------------------------------------------------*)
  65. (* REXX procedure to call DosSleep function for a specfied duration  *)
  66. (* in milliseconds.                                                  *)
  67. (* Usage: CALL RxDelay 100                                           *)
  68. (*-------------------------------------------------------------------*)
  69. PROCEDURE RXDELAY  ( VAR func : ARRAY OF CHAR;
  70.                          argc : LONGCARD;
  71.                         pargv : PRXSTRING;
  72.                      VAR  que : ARRAY OF CHAR;
  73.                      VAR  ret : RXSTRING) : LONGCARD;
  74. VAR
  75.   ms : LONGCARD;
  76.   OK : BOOLEAN;
  77.   rc : APIRET;
  78. BEGIN
  79.   OK := Conversions.StrToLongCard(pargv^.strptr^,ms);
  80.   IF OK THEN
  81.     ret.strptr^ := "";
  82.     ret.strlen  := 0;
  83.     rc := DOS.DosSleep(ms);
  84.     RETURN RXOK;
  85.   END;
  86.   ret.strptr^ := "ERROR";
  87.   ret.strlen  := Strings.Size(ret.strptr^);
  88.   RETURN RXERROR;
  89. END RXDELAY;
  90.  
  91. (*-------------------------------------------------------------------*)
  92. (* REXX procedure to constrain a number within a specified range.    *)
  93. (* Usage: xclipped = RxClipRange( x, xmin, xmax )                    *)
  94. (*-------------------------------------------------------------------*)
  95. PROCEDURE RXCLIPRANGE ( VAR func : ARRAY OF CHAR;
  96.                             argc : LONGCARD;
  97.                            pargv : PRXSTRING;
  98.                         VAR que  : ARRAY OF CHAR;
  99.                         VAR ret  : RXSTRING) : LONGCARD;
  100. VAR
  101.   px, pmin, pmax     : PRXSTRING;
  102.   x,  xmin, xmax, z  : LONGREAL;
  103.   OK : BOOLEAN;
  104. BEGIN
  105.   IF argc # 3 THEN
  106.     ret.strptr^ := "ERROR: 3 arguments required for function RxClipRange().";
  107.     ret.strlen  := Strings.Size(ret.strptr^);
  108.     RETURN RXERROR;
  109.   ELSE
  110.     (* extract the function parameters *)
  111.     px   := pargv;
  112.     pmin := IncAddr(pargv,SIZE(pargv^));
  113.     pmax := IncAddr(pargv,2*SIZE(pargv^));
  114.     OK := RealConversions.StrToReal(px^.strptr^,x);
  115.     IF OK <> TRUE THEN
  116.       ret.strptr^ := "ERROR: function RxClipRange() 1st argument is not a valid number.";
  117.       ret.strlen  := Strings.Size(ret.strptr^);
  118.       RETURN RXERROR;
  119.     END;
  120.     OK := RealConversions.StrToReal(pmin^.strptr^,xmin);
  121.     IF OK <> TRUE THEN
  122.       ret.strptr^ := "ERROR: function RxClipRange() 2nd argument is not a valid number.";
  123.       ret.strlen  := Strings.Size(ret.strptr^);
  124.       RETURN RXERROR;
  125.     END;
  126.     OK := RealConversions.StrToReal(pmax^.strptr^,xmax);
  127.     IF OK <> TRUE THEN
  128.       ret.strptr^ := "ERROR: function RxClipRange() 3rd argument is not a valid number.";
  129.       ret.strlen  := Strings.Size(ret.strptr^);
  130.       RETURN RXERROR;
  131.     END;
  132.     z := ClipRange(x,xmin,xmax);
  133.     OK := RealConversions.RealToStr(z,-9,ret.strptr^);
  134.     ret.strlen  := Strings.Size(ret.strptr^);
  135.     RETURN RXOK;
  136.   END;
  137. END RXCLIPRANGE;
  138.  
  139.  
  140. (*-------------------------------------------------------------------*)
  141. (* REXX procedure to convert a string to upper case.                 *)
  142. (* Usage: s = RxUpperCase( "abHmL7" )                                *)
  143. (*        result is s = "ABHML7"                                     *)
  144. (*-------------------------------------------------------------------*)
  145. PROCEDURE RXUPPERCASE( VAR func : ARRAY OF CHAR;
  146.                            argc : LONGCARD;
  147.                           pargv : PRXSTRING;
  148.                        VAR que  : ARRAY OF CHAR;
  149.                        VAR ret  : RXSTRING) : LONGCARD;
  150. VAR
  151.   rc    : LONGCARD;
  152. BEGIN
  153.   rc := RXERROR;
  154.   ret.strlen := 0;
  155.   ret.strptr^ := 0C;
  156.  
  157.   IF argc = 1 THEN
  158.     ret.strptr^ := pargv^.strptr^;
  159.     Caps(ret.strptr^);
  160.     ret.strlen := pargv^.strlen;
  161.     rc := RXOK;
  162.   END;
  163.  
  164.   RETURN rc;
  165. END RXUPPERCASE;
  166.  
  167. (*$CDECL-*)
  168.  
  169. BEGIN
  170. END MyRxDLL.
  171.