SECTION "BCPL"

GET "b.Header"

STATIC {
// Version of 28 Feb 86 11:51:01
   dummy = VersionMark
   version = 1*256+2 };

LET Start() BE {
   LET oldOutput = Output()
   LET mark.syntrn = VEC mk.size-1

   streams := 0
   workVectors := 0
   verStream := oldoutput
   ocodeStream := 0

   // Initialise the world and decode arguments: this routine sets up
   // the 'primal.mark' used in opening streams.

   cg := bcpl.args(mark.syntrn)

   TEST sourceStream~=0 THEN {
      LET keeptags = tagChain

      {  LET mark = VEC mk.size-1
	 LET a	  = ?
	 MarkHeap(mark)

	 // The 'ocode.mark' is used when store for OCODE buffers is
	 // allocated: these are held AFTER the mark on the chain, and so
	 // will not be released until the heap is reset to the mark made
	 // above, after the CG phase.	The heap is reset to 'ocode.mark'
	 // after the SYN and TRN phases, thus freeing the tree and
	 // declaration space.

	 ocode.mark := GetBlk(mk.size)
	 MarkHeap(ocode.mark)

	 SelectOutput(verStream)

	 a := bcpl.syn()
	 IF a=0 | rc>=20 THEN BREAK

	 WriteF("Tree size %N*N", space.used-mk.used!mark)

	 IF printTree THEN bcpl.ptree(a)

	 IF bcpl.trn(a)=0 THEN rc := 20

	 tagChain := keeptags
	 ResetHeap(ocode.mark)

	 IF (moduleStream~=0 | listStream~=0) & rc<=5 THEN bcpl.cg()

	 ResetHeap(mark)
      } REPEATUNTIL ch=endStreamch | rc>=20

      Close(sourceStream)
      IF ocodeStream~=0 THEN Close(ocodeStream)

      SelectOutput(verStream) }

   ELSE IF ocodeFile~=0 THEN {
      LET i = Input();
      LET op = ?;
      ocodeStream := Open(ocodeFile, TRUE, FALSE);
      SelectInput(ocodeStream);
      retainOcode := TRUE;

      {  ocode.mark := GetBlk(mk.size)
	 MarkHeap(ocode.mark)
	 ocodeBuf := GetWithMark(oc.size, mark.syntrn)
	 ocodeBufs := ocodeBuf
	 oc.lastbyte!ocodeBuf := oc.firstbyte
	 oc.next!ocodeBuf := 0;

	 {  LET n = 0;
	    op := ReadN();
	    IF result2~=0 THEN BREAK;
	    Out1(op);
	    SWITCHON op INTO {
	       DEFAULT:
		  ENDCASE
	       CASE s.fnap:CASE s.rtap:
	       CASE s.lp: CASE s.lg: CASE s.ln: CASE s.ll:
	       CASE s.llp:CASE s.llg:CASE s.lll:
	       CASE s.sp: CASE s.sg: CASE s.sl:
	       CASE s.jump:CASE s.jt:CASE s.jf:CASE s.endfor:
	       CASE s.lab: CASE s.res:
	       CASE s.stack:CASE s.rstack:CASE s.save:
	       CASE s.datalab:CASE s.iteml:CASE s.itemn:
	       CASE s.endproc:
	       CASE s.linecount: CASE s.argno:
		  n := 1; ENDCASE
	       CASE s.fconst:
	       CASE s.dtab:
		  n := 2; ENDCASE
	       CASE s.slctap: CASE s.slctst:
		  n := 3; ENDCASE
	       CASE s.needs:
	       CASE s.section:
	       CASE s.lstr:
		  n := ReadN(); Out1(n); ENDCASE
	       CASE s.entry:
		  n := ReadN(); Out1(n); n := n+1; ENDCASE
	       CASE s.switchon:
		  n := ReadN(); Out1(n); n := 2*n+1; ENDCASE
	       CASE s.global:
		  n := ReadN(); Out1(n); n := 2*n; ENDCASE };
	    WHILE n>0 DO { Out1(ReadN()); n := n-1 }
	 } REPEATWHILE op~=s.global;

	 IF oc.lastbyte!ocodeBufs=oc.firstbyte THEN BREAK;
	 bcpl.cg();
	 ResetHeap(mark.syntrn)
      } REPEAT;
      SelectInput(i);
      Close(ocodeStream) }

   ResetHeap(mark.syntrn)

   IF moduleStream~=0 THEN Close(moduleStream);
   IF listStream~=0 THEN Close(listStream);

   SelectOutput(verStream)

   IF rc<=5 THEN
      WriteF("Program size = %N bytes*N", programSize)

fail:
   IF (CGDebugMode&#x8000)~=0 THEN MapStore();
   Exit(rc) }

AND SmallNumber(x) =  0<x<256 -> TRUE, FALSE

AND Exit(rc) BE {
   WHILE streams~=0 DO Close(st.stream!streams)
   WHILE workVectors~=0 DO FreeVector(workVectors+1)
   Stop(rc) }

AND Complain(message, a, b, c) BE
  Abandon(0, message, a, b, c)

AND Abandon(rc, message, a, b, c) BE {
   SelectOutput(verStream)
   WriteF(message, a, b, c)
   result2 := rc
   NewLine()
   Exit(20) }

AND GetVector(size) = VALOF {
// Gets a vector of size (NOT upb) 'size'.
   LET v = GetVec(size)

   IF v=0 THEN Complain("ERROR: insufficient free store")
   IF (-1)!v>=0 THEN Complain("GetVec bug")
   !v := workVectors
   workVectors := v
   RESULTIS v+1 }

AND GetWithMark(size, mark) = VALOF {
// Allocates a new vector, and adds it to the chain AFTER the given mark.
   LET v  = GetVector(size)-1
   LET vm = mk.vector!mark

   workVectors := !v
   !v := !vm
   !vm := v
   RESULTIS v+1 }

AND FreeVector(v) BE {
   LET lv.c = @workVectors
   v := v-1

   WHILE !lv.c~=0 DO {
      LET v1 = !lv.c
      IF v1=v THEN {
	 !lv.c := !v1
	 FreeVec(v)
	 RETURN }
      lv.c := v1 }
   Complain("BUG: invalid freevector call") }

AND GetBlk(size) = VALOF {
   LET p = ?
   IF 2<=size<=free.max THEN {
      p := freeLists!size;
      IF p~=0 THEN {
	 freeLists!size := !p;
	 RESULTIS p } };

   IF heapptr+size>heap.block.size THEN {
   // Allocate 'large' vectors separately, to reduce fragmentation.
      IF size>heap.block.size/4 THEN RESULTIS GetVector(size)
      heap.block := GetVector(heap.block.size)
      heapptr := 0 }

   p := heapptr+heap.block
   heapptr := heapptr+size
   space.used := space.used+size
   RESULTIS p }

AND MarkHeap(mark) BE {
   mk.vector!mark := workVectors
   mk.block!mark := heap.block
   mk.ptr!mark := heapptr
   mk.used!mark := space.used }

AND ResetHeap(mark) BE {
   LET v = mk.vector!mark

   WHILE workVectors~=v DO
      FreeVector(workVectors+1);

   FOR i = 2 TO free.max DO freeLists!i := 0;

   heap.block := mk.block!mark
   heapptr := mk.ptr!mark
   space.used := mk.used!mark }

AND FreeBlk(p, size) = VALOF {
   LET res = !p;
   TEST 2<=size<=free.max THEN {
      !p := freeLists!size;
      freeLists!size := p }
   ELSE
      Complain("Bad call to FreeBlk: size = %n", size);
   RESULTIS res }

AND FillBlk(n, a, b, c, d, e, f, g, h, i, j, k) = VALOF {
   LET p = GetBlk(n);
   FOR i = 1 TO n DO
      (i-1)!p := i!@n;
   RESULTIS p }

AND Open(file, input, binary) = VALOF {
  // The store for the stream object is obtained by using
  // 'getwithmark', quoting the 'primal.mark'.	This is
  // important because the OCODE stream may be opened in the
  // TRN phase, AFTER the tree has been built.	If the
  // normal 'getvector' routine was used, the store for this
  // stream would be freed after the translation was
  // complete.
   LET s = input -> FindInput(file), FindOutput(file)
   IF s~=0 THEN {
      LET str = GetWithMark(st.size, primal.mark)
      LET name = GetWithMark((file%0)/BytesPerWord+1, primal.mark);
      FOR i = 0 TO file%0 DO name%i := file%i;
      st.stream!str := s;
      st.input!str := input;
      st.link!str := streams;
      st.file!str := name;
      streams := str }
   RESULTIS s }

AND Close(stream) BE {
   LET lv.str = @streams
   LET str = streams

   WHILE str~=0 & stream~=st.stream!str DO {
      lv.str := st.link+str
      str := !lv.str }

   IF str=0 THEN Complain("BUG: bad close argument")
   !lv.str := st.link!str

   TEST st.input!str THEN {
      LET i = Input()
      SelectInput(stream)
      EndRead()
      IF i~=stream THEN SelectInput(i) }
   ELSE {
      LET o = Output();
      SelectOutput(stream);
      EndWrite();
      IF stampFiles THEN Stamp(st.file!str);
      IF o~=stream THEN SelectOutput(o) }
   FreeVector(st.file!str);
   FreeVector(str) }

AND Stamp(name) BE {
   LET params = VEC 3;
   LET dt = VEC 1;
   BinaryTime(dt);
   params!0 := #xffffff00 | (dt!1)
   OSFile(2, name, params);
   params!1 := dt!0;
   OSFile(3, name, params) }

AND LookUpTag(string) = VALOF {
// Looks up the tag with the name given by the string,
// creating a new tag object (with value FALSE) if it is
// not found.  The tag object is returned as the result.
   LET t = tagChain
   LET len = string%0

   WHILE t~=0 DO {
      IF CompString(string, tag.name+t)=0 THEN RESULTIS t
      t := tag.link!t }

   t := GetBlk(tag.name+len/BytesPerWord+1)
   tag.link!t := tagChain
   tagChain := t
   tag.value!t := FALSE

   FOR j = 0 TO len DO
      (tag.name+t)%j := string%j
   RESULTIS t }

.

SECTION "Args"

GET "b.Header"

MANIFEST {
   argv.upb = 300;

// "FROM,TO=OBJ,OCODE/K,OPT/K,VER/K,LIST/K,HDR/K,CHARCODE/K"

   a.from =  0
   a.to =  1
   a.ocode =  2
   a.opt =  3
   a.ver =  4
   a.list = 5;
   a.hdr =  6
   a.charcode =  7 }

LET bcpl.args(mark) = VALOF {
// Called to initialise the world and decode the arguments
// of the BCPL compiler.  The parameter is a heap mark
// vector which is used before allocating the store that
// is not required after the SYN and TRN phases.
//
// The order of allocation of store is important, and is
// as follows:
//
//     VER stream
//     OCODE file name vector
//     Output code stream
//		      ------------- heap marked
//     Others streams and vectors
//     Tag name blocks from option string
//
   LET sssset = FALSE
   LET cg = 0
   LET log = 0
   LET bits = ?
   LET argv = VEC argv.upb
   LET s.front.end = "front end"
   AND s.code.gen = "code generator"
   AND s.not.recog = "not recognised"
   AND s.not.preceded = "not preceded by + or -"

   // Initialise storage and stream data: some of the
   // initialisation has been done in the 'main' program.

   heapptr := heap.block.size
   space.used := 0

   freeLists := GetVector(free.max)-1;
   FOR i = 2 TO free.max DO freeLists!i := 0;

   primal.mark := GetBlk(mk.size)
   MarkHeap(primal.mark)

   rc := 0
   transchars := FALSE
   lispExtensions := TRUE;
   charCode := 0
   headers := 0
   sourceStream, listStream, moduleStream := 0, 0, 0;

   programSize := 0

   tagChain := 0

   backwardVecs := FALSE;
   printTree := FALSE;
   procNames, naming := TRUE, FALSE;
   callCounting, counting := FALSE, FALSE;
   compactCode, AOFout := TRUE, FALSE;
   rbInCalls := TRUE;
   lispExtensions := TRUE;
   stampFiles := TRUE;
   CGDebugMode, CGOptMode := 0, 1;

   restrictedLanguage := FALSE
   extension.level := default.extension.level
   equateCases := TRUE
   retainOcode := TRUE

   stkchking := FALSE

   // Compute the machine dependent parameters for field
   // selectors.  'bitswidth' is the number of bits in a
   // BCPL cell on the target machine.

   bitswidth := 32
   bits := bitswidth-1
   WHILE bits~=0 DO { log := log+1; bits := bits>>1 }

   slct.size.shift := bitsperword-log
   slct.shift.shift := slct.size.shift-log
   slct.mask := (1<<log)-1
   slct.max.offset := (1<<slct.shift.shift)-1

   IF rdargs("FROM,TO=OBJ,OCODE/K,OPT/K,VER/K,LIST/K,HDR/K,CHARCODE/K",
	     argv, argv.upb)=0
      THEN Complain("Bad args")

   IF argv!a.ver~=0 THEN {
      verStream := OpenStream(argv!a.ver, FALSE, FALSE)
      SelectOutput(verStream) }

   IF argv!a.list~=0 THEN
      listStream := OpenStream(argv!a.list, FALSE, FALSE);

   WriteF("ARM BCPL Version %n.%n*N", majorVersion, minorVersion)

   IF argv!a.to~=0 THEN
      moduleStream := OpenStream(argv!a.to, FALSE, TRUE)

   ocodeFile := argv!a.ocode
   IF ocodeFile~=0 THEN ocodeFile := NewString(ocodeFile)

   // The store allocated above will be required for all
   // phases of the compiler; that which is allocted next
   // can be released after all the SYN and TRN phases.
   // Thus the heap is marked now.

   MarkHeap(mark)

   tag.value ! LookupTag("ARM") := TRUE;

   IF argv!a.charcode~=0 THEN {
      LET stream = OpenStream(argv!a.charcode, TRUE, FALSE)

      charCode := GetVector(128)
      transchars := TRUE

      SelectInput(stream)

      FOR i = 0 TO 127 DO charCode!i := ReadCode()
      Close(stream)
      IF rc>0 THEN Complain("Error in CHARCODE table") }

   IF argv!a.from~=0 THEN {
      fromfile := NewString(argv!a.from)
      sourceStream := OpenStream(fromfile, TRUE, FALSE) }

   IF sourceStream=0 & ocodeFile=0 THEN
      Complain("Nothing to compile")

   // OPT parameter
   //
   // Compiler options:
   //
   //	T     print parse tree
   //	R     'restricted' language
   //	C     equate cases
   //	Sn    set savespace size
   //	B     stack grows from high to low addresses -
   //	      point vecs at the end, not beginning
   //	Xn    set extension level to n
   //	$tag  set tag to TRUE
   //	$tag' set tag to FALSE
   //	Dn    - ignored -
   //	Ln    - ignored -
   //
   // Code generator options:
   //
   //	C     stack checking
   //	N     procedure names in code
   //	P     profile and call counting
   //	K     call counting
   //	Wn    - ignored -
   //	X-Z   machine dependent
   //
   // To allow for the $ (tag setting) option, options
   // may now be separated by commas.

   IF argv!a.opt~=0 THEN {
      STATIC { optp = 0; opts = 0 };
      LET found = FALSE
      LET value = ?

      LET rdn(optc, type) = VALOF {
	 LET n = 0
	 LET ok = FALSE;
	 WHILE optp<opts%0 DO {
	    LET ch = opts%(optp+1);
	    UNLESS '0'<=ch<='9' THEN BREAK;
	    optp := optp+1;
	    n := n*10 + ch-'0';
	    ok := TRUE };

	 IF ~ok THEN BadOpt(optc, type, "bad numeric argument")

	 RESULTIS n }

      AND GetTag() BE {
      // Called after $ has been found in the front end options.
	 LET l = 0
	 LET c = ?
	 LET v = VEC 255/BytesPerWord

	 WHILE optp<opts%0 DO {
	    c := CapitalCh(opts%(optp+1))
	    IF ~['A'<=c<='Z' | '0'<=c<='9'] THEN BREAK
	    l := l+1
	    optp := optp+1
	    v%l := c }

	 v%0 := l
	 TEST l=0 THEN
	    WriteS("Bad tag setting option*N")
	 ELSE {
	    LET t = LookUpTag(v)
	    TEST c='*'' THEN {
	       tag.value!t := FALSE
	       optp := optp+1 }
	    ELSE
	       tag.value!t := TRUE } }

      AND BadOpt(ch, stage, message) BE
	 WriteF("Bad %S option *'%C*' - %S*N",
		 stage, ch, message)

      opts := argv!a.opt;
      optp := 1;
      WHILE optp<=opts%0 DO {
	 LET lvOpt = 0
	 LET ch = opts%optp

	 SWITCHON CapitalCh(ch) INTO {
	    DEFAULT:  BadOpt(ch, s.front.end, s.not.recog); ENDCASE
	    CASE ',': ENDCASE
	    CASE '+': value, found := TRUE, TRUE; ENDCASE
	    CASE '-': value, found := FALSE, TRUE; ENDCASE

	    CASE 'B': lvOpt := @backwardVecs; ENDCASE
	    CASE 'C': lvOpt := @equateCases; ENDCASE
	    CASE 'D': rdn(ch, s.front.end); ENDCASE
	    CASE 'H': lvOpt := @naming; ENDCASE
	    CASE 'L': lvopt := @lispExtensions; ENDCASE
	    CASE 'R': lvOpt := @restrictedLanguage; ENDCASE
	    CASE 'S': sssset := TRUE;
		      savespacesize := rdn(ch, s.front.end); ENDCASE
	    CASE 'T': lvOpt := @printtree; ENDCASE
	    CASE 'X': extension.level := rdn(ch, s.front.end); ENDCASE

	    CASE '$': GetTag(); ENDCASE
	    CASE '/': optp := optp+1; BREAK }

	 optp := optp+1;
	 IF lvOpt=0 THEN LOOP

	 TEST found
	    THEN !lvOpt := value
	    ELSE BadOpt(ch, s.front.end, s.not.preceded)

	 lvOpt := 0 }

      // Check for code generator options

      found := FALSE

      WHILE optp<=opts%0 DO {
	 LET lvOpt = 0
	 LET ch = opts%optp

	 SWITCHON CapitalCh(ch) INTO {
	    DEFAULT:  BadOpt(ch, s.code.gen, s.not.recog); ENDCASE
	    CASE ',': ENDCASE
	    CASE '+': value, found := TRUE, TRUE; ENDCASE
	    CASE '-': value, found := FALSE, TRUE; ENDCASE

	    CASE 'A': lvOpt := @AOFout; ENDCASE
	    CASE 'B': lvopt := @rbInCalls; ENDCASE
	    CASE 'C': lvOpt := @stkchking; ENDCASE
	    CASE 'D': CGDebugMode := rdn(ch, s.code.gen); ENDCASE
	    CASE 'K': lvOpt := @callcounting; ENDCASE
	    CASE 'N': lvOpt := @procNames; ENDCASE
	    CASE 'O': CGOptMode := RdN(ch, s.code.gen); ENDCASE
	    CASE 'P': lvOpt := @counting; ENDCASE
	    CASE 'S': lvOpt := @compactCode; ENDCASE
	    CASE 'W': rdn(ch, s.code.gen); ENDCASE;
	    CASE 'Z': lvOpt := @stampFiles; ENDCASE };

	 optp := optp+1
	 IF lvOpt=0 THEN LOOP

	 TEST found THEN
	    !lvOpt := value
	 ELSE
	    BadOpt(ch, s.code.gen, s.not.preceded)
	 lvOpt := 0 } };

   IF ocodeFile~=0 THEN retainOcode := FALSE;

   // HDR parameter (if read with /L, the length is given in the first word).

   IF argv!a.hdr~=0 THEN
      headers := NewString(argv!a.hdr)

   IF sourceStream~=0 THEN {
      SelectInput(sourceStream)
      linecount := 1
      trnlinecount := 1 }

   IF ~sssset THEN savespacesize := 4

   RESULTIS cg }

