SECTION "TrnA"

GET "b.Header"

STATIC
$( /* Version of 01 Nov 85 15:44:31
   */
   dummy = VersionMark
   version = 1*256+1
$)

LET bcpl.trn(x) = VALOF
$( nameBlockV := GetVector(name.block.vector.size)

   FOR j = 0 TO name.block.vector.size-1 DO
     nameBlockV!j := 0

   err.p, err.l := Level(), fail

   nameVecE := -1
   AddName(0, 0, 0)
   namepbase := nameVecE+1

   globList, globListe := 0, @globList
   globCount := 0

   casekvec := 0

   endcaseLabel, defaultLabel := 0, 0;
   resultLabel, breakLabel, loopLabel := -1, -1, -1;
   returnLabel := 0;

   accessible := FALSE;
   currentBranch := x
   ocount := 0
   paramNumber := 0
   undefCount := 0

   // If necessary, initialise the OCODE store buffers.
   // Otherwise, open the OCODE file for output if this
   // not already been done.

   TEST retainOcode THEN $(
      ocodeBuf := GetWithMark(oc.size, ocode.mark)
      ocodeBufs := ocodeBuf
      oc.lastbyte!ocodeBuf := oc.firstbyte
      oc.next!ocodeBuf := 0 $)
   ELSE $(
      IF ocodeStream=0 THEN
      $( ocodeStream := open(ocodeFile, FALSE, FALSE)
	 IF ocodestream=0 THEN
	    complain("Can't open *"%S*" for output", ocodeFile) $);
      SelectOutput(ocodeStream) $)

   WHILE x~=0 & (h1!x=s.section | h1!x=s.needs) DO $(
      Out1(h1!x)
      OutString(h2!x+1)
      x:=h3!x $)

   ssp := saveSpaceSize
   Out2(s.stack, ssp)

   DeclLabels(x)
   Trans(x)
   DeclExternals()

   Out2(s.global, globCount)

   WHILE globList~=0 DO
   $( Out2(gl.number!globList, gl.label!globList)
      globList := gl.link!globList $)

fail:
   EndOcode()
   SelectOutput(verstream)

   RESULTIS -1
$)

AND NextParam() = VALOF
$( paramNumber := paramNumber+1
   RESULTIS paramNumber
$)

AND CompEntry(n, l) BE
$( LET s = @n!2
   LET t = s%0

   Out2(s.entry, t); Out1(l);
   accessible := TRUE;

   FOR i = 1 TO t DO
   $( LET c = s%i
      Out1(transChars -> charCode!c, c) $)
$)

AND CompJump(l) BE Out2(s.jump, l)

AND EndOcode() BE IF ~retainOcode THEN
$( WrCh('*N')
   ocount := 0
$)

AND DeclExternals() BE
$( LET e = externals.list

   WHILE e~=0 DO
   $( LET l1 = h3!e
      LET l2 = h4!e

      IF l1~=0 THEN
	 TEST l2=0 THEN $(
	    Out2(s.refext, l1)
	    OutString(h2!e) $)
	 ELSE $(
	    CompDataLab(l1)
	    Out2(s.iteml, l2) $)

      IF l2~=0 THEN
      $( Out2(s.defext, l2)
	 OutString(h2!e) $)
      e := h1!e $)
$)

