MODULE FoxArrayBase; (* stubs for array base runtime - can only be compiled by oc compiler *) (* (c) fof, fn, ETH Zürich, 2008 *) (*! do do: MAX(array,scalar) and MAX(array,array) for all datatypes*) IMPORT SYSTEM, KernelLog, Heaps, Math, MathL; TYPE GenericUnaryAALoopS = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: SHORTINT): SHORTINT ); GenericUnaryAALoopI = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: INTEGER): INTEGER ); GenericUnaryAALoopL = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: LONGINT): LONGINT ); GenericUnaryAALoopH = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: HUGEINT): HUGEINT ); GenericUnaryAALoopR = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: REAL): REAL ); GenericUnaryAALoopX = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: LONGREAL): LONGREAL ); GenericUnaryAALoopZ = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: COMPLEX): COMPLEX ); GenericUnaryAALoopLZ = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: LONGCOMPLEX): LONGCOMPLEX ); UnaryAALoop = PROCEDURE ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); UnaryASLoop = PROCEDURE ( ladr, dadr: ADDRESS; linc, len: SIZE ); UnarySALoop = PROCEDURE ( ladr, dadr: ADDRESS; dinc, len: SIZE ); BinaryAAALoop = PROCEDURE ( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); BinaryASALoop = PROCEDURE ( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); BinaryAASLoop = PROCEDURE ( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); BinaryAABLoop = PROCEDURE ( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; BinaryASBLoop = PROCEDURE ( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; CONST debug = FALSE; (* warning: debug=true -> a lot of output is generated -> traps are not displayed in Oberon (Kernel overflow) *) statistics= FALSE; conservative=TRUE; ArrDataArrayOffset=ADDRESS(16); (* offset of data in array with pointers *) AddressSize=SIZEOF(ADDRESS); MathPtrOffset=0*AddressSize; MathAdrOffset=1*AddressSize; MathFlagsOffset=2*AddressSize; MathDimOffset=3*AddressSize; MathElementSizeOffset=4*AddressSize; MathLenOffset=5*AddressSize; MathIncrOffset=6*AddressSize; GeometryMismatch = 400; DimensionMismatch=401; AllocationForbidden=402; TensorFlag = 0; RangeFlag = 1; TemporaryFlag = 2; down = 0; up = 1; (* memory copy modes *) (* flags for optimizations with small matricies and vectors (Alexey Morozov) *) SmallMatrixFlag = 3; (* flag for identification of a small matrix *) SmallVectorFlag = 3; (* flag for identification of a small vector *) Size2Flag = 4; (* size = 2 *) Size3Flag = 5; (* size = 3 *) Size4Flag = 6; (* size = 4 *) Size5Flag = 7; (* size = 5 *) Size6Flag = 8; (* size = 6 *) Size7Flag = 9; (* size = 7 *) Size8Flag = 10; (* size = 8 *) Mat2x2 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,Size2Flag}); Mat3x3 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,Size3Flag}); Mat4x4 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,Size4Flag}); Mat5x5 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,Size5Flag}); Mat6x6 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,Size6Flag}); Mat7x7 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,Size7Flag}); Mat8x8 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,Size8Flag}); Vec2 = SYSTEM.VAL(LONGINT,{SmallVectorFlag,Size2Flag}); Vec3 = SYSTEM.VAL(LONGINT,{SmallVectorFlag,Size3Flag}); Vec4 = SYSTEM.VAL(LONGINT,{SmallVectorFlag,Size4Flag}); Vec5 = SYSTEM.VAL(LONGINT,{SmallVectorFlag,Size5Flag}); Vec6 = SYSTEM.VAL(LONGINT,{SmallVectorFlag,Size6Flag}); Vec7 = SYSTEM.VAL(LONGINT,{SmallVectorFlag,Size7Flag}); Vec8 = SYSTEM.VAL(LONGINT,{SmallVectorFlag,Size8Flag}); MatVec2x2 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,SmallVectorFlag,Size2Flag}); MatVec3x3 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,SmallVectorFlag,Size3Flag}); MatVec4x4 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,SmallVectorFlag,Size4Flag}); MatVec5x5 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,SmallVectorFlag,Size5Flag}); MatVec6x6 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,SmallVectorFlag,Size6Flag}); MatVec7x7 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,SmallVectorFlag,Size7Flag}); MatVec8x8 = SYSTEM.VAL(LONGINT,{SmallMatrixFlag,SmallVectorFlag,Size8Flag}); SmallArrayMask = {SmallMatrixFlag,SmallVectorFlag,Size2Flag,Size3Flag,Size4Flag,Size5Flag,Size6Flag,Size7Flag,Size8Flag}; TYPE FastMatMul* = PROCEDURE ( matrixA, matrixB, matrixC, IncA, StrideA, IncB, StrideB, IncC, StrideC, RowsA, ColsA, RowsB, ColsB: LONGINT ): BOOLEAN; TransposeP* = PROCEDURE ( ladr, dadr, lstride, linc, dstride, dinc, rows, cols: LONGINT ); LenInc = RECORD len: SIZE; inc: SIZE END; ArrayDescriptor*= RECORD ptr*: ANY; adr*: ADDRESS; flags*: SET; dim*: SIZE; elementSize*: SIZE; END; Tensor = POINTER TO ArrayDescriptor; UnsafeArray*= POINTER {UNSAFE} TO RECORD(ArrayDescriptor) lens*: ARRAY 8 OF LenInc; END; A0 = RECORD(ArrayDescriptor) END; A1 = RECORD(ArrayDescriptor) lens : ARRAY 1 OF LenInc; END; A2 = RECORD(ArrayDescriptor) lens : ARRAY 2 OF LenInc; END; A3 = RECORD(ArrayDescriptor) lens : ARRAY 3 OF LenInc; END; A4 = RECORD(ArrayDescriptor) lens : ARRAY 4 OF LenInc; END; A5 = RECORD(ArrayDescriptor) lens : ARRAY 5 OF LenInc; END; A6 = RECORD(ArrayDescriptor) lens : ARRAY 6 OF LenInc; END; A7 = RECORD(ArrayDescriptor) lens : ARRAY 7 OF LenInc; END; A8 = RECORD(ArrayDescriptor) lens : ARRAY 8 OF LenInc; END; T0 = POINTER TO A0; T1 = POINTER TO A1; T2 = POINTER TO A2; T3 = POINTER TO A3; T4 = POINTER TO A4; T5 = POINTER TO A5; T6 = POINTER TO A6; T7 = POINTER TO A7; T8 = POINTER TO A8; (* used for optimizations of MatMul with small sizes (Alexey Morozov) *) SmallMatMul* = PROCEDURE(dadr, ladr, radr: LONGINT); VAR alloc*: LONGINT; (* statistics *) allocTemp*: LONGINT; (* statistics *) (* procedures that might be replaced by ASM methods *) loopSPAXAX*, loopSPARAR*: BinaryAASLoop; loopSPAZAZ, loopSPALZALZ: BinaryAASLoop; loopAddAXAX*, loopAddARAR*, loopAddAZAZ*, loopAddALZALZ*: BinaryAAALoop; loopMatMulAXAX*, loopMatMulARAR*: BinaryAASLoop; loopMatMulIncAXAX*, loopMatMulIncARAR*: BinaryAASLoop; loopMulAXSX*, loopMulARSR*, loopMulAZSZ*, loopMulALZSLZ*: BinaryASALoop; loopIncMulAXSX*, loopIncMulARSR*: BinaryASALoop; matMulX*, matMulR*: FastMatMul; matMulIncX*, matMulIncR*: FastMatMul; transpose4*: TransposeP; transpose8*: TransposeP; (* optimizations for small arrays (Alexey Morozov) *) matMulR2x2*: SmallMatMul; matMulR3x3*: SmallMatMul; matMulR4x4*: SmallMatMul; matVecMulR2x2*: SmallMatMul; matVecMulR3x3*: SmallMatMul; matVecMulR4x4*: SmallMatMul; matMulLR2x2*: SmallMatMul; matMulLR3x3*: SmallMatMul; matMulLR4x4*: SmallMatMul; matVecMulLR2x2*: SmallMatMul; matVecMulLR3x3*: SmallMatMul; matVecMulLR4x4*: SmallMatMul; (* TensorTypePool: ARRAY 32 OF TensorType; *) PROCEDURE SetDefaults*; (* set standard procedures *) BEGIN KernelLog.String( "ArrayBase XXXXXXX: setting runtime library (semi-optimized) default methods." ); KernelLog.Ln; loopSPAXAX := SPAXAXLoop; loopSPARAR := SPARARLoop; loopAddAXAX := AddAXAXLoop; loopSPAZAZ := SPAZAZLoop; loopSPALZALZ := SPALZALZLoop; loopAddARAR := AddARARLoop; loopMatMulAXAX := MatMulAXAXLoop; loopAddAZAZ := AddAZAZLoop; loopAddALZALZ := AddALZALZLoop; loopMatMulIncAXAX := MatMulIncAXAXLoop; loopMatMulARAR := MatMulARARLoop; loopMulAXSX := MulAXSXLoop; loopIncMulAXSX := IncMulAXSXLoop; loopMatMulIncARAR := MatMulIncARARLoop; loopMulARSR := MulARSRLoop; loopIncMulARSR := IncMulARSRLoop; matMulX := NIL; matMulR := NIL; matMulIncX := NIL; matMulIncR := NIL; loopMulAZSZ := MulAZSZLoop; loopMulALZSLZ := MulALZSLZLoop; END SetDefaults; PROCEDURE Err(CONST s: ARRAY OF CHAR ); BEGIN KernelLog.String( "Runtime Error: " ); KernelLog.String( s ); KernelLog.Ln; HALT( 100 ); END Err; (* get increment of dimension dim *) PROCEDURE GetIncr(base: UnsafeArray; dim: SIZE): SIZE; BEGIN{UNCHECKED} RETURN base.lens[dim].inc END GetIncr; (* set increment of dimension dim *) PROCEDURE PutInc(base: UnsafeArray; dim,val: SIZE); BEGIN{UNCHECKED} base.lens[dim].inc := val END PutInc; (* get length of dimension dim *) PROCEDURE GetLen(base: UnsafeArray; dim: SIZE): LONGINT; BEGIN{UNCHECKED} RETURN base.lens[dim].len END GetLen; (* set length of dimension dim *) PROCEDURE PutLen(base: UnsafeArray; dim,val: SIZE); BEGIN{UNCHECKED} base.lens[dim].len := val END PutLen; (* get data address *) PROCEDURE GetAdr(base: UnsafeArray): ADDRESS; BEGIN RETURN base.adr; END GetAdr; (* set data address *) PROCEDURE PutAdr(base: UnsafeArray; value: ADDRESS); BEGIN base.adr := value END PutAdr; (* get data base pointer (GC protection) *) PROCEDURE GetPtr(base: UnsafeArray): ANY; BEGIN RETURN base.ptr; END GetPtr; (* set data base pointer (GC protection) *) PROCEDURE PutPtr(base: UnsafeArray; value: ANY); BEGIN base.ptr := value END PutPtr; PROCEDURE GetSize( base: UnsafeArray ): LONGINT; BEGIN IF base = NIL THEN RETURN 0 ELSE RETURN base.elementSize END END GetSize; PROCEDURE PutSize( base: UnsafeArray; val: SIZE ); BEGIN base.elementSize := val END PutSize; PROCEDURE GetDim( base: UnsafeArray ): SIZE; VAR dim: LONGINT; BEGIN IF base = 0 THEN RETURN 0 ELSE RETURN base.dim END; END GetDim; PROCEDURE GetFlags( base: UnsafeArray ): SET; BEGIN RETURN base.flags END GetFlags; PROCEDURE PutDim( base: UnsafeArray; dim: SIZE ); BEGIN base.dim := dim END PutDim; PROCEDURE PutFlags( base: UnsafeArray; flags: SET ); BEGIN base.flags := flags END PutFlags; (* report geometry of array passed via address s *) PROCEDURE Report(CONST name: ARRAY OF CHAR; s: ADDRESS ); VAR i: LONGINT; dim: LONGINT; PROCEDURE Set( s: SET ); VAR i: LONGINT; first: BOOLEAN; BEGIN KernelLog.String( "{" ); first := TRUE; FOR i := 31 TO 0 BY -1 DO IF i IN s THEN IF ~first THEN KernelLog.String( "," ); ELSE first := FALSE END; KernelLog.Int( i, 1 ); END; END; KernelLog.String( "}" ); END Set; BEGIN KernelLog.String( name ); IF s = 0 THEN KernelLog.String( " : NIL " ); KernelLog.Ln; ELSE KernelLog.String( " at adr " ); KernelLog.Int( s, 1 ); KernelLog.String( "; ptr= " ); KernelLog.Address( GetPtr( s )); KernelLog.String( "; adr= " ); KernelLog.Address( GetAdr( s )); KernelLog.String( "; dim=" ); KernelLog.Int( GetDim( s ), 1 ); KernelLog.String( "; flags=" ); Set( GetFlags( s ) ); KernelLog.Ln; dim := GetDim( s ); IF dim > 32 THEN dim := 0 END; FOR i := 0 TO dim - 1 DO KernelLog.String( "dim (rev)=" ); KernelLog.Int( i, 1 ); KernelLog.String( ", len=" ); KernelLog.Int( GetLen( s, i ), 1 ); KernelLog.String( ", inc=" ); KernelLog.Int( GetIncr( s, i ), 1 ); KernelLog.Ln; END; (* FindPattern1( s, dim, ldim, len, inc ); KernelLog.String( "increment: " ); KernelLog.Int( inc, 10 ); KernelLog.Ln; KernelLog.String( "longest dim:" ); KernelLog.Int( ldim, 10 ); KernelLog.Ln; KernelLog.String( "len:" ); KernelLog.Int( len, 10 ); KernelLog.Ln; *) END; END Report; PROCEDURE GetArrayDesc( dim: LONGINT ): Tensor; VAR (* t: TensorType; *) ptr: Tensor; p0: T0; p1: T1; p2: T2; p3: T3; p4: T4; p5: T5; p6: T6; p7: T7; p8: T8; BEGIN (* IF dim < LEN( TensorTypePool ) THEN t := TensorTypePool[dim] ELSE NewTensorType( dim, t ); END; Heaps.NewRec( ptr, t.tag ); *) CASE dim OF |0: NEW(p0); ptr := p0; |1:NEW(p1); ptr := p1; |2:NEW(p2); ptr := p2; |3:NEW(p3); ptr := p3; |4:NEW(p4); ptr := p4; |5:NEW(p5); ptr := p5; |6:NEW(p6); ptr := p6; |7:NEW(p7); ptr := p7; |8:NEW(p8); ptr := p8; ELSE HALT(200) END; ptr.dim := dim; ptr.flags := {TensorFlag}; RETURN ptr; END GetArrayDesc; PROCEDURE Halt( code: LONGINT; left, right, dest: LONGINT ); VAR reason: ARRAY 64 OF CHAR; BEGIN IF left # 0 THEN Report( "Source operand ", left ) END; IF right # 0 THEN Report( "Source operand 2 ", right ) END; IF dest # 0 THEN Report( "Dest operand ", dest ) END; IF code = GeometryMismatch THEN reason := "Geometry mismatch"; ELSIF code = DimensionMismatch THEN reason := "Dimension mismatch"; ELSIF code = AllocationForbidden THEN reason := "Allocation forbidden for dest"; ELSE reason := "unknown"; END; KernelLog.String( "ArrayBase Halt. Reason= " ); KernelLog.String( reason ); KernelLog.Ln; HALT( 400 ); END Halt; (** patterns ********************************************************************) (* find the largest block with a regular pattern of the form offset+{i*li: 0<=i 0) DO DEC( d ); len := GetLen( left, d ); END; (* skip lower dimensions with len=1, in most cases d=0 *) linc := GetIncr( left, d ); DEC( d ); WHILE (d >= 0) & (GetIncr( left, d ) = len * linc) DO len := len * GetLen( left, d ); DEC( d ); END; (* find dimension where pattern does not work any more *) INC( d ); IF debug THEN KernelLog.String( "FindPattern1: " ); KernelLog.Int( len, 10 ); KernelLog.Int( linc, 10 ); KernelLog.Ln; END; END FindPattern1; (* find the largest block with a regular pattern of the form offset+{i*linc: 0<=i 0) DO DEC( d ); len := GetLen( left, d ); END; linc := GetIncr( left, d ); ri := GetIncr( right, d ); DEC( d ); WHILE (d >= 0) & (GetIncr( left, d ) = len * linc) & (GetIncr( right, d ) = len * ri) DO len := len * GetLen( left, d ); DEC( d ); END; INC( d ); IF debug THEN KernelLog.String( "FindPattern2: " ); KernelLog.Int( d, 10 ); KernelLog.Int( len, 10 ); KernelLog.Int( linc, 10 ); KernelLog.Int( ri, 10 ); KernelLog.Ln; END; END FindPattern2; (* find the largest block with a regular pattern of the form offset+{i*linc: 0<=i 0) DO DEC( d ); len := GetLen( left, d ); END; linc := GetIncr( left, d ); ri := GetIncr( right, d ); di := GetIncr( dest, d ); DEC( d ); WHILE (d >= 0) & (GetIncr( left, d ) = len * linc) & (GetIncr( right, d ) = len * ri) & (GetIncr( dest, d ) = len * di) DO len := len * GetLen( left, d ); DEC( d ); END; INC( d ); IF debug THEN KernelLog.String( "FindPattern3: " ); KernelLog.Int( len, 10 ); KernelLog.Int( linc, 10 ); KernelLog.Int( ri, 10 ); KernelLog.Int( di, 10 ); KernelLog.Ln; END; END FindPattern3; PROCEDURE Reverse( src: ADDRESS; dim: LONGINT ); VAR d, sl, sr: LONGINT; BEGIN d := 0; sl := GetAdr( src ); WHILE (d < dim) DO INC( sr, GetIncr( src, d ) * (GetLen( src, d ) - 1) ); PutInc( src, d, -GetIncr( src, d ) ); INC( d ); END; PutAdr( src, sl + sr ); END Reverse; (* check if forward copy may be performed *) PROCEDURE CopyUpCompatible( dest, src: ADDRESS; VAR modes: SET ); VAR d, sl, sr, dl, dr: LONGINT; dim: LONGINT; (* precondition: len(src,i)=len(dest,i) *) (* for forward src -> dest copy compatibility src must not be overwritten before src is copied. Sufficient (but not necessary) conditions: 1.) no overlap: src right < dest left or src left > dest right or 2.) same geometry and src left >= dest left same geometry if ginc(s)=ginc(d) with ginc(s)=inc(s,0)*len(s,0)+inc(s,1)*len(s,1)+... ginc(d)=inc(d,0)*len(d,0)+inc(d,1)*len(d,1)+... *) BEGIN d := 0; sl := GetAdr( src ); sr := sl; dl := GetAdr( dest ); dr := dl; dim := GetDim( src ); WHILE (d < dim) DO INC( sr, GetIncr( src, d ) * (GetLen( src, d ) - 1) ); INC( dr, GetIncr( dest, d ) * (GetLen( dest, d ) - 1) ); INC( d ); END; IF (sr < dl) OR (sl > dr) THEN (* no overlap, both directions possible *) ELSIF ((sr - sl) = (dr - dl)) THEN IF (sl = dl) THEN (* same memory region, both directions possible *) ELSIF (sl > dl) THEN EXCL( modes, down ) (* only copy up possible *) ELSE (*sl < dl*) EXCL( modes, up ) (* only copy down possible *) END; ELSE modes := modes - {down, up}; (* neither nor *) END; END CopyUpCompatible; PROCEDURE AllocateTemp( VAR dest: ADDRESS; src: ADDRESS; Size: LONGINT ): ANY; (* allocate a temporary block containing both descriptor and data *) VAR d, len, i: LONGINT; p: ANY; dim: LONGINT; BEGIN HALT(100); (* IF statistics THEN INC( allocTemp ) END; d := 0; len := Size; dim := GetDim( src ); WHILE (d < dim) DO len := len * GetLen( src, d ); INC( d ); END; INC( len, 2 * dim * SIZEOF( LONGINT ) + MathLenOffset ); SYSTEM.NEW( p, len ); dest := SYSTEM.VAL( LONGINT, p ); PutAdr( dest, dest + dim * 2 * SIZEOF( LONGINT ) + MathLenOffset ); PutPtr( dest, dest ); PutDim( dest, dim ); len := Size; FOR i := 0 TO dim - 1 DO PutInc( dest, i, len ); PutLen( dest, i, GetLen( src, i ) ); len := len * GetLen( src, i ); END; (* Report("allocdest",dest,dim); *) RETURN p; *) END AllocateTemp; (*** procedures to traverse arrays and apply operators *) (** apply unary operator to array: array SHORTINT -> array SHORTINT *) PROCEDURE ApplyGenericUnaryAAOpS( d, l: ADDRESS; elementSize: LONGINT; Loop: GenericUnaryAALoopS; op: PROCEDURE(x: SHORTINT): SHORTINT ); VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT; origdest: LONGINT; modes: SET; dest, left: ADDRESS; dim: SIZE; PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS ); VAR len: LONGINT; linc, dinc: LONGINT; BEGIN IF dim = loopd THEN Loop( ladr, dadr, loopli, loopdi, looplen, op ); IF conservative THEN INC( glen, looplen ) END; ELSE len := GetLen( left, dim ); linc := GetIncr( left, dim ); dinc := GetIncr( dest, dim ); INC( dim ); WHILE (len > 0) DO Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END; END Traverse; BEGIN SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left ); origdest := 0; modes := {up, down}; (* allocate destination, if necessary *) p := AllocateSame( dest, left, elementSize ); IF p = NIL THEN CopyUpCompatible( dest, left, modes ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize ); END; END; (* allocate destination, if necessary *) (*IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize ) ELSIF CheckGeometry( left, dest, dim ) END; *) IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END; (* check pattern: longest piece that can be done with a loop *) FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi ); Traverse( 0, GetAdr( left ), GetAdr( dest ) ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE CopyContent( origdest, dest, elementSize ); END; SYSTEM.PUT( d, dest ); END ApplyGenericUnaryAAOpS; (** apply unary operator to array: array INTEGER -> array INTEGER *) PROCEDURE ApplyGenericUnaryAAOpI( d, l: ADDRESS; elementSize: LONGINT; Loop: GenericUnaryAALoopI; op: PROCEDURE(x: INTEGER): INTEGER ); VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT; origdest: LONGINT; modes: SET; dest, left: ADDRESS; dim: SIZE; PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS ); VAR len: LONGINT; linc, dinc: LONGINT; BEGIN IF dim = loopd THEN Loop( ladr, dadr, loopli, loopdi, looplen, op ); IF conservative THEN INC( glen, looplen ) END; ELSE len := GetLen( left, dim ); linc := GetIncr( left, dim ); dinc := GetIncr( dest, dim ); INC( dim ); WHILE (len > 0) DO Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END; END Traverse; BEGIN SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left ); origdest := 0; modes := {up, down}; (* allocate destination, if necessary *) p := AllocateSame( dest, left, elementSize ); IF p = NIL THEN CopyUpCompatible( dest, left, modes ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize ); END; END; (* allocate destination, if necessary *) (*IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize ) ELSIF CheckGeometry( left, dest, dim ) END; *) IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END; (* check pattern: longest piece that can be done with a loop *) FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi ); Traverse( 0, GetAdr( left ), GetAdr( dest ) ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE CopyContent( origdest, dest, elementSize ); END; SYSTEM.PUT( d, dest ); END ApplyGenericUnaryAAOpI; (** apply unary operator to array: array LONGINT -> array LONGINT *) PROCEDURE ApplyGenericUnaryAAOpL( d, l: ADDRESS; elementSize: LONGINT; Loop: GenericUnaryAALoopL; op: PROCEDURE(x: LONGINT): LONGINT ); VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT; origdest: LONGINT; modes: SET; dest, left: ADDRESS; dim: SIZE; PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS ); VAR len: LONGINT; linc, dinc: LONGINT; BEGIN IF dim = loopd THEN Loop( ladr, dadr, loopli, loopdi, looplen, op ); IF conservative THEN INC( glen, looplen ) END; ELSE len := GetLen( left, dim ); linc := GetIncr( left, dim ); dinc := GetIncr( dest, dim ); INC( dim ); WHILE (len > 0) DO Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END; END Traverse; BEGIN SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left ); origdest := 0; modes := {up, down}; (* allocate destination, if necessary *) p := AllocateSame( dest, left, elementSize ); IF p = NIL THEN CopyUpCompatible( dest, left, modes ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize ); END; END; (* allocate destination, if necessary *) (*IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize ) ELSIF CheckGeometry( left, dest, dim ) END; *) IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END; (* check pattern: longest piece that can be done with a loop *) FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi ); Traverse( 0, GetAdr( left ), GetAdr( dest ) ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE CopyContent( origdest, dest, elementSize ); END; SYSTEM.PUT( d, dest ); END ApplyGenericUnaryAAOpL; (** apply unary operator to array: array HUGEINT -> array HUGEINT *) PROCEDURE ApplyGenericUnaryAAOpH( d, l: ADDRESS; elementSize: LONGINT; Loop: GenericUnaryAALoopH; op: PROCEDURE(x: HUGEINT): HUGEINT ); VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT; origdest: LONGINT; modes: SET; VAR dest, left: ADDRESS; dim: SIZE; PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS ); VAR len: LONGINT; linc, dinc: LONGINT; BEGIN IF dim = loopd THEN Loop( ladr, dadr, loopli, loopdi, looplen, op ); IF conservative THEN INC( glen, looplen ) END; ELSE len := GetLen( left, dim ); linc := GetIncr( left, dim ); dinc := GetIncr( dest, dim ); INC( dim ); WHILE (len > 0) DO Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END; END Traverse; BEGIN SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left ); origdest := 0; modes := {up, down}; (* allocate destination, if necessary *) p := AllocateSame( dest, left, elementSize ); IF p = NIL THEN CopyUpCompatible( dest, left, modes ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize ); END; END; (* (* allocate destination, if necessary *) IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize ) ELSIF CheckGeometry( left, dest, dim ) END; *) IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END; (* check pattern: longest piece that can be done with a loop *) FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi ); Traverse( 0, GetAdr( left ), GetAdr( dest ) ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE CopyContent( origdest, dest, elementSize ); END; SYSTEM.PUT( d, dest ); END ApplyGenericUnaryAAOpH; (** apply unary operator to array: array REAL -> array REAL *) PROCEDURE ApplyGenericUnaryAAOpR( d, l: ADDRESS; elementSize: LONGINT; Loop: GenericUnaryAALoopR; op: PROCEDURE(x: REAL): REAL ); VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT; origdest: LONGINT; modes: SET; dest, left: ADDRESS; dim: SIZE; PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS ); VAR len: LONGINT; linc, dinc: LONGINT; BEGIN IF dim = loopd THEN Loop( ladr, dadr, loopli, loopdi, looplen, op ); IF conservative THEN INC( glen, looplen ) END; ELSE len := GetLen( left, dim ); linc := GetIncr( left, dim ); dinc := GetIncr( dest, dim ); INC( dim ); WHILE (len > 0) DO Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END; END Traverse; BEGIN SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left ); origdest := 0; modes := {up, down}; (* allocate destination, if necessary *) p := AllocateSame( dest, left, elementSize ); IF p = NIL THEN CopyUpCompatible( dest, left, modes ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize ); END; END; (* allocate destination, if necessary *) (*IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize ) ELSIF CheckGeometry( left, dest, dim ) END; *) IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END; (* check pattern: longest piece that can be done with a loop *) FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi ); Traverse( 0, GetAdr( left ), GetAdr( dest ) ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE CopyContent( origdest, dest, elementSize ); END; SYSTEM.PUT( d, dest ); END ApplyGenericUnaryAAOpR; (** apply unary operator to array: array LONGREAL -> array LONGREAL *) PROCEDURE ApplyGenericUnaryAAOpX( d, l: ADDRESS; elementSize: LONGINT; Loop: GenericUnaryAALoopX; op: PROCEDURE(x: LONGREAL): LONGREAL ); VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT; origdest: LONGINT; modes: SET; dest, left: ADDRESS; dim: SIZE; PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS ); VAR len: LONGINT; linc, dinc: LONGINT; BEGIN IF dim = loopd THEN Loop( ladr, dadr, loopli, loopdi, looplen, op ); IF conservative THEN INC( glen, looplen ) END; ELSE len := GetLen( left, dim ); linc := GetIncr( left, dim ); dinc := GetIncr( dest, dim ); INC( dim ); WHILE (len > 0) DO Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END; END Traverse; BEGIN SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left ); origdest := 0; modes := {up, down}; (* allocate destination, if necessary *) p := AllocateSame( dest, left, elementSize ); IF p = NIL THEN CopyUpCompatible( dest, left, modes ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize ); END; END; (* (* allocate destination, if necessary *) IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize ) ELSIF CheckGeometry( left, dest, dim ) END; *) IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END; (* check pattern: longest piece that can be done with a loop *) FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi ); Traverse( 0, GetAdr( left ), GetAdr( dest ) ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE CopyContent( origdest, dest, elementSize ); END; SYSTEM.PUT( d, dest ); END ApplyGenericUnaryAAOpX; (** apply unary operator to array: array COMPLEX -> array COMPLEX *) PROCEDURE ApplyGenericUnaryAAOpZ( d, l: ADDRESS; elementSize: LONGINT; Loop: GenericUnaryAALoopZ; op: PROCEDURE(x: COMPLEX): COMPLEX ); VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT; origdest: LONGINT; modes: SET; dest, left: ADDRESS; dim: SIZE; PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS ); VAR len: LONGINT; linc, dinc: LONGINT; BEGIN IF dim = loopd THEN Loop( ladr, dadr, loopli, loopdi, looplen, op ); IF conservative THEN INC( glen, looplen ) END; ELSE len := GetLen( left, dim ); linc := GetIncr( left, dim ); dinc := GetIncr( dest, dim ); INC( dim ); WHILE (len > 0) DO Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END; END Traverse; BEGIN SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left ); origdest := 0; modes := {up, down}; (* allocate destination, if necessary *) p := AllocateSame( dest, left, elementSize ); IF p = NIL THEN CopyUpCompatible( dest, left, modes ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize ); END; END; (* (* allocate destination, if necessary *) IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize ) ELSIF CheckGeometry( left, dest, dim ) END; *) IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END; (* check pattern: longest piece that can be done with a loop *) FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi ); Traverse( 0, GetAdr( left ), GetAdr( dest ) ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE CopyContent( origdest, dest, elementSize ); END; SYSTEM.PUT( d, dest ); END ApplyGenericUnaryAAOpZ; (** apply unary operator to array: array LONGCOMPLEX -> array LONGCOMPLEX *) PROCEDURE ApplyGenericUnaryAAOpLZ( d, l: ADDRESS; elementSize: LONGINT; Loop: GenericUnaryAALoopLZ; op: PROCEDURE(x: LONGCOMPLEX): LONGCOMPLEX ); VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT; origdest: LONGINT; modes: SET; dest, left: ADDRESS; dim: SIZE; PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS ); VAR len: LONGINT; linc, dinc: LONGINT; BEGIN IF dim = loopd THEN Loop( ladr, dadr, loopli, loopdi, looplen, op ); IF conservative THEN INC( glen, looplen ) END; ELSE len := GetLen( left, dim ); linc := GetIncr( left, dim ); dinc := GetIncr( dest, dim ); INC( dim ); WHILE (len > 0) DO Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END; END Traverse; BEGIN SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left ); origdest := 0; modes := {up, down}; (* allocate destination, if necessary *) p := AllocateSame( dest, left, elementSize ); IF p = NIL THEN CopyUpCompatible( dest, left, modes ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize ); END; END; (* (* allocate destination, if necessary *) IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize ) ELSIF CheckGeometry( left, dest, dim ) END; *) IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END; (* check pattern: longest piece that can be done with a loop *) FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi ); Traverse( 0, GetAdr( left ), GetAdr( dest ) ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE CopyContent( origdest, dest, elementSize ); END; SYSTEM.PUT( d, dest ); END ApplyGenericUnaryAAOpLZ; (** apply unary operator to array: array -> array *) PROCEDURE ApplyUnaryAAOp( d, l: ADDRESS; elementSize: LONGINT; Loop: UnaryAALoop ); VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT; origdest: LONGINT; modes: SET; dest, left: ADDRESS; dim: SIZE; PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS ); VAR len: LONGINT; linc, dinc: LONGINT; BEGIN IF dim = loopd THEN Loop( ladr, dadr, loopli, loopdi, looplen ); IF conservative THEN INC( glen, looplen ) END; ELSE len := GetLen( left, dim ); linc := GetIncr( left, dim ); dinc := GetIncr( dest, dim ); INC( dim ); WHILE (len > 0) DO Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END; END Traverse; BEGIN SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left ); origdest := 0; modes := {up, down}; (* allocate destination, if necessary *) p := AllocateSame( dest, left, elementSize ); IF p = NIL THEN CopyUpCompatible( dest, left, modes ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize ); END; END; (* (* allocate destination, if necessary *) IF GetAdr( dest ) = -1 THEN p := Allocate( left, dest, dim, elementSize ) ELSIF CheckGeometry( left, dest, dim ) END; *) IF debug THEN Report( "AA: left", left ); Report( "AA: dest", dest ); END; (* check pattern: longest piece that can be done with a loop *) FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi ); Traverse( 0, GetAdr( left ), GetAdr( dest ) ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE CopyContent( origdest, dest, elementSize ); END; SYSTEM.PUT( d, dest ); END ApplyUnaryAAOp; (** apply unary operator to array: array -> scalar *) PROCEDURE ApplyUnaryASOp( dest, l: ADDRESS; Loop: UnaryASLoop ); VAR loopd, looplen, loopli: LONGINT; glen: LONGINT; VAR left, dim: LONGINT; PROCEDURE Traverse( dim: LONGINT; ladr: ADDRESS ); VAR len: LONGINT; linc: LONGINT; BEGIN IF dim = loopd THEN Loop( ladr, dest, loopli, looplen ); IF conservative THEN INC( glen, looplen ) END; ELSE len := GetLen( left, dim ); linc := GetIncr( left, dim ); INC( dim ); WHILE (len > 0) DO Traverse( dim, ladr ); INC( ladr, linc ); DEC( len ); END; END; END Traverse; BEGIN SYSTEM.GET( l, left ); dim := GetDim( left ); IF debug THEN Report( "AS: left", left ); END; (* check pattern: longest piece that can be done with a loop *) IF conservative THEN glen := 0 END; FindPattern1( left, dim, loopd, looplen, loopli ); Traverse( 0, GetAdr( left ) ); IF conservative THEN looplen := 1; WHILE (dim > 0) DO looplen := looplen * GetLen( left, dim - 1 ); DEC( dim ); END; ASSERT( looplen = glen ); END; END ApplyUnaryASOp; (** apply unary operator to array: scalar -> array *) PROCEDURE ApplyUnarySAOp( d, right: ADDRESS; Loop: UnarySALoop ); VAR loopd, looplen, loopdi: LONGINT; glen: LONGINT; VAR dest, dim: LONGINT; PROCEDURE Traverse( dim: LONGINT; dadr: ADDRESS ); VAR len: LONGINT; dinc: LONGINT; BEGIN IF dim = loopd THEN Loop( right, dadr, loopdi, looplen ); IF conservative THEN INC( glen, looplen ) END; ELSE len := GetLen( dest, dim ); dinc := GetIncr( dest, dim ); INC( dim ); WHILE (len > 0) DO Traverse( dim, dadr ); INC( dadr, dinc ); DEC( len ); END; END; END Traverse; BEGIN SYSTEM.GET( d, dest ); dim := GetDim( dest ); IF debug THEN Report( "AS: dest", dest ); END; (* check pattern: longest piece that can be done with a loop *) IF conservative THEN glen := 0 END; FindPattern1( dest, dim, loopd, looplen, loopdi ); Traverse( 0, GetAdr( dest ) ); IF conservative THEN looplen := 1; WHILE (dim > 0) DO looplen := looplen * GetLen( dest, dim - 1 ); DEC( dim ); END; ASSERT( looplen = glen ); END; END ApplyUnarySAOp; (** apply binary operator : array x array -> array *) PROCEDURE ApplyBinaryAAAOp( d, l, r: ADDRESS; elementSize: LONGINT; Loop: BinaryAAALoop ); VAR loopd, looplen, loopli, loopri, loopdi: LONGINT; p: ANY; glen: LONGINT; origdest: LONGINT; modes: SET; left, right, dest: ADDRESS; dim: LONGINT; PROCEDURE Traverse( dim: LONGINT; ladr, radr, dadr: ADDRESS ); VAR len: LONGINT; linc, rinc, dinc: LONGINT; BEGIN IF dim = loopd THEN Loop( ladr, radr, dadr, loopli, loopri, loopdi, looplen ); IF conservative THEN INC( glen, looplen ) END; ELSE len := GetLen( left, dim ); linc := GetIncr( left, dim ); rinc := GetIncr( right, dim ); dinc := GetIncr( dest, dim ); INC( dim ); WHILE (len > 0) DO Traverse( dim, ladr, radr, dadr ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END; END Traverse; BEGIN SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); SYSTEM.GET( r, right ); dim := GetDim( left ); (* allocate destination, if necessary *) IF ~SameShape( left, right ) THEN Halt( GeometryMismatch, left, right, 0 ) END; origdest := 0; modes := {up, down}; p := AllocateSame( dest, left, elementSize ); IF p = NIL THEN CopyUpCompatible( dest, left, modes ); CopyUpCompatible( dest, right, modes ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ); Reverse( right, dim ); ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize ); (* 1d field ? *) END; END; (* debugging *) IF debug THEN Report( "AAA:left", left ); Report( "AAA:right", right ); Report( "AAA:dest", dest ); END; (* check pattern: longest piece that can be done with a loop *) FindPattern3( left, right, dest, dim, loopd, looplen, loopli, loopri, loopdi ); (* run through dimensions *) Traverse( 0, GetAdr( left ), GetAdr( right ), GetAdr( dest ) ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ); Reverse( right, dim ); ELSE CopyContent( origdest, dest, elementSize ); END; SYSTEM.PUT( d, dest ); END ApplyBinaryAAAOp; (** apply binary operator: array x scalar -> array *) PROCEDURE ApplyBinaryASAOp( d, l, right: ADDRESS; elementSize: LONGINT; Loop: BinaryASALoop ); VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT; origdest: LONGINT; modes: SET; dest, left: ADDRESS; dim: SIZE; PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS ); VAR len: LONGINT; linc, dinc: LONGINT; BEGIN IF dim = loopd THEN Loop( ladr, right, dadr, loopli, loopdi, looplen ); IF conservative THEN INC( glen, looplen ) END; ELSE len := GetLen( left, dim ); linc := GetIncr( left, dim ); dinc := GetIncr( dest, dim ); INC( dim ); WHILE (len > 0) DO Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END; END Traverse; BEGIN SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); dim := GetDim( left ); (* allocate destination, if necessary *) origdest := 0; modes := {up, down}; p := AllocateSame( dest, left, elementSize ); IF p = NIL THEN CopyUpCompatible( dest, left, modes ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE origdest := dest; p := AllocateTemp( dest, origdest, elementSize ); END; END; (* debugging *) IF debug THEN Report( "ASA:left", left ); Report( "ASA:dest", dest ); END; (* check pattern: longest piece that can be done with a loop *) FindPattern2( left, dest, dim, loopd, looplen, loopli, loopdi ); (* run through dimensions *) IF conservative THEN glen := 0 END; Traverse( 0, GetAdr( left ), GetAdr( dest ) ); IF conservative THEN looplen := 1; WHILE (dim > 0) DO looplen := looplen * GetLen( left, dim - 1 ); DEC( dim ); END; ASSERT( looplen = glen ); END; IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( left, dim ); Reverse( dest, dim ) ELSE CopyContent( origdest, dest, elementSize ); END; SYSTEM.PUT( d, dest ); END ApplyBinaryASAOp; (** apply binary operator: array x array -> scalar *) PROCEDURE ApplyBinaryAASOp( dest, l, r: ADDRESS; Loop: BinaryAASLoop ); VAR loopd, looplen, loopli, loopri: LONGINT; glen: LONGINT; left, right, dim: LONGINT; PROCEDURE Traverse( dim: LONGINT; ladr, radr: ADDRESS ); VAR len: LONGINT; linc, rinc: LONGINT; BEGIN IF dim = loopd THEN Loop( ladr, radr, dest, loopli, loopri, looplen ); IF conservative THEN INC( glen, looplen ) END; ELSE len := GetLen( left, dim ); linc := GetIncr( left, dim ); rinc := GetIncr( right, dim ); INC( dim ); WHILE (len > 0) DO Traverse( dim, ladr, radr ); INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; END; END Traverse; BEGIN SYSTEM.GET( l, left ); SYSTEM.GET( r, right ); dim := GetDim( left ); (* check array lengths *) IF ~SameShape( left, right ) THEN Halt( GeometryMismatch, left, right, 0 ) END; IF debug THEN Report( "AAS:left", left ); Report( "AAS:right", right ); END; (* check pattern: longest piece that can be done with a loop *) FindPattern2( left, right, dim, loopd, looplen, loopli, loopri ); (* run through dimensions *) IF conservative THEN glen := 0 END; Traverse( 0, GetAdr( left ), GetAdr( right ) ); IF conservative THEN looplen := 1; WHILE (dim > 0) DO looplen := looplen * GetLen( left, dim - 1 ); DEC( dim ); END; ASSERT( looplen = glen ); END; END ApplyBinaryAASOp; (** special binary operator: array x array -> boolean *) PROCEDURE ApplyBinaryAABOp( l, r: ADDRESS; Loop: BinaryAABLoop; geometryMismatchDefault: BOOLEAN ): BOOLEAN; VAR loopd, looplen, loopli, loopri: LONGINT; left, right, dim: LONGINT; PROCEDURE Traverse( dim: LONGINT; ladr, radr: ADDRESS ): BOOLEAN; VAR len: LONGINT; linc, rinc: LONGINT; BEGIN IF dim = loopd THEN RETURN Loop( ladr, radr, loopli, loopri, looplen ); ELSE len := GetLen( left, dim ); linc := GetIncr( left, dim ); rinc := GetIncr( right, dim ); INC( dim ); WHILE (len > 0) DO IF ~Traverse( dim, ladr, radr ) THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END; END Traverse; BEGIN SYSTEM.GET( l, left ); SYSTEM.GET( r, right ); dim := GetDim( left ); (* check array lengths *) IF ~SameShape( left, right ) THEN RETURN geometryMismatchDefault END; (* is destination already allocated? (might be a temporary result) *) IF debug THEN Report( "AAB:left", left ); Report( "AAB:right", right ); END; (* check pattern: longest piece that can be done with a loop *) FindPattern2( left, right, dim, loopd, looplen, loopli, loopri ); (* run through dimensions *) RETURN Traverse( 0, GetAdr( left ), GetAdr( right ) ); END ApplyBinaryAABOp; (** special binary operator: array x scalar -> boolean *) PROCEDURE ApplyBinaryASBOp( l, right: ADDRESS; Loop: BinaryASBLoop ): BOOLEAN; VAR loopd, looplen, loopli: LONGINT; left, dim: LONGINT; PROCEDURE Traverse( dim: LONGINT; ladr: ADDRESS ): BOOLEAN; VAR len: LONGINT; linc: LONGINT; BEGIN IF dim = loopd THEN RETURN Loop( ladr, right, loopli, looplen ); ELSE len := GetLen( left, dim ); linc := GetIncr( left, dim ); INC( dim ); WHILE (len > 0) DO IF ~Traverse( dim, ladr ) THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END; END Traverse; BEGIN SYSTEM.GET( l, left ); dim := GetDim( left ); IF debug THEN Report( "AAB:left", left ); END; (* check pattern: longest piece that can be done with a loop *) FindPattern1( left, dim, loopd, looplen, loopli ); (* run through dimensions *) RETURN Traverse( 0, GetAdr( left ) ); END ApplyBinaryASBOp; (**** operators *) (*** copy *) PROCEDURE Copy4( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); CODE {SYSTEM.i386} MOV ECX, [EBP+ladr] ; ECX := ladr MOV EDX, [EBP+dadr] ; EDX := dadr MOV EBX, [EBP+len] ; EBX := len start: CMP EBX, 0 ; JLE end ; WHILE EBX > 0 DO MOV EAX, [ECX] ; EAX := SYSTEM.GET32(ECX) MOV [EDX], EAX ; SYSTEM.PUT32(EDX, EAX)) ADD ECX, [EBP+linc] ; INC(ECX, linc) ADD EDX, [EBP+dinc] ; INC(EDX, rinc) DEC EBX ; DEC(EBX) JMP start end: END Copy4; PROCEDURE Copy2( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); CODE {SYSTEM.i386} MOV ECX, [EBP+ladr] ; ECX := ladr MOV EDX, [EBP+dadr] ; EDX := dadr MOV EBX, [EBP+len] ; EBX := len start: CMP EBX, 0 ; JLE end ; WHILE EBX > 0 DO MOV AX, [ECX] ; EAX := SYSTEM.GET32(ECX) MOV [EDX], AX ; SYSTEM.PUT32(EDX, EAX)) ADD ECX, [EBP+linc] ; INC(ECX, linc) ADD EDX, [EBP+dinc] ; INC(EDX, rinc) DEC EBX ; DEC(EBX) JMP start end: END Copy2; PROCEDURE Copy1( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); CODE {SYSTEM.i386} MOV ECX, [EBP+ladr] ; ECX := ladr MOV EDX, [EBP+dadr] ; EDX := dadr MOV EBX, [EBP+len] ; EBX := len start: CMP EBX, 0 ; JLE end ; WHILE EBX > 0 DO MOV AL, [ECX] ; EAX := SYSTEM.GET32(ECX) MOV [EDX], AL ; SYSTEM.PUT32(EDX, EAX)) ADD ECX, [EBP+linc] ; INC(ECX, linc) ADD EDX, [EBP+dinc] ; INC(EDX, rinc) DEC EBX ; DEC(EBX) JMP start end: END Copy1; PROCEDURE Copy8( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); CODE {SYSTEM.i386} MOV ECX, [EBP+ladr] ; ECX := ladr MOV EDX, [EBP+dadr] ; EDX := dadr MOV EBX, [EBP+len] ; EBX := len start: CMP EBX, 0 ; JLE end ; WHILE EBX > 0 DO MOV EAX, [ECX] ; EAX := SYSTEM.GET32(ECX) MOV [EDX], EAX ; SYSTEM.PUT32(EDX, EAX)) MOV EAX, [ECX+4] ; EAX := SYSTEM.GET32(ECX+4) MOV [EDX+4], EAX ; SYSTEM.PUT32(EDX+4, EAX)) ADD ECX, [EBP+linc] ; INC(ECX, linc) ADD EDX, [EBP+dinc] ; INC(EDX, rinc) DEC EBX ; DEC(EBX) JMP start end: END Copy8; PROCEDURE -MoveB*( srcadr, destadr, len: LONGINT ); (** Correct move if overlap, might be important for some array operations, do not use SYSTEM.MOVE. *) CODE {SYSTEM.i386} MOV ECX, [ESP] ; len MOV EDI, [ESP+4] ; destadr MOV ESI, [ESP+8] ; srcadr CMP ESI, EDI JAE moveup ; src adr greater then dest adr, no problem with moving up MOV EAX, ESI ADD EAX, ECX CMP EAX, EDI JBE moveup ; no overlap, no problem, move up MOV ESI, EAX ADD EDI, ECX DEC ESI DEC EDI STD ; move down since overlap occured REP MOVSB JMP done moveup: CLD MOV BL, CL SHR ECX, 2 AND BL, 00000003H ; rest to move after 4 byte move REP MOVSD ; move 4 bytes each step MOV CL, BL REP MOVSB ; move rest in one byte steps done: ADD ESP, 12 ; adjust stack pointer(inline procedure!) END MoveB; PROCEDURE CopyContent( dest, src: ADDRESS; elementSize: SIZE ); (**! optimize *) VAR loopd, looplen, loopli, loopdi: LONGINT; p: ANY; glen: LONGINT; origdest: ADDRESS; modes: SET; dim: LONGINT; PROCEDURE Loop( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); BEGIN IF (dinc = elementSize) & (linc = elementSize) THEN MoveB( ladr, dadr, len * elementSize ); (* SYSTEM.MOVE( ladr, dadr, elementSize * len ); *) ELSIF (dinc = -elementSize) & (linc = -elementSize) THEN len := len * elementSize; MoveB( ladr - len + elementSize, dadr - len + elementSize, len ); ELSIF elementSize = 1 THEN Copy1( ladr, dadr, linc, dinc, len ); (* WHILE (len > 0) DO SYSTEM.PUT8( dadr, SYSTEM.GET8( ladr ) ); DEC( len ); INC( ladr, linc ); INC( dadr, dinc ); END; *) ELSIF elementSize = 2 THEN Copy2( ladr, dadr, linc, dinc, len ); (* WHILE (len > 0) DO SYSTEM.PUT16( dadr, SYSTEM.GET16( ladr ) ); DEC( len ); INC( ladr, linc ); INC( dadr, dinc ); END; *) ELSIF elementSize = 4 THEN Copy4( ladr, dadr, linc, dinc, len ); (* WHILE (len > 0) DO SYSTEM.PUT32( dadr, SYSTEM.GET32( ladr ) ); DEC( len ); INC( ladr, linc ); INC( dadr, dinc ); END; *) ELSIF elementSize = 8 THEN Copy8( ladr, dadr, linc, dinc, len ); (* WHILE (len > 0) DO SYSTEM.PUT32( dadr, SYSTEM.GET32( ladr ) ); SYSTEM.PUT32( dadr + 4, SYSTEM.GET32( ladr + 4 ) ); DEC( len ); INC( ladr, linc ); INC( dadr, dinc ); END; *) ELSE (* SYSTEM.MOVE is expensive ! *) WHILE (len > 0) DO SYSTEM.MOVE( ladr, dadr, elementSize ); DEC( len ); INC( ladr, linc ); INC( dadr, dinc ); END; END; END Loop; PROCEDURE Traverse( dim: LONGINT; ladr, dadr: ADDRESS ); VAR len: LONGINT; linc, dinc: LONGINT; BEGIN IF dim = loopd THEN Loop( ladr, dadr, loopli, loopdi, looplen ); IF conservative THEN INC( glen, looplen ) END; ELSE len := GetLen( src, dim ); linc := GetIncr( src, dim ); dinc := GetIncr( dest, dim ); INC( dim ); WHILE (len > 0) DO Traverse( dim, ladr, dadr ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END; END Traverse; BEGIN dim := GetDim( src ); origdest := 0; modes := {up, down}; (* copy modes *) ASSERT( SameShape( src, dest ) ); (* must be ensured by caller *) CopyUpCompatible( dest, src, modes ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN (* can only copy from top to bottom *) Reverse( src, dim ); Reverse( dest, dim ) ELSE (* can only copy via double buffer *) origdest := dest; p := AllocateTemp( dest, origdest, elementSize ); END; IF debug THEN Report( "AA: src", src ); Report( "AA: dest", dest ); END; (* check pattern: longest piece that can be done with a loop *) FindPattern2( src, dest, dim, loopd, looplen, loopli, loopdi ); Traverse( 0, GetAdr( src ), GetAdr( dest ) ); IF up IN modes THEN (* nothing to be done *) ELSIF down IN modes THEN Reverse( src, dim ); Reverse( dest, dim ) ELSE CopyContent( origdest, dest, elementSize ); END; END CopyContent; PROCEDURE AllocateSame( VAR dest: ADDRESS; src: ADDRESS; elementsize: LONGINT ): ANY; VAR ptr, data: ANY; Size: LONGINT; (* allocate a structure in dest compatible with src, if necessary. returns if allocation has taken place *) PROCEDURE UseDescriptor; VAR tag: LONGINT; BEGIN SYSTEM.GET( src - 4, tag ); Heaps.NewRec( ptr, tag, FALSE ); dest := ptr; END UseDescriptor; PROCEDURE NewData; VAR dim, len, size: LONGINT; BEGIN dim := GetDim( src ); size := elementsize; PutDim( dest, dim ); PutSize( dest, elementsize ); WHILE (dim > 0) DO DEC( dim ); len := GetLen( src, dim ); PutLen( dest, dim, len ); PutInc( dest, dim, size ); size := size * len; END; SYSTEM.NEW( data, size ); PutAdr( dest, data); PutPtr( dest, data ); END NewData; BEGIN IF dest # NIL THEN Size := GetSize( dest ); ASSERT( Size = elementsize ); END; IF debug THEN KernelLog.String( "Allocate same " ); Report( "allocation source", src ); Report( "allocation des", dest ); END; IF dest = NIL THEN (* NIL pointer, guaranteed to be tensor *) IF TensorFlag IN GetFlags( src ) THEN UseDescriptor(); ELSE ptr := GetArrayDesc( GetDim( src ) ); dest :=ptr; END; PutFlags(dest, {TensorFlag}); NewData(); RETURN ptr; ELSIF GetDim( dest ) # GetDim( src ) THEN (* different dimension *) (* check if re-allocation of descriptor is allowed *) IF ~(TensorFlag IN GetFlags( dest )) & ~(TemporaryFlag IN GetFlags( dest )) THEN (* no, not allowed*) HALT( 100 ); END; UseDescriptor(); PutFlags(dest, {TensorFlag}); NewData(); RETURN ptr; ELSIF (GetAdr( dest ) = 0) OR ~SameShape( dest, src ) THEN (* check if re-allocation of array data is allowed *) IF RangeFlag IN GetFlags( dest ) THEN (* no! not allowed *) HALT( 100 ); END; NewData(); RETURN data; ELSE (* nothing to do *) RETURN NIL; END; END AllocateSame; PROCEDURE TempDescCopy( src: ADDRESS ): ANY; VAR p: ANY; adr: ADDRESS;dim: SIZE; BEGIN dim := GetDim(src); p := GetArrayDesc(dim); adr := p; SYSTEM.MOVE( src, adr, dim * SIZEOF(LenInc) + MathLenOffset ); PutAdr( src, 0 ); PutPtr( src, NIL ); PutFlags( src, {} ); RETURN p; END TempDescCopy; (* used when arrays are passed by value *) PROCEDURE CopyArraySelf*( dest, src: ADDRESS; elementsize: LONGINT ); VAR p: ANY; BEGIN ASSERT( src = dest ); p := TempDescCopy( dest ); (* copy and prepare dest to be copied over *) CopyArray( dest, p, elementsize ); END CopyArraySelf; PROCEDURE CopyArray*( dest: ADDRESS; src: ADDRESS; elementsize: SIZE ); VAR p: ANY; srcdim, destdim: LONGINT; BEGIN ASSERT( dest # 0 ); (* impossible unless compiler error *) IF GetDim( src ) # GetDim( dest ) THEN (* not allowed but possible (tensor) *) srcdim := GetDim(src); destdim := GetDim(dest); (* Debugging.Stack("copy array"); *) Report( "copy array source", src ); Report( "copy array des", dest ); HALT(100); ELSIF src = dest THEN (* self copy *) CopyArraySelf( dest, src, elementsize ); ELSE p := AllocateSame( dest, src, elementsize ); CopyContent( dest, src, elementsize ) END; END CopyArray; PROCEDURE CopyTensorSelf*( VAR dest: ADDRESS; src: ADDRESS; elementsize: SIZE ); BEGIN dest := 0; CopyTensor( dest, src, elementsize ); END CopyTensorSelf; PROCEDURE CopyTensor*( VAR dest: ADDRESS; src: ADDRESS; elementsize: SIZE ); VAR p: ANY; BEGIN (* Report("dest",dest); Report("src",src); *) IF (dest = 0) OR ~(SameShape( dest, src )) OR (GetAdr( dest ) = 0) THEN p := AllocateSame( dest, src, elementsize ); (* includes check if allocation is allowed *) CopyContent( dest, src, elementsize ); ELSIF dest = src THEN CopyTensorSelf( dest, src, elementsize ); ELSE CopyContent( dest, src, elementsize ) END; END CopyTensor; (* copy descriptor of src to that of dest. If not existent then create.*) PROCEDURE ShallowCopy*(VAR dest: ADDRESS; src: ADDRESS); VAR ptr: ANY; flags: SET; PROCEDURE UseTypeDescriptor; VAR tag: LONGINT; ptr: ANY; BEGIN SYSTEM.GET( src + Heaps.TypeDescOffset, tag ); Heaps.NewRec( ptr, tag, FALSE ); dest := SYSTEM.VAL( LONGINT, ptr ); END UseTypeDescriptor; PROCEDURE CopyDescriptor; BEGIN SYSTEM.MOVE( src , dest, MathLenOffset + SIZEOF(ADDRESS) * GetDim( src ) *2 ); END CopyDescriptor; BEGIN (* KernelLog.String("ShallowCopy called with "); KernelLog.Int(src,10); KernelLog.Int(dest,10); KernelLog.Ln; Report( "scopy source", src ); Report( "scopy dest", dest ); *) IF dest = 0 THEN (* NIL pointer, guaranteed to be tensor *) IF TensorFlag IN GetFlags( src ) THEN UseTypeDescriptor(); ELSE ptr := GetArrayDesc( GetDim( src ) ); dest := SYSTEM.VAL( LONGINT, ptr ); (* ??? *) END; CopyDescriptor(); PutFlags(dest, {TensorFlag}); ELSIF GetDim( dest ) # GetDim( src ) THEN (* different dimension *) flags := GetFlags(dest); (* check if re-allocation of descriptor is allowed *) IF ~(TensorFlag IN GetFlags( dest )) & ~(TemporaryFlag IN GetFlags( dest )) THEN (* no, not allowed*) Halt(DimensionMismatch,src,0,dest); END; (* create a new descriptor!!! (added by Alexey) *) ptr := GetArrayDesc( GetDim( src ) ); dest := SYSTEM.VAL( LONGINT, ptr ); CopyDescriptor(); PutFlags(dest, flags); ELSE flags := GetFlags(dest); (* check if re-allocation of array data is allowed *) IF RangeFlag IN GetFlags( dest ) THEN (* no! not allowed *) Halt(AllocationForbidden,src,0,dest); END; CopyDescriptor(); PutFlags(dest, flags); END; END ShallowCopy; PROCEDURE DescriptorCopy( src, dest: LONGINT ); BEGIN IF debug THEN KernelLog.String( "DescriptorCopy from " ); KernelLog.Int( src, 1 ); KernelLog.String( " to " ); KernelLog.Int( dest, 1 ); KernelLog.Ln; END; SYSTEM.MOVE( src, dest, 2*SIZEOF(ADDRESS) ); (* adr and ptr *) SYSTEM.MOVE( src + MathLenOffset, dest + MathLenOffset, SIZEOF(ADDRESS) * GetDim( src ) *2 ); (* lens and increments *) END DescriptorCopy; PROCEDURE ZeroCopy*(CONST src: ARRAY [?]; VAR dest: ARRAY [?]); VAR s,d: ADDRESS; BEGIN s := SYSTEM.VAL(LONGINT,src); d := SYSTEM.VAL(LONGINT,dest); ShallowCopy(d,s); SYSTEM.PUT(ADDRESSOF(dest),d); END ZeroCopy; OPERATOR "ALIAS"*(CONST src: ARRAY [?]): ARRAY[?]; BEGIN ZeroCopy(src, RESULT); RETURN RESULT END "ALIAS"; PROCEDURE SameShape( l, r: ADDRESS ): BOOLEAN; VAR dim: LONGINT; BEGIN dim := GetDim( l ); IF dim # GetDim( r ) THEN RETURN FALSE END; WHILE (dim > 0) DO DEC( dim ); IF GetLen( l, dim ) # GetLen( r, dim ) THEN RETURN FALSE END; END; RETURN TRUE; END SameShape; (* PROCEDURE ZeroCopyArray*( dest: ADDRESS; src: ADDRESS; elementsize: LONGINT ); (* called as ZeroCopy(A,B,Size) with enhanced arrays A,B check if deep copy can be avoided and if so then do a shallow copy *) BEGIN ASSERT( dest # 0 ); (* impossible *) IF GetDim( src ) # GetDim( dest ) THEN (* not allowed but possible (tensor) *) HALT( 100 ); ELSIF (RangeFlag IN GetFlags( src )) THEN (* must copy (and allocate) *) CopyArray( dest, src, elementsize ); ELSIF (RangeFlag IN GetFlags( dest )) THEN (* copy only allowed if shape matches *) IF ~SameShape( dest, src ) THEN HALT( 100 ); ELSE CopyContent( dest, src, elementsize ) END; ELSE DescriptorCopy( src, dest ) END; END ZeroCopyArray; PROCEDURE ZeroCopyTensor*( VAR dest: ADDRESS; src: ADDRESS; elementsize: LONGINT ); (* called as ZeroCopy(A,B,Size) with A,B: ARRAY [?] OF ... check if deep copy can be avoided and if so then do a shallow copy *) BEGIN IF debug THEN KernelLog.String( "ZeroCopy2: " ); KernelLog.String( "ADDRESSOF(dest) " ); KernelLog.Int( ADDRESSOF( dest ), 10 ); KernelLog.Ln; KernelLog.String( "ADDRESSOF(src) " ); KernelLog.Int( ADDRESSOF( src ), 10 ); KernelLog.Ln; KernelLog.String( "dest " ); KernelLog.Int( dest, 10 ); KernelLog.Ln; KernelLog.String( "src " ); KernelLog.Int( src, 10 ); KernelLog.Ln; KernelLog.String( "elementsize" ); KernelLog.Int( elementsize, 10 ); KernelLog.Ln; END; IF (dest = 0) OR (TensorFlag IN GetFlags( dest )) THEN (* descriptor allocation allowed *) IF (TensorFlag IN GetFlags( src )) THEN dest := src; ELSE CopyTensor( dest, src, elementsize ); (* allocate freshly *) END; ELSIF (RangeFlag IN GetFlags( src )) THEN (* must copy (and allocate) *) CopyTensor( dest, src, elementsize ); ELSIF (RangeFlag IN GetFlags( dest )) THEN (* descriptor copy forbidden *) IF SameShape( src, dest ) THEN CopyContent( dest, src, elementsize ) ELSE HALT( 100 ); (* copy forbidden *) END; ELSIF GetDim( src ) = GetDim( dest ) THEN (* descriptor copy allowed *) DescriptorCopy( src, dest ); ELSE HALT( 100 ); (* different shapes: not allowed *) END; END ZeroCopyTensor; PROCEDURE ZeroCopy*( left, elementSize, dest, dim: LONGINT ); (**! optimize *) VAR i: LONGINT; BEGIN IF GetPtr( dest ) = -1 THEN (* zero copy forbidden, try data copy *) CopyContent( dest, left, elementSize ) ELSE IF debug THEN KernelLog.String( "Zero Copy" ); KernelLog.Int( left, 10 ); KernelLog.Int( dest, 10 ); KernelLog.Ln; END; PutPtr( dest, GetPtr( left ) ); PutAdr( dest, GetAdr( left ) ); FOR i := 0 TO dim - 1 DO PutInc( dest, i, GetIncr( left, i ) ); PutLen( dest, i, GetLen( left, i ) ); END; END; END ZeroCopy; *) (*** conversions ****) (** SHORTINT -> INTEGER *) PROCEDURE ConvertASAILoop( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); BEGIN WHILE (len > 0) DO (* SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); *) SYSTEM.PUT16( dadr, SYSTEM.GET8( ladr ) ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ConvertASAILoop; OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF SHORTINT ): ARRAY [?] OF INTEGER; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( INTEGER ),ConvertASAILoop ); RETURN RESULT END "@Convert"; OPERATOR "LONG"*(CONST src: ARRAY [ ? ] OF SHORTINT ): ARRAY [?] OF INTEGER; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( INTEGER ),ConvertASAILoop ); RETURN RESULT END "LONG"; (** SHORTINT -> LONGINT *) PROCEDURE ConvertLoopSL( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); BEGIN WHILE (len > 0) DO (* SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); *) SYSTEM.PUT32( dadr, SYSTEM.GET8( ladr ) ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ConvertLoopSL; OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF SHORTINT ): ARRAY [?] OF LONGINT; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ),ConvertLoopSL ); RETURN RESULT END "@Convert"; (** SHORTINT -> REAL *) PROCEDURE ConvertLoopSR( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: SHORTINT; dval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ConvertLoopSR; OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF SHORTINT ): ARRAY [?] OF REAL; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( REAL ), ConvertLoopSR ); RETURN RESULT END "@Convert"; (** SHORTINT -> LONGREAL *) PROCEDURE ConvertLoopSX( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: SHORTINT; dval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ConvertLoopSX; OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF SHORTINT ): ARRAY [ ? ] OF LONGREAL; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGREAL ), ConvertLoopSX ); RETURN RESULT END "@Convert"; (** INTEGER -> SHORTINT (SHORT) *) PROCEDURE ConvertLoopIS( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: INTEGER; dval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := SHORT( lval ); SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ConvertLoopIS; OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF SHORTINT; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( SHORTINT ), ConvertLoopIS ); RETURN RESULT END "@Convert"; OPERATOR "SHORT"*(CONST src: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF SHORTINT; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( SHORTINT ), ConvertLoopIS ); RETURN RESULT END "SHORT"; (** INTEGER -> LONGINT *) PROCEDURE ConvertLoopIL( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); BEGIN WHILE (len > 0) DO (* SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); *) SYSTEM.PUT32( dadr, SYSTEM.GET16( ladr ) ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ConvertLoopIL; OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF LONGINT; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ), ConvertLoopIL ); RETURN RESULT END "@Convert"; OPERATOR "LONG"*(CONST src: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF LONGINT; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ), ConvertLoopIL ); RETURN RESULT END "LONG"; (** INTEGER -> REAL *) PROCEDURE ConvertLoopIR( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: INTEGER; dval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ConvertLoopIR; OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF REAL; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( REAL ), ConvertLoopIR ); RETURN RESULT END "@Convert"; (** INTEGER -> LONGREAL *) PROCEDURE ConvertLoopIX( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: INTEGER; dval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ConvertLoopIX; OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF LONGREAL; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGREAL ), ConvertLoopIX ); RETURN RESULT END "@Convert"; (** LONGINT -> INTEGER (SHORT) *) PROCEDURE ConvertLoopLI( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: LONGINT; dval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := SHORT( lval ); SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ConvertLoopLI; OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF INTEGER; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( INTEGER ),ConvertLoopLI ); RETURN RESULT END "@Convert"; OPERATOR "SHORT"*(CONST src: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF INTEGER; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( INTEGER ),ConvertLoopLI ); RETURN RESULT END "SHORT"; (** LONGINT -> REAL *) PROCEDURE ConvertLoopLR( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: LONGINT; dval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ConvertLoopLR; OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF REAL; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( REAL ), ConvertLoopLR ); RETURN RESULT END "@Convert"; (** LONGINT -> LONGREAL *) PROCEDURE ConvertLoopLX( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: LONGINT; dval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ConvertLoopLX; OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF LONGREAL; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGREAL ), ConvertLoopLX ); RETURN RESULT END "@Convert"; (** REAL -> LONGINT (ENTIER) *) PROCEDURE ConvertLoopRL( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: REAL; dval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := ENTIER( lval ); SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ConvertLoopRL; OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF LONGINT; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ), ConvertLoopRL ); RETURN RESULT END "@Convert"; OPERATOR "ENTIER"*(CONST src: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF LONGINT; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ), ConvertLoopRL ); RETURN RESULT END "ENTIER"; (** REAL -> LONGREAL *) PROCEDURE ConvertLoopRX( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: REAL; dval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ConvertLoopRX; OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF LONGREAL; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGREAL ), ConvertLoopRX ); RETURN RESULT END "@Convert"; OPERATOR "LONG"*(CONST src: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF LONGREAL; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGREAL ), ConvertLoopRX ); RETURN RESULT END "LONG"; (** LONGREAL -> REAL (SHORT) *) PROCEDURE ConvertLoopXR( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: LONGREAL; dval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := SHORT( lval ); SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ConvertLoopXR; OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF REAL; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( REAL ), ConvertLoopXR ); RETURN RESULT END "@Convert"; OPERATOR "SHORT"*(CONST src: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF REAL; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( REAL ), ConvertLoopXR ); RETURN RESULT END "SHORT"; (** LONGREAL -> LONGINT (ENTIER) *) PROCEDURE ConvertLoopXL( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: LONGREAL; dval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := ENTIER( lval ); SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ConvertLoopXL; OPERATOR "@Convert"*(CONST src: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF LONGINT; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ),ConvertLoopXL ); RETURN RESULT END "@Convert"; OPERATOR "ENTIER"*(CONST src: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF LONGINT; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ),ConvertLoopXL ); RETURN RESULT END "ENTIER"; (*** monadic not A -> ~A ********************************************************************) (** BOOLEAN *) PROCEDURE NotLoopAB( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: BOOLEAN; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, ~lval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END NotLoopAB; OPERATOR "~"*(CONST src: ARRAY [ ? ] OF BOOLEAN): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( BOOLEAN ), NotLoopAB ); RETURN RESULT END "~"; (*** monadic generic (A) -> -A ********************************************************************) (** SHORTINT *) PROCEDURE GenericLoopS( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: SHORTINT): SHORTINT ); VAR lval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, op(lval) ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END GenericLoopS; (** INTEGER *) PROCEDURE GenericLoopI( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: INTEGER): INTEGER ); VAR lval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, op(lval) ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END GenericLoopI; (** LONGINT *) PROCEDURE GenericLoopL( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: LONGINT): LONGINT ); VAR lval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, op(lval) ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END GenericLoopL; (** HUGEINT *) PROCEDURE GenericLoopH( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: HUGEINT): HUGEINT ); VAR lval: HUGEINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, op(lval) ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END GenericLoopH; (** REAL *) PROCEDURE GenericLoopR( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: REAL): REAL ); VAR lval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, op(lval) ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END GenericLoopR; (** LONGREAL *) PROCEDURE GenericLoopX( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: LONGREAL): LONGREAL ); VAR lval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, op(lval) ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END GenericLoopX; (** COMPLEX *) PROCEDURE GenericLoopZ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: COMPLEX): COMPLEX ); VAR lval,dval: POINTER{UNSAFE} TO RECORD val: COMPLEX END; BEGIN WHILE (len > 0) DO lval := ladr; dval := dadr; dval.val := op(lval.val); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END GenericLoopZ; (** LONGCOMPLEX *) PROCEDURE GenericLoopLZ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE; op: PROCEDURE(x: LONGCOMPLEX): LONGCOMPLEX ); VAR lval,dval: POINTER{UNSAFE} TO RECORD val: LONGCOMPLEX END; BEGIN WHILE (len > 0) DO lval := ladr; dval := dadr; dval.val := op (lval.val); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END GenericLoopLZ; (*** monadic minus A -> -A ********************************************************************) (** SHORTINT *) PROCEDURE MinusLoopS( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, -lval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END MinusLoopS; OPERATOR "-"*(CONST src: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( SHORTINT ), MinusLoopS ); RETURN RESULT END "-"; (** INTEGER *) PROCEDURE MinusLoopI( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, -lval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END MinusLoopI; OPERATOR "-"*(CONST src: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( INTEGER ), MinusLoopI ); RETURN RESULT END "-"; (** LONGINT *) PROCEDURE MinusLoopL( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, -lval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END MinusLoopL; OPERATOR "-"*(CONST src: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ), MinusLoopL ); RETURN RESULT END "-"; (** REAL *) PROCEDURE MinusLoopR( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, -lval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END MinusLoopR; OPERATOR "-"*(CONST src: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF REAL; BEGIN IF debug THEN KernelLog.String( "MinusAR" ); KernelLog.Ln; END; ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( REAL ), MinusLoopR ); RETURN RESULT END "-"; (** LONGREAL *) PROCEDURE MinusLoopX( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, -lval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END MinusLoopX; OPERATOR "-"*(CONST src: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF LONGREAL; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGREAL ), MinusLoopX ); RETURN RESULT END "-"; (*** add array + array -> array ********************************************************************) (** SHORTINT *) PROCEDURE AddASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END AddASASLoop; OPERATOR "+"*(CONST left,right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), AddASASLoop ); RETURN RESULT END "+"; (** INTEGER *) PROCEDURE AddAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END AddAIAILoop; OPERATOR "+"*(CONST left,right: ARRAY [?] OF INTEGER): ARRAY [?] OF INTEGER; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), AddAIAILoop ); RETURN RESULT END "+"; (** LONGINT *) PROCEDURE AddALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END AddALALLoop; OPERATOR "+"*(CONST left,right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), AddALALLoop ); RETURN RESULT END "+"; (** REAL *) PROCEDURE AddARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END AddARARLoop; OPERATOR "+"*(CONST left,right: ARRAY [?] OF REAL): ARRAY [?] OF REAL; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), loopAddARAR ); RETURN RESULT END "+"; (** LONGREAL *) PROCEDURE AddAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END AddAXAXLoop; OPERATOR "+"*(CONST left,right: ARRAY [?] OF LONGREAL): ARRAY [?] OF LONGREAL; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), loopAddAXAX ); RETURN RESULT END "+"; (** COMPLEX *) PROCEDURE AddAZAZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: COMPLEX; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END AddAZAZLoop; OPERATOR "+"*(CONST left,right: ARRAY [?] OF COMPLEX): ARRAY [?] OF COMPLEX; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( COMPLEX ), loopAddAZAZ ); RETURN RESULT END "+"; (** LONGCOMPLEX *) PROCEDURE AddALZALZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm ); SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm ); SYSTEM.PUT( dadr, lvalRe+rvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), lvalIm+rvalIm ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END AddALZALZLoop; OPERATOR "+"*(CONST left,right: ARRAY [?] OF LONGCOMPLEX): ARRAY [?] OF LONGCOMPLEX; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGCOMPLEX ), loopAddALZALZ ); RETURN RESULT END "+"; (*** add array + scalar -> array and scalar + array -> array ********************************************************************) (** SHORTINT *) PROCEDURE AddASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END AddASSSLoop; OPERATOR "+"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF SHORTINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), AddASSSLoop ); RETURN RESULT END "+"; OPERATOR "+"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( SHORTINT ), AddASSSLoop ); RETURN RESULT END "+"; (** INTEGER *) PROCEDURE AddAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END AddAISILoop; OPERATOR "+"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF INTEGER; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), AddAISILoop ); RETURN RESULT END "+"; OPERATOR "+"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( INTEGER ), AddAISILoop ); RETURN RESULT END "+"; (** LONGINT *) PROCEDURE AddALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END AddALSLLoop; OPERATOR "+"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF LONGINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), AddALSLLoop ); RETURN RESULT END "+"; OPERATOR "+"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGINT ), AddALSLLoop ); RETURN RESULT END "+"; (** REAL *) PROCEDURE AddARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END AddARSRLoop; OPERATOR "+"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF REAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), AddARSRLoop ); RETURN RESULT END "+"; OPERATOR "+"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF REAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ), AddARSRLoop ); RETURN RESULT END "+"; (** LONGREAL *) PROCEDURE AddAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END AddAXSXLoop; OPERATOR "+"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF LONGREAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), AddAXSXLoop ); RETURN RESULT END "+"; OPERATOR "+"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF LONGREAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGREAL ), AddAXSXLoop ); RETURN RESULT END "+"; (** COMPLEX *) PROCEDURE AddAZSZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: COMPLEX; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval + rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END AddAZSZLoop; OPERATOR "+"*(CONST left: ARRAY [ ? ] OF COMPLEX; right: COMPLEX ): ARRAY [ ? ] OF COMPLEX; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( COMPLEX ), AddAZSZLoop ); RETURN RESULT END "+"; OPERATOR "+"*(left: COMPLEX; CONST right: ARRAY [ ? ] OF COMPLEX): ARRAY [ ? ] OF COMPLEX; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( COMPLEX ), AddAZSZLoop ); RETURN RESULT END "+"; (** LONGCOMPLEX *) PROCEDURE AddALZSLZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL; BEGIN SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm ); WHILE (len > 0) DO SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm ); SYSTEM.PUT( dadr, lvalRe + rvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), lvalIm + rvalIm ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END AddALZSLZLoop; OPERATOR "+"*(CONST left: ARRAY [ ? ] OF LONGCOMPLEX; right: LONGCOMPLEX ): ARRAY [ ? ] OF LONGCOMPLEX; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGCOMPLEX ), AddALZSLZLoop ); RETURN RESULT END "+"; OPERATOR "+"*(left: LONGCOMPLEX; CONST right: ARRAY [ ? ] OF LONGCOMPLEX): ARRAY [ ? ] OF LONGCOMPLEX; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGCOMPLEX ), AddALZSLZLoop ); RETURN RESULT END "+"; (*** subtraction array - array -> array ********************************************************************) (** SHORTINT *) PROCEDURE SubASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval - rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END SubASASLoop; OPERATOR "-"*(CONST left,right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), SubASASLoop ); RETURN RESULT END "-"; (** INTEGER *) PROCEDURE SubAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval - rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END SubAIAILoop; OPERATOR "-"*(CONST left,right: ARRAY [?] OF INTEGER): ARRAY [?] OF INTEGER; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), SubAIAILoop ); RETURN RESULT END "-"; (** LONGINT *) PROCEDURE SubALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval - rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END SubALALLoop; OPERATOR "-"*(CONST left,right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), SubALALLoop ); RETURN RESULT END "-"; (** REAL *) PROCEDURE SubARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval - rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END SubARARLoop; OPERATOR "-"*(CONST left,right: ARRAY [?] OF REAL): ARRAY [?] OF REAL; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), SubARARLoop ); RETURN RESULT END "-"; (** LONGREAL *) PROCEDURE SubAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval - rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END SubAXAXLoop; OPERATOR "-"*(CONST left,right: ARRAY [?] OF LONGREAL): ARRAY [?] OF LONGREAL; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), SubAXAXLoop ); RETURN RESULT END "-"; (** COMPLEX *) PROCEDURE SubAZAZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: COMPLEX; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval - rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END SubAZAZLoop; OPERATOR "-"*(CONST left,right: ARRAY [?] OF COMPLEX): ARRAY [?] OF COMPLEX; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( COMPLEX ), SubAZAZLoop ); RETURN RESULT END "-"; (** LONGCOMPLEX *) PROCEDURE SubALZALZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm ); SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm ); SYSTEM.PUT( dadr, lvalRe-rvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), lvalIm-rvalIm ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END SubALZALZLoop; OPERATOR "-"*(CONST left,right: ARRAY [?] OF LONGCOMPLEX): ARRAY [?] OF LONGCOMPLEX; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGCOMPLEX ), SubALZALZLoop ); RETURN RESULT END "-"; (*** subtraction array-scalar -> array ********************************************************************) (** SHORTINT *) OPERATOR "-"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF SHORTINT; (* a: left, b: right, c: dest *) BEGIN RESULT := left + (-right); RETURN RESULT END "-"; (** INTEGER *) OPERATOR "-"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF INTEGER; BEGIN RESULT := left + (-right); RETURN RESULT END "-"; (** LONGINT *) OPERATOR "-"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF LONGINT; BEGIN RESULT := left + (-right); RETURN RESULT END "-"; (** REAL *) OPERATOR "-"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF REAL; BEGIN RESULT := left + (-right); RETURN RESULT END "-"; (** LONGREAL *) OPERATOR "-"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF LONGREAL; BEGIN RESULT := left + (-right); RETURN RESULT END "-"; (** COMPLEX *) OPERATOR "-"*(CONST left: ARRAY [ ? ] OF COMPLEX; right: COMPLEX ): ARRAY [ ? ] OF COMPLEX; BEGIN RESULT := left + (-right); RETURN RESULT END "-"; (** LONGCOMPLEX *) OPERATOR "-"*(CONST left: ARRAY [ ? ] OF LONGCOMPLEX; right: LONGCOMPLEX ): ARRAY [ ? ] OF LONGCOMPLEX; BEGIN RESULT := left + (-right); RETURN RESULT END "-"; (*** subtraction scalar-array -> array ********************************************************************) (** SHORTINT *) PROCEDURE SubSSASLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval, dval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval - lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END SubSSASLoop; OPERATOR "-"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( SHORTINT ), SubSSASLoop ); RETURN RESULT END "-"; (** INTEGER *) PROCEDURE SubSIAILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval, dval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval - lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END SubSIAILoop; OPERATOR "-"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( INTEGER ), SubSIAILoop ); RETURN RESULT END "-"; (** LONGINT *) PROCEDURE SubSLALLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval, dval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval - lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END SubSLALLoop; OPERATOR "-"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGINT ), SubSLALLoop ); RETURN RESULT END "-"; (** REAL *) PROCEDURE SubSRARLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval, dval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval - lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END SubSRARLoop; OPERATOR "-"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF REAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ), SubSRARLoop ); RETURN RESULT END "-"; (** LONGREAL *) PROCEDURE SubSXAXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval, dval: LONGREAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval - lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END SubSXAXLoop; OPERATOR "-"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF LONGREAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGREAL ), SubSXAXLoop ); RETURN RESULT END "-"; (** COMPLEX *) PROCEDURE SubSZAZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval, dval: COMPLEX; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval - lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END SubSZAZLoop; OPERATOR "-"*(left: COMPLEX; CONST right: ARRAY [ ? ] OF COMPLEX): ARRAY [ ? ] OF COMPLEX; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( COMPLEX ), SubSZAZLoop ); RETURN RESULT END "-"; (** LONGCOMPLEX *) PROCEDURE SubSLZALZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL; BEGIN SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm ); WHILE (len > 0) DO SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm ); SYSTEM.PUT( dadr, rvalRe-lvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), rvalIm-lvalIm ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END SubSLZALZLoop; OPERATOR "-"*(left: LONGCOMPLEX; CONST right: ARRAY [ ? ] OF LONGCOMPLEX): ARRAY [ ? ] OF LONGCOMPLEX; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGCOMPLEX ), SubSLZALZLoop ); RETURN RESULT END "-"; (*** element-wise multiply array x array -> array ********************************************************************) (** SHORTINT *) PROCEDURE EMulASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval * rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EMulASASLoop; OPERATOR ".*"*(CONST left,right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), EMulASASLoop ); RETURN RESULT END ".*"; (** INTEGER *) PROCEDURE EMulAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: INTEGER; dval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval * rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EMulAIAILoop; OPERATOR ".*"*(CONST left,right: ARRAY [?] OF INTEGER): ARRAY [?] OF INTEGER; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), EMulAIAILoop ); RETURN RESULT END ".*"; (** LONGINT *) PROCEDURE EMulALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval * rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EMulALALLoop; OPERATOR ".*"*(CONST left,right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), EMulALALLoop ); RETURN RESULT END ".*"; (** REAL *) PROCEDURE EMulARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval * rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EMulARARLoop; OPERATOR ".*"*(CONST left,right: ARRAY [?] OF REAL): ARRAY [?] OF REAL; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), EMulARARLoop ); RETURN RESULT END ".*"; (** LONGREAL *) PROCEDURE EMulAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval * rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EMulAXAXLoop; OPERATOR ".*"*(CONST left,right: ARRAY [?] OF LONGREAL): ARRAY [?] OF LONGREAL; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), EMulAXAXLoop ); RETURN RESULT END ".*"; (** COMPLEX *) PROCEDURE EMulAZAZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: COMPLEX; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval * rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EMulAZAZLoop; OPERATOR ".*"*(CONST left,right: ARRAY [?] OF COMPLEX): ARRAY [?] OF COMPLEX; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( COMPLEX ), EMulAZAZLoop ); RETURN RESULT END ".*"; (** LONGCOMPLEX *) PROCEDURE EMulALZALZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm ); SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm ); SYSTEM.PUT( dadr, lvalRe*rvalRe - lvalIm*rvalIm ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), lvalRe*rvalIm + lvalIm*rvalRe ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EMulALZALZLoop; OPERATOR ".*"*(CONST left,right: ARRAY [?] OF LONGCOMPLEX): ARRAY [?] OF LONGCOMPLEX; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGCOMPLEX ), EMulALZALZLoop ); RETURN RESULT END ".*"; (*** element-wise multiply and add array x array -> array ********************************************************************) (** SHORTINT *) PROCEDURE EMulIncASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval,dval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.GET(dadr,dval); SYSTEM.PUT( dadr, dval + lval * rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EMulIncASASLoop; OPERATOR ".*+"*(CONST left,right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), EMulIncASASLoop ); END ".*+"; (** INTEGER *) PROCEDURE EMulIncAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval,dval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval );SYSTEM.GET(dadr,dval); dval := dval + lval * rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EMulIncAIAILoop; OPERATOR ".*+"*(CONST left,right: ARRAY [?] OF INTEGER): ARRAY [?] OF INTEGER; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), EMulIncAIAILoop ); END ".*+"; (** LONGINT *) PROCEDURE EMulIncALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval,dval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.GET(dadr,dval); SYSTEM.PUT( dadr, dval+ lval * rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EMulIncALALLoop; OPERATOR ".*+"*(CONST left,right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), EMulIncALALLoop ); END ".*+"; (** REAL *) PROCEDURE EMulIncARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval,dval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.GET(dadr,dval); SYSTEM.PUT( dadr, dval+ lval * rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EMulIncARARLoop; OPERATOR ".*+"*(CONST left,right: ARRAY [?] OF REAL): ARRAY [?] OF REAL; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), EMulIncARARLoop ); END ".*+"; (** LONGREAL *) PROCEDURE EMulIncAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval,dval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.GET(dadr,dval); SYSTEM.PUT( dadr,dval+ lval * rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EMulIncAXAXLoop; OPERATOR ".*+"*(CONST left,right: ARRAY [?] OF LONGREAL): ARRAY [?] OF LONGREAL; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), EMulIncAXAXLoop ); END ".*+"; (*** multiply array x scalar -> array and scalar + array -> array ********************************************************************) (** SHORTINT *) PROCEDURE MulASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval * rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END MulASSSLoop; OPERATOR "*"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF SHORTINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), MulASSSLoop ); RETURN RESULT END "*"; OPERATOR "*"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( SHORTINT ), MulASSSLoop ); RETURN RESULT END "*"; (** INTEGER *) PROCEDURE MulAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval * rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END MulAISILoop; OPERATOR "*"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF INTEGER; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), MulAISILoop ); RETURN RESULT END "*"; OPERATOR "*"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( INTEGER ), MulAISILoop ); RETURN RESULT END "*"; (** LONGINT *) PROCEDURE MulALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval * rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END MulALSLLoop; OPERATOR "*"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF LONGINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), MulALSLLoop ); RETURN RESULT END "*"; OPERATOR "*"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGINT ), MulALSLLoop ); RETURN RESULT END "*"; (** REAL *) PROCEDURE MulARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval * rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END MulARSRLoop; OPERATOR "*"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF REAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), loopMulARSR ); RETURN RESULT END "*"; OPERATOR "*"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF REAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ), loopMulARSR ); RETURN RESULT END "*"; (** LONGREAL *) PROCEDURE MulAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN IF debug THEN KernelLog.String( "MulAXSXLoop, ladr,radr,dadr,linc,dinc,len= " ); KernelLog.Int( ladr, 10 ); KernelLog.Int( radr, 10 ); KernelLog.Int( dadr, 10 ); KernelLog.Int( linc, 10 ); KernelLog.Int( dinc, 10 ); KernelLog.Int( len, 10 ); KernelLog.Ln; END; SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval * rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END MulAXSXLoop; OPERATOR "*"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF LONGREAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), loopMulAXSX ); RETURN RESULT END "*"; OPERATOR "*"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF LONGREAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGREAL ), loopMulAXSX ); RETURN RESULT END "*"; (** COMPLEX *) PROCEDURE MulAZSZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: COMPLEX; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval * rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END MulAZSZLoop; OPERATOR "*"*(CONST left: ARRAY [ ? ] OF COMPLEX; right: COMPLEX ): ARRAY [ ? ] OF COMPLEX; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( COMPLEX ), loopMulAZSZ ); RETURN RESULT END "*"; OPERATOR "*"*(left: COMPLEX; CONST right: ARRAY [ ? ] OF COMPLEX): ARRAY [ ? ] OF COMPLEX; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( COMPLEX ), loopMulAZSZ ); RETURN RESULT END "*"; (** LONGCOMPLEX *) PROCEDURE MulALZSLZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL; BEGIN SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm ); WHILE (len > 0) DO SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm ); SYSTEM.PUT( dadr, lvalRe * rvalRe - lvalIm*rvalIm ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), lvalRe * rvalIm + lvalIm*rvalRe ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END MulALZSLZLoop; OPERATOR "*"*(CONST left: ARRAY [ ? ] OF LONGCOMPLEX; right: LONGCOMPLEX ): ARRAY [ ? ] OF LONGCOMPLEX; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGCOMPLEX ), loopMulALZSLZ ); RETURN RESULT END "*"; OPERATOR "*"*(left: LONGCOMPLEX; CONST right: ARRAY [ ? ] OF LONGCOMPLEX): ARRAY [ ? ] OF LONGCOMPLEX; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGCOMPLEX ), loopMulALZSLZ ); RETURN RESULT END "*"; (*** multiply and add array * scalar -> array and scalar * array -> array ********************************************************************) (** SHORTINT *) PROCEDURE IncMulASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval, dval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( dadr, dval ); SYSTEM.PUT( dadr, dval + lval * rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END IncMulASSSLoop; OPERATOR "IncMul"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF SHORTINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), IncMulASSSLoop ); END "IncMul"; OPERATOR "IncMul"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( SHORTINT ), IncMulASSSLoop ); RETURN RESULT END "IncMul"; OPERATOR "DecMul"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF SHORTINT; BEGIN RESULT := -RESULT; ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), IncMulASSSLoop ); RESULT := -RESULT; RETURN RESULT END "DecMul"; OPERATOR "DecMul"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT; BEGIN RESULT := -RESULT; ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( SHORTINT ), IncMulASSSLoop ); RESULT := -RESULT; RETURN RESULT END "DecMul"; (** INTEGER *) PROCEDURE IncMulAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval, dval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( dadr, dval ); SYSTEM.PUT( dadr, dval + lval * rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END IncMulAISILoop; OPERATOR "IncMul"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF INTEGER; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), IncMulAISILoop ); RETURN RESULT END "IncMul"; OPERATOR "IncMul"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( INTEGER ), IncMulAISILoop ); RETURN RESULT END "IncMul"; OPERATOR "DecMul"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF INTEGER; BEGIN RESULT := -RESULT; ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), IncMulAISILoop ); RESULT := -RESULT; RETURN RESULT END "DecMul"; OPERATOR "DecMul"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER; BEGIN RESULT := -RESULT; ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( INTEGER ), IncMulAISILoop ); RESULT := -RESULT; RETURN RESULT END "DecMul"; (** LONGINT *) PROCEDURE IncMulALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval, dval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( dadr, dval ); SYSTEM.PUT( dadr, dval + lval * rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END IncMulALSLLoop; OPERATOR "IncMul"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF LONGINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), IncMulALSLLoop ); RETURN RESULT END "IncMul"; OPERATOR "IncMul"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGINT ), IncMulALSLLoop ); RETURN RESULT END "IncMul"; OPERATOR "DecMul"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF LONGINT; BEGIN RESULT := -RESULT; ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), IncMulALSLLoop ); RESULT := -RESULT; RETURN RESULT END "DecMul"; OPERATOR "DecMul"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT; BEGIN RESULT := -RESULT; ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGINT ), IncMulALSLLoop ); RESULT := -RESULT; RETURN RESULT END "DecMul"; (** REAL *) PROCEDURE IncMulARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval, dval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( dadr, dval ); SYSTEM.PUT( dadr, dval + lval * rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END IncMulARSRLoop; OPERATOR "IncMul"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF REAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), loopIncMulARSR ); RETURN RESULT END "IncMul"; OPERATOR "IncMul"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF REAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ), loopIncMulARSR ); RETURN RESULT END "IncMul"; OPERATOR "DecMul"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF REAL; BEGIN RESULT := -RESULT; ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), loopIncMulARSR ); RESULT := -RESULT; RETURN RESULT END "DecMul"; OPERATOR "DecMul"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF REAL; BEGIN RESULT := -RESULT; ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ), loopIncMulARSR ); RESULT := -RESULT; RETURN RESULT END "DecMul"; (** LONGREAL *) PROCEDURE IncMulAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval, dval: LONGREAL; BEGIN IF debug THEN KernelLog.String( "IncMulAXSXLoop, ladr,radr,dadr,linc,dinc,len= " ); KernelLog.Int( ladr, 10 ); KernelLog.Int( radr, 10 ); KernelLog.Int( dadr, 10 ); KernelLog.Int( linc, 10 ); KernelLog.Int( dinc, 10 ); KernelLog.Int( len, 10 ); KernelLog.Ln; END; SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( dadr, dval ); SYSTEM.PUT( dadr, dval + lval * rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END IncMulAXSXLoop; OPERATOR "IncMul"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF LONGREAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), loopIncMulAXSX ); RETURN RESULT END "IncMul"; OPERATOR "IncMul"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF LONGREAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGREAL ), loopIncMulAXSX ); RETURN RESULT END "IncMul"; OPERATOR "DecMul"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF LONGREAL; BEGIN RESULT := -RESULT; ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), loopIncMulAXSX ); RESULT := -RESULT; RETURN RESULT END "DecMul"; OPERATOR "DecMul"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF LONGREAL; BEGIN RESULT := -RESULT; ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGREAL ), loopIncMulAXSX ); RESULT := -RESULT; RETURN RESULT END "DecMul"; (*** element-wise division array / array -> array ********************************************************************) (** SHORTINT *) PROCEDURE EDivideASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; dval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EDivideASASLoop; OPERATOR "./"*(CONST left,right: ARRAY [?] OF SHORTINT): ARRAY [?] OF REAL; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), EDivideASASLoop ); RETURN RESULT END "./"; (** INTEGER *) PROCEDURE EDivideAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: INTEGER; dval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EDivideAIAILoop; OPERATOR "./"*(CONST left,right: ARRAY [?] OF INTEGER): ARRAY [?] OF REAL; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), EDivideAIAILoop ); RETURN RESULT END "./"; (** LONGINT *) PROCEDURE EDivideALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGINT; dval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EDivideALALLoop; OPERATOR "./"*(CONST left,right: ARRAY [?] OF LONGINT): ARRAY [?] OF REAL; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), EDivideALALLoop ); RETURN RESULT END "./"; (** REAL *) PROCEDURE EDivideARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: REAL; dval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EDivideARARLoop; OPERATOR "./"*(CONST left,right: ARRAY [?] OF REAL): ARRAY [?] OF REAL; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), EDivideARARLoop ); RETURN RESULT END "./"; (** LONGREAL *) PROCEDURE EDivideAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; dval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EDivideAXAXLoop; OPERATOR "./"*(CONST left,right: ARRAY [?] OF LONGREAL): ARRAY [?] OF LONGREAL; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), EDivideAXAXLoop ); RETURN RESULT END "./"; (** COMPLEX *) PROCEDURE EDivideAZAZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: COMPLEX; dval: COMPLEX; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EDivideAZAZLoop; OPERATOR "./"*(CONST left,right: ARRAY [?] OF COMPLEX): ARRAY [?] OF COMPLEX; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( COMPLEX ), EDivideAZAZLoop ); RETURN RESULT END "./"; (** LONGCOMPLEX *) PROCEDURE EDivideALZALZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL; dvalRe, dvalIm: LONGREAL; v: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm ); SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm ); IF rvalIm # 0.0D0 THEN v := 1.0D0/(rvalRe*rvalRe + rvalIm*rvalIm); dvalRe := v*(lvalRe*rvalRe+lvalIm*rvalIm); dvalIm := v*(lvalIm*rvalRe-lvalRe*rvalIm); ELSE dvalRe := lvalRe/rvalRe; dvalIm := lvalIm/rvalRe; END; SYSTEM.PUT( dadr, dvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), dvalIm ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EDivideALZALZLoop; OPERATOR "./"*(CONST left,right: ARRAY [?] OF LONGCOMPLEX): ARRAY [?] OF LONGCOMPLEX; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGCOMPLEX ), EDivideALZALZLoop ); RETURN RESULT END "./"; (*** division array / scalar -> array and scalar / array -> array ********************************************************************) (** SHORTINT *) PROCEDURE DivideASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; dval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivideASSSLoop; OPERATOR "/"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF REAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), DivideASSSLoop ); RETURN RESULT END "/"; PROCEDURE DivideSSASLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; dval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval / lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivideSSASLoop; OPERATOR "/"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF REAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ), DivideSSASLoop ); RETURN RESULT END "/"; (** INTEGER *) PROCEDURE DivideAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: INTEGER; dval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivideAISILoop; OPERATOR "/"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF REAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), DivideAISILoop ); RETURN RESULT END "/"; PROCEDURE DivideSIAILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: INTEGER; dval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval / lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivideSIAILoop; OPERATOR "/"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF REAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ), DivideSIAILoop ); RETURN RESULT END "/"; (** LONGINT *) PROCEDURE DivideALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGINT; dval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivideALSLLoop; OPERATOR "/"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF REAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), DivideALSLLoop ); RETURN RESULT END "/"; PROCEDURE DivideSLALLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGINT; dval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval / lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivideSLALLoop; OPERATOR "/"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF REAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ), DivideSLALLoop ); RETURN RESULT END "/"; (** REAL *) PROCEDURE DivideARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: REAL; dval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivideARSRLoop; OPERATOR "/"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF REAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), DivideARSRLoop ); RETURN RESULT END "/"; PROCEDURE DivideSRARLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: REAL; dval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval / lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivideSRARLoop; OPERATOR "/"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF REAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( REAL ), DivideSRARLoop ); RETURN RESULT END "/"; (** LONGREAL *) PROCEDURE DivideAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; dval: LONGREAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivideAXSXLoop; OPERATOR "/"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF LONGREAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), DivideAXSXLoop ); RETURN RESULT END "/"; PROCEDURE DivideSXAXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; dval: LONGREAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval / lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivideSXAXLoop; OPERATOR "/"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF LONGREAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGREAL ), DivideSXAXLoop ); RETURN RESULT END "/"; (** COMPLEX *) PROCEDURE DivideAZSZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: COMPLEX; dval: COMPLEX; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval / rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivideAZSZLoop; OPERATOR "/"*(CONST left: ARRAY [ ? ] OF COMPLEX; right: COMPLEX ): ARRAY [ ? ] OF COMPLEX; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( COMPLEX ), DivideAZSZLoop ); RETURN RESULT END "/"; PROCEDURE DivideSZAZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: COMPLEX; dval: COMPLEX; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval / lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivideSZAZLoop; OPERATOR "/"*(left: COMPLEX; CONST right: ARRAY [ ? ] OF COMPLEX): ARRAY [ ? ] OF COMPLEX; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( COMPLEX ), DivideSZAZLoop ); RETURN RESULT END "/"; (** LONGCOMPLEX *) PROCEDURE DivideALZSLZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL; dvalRe, dvalIm: LONGREAL; v: LONGREAL; BEGIN SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm ); IF rvalIm # 0.0D0 THEN v := 1.0D0/(rvalRe*rvalRe + rvalIm*rvalIm); WHILE (len > 0) DO SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm ); dvalRe := v*(lvalRe*rvalRe+lvalIm*rvalIm); dvalIm := v*(lvalIm*rvalRe-lvalRe*rvalIm); SYSTEM.PUT( dadr, dvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), dvalIm ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; ELSE WHILE (len > 0) DO SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm ); dvalRe := lvalRe / rvalRe; dvalIm := lvalIm / rvalRe; SYSTEM.PUT( dadr, dvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), dvalIm ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END; END DivideALZSLZLoop; OPERATOR "/"*(CONST left: ARRAY [ ? ] OF LONGCOMPLEX; right: LONGCOMPLEX ): ARRAY [ ? ] OF LONGCOMPLEX; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGCOMPLEX ), DivideALZSLZLoop ); RETURN RESULT END "/"; PROCEDURE DivideSLZALZLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL; dvalRe, dvalIm: LONGREAL; v: LONGREAL; BEGIN SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm ); WHILE (len > 0) DO SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm ); v := 1.0D0/(lvalRe*lvalRe + lvalIm*lvalIm); dvalRe := v*(rvalRe*lvalRe+rvalIm*lvalIm); dvalIm := v*(rvalIm*lvalRe-rvalRe*lvalIm); SYSTEM.PUT( dadr, dvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), dvalIm ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivideSLZALZLoop; OPERATOR "/"*(left: LONGCOMPLEX; CONST right: ARRAY [ ? ] OF LONGCOMPLEX): ARRAY [ ? ] OF LONGCOMPLEX; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGCOMPLEX ), DivideSLZALZLoop ); RETURN RESULT END "/"; (*** element-wise DIV array DIV array -> array ********************************************************************) (** SHORTINT *) PROCEDURE EDivASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; dval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval DIV rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EDivASASLoop; OPERATOR "DIV"*(CONST left,right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), EDivASASLoop ); RETURN RESULT END "DIV"; (** INTEGER *) PROCEDURE EDivAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: INTEGER; dval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval DIV rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EDivAIAILoop; OPERATOR "DIV"*(CONST left,right: ARRAY [?] OF INTEGER): ARRAY [?] OF INTEGER; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), EDivAIAILoop ); RETURN RESULT END "DIV"; (** LONGINT *) PROCEDURE EDivALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGINT; dval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval DIV rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EDivALALLoop; OPERATOR "DIV"*(CONST left,right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), EDivALALLoop ); RETURN RESULT END "DIV"; (*** division array DIV scalar -> array and scalar DIV array -> array ********************************************************************) (** SHORTINT *) PROCEDURE DivASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; dval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval DIV rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivASSSLoop; OPERATOR "DIV"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF SHORTINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), DivASSSLoop ); RETURN RESULT END "DIV"; PROCEDURE DivSSASLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; dval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval DIV lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivSSASLoop; OPERATOR "DIV"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( SHORTINT ), DivSSASLoop ); RETURN RESULT END "DIV"; (** INTEGER *) PROCEDURE DivAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: INTEGER; dval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval DIV rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivAISILoop; OPERATOR "DIV"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF INTEGER; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), DivAISILoop ); RETURN RESULT END "DIV"; PROCEDURE DivSIAILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: INTEGER; dval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval DIV lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivSIAILoop; OPERATOR "DIV"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( INTEGER ), DivSIAILoop ); RETURN RESULT END "DIV"; (** LONGINT *) PROCEDURE DivALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGINT; dval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval DIV rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivALSLLoop; OPERATOR "DIV"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF LONGINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), DivALSLLoop ); RETURN RESULT END "DIV"; PROCEDURE DivSLALLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGINT; dval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval DIV lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END DivSLALLoop; OPERATOR "DIV"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGINT ), DivSLALLoop ); RETURN RESULT END "DIV"; (*** element-wise modulus array MOD array -> array ********************************************************************) (** SHORTINT *) PROCEDURE EModASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; dval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval MOD rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EModASASLoop; OPERATOR "MOD"*(CONST left,right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), EModASASLoop ); RETURN RESULT END "MOD"; (** INTEGER *) PROCEDURE EModAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: INTEGER; dval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval MOD rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EModAIAILoop; OPERATOR "MOD"*(CONST left,right: ARRAY [?] OF INTEGER): ARRAY [?] OF INTEGER; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), EModAIAILoop ); RETURN RESULT END "MOD"; (** LONGINT *) PROCEDURE EModALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGINT; dval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := lval MOD rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EModALALLoop; OPERATOR "MOD"*(CONST left,right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), EModALALLoop ); RETURN RESULT END "MOD"; (*** modulus array MOD scalar -> array and scalar MOD array -> array ********************************************************************) (** SHORTINT *) PROCEDURE ModASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; dval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval MOD rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ModASSSLoop; OPERATOR "MOD"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF SHORTINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), ModASSSLoop ); RETURN RESULT END "MOD"; PROCEDURE ModSSASLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; dval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval MOD lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ModSSASLoop; OPERATOR "MOD"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( SHORTINT ), ModSSASLoop ); RETURN RESULT END "MOD"; (** INTEGER *) PROCEDURE ModAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: INTEGER; dval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval MOD rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ModAISILoop; OPERATOR "MOD"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF INTEGER; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), ModAISILoop ); RETURN RESULT END "MOD"; PROCEDURE ModSIAILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: INTEGER; dval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval MOD lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ModSIAILoop; OPERATOR "MOD"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( INTEGER ), ModSIAILoop ); RETURN RESULT END "MOD"; (** LONGINT *) PROCEDURE ModALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGINT; dval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := lval MOD rval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ModALSLLoop; OPERATOR "MOD"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF LONGINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), ModALSLLoop ); RETURN RESULT END "MOD"; PROCEDURE ModSLALLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGINT; dval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := rval MOD lval; SYSTEM.PUT( dadr, dval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ModSLALLoop; OPERATOR "MOD"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( LONGINT ), ModSLALLoop ); RETURN RESULT END "MOD"; (*** scalar product -> scalar ********************************************************************) (** SHORTINT *) PROCEDURE SPASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); VAR lval, rval: SHORTINT; dval: LONGINT; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + rval * lval; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END SPASASLoop; OPERATOR "+*"*( CONST left, right: ARRAY [ ? ] OF SHORTINT ): LONGINT; VAR dest: LONGINT; BEGIN dest := 0; ApplyBinaryAASOp( ADDRESSOF( dest ), ADDRESSOF( left ), ADDRESSOF( right ), SPASASLoop ); RETURN dest; END "+*"; (** INTEGER *) PROCEDURE SPAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); VAR lval, rval: INTEGER; dval: LONGINT; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + rval * lval; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END SPAIAILoop; OPERATOR "+*"*( CONST left, right: ARRAY [ ? ] OF INTEGER ): LONGINT; VAR dest: LONGINT; BEGIN dest := 0; ApplyBinaryAASOp( ADDRESSOF( dest ), ADDRESSOF( left ), ADDRESSOF( right ), SPAIAILoop ); RETURN dest; END "+*"; (** LONGINT *) PROCEDURE SPALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); VAR lval, rval: LONGINT; dval: LONGINT; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + rval * lval; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END SPALALLoop; OPERATOR "+*"*( CONST left, right: ARRAY [ ? ] OF LONGINT ): LONGINT; VAR dest: LONGINT; BEGIN dest := 0; ApplyBinaryAASOp( ADDRESSOF( dest ), ADDRESSOF( left ), ADDRESSOF( right ), SPALALLoop ); RETURN dest; END "+*"; (** REAL *) PROCEDURE SPARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); VAR lval, rval: REAL; dval: REAL; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + rval * lval; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END SPARARLoop; OPERATOR "+*"*( CONST left, right: ARRAY [ ? ] OF REAL ): REAL; VAR dest: REAL; BEGIN dest := 0; ApplyBinaryAASOp( ADDRESSOF( dest ), ADDRESSOF( left ), ADDRESSOF( right ), loopSPARAR ); RETURN dest; END "+*"; PROCEDURE SPAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); VAR lval, rval, dval: LONGREAL; BEGIN IF debug THEN KernelLog.String( "SPAXAX, ladr,radr,dadr,linc,rinc,len= " ); KernelLog.Int( ladr, 10 ); KernelLog.Int( radr, 10 ); KernelLog.Int( dadr, 10 ); KernelLog.Int( linc, 10 ); KernelLog.Int( rinc, 10 ); KernelLog.Int( len, 10 ); KernelLog.Ln; END; SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); INC( ladr, linc ); SYSTEM.GET( radr, rval ); INC( radr, rinc ); dval := dval + rval * lval; DEC( len ); END; SYSTEM.PUT( dadr, dval ); END SPAXAXLoop; OPERATOR "+*"*( CONST left, right: ARRAY [ ? ] OF LONGREAL ): LONGREAL; VAR dest: LONGREAL; BEGIN dest := 0; ApplyBinaryAASOp( ADDRESSOF( dest ), ADDRESSOF( left ), ADDRESSOF( right ), loopSPAXAX ); RETURN dest; END "+*"; (** COMPLEX *) PROCEDURE SPAZAZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); VAR lval, rval: COMPLEX; dval: COMPLEX; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); RE(dval) := RE(dval) + RE(lval) * RE(rval) + IM(lval) * IM(rval); IM(dval) := IM(dval) - RE(lval) * IM(rval) + IM(lval) * RE(rval); INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END SPAZAZLoop; OPERATOR "+*"*( CONST left, right: ARRAY [ ? ] OF COMPLEX ): COMPLEX; VAR dest: COMPLEX; BEGIN dest := 0; ApplyBinaryAASOp( ADDRESSOF( dest ), ADDRESSOF( left ), ADDRESSOF( right ), loopSPAZAZ ); RETURN dest; END "+*"; (** COMPLEX *) PROCEDURE SPALZALZLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL; dvalRe, dvalIm: LONGREAL; BEGIN SYSTEM.GET( dadr, dvalRe ); SYSTEM.GET( dadr+SIZEOF(LONGREAL), dvalIm ); WHILE (len > 0) DO SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm ); SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm ); dvalRe := dvalRe + lvalRe * rvalRe + lvalIm * rvalIm; dvalIm := dvalIm - lvalRe * rvalIm + lvalIm * rvalRe; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; SYSTEM.PUT( dadr, dvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), dvalIm ); END SPALZALZLoop; OPERATOR "+*"*( CONST left, right: ARRAY [ ? ] OF LONGCOMPLEX ): LONGCOMPLEX; VAR dest: LONGCOMPLEX; BEGIN dest := 0; ApplyBinaryAASOp( ADDRESSOF( dest ), ADDRESSOF( left ), ADDRESSOF( right ), loopSPALZALZ ); RETURN dest; END "+*"; (*** element-wise equal: array x array -> array of boolean ********************************************************************) (** BOOLEAN *) PROCEDURE EEqlABABLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: BOOLEAN; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EEqlABABLoop; OPERATOR ".="*(CONST left,right : ARRAY [?] OF BOOLEAN):ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EEqlABABLoop ); RETURN RESULT END ".="; (** SHORTINT *) PROCEDURE EEqlASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EEqlASASLoop; OPERATOR ".="*(CONST left, right: ARRAY [ ? ] OF SHORTINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EEqlASASLoop ); RETURN RESULT END ".="; (** INTEGER *) PROCEDURE EEqlAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EEqlAIAILoop; OPERATOR ".="*(CONST left, right: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EEqlAIAILoop ); RETURN RESULT END ".="; (** LONGINT *) PROCEDURE EEqlALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EEqlALALLoop; OPERATOR ".="*(CONST left, right: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EEqlALALLoop ); RETURN RESULT END ".="; (** REAL *) PROCEDURE EEqlARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EEqlARARLoop; OPERATOR ".="*(CONST left, right: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EEqlARARLoop ); RETURN RESULT END ".="; (** LONGREAL *) PROCEDURE EEqlAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EEqlAXAXLoop; OPERATOR ".="*(CONST left, right: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EEqlAXAXLoop ); RETURN RESULT END ".="; (*** elementwise equal array x scalar -> array of boolean ********************************************************************) (** BOOLEAN *) PROCEDURE EEqlABSBLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: BOOLEAN; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END EEqlABSBLoop; OPERATOR ".="*(CONST left : ARRAY [?] OF BOOLEAN; right: BOOLEAN):ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EEqlABSBLoop ); RETURN RESULT END ".="; OPERATOR ".="*(left: BOOLEAN; CONST right : ARRAY [?] OF BOOLEAN):ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), EEqlABSBLoop ); RETURN RESULT END ".="; (** SHORTINT *) PROCEDURE EEqlASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END EEqlASSSLoop; OPERATOR ".="*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EEqlASSSLoop ); RETURN RESULT END ".="; OPERATOR ".="*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), EEqlASSSLoop ); RETURN RESULT END ".="; (** INTEGER *) PROCEDURE EEqlAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END EEqlAISILoop; OPERATOR ".="*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EEqlAISILoop ); RETURN RESULT END ".="; OPERATOR ".="*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), EEqlAISILoop ); RETURN RESULT END ".="; (** LONGINT *) PROCEDURE EEqlALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END EEqlALSLLoop; OPERATOR ".="*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EEqlALSLLoop ); RETURN RESULT END ".="; OPERATOR ".="*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), EEqlALSLLoop ); RETURN RESULT END ".="; (** REAL *) PROCEDURE EEqlARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END EEqlARSRLoop; OPERATOR ".="*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EEqlARSRLoop ); RETURN RESULT END ".="; OPERATOR ".="*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), EEqlARSRLoop ); RETURN RESULT END ".="; (** LONGREAL *) PROCEDURE EEqlAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval = rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END EEqlAXSXLoop; OPERATOR ".="*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EEqlAXSXLoop ); RETURN RESULT END ".="; OPERATOR ".="*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), EEqlAXSXLoop ); RETURN RESULT END ".="; (*** elementwise nequal: array x array -> array of boolean ********************************************************************) (** BOOLEAN *) PROCEDURE ENeqABABLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: BOOLEAN; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ENeqABABLoop; OPERATOR ".#"*(CONST left,right : ARRAY [?] OF BOOLEAN):ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ENeqABABLoop ); RETURN RESULT END ".#"; (** SHORTINT *) PROCEDURE ENeqASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ENeqASASLoop; OPERATOR ".#"*(CONST left, right: ARRAY [ ? ] OF SHORTINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ENeqASASLoop ); RETURN RESULT END ".#"; (** INTEGER*) PROCEDURE ENeqAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ENeqAIAILoop; OPERATOR ".#"*(CONST left, right: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ENeqAIAILoop ); RETURN RESULT END ".#"; (** LONGINT*) PROCEDURE ENeqALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ENeqALALLoop; OPERATOR ".#"*(CONST left, right: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ENeqALALLoop ); RETURN RESULT END ".#"; (** REAL *) PROCEDURE ENeqARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ENeqARARLoop; OPERATOR ".#"*(CONST left, right: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ENeqARARLoop ); RETURN RESULT END ".#"; (** LONGREAL *) PROCEDURE ENeqAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ENeqAXAXLoop; OPERATOR ".#"*(CONST left, right: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ENeqAXAXLoop ); RETURN RESULT END ".#"; (*** elementwise nequal array x scalar -> array of boolean ********************************************************************) (** BOOLEAN *) PROCEDURE ENeqABSBLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: BOOLEAN; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ENeqABSBLoop; OPERATOR ".#"*(CONST left : ARRAY [?] OF BOOLEAN; right: BOOLEAN):ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ENeqABSBLoop ); RETURN RESULT END ".#"; OPERATOR ".#"*(left: BOOLEAN; CONST right : ARRAY [?] OF BOOLEAN):ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ENeqABSBLoop ); RETURN RESULT END ".#"; (** SHORTINT *) PROCEDURE ENeqASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ENeqASSSLoop; OPERATOR ".#"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ENeqASSSLoop ); RETURN RESULT END ".#"; OPERATOR ".#"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ENeqASSSLoop ); RETURN RESULT END ".#"; (** INTEGER *) PROCEDURE ENeqAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ENeqAISILoop; OPERATOR ".#"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ENeqAISILoop ); RETURN RESULT END ".#"; OPERATOR ".#"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ENeqAISILoop ); RETURN RESULT END ".#"; (** LONGINT *) PROCEDURE ENeqALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ENeqALSLLoop; OPERATOR ".#"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ENeqALSLLoop ); RETURN RESULT END ".#"; OPERATOR ".#"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ENeqALSLLoop ); RETURN RESULT END ".#"; (** REAL *) PROCEDURE ENeqARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ENeqARSRLoop; OPERATOR ".#"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ENeqARSRLoop ); RETURN RESULT END ".#"; OPERATOR ".#"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ENeqARSRLoop ); RETURN RESULT END ".#"; (** LONGREAL *) PROCEDURE ENeqAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval # rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ENeqAXSXLoop; OPERATOR ".#"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ENeqAXSXLoop ); RETURN RESULT END ".#"; OPERATOR ".#"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ENeqAXSXLoop ); RETURN RESULT END ".#"; (*** elementwise greater than: array x array -> array of boolean ********************************************************************) (** SHORTINT *) PROCEDURE EGtrASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval > rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EGtrASASLoop; OPERATOR ".>"*(CONST left, right: ARRAY [ ? ] OF SHORTINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGtrASASLoop ); RETURN RESULT END ".>"; (** INTEGER *) PROCEDURE EGtrAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval > rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EGtrAIAILoop; OPERATOR ".>"*(CONST left, right: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGtrAIAILoop ); RETURN RESULT END ".>"; (** LONGINT *) PROCEDURE EGtrALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval > rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EGtrALALLoop; OPERATOR ".>"*(CONST left, right: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGtrALALLoop ); RETURN RESULT END ".>"; (** REAL *) PROCEDURE EGtrARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval > rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EGtrARARLoop; OPERATOR ".>"*(CONST left, right: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGtrARARLoop ); RETURN RESULT END ".>"; (** LONGREAL *) PROCEDURE EGtrAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval > rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EGtrAXAXLoop; OPERATOR ".>"*(CONST left, right: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGtrAXAXLoop ); RETURN RESULT END ".>"; (*** elementwise greater array x scalar -> array of boolean ********************************************************************) (** SHORTINT *) PROCEDURE EGtrASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval > rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END EGtrASSSLoop; OPERATOR ".>"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGtrASSSLoop ); RETURN RESULT END ".>"; OPERATOR ".<"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), EGtrASSSLoop ); RETURN RESULT END ".<"; (** INTEGER *) PROCEDURE EGtrAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval > rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END EGtrAISILoop; OPERATOR ".>"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGtrAISILoop ); RETURN RESULT END ".>"; OPERATOR ".<"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), EGtrAISILoop ); RETURN RESULT END ".<"; (** LONGINT *) PROCEDURE EGtrALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval > rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END EGtrALSLLoop; OPERATOR ".>"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGtrALSLLoop ); RETURN RESULT END ".>"; OPERATOR ".<"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), EGtrALSLLoop ); RETURN RESULT END ".<"; (** REAL *) PROCEDURE EGtrARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval > rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END EGtrARSRLoop; OPERATOR ".>"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGtrARSRLoop ); RETURN RESULT END ".>"; OPERATOR ".<"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), EGtrARSRLoop ); RETURN RESULT END ".<"; (** LONGREAL *) PROCEDURE EGtrAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval > rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END EGtrAXSXLoop; OPERATOR ".>"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGtrAXSXLoop ); RETURN RESULT END ".>"; OPERATOR ".<"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), EGtrAXSXLoop ); RETURN RESULT END ".<"; (*** elementwise greater or equal: array x array -> array of boolean ********************************************************************) (** SHORTINT *) PROCEDURE EGeqASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval >= rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EGeqASASLoop; OPERATOR ".>="*(CONST left, right: ARRAY [ ? ] OF SHORTINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGeqASASLoop ); RETURN RESULT END ".>="; (** INTEGER *) PROCEDURE EGeqAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval >= rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EGeqAIAILoop; OPERATOR ".>="*(CONST left, right: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGeqAIAILoop ); RETURN RESULT END ".>="; (** LONGINT *) PROCEDURE EGeqALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval >= rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EGeqALALLoop; OPERATOR ".>="*(CONST left, right: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGeqALALLoop ); RETURN RESULT END ".>="; (** REAL *) PROCEDURE EGeqARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval >= rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EGeqARARLoop; OPERATOR ".>="*(CONST left, right: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGeqARARLoop ); RETURN RESULT END ".>="; (** LONGREAL *) PROCEDURE EGeqAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval >= rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END EGeqAXAXLoop; OPERATOR ".>="*(CONST left, right: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGeqAXAXLoop ); RETURN RESULT END ".>="; (*** elementwise geq array x scalar -> array of boolean ********************************************************************) (** SHORTINT *) PROCEDURE EGeqASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval >= rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END EGeqASSSLoop; OPERATOR ".>="*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGeqASSSLoop ); RETURN RESULT END ".>="; OPERATOR ".<="*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), EGeqASSSLoop ); RETURN RESULT END ".<="; (** INTEGER *) PROCEDURE EGeqAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval >= rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END EGeqAISILoop; OPERATOR ".>="*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGeqAISILoop ); RETURN RESULT END ".>="; OPERATOR ".<="*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), EGeqAISILoop ); RETURN RESULT END ".<="; (** LONGINT *) PROCEDURE EGeqALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval >= rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END EGeqALSLLoop; OPERATOR ".>="*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGeqALSLLoop ); RETURN RESULT END ".>="; OPERATOR ".<="*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), EGeqALSLLoop ); RETURN RESULT END ".<="; (** REAL *) PROCEDURE EGeqARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval >= rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END EGeqARSRLoop; OPERATOR ".>="*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGeqARSRLoop ); RETURN RESULT END ".>="; OPERATOR ".<="*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), EGeqARSRLoop ); RETURN RESULT END ".<="; (** LONGREAL *) PROCEDURE EGeqAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval >= rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END EGeqAXSXLoop; OPERATOR ".>="*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), EGeqAXSXLoop ); RETURN RESULT END ".>="; OPERATOR ".<="*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), EGeqAXSXLoop ); RETURN RESULT END ".<="; (*** elementwise less than: array x array -> array of boolean ********************************************************************) (** SHORTINT *) PROCEDURE ELssASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval < rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ELssASASLoop; OPERATOR ".<"*(CONST left, right: ARRAY [ ? ] OF SHORTINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELssASASLoop ); RETURN RESULT END ".<"; (** INTEGER *) PROCEDURE ELssAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval < rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ELssAIAILoop; OPERATOR ".<"*(CONST left, right: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELssAIAILoop ); RETURN RESULT END ".<"; (** LONGINT*) PROCEDURE ELssALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval < rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ELssALALLoop; OPERATOR ".<"*(CONST left, right: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELssALALLoop ); RETURN RESULT END ".<"; (** REAL *) PROCEDURE ELssARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval < rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ELssARARLoop; OPERATOR ".<"*(CONST left, right: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELssARARLoop ); RETURN RESULT END ".<"; (** LONGREAL *) PROCEDURE ELssAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval < rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ELssAXAXLoop; OPERATOR ".<"*(CONST left, right: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELssAXAXLoop ); RETURN RESULT END ".<"; (*** elementwise less array x scalar -> array of boolean ********************************************************************) (** SHORTINT *) PROCEDURE ELssASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval < rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ELssASSSLoop; OPERATOR ".<"*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELssASSSLoop ); RETURN RESULT END ".<"; OPERATOR ".>"*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ELssASSSLoop ); RETURN RESULT END ".>"; (** INTEGER *) PROCEDURE ELssAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval < rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ELssAISILoop; OPERATOR ".<"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELssAISILoop ); RETURN RESULT END ".<"; OPERATOR ".>"*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ELssAISILoop ); RETURN RESULT END ".>"; (** LONGINT *) PROCEDURE ELssALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval < rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ELssALSLLoop; OPERATOR ".<"*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELssALSLLoop ); RETURN RESULT END ".<"; OPERATOR ".>"*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ELssALSLLoop ); RETURN RESULT END ".>"; (** REAL *) PROCEDURE ELssARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval < rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ELssARSRLoop; OPERATOR ".<"*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELssARSRLoop ); RETURN RESULT END ".<"; OPERATOR ".>"*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ELssARSRLoop ); RETURN RESULT END ".>"; (** LONGREAL *) PROCEDURE ELssAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval < rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ELssAXSXLoop; OPERATOR ".<"*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELssAXSXLoop ); RETURN RESULT END ".<"; OPERATOR ".>"*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ELssAXSXLoop ); RETURN RESULT END ".>"; (*** elementwise less or equal: array x array -> array of boolean ********************************************************************) (** SHORTINT *) PROCEDURE ELeqASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval <= rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ELeqASASLoop; OPERATOR ".<="*(CONST left, right: ARRAY [ ? ] OF SHORTINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELeqASASLoop ); RETURN RESULT END ".<="; (** INTEGER *) PROCEDURE ELeqAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval <= rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ELeqAIAILoop; OPERATOR ".<="*(CONST left, right: ARRAY [ ? ] OF INTEGER ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELeqAIAILoop ); RETURN RESULT END ".<="; (** LONGINT *) PROCEDURE ELeqALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval <= rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ELeqALALLoop; OPERATOR ".<="*(CONST left, right: ARRAY [ ? ] OF LONGINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELeqALALLoop ); RETURN RESULT END ".<="; (** REAL *) PROCEDURE ELeqARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval <= rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ELeqARARLoop; OPERATOR ".<="*(CONST left, right: ARRAY [ ? ] OF REAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELeqARARLoop ); RETURN RESULT END ".<="; (** LONGREAL*) PROCEDURE ELeqAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval <= rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ELeqAXAXLoop; OPERATOR ".<="*(CONST left, right: ARRAY [ ? ] OF LONGREAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELeqAXAXLoop ); RETURN RESULT END ".<="; (*** elementwise leq array x scalar -> array of boolean ********************************************************************) (** SHORTINT *) PROCEDURE ELeqASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval <= rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ELeqASSSLoop; OPERATOR ".<="*(CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELeqASSSLoop ); RETURN RESULT END ".<="; OPERATOR ".>="*(left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ELeqASSSLoop ); RETURN RESULT END ".>="; (** INTEGER *) PROCEDURE ELeqAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval <= rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ELeqAISILoop; OPERATOR ".<="*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELeqAISILoop ); RETURN RESULT END ".<="; OPERATOR ".>="*(left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ELeqAISILoop ); RETURN RESULT END ".>="; (** LONGINT *) PROCEDURE ELeqALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval <= rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ELeqALSLLoop; OPERATOR ".<="*(CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELeqALSLLoop ); RETURN RESULT END ".<="; OPERATOR ".>="*(left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ELeqALSLLoop ); RETURN RESULT END ".>="; (** REAL *) PROCEDURE ELeqARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval <= rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ELeqARSRLoop; OPERATOR ".<="*(CONST left: ARRAY [ ? ] OF REAL; right: REAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELeqARSRLoop ); RETURN RESULT END ".<="; OPERATOR ".>="*(left: REAL; CONST right: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ELeqARSRLoop ); RETURN RESULT END ".>="; (** LONGREAL *) PROCEDURE ELeqAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval <= rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ELeqAXSXLoop; OPERATOR ".<="*(CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ELeqAXSXLoop ); RETURN RESULT END ".<="; OPERATOR ".>="*(left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ELeqAXSXLoop ); RETURN RESULT END ".>="; (*** elementwise or, elementwise and ********************************************************************) (** array x array *) PROCEDURE ElOrABABLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: BOOLEAN; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, (lval OR rval) ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ElOrABABLoop; OPERATOR "OR"*(CONST left,right : ARRAY [?] OF BOOLEAN):ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ElOrABABLoop ); RETURN RESULT END "OR"; PROCEDURE ElAndABABLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len:SIZE ); VAR lval, rval: BOOLEAN; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); SYSTEM.PUT( dadr, lval & rval ); INC( ladr, linc ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; END ElAndABABLoop; OPERATOR "&"*(CONST left,right : ARRAY [?] OF BOOLEAN):ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ElAndABABLoop ); RETURN RESULT END "&"; (** array x boolean *) PROCEDURE ElOrABSBLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: BOOLEAN; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval OR rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ElOrABSBLoop; OPERATOR "OR"*(CONST left : ARRAY [?] OF BOOLEAN; right: BOOLEAN):ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ElOrABSBLoop ); RETURN RESULT END "OR"; OPERATOR "OR"*(left: BOOLEAN; CONST right : ARRAY [?] OF BOOLEAN):ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ElOrABSBLoop ); RETURN RESULT END "OR"; PROCEDURE ElAndABSBLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, rval: BOOLEAN; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, lval & rval ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END ElAndABSBLoop; OPERATOR "&"*(CONST left : ARRAY [?] OF BOOLEAN; right: BOOLEAN):ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( BOOLEAN ), ElAndABSBLoop ); RETURN RESULT END "&"; OPERATOR "&"*(left: BOOLEAN; CONST right : ARRAY [?] OF BOOLEAN):ARRAY [ ? ] OF BOOLEAN; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( right ), ADDRESSOF( left ), SIZEOF( BOOLEAN ), ElAndABSBLoop ); RETURN RESULT END "&"; (*** less than, greater or equal: array x array -> boolean ********************************************************************) (** SHORTINT *) PROCEDURE LssASASLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval <= lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END LssASASLoop; OPERATOR "<"*( CONST left, right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LssASASLoop , FALSE); END "<"; PROCEDURE GeqASASLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval > lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END GeqASASLoop; OPERATOR ">="*( CONST left, right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqASASLoop , FALSE); END ">="; (** INTEGER *) PROCEDURE LssAIAILoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval <= lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END LssAIAILoop; OPERATOR "<"*( CONST left, right: ARRAY [ ? ] OF INTEGER ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LssAIAILoop , FALSE); END "<"; PROCEDURE GeqAIAILoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval > lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END GeqAIAILoop; OPERATOR ">="*( CONST left, right: ARRAY [ ? ] OF INTEGER ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqAIAILoop , FALSE); END ">="; (** LONGINT *) PROCEDURE LssALALLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval <= lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END LssALALLoop; OPERATOR "<"*( CONST left, right: ARRAY [ ? ] OF LONGINT ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LssALALLoop , FALSE); END "<"; PROCEDURE GeqALALLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval > lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END GeqALALLoop; OPERATOR ">="*( CONST left, right: ARRAY [ ? ] OF LONGINT ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqALALLoop , FALSE); END ">="; (** REAL *) PROCEDURE LssARARLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval <= lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END LssARARLoop; OPERATOR "<"*( CONST left, right: ARRAY [ ? ] OF REAL ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LssARARLoop , FALSE); END "<"; PROCEDURE GeqARARLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval > lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END GeqARARLoop; OPERATOR ">="*( CONST left, right: ARRAY [ ? ] OF REAL ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqARARLoop , FALSE); END ">="; (** LONGREAL *) PROCEDURE LssAXAXLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval <= lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END LssAXAXLoop; OPERATOR "<"*( CONST left, right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LssAXAXLoop , FALSE); END "<"; PROCEDURE GeqAXAXLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval > lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END GeqAXAXLoop; OPERATOR ">="*( CONST left, right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqAXAXLoop , FALSE); END ">="; (*** less than, greater or equal: array x array -> boolean ********************************************************************) (** SHORTINT *) PROCEDURE GtrASASLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval >= lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END GtrASASLoop; OPERATOR ">"*( CONST left, right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrASASLoop , FALSE); END ">"; PROCEDURE LeqASASLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval < lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END LeqASASLoop; OPERATOR "<="*( CONST left, right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqASASLoop , FALSE); END "<="; (** INTEGER *) PROCEDURE GtrAIAILoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval >= lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END GtrAIAILoop; OPERATOR ">"*( CONST left, right: ARRAY [ ? ] OF INTEGER ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrAIAILoop , FALSE); END ">"; PROCEDURE LeqAIAILoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval < lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END LeqAIAILoop; OPERATOR "<="*( CONST left, right: ARRAY [ ? ] OF INTEGER ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqAIAILoop ,FALSE); END "<="; (** LONGINT *) PROCEDURE GtrALALLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval >= lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END GtrALALLoop; OPERATOR ">"*( CONST left, right: ARRAY [ ? ] OF LONGINT ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrALALLoop , FALSE); END ">"; PROCEDURE LeqALALLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval < lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END LeqALALLoop; OPERATOR "<="*( CONST left, right: ARRAY [ ? ] OF LONGINT ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqALALLoop , FALSE); END "<="; (** REAL *) PROCEDURE GtrARARLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval >= lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END GtrARARLoop; OPERATOR ">"*( CONST left, right: ARRAY [ ? ] OF REAL ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrARARLoop , FALSE); END ">"; PROCEDURE LeqARARLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval < lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END LeqARARLoop; OPERATOR "<="*( CONST left, right: ARRAY [ ? ] OF REAL ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqARARLoop , FALSE); END "<="; (** LONGREAL *) PROCEDURE GtrAXAXLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval >= lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END GtrAXAXLoop; OPERATOR ">"*( CONST left, right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrAXAXLoop , FALSE); END ">"; PROCEDURE LeqAXAXLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval < lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END LeqAXAXLoop; OPERATOR "<="*( CONST left, right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqAXAXLoop , FALSE); END "<="; (*** equals: array x array -> boolean ********************************************************************) (** BOOLEAN *) PROCEDURE EqlABABLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: BOOLEAN; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval # lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END EqlABABLoop; OPERATOR "="*( CONST left, right: ARRAY [ ? ] OF BOOLEAN ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlABABLoop, FALSE); END "="; OPERATOR "#"*( CONST left, right: ARRAY [ ? ] OF BOOLEAN ): BOOLEAN; BEGIN RETURN ~ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlABABLoop, FALSE); END "#"; (** SHORTINT *) PROCEDURE EqlASASLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval # lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END EqlASASLoop; OPERATOR "="*( CONST left, right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlASASLoop , FALSE); END "="; OPERATOR "#"*( CONST left, right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN; BEGIN RETURN ~ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlASASLoop, FALSE ); END "#"; (** INTEGER *) PROCEDURE EqlAIAILoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval # lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END EqlAIAILoop; OPERATOR "="*( CONST left, right: ARRAY [ ? ] OF INTEGER ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlAIAILoop, FALSE ); END "="; OPERATOR "#"*( CONST left, right: ARRAY [ ? ] OF INTEGER ): BOOLEAN; BEGIN RETURN ~ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlAIAILoop, FALSE ); END "#"; (** LONGINT *) PROCEDURE EqlALALLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval # lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END EqlALALLoop; OPERATOR "="*( CONST left, right: ARRAY [ ? ] OF LONGINT ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlALALLoop, FALSE ); END "="; OPERATOR "#"*( CONST left, right: ARRAY [ ? ] OF LONGINT ): BOOLEAN; BEGIN RETURN ~ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlALALLoop, FALSE ); END "#"; (** REAL *) PROCEDURE EqlARARLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval # lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END EqlARARLoop; OPERATOR "="*( CONST left, right: ARRAY [ ? ] OF REAL ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlARARLoop, FALSE ); END "="; OPERATOR "#"*( CONST left, right: ARRAY [ ? ] OF REAL ): BOOLEAN; BEGIN RETURN ~ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlARARLoop, FALSE ); END "#"; (** LONGREAL *) PROCEDURE EqlAXAXLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval # lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END EqlAXAXLoop; OPERATOR "="*( CONST left, right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlAXAXLoop, FALSE ); END "="; OPERATOR "#"*( CONST left, right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN; BEGIN RETURN ~ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlAXAXLoop, FALSE ); END "#"; (** COMPLEX *) PROCEDURE EqlAZAZLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lval, rval: COMPLEX; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); IF rval # lval THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END EqlAZAZLoop; OPERATOR "="*( CONST left, right: ARRAY [ ? ] OF COMPLEX ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlAZAZLoop, FALSE ); END "="; OPERATOR "#"*( CONST left, right: ARRAY [ ? ] OF COMPLEX ): BOOLEAN; BEGIN RETURN ~ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlAZAZLoop, FALSE ); END "#"; (** LONGCOMPLEX *) PROCEDURE EqlALZALZLoop( ladr, radr: ADDRESS; linc, rinc, len: SIZE ): BOOLEAN; VAR lvalRe, lvalIm, rvalRe, rvalIm: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm ); SYSTEM.GET( radr, rvalRe ); SYSTEM.GET( radr+SIZEOF(LONGREAL), rvalIm ); IF (rvalRe # lvalRe) OR (rvalIm # lvalIm) THEN RETURN FALSE END; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; RETURN TRUE; END EqlALZALZLoop; OPERATOR "="*( CONST left, right: ARRAY [ ? ] OF LONGCOMPLEX ): BOOLEAN; BEGIN RETURN ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlALZALZLoop, FALSE ); END "="; OPERATOR "#"*( CONST left, right: ARRAY [ ? ] OF LONGCOMPLEX ): BOOLEAN; BEGIN RETURN ~ApplyBinaryAABOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlALZALZLoop, FALSE ); END "#"; (*** equals: array x scalar -> boolean ********************************************************************) (** BOOLEAN *) PROCEDURE EqlABSBLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: BOOLEAN; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval # rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END EqlABSBLoop; OPERATOR "="*( CONST left: ARRAY [ ? ] OF BOOLEAN; right: BOOLEAN ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlABSBLoop ); END "="; OPERATOR "="*( left: BOOLEAN; CONST right: ARRAY [ ? ] OF BOOLEAN ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), EqlABSBLoop ); END "="; OPERATOR "#"*( CONST left: ARRAY [ ? ] OF BOOLEAN; right: BOOLEAN ): BOOLEAN; BEGIN RETURN ~(left = right); END "#"; OPERATOR "#"*( left: BOOLEAN; CONST right: ARRAY [ ? ] OF BOOLEAN ): BOOLEAN; BEGIN RETURN ~( left = right ); END "#"; (** SHORTINT *) PROCEDURE EqlASSSLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval # rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END EqlASSSLoop; OPERATOR "="*( CONST left: ARRAY [ ? ] OF SHORTINT;right: SHORTINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlASSSLoop ); END "="; OPERATOR "="*( left: SHORTINT;CONST right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), EqlASSSLoop ); END "="; OPERATOR "#"*( CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): BOOLEAN; BEGIN RETURN ~( left= right ); END "#"; OPERATOR "#"*( left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN; BEGIN RETURN ~( left= right ); END "#"; (** INTEGER *) PROCEDURE EqlAISILoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval # rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END EqlAISILoop; OPERATOR "="*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlAISILoop ); END "="; OPERATOR "="*( left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), EqlAISILoop ); END "="; OPERATOR "#"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): BOOLEAN; BEGIN RETURN ~( left = right ); END "#"; OPERATOR "#"*( left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER ): BOOLEAN; BEGIN RETURN ~( left = right ); END "#"; (** LONGINT *) PROCEDURE EqlALSLLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval # rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END EqlALSLLoop; OPERATOR "="*( CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlALSLLoop ); END "="; OPERATOR "="*( left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), EqlALSLLoop ); END "="; OPERATOR "#"*( CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): BOOLEAN; BEGIN RETURN ~(left = right); END "#"; OPERATOR "#"*( left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT ): BOOLEAN; BEGIN RETURN ~(left = right); END "#"; (** REAL *) PROCEDURE EqlARSRLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval # rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END EqlARSRLoop; OPERATOR "="*( CONST left: ARRAY [ ? ] OF REAL; right: REAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlARSRLoop ); END "="; OPERATOR "="*( left: REAL; CONST right: ARRAY [ ? ] OF REAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), EqlARSRLoop ); END "="; OPERATOR "#"*( CONST left: ARRAY [ ? ] OF REAL; right: REAL ): BOOLEAN; BEGIN RETURN ~( left = right ); END "#"; OPERATOR "#"*( left: REAL; CONST right: ARRAY [ ? ] OF REAL ): BOOLEAN; BEGIN RETURN ~( left = right ); END "#"; (** LONGREAL *) PROCEDURE EqlAXSXLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGREAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval # rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END EqlAXSXLoop; OPERATOR "="*( CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), EqlAXSXLoop ); END "="; OPERATOR "="*( left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), EqlAXSXLoop ); END "="; OPERATOR "#"*( CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): BOOLEAN; BEGIN RETURN ~( left = right ); END "#"; OPERATOR "#"*( left: LONGREAL;CONST right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN; BEGIN RETURN ~( left= right ); END "#"; (*** gtr : array x scalar -> boolean ********************************************************************) (** SHORTINT *) PROCEDURE GtrASSSLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval <= rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END GtrASSSLoop; OPERATOR ">"*( CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrASSSLoop ); END ">"; OPERATOR "<"*( left: SHORTINT;CONST right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GtrASSSLoop ); END "<"; (** INTEGER *) PROCEDURE GtrAISILoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval <= rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END GtrAISILoop; OPERATOR ">"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrAISILoop ); END ">"; OPERATOR "<"*( left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GtrAISILoop ); END "<"; (** LONGINT *) PROCEDURE GtrALSLLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval <= rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END GtrALSLLoop; OPERATOR ">"*( CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrALSLLoop ); END ">"; OPERATOR "<"*( left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GtrALSLLoop ); END "<"; (** REAL *) PROCEDURE GtrARSRLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval <= rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END GtrARSRLoop; OPERATOR ">"*( CONST left: ARRAY [ ? ] OF REAL; right: REAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrARSRLoop ); END ">"; OPERATOR "<"*( left: REAL; CONST right: ARRAY [ ? ] OF REAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GtrARSRLoop ); END "<"; (** LONGREAL *) PROCEDURE GtrAXSXLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGREAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval <= rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END GtrAXSXLoop; OPERATOR ">"*( CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GtrAXSXLoop ); END ">"; OPERATOR "<"*( left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GtrAXSXLoop ); END "<"; (*** geq : array x scalar -> boolean ********************************************************************) (** SHORTINT *) PROCEDURE GeqASSSLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval < rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END GeqASSSLoop; OPERATOR ">="*( CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqASSSLoop ); END ">="; OPERATOR "<="*( left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GeqASSSLoop ); END "<="; (** INTEGER *) PROCEDURE GeqAISILoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval < rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END GeqAISILoop; OPERATOR ">="*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqAISILoop ); END ">="; OPERATOR "<="*( left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GeqAISILoop ); END "<="; (** LONGINT *) PROCEDURE GeqALSLLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval < rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END GeqALSLLoop; OPERATOR ">="*( CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqALSLLoop ); END ">="; OPERATOR "<="*( left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GeqALSLLoop ); END "<="; (** REAL *) PROCEDURE GeqARSRLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval < rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END GeqARSRLoop; OPERATOR ">="*( CONST left: ARRAY [ ? ] OF REAL; right: REAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqARSRLoop ); END ">="; OPERATOR "<="*( left: REAL; CONST right: ARRAY [ ? ] OF REAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GeqARSRLoop ); END "<="; (** LONGREAL *) PROCEDURE GeqAXSXLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGREAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval < rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END GeqAXSXLoop; OPERATOR ">="*( CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), GeqAXSXLoop ); END ">="; OPERATOR "<="*( left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), GeqAXSXLoop ); END "<="; (*** leq : array x scalar -> boolean ********************************************************************) (** SHORTINT *) PROCEDURE LeqASSSLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval > rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END LeqASSSLoop; OPERATOR "<="*( CONST left: ARRAY [ ? ] OF SHORTINT;right: SHORTINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqASSSLoop ); END "<="; OPERATOR ">="*( left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LeqASSSLoop ); END ">="; (** INTEGER *) PROCEDURE LeqAISILoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval > rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END LeqAISILoop; OPERATOR "<="*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqAISILoop ); END "<="; OPERATOR ">="*( left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LeqAISILoop ); END ">="; (** LONGINT *) PROCEDURE LeqALSLLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval > rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END LeqALSLLoop; OPERATOR "<="*( CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqALSLLoop ); END "<="; OPERATOR ">="*( left: LONGINT; CONST right: ARRAY [ ? ] OF LONGINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LeqALSLLoop ); END ">="; (** REAL *) PROCEDURE LeqARSRLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval > rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END LeqARSRLoop; OPERATOR "<="*( CONST left: ARRAY [ ? ] OF REAL; right: REAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqARSRLoop ); END "<="; OPERATOR ">="*( left: REAL; CONST right: ARRAY [ ? ] OF REAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LeqARSRLoop ); END ">="; (** LONGREAL *) PROCEDURE LeqAXSXLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGREAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval > rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END LeqAXSXLoop; OPERATOR "<="*( CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LeqAXSXLoop ); END "<="; OPERATOR ">="*( left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LeqAXSXLoop ); END ">="; (*** lss: array x scalar -> boolean ********************************************************************) (** SHORTINT *) PROCEDURE LssASSSLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: SHORTINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval >= rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END LssASSSLoop; OPERATOR "<"*( CONST left: ARRAY [ ? ] OF SHORTINT; right: SHORTINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LssASSSLoop ); END "<"; OPERATOR ">"*( left: SHORTINT; CONST right: ARRAY [ ? ] OF SHORTINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LssASSSLoop ); END ">"; (** INTEGER *) PROCEDURE LssAISILoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: INTEGER; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval >= rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END LssAISILoop; OPERATOR "<"*(CONST left: ARRAY [ ? ] OF INTEGER; right: INTEGER ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LssAISILoop ); END "<"; OPERATOR ">"*( left: INTEGER; CONST right: ARRAY [ ? ] OF INTEGER ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LssAISILoop ); END ">"; (** LONGINT *) PROCEDURE LssALSLLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGINT; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval >= rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END LssALSLLoop; OPERATOR "<"*( CONST left: ARRAY [ ? ] OF LONGINT; right: LONGINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LssALSLLoop ); END "<"; OPERATOR ">"*( left: LONGINT;CONST right: ARRAY [ ? ] OF LONGINT ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LssALSLLoop ); END ">"; (** REAL *) PROCEDURE LssARSRLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: REAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval >= rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END LssARSRLoop; OPERATOR "<"*( CONST left: ARRAY [ ? ] OF REAL; right: REAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LssARSRLoop ); END "<"; OPERATOR ">"*( left: REAL; CONST right: ARRAY [ ? ] OF REAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LssARSRLoop ); END ">"; (** LONGREAL *) PROCEDURE LssAXSXLoop( ladr, radr: ADDRESS; linc, len: SIZE ): BOOLEAN; VAR lval, rval: LONGREAL; BEGIN SYSTEM.GET( radr, rval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval >= rval THEN RETURN FALSE END; INC( ladr, linc ); DEC( len ); END; RETURN TRUE; END LssAXSXLoop; OPERATOR "<"*( CONST left: ARRAY [ ? ] OF LONGREAL; right: LONGREAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( left ), ADDRESSOF( right ), LssAXSXLoop ); END "<"; OPERATOR ">"*( left: LONGREAL; CONST right: ARRAY [ ? ] OF LONGREAL ): BOOLEAN; BEGIN RETURN ApplyBinaryASBOp( ADDRESSOF( right ), ADDRESSOF( left ), LssAXSXLoop ); END ">"; (**** binary max/min operators array x scalar-> array ********************************************************************) PROCEDURE MaxAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, val: LONGREAL; BEGIN SYSTEM.GET( radr, val ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); INC( ladr, linc ); DEC( len ); IF lval>val THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT(dadr, val) END;; INC(dadr,dinc); END; END MaxAXSXLoop; OPERATOR "MAX"*(CONST left: ARRAY [?] OF LONGREAL; right: LONGREAL): ARRAY [?] OF LONGREAL; TYPE Type = LONGREAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( Type ), MaxAXSXLoop ); RETURN RESULT END "MAX"; PROCEDURE MaxARSRLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, val: REAL; BEGIN SYSTEM.GET( radr, val ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); INC( ladr, linc ); DEC( len ); IF lval>val THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT(dadr, val) END;; INC(dadr,dinc); END; END MaxARSRLoop; OPERATOR "MAX"*(CONST left: ARRAY [?] OF REAL; right: REAL): ARRAY [?] OF REAL; TYPE Type = REAL; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( Type ), MaxARSRLoop ); RETURN RESULT END "MAX"; PROCEDURE MaxALSLLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, val: LONGINT; BEGIN SYSTEM.GET( radr, val ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); INC( ladr, linc ); DEC( len ); IF lval>val THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT(dadr, val) END; INC(dadr,dinc); END; END MaxALSLLoop; OPERATOR "MAX"*(CONST left: ARRAY [?] OF LONGINT; right: LONGINT): ARRAY [?] OF LONGINT; TYPE Type = LONGINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( Type ), MaxALSLLoop ); RETURN RESULT END "MAX"; PROCEDURE MaxAISILoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, val: INTEGER; BEGIN SYSTEM.GET( radr, val ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); INC( ladr, linc ); DEC( len ); IF lval>val THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT(dadr, val) END; INC(dadr,dinc); END; END MaxAISILoop; OPERATOR "MAX"*(CONST left: ARRAY [?] OF INTEGER; right: INTEGER): ARRAY [?] OF INTEGER; TYPE Type = INTEGER; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( Type ), MaxAISILoop ); RETURN RESULT END "MAX"; PROCEDURE MaxASSSLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, val: SHORTINT; BEGIN SYSTEM.GET( radr, val ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); INC( ladr, linc ); DEC( len ); IF lval>val THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT(dadr, val) END; INC(dadr,dinc); END; END MaxASSSLoop; OPERATOR "MAX"*(CONST left: ARRAY [?] OF SHORTINT; right: SHORTINT): ARRAY [?] OF SHORTINT; TYPE Type = SHORTINT; BEGIN ApplyBinaryASAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( Type ), MaxASSSLoop ); RETURN RESULT END "MAX"; PROCEDURE MinAXSXLoop( ladr, radr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval, val: LONGREAL; BEGIN SYSTEM.GET( radr, val ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); INC( ladr, linc ); DEC( len ); IF lval 0) DO SYSTEM.GET( ladr, lval ); INC( ladr, linc ); DEC( len ); IF lval 0) DO SYSTEM.GET( ladr, lval ); INC( ladr, linc ); DEC( len ); IF lval 0) DO SYSTEM.GET( ladr, lval ); INC( ladr, linc ); DEC( len ); IF lval 0) DO SYSTEM.GET( ladr, lval ); INC( ladr, linc ); DEC( len ); IF lval array ********************************************************************) PROCEDURE MaxAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); INC( ladr, linc ); INC(radr,rinc ); DEC( len ); IF lval>rval THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT (dadr,rval) END; INC(dadr,dinc); END; END MaxAXAXLoop; OPERATOR "MAX"*(CONST left, right: ARRAY [?] OF LONGREAL): ARRAY [?] OF LONGREAL; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), MaxAXAXLoop ); RETURN RESULT END "MAX"; PROCEDURE MaxARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: REAL ; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); INC( ladr, linc ); INC(radr,rinc ); DEC( len ); IF lval>rval THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT (dadr,rval) END; INC(dadr,dinc); END; END MaxARARLoop; OPERATOR "MAX"*(CONST left, right: ARRAY [?] OF REAL): ARRAY [?] OF REAL; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), MaxARARLoop ); RETURN RESULT END "MAX"; PROCEDURE MaxALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); INC( ladr, linc ); INC(radr,rinc ); DEC( len ); IF lval>rval THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT (dadr,rval) END; INC(dadr,dinc); END; END MaxALALLoop; OPERATOR "MAX"*(CONST left, right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT ; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), MaxALALLoop ); RETURN RESULT END "MAX"; PROCEDURE MaxAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); INC( ladr, linc ); INC(radr,rinc ); DEC( len ); IF lval>rval THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT (dadr,rval) END; INC(dadr,dinc); END; END MaxAIAILoop; OPERATOR "MAX"*(CONST left, right: ARRAY [?] OF INTEGER): ARRAY [?] OF INTEGER; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), MaxAIAILoop ); RETURN RESULT END "MAX"; PROCEDURE MaxASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); INC( ladr, linc ); INC(radr,rinc ); DEC( len ); IF lval>rval THEN SYSTEM.PUT( dadr, lval) ELSE SYSTEM.PUT (dadr,rval) END; INC(dadr,dinc); END; END MaxASASLoop; OPERATOR "MAX"*(CONST left, right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), MaxASASLoop ); RETURN RESULT END "MAX"; PROCEDURE MinAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); INC( ladr, linc ); INC(radr,rinc ); DEC( len ); IF lval 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); INC( ladr, linc ); INC(radr,rinc ); DEC( len ); IF lval 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); INC( ladr, linc ); INC(radr,rinc ); DEC( len ); IF lval 0) DO IF ladr.val < ladr.val THEN dadr.val := ladr.val ELSE dadr.val := radr.val END; ladr := ladr + linc; radr := radr + rinc; dadr := dadr + dinc; DEC(len); END; END MinALALLoop; OPERATOR "MIN"*(CONST left, right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT ; BEGIN ApplyBinaryAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), MinALALLoop ); RETURN RESULT END "MIN"; PROCEDURE MinAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, dinc, len: SIZE ); VAR lval, rval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); INC( ladr, linc ); INC(radr,rinc ); DEC( len ); IF lval 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); INC( ladr, linc ); INC(radr,rinc ); DEC( len ); IF lval scalar ********************************************************************) (*** min: array -> scalar ****************************************) (** SHORTINT *) PROCEDURE MinASLoop( ladr, dadr: ADDRESS; linc, len: SIZE ); VAR lval, dval: SHORTINT; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval < dval THEN dval := lval END; INC( ladr, linc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MinASLoop; OPERATOR "MIN"*( CONST left: ARRAY [ ? ] OF SHORTINT ): SHORTINT; TYPE Type = SHORTINT; VAR val: Type; BEGIN val := MAX( Type ); ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MinASLoop ); RETURN val; END "MIN"; (** INTEGER *) PROCEDURE MinAILoop( ladr, dadr: ADDRESS; linc, len: SIZE ); VAR lval, dval: INTEGER; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval < dval THEN dval := lval END; INC( ladr, linc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MinAILoop; OPERATOR "MIN"*( CONST left: ARRAY [ ? ] OF INTEGER ): INTEGER; TYPE Type = INTEGER; VAR val: Type; BEGIN val := MAX( Type ); ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MinAILoop ); RETURN val; END "MIN"; (** LONGINT *) PROCEDURE MinALLoop( ladr, dadr: ADDRESS; linc, len: SIZE ); VAR lval, dval: LONGINT; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval < dval THEN dval := lval END; INC( ladr, linc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MinALLoop; OPERATOR "MIN"*( CONST left: ARRAY [ ? ] OF LONGINT ): LONGINT; TYPE Type = LONGINT; VAR val: Type; BEGIN val := MAX( Type ); ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MinALLoop ); RETURN val; END "MIN"; (** REAL *) PROCEDURE MinARLoop( ladr, dadr: ADDRESS; linc, len: SIZE ); VAR lval, dval: REAL; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval < dval THEN dval := lval END; INC( ladr, linc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MinARLoop; OPERATOR "MIN"*( CONST left: ARRAY [ ? ] OF REAL ): REAL; TYPE Type = REAL; VAR val: Type; BEGIN val := MAX( Type ); ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MinARLoop ); RETURN val; END "MIN"; (** LONGREAL *) PROCEDURE MinAXLoop( ladr, dadr: ADDRESS; linc, len: SIZE ); VAR lval, dval: LONGREAL; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval < dval THEN dval := lval END; INC( ladr, linc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MinAXLoop; OPERATOR "MIN"*( CONST left: ARRAY [ ? ] OF LONGREAL ): LONGREAL; TYPE Type = LONGREAL; VAR val: Type; BEGIN val := MAX( Type ); ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MinAXLoop ); RETURN val; END "MIN"; (*** max: array -> scalar ********************************************************************) (** SHORTINT *) PROCEDURE MaxASLoop( ladr, dadr: ADDRESS; linc, len: SIZE ); VAR lval, dval: SHORTINT; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval > dval THEN dval := lval END; INC( ladr, linc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MaxASLoop; OPERATOR "MAX"*( CONST left: ARRAY [ ? ] OF SHORTINT ): SHORTINT; TYPE Type = SHORTINT; VAR val: Type; BEGIN val := MIN( Type ); ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MaxASLoop ); RETURN val; END "MAX"; (** INTEGER *) PROCEDURE MaxAILoop( ladr, dadr: ADDRESS; linc, len: SIZE ); VAR lval, dval: INTEGER; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval > dval THEN dval := lval END; INC( ladr, linc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MaxAILoop; OPERATOR "MAX"*( CONST left: ARRAY [ ? ] OF INTEGER ): INTEGER; TYPE Type = INTEGER; VAR val: Type; BEGIN val := MIN( Type ); ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MaxAILoop ); RETURN val; END "MAX"; (** LONGINT *) PROCEDURE MaxALLoop( ladr, dadr: ADDRESS; linc, len: SIZE ); VAR lval, dval: LONGINT; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval > dval THEN dval := lval END; INC( ladr, linc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MaxALLoop; OPERATOR "MAX"*( CONST left: ARRAY [ ? ] OF LONGINT ): LONGINT; TYPE Type = LONGINT; VAR val: Type; BEGIN val := MIN( Type ); ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MaxALLoop ); RETURN val; END "MAX"; (** REAL *) PROCEDURE MaxARLoop( ladr, dadr: ADDRESS; linc, len: SIZE ); VAR lval, dval: REAL; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval > dval THEN dval := lval END; INC( ladr, linc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MaxARLoop; OPERATOR "MAX"*( CONST left: ARRAY [ ? ] OF REAL ): REAL; TYPE Type = REAL; VAR val: Type; BEGIN val := MIN( Type ); ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MaxARLoop ); RETURN val; END "MAX"; (** LONGREAL *) PROCEDURE MaxAXLoop( ladr, dadr: ADDRESS; linc, len: SIZE ); VAR lval, dval: LONGREAL; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); IF lval > dval THEN dval := lval END; INC( ladr, linc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MaxAXLoop; OPERATOR "MAX"*( CONST left: ARRAY [ ? ] OF LONGREAL ): LONGREAL; TYPE Type = LONGREAL; VAR val: Type; BEGIN val := MIN( Type ); ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), MaxAXLoop ); RETURN val; END "MAX"; (*** LEN: array -> array **) OPERATOR "LEN"*(CONST left: ARRAY [?]): ARRAY [*] OF LONGINT; VAR src,dim,i: LONGINT; BEGIN src := SYSTEM.VAL(LONGINT,left); dim := GetDim( src ); IF (DIM(RESULT)#1) OR (LEN(RESULT,0) # dim) THEN NEW(RESULT,dim) END; FOR i := 0 TO dim-1 DO RESULT[i] := GetLen(src,i) END; RETURN RESULT END "LEN"; (*** SUM: array -> scalar ********************************************************************) (** SHORTINT *) PROCEDURE SumASLoop( ladr, dadr: ADDRESS; linc, len: SIZE ); VAR lval, dval: SHORTINT; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := dval + lval; INC( ladr, linc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END SumASLoop; OPERATOR "SUM"*( CONST left: ARRAY [ ? ] OF SHORTINT ): SHORTINT; TYPE Type = SHORTINT; VAR val: Type; BEGIN val := 0; ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), SumASLoop ); RETURN val; END "SUM"; (** INTEGER *) PROCEDURE SumAILoop( ladr, dadr: ADDRESS; linc, len: SIZE ); VAR lval, dval: INTEGER; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := dval + lval; INC( ladr, linc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END SumAILoop; OPERATOR "SUM"*( CONST left: ARRAY [ ? ] OF INTEGER ): INTEGER; TYPE Type = INTEGER; VAR val: Type; BEGIN val := 0; ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), SumAILoop ); RETURN val; END "SUM"; (** LONGINT *) PROCEDURE SumALLoop( ladr, dadr: ADDRESS; linc, len: SIZE ); VAR lval, dval: LONGINT; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := dval + lval; INC( ladr, linc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END SumALLoop; OPERATOR "SUM"*( CONST left: ARRAY [ ? ] OF LONGINT ): LONGINT; TYPE Type = LONGINT; VAR val: Type; BEGIN val := 0; ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), SumALLoop ); RETURN val; END "SUM"; (** REAL *) PROCEDURE SumARLoop( ladr, dadr: ADDRESS; linc, len: SIZE ); VAR lval, dval: REAL; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := dval + lval; INC( ladr, linc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END SumARLoop; OPERATOR "SUM"*( CONST left: ARRAY [ ? ] OF REAL ): REAL; TYPE Type = REAL; VAR val: Type; BEGIN val := 0; ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), SumARLoop ); RETURN val; END "SUM"; (** LONGREAL *) PROCEDURE SumAXLoop( ladr, dadr: ADDRESS; linc, len: SIZE ); VAR lval, dval: LONGREAL; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := dval + lval; INC( ladr, linc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END SumAXLoop; OPERATOR "SUM"*( CONST left: ARRAY [ ? ] OF LONGREAL ): LONGREAL; TYPE Type = LONGREAL; VAR val: Type; BEGIN val := 0; ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), SumAXLoop ); RETURN val; END "SUM"; (** COMPLEX *) PROCEDURE SumAZLoop( ladr, dadr: ADDRESS; linc, len: SIZE ); VAR lval, dval: COMPLEX; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); dval := dval + lval; INC( ladr, linc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END SumAZLoop; OPERATOR "SUM"*( CONST left: ARRAY [ ? ] OF COMPLEX ): COMPLEX; TYPE Type = COMPLEX; VAR val: Type; BEGIN val := 0; ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), SumAZLoop ); RETURN val; END "SUM"; (** LONGCOMPLEX *) PROCEDURE SumALZLoop( ladr, dadr: ADDRESS; linc, len: SIZE ); VAR lvalRe, lvalIm, dvalRe, dvalIm: LONGREAL; BEGIN SYSTEM.GET( dadr, dvalRe ); SYSTEM.GET( dadr+SIZEOF(LONGREAL), dvalIm ); WHILE (len > 0) DO SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm ); dvalRe := dvalRe + lvalRe; dvalIm := dvalIm + lvalIm; INC( ladr, linc ); DEC( len ); END; SYSTEM.PUT( dadr, dvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), dvalIm ); END SumALZLoop; OPERATOR "SUM"*( CONST left: ARRAY [ ? ] OF LONGCOMPLEX ): LONGCOMPLEX; TYPE Type = LONGCOMPLEX; VAR val: Type; BEGIN val := 0; ApplyUnaryASOp( ADDRESSOF( val ), ADDRESSOF( left ), SumALZLoop ); RETURN val; END "SUM"; (*** monadic ABS array -> array ********************************************************************) (** SHORTINT *) PROCEDURE AbsLoopS( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: SHORTINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, ABS( lval ) ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END AbsLoopS; OPERATOR "ABS"*(CONST src: ARRAY [ ? ] OF SHORTINT): ARRAY [ ? ] OF SHORTINT; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( SHORTINT ), AbsLoopS ); RETURN RESULT END "ABS"; (** INTEGER *) PROCEDURE AbsLoopI( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: INTEGER; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, ABS( lval ) ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END AbsLoopI; OPERATOR "ABS"*(CONST src: ARRAY [ ? ] OF INTEGER): ARRAY [ ? ] OF INTEGER; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( INTEGER ), AbsLoopI ); RETURN RESULT END "ABS"; (** LONGINT *) PROCEDURE AbsLoopL( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: LONGINT; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, ABS( lval ) ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END AbsLoopL; OPERATOR "ABS"*(CONST src: ARRAY [ ? ] OF LONGINT): ARRAY [ ? ] OF LONGINT; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGINT ), AbsLoopL ); RETURN RESULT END "ABS"; (** REAL *) PROCEDURE AbsLoopR( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: REAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, ABS( lval ) ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END AbsLoopR; OPERATOR "ABS"*(CONST src: ARRAY [ ? ] OF REAL): ARRAY [ ? ] OF REAL; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( REAL ), AbsLoopR ); RETURN RESULT END "ABS"; (** LONGREAL *) PROCEDURE AbsLoopX( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, ABS( lval ) ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END AbsLoopX; OPERATOR "ABS"*(CONST src: ARRAY [ ? ] OF LONGREAL): ARRAY [ ? ] OF LONGREAL; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGREAL ), AbsLoopX ); RETURN RESULT END "ABS"; (** COMPLEX *) PROCEDURE AbsLoopZ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lval: COMPLEX; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.PUT( dadr, ABS(lval) ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END AbsLoopZ; OPERATOR "ABS"*(CONST src: ARRAY [ ? ] OF COMPLEX): ARRAY [ ? ] OF REAL; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( REAL ), AbsLoopZ ); RETURN RESULT END "ABS"; (** LONGCOMPLEX *) PROCEDURE AbsLoopLZ( ladr, dadr: ADDRESS; linc, dinc, len: SIZE ); VAR lvalRe, lvalIm: LONGREAL; BEGIN WHILE (len > 0) DO SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm ); SYSTEM.PUT( dadr, MathL.sqrt(lvalRe*lvalRe + lvalIm*lvalIm) ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; END AbsLoopLZ; OPERATOR "ABS"*(CONST src: ARRAY [ ? ] OF LONGCOMPLEX): ARRAY [ ? ] OF LONGREAL; BEGIN ApplyUnaryAAOp( ADDRESSOF( RESULT ), ADDRESSOF( src ), SIZEOF( LONGREAL ), AbsLoopLZ ); RETURN RESULT END "ABS"; (*** assign number to array (initialisation) ********************************************************************) (** BOOLEAN *) PROCEDURE AssignSBABLoop( ladr, dadr: ADDRESS; dinc, len: SIZE ); VAR lval: BOOLEAN; BEGIN SYSTEM.GET( ladr, lval ); WHILE (len > 0) DO SYSTEM.PUT( dadr, lval ); INC( dadr, dinc ); DEC( len ); END; END AssignSBABLoop; OPERATOR ":="*(VAR dest: ARRAY [?] OF BOOLEAN; right: BOOLEAN); BEGIN ApplyUnarySAOp( ADDRESSOF( dest ), ADDRESSOF( right ), AssignSBABLoop ); END ":="; (** SHORTINT*) PROCEDURE AssignSSASLoop( ladr, dadr: ADDRESS; dinc, len: SIZE ); VAR lval: SHORTINT; BEGIN SYSTEM.GET( ladr, lval ); WHILE (len > 0) DO SYSTEM.PUT( dadr, lval ); INC( dadr, dinc ); DEC( len ); END; END AssignSSASLoop; OPERATOR ":="*(VAR dest: ARRAY [?] OF SHORTINT; right: SHORTINT); BEGIN ApplyUnarySAOp( ADDRESSOF( dest ), ADDRESSOF( right ), AssignSSASLoop ); END ":="; (**INTEGER *) PROCEDURE AssignSIAILoop( ladr, dadr: ADDRESS; dinc, len: SIZE ); VAR lval: INTEGER; BEGIN SYSTEM.GET( ladr, lval ); WHILE (len > 0) DO SYSTEM.PUT( dadr, lval ); INC( dadr, dinc ); DEC( len ); END; END AssignSIAILoop; OPERATOR ":="*(VAR dest: ARRAY [?] OF INTEGER; right: INTEGER); BEGIN ApplyUnarySAOp( ADDRESSOF( dest ), ADDRESSOF( right ), AssignSIAILoop ); END ":="; (** LONGINT *) PROCEDURE AssignSLALLoop( ladr, dadr: ADDRESS; dinc, len: SIZE ); VAR lval: LONGINT; BEGIN SYSTEM.GET( ladr, lval ); WHILE (len > 0) DO SYSTEM.PUT( dadr, lval ); INC( dadr, dinc ); DEC( len ); END; END AssignSLALLoop; OPERATOR ":="*(VAR dest: ARRAY [?] OF LONGINT; right: LONGINT); BEGIN ApplyUnarySAOp( ADDRESSOF( dest ), ADDRESSOF( right ), AssignSLALLoop ); END ":="; (** REAL *) PROCEDURE AssignSRARLoop( ladr, dadr: ADDRESS; dinc, len: SIZE ); VAR lval: REAL; BEGIN SYSTEM.GET( ladr, lval ); WHILE (len > 0) DO SYSTEM.PUT( dadr, lval ); INC( dadr, dinc ); DEC( len ); END; END AssignSRARLoop; OPERATOR ":="*(VAR dest: ARRAY [?] OF REAL; right: REAL); BEGIN ApplyUnarySAOp( ADDRESSOF( dest ), ADDRESSOF( right ), AssignSRARLoop ); END ":="; (** LONGREAL *) PROCEDURE AssignSXAXLoop( ladr, dadr: ADDRESS; dinc, len: SIZE ); VAR lval: LONGREAL; BEGIN SYSTEM.GET( ladr, lval ); WHILE (len > 0) DO SYSTEM.PUT( dadr, lval ); INC( dadr, dinc ); DEC( len ); END; END AssignSXAXLoop; OPERATOR ":="*(VAR dest: ARRAY [?] OF LONGREAL; right: LONGREAL); BEGIN ApplyUnarySAOp( ADDRESSOF( dest ), ADDRESSOF( right ), AssignSXAXLoop ); END ":="; (** COMPLEX *) PROCEDURE AssignSZAZLoop( ladr, dadr: ADDRESS; dinc, len: SIZE ); VAR lval: COMPLEX; BEGIN SYSTEM.GET( ladr, lval ); WHILE (len > 0) DO SYSTEM.PUT( dadr, lval ); INC( dadr, dinc ); DEC( len ); END; END AssignSZAZLoop; OPERATOR ":="*(VAR dest: ARRAY [?] OF COMPLEX; right: COMPLEX); BEGIN ApplyUnarySAOp( ADDRESSOF( dest ), ADDRESSOF( right ), AssignSZAZLoop ); END ":="; (** LONGCOMPLEX *) PROCEDURE AssignSLZALZLoop( ladr, dadr: ADDRESS; dinc, len: SIZE ); VAR lvalRe, lvalIm: LONGREAL; BEGIN SYSTEM.GET( ladr, lvalRe ); SYSTEM.GET( ladr+SIZEOF(LONGREAL), lvalIm ); WHILE (len > 0) DO SYSTEM.PUT( dadr, lvalRe ); SYSTEM.PUT( dadr+SIZEOF(LONGREAL), lvalIm ); INC( dadr, dinc ); DEC( len ); END; END AssignSLZALZLoop; OPERATOR ":="*(VAR dest: ARRAY [?] OF LONGCOMPLEX; right: LONGCOMPLEX); BEGIN ApplyUnarySAOp( ADDRESSOF( dest ), ADDRESSOF( right ), AssignSLZALZLoop ); END ":="; (*** matrix multipliation ********************************************************************) PROCEDURE AllocateMatrix( dest: ADDRESS; rows, cols, elementsize: LONGINT ): ANY; VAR p: ANY; BEGIN (* KernelLog.String( "ALLOCATE MATRIX WAS CALLED" ); KernelLog.Ln; *) SYSTEM.NEW( p, rows * cols * elementsize ); PutLen( dest, 1, cols ); PutLen( dest, 0, rows ); PutInc( dest, 1, elementsize ); PutInc( dest, 0, elementsize * cols ); PutAdr( dest, SYSTEM.VAL( LONGINT, p ) ); PutPtr( dest, p); RETURN p; END AllocateMatrix; PROCEDURE AllocateVector( dest: ADDRESS; l0, elementsize: LONGINT ): ANY; VAR p: ANY; BEGIN SYSTEM.NEW( p, l0 * elementsize ); PutLen( dest, 0, l0 ); PutInc( dest, 0, elementsize ); PutAdr( dest, SYSTEM.VAL( LONGINT, p ) ); PutPtr( dest, p ); RETURN p; END AllocateVector; PROCEDURE ApplyMatMulLoop( dest, left, right: ADDRESS; Size: LONGINT; loop: BinaryAASLoop; fast: FastMatMul ); (* Size= element-size *) VAR ladr, radr, dadr, dadri, radri, rowsL, colsL, rowsR, colsR, incL, incR, incD, strideR, strideL, strideD, colsRi: LONGINT; p: ANY; overlap: BOOLEAN; destOld, destNew: ADDRESS; BEGIN (* <- 1 -> xxx xxxx -> xxxx ^ xxx xxxx xxxx 0 xxx xxxx xxxx v xxx xxxx xxx xxxx Len(..,1): #columns ; Inc(..,1): inc in rows Len(..,0): #rows ; Inc(..,0): inc between rows *) (* apply multiplication D = L * R *) rowsL := GetLen( left, 0 ); (* # left rows = # dest rows*) colsL := GetLen( left, 1 ); (* # left columns *) rowsR := GetLen( right, 0 ); (* # right rows =!= left columns *) colsR := GetLen( right, 1 ); (* # right columns = # dest columns*) (* check geometric restriction *) IF colsL # rowsR THEN Halt( GeometryMismatch, left, right, 0 ); END; IF GetAdr( dest ) = 0 THEN p := AllocateMatrix( dest, rowsL, colsR, Size ); ELSIF (GetLen( dest, 0 ) # rowsL) OR (GetLen( dest, 1 ) # colsR) THEN IF RangeFlag IN GetFlags( dest ) THEN Halt( GeometryMismatch, left, right, dest ) ELSE p := AllocateMatrix( dest, rowsL, colsR, Size ); END; END; overlap := Overlap( left, dest ) OR Overlap( right, dest ); IF overlap THEN destOld := dest; destNew := 0; p := AllocateSame( destNew, destOld, Size ); CopyContent( destNew, destOld, Size ); (* for INCMUL ! *) dest := destNew; END; IF (GetLen( dest, 0 ) # rowsL) OR (GetLen( dest, 1 ) # colsR) THEN HALT( 9999 ) END; ladr := GetAdr( left ); radr := GetAdr( right ); dadr := GetAdr( dest ); incL := GetIncr( left, 1 ); strideL := GetIncr( left, 0 ); (* increment and stride of left matrix *) incR := GetIncr( right, 1 ); strideR := GetIncr( right, 0 ); (* increment and stride of right matrix *) incD := GetIncr( dest, 1 ); strideD := GetIncr( dest, 0 ); (* increment and stride of dest matrix *) (* KernelLog.String("incD="); KernelLog.Int(incD,10); KernelLog.Ln; KernelLog.String("strideD="); KernelLog.Int(strideD,10); KernelLog.Ln; KernelLog.String("Len(dest,0) [rows]="); KernelLog.Int(GetLen(dest,0),10); KernelLog.Ln; KernelLog.String("Len(dest,1) [cols]="); KernelLog.Int(GetLen(dest,1),10); KernelLog.Ln; *) IF rowsL = 0 THEN RETURN ELSIF colsL=0 THEN RETURN ELSIF colsR=0 THEN RETURN ELSIF (fast = NIL ) OR ~(fast( ladr, radr, dadr, incL, strideL, incR, strideR, incD, strideD, rowsL, colsL, rowsR, colsR )) THEN WHILE (rowsL > 0) DO (* outer loop: traverse rows of left matrix *) radri := radr; dadri := dadr; colsRi := colsR; WHILE (colsRi > 0) DO (* inner loop: traverse columns of right matrix *) loop( ladr, radri, dadri, incL, strideR, colsL ); INC( radri, incR ); INC( dadri, incD ); DEC( colsRi ); END; INC( ladr, strideL ); INC( dadr, strideD ); DEC( rowsL ); END; END; IF overlap THEN CopyContent( destOld, dest, Size ); END; END ApplyMatMulLoop; PROCEDURE ApplyMatVecMulLoop( dest, left, right: ADDRESS; Size: LONGINT; loop: BinaryAASLoop; fast: FastMatMul ); (* Size= element-size *) VAR ladr, radr, dadr, li1, li0, ri0, di0, l1, l2: LONGINT; p: ANY; overlap: BOOLEAN; destOld, destNew: ADDRESS; BEGIN (* <- 0 -> xxx T(xxx) -> T(xxxxx) xxx 1 xxx xxx xxx Len(..,0): #columns ; Inc(..,0): inc in rows Len(..,1): #rows ; Inc(..,1): inc between rows *) (* check geometric restriction *) IF GetLen( left, 1 ) # GetLen( right, 0 ) THEN Halt( GeometryMismatch, left, right,0 ); END; l1 := GetLen( left, 0 ); (* number of destination's rows *) l2 := GetLen( left, 1 ); (* inner loop len *) IF GetAdr( dest ) = 0 THEN p := AllocateVector( dest, l1, Size ); ELSIF (GetLen( dest, 0 ) # l1) THEN IF RangeFlag IN GetFlags( dest ) THEN Halt( GeometryMismatch, left, right, dest ); ELSE p := AllocateVector( dest, l1, Size ); END; END; overlap := Overlap( left, dest ) OR Overlap( right, dest ); IF overlap THEN destOld := dest; destNew := 0; p := AllocateSame( destNew, destOld, Size ); CopyContent( destNew, destOld, Size ); (* for INCMUL ! *) dest := destNew; END; (* IF GetAdr( dest ) = -1 THEN p := AllocateVector( dest, l1, Size ); ELSE IF (GetLen( dest, 0 ) # l1) THEN HALT( 102 ) END; END; *) ladr := GetAdr( left ); radr := GetAdr( right ); dadr := GetAdr( dest ); li0 := GetIncr( left, 1 ); li1 := GetIncr( left, 0 ); ri0 := GetIncr( right, 0 ); di0 := GetIncr( dest, 0 ); IF l1=0 THEN RETURN ELSIF l2=0 THEN RETURN ELSIF (fast = NIL ) OR ~(fast( ladr, radr, dadr, li0, li1, ri0, ri0, di0, di0, l1, l2, l2, 1 )) THEN WHILE (l1 > 0) DO (* inner loop: traverse columns of right matrix *) loop( ladr, radr, dadr, li0, ri0, l2 ); INC( ladr, li1 ); INC( dadr, di0 ); DEC( l1 ); END; END; IF overlap THEN CopyContent( destOld, dest, Size ); END; END ApplyMatVecMulLoop; PROCEDURE ApplyVecMatMulLoop( dest, left, right: ADDRESS; Size: LONGINT; loop: BinaryAASLoop; fast: FastMatMul ); (* Size= element-size *) VAR ladr, radr, dadr, li0, ri1, ri0, di0, l0, l2: LONGINT; p: ANY; overlap: BOOLEAN; destOld, destNew: ADDRESS; BEGIN (* <- 0 -> xxx xxxx -> xxxx xxxx 1 xxxx Len(..,0): #columns ; Inc(..,0): inc in rows Len(..,1): #rows ; Inc(..,1): inc between rows *) (* check geometric restriction *) IF GetLen( left, 0 ) # GetLen( right, 0 ) THEN HALT( GeometryMismatch ); END; l0 := GetLen( right, 1 ); (* number of destination's column *) l2 := GetLen( right, 0 ); (* inner loop len *) IF GetAdr( dest ) = 0 THEN p := AllocateVector( dest, l0, Size ); ELSIF (GetLen( dest, 0 ) # l0) THEN IF RangeFlag IN GetFlags( dest ) THEN HALT( GeometryMismatch ) ELSE p := AllocateVector( dest, l0, Size ); END; END; overlap := Overlap( left, dest ) OR Overlap( right, dest ); IF overlap THEN destOld := dest; destNew := 0; p := AllocateSame( destNew, destOld, Size ); CopyContent( destNew, destOld, Size ); (* for INCMUL ! *) dest := destNew; END; (* IF GetAdr( dest ) = -1 THEN p := AllocateVector( dest, l0, Size ); ELSE IF (GetLen( dest, 0 ) # l0) THEN HALT( 102 ) END; END; *) ladr := GetAdr( left ); radr := GetAdr( right ); dadr := GetAdr( dest ); li0 := GetIncr( left, 0 ); ri0 := GetIncr( right, 1 ); ri1 := GetIncr( right, 0 ); di0 := GetIncr( dest, 0 ); IF l2=0 THEN RETURN ELSIF l0=0 THEN RETURN ELSIF (fast = NIL ) OR ~fast( ladr, radr, dadr, li0, li0, ri0, ri1, di0, di0, 1, l2, l2, l0 ) THEN WHILE (l0 > 0) DO (* inner loop: traverse columns of right matrix *) loop( ladr, radr, dadr, li0, ri1, l2 ); INC( radr, ri0 ); INC( dadr, di0 ); DEC( l0 ); END; END; IF overlap THEN CopyContent( destOld, dest, Size ); END; END ApplyVecMatMulLoop; (** SHORTINT *) PROCEDURE MatMulASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); VAR lval, rval, dval: SHORTINT; BEGIN dval := 0; WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval; (* KernelLog.String("mul with: "); KernelLog.Int(lval,10); KernelLog.Int(rval,10); KernelLog.Ln; *) INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MatMulASASLoop; OPERATOR "*"*(CONST left, right: ARRAY [ * , * ] OF SHORTINT ): ARRAY [ * , * ] OF SHORTINT; BEGIN ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), MatMulASASLoop, NIL ); RETURN RESULT END "*"; OPERATOR "*"*(CONST left: ARRAY [ * , * ] OF SHORTINT; CONST right: ARRAY [ * ] OF SHORTINT): ARRAY [ * ] OF SHORTINT; BEGIN ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), MatMulASASLoop, NIL ); RETURN RESULT END "*"; OPERATOR "*"*( CONST left: ARRAY [ * ] OF SHORTINT; CONST right: ARRAY [ * , * ] OF SHORTINT ): ARRAY [ * ] OF SHORTINT; BEGIN ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), MatMulASASLoop, NIL ); RETURN RESULT END "*"; (** INTEGER *) PROCEDURE MatMulAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); VAR lval, rval, dval: INTEGER; BEGIN dval := 0; WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MatMulAIAILoop; OPERATOR "*"*( CONST left, right: ARRAY [ * , * ] OF INTEGER ): ARRAY [ * , * ] OF INTEGER; BEGIN ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), MatMulAIAILoop, NIL ); RETURN RESULT END "*"; OPERATOR "*"*(CONST left: ARRAY [ * , * ] OF INTEGER; CONST right: ARRAY [ * ] OF INTEGER ): ARRAY [ * ] OF INTEGER; BEGIN ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), MatMulAIAILoop, NIL ); RETURN RESULT END "*"; OPERATOR "*"*(CONST left: ARRAY [ * ] OF INTEGER; CONST right: ARRAY [ * , * ] OF INTEGER ): ARRAY [ * ] OF INTEGER; BEGIN ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), MatMulAIAILoop, NIL ); RETURN RESULT END "*"; (** LONGINT *) PROCEDURE MatMulALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); VAR lval, rval, dval: LONGINT; BEGIN dval := 0; WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MatMulALALLoop; OPERATOR "*"*(CONST left, right: ARRAY [ * , * ] OF LONGINT ): ARRAY [ * , * ] OF LONGINT; BEGIN (* KernelLog.String("MatMulALAL"); KernelLog.Int(SYSTEM.VAL(LONGINT,dest),10); KernelLog.Int(SYSTEM.VAL(LONGINT,left),10); KernelLog.Int(SYSTEM.VAL(LONGINT,right),10); KernelLog.Ln; *) ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), MatMulALALLoop, NIL ); RETURN RESULT END "*"; OPERATOR "*"*(CONST left: ARRAY [ * , * ] OF LONGINT; CONST right: ARRAY [ * ] OF LONGINT ): ARRAY [ * ] OF LONGINT; BEGIN ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), MatMulALALLoop, NIL ); RETURN RESULT END "*"; OPERATOR "*"*(CONST left: ARRAY [ * ] OF LONGINT; CONST right: ARRAY [ * , * ] OF LONGINT): ARRAY [ * ] OF LONGINT; BEGIN ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), MatMulALALLoop, NIL ); RETURN RESULT END "*"; (** REAL *) PROCEDURE MatMulARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); VAR lval, rval, dval: REAL; BEGIN dval := 0; WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MatMulARARLoop; (* Optimized for small matrices (Alexey Morozov) use of CONST for left, right makes execution slower, it seems that a new descriptor is created in this case *) OPERATOR "*"*(CONST left, right: ARRAY [ * , * ] OF REAL ): ARRAY [ * , * ] OF REAL; VAR flags: SET; dadr, ladr, radr: LONGINT; BEGIN dadr := GetAdr(ADDRESSOF(RESULT)); ladr := GetAdr(ADDRESSOF(left)); radr := GetAdr(ADDRESSOF(right)); (* account possible inplace left := left*right, right := left*right, left := left*left, right := right*right *) IF (ladr # dadr) & (radr # dadr) THEN flags := SmallArrayMask * SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(left)+MathFlagsOffset)) * SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(right)+MathFlagsOffset)); CASE SYSTEM.VAL(LONGINT,flags) OF Mat2x2: IF SYSTEM.VAL(LONGINT,SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset)) * SmallArrayMask) # Mat2x2 THEN IF dadr = 0 THEN NEW(RESULT,2,2); dadr := GetAdr(ADDRESSOF(RESULT)); ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0); END; END; IF matMulR2x2 # NIL THEN matMulR2x2(dadr,ladr,radr); ELSE RESULT[0,0] := left[0,0]*right[0,0] + left[0,1]*right[1,0]; RESULT[0,1] := left[0,0]*right[0,1] + left[0,1]*right[1,1]; RESULT[1,0] := left[1,0]*right[0,0] + left[1,1]*right[1,0]; RESULT[1,1] := left[1,0]*right[0,1] + left[1,1]*right[1,1]; END; |Mat3x3: IF SYSTEM.VAL(LONGINT,SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset)) * SmallArrayMask) # Mat3x3 THEN IF dadr = 0 THEN NEW(RESULT,3,3);dadr := GetAdr(ADDRESSOF(RESULT)); ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0); END; END; IF matMulR3x3 # NIL THEN matMulR3x3(dadr,ladr,radr); ELSE RESULT[0,0] := left[0,0]*right[0,0] + left[0,1]*right[1,0] + left[0,2]*right[2,0]; RESULT[0,1] := left[0,0]*right[0,1] + left[0,1]*right[1,1] + left[0,2]*right[2,1]; RESULT[0,2] := left[0,0]*right[0,2] + left[0,1]*right[1,2] + left[0,2]*right[2,2]; RESULT[1,0] := left[1,0]*right[0,0] + left[1,1]*right[1,0] + left[1,2]*right[2,0]; RESULT[1,1] := left[1,0]*right[0,1] + left[1,1]*right[1,1] + left[1,2]*right[2,1]; RESULT[1,2] := left[1,0]*right[0,2] + left[1,1]*right[1,2] + left[1,2]*right[2,2]; RESULT[2,0] := left[2,0]*right[0,0] + left[2,1]*right[1,0] + left[2,2]*right[2,0]; RESULT[2,1] := left[2,0]*right[0,1] + left[2,1]*right[1,1] + left[2,2]*right[2,1]; RESULT[2,2] := left[2,0]*right[0,2] + left[2,1]*right[1,2] + left[2,2]*right[2,2]; END; |Mat4x4: IF SYSTEM.VAL(LONGINT,SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset)) * SmallArrayMask) # Mat4x4 THEN IF dadr = 0 THEN NEW(RESULT,4,4); dadr := GetAdr(ADDRESSOF(RESULT)); ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0); END; END; IF matMulR4x4 # NIL THEN matMulR4x4(dadr,ladr,radr); ELSE RESULT[0,0] := left[0,0]*right[0,0] + left[0,1]*right[1,0] + left[0,2]*right[2,0] + left[0,3]*right[3,0]; RESULT[0,1] := left[0,0]*right[0,1] + left[0,1]*right[1,1] + left[0,2]*right[2,1] + left[0,3]*right[3,1]; RESULT[0,2] := left[0,0]*right[0,2] + left[0,1]*right[1,2] + left[0,2]*right[2,2] + left[0,3]*right[3,2]; RESULT[0,3] := left[0,0]*right[0,3] + left[0,1]*right[1,3] + left[0,2]*right[2,3] + left[0,3]*right[3,3]; RESULT[1,0] := left[1,0]*right[0,0] + left[1,1]*right[1,0] + left[1,2]*right[2,0] + left[1,3]*right[3,0]; RESULT[1,1] := left[1,0]*right[0,1] + left[1,1]*right[1,1] + left[1,2]*right[2,1] + left[1,3]*right[3,1]; RESULT[1,2] := left[1,0]*right[0,2] + left[1,1]*right[1,2] + left[1,2]*right[2,2] + left[1,3]*right[3,2]; RESULT[1,3] := left[1,0]*right[0,3] + left[1,1]*right[1,3] + left[1,2]*right[2,3] + left[1,3]*right[3,3]; RESULT[2,0] := left[2,0]*right[0,0] + left[2,1]*right[1,0] + left[2,2]*right[2,0] + left[2,3]*right[3,0]; RESULT[2,1] := left[2,0]*right[0,1] + left[2,1]*right[1,1] + left[2,2]*right[2,1] + left[2,3]*right[3,1]; RESULT[2,2] := left[2,0]*right[0,2] + left[2,1]*right[1,2] + left[2,2]*right[2,2] + left[2,3]*right[3,2]; RESULT[2,3] := left[2,0]*right[0,3] + left[2,1]*right[1,3] + left[2,2]*right[2,3] + left[2,3]*right[3,3]; RESULT[3,0] := left[3,0]*right[0,0] + left[3,1]*right[1,0] + left[3,2]*right[2,0] + left[3,3]*right[3,0]; RESULT[3,1] := left[3,0]*right[0,1] + left[3,1]*right[1,1] + left[3,2]*right[2,1] + left[3,3]*right[3,1]; RESULT[3,2] := left[3,0]*right[0,2] + left[3,1]*right[1,2] + left[3,2]*right[2,2] + left[3,3]*right[3,2]; RESULT[3,3] := left[3,0]*right[0,3] + left[3,1]*right[1,3] + left[3,2]*right[2,3] + left[3,3]*right[3,3]; END; ELSE ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), loopMatMulARAR, matMulR ); END; ELSE ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), loopMatMulARAR, matMulR ); END; RETURN RESULT END "*"; (* Optimized for small arrays (Alexey Morozov) use of CONST for left, right makes execution slower, it seems that a new descriptor is created in this case *) OPERATOR "*"*(CONST left: ARRAY [ * , * ] OF REAL; CONST right: ARRAY [ * ] OF REAL ): ARRAY [ * ] OF REAL; VAR flags: SET; dadr, ladr, radr: LONGINT; v0, v1, v2: REAL; BEGIN dadr := GetAdr(ADDRESSOF(RESULT)); ladr := GetAdr(ADDRESSOF(left)); radr := GetAdr(ADDRESSOF(right)); flags := SmallArrayMask * SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(left)+MathFlagsOffset)) * SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(right)+MathFlagsOffset)); CASE SYSTEM.VAL(LONGINT,flags) OF MatVec2x2: IF SYSTEM.VAL(LONGINT,SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset)) * SmallArrayMask) # Vec2 THEN IF dadr = 0 THEN NEW(RESULT,2);dadr := GetAdr(ADDRESSOF(RESULT)); ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0); END; END; IF matVecMulR2x2 # NIL THEN matVecMulR2x2(dadr,ladr,radr); ELSE (* account possible overlapping *) v0 := right[0]; RESULT[0] := left[0,0]*v0 + left[0,1]*right[1]; RESULT[1] := left[1,0]*v0 + left[1,1]*right[1]; END; |MatVec3x3: IF SYSTEM.VAL(LONGINT,SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset)) * SmallArrayMask) # Vec3 THEN IF dadr = 0 THEN NEW(RESULT,3);dadr := GetAdr(ADDRESSOF(RESULT)); ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0); END; END; IF matVecMulR3x3 # NIL THEN matVecMulR3x3(dadr,ladr,radr); ELSE (* account possible overlapping *) v0 := right[0]; v1 := right[1]; RESULT[0] := left[0,0]*v0 + left[0,1]*v1 + left[0,2]*right[2]; RESULT[1] := left[1,0]*v0 + left[1,1]*v1 + left[1,2]*right[2]; RESULT[2] := left[2,0]*v0 + left[2,1]*v1 + left[2,2]*right[2]; END; |MatVec4x4: IF SYSTEM.VAL(LONGINT,SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset)) * SmallArrayMask) # Vec4 THEN IF dadr = 0 THEN NEW(RESULT,4);dadr := GetAdr(ADDRESSOF(RESULT)); ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0); END; END; IF matVecMulR4x4 # NIL THEN matVecMulR4x4(dadr,ladr,radr); ELSE (* account possible overlapping *) v0 := right[0]; v1 := right[1]; v2 := right[2]; RESULT[0] := left[0,0]*v0 + left[0,1]*v1 + left[0,2]*v2 + left[0,3]*right[3]; RESULT[1] := left[1,0]*v0 + left[1,1]*v1 + left[1,2]*v2 + left[1,3]*right[3]; RESULT[2] := left[2,0]*v0 + left[2,1]*v1 + left[2,2]*v2 + left[2,3]*right[3]; RESULT[3] := left[3,0]*v0 + left[3,1]*v1 + left[3,2]*v2 + left[3,3]*right[3]; END; ELSE ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), loopMatMulARAR, matMulR ); END; RETURN RESULT END "*"; OPERATOR "*"*( CONST left: ARRAY [ * ] OF REAL; CONST right: ARRAY [ * , * ] OF REAL ): ARRAY [ * ] OF REAL; BEGIN ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), loopMatMulARAR, matMulR ); RETURN RESULT END "*"; (** LONGREAL *) PROCEDURE MatMulAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); VAR lval, rval, dval: LONGREAL; BEGIN dval := 0; WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MatMulAXAXLoop; (* Optimized for small matrices (Alexey Morozov) use of CONST for left, right makes execution slower, it seems that a new descriptor is created in this case *) OPERATOR "*"*( CONST left, right: ARRAY [ * , * ] OF LONGREAL): ARRAY [ * , * ] OF LONGREAL; VAR flags: SET; dadr, ladr, radr: LONGINT; BEGIN dadr := GetAdr(ADDRESSOF(RESULT)); ladr := GetAdr(ADDRESSOF(left)); radr := GetAdr(ADDRESSOF(right)); IF (ladr # dadr) & (radr # dadr) THEN flags := SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(left)+MathFlagsOffset)) * SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(right)+MathFlagsOffset)); CASE SYSTEM.VAL(LONGINT,flags) OF Mat2x2: IF SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset) # Mat2x2 THEN IF dadr = 0 THEN NEW(RESULT,2,2); ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0); END; END; IF matMulLR2x2 # NIL THEN matMulLR2x2(dadr,ladr,radr); ELSE RESULT[0,0] := left[0,0]*right[0,0] + left[0,1]*right[1,0]; RESULT[0,1] := left[0,0]*right[0,1] + left[0,1]*right[1,1]; RESULT[1,0] := left[1,0]*right[0,0] + left[1,1]*right[1,0]; RESULT[1,1] := left[1,0]*right[0,1] + left[1,1]*right[1,1]; END; |Mat3x3: IF SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset) # Mat3x3 THEN IF dadr = 0 THEN NEW(RESULT,3,3); ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0); END; END; IF matMulLR3x3 # NIL THEN matMulLR3x3(dadr,ladr,radr); ELSE RESULT[0,0] := left[0,0]*right[0,0] + left[0,1]*right[1,0] + left[0,2]*right[2,0]; RESULT[0,1] := left[0,0]*right[0,1] + left[0,1]*right[1,1] + left[0,2]*right[2,1]; RESULT[0,2] := left[0,0]*right[0,2] + left[0,1]*right[1,2] + left[0,2]*right[2,2]; RESULT[1,0] := left[1,0]*right[0,0] + left[1,1]*right[1,0] + left[1,2]*right[2,0]; RESULT[1,1] := left[1,0]*right[0,1] + left[1,1]*right[1,1] + left[1,2]*right[2,1]; RESULT[1,2] := left[1,0]*right[0,2] + left[1,1]*right[1,2] + left[1,2]*right[2,2]; RESULT[2,0] := left[2,0]*right[0,0] + left[2,1]*right[1,0] + left[2,2]*right[2,0]; RESULT[2,1] := left[2,0]*right[0,1] + left[2,1]*right[1,1] + left[2,2]*right[2,1]; RESULT[2,2] := left[2,0]*right[0,2] + left[2,1]*right[1,2] + left[2,2]*right[2,2]; END; |Mat4x4: IF SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset) # Mat4x4 THEN IF dadr = 0 THEN NEW(RESULT,4,4); ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0); END; END; IF matMulLR4x4 # NIL THEN matMulLR4x4(dadr,ladr,radr); ELSE RESULT[0,0] := left[0,0]*right[0,0] + left[0,1]*right[1,0] + left[0,2]*right[2,0] + left[0,3]*right[3,0]; RESULT[0,1] := left[0,0]*right[0,1] + left[0,1]*right[1,1] + left[0,2]*right[2,1] + left[0,3]*right[3,1]; RESULT[0,2] := left[0,0]*right[0,2] + left[0,1]*right[1,2] + left[0,2]*right[2,2] + left[0,3]*right[3,2]; RESULT[0,3] := left[0,0]*right[0,3] + left[0,1]*right[1,3] + left[0,2]*right[2,3] + left[0,3]*right[3,3]; RESULT[1,0] := left[1,0]*right[0,0] + left[1,1]*right[1,0] + left[1,2]*right[2,0] + left[1,3]*right[3,0]; RESULT[1,1] := left[1,0]*right[0,1] + left[1,1]*right[1,1] + left[1,2]*right[2,1] + left[1,3]*right[3,1]; RESULT[1,2] := left[1,0]*right[0,2] + left[1,1]*right[1,2] + left[1,2]*right[2,2] + left[1,3]*right[3,2]; RESULT[1,3] := left[1,0]*right[0,3] + left[1,1]*right[1,3] + left[1,2]*right[2,3] + left[1,3]*right[3,3]; RESULT[2,0] := left[2,0]*right[0,0] + left[2,1]*right[1,0] + left[2,2]*right[2,0] + left[2,3]*right[3,0]; RESULT[2,1] := left[2,0]*right[0,1] + left[2,1]*right[1,1] + left[2,2]*right[2,1] + left[2,3]*right[3,1]; RESULT[2,2] := left[2,0]*right[0,2] + left[2,1]*right[1,2] + left[2,2]*right[2,2] + left[2,3]*right[3,2]; RESULT[2,3] := left[2,0]*right[0,3] + left[2,1]*right[1,3] + left[2,2]*right[2,3] + left[2,3]*right[3,3]; RESULT[3,0] := left[3,0]*right[0,0] + left[3,1]*right[1,0] + left[3,2]*right[2,0] + left[3,3]*right[3,0]; RESULT[3,1] := left[3,0]*right[0,1] + left[3,1]*right[1,1] + left[3,2]*right[2,1] + left[3,3]*right[3,1]; RESULT[3,2] := left[3,0]*right[0,2] + left[3,1]*right[1,2] + left[3,2]*right[2,2] + left[3,3]*right[3,2]; RESULT[3,3] := left[3,0]*right[0,3] + left[3,1]*right[1,3] + left[3,2]*right[2,3] + left[3,3]*right[3,3]; END; ELSE ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), loopMatMulAXAX, matMulX ); END; ELSE ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), loopMatMulAXAX, matMulX ); END; RETURN RESULT END "*"; (* Optimized for small arrays (Alexey Morozov) use of CONST for left, right makes execution slower, it seems that a new descriptor is created in this case *) OPERATOR "*"*(CONST left: ARRAY [ * , * ] OF LONGREAL; CONST right: ARRAY [ * ] OF LONGREAL ): ARRAY [ * ] OF LONGREAL; VAR flags: SET; dadr, ladr, radr: LONGINT; v0, v1, v2: LONGREAL; BEGIN dadr := GetAdr(ADDRESSOF(RESULT)); ladr := GetAdr(ADDRESSOF(left)); radr := GetAdr(ADDRESSOF(right)); flags := SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(left)+MathFlagsOffset)) * SYSTEM.VAL(SET,SYSTEM.GET32(ADDRESSOF(right)+MathFlagsOffset)); CASE SYSTEM.VAL(LONGINT,flags) OF MatVec2x2: IF SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset) # Vec2 THEN IF dadr = 0 THEN NEW(RESULT,2); ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0); END; END; IF matVecMulLR2x2 # NIL THEN matVecMulLR2x2(dadr,ladr,radr); ELSE (* account possible overlapping *) v0 := right[0]; RESULT[0] := left[0,0]*v0 + left[0,1]*right[1]; RESULT[1] := left[1,0]*v0 + left[1,1]*right[1]; END; |MatVec3x3: IF SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset) # Vec3 THEN IF dadr = 0 THEN NEW(RESULT,3); ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0); END; END; IF matVecMulLR3x3 # NIL THEN matVecMulLR3x3(dadr,ladr,radr); ELSE (* account possible overlapping *) v0 := right[0]; v1 := right[1]; RESULT[0] := left[0,0]*v0 + left[0,1]*v1 + left[0,2]*right[2]; RESULT[1] := left[1,0]*v0 + left[1,1]*v1 + left[1,2]*right[2]; RESULT[2] := left[2,0]*v0 + left[2,1]*v1 + left[2,2]*right[2]; END; |MatVec4x4: IF SYSTEM.GET32(ADDRESSOF(RESULT)+MathFlagsOffset) # Vec4 THEN IF dadr = 0 THEN NEW(RESULT,4); ELSE Halt(GeometryMismatch,ADDRESSOF(left),ADDRESSOF(right),0); END; END; IF matVecMulLR4x4 # NIL THEN matVecMulLR4x4(dadr,ladr,radr); ELSE (* account possible overlapping *) v0 := right[0]; v1 := right[1]; v2 := right[2]; RESULT[0] := left[0,0]*v0 + left[0,1]*v1 + left[0,2]*v2 + left[0,3]*right[3]; RESULT[1] := left[1,0]*v0 + left[1,1]*v1 + left[1,2]*v2 + left[1,3]*right[3]; RESULT[2] := left[2,0]*v0 + left[2,1]*v1 + left[2,2]*v2 + left[2,3]*right[3]; RESULT[3] := left[3,0]*v0 + left[3,1]*v1 + left[3,2]*v2 + left[3,3]*right[3]; END; ELSE ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), loopMatMulAXAX, matMulX ); END; RETURN RESULT END "*"; OPERATOR "*"*( CONST left: ARRAY [ * ] OF LONGREAL; CONST right: ARRAY [ * , * ] OF LONGREAL ): ARRAY [ * ] OF LONGREAL; BEGIN ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), loopMatMulAXAX, matMulX ); RETURN RESULT END "*"; (** SHORTINT *) PROCEDURE MatMulIncASASLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); VAR lval, rval, dval: SHORTINT; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval; (* KernelLog.String("mul with: "); KernelLog.Int(lval,10); KernelLog.Int(rval,10); KernelLog.Ln; *) INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MatMulIncASASLoop; OPERATOR "@MulInc"*(CONST left, right: ARRAY [ * , * ] OF SHORTINT ): ARRAY [ * , * ] OF SHORTINT; BEGIN ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), MatMulIncASASLoop, NIL ); RETURN RESULT END "@MulInc"; OPERATOR "@MulInc"*(CONST left: ARRAY [ * , * ] OF SHORTINT; CONST right: ARRAY [ * ] OF SHORTINT ): ARRAY [ * ] OF SHORTINT; BEGIN ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), MatMulIncASASLoop, NIL ); RETURN RESULT END "@MulInc"; OPERATOR "@MulInc"*( CONST left: ARRAY [ * ] OF SHORTINT; CONST right: ARRAY [ * , * ] OF SHORTINT ): ARRAY [ * ] OF SHORTINT; BEGIN ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), MatMulIncASASLoop, NIL ); RETURN RESULT END "@MulInc"; OPERATOR "@MulDec"*(CONST left, right: ARRAY [ * , * ] OF SHORTINT ): ARRAY [ * , * ] OF SHORTINT; BEGIN RESULT := -RESULT; ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), MatMulIncASASLoop, NIL ); RESULT := -RESULT; RETURN RESULT END "@MulDec"; OPERATOR "@MulDec"*(CONST left: ARRAY [ * , * ] OF SHORTINT; CONST right: ARRAY [ * ] OF SHORTINT ): ARRAY [ * ] OF SHORTINT; BEGIN RESULT := -RESULT; ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), MatMulIncASASLoop, NIL ); RESULT := -RESULT; RETURN RESULT END "@MulDec"; OPERATOR "@MulDec"*( CONST left: ARRAY [ * ] OF SHORTINT; CONST right: ARRAY [ * , * ] OF SHORTINT ): ARRAY [ * ] OF SHORTINT; BEGIN RESULT := -RESULT; ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), MatMulIncASASLoop, NIL ); RESULT := -RESULT; RETURN RESULT END "@MulDec"; (** INTEGER *) PROCEDURE MatMulIncAIAILoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); VAR lval, rval, dval: INTEGER; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MatMulIncAIAILoop; OPERATOR "@MulInc"*(CONST left, right: ARRAY [ * , * ] OF INTEGER ): ARRAY [ * , * ] OF INTEGER; BEGIN ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), MatMulIncAIAILoop, NIL ); RETURN RESULT END "@MulInc"; OPERATOR "@MulInc"*(CONST left: ARRAY [ * , * ] OF INTEGER; CONST right: ARRAY [ * ] OF INTEGER): ARRAY [ * ] OF INTEGER; BEGIN ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), MatMulIncAIAILoop, NIL ); RETURN RESULT END "@MulInc"; OPERATOR "@MulInc"*( CONST left: ARRAY [ * ] OF INTEGER; CONST right: ARRAY [ * , * ] OF INTEGER ): ARRAY [ * ] OF INTEGER; BEGIN ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), MatMulIncAIAILoop, NIL ); RETURN RESULT END "@MulInc"; OPERATOR "@MulDec"*(CONST left, right: ARRAY [ * , * ] OF INTEGER ): ARRAY [ * , * ] OF INTEGER; BEGIN RESULT := -RESULT; ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), MatMulIncAIAILoop, NIL ); RESULT := -RESULT; RETURN RESULT END "@MulDec"; OPERATOR "@MulDec"*( CONST left: ARRAY [ * , * ] OF INTEGER; CONST right: ARRAY [ * ] OF INTEGER ): ARRAY [ * ] OF INTEGER; BEGIN RESULT := -RESULT; ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), MatMulIncAIAILoop, NIL ); RESULT := -RESULT; RETURN RESULT END "@MulDec"; OPERATOR "@MulDec"*( CONST left: ARRAY [ * ] OF INTEGER; CONST right: ARRAY [ * , * ] OF INTEGER ): ARRAY [ * ] OF INTEGER; BEGIN RESULT := -RESULT; ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), MatMulIncAIAILoop, NIL ); RESULT := -RESULT; RETURN RESULT END "@MulDec"; (** LONGINT *) PROCEDURE MatMulIncALALLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); VAR lval, rval, dval: LONGINT; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MatMulIncALALLoop; OPERATOR "@MulInc"*(CONST left, right: ARRAY [ * , * ] OF LONGINT ): ARRAY [ * , * ] OF LONGINT; BEGIN ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), MatMulIncALALLoop, NIL ); RETURN RESULT END "@MulInc"; OPERATOR "@MulInc"*(CONST left: ARRAY [ * , * ] OF LONGINT; CONST right: ARRAY [ * ] OF LONGINT ): ARRAY [ * ] OF LONGINT; BEGIN ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), MatMulIncALALLoop, NIL ); RETURN RESULT END "@MulInc"; OPERATOR "@MulInc"*( CONST left: ARRAY [ * ] OF LONGINT; CONST right: ARRAY [ * , * ] OF LONGINT ): ARRAY [ * ] OF LONGINT; BEGIN ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), MatMulIncALALLoop, NIL ); RETURN RESULT END "@MulInc"; OPERATOR "@MulDec"*( CONST left, right: ARRAY [ * , * ] OF LONGINT ): ARRAY [ * , * ] OF LONGINT; BEGIN RESULT := -RESULT; ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), MatMulIncALALLoop, NIL ); RESULT := -RESULT; RETURN RESULT END "@MulDec"; OPERATOR "@MulDec"*(CONST left: ARRAY [ * , * ] OF LONGINT; CONST right: ARRAY [ * ] OF LONGINT ): ARRAY [ * ] OF LONGINT; BEGIN RESULT := -RESULT; ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), MatMulIncALALLoop, NIL ); RESULT := -RESULT; RETURN RESULT END "@MulDec"; OPERATOR "@MulDec"*(CONST left: ARRAY [ * ] OF LONGINT; CONST right: ARRAY [ * , * ] OF LONGINT ): ARRAY [ * ] OF LONGINT; BEGIN RESULT := -RESULT; ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), MatMulIncALALLoop, NIL ); RESULT := -RESULT; RETURN RESULT END "@MulDec"; (** REAL *) PROCEDURE MatMulIncARARLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); VAR lval, rval, dval: REAL; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MatMulIncARARLoop; OPERATOR "@MulInc"*(CONST left, right: ARRAY [ * , * ] OF REAL ): ARRAY [ * , * ] OF REAL; BEGIN ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), loopMatMulIncARAR, matMulIncR ); RETURN RESULT END "@MulInc"; OPERATOR "@MulInc"*(CONST left: ARRAY [ * , * ] OF REAL;CONST right: ARRAY [ * ] OF REAL ): ARRAY [ * ] OF REAL; BEGIN ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), loopMatMulIncARAR, matMulIncR ); RETURN RESULT END "@MulInc"; OPERATOR "@MulInc"*( CONST left: ARRAY [ * ] OF REAL; CONST right: ARRAY [ * , * ] OF REAL ): ARRAY [ * ] OF REAL; BEGIN ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), loopMatMulIncARAR, matMulIncR ); RETURN RESULT END "@MulInc"; OPERATOR "@MulDec"*(CONST left, right: ARRAY [ * , * ] OF REAL ): ARRAY [ * , * ] OF REAL; BEGIN RESULT := -RESULT; ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), loopMatMulIncARAR, matMulIncR ); RESULT := -RESULT; RETURN RESULT END "@MulDec"; OPERATOR "@MulDec"*( CONST left: ARRAY [ * , * ] OF REAL; CONST right: ARRAY [ * ] OF REAL ): ARRAY [ * ] OF REAL; BEGIN RESULT := -RESULT; ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), loopMatMulIncARAR, matMulIncR ); RESULT := -RESULT; RETURN RESULT END "@MulDec"; OPERATOR "@MulDec"*(CONST left: ARRAY [ * ] OF REAL; CONST right: ARRAY [ * , * ] OF REAL ): ARRAY [ * ] OF REAL; BEGIN RESULT := -RESULT; ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), loopMatMulIncARAR, matMulIncR ); RESULT := -RESULT; RETURN RESULT END "@MulDec"; (** LONGREAL *) PROCEDURE MatMulIncAXAXLoop( ladr, radr, dadr: ADDRESS; linc, rinc, len: SIZE ); VAR lval, rval, dval: LONGREAL; BEGIN SYSTEM.GET( dadr, dval ); WHILE (len > 0) DO SYSTEM.GET( ladr, lval ); SYSTEM.GET( radr, rval ); dval := dval + lval * rval; INC( ladr, linc ); INC( radr, rinc ); DEC( len ); END; SYSTEM.PUT( dadr, dval ); END MatMulIncAXAXLoop; OPERATOR "@MulInc"*(CONST left, right: ARRAY [ * , * ] OF LONGREAL ): ARRAY [ * , * ] OF LONGREAL; BEGIN ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), loopMatMulIncAXAX, matMulIncX ); RETURN RESULT END "@MulInc"; OPERATOR "@MulInc"*(CONST left: ARRAY [ * , * ] OF LONGREAL; CONST right: ARRAY [ * ] OF LONGREAL ): ARRAY [ * ] OF LONGREAL; BEGIN ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), loopMatMulIncAXAX, matMulIncX ); RETURN RESULT END "@MulInc"; OPERATOR "@MulInc"*( CONST left: ARRAY [ * ] OF LONGREAL; CONST right: ARRAY [ * , * ] OF LONGREAL ): ARRAY [ * ] OF LONGREAL; BEGIN ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), loopMatMulIncAXAX, matMulIncX ); RETURN RESULT END "@MulInc"; OPERATOR "@MulDec"*(CONST left, right: ARRAY [ * , * ] OF LONGREAL ): ARRAY [ * , * ] OF LONGREAL; BEGIN RESULT := -RESULT; ApplyMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), loopMatMulIncAXAX, matMulIncX ); RESULT := -RESULT; RETURN RESULT END "@MulDec"; OPERATOR "@MulDec"*( CONST left: ARRAY [ * , * ] OF LONGREAL; CONST right: ARRAY [ * ] OF LONGREAL ): ARRAY [ * ] OF LONGREAL; BEGIN RESULT := -RESULT; ApplyMatVecMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), loopMatMulIncAXAX, matMulIncX ); RESULT := -RESULT; RETURN RESULT END "@MulDec"; OPERATOR "@MulDec"*( CONST left: ARRAY [ * ] OF LONGREAL; CONST right: ARRAY [ * , * ] OF LONGREAL ): ARRAY [ * ] OF LONGREAL; BEGIN RESULT := -RESULT; ApplyVecMatMulLoop( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), loopMatMulIncAXAX, matMulIncX ); RESULT := -RESULT; RETURN RESULT END "@MulDec"; (*** Cross product ********************************************************************) OPERATOR "*"*(CONST left, right: ARRAY [ * ] OF SHORTINT ): ARRAY [ * ] OF SHORTINT; VAR vl1, vl2, vl3, vr1, vr2, vr3: SHORTINT; BEGIN IF (LEN( left,0 ) # 3) OR (LEN( right,0 ) # 3) THEN Halt( GeometryMismatch, ADDRESSOF( left ), ADDRESSOF( right ), 0 ) END; IF LEN( RESULT,0 ) # 3 THEN NEW( RESULT, 3 ) END; (* will trap if not allowed *) vl1 := left[0]; vl2 := left[1]; vl3 := left[2]; vr1 := right[0]; vr2 := right[1]; vr3 := right[2]; RESULT[0] := vl2 * vr3 - vl3 * vr2; RESULT[1] := vl3 * vr1 - vl1 * vr3; RESULT[2] := vl1 * vr2 - vl2 * vr1; RETURN RESULT END "*"; OPERATOR "*"*(CONST left, right: ARRAY [ * ] OF INTEGER ): ARRAY [ * ] OF INTEGER; VAR vl1, vl2, vl3, vr1, vr2, vr3: INTEGER; BEGIN IF (LEN( left,0 ) # 3) OR (LEN( right,0 ) # 3) THEN Halt( GeometryMismatch, ADDRESSOF( left ), ADDRESSOF( right ), 0 ) END; IF LEN( RESULT,0 ) # 3 THEN NEW( RESULT, 3 ) END; (* will trap if not allowed *) vl1 := left[0]; vl2 := left[1]; vl3 := left[2]; vr1 := right[0]; vr2 := right[1]; vr3 := right[2]; RESULT[0] := vl2 * vr3 - vl3 * vr2; RESULT[1] := vl3 * vr1 - vl1 * vr3; RESULT[2] := vl1 * vr2 - vl2 * vr1; RETURN RESULT END "*"; OPERATOR "*"*(CONST left, right: ARRAY [ * ] OF LONGINT ): ARRAY [ * ] OF LONGINT; VAR vl1, vl2, vl3, vr1, vr2, vr3: LONGINT; BEGIN IF (LEN( left,0 ) # 3) OR (LEN( right,0 ) # 3) THEN Halt( GeometryMismatch, ADDRESSOF( left ), ADDRESSOF( right ), 0 ) END; IF LEN( RESULT,0 ) # 3 THEN NEW( RESULT, 3 ) END; (* will trap if not allowed *) vl1 := left[0]; vl2 := left[1]; vl3 := left[2]; vr1 := right[0]; vr2 := right[1]; vr3 := right[2]; RESULT[0] := vl2 * vr3 - vl3 * vr2; RESULT[1] := vl3 * vr1 - vl1 * vr3; RESULT[2] := vl1 * vr2 - vl2 * vr1; RETURN RESULT END "*"; OPERATOR "*"*(CONST left, right: ARRAY [ * ] OF REAL ): ARRAY [ * ] OF REAL; VAR vl1, vl2, vl3, vr1, vr2, vr3: REAL; BEGIN IF (LEN( left,0 ) # 3) OR (LEN( right,0 ) # 3) THEN Halt( GeometryMismatch, ADDRESSOF( left ), ADDRESSOF( right ), 0 ) END; IF LEN( RESULT,0 ) # 3 THEN NEW( RESULT, 3 ) END; (* will trap if not allowed *) vl1 := left[0]; vl2 := left[1]; vl3 := left[2]; vr1 := right[0]; vr2 := right[1]; vr3 := right[2]; RESULT[0] := vl2 * vr3 - vl3 * vr2; RESULT[1] := vl3 * vr1 - vl1 * vr3; RESULT[2] := vl1 * vr2 - vl2 * vr1; RETURN RESULT END "*"; OPERATOR "*"*(CONST left, right: ARRAY [ * ] OF LONGREAL ): ARRAY [ * ] OF LONGREAL; VAR vl1, vl2, vl3, vr1, vr2, vr3: LONGREAL; BEGIN IF (LEN( left,0 ) # 3) OR (LEN( right,0 ) # 3) THEN Halt( GeometryMismatch, ADDRESSOF( left ), ADDRESSOF( right ), 0 ) END; IF LEN( RESULT,0 ) # 3 THEN NEW( RESULT, 3 ) END; (* will trap if not allowed *) vl1 := left[0]; vl2 := left[1]; vl3 := left[2]; vr1 := right[0]; vr2 := right[1]; vr3 := right[2]; RESULT[0] := vl2 * vr3 - vl3 * vr2; RESULT[1] := vl3 * vr1 - vl1 * vr3; RESULT[2] := vl1 * vr2 - vl2 * vr1; RETURN RESULT END "*"; (** Transpose ********************************************************************) PROCEDURE Overlap( src1, src2: ADDRESS ): BOOLEAN; VAR from1, from2, to1, to2: ADDRESS; dim: LONGINT; BEGIN from1 := GetAdr( src1 ); from2 := GetAdr( src2 ); to1 := from1; to2 := from2; dim := GetDim( src1 ) - 1; WHILE (dim > 0) DO to1 := to1 + (GetLen( src1, dim ) - 1) * GetIncr( src1, dim ); DEC( dim ); END; dim := GetDim( src2 ) - 1; WHILE (dim > 0) DO to2 := to2 + (GetLen( src2, dim ) - 1) * GetIncr( src2, dim ); DEC( dim ); END; IF from1 < from2 THEN RETURN to1 >= from2; ELSIF from2 < from1 THEN RETURN to2 >= from1; ELSE RETURN TRUE; END; END Overlap; (* PROCEDURE Overlap( src1, src2, dim: ADDRESS ): BOOLEAN; VAR from1, from2, to1, to2: ADDRESS; BEGIN from1 := GetAdr( src1 ); from2 := GetAdr( src2 ); to1 := from1; to2 := from2; DEC( dim ); WHILE (dim > 0) DO to1 := to1 + (GetLen( src1, dim ) - 1) * GetIncr( src1, dim ); to2 := to2 + (GetLen( src2, dim ) - 1) * GetIncr( src2, dim ); DEC( dim ); END; IF from1 < from2 THEN RETURN to1 >= from2; ELSIF from2 < from1 THEN RETURN to2 >= from1; ELSE RETURN TRUE; END; END Overlap; *) PROCEDURE AllocateTransposed( VAR dest: ADDRESS; src: ADDRESS; elementsize: SIZE ): ANY; VAR ptr, data: ANY; Size: LONGINT; (* allocate a structure in dest compatible with src, if necessary. returns if allocation has taken place *) PROCEDURE TransposedShape( l, r: LONGINT ): BOOLEAN; VAR dim,max: LONGINT; BEGIN dim := GetDim( l ); IF dim # GetDim( r ) THEN RETURN FALSE END; max := dim-1; WHILE (dim > 0) DO DEC( dim ); IF GetLen( l, max-dim ) # GetLen( r, dim ) THEN RETURN FALSE END; END; RETURN TRUE; END TransposedShape; PROCEDURE UseDescriptor; VAR tag: LONGINT; BEGIN SYSTEM.GET( src - 4, tag ); Heaps.NewRec( ptr, tag, FALSE ); dest := SYSTEM.VAL( LONGINT, ptr ); END UseDescriptor; PROCEDURE NewData; VAR max,dim, len, size: LONGINT; BEGIN dim := GetDim( src ); size := elementsize; PutDim( dest, dim ); PutSize( dest, elementsize ); max := dim-1; WHILE (dim > 0) DO DEC( dim ); len := GetLen( src, max-dim ); PutLen( dest, dim, len ); PutInc( dest, dim, size ); size := size * len; END; SYSTEM.NEW( data, size ); PutAdr( dest, data ); PutPtr( dest, data ); END NewData; BEGIN IF dest # 0 THEN Size := GetSize( dest ); ASSERT( Size = elementsize ); END; IF debug THEN KernelLog.String( "Allocate same " ); Report( "allocation source", src ); Report( "allocation des", dest ); END; IF dest = 0 THEN (* NIL pointer, guaranteed to be tensor *) IF TensorFlag IN GetFlags( src ) THEN UseDescriptor(); ELSE ptr := GetArrayDesc( GetDim( src ) ); dest := SYSTEM.VAL( LONGINT, ptr ); END; PutFlags(dest, {TensorFlag}); NewData(); RETURN ptr; ELSIF GetDim( dest ) # GetDim( src ) THEN (* different dimension *) (* check if re-allocation of descriptor is allowed *) IF ~(TensorFlag IN GetFlags( dest )) & ~(TemporaryFlag IN GetFlags( dest )) THEN (* no, not allowed*) HALT( 100 ); END; UseDescriptor(); PutFlags(dest, {TensorFlag}); NewData(); RETURN ptr; ELSIF (GetAdr( dest ) = 0) OR ~TransposedShape( dest, src ) THEN (* check if re-allocation of array data is allowed *) IF RangeFlag IN GetFlags( dest ) THEN (* no! not allowed *) HALT( 100 ); END; NewData(); RETURN data; ELSE (* nothing to do *) RETURN NIL; END; END AllocateTransposed; PROCEDURE Transpose*( dest, left: ADDRESS; Size: LONGINT ); VAR len0, len1, linc0, linc1, dinc0, dinc1, ladr, dadr: LONGINT; p: ANY; PROCEDURE CopyLoop( src, dest, srcinc, destinc, len: LONGINT ); BEGIN WHILE (len > 0) DO SYSTEM.MOVE( src, dest, Size ); INC( src, srcinc ); INC( dest, destinc ); DEC( len ); END; END CopyLoop; BEGIN IF TemporaryFlag IN GetFlags( dest ) THEN (* destination is on the stack: can optimize transposition *) PutAdr( dest, GetAdr( left ) ); PutPtr( dest, GetPtr( left ) ); PutLen( dest, 1, GetLen( left, 0 ) ); PutLen( dest, 0, GetLen( left, 1 ) ); PutInc( dest, 1, GetIncr( left, 0 ) ); PutInc( dest, 0, GetIncr( left, 1 ) ); ELSE len0 := GetLen( left, 0 ); len1 := GetLen( left, 1 ); p := AllocateTransposed(dest,left,Size); IF Overlap( left, dest ) THEN (* copy data first, then transpose *) SYSTEM.NEW( p, len0 * len1 * Size ); dinc0 := Size; dinc1 := len0 * Size; dadr := SYSTEM.VAL( LONGINT, p ); linc0 := GetIncr( left, 0 ); linc1 := GetIncr( left, 1 ); ladr := GetAdr( left ); WHILE (len0 > 0) DO CopyLoop( ladr, dadr, linc1, dinc1, len1 ); INC( ladr, linc0 ); INC( dadr, dinc0 ); DEC( len0 ); END; len0 := GetLen( left, 0 ); linc0 := Size; linc1 := len0 * Size; ladr := SYSTEM.VAL( LONGINT, p ); ELSE linc0 := GetIncr( left, 0 ); linc1 := GetIncr( left, 1 ); ladr := GetAdr( left ); END; dinc0 := GetIncr( dest, 0 ); dinc1 := GetIncr( dest, 1 ); dadr := GetAdr( dest ); IF (Size = 4) & (transpose4 # NIL ) THEN transpose4( ladr, dadr, linc0, linc1, dinc0, dinc1, len0, len1 ); ELSIF (Size = 8) & (transpose8 # NIL ) THEN transpose8( ladr, dadr, linc0, linc1, dinc0, dinc1, len0, len1 ); ELSE WHILE (len0 > 0) DO CopyLoop( ladr, dadr, linc1, dinc0, len1 ); INC( ladr, linc0 ); INC( dadr, dinc1 ); DEC( len0 ); END; END; END; END Transpose; OPERATOR "`"*(CONST left: ARRAY [ * , * ] OF SHORTINT): ARRAY [ * , * ] OF SHORTINT; BEGIN Transpose( ADDRESSOF( RESULT ), ADDRESSOF( left ), SIZEOF( SHORTINT ) ); RETURN RESULT END "`"; OPERATOR "`"*( CONST left: ARRAY [ * , * ] OF INTEGER ):ARRAY [ * , * ] OF INTEGER ; BEGIN Transpose( ADDRESSOF( RESULT ), ADDRESSOF( left ), SIZEOF( INTEGER ) ); RETURN RESULT END "`"; OPERATOR "`"*( CONST left: ARRAY [ * , * ] OF LONGINT ): ARRAY [ * , * ] OF LONGINT; BEGIN Transpose( ADDRESSOF( RESULT ), ADDRESSOF( left ), SIZEOF( LONGINT ) ); RETURN RESULT END "`"; OPERATOR "`"*( CONST left: ARRAY [ * , * ] OF REAL ): ARRAY [ * , * ] OF REAL; BEGIN Transpose( ADDRESSOF( RESULT ), ADDRESSOF( left ), SIZEOF( REAL ) ); RETURN RESULT END "`"; OPERATOR "`"*( CONST left: ARRAY [ * , * ] OF LONGREAL ): ARRAY [ * , * ] OF LONGREAL; BEGIN Transpose( ADDRESSOF( RESULT ), ADDRESSOF( left ), SIZEOF( LONGREAL ) ); RETURN RESULT END "`"; PROCEDURE CheckTensorGeometry( left, right, dest: ADDRESS; ldim, rdim: LONGINT ): BOOLEAN; VAR i: LONGINT; BEGIN FOR i := 0 TO rdim - 1 DO IF GetLen( right, i ) # GetLen( dest, i ) THEN RETURN FALSE END; END; FOR i := 0 TO ldim - 1 DO IF GetLen( left, i ) # GetLen( dest, rdim + i ) THEN RETURN FALSE END; END; RETURN TRUE; END CheckTensorGeometry; (* PROCEDURE Zero(p: ANY; size: LONGINT); VAR adr: LONGINT; BEGIN adr := SYSTEM.VAL(LONGINT,p); WHILE(size>0) DO SYSTEM.PUT8(adr,0); DEC(size);INC(adr); END; END Zero; *) PROCEDURE DoReshape*( VAR dest: LONGINT; src: LONGINT; CONST shape: ARRAY [ * ] OF LONGINT ); VAR i, Size: LONGINT; ptr, data: ANY; new: LONGINT; oldSize, newSize: LONGINT; oldDim, newDim: LONGINT; squeezingReshape: BOOLEAN; PROCEDURE NewDescriptor; BEGIN ptr := GetArrayDesc( newDim ); new := SYSTEM.VAL( LONGINT, ptr ); END NewDescriptor; (* Added by Alexey Returns TRUE if the new shape is the result of squeezing (removing of singleton dimensions) *) PROCEDURE SqueezingReshape(): BOOLEAN; VAR i, j, n: LONGINT; BEGIN IF oldDim > newDim THEN i := 0; j := 0; WHILE (i < oldDim) & (j < newDim) DO n := GetLen(src,i); IF n = shape[j] THEN INC(j); END; INC(i); END; WHILE (i < oldDim) & (GetLen(src,i) = 1) DO INC(i); END; (* account for a trailing sequence of 1 *) ELSE squeezingReshape := FALSE; END; squeezingReshape := (i = oldDim) & (j = newDim); RETURN squeezingReshape; END SqueezingReshape; (*returns TRUE if the target is already allocated coninuous memory of correct length*) PROCEDURE TargetContinuous(): BOOLEAN; VAR i, n: LONGINT; continue: BOOLEAN; BEGIN i := GetDim(dest)-1; n := GetIncr(dest,i); continue := TRUE; WHILE (i > 0) & continue DO n := n * GetLen(dest,i); DEC(i); continue := GetIncr(dest,i) = n; END; (*TRACE(i,continue,Size,GetSize(dest));*) (*tod obviously size is not what I expect it to be*) IF (i = 0) & continue & (Size=GetSize(dest)) THEN (* destination array is continuous memory of the proper lenght *) RETURN TRUE; ELSE RETURN FALSE; END; END TargetContinuous; (* returns TRUE if reshape preserves contiguity pattern and thus is valid even for subranged arrays *) PROCEDURE PreservesContiguity(): BOOLEAN; VAR i, n: LONGINT; continue: BOOLEAN; BEGIN i := oldDim-1; n := GetIncr(src,i); continue := TRUE; WHILE (i > 0) & continue DO n := n * GetLen(src,i); DEC(i); continue := GetIncr(src,i) = n; END; IF (i = 0) & continue THEN (* array can be fully linearized and, therefore, can be reshaped to any size *) RETURN TRUE; ELSE Err("Not yet implemented!"); END; END PreservesContiguity; (* Added by Alexey *) PROCEDURE NewDescriptorForSameData; VAR len, size, i, j: LONGINT; BEGIN ptr := GetArrayDesc( newDim ); new := SYSTEM.VAL( LONGINT, ptr ); IF ~squeezingReshape THEN size := Size; FOR i := newDim - 1 TO 0 BY -1 DO len := shape[i]; PutInc( new, i, size ); PutLen( new, i, len ); size := size * len; END; ELSE (* squeezing reshape *) j := 0; len := shape[j]; FOR i := 0 TO oldDim-1 DO IF GetLen(src,i) = len THEN PutInc(new,j,GetIncr(src,i)); PutLen(new,j,len); INC(j); IF j < newDim THEN len := shape[j]; END; END; END; END; IF RangeFlag IN GetFlags(src) THEN (* keep range awareness for case of squeezing reshape and preservation of contiguity *) PutFlags(new,GetFlags(new)+{RangeFlag}); END; PutAdr( new, GetAdr(src) ); PutPtr( new, GetPtr(src) ); PutDim( new, newDim ); PutSize( new, Size ); END NewDescriptorForSameData; PROCEDURE NewData; VAR len, size, i: LONGINT; BEGIN size := Size; FOR i := newDim - 1 TO 0 BY -1 DO len := shape[i]; PutInc( new, i, size ); PutLen( new, i, len ); size := size * len; END; SYSTEM.NEW( data, size ); (* Zero(data,size*Size); *) PutAdr( new, data ); PutPtr( new, data ); PutDim( new, newDim ); PutSize( new, Size ); END NewData; PROCEDURE CopyData; VAR d, s, dadr: LONGINT; PROCEDURE Loop( dim: LONGINT; sadr: LONGINT ); VAR inc, len, i: LONGINT; BEGIN IF dim = d THEN inc := GetIncr( src, dim ); len := GetLen( src, dim ); FOR i := 0 TO len - 1 DO SYSTEM.MOVE( sadr, dadr, s ); INC( dadr, s ); INC( sadr, inc ); END; ELSE inc := GetIncr( src, dim ); len := GetLen( src, dim ); INC( dim ); FOR i := 0 TO len - 1 DO Loop( dim, sadr ); INC( sadr, inc ); END; END; END Loop; BEGIN s := Size; ASSERT( GetSize( src ) = s ); d := GetDim( src ) - 1; WHILE (d >= 0) & (GetIncr( src, d ) = s) DO s := s * GetLen( src, d ); DEC( d ); END; IF d = -1 THEN (* special case: both continuous *) SYSTEM.MOVE( GetAdr( src ), GetAdr( new ), s ); ELSE dadr := GetAdr( new ); Loop( 0, GetAdr( src ) ); END; END CopyData; PROCEDURE CopyDataBack; VAR d, s: LONGINT; sadr: LONGINT; PROCEDURE Loop( dim: LONGINT; dadr: LONGINT ); VAR inc, len, i: LONGINT; BEGIN IF dim = d THEN inc := GetIncr( dest, dim ); len := GetLen( dest, dim ); FOR i := 0 TO len - 1 DO SYSTEM.MOVE( sadr, dadr, s ); INC( dadr, inc ); INC( sadr, s ); END; ELSE inc := GetIncr( dest, dim ); len := GetLen( dest, dim ); INC( dim ); FOR i := 0 TO len - 1 DO Loop( dim, dadr ); INC( dadr, inc ); END; END; END Loop; BEGIN s := Size; ASSERT( GetSize( dest ) = s ); d := GetDim( dest ) - 1; WHILE (d >= 0) & (GetIncr( dest, d ) = s) DO s := s * GetLen( dest, d ); DEC( d ); END; IF d = -1 THEN (* special case: both continuous *) SYSTEM.MOVE( GetAdr( new ), GetAdr( dest ), s ); ELSE sadr := GetAdr( new ); Loop( 0, GetAdr( dest ) ); END; END CopyDataBack; PROCEDURE CopyDescriptor( src, dest: LONGINT ); BEGIN ASSERT( GetDim( src ) = GetDim( dest ) ); SYSTEM.MOVE( src, dest, MathLenOffset + GetDim( src ) * 8 ); END CopyDescriptor; PROCEDURE ShapeDiffers( ): BOOLEAN; VAR i: LONGINT; BEGIN ASSERT(GetDim(dest) = newDim); FOR i := 0 TO newDim - 1 DO IF GetLen(dest,i) # shape[i] THEN RETURN TRUE END; END; RETURN FALSE; END ShapeDiffers; BEGIN (* cases 1.) descriptor may be replaced = dimension may vary: dest = TENSOR 2.) descriptor may be reshaped: dest = ARRAY but no RANGE 3.) descriptor may not be reshaped: dest = RANGE *) (* first check invariants *) oldDim := GetDim( src ); IF oldDim = 0 THEN oldSize := 0 ELSE oldSize := 1; FOR i := 0 TO oldDim - 1 DO oldSize := oldSize * GetLen( src, i ); END; END; newDim := LEN( shape, 0 ); IF newDim = 0 THEN newSize := 0 ELSE newSize := 1; FOR i := 0 TO newDim - 1 DO newSize := newSize * shape[i]; END; END; IF oldSize # newSize THEN Err( "RESHAPE: Total length mismatch" ); END; Size := GetSize( src ); ASSERT( (Size > 0) & (Size < 128) ); (*! heuristic, remove upper bound *) IF dest = src THEN (* added by Alexey *) IF ~(RangeFlag IN GetFlags(dest)) OR PreservesContiguity() OR SqueezingReshape() THEN NewDescriptorForSameData; dest := new; ELSIF ((newDim = oldDim) & ~ShapeDiffers()) THEN (* create a copy of the original descriptor *) ptr := GetArrayDesc(newDim); dest := SYSTEM.VAL(LONGINT,ptr); CopyDescriptor(src,dest); ELSE Err( "RESHAPE: given RANGE array can not be reshaped!" ); END; ELSIF (dest = 0) THEN (* is tensor for sure *) NewDescriptor; NewData; CopyData; dest := new; ELSIF TargetContinuous() THEN NewDescriptor; new:=dest; CopyData; (*todo: check if target continous memory of correct size, if so don't allocate memory*) ELSIF (newDim # GetDim( dest )) THEN (* must be tensor *) IF ~(TensorFlag IN GetFlags( dest )) THEN (* no, not allowed*) Err( "RESHAPE: new dimension only allowed for TENSOR" ); END; NewDescriptor; NewData; CopyData; dest := new; ELSIF ShapeDiffers() THEN (* same dim but shape of destination does not match *) IF RangeFlag IN GetFlags( dest ) THEN Err( "RESHAPE: new shape not allowed for RANGE" ); END; NewDescriptor; NewData; CopyData; CopyDescriptor( new, dest ); ELSIF ~SameShape( src, dest ) THEN (* shape for destination matches but that of src is different *) NewDescriptor; NewData; CopyData; CopyDataBack; ELSE (* same shape, just copy *) CopyContent( src, dest, Size ); RETURN; END; END DoReshape; PROCEDURE AllocateTensorA*( CONST a: ARRAY OF SIZE; elementSize: SIZE; tag: ADDRESS; VAR dest: UnsafeArray ); VAR descr, data: ANY; same: BOOLEAN; i: LONGINT; dim: LONGINT; PROCEDURE NewData; VAR len, size, i: SIZE; BEGIN size := elementSize; FOR i := dim - 1 TO 0 BY -1 DO len := a[i]; PutInc( dest, i, size ); PutLen( dest, i, len ); size := size * len; END; IF tag = 0 THEN SYSTEM.NEW( data, size ); (* Zero(data,size*Size); *) PutAdr( dest, data ); ELSE Heaps.NewArr(data, tag, size DIV elementSize,1,FALSE); PutAdr(dest, data + ArrDataArrayOffset); END; PutPtr( dest, data ); PutSize( dest, elementSize ); END NewData; PROCEDURE ClearData; (*! todo *) END ClearData; BEGIN dim := LEN( a,0 ); IF (dest = 0) OR (dim # GetDim( dest )) THEN IF dest # 0 THEN IF (~(TensorFlag IN GetFlags( dest ))) THEN Err( "Array's number of dimension must not be modified (no TENSOR !)" ); END; END; descr := GetArrayDesc( LEN( a,0 ) ); dest := descr; NewData; ELSE i := 0; WHILE (i < dim) & same DO IF GetLen( dest, i ) # a[i] THEN same := FALSE; END; INC( i ); END; IF ~same THEN IF (RangeFlag IN GetFlags( dest )) THEN Err( "Array's shape must not be modified (is RANGE !) " ); END; NewData ELSE ClearData END; END; END AllocateTensorA; PROCEDURE AllocateArrayA*( CONST a: ARRAY OF SIZE; elementSize: SIZE; tag: ADDRESS; dest: UnsafeArray ); BEGIN AllocateTensorA(a,elementSize,tag,dest); END AllocateArrayA; PROCEDURE AllocateTensorX*( VAR destA: ARRAY [?]; CONST a: ARRAY [ * ] OF LONGINT; Size: SIZE; tag: ADDRESS ); VAR descr, data: ANY; same: BOOLEAN; i: LONGINT; dim: SIZE; dest: ADDRESS; PROCEDURE NewData; VAR len, size: SIZE; i: LONGINT; BEGIN size := Size; FOR i := dim - 1 TO 0 BY -1 DO len := a[i]; (* KernelLog.Int(len,10); KernelLog.Ln; *) PutInc( dest, i, size ); PutLen( dest, i, len ); size := size * len; END; IF tag = 0 THEN SYSTEM.NEW( data, size ); (* Zero(data,size*Size); *) PutAdr( dest, data ); ELSE Heaps.NewArr(data, tag, size DIV Size,1,FALSE); PutAdr( dest, data+ ArrDataArrayOffset ); END; PutPtr( dest, data ); PutSize( dest, Size ); END NewData; PROCEDURE ClearData; (*! todo *) END ClearData; BEGIN dim := LEN( a,0 ); dest := SYSTEM.VAL(ADDRESS,destA); (*! check range flag! *) IF (dest = 0) OR (dim # GetDim( dest )) THEN IF dest # 0 THEN IF (~(TensorFlag IN GetFlags( dest ))) THEN Err( "Array's number of dimension must not be modified (no TENSOR !)" ); END; END; descr := GetArrayDesc( LEN( a,0 ) ); dest := descr; NewData; ELSE i := 0; WHILE (i < dim) & same DO IF GetLen( dest, i ) # a[i] THEN same := FALSE; END; INC( i ); END; IF ~same THEN IF (RangeFlag IN GetFlags( dest )) THEN Err( "Array's shape must not be modified (is RANGE !) " ); END; NewData ELSE ClearData END; END; SYSTEM.PUT(ADDRESSOF(destA),dest); END AllocateTensorX; PROCEDURE LenA*( VAR dest: ARRAY [ * ] OF SIZE; src: ADDRESS ); VAR dim, i: LONGINT; BEGIN dim := GetDim( src ); IF LEN( dest, 0 ) # dim THEN NEW( dest, dim ); END; FOR i := 0 TO dim - 1 DO dest[i] := GetLen( src, i ); END; END LenA; PROCEDURE IncrA*( VAR dest: ARRAY [ * ] OF SIZE; src: ADDRESS ); VAR dim, len: SIZE; i: LONGINT; BEGIN dim := GetDim( src ); len := LEN( dest, 0 ); IF len # dim THEN NEW( dest, dim ); END; FOR i := 0 TO dim - 1 DO dest[i] := GetIncr( src, i ); END; END IncrA; PROCEDURE Len*(src: ADDRESS; d: SIZE): SIZE; VAR dim: SIZE; BEGIN dim := GetDim(src); IF (d<0) OR (d>=dim) THEN HALT(100) ELSE RETURN GetLen(src,d); END; END Len; PROCEDURE Incr*(src: ADDRESS; d: SIZE): SIZE; VAR dim: SIZE; BEGIN dim := GetDim(src); IF (d<0) OR (d>=dim) THEN HALT(100) ELSE RETURN GetIncr(src,d); END; END Incr; PROCEDURE AllocateTensor( VAR dest: ADDRESS; left, right: ADDRESS; Size: SIZE ): ANY; VAR ldim, rdim: SIZE; ptr, data: ANY; PROCEDURE NewData; VAR len, size, i: SIZE; BEGIN size := 1; FOR i := 0 TO ldim - 1 DO len := GetLen( left, i ); size := size * len; PutLen( dest, i, len ); END; FOR i := 0 TO rdim - 1 DO len := GetLen( right, i ); size := size * len; PutLen( dest, ldim + i, len ); END; SYSTEM.NEW( data, size * Size ); (* Zero(data,size*Size); *) (* KernelLog.String("adr data="); KernelLog.Int(SYSTEM.VAL(LONGINT,data),10); KernelLog.Ln; KernelLog.String("adr dest="); KernelLog.Int(dest,10); KernelLog.Ln; *) size := Size; FOR i := ldim + rdim - 1 TO 0 BY -1 DO PutInc( dest, i, size ); size := size * GetLen( dest, i ); END; PutAdr( dest, data ); PutPtr( dest, data ); END NewData; BEGIN ldim := GetDim( left ); rdim := GetDim( right ); IF dest = 0 THEN (* NIL pointer, guaranteed to be tensor *) ptr := GetArrayDesc( ldim + rdim ); dest := ptr; NewData(); RETURN ptr; ELSIF (ldim + rdim # GetDim( dest )) THEN IF ~(TensorFlag IN GetFlags( dest )) & ~(TemporaryFlag IN GetFlags( dest )) THEN (* no, not allowed*) HALT( 100 ); END; ptr := GetArrayDesc( ldim + rdim ); dest := ptr; NewData(); RETURN ptr; ELSIF ~CheckTensorGeometry( left, right, dest, ldim, rdim ) THEN (* dimension matches but not geometry *) IF RangeFlag IN GetFlags( dest ) THEN (* no! not allowed *) HALT( 100 ); END; NewData(); RETURN data; END; RETURN NIL; END AllocateTensor; (* find the largest block with a regular pattern of the form offset+{i*linc: 0<=i 0) & (rdim > 0) DO DEC( ldim ); DEC( rdim ); len := GetLen( left, ldim ); ASSERT( GetLen( left, ldim ) = GetLen( right, rdim ) ); END; linc := GetIncr( left, ldim ); ri := GetIncr( right, rdim ); DEC( rdim ); DEC( ldim ); WHILE (ldim >= 0) & (rdim >= 0) & (GetIncr( left, ldim ) = len * linc) & (GetIncr( right, rdim ) = len * ri) DO len := len * GetLen( left, ldim ); ASSERT( GetLen( left, ldim ) = GetLen( right, rdim ) ); DEC( rdim ); DEC( ldim ); END; INC( ldim ); INC( rdim ); IF debug THEN KernelLog.String( "FindPatternTensor: " ); KernelLog.Int( rdim, 10 ); KernelLog.Int( len, 10 ); KernelLog.Int( linc, 10 ); KernelLog.Int( ri, 10 ); KernelLog.Ln; END; END FindPatternTensor; PROCEDURE ApplyTensorAAAOp( d, l, r: ADDRESS; elementSize: LONGINT; Loop: BinaryASALoop ); VAR loopd, looplen, loopri, loopdi, lDim, rDim: LONGINT; p: ANY; origdest: LONGINT; left, right, dest: ADDRESS; PROCEDURE Traverse( ladr, radr, dadr: ADDRESS; ldim, rdim: LONGINT ); VAR len: LONGINT; linc, rinc, dinc: LONGINT; BEGIN IF (ldim < lDim) THEN len := GetLen( left, ldim ); linc := GetIncr( left, ldim ); dinc := GetIncr( dest, ldim + rdim ); INC( ldim ); WHILE (len > 0) DO Traverse( ladr, radr, dadr, ldim, rdim ); INC( ladr, linc ); INC( dadr, dinc ); DEC( len ); END; ELSIF (rdim # loopd) THEN len := GetLen( right, rdim ); rinc := GetIncr( right, rdim ); dinc := GetIncr( dest, ldim + rdim ); INC( rdim ); WHILE (len > 0) DO Traverse( ladr, radr, dadr, ldim, rdim ); INC( radr, rinc ); INC( dadr, dinc ); DEC( len ); END; ELSE (* KernelLog.String("MulALSLLoop"); KernelLog.Int(dadr,10); KernelLog.Int(loopdi,10); KernelLog.Int(looplen,10); KernelLog.Int(GetAdr(dest),10); KernelLog.Int(GetAdr(dest)+clen,10); KernelLog.Ln; *) Loop( radr, ladr, dadr, loopri, loopdi, looplen ); (* loop over right matrix and destination highest continuous dimension D[x,y,z,..] := L[x,y] ** R[z,..] *) END; END Traverse; BEGIN SYSTEM.GET( d, dest ); SYSTEM.GET( l, left ); SYSTEM.GET( r, right ); (* check array lengths *) origdest := 0; lDim := GetDim( left ); rDim := GetDim( right ); p := AllocateTensor( dest, left, right, elementSize ); (* IF (dest = 0) OR (GetPtr( dest ) = 0) THEN p := AllocateTensor( left, right, dest, elementSize ) ELSIF ~CheckTensorGeometry( left, right, dest, lDim, rDim ) THEN IF GetPtr( dest ) = -1 THEN HALT( GeometryMismatch ) ELSE p := AllocateTensor( left, right, dest, elementSize ); END; (*! to be done: treat overlapping memory *) END; *) (* debugging *) IF debug THEN Report( "AAA:left", left ); Report( "AAA:right", right ); Report( "AAA:dest", dest ); END; (* check pattern: longest piece that can be done with a loop *) FindPatternTensor( dest, right, loopd, looplen, loopri, loopdi ); (* run through dimensions *) Traverse( GetAdr( left ), GetAdr( right ), GetAdr( dest ), 0, 0 ); SYSTEM.PUT( d, dest ); END ApplyTensorAAAOp; OPERATOR "**"*(CONST left,right: ARRAY [?] OF SHORTINT): ARRAY [?] OF SHORTINT; BEGIN ApplyTensorAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( SHORTINT ), MulASSSLoop ); RETURN RESULT END "**"; OPERATOR "**"*(CONST left,right: ARRAY [?] OF INTEGER): ARRAY [?] OF INTEGER; BEGIN ApplyTensorAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( INTEGER ), MulAISILoop ); RETURN RESULT END "**"; OPERATOR "**"*(CONST left,right: ARRAY [?] OF LONGINT): ARRAY [?] OF LONGINT; BEGIN ApplyTensorAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGINT ), MulALSLLoop ); RETURN RESULT END "**"; OPERATOR "**"*(CONST left,right: ARRAY [?] OF REAL): ARRAY [?] OF REAL; BEGIN ApplyTensorAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( REAL ), loopMulARSR ); RETURN RESULT END "**"; OPERATOR "**"*(CONST left,right: ARRAY [?] OF LONGREAL): ARRAY [?] OF LONGREAL; BEGIN ApplyTensorAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGREAL ), loopMulAXSX ); RETURN RESULT END "**"; OPERATOR "**"*(CONST left,right: ARRAY [?] OF COMPLEX): ARRAY [?] OF COMPLEX; BEGIN ApplyTensorAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( COMPLEX ), loopMulAZSZ ); RETURN RESULT END "**"; OPERATOR "**"*(CONST left,right: ARRAY [?] OF LONGCOMPLEX): ARRAY [?] OF LONGCOMPLEX; BEGIN ApplyTensorAAAOp( ADDRESSOF( RESULT ), ADDRESSOF( left ), ADDRESSOF( right ), SIZEOF( LONGCOMPLEX ), loopMulALZSLZ ); RETURN RESULT END "**"; PROCEDURE InitOptimization; VAR p: PROCEDURE; BEGIN GETPROCEDURE("FoxArrayBaseOptimized","Install",p); IF p # NIL THEN p; ELSE KernelLog.String( "Warning: ArrayBase runtime library optimizer not installed." ); KernelLog.Ln; END; END InitOptimization; PROCEDURE CopyDescriptor*(VAR destPtr: ANY; src: LONGINT; prefixIndices, prefixRanges, suffixIndices, suffixRanges: LONGINT); VAR size: SIZE; srcDim, destDim,i,len,incr: LONGINT; dest: ADDRESS; BEGIN IF src = 0 THEN HALT(100); ELSE srcDim := GetDim(src); destDim := srcDim - prefixIndices - suffixIndices; (* KernelLog.String("srcDim "); KernelLog.Int(srcDim,1); KernelLog.Ln; KernelLog.String("prefixIndices "); KernelLog.Int(prefixIndices,1); KernelLog.Ln; KernelLog.String("prefixRanges "); KernelLog.Int(prefixRanges,1); KernelLog.Ln; KernelLog.String("suffixIndices "); KernelLog.Int(suffixIndices,1); KernelLog.Ln; KernelLog.String("suffixRanges "); KernelLog.Int(suffixRanges,1); KernelLog.Ln; KernelLog.String("destDim "); KernelLog.Int(destDim,1); KernelLog.Ln; *) destPtr := GetArrayDesc(destDim); dest := SYSTEM.VAL(LONGINT,destPtr); (* SYSTEM.MOVE(src,dest,MathLenOffset); *) PutAdr(dest,GetAdr(src)); PutPtr(dest,GetPtr(src)); PutFlags(dest,GetFlags(src)); PutSize(dest,GetSize(src)); FOR i := 0 TO srcDim-suffixIndices-suffixRanges-prefixIndices-prefixRanges-1 DO srcDim := i + prefixIndices + prefixRanges; destDim := i + prefixRanges; len := GetLen(src,srcDim); incr := GetIncr(src,srcDim); PutLen(dest,destDim,len); PutInc(dest,destDim,incr); END; (* Report("copy descriptor src",src); Report("copy descriptor dest",dest); *) END; END CopyDescriptor; (* when Reshape is called by a compiler, the arguments are - for the compiler - replaced as follows, this makes them compatible VAR dest: ARRAY [?] OF basetype CONST src: ARRAY [?] OF basetype CONST shape: ARRAY [*] OF LONGINT *) PROCEDURE Reshape*(CONST left: ARRAY [?]; CONST right: ARRAY [*] OF LONGINT): ARRAY [?]; BEGIN DoReshape(SYSTEM.VAL(LONGINT,RESULT), SYSTEM.VAL(LONGINT,left), right); RETURN RESULT END Reshape; (* OLIVIER *) (** creates a degenerated range from an integer. - makes it possible to convert the result of an integer-valued procedure F() into a range without executing the procedure twice as it would happen in "(F() .. F() BY 1)" **) PROCEDURE RangeFromInteger*(CONST integer: LONGINT): RANGE; BEGIN RETURN (integer .. integer BY 1) END RangeFromInteger; (* OLIVIER *) (** create an array with the same data but with more dimensions - each element in the array 'keptDimensions' corresponds to a dimension in the resulting array - if element = TRUE: use a dimension from the source array, i.e. reuse length and increment - if element = FALSE: insert a new dimension having length = 1 and increment = 0 e.g.: ExpandDimensions(array, [FALSE, TRUE, FALSE, FALSE, TRUE]) performs the following type transformation: ARRAY [10, 20] OF REAL -> ARRAY [1, 10, 1, 1, 20] OF REAL **) PROCEDURE ExpandDimensions*(CONST sourceArray: ARRAY [?]; CONST keptDimensions: ARRAY [*] OF BOOLEAN): ARRAY [?]; VAR targetDimensionality, sourceIndex, targetIndex: LONGINT; sourceADDRESS, targetADDRESS: LONGINT; targetArrayDescriptor: ANY; BEGIN sourceADDRESS := SYSTEM.VAL(LONGINT, sourceArray); targetDimensionality := LEN(keptDimensions, 0); targetArrayDescriptor := GetArrayDesc(targetDimensionality); (* create a new array descriptor *) SYSTEM.PUT(ADDRESSOF(RESULT), targetArrayDescriptor); targetADDRESS := SYSTEM.VAL(LONGINT, RESULT); PutAdr(targetADDRESS, GetAdr(sourceADDRESS)); PutPtr(targetADDRESS, GetPtr(sourceADDRESS)); PutFlags(targetADDRESS, {TensorFlag}); PutSize(targetADDRESS, GetSize(sourceADDRESS)); (* set increments and lengths *) sourceIndex := 0; FOR targetIndex := 0 TO targetDimensionality - 1 DO IF keptDimensions[targetIndex] THEN (* reuse length and increment from source array *) ASSERT(sourceIndex < DIM(sourceArray)); PutLen(targetADDRESS, targetIndex, GetLen(sourceADDRESS, sourceIndex)); PutInc(targetADDRESS, targetIndex, GetIncr(sourceADDRESS, sourceIndex)); INC(sourceIndex) ELSE (* set length = 1 and increment = 0 *) PutLen(targetADDRESS, targetIndex, 1); PutInc(targetADDRESS, targetIndex, 0); END END; (* Report("expand dimensions: ", targetADDRESS); *) RETURN RESULT END ExpandDimensions; (* index ranges *) (* the length of a range, i.e. the number of indices that it stands for *) OPERATOR "LEN"*(CONST range: RANGE): LONGINT; VAR temp, result: LONGINT; BEGIN IF (LAST(range) < FIRST(range)) OR (FIRST(range) < 0) OR (STEP(range) < 1) THEN (* invalid range *) result := 0 ELSIF LAST(range) = MAX(LONGINT) THEN (* open-ended range *) result := MAX(LONGINT) ELSE temp := 1 + LAST(range) - FIRST(range); result := temp DIV STEP(range); IF (temp MOD STEP(range)) # 0 THEN INC(result) END END; RETURN result END "LEN"; OPERATOR "ALL"*(CONST x: ARRAY [?] OF SHORTINT; op: PROCEDURE(x: SHORTINT): SHORTINT): ARRAY[?] OF SHORTINT; (*should also accept operator ?*) BEGIN ApplyGenericUnaryAAOpS(ADDRESSOF(RESULT),ADDRESSOF(x),SIZEOF(SHORTINT),GenericLoopS,op); RETURN RESULT; END "ALL"; OPERATOR "ALL"*(CONST x: ARRAY [?] OF INTEGER; op: PROCEDURE(x: INTEGER): INTEGER): ARRAY[?] OF INTEGER; (*should also accept operator ?*) BEGIN ApplyGenericUnaryAAOpI(ADDRESSOF(RESULT),ADDRESSOF(x),SIZEOF(INTEGER),GenericLoopI,op); RETURN RESULT; END "ALL"; OPERATOR "ALL"*(CONST x: ARRAY [?] OF LONGINT; op: PROCEDURE(x: LONGINT): LONGINT): ARRAY[?] OF LONGINT; (*should also accept operator ?*) BEGIN ApplyGenericUnaryAAOpL(ADDRESSOF(RESULT),ADDRESSOF(x),SIZEOF(LONGINT),GenericLoopL,op); RETURN RESULT; END "ALL"; OPERATOR "ALL"*(CONST x: ARRAY [?] OF HUGEINT; op: PROCEDURE(x: HUGEINT): HUGEINT): ARRAY[?] OF HUGEINT; (*should also accept operator ?*) BEGIN ApplyGenericUnaryAAOpH(ADDRESSOF(RESULT),ADDRESSOF(x),SIZEOF(HUGEINT),GenericLoopH,op); RETURN RESULT; END "ALL"; OPERATOR "ALL"*(CONST x: ARRAY [?] OF REAL; op: PROCEDURE(x: REAL): REAL): ARRAY[?] OF REAL; (*should also accept operator ?*) BEGIN ApplyGenericUnaryAAOpR(ADDRESSOF(RESULT),ADDRESSOF(x),SIZEOF(REAL),GenericLoopR,op); RETURN RESULT; END "ALL"; OPERATOR "ALL"*(CONST x: ARRAY [?] OF LONGREAL; op: PROCEDURE(x: LONGREAL): LONGREAL): ARRAY[?] OF LONGREAL; (*should also accept operator ?*) BEGIN ApplyGenericUnaryAAOpX(ADDRESSOF(RESULT),ADDRESSOF(x),SIZEOF(LONGREAL),GenericLoopX,op); RETURN RESULT; END "ALL"; OPERATOR "ALL"*(CONST x: ARRAY [?] OF COMPLEX; op: PROCEDURE(x: COMPLEX): COMPLEX): ARRAY[?] OF COMPLEX; (*should also accept operator ?*) BEGIN ApplyGenericUnaryAAOpZ(ADDRESSOF(RESULT),ADDRESSOF(x),SIZEOF(COMPLEX),GenericLoopZ,op); RETURN RESULT; END "ALL"; OPERATOR "ALL"*(CONST x: ARRAY [?] OF LONGCOMPLEX; op: PROCEDURE(x: LONGCOMPLEX): LONGCOMPLEX): ARRAY[?] OF LONGCOMPLEX; (*should also accept operator ?*) BEGIN ApplyGenericUnaryAAOpLZ(ADDRESSOF(RESULT),ADDRESSOF(x),SIZEOF(LONGCOMPLEX),GenericLoopLZ,op); RETURN RESULT; END "ALL"; BEGIN alloc := 0; SetDefaults(); InitOptimization(); (* CreateTypePool; *) END FoxArrayBase. Compiler.Compile FoxArrayBase.Mod ~ SystemTools.ListModules