-- JaMArray.mesa
-- Written by: John Warnock, March 2, 1979
-- Last changed by Doug Wyatt, February 10, 1981  4:50 PM

DIRECTORY
	JaMArrayDefs,
	JaMMasterDefs USING [Frame, Object, Stack],
	JaMControlDefs USING [GetCurrentFrame, RegisterCommand,
		RegisterIntCommand],
	JaMExecDefs USING [JaMError, stkundflw, rangechk],
	JaMFnsDefs USING [PopInteger, PopObject, PushObject],
	JaMStackDefs USING [CountStk, MoveStkOps, Pop, Push, Top],
	JaMTypeChkDefs USING [DescArrayType],
	JaMVMDefs USING [AllocateWordsVM, GetWordsVM, PutWordsVM];

JaMArray: PROGRAM
IMPORTS JaMControlDefs,JaMExecDefs,JaMFnsDefs,
	JaMStackDefs,JaMTypeChkDefs,JaMVMDefs 
EXPORTS JaMArrayDefs =
BEGIN OPEN JaMArrayDefs,JaMMasterDefs,JaMFnsDefs,JaMVMDefs;

Array: PUBLIC PROCEDURE = 
	BEGIN
	null:Object _ [lit,NullType[]];
	i:INTEGER _ PopInteger[];
	j:INTEGER _ 0;
	array:ArrayType Object _
		[lit,ArrayType[i,AllocateWordsVM[i*SIZE[Object]]]];
	IF i < 0 THEN RangeErr[];
	FOR j IN [0..i-1] DO
		PutWordsVM[array.ArrayPtr + SIZE[Object]*j,@null,SIZE[Object]];
		ENDLOOP;
	PushObject[array];
	END;

ArrayCopy: PUBLIC PROCEDURE = 
	BEGIN
	obj: Object;
	arrayd: ArrayType Object;
	arrays: ArrayType Object;
	j,l: INTEGER;
	arrays _ JaMTypeChkDefs.DescArrayType[PopObject[]];
	l_arrays.Length;
	arrayd_ [arrays.litflag,ArrayType[l,AllocateWordsVM[l*SIZE[Object]]]];
	FOR j IN [0..l) DO
		GetWordsVM[arrays.ArrayPtr+SIZE[Object]*j,@obj,SIZE[Object]];
		PutWordsVM[arrayd.ArrayPtr+SIZE[Object]*j,@obj,SIZE[Object]];
		ENDLOOP;
	PushObject[arrayd];
	END;

ArrayPut: PUBLIC PROCEDURE = 
	BEGIN
	val:Object _ PopObject[];
	i:INTEGER _ PopInteger[];
	array:ArrayType Object _ JaMTypeChkDefs.DescArrayType[PopObject[]];
	IF i < 0 OR ABS[i] > array.Length - 1 THEN RangeErr[];
	PutWordsVM[array.ArrayPtr + SIZE[Object]*i,@val,SIZE[Object]];
	END;

ArrayGet: PUBLIC PROCEDURE = 
	BEGIN
	val:Object;
	i:INTEGER _ PopInteger[];
	array:ArrayType Object _ JaMTypeChkDefs.DescArrayType[PopObject[]];
	IF i < 0 OR ABS[i] > array.Length - 1 THEN RangeErr[];
	GetWordsVM[array.ArrayPtr + SIZE[Object]*i,@val,SIZE[Object]];
	PushObject[val];
	END;


ArrayPart: PUBLIC PROCEDURE = 
	BEGIN
	i:INTEGER _ PopInteger[];
	j:INTEGER _ PopInteger[];
	array:ArrayType Object _ JaMTypeChkDefs.DescArrayType[PopObject[]];
	IF i < 0 OR j < 0 THEN RangeErr[];
	IF ABS[i+j] >= array.Length THEN RangeErr[];
	array.ArrayPtr _ array.ArrayPtr + j*SIZE[Object];
	array.Length_ i;
	PushObject[array];
	END;

ArrayAtom: PUBLIC PROCEDURE [aob:ArrayType Object,stk:JaMMasterDefs.Stack]
	RETURNS [BOOLEAN] = 
	BEGIN
	ob:Object;
	IF aob.Length <= 0  THEN RETURN [FALSE];
	GetWordsVM[aob.ArrayPtr,@ob,SIZE[Object]];
	aob.ArrayPtr _ aob.ArrayPtr + SIZE[Object];
	aob.Length_ aob.Length - 1;
	JaMStackDefs.Push[aob,stk];
	JaMStackDefs.Push[ob,stk];
	RETURN [TRUE];
	END;

