%begin   ;! pilot
%include "sysinc:command.inc"

%integer exclam = COMMAND_modifier;               !Command line modifier (0,'!','?')
%string(31)%name  in file == COMMAND_in1;   ! First input stream
%record %format file (%string(127) name, %integer chan,
                 %integer top, lim, vmtop, vmlim, flag)
%shortinteger lines, answerok, reply length, fatal error, %c
             optl, optu, opts, optg, opte, optw, accepted, expval, experr, %c
            labels, i, j, k, lastaccept, source lines, subrentries, jump
%integer ptr,first,last
%constinteger maxchars=40000
%integer chr

%string(6) goto destn
%string(6) %array label(1:200)
%shortintegerarray labpt(1:200)
%byteintegerarray reply(1:160)
%externalbytemapspec byte integer (%integer n)
%record(file) f=0;            !TEXT mapped on DA file
%byte %map text (%integer N)
   %result == byte integer (f_top + N)
%end
%integerarray line(1:1000)

%routine upper case(%integername ch)
   ch=ch - 'a' + 'A' %if 'a' <= ch <= 'z'
%end

%routine lower case(%integername ch)
   ch = ch - 'A' + 'a' %if 'A' <= ch <= 'Z'
%end

%routine get line;  ! of Pilot program
%shortinteger opcode
   %routine get label
   %shortinteger i
      labels=labels+1
      label(labels)= ""
      i=0
      read symbol(chr); upper case(chr)
      %if 'A' <= chr <= 'Z' %start
         %while ('A' <= chr <= 'Z' %or '0' <= chr <= '9') %and i<6 %cycle
            i=i+1
            label(labels)=label(labels).tostring(chr)
            read symbol(chr); upper case(chr)
         %repeat
         %if chr # ' ' %and chr # nl %start
            print string("warning - label more than 6 chrs long")
            newline; print string(label(labels))
            %cycle
               read symbol(chr); upper case(chr); print symbol(chr)
            %repeat %until chr = ' ' %or chr = nl
            spaces(2); print string("at line"); write(lines,4); newline
         %finish
         labpt(labels) = lines
         source lines=source lines + 1 %if chr = nl
      %else
         fatal error = 1
         print string("error in label definition at line")
         write(source lines,4); newline
         %cycle
            upper case(chr); print symbol(chr); read symbol(chr)
         %repeat  %until chr = ' ' %or chr = nl
         newline
      %finish
      %cycle
         read symbol(chr) 
         source lines=source lines+1 %if chr=nl
         %exit %if chr # nl %and chr # ' '
      %repeat
%end; !of get label

%routine get opcode
%constshortinteger codes = 12, mods = 8
%constbyteintegerarray modcon(1:8)='H','J','S','X','Y','N','E','C'
%constbyteintegerarray code(1:12)='R','T','A','M','J','U','E','C',
                                        'X','F','D','P'
%integer i, pt2
   upper case(chr)
   %if chr = ':' %start
      %if text(line(lines-1)) = 'T' %start
         i=0; pt2=line(lines-1)
         %cycle
            text(ptr)=text(pt2)
            ptr=ptr+1; pt2=pt2+1
         %repeat  %until text(pt2) = ':'
      %else
         print string("op-code missing at line")
         write(source lines,5); newline
         fatal error = 1
      %finish
   %else
      %for i=1,1,codes %cycle
         %if chr = code(i) %then opcode=chr %and -> codeok
      %repeat
      print string("op-code error"); spaces(2)
      print symbol(chr); newline
      print string("at line"); write(source lines,5); newline
      fatal error = 1
      read symbol(chr) %until chr=':' %or chr = nl
      %return
