!Revision history ! 8-Jul-87 PSR INT was using the wrong instruction format to add the 0.5 ! - Readsymbol etc weren't hazarding registers %routine Apply Trunc(%record(Stackfm)%name V) %integer R %return %unless Floating(V) Load(V, AnyF); Release(V_Base) R = GPR Plant7(FIX ! 2_11<<5, 0, R, V_Base) {round to zero} V_Type = Integers; V_Base = R; Claim(R) %end %routine Convert Function(%integer Op, %record(Stackfm)%name V) %return %unless Floating(V) Load(V, F0); Release(F0) Prim(Op) V_Type = Integers; V_Base = R0; Claim(R0) %end %routine Apply Round(%record(Stackfm)%name V) Convert Function(Real Round, V) %end %routine Apply Intpt(%record(Stackfm)%name V) %integer R %return %unless Floating(V) Load(V, AnyF); Release(V_Base) R = GPR Plant7(FIX ! 2_10<<5, 0, R, V_Base) {round to minus infinity} V_Type = Integers; V_Base = R; Claim(R) %end %routine Apply Int(%record(Stackfm)%name V) %integer R %return %unless Floating(V) Load(V, AnyF); Release(V_Base) Plant9(ADF ! Small Constant, V_Base, V_Base, 6) {add 0.5} R = GPR Plant7(FIX ! 2_10<<5, 0, R, V_Base) {round to minus infinity} V_Type = Integers; V_Base = R; Claim(R) %end %routine X Define(%integername Ep, %string(63) Text, %integer P) %record(Varfm) C = 0 %if Ep = 0 %start External Id = Text %if P = 0 %start {data} Dump External(2_00, C) Ep = C_Area %else C_Form = Proc Dump External(2_10, C) Ep = C_Disp %finish %finish %end %routine Stack Register(%integer R) %record(Stackfm)%name X == Literal(0) X_Base = R; Claim(R) X_Stack == Stack; Stack == X %end %routine Do(%string(31) Ident, %integername Ep, %integer Result) X Define(Ep, Ident, 1) X Call(Ep, Result, 1) %end %routine Do Conditional External(%integer CC, %string(31) Ident, %integername Ep) %integer Label X Define(Ep, Ident, 1) Hazard All %if Active Registers # 0 %if CC # Always %start Label = New Label Jump To(Label, Negated(CC)) %finish X Call(Ep, 0, 0) Define Label(Label) %if CC # Always %end %routine Special Call(%integer N) %record(Stackfm)%name V == Stack, X, Y, Z %owninteger Readch Ep = 0, Iread = 0, Rread = 0, Sread = 0, Nextch Ep = 0 %integer Type %constinteger Max Special = 59 %switch Sp(1:Max Special) %constbytearray Type Map(3:9) = Strings, Integers, Shorts, Bytes, Reals, Lreals, Records %constbytearray Len Map(3:9) = 0, 4, 2, 1, 4, 8, 0 ->Sp(N) %if 0 < N <= Max Special Sp(*): Fail("Bad primitive") %routine Psym(%record(Stackfm)%name Char) %owninteger Printsymbol Ep = 0 Load(Char, R0); Release and Drop(Char) Prim(Psymbol) Forget Everything %end %routine Do Printstring %owninteger Printstring Ep = 0 %record(Stackfm)%name S, V == Stack Stack == Stack_Stack {pop the string} %cycle S == V; V == S_Link; S_Oper = 0; S_Link == Nil %if S_Type <= Addrs %start Psym(S) %else %if S_Bias = 1 {null} Release and Drop(S) %else Amap(S); Load(S, R0) Release and Drop(S) Do("3L_IMP_PRINT_STRING", Printstring Ep, 0) %finish %repeat %until V == Nil %end %routine Load External Variable(%string(63) Id, %integername Ep) %record(Stackfm)%name V %record(Varfm) X %if Ep = 0 %start X_Form = 0 External Id = Id; Dump External(0, X) Ep = -X_Area %finish Hazard(R1) Dir3(Dir Spec Load, Actual(R1), Ep) Refs = Refs+1; Ca = Ca+4 Attributes = Attributes ! Attr Needs Gp %end %routine Do Input(%integer Fn) %record(Stackfm)%name R %owninteger In Scb = 0 Hazard All Load External Variable("3L___cur_in", In Scb) {LDR _ 1, IN___SCB} Forget Everything Dump Word(16_E4911000) {LDR _ R1, [R1]} Dump Word(16_E891001C) {LDM _ R1, } {R2 = Next} {R3 = Limit} {R4 = Buffer Handler} Dump Word(16_E1520003) {CMP _ R2, R3 } Prim(Enter P) {BLGE_ (R4) } %if Fn = 0 %start {nextsymbol } {don't advance} Dump Word(16_E4D24000) {LDRB_ R4, [R2] } %else {advance} Dump Word(16_E4D24001) {LDRB _ R4, [R2], #1! } Dump Word(16_E4012000) {STR _ R2, [R1] } %finish %if Fn >= 0 %start {readsymbol/nextsymbol} {give some result} R == Register(R4) R_Stack == Stack; Stack == R Assign(Equals) %if Fn = 1 {readsymbol} %finish %end Sp(1): Do Input( 1); %return {readsymbol} Sp(2): Do Input( 0); %return {nextsymbol} Sp(26): Do Input(-1); %return {skipsymbol} Sp(25): Stack == V_Stack; Psym(V); %return {Printsymbol} Sp(27): X == Literal(10); Psym(X); %return {Newline} Sp(28): X == Literal(32); Psym(X); %return {Space} Sp(24): Do Printstring; %return {Printstring} Sp(23): %if V_Type = Strings %start {Read(STRING)} Type = Strings X == Literal(Item Size(Stack_Format)-1) Amap(Stack); Load(Stack, R0) Load(X, R1); Release and Drop(X) Pop Release and Drop Do("3L_IMP___read_s", Sread, 0) %else %if Integers <= V_Type <= Addrs %start Type = Integers; Do("3L_IMP___read_i", Iread, R0) %else %if V_Type = Reals %or V_Type = Lreals Type = Lreals; Do("3L_IMP___read_r", Rread, F0) %else Warn(1, "Bad type of parameter for READ") Type = Integers %finish Stack_Type = Type Stack_Form = Direct %if Type = Strings Assign(Equals) %finish %return Sp(20): Amap(V); %return {addr} Sp(3): {string} Sp(4): {integer} Sp(5): {shortinteger, short} Sp(6): {byteinteger, byte} Sp(7): {real} Sp(8): {longreal, long} Sp(9): Vmap(V, Type Map(N)) {record} V_Format = Len Map(N) %return Sp(10): Float(Stack, FPR); %return {float} Sp(11): X == V_Stack; Stack == X_Stack {rem} Operate(REMx, V, X) V_Stack == Stack; Stack == V %return Sp(12): Advance(V, Bytes, 0) {length} %return Sp(13): X == V_Stack; Stack == X_Stack {charno - the index} Simplify(V) %if V_Index ## Nil V_Type = Bytes Apply Index(V, X, 1) V_Stack == Stack; Stack == V {stack the result} %return Sp(14): Stack Integer(Nl) {snl} Sp(15): Simplify(Stack) {tostring} %return Sp(16): Set Size or Type(1, V); %return {sizeof} Sp(17): Set Size or Type(2, V); %return {typeof} Sp(19): Apply Int(V); %return {int} Sp(18): Apply Intpt(V); %return {intpt} Sp(22): Apply Round(V); %return {round} Sp(21): Apply Trunc(V); %return {trunc} {=== Pascal items ===} %conststring({*}255) Fill Id = "3L_pascal___fill"; %owninteger Fill Ep = 0 %conststring({*}255) Ftxt Id = "3L_pascal___fill_text"; %owninteger Ftxt Ep = 0 %conststring({*}255) Safe Id = "3L_pascal___safe"; %owninteger Safe Ep = 0 %conststring({*}255) Empty Id = "3L_pascal___empty"; %owninteger Empty Ep = 0 %conststring({*}255) Eoln Id = "3L_pascal___eoln_error"; %owninteger Eoln Ep = 0 %conststring({*}255) Readln Id = "3L_pascal___read_ln"; %owninteger Readln Ep = 0 %conststring({*}255) WritelnId = "3L_pascal___write_ln"; %owninteger WritelnEp = 0 %conststring({*}255) WriteC Id = "3L_pascal___write_char"; %owninteger WriteC Ep = 0 %constinteger InLim Displacement = 0, Outlim Displacement = 4, Size Displacement = 8, EOF Displacement = 12, EOLN Displacement = 13 %routine Make Safe(%record(Stackfm)%name F, %integer EOF) %record(Stackfm)%name P, B, V2, V3 Simplify(F) Advance(F, Integers, 0) P == Copy(F) {Buffer Pointer} B == Copy(F); Advance(B, Integers, 4) {PFCB} %if B_Base >= 128 %or Activity(B_Base) < 0 %start {can remember} V2 == Copy(B) V3 == Copy(P) %else V2 == NIL V3 == NIL %finish Load(B, R2) P_Flags = P_Flags ! Known Ass; Load(P, R3) Vmap(B, Integers) Advance(B, Integers, InLim Displacement); B_Flags = B_Flags ! Known Ass Load(B, R4) Compare(P, B); Release and Drop Pair(P, B) {EOF # 0 implies that EOF is an error} %if EOF = 0 %then Do Conditional External(GT, Ftxt Id, Ftxt Ep) {-}%c %else Do Conditional External(GT, SAFE Id, SAFE Ep) F_Flags = F_Flags ! Known Ass %if V2 ## NIL %start {remember things} Remember(R2, V2) Remember(R3, V3) Release and Drop Pair(V2, V3) V2 == Register(R2); V2_Form = Direct Remember(R4, V2); Release and Drop(V2) %finish %end %routine Onto Boolean(%record(Stackfm)%name F, %integer Disp, Known) Advance(F, Integers, 4) {onto PFCB} F_Flags = F_Flags ! Known Load(F, R2) Vmap(F, Bytes); Advance(F, Bytes, Disp) F_Flags = F_Flags ! Known Ass %end %routine EOF(%record(Stackfm)%name F, %integer Text) Make Safe(F, 0) %if Text # 0 Onto Boolean(F, EOF Displacement, 0) %end %routine EOLN(%record(Stackfm)%name F) {EOLN must first test EOF as EOLN is invalid if EOF is true} Make Safe(F, 1) Onto Boolean(F, EOLN Displacement, Known Ass) %end !%prim(41)%routine P Get %alias"P_p_get"(%integername F) Sp(41): Stack == Stack_Stack Simplify(V) Advance(V, Integers, 0) X == Copy(V) Y == Copy(V); Load(Y, R3) {Buffer Pointer} Advance(V, Integers, 4); V_Flags = V_Flags ! Known Ass Load(V, R2) {PFCB} V_Form = Direct Z == Copy(V) Advance(V, Integers, Size Displacement); V_Flags = V_Flags ! Known Ass Operate(ADDx, Y, V) Advance(Z, Integers, InLim Displacement); Z_Flags = Z_Flags ! Known Ass Compare(Y, Z); Release and Drop Pair(Z, Y) Do Conditional External(GT, Fill Id, FILL Ep) Y == Register(R3); Simple(Y, X) Release and Drop Pair(X, Y) %return !%prim(42)%routine P Get Txt %alias"P_p_getx"(%integername F) Sp(42): Stack == Stack_Stack Make Safe(V, 1) Advance(V, Integers, 0) {Onto Buffer Pointer} Y == Register(R3) {loaded by MAKE SAFE} Operate(ADDx, Y, Literal(1)) Simple(Y, V) Release and Drop Pair(V, Y) %return !%prim(43)%integerfn P Safety %alias"P_p_safe"(%integername F) Sp(43): Stack == Stack_Stack Make Safe(V, 1) Release and Drop(V) V == Register(R3) V_Stack == Stack; Stack == V %return !%prim(44)%integerfn P ReadC %alias"P_p_rc"(%integername F) Sp(44): Stack == Stack_Stack Make Safe(V, 1) Y == Register(R3) X == Register(R1) Plant1(LDR ! Byte Op ! 16_0080 0000, R3, R1, 1) Simple(Y, V) Release and Drop Pair(V, Y) X_Stack == Stack; Stack == X %return !%prim(45)%routine P Readln %alias"P_p_rln"(%integername F) Sp(45): Stack == Stack_Stack Advance(V, Integers, 4) {onto PFCB} Load(V, R2) Release and Drop(V) Do(READLN Id, READLN Ep, 0) %return !%prim(46)%integerfn P Eoln %alias"P_p_eoln"(%integername F) Sp(46): EOLN(V) %return !%prim(47)%integerfn P Eof %alias"P_p_eof"(%integername F) Sp(47): EOF(V, 0); %return !%prim(48)%integerfn P Eof Txt %alias "P_p_eofx"(%integername F) Sp(48): EOF(V, 1); %return !%prim(49)%routine P Put %alias"P_p_put"(%integername F) Sp(49): Stack == Stack_Stack Simplify(V) Advance(V, Integers, 0) X == Copy(V) Y == Copy(V); Advance(Y, Integers, 4); Y_Flags = Y_Flags ! Known Ass Load(X, R3) Load(Y, R2) Y_Form = Direct; Y_Disp = OutLim Displacement Y_Flags = Y_Flags ! Known Ass Z == Copy(Y); Z_Disp = Size Displacement Operate(ADDx, X, Z); Load(X, R3) Compare(X, Y); Release and Drop Pair(Y, X) Do Conditional External(GE, EMPTY Id, EMPTY Ep) X == Register(R3) Simple(X, V) Release and Drop Pair(X, V) %return !%prim(50)%routine P Put Txt %alias"P_p_put"(%integername F) Sp(50): Stack == Stack_Stack Simplify(V) Advance(V, Integers, 0) X == Copy(V) Y == Copy(V); Advance(Y, Integers, 4); Y_Flags = Y_Flags ! Known Ass Load(X, R3) Load(Y, R2) Operate(ADDx, X, Literal(1)); Load(X, R3) Y_Form = Direct; Y_Disp = OutLim Displacement Y_Flags = Y_Flags ! Known Ass Compare(X, Y); Release and Drop Pair(Y, X) Do Conditional External(GE, EMPTY Id, EMPTY Ep) X == Register(R3) Simple(X, V) Release and Drop Pair(X, V) %return !%prim(51)%routine W Line %alias"P_p_line"(%integername F) Sp(51): Stack == Stack_Stack Advance(V, Integers, 4) Load(V, R2); Release and Drop(V) Do Conditional External(Always, Writeln Id, Writeln Ep) %return !%prim(52)%routine W Char %alias"P_p_wchr"(%integername F, %integer C, W) Sp(52): %begin %record(Stackfm)%name C, W, Bp, FCB, Z Simplify(V) C == V_Stack W == C_Stack Stack == W_Stack %if Iconst(W) %and W_Disp = 1 %start Release and Drop(W) Advance(V, Integers, 0) Bp == Copy(V) FCB == Copy(V); Advance(FCB, Integers, 4) Load(Bp, R3) FCB_Flags = FCB_Flags ! Known Ass Load(FCB, R2) Loadup(C); Plant1(STR ! Byte Op ! 16_0080 0000, R3, C_Base, 1) Release and Drop(C) FCB_Form = Direct; FCB_Disp = OutLim Displacement FCB_Flags = FCB_Flags ! Known Ass Compare(Bp, FCB); Release and Drop Pair(FCB, Bp) Do Conditional External(GT, EMPTY Id, EMPTY Ep) Bp == Register(R3) Simple(Bp, V) Release and Drop Pair(Bp, V) %else Load(W, R1) Load(C, R2) Amap(V); Load(V, R3) Release and Drop Pair(W, C) Release and Drop(V) Do(WRITEC Id, WRITEC Ep, 0) %finish %end %return !%prim(53)%routine Assoc Complete %alias"P_p_assc" Sp(53): %return {no need for Assoc complete on ARM - yet} %routine Do Real Fn(%integer Fn) %integer Reg Load(V, AnyF) Reg = Fpr; Claim(Reg) Plant9(Fn, 0, Reg, V_Base) Release(V_Base); V_Base = Reg %end Sp(54): !%prim(54)%longrealfn Sqrt(%longreal R) Do Real Fn(SQT); %return Sp(55): !%prim(55)%longrealfn Sin(%longreal R) Do Real Fn(SIN); %return Sp(56): !%prim(56)%longrealfn Cos(%longreal R) Do Real Fn(COS); %return Sp(57): !%prim(57)%longrealfn Ln(%longreal R) Do Real Fn(LGN); %return Sp(58): !%prim(58)%longrealfn Exp(%longreal R) Do Real Fn(EXP); %return Sp(59): !%prim(59)%longrealfn Arctan(%longreal R) Do Real Fn(ATN); %return %end %routine Call(%integer Tidy) {Tidy#0 if the caller is to remove parameters from the stack} %record(Stackfm)%name V, Temp, X, W %record(Stackfm) Work %integer Ep, Flags, Extra, Op, BaseReg V == Stack Stack == Stack_Stack Flags = V_Flags %if Flags&Primitive # 0 %start %while V_Params ## Nil %cycle V_Params_Stack == Stack Stack == V_Params V_Params == V_Params_Params %repeat Special Call(V_Prim) Drop(V) %return %finish BaseReg = R0 BaseReg = R1 %if Flags&Answer # 0 %and V_Flags&Defered = 0 %and (V_Type = Strings %or V_Type = Records) Pass Parameters(V, Extra, BaseReg) Hazard All %if Active Registers # 0 Assign Lock = 0 {no longer safe} Attributes = Attributes!Attr Dynamic Temp == Nil %if BaseReg = R1 %start {extra parameter for results} Temp == Claim Work Area(Item Size(V_Format), V_Type) Temp_Format = V_Format W == Copy(Temp) Amap(W); Load(W, R0) Release and Drop(W) %finish Ep = V_Disp %if Flags&Xproc Spec # 0 %start {external Call} %if Flags&Prim Proc # 0 %start Fail("XP-call") !!! Dir2(Dir xpCall, Ep); Ca = Ca+4; Refs = Refs+1 %else X Call(Ep, 0, 1) %finish %else %if Flags&Parameter # 0 %or V_Base # 0 %or V_Record ## Nil {procedure parameter call} W == Copy(V) W_Type = Integers; W_Form = Direct; W_Area = 0 Amap(W) Load(W, R4) Release and Drop(W) Prim(CallP) %else %if Flags&Prim Proc # 0 Fail("P-call") !!! Dir2(Dir pCall, Ep); Ca = Ca+4; Refs = Refs+1 %else {normal internal call} %if Flags&Nasty Proc # 0 %start {must pass an environment} Fail("No local display") %if Local Display = 0 X == Local Integer(Local Display) Load Address(X, R8) Release and Drop(X) %finish Dir2(Dir Call, Ep); Ca = Ca+4; Refs = Refs+1 %finish Pop Stack(Extra) %if Extra # 0 {restore the stack} Forget Everything %if Flags&Answer # 0 %start {set up result descriptor} %if Temp == Nil %start Temp == Literal(0) Temp_Type = V_Type Temp_Format = V_Format Temp_Base = R0 %if Flags&Defered # 0 %start {a map} Temp_Form = Direct Temp_Base = R0 %else %if Reals <= Temp_Type <= Lreals Temp_Base = F0; Temp_Type = Lreals %finish Claim(Temp_Base) %finish Temp_Stack == Stack; Stack == Temp %else %if Flags&Pred Call # 0 {a predicate} Plant1(TEQ, R0, 0, Nothing) {set CC} %finish Uncond Jump = Ca %if Flags&Closed # 0 Drop(V) %end %routine Prim(%integer N) %integer For, Reg, Par Fail("Prim ") %unless Signal <= N <= Last Prim Monitor(Nil, "Prim ".ItoS(N, 0)) %if Diag&MonOperate # 0 For = Corrupts(N) Par = Prim Parameter(N) Reg = R0 %while For # 0 %cycle %if For&1 # 0 %start {prim corrupts this register} %if Par&1 = 0 %start {it isn't a parameter} Hazard(Reg) %else {it is a parameter} Hazard(Reg) %if Activity(Reg) > 1 %finish Forget(Reg) {forget its value} %finish Reg = Reg+1 For = For>>1 Par = Par>>1 %repeat Dir2(Dir Prim, N); Ca = Ca+4; Refs = Refs+1 %end %endoffile