%BEGIN ! ! !********************************************************************* ! ! MORE COMMENTS AND SWITCH SYSFUN(232) - SYSFUN(280) TIDIED UP ! !********************************************************************* ! ! CHANNEL USAGE ! ST01 - DUMPFILE ! ST02 - LOGNAM ! ST03 - LOGOTEMP ! SM04 - LOGOFILE ! SM06 - LOGOSTK ! SM07 - LOGOMON ! SM08 - BFILE ! SM10 - JUNK FILE ! !***************************************** ! GRAPHICS LINKAGE !***************************************** ! %EXTERNALINTEGERFNSPEC CONV (%INTEGER X) %EXTERNALROUTINESPEC VECORPOINT (%INTEGER I,J,K,L) %EXTERNALROUTINESPEC PAUSE %EXTERNALROUTINESPEC LOAD42 (%STRING(63) FILE) %EXTERNALROUTINESPEC SET42 (%INTEGER NM) %EXTERNALROUTINESPEC CLEAR 42 %EXTERNALROUTINESPEC CH3 (%INTEGER CHAR) %EXTERNALROUTINESPEC MODE42 (%INTEGER N) %EXTERNALROUTINESPEC LBR %EXTERNALROUTINESPEC RBR ;! PARENTHESIS %CONSTINTEGER INIT GRAPHP = X'202E' ;! START OF DISPLAY SPACE ! %EXTRINSICINTEGER GRAPHP42 %EXTRINSICINTEGER CUR42 MODE %EXTRINSICINTEGER DDATA,DSTART,DLAST,GRAPHP ;!POINTERS TO GT42 CORE %EXTRINSICINTEGER VECTORM,POINTM,CHARM ;!EMAS GT42 EXEC INSTRUCTIONS %EXTRINSICINTEGER BLEEP,CHTXT,CHPIC,GRADV,ADD2,SET,ADD1, %C SETN,WAIT,PMOV,CLR,ACK ;!GT42 EXEC INSTRUCTIONS ! %OWNINTEGER PEN = X'4000', NORMAL= X'9E54',DJUMP=X'E000',FRAMETIME=50 %CONSTINTEGER CORE BOTTOM = X'3FF0' %CONSTINTEGER CALL=0, POSNAT=X'C000',LINETO=X'8000' %INTEGER TEXTFLAG,GMODE,CURPIC,CURMOVIE,CURFRAME,DEF PICTURE, %C CURMODE,FRAMEFLAG,GRABLIST,PICTURE POINTER %CONSTINTEGER TURTLE START=X'201A' %CONSTSTRING (17) GT42 EXEC = 'ECMI05.EXEC26' %OWN %INTEGER SHOW TURTLE 42 = 1 ! ! MOVIE AREA ! %RECORDFORMAT PICDIR(%INTEGER PTR,PTR42,X,Y,FADDR,MOVED %C ,MODE,LAST MOVE TIME) %OWNRECORDARRAY INDEX42( 0:1022) (PIC DIR) %STRING(10) SAVE PROMP %OWNINTEGER CAPFLAG = 0 ;! USED TO GENERATE CAPTIONS ! ! ! %INTEGER XCRANE, YCRANE, HDCRANE %CONSTINTEGER CRANE MARK = X'000F0000', CRANE MASK = X'FFFF0000' !*************************************************** %EXTERNALROUTINESPEC DRESUME(%INTEGER LNB,PC,ADDR18) %SYSTEMROUTINESPEC REROUTECONTINGENCY(%INTEGER EP,CLASS, %C %LONGINTEGER MASK,%ROUTINENAME RR,%INTEGERNAME FLAG) %EXTERNALINTEGERFNSPEC READID(%INTEGER ADR) %EXTERNALROUTINESPEC EDINNER(%INTEGER ST,SL,SC1,SC2,AWSP,%INTEGERNAME L) %EXTERNALROUTINESPEC DISCONNECT(%STRING(63) S) %EXTERNALROUTINESPEC CLOSESM(%INTEGER CH) %EXTERNALSTRINGFNSPEC UINFS(%INTEGER TYPE) %SYSTEMROUTINESPEC FINFO(%STRING(15) S,%INTEGER LEV,%C %RECORDNAME R, %INTEGERNAME FLAG) %SYSTEMROUTINESPEC FILL(%INTEGER LEN,ADDR,VAL) %SYSTEMROUTINESPEC MOVE(%INTEGER LENGTH,FROM,TO) %EXTERNALSTRINGFNSPEC DATE %EXTERNALROUTINESPEC LIST(%STRING(63) S) %EXTERNALSTRINGFNSPEC TIME %EXTERNALLONGREALFNSPEC CPUTIME %EXTERNALINTEGERFNSPEC SMADDR(%INTEGER CHANN,%INTEGERNAME LENGTH) %EXTERNALROUTINESPEC DEFINE(%STRING (65) S) %EXTERNALROUTINESPEC PERMIT(%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) %EXTERNALSTRINGFNSPEC INTERRUPT %EXTERNALROUTINESPEC RENAME(%STRING (65) S) %EXTERNALROUTINESPEC CLEAR(%STRING(65) S) %SYSTEMROUTINESPEC CONNECT(%STRING(31) FILE,%INTEGER MODE,HOLE,PROT, %C %RECORDNAME R,%INTEGERNAME FLAG) %RECORDFORMAT RF(%INTEGER CONAD,TYPE,START,END) %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 %INTEGERFNSPEC CHECKSTACK %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) %ROUTINESPEC GETPAGE(%INTEGER FLAG) !??; %ROUTINESPEC PRINTDIAG(%INTEGER I) %INTEGER FLENGTH,FSTART; ! FOR FILE MAPPING %STRING(6) EMASUSER; ! AS A STRING %CONSTINTEGER MAXSOURCE = 50000 ! ! ! ! THE FOLLOWING DECLARATIONS ARE CONCERNED WITH TRAPPING TIME EXCEEDED ! AND RESETTING THE LOCAL TIME LIMIT, AND DEALING WITH CONSOLE INTS ! %EXTERNALROUTINESPEC GETTIM(%INTEGERNAME I) %SYSTEMROUTINESPEC SIGNAL(%INTEGER EP,PARM,EXTRA,%INTEGERNAME FLAG) !@#$ %SYSTEMROUTINESPEC SVC(%RECORDNAME P) !@#$ %RECORDFORMAT PARM(%SHORTINTEGER DEST,DUM1,%INTEGER DUM2,%C !@#$ DUM3,ARG1,ARG2,ARG3,ARG4) !@#$ %RECORD P(PARM) !%STRINGNAME INTCHAR !%OWNINTEGERARRAY SAVE(1:26) !%OWNINTEGERARRAY RR(4:15) %OWNINTEGER I,K,FLAG,ADUMP,R3 ! ! ! ! WORD AREA AND NUMBER DECLARATIONS ! %BYTEINTEGERARRAY INBUFF(0:500) %INTEGER INPTR,HEADIN,UNUSEDHD %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 MAXINT=X'7FFFFFFF'; ! MAXIMUM INTEGER ALLOWED BY IMP %OWNINTEGER RANSEED=50003 %STRING(64) %NAME WORK1 %INTEGER LOGOTIME %INTEGERARRAY INTSTR(1:20) %STRING(4) SPACE4 %INTEGERNAME HASHVAL,LBRAK,RBRAK,DOTS,EMPTY,UNDEF,AND,REPEAT,APPLY,DO,%C COMMA,QUOTE,LPAR,RPAR,MINUS,IF,THEN,ELSE,CLOSE,WHILE,UNMINUS,%C IFT,IFF,TRUE,FALSE,END,DELETE,UNDO,UNDOS,TO,ERR,LOGONAME,DEF,%C LANGBRKS,RANGBRKS,QUIT,BREAK,SPACE1,TAB,ENEL,START,FINISH,COMMENT %INTEGERARRAY NAMES(1:100); ! CONTAINS HASHED VALUES OF ! SPECHARS AND RESERVED NAMES %OWNINTEGERARRAY SPECHAR(1:14)=':','<','>','''','(',')','*', '+',',','-','/','=','[',']' %INTEGER PRNUM %STRING(4) PROMP %INTEGER EVALIMIT,EVALCNT,PARSELIMIT,PARSECNT ! ! 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 ARGNO SWITCH......... ! 2) SYSTEM INFIX TRACEFLAG/2 PREC. SWITCH........ ! 3) SYSTEM INTERP 4 - SWITCH - ! 4) USER PREFIX TRACEFLAG/8 LA(INDEX) ARGNO ! 5) UNDEFINED 0 0 0 0 ! ! FNTEXT HOLDS POINTERS TO START OF TEXT OF FN ! FNLEN HOLDS THE LENGTH OF THE FN TEXT (IN BYTES) ! ! ! FUNCTION SPEC AREA DECLARATIONS ! %BYTEINTEGERARRAYFORMAT PARSEFORM(0:1022) %BYTEINTEGERARRAYNAME FNPARSE %INTEGERARRAYNAME FNVAL,OLDFN,ASSOCWA,FNTEXT,FNLEN %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 B3B=X'7F0000',B2=X'FFFF',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. %BYTEINTEGERARRAYNAME SOURCE %BYTEINTEGERARRAYFORMAT SOURCEFORM(0:50000) %INTEGER LINENUMLIST %INTEGER LEVEL,FNDEFN,SOURCEPTR,PARLEVEL,CONDFLAG,DIAGFLAG,PLEVEL,GOFLAG %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 ! ! ! ! INFERENCE SYSTEM DECLARATIONS ! %INTEGERNAME FACTKEYS, INFKEYS, IMPKEYS, FACT, IMPLIES, TOINFER %INTEGERNAME DATABASE,IMPRULES,INFRULES !DATABASE,IMPRULES AND INFRULES ARE LOGO WORDS WHOSE ! BVALUES HOLD A LIST OF THE ASSERTED FACTS, IMPLIED RULES ! AND INFERRED RULES RESPECTIVELY. ! ALL INFERENCE RULES ARE ALSO HELD IN ASSOCIATIONS. ! FACTKEYS,IMPKEYS AND INFKEYS ARE LOGO WORDS WHOSE ! BVALUES HOLD LISTS OF THE NAMES OF ASSOCIATION ! SETS FOR FACTS, IMPLIED RULES AND INFERRED RULES RESPECTIVELY ! FACT, IMPLIES AND TOINFER ARE ATTRIBUTES WITHIN EACH ! ASSOCIATION SET %INTEGERNAME THINKALOUD, NEW, VBL, NOT ! THINKALOUD IS A LOGO VARIABLE SET TO TRUE OR FALSE BY THE USER %INTEGER GENOS %INTEGERARRAY DBASE, IMPLINKS, INFLINKS(1:3) ! THE FIRST ELEMENT OF DBASE, IMPLINKS AND INFLINKS HOLDS ! THE LOGO WORD DATABASE, IMPRULES AND INFRULES RESPCTIVELY. ! THE 2ND ELEMENT CONTAINS THE LOGO WORD FACT, IMPLIES ! AND TOINFER RESPECTIVELY. ! THE 3RD ELEMENT HOLDS THE LOGO WORD FACTKEYS,IMPKEYS AND ! INFKEYS RESPECTIVELY. ! ! ! ! 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,SUPERJMP %INTEGER QUITFLAG,HOLDFLAG; ! USER INT FLAGS ! %INTEGERNAME QUITOTOP ! LOGO VARIABLE, SET TO TRUE OR FALSE BY THE USER ! DETERMINES WHETHER OR NOT TO ENTER THE PRIMEVAL FUNCTION RECUSIVELY, ! AFTER THE OCCURENCE OF AN ERROR ! DEFAULT IS TRUE - RETURN TO TOP LEVEL ! ! ! ! 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. ! ! ! ! FILING SYSTEM VARIABLES ! %OWNINTEGER TTY=0,DISC=1,SRCE=2 %INTEGER DEVICE,INDEX,NEWFN,CACTFILE,FLEN,FILSTART,TSTART,SINDEX %INTEGER MDP,MDIND,UDP,TXTP %STRING(64) USERFILE %STRING(20) MASWRITE,MASREAD,MASFILE %CONSTSTRING(7) MASNUM='ECMI05.' %OWNSTRING(8)%ARRAY SYSFILES(1:2)='LOGALERT','EXEC26' %STRING(6) OWNER %BYTEINTEGERNAME MDENTS,TMDENTS,UDENTS,TUDENTS %BYTEINTEGERNAME MDNEXT,TMDNEXT,UDNEXT,TUDNEXT %BYTEINTEGERNAME TXTNEXT,TTXTNEXT,ENDTXT,TENDTXT %BYTEINTEGERARRAYNAME TXTENTS,TTXTENTS,ENDIND,TENDIND %STRINGARRAYNAME UDNAM,TUDNAM,FUNNAM,TFUNNAM %BYTEINTEGERARRAYNAME TXTIND,TTXTIND %BYTEINTEGERARRAYNAME FNTXT,TFNTXT,UDPAGE,TUDPAGE,TXTPAGE,TTXTPAGE %STRING(64) %ARRAYFORMAT DF(1:62) %STRING(64) %ARRAYFORMAT FF(1:60) %BYTEINTEGERARRAYFORMAT XF(1:60) %BYTEINTEGERARRAYFORMAT PF(1:62) %BYTEINTEGERARRAYFORMAT SF(1:2) %BYTEINTEGERARRAYFORMAT NF(1:2,1:60) %BYTEINTEGERARRAYFORMAT TF(0:4092) ! ! ! ! SPECIAL OUTPUT DEVICE VARS ! %INTEGER TDEV; ! DEVICE NUMBER ALLOCATED ELSE 0 %OWNSTRING(10)%ARRAY TDEVNAMES(1:8)='PLOTTERA','PLOTTERB','DISPLAY',%C 'TURTLE','TAPE','MUSIC','MECCANO','GT42' %REAL XTURTLE,YTURTLE %INTEGER HDTURTLE,PENTURTLE; ! TURTLE STATE %OWNINTEGER HOOTBIT=X'8080',PENBIT=X'4000',FDBITS=X'2800',%C BDBITS=X'1800',RTBITS=X'3800',LTBITS=X'800',PINDLBIT=X'1000',%C PINDRBIT=X'4000' %INTEGERNAME UP,DOWN; ! UP DOWN AS LOGO WORDS TO SET PENTURTLE %BYTEINTEGERARRAY BINBUFF(0:13); ! BUFFER FOR BINARY OUTPUT %INTEGER ADDRBINBUFF; ! ADDRESS PF BINBUFF(1) ! ! PARSE DECLARATIONS ! %CONSTINTEGER QU=X'10', %C DTS=X'20', %C FNM=X'40', %C LP=X'80', %C MARKERMASK=X'FFFFFF0F', %C INTR=-1, %C FAULT=-2 ! ! ! CODE INSERTED TO MONITOR HASHFN ! LOGO COMMAND HASHINFO ! %INTEGERARRAY 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) !???;PRINTSTRING("GET ITEM >>>".WORD."<<<");NEWLINE 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 CURRENT FILE CLOSESM(4);CLEAR("4");DISCONNECT(MASFILE) %END; ! END CLUSERFL ! %ROUTINE GETMASTER; ! CONNECTS MASTER FILE DEFINE('4,LOGOFILE') FILSTART=SMADDR(4,FLEN) %END; ! END GETMASTER ! %ROUTINE FREEMASTER ! DISCONNECTS MASTER FILE IN WRITE AND RECONNECTS IN READ CLOSESM(4) PERMIT(MASREAD) %UNLESS CACTFILE=2 %THEN GETMASTER %END; ! END FREEMASTER ! %INTEGERFN STATUS(%STRING(15) FILENAME,%INTEGER LEVEL) ! FINDS CONNECT STATUS OF FILENAME %RECORDFORMAT F(%INTEGER AD,TYPE,DST,DEND,SIZE,RUP,EEP,MODE,CONS,ARCH,%C %STRING(6) TRANS,%STRING(8) DATE,TIME, %INTEGER COUNT, SPARE1,SPARE2) %RECORD R(F) %INTEGER FLAG,RES FINFO('NOFILE',0,R,FLAG) FINFO(FILENAME,LEVEL,R,FLAG) %IF FLAG>0 %THEN %RESULT=-FLAG RES=R_MODE %IF R_CONS=0 %THENRESULT=0 %RESULT=RES %END; ! END STATUS ! ! %ROUTINESPEC PRINTFNLINE(%INTEGERNAME SPTR) %ROUTINE BADERROR(%STRING(80) ERRMESS,%INTEGER CULPRIT) %INTEGER FUNLIST,FUN,PTR %REAL FAIL17 %IF TDEV=8 %THEN SET42(CHTXT) 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('3,LOGOTEMP') SELECTOUTPUT(3) DEVICE =TTY FUNLIST=NEWFN %WHILE FUNLIST#NIL %CYCLE PTR=FNTEXT(HD(FUNLIST)>>8) %UNTIL SOURCE(FUN)='E' %AND SOURCE(FUN+1)='N' %C %AND SOURCE(FUN+2)='D' %CYCLE FUN=PTR PRINTFNLINE(PTR) %REPEAT FUNLIST=TL(FUNLIST) %REPEAT PRSTRING('GETTY');NOOLINE(1); SELECTOUTPUT(0) PRSTRING('SAVED');NOOLINE(1) CLOSESTREAM(3) CLUSERFL;CLOSESM(6);CLEAR("6") DESTROY('LOGOSTK') FAIL17=1.0/0; ! FAILS FAULT17 %END; ! END BADERROR ! %INTEGERFN TIME100 %LONGREAL X X=CPUTIME %RESULT=INT(CPUTIME*100) %END; ! END TIME100 ! ! ! ! FILING SYSTEM MAPPING ROUTINES ! %ROUTINE MDMAP(%INTEGER MDSTART) ! MAPS A PAGE IN MASTER DIRECTOR FORMAT MDENTS==BYTEINTEGER(MDSTART+1) MDNEXT==BYTEINTEGER(MDSTART+3) UDNAM==ARRAY(MDSTART+4,DF) UDPAGE==ARRAY(MDSTART+4034,PF) %END; ! END MDMAP ! %ROUTINE TMDMAP(%INTEGER START) TMDENTS==BYTEINTEGER(START+1) TMDNEXT==BYTEINTEGER(START+3) TUDNAM==ARRAY(START+4,DF) TUDPAGE==ARRAY(START+4034,PF) %END; !END TMDMAP ! %ROUTINE UDMAP(%INTEGER UDSTART) ! MAPS A PAGE IN USER DIRECTORY FORMAT UDENTS==BYTEINTEGER(UDSTART+5) UDNEXT==BYTEINTEGER(UDSTART+7) FUNNAM==ARRAY(UDSTART+8,FF) TXTPAGE==ARRAY(UDSTART+3908,XF) TXTIND==ARRAY(UDSTART+3968,NF) %END; !END UDMAP ! %ROUTINE TUDMAP(%INTEGER START) TUDENTS==BYTEINTEGER(START+5) TUDNEXT==BYTEINTEGER(START+7) TFUNNAM==ARRAY(START+8,FF) TTXTPAGE==ARRAY(START+3908,XF) TTXTIND==ARRAY(START+3968,NF) %END; ! END TUDMAP ! %ROUTINE TXTMAP(%INTEGER TXTSTART) ! MAPS A PAGE IN TEXT FORMAT TXTENTS==ARRAY(TXTSTART,SF) TXTNEXT==BYTEINTEGER(TXTSTART+3) FNTXT==ARRAY(TXTSTART+3,TF) %END; !END TXTMAP ! ! %ROUTINE TTXTMAP(%INTEGER START) TTXTENTS==ARRAY(START,SF) TTXTNEXT==BYTEINTEGER(START+3) TFNTXT==ARRAY(START+3,TF) %END ! %ROUTINE ENDMAP ! MAPS LAST TEXT PAGE POINTERS ENDTXT==BYTEINTEGER(FILSTART+4097) ENDIND==ARRAY(FILSTART+4098,SF) %END; ! END ENDMAP ! %ROUTINE TENDMAP TENDTXT==BYTEINTEGER(TSTART+4097) TENDIND==ARRAY(TSTART+4098,SF) %END; !END TENDMAP ! %INTEGERFN SHORTINT(%BYTEINTEGERNAME INDEX) ! RETURNS INTEGER VALUE HELD IN 2 BYTE ARRAY, INDEX %RESULT=INDEX<<8!BYTEINTEGER(ADDR(INDEX)+1) %END; ! END SHORTINT ! %ROUTINE SETSHORTINT(%BYTEINTEGERNAME NAME,%INTEGER VALUE) ! PUTS VALUE INTO 2 BYTE ARRAY, NAME NAME=VALUE>>8 BYTEINTEGER(ADDR(NAME)+1)=VALUE&X'FF' %END; ! END SETSHORTINT ! %ROUTINE MAPEND ! MAPS LASR TEXT PAGE TXTP=ENDTXT %UNLESS TXTP=0 %THEN TXTMAP(FILSTART+TXTP*4096) %IF TXTP=0 %OR SHORTINT(ENDIND(1))=4093 %THENSTART GETPAGE(4) ENDTXT=TXTP ENDIND(1)=0; ENDIND(2)=1 %FINISH INDEX=SHORTINT(ENDIND(1)) %END; !END MAPEND ! %ROUTINE GETUDP UDP=UDPAGE(MDIND) UDMAP(FILSTART+UDP*4096) %END ! %ROUTINE GETTXTP(%INTEGER IND) TXTP=TXTPAGE(IND) TXTMAP(FILSTART+TXTP*4096) %END ! ! ! ! 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 ! %INTEGERFN CONSG (%INTEGER X,LIST) ! PATCH ROUTINE FOR ADDING STANDARD ! EMAS NUMBERS TO LISTS ! %RESULT=CONS(X<<8!NM,LIST) %END ! %INTEGERFN WITHOUT (%INTEGER ITEM,LIST) ! REMOVES 'ITEM' FROM 'LIST' ! ! %RESULT=NIL %IF LIST=NIL %RESULT=CONS(HD(LIST),WITHOUT(ITEM,TL(LIST))) %IF ITEM#HD(LIST) %RESULT=WITHOUT(ITEM,TL(LIST)) ;! REMOVE ITEM %END %INTEGERFN AMONGQ (%INTEGER ITEM,LIST) %RESULT=0 %IF LIST=NIL %RESULT=1 %IF ITEM=HD(LIST) %RESULT=AMONGQ(ITEM,TL(LIST)) %END ! %INTEGERFN APPENDL (%INTEGER L1,L2) ! APPENDS L1 - L2 ! SIMILAR TO ! *1: SENTENCE :L1 :L2 ! WHERE L1 AND L2 ARE LISTS ! ! USED IN PICTURE FUNCTION 'CUT' ! %INTEGER L3 L3 = NIL ;! CLEAR WORKSPACE L3 = CONS(HD(L1),L3) %AND L1 = TL(L1) %WHILE L1 # NIL ;! REVERSE COPY L1 INTO L3 L2 = CONS(HD(L3),L2) %AND L3=TL(L3) %WHILE L3 # NIL ;! AND STICK ON FRONT OF L2 %RESULT = L2 %END ! %INTEGERFN FROMLIST(%INTEGER ITEM,LIST) %INTEGER NEWLIST %IF HD(LIST)=ITEM %THEN %RESULT=TL(LIST) NEWLIST=LIST %WHILE TL(NEWLIST)#NIL %CYCLE %IF HD(TL(NEWLIST))=ITEM %THENSTART REPTAIL(NEWLIST,TL(TL(NEWLIST))) ;! ALTERS LIST %RESULT=LIST %FINISH NEWLIST=TL(NEWLIST) %REPEAT %RESULT=LIST %END; ! END OF FROMLIST ! ! ! ! ! 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) ! COLLECT PICTURE LIST AREA NOW %CYCLE I = 0,1,1022 %IF INDEX42(I)_PTR # 0 %THEN INDEX42(I)_PTR=GENCOPY(INDEX42(I)_PTR) %REPEAT CURPIC = GENCOPY(CURPIC) CURFRAME=GENCOPY(CURFRAME) CURMOVIE=GENCOPY(CURMOVIE) ! USEDAFTER=LPOINT-LABASE %IF STATUS(MASNUM.'LOGOMON',0)>=0 %THENSTART DEFINE('7,'.MASNUM.'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("7") DISCONNECT(MASNUM.'LOGOMON') %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) %INTEGER MARK MARK=LIST&X'F0' %IF LIST&LM#LM %OR LIST&MARKERMASK=NIL %THENRESULT=LIST %RESULT=CONS1(COPY(HD(LIST)),COPY(TL(LIST)))!MARK %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&MARKERMASK#NIL %CYCLE LIST1=CONS(HD(LIST),LIST1) LIST=TL(LIST) %REPEAT %RESULT=LIST1 %END; ! END REVERSE ! %INTEGERFN REVERSE1(%INTEGER LIST) %INTEGER LIST1 LIST1=NIL %WHILE LIST&MARKERMASK#NIL %CYCLE LIST1=CONS1(HD(LIST),LIST1) LIST=TL(LIST) %REPEAT %RESULT=LIST1 %END; ! OF REVERSE1 ! ! ! ! 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 ORDER. ! ARG VALUES ARE ON STACK !???;PRINTSTRING("ENTERED SETBIND");NEWLINE %WHILE PARMLIST#NIL %CYCLE %IF ENVIR=3000 %THEN BADERROR('ENVIRONMENT OVERFLOW',EMPTY) ENVIR=ENVIR+1 BNAME(ENVIR)=HD(PARMLIST) %IF CHECKSTACK=FAULT %THEN %RESULT=FAULT BVALUE(ENVIR)=UNSTACK !???; PRINTSTRING("ENVIR=");WRITE(ENVIR,6);NEWLINE 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 !??; PRINTSTRING("UNSTACK>>");PRINTDIAG(STK(STKPNT+1)) !??; PRINTSTRING("<<");NEWLINE %RESULT=STK(STKPNT+1) %END; ! END UNSTACK ! %ROUTINE STACK(%INTEGER I) %IF STKPNT=2000 %THEN BADERROR('STACK OVERFLOW',EMPTY) STKPNT=STKPNT+1 !??; PRINTSTRING("STACK>>");PRINTDIAG(I); !??; PRINTSTRING("<<");NEWLINE STK(STKPNT)=I %END; ! END STACK; ! %INTEGERFN CHECKSTACK %IF STKPNT=0 %THEN %RESULT=FAULT %RESULT=0 %END ! ! ! 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 !??; PRINTSTRING("UNSTKSYS>>");WRITE(SYSTK(SYSTKPNT+1),10) !??; PRINTSTRING("<<");NEWLINE %RESULT=SYSTK(SYSTKPNT+1) %END; ! END UNSTKSYS ! %ROUTINE STKSYS(%INTEGER I) %IF SYSTKPNT=2000 %THEN BADERROR('SYSTACK OVERFLOW',EMPTY) SYSTKPNT=SYSTKPNT+1 !??; PRINTSTRING("STKSYS>>");WRITE(I,10) !??; PRINTSTRING("<<");NEWLINE 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. ! ! %ROUTINE CHKIND(%INTEGERNAME INDEX) ! CHECKS INDEX FOR READ ROUTINES %IF INDEX>SHORTINT(TXTENTS(1)) %THENSTART %IF TXTNEXT=0 %THENSTART BADERROR('NEXT TEXT PAGE NOT INDICATED',EMPTY) %FINISH TXTP=TXTNEXT TXTMAP(FILSTART+TXTP*4096) INDEX=1 %FINISH %END; !END CHKIND ! ! ! INPUT ROUTINES -- READ SYMBOL FROM INPUT BUFFER ! INPTR IS A POINTER TO CURRENT POSITION IN LINE ! %ROUTINE LGREAD SYM(%INTEGERNAME SYM) ! READ SYMBOL FROM INPUT BUFFER SYM=INBUFF(INPTR) INPTR=INPTR+1 %RETURN; %END; ! END LGREAD SYM ! %INTEGERFN LGNEXT SYM; ! NEXT SYMBOL FROM INPUT BUFFER %RESULT=INBUFF(INPTR) %END; ! END LGNEXT SYM ! %ROUTINE LGSKIP SYM ! SKIP SYMBOL IN INPUT BUFFER INPTR=INPTR+1 %RETURN; %END; ! END LGSKIP SYM ! %ROUTINE LGREAD ITEM(%STRINGNAME ITEM) ! READ ITEM FROM INPUT BUFFER ITEM=TOSTRING(INBUFF(INPTR)) INPTR=INPTR+1 %RETURN; %END; !END LGREAD ITEM ! ! %INTEGERFN GETITEM ! ! READ NEXT LOGO ITEM FROM INPUT BUFFER ! %INTEGER SYM,SKIPMARK %STRING(2) ITEM %STRING(64) WORD %INTEGER SYMCOUNT SYMCOUNT=0;WORD='';SKIPMARK=0 %IF QUOTEON=1 %AND (LGNEXT SYM<'0' %OR '9''Z') %THENRESULT=EMPTY LP:%IF LGNEXT SYM=' ' %THENSTART LGSKIP SYM %IF SYMCOUNT=0 %THEN ->LP %ELSESTART %IF SKIPMARK=1 %THEN NOOLINE(1) %RESULT=PUT(WORD) %FINISH %FINISH %IF LGNEXT SYM='@' %THENSTART %IF SYMCOUNT=0 %THEN %START LGSKIP SYM; ! SKIP @ LGSKIP SYM %IF LGNEXT SYM = NL; ! SKIP NL ->LP %FINISHELSESTART %IF SKIPMARK=1 %THEN NOOLINE(1) %RESULT=PUT(WORD) %FINISH %FINISH %IF LGNEXT SYM=TERMIN %THENSTART; ! TERMIN=NL %IF SYMCOUNT=0 %THENSTART %IF LEVEL>BLEVEL %OR PARLEVEL>BLEVEL %THENSTART PRSTRING('MISSING RIGHT BRACKET INSERTED');NOOLINE(1) %FINISH LEVEL=BLEVEL PARLEVEL=BLEVEL !???;PRINTSTRING("GETITEM--TERMIN");NEWLINE %RESULT=RBRAK %FINISHELSESTART %IF SKIPMARK=1 %THEN NOOLINE(1) !????; %IF WORD="DIAGSON" %OR WORD="DIAGSOFF" %THEN %START !????; %IF WORD="DIAGSON" %THEN DIAGFLAG=1 %ELSE DIAGFLAG=0 !????; %RESULT=GETITEM !????;%FINISH %RESULT=PUT(WORD) %FINISH %FINISH %IF LGNEXT SYM=LBRAK %OR LGNEXT SYM=RBRAK %THENSTART %IF SYMCOUNT=0 %THENSTART LGREAD SYM(SYM) %IF SYM = LBRAK %THEN LEVEL=LEVEL+1 %ELSE LEVEL=LEVEL-1 !???;PRINTSTRING("GET ITEM >>".TOSTRING(SYM)."<<");NEWLINE %RESULT=SYM %FINISHELSESTART %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) %FINISHELSESTART !???;PRINTSTRING("GET ITEM >>-".TOSTRING(SYM)."<<");NEWLINE %RESULT=(-SYM>>8)<<8!NM %FINISH %FINISHELSESTART %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 %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 ! ! INPUT BUFFER IS THOUGHT OF AS A LIST. ! HEADIN IS THE HEAD OF THE LIST ! TAILIN CAUSES HEADIN TO BE UPDATED TO NEXT ITEM ON LIST ! UNUSEDHD IS A FLAG USED BY PARSE ROUTINES TO CHECK ! WHETHER THE HEAD OF THE INPUT LIST HAS BEEN PROCESSED ! %ROUTINE TAILIN HEADIN=GETITEM UNUSEDHD=0 %END; ! OF TAILIN ! ! ! INPUT ROUTINES FROM CURRENT INPUT STREAM ! THIS IS EITHER .TT, SOURCETEXT, FILESTORE ! %ROUTINE READ IN SYM(%INTEGERNAME SYM) ! LOGO READ SYMBOL %IF DEVICE=TTY %THEN READ SYMBOL(SYM) %ELSE %START %IF DEVICE=SRCE %THEN %START SYM=SOURCE(SINDEX) SINDEX=SINDEX+1 %FINISH %ELSE %START CHKIND(INDEX) SYM=FNTXT(INDEX) INDEX=INDEX+1 %FINISH %FINISH %END; ! END OF READ IN SYM ! %INTEGERFN NEXT IN SYM ! LOGO NEXT SYMBOL %IF DEVICE=TTY %THEN %RESULT=NEXT SYMBOL %IF DEVICE=SRCE %THEN %RESULT=SOURCE(SINDEX) CHKIND(INDEX) %RESULT=FNTXT(INDEX) %END; ! END OF NEXT IN SYM ! %ROUTINE SKIP IN SYM ! LOGO SKIP SYMBOL %IF DEVICE=TTY %THEN SKIP SYMBOL %AND %RETURN %IF DEVICE=SRCE %THEN SINDEX=SINDEX+1 %ELSE INDEX=INDEX+1 %END; ! END OF SKIP IN SYMBOL ! %ROUTINE READINLINE(%STRING(15) PROMP) ! ! READ A LINE FROM CURRENT INPUT STREAM TO INPUT BUFFER ! %INTEGER PTR,SYM LEVEL=BLEVEL PARLEVEL=BLEVEL PROMPT(PROMP) PTR=1 SKIPINSYM %WHILE NEXTINSYM=NL %UNTIL NEXTINSYM=NL %THEN %CYCLE %IF PTR>=255 %THEN %START PRSTRING("LINE TOO LONG") NOOLINE(1) %EXIT %FINISH READINSYM(SYM) INBUFF(PTR)=SYM PTR=PTR+1 %IF SYM='@' %THEN %START %WHILE NEXTINSYM#NL %THEN SKIPINSYM %IF PTR>=255 %THENSTART PRSTRING("LINE TOO LONG") NOOLINE(1) %EXIT %FINISH READINSYM(SYM) INBUFF(PTR)=SYM PTR=PTR+1 PROMPT("C:") %FINISH %REPEAT INBUFF(PTR)=NL PROMPT(PROMP) INBUFF(0)=PTR INPTR=1 HEADIN=GET ITEM UNUSEDHD=0 %IF HEADIN=RBRAK %THEN READINLINE(PROMP) !??;PRINTSTRING("INPUTLINE READ");NEWLINE !??;PRINTSTRING(STRING(ADDR(INBUFF(0))));NEWLINE %END; ! END OF READ LINE ! ! %ROUTINE COPYLINE ! ! COPY A LINE FROM INPUT BUFFER INTO SOURCE TEXT FILE ! %IF SOURCEPTR+INBUFF(0)>MAXSOURCE %THEN %C BADERROR('FILE SOURCE SPACE OVERFLOW',EMPTY) MOVE(INBUFF(0),ADDR(INBUFF(1)),ADDR(SOURCE(SOURCEPTR))) SOURCEPTR=SOURCEPTR+INBUFF(0) %END ! ! %INTEGERFN READLIST ! ! READ A LIST FROM INPUT BUFFER ! RESULT IS HEAD OF LIST ! %INTEGER THISPOINT,ITEM !???; PRINTSTRING("ENTERED READLIST -- HEADIN= ") !???; WRITE(HEADIN,6) !???; NEWLINE THISPOINT=LPOINT ITEM=HEADIN TAILIN !%IF ITEM=QUOTE %THEN QUOTEON=1 %ELSE QUOTEON=0 %IF ITEM=RBRAK %THEN %START %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 %FINISHELSE LA(THISPOINT)=ITEM LA(THISPOINT+1)=READLIST %RESULT=THISPOINT<<8!LM %FINISH %END; ! OF READLIST ! ! %INTEGERFN READLINE BLEVEL=1 READINLINE(PROMP) %RESULT=READLIST %END; ! END READLINE ! %ROUTINE GETPAGE(%INTEGER FLAG) ! GETS A NEW PAGE ! FLAG 1 - NEW MASTER DIRECTORY PAGE ! FLAG 2 - NEW USER DIRECTORY PAGE ! FLAG 4 - NEW TEXT PAGE ! FLAGS MAY BE COMBINED %STRING(10) SIZE %INTEGER LEN, I, J, K I=(FLAG&1) + ((FLAG&2)//2) + ((FLAG&4)//4) SIZE=NUMTOSTR((FLEN+4096*I)<<8) DEFINE('10,JUNK') NEWSMFILE('JUNK,'.SIZE) TSTART=SMADDR(10,LEN) %CYCLE I=0,4096,FLEN-4096; ! COPY OLD FILE TO NEW FILE J=FILSTART+I K=TSTART+I MOVE(4096,J,K) %REPEAT CLOSESM(10) CLEAR("10") CLOSESM(4) CLEAR("4") DESTROY(MASFILE) RENAME('JUNK,'.MASFILE) CHERISH(MASFILE) PERMIT(MASFILE.',,R') PERMIT(MASWRITE) GETMASTER MDMAP(FILSTART+MDP*4096) %IF FLAG=4 %THENSTART ENDMAP %UNLESS TXTP=0 %THEN TXTMAP(FILSTART+TXTP*4096) %AND %C TXTNEXT=LEN//4096-1 TXTP=LEN//4096-1 TXTMAP(FILSTART+TXTP*4096) TXTENTS(1)=0;TXTENTS(2)=0 INDEX=1;TXTNEXT=0 %FINISHELSESTART %IF FLAG=3 %THENSTART MDENTS=63 MDNEXT=LEN//4096-2 MDP=MDNEXT MDMAP(FILSTART +MDP*4096) MDENTS=0 %FINISH %UNLESS UDP=0 %THENSTART UDMAP(FILSTART+UDP*4096) UDENTS=61;UDNEXT=LEN//4096-1 %FINISH UDP=LEN//4096-1 UDMAP(FILSTART+UDP*4096);UDENTS=0 ENDMAP %IF UDP=1 %THEN ENDTXT=0 %AND SETSHORTINT(ENDIND(1),1) %FINISH %END; ! END GETPAGE ! %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 !??; PRINTSTRING(' PRSTRING - START');NEWLINE N=LENGTH(WORD) !??; PRINTSTRING(' PRSTRING - 2');NEWLINE %IF (CHAROUT+N)>72 %THENSTART !??; PRINTSTRING(' PRSTRING - 2A');NEWLINE NEWLINE %IF WORD->(" ").WORD %THEN N=N-1 !??; PRINTSTRING(' PRSTRING - 2B');NEWLINE SPACES(3) !??; PRINTSTRING(' PRSTRING - 2C');NEWLINE PRINTSTRING(WORD) !??; PRINTSTRING(' PRSTRING - 2D');NEWLINE CHAROUT=N+3 %FINISHELSESTART !??; PRINTSTRING(' PRSTRING - 3');NEWLINE PRINTSTRING(WORD) !??; PRINTSTRING(' PRSTRING - 3A');NEWLINE CHAROUT=CHAROUT+N !??; PRINTSTRING(' PRSTRING - 3B');NEWLINE %FINISH !??; PRINTSTRING(' PRSTRING - FINISH');NEWLINE %END; ! END PRSTRING ! %ROUTINE LGPRNT STR(%STRING (64) WORD) %INTEGER SAVE,NEWIND !??; PRINTSTRING(' LGPRNT STR- START');NEWLINE %IF DEVICE=TTY %THEN PRSTRING(WORD) %ANDRETURN !??; PRINTSTRING(' LGPRNT STR - 2');NEWLINE %IF DEVICE=SRCE %THEN %START !??; PRINTSTRING(' LGPRNT STR - 2A');NEWLINE SAVE=SOURCE(SOURCEPTR-1) !??: PRINTSTRING(' LGPRNT STR - 2B');NEWLINE STRING(ADDR(SOURCE(SOURCEPTR-1)))=WORD !??; PRINTSTRING(' LGPRNT STR - 2C');NEWLINE NEWIND=SOURCEPTR+SOURCE(SOURCEPTR-1) SOURCE(SOURCEPTR-1)=SAVE !??; PRINTSTRING(' LGPRNT STR - 2D');NEWLINE SOURCEPTR=NEWIND !??; PRINTSTRING(' LGPRNT STR - FINISH');NEWLINE %FINISH !%IF 4093-INDEX>8)&X'FFFF') PRINTWORD(WORD) %END; ! END PRINTWN ! %ROUTINE PRINTLCON(%INTEGER LIST) %INTEGER I !??; PRINTSTRING(' PRINTLCON - START');NEWLINE LP:%IF ENUF=1 %OR (INTERRUPT='ENUF' %AND DEVICE=TTY) %THENSTART !??; PRINTSTRING(' PRINTLCON - 1');NEWLINE ENUF=1 %RETURN %FINISH !??; PRINTSTRING(' PRINTLCON - 2');NEWLINE %IF LIST=NIL %THENRETURN !??; PRINTSTRING(' PRINTLCON - 3');NEWLINE I=HD(LIST) !??: PRINTSTRING(' PRINTLCON - 4');NEWLINE %IF I&LM=LM %THEN PRINTLIST(I) %ELSE PRINTWN(I) !??; PRINTSTRING(' PRINTLCON - 5');NEWLINE LIST=TL(LIST) !??: PRINTSTRING(' PRINTLCON - 6');NEWLINE ->LP %END; ! END PRINTLCON ! %ROUTINE PRINTLIST(%INTEGER LIST) SEP="" !??; PRINTSTRING(' PRINTLIST - START');NEWLINE PRINTWORD("[") !??; PRINTSTRING(' PRINTLIST - 1');NEWLINE PRINTLCON(LIST) !??; PRINTSTRING(' PRINTLIST - 2');NEWLINE PRINTWORD("]") !??; PRINTSTRING(' PRINTLIST - FINISH');NEWLINE %END; ! END PRINTLIST ! %ROUTINE PRINTEL(%INTEGER I) %INTEGER J !??; PRINTSTRING(' PRINTEL - START');NEWLINE ENUF=0 SEP="" !??; PRINTSTRING(' PRINTEL - 1');NEWLINE %CYCLE J=1,1,14 %IF SPECHAR(J)=I %THEN ->SPCHAR %REPEAT !??; PRINTSTRING(' PRINTEL - 2');NEWLINE %IF I&LM=LM %THEN PRINTLIST(I) %ELSE PRINTWN(I) !??; PRINTSTRING(' PRINTEL - FINISH1');NEWLINE %RETURN SPCHAR: !??; PRINTSTRING(' PRINTEL - 3');NEWLINE PRINTWORD(TOSTRING(I)) !??; PRINTSTRING(' PRINTEL - FINISH2');NEWLINE %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 ! %ROUTINE PRINTFNLINE(%INTEGERNAME SPTR) %INTEGER SYM,I,CONT CONT=0 %IF DEVICE=TTY %THEN %START %CYCLE I=0,1,255 SYM=SOURCE(SPTR+I) PRINTSYMBOL(SYM) %IF SYM='@' %THENSTART %CYCLE SYM=SOURCE(SPTR+I+1) %IF SYM=NL %THEN %EXIT PRINTSYMBOL(SYM) SPTR=SPTR+1 %REPEAT CONT=1 %FINISHELSESTART %IF SYM=NL %THEN %START %EXIT %UNLESS CONT=1 CONT=0 %FINISH %FINISH %REPEAT %FINISHELSESTART %CYCLE I=0,1,255 %IF INDEX=4093 %THEN SETSHORTINT(TXTENTS(1),4092) %AND GETPAGE(4) SYM=SOURCE(SPTR+I) FNTXT(INDEX)=SYM INDEX=INDEX+1 %IF SYM='@' %THENSTART %WHILE SOURCE(SPTR+I+1)#NL %THEN SPTR=SPTR+1 CONT=1 %FINISH %IF SYM=NL %THEN %START %EXIT %UNLESS CONT=1 CONT=0 %FINISH %REPEAT SETSHORTINT(TXTENTS(1),INDEX-1) %FINISH SPTR=SPTR+I+1 %IF I=255 %THEN %START PRSTRING("LINE TOO LONG - TRUNCATED") %IF DEVICE=TTY %THEN PRINTSYMBOL(NL) %ELSE FNTXT(INDEX-1)=NL NOOLINE(1) %FINISH %END; ! END OF PRINTFNLINE ! %ROUTINE PRINTHEX(%BYTEINTEGER I) %CONSTBYTEINTEGERARRAY HEX(0:15)='0','1','2','3','4','5','6','7', %C '8','9','A','B','C','D','E','F' %INTEGER CYC %STRING(2) H H="" %CYCLE CYC=0,1,1 H=TOSTRING(HEX((I>>(CYC*4))&15)).H %REPEAT PRINTSTRING(H) %END !??; %ROUTINE PRINTDIAGLIST(%INTEGER LIST) !??; %INTEGER I !??; %RETURN %IF DIAGFLAG=0 !??; SEP="" !??; LP: %IF LIST&X'FFFF0F'=NIL %THEN PRINTDIAG(LIST) %AND %RETURN !??; I=HD(LIST&X'FFFFFF') !??; PRINTSTRING("{<") !??; PRINTHEX(BYTEINTEGER(ADDR(LIST))) !??; PRINTSTRING(",") !??; WRITE((LIST>>8)&X'FFFF',3) !??; PRINTSTRING(",") !??; PRINTHEX(BYTEINTEGER(ADDR(LIST)+3)) !??; PRINTSTRING(">}") !??; %IF I&LM=LM %THEN %START !??; PRINTWORD("[") !??; PRINTDIAGLIST(I) !??; PRINTWORD("]") !??; %FINISH %ELSE PRINTDIAG(I) !??; LIST=TL(LIST&X'FFFFFF') !??; ->LP !??; %END ! !??; %ROUTINE PRINTDIAG(%INTEGER I) !??; %STRING(64) WORD !??; %RETURN %IF DIAGFLAG=0 !??; SEP="" !??; %IF I&NM=NM %THEN %START !??; %IF I<0 %THEN WORD="-".NUMTOSTR(\I+256) %ELSE WORD=" ".NUMTOSTR(I) !??; %FINISH %ELSE %START !??; % %IF I&WM=WM %THEN WORD=WA(I>>8) %ELSE WORD="" !??; %FINISH !??; PRINTSTRING(" ") !??; PRINTWORD("/".WORD."/") !??; PRINTHEX(BYTEINTEGER(ADDR(I)+3)) !??; %END ! ! ! INFERENCE SYSTEM ! %ROUTINE SETUPINF BVALUE(DATABASE>>8)=NIL;BVALUE(FACTKEYS>>8)=NIL BVALUE(IMPRULES>>8)=NIL;BVALUE(IMPKEYS>>8)=NIL BVALUE(INFRULES>>8)=NIL;BVALUE(INFKEYS>>8)=NIL GENOS=0 %END; ! END SETUPINF ! %ROUTINE INITINF DBASE(1)=DATABASE;IMPLINKS(1)=IMPRULES;INFLINKS(1)=INFRULES DBASE(2)=FACT;IMPLINKS(2)=IMPLIES;INFLINKS(2)=TOINFER DBASE(3)=FACTKEYS;IMPLINKS(3)=IMPKEYS;INFLINKS(3)=INFKEYS SETUPINF %END; ! END INITINF ! ! ! ! EVAL AND APPLY ! %INTEGERFN FINDLINENUMS(%INTEGER LIST) ! ! SEARCHES LINE NUMBER LIST IN USER PROCEDURE FOR THE NUMBER ! THAT IS AT TOP OF STACK ! %INTEGER NUM NUM=UNSTACK %WHILE LIST # NIL %THEN %CYCLE %IF HD(HD(LIST))=NUM %THEN %START GOFLAG=0 STACK(NUM) %RESULT=TL(HD(LIST)) %FINISH LIST=TL(LIST) %REPEAT STACK(NUM) %RESULT=0 %END ! ! ! %INTEGERFNSPEC CHECKFNHEAD(%INTEGERNAME NAME) %ROUTINESPEC PARSEERR(%INTEGER ERRMESS,CULPRIT) %ROUTINE EDIT(%INTEGERNAME NAME) %INTEGER SSTART,SLEN,WSP,LWSP,FLAG,USERFUN USERFUN=NAME>>8 SSTART=ADDR(SOURCE(FNTEXT(USERFUN))); ! ADDR OF START OF USER TEXT SLEN=FNLEN(USERFUN); ! LENGTH OF CURRENT TEXT WSP=ADDR(SOURCE(SOURCEPTR)); ! ADDR OF START OF FREE SPACE LWSP=MAXSOURCE-SOURCEPTR+1; ! LENGTH OF AVAILABLE FREE SPACE PROMPT(">") EDINNER(SSTART,SLEN,SSTART,SLEN,WSP,LWSP); ! ENTER ECCE PROMPT(PROMP); ! RESET PROMPT FNTEXT(USERFUN)=SOURCEPTR; ! STORE ADDR OF NEW DEFN FNLEN(USERFUN)=LWSP SOURCEPTR=SOURCEPTR+LWSP %IF LWSP>4 %THEN %START %CYCLE WSP=5,1,LWSP %IF SOURCE(SOURCEPTR-WSP)=NL %THEN ->CHEND %REPEAT %FINISH CHEND: %IF SOURCE(SOURCEPTR-WSP+1)='E' %AND %C SOURCE(SOURCEPTR-WSP+2)='N' %AND %C SOURCE(SOURCEPTR-WSP+3)='D' %THEN -> CHFNHD INSEND: %IF SOURCEPTR+4>MAXSOURCE %THEN %C BADERROR('SOURCE FILE SPACE OVERFLOW',EMPTY) SOURCE(SOURCEPTR)='E' SOURCE(SOURCEPTR+1)='N' SOURCE(SOURCEPTR+2)='D' SOURCE(SOURCEPTR+3)=NL SOURCEPTR=SOURCEPTR+4 FNLEN(USERFUN)=LWSP+4 PRSTRING('END INSERTED') NOOLINE(1) CHFNHD: FLAG=CHECKFNHEAD(NAME); ! CHECK NEW PROCEDURE HEADER %IF FLAG=FAULT %THEN FNPARSE(NAME>>8)=255 %END ! ! %INTEGERFNSPEC COUNTARGS %INTEGERFN CHECKFNHEAD(%INTEGERNAME USERFUN) %INTEGER FN,SAVEDEV,NUMARGS,RES,FNSPEC RES=0;NUMARGS=0 FNPARSE(USERFUN>>8)=0 FNVAL(USERFUN>>8)=USERPRE SAVEDEV=DEVICE; ! CHECK FIRST LINE DEVICE=SRCE SINDEX=FNTEXT(USERFUN>>8) READINLINE(PROMP) DEVICE=SAVEDEV %IF HEADIN#TO %THEN %START; ! CHECK THAT DEFN STARTS WITH TO PARSEERR(-17,USERFUN); ! INVALID FN DEFN - TO MISSING RES=FAULT ->EXIT %FINISH TAILIN FN=HEADIN %IF FN&WM#WM %THEN %START; ! CHECK THAT NAME OF PROC IS A WORD PARSEERR(-14,FN) RES=FAULT ->EXIT %FINISH %IF FN#USERFUN %THEN %START; ! NAME CHANGED NEWFN=FROMLIST(FN,NEWFN) %UNLESS NEWFN=NIL FNSPEC=FNVAL(FN>>8); ! GET SPEC %UNLESS FNSPEC=0 %OR FNSPEC&USERPRE=USERPRE %THEN %START PARSEERR(-15,FN) RES=FAULT ->EXIT %FINISH %IF FNTEXT(FN>>8)#0 %THEN OLDFN(FN>>8)=FNLEN(FN>>8)<<16!FNTEXT(FN>>8) FNTEXT(FN>>8)=FNTEXT(USERFUN>>8) FNLEN(FN>>8)=FNLEN(USERFUN>>8) FNTEXT(USERFUN>>8)=0 FNLEN(USERFUN>>8)=0 FNVAL(USERFUN>>8)=0 USERFUN=FN %FINISH TAILIN NUMARGS=COUNTARGS %IF NUMARGS>127 %THEN %START PARSEERR(-13,USERFUN) RES=FAULT ->EXIT %FINISH %IF NUMARGS<0 %THEN RES=FAULT %AND NUMARGS=0 EXIT: FNVAL(USERFUN>>8)=USERPRE+NUMARGS; ! TEMP SPEC TO ALLOW RECURSIVE CALLS %RESULT=RES %END ! %INTEGERFN COUNTARGS ! ! COUNT NO OF ARGS IN A USER PROCEDURE. ! %INTEGER LEN LEN=0 %WHILE HEADIN#RBRAK %THEN %CYCLE ->ERRLAB %UNLESS HEADIN=QUOTE TAILIN ->ERRLAB %IF HEADIN&WM#WM %OR HEADIN=RBRAK LEN=LEN+1 TAILIN %REPEAT %RESULT=LEN ERRLAB: PARSEERR(-16,EMPTY) %RESULT=FAULT %END; ! OF COUNTARGS ! ! ! ! %ROUTINE PARSEERR(%INTEGER ERRMESS,CULPRIT) %INTEGER SAVEDEV,ERRNUM %CONSTSTRING(80)%ARRAY MESSAGE (1:22) = %C "NAME MISSING AFTER : ", %C "NON-WORD AFTER : - ", %C "MISSING >> ", %C "MISPLACED CLOSING BRACKET - ", %C "MISPLACED INFIX FN ", %C "THEN MISSING - ", %C "THEN NOT FOUND - ", %C "FINISH MISSING - ", %C "NO NUMBER ON FN LINE - LINE IGNORED - ", %C "ERROR IN FN TYPE ", %C "UNDEFINED PROCEDURE ", %C "NOT ENOUGH ARGS FOR - ", %C "TOO MANY ARGS FOR ", %C "TO MUST BE GIVEN A WORD AS PROCEDURE NAME - ", %C "YOU CAN'T REDEFINE A SYSTEM PROCEDURE - ", %C "INCORRECT FORMAT FOR ARGS ", %C "INCORRECT FORMAT FOR FN DEFN - TO MISSING - ", %C "RUN OUT OF FILE SPACE ", %C "FN DEFN NOT AT OUTER LEVEL", %C "LINE IGNORED - ", %C "CONDITION CLAUSE MISSING", %C "THEN CLAUSE MISSING" ERRNUM=-ERRMESS SAVEDEV=DEVICE DEVICE=TTY PRSTRING(MESSAGE(ERRNUM));SPACE;PRINTEL(CULPRIT) NOOLINE(1) DEVICE=SAVEDEV %END ! ! %INTEGERFNSPEC PARSELINE(%INTEGER PREC) %ROUTINE EVALAPPL(%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 LINE 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 IN,%INTEGERNAME EACHVAL) ! ! %ROUTINE ERROR(%STRING(80) ERRMESS,%INTEGER CULPRIT,SEVERITY,%C %INTEGERNAME IN) %INTEGER SAVEDEV,TXTPTR %IF TDEV=8 %THEN SET42(CHTXT) SAVEDEV=DEVICE DEVICE=TTY NOOLINE(1);PRSTRING(ERRMESS);SPACE;PRINTEL(CULPRIT);NOOLINE(1) %IF FUN=NIL %THEN -> ERR1; ! NOT IN A USER FUN PRSTRING('IN ');PRINTEL(HD(TL(HD(FUN)))); ! NAME OF USER FUN NOOLINE(1) %UNLESS CURFUN=NIL %THENSTART TXTPTR=(HD(CURFUN)>>16)&X'FFFF' PRINTFNLINE(TXTPTR) !PRINTLINE(HD(CURFUN)); ! CURRENT LINE NOOLINE(1) %FINISH %IF GETVAL(QUITOTOP,ENVIR)=FALSE %THENSTART !??; PRINTSTRING(" ENTERING LOGO RECURSIVELY"); NEWLINE ! ENTER LOGO RECURSIVELY 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 %FINISH ERR1:JUMPFLAG=1; ! TRIGGERS A RETURN TO LOGO IN=NIL STACK(ERR) DEVICE=SAVEDEV %END; ! END ERROR ! %ROUTINE ERROR1(%STRING(80) ERRMESS,%INTEGER CULPRIT) %INTEGER SAVEDEV SAVEDEV=DEVICE DEVICE=TTY 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 ! ! %ROUTINE CHKLIST(%INTEGER LIST) %INTEGER WORD %IF LIST&LM#LM %THENSTART ERROR('NEW CANNOT HAVE A NUMBER AS ARGUMENT - ',LIST,1,IN) %RETURN %FINISH %WHILE LIST#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1; STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(LIST) ERROR('USER INTERRUPT',EMPTY,0,IN) LIST=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN %FINISH WORD=HD(LIST) %IF WORD&WM#WM %THENSTART ERROR(' NEW MUST HAVE A WORD AS ARGUMENT - ',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; ! END STRTRACE ! %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; ! END ENDTRACE ! %ROUTINE SENDBIN(%BYTEINTEGER TYPE,N) ! IF TYPE=0, N 16 BIT ARGS ALREADY SET UP IN BINARG1,2,ETC ! IF TYPE=1 N IS IRRELEVANT N=2*N BINBUFF(1)=TDEV-1 BINBUFF(2)=TYPE %IF TYPE=0 %THEN %START BINBUFF(3)=N !@#$ P_ARG3=N+3 %FINISH; !@#$ ELSE P_ARG3=2 !@#$ P_DEST=208; ! SVC PUT OUTPUT !@#$ P_ARG1=16; ! CHANNEL 0 WITH BINARY NIT !@#$ P_ARG2=ADDRBINBUFF !@#$ DOSVC:SVC(P) !@#$ %IF P_ARG1<0 %THENSTART; ! ABORTED !@#$ P_ARG1=P_ARG2 !@#$ P_ARG2=P_ARG3 !@#$ P_ARG3=P_ARG4 !@#$ P_DEST=208 !@#$ ->DOSVC !@#$ %FINISH %END; ! END SENDBIN ! %ROUTINE BINARG(%INTEGER ARGN,VAL) ! BINARY ARG IS LEAST SIG, 16 BITS OF VAL ! ARG1==BINBUFF(4) AND(5) ! ARG2==BINBUFF(6) AND (7) ! ETC %INTEGER I I=2*ARGN+2; ! BINBUFF LOWER INDEX BINBUFF(I)=(VAL>>8)&X'FF' BINBUFF(I+1)=VAL&X'FF' %END; ! END BINARG ! %ROUTINE CLESET ! CLEARS AND RSETS TURTLE DEVICE (IE CLEARS H316 Q) %IF TDEV=8 %THEN CLEAR42 SENDBIN(1,0) XTURTLE=0;YTURTLE=0;HDTURTLE=0;PENTURTLE=DOWN %END; ! END CLESET ! ! ! ! ! ! %ROUTINE APPLYSYS(%INTEGER SW,%INTEGERNAME FN,IN,EACHVAL) ! %ROUTINESPEC ADDFACT(%INTEGER FACT,INDENT) %INTEGERFNSPEC DEDUCEQ(%INTEGER PATTERN,INDENT) %INTEGERFNSPEC TRYINFQ(%INTEGER PAT,INDENT) ! %SWITCH SYSFUN(1:300) %SWITCH FDSW,BDSW,LEFTSW,RIGHTSW,LIFTSW,DROPSW,HOOTSW,CENSW,%C CLSW,WHSW,HERESW,XCORSW,YCORSW,HDSW,PENSW,SETXSW,SETYSW,SETHSW,%C POSW,ARCLSW,ARCRSW,PNSW,RNSW,NOTESW,PLAYSW,MOTASW,MOTBSW,ROTSW,%C PAIRSW(0:8) %REAL RW1,RW2 %REAL DX,DY %INTEGER XC,YC; ! TURTLE WORKSPACE %INTEGER ARG1,ARG2,ARG3,ARG4,W1,W2,W3,W4 %INTEGER SAVEDEV,STARTTEXT %INTEGER COND,TBRANCH,FBRANCH,RES,CONDLIST %REALARRAY TSTOR(1:2) ; ! USED IN "PICTURE" TO HOLD TURTLE COORDS %INTEGERARRAY TSTORI(3:4) %INTEGERARRAY MOVIE RECORD(1:FRAME TIME) %INTEGER CURRENT MOVIE TIME %INTEGERNAME WPTR1 %INTEGER REDEF; ! USED BY ABBREV %STRING(64) WSTR1,WSTR2 %ROUTINESPEC VECTOR(%REAL X,Y) %ROUTINESPEC CALC TURTLE ! ! %INTEGERFN EVALSTARTFIN(%INTEGER BRANCH) %INTEGER LNUMBERS,POLIST BRANCH=TL(BRANCH) LNUMBERS=HD(BRANCH); ! LINE NUMBER LIST BRANCH=TL(BRANCH) EVALNEXTLINE: POLIST=TL(HD(BRANCH)) %CYCLE %UNLESS POLIST=NIL %THEN %START %EXIT %IF HD(POLIST)=FINISH %RESULT=NIL %IF BRANCH=NIL STKSYS(IN); STKSYS(CONDLIST);STKSYS(LNUMBERS);STKSYS(BRANCH) EVAL(POLIST,EACHVAL) BRANCH=UNSTKSYS;LNUMBERS=UNSTKSYS;CONDLIST=UNSTKSYS; IN=UNSTKSYS %IF JUMPFLAG=1 %THEN %RESULT=NIL %IF GOFLAG=1 %THEN %EXIT; ! JUMP INSTR VAL=UNSTACK %IF FUN#NIL %AND CURFUN=NIL %THEN %RESULT=VAL %FINISH BRANCH=TL(BRANCH) POLIST=TL(HD(BRANCH)) %REPEAT %IF GOFLAG=1 %THEN %START; ! JUMP BRANCH=FINDLINENUMS(LNUMBERS); ! FIND LINE WITH THIS LABEL %IF BRANCH=0 %THEN %RESULT=NIL; ! LABEL NOT FOUND AT THIS LEVEL VAL=UNSTACK ->EVALNEXTLINE %FINISH; ! FINISH JUMP %RESULT=VAL %END; ! OF EVALSTARTFIN ! ! %INTEGERFNSPEC EQUAL(%INTEGER L1,L2) %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 EQUAL(HD(HD(W2)),ATT)=FALSE %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 I0 %THENSTART %IF ARG2>0 %AND MAXINT-ARG1>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 ARG1<0 %THENSTART ERROR('WORD MUST HAVE A WORD OR NON-NEGATIVE NUMBER AS ARGUMENT - ',%C ARG1,1,IN) %RETURN %FINISH %IF ARG2&LM=LM %OR ARG2<0 %THENSTART ERROR('WORD MUST HAVE A WORD OR NON-NEGATIVE NUMBER AS ARGUMENT - ',%C ARG2,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 ERROR('LASTPUT MUST HAVE A LIST AS SECOND ARGUMENT - ',ARG2,1,IN) %RETURN %FINISH ARG3=NIL %WHILE ARG2#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT);%RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(ARG2);STKSYS(ARG3) ERROR('USER INTERRUPT',EMPTY,0,IN) ARG3=UNSTKSYS;ARG2=UNSTKSYS %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 %END; ! END LASTPUT ! ! %INTEGERFN EQUAL(%INTEGER LIST1,LIST2) %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 %RESULT=QUIT %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(LIST1);STKSYS(LIST2) ERROR('USER INTERRUPT',EMPTY,0,IN) LIST2=UNSTKSYS;LIST1=UNSTKSYS %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 ! ! ! FILING SYSTEM SUPPORT ROUTINES %ROUTINE RESTFILE ! RESTORES OWNER ETC. OWNER=WSTR2 USERFILE=WSTR1 MDP=W1; MDIND=W2 %UNLESS CACTFILE=2 %THEN GETMASTER %END; ! END RESTFILE ! %ROUTINE SAVEFILE ! SAVES OWNER, USERFILE, MDP, MDIND DURING LIBRARY AND BORROWFILE WSTR2=OWNER OWNER=WSTR1 WSTR1=USERFILE W1=MDP W2=MDIND %END; ! END SAVEFILE ! %ROUTINE NOFILE CACTFILE=0;USERFILE="";OWNER=EMASUSER MDP=0;MDIND=0 %END; ! END NOFILE ! %ROUTINE FROTHDIR ! FREES ANOTHERS FILE CLOSESM(4) CLEAR("4") DISCONNECT(OWNER.".".MASFILE) %END; ! END FROTHDIR ! %ROUTINE SHAREFILE(%STRING(15) FILENAME) ! CONNECTS A FILE FOR SHARED READ ! EXITS IF CURRENTLY CONNECTED WRITE ELSEWHERE %INTEGER STAT STAT=STATUS(FILENAME,0) %IF STAT<0 %OR (STAT#0 %AND STAT&4=0) %THENSTART %IF SW=86 %THEN RESTFILE %IF SW=85 %THEN NOFILE %AND GETMASTER %FINISHELSE %RETURN %IF STAT<0 %THEN ERROR('FINFO CALL FAILS - ',(-STAT)<<8!NM,1,IN) %C %ELSE ERROR('LIBRARY IS BEING UPDATED - TRY AGAIN',EMPTY,1,IN) %END; ! END SHAREFILE ! %INTEGERFN FINDFILE %INTEGER I MDP=0; UDP=0; TXTP=0 FF1:MDMAP(FILSTART+MDP*4096) %UNLESS MDENTS=0 %THENSTART I=1 %WHILE I<= MDENTS %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 %IF SW=75 %THEN NOFILE %ELSE FROTHDIR %IF SW=86 %THEN RESTFILE %IF SW=85 %THEN NOFILE %AND GETMASTER %RESULT=QUIT %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0 %IF SW=75 %THEN NOFILE %ELSE FROTHDIR %IF SW=86 %THEN RESTFILE %IF SW=85 %THEN NOFILE %AND GETMASTER ERROR('USER INTERRUPT - PROCESS ABANDONNED',EMPTY,1,IN) %RESULT=UNSTACK %FINISH %IF I=63 %THEN MDP=MDNEXT %AND ->FF1 %IF UDNAM(I)=USERFILE %THEN %RESULT=I I=I+1 %REPEAT %FINISH %RESULT=-1 %END; !END FINDFILE ! %ROUTINE GOTHDIR ! CONNECTS ANOTHERS MASTER FILE ! OWNER CONTAINS OWNERS NAME %INTEGER TEMP SHAREFILE(OWNER.".".MASFILE) %IF JUMPFLAG=1 %THENRETURN DEFINE('4,'.OWNER.".".MASFILE) FILSTART=SMADDR(4,FLEN) TEMP=FINDFILE %IF JUMPFLAG=1 %THEN STACK(TEMP) %ANDRETURN %IF TEMP<0 %THENSTART FROTHDIR;%IF SW=86 %THEN RESTFILE %IF SW=85 %THEN NOFILE %AND GETMASTER ERROR('CANNOT FIND LIBRARY FILE ',EMPTY,1,IN) %RETURN %FINISH MDIND=TEMP %END; ! END GOTHDIR ! %ROUTINE CLAIMMASTER ! CLAIMS MASTER FILE FOR WRITE %INTEGER STAT STAT=STATUS(MASFILE,0) %IF STAT=0 %THEN PERMIT(MASWRITE) %ELSESTART %IF SW=75 %THEN NOFILE %IF SW=104 %OR SW=105 %THEN DEVICE=TTY %UNLESS CACTFILE=2 %THEN GETMASTER %IF STAT<0 %THEN ERROR('FINFO CALL FAILS - ',(-STAT)<<8!NM,1,IN) %C %ELSE ERROR('YOUR FILE IS IN USE BY ANOTHER - TRY AGAIN',EMPTY,1,IN) %RETURN %FINISH GETMASTER %END; ! END CLAIMMASTER ! %ROUTINE FILETIDY %STRING(10) SIZE %INTEGER TLEN, PAGE, TMDP, TTXTP, TINDEX, I, J, K %UNLESS CACTFILE=2 %THEN CLUSERFL CLAIMMASTER %IF JUMPFLAG=1 %THENRETURN MDMAP(FILSTART) %IF MDENTS=0 %THENSTART CLOSESM(4) PERMIT(MASREAD) %RETURN %FINISH TMDP=0; PAGE=0; TXTP=0; SIZE=NUMTOSTR(FLEN<<8) DEFINE('10,JUNK') NEWSMFILE('JUNK,'.SIZE) TSTART=SMADDR(10,TLEN) TMDMAP(TSTART) TENDMAP TENDTXT=0; TMDENTS=0; FT1:I=1 %WHILE I<=MDENTS %CYCLE %IF I=63 %THEN MDMAP(FILSTART+MDNEXT*4096) %AND ->FT1 %UNLESS UDNAM(I)='' %THENSTART TMDENTS=TMDENTS+1 %IF TMDENTS=63 %THENSTART PAGE=PAGE+1 TMDNEXT=PAGE; TMDP=PAGE TMDMAP(TSTART+PAGE*4096) TMDENTS=1 %FINISH TUDNAM(TMDENTS)=UDNAM(I) %IF CACTFILE=1 %THENSTART %IF UDNAM(I)=USERFILE %THEN MDP=TMDP %AND MDIND=TMDENTS %FINISH PAGE=PAGE+1;TUDPAGE(TMDENTS)=PAGE TUDMAP(TSTART+PAGE*4096) TUDENTS=0 UDMAP(FILSTART+UDPAGE(I)*4096) FT2:J=1 %WHILE J<=UDENTS %CYCLE %IF J=61 %THEN UDMAP(FILSTART+UDNEXT*4096) %AND->FT2 %UNLESS FUNNAM(J)='' %THENSTART TUDENTS=TUDENTS+1 %IF TUDENTS=61 %THENSTART PAGE=PAGE+1 TUDNEXT=PAGE TUDMAP(TSTART+PAGE*4096) TUDENTS=1 %FINISH TFUNNAM(TUDENTS)=FUNNAM(J) %IF TENDTXT=0 %OR SHORTINT(TENDIND(1))=4093 %THENSTART PAGE=PAGE+1; TTXTP=PAGE %UNLESS TENDTXT=0 %THEN TTXTNEXT=PAGE TTXTMAP(TSTART+PAGE*4096) TINDEX=0;TTXTNEXT=0 TENDTXT=PAGE; TENDIND(1)=0;TENDIND(2)=1 %FINISH %IF TXTP#TXTPAGE(J) %THEN GETTXTP(J) INDEX=SHORTINT(TXTIND(1,J)) FT3:%IF TINDEX=4092 %THENSTART PAGE=PAGE+1; TTXTNEXT=PAGE TTXTP=PAGE; SETSHORTINT(TTXTENTS(1),4092) TTXTMAP(TSTART+PAGE*4096) TINDEX=0;TTXTNEXT=0 %FINISH TINDEX=TINDEX+1 READIN SYM(K) TFNTXT(TINDEX)=K %IF K=TERMIN %THENSTART %IF INDEX<=SHORTINT(TXTENTS(1)) %OR TXTNEXT#0 %THENSTART %IF NEXTIN SYM # 'T' %THEN ->FT3 %FINISH %FINISHELSE ->FT3 TTXTPAGE(TUDENTS)=TENDTXT TTXTIND(1,TUDENTS)=TENDIND(1); TTXTIND(2,TUDENTS)=TENDIND(2) TENDTXT=TTXTP SETSHORTINT(TENDIND(1),TINDEX+1) SETSHORTINT(TTXTENTS(1),TINDEX) %FINISH J=J+1 %REPEAT %FINISH I=I+1 %REPEAT CLOSESM(4) CLEAR("4") DESTROY(MASFILE) %IF PAGE*4096+4096 < TLEN %THENSTART SIZE=NUMTOSTR((PAGE*4096+4096)<<8) DEFINE('4,'.MASFILE) NEWSMFILE(MASFILE.",".SIZE) FILSTART=SMADDR(4,FLEN) %CYCLE I=0,4096,FLEN-4096 J=FILSTART+I K=TSTART+I MOVE(4096,K,J) %REPEAT CLOSESM(10) DESTROY('JUNK') CLOSESM(4) %FINISHELSESTART CLOSESM(10) RENAME('JUNK,'.MASFILE) %FINISH CLEAR("10") CHERISH(MASFILE) PERMIT(MASREAD) PERMIT(MASFILE.',,R') %END; ! END FILETIDY ! %ROUTINE UPDIR(%INTEGER NAME) %INTEGER I UDP=UDPAGE(MDIND) UP1:UDMAP(FILSTART+UDP*4096) I=1 %IF UDENTS=0 %THEN ->UP2 %WHILE I<= UDENTS %CYCLE %IF I=61 %THEN UDP=UDNEXT %AND ->UP1 %IF WA(NAME>>8)=FUNNAM(I) %THENSTART TXTPAGE(I)=ENDTXT;TXTIND(1,I)=ENDIND(1);TXTIND(2,I)=ENDIND(2) SETSHORTINT(ENDIND(1),INDEX); ENDTXT=TXTP %RETURN %FINISH I=I+1 %REPEAT %IF UDENTS=60 %THEN GETPAGE(2) UP2:UDENTS=UDENTS+1 FUNNAM(UDENTS)=WA(NAME>>8) TXTPAGE(UDENTS)=ENDTXT TXTIND(1,UDENTS)=ENDIND(1);TXTIND(2,UDENTS)=ENDIND(2) SETSHORTINT(ENDIND(1),INDEX); ENDTXT=TXTP %END; ! END UPDIR ! %INTEGERFN FNENTS %INTEGER NO MDMAP(FILSTART+MDP*4096) ENDMAP GETUDP TXTP=0 NO=UDENTS %WHILE UDENTS=61 %THEN %CYCLE UDP=UDNEXT UDMAP(FILSTART+UDP*4096) NO=NO-1+UDENTS %REPEAT %RESULT=NO %END; !END FNENTS ! ! %ROUTINE CHLIB !CHECKS LIBRARY OWNER ARG1=UNSTACK ARG2=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 %THEN ERROR('LIBRARY NAME MUST BE A WORD - ',ARG2,1,IN) %END; !END CHLIB ! ! ! ! TURTLE DEVICE SERVICE ROUTINES ! %ROUTINESPEC TSEND(%INTEGER MOTORS,PULSES) %ROUTINESPEC TSEND1(%INTEGER ARG) %INTEGERFNSPEC TSCALE(%INTEGER N) %INTEGERFNSPEC TANGLE(%INTEGER N) ! %INTEGERFN INTREM(%INTEGER I,J) %RESULT=I-(I//J)*J %END; ! END INTREM ! %INTEGERFN MOD360(%INTEGER I) I=INTREM(I,360) %IF I<0 %THENRESULT=I+360 %ELSERESULT=I %END; ! END MOD360 ! %ROUTINE COORDOK(%INTEGER COORD) %STRING(80) ERRM %IF COORD<(-501) %OR COORD>501 %THENSTART ERRM='THE TURTLE WILL GO OFF THE EDGE OF THE ' %IF TDEV=3 %OR TDEV=8 %THEN ERRM=ERRM.'SCREEN' %ELSEC ERRM=ERRM.'PAPER' ERROR(ERRM,EMPTY,1,IN) %FINISH %END; ! END COORDOK ! %INTEGERFN TSTATE %RESULT=CONS(INTPT(XTURTLE)<<8!NM,CONS(INTPT(YTURTLE)<<8!NM,%C CONS(HDTURTLE<<8!NM,CONS(PENTURTLE,NIL)))) %END; ! END TSTATE ! %INTEGERFN IMPNUM(%INTEGER I) %IF I<0 %THENRESULT=I>>8!T8 %ELSERESULT=I>>8 %END; ! END IMPNUM ! %ROUTINE CIRCLETEST(%INTEGER FLAG,RAD,ANG) %SWITCH SW(0:1) COORDOK(INTPT(XTURTLE+DX));%IF JUMPFLAG=1 %THENRETURN COORDOK(INTPT(YTURTLE+DY));%IF JUMPFLAG=1 %THENRETURN %IF RAD<0 %THEN RAD=-RAD %IF ANG<0 %THEN ANG=-ANG ->SW(FLAG) SW(0):; ! LEFT %IF ANG>=MOD360(360-HDTURTLE) %THENSTART COORDOK((YC//32)+INTPT(YTURTLE)-RAD);%IF JUMPFLAG=1 %THENRETURN %FINISH %IF ANG>=MOD360(270-HDTURTLE) %THENSTART COORDOK((XC//32)+INTPT(XTURTLE)-RAD);%IF JUMPFLAG=1 %THENRETURN %FINISH %IF ANG>=MOD360(180-HDTURTLE) %THENSTART COORDOK((YC//32)+INTPT(YTURTLE)+RAD);%IF JUMPFLAG=1 %THENRETURN %FINISH %IF ANG>=MOD360(90-HDTURTLE) %THENSTART COORDOK((XC//32)+INTPT(XTURTLE)+RAD);%IF JUMPFLAG=1 %THENRETURN %FINISH %RETURN ! SW(1):; ! RIGHT %IF ANG>=HDTURTLE %THENSTART COORDOK((YC//32)+INTPT(YTURTLE)+RAD) %IF JUMPFLAG=1 %THENRETURN %FINISH %IF ANG>=MOD360(HDTURTLE+90) %THENSTART COORDOK((XC//32)+INTPT(XTURTLE)+RAD);%IF JUMPFLAG=1 %THENRETURN %FINISH %IF ANG>=MOD360(HDTURTLE+180) %THENSTART COORDOK((YC//32)+INTPT(YTURTLE)-RAD);%IF JUMPFLAG=1 %THENRETURN %FINISH %IF ANG>=MOD360(HDTURTLE+270) %THENSTART COORDOK((XC//32)+INTPT(XTURTLE)-RAD);%IF JUMPFLAG=1 %THENRETURN %FINISH %RETURN %END; ! END CIRCLETEST ! %INTEGERFN CHDEVARG %INTEGER ARG ARG=UNSTACK; %IF ARG&NM=0 %THENSTART ERROR(WA(FN>>8).' MUST HAVE A NUMBER AS INPUT - ',ARG,1,IN) %RESULT=UNSTACK %FINISH W1=ARG %RESULT=IMPNUM(ARG) %END; ! END CHDEVARG ! %ROUTINE SETUP(%INTEGER N,A) %INTEGER H %IF N=0 %THENRETURN H=0 %IF A>180 %THEN A=A-360 %IF PENTURTLE=DOWN %THENSTART PENTURTLE=UP TSEND1(32) H=1 %FINISH %IF A#0 %THENSTART %IF A<0 %THEN TSEND(LTBITS,TANGLE(-A)) %ELSE TSEND(RTBITS,TANGLE(A)) %IF JUMPFLAG=1 %THENRETURN ! RIGHT (A) %FINISH %IF N<0 %THEN TSEND(BDBITS,TSCALE(-N)) %ELSE TSEND(FDBITS,TSCALE(N)) %IF JUMPFLAG=1 %THENRETURN ! FORWARD(N) %IF A#0 %THENSTART %IF A<0 %THEN TSEND(RTBITS,TANGLE(-A)) %ELSE TSEND(LTBITS,TANGLE(A)) %IF JUMPFLAG=1 %THENRETURN ! LEFT(A) %FINISH %IF H=1 %THENSTART PENTURTLE=DOWN TSEND1(32) %FINISH %END; ! END SETUP ! %ROUTINE TSEND1(%INTEGER ARG) %IF ARG=0 %THENRETURN %IF PENTURTLE=UP %THEN BINARG(1,ARG+PENBIT) %ELSE BINARG(1,ARG) ! JAM TRANSFER ONLY REQUIREDD FOR HOOTBIT SENDBIN(0,1) %END; ! END TSEND1 ! %ROUTINE TSEND(%INTEGER MOTORS,PULSES) %WHILE PULSES>1500 %CYCLE; ! 500 MOVE UNITS OR 375 ROTATE UNITS %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 CLESET; ! THIS IS THE POINT OF IT. TO BREAK A CLOG IN H316 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;CLESET ERROR('USER INTERRUPT - TURTLE DEVICE RESET',EMPTY,1,IN) %RETURN %FINISH TSEND1(MOTORS+1500) PULSES=PULSES-1500 %REPEAT TSEND1(MOTORS+PULSES) %END; ! END TSEND ! %ROUTINE PINDSEND(%INTEGER DIRECTION,ANGLE) ! SENDS FOR PLOTTER INDICATOR BINARG(1,5) %WHILE ANGLE>360 %CYCLE %IF QUITFLAG=1 %THENSTART; ! AS FOR TSEND QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 CLESET STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;CLESET ERROR('USER INTERRUPT - TURTLE DEVICE RESET',EMPTY,1,IN) %RETURN %FINISH BINARG(2,360+DIRECTION) SENDBIN(0,2) ANGLE=ANGLE-360 %REPEAT BINARG(2,ANGLE+DIRECTION) SENDBIN(0,2) %END; ! END PINDSEND ! %INTEGERFN TSCALE(%INTEGER M) ! FOR 75 MM WHEEEL, ONE PULSE GIVES 0.06814 CM TRAVEL ! WITH GEAR RATIO 5:36 AT 48 PULSES TO ONE REV %RESULT=M*3 %END; ! END TSCALE ! %INTEGERFN TANGLE(%INTEGER A) ! TRACK 312.5 MM, WHEEL 75 MM DIA, RATIO 5:36, ! THUS 4 PULSES TO ONE DEGREE TURN %RESULT=4*A %END; ! END TANGLE ! %ROUTINE GTARCLEFT(%INTEGER R,A) %INTEGER P,Q,N,TH,C,D,E %REAL RV1,B, DX,DY ! %ROUTINE ARCAUX(%INTEGER M,A) %IF A=0 %THENRETURN %IF M=0 %THENSTART HDTURTLE=HDTURTLE-A %FINISHELSESTART HDTURTLE=HDTURTLE+A %FINISH CALC TURTLE %END; ! END ARCAUX ! C=-1;D=0;TH=2 %IF A<0 %THENSTART HDTURTLE=MOD360(HDTURTLE-180) CALC TURTLE R=-R;A=-A %FINISH %IF R<0 %THENSTART C=0;D=-1;R=-R %FINISH LOOP:RV1=2.0*R*SIN(TH*3.14159/1440.0) N=INT(RV1) %IF A>(TH+1) %AND R>N %AND (N<1 %ORC (N-RV1)>0.1 %OR (N-RV1)<(-0.1)) %THENSTART TH=TH+1 ->LOOP %FINISH P=A//TH Q=INTREM(A,TH) E=INTPT(TH/2.0) ARCAUX(C,E) %WHILE P#0 %OR Q#0 %CYCLE B=HDTURTLE*3.14159/180.0 DX=N*COS(B) DY=N*SIN(B) VECTOR(DX,DY) XTURTLE=XTURTLE+DX YTURTLE=YTURTLE+DY ARCAUX(C,TH) P=P-1 %IF P=0 %AND Q#0 %THENSTART N=INT(2.0*R*SIN(Q*3.14159/1440.0)) TH=Q P=1 Q=0 %FINISH %REPEAT ARCAUX(D,E) %END; ! END TARCLEFT ! %ROUTINE TARCLEFT(%INTEGER R,A) %INTEGER P,Q,N,TH,C,D,E,TTTXCOR,TTTYCOR,TTHEAD %REAL RV1,B ! %ROUTINE ARCAUX(%INTEGER M,A) %IF A=0 %THENRETURN %IF M=0 %THENSTART TSEND(RTBITS,A) %IF JUMPFLAG=1 %THENRETURN TTHEAD=TTHEAD-A %FINISHELSESTART TSEND(LTBITS,A) %IF JUMPFLAG=1 %THENRETURN TTHEAD=TTHEAD+A %FINISH %END; ! END ARCAUX ! R=3*R;TTTXCOR=3*INTPT(XTURTLE);TTTYCOR=3*INTPT(YTURTLE); A=4*A;C=-1;D=0;TH=2 %IF A<0 %THENSTART HDTURTLE=MOD360(HDTURTLE-180) TSEND(RTBITS,720); ! RIGHT(180) %IF JUMPFLAG=1 %THENRETURN R=-R;A=-A %FINISH TTHEAD=4*HDTURTLE %IF R<0 %THENSTART C=0;D=-1;R=-R %FINISH LOOP:RV1=2.0*R*SIN(TH*3.14159/1440.0) N=INT(RV1) %IF A>(TH+1) %AND R>N %AND (N<1 %ORC (N-RV1)>0.1 %OR (N-RV1)<(-0.1)) %THENSTART TH=TH+1 ->LOOP %FINISH P=A//TH Q=INTREM(A,TH) E=INTPT(TH/2.0) ARCAUX(C,E) %IF JUMPFLAG=1 %THENRETURN %WHILE P#0 %OR Q#0 %CYCLE B=TTHEAD*3.14159/720.0 TTTXCOR=TTTXCOR+INT(N*COS(B)) TTTYCOR=TTTYCOR+INT(N*SIN(B)) TSEND(FDBITS,N) %IF JUMPFLAG=1 %THENRETURN ARCAUX(C,TH) %IF JUMPFLAG=1 %THENRETURN P=P-1 %IF P=0 %AND Q#0 %THENSTART N=INT(2.0*R*SIN(Q*3.14159/1440.0)) TH=Q P=1 Q=0 %FINISH %REPEAT ARCAUX(D,E) %IF JUMPFLAG=1 %THENRETURN XTURTLE=TTTXCOR/3.0 YTURTLE=TTTYCOR/3.0 HDTURTLE=MOD360(INT(TTHEAD/4.0)) %END; ! END TARCLEFT ! %ROUTINE CLAIMDEVICE(%INTEGER N) %RECORD R(RF) %INTEGER FLAG %IF TDEV#0 %THENSTART; ! ALREADY GOR A DEVICE %IF TDEV=N %THEN ERROR('YOU ALREADY HAVE IT',EMPTY,1,IN) %ELSEC ERROR('YOU CAN ONLY BE CONNECTED TO ONE DEVICE',EMPTY,1,IN) %RETURN %FINISH ! SO NOT GOT A DEVICE CONNECT(MASNUM.TDEVNAMES(N),2,0,0,R,FLAG) ! CONNECT WRITE, NO SHARING - SO WE GOT IT ALONE %IF FLAG#0 %THENC ERROR('DEVICE '.TDEVNAMES(N).' IS ALREADY CONNECTED ELSEWHERE',%C EMPTY,1,IN) %ANDRETURN ! FLAG#0 INDICATES CONNECTING NOT POSSIBLE, I.E. DEVICE IN USE ! ! SO NOW GOT DEVICE TDEV=N PRSTRING(TDEVNAMES(N).' CONNECTED');NOOLINE(1) %END; ! END CLAIMDEVOCE ! %ROUTINE FREEDEVICE ! ONLY IF TDEV#0 CLESET %UNLESS TDEV=8 ; ! CLEAR AND RESET HONEY AS APROPRIATE DISCONNECT(MASNUM.TDEVNAMES(TDEV)) TDEV=0 %END; ! END FREEDEVICE ! %ROUTINE GCOMPILE (%REAL X,Y, %INTEGER MODE) !COMPILES A VECTOR DEFINITION INTO GT42 CODE %EXTRINSIC %INTEGER %ARRAY MODE TABLE (0:2) ! %INTEGER PENV %IF PENTURTLE=DOWN %THEN PENV=PEN %ELSE PENV=0 %IF MODE # GMODE %THEN %C CURPIC= CONSG(MODETABLE(MODE),CURPIC) %AND GMODE=MODE CURPIC=CONSG((CONV(INT(Y))),CONSG(PENV!(CONV(INT(X))),CURPIC)) %END ! %INTEGERFN GETNUMB (%INTEGERNAME LIST,%STRING(64) FUNC) ! ! POPS A NUMBER FROM THE HEAD OF LIST, REPLACING LIST BY ! TAIL OF LIST. FUNC IS ONLY USED IF LIST IS EMPTY (=NIL) ! WHEN AN ERROR DIAGNOSTIC IS OUTPUT ! %INTEGER W1 %IF LIST=NIL %THEN ERROR (FUNC.' NEEDS A LONGER LIST ',ARG2,1,IN) %C %AND %RESULT=-100000; ! CHECK THAT LIST NON-EMPTY W1 = HD(LIST) LIST=TL(LIST) %IF W1&NM #NM %THEN ERROR (FUNC.' NEEDS A NUMBER ',W1,1,IN) %C %AND %RESULT=-100000; !CHECK THAT YOU HAVE A NUMBER %RESULT = W1 >> 8; !AND RETURN ITS VALUE %END %INTEGERFN CHECKXY (%INTEGER N) ! ! CHECKS THAT GIVEN COORDINATE IS WITHIN THE SCREEN ! BOUNDARY (-512 -> 512) ! %WHILE N > 512 %THEN N=N-1024 %WHILE N < -512 %THEN N=N+1024 %RESULT=N %END; ! ! %ROUTINE VECTOR (%REAL X,Y) %INTEGER T %IF DEFPICTURE = 1 %THEN GCOMPILE(X,Y,VECTORM) %ANDRETURN %IF PENTURTLE=DOWN %AND SHOW TURTLE 42 = 1 %THENSTART T = INT PT(SQRT(X**2 + Y**2)/5) %IF T=0 %THEN T=1 ;! ZERO TIME WILL BUGGER EXEK SET42(CHPIC) ;! SET 42 TO PICTURE MODE MODE42(VECTORM) CH3(GRADV) ;!AND SEND A GRADUAL VECTOR CH3(T) ;! DURATION CH3(INT(X)) CH3(INT(Y)) GRAPHP=GRAPHP+4 %RETURN %FINISH %IF PENTURTLE = DOWN %THEN VECORPOINT(INT(X),INT(Y),PEN,VECTORM) %C %ELSE VECORPOINT(INT(X),INT(Y),0,VECTORM) %END ! ! %ROUTINE POINT (%REAL ATX,ATY) ! SENDS A DARK POINT INSTRUCTION TO DISPLAY ! ! ONLY USED FROM SETX SETY SETTURTLE AND INITIALISATION ! ! %INTEGER SAVE GP %IF DEF PICTURE = 1 %THEN GCOMPILE(ATX,ATY,POINTM) SAVE GP = GRAPHP VECORPOINT(INT(ATX),INT(ATY),0,POINTM) GRAPHP = SAVE GP %END ! ! %ROUTINE MODIFY EXEC ! !*** 'HACK' DP1 EXEC FOR LOGO USE !*** TO GIVE IMPROVED STATIC/DYNAMIC PICTURE !*** CAPABILITIES ! %CONSTINTEGERARRAY NEW HEADER (1:15)= %C X'E000', X'3FF0', X'F700' ,X'0000', %C X'2028', X'2028', X'8F5C', X'404A', %C X'4F8A', X'6F8A', X'404A', X'E000', %C X'2012', X'E000', X'201A' %CONSTINTEGERARRAY NEW TAIL (1:5) = %C X'9354', 512, 512, X'E000', X'2028' %CONSTINTEGER REF1=X'1016' %CONSTINTEGER REF2=X'145E' %CONSTINTEGER STADDR= X'200E' %INTEGER I ! SET42(CHPIC) GRAPHP = INIT GRAPHP LBR CH3(SETN) CH3(STADDR) CH3(15) %CYCLE I=1,1,15 CH3(NEW HEADER(I)) %REPEAT CH3(SETN) CH3(CORE BOTTOM) CH3(5) %CYCLE I=1,1,5 CH3(NEW TAIL(I)) %REPEAT CH3(SET) CH3(REF1) CH3(TURTLE START) ;!**IMPORTANT** MOD TO 'CLEAR' ;! INSTR IN GT42 EXEC CH3(SET) CH3(REF2) CH3(TURTLE START) RBR %END ! ! %ROUTINE CALC TURTLE %INTEGER I ! ! THIS ROUTINE SENDS A VECTOR DESCRIPTION OF THE ! TURTLE TO THE GT42 - ASSUMING THAT THE TURTLE ! IS CURRENTLY BEING SHOWN ! %INTEGERFN VEC (%INTEGER DX,DY) !CONVERTS DX,DY INTO A GT42 SHORT VECTOR ! %IF DX<0 %THEN DX=X'40'+((0-DX)&X'3F') %ELSEC DX= DX&X'3F' %IF DY<0 %THEN DY=X'40'+((0-DY)&X'3F') %ELSEC DY=DY&X'3F' %RESULT = X'4000'!(DX<<7)!DY %END %CONSTINTEGERARRAY X(1:4)= 0,31, -31, 0 %CONSTINTEGERARRAY Y(1:4)= -10,10,10,-10 !*** FUNCTIONS TO CALCULATE NEW X AND Y DISPLACEMENTS *** !*** (DONE LIKE THIS FOR EASE OF MODIFICATION ) *** %INTEGERFN NEWX %RESULT=INT(X(I)*COS(HDTURTLE/57.3)-SIN(HDTURTLE/57.3) %C *Y(I)) %END %INTEGERFN NEWY %RESULT= INT(Y(I)*COS(HDTURTLE/57.3)+X(I)*SIN %C (HDTURTLE/57.3)) %END %CONSTINTEGER TURTLE MODE=X'8F5C' %RETURN %IF SHOW TURTLE 42 = 0 %RETURN %IF DEF PICTURE = 1 ;! DON'T BOTHER WITH TURTLE IN DEF MODE SET42(CHPIC) LBR;CH3(SETN);CH3(TURTLE START);CH3(5) CH3(TURTLE MODE) ;! SEND DESCRIPTION %CYCLE I=1,1,4 CH3(VEC(NEWX,NEWY)) %REPEAT RBR %RETURN ! !OTHERWISE PART OF PICTURE DEFINITION ! SO IGNORE THE BLOODY THING ! %END %ROUTINE SHOW TURTLE SHOW TURTLE 42 = 1 CALC TURTLE %END %ROUTINE HIDE TURTLE ! ! *** SENDS CODE TO THE GT42 TO PREVENT TURTLE BEING DRAWN ! *** (ACTUALLY DUMPS A DJMP INST{UCTION ROUND THE TURTLE BLOCK) ! SET42(CHPIC) ;! SET GRAPHICS MODE LBR CH3(SETN) ; CH3(TURTLE START) ; CH3(2) CH3(DJUMP) ;! JUMP INSTRUCTION CH3(DLAST) ;! TO END OF DISPLAY FILE RBR SHOW TURTLE 42 = 0 %END ! %ROUTINE SET CORE POINTER (%INTEGER TO VAL) ! USED TO ASSIGN TO END OF CORE POINTER IN GT42 ! ! ALSO UPDATES EMAS LOCAL VARIABLE PICTURE POINTER ! %CONSTINTEGER CORE POINTER= X'2010' ;! ADDRESS IN GT42 ! PICTURE POINTER = TO VAL ;! UPDATE EMAS POINTER SET42(CHPIC) CH3(SET) ;! AND GT42 POINTER CH3(CORE POINTER) CH3(PICTURE POINTER) ;! NEW VALUE %END %ROUTINE INC (%INTEGER W1) ! *** ROUTINE TO SEND A PICTURE DEFINITION ! *** TO THE GT42 -- CALLED FROM 'INCLUDE' AND 'PUT' ! %INTEGER W2,W3 SET42(CHPIC) ;! SET GT42 MODE W2=LISTLEN(INDEX42(W1)_PTR) ;! LENGTH OF PICTURE INDEX42(W1)_FADDR = PICTURE POINTER PICTURE POINTER = PICTURE POINTER - W2 -W2 -2 LBR; CH3(SETN); CH3(PICTURE POINTER); CH3(W2) ;! HEADER !! W3=CONSG(DJUMP,CONSG(INDEX42(W1)_FADDR, %C TL(TL(INDEX42(W1)_PTR)))) %UNTIL W3=NIL %THEN CH3(HD(W3)>>8) %AND W3=TL(W3) RBR ;! DELIMITER INDEX42(W1)_PTR42=PICTURE POINTER;! START ADDR IN 42 SET CORE POINTER (PICTURE POINTER) %IF PICTURE POINTER < GRAPHP %THEN ERROR ( %C 'GT42 DISPLAY FILE CORRUPTED :- TOO MUCH DISPLAY DATA',EMPTY,1,IN) %AND %RETURN %END ! ! ! ! INFERENCE SERVICE ROUTINES ! %ROUTINE SAYL(%STRING(20) MESS, %INTEGER RULE,INDENT) ! PRINTS MESS INDENTED INDENT SPACES %IF GETVAL(THINKALOUD,ENVIR)=TRUE %THENSTART PRINTSTRING("*");SPACES(INDENT);CHAROUT=CHAROUT+1+INDENT; PRSTRING(MESS);PRINTEL(RULE) NOOLINE(1) %FINISH %END; ! END SAYL ! %INTEGERFN FITSQ(%INTEGER FACT,PAT) ! MATCHES FACT AGAINST PAT. ! FACT AND PAT ARE ASSUMED TO BE SIMPLE PATTERNS. ! (FACT WILL HAVE HAD COLON VARIABLES ASSIGNED ALREADY.) %INTEGER VAL %IF FACT=NIL %THENSTART %IF PAT=NIL %THEN %RESULT=TRUE %RESULT=FALSE %FINISH %IF PAT=NIL %THEN %RESULT=FALSE ! (NEXT LINE INCORRECT IF FACT ALLOWED TO CONTAIN QUOTED VARIABLES.) %IF HD(PAT)=QUOTE %THEN SETVAL(HD(TL(PAT)),HD(FACT),ENVIR) %C %ELSESTART %IF HD(PAT)=DOTS %THENSTART VAL=GETVAL(HD(TL(PAT)),ENVIR) %IF VAL =UNDEF %THENSTART ERROR('NO VALUE HAS BEEN GIVEN TO VARIABLE -',%C HD(TL(PAT)),1,IN) %RESULT=UNSTACK %FINISH %IF VAL#HD(FACT) %THEN %RESULT=FALSE %FINISHELSESTART %IF HD(PAT)#HD(FACT) %THEN %RESULT=FALSE %RESULT=FITSQ(TL(FACT),TL(PAT)) %FINISH %FINISH %RESULT=FITSQ(TL(FACT),TL(TL(PAT))) %END; ! END FITSQ ! %ROUTINE SETVBLS(%INTEGER VBLS) ! VBLS IS A LIST OF QUOTED VARIABLES. EACH VARIABLE IS SET TO NIL, ! EITHER GLOBALLY OR LOCALLY. %INTEGER I,L VBLS=HD(TL(VBLS));L=LISTLEN(VBLS) %IF ENVIR=BASENVIR %THENSTART %CYCLE I=1,1,L SETVAL(HD(VBLS),NIL,ENVIR) VBLS=TL(VBLS) %REPEAT %FINISHELSESTART %CYCLE I=1,1,L STACK(NIL) %REPEAT ENVIR=SETBIND(VBLS,ENVIR) %FINISH %END; ! END SETVBLS ! %ROUTINE TRYIMPRULE(%INTEGER RULE,FACT,KEYED,INDENT) ! MATCHES IMPLIED RULE AGAINST FACT. ! KEYED IS TRUE IF RULE STARTS WITH AKEYWORD, FALSE IF IT STARTS WITH ! A QUOTED WORD. IF MATCH IS FOUND, ADDS IMPLIED FACT. %INTEGER VBLS,PRED VBLS=HD(RULE);RULE=TL(RULE) %IF VBLS#NIL %THEN SETVBLS(VBLS) %IF KEYED=TRUE %THEN PRED=FITSQ(TL(FACT),TL(HD(RULE))) %C %ELSE PRED=FITSQ(FACT,HD(RULE)) %IF JUMPFLAG=1 %THEN STACK(PRED) %ANDRETURN %IF PRED=TRUE %THENSTART SAYL('USING RULE ',CONS(IMPLIES,RULE),INDENT) ADDFACT(HD(TL(RULE)),INDENT+3) %FINISH %END; ! END TRYIMPRULE ! %INTEGERFN VBLSIN(%INTEGER TERMS) ! LOOKS FOR QUOTED VARIABLES IN IMPLY/TOINFER RULE, TERMS, AND PUTS ! THEM INTO A LIST CONSED ON TO 'NEW'. E.G. [NEW [X Y]] ! CHECKS THAT CONSEQUENT OF TOINFER RULE DOESN'T CONTAIN A DOTTED ! VARIABLE AND THAT AN IMPLY RULE ONLY HAS ONE CONSEQUENT. %INTEGER TERM,VBLS, RULE, FIRST VBLS=NIL; RULE=HD(TERMS); TERMS=TL(TERMS) FIRST=TRUE %WHILE TERMS#NIL %CYCLE TERM=HD(TERMS) %IF TERM&LM#LM %OR TERM=NIL %THEN ->VBLERR %IF HD(TERM)&LM=LM %THEN ->VBLERR %WHILE TERM#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0 %RESULT=QUIT %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(TERM);STKSYS(TERMS);STKSYS(VBLS) ERROR('USER INTERRUPT',EMPTY,0,IN) VBLS=UNSTKSYS;TERMS=UNSTKSYS;TERM=UNSTKSYS %IF JUMPFLAG=1 %THEN %RESULT=UNSTACK %FINISH %IF HD(TERM)=QUOTE %THENSTART TERM=TL(TERM) %IF TERM=NIL %OR HD(TERM)&WM#WM %THEN ->VBLERR VBLS=CONS(HD(TERM),VBLS) %FINISHELSESTART %IF HD(TERM)=DOTS %THENSTART %IF RULE=TOINFER %AND FIRST=TRUE %THEN ->VBLERR TERM=TL(TERM) %IF TERM=NIL %OR HD(TERM)&WM#WM %THEN ->VBLERR %FINISH %FINISH TERM=TL(TERM) %REPEAT TERMS=TL(TERMS) %IF FIRST=FALSE %THENSTART %IF TERMS#NIL %AND RULE=IMPLIES %THEN->VBLERR %FINISHELSE FIRST=FALSE %REPEAT %IF VBLS#NIL %THEN VBLS=CONS(NEW,CONS(VBLS,NIL)) %RESULT=VBLS VBLERR:ERROR('INVALID PATTERN FOR IMPLIES/TOINFER RULE -',TERMS,1,IN) %RESULT=UNSTACK %END; ! END VBLSIN ! %INTEGERFN INSTANCE(%INTEGER ITEM) ! ITEM IS A (SIMPLE?) PATTERN. ! IF IT IS SIMPLE,CHECKS THAT IT IS IN CORRECT FROM AND ASSIGNS ! CURRENT VALUES TO COLON VARIABLES. %INTEGER VAL %IF ITEM=NIL %THEN %RESULT=NIL %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0 %RESULT=QUIT %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(ITEM) ERROR('USER INTERRUPT',EMPTY,0,IN) ITEM=UNSTKSYS %IF JUMPFLAG=1 %THEN %RESULT=UNSTACK %FINISH VAL=HD(ITEM) %IF VAL=DOTS %THENSTART ITEM=TL(ITEM) %IF ITEM=NIL %OR HD(ITEM)&WM#WM %THEN ->INSTERR VAL=GETVAL(HD(ITEM),ENVIR) %IF VAL=UNDEF %THEN %C ERROR('NO VALUE HAS BEEN GIVEN TO VARIABLE - ',HD(ITEM),1,IN) %C %AND %RESULT=UNSTACK %FINISHELSESTART %IF VAL=QUOTE %THENSTART %IF TL(ITEM)=NIL %OR HD(TL(ITEM))&WM#WM %THEN ->INSTERR %FINISH %FINISH %RESULT=CONS(VAL,INSTANCE(TL(ITEM))) INSTERR:ERROR('INVALID PATTERN FOR FACT -',ITEM,1,IN) %RESULT=UNSTACK %END; ! END INSTANCE ! %ROUTINE ADDLINK(%INTEGER ITEM,KEY, %INTEGERARRAYNAME LINKS) ! ADDS PATTERN, ITEM, TO ONE OF DATABASE,IMPRULES OR INFRULES ! ACCORDING TO VALUE OF LINKS. SETS UP WORD, KEY, AS AN ! ASSOCIATION SET, IF IT DOES NOT ALREADY EXIST, ADDING KEY TO ONE OF ! FACTKEYS, IMPKEYS, INFKEYS, AND ADDS ITEM TO THE ASSOCIATION SET. %INTEGER VAL,IND %IF KEY&WM#WM %THENSTART %IF LINKS(2)#FACT %THEN ITEM=CONS(LINKS(2),TL(ITEM)) ERROR('INVALID PATTERN FOR ASSERT - ',ITEM,1,IN) %RETURN %FINISH BVALUE(LINKS(1)>>8)=CONS(ITEM,BVALUE(LINKS(1)>>8)) IND=KEY>>8 VAL=FINDASS(ASSOCWA(IND),LINKS(2)) %IF VAL#NIL %THENSTART VAL=TL(HD(VAL)) REPHEAD(VAL,CONS(ITEM,HD(VAL))) %FINISHELSESTART BVALUE(LINKS(3)>>8)=CONS(KEY,BVALUE(LINKS(3)>>8)) ASSOCWA(IND)=CONS(CONS(LINKS(2),CONS(CONS(ITEM,NIL),NIL)), %C ASSOCWA(IND)) %FINISH %END; ! END ADDLINK ! %ROUTINE ADDRULE(%INTEGER RULE,INDENT,%INTEGERARRAYNAME LINKS) ! REPLACES HEAD OF RULE WITH A LIST OF THE QUOTED VARIABLES IN THE RULE ! OF THE FORM [NEW [X Y]]. ADDS THE RULE TO IMPRULES/INFRULES. %INTEGER VBLS %IF TL(RULE)=NIL %THENSTART ERROR('INVALID PATTERN FOR IMPLIES/TOINFER RULE -',TL(RULE),1,IN) %RETURN %FINISH STKSYS(RULE) VBLS=VBLSIN(RULE) RULE=UNSTKSYS %IF JUMPFLAG=1 %THEN STACK(VBLS) %ANDRETURN VBLS=CONS(VBLS,TL(RULE)) ADDLINK(VBLS,HD(HD(TL(RULE))),LINKS) %IF JUMPFLAG=1 %THENRETURN SAYL('ADDED RULE ',RULE,INDENT) %END; ! END ADDRULE ! %ROUTINE ADDFACT(%INTEGER FACT,INDENT) ! ADDS A FACT TO DATABASE.(NO CHECK MADE FOR FACT CONTAINING QUOTED ! VARIABLES.) CHECKS IF KEYWORD POINTS TO ANY IMPLIED RULES, I.E. IF ! THE ASSOCIATION SET, KEY, HAS ANY VALUES WITH ATTRIBUTE 'IMPLIES', ! AND, IF THEY MATCH FACT, ADDS THE IMPLIED FACT. ! SIMILARLY, CHECKS IF FACT MATCHES ANY IMPLIED RULES WHOSE KEY WORD IS ! NOT FIRST, BY LOOKING AT THE ASSOCIATION SET FOR 'QUOTE', AND ADDS ! ANY MATCHING IMPLIED FACT. %INTEGER KEY,VAL FACT=INSTANCE(FACT) %IF JUMPFLAG=1 %THEN STACK(FACT) %ANDRETURN KEY=HD(FACT) ADDLINK(FACT,KEY,DBASE) %IF JUMPFLAG=1 %THENRETURN SAYL('ADDED FACT ',FACT,INDENT) VAL=FINDASS(ASSOCWA(KEY>>8),IMPLIES) %IF VAL#NIL %THENSTART VAL=HD(TL(HD(VAL))) %WHILE VAL#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(VAL);STKSYS(FACT) ERROR('USER INTERRUPT',EMPTY,0,IN) FACT=UNSTKSYS;VAL=UNSTKSYS %IF JUMPFLAG=1 %THEN %RETURN %FINISH STKSYS(VAL);STKSYS(FACT) TRYIMPRULE(HD(VAL),FACT,TRUE,INDENT) FACT=UNSTKSYS;VAL=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN VAL=TL(VAL) %REPEAT %FINISH VAL=FINDASS(ASSOCWA(QUOTE>>8),IMPLIES) %IF VAL#NIL %THENSTART VAL=HD(TL(HD(VAL))) %WHILE VAL#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(VAL);STKSYS(FACT) ERROR('USER INTERRUPT',EMPTY,0,IN) FACT=UNSTKSYS;VAL=UNSTKSYS %IF JUMPFLAG=1 %THEN %RETURN %FINISH STKSYS(VAL);STKSYS(FACT) TRYIMPRULE(HD(VAL),FACT,FALSE,INDENT) FACT=UNSTKSYS;VAL=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN VAL=TL(VAL) %REPEAT %FINISH %END; ! END ADDFACT ! %INTEGERFN TRYBEST(%INTEGERARRAYNAME LINKS,%INTEGERNAME EPAT,KEYED,%C %INTEGER IPAT) ! IPAT IS A PATTERN (SHOULD BE SIMPLE). ! IF ITS HEAD IS A QUOTED VARIABLE, RETURNS ONE OF DATABASE, IMPRULES ! OR INFRULES, DEPNEDING ON VALUE OF LINKS, AND SETS KEYED TO FALSE, ! EPAT TO IPAT. OTHERWISE, RETURNS THE ASSOCIATION SET FOR HD(IPAT) ! WITH ATTRIBUTE FACT, IMPLIES OR TOINFER AND SETS KEYED TO TRUE, ! EPAT TO TL(IPAT). %INTEGER IT %IF HD(IPAT)=QUOTE %THENSTART EPAT=IPAT;KEYED=FALSE %RESULT=BVALUE(LINKS(1)>>8) %FINISH KEYED=TRUE %IF HD(IPAT)=DOTS %THENSTART EPAT=TL(TL(IPAT)) IT=GETVAL(HD(TL(IPAT)),ENVIR) %IF IT=UNDEF %THENSTART ERROR('NO VALUE HAS BEEN GIVEN TO VARIABLE - ',HD(TL(IPAT)),1,IN) %RESULT=UNSTACK %FINISH %FINISHELSESTART EPAT=TL(IPAT);IT=HD(IPAT) %FINISH %IF IT&WM#WM %THENSTART ERROR('INVALID PATTERN - ',IPAT,1,IN) %RESULT=UNSTACK %FINISH IT=FINDASS(ASSOCWA(IT>>8),LINKS(2)) %IF IT#NIL %THEN %RESULT=HD(TL(HD(IT))) %RESULT=NIL %END; ! END TRYBEST ! %INTEGERFN INFINSTANCE(%INTEGER TERM) ! TERM IS AN ANTECEDENT OF A TOINFER RULE. ! RETURNS TERM WITH COLON VARIABLES REPLACED BY THEIR CURRENT ! VALUES (THIS MAY BE A QUOTED VARIABLE OR ANOTHER COLON VARIABLE) ! AND QUOTED VARIABLES ASSIGNED TO LOCAL COLON VARIABLES AND REPLACED ! BY LOCAL QUOTED VARIABLES. (SO THEY DO NOT CLASH WITH QUOTED ! VARIABLES OF ORIGINAL PATTERN WHICH WAS MATCHED AGAINST CONSEQUENT OF ! THIS TOINFER RULE.) %INTEGER VF,IT %STRING(10) STR1,STR2 %IF TERM=NIL %THEN %RESULT=NIL %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0 %RESULT=QUIT %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(TERM);STKSYS(ARG1);STKSYS(ARG3) ERROR('USER INTERRUPT',EMPTY,0,IN) ARG3=UNSTKSYS;ARG1=UNSTKSYS;TERM=UNSTKSYS %IF JUMPFLAG=1 %THEN %RESULT=UNSTACK %FINISH %IF HD(TERM)=DOTS %THENSTART VF=GETVAL(HD(TL(TERM)),ENVIR) %IF VF=UNDEF %THENSTART ERROR('NO VALUE HAS BEEN GIVEN TO VARIABLE - ',HD(TL(TERM)),1,IN) %RESULT=UNSTACK %FINISH %IF VF&LM#LM %OR VF=NIL %THEN %C %RESULT=CONS(VF,INFINSTANCE(TL(TL(TERM)))) %IF HD(VF)=QUOTE %THENSTART REPHEAD(VF,DOTS) %RESULT=CONS(QUOTE,CONS(HD(TL(VF)),INFINSTANCE(TL(TL(TERM))))) %FINISH %IF HD(VF)#DOTS %THEN %RESULT=CONS(VF,INFINSTANCE(TL(TL(TERM)))) %RESULT=CONS(DOTS,CONS(HD(TL(VF)),INFINSTANCE(TL(TL(TERM))))) %FINISH %IF HD(TERM)#QUOTE %THEN %RESULT=CONS(HD(TERM),INFINSTANCE(TL(TERM))) GENOS=GENOS+1 STR1=WA(VBL>>8) STR2=NUMTOSTR(GENOS<<8) IT=PUT(STR1.STR2) SETVAL(HD(TL(TERM)),CONS(DOTS,CONS(IT,NIL)),ENVIR) %RESULT=CONS(QUOTE,CONS(IT,INFINSTANCE(TL(TL(TERM))))) %END; ! END INFINSTANCE ! %INTEGERFN INFFITSQ(%INTEGER PAT,RPAT) ! MATCHES PATTERN, PAT, AGAINST CONSEQUENT OF TOINFER RULE, RPAT. ! SETS QUOTED VARIABLES IN RPAT TO CORRESPONDING VALUE IN PAT ! (THIS MAY ALSO BE A QUOTED VARIABLE). SETS ANY OTHER QUOTED ! VARIABLES IN PAT TO CORRESPONDING VALUE IN RPAT. %INTEGER P1,RP1 !????; PRINTSTRING("ENTERED INFFITSQ ");NEWLINE INFF1: !????; PRINTSTRING("PAT=");PRINTDIAGLIST(PAT) %UNLESS PAT=0 !????; NEWLINE !????; PRINTSTRING("RPAT=");PRINTDIAGLIST(RPAT) %UNLESS RPAT=0 !????; NEWLINE %IF PAT=NIL %THENSTART %IF RPAT=NIL %THEN %RESULT=TRUE %RESULT=FALSE %FINISH %IF RPAT=NIL %THEN %RESULT=FALSE P1=HD(PAT);PAT=TL(PAT) RP1=HD(RPAT);RPAT=TL(RPAT) %IF P1=DOTS %THENSTART P1=GETVAL(HD(PAT),ENVIR) %IF P1=UNDEF %THENSTART ERROR('NO VALUE HAS BEEN GIVEN TO VARIABLE - ',HD(PAT),1,IN) %RESULT=UNSTACK %FINISH PAT=TL(PAT) %FINISHELSESTART %IF P1=QUOTE %THENSTART P1=HD(PAT);PAT=TL(PAT) %IF RP1=QUOTE %THENSTART SETVAL(HD(RPAT),CONS(QUOTE,CONS(P1,NIL)),ENVIR) RPAT=TL(RPAT) %FINISHELSE SETVAL(P1,RP1,ENVIR) ->INFF1 %FINISH %FINISH %IF RP1=QUOTE %THENSTART SETVAL(HD(RPAT),P1,ENVIR) RPAT=TL(RPAT) ->INFF1 %FINISH %IF P1=RP1 %THEN ->INFF1 %RESULT=FALSE %END; ! END INFFITSQ ! %INTEGERFN TRYINFRULE(%INTEGER RULE,EPAT,PAT,KEYED,INDENT) ! MATCHES PATTERN, EPAT, AGAINST TOINFER RULE, RULE. ! IF EPAT MATCHES CONSEQUENT OF TOINFER RULE, SUBSTITUTES ! CURRENT VALUES FOR VARIABLES IN ANTECEDENT(S) AND TRIES ! TO MATCH ANTECEDENT(S) USING TRYINFQ. %INTEGER VBLS,PRED,LIST,SAVLIST,TEMP !????;PRINTSTRING("ENTERED TRYINFRULE--PARAMS ARE"); !????;WRITE(RULE,6);WRITE(EPAT,6);WRITE(PAT,6);WRITE(KEYED,6) !????;WRITE(INDENT,6) !????;NEWLINE !????;PRINTSTRING("RULE IS");PRINTDIAGLIST(RULE);NEWLINE VBLS=HD(RULE);RULE=TL(RULE) %IF VBLS#NIL %THEN SETVBLS(VBLS) %IF KEYED=TRUE %THEN PRED=INFFITSQ(EPAT,TL(HD(RULE))) %C %ELSE PRED=INFFITSQ(EPAT,HD(RULE)) %IF JUMPFLAG=1 %THEN %RESULT=PRED !????;PRINTSTRING("RETURNED FROM INFFITSQ--PRED IS");WRITE(PRED,6) !????;NEWLINE %IF PRED=TRUE %THENSTART SAYL('USING RULE ',CONS(TOINFER,RULE),INDENT) LIST=CONS(NIL,NIL) SAVLIST=LIST %WHILE TL(RULE)#NIL %CYCLE STKSYS(RULE);STKSYS(LIST);STKSYS(SAVLIST);STKSYS(PAT) TEMP=INFINSTANCE(HD(TL(RULE))) PAT=UNSTKSYS;SAVLIST=UNSTKSYS;LIST=UNSTKSYS;RULE=UNSTKSYS %IF JUMPFLAG=1 %THEN %RESULT=TEMP REPTAIL(LIST,CONS(TEMP,NIL)) RULE=TL(RULE);LIST=TL(LIST) %REPEAT REPTAIL(LIST,TL(PAT)) LIST=TL(SAVLIST) %RESULT=TRYINFQ(LIST,INDENT+3) %FINISH %RESULT=FALSE %END; !END TRYINFRULE ! %INTEGERFN BINDINGS(%INTEGER VLIST) ! VLIST IS THE LIST OF VARIABLES OF FINDANY/FINDALL. ! A LIST OF THE VALUES OF THESE VARIABLES IS RETURNED. %INTEGER VAL %IF VLIST=NIL %THEN %RESULT=NIL VAL=GETVAL(HD(VLIST),ENVIR) %IF VAL=UNDEF %THENSTART ERROR('NO VALUE HAS BEEN GIVEN TO VARIABLE - ',HD(VLIST),1,IN) %RESULT=UNSTACK %FINISH %RESULT=CONS(VAL,BINDINGS(TL(VLIST))) %END; ! END BINDINGS ! %INTEGERFN TRYINFQ(%INTEGER PAT,INDENT) ! MATCHES PATTERN, PAT. ! IF PAT HAS A KEYWORD, MATCHES AGAINST ITS ASSOCIATION SET, ! FIRSTLY WITH ATTRIBUTE 'FACT', THEN 'TOINFER', ! EXITING IF A MATCH IS FOUND AND ONLY ONE MATCH REQUIRED (VALUE ! OF SW DETERMINES THIS). OTHERWISE, PAT IS MATCHED AGAINST ! DATABASE, THEN INFRULES, EXITING AS ABOVE. FINALLY, IF PAT HAS ! A KEYWORD, IT IS MATCHED AGAINST THE ASSOCIATION SET FOR 'QUOTE' ! WITH ATTRIBUTE 'TOINFER', EXITING AS ABOVE. ! BEFORE EXITING, IF CURRENT FUNCTION IS FINDALL, ASSIGNS CURRENT ! VALUES TO ITS VARIABLE LIST, AND CONS'S THIS LIST TO ARG3 AS RESULT. %INTEGER IPAT,EPAT,KEYED,IT,FACT,RES,TEMP %IF PAT=NIL %THENSTART %IF SW=156 %THENSTART FACT=BINDINGS(ARG1); %IF JUMPFLAG=1 %THEN %RESULT=FACT IT=ARG3 %WHILE IT#NIL %CYCLE STKSYS(IT);STKSYS(FACT) RES=EQUAL(HD(IT),FACT) FACT=UNSTKSYS;IT=UNSTKSYS %IF JUMPFLAG=1 %THEN %RESULT=RES %IF RES=TRUE %THEN %RESULT=TRUE IT=TL(IT) %REPEAT ARG3=CONS(FACT,ARG3) %FINISH %RESULT=TRUE %FINISH IPAT=HD(PAT) %IF IPAT&LM#LM %OR IPAT=NIL %THEN ->TRYINFERR IT=IPAT %WHILE IT#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0 %RESULT=QUIT %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(IT);STKSYS(IPAT);STKSYS(PAT) STKSYS(ARG1);STKSYS(ARG3) ERROR('USER INTERRUPT',EMPTY,0,IN) ARG3=UNSTKSYS;ARG1=UNSTKSYS PAT=UNSTKSYS;IPAT=UNSTKSYS;IT=UNSTKSYS %IF JUMPFLAG=1 %THEN %RESULT=UNSTACK %FINISH %IF HD(IT)=DOTS %OR HD(IT)=QUOTE %THENSTART IT=TL(IT) %IF IT=NIL %THEN ->TRYINFERR %FINISH IT=TL(IT) %REPEAT SAYL('LOOK FOR ',IPAT,INDENT) %IF HD(IPAT)=NOT %THENSTART %IF TL(IPAT)=NIL %THEN ->TRYINFERR IPAT=TL(IPAT) STACK(SW);SW=154 STKSYS(PAT);STKSYS(IPAT) RES=DEDUCEQ(IPAT,INDENT+3) SW=UNSTACK;IPAT=UNSTKSYS;PAT=UNSTKSYS %IF JUMPFLAG=1 %THEN %RESULT=RES %IF RES=TRUE %THEN %RESULT=FALSE SAYL('SUCCEED WITH - ',CONS(NOT,IPAT),INDENT) %RESULT=TRYINFQ(TL(PAT),INDENT+3) %FINISH IT=TRYBEST(DBASE,EPAT,KEYED,IPAT) %IF JUMPFLAG=1 %THEN %RESULT=IT %WHILE IT#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0 %RESULT=QUIT %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(IT);STKSYS(IPAT);STKSYS(PAT) STKSYS(EPAT);STKSYS(ARG1);STKSYS(ARG3) ERROR('USER INTERRUPT',EMPTY,0,IN) ARG3=UNSTKSYS;ARG1=UNSTKSYS;EPAT=UNSTKSYS PAT=UNSTKSYS;IPAT=UNSTKSYS;IT=UNSTKSYS %IF JUMPFLAG=1 %THEN %RESULT=UNSTACK %FINISH %IF KEYED=TRUE %THEN FACT=TL(HD(IT)) %ELSE FACT=HD(IT) TEMP=FITSQ(FACT,EPAT) %IF JUMPFLAG=1 %THEN %RESULT=TEMP %IF TEMP=TRUE %THENSTART SAYL('SUCCEED WITH ',HD(IT),INDENT) STKSYS(IT);STKSYS(PAT);STKSYS(IPAT) RES=TRYINFQ(TL(PAT),INDENT+3) IPAT=UNSTKSYS;PAT=UNSTKSYS;IT=UNSTKSYS %IF JUMPFLAG=1 %THEN %RESULT=RES %IF RES=TRUE %AND (SW=154 %OR SW=155) %THEN %RESULT=TRUE %FINISH IT=TL(IT) %REPEAT IT=TRYBEST(INFLINKS,EPAT,KEYED,IPAT) %IF JUMPFLAG=1 %THEN %RESULT=IT %WHILE IT#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0 %RESULT=QUIT %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(IT);STKSYS(IPAT);STKSYS(PAT) STKSYS(EPAT);STKSYS(ARG1);STKSYS(ARG3) ERROR('USER INTERRUPT',EMPTY,0,IN) ARG3=UNSTKSYS;ARG1=UNSTKSYS;EPAT=UNSTKSYS PAT=UNSTKSYS;IPAT=UNSTKSYS;IT=UNSTKSYS %IF JUMPFLAG=1 %THEN %RESULT=UNSTACK %FINISH STKSYS(IT);STKSYS(PAT);STKSYS(EPAT);STKSYS(IPAT) RES=TRYINFRULE(HD(IT),EPAT,PAT,KEYED,INDENT) IPAT=UNSTKSYS;EPAT=UNSTKSYS;PAT=UNSTKSYS;IT=UNSTKSYS %IF JUMPFLAG=1 %THEN %RESULT=RES %IF RES=TRUE %AND (SW=154 %OR SW=155) %THEN %RESULT=TRUE IT=TL(IT) %REPEAT %IF KEYED=TRUE %THENSTART KEYED=FALSE; EPAT=IPAT IT=FINDASS(ASSOCWA(QUOTE>>8),TOINFER) %IF IT#NIL %THEN IT=HD(TL(HD(IT))) %WHILE IT#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0 %RESULT=QUIT %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(IT);STKSYS(PAT);STKSYS(EPAT); STKSYS(ARG1);STKSYS(ARG3) ERROR('USER INTERRUPT',EMPTY,0,IN) ARG3=UNSTKSYS;ARG1=UNSTKSYS;EPAT=UNSTKSYS PAT=UNSTKSYS;IT=UNSTKSYS %IF JUMPFLAG=1 %THEN %RESULT=UNSTACK %FINISH STKSYS(IT);STKSYS(PAT);STKSYS(EPAT) RES=TRYINFRULE(HD(IT),EPAT,PAT,KEYED,INDENT) EPAT=UNSTKSYS;PAT=UNSTKSYS;IT=UNSTKSYS %IF JUMPFLAG=1 %THEN %RESULT=RES %IF RES=TRUE %AND (SW=154 %OR SW=155) %THEN %RESULT=TRUE IT=TL(IT) %REPEAT %FINISH SAYL('FAILED',EMPTY,INDENT) %RESULT=FALSE TRYINFERR:ERROR('INVALID PATTERN -',IPAT,1,IN) %RESULT=UNSTACK %END; ! END TRYINFQ ! %INTEGERFN DEDUCEQ(%INTEGER PATTERN,INDENT) %IF HD(PATTERN)&LM#LM %THEN PATTERN=CONS(PATTERN,NIL) %RESULT=TRYINFQ(PATTERN,INDENT) %END; ! END DEDUCEQ ! ! ! !??;PRINTSTRING("ENTERED APPLYSYS");NEWLINE ->SYSFUN(SW) ! ! INPUT OUTPUT SYSFUN(1):; ! PRINT %IF TDEV=8 %THEN SET42(CHTXT) ARG1=UNSTACK %IF ARG1=ENEL %THEN NOOLINE(1) %ELSE PRINTEL(ARG1) NOOLINE(1) STACK(ARG1) %RETURN ! ! SYSFUN(2):; ! TYPE %IF TDEV=8 %THEN SET42(CHTXT) ARG1=UNSTACK %IF ARG1=ENEL %THEN NOOLINE(1) %ELSE PRINTEL(ARG1) STACK(ARG1) %RETURN; ! END TYPE ! ! SYSFUN(3):; ! GETLIST %IF TDEV=8 %THEN SET42(CHTXT) BLEVEL=2 READINLINE("REPLY:") STACK(READLIST) PROMPT(PROMP) %RETURN; ! END GETLIST ! ! SYSFUN(4):; ! GETWORD %IF TDEV=8 %THEN SET42(CHTXT) BLEVEL=2 READINLINE("REPLY:") ARG1=HEADIN %IF ARG1=RBRAK %THEN STACK(EMPTY) %ELSESTART %IF ARG1&LM=LM %THENSTART;PRSTRING('NOT A WORD');NOOLINE(1); ->SYSFUN(4) %FINISH STACK(ARG1) %FINISH PROMPT(PROMP) %RETURN; ! END GETWORD ! ! SYSFUN(5):; ! 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 ! ! ! ARITHMETIC SYSFUN(10):; ! + OR SUM READYNUM %IF JUMPFLAG=1 %THENRETURN CHECKSUM(ARG1,ARG2) %IF JUMPFLAG=1 %THENRETURN STACK(CHECKSIZE(ARG1+ARG2)<<8!NM) %RETURN; ! END SUM ! ! ! SYSFUN(11):; ! - OR DIFFERENCE READYNUM %IF JUMPFLAG=1 %THENRETURN CHECKSUM(ARG1,-ARG2) %IF JUMPFLAG=1 %THENRETURN STACK(CHECKSIZE(ARG1-ARG2)<<8!NM) %RETURN; ! END DIFFERENCE ! ! SYSFUN(12):; ! * OR TIMES READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG1=0 %OR ARG2=0 %THEN ->STK %IF MAXINT/IMOD(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('FIRST MUST HAVE A LIST AS ARGUMENT - ',ARG1,1,IN) %RETURN %FINISH %IF ARG1=NIL %THENSTART ERROR('FIRST CANNOT HAVE THE EMPTY LIST AS ARGUMENT',EMPTY,1,IN) %RETURN %FINISH STACK(HD(ARG1)) %RETURN; ! END FIRST ! ! SYSFUN(21):; ! LAST ARG1=UNSTACK %IF ARG1&LM#LM %THENSTART ERROR('LAST MUST HAVE A LIST AS ARGUMENT - ',ARG1,1,IN) %RETURN %FINISH %IF ARG1=NIL %THENSTART ERROR('LAST CANNOT HAVE THE EMPTY LIST AS ARGUMENT',EMPTY,1,IN) %RETURN %FINISH %WHILE TL(ARG1)#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(ARG1) ERROR('USER INTERRUPT',EMPTY,0,IN) ARG1=UNSTKSYS %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('BUTFIRST MUST HAVE A LIST AS ARGUMENT - ',ARG1,1,IN) %RETURN %FINISH %IF ARG1=NIL %THENSTART ERROR('BUTFIRST CANNOT HAVE THE EMPTY LIST AS ARGUMENT',EMPTY,1,IN) %RETURN %FINISH STACK(TL(ARG1)) %RETURN; ! END BUTFIRST ! ! SYSFUN(23):; ! BUTLAST ARG1=UNSTACK %IF ARG1&LM#LM %THENSTART ERROR('BUTLAST MUST HAVE A LIST AS ARGUMENT - ',ARG1,1,IN) %RETURN %FINISH %IF ARG1=NIL %THENSTART ERROR('BUTLAST CANNOT HAVE THE EMPTY LIST AS ARGUMENT',EMPTY,1,IN) %RETURN %FINISH ARG2=NIL; ! ARG2 USED TEMP %WHILE TL(ARG1)#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(ARG1);STKSYS(ARG2) ERROR('USER INTERRUPT',EMPTY,0,IN) ARG2=UNSTKSYS;ARG1=UNSTKSYS %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 ARG1=UNSTACK ARG2=UNSTACK WORD %RETURN; ! END WORD ! ! SYSFUN(25):; ! LIST ARG1=UNSTACK ARG2=UNSTACK STACK(CONS(ARG1,CONS(ARG2,NIL))) %RETURN; ! ND LIST ! ! SYSFUN(26):; ! FIRSTPUT ARG1=UNSTACK ARG2=UNSTACK %IF ARG2&LM=LM %THENSTART; ! ARG2 A LIST STACK(CONS(ARG1,ARG2)) %RETURN %FINISH ERROR('FIRSTPUT MUST HAVE A LIST AS SECOND ARGUMENT - ',ARG2,1,IN) %RETURN; ! END FIRSTPUT ! ! SYSFUN(27):; ! LASTPUT ARG1=UNSTACK ARG2=UNSTACK LASTPUT %RETURN; ! END LASTPUT ! ! SYSFUN(28):; ! JOIN ARG1=UNSTACK ARG2=UNSTACK %IF ARG1&LM#LM %THENSTART ERROR('JOIN MUST HAVE A LIST AS FIRST ARGUMENT - ',ARG1,1,IN) %RETURN %FINISH %IF ARG2&LM#LM %THENSTART ERROR('JOIN MUST HAVE A LIST AS SECOND ARGUMENT - ',ARG2,1,IN) %RETURN %FINISH ARG3=NIL; ! ARG3 USED TEMP %WHILE ARG1#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(ARG1);STKSYS(ARG2);STKSYS(ARG3) ERROR('USER INTERRUPT',EMPTY,0,IN) ARG3=UNSTKSYS;ARG2=UNSTKSYS;ARG1=UNSTKSYS %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('COUNT MUST HAVE A LIST AS ARGUMENT - ',ARG1,1,IN) %RETURN %FINISH ARG2=0 %WHILE ARG1#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(ARG1) ERROR('USER INTERRUPT',EMPTY,0,IN) ARG1=UNSTKSYS %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 ARG1=UNSTACK ARG2=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 ARG1=UNSTACK ARG2=UNSTACK %IF ARG1=TRUE %AND ARG2=TRUE %C %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; ! END BOTH ! ! SYSFUN(41):; ! EITHER ARG1=UNSTACK ARG2=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('TEST MUST HAVE TRUE OR FALSE AS ARGUMENT - ',ARG1,1,IN) %RETURN %FINISH %FINISH STACK(ARG1) %RETURN; ! END TEST ! ! SYSFUN(51):; ! IFTRUE %IF TSTFLG=1 %THENSTART %IF IN=NIL %THEN %START ERROR('NULL INSTRUCTION',EMPTY,1,IN) %RETURN %FINISH STKSYS(IN) EVAL(IN,EACHVAL) IN=UNSTKSYS %FINISHELSE STACK(FALSE) %RETURN; ! END IFTRUE ! ! SYSFUN(52):; ! IFFALSE %IF TSTFLG=0 %THENSTART %IF IN=NIL %THENSTART ERROR('NULL INSTRUCTION',EMPTY,1,IN) %RETURN %FINISH STKSYS(IN) EVAL(IN,EACHVAL) IN=UNSTKSYS %FINISHELSE STACK(TRUE) %RETURN; ! END IFFALSE ! ! SYSFUN(53):; ! IF CONDLIST=HD(IN) %IF CONDLIST=NIL %THEN %START ERROR("NULL CONDITION",EMPTY,1,IN) %RETURN %FINISH STKSYS(IN) EVAL(CONDLIST,EACHVAL); ! EVAL CONDITION IN=UNSTKSYS %IF JUMPFLAG=1 %THEN %RETURN COND=UNSTACK; ! RESULT OF CONDITION TBRANCH=HD(TL(IN)) FBRANCH=TL(TL(IN)) %IF COND = TRUE %THEN %START ;!THEN %IF TBRANCH = NIL %THEN %START ERROR("NULL THEN CLAUSE",EMPTY,1,IN) %RETURN %FINISH %ELSE %START; ! EVAL TBRANCH %IF HD(TBRANCH)=START %THEN %START; ! EVAL START...FINISH RES=EVALSTARTFIN(TBRANCH) %IF JUMPFLAG=1 %THEN %RETURN %IF GOFLAG=1 %THEN %RETURN; ! JUMP INSTR %FINISH %ELSE %START; ! NOT START...FINISH STKSYS(IN) EVAL(TBRANCH,EACHVAL) DUMLAB: IN=UNSTKSYS %IF JUMPFLAG=1 %THEN %RETURN RES=UNSTACK %FINISH %FINISH; ! FINISH EVAL TBRANCH %FINISH %ELSE %START; !FINISH THEN %IF COND=FALSE %THEN %START ; ! ELSE %IF FBRANCH=NIL %THEN RES=NIL %ELSESTART %IF HD(FBRANCH)=START %THEN %START; ! EVAL START...FINISH RES=EVALSTARTFIN(FBRANCH) %IF JUMPFLAG=1 %THEN %RETURN %IF GOFLAG=1 %THEN %RETURN; ! JUMP INSTR %FINISH %ELSE %START STKSYS(IN) EVAL(FBRANCH,EACHVAL) IN=UNSTKSYS %IF JUMPFLAG=1 %THEN %RETURN RES=UNSTACK %FINISH %FINISH %FINISHELSESTART ERROR("BAD CONDITION",EMPTY,1,IN) %RETURN %FINISH %FINISH STACK(RES) %RETURN; ! END IF ! ! SYSFUN(54):; ! WHILE CONDLIST=HD(IN) TBRANCH=HD(TL(IN)) %IF CONDLIST=NIL %THENSTART ERROR('NULL CONDITION',EMPTY,1,IN) %RETURN %FINISH %IF TBRANCH=NIL %THENSTART ERROR('NULL THEN CLAUSE',EMPTY,1,IN) %RETURN %FINISH RES=NIL; ! RESULT IF COND FALSE FIRST TIME ROUND %CYCLE STKSYS(CONDLIST);STKSYS(TBRANCH);STKSYS(IN) EVAL(CONDLIST,EACHVAL); ! EVAL CONDITION IN=UNSTKSYS;TBRANCH=UNSTKSYS;CONDLIST=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN COND=UNSTACK %EXIT %IF COND=FALSE %UNLESS COND=TRUE %THENSTART ERROR("BAD CONDITION",EMPTY,1,IN) %RETURN %FINISH %IF HD(TBRANCH)=START %THEN %START; ! START...FINISH RES=EVALSTARTFIN(TBRANCH) %IF JUMPFLAG=1 %THEN %RETURN %IF GOFLAG=1 %THEN %RETURN %FINISHELSESTART STKSYS(CONDLIST);STKSYS(TBRANCH);STKSYS(IN) EVAL(TBRANCH,EACHVAL) IN=UNSTKSYS;TBRANCH=UNSTKSYS;CONDLIST=UNSTKSYS %IF JUMPFLAG=1 %THEN %RETURN RES=UNSTACK %IF FUN#NIL %AND CURFUN#NIL %THEN %EXIT ;! SPECIAL TEST FOR RESULT %FINISH %REPEAT STACK(RES) %RETURN; ! END WHILE ! ! SYSFUN(61):; ! EDIT ARG1=UNSTACK %IF ARG1&WM#WM %THENSTART ERROR('EDIT MUST HAVE A WORD AS ARGUMENT - ',ARG1,1,IN) %RETURN %FINISH ARG2=FNVAL(ARG1>>8); ! GET SPEC %IF ARG2=0 %THENSTART ERROR('PROCEDURE FOR EDIT UNDEFINED - ',ARG1,1,IN) %RETURN %FINISH %IF ARG2&USERPRE#USERPRE %THENSTART ERROR('SYSTEM PROCEDURE CANNOT BE EDITED - ',ARG1,1,IN) %RETURN %FINISH %IF SOURCEPTR+2 * FNLEN(ARG1>>8)+64>MAXSOURCE %THEN %C BADERROR('SOURCE FILE SPACE OVERFLOW',EMPTY) OLDFN(ARG1>>8)=FNLEN(ARG1>>8)<<16!FNTEXT(ARG1>>8) NEWFN=FROMLIST(ARG1,NEWFN) %UNLESS NEWFN=NIL EDIT(ARG1) %UNLESS FNPARSE(ARG1>>8)=255 %THEN NEWFN=CONS(ARG1,NEWFN) DEVICE=TTY NOOLINE(1) PRINTEL(ARG1) PRSTRING(' EDITED') NOOLINE(1) STACK(ARG1) %RETURN; ! END EDIT ! ! SYSFUN(62):; ! MAKE ARG1=UNSTACK ARG2=UNSTACK %IF ARG1&WM#WM %THENSTART ERROR('MAKE MUST HAVE A WORD AS FIRST ARGUMENT - ',ARG1,1,IN) %RETURN %FINISH SETVAL(ARG1,ARG2,ENVIR) STACK(ARG2) %RETURN; ! END MAKE ! ! SYSFUN(63):; ! NEW ARG1=UNSTACK %IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL) %ELSE CHKLIST(ARG1) %IF JUMPFLAG=1 %THENRETURN ARG2=LISTLEN(ARG1) %IF ARG2=0 %THEN STACK(NIL) %ANDRETURN %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 STACK(ARG1) GOFLAG=1 %RETURN; ! END GO ! ! ! SYSFUN(65):; ! STOP CURFUN=NIL !CURFUN=CONS(NIL,NIL); ! APPLYUSR STOPS WHEN A SINGLE LINE LEFT STACK(TRUE) %RETURN; ! END STOP ! ! SYSFUN(66):; ! RESULT (OUTPUT) CURFUN=NIL !CURFUN=CONS(NIL,NIL) ! STACK(UNSTACK) %RETURN; ! END RESULT ! ! SYSFUN(70):; ! SHOW ARG1=UNSTACK %IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL) %IF ARG1&LM#LM %THENSTART NOOLINE(1) ERROR1('NON-WORD FOR SHOW - ',ARG1) ->SH2 %FINISH %WHILE ARG1#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(ARG1) ERROR('USER INTERRUPT',EMPTY,0,IN) ARG1=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN %FINISH ARG2=HD(ARG1) ARG1=TL(ARG1) NOOLINE(1) %IF ARG2&WM#WM %THENSTART ERROR1('NON WORD FOR SHOW - ',ARG2) ->SH1 %FINISH ARG3=FNVAL(ARG2>>8); ! GET SPEC %IF ARG3=0 %THENSTART ERROR1('UNDEFINED PROCEDURE FOR SHOW - ',ARG2) ->SH1 %FINISH %IF ARG3&USERPRE#USERPRE %THENSTART ERROR1('SYSTEM PROCEDURE FOR SHOW - ',ARG2) ->SH1 %FINISH ARG3=FNTEXT(ARG2>>8) %UNTIL SOURCE(ARG4)='E' %AND SOURCE(ARG4+1)='N' %C %AND SOURCE(ARG4+2)='D' %THEN %CYCLE ARG4=ARG3 PRINTFNLINE(ARG3) %REPEAT SH1:%REPEAT SH2:STACK(TRUE) %RETURN; ! END SHOW ! ! SYSFUN(71):; ! SHOWTITLES ARG2=-1 NOOLINE(1) %CYCLE ARG1=0,1,1022 %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0 ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN %FINISH %IF FNVAL(ARG1)&USERPRE=USERPRE %THEN %START ARG2=FNTEXT(ARG1) PRINTFNLINE(ARG2) %FINISH !PRINTLINE(HD(FNVAL(ARG1)&M16!LM)) %AND ARG2=1 %REPEAT %IF ARG2<0 %THEN PRSTRING( 'NO USER PROCEDURES DEFINED YET') %C %AND NOOLINE(1) STACK(TRUE) %RETURN; ! END SHOWTITLES ! ! SYSFUN(72):; ! SHOWALL ARG2=-1 %CYCLE ARG1=0,1,1022 %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0; ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THEN %RETURN %FINISH %IF FNVAL(ARG1)&USERPRE=USERPRE %THENSTART NOOLINE(1) ARG2=FNTEXT(ARG1) %UNTIL SOURCE(ARG3)='E' %AND SOURCE(ARG3+1)='N' %C %AND SOURCE(ARG3+2)='D' %CYCLE ARG3=ARG2 PRINTFNLINE(ARG2) %REPEAT %FINISH %REPEAT %IF ARG2<0 %THENSTART NOOLINE(1) PRSTRING('NO USER PROCEDURES DEFINED YET') NOOLINE(1) %FINISH STACK(TRUE) %RETURN; ! END SHOWALL ! ! SYSFUN(73):; ! SHOWNEW NOOLINE(1) %IF NEWFN=NIL %THENSTART PRSTRING( 'NO NEW PROCEDURES') NOOLINE(1) STACK(TRUE) %RETURN;%FINISH ARG2=NEWFN %WHILE ARG2#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(ARG2) ERROR('USER INTERRUP',EMPTY,0,IN) ARG2=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN %FINISH ARG1=HD(ARG2) ARG3=FNTEXT(ARG1>>8) PRINTFNLINE(ARG3) ARG2=TL(ARG2) %REPEAT STACK(TRUE) %RETURN; ! END SHOWNEW ! ! SYSFUN(74):; ! OLDDEF ARG1=UNSTACK %IF ARG1&WM#WM %THENSTART ERROR('OLDDEF MUST HAVE A WORD FOR ARGUMENT - ',ARG1,1,IN) %RETURN;%FINISH %IF OLDFN(ARG1>>8)=0 %THENSTART ERROR(' NO STANDBY DEF FOR PROCEDURE - ',ARG1,1,IN) %RETURN;%FINISH NEWFN=FROMLIST(ARG1,NEWFN) %UNLESS NEWFN=NIL ARG2=FNLEN(ARG1>>8)<<16 ! FNTEXT(ARG1>>8) FNTEXT(ARG1>>8)=OLDFN(ARG1>>8)&X'FFFF' FNLEN(ARG1>>8)=OLDFN(ARG1>>8)>>16 W1=CHECKFNHEAD(ARG1) %IF W1=FAULT %THEN FNPARSE(ARG1>>8)=255 OLDFN(ARG1>>8)=ARG2 NEWFN=CONS(ARG1,NEWFN) %UNLESS W1=FAULT PRSTRING( 'STANDBY DEFINITION OF ');PRSTRING(WA(ARG1>>8).' RESTORED') NOOLINE(1);STACK(ARG1) %RETURN; ! END OLDDEF ! ! SYSFUN(75):; ! GETFILE ARG1=UNSTACK %IF ARG1&WM#WM %THENSTART ERROR('GETFILE MUST HAVE A WORD AS ARGUMENT - ',ARG1,1,IN) %RETURN;%FINISH USERFILE=WA(ARG1>>8) %IF CACTFILE=2 %THEN GETMASTER MDIND=FINDFILE %IF JUMPFLAG=1 %THEN STACK(MDIND) %ANDRETURN CACTFILE=1 %IF MDIND<0 %THENSTART; ! FILE NOT FOUND IN MASTER DIRECTORY CLUSERFL; CLAIMMASTER; ! OPEN MASTERFILE FOR WRITE,UNSHARED ACCESS %IF JUMPFLAG=1 %THEN %RETURN %IF MDENTS=62 %THEN GETPAGE(3) %ELSE GETPAGE(2) MDENTS=MDENTS+1 MDIND=MDENTS UDNAM(MDENTS)=USERFILE UDPAGE(MDENTS)=UDP NOOLINE(1) PRINTEL(ARG1); PRSTRING(' CREATED') FREEMASTER; ! FREE MASTERFILE FOR SHARED ACCESS %FINISH NOOLINE(1);PRINTEL(ARG1);PRSTRING(' ACTIVE');NOOLINE(1) STACK(TRUE) %RETURN; ! END GETFILE ! ! SYSFUN(76):; ! LOAD DOT ARG1=UNSTACK %IF CACTFILE=0 %THENSTART ERROR('NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN;%FINISH NOOLINE(1) %IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL) %IF ARG1&LM#LM %THEN %C ERROR1('LOAD CANNOT HAVE A NUMBER AS ARGUMENT - ',ARG1) %AND ->LD5 %IF CACTFILE =2 %THENSTART GOTHDIR %IF JUMPFLAG = 1 %THENRETURN %FINISH LIBLOAD=1 MDMAP(FILSTART+MDP*4096) UDP=0 %WHILE ARG1#NIL %CYCLE W1=HD(ARG1) ARG1=TL(ARG1) %IF W1&WM#WM %THENSTART ERROR1('NON-WORD FOR LOAD - ',W1) ->LD3;%FINISH %IF UDP=UDPAGE(MDIND) %THEN ->LD2 %ELSE GETUDP %IF UDENTS=0 %THENSTART PRSTRING('NO USER PROCEDURES SAVED') NOOLINE(1) ->LD4 %FINISH ->LD2 LD1:UDMAP(FILSTART+UDP*4096) LD2:ARG2=1 %WHILE ARG2 <= UDENTS %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT); ->LD4 %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;LIBLOAD=0;DEVICE=TTY %IF CACTFILE=2 %THEN FROTHDIR ERROR('USER INTERRUPT - PROCESS ABANDONNED',EMPTY,1,IN) %RETURN %FINISH %IF ARG2=61 %THEN UDP=UDNEXT %AND ->LD1 %IF FUNNAM(ARG2)=WA(W1>>8) %THENSTART TXTMAP(FILSTART +TXTPAGE(ARG2)*4096) INDEX=SHORTINT(TXTIND(1,ARG2)) DEVICE=DISC STARTTEXT=SOURCEPTR %UNTIL HEADIN=END %THEN %CYCLE READINLINE(PROMP) COPYLINE %REPEAT NEWFN=FROMLIST(W1,NEWFN) %UNLESS NEWFN=NIL %IF FNTEXT(W1>>8)#0 %THEN OLDFN(W1>>8)=FNLEN(W1>>8)<<16 ! FNTEXT(W1>>8) FNLEN(W1>>8)=SOURCEPTR-STARTTEXT FNTEXT(W1>>8)=STARTTEXT ARG3=CHECKFNHEAD(W1) %IF ARG3=FAULT %THEN FNPARSE(W1>>8)=255 %ELSE NEWFN=CONS(W1,NEWFN) -> LD3 %FINISH ARG2=ARG2+1 %REPEAT PRSTRING(WA(W1>>8));PRSTRING( ' NOT SAVED') NOOLINE(1) LD3:%REPEAT LD4:DEVICE=TTY %IF CACTFILE=2 %THEN FROTHDIR LIBLOAD=0 LD5:%UNLESS JUMPFLAG=1 %THEN STACK(TRUE) %RETURN; ! END LOAD ! ! SYSFUN(77):; ! SAVE ARG3=UNSTACK %IF CACTFILE=0 %THEN%START ERROR(' NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN;%FINISH %IF CACTFILE=2 %THENSTART ERROR('CANNOT SAVE TO A LIBRARY FILE',EMPTY,1,IN) %RETURN %FINISH NOOLINE(1) %IF ARG3&WM=WM %THEN ARG3=CONS(ARG3,NIL) %IF ARG3&LM#LM %THEN ERROR1('NON-WORD FOR SAVE - ',ARG3) %AND ->SAVE2 CLUSERFL;CLAIMMASTER %IF JUMPFLAG=1 %THENRETURN MDMAP(FILSTART+MDP*4096) ENDMAP DEVICE=DISC %WHILE ARG3#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 DEVICE=TTY;FREEMASTER STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;DEVICE=TTY;FREEMASTER ERROR('USER INTERRUPT - PROCESS ABANDONNED',EMPTY,1,IN) %RETURN %FINISH ARG1=HD(ARG3) ARG3=TL(ARG3) %IF ARG1&WM#WM %THEN%START ERROR1(' NON-WORD FOR SAVE - ',ARG1) ->SAVEREP;%FINISH ARG2=FNPARSE(ARG1>>8) %IF ARG2=255 %THEN %START ERROR1('PROCEDURE HAS FAULTY FIRST LINE',ARG1) ->SAVEREP %FINISH ARG2=FNVAL(ARG1>>8) %IF ARG2=0 %THEN%START ERROR1(' UNDEFINED PROCEDURE FOR SAVE - ',ARG1) ->SAVEREP;%FINISH %IF ARG2&USERPRE#USERPRE %THEN%START ERROR1('YOU CANNOT SAVE A SYSTEM PROCEDURE - ',ARG1) ->SAVEREP;%FINISH MAPEND W1=FNTEXT(ARG1>>8); ! START OF TEXT W2=W1+FNLEN(ARG1>>8); ! END OF TEXT %UNTIL W1>=W2 %THEN %CYCLE W3=W1; ! SAVE PTR TO START OF LINE PRINTFNLINE(W1) %REPEAT ! ! UPDATE DIRECTORY UPDIR(ARG1) ! NEWFN=FROMLIST(ARG1,NEWFN) %UNLESS NEWFN=NIL PRSTRING(WA(ARG1>>8));PRSTRING(' SAVED'); NOOLINE(1) SAVEREP:%REPEAT DEVICE=TTY FREEMASTER SAVE2:STACK(TRUE) %RETURN; ! END SAVE ! ! SYSFUN(78):; ! SAVENEW %IF CACTFILE=0 %THENSTART ERROR ('NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN;%FINISH %IF CACTFILE=2 %THENSTART ERROR('CANNOT SAVE TO A LIBRARY FILE',EMPTY,1,IN) %RETURN %FINISH NOOLINE(1) %IF NEWFN=NIL %THENSTART PRSTRING('NO USER PROCEDURES DEFINED OR EDITED YET');NOOLINE(1) STACK(TRUE);%RETURN;%FINISH CLUSERFL; CLAIMMASTER %IF JUMPFLAG=1 %THENRETURN MDMAP(FILSTART+MDP*4096) ENDMAP DEVICE=DISC %WHILE NEWFN#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 DEVICE=TTY;FREEMASTER STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;DEVICE=TTY;FREEMASTER ERROR('USER INTERRUPT - PROCESS ABANDONNED',EMPTY,1,IN) %RETURN %FINISH MAPEND ARG1=HD(NEWFN) W1=FNTEXT(ARG1>>8); ! START OF TEXT W2=W1+FNLEN(ARG1>>8); ! END OF TEXT %UNTIL W1>=W2 %THEN %CYCLE W3=W1; ! SAVE PTR TO START OF LINE PRINTFNLINE(W1) %REPEAT ! UPDATE DIR UPDIR(ARG1) PRSTRING(WA(ARG1>>8));PRSTRING(' SAVED') NOOLINE(1) NEWFN=TL(NEWFN) %REPEAT DEVICE=TTY FREEMASTER STACK(TRUE) %RETURN; ! END SAVENEW ! ! SYSFUN(79):; ! FORGET ARG3=UNSTACK %IF CACTFILE=0 %THENSTART ERROR(' NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN;%FINISH %IF CACTFILE=2 %THENSTART ERROR('CANNOT FORGET LIBRARY PROCEDURES',EMPTY,1,IN) %RETURN %FINISH NOOLINE(1) %IF ARG3&WM=WM %THEN ARG3=CONS(ARG3,NIL) %IF ARG3&LM#LM %THENSTART ERROR1('FORGET CANNOT HAVE A NUMBER AS ARGUMENT - ',ARG3) STACK(TRUE) %RETURN;%FINISH CLUSERFL; CLAIMMASTER %IF JUMPFLAG=1 %THENRETURN UDP=0 MDMAP(FILSTART+MDP*4096) %WHILE ARG3#NIL %CYCLE ARG1=HD(ARG3) ARG3=TL(ARG3) %IF ARG1&WM#WM %THENSTART ERROR1(' NON-WORD FOR FORGET - ',ARG1) ->FG3;%FINISH %IF UDP=UDPAGE(MDIND) %THEN ->FG2 %ELSE GETUDP %IF UDENTS=0 %THENSTART PRSTRING('NO USER PROCEDURES SAVED') NOOLINE(1) ->FG4 %FINISH FG1:UDMAP(FILSTART+UDP*4096) FG2:ARG2=1 %WHILE ARG2<=UDENTS %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 FREEMASTER;STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;FREEMASTER ERROR('USER INTERRUPT - PROCESS ABANDONNED',EMPTY,1,IN) %RETURN %FINISH %IF ARG2=61 %THEN UDP=UDNEXT %AND ->FG1 %IF FUNNAM(ARG2)=WA(ARG1>>8) %THENSTART FUNNAM(ARG2)='' TXTPAGE(ARG2)=0 PRSTRING(WA(ARG1>>8).' FORGOTTEN') NOOLINE(1) -> FG3 %FINISH ! SPACES IN USER DIR ONLY AT MOMENT ARG2=ARG2+1 %REPEAT PRSTRING(WA(ARG1>>8));PRSTRING(' NOT SAVED') NOOLINE(1) FG3:%REPEAT FG4:FREEMASTER STACK(TRUE) %RETURN; ! END FORGET ! ! SYSFUN(80):; ! SHOWSAVEDTITLES %IF CACTFILE=0 %THENSTART ERROR('NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN %FINISH %IF CACTFILE=2 %THENSTART GOTHDIR %IF JUMPFLAG=1 %THENRETURN %FINISH MDMAP(FILSTART+MDP*4096) UDP=UDPAGE(MDIND) TXTP=0 NOOLINE(1) SS5:UDMAP(FILSTART+UDP*4096) ARG2=1 %IF UDENTS=0 %THENSTART PRSTRING('NO USER PROCEDURES SAVED YET') NOOLINE(1) ->SS6 %FINISH %WHILE ARG2<=UDENTS %CYCLE %IF ARG2=61 %THEN UDP=UDNEXT %AND ->SS5 %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 %IF CACTFILE=2 %THEN FROTHDIR STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0 %IF CACTFILE=2 %THEN FROTHDIR ERROR('USER INTERRUPT - PROCESS ABANDONNED',EMPTY,1,IN) %RETURN %FINISH %IF TXTPAGE(ARG2)=0 %THENSTART PRSTRING('FORGOTTEN PROCEDURE') NOOLINE(1) %FINISHELSESTART %UNLESS TXTP=TXTPAGE(ARG2) %THEN GETTXTP(ARG2) INDEX=SHORTINT(TXTIND(1,ARG2)) DEVICE=DISC ARG3=READLINE DEVICE=TTY PRINTLINE(ARG3) %FINISH ARG2=ARG2+1 %REPEAT SS6:%IF CACTFILE=2 %THEN FROTHDIR STACK(TRUE) %RETURN; ! END SHOWSAVEDTITLES ! ! SYSFUN(81):; ! SHOWSAVED 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 NOOLINE(1) ERROR1('SHOWSAVED CANNOT HAVE A NUMBER AS ARGUMENT - ',ARG1) ->SS10 %FINISH %IF CACTFILE=2 %THENSTART GOTHDIR %IF JUMPFLAG=1 %THENRETURN %FINISH MDMAP(FILSTART+MDP*4096) UDP=0 %WHILE ARG1#NIL %CYCLE W1=HD(ARG1) ARG1=TL(ARG1) NOOLINE(1) %IF W1&WM#WM %THENSTART ERROR1(' NON-WORD FOR SHOWSAVED - ',W1) ->SS3;%FINISH %IF UDP=UDPAGE(MDIND) %THEN ->SS2 %ELSE GETUDP %IF UDENTS=0 %THENSTART PRSTRING('NO USER PROCEDURES SAVED') NOOLINE(1) ->SS4 %FINISH ->SS2 SS1:UDMAP(FILSTART+UDP*4096) SS2:ARG3=1 %WHILE ARG3<=UDENTS %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 %IF CACTFILE=2 %THEN FROTHDIR STACK(QUIT) %RETURN %FINISH %IF ARG3=61 %THEN UDP=UDNEXT %AND ->SS1 %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0 %IF CACTFILE=2 %THEN FROTHDIR ERROR('USER INTERRUPT - PROCESS ABANDONNED',EMPTY,1,IN) %RETURN %FINISH %IF FUNNAM(ARG3)=WA(W1>>8) %THENSTART TXTMAP(FILSTART+TXTPAGE(ARG3)*4096) INDEX=SHORTINT(TXTIND(1,ARG3)) RL:DEVICE=DISC ARG2=READLINE DEVICE=TTY PRINTLINE(ARG2) %IF HD(ARG2)=END %THEN ->SS3 ->RL %FINISH ARG3=ARG3+1 %REPEAT PRSTRING(WA(W1>>8));PRSTRING( ' NOT SAVED') NOOLINE(1) SS3:;%REPEAT SS4:%IF CACTFILE=2 %THEN FROTHDIR SS10:STACK(TRUE);%RETURN; ! END SHOWSAVED ! ! SYSFUN(82):; ! SHOWSAVEDALL %IF CACTFILE=0 %THENSTART ERROR('NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN %FINISH %IF CACTFILE=2 %THENSTART GOTHDIR %IF JUMPFLAG=1 %THENRETURN %FINISH MDMAP(FILSTART+MDP*4096) UDP=UDPAGE(MDIND) TXTP=0 SSALL1:UDMAP(FILSTART+UDP*4096) %IF UDENTS=0 %THENSTART NOOLINE(1) PRSTRING('NO USER PROCEDURES SAVED YET') NOOLINE(1) ->SSALL2 %FINISH ARG2=1 %WHILE ARG2<=UDENTS %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 %IF CACTFILE=2 %THEN FROTHDIR STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0 %IF CACTFILE =2 %THEN FROTHDIR ERROR('USER INTERRUPT - PROCESS ABANDONNED',EMPTY,1,IN) %RETURN %FINISH %IF ARG2=61 %THEN UDP=UDNEXT %AND ->SSALL1 %IF TXTPAGE(ARG2)=0 %THENSTART PRSTRING('FORGOTTEN PROCEDURE') NOOLINE(1) %FINISHELSESTART %UNLESS TXTP=TXTPAGE(ARG2) %THEN GETTXTP(ARG2) NOOLINE(1) INDEX=SHORTINT(TXTIND(1,ARG2)) %CYCLE DEVICE=DISC ARG3=READLINE DEVICE=TTY PRINTLINE(ARG3) %IF HD(ARG3)=END %THENEXIT %REPEAT %FINISH ARG2=ARG2+1 %REPEAT SSALL2:%IF CACTFILE=2 %THEN FROTHDIR STACK(TRUE) %RETURN; ! END SHOWSAVEDALL ! ! SYSFUN(83):; ! LOADSAVED %IF CACTFILE=0 %THENSTART ERROR(' NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN;%FINISH %IF CACTFILE=2 %THENSTART GOTHDIR %IF JUMPFLAG=1 %THENRETURN %FINISH MDMAP(FILSTART+MDP*4096) UDMAP(FILSTART+UDPAGE(MDIND)*4096) NOOLINE(1) %IF UDENTS=0 %THEN %START PRSTRING( ' NO USER PROCEDURES SAVED YET') NOOLINE(1) %IF CACTFILE=2 %THEN FROTHDIR STACK(TRUE) %RETURN;%FINISH TXTP=0 LIBLOAD=1 LS1:ARG1=1 %WHILE ARG1<=UDENTS %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT); ->LS3 %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;DEVICE=TTY;LIBLOAD=0 %IF CACTFILE=2 %THEN FROTHDIR ERROR('USER INTERRUPT - PROCESS ABANDONNED',EMPTY,1,IN) %RETURN %FINISH %IF ARG1=61 %THEN UDMAP(FILSTART+UDNEXT*4096) %AND ->LS1 %IF TXTPAGE(ARG1)=0 %THEN ->LS2 %UNLESS TXTP=TXTPAGE(ARG1) %THEN GETTXTP(ARG1) INDEX=SHORTINT(TXTIND(1,ARG1)) DEVICE=DISC STARTTEXT=SOURCEPTR %UNTIL HEADIN=END %THEN %CYCLE READINLINE(PROMP) COPYLINE %REPEAT ARG2=HASH(FUNNAM(ARG1)) NEWFN=FROMLIST(ARG2,NEWFN) %UNLESS NEWFN=NIL %IF FNTEXT(ARG2>>8) # 0 %THEN %C OLDFN(ARG2>>8)=FNLEN(ARG2>>8)<<16 ! FNTEXT(ARG2>>8) FNLEN(ARG2>>8)=SOURCEPTR-STARTTEXT FNTEXT(ARG2>>8)=STARTTEXT ARG3=CHECKFNHEAD(ARG2) %IF ARG3=FAULT %THEN FNPARSE(ARG2>>8)=255 %ELSE NEWFN=CONS(ARG2,NEWFN) LS2:ARG1=ARG1+1 %REPEAT STACK(TRUE) LS3:DEVICE=TTY %IF CACTFILE=2 %THEN FROTHDIR LIBLOAD=0 %RETURN; ! END LOADSAVED ! ! SYSFUN(84):; ! DESTROY ARG1=UNSTACK NOOLINE(1) %IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL) %IF ARG1&LM#LM %THENSTART ERROR1('DESTROY MUST HAVE A WORD AS ARGUMENT -',ARG1) STACK(TRUE) %RETURN; %FINISH %UNLESS CACTFILE=2 %THEN CLUSERFL CLAIMMASTER %IF JUMPFLAG=1 %THENRETURN MDMAP(FILSTART) %IF MDENTS=0 %THENSTART PRSTRING('NO FILES CREATED YET') NOOLINE(1) ->D4 %FINISH %WHILE ARG1#NIL %CYCLE ARG2=HD(ARG1) ARG1=TL(ARG1) %IF ARG2&WM#WM %THENSTART ERROR1('NON-WORD FOR DESTROY - ',ARG2) ->D3 %FINISH MDMAP(FILSTART) D2:ARG3=1 %WHILE ARG3<=MDENTS %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 FREEMASTER;STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;FREEMASTER ERROR('USER INTERRUPT - PROCESS ABANDONNED',EMPTY,1,IN) %RETURN %FINISH %IF ARG3=63 %THEN MDMAP(FILSTART+MDNEXT*4096) %AND ->D2 %IF UDNAM(ARG3)=WA(ARG2>>8) %THENSTART UDNAM(ARG3)='';UDPAGE(ARG3)=0 PRSTRING(WA(ARG2>>8).' DESTROYED') NOOLINE(1) %IF USERFILE=WA(ARG2>>8) %AND OWNER=EMASUSER %THEN NOFILE ->D3 %FINISH ARG3=ARG3+1 %REPEAT PRSTRING(WA(ARG2>>8).' DOES NOT EXIST') NOOLINE(1) D3:%REPEAT D4:FREEMASTER STACK(TRUE) %RETURN; ! END DESTROY ! ! SYSFUN(85):; ! BORROWFILE CHLIB %IF JUMPFLAG=1 %THENRETURN %UNLESS CACTFILE=2 %THEN CLUSERFL OWNER=WSTR1 USERFILE=WA(ARG2>>8) GOTHDIR %IF JUMPFLAG=1 %THENRETURN FROTHDIR CACTFILE=2 NOOLINE(1);PRINTEL(ARG1);PRSTRING(" ");PRINTEL(ARG2) PRSTRING(' EXISTS');NOOLINE(1) STACK(TRUE) %RETURN; ! END BORROWFILE ! ! SYSFUN(86):; ! LIBRARY CHLIB %IF JUMPFLAG=1 %THENRETURN SAVEFILE %UNLESS CACTFILE=2 %THEN CLOSESM(4) %AND CLEAR("4") ! MAP ONTO LIB OWNER'S DIRECTORY USERFILE=WA(ARG2>>8) GOTHDIR %IF JUMPFLAG=1 %THENRETURN ! GET LIBRARY DIR CACTFILE=CACTFILE+1 LIBLOAD=1 UDP=UDPAGE(MDIND) LIB1:UDMAP(FILSTART+UDP*4096) ARG1=1 %WHILE ARG1<=UDENTS %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %EXIT %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;DEVICE=TTY;CACTFILE=CACTFILE-1 FROTHDIR;RESTFILE;LIBLOAD=0 ERROR('USER INTERRUPT - PROCESS ABANDONNED',EMPTY,1,IN) %RETURN %%FINISH %IF ARG1=61 %THEN UDP=UDNEXT %AND ->LIB1 %UNLESS TXTPAGE(ARG1)=0 %THENSTART %UNLESS TXTP=TXTPAGE(ARG1) %THEN GETTXTP(ARG1) INDEX=SHORTINT(TXTIND(1,ARG1)) DEVICE=DISC STARTTEXT=SOURCEPTR %UNTIL HEADIN=END %THEN %CYCLE READINLINE(PROMP) COPYLINE %REPEAT ARG2=HASH(FUNNAM(ARG1)) NEWFN=FROMLIST(ARG2,NEWFN) %UNLESS NEWFN=NIL %IF FNTEXT(ARG2>>8) # 0 %THEN %C OLDFN(ARG2>>8)=FNLEN(ARG2>>8)<<16 ! FNTEXT(ARG2>>8) FNLEN(ARG2>>8)=SOURCEPTR-STARTTEXT FNTEXT(ARG2>>8)=STARTTEXT ARG3=CHECKFNHEAD(ARG2) %IF ARG3=FAULT %THEN FNPARSE(ARG2>>8)=255 %C %ELSE NEWFN=CONS(ARG2,NEWFN) %FINISH ARG1=ARG1+1 %REPEAT DEVICE=TTY CACTFILE=CACTFILE-1 FROTHDIR RESTFILE LIBLOAD=0 %IF JUMPFLAG#1 %THEN STACK(TRUE) %RETURN; ! END LIBRARY ! ! SYSFUN(87):; ! FILEINFO %IF CACTFILE=0 %THENSTART ERROR('NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN;%FINISH %IF CACTFILE=2 %THENSTART GOTHDIR %IF JUMPFLAG=1 %THENRETURN %FINISH ARG1=FNENTS NOOLINE(1) PRSTRING( 'NO OF ENTRIES IN FILE DIRECTORY= ') WRITE(ARG1,6) NOOLINE(1);PRSTRING( 'NXT FREE PAGE IN USER TEXT AREA =') WRITE(ENDTXT+1,6) NOOLINE(1) PRSTRING('NXT FREE INDEX =') WRITE(SHORTINT(ENDIND(1)),6) NOOLINE(1) %IF UDP#UDPAGE(MDIND) %THEN GETUDP %IF UDENTS=0 %THEN ->FI2 FI1:ARG1=1 %WHILE ARG1<= UDENTS %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 %IF CACTFILE=2 %THEN FROTHDIR STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0 %IF CACTFILE=2 %THEN FROTHDIR ERROR('USER INTERRUPT - PROCESS ABANDONNED',EMPTY,1,IN) %RETURN %FINISH %IF ARG1=61 %THENSTART UDP=UDNEXT UDMAP(FILSTART+UDP*4096) ->FI1 %FINISH NOOLINE(1) %IF FUNNAM(ARG1)='' %THENSTART PRSTRING( ' FORGOTTEN PROCEDURE');NOOLINE(1) %FINISH %C %ELSESTART PRSTRING( ' ENTRY NO = ');WRITE(ARG1,6);NOOLINE(1) PRSTRING( ' STARTING PAGE =');WRITE(TXTPAGE(ARG1)+1,6);NOOLINE(1) PRSTRING(' STARTING INDEX =');WRITE(SHORTINT(TXTIND(1,ARG1)),6) NOOLINE(1) PRSTRING( ' TEXT =');NOOLINE(2) %UNLESS TXTP=TXTPAGE(ARG1) %THEN GETTXTP(ARG1) INDEX=SHORTINT(TXTIND(1,ARG1)) %CYCLE DEVICE=DISC ARG2=READLINE DEVICE=TTY PRINTLINE(ARG2) %IF HD(ARG2)=END %THENEXIT %REPEAT %FINISH ARG1=ARG1+1 %REPEAT FI2:STACK(TRUE) %IF CACTFILE=2 %THEN FROTHDIR %RETURN; ! END FILEINFO ! ! SYSFUN(88):; ! LISTFILE %IF CACTFILE=0 %THENSTART ERROR(' NO FILE CURRENTLY ACTIVE',EMPTY,1,IN) %RETURN;%FINISH %IF CACTFILE=2 %THENSTART GOTHDIR %IF JUMPFLAG=1 %THENRETURN %FINISH ARG1=FNENTS %IF UDENTS = 0 %THENSTART PRINTSTRING( 'FILE EMPTY') NEWLINE -> LF3 %FINISH DEFINE('10,.LP'); ! USUALLY .LP SELECT OUTPUT(10) NEWLINE;PRINTSTRING('****** PROCEDURE DIRECTORY FOR ') %IF OWNER='' %THEN PRINTSTRING('USER ') %ELSE PRINTSTRING('LIBRARY ') PRINTSTRING('FILE '.USERFILE.' ******') NEWLINES(2) PRINTSTRING( ' NO OF PROCEDURES SAVED/FORGOTTEN = ');WRITE(ARG1,8) ;NEWLINE PRINTSTRING(' ENTRY NO START PAGE START INDEX PROCEDURE NAME') %IF UDP#UDPAGE(MDIND) %THEN GETUDP LF1:ARG1=1 %WHILE ARG1<=UDENTS %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) ->LF4 %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0 SELECT OUTPUT(0);CLOSE STREAM(10);CLEAR("10") %IF CACTFILE=2 %THEN FROTHDIR ERROR('USER INTERRUPT - PROCESS ABANDONNED',EMPTY,1,IN) %RETURN %FINISH %IF ARG1=61 %THENSTART UDP=UDNEXT UDMAP(FILSTART + UDP*4096) ->LF1 %FINISH NEWLINE;WRITE(ARG1,6) %IF FUNNAM(ARG1)='' %THENSTART SPACES(7); PRINTSTRING(' FORGOTTEN PROCEDURE ') -> REP136 %FINISH SPACES(10);WRITE(TXTPAGE(ARG1)+1,6) SPACES(8);WRITE(SHORTINT(TXTIND(1,ARG1)),6) SPACES(8);PRINTSTRING(FUNNAM(ARG1)) REP136:ARG1=ARG1+1 %REPEAT NEWLINES(2) PRINTSTRING('****** TEXT AREA ******') %IF UDP#UDPAGE(MDIND) %THEN GETUDP TXTP=0 LF2:ARG1=1 %WHILE ARG1<=UDENTS %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT); ->LF4 %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;SELECT OUTPUT(0) CLOSE STREAM(10);CLEAR("10") %IF CACTFILE=2 %THEN FROTHDIR ERROR('USER INTERRUPT - PROCESS ABANDONNED',EMPTY,11,IN) %RETURN %FINISH %IF ARG1=61 %THENSTART UDP=UDNEXT UDMAP(FILSTART+UDP*4096) ->LF2 %FINISH %UNLESS FUNNAM(ARG1)='' %THENSTART %UNLESS TXTP=TXTPAGE(ARG1) %THEN GETTXTP(ARG1) ARG2=SHORTINT(TXTIND(1,ARG1)) NEWLINE LFF:PRINTSYMBOL(FNTXT(ARG2)) %IF FNTXT(ARG2)=TERMIN %THENSTART ARG2=ARG2+1 %IF ARG2>SHORTINT(TXTENTS(1)) %THEN ->LF5 CHKIND(ARG2) %IF FNTXT(ARG2)='T' %THEN -> LF5 %FINISHELSE ARG2=ARG2+1 %AND CHKIND(ARG2) -> LFF %FINISH LF5:ARG1=ARG1+1 %REPEAT LF4:SELECT OUTPUT(0) CLOSE STREAM(10) CLEAR("10") LF3:%IF CACTFILE=2 %THEN FROTHDIR %UNLESS JUMPFLAG=1 %THEN STACK(TRUE) %RETURN; ! END LISTFILE ! ! SYSFUN(89):; ! SHOWFILES %IF CACTFILE=2 %THEN GETMASTER MDMAP(FILSTART) NOOLINE(1) %IF MDENTS=0 %THEN PRSTRING('NO FILES CREATED YET') %AND ->SF2 PRSTRING(' LOGO MASTER DIRECTORY ') NOOLINE(2) PRSTRING(' ENTRY NO FILENAME ') SF1:ARG1=1 %WHILE ARG1<=MDENTS %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 %IF CACTFILE=2 %THEN CLUSERFL STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0 %IF CACTFILE=2 %THEN CLUSERFL ERROR('USER INTERRUPT - PROCESS ABANDONNED',EMPTY,1,IN) %RETURN %FINISH %IF ARG1=63 %THEN MDMAP(FILSTART+MDNEXT*4096) %AND -> SF1 NOOLINE(1) WRITE(ARG1,9);SPACES(9) %IF UDNAM(ARG1)='' %THEN PRSTRING('FORGOTTEN FILE') %ELSESTART PRSTRING(UDNAM(ARG1)) %FINISH ARG1=ARG1+1 %REPEAT SF2:NOOLINE(1) STACK(TRUE) %IF CACTFILE=2 %THEN CLUSERFL %RETURN; ! END SHOWFILES ! ! SYSFUN(90):; !SUPERQUIT JUMPFLAG=1 JUMPOUT=100 SUPERJMP=1 STACK(FN) %RETURN; ! END SUPERQUIT ! ! SYSFUN(91):; ! ABORT ARG1=UNSTACK %IF ARG1&NM#NM %OR ARG1<0 %THENSTART ERROR('ABORT MUST HAVE A POSITIVE NUMBER AS ARGUMENT - ',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):; ! 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(94):; ! SENDBACK ARG1=UNSTACK; ! VALUE TO BE SENT ARG2=UNSTACK; ! FN TO BE SENT TO OR NUMBER OF FNS TO BE EXITED %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(95):; ! BREAK ARG1=IN NOOLINE(1) %IF ARG1=NIL %THEN PRINTEL(BREAK) %WHILE ARG1#NIL %THEN %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(96):; ! 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 READINLINE("RESULT:") PLEVEL=0 ARG1=PARSELINE(0) %IF ARG1=FAULT %THEN STKPNT=ARG3 %AND ->RL107 STKSYS(IN) EVAL(ARG1,EACHVAL) IN=UNSTKSYS %IF JUMPFLAG=1 %THENSTART; ! SPECIAL FOR RETRY %IF SUPERJMP=1 %THENRETURN JUMPFLAG=0 JUMPOUT=0 SENDFLAG=0 STKPNT=ARG3 ->RL107 %FINISH PROMPT(PROMP) ! STACK(UNSTACK) %RETURN; ! END CALLUSER ! ! SYSFUN(97):; ! FNCALLS ARG1=ENVIR NOOLINE(1) %WHILE ARG1>1022 %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0 ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN %FINISH %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(98):; ! FNVALS ARG1=ENVIR NOOLINE(1) %WHILE ARG1>1022 %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0 ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN %FINISH 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(99):; ! ABBREV REDEF=0 ARG1=UNSTACK ARG2=UNSTACK %IF ARG1&WM#WM %THENSTART ERROR('ABBREV MUST HAVE A WORD AS FIRST ARGUMENT - ',ARG1,1,IN) %RETURN %FINISH %IF ARG2&WM#WM %THENSTART ERROR('ABBREV MUST HAVE A WORD AS SECOND ARGUMENT - ',ARG2,1,IN) %RETURN %FINISH %IF FNVAL(ARG1>>8)=0 %THENSTART ERROR('UNDEFINED PROCEDURE 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 NEWFN=FROMLIST(ARG2,NEWFN) %UNLESS NEWFN=NIL ->TRANSPEC %FINISH; ! ALREADY DEFINED BY USER ERROR('YOU CANNOT USE ONE OF LOGOS OWN PROCEDURE NAMES'. %C ' AS 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(100):; ! MFIRST ARG1=UNSTACK ARG2=UNSTACK %IF ARG1&LM#LM %OR ARG1=NIL %THENSTART ERROR('MFIRST MUST HAVE A NON-NULL LIST AS FIRST ARGUMENT -',ARG1,1,IN) %RETURN %FINISH %IF (ARG1>>8)>=LAFNB %THENSTART; ! LIST EMBEDDED IN FN DEFN ERROR('LIST EMBEDDED IN PROCEDURE DEFN CANNOT BE UPDATED - ', %C ARG1,1,IN) %RETURN %FINISH REPHEAD(ARG1,ARG2) STACK(ARG2) %RETURN; ! END MFIRST ! ! SYSFUN(101):; ! MBUTFIRST ARG1=UNSTACK ARG2=UNSTACK %IF ARG1&LM#LM %OR ARG1=NIL %THENSTART ERROR('MBUTFIRST MUST HAVE A NON EMPTY LIST AS FIRST ARGUMENT - ', %C ARG1,1,IN) %RETURN %FINISH %IF (ARG1>>8)>=LAFNB %THENSTART ERROR('LIST EMBEDDED IN PROCEDURE DEFN CANNOT BE UPDATED - ', %C ARG1,1,IN) %RETURN %FINISH %IF ARG2&LM#LM %THENSTART ERROR('MBUTFIRST MUST HAVE A LIST AS SECOND ARGUMENT - ',ARG2,1,IN) %RETURN %FINISH REPTAIL(ARG1,ARG2) STACK(ARG2) %RETURN; ! END MBUTFIRST ! ! SYSFUN(102):; !PACK ARG1=UNSTACK %IF ARG1&LM#LM %THENSTART ERROR('PACK MUST HAVE A LIST AS ARGUMENT - ',ARG1,1,IN) %RETURN %FINISH WSTR1='' %WHILE ARG1#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(ARG1) ERROR('USER INTERRUPT',EMPTY,0,IN) ARG1=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN %FINISH 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('CAN ONLY PACK SINGLE LETTERS OR DIGITS - ',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(103):; !UNPACK ARG1=UNSTACK %IF ARG1&LM=LM %THENSTART ERROR('UNPACK MUST HAVE A WORD OR NUMBER AS ARGUMENT - ',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(104):; ! COMPRESS DEVICE=DISC FILETIDY; ! ASSUME USER IDENTIFIED %IF JUMPFLAG=1 %THENRETURN DEVICE=TTY %UNLESS CACTFILE=2 %THEN GETMASTER STACK(TRUE) %RETURN; ! END COMPRESS ! ! SYSFUN(105):; ! GOODBYE DEVICE=DISC FILETIDY %IF JUMPFLAG=1 %THENRETURN DEVICE=TTY PRSTRING('FILE TIDIED');NOOLINE(1) CLOSESTREAM(1) CLEAR("1") CLOSESM(6);CLEAR("6") DESTROY('LOGOSTK') %STOP; ! END GOODBYE ! ! SYSFUN(106):; ! EXIT CLOSESTREAM(1) CLEAR("1") CLOSESM(6);CLEAR("6") DESTROY('LOGOSTK') %STOP; ! END EXIT ! ! SYSFUN(107):; ! AND ARG2=UNSTACK ARG1=UNSTACK STACK(ARG2); ! DISCARD FIRST ARG %RETURN; ! END AND ! ! 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 VAL1:ARG2=GETVAL(ARG1,ENVIR) %IF ARG2=UNDEF %THENSTART STKSYS(ARG1) ERROR('NO VALUE HAS BEEN GIVEN TO VARIABLE - ',ARG1,0,IN) ARG1=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN ->VAL1 %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 STKSYS(IN) EVAL(ARG3,EACHVAL) IN=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN W1=UNSTACK; ! LAST VALUE %REPEAT STACK(W1) %RETURN; ! END REPEAT ! ! SYSFUN(113):; ! RESET LOGOTIME=TIME100 STACK(LOGOTIME<<8!NM) %RETURN; ! END RESET ! ! SYSFUN(114):; ! TIME STACK((TIME100-LOGOTIME)<<8!NM) %RETURN; ! END TIME ! ! SYSFUN(115):; ! DOLOGO ARG1=UNSTACK %IF ARG1&LM#LM %THENSTART ERROR('DOLOGO MUST HAVE A LIST AS ARGUMENT - ',ARG1,1,IN) %RETURN %FINISH STKSYS(IN) EVAL(ARG1,EACHVAL) IN=UNSTKSYS ! STACK(UNSTACK) %RETURN; ! END DOLOGO ! ! SYSFUN(116):; ! RANDOM ARG1=UNSTACK %IF ARG1&NM#NM %THENSTART ERROR('RANDOM MUST HAVE A NUMBER AS ARGUMENT - ',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 ARG1=UNSTACK %IF ARG1&WM#WM %THENSTART ERROR("APPLY MUST HAVE A WORD AS FIRST ARG - ",ARG1,1,IN) %RETURN %FINISH %IF ARG1=IFT %OR ARG1=IFF %THENSTART IN=CONS(ARG1!FNM,IN) %FINISHELSESTART %IF ARG1=REPEAT %THENSTART %IF IN=NIL %THENSTART ERROR("NOT ENOUGH ARGS FOR ",ARG1,1,IN) %RETURN %FINISH ARG2=REVERSE(IN) ARG3=HD(ARG2) IN=REVERSE(TL(ARG2)) IN=CONS(ARG3,CONS(ARG1!FNM,IN)) %FINISHELSESTART ARG1=CONS(ARG1!FNM,NIL) %IF IN#NIL %THENSTART ARG2=IN %WHILE TL(ARG2)#NIL %THEN ARG2=TL(ARG2) REPTAIL(ARG2,ARG1) %FINISHELSE IN=ARG1 %FINISH %FINISH !IN=CONS(UNSTACK,IN) !??;PRINTSTRING("NEW LIST FROM APPLY IS");NEWLINE !??;PRINTDIAGLIST(IN);NEWLINE STKSYS(IN) EVAL(IN,EACHVAL) IN=UNSTKSYS ! STACK(UNSTACK) %RETURN; ! END APPLY ! ! SYSFUN(118):; ! ALERT LIST(MASNUM.'LOGALERT') STACK(TRUE) %RETURN; ! END ALERT ! ! ! SYSFUN(119):; ! EXERCISE %CYCLE ARG1=1,1,8 %IF STATUS(MASNUM.TDEVNAMES(ARG1),1)<0 %THENSTART PRSTRING('SYSTEM FILE '.TDEVNAMES(ARG1).' NEEDS RESTORING.') NOOLINE(1) PRSTRING('SET PERMIT W,ALL AFTER RESTORE.') NOOLINE(1) %FINISHELSE DISCONNECT(MASNUM.TDEVNAMES(ARG1)) %REPEAT %CYCLE ARG1=1,1,2 %IF STATUS(MASNUM.SYSFILES(ARG1),1)<0 %THENSTART PRSTRING('SYSTEM FILE '.SYSFILES(ARG1).' NEEDS RESTORING.') NOOLINE(1) PRSTRING('SET PERMIT RS,ALL AFTER RESTORE.') NOOLINE(1) %FINISHELSE DISCONNECT(MASNUM.SYSFILES(ARG1)) %REPEAT STACK(TRUE) %RETURN; ! END EXERCISE ! ! SYSFUN(120):; ! DUMP DUMP('USER REQUEST') STACK(NIL); %RETURN; ! END DUMP ! ! ! SYSFUN(122):; ! GETTY SELECTINPUT(0) CLOSESTREAM(3) CLEAR("3") DESTROY('LOGOTEMP') PRSTRING('TEMPORARY FILE DESTROYED');NOOLINE(1) PRSTRING('LOADED AND READY');NOOLINE(3) STACK(NIL) %RETURN; ! END 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(131):; ! 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(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 HASHINFO ! ! SYSFUN(134):; ! MAKEASSOC ARG1=UNSTACK; ! OBJECT ARG2=UNSTACK; ! ATTRIBUTE ARG3=UNSTACK; ! VALUE %IF ARG1&WM#WM %THENSTART ERROR('MAKEASSOC MUST HAVE A WORD AS FIRST ARGUMENT - ',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(135):; ! GETASSOC ARG1=UNSTACK; ! OB ARG2=UNSTACK; ! ATT %IF ARG1&WM#WM %THENSTART ERROR('GETASSOC MUST HAVE A WORD AS FIRST ARGUMENT - ',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(136):; ! REMASSOC ARG1=UNSTACK ARG2=UNSTACK %IF ARG1&WM#WM %THENSTART ERROR('REMASSOC MUST HAVE A WORD AS FIRST ARGUMENT - ',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(137):; ! CLEARASSOC ARG1=UNSTACK %IF ARG1&WM#WM %THENSTART ERROR('CLEARASSOC MUST HAVE A WORD AS ARGUMENT - ',ARG1,1,IN) %RETURN %FINISH ASSOCWA(ARG1>>8)=NIL STACK(NIL) %RETURN; ! END CLEARASSOC ! ! SYSFUN(138):; ! CLEARALLASSOC %CYCLE ARG1=0,1,1022 ASSOCWA(ARG1)=NIL %REPEAT STACK(NIL) %RETURN; ! END CLEARALLASSOC ! ! ! ! ! SYSFUN(144):; ! 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 %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(ARG3) ERROR('USER INTERRUPT',EMPTY,0,IN) ARG3=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN %FINISH 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 PROCEDURE FOR TRACE - ',ARG1) ->TR1 %FINISH %IF ARG2&INTERP=INTERP %THENSTART ERROR1('CANNOT TRACE AN INTERP PROCEDURE - ',ARG1) ->TR1 %FINISH FNVAL(ARG1>>8)=(ARG2&UNMASK)!TRACE1; ! INSERT TRACE FLAG TR1:%REPEAT TR2:STACK(TRUE) %RETURN; ! END TRACE ! ! SYSFUN(145):; ! FULLTRACE ARG3=UNSTACK %IF ARG3&WM=WM %THEN ARG3=CONS(ARG3,NIL) %IF ARG3&LM#LM %THENSTART ERROR1('FULLTRACE WHAT? ',ARG3) ->FT2 %FINISH %WHILE ARG3#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(ARG3) ERROR('USER INTERRUPT',EMPTY,0,IN) ARG3=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN %FINISH ARG1=HD(ARG3) ARG3=TL(ARG3) %IF ARG1&WM#WM %THENSTART ERROR1('FULLTRACE WHAT? ',ARG1) ->FT1 %FINISH ARG2=FNVAL(ARG1>>8) %IF ARG2=0 %THENSTART ERROR1('UNDEFINED PROCEDURE FOR TRACE - ',ARG1) ->FT1 %FINISH %IF ARG2&INTERP=INTERP %THENSTART ERROR1('CANNOT TRACE AN INTERP PROCEDURE - ',ARG1) ->FT1 %FINISH FNVAL(ARG1>>8)=(ARG2&UNMASK)!TRACE2; !INSERT TRACE FLAG FT1:%REPEAT FT2:STACK(TRUE) %RETURN; ! END FULLTRACE ! ! ! SYSFUN(147):; ! UNTRACE ARG3=UNSTACK NOOLINE(1) %IF ARG3&WM=WM %THEN ARG3=CONS(ARG3,NIL) %IF ARG3&LM#LM %THENSTART ERROR1('UNTRACE WHAT? ',ARG3) ->UNTR2 %FINISH %WHILE ARG3#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART HOLDFLAG=0;STKSYS(ARG3) ERROR('USER INTERRUPT',EMPTY,0,IN) ARG3=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN %FINISH 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 PROCEDURE 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(148):; ! MAPLIST ARG1=UNSTACK %IF ARG1&LM#LM %THENSTART ERROR('MAPLIST MUST HAVE A LIST AS FIRST ARGUMENT - ',ARG1,1,IN) %RETURN %FINISH ARG3=NIL ARG2=IN %IF HD(ARG2)&NM=NM %THEN %START ERROR("INVALID SECOND ARG FOR MAPLIST-",ARG2,1,IN) %RETURN %FINISH %IF HD(ARG2)&WM=WM %THEN %START STKSYS(IN);STKSYS(ARG1) EVAL(ARG2,EACHVAL) ARG1=UNSTKSYS;IN=UNSTKSYS %IF JUMPFLAG=1 %THEN %RETURN ARG2=UNSTACK %FINISH %IF ARG2&WM=WM %THENSTART %WHILE ARG1#NIL %CYCLE W1=HD(ARG1)!QU W1=CONS(W1,CONS(ARG2!FNM,NIL)) ARG1=TL(ARG1) STKSYS(IN);STKSYS(ARG1);STKSYS(ARG3) EVAL(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 %IF HD(ARG2)&LP#LP %THEN %START SAVEDEV=DEVICE DEVICE=SRCE SINDEX=SOURCEPTR PRINTLIST(ARG2&X'FFFFFF0F') READINLINE(PROMP) DEVICE=SAVEDEV ARG2=PARSELINE(0) %FINISH %WHILE ARG1#NIL %CYCLE W1=HD(ARG1) ARG1=TL(ARG1) STKSYS(IN);STKSYS(ARG1);STKSYS(ARG2);STKSYS(ARG3) EVAL(ARG2,W1) ARG3=UNSTKSYS;ARG2=UNSTKSYS;ARG1=UNSTKSYS;IN=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN ARG3=CONS(UNSTACK,ARG3) %REPEAT %FINISH %WHILE ARG3#NIL %CYCLE; ! REVERSE LIST ARG1=CONS(HD(ARG3),ARG1) ARG3=TL(ARG3) %REPEAT STACK(ARG1) %RETURN; ! END MAPLIST ! ! SYSFUN(149):; ! APPLIST ARG1=UNSTACK %IF ARG1&LM#LM %THENSTART ERROR('APPLIST MUST HAVE A LIST AS FIRST ARGUMENT - ',ARG1,1,IN) %RETURN %FINISH ARG3=NIL ARG2=IN %IF HD(ARG2)&NM=NM %THEN %START ERROR("INVALID SECOND ARG FOR APPLIST-",ARG2,1,IN) %RETURN %FINISH %IF HD(ARG2)&WM=WM %THEN %START STKSYS(IN);STKSYS(ARG1) EVAL(ARG2,EACHVAL) ARG1=UNSTKSYS;IN=UNSTKSYS %IF JUMPFLAG=1 %THEN %RETURN ARG2=UNSTACK %FINISH %IF ARG2&WM=WM %THENSTART %WHILE ARG1#NIL %CYCLE W1=HD(ARG1)!QU ARG3=CONS(W1,CONS(ARG2!FNM,NIL)) ARG1=TL(ARG1) STKSYS(IN);STKSYS(ARG1) EVAL(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 %IF HD(ARG2)&LP#LP %THEN %START SAVEDEV=DEVICE DEVICE=SRCE SINDEX=SOURCEPTR PRINTLIST(ARG2&X'FFFFFF0F') READINLINE(PROMP) DEVICE=SAVEDEV ARG2=PARSELINE(0) %FINISH %WHILE ARG1#NIL %CYCLE W1=HD(ARG1) !???;PRINTSTRING("W1 AND ARG2 ARE ");PRINTDIAG(W1);NEWLINE !???;PRINTDIAGLIST(ARG2);NEWLINE ARG1=TL(ARG1) STKSYS(IN);STKSYS(ARG1);STKSYS(ARG2) EVAL(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 ! ! SYSFUN(151):; ! CLEARDATABASE ARG3=BVALUE(FACTKEYS>>8) %WHILE ARG3#NIL %CYCLE ARG1=HD(ARG3)>>8 ARG3=TL(ARG3) ARG2=FINDASS(ASSOCWA(ARG1),FACT) %IF ARG2#NIL %THENSTART %IF W1=W2 %THEN ASSOCWA(ARG1)=TL(W2) %ELSE REPTAIL(W1,TL(W2)) %FINISH %REPEAT ARG3=BVALUE(IMPKEYS>>8) %WHILE ARG3#NIL %CYCLE ARG1=HD(ARG3)>>8 ARG3=TL(ARG3) ARG2=FINDASS(ASSOCWA(ARG1),IMPLIES) %IF ARG2#NIL %THENSTART %IF W1=W2 %THEN ASSOCWA(ARG1)=TL(W2) %ELSE REPTAIL(W1,TL(W2)) %FINISH %REPEAT ARG3=BVALUE(INFKEYS>>8) %WHILE ARG3#NIL %CYCLE ARG1=HD(ARG3)>>8 ARG3=TL(ARG3) ARG2=FINDASS(ASSOCWA(ARG1),TOINFER) %IF ARG2#NIL %THENSTART %IF W1=W2 %THEN ASSOCWA(ARG1)=TL(W2) %ELSE REPTAIL(W1,TL(W2)) %FINISH %REPEAT SETUPINF STACK(NIL) %RETURN; ! END CLEARDATABASE ! ! SYSFUN(152):; ! ASSERT ARG1=UNSTACK %IF ARG1&LM#LM %OR ARG1=NIL %THENSTART ERROR('INVALID ARG FOR ASSERT -',ARG1,1,IN) %RETURN %FINISH %IF HD(ARG1)=IMPLIES %THEN ADDRULE(ARG1,0,IMPLINKS) %ELSESTART %IF HD(ARG1)=TOINFER %THEN ADDRULE(ARG1,0,INFLINKS) %C %ELSE ADDFACT(ARG1,0) %FINISH %IF JUMPFLAG=1 %THENRETURN STACK(NIL) %RETURN; ! END ASSERT ! ! SYSFUN(153):; ! AMONGQ ARG1=UNSTACK ARG2=UNSTACK %IF ARG2&LM#LM %THENSTART ERROR('INVALID 2ND ARG FOR AMONGQ -',ARG2,1,IN) %RETURN %FINISH %WHILE ARG2#NIL %CYCLE ARG3=EQUAL(HD(ARG2),ARG1) %IF JUMPFLAG=1 %THEN STACK(ARG3) %AND %RETURN %IF ARG3=TRUE %THEN STACK(TRUE) %AND %RETURN ARG2=TL(ARG2) %REPEAT STACK(FALSE) %RETURN; ! END AMONGQ ! ! SYSFUN(154):; !ISQ ARG1=UNSTACK %IF ARG1&LM#LM %OR ARG1=NIL %THENSTART ERROR('INVALID ARG FOR ISQ -',ARG1,1,IN) %RETURN %FINISH ARG3=UNDEF STACK(DEDUCEQ(ARG1,0)) %RETURN; ! END ISQ ! ! SYSFUN(155):; !FINDANY ARG1=UNSTACK ARG2=UNSTACK %IF ARG1&LM#LM %OR ARG1=NIL %THENSTART ERROR('INVALID 1ST ARG FOR FINDANY -',ARG1,1,IN) %RETURN %FINISH %IF ARG2&LM#LM %OR ARG2=NIL %THENSTART ERROR('INVALID 2ND ARG FOR FINDANY -',ARG2,1,IN) %RETURN %FINISH ARG3=UNDEF ARG3=DEDUCEQ(ARG2,0) %IF JUMPFLAG=1 %THEN STACK(ARG2) %ANDRETURN %IF ARG3=TRUE %THEN STACK(BINDINGS(ARG1)) %ELSE STACK(NIL) %RETURN; ! END FINDANY ! ! SYSFUN(156):; ! FINDALL ARG1=UNSTACK ARG2=UNSTACK %IF ARG1&LM#LM %OR ARG1=NIL %THENSTART ERROR('INVALID 1ST ARG FOR FINDALL -',ARG1,1,IN) %RETURN %FINISH %IF ARG2&LM#LM %OR ARG2=NIL %THENSTART ERROR('INVALID 2ND ARG FOR FINDALL -',ARG2,1,IN) %RETURN %FINISH ARG3=NIL ARG2=DEDUCEQ(ARG2,0) %IF JUMPFLAG=1 %THEN STACK(ARG2) %ELSE STACK(ARG3) %RETURN; !END FINDALL ! ! ! SYSFUN(160):; ! FORWARD ARG1=CHDEVARG %IF JUMPFLAG=1 %THEN STACK(ARG1) %ANDRETURN ->FDSW(TDEV) ! FDSW(1):FDSW(2): ! PLOTTERS DY=ARG1*SIN(HDTURTLE/57.3) DX=ARG1*COS(HDTURTLE/57.3) COORDOK(INTPT(XTURTLE+DX));%IF JUMPFLAG=1 %THENRETURN COORDOK(INTPT(YTURTLE+DY));%IF JUMPFLAG=1 %THENRETURN %IF PENTURTLE=DOWN %THENSTART BINARG(1,0) BINARG(2,4) SENDBIN(0,2); ! PENDOWN %FINISH BINARG(1,2) BINARG(2,INTPT(DX+FRACPT(XTURTLE))<<5) BINARG(3,INTPT(DY+FRACPT(YTURTLE))<<5) SENDBIN(0,3); ! OUTLINV(DX,DY) %IF PENTURTLE=DOWN %THENSTART BINARG(1,0) BINARG(2,0) SENDBIN(0,2); ! PENUP %FINISH XTURTLE=XTURTLE+DX; YTURTLE=YTURTLE+DY STACK(W1); ! NO SPECIAL RESULT %RETURN ! FDSW(3):; ! DISPLAY DY=ARG1*SIN(HDTURTLE/57.3) DX=ARG1*COS(HDTURTLE/57.3) COORDOK(INTPT(XTURTLE+DX));%IF JUMPFLAG=1 %THENRETURN COORDOK(INTPT(YTURTLE+DY));%IF JUMPFLAG=1 %THENRETURN BINARG(2,INTPT(DX+FRACPT(XTURTLE))<<5) BINARG(3,INTPT(DY+FRACPT(YTURTLE))<<5) %IF PENTURTLE=DOWN %THEN BINARG(1,9) %ELSE BINARG(1,5) SENDBIN(0,3); ! DLINEV(DX,DY) OR DSETV(DX,DY) XTURTLE=XTURTLE+DX YTURTLE=YTURTLE+DY STACK(W1) %RETURN ! FDSW(4):; ! TURTLE %IF ARG1=0 %THEN STACK(W1) %ANDRETURN DY=ARG1*SIN(HDTURTLE/57.3) DX=ARG1*COS(HDTURTLE/57.3) %IF ARG1<0 %THEN TSEND(BDBITS,TSCALE(-ARG1)) %ELSEC TSEND(FDBITS,TSCALE(ARG1)) %IF JUMPFLAG=1 %THENRETURN XTURTLE=XTURTLE+DX;YTURTLE=YTURTLE+DY STACK(W1) %RETURN ! FDSW(5):FDSW(6):FDSW(7):; ! PUNCH,MUSIC,MECCANO ! ERROR('DEVICE CANNOT DO',FN,1,IN) %RETURN FDSW(8): ;! GT42 DISPLAY DX=ARG1*COS(HDTURTLE/57.3) DY=ARG1*SIN(HDTURTLE/57.3) COORDOK(INTPT(XTURTLE+DX)); %IF JUMPFLAG=1 %THENRETURN COORDOK(INTPT(YTURTLE+DY)); %IF JUMPFLAG=1 %THENRETURN ! *** CHECK FOR COMPILING A PICTURE (LATER VERSION) VECTOR(DX,DY) XTURTLE=XTURTLE+DX YTURTLE=YTURTLE+DY STACK(W1) %RETURN; ! END FORWARD ! ! SYSFUN(161):; ! BACKWARD ARG1=CHDEVARG %IF JUMPFLAG=1 %THEN STACK(ARG1) %ANDRETURN ->BDSW(TDEV) ! BDSW(1):BDSW(2):; ! PLOTTERS ARG1=-ARG1 ->FDSW(1) ! BDSW(3):; ! DISPLAY ARG1=-ARG1 ->FDSW(3) ! BDSW(4):; ! TURTLE ARG1=-ARG1 ->FDSW(4) ! BDSW(5):BDSW(6):BDSW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO',FN,1,IN) ! %RETURN BDSW(8): ;! GT42 DISPLAA ARG1 = -ARG1 -> FDSW(8); ! END BACKWARD ! SYSFUN(162):; ! LEFT ARG1=CHDEVARG %IF JUMPFLAG=1 %THEN STACK(ARG1) %ANDRETURN ->LEFTSW(TDEV) ! LEFTSW(1):LEFTSW(2):; ! PLOTTERS %IF ARG1=0 %THEN STACK(W1) %ANDRETURN HDTURTLE=MOD360(HDTURTLE+ARG1) %IF ARG1<0 %THEN PINDSEND(0,-ARG1) %ELSE PINDSEND(PINDLBIT,ARG1) %IF JUMPFLAG=1 %THENRETURN %IF W1=TRUE %THEN W1=TSTATE STACK(W1) %RETURN ! LEFTSW(3):; ! DISPLAY HDTURTLE=MOD360(HDTURTLE+ARG1) %IF W1=TRUE %THEN W1=TSTATE STACK(W1) %RETURN ! LEFTSW(4):; ! TURTLE %IF ARG1=0 %THEN STACK(W1) %ANDRETURN HDTURTLE=MOD360(HDTURTLE+ARG1) %IF ARG1<0 %THEN TSEND(RTBITS,TANGLE(-ARG1)) %ELSEC TSEND(LTBITS,TANGLE(ARG1)) %IF JUMPFLAG=1 %THENRETURN %IF W1=TRUE %THEN W1=TSTATE STACK(W1) %RETURN ! LEFTSW(5):LEFTSW(6):LEFTSW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO',FN,1,IN) %RETURN ! LEFTSW(8): ;! GT42 DISPLAY HDTURTLE=MOD360(HDTURTLE+ARG1) CALC TURTLE STACK(W1) %RETURN; ! END LEFT ! ! SYSFUN(163):; !RIGHT ARG1=CHDEVARG %IF JUMPFLAG=1 %THEN STACK(ARG1) %ANDRETURN ->RIGHTSW(TDEV) ! RIGHTSW(1):RIGHTSW(2):; ! PLOTTERS ARG1=-ARG1 ->LEFTSW(1) ! RIGHTSW(3):; ! DISPLAY ARG1=-ARG1 ->LEFTSW(3) ! RIGHTSW(4):; ! TURTLE ARG1=-ARG1 ->LEFTSW(4) ! RIGHTSW(5):RIGHTSW(6):RIGHTSW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN ! RIGHTSW(8): ;! GT42 DISPLAA ARG1=-ARG1 -> LEFTSW(8); ! END RIGHT ! ! SYSFUN(164):; ! LIFT PEN ->LIFTSW(TDEV) ! LIFTSW(1):LIFTSW(2):LIFTSW(3):LIFTSW(8):; ! PLOTTERS AND DISPLAYS PENTURTLE=UP STACK(FALSE) %RETURN ! LIFTSW(4):; ! TURTLE PENTURTLE=UP TSEND1(32) STACK(FALSE) %RETURN ! LIFTSW(5):LIFTSW(6):LIFTSW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO',FN,1,IN) %RETURN; ! END LIFT ! ! SYSFUN(165):; ! DROP PEN ->DROPSW(TDEV) ! DROPSW(1):DROPSW(2):DROPSW(3):DROPSW(8):; ! PLOTTERS AND DISPLAYS PENTURTLE=DOWN STACK(TRUE) %RETURN ! DROPSW(4):; ! TURTLE PENTURTLE=DOWN TSEND1(32) STACK(TRUE) %RETURN ! DROPSW(5):DROPSW(6):DROPSW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO' ,FN,1,IN) %RETURN; ! END DROP ! ! SYSFUN(166):; ! HOOT ->HOOTSW(TDEV) ! HOOTSW(1):HOOTSW(2):HOOTSW(3):HOOTSW(5):HOOTSW(6):HOOTSW(7):; ! ALL BUT TURTLE ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN ! HOOTSW(4):; ! TURTLE TSEND1(HOOTBIT) STACK(TRUE) %RETURN ! HOOTSW(8): ;! GT42 DISPLAY SET42(CHPIC) CH3(BLEEP) STACK(TRUE) %RETURN; ! END HOOT ! ! SYSFUN(167):; ! CENTRE ->CENSW(TDEV) ! CENSW(1):CENSW(2):; ! PLOTTERS XTURTLE=0 YTURTLE=0 HDTURTLE=0 PENTURTLE=DOWN BINARG(1,1) BINARG(2,0) BINARG(3,0) SENDBIN(0,3); ! OUTLIN(0,0) PINDSEND(PINDRBIT+PINDLBIT,360); ! RESET IND ANTICLOCK %IF JUMPFLAG=1 %THENRETURN STACK(TRUE) %RETURN ! CENSW(3):; ! DISPLAY XTURTLE=0 YTURTLE=0 HDTURTLE=0 PENTURTLE=DOWN BINARG(1,6) BINARG(2,0) BINARG(3,0) SENDBIN(0,3); ! DPOINT(0,0) STACK(TRUE) %RETURN ! CENSW(4):; ! TURTLE ARG2=0 ARG3=0 W2=0 ARG1=DOWN W1=TRUE ->POSW(4); ! SETTURTLE ! CENSW(5):CENSW(6):CENSW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO',FN,1,IN) %RETURN ! CENSW(8): ;! GT42 DISPLAY XTURTLE=0 YTURTLE=0 HDTURTLE=0 PENTURTLE=DOWN POINT(512,512) CALC TURTLE STACK(TRUE) %RETURN; ! END CENTRE ! ! SYSFUN(168):; ! CLEAR ->CLSW(TDEV) ! CLSW(1):CLSW(2):CLSW(4):; ! PLOTTERS,TURTLE STACK(TRUE) %RETURN ! CLSW(5):CLSW(6):CLSW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO',FN,1,IN) %RETURN ! CLSW(3):; ! DISPLAY BINARG(1,0) SENDBIN(0,1); ! CLEARDIS ->WHSW(3) ! CLSW(8): ;! GT42 DISPLAY SET42(CHPIC) CLEAR42 XTURTLE=0 YTURTLE=0 HDTURTLE=0 PENTURTLE=DOWN POINT(512,512) -> WHSW(8); ! END CLEAR ! ! SYSFUN(169):; ! WHERE ->WHSW(TDEV) ! WHSW(1):WHSW(2):; ! PLOTTERS ARG1=HDTURTLE+90 BINARG(1,0) BINARG(2,4) SENDBIN(0,2); ! PENDOWN %CYCLE W1=1,1,2 ARG1=MOD360(ARG1+60) ARG2=INT(10.0*SIN(ARG1/57.3)) ARG3=INT(10.0*COS(ARG1/57.3)) BINARG(1,2) BINARG(2,ARG3<<5) BINARG(3,ARG2<<5) SENDBIN(0,3); ! OUTLINV(DX,DY) BINARG(2,-(ARG3<<5)) BINARG(3,-(ARG2<<5)) SENDBIN(0,3); ! OUTLINV(-DX,-DY) %REPEAT BINARG(1,0) BINARG(2,0) SENDBIN(0,2); ! PENUP STACK(TRUE) %RETURN ! WHSW(3):; ! DISPLAY RW1=SIN(HDTURTLE/57.3) RW2=COS(HDTURTLE/57.3) BINARG(1,12) BINARG(2,INT(-1300.0*(0.9659*RW2+0.2588*RW1))) BINARG(3,INT(-1300.0*(0.9659*RW1-0.2588*RW2))) BINARG(4,INT(0.5176*1300.0*RW1)) BINARG(5,INT(-0.5176*1300.0*RW2)) SENDBIN(0,5); ! DRAWTURT STACK(TRUE) %RETURN ! WHSW(4):WHSW(5):WHSW(6):WHSW(7):; ! TURTLE,PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO',FN,1,IN) %RETURN ! WHSW(8): ;! GT42 DISPLAY SHOW TURTLE 42 = 1 CALC TURTLE STACK(TRUE) %RETURN; ! END WHERE ! ! SYSFUN(170):; ! HERE ->HERESW(TDEV) ! HERESW(1):HERESW(2):HERESW(3):HERESW(4):HERESW(8):; ! PLOTTERS,DISPLAY,TURTLE STACK(TSTATE) %RETURN ! HERESW(5):HERESW(6):HERESW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO',FN,1,IN) %RETURN; ! END HERE ! ! SYSFUN(171):; ! XCOR ->XCORSW(TDEV) ! XCORSW(1):XCORSW(2):XCORSW(3):XCORSW(4):XCORSW(8):; ! PLOTTERS,DISPLAY,TURTLE STACK(INTPT(XTURTLE)<<8!NM) %RETURN ! XCORSW(5):XCORSW(6):XCORSW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN; ! END XCOR ! ! SYSFUN(172):; ! YCOR ->YCORSW(TDEV) ! YCORSW(1):YCORSW(2):YCORSW(3):YCORSW(4):YCORSW(8):; ! PLOTTERS,DISPLAY,TURTLE STACK(INTPT(YTURTLE)<<8!NM) %RETURN ! YCORSW(5):YCORSW(6):YCORSW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN; ! END YCOE ! ! SYSFUN(173):; ! HEADING ->HDSW(TDEV) ! HDSW(1):HDSW(2):HDSW(3):HDSW(4):HDSW(8):; ! PLOTTERS,DISPLAY,TURTLE STACK(HDTURTLE<<8!NM) %RETURN ! HDSW(5):HDSW(6):HDSW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN; ! END HEADING ! ! SYSFUN(174):; ! PEN ->PENSW(TDEV) ! PENSW(1):PENSW(2):PENSW(3):PENSW(4):PENSW(8):; ! PLOTTERS,DISPLAY,TURTLE STACK(PENTURTLE) %RETURN ! PENSW(5):PENSW(6):PENSW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN; ! END PEN ! ! SYSFUN(175):; ! SETX ARG1=CHDEVARG %IF JUMPFLAG=1 %THEN STACK(ARG1) %ANDRETURN ->SETXSW(TDEV) ! SETXSW(1):SETXSW(2):; ! PLOTTERS COORDOK(ARG1);%IF JUMPFLAG=1 %THENRETURN XTURTLE=ARG1 BINARG(1,1) BINARG(2,ARG1<<5) BINARG(3,INTPT(YTURTLE)<<5) SENDBIN(0,3); ! OUTLIN(X,Y) STACK(W1) %RETURN ! SETXSW(3):; ! DISPLAY COORDOK(ARG1);%IF JUMPFLAG=1 %THENRETURN XTURTLE=ARG1 %IF PENTURTLE=DOWN %THEN BINARG(1,6) %ELSE BINARG(1,4) ! EITHER DPOINT(X,Y) OR DSET(X,Y) BINARG(2,ARG1<<5) BINARG(3,INTPT(YTURTLE)<<5) SENDBIN(0,3) STACK(W1) %RETURN ! SETXSW(4):; ! TURTLE SETUP(ARG1-INTPT(XTURTLE),HDTURTLE) %IF JUMPFLAG=1 %THENRETURN XTURTLE=ARG1 STACK(W1) %RETURN ! SETXSW(5):SETXSW(6):SETXSW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN ! SETXSW(8): ;! GT42 DISPLAY COORDOK(ARG1); %IF JUMPFLAG=1 %THENRETURN XTURTLE=ARG1 POINT(XTURTLE+512,YTURTLE+512) STACK(W1) %RETURN; ! END SETX ! ! SYSFUN(176):; ! SETY ARG1=CHDEVARG %IF JUMPFLAG=1 %THEN STACK(ARG1) %ANDRETURN ->SETYSW(TDEV) ! SETYSW(1):SETYSW(2):; ! PLOTTERS COORDOK(ARG1);%IF JUMPFLAG=1 %THENRETURN YTURTLE=ARG1 BINARG(1,1) BINARG(2,INTPT(XTURTLE)<<5) BINARG(3,ARG1<<5) SENDBIN(0,3); ! OUTLIN,X,Y) STACK(W1) %RETURN ! SETYSW(3):; ! DISPLAY COORDOK(ARG1);%IF JUMPFLAG=1 %THENRETURN YTURTLE=ARG1 %IF PENTURTLE=DOWN %THEN BINARG(1,6) %ELSE BINARG(1,4) BINARG(2,INTPT(XTURTLE)<<5) BINARG(3,ARG1<<5) SENDBIN(0,3) STACK(W1) %RETURN ! SETYSW(4):; ! TURTLE SETUP(ARG1-INTPT(YTURTLE),HDTURTLE-90) %IF JUMPFLAG=1 %THENRETURN YTURTLE=ARG1 STACK(W1) %RETURN ! SETYSW(5):SETYSW(6):SETYSW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN ! SETYSW(8): ;! GT42 DISPLAY COORDOK(ARG1); %IF JUMPFLAG=1 %THENRETURN YTURTLE=ARG1 POINT(XTURTLE+512,YTURTLE+512) STACK(W1) %RETURN; ! END SETY ! ! SYSFUN(177):; ! SETHEADING ARG1=CHDEVARG %IF JUMPFLAG=1 %THEN STACK(ARG1) %ANDRETURN ->SETHSW(TDEV) ! SETHSW(1):SETHSW(2):; ! PLOTTERS ARG1=MOD360(ARG1-HDTURTLE) %IF ARG1>180 %THEN ARG1=ARG1-360 ->LEFTSW(1) ! SETHSW(3):; ! DISPLAY HDTURTLE=MOD360(ARG1) STACK(W1) %RETURN ! SETHSW(4):; ! TURTLE ARG1=MOD360(ARG1-HDTURTLE) %IF ARG1>180 %THEN ARG1=ARG1-360 ->LEFTSW(4) ! SETHSW(5):SETHSW(6):SETHSW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN ! SETHSW(8): ;! GT42 DISPLAY HDTURTLE=MOD360(ARG1) CALC TURTLE STACK(W1) %RETURN; ! END SETHEADING ! ! SYSFUN(178):; ! POSITION ARG1=UNSTACK; %IF ARG1&LM=0 %THENSTART ERROR('LIST INPUT REQUIRED FOR ',FN,1,IN) %RETURN %FINISH W1=ARG1 %IF LISTLEN(ARG1)#4 %THEN ->POS1 ARG2=HD(ARG1);ARG1=TL(ARG1); ! X ARG3=HD(ARG1);ARG1=TL(ARG1); ! Y W2=HD(ARG1); ! HEADING ARG1=HD(TL(ARG1)); ! PEN %IF ARG2&NM=0 %OR ARG3&NM=0 %OR W2&NM=0 %ORC (ARG1#UP %AND ARG1#DOWN) %THEN ->POS1 ARG2=IMPNUM(ARG2) ARG3=IMPNUM(ARG3) W2=IMPNUM(W2) ->POSW(TDEV) ! POSW(1):POSW(2):; ! PLOTTERS COORDOK(ARG2);%IF JUMPFLAG=1 %THENRETURN COORDOK(ARG3);%IF JUMPFLAG=1 %THENRETURN XTURTLE=ARG2 YTURTLE=ARG3 PENTURTLE=ARG1 BINARG(1,1) BINARG(2,ARG2<<5) BINARG(3,ARG3<<5) SENDBIN(0,3); ! OUTLIN(X,Y) ARG1=W2 ->SETHSW(1) POS1:ERROR('WRONGLY FORMATTED LIST FOR ',FN,1,IN) %RETURN ! POSW(3):; ! DISPLAY COORDOK(ARG2);%IF JUMPFLAG=1 %THENRETURN COORDOK(ARG3);%IF JUMPFLAG=1 %THENRETURN XTURTLE=ARG2 YTURTLE=ARG3 HDTURTLE=MOD360(W2) PENTURTLE=ARG1 %IF PENTURTLE=DOWN %THEN BINARG(1,6) %ELSE BINARG(1,4) BINARG(2,ARG2<<5) BINARG(3,ARG3<<5) SENDBIN(0,3) STACK(W1) %RETURN ! POSW(4):; ! TURTLE PENTURTLE=UP TSEND1(32); ! PENUP SETUP(ARG2-INTPT(XTURTLE),HDTURTLE) %IF JUMPFLAG=1 %THENRETURN SETUP(ARG3-INTPT(YTURTLE),HDTURTLE-90) %IF JUMPFLAG=1 %THENRETURN XTURTLE=ARG2 YTURTLE=ARG3 ARG2=MOD360(W2-HDTURTLE) HDTURTLE=MOD360(W2) %IF ARG2>180 %THEN ARG2=ARG2-360 %IF ARG2#0 %THENSTART %IF ARG2<0 %THEN TSEND(RTBITS,TANGLE(-ARG2)) %ELSEC TSEND(LTBITS,TANGLE(ARG2)) %IF JUMPFLAG=1 %THENRETURN %FINISH PENTURTLE=ARG1 TSEND1(32) STACK(W1) %RETURN ! POSW(5):POSW(6):POSW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN ! POSW(8): ;! GT42 DISPLAY COORDOK(ARG2); %IF JUMPFLAG=1 %THEN %RETURN COORDOK(ARG3); %IF JUMPFLAG=1 %THEN %RETURN XTURTLE=ARG2 YTURTLE=ARG3 HDTURTLE= MOD360(W1) PENTURTLE=W2 POINT(XTURTLE+512,YTURTLE+512) CALC TURTLE STACK(W1) %RETURN; ! END POSITION ! ! SYSFUN(179):; ! ARCLEFT ARG1=CHDEVARG %IF JUMPFLAG=1 %THEN STACK(ARG1) %ANDRETURN ARG2=CHDEVARG %IF JUMPFLAG=1 %THEN STACK(ARG2) %ANDRETURN ARG3=0 ; ! TO INDICATE LEFT ! ARG1=ANG,ARG2=RAD W1=TRUE ->ARCLSW(TDEV) ! ARCLSW(1):ARCLSW(2):; ! PLOTTERS %IF ARG1=0 %THEN ->ARCL1 %IF ARG2=0 %THEN ->LEFTSW(1); ! ZERO RAD. DO LEFT(ANG) XC=INT(-ARG2*SIN(HDTURTLE/57.3)*32) YC=INT(ARG2*COS(HDTURTLE/57.3)*32) RW1=2.0*ARG2*SIN(ARG1/114.6) DX=RW1*COS((HDTURTLE+ARG1/2.0)/57.3) DY=RW1*SIN((HDTURTLE+ARG1/2.0)/57.3) CIRCLETEST(ARG3,ARG2,ARG1) %IF JUMPFLAG=1 %THENRETURN W1=INT(0.5*MOD(ARG2)*ARG1/360.0*32) %IF PENTURTLE=DOWN %THENSTART BINARG(1,0) BINARG(2,4) SENDBIN(0,2); ! PENDOWN %FINISH %IF W1#0 %THENSTART BINARG(1,4) BINARG(2,XC) BINARG(3,YC) BINARG(4,W1) SENDBIN(0,4); ! OUTCRCLV(XC,YC,W1) %FINISH XTURTLE=XTURTLE+DX YTURTLE=YTURTLE+DY BINARG(1,1) BINARG(2,INTPT(XTURTLE)<<5) BINARG(3,INTPT(YTURTLE)<<5); ! OUTLIN(X,Y) TO FINISH SENDBIN(0,3) %IF PENTURTLE=DOWN %THENSTART BINARG(1,0) BINARG(2,0) SENDBIN(0,2) %FINISH W1=TRUE ->LEFTSW(1); ! TO DO HDTURTLE AND INDICATOR ARCL1:STACK(TSTATE) %RETURN ! ARCLSW(3):; ! DISPLAY %IF ARG1=0 %THEN ->ARCL2 %IF ARG2=0 %THEN ->LEFTSW(3) XC=INT(-ARG2*SIN(HDTURTLE/57.3)*32) YC=INT(ARG2*COS(HDTURTLE/57.3)*32) RW1=2.0*ARG2*SIN(ARG1/114.6) DX=RW1*COS((HDTURTLE+ARG1/2.0)/57.3) DY=RW1*SIN((HDTURTLE+ARG1/2.0)/57.3) CIRCLETEST(ARG3,ARG2,ARG1) %IF JUMPFLAG=1 %THENRETURN W1=INT(0.5*MOD(ARG2)*ARG1/360.0*32) %IF PENTURTLE=DOWN %AND W1#0 %THENSTART BINARG(1,11) BINARG(2,XC) BINARG(3,YC) BINARG(4,W1) SENDBIN(0,4); ! DCIRCLV(XC,YX,W1) %FINISHELSESTART BINARG(1,5) BINARG(2,INTPT(DX+FRACPT(XTURTLE))<<5) BINARG(3,INTPT(DY+FRACPT(YTURTLE))<<5) SENDBIN(0,3); ! DSETV(DX,DY) %FINISH XTURTLE=XTURTLE+DX YTURTLE=YTURTLE+DY HDTURTLE=MOD360(HDTURTLE+ARG1) ARCL2:%IF PENTURTLE=DOWN %THEN BINARG(1,6) %ELSE BINARG(1,4) BINARG(2,INTPT(XTURTLE)<<5) BINARG(3,INTPT(YTURTLE)<<5) SENDBIN(0,3); ! DPOINT OR DSET TO FINISH STACK(TSTATE) %RETURN ! ARCLSW(4):; ! TURTLE %IF ARG1=0 %THEN STACK(TSTATE) %ANDRETURN %IF ARG2=0 %THEN ->LEFTSW(4) TARCLEFT(ARG2,ARG1) %IF JUMPFLAG=1 %THENRETURN STACK(TSTATE) %RETURN ! ARCLSW(5):ARCLSW(6):ARCLSW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN ! ARCLSW(8): ;! GT42 %IF ARG1=0 %THEN STACK(TSTATE) %ANDRETURN %IF ARG2=0 %THEN ->LEFTSW(8) GTARCLEFT(ARG2,ARG1) %IF JUMPFLAG=1 %THENRETURN STACK(TSTATE) %RETURN; ! END ARCLEFT ! ! SYSFUN(180):; ! ARCRIGHT ARG1=CHDEVARG %IF JUMPFLAG=1 %THEN STACK(ARG1) %ANDRETURN ARG2=CHDEVARG %IF JUMPFLAG=1 %THEN STACK(ARG2) %ANDRETURN ARG3=1 ; ! TO INDICATE RIGHT ! ARG1=ANG,ARG2=RAD W1=TRUE ->ARCRSW(TDEV) ! ARCRSW(1):ARCRSW(2):; ! PLOTTERS ARG2=-ARG2 ARG1=-ARG1 ->ARCLSW(1) ! ARCRSW(3):; ! DISPLAY ARG2=-ARG2 ARG1=-ARG1 ->ARCLSW(3) ! ARCRSW(4):; ! TURTLE ARG2=-ARG2 ->ARCLSW(4) ! ARCRSW(5):ARCRSW(6):ARCRSW(7):; ! PUNCH,MUSIC,MECCANO ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN ! ARCRSW(8): ;! GT42 ARG2=-ARG2 -> ARCLSW(8); ! END ARCRIGHT ! ! SYSFUN(181):; ! PUNCH ->PNSW(TDEV) ! PNSW(1):PNSW(2):PNSW(3):PNSW(4):PNSW(6):PNSW(7):PNSW(8): ! ALL BUT PUNCH ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN ! PNSW(5):; ! PUNCH ARG1=CHDEVARG %IF ARG1=ERR %THENRETURN %IF ARG1>255 %THENSTART ERROR('NUMBER TOO BIG TO BE PUNCHED',EMPTY,1,IN) %RETURN %FINISH %IF ARG1<0 %THENSTART ERROR('NEGATIVE NUMBERS CANNOT BE PUNCHED',EMPTY,1,IN) %RETURN %FINISH BINARG(1,0) BINARG(2,ARG1) SENDBIN(0,2); ! PUNCH(ARG1) STACK(TRUE) %RETURN; ! END PUNCH ! ! SYSFUN(182):; ! RUNOUT ->RNSW(TDEV) ! RNSW(1):RNSW(2):RNSW(3):RNSW(4):RNSW(6):RNSW(7):RNSW(8): ! ALL BUT PUNCH ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN ! RNSW(5):; ! PUNCH BINARG(1,1) SENDBIN(0,1); ! RUNOUT STACK(TRUE) %RETURN; ! END RUNOUT ! ! ! FDSW(0):BDSW(0):LEFTSW(0):RIGHTSW(0):LIFTSW(0):DROPSW(0):HOOTSW(0): CENSW(0):CLSW(0):WHSW(0):HERESW(0):XCORSW(0):YCORSW(0):HDSW(0):PENSW(0): SETXSW(0):SETYSW(0):SETHSW(0):POSW(0):ARCLSW(0):ARCRSW(0):PNSW(0): RNSW(0):NOTESW(0):PLAYSW(0):MOTASW(0):MOTBSW(0):ROTSW(0):PAIRSW(0): ERROR('NO TURTLE DEVICE ASSIGNED TO DO ',FN,1,IN) %RETURN ! ! ! SYSFUN(183):; ! PLOTTERA CLAIMDEVICE(1) %IF JUMPFLAG=1 %THENRETURN ->CENSW(1); ! END PLOTTERA ! ! SYSFUN(184):; ! PLOTTERB CLAIMDEVICE(2) %IF JUMPFLAG=1 %THENRETURN ->CENSW(2); ! END PLOTTERB ! ! SYSFUN(185):; ! DISPLAY CLAIMDEVICE(3) %IF JUMPFLAG=1 %THENRETURN BINARG(1,0);SENDBIN(0,1); ! CLEARDIS ->CENSW(3); ! END DISPLAY ! ! SYSFUN(186):; ! TURTLE CLAIMDEVICE(4) %IF JUMPFLAG=1 %THENRETURN XTURTLE=0;YTURTLE=0;HDTURTLE=0;PENTURTLE=DOWN TSEND1(32); ! PUT PEN DOWN STACK(TRUE) %RETURN; ! END TURTLE ! ! SYSFUN(187):; ! TAPE CLAIMDEVICE(5) %IF JUMPFLAG=1 %THENRETURN ->RNSW(5); ! END TAPE ! ! SYSFUN(188):; ! FREE %IF TDEV=0 %THENSTART ERROR('YOU ARE NOT CONNECTED TO ANY DEVICE',EMPTY,1,IN) %RETURN %FINISH WSTR1=TDEVNAMES(TDEV) %IF TDEV=8 %THEN DISCONNECT(MASNUM.'EXEC26') FREEDEVICE PRSTRING(WSTR1.' DISCONNECTED');NOOLINE(1) STACK(TRUE) %RETURN; ! END FREE ! ! SYSFUN(189):; ! CLESET %IF TDEV=0 %THENSTART ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN %FINISH CLESET STACK(TRUE) %RETURN; ! END CLESET ! ! ! ! SYSFUN(191):; ! MUSIC CLAIMDEVICE(6) %IF JUMPFLAG=1 %THENRETURN STACK(TRUE) %RETURN; ! END MUSIC ! ! SYSFUN(192):; ! MECCANO CLAIMDEVICE(7) %IF JUMPFLAG=1 %THENRETURN XTURTLE=0;YTURTLE=0;HDTURTLE=0;PENTURTLE=DOWN STACK(TRUE) %RETURN; ! END MECCANO ! ! ! ! ! SYSFUN(200): ;! GT42 CLAIMDEVICE(8) %IF JUMPFLAG=1 %THENRETURN LOAD42(GT42 EXEC) MODIFY EXEC CLEAR 42 POINT(512,512) GRAPHP = INIT GRAPHP PICTURE POINTER = CORE BOTTOM SET42(CHTXT) HDTURTLE=0 XTURTLE=0 YTURTLE=0 PENTURTLE=DOWN STACK(TRUE) %RETURN; ! END GT42 ! ! SYSFUN(201):; ! HIDE (HIDETURTLE FOR GT42???) %IF TDEV#8 %THEN ERROR ('DEVICE CANNOT DO ',FN,1,IN) %ANDRETURN HIDE TURTLE STACK(TRUE) %RETURN; ! END HIDE ! ! ! ! ! SYSFUN(210): ;! PICTURE / PIC %IF TDEV#8 %THEN ERROR (%C 'DEVICE CANNOT DO ',FN,1,IN) %ANDRETURN ARG1=UNSTACK %IF ARG1&WM#WM %THEN ERROR ( %C 'PICTURE NEEDS A WORD FOR FIRST ARG-',ARG1,1,IN) %C %AND %RETURN W1=ARG1>>8 ;! GET INDEX FROM ARG TSTOR(1)=XTURTLE TSTOR(2)=YTURTLE TSTORI(3)=HDTURTLE TSTORI(4)=PENTURTLE CURPIC=CONSG(INT(YTURTLE)+512,CONSG(INT(XTURTLE)+512 %C ,CONSG(CURMODE,NIL))) GMODE=0 DEF PICTURE=1 ;! SET COMPILE FLAG STKSYS(IN) EVAL(IN,EACHVAL) ;! AND EXECUTE DRAWING FN IN=UNSTKSYS %IF JUMPFLAG = 1 %THEN DEF PICTURE=0 %ANDRETURN INDEX42(W1)_PTR=REVERSE(CURPIC) ;! AND DEF PICTUREE PICTURE DEFINITION INDEX42(W1)_PTR42=0 ;! SET PICTURE FLAG XTURTLE=TSTOR(1) YTURTLE=TSTOR(2) HDTURTLE=TSTORI(3) PENTURTLE=TSTORI(4) DEF PICTURE=0 ;! RESET MARKER STACK(TSTATE) ;!RETURN PIC NAME AS RESULT %RETURN ! ! ! ! ! %RETURN SYSFUN(211): ;! INCLUDE / INC %IF TDEV#8 %THEN ERROR (%C 'YOU NEED THE GT42 TO RUN MOVIES ',EMPTY,1,IN) %ANDRETURN %IF FRAMEFLAG=0 %THEN ERROR (%C 'YOU ARE NOT INSIDE A FRAME ',EMPTY,1,IN) %ANDRETURN ARG1=UNSTACK ;! GET NAME %IF ARG1&WM#WM %THEN ERROR ( %C 'INCLUDE NEEDS A WORD ARGUMENT-',ARG1,1,IN) %AND %RETURN W1=ARG1>>8 %IF INDEX42(W1)_PTR=0 %THEN ERROR ( %C 'PICTURE DOES NOT EXIST-',ARG1,1,IN) %AND %RETURN %IF INDEX42(W1)_PTR42=0 %THEN INC (W1) ;! PICTURE NOT ALREADY IN !DUMP CODE TO INCLUDE PICTURE AT CURRENT CRANE COORDS !*** WHEN MOVIE IS RUN INDEX42(W1)_MODE=CURMODE CURFRAME=CONSG(YCRANE,CONSG(XCRANE,CONSG(CURMODE,CONSG(3, %C CONSG(INDEX42(W1)_PTR42,CONSG(SETN,CURFRAME)))))) INDEX42(W1)_X=XCRANE ;! RECORD CURRENT COORDS INDEX42(W1)_Y = YCRANE STACK(TRUE) %RETURN ;! END-- INCLUDE ! SYSFUN(212): ;! ACTION %IF TDEV#8 %THEN ERROR ( %C 'YOU NEED THE GT42 TO RUN MOVIES',EMPTY,1,IN )%ANDRETURN %IF FRAMEFLAG# 0 %THEN ERROR ( %C 'ACTION INSIDE FRAME INVALID',EMPTY,1,IN) %AND%RETURN FRAMEFLAG=1 ;! SET FRAME FLAG CURFRAME=NIL ;! AND INITIALISE FRAMELIST SAVE PROMP=PROMP PROMP='A:' PROMPT(PROMP) %IF GRABLIST=NIL %START ;! CRANE ONLY INITIALISED ;!TO CENTRE WHEN NOTHING ;! IS CURRENTLY GRABBED XCRANE=512 YCRANE=512 %FINISH HDCRANE=0 ;!**CRANE HEADING 0 ON ENTRY %CYCLE W1=1,1,1022 ;! CLEAR MOVE CTRS INDEX42(W1)_MOVED=0 INDEX42(W1)_LAST MOVE TIME = FRAME TIME %REPEAT STACK(TRUE) %RETURN ! SYSFUN(213): ;! CUT %IF TDEV#8 %THEN ERROR ( %C 'YOU NEED THE GT42 TO RUN MOVIES' ,EMPTY,1,IN) %ANDRETURN %IF FRAMEFLAG=0 %THEN ERROR ( %C 'CUT OUTSIDE FRAME INVALID',EMPTY,1,IN) %AND %RETURN FRAMEFLAG=0 ;! END OF FRAME %IF CURFRAME=NIL %THENSTART ;! SPECIAL CASE -- ;! NULL FRAME DECLARED SO PAD ;! FOR "FRAMETIME" TIME UNITS W2=CONSG(WAIT,CONSG(FRAME TIME,NIL)) CURMOVIE = CONS(W2,CURMOVIE) PROMP=SAVE PROMP; PROMPT(PROMP) STACK(TRUE) %RETURN %FINISH %CYCLE W1 = 1,1,FRAME TIME ;! RESET MOVIE RECORD ;! 'MOVIE RECORD' IS A ;!A TABLE OF LISTS MOVIE RECORD(W1) = NIL %REPEAT ! CURRENT MOVIE TIME = 1 W1=CURFRAME %WHILE W1#NIL %CYCLE ARG1=HD(W1)//256 %IF ARG1>0 %AND ARG1&CRANE MASK=CRANE MARK %START ;! MOVE GROUP FOUND, EG ;! [MARK DY DX PTR TO INDEX ---] W1=TL(W1) ;! 'POP' MARK W2 = HD(TL(TL(W1))) >> 8 ;! AND GET PTR TO INDEX %IF HD(W1)>>8 = CRANE MARK %THEN %C W4=INT(HD(TL(W1))/INDEX42(W2)_MOVED * FRAME TIME) %C %ELSESTART ;! COULD BE A 'HOLD' MARK RW1 = SQRT((HD(W1)/256.0)**2 + (HD(TL(W1))/256.0)**2) W4 = INT(RW1/INDEX42(W2)_MOVED * FRAME TIME) ;! CALCULATE TIME THIS MOVE ;! WILL TAKE. ( = FRACTION OF ;! OF TOTAL DISTANCE MOVED * ;! TIME TAKEN FOR FRAME ) %FINISH W4 = 1 %IF W4 <= 0 W4 = FRAME TIME %IF W4 > FRAME TIME WPTR1 == INDEX42(W2)_LAST MOVE TIME WPTR1 = WPTR1 - W4 WPTR1 = 1 %IF WPTR1 <= 0 WPTR1 = FRAME TIME %IF WPTR1 > FRAME TIME ;! WPTR1 NOW POINTS TO THE ;! THE APPROPRIATE MOVIE ;! RECORD %IF HD(W1)>>8 # CRANE MARK %THEN %C MOVIE RECORD (WPTR1) = %C CONS(HD(W1),CONS(HD(TL(W1)),CONSG(W4, CONSG ( %C INDEX42(W2)_PTR42+2,CONSG(PMOV,MOVIE RECORD (WPTR1)))))) ;! ADD CELL TO LIST ! CURRENT MOVIE TIME = WPTR1 ;! UPDATE CURRENT MOVIE ;! CLOCK SO THAT ANY INCLUSIONS ;! OR OMMISIONS ;! CAN BE ADDED TO ;! THE APPROPRIATE MOVIE ;! RECORD W1 = TL(TL(TL(W1))) ;! POP CELL FROM LIST %FINISH %ELSE %START ARG1 = HD(W1) ARG2 = MOVIE RECORD(CURRENT MOVIE TIME) LASTPUT MOVIE RECORD (CURRENT MOVIE TIME)= UNSTACK W1 = TL(W1) %FINISH %REPEAT ! !*** FRAME NOW DISSSEMBLED INTO TIME SLICES ON MOVIE !*** RECORD ARRAY. ! !*** NOW REASSEMBLE INTO CURFRAME (BACKWARDS, OF COURSE) !*** AND DUMP APPROPRIATE 'WAIT' INSTRUCTIONS ! CURFRAME = NIL W1 = FRAME TIME +1 %CYCLE W2 = 0 ;! NO OF OUTSTANDING TIME ;! INNCREMENTS W1=W1-1 %AND W2=W2+1 %UNTIL W1 = 0 %C %OR MOVIE RECORD(W1) # NIL ;! FIND LENGTH OF NEXT WAIT %IF W1=0 %THENSTART ;! END OF FRAME CURMOVIE=CONS(REVERSE(CURFRAME),CURMOVIE) ;! ADD TO MOVIE LIST STACK(TRUE) PROMP = SAVE PROMP; PROMPT (PROMP) %RETURN %FINISH ARG2=CONSG (W2, CONSG(WAIT, MOVIE RECORD(W1))) ;! CURRENT TIME SLICE OF ;! FRAME ARG1=CURFRAME ;! ARGS LIKE THIS FOR LPUT CURFRAME = APPENDL(ARG1,ARG2) ;! FUNCTION ! ! *** LOTS OF LIST SPACE BEING CLAIMED/FREED, SO CHECK FOR ! *** POSSIBLE GARBAGE COLLECTS ! %IF CLECTFLG = 1 %THENSTART ;! GARBAGE COLLECT NEEDED %CYCLE W4=1,1,W1 ;! PUT REMAINING MOVIE RECORD ;!INTO COLLECTABLE SPACE STACK(MOVIE RECORD(W4)) %REPEAT STKSYS(IN) ; STKSYS(VAL) ;! SYSTEM SPACE COLLECT (ENVIR) VAL=UNSTKSYS ; IN=UNSTKSYS ;! RESTORE %CYCLE W4 = W1,-1,1 MOVIE RECORD(W4)=UNSTACK %REPEAT %FINISH %REPEAT ! ! ! ! SYSFUN(214): ;! ROLLMOVIE / ROLL %IF TDEV#8 %THEN ERROR ('DEVICE CANNOT DO ',FN,1,IN) %C %ANDRETURN %IF FRAMEFLAG#0 %THEN ERROR (%C 'CANNOT ROLL MOVIE INSIDE A FRAME',EMPTY,1,IN) %AND%RETURN SET42(CHPIC) ! *** TUURTLE IS SWITCHED OFF FOR DURATION OF MOVIE ! W4 = SHOW TURTLE 42 ;! SAVE CURRENT SHOWN STATE %IF W4 = 1 %THEN HIDE TURTLE LBR ;! NEST COMMAND GROUP %CYCLE W1=0,1,1022 ;! OMIT ANY CURRENTLY %IF INDEX42(W1)_PTR42#0 %START ;!INCLUDED PICTURES CH3(SETN); CH3(INDEX42(W1)_PTR42) CH3(2); CH3(DJUMP); CH3(INDEX42(W1)_FADDR) ;! OMIT GROUP %FINISH %REPEAT RBR ;! AND CLOSE GROUP W1=REVERSE(CURMOVIE) STACK(TRUE) %CYCLE %IF W1 = NIL %START ;! END OF MOVIE SHOW TURTLE %IF W4 = 1 ;! RESTORE ORIGINAL TURTLE STATE %RETURN %FINISH W3=HD(W1) ;! NEXT FRAME W1=TL(W1) LBR ;! DEFER EXECUTION OF FRAMES %WHILE W3#NIL %THEN %CYCLE CH3(HD(W3)//256) W3=TL(W3) %REPEAT RBR %REPEAT %RETURN ! SYSFUN(215): ;! CRANE FORWARD (VERSION 2 %IF TDEV#8 %THEN ERROR('DEVICE CANNOT DO ',FN,1,IN) %ANDRETURN ARG1=UNSTACK %IF ARG1&NM#NM %THEN ERROR (%C 'CRANEFORWARD NEEDS A NUMBER-',ARG1,1,IN) %ANDRETURN %IF FRAMEFLAG= 0 %THEN ERROR (%C 'CRANE MOVEMENT OUTSIDE FRAME INVALID',EMPTY,1,IN) %ANDRETURN W1=ARG1//256 ;! CONVERT TO ORDINARY NUM CFD: W2=INTPT(W1*COS(HDCRANE/57.3)) ;!NEW COORDS W3=INTPT(W1*SIN(HDCRANE/57.3)) ;! W2=DX : W3=DY XCRANE=XCRANE+W2 YCRANE=YCRANE+W3 ARG2=GRABLIST ;! NOW MOVE ANY PICTURES %WHILE ARG2#NIL %CYCLE ;! CURRENTLY 'GRABBED' W4=HD(ARG2)>>8 INDEX42(W4)_MOVED=INDEX42(W4)_MOVED+IMOD(W1) CURFRAME = CONSG(CRANE MARK, CONSG(W3, CONSG(W2, %C CONSG(W4, CURFRAME)))) ;! ADD CELL TO FRAMELIST INDEX42(W4)_X=INDEX42(W4)_X+W2 INDEX42(W4)_Y=INDEX42(W4)_Y + W3 ARG2=TL(ARG2) %REPEAT STACK(TRUE) %RETURN ! SYSFUN(216): ;! CRANEBACKWARD %IF TDEV#8 %THEN ERROR ('DEVICE CANNOT DO ',FN,1,IN) %ANDRETURN ARG1=UNSTACK %IF ARG1&NM#NM %THEN ERROR (%C 'CRANEBACKWARD NEEDS A NUMBER-',ARG1,1,IN) %ANDRETURN %IF FRAMEFLAG=0 %THEN ERROR (%C 'CRANE MOVEMENT OUTSIDE FRAME INVALID',EMPTY,1,IN) %ANDRETURN W1=-(ARG1//256) -> CFD ! SYSFUN(217): ;! CRANE LEFT / CLEFT %IF TDEV#8 %THEN ERROR ('DEVICE CANNOT DO ',FN,1,IN) %ANDRETURN ARG1=UNSTACK %IF ARG1&NM#NM %THEN ERROR (%C 'CRANELEFT NEEDS A NUMBER-',ARG1,1,IN) %ANDRETURN %IF FRAMEFLAG=0 %THEN ERROR (%C 'CRANE MOVEMENT OUTSIDE FRAME INVALID',EMPTY,1,IN) %C %ANDRETURN HDCRANE=MOD360(ARG1>>8+HDCRANE) STACK(TRUE) %RETURN ! SYSFUN(218): ;! CRANE RIGHT/ CRIGHT %IF TDEV#8 %THEN ERROR ('DEVICE CANNOT DO ',FN,1,IN) %AND %RETURN ARG1=UNSTACK %IF ARG1&NM#NM %THEN ERROR (%C 'CRANERIGHT NEEDS A NUMBER',ARG1,1,IN) %ANDRETURN %IF FRAMEFLAG=0 %THEN ERROR (%C 'CRANE MOVEMENT OUTSIDE FRAME INVALID',EMPTY,1,IN) %C %AND %RETURN HDCRANE=MOD360(HDCRANE-ARG1>>8) STACK(TRUE) %RETURN ! SYSFUN(219): ;! NEWMOVIE %IF TDEV#8 %THEN ERROR('DEVICE CANNOT DO ',FN,1,IN) %ANDRETURN CURMOVIE=NIL ;! INITIALISES CURRENT MOVIE LIST PROMP=SAVE PROMP %UNLESS FRAMEFLAG=0 FRAMEFLAG=0 ;!MAKE SURE NOT IN FRAME PROMPT(PROMP) ;!AND RESTORE PROMPT GRABLIST=NIL STACK(TRUE) %RETURN ! SYSFUN(220): ;! GRAB (VERSION 2) %IF TDEV#8 %THEN ERROR('DEVICE CANNOT DO ',FN,1,IN) %ANDRETURN ARG1=UNSTACK %IF ARG1&WM#WM %THEN ERROR (%C 'I CAN''T GRAB ',ARG1,1,IN) %ANDRETURN %IF FRAMEFLAG=0 %THEN ERROR (%C 'GRAB NOT VALID OUTSIDE FRAME',EMPTY,1,IN) %ANDRETURN W1=ARG1>>8 %IF INDEX42(W1)_PTR42=0 %THEN ERROR (%C 'GRAB FAILS - PICTURE NOT IN GT42 -',ARG1,1,IN) %C %ANDRETURN %IF AMONGQ(ARG1,GRABLIST)=1 %THEN ERROR ( %C 'I HAVE ALREADY GRABBED ',ARG1,1,IN) %ANDRETURN GRABLIST=CONS(ARG1,GRABLIST) XCRANE=INDEX42(W1)_X ;! MOVE CRANE TO PICTURE YCRANE=INDEX42(W1)_Y ;! COORDINATES STACK (TRUE) %RETURN ! SYSFUN(221): ;! RELEASE (VERSION2) %IF TDEV#8 %THEN ERROR('DEVICE CANNOT DO ',FN,1,IN) %ANDRETURN ARG1=UNSTACK %IF ARG1&WM#WM %THEN ERROR (%C 'I CAN''T RELEASE ',ARG1,1,IN) %ANDRETURN %IF FRAMEFLAG=0 %THEN ERROR (%C 'RELEASE NOT VALID OUTSIDE FRAME',EMPTY,1,IN) %ANDRETURN %IF AMONGQ(ARG1,GRABLIST)=0 %THEN ERROR ( %C 'I HAVE NOT GRABBED ',ARG1,1,IN) %ANDRETURN GRABLIST=WITHOUT(ARG1,GRABLIST) STACK (TRUE) %RETURN ! SYSFUN(222): ;!SET CRANE/ SETC %IF TDEV#8 %THEN ERROR ('DEVICE CANNOT DO ',FN,1,IN) %ANDRETURN ARG1=UNSTACK %IF FRAMEFLAG=0 %THEN ERROR (%C 'CRANE MOVEMENT OUTSDIE FRAME INVALID',EMPTY,1,IN) %C %AND %RETURN %IF ARG1&LM#LM %THEN ERROR ( %C 'SETCRANE NEEDS A LIST-',ARG1,1,IN) %AND %RETURN ARG2=ARG1 ;! SAVE ARGUMENT W1=GETNUMB(ARG1,'SETCRANE') ;! CHECK ALL CRANE %IF W1=-100000 %THENRETURN W2=GETNUMB(ARG1,'SETCRANE') ;!COORDS BEFORE %RETURNIF W2=-100000 W3=GETNUMB(ARG1,'SETCRANE') ;!ALTERING POSITION %RETURNIF W3 =-100000 XCRANE=CHECKXY(W1)+512 YCRANE=CHECKXY(W2)+512 HDCRANE=MOD360(W3) STACK(TRUE) %RETURN ! SYSFUN(223): ;!OMIT %IF TDEV#8 %THEN ERROR('DEVICE CANNOT DO ',FN,1,IN) %ANDRETURN ARG1=UNSTACK ;! GET PICTURE NAME %IF ARG1&WM#WM %THEN ERROR ( %C 'OMIT NEEDS A WORD-',ARG1,1,IN) %AND %RETURN %IF FRAMEFLAG=0 %THEN ERROR ( %C 'OMIT OUTSIDE FRAME INVALID',EMPTY,1,IN) %AND %RETURN W1=ARG1>>8 %IF INDEX42(W1)_PTR42=0 %THEN ERROR ( %C 'OMIT FAILS - PICTURE NOT IN GT42 -',ARG1,1,IN) %C %ANDRETURN GRABLIST=WITHOUT(ARG1,GRABLIST) CURFRAME=CONSG(INDEX42(W1)_FADDR,CONSG(DJUMP,CONSG %C (2,CONSG(INDEX42(W1)_PTR42,CONSG(SETN,CURFRAME))))) STACK(TRUE) %RETURN ! %RETURN ! SYSFUN(224): ;! GRABLIST %IF TDEV#8 %THEN ERROR('DEVICE CANNOT DO ',FN,1,IN) %ANDRETURN STACK(GRABLIST) %RETURN %RETURN; ! END GRABLIST ! SYSFUN(228): ;! CRANEHERE %IF TDEV#8 %THEN ERROR('DEVICE CANNOT DO ',FN,1,IN) %ANDRETURN %IF FRAMEFLAG=0 %THEN ERROR ( %C 'CRANE COMMAND OUTSIDE FRAME NOT VALID',EMPTY,1,IN) %C %ANDRETURN W2=XCRANE-512 W3=YCRANE-512 W1=CONSG(XCRANE,CONSG(YCRANE,CONSG(HDCRANE,NIL))) STACK(W1) %RETURN ! %RETURN ! SYSFUN(225): ;! CAPTION %IF TDEV#8 %THEN ERROR('DEVICE CANNOT DO ',FN,1,IN) %ANDRETURN CAPFLAG=1 ARG1=UNSTACK PRINTEL(ARG1) CAPFLAG=0 STACK(ARG1) %RETURN ! %RETURN ! SYSFUN(226): ;! FRAMESPEED N %IF TDEV#8 %THEN ERROR('DEVICE CANNOT DO ',FN,1,IN) %ANDRETURN ARG1=UNSTACK %IF ARG1 & NM # NM %THEN ERROR ( %C 'FRAME SPEED NEEDS A NUMBER',ARG1,1,IN) %ANDRETURN %IF FRAMEFLAG=1 %THEN ERROR (%C 'CANNOT ADJUST FRAMESPEED WITHIN A FRAME',EMPTY,1,IN) %C %ANDRETURN %IF ARG1< 0 %THEN ERROR (%C 'FRAMESPEED NEEDS A +VE NUMBER',ARG1,1,IN) %ANDRETURN FRAMETIME=ARG1>>8 STACK(TRUE) %RETURN ! SYSFUN(227): ;! KILL FRAME %IF TDEV# 8 %THEN ERROR ('DEVICE CANNOT DO ',FN,1,IN) %ANDRETURN %IF FRAMEFLAG=0 %THEN ERROR (%C 'KILLFRAME FAILS - NO FRAME CURRENT',EMPTY,1,IN) %C %AND %RETURN FRAMEFLAG=0 PROMPT(SAVEPROMP) PRSTRING('*** FRAME KILLED '.TIME.' ***') NOOLINE(1) STACK(TRUE) %RETURN ! SYSFUN(229): ;! WIPE (CLEARS DYNAMIC DISPLAY SPACE) ! SET CORE POINTER (CORE BOTTOM) %CYCLE W1 = 0 , 1, 1022 INDEX42(W1)_PTR42 = 0 %REPEAT CURMOVIE = NIL ;! RESET MOVIE LIST STACK(TRUE) %RETURN; ! END WIPE ! ! SYSFUN(230):; ! NOTE (FOR MUSIC BOX) ->NOTESW(TDEV) ! NOTESW(1):NOTESW(2):NOTESW(3):NOTESW(4):NOTESW(5):NOTESW(7):NOTESW(8): ! ALL BUT MUSIC ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN ! NOTESW(6):; ! MUSIC READYNUM;%IF JUMPFLAG=1 %THENRETURN %UNLESS 0<=ARG1<=48 %THENSTART ERROR('THE FIRST INPUT FOR NOTE MUST LIE BETWEEN 0 AND 48. IT WAS GIVEN ', ARG1<<8!NM,1,IN) %RETURN %FINISH %UNLESS 1<=ARG2<=256 %THENSTART ERROR('THE SECOND INPUT FOR NOTE MUST LIE BETWEEN 1 AND 256. IT WAS GIVEN ', ARG2<<8!NM,1,IN) %RETURN %FINISH BINARG(1,1) BINARG(2,(ARG1<<8)!(ARG2-1)) SENDBIN(0,2) STACK(TRUE) %RETURN; ! END NOTE ! ! SYSFUN(231):; ! PLAY ->PLAYSW(TDEV) ! PLAYSW(1):PLAYSW(2):PLAYSW(3):PLAYSW(4):PLAYSW(5):PLAYSW(7):PLAYSW(8): ! ALL BUT MUSIC ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN ! PLAYSW(6):; ! MUSIC BINARG(1,0) SENDBIN(0,1) STACK(TRUE) %RETURN; ! END PLAY ! ! SYSFUN(232):; ! REST SYSFUN(233):; ! A0 SYSFUN(234):; ! AS0 SYSFUN(235):; ! B0 SYSFUN(236):; ! C0 SYSFUN(237):; ! CS0 SYSFUN(238):; ! D0 SYSFUN(239):; ! DS0 SYSFUN(240):; ! E0 SYSFUN(241):; ! F0 SYSFUN(242):; ! FS0 SYSFUN(243):; ! G0 SYSFUN(244):; ! GS0 SYSFUN(245):; ! A1 SYSFUN(246):; ! AS1 SYSFUN(247):; ! B1 SYSFUN(248):; ! C1 SYSFUN(249):; ! CS1 SYSFUN(250):; ! D1 SYSFUN(251):; ! DS1 SYSFUN(252):; ! E1 SYSFUN(253):; ! F1 SYSFUN(254):; ! FS1 SYSFUN(255):; ! G1 SYSFUN(256):; ! GS1 SYSFUN(257):; ! A2 SYSFUN(258):; ! AS2 SYSFUN(259):; ! B2 SYSFUN(260):; ! C2 SYSFUN(261):; ! CS2 SYSFUN(262):; ! D2 SYSFUN(263):; ! DS2 SYSFUN(264):; ! E2 SYSFUN(265):; ! F2 SYSFUN(266):; ! FS2 SYSFUN(267):; ! G2 SYSFUN(268):; ! GS2 SYSFUN(269):; ! A3 SYSFUN(270):; ! AS3 SYSFUN(271):; ! B3 SYSFUN(272):; ! C3 SYSFUN(273):; ! CS3 SYSFUN(274):; ! D3 SYSFUN(275):; ! DS3 SYSFUN(276):; ! E3 SYSFUN(277):; ! F3 SYSFUN(278):; ! FS3 SYSFUN(279):; ! G3 SYSFUN(280):; ! GS3 ! ! STACK((SW-232)<<8 ! NM) %RETURN ! ! SYSFUN(281):; ! MOTORA ->MOTASW(TDEV) ! MOTASW(1):MOTASW(2):MOTASW(3):MOTASW(4):MOTASW(5):MOTASW(6):MOTASW(8): ! ALL BUT MECCANO ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN ! MOTASW(7):; ! MECCANO ->DROPSW(4); ! TURTLE DROP FOR NOW ! ! SYSFUN(282):; ! MOTORB ->MOTBSW(TDEV) ! MOTBSW(1):MOTBSW(2):MOTBSW(3):MOTBSW(4):MOTBSW(5):MOTBSW(6):MOTBSW(8): ! ALL BUT MECCANO ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN ! MOTBSW(7):; ! MECCANO ->LIFTSW(4); ! TURTLE LIFT FOR NOW ! ! SYSFUN(283):; ! ROTATE ARG1=CHDEVARG %IF ARG1=ERR %THENRETURN ->ROTSW(TDEV) ! ROTSW(1):ROTSW(2):ROTSW(3):ROTSW(4):ROTSW(5):ROTSW(6):ROTSW(8): ! ALL BUT MECCANO ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN ! ROTSW(7):; ! MECCANO ->FDSW(4); ! TURTLE FORWARD FOR NOW ! ! SYSFUN(284):; ! PAIR ARG1=CHDEVARG %IF ARG1=ERR %THENRETURN ->PAIRSW(TDEV) ! PAIRSW(1):PAIRSW(2):PAIRSW(3):PAIRSW(4):PAIRSW(5):PAIRSW(6):PAIRSW(8): ! ALL BUT MECCANO ERROR('DEVICE CANNOT DO ',FN,1,IN) %RETURN ! PAIRSW(7):; ! MECCANO ->LEFTSW(4); ! TURTLE LEFT FOR NOW ! ! ! ! ! ! ! %END; ! END APPLYSYS ! ! ! ! ! %ROUTINE EVAL(%INTEGER IN,%INTEGERNAME EACHVAL) %INTEGER FN,FUNSPEC,TYPE,ARGNO,PARMLIST,FUNLIST,USERENV %INTEGER WORK1,WORK2,TRACE,COUNT,SW,SAVEDEV %SWITCH SYSTR(0:2),USRTR(0:2),OUTR(0:2) %SWITCH EVALSW(0:15) %CONSTINTEGER MARKERMASK = X'FFFFFF0F' !??;PRINTSTRING("ENTERED EVAL");NEWLINE %IF QUITFLAG=1 %THENSTART; ! USER INT Q QUITFLAG=0;JUMPOUT=0;JUMPFLAG=1 %IF TDEV#0 %THEN CLESET; ! CLEAR AND RESET TURTLE DEVICE STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %AND LIBLOAD=0 %THENSTART HOLDFLAG=0 %IF IN=NIL %THEN STACK(VAL) %AND %RETURN %IF TDEV#0 %THENSTART CLESET ERROR('USER INTERRUPT - TURTLE DEVICE RESET',EMPTY,1,IN) %RETURN %FINISH ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN %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 %IF IN&MARKERMASK=NIL %THENSTART;STACK(VAL);%RETURN;%FINISH LP: %RETURN %IF IN=NIL FN=HD(IN) IN=TL(IN)&MARKERMASK TOP: SW=(FN>>4)&X'F'; ! SWITCH ON MARKER FN=FN&MARKERMASK; ! REMOVE MARKER ->EVALSW(SW) EVALSW(1):; ! QUOTES STACK(FN) ->LP EVALSW(2):; ! DOTS TOP1: WORK1=GETVAL(FN,ENVIR) %IF WORK1=UNDEF %THEN %START ERROR("NO VALUE HAS BEEN GIVEN TO VARIABLE - ",FN,0,IN) %IF JUMPFLAG=1 %THEN %RETURN ->TOP1 %FINISHELSE STACK(WORK1) ->LP EVALSW(4):; ! FUNCTION NAME ! SPECIAL TREATMENT IS REQUIRED FOR UNARY MINUS AND ANGLE BRACKETS %IF FN=UNMINUS %THEN STACK(NEGATE(UNSTACK)) %AND ->LP %IF FN=LANGBRKS %THEN %START WORK2=NIL WORK1=HD(IN) IN=TL(IN) %WHILE WORK1&MARKERMASK # RANGBRKS %THEN %CYCLE STKSYS(WORK2);STKSYS(IN) EVAL(WORK1,EACHVAL) IN=UNSTKSYS;WORK2=UNSTKSYS %IF JUMPFLAG=1 %THEN %RETURN WORK2=CONS(UNSTACK,WORK2) WORK1=HD(IN) IN=TL(IN) %REPEAT STACK(REVERSE(WORK2)) ->LP %FINISH; ! FINISH ANGLE BRACKETS FUNSPEC=FNVAL(FN>>8); ! GET FUNCTION SPEC TYPE=FUNSPEC&B4; ! GET FUNCTION TYPE %IF FNPARSE(FN>>8)=255 %THEN %START ERROR("FAULTY FIRST LINE OF PROCEDURE-",FN,0,IN) %IF JUMPFLAG=1 %THEN %RETURN ->EVALSW(4) %FINISH %IF FNPARSE(FN>>8)=0 %AND TYPE=USERPRE %THEN %START; ! FN NOT PARSED SINDEX=FNTEXT(FN>>8) SAVEDEV=DEVICE DEVICE=SRCE READINLINE(PROMP); ! INPUT FROM SOURCE TEXT PLEVEL=1 WORK1=PARSELINE(0) DEVICE=SAVEDEV %IF WORK1=FAULT %THEN %START ERROR("ERROR WHILE PARSING",FN,0,IN) %IF JUMPFLAG=1 %THEN %RETURN -> EVALSW(4) %FINISH FUNSPEC=FNVAL(FN>>8) TYPE=FUNSPEC&B4 %FINISH %IF FUNSPEC=0 %THENSTART; ! UNDEFINED ERROR('UNDEFINED PROCEDURE - ',FN,0,IN) %IF JUMPFLAG=1 %THENRETURN ->EVALSW(4) %FINISH %IF TYPE=SYSPRE %OR TYPE=USERPRE %OR TYPE=INFIX %THENSTART %IF TYPE=INFIX %THEN ARGNO=2 %ELSE %START %IF TYPE=SYSPRE %THEN ARGNO=(FUNSPEC&B3B)>>16 %ELSEC ARGNO=FUNSPEC&X'FF'; ! GET NUMBER OF ARGS %FINISH TRACE=(FUNSPEC&TRACEFLG)>>30 %IF TYPE=SYSPRE %OR TYPE=INFIX %THENSTART %IF STKPNT-ARGNO<0 %THENSTART ERROR("NOT ENOUGH ARGS FOR ",FN,1,IN) %RETURN %FINISH ->SYSTR(TRACE) SYSTR(2):STRTRACE(FN) %IF ARGNO#0 %THENSTART; ! ARGS EXIST SPACES(INDENT) %CYCLE WORK1=1,1,ARGNO; ! PRINT VALUES OF ARGS PRINTSTRING('ARG'.TOSTRING(WORK1+48).' = ') PRINTEL(STK(STKPNT+1-WORK1)) PRINTSTRING(', ') %REPEAT NOOLINE(1) %FINISH ->SYSTR(0) SYSTR(1):STRTRACE(FN) SYSTR(0):APPLYSYS(FUNSPEC&B2,FN,IN,EACHVAL) !??; PRINTSTRING("RETURNED FROM APPLYSYS");NEWLINE %FINISHELSESTART; ! FINISH SYSPRE,INFIX : START USERPRE FUNLIST=FUNSPEC&M16!LM; ! FUN NOW HAS USER DEF AS LIST PARMLIST=TL(TL(HD(FUNLIST))); ! PARAMETRS %IF JUMPFLAG=1 %THEN STACK(PARMLIST) %ANDRETURN USERENV=MAKEBIND(PARMLIST,ENVIR,FN) %IF USERENV=FAULT %THENSTART ERROR('NOT ENOUGH ARGS FOR ',FN,1,IN) %RETURN %FINISH ->USRTR(TRACE) USRTR(2):STRTRACE(FN) %IF ARGNO#0 %THENSTART SPACES(INDENT);WORK1=PARMLIST %CYCLE COUNT=1,1,ARGNO PRINTEL(HD(WORK1));PRINTSTRING(' = ') PRINTEL(BVALUE(USERENV-ARGNO+COUNT));PRINTSTRING(', ') WORK1=TL(WORK1) %REPEAT NOOLINE(1) %FINISH ->USRTR(0) USRTR(1):STRTRACE(FN) USRTR(0):STKSYS(IN);STKSYS(VAL); APPLYUSR(USERENV,FUNLIST,TSTFLG,VAL,SEVERITY) !??; PRINTSTRING("RETURNED FROM APPLYUSR");NEWLINE VAL=UNSTKSYS;IN=UNSTKSYS %FINISH; ! FINISH USERPRE ->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 SYSPRE/USERPRE/INFIX %IF TYPE=INTERP %THENSTART; ! START INTERP APPLYSYS(FUNSPEC&B2,FN,IN,EACHVAL) !??; PRINTSTRING("RETURNED FROM APPLYSYS INTERP");NEWLINE %IF JUMPFLAG=1 %THENRETURN %FINISHELSESTART ERROR('ERROR IN FN TYPE FOR EVAL',EMPTY,1,IN) %RETURN %FINISH %FINISH; ! FINISH INTERP ! %RETURN ! EVALSW(0):; ! POINTER EVALSW(8): STKSYS(IN) EVAL(FN,EACHVAL) IN=UNSTKSYS %IF JUMPFLAG=1 %THEN %RETURN ->LP ! ! %END; ! END EVAL EVAL(IN,UNDEF) %END; ! OF EVALAPPL ! ! %INTEGERFN PARSELINE(%INTEGER PREC) %INTEGERFNSPEC CHECKHD(%INTEGER HD) %ROUTINESPEC TOPOLISH(%INTEGERNAME ARGLIST,OPERATOR) %INTEGERFNSPEC READFNDEFN %INTEGERFNSPEC PARSETO %INTEGERFNSPEC PARSEIFC %INTEGERFNSPEC PARSEIF %ROUTINESPEC TOBOTTOM(%INTEGER OP,LIST) %INTEGERFNSPEC PRECED(%INTEGER OP) %INTEGERFNSPEC PARSEAPPMAP %INTEGER UNDEFIN %INTEGERFN PARSE(%INTEGER PREC) %INTEGER FN,FUNSPEC,TYPE,ARGNO,NEXTPREC %INTEGER POLIST,ARG1LIST,OPERATOR,ARG1,ITEM,IN %INTEGER WORK1,WORK2 %SWITCH INTERPSW(59:150) IN=NIL !??; PRINTSTRING('ENTERED PARSE'); NEWLINE POLIST=NIL; ARG1LIST=NIL PLEVEL=PLEVEL+1 LP: FN=HEADIN UNUSEDHD=0 %IF FN=RBRAK %THEN %RESULT=POLIST; ! END OF LINE %IF FN=RPAR %THEN %RESULT = POLIST; ! ')' %IF FN=COMMENT %THEN %RESULT=POLIST; ! IGNORE REST OF LINE %IF FN=COMMA %THEN TAILIN %AND ->LP; ! SEPARATOR TOP:%IF FN&NM=NM %THENSTART; ! NUMBER FN=FN!QU; ! QU IS A VALUE MARKER POLIST=CONS(FN,POLIST) %FINISHELSESTART; ! START 0 %IF FN=LBRAK %THEN %START; ! '[' TAILIN FN = READLIST!QU; ! READLIST POLIST=CONS(FN,POLIST) !??; PRINTSTRING("RETURNED FROM READLIST FN = ") !???; PRINTDIAGLIST(POLIST);NEWLINE %RESULT=POLIST %FINISHELSESTART; ! START 1 %IF FN=QUOTE %THENSTART; ! DATA WORD FOLLOWS QUOTEON=1 TAILIN; FN=HEADIN POLIST=CONS(FN!QU,POLIST) QUOTEON=0 %FINISHELSESTART; ! START 2 %IF FN=DOTS %THENSTART; ! DATA NAME FOLLOWS TAILIN; FN=HEADIN %IF FN = RBRAK %THEN %START; ! ']' PARSEERR(-1,EMPTY) %RESULT=FAULT %FINISH FN=FN!DTS; ! DTS IS A NAME MARKER %IF FN&WM=WM %THENSTART POLIST=CONS(FN,POLIST) %FINISHELSESTART PARSEERR(-2,FN) %RESULT = FAULT %FINISH %FINISHELSESTART; ! START 3 %IF FN=LPAR %THENSTART; ! '(' TAILIN WORK1= PARSE(4); ! CALL PARSE RECURSIVELY WITH HIGHER PRECEDENCE ! RETURNS ON MATCHING ')' OR END OF LINE !??;PRINTSTRING("RETURNED FROM PARSE");NEWLINE %IF WORK1<0 %THEN %RESULT=FAULT POLIST=CONS((WORK1!LP),POLIST) TAILIN %WHILE HEADIN#RPAR %AND HEADIN#RBRAK %FINISHELSESTART; ! START 4 %IF FN=MINUS %THENSTART; ! UNARY MINUS. EVAL WITH TOP PREC POLIST=CONS(UNMINUS!FNM,POLIST) TAILIN WORK1=PARSE(100) !??;PRINTSTRING("RETURNED FROM PARSE");NEWLINE %IF WORK1<0 %THEN %RESULT = FAULT POLIST=CONS(WORK1!LP,POLIST) %FINISHELSESTART; ! START 5 %IF FN=LANGBRKS %THENSTART; ! << POLIST=CONS(LANGBRKS!FNM,POLIST) TAILIN; ITEM=HEADIN %WHILE HEADIN#RBRAK %AND HEADIN # RANGBRKS %CYCLE; ! UNTIL NEXT ITEM ! IS MATCHING '>>' OR END OF LINE WORK1=PARSE(0) !??;PRINTSTRING("RETURNED FROM PARSE");NEWLINE %IF WORK1<0 %THEN %RESULT = FAULT POLIST=CONS(WORK1!LP,POLIST) %REPEAT %IF HEADIN=RBRAK %THENSTART PARSEERR(-3,EMPTY) %RESULT=FAULT %FINISH UNUSEDHD=0 POLIST=CONS(RANGBRKS!FNM,POLIST) POLIST=REVERSE(POLIST) %FINISHELSESTART; ! START 6 %IF FN=RPAR %OR FN=RANGBRKS %THENSTART; ! SPURIOUS ')' OR '>>' PARSEERR(-4,FN) %RESULT=FAULT %FINISH POLIST=CONS(FN!FNM,POLIST); ! FNM IS A FN MARKER FUNSPEC=FNVAL(FN>>8); ! GET FUNCTION SPEC %IF FUNSPEC=0 %THENSTART; ! UNDEFINED UNDEFIN=1 ! IF NOT PARSING A FN DEFINITION OR A CONDITION THEN... %IF FNDEFN = 0 %AND CONDFLAG=0 %THEN %START PARSEERR(-11,FN) %RESULT=FAULT %FINISH TYPE=USERPRE %FINISHELSE TYPE=FUNSPEC&B4 %IF FN=IF %OR FN=WHILE %THEN %START WORK1=PARSEIF CONDFLAG=CONDFLAG-1 %UNLESS CONDFLAG=0 %RESULT=WORK1 %FINISH %IF FN=IFT %OR FN=IFF %THENSTART WORK1=PARSEIFC CONDFLAG=CONDFLAG-1 %UNLESS CONDFLAG=0 %RESULT=WORK1 %FINISH %IF TYPE=SYSPRE %OR TYPE=USERPRE %THENSTART; ! PREFIX FUN ! GET NUMBER OF ARGS %IF UNDEFIN=1 %THEN ARGNO = -1 %ELSE %START %IF TYPE=SYSPRE %THEN ARGNO=(FUNSPEC&B3B)>>16 %ELSE %C ARGNO=FUNSPEC&X'FF' %FINISH !??;PRINTSTRING("ARGNO IS ");WRITE(ARGNO,4);NEWLINE TAILIN %IF ARGNO#0 %THENSTART WORK1=ARGNO %IF WORK1<0 %THEN %START; ! UNKNOWN NUMBER OF ARGS %CYCLE %EXIT %IF CHECKHD(HEADIN )= 1; ! CHECK FOR SPECIAL VALUES WORK2=PARSE(10); ! PARSE ARGS !??;PRINTSTRING("RETURNED FROM PARSE");NEWLINE %IF WORK2<0 %THEN %RESULT=FAULT POLIST=CONS(WORK2!LP,POLIST) %REPEAT %FINISHELSESTART %WHILE WORK1>0 %CYCLE; ! GATHER ARGS INTO POLIST %IF CHECKHD(HEADIN)=1 %THEN %START %EXIT %IF UNDEFIN=1 PARSEERR(-12,FN) %RESULT=FAULT %FINISH WORK2=PARSE(10) !??;PRINTSTRING("RETURNED FROM PARSE");NEWLINE %IF WORK2<0 %THENRESULT=FAULT POLIST=CONS(WORK2!LP,POLIST) WORK1=WORK1-1 %REPEAT %FINISH !??;PRINTSTRING('ARGS ON STACK');NEWLINE !???;PRINTDIAGLIST(POLIST);NEWLINE %FINISH %IF HEADIN = THEN %OR HEADIN = ELSE %THEN %RESULT = POLIST %IF FN=BREAK %THENSTART WORK1=READLIST REPTAIL(POLIST,WORK1) %RESULT=POLIST %FINISH %IF FN=APPLY %THENSTART WORK1=NIL %CYCLE %EXIT %IF CHECKHD(HEADIN)=1 WORK2=PARSE(10) %IF WORK2<0 %THEN %RESULT=FAULT WORK1=CONS(WORK2,WORK1) %REPEAT REPTAIL(TL(POLIST),WORK1) %RESULT=POLIST %FINISH %IF FN=REPEAT %THEN %START WORK1=PARSE(0) %IF WORK1<0 %THEN %RESULT=FAULT WORK2=TL(POLIST) REPTAIL(WORK2,WORK1) !??;PRINTSTRING("REPEAT POLIST= ");NEWLINE !???;PRINTDIAGLIST(POLIST);NEWLINE %RESULT=POLIST %FINISH %IF FN=DO %THENSTART WORK1=HD(POLIST) WORK2=HD(TL(POLIST)) POLIST=TL(TL(POLIST)) POLIST=CONS(WORK2,CONS(WORK1,POLIST)) %FINISH UNUSEDHD=1 POLIST=CONS(POLIST!LP,NIL) %FINISHELSESTART; ! START 7 %IF TYPE = INTERP %THEN %START ->INTERPSW(FUNSPEC&B2) INTERPSW(59):; ! DEFINE %IF PLEVEL>1 %THEN PARSEERR(-19,FN) %AND %RESULT=FAULT POLIST=PARSETO PROMPT(PROMP) FNDEFN=0 %RESULT=POLIST ! INTERPSW(60):; ! FN DEFINITION -- NOT PARSED UNTIL FIRST CALL %IF PLEVEL=1 %THEN POLIST=READFNDEFN %ELSE POLIST=PARSETO PROMPT(PROMP) FNDEFN=0 %RESULT=POLIST INTERPSW(148):; ! MAPLIST INTERPSW(149):; ! APPLIST %RESULT=PARSEAPPMAP %FINISH %ELSE %START; ! START 8 %IF TYPE=INFIX %THENSTART; ! MISPLACED INFIX PARSEERR(-5,FN) %RESULT=FAULT %FINISHELSESTART PARSEERR(-10,EMPTY) %RESULT=FAULT %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 %FINISH; ! FINISH 0 ! ! ! INFIX LOOP INFIX: %IF HEADIN=RPAR %THEN %START %IF FN#LPAR %THEN -> RETURN UNUSEDHD=0 %FINISH TAILIN %UNLESS UNUSEDHD=1 NEXTINF: !??; PRINTSTRING('ENTERED INFIX LOOP'); NEWLINE !???; PRINTDIAGLIST(POLIST); NEWLINE FN=HEADIN %IF FN=RBRAK %OR FN=RPAR %OR FN&WM#WM %THEN ->RETURN FUNSPEC=FNVAL((FN>>8)&X'FFFF'); !GET FN DEFN %IF FUNSPEC=0 %THEN -> RETURN ;!NOT DEFINED AS A FN TYPE=FUNSPEC&B4 ;! GET TYPE %IF TYPE # INFIX %THEN ->RETURN ;! NOT INFIX NEXTPREC=(FUNSPEC&B3B)>>16; ! GET PREC %IF NEXTPREC<=PREC %THEN ->RETURN;! NEXT PREC LOWER THAN CURRENT ARG1=HD(POLIST) POLIST=TL(POLIST) ARG1LIST=CONS(ARG1,NIL) ;!PUT FIRST ARG ONTO TEMP POLISH LIST OPERATOR=FN TOPOLISH(ARG1LIST,OPERATOR); ! OPERATOR IS THE FN JUST FOUND !??;PRINTSTRING("RETURNED FROM TOPOLISH");NEWLINE !ARG1LIST IS UPDATED BEFORE RETURN FROM TOPOLISH %IF ARG1LIST=FAULT %THEN %RESULT=FAULT POLIST=CONS(ARG1LIST!LP,POLIST) ->NEXTINF RETURN: UNUSEDHD=1 %RESULT=POLIST %END; ! END PARSE ! ! %INTEGERFN CHECKHD(%INTEGER HD) %INTEGER FUNSPEC,TYPE %IF HD=RBRAK %OR HD=RPAR %OR HD=RANGBRKS %OR HD=AND %OR HD=THEN %C %OR HD=ELSE %THEN %RESULT=1 %IF HD&FNM=FNM %THEN %START FUNSPEC=FNVAL(HD>>8) TYPE=FUNSPEC&B4 %IF TYPE=INFIX %THEN %RESULT=1 %FINISH %RESULT=0 %END ! ! %ROUTINE TOPOLISH(%INTEGERNAME ARG1LIST,OP) %INTEGER POLIST,OP1,WORK1 !??; PRINTSTRING("ENTERED TOPOLISH"); NEWLINE POLIST=NIL OP1=OP TAILIN WORK1=PARSE(PRECED(OP)) !??;PRINTSTRING("RETURNED FROM PARSE");NEWLINE %IF WORK1<0 %THEN ARG1LIST=FAULT %AND %RETURN POLIST=WORK1 ! SPECIAL CASE FOR AND %IF OP=AND %THEN ARG1LIST=CONS(ARG1LIST!LP,POLIST) %ELSE %C ARG1LIST=CONS(POLIST!LP,ARG1LIST) TOBOTTOM(OP1!FNM,ARG1LIST) %RETURN %END ! ! %ROUTINE TOBOTTOM(%INTEGER ITEM,LIST) ! INSERT ITEM AT END OF LIST %INTEGER L,NEWTAIL LA(LPOINT)=ITEM LA(LPOINT+1)=NIL NEWTAIL=LPOINT<<8!LM LPOINT=LPOINT+2 L=LIST %WHILE TL(L)#NIL %THEN L=TL(L) REPTAIL(L,NEWTAIL) %END ! ! ! %INTEGERFN PRECED(%INTEGER OP) ! RETURNS PRECEDENCE OF OP. %INTEGER FUNSPEC FUNSPEC=FNVAL(OP>>8) %RESULT=(FUNSPEC&B3B)>>16 %END ! %INTEGERFN PARSEIFC %INTEGER THENC,FN,INS FN=HEADIN TAILIN CONDFLAG=CONDFLAG+1 THENC=PARSE(0) %IF THENC<0 %THEN %RESULT=FAULT %IF FNDEFN=1 %THENSTART THENC=MOVE1(THENC) INS=CONS1(FN!FNM,THENC) %FINISHELSE INS=CONS(FN!FNM,THENC) %RESULT=INS %END; ! END OF PARSEIFC ! %CONSTSTRING(6) STRT="START:" %INTEGERFNSPEC MAKECONDBRANCH !%ROUTINESPEC PROCESS LINENUMS(%INTEGER LIST) %INTEGERFN PARSEIF %INTEGER TBRANCH,FBRANCH,COND,THENC,ELSEC,ITEM,FN,WORK1 !??; PRINTSTRING("ENTERED PARSEIF");NEWLINE TBRANCH=NIL; FBRANCH=NIL FN=HEADIN COND=NIL TAILIN %IF HEADIN=THEN %OR HEADIN=ELSE %THENSTART PARSEERR(-21,EMPTY) %RESULT=FAULT %FINISH WORK1=PARSE(0); ! PARSE CONDITION !??;PRINTSTRING("RETURNED FROM PARSE");NEWLINE !???; PRINTSTRING("WORK1 IS "); PRINTDIAGLIST(WORK1);NEWLINE %IF WORK1<0 %THEN %RESULT=FAULT %IF HEADIN=THEN %THEN ->THENCL %IF HEADIN=ELSE %THEN PARSEERR(-6,HEADIN) PARSEERR(-7,HEADIN) %RESULT=FAULT ! THENCL:; ! THEN CLAUSE CONDFLAG=CONDFLAG+1; ! DOWN A LEVEL OF CONDITION TAILIN ITEM=HEADIN %IF ITEM=ELSE %THENSTART PARSEERR(-22,EMPTY) %RESULT=FAULT %FINISH %IF ITEM=START %THEN %START; ! START...FINISH PROMPT(STRT) TBRANCH=MAKECONDBRANCH PROMPT(PROMP) %IF TBRANCH=FAULT %THEN %RESULT=FAULT %FINISH %ELSE %START THENC=PARSE(0) !??;PRINTSTRING("RETURNED FROM PARSE");NEWLINE !???; PRINTSTRING("THENC IS");PRINTDIAGLIST(THENC);NEWLINE %IF THENC<0 %THEN %RESULT=FAULT ! IF PARSING A FN DEFINITION MOVE LIST INTO FN DEFN SPACE %IF FNDEFN=1 %THEN TBRANCH=MOVE1(THENC) %ELSE TBRANCH=THENC %FINISH %IF HEADIN=ELSE %THEN ->ELSECL ->BUILDCOND ELSECL:; ! ELSE CLAUSE %IF FN=WHILE %THEN FBRANCH=NIL %ELSE %START TAILIN ITEM=HEADIN %IF ITEM=START %THEN %START; ! START...FINISH PROMPT(STRT) FBRANCH=MAKECONDBRANCH PROMPT(PROMP) %IF FBRANCH=FAULT %THEN %RESULT=FAULT %FINISH %ELSE %START ELSEC=PARSE(0) !??;PRINTSTRING("RETURNED FROM PARSE");NEWLINE !???; PRINTSTRING("ELSEC IS ");PRINTDIAGLIST(ELSEC);NEWLINE %IF ELSEC<0 %THEN %RESULT=FAULT %IF FNDEFN=1 %THEN FBRANCH=MOVE1(ELSEC) %ELSE FBRANCH=ELSEC %FINISH %FINISH BUILDCOND: %IF FNDEFN=1 %THEN %START; ! PARSING A FN DEFN WORK1=MOVE1(WORK1) COND=CONS1(FN!FNM,CONS1(WORK1!LP,CONS1(TBRANCH,FBRANCH))) %FINISHELSESTART COND=CONS(FN!FNM,CONS(WORK1!LP,CONS(TBRANCH,FBRANCH))) %FINISH !??;PRINTSTRING("END OF PARSEIF RESULT = ");NEWLINE !???;PRINTDIAGLIST(COND);NEWLINE %RESULT=COND %END; ! END OF PARSEIF %INTEGERFN MAKECONDBRANCH %INTEGER CONDLIST,WORK1,LINENUM,ITEM,LINENUMLIST,FTCONDLIST,TXTPTR !??; PRINTSTRING("ENTERED MAKECONDBRANCH");NEWLINE CONDLIST=NIL; LINENUMLIST=NIL %UNTIL ITEM=FINISH %CYCLE; ! PARSE LINES UP TO 'FINISH' %IF FNDEFN=1 %THENSTART %IF DEVICE=TTY %THENSTART COPYLINE; ! USING 'DEFINE' - COPY LINE TO SOURCE TXTPTR=SOURCEPTR; ! PTR TO NEXT SOURCE LINE %FINISH %ELSE TXTPTR=SINDEX %FINISH READINLINE(STRT) !??;PRINTSTRING(STRING(ADDR(INBUFF(0))));NEWLINE ITEM=HEADIN %IF FNDEFN=1 %THEN %START %IF ITEM=END %THEN PARSEERR(-8,ITEM) %ANDRESULT=FAULT %IF ITEM&NM#NM %THEN %START PARSEERR(-9,ITEM) ->REP %FINISH LINENUM=ITEM TAILIN ITEM=HEADIN %FINISH %IF ITEM = FINISH %THEN WORK1=CONS(FINISH,NIL) %ELSESTART WORK1=PARSE(0) !??;PRINTSTRING("RETURNED FROM PARSE");NEWLINE !???;PRINTSTRING("WORK1 IS ");PRINTDIAGLIST(WORK1);NEWLINE %IF WORK1<0 %THEN %RESULT=FAULT %FINISH %IF FNDEFN=1 %THEN %START WORK1=MOVE1(WORK1) ! LP; ! MOVE LIST INTO FN DEFN SPACE !??;PRINTSTRING("TXTPTR<<16!(LINENUM>>8)<<2") !??;WRITE((TXTPTR<<16)!((LINENUM>>8)<<2),10) !??;NEWLINE ! INSERT LINENUMBER AND PTR TO FN TEXT FOR DIAGNOSTICS WORK1=CONS1(CONS1(((TXTPTR<<16)!((LINENUM>>8)<<2)),WORK1),NIL) %FINISH %ELSE WORK1=CONS(CONS(SOURCEPTR<<16,WORK1),NIL) ! ADD THIS LINE TO END OF FN LIST %IF CONDLIST=NIL %THEN %START CONDLIST=WORK1 FTCONDLIST=CONDLIST %FINISHELSE %START REPTAIL(FTCONDLIST,WORK1) FTCONDLIST=TL(FTCONDLIST) %FINISH ! IF A FN DEFN THEN ADD THIS LINE TO LINE NUMBER LIST %IF FNDEFN=1 %THEN %C LINENUMLIST=CONS1(CONS1(LINENUM,FTCONDLIST),LINENUMLIST) REP: %REPEAT TAILIN ! INSERT LINE NUMBER INTO START...FINISH LIST %IF FNDEFN=1 %THEN %C %RESULT=CONS1(START,CONS1(LINENUMLIST,CONDLIST)) %ELSE %C %RESULT=CONS(START,CONS(LINENUMLIST,CONDLIST)) %END %INTEGERFN READFNDEFN ! READ TEXT OF A FN INTO SOURCE TEXT FILE %INTEGER STARTTEXT,ARG1,ARG2,INDEX STARTTEXT=SOURCEPTR TAILIN ARG1=HEADIN INDEX=ARG1>>8 %IF ARG1&WM#WM %OR ARG1=RBRAK %THEN %START PARSEERR(-14,ARG1) %RESULT=FAULT %FINISH ARG2=FNVAL(INDEX) %IF ARG2#0 %THEN %START %UNLESS ARG2&USERPRE=USERPRE %THEN %START PARSEERR(-15,ARG1) %RESULT=FAULT %FINISH OLDFN(INDEX)=FNLEN(INDEX)<<16!FNTEXT(INDEX) %FINISH COPYLINE %IF SOURCEPTR+2*(SOURCEPTR-STARTTEXT)+64>MAXSOURCE %THEN %C BADERROR('SOURCE FILE SPACE OVWRFLOW',EMPTY) NEWFN=FROMLIST(ARG1,NEWFN) %UNLESS NEWFN=NIL FNTEXT(INDEX)=STARTTEXT FNLEN(INDEX)=SOURCEPTR-STARTTEXT EDIT(ARG1) %UNLESS FNPARSE(ARG1>>8)=255 %THEN NEWFN=CONS(ARG1,NEWFN) %RESULT=NIL %END ! ! ! %INTEGERFNSPEC MAKEARGLIST(%INTEGERNAME LEN) %INTEGERFN PARSETO ! FIRST LINE OF FN ALREADY READ ! PARSE A FN DEFN -- TEXT IS IN SOURCE TEXT FILE IF HEADIN=TO ! OR READ FROM INPUT FILE IF HEADIN=DEFINE ! %INTEGER LEN,ARG1,ARG2,ARG3,ARGS,FNLINE,LINENUM,FN,ITEM,REDEF,FNLIST %INTEGER ENDFNLIST,STARTTEXT,LENTEXT,INDEX,TXTPTR,I,REST %CONSTSTRING(8) FNDEF="FN DEFN:" !??;PRINTSTRING("ENTERED PARSETO");NEWLINE FNDEFN=1 REDEF=0 FNLIST=NIL ENDFNLIST=NIL LINENUMLIST=NIL FN=HEADIN; ! TO TAILIN ARG1=HEADIN; ! PROC NAME INDEX=ARG1>>8 TAILIN %IF FN=DEF %THENSTART STARTTEXT=SOURCEPTR PROMPT(FNDEF) %IF ARG1&WM#WM %OR ARG1=RBRAK %THENSTART PARSEERR(-14,ARG1) %RESULT=FAULT %FINISH ARG2=FNVAL(INDEX) %IF ARG2=0 %THEN->MAKESPEC %IF ARG2&USERPRE=USERPRE %THENSTART REDEF=1 ->MAKESPEC %FINISHELSE PARSEERR(-15,ARG1) %RESULT=FAULT MAKESPEC: NEWFN=FROMLIST(ARG1,NEWFN) %UNLESS NEWFN=NIL I=1 I=I+1 %WHILE INBUFF(I)=' '; !SKIP LEADING SPACES I=I+1 %WHILE INBUFF(I)#' '; ! SKIP FIRST WORD REST=INBUFF(0)-I+1 %IF SOURCEPTR+2+REST>MAXSOURCE %THEN %C BADERROR('SOURCE FILE SPACE OVERFLOW',EMPTY) SOURCE(SOURCEPTR)='T' SOURCE(SOURCEPTR+1)='O' MOVE(REST,ADDR(INBUFF(I)),ADDR(SOURCE(SOURCEPTR+2))) SOURCEPTR=SOURCEPTR+2+REST %FINISH ARGS=MAKEARGLIST(LEN); ! MAKE A LIST OF ARGUMENTS %IF ARGS=FAULT %THEN %RESULT=FAULT !??;PRINTSTRING("RETURNED FROM MAKEARGLIST LEN =");WRITE(LEN,5); !??;NEWLINE %IF FN=DEF %THENSTART %IF LEN>127 %THENSTART PARSEERR(-13,ARG1) %RESULT=FAULT %FINISH %IF REDEF=1 %THEN OLDFN(INDEX)=FNLEN(INDEX)<<8 ! FNTEXT(INDEX) %FINISH ARG3=CONS1(TO,CONS1(ARG1,ARGS)) !???;PRINTSTRING("ARG3 IS ");PRINTDIAGLIST(ARG3);NEWLINE FNVAL(INDEX)=USERPRE+LEN; ! TEMP SPEC TO ALLOW RECURSIVE CALLS ! FN=DEF IMPLIES DEVICE=TTY %IF DEVICE =TTY %THEN TXTPTR=SOURCEPTR %ELSE %C TXTPTR=SINDEX; ! POINTER TO BEGINNING OF NEXT LINE OF TEXT READINLINE(FNDEF); ! READ FIRST LINE ITEM=HEADIN TAILIN %WHILE ITEM#END %THEN %CYCLE FNLINE=NIL %IF ITEM&NM#NM %THEN %START PARSEERR(-9,ARG1); ! NO NUMBER ON FN LINE ->READLINE %FINISH LINENUM=ITEM; ! STORE LINE NUMBER UNDEFIN=0 FNLINE=PARSE(0); ! PARSE LINE !??;PRINTSTRING("RETURNED FROM PARSE");NEWLINE %IF FNLINE=FAULT %THEN PARSEERR(-20,ARG1) %AND ->READLINE FNLINE=MOVE1(FNLINE)!LP; ! MOVE INTO FN DEFN SPACE !??;PRINTSTRING("TXTPTR<<16!LINENUM<<2") !??;WRITE((TXTPTR<<16)!(LINENUM<<2),10) !??;NEWLINE ! INSERT LINENUMBER AND TEXT POINTER IN FN LIST FNLINE=CONS1(CONS1(((TXTPTR<<16)!((LINENUM>>8)<<2)),FNLINE),NIL) ! ADD LINE TO END OF LIST %IF FNLIST=NIL %THEN %START FNLIST=FNLINE ENDFNLIST=FNLIST %FINISH %ELSE %START REPTAIL(ENDFNLIST,FNLINE) ENDFNLIST=TL(ENDFNLIST) %FINISH ! UPDATE LINE NUMBER LIST LINENUMLIST=CONS1(CONS1(LINENUM,ENDFNLIST),LINENUMLIST) %IF FN=DEF %THEN COPYLINE READLINE:; ! READ NEXT LINE %IF DEVICE=TTY %THEN TXTPTR=SOURCEPTR %ELSE TXTPTR=SINDEX READINLINE(FNDEF) ITEM=HEADIN TAILIN %REPEAT %IF FN=DEF %THEN COPYLINE; ! INSERT END INTO SOURCE ! INSERT END INTO FN LIST ! %IF ENDFNLIST=NIL %THEN FNLIST=CONS1(CONS1(END,NIL)!LP,NIL) %IF ENDFNLIST=NIL %THEN FNLIST=CONS1(END,NIL) %C %ELSE REPTAIL(ENDFNLIST,CONS1(END,NIL)) ! INSERT LINE NUMBER LIST INTO FN LIST FNLIST=CONS1(ARG3!LP,CONS1(LINENUMLIST!LP,FNLIST)) FNVAL(INDEX)=USERPRE+FNLIST&M16+LEN; !BUILD SPEC !??;PRINTSTRING("FNLIST IS ");PRINTDIAGLIST(FNLIST);NEWLINE %IF FN=DEF %THENSTART NEWFN=CONS(ARG1,NEWFN) PRINTEL(ARG1) %IF REDEF=1 %THEN PRSTRING(' REDEFINED') %ELSE PRSTRING(' DEFINED') NOOLINE(1) LENTEXT=SOURCEPTR-STARTTEXT FNTEXT(INDEX)=STARTTEXT FNLEN(INDEX)=LENTEXT %FINISH FNPARSE(INDEX)=1 %RESULT=NIL %END; ! END OF PARSETO ! %INTEGERFN MAKEARGLIST(%INTEGERNAME LEN) ! MAKE A LIST OF ARGS. %INTEGER LIST,WORD !??;PRINTSTRING("ENTERED MAKEARGLIST ");NEWLINE LIST=NIL LEN=0 %RESULT=NIL %IF HEADIN=RBRAK %UNTIL WORD=RBRAK %CYCLE ->ERRLAB %UNLESS HEADIN=QUOTE TAILIN WORD=HEADIN ->ERRLAB %IF WORD=RBRAK %OR WORD&WM#WM LIST=CONS(WORD,LIST) LEN=LEN+1 TAILIN WORD=HEADIN %REPEAT TAILIN %RESULT=REVERSE1(LIST) ERRLAB: PARSEERR(-16,EMPTY) %RESULT=FAULT %END; ! END OF MAKEARGLIST ! ! %INTEGERFN PARSEAPPMAP ! SPECIAL SYSTEM FNS APPLIST AND MAPLIST %INTEGER FN,WORK1,WORK2 FN=HEADIN TAILIN WORK1=PARSE(0) %IF WORK1<0 %THEN %RESULT=FAULT %IF WORK1=NIL %THENSTART PARSEERR(-12,FN) %RESULT=FAULT %FINISH ! ! PARSE LIST WHICH WILL BE APPLIED TO EACH ARG OF ARG1 ! %IF HEADIN=LBRAK %THEN %START TAILIN WORK2=PARSE(0) %FINISH %ELSE WORK2=PARSE(0) %IF WORK2=FAULT %THEN %RESULT=FAULT %IF WORK2=NIL %THENSTART PARSEERR(-12,FN) %RESULT=FAULT %FINISH %RESULT=CONS(WORK1,CONS(FN!FNM,WORK2)) %END ! ! ! ! UNDEFIN=0 %RESULT=PARSE(PREC) ! %END; ! OF PARSELINE ! ! %ROUTINE APPLYUSR(%INTEGER ENVIR,FUN,TSTFLG,VAL,%INTEGERNAME SEVERITY) %INTEGER IN,NEXTFUN,SAVESTK,LINENUMLIST,CURFUN,NUM !??; PRINTSTRING("ENTERED APPLYUSR ; ENVIR,FUN =") !???; WRITE(ENVIR,10);WRITE(FUN,10);NEWLINE SAVESTK=STKPNT LINENUMLIST=HD(TL(FUN)) NEXTFUN=TL(TL(FUN)) %WHILE HD(NEXTFUN)#END %CYCLE %IF NEXTFUN=NIL %THEN %RETURN CURFUN=HD(NEXTFUN) IN=TL(CURFUN) NEXTFUN=TL(NEXTFUN) EVALAPPL(ENVIR,FUN,CURFUN,IN,TSTFLG,VAL,SEVERITY) %RETURN %IF CURFUN=NIL !??;PRINTSTRING("RETURNED FROM EVALAPPL : GOFLAG= ") !??;WRITE(GOFLAG,10);NEWLINE %IF GOFLAG=1 %THEN %START NEXTFUN=FINDLINENUMS(LINENUMLIST) !??; PRINTSTRING("RETURNED FROM FINDLINENUMS IN APPLYUSR : NEXTFUN IS ") !??; WRITE(NEXTFUN,10);NEWLINE %IF NEXTFUN=0 %THEN %START NUM=UNSTACK NEWLINE PRINTSTRING("CANNOT JUMP TO LINE") WRITE(NUM>>8,2) NEWLINE JUMPFLAG=1 GOFLAG=0 STACK(NUM) %FINISH %FINISH %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 %RETURN %IF NEXTFUN=NIL %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,ARGNO !%SHORTINTEGERNAME SWITCH TYPE==BYTEINTEGER(ADDR(SYSVAL)) !SWITCH==SHORTINTEGER(ADDR(SYSVAL)+2) ARGNO==BYTEINTEGER(ADDR(SYSVAL)+1) ! %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 PRINTSTRING('WORD AREA');NEWLINE PRINTSTRING(' INDEX WORD BASE VALUE ') PRINTSTRING('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(SYSVAL&X'FFFF',10) %IF TYPE#4 %THEN WRITE(ARGNO,14) %FINISHELSESTART SPACES(11) WRITE(SYSVAL&X'FF',14) SPACES(2) PRINTSTRING("L") WRITE(SYSVAL<<8>>16,4) %FINISH NEWLINE %FINISH REP:%REPEAT NEWLINE PRINTSTRING('LIST AREA');NEWLINES(2) PRINTSTRING('FUNCTION SPACE');NEWLINE %IF LPOINT1=LISTOP %THENSTART;PRINTSTRING('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:PRINTSTRING('CURRENT SEMISPACE');NEWLINE %IF LPOINT=LABASE %THENSTART;PRINTSTRING('NO LIST SPACE');NEWLINE ->ENV;%FINISH %CYCLE I=LABASE,1,LPOINT-1 WRITE(I,5);SPACES(2) DUMPITEM(LA(I)) NEWLINE %REPEAT NEWLINE ENV:PRINTSTRING('LOCAL ENVIRS');NEWLINE %IF TOPMARK=1022 %THENSTART PRINTSTRING('NO LOCALS' );NEWLINE %FINISHELSESTART %CYCLE I=1023,1,TOPMARK WRITE(BNAME(I)>>8,5);SPACES(2) DUMPITEM(BVALUE(I)) NEWLINE %REPEAT %FINISH NEWLINE PRINTSTRING('USER STACK') NEWLINE %IF STKPNT=0 %THENSTART PRINTSTRING('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, TSWITCH %BYTEINTEGERNAME TYPE,ARGNO %BYTEINTEGERARRAYNAME SWITCH %BYTEINTEGERARRAYFORMAT SF(1:2) TYPE==BYTEINTEGER(ADDR(SYSVAL)) SWITCH==ARRAY(ADDR(SYSVAL)+2,SF) ARGNO==BYTEINTEGER(ADDR(SYSVAL)+1) LP:READSTRING(NAME) %IF NAME='END' %THENRETURN SYSVAL=0 READ(TYPE) READ(TSWITCH) %IF TYPE#4 %THEN READ(ARGNO) SETSHORTINT(SWITCH(1),TSWITCH) FNVAL(HASH(NAME)>>8)=SYSVAL ->LP %END; ! END GETFUNS ! ! EMASUSER=UINFS(1); ! USER NAME AS STRING OWNER=EMASUSER MASFILE='LOGOFILE' MASREAD=MASFILE.",".EMASUSER.",R" MASWRITE=MASFILE.",".EMASUSER.",WR" %CYCLE I=0,1,1022 BVALUE(I)=0 FNVAL(I)=0 FNTEXT(I)=0 FNLEN(I)=0 OLDFN(I)=0 WA(I)="?" %REPEAT SPACE4=' ' QUOTEON=0 SOURCEPTR=1 FNDEFN=0 DIAGFLAG=0 CONDFLAG=0 GOFLAG=0 HASHVAL==INTSTR(2) WORK1==STRING(ADDR(INTSTR(2))-1) LBRAK==SPECHAR(13) RBRAK==SPECHAR(14) TDEV=0 ADDRBINBUFF=ADDR(BINBUFF(1)) DEVICE=TTY USERFILE="" CACTFILE=0 MDIND=0 MDP=0 CHAROUT=0 HASH1023=0 HASH1024=0 INDENT=1 PRNUM=0 STKPNT=0 STKTOP=0 SYSTKPNT=0 JUMPFLAG=0 JUMPOUT=0 SUPERJMP=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=X'007FFFFF' NUMBOT=X'FF800001' EVALIMIT=1000000 LIBLOAD=0 EMPTY==NAMES(2) SPACE1==NAMES(4) ENEL==NAMES(6) TAB==NAMES(8) TRUE==NAMES(9) FALSE==NAMES(11) QUOTE==NAMES(14) DOTS==NAMES(16) LPAR==NAMES(17) RPAR==NAMES(18) COMMA==NAMES(19) NIL==NAMES(20) UNDEF==NAMES(21) THEN==NAMES(22) ELSE==NAMES(23) END==NAMES(24) DELETE==NAMES(25) UNDO==NAMES(26) UNDOS==NAMES(27) TO==NAMES(28) DO==NAMES(29) ERR==NAMES(30) LOGONAME==NAMES(31) QUIT==NAMES(32) BREAK==NAMES(33) IF==NAMES(34) CLOSE==NAMES(35) WHILE==NAMES(36) THINKALOUD==NAMES(37) FACT==NAMES(38) IMPLIES==NAMES(39) TOINFER==NAMES(40) NEW==NAMES(41) VBL==NAMES(42) NOT==NAMES(43) DATABASE==NAMES(44) IMPRULES==NAMES(45) INFRULES==NAMES(46) FACTKEYS==NAMES(47) IMPKEYS==NAMES(48) INFKEYS==NAMES(49) UP==NAMES(50) DOWN==NAMES(51) LANGBRKS==NAMES(52) RANGBRKS==NAMES(53) MINUS==NAMES(54) QUITOTOP==NAMES(63) START==NAMES(64) FINISH==NAMES(65) AND==NAMES(66) REPEAT==NAMES(67) APPLY==NAMES(68) UNMINUS==NAMES(69) COMMENT==NAMES(70) DEF==NAMES(71) IFT==NAMES(72) IFF==NAMES(73) 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 FILL(1023,ADDR(FNPARSE(0)),0) INITINF SETVAL(THINKALOUD,TRUE,BASENVIR) SETVAL(QUITOTOP,TRUE,BASENVIR) NEWFN=NIL LOGOTIME=TIME100 SELECTINPUT(0) CLOSESTREAM(2);CLEAR("2") GETMASTER !******* GRAPHICS INITIALISATION CURPIC=NIL DEF PICTURE = 0 FRAMEFLAG=0 ;! NOT WITHIN FRAME CURMOVIE=NIL ;! NO CURRENT MOVIE CURFRAME=NIL GRABLIST=NIL %RETURN %FINISH %END; ! END INITIALISE ! ! %ROUTINE LOGO(%INTEGER STKTOP,ENVIR,SEVERITY) %INTEGER VAL,FUN,CURFUN,TSTFLG,IN VAL=UNDEF FUN=NIL IN=NIL CURFUN=NIL TSTFLG=0 !??; DIAGFLAG=0 PRNUM=PRNUM+1 PROMP=NUMTOSTR(PRNUM<<8).":" PROMPT(PROMP) LP: %IF TDEV=8 %THEN SET42(CHTXT) BLEVEL=1 READINLINE(PROMP) !??; PRINTSTRING(STRING(ADDR(INBUFF(0)))); NEWLINE PARSECNT=0;PLEVEL=0 IN=PARSELINE(0) %IF IN>0 %THEN %START EVALCNT=0 EVALAPPL(ENVIR,FUN,CURFUN,IN,TSTFLG,VAL,SEVERITY) %FINISH %ELSE ->LP %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 SUPERJMP=0 %FINISH; ! FINISH JUMPFLAG=1 ->LP %END; ! END LOGO ! %ROUTINE ONTRAP(%INTEGER CLASS,SUBCLASS) %INTEGER FLAG %INTEGERARRAY INFO(1:32) FLAG=READID(ADDR(INFO(1))) %IF SUBCLASS='Q' %THEN QUITFLAG=1 %ELSE HOLDFLAG=1 DRESUME(0,0,ADDR(INFO(1))) %END; ! END ONTRAP ! ! ! ! ! ! ! %ON %EVENT 1 %START; ->REINIT; %FINISH ! %FAULT 17 ->REINIT REINIT:%BEGIN ! MAIN PROG STARTS ! REROUTECONTINGENCY(3,65,X'20100',ONTRAP,FLAG) NEWSMFILE('LOGOSTK,436029') DEFINE('6,LOGOSTK') FSTART=SMADDR(6,FLENGTH) FNVAL==ARRAY(FSTART,INTFORM1) OLDFN==ARRAY(FSTART+4092,INTFORM1) FNTEXT==ARRAY(FSTART+8184,INTFORM1) FNLEN==ARRAY(FSTART+12276,INTFORM1) FNPARSE==ARRAY(FSTART+16368,PARSEFORM) SYSTK==ARRAY(FSTART+17392,INTFORM2) LA==ARRAY(FSTART+25392,INTFORM3) BNAME==ARRAY(FSTART+287536,INTFORM4) BVALUE==ARRAY(FSTART+295448,INTFORM5) ASSOCWA==ARRAY(FSTART+307452,INTFORM1) STK==ARRAY(FSTART+311544,INTFORM2) WA==ARRAY(FSTART+319544,SFORM1) SOURCE==ARRAY(FSTART+386029,SOURCEFORM) DEFINE('2,'.MASNUM.'LOGNAM96') INITIALISE %IF RESTART=0 %THENSTART; ! NOT A RESTART DEFINE('1,DUMPFILE') NEWLINES(2) PRINTSTRING('LOGO - VERSION DEV (03/10/80) '.TIME) NEWLINES(2) %FINISHELSESTART; ! RESTART PRINTSTRING('REINITIALISING AND RELOADING SAVED FUNCTIONS') NEWLINE SELECTINPUT(3) %FINISH LOGO(STKTOP,BASENVIR,0) ! %END %ENDOFPROGRAM