



		    bcpl_arithmetic_.bcpl           04/22/82  1623.2rew 04/22/82  1125.0       40572



//  Functions to perform mathematical operations not provided by the language.
//  Last modified on 06/03/74 at 12:02:56 by R F Mabee.
//  Reinstalled with no material change in June 1974 by R F Mabee.
//  This module first installed on 6180 Multics in June 1973 by R F Mabee.
//  Formed from bcpl_lib_, first installed on 645 Multics in September 1971 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"

manifest
     $(	LogEofTwo = 0.6931471806  $)

let MaxI (a, b) = a < b -> b, a
and MinI (a, b) = a < b -> a, b
and MaxR (a, b) = a .< b -> b, a
and MinR (a, b) = a .< b -> a, b
and AbsI (a) = a < 0 -> -a, a
and AbsR (a) = a .< 0.0 -> .-a, a

let RandomI () = valof		//  Return random positive integer. Borrowed from Roger Schell's version.
     $(	static  $(  Seed = 0  $)
	if Seed = 0 do				//  Get unique initial value.
	     $(	let v = vec 2
		RawClockTime (v)
		Seed := v!1			//  Time in microseconds up to about 20 hours.
	     $)
	Seed := Seed neqv (Seed rshift 11)
	Seed := Seed neqv (Seed lshift 25)
	resultis Seed rshift 1			//  Make sure result is positive.
     $)
and RandomR () = ItoR (RandomI ()) ./ ItoR (true rshift 1)	//  Return random floating-point number between 0 and 1.

let SquareRoot (x) = valof		//  Return square root of a floating-point number.
     $(	let p = x / 2 & (true lshift 36 - 8) | (1 lshift 36 - 8 - 2)	//  Let x = m * 2**n where .5 <_ m < 1.
	unless (x & (1 lshift 36 - 8)) = 0 do p := p .* 1.414213557		//  Now p**2 = 2**n / 2.
	let m = x & (true rshift 8 + 1)
	let y = p .* (m .* 0.586 .+ 0.42) .* 2.0	//  Interpolate square root of m.  y is first estimate of result.
	for i = 0 to 2 do y := (y .+ x ./ y) .* 0.5	//  Improve estimate by Newton-Raphson approximation.
	resultis y
     $)
and Exponential (x) = valof		//  Return e ** x (x is a floating-point number).
     $(	manifest
	     $(	A = 87.4175034
		B = .- 617.972360
		C = 0.0346573560
		D = 9.95459586
	     $)
	test x .ge 0.0
	then test x .< 1.0E-8
	     then resultis 1.0		//  This close to zero result is always 1.0.
	     or if x .> 88.028 resultis 0.17014118E39	//  Too big, return largest possible number.
	or test x .> .- 1.0E-8
	   then resultis 1.0		//  Close to zero, result is always 1.0.
	   or if x .< .- 88.028 resultis 0.0	//  Too small, return smallest possible number (zero).

	x := x .* (1.0 ./ LogEofTwo)		//  x is now log base two of desired result.
	let n = RtoI (x)
	let r = x .- ItoR (n)		//  Result is 2**r * 2**n, where 0 <_ r < 1.
	let y = 1.0 .+ r .* 2.0 ./ (D .- r .+ C .* r .* r .+ B ./ (r .* r .+ A))	//  Polynomial interpolation.
	resultis y + (n lshift 36 - 8)		//  Add n to binary exponent.
     $)
and Logarithm (x) = valof		//  Return natural logarithm of floating-point number x.
     $(	manifest
	     $(	C1 = 0.10764273
		C2 = 1.21873057
		C3 = .- 1.091870621
		C4 = .- 1.39755978
		B1 = 1.0 ./ 128.0
		B2 = .- 0.5 .- 3.0 ./ 262144.0
		B3 = 1.414213557 ./ 2.0
	     $)
	let z = x .- 1.0
	if .- B1 .< z .< B1 resultis z .+ B2 .* z .* z .+ z .* z .* z .* z ./ 3.0	//  For x near one use polynomial.
	let p = ItoR (((x rshift 36 - 8) neqv (1 lshift 8 - 1)) - (1 lshift 8 - 1))
	p := (p .- 0.5) .* LogEofTwo		//  Logarithm of exponent.
	let m = x & (true rshift 8 + 1)	//  Fractional part.
	z := (m .- B3) ./ (m .+ B3)
	resultis (p .+ z .* (C1 .* z .* z .+ C2 .+ C3 ./ (z .* z .+ C4)))
     $)

let IpowerI (Integer, Exp) = valof			//  Return Integer ** Exp (both integers).
     $(	let Result = 1
	if Exp < 0 resultis 0			//  Get rid of this case right away.
	until Exp = 0 do
	     $(	unless (Exp & 1) = 0 do Result := Result * Integer
		Integer := Integer * Integer
		Exp := Exp rshift 1
	     $)
	resultis Result
     $)
and RpowerI (Real, Exp) = valof			//  Return Real ** Exp (Exp integer).
     $(	let Result = 1.0
	if Exp < 0 do Real, Exp := 1.0 ./ Real, - Exp
	until Exp = 0 do
	     $(	unless (Exp & 1) = 0 do Result := Result .* Real
		Real := Real .* Real
		Exp := Exp rshift 1
	     $)
	resultis Result
     $)
and RpowerR (Real, Exp) = valof			//  Return Real ** Exp (both reals).
     $(	let x = Logarithm (Real)
	resultis Exponential (x .* Exp)
     $)




		    bcpl_command_lib_.bcpl          04/22/82  1623.2rew 04/22/82  1125.2       95508



//  Interface to Multics command level features.
//  Last modified on 06/03/74 at 12:02:01 by R F Mabee.
//  Reinstalled with no material change in June 1974, R F Mabee.
//  Modifications for 6180 conversion installed in May 1973 by R F Mabee.
//  First installed in September 1971 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"

external
     $(	ComErr = "com_err_"			//  call com_err_ (error code, command name, comment, arg1, arg2)
	ActFncErr = "active_fnc_err_"		//  call active_fnc_err_ (error code, command name, comment)

	ErrTableNoArg = "error_table_$noarg"	//  dcl error_table_$noarg bit 36 external static
	ErrTableBadOpt = "error_table_$badopt"	//  dcl error_table_$badopt bit 36 external static
     $)
global
     $(	Frame : 0; ConditionFlag : 16
	ArgITS : 26			//  ITS pointer to Multics argument list is always stored in 26 and 27.
	ConditionChain : 30; ConditionMask : 31

	MyConditionList : 41
     $)

let Pl1NumbArgs () = rv BCPLaddr (lv ArgITS) rshift 19	//  Return number of arguments passed by PL/I caller.
and Pl1ArgPtr (n) = BCPLaddr (BCPLaddr (lv ArgITS) + n * 2) //  Return pointer to argument passed by PL/I caller.
and Pl1Descriptor (n) = valof				//  Return descriptor image provided by PL/I caller.
     $(	let Ap = BCPLaddr (lv ArgITS)
	let t = Ap!1 rshift 18
	if t = 0 resultis 0
	if (Ap!0 & Right) = 8 do t := t + 2
	let D = rv BCPLaddr (Ap + t + n * 2)
	if D < 0 resultis D		//  Done if was new format.
//  Map old format descriptor into the new format.
	let Type, Dims = D rshift 21, 0
	let NewType = valof switchon Type into
	     $(	case 1 to 16:	resultis Type
		case 17 to 32:	Dims := 1		//  Array, guess at order.
				resultis Type - 16
		case 523:		Dims := 1
		case 514:		resultis 17	//  Structure.
		case 524:		Dims := 1
		case 518:		resultis 18	//  Area.
		case 525:		Dims := 1
		case 519:		resultis 19	//  Bit string.
		case 527:		Dims := 1
		case 521:		resultis 20	//  Varying bit string.
		case 526:		Dims := 1
		case 520:		resultis 21	//  Character string.
		case 528:		Dims := 1
		case 522:		resultis 22	//  Varying character string.
		default:		resultis 0
	     $)
	resultis 1 lshift 35 | NewType lshift 29 | Dims lshift 24 | D & Right
     $)

let Pl1ArgString (n, Space, MaxLen) = valof		//  Make copy of n'th command arg in BCPL string form.
		//  Will work for other PL/I to BCPL calls passing strings, but will not strip trailing blanks.
     $(	if NumbArgs () < 3 do MaxLen := 511
	let P = Pl1ArgPtr (n)		//  Contains bit offset also.
	and D = Pl1Descriptor (n) & $877777777
	if D > MaxLen do D := MaxLen
	MoveBits (Space, CountSize, P, 0, D * ByteSize)
	resultis SetLength (Space, D)			//  Return ptr to newly built BCPL string.
     $)
let Pl1ReturnString (BcplString) be			//  Return a string value. For active function commands.
     $(	let n = Pl1NumbArgs ()			//  Number of args.
	if n = 0 goto Err
	let q = Pl1ArgPtr (n)			//  q -> varying string.
	let d = Pl1Descriptor (n)			//  Descriptor.
	unless (d rshift 29) = 64 + 22 goto Err		//  Not a varying character string!
	d := d & $877777777
	let l = Length (BcplString)
	if l > d do l := d
	MakePl1String (BcplString, q, d)		//  Make aligned padded string like non-varying.
	q!-1 := l					//  Set character count field of varying string.
	return
   Err:	let v, w = vec 20, vec 20
	MakePl1String (ProgramID, v, 32)		//  Align args to ActFncErr. Coding around a Multics bug.
	MakePl1String (BcplString, w, 80)
	call ActFncErr (ErrTableNoArg, v char 32, w char 80)	//  Puts out standard error messages (two of them).
     $)

let SetupConditionList () be		//  Initialize stack header for condition mechanism.
     $(	if (ConditionFlag & $8100) = 0 do		//  Set to zero when frame is created. signal_ uses this flag
	     $(	ConditionChain := 0		//  to avoid trying to follow an uninitialized chain.
		ConditionMask := 0
		MyConditionList := 0
		ConditionFlag := ConditionFlag | $8100
	     $)
     $)
and SetHandler (Name, Routine, Space) be	//  Establish handler for a PL/I condition.
     $(	SetupConditionList ()
	MakePl1String (Name, Space + 8, 32)
	ITS (Space + 8, Space)
	ITS (MainCondition, Space + 2)
	Space!4 := Length (Name)
	Space!5 := ConditionChain
	Space!6 := Routine
	Space!7 := MyConditionList
	ConditionChain, MyConditionList := (Space - lv Frame) lshift Left, Space
     $)
and RevertHandler (Name) be		//  Remove handler for a PL/I condition.
     $(	SetupConditionList ()
	let Block = FindConditionBlock (Name)
	unless Block = 0 test Block = MyConditionList
	then ConditionChain, MyConditionList := Block!5, Block!7
	or   $(	let t = MyConditionList
		until t = 0 do
		     $(	if t!7 = Block break
			t := t!7
		     $)
		unless t = 0 do t!5, t!7 := Block!5, Block!7
	     $)
	if ConditionChain = 0 do ConditionFlag := ConditionFlag & not $8100	//  Reset flag if no handler info.
     $)
and MainCondition () be main		//  PL/I-callable routine to be invoked for any condition.
     $(	let Name = vec 32 / 4
	let Ap = BCPLaddr (lv ArgITS)
	let Nargs = Ap!0 rshift 19
	let Sp = BCPLaddr (Ap + Nargs * 2 + 2)
	Pl1ArgString (Nargs = 1 -> 1, 2, Name, 32)
	for i = 32 to 399 do (lv Frame)!i := Sp!i	//  Retrieve old global values.
	let Block = FindConditionBlock (Name)
	if Block = 0 do Block := FindConditionBlock ("unclaimed_signal")
	unless Block = 0 do (Block!6) (Name)
     $)
