############################################################################
#
#	Name:	calc.icn
#
#	Title:	Desk calculator
#
#	Author:	Ralph E. Griswold
#
#	Date:	February 22, 1990
#
############################################################################
#
#  This is a simple Polish "desk calculator".  It accepts as values Icon
#  integers, reals, csets, and strings (as they would appear in an Icon
#  program). Other lines of input are interpreted as operations. These
#  may be Icon operators, functions, or the special instructions listed
#  below.
#
#  In the case of operator symbols, such as +, that correspond to both unary
#  and binary operations, the binary one is used.  Thus, the unary operation
#  is not available.
#
#  In case of Icon functions like write() that take an arbitrary number of
#  arguments, one argument is used.
#
#  The special instructions are:
#
#	clear	remove all values from the calculator's stack
#	dump	write out the contents of the stack
#	print	print the top value on the stack, but do not remove it
#	quit	exit the calculator
#
#  Example: the input lines
#
#	"abc"
#	3
#	repl
#	print
#
#  prints "abcabcabc" and leaves this the only value on the stack.
#
#  Failure and most errors are detected, but in these case, arguments are
#  consumed and not restored to the stack.
#
############################################################################

global stack

procedure main()
   local line, p, n, arglist

   stack := []

   while line := read() do {
      push(stack,value(line)) | {	# if it's a value, push it
         case line of {	# else check special operations
            "clear":   {stack := []; next}
            "dump":    {every write(image(!stack)); next}
            "print":   {write(image(stack[1])); next}
            "quit":    exit()
            }      
         if p := proc(line,3 | 2 | 1) then {	# check for procedure
            n := abs(args(p))
            arglist := []
            every 1 to n do
               push(arglist,pop(stack)) | {
                  write(&errout,"*** not enough arguments ***")
                  break next
                  }
            &error := 1	# anticipate possible error
            push(stack,p!arglist) | {
               if &error = 0 then {
                  write(&errout,"*** error performing ",line)
                  }
               else write(&errout,"*** failure performing ",line)
               }
            }
         else write(&errout,"*** invalid input: ",line)
         }
      }
end

#  Check input to see if it's a value
#
procedure value(s)
   local n

   if n := numeric(s) then return n
   else {
      s ? {
         if ="\"" & s := tab(-1) & ="\"" then return escape(s)
         else if ="'" & s := tab(-1) & ="'" then return cset(escape(s))
         else fail
         }
      }
end

#  Handling escape sequences is no fun
#
procedure escape(s)
   local ns, c

   ns := ""
   s ? {
      while ns ||:= tab(upto('\\')) do {
         move(1)
         ns ||:= case c := map(move(1 | 0)) of {	# can be either case
            "b":  "\b"
            "d":  "\d"
            "e":  "\e"
            "f":  "\f"
            "l":  "\n"
            "n":  "\n"
            "r":  "\r"
            "t":  "\t"
            "v":  "\v"
            "'":  "'"
            "\"":  "\""
            "x":  hexcode()
            "^":  ctrlcode()
            !"01234567":  octcode()
            default:  c
            }
         }
      ns ||:= tab(0)
      }
   return ns
end

procedure hexcode()
   local i, s
   static cdigs
   initial cdigs := ~'0123456789ABCDEFabcdef'
   
   move(i := 2 | 1) ? s := tab(upto(cdigs) | 0)
   move(*s - i)
   return char("16r" || s)
end

procedure octcode()
   local i, s
   static cdigs
   initial cdigs := ~'01234567'
   
   move(-1)
   move(i := 3 | 2 | 1) ? s := tab(upto(cdigs) | 0)
   move(*s - i)
   if s > 377 then {	# back off if too large
      s := s[1:3]
      move(-1)
      }
   return char("8r" || s)
end

procedure ctrlcode(s)
   return char(upto(map(move(1)),&lcase))
end