Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-02 - 43,50242/blipp.bli
There are no other files named blipp.bli in the archive.
00100	! - - - - - - - - BLIPP.BLI  - - - - - - - - -
00200	!
00300	!
00400	MODULE BLIPP(INSPECT,DREGS=5,RSAVE,LOWSEG)=
00500	BEGIN
00600
00700	  MACRO         ! SHORTEN GLOBAL NAMES TO UNREADABLE UNIQUE.
00800	    BLIPPERRCOUNT = ERRCOUNT$,
00900	    BLIPPERRMSG = BERRMS$,
01000	    RELEASESPACE = RELSPACE$,
01100	    RELEASELIST = RELIST$,
01200	    RELEASEMEMBERS = RELMBR$,
01300	    INSERTBEFORE = INSBEF$,
01400	    INSERTAFTER = INSAFT$;
01500
01600	 
01700	  STRUCTURE
01800	    OBJECT[X] = (@.OBJECT+.X)<0,36>;
01900	 
02000	  GLOBAL
02100	    OBJECT MEMOB,
02200	    MAXMEM,           ! MAXIMAL FREELIST SIZE
02300	    MEMSIZE,          ! CURRENT FREELIST SIZE.
02400	    BLIPPERRCOUNT,
02500	    BLIPPERRMSG;
02600	
02700	  EXTERNAL		! I/O ROUTINES.
02800	    WRITE,
02900	    OCTOUT,
03000	    DECOUT,
03100	    OUTMSG;
03200	
03300	  MACRO
03400	    MEM = (.MEMOB - 3)$;
03500	 
03600	  MACRO
03700	    FREECLASS = 0$,
03800	    HEADCLASS = #777777$,
03900	    REPCLASS = #777776$,
04000	    HWNONE = #707070$,
04100	    NONE = #707070707070$;
04200
04300	%_
04400	    IF THE ACTUAL STRING SUPPLIED FOR E IS MAPPED TO OBJECT,
04500	  THE FOLLOWING MACROS GIVE ACCESS TO THE FIELDS OF AN OBJECT.
04600	_%
04700	  MACRO
04800	    PRED(E) = (E[-3]<18,18>)$,
04900	    SUC(E) = (E[-3]<0,18>)$,
05000	    CLASS(E) = (E[-2]<18,18>)$,
05100	    SIZE(E) = (E[-2]<0,18>)$,
05200	    POINTERS(E) = (E[-3])$,
05300	    OBJREF(E) = (E[-1])$;
05400	 
05500	  MACRO
05600	    RIGHTHALF = 0,18$,
05700	    LEFTHALF = 18,18$;
05800	 
05900	  MACRO
06000	    GETSPERR1 = 1$,
06100	    GETSPERR2 = 2$,
06200	    RELSPERR = 3$,
06300	    REMOVERR = 4$,
06400	    INSAFTERR = 5$,
06500	    MKELISTERR = 6$,
06600	    MKEOBJERR = 7$,
06700	    MKEREPERR = 8$,
06800	    INSBEFERR = 9$,
06900	    NOTLISTERR = 10$,
07000	    INCLERR = 11$,
07100	    STKOFLOERR = 13$,
07200	    MAPLISERR = 14$,
07300	    NOCORERR = 15$,
07400	    REPLERR = 12$;
07500	 
07600	  FORWARD
07700	    ISROFUN,
07800	    RELEASESPACE(1),
07900	    GETCORE(0),
08000	    UTAVLISTE(1),		! LONG LIVE PATRIOTISM!
08100	    INNILISTE(2);
08200	
08300	
08400	%>
08500	OUTPUT:
08600	
08700	THE MACROS HERE DESCRIBED PROVIDE AN INTERFACE TO THE BLISS
08800	I/O PACKAGE COMPATIBLE WITH EARLIER I/O IN POOMAS EXEPT THAT
08900	LEFTADJUSTED STRINGS ARE EXPECTED WHERE PREVIOUSLY RIGHT-
09000	ADJUSTED ONES WERE APPROPRIATE.
09100	
09200	TYPE(WORD,LF)
09300	TYPES UP TO 5 CHARACTERS AT THE TTY.  FIRST ARGUMENT SHOULD
09400	BE A LEFTADJUSTED STRING OF AT MOST 5 CHARACTERS, SECOND
09500	ARGUMENT SHOULD BE ODD IF A CR,LF IS DESIRED FOLLOWING
09600	THE STRING.
09700
09800	TYPDEC(N,LF)
09900	OUTPUTS SIGNED DECIMAL INTEGERS, LEADING ZEROES SUPPRESSED.
10000	IF LF IS ODD A CR,LF WILL FOLLOW THE INTEGER.
10100	
10200	
10300	TYPOCT IS A ROUTINE.
10400	
10500	TYPOCT(N,LF)
10600	TYPES THE OCTAL NUMBER N AS AN UNSIGNED NUMBER, FOLLOWED BY
10700	CR,LF IFF LF IS ODD.  LEADING ZEROES ARE SUPPRESSED.
10800
10900	
11000	THE FOLLOWING ROUTINE IS USEFUL DURING DEBUGGING:
11100	
11200	TYPLIS(L)
11300	TYPES THE FIRST 4 WORDS (FEWER IF OBJECT IS SMALLER) OF
11400	EACH MEMBER OF THE LIST AT .L, INCLUDING THE HEAD.
11500	EACH OBJECT ON A SEPARATE LINE, PRECEEDED BY ITS ADDRESS.
11600	FORMAT AS FOR TYPOCT.
11700	VALUE: 0.
11800	<%
11900	
12000	  MACRO			! INTERFACING OLD I/O TO BLISS I/O.
12100	    TYPECRLF = TYPELINE()$,
12200	    TYPDEC(N,LF) = (DECOUT(0,0,N);
12300			   IF LF THEN TYPECRLF)$,
12400	    TYPE(MSG,LF) = (OUTMSG(0,PLIT MSG);
12500			   IF LF THEN TYPECRLF)$;
12600	
12700	  GLOBAL ROUTINE TYPELINE =	! FUDGE, - FIX LATER -
12800	  ( EXTERNAL WRITE;
12900	    WRITE(0,#15);   WRITE(0,#12)
13000	  );
13100	
13200	GLOBAL ROUTINE TYPOCT(N,LF) =
13300	( IF .N LSS 0 THEN
13400	    (OCTOUT(0,-6,.N<18,18>);  OCTOUT(0,-6,.N<0,18>))
13500	  ELSE OCTOUT(0,0,.N);
13600	  IF .LF THEN TYPELINE()
13700	);
13800	
13900	
14000	  GLOBAL ROUTINE TYPLIS(L) =
14100	  BEGIN
14200	    LOCAL M,S;
14300	    MAP OBJECT  L:M;
14400	    M _ .L;
14500	    DO
14600	    ( S _ .SIZE(M);
14700	      IF .S GTR 4 THEN S _ 4;
14800	      TYPOCT(.M,0);   OUTMSG(0,PLIT '   ');
14900	      INCR I FROM .M-3 TO .M-4+.S DO
15000	        ( TYPOCT(@.I,0);   OUTMSG(0,PLIT '   ') );
15100	      TYPELINE();
15200	    )
15300	    UNTIL (M _ .SUC(M)) EQL .L;
15400	    TYPELINE();  TYPELINE();  TYPELINE();
15500	  END;   ! END TYPLIS.
15600
15700	
15800	%>
15900	   ERROR HANDLING:
16000	
16100	DDTBREAK
16200	A DUMMY ROUTINE THAT CAN BE USED TO SET A BREAKPOINT AT
16300	TO FORCE PROGRAM INTO DDT AT PREDETERMINED LOCATIONS.
16400	ONLY ONE BREAKPOINT, AT 'DDTBREAK', NEED BE SET IN DDT
16500	VALUE: 0.
16600	
16700	BLIPPERROR(MSG)
16800	BLIPP WILL CHECK FOR INCONSISTENCIES OF PARAMETERS AND
16900	SIMILAR ERROR CONDITIONS.  WHEN AN ERROR IS DETECTED THE
17000	ROUTINE BLIPPERROR IS CALLED WITH A PARAMETER DESCRIBING THE
17100	ERROR.  BLIPPERROR WILL DECREASE BLIPPERRCOUNT, AND WHEN
17200	THIS REACHES 0 EXECUTION WILL BE ABORTED.  THE ERROR
17300	INDICATOR IS STORED IN BLIPPERRMSG. IN ANY CASE BLIPPERROR
17400	WILL CALL DDTBREAK.
17500	VALUE: .BLIPPERRCOTNT.
17600	<%
17700	  GLOBAL ROUTINE DDTBREAK = (0);
17800
17900	  GLOBAL ROUTINE BLIPPERROR(MSG) =
18000	  BEGIN
18100	    MACHOP HALT = #254;
18200	    EXTERNAL JOBOPC;
18300	    BLIPPERRMSG _ .MSG;
18400	    BLIPPERRCOUNT _ .BLIPPERRCOUNT-1;
18500	    TYPE('ERR= ',0);   TYPOCT(.BLIPPERRMSG,0);  TYPE(' ',0);
18600	    TYPE('CNT= ',0);   TYPOCT(.BLIPPERRCOUNT,1);
18700	    DDTBREAK();
18800	    IF .BLIPPERRCOUNT LEQ 0 THEN HALT(4,JOBOPC,0,1);
18900	    .BLIPPERRCOUNT
19000	  END;   ! END BLIPPERROR.
19100	
19200	
19300	%>
19400	  INITIALIZATION OF BLIPP:
19500	
19600	INITMEM()
19700	CLEARS MEM TO ZEROES, SETS UP A LIST HEAD IN THE FIRST 2 WORDS
19800	AND MAKES THE REST OF MEM ONE LARGE OBJECT OF THE FREELIST.
19900	MEM IS ASSUMED TO BE CONTIGUOUS FROM .MEMOB-3 TO .MEMOB-3+.MEMSIZE.
20000	THIS WILL BE THE CASE WHEN ALL I/O BUFFERS ARE SET UP BEFORE INITBLIPP IS CALLED.
20100	VALUE:  .MEMSIZE - 2.
20200	
20300	INITBLIBB()
20400	INITIALIZES BLIPP VARIABLES ETC, INCLUDING FREELIST.  CORE FOR
20500	THE LATTER OBTAINED BY GETCORE AT HIGH END OF LOWSEGMENT.  THIS
20600	IS SUBSEQUENTLY INITIALIZED AS FREELIST BY INITMEM.
20700	VALUE: .MEMSIZE - 2.
20800	
20900	<%
21000	
21100	  GLOBAL ROUTINE INITMEM =
21200	  BEGIN
21300	    LOCAL OBJECT TEMP;
21400	    INCR I FROM MEM TO MEM+.MEMSIZE-1 BY 1 DO (.I)<0,36> _ 0;
21500	    TEMP _ .MEMOB + 2;
21600	    PRED(MEMOB) _ SUC(MEMOB) _ .TEMP;
21700	    CLASS(MEMOB) _ HEADCLASS;
21800	    SIZE(MEMOB) _ .MEMSIZE-2;
21900	    PRED(TEMP) _ SUC(TEMP) _ .MEMOB;
22000	    CLASS(TEMP) _ FREECLASS;
22100	    SIZE(TEMP) _ .MEMSIZE - 2
22200	  END;   ! END ROUTINE INITMEM.
22300	
22400	  GLOBAL ROUTINE INITBLIPP =
22500	  BEGIN
22600	    EXTERNAL JOBFF,JOBREL;
22700	    LOCAL OBJECT  TEMP;
22800	    BLIPPERRMSG _ 0;
22900	    TEMP _ GETCORE();
23000	    MEMOB _ .TEMP<RIGHTHALF> + 3;    MEMSIZE _ .TEMP<LEFTHALF>;
23100	    JOBFF<RIGHTHALF> _ .JOBREL<RIGHTHALF> +1;
23200	    INITMEM()
23300	  END;   ! END INITBLIPP.
23400
23500	
23600	%>
23700	   MEMORY MANAGEMENT:
23800
23900	THE FREE LIST IS MAINTAINED BY THE FOLLOWING ROUTINES:
24000	
24100	GETCORE()
24200	WILL OBTAIN A BLOCK OF CONTIGUOUS CORE, AT LEAST 4 WORDS, AT THE HIGH
24300	END OF THE LOW SEGMENT.  IF SPACE IS AVAILABLE BETWEEN .JOBFF
24400	AND .JOBREL USE THIS SPACE, OTHERWISE OBTAIN 1024 WORDS FROM THE
24500	MONITOR.  JOBFF IS NOT UPDATED.
24600	VALUE:  0 IF ERRORS, OTHERWISE (SIZE OF BLOCK)^18+ADDRESS OF BLOCK.
24700	
24800	EXPAND()
24900	WILL EXPAND MEM BY CALLING GETCORE UNLESS THE SIZE OF MEM
25000	WOULD PASS .MAXMEM.  CORE SO OBTAINED IS INSERTED AS AN OBJECT
25100	IN THE FREELIST.
25200	VALUE:  0 IF ERRORS, OTHERWISE 1.
25300	
25400	GETSPACE(WDS)
25500	WILL FIND SPACE FOR AN OBJECT OF SIZE .WDS FROM THE FREE
25600	LIST.  THE USER WORDS ARE CLEARED TO ZEROES, SUC AND PRED ARE
25700	SET TO NONE.
25800	VALUE: 0 IF SPACE NOT AVAILABLE, OTHERWISE ADDRESS OF OBJECT.
25900	!
26000	RELEASESPACE(OBJ)
26100	WILL RETURN THE SPACE OF THE OBJECT WITH INDEX .OBJ TO THE
26200	FREE LIST, MERGING IT WITH NEIGHBOURING FREE SPACE IF POSS-
26300	IBLE.
26400	VALUE: 0 IF ERRORS, OTHERWISE 1.
26500	<%
26600	
26700	
26800	ROUTINE GETCORE =
26900	BEGIN
27000	  LOCAL S;
27100	  REGISTER AC;
27200	  MACHOP CALLI = #47, MOVEI = #201;
27300	  EXTERNAL JOBFF,JOBREL;
27400	  IF (S _ .JOBREL<RIGHTHALF> - .JOBFF<RIGHTHALF> +1 ) LSS 4 THEN
27500	  ( AC _ .JOBREL<RIGHTHALF> + 1024;
27600	    MOVEI(VREG,0);
27700	    CALLI(AC,#11);
27800	    MOVEI(VREG,1);
27900	    IF .VREG THEN ( BLIPPERROR(NOCORERR);  RETURN 0);
28000	    S _ .JOBREL<RIGHTHALF> - .JOBFF<RIGHTHALF> +1;
28100	  );
28200	  .S^18 OR .JOBFF<RIGHTHALF>
28300	END;
28400	
28500	ROUTINE EXPAND =
28600	BEGIN
28700	  LOCAL OBJECT NEWOBJ, TMP;
28800	  EXTERNAL JOBFF,JOBREL;
28900	  IF (NEWOBJ _ GETCORE()) EQL 0 THEN RETURN 0;
29000	  IF (TMP _ .MEMSIZE +  .NEWOBJ<LEFTHALF>) GTR .MAXMEM THEN
29100	    RETURN 0;
29200	      ! EXPANSION IS VALID:
29300	  MEMSIZE _ .TMP;
29400	  JOBFF<RIGHTHALF> _ .JOBREL<RIGHTHALF> +1;
29500	  NEWOBJ _ .NEWOBJ + 3;
29600	  POINTERS(NEWOBJ) _ NONE;   CLASS(NEWOBJ) _ 100;
29700	  SIZE(NEWOBJ) _ .NEWOBJ<LEFTHALF>;
29800	  RELEASESPACE(.NEWOBJ)
29900	END;
30000	
30100	  GLOBAL ROUTINE GETSPACE(WDS) =
30200	  BEGIN
30300	    LOCAL OBJECT  L;
30400	    IF .SREG GEQ 0 THEN BLIPPERROR(STKOFLOERR);
30500	    IF .WDS LSS 2 THEN (BLIPPERROR(GETSPERR1); RETURN);
30600	    WHILE 1 DO
30700	    ( L _ .SUC(MEMOB);
30800	      WHILE .L NEQ .MEMOB DO
30900	      ( IF .SIZE(L) LSS .WDS THEN L _ .SUC(L)
31000	        ELSE
31100	        ( IF .SIZE(L) LEQ .WDS+1 THEN
31200	              (UTAVLISTE(.L);  WDS _ .SIZE(L) )
31300	            ELSE
31400	            ( ! SIZE GTR THAN .WDS:
31500	              L _ .L+(SIZE(L) _ .SIZE(L) - .WDS);
31600	              SIZE(L) _ .WDS;
31700	            ); ! END SPLIT-UP OF LARGER OBJECT.
31800	            POINTERS(L) _ NONE;
31900	            CLASS(L) _ 100;        ! FUDGE, FIX LATER!!!!!!!!
32000	            IF .WDS GTR 2 THEN L[-1] _ 0;
32100		    IF .WDS GTR 3 THEN
32200		      BEGIN
32300			REGISTER R1,R2;  MACHOP BLT=#251;
32400			R1<LEFTHALF> _ L[-1]<0,0>;
32500			R1<RIGHTHALF> _ L[0]<0,0>;
32600			R2 _ .WDS+.L;
32700			BLT(R1,-4,R2)
32800		      END;
32900	            SIZE(MEMOB) _ .SIZE(MEMOB) - .SIZE(L);
33000	            RETURN(.L);
33100	      ) ); ! END OF FREE LIST AND NO SPACE FOUND.
33200	      IF NOT EXPAND() THEN ( BLIPPERROR(GETSPERR2);   RETURN );
33300	    );
33400	  END;
33500
33600
33700	  GLOBAL ROUTINE RELEASESPACE(OBJ) =
33800	  BEGIN
33900	    LOCAL L,M;
34000	    MAP OBJECT L:M:OBJ;
34100	    IF .SREG GEQ 0 THEN BLIPPERROR(STKOFLOERR);
34200	    IF .OBJ<RIGHTHALF> EQL HWNONE THEN
34300	      (BLIPPERROR(RELSPERR); RETURN);
34400	    IF .CLASS(OBJ) EQL FREECLASS THEN
34500	      ( BLIPPERROR(RELSPERR);  RETURN);
34600	    IF .POINTERS(OBJ) NEQ NONE
34700	       AND .PRED(OBJ) NEQ .OBJ THEN UTAVLISTE(.OBJ);
34800	    CLASS(OBJ) _ FREECLASS;
34900	    SIZE(MEMOB) _ .SIZE(MEMOB)+.SIZE(OBJ);
35000	    L _ .SUC(MEMOB);  M _ .MEMOB;
35100	    WHILE .L NEQ .MEMOB DO
35200	    ( IF .L LSS .OBJ THEN ( M _ .L; L _ .SUC(L) )
35300	      ELSE
35400	      ( IF .OBJ+.SIZE(OBJ) EQL .L THEN
35500	        ( SIZE(OBJ) _ .SIZE(OBJ)+.SIZE(L);
35600	          UTAVLISTE(.L);
35700	        );
35800	        EXITLOOP;
35900	    ) );
36000	    IF .M NEQ .MEMOB AND .M+.SIZE(M) EQL .OBJ THEN
36100	      SIZE(M) _ .SIZE(M)+.SIZE(OBJ)
36200	    ELSE
36300	      INNILISTE(.OBJ,.SUC(M));
36400	    1
36500	  END;   ! END OF RELEASESPACE.
36600
36700	!
36800	!  OBJECT AND SET CREATION:
36900	!
37000	! THESE ROUTINES ARE USED TO CREATE OBJECTS OF STANDARD
37100	! AND USER-INVENTED KINDS.
37200	!
37300	! MAKELIST
37400	! WILL CREATE A LIST HEAD.
37500	! VALUE: 0 IF ERRORS, OTHERWISE ADDRESS OF HEAD.
37600	!
37700	! MAKEOBJ(WDS,CLASS)
37800	! CREATES AN OBJECT OF .WDS USER WORDS AND CLASS .CLASS.
37900	! VALUE: 0 IF ERRORS, OTHERWISE ADDRESS OF OBJECT.
38000	!
38100	! MAKEREP(0BJ)
38200	! CREATES A REPRESENTATIVE OF OBJECT .OBJ.
38300	! VALUE: 0 IF ERRORS, OTHERWISE ADDRESS OF REP.
38400	!
38500	!
38600	  GLOBAL ROUTINE MAKELIST =
38700	  BEGIN
38800	    LOCAL L;
38900	    MAP OBJECT  L;
39000	    IF (L _ GETSPACE(2)) EQL 0 THEN
39100	      (BLIPPERROR(MKELISTERR);  RETURN);
39200	    CLASS(L) _ HEADCLASS;
39300	    PRED(L) _ SUC(L) _ .L
39400	  END;   ! END MAKELIST.
39500
39600	  GLOBAL ROUTINE MAKEOBJ(WDS,C) =
39700	  BEGIN
39800	    LOCAL L;
39900	    MAP OBJECT  L;
40000	    IF (L _ GETSPACE(.WDS+3) ) EQL 0 THEN
40100	      (BLIPPERROR(MKEOBJERR);   RETURN);
40200	    CLASS(L) _ .C;
40300	    .L
40400	  END;   ! END MAKEOBJ.
40500
40600	  GLOBAL ROUTINE MAKEREP(OBJ) =
40700	  BEGIN
40800	    LOCAL L;
40900	    MAP OBJECT  L;
41000	    IF .OBJ<RIGHTHALF> EQL HWNONE THEN
41100	      (BLIPPERROR(MKEREPERR);  RETURN);
41200	    IF (L_GETSPACE(3)) EQL 0 THEN
41300	      (BLIPPERROR(MKEREPERR);   RETURN);
41400	    CLASS(L) _ REPCLASS;
41500	    OBJREF(L) _ .OBJ;
41600	    .L
41700	  END;   ! END MAKEREP.
41800
41900	%>
42000	REMOVAL FROM AND DESTRUCTION OF LISTS.
42100	
42200	
42300	UTAVLISTE(X)
42400	SERVICE-ROUTINE FOR THE OTHER REMOVAL ROUTINES.  DOES NO PARAMETER
42500	CHECKING.  ASSUMES OBJECT AT .X IS A LIST MEMBER AND REMOVES IT.
42600	VALUE:  .X.
42700	
42800	REMOVE(X)
42900	REMOVES X FROM WHATEVER LIST IT WAS A MEMBER, UNLESS IT
43000	IS A LIST HEADER.
43100	VALUE: 0 IF X IS NONE OR A HEADER, OTHERWISE .X.
43200	
43300	CLEARLIST(S)
43400	REMOVES ALL MEMBERS OF LIST S.
43500	NOTE       NOTE         NOTE!
43600	SHOULD BE USED WITH CAUTION SINCE NON-REFERENCABLE
43700	OBJECTS WILL NOT BE GARBAGECOLLECTED.
43800	VALUE: 0 IF ERRORS, OTHERWISE .S.
43900	
44000	RELEASELIST(S)
44100	WILL REMOVE ALL MEMBERS OF S INCLUDING THE HEAD AND
44200	RELEASE THEIR SPACE TO THE FREE LIST.  0 IS STORED
44300	IN S.
44400	VALUE: 0 IF ERRORS, OTHERWISE 1.
44500	
44600	RELEASEMEMBERS(S)
44700	AS RELEASELIST BUT DOES NOT RELEASE LIST HEAD.
44800	VALUE: 0 IF ERRORS, OTHERWISE .S.
44900	<%
45000	
45100	GLOBAL ROUTINE UTAVLISTE(X) =
45200	BEGIN
45300	  MAP OBJECT X;
45400	  SUC((.PRED(X))) _ .SUC(X);
45500	  PRED((.SUC(X))) _ .PRED(X);
45600	  POINTERS(X) _ NONE;
45700	  .X
45800	END;   !   END OF UTAVLISTE.
45900	
46000	  GLOBAL ROUTINE REMOVE(X) =
46100	  BEGIN
46200	    MAP OBJECT  X;
46300	    IF .X<RIGHTHALF> EQL HWNONE THEN
46400	      ( BLIPPERROR(REMOVERR);  RETURN);
46500	    IF .CLASS(X) EQL HEADCLASS THEN
46600	      ( BLIPPERROR(REMOVERR);  RETURN);
46700	    IF .POINTERS(X) NEQ NONE THEN UTAVLISTE(.X)
46800	    ELSE .X
46900	  END;   ! END REMOVE.
47000
47100	  GLOBAL ROUTINE CLEARLIST(S) =
47200	  BEGIN
47300	    REGISTER M;
47400	    LOCAL L;
47500	    MAP OBJECT L:S;
47600	    IF .CLASS(S) NEQ HEADCLASS THEN
47700	      (BLIPPERROR(NOTLISTERR);   RETURN);
47800	    L _ .SUC(S);
47900	    WHILE .L NEQ .S DO
48000	    ( M _ .SUC(L);
48100	      POINTERS(L) _ NONE;
48200	      L _ .M;
48300	    );
48400	    PRED(S) _ SUC(S) _ .S
48500	  END;   ! END CLEARLIST.
48600
48700	  GLOBAL ROUTINE RELEASEMEMBERS(S) =
48800	  BEGIN
48900	    LOCAL L,M;
49000	    MAP OBJECT  L:S;
49100	    IF .CLASS(S) NEQ HEADCLASS THEN
49200	      (BLIPPERROR(NOTLISTERR);   RETURN);
49300	    L _ .SUC(S);
49400	    WHILE .L NEQ .S DO
49500	    ( M _ .SUC(L);  POINTERS(L) _ NONE;
49600	      RELEASESPACE(.L);
49700	      L _ .M;
49800	    );
49900	    PRED(S) _ SUC(S) _ .S
50000	  END;   ! END RELEASEMEMBERS.
50100
50200	  GLOBAL ROUTINE RELEASELIST(S) =
50300	  BEGIN
50400	    MAP OBJECT  S;
50500	    IF .CLASS(S) NEQ HEADCLASS THEN
50600	      (BLIPPERROR(NOTLISTERR);   RETURN);
50700	    RELEASEMEMBERS(.S);
50800	    RELEASESPACE(.S);
50900	    1
51000	  END;   ! END RELEASELIST.
51100
51200	%>
51300	INSERTION INTO LISTS:
51400	
51500	INNILISTE(X,Y)
51600	SERVICE-ROUTINE FOR THE OTHER INSERTION ROUTINES.  DOES NO PARAMETER CHECKING.
51700	ASSUMES THAT .X AND .Y ARE ADDRESSES OF OBJECTS S.T. Y IS A
51800	LIST MEMBER BUT X IS NOT.  WILL INSERT X BEFORE Y.
51900	VALUE:  .X.
52000	
52100	THE USER SHOULD USE THE FOLLOWING ROUTINES, WHICH CHECK PARAMETERS.
52200	IF X IS ALREADY MEMBER OF SOME LIST IT WILL BE REMOVED
52300	FROM THAT LIST, EXEPT FOR INCLUDE, WHICH WILL CREATE A REP.  NEXT X WILL BE INSERTED INTO ANOTHER
52400	LIST AS FOR THE SPECIFIC FUNCTION INVOLVED. IN CASE OF
52500	ERROR X IS NOT REMOVED.
52600
52700	INSERTAFTER(X,Y)
52800	INSERTS X AFTER Y IN THE LIST WHERE Y IS A MEMBER.
52900	VALUE: 0 IF ERRORS, OTHERWISE .X.
53000	
53100	INSERTBEFORE(X,Y)
53200	AS INSERTAFTER BUT INSERTS X BEFORE Y.
53300	
53400	INCLUDE(X,S)
53500	X IS INSERTED AS THE LAST MEMBER OF THE SET S.
53600	VALUE: 0 IF ERRORS, OTHERWISE .X.
53700	
53800	REPLACE(OLD,NEW)
53900	NEW IS INSERTED INSTEAD OF OLD IN THE LIST WHERE OLD WAS
54000	A MEMBER.  NEITHER OR BOTH ARGUMENTS SHOULD BE HEADS.
54100	VALUE: 0 IF ERRORS, OTHERWISE .OLD
54200	<%
54300	
54400	GLOBAL ROUTINE INNILISTE(X,Y) =
54500	BEGIN
54600	  MAP OBJECT X:Y;
54700	  SUC(X) _ .Y;   PRED(X) _ .PRED(Y);
54800	  SUC((.PRED(Y))) _ .X;   PRED(Y) _ .X
54900	END;   !   END OF INNILISTE.
55000	
55100	  GLOBAL ROUTINE INSERTAFTER(X,Y) =
55200	  BEGIN
55300	    MAP OBJECT  X:Y;
55400	    IF .X<RIGHTHALF> EQL HWNONE OR .Y<RIGHTHALF> EQL HWNONE THEN
55500	      ( BLIPPERROR(INSAFTERR);  RETURN);
55600	    IF .POINTERS(Y) EQL NONE OR .CLASS(X) EQL HEADCLASS THEN
55700	      ( BLIPPERROR(INSAFTERR); RETURN);
55800	    IF .POINTERS(X) NEQ NONE THEN UTAVLISTE(.X);
55900	    INNILISTE(.X,.SUC(Y))
56000	  END;  ! END OF INSERTAFTER.
56100
56200	  GLOBAL ROUTINE INSERTBEFORE(X,Y) =
56300	  BEGIN
56400	    MAP OBJECT  X:Y;
56500	    IF .X<RIGHTHALF> EQL HWNONE OR .Y<RIGHTHALF> EQL HWNONE THEN
56600	      ( BLIPPERROR(INSBEFERR);  RETURN);
56700	    IF .POINTERS(Y) EQL NONE OR .CLASS(X) EQL HEADCLASS THEN
56800	      (BLIPPERROR(INSBEFERR);   RETURN);
56900	    IF .POINTERS(X) NEQ NONE THEN UTAVLISTE(.X);
57000	    INNILISTE(.X,.Y)
57100	  END;   ! END INSERTBEFORE.
57200
57300	  GLOBAL ROUTINE INCLUDE(X,S) =
57400	  ( MAP OBJECT S:X;
57500	    ( IF .X<RIGHTHALF> EQL HWNONE THEN EXITCOND
57600	      ELSE IF .CLASS(X) EQL HEADCLASS THEN EXITCOND
57700	      ELSE IF .CLASS(S) EQL HEADCLASS THEN EXITCOMPOUND;
57800	      BLIPPERROR(INCLERR);   RETURN
57900	    );
58000	    IF .POINTERS(X) NEQ NONE THEN
58100	    ( IF (X _ MAKEREP(.X)) EQL 0 THEN RETURN);
58200	    INNILISTE(.X,.S)
58300	  );     ! END INCLUDE
58400
58500	  GLOBAL ROUTINE REPLACE(OLD,NEW) =
58600	  ( MAP OBJECT OLD:NEW;
58700	    IF .OLD<RIGHTHALF> EQL HWNONE
58800	      OR .NEW<RIGHTHALF> EQL HWNONE
58900	    THEN
59000	      (BLIPPERROR(REPLERR);  RETURN);
59100	    IF .POINTERS(OLD) EQL NONE
59200	      OR (.CLASS(OLD) EQL HEADCLASS
59300	           AND .CLASS(NEW) NEQ HEADCLASS)
59400	      OR (.CLASS(NEW) EQL HEADCLASS
59500	           AND .CLASS(OLD) NEQ HEADCLASS)
59600	    THEN
59700	      (BLIPPERROR(REPLERR);   RETURN)
59800	    ELSE
59900	      ( INNILISTE(.NEW,.OLD);
60000	        UTAVLISTE(.OLD)
60100	  )   );   ! END REPLACE.
60200
60300
60400
60500	!ACCESSING LIST MEMBERS:
60600	!
60700	! FIRST(S)
60800	! FINDS FIRST MEMBER OF LIST .S.
60900	! VALUE: 0 IF S IS NOT A LIST, NONE IF IT IS EMPTY, OTHERWISE
61000	!        ADDRESS OF FIRST MEMBER.
61100	!
61200	! LAST(S)
61300	! ANALOGOUS TO FIRST.
61400	!
61500	! FIND(S,C,I,X)
61600	! ATTEMPTS TO FIND A MEMBER OF S OF CLASS C WHOSE .I'TH
61700	! WORD CONTAINS .X.
61800	! VALUE: 0 IF S IS NOT A LIST, NONE IF UNSUCCESSFUL,
61900	!        OTHERWISE ADDRESS OF MEMBER.
62000	!
62100	! MAPLIST(S,F)
62200	! APPLIES THE FUNCTION OR ROUTINE F TO ALL MEMBERS OF THE
62300	! LIST S EXEPT THE HEAD.
62400	! F TAKES ONE ARGUMENT, THE CURRENT OBJECT TO WHICH IT SHOULD
62500	! BE APPLIED.  MAPLIST HAS A POINTER TO THE NEXT MEMBER OF
62600	! THE LIST, HENCE F MAY REMOVE ITS ARGUMENT IF DESIRED,
62700	! BUT NOT ITS SUCCESSOR.  VALUE OF F SHOULD BE NONZERO UN-
62800	! LESS ERRORS OCCUR.  IF 0 IS RETURNED BY F, MAPLIST WILL
62900	! EXECUTE A RETURN(0) IMMEDIATELY.
63000	! VALUE: 0 IF ERRORS, OTHERWISE 1.
63100	!
63200	!
63300	  GLOBAL ROUTINE FIRST(S) =
63400	  BEGIN
63500	    MAP OBJECT  S;
63600	    IF .CLASS(S) NEQ HEADCLASS THEN
63700	      (BLIPPERROR(NOTLISTERR);   RETURN);
63800	    IF .SUC(S) NEQ .S THEN .SUC(S) ELSE NONE
63900	  END;    ! END FIRST.
64000
64100	  GLOBAL ROUTINE LAST(S) =
64200	  BEGIN
64300	    MAP OBJECT  S;
64400	    IF .CLASS(S) NEQ HEADCLASS THEN
64500	      (BLIPPERROR(NOTLISTERR);   RETURN);
64600	    IF .PRED(S) NEQ .S THEN .PRED(S) ELSE NONE
64700	  END;   ! END LAST.
64800
64900	  GLOBAL ROUTINE FIND(L,C,I,X) =
65000	  BEGIN
65100	    LOCAL M;
65200	    MAP OBJECT  L:M;
65300	    IF .CLASS(L) NEQ HEADCLASS THEN
65400	      (BLIPPERROR(NOTLISTERR);   RETURN);
65500	    M _ .SUC(L);
65600	    WHILE .M NEQ .L DO
65700	    ( IF .CLASS(M) EQL .C THEN
65800	        IF .M[.I] EQL .X THEN RETURN(.M);
65900	      M _ .SUC(M);
66000	    );
66100	    NONE
66200	  END;   ! END FIND.
66300
66400	  GLOBAL ROUTINE MAPLIST(L,F) =
66500	  BEGIN
66600	    LOCAL X,Y;
66700	    MAP OBJECT L:X;
66800	    IF .CLASS(L) NEQ HEADCLASS OR NOT ISROFUN(.F) THEN
66900	      ( BLIPPERROR(MAPLISERR);   RETURN);
67000	    X _ .SUC(L);
67100	    WHILE .X NEQ .L DO
67200	    ( Y _ .X;   X _ .SUC(X);
67300	      (IF (.F)(.Y) EQL 0 THEN RETURN);
67400	    );
67500	    1
67600	  END;   ! END MAPLIST.
67700
67800	%>
67900	MISCELLANEOUS ROUTINES:
68000	
68100	
68200	EMPTY(S)
68300	VALUE: 1 IF S IS AN EMPTY LIST, 0 IF S IS A NON-EMPTY
68400	       LIST OR -2 IF S IS NOT A HEAD.
68500	
68600	CARDINAL(S)
68700	VALUE: -1 IF S IS NOT A LIST HEAD, OTHERWISE THE # OF
68800	       MEMBERS DISTINCT FROM THE HEAD.
68900	
69000	ISROFUN(P)
69100	WILL ATTEMPT TO CHECK WHETHER .P IS THE ADDRESS (ENTRYPOINT) OF A ROUTINE
69200	OR FUNCTION.
69300	IF @.P IS A 'PUSH 0,2' THEN WE'RE OK, OTHERWISE IF @.P<27,9> IS A 'JSP'
69400	AND @@.P IS A 'PUSH 0,2' WE'RE ALSO OK, OTHERWISE IT MAY STILL
69500	BE A ROUTINE WITH NO PARAMETERS, LOCALS OR SAVED REGISTERS.  IN
69600	THAT CASE @(.P-1) = 1 PROVIDED THE INSPECT OPTION WAS USED DURING COMPILATION.
69700	HENCE:  IF INSPECT OPTION WAS USED NO PROCEDURES WILL FLUNK THIS TEST,
69800	BUT SOME NON-PROCEDURES WILL PASS IT.
69900	VALUE: 0 OR 1 IF SURE, 3 IF UNCERTAIN.
70000	<%
70100	
70200	  GLOBAL ROUTINE EMPTY(L) =
70300	  BEGIN
70400	    MAP OBJECT  L;
70500	    IF .CLASS(L) NEQ HEADCLASS THEN
70600	      (BLIPPERROR(NOTLISTERR);   RETURN -2)
70700	    ELSE
70800	    IF .SUC(L) EQL .L THEN 1
70900	    ELSE 0
71000	  END;   ! END EMPTY.
71100
71200	  GLOBAL ROUTINE CARDINAL(X) =
71300	  BEGIN
71400	    REGISTER N;
71500	    LOCAL L;
71600	    MAP OBJECT  L:X;
71700	    N _ 0;
71800	    IF .CLASS(X) NEQ HEADCLASS THEN
71900	      (BLIPPERROR(NOTLISTERR);   RETURN(-1));
72000	    L _ .SUC(X);
72100	    WHILE .L NEQ .X DO
72200	    ( N_.N+1;   L _ .SUC(L));
72300	    .N
72400	  END;   ! END CARDINAL.
72500	
72600	GLOBAL ROUTINE ISROFUN(P) =
72700	( IF @@P EQL #261000000002 THEN RETURN 1 ELSE
72800	  IF .(@P)<27,9> EQL #265 THEN
72900	  ( IF @@@P EQL #261000000002 THEN RETURN 1
73000	    ELSE RETURN 0
73100	  );
73200	  IF @(@P-1) EQL 1 THEN 3 ELSE 0
73300	);   !   END OF ISROFUN.
73400	
73500	END   ! OF BLIPP.
73600	ELUDOM