and FindConditionBlock (Name) = valof		//  Get the condition block for a particular condition.
     $(	let v = vec 32 / 4
	MakePl1String (Name, v, 32)
	let t = MyConditionList
	until t = 0 do
	     $(	for i = 0 to 32 / 4 - 1 unless v!i = t!(i + 8) goto NoMatch
		resultis t
	NoMatch:
		t := t!7
	     $)
	resultis 0
     $)

let Complain (a, b, c, d, e, f) be		//  Produce standard Multics error message and abort command.
      $(	let n = NumbArgs ()
	for i = n + 1 to 6 do (lv a)!(i - 1) := ""		//  Fill out arglist.
	call ComErr (lv Errcode bit 36, ProgramID string, a string, b string, c string, d string, e string, f string)
	SetupConditionList ()
	let Block = nil		//  Invoke cleanup handler for this command if there is one.
	Block := FindConditionBlock ("cleanup")
	unless Block = 0 do (Block!6) ()
	finish
     $)

//  Subroutine to standardize command argument processing; can be used on any option list because
//  GetNextArg is called for each option processed.  See GetNextCommandArg.

//  Caller prepares three lists of length ListSize:
//	NamesList is a list of options as BCPL strings.  Omit '-' and 'no_' prefixes.
//	FlagsList is a list of flag words for option in corresponding position in above list.  Flags:
//		OptNegatable	Option can be specified with 'no_' or '^' prefix to complement meaning.
//		OptNegate		Complement sense of resulting boolean value.
//		OptGetNext	Next option is a value that this one uses.
//		OptConvert	Convert string value to number value (implies OptGetNext).
//		OptCallOut	Corresponding element of PointersList is a subroutine to be called to process value.
//	PointersList elements are pointers to cells where value of option is to be stored, unless OptCallOut flag is set.

//  PutName is called to process any argument that isn't an option (doesn't start with '-').
//  To treat such arguments as options, supply PutName equal to zero.
//  All errors are reported immediately using Complain, which aborts the program.

let OptionParse (GetNextArg, ListSize, NamesList, PointersList, FlagsList, PutName) be
     $(	let Arg, Arg2 = vec 128, vec 128
	while GetNextArg (Arg) do
	     $(	let i, B, w = 1, true, nil
		test Subch (Arg, 1) = '-'
		then i := i + 1		//  Skip over hyphen in option.
		or unless PutName = 0 do	//  If names are allowed, this is a name.
		     $(	PutName (Arg)
			loop
		     $)
	Search:	w := i = 1 -> Arg, Substr (Arg2, Arg, i)	//  w is rest-of-string after prefix already parsed.

		let j = 0
		     $(	if -1 le CompareStrings (w, NamesList!j) le 1 goto Match	//  Equal or case-bit different.
			j := j + 1
		     $)	repeatwhile j < ListSize

		//  Failed on search - see if there is a way to fix it up.
		switchon Subch (Arg, i) into		//  Dispatch on first character.
		     $(	case '^':	B := not B	//  Initial not sign means complement option.
				i := i + 1
				goto Search

			case 'n': case 'N':
				let c = Subch (Arg, i + 1)
				unless c = 'o' | c = 'O' endcase
				B := not B	//  Initial 'no' also means complement.
				i := i + 2
				if Subch (Arg, i) = '_' do i := i + 1	//  Also allow 'no_'.
				goto Search

			case 'o': case 'O':
				let c, d = Subch (Arg, i + 1), Subch (Arg, i + 2)
				unless c = 'l' | c = 'L' endcase
				unless d = 'd' | d = 'D' endcase
				B := not B	//  Initial 'old' also means complement.
				Concatenate (Arg, 511, "new", Substr (Arg2, Arg, i + 3))
				i := 1		//  Replace 'old' with 'new' and try again.
				goto Search

			default:	endcase
		     $)
		//  Can't figure it out, complain.
		Errcode := rv ErrTableBadOpt
		Complain (Arg)

	Match:	let T, P = FlagsList!j, PointersList!j
		if (T & OptNegatable) = 0 & not B do		//  Weren't supposed to have 'no' prefix.
		     $(	Errcode := rv ErrTableBadOpt
			Complain (Arg)
		     $)
		if (T & OptNegate) ne 0 do B := not B
		if (T & (OptGetNext | OptConvert)) ne 0 do	//  Need next argument.
		     $(	unless GetNextArg (Arg2) do
			     $(	Errcode := rv ErrTableNoArg
				Complain (Arg)
			     $)
			if (T & OptConvert) ne 0 do		//  Want only number.
			     $(	B := ConvertStoN (Arg2, 10)
				unless Errcode = 0 do Complain (Arg2)
			     $)
		     $)
		if (T & OptCallOut) ne 0 do
		     $(	P (Arg2, B, Arg, j)	//  Pass whatever might come in handy.
			loop
		     $)
		rv P := B
	     $)
     $)

and GetNextCommandArg (Arg) = valof		//  This routine is meant for ordinary use as GetNextArg in OptionParse.
     $(	if ArgIndex > Pl1NumbArgs () resultis false
	Pl1ArgString (ArgIndex, Arg, 511)
	ArgIndex := ArgIndex + 1
	resultis true
     $)

and ConcatenateArgs (First, Space, MaxLen) = valof	//  Make one string out of all command args from First on.
     $(	let Nargs = Pl1NumbArgs ()
	let Arg = vec 128
	test Nargs < First
	then SetLength (Space, 0)
	or   $(	Pl1ArgString (First, Space, MaxLen)
		for i = First + 1 to Nargs do Concatenate (Space, MaxLen, Space, " ", Pl1ArgString (i, Arg, 511))
	     $)
	resultis Space
     $)




		    bcpl_conversions_.bcpl          04/22/82  1623.2rew 04/22/82  1125.2      130779



//  Functions to convert values from one representation to another.
//  Last modified on 06/10/74 at 01:14:41 by R F Mabee.
//  Reinstalled with no material change in June 1974 by R F Mabee.
//  This module first installed on 6180 Multics in June 1973 by R F Mabee.
//  Formed from bcpl_lib_ and bcpl_io_, first installed on 645 Multics in September 1971 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"

external
     $(	SetTimeZone = "set_time_zone"		//  Meant to be used from command level.

	SysInfoTimeZone = "sys_info$time_zone"		//  Name of current zone.
	SysInfoTimeCorrectionConstant = "sys_info$time_correction_constant"
						//  Zone offset in microseconds.
	ErrTableBadString = "error_table_$bad_conversion"
     $)

let StoreN (N, w, Base, Digits) = valof
     $(	let i, j, v = 0, 0, vec 100
//  Generate digits in reverse order.
	     $(	i := i + 1
		let a = N rshift 1				//  Simulate unsigned arithmetic.
		let b = N - a - 1				//  N = a + b + 1.
		let T = a rem Base + b rem Base + 1 rem Base
		v!i := T rem Base				//  Unsigned remainder: N rem Base.
		N := a / Base + b / Base + 1 / Base + T / Base	//  Unsigned quotient: N / Base.
	     $)	repeatuntil N = 0 & i ge Digits
//  Reverse digits and put into result vector.
	     $(	j := j + 1
		w!j := (v!i > 9 -> 'A' - 10, '0') + v!i		//  Form printable digit.
		i := i - 1
	     $)	repeatuntil i = 0
	resultis j
     $)
and ConvertNtoS (N, Space, Base, Digits) = valof		//  Convert a number to a decimal string representation.
     $(	let j, w = 0, vec 100
	let Nargs = NumbArgs ()
	if Nargs < 4 do
	     $(	Digits := 1
		if Nargs < 3 do Base := -10
	     $)
	if Base < 0 do		//  Negative Base means N is signed.
	     $(	Base := - Base
		if N < 0 do N, w!1, j := - N, '-', 1
	     $)
	j := j + StoreN (N, lv w!j, Base, Digits)
	w!0 := j
	Packstring (w, Space)
	resultis Space
     $)
and ConvertFtoS (F, Space, Digits) = valof		//  Convert a floating-point number to string representation.
     $(	let j, w = 0, vec 100
	if NumbArgs () < 3 do Digits := 5
	if F .< 0.0 do F, w!1, j := .- F, '-', 1	//  Handle sign.
//  Compute exponent for E notation.
	let e = 0
	unless F .= 0.0 | 0.1 .le F .< 10000.0 do
		test F .ge 10.0			//  Get F in range 1.0 to 9.999....
		then e, F := e + 1, F ./ 10.0 repeatwhile F .ge 10.0
		or e, F := e - 1, F .* 10.0 repeatwhile F .< 1.0
//  Convert the integer part.
	let n = RtoI (F)
	F := F .- ItoR (n)
	let T = StoreN (n, lv w!j, 10, 1)
	j, Digits := j + T + 1, Digits - T
	w!j := '.'
	if Digits > 20 do Digits := 20
	for i = 1 to Digits do
	     $(	F := F .* 10.0
		j := j + 1
		w!j := RtoI (F) rem 10 + '0'
	     $)
	unless e = 0 do
	     $(	j := j + 1
		w!j := 'E'
		if e < 0 do
		     $(	j := j + 1
			e, w!j := - e, '-'
		     $)
		j := j + StoreN (e, lv w!j, 10, 2)
	     $)
	w!0 := j
	Packstring (w, Space)
	resultis Space
     $)

//  Functions to convert a BCPL string to and from escaped format exactly like that allowed by compiler.

let InsertEscapes (Input, Space) = valof
     $(	let v, w = vec 300 / 4, vec 300
	and j = 0
	SetLength (Space, 0)
	let Len = Length (Input)
	for i = 1 to Len do
	     $(	if j > 300 - 5 do		//  Temporary string w nearly full, move onto output.
		     $(	w!0 := j
			Packstring (w, v)
			Concatenate (Space, Len * 5, Space, v)		//  Max length - assume worst case.
			j := 0
		     $)
		let c = Subch (Input, i)
		let s = valof switchon c 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':
			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':
			case '0': case '1': case '2': case '3': case '4':
			case '5': case '6': case '7': case '8': case '9':
			case '<': case '>': case ':': case ';': case '+': case '-':
			case '=': case '.': case ',': case '/': case '?': case '#':
			case '|': case '`': case '\': case '_': case '[': case ']':
			case '{': case '}': case '(': case ')': case '&': case '%':
			case '$': case '!': case '^': case '~': case '@': case ' ':
				j := j + 1; w!j := c
				loop
	
			case '*n': resultis 'n'
			case '*t': resultis 't'
			case '*b': resultis 'b'
			case '*f': resultis 'f'
			case '*v': resultis 'v'
			case '*r': resultis 'r'
			case '*d': resultis 'd'
			case '*k': resultis 'k'
			case '**': case '*'': case '*"':
				resultis c
	
			default:	resultis 'o'
		     $)
		j := j + 1; w!j := '**'
		j := j + 1; w!j := s
		if s = 'o' do j := j + StoreN (c, lv w!j, 8, 3)
	     $)

	w!0 := j
	Packstring (w, v)
	Concatenate (Space, Len * 5, Space, v)
	resultis Space
     $)

