Copyright (C) 1994, Digital Equipment Corp. MODULE============; IMPORT Text, TextRd, Rd, Lex, Fmt, ObLib, ObValue, SynLocation, TextConv, Thread, NetObj, Env, Params, Math, ObEval, FloatMode; PROCEDURE ObBuiltIn Setup () = BEGIN SetupSys(); SetupBool(); SetupInt(); SetupReal(); (* after Int, so real_+ etc. have precedence *) SetupMath(); SetupAscii(); SetupText(); SetupArray(); SetupNet(); SetupThread(); END Setup;
sys
package ============
TYPE SysCode = {Address, GetEnvVar, GetParamCount, GetParam, CallFailure, Call, Copy}; 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("copy", 1, SysCode.Copy, ObLib.OpFixity.Prefix) }; ObLib.Register( NEW(PackageSys, name:="sys", opCodes:=opCodes)); END SetupSys; PROCEDUREEvalSys (self: PackageSys; opCode: ObLib.OpCode; 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); ELSE ObValue.BadOp(self.name, opCode.name, loc); END; EXCEPT | NetObj.Error(atoms) => ObValue.RaiseNetException(self.name&"_"&opCode.name, atoms, loc); 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; arity: ObLib.OpArity; READONLY args: ObValue.ArgArray; temp: BOOLEAN; loc: SynLocation.T) : ObValue.Val RAISES {ObValue.Error, ObValue.Exception} = 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); 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; arity: ObLib.OpArity; READONLY args: ObValue.ArgArray; temp: BOOLEAN; loc: SynLocation.T) : ObValue.Val RAISES {ObValue.Error, ObValue.Exception} = 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); 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); END; CASE intCode OF | 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); 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); 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); 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; arity: ObLib.OpArity; READONLY args: ObValue.ArgArray; temp: BOOLEAN; loc: SynLocation.T) : ObValue.Val RAISES {ObValue.Error, ObValue.Exception} = 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); 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); END; IF isReal1 # isReal2 THEN IF isReal1 THEN ObValue.BadArgType(2, "real (like argument 1)", self.name, opCode.name, loc); ELSE ObValue.BadArgType(2, "int (like argument 1)", self.name, opCode.name, loc); 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) 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) 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); END; IF isReal1 # isReal2 THEN IF isReal1 THEN ObValue.BadArgType(2, "real (like argument 1)", self.name, opCode.name, loc); ELSE ObValue.BadArgType(2, "int (like argument 1)", self.name, opCode.name, loc); 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); 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; arity: ObLib.OpArity; READONLY args: ObValue.ArgArray; temp: BOOLEAN; loc: SynLocation.T) : ObValue.Val RAISES {ObValue.Error, ObValue.Exception} = 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); 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; arity: ObLib.OpArity; READONLY args: ObValue.ArgArray; temp: BOOLEAN; loc: SynLocation.T) : ObValue.Val RAISES {ObValue.Error, ObValue.Exception} = 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); 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; 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); END; TYPECASE args[2] OF | ObValue.ValChar(node) => char1:=node.char; ELSE ObValue.BadArgType(2, "char", self.name, opCode.name, loc); END; IF int1<0 THEN ObValue.BadArgVal(1, "non-negative", self.name, opCode.name, loc); 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); 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); 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); END; TYPECASE args[2] OF | ObValue.ValText(node) => text2:=node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); 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); END; TYPECASE args[2] OF | ObValue.ValInt(node) => int1:=node.int; ELSE ObValue.BadArgType(2, "int", self.name, opCode.name, loc); END; IF (int1<0) OR (int1>=Text.Length(text1)) THEN ObValue.BadArgVal(2, "in range", self.name, opCode.name, loc); 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); END; TYPECASE args[2] OF | ObValue.ValInt(node) => int1:=node.int; ELSE ObValue.BadArgType(2, "int", self.name, opCode.name, loc); END; TYPECASE args[3] OF | ObValue.ValInt(node) => int2:=node.int; ELSE ObValue.BadArgType(3, "int", self.name, opCode.name, loc); END; len := Text.Length(text1); IF (int1<0) OR (int1>len) THEN ObValue.BadArgVal(2, "in range", self.name, opCode.name, loc); END; IF (int2<0) OR (int1+int2>len) THEN ObValue.BadArgVal(3, "in range", self.name, opCode.name, loc); 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); END; TYPECASE args[2] OF | ObValue.ValText(node) => text2:=node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); 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); END; TYPECASE args[2] OF | ObValue.ValText(node) => text2:=node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); 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); 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); 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); 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); END; TYPECASE args[2] OF | ObValue.ValArray(node) => array1:=node.remote.Obtain(); ELSE ObValue.BadArgType(2, "array", self.name, opCode.name, loc); 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); 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); END; TYPECASE args[2] OF | ObValue.ValText(node) => text1:=node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); 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); 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); 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); END; | TextCode.FromInt => TYPECASE args[1] OF | ObValue.ValInt(node) => int1:=node.int; ELSE ObValue.BadArgType(1, "int", self.name, opCode.name, loc); 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); END; TYPECASE args[2] OF | ObValue.ValText(node) => text1:=node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); END; TYPECASE args[3] OF | ObValue.ValInt(node) => int1:=node.int; ELSE ObValue.BadArgType(3, "int", self.name, opCode.name, loc); 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); END; TYPECASE args[2] OF | ObValue.ValText(node) => text1:=node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); END; TYPECASE args[3] OF | ObValue.ValInt(node) => int1:=node.int; ELSE ObValue.BadArgType(3, "int", self.name, opCode.name, loc); 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); END; TYPECASE args[2] OF | ObValue.ValText(node) => text2:=node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); END; TYPECASE args[3] OF | ObValue.ValInt(node) => int1:=node.int; ELSE ObValue.BadArgType(3, "int", self.name, opCode.name, loc); 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); END; TYPECASE args[2] OF | ObValue.ValText(node) => text2:=node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); END; TYPECASE args[3] OF | ObValue.ValInt(node) => int1:=node.int; ELSE ObValue.BadArgType(3, "int", self.name, opCode.name, loc); 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); END; TYPECASE args[2] OF | ObValue.ValText(node) => text2:=node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); END; TYPECASE args[3] OF | ObValue.ValText(node) => text3:=node.text; ELSE ObValue.BadArgType(3, "text", self.name, opCode.name, loc); END; RETURN ObValue.NewText(ReplaceAll(text3, text1, text2)); ELSE ObValue.BadOp(self.name, opCode.name, loc); END; EXCEPT | NetObj.Error(atoms) => ObValue.RaiseNetException(self.name&"_"&opCode.name, atoms, loc); | Thread.Alerted => ObValue.RaiseException(ObValue.threadAlerted, self.name&"_"&opCode.name, loc); 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; 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); END; IF int1<0 THEN ObValue.BadArgVal(1, "non-negative", self.name, opCode.name, loc); 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); END; TYPECASE args[2] OF | ObValue.ValFun(node) => clos1:=node; ELSE ObValue.BadArgType(1, "procedure", self.name, opCode.name, loc); END; IF int1<0 THEN ObValue.BadArgVal(1, "non-negative", self.name, opCode.name, loc); 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); END; | ArrayCode.Get => TYPECASE args[2] OF | ObValue.ValInt(node) => int1:=node.int; ELSE ObValue.BadArgType(2, "int", self.name, opCode.name, loc); 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); END; | ArrayCode.Set => TYPECASE args[1] OF | ObValue.ValArray(node) => rem1:=node.remote; ELSE ObValue.BadArgType(1, "array", self.name, opCode.name, loc); END; TYPECASE args[2] OF | ObValue.ValInt(node) => int1:=node.int; ELSE ObValue.BadArgType(2, "int", self.name, opCode.name, loc); 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); END; TYPECASE args[3] OF | ObValue.ValInt(node) => int2:=node.int; ELSE ObValue.BadArgType(3, "int", self.name, opCode.name, loc); 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); END; | ArrayCode.Upd => TYPECASE args[1] OF | ObValue.ValArray(node) => rem1:=node.remote; ELSE ObValue.BadArgType(1, "array", self.name, opCode.name, loc); END; TYPECASE args[2] OF | ObValue.ValInt(node) => int1:=node.int; ELSE ObValue.BadArgType(2, "int", self.name, opCode.name, loc); END; TYPECASE args[3] OF | ObValue.ValInt(node) => int2:=node.int; ELSE ObValue.BadArgType(3, "int", self.name, opCode.name, loc); END; TYPECASE args[4] OF | ObValue.ValArray(node) => array1:=node.remote.Obtain(); ELSE ObValue.BadArgType(4, "array", self.name, opCode.name, loc); 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); END; TYPECASE args[2] OF | ObValue.ValArray(node) => array2:=node.remote.Obtain(); ELSE ObValue.BadArgType(2, "array", self.name, opCode.name, loc); END; badOp := 1; RETURN ObValue.ArrayCat(array1, array2); ELSE ObValue.BadOp(self.name, opCode.name, loc); END; EXCEPT | ObValue.ServerError => ObValue.BadArgVal(badOp, "in range", self.name, opCode.name, loc); | NetObj.Error(atoms) => ObValue.RaiseNetException(self.name&"_"&opCode.name, atoms, loc); 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; arity: ObLib.OpArity; READONLY args: ObValue.ArgArray; temp: BOOLEAN; loc: SynLocation.T) : ObValue.Val RAISES {ObValue.Error, ObValue.Exception} = VAR text1, text2: TEXT; remObj: ObValue.RemObj; BEGIN CASE NARROW(opCode, NetOpCode).code OF | NetCode.Error => RETURN ObValue.netException; | NetCode.Who => TYPECASE args[1] OF | ObValue.ValObj(node) => RETURN NetObjectWho(node.remote, loc); | ObValue.ValEngine(node) => RETURN NetEngineWho(node.remote, loc); ELSE ObValue.BadArgType(1, "object or engine", self.name, opCode.name, loc); END; | NetCode.Export => 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.ValText(node) => text2:=node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); END; TYPECASE args[3] OF | ObValue.ValObj(node) => remObj:=node.remote; ELSE ObValue.BadArgType(3, "object", self.name, opCode.name, loc); END; NetExport(text1, text2, remObj, 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); END; TYPECASE args[2] OF | ObValue.ValText(node) => text2:=node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); 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); END; TYPECASE args[2] OF | ObValue.ValText(node) => text2:=node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); 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); END; TYPECASE args[2] OF | ObValue.ValText(node) => text2:=node.text; ELSE ObValue.BadArgType(2, "text", self.name, opCode.name, loc); END; RETURN NetImportEngine(text1, text2, loc); ELSE ObValue.BadOp(self.name, opCode.name, loc); 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 (remObj: ObValue.RemObj; loc: SynLocation.T) : ObValue.Val RAISES {ObValue.Exception} = VAR protected, serialized: BOOLEAN; BEGIN TRY RETURN ObValue.NewText(remObj.Who((*out*)protected, (*out*)serialized)); EXCEPT | NetObj.Error(atoms) => ObValue.RaiseNetException("net_who", atoms, loc); | Thread.Alerted => ObValue.RaiseException(ObValue.threadAlerted, "net_who", loc); 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); | Thread.Alerted => ObValue.RaiseException(ObValue.threadAlerted, "net_who", loc); END; END NetEngineWho; PROCEDURENetExport (name, server: TEXT; remObj: ObValue.RemObj; loc: SynLocation.T) RAISES {ObValue.Exception} = VAR address: TEXT; netAddress: NetObj.Address; BEGIN NetLocate(server, (*out*)address, (*out*)netAddress, loc); TRY NetObj.Export(name, remObj, netAddress); 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 remObj OF | ObValue.RemObjServer(serv) => IF Text.Empty(serv.who) THEN serv.who := name & "@" & address; 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); | Thread.Alerted => ObValue.RaiseException(ObValue.threadAlerted, "net_import: '" & name & "' at '" & address & "'", loc); END; IF netObj=NIL THEN ObValue.RaiseException(ObValue.netException, "net_import: '" & name & "' was not found at '" & address & "'", loc); END; TYPECASE netObj OF | ObValue.RemObj(remObj) => RETURN NEW(ObValue.ValObj, remote:=remObj); ELSE ObValue.RaiseException(ObValue.netException, "net_import failed: '" & name & "' at '"& address & "' is not a network object", loc); 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); | Thread.Alerted => ObValue.RaiseException(ObValue.threadAlerted, "net_importEngine: '" & name & "' at '" & address & "'", loc); END; IF netObj=NIL THEN ObValue.RaiseException(ObValue.netException, "net_importEngine: '" & name & "' was not found at '" & address & "'", loc); 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); END; END NetImportEngine;
thread
package ============
TYPE ThreadCode = {Alerted, NewMutex, NewCondition, Self, Fork, Join, Wait, Acquire, Release, Broadcast, Signal, Pause, Alert, TestAlert, AlertWait, AlertJoin, AlertPause, Lock}; 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; PROCEDURECopyMutex (self: ObValue.ValAnything; tbl: ObValue.Tbl; loc: SynLocation.T): ObValue.ValAnything RAISES {ObValue.Error} = BEGIN RETURN NEW(ValMutex, what:="<a Thread.Mutex>", picklable:=FALSE, mutex:=NEW(Thread.Mutex)); END CopyMutex; PROCEDURECopyCondition (self: ObValue.ValAnything; tbl: ObValue.Tbl; loc: SynLocation.T): ObValue.ValAnything RAISES {ObValue.Error} = BEGIN RETURN NEW(ValCondition, what:="<a Thread.Condition>", picklable:=FALSE, condition:= NEW(Thread.Condition)); END CopyCondition; TYPE ThreadClosure = Thread.SizedClosure OBJECT fun: ObValue.ValFun; location: SynLocation.T; result: ObValue.Val; error: ObValue.ErrorPacket; exception: ObValue.ExceptionPacket; OVERRIDES apply := ApplyThreadClosure; END; PROCEDUREApplyThreadClosure (self: ThreadClosure): 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.Exception(packet) => self.exception := packet; END; RETURN self; END ApplyThreadClosure; PROCEDUREForkThread (fun: ObValue.ValFun; stackSize: INTEGER; loc: SynLocation.T): ValThread = VAR thread: Thread.T; threadClosure: ThreadClosure; BEGIN stackSize := MIN(MAX(stackSize,4096), LAST(CARDINAL)); threadClosure := NEW(ThreadClosure, 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, 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: ThreadClosure; 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("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; arity: ObLib.OpArity; READONLY args: ObValue.ArgArray; 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: INTEGER; noArgs: ARRAY [0..-1] OF ObValue.Val; 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>", picklable:=FALSE, mutex:=mutex1); | ThreadCode.NewCondition => condition1 := NEW(Thread.Condition); RETURN NEW(ValCondition, what:="<a Thread.Condition>", picklable:=FALSE, condition:=condition1); | ThreadCode.Self => thread1 := Thread.Self(); RETURN NEW(ValThread, what:="<a Thread.T>", picklable:=FALSE, 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); END; TYPECASE args[2] OF | ObValue.ValInt(node) => int1:=node.int; ELSE ObValue.BadArgType(2, "int", self.name, opCode.name, loc); 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); 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); END; TYPECASE args[2] OF | ValCondition(node) => condition1 := node.condition; ELSE ObValue.BadArgType(2, "condition", self.name, opCode.name, loc); 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); 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); 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); 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); 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); END; IF longReal1 < 0.0d0 THEN ObValue.BadArgVal(1, "non-negative", self.name, opCode.name, loc); 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); 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); END; TRY RETURN Thread.AlertJoin(thread1); EXCEPT Thread.Alerted => ObValue.RaiseException(ObValue.threadAlerted, opCode.name, loc); END; | ThreadCode.AlertWait => TYPECASE args[1] OF | ValMutex(node) => mutex1 := node.mutex; ELSE ObValue.BadArgType(1, "mutex", self.name, opCode.name, loc); END; TYPECASE args[2] OF | ValCondition(node) => condition1 := node.condition; ELSE ObValue.BadArgType(2, "condition", self.name, opCode.name, loc); END; TRY Thread.AlertWait(mutex1, condition1); RETURN ObValue.valOk; EXCEPT Thread.Alerted => ObValue.RaiseException(ObValue.threadAlerted, opCode.name, loc); END; | ThreadCode.AlertPause => TYPECASE args[1] OF | ObValue.ValReal(node) => longReal1:=node.real; ELSE ObValue.BadArgType(1, "real", self.name, opCode.name, loc); END; IF longReal1<0.0d0 THEN ObValue.BadArgVal(1, "non-negative", self.name, opCode.name, loc); END; TRY Thread.AlertPause(longReal1); RETURN ObValue.valOk; EXCEPT Thread.Alerted => ObValue.RaiseException(ObValue.threadAlerted, opCode.name, loc); END; | ThreadCode.Lock => TYPECASE args[1] OF | ValMutex(node) => mutex1 := node.mutex; ELSE ObValue.BadArgType(1, "mutex", self.name, opCode.name, loc); END; TYPECASE args[2] OF | ObValue.ValFun(node) => fun1:=node; ELSE ObValue.BadArgType(2, "procedure", self.name, opCode.name, loc); END; LOCK mutex1 DO RETURN ObEval.Call(fun1, noArgs, loc) END; ELSE ObValue.BadOp(self.name, opCode.name, loc); END; END EvalThread; BEGIN END ObBuiltIn.