ArrayStore: PUBLIC PROCEDURE =
-- expects opstk: (ob0, ob1, ... , obn-1, array)  array of length n
-- returns opstk: (array)
	BEGIN
	array: ArrayType Object _ JaMTypeChkDefs.DescArrayType[PopObject[]];
	frame: Frame _ JaMControlDefs.GetCurrentFrame[];
	val: Object;
	i: CARDINAL _ array.Length*SIZE[Object];
	IF array.Length > JaMStackDefs.CountStk[frame.opstk]
	THEN { OPEN JaMExecDefs; JaMError[stkundflw,TRUE] };
	THROUGH [0..array.Length)
	DO	i _ i - SIZE[Object];
		val _ PopObject[];
		PutWordsVM[array.ArrayPtr + i, @val,SIZE[Object]];
	ENDLOOP;
	JaMStackDefs.Push[array, frame.opstk];
	END;

ArrayLoad: PUBLIC PROCEDURE =
-- expects opstk: (array)  array of length n
-- returns opstk: (array[0], array[1], ... , array[n-1], array)
	BEGIN
	array: ArrayType Object _ JaMTypeChkDefs.DescArrayType[PopObject[]];
	frame: Frame _ JaMControlDefs.GetCurrentFrame[];
	val: Object;
	i: CARDINAL;
	FOR i _ 0, i+SIZE[Object] UNTIL i = array.Length*SIZE[Object]
	DO	GetWordsVM[array.ArrayPtr + i, @val,SIZE[Object]];
		PushObject[val];
	ENDLOOP;
	JaMStackDefs.Push[array, frame.opstk];
	END;


--"ArrayForall" is the "do for each array element" instruction. Two operands are required:
-- an Object. The Object is executed for each member of the
-- given array.

ArrayForall: PUBLIC PROCEDURE =
	BEGIN OPEN JaMStackDefs;
	frame:Frame _ JaMControlDefs.GetCurrentFrame[];
	ob:Object _ Pop[frame.opstk];
	array:ArrayType Object _
		JaMTypeChkDefs.DescArrayType[Pop[frame.opstk]];
	m:MarkType Object_[nolit,MarkType[]];
	Push[m,frame.execstk];
	Push[ob,frame.execstk];
	Push[array,frame.execstk];
	Push[arrayc,frame.execstk];
	END;

CArrayForall: PUBLIC PROCEDURE =
	BEGIN OPEN JaMStackDefs;
	frame:Frame _ JaMControlDefs.GetCurrentFrame[];
	array:ArrayType Object _
		JaMTypeChkDefs.DescArrayType[Pop[frame.execstk]];
	ob:Object _ Top[frame.execstk];
	IF ArrayAtom[array,frame.execstk] THEN
		BEGIN
		MoveStkOps[frame.execstk,frame.opstk,1];
		Push[arrayc,frame.execstk];
		Push[ob,frame.execstk];
		END
	ELSE
		BEGIN
		[]_Pop[frame.execstk];
		[]_Pop[frame.execstk];
		END;
	END;


RangeErr: PROCEDURE = { OPEN JaMExecDefs; JaMError[rangechk,TRUE] };

arrayc: CommandType Object;

-- Initialization

arrayc _ JaMControlDefs.RegisterIntCommand[CArrayForall];

STOP;

{ OPEN JaMControlDefs;
RegisterCommand[".array"L,Array];
RegisterCommand[".aget"L,ArrayGet];
RegisterCommand[".aput"L,ArrayPut];
RegisterCommand[".subarray"L,ArrayPart];
RegisterCommand[".arrayforall"L,ArrayForall];
RegisterCommand[".astore"L,ArrayStore];
RegisterCommand[".aload"L,ArrayLoad];
RegisterCommand[".acopy"L,ArrayCopy];
};

END.

DKW  March 28, 1980  4:56 PM
	added StartArray

DKW  April 1, 1980  2:56 PM
	now uses NotifyCommand, NotifyStringObject

DKW  December 8, 1980  12:41 PM
	cleaned up CArrayForall to reduce stack shuffling

DKW  February 10, 1981  3:41 PM
	imports errors from JaMExecDefs
(670)