AND OpenStream(file, input, binary) = VALOF {
   LET s = Open(file, input, binary)

   IF s=0 THEN
     Abandon(result2, "Can't open %S for %Sput",
	     file, (input -> "in", "out"))

   RESULTIS s }

AND NewString(s) = s=0 -> 0, VALOF {
   LET l = s%0
   LET v = GetBlk(l / BytesPerWord+1)
   FOR c = 0 TO l DO v%c := s%c
   RESULTIS v }

AND ReadCode() = VALOF {
  // Used to read code value for CHARCODE parameter.
  //
  // Value may be:    ooo	 octal
  //		      :xx	 hex
   LET n = 0
   LET ch = ' '
   LET rx = 8
   LET dc = 3

   WHILE ch='*S' | ch='*T' | ch='*N' DO ch := rdch()

   IF ch=':' THEN {
      rx := 16; dc :=  2; ch := rdch() }

   FOR i = 1 TO dc DO {
      LET c = CapitalCh(ch)
      LET d = '0'<=c<='9' -> c-'0',
	      'A'<=c<='F' -> c-'A'+10, -1

      TEST 0<=d<rx THEN
	 n := n*rx+d
      ELSE {
	 rc := 10; BREAK }
      ch := rdch() }

   IF ~[ch='*S' | ch='*T' | ch='*N'] THEN rc := 10
   unrdch()
   RESULTIS n }
