


		    bcpl_cae0.bcpl                  04/22/82  1624.2rew 04/22/82  1125.0       35505


//  Miscellaneous tree-building routines.
//  Last modified on 06/06/74 at 18:03:09 by R F Mabee.
//  Installed on 6180 as Version 3.4, R F Mabee.
//  First installed on 645 as Version 2.7, R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_cae_head"

let Rblock (Rbody, Arg) = valof
     $(	unless Symb = SECTBRA_S do
		test Symb = SECTBEGIN_S
		then DictionaryEntry := 0		//  Ignore "tag" for keyword _b_e_g_i_n.
		or   $(	CaeReport (BlockExpected)
			resultis Rbody (Arg)
		     $)
	let Tag = DictionaryEntry
	Nextsymb ()
	let A = Rbody (Arg)
	unless Symb = SECTKET_S do
		test Symb = SECTEND_S
		then DictionaryEntry := 0		//  As above.
		or   $(	CaeReport (MissingSECTKET)
			resultis A
		     $)
	if Tag = DictionaryEntry do Nextsymb ()		//  If tag on bracket is same string.
	resultis A
     $)

let Rname () = valof
     $(	unless Symb = NAME_S do
	     $(	CaeReport (NameExpected)
		resultis ErrorNode
	     $)
	let x = DictionaryEntry
	Nextsymb ()
	resultis x
     $)
and Rnamelist (PermitREP) = GetCommaNode (Rname, 0, PermitREP)
and GetCommaNode (F, x, PermitREP) = valof
     $(	let Op = LineCount lshift Left | COMMA_S
	let v, i, Max = vec 20, 0, 20
	     $(	i := i + 1
		v!i := F (x)
		if Symb = REP_S & PermitREP do
		     $(	let Xop = LineCount lshift Left | REP_S
			Nextsymb ()
			v!i := List3 (Xop, v!i, Rexp (0))
		     $)
		unless Symb = COMMA_S break
		Nextsymb ()
		if i ge Max do
		     $(	let w = Newvec (Max * 2)
			for j = 1 to i do w!j := v!j
			if Max > 20 do Freevec (v, Max)
		v, Max := w, Max * 2
		     $)
	     $)	repeat
	if i = 1 resultis v!1
	let r = Newvec (i + 1)
	for j = 1 to i do r!(j + 1) := v!j
	r!0, r!1 := Op, i
	if Max > 20 do Freevec (v, Max)
	resultis r
     $)
and ReadList (PermitREP) = GetCommaNode (Rexp, 0, PermitREP)

let Rdef () = valof
     $(	let A, B, C = nil, nil, nil
	let Lc = LineCount lshift Left
	A := Rnamelist (false)
	test Symb = RBRA_S
	then $(	unless (A!0 & Right) = NAME_S do CaeReport (NameExpected)
		Nextsymb ()
		B := 0
		if Symb = NAME_S do B := Rnamelist (true)
		test Symb = RKET_S
		then Nextsymb ()
		or CaeReport (MissingRKET)
		let Ll = LabelList
		LabelList := 0
		let m, Op = 0, Symb
		Nextsymb ()
		test Op = BE_S
		then $(	m := Symb
			if m = MAIN_S do Nextsymb ()
			C := Rcom (8)
			Lc := Lc logor RTDEF_S
		     $)
		or   $(	unless Op = VALDEF_S do CaeReport (MalformedDeclaration)
			C := Rexp (0)
			Lc := Lc logor FNDEF_S
		     $)
		A := List6 (Lc, A, B, C, LabelList, m)
		LabelList := Ll
	     $)
	or   $(	unless Symb = VALDEF_S do CaeReport (MalformedDeclaration)
		Nextsymb ()
		A := List3 (VALDEF_S logor Lc, A, ReadList (true))
	     $)
	unless Symb = AND_S resultis A
	Lc := LineCount lshift Left
	Nextsymb ()
	B := Rdef ()
	resultis List3 (AND_S logor Lc, A, B)
     $)

let Rdeclbody (Op) = valof
     $(	let Match = Op = GLOBAL_S -> COLON_S, VALDEF_S
	let A, B, C = nil, nil, 0
	     $(	A := Rname ()
		test Symb = Match
		then $(	Nextsymb ()
			B := Rexp (0)
		     $)
		or   $(	unless Op = EXTERNAL_S do CaeReport (MalformedDeclaration)
			B := 0
		     $)
		C := List4 (CONSTDEF_S logor LineCount lshift Left, A, B, C)
		unless Symb = SEMICOLON_S break
		Nextsymb ()
	     $)	repeat
	resultis C
     $)

let CAE () = valof
     $(	LabelList := 0
	ErrorNode := List1 (ERROR_S)

	let A = Rcom (0)
	unless LabelList = 0 do A := List3 (LABDEF_S, A, LabelList)	//  Make dummy block for left-over labels.

	unless Symb = ENDPROG_S do
	     $(	CaeReport (PrematureTermination)
		Nextsymb () repeatuntil Symb = ENDPROG_S
	     $)
	resultis A
     $)
   



		    bcpl_cae1.bcpl                  04/22/82  1624.2rew 04/22/82  1125.1       34191


//  Rexp --  read an expression.
//  Last modified on 06/06/74 at 18:03:27 by R F Mabee.
//  Prepared for installation as part of Version 3.4, R F Mabee.
//  First installed as Version 2.7 by R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_cae_head"

let Rexp (n) = valof		//  n is minimum precedence to be read.  It is zero except on recursive calls.
     $(	let A, B, C = nil, nil, nil
	let Op = Symb logor LineCount lshift Left
	A := valof switchon Symb into
	     $(	default:	CaeReport (ExpressionMissing)
			resultis ErrorNode

		case NAME_S:
		case NUMBER_S:
		case CHARCONST_S:
		case STRINGCONST_S:
			B := DictionaryEntry
			Nextsymb ()
			resultis B

		case NIL_S:
		case TRUE_S:
		case FALSE_S:
			Nextsymb ()
			resultis List1 (Op)

		case PLUS_F:
			Op := POS_F
			goto Arith
		case PLUS_S:
			Op := POS_S
			goto Arith
		case MINUS_F:
			Op := NEG_F
			goto Arith
		case MINUS_S:
			Op := NEG_S
		  Arith:	Op := Op logor LineCount lshift Left
			B := 32
			goto Unary
		case NOT_S:
			B := 22
			goto Unary
		case LV_S:
		case RV_S:
			B := 40
		  Unary:	Nextsymb ()
			B := Rexp (B)
			resultis List2 (Op, B)

		case VEC_S:
			Nextsymb ()
			B := Rexp (0)
			resultis List2 (Op, B)

		case LIST_S:
		case TABLE_S:
			Nextsymb ()
			B := ReadList (true)
			resultis List2 (Op, B)

		case VALOF_S:
			Nextsymb ()
			B := Rcom (8)
			resultis List2 (Op, B)

		case RBRA_S:
			Nextsymb ()
			B := Rexp (0)
			test Symb = RKET_S
			then Nextsymb ()
			or CaeReport (MissingRKET)
			resultis B
	     $)

  MORE:
	Op := Symb logor LineCount lshift Left
	B := valof switchon Symb into
	     $(	default:	goto EXIT

		case RBRA_S:
			Op := FNAP_S logor LineCount lshift Left
			Nextsymb ()
			B := Symb = RKET_S -> 0, ReadList (true)
			test Symb = RKET_S
			then Nextsymb ()
			or CaeReport (MissingRKET)
			A := List3 (Op, A, B)
			goto MORE

		case VECAP_S:
			resultis 44

		case SBRA_S:
			if n ge 44 goto EXIT
			Op := VECAP_S logor LineCount lshift Left
			Nextsymb ()
			B := Rexp (0)
			test Symb = SKET_S
			then Nextsymb ()
			or CaeReport (MissingSKET)
			A := List3 (Op, A, B)
			goto MORE

		case MULT_S:
		case MULT_F:
		case DIV_S:
		case DIV_F:
		case REM_S:
			resultis 36

		case PLUS_S:
		case PLUS_F:
		case MINUS_S:
		case MINUS_F:
			resultis 32

		case VALDEF_S:
			Op := EQ_S logor LineCount lshift Left
		case EQ_S:
		case EQ_F:
		case NE_S:
		case NE_F:
		case LS_S:
		case LS_F:
		case LE_S:
		case LE_F:
		case GR_S:
		case GR_F:
		case GE_S:
		case GE_F:
			if n > 28 goto EXIT
			Nextsymb ()
			B := Rexp (28)
			A := List3 (Op, A, B)
			unless n = 28 do A := List2 (REL_S logor LineCount lshift Left, A)
			goto MORE

		case LSHIFT_S:
		case RSHIFT_S:
			resultis 24

		case LOGAND_S:
			resultis 20

		case LOGOR_S:
			resultis 16

		case EQV_S:
			resultis 14

		case NEQV_S:
			resultis 12

		case COND_S:
			if n > 8 goto EXIT
			Nextsymb ()
			B := Rexp (8)
			test Symb = COMMA_S
			then Nextsymb ()
			or CaeReport (MissingCOMMA)
			C := Rexp (8)
			A := List4 (Op, A, B, C)
			goto MORE

		case CHAR_S:
		case BIT_S:
		case TYPE_S:
		case OFFSET_S:
		case LENGTH_S:
			resultis 6

		case FIXED_S:
		case FLOAT_S:
		case DOUBLE_S:
		case POINTER_S:
		case STRING_S:
			if n ge 6 goto EXIT
			A := List2 (Op, A)
			Nextsymb ()
			goto MORE
	     $)
	if n ge B goto EXIT
	Nextsymb ()
	B := Rexp (B)
	A := List3 (Op, A, B)
	goto MORE

  EXIT:
	resultis A
     $)
 



		    bcpl_cae2.bcpl                  04/22/82  1624.2rew 04/22/82  1125.1       55476


//  Rcom -- read command and declaration.
//  Last modified on 06/06/74 at 18:20:51 by R F Mabee.
//  Installed on 6180 with Version 3.4 by R F Mabee.
//  First installed on 645 with Version 2.7 by R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_cae_head"

let Rcom (n) = valof		//  n = 0 means read to end of containing block or program,
				//  n = 8 means accept exactly one command (definitions not allowed),
				//  n = 4 allows definitions but if first item is command, stops after it.
     $(	let A, B, C, D = nil, nil, nil, nil
  Top:	let Op = Symb logor LineCount lshift Left
	switchon Symb into
	     $(	case LET_S:
		case MANIFEST_S: case GLOBAL_S:
		case EXTERNAL_S: case STATIC_S:
			if n ge 8 do CaeReport (MisplacedDeclaration)
			Nextsymb ()
			test (Op & Right) = LET_S
			then A := Rdef ()
			or A := Rblock (Rdeclbody, Op & Right)
			B := Rcom (0)
			resultis List3 (Op, A, B)

		case SEMICOLON_S:
			unless n = 0 resultis 0
			Nextsymb ()
			goto Top

		case SECTBRA_S:
		case SECTBEGIN_S:
			A := Rblock (Rcom, 0)
			goto MORE

		case SECTKET_S:
		case SECTEND_S:
		case ENDPROG_S:
			resultis 0


		case NAME_S: case NUMBER_S: case STRINGCONST_S: case CHARCONST_S:
		case TRUE_S: case FALSE_S: case LV_S: case RV_S: case NOT_S:
		case RBRA_S: case VALOF_S: case PLUS_S: case MINUS_S:
		case LIST_S: case TABLE_S:
			A := ReadList (false)
			Op := Symb logor LineCount lshift Left
			if Symb = ASSIGN_S do
			     $(	Nextsymb ()
				B := ReadList (true)
				A := List3 (Op, A, B)
				goto MORE
			     $)
			if Symb = COLON_S do
			     $(	unless (A!0 & Right) = NAME_S do CaeReport (NameExpected)
				Nextsymb ()
				B := Rcom (n = 0 -> 4, n)		//  Stop at end of command.
				A := List5 (Op, A, B, LabelList, 0)
				LabelList := A
				goto MORE
			     $)
			if (A!0 & Right) = FNAP_S do
			     $(	A!0 := A!0 + RTAP_S - FNAP_S
				goto MORE
			     $)
			CaeReport (IncompleteCommand)
			goto Drain

		case GOTO_S: case RESULTIS_S:
			Nextsymb ()
			A := List2 (Op, Rexp (0))
			goto MORE

		case CALL_S:
			Nextsymb ()
			A := List2 (Op, Rexp (0))
			goto MORE

		case IF_S: case UNLESS_S:
		case WHILE_S: case UNTIL_S:
			Nextsymb ()
			A := Rexp (0)
			test Symb = DO_S
			then Nextsymb ()
			or CaeReport (MissingDO)
			B := Rcom (8)
			A := List3 (Op, A, B)
			goto MORE

		case TEST_S:
			Nextsymb ()
			A := Rexp (0)
			D := Symb
			unless D = DO_S logor D = IFSO_S logor D = IFNOT_S do
			     $(	CaeReport (MalformedTest)
				goto Drain
			     $)
			Nextsymb ()
			B := Rcom (8)
			unless Symb = (D = DO_S -> OR_S, D = IFSO_S -> IFNOT_S, IFSO_S) do
			     $(	CaeReport (MalformedTest)
				Op := D = IFNOT_S -> UNLESS_S, IF_S
				A := List3 (Op, A, B)
				goto Drain
			     $)
			Nextsymb ()
			C := Rcom (8)
			if D = IFNOT_S do
			     $(	let q = B
				B := C
				C := q
			     $)
			A := List4 (Op, A, B, C)
			goto MORE

		case FOR_S:
			Nextsymb ()
			A := Rname ()
			unless Symb = VALDEF_S do
			     $(	CaeReport (ValdefExpected)
				goto Drain
			     $)
			Nextsymb ()
			B := Rexp (0)
			D := 0
			if Symb = BY_S do
			     $(	Nextsymb ()
				D := Rexp (0)
			     $)
			test Symb = TO_S
			then $(	Nextsymb ()
				C := Rexp (0)
			     $)
			or   $(	CaeReport (MissingTO)
				C := ErrorNode
			     $)
			if Symb = BY_S & D = 0 do
			     $(	Nextsymb ()
				D := Rexp (0)
			     $)
			test Symb = DO_S
			then Nextsymb ()
			or CaeReport (MissingDO)
			A := List6 (Op, A, B, C, D, Rcom (8))
			goto MORE

		case BREAK_S: case LOOP_S:
		case RETURN_S: case FINISH_S:
		case ENDCASE_S:
			Nextsymb ()
			A := List1 (Op)
			goto MORE

		case SWITCHON_S:
			Nextsymb ()
			A := Rexp (0)
			test Symb = INTO_S
			then Nextsymb ()
			or CaeReport (MissingINTO)
			B := Rblock (Rcom, 0)
			A := List3 (Op, A, B)
			goto MORE

		case CASE_S:
			Nextsymb ()
			A := Rexp (0)
			B := 0
			if Symb = TO_S do
			     $(	Nextsymb ()
				B := Rexp (0)
			     $)
			test Symb = COLON_S
			then Nextsymb ()
			or CaeReport (MissingCOLON)
			C := Rcom (n = 0 -> 4, n)		//  Pick up just one command.
			A := List4 (Op, A, B, C)
			goto MORE

		case DEFAULT_S:
			Nextsymb ()
			test Symb = COLON_S
			then Nextsymb ()
			or CaeReport (MissingCOLON)
			A := List2 (Op, Rcom (n = 0 -> 4, n))		//  Stop at end of next command.
			goto MORE

		default:	CaeReport (UnrecognizedCommand)

		  Drain:	A := 0
			while true do switchon Symb into		//  Skip past rest of bad command.
			     $(	case SEMICOLON_S:
					if n = 0 goto MORE	//  We're supposed to pick up succeeding commands too.
				case SECTKET_S:		//  All the cases which must begin a new command.
				case SECTEND_S:
				case ENDPROG_S:
				case LET_S:
				case GLOBAL_S:
				case MANIFEST_S:
				case STATIC_S:
				case EXTERNAL_S:
					resultis A
				case AND_S:		//  Botched definition, read rest of it.
					Nextsymb ()
					A := Rdef ()
					loop
				case SECTBRA_S:
				case SECTBEGIN_S:
					A := Rblock (Rcom, 0)
					loop
				default:	Nextsymb ()
			     $)		//  Note indefinite looping.
	     $)

  MORE:	Op := Symb logor LineCount lshift Left
	switchon Symb into
	     $(	case REPEAT_S:
			Nextsymb ()
			A := List2 (Op, A)
			goto MORE

		case REPEATWHILE_S:
		case REPEATUNTIL_S:
			Nextsymb ()
			B := Rexp (0)
			A := List3 (Op, A, B)
			goto MORE

		case SEMICOLON_S:
			unless n = 0 resultis A		//  If we're supposed to read only one command.
			Nextsymb ()
			B := Rcom (0)		//  This picks up all following commands.
			resultis List3 (Op, A, B)

		case SECTKET_S:		//  All the symbols which force the end of the current command.
		case SECTEND_S:
		case ENDPROG_S:
		case LET_S:
		case GLOBAL_S:
		case MANIFEST_S:
		case STATIC_S:
		case EXTERNAL_S:
		case AND_S:
		case OR_S:
			resultis A

		default:	CaeReport (IncompleteCommand)
			goto Drain
	     $)
     $)



		    bcpl_cg0.bcpl                   04/22/82  1624.2rew 04/22/82  1125.1       43416


//  Initialization and termination code for the code generator phase.
//  Last modified on 06/06/74 at 18:21:14 by R F Mabee.
//  Revisions for 6180 installed in Version 3.4, R F Mabee.
//  First installed as part of bcpl_trans0 with Version 2.7 by R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_cg_head"
get "bcpl_metering_head"

let CgInit () be
     $(	NewLiteralsList, OldLiteralsList := 0, 0

	LabTable := Newvec (LabTableSize)
	for i = 0 to LabTableSize do LabTable!i := 0

	if Symbols do
	     $(	SymtabFirst := Newvec (SymtabSize)
		SymtabV, SymtabP := SymtabFirst, 2
	     $)
	if LineMap do
	     $(	LineMapFirst := Newvec (1)
		LineMapFirst!0 := 1
		LineMapList, LineMapLength := LineMapFirst, 1
	     $)

	CodeFirst := Newvec (CodeSize)
	CodeV, CodeP := CodeFirst, 2
	BeginSection (0)

	LinkList, MainEntriesList := 0, 0
	CgTempList := 0
	LabMaxSSP, MaxSSP := 0, 0
	if Crep do
	     $(	LabMaxSSP := Nextparam ()
		DefineLab (LabMaxSSP, 0)		//  To prevent useless error message.
	     $)
	LabMaxArg, MaxArgOffset := 0, 0
	SaveSpaceSize := Machine = 645 -> 4, 2
	StackRefTag := Machine = 645 -> Sp | X1, Sb | X1
	RegisterTemps, RegisterUsage := Newvec (NumberOfRegisters), Newvec (NumberOfRegisters)
	for i = 0 to NumberOfRegisters do RegisterTemps!i, RegisterUsage!i := 0, 0
	UsageCounter := 0

	Jumpsw := not Crep
	DeferredJumpLabel := 0
	EntryLabel, GetLpLabel := 0, 0
	Param, Reloc, Comment := 0, 0, 0
	IndicatorsSetBy := 0
     $)

and FinishText (StaticList, EntriesList) be
     $(	OutLiterals ()
	if Crep do Listing := false	//  Avoid lengthy, useless output if in online-debug mode.
	if GetLpLabel ne 0 do WriteGetlp ()
	if EntryLabel ne 0 do WriteEntry ()
	Jumpsw := false
	TextLength := LC
	if (LC & 1) ne 0 do OutW2 (0, "padding")
	TextRelbits := SaveRelbits ()
	TotalWords := LC

	BeginSection (0)
	WriteDefs (EntriesList)
	DefsLength := LC
	if (LC & 1) ne 0 do OutW2 (0, "padding")
	DefsRelbits := SaveRelbits ()
	TotalWords := TotalWords + LC
	DefsRelbits := 0		//  Discard, not currently needed for new-format object segment.

	BeginSection (0)
	WriteLinkage (StaticList)
	LinkageLength := LC
	if (LC & 1) ne 0 do OutW2 (0, "padding")
	LinkageRelbits := SaveRelbits ()
	TotalWords := TotalWords + LC

	BeginSection (0)
	WriteSymbol ()			//  Counts bits in TextRelbits, etc.
	SymbolRelbits := SaveRelbits ()
	BeginSection (LC)			//  To Multics this is a part of the symbol section without relbits.
	WriteRelBits ()
	SymbolLength := LC
	SaveRelbits ()			//  For listing - not part of object segment.
	TotalWords := TotalWords + LC

	BeginSection (TotalWords)		//  Use absolute location counter for object map.
	WriteObjectMap (TotalWords)
	SaveRelbits ()			//  For listing - not part of object segment.
	TotalWords := LC

	if Listing do WriteS (OUTPUT, "*tend*n")
	CodeV!0, CodeV!1 := 0, CodeP

//  Fill in final addresses for all label references in text.
	let p = CodeFirst
	until p = 0 do
	     $(	for i = 2 to p!1 - 3 by 3 do switchon p!i & Right into
		     $(	case CodeSwitch:
			case InstructionSwitch:
			case DataSwitch:
				let Param = p!i rshift Left
				if Param ne 0 do
				     $(	let N = LookupLabel (Param)
					if N = 0 do CGreport (UndefLab, Param)
					p!(i + 1) := p!(i + 1) + (N lshift 18)
				     $)
				LC := LC + 1
				loop

			case LineCountSwitch:
				LineCount := p!(i + 1)
				loop

			case LabelSwitch:
				if LC ne p!(i + 2) do CGreport (PhaseError, "FinishText")
				loop

			case SectionSwitch:
				LC := p!(i + 1)
			default:
		     $)
		p := p!0
	     $)
     $)
and SaveRelbits () = valof
     $(	if AbsRelBits > 0 do PutAbsBits ()
	RelbitsList!1 := 0
	resultis List2 (RelbitsLength * 36 + RelbitsOffset, RelbitsFirst)
     $)
and BeginSection (NewLC) be
     $(	LC := NewLC
	RelbitsFirst := Newvec (1)
	RelbitsFirst!0 := 0
	RelbitsList := RelbitsFirst
	RelbitsOffset, RelbitsLength, AbsRelBits := 0, 0, 0
	PutCode (SectionSwitch, NewLC, RelbitsList)	//  So listing will agree.
     $)

let BuildObject (s) = valof
     $(	let p, LC = CodeFirst, 0
	until p = 0 do
	     $(	for i = 2 to p!1 - 3 by 3 do switchon p!i & Right into
		     $(	case CodeSwitch:
			case InstructionSwitch:
			case DataSwitch:
				s!LC := p!(i + 1)
				LC := LC + 1
			default:
		     $)
		p := p!0
	     $)
	resultis LC * 36
     $)

and WriteObjectListing () be
     $(	let p = CodeFirst
	until p = 0 do
	     $(	for i = 2 to p!1 - 3 by 3 do ListCodeItem (lv p!i)
		p := p!0
	     $)
     $)



		    bcpl_cg1.bcpl                   04/22/82  1624.2rew 04/22/82  1125.1       90117


//  Arithmetic sequences are generated by these routines.
//  Last modified on 06/06/74 at 18:21:22 by R F Mabee.
//  First installed as Version 3.4 by R F Mabee.
//  Written in April 1973 to properly divide the work between Trans and CG.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_cg_head"
get "bcpl_opcodes"

let ApplyDiadicOperator (Op, Result) be
     $(	let Reg = valof switchon Op into
	     $(	case PLUS_S:
			if Optimize then if TryDiadicRAR (Result, Asa) resultis 0
			resultis ApplySymmetrical (Ada, AorQr)
	
		case PLUS_F:
			resultis ApplySymmetrical (Fad, EAQr)
	
		case MINUS_S:
			if Optimize do
			     $(	if TryDiadicRAR (Result, Ssa) resultis 0
				if InRegister (Rrand, AorQr) & not InRegister (Lrand, AorQr) do
				     $(	let r = ApplyRL (Sba, AorQr)
					resultis ApplyNegate (r)
				     $)
			     $)
			resultis ApplyLR (Sba, AorQr)
	
		case MINUS_F:
			if Optimize then if InRegister (Rrand, EAQr) do
				     $(	ApplyRL (Fsb, EAQr)
					resultis ApplyNegate (EAQr)
				     $)
			resultis ApplyLR (Fsb, EAQr)
	
		case MULT_S:
			if Optimize do
			     $(	let r = TryShift (Lrand, Rrand)
				if r ne 0 resultis r
				r := TryShift (Rrand, Lrand)
				if r ne 0 resultis r
				if (InRegister (Lrand, Ar) & not InRegister (Rrand, Qr))
				   | (InRegister (Rrand, Ar) & not InRegister (Lrand, Qr)) do SwapAandQ ()
			     $)
			GetRegister (Ar)		//  Overwritten by multiply hardware.
			resultis ApplySymmetrical (Mpy, Qr)
	
		case MULT_F:
			resultis ApplySymmetrical (Fmp, EAQr)
	
		case DIV_S:
			if Optimize then if InRegister (Lrand, Ar) do SwapAandQ ()
			GetRegister (Ar)		//  Overwritten by divide hardware.
			resultis ApplyLR (Div, Qr)
	
		case DIV_F:
			if Optimize then if InRegister (Rrand, EAQr) do
				resultis ApplyRL (Fdi, EAQr)
			resultis ApplyLR (Fdv, EAQr)
	
		case REM_S:
			if Optimize then if InRegister (Lrand, Ar) do SwapAandQ ()
			GetRegister (Ar)		//  Remainder appears in Ar but operands do not.
			ApplyLR (Div, Qr)
			resultis Ar
	
		case LOGOR_S:
			if Optimize then if TryDiadicRAR (Result, Orsa) resultis 0
			resultis ApplySymmetrical (Ora, AorQr)
	
		case LOGAND_S:
			if Optimize then if TryDiadicRAR (Result, Ansa) resultis 0
			resultis ApplySymmetrical (Ana, AorQr)
	
		case NEQV_S:
			if Optimize then if TryDiadicRAR (Result, Ersa) resultis 0
			resultis ApplySymmetrical (Era, AorQr)
	
		case EQV_S:    $(	let r = ApplySymmetrical (Era, AorQr)
				Literal (true, "true")
				Outop (FormOpcode (Era, r))
				resultis r
			     $)
	
		default:	CGreport (UnexpectedCase, Op, "ApplyDiadicOperator")
			resultis 0
	     $)
	DisclaimRegister (Lrand)
	DisclaimRegister (Rrand)
	ClaimRegister (Reg, Result)
     $)

and ApplyOffsetOperator (Op, Result, Offset) be
     $(	let Reg = valof switchon Op into
	     $(	case VECAP_S:
			if Result!0 = LV_TEMP goto RememberAddress
			let r = GetRegister (AorQr)
			CombineAddress (Lrand, Rrand, Offset)
			Outop (FormOpcode (Lda, r))
			IndicatorsSetBy := r
			resultis r
	
		case LVECAP_S:
			if Result!0 = LV_TEMP goto RememberAddress
			if Optimize then if IsSameLoc (Result, Lrand) do
			     $(	let r = nil
				test IsZero (Rrand)
				then $(	if Offset = 1 do
					     $(	SetupAddr (Result)
						Outop (Aos)
						IndicatorsSetBy := 0
						resultis 0
					     $)
					r := LoadNumber (Offset, AorQr)
				     $)
				or   $(	r := LoadRegister (Rrand, AorQr)
					unless Offset = 0 do
					     $(	Literal (Offset)
						Outop (FormOpcode (Ada, r))
					     $)
				     $)
				SetupAddr (Result)
				Outop (FormOpcode (Asa, r))
				IndicatorsSetBy := 0
				RegisterUsage!r := 0
				resultis 0
			     $)
			r := GetRegister (AnyPr)
			CombineAddress (Lrand, Rrand, Offset)
			Outop (FormOpcode (Eapap, r))
			resultis r
	
		RememberAddress:
			let h = MakeCgTemp (Result!1)
			h!1 := Op
			h!2, h!3, h!4 := Lrand!0, Lrand!1, Lrand!2
			h!5, h!6, h!7 := Rrand!0, Rrand!1, Rrand!2
			h!8 := Offset
			return

		case LSHIFT_S:
		case RSHIFT_S:
			     $(	let r = LoadRegister (Lrand, AorQr)
				let Xr = IsZero (Rrand) -> 0, LoadIndex (Rrand, AnyXr)
				Outop3 (FormOpcode (Op = LSHIFT_S -> Als, Arl, r), Offset, FormTag (Xr))
				IndicatorsSetBy := r
				resultis r
			     $)
	
		default:	CGreport (UnexpectedCase, Op, "ApplyAddressOperator")
			resultis 0
	     $)
	DisclaimRegister (Lrand)
	DisclaimRegister (Rrand)
	ClaimRegister (Reg, Result)
     $)

and ApplyMonadicOperator (Op, Result) be
     $(	let Reg = valof switchon Op into
	     $(	case POS_S:
		case POS_F:
		case ASSIGN_S:
			if Optimize then if Result!0 ne LV_TEMP do
			     $(	Store (Lrand, Result)
				resultis 0
			     $)
			resultis LoadAppropriateRegister (Lrand, 0)
	
		case NEG_S:
			if Optimize then if TryMonadicRAR (Result, Ssa, 0) resultis 0
			resultis LoadNegative (Lrand)
	
		case NEG_F:
			resultis ApplyNegate (LoadRegister (Lrand, EAQr))
	
		case NOT_S:
			if Optimize then if TryMonadicRAR (Result, Ersa, true) resultis 0
			let r = FindInRegister (Lrand, AorQr)
			test r = 0
			then $(	r := LoadNumber (true, AorQr, "true")
				Makeaddressable (Lrand)
			     $)
			or Literal (true, "true")
			Outop (FormOpcode (Era, r))
			IndicatorsSetBy := r
			resultis r

		default:	CGreport (UnexpectedCase, Op, "ApplyMonadicOperator")
			resultis 0
	     $)
	DisclaimRegister (Lrand)
	ClaimRegister (Reg, Result)
     $)
	
