opsubs.p

<B>Digital的Unix操作系统VAX 4.2源码</B>

(*#@(#)opsubs.p	4.1	Ultrix	7/17/90 *)
(****************************************************************************
 *									    *
 *  Copyright (c) 1984 by						    *
 *  DIGITAL EQUIPMENT CORPORATION, Maynard, Massachusetts.		    *
 *  All rights reserved.						    *
 * 									    *
 *  This software is furnished under a license and may be used and copied   *
 *  only in  accordance with  the  terms  of  such  license  and with the   *
 *  inclusion of the above copyright notice. This software or  any  other   *
 *  copies thereof may not be provided or otherwise made available to any   *
 *  other person.  No title to and ownership of  the  software is  hereby   *
 *  transferred.							    *
 * 									    *
 *  The information in this software is  subject to change without notice   *
 *  and  should  not  be  construed as  a commitment by DIGITAL EQUIPMENT   *
 *  CORPORATION.							    *
 * 									    *
 *  DIGITAL assumes no responsibility for the use  or  reliability of its   *
 *  software on equipment which is not supplied by DIGITAL.		    *
 * 									    *
$Header: opsubs.p,v 1.5 84/05/19 11:34:50 powell Exp $
 ****************************************************************************)
#include "globals.h"
#include "util.h"
#include "codesubs.h"
#include "opsubs.h"

procedure opabsc;
var lab : LabelNumber;
begin
    Eval(top);
    lab := NewLabel;
    if opd11 = 'r' then begin
	Op('tstf'); Opnd(top); L;
	Op('jgeq'); Lab(lab); L;
	Op('mnegf'); Opnd(top); X; Opnd(top); L;
    end else if opd11 = 'R' then begin
	Op('tstd'); Opnd(top); L;
	Op('jgeq'); Lab(lab); L;
	Op('mnegd'); Opnd(top); X; Opnd(top); L;
    end else begin
	Op('tstl'); Opnd(top); L;
	Op('jgeq'); Lab(lab); L;
	Op('mnegl'); Opnd(top); X; Opnd(top); L;
    end;
    Lab(lab); C(':'); L;
end;

procedure opaddc;
var
    r : Reg;
begin
    if opd11 = 'r' then begin
	TwoOrThree('addfN',top,top-1,treal,WORDSIZE);
    end else if opd11 = 'R' then begin
	TwoOrThree('adddN',top,top-1,tlongreal,2*WORDSIZE);
    end else if opd11 = 'a' then begin
	MakeBaseAddress(top);
	MakeBaseAddress(top-1);
	{ make sure subscripts are compatible }
	if ees[top].sreg <> NULLREG then begin
	    if ees[top-1].sreg <> NULLREG then begin
		if ees[top].sunits > ees[top-1].sunits then begin
		    CheckSub(top,ees[top-1].sunits);
		end else begin
		    CheckSub(top-1,ees[top].sunits);
		end;
	    end;
	end;
	ees[top-1].addrOffset := ees[top-1].addrOffset + ees[top].addrOffset;
	if ees[top].addrMemType <> ' ' then begin
	    if ees[top-1].addrMemType <> ' ' then begin
		Error('opaddc: add two base addresses');
	    end;
	    ees[top-1].addrMemType := ees[top].addrMemType;
	    ees[top-1].addrLevel := ees[top].addrLevel;
	    ees[top-1].addrBlock := ees[top].addrBlock;
	end;
	{ check for special case: no sreg, no constant }
	if (ees[top].sreg = NULLREG) and (ees[top-1].sreg = NULLREG) and
	    (ees[top-1].addrMemType = ' ') and (ees[top-1].addrOffset = 0)
	    and (ees[top].breg <> NULLREG) and (ees[top-1].breg <> NULLREG)
	then begin
	    { to use TwoOrThree, rearrange as dreg }
	    ees[top].kind := EESDATA;
	    ees[top].dreg := ees[top].breg;
	    ees[top].breg := NULLREG;
	    ees[top-1].kind := EESDATA;
	    ees[top-1].dreg := ees[top-1].breg;
	    ees[top-1].breg := NULLREG;
	    TwoOrThree('addlN',top,top-1,taddress,WORDSIZE);
	end else begin
	    if ees[top].breg <> NULLREG then begin
		if ees[top-1].breg <> NULLREG then begin
		    if not ActiveReg(ees[top-1].breg) and ActiveReg(ees[top].breg)
		    then begin
			{ switch them }
			MoveReg(top-1,ees[top].breg);
			MoveReg(top,ees[top-1].breg);
			r := ees[top].breg;
			ees[top].breg := ees[top-1].breg;
			ees[top-1].breg := r;
		    end;
		    Op('addl3'); R(ees[top].breg); X;
			    TRegOpnd(ees[top-1].breg,top-1); L;
		end else begin
		    ees[top-1].breg := ees[top].breg;
		    MoveReg(top-1,ees[top].breg);
		    ees[top].breg := NULLREG;
		end;
	    end;
	    if ees[top].sreg <> NULLREG then begin
		if ees[top-1].sreg <> NULLREG then begin
		    if not ActiveReg(ees[top-1].sreg) and ActiveReg(ees[top].sreg)
		    then begin
			{ switch them }
			MoveReg(top-1,ees[top].sreg);
			MoveReg(top,ees[top-1].sreg);
			r := ees[top].sreg;
			ees[top].sreg := ees[top-1].sreg;
			ees[top-1].sreg := r;
		    end;
		    Op('addl3'); R(ees[top].sreg); X;
			    TRegOpnd(ees[top-1].sreg,top-1); L;
		end else begin
		    ees[top-1].sreg := ees[top].sreg;
		    MoveReg(top-1,ees[top].sreg);
		    ees[top].sreg := NULLREG;
		    ees[top-1].sunits := ees[top].sunits;
		end;
	    end;
	    ees[top-1].ptype := taddress;
	    ees[top-1].size := WORDSIZE;
	end;
    end else if (ees[top].kind = EESDATA) and (ees[top].dreg = NULLREG)
	and (ees[top-1].kind in [EESDATA,EESVAR])
    then begin
	{ top is constant }
	ees[top-1].constInt := Add(ees[top-1].constInt,ees[top].constInt);
    end else if (ees[top-1].kind = EESDATA) and (ees[top-1].dreg = NULLREG)
	and (ees[top].kind in [EESDATA,EESVAR])
    then begin
	{ top-1 is constant }
	SwapEES(top,top-1);	{ make top constant }
	ees[top-1].constInt := Add(ees[top-1].constInt,ees[top].constInt);
    end else begin
	TwoOrThree('addlN',top,top-1,tinteger,WORDSIZE);
    end;
    Pop(1);
end;

procedure opad2c;
var
    size : integer;
begin
    size := Int(opd^[2]);
    MakeVariable(top-1);
    Check(top-1,size);
    Check(top,size);
    ees[top-1].size := size;
    if (size <> WORDSIZE) and (size <> BYTESIZE) then begin
	Error('opad2: bad size');
    end;
    if opd11 = 'r' then begin
	ees[top-1].ptype := treal;
	Op('addf2'); Opnd(top); X; Opnd(top-1); L;
    end else if opd11 = 'R' then begin
	ees[top-1].ptype := tlongreal;
	Op('addd2'); Opnd(top); X; Opnd(top-1); L;
    end else begin
	if (ees[top].kind = EESDATA) and (ees[top].dreg = NULLREG) and
		(ees[top].constInt = 1)
	then begin
	    if size = BYTESIZE then begin
		Op('incb'); Opnd(top-1); L;
	    end else begin
		Op('incl'); Opnd(top-1); L;
	    end;
	end else begin
	    if size = BYTESIZE then begin
		Op('addb2');
	    end else begin
		Op('addl2');
	    end;
	    Opnd(top); X; Opnd(top-1); L;
	end;
    end;
    Pop(2);
end;

procedure opandc;
var r : Reg;
begin
    check2(2,[tboolean]);

    Check(top-1,BOOLSIZE);
    Check(top,BOOLSIZE);
    r := AllocReg(REGEES,top-1,tboolean);
    Op('xorb3'); Opnd(top-1); X; C('$'); I(1); X; R(r); L;
    Op('bicb3'); R(r); X; Opnd(top); X; R(r); L;
    Pop(2);
    Push(EESDATA);
    ees[top].dreg := r;
    ees[top].ptype := tboolean;
    ees[top].size := BOOLSIZE;
end;

procedure opbgnc;
var
    i : integer;
    r : Reg;
begin
    if (pclbsize=0) then Error('Missing program name');

    mainprogblockid := Int(opd^[2]);
    Op('.data'); L;
    Op('.comm'); S('_runtime__linenumber'); X; I(4); L;
    Op('.comm'); S('_runtime__filename'); X; I(4); L;
    Op('.comm'); S('_runtime__display'); X; I(4*(MAXDISPLEVEL+1)); L;
    for r := FIRSTVREG to LASTVREG do begin
	Op('.comm'); R(r); X; I(4); L;
    end;
    Op('.text'); L;
    Op('.align'); I(1); L;

    { use label as program name for separate compilation }
    for i := 1 to pclbsize do  progname[i]:=pclabel[i];
    prognmsize := pclbsize;
end;

procedure opcapc;
var
    lab : LabelNumber;
begin
    check1(1,[tchar]);

    Eval(top);
    lab := NewLabel;
    Op('cmpb'); Opnd(top); X; C('$'); I(ord('a')); L;
    Op('jlss'); Lab(lab); L;
    Op('cmpb'); Opnd(top); X; C('$'); I(ord('z')); L;
    Op('jgtr'); Lab(lab); L;
    Op('addb2'); C('$'); I(ord('A')-ord('a')); X; Opnd(top); L;
    Lab(lab); C(':'); L;
end;

procedure opcepc;
begin
	CallProcOp(opcep);
end;

procedure opcipc;
begin
	CallProcOp(opcip);
end;

procedure opcspc;
begin
    error(6);
end;

procedure opchkc;
    function GetValue(var i : integer) : integer;
    var
	result : integer;
    begin
	result := 0;
	while opd^[4][i] in ['0'..'9'] do begin
	    result := result * 10 + ord(opd^[4][i]) - ord('0');
	    i := i + 1;
	end;
	GetValue := result;
    end;
var
    labok, laberr, tmp : LabelNumber;
    min, max, value, offset, size, i : integer;
    ok, elsevariant, continue : boolean;
    op : ShortString;
begin
    ok := false;
    if (ees[top].kind = EESDATA) and (ees[top].dreg = NULLREG)
	and (opd11 in ['r','s'])
    then begin
	min := Int(opd^[3]);
	max := Int(opd^[4]);
	value := ees[top].constInt;
	if max < min then begin
	    { cardinal range that spans maxint, shift value and range down }
	    if value < 0 then begin
		value := value + maxint + 1;
	    end else begin
		value := value - maxint - 1;
	    end;
	    ok := (max+maxint+1 >= value) and (min-maxint-1 <= value);
	end else begin
	    ok := (max >= value) and (min <= value);
	end;
    end;
    if ok then begin
    end else begin
	case opd11 of
	    'a' : begin
		labok := NewLabel;
		Eval(top);
		case opd^[2][1] of
		    'm' : begin
			Op('cmpl'); Opnd(top); X; I(-4); C('('); Opnd(top);
					C(')'); L;
			Op('jeql'); Lab(labok); L;
		    end;
		    'n' : begin
			Op('tstl'); Opnd(top); L;
			Op('jneq'); Lab(labok); L;
		    end;
		    'p' : begin
			laberr := NewLabel;
			Op('cmpl'); Opnd(top); X; S('__maxptr'); L;
			Op('jgtru'); Lab(laberr); L;
			Op('cmpl'); Opnd(top); X; S('__minptr'); L;
			Op('jgequ'); Lab(labok); L;
			Lab(laberr); C(':'); L;
		    end;
		end;
		Op('calls'); S('$0,_runtime__erroraddr'); L;
		Lab(labok); C(':'); L;
	    end;
	    'r','s' : begin
		labok := NewLabel;
		laberr := NewLabel;
		min := Int(opd^[3]);
		max := Int(opd^[4]);
		Eval(top);
		if min = 0 then begin
		    { treat as logical value }
		end else begin
		    Op('cmpl'); Opnd(top); X; C('$'); I(min); L;
		    { if (signed!) max < min, then it's a cardinal range }
		    {  that spans maxint.  Only case where signed fails. }
		    if max < min then begin
			Op('jlssu'); Lab(laberr); L;
		    end else begin
			Op('jlss'); Lab(laberr); L;
		    end;
		end;
		Op('cmpl'); Opnd(top); X; C('$'); I(max); L;
		if min >= 0 then begin
		    Op('jlequ'); Lab(labok); L;
		end else begin
		    Op('jleq'); Lab(labok); L;
		end;
		Lab(laberr); C(':');
		Op('pushl'); C('$'); I(max); L;
		Op('pushl'); C('$'); I(min); L;
		Op('pushl'); Opnd(top); L;
		if opd11 = 's' then begin
		    Op('calls'); S('$3,_runtime__errorsubscript'); L;
		end else begin
		    Op('calls'); S('$3,_runtime__errorrange'); L;
		end;
		Lab(labok); C(':'); L;
	    end;
	    'A' : begin
		{ put condition on top }
		SwapEES(top,top-1);
		labok := NewLabel;
		Check(top,BOOLSIZE);
		Op('bitb'); S('$1'); X; Opnd(top); L;
		Op('jneq'); Lab(labok); L;
		Pop(1);		{ get rid of condition }
		CallProc(opcep,'p',0,1,RTERRORASSERT);
		Lab(labok); C(':'); L;
	    end;
	    'p' : begin
		Op('calls'); S('$0,_runtime__errornoreturn'); L;
		{ insert a few no-ops so dbx will print the right address }
		Op('.byte'); I(1); X; I(1); L;
	    end;
	    'c' : begin
		Op('calls'); S('$0,_runtime__errorcase'); L;
	    end;
	    'o' : begin
		labok := NewLabel;
		Eval(top-1);
		Increment(WORDSIZE);
		MakeVariable(top);
		ees[top].ptype := tcardinal;
		ees[top].size := WORDSIZE;
		Check(top,WORDSIZE);
		Op('cmpl'); Opnd(top-1); X; Opnd(top); L;
		Op('jlssu'); Lab(labok); L;
		Op('pushl'); Opnd(top); L;
		Op('pushl'); C('$'); I(0); L;
		Op('pushl'); Opnd(top-1); L;
		Op('calls'); S('$3,_runtime__errorsubscript'); L;
		Lab(labok); C(':'); L;
		Pop(1);
	    end;
	    'v' : begin
		Point(top);
		offset := Int(opd^[2]) div BYTESIZE;
		size := Int(opd^[3]);
		if (size <> BYTESIZE) and (size <> WORDSIZE) then begin
		    Error('opchk v: bad tag size');
		end;
		if size <= BYTESIZE then begin
		    op := 'cmpb';
		end else begin
		    op := 'cmpl';
		end;
		if opd^[4][1] = '~' then begin
		    i := 2;
		    elsevariant := true;
		end else begin
		    i := 1;
		    elsevariant := false;
		end;
		labok := NewLabel;
		laberr := NewLabel;
		repeat
		    min := GetValue(i);
		    if opd^[4][i] <> ':' then begin
			Op(op); I(offset); Opnd(top); X; C('$'); I(min); L;
			Op('jeql'); Lab(labok); L;
		    end else begin
			i := i + 1;
			max := GetValue(i);
			Op(op); I(offset); Opnd(top); X; C('$'); I(min); L;
			Op('jlss'); Lab(laberr); L;
			Op(op); I(offset); Opnd(top); X; C('$'); I(max); L;
			Op('jleq'); Lab(labok); L;
			Lab(laberr); C(':'); L;
			laberr := NewLabel;
		    end;
		    if opd^[4][i] = ';' then begin
			i := i + 1;
			continue := i <= opdsizes^[4];
		    end else begin
			continue := false;
		    end;
		until not continue;
		if elsevariant then begin
		    { on else, switch labels }
		    tmp := labok;
		    labok := laberr;
		    laberr := tmp;
		    Op('jbr'); Lab(labok); L;
		end;
		Lab(laberr); C(':'); L;
		if size <= BYTESIZE then begin
		    Op('movb'); I(offset); Opnd(top); X; R(RETURNREG); L;
		    Op('pushl'); R(RETURNREG); L;
		end else begin
		    Op('pushl'); I(offset); Opnd(top); L;
		end;
		Op('calls'); S('$1,_runtime__errorvariant'); L;
		Lab(labok); C(':'); L;
		{ Point converted from address to variable; switch back }
		ees[top].kind := EESADDR;
	    end;
	end;
    end;
end;

procedure opchrc;
begin
    check1(0,[tinteger,tcardinal]);

    ees[top].ptype := tchar;
    ees[top].size := CHARSIZE;
end;

procedure opcomc;
var
    i : integer;
begin
    if opdcount <> 3 then begin
	error(1);
    end;
    comtable[numcomblocks].block := Int(opd^[1]);
    for i := 1 to opdsizes^[2] do begin
	comtable[numcomblocks].name[i] := opd^[2][i];
    end;
    comtable[numcomblocks].name[opdsizes^[2]+1] := ' ';
    Op('.comm'); C('_'); Comm(comtable[numcomblocks].name); X;
			    I((Int(opd^[3])*WORDSIZE) div BYTESIZE); L;
    if numcomblocks < NUMCOMBLOCKS then begin
	numcomblocks := numcomblocks + 1;
    end;
end;

procedure opctsc;
begin
end;

procedure opctrc;
begin
end;