// XPAL3 LAST MODIFIED ON FRIDAY, 12 JUNE 1970 // AT 5:37:38.68 BY R MABEE >>> FILENAME 'XPAL3' // // *********** // * * // * XPAL3 * // * * // *********** // >>> GET 'XPALHD' >>> EJECT // XPAL3A LET R_FINISH() BE $( WRITES('*N*NEXECUTION FINISHED*N') TERMINATE1() $) AND PRINT() BE $( SPLIT1() PRINTB(A) A := DUMMYRV NEXTLV11() $) AND USERPAGE() BE $( SPLIT1() CONTROL(OUTPUT, -1) A := DUMMYRV NEXTLV11() $) AND STEM() BE $( SPLIT1(); B := H3*(A) A := NILSRV UNLESS H2*(B)=STRING DO $( ERROR1('STEM', B, 0) ERRLVDBG() RETURN $) A := LIST(4, STRING, A, H4*(B) ) NEXTLV11() $) AND STERN() BE $( SPLIT1(); A := H3*(A) UNLESS H2*(A)=STRING DO $( ERROR1('STERN', A, 0) A := NILSRV ERRLVDBG() RETURN $) A := H3*(A) NEXTLV11() $) AND CONC() BE $(1 A := H3*(S*(STACKP-1)) UNLESS H2*(A)=M_TUPLE & H3*(A)=2 DO CONCERR:$( ERROR1('CONC', A, 0) SPLIT1() A := NILSRV ERRLVDBG() RETURN $) $( LET X, Y = H2*(H3*(H4*(A))), H2*(H3*(H5*(A))) UNLESS ( X=STRING LOGOR X=NILS ) & ( Y=STRING LOGOR Y=NILS ) GOTO CONCERR $( LET V = VEC 512 B, X := H3*(H4*(A)), 1 UNTIL H2*(B) = NILS DO $( V*(X) := H4*(B) B := H3*(B) X := X+1 $) IF X=1 DO $( B := H3*(H5*(A)) SPLIT1() A := B NEXTLV11() RETURN $) B := LIST(4, STRING, 0, V*(I)) A := B FOR I = 2 TO X-1 DO $( H3*(A) := LIST(4, STRING, 0, V*(I)) A := H3*(A) $) H3*(A) := H3*(H5*(H3*(S*(STACKP-1)))) SPLIT1() A := B NEXTLV11() $)1 AND ATOM() BE $( SPLIT1() SWITCHON H2*(H3*(A)) INTO $( CASE M_TRUE: CASE M_FALSE: CASE NUMBER: CASE REAL: CASE STRING: CASE NILS: A := TRUERV NEXTLV11() RETURN $) A := FALSERV NEXTLV11() $) AND NULL() BE $( SPLIT1() A := H2*(H3*(A))=M_TUPLE & H3*(H3*(A))=O -* TRUERV, FALSERV NEXTLV11() $) AND LENGTH() BE $( SPLIT1() UNLESS H2*(H3*(A))=M_TUPLE DO $( ERROR1('ORDER', A, 0) A := LIST(3, NUMBER, 0) ERRLVDBG() RETURN $) A := LIST(3, NUMBER, H3*(H3*(A)) ) NEXTLV11() $) AND ISTRUTHVALUE() BE $( SPLIT1() SWITCHON H2*(H3*(A)) INTO $( CASE M_TRUE: CASE M_FALSE: A := TRUERV NEXTLV11() RETURN $) A := FALSERV NEXTLV11() $) AND ISNUMBER() BE $( SPLIT1() A := H2*(H3*(A))=NUMBER -* TRUERV, FALSERV NEXTLV11() $) AND ISSTRING() BE $( SPLIT1() SWITCHON H2*(H3*(A)) INTO $( CASE STRING: CASE NILS: A := TRUERV NEXTLV11() RETURN $) A := FALSERV NEXTLV11() $) AND ISFUNCTION() BE $( SPLIT1() SWITCHON H2*(H3*(A)) INTO $( CASE CLOSURE: CASE BASICFN: A := TRUERV NEXTLV11() RETURN $) A := FALSERV NEXTLV11() $) AND ISENVIRONMENT() BE $( SPLIT1() A := H2*(H3*(A))=JJ -* TRUERV, FALSERV NEXTLV11() $) AND ISLABEL() BE $( SPLIT1() A := H2*(H3*(A))=LABEL -* TRUERV, FALSERV NEXTLV11() $) AND ISTUPLE() BE $( SPLIT1() A := H2*(H3*(A))=M_TUPLE -* TRUERV, FALSERV NEXTLV11() $) AND ISREAL() BE $( SPLIT1() A := H2*(H3*(A))=REAL -* TRUERV, FALSERV NEXTLV11() $) AND ISDUMMY() BE $( SPLIT1() A := H2*(H3*(A))=M_DUMMY -* TRUERV, FALSERV NEXTLV11() $) AND SHARE() BE $( SPLIT1(); A := H3*(A) UNLESS H2*(A)=M_TUPLE & H3*(A)=2 DO $( ERROR1('SHARE', A, 0) A := FALSERV ERRLVDBG() RETURN $) A := H4*(A)=H5*(A) -* TRUERV, FALSERV NEXTLV11() $) >>> EJECT // XPAL3B MANIFEST $( NFIELD=$867700000000; N1=$8100000000 $) LET STON() BE $(1 SPLIT1(); A := H3*(A) UNLESS H2*(A)=STRING DO $( ERROR1('STOI', A, 0) A := LIST(3, NUMBER, 0) ERRLVDBG() RETURN $) $( LET B = 0 WHILE H2*(A)=STRING DO $( B := B*10 + H4*(A) - '0' A := H3*(A) $) A := LIST(3, NUMBER, B) NEXTLV11() $)1 AND CTON() BE $( SPLIT1() A := H3*(A) UNLESS H2*(A)=STRING LOGAND H2*(H3*(A))=NILS DO $( ERROR1('CTOI', A, 0) A := LIST(3, NUMBER, 0) ERRLVDBG() RETURN $) A := LIST(3, NUMBER, H4*(A) ) NEXTLV11() $) AND NTOC() BE $( SPLIT1() A := H3*(A) UNLESS H2*(A)=NUMBER LOGAND H3*(A) LS 256 LOGAND H3*(A) GE 0 DO $( ERROR1('ITOC', A, 0) A := NILSRV ERRLVDBG() RETURN $) A := LIST(4, STRING, NILSRV, H3*(A) ) NEXTLV11() $) AND NTOR() BE $( SPLIT1(); A := H3*(A) UNLESS H2*(A)=NUMBER DO $( ERROR1('ITOR', A, 0) A := LIST(3, REAL, 0) ERRLVDBG() RETURN $) A := LIST(3, REAL, ITOR(H3*(A)) ) NEXTLV11() $) AND RTON() BE $( SPLIT1(); A := H3*(A) UNLESS H2*(A)=REAL DO $( ERROR1('RTOI', A, 0) A := LIST(3, NUMBER, 0) ERRLVDBG() RETURN $) A := LIST(3, NUMBER, RTOI(H3*(A)) ) NEXTLV11() $) AND RDCHAR() BE $( SPLIT1() A := LIST(2, NILS) IF LINEP>LINET DO $(2 UNLESS DATAFLAG GOTO ENDDATA IF CH='#' DO TEST DATAFLAG THEN $( DATAFLAG := FALSE NEXTLV11() // VALUE OF NILS INDICATES EOD RETURN $) OR ENDDATA: $( WRITES('*NEND OF DATA FILE ENCOUNTERED*N*N') TERMINATE1() $) LINET := LINEV LINET*(0) := CH UNTIL CH='*N' DO $( READCH(INPUT, LVCH) LINET := LINET + 1 LINET*(0) := CH $) READCH(INPUT, LVCH) LINEP := LINEV $)2 A := LIST(4, STRING, A, LINEP*(O) ) LINEP := LINEP + 1 NEXTLV11() $) AND R_TABLE() BE $(1 SPLIT1(); A := H3*(A) UNLESS H2*(A) = M_TUPLE & H3*(A) = 2 DO TABLERR:$( ERROR1('TABLE', A, 0) A := NILRV ERRLVDBG() RETURN $) $( LET N = H3*(H4*(A)) UNLESS H2*(N) = NUMBER GOTO TABLERR N := H3*(N) B := H3*(H5*(A)) A := NODE(N+3) A*(0), A*(1), A*(2) := N+3, M_TUPLE, N FOR I = 3 TO N+2 DO A*(I) := LIST(3, LVALUE, B) NEXTLV11() $)1 AND DIAGNOSE() BE $(1 LET N, I = 0, 1000 A := S*(STACKP-1) S*(STACKP-1) := LIST(3, LVALUE, DUMMYRV) // RETURN VALUE //REPLACES ARGUMENT ON STACK C := C+1 IF H2*(H3*(A))=NUMBER DO I := H3*(H3*(A)) ERRORLV := LIST(3, LVALUE, LIST(3, BASICFN, LASTFN) ) IF NSET DO // 2 SUCCESSIVE EXECUTIONS OF DIAGNOSE REQUIRE // AN INTERVENING MARKING PHASE $( MARK() LISTL := LISTV $) // TAKE ADVANTAGE OF THE EXTRA // MARKING PHASE NSET := TRUE CONTROL(OUTPUT, -1) WRITES('THE CURRENT ENVIRONMENT IS:*N*N') A := E Q := S IF H4*(S)=RESTARTC // TRUE IFF CALL IS FROM COMDBG DO LASTFN1(0) // PEEL OFF TOP STACK NODE L: WRITES('*TVARIABLE*TRVALUE*N*N') WHILE H4*(A) NE 0 DO $(2 LET M = H1*(A) LOGAND NFIELD TEST M NE 0 THEN $( WRITENODE(M) WRITES('ETC*N') BREAK $) OR $( N := N+N1 H1*(A) := H1*(A) LOGOR N WRITENODE(N) A := H3*(A) $)2 I := I-1 A := H6*(Q) CONTROL(OUTPUT, 3) UNLESS LASTFN1(1) DO FINI: $( CONTROL(OUTPUT, -1) RETURN $) IF I LE 0 GOTO FINI WRITES('*N*NTHE ENVIRONMENT IN WHICH ') WRITES('THE ABOVE APPLICATION TAKES PLACE IS:*N*N') GOTO L $)1 AND LASTFN() BE $( S*(STACKP-1) := LIST(3, LVALUE, DUMMYRV) // RETURN VALUE // REPLACES ARGUMENT ON STACK C := C+1 CONTROL(OUTPUT, 2) Q := S IF H4*(S)=RESTARTC // TRUE IFF CALL IS FROM COMDBG DO LASTFN1(0) // PEEL OFF TOP STACK NODE UNLESS LASTFN1(1) DO WRITES('ERROR OCCURRED IN OUTER LEVEL OF PROGRAM*N') CONTROL(OUTPUT, 3) $) AND LOOKUPINE() BE $(1 SPLIT1(); A := H3*(A) UNLESS H2*(A) = M_TUPLE & H3*(A) = 2 DO LERR: $( ERROR1('LOOKUPINE', A, 0) A := NILRV ERRLVDBG() RETURN $) $( LET X, I, L = H3*(H5*(A)), 1, NAMECHAIN LET VP = VEC 10 LET V = VEC 40 B := H3*(H4*(A)) UNLESS H2*(B)=STRING & H2*(X)=JJ GOTO LERR WHILE H2*(B)=STRING DO $( V*(I) := H4*(B) B := H3*(B) I := I+1 $) V*(0) := I-1 PACKSTRING(V, VP) I := ( I-1 ) /BYTESPERWORD + 1 UNTIL L=0 DO $(2 LET V = L*(1) IF VP*(O)=V*(0) DO $(3 IF I=1 BREAK IF VP*(1)=V*(1) DO $( IF I=2 BREAK IF VP*(2)=V*(2) DO $( IF I=3 BREAK IF VP*(3)=V*(3) DO $( IF I=4 BREAK IF VP*(4)=V*(4) DO $( IF I=5 BREAK $)3 L := L*(0) $)2 TEST L=0 THEN I := VP OR I := L*(1) A := LVOFNAME(I, H5*(X)) TEST A=NILRV THEN ERRLVDBG() OR NEXT11() $)1 AND SAVEENV() BE $( SPLIT1() A := LIST(5, JJ, H4*(S), H5*(S), H6*(S) ) NEXTLV11() $)