and ApplySymmetrical (Inst, Reg) = InRegister (Rrand, Reg) -> ApplyRL (Inst, Reg), ApplyLR (Inst, Reg)
and ApplyRL (Inst, Reg) = valof
     $(	let t, u = Lrand, Rrand
	Rrand, Lrand := t, u
	let r = ApplyLR (Inst, Reg)
	Lrand, Rrand := t, u
	resultis r
     $)
and ApplyLR (Inst, Reg) = valof
     $(	let r = LoadRegister (Lrand, Reg)
	Makeaddressable (Rrand)
	Outop (FormOpcode (Inst, r))
	IndicatorsSetBy := r
	resultis r
     $)
and ApplyNegate (r) = valof
  switchon r into
     $(	case Qr:	if RegisterTemps!Ar = 0 do
		     $(	Outop3 (Negl, 0, Dl)
			IndicatorsSetBy := 0
			resultis Qr
		     $)
		SwapAandQ ()
	case Ar:	Outop3 (Neg, 0, Dl)
		IndicatorsSetBy := Ar
		resultis Ar
	case EAQr:Outop3 (Fneg, 0, Dl)
		IndicatorsSetBy := EAQr
		resultis EAQr
	default:	CGreport (UnexpectedCase, r, "ApplyNegate")
		resultis r
     $)
and LoadNegative (t) = valof
     $(	let r = FindInRegister (t, AorQr)
	if r ne 0 resultis ApplyNegate (r)
	r := GetRegister (AorQr)
	Makeaddressable (t)
	Outop (FormOpcode (Lca, r))
	IndicatorsSetBy := r
	resultis r
     $)

and TryShift (Rand, Const) = valof
     $(	unless IsNumber (Const) resultis 0
	let n, i = EvalNumber (Const!0, Const!1), 0
	until n = (1 lshift i) do
	     $(	if i > 36 resultis 0
		i := i + 1
	     $)
	let r = LoadRegister (Rand, AorQr)
	Outop3 (FormOpcode (Als, r), i, 0)
	IndicatorsSetBy := r
	resultis r
     $)

and TryMonadicRAR (Result, Op, Const) = valof
     $(	unless IsSameLoc (Result, Lrand) resultis false
	let r = LoadNumber (Const, AorQr, 0)
	SetupAddr (Result)
	Outop (FormOpcode (Op, r))
	IndicatorsSetBy := 0
	RegisterUsage!r := 0
	resultis true
     $)
and TryDiadicRAR (Result, Op) = valof
     $(	let X = Rrand
	unless IsSameLoc (Result, Lrand) do
	     $(	X := Lrand
		unless IsSameLoc (Result, Rrand) resultis false
	     $)
	if Op = Asa & IsNumber (X) then if EvalNumber (X!0, X!1) = 1 do
	     $(	SetupAddr (Result)
		Outop (Aos)
		IndicatorsSetBy := 0
		resultis true
	     $)
	let r = nil
	test Op = Ssa & X = Rrand
	then r, Op := LoadNegative (X), Asa
	or r := LoadRegister (X, AorQr)
	SetupAddr (Result)
	Outop (FormOpcode (Op, r))
	IndicatorsSetBy := 0
	RegisterUsage!r := 0
	resultis true
     $)

and IsSameLoc (t, u) = valof
  switchon t!0 into
     $(	case LV_GLOBAL:
		resultis u!0 = GLOBAL_S & t!1 = u!1 -> true, false
	case LV_LOCAL:
		resultis u!0 = LOCAL_S & t!1 = u!1 -> true, false
	case LV_STATIC:
		resultis u!0 = STATIC_S & t!1 = u!1 -> true, false
	case TEMP_S:
		unless u!0 = TEMP_S resultis false
		let g, h = LookupTemp (t!1), LookupTemp (u!1)
		if g = 0 | h = 0 resultis false
		unless g!1 = LVECAP_S & h!1 = VECAP_S resultis false
		resultis g!2 = h!2 & g!3 = h!3 & g!5 = h!5 & g!6 = h!6 & g!8 = h!8 -> true, false
	default:	resultis false
     $)

and DiadicJumpcond (Op, L) be
     $(	let Reversed = valof switchon Op into
	     $(	case EQ_S: case NE_S: case LS_S: case GR_S: case LE_S: case GE_S:
			if IsZero (Rrand) do
			     $(	CompareToZero (Lrand)
				resultis false
			     $)
			if IsZero (Lrand) do
			     $(	CompareToZero (Rrand)
				resultis true
			     $)
			if InRegister (Rrand, AorQr) do
			     $(	ApplyRL (Cmpa, AorQr)
				IndicatorsSetBy := 0
				resultis true
			     $)
			ApplyLR (Cmpa, AorQr)
			IndicatorsSetBy := 0
			resultis false
	
		case EQ_F: case NE_F: case LS_F: case GR_F: case LE_F: case GE_F:
			if InRegister (Rrand, EAQr) do
			     $(	ApplyRL (Fcmp, EAQr)
				IndicatorsSetBy := 0
				resultis true
			     $)
			ApplyLR (Fcmp, EAQr)
			IndicatorsSetBy := 0
			resultis false

		default:	CGreport (UnexpectedCase, Op, "DiadicJumpcond")
			return
	     $)

	let t = valof switchon Op into
	     $(	case EQ_S: case EQ_F:	resultis Tze
		case NE_S: case NE_F:	resultis Tnz
		case LS_S: case LS_F:	resultis Reversed -> Tpnz, Tmi
		case GR_S: case GR_F:	resultis Reversed -> Tmi, Tpnz
		case LE_S: case LE_F:	resultis Reversed -> Tpl, Tmoz
		case GE_S: case GE_F:	resultis Reversed -> Tmoz, Tpl
	     $)

	if Machine = 645 test t = Tmoz
		then $(	Outop2 (Tmi, L)
			t := Tze
		     $)
		or if t = Tpnz do
		     $(	Outop3 (Tze, 2, Ic)
			t := Tpl
		     $)
	Outop2 (t, L)
	DisclaimRegister (Lrand)
	DisclaimRegister (Rrand)
     $)

and MonadicJumpcond (Op, L) be
     $(	CompareToZero (Lrand)
	Outop2 (Op = TRUE_S -> Tnz, Tze, L)
	DisclaimRegister (Lrand)
     $)
   



		    bcpl_cg2.bcpl                   04/22/82  1624.2rew 04/22/82  1125.1       70128


//  Routines to manage labels, literals, and CG temporaries.
//  Last modified on 06/14/74 at 01:14:45 by R F Mabee.
//  Revised for 6180 and installed with Version 3.4 of the compiler, R F Mabee.
//  First installed with Version 2.7 by R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_cg_head"
get "bcpl_opcodes"

let LookupTemp (a) = valof
     $(	let h = CgTempList
	until h = 0 do
	     $(	if h!0 = a resultis h
		h := h!CgTempSize
	     $)
	resultis 0
     $)
and MakeCgTemp (a) = valof
     $(	let h = LookupTemp (a)
	if h ne 0 resultis h
	h := Newvec (CgTempSize)
	h!CgTempSize := CgTempList
	CgTempList := h
	h!0, h!1 := a, 0
	resultis h
     $)

let IsNumber (t) = valof
  switchon t!0 into
     $(	case NUMBER_S: case CONSTANT_S: case CHARCONST_S: case TRUE_S: case FALSE_S:
		resultis true
	default:	resultis false
     $)
and EvalNumber (Op, N) = valof
  switchon Op into
     $(	case NUMBER_S:
		resultis ConvertStoN (N)
	case CONSTANT_S:
		resultis N
	case CHARCONST_S:
		resultis FormCharconst (N)
	case TRUE_S:
		resultis true
	case FALSE_S:
		resultis false
	default:	CGreport (UnexpectedCase, Op, "EvalNumber")
		resultis 0
     $)
and IsZero (t) = IsNumber (t) -> EvalNumber (t!0, t!1) = 0, false
and IsAddress (t) = valof
  switchon t!0 into
     $(	case STRINGCONST_S: case EXTERNAL_S: case TABLE_S:
	case LABEL_S: case RTDEF_S:
	case LV_GLOBAL: case LV_LOCAL: case LV_STATIC:
	case LV_TEMP: case LV_ARG_OUT:
		resultis true
	case TEMP_S:
		let h = LookupTemp (t!1)
		if h = 0 resultis false
		resultis h!1 = REGISTER_S -> Satisfactory (h!2, AnyPr), h!1 = LVECAP_S
	case GLOBAL_S: case LOCAL_S: case STATIC_S:
	case NUMBER_S: case CONSTANT_S: case CHARCONST_S: case TRUE_S: case FALSE_S:
		resultis false
	default:	CGreport (UnexpectedCase, t!0, "IsAddress")
		resultis false
     $)
and IsStored (t) = valof
  switchon t!0 into
     $(	case GLOBAL_S: case LOCAL_S: case STATIC_S:
		resultis true
	case TEMP_S:
		let h = LookupTemp (t!1)
		if h = 0 resultis true
		resultis h!1 = VECAP_S
	default:	resultis false
     $)
and FindInRegister (t, r) = valof
     $(	unless t!0 = TEMP_S resultis 0
	let h = LookupTemp (t!1)
	if h = 0 resultis 0
	test h!1 = REGISTER_S
	then if Satisfactory (h!2, r) resultis h!2
	or if h!1 = LVECAP_S & IsZero (lv h!5) & h!8 = 0 resultis FindInRegister (lv h!2, r)
	resultis 0
     $)
and InRegister (t, r) = (FindInRegister (t, r) ne 0)

and CombineAddress (Pointer, Index, Delta) be
     $(	let Pr = GetRegister (AnyPr)		//  Might not need it.
	and Xr = IsZero (Index) -> 0, LoadIndex (Index, AnyXr)
	SetupAddr (Pointer)
	Comment := 0		//  Misleading comment.
	test (Tag & TagXrMask) ne 0 & Xr ne 0 logor (Tag & Star) ne 0 & Delta ne 0
	then $(	Outop (FormOpcode (Eapap, Pr))
		Address, Tag, Param := Delta, FormTag (Xr) | FormTag (Pr), 0
	     $)
	or   $(	Address := Address + Delta
		unless Xr = 0 do
		     $(	Tag := Tag | FormTag (Xr)
			if (Tag & Star) ne 0 do Tag := Tag + StarThenReg - Star
		     $)
	     $)
     $)
and ClaimRegister (r, t) be
	test r = 0
	then DisclaimRegister (t)		//  Was already stored.
	or test t!0 = LV_TEMP
	then $(	let h = MakeCgTemp (t!1)
		h!1, h!2 := REGISTER_S, Preserve (r)
		RegisterTemps!r := h
	     $)
	or   $(	StoreRegister (r, t)
		DisclaimRegister (t)
	     $)
and DisclaimRegister (t) be
     $(	unless t!0 = TEMP_S return
	let h = LookupTemp (t!1)
	if h = 0 return
	test h!1 = REGISTER_S
	then RegisterTemps!(h!2), RegisterUsage!(h!2) := 0, 0
	or   $(	DisclaimRegister (lv h!2)
		DisclaimRegister (lv h!5)
	     $)
	let p = lv CgTempList
	until rv p = 0 do
	     $(	if rv p = h do
		     $(	rv p := h!CgTempSize
			break
		     $)
		p := lv ((rv p)!CgTempSize)
	     $)
	Freevec (h, CgTempSize)
     $)

let Complab (L) be
     $(	unless DeferredJumpLabel = 0 do
	     $(	unless DeferredJumpLabel = L do
		     $(	Jumpsw := false
			Outop2 (Tra, DeferredJumpLabel)
		     $)
		DeferredJumpLabel := 0
	     $)
	ClearRegisters ()
	ClearMemory ()
	if Listing do Format (OUTPUT, "L^d:", L)
	PutCode (LabelSwitch, L, LC)
	DefineLab (L, LC)
	Jumpsw, IndicatorsSetBy := false, 0
     $)
and DefineLab (L, n) be
     $(	let P = LabelCell (L)
	unless rv P = 0 do CGreport (DupLabel, L)
	rv P := 1 lshift Left logor n
     $)
and LookupLabel (L) = rv LabelCell (L)
and LabelCell (L) = valof
     $(	unless 0 < L < LabTableSize * 100 do
	     $(	CGreport (BadLabel, L)
		L := 0
	     $)
	let Q = L / 100
	let P = LabTable!Q
	if P = 0 do
	     $(	P := Newvec (100 - 1)
		for i = 0 to 100 - 1 do P!i := 0
		LabTable!Q := P
	     $)
	resultis lv P!(L rem 100)
     $)
and Compjump (n) be
     $(	unless Jumpsw do DeferredJumpLabel := n
	Jumpsw := true
     $)
and ClearMemory () be
	return
and ClearRegisters () be
     $(	let T = table Xr2, Xr3, Xr4, Xr5, Xr6, Apr, Abr, Bpr, Bbr, Lbr, Ar, Qr, EAQr
	for i = 0 to 12 do GetRegister (T!i)
     $)

and Outstring (s) be
     $(	let v = vec Vmax
	let Len = FormStringconst (s, v)
	Comment := s
	for i = 0 to Len do OutData (v!i)
     $)
and OutLiterals () be
     $(	if NewLiteralsList = 0 return
	ClearRegisters ()
	SectionHeader ("*nLiteral pool")
	let HaveAlignmentRequirements = true
	until NewLiteralsList = 0 do
	     $(	let Alignment = 2 - (LC & 1)
		if HaveAlignmentRequirements do
		     $(	let t, B = NewLiteralsList, false
			until t = 0 do
			     $(	if t!3 = Alignment do
				     $(	PutOneLiteral (t)
					goto OuterLoop
				     $)
				if t!3 ne 0 do B := true
				t := t!4
			     $)
			HaveAlignmentRequirements := B
		     $)
		let t = NewLiteralsList
		until t = 0 do
		     $(	if t!3 = 0 do
			     $(	t!3 := Alignment
				PutOneLiteral (t)
				goto OuterLoop
			     $)
			t := t!4
		     $)
		HaveAlignmentRequirements := true
		Comment := "padding"
		OutData (0)
	OuterLoop:
	     $)
     $)
and PutOneLiteral (t) be
     $(	let u = lv NewLiteralsList
	until rv u = t do u := lv (rv u)!4
	rv u := t!4
	Comment := t!2
	let P = t!0
	for i = 0 to t!1 * 2 - 2 by 2 do
	     $(	unless P!i = 0 do Complab (P!i)
		OutData (P!(i + 1))
	     $)
	t!4 := OldLiteralsList
	OldLiteralsList := t
     $)

and AddLiteral (P, Len, C, Alignment) be
     $(	let Data, Ent = Newvec (Len * 2 - 1), Newvec (4)
	for i = 0 to Len - 1 do Data!(i * 2), Data!(i * 2 + 1) := 0, P!i
	Ent!0, Ent!1, Ent!2, Ent!3, Ent!4 := Data, Len, C, Alignment, NewLiteralsList
	NewLiteralsList := Ent

	let t = Ent!4
	until t = 0 do
	     $(	if CombineLiteral (Ent, t) return
		t := t!4
	     $)
	t := OldLiteralsList
	until t = 0 do
	     $(	if CombineLiteral (Ent, t) return
		t := t!4
	     $)
	t := Ent!4
	until t = 0 do
	     $(	CombineLiteral (t, Ent)
		t := t!4
	     $)
	if Data!0 = 0 do Data!0 := Nextparam ()
	Address, Tag, Param, Comment := 0, 0, Data!0, C
     $)
and CombineLiteral (New, Old) = valof
     $(	let Ndata, Odata = New!0, Old!0
	for i = 0 to Old!1 - New!1 do
	     $(	for j = 0 to New!1 - 1 if Ndata!(j * 2 + 1) ne Odata!((i + j) * 2 + 1)
					| Ndata!(j * 2) ne 0 & Odata!((i + j) * 2) ne 0 goto OuterLoop
		if New!3 ne 0 test Old!3 ne 0
			then unless ((New!3 + Old!3 + i) & 1) = 0 goto OuterLoop
			or Old!3 := 2 - ((New!3 + i) & 1)
		for j = 0 to New!1 - 1 if Ndata!(j * 2) ne 0 do Odata!((i + j) * 2) := Ndata!(j * 2)
		Address, Tag, Param := i, 0, Odata!0
		let u = lv NewLiteralsList
		until rv u = New do u := lv (rv u)!4
		rv u := New!4
		Freevec (Ndata, New!1 * 2 - 1)
		Freevec (New, 4)
		resultis true
	OuterLoop:
	     $)
	resultis false
     $)



		    bcpl_cg3.bcpl                   04/22/82  1624.2rew 04/22/82  1125.1       65196


//  Primitives to manipulate registers and addresses.
//  Last modified on 06/06/74 at 18:22:13 by R F Mabee.
//  Revised for 6180 and installed with Version 3.4 of the compiler, R F Mabee.
//  First installed with Version 2.7 by R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_cg_head"
get "bcpl_opcodes"

//  LoadRegister moves a CG operand into an arithmetic register.

let LoadRegister (t, r) = valof
     $(	let q = FindInRegister (t, r)
	if q ne 0 resultis Preserve (q)
	if r = Ar | r = Qr then if FindInRegister (t, Qr + Ar - r) ne 0 do
	     $(	SwapAandQ ()
		resultis Preserve (r)
	     $)
	if IsNumber (t) resultis LoadNumber (EvalNumber (t!0, t!1), r, t!2)
	r := GetRegister (r)
	Makeaddressable (t)
	Outop (r = EAQr -> Fld, FormOpcode (Lda, r))
	IndicatorsSetBy := r
	resultis Preserve (r)
     $)
and LoadNumber (n, r, c) = valof
     $(	r := GetRegister (r)
	let Op = Lda
	test r = EAQr
	then Op := Fld
	or if n < 0 then unless n = (1 lshift 35) do Op, n := Lca, - n	//  Can't complement most negative number.
	Literal (n, c)
	Outop (FormOpcode (Op, r))
	IndicatorsSetBy := r
	resultis Preserve (r)
     $)
and SwapAandQ () be
     $(	Outop4 (Llr, 36, 0, "exchange A and Q")
	IndicatorsSetBy := 0
	let p, q = RegisterTemps!Ar, RegisterTemps!Qr
	RegisterTemps!Ar, RegisterTemps!Qr := q, p
	if p ne 0 do p!2 := Qr
	if q ne 0 do q!2 := Ar
     $)
and LoadPointer (t, r) = valof
     $(	let q = FindInRegister (t, r)
	if q ne 0 resultis Preserve (q)
	r := GetRegister (r)
	test IsAddress (t)
	then $(	SetupAddr (t)
		Outop (FormOpcode (Eapap, r))
	     $)
	or   $(	Makeaddressable (t)
		Outop (FormOpcode (Lprpap, r))
	     $)
	resultis Preserve (r)
     $)
and LoadIndex (t, r) = valof
     $(	let q = FindInRegister (t, r)
	if q = 0 & r = AnyXr do q := FindInRegister (t, AorQr)	//  A and Q can be used as index registers.
	if q ne 0 resultis Preserve (q)
	r := GetRegister (r)
	test IsAddress (t)
	then $(	SetupAddr (t)
		Outop (FormOpcode (Eax0, r))
	     $)
	or   $(	Makeaddressable (t)
		Outop (FormOpcode (Lxl0, r))
	     $)
	IndicatorsSetBy := r
	resultis Preserve (r)
     $)
and LoadAppropriateRegister (t, r) = valof
     $(	if r = 0 do
	     $(	r := FindInRegister (t, AorQr)
		if r = 0 do r := FindInRegister (t, AnyPr)
		if r = 0 do r := FindInRegister (t, EAQr)
		if r ne 0 resultis Preserve (r)
		r := IsAddress (t) -> AnyPr, AorQr
	     $)
	if r = AorQr | Satisfactory (r, AorQr) | r = EAQr resultis LoadRegister (t, r)
	if r = AnyPr | Satisfactory (r, AnyPr) resultis LoadPointer (t, r)
	CGreport (UnexpectedCase, r, "LoadAppropriateRegister")
	resultis Ar
     $)

and Makeaddressable (t) be
     $(	test IsNumber (t)
	then Literal (EvalNumber (t!0, t!1), t!2)
	or test IsStored (t)
	then SetATP (t)
	or   $(	let u = list LV_GLOBAL, 0, 0		//  Temporary cell.
		Store (t, u)
		Address, Tag, Param := 0, Sp, 0
	     $)
	unless t!2 = 0 do Comment := t!2
     $)
and SetupAddr (t) be
     $(	test IsAddress (t)
	then SetATP (t)
	or   $(	let r = LoadPointer (t, AnyPr)
		Address, Tag, Param := 0, FormTag (r), 0
	     $)
	unless t!2 = 0 do Comment := t!2
     $)
and SetATP (t) be
     $(	Address, Tag, Param := 0, 0, 0
	switchon t!0 into
	     $(	case GLOBAL_S: case LV_GLOBAL:
			Address, Tag := t!1, Sp
			endcase
		case TEMP_S:
			let h = LookupTemp (t!1)
			if h ne 0 then if h!1 = VECAP_S | h!1 = LVECAP_S do
			     $(	CombineAddress (lv h!2, lv h!5, h!8)
				endcase
			     $)
		case LOCAL_S: case LV_LOCAL:
		case LV_TEMP:
			Address, Tag := t!1 + SaveSpaceSize, StackRefTag
			endcase
		case LV_ARG_OUT:
			Address, Tag, Param := t!1 + SaveSpaceSize, StackRefTag, LabMaxSSP
			endcase
		case STATIC_S: case LV_STATIC:
			Address, Tag := t!1 + 8, Lp
			endcase
		case EXTERNAL_S:
			Tag, Param := Lp | Star, Compexternal (t!1)
			endcase
		case LABEL_S: case RTDEF_S:
			Param := t!1
			endcase
		case STRINGCONST_S:
			Compstring (t!1)
			endcase
		case TABLE_S:
			Comptable (t!1)
			endcase
		default:	CGreport (UnexpectedCase, t!0, "SetATP")
	     $)
	CheckAddr ()
     $)
and CompareToZero (t) be
     $(	let r = FindInRegister (t, AorQr)
	test r ne 0
	then unless r = IndicatorsSetBy do
	     $(	Outop3 (FormOpcode (Cmpa, r), 0, Dl)
		IndicatorsSetBy := r
	     $)
	or   $(	Makeaddressable (t)
		Outop (Szn)
		IndicatorsSetBy := 0
	     $)
     $)

and StoreRegister (r, To) be
     $(	let Op = valof switchon r into
	     $(	case Ar: case Qr:
		default:
			resultis Sta
		case Apr: case Abr: case Bpr: case Bbr: case Lbr:
			resultis Sprpap
		case EAQr:
			resultis Fstr
	     $)
	SetupAddr (To)
	test Machine = 645 & Op = Sprpap
	then $(	let A, T, P = Address, Tag, Param
		Outop (FormOpcode (Sprpap, r + 1))
		Outop3 (Eax0, 0, FormTag (r))
		Address, Tag, Param := A, T, P
		Outop (Sxl0)
	     $)
	or Outop (FormOpcode (Op, r))
	RegisterUsage!r := 0		//  Indicate register not needed for anything.
     $)
and Store (From, To) be
	test IsZero (From)
	then $(	SetupAddr (To)
		Outop (Stz)
	     $)
	or   $(	let r = LoadAppropriateRegister (From, 0)
		StoreRegister (r, To)
	     $)

and Preserve (r) = valof
     $(	UsageCounter := UsageCounter + 1
	RegisterUsage!r := UsageCounter
	resultis r
     $)
and GetRegister (r) = valof
     $(	switchon r into
	     $(	default:	CGreport (UnexpectedCase, r, "GetRegister")
			r := Ar

		case Ar: case Qr:
			MakeAvailable (EAQr)		//  EAQr overlaps both Ar and Qr.
			endcase

		case EAQr:
			MakeAvailable (Ar)
			MakeAvailable (Qr)
			endcase

		case Xr2: case Xr3: case Xr4: case Xr5: case Xr6:
		case Apr: case Abr: case Bpr: case Bbr: case Lbr:
			endcase

		case AorQr:
			r := RegisterUsage!Ar < RegisterUsage!Qr -> Ar, Qr
			MakeAvailable (EAQr)
			endcase

		case AnyPr:
			r := RegisterUsage!Bpr < RegisterUsage!Apr -> Bpr, Apr
			if Machine = 6180 do
			     $(	let T = table Abr, Bbr, Lbr
				for i = 0 to 2 if RegisterUsage!(T!i) < RegisterUsage!r do r := T!i
			     $)
			endcase

		case AnyXr:
			r := Xr2
			let T = table Xr3, Xr4, Xr5, Xr6
			for i = 0 to 3 if RegisterUsage!(T!i) < RegisterUsage!r do r := T!i
			endcase
	     $)
	MakeAvailable (r)
	resultis r
     $)
and Satisfactory (r, q) = valof
     $(	switchon q into
	     $(	case AnyXr:
			if r = Xr2 | r = Xr3 | r = Xr4 | r = Xr5 | r = Xr6 resultis true
			resultis false
		case AorQr:
			if r = Ar | r = Qr resultis true
			resultis false
		case AnyPr:
			if r = Apr | r = Abr | r = Bpr | r = Bbr | r = Lbr resultis true
			resultis false
		default:	resultis r = q
	     $)
     $)
and MakeAvailable (r) be
     $(	let h = RegisterTemps!r
	if h = 0 return
	let To = list LV_TEMP, h!0, "temporary"
	StoreRegister (r, To)
	RegisterTemps!r, RegisterUsage!r := 0, 0
	h!0 := -1
     $)

and Literal (n, c) be
     $(	Address, Tag, Param, Comment := n & $8777777, Dl, 0, c
	if Address = n return
	test Address = 0
	then Address, Tag := n rshift 18, Du
	or AddLiteral (lv n, 1, c, 0)
     $)



		    bcpl_cg4.bcpl                   04/22/82  1624.2rew 04/22/82  1125.1       74133


//  ******************************************************
//  *                                                    *
//  *                                                    *
//  * Copyright (c) 1972 by Massachusetts Institute of   *
//  * Technology and Honeywell Information Systems, Inc. *
//  *                                                    *
//  *                                                    *
//  ******************************************************

//  Canned code sequences (call/save/return, etc.).
//  Modified March 1982 by C. Hornig to set stack_frame.next_sp properly.
//  Modified on 06/14/74 at 01:13:39 by R F Mabee.
//  Converted for 6180 operation and installed in Version 3.4, R F Mabee.
//  First installed in Version 2.7 by R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_cg_head"
get "bcpl_opcodes"

let NewSSP (S) be
	if S > MaxSSP do MaxSSP := S

and Compentry (L, ID, FunctSw, MainSw) be
     $(	Jumpsw := false
	MaxSSP, LabMaxSSP := 0, Nextparam ()
	MaxArgOffset, LabMaxArg := 0, Nextparam ()
	let v = vec Vmax
	Concatenate (v, Vmax, "*fBegin text of ", ID)
	SectionHeader (StoreString (v))
	Outstring (ID)
	if MainSw do		//  Also need def ptr before entry.
	     $(	let M = Nextparam ()
		MainEntriesList := List4 (L, M, ID, MainEntriesList)
		Reloc, Param, Comment := RelDef lshift Left, M, "relative pointer to definition for entry"
		OutData (0)
	     $)
	Complab (L)
	Comment := "set lp to linkage section"
	test Machine = 645
	then $(	if GetLpLabel = 0 do GetLpLabel := Nextparam ()
		Outop2 (Tsx0, GetLpLabel)
	     $)
	or   $(	Outop3 (Epaq, 0, 0)
		Outop3 (Lprplp, 22, Sb | StarThenReg | Au)
	     $)

	if MainSw do
	     $(	if EntryLabel = 0 do EntryLabel := Nextparam ()
		Comment := "execute Multics save"
		Outop2 (Tsx0, EntryLabel)
	     $)
	Outop4 (Adlx1, 0, Bp, "BCPL save")
	test Machine = 645
	then $(	Outop3 (Stpbp, 0, StackRefTag)
		Outop3 (Stplp, 2, StackRefTag)
	     $)
	or   $(	Outop3 (Sprpbp, 0, StackRefTag)
		Outop3 (Sprplp, 1, StackRefTag)
	     $)
	Address, Tag, Param := 15, StackRefTag, LabMaxArg
	Outop (Eax0)
	Outop3 (Anx0, Mod16, Du)
	unless Machine = 645
	     do Outop3 (Stx0, 21, Sb)
	Comment := "end of save sequence*n"
	Outop3 (Stx0, 19, Sp)
     $)

and Compreturn (Desc) be
     $(	unless Desc = 0 do
	     $(	LoadRegister (Desc, Qr)
		DisclaimRegister (Desc)
	     $)
	test Machine = 645
	then Outop4 (Eapbp, 0, StackRefTag | Star, "bcpl return")
	or Outop4 (Lprpbp, 0, StackRefTag, "bcpl return")
	Outop3 (Sblx1, 0, Bp)
	test Machine = 645
	then Outop3 (Eaplp, 2, StackRefTag | Star)
	or Outop3 (Lprplp, 1, StackRefTag)
	Outop4 (Tra, 1, Bp, "end of return sequence")
	MaxSSP := MaxSSP + SaveSpaceSize + 1 & Even
	Equate (LabMaxSSP, MaxSSP)
	Equate (LabMaxArg, (MaxSSP > 256 -> MaxSSP, 256) + MaxArgOffset)		//  Don't reduce caller's sb|21.
	OutLiterals ()
	Jumpsw := true
     $)
and Equate (L, n) be
     $(	DefineLab (L, n)
	if Listing do Format (OUTPUT, "*tequ*tL^d,^d*n", L, n)
     $)

and CreateArglist (Nargs) be
	ArgCount, ArgLen := Nargs, Nargs + SaveSpaceSize
and StoreArg (i, Desc) be
     $(	let To = list LV_ARG_OUT, i, 0
	Store (Desc, To)
	DisclaimRegister (Desc)
     $)
and Compfnap (Result, F) be
     $(	SetupAddr (F)
	if F!0 = RTDEF_S do Address := Address + (Machine = 645 -> 1, 2)	//  Skip GETLP code.
	Outop (Tsbbp)
	Param := LabMaxSSP
	OutData (ArgCount)
	if ArgLen > MaxArgOffset do MaxArgOffset := ArgLen
	DisclaimRegister (F)
	unless Result = 0 do ClaimRegister (Qr, Result)
	IndicatorsSetBy := 0
     $)

