// S C A N   (PREPRESS)

//BCPL.Run/f Scan.bcpl

//Last modified February 28, 1980  12:48 PM (by LaPrade)
//  TypeForm now types carriage return without line feed.
//  Reverted to old definition (groan) of StrCop.
//  
//Last modified January 12, 1980  3:35 PM by Kerry A. LaPrade, XEOS
//  TypeForm handles chars in range 0-#377.
//  
//Modified November 8, 1979  12:09 PM (by LaPrade)

// ScanInit(b,file) (b= vec SCANIlen).  Sets up a scan
//	control block, using specified file to read from.
// ScanClose() Closes current file.
// ScanSet(b) (b = vec SCANIlen) use this file for scanner.
//	b is set up with ScanInit
//	Returns old pointer, if any, so you may restore.
// Scan() => token identifier (numbers defined in scan.defs)
// ScanFor(token) scans to be sure next thing is "token"
// ScanUntil(token) scans until token detected
//		(if token=RPAREN, must be at this "level")
// ScanBack(token) arranges to have next token be token
// ScanGiveID() returns pointer to string last scanned as ID.
// ScanCh()  returns a single character from the file.

// ReadNumber(STR) parses a number in STR format
//		result in FPAC 1; integer part is result of fcn
// PrintNumber(STR,num [,radix])
// PrintFloat(str,lvnum)	Prints floating point number.

// AppendChar(char, string) Appends char to string
// SearchChar(string, char) true if char appears in string
// StrEq(a,b) => true if two strings equal
// StrCop(f,t) copy STR f to STR t
// StringToValue(string, radix [10]) resultis (unsigned) value
// Type(STR)  type string on terminal
// TypeIn(STR)  get a string from the terminal, terminated by CR
// TypeForm(xxxxx)
//	Types a formatted message. For each entry in the call,
//	If it is not in the range 0-#377, type it as a string ptr.
//	Otherwise if it is:
//	0 -- type carriage-return
//	1 -- use the next entry as a string pointer to accept typein
//	2 -- print the next entry as a floating point number
//	3 -- Double precision (fixed,fraction)
//	4 -- Double integer
//	8,10 -- print the next entry as a number in corresonding
//		radix
//	default -- print it as a single character.

// ReadCom(str,sw) =res
//		Reads command file and returns true if more
//		there.  STR will contain string; sw if present
//		is a list of switches (sw!0= # of sw's)
// ReadComInit() starts it off


get "GoodFoo.d"
get "scan.dfs"
//get "streams.d"

// outgoing procedures
external
   [
   AppendChar
   PauseForCR
   PrintFloat
   PrintNumber
   ReadComInit
   ReadCom
   ReadNumber
   Scan
   ScanFor
   ScanUntil
   ScanInit
   ScanClose
   ScanSet
   ScanBack
   ScanGiveID
   ScanCh
   SearchChar
   StrCop
   StrEq
   StringToValue
   Type
   TypeForm
//   TypeIn
   ]

// outgoing statics
external
   [
   @outstream  //If non-zero, use for typing.
   @ScanSavedLetter
   ]

static
   [
   @outstream
   @ScanSavedLetter
   ]

// incoming procedures
external
   [
   Scream   //This is for reporting errors

//OS
//	Gets
//	Puts
//	Endofs
//	OpenFile
//	Closes
//	Wss
//	Zero

//FLOAT
	FLD;FST;FTR;FLDI;FNEG;FAD;FSB;FML;FDV;FCM;FSN
	FLDV;FSTV;FLDDP;FSTDP;DPAD;DPSB

//SDialog
//	DlgInit
//	DlgStr

//StringUtil
   CopyString
   StringCompare
   ]

// incoming statics
external
   [
   fpComCm
//	keys
//	dsp
   ]

// internal statics
static
   [
   @coms
   @sc
   ]

// File-wide structure and manifest declarations.

//structure STR: [
//	length byte
//	char^1,255 byte
//]

manifest
   [
   strlen = 10		//number of words
   DEL = #177
   CONTROLA = 1
   BACKSPACE = $H - $A + 1
   ]

// Procedures

//Scanner routines.

//*********************************************************
let ScanInit(b,s) be
//*********************************************************
   [
   Zero(b, SCANIlen)
   let str = OpenFile(s, ksTypeReadOnly, 1)
   if str eq 0 then Scream("File not found")
   b>> SCANI.stream = str
   ]

//*********************************************************
and ScanClose() be Closes(sc>>SCANI.stream)
//*********************************************************