codeok:  text(ptr) = chr
      %if chr = 'P' %start
         %if  next symbol = 'R' %start
            ptr = ptr + 1
            read symbol(chr); upper case(chr)
            text(ptr) = chr
         %else
            print string("no R after opcode P at line ")
            write(source lines,4); newline
            fatal error = 1
         %finish
      %finish
       ptr=ptr+1
      read symbol(chr) %until chr # ' '
      %return %if chr = ':' %or chr = nl
      %cycle
         -> modok %if '0'<= chr <= '9'
         %for i=1,1,mods %cycle
         upper case(chr)
         %if chr = modcon(i) %start
            %if (i=1 %and text(ptr-1)#'T') %or (2<=i<=4 %and    %c
                        text(ptr-1) # 'M') %start
               fatal error = 1
               print string("illegal modifier  "); print symbol(chr)
               print string("  with op-code  ")
               print symbol(text(ptr-1)); newline
            %else
               -> modok
            %finish
         %finish
         %repeat
         %if chr = '(' %start
            text(ptr) = chr; ptr = ptr + 1
            %cycle
               read symbol(chr); upper case(chr); text(ptr) = chr
               ptr = ptr + 1 
            %repeat  %until chr = ')'
         %else
            print string("illegal modifier  "); print symbol(chr)
            print string("  in line "); write(source lines,5); newline
         %finish
modok:  text(ptr) = chr; ptr = ptr + 1
         read symbol(chr) %until chr # ' '
      %repeat  %until chr = ':' %or chr = nl
   %finish
%end; ! leaves chr as : or nl

   ptr = line(lines)
   %if next symbol = nl %start  ;! skip blank line
      read symbol(chr)
      source lines = source lines + 1
      %return
   %finish
   read symbol(chr) %until chr # ' '
   get label %while chr = '*'
   get opcode
   %if chr # ':' %start
      print string("colon missing from line ");
      write(source lines,5); newline
      fatal error = 1
   %finish
! move rest of line into text array
   %while chr # nl %cycle
      text(ptr) = chr
      read symbol(chr)
      ptr = ptr + 1
   %repeat
   lines=lines + 1
   source lines = source lines +1
   line(lines) = ptr
%end; ! of get line

%routine load text
   %on %event 9 %start
       %return
   %finish
   %cycle
      get line
   %repeat
%end

%routine wrapup
   %external %routine %spec close off (%record(file)%name f)
   close off (f)
   select output(1)
   print string("Finish time "); print string(time); newline
   close output
   %stop
%end

%routine match(%shortinteger matchparm)
%shortinteger oksofar,windows,errors,textsep, %c
               replyptr,frame,textlength,reply offset
%integer firstext, lastext, nextext, textptr, i, j, k, chr, chr2
%integerarray rerrpt(1:2),terrpt(1:2)
   oksofar = 0; textptr = first; reply offset = 0; replyptr=1
   %cycle
      first=first + 1 %while text(first)=' '
      firstext=first
      %if text(firstext) = '%' %then frame=2 %else frame = 0
      %for j=first,1,last %cycle
         %exit %if text(j)='!' %or text(j)='&' %or j=last
      %repeat
      %if j=last %start
         lastext = j
         textsep=' '
      %else
         lastext=j-1
         textsep=text(j)
      %finish
      first = j + 1
      textlength = lastext - firstext + 1
      windows = reply length -textlength +1 +frame - reply offset
      %if windows < 1 %then oksofar = 0 %and -> nexsep
      %for i= 1, 1, windows %cycle
         errors = 0; replyptr = i + reply offset; textptr = firstext
         %while textptr <= lastext %cycle
            %if text(firstext) = '%' %start
               textptr=textptr + 1
               %if i # 1 %and reply(i) # ' ' %then -> nexwindow
               %if i # 1 %then replyptr=replyptr + 1
            %finish
            chr=text(textptr)
            upper case(chr) %if optu = 1
            lower case(chr) %if optl = 1
            %if reply(replyptr) # chr %and chr # '*' %start
               errors=errors + 1
               %if errors > 2 %then -> nexwindow
               rerrpt(errors) = replyptr
               terrpt(errors) = textptr
            %finish
            textptr = textptr + 1; replyptr = replyptr + 1
         %repeat
         %if errors = 0 %then oksofar = 1 %and -> nexsep
         %if matchparm # 'S' %then -> nexwindow
         %if errors = 1 %then oksofar = 1 %and -> nexsep
         %if rerrpt(1)+1 # rerrpt(2) %then -> nexwindow
         chr=text(terrpt(1)); chr2=text(terrpt(2))
         upper case(chr) %and upper case(chr2) %if optu = 1
         lower case(chr) %and lower case(chr2) %if optl = 1
         %if reply(rerrpt(1)) # chr2 %or  %c
            reply(rerrpt(2)) # chr %then -> nexwindow
         oksofar = 1; -> nexsep
   nexwindow:
      %repeat
   nexsep:
      answerok = oksofar %and %return %if lastext = last
      answerok=1 %and %return %if oksofar=1 %and textsep='!'
      %if textsep = '&' %start
         %if oksofar = 0 %start
            textptr=textptr+1 %until text(textptr)='!' %or %c
                                       textptr=last
            %if textptr=last %then answerok=0 %and %return
            first=textptr+1
            replyptr = 1; reply offset = 0
         %else
            reply offset = replyptr - 1
            oksofar=0
         %finish
      %finish
   %repeat
%end


%routine scan(%shortinteger firstline)
%shortinteger count,opcode,matchparm,replyparm,lineno,subrline
%integer i,j,k,lineptr
%string (6) label destn; %byteintegerarray modcon(1:10)

%routine get symbol(%integername ch)
   read symbol(ch) ; print symbol(ch)
%end

%routine find label(%shortintegername lineno)
%shortinteger i
   %for i=1,1,labels %cycle
      lineno = labpt(i) %and %return %if label(i) = label destn
   %repeat
   print string("missing label - "); print string(label destn)
   newline
   %stop
%end

%routine get reply(%shortinteger replyparm)
%shortinteger i,j,lastch; %integer ch
%constshortintegerarray goto(1:4)='G','O','T','O'

%routine cue response
%integer pt,pt1,pt2,l
   select output(1)
   %for l=lineno-2,1,lineno-1 %cycle
      pt1 = line(l)
      pt2 = line(l+1) - 1
      print symbol(text(pt)) %for pt = pt1,1,pt2
      newline
   %repeat
   write(lineno,4); newline
%end

   cue response

start:     i=0; lastch=0; goto destn=""
   %if replyparm = 'X' %start
      %cycle
         get symbol(ch)
         i = i + 1
         reply (i) = ch
      %repeat  %until ch = nl
      reply length = i
      -> count reply
   %finish
   get symbol(ch) %until ch # ' '
   %while ch # nl %cycle
      -> next %if ch = ' ' %and lastch = ' '
      -> next %if ch = ' ' %and opts = 1
      upper case(ch) %if optu = 1
      lower case(ch) %if optl = 1
      lastch = ch
      i = i +1
      reply(i) = ch
next: get symbol(ch)
   %repeat
   reply length = i
   %if i<=1 %then -> countreply
 %if reply(i-1) = ' ' %then reply length = i-1 
countreply: 
      %if reply length = 0 %then -> start
      %if optg=1 %start
         j=1
         %for i=1,1,reply length %cycle
            %continue %if reply(i)=' '
            ch=reply(i); upper case(ch)
            %exit %if ch # goto(j)
            j=j + 1
            %exit %if j=5
         %repeat
         %if j = 5 %start
            %for i=j,1,reply length %cycle
               %continue %if reply(i)=' '
               ch=reply(i); upper case(ch)
               goto destn=goto destn.tostring(ch)
               %exit %if length(goto destn)=6
            %repeat
            %if goto destn = "FINISH" %then wrapup
         %finish
      %finish
      %if lineno = lastaccept %start
               accepted = accepted + 1
            %else
               lastaccept = lineno
               accepted = 1
            %finish
   select output(0)
%end; ! of get reply

%routine get exprn
   lineptr = lineptr + 1 %until text(lineptr) = ')'
   print string("expression evaluation not yet implemented")
   newline
   expval = 0; experr = 0
%end

%routine set options
   %shortinteger option
   optu=0; optl=0; opts=0; optg=0; optw=0; opte=0
   lineptr = lineptr + 1 %while text(lineptr) # ':'
   %while lineptr < last %cycle
      lineptr = lineptr + 1
      %continue %if text(lineptr) = ' '
      option = text(lineptr)
      optu = 1 %and %continue %if option = 'U'
      optl = 1 %and %continue %if option = 'L'
      opts = 1 %and %continue %if option = 'S'
      optg = 1 %and %continue %if option = 'G'
      optw = 1 %and %continue %if option = 'W'
      opte = 1 %and %continue %if option = 'E'
   %repeat
%end

   lineno = firstline; opcode = ' '; experr = 0; expval = 0
   %cycle; ! process one line of text
      lineptr = line(lineno); last = line(lineno+1) - 1
      opcode = text(lineptr)
      lineptr = lineptr + 1
!**********************************************
      %if opcode = 'R' %then -> nexline
!***********************************************
      %if opcode = 'P' %then set options %and -> nexline
!************************************************
      %for i= 1,1,10 %cycle
         j = text(lineptr)
         %exit %if j= ':'
         %if j = '(' %then get exprn %else modcon(i) = j
         lineptr = lineptr + 1
      %repeat
      count = i-1
      %if count > 0 %start
         %for i= 1,1,count %cycle
            j = modcon(i)
            %continue %if j = 'Y' %and answerok = 1
            %continue %if j = 'N' %and answerok = 0
            %if '0' <= j <= '9' %start
               k=j-'0'
               %continue %if accepted = k 
            %finish
            %continue %if j ='C' %and expval = 1 
            %continue %if j ='E' %and experr = 1 
            %continue %if j = 'S' %or j = 'J'
            -> nexline
         %repeat
      %finish
         i = lineptr +1; label destn = ""
         i = i + 1 %until text(i) # ' '
         j = 0
         %cycle
            chr=text(i); upper case(chr)
            label destn = label destn.tostring(chr)
            i = i + 1
            j = j + 1
            %exit %if j = 6
         %repeat %until text(i) = ' ' %or i > last
      ! label destn contains label if there is one
      %return %if opcode = 'E'
!**************************************************
      %if opcode = 'U' %start
         find label(subrline)
         subrentries = subrentries + 1
         scan(subrline)
         subrentries = subrentries - 1
         -> setjump %if jump=1 %and subrentries = 0
         -> nexline
      %finish
      first = lineptr + 1
!*************************************************
      %if opcode = 'T' %start
         select output(0)
          print symbol(text(i)) %for i=first,1,last 
          newline
      %finish
!**************************************************
      %if opcode = 'M' %start
         matchparm= ' '; j = 0
         %for i = 1,1,count %cycle
            matchparm = 'S' %and %exit %if modcon(i) = 'S'
            j = 1 %if modcon(i) = 'J'
         %repeat
         match(matchparm)
         %if answerok = 0 %and j = 1 %start
            lineno = lineno + 1 %until Text(line(lineno)) = 'M'
            %continue
         %finish
      %finish
!**********************************************
      %if opcode = 'A' %start
         replyparm = ' '
         %for i= 1,1,count %cycle
            replyparm = 'X' %and %exit %if modcon(i) = 'X'
         %repeat
         get reply(replyparm)
         %if goto destn # "" %start
            jump = 1
            %return %if subrentries > 0
setjump:    label destn=goto destn
            opcode='J'
            accepted = 0
            jump = 0
         %finish
      %finish
!**********************************************************
      %if opcode = 'J' %start
         i=first
         i = i +1 %while text(i) = ' '
         %if text(i) = '@' %start
            i = i + 1
            %if text(i) = 'A' %then j = -1 %else j = 1
            k = text(i)
            lineno = lineno + j %until text(line(lineno)) = k
         %else
            find label(lineno)
         %finish
         %continue
      %finish
nexline:  lineno = lineno + 1
   %repeat; ! processing of text line completed
%end

   print string ("Loading " . in file . " -- please wait")
   newline
   f_name = "";  f_flag = 100;  !Scratch file + 100 scratch blocks
   %external %routine %spec connect input (%record(file)%name f)
   connect input (f)
   prompt ("?")
   %if exclam = 0 %start;            !No command modifier -- student user
      open output (1,"LP:Answers")
   %else;                            !program invoked by:  PILOT fred!
      open output (1,"Null:");       !(suppress the gungy listing)
   %finish
   select output(1)
   print string("Start time "); print string(time); newline
   select output(0)
   select input(1)
   source lines=1
   subrentries = 0
   lines=1; line(lines)=1; labels=0; fatal error=0
   jump = 0
   load text
   close input
   %if fatal error = 1 %start
      print string("fatal error(s) - run aborted"); newline
      %stop
   %finish
   lines = 1
   select input(0)
   scan(lines)
   wrapup
%endofprogram
