-- JaMAttributes.mesa
-- Written by John Warnock/Martin Newell, February, 1979.
-- Last changed by Doug Wyatt, February 10, 1981  4:53 PM

DIRECTORY
	JaMAttributesDefs,
	JaMMasterDefs USING [Object, Stack],
	JaMControlDefs USING [GetCurrentFrame, RegisterCommand],
	JaMDictionaryDefs USING [Length],
	JaMExecDefs USING [JaMError, rangechk, typechk],
	JaMFnsDefs USING [PushBoolean, PushInteger],
	JaMLiteralDefs USING [IntegerLit, MakeStringObject],
	JaMScannerDefs USING [StringToken],
	JaMStackDefs USING [CountStk, Exch, Pop, Push],
	JaMTypeChkDefs USING [DescIntegerType, DescUserType],
	InlineDefs USING [LowHalf],
	Real USING [Fix, FixI];

JaMAttributes: PROGRAM
IMPORTS JaMControlDefs,JaMDictionaryDefs,JaMExecDefs,JaMFnsDefs,
	JaMLiteralDefs,JaMScannerDefs,JaMStackDefs,JaMTypeChkDefs,
	InlineDefs,Real
EXPORTS JaMAttributesDefs  =
BEGIN OPEN JaMControlDefs,JaMLiteralDefs,JaMStackDefs,JaMMasterDefs;

GetOpStk: PROCEDURE RETURNS[Stack] = INLINE
	BEGIN RETURN[GetCurrentFrame[].opstk] END;

Length: PUBLIC PROCEDURE  =
	BEGIN
	SLength[GetOpStk[]];
	END;

SLength: PUBLIC PROCEDURE [stack: Stack] =
--Does stack: (object) => (length of object)
	BEGIN
	ob: Object _ Pop[stack];
	WITH dob:ob SELECT FROM
		StringType	=> IntegerLit[dob.Length,stack];
		ArrayType	=> IntegerLit[dob.Length,stack];
		DictType	=> BEGIN
			dict: DictType Object = dob;
			IntegerLit[JaMDictionaryDefs.Length[dict],stack];
			END;
		StackType	=> BEGIN
			stk: StackType Object = dob;
			IntegerLit[CountStk[stk.StkPtr],stack];
			END;
		ENDCASE	=> IntegerLit[1,stack];
	END;

LitType: PUBLIC PROCEDURE =
	BEGIN
	opstk: Stack _ GetOpStk[];
	ob: Object _ Pop[opstk];
	JaMFnsDefs.PushBoolean[ob.litflag = lit];
	END;

UserType: PUBLIC PROCEDURE =
	BEGIN
	opstk: Stack _ GetOpStk[];
	ob:  UserType Object _ JaMTypeChkDefs.DescUserType[Pop[opstk]];
	JaMFnsDefs.PushInteger[ob.Type];
	END;

Type: PUBLIC PROCEDURE  =
	BEGIN
	opstk: Stack _ GetOpStk[];
	ob: Object _ Pop[opstk];
	WITH dob:ob SELECT FROM
		IntegerType => Push[IntegerOb,opstk];
		LongIntegerType => Push[LongIntegerOb,opstk];
		RealType => Push[RealOb,opstk];
		BooleanType => Push[BooleanOb,opstk];
		StringType => Push[StringOb,opstk];
		StreamType => Push[StreamOb,opstk];
		CommandType => Push[CommandOb,opstk];
		DictType => Push[DictOb,opstk];
		ArrayType => Push[ArrayOb,opstk];
		StackType => Push[StackOb,opstk];
		FrameType => Push[FrameOb,opstk];
		MarkType => Push[MarkOb,opstk];
		UserType => Push[UserOb,opstk];
		NullType => Push[NullOb,opstk];
		ENDCASE;
	END;

