%BEGIN %EXTERNALROUTINESPEC DISCONNECT(%STRING(63) S) %EXTERNALROUTINESPEC CLOSESM(%INTEGER CH) %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %SYSTEMROUTINESPEC FINFO(%STRING(15) S,%INTEGER LEV,%C %RECORDNAME R, %INTEGERNAME FLAG) %EXTERNALSTRINGFNSPEC DATE %EXTERNALROUTINESPEC LIST(%STRING(63) S) %EXTERNALSTRINGFNSPEC TIME %EXTERNALLONGREALFNSPEC CPUTIME %EXTERNALINTEGERFNSPEC SMADDR(%INTEGER CHANN,%INTEGERNAME LENGTH) %EXTERNALROUTINESPEC DEFINE(%STRING (65) S) %EXTERNALROUTINESPEC PERMIT FILE(%STRING (65) S) %EXTERNALROUTINESPEC NEWSMFILE(%STRING (63) S) %EXTERNALROUTINESPEC CHERISH(%STRING (63) S) %EXTERNALROUTINESPEC PROMPT(%STRING(15) M) %EXTERNALROUTINESPEC DESTROY(%STRING(65) S) %EXTERNALROUTINESPEC CLOSESTREAM(%INTEGER CH) %EXTERNALREALFNSPEC RANDOM (%INTEGERNAME I,%INTEGER J) %EXTERNALINTEGERFNSPEC TESTINT(%INTEGER C,%STRING(15) INT) %EXTERNALROUTINESPEC RENAME(%STRING (65) S) %EXTERNALROUTINESPEC CLEAR(%STRING(65) S) %ROUTINESPEC BADERROR(%STRING(80) ERRMESS,%INTEGER CULPRIT) %ROUTINESPEC APPLYUSR(%INTEGER ENVIR,FUN,TSTFLG,VAL,%C %INTEGERNAME SEVERITY) %ROUTINESPEC NOOLINE(%INTEGER N) %ROUTINESPEC PRSTRING(%STRING(255) WORD) %INTEGERFNSPEC UNSTACK %ROUTINESPEC PRINTLIST(%INTEGER LIST) %ROUTINESPEC PRINTEL(%INTEGER I) %INTEGERFNSPEC HD(%INTEGER LIST) %INTEGERFNSPEC TL(%INTEGER LIST) %ROUTINESPEC PRINTLINE(%INTEGER LINE) %INTEGERFNSPEC READLINE %ROUTINESPEC LOGO(%INTEGER STKTOP,ENVIR,SEVERITY) %ROUTINESPEC DUMP(%STRING(80) ERRMESS) %INTEGER FLENGTH,FSTART; ! FOR FILE MAPPING %INTEGER EUNAD; ! FOR ADDTESS OF EMAS USER NAME %BYTEINTEGERARRAY EUNBYTE(1:7); ! USERNAME %STRING(6) %NAME EMASUSER; ! AS A STRING %STRING(20) MASWRITE,MASREAD,MASDIR ! ! ! WORD AREA AND NUMBER DECLARATIONS ! %STRINGARRAYNAME WA %STRING(64)%ARRAYFORMAT SFORM1(0:1022); ! WORD TABLE %OWNINTEGER WM=1,NM=4; ! WORD MARKER,NUMBER MARKER %OWNINTEGER T8=X'FF000000' %INTEGER NUMTOP,NUMBOT; ! NUMBER RANGE DELIMITERS %OWNINTEGER RANSEED=50003 %STRING(64) %NAME WORK1 %INTEGER LOGOTIME %INTEGERARRAY INTSTR(1:20) %STRING(4) SPACE4 %INTEGERNAME HASHVAL,LBRAK,RBRAK,DOTS,EMPTY,UNDEF, %C COMMA,QUOTE,LPAR,RPAR,MINUS,IF,THEN,ELSE,CLOSE,WHILE,%C TRUE,FALSE,END,DELETE,UNDO,UNDOS,TO,DO,ERR,LOGONAME,%C LANGBRKS,RANGBRKS,QUIT,BREAK,SPACE1,TAB,ENEL %INTEGERARRAY NAMES(1:100); ! CONTAINS HASHED VALUES OF ! SPECHARS AND RESERVED NAMES %OWNINTEGERARRAY SPECHAR(1:14)=':','<','>','''','(',')','*', '+',',','-','/','=','[',']' %INTEGER PRNUM %STRING(3) PROMP %INTEGER EVALIMIT,EVALCNT ! ! FUNCTION SPEC INFO IS HELD IN ARRAY FNVAL WHICH IS ! PARALLEL TO WA AND IS ACCESSED DIRECTLY USING ! WORD INDEX. ! EACH ENTRY IN FNVAL WILL BE ONE OF THE FOLLOWING.... ! ! FNVAL ENTRY ! FUNCTION TYPE B4 B3 B2 B1 ! 1) SYSTEM PREFIX TRACEFLAG/1 - SWITCH ARGNO ! 2) SYSTEM INFIX TRACEFLAG/2 - SWITCH PRECEDENCE ! 3) SYSTEM INTERP 4 - SWITCH - ! 4) USER PREFIX TRACEFLAG/8 LA(INDEX) ARGNO ! 5) UNDEFINED 0 0 0 0 ! ! ! FUNCTION SPEC AREA DECLARATIONS ! %INTEGERARRAYNAME FNVAL,OLDFN,ASSOCWA %INTEGERARRAYFORMAT INTFORM1 (0:1022) ! OLDFN HAS OLD FNVAL ENTRY WHEN FN REDEFINED. ! ASSOCWA HAS OBJECT ASSOCIATION POINTER INTO LIST SPACE. ! ASSOCWA USED ONLY BY MAKEASSOC,GETASSOC,AND REMASSOC %OWNINTEGER SYSPRE=X'1000000',INFIX=X'2000000',INTERP=X'4000000',%C USERPRE=X'8000000' %OWNINTEGER TTY=0,DISC=1 %INTEGER DEVICE,INDEX,NEWFN,CACTFILE,MLEN,ULEN %STRING(10) USERFILE %BYTEINTEGERNAME MDENTS,TDENTS %STRINGARRAYNAME USERNAM,TEMPUSER %INTEGERNAME UDENTS,UNFS,TEMPENTS,TEMPUNFS %STRINGARRAYNAME DIRNAM,TEMPNAM %INTEGERARRAYNAME DIRVAL,TEMPVAL %BYTEINTEGERARRAYNAME FNTEXT,TEMPTEXT %STRING(64) %ARRAYFORMAT UF(1:189) %STRING(64) %ARRAYFORMAT NF(1:118) %INTEGERARRAYFORMAT VF(1:118) %BYTEINTEGERARRAYFORMAT TF(1:57344) %OWNINTEGER B1B=X'7F',B2=X'FF00',B4=X'3F000000',M16=X'FFFF00' %OWNINTEGER TRACEFLG=X'C0000000',UNMASK=X'3FFFFFFF' %OWNINTEGER TRACE1=X'40000000',TRACE2=X'80000000' %OWNINTEGER RESTART=0; ! SET BY BADERROR FOR REINIT %INTEGER INDENT ! ! USER STACK DECLARATIONS %INTEGERARRAYNAME STK %INTEGER STKTOP,STKPNT ! ! ! SYSTEM STACK DECLARATONS %INTEGERARRAYNAME SYSTK %INTEGERARRAYFORMAT INTFORM2(1:2000) %INTEGER SYSTKPNT ! ! ! ! ! LIST AREA DECLARATIONS ! %INTEGERARRAYNAME LA %INTEGERARRAYFORMAT INTFORM3(1:65536) ! ALL LIST STRUCTURE IS CONSTRUCED IN LA. ! LA IS DIVIDED INTO THREE PARTS. THE FIRST AND SECOND PARTS ARE ! USED AS THE TWO SEMISPACES FOR LISTS GENERATED BY THE USER AND BY ! THE INPUT READER. ONLY ONE SEMISPACE IS ACTIVE AT ONE TIME, THE ! COLLECTOR COPYING FROM ONE TO THE OTHER. ! THE THIRD PART IS USED FOR FUNCTION DEFINITIONS AND IS NEVER ! COLLECTED. %OWNINTEGER LA1B=1,LA1T=24576,LA2B=24577,LA2T=49152,LAFNB=49153, %C LAFNT=65536 ! TOP AND BOTTOM VALUES OF VARIOUS LIST SPACES %INTEGER CLECTFLG; ! GARBAGE COLLECT FLAG %INTEGER LISTOP,LPOINT,LPOINT1,LABASE,SEMISIZE ! LPOINT IS FREE POINTER TO COLLECTABLE LIST AREA ! LPOINT1 IS FREE POINTER TO UNCOLLECTABLE AREA ! LABASE IS BASE OF CURRENT SEMISPACE ! SEMISIZE IS SIZE OF SEMISPACE ! %REAL CFRACT; ! GARBAGE COLLECT WHEN CFRACT OF SPACE USED %INTEGER QUOTEON,BLEVEL; ! USED BY LIST READER %INTEGERNAME NIL %STRING(1) SEP; ! USED BY PRINTER %OWNSTRING(1) STERMIN=' '; ! NL ASSSTRING %OWNINTEGER TERMIN=' '; ! NL AS SYMBOL %INTEGER CHAROUT %INTEGER ENUF %OWNINTEGER LM=2 ! ! ! ENVIRONMENT DECLARATIONS ! %INTEGERARRAYNAME BNAME,BVALUE %INTEGERARRAYFORMAT INTFORM4(1023:3000) %INTEGERARRAYFORMAT INTFORM5(0:3000) %INTEGER BASENVIR,TOPMARK ! ! ERROR AND USER INTERUPPT RECOVERY ! ! ERROR RECOVERY IS CONTROLLED BY THREE FLAGS - JUMPFLAG,JUMPOUT ! AND SENDFLAG. ! JUMPFLAG=1 WITH SENDFLAG=0 TRIGGERS A SEQUENCE OF RETURNS FROM THE ! ERROR ROUTINE TO THE LAST ACTIVATION OF LOGO. ! RETURNS THRU LOGO TO EARLIER ACTIVATIONS IS CONTROLLED BY JUMPOUT ! IF JUMPOUT =0 NO RETURN PAST THE LAST ACTIVATION OCCURS. THIS IS THE ! CASE FOR SIMPLE ERRORS (IE OUTSIDE USER FUNS). ! IF JUMPOUT=-1 A NORMAL RETURN THRU THE LAST LOGO IS OBTAINED. THIS ! CAUSES THE LAST SUSPENDED PROCESS TO BE CONTINUED. JUMPOUT IS SET ! TO -1 BY LOGO FUN CONTINUE. ! IF JUMPOUT>0 ,THAT MANY LOGOS ARE RETURNED FROM. JUMPOUT IS SET ! TO N BY ABORT N, AND TO 100 BY QUIT. ! WHENEVER BASE LEVEL IS REACHED (WHEN PROMPT NUMBER IS 1), THE SETTING ! OF JUMPOUT IS IGNORED. ! ! JUMPFLAG=1 WITH SENDFLAG>0 TRIGGERS A SERIES OF RETURNS FROM THE ! ERROR ROUTINE TO THE LAST ACTIVATION OF APPLYUSR. ! RETURNS THRU APPLYUSR ARE CONTROLLED BY THE ACTUAL VALUE ! OF SENDFLAG, THAT MANY RETURNS BEING MADE. THIS IS USED TO SEND BACK ! A USER SUPPLIED VALUE AS THE RESULT OF A NAMED USERFN IN THE ! CURRENT NEST. SENDFLAG IS SET BY SENDBACK IN APPLYSYS. ! ! %INTEGER JUMPFLAG,JUMPOUT,SENDFLAG,LIBLOAD %INTEGER QUITFLAG,HOLDFLAG; ! USER INT FLAGS ! ! ! WORD AREA ! ! ! WORDS (EXCLUDING NUMBERS) ARE HELD UNIQUELY IN STRING ARRAY WA ! AND ARE REPRESENTED BY AN INTEGER CARRYING THE WORD MARKER AND THE ! INDEX IN WA. ! NUMBERS ARE REPRESENTED BY AN INTEGER CARRYING THE ! BINARY VALUE OF THE NUMBER IN THE TOP THREE BYTES AND THE ! NUMBER MARKER IN THE BOTTOM BYTE. ! FUNCTION PUT IS USED TO TRANSFORM WORDS INCLUDING NUMBERS ! TO INTERNAL FORM. IF THE WORD IS A NUMBER IT IS CONVERTED TO ! BINARY OTHERWISE IT IS HASHED. ! FUNCTION HASH PLACES A WORD INTO WA. AN OPEN HASH IS USED STARTING ! WITH A KEY GENERATD BY FUNCTION HASHFUN. THE KEY IS INCREMENTED ! WHEN NECESSARY BY 1, IN ORDER TO KEEP THE SEARCH AREA TO A PAGE ! OR SO. ! ! ! CODE INSERTED TO MONITOR HASHFN ! LOGO COMMAND HASHINFO ! %SHORTINTEGERARRAY HASHINFO(0:1022) %INTEGER HASH1023,HASH1024 ! ! HASHINFO IS PARALLEL TO WA ! HASH1023 HOLDS TOTAL NO OF ACCESSES OF WA ! HASH1024 HOLDS TOTAL NO OF WORDS HASHED ! %INTEGERFN HASH(%STRING(64) WORD) %INTEGER WPOINT,FULLMARK,HASH %STRING(64) W ! %INTEGERFN HASHFUN WORK1=SPACE4; ! FIRST FOUR CHARS OF WORD USED. FILL WITH SPACES WORK1=WORD; ! IN CASE ACTUAL WORD LESS THAN FOUR %RESULT=HASHVAL-1023*(HASHVAL//1023) ! HASHVAL IS EQUIVALENCED TO FIRST FOUR CHARS OF WORK1 IN INITIALISE %END; ! END HASHFUN ! FULLMARK=0; ! USED TO TELL IF TABLE FULL WPOINT=HASHFUN; ! GENERATE KEY HASH=WPOINT LP:W=WA(WPOINT); ! RETRIEVE WORD AT KEY HASH1023=HASH1023+1 %IF W='?' %THENSTART; ! NOT YET USED SO WA(WPOINT)=WORD; ! PLACE WORD HASHINFO(WPOINT)=HASH HASH1024=HASH1024+1 %RESULT=WPOINT<<8!WM; ! AND RETURN INDEX %FINISH %IF W=WORD %THENSTART HASH1024=HASH1024+1 %RESULT=WPOINT<<8!WM; ! ALREADY ENTERED %FINISH WPOINT=WPOINT+1; ! NOT AT KEY POSITION SO INCREMENT %IF WPOINT>1022 %THENSTART; ! TAKE MODULO AND CHECK FOR WA FUL %IF FULLMARK=1 %THEN BADERROR('WORD AREA OVERFLOW',EMPTY) %C %ELSESTART; FULLMARK=1 WPOINT=0 %FINISH %FINISH ->LP %END; ! END HASH ! ! %INTEGERFN PUT(%STRING(64) WORD) ! WORD IS A STRING OF ALPHANUMERIC CHARS ONLY ! IF THEY ARE ALL NUMERIC,THE STRING IS CONVERTED TO A NUMBER ! OTHERWISE THE WORD IS HASHED. ! A NEGATIVE NUMBER IN STRING FORM SHOULD NOT EXIST IN THE ! SYSTEM, BUT IN ANY CASE WOULD NOT BE CONVERTED TO A NUMBER HERE. %INTEGER NUM,I,J,CHAR,TOOLONG %BYTEINTEGERARRAY STRBYTE(0:64) STRING(ADDR(STRBYTE(0)))=WORD I=STRBYTE(0) %IF I>7 %THEN TOOLONG=1 %ELSE TOOLONG=0 NUM=0; J=1 %IF WORD='' %THENRESULT=HASH(WORD); %WHILE I>0 %CYCLE CHAR=STRBYTE(I) %IF 47NUMTOP %THENSTART PRSTRING('NUMBER OUTSIDE RANGE.'); SPACE;PRSTRING('MAX. SUBSTITUTED');NOOLINE(1) NUM=NUMTOP %FINISH %RESULT=NUM<<8!NM %END; ! END PUT ! ! SERVICE ROUTINES ! ! ! %STRING(64)%FN NUMTOSTR(%INTEGER NUM) ! NUM WILL ALWAYS BE POSITIVE NUMBER IN STANDARD FORM AND IN ! RANGE. IT IS CONVERTED TO A STRING BUT IS NOT HASHED SICE ! THIS CONVERSION WILL ONLY BE CARRIED OUT BY CHAR FUNS PRIOR ! TO A CHAR MANIPULATION WHOSE RESULT WILL BE HASHED %OWNINTEGERARRAY TENS(1:7)=1000000,100000,10000,1000,100,10,1 %INTEGER I,J,K,L,WIND,MARK %BYTEINTEGERARRAY WORD(0:64) WIND=1 MARK=0 NUM=NUM>>8 %CYCLE I=1,1,7 J=TENS(I) K=J L=0 %WHILE NUM>=K %CYCLE K=K+J L=L+1 MARK=1 %REPEAT NUM=NUM-K+J %IF MARK=1 %THENSTART WORD(WIND)=L+48 WIND=WIND+1 %FINISH %REPEAT %IF WIND=1 %THENSTART; ! NUMBER WAS ZERO WORD(WIND)=48 WIND=2 %FINISH WORD(0)=WIND-1 %RESULT=STRING(ADDR(WORD(0))) %END; ! END NUMTOSTR ! %ROUTINE CLUSERFL; ! DISCONNECTS USER FILE IF ANY %IF CACTFILE=0 %THENRETURN CLOSESM(5);CLEAR('SM05');DISCONNECT(USERFILE) CACTFILE=0 %END; ! END CLUSERFL ! %ROUTINE GETMASTER; ! CONNECTS MASTER DIR %INTEGER STADDR DEFINE('SM04,LOGODIR') STADDR=SMADDR(4,MLEN) MDENTS==BYTEINTEGER(STADDR) USERNAM==ARRAY(STADDR+1,UF) %END; ! END GETMASTER ! %ROUTINE FREEMASTER ! DISCONNECTS MASTER IN WRITE AND RECONNECTS IN READ CLOSESM(4) CLEAR('SM04') DISCONNECT(MASDIR) PERMITFILE(MASREAD) GETMASTER %END; ! END FREEMASTER ! %INTEGERFN STATUS(%STRING(15) FILENAME) ! FINDS CONNECT STATUS OF FILENAME %RECORDFORMAT F(%INTEGER AD,SIZE,%BYTEINTEGER RUP,%C EEP,MODE,CONS,ARCH,%STRING(6) TRANS,%SHORTINTEGER TYPE,%C NPERMS,%INTEGER DST,DEND,PTR) %RECORD R(F) %INTEGER RES,FLAG FINFO('NOFILE',0,R,FLAG) FINFO(FILENAME,0,R,FLAG) %IF FLAG>0 %THEN %RESULT=-FLAG RES=R_MODE %IF R_CONS=0 %THENRESULT=0 %RESULT=RES %END; ! END STATUS ! ! ! ! %ROUTINE BADERROR(%STRING(80) ERRMESS,%INTEGER CULPRIT) %INTEGER FUNLIST,FUN %REAL FAIL17 NOOLINE(1) PRSTRING(ERRMESS) SPACE;PRINTEL(CULPRIT) NOOLINE(1) DUMP(ERRMESS) RESTART=1; ! FOR REINIT PRSTRING('SAVING NEW FUNCTIONS IN TEMPORARY FILE');NOOLINE(1) DEFINE('ST03,LOGOTEMP') SELECTOUTPUT(3) FUNLIST=NEWFN %WHILE FUNLIST#NIL %CYCLE FUN=FNVAL(HD(FUNLIST)>>8)&M16!LM; ! LIST DEF %WHILE FUN#NIL %CYCLE PRINTLINE(HD(FUN)) FUN=TL(FUN) %REPEAT PRINTEL(END) NOOLINE(1) FUNLIST=TL(FUNLIST) %REPEAT PRSTRING('GETTY');NOOLINE(1); SELECTOUTPUT(0) PRSTRING('SAVED');NOOLINE(1) CLOSESTREAM(3) CLOSESM(4);CLEAR('SM04');CLUSERFL;CLOSESM(6);CLEAR('SM06') DESTROY('AI2LGSTK') FAIL17=1.0/0; ! FAILS FAULT 17 %END; ! END BADERROR ! %INTEGERFN TIME100 %LONGREAL X X=CPUTIME %RESULT=INT(CPUTIME*100) %END; ! END TIME100 ! ! ! ! LIST AREA AND LISTPRO PRIMITIVES ! ! LIST STRUCTURE IS HELD IN INTEGER ARRAY LA. A LIST IS REPRESENTED ! BY TWO ADJACENT ELEMENTS OF LA - THE FIRST POINTING TO THE HEAD ! THE SECOND POINTING TO THE TAIL. EACH ELEMENT CARRIES A MARKER ! IDENTIFYING IT AS A LIST ,A WORD OR A NUMBER. ! THE NULL LIST IS REPRESENTED BY A POINTER TO THE WORD 'NIL' ! IN THE WORD AREA. ! ABSOLUTE POINTERS ARE USED IN LA AND ARE THUS ALWAYS POSITIVE, ! A LIST IS ADDRESSED BY AN INTEGER CARRYING A LIST MARKER AND A ! POINTER TO ITS FIRST LA ELEMENT - I.E. ITS HEAD. ! ! ! %INTEGERFN HD(%INTEGER LIST); ! RETRIIEVES HEAD OF LIST %IF LIST&LM=0 %OR LIST=NIL %THEN BADERROR('NON-LIST ARG FOR HEAD - ',%C LIST) %RESULT=LA(LIST>>8) %END; ! END HD ! ! %ROUTINE REPHEAD(%INTEGER LIST,NEWHEAD); ! UPDATES HEAD OF LIST %IF LIST&LM=0 %OR LIST=NIL%THEN BADERROR('NON-LIST ARG FOR REPHEAD',%C LIST) LA(LIST>>8)=NEWHEAD %END; ! END REPHEAD ! ! %INTEGERFN TL(%INTEGER LIST); ! RETRIEVES TAIL OF LIST %IF LIST&LM=0 %OR LIST=NIL %THENC BADERROR('NON-LIST ARG FOR TAIL - ',LIST) %RESULT=LA(LIST>>8+1) %END; ! END TL %ROUTINE REPTAIL(%INTEGER LIST,NEWTAIL) %IF LIST&LM=0 %OR LIST=NIL %THENC BADERROR('NONLIST FIRST ARG FOR REPTAIL - ',LIST) %IF NEWTAIL&LM=0 %THENC BADERROR('NON-LIST SECOND ARG FOR REPTAIL - ',NEWTAIL) LA(LIST>>8+1)=NEWTAIL %END; ! END REPTAIL ! ! %INTEGERFN CONS(%INTEGER X,LIST); ! CONSTRUCTS LIST WITH HEAD X %INTEGER I; ! AND TAIL LIST I=LPOINT %IF LIST&LM=0 %THEN BADERROR('NON-LIST SECOND ARG FOR CONS - ',LIST) LA(LPOINT)=X LA(LPOINT+1)=LIST LPOINT=LPOINT+2 %IF (LPOINT-LABASE)>CFRACT*SEMISIZE %THEN CLECTFLG=1 ! SET COLLECT FLAG %RESULT=I<<8!LM %END; ! END CONS ! %INTEGERFN CONS1(%INTEGER X,LIST) ! CONS1 COSTRUCTS LIST WITH HEAD X AND TAIL LIST IN UNCOLLECTABLE SPACE ! I.E. FUNCTION SPACE. IT IS IDENTICAL TO CONS EXCEPT THAT ! IT USES LPOINT1 INSTEAD OF LPOINT AS THE FREE POINTER %INTEGER I I=LPOINT1 %IF LPOINT1>=(LAFNT-1) %THEN BADERROR('FNSPACE OVERFLOW',EMPTY) %IF LIST&LM=0 %THEN BADERROR('NON-LIST SECOND ARG FOR CONS1 - ',LIST) LA(LPOINT1)=X LA(LPOINT1+1)=LIST LPOINT1=LPOINT1+2 %RESULT=I<<8!LM %END; ! END CONS1 ! ! GARBAGE COLLECTOR ! ! COLLECTION IS CARRIED OUT IF REQUIRED ON ENTRY TO EVAL ! WHEN MOST USER LIST STRUCTURE IS REFERENCED FROM THE USER STACK OR ! FROM THE ENVIRONMENT. WHERE NECESSARY, LIST REFERENCES FROM LOCAL ! IMP VARIABLES ARE TRANSFERRED TO THE SYSTEM STACK. ! COLLECTION INVOLVES ALTERING LABASE TO POINT TO THE BASE OF THE NEW ! SEMISPACEAND COPYING ALL ACTIVE LIST STRUCTURE TO THAT SEMISPACE. ! %ROUTINE COLLECT(%INTEGER ENVIR) %INTEGERNAME FREEPOINTER %INTEGER STADDR,LEN %INTEGER I,ITEM,USEDBEFORE,USEDAFTER,COLLECTED ! %INTEGERFN GENCOPY(%INTEGER LIST) ! COPIES LIST STRUCTURE AS IS,INCLUDING CIRCULAR/BLAM LISTS. ! IT ALTERS THE STRUCTURE IT IS COPYING FROM AND SO MAY ONLY BE ! USED WITHIN THE GARBAGE COLLECTOR . %INTEGER NEWLIST,HEAD,TAIL %IF LIST&LM#LM %OR LIST=NIL %OR (LIST>>8)>=LAFNB %THENRESULT=LIST ! WORD,NUMBER OR LIST IN UNCOLLECTABLE SPACE %IF HD(LIST)=-1 %THENRESULT=TL(LIST); ! ALREADY COPIED HEAD=HD(LIST) TAIL=TL(LIST) NEWLIST=CONS(NIL,NIL); ! SPACE FOR COPY IN NEW SEMISPACE REPHEAD(LIST,-1); ! INSERT COPY MARKER REPTAIL(LIST,NEWLIST); ! INSERT ADDR OF COPY IN TAIL REPTAIL(NEWLIST,GENCOPY(TAIL)) REPHEAD(NEWLIST,GENCOPY(HEAD)) %RESULT=NEWLIST %END; ! END GENCOPY ! ! USEDBEFORE=LPOINT-LABASE %IF LABASE=LA1B %THEN LABASE=LA2B %ELSE LABASE=LA1B; ! FLIP SEMISPACE LPOINT=LABASE; ! CONS NOW WORKS IN NEW SEMISPACE %CYCLE I=0,1,BASENVIR ITEM=BVALUE(I) %IF ITEM#0 %THEN BVALUE(I)=GENCOPY(ITEM) ITEM=ASSOCWA(I) %IF ITEM#NIL %THEN ASSOCWA(I)=GENCOPY(ITEM) %REPEAT %IF ENVIR>BASENVIR %THENSTART %CYCLE I=BASENVIR,1,ENVIR BVALUE(I)=GENCOPY(BVALUE(I)) %REPEAT %FINISH %IF STKPNT>0 %THENSTART %CYCLE I=1,1,STKPNT STK(I)=GENCOPY(STK(I)) %REPEAT %FINISH %IF SYSTKPNT>0 %THENSTART %CYCLE I=1,1,SYSTKPNT SYSTK(I)=GENCOPY(SYSTK(I)) %REPEAT %FINISH NEWFN=GENCOPY(NEWFN) USEDAFTER=LPOINT-LABASE %IF STATUS('ERCI06.LOGOMON')>=0 %THENSTART DEFINE('SM07,ERCI06.LOGOMON') STADDR=SMADDR(7,LEN) FREEPOINTER==INTEGER(STADDR) %IF FREEPOINTER+48>LEN %THEN ->CLOSE STADDR=STADDR+FREEPOINTER FREEPOINTER=FREEPOINTER+48 STRING(STADDR)=TIME.DATE STRING(STADDR+19)=EMASUSER INTEGER(STADDR+28)=USEDBEFORE INTEGER(STADDR+32)=ENVIR-BASENVIR INTEGER(STADDR+36)=STKPNT INTEGER(STADDR+40)=SYSTKPNT INTEGER(STADDR+44)=USEDAFTER CLOSE:CLOSESM(7);CLEAR('SM07') %FINISH CLECTFLG=0 COLLECTED=USEDBEFORE-USEDAFTER %IF COLLECTED<100 %THEN BADERROR('TOO FEW LIST CELLS COLLECTED',%C COLLECTED<<8!NM) %END; ! END COLLECT ! ! ! %INTEGERFN MOVE1(%INTEGER LIST) ! MOVE1 IS USED TO COPY LIST STRUCTURE CREATED BY THE READER IN ! COLLECTABLE SPACE TO UNCOLLECTABLE SPACE. NO CIRCULAR/BLAM LISTS ! %INTEGERFN COPY(%INTEGER LIST) %IF LIST&LM#LM %OR LIST=NIL %THENRESULT=LIST %RESULT=CONS1(COPY(HD(LIST)),COPY(TL(LIST))) %END; ! END COPY ! %IF LIST&LM#LM %THEN BADERROR('NON-LIST ARG FOR MOVE1 - ',LIST) %IF (LIST>>8)>=LAFNB %THENRESULT=LIST; ! ALREADY IN FNSPACE %RESULT=COPY(LIST) %END; ! END MOVE ! %INTEGERFN REVERSE(%INTEGER LIST) %INTEGER LIST1 LIST1=NIL %WHILE LIST#NIL %CYCLE LIST1=CONS(HD(LIST),LIST1) LIST=TL(LIST) %REPEAT %RESULT=LIST1 %END; ! END REVERSE ! ! ! ! ! ! ! ENVIRONMENT ! ! VARIABLE BINDINGS ARE HELD AS (NAME,VALUE) PAIRS IN ARRAYS ! BNAME AND BVALUE. THE CURRENT ENVIRONMENT IS DEFINED BY ENVIR ! WHICH POINTS TO THE TOP OF THE LAST ENVIRONMEBT CREATED, ! OR IS EQUAL TO 1022 IF ONLY THE BASE ENVIRONMENT EXISTS. ! WHENEVER A LOGO FUN IS APPLIED, THE PARAMETER NAMES AND LOCAL ! NAMES ARE INSERTED IN A NEWLY CREATED ENVIRONMENT TOGETHER WITH ! A SINGLE DIAGNOSTIC RECORD (THE FIRST) WHICH HAS 0 AS ITS NAME ! COMPONENT. ! SUCH LOCAL ENVIRONMENTS ARE CREATED UPWARDS FROM 1023. ! BVALUE(0-1022) IS USED FOR THE BASE ENVIRONMENT VALUES. ! THIS PART OF BVALUE IS PARALLEL TO WA AND IS ACCESSED ! BY DIRECT APPLICATION OF THE WORD INDEX. ! BASENVIR IS USED TO REFER TO THE BASE ENVIR ! VARIABLE UNDEF CONTAINS A POINTER TO THE WORD 'UNDEF' IN THE WORD ! AREA. ! FUNCTION UNSTACK RETREIVES THE TOP ELEMENT FROM THE LOGO STACK. ! VARIABLE NIL POINTS TO THE EMPTY LIST-THE WORD 'NIL'. ! VARIABLE DOTS POINTS TO THE WORD ':'. ! ! ! ! %INTEGERFN FINDBIND(%INTEGER NAME,ENVIR) ! FINDS A BINDING IN AN ENVIRONMENT. IF CALLED WITH ENVIR<=1022,ONLY ! THE GLOBAL ENVIRONMENT IS INTERROGATED. LOCAL:%WHILE ENVIR>1022 %CYCLE %IF BNAME(ENVIR)=0 %THENSTART; ! SKIP DIAGNOSTIC RECORD AT START ENVIR=ENVIR-1 ->LOCAL %FINISH %IF BNAME(ENVIR)=NAME %THENRESULT=ENVIR; ! FOUND IT ENVIR=ENVIR-1 %REPEAT NAME=NAME>>8; ! NOT LOCAL SO TRY GLOBAL %IF BVALUE(NAME)=0 %THENRESULT=UNDEF %ELSERESULT=NAME %END; ! END FINDBIND ! ! %ROUTINE SETVAL(%INTEGER NAME,VALUE,ENVIR) ! UPDATES A BINDING IF ONE EXISTS,OTHERWISE CREATES A NEW GLOBAL BINDING %INTEGER BINDING BINDING=FINDBIND(NAME,ENVIR) %IF BINDING=UNDEF %THENSTART; ! NOT YET DEFINED BVALUE(NAME>>8)=VALUE; ! SO CREATE IT GLOBALLY %FINISHELSE BVALUE(BINDING)=VALUE; ! ALREADY DEFINED SO UPDATE IT %END; ! END SETVAL ! ! %INTEGERFN GETVAL(%INTEGER NAME,ENVIR); ! RETRIEVES A BINDING %INTEGER BINDING BINDING=FINDBIND(NAME,ENVIR) %IF BINDING=UNDEF %THENRESULT=UNDEF %ELSERESULT=BVALUE(BINDING) %END; ! END GETVAL ! ! %INTEGERFN SETBIND(%INTEGER PARMLIST,ENVIR) ! BINDS PARMATER NAMES AND ARGS IN NEW ENVIRONMENT ! PARAMETER NAMES ARE IN PARMLIST IN REVERSE ORDER. ! ARG VALUES ARE ON STACK %WHILE PARMLIST#NIL %CYCLE %IF ENVIR=3000 %THEN BADERROR('ENVIRONMENT OVERFLOW',EMPTY) ENVIR=ENVIR+1 BNAME(ENVIR)=HD(PARMLIST) BVALUE(ENVIR)=UNSTACK PARMLIST=TL(PARMLIST) %REPEAT %IF ENVIR>TOPMARK %THEN TOPMARK=ENVIR; ! TOPMARK USED BY DUMP %RESULT=ENVIR %END; ! END SETBIND ! %INTEGERFN MAKEBIND(%INTEGER PARMLIST,ENVIR,FNAME) ! MAKEBIND CREATES NEW LOCAL ENVIRONMENT INSERTING DIAGNOSTIC ! RECORD AND BINDING PARAMETERS %IF ENVIR=3000 %THEN BADERROR('ENVIRONMENT OVERFLOW',EMPTY) ENVIR=ENVIR+1 BNAME(ENVIR)=0; ! DIAGNOSTIC RECORD BVALUE(ENVIR)=FNAME %RESULT=SETBIND(PARMLIST,ENVIR) %END; ! END MAKEBIND ! ! ! ! USER STACK MANIPULATION ! %INTEGERFN UNSTACK %IF STKPNT=0 %THEN BADERROR('STACK UNDERFLOW',EMPTY) STKPNT=STKPNT-1 %RESULT=STK(STKPNT+1) %END; ! END UNSTACK ! %ROUTINE STACK(%INTEGER I) %IF STKPNT=2000 %THEN BADERROR('STACK OVERFLOW',EMPTY) STKPNT=STKPNT+1 STK(STKPNT)=I %END; ! END STACK; ! ! ! SYSTEM STACK ! USED TO MAKE REFS TO COLLECTABLE LIST STRUCTURE FROM IMP LOCALS ! AVAILABLE TO THE COLLECTOR. ! %INTEGERFN UNSTKSYS %IF SYSTKPNT=0 %THEN BADERROR('SYSTACK UNDERFLOW',EMPTY) SYSTKPNT=SYSTKPNT-1 %RESULT=SYSTK(SYSTKPNT+1) %END; ! END UNSTKSYS ! %ROUTINE STKSYS(%INTEGER I) %IF SYSTKPNT=2000 %THEN BADERROR('SYSTACK OVERFLOW',EMPTY) SYSTKPNT=SYSTKPNT+1 SYSTK(SYSTKPNT)=I %END; ! END STKSYS ! ! ! ! SYSTEM INPUT/OUTPUT ! ! ALL SYSTEM INPUT IS IN THE FORM OF A LIST WITH OUTERMOST ! BRACKETS IMPLICIT. SPACES AND NOOLINE AT START OF INPUT ARE ! DISCARDED OTHERWISE THEY SERVE TO DELIMIT WORDS. THE LIST IS ! TERMINATED WITH A SEMI COLON ! AT LEVEL 1 (IE USER LEVEL ZERO),THE MINUS CHAR IS LEFT ! AS A SEPARATE WORD. AT ANY OTHER LEVEL IT IS ASSUMED TO BE ! THE UNARY MINUS AND MUST BE FOLLOWED BY A NUMBER. THE NUMBER ! IS THEN CONVERTED TO BINARY AND NEGATED. ! ! ! ! ! **** ! READ ROUTINES AND FNS FOR LOGO ! %ROUTINE LGREAD SYM(%INTEGERNAME SYM) ! LOGO READ SYMBOL ! ! ! %IF DEVICE=TTY %THEN READSYMBOL(SYM) %ELSESTART SYM=FNTEXT(INDEX) INDEX=INDEX+1 %FINISH %RETURN; %END; ! END LGREAD SYM ! ! %INTEGERFN LGNEXT SYM; ! LOGO NEXT SYMBOL ! ! ! ! %IF DEVICE=TTY %THEN %RESULT=NEXTSYMBOL %RESULT=FNTEXT(INDEX) %END; ! END LGNEXT SYM ! ! ! %ROUTINE GETDIR(%INTEGER NEW,CHANNEL) %INTEGER STADDR STADDR=SMADDR(CHANNEL,ULEN) UDENTS==INTEGER(STADDR) UNFS==INTEGER(STADDR+4) DIRNAM==ARRAY(STADDR+8,NF) DIRVAL==ARRAY(STADDR+7680,VF) FNTEXT==ARRAY(STADDR+8192,TF) %IF NEW=0 %THEN UDENTS=0 %AND UNFS=2 %IF CACTFILE=0 %THEN CACTFILE=1 %RETURN %END; ! END GETDIR ! ! %ROUTINE FILETIDY %STRING(10) TEXTSIZE %INTEGER STADDR,SIZE,LEN,NEW,PNTER,I,J,NFS,OLDFS NOOLINE(1) PRSTRING( 'TIDYING FUN FILE');NOOLINE(1) SIZE=(4096*(UNFS//4096+1)+8192) %IF SIZE<=16383 %THEN SIZE=16384 OLDFS=UNFS TEXTSIZE=NUMTOSTR(SIZE<<8) DEFINE('SM10,JUNK') NEWSMFILE('JUNK,'.TEXTSIZE) STADDR=SMADDR(10,LEN) TEMPVAL==ARRAY(STADDR+7680,VF) TEMPNAM==ARRAY(STADDR+8,NF) TEMPTEXT==ARRAY(STADDR+8192,TF) TEMPUNFS==INTEGER(STADDR+4) TEMPENTS==INTEGER(STADDR) NEW=0 NFS=1 INDEX=0 %CYCLE I=1,1,UDENTS %UNLESS DIRVAL(I)=M' ' %THENSTART PNTER=NFS NEW=NEW+1 INDEX=DIRVAL(I) 1:LGREAD SYM(J) TEMPTEXT(NFS)=J NFS=NFS+1 %IF J=TERMIN %AND LGNEXT SYM='E' %THEN -> OUT -> 1 OUT:%WHILE LGNEXT SYM#'T' %AND INDEX=1500 %THENSTART CLOSESM(10) CLEAR('SM10') DESTROY(USERFILE) RENAME('JUNK,'.USERFILE) DEFINE('SM05,'.USERFILE) CHERISH(USERFILE) GETDIR(1,5) %RETURN;%FINISH ! TEXTSIZE=NUMTOSTR((LEN+4096)<<8) DESTROY(USERFILE) NEWSMFILE(USERFILE.','.TEXTSIZE) DEFINE('SM05,'.USERFILE) CHERISH(USERFILE) GETDIR(1,5) %CYCLE I=1,1,TEMPUNFS FNTEXT(I)=TEMPTEXT(I) %REPEAT %CYCLE I=1,1,TEMPENTS DIRNAM(I)=TEMPNAM(I) DIRVAL(I)=TEMPVAL(I) %REPEAT UDENTS=TEMPENTS UNFS=TEMPUNFS CLOSESM(10) CLEAR('SM10') DESTROY('JUNK') %RETURN %END; ! END OF TIDY %ROUTINE LGSKIP SYM ! LOGO SKIP SYMBOL ! ! ! ! %IF DEVICE=TTY %THEN SKIP SYMBOL %ELSE INDEX=INDEX+1 %RETURN; %END; ! END LGSKIP SYM ! ! ! ! %ROUTINE LGREAD ITEM(%STRINGNAME ITEM) ! LOGOREAD ITEM ! ! ! ! %IF DEVICE=TTY %THEN READITEM(ITEM) %ELSESTART ITEM=TO STRING(FNTEXT(INDEX)) INDEX=INDEX+1 %FINISH %RETURN; %END; !END LGREAD ITEM ! ! ! %INTEGERFN READLIST(%INTEGER LEVEL) ! %INTEGERFN GETITEM %INTEGER SYM,SKIPMARK %STRING(2) ITEM %STRING(64) WORD %INTEGER SYMCOUNT SYMCOUNT=0;WORD='';SKIPMARK=0 %IF QUOTEON=1 %AND (LGNEXT SYM<48 %OR 5790) %THENRESULT=EMPTY LP:%IF LGNEXT SYM=' ' %THENSTART LGSKIP SYM %IF SYMCOUNT=0 %THEN ->LP %ELSESTART SYMCOUNT=0 %IF SKIPMARK=1 %THEN NOOLINE(1) %RESULT=PUT(WORD) %FINISH %FINISH %IF LGNEXT SYM='@' %THENSTART %IF SYMCOUNT=0 %THENSTART %WHILE LGNEXT SYM#NL %THEN LGSKIP SYM LGSKIP SYM; ! SKIP UP TO AND INC NL PROMPT('C:') ->LP %FINISHELSESTART SYMCOUNT=0 %IF SKIPMARK=1 %THEN NOOLINE(1) %RESULT=PUT(WORD) %FINISH %FINISH %IF LGNEXT SYM=TERMIN %THENSTART;PROMPT(PROMP) %IF SYMCOUNT=0 %THENSTART %IF LEVEL>BLEVEL %THENSTART PRSTRING('MISSING RIGHT BRACKET INSERTED');NOOLINE(1) %FINISHELSE LGSKIP SYM %RESULT=RBRAK %FINISHELSESTART SYMCOUNT=0 %IF SKIPMARK=1 %THEN NOOLINE(1) %RESULT=PUT(WORD) %FINISH %FINISH %IF LGNEXT SYM=LBRAK %OR LGNEXT SYM=RBRAK %THENSTART %IF SYMCOUNT=0 %THENSTART;LGREAD SYM(SYM);%RESULT=SYM %FINISHELSESTART SYMCOUNT=0 %IF SKIPMARK=1 %THEN NOOLINE(1) %RESULT=PUT(WORD) %FINISH %FINISH %IF LGNEXT SYM='-' %AND LEVEL#1 %THENSTART %IF SYMCOUNT=0 %THENSTART LGSKIP SYM SYM=GETITEM %IF SYM&NM=0 %THENSTART PRSTRING('INVALID ''-'' BEFORE ') PRINTEL(SYM) SPACE PRSTRING('IGNORED') NOOLINE(1) %FINISHELSERESULT=(-SYM>>8)<<8!NM %FINISHELSESTART SYMCOUNT=0 %IF SKIPMARK=1 %THEN NOOLINE(1) %RESULT=PUT(WORD) %FINISH %FINISH %IF LGNEXT SYM<48 %OR (LGNEXT SYM>57 %AND LGNEXT SYM <65) %C %OR LGNEXT SYM>90 %THENSTART %IF SYMCOUNT=0 %THENSTART LGREAD ITEM(ITEM) %IF (ITEM='<' %OR ITEM='>') %AND LGNEXT SYM='=' %THENSTART ITEM=ITEM.'=' LGSKIP SYM %FINISH %IF ITEM='<' %AND LGNEXT SYM='<' %THENSTART ITEM='<<' LGSKIP SYM %FINISH %IF ITEM='>' %AND LGNEXT SYM='>' %THENSTART ITEM='>>' LGSKIP SYM %FINISH %RESULT=PUT(ITEM) %FINISHELSESTART SYMCOUNT=0 %IF SKIPMARK=1 %THEN NOOLINE(1) %RESULT=PUT(WORD) %FINISH %FINISH LGREAD ITEM(ITEM); %IF SYMCOUNT=64 %THENSTART %IF SKIPMARK=1 %THEN PRSTRING(ITEM) %ELSESTART SKIPMARK=1 PRSTRING('EXCESS CHARS IGNORED - ') PRSTRING(ITEM) %FINISH %FINISHELSESTART WORD=WORD.ITEM;SYMCOUNT=SYMCOUNT+1 %FINISH ->LP %END; ! END GETITEM ! %INTEGER THISPOINT,ITEM THISPOINT=LPOINT ITEM=GETITEM %IF ITEM=QUOTE %THEN QUOTEON=1 %ELSE QUOTEON=0 %IF ITEM=RBRAK %THENSTART %RESULT=NIL %FINISHELSESTART LPOINT=LPOINT+2 %IF (LPOINT-LABASE)>CFRACT*SEMISIZE %THEN CLECTFLG=1 ! SET FLAG FOR COLLECT %IF ITEM=LBRAK %THENSTART LA(THISPOINT)=READLIST(LEVEL+1) %FINISHELSE LA(THISPOINT)=ITEM LA(THISPOINT+1)=READLIST(LEVEL) %RESULT=THISPOINT<<8!LM %FINISH %END; ! END READLIST ! ! ! %INTEGERFN READLINE BLEVEL=1 %RESULT=READLIST(BLEVEL) %END; ! END READLINE ! %ROUTINE NOOLINE(%INTEGER N) %WHILE N>0 %CYCLE NEWLINE N=N-1 %REPEAT CHAROUT=0 %END; ! END NOOLINE ! %ROUTINE PRSTRING(%STRING(255) WORD) %INTEGER N N=LENGTH(WORD) %IF (CHAROUT+N)>72 %THENSTART NEWLINE %IF WORD->(' ').WORD %THEN N=N-1 SPACES(3) PRINTSTRING(WORD) CHAROUT=N+3 %FINISHELSESTART PRINTSTRING(WORD) CHAROUT=CHAROUT+N %FINISH %END; ! END PRSTRING ! %ROUTINE LGPRNT STR(%STRING (64) WORD) %INTEGER SAVE,NEWIND,BUFFCNT %IF DEVICE=TTY %THEN PRSTRING(WORD) %ANDRETURN SAVE=FNTEXT(INDEX-1) STRING(ADDR(FNTEXT(INDEX-1)))=WORD NEWIND=INDEX+FNTEXT(INDEX-1) FNTEXT(INDEX-1)=SAVE INDEX=NEWIND %IF ULEN-INDEX-8192>=64 %THENRETURN %ELSE BUFFCNT=INDEX-UNFS %BEGIN %BYTEINTEGERARRAY BUFFER(1:BUFFCNT) NEWIND=UNFS %CYCLE SAVE=1,1,BUFFCNT BUFFER(SAVE)=FNTEXT(NEWIND) NEWIND=NEWIND+1 %REPEAT FILETIDY NEWIND=UNFS %CYCLE SAVE=1,1,BUFFCNT FNTEXT(NEWIND)=BUFFER(SAVE) NEWIND=NEWIND+1 %REPEAT INDEX=NEWIND+1 %END %RETURN;%END; ! END LGPRNT STR ! %ROUTINE LGNEWLINE %IF DEVICE=TTY %THEN NOOLINE(1) %ELSE LGPRNT STR(STERMIN) %END; ! END LGNEWLINE ! ! ! %ROUTINE PRINTWORD(%STRING(64) WORD) %IF WORD=']' %OR WORD=')' %THENSTART LGPRNT STR(WORD) SEP=' ' %RETURN %FINISH %IF WORD='(' %OR WORD='[' %OR WORD='''' %OR WORD=':' %THENSTART LGPRNT STR(SEP.WORD) SEP='' %RETURN %FINISH %IF WORD='+' %OR WORD='-' %OR WORD='*' %OR WORD='/' %OR WORD='<' %C %OR WORD='<=' %OR WORD='>' %OR WORD='>=' %OR WORD='=' %THENSTART LGPRNT STR(WORD) SEP='' %RETURN %FINISH LGPRNT STR(SEP.WORD) SEP=' ' %RETURN %END; ! END PRINTWORD ! ! %ROUTINE PRINTWN(%INTEGER I) %STRING(64) WORD %IF I&NM=NM %THENSTART %IF I<0 %THEN WORD='-'.NUMTOSTR(\I+256) %ELSE WORD=' '.NUMTOSTR(I) %FINISHELSE WORD=WA(I>>8) PRINTWORD(WORD) %END; ! END PRINTWN ! %ROUTINE PRINTLCON(%INTEGER LIST) %INTEGER I LP:%IF ENUF=1 %OR (TESTINT(0,'ENUF')#0 %AND DEVICE=TTY) %THENSTART ENUF=1 %RETURN %FINISH %IF LIST=NIL %THENRETURN I=HD(LIST) %IF I&LM=LM %THEN PRINTLIST(I) %ELSE PRINTWN(I) LIST=TL(LIST) ->LP %END; ! END PRINTLCON ! %ROUTINE PRINTLIST(%INTEGER LIST) PRINTWORD('[') PRINTLCON(LIST) PRINTWORD(']') %END; ! END PRINTLIST ! ! %ROUTINE PRINTEL(%INTEGER I) ENUF=0 SEP='' %IF I&LM=LM %THEN PRINTLIST(I) %ELSE PRINTWN(I) %END; ! END PRINTEL ! ! %ROUTINE PRINTLINE(%INTEGER LINE) %INTEGER HEAD SEP='' %IF LINE=NIL %THENSTART ENUF=0 PRINTLIST(NIL) %FINISH %WHILE LINE#NIL %CYCLE HEAD=HD(LINE) %IF HEAD&LM=LM %THENSTART ENUF=0 PRINTLIST(HEAD) %FINISHELSE PRINTWN(HEAD) LINE=TL(LINE) %REPEAT LGNEWLINE %END; ! END PRINTLINE ! ! ! ! ! ! EVAL AND APPLY ! %ROUTINE EVALAPPL(%INTEGER PREC,%INTEGERNAME ENVIR,FUN,CURFUN,%C IN,TSTFLG,VAL,SEVERITY) ! ! ENVIR IS THE CURRENT ENVIRONMENT POINTER - 1022 IF OUTSIDE A USER ! FUN AND ONLY BASE ENVIR EXISTS. ! FUN IS THE USER FUN WE ARE CURRENTLY IN - NIL IF OUTSIDE USER ! FUN ! CURFUN IS THE REST OF THE USER FUN WE ARE CURRENTLY IN - NIL ! IF OUTSIDE USER FUN ! IN CONTAINS THE LINE WE ARE CURRENTLY EVALUATING EITHER FROM ! A USER FUN OR FROM THE TTY ! TSTFLG IS THE CURRENT TEST LOCATION USED BY TEST IFTRUE,ETC ! VAL IS THE LAST VALUE ! SEVERITY IS USED IN APPLYSYS TO TELL IF A CONTINUE ! IS POSSIBLE ! ! THESE PARAMETES ARE CREATED BY LOGO AT BASE LEVEL AND ARE ! RECREATED BY APPLYUSR ON EACH ENTRY TO USER FUN. ! THEY ARE USED FREE BY ROUTINE ERROR FOR DIAGNOSTIC PURPOSES ! AND BY APPLYSYS AND EVAL ! %ROUTINESPEC EVAL(%INTEGER PREC,%INTEGERNAME IN,EACHVAL) ! ! %ROUTINE ERROR(%STRING(80) ERRMESS,%INTEGER CULPRIT,SEVERITY,%C %INTEGERNAME IN) %INTEGER SAVEDEV SAVEDEV=DEVICE DEVICE=TTY NOOLINE(1);PRSTRING(ERRMESS);SPACE;PRINTEL(CULPRIT);NOOLINE(1) %IF FUN=NIL %THENSTART; ! NOT IN A USER FUN JUMPFLAG=1; ! TRIGGERS A RETURN TO LOGO IN=NIL STACK(ERR) DEVICE=SAVEDEV %RETURN %FINISH PRSTRING('IN ');PRINTEL(HD(TL(HD(FUN)))); ! NAME OF USER FUN NOOLINE(1) PRINTLINE(HD(CURFUN)); ! CURRENT LINE NOOLINE(1) STKSYS(IN);STKSYS(VAL); LOGO(STKPNT,MAKEBIND(NIL,ENVIR,LOGONAME),SEVERITY) VAL=UNSTKSYS;IN=UNSTKSYS ! IN NEEDS TO BE AVAILABLE TO THE COLLECTOR ONLY IN THE SINGLE !CASE WHERE IT IS THE ARGUMENT PASSED FROM DOLOGO. IN ALL OTHER ! CASES IT WILL BE A REFERENCE TO THE UNCOLLECTABLE FNSPACE. THE ! COLLECTOR CHECKS THAT THE REFERENCES ON SYSTK ARE IN FACT TO ! COLLECTABLE SPACE DEVICE=SAVEDEV %RETURN %END; ! END ERROR ! %ROUTINE ERROR1(%STRING(80) ERRMESS,%INTEGER CULPRIT) %INTEGER SAVEDEV SAVEDEV=DEVICE DEVICE=TTY NOOLINE(1);PRSTRING(ERRMESS);SPACE;PRINTEL(CULPRIT);NOOLINE(1) DEVICE=SAVEDEV %END; ! END ERROR1 ! ! %INTEGERFN NEGATE(%INTEGER I) %IF I&NM#NM %THENSTART; PRSTRING('INVALID UNARY MINUS BEFORE ') PRINTEL(I) PRSTRING(' IGNORED') NOOLINE(1) %RESULT=I %FINISH %IF I<0 %THENRESULT=(-I>>8!T8)<<8!NM %ELSERESULT=(-I>>8)<<8!NM %END; ! END NEGATE ! ! %INTEGERFN REVQUOTE(%INTEGER LIST) !REVERSES LIST AND REMOVES QUOTES %INTEGER LIST1,WORD LIST1=NIL %WHILE LIST#NIL %CYCLE %IF HD(LIST)=QUOTE %THEN LIST=TL(LIST) %ELSE ->RQ1 %IF LIST=NIL %THEN ->RQ1 WORD=HD(LIST) %IF WORD&WM#WM %THEN ->RQ1 LIST1=CONS(WORD,LIST1) LIST=TL(LIST) %REPEAT %RESULT=LIST1 RQ1:ERROR('INCORRECT FORM FOR FN ARGS',EMPTY,1,IN) %RESULT=ERR %END; !END REVQUOTE ! ! %ROUTINE CHKLIST(%INTEGER LIST) %INTEGER WORD %IF LIST&LM#LM %THENSTART ERROR('NON-WORD FOR NEW - ',LIST,1,IN) %RETURN %FINISH %WHILE LIST#NIL %CYCLE WORD=HD(LIST) %IF WORD&WM # WM %THENSTART ERROR('NON-WORD FOR NEW - ',WORD,1,IN) %RETURN %FINISH LIST=TL(LIST) %REPEAT %END; ! END CHKLIST ! %INTEGERFN LISTLEN(%INTEGER LIST); ! RETURNS LENGTH OF LIST %INTEGER LEN LEN=0 %WHILE LIST#NIL %CYCLE LEN=LEN+1 LIST=TL(LIST) %REPEAT %RESULT=LEN %END; ! END LISTLEN ! %INTEGERFN GETMATCH(%INTEGERNAME CLAUSE,IN) ! PLACES ELEMENTS FROM IN INTO CLAUSE UP TO AND INCLUDING MATCHING RPAR ! ENTER WITH LPAR AS HD(IN) %INTEGER HEAD,RES CLAUSE=CONS(LPAR,CLAUSE) IN=TL(IN) %WHILE IN#NIL %CYCLE HEAD=HD(IN) %IF HEAD=RPAR %THENSTART IN=TL(IN) CLAUSE=CONS(HEAD,CLAUSE) %RESULT=EMPTY %FINISH %IF HEAD=LPAR %THENSTART RES=GETMATCH(CLAUSE,IN) %IF RES#EMPTY %THENRESULT=RES; ! PASS ERROR OUT %FINISHELSESTART; ! NEITHER LPAR NOR RPAR SO CONTINUE IN=TL(IN) CLAUSE=CONS(HEAD,CLAUSE) %FINISH %REPEAT %RESULT=RPAR; ! NO RPAR BEFORE END %END; ! END GETMATCH ! ! %ROUTINE STRTRACE(%INTEGER FN) ! USED TO PRINT FN. NAME ETC WHEN ENTERING A TRACED FN INDENT=INDENT+1; SPACES(INDENT) PRINTSTRING('>'); PRINTEL(FN) NOOLINE(1); INDENT=INDENT+1 %END ! ! %ROUTINE ENDTRACE(%INTEGER FN) ! USED TO PRINT FN NAME ETC. WHEN EXITING A TRACED FN INDENT=INDENT-1; SPACES(INDENT) PRINTSTRING('<'); PRINTEL(FN) NOOLINE(1); INDENT=INDENT-1 %END ! ! %ROUTINE APPLYSYS(%INTEGER SW,%INTEGERNAME FN,IN,EACHVAL) %SWITCH SYSFUN(1:255) %INTEGER ARG1,ARG2,ARG3,W1,W2 %INTEGER REDEF; ! USED BY EDIT %STRING(64) WSTR1,WSTR2 ! ! %INTEGERFN EXTRACT(%INTEGERNAME COND,THENC,ELSEC) ! USED BY IF AND WHILE TO EXTRACT CLAUSES. ! RESULT IS EMPTY IF SYNTAX OK ! RESULT IS CULPRIT IF SOMETHING MISPLACED OR MISSING %INTEGER HEAD,RES,FN FN=HD(IN) COND=CONS(HD(IN),COND); ! INITIAL IF INTO COND IN=TL(IN) %WHILE IN#NIL %CYCLE ! LOOK FOR THEN BEFORE ELSE OR TERMIN HEAD=HD(IN) %IF HEAD=LPAR %THENSTART; ! LEFT PARENTHESES RES=GETMATCH(COND,IN); ! EXTRACT UP TO MATCHING RPAR %IF RES#EMPTY %THENRESULT=RES; ! PASS OUT ERROR %FINISHELSESTART %IF HEAD=THEN %THEN ->THENL; ! FOUND THEN %IF HEAD=ELSE %OR HEAD=RPAR %THENRESULT=THEN; ! ERROR - THEN MISSING %IF HEAD=IF %OR HEAD=WHILE %THENSTART RES=EXTRACT(COND,COND,COND) %IF RES#EMPTY %THENRESULT=RES; ! ERROR PASSED OUT %FINISHELSESTART COND=CONS(HEAD,COND) IN=TL(IN) %FINISH %FINISH %REPEAT %RESULT=THEN; ! ERROR - THEN NOT FOUND BEFORE END ! THENL:THENC=CONS(HD(IN),THENC) IN=TL(IN) %WHILE IN#NIL %CYCLE ! LOOK FOR ELSE OR ANOTHER THEN HEAD=HD(IN) %IF HEAD=LPAR %THENSTART RES=GETMATCH(THENC,IN) %IF RES#EMPTY %THENRESULT=RES %FINISHELSESTART %IF HEAD=ELSE %THEN ->ELSEL %IF HEAD=THEN %OR HEAD=RPAR %THENRESULT=EMPTY; ! END OF THIS IF %IF HEAD=IF %OR HEAD=WHILE %THENSTART RES=EXTRACT(THENC,THENC,THENC) %IF RES#EMPTY %THENRESULT=RES %FINISHELSESTART THENC=CONS(HEAD,THENC) IN=TL(IN) %FINISH %FINISH %REPEAT %RESULT=EMPTY; ! END OF THIS IF ! ELSEL:%IF FN=WHILE %THENRESULT=EMPTY; ! END OF WHILE ELSEC=CONS(HD(IN),ELSEC) IN=TL(IN) %WHILE IN#NIL %CYCLE HEAD=HD(IN) %IF HEAD=LPAR %THENSTART RES=GETMATCH(ELSEC,IN) %IF RES#EMPTY %THENRESULT=RES %FINISHELSESTART %IF HEAD=THEN %OR HEAD=ELSE %OR HEAD=RPAR %THENRESULT=EMPTY %IF HEAD=IF %OR HEAD=WHILE %THENSTART RES=EXTRACT(ELSEC,ELSEC,ELSEC) %IF RES#EMPTY %THENRESULT=RES %FINISHELSESTART ELSEC=CONS(HEAD,ELSEC) IN=TL(IN) %FINISH %FINISH %REPEAT %RESULT=EMPTY %END; ! END EXTRACT ! ! %INTEGERFN FINDASS(%INTEGER LIST,ATT) ! FINDS AN ASSOCIATION IN LIST WITH ATTRIBUTE ATT. USES W1 AND W2 ! FREE. IF ASSOC FOUND, W2 POINTS TO LIST STARTING WITH ASSOC AND ! W1 POINTS TO ONE BEFORE, UNLESS ASSOC IS FIRST IN LIST WHEN W1=W2 ! IN EITHER CASE W2 ALSO RETURNED VIA RESULT. ! IF NO ASSOC FOUND, NIL RETURNED. W1=LIST W2=LIST %WHILE W2#NIL %CYCLE %IF HD(HD(W2))#ATT %THENSTART W1=W2 W2=TL(W2) %FINISHELSERESULT=W2 %REPEAT %RESULT=NIL %END; ! END FINDASS ! ! ! %ROUTINE CHECKNUM %IF ARG1&NM#NM %OR ARG2&NM#NM %THEN %C ERROR('ARITHMETIC REQUIRES NUMBERS - ',CONS(ARG1,CONS(ARG2,NIL)),1,IN) %RETURN %END; ! END CHECKNUM ! %INTEGERFN CHECKSIZE(%INTEGER I) %IF I>NUMTOP %THENSTART PRSTRING('ARITHMETIC RESULT OUT OF RANGE.') WRITE(I,0);SPACE PRSTRING('MAX SUBSTITUTED') NOOLINE(1) %RESULT=NUMTOP %FINISH %IF I>8!T8 %ELSE ARG1=ARG1>>8 %IF ARG2<0 %THEN ARG2=ARG2>>8!T8 %ELSE ARG2=ARG2>>8 %END; ! END READYNUM ! ! %ROUTINE WORD %IF ARG1&LM=LM %OR ARG2&LM=LM %THENSTART ERROR('NON-WORD ARG FOR CHARFUN - ',%C CONS(FN,CONS(ARG1,CONS(ARG2,NIL))),1,IN) %RETURN %FINISH %IF ARG1<0 %OR ARG2<0 %THENSTART ERROR('NEGATIVE NUMBER FOR CHARFUN - ',%C CONS(FN,CONS(ARG1,CONS(ARG2,NIL))),1,IN) %RETURN %FINISH %IF ARG1&NM=NM %THEN WSTR1=NUMTOSTR(ARG1) %ELSEC WSTR1=WA(ARG1>>8) %IF ARG2&NM=NM %THEN WSTR2=NUMTOSTR(ARG2) %ELSEC WSTR2=WA(ARG2>>8) %IF LENGTH(WSTR1)+LENGTH(WSTR2)>64 %THENSTART ERROR('WORD LENGTH EXCEEDED - ',%C CONS(ARG1,CONS(ARG2,NIL)),1,IN) %RETURN %FINISH STACK(PUT(WSTR1.WSTR2)) %RETURN %END; ! END WORD ! ! %ROUTINE LASTPUT %IF ARG2&LM=LM %THENSTART; ! ARG2 A LIST ARG3=NIL %WHILE ARG2#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT);%RETURN %FINISH %IF HOLDFLAG=1 %THENSTART ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN %FINISH ARG3=CONS(HD(ARG2),ARG3) ARG2=TL(ARG2) %REPEAT ! ARG3 NOW ARG2 REVERSED ARG2=CONS(ARG1,NIL) %WHILE ARG3#NIL %CYCLE ARG2=CONS(HD(ARG3),ARG2) ARG3=TL(ARG3) %REPEAT STACK(ARG2) %RETURN %FINISH ! ARG2 NOT A LIST SO WE WANT WORD ARG2,ARG1 ARG3=ARG1 ARG1=ARG2 ARG2=ARG3; !ARG1 AND ARG2 INTERCHANGED WORD %RETURN %END; ! END LASTPUT ! ! ! ! %INTEGERFN EQUAL(%INTEGER LIST1,LIST2) %IF QUITFLAG=1 %THENSTART QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1 %RESULT=QUIT %FINISH %IF HOLDFLAG=1 %THENSTART ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRESULT=UNSTACK %FINISH %IF LIST1=LIST2 %THENRESULT=TRUE; ! WORD %IF LIST1&LM=0 %OR LIST2&LM=0 %OR LIST1=NIL %OR LIST2=NIL %C %THENRESULT=FALSE %IF EQUAL(HD(LIST1),HD(LIST2))=TRUE %C %THENRESULT=EQUAL(TL(LIST1),TL(LIST2)) %RESULT=FALSE %END; ! END EQUAL ! ! %INTEGERFN GETNEXT(%INTEGERNAME IN) %INTEGER NEXT %IF IN=NIL %THENSTART ERROR('SOMETHING MISSING',EMPTY,1,IN) %RESULT=ERR %FINISH NEXT=HD(IN) IN=TL(IN) %RESULT=NEXT %END; ! END GETNEXT ! ! ! ! %ROUTINE FROMLIST(%INTEGER ITEM) %INTEGER ARG %IF HD(NEWFN)=ITEM %THENSTART NEWFN=TL(NEWFN); ! MATCH LATEST ENTRY %RETURN;%FINISH ARG=NEWFN %WHILE TL(ARG)#NIL %CYCLE %IF HD(TL(ARG))=ITEM %THENSTART ! REPTAIL(ARG,TL(TL(ARG))); ! ALTERS NEWFN LIST ! %RETURN;%FINISH ARG=TL(ARG) %REPEAT %END; ! END FROMLIST ! ! %ROUTINE EDIT(%INTEGER USERFUN) %INTEGER LINE,LESSLINE,REST,DELLIST,SAVESTK %STRING(3) SAVEPROM ! %ROUTINE FINDLINE(%INTEGER NUM) ! SETS REST TO FUN STARTING AT LINE>=NUM, AND SETS LESSLINE ! TO FUN STARTING ONE LINE BEFORE LESSLINE=USERFUN REST=TL(USERFUN) %WHILE REST#NIL %AND HD(HD(REST))>8); ! GET NEW SPEC %IF ARG2=0 %OR ARG2&USERPRE=USERPRE %THENSTART; ! NOT SYSFUN OLDFN(ITEM>>8)=FNVAL(ITEM>>8); ! SAVE OLD DEF OF NEW NAME FNVAL(ARG1>>8)=0; ! RESET OLD SPEC TO UNDEF OLDFN(ARG1>>8)=0 ARG1=ITEM; ! MAKE OLD NAME NEW PRSTRING('MOVING DEFINITION TO ') PRINTEL(ARG1) %IF ARG2#0 %THEN PRSTRING(' WHICH IS NOW REDEFINED') NOOLINE(1) %FINISHELSESTART; ! NEW NAAE IS SYSTEM FUN PRSTRING('YOU CANT REDEFINE A SYSTEM FUNCTION ') PRINTEL(ITEM) NOOLINE(1) %RETURN %FINISH %FINISH; ! FINISH ITEM#ARG1 ARG2=LINE %WHILE ARG2#NIL %CYCLE %IF HD(ARG2)=QUOTE %THEN ARG2=TL(ARG2) %ELSE ->ED1 %IF ARG2=NIL %THEN ->ED1 %IF HD(ARG2)&WM#WM %THEN ->ED1 ARG2=TL(ARG2) %REPEAT ->ED2 ED1:PRSTRING('INCORRECT FORM FOR FN ARGS') NOOLINE(1) %RETURN ED2:ARG2=LISTLEN(LINE); ! GET LENGTH OF REMAINING LINE ARG2=ARG2//2; ! NO OF PARAMS %IF ARG2>127 %THENSTART PRSTRING('TOO MANY ARGS') NOOLINE(1) %RETURN %FINISH ARG3=CONS1(TO,CONS1(ARG1,MOVE1(LINE))); ! REBUILD LINE IN FNSPACE REPHEAD(USERFUN,ARG3); ! REPLACE TITLE LINE IN DEF FNVAL(ARG1>>8)=USERPRE+USERFUN&M16+ARG2; ! NEW SPEC %FINISHELSESTART; ! FINISH ITEM=TO %IF ITEM=DO %THENSTART; ! LINE FOR IMMEDIATE EVAL LINE=TL(LINE) STKSYS(DELLIST) STKSYS(IN) EVAL(0,LINE,EACHVAL) IN=UNSTKSYS DELLIST=UNSTKSYS VAL=UNSTACK %FINISHELSESTART; ! FINISH DO %IF ITEM&NM=NM %THENSTART; ! A NUMBERED LINE TO INSERT OR ! OR REPLACE EXISTING LINE FINDLINE(ITEM) %IF REST#NIL %AND HD(HD(REST))=ITEM %THENSTART; ! A LINE TP REPLACE DELLIST=CONS(HD(REST),DELLIST); ! SAVE REPLACED LINE REPHEAD(REST,MOVE1(LINE)); ! AND REPLACE LINE %FINISHELSE REPTAIL(LESSLINE,CONS1(MOVE1(LINE),REST)); ! INSERT %FINISHELSESTART; ! FINISH ITEM=NUMBER %IF ITEM=DELETE %THENSTART LINE=TL(LINE); ! DISCARD DELETE ITEM=GETNEXT(LINE); ! GET LINE NUMBER %IF JUMPFLAG=1 %THENRETURN %IF ITEM&NM#NM %THENSTART PRSTRING('DELETE NEEDS A NUMBER') NOOLINE(1) %RETURN %FINISH FINDLINE(ITEM) %IF REST=NIL %OR HD(HD(REST))>ITEM %THENSTART; PRSTRING('NO SUCH LINE') NOOLINE(1) %RETURN %FINISHELSESTART DELLIST=CONS(HD(REST),DELLIST) REPTAIL(LESSLINE,TL(REST)) %FINISH %FINISHELSESTART; ! FINISH ITEM=DELETE %IF ITEM=UNDO %THENSTART; %IF DELLIST=NIL %THENSTART PRSTRING('NONE SAVED') NOOLINE(1) %RETURN %FINISH LINE=HD(DELLIST) DELLIST=TL(DELLIST) ->TOP %FINISHELSESTART; ! FINISH UNDO %IF ITEM=UNDOS %THENSTART ITEM=DELLIST %IF ITEM=NIL %THENSTART PRSTRING('NONE SAVED') NOOLINE(1) %RETURN %FINISH %WHILE ITEM#NIL %CYCLE PRINTLINE(HD(ITEM)) ITEM=TL(ITEM) %REPEAT %FINISHELSESTART; ! FINISH UNDOS PRSTRING('WRONG FORM') NOOLINE(1) %RETURN %FINISH %FINISH %FINISH %FINISH %FINISH %FINISH %END; ! END EDITLINE ! DELLIST=NIL SAVESTK=STKPNT LP1:SAVEPROM=PROMP PROMP='&:' PROMPT(PROMP) LP:LINE=READLINE %IF LINE=NIL %THEN ->LP %IF HD(LINE)=END %THENSTART; PROMP=SAVEPROM PROMPT(PROMP);%RETURN;%FINISH EDITLINE %IF JUMPFLAG=1 %THENSTART; ! RETURN FROM USERINT OR ERROR STKPNT=SAVESTK; ! RESTORE STACK TO EDIT ENTRY %IF JUMPOUT>0 %THENSTART JUMPOUT=JUMPOUT-1 STACK(VAL) %RETURN %FINISH ! JUMPOUT=0 JUMPFLAG=0; ->LP1 %FINISH; ! NOTE THAT AN EDIT ENTRY COUNTS TOWARDS AN ABORT N ->LP %END; ! END EDIT ! ! ! %ROUTINE GOTHDIR ! CONNECTS ANOTHERS MASTER DIR ! CALLED ONLY FROM LIBRARY ! WSTR1 USED FREE CONTAINS OWNERS NAME %INTEGER STADDR CLOSESM(4);CLEAR('SM04');DISCONNECT(MASDIR) DEFINE('SM04,'.WSTR1.'.'.MASDIR) STADDR=SMADDR(4,MLEN) MDENTS==BYTEINTEGER(STADDR) USERNAM==ARRAY(STADDR+1,UF) %END; ! END GOTHDIR ! %ROUTINE FROTHDIR ! FREES ANOTHERS DIR AND GETS OWN. USES WSTR1 FREE CLOSESM(4) CLEAR('SM04') DISCONNECT(WSTR1.'.'.MASDIR) GETMASTER %END; ! END FRPTHDIR ! %ROUTINE CLAIMMASTER ! CLAIMS MASTER DIR FOR WRITE %INTEGER ERRSED,STAT ERRSED=0 CLOSESM(4) CLEAR('SM04') DISCONNECT(MASDIR) TEST:STAT=STATUS(MASDIR) %IF STAT<0 %THENSTART GETMASTER ERROR('FINFO CALL FAILS - ',(-STAT)<<8!NM,1,IN) %RETURN %FINISH %IF STAT=0 %THENSTART; ! DIR NOT CONNECTED ELSEWHERE PERMITFILE(MASWRITE); ! PERMIT FOR WRITE %IF ERRSED=1 %THEN PRSTRING('DIRECTORY FREE') %AND NOOLINE(1) %FINISHELSESTART; ! CONNECTED ELSEWHERE %IF ERRSED=0 %THENSTART PRSTRING('YOUR DIRECTORY IS IN USE BY ANOTHER - WAIT') NOOLINE(1) ERRSED=1 %FINISH %IF QUITFLAG=1 %THENSTART; ! INT Q QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1;STACK(QUIT) ->GETM %FINISH %IF HOLDFLAG=1 %THENSTART; ! INT H HOLDFLAG=0 %IF FUN#NIL %THENSTART GETMASTER ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN CLOSESM(4) CLEAR('SM04') DISCONNECT(MASDIR) ->TEST %FINISH JUMPOUT=0;JUMPFLAG=0;STACK(QUIT) ->GETM %FINISH ->TEST %FINISH GETM:GETMASTER %END; ! END CLAIMMASTER ! %ROUTINE SHAREFILE(%STRING(15) FILENAME,%INTEGER FLAG) ! CONNECTS A FILE FOR SHARED READ !IF CURRENTLY CONNECTED WRITE ELSEWHERE WAITS IN AN INTERRUPTABLE LOOP %INTEGER ERRSED,STAT ERRSED=0 TEST:STAT=STATUS(FILENAME) %IF STAT<0 %THENSTART ERROR('FINFO CALL FAILS - ',(-STAT)<<8!NM,1,IN) %RETURN %FINISH %IF STAT&1#1 %THENSTART; ! NOT CONNECTED WRITE ELSEWHERE %IF ERRSED=1 %THEN PRSTRING('DIRECTORY FREE') %AND NOOLINE(1) %RETURN %FINISH %IF FLAG=1 %THENSTART; ! LIB IN WRITE MODE ELSEWHERE ERROR('LIBRARY IS BEING UPDATED - TRY LATER',EMPTY,1,IN) %RETURN %FINISH %IF ERRSED=0 %THENSTART PRSTRING('LIBRARY OWNER''S DIRECTORY IS BEING UPDATED - WAIT') NOOLINE(1) ERRSED=1 %FINISH %IF QUITFLAG=1 %THENSTART QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1;STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0 %IF FUN#NIL %THENSTART ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN ->TEST %FINISH JUMPOUT=0;JUMPFLAG=1;STACK(QUIT) %RETURN %FINISH ->TEST %END; ! END SHAREFILE ! %ROUTINE GETPAGE(%STRING(10) %NAME SIZE) %INTEGER I,J,LEN DEFINE('SM10,JUNK') NEWSMFILE('JUNK,'.SIZE) TEMPUSER==ARRAY(SMADDR(10,LEN)+1,UF) TDENTS==BYTEINTEGER(SMADDR(10,LEN)) J=MDENTS;%CYCLE I=1,1,J TEMPUSER(I)=USERNAM(I) %REPEAT TDENTS=MDENTS CLOSESM(4) CLEAR('SM04') DESTROY('LOGODIR') RENAME('JUNK,LOGODIR') CLOSESM(10) CLEAR('SM10') %RETURN %END; ! END GETPAGE ! %INTEGERFN GETFILE(%INTEGER USER,FLAG) ! FLAG 0 SEARCH FOR LOGOFILE ! 1 SEARCH FOR LIBRARY %STRING(10) TEMP,SIZE %STRING (64) S %BYTEINTEGER I S=WA(USER>>8) %UNLESS MDENTS=0 %THENSTART I=1 %WHILE I<=MDENTS %CYCLE %IF USERNAM(I)=S %THEN %START TEMP=NUMTOSTR(I<<8) USERFILE = 'AI2LG'.TEMP %IF FLAG=1 %THENSTART FROTHDIR; ! FREE OWNERS DIR SHAREFILE(WSTR1.'.'.USERFILE,1); ! ONLY GET HERE FROM LIBRARY ! SO OWNER IN WSTR1 SET THERE %IF JUMPFLAG=1 %THENRESULT=-3 %RESULT=I %FINISH DEFINE('SM05,'.USERFILE) GETDIR(1,5) %RESULT=I %FINISH I=I+1 %REPEAT %FINISH %IF FLAG=0 %THENSTART CLAIMMASTER; ! GET MASTER FOR WRITE %IF JUMPFLAG=1 %THENRESULT=-3 %IF MDENTS>=189 %THEN FREEMASTER %AND %C BADERROR('MASTER DIR HAS OVERFLOWED 3 PAGE FILE',EMPTY) %IF MDENTS=63 %OR MDENTS=127 %THENSTART SIZE=NUMTOSTR((MLEN+4096)<<8) TEMP='LOGODIR' GETPAGE(SIZE) GETMASTER; ! CONNECT TO EXTENDED DIR STILL IN WRITE MODE %FINISH TEMP=NUMTOSTR((MDENTS+1)<<8) USERFILE='AI2LG'.TEMP DEFINE('SM05,'.USERFILE) NEWSMFILE(USERFILE.',16384') PERMITFILE(USERFILE.',,8') CHERISH(USERFILE) MDENTS=MDENTS+1 USERNAM(MDENTS)=S FREEMASTER NOOLINE(1);PRINTEL(USER);PRSTRING(' CREATED') GETDIR(0,5) %RESULT=MDENTS %FINISH FROTHDIR %RESULT=-1 %END; ! END GETFILE ! ! ! ! %ROUTINE UPDIR(%INTEGER NAME) %INTEGER ARG3 %IF UDENTS=0 %THEN -> 1 %CYCLE ARG3=1,1,UDENTS %IF WA(NAME>>8)=DIRNAM(ARG3) %THENSTART DIRVAL(ARG3)=UNFS -> 2 %FINISH %REPEAT ! NEW USER FUN 1: UDENTS=UDENTS+1 DIRNAM(UDENTS)=WA(NAME>>8) DIRVAL(UDENTS)=UNFS ! ! 2: UNFS=INDEX; ! INDEX BACK POINTING TO NFSP %RETURN %END; ! END UPDIR ! ! ! ! ->SYSFUN(SW) ! ! INPUT OUTPUT SYSFUN(1):; ! PRINT ARG1=UNSTACK %IF ARG1=ENEL %THEN NOOLINE(1) %ELSE PRINTEL(ARG1) NOOLINE(1) STACK(ARG1) %RETURN ! ! SYSFUN(2):; ! TYPE ARG1=UNSTACK %IF ARG1=ENEL %THEN NOOLINE(1) %ELSE PRINTEL(ARG1) STACK(ARG1) %RETURN; ! END TYPE ! ! SYSFUN(3):; ! GETLIST BLEVEL=2 PROMPT('DATA:') STACK(READLIST(BLEVEL)) PROMPT(PROMP) %RETURN; ! END GETLIST ! ! SYSFUN(4):; ! GETWORD BLEVEL=2 PROMPT('DATA:') ARG1=READLIST(BLEVEL) %IF ARG1=NIL %THEN STACK(EMPTY) %ELSESTART ARG1=HD(ARG1) %IF ARG1&LM=LM %THENSTART;PRSTRING('NOT A WORD');NOOLINE(1); ->SYSFUN(4) %FINISH STACK(ARG1) %FINISH PROMPT(PROMP) %RETURN; ! END GETWORD ! ! ! ARITHMETIC SYSFUN(10):; ! + OR SUM READYNUM %IF JUMPFLAG=1 %THENRETURN STACK(CHECKSIZE(ARG1+ARG2)<<8!NM) %RETURN; ! END SUM ! ! ! SYSFUN(11):; ! - OR DIFFERENCE READYNUM %IF JUMPFLAG=1 %THENRETURN STACK(CHECKSIZE(ARG1-ARG2)<<8!NM) %RETURN; ! END DIFFEREBCE ! ! SYSFUN(12):; ! * OR TIMES READYNUM %IF JUMPFLAG=1 %THENRETURN STACK(CHECKSIZE(ARG1*ARG2)<<8!NM) %RETURN; ! END TIMES ! ! SYSFUN(13):; ! / OR QUOTIENT READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG2=0 %THENSTART ERROR('DIVISION BY ZERO - ',CONS(FN,CONS(ARG1,CONS(ARG2,NIL))),1,IN) %RETURN %FINISH STACK(CHECKSIZE(ARG1//ARG2)<<8!NM) %RETURN; ! END QUOTIENT ! ! SYSFUN(14):; ! REMAINDER READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG2=0 %THENSTART ERROR('DIVISION BY ZERO - ',CONS(FN,CONS(ARG1,CONS(ARG2,NIL))),1,IN) %RETURN %FINISH STACK(CHECKSIZE(ARG1-(ARG1//ARG2)*ARG2)<<8!NM) %RETURN; ! END REMAINDER ! ! SYSFUN(15):; ! DIVISION READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG2=0 %THENSTART ERROR('DIVISION BY ZERO - ',CONS(FN,CONS(ARG1,CONS(ARG2,NIL))),1,IN) %RETURN %FINISH ARG3=ARG1//ARG2; ! ARG3 USED TEMP STACK(CONS(CHECKSIZE(ARG3)<<8!NM,CONS(CHECKSIZE(ARG1-ARG3*ARG2)%C <<8! NM,NIL))) %RETURN; ! END DIVISION ! ! SYSFUN(16):; ! MAXIMUM READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG1>=ARG2 %THEN STACK(ARG1<<8!NM) %ELSE STACK(ARG2<<8!NM) %RETURN; ! END MAXIMUM ! ! SYSFUN(17):; ! MINIMUM READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG1<=ARG2 %THEN STACK(ARG1<<8!NM) %ELSE STACK(ARG2<<8!NM) %RETURN; ! END MIMIMUM ! ! ! ! CHARACTER AND LIST MANIPULATION ! SYSFUN(20):; ! FIRST ARG1=UNSTACK %IF ARG1&LM#LM %THENSTART ERROR('NON-LIST ARG FOR LIST FN FIRST - ',ARG1,1,IN) %RETURN %FINISH %IF ARG1=NIL %THENSTART ERROR('EMPTY LIST FOR LIST FN FIRST - ',ARG1,1,IN) %RETURN %FINISH STACK(HD(ARG1)) %RETURN; ! END FIRST ! ! SYSFUN(21):; ! LAST ARG1=UNSTACK %IF ARG1&LM#LM %THENSTART ERROR('NON-LIST ARG FOR LIST FN LAST - ',ARG1,1,IN) %RETURN %FINISH %IF ARG1=NIL %THENSTART ERROR('EMPTY LIST FOR LIST FN LAST - ',ARG1,1,IN) %RETURN %FINISH %WHILE TL(ARG1)#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN %FINISH ARG1=TL(ARG1) %REPEAT STACK(HD(ARG1)) %RETURN; ! END LAST ! ! SYSFUN(22):; ! BUTFIRST ARG1=UNSTACK %IF ARG1&LM#LM %THENSTART ERROR('NON-LIST ARG FOR LIST FN BUTFIRST - ',ARG1,1,IN) %RETURN %FINISH %IF ARG1=NIL %THENSTART ERROR('EMPTY LIST FOR LIST FN BUTFIRST - ',ARG1,1,IN) %RETURN %FINISH STACK(TL(ARG1)) %RETURN; ! END BUTFIRST ! ! SYSFUN(23):; ! BUTLAST ARG1=UNSTACK %IF ARG1&LM#LM %THENSTART ERROR('NON-LIST ARG FOR LIST FN BUTLAST - ',ARG1,1,IN) %RETURN %FINISH %IF ARG1=NIL %THENSTART ERROR('EMPTY LIST FOR LIST FN BUTLAST - ',ARG1,1,IN) %RETURN %FINISH ARG2=NIL; ! ARG2 USED TEMP %WHILE TL(ARG1)#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN %FINISH ARG2=CONS(HD(ARG1),ARG2) ARG1=TL(ARG1) %REPEAT ! ARG2 NOW HAS ARG1 LESS LAST ELEMENT REVERSED ARG1=NIL %WHILE ARG2#NIL %CYCLE ARG1=CONS(HD(ARG2),ARG1) ARG2=TL(ARG2) %REPEAT STACK(ARG1) %RETURN; ! END BUTLAST ! ! SYSFUN(24):; ! WORD ARG2=UNSTACK ARG1=UNSTACK WORD %RETURN; ! END WORD ! ! SYSFUN(25):; ! LIST ARG2=UNSTACK ARG1=UNSTACK STACK(CONS(ARG1,CONS(ARG2,NIL))) %RETURN; ! ND LIST ! ! SYSFUN(26):; ! FIRSTPUT ARG2=UNSTACK ARG1=UNSTACK %IF ARG2&LM=LM %THENSTART; ! ARG2 A LIST STACK(CONS(ARG1,ARG2)) %RETURN %FINISH WORD %RETURN; ! END FIRSTPUT ! ! SYSFUN(27):; ! LASTPUT ARG2=UNSTACK ARG1=UNSTACK LASTPUT %RETURN; ! END LASTPUT ! ! SYSFUN(28):; ! JOIN ARG2=UNSTACK ARG1=UNSTACK %IF ARG1&LM#LM %THENSTART ERROR('NON-LIST ARG FOR LIST FN JOIN - ',ARG1,1,IN) %RETURN %FINISH %IF ARG2&LM#LM %THENSTART ERROR('NON-LIST ARG FOR LIST FN JOIN - ',ARG2,1,IN) %RETURN %FINISH ARG3=NIL; ! ARG3 USED TEMP %WHILE ARG1#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN %FINISH ARG3=CONS(HD(ARG1),ARG3) ARG1=TL(ARG1) %REPEAT ! ARG3 NOW ARG1 REVERSED %WHILE ARG3#NIL %CYCLE ARG2=CONS(HD(ARG3),ARG2) ARG3=TL(ARG3) %REPEAT STACK(ARG2); ! LISTS APPENDED %RETURN; ! END JOIN ! ! SYSFUN(29):; ! COUNT ARG1=UNSTACK %IF ARG1&LM#LM %THENSTART ERROR('NON-LIST ARG FOR LIST FN COUNT - ',ARG1,1,IN) %RETURN %FINISH ARG2=0 %WHILE ARG1#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN %FINISH ARG2=ARG2+1 ARG1=TL(ARG1) %REPEAT STACK(ARG2<<8!NM) %RETURN; ! END COUNT ! ! ! PREDICATES AND CONDITIONALS ! ! ! ! SYSFUN(30):; ! LESS THAN READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG1ARG2 %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; ! END GREATER THAN ! ! SYSFUN(33):; ! GREATER THAN OR EQUAL TO READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG1>=ARG2 %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; ! END GREATER THAN OR EQUAL TO ! ! SYSFUN(34):; ! EQUAL TO ARG2=UNSTACK ARG1=UNSTACK ARG3=EQUAL(ARG1,ARG2) STACK(ARG3) %RETURN; ! END EQUAL TO ! ! SYSFUN(35):; !ZEROQ ARG1=UNSTACK %IF ARG1&NM=NM %AND ARG1>>8=0 %C %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; ! END ZEROQ ! ! SYSFUN(36):; ! NUMBERQ ARG1=UNSTACK %IF ARG1&NM=NM %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; ! END NUMBERQ ! ! SYSFUN(37):; ! WORDQ ARG1=UNSTACK %IF ARG1&WM=WM %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; ! END WORDQ ! ! SYSFUN(38):; !LISTQ ARG1=UNSTACK %IF ARG1&LM=LM %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; ! END LISTQ ! ! SYSFUN(39):; !EMPTYQ ARG1=UNSTACK %IF ARG1=NIL %OR ARG1=EMPTY %C %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; !END EMPTYQ ! ! SYSFUN(40):; ! BOTH ARG2=UNSTACK ARG1=UNSTACK %IF ARG1=TRUE %AND ARG2=TRUE %C %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; ! END BOTH ! ! SYSFUN(41):; ! EITHER ARG2=UNSTACK ARG1=UNSTACK %IF ARG1=TRUE %OR ARG2=TRUE %C %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; ! END EITHER ! ! SYSFUN(42):; !NOT ARG1=UNSTACK %IF ARG1=TRUE %THEN STACK(FALSE) %ELSE STACK(TRUE) %RETURN; ! END NOT ! ! ! SYSFUN(50):; ! TEST ARG1=UNSTACK %IF ARG1=TRUE %THEN TSTFLG=1 %ELSESTART %IF ARG1=FALSE %THEN TSTFLG=0 %ELSESTART ERROR('BAD ARG FOR TEST - ',ARG1,1,IN) %RETURN %FINISH %FINISH STACK(ARG1) %RETURN; ! END TEST ! ! SYSFUN(51):; ! IFTRUE %IF TSTFLG=1 %THENSTART EVAL(0,IN,EACHVAL) %IF JUMPFLAG=1 %THENRETURN %FINISHELSESTART IN=NIL STACK(FALSE) %FINISH %RETURN; ! END IFTRUE ! ! SYSFUN(52):; ! IFFALSE %IF TSTFLG=0 %THENSTART EVAL(0,IN,EACHVAL) %IF JUMPFLAG=1 %THENRETURN %FINISHELSESTART IN=NIL STACK(TRUE) %FINISH %RETURN; ! END IFFALSE ! ! SYSFUN(53):; ! IF IN=CONS(FN,IN); ! PUT BACK IF ARG1=NIL;ARG2=NIL;ARG3=NIL W1=EXTRACT(ARG1,ARG2,ARG3) %IF W1#EMPTY %THENSTART ERROR('MISSING ',W1,1,IN) %RETURN %FINISH ! ARG1 HAS IF COND REVERSED ! ARG2 HAS THEN THENCLAUSE REVERSED ! ARG3 HAS ELSE ELSECLAUSE REVERSED OR NIL ARG1=TL(REVERSE(ARG1)); ! REVERSE AND REMOVE LEADING IF ARG2=TL(REVERSE(ARG2)); ! REMOVE LEADING THEN %IF ARG3#NIL %THEN ARG3=TL(REVERSE(ARG3)) ! ARG1 NOW HAS COND,ARG2 THENCLAUSE AND ARG3 ELSECLAUSE ! ALL OR ANY MAY BE NIL %IF ARG1=NIL %THENSTART ERROR('NULL CONDITION',EMPTY,1,IN) %RETURN %FINISH STKSYS(ARG2);STKSYS(ARG3);STKSYS(IN) EVAL(0,ARG1,EACHVAL); ! EVAL CONDITION IN=UNSTKSYS;ARG3=UNSTKSYS;ARG2=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN W1=UNSTACK; ! RESULT OF CONDITION %IF W1=TRUE %THENSTART; ! COND TRUE %IF ARG2=NIL %THENSTART ERROR('NULL THEN CLAUSE',EMPTY,1,IN) %RETURN %FINISHELSESTART STKSYS(ARG1);STKSYS(ARG3);STKSYS(IN) EVAL(0,ARG2,EACHVAL); ! EVAL THEN CLAUSE DUMLAB: IN=UNSTKSYS;ARG3=UNSTKSYS;ARG1=UNSTKSYS ! DUMLAB INSERTED TO AVOID COMPILER ERRROR RESULTING IN ! ADDRESS ERROR ON RETURN TO HERE. %IF JUMPFLAG=1 %THENRETURN W2=UNSTACK %FINISH %FINISHELSESTART; ! W1#TRUE %IF W1=FALSE %THENSTART %IF ARG3=NIL %THEN W2=NIL %ELSESTART STKSYS(ARG1);STKSYS(ARG2);STKSYS(IN) EVAL(0,ARG3,EACHVAL) IN=UNSTKSYS;ARG2=UNSTKSYS;ARG1=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN W2=UNSTACK %FINISH %FINISHELSESTART; ! W1#TRUE AND #FALSE ERROR('BAD CONDITION - ',W1,1,IN) %RETURN %FINISH %FINISH STACK(W2) %RETURN; ! END IF ! ! SYSFUN(54):; ! WHILE IN=CONS(FN,IN) ARG1=NIL;ARG2=NIL;ARG3=NIL W1=EXTRACT(ARG1,ARG2,ARG3) %IF W1#EMPTY %THENSTART ERROR('MISSING ',W1,1,IN) %RETURN %FINISH ! ARG1 HAS 'WHILE COND' REVERSED ! ARG2 HAS 'THEN THENCLAUSE' REVERSED ARG1=TL(REVERSE(ARG1)) ARG2=TL(REVERSE(ARG2)) ! ARG1 NOW HAS COND, ARG2 HAS THENCLAUSE ! ONE OR BOTH MAY BE NIL %IF ARG1=NIL %THENSTART ERROR('NULL CONDITION',EMPTY,1,IN) %RETURN %FINISH %IF ARG2=NIL %THENSTART ERROR('NULL THEN CLAUSE',EMPTY,1,IN) %RETURN %FINISH ARG3=NIL; ! RESULT IF COND FALSE FIRST TIME ROUTND %CYCLE W1=ARG1 STKSYS(ARG1);STKSYS(ARG2);STKSYS(IN) EVAL(0,W1,EACHVAL) IN=UNSTKSYS;ARG2=UNSTKSYS;ARG1=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN W2=UNSTACK %IF W2=TRUE %THENSTART W1=ARG2 STKSYS(ARG1);STKSYS(ARG2);STKSYS(IN) EVAL(0,W1,EACHVAL) IN=UNSTKSYS;ARG2=UNSTKSYS;ARG1=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN ARG3=UNSTACK; ! RESULT %FINISHELSESTART %IF W2=FALSE %THENEXIT %ELSESTART ERROR('BAD CONDITION - ',W2,1,IN) %RETURN %FINISH %FINISH %REPEAT STACK(ARG3) %RETURN; ! END WHILE ! ! SYSFUN(60):; ! TO REDEF=0; ! USED TO TELL IF FUN REDEFINED ARG1=GETNEXT(IN) %IF JUMPFLAG=1 %THENRETURN %IF ARG1&WM#WM %THENSTART ERROR('TO WHAT? ',CONS(FN,CONS(ARG1,IN)),1,IN) %RETURN %FINISH ARG2=FNVAL(ARG1>>8); ! GET FUNSPEC %IF ARG2=0 %THEN ->MAKESPEC; ! UNDEFINED %IF ARG2&USERPRE=USERPRE %THENSTART REDEF=1 ->MAKESPEC %FINISH ERROR('YOU CANT REDEFINE A SYSTEM FUNCTION - ',ARG1,1,IN) %RETURN MAKESPEC:W1=REVQUOTE(IN); ! CHECK FOR 'NAME 'NAME ETC. %IF JUMPFLAG=1 %THENRETURN W1=LISTLEN(IN); ! GET LENGTH OF REMAINING LINE ! ': ARG : ARG ETC' W1=W1//2; ! NUMBER OF PARAMS %IF W1>127 %THENSTART ERROR('TOO MANY ARGS FOR ',ARG1,1,IN) %RETURN %FINISH ! ALL OK FROMLIST(ARG1) %UNLESS NEWFN=NIL %IF REDEF=1 %THEN OLDFN(ARG1>>8)=ARG2; ! STANDBY DEFN ARG3=CONS1(CONS1(FN,CONS1(ARG1,MOVE1(IN))),NIL); ! REBUILD LINE IN FNSPACE AND INSERT ! AS FRST COMP OF DEF FNVAL(ARG1>>8)=USERPRE+ARG3&M16+W1; ! BUILD SPEC EDIT(ARG3); ! GOTO EDIT FOR REST OF DEF %IF JUMPFLAG=1 %THENRETURN %IF DEVICE#DISC %THEN NEWFN=CONS(ARG1,NEWFN) DEVICE=TTY PRINTEL(ARG1) %IF REDEF=1 %THEN PRSTRING(' REDEFINED') %ELSEC PRSTRING(' DEFINED') NOOLINE(1) STACK(ARG1) %RETURN; ! END TO ! ! SYSFUN(61):; ! EDIT ARG1=UNSTACK FROMLIST(ARG1) %UNLESS NEWFN=NIL %IF ARG1&WM#WM %THENSTART ERROR('EDIT WHAT? ',CONS(FN,CONS(ARG1,NIL)),1,IN) %RETURN %FINISH ARG2=FNVAL(ARG1>>8); ! GET SPEC %IF ARG2=0 %THENSTART ERROR('FUNCTION FOR EDIT UNDEFINED - ',ARG1,1,IN) %RETURN %FINISH %IF ARG2&USERPRE#USERPRE %THENSTART ERROR('SYSTEM FUNCTION CANNOT BE EDITED - ',ARG1,1,IN) %RETURN %FINISH ARG2=ARG2&M16!LM; ! POINTER TO LIST DEF EDIT(ARG2) %IF JUMPFLAG=1 %THENRETURN %IF DEVICE#DISC %THEN NEWFN=CONS(ARG1,NEWFN) DEVICE=TTY PRINTEL(ARG1) PRSTRING(' EDITED') NOOLINE(1) STACK(ARG1) %RETURN; ! END EDIT ! ! SYSFUN(62):; ! MAKE ARG2=UNSTACK ARG1=UNSTACK %IF ARG1&WM#WM %THENSTART ERROR('NON-WORD FIRST ARG FOR MAKE - ',ARG1,1,IN) %RETURN %FINISH SETVAL(ARG1,ARG2,ENVIR) STACK(ARG2) %RETURN; ! END MAKE ! ! SYSFUN(63):; ! NEW ARG1=UNSTACK; ! GET LIST OF NAMES %IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL) %ELSE CHKLIST(ARG1) %IF JUMPFLAG=1 %THENRETURN ARG2=LISTLEN(ARG1) %IF ENVIR=BASENVIR %THENSTART; ! CREATE GLOBALS %CYCLE ARG3=1,1,ARG2 SETVAL(HD(ARG1),NIL,ENVIR) ARG1=TL(ARG1) %REPEAT %FINISHELSESTART; ! CREATE LOCALS %CYCLE ARG3=1,1,ARG2 STACK(NIL); ! VALUES ONTO STACK %REPEAT ENVIR=SETBIND(ARG1,ENVIR) %FINISH STACK(NIL) %RETURN; ! END NEW ! ! SYSFUN(64):; ! GO ARG1=UNSTACK %IF ARG1&NM#NM %THENSTART ERROR('GO NEEDS A NUMBER - ',ARG1,1,IN) %RETURN %FINISH ARG2=FUN; ! USER FUN CURRENT %WHILE ARG2#NIL %CYCLE %IF HD(HD(TL(ARG2)))=ARG1 %THENSTART CURFUN=ARG2; ! ONE LINE BEFORE REQUESTED LINE STACK(ARG1) %RETURN %FINISH ARG2=TL(ARG2) %REPEAT ERROR('NO SUCH LINE NUMBER - ',ARG1,1,IN) %RETURN; ! END GO ! ! ! SYSFUN(65):; ! STOP CURFUN=CONS(NIL,NIL); ! APPLYUSR STOPS WHEN A SINGLE LINE LEFT STACK(TRUE) %RETURN; ! END STOP ! ! SYSFUN(66):; ! RESULT (OUTPUT) CURFUN=CONS(NIL,NIL) ! STACK(UNSTACK) %RETURN; ! END RESULT ! ! SYSFUN(67):; ! RENUMBER ARG1=UNSTACK %IF ARG1&WM#WM %THENSTART ERROR('RENUMBER WHAT? ',ARG1,1,IN) %RETURN %FINISH ARG2=FNVAL(ARG1>>8); ! GET SPEC %IF ARG2=0 %THENSTART ERROR('UNDEFINED FUNCTION FOR RENUMBER - ',ARG1,1,IN) %RETURN %FINISH %IF ARG2&USERPRE#USERPRE %THENSTART ERROR('SYSTEM FUNCTION CANNOT BE RENUMBERED - ',ARG1,1,IN) %RETURN %FINISH ARG2=ARG2&M16!LM; ! LIST DEF POINTER ARG3=10 ARG2=TL(ARG2); ! DEF STARTING AT FIRST NUMBERED LINE %WHILE ARG2#NIL %CYCLE REPHEAD(HD(ARG2),ARG3<<8!NM) ARG3=ARG3+10 ARG2=TL(ARG2) %REPEAT PRINTEL(ARG1) PRSTRING(' RENUMBERED') NOOLINE(1) STACK(ARG1) %RETURN; ! END RENUMBER ! ! ! ! SYSFUN(68):; ! SHOWALL ARG2=0 %CYCLE ARG1=0,1,1022 %IF FNVAL(ARG1)&USERPRE=USERPRE %THENSTART NOOLINE(1) ARG3=FNVAL(ARG1)&M16!LM %WHILE ARG3#NIL %CYCLE PRINTLINE(HD(ARG3)) ARG3=TL(ARG3) %REPEAT PRINTEL(END) NOOLINE(1) ARG2=1 %FINISH %REPEAT %IF ARG2=0 %THEN PRSTRING('NO USER FUNS DEFINED YET') NOOLINE(1) STACK(TRUE) %RETURN; ! END SHOWALL ! ! ! SYSFUN(69):; !SHOWSAVEDALL %IF CACTFILE=0 %THENSTART ERROR('NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN %%FINISH NOOLINE(1) %IF UDENTS=0 %THEN PRSTRING('NO USER FUNS SAVED YET') %AND ->SSALL1 %CYCLE ARG2=1,1,UDENTS %UNLESS DIRVAL(ARG2)=M' ' %THENSTART INDEX=DIRVAL(ARG2) NOOLINE(1) %CYCLE DEVICE=DISC ARG3=READLINE DEVICE=TTY PRINTLINE(ARG3) %IF HD(ARG3)=END %THENEXIT %REPEAT %FINISH %REPEAT SSALL1:NOOLINE(1) STACK(TRUE) %RETURN; ! END SHOWSAVEDALL ! ! ! SYSFUN(70):; ! DOT SHOW ARG1=UNSTACK %IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL) %IF ARG1&LM#LM %THENSTART ERROR1('NON-WORD FOR SHOW - ',ARG1) ->SH2 %FINISH %WHILE ARG1#NIL %CYCLE ARG2=HD(ARG1) ARG1=TL(ARG1) %IF ARG2&WM#WM %THENSTART ERROR1('NON WORD FOR SHOW - ',ARG2) ->SH1 %FINISH ARG3=FNVAL(ARG2>>8); ! GET SPEC %IF ARG3=0 %THENSTART ERROR1('UNDEF FN FOR SHOW - ',ARG2) ->SH1 %FINISH %IF ARG3&USERPRE#USERPRE %THENSTART ERROR1('SYSFUN FOR SHOW - ',ARG2) ->SH1 %FINISH ARG3=ARG3&M16!LM; ! DEFINITION NOOLINE(1) %WHILE ARG3#NIL %CYCLE PRINTLINE(HD(ARG3)) ARG3=TL(ARG3) %REPEAT PRINTEL(END) NOOLINE(1) SH1:%REPEAT SH2:NOOLINE(1) STACK(TRUE) %RETURN; ! END SHOW ! SYSFUN(71):; ! DOT SHOWTITLES ARG2=0 NOOLINE(1) %CYCLE ARG1=0,1,1022 %IF FNVAL(ARG1)&USERPRE=USERPRE %THEN %C PRINTLINE(HD(FNVAL(ARG1)&M16!LM)) %AND ARG2=1 %REPEAT %IF ARG2=0 %THEN PRSTRING( ' NO USER FUNS DEFINED YET') NOOLINE(1) STACK(TRUE) %RETURN; ! END SHOWTITLES ! ! SYSFUN(72):; ! DOT SAVE ARG1 ARG2 ETC ARG3=UNSTACK %IF CACTFILE=0 %THEN%START ERROR(' NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN;%FINISH %IF ARG3&WM=WM %THEN ARG3=CONS(ARG3,NIL) %IF ARG3&LM#LM %THENSTART ERROR1('NON-WORD FOR SAVE - ',ARG3) ->SAVE2 %FINISH %WHILE ARG3#NIL %CYCLE ARG1=HD(ARG3) ARG3=TL(ARG3) %IF ARG1&WM#WM %THEN%START ERROR1(' NON-WORD FOR SAVE - ',ARG1) ->SAVEREP;%FINISH ARG2=FNVAL(ARG1>>8) %IF ARG2=0 %THEN%START ERROR1(' UNDEFINED FN FOR SAVE - ',ARG1) ->SAVEREP;%FINISH %IF ARG2&USERPRE#USERPRE %THEN%START ERROR1(' SYSTEM FN FOR SAVE - ',ARG1) ->SAVEREP;%FINISH DEVICE=DISC %WHILE UDENTS=118 %CYCLE; ! DIRECTORY FULL FILETIDY; ! TRY A TIDY TO REMOVE FORGOTTEN ENTRIES %IF UDENTS=118 %THENSTART; ! TIDY HAS NOT RECOVERED ANY ERROR('USER DIRECTORY FULL',EMPTY,0,IN) %IF JUMPFLAG=1 %THENSTART; ! EXIT DEVICE=TTY %RETURN %FINISH %FINISHELSEEXIT; ! TIDY HAS RECOVERD SOME, SO CARRY ON %REPEAT; ! DIR WAS FULL AND TIDY NO GOOD BUT USER HAS CONTINUED ! SO TRY TIDY AGAIN ARG2=ARG2&M16!LM INDEX=UNFS %WHILE ARG2#NIL %CYCLE PRINTLINE(HD(ARG2)); ! ASSUME HAS SEMI-COL ARG2=TL(ARG2) %REPEAT PRINTEL(END) LGPRNT STR(STERMIN) ! ! ! UPDATE DIRECTORY UPDIR(ARG1) ! FROMLIST(ARG1) %UNLESS NEWFN=NIL NOOLINE(1) PRSTRING(WA(ARG1>>8));PRSTRING(' SAVED'); SAVEREP:%REPEAT DEVICE=TTY SAVE2:NOOLINE(2) STACK(TRUE) %RETURN; ! END SAVE ! ! ! ! SYSFUN(73):; ! GETFILE CLUSERFL ARG1=UNSTACK %IF ARG1&WM#WM %THENSTART ERROR(' NON-WORD FOR GETFILE - ',ARG1,1,IN) %RETURN;%FINISH ARG3=0; ! INDICATES SEARCH ONLY ARG2=GETFILE(ARG1,ARG3) %IF JUMPFLAG=1 %THENRETURN NOOLINE(1);PRINTEL(ARG1);PRSTRING(' ACTIVE');NOOLINE(1) STACK(TRUE) %RETURN; ! END GETFILE ! ! SYSFUN(74):; ! LOAD DOT ARG1=UNSTACK %IF CACTFILE=0 %THENSTART ERROR(' NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN;%FINISH %IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL) %IF ARG1&LM#LM %THENSTART ERROR1('NON-WORD FOR LOAD - ',ARG1) ->LD2 %FINISH %WHILE ARG1#NIL %CYCLE W1=HD(ARG1) ARG1=TL(ARG1) %IF W1&WM#WM %THENSTART ERROR1(' NON-WORD FOR LOAD - ',W1) ->REP;%FINISH %IF UDENTS=0 %THENSTART NOOLINE(1) PRSTRING( ' NO USER FUNS SAVED ') NOOLINE(1) STACK(TRUE) %RETURN;%FINISH %CYCLE ARG2=1,1,UDENTS %IF WA(W1>>8)=DIRNAM(ARG2) %THEN %START INDEX=DIRVAL(ARG2) DEVICE=DISC ARG3=READLINE STKSYS(IN); STKSYS(ARG1) EVAL(0,ARG3,EACHVAL) ARG1=UNSTKSYS;IN=UNSTKSYS %IF JUMPFLAG=1 %THENSTART;DEVICE=TTY;%RETURN;%FINISH ARG3=UNSTACK -> REP %FINISH %REPEAT PRSTRING(WA(W1>>8));PRSTRING( ' NOT SAVED') NOOLINE(1) REP:%REPEAT DEVICE=TTY LD2:STACK(TRUE) %RETURN; ! END LOAD ! ! SYSFUN(75):; ! SHOWSAVED ARG1 ARG2 ETC ARG1=UNSTACK %IF CACTFILE=0 %THENSTART ERROR(' NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN;%FINISH %IF UDENTS=0 %THENSTART NOOLINE(1);PRSTRING(' NO USER FNS SAVED YET') NOOLINE(1);STACK(TRUE);%RETURN;%FINISH %IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL) %IF ARG1&LM#LM %THENSTART ERROR1('NON-WORD FOR SHOWSAVED - ',ARG1) ->SS2 %FINISH %WHILE ARG1#NIL %CYCLE W1=HD(ARG1) ARG1=TL(ARG1) %IF W1&WM#WM %THENSTART ERROR1(' NON-WORD FOR SHOWSAVED - ',W1) ->NEW;%FINISH %CYCLE ARG3=1,1,UDENTS %IF DIRNAM(ARG3)=WA(W1>>8) %THEN %START INDEX=DIRVAL(ARG3) NOOLINE(1) RL:DEVICE=DISC ARG2=READLINE DEVICE=TTY PRINTLINE(ARG2) %IF HD(ARG2)=END %THEN ->NEW ->RL %FINISH %REPEAT NOOLINE(1);PRSTRING(WA(W1>>8));PRSTRING( ' NOT SAVED') NOOLINE(1) NEW:;%REPEAT SS2:NOOLINE(1) STACK(TRUE);%RETURN ! ! ! ! SYSFUN(76):; ! LOADSAVED %IF CACTFILE=0 %THENSTART ERROR(' NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN;%FINISH %IF UDENTS=0 %THEN %START NOOLINE(1) PRSTRING( ' NO USER FUNS SAVED YET') NOOLINE(1) STACK(TRUE) %RETURN;%FINISH %CYCLE ARG1=1,1,UDENTS %UNLESS DIRVAL(ARG1)=M' ' %THENSTART; ! CHECK FOR FORGET INDEX=DIRVAL(ARG1); ! SB OF FN DEVICE=DISC ARG2=READLINE STKSYS(IN) EVAL(0,ARG2,EACHVAL) IN=UNSTKSYS %IF JUMPFLAG=1 %THENSTART;DEVICE=TTY;%RETURN;%FINISH ARG2=UNSTACK %FINISH %REPEAT DEVICE=TTY STACK(TRUE) %RETURN; ! END LOADSAVED ! ! SYSFUN(77):; ! FORGET ARG1 ARG2 ETC ARG3=UNSTACK %IF CACTFILE=0 %THENSTART ERROR(' NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN;%FINISH %IF ARG3&WM=WM %THEN ARG3=CONS(ARG3,NIL) %IF ARG3&LM#LM %THENSTART ERROR1('NON-WORD FOR FORGET - ',ARG3) ->FG2 %FINISH %WHILE ARG3#NIL %CYCLE ARG1=HD(ARG3) ARG3=TL(ARG3) %IF ARG1&WM#WM %THENSTART ERROR1(' NON-WORD FOR FORGET - ',ARG1) ->FG1;%FINISH %IF UDENTS#0 %THENSTART ! SEARCH ARG1 IN DIR %CYCLE ARG2=1,1,UDENTS %IF DIRNAM(ARG2)=WA(ARG1>>8) %THENSTART DIRVAL(ARG2)=M' ' DIRNAM(ARG2)='' NOOLINE(1);PRSTRING(WA(ARG1>>8).' FORGOTTEN') -> FG1 %FINISH ! SPACES IN DIR ONLY AT MOMENT %REPEAT %FINISH NOOLINE(1);PRSTRING(WA(ARG1>>8));PRSTRING(' NOT SAVED') FG1:%REPEAT FG2:NOOLINE(2) STACK(TRUE) %RETURN; ! END FORGET ! ! SYSFUN(78):; ! SAVENEW %IF CACTFILE=0 %THENSTART ERROR (' NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN;%FINISH %IF NEWFN=NIL %THENSTART NOOLINE(1);PRSTRING( ' NO USER FN SAVED OR EDITED YET');NOOLINE(1) STACK(TRUE);%RETURN;%FINISH %WHILE NEWFN#NIL %CYCLE DEVICE=DISC %WHILE UDENTS=118 %CYCLE; ! DIR FULL FILETIDY %IF UDENTS=118 %THENSTART; ! TIDY NO GOOD ERROR('USER DIRECTORY FULL',EMPTY,0,IN) %IF JUMPFLAG=1 %THENSTART; ! EXIT DEVICE=TTY %RETURN %FINISH %FINISHELSEEXIT; ! TIDY WAS GOOD %REPEAT ARG1=HD(NEWFN) INDEX=UNFS ARG2=FNVAL(ARG1>>8)&M16!LM %WHILE ARG2#NIL %CYCLE PRINTLINE(HD(ARG2)) ARG2=TL(ARG2) %REPEAT PRINTEL(END) LGPRNT STR(STERMIN) ! UPDATE DIR UPDIR(ARG1) NOOLINE(1) PRSTRING(WA(ARG1>>8));PRSTRING(' SAVED') NEWFN=TL(NEWFN) %REPEAT NOOLINE(2) DEVICE=TTY STACK(TRUE) %RETURN; ! END SAVENEW ! ! SYSFUN(79):; ! SHOWNEW %IF NEWFN=NIL %THENSTART NOOLINE(1) PRSTRING( 'NO NEW FUNS') NOOLINE(1) STACK(TRUE) %RETURN;%FINISH ARG2=NEWFN NOOLINE(1) %WHILE ARG2#NIL %CYCLE ARG1=HD(ARG2) PRINTLINE(HD(FNVAL(ARG1>>8)&M16!LM)) ARG2=TL(ARG2) %REPEAT NOOLINE(1) STACK(TRUE) %RETURN; ! END SHOWNEW ! ! SYSFUN(80):; ! SHOWSAVEDTITLES %IF CACTFILE=0 %THENSTART ERROR(' NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN;%FINISH NOOLINE(1) %IF UDENTS=0 %THENSTART PRSTRING(' NO USER FNS SAVED YET') NOOLINE(1);STACK(TRUE) %RETURN %FINISH %CYCLE ARG2=1,1,UDENTS %UNLESS DIRVAL(ARG2)=M' ' %THENSTART INDEX=DIRVAL(ARG2) DEVICE=DISC ARG3=READLINE DEVICE=TTY PRINTLINE(ARG3) %FINISH %REPEAT NOOLINE(1) STACK(TRUE) %RETURN; ! END SHOWSAVEDTITLES ! ! SYSFUN(81):; ! COMPRESS %IF CACTFILE=0 %THENRETURN ! MAY CALL HOUSEJEEPING DEVICE=DISC FILETIDY; ! ASSUME USER IDENTIFIED ! DEVICE=TTY STACK(TRUE) %RETURN; ! END COMPRESS ! ! SYSFUN(83):; ! OLDDEF ARG1=UNSTACK %IF ARG1&WM#WM %THENSTART ERROR(' NON-WORD FOR OLDDEF - ',ARG1,1,IN) %RETURN;%FINISH %IF OLDFN(ARG1>>8)=0 %THENSTART ERROR(' NO STANDBY DEF FOR FN - ',ARG1,1,IN) %RETURN;%FINISH ARG2=FNVAL(ARG1>>8) FNVAL(ARG1>>8)=OLDFN(ARG1>>8) OLDFN(ARG1>>8)=ARG2 PRSTRING( 'STANDBY DEFINITION OF ');PRSTRING(WA(ARG1>>8).' RESTORED') NOOLINE(1);STACK(ARG1) %RETURN; ! END OLDDEF ! ! ! SYSFUN(91):; ! ABORT ARG1=UNSTACK %IF ARG1&NM#NM %OR ARG1<0 %THENSTART ERROR('NON-POSITIVE ARG FOR ABORT - ',ARG1,1,IN) %RETURN %FINISH JUMPFLAG=1 JUMPOUT=ARG1>>8 STACK(FN) %RETURN; ! END ABORT ! ! SYSFUN(92):; ! QUIT JUMPFLAG=1 JUMPOUT=100 STACK(FN) %RETURN; ! END QUIT ! ! SYSFUN(93):; ! FNCALLS ARG1=ENVIR NOOLINE(1) %WHILE ARG1>1022 %CYCLE %IF BNAME(ARG1)=0 %THENSTART PRINTEL(BVALUE(ARG1)) NOOLINE(1) %FINISH ARG1=ARG1-1 %REPEAT PRINTEL(LOGONAME) NOOLINE(1) STACK(LOGONAME) %RETURN; ! END FNCALLS ! ! SYSFUN(94):; ! FNVALS ARG1=ENVIR NOOLINE(1) %WHILE ARG1>1022 %CYCLE ARG2=ARG1 %WHILE BNAME(ARG2)#0 %CYCLE ARG2=ARG2-1 %REPEAT; ! ARG2 POINTS TO CURRENT BOTTOM PRINTEL(BVALUE(ARG2)); ! FUNCTION NAME PRSTRING(':-') NOOLINE(1) ARG3=ARG2+1 %WHILE ARG3<=ARG1 %CYCLE SPACES(4) PRINTEL(BNAME(ARG3)) SPACE PRINTEL(BVALUE(ARG3)) NOOLINE(1) ARG3=ARG3+1 %REPEAT NOOLINE(1) ARG1=ARG2-1 %REPEAT PRINTEL(LOGONAME) NOOLINE(1) STACK(LOGONAME) %RETURN; ! END FNVALS ! ! SYSFUN(95):; ! TRACE ARG3=UNSTACK %IF ARG3&WM=WM %THEN ARG3=CONS(ARG3,NIL) %IF ARG3&LM#LM %THENSTART ERROR1('TRACE WHAT? ',ARG3) ->TR2 %FINISH %WHILE ARG3#NIL %CYCLE ARG1=HD(ARG3) ARG3=TL(ARG3) %IF ARG1&WM#WM %THENSTART ERROR1('TRACE WHAT? ',ARG1) ->TR1 %FINISH ARG2=FNVAL(ARG1>>8) %IF ARG2=0 %THENSTART ERROR1('UNDEFINED FN FOR TRACE - ',ARG1) ->TR1 %FINISH %IF ARG2&INTERP=INTERP %THENSTART ERROR1('CANNOT TRACE AN INTERP FN - ',ARG1) ->TR1 %FINISH FNVAL(ARG1>>8)=(ARG2&UNMASK)!TRACE1; ! INSERT TRACE FLAG TR1:%REPEAT TR2:STACK(TRUE) %RETURN; ! END TRACE ! SYSFUN(96):; ! UNTRACE ARG3=UNSTACK %IF ARG3&WM=WM %THEN ARG3=CONS(ARG3,NIL) %IF ARG3&LM#LM %THENSTART ERROR1('UNTRACE WHAT? ',ARG3) ->UNTR2 %FINISH %WHILE ARG3#NIL %CYCLE ARG1=HD(ARG3) ARG3=TL(ARG3) %IF ARG1&WM#WM %THENSTART ERROR1('UNTRACE WHAT? ',ARG1) ->UNTR1 %FINISH ARG2=FNVAL(ARG1>>8) %IF ARG2=0 %THENSTART ERROR1('UNDEFINED FN FOR UNTRACE - ',ARG1) ->UNTR1 %FINISH FNVAL(ARG1>>8)=ARG2&UNMASK; ! REMOVE TRACE FLAG. IF SYSFUN NO EFFECT UNTR1:%REPEAT UNTR2:STACK(FALSE) %RETURN; ! END UNTRACE ! ! SYSFUN(97):; ! RESET LOGOTIME=TIME100 STACK(LOGOTIME<<8!NM) %RETURN; ! END RESET ! SYSFUN(98):; ! TIME STACK((TIME100-LOGOTIME)<<8!NM) %RETURN; ! END TIME ! ! ! SYSFUN(100):; ! CONTINUE %IF SEVERITY=1 %THENSTART ERROR('CANNOT CONTINUE FROM LAST ERROR',EMPTY,1,IN) %RETURN %FINISH JUMPFLAG=1 JUMPOUT=-1 STACK(FN) %RETURN; ! END CONTINUE ! ! SYSFUN(101):; ! AND ARG2=UNSTACK ARG1=UNSTACK STACK(ARG2); ! DISCARD FIRST ARG %RETURN; ! END AND ! SYSFUN(102):; ! SENDBACK ARG1=UNSTACK; ! VALUE TO BE SENT ARG2=GETNEXT(IN); ! FN TO BE SENT TO OR NUMBER OF FNS TO BE EXITED %IF JUMPFLAG=1 %THENRETURN %IF ARG2&NM=NM %THENSTART %IF ARG2<0 %THENSTART ERROR('NEGATIVE SECOND ARG FOR SENDBACK - ',EMPTY,1,IN) %RETURN %FINISH SENDFLAG=ARG2>>8; ! NO OF RETURNS JUMPFLAG=1 STACK(ARG1) %RETURN %FINISH %IF ARG2&WM#WM %THENSTART ERROR('SENDBACK TO WHERE? ',ARG2,1,IN) %RETURN %FINISH W1=ENVIR; ! CURRENT ENVIR TOP ARG3=0 %WHILE W1>BASENVIR %CYCLE %WHILE BNAME(W1)#0 %CYCLE;W1=W1-1;%REPEAT W2=BVALUE(W1); ! FN ENTERED W1=W1-1; ! NEXT ENVIR TOP %IF W2=ARG2 %THENSTART; ! FOUND IT SENDFLAG=ARG3+1; ! NO OF RETURNS TO BE MADE TO GET THERE JUMPFLAG=1 STACK(ARG1) %RETURN %FINISHELSESTART; ! NOT THE RIGHT FN %IF W2#LOGONAME %THEN ARG3=ARG3+1; ! SO INC NO OF RETURNS, UNLESS LOGO %FINISH %REPEAT ! GETS HERE IF FN NOT FOUND AT CURRENT LEVEL ERROR('FN FOR SENDBACK NOT OUTSTANDING - ',%C ARG2,1,IN) %RETURN; ! END SENDBACK ! SYSFUN(103):; ! BREAK ARG1=IN NOOLINE(1) %IF ARG1=NIL %THEN PRINTEL(BREAK) %WHILE ARG1#NIL %CYCLE PRINTEL(HD(ARG1)) SPACE ARG1=TL(ARG1) %REPEAT ERROR('',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN; ! ABORT OR QUIT STACK(BREAK); ! RESULT FOR CONTINUE %RETURN; ! FROM CONTINUE. END BREAK ! ! SYSFUN(104):; ! MAKEASSOC ARG3=UNSTACK; ! VALUE ARG2=UNSTACK; ! ATTRIBUTE ARG1=UNSTACK; ! OBJECT %IF ARG1&WM#WM %THENSTART ERROR('INVALID FIRST ARG FOR MAKEASSOC - ',ARG1,1,IN) %RETURN %FINISH ARG1=ARG1>>8; ! WA INDEX STACK(ARG3) ARG3=CONS(ARG2,CONS(ARG3,NIL)); ! [ATT VAL] %IF FINDASS(ASSOCWA(ARG1),ARG2)=NIL %THENSTART; ! NO EXISTING ASSOC ASSOCWA(ARG1)=CONS(ARG3,ASSOCWA(ARG1)) ! INSERT [ATT VAL] AS FIRST ELEMENT IN ASSLIST FOR THIS OBJECT %FINISHELSESTART; ! ASSOC ALREADY EXISTS. W2 POINTS TO LIST ! WHOSE HEAD IS ASSOC REPHEAD(W2,ARG3) %FINISH %RETURN; ! END MAKEASSOC ! ! SYSFUN(105):; ! GETASSOC ARG2=UNSTACK; ! ATT ARG1=UNSTACK; ! OB %IF ARG1&WM#WM %THENSTART ERROR('INVALID FIRST ARG FOR GETASSOC - ',ARG1,1,IN) %RETURN %FINISH ARG3=FINDASS(ASSOCWA(ARG1>>8),ARG2) %IF ARG3#NIL %THEN ARG3=HD(TL(HD(ARG3))); ! VALUE STACK(ARG3) %RETURN; ! END GETASSOC ! ! SYSFUN(106):; ! REMASSOC ARG2=UNSTACK ARG1=UNSTACK %IF ARG1&WM#WM %THENSTART ERROR('INVALID FIRST ARG FOR REMASSOC - ',ARG1,1,IN) %RETURN %FINISH ARG1=ARG1>>8 ARG3=FINDASS(ASSOCWA(ARG1),ARG2) %IF ARG3#NIL %THENSTART; ! ASSOC EXISTS %IF W1=W2 %THEN ASSOCWA(ARG1)=TL(W2) %ELSE REPTAIL(W1,TL(W2)) %FINISH STACK(NIL) %RETURN; ! END REMASSOC ! SYSFUN(107):; ! CALLUSER ARG1=ENVIR NOOLINE(1) PRSTRING('CALLUSER CALLED FROM:-') %IF ARG1=BASENVIR %THENSTART PRINTEL(LOGONAME) NOOLINE(1) %FINISHELSESTART ARG2=ARG1 %WHILE BNAME(ARG2)#0 %THEN ARG2=ARG2-1 PRINTEL(BVALUE(ARG2)); ! FN NAME NOOLINE(1) %IF ARG2=ARG1 %THENSTART PRSTRING('NO LOCALS') NOOLINE(1) %FINISHELSESTART ARG2=ARG2+1 %WHILE ARG2<=ARG1 %CYCLE SPACES(2);PRINTEL(BNAME(ARG2)) PRSTRING(':-');PRINTEL(BVALUE(ARG2)) NOOLINE(1) ARG2=ARG2+1 %REPEAT %FINISH %FINISH RL107:ARG3=STKPNT; ! SAVV STACK PROMPT('RESULT:') BLEVEL=1 ARG1=READLIST(BLEVEL) STKSYS(IN) EVAL(0,ARG1,EACHVAL) IN=UNSTKSYS %IF JUMPFLAG=1 %THENSTART; ! SPECIAL FOR RETRY JUMPFLAG=0 JUMPOUT=0 STKPNT=ARG3 ->RL107 %FINISH PROMPT(PROMP) ! STACK(UNSTACK) %RETURN; ! END CALLUSER ! SYSFUN(108):; ! QUOTE STACK(QUOTE) %RETURN; ! END QUOTE ! SYSFUN(109):; ! DOTS STACK(DOTS) %RETURN; ! END DOTS ! SYSFUN(110):; ! IT STACK(VAL); %RETURN; ! END IT ! ! SYSFUN(111):; ! VALUE ARG1=UNSTACK %IF ARG1&WM#WM %THENSTART ERROR('VALUE OF WHAT? ',ARG1,1,IN) %RETURN %FINISH ARG2=GETVAL(ARG1,ENVIR) %IF ARG2=UNDEF %THENSTART ERROR('UNDEFINED DATA NAME - ',ARG1,1,IN) %RETURN %FINISH STACK(ARG2) %RETURN; ! END VALUE ! ! SYSFUN(112):; ! REPEAT ARG1=UNSTACK %IF ARG1&NM#NM %OR ARG1<0 %THENSTART ERROR('REPEAT NEEDS A NON-NEGATIVE NUMBER - ',ARG1,1,IN) %RETURN %FINISH %IF ARG1>>8=0 %THENSTART STACK(ARG1) %RETURN %FINISH %CYCLE ARG2=1,1,ARG1>>8 ARG3=IN; ! SAVE IN TO REUSE FOR REOEATS STKSYS(IN) EVAL(0,ARG3,EACHVAL) IN=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN ARG3=UNSTACK; ! LAST VALUE %REPEAT IN=NIL STACK(ARG3) %RETURN; ! END REPEAT ! ! SYSFUN(113):; ! GOODBYE CLOSESTREAM(1) CLEAR('ST01') CLOSESM(4);CLEAR('SM04');CLUSERFL CLOSESM(6);CLEAR('SM06') DESTROY('AI2LGSTK') %STOP ! ! SYSFUN(114):; ! ABBREV REDEF=0 ARG2=UNSTACK ARG1=UNSTACK %IF ARG1&WM#WM %OR ARG2&WM#WM %THENSTART ERROR('NON WORD ARG FOR ABBREV - ',CONS(ARG1,CONS(ARG2,NIL)),1,IN) %RETURN %FINISH %IF FNVAL(ARG1>>8)=0 %THENSTART ERROR('UNDEFINED FUNCTION FOR ABBREV - ',ARG1,1,IN) %RETURN %FINISH ! SO ARG1 OK ARG3=FNVAL(ARG2>>8); ! GET SPEC FOR ABBREVIATION %IF ARG3=0 %THEN -> TRANSPEC; ! UNDEFINED SO OK %IF ARG3&USERPRE=USERPRE %THENSTART REDEF=1 ->TRANSPEC %FINISH; ! ALREADY DEFINED BY USER ERROR('SYSTEM FN CANNOT BE AN ABBREVIATION - ',ARG2,1,IN) %RETURN TRANSPEC:FNVAL(ARG2>>8)=FNVAL(ARG1>>8) PRINTEL(ARG2) PRSTRING(' IS') %IF REDEF=1 %THEN PRSTRING(' REDEFINED') %ELSEC PRSTRING(' DEFINED') PRSTRING(' AS AN ABBREVIATION FOR ') PRINTEL(ARG1) NOOLINE(1) STACK(ARG1) %RETURN; ! END ABBREV ! ! SYSFUN(115):; ! DOLOGO ARG1=UNSTACK %IF ARG1&LM#LM %THENSTART ERROR('NON-LIST ARG FOR DOLOGO - ',ARG1,1,IN) %RETURN %FINISH STKSYS(IN) EVAL(0,ARG1,EACHVAL) IN=UNSTKSYS ! STACK(UNSTACK) %RETURN; ! END DOLOGO ! ! SYSFUN(116):; ! RANDOM ARG1=UNSTACK %IF ARG1&NM#NM %THENSTART ERROR('NON-NUMERIC ARG FOR RANDOM - ',ARG1,1,IN) %RETURN %FINISH %IF ARG1<0 %THENSTART ARG2=-1 ARG1=-(ARG1>>8!T8)+1; ! POSITIVE BINARY +1 %FINISHELSESTART ARG2=1 ARG1=ARG1>>8+1 %FINISH STACK((INTPT(RANDOM(RANSEED,1)*ARG1)*ARG2)<<8!NM) %RETURN; ! END RANDOM ! ! SYSFUN(117):; ! APPLY IN=CONS(UNSTACK,IN) EVAL(0,IN,EACHVAL) ! STACK(UNSTACK) %RETURN; ! END APPLY ! ! ! ! SYSFUN(118):; ! ALERT LIST('ECMI05.LOGALERT') STACK(TRUE) %RETURN; ! END ALERT ! ! SYSFUN(119):; ! SETELIM ARG1=UNSTACK %IF ARG1&NM#NM %OR ARG1<0 %THENSTART ERROR('SETELIM NEEDS A POSITIVE NUMBER - ',ARG1,1,IN) %RETURN %FINISH EVALIMIT=ARG1>>8 STACK(ARG1) %RETURN; ! END SETELIM ! SYSFUN(120):; ! DUMP DUMP('USER REQUEST') STACK(NIL); %RETURN ! ! ! SYSFUN(121):; ! CONVERT %IF CACTFILE=0 %THENSTART ERROR(' NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN %FINISH %IF UDENTS>0 %THENSTART %CYCLE ARG1=2,1,UNFS-1 %IF FNTEXT(ARG1)=';' %THEN FNTEXT(ARG1)=NL %REPEAT %FINISH STACK(TRUE) %RETURN; ! END CONVERT ! SYSFUN(122):; ! GETTY SELECTINPUT(0) CLOSESTREAM(3) CLEAR('ST03') DESTROY('LOGOTEMP') PRSTRING('TEMPORARY FILE DESTROYED');NOOLINE(1) PRSTRING('LOADED AND READY');NOOLINE(3) STACK(NIL) %RETURN; ! TEMP GETTY ! ! ! SYSFUN(123):; ! TRUE STACK(TRUE) %RETURN; ! END TRUE ! SYSFUN(124):; ! FALSE STACK(FALSE) %RETURN; ! END FALSE ! SYSFUN(125):; !SPACE STACK(SPACE1) %RETURN; ! END SPACE ! SYSFUN(126):; ! TAB STACK(TAB) %RETURN; ! END TAB ! SYSFUN(127):; ! NL STACK(ENEL) %RETURN; ! END NL ! SYSFUN(128):; ! EMPTY STACK(EMPTY) %RETURN; ! END EMPTY ! SYSFUN(130):; ! MFIRST ARG2=UNSTACK ARG1=UNSTACK %IF ARG1&LM#LM %OR ARG1=NIL %THENSTART ERROR('BAD FIRST ARG FOR MFIRST - ',CONS(ARG1,CONS(ARG2,NIL)),1,IN) %RETURN %FINISH %IF (ARG1>>8)>=LAFNB %THENSTART; ! LIST EMBEDDED IN FN DEFN ERROR('LIST EMBEDDED IN FN DEFN CANNOT BE UPDATED - ',ARG1,1,IN) %RETURN %FINISH REPHEAD(ARG1,ARG2) STACK(ARG2) %RETURN; ! END MFIRST ! SYSFUN(131):; ! MBUTFIRST ARG2=UNSTACK ARG1=UNSTACK %IF ARG1&LM#LM %OR ARG1=NIL %THENSTART ERROR('BAD FIRST ARG FOR MBUTFIRST - ',CONS(ARG1,CONS(ARG2,NIL)),1,IN) %RETURN %FINISH %IF (ARG1>>8)>=LAFNB %THENSTART ERROR('LIST EMBEDDED IN FN DEFN CANNOT BE UPDATED - ',ARG1,1,IN) %RETURN %FINISH %IF ARG2&LM#LM %THENSTART ERROR('BAD SECOND ARG FOR MBUTFIRST - ',%C CONS(ARG1,CONS(ARG2,NIL)),1,IN) %RETURN %FINISH REPTAIL(ARG1,ARG2) STACK(ARG2) %RETURN; ! END MBUTFIRST ! SYSFUN(132):; ! SETCFLG CLECTFLG=1 STACK(NIL) %RETURN; ! END SETCFLG ! ! ! SYSFUN(133):; ! HASHINFO ARG1=HASH1023//HASH1024 PRSTRING( ' AVERAGE NO OF ACCESSES OF WA= ');WRITE(ARG1,6) NOOLINE(1);PRSTRING( ' WHERE NO OF WORDS HASHED= ') WRITE(HASH1024,8);NOOLINE(1) PRSTRING( ' AND TOTAL NO OF ACCESSES OF WA= ') WRITE(HASH1023,8) NOOLINE(1) PRSTRING( ' DUMPING INFO TO FILE HASHINFO');NOOLINE(1) SELECT OUTPUT(1) %CYCLE ARG1=0,1,1022 %UNLESS WA(ARG1)='?' %THENSTART NOOLINE(1);PRSTRING( ' ORIG HASH VALUE=') WRITE(HASHINFO(ARG1),5) PRSTRING( ' ACHIEVED ENTRY KEY=');WRITE(ARG1,5) PRSTRING( ' WORD= ');PRSTRING(WA(ARG1)) %FINISH %REPEAT SELECT OUTPUT(0);PRSTRING( ' FILE HASH INFO WRITTEN');NOOLINE(1) STACK(TRUE) %RETURN; ! END OF HASHINFO ! ! SYSFUN(134):; ! FILEINFO %IF CACTFILE=0 %THENSTART ERROR(' NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN;%FINISH PRSTRING( ' NO OF ENTRIES IN USER DIRECTORY= ') WRITE(UDENTS,6) NOOLINE(1);PRSTRING( ' POINTER TO NXT FREE SP IN USER TEXT AREA =') WRITE(UNFS,6) NOOLINE(1) %IF UDENTS=0 %THEN STACK(TRUE) %ANDRETURN %CYCLE ARG1=1,1,UDENTS NOOLINE(2) %IF DIRNAM(ARG1)='' %THENSTART PRSTRING( ' FORGOTTEN FUNCTION');NOOLINE(1) %FINISH %C %ELSESTART PRSTRING( ' ENTRY NO = ');WRITE(ARG1,6);NOOLINE(1) PRSTRING( ' STARTING BYTE =');WRITE(DIRVAL(ARG1),6);NOOLINE(1) PRSTRING( ' TEXT =');NOOLINE(1) NOOLINE(1) INDEX=DIRVAL(ARG1) %CYCLE DEVICE=DISC ARG2=READLINE DEVICE=TTY PRINTLINE(ARG2) %IF HD(ARG2)=END %THENEXIT %REPEAT %FINISH %REPEAT STACK(TRUE);%RETURN; ! END FILEINFO ! SYSFUN(135):; ! SHOWFILES NOOLINE(1) %IF MDENTS=0 %THENSTART PRSTRING('NO FILES CREATED YET');NOOLINE(1) STACK(TRUE); %RETURN %FINISH PRSTRING(' LOGO MASTER DIRECTORY') NOOLINE(1) %CYCLE ARG1=1,1,MDENTS WRITE(ARG1,3);PRSTRING( ' USER ID = ');PRSTRING(USERNAM(ARG1)) NOOLINE(1) %REPEAT STACK(TRUE) %RETURN; ! END SHOWFILES ! ! SYSFUN(136):; ! LISTFILE %IF CACTFILE=0 %THENSTART ERROR(' NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN;%FINISH %IF UDENTS = 0 %THENSTART %PRINTTEXT 'FILE EMPTY' NEWLINE STACK(TRUE) %RETURN %FINISH DEFINE('ST10,.LP'); ! USUALLY .LP SELECT OUTPUT(10) NEWLINE;PRINTSTRING('****** FUNCTION DIRECTORY FOR ') %IF USERFILE->('AI2LG').WSTR1 %THENSTART ! NUMBER AS STRING IN WSTR1 WSTR2=USERNAM(PUT(WSTR1)>>8); ! PUT CONVERTS STRING NUMBER TO ! NUMBER IN INTERNAL FORM PRINTSTRING('USER ') PRINTSTRING('FILE '.WSTR2.' ******') NEWLINES(2) %FINISH %PRINTTEXT ' NO OF FUNCTIONS SAVED/FORGOTTEN = ';WRITE(UDENTS,8) ;NEWLINE %PRINTTEXT ' NO OF CHARACTERS IN TEXT AREA = ' WRITE(UNFS-1,8);NEWLINES(2) %PRINTTEXT ' ENTRY NO START BYTE FUNCTION NAME' %CYCLE ARG1=1,1,UDENTS NEWLINE;WRITE(ARG1,6) %IF DIRNAM(ARG1)='' %THENSTART SPACES(7); %PRINTTEXT ' FORGOTTEN FUNCTION ' -> REP136 %FINISH SPACES(6);WRITE(DIRVAL(ARG1),8) SPACES(10);PRINTSTRING(DIRNAM(ARG1)) REP136:%REPEAT NEWLINES(2) %PRINTTEXT '****** TEXT AREA ******' %CYCLE ARG1=1,1,UDENTS %UNLESS DIRNAM(ARG1)='' %THENSTART ARG2=DIRVAL(ARG1) NEWLINE LFF:PRINTSYMBOL(FNTEXT(ARG2)) %IF FNTEXT(ARG2)=TERMIN %THENSTART %IF FNTEXT(ARG2+1)='T' %OR ARG2+1>=UNFS %C %THEN -> 1 %FINISH ARG2=ARG2+1 -> LFF %FINISH 1:%REPEAT SELECT OUTPUT(0) CLOSE STREAM(10) CLEAR('ST10') STACK(TRUE) %RETURN; ! END LISTFILE ! ! ! ! ! SYSFUN(137):; ! LIBRARY ARG2=UNSTACK ARG1=UNSTACK %IF ARG1&WM#WM %THENSTART ERROR(' INVALID NAME FOR LIBRARY OWNER - ',ARG1,1,IN) %RETURN;%FINISH WSTR1=WA(ARG1>>8); ! GET CHARS %IF LENGTH(WSTR1)#6 %THENSTART ERROR('INVALID NAME FOR LIBRARY OWNER - ',ARG1,1,IN) %RETURN %FINISH %CYCLE W1=1,1,4 WSTR2=FROMSTRING(WSTR1,W1,W1) %IF WSTR2<='9' %THENSTART; ! NUMERIC CHAR ERROR('INVALID NAME FOR LIBRARY OWNER - ',ARG1,1,IN) %RETURN %FINISH %REPEAT %CYCLE W1=5,1,6 WSTR2=FROMSTRING(WSTR1,W1,W1) %IF WSTR2>'9' %THENSTART; ! NON NUMERIC CHAR ERROR('INVALID NAME FOR LIBRARY OWNER - ',ARG1,1,IN) %RETURN %FINISH %REPEAT %IF ARG2&WM#WM %THENSTART ERROR(' NON-WORD FOR LIBRARY NAME - ',ARG2,1,IN) %RETURN;%FINISH ! MAP ONTO LIB OWNER'S DIRECTORY SHAREFILE(WSTR1.'.'.MASDIR,0) %IF JUMPFLAG=1 %THENRETURN GOTHDIR; ! GET OWNERS DIR %IF CACTFILE>0 %THENSTART CLOSESM(5); ! CLOSE CURRENT FILE, IF ANY WSTR2=USERFILE; ! SAVE NAME %FINISH ARG3=1 ARG3=GETFILE(ARG2,ARG3) %IF JUMPFLAG=1 %THEN ->LIB1 %IF ARG3=-1 %THEN ERROR(' CANNOT FIND LIBRARY - ',ARG2,1,IN) %C %ELSE ->LIB2 LIB1:%IF CACTFILE>0 %THEN USERFILE=WSTR2 %AND GETDIR(1,5) %RETURN ! GET LIBRARY DIR LIB2:DEFINE('SM08,'.WSTR1.'.'.USERFILE) CACTFILE=CACTFILE+1 GETDIR(ARG3,8) LIBLOAD=1 %IF UDENTS#0 %THENSTART %CYCLE ARG1=1,1,UDENTS %UNLESS DIRVAL(ARG1)=M' ' %THENSTART INDEX=DIRVAL(ARG1) DEVICE=DISC ARG2=READLINE STKSYS(IN) EVAL(0,ARG2,EACHVAL) IN=UNSTKSYS %IF JUMPFLAG=1 %THENEXIT ARG2=UNSTACK %FINISH %REPEAT DEVICE=TTY %FINISH CLOSESM(8);CLEAR('SM08') DISCONNECT(WSTR1.'.'.USERFILE); ! DISCONNECT OWNERS LIB CACTFILE=CACTFILE-1 %IF CACTFILE>0 %THEN USERFILE=WSTR2 %AND GETDIR(1,5) LIBLOAD=0 %IF JUMPFLAG#1 %THEN STACK(TRUE) %RETURN; ! END LIBRARY ! ! SYSFUN(144):; ! SAY ARG1=UNSTACK %IF ARG1=ENEL %THEN NOOLINE(1) %ELSESTART ENUF=0;SEP='' %IF ARG1&LM=LM %THEN PRINTLCON(ARG1) %ELSE PRINTWN(ARG1) %FINISH NOOLINE(1) STACK(ARG1) %RETURN; ! END SAY ! ! SYSFUN(145):; ! FULLTRACE ARG3=UNSTACK %IF ARG3&WM=WM %THEN ARG3=CONS(ARG3,NIL) %IF ARG3&LM#LM %THENSTART ERROR1('FULLTRACE WHAT? ',ARG3) ->FTR2 %FINISH %WHILE ARG3#NIL %CYCLE ARG1=HD(ARG3) ARG3=TL(ARG3) %IF ARG1&WM#WM %THENSTART ERROR1('TRACE WHAT? ',ARG1) ->FTR1 %FINISH ARG2=FNVAL(ARG1>>8) %IF ARG2=0 %THENSTART ERROR1('UNDEFINED FN FOR TRACE - ',ARG1) ->FTR1 %FINISH %IF ARG2&INTERP=INTERP %THENSTART ERROR1('CANNOT TRACE AN INTERP FN - ',ARG1) ->FTR1 %FINISH FNVAL(ARG1>>8)=(ARG2&UNMASK)!TRACE2; !INSERT TRACE FLAG FTR1:%REPEAT FTR2:STACK(TRUE) %RETURN; ! END FULLTRACE ! ! SYSFUN(146):; !PACK ARG1=UNSTACK %IF ARG1&LM#LM %THENSTART ERROR('NON-LIST ARG FOR FN PACK - ',ARG1,1,IN) %RETURN %FINISH WSTR1='' %WHILE ARG1#NIL %CYCLE ARG2=HD(ARG1) %IF ARG2&NM=NM %THENSTART ARG3=ARG2>>8 %IF ARG3>=0 %AND ARG3<=9 %THENSTART WSTR2=NUMTOSTR(ARG2) ->PACKOK %FINISH %FINISHELSESTART %IF ARG2&WM=WM %THENSTART WSTR2=WA(ARG2>>8) %IF LENGTH(WSTR2)=1 %THEN ->PACKOK %FINISH %FINISH ERROR('CANNOT PACK MULTIPLE CHARS - ',ARG2,1,IN) %RETURN PACKOK:%IF LENGTH(WSTR1)=64 %THENSTART ERROR('WORD LENGTH EXCEEDED - ',ARG1,1,IN) %RETURN %FINISH WSTR1=WSTR1.WSTR2 ARG1=TL(ARG1) %REPEAT STACK(PUT(WSTR1)) %RETURN; !END PACK ! ! SYSFUN(147):; !UNPACK ARG1=UNSTACK %IF ARG1&LM=LM %THENSTART ERROR('LIST ARG FOR FN UNPACK - ',ARG1,1,IN) %RETURN %FINISH %IF ARG1&NM=NM %THEN WSTR1=NUMTOSTR(ARG1) %ELSE WSTR1=WA(ARG1>>8) ARG1=NIL ARG2=LENGTH(WSTR1) %WHILE ARG2#0 %CYCLE W1=PUT(FROMSTRING(WSTR1,ARG2,ARG2)) ARG1=CONS(W1,ARG1) ARG2=ARG2-1 %REPEAT STACK(ARG1) %RETURN; !END UNPACK ! ! SYSFUN(148):; !MAPLIST ARG2=UNSTACK ARG1=UNSTACK %IF ARG1&LM#LM %THENSTART ERROR('NON-LIST ARG FOR MAPLIST - ',ARG1,1,IN) %RETURN %FINISH ARG3=NIL %IF ARG2&WM=WM %THENSTART %WHILE ARG1#NIL %CYCLE W2=HD(ARG1) %IF W2&WM=WM %THEN W2=CONS(QUOTE,CONS(W2,NIL)) %C %ELSE W2=CONS(W2,NIL) W1=CONS(ARG2,W2) ARG1=TL(ARG1) STKSYS(IN);STKSYS(ARG1);STKSYS(ARG3) EVAL(0,W1,EACHVAL) ARG3=UNSTKSYS;ARG1=UNSTKSYS;IN=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN ARG3=CONS(UNSTACK,ARG3) %REPEAT %FINISHELSESTART %IF ARG2&LM#LM %THENSTART ERROR('INVALID 2ND ARG FOR MAPLIST - ',ARG2,1,IN) %RETURN %FINISH %WHILE ARG1#NIL %CYCLE W1=HD(ARG1) ARG1=TL(ARG1) STKSYS(IN);STKSYS(ARG1);STKSYS(ARG2);STKSYS(ARG3) EVAL(0,ARG2,W1) ARG3=UNSTKSYS;ARG2=UNSTKSYS;ARG1=UNSTKSYS;IN=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN ARG3=CONS(UNSTACK,ARG3) %REPEAT %FINISH %WHILE ARG3#NIL %CYCLE ARG1=CONS(HD(ARG3),ARG1) ARG3=TL(ARG3) %REPEAT STACK(ARG1) %RETURN; ! END MAPLIST ! ! SYSFUN(149):; ! APPLIST ARG2=UNSTACK ARG1=UNSTACK %IF ARG1&LM#LM %THENSTART ERROR('NON-LIST ARG FOR APPLIST - ',ARG1,1,IN) %RETURN %FINISH ARG3=NIL %IF ARG2&WM=WM %THENSTART %WHILE ARG1#NIL %CYCLE W1=HD(ARG1) %IF W1&WM=WM %THEN W1=CONS(QUOTE,CONS(W1,NIL)) %C %ELSE W1=CONS(W1,NIL) ARG3=CONS(ARG2,W1) ARG1=TL(ARG1) STKSYS(IN);STKSYS(ARG1) EVAL(0,ARG3,EACHVAL) ARG1=UNSTKSYS;IN=UNSTKSYS %IF JUMPFLAG =1 %THENRETURN ARG3=UNSTACK %REPEAT %FINISHELSESTART %IF ARG2&LM#LM %THENSTART ERROR('INVALID 2ND ARG FOR APPLIST - ',ARG2,1,IN) %RETURN %FINISH %WHILE ARG1#NIL %CYCLE W1=HD(ARG1) ARG1=TL(ARG1) STKSYS(IN);STKSYS(ARG1);STKSYS(ARG2) EVAL(0,ARG2,W1) ARG2=UNSTKSYS;ARG1=UNSTKSYS;IN=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN ARG3=UNSTACK %REPEAT %FINISH STACK(ARG3) %RETURN; ! END APPLIST ! ! SYSFUN(150):; ! EACH %IF EACHVAL=UNDEF %THEN ERROR('EACH USED OUT OF CONTEXT',EMPTY,1,IN) %C %ELSE STACK(EACHVAL) %RETURN; ! END EACH ! ! ! ! ! ! ! ! %END; ! END APPLYSYS ! %ROUTINE EVAL(%INTEGER PREC,%INTEGERNAME IN,EACHVAL) %INTEGER FN,FUNSPEC,TYPE,ARGNO,PARMLIST,NEXTPREC,FUNLIST %INTEGER WORK1,WORK2,TRACE %SWITCH SYSTR(0:2),USRTR(0:2),OUTR(0:2),INFTR(0:2),INFOUTR(0:2) %IF QUITFLAG=1 %THENSTART; ! USER INT Q QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %AND LIBLOAD=0 %THENSTART HOLDFLAG=0 %IF FUN#NIL %THENSTART ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN %FINISH %FINISH ! IF USER INTERRUPT HAS HAPPENED SERVICE IT %IF CLECTFLG=1 %THENSTART; ! GARBAGE COLLECT NEEDED STKSYS(IN);STKSYS(VAL); COLLECT(ENVIR) VAL=UNSTKSYS;IN=UNSTKSYS %FINISH EVALCNT=EVALCNT+1 %IF EVALCNT>=EVALIMIT %THENSTART ERROR('EVALIMIT EXCEEDED',EMPTY,1,IN) %RETURN %FINISH LP:%IF IN=NIL %THENSTART;STACK(VAL);%RETURN;%FINISH FN=HD(IN) IN=TL(IN) %IF FN=COMMA %THEN ->LP; ! SEPARATOR TOP:%IF FN&NM=NM %OR FN&LM=LM %THENSTART; ! NUMBER OR LIST STACK(FN) %FINISHELSESTART; ! START 1 %IF FN=QUOTE %THENSTART; ! DATA WORD FOLLOWS STACK(HD(IN)) IN=TL(IN) %FINISHELSESTART; ! START 2 %IF FN=DOTS %THENSTART; ! DATA NAME FOLLOWS %IF IN=NIL %THENSTART ERROR('NAME MISSING AFTER :',EMPTY,1,IN) %RETURN %FINISH FN=HD(IN) IN=TL(IN) %IF FN&WM=WM %THENSTART TOP1:WORK1=GETVAL(FN,ENVIR) %IF WORK1=UNDEF %THENSTART ERROR('UNDEFINED DATA NAME - ',FN,0,IN) %IF JUMPFLAG=1 %THENRETURN ->TOP1 %FINISHELSE STACK(WORK1) %FINISHELSESTART ERROR('NON-WORD AFTER : - ',FN,1,IN) %RETURN %FINISH %FINISHELSESTART; ! START 3 %IF FN=LPAR %THENSTART EVAL(4,IN,EACHVAL) %IF JUMPFLAG=1 %THENRETURN IN=CONS(LPAR,IN); ! PUT BACK LPAR FOR GETMATCH WORK1=NIL WORK1=GETMATCH(WORK1,IN); ! DISCARD UP TO MATCHING ) %IF WORK1#EMPTY %THENSTART ERROR('MISSING )',EMPTY,1,IN) %RETURN %FINISH %FINISHELSESTART; ! START 4 %IF FN=MINUS %THENSTART; ! UNARY MINUS. EVAL WITH TOP PREC EVAL(100,IN,EACHVAL) %IF JUMPFLAG=1 %THENRETURN STACK(NEGATE(UNSTACK)) %FINISHELSESTART; ! START 5 %IF FN=LANGBRKS %THENSTART; ! << WORK1=NIL %WHILE IN#NIL %AND HD(IN)#RANGBRKS %CYCLE STKSYS(WORK1); ! IN CASE OF A COLLECT EVAL(0,IN,EACHVAL) WORK1=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN WORK1=CONS(UNSTACK,WORK1) %REPEAT %IF IN=NIL %THENSTART ERROR('MISSING >>',EMPTY,1,IN) %RETURN %FINISH IN=TL(IN) STACK(REVERSE(WORK1)) %FINISHELSESTART; ! START 6 %IF FN=RPAR %OR FN=RANGBRKS %THENSTART ERROR('MISPLACED ',FN,1,IN) %RETURN %FINISH FUNSPEC=FNVAL(FN>>8); ! GET FUNCTION SPEC %IF FUNSPEC=0 %THENSTART; ! UNDEFINED ERROR('UNDEFINED FUNCTION - ',FN,0,IN) %IF JUMPFLAG=1 %THENRETURN ->TOP %FINISH TYPE=FUNSPEC&B4; ! GET FUNCTION TYPE %IF TYPE=SYSPRE %OR TYPE=USERPRE %THENSTART; ! PREFIX FUN ARGNO=FUNSPEC&B1B; ! GET NUMBER OF ARGS WORK1=ARGNO %WHILE WORK1>0 %CYCLE; ! GATHER ARGS AND LEAVE ON STACK %IF IN=NIL %THENSTART ERROR('NOT ENOUGH ARGS FOR ',FN,1,IN) %RETURN %FINISH EVAL(10,IN,EACHVAL) %IF JUMPFLAG=1 %THENRETURN WORK1=WORK1-1 %REPEAT TRACE=(FUNSPEC&TRACEFLG)>>30 %IF TYPE=SYSPRE %THENSTART ->SYSTR(TRACE) SYSTR(2):STRTRACE(FN) %IF ARGNO#0 %THENSTART SPACES(INDENT) %CYCLE WORK1=1,1,ARGNO PRINTSTRING('ARG'.TOSTRING(WORK1+48).' = ') PRINTEL(STK(STKPNT+WORK1-ARGNO)) PRINTSTRING(', ') %REPEAT NOOLINE(1) %FINISH ->SYSTR(0) SYSTR(1):STRTRACE(FN) SYSTR(0):APPLYSYS((FUNSPEC&B2)>>8,FN,IN,EACHVAL) %FINISHELSESTART FUNLIST=FUNSPEC&M16!LM; ! FUN NOW HAS USER DEF AS LIST PARMLIST=TL(TL(HD(FUNLIST))); ! PARAMETRS PARMLIST=REVQUOTE(PARMLIST); ! NOW IN REVERSE ORDER %IF JUMPFLAG=1 %THENRETURN ->USRTR(TRACE) USRTR(2):STRTRACE(FN) %IF ARGNO#0 %THENSTART SPACES(INDENT);WORK1=PARMLIST; WORK2=NIL %WHILE WORK1#NIL %CYCLE WORK2=CONS(HD(WORK1),WORK2) WORK1=TL(WORK1) %REPEAT %WHILE ARGNO#0 %CYCLE PRINTEL(HD(WORK2));PRINTSTRING(' = ') PRINTEL(STK(STKPNT+1-ARGNO));PRINTSTRING(', ') WORK2=TL(WORK2); ARGNO=ARGNO-1 %REPEAT NOOLINE(1) %FINISH ->USRTR(0) USRTR(1):STRTRACE(FN) USRTR(0):STKSYS(IN);STKSYS(VAL); APPLYUSR(MAKEBIND(PARMLIST,ENVIR,FN),FUNLIST,TSTFLG,VAL,SEVERITY) VAL=UNSTKSYS;IN=UNSTKSYS %FINISH ->OUTR(TRACE) OUTR(2):SPACES(INDENT);PRINTSTRING('RESULT = ') PRINTEL(STK(STKPNT));NOOLINE(1) OUTR(1):ENDTRACE(FN) OUTR(0):%IF JUMPFLAG=1 %THENRETURN %FINISHELSESTART; ! FINISH PREFIX. START 7 %IF TYPE=INTERP %THENSTART APPLYSYS((FUNSPEC&B2)>>8,FN,IN,EACHVAL) %IF JUMPFLAG=1 %THENRETURN %FINISHELSESTART; ! START 8 %IF TYPE=INFIX %THENSTART; ! MISPLACED INFIX ERROR('MISPLACED INFIX FN - ',FN,1,IN) %RETURN %FINISHELSESTART ERROR('ERROR IN FN TYPE FOR EVAL',EMPTY,1,IN) %RETURN %FINISH %FINISH; ! FINISH 8 %FINISH; ! FINISH 7 %FINISH; ! FINISH 6 %FINISH; ! FINISH 5 %FINISH; ! FINISH 4 %FINISH; ! FINISH 3 %FINISH; ! FINISH 2 %FINISH; ! FINISH 1 ! ! ! INFIX LOOP INLP:%IF IN=NIL %THENRETURN; ! LINE EMPTY FN=HD(IN) %IF FN&WM#WM %THENRETURN; ! NOT A WORD-IE NUMBER OR LIST FUNSPEC=FNVAL(FN>>8); ! GET FUNCTION DEF %IF FUNSPEC=0 %THENRETURN; ! NOT DEFINED AS A FUNCTION TYPE=FUNSPEC&B4; ! FUNCTION DEFINED-GET TYPE %IF TYPE#INFIX %THENRETURN; ! TYPE NOT INFIX NEXTPREC=FUNSPEC&B1B; ! INFIX FUN-GET PRECEDENCE %IF NEXTPREC<=PREC %THENRETURN; ! NEXT PRECECENCE LOWER THAN CURRENT IN=TL(IN) EVAL(NEXTPREC,IN,EACHVAL) %IF JUMPFLAG=1 %THENRETURN TRACE=(FUNSPEC&TRACEFLG)>>30 ->INFTR(TRACE) INFTR(2):STRTRACE(FN);SPACES(INDENT) PRINTSTRING('ARG1 = ');PRINTEL(STK(STKPNT-1)) PRINTSTRING(', ARG2 = ');PRINTEL(STK(STKPNT)) NOOLINE(1); ->INFTR(0) INFTR(1):STRTRACE(FN) INFTR(0):APPLYSYS((FUNSPEC&B2)>>8,FN,IN,EACHVAL) ->INFOUTR(TRACE) INFOUTR(2):SPACES(INDENT);PRINTSTRING('RESULT = ') PRINTEL(STK(STKPNT));NOOLINE(1) INFOUTR(1):ENDTRACE(FN) INFOUTR(0):%IF JUMPFLAG=1 %THENRETURN ->INLP %END; ! END EVAL ! EVAL(PREC,IN,UNDEF) %END; ! END EVALAPPL ! ! %ROUTINE APPLYUSR(%INTEGER ENVIR,FUN,TSTFLG,VAL,%INTEGERNAME SEVERITY) %INTEGER IN,CURFUN,SAVESTK SAVESTK=STKPNT CURFUN=FUN %WHILE TL(CURFUN)#NIL %CYCLE CURFUN=TL(CURFUN) IN=TL(HD(CURFUN)); ! NEXT LINE WITHOUT NUMBER EVALAPPL(0,ENVIR,FUN,CURFUN,IN,TSTFLG,VAL,SEVERITY) %IF JUMPFLAG=1 %THENSTART; ! RETURN FROM USERINT OR ERROR %IF SENDFLAG>1 %THENSTART SENDFLAG=SENDFLAG-1 %RETURN %FINISHELSESTART %IF SENDFLAG=1 %THENSTART SENDFLAG=0 JUMPFLAG=0 VAL=UNSTACK; ! VALUE SENT BACK STKPNT=SAVESTK; ! RESET STACK STACK(VAL) %RETURN %FINISH; ! SENDFLAG=1 %FINISH; ! SENDFLAG NOT >1 %RETURN; ! SENDFLAG=0 %FINISH; ! JUMPFLAG=1 VAL=UNSTACK %REPEAT STACK(VAL); ! RESULT OF USER FUN-VALUE FROM LAST LINE %END; ! END APPLYUSR ! ! ! ! ! ! %ROUTINE DUMP(%STRING(80) ERRMESS) %INTEGER I %INTEGER SYSVAL %BYTEINTEGERNAME TYPE,SWITCH,ARGNO TYPE==BYTEINTEGER(ADDR(SYSVAL)) SWITCH==BYTEINTEGER(ADDR(SYSVAL)+2) ARGNO==BYTEINTEGER(ADDR(SYSVAL)+3) ! %ROUTINE DUMPITEM(%INTEGER I) %IF I&WM=WM %THENSTART PRINTSTRING('W');WRITE(I>>8,5) %RETURN %FINISH %IF I&LM=LM %THENSTART PRINTSTRING('L');WRITE(I>>8,5) %RETURN %FINISH %IF I&NM=NM %THENSTART PRINTSTRING('N');SPACES(3) %IF I<0 %THEN WRITE(I>>8!T8,0) %ELSE WRITE(I>>8,0) %RETURN %FINISH PRINTSTRING('UNDEF') %END; ! END DUMPITEM NOOLINE(1) PRSTRING('DUMPING');NOOLINE(1) SELECTOUTPUT(1) NEWLINES(5) PRINTSTRING('********* DUMP STARTS **********'.DATE.' '.TIME) NEWLINE;PRINTSTRING('ERROR - '.ERRMESS);NEWLINE NEWLINE %PRINTTEXT'WORD AREA';NEWLINE %PRINTTEXT' INDEX WORD BASE VALUE ' %PRINTTEXT'FNTYPE FNSWITCH FNARGNO/PREC LIST INDEX'; NEWLINE %CYCLE I=0,1,1022 %IF WA(I)='?' %THEN ->REP %ELSESTART WRITE(I,5);SPACES(2) PRINTSTRING(WA(I));SPACES(9-LENGTH(WA(I)));DUMPITEM(BVALUE(I)) SYSVAL=FNVAL(I) WRITE(TYPE,10) %IF TYPE#8 %THENSTART WRITE(SWITCH,10) %IF TYPE#4 %THEN WRITE(ARGNO,14) %FINISHELSESTART SPACES(11) WRITE(ARGNO,14) SPACES(2) PRINTSTRING('L') WRITE(SYSVAL<<8>>16,4) %FINISH NEWLINE %FINISH REP:%REPEAT NEWLINE %PRINTTEXT'LIST AREA';NEWLINES(2) %PRINTTEXT'FUNCTION SPACE';NEWLINE %IF LPOINT1=LISTOP %THENSTART;%PRINTTEXT'NO NEW FNSPACE';NEWLINE ->SEMISP;%FINISH %CYCLE I=LISTOP,1,LPOINT1-1 WRITE(I,5);SPACES(2) DUMPITEM(LA(I)) NEWLINE %REPEAT NEWLINE LISTOP=LPOINT1 SEMISP:%PRINTTEXT'CURRENT SEMISPACE';NEWLINE %IF LPOINT=LABASE %THENSTART;%PRINTTEXT'NO LIST SPACE';NEWLINE ->ENV;%FINISH %CYCLE I=LABASE,1,LPOINT-1 WRITE(I,5);SPACES(2) DUMPITEM(LA(I)) NEWLINE %REPEAT NEWLINE ENV:%PRINTTEXT'LOCAL ENVIRS';NEWLINE %IF TOPMARK=1022 %THENSTART %PRINTTEXT'NO LOCALS' ;NEWLINE %FINISHELSESTART %CYCLE I=1023,1,TOPMARK WRITE(BNAME(I)>>8,5);SPACES(2) DUMPITEM(BVALUE(I)) NEWLINE %REPEAT %FINISH NEWLINE %PRINTTEXT'USER STACK' NEWLINE %IF STKPNT=0 %THENSTART %PRINTTEXT'STACK EMPTY' NEWLINE %FINISHELSESTART %CYCLE I=STKPNT,-1,1 WRITE(I,5) SPACES(2) PRINTEL(STK(I)) NEWLINE %REPEAT %FINISH SELECTOUTPUT(0) PRSTRING('DUMPED');NOOLINE(1) %END; ! END DUMP ! ! %ROUTINE INITIALISE %INTEGER I %STRING(64) IN %ROUTINE GETFUNS %STRING(64) NAME %INTEGER SYSVAL %BYTEINTEGERNAME TYPE,SWITCH,ARGNO TYPE==BYTEINTEGER(ADDR(SYSVAL)) SWITCH==BYTEINTEGER(ADDR(SYSVAL)+2) ARGNO==BYTEINTEGER(ADDR(SYSVAL)+3) LP:READSTRING(NAME) %IF NAME='END' %THENRETURN SYSVAL=0 READ(TYPE) READ(SWITCH) %IF TYPE#4 %THEN READ(ARGNO) FNVAL(HASH(NAME)>>8)=SYSVAL ->LP %END; ! END GETFUNS ! ! EUNAD=COMREG(16); ! ADDRESS OF USER NAME START EUNBYTE(1)=6 %CYCLE I=2,1,7 EUNBYTE(I)=BYTEINTEGER(EUNAD+I-2) %REPEAT EMASUSER==STRING(ADDR(EUNBYTE(1))); ! USER NAME AS STRING MASDIR='LOGODIR' MASREAD=MASDIR.','.EMASUSER.',8' MASWRITE=MASDIR.','.EMASUSER.',F' PERMITFILE(MASREAD); ! THIS MAY BE UNNECESSARY,BUT MUST ! REMAIN IN CASE A PROCESS IN WHICH LOGODIR WAS CREATED WITH SELF F ! PERMISSION HAS NOT USED THIS UPDATED VERSION(25/10/74) YET %CYCLE I=0,1,1022 BVALUE(I)=0 FNVAL(I)=0 OLDFN(I)=0 WA(I)='?' %REPEAT SPACE4=' ' QUOTEON=0 HASHVAL==INTSTR(2) WORK1==STRING(ADDR(INTSTR(2))-1) LBRAK==SPECHAR(13) RBRAK==SPECHAR(14) DEVICE=TTY CACTFILE=0 CHAROUT=0 HASH1023=0 HASH1024=0 INDENT=1 PRNUM=0 STKPNT=0 STKTOP=0 SYSTKPNT=0 JUMPFLAG=0 JUMPOUT=0 SENDFLAG=0 QUITFLAG=0 HOLDFLAG=0 LPOINT=LA1B LABASE=LA1B LPOINT1=LAFNB LISTOP=LAFNB SEMISIZE=LA2B-LA1B CLECTFLG=0 TOPMARK=1022 BASENVIR=1022 NUMTOP=2**23-1 NUMBOT=-2**23 EVALIMIT=1000000 LIBLOAD=0 NIL==NAMES(29) UNDEF==NAMES(30) DOTS==NAMES(16) EMPTY==NAMES(2) COMMA==NAMES(23) QUOTE==NAMES(14) LPAR==NAMES(19) RPAR==NAMES(20) MINUS==NAMES(24) THEN==NAMES(31) ELSE==NAMES(32) TRUE==NAMES(9) FALSE==NAMES(11) END==NAMES(33) DELETE==NAMES(34) UNDO==NAMES(35) UNDOS==NAMES(36) TO==NAMES(37) DO==NAMES(38) ERR==NAMES(39) LOGONAME==NAMES(40) LANGBRKS==NAMES(41) RANGBRKS==NAMES(42) QUIT==NAMES(43) BREAK==NAMES(44) IF==NAMES(45) CLOSE==NAMES(46) WHILE==NAMES(47) SPACE1==NAMES(4) TAB==NAMES(8) ENEL==NAMES(6) SELECTINPUT(2) READ(CFRACT) I=1 LP:READSTRING(IN) %IF IN#'ENDUP' %THENSTART NAMES(I)=HASH(IN) I=I+1 ->LP %FINISHELSESTART NIL=NIL>>8<<8!LM; ! CHANGE MARKER ON NIL FROM WM TO LM %CYCLE I=0,1,1022 ASSOCWA(I)=NIL %REPEAT GETFUNS %CYCLE I=1,2,15 SETVAL(NAMES(I),NAMES(I+1),BASENVIR); ! INITVALS %REPEAT NEWFN=NIL LOGOTIME=TIME100 SELECTINPUT(0) CLOSESTREAM(2);CLEAR('ST02') GETMASTER %RETURN %FINISH %END; ! END INITIALISE ! ! %ROUTINE LOGO(%INTEGER STKTOP,ENVIR,SEVERITY) %INTEGER VAL,IN,FUN,CURFUN,TSTFLG VAL=UNDEF IN=NIL FUN=NIL CURFUN=NIL TSTFLG=0 PRNUM=PRNUM+1 PROMP=NUMTOSTR(PRNUM<<8).':' PROMPT(PROMP) LP:IN=READLINE EVALCNT=0 EVALAPPL(0,ENVIR,FUN,CURFUN,IN,TSTFLG,VAL,SEVERITY) %IF SENDFLAG>0 %THENSTART; ! GO BACK TO APPLYUSR %IF PRNUM>1 %THENSTART; ! NOT AT BASE LEVEL PRNUM=PRNUM-1 PROMP=NUMTOSTR(PRNUM<<8).':' PROMPT(PROMP) %RETURN %FINISHELSESTART; ! AT BASE LEVEL SENDFLAG=0;JUMPFLAG=0 %FINISH %FINISH VAL=UNSTACK %IF JUMPFLAG=1 %THENSTART; ! ERROR RETURN OR USER HAS DONE ! CONTINUE, ABORT OR QUIT STKPNT=STKTOP; ! RESET STACK - DISCARD EXCESS LEFT BY ERROR EXIT %IF PRNUM#1 %THENSTART; ! NOT AT BASE LEVEL %IF JUMPOUT=-1 %THENSTART; ! USER CONTINUE JUMPOUT=0 JUMPFLAG=0 PRNUM=PRNUM-1 PROMP=NUMTOSTR(PRNUM<<8).':' PROMPT(PROMP) %RETURN %FINISH %IF JUMPOUT>0 %THENSTART; ! USER ABORT OR QUIT JUMPOUT=JUMPOUT-1 STACK(VAL) PRNUM=PRNUM-1 PROMP=NUMTOSTR(PRNUM<<8).':' PROMPT(PROMP) %RETURN %FINISH %FINISH; ! FINISH PRNUM#1 JUMPFLAG=0; ! EITHER PRNUM=1 OR PRNUM#1 AND JUMPOUT=0 JUMPOUT=0 %FINISH; ! FINISH JUMPFLAG=1 ->LP %END; ! END LOGO ! ! ! ! ! ! ! THE FOLLOWING DECLARATIONS ARE CONCERNED WITH TRAPPING TIME EXCEEDED ! AND RESETTING THE LOCAL TIME LIMIT, AND DEALING WITH CONSOLE INTS %SYSTEMROUTINESPEC SIGNAL(%INTEGER EP,PARM,EXTRA,%INTEGERNAME FLAG) %SYSTEMROUTINESPEC SVC(%RECORDNAME P) %SYSTEMROUTINESPEC MOVE(%INTEGER LENGTH,FROM,TO) %RECORDFORMAT PARM(%SHORTINTEGER DEST,DUM1,%INTEGER DUM2,%C DUM3,SECS) %RECORDNAME P(PARM) %STRINGNAME INTCHAR %OWNINTEGERARRAY SAVE(1:26) %OWNINTEGERARRAY RR(4:15) %OWNINTEGER I,K,FLAG,WT,ADUMP,TIMETOT,R3 %OWNLONGREAL DUM1; ! FOR ALIGNMENT %OWNSHORTINTEGER DEST,DUM2 %OWNINTEGER DUM3,DUM4,SECS %FAULT 17 ->REINIT REINIT:%BEGIN P==RECORD(ADDR(DEST)); !RECORD FOR SVC PARMS I=ADDR(RR(4)); ! ADDR OF RECOVERY INFO SAVE AREA K=ADDR(SAVE(1)); ! ADDR OF USER DUMP SAVE AREA *L_1,I *STM_ 4,14,0(1); ! SAVE ENVIR IN RECOVERY AREA *LA_2,; ! ADDR OF ENTRY POINT ON CONTINGENCY *ST_2,44(1); ! INTO RECOVERY AREA *MVI_44(1),8; ! SET PROGRAM MASK FOR INTEGER OFLOW SIGNAL(0,I,0,FLAG); ! STACK RECOVERY INFO P_DEST=215 P_SECS=60 SVC(P); ! SET LOCAL TIME LIMIT TO 60 SECS *LA_11,2048(11); ! INC STACK POINTER TO LEAVE HOLE TO BE ! USED ON CONTINGENCY ! ! MAIN PROG STARTS ! NEWSMFILE('AI2LGSTK,376831') DEFINE('SM06,AI2LGSTK') FSTART=SMADDR(6,FLENGTH) FNVAL==ARRAY(FSTART,INTFORM1) OLDFN==ARRAY(FSTART+4092,INTFORM1) SYSTK==ARRAY(FSTART+8184,INTFORM2) LA==ARRAY(FSTART+16184,INTFORM3) BNAME==ARRAY(FSTART+278328,INTFORM4) BVALUE==ARRAY(FSTART+286240,INTFORM5) ASSOCWA==ARRAY(FSTART+298244,INTFORM1) STK==ARRAY(FSTART+302336,INTFORM2) WA==ARRAY(FSTART+310336,SFORM1) DEFINE('ST02,ECMI05.OLDNAMES') INITIALISE %IF RESTART=0 %THENSTART; ! NOT A RESTART DEFINE('ST01,DUMPFILE') NEWLINES(2) PRINTSTRING('LOGO - VERSION 2.7 (8/12/75) '.TIME) PRINTSTRING(' OLD FILING SYSTEM') NEWLINES(2) %FINISHELSESTART; ! RESTART PRINTSTRING('REINITIALISING AND RELOADING SAVED FUNCTIONS') NEWLINE SELECTINPUT(3) %FINISH LOGO(STKTOP,BASENVIR,0) ! ! RECOVERY ENTRY ERROR: *ST_1,ADUMP; ! USER DUMP ADDRESS *ST_2,WT; ! WEIGHT OF INTERRUPT *ST_3,R3 MOVE(104,ADUMP,K); !SAVE USER DUMP AREA IN CASE OF ANOTHER INT %IF WT=128 %THENSTART; ! CONSOLE INT INTCHAR==STRING(ADDR(R3)) %IF INTCHAR='Q' %THENSTART QUITFLAG=1 ->RESUME %FINISH %IF INTCHAR='H' %THENSTART HOLDFLAG=1 ->RESUME %FINISH SIGNAL(4,I,0,FLAG); ! PASS TO OUTER LEVEL %FINISH %IF WT=132 %THENSTART; ! TIME EXCEEDED P==RECORD(ADDR(DEST)) P_DEST=215 P_SECS=60 SVC(P) TIMETOT=TIMETOT+1;NEWLINE; WRITE(TIMETOT,2) %IF TIMETOT=1 %THEN PRINTSTRING(' MINUTE') %ELSEC PRINTSTRING(' MINUTES') PRINTSTRING(' USED');NOOLINE(2) %FINISHELSE SIGNAL(4,I,0,FLAG) RESUME:I=ADDR(RR(4)) *L_1,I *STM_4,14,0(1) *LA_2, *ST_2,44(1) *MVI_44(1),8 SIGNAL(0,I,0,FLAG); ! RESTACK RECOVERY INFO SIGNAL(5,K,0,FLAG); ! GO BACK TO USER ENVIR %END %ENDOFPROGRAM