and CreateSystemArglist (Nargs) be
     $(	ArgCount, ArgLen := Nargs, Nargs * 4 + 2
	let T = list Nargs lshift 19 | 4, Nargs lshift 19
	AddLiteral (T, 2, "arglist header", 2)
	Outop (Ldaq)
	Address, Tag, Param, Comment := 0, StackRefTag, LabMaxSSP, "arg count"
	Outop (Staq)
     $)
and StoreSystemArg (i, Arg, Offset, Type, Length, StringSw) be
     $(	if StringSw & Offset = 0 do Offset := Machine = 645 -> (table CONSTANT_S, 9, 0), (table CONSTANT_S, 18, 0)
	let Pr = LoadPointer (Arg, AnyPr)
	if Machine = 6180 & Offset ne 0 do
	     $(	let Xr = LoadIndex (Offset, AnyXr)
		Outop3 (Abd, 0, FormTag (Pr) | FormTag (Xr))
	     $)
	Address, Tag, Param := i * 2 + 2, StackRefTag, LabMaxSSP
	Outop (FormOpcode (Stpap, Pr))
	if Machine = 645 & Offset ne 0 do
	     $(	let q = LoadRegister (Offset, AorQr)
		Outop3 (FormOpcode (Als, q), 9, 0)
		Outop3 (FormOpcode (Ana, q), $8077000, Dl)
		Address, Tag, Param := i * 2 + 2, StackRefTag, LabMaxSSP
		Address, Tag, Param := i * 2 + 3, StackRefTag, LabMaxSSP
		Outop (FormOpcode (Orsa, q))
	     $)
	let ConstantPart, RegPart, CellOffset = 1 lshift 35, 0, 0
	test Length = 0
	then if StringSw do
	     $(	RegPart := GetRegister (AorQr)
		Outop3 (FormOpcode (Lda, RegPart), 0, FormTag (Pr))
		Outop3 (FormOpcode (Arl, RegPart), (Machine = 645 -> 27, 18), 0)
	     $)
	or test IsNumber (Length)
	then ConstantPart := ConstantPart | (EvalNumber (Length!0, Length!1) & $877777777)
	or   $(	RegPart := LoadRegister (Length, AorQr)
		Literal ($877777777, 0)
		Outop (FormOpcode (Ana, RegPart))
	     $)

	test IsNumber (Type)
	then ConstantPart := ConstantPart | (EvalNumber (Type!0, Type!1) lshift 29)
	or   $(	if RegPart ne 0 do
		     $(	CellOffset := ArgLen
			ArgLen := ArgLen + 1
			Address, Tag, Param := CellOffset, StackRefTag, LabMaxSSP
			Outop (FormOpcode (Sta, RegPart))
		     $)
		RegPart := LoadRegister (Type, AorQr)
		Outop3 (FormOpcode (Als, RegPart), 29, 0)
	     $)
	test RegPart = 0
	then AddLiteral (lv ConstantPart, 1, "descriptor", 0)
	or   $(	Literal (ConstantPart, 0)
		Outop (FormOpcode (Ora, RegPart))
		let Op = nil
		test CellOffset = 0
		then $(	CellOffset := ArgLen
			ArgLen := ArgLen + 1
			Op := Sta
		     $)
		or Op := Orsa
		Address, Tag, Param := CellOffset, StackRefTag, LabMaxSSP
		Outop (FormOpcode (Op, RegPart))
		Address, Tag, Param := CellOffset, StackRefTag, LabMaxSSP
	     $)
	Outop (FormOpcode (Eapap, Pr))
	Address, Tag, Param := i * 2 + ArgCount * 2 + 2, StackRefTag, LabMaxSSP
	Outop (FormOpcode (Stpap, Pr))
	DisclaimRegister (Arg)
	unless Offset = 0 do DisclaimRegister (Offset)
	DisclaimRegister (Type)
	unless Length = 0 do DisclaimRegister (Length)
     $)
and CompSystemCall (F) be
     $(	if ArgLen > MaxArgOffset do MaxArgOffset := ArgLen
	test Machine = 645
	then $(	Outop3 (Stb, 0, Sp)
		Outop3 (Sreg, 8, Sp)
	     $)
	or   $(	Outop3 (Sxl1, 8, Sp)		//  Save stack index in stack frame header.
		Outop3 (Stplp, 24, Sp)
	     $)
	LoadPointer (F, Bpr)
	Address, Tag, Param := 0, StackRefTag, LabMaxSSP
	Outop (Eapap)
	Outop4 (Tsblp, 30, Sb | Star, "Multics call operator")
	if Machine = 6180 do
	     $(	Outop3 (Lxl1, 8, Sp)
		Outop3 (Lprplp, 1, StackRefTag)
	     $)
	DisclaimRegister (F)
	IndicatorsSetBy := 0
     $)

and ResultBlockBegin () be
     $(	let New = Newvec (1)
	New!0, New!1 := ResultInfo, ResultInfoList
	ResultInfo, ResultInfoList := 0, New
     $)
and ResultSet (Desc) be
     $(	ResultInfo := LoadAppropriateRegister (Desc, ResultInfo)
	DisclaimRegister (Desc)
     $)
and ResultGet (Desc) be
     $(	ClaimRegister (ResultInfo, Desc)
	let Old = ResultInfoList
	ResultInfo, ResultInfoList := Old!0, Old!1
	Freevec (Old, 1)
     $)

and Compstring (s) be
     $(	let v = vec Vmax
	let Len = FormStringconst (s, v)
	AddLiteral (v, Len + 1, s, 0)
     $)
and Comptable (t) be
     $(	let v = Newvec (t!0)
	for i = 0 to t!0 - 1 do v!i := EvalNumber (t!(i * 2 + 1), t!(i * 2 + 2))
	AddLiteral (v, t!0, "a table", 2)
	Freevec (v, t!0)
     $)
let Compexternal (s) = valof
     $(	let p = LinkList
	until p = 0 do
	     $(	if EqualString (s, p!1) resultis p!2
		p := p!0
	     $)
	let L = Nextparam ()
	LinkList := List4 (LinkList, s, L, 0)
	resultis L
     $)
and Compfinish () be
	Outop4 (Tra, 34, Sb | Star, "Multics return")
and Compgoto (p) be
     $(	SetupAddr (p)
	Outop (Tra)
	DisclaimRegister (p)
     $)
   



		    bcpl_cg5.bcpl                   04/22/82  1624.2rew 04/22/82  1125.1       54918


//  These routines store the object code in an internal representation.
//  Last modified on 06/06/74 at 18:22:35 by R F Mabee.
//  Changes for 6180 code generation installed with Version 3.4 by R F Mabee.
//  First installed with Version 2.7 of the compiler, R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_cg_head"
get "bcpl_opcodes"

let CompRel (r) be
     $(	test r = 0
	then $(	if AbsRelBits ge 1023 do PutAbsBits ()
		AbsRelBits := AbsRelBits + 1
	     $)
	or   $(	unless AbsRelBits = 0 do PutAbsBits ()
		PutBits (r, 5)
	     $)
     $)
and PutAbsBits () be
     $(	test AbsRelBits le 15
	then PutBits (0, AbsRelBits)
	or PutBits (RelExtendedAbs lshift 10 | AbsRelBits, 15)
	AbsRelBits := 0
     $)
and PutBits (r, n) be
     $(	RelbitsOffset := RelbitsOffset + n
	test RelbitsOffset le 36
	then RelbitsList!0 := RelbitsList!0 | r lshift (36 - RelbitsOffset)
	or   $(	RelbitsOffset := RelbitsOffset - 36
		RelbitsList!0 := RelbitsList!0 | r rshift RelbitsOffset
		let New = Newvec (1)
		RelbitsList!1 := New
		RelbitsList, RelbitsLength := New, RelbitsLength + 1
		RelbitsList!0 := r lshift (36 - RelbitsOffset)
	     $)
     $)

let PutCode (Flags, a, b) be
     $(	if CodeP ge CodeSize - 3 do
	     $(	let y = Newvec (CodeSize)
		CodeV!0, CodeV!1 := y, CodeP
		CodeV, CodeP := y, 2
	     $)
	CodeV!CodeP, CodeV!(CodeP + 1), CodeV!(CodeP + 2) := Flags, a, b
	CodeP := CodeP + 3
     $)
and OutWord (x, ListType) be
     $(	PutCode (Param lshift Left | ListType, x, Comment)
	CompRel (Reloc rshift Left)
	CompRel (Reloc & Right)
	LC, Param, Reloc, Comment := LC + 1, 0, 0, 0
     $)

let SetLineNumber (n) be
     $(	PutCode (LineCountSwitch, n)
	if LineMap do
	     $(	unless (LineMapList!0 rshift Left) = LC do
		     $(	let New = Newvec (1)
			LineMapList!1 := New
			LineMapList, LineMapLength := New, LineMapLength + 1
		     $)
		LineMapList!0 := LC lshift Left | n
	     $)
     $)
and SectionHeader (Comment) be
	PutCode (HeaderSwitch, 0, Comment)

let OutW (x) be
     $(	if Jumpsw return
	OutWord (x, CodeSwitch)
     $)
and OutW2 (x, c) be
     $(	Comment := c
	OutW (x)
     $)

and Outop (Op) be
     $(	if Jumpsw return
	let a, t = Address, Tag
	if Reloc = 0 then test t = 0 & Param ne 0
	then a, t := a - LC, t | Ic
	or if (t & TagPrMask) = Lp do Reloc := (t & Star) = 0 -> RelStat15 lshift Left, RelLink15 lshift Left
	if (t & TagPrMask) ne 0 do a := a & $877777
	let Ext, Rest = Op rshift 9, Op & $8777
	let Word = (a lshift 18) | (Rest lshift 9) | (Ext lshift 8) | t
	if Listing do
	     $(	WriteInstruction (Word, Param)
		Writech (OUTPUT, '*n')
	     $)
	OutWord (Word, InstructionSwitch)
     $)
and Outop2 (Op, P) be
     $(	Address, Tag, Param := 0, 0, P
	Outop (Op)
     $)
and Outop3 (Op, A, T) be
     $(	Address, Tag, Param := A, T, 0
	CheckAddr ()
	Outop (Op)
     $)
and Outop4 (Op, A, T, C) be
     $(	Address, Tag, Param, Comment := A, T, 0, C
	CheckAddr ()
	Outop (Op)
     $)

and OutData (w) be
     $(	if Jumpsw return
	if Listing do
	     $(	WriteData (w, Param)
		Writech (OUTPUT, '*n')
	     $)
	OutWord (w, DataSwitch)
     $)

and FormOpcode (Op, r) = valof
     $(	let OpAB, OpLP = nil, nil
	switchon Op into
	     $(	case Ada: case Als: case Ana: case Ansa:
		case Arl: case Asa: case Cmpa: case Era:
		case Ersa: case Lca: case Lda: case Ora:
		case Orsa: case Sba: case Ssa: case Sta:
			if r = Ar resultis Op
			if r = Qr resultis Op + 1
			endcase

		case Mpy: case Div:
			if r = Qr resultis Op
			endcase

		case Fad: case Fcmp: case Fdi: case Fdv:
		case Fld: case Fmp: case Fneg: case Fsb:
		case Fstr:
			if r = EAQr resultis Op
			endcase

		case Eax0: case Lxl0:
			switchon r into
			     $(	case Xr0:	resultis Op
				case Xr1:	resultis Op + 1
				case Xr2:	resultis Op + 2
				case Xr3: resultis Op + 3
				case Xr4:	resultis Op + 4
				case Xr5:	resultis Op + 5
				case Xr6:	resultis Op + 6
				case Xr7:	resultis Op + 7
				default:
			     $)
			endcase

		case Eabap:
			OpAB, OpLP := 1, Eablp - Eabap
			goto Bases
		case Eapap:
			OpAB, OpLP := Eapab - Eapap, Eaplp - Eapap
			goto Bases
		case Stpap:
			OpAB, OpLP := Stpab - Stpap, Stplp - Stpap
			goto Bases
		case Lprpap: case Sprpap:
			OpAB, OpLP := 1, 4		//  Normal case.
		  Bases:
			switchon r into
			     $(	case Apr:	resultis Op
				case Abr:	resultis Op + OpAB
				case Bpr:	resultis Op + 2
				case Bbr:	resultis Op + 2 + OpAB
				case Lpr:	resultis Op + OpLP
				case Lbr:	resultis Op + OpLP + OpAB
				case Spr:	resultis Op + OpLP + 2
				case Sbr:	resultis Op + OpLP + 2 + OpAB
				default:
			     $)
		default:
	     $)
	CGreport (BadRegOpPair, r, Op)
	resultis Op
     $)
and FormTag (r) = valof
  switchon r into
     $(	case Ar:	resultis Al
	case Qr:	resultis Ql
	case Xr0:	resultis X0
	case Xr1:	resultis X1
	case Xr2:	resultis X2
	case Xr3:	resultis X3
	case Xr4:	resultis X4
	case Xr5:	resultis X5
	case Xr6:	resultis X6
	case Xr7:	resultis X7
	case Apr:	resultis Ap
	case Abr:	resultis Ab
	case Bpr:	resultis Bp
	case Bbr:	resultis Bb
	case Lpr:	resultis Lp
	case Lbr:	resultis Lb
	case Spr:	resultis Sp
	case Sbr:	resultis Sb
	default:	CGreport (UnexpectedCase, r, "FormTag")
		resultis 0
	case 0:	resultis 0
     $)


and CheckAddr () be
     $(	manifest
	     $(	TwoToTheEighteenth = 1 lshift 18
		TwoToTheFourteenth = 1 lshift 14
	     $)
	unless - TwoToTheEighteenth le Address < TwoToTheEighteenth do CGreport (BadAddress, Address)
	if (Tag & $8100) ne 0 then unless - TwoToTheFourteenth le Address < TwoToTheFourteenth do
	     $(	let t, p, c = Tag, Param, Comment
		Tag, Param, Comment := Tag & TagXrMask, 0, "compute offset"
		Outop (Eax7)
		IndicatorsSetBy := Xr7
		Address, Tag, Param, Comment := 0, (t & not TagXrMask) | X7, p, c
	     $)
     $)
  



		    bcpl_cg6.bcpl                   04/22/82  1624.2rew 04/22/82  1125.1       54819


//  These routines generate the code for switchons.
//  Last modified on 06/06/74 at 18:22:41 by R F Mabee.
//  Converted to 6180 and installed in Version 3.4, R F Mabee.
//  First installed in Version 2.7 by R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_cg_head"
get "bcpl_opcodes"

global
     $(	NoDefault : GlobalTemp  $)

let Compswitch (Val, CaseList, DefaultL, EndcaseL) be
     $(		//  Copy cases into a vector, evaluated and sorted.
	let CaseV = vec 1000 + 2
	and CaseP = 0
	let t = CaseList
	until t = 0 do
	     $(	for i = EvalNumber (t!2, t!3) to EvalNumber (t!4, t!5) do
		     $(	let j = CaseP
			while j > 0 & CaseV!j > i do j := j - 2
			if j > 0 & CaseV!j = i do
			     $(	CGreport (DupCase, i)
				loop
			     $)
			for k = CaseP to j + 2 by -2 do CaseV!(k + 2), CaseV!(k + 3) := CaseV!k, CaseV!(k + 1)
			CaseV!(j + 2), CaseV!(j + 3) := i, t!1
			test CaseP ge 1000
			then CGreport (OverCase, 1000 / 2)
			or CaseP := CaseP + 2
		     $)
		t := t!0
	     $)
	NoDefault := DefaultL = 0 & Optimize
	let Min, Max = 1 lshift 35, not (1 lshift 35)
	if NoDefault do Min, Max := CaseV!2, CaseV!CaseP
	SectionHeader ("*nBegin switchon")
	LoadRegister (Val, Ar)
	AnySwitch (lv CaseV!2, lv CaseV!CaseP, Min, Max, DefaultL = 0 -> EndcaseL, DefaultL)
	DisclaimRegister (Val)
     $)
and AnySwitch (Lp, Up, Ll, Ul, DefaultL) be
     $(	let n = (Up - Lp) / 2 + 1
		// Number of cases.
	if NoDefault -> n < 4, n < 3 do
	     $(	LinearSwitch (Lp, Up, Ll, Ul, DefaultL)
		return
	     $)
	let a, b, c, d = 0, Lp + (n & Even), 0, 0
	if Optimize do
	     $(	let u, w, x, y, z = 0, 0, 0, 0, 0
		let v = vec 2000
		w := Lp!0
		for p = Lp to Up by 2 do
		     $(	let q, r = p!1, p!0 - w
			for i = 1 to a do if q = v!i goto L
			a := a + 1
			v!a := q
		     L:	test q = x & (NoDefault | r = 1)
			then z := z + 1
			or   $(	if z ge c do b, c := y, z
				x, y, z := q, p, 0
			     $)
			if r > u do d, u := p, r
			w := p!0
		     $)
		if z > c do b, c := y, z
		if c = 0 do b := u ge n -> d, Lp + (n & Even)
			// Here a is the number of distinct labels
			// and b points to c adjacent cases.
		if c < n / 4 do
		     $(	let r = Up!0 - Lp!0
			if r < 0 do r := 30000000000
				// Now r is the range of cases covered.
			let i, j, k = a, n * 4, r - 2
			unless NoDefault do i, j, k := n, n * 2, k / 2 + 2
			if j > k do j := k
				// Here i is the minimum hash table size,
				// j is a reasonable limit for i,
				// and k is the size beyond which a direct switch is better.
			while i < j do
			     $(	for m = 0 to i do v!m := 0
				for p = Lp to Up by 2 do
				     $(	let m = p!0
					for s = 35 to 0 by -1 do if (m rshift s) ge i do m := m - (i lshift s)
					let t = p!1
					unless v!m = 0 | v!m = t & NoDefault goto M
					v!m := t
				     $)
				HashSwitch (Lp, Up, i, DefaultL)
				return
			     M:	i := i + 1
			     $)
			if k le j & u < n do
			     $(	DirectSwitch (Lp, Up, Ll, Ul, DefaultL)
				return
			     $)
		     $)
	     $)
	BinarySwitch (Lp, Up, Ll, Ul, b, c, DefaultL)
     $)
and LinearSwitch (Lp, Up, Ll, Ul, DefaultL) be
     $(	let LastL = DefaultL
	if NoDefault | (Lp!0 = Ll & Up!0 = Ul & Ul - Ll = (Up - Lp) / 2) do
	     $(	LastL := Up!1
		Up := Up - 2
	     $)
	for p = Lp to Up by 2 do Swjump (p!0, Tze, p!1)
	Compjump (LastL)
     $)
and HashSwitch (Lp, Up, i, DefaultL) be
     $(	let v = vec 2000
	and w = vec 2000
	for j = 0 to i do v!j, w!j := DefaultL, 0
	for p = Lp to Up by 2 do
	     $(	let m, n = p!0, 0
		for s = 35 to 0 by -1 do
		     $(	n := n lshift 1
			if (m rshift s) ge i do m, n := m - (i lshift s), n + 1
		     $)
		v!m, w!m := p!1, n
	     $)
	Outop3 (Lrl, 35, 0)
	Literal (i, "hash table size")
	Outop (Dvf)
	let Tl = 0
	unless NoDefault do
	     $(	Tl := Nextparam ()
		Address, Tag, Param, Reloc := 0, Ql, Tl, RelText lshift Left
		Outop (Cmpa)
		Outop2 (Tnz, DefaultL)
	     $)
	let Lab = Nextparam ()
	Address, Tag, Param, Reloc := 0, Ql, Lab, RelText lshift Left
	Outop (Tra)
	Complab (Lab)
	for j = 0 to i - 1 do Outop2 (Tra, v!j)
	unless NoDefault do
	     $(	Complab (Tl)
		for j = 0 to i - 1 do OutData (w!j)
	     $)
     $)
and DirectSwitch (Lp, Up, Ll, Ul, DefaultL) be
     $(	let n = (Up - Lp) / 10 + 2
	let x = 0
	test NoDefault
	then Ll, Ul := Lp!0, Up!0
	or test Ul - n ge Up!0
	then $(	let r, t = Up!0, Tpl
		Ul := r
		if Ll + n < Lp!0 do
		     $(	test 0 le Lp!0 le n
			then Ll := 0
			or   $(	Outop3 (Sba, Lp!0, Dl)
				Ll := Lp!0
				x, r := Ll, Ul - Ll
			     $)
			t := Trc
		     $)
		Swjump (r + 1, t, DefaultL)
	     $)
	or if Ll + n < Lp!0 do
	     $(	Ll := Lp!0
		Swjump (Ll, Tmi, DefaultL)
	     $)
	let Lab = Nextparam ()
	Address, Param, Tag, Reloc := x - Ll, Lab, Al, RelText lshift Left
	Outop (Tra)
	Complab (Lab)
	for i = Ll to Ul do
		test Lp!0 = i
		then $(	Outop2 (Tra, Lp!1)
			Lp := Lp + 2
		     $)
		or Outop2 (Tra, DefaultL)
     $)
and BinarySwitch (Lp, Up, Ll, Ul, b, c, DefaultL) be
     $(	let Tl = 0
	let d = b + c + c
	let s, t = false, false
	unless b = Lp & (NoDefault | Ll = Lp!0) do
	     $(	test b le Lp + 2 & (NoDefault | b = Lp | Ll = Lp!0 & b!0 = Ll + 1)
		then Swjump (b!0, Tmi, b = Lp -> DefaultL, Lp!1)
		or   $(	Tl := Nextparam ()
			Swjump (b!0, Tmi, Tl)
		     $)
		s := true
	     $)
	test d = Up & (NoDefault | Ul = Up!0)
	then $(	Compjump (d!1)
		t := true
	     $)
	or test c = 0 & s
	   then Outop2 (Tze, b!1)
	   or Swjump (d!0 + 1, Tmi, d!1)
	unless t test d = Up
	then unless NoDefault | Ul = Up!0 do Compjump (DefaultL)
	or AnySwitch (d + 2, Up, d!0 + 1, Ul, DefaultL)
	unless Tl = 0 do
	     $(	Complab (Tl)
		AnySwitch (Lp, b - 2, Ll, b!0 - 1, DefaultL)
	     $)
     $)
and Swjump (n, t, l) be
     $(	Literal (n, 0)
	Outop (Cmpa)
	Outop2 (t, l)
     $)
 



		    bcpl_cg7.bcpl                   04/22/82  1624.2rew 04/22/82  1125.1       82800


//  These routines generate the definitions and linkage sections of the object segment.
//  Last modified on 06/06/74 at 18:23:04 by R F Mabee.
//  Modified for 6180 conversion, and installed as Version 3.4 by R F Mabee.
//  First installed as Version 2.7, R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_cg_head"
get "bcpl_opcodes"

global
     $(	NamesList : 398
	DefsList : 399
     $)

manifest
     $(	NewFlag = 1 lshift 17
	IgnoreFlag = 1 lshift 16
	EntryFlag = 1 lshift 15
	ClassMask = $8777
     $)


let WriteGetlp () be
     $(	SectionHeader ("*nLocal subroutine to find linkage section by looking in LOT")
	Complab (GetLpLabel)
	Outop3 (Stcd, 18, Sp | Star)
	Outop3 (Ldx7, 18, Sp | Star)
	Outop3 (Lda, 22, Sb | StarThenReg | X7)
	Outop3 (Eablb, 0, Au)
	Outop3 (Eablp, 0, Al)
	Outop3 (Tra, 0, X0)
     $)
and WriteEntry () be
     $(	SectionHeader ("*nLocal subroutine to help enter BCPL environment")
	Complab (EntryLabel)
	Outop4 (Eax7, 2048, 0, "Multics save sequence")
	Outop3 (Tsbbp, 32, Sb | Star)
	Outop3 (Eax1, 400, Machine = 6180 -> Sp, 0)
	Outop3 (Stplp, 24, Sp)	//  Operator pointer.
	Outop3 (Eapap, Machine = 6180 -> -3, -2, X0)	//  Def ptr.
	Outop3 (Stpap, 22, Sp)	//  Entry pointer.
	Outop4 (Tsbbp, 0, X0, "simulate standard BCPL call")
	OutData (0)
	Compfinish ()
     $)

//  This routine generates the entire definition section.  LC must be zero at entry.

let WriteDefs (EntriesList) be
     $(	let v, w = vec Vmax, vec Vmax
	SectionHeader ("*fDefinition section part one - external entry points")
	let ZeroWordLab = Nextparam ()
	NamesList, DefsList := 0, List4 (0, ZeroWordLab lshift Left | NewFlag | 3, ProgramName, Nextparam ())

//  Insert each entry point in the appropriate place in DefsList.
	let p = EntriesList
	until p = 0 do
	     $(	Split (p!1, v, w)
		let L = p!2
		if Listing do
		     $(	Format (OUTPUT, "*tequ*t^s,L^d*n", p!1, L)
			Format (OUTPUT, "*tsegdef*t^s*n", p!1)
		     $)
		let q, DefLabel = MainEntriesList, 0
		until q = 0 do		//  Determine whether this definition is referenced from text.
		     $(	if q!0 = L do q!0, DefLabel := 0, q!1
			q := q!3
		     $)
		AddDefinition (L lshift Left | NewFlag | EntryFlag | 0, StoreString (w), DefLabel, v)
		p := p!0
	     $)

//  Insert the symbol_table definition required by certain system tools.
	AddDefinition (0 lshift Left | NewFlag | 2, "symbol_table", 0, ProgramName)

//  If there are any names in MainEntriesList which were not in EntriesList, add dummy definitions for them.
	let q = MainEntriesList
	until q = 0 do
	     $(	if q!0 ne 0 do AddDefinition (q!0 lshift Left | NewFlag | EntryFlag | IgnoreFlag | 0, q!2, q!1, ProgramName)
		q := q!3
	     $)

//  Put out definitions header.
	Param, Reloc := DefsList!3, RelDef lshift Left
	OutW2 (0, "pointer to first definition")
	OutW2 (NewFlag | IgnoreFlag, "flags: new format, ignore header")
	let ZeroWord = LC
	DefineLab (ZeroWordLab, ZeroWord)
	OutW2 (0, "list terminator*n")

//  Put out all the names belonging to definitions.
	p := DefsList
	until p = 0 do
	     $(	p!3 := p!3 | GetName (p!2) lshift Left
		p := p!0
	     $)

//  Put out the definitions.
	let PreviousDef, NextDef, SegnameDef = ZeroWord, LC, nil
	and RelCodesTable = table RelText lshift Left, RelLink18 lshift Left, RelSymbol lshift Left, RelDef lshift Left
	p := DefsList
	until p = 0 do
	     $(	let ThisDef = NextDef
		unless ThisDef = LC do CGreport (PhaseError, "WriteDefs")
		NextDef := p!0 = 0 -> ZeroWord, ThisDef + 3
		let DefLabel, Class = p!3 & Right, p!1 & ClassMask
		and SegnameInfo, SegnameComment = nil, nil
		test Class = 3		//  I.e., this is a segname definition.
		then $(	Concatenate (v, Vmax, "*nSegname definition for ", p!2)
			SegnameDef := ThisDef
			SegnameInfo, SegnameComment := NextDef, "name pointer, first entry def"
		     $)
		or   $(	Concatenate (v, Vmax, "*nDefinition for ", p!2)
			SegnameInfo, SegnameComment := SegnameDef, "name pointer, segname def pointer"
		     $)
		SectionHeader (StoreString (v))
		if DefLabel ne 0 do DefineLab (DefLabel, ThisDef)
		Reloc := RelDef lshift Left | RelDef
		OutW2 (NextDef lshift Left | PreviousDef, "forward, backward threads")
		Param, Reloc := p!1 rshift Left, RelCodesTable!Class
		OutW2 (p!1 & Right, "value defined, class flags")
		Reloc := RelDef lshift Left | RelDef
		OutW2 ((p!3 & not Right) | SegnameInfo, SegnameComment)
		PreviousDef := ThisDef
		p := p!0
	     $)

//  Put out link info.
	SectionHeader ("*fDefinition section part two - symbolic info for external references")
	p := LinkList
	until p = 0 do
	     $(	Split (p!1, v, w)
		if EqualString (v, ProgramName) do CGreport (LinkRefersThis, p!1)
		let x, y, z, r = GetName (StoreString (v)), 0, 3, 0
		unless Length (w) = 0 do y, z, r := GetName (StoreString (w)), 4, RelDef
		Reloc := RelDef lshift Left
		p!3 := LC
		OutW (LC + 1 lshift Left)
		OutW (z lshift Left)
		Reloc := RelDef lshift Left logor r
		OutW (x lshift Left logor y)
		p := p!0
	     $)
     $)

and Split (s, v, w) be
     $(	let t, u = vec Vmax, vec Vmax
	RemoveEscapes (s, t)
	Unpackstring (t, u)
	for i = 1 to u!0 if u!i = '$' do
	     $(	let j = u!0 - i		//  Found '$' - separate parts before and after.
		for k = 1 to j do t!k := u!(i + k)
		u!0, t!0 := i - 1, j
		Packstring (u, v)
		Packstring (t, w)
		return
	     $)
	Packstring (u, v)		//  No '$' - both parts equal to whole.
	Packstring (u, w)
     $)
and GetName (s) = valof
     $(	let p = NamesList
	until p = 0 do
	     $(	if EqualString (p!0, s) resultis p!1
		p := p!2
	     $)
	NamesList := List3 (s, LC, NamesList)
	let w = vec Vmax + 4
	Concatenate (w, Vmax, "*"", s, "*"")
	Comment := StoreString (w)
	Unpackstring (s, w)
	let Len = w!0
	w!(Len + 1), w!(Len + 2), w!(Len + 3) := 0, 0, 0
		//  An ACC string has the length in the first nine bits.
	for i = 0 to Len by 4 do OutW (w!i lshift 27 | w!(i + 1) lshift 18 | w!(i + 2) lshift 9 | w!(i + 3))
	resultis NamesList!1
     $)