IType: PUBLIC PROCEDURE  =
	BEGIN OPEN JaMFnsDefs;
	opstk: Stack _ GetOpStk[];
	ob: Object _ Pop[opstk];
	WITH dob:ob SELECT FROM
		IntegerType => PushInteger[1];
		LongIntegerType => PushInteger[2];
		RealType => PushInteger[3];
		BooleanType => PushInteger[4];
		StringType => PushInteger[5];
		StreamType => PushInteger[6];
		CommandType => PushInteger[7];
		DictType => PushInteger[8];
		ArrayType => PushInteger[9];
		StackType => PushInteger[10];
		FrameType => PushInteger[11];
		MarkType => PushInteger[12];
		UserType => PushInteger[13];
		NullType => PushInteger[0];
		ENDCASE;
	END;

ConvertToLiteral: PUBLIC PROCEDURE  =
	BEGIN
	opstk: Stack _ GetOpStk[];
	ob: Object _ Pop[opstk];
	ob.litflag _ lit;
	Push[ob,opstk];
	END;

ConvertToExec: PUBLIC PROCEDURE  =
	BEGIN
	opstk: Stack _ GetOpStk[];
	ob: Object _ Pop[opstk];
	ob.litflag _ nolit;
	Push[ob,opstk];
	END;

ConvertToInteger: PUBLIC PROCEDURE  =
	BEGIN
	opstk: Stack _ GetOpStk[];
	ob: Object _ Pop[opstk];
	iob: IntegerType Object _ [lit,IntegerType[0]];
	WITH dob:ob SELECT FROM
		IntegerType => Push[ob,opstk];
		LongIntegerType => BEGIN
			l:LONG INTEGER_dob.LongIntegerVal;
			IF l NOT IN [lloweri..lupperi] THEN
				{ OPEN JaMExecDefs; ERROR JaMError[rangechk,TRUE] };
			iob.IntegerVal _ LOOPHOLE[InlineDefs.LowHalf[l],INTEGER];
			Push[iob,opstk];
			END;
		RealType => BEGIN
			r:REAL_dob.RealVal;
			IF r NOT IN [rloweri..rupperi] THEN 
				{ OPEN JaMExecDefs; ERROR JaMError[rangechk,TRUE] };
			iob.IntegerVal_Real.FixI[r];
			Push[iob,opstk];
			END;
		StringType => BEGIN
			s:StringType Object_dob;
			[]_JaMScannerDefs.StringToken[s,opstk];
			Exch[opstk];
			[]_Pop[opstk];
			Push[JaMTypeChkDefs.DescIntegerType[Pop[opstk]],opstk]; 
			END;
		ENDCASE => { OPEN JaMExecDefs; ERROR JaMError[typechk,TRUE] };
	END;

ConvertToLongInteger: PUBLIC PROCEDURE  =
	BEGIN
	opstk: Stack _ GetOpStk[];
	ob: Object _ Pop[opstk];
	liob: LongIntegerType Object _ [lit,LongIntegerType[0]];
	WITH dob:ob SELECT FROM
		IntegerType => BEGIN
			i:INTEGER_dob.IntegerVal;
			liob.LongIntegerVal_i;
			Push[liob,opstk];
			END;
		LongIntegerType => Push[ob,opstk];
		RealType => BEGIN
			l:LONG INTEGER;
			r:REAL_dob.RealVal;
			IF r NOT IN [rlowerl..rupperl] THEN 
				{ OPEN JaMExecDefs; ERROR JaMError[rangechk,TRUE] };
			l_Real.Fix[r];
			liob.LongIntegerVal_l;
			Push[liob,opstk];
			END;
		StringType => BEGIN
			s:StringType Object_dob;
			obj:Object;
			[]_JaMScannerDefs.StringToken[s,opstk];
			Exch[opstk];
			[]_Pop[opstk];
			obj_Pop[opstk]; 
			WITH d1ob:obj SELECT FROM
				IntegerType => liob.LongIntegerVal _ LONG[d1ob.IntegerVal];
				LongIntegerType => liob.LongIntegerVal _ d1ob.LongIntegerVal;
				ENDCASE => { OPEN JaMExecDefs; ERROR JaMError[typechk,TRUE] };
			Push[liob,opstk];
			END;
		ENDCASE => { OPEN JaMExecDefs; ERROR JaMError[typechk,TRUE] };
	END;

