MODULESetupReflect();; IMPORT Text, TextRd, Rd, Lex, Fmt, ObLib, ObValue, SynLocation, TextConv, Thread, NetObj, Env, Params, Math, ObEval, ObjectSpace, FloatMode, SharedObj, SharedObjRT, ObValueNotify, Obliq, Time, SynWr, WorkerPool, Work; PROCEDURE ObBuiltIn Setup () = BEGIN SetupSys(); SetupBool(); SetupInt(); SetupReal(); (* after Int, so real_+ etc. have precedence *) SetupMath(); SetupAscii(); SetupText(); SetupArray(); SetupNet(); SetupReplica(); SetupThread();
END Setup;============
sys
package ============
TYPE SysCode = {Address, GetEnvVar, GetParamCount, GetParam, CallFailure, Call, Copy, TimeNow, TimeGrain}; SysOpCode = ObLib.OpCode OBJECT code: SysCode; END; PackageSys = ObLib.T OBJECT OVERRIDES Eval := EvalSys; END; PROCEDURE============NewSysOC (name : TEXT; arity : INTEGER; code : SysCode; fixity: ObLib.OpFixity := ObLib.OpFixity.Qualified): SysOpCode = BEGIN RETURN NEW(SysOpCode, name := name, arity := arity, code := code, fixity := fixity); END NewSysOC; PROCEDURESetupSys () = TYPE OpCodes = ARRAY OF ObLib.OpCode; VAR opCodes: REF OpCodes; BEGIN opCodes := NEW(REF OpCodes, NUMBER(SysCode)); opCodes^ := OpCodes{NewSysOC("address", -1, SysCode.Address), NewSysOC("getEnvVar", 1, SysCode.GetEnvVar), NewSysOC("paramCount", -1, SysCode.GetParamCount), NewSysOC("getParam", 1, SysCode.GetParam), NewSysOC("callFailure", -1, SysCode.CallFailure), NewSysOC("call", 2, SysCode.Call), NewSysOC("timeNow", -1, SysCode.TimeNow), NewSysOC("timeGrain", -1, SysCode.TimeGrain), NewSysOC("copy", 1, SysCode.Copy, ObLib.OpFixity.Prefix)}; ObLib.Register(NEW(PackageSys, name := "sys", opCodes := opCodes)); END SetupSys; PROCEDUREEvalSys ( self : PackageSys; opCode: ObLib.OpCode; <*UNUSED*> arity : ObLib.OpArity; READONLY args : ObValue.ArgArray; temp : BOOLEAN; loc : SynLocation.T ): ObValue.Val RAISES {ObValue.Error, ObValue.Exception} = VAR int1 : INTEGER; text1, text2: TEXT; array1 : REF ObValue.Vals; sysProc : ObValue.SysCallClosure; BEGIN TRY CASE NARROW(opCode, SysOpCode).code OF | SysCode.Address => RETURN ObValue.NewText(ObValue.machineAddress); | SysCode.GetEnvVar => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); END; text2 := Env.Get(text1); RETURN ObValue.NewText(text2); | SysCode.GetParamCount => RETURN NEW(ObValue.ValInt, int := Params.Count, temp := temp); | SysCode.GetParam => TYPECASE args[1] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(1, "int", self.name, opCode.name, loc); END; IF (int1 < 0) OR (int1 >= Params.Count) THEN ObValue.BadArgVal(1, "in range", self.name, opCode.name, loc); END; RETURN ObValue.NewText(Params.Get(int1)); | SysCode.CallFailure => RETURN ObValue.sysCallFailure; | SysCode.Call => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); END; TYPECASE args[2] OF | ObValue.ValArray (node) => array1 := node.remote.Obtain(); ELSE ObValue.BadArgType(2, "array", self.name, opCode.name, loc) END; IF NOT ObValue.FetchSysCall(text1, (*out*) sysProc) THEN ObValue.RaiseException(ObValue.sysCallFailure, self.name & "_" & opCode.name & ": \"" & text1 & "\" not found", loc); END; RETURN sysProc.SysCall(array1^, loc); | SysCode.Copy => RETURN ObValue.CopyVal(args[1], ObValue.NewTbl(), loc); | SysCode.TimeNow => RETURN Obliq.NewReal(Time.Now()); | SysCode.TimeGrain => WITH grain = Time.Grain DO RETURN Obliq.NewReal(grain); END; ELSE ObValue.BadOp(self.name, opCode.name, loc); <*ASSERT FALSE*> END; EXCEPT | SharedObj.Error (atoms) => ObValue.RaiseSharedException( self.name & "_" & opCode.name, atoms, loc); <*ASSERT FALSE*> | NetObj.Error (atoms) => ObValue.RaiseNetException( self.name & "_" & opCode.name, atoms, loc); <*ASSERT FALSE*> | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, self.name & "_" & opCode.name, loc); <*ASSERT FALSE*> END; END EvalSys;
bool
package ============
TYPE BoolCode = {Is, IsNot, Not, And, Or}; BoolOpCode = ObLib.OpCode OBJECT code: BoolCode; END; PackageBool = ObLib.T OBJECT OVERRIDES Eval := EvalBool; END; PROCEDURE============NewBoolOC (name : TEXT; arity : INTEGER; code : BoolCode; fixity: ObLib.OpFixity := ObLib.OpFixity.Qualified): BoolOpCode = BEGIN RETURN NEW(BoolOpCode, name := name, arity := arity, code := code, fixity := fixity); END NewBoolOC; VAR true, false: ObValue.ValBool; PROCEDURESetupBool () = TYPE OpCodes = ARRAY OF ObLib.OpCode; VAR opCodes: REF OpCodes; BEGIN opCodes := NEW(REF OpCodes, NUMBER(BoolCode)); opCodes^ := OpCodes{NewBoolOC("not", 1, BoolCode.Not, ObLib.OpFixity.Prefix), NewBoolOC("and", 2, BoolCode.And, ObLib.OpFixity.Infix), NewBoolOC("or", 2, BoolCode.Or, ObLib.OpFixity.Infix), NewBoolOC("is", 2, BoolCode.Is, ObLib.OpFixity.Infix), NewBoolOC("isnot", 2, BoolCode.IsNot, ObLib.OpFixity.Infix)}; ObLib.Register(NEW(PackageBool, name := "bool", opCodes := opCodes)); true := NEW(ObValue.ValBool, bool := TRUE); false := NEW(ObValue.ValBool, bool := FALSE); END SetupBool; PROCEDUREEvalBool ( self : PackageBool; opCode: ObLib.OpCode; <*UNUSED*> arity : ObLib.OpArity; READONLY args : ObValue.ArgArray; <*UNUSED*> temp : BOOLEAN; loc : SynLocation.T ): ObValue.Val RAISES {ObValue.Error} = VAR bool1, bool2: BOOLEAN; BEGIN CASE NARROW(opCode, BoolOpCode).code OF | BoolCode.Not => TYPECASE args[1] OF | ObValue.ValBool (node) => bool1 := node.bool; ELSE ObValue.BadArgType(1, "bool", self.name, opCode.name, loc); END; IF NOT bool1 THEN RETURN true ELSE RETURN false END; | BoolCode.And => TYPECASE args[1] OF | ObValue.ValBool (node) => bool1 := node.bool; ELSE ObValue.BadArgType(1, "bool", self.name, opCode.name, loc); END; TYPECASE args[2] OF | ObValue.ValBool (node) => bool2 := node.bool; ELSE ObValue.BadArgType(2, "bool", self.name, opCode.name, loc); END; IF bool1 AND bool2 THEN RETURN true ELSE RETURN false END; | BoolCode.Or => TYPECASE args[1] OF | ObValue.ValBool (node) => bool1 := node.bool; ELSE ObValue.BadArgType(1, "bool", self.name, opCode.name, loc); END; TYPECASE args[2] OF | ObValue.ValBool (node) => bool2 := node.bool; ELSE ObValue.BadArgType(2, "bool", self.name, opCode.name, loc); END; IF bool1 OR bool2 THEN RETURN true ELSE RETURN false END; | BoolCode.Is => IF ObValue.Is(args[1], args[2], loc) THEN RETURN true ELSE RETURN false END; | BoolCode.IsNot => IF NOT ObValue.Is(args[1], args[2], loc) THEN RETURN true ELSE RETURN false END; ELSE ObValue.BadOp(self.name, opCode.name, loc); <*ASSERT FALSE*> END; END EvalBool;
int
package ============
TYPE IntCode = {Minus, Add, Sub, Mult, Div, Mod, Less, More, LessEq, MoreEq}; IntOpCode = ObLib.OpCode OBJECT code: IntCode; END; PackageInt = ObLib.T OBJECT OVERRIDES Eval := EvalInt; END; PROCEDURE============NewIntOC (name : TEXT; arity : INTEGER; code : IntCode; fixity: ObLib.OpFixity := ObLib.OpFixity.Qualified): IntOpCode = BEGIN RETURN NEW(IntOpCode, name := name, arity := arity, code := code, fixity := fixity); END NewIntOC; PROCEDURESetupInt () = TYPE OpCodes = ARRAY OF ObLib.OpCode; VAR opCodes: REF OpCodes; BEGIN opCodes := NEW(REF OpCodes, NUMBER(IntCode)); opCodes^ := OpCodes{ NewIntOC("minus", 1, IntCode.Minus), NewIntOC("+", 2, IntCode.Add), NewIntOC("-", 2, IntCode.Sub), NewIntOC("*", 2, IntCode.Mult), NewIntOC("/", 2, IntCode.Div), NewIntOC("%", 2, IntCode.Mod, ObLib.OpFixity.Infix), NewIntOC("<", 2, IntCode.Less), NewIntOC(">", 2, IntCode.More), NewIntOC("<=", 2, IntCode.LessEq), NewIntOC(">=", 2, IntCode.MoreEq)}; ObLib.Register(NEW(PackageInt, name := "int", opCodes := opCodes)); END SetupInt; PROCEDUREEvalInt ( self : PackageInt; opCode: ObLib.OpCode; <*UNUSED*> arity : ObLib.OpArity; READONLY args : ObValue.ArgArray; temp : BOOLEAN; loc : SynLocation.T ): ObValue.Val RAISES {ObValue.Error} = VAR int1, int2 : INTEGER; intCode : IntCode; intRes, intVal1, intVal2: ObValue.ValInt; BEGIN intCode := NARROW(opCode, IntOpCode).code; TYPECASE args[1] OF | ObValue.ValInt (node) => intVal1 := node; int1 := node.int; ELSE ObValue.BadArgType(1, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; CASE intCode OF | IntCode.Minus => RETURN NEW(ObValue.ValInt, int := -int1, temp := temp); | IntCode.Add, IntCode.Sub, IntCode.Mult, IntCode.Div, IntCode.Mod, IntCode.Less, IntCode.More, IntCode.LessEq, IntCode.MoreEq => TYPECASE args[2] OF | ObValue.ValInt (node) => intVal2 := node; int2 := node.int; ELSE ObValue.BadArgType(2, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; CASE intCode OF | IntCode.Minus => <*ASSERT FALSE*>(* can't happen *) | IntCode.Add => RETURN NEW(ObValue.ValInt, int := int1 + int2, temp := temp); | IntCode.Sub => RETURN NEW(ObValue.ValInt, int := int1 - int2, temp := temp); | IntCode.Mult => RETURN NEW(ObValue.ValInt, int := int1 * int2, temp := temp); | IntCode.Div => IF int2 = 0 THEN ObValue.BadArgVal(2, "non-zero", self.name, opCode.name, loc); <*ASSERT FALSE*> ELSE RETURN NEW(ObValue.ValInt, int := int1 DIV int2, temp := temp); END; | IntCode.Mod => IF int2 = 0 THEN ObValue.BadArgVal(2, "non-zero", self.name, opCode.name, loc); <*ASSERT FALSE*> ELSE IF intVal1.temp THEN intRes := intVal1; ELSIF intVal2.temp THEN intRes := intVal2; ELSE intRes := NEW(ObValue.ValInt); END; intRes.temp := temp; intRes.int := int1 MOD int2; RETURN intRes; END; | IntCode.Less => RETURN NEW(ObValue.ValBool, bool := int1 < int2); | IntCode.More => RETURN NEW(ObValue.ValBool, bool := int1 > int2); | IntCode.LessEq => RETURN NEW(ObValue.ValBool, bool := int1 <= int2); | IntCode.MoreEq => RETURN NEW(ObValue.ValBool, bool := int1 >= int2); END; ELSE ObValue.BadOp(self.name, opCode.name, loc); <*ASSERT FALSE*> END; END EvalInt;
real
package ============
TYPE RealCode = {Minus, Add, Sub, Mult, Div, Less, More, LessEq, MoreEq, Round, Float, Floor, Ceiling}; RealOpCode = ObLib.OpCode OBJECT code: RealCode; END; PackageReal = ObLib.T OBJECT OVERRIDES Eval := EvalReal; END; PROCEDURE============NewRealOC (name : TEXT; arity : INTEGER; code : RealCode; fixity: ObLib.OpFixity := ObLib.OpFixity.Qualified): RealOpCode = BEGIN RETURN NEW(RealOpCode, name := name, arity := arity, code := code, fixity := fixity); END NewRealOC; PROCEDURESetupReal () = TYPE OpCodes = ARRAY OF ObLib.OpCode; VAR opCodes: REF OpCodes; BEGIN opCodes := NEW(REF OpCodes, NUMBER(RealCode)); opCodes^ := OpCodes{NewRealOC("minus", 1, RealCode.Minus), NewRealOC("+", 2, RealCode.Add, ObLib.OpFixity.Infix), NewRealOC("-", 2, RealCode.Sub, ObLib.OpFixity.Infix), NewRealOC("*", 2, RealCode.Mult, ObLib.OpFixity.Infix), NewRealOC("/", 2, RealCode.Div, ObLib.OpFixity.Infix), NewRealOC("<", 2, RealCode.Less, ObLib.OpFixity.Infix), NewRealOC(">", 2, RealCode.More, ObLib.OpFixity.Infix), NewRealOC("<=", 2, RealCode.LessEq, ObLib.OpFixity.Infix), NewRealOC(">=", 2, RealCode.MoreEq, ObLib.OpFixity.Infix), NewRealOC("round", 1, RealCode.Round, ObLib.OpFixity.Prefix), NewRealOC("float", 1, RealCode.Float, ObLib.OpFixity.Prefix), NewRealOC("floor", 1, RealCode.Floor), NewRealOC("ceiling", 1, RealCode.Ceiling)}; ObLib.Register(NEW(PackageReal, name := "real", opCodes := opCodes)); END SetupReal; PROCEDUREEvalReal ( self : PackageReal; opCode: ObLib.OpCode; <*UNUSED*> arity : ObLib.OpArity; READONLY args : ObValue.ArgArray; temp : BOOLEAN; loc : SynLocation.T ): ObValue.Val RAISES {ObValue.Error} = VAR realRes, realVal1, realVal2: ObValue.ValReal; real1, real2 : LONGREAL; intRes, intVal1, intVal2 : ObValue.ValInt; int1, int2 : INTEGER; realCode : RealCode; isReal1, isReal2 : BOOLEAN; BEGIN realCode := NARROW(opCode, RealOpCode).code; TYPECASE args[1] OF | ObValue.ValReal (node) => realVal1 := node; real1 := node.real; isReal1 := TRUE; | ObValue.ValInt (node) => intVal1 := node; int1 := node.int; isReal1 := FALSE; ELSE ObValue.BadArgType(1, "real or int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; CASE realCode OF | RealCode.Minus => IF isReal1 THEN IF realVal1.temp THEN realRes := realVal1; ELSE realRes := NEW(ObValue.ValReal); END; realRes.temp := temp; realRes.real := -real1; RETURN realRes; ELSE IF intVal1.temp THEN intRes := intVal1; ELSE intRes := NEW(ObValue.ValInt); END; intRes.temp := temp; intRes.int := -int1; RETURN intRes; END; | RealCode.Float => IF isReal1 THEN IF realVal1.temp THEN realVal1.temp := temp; END; RETURN realVal1; ELSE RETURN NEW(ObValue.ValReal, real := FLOAT(int1, LONGREAL), temp := temp); END; | RealCode.Round => IF isReal1 THEN RETURN NEW(ObValue.ValInt, int := ROUND(real1), temp := temp); ELSE IF intVal1.temp THEN intVal1.temp := temp END; RETURN intVal1; END; | RealCode.Floor => IF isReal1 THEN RETURN NEW(ObValue.ValInt, int := FLOOR(real1), temp := temp); ELSE IF intVal1.temp THEN intVal1.temp := temp END; RETURN intVal1; END; | RealCode.Ceiling => IF isReal1 THEN RETURN NEW(ObValue.ValInt, int := CEILING(real1), temp := temp); ELSE IF intVal1.temp THEN intVal1.temp := temp END; RETURN intVal1; END; | RealCode.Add, RealCode.Sub, RealCode.Mult, RealCode.Div => TYPECASE args[2] OF | ObValue.ValReal (node) => realVal2 := node; real2 := node.real; isReal2 := TRUE; | ObValue.ValInt (node) => intVal2 := node; int2 := node.int; isReal2 := FALSE; ELSE ObValue.BadArgType(2, "real or int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; IF isReal1 # isReal2 THEN IF isReal1 THEN ObValue.BadArgType( 2, "real (like argument 1)", self.name, opCode.name, loc); <*ASSERT FALSE*> ELSE ObValue.BadArgType( 2, "int (like argument 1)", self.name, opCode.name, loc); <*ASSERT FALSE*> END; END; IF isReal1 THEN IF realVal1.temp THEN realRes := realVal1; ELSIF realVal2.temp THEN realRes := realVal2; ELSE realRes := NEW(ObValue.ValReal); END; realRes.temp := temp; ELSE IF intVal1.temp THEN intRes := intVal1; ELSIF intVal2.temp THEN intRes := intVal2; ELSE intRes := NEW(ObValue.ValInt); END; intRes.temp := temp; END; CASE realCode OF | RealCode.Add => IF isReal1 THEN realRes.real := real1 + real2; RETURN realRes; ELSE intRes.int := int1 + int2; RETURN intRes; END; | RealCode.Sub => IF isReal1 THEN realRes.real := real1 - real2; RETURN realRes; ELSE intRes.int := int1 - int2; RETURN intRes; END; | RealCode.Mult => IF isReal1 THEN realRes.real := real1 * real2; RETURN realRes; ELSE intRes.int := int1 * int2; RETURN intRes; END; | RealCode.Div => IF isReal1 THEN IF real2 = 0.0d0 THEN ObValue.BadArgVal( 2, "a non-zero real", self.name, opCode.name, loc); <*ASSERT FALSE*> ELSE realRes.real := real1 / real2; RETURN realRes; END; ELSE IF int2 = 0 THEN ObValue.BadArgVal( 2, "a non-zero int", self.name, opCode.name, loc); <*ASSERT FALSE*> ELSE intRes.int := int1 DIV int2; RETURN intRes; END; END; ELSE <*ASSERT FALSE*> END; | RealCode.Less, RealCode.More, RealCode.LessEq, RealCode.MoreEq => TYPECASE args[2] OF | ObValue.ValReal (node) => real2 := node.real; isReal2 := TRUE; | ObValue.ValInt (node) => int2 := node.int; isReal2 := FALSE; ELSE ObValue.BadArgType(2, "real or int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; IF isReal1 # isReal2 THEN IF isReal1 THEN ObValue.BadArgType( 2, "real (like argument 1)", self.name, opCode.name, loc); <*ASSERT FALSE*> ELSE ObValue.BadArgType( 2, "int (like argument 1)", self.name, opCode.name, loc); <*ASSERT FALSE*> END; END; CASE realCode OF | RealCode.Less => IF isReal1 THEN IF real1 < real2 THEN RETURN true ELSE RETURN false END ELSE IF int1 < int2 THEN RETURN true ELSE RETURN false END END; | RealCode.More => IF isReal1 THEN IF real1 > real2 THEN RETURN true ELSE RETURN false END ELSE IF int1 > int2 THEN RETURN true ELSE RETURN false END END; | RealCode.LessEq => IF isReal1 THEN IF real1 <= real2 THEN RETURN true ELSE RETURN false END ELSE IF int1 <= int2 THEN RETURN true ELSE RETURN false END END; | RealCode.MoreEq => IF isReal1 THEN IF real1 >= real2 THEN RETURN true ELSE RETURN false END ELSE IF int1 >= int2 THEN RETURN true ELSE RETURN false END END; ELSE <*ASSERT FALSE*> END; ELSE ObValue.BadOp(self.name, opCode.name, loc); <*ASSERT FALSE*> END; END EvalReal;
math
package ============
TYPE MathCode = {Pi, E, Degree, Exp, Log, Sqrt, Pow, Cos, Sin, Tan, Acos, Asin, Atan, Atan2, Hypot}; MathOpCode = ObLib.OpCode OBJECT code: MathCode; END; PackageMath = ObLib.T OBJECT OVERRIDES Eval := EvalMath; END; VAR MathPi, MathE, MathDegree: ObValue.Val; PROCEDURE============NewMathOC (name: TEXT; arity: INTEGER; code: MathCode): MathOpCode = BEGIN RETURN NEW(MathOpCode, name := name, arity := arity, code := code); END NewMathOC; PROCEDURESetupMath () = TYPE OpCodes = ARRAY OF ObLib.OpCode; VAR opCodes: REF OpCodes; BEGIN opCodes := NEW(REF OpCodes, NUMBER(MathCode)); opCodes^ := OpCodes{NewMathOC("pi", -1, MathCode.Pi), NewMathOC("e", -1, MathCode.E), NewMathOC("degree", -1, MathCode.Degree), NewMathOC("exp", 1, MathCode.Exp), NewMathOC("log", 1, MathCode.Log), NewMathOC("sqrt", 1, MathCode.Sqrt), NewMathOC("pow", 2, MathCode.Pow), NewMathOC("cos", 1, MathCode.Cos), NewMathOC("sin", 1, MathCode.Sin), NewMathOC("tan", 1, MathCode.Tan), NewMathOC("acos", 1, MathCode.Acos), NewMathOC("asin", 1, MathCode.Asin), NewMathOC("atan", 1, MathCode.Atan), NewMathOC("atan2", 2, MathCode.Atan2), NewMathOC("hypot", 2, MathCode.Hypot)}; ObLib.Register(NEW(PackageMath, name := "math", opCodes := opCodes)); MathPi := NEW(ObValue.ValReal, real := FLOAT(Math.Pi, LONGREAL), temp := FALSE); MathE := NEW(ObValue.ValReal, real := FLOAT(Math.E, LONGREAL), temp := FALSE); MathDegree := NEW(ObValue.ValReal, real := FLOAT(Math.Degree, LONGREAL), temp := FALSE); END SetupMath; PROCEDUREEvalMath ( self : PackageMath; opCode: ObLib.OpCode; <*UNUSED*> arity : ObLib.OpArity; READONLY args : ObValue.ArgArray; temp : BOOLEAN; loc : SynLocation.T ): ObValue.Val RAISES {ObValue.Error} = VAR real1, real2 : LONGREAL; realRes, realVal1, realVal2: ObValue.ValReal; BEGIN CASE NARROW(opCode, MathOpCode).code OF | MathCode.Pi => RETURN MathPi; | MathCode.E => RETURN MathE; | MathCode.Degree => RETURN MathDegree; | MathCode.Exp => TYPECASE args[1] OF | ObValue.ValReal (node) => IF node.temp THEN realRes := node; ELSE realRes := NEW(ObValue.ValReal); END; realRes.temp := temp; real1 := node.real; ELSE ObValue.BadArgType(1, "real", self.name, opCode.name, loc); END; realRes.real := Math.exp(real1); RETURN realRes; | MathCode.Log => TYPECASE args[1] OF | ObValue.ValReal (node) => IF node.temp THEN realRes := node; ELSE realRes := NEW(ObValue.ValReal); END; realRes.temp := temp; real1 := node.real; ELSE ObValue.BadArgType(1, "real", self.name, opCode.name, loc); END; realRes.real := Math.log(real1); RETURN realRes; | MathCode.Sqrt => TYPECASE args[1] OF | ObValue.ValReal (node) => IF node.temp THEN realRes := node; ELSE realRes := NEW(ObValue.ValReal); END; realRes.temp := temp; real1 := node.real; ELSE ObValue.BadArgType(1, "real", self.name, opCode.name, loc); END; realRes.real := Math.sqrt(real1); RETURN realRes; | MathCode.Pow => TYPECASE args[1] OF | ObValue.ValReal (node) => realVal1 := node; real1 := node.real; ELSE ObValue.BadArgType(1, "real", self.name, opCode.name, loc); END; TYPECASE args[2] OF | ObValue.ValReal (node) => realVal2 := node; real2 := node.real; ELSE ObValue.BadArgType(2, "real", self.name, opCode.name, loc); END; IF realVal1.temp THEN realRes := realVal1; ELSIF realVal2.temp THEN realRes := realVal2; ELSE realRes := NEW(ObValue.ValReal); END; realRes.temp := temp; realRes.real := Math.pow(real1, real2); RETURN realRes; | MathCode.Cos => TYPECASE args[1] OF | ObValue.ValReal (node) => IF node.temp THEN realRes := node; ELSE realRes := NEW(ObValue.ValReal); END; realRes.temp := temp; real1 := node.real; ELSE ObValue.BadArgType(1, "real", self.name, opCode.name, loc); END; realRes.real := Math.cos(real1); RETURN realRes; | MathCode.Sin => TYPECASE args[1] OF | ObValue.ValReal (node) => IF node.temp THEN realRes := node; ELSE realRes := NEW(ObValue.ValReal); END; realRes.temp := temp; real1 := node.real; ELSE ObValue.BadArgType(1, "real", self.name, opCode.name, loc); END; realRes.real := Math.sin(real1); RETURN realRes; | MathCode.Tan => TYPECASE args[1] OF | ObValue.ValReal (node) => IF node.temp THEN realRes := node; ELSE realRes := NEW(ObValue.ValReal); END; realRes.temp := temp; real1 := node.real; ELSE ObValue.BadArgType(1, "real", self.name, opCode.name, loc); END; realRes.real := Math.tan(real1); RETURN realRes; | MathCode.Acos => TYPECASE args[1] OF | ObValue.ValReal (node) => IF node.temp THEN realRes := node; ELSE realRes := NEW(ObValue.ValReal); END; realRes.temp := temp; real1 := node.real; ELSE ObValue.BadArgType(1, "real", self.name, opCode.name, loc); END; realRes.real := Math.acos(real1); RETURN realRes; | MathCode.Asin => TYPECASE args[1] OF | ObValue.ValReal (node) => IF node.temp THEN realRes := node; ELSE realRes := NEW(ObValue.ValReal); END; realRes.temp := temp; real1 := node.real; ELSE ObValue.BadArgType(1, "real", self.name, opCode.name, loc); END; realRes.real := Math.asin(real1); RETURN realRes; | MathCode.Atan => TYPECASE args[1] OF | ObValue.ValReal (node) => IF node.temp THEN realRes := node; ELSE realRes := NEW(ObValue.ValReal); END; realRes.temp := temp; real1 := node.real; ELSE ObValue.BadArgType(1, "real", self.name, opCode.name, loc); END; realRes.real := Math.atan(real1); RETURN realRes; | MathCode.Atan2 => TYPECASE args[1] OF | ObValue.ValReal (node) => realVal1 := node; real1 := node.real; ELSE ObValue.BadArgType(1, "real", self.name, opCode.name, loc); END; TYPECASE args[2] OF | ObValue.ValReal (node) => realVal2 := node; real2 := node.real; ELSE ObValue.BadArgType(2, "real", self.name, opCode.name, loc); END; IF realVal1.temp THEN realRes := realVal1; ELSIF realVal2.temp THEN realRes := realVal2; ELSE realRes := NEW(ObValue.ValReal); END; realRes.temp := temp; realRes.real := Math.atan2(real1, real2); RETURN realRes; | MathCode.Hypot => TYPECASE args[1] OF | ObValue.ValReal (node) => realVal1 := node; real1 := node.real; ELSE ObValue.BadArgType(1, "real", self.name, opCode.name, loc); END; TYPECASE args[2] OF | ObValue.ValReal (node) => realVal2 := node; real2 := node.real; ELSE ObValue.BadArgType(2, "real", self.name, opCode.name, loc); END; IF realVal1.temp THEN realRes := realVal1; ELSIF realVal2.temp THEN realRes := realVal2; ELSE realRes := NEW(ObValue.ValReal); END; realRes.temp := temp; realRes.real := Math.hypot(real1, real2); RETURN realRes; ELSE ObValue.BadOp(self.name, opCode.name, loc); <*ASSERT FALSE*> END; END EvalMath;
ascii
package ============
TYPE AsciiCode = {Char, Val}; AsciiOpCode = ObLib.OpCode OBJECT code: AsciiCode; END; PackageAscii = ObLib.T OBJECT OVERRIDES Eval := EvalAscii; END; PROCEDURE============NewAsciiOC (name: TEXT; arity: INTEGER; code: AsciiCode): AsciiOpCode = BEGIN RETURN NEW(AsciiOpCode, name := name, arity := arity, code := code); END NewAsciiOC; PROCEDURESetupAscii () = TYPE OpCodes = ARRAY OF ObLib.OpCode; VAR opCodes: REF OpCodes; BEGIN opCodes := NEW(REF OpCodes, NUMBER(AsciiCode)); opCodes^ := OpCodes{NewAsciiOC("char", 1, AsciiCode.Char), NewAsciiOC("val", 1, AsciiCode.Val)}; ObLib.Register(NEW(PackageAscii, name := "ascii", opCodes := opCodes)); END SetupAscii; PROCEDUREEvalAscii ( self : PackageAscii; opCode: ObLib.OpCode; <*UNUSED*> arity : ObLib.OpArity; READONLY args : ObValue.ArgArray; temp : BOOLEAN; loc : SynLocation.T ): ObValue.Val RAISES {ObValue.Error} = VAR int1 : INTEGER; char1: CHAR; BEGIN CASE NARROW(opCode, AsciiOpCode).code OF | AsciiCode.Char => TYPECASE args[1] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(1, "int", self.name, opCode.name, loc); END; IF (int1 < 0) OR (int1 > 255) THEN ObValue.BadArgVal(1, "0..255", self.name, opCode.name, loc); END; RETURN NEW(ObValue.ValChar, char := VAL(int1, CHAR)); | AsciiCode.Val => TYPECASE args[1] OF | ObValue.ValChar (node) => char1 := node.char; ELSE ObValue.BadArgType(1, "char", self.name, opCode.name, loc); END; RETURN NEW(ObValue.ValInt, int := ORD(char1), temp := temp); ELSE ObValue.BadOp(self.name, opCode.name, loc); <*ASSERT FALSE*> END; END EvalAscii;
text
package ============
TYPE TextCode = {New, Empty, Length, Equal, Char, Sub, Cat, Precedes, Encode, Decode, Implode, Explode, Hash, ToInt, FromInt, FindFirstChar, FindLastChar, FindFirst, FindLast, ReplaceAll}; TextOpCode = ObLib.OpCode OBJECT code: TextCode; END; PackageText = ObLib.T OBJECT OVERRIDES Eval := EvalText; END; PROCEDURE============NewTextOC (name : TEXT; arity : INTEGER; code : TextCode; fixity: ObLib.OpFixity := ObLib.OpFixity.Qualified): TextOpCode = BEGIN RETURN NEW(TextOpCode, name := name, arity := arity, code := code, fixity := fixity); END NewTextOC; PROCEDURESetupText () = TYPE OpCodes = ARRAY OF ObLib.OpCode; VAR opCodes: REF OpCodes; BEGIN opCodes := NEW(REF OpCodes, NUMBER(TextCode)); opCodes^ := OpCodes{NewTextOC("new", 2, TextCode.New), NewTextOC("empty", 1, TextCode.Empty), NewTextOC("length", 1, TextCode.Length), NewTextOC("equal", 2, TextCode.Equal), NewTextOC("char", 2, TextCode.Char), NewTextOC("sub", 3, TextCode.Sub), NewTextOC("&", 2, TextCode.Cat, ObLib.OpFixity.Infix), NewTextOC("precedes", 2, TextCode.Precedes), NewTextOC("encode", 1, TextCode.Encode), NewTextOC("decode", 1, TextCode.Decode), NewTextOC("implode", 2, TextCode.Implode), NewTextOC("explode", 2, TextCode.Explode), NewTextOC("hash", 1, TextCode.Hash), NewTextOC("toInt", 1, TextCode.ToInt), NewTextOC("fromInt", 1, TextCode.FromInt), NewTextOC("findFirstChar", 3, TextCode.FindFirstChar), NewTextOC("findLastChar", 3, TextCode.FindLastChar), NewTextOC("findFirst", 3, TextCode.FindFirst), NewTextOC("findLast", 3, TextCode.FindLast), NewTextOC("replaceAll", 3, TextCode.ReplaceAll)}; ObLib.Register(NEW(PackageText, name := "text", opCodes := opCodes)); END SetupText; PROCEDUREEvalText ( self : PackageText; opCode: ObLib.OpCode; <*UNUSED*> arity : ObLib.OpArity; READONLY args : ObValue.ArgArray; temp : BOOLEAN; loc : SynLocation.T ): ObValue.Val RAISES {ObValue.Error, ObValue.Exception} = TYPE Chars = REF ARRAY OF CHAR; TYPE Texts = REF ARRAY OF TEXT; TYPE Vals = REF ARRAY OF ObValue.Val; VAR text1, text2, text3: TEXT; int1, int2, len : INTEGER; char1 : CHAR; chars : Chars; val : ObValue.Val; texts : Texts; array1 : Vals; chSet : SET OF CHAR; BEGIN TRY CASE NARROW(opCode, TextOpCode).code OF | TextCode.New => TYPECASE args[1] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(1, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValChar (node) => char1 := node.char; ELSE ObValue.BadArgType(2, "char", self.name, opCode.name, loc); <*ASSERT FALSE*> END; IF int1 < 0 THEN ObValue.BadArgVal( 1, "non-negative", self.name, opCode.name, loc); <*ASSERT FALSE*> END; chars := NEW(Chars, int1); FOR i := 0 TO int1 - 1 DO chars^[i] := char1; END; RETURN ObValue.NewText(Text.FromChars(chars^)); | TextCode.Empty => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; IF Text.Empty(text1) THEN RETURN true ELSE RETURN false END; | TextCode.Length => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN NEW(ObValue.ValInt, int := Text.Length(text1), temp := temp); | TextCode.Equal => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValText (node) => text2 := node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; IF Text.Equal(text1, text2) THEN RETURN true ELSE RETURN false END; | TextCode.Char => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(2, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; IF (int1 < 0) OR (int1 >= Text.Length(text1)) THEN ObValue.BadArgVal(2, "in range", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN NEW(ObValue.ValChar, char := Text.GetChar(text1, int1)); | TextCode.Sub => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(2, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[3] OF | ObValue.ValInt (node) => int2 := node.int; ELSE ObValue.BadArgType(3, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; len := Text.Length(text1); IF (int1 < 0) OR (int1 > len) THEN ObValue.BadArgVal(2, "in range", self.name, opCode.name, loc); <*ASSERT FALSE*> END; IF (int2 < 0) OR (int1 + int2 > len) THEN ObValue.BadArgVal(3, "in range", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN ObValue.NewText(Text.Sub(text1, int1, int2)); | TextCode.Cat => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValText (node) => text2 := node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN ObValue.NewText(Text.Cat(text1, text2)); | TextCode.Precedes => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValText (node) => text2 := node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; IF Text.Compare(text1, text2) < 0 THEN RETURN true; ELSE RETURN false; END; | TextCode.Encode => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN ObValue.NewText(TextConv.Encode(text1, FALSE)); | TextCode.Decode => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TRY val := ObValue.NewText(TextConv.Decode(text1, FALSE)); EXCEPT TextConv.Fail => ObValue.BadArgVal(1, "a well-formed encoded text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN val; | TextCode.Implode => TYPECASE args[1] OF | ObValue.ValChar (node) => char1 := node.char; ELSE ObValue.BadArgType(1, "char", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValArray (node) => array1 := node.remote.Obtain(); ELSE ObValue.BadArgType(2, "array", self.name, opCode.name, loc); <*ASSERT FALSE*> END; texts := NEW(Texts, NUMBER(array1^)); FOR i := 0 TO NUMBER(texts^) - 1 DO TYPECASE array1^[i] OF | ObValue.ValText (node) => texts^[i] := node.text; ELSE ObValue.BadArgType( 1, "array(text)", self.name, opCode.name, loc); <*ASSERT FALSE*> END; END; RETURN ObValue.NewText(TextConv.Implode(texts^, char1)); | TextCode.Explode => TYPECASE args[1] OF | ObValue.ValText (node) => text2 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; chSet := CharSet(text2); texts := NEW(Texts, TextConv.ExplodedSize(text1, chSet)); TextConv.Explode(text1, texts^, chSet); array1 := NEW(Vals, NUMBER(texts^)); FOR i := 0 TO NUMBER(array1^) - 1 DO array1[i] := ObValue.NewText(texts[i]); END; RETURN ObValue.NewArrayFromVals(array1); | TextCode.Hash => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN NEW(ObValue.ValInt, int := Text.Hash(text1), temp := temp); | TextCode.ToInt => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TRY RETURN NEW(ObValue.ValInt, int := Lex.Int(TextRd.New(text1)), temp := temp); EXCEPT Lex.Error, Rd.Failure, FloatMode.Trap => ObValue.BadArgVal( 1, "a well-formed int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; | TextCode.FromInt => TYPECASE args[1] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(1, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN ObValue.NewText(Fmt.Int(int1)); | TextCode.FindFirstChar => TYPECASE args[1] OF | ObValue.ValChar (node) => char1 := node.char; ELSE ObValue.BadArgType(1, "char", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[3] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(3, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN NEW(ObValue.ValInt, int := Text.FindChar(text1, char1, int1), temp := temp); | TextCode.FindLastChar => TYPECASE args[1] OF | ObValue.ValChar (node) => char1 := node.char; ELSE ObValue.BadArgType(1, "char", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[3] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(3, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN NEW(ObValue.ValInt, int := Text.FindCharR(text1, char1, int1), temp := temp); | TextCode.FindFirst => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValText (node) => text2 := node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[3] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(3, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN NEW(ObValue.ValInt, int := FindFirst(text2, int1, text1), temp := temp); | TextCode.FindLast => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValText (node) => text2 := node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[3] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(3, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN NEW(ObValue.ValInt, int := FindLast(text2, int1, text1), temp := temp); | TextCode.ReplaceAll => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValText (node) => text2 := node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[3] OF | ObValue.ValText (node) => text3 := node.text; ELSE ObValue.BadArgType(3, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN ObValue.NewText(ReplaceAll(text3, text1, text2)); ELSE ObValue.BadOp(self.name, opCode.name, loc); <*ASSERT FALSE*> END; EXCEPT | NetObj.Error (atoms) => ObValue.RaiseNetException( self.name & "_" & opCode.name, atoms, loc); <*ASSERT FALSE*> | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, self.name & "_" & opCode.name, loc); <*ASSERT FALSE*> END; END EvalText; PROCEDURECharSet (text: TEXT): SET OF CHAR = VAR s: SET OF CHAR; BEGIN s := SET OF CHAR{}; FOR i := 0 TO Text.Length(text) - 1 DO s := s + SET OF CHAR{Text.GetChar(text, i)}; END; RETURN s; END CharSet; PROCEDUREFindFirst (source: TEXT; start: INTEGER; pattern: TEXT): INTEGER = VAR i, ii, j, srcLimit, patLimit: INTEGER; patFirst : CHAR; BEGIN srcLimit := Text.Length(source) - start; patLimit := Text.Length(pattern); IF patLimit = 0 THEN RETURN 0 END; patFirst := Text.GetChar(pattern, 0); i := start; LOOP IF i >= srcLimit THEN RETURN -1 END; IF Text.GetChar(source, i) = patFirst THEN ii := i; j := 0; LOOP INC(j); IF j >= patLimit THEN RETURN i END; INC(ii); IF ii >= srcLimit THEN EXIT END; IF Text.GetChar(source, ii) # Text.GetChar(pattern, j) THEN EXIT END; END; END; INC(i); END; END FindFirst; PROCEDUREFindLast (source: TEXT; start: INTEGER; pattern: TEXT): INTEGER = VAR i, ii, j, patLength: INTEGER; patLast : CHAR; BEGIN patLength := Text.Length(pattern); IF patLength = 0 THEN RETURN i END; patLast := Text.GetChar(pattern, patLength - 1); i := MIN(Text.Length(source), start); LOOP DEC(i); IF i < 0 THEN RETURN -1 END; IF Text.GetChar(source, i) = patLast THEN ii := i; j := patLength - 1; LOOP DEC(j); IF j < 0 THEN RETURN ii END; DEC(ii); IF ii < 0 THEN EXIT END; IF Text.GetChar(source, ii) # Text.GetChar(pattern, j) THEN EXIT END; END; END; END; END FindLast; PROCEDUREReplaceAll (source: TEXT; pattern: TEXT; repl: TEXT): TEXT = VAR i, ii, j, k, srcLimit, patLimit, replLength, count: INTEGER; patFirst, ch : CHAR; res : REF ARRAY OF CHAR; BEGIN srcLimit := Text.Length(source); patLimit := Text.Length(pattern); IF patLimit = 0 THEN RETURN source END; patFirst := Text.GetChar(pattern, 0); count := 0; i := 0; LOOP IF i >= srcLimit THEN EXIT END; IF Text.GetChar(source, i) = patFirst THEN ii := i; j := 0; LOOP INC(j); IF j >= patLimit THEN INC(count); INC(i, patLimit); EXIT; END; INC(ii); IF (ii >= srcLimit) OR (Text.GetChar(source, ii) # Text.GetChar(pattern, j)) THEN INC(i); EXIT; END; END; ELSE INC(i); END; END; replLength := Text.Length(repl); res := NEW(REF ARRAY OF CHAR, (srcLimit - (count * patLimit)) + (count * replLength)); i := 0; k := 0; LOOP IF i >= srcLimit THEN EXIT END; ch := Text.GetChar(source, i); IF ch = patFirst THEN ii := i; j := 0; LOOP INC(j); IF j >= patLimit THEN Text.SetChars(SUBARRAY(res^, k, replLength), repl); INC(k, replLength); INC(i, patLimit); EXIT; END; INC(ii); IF (ii >= srcLimit) OR (Text.GetChar(source, ii) # Text.GetChar(pattern, j)) THEN res^[k] := ch; INC(k); INC(i); EXIT; END; END; ELSE res^[k] := ch; INC(k); INC(i); END; END; RETURN Text.FromChars(res^); END ReplaceAll;
array
package ============
TYPE ArrayCode = {New, Gen, Size, Get, Set, Sub, Upd, Cat}; ArrayOpCode = ObLib.OpCode OBJECT code: ArrayCode; END; PackageArray = ObLib.T OBJECT OVERRIDES Eval := EvalArray; END; PROCEDURE============NewArrayOC (name : TEXT; arity : INTEGER; code : ArrayCode; fixity: ObLib.OpFixity := ObLib.OpFixity.Qualified): ArrayOpCode = BEGIN RETURN NEW(ArrayOpCode, name := name, arity := arity, code := code, fixity := fixity); END NewArrayOC; PROCEDURESetupArray () = TYPE OpCodes = ARRAY OF ObLib.OpCode; VAR opCodes: REF OpCodes; BEGIN opCodes := NEW(REF OpCodes, NUMBER(ArrayCode)); opCodes^ := OpCodes{NewArrayOC("new", 2, ArrayCode.New), NewArrayOC("gen", 2, ArrayCode.Gen), NewArrayOC("#", 1, ArrayCode.Size, ObLib.OpFixity.Prefix), NewArrayOC("get", 2, ArrayCode.Get), NewArrayOC("set", 3, ArrayCode.Set), NewArrayOC("sub", 3, ArrayCode.Sub), NewArrayOC("upd", 4, ArrayCode.Upd), NewArrayOC("@", 2, ArrayCode.Cat, ObLib.OpFixity.Infix)}; ObLib.Register(NEW(PackageArray, name := "array", opCodes := opCodes)); END SetupArray; PROCEDUREEvalArray ( self : PackageArray; opCode: ObLib.OpCode; <*UNUSED*> arity : ObLib.OpArity; READONLY args : ObValue.ArgArray; temp : BOOLEAN; loc : SynLocation.T ): ObValue.Val RAISES {ObValue.Error, ObValue.Exception} = TYPE Vals = REF ARRAY OF ObValue.Val; VAR int1, int2 : INTEGER; vals, array1, array2: Vals; rem1 : ObValue.RemArray; badOp : INTEGER := 0; clos1 : ObValue.ValFun; BEGIN TRY CASE NARROW(opCode, ArrayOpCode).code OF | ArrayCode.New => TYPECASE args[1] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(1, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; IF int1 < 0 THEN ObValue.BadArgVal( 1, "non-negative", self.name, opCode.name, loc); <*ASSERT FALSE*> END; vals := NEW(Vals, int1); FOR i := 0 TO int1 - 1 DO vals^[i] := args[2]; END; RETURN ObValue.NewArrayFromVals(vals); | ArrayCode.Gen => TYPECASE args[1] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(1, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValFun (node) => clos1 := node; ELSE ObValue.BadArgType(1, "procedure", self.name, opCode.name, loc); <*ASSERT FALSE*> END; IF int1 < 0 THEN ObValue.BadArgVal( 1, "non-negative", self.name, opCode.name, loc); <*ASSERT FALSE*> END; vals := NEW(Vals, int1); FOR i := 0 TO int1 - 1 DO vals^[i] := ObEval.Call(clos1, ObValue.Vals{NEW(ObValue.ValInt, int := i, temp := FALSE)}, loc); END; RETURN ObValue.NewArrayFromVals(vals); | ArrayCode.Size => TYPECASE args[1] OF | ObValue.ValArray (node) => RETURN NEW(ObValue.ValInt, int := node.remote.Size(), temp := temp); ELSE ObValue.BadArgType(1, "array", self.name, opCode.name, loc); <*ASSERT FALSE*> END; | ArrayCode.Get => TYPECASE args[2] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(2, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[1] OF | ObValue.ValArray (node) => badOp := 2; RETURN node.remote.Get(int1); ELSE ObValue.BadArgType(1, "array", self.name, opCode.name, loc); <*ASSERT FALSE*> END; | ArrayCode.Set => TYPECASE args[1] OF | ObValue.ValArray (node) => rem1 := node.remote; ELSE ObValue.BadArgType(1, "array", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(2, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; rem1.Set(int1, args[3]); badOp := 2; RETURN ObValue.valOk; | ArrayCode.Sub => TYPECASE args[2] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(2, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[3] OF | ObValue.ValInt (node) => int2 := node.int; ELSE ObValue.BadArgType(3, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[1] OF | ObValue.ValArray (node) => badOp := 3; RETURN node.remote.Sub(int1, int2); ELSE ObValue.BadArgType(1, "array", self.name, opCode.name, loc); <*ASSERT FALSE*> END; | ArrayCode.Upd => TYPECASE args[1] OF | ObValue.ValArray (node) => rem1 := node.remote; ELSE ObValue.BadArgType(1, "array", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(2, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[3] OF | ObValue.ValInt (node) => int2 := node.int; ELSE ObValue.BadArgType(3, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[4] OF | ObValue.ValArray (node) => array1 := node.remote.Obtain(); ELSE ObValue.BadArgType(4, "array", self.name, opCode.name, loc); <*ASSERT FALSE*> END; badOp := 3; rem1.Upd(int1, int2, array1); RETURN ObValue.valOk; | ArrayCode.Cat => TYPECASE args[1] OF | ObValue.ValArray (node) => array1 := node.remote.Obtain(); ELSE ObValue.BadArgType(1, "array", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValArray (node) => array2 := node.remote.Obtain(); ELSE ObValue.BadArgType(2, "array", self.name, opCode.name, loc); <*ASSERT FALSE*> END; badOp := 1; RETURN ObValue.ArrayCat(array1, array2); ELSE ObValue.BadOp(self.name, opCode.name, loc); <*ASSERT FALSE*> END; EXCEPT | ObValue.ServerError => ObValue.BadArgVal(badOp, "in range", self.name, opCode.name, loc); <*ASSERT FALSE*> | NetObj.Error (atoms) => ObValue.RaiseNetException( self.name & "_" & opCode.name, atoms, loc); <*ASSERT FALSE*> | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, self.name & "_" & opCode.name, loc); <*ASSERT FALSE*> END; END EvalArray;
net
package ============
TYPE NetCode = {Error, Who, Export, Import, ExportEngine, ImportEngine}; NetOpCode = ObLib.OpCode OBJECT code: NetCode; END; PackageNet = ObLib.T OBJECT OVERRIDES Eval := EvalNet; END; PROCEDURE============NewNetOC (name: TEXT; arity: INTEGER; code: NetCode): NetOpCode = BEGIN RETURN NEW(NetOpCode, name := name, arity := arity, code := code); END NewNetOC; PROCEDURESetupNet () = TYPE OpCodes = ARRAY OF ObLib.OpCode; VAR opCodes: REF OpCodes; BEGIN opCodes := NEW(REF OpCodes, NUMBER(NetCode)); opCodes^ := OpCodes{NewNetOC("failure", -1, NetCode.Error), NewNetOC("who", 1, NetCode.Who), NewNetOC("export", 3, NetCode.Export), NewNetOC("import", 2, NetCode.Import), NewNetOC("exportEngine", 3, NetCode.ExportEngine), NewNetOC("importEngine", 2, NetCode.ImportEngine)}; ObLib.Register(NEW(PackageNet, name := "net", opCodes := opCodes)); END SetupNet; PROCEDUREEvalNet ( self : PackageNet; opCode: ObLib.OpCode; <*UNUSED*> arity : ObLib.OpArity; READONLY args : ObValue.ArgArray; <*UNUSED*> temp : BOOLEAN; loc : SynLocation.T ): ObValue.Val RAISES {ObValue.Error, ObValue.Exception} = VAR text1, text2: TEXT; BEGIN CASE NARROW(opCode, NetOpCode).code OF | NetCode.Error => RETURN ObValue.netException; | NetCode.Who => TYPECASE args[1] OF | ObValue.ValObj (node) => RETURN NetObjectWho(node, loc); | ObValue.ValEngine (node) => RETURN NetEngineWho(node.remote, loc); ELSE ObValue.BadArgType( 1, "object or engine", self.name, opCode.name, loc); <*ASSERT FALSE*> END; | NetCode.Export => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValText (node) => text2 := node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[3] OF | ObValue.ValRemObj, ObValue.ValReplObj, ObValue.ValSimpleObj => ELSE ObValue.BadArgType(3, "object", self.name, opCode.name, loc); <*ASSERT FALSE*> END; NetExport(text1, text2, args[3], loc); RETURN args[3]; | NetCode.Import => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValText (node) => text2 := node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN NetImport(text1, text2, loc); | NetCode.ExportEngine => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValText (node) => text2 := node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; NetExportEngine(text1, text2, args[3], loc); RETURN ObValue.valOk; | NetCode.ImportEngine => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValText (node) => text2 := node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN NetImportEngine(text1, text2, loc); ELSE ObValue.BadOp(self.name, opCode.name, loc); <*ASSERT FALSE*> END; END EvalNet; PROCEDURENetLocate ( server : TEXT; VAR (*out*) address : TEXT; VAR (*out*) netAddress: NetObj.Address; location : SynLocation.T ) RAISES {ObValue.Exception} = BEGIN IF Text.Empty(server) THEN address := ObValue.machineAddress; netAddress := NIL; ELSE address := server; TRY netAddress := NetObj.Locate(address); EXCEPT | NetObj.Invalid, NetObj.Error => ObValue.RaiseNetException("Could not locate name server for '" & address & "'", NIL, location); | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, "net_locate", location); END; END; END NetLocate; PROCEDURENetObjectWho (valObj: ObValue.ValObj; loc: SynLocation.T): ObValue.Val RAISES {ObValue.Exception} = VAR protected, serialized: BOOLEAN; BEGIN TRY RETURN ObValue.NewText(valObj.Who( (*out*)protected, (*out*) serialized)); EXCEPT | SharedObj.Error (atoms) => ObValue.RaiseSharedException("net_who", atoms, loc); <*ASSERT FALSE*> | NetObj.Error (atoms) => ObValue.RaiseNetException("net_who", atoms, loc); <*ASSERT FALSE*> | Thread.Alerted => ObValue.RaiseException(ObValue.threadAlerted, "net_who", loc); <*ASSERT FALSE*> END; END NetObjectWho; PROCEDURENetEngineWho (remObj: ObValue.RemEngine; loc: SynLocation.T): ObValue.Val RAISES {ObValue.Exception} = BEGIN TRY RETURN ObValue.NewText(remObj.Who()); EXCEPT | NetObj.Error (atoms) => ObValue.RaiseNetException("net_who", atoms, loc); <*ASSERT FALSE*> | Thread.Alerted => ObValue.RaiseException(ObValue.threadAlerted, "net_who", loc); <*ASSERT FALSE*> END; END NetEngineWho; PROCEDURENetExport (name, server: TEXT; valObj : ObValue.ValObj; loc : SynLocation.T ) RAISES {ObValue.Exception} = VAR address : TEXT; netAddress: NetObj.Address; BEGIN NetLocate(server, (*out*) address, (*out*) netAddress, loc); TRY TYPECASE valObj OF | ObValue.ValRemObj (o) => NetObj.Export(name, o.remote, netAddress); | ObValue.ValReplObj (o) => NetObj.Export( name, NEW(ObValue.NonRemObjHookServer).init(o), netAddress); | ObValue.ValSimpleObj (o) => NetObj.Export( name, NEW(ObValue.NonRemObjHookServer).init(o), netAddress); ELSE <*ASSERT FALSE*> END; EXCEPT | NetObj.Error (atoms) => ObValue.RaiseNetException( "net_export: '" & name & "' at '" & address & "'", atoms, loc); | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, "net_export: '" & name & "' at '" & address & "'", loc); END; TYPECASE valObj OF | ObValue.ValRemObj (remObj) => TYPECASE remObj.remote OF | ObValue.RemObjServer (serv) => IF Text.Empty(serv.who) THEN serv.who := name & "@" & address; END; ELSE END; ELSE END; END NetExport; PROCEDURENetImport (name, server: TEXT; loc: SynLocation.T): ObValue.Val RAISES {ObValue.Exception} = VAR address : TEXT; netAddress: NetObj.Address; netObj : NetObj.T; BEGIN NetLocate(server, (*out*) address, (*out*) netAddress, loc); TRY netObj := NetObj.Import(name, netAddress); EXCEPT | NetObj.Error (atoms) => ObValue.RaiseNetException( "net_import: '" & name & "' at '" & address & "'", atoms, loc); <*ASSERT FALSE*> | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, "net_import: '" & name & "' at '" & address & "'", loc); <*ASSERT FALSE*> END; IF netObj = NIL THEN ObValue.RaiseException( ObValue.netException, "net_import: '" & name & "' was not found at '" & address & "'", loc); <*ASSERT FALSE*> END; TYPECASE netObj OF | ObValue.RemObj (remObj) => RETURN NEW(ObValue.ValRemObj, remote := remObj); | ObValue.NonRemObjHook (hook) => TRY RETURN hook.Get(); EXCEPT | NetObj.Error (atoms) => ObValue.RaiseNetException("net_import: '" & name & "' at '" & address & "'", atoms, loc); <*ASSERT FALSE*> | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, "net_import: '" & name & "' at '" & address & "'", loc); <*ASSERT FALSE*> END; ELSE ObValue.RaiseException( ObValue.netException, "net_import failed: '" & name & "' at '" & address & "' is not a network object", loc); <*ASSERT FALSE*> END; END NetImport; PROCEDURENetExportEngine (name, server: TEXT; arg : ObValue.Val; loc : SynLocation.T) RAISES {ObValue.Exception} = VAR address : TEXT; netAddress: NetObj.Address; remEngine : ObValue.RemEngine; BEGIN NetLocate(server, (*out*) address, (*out*) netAddress, loc); remEngine := NEW(ObValue.RemEngineServer, who := name & "@" & address, arg := arg); TRY NetObj.Export(name, remEngine, netAddress); EXCEPT | NetObj.Error (atoms) => ObValue.RaiseNetException("net_exportEngine: '" & name & "' at '" & address & "'", atoms, loc); | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, "net_exportEngine: '" & name & "' at '" & address & "'", loc); END; END NetExportEngine; PROCEDURENetImportEngine (name, server: TEXT; loc: SynLocation.T): ObValue.Val RAISES {ObValue.Exception} = VAR address : TEXT; netAddress: NetObj.Address; netObj : NetObj.T; BEGIN NetLocate(server, (*out*) address, (*out*) netAddress, loc); TRY netObj := NetObj.Import(name, netAddress); EXCEPT | NetObj.Error (atoms) => ObValue.RaiseNetException("net_importEngine: '" & name & "' at '" & address & "'", atoms, loc); <*ASSERT FALSE*> | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, "net_importEngine: '" & name & "' at '" & address & "'", loc); <*ASSERT FALSE*> END; IF netObj = NIL THEN ObValue.RaiseException( ObValue.netException, "net_importEngine: '" & name & "' was not found at '" & address & "'", loc); <*ASSERT FALSE*> END; TYPECASE netObj OF | ObValue.RemEngine (remEngine) => RETURN NEW(ObValue.ValEngine, remote := remEngine); ELSE ObValue.RaiseException( ObValue.netException, "net_importEngine failed: '" & name & "' at '" & address & "' is not a network engine", loc); <*ASSERT FALSE*> END; END NetImportEngine;
replica
package ============
TYPE ReplicaCode = {Error, Fatal, AcquireGlobalLock, ReleaseGlobalLock, SetNodeName, SetDefaultSequencer, Notify, CancelNotifier, DumpState}; ReplicaOpCode = ObLib.OpCode OBJECT code: ReplicaCode; END; PackageReplica = ObLib.T OBJECT OVERRIDES Eval := EvalReplica; END; PROCEDURE============NewReplicaOC (name : TEXT; arity : INTEGER; code : ReplicaCode; fixity: ObLib.OpFixity := ObLib.OpFixity.Qualified): ReplicaOpCode = BEGIN RETURN NEW(ReplicaOpCode, name := name, arity := arity, code := code, fixity := fixity); END NewReplicaOC; PROCEDURESetupReplica () = TYPE OpCodes = ARRAY OF ObLib.OpCode; VAR opCodes: REF OpCodes; BEGIN opCodes := NEW(REF OpCodes, NUMBER(ReplicaCode)); opCodes^ := OpCodes{ NewReplicaOC("failure", -1, ReplicaCode.Error), NewReplicaOC("fatal", -1, ReplicaCode.Fatal), NewReplicaOC("acquire", 1, ReplicaCode.AcquireGlobalLock), NewReplicaOC("release", 1, ReplicaCode.ReleaseGlobalLock), NewReplicaOC("setNodeName", 1, ReplicaCode.SetNodeName), NewReplicaOC("notify", 2, ReplicaCode.Notify), NewReplicaOC("cancelNotifier", 1, ReplicaCode.CancelNotifier), NewReplicaOC( "setDefaultSequencer", 2, ReplicaCode.SetDefaultSequencer), NewReplicaOC("dumpState", 0, ReplicaCode.DumpState)}; ObLib.Register( NEW(PackageReplica, name := "replica", opCodes := opCodes)); END SetupReplica; PROCEDUREEvalReplica ( self : PackageReplica; opCode: ObLib.OpCode; <*UNUSED*> arity : ObLib.OpArity; READONLY args : ObValue.ArgArray; <*UNUSED*> temp : BOOLEAN; loc : SynLocation.T ): ObValue.Val RAISES {ObValue.Error, ObValue.Exception} = VAR text1, text2: TEXT; BEGIN CASE NARROW(opCode, ReplicaOpCode).code OF | ReplicaCode.Error => RETURN ObValue.sharedException; | ReplicaCode.Fatal => RETURN ObValue.sharedFatal; | ReplicaCode.Notify => RETURN ReplicaNotify(args[1], args[2], loc); | ReplicaCode.CancelNotifier => ReplicaCancelNotifier(args[1], loc); RETURN ObValue.valOk; | ReplicaCode.DumpState => ReplicaDumpState(loc); RETURN ObValue.valOk; | ReplicaCode.AcquireGlobalLock => TYPECASE args[1] OF | ObValue.ValReplObj => ELSE ObValue.BadArgType( 1, "replicated object", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN ReplicaAcquireLock(args[1], loc); | ReplicaCode.ReleaseGlobalLock => TYPECASE args[1] OF | ObValue.ValReplObj => ELSE ObValue.BadArgType( 1, "replicated object", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN ReplicaReleaseLock(args[1], loc); | ReplicaCode.SetNodeName => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN ReplicaSetNodeName(text1, loc); | ReplicaCode.SetDefaultSequencer => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValText (node) => text2 := node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN ReplicaSetDefaultSequencer(text1, text2, loc); ELSE ObValue.BadOp(self.name, opCode.name, loc); <*ASSERT FALSE*> END; END EvalReplica; PROCEDUREReplicaNotify (valObj : ObValue.Val; notifyObj: ObValue.ValObj; loc : SynLocation.T ): ObValue.Val RAISES {ObValue.Exception} = BEGIN TYPECASE valObj OF | ObValue.ValReplObj (obj) => TYPECASE notifyObj OF | ObValue.ValSimpleObj (notifier) => RETURN ObValueNotify.New(obj, notifier, loc); ELSE ObValue.RaiseException( ObValue.sharedException, "replica_notify failed: '" & "second argument must be a simple object", loc); <*ASSERT FALSE*> END; ELSE ObValue.RaiseException( ObValue.sharedException, "replica_notify failed: '" & "first argument must be a replicated object", loc); <*ASSERT FALSE*> END; END ReplicaNotify; PROCEDUREReplicaCancelNotifier (notifier: ObValue.Val; loc: SynLocation.T) RAISES {ObValue.Exception} = BEGIN TYPECASE notifier OF | ObValueNotify.ValObjCB (obj) => obj.cancel(); ELSE ObValue.RaiseException( ObValue.sharedException, "replica_cancelNotifier failed: '" & "first argument must be a notifier callback", loc); <*ASSERT FALSE*> END; END ReplicaCancelNotifier; PROCEDUREReplicaAcquireLock (valObj: ObValue.ValObj; loc: SynLocation.T): ObValue.Val RAISES {ObValue.Exception} = BEGIN TRY TYPECASE valObj OF | ObValue.ValReplObj (obj) => SharedObj.AcquireGlobalLock(obj.replica); ELSE ObValue.RaiseException( ObValue.sharedException, "replica_acquire failed: '" & "argument must be a replicated object", loc); <*ASSERT FALSE*> END; EXCEPT | SharedObj.Error (atoms) => ObValue.RaiseSharedException("replica_acquire: ", atoms, loc); | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, "replica_acquire: ", loc); END; RETURN ObValue.valOk; END ReplicaAcquireLock; PROCEDUREReplicaReleaseLock (valObj: ObValue.ValObj; loc: SynLocation.T): ObValue.Val RAISES {ObValue.Exception} = BEGIN TRY TYPECASE valObj OF | ObValue.ValReplObj (obj) => SharedObj.ReleaseGlobalLock(obj.replica); ELSE ObValue.RaiseException( ObValue.sharedException, "replica_release failed: '" & "argument must be a replicated object", loc); <*ASSERT FALSE*> END; EXCEPT | SharedObj.Error (atoms) => ObValue.RaiseSharedException("replica_release: ", atoms, loc); <*ASSERT FALSE*> | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, "replica_release: ", loc); <*ASSERT FALSE*> END; RETURN ObValue.valOk; END ReplicaReleaseLock; PROCEDUREReplicaSetNodeName (name: TEXT; loc: SynLocation.T): ObValue.Val RAISES {ObValue.Exception} = BEGIN TRY IF Text.Equal(name, "") THEN name := ObValue.machineAddress; END; SharedObjRT.ExportSpace(name); RETURN ObValue.NewText(name); EXCEPT | SharedObj.Error (atoms) => ObValue.RaiseSharedException("replica_setNodeName: ", atoms, loc); <*ASSERT FALSE*> | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, "replica_setNodeName: ", loc); <*ASSERT FALSE*> END; END ReplicaSetNodeName; PROCEDUREReplicaDumpState (loc: SynLocation.T) RAISES {ObValue.Exception} = BEGIN TRY SharedObjRT.LocalSpace().printState(); EXCEPT | NetObj.Error (atoms) => ObValue.RaiseNetException("replica_dumpState: ", atoms, loc); <*ASSERT FALSE*> | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, "replica_setNodeName: ", loc); <*ASSERT FALSE*> END; END ReplicaDumpState; PROCEDUREReplicaSetDefaultSequencer (host, name: TEXT; loc: SynLocation.T): ObValue.Val RAISES {ObValue.Exception} = VAR space: ObjectSpace.T; BEGIN TRY IF Text.Equal("", host) THEN WITH defhost = Env.Get("SEQUENCERHOST") DO IF defhost # NIL THEN host := defhost; END; END; END; IF Text.Equal("", name) THEN WITH defname = Env.Get("SEQUENCERNAME") DO IF defname # NIL THEN name := defname; END; END; END; IF NOT Text.Equal("", host) OR NOT Text.Equal("", name) THEN space := SharedObjRT.ImportSpace(host, name); IF space = NIL THEN ObValue.RaiseException( ObValue.sharedException, "replica_setDefaultSequencer: node " & name & "@" & host & " is unavailable", loc); <*ASSERT FALSE*> END; ELSE space := SharedObjRT.LocalSpace(); END; SharedObjRT.SetDfltSequencer(space); RETURN ObValue.valOk; EXCEPT | SharedObj.Error (atoms) => ObValue.RaiseSharedException( "replica_setDefaultSequencer: ", atoms, loc); <*ASSERT FALSE*> | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, "replica_setDefaultSequencer: ", loc); <*ASSERT FALSE*> END; END ReplicaSetDefaultSequencer;
thread
package ============
TYPE ThreadCode = {Alerted, NewMutex, NewCondition, Self, Fork, Join, Wait, Acquire, Release, Broadcast, Signal, Pause, Alert, TestAlert, AlertWait, AlertJoin, AlertPause, Lock, NewPool, AddWork, StealWorker, FinishWork}; ThreadOpCode = ObLib.OpCode OBJECT code: ThreadCode; END; PackageThread = ObLib.T OBJECT OVERRIDES Eval := EvalThread; END; PROCEDUREIsMutex (self: ValMutex; other: ObValue.ValAnything): BOOLEAN = BEGIN TYPECASE other OF ValMutex (oth) => RETURN self.mutex = oth.mutex; ELSE RETURN FALSE END; END IsMutex; PROCEDUREIsCondition (self: ValCondition; other: ObValue.ValAnything): BOOLEAN = BEGIN TYPECASE other OF ValCondition (oth) => RETURN self.condition = oth.condition; ELSE RETURN FALSE END; END IsCondition; PROCEDUREIsThread (self: ValThread; other: ObValue.ValAnything): BOOLEAN = BEGIN TYPECASE other OF ValThread (oth) => RETURN self.thread = oth.thread; ELSE RETURN FALSE END; END IsThread; PROCEDUREIsPool (self: ValPool; other: ObValue.ValAnything): BOOLEAN = BEGIN TYPECASE other OF ValPool (oth) => RETURN self.pool = oth.pool; ELSE RETURN FALSE END; END IsPool; PROCEDURECopyMutex (<*UNUSED*> self: ObValue.ValAnything; <*UNUSED*> tbl : ObValue.Tbl; <*UNUSED*> loc : SynLocation.T ): ObValue.ValAnything = BEGIN RETURN NEW(ValMutex, what := "<a Thread.Mutex>", picklable := FALSE, tag:= "Thread`Mutex", mutex := NEW(Thread.Mutex)); END CopyMutex; PROCEDURECopyCondition (<*UNUSED*> self: ObValue.ValAnything; <*UNUSED*> tbl : ObValue.Tbl; <*UNUSED*> loc : SynLocation.T ): ObValue.ValAnything = BEGIN RETURN NEW(ValCondition, what := "<a Thread.Condition>", tag:="Thread`Condition", picklable := FALSE, condition := NEW(Thread.Condition)); END CopyCondition; TYPE ObliqThreadClosure = Thread.SizedClosure OBJECT fun : ObValue.ValFun; location : SynLocation.T; result : ObValue.Val; error : ObValue.ErrorPacket; exception: ObValue.ExceptionPacket; OVERRIDES apply := ApplyThreadClosure; END; TYPE ObliqWork = Work.T OBJECT fun : ObValue.ValFun; location : SynLocation.T; OVERRIDES handle := HandleWork; END; PROCEDUREMsg (swr : SynWr.T; msg : TEXT; sourceLocation: SynLocation.T) = BEGIN SynWr.Beg(swr, 2, loud := TRUE); SynWr.Text(swr, msg, loud := TRUE); SynLocation.PrintLocation(swr, sourceLocation); SynWr.End(swr, loud := TRUE); SynWr.NewLine(swr, loud := TRUE); SynWr.Flush(swr, loud := TRUE); END Msg; PROCEDUREApplyThreadClosure (self: ObliqThreadClosure): REFANY = VAR noArgs: ARRAY [0 .. -1] OF ObValue.Val; BEGIN TRY self.result := ObEval.Call(self.fun, noArgs, self.location); EXCEPT | ObValue.Error (packet) => self.error := packet; ObValue.ErrorMsg(SynWr.err, packet); Msg(SynWr.err, "<Thread.T> terminated by execution error", self.location); | ObValue.Exception (packet) => self.exception := packet; ObValue.ExceptionMsg(SynWr.err, packet); Msg(SynWr.err, "<Thread.T> terminated by unhandled exception", self.location); END; RETURN self; END ApplyThreadClosure; PROCEDUREHandleWork (self: ObliqWork) = VAR noArgs: ARRAY [0 .. -1] OF ObValue.Val; BEGIN TRY EVAL ObEval.Call(self.fun, noArgs, self.location); EXCEPT | ObValue.Error (packet) => ObValue.ErrorMsg(SynWr.err, packet); Msg(SynWr.err, "<work> terminated by execution error", self.location); | ObValue.Exception (packet) => ObValue.ExceptionMsg(SynWr.err, packet); Msg(SynWr.err, "<work> terminated by unhandled exception", self.location); END; END HandleWork; PROCEDURENewPool (maxThreads, idleThreads, stackSize: INTEGER): ValPool = VAR pool : WorkerPool.T; BEGIN stackSize := MIN(MAX(stackSize, 4096), LAST(CARDINAL)); pool := NEW(WorkerPool.T).init(maxThreads, idleThreads, stackSize); RETURN NEW(ValPool, what := "<a WorkerPool.T>", picklable := FALSE, tag:="Workerpool`T", pool := pool); END NewPool; PROCEDUREForkThread (fun : ObValue.ValFun; stackSize: INTEGER; loc : SynLocation.T ): ValThread = VAR thread : Thread.T; threadClosure: ObliqThreadClosure; BEGIN stackSize := MIN(MAX(stackSize, 4096), LAST(CARDINAL)); threadClosure := NEW(ObliqThreadClosure, stackSize := stackSize, fun := fun, location := loc, result := NIL, error := NIL, exception := NIL); thread := Thread.Fork(threadClosure); RETURN NEW(ValThread, what := "<a Thread.T>", picklable := FALSE, tag:="Thread`T", thread := thread, joinedMu := NEW(Thread.Mutex), joined := FALSE); END ForkThread; PROCEDUREJoinThread (threadVal: ValThread; loc: SynLocation.T): ObValue.Val RAISES {ObValue.Error, ObValue.Exception} = VAR threadClosure: ObliqThreadClosure; BEGIN LOCK threadVal.joinedMu DO IF threadVal.joined THEN ObValue.RaiseError("Thread already joined", loc); ELSE threadVal.joined := TRUE; END; END; threadClosure := Thread.Join(threadVal.thread); IF threadClosure.error # NIL THEN RAISE ObValue.Error(threadClosure.error); ELSIF threadClosure.exception # NIL THEN RAISE ObValue.Exception(threadClosure.exception); ELSE RETURN threadClosure.result; END; END JoinThread; PROCEDURENewThreadOC (name : TEXT; arity : INTEGER; code : ThreadCode; fixity: ObLib.OpFixity := ObLib.OpFixity.Qualified): ThreadOpCode = BEGIN RETURN NEW(ThreadOpCode, name := name, arity := arity, code := code, fixity := fixity); END NewThreadOC; PROCEDURESetupThread () = TYPE OpCodes = ARRAY OF ObLib.OpCode; VAR opCodes: REF OpCodes; BEGIN opCodes := NEW(REF OpCodes, NUMBER(ThreadCode)); opCodes^ := OpCodes{NewThreadOC("alerted", -1, ThreadCode.Alerted), NewThreadOC( "mutex", 0, ThreadCode.NewMutex, ObLib.OpFixity.Prefix), NewThreadOC("condition", 0, ThreadCode.NewCondition, ObLib.OpFixity.Prefix), NewThreadOC("self", 0, ThreadCode.Self), NewThreadOC( "fork", 2, ThreadCode.Fork, ObLib.OpFixity.Prefix), NewThreadOC( "join", 1, ThreadCode.Join, ObLib.OpFixity.Prefix), NewThreadOC( "wait", 2, ThreadCode.Wait, ObLib.OpFixity.Prefix), NewThreadOC("acquire", 1, ThreadCode.Acquire), NewThreadOC("release", 1, ThreadCode.Release), NewThreadOC("broadcast", 1, ThreadCode.Broadcast, ObLib.OpFixity.Prefix), NewThreadOC( "signal", 1, ThreadCode.Signal, ObLib.OpFixity.Prefix), NewThreadOC( "pause", 1, ThreadCode.Pause, ObLib.OpFixity.Prefix), NewThreadOC("alert", 1, ThreadCode.Alert), NewThreadOC("testAlert", 0, ThreadCode.TestAlert), NewThreadOC("alertWait", 2, ThreadCode.AlertWait), NewThreadOC("alertJoin", 1, ThreadCode.AlertJoin), NewThreadOC("alertPause", 1, ThreadCode.AlertPause), NewThreadOC("pool", 3, ThreadCode.NewPool), NewThreadOC("addWork", 2, ThreadCode.AddWork), NewThreadOC("stealWorker", 1, ThreadCode.StealWorker), NewThreadOC("finish", 1, ThreadCode.FinishWork), NewThreadOC("lock", 2, ThreadCode.Lock)}; ObLib.Register( NEW(PackageThread, name := "thread", opCodes := opCodes)); ObValue.InhibitTransmission( TYPECODE(ValMutex), "mutexes cannot be transmitted/duplicated"); ObValue.InhibitTransmission( TYPECODE(ValCondition), "conditions cannot be transmitted/duplicated"); ObValue.InhibitTransmission( TYPECODE(ValThread), "threads cannot be transmitted/duplicated"); END SetupThread; PROCEDUREEvalThread ( self : PackageThread; opCode: ObLib.OpCode; <*UNUSED*> arity : ObLib.OpArity; READONLY args : ObValue.ArgArray; <*UNUSED*> temp : BOOLEAN; loc : SynLocation.T ): ObValue.Val RAISES {ObValue.Error, ObValue.Exception} = VAR thread1 : Thread.T; threadVal1: ValThread; fun1 : ObValue.ValFun; mutex1 : Thread.Mutex; condition1: Thread.Condition; longReal1 : LONGREAL; int1,int2,int3: INTEGER; noArgs : ARRAY [0 .. -1] OF ObValue.Val; pool1 : WorkerPool.T; BEGIN CASE NARROW(opCode, ThreadOpCode).code OF | ThreadCode.Alerted => RETURN ObValue.threadAlerted; | ThreadCode.NewMutex => mutex1 := NEW(Thread.Mutex); RETURN NEW(ValMutex, what := "<a Thread.Mutex>", tag:="Thread`Mutex", picklable := FALSE, mutex := mutex1); | ThreadCode.NewCondition => condition1 := NEW(Thread.Condition); RETURN NEW(ValCondition, what := "<a Thread.Condition>", tag:="Thread`Condition", picklable := FALSE, condition := condition1); | ThreadCode.Self => thread1 := Thread.Self(); RETURN NEW(ValThread, what := "<a Thread.T>", picklable := FALSE, tag:="Thread`T", thread := thread1, joinedMu := NEW(Thread.Mutex), joined := FALSE); | ThreadCode.Fork => TYPECASE args[1] OF | ObValue.ValFun (node) => fun1 := node; ELSE ObValue.BadArgType(1, "procedure", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(2, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN ForkThread(fun1, int1, loc); | ThreadCode.Join => TYPECASE args[1] OF | ValThread (node) => threadVal1 := node; ELSE ObValue.BadArgType(1, "thread", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN JoinThread(threadVal1, loc); | ThreadCode.Wait => TYPECASE args[1] OF | ValMutex (node) => mutex1 := node.mutex; ELSE ObValue.BadArgType(1, "mutex", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ValCondition (node) => condition1 := node.condition; ELSE ObValue.BadArgType(2, "condition", self.name, opCode.name, loc); <*ASSERT FALSE*> END; Thread.Wait(mutex1, condition1); RETURN ObValue.valOk; | ThreadCode.Acquire => TYPECASE args[1] OF | ValMutex (node) => mutex1 := node.mutex; ELSE ObValue.BadArgType(1, "mutex", self.name, opCode.name, loc); <*ASSERT FALSE*> END; Thread.Acquire(mutex1); RETURN ObValue.valOk; | ThreadCode.Release => TYPECASE args[1] OF | ValMutex (node) => mutex1 := node.mutex; ELSE ObValue.BadArgType(1, "mutex", self.name, opCode.name, loc); <*ASSERT FALSE*> END; Thread.Release(mutex1); RETURN ObValue.valOk; | ThreadCode.Broadcast => TYPECASE args[1] OF | ValCondition (node) => condition1 := node.condition; ELSE ObValue.BadArgType(1, "condition", self.name, opCode.name, loc); <*ASSERT FALSE*> END; Thread.Broadcast(condition1); RETURN ObValue.valOk; | ThreadCode.Signal => TYPECASE args[1] OF | ValCondition (node) => condition1 := node.condition; ELSE ObValue.BadArgType(1, "condition", self.name, opCode.name, loc); <*ASSERT FALSE*> END; Thread.Signal(condition1); RETURN ObValue.valOk; | ThreadCode.Pause => TYPECASE args[1] OF | ObValue.ValReal (node) => longReal1 := node.real; ELSE ObValue.BadArgType(1, "real", self.name, opCode.name, loc); <*ASSERT FALSE*> END; IF longReal1 < 0.0d0 THEN ObValue.BadArgVal(1, "non-negative", self.name, opCode.name, loc); <*ASSERT FALSE*> END; Thread.Pause(longReal1); RETURN ObValue.valOk; | ThreadCode.Alert => TYPECASE args[1] OF | ValThread (node) => thread1 := node.thread; ELSE ObValue.BadArgType(1, "thread", self.name, opCode.name, loc); <*ASSERT FALSE*> END; Thread.Alert(thread1); RETURN ObValue.valOk; | ThreadCode.TestAlert => IF Thread.TestAlert() THEN RETURN true ELSE RETURN false END; | ThreadCode.AlertJoin => TYPECASE args[1] OF | ValThread (node) => thread1 := node.thread; ELSE ObValue.BadArgType(1, "thread", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TRY RETURN Thread.AlertJoin(thread1); EXCEPT Thread.Alerted => ObValue.RaiseException(ObValue.threadAlerted, opCode.name, loc); <*ASSERT FALSE*> END; | ThreadCode.AlertWait => TYPECASE args[1] OF | ValMutex (node) => mutex1 := node.mutex; ELSE ObValue.BadArgType(1, "mutex", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ValCondition (node) => condition1 := node.condition; ELSE ObValue.BadArgType(2, "condition", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TRY Thread.AlertWait(mutex1, condition1); RETURN ObValue.valOk; EXCEPT Thread.Alerted => ObValue.RaiseException(ObValue.threadAlerted, opCode.name, loc); <*ASSERT FALSE*> END; | ThreadCode.AlertPause => TYPECASE args[1] OF | ObValue.ValReal (node) => longReal1 := node.real; ELSE ObValue.BadArgType(1, "real", self.name, opCode.name, loc); <*ASSERT FALSE*> END; IF longReal1 < 0.0d0 THEN ObValue.BadArgVal(1, "non-negative", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TRY Thread.AlertPause(longReal1); RETURN ObValue.valOk; EXCEPT Thread.Alerted => ObValue.RaiseException(ObValue.threadAlerted, opCode.name, loc); <*ASSERT FALSE*> END; | ThreadCode.Lock => TYPECASE args[1] OF | ValMutex (node) => mutex1 := node.mutex; ELSE ObValue.BadArgType(1, "mutex", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValFun (node) => fun1 := node; ELSE ObValue.BadArgType(2, "procedure", self.name, opCode.name, loc); <*ASSERT FALSE*> END; LOCK mutex1 DO RETURN ObEval.Call(fun1, noArgs, loc) END; | ThreadCode.NewPool => TYPECASE args[1] OF | ObValue.ValInt (node) => int1 := node.int; ELSE ObValue.BadArgType(1, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValInt (node) => int2 := node.int; ELSE ObValue.BadArgType(2, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[3] OF | ObValue.ValInt (node) => int3 := node.int; ELSE ObValue.BadArgType(3, "int", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN NewPool(int1, int2, int3); | ThreadCode.AddWork => TYPECASE args[1] OF | ValPool (node) => pool1 := node.pool; ELSE ObValue.BadArgType(1, "pool", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValFun (node) => fun1 := node; ELSE ObValue.BadArgType(2, "procedure", self.name, opCode.name, loc); <*ASSERT FALSE*> END; pool1.add(NEW(ObliqWork, fun := fun1, location := loc)); RETURN ObValue.valOk; | ThreadCode.StealWorker => TYPECASE args[1] OF | ValPool (node) => pool1 := node.pool; ELSE ObValue.BadArgType(1, "pool", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN NEW(ObValue.ValBool, bool := pool1.stealWorker()); | ThreadCode.FinishWork => TYPECASE args[1] OF | ValPool (node) => pool1 := node.pool; ELSE ObValue.BadArgType(1, "pool", self.name, opCode.name, loc); <*ASSERT FALSE*> END; pool1.finish(); RETURN ObValue.valOk; ELSE ObValue.BadOp(self.name, opCode.name, loc); <*ASSERT FALSE*> END; END EvalThread;
(* ============ reflect
package ============
the possible option tags are: valOk, valBool, valChar, valText, valInt, valReal, valException, valOption, valVar, valArray, valMethod, valClosure, valAlias, valObject, valAnything objects will have the ta
TYPE ReflectCode = {Error, isVar, (* does the ide refer to an updatable value? *) isArray, (* is the Val an Array? *) isObject, (* an Object? *) isPrimitive, (* a Primitive? *) isOpaque, (* is this a opaque wrapper of an M3 value? *) isSimple, isReplicated, isRemote, objectType, (* get an option describing which of the 3 it is *) isProtected, isSynchronized, isClosure, (* is this value a closure? *) isCompatible, (* does o1 have AT LEAST the same fields as o2? *) (* the fields must be compatible (meth=meth, non-meth=non-meth) and have the same number of params, etc *) tagCompatible, (* pass an object and an array of option tagged objects, return the object option tagged with the tag of the first array element it is compatible with *) (* we do not allow method fields to be retrieved *) getType, (* return an option describing the type *) getFields, (* return an array of non-method fields of o *) getField, (* return the named non-method field of o *) isAlias, (* is the named slot an alias? *) getName, getValue, setValue, invoke, equals, toString}; ReflectOpCode = ObLib.OpCode OBJECT code: ReflectCode; END; PackageReflect = ObLib.T OBJECT OVERRIDES Eval := EvalReflect; END; PROCEDURE NewReflectOC (name : TEXT; arity : INTEGER; code : ReflectCode; fixity: ObLib.OpFixity := ObLib.OpFixity.Qualified): ReflectOpCode = BEGIN RETURN NEW(ReflectOpCode, name := name, arity := arity, code := code, fixity := fixity); END NewReflectOC; PROCEDURE SetupReflect () = TYPE OpCodes = ARRAY OF ObLib.OpCode; VAR opCodes: REF OpCodes; BEGIN opCodes := NEW(REF OpCodes, NUMBER(ReflectCode)); opCodes^ := OpCodes{ NewReflectOC("failure", -1, ReflectCode.Error), NewReflectOC("fatal", -1, ReflectCode.Fatal), NewReflectOC("acquire", 1, ReflectCode.AcquireGlobalLock), NewReflectOC("release", 1, ReflectCode.ReleaseGlobalLock), NewReflectOC("setNodeName", 1, ReflectCode.SetNodeName), NewReflectOC("notify", 2, ReflectCode.Notify), NewReflectOC("cancelNotifier", 1, ReflectCode.CancelNotifier), NewReflectOC( "setDefaultSequencer", 2, ReflectCode.SetDefaultSequencer), NewReflectOC("dumpState", 0, ReflectCode.DumpState)}; ObLib.Register( NEW(PackageReflect, name := "reflect", opCodes := opCodes)); END SetupReflect; PROCEDURE EvalReflect ( self : PackageReflect; opCode: ObLib.OpCode; <*UNUSED*> arity : ObLib.OpArity; READONLY args : ObValue.ArgArray; <*UNUSED*> temp : BOOLEAN; loc : SynLocation.T ): ObValue.Val RAISES {ObValue.Error, ObValue.Exception} = VAR text1, text2: TEXT; BEGIN CASE NARROW(opCode, ReflectOpCode).code OF | ReflectCode.Error => RETURN ObValue.sharedException; | ReflectCode.Fatal => RETURN ObValue.sharedFatal; | ReflectCode.Notify => RETURN ReflectNotify(args[1], args[2], loc); | ReflectCode.CancelNotifier => ReflectCancelNotifier(args[1], loc); RETURN ObValue.valOk; | ReflectCode.DumpState => ReflectDumpState(loc); RETURN ObValue.valOk; | ReflectCode.AcquireGlobalLock => TYPECASE args[1] OF | ObValue.ValReplObj => ELSE ObValue.BadArgType( 1, "reflectted object", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN ReflectAcquireLock(args[1], loc); | ReflectCode.ReleaseGlobalLock => TYPECASE args[1] OF | ObValue.ValReplObj => ELSE ObValue.BadArgType( 1, "reflectted object", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN ReflectReleaseLock(args[1], loc); | ReflectCode.SetNodeName => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN ReflectSetNodeName(text1, loc); | ReflectCode.SetDefaultSequencer => TYPECASE args[1] OF | ObValue.ValText (node) => text1 := node.text; ELSE ObValue.BadArgType(1, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; TYPECASE args[2] OF | ObValue.ValText (node) => text2 := node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); <*ASSERT FALSE*> END; RETURN ReflectSetDefaultSequencer(text1, text2, loc); ELSE ObValue.BadOp(self.name, opCode.name, loc); <*ASSERT FALSE*> END; END EvalReflect; PROCEDURE ReflectNotify (valObj : ObValue.Val; notifyObj: ObValue.ValObj; loc : SynLocation.T ): ObValue.Val RAISES {ObValue.Exception} = BEGIN TYPECASE valObj OF | ObValue.ValReplObj (obj) => TYPECASE notifyObj OF | ObValue.ValSimpleObj (notifier) => RETURN ObValueNotify.New(obj, notifier, loc); ELSE ObValue.RaiseException( ObValue.sharedException, "reflect_notify failed: '" & "second argument must be a simple object", loc); <*ASSERT FALSE*> END; ELSE ObValue.RaiseException( ObValue.sharedException, "reflect_notify failed: '" & "first argument must be a reflectted object", loc); <*ASSERT FALSE*> END; END ReflectNotify; PROCEDURE ReflectCancelNotifier (notifier: ObValue.Val; loc: SynLocation.T) RAISES {ObValue.Exception} = BEGIN TYPECASE notifier OF | ObValueNotify.ValObjCB (obj) => obj.cancel(); ELSE ObValue.RaiseException( ObValue.sharedException, "reflect_cancelNotifier failed: '" & "first argument must be a notifier callback", loc); <*ASSERT FALSE*> END; END ReflectCancelNotifier; PROCEDURE ReflectAcquireLock (valObj: ObValue.ValObj; loc: SynLocation.T): ObValue.Val RAISES {ObValue.Exception} = BEGIN TRY TYPECASE valObj OF | ObValue.ValReplObj (obj) => SharedObj.AcquireGlobalLock(obj.reflect); ELSE ObValue.RaiseException( ObValue.sharedException, "reflect_acquire failed: '" & "argument must be a reflectted object", loc); <*ASSERT FALSE*> END; EXCEPT | SharedObj.Error (atoms) => ObValue.RaiseSharedException("reflect_acquire: ", atoms, loc); | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, "reflect_acquire: ", loc); END; RETURN ObValue.valOk; END ReflectAcquireLock; PROCEDURE ReflectReleaseLock (valObj: ObValue.ValObj; loc: SynLocation.T): ObValue.Val RAISES {ObValue.Exception} = BEGIN TRY TYPECASE valObj OF | ObValue.ValReplObj (obj) => SharedObj.ReleaseGlobalLock(obj.reflect); ELSE ObValue.RaiseException( ObValue.sharedException, "reflect_release failed: '" & "argument must be a reflectted object", loc); <*ASSERT FALSE*> END; EXCEPT | SharedObj.Error (atoms) => ObValue.RaiseSharedException("reflect_release: ", atoms, loc); <*ASSERT FALSE*> | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, "reflect_release: ", loc); <*ASSERT FALSE*> END; RETURN ObValue.valOk; END ReflectReleaseLock; PROCEDURE ReflectSetNodeName (name: TEXT; loc: SynLocation.T): ObValue.Val RAISES {ObValue.Exception} = BEGIN TRY IF Text.Equal(name, "") THEN name := ObValue.machineAddress; END; SharedObjRT.ExportSpace(name); RETURN ObValue.NewText(name); EXCEPT | SharedObj.Error (atoms) => ObValue.RaiseSharedException("reflect_setNodeName: ", atoms, loc); <*ASSERT FALSE*> | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, "reflect_setNodeName: ", loc); <*ASSERT FALSE*> END; END ReflectSetNodeName; PROCEDURE ReflectDumpState (loc: SynLocation.T) RAISES {ObValue.Exception} = BEGIN TRY SharedObjRT.LocalSpace().printState(); EXCEPT | NetObj.Error (atoms) => ObValue.RaiseNetException("reflect_dumpState: ", atoms, loc); <*ASSERT FALSE*> | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, "reflect_setNodeName: ", loc); <*ASSERT FALSE*> END; END ReflectDumpState; PROCEDURE ReflectSetDefaultSequencer (host, name: TEXT; loc: SynLocation.T): ObValue.Val RAISES {ObValue.Exception} = VAR space: ObjectSpace.T; BEGIN TRY IF Text.Equal("", host) THEN WITH defhost = Env.Get("SEQUENCERHOST") DO IF defhost # NIL THEN host := defhost; END; END; END; IF Text.Equal("", name) THEN WITH defname = Env.Get("SEQUENCERNAME") DO IF defname # NIL THEN name := defname; END; END; END; IF NOT Text.Equal("", host) OR NOT Text.Equal("", name) THEN space := SharedObjRT.ImportSpace(host, name); IF space = NIL THEN ObValue.RaiseException( ObValue.sharedException, "reflect_setDefaultSequencer: node " & name & "@" & host & " is unavailable", loc); <*ASSERT FALSE*> END; ELSE space := SharedObjRT.LocalSpace(); END; SharedObjRT.SetDfltSequencer(space); RETURN ObValue.valOk; EXCEPT | SharedObj.Error (atoms) => ObValue.RaiseSharedException( "reflect_setDefaultSequencer: ", atoms, loc); <*ASSERT FALSE*> | Thread.Alerted => ObValue.RaiseException( ObValue.threadAlerted, "reflect_setDefaultSequencer: ", loc); <*ASSERT FALSE*> END; END ReflectSetDefaultSequencer; *) BEGIN END ObBuiltIn.