and RemoveEscapes (Input, Space) = valof
     $(	let v, w = vec 300 / 4, vec 300
	and j = 0
	SetLength (Space, 0)
	let First, Last = 1, Length (Input)
	let c = Subch (Input, First)
	if (c = '*'' | c = '*"') & Last > First & Subch (Input, Last) = c do First, Last := First + 1, Last - 1
	for i = First to Last do
	     $(	if j > 300 - 1 do		//  Temporary string w is full, stuff it into output string Space.
		     $(	w!0 := j
			Packstring (w, v)
			Concatenate (Space, Last, Space, v)
			j := 0
		     $)
		c := Subch (Input, i)
		if c = '**' & i < Last do
		     $(	i := i + 1
			c := Subch (Input, i)
			c := valof switchon c into
			     $(	case 's':	case 'S':	resultis '*s'
				case 'n':	case 'N':	resultis '*n'
				case 't':	case 'T':	resultis '*t'
				case 'b':	case 'B':	resultis '*b'
				case 'r':	case 'R':	resultis '*r'
				case 'f':	case 'F':	resultis '*f'
				case 'v':	case 'V':	resultis '*v'
				case 'k':	case 'K':	resultis '*k'
				case 'd':	case 'D':	resultis '*d'
	
				case 'c':	case 'C':	i := i + 1 repeatuntil Subch (Input, i) = '**' | i ge Last
						loop
				case 'o':	case 'O':	     $(	let n = 0
							for k = 1 to 3 do
							     $(	if i ge Last break
								let c = Subch (Input, i + 1)
								unless '0' le c le '7' break
								n := n lshift 3 | (c - '0')
								i := i + 1
							     $)
							resultis n
						     $)
				default:		resultis c
			     $)
		     $)
		j := j + 1
		w!j := c
	     $)

	w!0 := j
	Packstring (w, v)
	Concatenate (Space, Last, Space, v)
	resultis Space
     $)


let ConvertStoN (String, Base) = valof		//  String to number conversion.
					//  Allows floating point and base specification (i.e. octal).
					//  If an unexpected character is found, an appropriate error code is set.
     $(	if NumbArgs () < 2 do Base := 10
	let Unpacked = vec 512
	Unpackstring (String, Unpacked)
	let Index, Length = 1, Unpacked!0		//  For scanning string.
	let Integer, Real = 0, 0.0			//  For result.
	let Neg = false
	Errcode := 0

//  First remove all blanks from the string.
	for i = Length to 1 by -1 if Unpacked!i = '*s' do
			     $(	Length := Length - 1
				for j = i to Length do Unpacked!j := Unpacked!(j + 1)
			     $)

	let Ch = Unpacked!Index			//  Next character to process.
	if Ch = '-' logor Ch = '+' do			//  Allow sign.
	     $(	if Ch = '-' do Neg := true
		Index := Index + 1			//  Space over sign.
		Ch := Unpacked!Index
	     $)
	if Ch = '$' & Index < Length do		//  May start with base specification, for example $8 for octal.
	     $(	Ch := Unpacked!(Index + 1)
		test '2' le Ch le '9'
		then Base := Ch - '0'
		or test Ch = 'x' logor Ch = 'X'
		   then Base := 16			//  Hexadecimal.
		   or $(	Errcode := rv ErrTableBadString
			resultis 0
		      $)
		Index := Index + 2			//  Space over dollar sign and digit.
		Ch := Unpacked!Index
	     $)
	while Index le Length do			//  Gather in integer part.
	     $(	let N = Ch - '0'
		unless 0 le N < Base do
		     $(	N := Ch - 'A' + 10
			unless 10 le N < Base break
		     $)
		Integer := Integer * Base + N
		if Base = 10 do Real := Real .* 10.0 .+ ItoR (N)	//  In case it turns out to be floating.
		Index := Index + 1
		Ch := Unpacked!Index
	     $)
	if Neg do Integer := - Integer
	if Index > Length resultis Integer
	unless Ch = '.' & Base = 10 do
	     $(	Errcode := rv ErrTableBadString
		resultis Integer
	     $)
						//  Now it is known to be a floating point number.
	let Div, Fraction = 1.0, 0.0			//  Accumulate fraction and divisor.
	     $(	Index := Index + 1			//  Gather in the fractional part of the number.
		Ch := Unpacked!Index
		unless Index le Length & '0' le Ch le '9' break
		Div := Div .* 10.0
		Fraction := Fraction .* 10.0 .+ ItoR (Ch - '0')
	     $)	repeat
	Real := Real .+ Fraction ./ Div
	if Index < Length & (Ch = 'e' | Ch = 'E') do	//  E-notation.
	     $(	let Neg = false
		let Exp = 0			//  Power of ten to multiply result by.
		Index := Index + 1			//  Skip the E.
		Ch := Unpacked!Index
		if Ch = '-' logor Ch = '+' do		//  Signed exponent.
		    $(	if Ch = '-' do Neg := true
			Index := Index + 1
			Ch := Unpacked!Index
		     $)
		while Index le Length & '0' le Ch le '9' do	//  Get exponent.
		     $(	Exp := Exp * 10 + Ch - '0'
			Index := Index + 1
			Ch := Unpacked!Index
		     $)
		if Neg do Exp := - Exp
		Real := Real .* RpowerI (10.0, Exp)	//  Multiply Real by 10.0 ** Exp.
	     $)
	if Neg do Real := .- Real
	unless Index > Length do Errcode := rv ErrTableBadString
	resultis Real
     $)

static
     $(	StandardZone = 0
	StandardDelta = 0
	DaylightZone = 0
	DaylightDelta = 0
     $)

let StoreDate (SecondsSince1901, Space, Breaks) be	//  Internal routine to decode clock value.
     $(	let SecondsSinceMidnight = Mod (SecondsSince1901 - 1, 24 * 3600) + 1		//  24:00:00 exists.
	let DaysSince1901 = (SecondsSince1901 - SecondsSinceMidnight) / (24 * 3600)
	let DayOfCycle = Mod (DaysSince1901, 1461)		//  1461 days in four year leap cycle.
	let MonthOfCycle = DayOfCycle / 31			//  First guess - must check with table.
	let Table = table 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334,
		365, 396, 424, 455, 485, 516, 546, 577, 608, 638, 669, 699,
		730, 761, 789, 820, 850, 881, 911, 942, 973, 1003, 1034, 1064,
		1095, 1126, 1155, 1186, 1216, 1247, 1277, 1308, 1339, 1369, 1400, 1430,
		1461
	if DayOfCycle ge Table!(MonthOfCycle + 1) do MonthOfCycle := MonthOfCycle + 1

	let MonthOfYear = MonthOfCycle rem 12
	and DayOfMonth = DayOfCycle - Table!MonthOfCycle
	and Year = 1901 + (DaysSince1901 - DayOfCycle) / 1461 * 4 + DayOfCycle * 4 / 1461
	and DayOfWeek = Mod (DaysSince1901 + 2, 7)			//  1 Jan 1901 was a Tuesday (2).

	let MonthNames = list "January", "February", "March", "April", "May", "June",
			"July", "August", "September", "October", "November", "December"
	and DayNames = list "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday"

	Space!0, Space!1 := MonthOfYear + 1, MonthNames!MonthOfYear
	Space!2, Space!3 := DayOfMonth + 1, Year
	Space!4, Space!5 := DayOfWeek, DayNames!DayOfWeek

	Space!6 := SecondsSinceMidnight / 3600
	Space!7 := (SecondsSinceMidnight / 60) rem 60
	Space!8 := SecondsSinceMidnight rem 60

	let FirstMonthOfYear = MonthOfCycle - MonthOfYear
	let LastDayOfApril = Table!(FirstMonthOfYear + 4) - 1	//  First day of May - 1.
	and LastDayOfOctober = Table!(FirstMonthOfYear + 10) - 1
	let LastSundayOfApril = LastDayOfApril - (LastDayOfApril + DayOfWeek - DayOfCycle + 7777) rem 7
	and LastSundayOfOctober = LastDayOfOctober - (LastDayOfOctober + DayOfWeek - DayOfCycle + 7777) rem 7
	Breaks!0 := (LastSundayOfApril + DaysSince1901 - DayOfCycle) * (24 * 3600) + 2 * 3600
	Breaks!1 := (LastSundayOfOctober + DaysSince1901 - DayOfCycle) * (24 * 3600) + 2 * 3600
     $)
and Mod (x, y) = x ge 0 -> x rem y, (x rem y + y) rem y	//  Necessary from 6180 definition of rem.


//  Routine to interpret a clock time in seconds since 1901 into a form easily formatted for printing.
//  This routine applies the standard Daylight Saving Time algorithm to determine which of two time zones to use.

and FormDate (Seconds, Space, GMTsw) be
     $(	let Breaks = vec 2
	if StandardZone = 0 do InitializeZoneInfo ()	//  Initialize static strings.

	if NumbArgs () > 2 then if GMTsw do
	     $(	StoreDate (Seconds, Space, Breaks)
		Space!9 := "GMT"
		return
	     $)

	StoreDate (Seconds - StandardDelta, Space, Breaks)	//  Assume Standard time first.
	Space!9 := StandardZone

	if (Seconds - StandardDelta) > Breaks!0 & (Seconds - DaylightDelta) le Breaks!1 do
	     $(	StoreDate (Seconds - DaylightDelta, Space, Breaks)	//  Try daylight time.
		Space!9 := DaylightZone
	     $)
     $)
and InitializeZoneInfo () be
     $(	let Zone = rv SysInfoTimeZone

//  Convert Zone to all upper case.
	for i = 0 to WordSize  - ByteSize by ByteSize do
	     $(	let c = (Zone rshift i) logand (true rshift WordSize - ByteSize)
		if 'a' le c le 'z' do Zone := Zone + ('A' - 'a' lshift i)
	     $)

	switchon Zone into
	     $(	case 'EST ': case 'EDT ':
			StandardZone, StandardDelta := "EST", 5 * 3600
			DaylightZone, DaylightDelta := "EDT", 4 * 3600
			endcase

		case 'CST ': case 'CDT ':
			StandardZone, StandardDelta := "CST", 6 * 3600
			DaylightZone, DaylightDelta := "CDT", 5 * 3600
			endcase

		case 'MST ': case 'MDT ':
			StandardZone, StandardDelta := "MST", 7 * 3600
			DaylightZone, DaylightDelta := "MDT", 6 * 3600
			endcase

		case 'PST ': case 'PDT ':
			StandardZone, StandardDelta := "PST", 8 * 3600
			DaylightZone, DaylightDelta := "PDT", 7 * 3600
			endcase

		default:
			let v = vec 10
			MakeBcplString (lv Zone, 4, v)
			let t = Allocate (LengthInWords (v))
			CopyString (v, t)
			let d = TimeToSeconds (SysInfoTimeCorrectionConstant)
			StandardZone, StandardDelta := t, d
			DaylightZone, DaylightDelta := t, d
	     $)
     $)

let SetTimeZone () be main
     $(	let Arg = vec 128
	if Pl1NumbArgs () < 4 do
	     $(	InitializeZoneInfo ()
		return
	     $)
	DaylightDelta := ConvertStoN (Pl1ArgString (4, Arg))
	Pl1ArgString (3, Arg)
	DaylightZone := Allocate (LengthInWords (Arg))
	CopyString (Arg, DaylightZone)
	StandardDelta := ConvertStoN (Pl1ArgString (2, Arg))
	Pl1ArgString (1, Arg)
	StandardZone := Allocate (LengthInWords (Arg))
	CopyString (Arg, StandardZone)
    $)




		    bcpl_filesys_lib_.bcpl          04/22/82  1623.2rew 04/22/82  1125.2       84357



//  Interface to Multics file system routines for BCPL programs.
//  Last modified on 06/03/74 at 11:56:55 by R F Mabee.
//  Reinstalled with no material change in June 1974, R F Mabee.
//  Modified for 6180 bootstrap and installed in June 1973, R F Mabee.
//  First installed in September 1971 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"

external
     $(	ExpandPath = "expand_path_"		//  call expand_path_ (path name ptr, path name length,
					//	dir name ptr, entry name ptr, return code)
	Initiate = "hcs_$initiate"		//  call hcs_$initiate (dir name, entry name, reference name,
					//	segno_sw, copy_sw, return ptr, return code)
	StatusMinf = "hcs_$status_minf"	//  call hcs_$status_minf (dir name, entry name, chase_sw,
					//	return type, return bit count, return code)
	MakeSeg = "hcs_$make_seg"		//  call hcs_$make_seg (dir name, entry name, reference name,
					//	access mode, return ptr, return code)
	Delentry = "hcs_$delentry_file"	//  call hcs_$delentry_file (dir name, entry name, return code)
	TruncateSeg = "hcs_$truncate_seg"	//  call hcs_$truncate_seg (segment ptr, word length, return code)
	TerminateNoname = "hcs_$terminate_noname" // call hcs_$terminate_noname (segment ptr, return code)
	SetBC = "hcs_$set_bc_seg"		//  call hcs_$set_bc_seg (segment ptr, bit count, return code)
	FsGetPathName = "hcs_$fs_get_path_name"	//  call hcs_$fs_get_path_name (segment ptr, return dir name,
					//	return dir name length, return entry name, return code)
	GetWdir = "get_wdir_"		//  call get_wdir_ (return working dir name)
	GetPdir = "get_pdir_"		//  call get_pdir_ (return process dir name)
	AssignLinkage = "hcs_$assign_linkage"	//  call hcs_$assign_linkage (# words, return ptr)
	MakePtr = "hcs_$make_ptr"		//  call hcs_$make_ptr (caller ptr, name1, name2, return ptr, return code)
	VirtualCpuTime = "virtual_cpu_time_"	//  call virtual_cpu_time_ (return 52-bit cpu usage)

	SegKnown = "error_table_$segknown"	//  declare error_table_$segknown fixed binary external static;
	ZeroLenSeg = "error_table_$zero_length_seg" // declare error_table_$zero_length_seg fixed binary external static;
	DirSeg = "error_table_$dirseg"	//  declare error_table_$dirseg fixed binary external static;
	NoEntry = "error_table_$noentry"	//  declare error_table_$noentry fixed binary external static;

	MaxSegSize = "sys_info$max_seg_size"	//  declare sys_info$max_seg_size fixed binary external static;
     $)
global
     $(	FirstTemp : 42; Freearea : 43
	Freelimit : 44; Freelist : 45
     $)
static
     $(	Zero = 0; One = 1; Eleven = 11  $)	//  Constants for Multics calls.

let ExpandPathname (Name, Path) = valof		//  Returns Path containing full pathname as string.
     $(	let Dir, Ent = vec 42, vec 8
	let v = vec 6
	let l = Length (Name)
	call ExpandPath (ITS (Name, v, CountSize) pointer, lv l, ITS (Dir, v + 2) pointer,
							ITS (Ent, v + 4) pointer, lv Errcode bit 36)
	resultis JoinPathname (Dir, Ent, Path)
     $)
and JoinPathname (Dir, Ent, Path) = valof
     $(	MakeBcplString (Dir, 168, Path)
	if Path!0 = ">"!0 do Path!0 := ""!0
	let v = vec 10
	MakeBcplString (Ent, 32, v)
	resultis Concatenate (Path, 168, Path, ">", v)
     $)
and SplitPathname (Path, Dir, Ent) be		//  Get back aligned Dir168, Ent32 for internal use.
     $(	let Temp = vec 50
	for i = Length (Path) to 1 by -1 if Subch (Path, i) = '>' do
		     $(	Substr (Temp, Path, 1, MinI (i - 1, 168))
			MakePl1String (i = 1 -> ">", Temp, Dir, 168)
			Substr (Temp, Path, i + 1, 32)
			MakePl1String (Temp, Ent, 32)
			return
		     $)
	MakePl1String (Path, Dir, 168)
	MakePl1String ("", Ent, 32)
     $)

let FindSegment (Path, LvL) = valof		//  Return pointer to named segment.  rv LvL gets bit count.
     $(	let Dir, Ent = vec 42, vec 8
	SplitPathname (Path, Dir, Ent)
	let Type, v = 0, vec 2
	call StatusMinf (Dir char 168, Ent char 32, lv One, lv Type, LvL, lv Errcode bit 36)
	if Type = 2 do Errcode := rv DirSeg
	unless Errcode = 0 resultis Null
	call Initiate (Dir char 168, Ent char 32, lv Zero char 0, lv Zero, lv One, v pointer, lv Errcode bit 36)
	if Errcode ne 0 then if Errcode = rv SegKnown do Errcode := 0
	resultis BCPLaddr (v)
     $)

let MakeSegment (Path) = valof			//  Return pointer to named segment, creating it or truncating it.
     $(	let v, Dir, Ent = vec 2, vec 42, vec 8
	SplitPathname (Path, Dir, Ent)
	call MakeSeg (Dir char 168, Ent char 32, lv Zero char 0, lv Eleven, v pointer, lv Errcode bit 36)
	let p = BCPLaddr (v)
	unless Errcode = 0 logor p = Null do SetBitCount (p, 0)
	resultis p
     $)

and SetBitCount (p, l) be			//  Truncate segment p to l bits.
     $(	let v = vec 2
	let n = (l + WordSize - 1) / WordSize
	call TruncateSeg (ITS (p, v) pointer, lv n, lv Errcode bit 36)
	call SetBC (ITS (p, v) pointer, lv l, lv Errcode bit 36)
     $)
and Terminate (p) be			//  Terminate one null reference name on segment p.
     $(	let v = vec 2
	call TerminateNoname (ITS (p, v) pointer, lv Errcode bit 36)
     $)
and GetPathname (p, Path) = valof
     $(	let Dir, Ent = vec 42, vec 8
	let v, x = vec 2, nil
	call FsGetPathName (ITS (p, v) pointer, Dir char 168, lv x, Ent char 32, lv Errcode bit 36)
	resultis JoinPathname (Dir, Ent, Path)
     $)

let MakeTempSeg (Index, ID) = valof		//  Create a temporary segment in the process directory.
     $(	unless NumbArgs () = 2 do ID := "temp"
	let Name, v = vec 50, vec 2
	MakeName (Index, ID, Name)
	call MakeSeg ("" string, Name string, "" string, lv Eleven, v pointer, lv Errcode bit 36)
	resultis BCPLaddr (v)
     $)
and DeleteTempSeg (Index, ID) be		//  Delete a temporary segment from the process directory.
     $(	unless NumbArgs () = 2 do ID := "temp"
	let Name, Pdir = vec 50, vec 50
	MakeName (Index, ID, Name)
	call GetPdir (Pdir char 168)
	call Delentry (Pdir char 168, Name string, lv Errcode bit 36)
     $)
and MakeName (Index, ID, Name) be		//  Fabricate temp seg name.
     $(	let w = vec 50
	Concatenate (Name, 32, ProgramID, ".temp_seg_", ConvertNtoS (Index, w), ".", ID)
     $)

let Allocate (n) = valof				//  Return a pointer to n free words from the combined linkage.
     $(	let v = vec 2
	if n < 0 logor n ge 16000 do n := 16000
	n := n + n rem 2		//  Round up to even number.
	call AssignLinkage (lv n, v pointer, lv Errcode bit 36)	//  Let hcs_ entry do the work.
	resultis BCPLaddr (v)
     $)

manifest $( NewvecID = $8001234567654  $)	//  Magic flag must be present or vector cannot be freed.
static $( NewvecTemps = 0  $)			//  Used to obtain unique names for temporary segments.
let NewvecInit (Space, Size) be		//  Initialize free-storage allocation package.
     $(	for i = 0 to 20 do Space!i := 0
	Freelist := Space
	Freearea := Space + 21
	Freelimit := Space + Size
	FirstTemp := NewvecTemps
     $)
and Newvec (Size) = valof		//  Get a vector of length Size from free storage.
     $(	Size := Size + 1		//  n-word vector has n+1 words.
	Size := Size & Right
	let j = 0		//  Determine next larger power of two.
	     $(	Size := Size rshift 1
		if Size = 0 break
		j := j + 1
	     $)	repeat
	let p = Freelist!j		//  Look first for reusable space of same size.
	unless p = 0 do
	     $(	Freelist!j := p!0
		p!0 := NewvecID | j lshift 30
		resultis lv p!1
	     $)
   Try:	p := Freearea		//  Carve new chunk off unused block.
	Freearea := Freearea + (2 lshift j)
	if Freearea le Freelimit do			//  If it fits, done.
	     $(	p!0 := NewvecID | j lshift 30
		resultis lv p!1
	     $)
	NewvecTemps := NewvecTemps + 1		//  Need more space, grab another segment.
	Freearea := MakeTempSeg (NewvecTemps, "Newvec")
	Freelimit := Freearea + rv MaxSegSize
	goto Try
     $)
and Freevec (Space) be		//  Put back a previously allocated vector.
     $(	Space := lv Space!(-1)
	let j = Space!0
	unless (j & $8007777777777) = NewvecID return		//  Clobbered somehow?
	j := j rshift 30
	Space!0 := Freelist!j
	Freelist!j := Space
     $)
and NewvecCleanup () be		//  Release segments created by Newvec in this invocation.
     $(	while FirstTemp < NewvecTemps do
	     $(	FirstTemp := FirstTemp + 1
		DeleteTempSeg (FirstTemp, "Newvec")
	     $)
     $)
let Findadr (s, t) = valof	//  Invoke the linker with string variable arguments.
			//  The external declaration should be used if the names are known at compile time.
     $(	let v, w = vec 2, vec 2
	let N1, N2 = vec 128, vec 128
	test NumbArgs () = 1
	then $(	let i = IndexCh (s, '$')
		test i = 0
		then t := s
		or   $(	Substr (N1, s, 1, MinI (i - 1, 511))
			Substr (N2, s, i + 1, 511)
			s, t := N1, N2
		     $)
	     $)
	or if t = 0 do t := ""		//  For direct text reference. No linkage section is required.
	let CallerPtr = rv (lv s - 2)		//  Routine that called Findadr; used for referencing_dir rule.
	call MakePtr (ITS (CallerPtr, w) pointer, s string, t string, v pointer, lv Errcode bit 36)
	unless Errcode = 0 resultis Null
	resultis BCPLaddr (v)
     $)

let GetCpuUsage () = valof		//  Return cpu time usage in microseconds.
     $(	let v = vec 2
	call VirtualCpuTime (v fixed double)
	resultis v!1
     $)




		    bcpl_machine_code_.alm          11/05/86  1205.8r w 11/04/86  1038.4      117504



"  Stuff coded in ALM for faster execution or easier writing.
"  Last modified on 08/02/74 at 19:05:37 by R F Mabee.
"  Reinstalled with no material change in August 1974, R F Mabee.
"  Transformed to 6180 machine code and installed in June 1973 by R F Mabee.
"  First installed as bcpl_alm_ in September 1971 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.

"		calling sequence for all routines (BCPL standard call):
"
"	lda	arg1
"	sta	sb|k+2,1
"	lda	arg2
"	sta	sb|k+3,1
"	..
"	lda	argn
"	sta	sb|k+n+1,1
"	tspbp	routine
"	zero	k,n		" n is restricted to 6 bits.
"	stq	result		" i.e. result of routine is in Q, if any.
"
"	Return is always to bp|1. Registers bp, lp, sp, sb, and x1 should not be altered.
"	lp can be reloaded from the caller's frame.

"	save sequence used by BCPL programs:
"
"	adlx1	bp|0		" increment stack pointer.
"	sprpbp	sb|0,1
"	sprplp	sb|1,1		" new lp - set by entry sequence.

"	standard BCPL return sequence:
"
"	lprpbp	sb|0,1
"	sblx1	bp|0		" decrement stack pointer.
"	lprplp	sb|1		" reload caller's lp from his frame.
"	tra	bp|1

"	These routines use x2 for the stack pointer to shorten the save and
"	return sequences. A standard _g_e_t_l_p sequence is used only when the routine
"	must be able to access the linkage section.

	use	textc

	segdef	RawClockTime	" RawClockTime (Space2) = Space2.
RawClockTime:
	eax2	bp|0,*1
	sprpbp	sb|0,2
	getlp			" find linkage section to reference links.
	rccl	<sys_info>|[clock_],*	" clock reading in microseconds, GMT.
	lprpap	sb|2,2
	staq	ap|0
	ldq	sb|2,2		" result to Q.
	lprpbp	sb|0,2		" reload return address.
	lprplp	sb|1,1		" restore caller's lp.
	tra	bp|1		" that's all.

	segdef	TimeToSeconds	" TimeToSeconds (RawTime) = Seconds since 1901.
TimeToSeconds:
	eax2	bp|0,*1
	lprpap	sb|2,2
	ldaq	ap|0
	dvf	number-*,ic	" Divide by one million to get seconds.
	lrl	36		" result to Q.
	tra	bp|1

number:	dec	500000		" because dvf ignores lowest bit of Q.

	segdef	ItoR		" ItoR (Integer) = floating point number.
ItoR:	eax2	bp|0,*1		" to address args.
	fld	=35b25,du		" puts binary point between A & Q.
	lda	sb|2,2		" the integer.
	fad	=0.0,du		" normalize a floating point number.
	fst	sb|3,2		" get it back in Q.
	ldq	sb|3,2		" result.
	tra	bp|1		" return.

	segdef	RtoI		" RtoI (Floating point number) = Integer.
RtoI:	eax2	bp|0,*1
	fld	sb|2,2		" the floating point number.
	tmi	negative
	ufa	=71b25,du		" move binary point over to right of Q.
	tra	bp|1

negative:	fneg	0,dl		" make positive for proper truncation (toward zero).
	ufa	=71b25,du
	negl	0,du		" restore sign.
	tra	bp|1

	segdef	SetOverflowMask	" SetOverflowMask (Boolean).
SetOverflowMask:
	eax2	bp|0,*1
	ldi	=o004000,dl	" disable overflow fault.
	lda	sb|2,2		" the boolean value.
	tnz	2,ic		" if true, leave disabled.
	ldi	0,dl		" re-enable overflow fault.
	tra	bp|1

	segdef	BCPLaddr		" BCPLaddr (ITS ptr) = bcpl address.
BCPLaddr:	eax2	bp|0,*1
	lprpap	sb|2,2		" BCPL address of ITS pair.
	eppab	ap|0,*		" evaluate ITS (or any other indirect) address.
	sprpab	sb|3,2		" store BCPL pointer.
	ldq	sb|3,2		" return result in Q.
	tra	bp|1

	segdef	ITS		" ITS (Address to be stored, Vector, bit offset) = Vector.
ITS:	eax2	bp|0,*1
	lprpbb	sb|2,2
	lprpap	sb|3,2
	lxl3	bp|0		" get number of arguments.
	anx3	63,du		" mask off possible extraneous bits.
	cmpx3	3,du		" check for third argument.
	tmi	3,ic		" only two args, use default offset.
	ldq	sb|4,2		" bit offset argument.
	abd	bb|0,ql		" add in bit offset.

	spribb	ap|0		" store as ITS pair.
	ldq	sb|3,2		" result is Vector.
	tra	bp|1

	segdef	NumbArgs		" NumbArgs () = number of arguments passed to caller.
NumbArgs:	lprpap	sb|0,1		" assume normal save sequence.
	ldq	ap|0
	anq	63,dl		" mask excess bits.
	tra	bp|1		" that's all.

	segdef	Readch		" Readch (Stream, lv Ch).
Readch:	eax2	bp|0,*1
	lprpap	sb|2,2		" stream.
	lprpab	sb|3,2		" lv Ch.
	lda	ap|0		" Nextch (character offset to next character).
	cmpa	ap|1		" Maxch (current number of characters in buffer).
	tpl	refill-*,ic
	aos	ap|0		" count character.
	lprpbb	ap|6		" load address of buffer.
	mrl	(pr,al),(pr),fill(0)
	desc9a	bb|0,1
	desc9a	ab|0,4		" Move will pad left of Ch.
	tra	bp|1

refill:	szn	ap|4		" routine to refill buffer.
	tze	nofill-*,ic	" cannot be refilled.
	eax1	0,2		" prepare to call out.
	eax2	2048,2
	anx2	=o777760,du
	stx2	sb|stack_header.stack_end_ptr+1
	sprpbp	sb|0,1
	sprplp	sb|1,1		" save caller's lp.
	sprpap	sb|6,1		" pass one argument, namely the stream address.
	lprpab	ap|4		" routine to refill buffer.
	tspbp	ab|0		" call.
	zero	4,1
	lprpbp	sb|0,1		" undo the save.
	sblx1	bp|0
	tra	Readch-*,ic	" try Readch all over again.

nofill:	lda	=o7777,dl		" return Endofstreamch if buffer cannot be refilled.
	sta	ab|0
	tra	bp|1

	segdef	Writech		" Writech (Stream, Ch).
Writech:	eax2	bp|0,*1
	lprpap	sb|2,2		" the stream.
	lda	ap|0		" Nextch (character offset in buffer).
	cmpa	ap|1		" Maxch (length of buffer).
	tpl	full-*,ic		" buffer is full - write it out.
	aos	ap|0		" count character.
	lprpbb	ap|6		" buffer.
	eppab	sb|3,2		" lv Ch.
	mlr	(pr),(pr,al)
	desc9a	ab|0(3),1	" Move from rightmost byte of Ch
	desc9a	bb|0,1		" to indexed byte of buffer.
	lda	ap|2		" delimiter if any (character ending line).
	tze	bp|1		" no delimiter.
	cmpa	sb|3,2		" compare to Ch.
	tnz	bp|1		" no match - done.
	tsx6	empty-*,ic	" write out buffer, set return point.
	tra	bp|1

full:	eax6	Writech-*,ic	" set return point from empty
empty:	szn	ap|4		" routine to write out buffer.
	tze	bp|1		" buffer cannot be written out.
	eax1	0,2		" prepare for call out.
	eax2	2048,2
	anx2	=o777760,du
	stx2	sb|stack_header.stack_end_ptr+1
	sprpbp	sb|0,1		" Save old return address
	sprplp	sb|1,1		" and caller's lp.
	stx6	sb|4,1		" save return point from empty.
	sprpap	sb|8,1		" pass one arg, the address of the stream.
	lprpab	ap|4		" routine to write out buffer.
	tspbp	ab|0		" call.
	zero	6,1
	lprpbp	sb|0,1		" restore old return address.
	ldx6	sb|4,1		" return point from empty.
	sblx1	bp|0
	tra	0,6		" return or try again to write character.

	segdef	Packstring	" Packstring (Unpacked string, Vector).
Packstring:
	eax2	bp|0,*1
	sprpbp	sb|0,2		" save return address.
	lprpap	sb|2,2		" address of unpacked string.
	lprpbp	sb|3,2		" address of vector.
	lda	ap|0		" length of string.
	ada	1,dl		" + 2 bytes for length, - 1 for divide.
	lrl	2		" number of words in A.
	qrl	16		" number of bytes used in last word in Qu.
	eax5	0,qu
	eppbp	bp|1,al		" bp -> last word to be stored into.
	neg
	eax6	-1,al		" so that bp|0,6 points to first word.
	lda	ap|2
	lrl	9
	lda	ap|1
	lrl	9
	lda	ap|0
	lrl	18
	eppap	ap|-1
	tra	penter-*,ic	" Jump into loop.

ploop:	lda	ap|3		" take four characters in reverse order.
	lrl	9		" and shift each one into Q.
	lda	ap|2
	lrl	9
	lda	ap|1
	lrl	9
	lda	ap|0
	lrl	9
penter:	stq	bp|0,6		" store packed word.
	eppap	ap|4		" advance pointer to unpacked version.
	adx6	1,du		" increment counter.
	tmi	ploop-*,ic
	anq	masklist,5	" mask off trailing character positions in last word.
	stq	bp|-1,6		" overwrite last word as stored within loop.
	tra	reloadreturn-*,ic

masklist:	oct	777000000000
	oct	777777000000
	oct	777777777000
	oct	777777777777

	segdef	Unpackstring	" Unpackstring (String, Vector).
Unpackstring:
	eax2	bp|0,*1
	sprpbp	sb|0,2		" save return address.
	lprpap	sb|2,2		" string address.
	lprpbp	sb|3,2		" vector address.
	lda	ap|0		" get character count.
	lrl	18
	sta	bp|0		" store length of string.
	eppbp	bp|2,al		" bp -> last word of unpacked string to be stored.
	neg
	eax6	-1,al		" so bp|0,6 will point to first word (after count).
	tra	uenter-*,ic	" Jump into loop.

uloop:	ldq	ap|0		" next four characters.
	lda	0,dl		" clear A.
	lls	9		" shift next character into A.
	sta	bp|0,6		" store it.
	adx6	1,du		" check for end.
	tpl	reloadreturn-*,ic
	lda	0,dl
	lls	9
	sta	bp|0,6
	adx6	1,du
	tpl	reloadreturn-*,ic
uenter:	lda	0,dl
	lls	9
	sta	bp|0,6
	adx6	1,du
	tpl	reloadreturn-*,ic
	lda	0,dl
	lls	9
	sta	bp|0,6
	eppap	ap|1		" advance pointer to string.
	adx6	1,du		" check for end.
	tmi	uloop-*,ic
	tra	reloadreturn-*,ic

	segdef	Move		" Move (Toptr, Fromptr, Wordcount).
Move:	eax2	bp|0,*1
	sprpbp	sb|0,2
	lprpap	sb|2,2		" Toptr.
	lprpbp	sb|3,2		" Fromptr.
	eax6	0		" count number of words already moved.
	stz	sb|5,2		" clear for later use.
mloop:	lda	sb|4,2		" Wordcount.
	sxl6	sb|5,2		" words already moved.
	sba	sb|5,2		" words left to move.
	tmi	reloadreturn-*,ic
	tze	reloadreturn-*,ic
	als	10		" set up for rpd.
	bool	rpdbits,001000	" the only way to specify the address in octal.
	eax0	rpdbits,al	" make it an rpda (index on first instruction).
	odd
	rpdx	,1		" X0 contains tally, RPDA code, and (null) termination bits.
	ldq	bp|0,6
	stq	ap|0,6
	tra	mloop-*,ic

	segdef	MoveBits		" MoveBits (To, Tobit, From, Frombit, Bitcount).
MoveBits:	eax2	bp|0,*1
	lprpap	sb|2,2		" To.
	lda	sb|3,2		" Tobit.
	lprpab	sb|4,2		" From.
	ldq	sb|5,2		" Frombit.
	abd	ap|0,al		" Free A by adding offset into pointer.
	lda	sb|6,2		" Bitcount.
	tmoz	bp|1		" Nothing to move.

	csl	bool(03),(pr,rl,ql),(pr,rl)	" This is really a copy.
	descb	ab|0,al		" Offset by ql.
	descb	ap|0,al		" Length in al.
	tra	bp|1

	segdef	ScanChar		" ScanChar (Ptr, Offset, Length, Ch) = Offset to Ch or -1.
ScanChar:	eax2	bp|0,*1
	lprpap	sb|2,2		" Ptr.
	lda	sb|3,2		" Offset.
	ldq	sb|4,2		" Length.
	eppab	sb|5,2		" lv Ch.
	scm	mask(0),(pr,rl,al),(pr)	" Match on all 9 bits of character.
	desc9a	ap|0,ql		" Length in ql, offset in al.
	desc9a	ab|0(3),1		" Ch right justified.
	arg	sp|0		" Resulting offset stored here.
	ldq	sp|0
	ttf	bp|1		" Return it if match occurred.
	lcq	1,dl
	tra	bp|1

reloadreturn:	"		" common return sequence when bp has been stored.
	lprpbp	sb|0,2
	tra	bp|1

	segdef	Subch		" Subch (String, Characteroffset) = Character.
Subch:	eax2	bp|0,*1
	lprpap	sb|2,2		" String.
	lda	sb|3,2		" Characteroffset.
	mrl	(pr,al),(pr),fill(0)	" Copy character right justified.
	desc9a	ap|0(1),1	" Offset by one extra for string count byte.
	desc9a	sp|0,4
	ldq	sp|0
	tra	bp|1

	segdef	Level		" Level () = level (sp in left half, x1 in right half).
Level:	eaa	sp|0		" sp in Au.
	eaq	0,1		" x1 in Qu.
	arl	18
	lrl	18		" result in Q.
	tra	bp|1

	segdef	Longjump		" Longjump (Label, Level).
Longjump:	eax2	bp|0,*1
	sprpbp	sb|0,2		" save return address although don't use it.
	getlp			" find linkage section.
	lprpbp	sb|2,2		" label.
	ldq	sb|3,2		" level.
	eax6	sp|0		" current sp.
	cmpx6	sb|3,2		" check for jump crossing Multics stack frames.
	tnz	hard_way-*,ic	" do it by calling the unwinder.
	eax1	0,ql		" set x1 (BCPL stack frame pointer).
	lprplp	sb|1,1		" reload lp from old frame.
	tra	bp|0		" goto label.

hard_way:	eax3	64,2		" adjust stack frame.
	anx3	=o777760,du
	stx3	sb|stack_header.stack_end_ptr+1
	eppbb	sb|0,qu		" old stack frame (old sp).
	stq	bb|8		" store args for use by do_jump after unwinding.
	spribp	bb|0
	eppbp	do_jump-*,ic	"'return' address from unwinder
	spribp	sb|2,2		" make label variable.
	spribb	sb|4,2		" part of label variable by PL/I standards.
	eppap	sb|8,2		" arglist for the unwinder.
	eppbp	sb|2,2		" the argument - the label variable.
	spribp	ap|2
	fld	=1b24,dl		" one arg, no descriptors.
	staq	ap|0		" put count in arglist.
	short_call	<unwinder_>|[unwinder_]
	arg	12345		" just in case unwinder_ returns.

do_jump:	lxl1	sp|8		" come here in right stack frame.
	lprplp	sb|1,1		" reload and jump.
	tra	sp|0,*

	segdef	Pl1Call		" Pl1Call (F, Arglist)
Pl1Call:	adlx1	bp|0
	sprpbp	sb|0,1		" save any registers needed later.
	sxl1	sp|8
	sprilp	sp|24
	lprpbp	sb|2,1		" Pick up routine address
	lprpap	sb|3,1		" and argument list pointer.
	tsplp	sb|stack_header.call_op_ptr,*
	lxl1	sp|8		" Restore and return.
	lprpbp	sb|0,1
	sblx1	bp|0
	lprplp	sb|1,1
	tra	bp|1

	segdef	Bcall		" Bcall (F, n, (list X1, ..., Xn)) = F (X1, ..., Xn).
Bcall:	adlx1	bp|0		" more like the regular BCPL save sequence.
	sprpbp	sb|0,1		" save return address.
	getlp			" find linkage section.
	sprplp	sb|1,1		" save its address too.
	eax2	2048,1		" adjust stack frame for adequate room.
	anx2	=o777760,du
	stx2	sb|stack_header.stack_end_ptr+1
	lprpap	sb|4,1		" arg list address.
	eppbp	sb|8,1		" address of first arg for BCPL call.
	lxl6	sb|3,1		" arg count.
	sxl6	lp|nargs		" initialize arg count for NumbArgs.
cloop:	sbx6	1,du		" copy arguments into stack.
	tmi	doit-*,ic
	ldq	ap|0,6
	stq	bp|0,6
	tra	cloop-*,ic
doit:	lprpap	sb|2,1		" routine address.
	tra	lp|realcall	" put call and its data word in static section.

	use	linklc
	join	/link/linklc

realcall:	tspbp	ap|0		" make the call from here.
nargs:	zero	6,12345
	lprpbp	sb|0,1		" restore and return.
	sblx1	bp|0
	lprplp	sb|1,1
	tra	bp|1



	use	textc		" back to text section.

	include	stack_header	" Get declaration of stack_header.stack_end_ptr.

	end




		    bcpl_stream_io_.bcpl            04/22/82  1623.2rew 04/22/82  1125.2      175473



//  BCPL stream I/O routines.
//  Last modified on 06/03/74 at 11:50:07 by R F Mabee.
//  Reinstalled with no material change in June 1974, R F Mabee.
//  Modified for 6180 bootstrap and installed in June 1973, R F Mabee.
//  First installed in September 1971 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"

external
     $(	GetWdir = "get_wdir_"		//  call get_wdir_ (return working dir name)
	FindIncludeFile = "find_include_file_$initiate_count" // call find_include_file_$initiate_count (caller name,
					//  ref ptr, search name, return bit count, return ptr, return code)

	MsfManagerOpen = "msf_manager_$open"	// call msf_manager_$open (dir name, entry name, return fcb ptr,
					//	return code)
	MsfManagerGetPtr = "msf_manager_$get_ptr" // call msf_manager_$get_ptr (fcb ptr, component, create_sw,
					//	return segment pointer, return bit count, return code)
	MsfManagerAdjust = "msf_manager_$adjust" // call msf_manager_$adjust (fcb ptr, component, bit count,
					//	flags, return code)
	MsfManagerClose = "msf_manager_$close"	//  call msf_manager_$close (fcb ptr)

	ReadPtr = "ios_$read_ptr"		//  call ios_$read_ptr (buffer ptr, buffer length, return line length)
	WritePtr = "ios_$write_ptr"		//  call ios_$write_ptr (buffer ptr, character offset, length)
	IosRead = "ios_$read"		//  call ios_$read (stream name, buffer ptr, character offset,
					//	buffer length, return line length, return status bits)
	IosWrite = "ios_$write"		//  call ios_$write (stream name, buffer ptr, character offset,
					//	length, return length, return status bits)
	IosResetread = "ios_$resetread"	//  call ios_$resetread (stream name, return status bits)
	GetAtEntry = "get_at_entry_"		//  call get_at_entry_ (stream name, return type,
					//	return ioname 2, return mode, return code)

	SegKnown = "error_table_$segknown"	//  declare error_table_$segknown fixed binary external static;
	ZeroLenSeg = "error_table_$zero_length_seg" // declare error_table_$zero_length_seg fixed binary external static;
	DirSeg = "error_table_$dirseg"	//  declare error_table_$dirseg fixed binary external static;
	NoEntry = "error_table_$noentry"	//  declare error_table_$noentry fixed binary external static;

	MaxSegSize = "sys_info$max_seg_size"	//  declare sys_info$max_seg_size fixed binary external static;
     $)
static
    $(	In = 0; Out = 0			//  Saved console streams.
	Freelist = 0			//  Chain of ten-word free blocks.
	Bufferlist = 0			//  Chain of free stream buffers
	Zero = 0; One = 1; Eleven = 11	//  Constants for Multics calls.
     $)
manifest
     $(	RwaBits = Read | Write | Append
	TypeBits = Pointer | Console | StreamName | PathName | EntryName | SearchName
	MsfBits = MultiSegmentFile
     $)


let Open (Options, Name, Length, Delimiter) = valof	//  Return pointer to ten-word block representing a stream.
		//  Options consists of one of
		//	{ Read Write Append }
		//  plus one of
		//	{ Console StreamName Pointer PathName EntryName SearchName }
		//  plus possibly MultiSegmentFile.
		//
		//  These are manifest constants defined in head.bcpl.  There are no defined defaults.  Read and
		//  Write are self-explanatory.  A stream can not be used for both input and output.  Append is
		//  similar to Write except that output is appended to that which already exists rather than
		//  replacing it.  This makes no difference for Console or StreamName output.
		//
		//  Console implies Multics stream I/O on the streams user_input and user_output.
		//  StreamName specifies Multics stream I/O on the stream Name, which is assumed to be already
		//  attached.  Length is the length of the buffer to be used; default is 200 characters.
		//
		//  Pointer indicates that "Name" is actually a pointer to a segment or vector to be read
		//  from or written into.  With Read and Write Length is the maximum length; default is a full
		//  segment.  With Append Length is the current length; default is 0.
		//
		//  PathName indicates that Name is a relative path name to the segment to be read or written.
		//  With Write Length is the maximum length; default is a full segment.  With Read or Append
		//  Length is the current length; default is the bit count / 9.
		//
		//  EntryName is similar to PathName except that Name is not expanded; the named segment is
		//  found or created (for Write and Append) in the current working directory.
		//
		//  SearchName indicates that Name is the entry name of a segment to be located by a standard
		//  search through several directories; the segment must exist.  "Length" is then actually a
		//  stream which provides a "referencing dir" for the search rules.
		//
		//  MultiSegmentFile applies only with PathName, EntryName, or SearchName; it indicates that the file
		//  may already be an MSF or may grow to be one.
		//
		//  Delimiter applies only with StreamName and Write or Append.
		//  It is the output delimiter character (the default is '*n').
		//  If it is zero the buffer is written out only when it is full or Writeout is called.
		//  
		//  The format of the stream block:
		//	Nextch, Maxch, Bufflen, Options, Refill, Name, Bufferptr, MSFcount, MSFfcb
		//
		//  Nextch is the offset within the buffer to the next character position.
		//
		//  Maxch is the length of the buffer for Write and Append.  For Read it is the length of the
		//  current line and the buffer length is stored in Bufflen.
		//  For Write and Append Bufflen is used for the delimiter which, if non-zero, is the
		//  character which causes the current buffer to be written out.  It is set to '*n' for Console
		//  and StreamName, otherwise zero.
		//
		//  Options is a copy of the argument to the call to Open which created this stream.
		//
		//  Refill is the address of a routine to be called when the buffer must be written out or
		//  refilled.  If it is zero, the buffer cannot be written out or refilled.
		//
		//  Name is a copy of the argument to Open, except for Console, when it is either "user_input"
		//  or "user_output".
		//
		//  Bufferptr is a pointer to the buffer, or for Pointer, PathName, EntryName, and SearchName it
		//  points directly to the segment referenced by the stream.
		//
		//  MSFcount is the index of the current segment in an MSF.
		//
		//  MSFfcb is the File Control Block for msf_manager_.


     $(	let Rwa, Type, Msf = Options & RwaBits, Options & TypeBits, Options & MsfBits
	Errcode := 0
	if Type = Console test Rwa = Read	//  Special case the two most common streams. All console input
	then $(	if In = 0 do		//  goes through the same stream block, and similarly for output.
		     $(	let f = Allocate (10)
			f!2, f!3, f!4 := 400 * 4, Console + Read, ConsoleRead
			f!5, f!6, f!7, f!8 := "user_input", Allocate (400), 0, 0
			In := f
		     $)
		In!0, In!1 := 0, 0		//  Throw away partial line left from previous use.
		resultis In
	     $)
	or   $(	if Out = 0 do
		     $(	let f = Allocate (10)
			f!1, f!2, f!3, f!4 := 100 * 4, '*n', Console + Write, ConsoleWrite
			f!5, f!6, f!7, f!8 := "user_output", Allocate (100), 0, 0
			Out := f
		     $)
		Out!0 := 0		//  Throw away partial line.
		resultis Out
	     $)
	let f = Freelist			//  Chain of free stream blocks.
	test f = 0
	then f := Allocate (10)
	or Freelist := f!0			//  Pop chain.
	let Buffer = nil
	let Nargs = NumbArgs ()
	f!0, f!1, f!2, f!3, f!4, f!5, f!6, f!7, f!8 := 0, 0, 0, Options, 0, Name, Null, 0, 0
	test Type = StreamName
	then $(	if Nargs < 3 | Length le 0 do Length := 200
		let p, q = Bufferlist, lv Bufferlist
		until p = 0 do			//  Look for free buffer of exactly the right length.
		     $(	if p!1 = Length do		//  User probably keeps reusing same length,
			     $(	Buffer := p	//  so we never fragment these blocks.
				q!0 := p!0
				goto Gotbuf
			     $)
			q := p
			p := p!0
		     $)
		Buffer := Allocate (Length / 4 + 10)	//  Allow space in Buffer for copy of Name.
	Gotbuf:	for i = 0 to 8 do Buffer!i := Name!i	//  Make copy so caller can release his copy.
		f!5 := Buffer
		Buffer := Buffer + 9
		if Nargs < 4 do Delimiter := '*n'
		test Rwa = Read
		then f!2, f!4 := Length, StreamRead
		or f!1, f!2, f!4 := Length, Delimiter, StreamWrite
		let x, y, z = nil, nil, nil
		call GetAtEntry (Name string, lv x char 0, lv y char 0, lv z char 0, lv Errcode bit 36)
					//  Verify that attachment exists (user may check Errcode.)
	     $)
		//  Otherwise it must be file I/O in some form.
	or   $(	test Type = Pointer
		then $(	Buffer := Name
			if Nargs < 3 do Length := rv MaxSegSize * 4
		     $)
		or   $(	let Dir, Ent, Path = vec 42, vec 8, vec 42
			let Rlen = 0
			unless Msf = 0 do f!4 := MsfNextSeg
			test Type = PathName
			then ExpandPathname (Name, Path)
			or test Type = EntryName
			then $(	MakePl1String (Name, Ent, 32)
				call GetWdir (Dir char 168)
				JoinPathname (Dir, Ent, Path)
			     $)
			//  Otherwise it must be SearchName.
			or   $(	let ReferencingSeg = Nargs < 3 | Length = 0 -> Null, Length!6
				Nargs := 2		//  Since Length is really something else.
				let v, w = vec 2, vec 2
				call FindIncludeFile (ProgramID string, ITS (ReferencingSeg, v) pointer,
							Name string, lv Rlen, w pointer, lv Errcode bit 36)
				if Errcode = 0 do GetPathname (BCPLaddr (w), Path)
			     $)
			unless Errcode = 0 resultis f
			Buffer := FindSegment (Path, lv Rlen)
			if Errcode ne 0 then if Msf ne 0 & Errcode = rv DirSeg do
			     $(	SplitPathname (Path, Dir, Ent)
				MsfOpen (f, Path)
				unless Errcode = 0 resultis f
				Buffer := MsfGetseg (f, Rwa = Append -> Rlen - 1, 0, lv Rlen)
			     $)
			test Rwa = Read
			then if Rlen = 0 & Errcode = 0 do Errcode := rv ZeroLenSeg
			or test Buffer = Null
			   then Buffer := MakeSegment (Path)		//  Create output segment if necessary.
			   or if Rwa = Write do SetBitCount (Buffer, 0)	//  Truncate segment for faster writing.

			Rlen := Rlen / 9		//  Character count (from Findseg).
			if Nargs < 3 do Length := Rwa = Write -> rv MaxSegSize * 4, Rlen
			if Rwa = Append & Msf ne 0 & Length ge rv MaxSegSize * 4 do
			     $(	if f!8 = 0 do MsfOpen (f, Path)
				unless Errcode = 0 resultis f
				Buffer := MsfGetseg (f, Length / (rv MaxSegSize * 4), lv Rlen)
				Length := Length rem (rv MaxSegSize * 4)
			     $)
		     $)
		test Rwa = Append
		then f!0, f!1 := Length, rv MaxSegSize * 4
		or f!1 := Length
	     $)
	f!6 := Buffer
	resultis f
     $)

and ConsoleRead (f) be			//  Routine to refill buffer from user_input.
     $(	unless Out = 0 | Out!0 = 0 do ConsoleWrite (Out)	//  Write out partial output line before waiting for input.
	let w = vec 2
	call ReadPtr (ITS (f!6, w) pointer, lv f!2, lv f!1)
	f!0 := 0
     $)
and ConsoleWrite (f) be			//  Routine to write out buffer to user_output.
     $(	let w = vec 2
	call WritePtr (ITS (f!6, w) pointer, lv Zero, lv f!0)
	f!0 := 0
     $)
and StreamRead (f) be			//  Routine to refill buffer from arbitrary Multics stream.
     $(	f!1 := 0
	let w = vec 2
	call IosRead (f!5 string, ITS (f!6, w) pointer, lv Zero, lv f!2, lv f!1, lv Errcode bit 72)
	if f!1 = 0 do f!1, rv (f!6) := 1, Endofstreamch lshift 27	//  Stream not attached or at end of file.
	f!0 := 0
     $)
and StreamWrite (f) be			//  Routine to write buffer to Multics stream.
     $(	let w, x = vec 2, nil
	call IosWrite (f!5 string, ITS (f!6, w) pointer, lv Zero, lv f!0, lv x, lv Errcode bit 72)
	f!0 := 0
     $)
and MsfNextSeg (f) be		//  Routine to get next segment of multi-segment file stream.
     $(	let Rwa = f!3 & RwaBits
	let p, l = f!6, 0
	if f!8 = 0 do
	     $(	if Rwa = Read goto NoGood
		let Path = vec 50
		GetPathname (p, Path)
		unless Errcode = 0 goto NoGood
		MsfOpen (f, Path)
		unless Errcode = 0 goto NoGood
	     $)
	unless Rwa = Read do SetBitCount (p, f!0 * 9)
	f!7 := f!7 + 1
	p := MsfGetseg (f, f!7, lv l)
	unless Errcode = 0 goto NoGood
	f!0 := 0
	test Rwa = Read
	then f!1 := l / 9
	or SetBitCount (p, 0)
	return
  NoGood:	f!4 := 0
     $)
and MsfOpen (f, Path) be		//  Make a stream into a multi-segment file.
     $(	let v, Dir, Ent = vec 2, vec 48, vec 8
	SplitPathname (Path, Dir, Ent)
	call MsfManagerOpen (Dir char 168, Ent char 32, v pointer, lv Errcode bit 36)
	if Errcode ne 0 then if Errcode = rv NoEntry & (f!3 & RwaBits) ne Read do Errcode := 0
	f!8 := BCPLaddr (v)
     $)
and MsfGetseg (f, n, LvL) = valof		//  Get pointer to n'th segment of a multi-segment file.
     $(	let v, w = vec 2, vec 2
	let Createsw = (f!3 & RwaBits) = Read -> 0, 1 lshift 35
	call MsfManagerGetPtr (ITS (f!8, v) pointer, lv n, lv Createsw bit 1, w pointer, LvL, lv Errcode bit 36)
	if Errcode ne 0 then if Errcode = rv SegKnown do Errcode := 0
		let p = BCPLaddr (w)
	f!6, f!7 := p, n
	resultis p
     $)

let Writeout (f) be				//  Write out contents of buffer.
	unless f!0 = 0 | f!4 = 0 do (f!4) (f)
and Flushinput (f) be			//  Discard unprocessed contents of buffer & delete read ahead.
     $(	let Rwa, Type = f!3 & RwaBits, f!3 & TypeBits
	if Rwa = Read & (Type = Console | Type = StreamName) do
	     $(	call IosResetread (f!5 string, lv Errcode bit 72)
		f!0, f!1 := 0, 0
	     $)
     $)
and ResetStream (f, Offset) be		//  Back up current working point in stream.
     $(	if NumbArgs () = 1 do Offset := 0
	Errcode := 0
	let Type, Rwa, p = f!3 & TypeBits, f!3 & RwaBits, f!6
	if Type = PathName | Type = EntryName | Type = SearchName do
	     $(		let l, n = nil, Offset / (rv MaxSegSize * 4)
		Offset := Offset rem (rv MaxSegSize * 4)
		unless f!8 = 0 | n = f!7 do
		     $(	p := MsfGetseg (f, n, lv l)
			if Rwa = Read do f!1 := l / 9
		     $)
		unless Rwa = Read do SetBitCount (p, (Offset + 3) * ByteSize)
	     $)
	f!0 := Offset
     $)
and StreamPointer (Stream) = Stream!6
and StreamOffset (Stream) = Stream!0 + Stream!7 * rv MaxSegSize * 4
and StreamLength (Stream) = Stream!1

let Close (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) be
					//  Release stream block. Write out buffer or set bit count as necessary.
   for i = 0 to NumbArgs () - 1 do		//  Walk argument list.
     $(	let f = (lv a)!i
	let Rwa, Type = f!3 & RwaBits, f!3 & TypeBits
	switchon Type into
	     $(	case Console:		//  Common stream block should not be released.
			test Rwa = Read
			then f!0, f!1 := 0, 0	//  Discard unwanted input line.
			or Writeout (f)
			loop
		case StreamName:
			let l = nil
			test Rwa = Read
			then l := f!2
			or   $(	Writeout (f)
				l := f!1
			     $)
			let p = f!5	//  Original buffer area (I hope).
			p!0, p!1 := Bufferlist, l
			Bufferlist := p
			endcase
		case PathName:
		case EntryName:
		case SearchName:
			let p, BitCount = f!6, f!0 * 9
			unless Rwa = Read do SetBitCount (p, BitCount)
			test f!8 = 0
			then $(	Terminate (p)	//  Free segment number unless otherwise in use.
				if Type = SearchName do Terminate (p)	//  Got initiated twice at open.
			     $)
			or   $(	let v = vec 2
				ITS (f!8, v)
				unless Rwa = Read call MsfManagerAdjust (v pointer, lv f!7, lv BitCount,
								     lv Zero bit 3, lv Errcode bit 36)
				call MsfManagerClose (v pointer)
			     $)
			endcase
		default:	loop		//  Already closed or isn't a stream or Type = Pointer.
	     $)
	for i = 1 to 8 do f!i := 0
	f!0 := Freelist
	Freelist := f
     $)

let WriteS (f, s) be			//  Write a string.
     $(	if NumbArgs () = 1 do
	     $(	s := f
		f := OUTPUT
	     $)
	let c, l = 0, Length (s)		//  Current offset, remaining length.
	if l = 0 return
	     $(	let r = f!0		//  Current offset in output buffer.
		let n = f!1 - r		//  Remaining space.
		if n > l do n := l
		MoveBits (f!6, r * ByteSize, s, c * ByteSize + CountSize, n * ByteSize)
		f!0 := f!0 + n
		c := c + n
		l := l - n
		if l = 0 break
		Writeout (f)
	     $)	repeat
	if Subch (s, c) = f!2 ne 0 do Writeout (f)	//  Write out buffer ending with delimiter.
     $)

let WriteN (f, n) be			//  Write out a number in decimal.
     $(	if NumbArgs () = 1 do
	     $(	n := f
		f := OUTPUT
	     $)
	let w = vec 20
	WriteS (f, ConvertNtoS (n, w))
     $)

let Format (Stream, Control, a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y,
		         A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U, V, W, X, Y) be
		//  Control string is written out with additional arguments substituted for control codes.
     $(	let Space = vec 500
	ProcessFormatString (Control, lv a, Space, 500 * WordSize / ByteSize)
	WriteS (Stream, Space)
     $)
and FormatString (Space, MaxLen, Control, a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y,
				  A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U, V, W, X, Y) be
	ProcessFormatString (Control, lv a, Space, MaxLen)

and ProcessFormatString (Control, p, Space, MaxLen) be
     $(	let n = Length (Control)
	let u, v, w = vec 400, vec 100, vec 100
	and j = 0
	SetLength (Space, 0)
	for i = 1 to n do
	     $(	if j > 100 do
		     $(	u!0 := j
			Packstring (u, v)
			Concatenate (Space, MaxLen, Space, v)
			j := 0
		     $)
		let c = Subch (Control, i)
		if c ne '^' | i ge n do
		     $(	j := j + 1
			u!j := c
			loop
		     $)
		let Width, Digits = 0, 0
		     $(	i := i + 1
			c := Subch (Control, i)
			unless '0' le c le '9' break
			Width := Width * 10 + c - '0'
		     $)	repeat
		if c = '.' do
		     $(	i := i + 1
			c := Subch (Control, i)
			unless '0' le c le '9' break
			Digits := Digits * 10 + c - '0'
		     $)	repeat
		Width, Digits := MinI (Width, 200), MinI (Digits, 200)
		if c = '^' do
		     $(	j := j + 1
			u!j := '^'
			loop
		     $)
		let Val = ProcessItem (c, rv p, Digits, w)
		p := lv p!1
		let Len = Length (Val)
		for k = 1 to Len if Subch (Val, k) = '*b' do Len := Len - 2
		for k = Len + 1 to Width do
		     $(	j := j + 1
			u!j := '*s'
		     $)
		u!0 := j
		Packstring (u, v)
		Concatenate (Space, MaxLen, Space, v, Val)
		j := 0
	     $)
	if j ne 0 do
	     $(	u!0 := j
		Packstring (u, v)
		Concatenate (Space, MaxLen, Space, v)
	     $)
     $)
and ProcessItem (c, x, Digits, Space) = valof
     $(	let v = vec 100
	switchon c into
	     $(	case 'a': case 's':
			if Length (x) ge Digits resultis x
			CopyString (x, Space)
			Concatenate (Space, 400, Space, " ") repeatwhile Length (Space) < Digits
			resultis Space

		case 'p':	test (x rshift 30) = 0
			then FormatString (Space, 100, "^o|^o", (x rshift 18) & $87777, x & $8777777)
			or FormatString (Space, 100, "^o|^o(^2.2d)", (x rshift 18) & $87777, x & $8777777, x rshift 30)
			resultis Space

		case 'b':	resultis x -> "true", "false"

		case 'c':	if Digits = 0 do Digits := 1
			for i = Digits to 1 by -1 do
			     $(	v!i := x
				x := x rshift ByteSize
			    $)
			v!0 := Digits
			Packstring (v, Space)
			resultis Space

		case 'd':
		case 'n':	ConvertNtoS (x, Space, -10, Digits)	//  -10 requests signed conversion.
			resultis Space

		case 'w':	if Digits = 0 do Digits := 12
			ConvertNtoS (x, Space, 8, Digits)	//  Request unsigned conversion.
			resultis Space

		case 'o':	ConvertNtoS (x, Space, -8, Digits)	//  Request signed conversion.
			resultis Space

		case 'f':	if Digits = 0 do Digits := 5
			ConvertFtoS (x, Space, Digits)
			resultis Space

		default:	v!0, v!1 := 1, c
			Packstring (v, Space)
	     $)
	resultis Space
     $)




		    bcpl_strings_.bcpl              04/22/82  1623.2rew 04/22/82  1125.2       56628



//  Routines to manipulate strings for BCPL programs.
//  Last modified on 06/06/74 at 15:36:39 by R F Mabee.
//  Reinstalled with no material change in June 1974 by R F Mabee.
//  Modifications for 6180 conversion installed in June 1973 by R F Mabee.
//  First installed as bcpl_lib_ on 645 Multics in September 1971 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"

manifest
     $(	FirstCharsMask = true rshift CountSize	  //  Mask for characters in first word of string.
	BlankWord = '*s*s*s*s'
     $)

let Length (String) = String!0 rshift (WordSize - CountSize)	//  Return length in characters.
and SetLength (String, Len) = valof			//  Fix length of BCPL string.
     $(	String!0 := String!0 & FirstCharsMask | Len lshift (WordSize - CountSize)
	let Nbits = Len * ByteSize + CountSize
	let Nwords = (Nbits + WordSize - 1) / WordSize
	String!(Nwords - 1) := String!(Nwords - 1) & not (true rshift ((Nbits - 1) rem WordSize + 1))
	resultis String
     $)
and LengthInWords (String) = 			//  Return length of string in words.
	(Length (String) * ByteSize + CountSize + WordSize - 1) / WordSize

let EqualString (s, t) = valof		//  Compare two strings.  Returns true if identical, otherwise false.
     $(	if s = t resultis true		//  Easy case.
	for i = 0 to LengthInWords (s) - 1 unless s!i = t!i resultis false
	resultis true
     $)
and CompareStrings (s, t) = valof	//  Compare two strings.  Returns 0 for s = t, 1 or 2 for s > t, -1 or -2 for s < t.
				//  1 or -1 means difference is only in case bits, 2 or -2 other difference.
     $(	if EqualString (s, t) resultis 0
	let a, b = Length (s), Length (t)
	let Case = 0
	for i = 1 to MinI (a, b) do
	     $(	let c, d = Subch (s, i), Subch (t, i)
		if c = d loop
		if 'a' le c le 'z' do c := c - 'a' + 'A'
		if 'a' le d le 'z' do d := d - 'a' + 'A'
		unless c = d resultis c < d -> -2, 2		//  A significant difference.
		if Case = 0 do Case := Subch (s, i) < Subch (t, i) -> -1, 1
	     $)
	unless a = b resultis a < b -> -2, 2
	resultis Case
     $)

let CopyString (String, Space) be			//  Copy a BCPL string.
	Move (Space, String, LengthInWords (String))

let StringToChar (s) = valof
     $(	let C = 0
	for i = 1 to Length (s, i) do C := C lshift ByteSize logor Subch (s, i)
	resultis C
     $)
and CharToString (Ch, Space) = valof
     $(	for Len = ByteSize to WordSize by ByteSize if (Ch rshift Len) = 0 do		//  Skip unused bytes.
	     $(	MoveBits (Space, CountSize, lv Ch, WordSize - Len, Len)
		resultis SetLength (Space, Len / ByteSize)
	     $)
     $)

let Concatenate (Space, MaxLen, a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) = valof
						//  Concatenate any number of BCPL strings.
     $(	let n = Length (a)
	unless a = Space do CopyString (a, Space)	//  Special-case first string for Concatenate (v, ., v, ...).
	for i = 1 to NumbArgs () - 3 do
	     $(	let p = (lv a)!i			//  p is i'th string arg.
		let l = Length (p)
		if n + l ge MaxLen do l := MaxLen - n
		MoveBits (Space, n * ByteSize + CountSize, p, CountSize, l * ByteSize)
		n := n + l
	     $)
	resultis SetLength (Space, n)
     $)

let Substr (Space, String, First, Count) = valof		//  Like PL/I substr, but requires space for result.
     $(	let l = Length (String) - First + 1		//  Max or default length of substring.
	if NumbArgs () < 4 | Count > l do Count := l
	if Count < 0 do Count := 0
	MoveBits (Space, CountSize, String, (First - 1) * ByteSize + CountSize, Count * ByteSize)
	resultis SetLength (Space, Count)
     $)

let IndexCh (String, Ch) =				//  Return i such that i'th character of String is Ch.
	ScanChar (String, CountSize / ByteSize, Length (String), Ch) + 1
let Index (String, Pattern) = valof			//  Just like the PL/I index built-in function.
     $(	let l = Length (Pattern)
	if l = 0 resultis 0				//  Define weird case.
	let Ch = Subch (Pattern, 1)			//  First character to look for.
	let n = Length (String) - l + 1		//  Number of characters worth looking at.
	let b = 0
	while b < n do
	     $(	let p = ScanChar (String, b + CountSize / ByteSize, n - b, Ch)	//  Find next instance of Ch.
		if p < 0 break			//  Not there.
		b := b + p + 1
		for i = 2 to l do			//  Check for rest of string.
			unless Subch (String, b + i - 1) = Subch (Pattern, i) goto Nomatch
		resultis b
	Nomatch:
	     $)
	resultis 0
     $)

let Pad (Space, From, Len) be			//  Pad a string with blanks.
     $(	let Fp, Lp = From - From rem 4, Len - Len rem 4
	let Blanks = BlankWord
	unless Fp = From do
	     $(	Fp := Fp + 4
		MoveBits (Space, From * ByteSize, lv Blanks, 0, (MinI (Fp, Len) - From) * ByteSize)
	     $)
	while Fp < Lp do
	     $(	Space!(Fp / 4) := BlankWord
		Fp := Fp + 4
	     $)
	unless Lp = Len | Fp > Lp do MoveBits (Space, Lp * ByteSize, lv Blanks, 0, (Len - Lp) * ByteSize)
     $)
and LastNonBlank (Space, Len) = valof
     $(	let Lp = Len - Len rem 4
	let c = 0
	while Len > Lp do
	     $(	Len := Len - 1
		MoveBits (lv c, WordSize - ByteSize, Space, Len * ByteSize, ByteSize)		//  Grab last character.
		unless c = '*s' resultis Len + 1
	     $)
	while Len > 0 do
	     $(	unless Space!(Len / 4 - 1) = BlankWord break
		Len := Len - 4
	     $)
	while Len > 0 do
	     $(	Len := Len - 1
		MoveBits (lv c, WordSize - ByteSize, Space, Len * ByteSize, ByteSize)
		unless c = '*s' resultis Len + 1
	     $)
	resultis Len
     $)

let MakePl1String (BcplString, Space, Len) = valof	//  Make a PL/I-style aligned string padded to length.
     $(	let l = Length (BcplString)
	if l > Len do l := Len
	MoveBits (Space, 0, BcplString, CountSize, l * ByteSize)
	if Len > l do Pad (Space, l, Len)
	resultis Space
     $)
let MakeBcplString (Pl1String, Len, Space) = valof	//  Convert aligned PL/I string back to BCPL format.
     $(	Len := LastNonBlank (Pl1String, Len)		//  Strip off trailing blanks.
	MoveBits (Space, CountSize, Pl1String, 0, Len * ByteSize)
	resultis SetLength (Space, Len)
     $)




		    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