ConvertToReal: PUBLIC PROCEDURE  =
	BEGIN
	opstk: Stack _ GetOpStk[];
	ob: Object _ Pop[opstk];
	riob: RealType Object _ [lit,RealType[0]];
	WITH dob:ob SELECT FROM
		IntegerType => BEGIN
			i:INTEGER_dob.IntegerVal;
			riob.RealVal_i;
			Push[riob,opstk];
			END;
		LongIntegerType => BEGIN
			l: LONG INTEGER_dob.LongIntegerVal;
			riob.RealVal_l;
			Push[riob,opstk];
			END;
		RealType => Push[ob,opstk];
		StringType => BEGIN
			s:StringType Object_dob;
			obj:Object;
			[]_JaMScannerDefs.StringToken[s,opstk];
			Exch[opstk];
			[]_Pop[opstk];
			obj_Pop[opstk]; 
			WITH d1ob:obj SELECT FROM
				IntegerType => BEGIN
					riob.RealVal _ d1ob.IntegerVal;
					Push[riob,opstk];
					END;
				LongIntegerType => BEGIN
					riob.RealVal _ d1ob.LongIntegerVal;
					Push[riob,opstk];
					END;
				RealType => Push[obj,opstk];
				ENDCASE => { OPEN JaMExecDefs; ERROR JaMError[typechk,TRUE] };
			END;
		ENDCASE => { OPEN JaMExecDefs; ERROR JaMError[typechk,TRUE] };
	END;

rlowerl: REAL _ -214748364;
rupperl: REAL _ 214748363;
lloweri: LONG INTEGER _ -LONG[32768];
lupperi: LONG INTEGER _ 32767;
rloweri: REAL _ lloweri;
rupperi: REAL _ lupperi;

IntegerOb,LongIntegerOb,RealOb,BooleanOb,StringOb,
 StreamOb,CommandOb,DictOb,ArrayOb,StackOb,FrameOb,MarkOb,
 UserOb,NullOb: StringType Object;

-- Initialization

STOP;

{ OPEN JaMLiteralDefs;
IntegerOb _ MakeStringObject[".integertype"L];
LongIntegerOb _ MakeStringObject[".longintegertype"L];
RealOb _ MakeStringObject[".realtype"L];
BooleanOb _ MakeStringObject[".booleantype"L];
StringOb _ MakeStringObject[".stringtype"L];
StreamOb _ MakeStringObject[".streamtype"L];
CommandOb _ MakeStringObject[".commandtype"L];
DictOb _ MakeStringObject[".dicttype"L];
ArrayOb _ MakeStringObject[".arraytype"L];
StackOb _ MakeStringObject[".stacktype"L];
FrameOb _ MakeStringObject[".frametype"L];
MarkOb _ MakeStringObject[".marktype"L];
UserOb _ MakeStringObject[".usertype"L];
NullOb _ MakeStringObject[".nulltype"L];
};

{ OPEN JaMControlDefs;
RegisterCommand[".litchk"L,LitType];
RegisterCommand[".usertype"L,UserType];
RegisterCommand[".type"L,Type];
RegisterCommand[".itype"L,IType];
RegisterCommand[".length"L,Length];
RegisterCommand[".cvlit"L,ConvertToLiteral];
RegisterCommand[".cvi"L,ConvertToInteger];
RegisterCommand[".cvli"L,ConvertToLongInteger];
RegisterCommand[".cvr"L,ConvertToReal];
RegisterCommand[".cvx"L,ConvertToExec];
};

END.

DKW  March 28, 1980  4:47 PM
	added StartAttributes

DKW  March 29, 1980  2:49 PM
	fixed a bug in the StringType case of ConvertToLongInteger

DKW  March 29, 1980  3:08 PM
	added GetOpStk, substituted opstk for frame.opstk everywhere

DKW  April 1, 1980  3:06 PM
	now uses NotifyCommand, NotifyStringObject

DKW  August 4, 1980  4:24 PM
	added Mesa5RealType (in case an old VM contains Mesa5-style REALs)

DKW  February 10, 1981  2:32 PM
	eliminated Mesa5RealType
	imports errors from JaMExecDefs
	initializes after STOP
(600)