//*********************************************************
and Scan() = valof
//*********************************************************
   [
   let ins = sc>> SCANI.stream
   let lastch = sc>> SCANI.lastch
   let ch = sc>> SCANI.backtoken
   if ch ne 0 then
      [
      sc>> SCANI.backtoken=0
      resultis ch
      ]
   test lastch eq 0
   ifso ch = Gets(ins)
   ifnot ch = lastch

   let idname=lv sc>>SCANI.idname
   sc>>SCANI.lastch = 0
      [
      if Endofs(ins) then resultis EOF
      let c = getcharclass(ch)
      switchon c into
         [
         case 0: //separator...
         endcase

         case 1: // left parenthesis.
            if Endofs(ins) then resultis LPAREN
            ch = Gets(ins)
            if getcharclass(ch) eq 2 then resultis SNIL
            sc>> SCANI.lastch = ch
         resultis LPAREN

         case 2:
         resultis RPAREN

         case 3: // "
            [
            let cn = 0
               [
               if Endofs(ins) then break
               ch = Gets(ins)
               if getcharclass(ch) eq 3 then break
               cn = cn + 1
               idname>> STRING.char^cn = ch
               ] repeat
            idname>> STRING.length = cn
            ]
         resultis STRING

         case 4:
         resultis SLASH

         case 5:
         case 6: //Scan into an identifier.
            [
            let firstclass = c
            let cn = 0
               [
               ScanSavedLetter=ch
               if $a le ch & ch le $z then ch = ch - $a + $A
               cn = cn + 1
               idname>> STRING.char^cn=ch
               if Endofs(ins) then break
               ch = Gets(ins)
               let c = getcharclass(ch)
               if c ls 5 then break //out of bounds.
               ] repeat
            idname>> STRING.length = cn
            sc>>SCANI.lastch = ch
            let failflg = true //try number, but may not be one
            if firstclass eq 5 then ReadNumber(idname, 1, lv failflg)
            resultis (failflg ? ID, NUMBER)
            ]

         case 7:
         resultis EQUAL
         ]
      ch = Gets(ins)
      ] repeat
   ]

//*********************************************************
and ScanFor(token) be
//*********************************************************
   [
   let c = Scan()
   if c ne token then Scream("Format")
   ]

//*********************************************************
and ScanUntil(token) be
//*********************************************************
   [
   let level = 0
      [
      let c=Scan()
      if c eq token then
         if token ne RPAREN % level eq 0 then return
      if c eq LPAREN then level=level+1
      if c eq RPAREN then level=level-1
      ] repeat
   ]

//*********************************************************
and ScanBack(token) be sc>>SCANI.backtoken = token
//*********************************************************

//*********************************************************
and ScanSet(b) = valof
//*********************************************************
   [
   let c = sc
   sc = b
   resultis c
   ]

//*********************************************************
and ScanGiveID() = lv sc>>SCANI.idname
//*********************************************************

//*********************************************************
and ScanCh() = valof
//*********************************************************
   [
   let ch=sc>>SCANI.lastch
   sc>>SCANI.lastch=0
   if ch then resultis ch
   let ins=sc>>SCANI.stream
   if Endofs(ins) then resultis EOF
   ch=Gets(ins)
   resultis ch
   ]

//*********************************************************
and getcharclass(ch) = 
//*********************************************************
   selecton ch into
      [
      case $*s:
      case $*l:
      case $*n:
      case #11: 
         0
      case $(:
         1
      case $):
         2
      case $":
         3
      case $/:
         4
      case $-:
      case $.:
      case $0:
      case $1:
      case $2:
      case $3:
      case $4:
      case $5:
      case $6:
      case $7:
      case $8:
      case $9:
         5
      case $=:
         7
      default:
         6
   ]

//Number reading and printing....

//*********************************************************
and ReadNumber (str,x,fail;numargs na) = valof
//*********************************************************
// Read a number from str and return it in FPAC 1
// uses FPAC's 2,3,4
// Set @fail if it turns out not to be a number.
//
   [
   let a = nil
   DefaultArgs(lv na, 1, 1, lv a)
//   if na eq 1 then x = 1
//   if na ls 3 then fail = lv a
   @fail=false
   let octn=0
   let sign=false
   FLDI(1,0); FLDI(4,10); FLDI(2,1)
   let pseen=false
   for i = x to str>> STRING.length do 
      [
      let ch=str>> STRING.char^i
      test ch eq $.
      ifso pseen = true
      ifnot
         [
         test ch eq $-
         ifso sign=not sign
         ifnot
            [
            test $0 le ch & ch le $9
            ifso
               [
               FLDI(3,ch-$0)
               test pseen
               ifso [ FDV(2,4); FML(3,2) ]
               ifnot FML(1,4)
               FAD(1,3)
               octn=(octn lshift 3)+ch-$0
               ]
            ifnot
               [
               test ch eq $E
               ifso
                  [ //exponent...
                  let flg=nil
                  let s=vec 2; FST(1,s);
                  ReadNumber(str,i+1,lv flg)
                  if flg then [ @fail=true; break ]
                  let exp=FTR(1)
                  FLD(1,s)
                  FLDI(4,10)
                  while exp gr 0 do [ FML(1,4); exp=exp-1 ]
                  while exp ls 0 do [ FDV(1,4); exp=exp+1 ]
                  break
                  ]
               ifnot
                  [
		test ch eq $Q
                  ifso FLDI(1,octn)
                  ifnot
                     [
                     @fail=true
                     break	//Don't try to parse any more
                     ]
                  ]
               ]
            ]
         ]  
      ]
   if @fail ne 0 & na ls 3 then Scream("ReadNumber: format")
   if sign then FNEG(1)
   resultis(FTR(1))
   ]

