Trailing-Edge
-
PDP-10 Archives
-
decus_20tap1_198111
-
decus/20-0002/recaux.sai
There is 1 other file named recaux.sai in the archive. Click here to see a list.
COMMENT VALID 00005 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 Auxilliary record service routines.
C00003 00003 ! rectype, $rectype, cvrts, bldnrc, chkrec, cpyrec, etc
C00008 00004 ! cell routines
C00012 00005 ! rlist primitives
C00018 ENDMK
C;
COMMENT Auxilliary record service routines.
Modified for new-style record descriptors.
;
ENTRY;
BEGIN "RECAUX"
REQUIRE "ABBREV.SAI[S,RHT]" SOURCEFILE;
REQUIRE "MACROS.SAI[S,RHT]" SOURCEFILE;
REQUIRE "STCODE.DEF[S,RHT]" SOURCEFILE;
REQUIRE "SYS:RECORD.DEF" SOURCEFILE;
DEFINE RPTR="RECORDPOINTER";
! rectype, $rectype, cvrts, bldnrc, chkrec, cpyrec, etc;
INTERNAL INTEGER SIMPLE PROCEDURE RECLEN(RPTR(ANYCLASS) R);
STARTCODE
LABEL XIT;
SKIPN 1,R;
JRST XIT;
MOVE 1,(1); ! get the descriptor;
MOVE 1,3(1); ! the size field therefrom;
XIT: END;
INTERNAL INTEGER SIMPLE PROCEDURE RECTYPE(RPTR (ANYCLASS) R);
STARTCODE
SKIPE 1,R;
HRRZ 1,(1);
END;
INTERNAL RPTR($CLASS) SIMPLE PROCEDURE $RECTYPE(RPTR(ANYCLASS) R);
STARTCODE
SKIPE 1,R;
HRRZ 1,(1);
END;
INTERNAL INTEGER PROCEDURE FLDTYPE(RPTR (ANYCLASS) R;INTEGER IX);
RETURN($CLASS:TYPARR[$RECTYPE(R)][IX] LSH -23);
INTERNAL STRING SIMPLE PROCEDURE CVRCS(RPTR($CLASS) RC);
RETURN($CLASS:TXTARR[RC][0]);
INTERNAL STRING SIMPLE PROCEDURE CVRTS(INTEGER RT);
STARTCODE
JRST CVRCS;
END;
INTERNAL INTEGER PROCEDURE FLDREF(RPTR(ANYCLASS) R;STRING ID);
BEGIN
INTEGER I,N;
RPTR($CLASS) RC;
RC_$RECTYPE(R);
N_$CLASS:RECSIZ[RC];
FOR I_1 STEP 1 UNTIL N DO
IF EQU($CLASS:TXTARR[RC][I],ID) THEN
RETURN($CLASS:TYPARR[RC][I]+I+MEMORY[LOCATION(R)]);
RETURN(0);
END;
INTERNAL RPTR($CLASS) PROCEDURE CLSFND(STRING ID);
BEGIN
LABEL XIT;
RPTR($CLASS) RC;
MEMORY[LOCATION(RC)]_LOCATION($CLASS);
WHILE TRUE DO
BEGIN
IF EQU($CLASS:TXTARR[RC][0],ID) THEN
RETURN(RC)
ELSE
STARTCODE
MOVE 1,RC;
HLRZ 1,-1(1);
CAIN 1,$CLASS;
JRST XIT;
MOVEM 1,RC;
END;
END;
XIT:RETURN(NULLRECORD);
END;
INTERNAL RECORDPOINTER(ANYCLASS) PROCEDURE BLDNRC(INTEGER RT);
STARTCODE
! This procedure is to be called by a procedure of the form:
rptr(id) procedure newid(fld1,...,fldn)
return(bldnew(loc(id))
;
EXTERNAL INTEGER $RECFN;
LABEL L1,L2;
SALACS;
SKIPN B,RT;
JRST 4,;
PUSH P,[1] ; ! allocate;
PUSH P,RT;
PUSHJ P,$RECFN;
HRRZ C,(A); ! record class;
MOVN C,3(C); ! - number of subfields;
JUMPE C,L2; ! no subfields;
HRRZ B,A; ! will do pushes to copy;
MOVE D,(RF); ! look at caller;
ADDI D,-1(C); ! point at first argument;
HRL D,C; ! -cnt,,first arg;
L1: PUSH B,(D); ! copy value;
SETZM (D); ! sterilize it;
AOBJN D,L1; ! iterate;
L2: END;
INTERNAL RPTR(ANYCLASS) PROCEDURE CHKREC(RPTR(ANYCLASS) R;INTEGER T);
BEGIN
IF T0 RECTYPE(R)T THEN
BEGIN
USERERR(1,1,(CRLF&"RECORD ")&CVOS(MEMORY[LOCATION(R)])
&" HAS TYPE "&CVRTS(RECTYPE(R))&
" INSTEAD OF "&CVRTS(T));
END;
RETURN(R);
END;
INTERNAL RPTR(ANYCLASS) PROCEDURE CPYREC(RPTR(ANYCLASS) R1,R2(NULLRECORD));
BEGIN
INTEGER I;
IF R2=NULLRECORD THEN
R2_$REC$(ALLOCATERECORD,$RECTYPE(R1))
ELSE
CHKREC(R2,RECTYPE(R1));
FOR I_RECLEN(R1) STEP -1 UNTIL 1 DO
MEMORY[MEMORY[LOCATION(R2)]+I]_MEMORY[MEMORY[LOCATION(R1)]+I];
RETURN(R2);
END;
! cell routines;
INTERNAL RECORDCLASS CELL(RPTR (ANYCLASS) CAR,CDR);
INTERNAL RPTR(CELL) PROCEDURE CONS(RPTR(ANYCLASS) A,D);
BEGIN
RPTR(CELL) C;
C_NEWRECORD(CELL);
CELL:CAR[C]_A;
CELL:CDR[C]_D;
RETURN(C);
END;
INTERNAL RPTR(ANYCLASS) RECURSIVE PROCEDURE SECOPY(RPTR(ANYCLASS) C);
BEGIN
RPTR(CELL) L1,L2,L3;
IF C=NULLRECORD THEN RETURN(NULLRECORD);
IF RECTYPE(C)LOC(CELL) THEN RETURN(C);
DO BEGIN
L3_NEWRECORD(CELL);
IF L1=NULLRECORD THEN
L2_L1_L3
ELSE
BEGIN
CELL:CDR[L2]_L3;
L2_L3;
END;
CELL:CAR[L2]_SECOPY(CELL:CAR[C]);
C_CELL:CDR[C];
END UNTIL RECTYPE(C)LOC(CELL);
CELL:CDR[L2]_C;
RETURN(L1);
END;
INTERNAL BOOLEAN PROCEDURE INCL(RPTR(ANYCLASS) C;RPTR(CELL) L);
BEGIN
WHILE LNULLRECORD DO
BEGIN
IF C=CELL:CAR[L] THEN RETURN(TRUE);
L_CELL:CDR[L];
END;
RETURN(FALSE);
END;
INTERNAL RPTR(ANYCLASS) PROCEDURE LLOP(REFERENCE RPTR(CELL) C);
BEGIN
RPTR(ANYCLASS) V;
IF RECTYPE(C)LOCATION(CELL) THEN
BEGIN
USERERR(1,1,"LLOP CALLED WITH RECORD OF TYPE "&CVRTS(RECTYPE(C)));
RETURN(NULLRECORD);
END;
V_CELL:CAR[C];
C_CELL:CDR[C];
RETURN(V);
END;
INTERNAL INTEGER PROCEDURE CLLEN(RPTR(CELL) C);
BEGIN
INTEGER I;
I_0;
WHILE CNULL DO
BEGIN
I_I+1;
C_CELL:CDR[C];
END;
RETURN(I);
END;
INTERNAL RPTR(CELL) PROCEDURE APPEND(RPTR(CELL) ARG1, ARG2);
BEGIN "append" ! Coded by RF;
! Appends the two lists by RPLACD on the last CDR field of ARG1;
RPTR(CELL) P1, P2;
IF ARG1 = NULLRECORD THEN RETURN(ARG2);
P1 _ ARG1;
WHILE P1 NULLRECORD DO
BEGIN ! Chain down ARG1 looking for the end;
P2 _ P1;
P1 _ CELL:CDR[P1];
END;
CELL:CDR[P2] _ ARG2;
RETURN(ARG1);
END "append";
INTERNAL RPTR(CELL) PROCEDURE LIST2(RPTR(ANYCLASS) C1,C2);
RETURN(CONS(C1,CONS(C2,NULLRECORD)));
INTERNAL RPTR(ANYCLASS) PROCEDURE CONSON(RPTR(ANYCLASS) X;REFERENCE RPTR(CELL) C);
BEGIN
C_CONS(X,C);
RETURN(X);
END;
! rlist primitives;
INTERNAL RECORDCLASS RLIST(INTEGER LEN;RPTR(CELL) FIRST,LAST);
INTERNAL PROCEDURE RLADD(RPTR(RLIST) RL;RPTR(ANYCLASS) REC;INTEGER N);
BEGIN
! adds REC to RL after N;
INTEGER I,L;
RPTR(CELL) C1;
L_RLIST:LEN[RL];
IF N>L N<0 THEN
BEGIN
BUG("RLADD INDEX OUT OF RANGE:"&CVS(N));
N_L;
END;
IF N=L THEN
BEGIN
IF N=0 THEN
RLIST:FIRST[RL]_RLIST:LAST[RL]_CONS(REC,NULLRECORD)
ELSE
BEGIN
C1_CONS(REC,NULLRECORD);
CELL:CDR[RLIST:LAST[RL]]_C1;
RLIST:LAST[RL]_C1;
END;
END
ELSE IF N=0 THEN
RLIST:FIRST[RL]_CONS(REC,RLIST:FIRST[RL])
ELSE
BEGIN
C1_RLIST:FIRST[RL];
FOR I_2 STEP 1 UNTIL N DO C1_CELL:CDR[C1];
CELL:CDR[C1]_CONS(REC,CELL:CDR[C1]);
END;
RLIST:LEN[RL]_L+1;
END;
INTERNAL INTEGER PROCEDURE RLREM(RPTR(RLIST) RL;RPTR(ANYCLASS) REC;
INTEGER HOWMANY(1));
BEGIN
! Removes up to the first HOWMANY instances of REC from RL.
Returns the number actually removed.
;
INTEGER CNT;
RPTR(CELL) C,CP;
CNT_0;
C_RLIST:FIRST[RL];CP_NULLRECORD;
WHILE CNULLRECORD HOWMANY>0 DO
BEGIN
IF REC=CELL:CAR[C] THEN
BEGIN
C_CELL:CDR[C];
IF CPNULLRECORD THEN
CELL:CDR[CP]_C
ELSE
RLIST:FIRST[RL]_C;
RLIST:LEN[RL]_RLIST:LEN[RL]-1;
HOWMANY_HOWMANY-1;
CNT_CNT+1;
IF C=NULLRECORD THEN
RLIST:LAST[RL]_CP;
END
ELSE
BEGIN
CP_C;C_CELL:CDR[C];
END;
END;
RETURN(CNT);
END;
INTERNAL RPTR(ANYCLASS) PROCEDURE RLNREM(RPTR(RLIST) RL;INTEGER N);
BEGIN
! removes RL[N] from RL & returns it;
INTEGER I;
IF 1 N RLIST:LEN[RL] THEN
BEGIN
RPTR(ANYCLASS) REC;
RPTR(CELL) C,CP;
C_RLIST:FIRST[RL];CP_NULLRECORD;
FOR I_2 STEP 1 UNTIL N DO
BEGIN
CP_C;C_CELL:CDR[C];
END;
REC_CELL:CAR[C];C_CELL:CDR[C];
IF N=1 THEN
RLIST:FIRST[RL]_C
ELSE
CELL:CDR[CP]_C;
IF C=NULLRECORD THEN
RLIST:LAST[RL]_CP;
RLIST:LEN[RL]_RLIST:LEN[RL]-1;
RETURN(REC);
END;
BUG("RLNREM OUT OF RANGE: "&CVS(N));
RETURN(NULLRECORD);
END;
INTERNAL INTEGER PROCEDURE RLINX(RPTR(RLIST) RL;RPTR(ANYCLASS) REC);
BEGIN
! returns index of REC in RL.;
INTEGER I;RPTR(CELL) C;
C_RLIST:FIRST[RL];
FOR I_1 STEP 1 UNTIL RLIST:LEN[RL] DO
BEGIN
IF REC=CELL:CAR[C] THEN RETURN(I);
C_CELL:CDR[C];
END;
RETURN(0);
END;
INTERNAL RPTR(ANYCLASS) PROCEDURE RLNTH(RPTR(RLIST) RL;INTEGER N);
BEGIN
! returns the N'th element of RL.;
IF 1 N RLIST:LEN[RL] THEN
BEGIN
RPTR(CELL) C;
C_RLIST:FIRST[RL];
WHILE (N_N-1)>0 DO C_CELL:CDR[C];
RETURN(CELL:CAR[C]);
END
ELSE
BEGIN
BUG("RLNTH OUT OF RANGE: "&CVS(N));
RETURN(NULLRECORD);
END;
END;
INTERNAL RPTR(RLIST) PROCEDURE RLCOPY(RPTR(RLIST) RL,RL2(NULLRECORD));
BEGIN
! copies RL into RL2 & returns the copy.;
RPTR(CELL) C;
INTEGER L,I;
IF RL2=NULLRECORD THEN
RL2_NEWRECORD(RLIST)
ELSE
BEGIN
RLIST:FIRST[RL2]_RLIST:LAST[RL2]_NULLRECORD;
RLIST:LEN[RL]_0;
END;
L_RLIST:LEN[RL]-1;
C_RLIST:FIRST[RL];
FOR I_0 STEP 1 UNTIL L DO
BEGIN
RLADD(RL2,CELL:CAR[C],I);
C_CELL:CDR[C];
END;
END;
INTERNAL MATCHING RECPROC MAPRLIST(RPTR(RLIST) RL;REFERENCE RPTR(ANYCLASS) R);
BEGIN
EXTERNAL RPTR(ANYCLASS) PROCEDURE $REC$(INTEGER OP;RPTR(ANYCLASS) R);
RPTR(CELL) C,CP;
RPTR(RLIST) RL1;
PROCEDURE RL1KILL;
BEGIN
WHILE CNULLRECORD DO
BEGIN
CP_C;
C_CELL:CDR[C];
$REC$(DELETERECORD,C);
END;
RL1_RL1; ! access bug;
$REC$(DELETERECORD,RL1);
END;
CLEANUP RL1KILL;
RL1_RLCOPY(RL);
C_RLIST:FIRST[RL1];
WHILE CNULLRECORD DO
BEGIN
R_CELL:CAR[C];CP_C;C_CELL:CDR[C];
$REC$(DELETERECORD,CP);
SUCCEED;
END;
FAIL;
END;
END "RECAUX"