1 /* ******************************************************
  2    *                                                    *
  3    *                                                    *
  4    * Copyright (c) 1972 by Massachusetts Institute of   *
  5    * Technology and Honeywell Information Systems, Inc. *
  6    *                                                    *
  7    *                                                    *
  8    ****************************************************** */
  9 
 10 decam:    dcm:      procedure;
 11 
 12 /*        "Desk Calculator with Memory"           */
 13 /*        Transcribed from the CTSS MAD version,  */
 14 /*        J. H. Saltzer, May, 1969.               */
 15 
 16 
 17 declare   buffer    character(40) init("Go
 18 "),
 19           status    bit(72) aligned,
 20           char      character(1),
 21           digno     fixed,
 22           eof       bit(1),
 23           int       fixed binary(35),
 24           intlist   character(20)       internal  static    initial("0123456789abcdefghij"),
 25           k         fixed binary(35),
 26           length    fixed,
 27           lhs       fixed binary(35),
 28           lnct      fixed,
 29           nl        character(1)        internal  static    initial("
 30 "),                                                                   /*  New line character literal.  */
 31           op        character(1),
 32           reg(0:10) fixed binary(35),
 33           reglist   character(8)        internal  static    initial("stuvwxyz"),
 34           rhs       fixed binary(35),
 35           rlength   fixed bin,
 36           scan      entry               internal,
 37           size      fixed,
 38           temp      fixed binary(35);
 39 
 40 declare   ios_$write_ptr ext entry(ptr,fixed bin,fixed bin),
 41           ios_$read_ptr ext entry(ptr,fixed bin,fixed bin),
 42           ios_$resetread ext entry(char(*),bit(72) aligned),
 43           com_err_ ext entry options(variable);
 44 
 45 
 46 
 47 /*  . . . Program . . . . . . . . . . . . . . . . . . . */
 48 
 49           reg(0) = 0;                             /*  Initialize automatic variable.  */
 50           reg(1) = 10;                            /*  Initial value for radix.  */
 51           call ios_$write_ptr(addr(buffer),0,3);
 52 
 53 rdlp:     call ios_$read_ptr(addr(buffer),40,rlength);
 54           length = rlength - 1;                   /*  "length" does not include carriage return.  */
 55           lnct = 0;
 56           eof = "0"b;
 57 
 58 /*        Evaluate left hand side of input.  */
 59 
 60           call scan;
 61           if eof then go to rdlp;                 /*  Ignore blank line.  */
 62           lhs = index(reglist, char);
 63           if lhs > 0 then call scan;
 64           if eof then go to err;                  /*  Complain about ill-constructed line.  */
 65 
 66 /*        Save operator.      */
 67 
 68           op = char;
 69 
 70 /*        Evaluate right hand side of input       */
 71 
 72           call scan;
 73           if eof then rhs = reg(0);
 74                     else do;  rhs = index(reglist, char);   /*  rhs temporarily contains lvalue.  */
 75                               if rhs = 0 then do while (^eof);        /*  Non-register, evaluate literal.  */
 76                                         int = index(substr(intlist, 1, reg(1)), char) - 1;
 77                                         if int = -1 then go to err;
 78                                         rhs = rhs*reg(1) + int;
 79                                         call scan;
 80                                         end;
 81                               else rhs = reg(rhs);                    /*  now rhs contains rvalue.  */
 82                               end;
 83 
 84 /*        Perform requested operation.  */
 85 
 86           if op = "+"
 87                     then reg(0) = reg(lhs) + rhs;
 88           else if op = "-"
 89                     then reg(0) = reg(lhs) - rhs;
 90           else if op = "/"
 91                     then if rhs = 0 then do;
 92 div_err:                      call com_err_(0,"decam","I can't divide by zero.");
 93                               call ios_$resetread("user_input",status);
 94                               go to rdlp;
 95                               end;
 96                     else reg(0) = divide(reg(lhs), rhs, 35, 0);
 97           else if op = "%"
 98                     then if reg(lhs) = 0 then go to div_err;
 99                     else reg(0) = divide(rhs, reg(lhs), 35, 0);
100           else if op = "*"
101                     then reg(0) = reg(lhs) * rhs;
102           else if op = "="
103                     then do;
104                     if lhs = 1 then if (rhs<2) | (rhs>20) then do;
105                               call com_err_(0,"decam","Radix out of range.");
106                               call ios_$resetread("user_input",status);
107                               go to rdlp;
108                               end;
109                     reg(lhs) = rhs;               /*  Perform storage requested.  */
110                     end;
111           else if op = "p"
112                     then go to print;
113           else if op = "q"
114                     then return;                  /*  Quit request, return to command level.  */
115           else do;
116 err:                call com_err_(0,"decam","Illegal request ^a",substr(buffer,1,rlength));
117                     call ios_$resetread("user_input",status);
118                     end;
119           go to rdlp;
120 
121 print:    k = abs(rhs);
122           buffer = nl;
123           do size = 0 by 1 while ((k>0)|(size=0));
124                     temp = divide(k,reg(1), 35, 0);
125                     digno = k-temp*reg(1) + 1;                        /*  Compute which digit wanted.  */
126                     buffer = substr(intlist,digno,1)||buffer;         /*  Pick output digit.  */
127                     k = temp;
128                     end;
129           if rhs < 0 then do; buffer = "-"||buffer;
130                               size = size + 1;
131                               end;
132           substr(buffer,size+2,1) = "
133 ";
134           call ios_$write_ptr(addr(buffer),0,size+2);
135           go to rdlp;
136 
137 
138 /*        "scan" is an internal subroutine which pushes the
139           index "lnct" to the next non-blank character in the input
140           line, or sets "eof" if the end of line is reached.          */
141 
142 scan:     procedure;
143 scnlp:    if lnct >= length then do;
144                     eof = "1"b;
145                     return;
146                     end;
147           lnct = lnct + 1;
148           char = substr(buffer,lnct,1);
149           if char = " " then go to scnlp;         /*  Skip over all blanks.  */
150           end scan;
151 end dcm;