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 |[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_] 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