AND Trans(x) BE IF x~=0 THEN
$( LET sw = FALSE
   currentBranch := x
   SWITCHON h1!x INTO
   $( DEFAULT:
	TransReport(100, x)
	ENDCASE

      CASE s.let:
      $( LET a, s, s1 = nameVecE, ssp, 0
	 LET v = vecssp

	 Declnames(h2!x)
	 CheckDistinct(a+1, nameVecE)
	 vecssp, s1 := ssp, ssp
	 ssp := s
	 TransDef(h2!x)

	 IF ssp~=s1 THEN TransReport(110, x)

	 IF ssp~=vecssp THEN $(
	    ssp := vecssp
	    Out2(s.stack, ssp) $)

	 OutOp(s.store)
	 DeclLabels(h3!x)
	 Trans(h3!x)

	 vecssp := v
	 IF accessible & ssp~=s THEN Out2(s.stack, s)
	 nameVecE, ssp := a, s
	 ENDCASE $)

      CASE s.static:
      CASE s.global:
      CASE s.manifest:
      CASE s.external:
      $( LET a, s = nameVecE, ssp
	 LET op = h1!x
	 LET list = h2!x
	 LET p = list+2

	 FOR i = 0 TO h2!list-1 BY 3 DO $(
	    LET name = p!i
	    LET k = p!(i+1)
	    LET type = op

	    trnLineCount := p!(i+2)

	    TEST op=s.manifest THEN
	    $( LET name = 0
	       LET kt = 0

	       IF k~=0 & ~SmallNumber(k) THEN kt := h1!k

	       IF kt=s.name THEN $(
		  name := FindName(k)
		  kt := name.type!name $)

	       TEST kt~=s.string & kt~=s.table |
		    extension.level<5 THEN $(
		  type := s.number
		  k := EvalConst(k) $)
	       ELSE $(
		  type := kt

		  TEST name=0 THEN $(
		     IF kt=s.table THEN
			h2!k := nameVecE
		     h1!k := 0 $)
		  ELSE
		     k := name.value!name $) $)

	    ELSE IF op=s.global
	       THEN k := EvalConst(k)

	    TEST op=s.static THEN $(
	       LET m = NextParam()
	       LET l = 0

	       IF extension.level>=5 THEN
		  l := CheckLabel(k)

	       AddName(name, s.label, m)
	       CompDataLab(m)

	       TEST l=0
		  THEN Out2(s.itemn, EvalConst(k))
		  ELSE Out2(s.iteml, l) $)

	    ELSE
	       AddName(name, type, k) $)

	 DeclLabels(h3!x)
	 Trans(h3!x)
	 nameVecE, ssp := a, s
	 ENDCASE $)

      CASE s.ass:
	 Assign(h2!x, h3!x, 0)
	 ENDCASE

      CASE s.opab:
	 Assign(h3!x, h4!x, h2!x)
	 ENDCASE

      CASE s.rtap:
      $( LET s = ssp
	 ssp := ssp+saveSpaceSize
	 Out2(s.stack, ssp)
	 LoadList(h3!x)
	 Load(h2!x)
	 Out2(s.rtap, s)
	 ssp := s
	 ENDCASE $)

      CASE s.goto:
	 Load(h2!x)
	 OutOp(s.goto)
	 ssp := ssp-1;
	 accessible := FALSE;
	 ENDCASE

      CASE s.colon:
	 CompLab(h4!x, ssp)
	 Trans(h3!x)
	 ENDCASE

      CASE s.unless:
	 sw := TRUE
      CASE s.if:
      $( LET val = ?

	 TEST CheckConstant(h2!x, @val) THEN
	    IF sw=(val=0) THEN Trans(h3!x)
	 ELSE $(
	    LET l = NextParam()
	    JumpCond(h2!x, sw, l)
	    Trans(h3!x)
	    CompLab(l, ssp) $)
	 ENDCASE $)

      CASE s.test:
      $( LET val = ?

	 TEST CheckConstant(h2!x, @val) THEN
	    TEST val~=0 THEN
	       Trans(h3!x)
	    ELSE
	       Trans(h4!x)

	 ELSE $(
	    LET l, m = NextParam(), NextParam()
	    JumpCond(h2!x, FALSE, l)
	    Trans(h3!x)
	    TEST accessible
	       THEN CompJump(m)
	       ELSE m := 0;
	    CompLab(l, ssp);
	    Trans(h4!x);
	    CompLab(m, ssp) $)
	 ENDCASE $)

      CASE s.loop:
	 IF loopLabel<0 THEN TransReport(108, x)
	 IF loopLabel=0 THEN loopLabel := NextParam()
	 CompJump(loopLabel);
	 ENDCASE

      CASE s.break:
	 IF breakLabel<0 THEN TransReport(104, x)
	 IF breakLabel=0 THEN breakLabel := NextParam()
	 CompJump(breakLabel)
	 ENDCASE

      CASE s.return:
	 IF returnLabel<0 THEN TransReport(91, x);
	 OutOp(s.rtrn);
	 accessible := FALSE;
	 ENDCASE

      CASE s.finish:
	 OutOp(s.finish);
	 accessible := FALSE;
	 ENDCASE

      CASE s.resultis:
	 IF resultLabel<0 THEN TransReport(107, x)
	 Load(h2!x)
	 TEST resultLabel=0
	    THEN OutOp(s.fnrn)
	    ELSE Out2(s.res, resultLabel);
	 ssp := ssp-1;
	 accessible := FALSE;
	 ENDCASE

      CASE s.while:
	 sw := TRUE
      CASE s.until:
      $( LET l,  m = NextParam(), NextParam()
	 LET bl, ll = breakLabel,  loopLabel

	 breakLabel, loopLabel := 0, m

	 CompJump(m)
	 CompLab(l, ssp)
	 Trans(h3!x)
	 CompLab(m, ssp)
	 JumpCond(h2!x, sw, l)

	 CompLab(breakLabel, ssp)
	 breakLabel, loopLabel := bl, ll
	 ENDCASE $)

      CASE s.repeatwhile:
	 sw := TRUE
      CASE s.repeatuntil:
      CASE s.repeat:
      $( LET l = NextParam()
	 LET bl = breakLabel
	 LET ll = loopLabel

	 breakLabel, loopLabel := 0, NextParam()
	 CompLab(l, ssp)

	 TEST h1!x=s.repeat THEN $(
	    loopLabel := l;
	    Trans(h2!x);
	    CompJump(l);
	    accessible := FALSE $)
	 ELSE $(
	    Trans(h2!x)
	    CompLab(loopLabel, ssp)
	    JumpCond(h3!x, sw, l) $)

	 CompLab(breakLabel, ssp)
	 breakLabel, loopLabel := bl, ll
	 ENDCASE $)

      CASE s.case:
      $( LET l, k = NextParam(), EvalConst(h2!x)
	 TEST casekvec=0 THEN
	    TransReport(105, x)
	 ELSE $(
	    IF caseptr>=caselim THEN $(
	       rc := 20
	       TransReport(141, x) $)
	    FOR i = 0 TO caseptr-1 DO
	       IF casekvec!i=k THEN
		  TransReport(106, x)

	    casekvec!caseptr := k
	    caselvec!caseptr := l
	    caseptr := caseptr+1

	    CompLab(l, ssp) $)
	 Trans(h3!x)
	 ENDCASE $)

      CASE s.default:
	 IF casekvec=0 | defaultLabel~=0 THEN TransReport(101, x)
	 defaultLabel := NextParam()
	 CompLab(defaultLabel, ssp)
	 Trans(h2!x)
	 ENDCASE

      CASE s.endcase:
	 IF casekvec=0 THEN TransReport(121, x);
	 IF endcaseLabel=0 THEN endCaseLabel := NextParam();
	 CompJump(endcaseLabel);
	 ENDCASE

      CASE s.switchon:
	 TransSwitch(x);
	 ENDCASE

      CASE s.for:
	 TransFor(x)
	 ENDCASE

      CASE s.semicolon:
	 trnLineCount := h3!x
	 Trans(h2!x)
	 trnLineCount := h5!x
	 Trans(h4!x)
	 ENDCASE

      CASE s.semicolonlist:
	 FOR h = 2 TO h2!x BY 2 DO $(
	    trnLineCount := x!(h+1)
	    Trans(h!x) $)
	 ENDCASE
   $)
$)

AND CheckConstant(x, lv.v) = VALOF
$( IF x=0 THEN RESULTIS FALSE

   IF SmallNumber(x) THEN $(
      !lv.v := x
      RESULTIS TRUE $)

   SWITCHON h1!x INTO
   $( CASE s.name:
      $( LET n = FindName(x)

	 IF name.type!n=s.number THEN $(
	    !lv.v := name.value!n
	    RESULTIS TRUE $)
	 RESULTIS FALSE $)

      CASE s.number: !lv.v := h2!x;  RESULTIS TRUE
      CASE s.true:   !lv.v := TRUE;  RESULTIS TRUE
      CASE s.false:  !lv.v := FALSE; RESULTIS TRUE

      DEFAULT:			     RESULTIS  FALSE
   $)
$)