and AddDefinition (ValueLabel, Name, DefLabel, Segname) be
     $(	let New = Newvec (3)
	New!1, New!2, New!3 := ValueLabel, Name, DefLabel
	let Dp = DefsList			//  Try to find segname block where this def belongs.
	until Dp = 0 do
	     $(	if (Dp!1 & ClassMask) = 3 then if EqualString (Dp!2, Segname) do
		     $(	     $(	let q = Dp!0		//  Find end of block.
				if q = 0 break
				if (q!1 & ClassMask) = 3 break
				Dp := q
			     $)	repeat
			goto GotSegname
		     $)
		Dp := Dp!0
	     $)

//  No match for Segname, must create a new segname definition.
	Dp := Newvec (3)
	Dp!0, Dp!1, Dp!2, Dp!3 := DefsList, DefsList!3 lshift Left | NewFlag | 3, StoreString (Segname), Nextparam ()
	DefsList := Dp
  GotSegname:
	New!0 := Dp!0
	Dp!0 := New
     $)

//  This routine generates the entire linkage section.  LC must be zero at entry.

let WriteLinkage (StaticList) be
     $(	SectionHeader ("*fLinkage section - static variables and external links")

//  Calculate lengths of the various components of the linkage section.

	let HeaderLength, StaticLength, LinksLength = 8, 0, 0
	and t = StaticList
	until t = 0 do t, StaticLength := t!0, StaticLength + 1
	t := LinkList
	until t = 0 do t, LinksLength := t!0, LinksLength + 2
	unless LinksLength = 0 do StaticLength := StaticLength + 1 & Even	//  Links must start at evan address.
	let TotalLength = HeaderLength + StaticLength + LinksLength

//  Put out the linkage header.
	OutW2 (0, "linkage header")
	Reloc := RelText lshift Left
	OutW2 ((TextLength + 1 & Even) lshift Left, "address of defs")
	for i = 1 to 4 do OutW (0)
	Reloc := RelLink18 lshift Left
	OutW2 ((HeaderLength + StaticLength) lshift Left | TotalLength, "offset to links, total length")
	OutW2 (TotalLength, "obsolete length")		//  Still required by lot_maintainer in August 1973.

	if StaticList ne 0 do
	     $(	SectionHeader ("*nStatic variables")
		if Listing do
		     $(	WriteS ("*tuse*tlinkc*n")
			WriteS ("*tjoin*t/link/linkc*n")
		     $)
		t := StaticList
		until t = 0 do
		     $(	unless LC = t!1 + HeaderLength do CGreport (PhaseError, "WriteLinkage")
			Comment := t!2
			OutData (EvalNumber (t!3, t!4))
			t := t!0
		     $)
	     $)

	if LinkList ne 0 do
	     $(	unless (LC & 1) = 0 do OutW (0)	     //  Force even alignment for links.
		SectionHeader ("*nExternal link pairs")
		t := LinkList
		until t = 0 do
		     $(	DefineLab (t!2, LC)
			PutCode (LabelSwitch, t!2, LC)
			Comment := t!1
			Reloc := RelNegLink18 lshift Left
			OutW (-LC lshift Left logor Ft2)
			Reloc := RelDef lshift Left
			OutW (t!3 lshift Left)
			if Listing do
			     $(	let v, w = vec Vmax, vec Vmax
				Split (t!1, v, w)
				Format (OUTPUT, "*tlink*tL^d,<^s>|", t!2, v)
				test Length (w) = 0
				then WriteS (OUTPUT, "0*n")
				or Format (OUTPUT, "[^s]*n", w)
			     $)
			t := t!0
		     $)
	     $)

	unless LC = TotalLength do CGreport (PhaseError, "WriteLinkage")
     $)



		    bcpl_cg8.bcpl                   04/22/82  1624.2rew 04/22/82  1125.1       54198


//  These routines generate the symbol section and object map.
//  Last modified on 06/06/74 at 18:23:54 by R F Mabee.
//  Modified for 6180 conversion, and installed as Version 3.4 by R F Mabee.
//  First installed as Version 2.7, R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_cg_head"
get "bcpl_opcodes"

global
     $(	Strings : GlobalTemp  $)


let LineMapLength () = valof
     $(	LineMapList!1 := 0
	let q, l = LineMapFirst, 0
	until q = 0 do l, q := l + 1, q!1
	resultis l + 1
     $)
and WriteLineMap (MapL) be
     $(	Complab (MapL)
	let l = LineMapLength () - 1
	OutW2 (TextLength lshift Left logor l, "text length, map entry count")
	let q = LineMapFirst
	until q = 0 do
	     $(	OutW (q!0)
		q := q!1
	     $)
     $)
and SymbolTableLength () = 1
and WriteSymbolTable (SymL) be
     $(	Complab (SymL)
	OutW2 (0, "no symbol table implemented")
     $)

//  This routine writes the symbol section except for the relocation bits at the end.
//  LC must be zero at entry.

let WriteSymbol () be
     $(	SectionHeader ("*fSymbol section header")
	let SymL = Symbols -> Nextparam (), 0
	and MapL = LineMap -> Nextparam (), 0
	let Smap = 20			//  Number of words in fixed-format part of header below; must be even.
	SymbolLength := Smap + 2 + FileCount * 4 + 4
	Strings := vec 50
	Strings!0 := 0
	OutW2 (1, "version number of header structure")
	OutAlignedString ("symbtree")			//  Block type.
	OutW2 (CompilerVersionNumber, "compiler version number")
	OutW2 (CompilerDTM!0, "date/time compiler modified")
	OutW2 (CompilerDTM!1, CompilerDTMString)
	OutW2 (TimeNow!0, "time of this compilation")
	OutW2 (TimeNow!1, TimeNowString)
	OutAlignedString ("bcpl    ")			//  Compiler name.
	OutW2 (RemoteString (CompilerVersionString), "compiler version name - pointer, length")
	OutW2 (RemoteString (UserID), "user id - pointer, length")
	OutW2 (RemoteString (OptionString), "comment string - pointer, length")
	OutW2 (2 lshift Left | 2, "text and linkage boundaries")

	let w = vec 50
	for i = 0 to FileCount do w!i := RemoteString (FilesInfo!(i * 4))
	let Tree = 0
	if Symbols | LineMap do
	     $(	Tree := SymbolLength
		SymbolLength := SymbolLength + 1		//  For block header.
		if Symbols do SymbolLength := SymbolLength + SymbolTableLength ()
		if LineMap do SymbolLength := SymbolLength + LineMapLength ()
	     $)
	OutW2 (Smap lshift Left | Tree, "source map, symbol tree root")
	let Tlen, Llen = CountRelbits (TextRelbits), CountRelbits (LinkageRelbits)
	Reloc := RelNegSymbol lshift Left			//  section_header_pointer only item not self-relocating.
	OutW2 (SymbolLength, "section header pointer, block size")
	OutW2 (SymbolLength, "next block pointer, rel_text")
	OutW2 (SymbolLength + Tlen, "rel_def, rel_link")
	OutW2 (SymbolLength + Tlen + Llen lshift Left | SymbolLength, "rel_symbol, default truncate")
	OutW2 (Smap lshift Left, "optional truncate, unused")

//  End of fixed format header.  Rest is unstructured, pointed to by items above.

	OutW2 (1, "source files map: version number")
	OutW2 (FileCount + 1, "                  number of files")
	for i = 0 to FileCount do
	     $(	let Info = lv FilesInfo!(i * 4)
		OutW2 (w!i, FileNames!i)
		OutW2 (Info!1, "last modified on")		//  Unique ID.
		OutW2 (Info!2, MakeTimeString (lv Info!2))	//  DTM.
		OutW (Info!3)
	     $)
	for i = 1 to Strings!0 do OutAlignedString (Strings!i)

	if Symbols | LineMap do
	     $(	SectionHeader ("*fSymbol table block")
		Param := SymL
		OutW2 (LineMap -> LC + 1, 0, "symbol table pointer, line map pointer")

		if LineMap do WriteLineMap (MapL)
		if Symbols do WriteSymbolTable (SymL)
	     $)

	unless LC = SymbolLength do CGreport (PhaseError, "WriteSymbol")
     $)

and RemoteString (s) = valof
     $(	let l = Length (s)
	let r = SymbolLength lshift Left | l
	SymbolLength := SymbolLength + (l + 3) / 4
	Strings!0 := Strings!0 + 1
	Strings!(Strings!0) := s
	resultis r
     $)
and OutAlignedString (s) be
     $(	let v = vec Vmax
	Concatenate (v, Vmax, "*"", s, "*"")
	Comment := StoreString (v)
	Unpackstring (s, v)
	let Len = v!0
	v!(Len + 1), v!(Len + 2), v!(Len + 3) := '*s', '*s', '*s'
	for i = 1 to Len by 4 do OutW (v!i lshift 27 | v!(i + 1) lshift 18 | v!(i + 2) lshift 9 | v!(i + 3))
     $)

and OutRel (p, c) be
     $(	if p = 0 return
	SectionHeader (c)
	OutW2 (2, "version number of rel-bits structure")
	OutW2 (p!0, "length in bits")
	p := p!1
	until p = 0 do
	     $(	OutW (p!0)
		p := p!1
	     $)
     $)
and CountRelbits (p) = valof
     $(	if p = 0 resultis 0
	let n = 0
	n, p := n + 1, p!1 repeatuntil p = 0
	resultis n + 1
     $)
and WriteRelBits () be
     $(	SectionHeader ("*fRelocation information")
	OutRel (TextRelbits, "*ntext section relocation bits")
	OutRel (DefsRelbits, "*ndefinitions section relocation bits")
	OutRel (LinkageRelbits, "linkage relocation bits")
	OutRel (SymbolRelbits, "symbol relocation bits")
     $)

let WriteObjectMap (AbsLC) be
     $(	SectionHeader ("*fObject map")
	let t, d, l = TextLength + 1 & Even, DefsLength + 1 & Even, LinkageLength + 1 & Even
	unless t + d + l + SymbolLength = AbsLC do CGreport (PhaseError, "WriteObjectMap")
	OutW2 (1, "version number of object_map structure")
	OutAlignedString ("obj_map ")
	OutW2 (TextLength, "text offset, length")
	OutW2 (t lshift Left | DefsLength, "def offset, length")
	OutW2 (t + d lshift Left | LinkageLength, "link offset, length")
	OutW2 (t + d + l lshift Left | SymbolLength, "symbol offset, length")
	OutW2 (0, "break map offset, length")
	OutW2 ($834 lshift 30, "flags: ^bound, relocatable, procedure, standard")
	OutW2 (AbsLC lshift Left, "object map pointer, unused")		//  Last word of segment.
     $)
  



		    bcpl_cg9.bcpl                   04/22/82  1624.2rew 04/22/82  1125.1       88659


//  These routines write the assembly-format listing.
//  Last modified on 06/06/74 at 18:24:47 by R F Mabee.
//  Changes for 6180 code generation installed with Version 3.4 by R F Mabee.
//  First installed with Version 2.7 of the compiler, R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_cg_head"
get "bcpl_opcodes"

let OpcodeName (Op) = valof
  switchon Op into
     $(	default:		CGreport (UnexpectedCase, Op, "OpcodeName")
			resultis "<error>"

	case Abd:		resultis "abd"
	case Ada:		resultis "ada"
	case Ada + 1:	resultis "adq"
	case Adlx1:	resultis "adlx1"
	case Als:		resultis "als"
	case Als + 1:	resultis "qls"
	case Ana:		resultis "ana"
	case Ana + 1:	resultis "anq"
	case Ansa:	resultis "ansa"
	case Ansa + 1:	resultis "ansq"
	case Anx0:	resultis "anx0"
	case Aos:		resultis "aos"
	case Arl:		resultis "arl"
	case Arl + 1:	resultis "qrl"
	case Asa:		resultis "asa"
	case Asa + 1:	resultis "asq"
	case Cmpa:	resultis "cmpa"
	case Cmpa + 1:	resultis "cmpq"
	case Div:		resultis "div"
	case Dvf:		resultis "dvf"
	case Eabap:	resultis "eabap"
	case Eabap + 1:	resultis "eabab"
	case Eabap + 2:	resultis "eabbp"
	case Eabap + 3:	resultis "eabbb"
	case Eablp:	resultis "eablp"
	case Eablp + 1:	resultis "eablb"
	case Eapap:	resultis "eapap"
	case Eapab:	resultis "eapab"
	case Eapap + 2:	resultis "eapbp"
	case Eapab + 2:	resultis "eapbb"
	case Eaplp:	resultis "eaplp"
	case Eaplb:	resultis "eaplb"
	case Eaplp + 2:	resultis "eapsp"
	case Eaplb + 2:	resultis "eapsb"
	case Eax0:	resultis "eax0"
	case Eax0 + 1:	resultis "eax1"
	case Eax0 + 2:	resultis "eax2"
	case Eax0 + 3:	resultis "eax3"
	case Eax0 + 4:	resultis "eax4"
	case Eax0 + 5:	resultis "eax5"
	case Eax0 + 6:	resultis "eax6"
	case Eax0 + 7:	resultis "eax7"
	case Epaq:	resultis "epaq"
	case Era:		resultis "era"
	case Era + 1:	resultis "erq"
	case Ersa:	resultis "ersa"
	case Ersa + 1:	resultis "ersq"
	case Fad:		resultis "fad"
	case Fcmp:	resultis "fcmp"
	case Fdi:		resultis "fdi"
	case Fdv:		resultis "fdv"
	case Fld:		resultis "fld"
	case Fmp:		resultis "fmp"
	case Fneg:	resultis "fneg"
	case Fsb:		resultis "fsb"
	case Fstr:	resultis "fstr"
	case Fszn:	resultis "fszn"
	case Lca:		resultis "lca"
	case Lca + 1:	resultis "lcq"
	case Lda:		resultis "lda"
	case Lda + 1:	resultis "ldq"
	case Ldaq:	resultis "ldaq"
	case Ldx7:	resultis "ldx7"
	case Llr:		resultis "llr"
	case Lprpap:	resultis "lprpap"
	case Lprpap + 1:	resultis "lprpab"
	case Lprpap + 2:	resultis "lprpbp"
	case Lprpap + 3:	resultis "lprpbb"
	case Lprplp:	resultis "lprplp"
	case Lprplp + 1:	resultis "lprplb"
	case Lprplp + 2:	resultis "lprpsp"
	case Lprplp + 3:	resultis "lprpsb"
	case Lrl:		resultis "lrl"
	case Lxl0:	resultis "lxl0"
	case Lxl0 + 1:	resultis "lxl1"
	case Lxl0 + 2:	resultis "lxl2"
	case Lxl0 + 3:	resultis "lxl3"
	case Lxl0 + 4:	resultis "lxl4"
	case Lxl0 + 5:	resultis "lxl5"
	case Lxl0 + 6:	resultis "lxl6"
	case Lxl0 + 7:	resultis "lxl7"
	case Mpy:		resultis "mpy"
	case Neg:		resultis "neg"
	case Negl:	resultis "negl"
	case Ora:		resultis "ora"
	case Ora + 1:	resultis "orq"
	case Orsa:	resultis "orsa"
	case Orsa + 1:	resultis "orsq"
	case Sba:		resultis "sba"
	case Sba + 1:	resultis "sbq"
	case Sblx1:	resultis "sblx1"
	case Sprpap:	resultis "sprpap"
	case Sprpap + 1:	resultis "sprpab"
	case Sprpap + 2:	resultis "sprpbp"
	case Sprpap + 3:	resultis "sprpbb"
	case Sprplp:	resultis "sprplp"
	case Sprplp + 1:	resultis "sprplb"
	case Sprplp + 2:	resultis "sprpsp"
	case Sprplp + 3:	resultis "sprpsb"
	case Sreg:	resultis "sreg"
	case Ssa:		resultis "ssa"
	case Ssa + 1:	resultis "ssq"
	case Sta:		resultis "sta"
	case Sta + 1:	resultis "stq"
	case Staq:	resultis "staq"
	case Stb:		resultis "stb"
	case Stc1:	resultis "stc1"
	case Stcd:	resultis "stcd"
	case Stpap:	resultis "stpap"
	case Stpab:	resultis "stpab"
	case Stpap + 2:	resultis "stpbp"
	case Stpab + 2:	resultis "stpbb"
	case Stplp:	resultis "stplp"
	case Stplb:	resultis "stplb"
	case Stplp + 2:	resultis "stpsp"
	case Stplb + 2:	resultis "stpsb"
	case Stx0:	resultis "stx0"
	case Stz:		resultis "stz"
	case Sxl0:	resultis "sxl0"
	case Sxl1:	resultis "sxl1"
	case Szn:		resultis "szn"
	case Tmi:		resultis "tmi"
	case Tmoz:	resultis "tmoz"
	case Tnz:		resultis "tnz"
	case Tpl:		resultis "tpl"
	case Tpnz:	resultis "tpnz"
	case Tra:		resultis "tra"
	case Trc:		resultis "trc"
	case Tsbap:	resultis "tsbap"
	case Tsbbp:	resultis "tsbbp"
	case Tsblp:	resultis "tsblp"
	case Tsx0:	resultis "tsx0"
	case Tze:		resultis "tze"
     $)
and RegisterName (Reg) = valof
  switchon Reg & TagXrMask into
     $(	case 0:	resultis "n"
	case Au:	resultis "au"
	case Al:	resultis "al"
	case Qu:	resultis "qu"
	case Ql:	resultis "ql"
	case Du:	resultis "du"
	case Dl:	resultis "dl"
	case Ic:	resultis "ic"
	case X0:	resultis "x0"
	case X1:	resultis "x1"
	case X2:	resultis "x2"
	case X3:	resultis "x3"
	case X4:	resultis "x4"
	case X5:	resultis "x5"
	case X6:	resultis "x6"
	case X7:	resultis "x7"
     $)
and BaseName (Base) = valof
  switchon Base & TagPrMask into
     $(	case Ap:	resultis "ap"
	case Ab:	resultis "ab"
	case Bp:	resultis "bp"
	case Bb:	resultis "bb"
	case Lp:	resultis "lp"
	case Lb:	resultis "lb"
	case Sp:	resultis "sp"
	case Sb:	resultis "sb"
     $)

let WriteH (x) be
     $(	Writech (OUTPUT, '*s')
	for i = 15 to 0 by -3 do
		Writech (OUTPUT, '0' + ((x rshift i) & 7))
     $)
and WriteNcount (n) be
     $(	let v = vec 20
	ConvertNtoS (n, v, 10)
	WriteS (OUTPUT, v)
	Column := Column + Length (v)
     $)
and WriteAddress (Address, Param) be
     $(	if Param ne 0 do
	     $(	Writech (OUTPUT, 'L')
		Column := Column + 1
		WriteNcount (Param)
		if Address = 0 return
		if (Address & (1 lshift 17)) = 0 do
		     $(	Writech (OUTPUT, '+')
			Column := Column + 1
		     $)
	     $)
	if (Address & (1 lshift 17)) ne 0 do
	     $(	Writech (OUTPUT, '-')
		Column := Column + 1
		Address := - (Address | (true lshift 18))
	     $)
	WriteNcount (Address)
     $)

let WriteInstruction (Word, Param) be
     $(	Format (OUTPUT, "*t^s*t", OpcodeName ((Word rshift 9) & $8777 | (Word lshift 1) & $81000))
	if (Word & $8100) ne 0 do
	     $(	Format (OUTPUT, "^s|", BaseName (Word))
		Column := Column + 3
		test (Word & (1 lshift 32)) = 0
		then Word := Word & (true rshift 3)
		or Word := Word | (true lshift 33)
	     $)
	if (Word & $877) = Ic do Word := Word + (LC lshift 18) - Ic	//  Simulate ic modifier.
	WriteAddress (Word rshift Left, Param)
	if (Word & $877) ne 0 do
	     $(	let Reg = RegisterName (Word & $817)
		switchon Word & $860 into
		     $(	case $800:
				Format (OUTPUT, ",^s", Reg)
				Column := Column + Length (Reg) + 1
				endcase
			case $820:
				if (Word & $817) = 0 do Reg := ""
				Format (OUTPUT, ",^s**", Reg)
				Column := Column + Length (Reg) + 2
				endcase
			case $840:
				Format (OUTPUT, ",^o", Word & $877)
				Column := Column + 3
				endcase
			case $860:
				Format (OUTPUT, ",**^s", Reg)
				Column := Column + Length (Reg) + 2
		     $)
	     $)
     $)
and WriteData (Word, Param) be
     $(	WriteS (OUTPUT, "*tzero*t")
	WriteAddress (Word rshift Left, Param)
	if (Word & Right) ne 0 do
	     $(	Writech (OUTPUT, ',')
		Column := Column + 1
		WriteAddress (Word & Right, 0)
	     $)
     $)

let ListCodeItem (p) be
     $(	let Flags, Word, Comment = p!0, p!1, p!2
	switchon Flags & Right into
	     $(	case CodeSwitch:
		case InstructionSwitch:
		case DataSwitch:
		Writech (OUTPUT, GetRelCode ())
			Writech (OUTPUT, GetRelCode ())
			WriteH (LC)
			Writech (OUTPUT, '*s')
			WriteH (Word rshift 18)
			WriteH (Word & $8777777)
			Column := 0
			test (Flags & Right) = InstructionSwitch
			then $(	if LineCount ne 0 do
				     $(	Format (OUTPUT, "  ^d", LineCount)
					LineCount := 0
				     $)
				Writech (OUTPUT, '*t')
				let Param = Flags rshift Left
				if Param ne 0 test (Word & TagXrMask) = X1
					then Param := 0
					or Word := Word - (LookupLabel (Param) lshift 18)
				WriteInstruction (Word, Param)
			     $)
			or if (Flags & Right) = DataSwitch do
			     $(	Writech (OUTPUT, '*t')
				WriteData (Word, 0)
			     $)
			if Comment ne 0 do
			     $(	if Column < 10 do Writech (OUTPUT, '*t')
				Format (OUTPUT, "*t*" ^s", Comment)
			     $)
			Writech (OUTPUT, '*n')
			LC := LC + 1
			return

		case LabelSwitch:
			Format (OUTPUT, "*t*t*tL^d:*n", Word)
			return

		case LineCountSwitch:
			LineCount := Word
			return

		case HeaderSwitch:
			let v = vec Vmax
			Unpackstring (Comment, v)
			Format (OUTPUT, "^c*t*"*t", v!1)
			for i = 2 to v!0 do Writech (OUTPUT, v!i)
			WriteS (OUTPUT, "*n*n")
			return

		case SectionSwitch:
			LC := Word
			RelbitsList, RelbitsOffset, AbsRelBits := Comment, 0, 0
			return

		default:	CGreport (UnexpectedCase, Flags, "ListCodeItem")
	     $)
     $)
and GetRelCode () = valof
     $(	if AbsRelBits > 0 do
	     $(	AbsRelBits := AbsRelBits - 1
		resultis 'a'
	     $)
	if GetBits (1) = 0 resultis 'a'
	let c = GetBits (4)
	if c = (RelExtendedAbs & $817) do
	     $(	AbsRelBits := GetBits (10) - 1
		resultis 'a'
	     $)
	resultis '0' + c
     $)
and GetBits (n) = valof
     $(	RelbitsOffset := RelbitsOffset + n
	if RelbitsList = 0 do
	     $(	CGreport (PhaseError, "GetBits")
		resultis 0
	     $)
	let r = nil
	test RelbitsOffset le 36
	then r := RelbitsList!0 rshift (36 - RelbitsOffset)
	or   $(	RelbitsOffset := RelbitsOffset - 36
		r := RelbitsList!0 lshift RelbitsOffset
		RelbitsList := RelbitsList!1
		r := r | RelbitsList!0 rshift (36 - RelbitsOffset)
	     $)
	resultis r & true rshift (36 - n)
     $)
 



		    bcpl_cg_interface.bcpl          04/22/82  1624.2rew 04/22/82  1125.2       93456


//  Interface module between semantic translator and code generator of BCPL compiler.
//  Last modified on 06/06/74 at 18:24:52 by R F Mabee.
//  First installed as Version 3.4 by R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_trans_head"
get "bcpl_cg_head"
get "bcpl_metering_head"

let WriteOperand (Desc) be
     $(	if Desc = 0 do
	     $(	WriteS (OUTPUT, "*t0")
		return
	     $)
	Format (OUTPUT, "*t(^s", SymbolName (Desc!0))
	switchon Desc!0 into
	     $(	case NUMBER_S: case STRINGCONST_S: case CHARCONST_S: case EXTERNAL_S:
			Format (OUTPUT, " ^s", Desc!1)
			endcase
		case CONSTANT_S: case GLOBAL_S: case LV_GLOBAL: case LOCAL_S: case LV_LOCAL:
		case TEMP_S: case LV_TEMP: case STATIC_S: case LV_STATIC: case LABEL_S: case RTDEF_S:
			Format (OUTPUT, " ^d", Desc!1)
			endcase
		case TRUE_S: case FALSE_S:
			endcase
		case TABLE_S:
			Format (OUTPUT, " ^d", Desc!1!0)
			for i = 1 to Desc!1!0 do WriteConst (lv Desc!1!(i * 2 - 1))
			endcase
		default:	CGreport (UnexpectedCase, Desc!0, "WriteOperand")
			Format (OUTPUT, " ^o", Desc!1)
		     $)
	unless Desc!2 = 0 do Format (OUTPUT, "  /^s/", Desc!2)
	Writech (OUTPUT, ')')
     $)
and WriteConst (v) be
     $(	Writech (OUTPUT, '*s')
	switchon v!0 into
	     $(	case CONSTANT_S:
			WriteN (OUTPUT, v!1)
			return
		case NUMBER_S: case CHARCONST_S:
			WriteS (OUTPUT, v!1)
			return
		case TRUE_S:
			WriteS (OUTPUT, "TRUE")
			return
		case FALSE_S:
			WriteS (OUTPUT, "FALSE")
			return
		default:	CGreport (UnexpectedCase, v!0, "WriteConst")
	     $)
     $)

let GenerateJump (L) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do Format (OUTPUT, "JUMP ^d*n", L)
	Compjump (L)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)
and GenerateLabel (L) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do Format (OUTPUT, "LAB ^d*n", L)
	Complab (L)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)

let GenerateRtdefBegin (L, ID, Functsw, Mainsw) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do Format (OUTPUT, "^s ^d ^s ^b*n", (Functsw -> "FNDEF", "RTDEF"), L, ID, Mainsw)
	Compentry (L, ID, Functsw, Mainsw)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)
and GenerateRtdefEnd (Desc) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do
	     $(	WriteS (OUTPUT, Desc = 0 -> "RETURN", "RETURN_VAL")
		if Desc ne 0 do WriteOperand (Desc)
		Writech (OUTPUT, '*n')
	     $)
	Compreturn (Desc)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)

let GenerateGoto (Desc) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do
	     $(	WriteS (OUTPUT, "GOTO")
		WriteOperand (Desc)
		Writech (OUTPUT, '*n')
	     $)
	Compgoto (Desc)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)
and GenerateFinish () be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do WriteS (OUTPUT, "FINISH*n")
	Compfinish ()
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)
and ReserveArglist (Nargs) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do Format (OUTPUT, "ARGLIST ^d*n", Nargs)
	CreateArglist (Nargs)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)
and GenerateArg (i, Desc) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do
	     $(	Format (OUTPUT, "ARG ^d", i)
		WriteOperand (Desc)
		Writech (OUTPUT, '*n')
	     $)
	StoreArg (i, Desc)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)
and GenerateFnap (Result, F) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do
	     $(	WriteS (OUTPUT, Result = 0 -> "RTAP", "FNAP")
		WriteOperand (F)
		unless Result = 0 do WriteOperand (Result)
		Writech (OUTPUT, '*n')
	     $)
	Compfnap (Result, F)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)
and ReserveSystemArglist (Nargs) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do Format (OUTPUT, "SYSTEM_ARGLIST ^d*n", Nargs)
	CreateSystemArglist (Nargs)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)
and GenerateSystemArg (i, Arg, Offset, Type, Length, StringSw) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do
	     $(	Format (OUTPUT, "SYSTEM_ARG ^d", i)
		WriteOperand (Arg)
		WriteOperand (Offset)
		WriteOperand (Type)
		WriteOperand (Length)
		if StringSw do Writech (OUTPUT, " STRING")
		Writech (OUTPUT, '*n')
	     $)
	StoreSystemArg (i, Arg, Offset, Type, Length, StringSw)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)
and GenerateSystemCall (F) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do
	     $(	WriteS (OUTPUT, "SYSTEM_CALL ")
		WriteOperand (F)
		Writech (OUTPUT, '*n')
	     $)
	CompSystemCall (F)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)

let GenerateResultBlock () be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do WriteS (OUTPUT, "RESULT_BLOCK*n")
	ResultBlockBegin ()
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)
and GenerateResultValue (Desc) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do
	     $(	WriteS (OUTPUT, "SET_RESULT")
		WriteOperand (Desc)
		Writech (OUTPUT, '*n')
	     $)
	ResultSet (Desc)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)
and GenerateClaimResult (Desc) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do
	     $(	WriteS (OUTPUT, "CLAIM_RESULT")
		WriteOperand (Desc)
		Writech (OUTPUT, '*n')
	     $)
	ResultGet (Desc)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)

and GenerateSwitch (Desc, CaseList, DefaultL, EndcaseL) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do
	     $(	WriteS (OUTPUT, "SWITCHON")
		WriteOperand (Desc)
		let Ncases, t = 0, CaseList
		until t = 0 do t, Ncases := t!0, Ncases + 1
		Format (OUTPUT, " ^d ^d ^d", DefaultL, EndcaseL, Ncases)
		t := CaseList
		until t = 0 do
		     $(	Format (OUTPUT, " (^d", t!1)
			WriteConst (lv t!2)
			WriteConst (lv t!4)
			Writech (OUTPUT, ')')
			t := t!0
		     $)
		Writech (OUTPUT, '*n')
	     $)
	Compswitch (Desc, CaseList, DefaultL, EndcaseL)
	if Metering test Optimize
		  then RecordUsage (CompileSwitchWithOptimizing_Meter, UsageTemp)
		  or RecordUsage (CompileSwitchWithoutOptimizing_Meter, UsageTemp)
     $)

let GenerateMonadicOperator (Op, Result, Desc1) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do
	     $(	WriteS (OUTPUT, SymbolName (Op))
		WriteOperand (Result)
		WriteOperand (Desc1)
		Writech (OUTPUT, '*n')
	     $)
	Lrand := Desc1
	ApplyMonadicOperator (Op, Result)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)
and GenerateDiadicOperator (Op, Result, Desc1, Desc2) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do
	     $(	WriteS (OUTPUT, SymbolName (Op))
		WriteOperand (Result)
		WriteOperand (Desc1)
		WriteOperand (Desc2)
		Writech (OUTPUT, '*n')
	     $)
	Lrand, Rrand := Desc1, Desc2
	ApplyDiadicOperator (Op, Result)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)
