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