AND DeclNames(x) BE UNTIL x=0 DO
   SWITCHON h1!x INTO
   $( DEFAULT:
	 TransReport(102, currentBranch)
	 BREAK

      CASE s.vecdef: CASE s.valdef:
	 trnLineCount := h4!x
	 DeclDyn(h2!x)
	 BREAK

      CASE s.rtdef: CASE s.fndef:
	 trnLineCount := h6!x
	 h5!x := NextParam()
	 DeclStat(h2!x, h5!x)
	 BREAK

      CASE s.and:
	 DeclNames(h2!x)
	 x := h3!x
	 LOOP
   $)


AND DeclDyn(x) BE IF x~=0 THEN
   SWITCHON h1!x INTO
   $( CASE s.name:
	 AddName(x, s.local, ssp)
	 ssp := ssp+1
	 ENDCASE

      CASE s.comma:
	 AddName(h2!x, s.local, ssp)
	 ssp := ssp+1
	 DeclDyn(h3!x)
	 ENDCASE

      CASE s.commalist:
	 FOR h = 2 TO h2!x+1 DO DeclDyn(h!x)
	 ENDCASE

      DEFAULT:
	 TransReport(103, x)
   $)


AND DeclStat(x, l) BE
$( LET name = FindName(x)

   IF name.type!name=s.global THEN $(
      LET n = name.value!name
      LET g = GetBlk(gl.size)

      AddName(x, s.global, n)

      globcount := globCount+1
      gl.number!g := n
      gl.label!g := l
      gl.link!g := 0

      !globListE := g
      globListE := gl.link+g
      RETURN $)

   IF name.type!name=s.external THEN $(
      LET e = name.value!name
      h4!e := l
      AddName(x, s.external, e)
      RETURN $)

   $( LET m = NextParam()
      AddName(x, s.label, m)
      CompDataLab(m)
      Out1(s.iteml); Out1(l) $)
$)

AND DeclLabels(x) BE
$( LET b = nameVecE
   ScanLabels(x)
   CheckDistinct(b+1, nameVecE)
$)

AND CheckDistinct(p, q) BE
   FOR s = q TO p+1 BY -1 DO $(
      LET n = name.name!name(s)

      FOR r = p TO s-1 DO
	IF n=name.name!name(r) THEN TransReport(142, n) $)

AND AddName(name, type, value) BE
$( LET b, v, nblk = ?, ?, ?
   nameVecE := nameVecE+1

   b := nameVecE>>name.block.shift
   IF b>=name.block.vector.size THEN
   $( rc := 20
      TransReport(143, currentBranch) $)

   v := nameBlockV!b
   IF v=0 THEN
   $( v := GetVector(name.size * name.block.size)
      nameBlockV!b := v $)

   nblk := v+name.size * (nameVecE & name.block.mask)
   name.name!nblk := name
   name.type!nblk := type
   name.value!nblk := value
$)

AND Name(num) = VALOF
  //
  // Returns the object for the name of the given number.
  //
$( LET b = nameBlockV!(num>>name.block.shift)

     // If all is well, the block should already have been
     // allocated

   IF b=0 THEN $(
      rc := 20
      TransReport(1882, currentBranch) $)

   RESULTIS b+name.size * [num & name.block.mask]
$)


AND FindCell(n) = VALOF
  // Finds the cell number of the name 'n', returning zero
  // if it is not found.
$( FOR x = nameVecE TO 1 BY -1 DO
     IF name.name!Name(x)=n THEN
       RESULTIS x

   RESULTIS 0
$)

AND FindName(n) = Name(FindCell(n))

AND ScanLabels(x) BE IF x~=0 THEN
   SWITCHON h1!x INTO
   $( CASE s.colon:
	 h4!x := NextParam()
	 DeclStat(h2!x, h4!x)

      CASE s.if: CASE s.unless: CASE s.while:
      CASE s.until: CASE s.switchon: CASE s.case:
	 ScanLabels(h3!x)
	 ENDCASE

      CASE s.semicolonlist:
	 FOR h = 2 TO h2!x BY 2 DO ScanLabels(h!x)
	 ENDCASE

      CASE s.semicolon:
	 ScanLabels(h4!x)

      CASE s.repeat: CASE s.repeatwhile:
      CASE s.repeatuntil: CASE s.default:
	 ScanLabels(h2!x)
	 ENDCASE

      CASE s.test:
	 ScanLabels(h3!x)
	 ScanLabels(h4!x)
	 ENDCASE
   $)

AND TransDef(x) BE
$( TransDynDefs(x)

   IF StatDefs(x) THEN
   $( LET l, s = 0, ssp
      IF accessible THEN
      $( l := NextParam();
	 CompJump(l) $);

      TransStatDefs(x)
      ssp := s
      CompLab(l, ssp) $)
$)

AND TransDynDefs(x) BE SWITCHON h1!x INTO
$( CASE s.and:
      TransDynDefs(h2!x)
      x := h3!x
      LOOP

   CASE s.vecdef:
      trnLineCount := h4!x
      $( LET n = EvalConst(h3!x);
	 Out2(s.llp, vecssp+(backwardVecs -> n, 0));
	 ssp := ssp+1;
	 vecssp := vecssp+1+n $);
      BREAK

   CASE s.valdef:
      trnLineCount := h4!x
      LoadList(h3!x)
      BREAK

   DEFAULT:
      BREAK
$) REPEAT