and GenerateOffsetOperator (Op, Result, Desc1, Desc2, Offset) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do
	     $(	WriteS (OUTPUT, SymbolName (Op))
		WriteOperand (Result)
		WriteOperand (Desc1)
		WriteOperand (Desc2)
		Format (OUTPUT, " + ^d*n", Offset)
	     $)
	Lrand, Rrand := Desc1, Desc2
	ApplyOffsetOperator (Op, Result, Offset)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)

let GenerateMonadicConditional (Op, L, Desc1) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do
	     $(	Format (OUTPUT, "JUMP_^s ^d", SymbolName (Op), L)
		WriteOperand (Desc1)
		Writech (OUTPUT, '*n')
	     $)
	Lrand := Desc1
	MonadicJumpcond (Op, L)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)
and GenerateDiadicConditional (Op, L, Desc1, Desc2) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do
	     $(	Format (OUTPUT, "JUMP_^s ^d", SymbolName (Op), L)
		WriteOperand (Desc1)
		WriteOperand (Desc2)
		Writech (OUTPUT, '*n')
	     $)
	Lrand, Rrand := Desc1, Desc2
	DiadicJumpcond (Op, L)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)

let GenerateSSP (P) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do Format (OUTPUT, "SSP ^d*n", P)
	NewSSP (P)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)
and GenerateLineNumber (n) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do Format (OUTPUT, "LINE ^d*n", n)
	SetLineNumber (n)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)
and StoreAll () be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do WriteS (OUTPUT, "STORE_ALL*n")
	ClearRegisters ()
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)

and CgFinish (Static, Defs) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if OcodeSw do
	     $(	let t = Static
		until t = 0 do
		     $(	Format (OUTPUT, "STATIC ^d", t!1)
			WriteConst (lv t!3)
			Format (OUTPUT, "*t/^s/*n", t!2)
			t := t!0
		     $)
		t := Defs
		until t = 0 do
		     $(	Format (OUTPUT, "ENTRY ^s ^d*n", t!1, t!2)
			t := t!0
		     $)
	     $)
	FinishText (Static, Defs)
	if Metering do RecordUsage (CodeGeneration_Meter, UsageTemp)
     $)



		    bcpl_driver.bcpl                04/22/82  1624.2rew 04/22/82  1125.2      113769


//  The command interface for the compiler.
//  Last modified on 06/06/74 at 18:25:47 by R F Mabee.
//  Installed on 6180 as Version 3.4, R F Mabee.
//  ACL rings changed to V,V,V and installed as Version 2.8, R F Mabee.
//  First installed as Version 2.7 by R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "head"		//  Declarations for whole BCPL library, because driver uses things not in bcpl_compiler_head.
get "bcpl_compiler_head"	//  Declarations for compiler routines and global cells.
get "bcpl_metering_head"	//  Declarations for compiler metering tools.

external
     $(	BcplCommand = "bcpl_driver$bcpl"
	BcplMeters = "bcpl_driver$meters"

	Wdir = "get_wdir_"		//  call get_wdir_ (return dir name)
	GetGroupId = "get_group_id_"	//  call get_group_id_ (return userid)
	LevelGet = "cu_$level_get"	//  call cu_$level_get (return validation ring number)
	Initiate = "hcs_$initiate"	//  call hcs_$initiate (dir name, ent name, ref name, 0, 1, return ptr, return code)
	MakeSeg = "hcs_$make_seg"	//  call hcs_$make_seg (dir name, ent name, ref name, mode, return ptr, return code)
	AclAddOne = "hcs_$acl_add1"	//  call hcs_$acl_add1 (dir name, ent name, userid, mode, rings, return code)
	AclDelete = "hcs_$acl_delete"	//  call hcs_$acl_delete (dir name, entry name, acl ptr, count, return code)
	UnsnapLinks = "term_$nomakeunknown" // call term_$nomakeunknown (pointer, return code)

	SymbolTable = "bound_bcpl_$symbol_table"	//  Compiler's own symbol table contains time compiler updated.

	BadOpt = "error_table_$badopt"
	TranslationFailed = "error_table_$translation_failed"
     $)
static
     $(	StaticMeterData = 0
	StaticMeteringSw = false

	RE = 12
	RWA = 11
	Zero = 0
	One = 1
     $)
manifest
     $(	Empty = $8707070  $)	//  Used to indicate undefined state of truth value.


let BcplCommand () be main
     $(	Errcode, ProgramID := 0, "bcpl"
  Clp:	MONITOR := Open (Console + Write)
	OUTPUT := MONITOR
	let StartingTime = GetCpuUsage ()

	if Pl1NumbArgs () = 0 do
		Complain ("Pathname of source file is required as first argument.  Options:*n^a*n^a",
			"General:  list  source  xref  alist  check  uppercase  symbols  map  optimize  quiet",
			"Compiler debug:  time  print_meters  tree  crep  pprep  645  ocode")

//  Process options.
	let Source, Alist = Empty, Empty
	and List, Time, DumpTree, MetersPrintSw, Check = false, false, false, false, false
	and Followon = true			//  This is the 6180 version.
	Xref, LineMap, Optimize := Empty, Empty, Empty
	Crep, PPrep, OcodeSw, QuietSw, Symbols, UpperCase := false, false, false, false, false, false

	let Names = list "list", "xref", "source", "alist", "tree",
			"check", "uppercase", "symbols", "map", "optimize",
			"crep", "pprep", "time", "quiet", "print_meters",
			"645", "ocode"
	and Pointers = list lv List, lv Xref, lv Source, lv Alist, lv DumpTree,
			lv Check, lv UpperCase, lv Symbols, lv LineMap, lv Optimize,
			lv Crep, lv PPrep, lv Time, lv QuietSw, lv MetersPrintSw,
			lv Followon, lv OcodeSw
	and Flags = table OptNegatable, OptNegatable, OptNegatable, OptNegatable, OptNegatable,
			OptNegatable, OptNegatable, OptNegatable, OptNegatable, OptNegatable,
			OptNegatable, OptNegatable, OptNegatable, OptNegatable, OptNegatable,
			OptNegatable | OptNegate, OptNegatable
	ArgIndex := 2		//  Used by GetNextCommandArg.
	OptionParse (GetNextCommandArg, 17, Names, Pointers, Flags, 0)
			//  Apply complicated defaults.
	if Xref = Empty do Xref := List
	if Source = Empty do Source := List | Xref
	if Alist = Empty do Alist := List
	Check := Check | Crep
	if Optimize = Empty do Optimize := Source & not (Check | Symbols)	//  Guess whether this compilation is final version.
	if LineMap = Empty do LineMap := not (Optimize | Check)
	LineMap := LineMap | Symbols

	HaveListingFile := (Source | Xref | Alist | DumpTree | OcodeSw | PPrep) & not Crep
	Machine := Followon -> 6180, 645
	Metering := MetersPrintSw logor StaticMeteringSw
	let TimeSummary, TimeTemp = Time | HaveListingFile, nil
			//  Make list of options used.
	OptionString := vec 128
	SetLength (OptionString, 0)
	if Source do AddOption ("source")
	if Xref do AddOption ("xref")
	if DumpTree do AddOption ("tree")
	if Alist do AddOption ("alist")
	if Check do AddOption ("check")
	if UpperCase do AddOption ("uppercase")
	if Symbols do AddOption ("symbols")
	if LineMap do AddOption ("map")
	if Optimize do AddOption ("optimize")
	if PPrep do AddOption ("pprep")
	if OcodeSw do AddOption ("ocode")
	AddOption (Followon -> "6180", "645")

//  Process file name argument.
	let Arg = vec 100
	Pl1ArgString (1, Arg, 100 * 4)
	let Len = Length (Arg)
	if Len > 5 do		//  If the ".bcpl" suffix might already be present.
	     $(	let w = vec 5
		Substr (w, Arg, Len - 4, 5)
		if EqualString (w, ".bcpl") do SetLength (Arg, Len - 5)
	     $)
	let Path, Dir, Ent = vec 50, vec 50, vec 10
	ExpandPathname (Arg, Path)
	SplitPathname (Path, Dir, Ent)
	unless Errcode = 0 do Complain (Arg)
	ProgramName := vec 8
	MakeBcplString (Ent, 32, ProgramName)

//  Set up some more environment things.
		//  Temporary kludge to check for stack segment too full to allow for Newvec space.
	if (ProgramName & Right) ge 45000 do Complain ("Not enough room left in stack to perform compilation. Type 'release'.")

	let v = vec 10000
	UtilitiesInit (v, 10000, StartingTime)
	let v = vec 20
	SetHandler ("cleanup", Cleanup, v)
	SetOverflowMask (true)	//  Turn off overflow faults.

	Errorsw := false
	NAMECHAIN := 0

	GetVersion ()		//  Compiler version info is isolated in small easily changed program.

		//  Get date/time compiler was updated (bound) from symbol table of bound segment.
	CompilerDTM, TimeNow := vec 2, vec 2
	CompilerDTM!0, CompilerDTM!1 := SymbolTable!6, SymbolTable!7
	RawClockTime (TimeNow)
	CompilerDTMString, TimeNowString := MakeTimeString (CompilerDTM), MakeTimeString (TimeNow)

	UserID := vec 8
	let v = vec 8
	call GetGroupId (v char 32)
	MakeBcplString (v, 32, UserID)

//  Open input and output files.
	test Crep
	then $(	INPUT := Open (Console + Read)
		FilesInfo!0, FilesInfo!1, FilesInfo!2, FilesInfo!3 := "console", 0, 0, 0
		FileNames!0 := "console"
		LineCount := FileCount lshift FileShift
		WriteS (MONITOR, "Type program:*n")
	     $)
	or   $(	GetStream (Arg, 0)		//  0 indicates no previous input stream for searching.
		if HaveListingFile do
		     $(	let w = vec 50
			OUTPUT := Open (EntryName + Write + MultiSegmentFile, Concatenate (w, 32, ProgramName, ".list"))
			unless Errcode = 0 do Complain (w)
			Format (OUTPUT, "Compilation listing of file ^s.*n", FilesInfo!0)
			Format (OUTPUT, "Compilation performed for ^s at ^s.*n", UserID, TimeNowString)
			Format (OUTPUT, "Compiled by ^s.  Compiler updated at ^s.*n",
								CompilerVersionString, CompilerDTMString)
			Format (OUTPUT, "Options applied:  ^s.*n*n", OptionString)
		     $)
		WriteS (MONITOR, "BCPL*n")
	     $)

//  Read source program and construct syntax tree.
	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	if TimeSummary do TimeTemp := GetCpuUsage ()
	Listing := Source

	LexInit ()
	let A = CAE ()
	if Crep & A = 0 & not Errorsw finish	//  Escape from type-in mode.
	if Metering do
	     $(	MeterData!TotalLines_Count := TotalLines
		RecordUsage (SyntaxAnalysis_Meter, UsageTemp)
	     $)
	Close (INPUT)
	INPUT := 0
	if TimeSummary do Wrtime ("CAE", GetCpuUsage () - TimeTemp, "source lines", TotalLines, Time)

//  Put out optional cross reference and tree listings.
	if Xref do
	     $(	Writech (OUTPUT, Crep -> '*n', '*f')
		WriteS ("cross reference table*n*n")
		Pname (NAMECHAIN)
	     $)
	if DumpTree do
	     $(	Writech (OUTPUT, Crep -> '*n', '*f')
		WriteS ("abstract syntax tree*n*n")
		Plist (A, 0)
	     $)

//  Perform semantic translation on syntax tree, generating machine code and listing.
	unless Errorsw do
	     $(	Listing := Alist & Check		//  Generate only partial listing during Trans.
		if Metering do UsageTemp := SaveOldUsage ()
		if TimeSummary do TimeTemp := GetCpuUsage ()
		CgInit ()
		Trans (A)
		if Metering do
		     $(	MeterData!TextWords_Count := TotalWords
			RecordUsage (SemanticTranslation_Meter, UsageTemp)
		     $)
		if TimeSummary do Wrtime ("Trans", GetCpuUsage () - TimeTemp, "object words", TotalWords, Time)
		if Alist & not Check do WriteObjectListing ()	//  Generate full listing in separate pass.
	     $)
	unless OUTPUT = MONITOR do
	     $(	Close (OUTPUT)
		OUTPUT := MONITOR
	     $)

//  Form object segment out of internally-stored machine code program.
	unless Check | Errorsw do
	     $(	let x, y = nil, nil
		let v = vec 2
		if Metering do UsageTemp := SaveOldUsage ()
		call Wdir (Dir char 168)
		call Initiate (Dir char 168, Ent char 32, "" char 0, lv Zero, lv One, v pointer, lv Errcode)
		let P = BCPLaddr (v)
		unless Errcode = 0 do
			test P = Null
			then $(	call MakeSeg (Dir char 168, Ent char 32, "" char 0, lv RE, v pointer, lv Errcode)
				P := BCPLaddr (v)
				if P = Null do Complain ("Unable to create object segment ^a.", ProgramName)
			     $)
			or call UnsnapLinks (ITS (P, v), lv Errcode)	// Segment in use, unlink it.
		let AclArray, Rings = vec 8, vec 3
		MakePl1String (UserID, AclArray, 32)
		AclArray!8 := 0
		call LevelGet (lv x)
		Rings!0, Rings!1, Rings!2 := x, x, x
		call AclAddOne (Dir char 168, Ent char 32, AclArray char 32, lv RWA, Rings, lv Errcode)
		unless Errcode = 0 do Complain ("Unable to change ACL of object segment ^a.", ProgramName)
		x := BuildObject (P)
		SetBitCount (P, x)
		call AclDelete (Dir char 168, Ent char 32, ITS (AclArray, v) pointer, lv One, lv Errcode)
		Terminate (P)
		if Metering do RecordUsage (MakeObject_Meter, UsageTemp)
	     $)

//  Print or save meter values as required.
	if Metering do
	     $(	RecordUsage (DriverOverhead_Meter, 0)
		let Elapsed, Total, Calls = GetCpuUsage () - StartingTime, 0, 0
		for i = 0 to MeteringOverhead_Meter - 1 by 3 do
			Total, Calls := Total + MeterData!i, Calls + MeterData!(i + 1)
		MeterData!MeteringOverhead_Meter := Elapsed - Total
		MeterData!(MeteringOverhead_Meter + 1) := Calls
		for i = 0 to MeteringOverhead_Meter by 3 unless MeterData!i = 0 do MeterData!(i + 2) := Total
		MeterData!DictionaryDepth_Count := DictionaryDepth
		if StaticMeteringSw do for i = 0 to Meters_Length do StaticMeterData!i := StaticMeterData!i + MeterData!i
		if MetersPrintSw do PrintMeters (MeterData)
	     $)

//  Almost done.  Clean up and report success/failure in form suitable for programmed interpretation.
	Cleanup ()
	RevertHandler ("cleanup")
	Close (MONITOR)
	if Crep goto Clp		//  "C_ompile and _r_e_peat" - jump back to beginning of driver.

	if Errorsw do
	     $(	Errcode := rv TranslationFailed
		Complain (Arg)
	     $)
     $)

and AddOption (s) be		//  Append option name to list in OptionString.
	test Length (OptionString) = 0
	then CopyString (s, OptionString)
	or Concatenate (OptionString, 511, OptionString, "  ", s)
and Wrtime (ID, Usage, Thing, Nthings, Time) be	//  Report time used, etc. in listing and console streams.
     $(	let Rate = Nthings * 1000 * 1000 / Usage
	Usage := Usage / 100 / 1000
	let a, b = Usage / 10, Usage rem 10
	if Time do Format (MONITOR, "^s time ^d.^d, ^d ^s per second.*n", ID, a, b, Rate, Thing)
	if HaveListingFile do Format (OUTPUT, "*n*n*n^s time ^d.^d, ^d ^s per second.*n", ID, a, b, Rate, Thing)
     $)

let BcplMeters () be main		//  Entry to control static metering of compiler.
     $(	Errcode, ProgramID := 0, "bcpl$meters"
	if Pl1NumbArgs () = 0 do Complain ("Options are:  print  reset  meter  no_meter")

	let Print, Reset, Start = false, false, Empty
	let Names = list "print", "reset", "meter"
	and Pointers = list lv Print, lv Reset, lv Start
	and Flags = list OptNegatable, OptNegatable, OptNegatable
	ArgIndex := 1
	OptionParse (GetNextCommandArg, 3, Names, Pointers, Flags, 0)

	if StaticMeterData = 0 do
	     $(	let x = Allocate (Meters_Length + 1)
		for i = 0 to Meters_Length do x!i := 0
		StaticMeterData := x
	     $)
	unless Start = Empty do StaticMeteringSw := Start
	if Print do
	     $(	if StaticMeterData!(MeteringOverhead_Meter + 1) = 0 do Complain ("No metering data available.")
		OUTPUT := Open (Console + Write)
		PrintMeters (StaticMeterData)
		Close (OUTPUT)
	     $)
	if Reset then for i = 0 to Meters_Length do StaticMeterData!i := 0
     $)
   



		    bcpl_lex0.bcpl                  04/22/82  1624.2rew 04/22/82  1125.2       74844


//  This part of the lexical analyzer contains the miscellaneous short routines.
//  Last modified on 06/06/74 at 18:25:50 by R F Mabee.
//  Slight modifications installed on 6180 as Version 3.4 by R F Mabee.
//  First installed as Version 2.7 on 645 by R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_lex_head"
get "bcpl_metering_head"

manifest
     $(	HashSize = 101  $)


//  The routine Rch fetches the next input character, sets Chkind to reflect its type,
//  writes the character in the listing, keeps track of line numbers for cross-reference and
//  for error messages, and switches input streams when end-of-file is detected.

let Rch () be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
  Top:	Readch (INPUT, Lvch)
	Chkind := valof switchon Ch into
	     $(	case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': case 'G':
		case 'H': case 'I': case 'J': case 'K': case 'L': case 'M': case 'N':
		case 'O': case 'P': case 'Q': case 'R': case 'S': case 'T': case 'U':
		case 'V': case 'W': case 'X': case 'Y': case 'Z':
			resultis Capital

		case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'g':
		case 'h': case 'i': case 'j': case 'k': case 'l': case 'm': case 'n':
		case 'o': case 'p': case 'q': case 'r': case 's': case 't': case 'u':
		case 'v': case 'w': case 'x': case 'y': case 'z':
			resultis Small

		case '0': case '1': case '2': case '3': case '4':
		case '5': case '6': case '7': case '8': case '9':
			resultis Digit

		case '{': case '}':
			resultis Bracket

		case '_':	resultis UnderScore

		case '*s': case '*t': case '*r':
		case '*v': case '*d': case '*k':
		case '*f': case '*b':
			resultis Ignorable

		case '*n':EndCurrentLine := true
			resultis Endline

		case '?':	unless Crep & NestingDepth = 0 resultis Simple	//  Terminator for typed-in program, otherwise illegal.

		case Endofstreamch:
			unless EndOfAllInputReached do TotalLines := TotalLines + (LineCount & LineMask)
			if NestingDepth = 0 do		//  If the outermost source file is finished...
			     $(	Chkind := Endline
				EndOfAllInputReached := true
				goto Exit
			     $)
			if Listing & not BeginNewLine do Writech (OUTPUT, '*n')
			NestingDepth := NestingDepth - 1		//  For indenting listing.
			PopInput ()
			NLPending := true
			goto Top

		default:	resultis Simple
	     $)
	if BeginNewLine do
	     $(	LineCount := LineCount + 1
		if Listing do
		     $(	for i = 1 to NestingDepth do Writech (OUTPUT, '*t')
			Format (OUTPUT, "  ^4d*t", LineCount & LineMask)
		     $)
		BeginNewLine := false
	     $)
	if Listing do Writech (OUTPUT, Ch)
	if EndCurrentLine do BeginNewLine, EndCurrentLine := true, false

  Exit:	if Metering do RecordUsage (Listing -> RchWithListing_Meter, RchWithoutListing_Meter, UsageTemp)
     $)


manifest
     $(	Must = $8100		//  Categories for symbols with respect to insertion of ; and _d_o.
	May = $8000
	BeginCommand = $8010
	EndCommand = $8001
     $)

//  Nextsymb is used throughout the syntax analyzer to get the next input canonical symbol.
//  It puts the internal representation (a named constant) for the input token in the global cell Symb.
//  This routine applies the pre-processor rules for inserting DO and SEMICOLON,
//  as well as detecting a GET phrase.  Nsymb is used to obtain actual input symbols.

let Nextsymb () be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	unless SavedSymb = 0 do
	     $(	Symb := SavedSymb
		SavedSymb := 0
		goto Exit
	     $)
  Rnext:	Symb := Nsymb ()
	let Category = valof switchon Symb into
	     $(	case GET_S:
			ProcessGet ()
			goto Rnext

		case NAME_S:
			if Xref do EnterIntoCrossreference ()

		case FALSE_S: case TRUE_S: case NUMBER_S:
		case STRINGCONST_S: case CHARCONST_S:
			resultis May | BeginCommand | EndCommand

		case PLUS_S: case MINUS_S: case SECTBRA_S: case RBRA_S: case VALOF_S:
		case TABLE_S: case LIST_S: case SECTBEGIN_S: case NOT_S:
		case RV_S: case LV_S:
			resultis May | BeginCommand

		case BREAK_S: case ENDCASE_S: case LOOP_S: case FINISH_S: case RETURN_S:
			resultis Must | BeginCommand | EndCommand

		case MANIFEST_S: case GLOBAL_S: case STATIC_S: case EXTERNAL_S:
		case LET_S: case STRUCTURE_S:
		case CALL_S: case CASE_S: case DEFAULT_S:
		case FOR_S: case GOTO_S:
		case IF_S: case RESULTIS_S:
		case SWITCHON_S: case TEST_S: case UNLESS_S:
		case UNTIL_S: case WHILE_S:
			resultis Must | BeginCommand

		case REPEAT_S:
			resultis Must | EndCommand

		case NIL_S: case RKET_S: case SKET_S: case SECTKET_S: case SECTEND_S:
			resultis May | EndCommand

		default:	resultis 0		//  Can't begin or end a command.
	     $)
	test NLPending
	then $(	NLPending := false
		if (ST & EndCommand) ne 0 & (Category & BeginCommand) ne 0 do
		     $(	SavedSymb := Symb
			Symb := SEMICOLON_S
		     $)
	     $)
	or if (ST & EndCommand) ne 0 & (Category & (Must | BeginCommand)) = (Must | BeginCommand) do
		     $(	SavedSymb := Symb
			Symb := DO_S
		     $)
	ST := Category
  Exit:	if Metering do RecordUsage (Nextsymb_Meter, UsageTemp)
	if PPrep do
	     $(	WriteS (OUTPUT, SymbolName (Symb))
		Writech (OUTPUT, '*n')
	     $)
     $)
and ProcessGet () be		//  Handle GET phrase for Nextsymb.
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	unless Nsymb () = STRINGCONST_S do
	     $(	CaeReport (GetStringMissing)
		goto Exit
	     $)
	unless BeginNewLine do
	     $(	if Listing do Writech (OUTPUT, '*n')
		LineCount := LineCount - 1
	     $)
	PushInput (DictionaryEntry!1)
	NestingDepth := NestingDepth + 1		//  For indenting listing.
	BeginNewLine, NLPending := true, true
	Ch, Chkind := '*n', Endline

  Exit:	if Metering do RecordUsage (ProcessGet_Meter, UsageTemp)
     $)

//  EnterIntoDictionary is called to record any string in the compiler's symbol table so that it may
//  be referenced by a unique pointer to a dictionary entry.  Result is left in global DictionaryEntry.

let EnterIntoDictionary (Unpacked, Type) = valof
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	let String = vec Vmax
	Packstring (Unpacked, String)
	let Len = LengthInWords (String) - 1
	let Hash = String!0 + String!Len		//  Use primitive hashing to fan out binary tree rapidly.
	if Hash < 0 do Hash := - Hash
	let Q = lv NamesTable!(Hash rem HashSize)		//  Separate name chain for each hash value.
	     $(	DictionaryEntry := rv Q
		DictionaryDepth := DictionaryDepth + 1
		if DictionaryEntry = 0 break		//  Not found.
		let d = String!0 - DictionaryEntry!1!0	//  Compare raw representations.
		if d = 0 then for i = 1 to Len do
		     $(	d := String!i - DictionaryEntry!1!i
			unless d = 0 break
		     $)
		if d = 0 do			//  Is found.
		     $(	if Metering do RecordUsage (SymbolSearch_Meter, UsageTemp)
			resultis DictionaryEntry!0
		     $)
		Q := d < 0 -> lv DictionaryEntry!4, lv DictionaryEntry!5
	     $)	repeat
	DictionaryEntry := List6 (Type, StoreString (String), 0, 0, 0, 0)	
		//  Format:  type, name pointer, value cell for Trans, xref list, < dict list, > dict list.
	rv Q := DictionaryEntry		//  And enter into symbol tree.
	if Metering do RecordUsage (SymbolAdd_Meter, UsageTemp)
	resultis Type
     $)


//  This is LexInit, which initializes some global cells for the lexical analyzer,
//  and loads up the dictionary with all the reserved words with their internal values.
//  The lexical phase (Lex) operates as a co-routine to the syntactic phase (Cae).
//  Cae can keep things in its stack, but Lex must store everything in global cells.

let LexInit () be
     $(	Ch, Chkind, Lvch := '*n', Endline, lv Ch
	BeginNewLine, EndCurrentLine := true, false
	EndOfAllInputReached := false
	NestingDepth := 0
	NLPending, ST, SavedSymb := true, 0, 0
	V, Vp := Newvec (Vmax), 0
	TotalLines, DictionaryDepth := 0, 0
	NamesTable := Newvec (HashSize)
	for i = 0 to HashSize do NamesTable!i := 0

	LoadDictionary ()
	Nextsymb ()		//  Symb should always be valid.
     $)



		    bcpl_lex1.bcpl                  04/22/82  1624.2rew 04/22/82  1125.2       42516


//  This is Nsymb, which returns the next symbol of the real program (before SEMICOLON_S is inserted.)
//  Last modified on 06/06/74 at 18:25:56 by R F Mabee.
//  Installed on 6180 as Version 3.4, R F Mabee.
//  First installed on 645 as Version 2.7, R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_lex_head"

let Nsymb () = valof
     $(	let Sym = nil
	Vp := 0
  Top:	switchon Chkind into
	     $(	case Ignorable:
			Rch () repeatwhile Chkind = Ignorable
			goto Top

		case Small:
			SaveCh () repeatwhile Chkind = Small
			V!0 := Vp
			Sym := EnterIntoDictionary (V, NAME_S)
			if Sym = NAME_S & Vp ge 2 do CaeReport (BadSystemword, DictionaryEntry!1)
			resultis Sym

		case Capital:
			SaveCh () repeatwhile Chkind ge Digit
			V!0 := Vp
			resultis EnterIntoDictionary (V, NAME_S)

		case Digit:
			SaveCh () repeatwhile Chkind = Digit
			if Ch = '.' do
			     $(	SaveCh () repeatwhile Chkind = Digit
				if Ch = 'e' logor Ch = 'E' do
				     $(	SaveCh ()
					if Ch = '+' logor Ch = '-' do SaveCh ()
					test Chkind = Digit
					then SaveCh () repeatwhile Chkind = Digit
					or CaeReport (BadNumber)
				     $)
			     $)
			V!0 := Vp
			resultis EnterIntoDictionary (V, NUMBER_S)

		case Bracket:
			test Ch = '{'
			then Sym := SECTBRA_S
			or Sym, Ch := SECTKET_S, '{'		//  Make string part same as SECTBRA_S.
		  Rtag:	SaveCh () repeatwhile Chkind ge Digit
			V!0 := Vp
			EnterIntoDictionary (V, SECTBRA_S)
			resultis Sym

		case Endline:
			if EndOfAllInputReached resultis ENDPROG_S
			NLPending := true
			Rch () repeatwhile Ch = '*n'
			goto Top

		case UnderScore:		//  Illegal character, so it falls through.
		case Simple:
	     $)

	let c = Ch
	Rch ()
	switchon c into
	     $(	default:	CaeReport (BadCharacter, c)
			goto Top

		case '(':	resultis RBRA_S
		case ')':	resultis RKET_S
		case '[':	resultis SBRA_S
		case ']':	resultis SKET_S
		case ',':	resultis COMMA_S
		case '!':	resultis VECAP_S
		case '&':	resultis LOGAND_S
		case '|':	resultis LOGOR_S
		case ';':	resultis SEMICOLON_S
		case '=':	resultis VALDEF_S
		case '+':	resultis PLUS_S
		case '**':resultis MULT_S

		case '-':	unless Ch = '>' logor Ch = '**' resultis MINUS_S
			Rch ()
			resultis COND_S
		case '/':	unless Ch = '/' resultis DIV_S
			Rch () repeatuntil Chkind = Endline
			goto Top
		case ':':	unless Ch = '=' resultis COLON_S
			Rch ()
			resultis ASSIGN_S
		case '^':	unless Ch = '=' resultis NOT_S
			Rch ()
			resultis NE_S
		case '<':	unless Ch = '=' resultis LS_S
			Rch ()
			resultis LE_S
		case '>':	unless Ch = '=' resultis GR_S
			Rch ()
			resultis GE_S

		case '$':	switchon Ch into
			     $(	case '(':	Sym := SECTBRA_S
					goto Rtag

				case ')':	Sym, Ch := SECTKET_S, '('
					goto Rtag

				case '2': case '8': case 'X':
					V!1, Vp := '$', 1
					c := Ch		//  Remember base.
					     $(	SaveCh ()
						switchon Ch into
						     $(	case '8': case '9': case 'A': case 'B':
							case 'C': case 'D': case 'E': case 'F':
								if c = 'X' loop
								break
							case '2': case '3': case '4':
							case '5': case '6': case '7':
								unless c = '2' loop
								break
							case '0': case '1':
								loop
							default:	break
						     $)
					     $)	repeat
					V!0 := Vp
					resultis EnterIntoDictionary (V, NUMBER_S)

				default:	CaeReport (BadDollar, Ch)
					goto Top
			     $)

		case '.':	c := Nsymb ()
			switchon c into
			     $(	case VALDEF_S:
				case EQ_S:	resultis EQ_F
				case NE_S:	resultis NE_F
				case LS_S:	resultis LS_F
				case LE_S:	resultis LE_F
				case GR_S:	resultis GR_F
				case GE_S:	resultis GE_F
				case PLUS_S:	resultis PLUS_F
				case MINUS_S:	resultis MINUS_F
				case MULT_S:	resultis MULT_F
				case DIV_S:	resultis DIV_F
				default:		CaeReport (BadFloat)
						resultis c
			     $)

		case '*'':
			Sym := CHARCONST_S
			goto Rstring
		case '"':
			Sym := STRINGCONST_S
		Rstring:	V!1, Vp := c, 1
			until Ch = c do
			     $(	if Ch = '**' do SaveCh ()
				SaveCh ()
				if Vp ge Vmax break
			     $)
			SaveCh ()
			V!0 := Vp
			resultis EnterIntoDictionary (V, Sym)
	     $)
     $)

