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_ ;