AND TransStatDefs(x) BE
$( WHILE h1!x=s.and DO
   $( TransStatDefs(h2!x)
      x := h3!x $);

   IF h1!x=s.fndef | h1!x=s.rtdef THEN $(
      LET a,  c = nameVecE, namepbase
      LET bl, ll = breakLabel, loopLabel
      LET rl, kv = resultLabel, casekvec
      LET rtl, ecl = returnLabel, endcaseLabel;

      trnLineCount := h6!x

      breakLabel,  loopLabel := -1, -1
      resultLabel, casekvec := -1,  0
      returnLabel, endcaseLabel := -1, -1;

      CompEntry(h2!x, h5!x)
      ssp := saveSpaceSize

      namepbase := nameVecE+1

      DeclDyn(h3!x)
      CheckDistinct(a+1, nameVecE)
      DeclLabels(h4!x)

      Out2(s.save, ssp)

      TEST h1!x=s.fndef THEN $(
	 LET y = h4!x;
	 TEST h1!y=s.valof THEN $(
	    DeclLabels(h2!y);
	    resultLabel := 0;
	    Trans(h2!y);
	    IF accessible THEN TransReport(92, x) $)
	 ELSE $(
	    Load(y)
	    OutOp(s.fnrn);
	    accessible := FALSE $) $)

      ELSE $(
	 returnLabel := 0;
	 Trans(h4!x);
	 CompLab(returnLabel, ssp) $);

      IF accessible THEN
      $( OutOp(s.rtrn);
	 accessible := FALSE $);

      Out2(s.endproc, 0);

      breakLabel,  loopLabel := bl, ll;
      resultLabel, casekvec := rl, kv;
      nameVecE,    namepbase := a,  c;
      returnLabel, endcaseLabel := rtl, ecl $)
$)

AND StatDefs(x) = h1!x=s.fndef | h1!x=s.rtdef -> TRUE,
		  h1!x~=s.and -> FALSE,
		  StatDefs(h2!x) -> TRUE,
		  StatDefs(h3!x)

AND JumpCond(x, b, l) BE
$( LET sw = b
   IF ~SmallNumber(x) THEN
      SWITCHON h1!x INTO
      $( CASE s.false:
	    b := ~b

	 CASE s.true:
	    IF b THEN CompJump(l)
	    RETURN

	 CASE s.not:
	    JumpCond(h2!x, ~b, l)
	    RETURN

	 CASE s.logand:
	    sw := ~sw

	 CASE s.logor:
	    TEST sw THEN $(
	       JumpCond(h2!x, b, l)
	       JumpCond(h3!x, b, l) $)
	    ELSE $(
	       LET m = NextParam()
	       JumpCond(h2!x, ~b, m)
	       JumpCond(h3!x, b, l)
	       CompLab(m, -1) $)
	    RETURN
      $)

   Load(x)
   Out2(b -> s.jt, s.jf, l)
   ssp := ssp-1
$)

AND TransSwitch(x) BE
$( LET kvec, lvec = casekvec, caselvec
   LET cp, clim = caseptr, caselim
   LET ecl, dl = endcaseLabel, defaultLabel
   LET l = NextParam()

   endcaseLabel := 0;

   caseptr := 0
   caselim := h4!x

   casekvec := GetVector(2*caselim)
   caselvec := casekvec+caselim

   CompJump(l);
   defaultLabel := 0;

   Trans(h3!x);
   IF accessible THEN
   $( IF endcaseLabel=0 THEN endcaseLabel := NextParam();
      CompJump(endcaseLabel) $);

   CompLab(l, ssp)
   Load(h2!x)

   IF defaultLabel=0 THEN
   $( IF endcaseLabel=0 THEN endcaseLabel := NextParam();
      defaultLabel := endcaseLabel $);

   Out2(s.switchon, caselim)
   Out1(defaultLabel)

   FOR i = 0 TO caselim-1 DO Out2(casekvec!i, caselvec!i)

   accessible := FALSE;
   ssp := ssp-1;
   CompLab(endcaseLabel, ssp)

   FreeVector(casekvec)
   endcaseLabel, defaultLabel := ecl, dl
   casekvec, caselvec := kvec, lvec
   caseptr, caselim := cp, clim
$)


AND TransFor(x) BE
$( LET a = nameVecE
   LET m = NextParam()
   LET l = ?
   LET dojump = TRUE
   LET bl, ll = breakLabel, loopLabel
   LET k, n = 0, 0
   LET step = 1
   LET s = ssp

   breakLabel, loopLabel := 0, 0

   AddName(h2!x, s.local, s)
   Load(h3!x)

   IF h5!x~=0 THEN step := EvalConst(h5!x)

   TEST CheckConstant(h4!x, @n) THEN $(
      LET first = ?
      k := s.ln

      IF CheckConstant(h3!x, @first) THEN
	    // Only compare the values if they are of the
	    // same sign, to avoid inconsistencies with
	    // the target machine's handling of loops.

	 IF (n NEQV first)>=0 THEN
	    IF first<=n & step>=0 |
	       first>=n & step<0 THEN
	       dojump := FALSE $)

      ELSE $(
	 k, n := s.lp, ssp
	 Load(h4!x) $)

   OutOp(s.store)

   IF dojump THEN
   $( l := NextParam()
      CompJump(l) $)

   DeclLabels(h6!x)
   CompLab(m, ssp)
   Trans(h6!x)

   CompLab(loopLabel, ssp)

   Out2(s.lp, s); Out2(s.ln, step)
   OutOp(s.plus); Out2(s.sp, s)

   IF dojump THEN CompLab(l, ssp)

   TEST step>=0 THEN $(
      Out2(s.lp,s)
      Out2(k,n) $)
   ELSE $(
      Out2(k,n)
      Out2(s.lp,s) $)

   Out2(s.endfor, m)

   CompLab(breakLabel, s);
   breakLabel, loopLabel, ssp := bl, ll, s

   nameVecE := a
$)

.


SECTION "TrnB"

GET "b.Header"

STATIC
$( /* Version of 28 Feb 86 12:47:18
   */
   dummy = VersionMark
   version = 1*256+4
$)

/* 1.3	07 Feb 86 13:44:20
     Floating point incorporated
   1.4	28 Feb 86 12:46:52
     op:= allowed for selections
*/