and SaveCh () be		//  Subroutine to stash current character and get next.
     $(	Vp := Vp + 1
	if Vp ge Vmax do
	     $(	if Vp = Vmax do CaeReport (TokenTooLong, Vmax)		//  Trick to avoid repeating message.
		Vp := Vmax
	     $)
	V!Vp := Ch
	Rch ()
     $)



		    bcpl_lex2.bcpl                  04/22/82  1624.2rew 04/22/82  1125.2       37215


//  These routines are used for initialization of the lexical analyzer.
//  Last modified on 06/06/74 at 18:25:59 by R F Mabee.
//  Prepared for installation with Version 3.4, R F Mabee.
//  Rewritten in March 1973 to predefine reserved words rather than recognize then algorithmically (old Lookupword).
//  First version installed in Version 2.7, R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_lex_head"


//  This routine applies a given routine to all the system words and their internal codes.

let MapSystemwords (MapF) be
     $(	MapF ("and", AND_S)

	MapF ("break", BREAK_S); MapF ("be", BE_S); MapF ("begin", SECTBEGIN_S)
	MapF ("bit", BIT_S); MapF ("by", BY_S)

	MapF ("case", CASE_S); MapF ("call", CALL_S); MapF ("char", CHAR_S)

	MapF ("do", DO_S); MapF ("default", DEFAULT_S); MapF ("double", DOUBLE_S)

	MapF ("endcase", ENDCASE_S); MapF ("else", OR_S); MapF ("end", SECTEND_S)
	MapF ("eqv", EQV_S); MapF ("external", EXTERNAL_S); MapF ("eq", EQ_S)

	MapF ("for", FOR_S); MapF ("false", FALSE_S); MapF ("fixed", FIXED_S)
	MapF ("finish", FINISH_S); MapF ("float", FLOAT_S)

	MapF ("goto", GOTO_S); MapF ("ge", GE_S); MapF ("get", GET_S)
	MapF ("global", GLOBAL_S); MapF ("gr", GR_S)

	MapF ("if", IF_S); MapF ("ifso", IFSO_S); MapF ("ifnot", IFNOT_S)
	MapF ("into", INTO_S)

	MapF ("let", LET_S); MapF ("le", LE_S); MapF ("loop", LOOP_S)
	MapF ("logand", LOGAND_S); MapF ("logor", LOGOR_S); MapF ("length", LENGTH_S)
	MapF ("list", LIST_S); MapF ("lshift", LSHIFT_S); MapF ("lv", LV_S)
	MapF ("ls", LS_S)

	MapF ("manifest", MANIFEST_S); MapF ("main", MAIN_S)

	MapF ("nil", NIL_S); MapF ("not", NOT_S); MapF ("ne", NE_S)
	MapF ("neqv", NEQV_S)

	MapF ("or", OR_S); MapF ("offset", OFFSET_S); MapF ("otherwise", OR_S)

	MapF ("pointer", POINTER_S); MapF ("ptr", POINTER_S)

	MapF ("repeatuntil", REPEATUNTIL_S); MapF ("resultis", RESULTIS_S); MapF ("rem", REM_S)
	MapF ("repeatwhile", REPEATWHILE_S); MapF ("rshift", RSHIFT_S); MapF ("return", RETURN_S)
	MapF ("repeat", REPEAT_S); MapF ("rv", RV_S); MapF ("rep", REP_S)

	MapF ("static", STATIC_S); MapF ("structure", STRUCTURE_S); MapF ("switchon", SWITCHON_S)
	MapF ("string", STRING_S); MapF ("step", BY_S)

	MapF ("then", DO_S); MapF ("table", TABLE_S); MapF ("test", TEST_S)
	MapF ("true", TRUE_S); MapF ("type", TYPE_S); MapF ("to", TO_S)

	MapF ("unless", UNLESS_S); MapF ("until", UNTIL_S)

	MapF ("valof", VALOF_S); MapF ("vec", VEC_S)

	MapF ("while", WHILE_S)
     $)

//  Initialize the dictionary to contain all reserved words for faster lookup later.

let LoadDictionary () be
     $(	MapSystemwords (DefineSystemword)
	if UpperCase do MapSystemwords (DefineUppercaseSystemword)
     $)
and DefineSystemword (Word, Symbol) be
     $(	Unpackstring (Word, V)
	EnterIntoDictionary (V, Symbol)
     $)
and DefineUppercaseSystemword (Word, Symbol) be
     $(	Unpackstring (Word, V)
	for i = 1 to V!0 do V!i := MakeUpperCase (V!i)
	EnterIntoDictionary (V, Symbol)
     $)
and MakeUpperCase (c) = valof switchon c into		//  Map lower case to upper for any character set.
     $(	case 'a':	resultis 'A'
	case 'b':	resultis 'B'
	case 'c': resultis 'C'
	case 'd': resultis 'D'
	case 'e': resultis 'E'
	case 'f': resultis 'F'
	case 'g': resultis 'G'
	case 'h': resultis 'H'
	case 'i': resultis 'I'
	case 'j': resultis 'J'
	case 'k': resultis 'K'
	case 'l': resultis 'L'
	case 'm': resultis 'M'
	case 'n': resultis 'N'
	case 'o': resultis 'O'
	case 'p': resultis 'P'
	case 'q': resultis 'Q'
	case 'r': resultis 'R'
	case 's': resultis 'S'
	case 't': resultis 'T'
	case 'u': resultis 'U'
	case 'v': resultis 'V'
	case 'w': resultis 'W'
	case 'x': resultis 'X'
	case 'y': resultis 'Y'
	case 'z': resultis 'Z'
	default:	resultis c	//  All others map into themselves.
     $)
 



		    bcpl_meter_print.bcpl           04/22/82  1624.2rew 04/22/82  1125.2       39267


//  Routines for printing out the results of metering the BCPL compiler.
//  Last modified on 06/06/74 at 18:26:03 by R F Mabee.
//  First installed as Version 3.4, R F Mabee.
//  Written in April 1973 in order to compare performance of BCPL compiler on 645 vs. 6180.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_compiler_head"
get "bcpl_metering_head"

global
     $(	MeterPointer : GlobalTemp  $)

let PrintMeters (BV_MeterPointer) be
     $(	MeterPointer := BV_MeterPointer
	let TotalTime = MeterPointer!(MeteringOverhead_Meter + 2)
	let Lines, Words = MeterPointer!TotalLines_Count, MeterPointer!TextWords_Count
	WriteS (OUTPUT, "*n*tBCPL COMPILER METERING RESULTS*n*nTotal time is")
	PrintTime (TotalTime)
	WriteS (OUTPUT, ".*n")
	if TotalTime = 0 return
	let TimeMillisecs = TotalTime / 1000
	if TimeMillisecs = 0 do TimeMillisecs := 1
	Format (OUTPUT, "Overall speed was ^d source lines per second, ^d object words per second",
			Lines * 1000 / TimeMillisecs, Words * 1000 / TimeMillisecs)
	unless Lines = 0 do
	     $(	WriteS (OUTPUT, " (")
		PrintFraction (Words * 100 / Lines, 100)
		WriteS (OUTPUT, " words per line)")
	     $)
	WriteS (OUTPUT, ".*n*n")

	PrintAverage (RchWithoutListing_Meter, "Rch, no listing")
	PrintAverage (RchWithListing_Meter, "Rch, with listing")
	PrintAverage (Nextsymb_Meter, "Nextsymb")
	PrintAverage (SymbolAdd_Meter, "Dictionary lookup (symbol added)")
	PrintAverage (SymbolSearch_Meter, "Dictionary lookup (already present)")
	let D = MeterPointer!(SymbolAdd_Meter + 1) + MeterPointer!(SymbolSearch_Meter + 1)
	unless D = 0 do
	     $(	WriteS (OUTPUT, "Average dictionary depth is ")
		PrintFraction (MeterPointer!DictionaryDepth_Count * 100 / D, 100)
		Writech (OUTPUT, '*n')
	     $)
	PrintAverage (ProcessGet_Meter, "ProcessGet")
	PrintPerUnit (SyntaxAnalysis_Meter, "Syntax analyzer", Lines, "line")
	PrintAverage (PrintXref_Meter, "Pname")
	PrintPerUnit (SemanticTranslation_Meter, "Semantic translator", Words, "word")
	PrintAverage (CompileExpression_Meter, "Compile expression")
	PrintAverage (CompileSwitchWithoutOptimizing_Meter, "Compile switchon, no optimization")
	PrintAverage (CompileSwitchWithOptimizing_Meter, "Compile switchon, with optimization")
	PrintAverage (CodeGeneration_Meter, "Code generation phase")
	PrintAverage (MakeObject_Meter, "Creating object segment")
	PrintAverage (DriverOverhead_Meter, "Miscellaneous in command interface")
	PrintAverage (MeteringOverhead_Meter, "Metering calls")
	Writech (OUTPUT, '*n')
     $)
and PrintPerUnit (Meter, Comment, Unit, UnitComment) be
     $(	if MeterPointer!Meter = 0 return
	WriteS (OUTPUT, Comment)
	PrintTime (MeterPointer!Meter)
	Writech (OUTPUT, ',')
	unless Unit = 0 do
	     $(	PrintTime (MeterPointer!Meter / Unit)
		Format (OUTPUT, " per ^s,", UnitComment)
	     $)
	PrintPercent (Meter)
     $)
and PrintAverage (Meter, Comment) be
     $(	if MeterPointer!Meter = 0 return
	WriteS (OUTPUT, Comment)
	test MeterPointer!(Meter + 1) = 1	//  Event happened only once.
	then $(	PrintTime (MeterPointer!Meter)
		Writech (OUTPUT, ',')
	     $)
	or   $(	Format (OUTPUT, " done ^d times,", MeterPointer!(Meter + 1))
		PrintTime (MeterPointer!Meter / MeterPointer!(Meter + 1))
		WriteS (" average,")
	     $)
	PrintPercent (Meter)
     $)
and PrintTime (t) be
     $(	let Unit, Mult = "micro", 1
	if t ge Mult * 1000 do Unit, Mult := "milli", 1000
	if t ge Mult * 1000 do Unit, t := "", t / 1000
	Writech (OUTPUT, '*s')
	PrintFraction (t, Mult)
	Format (OUTPUT, " ^sseconds", Unit)
     $)
and PrintPercent (Meter) be
     $(	Writech (OUTPUT, '*s')
	let T = MeterPointer!(Meter + 2) / 1000
	if T = 0 do T := 1
	PrintFraction (MeterPointer!Meter / T, 10)
	WriteS (OUTPUT, "%.*n")
     $)
and PrintFraction (R, Mult) be
     $(	let F = R * 201 / Mult / 2
	WriteN (OUTPUT, F / 100)
	if F < 1000 & Mult > 1 do
	     $(	Writech (OUTPUT, '.')
		Writech (OUTPUT, '0' + (F / 10 rem 10))
		if F < 100 & Mult > 10 do Writech (OUTPUT, '0' + (F rem 10))
	     $)
     $)
 



		    bcpl_plist.bcpl                 04/22/82  1624.2rew 04/22/82  1125.2       81603


//  These routines are used to implement the tree, xref, and pprep options.
//  Last modified on 06/06/74 at 18:26:07 by R F Mabee.
//  Prepared for installation on 6180 with Version 3.4 by R F Mabee
//  First installed as Version 2.7, R F Mabee

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_compiler_head"
get "bcpl_symbols"
get "bcpl_metering_head"


let SymbolName (Op) = valof
  switchon Op into
     $(	default:		CGreport (UnexpectedCase, Op, "SymbolName")
			resultis "<unknown>"

	case AND_S:	resultis "AND"
	case ASSIGN_S:	resultis "ASSIGN"
	case BE_S:	resultis "BE"
	case BIT_S:	resultis "BIT"
	case BREAK_S:	resultis "BREAK"
	case BY_S:	resultis "BY"
	case CALL_S:	resultis "CALL"
	case CASE_S:	resultis "CASE"
	case CHAR_S:	resultis "CHAR"
	case CHARCONST_S:	resultis "CHARCONST"
	case COLON_S:	resultis "COLON"
	case COMMA_S:	resultis "COMMA"
	case COND_S:	resultis "COND"
	case CONSTANT_S:	resultis "CONSTANT"
	case CONSTDEF_S:	resultis "CONSTDEF"
	case DEFAULT_S:	resultis "DEFAULT"
	case DIV_F:	resultis "DIV_F"
	case DIV_S:	resultis "DIV"
	case DO_S:	resultis "DO"
	case DOUBLE_S:	resultis "DOUBLE"
	case ENDCASE_S:	resultis "ENDCASE"
	case ENDPROG_S:	resultis "ENDPROG"
	case EQ_F:	resultis "EQ_F"
	case EQ_S:	resultis "EQ"
	case EQV_S:	resultis "EQV"
	case ERROR_S:	resultis "<error>"
	case EXTERNAL_S:	resultis "EXTERNAL"
	case FALSE_S:	resultis "FALSE"
	case FINISH_S:	resultis "FINISH"
	case FIXED_S:	resultis "FIXED"
	case FLOAT_S:	resultis "FLOAT"
	case FNAP_S:	resultis "FNAP"
	case FNDEF_S:	resultis "FNDEF"
	case FOR_S:	resultis "FOR"
	case GE_F:	resultis "GE_F"
	case GE_S:	resultis "GE"
	case GLOBAL_S:	resultis "GLOBAL"
	case GOTO_S:	resultis "GOTO"
	case GR_F:	resultis "GR_F"
	case GR_S:	resultis "GR"
	case IF_S:	resultis "IF"
	case IFNOT_S:	resultis "IFNOT"
	case IFSO_S:	resultis "IFSO"
	case INTO_S:	resultis "INTO"
	case LABDEF_S:	resultis "LABDEF"
	case LABEL_S:	resultis "LABEL"
	case LE_F:	resultis "LE_F"
	case LE_S:	resultis "LE"
	case LENGTH_S:	resultis "LENGTH"
	case LET_S:	resultis "LET"
	case LIST_S:	resultis "LIST"
	case LOCAL_S:	resultis "LOCAL"
	case LOGAND_S:	resultis "LOGAND"
	case LOGOR_S:	resultis "LOGOR"
	case LOOP_S:	resultis "LOOP"
	case LS_F:	resultis "LS_F"
	case LS_S:	resultis "LS"
	case LSHIFT_S:	resultis "LSHIFT"
	case LV_S:	resultis "LV"
	case LV_ARG_OUT:	resultis "LV_ARG_OUT"
	case LV_FNAP_RESULT:resultis "LV_FNAP_RESULT"
	case LV_GLOBAL:	resultis "LV_GLOBAL"
	case LV_LOCAL:	resultis "LV_LOCAL"
	case LV_STATIC:	resultis "LV_STATIC"
	case LV_TEMP:	resultis "LV_TEMP"
	case LVECAP_S:	resultis "LVECAP"
	case MAIN_S:	resultis "MAIN"
	case MANIFEST_S:	resultis "MANIFEST"
	case MINUS_F:	resultis "MINUS_F"
	case MINUS_S:	resultis "MINUS"
	case MULT_F:	resultis "MULT_F"
	case MULT_S:	resultis "MULT"
	case NAME_S:	resultis "NAME"
	case NE_F:	resultis "NE_F"
	case NE_S:	resultis "NE"
	case NEG_F:	resultis "NEG_F"
	case NEG_S:	resultis "NEG"
	case NEQV_S:	resultis "NEQV"
	case NIL_S:	resultis "NIL"
	case NOT_S:	resultis "NOT"
	case NUMBER_S:	resultis "NUMBER"
	case OFFSET_S:	resultis "OFFSET"
	case OR_S:	resultis "OR"
	case PLUS_F:	resultis "PLUS_F"
	case PLUS_S:	resultis "PLUS"
	case POINTER_S:	resultis "POINTER"
	case POS_F:	resultis "POS_F"
	case POS_S:	resultis "POS"
	case RBRA_S:	resultis "RBRA"
	case REGISTER_S:	resultis "REGISTER"
	case REL_S:	resultis "REL"
	case REM_S:	resultis "REM"
	case REP_S:	resultis "REP"
	case REPEAT_S:	resultis "REPEAT"
	case REPEATUNTIL_S:	resultis "REPEATUNTIL"
	case REPEATWHILE_S:	resultis "REPEATWHILE"
	case RESULTIS_S:	resultis "RESULTIS"
	case RETURN_S:	resultis "RETURN"
	case RKET_S:	resultis "RKET"
	case RSHIFT_S:	resultis "RSHIFT"
	case RTAP_S:	resultis "RTAP"
	case RTDEF_S:	resultis "RTDEF"
	case RV_S:	resultis "RV"
	case SBRA_S:	resultis "SBRA"
	case SECTBEGIN_S:	resultis "BEGIN"
	case SECTBRA_S:	resultis "SECTBRA"
	case SECTEND_S:	resultis "END"
	case SECTKET_S:	resultis "SECTKET"
	case SEMICOLON_S:	resultis "SEMICOLON"
	case SKET_S:	resultis "SKET"
	case STATIC_S:	resultis "STATIC"
	case STRING_S:	resultis "STRING"
	case STRINGCONST_S:	resultis "STRINGCONST"
	case STRUCTURE_S:	resultis "STRUCTURE"
	case SWITCHON_S:	resultis "SWITCHON"
	case TABLE_S:	resultis "TABLE"
	case TEMP_S:	resultis "TEMP"
	case TEST_S:	resultis "TEST"
	case TO_S:	resultis "TO"
	case TRUE_S:	resultis "TRUE"
	case TYPE_S:	resultis "TYPE"
	case UNLESS_S:	resultis "UNLESS"
	case UNTIL_S:	resultis "UNTIL"
	case VALDEF_S:	resultis "VALDEF"
	case VALOF_S:	resultis "VALOF"
	case VEC_S:	resultis "VEC"
	case VECAP_S:	resultis "VECAP"
	case WHILE_S:	resultis "WHILE"
     $)
and FindPrintName (x) = valof
  switchon x!0 & Right into
     $(	case NAME_S:
	case NUMBER_S:
	case CHARCONST_S:
	case STRINGCONST_S:
		resultis x!1
	default:	resultis SymbolName (x!0 & Right)
     $)

let Plist (x, n) be
     $(	for i = 0 to n do Writech (OUTPUT, '|')
	Writech (OUTPUT, '*s')
	if x = 0 do
	     $(	WriteS ("<empty>*n")
		return
	     $)
	let s, t = 1, 0
	let Op = x!0 & Right
	t := valof switchon Op into
	     $(	case NIL_S: case TRUE_S: case FALSE_S:
		case LOOP_S: case BREAK_S: case RETURN_S:
		case ENDCASE_S: case FINISH_S:
		case ERROR_S:
			resultis 0

		case NEG_S: case NOT_S: case REL_S: case LV_S:
		case RV_S: case VEC_S: case VALOF_S:
		case TABLE_S: case GOTO_S: case RESULTIS_S:
		case REPEAT_S: case DEFAULT_S: case LIST_S:
		case NEG_F: case CALL_S:
		case FIXED_S: case FLOAT_S: case DOUBLE_S:
		case POINTER_S: case STRING_S:
		case POS_S: case POS_F:
			resultis 1

		case AND_S: case ASSIGN_S: case BIT_S: case CHAR_S:
		case COLON_S: case DIV_F: case DIV_S: case EQ_F:
		case EQ_S: case EQV_S: case EXTERNAL_S: case FNAP_S:
		case GE_F: case GE_S: case GLOBAL_S: case GR_F:
		case GR_S: case IF_S: case LE_F: case LE_S:
		case LENGTH_S: case LET_S: case LOGAND_S: case LOGOR_S:
		case LS_F: case LS_S: case LSHIFT_S: case MANIFEST_S:
		case MINUS_F: case MINUS_S: case MULT_F: case MULT_S:
		case NE_F: case NE_S: case NEQV_S: case OFFSET_S:
		case PLUS_F: case PLUS_S: case REM_S: case REP_S:
		case REPEATUNTIL_S: case REPEATWHILE_S: case RSHIFT_S: case RTAP_S:
		case SEMICOLON_S: case STATIC_S: case STRUCTURE_S:
		case SWITCHON_S: case TYPE_S: case UNLESS_S: case UNTIL_S:
		case VALDEF_S: case VECAP_S: case WHILE_S:
			resultis 2

		case CASE_S: case COND_S: case TEST_S:
		case CONSTDEF_S: case FNDEF_S: case RTDEF_S:
			resultis 3

		case FOR_S:
			resultis 5

		case COMMA_S:
			s := 2
			resultis x!1 + 1

		case CONSTANT_S:
			Format (OUTPUT, "CONSTANT ^d*n", x!1)
			return

		case NUMBER_S:
		case CHARCONST_S:
		case STRINGCONST_S:
		case NAME_S:
			Format (OUTPUT, "^s ^s*n", SymbolName (Op), x!1)
			return

		default:	CGreport (UnexpectedCase, Op, "Plist")
			resultis 0
	     $)
	Format (OUTPUT, "^s*n", SymbolName (Op))
	while s le t do
	     $(	Plist (x!s, n + 1)
		s := s + 1
	     $)
     $)

let Pname (x) be
     $(	if x = 0 return
	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	Pname (x!1)
	let Chain = x!0!3
	unless Chain = 0 do
	     $(	let Last = 0		//  Cross-reference chain is created backwards, so reverse it.
		     $(	let Next = Chain!1
			Chain!1 := Last
			if Next = 0 break
			Last := Chain
			Chain := Next
		     $)	repeat

		WriteS (x!0!1)		//  Put out name of item being listed.
		Column := Length (x!0!1)
		Column := Column - Column rem 10
		     $(	Writech (OUTPUT, '*t')
			Column := Column + 10
		     $)	repeatwhile Column < 30

		let LastFile = -1
		let Number = vec 20
		     $(	let Line = Chain!0 rshift Left
			let File = Line rshift FileShift
			Line := Line & LineMask
			unless File = LastFile do
			     $(	let ID = FileNames!File
				Need (Length (ID) + 3, 90)
				WriteS (ID)
				WriteS (":*s*s")
				LastFile := File
			     $)
			ConvertNtoS (Line, Number, 10)
			Need (Length (Number) + 2, 120)
			WriteS (OUTPUT, Number)
			Chain := Chain!1
			if Chain = 0 break
			WriteS (OUTPUT, ",*s")
		     $)	repeat
		WriteS (OUTPUT, "*n*n")
	     $)
	Pname (x!2)

	if Metering do RecordUsage (PrintXref_Meter, UsageTemp)
     $)
and Need (n, Max) be
     $(	Column := Column + n
	if Column > Max do
	     $(	WriteS (OUTPUT, "*n*t*t*t")
		Column := 30 + n
	     $)
     $)

and EnterIntoCrossreference () be		//  Make list for Pname, using current named symbol.
     $(	if DictionaryEntry!3 = 0 do		//  First reference, create NAMECHAIN entry.
	     $(	let Q = lv NAMECHAIN
		     $(	let P = rv Q
			if P = 0 break
			Q := CompareStrings (DictionaryEntry!1, P!0!1) < 0 -> lv P!1, lv P!2
		     $)	repeat
		rv Q := List3 (DictionaryEntry, 0, 0)		//  Format:  NAME node, < names list, > names list.
	     $)
	DictionaryEntry!3 := List2 (LineCount lshift Left, DictionaryEntry!3)
     $)
 



		    bcpl_report.bcpl                04/22/82  1624.2rew 04/22/82  1125.2       49842


//  Error reporting routines for all phases of the BCPL compiler.
//  Last modified on 06/06/74 at 18:26:13 by R F Mabee.
//  Revisions for 6180 bootstrap installed with Version 3.4, R F Mabee.
//  First installed as Version 2.7 by R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_compiler_head"
get "bcpl_lex_codes"
get "bcpl_cae_codes"
get "bcpl_trans_codes"
get "bcpl_cg_codes"

let WriteMessage (Stream, n, a, b) be
     $(	let Fatal = true
	let s = valof switchon n into
	     $(	default:	resultis "Unknown error code"

		//  General-purpose error message.
		case UnexpectedCase:
			resultis "Internal error - case ^d not expected in ^s"

		//  Lexical analysis error messages.
		case BadCharacter:
			resultis "Illegal character ^o"

		case BadDollar:
			resultis "Illegal character after '$' ^o"

		case BadFloat:
			resultis "Illegal use of '.'"

		case BadNumber:
			resultis "Malformed number"

		case BadSystemword:
			resultis "Unknown system word ^s"

		case GetStringMissing:
			resultis "File name missing after 'get'"

		case TokenTooLong:
			Fatal := false
			resultis "String part of token exceeds implementation limit of ^d characters"

		//  Syntactic analysis error messages.
		case BlockExpected:
			resultis "Block expected"

		case ExpressionMissing:
			resultis "Expression missing"

		case IncompleteCommand:
			resultis "Incomplete command"

		case MalformedDeclaration:
			resultis "Malformed declaration"

		case MalformedTest:
			resultis "Malformed 'test' command"

		case MisplacedDeclaration:
			resultis "Misplaced declaration"

		case MissingCOLON:
			Fatal := false
			resultis "Missing colon"

		case MissingCOMMA:
			Fatal := false
			resultis "Missing comma"

		case MissingDO:
			Fatal := false
			resultis "Missing 'do'"

		case MissingINTO:
			Fatal := false
			resultis "Missing 'into'"

		case MissingRKET:
			Fatal := false
			resultis "Missing ')'"

		case MissingSECTKET:
			resultis "Closing section bracket missing"

		case MissingSKET:
			Fatal := false
			resultis "Missing ']'"

		case MissingTO:
			Fatal := false
			resultis "Missing 'to'"

		case NameExpected:
			resultis "Name expected"

		case PrematureTermination:
			resultis "Program is prematurely terminated"


		case UnrecognizedCommand:
			resultis "Unrecognized command"

		case ValdefExpected:
			resultis "'=' expected in 'for' command"

		//  Semantic translation error messages.
		case BadCall:
			resultis "Bad format in 'call' command"

		case BadDescriptors:
			resultis "Incompatible descriptor information in 'call' command."

		case BadLink:
			resultis "Unrecognized expression in external declaration (^s)"

		case Conformality:
			resultis "Conformality error - lists in assignment different lengths"

		case DupDefault:
			resultis "Two defaults in one switchon"

		case DupName:
			resultis "Duplicate name ^s"

		case FreeVar:
			resultis "Reference to a variable ^s local to another routine body"

		case LmodeRequired:
			resultis "Expression invalid for Lmode context (^s)"

		case NegVector:
			resultis "Vector length is negative"

		case NoLoop:
			resultis "Command ^s not inside a loop"

		case NoSwitch:
			resultis "Command ^s not inside a switchon"

		case NotConstant:
			resultis "Expression invalid for constant context (^s)"

		case NotInsideRtdef:
			resultis "Command ^s not inside a routine body"

		case NotName:
			resultis "Name expected in definition"

		case NoValof:
			resultis "Command ^s not inside a valof block"

		case UndefName:
			resultis "Undefined name ^s"

		case UnrecognizedExpression:
			resultis "Expression could not be recognized (^s)"

		//  Code generator error messages.
		case BadAddress:
			resultis "Compiler error: Address field too large ^o"

		case BadLabel:
			resultis "Compiler error: Internal label ^d out of range"

		case BadRegOpPair:
			resultis "Compiler error: Incompatible register/opcode pair in FormOpcode ^o/^o"

		case DupCase:
			resultis "Duplicate case constant ^d"

		case DupLabel:
			resultis "Compiler error: Internal label ^d doubly defined"

		case LinkRefersThis:
			Fatal := false
			resultis "External reference to same segment ^s"

		case OverCase:
			resultis "The number of cases in a switchon exceeds the implementation limit of ^d"

		case PhaseError:
			resultis "Compiler error: Discrepancy between passes detected in ^s"

		case UndefLab:
			resultis "Compiler error: Internal label ^d not defined"
	     $)

	Errorsw := Errorsw | Fatal

	Format (Stream, "Error ^d: ", n)
	Format (Stream, s, a, b)
	unless LineCount = 0 do Format (Stream, " in line ^d", LineCount & LineMask)
	let f = LineCount rshift FileShift
	unless f = 0 do Format (Stream, " of file ^s", FileNames!f)
	WriteS (Stream, ".*n")
     $)

let CaeReport (n, a, b) be
     $(	unless QuietSw do WriteMessage (MONITOR, n, a, b)
	if HaveListingFile do
	     $(	Writech (OUTPUT, '*n')
		WriteMessage (OUTPUT, n, a, b)
	     $)
     $)
and Transreport (n, x) be
     $(	let Id = ""
	unless x = 0 do
	     $(	Id := FindPrintName (x)
		if LineCount = 0 do LineCount := x!0 rshift Left
	     $)
	CaeReport (n, Id)
     $)
and CGreport (n, a, b) be
	CaeReport (n, a, b)
  



		    bcpl_trans0.bcpl                04/22/82  1624.2rew 04/22/82  1125.2       10557


//  The main routine for the second pass, called from the driver.
//  Last modified on 06/06/74 at 18:26:18 by R F Mabee.
//  Revisions for 6180 installed in Version 3.4, R F Mabee.
//  First installed with Version 2.7 by R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_trans_head"