//*********************************************************
and PrintNumber(str, n, radix, pos; numargs na) be
//*********************************************************
   [
//   DefaultArgs(lv na, 2, 10, 0)
   if na ls 4 then str>> STRING.length = 0
   if na ls 3 then radix = 10
   if n ls 0 then
      [
      n = -n
      AppendChar($-, str)
      ]
   printnumber2(str, n, radix)
   ]

//*********************************************************
and printnumber2(str, n, radix) be
//*********************************************************
   [
   let f = n / radix
   if f ne 0 then printnumber2(str, f, radix)
   AppendChar($0 + (n rem radix), str)
   ]

//*********************************************************
and PrintFloat(s, lvnum) be
//*********************************************************
   [
   let v = vec 4*5
   for i = 1 to 4 do FSTV(i, v + 4 * i)
   @s = 0
   FLD(1,lvnum)
   let p = FSN(1)
   test p eq 0
   ifso
      AppendChar($0, s)
   ifnot
      [	//Really work
      if p eq -1 then [ FNEG(1); AppendChar($-, s) ]

      FLDV(2, table [ 0; 1; #100000; 4 ]) //Fuzz1= 1 + 2E-9
      FML(1, 2)	//n_fuzz1*number
      FLDI(3, 1);FLDI(2,10)
      FLD(4, 1)	//number
      p = 0
      while FCM(4, 2) eq 1 do [ FDV(4, 2); p = p + 1 ]
      while FCM(4, 3) eq -1 do [ FML(4, 2); p = p - 1 ]

// 4 has  number between 1 and 10, and p has power

      FLD(3, table [ #031325; #163073 ])	//Fuzz2 = 5E-9
      FML(3, 1) //s_fuzz2 * n
      let q = p
      test p gr 7 % p ls -3 then p = 0 or q = 0
      test p ls 0
      ifso
         [
         AppendChar($0, s); AppendChar($., s)
         for i = p to -2 do AppendChar($0, s)
         for i = 1 to -p do FDV(3, 2)	//s = s E P
	]
      ifnot
         for i = 1 to p do FML(3,2)

//now print (s suppresses trailing zeroes)

      for i = 1 to 9 do
         [
         let ipart = FTR(4)
         AppendChar($0 + ipart, s)
         p = p - 1
         FLDI(1,ipart); FSB(4, 1); FML(4, 2)
         if p ls 0 then
            [
            if p eq -1 then AppendChar($., s)
            FML(3, 2)
            if FCM(4, 3) eq -1 then break //fuzz
            ]
	]
	if q ne 0 then
           [
           AppendChar($E, s);
           PrintNumber(s,q,10,nil)
           ]
      ] //Really work
   for i = 1 to 4 do FLDV(i,v+4*i)
   ]

//Type in and out routines.

//*********************************************************
and TypeForm(m,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil; numargs na) be
//*********************************************************
   [
   let lvm = lv m
   let i = 0; let str = vec 20
   while i ls na do
      [
      let x = lvm!i
      let i1 = i + 1
      if (x & #177400) eq 0 then switchon x into
         [
         case 8:
         case 10:
            i = i1
            PrintNumber(str,lvm!i,x)
            x = str
         endcase

         case 0:
//            x = "*N*L"
            x = "*N"
         endcase

         case 1:
            i = i1
            TypeIn(lvm!i)
            x = ""
         endcase

         case 2:
            i = i1
            PrintFloat(str, lvm!i)
            x = str
         endcase

         case 3:
         case 4:
            [
            i = i1
            let v = vec 4
            FSTV(1, v)
            FLDDP(1, lvm!i)
            if x eq 4 then
               [
               let s = vec 4
               FSTV(1, s); s!1 = s!1 + 16; FLDV(1, s)
               ]
            PrintFloat(str,1)
            FLDV(1, v)
            x = str
            ]
         endcase

         default:
            str!0 = x + #400
            x = str
         endcase
         ]
      Type(x)
      i = i + 1
      ]
   ]

//*********************************************************
and Type(str) be
//*********************************************************
   Wss(((outstream eq 0)? dsp, outstream), str)

//*********************************************************
and TypeIn(str) be
//*********************************************************
   [
//	DlgInit()
//	DlgStr("", str)
//The following code is evidently an alternative to the SDialog
//package
   let count=0
   let ch = Gets(keys)

   until ch eq $*N do
      [
      switchon ch into
         [
         case BACKSPACE:
         case CONTROLA:
            if count eq 0 then endcase
            Puts(dsp,$/)
            Puts(dsp,str>> STRING.char^count)
            count = count - 1
         endcase

         case DEL:
            Type("XXX");count=0
         endcase

         default:
            count = count + 1
            str>> STRING.char^count = ch
            Puts(dsp,ch)
         endcase
         ] //end of switchon

      ch = Gets(keys)
      ] //end of wait for *n
   str>> STRING.length=count
   Puts(dsp,$*n)
  ]

//String stuff

//*********************************************************
//and AppendChar(string, char) be
and AppendChar(char, string) be
//*********************************************************
   [
   let newLength = string>> STRING.length + 1
   string>> STRING.char^newLength = char
   string>> STRING.length = newLength
   ]

//*********************************************************
and SearchChar(string, char) = valof
//*********************************************************
   [
   for I = 1 to string>> STRING.length do
      if string>> STRING.char^I eq char then resultis true
   resultis false
   ]

//*********************************************************
and StrEq(a,b) = StringCompare(a, b) eq 0
//*********************************************************
//   [
//   if a>> STRING.length ne b>> STRING.length then resultis false
//   for i = 1 to a>> STRING.length do
//      [
//      let c1=a>> STRING.char^let c2=b>> STRING.char^i
//      if (c1 ge $a)&(c1 le $z) then c1=c1+$A-$a
//      if (c2 ge $a)&(c2 le $z) then c2=c2+$A-$a
//      unless c1 eq c2 then resultis false
//      ]
//   resultis true
//   ]

//*********************************************************
and StrCop(source, destination) be
//*********************************************************
   [
   for i = 1 to source>> STRING.length do
      destination>> STRING.char^i = source>> STRING.char^i
   destination>> STRING.length = source>> STRING.length
   ]

////*********************************************************
//and StrCop(source, destination) be
////*********************************************************
//Commented out because CopyString does a move block,
//  which sometimes puts garbage into
//    destination>> STRING.char^(source>> STRING.length + 1)
//
//   CopyString(destination, source)

//Command line reader and processor.  Uses the main routine SCAN above.

//************************************************
and StringToValue(string, radix; numargs na) = valof
//************************************************
   [
   DefaultArgs(lv na, 0, "", 10)
   let N = 0
   for I = 1 to string>> STRING.length do
      N = N * radix + (string>> STRING.char^I - $0)
   resultis N
   ]

//*********************************************************
and ReadComInit() be
//*********************************************************
   [
   coms=table [ 0;0;0;0;0;0;0;0;0;0;0;0;0;0 ]
   compileif SCANIlen gr 14 then [ foo = nil ]

   Zero(coms, SCANIlen)
   coms>>SCANI.stream =
      OpenFile("Com.Cm", ksTypeReadOnly, 1, 0, fpComCm)
   ]

//*********************************************************
and ReadCom(str,sw; numargs na) = valof
//*********************************************************
   [
   if na eq 2 then sw!0 = 0
   let old = ScanSet(coms)
   let ans = valof
      [
      let c = Scan()
      if c eq EOF then [ ScanBack(EOF); resultis 0 ]
      if c eq ID % c eq NUMBER then
         [
         StrCop(lv coms>> SCANI.idname,str)
         while coms>> SCANI.lastch eq $/ do 
            [ //switches
            Scan()	//To pick up /
            Scan()
            if na eq 2 then
               [
               let s = (lv coms>>SCANI.idname)
               for i = 1 to s>> STRING.length do
                  [
                  sw!0 = sw!0+1
                  sw!(sw!0) = s>> STRING.char^i
                  ]
               ]

            ]
         resultis c
         ]
      Scream("Invalid command line")
      ]
   ScanSet(old)
   resultis ans
   ]

//************************************************
and PauseForCR(string) be
//************************************************
   [
   Wl(" Pause for CR")
   Ws(string)

   let char = nil

      [
      char = Gets(keys)
      ]
   repeatuntil char eq $*n % char eq $b % char eq $B

   unless char eq $*n do CallSwat()
   ]