LET Load(x) BE
$( IF x=0 THEN
   $( TransReport(148, currentBranch)
      LoadZero()
      RETURN $)

   IF SmallNumber(x) THEN
   $( Out2(s.ln, x)
      ssp := ssp+1
      RETURN $)

   $( LET op = h1!x
      SWITCHON op INTO
      $( DEFAULT:
	    TransReport(147, currentBranch)
	    LoadZero()
	    RETURN

	 CASE s.byteap:
	    op := s.getbyte

	 CASE s.div: CASE s.rem: CASE s.minus:
	 CASE s.fdiv:CASE s.fminus:
	 CASE s.ls:  CASE s.gr:  CASE s.le:  CASE s.ge:
	 CASE s.lls: CASE s.lgr: CASE s.lle: CASE s.lge:
	 CASE s.fls: CASE s.fgr: CASE s.fle: CASE s.fge:
	 CASE s.lshift: CASE s.rshift:
	    Load(h2!x)
	    Load(h3!x)
	    OutOp(op)
	    ssp := ssp-1
	    RETURN

	 CASE s.of:
	     // If the field is a whole word in size,
	     // code for x!v is generated.
	 $( LET selector = EvalConst(h2!x)
	    LET offset = selector & slct.max.offset
	    Load(h3!x)

	    TEST selector~=offset THEN $(
	       LET size = selector>>slct.size.shift;
	       LET shift = (selector>>slct.shift.shift) & slct.mask;
	       IF size=0 THEN size := bitswidth-shift;
	       OutOp(s.slctap)
	       Out1(size); Out1(shift); Out1(offset) $)
	    ELSE $(
	       Out2(s.ln, offset)
	       Out2(s.plus, s.rv) $)

	    RETURN $)

	 CASE s.vecap:
	 CASE s.mult:  CASE s.plus:
	 CASE s.eq:    CASE s.ne:
	 CASE s.fmult: CASE s.fplus:
	 CASE s.feq:   CASE s.fne:
	 CASE s.logand:CASE s.logor: CASE s.eqv: CASE s.neqv:
	 $( LET a, b = h2!x, h3!x
	      // Try to get the simpler operand on the right.

	    IF SmallNumber(a) | h1!a=s.name | h1!a=s.number THEN
	       a, b := h3!x, h2!x

	    Load(a)
	    Load(b)

	    IF op=s.vecap THEN
	    $( OutOp(s.plus)
	       op := s.rv $)

	    OutOp(op)
	    ssp := ssp-1
	    RETURN $)

	 CASE s.neg: CASE s.not: CASE s.rv: CASE s.abs:
	 CASE s.fneg:CASE s.fabs:
	 CASE s.fix: CASE s.float:
	 CASE s.car: CASE s.cdr: CASE s.vcar: CASE s.vcdr:
	    Load(h2!x)
	    OutOp(op)
	    RETURN

	 CASE s.nil:
	 CASE s.true: CASE s.false: CASE s.query:
	    OutOp(op)
	    ssp := ssp+1
	    RETURN

	 CASE s.lv:
	    LoadLV(h2!x)
	    RETURN

	 CASE s.number:
	    Out2(s.ln, h2!x)
	    ssp := ssp+1
	    RETURN

	 CASE s.fconst:
	    Out2(s.fconst, h2!x);
	    Out1(h3!x);
	    ssp := ssp+1;
	    ENDCASE

	 CASE s.slct:
	    Out2(s.ln, EvalConst(x))
	    ssp := ssp+1
	    RETURN

	 CASE s.string:
	    OutOp(s.lstr)
	    OutString(@h2!x)
	    ssp := ssp+1
	    RETURN

	 CASE s.name:
	    TransName(x, s.lp, s.lg, s.ll, s.ln, s.lll)
	    ssp := ssp+1
	    RETURN

	 CASE s.valof:
	 $( LET rl = resultLabel;
	    LET a = nameVecE;

	    DeclLabels(h2!x);
	    resultLabel := NextParam();
	    Trans(h2!x);
	    IF accessible THEN TransReport(92, x);

	    CompLab(resultLabel, -1);
	    Out2(s.rstack, ssp);

	    ssp := ssp+1;
	    nameVecE := a;
	    resultLabel := rl;
	    RETURN $)

	 CASE s.fnap:
	 $( LET s = ssp
	    ssp := ssp+saveSpaceSize
	    Out2(s.stack, ssp)
	    LoadList(h3!x)
	    Load(h2!x)
	    Out2(s.fnap, s)
	    ssp := s+1
	    RETURN $)

	 CASE s.cond:
	 $( LET val = ?

	    TEST CheckConstant(h2!x, @val) THEN
	       Load((val -> h3!x, h4!x))
	    ELSE $(
	       LET l, m = NextParam(), NextParam()
	       LET s = ssp

	       JumpCond(h2!x, FALSE, m);
	       Out2(s.stack, ssp)
	       Load(h3!x)
	       Out2(s.res,l)

	       ssp := s

	       CompLab(m, ssp)
	       Load(h4!x)
	       Out2(s.res,l)

	       CompLab(l, ssp)
	       Out2(s.rstack,s) $)
	    RETURN $)

	 CASE s.table:
	    Out2(s.lll, define.table(x))
	    ssp := ssp+1
	    RETURN
      $)
   $)
$)

AND LoadLV(x) BE
$( IF x=0 | SmallNumber(x) THEN GOTO err

   SWITCHON h1!x INTO
   $( DEFAULT:
   err: TransReport(113, currentBranch)
	LoadZero()
	ENDCASE

      CASE s.name:
	TransName(x, s.llp, s.llg,
		     (restrictedLanguage -> 0, s.lll), 0, 0)
	ssp := ssp+1
	ENDCASE

      CASE s.rv:
	Load(h2!x)
	ENDCASE

      CASE s.vecap:
	$( LET a, b = h2!x, h3!x

	   IF SmallNumber(a) | h1!a=s.name THEN
	     a, b := h3!x, h2!x

	   Load(a)
	   Load(b)
	   OutOp(s.plus)
	   ssp := ssp-1
	   ENDCASE $)
   $)
$)

AND LoadZero() BE
$( Out2(s.ln, 0)
   ssp := ssp+1
$)

AND LoadList(x) BE IF x~=0 THEN
$( IF ~SmallNumber(x) THEN $(
      LET p, n = 0, 0

      IF h1!x=s.comma THEN p, n := x+1, 2
      IF h1!x=s.commalist THEN p, n := x+2, h2!x

      IF p~=0 THEN $(
	 FOR h = 0 TO n-1 DO Load(h!p)
	 RETURN $) $)
   Load(x)
$)

AND EvalConst(x) = VALOF
$( LET a, b = 0, 0

   IF x=0 THEN
   $( TransReport(117, currentBranch)
      RESULTIS 0 $)

   IF SmallNumber(x) THEN RESULTIS x

   SWITCHON h1!x INTO
   $( DEFAULT:
	TransReport(118, x)
	RESULTIS 0

      CASE s.name:
	$( LET n = FindName(x)
	   LET k = name.type!n

	   IF k=0 THEN
	   $( TransReport(115, x)
	      undefCount := undefCount+1
	      RESULTIS undefCount $)

	   IF k=s.number THEN RESULTIS name.value!n

	   TransReport(119, x)
	   RESULTIS 0
	$)

      CASE s.number: RESULTIS h2!x

      CASE s.true:   RESULTIS TRUE

      CASE s.query:
      CASE s.false:  RESULTIS FALSE

      CASE s.cond:
	IF extension.level>=5 THEN
	$( LET b = EvalConst(h2!x)
	   LET t = EvalConst(h3!x)
	   LET f = EvalConst(h4!x)

	   RESULTIS b -> t, f $)
	TransReport(118, x)
	RESULTIS 0

      CASE s.slct:
	$( LET size = EvalConst(h2!x)
	   LET shift = EvalConst(h3!x)
	   LET offset = EvalConst(h4!x)

	   TEST 0<=size<=(bitswidth-shift) &
		0<=shift<bitswidth &
		0<=offset<=slct.max.offset THEN
	      RESULTIS [size<<slct.size.shift]	+
		       [shift<<slct.shift.shift] +
		       offset

	   ELSE $(
	      TransReport(120, x)
	      RESULTIS 0 $)
	$)

      CASE s.mult: CASE s.div: CASE s.rem:
      CASE s.plus: CASE s.minus:
      CASE s.lshift: CASE s.rshift:
      CASE s.logor: CASE s.logand: CASE s.eqv: CASE s.neqv:
	b := EvalConst(h3!x)

      CASE s.abs: CASE s.neg: CASE s.not:
	a := EvalConst(h2!x)
   $)

   SWITCHON h1!x INTO
   $( CASE s.abs:    RESULTIS ABS a
      CASE s.neg:    RESULTIS -a
      CASE s.not:    RESULTIS ~a

      CASE s.mult:   RESULTIS a*b
      CASE s.div:    RESULTIS a/b
      CASE s.rem:    RESULTIS a REM b
      CASE s.plus:   RESULTIS a+b
      CASE s.minus:  RESULTIS a-b
      CASE s.lshift: RESULTIS a<<b
      CASE s.rshift: RESULTIS a>>b
      CASE s.logand: RESULTIS a&b
      CASE s.logor:  RESULTIS a|b
      CASE s.eqv:    RESULTIS a EQV b
      CASE s.neqv:   RESULTIS a NEQV b
   $)
$)


AND Assign(x, y, op) BE
$( IF x=0 | SmallNumber(x) | y=0 THEN
   $( TransReport(110, currentBranch)
      RETURN $)

   IF ~SmallNumber(y) &
      [h1!y=s.comma | h1!y=s.commalist] &
      h1!y~=h1!x THEN
   $( TransReport(112, currentBranch)
      RETURN $)

   SWITCHON h1!x INTO
   $( CASE s.comma:
      CASE s.commalist:
	IF SmallNumber(y) | h1!x~=h1!y THEN
	$( TransReport(112, currentBranch)
	   ENDCASE $)

	$( LET l, n = h2, 2

	   IF h1!x=s.commalist THEN
	   $( l, n := h3, h2!x

	      IF h2!y~=n THEN
	      $( TransReport(112, currentBranch)
		 ENDCASE $) $)

	   FOR h = l TO l+n-1 DO
	     Assign(h!x, h!y, op)

	   ENDCASE
	$)

      CASE s.name:
	Load(y)
	TEST op=0 THEN
	   TransName(x, s.sp, s.sg,
			(restrictedLanguage -> 0, s.sl), 0, 0)
	ELSE $(
	   LoadLV(x);
	   Out2(s.mod, op);
	   ssp := ssp-1 $);
	ssp := ssp-1;
	ENDCASE

      CASE s.byteap:
	Load(y)
	Load(h2!x)
	Load(h3!x)

	OutOp(s.putbyte)
	ssp := ssp-3

	    // a % b +:= 2 is not allowed

	IF op~=0 THEN
	  TransReport(150, currentBranch)

	ENDCASE

      CASE s.of:
      $( LET selector = EvalConst(h2!x)
	 LET offset = selector & slct.max.offset

	 Load(y)
	 Load(h3!x)

	 TEST selector~=offset THEN $(
	    LET size = selector>>slct.size.shift;
	    LET shift = (selector>>slct.shift.shift) & slct.mask;
	    IF size=0 THEN size := bitswidth-shift;
	    TEST op=0 THEN $(
	       OutOp(s.slctst);
	       Out1(size); Out1(shift); Out1(offset) $)
	    ELSE $(
	       OutOp(s.slctap);
	       Out1(size); Out1(shift); Out1(offset);
	       Out2(s.modslct, op) $) $)

	 ELSE $(
	    Out2(s.ln, offset)
	    OutOp(s.plus)
	    TEST op=0 THEN
	       OutOp(s.stind)
	    ELSE
	       Out2(s.mod, op) $)
	 ssp := ssp-2
	 ENDCASE
      $)

      CASE s.rv: CASE s.vecap:
	 Load(y)
	 LoadLV(x)

	 TEST op=0 THEN
	    OutOp(s.stind)
	 ELSE
	    Out2(s.mod, op);
	 ssp := ssp-2
	 ENDCASE

      CASE s.nil:
	Load(y);
	OutOp(s.stnil);
	ssp := ssp-1;
	ENDCASE

      CASE s.car: CASE s.cdr: CASE s.vcar: CASE s.vcdr:
	IF op~=0 THEN TransReport(150, currentBranch);
	Load(y);
	Load(h2!x);
	OutOp(h1!x+s.stcar-s.car);
	ssp := ssp-2;
	ENDCASE

      DEFAULT:
	TransReport(109, currentBranch)
   $)
$)

AND TransName(x, p, g, l, n, s) BE
$( LET t = FindCell(x)
   LET nam = Name(t)
   LET k, a = name.type!nam, name.value!nam
   LET op = g

   SWITCHON k INTO
   $( DEFAULT:
	TransReport(115, x)
	ENDCASE

      CASE s.local:
	IF t<namepbase THEN TransReport(116, x)
	op := p
	ENDCASE

      CASE s.global:
	ENDCASE

      CASE s.label:
	TEST l=0
	   THEN TransReport(113, x)
	   ELSE op := l
	ENDCASE

      CASE s.number:
	TEST n=0
	   THEN TransReport(113, x)
	   ELSE op := n
	ENDCASE

      CASE s.string:
      CASE s.table:
	TEST s=0 THEN
	   TransReport(113, x)
	ELSE $(
	   LET l =!a
	   IF l=0 THEN $(
	      TEST k=s.string
		 THEN l := define.string(a+1)
		 ELSE l := define.table(a)

	      !a := l $)
	   a := l
	   op := s $)
	ENDCASE

      CASE s.external:
	TEST l=0 THEN
	   TransReport(113, x)
	ELSE $(
	   LET e = a;
	   a := h3!e;
	   IF a=0 THEN $(
	      a := NextParam()
	      h3!e := a $);
	   op := l $)
	ENDCASE
   $)
   Out2(op, a)
$)


AND define.string(sptr) = VALOF
  // Outputs a DSTR operation to define a string, returning
  // the label number as the result.
$( LET l = NextParam()
   Out2(s.dstr, l)
   OutString(sptr)
   RESULTIS l
$)


AND define.table(tab) = VALOF
  // Outputs a DTAB operation to define a table, returning
  // the label as the result.
  //
  //	DTAB l n t1 v1 t2 v2 ..... tn vn
  //
  // The parameter is a pointer to a TABLE object from the
  // parse tree.
$( LET label = NextParam()
   LET keep = nameVecE
   LET ln = trnLineCount
   LET names = h2!tab
   LET listptr = h4+tab
   LET list = ! listptr
   LET v, n = listptr, 1
   LET bsiz = ?
   LET bitmap = ?
   LET word, p, shift = 0, 0, bitsperword-1

     // Find the type and size of the value list

   IF ~SmallNumber(list) THEN $(
      IF h1!list=s.comma THEN $(
	 v := list+1
	 n := 2 $)

      IF h1!list=s.commalist THEN $(
	 v := list+2
	 n := h2!list $) $);

   bsiz := (n-1)/bitsperword+1
   bitmap := GetVector(bsiz)

     // The 'h2' field of a table object holds the end of
     // name vector at the time at which the table was
     // Declared.  If this field is negative, this is the
     // first time that the table has been encountered.
     // Otherwise, the name pointer must be changed while
     // table is being evaluated.

   IF names>=0 THEN nameVecE := names

     // The 'h3' field holds the line number of the table.

   trnLineCount := h3!tab

   FOR j = 0 TO n-1 DO $(
      LET e = v!j
      LET l = extension.level<5 -> 0, CheckLabel(e)
      LET b = 0

      TEST l=0 THEN
	 v!j := EvalConst(e)
      ELSE $(
	 b := 1
	 v!j := l $)

      IF shift<0 THEN $(
	 bitmap!p := word
	 p := p+1
	 word := 0
	 shift := bitsperword-1 $)

      word := word | (b << shift)
      shift := shift-1 $)

   bitmap!p := word
   p := 0
   shift := -1

   // Generate the DTAB operation and Output the types and values.

   Out2(s.dtab, label)
   Out1(n)

   FOR j = 0 TO n-1 DO $(
      IF shift<0 THEN $(
	 word := bitmap!p
	 p := p+1
	 shift := bitsperword-1 $)

      Out2(([(word >> shift) & 1]~=0 -> s.iteml,
					s.itemn),
	   v!j)

      shift := shift-1 $)

   freevector(bitmap)

     // The names pointer and line number can now be reset.

   nameVecE := keep
   trnLineCount := ln

   RESULTIS label
$)

AND CheckLabel(x) = SmallNumber(x) -> 0, VALOF
  // Checks whether the expression defined by 'x' is of
  // 'label' (table or string) or 'numeric' type.  The
  // result is zero or a label number.
$( LET type = h1!x
   LET name = FALSE
   LET thing = x

   IF type=s.name THEN $(
      LET n = FindName(x)

      name := TRUE
      type := name.type!n
      thing := name.value!n $)

   IF type=s.string | type=s.table THEN $(
      LET label = ?

      IF name THEN $(
	 label :=!thing
	 IF label~=0 THEN RESULTIS label $)

      TEST type=s.string
	 THEN label := define.string(thing+1)
	 ELSE label := define.table(thing)

      IF name THEN !thing := label

      RESULTIS label $)

   RESULTIS 0
$)

AND CompLab(l, s) BE
$( IF l~=0 THEN
   $( Out2(s.lab, l);
      accessible := TRUE $);
   IF s>=0 THEN Out2(s.stack, s)
$)

AND CompDataLab(l) BE
$( Out1(s.datalab);
   Out1(l)
$)

AND OutString(x) BE
$( LET l = x%0
   Out1(l)
   FOR i = 1 TO l DO Out1(x%i)
$)

AND OutOp(op) BE
$( IF outLineCount~=trnLineCount THEN $(
      Out1(s.linecount);
      Out1(trnLineCount);
      outLineCount := trnLineCount $);
   Out1(op)
$)

AND Out1(n) BE
   TEST retainOcode THEN
      TEST -127<=n<=127 THEN
	 PByte(n & 255)
      ELSE $(
	 LET shift = 8 * (bytesperword-1)
	 PByte(#X80)

	 FOR j = 1 TO bytesperword DO $(
	    PByte((n >> shift) & 255)
	    shift := shift-8 $) $)

   ELSE $(
      IF n<0 THEN $(
	 wrc('-'); n := - n
	 IF n<0 THEN $(
	    LET ndiv10 = (n >> 1)/5
	    wrpn(ndiv10)
	    n:=n-ndiv10*10 $) $)

      wrpn(n)
      wrc('*s') $)

AND PByte(byte) BE
$( LET ptr = oc.lastbyte!ocodebuf
   IF ptr>=oc.bytes THEN $(
      LET b = GetWithMark(oc.size, ocode.mark)
      !ocodeBuf := b;
      ocodeBuf := b
      oc.next!ocodeBuf := 0
      ptr := oc.firstbyte $)
   ocodeBuf%ptr := byte
   oc.lastbyte!ocodeBuf := ptr+1
$)

AND WrPn(n) BE
$( IF n>9 THEN WrPn(n/10)
   WrC(n REM 10+'0')
$)

AND Out2(x, y) BE $( OutOp(x); Out1(y)	$)

AND WrC(ch) BE
$( ocount := ocount+1
   IF ocount>62 & ch='*S' THEN
   $( WrCh('*N')
      ocount := 0
      RETURN $)
   WrCh(ch)
$)

AND TransReport(n, x) BE
$( LET arg = x+2
   LET str = Output()
   LET s = ?
   LET newrc, wm = 10, "Error";

   SelectOutput(verstream)

   s := VALOF SWITCHON n INTO
   $( DEFAULT: arg := n; RESULTIS "%N"

      CASE 101: RESULTIS "illegal use of DEFAULT"
      CASE 105: RESULTIS "illegal use of CASE"
      CASE 121: RESULTIS "illegal use of ENDCASE"
      CASE 104: RESULTIS "illegal use of BREAK"
      CASE 108: RESULTIS "illegal use of LOOP"
      CASE 107: RESULTIS "illegal use of RESULTIS"
      CASE 106: RESULTIS "two cases with the same constant"
      CASE 109:
      CASE 113: RESULTIS "L-type expression expected"
      CASE 110:
      CASE 112: RESULTIS "LHS and RHS do not match"
      CASE 115: RESULTIS "'%S' not declared"
      CASE 116: RESULTIS "dynamic free variable used ('%S')"
      CASE 117:
      CASE 118:
      CASE 119: RESULTIS "invalid constant expression"
      CASE 120: RESULTIS "invalid parameter in selector"
      CASE 142: RESULTIS "'%S' declared twice"
      CASE 143: RESULTIS "too many names declared"
      CASE 150: RESULTIS "invalid LHS for compound assignment"
      CASE  91: RESULTIS "RETURN used in body of function"
      CASE  92: RESULTIS "value of VALOF block may be undefined"
   $)

   IF n<100 THEN newrc, wm := 5, "Warning";
   WriteF("%s near line %N: ", wm, trnLineCount)
   WriteF(s, arg)

   IF rc>=20 THEN
   $( WriteS("compilation abandoned*N")
      LongJump(err.p, err.l) $)

   IF rc<newrc THEN rc := newrc

   NewLine()
   SelectOutput(str)
$)

.

SECTION "PTree"

GET "b.Header"

STATIC
$( /* Version of 07 Feb 86 13:55:00
   */
   dummy = VersionMark
   version = 1*256+2
$)

/* 1.2	07 Feb 86 13:44:20
     Floating point incorporated
*/

LET bcpl.ptree(a) BE PList(a, 0, 30)

AND PList(x, n, d) BE
$( LET size = 0
   LET v = TABLE 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
		 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
   IF n=0 THEN
     err.p, err.l := Level(), exit

   IF x=0 THEN
   $( WriteS("nil"); RETURN $)

   IF SmallNumber(x) THEN
   $( WriteN(x); RETURN $)

   SWITCHON h1!x INTO
   $( CASE s.number:
	 WriteN(h2!x)
	 RETURN
      CASE s.fconst:
	 WriteF("%nE%n", h2!x, h3!x);
	 RETURN

      CASE s.name:
	 WriteS(x+2)
	 RETURN

      CASE s.string:
	 WriteF("*"%S*"",x+1)
	 RETURN

      CASE s.semicolonlist:
      CASE s.commalist:
	 size := h2!x+2
	 goto out
      CASE s.for:
	 size := size+2

      CASE s.cond:CASE s.fndef:CASE s.rtdef:
      CASE s.test:
	 size := size+1

      CASE s.needs:CASE s.section:CASE s.vecap:
      CASE s.byteap:CASE s.fnap:CASE s.mult:
      CASE s.div:CASE s.rem:CASE s.plus:CASE s.minus:
      CASE s.eq:CASE s.ne:CASE s.ls:CASE s.gr:
      CASE s.le:CASE s.ge:CASE s.lshift:CASE s.rshift:
      CASE s.lle:CASE s.lge:CASE s.lls:CASE s.lgr:
      CASE s.fmult:CASE s.fdiv:CASE s.fplus:CASE s.fminus:
      CASE s.feq:CASE s.fne:CASE s.fls:CASE s.fgr:
      CASE s.fle:CASE s.fge:
      CASE s.logand:CASE s.logor:CASE s.eqv:CASE s.neqv:
      CASE s.comma:CASE s.and:CASE s.valdef:
      CASE s.vecdef:CASE s.ass:CASE s.rtap:CASE s.colon:
      CASE s.if:CASE s.unless:CASE s.while:CASE s.until:
      CASE s.repeatwhile:CASE s.repeatuntil:CASE s.let:
      CASE s.switchon:CASE s.case:
      CASE s.manifest:CASE s.static:CASE s.global:
	 size := size+1

      CASE s.valof:CASE s.lv:CASE s.rv:CASE s.neg:
      CASE s.not:CASE s.abs:CASE s.table:CASE s.goto:
      CASE s.fneg:CASE s.fabs:CASE s.fix:CASE s.float:
      CASE s.resultis:CASE s.repeat:CASE s.default:
      CASE s.car:CASE s.cdr:CASE s.vcar:CASE s.vcdr:
	 size := size+1

      CASE s.loop:CASE s.break:CASE s.return:
      CASE s.finish:CASE s.endcase:CASE s.true:
      CASE s.false:CASE s.query:
      CASE s.nil:
      DEFAULT:
	 size := size+1

out:	 IF n=d THEN
	 $( WriteS("etc"); RETURN $)
	 WriteS("op")
	 WriteN(h1!x)
	 FOR i = 2 TO size DO
	 $( NewLine()
	    FOR j = 0 TO n-1 DO WriteS(v!j)
	    WriteS("**-")
	    v!n := i= size-> "  ","! "
	    PList(h1!(x+i-1), n+1, d)
	 $)
   $)
exit:
$)