let Trans (x) be
     $(	DvecP := Newvec (DvecSize)
	for i = 0 to DvecSize do DvecP!i := 0
	DvecC := DvecP

	StaticFirst, StaticList, DefList := 0, 0, 0
	StaticAllocationCounter := 0
	InsideRtdef, RtdefNesting, RtdefList := false, 0, 0
	ReturnLabel := 0
	LineCount := 0
	ValofFlag, SwitchFlag, LoopFlag := false, false, false
	BreakLabel, LoopLabel, EndcaseLabel := 0, 0, 0
	SSP := 0
	FreeLocalList, PendingTemps := 0, 0

	Transbody (x)

	LineCount := 0
	CgFinish (StaticFirst, DefList)
     $)
   



		    bcpl_trans1.bcpl                04/22/82  1624.2rew 04/22/82  1125.2       45693


//  This routine walks the command nodes of the tree.
//  Last modified on 06/06/74 at 18:26:24 by R F Mabee.
//  Installed with Version 3.4 for 6180 bootstrap by R F Mabee.
//  First installed as Version 2.7 by R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_trans_head"

let Transbody (x) be
     $(
  Top:	if x = 0 return
	let Op = x!0
	     $(	let NewLine = Op rshift Left
		if NewLine ne LineCount & (NewLine rshift FileShift) = 0 do GenerateLineNumber (NewLine)
		LineCount := NewLine
	     $)
	Op := Op & Right
	let a, b = x!1, x!2
	let s, p = nil, nil
	switchon Op into
	     $(	default:	CGreport (UnexpectedCase, Op, "Transbody")
			return

		case LET_S:
			s, p := SSP, DvecP
			Declnames (a)
			Checkdistinct ()
			Transdef (a)
			Transbody (b)
			Removenames (p)
			ResetSSP (s)
			return

		case MANIFEST_S:
		case EXTERNAL_S:
		case STATIC_S:
		case GLOBAL_S:
			p := DvecP
			until a = 0 do
			     $(	Declitem (Op, a!1, a!2)
				a := a!3
			     $)
			Checkdistinct ()
			Transbody (b)
			Removenames (p)
			return

		case LABDEF_S:
			p := DvecP
			Decllabels (b)
			Checkdistinct ()
			Transbody (a)
			Removenames (p)
			return

		case ASSIGN_S:
			Assignlist (a, b)
			return

		case SEMICOLON_S:
			Transbody (a)
			x := b			//  Same as "Transbody (b); return" but saves stack space.
			goto Top

		case RTAP_S:
			TransFnap (0, a, b)
			return

		case CALL_S:
			TransSystemCall (a)
			return

		case GOTO_S:
			p := Target (x)
			test p ne 0
			then GenerateJump (p)		//  Optimize common hop.
			or   $(	let PT, Desc = PendingTemps, vec DescSize
				CompileOperand (a, Desc)
				GenerateGoto (Desc)
				PutBackTemps (PT)
			     $)
			return

		case COLON_S:
			GenerateLabel (x!4)
			Transbody (b)
			return

		case FINISH_S:
			GenerateFinish ()
			return

		case LOOP_S:
		case BREAK_S:
		case RETURN_S:
		case ENDCASE_S:
			GenerateJump (Target (x))
			return

		case RESULTIS_S:
			test ValofFlag
			then $(	p := PendingTemps
				SetResult (a)
				GenerateJump (ValofLabel)
				PutBackTemps (p)
			     $)
			or Transreport (NoValof, x)
			return

		case IF_S:
		case UNLESS_S: $(	let Sense = (Op = IF_S)
				if Optimize do
				     $(	if IsConst (a) do
					     $(	if Evalconst (a) eqv Sense do Transbody (b)
						return
					     $)
					let M = Target (b)
					if M ne 0 do	//  b is a loop, break, return, or goto command.
					     $(	TransConditional (a, Sense, M)
						return
					     $)
				     $)
				let L = Nextparam ()
				TransConditional (a, not Sense, L)
				Transbody (b)
				GenerateLabel (L)
				return
			     $)

		case TEST_S:   $(	let c = x!3
				if Optimize then if IsConst (a) do
				     $(	Transbody (Evalconst (a) -> b, c)
					return
				     $)
				let L, M = Nextparam (), Nextparam ()
				TransConditional (a, false, L)
				Transbody (b)
				GenerateJump (M)
				GenerateLabel (L)
				Transbody (c)
				GenerateLabel (M)
				return
			     $)

		case WHILE_S:
		case UNTIL_S:
			TransLoop (b, a, Op = WHILE_S, Nextparam ())
			return

		case REPEAT_S:
			TransLoop (a, 0, 0, 0)
			return

		case REPEATWHILE_S:
		case REPEATUNTIL_S:
			TransLoop (a, b, Op = REPEATWHILE_S, 0)
			return

		case FOR_S:
			TransFor (x)
			return

		case SWITCHON_S:
			     $(	s := SSP
				let El, Dl = EndcaseLabel, DefaultLabel
				let Cf, Cl, Sf = CaseFirst, CaseList, SwitchFlag
				EndcaseLabel, DefaultLabel := Nextparam (), 0
				CaseFirst, CaseList, SwitchFlag := 0, 0, true

				let Begin = Nextparam ()
				GenerateJump (Begin)
				Transbody (x!2)
				GenerateJump (EndcaseLabel)

				GenerateLabel (Begin)
				let PT, Val = PendingTemps, vec DescSize
				CompileOperand (x!1, Val)
				GenerateSwitch (Val, CaseFirst, DefaultLabel, EndcaseLabel)
				PutBackTemps (PT)
				GenerateLabel (EndcaseLabel)

				EndcaseLabel, DefaultLabel := El, Dl
				CaseFirst, CaseList, SwitchFlag := Cf, Cl, Sf
				ResetSSP (s)
				return
			     $)

		case CASE_S:
			p := Nextparam ()
			GenerateLabel (p)
			unless SwitchFlag do Transreport (NoSwitch, x)
			     $(	let t = Newvec (5)
				t!0, t!1 := 0, p
				PartialEvalconst (x!1, lv t!2)
				test x!2 = 0
				then t!4, t!5 := t!2, t!3		//  Limit same as first value.
				or PartialEvalconst (x!2, lv t!4)
				test CaseList = 0
				then CaseFirst := t
				or CaseList!0 := t
				CaseList := t
				x := x!3
				if x = 0 break
			     $)	repeatwhile (x!0 & Right) = CASE_S	//  This is to economize on labels.
			Transbody (x)
			return

		case DEFAULT_S:
			test SwitchFlag
			then $(	unless DefaultLabel = 0 do Transreport (DupDefault, x)
				DefaultLabel := Nextparam ()
				GenerateLabel (DefaultLabel)
			     $)
			or Transreport (NoSwitch, x)
			Transbody (a)
			return
	     $)
     $)
   



		    bcpl_trans2.bcpl                04/22/82  1624.2rew 04/22/82  1125.2       53379


//  Miscellaneous short routines for Trans.
//  Last modified on 06/06/74 at 18:26:32 by R F Mabee.
//  Installed on 6180 as Version 3.4 by R F Mabee.
//  First installed as part of Version 2.7, R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_trans_head"

let Addname (x, Type, Val) be
     $(	test (x!0 & Right) = NAME_S
	then $(	let New = Newvec (DvecSize)
		New!DvecSize := DvecP
		DvecP := New
		DvecP!0, DvecP!1, DvecP!2, DvecP!3 := x, Type, Val, x!2
	     $)
	or Transreport (NotName, x)
     $)
and Checkdistinct () be
     $(	let Cp = DvecP
	until Cp = DvecC do
	     $(	let b, Dict = Cp!DvecSize, Cp!0
		until b = DvecC do
		     $(	if b!0 = Dict do
			     $(	Transreport (DupName, Dict)
				break
			     $)
			b := b!DvecSize
		     $)
		Dict!2 := Cp
		Cp := Cp!DvecSize
	     $)
	DvecC := DvecP
     $)
and Cellwithname (Name) = valof
     $(	let Dp = Name!2
	if Dp = 0 do
	     $(	Transreport (UndefName, Name)
		Addname (Name, GLOBAL_S, 0)		//  Create dummy declaration to avoid extra error messages.
		Name!2, DvecC, Dp := DvecP, DvecP, DvecP
	     $)
	resultis Dp
     $)
and Removenames (p) be
     $(	until DvecP = p do
	     $(	if DvecP!1 = LOCAL_S do DeallocateLocal (DvecP!2 & Right)		//  Reclaim space.
		DvecP!0!2 := DvecP!3
		let Old = DvecP
		DvecP := DvecP!DvecSize
		DvecC := DvecP
		Freevec (Old, DvecSize)
	     $)
     $)
and SaveEnv () = valof
     $(	let t, u = DvecP, 0
	until t = EnvBase do
	     $(	let New = Newvec (DvecSize)
		New!0, New!1, New!2, New!3 := t!0, t!1, t!2, t!3
		New!DvecSize := u
		u := New
		t := t!DvecSize
	     $)
	resultis u
     $)
and RestoreEnv (u) be
     $(	until u = 0 do
	     $(	let Old = u
		u := Old!DvecSize
		Old!DvecSize := DvecP
		DvecP := Old
		DvecP!0!2 := DvecP
	     $)
     $)

and Declnames (x) be
     $(	switchon x!0 & Right into
	     $(	default:	return		//  Error message for this case is produced later.

		case AND_S:
			Declnames (x!1)
			Declnames (x!2)
			return

		case VALDEF_S:
			WalkList (x!1, Addlocal, 0)
			return

		case FNDEF_S:
		case RTDEF_S:
			let L = Nextparam ()
			let T = x!1!2		//  Previous value of this name.
			if T ne 0 then if T!1 = EXTERNAL_S do
				DefList := List3 (DefList, T!2, L)
			Addname (x!1, RTDEF_S, L)
			return
	     $)
     $)
and Transdef (x) be
     $(
  Top:	let Op = x!0
	     $(	let NewLine = Op rshift Left
		if NewLine ne LineCount & (NewLine rshift FileShift) = 0 do GenerateLineNumber (NewLine)
		LineCount := NewLine
	     $)
	Op := Op & Right
	switchon Op into
	     $(	default:	CGreport (UnexpectedCase, Op, "Transdef")
			return

		case AND_S:
			     $(	let a, b = x!1, x!2
				if (RandomI () & 1) ne 0 do a, b := x!2, x!1	//  Make order undefined.
				Transdef (a)
				x := b		//  Same as "Transdef (b); return" but saves stack space.
				goto Top
			     $)

		case VALDEF_S:
			Assignlist (x!1, x!2)
			return

		case FNDEF_S:
		case RTDEF_S:
			test InsideRtdef
			then $(	let New = Newvec (3)
				New!0, New!1, New!2, New!3 := x, SaveEnv (), RtdefNesting, RtdefList
				RtdefList := New
			     $)
			or   $(	InsideRtdef, RtdefNesting, EnvBase := true, 1, DvecP
				TransRtdef (x)
				Removenames (EnvBase)
				until RtdefList = 0 do		//  Translate all embedded routines.
				     $(	let Old = RtdefList
					RtdefList := Old!3
					RestoreEnv (Old!1)
					RtdefNesting := Old!2 + 1
						TransRtdef (Old!0)
					Removenames (EnvBase)
					Freevec (Old, 3)
				     $)
				InsideRtdef, RtdefNesting := false, 0
			     $)
	     $)
     $)
and TransRtdef (x) be
     $(	let FunctSw, MainSw = ((x!0 & Right) = FNDEF_S), (x!5 = MAIN_S)
	and Dp = DvecP
	and M = Cellwithname (x!1)!2		//  Label of entry point.
	WalkList (x!2, AddFormalParameter, 0)
	Decllabels (x!4)
	Checkdistinct ()
	GenerateRtdefBegin (M, x!1!1, FunctSw, MainSw)
	ResetSSP (ListSize (x!2))		//  First n locals are formal parameters.
	test FunctSw
	then $(	let Desc = vec DescSize
		ReturnLabel := 0		//  RETURN not allowed in function definition.
		CompileOperand (x!3, Desc)
		GenerateRtdefEnd (Desc)
	     $)
	or   $(	ReturnLabel := Nextparam ()
		Transbody (x!3)
		GenerateLabel (ReturnLabel)
		GenerateRtdefEnd (0)
	     $)

	Removenames (Dp)
	PutBackTemps (0)
	until FreeLocalList = 0 do
	     $(	let t = FreeLocalList
		FreeLocalList := FreeLocalList!2
		Freevec (t, 2)
	     $)
	SSP := 0
     $)
and AddFormalParameter (Name, Loc) be
	unless (Name!0 & Right) = NIL_S do Addname (Name, LOCAL_S, (RtdefNesting lshift Left) | Loc)
and Decllabels (x) be
     $(	until x = 0 do
	     $(	let L = Nextparam ()
		Addname (x!1, LABEL_S, L)
		x!4 := L
		x := x!3
	     $)
     $)

and Addlocal (x) be
     $(	let p = AllocateLocal (1)
	Addname (x, LOCAL_S, p logor (RtdefNesting lshift Left))
     $)

let Declitem (Op, Name, Val) be
     $(	let n = valof switchon Op into
	     $(	case EXTERNAL_S:
			unless Val = 0 do
			     $(	if (Val!0 & Right) = STRINGCONST_S resultis Val!1
				Transreport (BadLink, Val)
			     $)
			resultis Name!1

		case MANIFEST_S:
			let v = vec 2
			PartialEvalconst (Val, v)
			Op := v!0
			resultis v!1

		case GLOBAL_S:
			resultis Evalconst (Val)

		case STATIC_S:
			let New = Newvec (4)
			New!0, New!1, New!2 := 0, StaticAllocationCounter, Name!1
			PartialEvalconst (Val, lv New!3)
			test StaticList = 0
			then StaticFirst := New
			or StaticList!0 := New
			StaticList := New
			StaticAllocationCounter := StaticAllocationCounter + 1
			resultis StaticAllocationCounter - 1

		default:	CGreport (UnexpectedCase, Op, "Declitem")
			resultis Val
	     $)
	Addname (Name, Op, n)
     $)
 



		    bcpl_trans3.bcpl                04/22/82  1624.2rew 04/22/82  1125.2       63324


//  Miscellaneous subroutines of Trans.
//  Last modified on 06/06/74 at 18:26:39 by R F Mabee.
//  Prepared for installation as Version 3.4 by R F Mabee.
//  Modified at time of 6180 bootstrap to change interface to code generator.
//  First installed as part of Version 2.7 by R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_trans_head"

let TransConditional (x, B, L) be
  switchon x!0 & Right into
     $(	case NOT_S:
		TransConditional (x!1, not B, L)
		return

	case LOGOR_S:
	case LOGAND_S:
		test B neqv ((x!0 & Right) = LOGOR_S)
		then $(	let M = Nextparam ()
			TransConditional (x!1, not B, M)
			TransConditional (x!2, B, L)
			GenerateLabel (M)
		     $)
	or   $(	TransConditional (x!1, B, L)
			TransConditional (x!2, B, L)
		     $)
		return

	case COND_S:   $(	let M, N = Nextparam (), Nextparam ()
			TransConditional (x!1, false, M)
			TransConditional (x!2, B, L)
			GenerateJump (N)
			GenerateLabel (M)
			TransConditional (x!3, B, L)
			GenerateLabel (N)
			return
		     $)

	case REL_S:
		x := x!1
	case EQ_S: case NE_S: case LS_S: case GR_S: case LE_S: case GE_S:
	case EQ_F: case NE_F: case LS_F: case GR_F: case LE_F: case GE_F:
		     $(	let PT, M = PendingTemps, 0
			let Desc1, Desc2 = vec DescSize, vec DescSize
			let LeftOperand = x!1
			while IsRelational (x!2) do
			     $(	let MiddleOperand = x!2!1
				if CountTemporaries (MiddleOperand) > 1 do MiddleOperand := MakeCopy (MiddleOperand)
				CompileOperand (LeftOperand, Desc1)
				CompileOperand (MiddleOperand, Desc2)
				if B & M = 0 do M := Nextparam ()
				GenerateDiadicConditional (ComplementRelop (x!0 & Right), (B -> M, L), Desc1, Desc2)
				x := x!2
				LeftOperand := MiddleOperand
			     $)
			CompileOperand (LeftOperand, Desc1)
			CompileOperand (x!2, Desc2)
			let Op = x!0 & Right
			unless B do Op := ComplementRelop (Op)
			GenerateDiadicConditional (Op, L, Desc1, Desc2)
			PutBackTemps (PT)
			unless M = 0 do GenerateLabel (M)
			return
		     $)

	case EQV_S:
		B, x!0 := not B, NEQV_S	//  Kludge - NEQV is easier to calculate (using exclusive-OR hardware).
	default:	let PT, Switch = PendingTemps, vec DescSize
		CompileOperand (x, Switch)
		GenerateMonadicConditional ((B -> TRUE_S, FALSE_S), L, Switch)
		PutBackTemps (PT)
     $)
and ComplementRelop (Op) = valof
  switchon Op into
     $(	case EQ_S: resultis NE_S
	case EQ_F: resultis NE_F
	case NE_S: resultis EQ_S
	case NE_F: resultis EQ_F
		case LS_S: resultis GE_S
	case LS_F: resultis GE_F
	case GE_S: resultis LS_S
	case GE_F: resultis LS_F
	case GR_S: resultis LE_S
	case GR_F: resultis LE_F
	case LE_S: resultis GR_S
	case LE_F: resultis GR_F
	default:	 CGreport (UnexpectedCase, Op, "ComplementRelop")
		 resultis EQ_S
     $)

let Target (x) = valof
     $(	let a = nil
	if x = 0 resultis 0
	switchon x!0 & Right into
	     $(	case RETURN_S:
			if ReturnLabel = 0 do Transreport (NotInsideRtdef, x)
			resultis ReturnLabel
		case ENDCASE_S:
			unless SwitchFlag do Transreport (NoSwitch, x)
			resultis EndcaseLabel
		case LOOP_S:
			a := lv LoopLabel
			goto Check
		case BREAK_S:
			a := lv BreakLabel
		Check:	unless LoopFlag do Transreport (NoLoop, x)
			if rv a = 0 do rv a := Nextparam ()
			resultis rv a
		case GOTO_S:
			a := x!1
			if (a!0 & Right) = NAME_S do
			     $(	let T = Cellwithname (a)
				if T!1 = LABEL_S resultis T!2
			     $)
		default:	resultis 0
	     $)
     $)

let ListSize (List) = valof
     $(	if List = 0 resultis 0
	unless (List!0 & Right) = COMMA_S resultis SubListSize (List)
	let N = 0
	for i = 1 to List!1 do N := N + SubListSize (List!(i + 1))
	resultis N
     $)
and SubListSize (List) = valof
     $(	unless (List!0 & Right) = REP_S resultis 1
	unless (List!2!0 & Right) = CONSTANT_S do
	     $(	let N = Evalconst (List!2)
		if N < 0 do N := 0
		List!2 := List2 (CONSTANT_S, N)
	     $)
	resultis List!2!1
     $)

and WalkList (List, F, x) be
     $(	let N, Len = 0, ListSize (List)
	if Len = 0 return
	let FlatList = Newvec (Len - 1)
	for i = 0 to Len - 1 do FlatList!i := 0
	test (List!0 & Right) = COMMA_S
	then for i = 1 to List!1 do N := N + WalkSubList (List!(i + 1), lv FlatList!N)
	or WalkSubList (List, FlatList)
	for i = 1 to Len do
	     $(	N := RandomI () rem Len repeatwhile FlatList!N = -1
		F (FlatList!N, x + N)
		FlatList!N := -1
		     $)
	Freevec (FlatList, Len - 1)
     $)
and WalkSubList (List, Flat) = valof
     $(	unless (List!0 & Right) = REP_S do
	     $(	Flat!0 := List
		resultis 1
	     $)
	let T = List!1
	if CountTemporaries (T) > 1 do T := MakeCopy (T)
	let N = List!2!1
	for i = 0 to List!2!1 - 1 do Flat!i := T
	resultis List!2!1
     $)

let Assignlist (LeftTree, RightTree) be
     $(	let Len = ListSize (RightTree)
	and OldLHS, PT = LHSpointer, PendingTemps
	test (LeftTree!0 & Right) = COMMA_S
	then $(	LHSpointer := lv LeftTree!2
		test LeftTree!1 = Len
		then WalkList (RightTree, AssignElement, 0)
		or Transreport (Conformality, RightTree)
	     $)
	or   $(	LHSpointer := lv LeftTree
		test Len = 1
		then WalkList (RightTree, AssignElement, 0)
		or Transreport (Conformality, LeftTree)
	     $)
	LHSpointer := OldLHS
	PutBackTemps (PT)
     $)
and AssignElement (RightTree, i) be
	CompileExpression (LHSpointer!i, RightTree)

let TransLoop (Body, Cond, Sense, Enter) be
     $(	let Bl, Ll, Lf = BreakLabel, LoopLabel, LoopFlag
	BreakLabel, LoopLabel, LoopFlag := 0, Enter, true
	unless Enter = 0 do GenerateJump (Enter)

	let Top = Nextparam ()
	GenerateLabel (Top)
	Transbody (Body)
	unless LoopLabel = 0 do GenerateLabel (LoopLabel)
	LoopFlag := false		//  Force any break in conditional to get error message.
	test Cond = 0
	then GenerateJump (Top)
	or TransConditional (Cond, Sense, Top)
	unless BreakLabel = 0 do GenerateLabel (BreakLabel)
	BreakLabel, LoopLabel, LoopFlag := Bl, Ll, Lf
     $)

let TransFor (x) be
     $(	let s, Dp, PT = SSP, DvecP, PendingTemps
	let Bl, Ll, Lf = BreakLabel, LoopLabel, LoopFlag
	BreakLabel, LoopLabel, LoopFlag := 0, 0, true

	let Name, Initial, Max, Step, Body = x!1, x!2, x!3, x!4, x!5
	Addlocal (Name)
	Checkdistinct ()
	CompileExpression (Name, Initial)
	unless IsConst (Max) do Max := MakeCopy (Max)
	if Step = 0 do Step := table CONSTANT_S, 1

	let L, M = Nextparam (), Nextparam ()
	GenerateJump (M)

	GenerateLabel (L)
	Transbody (Body)
	unless LoopLabel = 0 do GenerateLabel (LoopLabel)

	let T1 = list PLUS_S, Name, Step
	CompileExpression (Name, T1)

	GenerateLabel (M)
	let T2 = list (Evalconst (Step) < 0 -> GE_S, LE_S), Name, Max
	TransConditional (T2, true, L)

	unless BreakLabel = 0 do GenerateLabel (BreakLabel)
	BreakLabel, LoopLabel, LoopFlag := Bl, Ll, Lf
	Removenames (Dp)
	PutBackTemps (PT)
	ResetSSP (s)
     $)



		    bcpl_trans4.bcpl                04/22/82  1624.2rew 04/22/82  1125.2       77976


//  Expression evaluation routines.
//  Last modified on 06/06/74 at 18:26:51 by R F Mabee.
//  Prepared for installation as part of Version 3.4 by R F Mabee.
//  Greatly revised during 6180 bootstrap to simplify interface to code generator.
//  First installed as Version 2.7, by R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_trans_head"
get "bcpl_metering_head"


let CompileExpression (Result, x) be
     $(	let UsageTemp = nil
	if Metering do UsageTemp := SaveOldUsage ()
	let Op = x!0 & Right
	switchon Op into
	     $(	default:	Transreport (UnrecognizedExpression, x)
		case NIL_S:
			endcase

		case NAME_S:
		case NUMBER_S:
		case CHARCONST_S:
		case STRINGCONST_S:
		case CONSTANT_S:
		case TRUE_S:
		case FALSE_S:
		case LV_S:
		case VEC_S:
		case LIST_S:
		case TABLE_S:
		case LOCAL_S:
			Monadic (ASSIGN_S, Result, x)
			endcase

		case POS_S: case POS_F:
		case NEG_S: case NEG_F:
		case NOT_S:
			if Optimize then if IsConst (x) goto AssignConstant
			Monadic (Op, Result, x!1)
			endcase

		AssignConstant:
			Monadic (ASSIGN_S, Result, x)
			endcase


		case PLUS_S: case PLUS_F:
		case MINUS_S: case MINUS_F:
		case MULT_S: case MULT_F:
		case DIV_S: case DIV_F:
		case REM_S:
		case LOGOR_S:
		case LOGAND_S:
		case EQV_S:
		case NEQV_S:
			if Optimize then if IsConst (x) goto AssignConstant
			     $(	let Order = DecideOrder (Result, x!1, x!2)
				and Desc1, Desc2, Desc3 = vec DescSize, vec DescSize, vec DescSize
				for i = 1 to 3 do
				     $(	test (Order & $81) ne 0
					then CompileLmode (Result, Desc1)
					or test (Order & $82) ne 0
					   then CompileOperand (x!1, Desc2)
					   or CompileOperand (x!2, Desc3)
					Order := Order rshift 3
				     $)
				GenerateDiadicOperator (Op, Desc1, Desc2, Desc3)
				endcase
			     $)

		case LSHIFT_S:
		case RSHIFT_S:
		case VECAP_S:
			CompileWithOffset (Op, Result, x!1, x!2)
			endcase

		case RV_S:
			     $(	let Zero = list CONSTANT_S, 0
				CompileWithOffset (VECAP_S, Result, x!1, Zero)
				endcase
			     $)

		case REL_S:    $(	let T, F = TRUE_S, FALSE_S
				let Xprime = list COND_S, x, lv T, lv F
				CompileExpression (Result, Xprime)
				endcase
			     $)

		case COND_S:
			if Optimize then if IsConst (x!1) do
			     $(	let B = Evalconst (x!1)
				CompileExpression (Result, (B -> x!2, x!3))
				endcase
			     $)

			     $(	let L, M = Nextparam (), Nextparam ()
				GenerateResultBlock ()
				TransConditional (x!1, false, L)
				SetResult (x!2)
				GenerateJump (M)
				GenerateLabel (L)
				SetResult (x!3)
				GenerateLabel (M)
				ClaimResult (Result)
				endcase
			     $)

		case VALOF_S:
			     $(	let s = SSP
				let Rl, Rf = ValofLabel, ValofFlag
				ValofLabel, ValofFlag := Nextparam (), true
				GenerateResultBlock ()
				Transbody (x!1)
				GenerateLabel (ValofLabel)
				ClaimResult (Result)
				ValofLabel, ValofFlag := Rl, Rf
				ResetSSP (s)
				endcase
			     $)

		case FNAP_S:
			     $(	let Desc1, Desc2 = vec DescSize, vec DescSize
				test (Result!0 & Right) = NAME_S
				then $(	CompileLmode (Result, Desc1)
					TransFnap (Desc1, x!1, x!2)
				     $)
				or   $(	let T = MakeTemp ()
					CompileLmode (T, Desc1)
					TransFnap (Desc1, x!1, x!2)
					Monadic (ASSIGN_S, Result, T)
				     $)
				endcase
			     $)
	     $)
	if Metering do RecordUsage (CompileExpression_Meter, UsageTemp)
     $)
and Monadic (Op, Result, x) be
     $(	let Desc1, Desc2 = vec DescSize, vec DescSize
	and Order = ChooseOrder (CountTemporaries (Result), CountTemporaries (x))
	if Order do CompileLmode (Result, Desc1)
	CompileOperand (x, Desc2)
	unless Order do CompileLmode (Result, Desc1)
	GenerateMonadicOperator (Op, Desc1, Desc2)
     $)
and ChooseOrder (a, b) = a = b -> (RandomI () & $81) = 0, a > b
and DecideOrder (a, b, c) = valof
     $(	let Min, Max = 0, 0
	and T = list CountTemporaries (a), CountTemporaries (b), CountTemporaries (c)
	for i = 1 to 2 test ChooseOrder (T!i, T!Max) then Max := i
		or unless ChooseOrder (T!i, T!Min) do Min := i
	if Min = Max do Min := (Max + 1) rem 3
	let Middle = 3 - Min - Max
	resultis ($81 lshift (Min + 6)) | ($81 lshift (Middle + 3)) | ($81 lshift Max)
     $)

and SetResult (x) be
     $(	let Desc = vec DescSize
	CompileOperand (x, Desc)
	GenerateResultValue (Desc)
     $)
and ClaimResult (x) be
     $(	let T, Desc = MakeTemp (), vec DescSize
	CompileLmode (T, Desc)
	GenerateClaimResult (Desc)
	Monadic (ASSIGN_S, x, T)
     $)

and CompileOperand (x, Desc) be
     $(	let Op = x!0 & Right
	switchon Op into
	     $(	case NAME_S:
			let T = Cellwithname (x)
			Desc!0, Desc!1, Desc!2 := T!1, T!2, x!1
			if Desc!0 = LOCAL_S do
			     $(	unless (Desc!1 rshift Left) = RtdefNesting do Transreport (FreeVar, x)
				Desc!1 := Desc!1 & Right
			     $)
			return

		case LOCAL_S:
		case TEMP_S:
			Desc!0, Desc!1, Desc!2 := Op, x!1, 0
			return

		case NUMBER_S:
		case CHARCONST_S:
		case STRINGCONST_S:
			Desc!0, Desc!1, Desc!2 := Op, x!1, x!1
			return

		case CONSTANT_S:
			Desc!0, Desc!1, Desc!2 := CONSTANT_S, x!1, 0
			return

		case TRUE_S:
			Desc!0, Desc!1, Desc!2 := TRUE_S, true, "true"
			return

		case FALSE_S:
			Desc!0, Desc!1, Desc!2 := FALSE_S, false, "false"
			return

		case LV_S:
			CompileLmode (x!1, Desc)
			return

		case VEC_S:
			let n = Evalconst (x!1)
			if n < 0 do
			     $(	Transreport (NegVector, x!1)
				n := 0
			     $)
			let p = AllocateLocal (n + 1)
			Desc!0, Desc!1, Desc!2 := LV_LOCAL, p, "a vector"
			return

		case LIST_S:
			p := AllocateLocal (ListSize (x!1))
			WalkList (x!1, LoadListItem, p)
			Desc!0, Desc!1, Desc!2 := LV_LOCAL, p, "a list"
			return

		case TABLE_S:
			n := ListSize (x!1)
			p := TableCell
			TableCell := Newvec (n * 2)
			TableCell!0 := n
			WalkList (x!1, StoreTableItem, 0)
			Desc!0, Desc!1, Desc!2 := TABLE_S, TableCell, "a table"
			TableCell := p
			return

		default:	if Optimize then if IsConst (x) do
			     $(	Desc!0, Desc!1, Desc!2 := CONSTANT_S, Evalconst (x), 0
				return
			     $)
			let Result = MakeTemp ()
			CompileExpression (Result, x)
			CompileOperand (Result, Desc)
			return
	     $)
     $)
