1 /****^ *********************************************************** 2 * * 3 * Copyright, (C) Honeywell Bull Inc., 1988 * 4 * * 5 * Copyright, (C) Honeywell Information Systems Inc., 1982 * 6 * * 7 * Copyright (c) 1972 by Massachusetts Institute of * 8 * Technology and Honeywell Information Systems, Inc. * 9 * * 10 *********************************************************** */ 11 12 13 14 /****^ HISTORY COMMENTS: 15 1) change(86-09-03,Oke), approve(86-09-03,MCR7543), audit(86-09-30,JRGray), 16 install(86-10-08,MR12.0-1180): 17 Extend octal input 18 processing to permit 1 or 2 word values. Double precision is selected 19 if an "L" suffix is supplied. Previously >12 digits wasg an F error, 20 now an "F" error is >12 digits if single, >24 digits if double. Permits 21 double-word octal literals and constants to be generated. 22 END HISTORY COMMENTS */ 23 24 octevl_: 25 procedure( rslts ) returns ( fixed bin(17) ); 26 27 /* OCTEVL: evaluates octal literal field and returns results and brk. */ 28 /* octevl returns one word if no "L" suffix, two words if "L" suffix */ 29 /* supplied. Modifier done by litevl. */ 30 /* note that according to bsa conventions, no negative sign is */ 31 /* allowed in octal fields, and fields may be separated by */ 32 /* commas followed by blanks. */ 33 34 /* Last modified by Nate Adleman on June 28, 1970 at 2104 for the new CODTAB */ 35 36 /* INCLUDE FILES USED BY OCTEVL */ 37 38 % include varcom; 39 % include erflgs; 40 % include codtab; 41 42 /* AUTOMATIC DATA USED BY OCTEVL */ 43 44 declare double bit (1); 45 declare nochrs fixed bin(17) ; 46 dcl rslts(2) fixed bin (35); 47 dcl num bit (72) aligned; 48 dcl num_array (2) fixed bin (35) unaligned based (addr (num)); 49 /* EXTERNAL ENTRIES CALLED BY OCTEVL */ 50 51 declare inputs_$next ext entry, 52 inputs_$nxtnb ext entry ; 53 54 55 /* EXTERNAL FUNCTIONS USED BY OCTEVL */ 56 57 declare utils_$and ext entry (fixed bin(26), fixed bin(26)) returns (fixed bin(26)) ; 58 59 60 /*^L*/ 61 /* - - - - - - - - - PROGRAM STARTS HERE - - - - - - - - */ 62 63 /* setup num and get next character */ 64 65 label_100: 66 double = ""b; 67 num = "0"b; 68 nochrs = 0; 69 call inputs_$nxtnb; 70 71 /* conversion loop. */ 72 73 label_110: 74 if (brk(1) ^= inum) then go to label_150; 75 76 /* check to see that only octal digits are in the expression */ 77 /* by seeing if the digit is greater than 7 */ 78 /* 55 is 067 octal which is the ascii character 7 */ 79 80 if brk(2) > 55 then prnt7 = 1; /*TRUE*/ 81 82 /* now check to see that there are no more than 12 characters */ 83 /* in the expression */ 84 85 nochrs = nochrs + 1; 86 if nochrs > 24 then prntf = 1; /*TRUE*/ 87 num = substr (num, 4, 69) || bit (fixed (brk(2)-48, 3)); 88 call inputs_$next; 89 go to label_110; 90 91 /* set results and return to caller. */ 92 93 label_150: 94 if byte(brk(2)) = "L" then do; 95 double = "1"b; 96 call inputs_$next; 97 end; 98 if ^double then do; 99 if nochrs > 12 then prntf = 1; /*TRUE*/ 100 rslts(1) = num_array (2); 101 return(1); 102 end; 103 104 /* return two words. */ 105 106 rslts(1) = num_array (1); 107 rslts(2) = num_array (2); 108 return (2); 109 end octevl_ ;