and LoadListItem (x, p) be
     $(	let Cell = list LOCAL_S, p
	CompileExpression (Cell, x)
     $)
and StoreTableItem (x, n) be
	PartialEvalconst (x, lv TableCell!(n * 2 + 1))

and CompileLmode (x, Desc) be
  switchon x!0 & Right into
     $(	case RV_S:
		CompileOperand (x!1, Desc)
		return

	case VECAP_S:
		let Result = MakeTemp ()
		CompileWithOffset (LVECAP_S, Result, x!1, x!2)
		CompileOperand (Result, Desc)
		return

	case NAME_S:
		let T = Cellwithname (x)
		Desc!1, Desc!2 := T!2, x!1
		Desc!0 := valof switchon T!1 into
		     $(	case GLOBAL_S:
				resultis LV_GLOBAL
			case STATIC_S:
				resultis LV_STATIC
			case LOCAL_S:
				unless (Desc!1 rshift Left) = RtdefNesting do Transreport (FreeVar, x)
				Desc!1 := Desc!1 & Right
				resultis LV_LOCAL
			default:	Transreport (LmodeRequired, x)
				resultis T!1
		     $)
		return

	case LOCAL_S:
	case TEMP_S:
		Desc!0, Desc!1, Desc!2 := ((x!0 & Right) = LOCAL_S -> LV_LOCAL, LV_TEMP), x!1, 0
		return

	default:	Transreport (LmodeRequired, x)
		CompileOperand (x, Desc)
     $)

and CompileWithOffset (Op, Result, a, b) be
     $(	let Desc1, Desc2, Desc3 = vec DescSize, vec DescSize, vec DescSize
	and Order = DecideOrder (Result, a, b)
	and Offset = 0
	for i = 1 to 3 do
	     $(	test (Order & $81) ne 0
		then CompileLmode (Result, Desc1)
		or test (Order & $82) ne 0
		   then CompileOperand (a, Desc2)
		   or CompileOffsetOperand (b, Desc3, lv Offset)
		Order := Order rshift 3
	     $)
	GenerateOffsetOperator (Op, Desc1, Desc2, Desc3, Offset)
     $)
and CompileOffsetOperand (x, Desc, LvN) be
     $(	let Op = Op
	switchon Op into
	     $(	case PLUS_S:
			if Optimize then if IsConst (x!1) do
			     $(	CompileOffsetOperand (x!2, Desc, LvN)
				rv LvN := EvaluateOperator (PLUS_S, Evalconst (x!1), rv LvN)
				endcase
			     $)

		case MINUS_S:
			if Optimize then if IsConst (x!2) do
			     $(	CompileOffsetOperand (x!1, Desc, LvN)
				rv LvN := EvaluateOperator (Op, rv LvN, Evalconst (x!2))
			endcase
			     $)

		default:	if Optimize then if IsConst (x) do
			    $(	Desc!0, Desc!1, Desc!2 := CONSTANT_S, 0, 0
				rv LvN := Evalconst (x)
				endcase
			     $)
			CompileOperand (x, Desc)
		rv LvN := 0
	     $)
     $)



		    bcpl_trans5.bcpl                04/22/82  1624.2rew 04/22/82  1125.3       58230


//  Functions to aid CompileExpression in evaluating expressions.
//  Last modified on 06/06/74 at 18:27:11 by R F Mabee.
//  First installed with Version 3.4 by R F Mabee.
//  Written in March 1973 as part of cleanup accompanying 6180 bootstrap.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_trans_head"

let CountTemporaries (x) = valof
     $(	switchon x!0 & Right into
	     $(	case NAME_S:
			resultis IsNameConst (Cellwithname (x)) -> 0, 1

		case NUMBER_S:
		case CHARCONST_S:
		case CONSTANT_S:
		case TRUE_S:
		case FALSE_S:
		case NIL_S:
			resultis 0

		case STRINGCONST_S:
		case TABLE_S:
		case VEC_S:
			resultis 1

		case POS_S: case POS_F:
		case NEG_S: case NEG_F:
		case NOT_S:
		case RV_S:
		case LV_S:
			let C = CountTemporaries (x!1)
			if C = 1 resultis 2
			resultis C

		case PLUS_S: case PLUS_F:
		case MINUS_S: case MINUS_F:
		case MULT_S: case MULT_F:
		case DIV_S: case DIV_F:
		case REM_S:
		case LOGOR_S:
		case LOGAND_S:
		case EQV_S:
		case NEQV_S:
		case LSHIFT_S:
		case RSHIFT_S:
		case VECAP_S:
			let C1, C2 = CountTemporaries (x!1), CountTemporaries (x!2)
			if C1 = 0 do
			     $(	if C2 = 0 resultis 0
				C1 := 1
			     $)
			if C1 > C2 resultis C1
			if C1 < C2 resultis C2
			resultis C1 + 1

		case FNAP_S:
		case VALOF_S:
		case COND_S:
		case REL_S:
		case LIST_S:
		default:	resultis 100		//  Don't know, guess wild.
	     $)
     $)
and IsNameConst (T) = valof
  switchon T!1 into
     $(	case CONSTANT_S: case NUMBER_S: case CHARCONST_S: case TRUE_S: case FALSE_S:
		resultis true
	default:	resultis false
     $)
let PartialEvalconst (x, v) be
     $(	let Op = x!0 & Right
	switchon Op into
	     $(	case NAME_S:
			let T = Cellwithname (x)
			unless IsNameConst (T) endcase
			v!0, v!1 := T!1, T!2
			return
		case NUMBER_S:
		case CHARCONST_S:
			v!0, v!1 := Op, x!1
			return
		case TRUE_S:
		case FALSE_S:
			v!0, v!1 := Op, Op = TRUE_S
			return
		default:
	     $)
	v!0, v!1 := CONSTANT_S, Evalconst (x)
     $)
and FinalEvalconst (Op, N) = valof
  switchon Op into
     $(	case NUMBER_S:	resultis ConvertStoN (N)
	case CHARCONST_S:	resultis FormCharconst (N)
	case TRUE_S:	resultis true
	case FALSE_S:	resultis false
	case CONSTANT_S:	resultis N
	default:		CGreport (UnexpectedCase, Op, "FinalEvalconst")
			resultis N
     $)

and Evalconst (x) = valof
     $(	let Op = x!0 & Right
	switchon Op into
	     $(	case NAME_S:
			     $(	let T = Cellwithname (x)
				unless IsNameConst (T) endcase		//  Go produce error message.
				resultis FinalEvalconst (T!1, T!2)
			     $)

		case NUMBER_S:
		case CHARCONST_S:
		case TRUE_S:
		case FALSE_S:
			resultis FinalEvalconst (Op, x!1)

		case CONSTANT_S:
			resultis x!1

		case POS_S: case POS_F:
		case NEG_S: case NEG_F:
		case NOT_S:
			resultis EvaluateOperator (Op, Evalconst (x!1))

		case PLUS_S: case PLUS_F:
		case MINUS_S: case MINUS_F:
		case MULT_S: case MULT_F:
		case DIV_S: case DIV_F:
		case REM_S:
		case LOGOR_S:
		case LOGAND_S:
		case EQV_S:
		case NEQV_S:
		case LSHIFT_S:
		case RSHIFT_S:
			resultis EvaluateOperator (Op, Evalconst (x!1), Evalconst (x!2))

		case COND_S:
			resultis Evalconst (Evalconst (x!1) -> x!2, x!3)

		case REL_S:
			x := x!1
			     $(	let A = Evalconst (x!1)
				while IsRelational (x!2) do
				     $(	let Middle = Evalconst (x!2!1)
					unless EvaluateOperator (x!0 & Right, A, Middle) resultis false
					x, A := x!2, Middle
				     $)
				resultis EvaluateOperator (x!0 & Right, A, Evalconst (x!2))
			     $)

		case VECAP_S:
			if (x!1!0 & Right) = STRINGCONST_S do
			     $(	let v = vec Vmax
				let Len = FormStringconst (x!1!1, v)
				let i = Evalconst (x!2)
				if 0 le i le Len resultis v!i
			     $)
			endcase

		default:
	     $)
//  Fall out to here if not a valid constant expression.
	Transreport (NotConstant, x)
	resultis RandomI ()
     $)

and IsRelational (x) = valof
	switchon x!0 & Right into
	     $(	case EQ_S: case EQ_F:
		case NE_S: case NE_F:
		case LS_S: case LS_F:
		case LE_S: case LE_F:
		case GR_S: case GR_F:
			resultis true

		default:	resultis false
	     $)

and EvaluateOperator (Op, a, b) = valof switchon Op into
     $(	default:		CGreport (UnexpectedCase, Op, "EvaluateOperator")
			resultis RandomI ()

	case POS_S:	resultis  + a
	case POS_F:	resultis .+ a
	case NEG_S:	resultis  - a
	case NEG_F:	resultis .- a
	case NOT_S:	resultis not a

	case PLUS_S:	resultis a  + b
	case PLUS_F:	resultis a .+ b
	case MINUS_S:	resultis a  - b
	case MINUS_F:	resultis a .- b
	case MULT_S:	resultis a  * b
	case MULT_F:	resultis a .* b
	case DIV_S:	resultis a  / b
	case DIV_F:	resultis a ./ b
	case REM_S:	resultis a rem b
	case EQV_S:	resultis a eqv b
	case NEQV_S:	resultis a neqv b
	case LOGOR_S:	resultis a logor b
	case LOGAND_S:	resultis a logand b

	case LSHIFT_S:	resultis a lshift b
	case RSHIFT_S:	resultis a rshift b
	case EQ_S:	resultis a  = b
	case EQ_F:	resultis a .= b
	case NE_S:	resultis a  ne b
	case NE_F:	resultis a .ne b
	case LS_S:	resultis a  < b
	case LS_F:	resultis a .< b
	case LE_S:	resultis a  le b
	case LE_F:	resultis a .le b
	case GR_S:	resultis a  > b
	case GR_F:	resultis a .> b
	case GE_S:	resultis a  ge b
	case GE_F:	resultis a .ge b
     $)

let IsConst (x) = valof
     $(
  Top:	switchon x!0 & Right into
	     $(	case NAME_S:
			resultis IsNameConst (Cellwithname (x))

		case NUMBER_S:
		case CHARCONST_S:
		case CONSTANT_S:
		case TRUE_S:
		case FALSE_S:
			resultis true

		case POS_S: case POS_F:
		case NEG_S: case NEG_F:
		case NOT_S:
		case REL_S:
			x := x!1
			goto Top

		case PLUS_S: case PLUS_F:
		case MINUS_S: case MINUS_F:
		case MULT_S: case MULT_F:
		case DIV_S: case DIV_F:
		case REM_S:
		case LOGOR_S:
		case LOGAND_S:
		case EQV_S:
		case NEQV_S:
		case LSHIFT_S:
		case RSHIFT_S:
		case EQ_S: case EQ_F:
		case NE_S: case NE_F:
		case LS_S: case LS_F:
		case LE_S: case LE_F:
		case GR_S: case GR_F:
		case GE_S: case GE_F:
			unless IsConst (x!1) resultis false
			x := x!2
			goto Top

		case COND_S:
			if IsConst (x!1) resultis IsConst (Evalconst (x!1) -> x!2, x!3)
			resultis false

		default:	resultis false
	     $)
     $)
  



		    bcpl_trans6.bcpl                04/22/82  1624.2rew 04/22/82  1125.3       52371


//  More subroutines to augment Transbody.
//  Last modified on 06/26/74 at 22:19:29 by R F Mabee.
//  First installed as Version 3.4 by R F Mabee.
//  Separated from bcpl_trans2 and bcpl_trans3 during 6180 conversion.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.


get "bcpl_trans_head"

let AllocateLocal (n) = valof
     $(	test n = 1
	then unless FreeLocalList = 0 do
	     $(	let t, p = FreeLocalList, FreeLocalList!1
		FreeLocalList := t!2
		Freevec (t, 2)
		resultis p
	     $)
	or unless SSP rem 2 = 0 do		//  Make multi-word blocks even addresses.
	     $(	ResetSSP (SSP + 1)		//  This is a kludge for the Multics implementation.
		DeallocateLocal (SSP - 1)
	     $)
	let p = SSP
	ResetSSP (p + n)
	resultis p
     $)
and DeallocateLocal (p) be
     $(	let New = Newvec (2)
	New!0, New!1, New!2 := 0, p, FreeLocalList
	FreeLocalList := New
     $)
and ResetSSP (p) be
     $(	let t = PendingTemps
	until t = 0 do
	     $(	if t!1 ge p do p := t!1 + 1
		t := t!2
	     $)
	if p = SSP return
	SSP := p
	GenerateSSP (SSP)
	t := lv FreeLocalList
	until rv t = 0 do		//  Dis-remember all temporaries outside new SSP.
	     $(	let u = rv t
		test u!1 ge SSP
		then $(	rv t := u!2
			Freevec (u, 2)
		     $)
		or t := lv u!2
	     $)
     $)
and MakeTemp () = valof
     $(	let Temp = AllocateLocal (1)
	let New = Newvec (2)
	New!0, New!1, New!2 := TEMP_S, Temp, PendingTemps
	PendingTemps := New
	resultis New
     $)
and MakeCopy (x) = valof
     $(	let P = MakeTemp ()
	P!0 := LOCAL_S
	CompileExpression (P, x)
	resultis P
     $)
and PutBackTemps (PT) be
	until PendingTemps = PT | PendingTemps = 0 do
	     $(	let Old = PendingTemps
		PendingTemps := PendingTemps!2
		Old!2 := FreeLocalList
		FreeLocalList := Old
	     $)

let ContainsFnap (x) = valof
  switchon x!0 & Right into
     $(	case FNAP_S: case VALOF_S: case LIST_S: case COND_S: case REL_S:
	default:	resultis true

	case POS_S: case POS_F: case NEG_S: case NEG_F: case NOT_S: case RV_S: case LV_S:
		resultis ContainsFnap (x!1)

	case PLUS_S: case PLUS_F: case MINUS_S: case MINUS_F:
		case MULT_S: case MULT_F: case DIV_S: case DIV_F:
	case REM_S: case LOGOR_S: case LOGAND_S: case EQV_S: case NEQV_S:
	case LSHIFT_S: case RSHIFT_S: case VECAP_S:
		if ContainsFnap (x!1) resultis true
		resultis ContainsFnap (x!2)

	case NAME_S: case NUMBER_S: case CHARCONST_S: case CONSTANT_S: case STRINGCONST_S:
	case NIL_S: case TRUE_S: case FALSE_S: case TABLE_S:
		resultis false
     $)

let TransFnap (ResultDesc, F, Args) be
     $(	let Nargs = ListSize (Args)
	and Ai, PT = ArgInfo, PendingTemps
	if ContainsFnap (F) do F := MakeCopy (F)
	ArgInfo := Newvec (Nargs - 1)
	WalkList (Args, PreCheckArg, 0)
	ReserveArglist (Nargs)
	let TempDesc = vec DescSize
	for i = 0 to Nargs - 1 do
	     $(	CompileOperand (ArgInfo!i, TempDesc)
		GenerateArg (i, TempDesc)
	     $)
	Freevec (ArgInfo, Nargs - 1)
	ArgInfo := Ai
	StoreAll ()
	CompileOperand (F, TempDesc)
	GenerateFnap (ResultDesc, TempDesc)
	PutBackTemps (PT)
     $)
and PreCheckArg (x, n) be
     $(	if ContainsFnap (x) do x := MakeCopy (x)
	ArgInfo!n := x
     $)

let TransSystemCall (x) be
     $(	test (x!0 & Right) = FNAP_S
	then $(	let Nargs = ListSize (x!2)
		and Ai, PT = ArgInfo, PendingTemps
		ArgInfo := Newvec (Nargs * 5)
		WalkList (x!2, StoreSystemArg, 0)
		ReserveSystemArglist (Nargs)
		for i = 0 to Nargs - 1 do
		     $(	let Info = lv ArgInfo!(i * 5)
			and Arg, Offset, Type, Length = vec DescSize, vec DescSize, vec DescSize, vec DescSize
			CompileOperand (Info!0, Arg)
			test Info!1 = 0
			then Offset := 0
			or CompileOperand (Info!1, Offset)
			CompileOperand (Info!2, Type)
			test Info!3 = 0
			then Length := 0
			or CompileOperand (Info!3, Length)
			GenerateSystemArg (i, Arg, Offset, Type, Length, Info!4)
		     $)
		Freevec (ArgInfo, Nargs * 5)
		ArgInfo := Ai
		StoreAll ()
		let TempDesc = vec DescSize
		CompileOperand (x!1, TempDesc)
		GenerateSystemCall (TempDesc)
		PutBackTemps (PT)
	     $)
	or Transreport (BadCall, x)
     $)
and StoreSystemArg (x, Ai) be
     $(	let TypeC, TypeE, LengthE, OffsetE = 1, 0, 0, 0
	let String, Double = false, false
	     $(	switchon x!0 & Right into
		     $(	default:	break
			case FIXED_S:
				TypeC := 1
				endcase
			case FLOAT_S:
				TypeC := 3
				endcase
			case DOUBLE_S: 
				Double := true
				endcase
			case POINTER_S:
				TypeC := 13
				endcase
			case TYPE_S:
				TypeE := x!2
				endcase
			case CHAR_S:
				LengthE := x!2
				TypeC := 21
				endcase
			case BIT_S:
				LengthE := x!2
				TypeC := 19
				endcase
			case OFFSET_S:
				OffsetE := x!2
				endcase
			case LENGTH_S:
				LengthE := x!2
				endcase
			case STRING_S:
				String := true
				TypeC := 21
				endcase
		     $)
		x := x!1
	     $)	repeat

	if Double test TypeE = 0 & (TypeC = 1 | TypeC = 3)
		then TypeC := TypeC + 1
		or Transreport (BadDescriptors, x)
	if TypeE = 0 do TypeE := List2 (CONSTANT_S, TypeC)
	if String & LengthE = 0 then if (x!0 & Right) = STRINGCONST_S do
		     $(	let v = vec Vmax
			RemoveEscapes (x!1, v)
			LengthE := List2 (CONSTANT_S, Length (v))
		     $)

	if ContainsFnap (x) do x := MakeCopy (x)
	if OffsetE ne 0 then if ContainsFnap (OffsetE) do OffsetE := MakeCopy (OffsetE)
	if ContainsFnap (TypeE) do TypeE := MakeCopy (TypeE)
	if LengthE ne 0 then if ContainsFnap (LengthE) do LengthE := MakeCopy (LengthE)
	let Info = lv ArgInfo!(Ai * 5)
	Info!0, Info!1, Info!2, Info!3, Info!4 := x, OffsetE, TypeE, LengthE, String
     $)
 



		    bcpl_utility.bcpl               04/22/82  1624.2rew 04/22/82  1125.3       72576


//  Simple routines used throughout the compiler.
//  Last modified on 08/06/74 at 17:34:26 by R F Mabee.
//  Prepared for installation as Version 3.4 after 6180 bootstrap, R F Mabee.
//  First installed as Version 2.7 by R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "head"
get "bcpl_compiler_head"
get "bcpl_metering_head"

external
     $(	TranslatorInfo = "translator_info_$get_source_info"
			//  call translator_info_$get_source_info (pointer, return dir name, return entry name,
			//					return 52-bit DTM, return UID, return code)
	DateTime = "date_time_"	//  call date_time_ (52-bit time, return 24-character date-time string)
	MaxSegSize = "sys_info$max_seg_size"	//  dcl sys_info$max_seg_size external static fixed binary
     $)
global
     $(	TimeNotAccountedFor	: 158		//  Metering temporaries.
	TimingFudgeFactor	: 159

	FreeareaP		: 160
	FreeareaT		: 161
	FreeList		: 162
	FreeListArray	: 163
	TempsegID		: 164
	ParamNumber	: 165
	GetP		: 166
     $)
static
     $(	OverflowCount = 0  $)

let Newvec (n) = valof
     $(	if n < 0 do n := 0
	test n < 20
	then $(	let p = FreeListArray!n
		unless p = 0 do
		     $(	FreeListArray!n := p!0
			resultis p
		     $)
	     $)
	or   $(	let q = lv FreeList
		     $(	let p = rv q
			if p = 0 break
			if p!1 = n do
			     $(	rv q := p!0
				resultis p
			     $)
			q := lv p!0
		     $)	repeat
	     $)

	let p = FreeareaP
	FreeareaP := FreeareaP + n + 1
	if FreeareaP < FreeareaT resultis p
	Errcode := 0
	unless TempsegID = 0 do Complain ("Out of space in Newvec.")
	OverflowCount := OverflowCount + 1
	TempsegID := OverflowCount
	p := MakeTempSeg (TempsegID, "Newvec")
	FreeareaP, FreeareaT := p + n + 1, p + rv MaxSegSize
	resultis p
     $)
and List1 (a) = valof
     $(	let p = FreeareaP
	FreeareaP := FreeareaP + 1
	if FreeareaP > FreeareaT do p := Newvec (0)
	p!0 := a
	resultis p
     $)
and List2 (a, b) = valof
     $(	let p = FreeareaP
	FreeareaP := FreeareaP + 2
	if FreeareaP > FreeareaT do p := Newvec (1)
	p!0, p!1 := a, b
	resultis p
     $)
and List3 (a, b, c) = valof
     $(	let p = FreeareaP
	FreeareaP := FreeareaP + 3
	if FreeareaP > FreeareaT do p := Newvec (2)
	p!0, p!1, p!2 := a, b, c
	resultis p
     $)
and List4 (a, b, c, d) = valof
     $(	let p = FreeareaP
	FreeareaP := FreeareaP + 4
	if FreeareaP > FreeareaT do p := Newvec (3)
	p!0, p!1, p!2, p!3 := a, b, c, d
	resultis p
     $)
and List5 (a, b, c, d, e) = valof
     $(	let p = FreeareaP
	FreeareaP := FreeareaP + 5
	if FreeareaP > FreeareaT do p := Newvec (4)
	p!0, p!1, p!2, p!3, p!4 := a, b, c, d, e
	resultis p
     $)
and List6 (a, b, c, d, e, f) = valof
     $(	let p = FreeareaP
	FreeareaP := FreeareaP + 6
	if FreeareaP > FreeareaT do p := Newvec (5)
	p!0, p!1, p!2, p!3, p!4, p!5 := a, b, c, d, e, f
	resultis p
     $)
and Freevec (p, n) be
     $(	test n < 20
	then $(	p!0 := FreeListArray!n
		FreeListArray!n := p
	     $)
	or   $(	p!0, p!1 := FreeList, n
		FreeList := p
	     $)
     $)
and StoreString (s) = valof		//  Make safe-stored copy of string s in free storage.
     $(	let l = LengthInWords (s)
	let x = Newvec (l - 1)
	Move (x, s, l)
	resultis x
     $)

let MakeTimeString (t) = valof	//  Convert double-word time to string and allocate it.
     $(	let v, w = vec 24, vec 24
	call DateTime (t fixed double, w char 24)
	MakeBcplString (w, 24, v)
	resultis StoreString (v)
     $)


let Nextparam () = valof
     $(	ParamNumber := ParamNumber + 1
	resultis ParamNumber
     $)

let GetStream (Arg, ParentStream) be		//  Open new stream for input.
     $(	let Name = vec Vmax
	RemoveEscapes (Arg, Name)
	FileNames!FileCount := StoreString (Name)
	Concatenate (Name, Vmax, Name, ".bcpl")
	INPUT := ParentStream = 0 -> Open (PathName + Read + MultiSegmentFile, Name),
				Open (SearchName + Read + MultiSegmentFile, Name, ParentStream)
	unless Errcode = 0 do Complain (Name)

//  Acquire and save some information about the source file needed for the symbol table.
	let Dir, Ent = vec 50, vec 10
	and Path, w = vec 50, vec 10
	let Info = lv FilesInfo!(FileCount * 4)
	call TranslatorInfo (ITS (StreamPointer (INPUT), w) pointer, Dir char 168, Ent char 32, lv Info!2 fixed double,
							lv Info!1 bit 36, lv Errcode)
	unless Errcode = 0 do Complain (Name)
	Info!0 := StoreString (JoinPathname (Dir, Ent, Path))

	LineCount := FileCount lshift FileShift		//  Reset counter to agree with new stream.
     $)

let PushInput (NewName) be		//  Open new stream, saving current stream and line count.
     $(	FileCount := FileCount + 1
	if FileCount ge 32 do Complain ("The number of head files has exceeded the implementation limit of 32.")
	let x = Newvec (2)
	x!0, x!1, x!2 := GetP, INPUT, LineCount
	GetP := x
	INPUT := 0		//  Policy: INPUT should not be a duplicate or closed stream.
	GetStream (NewName, GetP!1)
     $)
and PopInput () be			//  Revert to previous stream.
     $(	Close (INPUT)
	INPUT, LineCount := GetP!1, GetP!2
	let x = GetP
	GetP := GetP!0
	Freevec (x, 2)
     $)

let SaveOldUsage () = valof		//  Half of the metering provision.
     $(	let T = GetCpuUsage ()
	let R = TimeNotAccountedFor
	TimeNotAccountedFor := T
	resultis R - T
     $)
and RecordUsage (MeterSlot, OldT) be	//  Other half, called at end of interval to be metered.
     $(	let T = GetCpuUsage ()
	MeterData!MeterSlot := MeterData!MeterSlot + (T - TimeNotAccountedFor - TimingFudgeFactor)
	MeterData!(MeterSlot + 1) := MeterData!(MeterSlot + 1) + 1
	TimeNotAccountedFor := T + OldT + TimingFudgeFactor
     $)

let FormCharconst (s) = valof
     $(	let R, v, w = 0, vec Vmax, vec Vmax
	Unpackstring (RemoveEscapes (s, v), w)
	for i = 1 to w!0 do R := R lshift ByteSize | w!i
	resultis R
     $)
and FormStringconst (s, Space) = valof		//  Returns length in words (minus one).
     $(	let v, w = vec Vmax, vec Vmax + 4	//  Form a BCPL-format string explicitly -
	Unpackstring (RemoveEscapes (s, v), w)	//  this is where the string format is defined.
	let Len, Nwords = w!0, 0
	w!(Len + 1), w!(Len + 2), w!(Len + 3) := 0, 0, 0
	test Machine = 6180
	then $(	Space!0 := Len lshift 18 | w!1 lshift 9 | w!2
		Nwords := 1
		for i = 3 to Len by 4 do
		     $(	Space!Nwords := w!i lshift 27 | w!(i + 1) lshift 18 | w!(i + 2) lshift 9 | w!(i + 3)
			Nwords := Nwords + 1
		     $)
	     $)
	or for i = 0 to Len by 4 do
	     $(	Space!Nwords := w!i lshift 27 | w!(i + 1) lshift 18 | w!(i + 2) lshift 9 | w!(i + 3)
		Nwords := Nwords + 1
	     $)
	resultis Nwords - 1
     $)

let UtilitiesInit (v, Len, StartingTime) be
     $(	TempsegID, FreeList := 0, 0
	FreeListArray := v
	for i = 0 to 20 do FreeListArray!i := 0
	FreeareaP, FreeareaT := v + 21, v + Len

	ParamNumber := 0

	FileNames, FileCount, FilesInfo := Newvec (32), 0, Newvec (32 * 4)
	FilesInfo := (FilesInfo + 1) & Even		//  Even alignment required to hold clock values.
	GetP, INPUT := 0, 0

	if Metering do
	     $(	MeterData := Newvec (Meters_Length)
		for i = 0 to Meters_Length do MeterData!i := 0
		TimeNotAccountedFor, TimingFudgeFactor := StartingTime, 0
		let t = vec 10		//  Calculate time spent to read clock.
		RecordUsage (MeteringOverhead_Meter, SaveOldUsage ())
		MeterData!MeteringOverhead_Meter := 0		//  First time doesn't count.
		for i = 1 to 10 do t!i := SaveOldUsage ()
		for i = 10 to 1 by -1 do RecordUsage (MeteringOverhead_Meter, t!i)
		TimingFudgeFactor := MeterData!MeteringOverhead_Meter / 19
	     $)
     $)
and Cleanup () be			//  Things that get done on normal or abnormal termination.
     $(	until GetP = 0 do
	     $(	Close (GetP!1)
		GetP := GetP!0
	     $)
	unless TempsegID = 0 do
	     $(	DeleteTempSeg (TempsegID, "Newvec")
		TempsegID := 0
	     $)
	unless INPUT = 0 do
	     $(	Close (INPUT)
		INPUT := 0
	     $)
     $)



		    bcpl_version.bcpl               04/22/82  1624.2rew 04/22/82  1125.3       17055


//  ******************************************************
//  *                                                    *
//  *                                                    *
//  * Copyright (c) 1972 by Massachusetts Institute of   *
//  * Technology and Honeywell Information Systems, Inc. *
//  *                                                    *
//  *                                                    *
//  ******************************************************

//  This short segment determines the compiler version.
//  Version 3.5 - Multics save sets stack_frame.next_sp, March 1982.
//  Version 3.4 was reinstalled in August 1974 for comment changes in each module, R F Mabee.
//		Also fixed minor errors (mistypings) in CG.
//  Version 3.4 - installed on 6180 system in August 1973 by R F Mabee.
//  Version 3.3 - first version to run on 6180 system, May 1973.  Never installed.
//  Version 3.2 - expression evaluator improved, 6180 string format changes. April 1973.  Never installed.
//  Version 3.1 - new standard for object segment format, February 1973.  Never installed.
//  Version 3.0 - conversion for Multics on 6180 system, January 1973.  Never installed.
//  Version 2.8 - ring number change to driver, February 1972, R F Mabee.
//  Version 2.7 - first installed version, September 1971, R F Mabee.

//  Copyright (c) 1974 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc.

//  General permission is granted to copy and use this program, but not to sell it, provided that the above
//  copyright statement is given.  Contact Information Processing Services, MIT, for further information.
//  Please contact R F Mabee at MIT for information on this program and versions for other machines.

get "bcpl_compiler_head"

let GetVersion () be
     $(	CompilerVersionString := "BCPL version 3.5, March 1982"
	CompilerVersionNumber := 3
     $)


		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved