%BEGIN ! ! CHANNEL USAGE ! ST01 - DUMPFILE AND DRIBBLE AT GOODBYE ! ST02 - ELGNAM ! SM04 - OWNFILE ! SM05 - LOGERRS ! SM06 - LOGOSTK ! SM07 - LOGOMON ! SM08 - BFILE ! SM09 - LOGMASTR ! SM10 - LOGOTEMP ! SM11 - LOGODRIB ! SM12 - NEW LOGON IN EDITMASTER ! ST13 - SHOWFILE? ! !***************************************** ! 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 = 'ECMI50.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 OBEYFILE(%STRING(63) S) %EXTERNALROUTINESPEC DISCONNECT(%STRING(63) S) %EXTERNALROUTINESPEC CLOSESM(%INTEGER CH) %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %SYSTEMROUTINESPEC FINFO(%STRING(15) S,%INTEGER LEV,%C %RECORDNAME R, %INTEGERNAME FLAG) %SYSTEMROUTINESPEC MOVE(%INTEGER LENGTH,FROM,TO) %EXTERNALSTRINGFNSPEC DATE %EXTERNALROUTINESPEC LIST(%STRING(63) S) %EXTERNALROUTINESPEC SEND(%STRING(63) S) %EXTERNALSTRINGFNSPEC TIME %EXTERNALLONGREALFNSPEC CPUTIME %EXTERNALINTEGERFNSPEC SMADDR(%INTEGER CHANN,%INTEGERNAME LENGTH) %EXTERNALROUTINESPEC DEFINE(%STRING (65) S) %EXTERNALROUTINESPEC PERMIT FILE(%STRING (65) S) %EXTERNALROUTINESPEC NEWSMFILE(%STRING (63) S) %EXTERNALROUTINESPEC CHERISH(%STRING (63) S) %EXTERNALROUTINESPEC PROMPT(%STRING(15) M) %EXTERNALROUTINESPEC DESTROY(%STRING(65) S) %EXTERNALROUTINESPEC CLOSESTREAM(%INTEGER CH) %EXTERNALREALFNSPEC RANDOM (%INTEGERNAME I,%INTEGER J) %EXTERNALINTEGERFNSPEC TESTINT(%INTEGER C,%STRING(15) INT) %EXTERNALROUTINESPEC CLEAR(%STRING(65) S) %EXTERNALROUTINESPEC CRASHDRI %ROUTINESPEC BADERROR(%STRING(80) ERRMESS,%INTEGER CULPRIT) %ROUTINESPEC APPLYUSR(%INTEGER ENVIR,FUN,TSTFLG,VAL,%C %INTEGERNAME SEVERITY,WALKFN) %ROUTINESPEC NOOLINE(%INTEGER N) %ROUTINESPEC PRSTRING(%STRING(255) WORD) %INTEGERFNSPEC UNSTACK %ROUTINESPEC PRINTLIST(%INTEGER LIST) %ROUTINESPEC PRINTEL(%INTEGER I) %INTEGERFNSPEC HD(%INTEGER LIST) %INTEGERFNSPEC TL(%INTEGER LIST) %ROUTINESPEC PRINTLINE(%INTEGER LINE) %INTEGERFNSPEC READLINE %ROUTINESPEC LOGO(%INTEGER STKTOP,ENVIR,SEVERITY,FLAG) %ROUTINESPEC DUMP(%STRING(80) ERRMESS) %INTEGER FLENGTH,FSTART; ! FOR WORKSPACE MAPPING %INTEGER EUNAD; ! FOR ADDTESS OF EMAS USER NAME %BYTEINTEGERARRAY EUNBYTE(1:7); ! USERNAME %STRING(6) %NAME EMASUSER; ! AS A STRING ! ! ! ! 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,WT,ADUMP,TIMELIM,R3 ! ! ERROR MESSAGE MAP ! %STRINGARRAYNAME ERRMESS %STRING(255)%ARRAYFORMAT SFORM2(1:150) ! ! ! WORD AREA AND NUMBER DECLARATIONS ! %STRINGARRAYNAME WA %STRING(64)%ARRAYFORMAT SFORM1(0:1022); ! WORD TABLE %OWNINTEGER WM=1,NM=4; ! WORD MARKER,NUMBER MARKER %OWNINTEGER T8=X'FF000000' %INTEGER NUMTOP,NUMBOT; ! NUMBER RANGE DELIMITERS %OWNINTEGER MAXINT=X'7FFFFFFF' %OWNINTEGER RANSEED=50003 %STRING(64) %NAME WORK1 %INTEGER LOGOTIME %INTEGERARRAY INTSTR(1:20) %STRING(4) SPACE4 %INTEGERNAME HASHVAL,LBRAK,RBRAK,DOTS,EMPTY,UNDEF, %C COMMA,QUOTE,LPAR,RPAR,MINUS,IF,THEN,ELSE,CLOSE,WHILE,%C TRUE,FALSE,END,DELETE,UNDO,UNDOS,TO,DO,ERR,LOGONAME,%C LANGBRKS,RANGBRKS,QUIT,BREAK,SPACE1,TAB,ENEL,QQPROC,RETITLE,%C QQRESULT,DEFINEWORD,INSERT,NULL,UNPARSE %INTEGER NSRTAIL; ! NO SPECIAL RESULT TEXT AS LIST %INTEGER OWNFUNS; ! LIST OF OWN PROCS %INTEGER GETID; ! WHO ARE YOU TRIGGER LIST %INTEGERARRAY NAMES(1:100); ! CONTAINS HASHED VALUES OF ! SPECHARS AND RESERVED NAMES %OWNINTEGERARRAY SPECHAR(1:14)=':','<','>','"','(',')','*', '+',',','-','/','=','[',']' %INTEGER PRNUM %STRING(23) PROMP %STRING(15) DPROMP %INTEGER EVALIMIT,EVALCNT,APPUCNT,APPULIM ! ! 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 ! ! ! FUNCTION SPEC AREA DECLARATIONS ! %INTEGERARRAYNAME FNVAL,OLDFN,ASSOCWA %INTEGERARRAYFORMAT INTFORM1 (0:1022) ! OLDFN HAS OLD FNVAL ENTRY WHEN FN REDEFINED. ! ASSOCWA HAS OBJECT ASSOCIATION POINTER INTO LIST SPACE. ! ASSOCWA USED ONLY BY MAKEASSOC,GETASSOC,AND REMASSOC %OWNINTEGER SYSPRE=X'1000000',INFIX=X'2000000',INTERP=X'4000000',%C USERPRE=X'8000000' %INTEGER NEWFN,DEFINED %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',PARSE=X'C0000000' %INTEGER INDENT,NXTSTP %STRING(255) PARSPR ! ! USER STACK DECLARATIONS %INTEGERARRAYNAME STK %INTEGER STKTOP,STKPNT ! ! ! SYSTEM STACK DECLARATONS %INTEGERARRAYNAME SYSTK %INTEGERARRAYFORMAT INTFORM2(1:2000) %INTEGER SYSTKPNT ! ! ! ! ! LIST AREA DECLARATIONS ! %INTEGERARRAYNAME LA %INTEGERARRAYFORMAT INTFORM3(1:65536) ! ALL LIST STRUCTURE IS CONSTRUCED IN LA. ! LA IS DIVIDED INTO THREE PARTS. THE FIRST AND SECOND PARTS ARE ! USED AS THE TWO SEMISPACES FOR LISTS GENERATED BY THE USER AND BY ! THE INPUT READER. ONLY ONE SEMISPACE IS ACTIVE AT ONE TIME, THE ! COLLECTOR COPYING FROM ONE TO THE OTHER. ! THE THIRD PART IS USED FOR FUNCTION DEFINITIONS AND IS NEVER ! COLLECTED. %OWNINTEGER LA1B=1,LA1T=24576,LA2B=24577,LA2T=49152,LAFNB=49153, %C LAFNT=65536 ! TOP AND BOTTOM VALUES OF VARIOUS LIST SPACES %INTEGER CLECTFLG; ! GARBAGE COLLECT FLAG %INTEGER LISTOP,LPOINT,LPOINT1,LABASE,SEMISIZE ! LPOINT IS FREE POINTER TO COLLECTABLE LIST AREA ! LPOINT1 IS FREE POINTER TO UNCOLLECTABLE AREA ! LABASE IS BASE OF CURRENT SEMISPACE ! SEMISIZE IS SIZE OF SEMISPACE ! %REAL CFRACT; ! GARBAGE COLLECT WHEN CFRACT OF SPACE USED %INTEGER QUOTEON,BLEVEL; ! USED BY LIST READER %INTEGERNAME NIL %STRING(1) SEP; ! USED BY PRINTER %OWNSTRING(1) STERMIN=' '; ! NL ASSSTRING %OWNINTEGER TERMIN=' '; ! NL AS SYMBOL %INTEGER CHAROUT %INTEGER ENUF %OWNINTEGER LM=2 ! ! ! ENVIRONMENT DECLARATIONS ! %INTEGERARRAYNAME BNAME,BVALUE %INTEGERARRAYFORMAT INTFORM4(1023:3000) %INTEGERARRAYFORMAT INTFORM5(0:3000) %INTEGER BASENVIR,TOPMARK ! ! ! ! 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 %INTEGER QUITFLAG,HOLDFLAG; ! USER INT FLAGS ! ! ! WORD AREA ! ! ! WORDS (EXCLUDING NUMBERS) ARE HELD UNIQUELY IN STRING ARRAY WA ! AND ARE REPRESENTED BY AN INTEGER CARRYING THE WORD MARKER AND THE ! INDEX IN WA. ! NUMBERS ARE REPRESENTED BY AN INTEGER CARRYING THE ! BINARY VALUE OF THE NUMBER IN THE TOP THREE BYTES AND THE ! NUMBER MARKER IN THE BOTTOM BYTE. ! FUNCTION PUT IS USED TO TRANSFORM WORDS INCLUDING NUMBERS ! TO INTERNAL FORM. IF THE WORD IS A NUMBER IT IS CONVERTED TO ! BINARY OTHERWISE IT IS HASHED. ! FUNCTION HASH PLACES A WORD INTO WA. AN OPEN HASH IS USED STARTING ! WITH A KEY GENERATD BY FUNCTION HASHFUN. THE KEY IS INCREMENTED ! WHEN NECESSARY BY 1, IN ORDER TO KEEP THE SEARCH AREA TO A PAGE ! OR SO. ! ! ! ! ! FILING SYTEM VARS ! ! %RECORDFORMAT D (%STRING(63)PROCNAME,%INTEGER TEXTINDEX) %RECORDARRAYFORMAT DIRFORM(1:603) (D) %RECORDARRAYNAME DIR(D); ! DIRECTORY %BYTEINTEGERARRAYFORMAT TEXTFORM(0:36864); ! 9 PAGESS WORTH %BYTEINTEGERARRAYNAME TEXT %SHORTINTEGERNAME DIRNUM,UNTIDY; ! NO OF DIRENTRIES AD UNTIDY FLAG %SHORTINTEGERNAME WRITINGFILE,DIRPAGES; ! WRITEFLAG AND NO OF DIRPAGES %INTEGERNAME NFTEXT; ! NEXT FREE TEXT INDEX %INTEGER OWNFLENGTH,OWNFADDR; ! OWN FILE LENGTH AND START ADDRESS %INTEGER BFLENGTH,BFADDR; ! DITTO BORROWED FILE %STRING(15) OWNFILE,BFILE; ! FILE NAME OWN AND BORROWED %INTEGER BORROWFLAG,BORROWLOAD,FULLFLAG %OWNINTEGER PAGES=10; ! SIZE OF FILES %OWNINTEGERARRAY PAGENTRIES(1:10)=60,120,180,240,300,361,421,481, 541,602; ! NO OF COMPLETE DIR ENTRIES IN 1,2,3 PAGES ETC %INTEGER DEVICE,CURTEXT %OWNINTEGER DISC=1,TTY=0 %STRING(64) USER,BORROWEE ! %STRING(64)%ARRAYFORMAT USERFORM(1:99) %INTEGERNAME MASENTS; ! NO OF MASTER DIR ENTRIES %STRINGARRAYNAME USERIDS ! %OWNSTRING(7) MASNUM='ECMI50.' %OWNSTRING(20) MASNAME='MASTER ' %OWNSTRING(8)%ARRAY SYSFILES(1:4)='CRASHDRO','LOGALERT','LOGRECAL', 'EXEC26' ! ! ! 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 %SHORTINTEGERNAME BINARG1,BINARG2,BINARG3,BINARG4,BINARG5 ! EQUIVALENCED TO BINBUFF(4,6,8,ETC) %INTEGER ADDRBINBUFF; ! ADDRESS PF BINBUFF(1) ! ! CODE INSERTED TO MONITOR HASHFN ! LOGO COMMAND HASHINFO ! %SHORTINTEGERARRAY HASHINFO(0:1022) %INTEGER HASH1023,HASH1024 ! ! HASHINFO IS PARALLEL TO WA ! HASH1023 HOLDS TOTAL NO OF ACCESSES OF WA ! HASH1024 HOLDS TOTAL NO OF WORDS HASHED ! %INTEGERFN HASH(%STRING(64) WORD) %INTEGER WPOINT,FULLMARK,HASH %STRING(64) W ! %INTEGERFN HASHFUN WORK1=SPACE4; ! FIRST FOUR CHARS OF WORD USED. FILL WITH SPACES WORK1=WORD; ! IN CASE ACTUAL WORD LESS THAN FOUR %RESULT=HASHVAL-1023*(HASHVAL//1023) ! HASHVAL IS EQUIVALENCED TO FIRST FOUR CHARS OF WORK1 IN INITIALISE %END; ! END HASHFUN ! FULLMARK=0; ! USED TO TELL IF TABLE FULL WPOINT=HASHFUN; ! GENERATE KEY HASH=WPOINT LP:W=WA(WPOINT); ! RETRIEVE WORD AT KEY HASH1023=HASH1023+1 %IF W='?' %THENSTART; ! NOT YET USED SO WA(WPOINT)=WORD; ! PLACE WORD HASHINFO(WPOINT)=HASH HASH1024=HASH1024+1 %RESULT=WPOINT<<8!WM; ! AND RETURN INDEX %FINISH %IF W=WORD %THENSTART HASH1024=HASH1024+1 %RESULT=WPOINT<<8!WM; ! ALREADY ENTERED %FINISH WPOINT=WPOINT+1; ! NOT AT KEY POSITION SO INCREMENT %IF WPOINT>1022 %THENSTART; ! TAKE MODULO AND CHECK FOR WA FUL %IF FULLMARK=1 %THEN BADERROR('WORD AREA OVERFLOW',EMPTY) %C %ELSESTART; FULLMARK=1 WPOINT=0 %FINISH %FINISH ->LP %END; ! END HASH ! ! %INTEGERFN PUT(%STRING(64) WORD) ! WORD IS A STRING OF ALPHANUMERIC CHARS ONLY ! IF THEY ARE ALL NUMERIC,THE STRING IS CONVERTED TO A NUMBER ! OTHERWISE THE WORD IS HASHED. ! A NEGATIVE NUMBER IN STRING FORM SHOULD NOT EXIST IN THE ! SYSTEM, BUT IN ANY CASE WOULD NOT BE CONVERTED TO A NUMBER HERE. %INTEGER NUM,I,J,CHAR,TOOLONG %BYTEINTEGERARRAY STRBYTE(0:64) STRING(ADDR(STRBYTE(0)))=WORD I=STRBYTE(0) %IF I>7 %THEN TOOLONG=1 %ELSE TOOLONG=0 NUM=0; J=1 %IF WORD='' %THENRESULT=HASH(WORD); %WHILE I>0 %CYCLE CHAR=STRBYTE(I) %IF 47NUMTOP %THENRESULT=ERR %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 ! %INTEGERFN STATUS(%STRING(15) FILENAME,%INTEGER LEVEL) ! FINDS CONNECT STATUS OF FILENAME %RECORDFORMAT F(%INTEGER AD,SIZE,%BYTEINTEGER RUP,%C EEP,MODE,CONS,ARCH,%STRING(6) TRANS,%SHORTINTEGER TYPE,%C NPERMS,%INTEGER DST,DEND,PTR) %RECORD R(F) %INTEGER FLAG FINFO('NOFILE',0,R,FLAG) FINFO(FILENAME,LEVEL,R,FLAG) %IF FLAG>0 %THEN %RESULT=-FLAG %RESULT=R_CONS %END; ! END STATUS ! ! %ROUTINE BADERROR(%STRING(80) ERRMESS,%INTEGER CULPRIT) %IF TDEV = 8 %THEN SET42(CHTXT) NOOLINE(1) PRSTRING(ERRMESS) SPACE;PRINTEL(CULPRIT) NOOLINE(1) DUMP(ERRMESS) %MONITORSTOP %END; ! END BADERROR ! %INTEGERFN TIME100 %LONGREAL X X=CPUTIME %RESULT=INT(CPUTIME*100) %END; ! END TIME100 ! ! ! ! ! ! ! LIST AREA AND LISTPRO PRIMITIVES ! ! LIST STRUCTURE IS HELD IN INTEGER ARRAY LA. A LIST IS REPRESENTED ! BY TWO ADJACENT ELEMENTS OF LA - THE FIRST POINTING TO THE HEAD ! THE SECOND POINTING TO THE TAIL. EACH ELEMENT CARRIES A MARKER ! IDENTIFYING IT AS A LIST ,A WORD OR A NUMBER. ! THE NULL LIST IS REPRESENTED BY A POINTER TO THE WORD 'NIL' ! IN THE WORD AREA. ! ABSOLUTE POINTERS ARE USED IN LA AND ARE THUS ALWAYS POSITIVE, ! A LIST IS ADDRESSED BY AN INTEGER CARRYING A LIST MARKER AND A ! POINTER TO ITS FIRST LA ELEMENT - I.E. ITS HEAD. ! ! ! %INTEGERFN HD(%INTEGER LIST); ! RETRIIEVES HEAD OF LIST %IF LIST&LM=0 %OR LIST=NIL %THEN BADERROR('NON-LIST ARG FOR HEAD - ',%C LIST) %RESULT=LA(LIST>>8) %END; ! END HD ! ! %ROUTINE REPHEAD(%INTEGER LIST,NEWHEAD); ! UPDATES HEAD OF LIST %IF LIST&LM=0 %OR LIST=NIL%THEN BADERROR('NON-LIST ARG FOR REPHEAD',%C LIST) LA(LIST>>8)=NEWHEAD %END; ! END REPHEAD ! ! %INTEGERFN TL(%INTEGER LIST); ! RETRIEVES TAIL OF LIST %IF LIST&LM=0 %OR LIST=NIL %THENC BADERROR('NON-LIST ARG FOR TAIL - ',LIST) %RESULT=LA(LIST>>8+1) %END; ! END TL %ROUTINE REPTAIL(%INTEGER LIST,NEWTAIL) %IF LIST&LM=0 %OR LIST=NIL %THENC BADERROR('NONLIST FIRST ARG FOR REPTAIL - ',LIST) %IF NEWTAIL&LM=0 %THENC BADERROR('NON-LIST SECOND ARG FOR REPTAIL - ',NEWTAIL) LA(LIST>>8+1)=NEWTAIL %END; ! END REPTAIL ! ! %INTEGERFN CONS(%INTEGER X,LIST); ! CONSTRUCTS LIST WITH HEAD X %INTEGER I; ! AND TAIL LIST I=LPOINT %IF LIST&LM=0 %THEN BADERROR('NON-LIST SECOND ARG FOR CONS - ',LIST) LA(LPOINT)=X LA(LPOINT+1)=LIST LPOINT=LPOINT+2 %IF (LPOINT-LABASE)>CFRACT*SEMISIZE %THEN CLECTFLG=1 ! SET COLLECT FLAG %RESULT=I<<8!LM %END; ! END CONS ! %INTEGERFN CONS1(%INTEGER X,LIST) ! CONS1 COSTRUCTS LIST WITH HEAD X AND TAIL LIST IN UNCOLLECTABLE SPACE ! I.E. FUNCTION SPACE. IT IS IDENTICAL TO CONS EXCEPT THAT ! IT USES LPOINT1 INSTEAD OF LPOINT AS THE FREE POINTER %INTEGER I I=LPOINT1 %IF LPOINT1>=(LAFNT-1) %THEN BADERROR('FNSPACE OVERFLOW',EMPTY) %IF LIST&LM=0 %THEN BADERROR('NON-LIST SECOND ARG FOR CONS1 - ',LIST) LA(LPOINT1)=X LA(LPOINT1+1)=LIST LPOINT1=LPOINT1+2 %RESULT=I<<8!LM %END; ! END CONS1 ! %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 ! 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) DEFINED=GENCOPY(DEFINED) ! ! 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('SM07,'.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('SM07') 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) %IF LIST&LM#LM %OR LIST=NIL %THENRESULT=LIST %RESULT=CONS1(COPY(HD(LIST)),COPY(TL(LIST))) %END; ! END COPY ! %IF LIST&LM#LM %THEN BADERROR('NON-LIST ARG FOR MOVE1 - ',LIST) %IF (LIST>>8)>=LAFNB %THENRESULT=LIST; ! ALREADY IN FNSPACE %RESULT=COPY(LIST) %END; ! END MOVE ! %INTEGERFN REVERSE(%INTEGER LIST) %INTEGER LIST1 LIST1=NIL %WHILE LIST#NIL %CYCLE LIST1=CONS(HD(LIST),LIST1) LIST=TL(LIST) %REPEAT %RESULT=LIST1 %END; ! END REVERSE ! ! ! ! ! ! ! ENVIRONMENT ! ! VARIABLE BINDINGS ARE HELD AS (NAME,VALUE) PAIRS IN ARRAYS ! BNAME AND BVALUE. THE CURRENT ENVIRONMENT IS DEFINED BY ENVIR ! WHICH POINTS TO THE TOP OF THE LAST ENVIRONMEBT CREATED, ! OR IS EQUAL TO 1022 IF ONLY THE BASE ENVIRONMENT EXISTS. ! WHENEVER A LOGO FUN IS APPLIED, THE PARAMETER NAMES AND LOCAL ! NAMES ARE INSERTED IN A NEWLY CREATED ENVIRONMENT TOGETHER WITH ! A SINGLE DIAGNOSTIC RECORD (THE FIRST) WHICH HAS 0 AS ITS NAME ! COMPONENT. ! SUCH LOCAL ENVIRONMENTS ARE CREATED UPWARDS FROM 1023. ! BVALUE(0-1022) IS USED FOR THE BASE ENVIRONMENT VALUES. ! THIS PART OF BVALUE IS PARALLEL TO WA AND IS ACCESSED ! BY DIRECT APPLICATION OF THE WORD INDEX. ! BASENVIR IS USED TO REFER TO THE BASE ENVIR ! VARIABLE UNDEF CONTAINS A POINTER TO THE WORD 'UNDEF' IN THE WORD ! AREA. ! FUNCTION UNSTACK RETREIVES THE TOP ELEMENT FROM THE LOGO STACK. ! VARIABLE NIL POINTS TO THE EMPTY LIST-THE WORD 'NIL'. ! VARIABLE DOTS POINTS TO THE WORD ':'. ! ! ! ! %INTEGERFN FINDBIND(%INTEGER NAME,ENVIR) ! FINDS A BINDING IN AN ENVIRONMENT. IF CALLED WITH ENVIR<=1022,ONLY ! THE GLOBAL ENVIRONMENT IS INTERROGATED. LOCAL:%WHILE ENVIR>1022 %CYCLE %IF BNAME(ENVIR)=0 %THENSTART; ! SKIP DIAGNOSTIC RECORD AT START ENVIR=ENVIR-1 ->LOCAL %FINISH %IF BNAME(ENVIR)=NAME %THENRESULT=ENVIR; ! FOUND IT ENVIR=ENVIR-1 %REPEAT NAME=NAME>>8; ! NOT LOCAL SO TRY GLOBAL %IF BVALUE(NAME)=0 %THENRESULT=UNDEF %ELSERESULT=NAME %END; ! END FINDBIND ! ! %ROUTINE SETVAL(%INTEGER NAME,VALUE,ENVIR) ! UPDATES A BINDING IF ONE EXISTS,OTHERWISE CREATES A NEW GLOBAL BINDING %INTEGER BINDING BINDING=FINDBIND(NAME,ENVIR) %IF BINDING=UNDEF %THENSTART; ! NOT YET DEFINED BVALUE(NAME>>8)=VALUE; ! SO CREATE IT GLOBALLY %FINISHELSE BVALUE(BINDING)=VALUE; ! ALREADY DEFINED SO UPDATE IT %END; ! END SETVAL ! ! %INTEGERFN GETVAL(%INTEGER NAME,ENVIR); ! RETRIEVES A BINDING %INTEGER BINDING BINDING=FINDBIND(NAME,ENVIR) %IF BINDING=UNDEF %THENRESULT=UNDEF %ELSERESULT=BVALUE(BINDING) %END; ! END GETVAL ! ! %INTEGERFN SETBIND(%INTEGER PARMLIST,ENVIR) ! BINDS PARMATER NAMES AND ARGS IN NEW ENVIRONMENT ! PARAMETER NAMES ARE IN PARMLIST IN REVERSE ORDER. ! ARG VALUES ARE ON STACK %WHILE PARMLIST#NIL %CYCLE %IF ENVIR=3000 %THEN BADERROR('ENVIRONMENT OVERFLOW',EMPTY) ENVIR=ENVIR+1 BNAME(ENVIR)=HD(PARMLIST) BVALUE(ENVIR)=UNSTACK PARMLIST=TL(PARMLIST) %REPEAT %IF ENVIR>TOPMARK %THEN TOPMARK=ENVIR; ! TOPMARK USED BY DUMP %RESULT=ENVIR %END; ! END SETBIND ! %INTEGERFN MAKEBIND(%INTEGER PARMLIST,ENVIR,FNAME) ! MAKEBIND CREATES NEW LOCAL ENVIRONMENT INSERTING DIAGNOSTIC ! RECORD AND BINDING PARAMETERS %IF ENVIR=3000 %THEN BADERROR('ENVIRONMENT OVERFLOW',EMPTY) ENVIR=ENVIR+1 BNAME(ENVIR)=0; ! DIAGNOSTIC RECORD BVALUE(ENVIR)=FNAME %RESULT=SETBIND(PARMLIST,ENVIR) %END; ! END MAKEBIND ! ! ! ! USER STACK MANIPULATION ! %INTEGERFN UNSTACK %IF STKPNT=0 %THEN BADERROR('STACK UNDERFLOW',EMPTY) STKPNT=STKPNT-1 %RESULT=STK(STKPNT+1) %END; ! END UNSTACK ! %ROUTINE STACK(%INTEGER I) %IF STKPNT=2000 %THEN BADERROR('STACK OVERFLOW',EMPTY) STKPNT=STKPNT+1 STK(STKPNT)=I %END; ! END STACK; ! ! ! SYSTEM STACK ! USED TO MAKE REFS TO COLLECTABLE LIST STRUCTURE FROM IMP LOCALS ! AVAILABLE TO THE COLLECTOR. ! %INTEGERFN UNSTKSYS %IF SYSTKPNT=0 %THEN BADERROR('SYSTACK UNDERFLOW',EMPTY) SYSTKPNT=SYSTKPNT-1 %RESULT=SYSTK(SYSTKPNT+1) %END; ! END UNSTKSYS ! %ROUTINE STKSYS(%INTEGER I) %IF SYSTKPNT=2000 %THEN BADERROR('SYSTACK OVERFLOW',EMPTY) SYSTKPNT=SYSTKPNT+1 SYSTK(SYSTKPNT)=I %END; ! END STKSYS ! ! ! ! SYSTEM INPUT/OUTPUT ! ! ALL SYSTEM INPUT IS IN THE FORM OF A LIST WITH OUTERMOST ! BRACKETS IMPLICIT. SPACES AND NOOLINE AT START OF INPUT ARE ! DISCARDED OTHERWISE THEY SERVE TO DELIMIT WORDS. THE LIST IS ! TERMINATED WITH A SEMI COLON ! AT LEVEL 1 (IE USER LEVEL ZERO),THE MINUS CHAR IS LEFT ! AS A SEPARATE WORD. AT ANY OTHER LEVEL IT IS ASSUMED TO BE ! THE UNARY MINUS AND MUST BE FOLLOWED BY A NUMBER. THE NUMBER ! IS THEN CONVERTED TO BINARY AND NEGATED. ! ! ! ! %ROUTINE CAPTION (%STRING (255) WORD) ! ! *** USED TO SEND TEXT AS PART OF A PICTURE TO THE GT42 ! *** PROCESOR %CONSTINTEGER LETTER WIDTH = 14 %BYTEINTEGERMAP MSB (%INTEGER I) %RESULT== BYTEINTEGER(ADDR(WORD)+I+1) %END %BYTEINTEGERMAP LSB (%INTEGER I) %RESULT == BYTEINTEGER(ADDR(WORD)+I) %END ! %INTEGER I, L; %IF DEF PICTURE = 0 %THENSTART ;! IMMEDIATE EXECUTION SET42(CHPIC) MODE42(CHARM) %FINISH %ELSE %START CURPIC = CONSG(X'8000',CURPIC) CUR42MODE = CHAR M %FINISH L = LENGTH(WORD) GRAPHP = GRAPHP + L + (L&1)<<1 !UPDAA?E TURTLE COORDS ! XTURTLE=XTURTLE+ LETTER WIDTH * L I = 1 %CYCLE %IF DEF PICTURE = 0 %THENSTART %IF L=0 %THENRETURN CH3(ADD1) %IF L = 1 %THEN CH3(LSB(I)) %ANDRETURN CH3 (MSB(I)<< 8 ! LSB(I)) %FINISHELSESTART %IF L = 0 %THENEXIT %IF L = 1 %THEN CURPIC = CONSG(LSB(I),CURPIC) %ANDEXIT CURPIC = CONSG(MSB(I)<<8!LSB(I), CURPIC) %FINISH L = L - 2 I = I + 2 %REPEAT GMODE = 3 ! %END ! ! DRIBBLE FILE BITS AND OIECES ! %CONSTSTRING(10) INTQ=' INT:Q ',INTH=' INT:H ' %BYTEINTEGERARRAYFORMAT DF(1:50000) %BYTEINTEGERARRAYNAME DFILE %INTEGERNAME DPNT %BYTEINTEGERARRAY LINE BUFFER(1:80) %INTEGER BPNT ! %INTEGERFN ETIME %BYTEINTEGERARRAY BT(0:8) STRING(ADDR(BT(0)))=TIME BT(1)=BT(1)-'0' BT(2)=BT(2)-'0' BT(4)=BT(4)-'0' BT(5)=BT(5)-'0' BT(7)=BT(7)-'0' BT(8)=BT(8)-'0' %RESULT=((BT(1)*10+BT(2))*60+BT(4)*10+BT(5))*60+BT(7)*10+BT(8) %END; ! END ETIME ! %ROUTINE DRIBBLE(%STRING(255) S) %BYTEINTEGER SAVE SAVE=DFILE(DPNT) STRING(ADDR(DFILE(DPNT)))=S DFILE(DPNT)=SAVE DPNT=DPNT+LENGTH(S) %END; ! END DRIBBLE ! %ROUTINE DPRINTSTRING(%STRING(255) S) DRIBBLE(S) PRINTSTRING(S) %END; ! END DPRINTSTRING ! %ROUTINE DNEWLINE DPNT=DPNT+1 DFILE(DPNT)=NL NEWLINE %END; ! END DNEWLINE ! %ROUTINE DPROMPT(%STRING(15) S) DPROMP=S PROMPT(S) %END; ! END DPROMPT ! %ROUTINE FILL LINE BUFFER %INTEGER N,T T=ETIME DRIBBLE(DPROMP) BPNT=0 %UNTIL N=NL %CYCLE READSYMBOL(N) %IF N#NL %THENSTART DPNT=DPNT+1 DFILE(DPNT)=N %FINISH BPNT=BPNT+1 LINE BUFFER(BPNT)=N %REPEAT T=(ETIME-T)<<8 %CYCLE N=1,1,80-BPNT-LENGTH(DPROMP) DPNT=DPNT+1 DFILE(DPNT)='.' %REPEAT DRIBBLE(NUMTOSTR(T)) DPNT=DPNT+1 DFILE(DPNT)=NL BPNT=1 %END; ! END FILL LINE BUFFER ! %ROUTINE LGREADSYM(%INTEGERNAME SYM) %IF DEVICE=TTY %THENSTART SYM=LINE BUFFER(BPNT) BPNT=BPNT+1 %FINISHELSESTART SYM=TEXT(CURTEXT) CURTEXT=CURTEXT+1 %FINISH %END; ! END LGREADSYM ! ! %INTEGERFN LGNEXTSYM %IF DEVICE=TTY %THENRESULT=LINE BUFFER(BPNT) %RESULT=TEXT(CURTEXT) %END; ! END LGNEXTSYM ! ! %ROUTINE LGSKIPSYM %IF DEVICE=TTY %THEN BPNT=BPNT+1 %ELSE CURTEXT=CURTEXT+1 %END; ! END LGSKIPSYM ! ! %ROUTINE LGREADITEM(%STRINGNAME ITEM) %IF DEVICE=TTY %THENSTART ITEM=TOSTRING(LINE BUFFER(BPNT)) BPNT=BPNT+1 %FINISHELSESTART ITEM=TOSTRING(TEXT(CURTEXT)) CURTEXT=CURTEXT+1 %FINISH %END; ! END LGREADITEM ! ! ! ! %INTEGERFN READLIST(%INTEGER LEVEL) ! %INTEGERFN GETITEM %INTEGER SYM,N,RES %STRING(2) ITEM %STRING(64) WORD %INTEGER SYMCOUNT SYMCOUNT=0;WORD='' N=LGNEXT SYM %IF QUOTEON=1 %AND (N<45 %OR 5790) %THENRESULT=EMPTY LP:N=LGNEXT SYM %IF N=' ' %THENSTART LGSKIP SYM %IF SYMCOUNT=0 %THEN ->LP %ELSESTART SYMCOUNT=0 RES=PUT(WORD) %IF RES=ERR %THEN DPRINTSTRING('NUMBER TOO LARGE.') %AND ->ERR1 %RESULT=RES %FINISH %FINISH %IF N='+' %THENSTART %IF SYMCOUNT=0 %THENSTART LGREADSYM(N) %UNTIL N=NL DPROMPT(' C:') FILL LINE BUFFER %IF DEVICE=TTY ->LP %FINISHELSESTART SYMCOUNT=0 RES=PUT(WORD) %IF RES=ERR %THEN DPRINTSTRING('NUMBER TOO LARGE.') %AND ->ERR1 %RESULT=RES %FINISH %FINISH %IF N=TERMIN %THENSTART;DPROMPT(PROMP) %IF SYMCOUNT=0 %THENSTART %IF LEVEL>BLEVEL %THENSTART DPRINTSTRING('MISSING RIGHT BRACKET.') ->ERR1 %FINISH LGSKIP SYM %RESULT=RBRAK %FINISHELSESTART SYMCOUNT=0 RES=PUT(WORD) %IF RES=ERR %THEN DPRINTSTRING('NUMBER TOO LARGE.') %AND ->ERR1 %RESULT=RES %FINISH %FINISH %IF N=LBRAK %OR N=RBRAK %THENSTART %IF SYMCOUNT=0 %THENSTART;LGREAD SYM(SYM);%RESULT=SYM %FINISHELSESTART SYMCOUNT=0 RES=PUT(WORD) %IF RES=ERR %THEN DPRINTSTRING('NUMBER TOO LARGE.') %AND ->ERR1 %RESULT=RES %FINISH %FINISH %IF N='-' %THENSTART %IF SYMCOUNT=0 %THENSTART LGSKIP SYM N=LGNEXT SYM SYM=GETITEM %IF SYM=ERR %THENRESULT=ERR %IF SYM=LBRAK %OR SYM=RBRAK %OR SYM&NM=0 %THENSTART DPRINTSTRING('INVALID ''-''.') ->ERR1 %FINISHELSERESULT=(-SYM>>8)<<8!NM %FINISHELSESTART SYMCOUNT=0 RES=PUT(WORD) %IF RES=ERR %THEN DPRINTSTRING('NUMBER TOO LARGE.') %AND ->ERR1 %RESULT=RES %FINISH %FINISH %IF N<48 %OR (N>57 %AND N <65) %OR N>90 %THENSTART %IF SYMCOUNT=0 %THENSTART LGREAD ITEM(ITEM) %RESULT=PUT(ITEM) %FINISHELSESTART SYMCOUNT=0 RES=PUT(WORD) %IF RES=ERR %THEN DPRINTSTRING('NUMBER TOO LARGE.') %AND ->ERR1 %RESULT=RES %FINISH %FINISH LGREAD ITEM(ITEM); %IF SYMCOUNT=64 %THENSTART DPRINTSTRING('TOO MANY CHARACTERS IN WORD.') ->ERR1 %FINISHELSESTART WORD=WORD.ITEM;SYMCOUNT=SYMCOUNT+1 %FINISH ->LP ERR1:%WHILE N#NL %THEN LGREAD SYM(N) DPRINTSTRING(' LINE DISCARDED.') DNEWLINE %RESULT=ERR %END; ! END GETITEM ! %INTEGER THISPOINT,ITEM THISPOINT=LPOINT ITEM=GETITEM %IF ITEM=ERR %THENRESULT=ERR %IF ITEM=QUOTE %THEN QUOTEON=1 %ELSE QUOTEON=0 %IF ITEM=RBRAK %THENSTART %RESULT=NIL %FINISHELSESTART LPOINT=LPOINT+2 %IF (LPOINT-LABASE)>CFRACT*SEMISIZE %THEN CLECTFLG=1 ! SET FLAG FOR COLLECT %IF ITEM=LBRAK %THENSTART ITEM=READLIST(LEVEL+1) %IF ITEM=ERR %THENRESULT=ERR %FINISH LA(THISPOINT)=ITEM ITEM=READLIST(LEVEL) %IF ITEM=ERR %THENRESULT=ERR LA(THISPOINT+1)=ITEM %RESULT=THISPOINT<<8!LM %FINISH %END; ! END READLIST ! ! ! %INTEGERFN READLINE %INTEGER RES LP:BLEVEL=1 %IF DEVICE=TTY %THEN FILL LINE BUFFER RES=READLIST(BLEVEL) %IF RES=ERR %THEN ->LP %RESULT=RES %END; ! END READLINE ! %ROUTINE NOOLINE(%INTEGER N) %WHILE N>0 %CYCLE DNEWLINE N=N-1 %REPEAT CHAROUT=0 %END; ! END NOOLINE ! %ROUTINE PRSTRING(%STRING(255) WORD) %INTEGER N %IF CAPFLAG=1 %THEN CAPTION(WORD) %ANDRETURN N=LENGTH(WORD) %IF (CHAROUT+N)>72 %THENSTART DNEWLINE %IF WORD->(' ').WORD %THEN N=N-1 DPRINTSTRING(' ') DPRINTSTRING(WORD) CHAROUT=N+3 %FINISHELSESTART DPRINTSTRING(WORD) CHAROUT=CHAROUT+N %FINISH %END; ! END PRSTRING ! %ROUTINE LGPRNTSTR(%STRING(65) WORD) %BYTEINTEGER SAVE %INTEGER L %IF DEVICE=TTY %THEN PRSTRING(WORD) %ANDRETURN %IF FULLFLAG=1 %THENRETURN L=LENGTH(WORD) %IF (OWNFLENGTH-DIRPAGES*4096-NFTEXT+1)>8) PRINTWORD(WORD) %END; ! END PRINTWN ! %ROUTINE PRINTLCON(%INTEGER LIST) %INTEGER I LP:%IF ENUF=1 %OR (TESTINT(0,'ENUF')#0 %AND DEVICE=TTY) %THENSTART ENUF=1 %RETURN %FINISH %IF LIST=NIL %THENRETURN I=HD(LIST) %IF I&LM=LM %THEN PRINTLIST(I) %ELSE PRINTWN(I) LIST=TL(LIST) ->LP %END; ! END PRINTLCON ! %ROUTINE PRINTLIST(%INTEGER LIST) PRINTWORD('[') PRINTLCON(LIST) PRINTWORD(']') %END; ! END PRINTLIST ! ! %ROUTINE PRINTEL(%INTEGER I) ENUF=0 SEP='' %IF I&LM=LM %THEN PRINTLIST(I) %ELSE PRINTWN(I) %END; ! END PRINTEL ! ! %ROUTINE PRINTEL1(%INTEGER I) ENUF=0 SEP='' %IF I&LM=LM %THEN PRINTLCON(I) %ELSE PRINTWN(I) %END; ! END PRINTEL1 ! ! %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 ! ! ! ! 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 ! %ROUTINE EVALAPPL(%INTEGER PREC,%INTEGERNAME ENVIR,FUN,CURFUN,%C IN,TSTFLG,VAL,SEVERITY,WALKFN) ! ! ENVIR IS THE CURRENT ENVIRONMENT POINTER - 1022 IF OUTSIDE A USER ! FUN AND ONLY BASE ENVIR EXISTS. ! FUN IS THE USER FUN WE ARE CURRENTLY IN - NIL IF OUTSIDE USER ! FUN ! CURFUN IS THE REST OF THE USER FUN WE ARE CURRENTLY IN - NIL ! IF OUTSIDE USER FUN ! IN CONTAINS THE LINE WE ARE CURRENTLY EVALUATING EITHER FROM ! A USER FUN OR FROM THE TTY ! TSTFLG IS THE CURRENT TEST LOCATION USED BY TEST IFTRUE,ETC ! VAL IS THE LAST VALUE ! SEVERITY IS USED IN APPLYSYS TO TELL IF A CONTINUE ! IS POSSIBLE ! WALKFN IS USED TO TELL IF A USER FUNCTION IS BEING EXECUTED ! IN STEPPING MODE ! ! THESE PARAMETES ARE CREATED BY LOGO AT BASE LEVEL AND ARE ! RECREATED BY APPLYUSR ON EACH ENTRY TO USER FUN. ! THEY ARE USED FREE BY ROUTINE ERROR FOR DIAGNOSTIC PURPOSES ! AND BY APPLYSYS AND EVAL ! %ROUTINESPEC EVAL(%INTEGER PREC,%INTEGERNAME IN,EACHVAL,WALKFN) ! ! ! %ROUTINE ERROR(%STRING(255) ERRMESS,%INTEGER CULPRIT,SEVERITY,%C %INTEGERNAME IN) %INTEGER SAVEDEV %IF TDEV = 8 %THEN SET42(CHTXT) SAVEDEV=DEVICE DEVICE=TTY NOOLINE(1) %IF FUN=NIL %THENC PRSTRING('LOGO CANNOT FULLY EXECUTE THAT COMMAND, BECAUSE') %ELSESTART PRSTRING('LOGO CANNOT FULLY EXECUTE THIS COMMAND:-');NOOLINE(1) PRSTRING(' ');PRINTLINE(HD(CURFUN)) PRSTRING('IN PROCEDURE ');PRINTEL(HD(TL(TL(HD(FUN))))); PRSTRING(', BECAUSE') %FINISH NOOLINE(1) DPRINTSTRING(ERRMESS);PRINTEL1(CULPRIT);NOOLINE(3) JUMPFLAG=1; ! TRIGGERS A RETURN TO LOGO IN=NIL STACK(CONS(QQPROC,CONS(ERR,NSRTAIL))) DEVICE=SAVEDEV %RETURN ! FOLLOWING USED TO REENTER LOGO RECURSIVELY, SUSPENDING ! CURRENT PROCESS. NOT IMPLEMENTED IN THIS VERSION. ! ! STKSYS(IN) ! STKSYS(VAL); ! LOGO(STKPNT,MAKEBIND(NIL,ENVIR,LOGONAME),SEVERITY,0) ! VAL=UNSTKSYS ! IN=UNSTKSYS ! DEVICE=SAVEDEV ! %RETURN %END; ! END ERROR ! %ROUTINE ERROR1(%STRING(255) ERRMESS,%INTEGER CULPRIT) %INTEGER SAVEDEV SAVEDEV=DEVICE DEVICE=TTY DPRINTSTRING(ERRMESS);PRINTEL(CULPRIT);NOOLINE(1) DEVICE=SAVEDEV %END; ! END ERROR1 ! ! %ROUTINE ERROR2(%INTEGER CULPRIT) %INTEGER SAVEDEV SAVEDEV=DEVICE DEVICE=TTY NOOLINE(1) %IF FUN=NIL %THENSTART DPRINTSTRING %C ('THAT LINE IS NOT A COMMAND BECAUSE YOU DID NOT SAY WHAT TO DO WITH ') %FINISHELSESTART DPRINTSTRING('THIS LINE - ');PRINTEL(HD(CURFUN));NOOLINE(1) DPRINTSTRING('IN PROCEDURE ');PRINTEL(HD(TL(TL(HD(FUN))))) DPRINTSTRING(' IS NOT A COMMAND BECAUSE YOU DID NOT SAY WHAT TO DO WITH ') %FINISH %IF CULPRIT&WM=WM %THEN PRINTEL(QUOTE) PRINTEL(CULPRIT);NOOLINE(3) JUMPFLAG=1 IN=NIL STACK(CONS(QQPROC,CONS(ERR,NSRTAIL))) %RETURN %END; ! END ERROR2 ! ! ! ! %INTEGERFN REVQUOTE(%INTEGER LIST) ! REVERSES LIST AND REMOVES QUOTES %INTEGER LIST1,WORD %IF LIST=NIL %THEN ->RQ1 LIST1=NIL %WHILE LIST#NIL %CYCLE %IF HD(LIST)=QUOTE %THEN LIST=TL(LIST) %ELSE ->RQ1 %IF LIST=NIL %THEN ->RQ1 WORD=HD(LIST) %IF WORD&WM#WM %OR WORD=EMPTY %THEN ->RQ1 LIST1=CONS(WORD,LIST1) LIST=TL(LIST) %REPEAT %RESULT=LIST1 RQ1:ERROR('INCORRECT FORMAT FOR PROCEDURE TITLE LINE',EMPTY,1,IN) %RESULT=ERR %END; ! END REVQUOTE ! ! %ROUTINE CHKLIST(%INTEGER LIST) %INTEGER WORD %IF LIST&LM#LM %THENSTART ERROR(ERRMESS(53),LIST,1,IN) %RETURN %FINISH %WHILE LIST#NIL %CYCLE WORD=HD(LIST) %IF WORD&WM#WM %THENSTART ERROR(ERRMESS(53),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,%STRING(2) S) ! USED TO PRINT FN. NAME ETC WHEN ENTERING A TRACED/PARSED FN INDENT=INDENT+2 PARSPR=PARSPR.S DPRINTSTRING(PARSPR) PRINTEL(FN) %END ! ! %INTEGERFN SYSTRACE(%INTEGER TRBIT,FN) %INTEGER TRLIST, TRFN, TRWD TRLIST=OWNFUNS %WHILE TRLIST#NIL %CYCLE TRWD=HD(TRLIST);TRLIST=TL(TRLIST) TRFN=FNVAL(TRWD>>8) %IF TRFN&INTERP=INTERP %THENSTART ERROR1(WA(TRWD>>8).' IS A SPECIAL PROCEDURE OF LOGO'. %C ' WHICH CANNOT BE '.WA(FN>>8).'D',EMPTY) ->TR1 %FINISH FNVAL(TRWD>>8)=(TRFN&UNMASK)!TRBIT TR1:%REPEAT %RESULT=OWNFUNS %END; ! END SYSTRACE ! ! %INTEGERFN TRACE(%INTEGER TRBIT,ARG,FN) %INTEGER TRLIST,TRFN,TRWD %IF ARG=OWNFUNS %THENRESULT=SYSTRACE(TRBIT,FN) %IF ARG&WM=WM %THEN ARG=CONS(ARG,NIL) %IF ARG&LM#LM %THENSTART ERROR(WA(FN>>8).ERRMESS(24),ARG,1,IN) %RESULT=ERR %FINISH TRLIST=NIL %WHILE ARG#NIL %CYCLE TRWD=HD(ARG) ARG=TL(ARG) %IF TRWD&WM#WM %THENSTART ERROR1(WA(FN>>8).ERRMESS(24),CONS(TRWD,ARG)) ->TR2 %FINISH TRFN=FNVAL(TRWD>>8) %IF TRFN=0 %THENSTART ERROR1(ERRMESS(21).WA(TRWD>>8).ERRMESS(23),FN) ->TR2 %FINISH %IF TRFN&INTERP=INTERP %THENSTART ERROR1(WA(TRWD>>8).' IS A SPECIAL PROCEDURE OF LOGO'. %C ' WHICH CANNOT BE '.WA(FN>>8).'D',EMPTY) ->TR2 %FINISH FNVAL(TRWD>>8)=(TRFN&UNMASK)!TRBIT ; ! INSERT TRACE FLAG TRLIST=CONS(TRWD,TRLIST) TR2:%REPEAT %RESULT=TRLIST %END; ! END TRACE ! ! %ROUTINE ENDTRACE(%INTEGER FN) ! USED TO PRINT FN NAME ETC. WHEN EXITING A TRACED/PARSED FN INDENT=INDENT-2 BYTEINTEGER(ADDR(PARSPR))=INDENT DPRINTSTRING(PARSPR);DPRINTSTRING(' <') PRINTEL(FN) %END ! %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 %THENSTART BINBUFF(3)=N P_ARG3=N+3 %FINISHELSE 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 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,W1,W2,W3,W4 %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 EDIT %STRING(255) WSTR1,WSTR2,WSTR3 %ROUTINESPEC VECTOR(%REAL X,Y) %ROUTINESPEC CALC TURTLE ! ! %INTEGERFN EXTRACT(%INTEGERNAME COND,THENC,ELSEC) ! USED BY IF AND WHILE TO EXTRACT CLAUSES. ! RESULT IS EMPTY IF SYNTAX OK ! RESULT IS CULPRIT IF SOMETHING MISPLACED OR MISSING %INTEGER HEAD,RES,FN FN=HD(IN) COND=CONS(HD(IN),COND); ! INITIAL IF INTO COND IN=TL(IN) %WHILE IN#NIL %CYCLE ! LOOK FOR THEN BEFORE ELSE OR TERMIN HEAD=HD(IN) %IF HEAD=LPAR %THENSTART; ! LEFT PARENTHESES RES=GETMATCH(COND,IN); ! EXTRACT UP TO MATCHING RPAR %IF RES#EMPTY %THENRESULT=RES; ! PASS OUT ERROR %FINISHELSESTART %IF HEAD=THEN %THEN ->THENL; ! FOUND THEN %IF HEAD=ELSE %OR HEAD=RPAR %THENRESULT=THEN; ! ERROR - THEN MISSING %IF HEAD=IF %OR HEAD=WHILE %THENSTART RES=EXTRACT(COND,COND,COND) %IF RES#EMPTY %THENRESULT=RES; ! ERROR PASSED OUT %FINISHELSESTART COND=CONS(HEAD,COND) IN=TL(IN) %FINISH %FINISH %REPEAT %RESULT=THEN; ! ERROR - THEN NOT FOUND BEFORE END ! THENL:THENC=CONS(HD(IN),THENC) IN=TL(IN) %WHILE IN#NIL %CYCLE ! LOOK FOR ELSE OR ANOTHER THEN HEAD=HD(IN) %IF HEAD=LPAR %THENSTART RES=GETMATCH(THENC,IN) %IF RES#EMPTY %THENRESULT=RES %FINISHELSESTART %IF HEAD=ELSE %THEN ->ELSEL %IF HEAD=THEN %OR HEAD=RPAR %THENRESULT=EMPTY; ! END OF THIS IF %IF HEAD=IF %OR HEAD=WHILE %THENSTART RES=EXTRACT(THENC,THENC,THENC) %IF RES#EMPTY %THENRESULT=RES %FINISHELSESTART THENC=CONS(HEAD,THENC) IN=TL(IN) %FINISH %FINISH %REPEAT %RESULT=EMPTY; ! END OF THIS IF ! ELSEL:%IF FN=WHILE %THENRESULT=EMPTY; ! END OF WHILE ELSEC=CONS(HD(IN),ELSEC) IN=TL(IN) %WHILE IN#NIL %CYCLE HEAD=HD(IN) %IF HEAD=LPAR %THENSTART RES=GETMATCH(ELSEC,IN) %IF RES#EMPTY %THENRESULT=RES %FINISHELSESTART %IF HEAD=THEN %OR HEAD=ELSE %OR HEAD=RPAR %THENRESULT=EMPTY %IF HEAD=IF %OR HEAD=WHILE %THENSTART RES=EXTRACT(ELSEC,ELSEC,ELSEC) %IF RES#EMPTY %THENRESULT=RES %FINISHELSESTART ELSEC=CONS(HEAD,ELSEC) IN=TL(IN) %FINISH %FINISH %REPEAT %RESULT=EMPTY %END; ! END EXTRACT ! ! %INTEGERFN FINDASS(%INTEGER LIST,ATT) ! FINDS AN ASSOCIATION IN LIST WITH ATTRIBUTE ATT. USES W1 AND W2 ! FREE. IF ASSOC FOUND, W2 POINTS TO LIST STARTING WITH ASSOC AND ! W1 POINTS TO ONE BEFORE, UNLESS ASSOC IS FIRST IN LIST WHEN W1=W2 ! IN EITHER CASE W2 ALSO RETURNED VIA RESULT. ! IF NO ASSOC FOUND, NIL RETURNED. W1=LIST W2=LIST %WHILE W2#NIL %CYCLE %IF HD(HD(W2))#ATT %THENSTART W1=W2 W2=TL(W2) %FINISHELSERESULT=W2 %REPEAT %RESULT=NIL %END; ! END FINDASS ! ! ! %INTEGERFN UNSTACKINPUT %INTEGER ARG %STRING(63) STR ARG=UNSTACK %IF ARG&LM=LM %AND ARG#NIL %THENSTART %IF HD(ARG)=QQPROC %THEN STR=WA(HD(TL(ARG))>>8) %ELSESTART %IF HD(ARG)=QQRESULT %THEN STR='RESULT' %ELSERESULT=ARG %FINISH ERROR('PROCEDURE '.STR.' DID NOT PRODUCE A RESULT AS INPUT FOR PROCEDURE ',FN,1,IN) %FINISH %RESULT=ARG %END; ! END UNSTACKINPUT ! ! %ROUTINE CHECKNUM %IF ARG1&NM#NM %OR ARG2&NM#NM %THEN %C ERROR(ERRMESS(10).WA(FN>>8).ERRMESS(11),%C CONS(ARG1,CONS(ARG2,NIL)),1,IN) %RETURN %END; ! END CHECKNUM ! %INTEGERFN CHECKSIZE(%INTEGER I) %IF I>NUMTOP %OR I>8).ERRMESS(31),EMPTY,1,IN) %RESULT=ERR %FINISH %RESULT=I %END; ! END CHECKSIZE ! %ROUTINE READYNUM ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN CHECKNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG1<0 %THEN ARG1=ARG1>>8!T8 %ELSE ARG1=ARG1>>8 %IF ARG2<0 %THEN ARG2=ARG2>>8!T8 %ELSE ARG2=ARG2>>8 %END; ! END READYNUM ! ! %ROUTINE CHECKSUM(%INTEGER ARG1,ARG2) ! CHECKS THAT ARG1+ARG2 DOES NOT EXCEED IMP LIMIT ! BOTH POSITIVE %IF MAXINT-ARG1>8).ERRMESS(31),%C EMPTY,1,IN) %RETURN %END ; ! END CHECKSUM ! ! %ROUTINE CHECKPROD(%INTEGER ARG1,ARG2) ! AS CHECKSUM FOR PRODUCT %IF MAXINT/ARG1>8).ERRMESS(31),%C EMPTY,1,IN) %RETURN %END; ! END CHECKPROD ! ! %ROUTINE WORD %INTEGER I %IF ARG1&LM=LM %OR ARG2&LM=LM %OR ARG1<0 %OR ARG2<0 %THENSTART ERROR(WA(FN>>8).ERRMESS(47),CONS(ARG1,CONS(ARG2,NIL)),1,IN) %RETURN %FINISH %IF ARG1&NM=NM %THEN WSTR1=NUMTOSTR(ARG1) %ELSEC WSTR1=WA(ARG1>>8) %IF ARG2&NM=NM %THEN WSTR2=NUMTOSTR(ARG2) %ELSEC WSTR2=WA(ARG2>>8) %IF LENGTH(WSTR1)+LENGTH(WSTR2)>64 %THEN ->ERR1 I=PUT(WSTR1.WSTR2) %IF I=ERR %THEN ->ERR1 STACK(I) %RETURN ERR1:ERROR(ERRMESS(30).WA(FN>>8).ERRMESS(31).ERRMESS(48),%C CONS(ARG1,CONS(ARG2,NIL)),1,IN) %RETURN %END; ! END WORD ! ! %ROUTINE LASTPUT %IF ARG2&LM=LM %THENSTART; ! ARG2 A LIST ARG3=NIL %WHILE ARG2#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT);%RETURN %FINISH %IF HOLDFLAG=1 %THENSTART STKSYS(ARG3);STKSYS(ARG2) ERROR('USER INTERRUPT',EMPTY,0,IN) ARG2=UNSTKSYS;ARG3=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 %FINISH ! ARG2 NOT A LIST SO WE WANT WORD ARG2,ARG1 ARG3=ARG1 ARG1=ARG2 ARG2=ARG3; !ARG1 AND ARG2 INTERCHANGED WORD %RETURN %END; ! END LASTPUT ! ! ! ! %INTEGERFN EQUAL(%INTEGER LIST1,LIST2) %IF QUITFLAG=1 %THENSTART QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1 %RESULT=QUIT %FINISH %IF HOLDFLAG=1 %THENSTART 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 ! ! %INTEGERFN GETNEXT(%INTEGERNAME IN) %INTEGER NEXT %IF IN=NIL %THENSTART ERROR('SOMETHING MISSING',EMPTY,1,IN) %RESULT=ERR %FINISH NEXT=HD(IN) IN=TL(IN) %RESULT=NEXT %END; ! END GETNEXT ! ! ! ! %ROUTINE FROMLIST(%INTEGERNAME LIST,%INTEGER ITEM) %INTEGER ARG %IF HD(LIST)=ITEM %THENSTART LIST=TL(LIST); ! MATCH LATEST ENTRY %RETURN;%FINISH ARG=LIST %WHILE TL(ARG)#NIL %CYCLE %IF HD(TL(ARG))=ITEM %THENSTART ! REPTAIL(ARG,TL(TL(ARG))); ! ALTERS NEWFN LIST ! %RETURN;%FINISH ARG=TL(ARG) %REPEAT %END; ! END FROMLIST ! ! %ROUTINE EDIT(%INTEGER USERFUN) %INTEGER LINE,LESSLINE,REST,DELLIST,SAVESTK %STRING(10) SAVEPROM ! %ROUTINE FINDLINE(%INTEGER NUM) ! SETS REST TO FUN STARTING AT LINE>=NUM, AND SETS LESSLINE ! TO FUN STARTING ONE LINE BEFORE LESSLINE=USERFUN REST=TL(USERFUN) %WHILE REST#NIL %AND HD(HD(REST))127 %THENSTART PRSTRING('TOO MANY INPUTS');NOOLINE(1) %RETURN %FINISH ITEM=HD(TL(LINE)); ! PROC NAME %IF ITEM#ARG1 %THENSTART; ! NEW NAME DIFF FROM OLD ARG2=FNVAL(ITEM>>8); ! FUNSPEC FOR NEW NAME %IF ARG2&USERPRE=USERPRE %THENSTART; ! ALREADT DEFINED PRSTRING('PROCEDURE ALREADY DEFINED - ') PRINTEL(ITEM);NOOLINE(1) %RETURN %FINISH %IF ARG2#0 %THENSTART; ! SYSTEM PROC PRSTRING('YOU CANNOT REDEFINE ONE OF ELOGO''S OWN PROCEDURES') NOOLINE(1) %RETURN %FINISH FNVAL(ARG1>>8)=0; ! UNDEFINE OLD NAME OLDFN(ARG1>>8)=0; ! AND STANDBY FROMLIST(NEWFN,ARG1) %UNLESS NEWFN=NIL FROMLIST(DEFINED,ARG1); ! DEFINED MUST HAVE ARG1 PRSTRING('PROCEDURE ');PRINTEL(ARG1) PRSTRING(' WILL FROM NOW ON BE NAMED ') PRINTEL(ITEM);NOOLINE(1) ARG1=ITEM NEWFN=CONS(ARG1,NEWFN) DEFINED=CONS(ARG1,DEFINED) %FINISH; ! FINISH ITEM#ARG1 ARG3=CONS1(DEFINEWORD,MOVE1(LINE)); ! REBUILD LINE REPHEAD(USERFUN,ARG3); ! REPLACE TITLE LINE IN DEF FNVAL(ARG1>>8)=USERPRE+USERFUN&M16+W1; ! NEW SPEC %FINISHELSESTART; ! FINISH ITEM=RETITLE %IF ITEM=DO %THENSTART; ! LINE FOR IMMEDIATE EVAL LINE=TL(LINE) STKSYS(DELLIST) STKSYS(IN) EVAL(0,LINE,EACHVAL,WALKFN) IN=UNSTKSYS DELLIST=UNSTKSYS VAL=UNSTACK %FINISHELSESTART; ! FINISH DO %IF ITEM&NM=NM %THENSTART; ! A NUMBERED LINE TO INSERT OR ! OR REPLACE EXISTING LINE FINDLINE(ITEM) %IF REST#NIL %AND HD(HD(REST))=ITEM %THENSTART; ! A LINE TP REPLACE DELLIST=CONS(HD(REST),DELLIST); ! SAVE REPLACED LINE REPHEAD(REST,MOVE1(LINE)); ! AND REPLACE LINE %FINISHELSE REPTAIL(LESSLINE,CONS1(MOVE1(LINE),REST)); ! INSERT %FINISHELSESTART; ! FINISH ITEM=NUMBER %IF ITEM=DELETE %THENSTART LINE=TL(LINE); ! DISCARD DELETE ITEM=GETNEXT(LINE); ! GET LINE NUMBER %IF JUMPFLAG=1 %THENRETURN %IF ITEM&NM#NM %THENSTART PRSTRING('DELETE NEEDS A NUMBER') NOOLINE(1) %RETURN %FINISH FINDLINE(ITEM) %IF REST=NIL %OR HD(HD(REST))>ITEM %THENSTART; PRSTRING('NO SUCH LINE') NOOLINE(1) %RETURN %FINISHELSESTART DELLIST=CONS(HD(REST),DELLIST) REPTAIL(LESSLINE,TL(REST)) %FINISH %FINISHELSESTART; ! FINISH ITEM=DELETE %IF ITEM=UNDO %THENSTART; %IF DELLIST=NIL %THENSTART PRSTRING('NONE SAVED') NOOLINE(1) %RETURN %FINISH LINE=HD(DELLIST) DELLIST=TL(DELLIST) ->TOP %FINISHELSESTART; ! FINISH UNDO %IF ITEM=UNDOS %THENSTART ITEM=DELLIST %IF ITEM=NIL %THENSTART PRSTRING('NONE SAVED') NOOLINE(1) %RETURN %FINISH %WHILE ITEM#NIL %CYCLE PRINTLINE(HD(ITEM)) ITEM=TL(ITEM) %REPEAT %FINISHELSESTART; ! FINISH UNDOS DPRINTSTRING(ERRMESS(60)) PRINTLCON(LINE) DPRINTSTRING(ERRMESS(60)) DPRINTSTRING(ERRMESS(12)) DNEWLINE %RETURN %FINISH %FINISH %FINISH %FINISH %FINISH %FINISH %END; ! END EDITLINE ! DELLIST=NIL SAVESTK=STKPNT LP1:SAVEPROM=PROMP PROMP=' D: ' DPROMPT(PROMP) LP:LINE=READLINE %IF LINE=NIL %THEN ->LP %IF HD(LINE)=END %THENSTART; PROMP=SAVEPROM DPROMPT(PROMP);%RETURN;%FINISH EDITLINE %IF JUMPFLAG=1 %THENSTART; ! RETURN FROM USERINT OR ERROR STKPNT=SAVESTK; ! RESTORE STACK TO EDIT ENTRY %IF JUMPOUT>0 %THENSTART JUMPOUT=JUMPOUT-1 STACK(VAL) %RETURN %FINISH ! JUMPOUT=0 JUMPFLAG=0; ->LP %FINISH; ! NOTE THAT AN EDIT ENTRY COUNTS TOWARDS AN ABORT N ->LP %END; ! END EDIT ! ! ! ! FILING SYSTEM SUPPORT ROUTINES ! ! %ROUTINE MAPFILE(%INTEGER STADDR) DIRNUM==SHORTINTEGER(STADDR) DIRPAGES==SHORTINTEGER(STADDR+2) WRITINGFILE==SHORTINTEGER(STADDR+4) UNTIDY==SHORTINTEGER(STADDR+6) NFTEXT==INTEGER(STADDR+8) DIR==ARRAY(STADDR+16,DIRFORM) TEXT==ARRAY(STADDR+4096*DIRPAGES-1,TEXTFORM) ! TEXT(0) OVERLAPS DIR. IT IS NOT USED FOR TEXT. SEE LGPRNTSTR %END; ! END MAPFILE ! ! %ROUTINE CONOWNFILE ! CONNECT OWN FILE DEFINE('SM04,'.OWNFILE) OWNFADDR=SMADDR(4,OWNFLENGTH) MAPFILE(OWNFADDR) %END; ! END CONOWNFILE ! ! %ROUTINE DISCONOWNFILE CLOSESM(4) CLEAR('SM04') DISCONNECT(OWNFILE) %END; ! END DISCONOWNFILE ! ! %ROUTINE CONBFILE ! CONNECT BORROWED FILE DEFINE('SM08,'.BFILE) BFADDR=SMADDR(8,BFLENGTH) MAPFILE(BFADDR) %END; ! END CONBFILE ! ! %ROUTINE DISCONBFILE CLOSESM(8) CLEAR('SM08') DISCONNECT(BFILE) %END; ! END DISCONBFILE ! ! %ROUTINE MAPMASTER ! CONNECT MASTER DIRECTORY %INTEGER FL,STADDR DEFINE('SM09,'.MASNUM.'LOGMASTR') STADDR=SMADDR(9,FL) MASENTS==INTEGER(STADDR) USERIDS==ARRAY(STADDR+4,USERFORM) %END; ! END MAPMASTER ! ! %ROUTINE DISCONMASTER CLOSESM(9) CLEAR('SM09') DISCONNECT(MASNUM.'LOGMASTR') %END; ! END DISCONMASTER ! ! %INTEGERFN SHAREFILE ! CONNECTS TO BORROWED FILE AFTER CHECKING THAT IT IS NOT ! BEING WRITTEN TO BY OWNER CONBFILE %IF WRITINGFILE#0 %THENSTART DISCONBFILE ERROR('THE OWNER OF THE MEMORY YOU ARE BORROWING IS REMEMBERING A' %C .' PROCEDURE IN IT. TRY LATER.',EMPTY,1,IN) %RESULT=1 %FINISH %RESULT=0 %END; ! END SHAREFILE ! ! %INTEGERFN SEARCHDIR(%STRING(63) PROC) ! SEARCHES DIR FOR ENTRY WITH NAME PROC ! RETURNS DIR INDEX IF FOUND ELSE 0 %INTEGER I %IF DIRNUM=0 %THENRESULT=0 %CYCLE I=1,1,DIRNUM %IF DIR(I)_PROCNAME=PROC %THENRESULT=I %REPEAT %RESULT=0 %END; ! ENS SEARCHDIR ! ! %ROUTINE WRITEDIR(%STRING(63) PROC,%INTEGER TEXTSTART) ! UPDATES DIR WITH ENTRY FOR PROC NAMED PROC WHOSE TEXT STARTS ! AT TEXTSTART ! %ROUTINE ROLLDOWN ! MOVES TEXT DOWN ONE PAGE OVERALL TO CCLEAR A NEW DIR PAGE %INTEGER I,J,K I=(NFTEXT-1)//4096 %IF (NFTEXT-1-I*4096)#0 %THEN I=I+1; ! TOTAL TEXT BEARING PAGES %CYCLE J=I,-1,1 K=OWNFADDR+(DIRPAGES+J-1)*4096; ! PAGE START ADDRESSES MOVE(4096,K,K+4096) %REPEAT %END; ! END ROLLDOWN ! %INTEGER I I=SEARCHDIR(PROC) %IF I#0 %THENSTART; ! ALREADY THERE DIR(I)_TEXTINDEX=TEXTSTART UNTIDY=1 %RETURN %FINISH %CYCLE I=1,1,PAGES %IF DIRNUMREP TDIRNUM=TDIRNUM+1 TDIR(TDIRNUM)_PROCNAME=WSTR TDIR(TDIRNUM)_TEXTINDEX=TNFTEXT OLDINDEX=DIR(I)_TEXTINDEX CHAR=TEXT(OLDINDEX) %CYCLE TTEXT(TNFTEXT)=CHAR OLDINDEX=OLDINDEX+1 TNFTEXT=TNFTEXT+1 %IF OLDINDEX=NFTEXT %THENEXIT NEXTCHAR=TEXT(OLDINDEX) %IF CHAR=NL %AND (NEXTCHAR='D' %OR NEXTCHAR='T') %THENEXIT CHAR=NEXTCHAR %REPEAT REP:%REPEAT ! SO THATS IT ALL COPIED. NOW MOVE IT BACK TO ORIGINAL FILE MOVE(TDIRPAGES*4096+TNFTEXT-1,TFADDR,OWNFADDR) CLOSESM(10) CLEAR('SM10') DESTROY('LOGOTEMP') TEXT==ARRAY(OWNFADDR+4096*DIRPAGES-1,TEXTFORM) %END; ! END TIDYFILE ! ! ! ! ! ! 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 %IF TDEV=3 %OR TDEV=8 %THEN ERRM=ERRMESS(42).'SCREEN' %ELSEC ERRM=ERRMESS(42).'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 ! %INTEGERFN NSR ! NO SPECIAL RESULT %RESULT=CONS(QQPROC,CONS(FN,NSRTAIL)) %END; ! END NSR ! %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=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRESULT=ERR %IF ARG&NM=0 %THENSTART ERROR(ERRMESS(10).WA(FN>>8).ERRMESS(20),ARG,1,IN) %RESULT=ERR %FINISH %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 BINARG1<-ARG+PENBIT %ELSE BINARG1<-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;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1 CLESET; ! THIS IS THE POINT OF IT. TO BREAK A CLOG IN H316 STACK(CONS(QQPROC,CONS(QUIT,NSRTAIL))) %RETURN %FINISH TSEND1(MOTORS+1500) PULSES=PULSES-1500 %REPEAT TSEND1(MOTORS+PULSES) %END; ! END TSEND ! %ROUTINE PINDSEND(%INTEGER DIRECTION,ANGLE) ! SENDS FOR PLOTTER INDICATOR BINARG1=5 %WHILE ANGLE>360 %CYCLE %IF QUITFLAG=1 %THENSTART; ! AS FOR TSEND QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1 CLESET STACK(CONS(QQPROC,CONS(QUIT,NSRTAIL))) %RETURN %FINISH BINARG2=360+DIRECTION SENDBIN(0,2) ANGLE=ANGLE-360 %REPEAT BINARG2=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) %IF TDEV#0 %THENSTART; ! ALREADY GOR A DEVICE %IF TDEV=N %THEN ERROR('YOU ALREADY HAVE IT',EMPTY,1,IN) %ELSEC ERROR(ERRMESS(41),EMPTY,1,IN) %RETURN %FINISH ! SO NOT GOT A DEVICE %IF STATUS('ECMI50.'.TDEVNAMES(N),1)<0 %THENC ERROR(ERRMESS(8).TDEVNAMES(N).ERRMESS(9),EMPTY,1,IN) %ANDRETURN ! STATUS WITH LEVEL=1 FORCES CONNECTION IF POSSIBLE ! RESULT<0 INDICATES CONNECTION NOT POSSIBLE, IE 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 TO HONEY AS APRROPRIATE DISCONNECT('ECMI50.'.TDEVNAMES(TDEV)) TDEV=0 %END; ! END FREEDEVICE ! %STRING(63)%FN CHECKID(%INTEGER IDLIST) ! ENTERED AT START OF SESSION TO CHECK USER ID, AND IF OK ! RETURNS STRING OF CONCATENATED ID ELEMENTS. ! ALSO USED BY EDITMASTER, BORROW & LIBRARY %INTEGER HEAD,ID %STRING(63) RES,W %IF IDLIST=NIL %THENRESULT='' ID=IDLIST;RES='' %WHILE ID#NIL %CYCLE HEAD=HD(ID);ID=TL(ID) %IF HEAD&WM=0 %THENRESULT=''; ! NOT A WORD W=WA(HEAD>>8) %IF (LENGTH(RES)+LENGTH(W)+1)>63 %THENSTART PRSTRING('IDENTIFIER TOO LONG - ') PRINTEL(IDLIST);NOOLINE(1) %RESULT='' %FINISH RES=RES.W.' ' %REPEAT %RESULT=RES %END; ! END CHECKID ! %ROUTINE BORROW(%INTEGER ARG1,FN) %IF BORROWFLAG=1 %THENSTART ERROR('YOU ARE ALREADY BORROWING FROM '.BORROWEE,EMPTY,1,IN) %RETURN %FINISH %IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL) %IF ARG1&LM#LM %THENSTART ERROR(WA(FN>>8).' MUST HAVE A WORD OR LIST AS SECOND INPUT.' %C .' IT WAS GIVEN ',ARG1,1,IN) %RETURN %FINISH BORROWEE=CHECKID(ARG1) %IF BORROWEE='' %THENSTART ERROR('WRONGLY FORMATTED IDENTIFIER - ',ARG1,1,IN) %RETURN %FINISH MAPMASTER %CYCLE ARG1=1,1,MASENTS %IF BORROWEE=USERIDS(ARG1) %THEN ->BR1 %REPEAT !NOT FOUND DISCONMASTER ERROR(BORROWEE.ERRMESS(17),EMPTY,1,IN) %RETURN !ARG1=MN, SO WE WANT 'LOGOMN' BR1:%IF BORROWEE=USER %THENSTART PRSTRING('YOU NEED NOT BORROW FROM YOURSELF.') NOOLINE(1) %FINISHELSESTART BFILE=MASNUM.'LOGO'.NUMTOSTR(ARG1<<8) BORROWFLAG=1 BORROWEE->WSTR1.(' ') PRSTRING('YOU ARE NOW CONNECTED TO '.WSTR1.'''S PERMANENT MEMORY') NOOLINE(1) %FINISH DISCONMASTER %END; ! END BORROW ! ! ! ! %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,W4 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) %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) %INTEGER VAL %IF FACT=NIL %THENSTART %IF PAT=NIL %THEN %RESULT=TRUE %RESULT=FALSE %FINISH %IF PAT=NIL %THEN %RESULT=FALSE %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) %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) %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) %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); 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) %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) %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) %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) %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) %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) %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 %THEN %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) IT=PUT(STR1.STR2) SETVAL(HD(TL(TERM)),CONS(DOTS,IT),ENVIR) %RESULT=CONS(QUOTE,CONS(IT,INFINSTANCE(TL(TL(TERM))))) %END; ! END INFINSTANCE ! %INTEGERFN INFFITSQ(%INTEGER PAT,RPAT) %INTEGER P1,RP1 INFF1:%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) %INTEGER VBLS,PRED,LIST,SAVLIST,TEMP 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 %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) %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) %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 ! ! -> SYSFUN(SW) ! ! INPUT OUTPUT SYSFUN(1):; ! PRINT %IF TDEV = 8 %THEN SET42(CHTXT) ARG1=UNSTACKINPUT %IF JUMPFLAG=1 %THENRETURN %IF ARG1=ENEL %THEN NOOLINE(1) %ELSE PRINTEL(ARG1) NOOLINE(1) STACK(NSR) %RETURN ! ! SYSFUN(2):SYSFUN(6):; ! TYPE TYPESET %IF TDEV = 8 %THEN SET42(CHTXT) ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1=ENEL %THEN NOOLINE(1) %ELSE PRINTEL(ARG1) %IF SW=6 %THEN PRINTEL(SPACE1) STACK(NSR) %RETURN; ! END TYPE ! ! SYSFUN(3):; ! REPLY %IF TDEV = 8 %THEN SET42(CHTXT) BLEVEL=2 DPROMPT('REPLY: ') FILL LINE BUFFER ARG1=READLIST(BLEVEL) %IF ARG1=ERR %THEN ->SYSFUN(3) STACK(ARG1) DPROMPT(PROMP) %RETURN; ! END REPLY ! ! SYSFUN(4):; ! GETWORD BLEVEL=2 %IF TDEV = 8 %THEN SET42(CHTXT) DPROMPT('WORD: ') FILL LINE BUFFER ARG1=READLIST(BLEVEL) %IF ARG1=ERR %THEN ->SYSFUN(4) %IF ARG1=NIL %THEN STACK(EMPTY) %ELSESTART ARG1=HD(ARG1) %IF ARG1&LM=LM %THENSTART;PRSTRING('NOT A WORD');NOOLINE(1); ->SYSFUN(4) %FINISH STACK(ARG1) %FINISH DPROMPT(PROMP) %RETURN; ! END GETWORD ! ! SYSFUN(5):; ! SAY ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1=ENEL %THEN NOOLINE(1) %ELSESTART ENUF=0;SEP='' %IF ARG1&LM=LM %THEN PRINTLCON(ARG1) %ELSE PRINTWN(ARG1) %FINISH NOOLINE(1) STACK(NSR) %RETURN; ! END SAY ! ! ! ARITHMETIC SYSFUN(10):; ! + OR SUM READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG1<0 %THENSTART %IF ARG2<0 %THEN CHECKSUM(-ARG1,-ARG2) %FINISHELSESTART; ! ARG1>=0 %IF ARG2>0 %THEN CHECKSUM(ARG1,ARG2) %FINISH %IF JUMPFLAG=1 %THENRETURN ARG3=CHECKSIZE(ARG1+ARG2) %IF JUMPFLAG=1 %THENRETURN STACK(ARG3<<8!NM) %RETURN; ! END SUM ! ! ! SYSFUN(11):; ! - OR DIFFERENCE READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG1<0 %THENSTART %IF ARG2>0 %THEN CHECKSUM(-ARG1,ARG2) %FINISHELSESTART; ! ARG1>=0 %IF ARG2<0 %THEN CHECKSUM(ARG1,-ARG2) %FINISH %IF JUMPFLAG=1 %THENRETURN ARG3=CHECKSIZE(ARG1-ARG2) %IF JUMPFLAG=1 %THENRETURN STACK(ARG3<<8!NM) %RETURN; ! END DIFFEREBCE ! ! SYSFUN(12):; ! * OR TIMES READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG1=0 %OR ARG2=0 %THEN STACK(NM) %ANDRETURN %IF ARG1<0 %THENSTART %IF ARG2<0 %THEN CHECKPROD(-ARG1,-ARG2) %ELSE CHECKPROD(-ARG1,ARG2) %FINISHELSESTART; ! ARG1>=0 %IF ARG2<0 %THEN CHECKPROD(ARG1,-ARG2) %ELSE CHECKPROD(ARG1,ARG2) %FINISH %IF JUMPFLAG=1 %THENRETURN ARG3=CHECKSIZE(ARG1*ARG2);%IF JUMPFLAG=1 %THENRETURN STACK(ARG3<<8!NM) %RETURN; ! END TIMES ! ! SYSFUN(13):; ! / OR QUOTIENT READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG2=0 %THENSTART ERROR(ERRMESS(62),EMPTY,1,IN) %RETURN %FINISH STACK((ARG1//ARG2)<<8!NM) %RETURN; ! END QUOTIENT ! ! SYSFUN(14):; ! REMAINDER READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG2=0 %THENSTART ERROR(ERRMESS(62),EMPTY,1,IN) %RETURN %FINISH STACK((ARG1-(ARG1//ARG2)*ARG2)<<8!NM) %RETURN; ! END REMAINDER ! ! SYSFUN(15):; ! DIVISION READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG2=0 %THENSTART ERROR(ERRMESS(62),EMPTY,1,IN) %RETURN %FINISH ARG3=ARG1//ARG2; ! ARG3 USED TEMP STACK(CONS(ARG3<<8!NM,CONS((ARG1-ARG3*ARG2)<<8! NM,NIL))) %RETURN; ! END DIVISION ! ! SYSFUN(16):; ! MAXIMUM READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG1>=ARG2 %THEN STACK(ARG1<<8!NM) %ELSE STACK(ARG2<<8!NM) %RETURN; ! END MAXIMUM ! ! SYSFUN(17):; ! MINIMUM READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG1<=ARG2 %THEN STACK(ARG1<<8!NM) %ELSE STACK(ARG2<<8!NM) %RETURN; ! END MIMIMUM ! ! ! ! CHARACTER AND LIST MANIPULATION ! SYSFUN(20):; ! FIRST ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1<0 %THENSTART ERROR(WA(FN>>8).ERRMESS(45),ARG1,1,IN) %RETURN %FINISH %IF ARG1=EMPTY %THENSTART ERROR(WA(FN>>8).ERRMESS(44),EMPTY,1,IN) %RETURN %FINISH %IF ARG1=NIL %THENSTART ERROR(WA(FN>>8).ERRMESS(46),EMPTY,1,IN) %RETURN %FINISH %IF ARG1&LM=LM %THEN STACK(HD(ARG1)) %ANDRETURN %IF ARG1&NM=NM %THEN WSTR1=NUMTOSTR(ARG1) %ELSE WSTR1=WA(ARG1>>8) STACK(PUT(FROMSTRING(WSTR1,1,1))) %RETURN; ! END FIRST ! ! SYSFUN(21):; ! LAST ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1<0 %THENSTART ERROR(WA(FN>>8).ERRMESS(45),ARG1,1,IN) %RETURN %FINISH %IF ARG1=EMPTY %THENSTART ERROR(WA(FN>>8).ERRMESS(44),EMPTY,1,IN) %RETURN %FINISH %IF ARG1=NIL %THENSTART ERROR(WA(FN>>8).ERRMESS(46),EMPTY,1,IN) %RETURN %FINISH %IF ARG1&LM=LM %THENSTART %WHILE TL(ARG1)#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN %FINISH ARG1=TL(ARG1) %REPEAT STACK(HD(ARG1)) %RETURN; %FINISH %IF ARG1&NM=NM %THEN WSTR1=NUMTOSTR(ARG1) %ELSE WSTR1=WA(ARG1>>8) ARG2=LENGTH(WSTR1) STACK(PUT(FROMSTRING(WSTR1,ARG2,ARG2))) %RETURN; ! END LAST ! ! SYSFUN(22):; ! REST ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1<0 %THENSTART ERROR(WA(FN>>8).ERRMESS(45),ARG1,1,IN) %RETURN %FINISH %IF ARG1=EMPTY %THENSTART ERROR(WA(FN>>8).ERRMESS(44),EMPTY,1,IN) %RETURN %FINISH %IF ARG1=NIL %THENSTART ERROR(WA(FN>>8).ERRMESS(46),EMPTY,1,IN) %RETURN %FINISH %IF ARG1&LM=LM %THEN STACK(TL(ARG1)) %ANDRETURN %IF ARG1&NM=NM %THEN WSTR1=NUMTOSTR(ARG1) %ELSE WSTR1=WA(ARG1>>8) ARG2=LENGTH(WSTR1) %IF ARG2=1 %THEN STACK(EMPTY) %ELSESTART ARG3=PUT(FROMSTRING(WSTR1,2,ARG2)) %IF ARG3=ERR %THENSTART; ! NUMBER TOO LRAGE ERROR(ERRMESS(30).WA(FN>>8).ERRMESS(31).ERRMESS(63),ARG1,1,IN) %RETURN %FINISH STACK(ARG3) %FINISH %RETURN; ! EN REST ! ! SYSFUN(23):; ! BUTLAST ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1<0 %THENSTART ERROR(WA(FN>>8).ERRMESS(45),ARG1,1,IN) %RETURN %FINISH %IF ARG1=EMPTY %THENSTART ERROR(WA(FN>>8).ERRMESS(44),EMPTY,1,IN) %RETURN %FINISH %IF ARG1=NIL %THENSTART ERROR(WA(FN>>8).ERRMESS(46),EMPTY,1,IN) %RETURN %FINISH %IF ARG1&LM=LM %THENSTART ARG2=NIL; ! ARG2 USED TEMP %WHILE TL(ARG1)#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN %FINISH ARG2=CONS(HD(ARG1),ARG2) ARG1=TL(ARG1) %REPEAT ! ARG2 NOW HAS ARG1 LESS LAST ELEMENT REVERSED ARG1=NIL %WHILE ARG2#NIL %CYCLE ARG1=CONS(HD(ARG2),ARG1) ARG2=TL(ARG2) %REPEAT STACK(ARG1) %RETURN; %FINISH %IF ARG1&NM=NM %THEN WSTR1=NUMTOSTR(ARG1) %ELSE WSTR1=WA(ARG1>>8) ARG2=LENGTH(WSTR1) %IF ARG2=1 %THEN STACK(EMPTY) %ELSESTART ARG3=PUT(FROMSTRING(WSTR1,1,ARG2-1)) %IF ARG3=ERR %THENSTART; ! NUMBER TOO LARGE ERROR(ERRMESS(30).WA(FN>>8).ERRMESS(31).ERRMESS(63),ARG1,1,IN) %RETURN %FINISH STACK(ARG3) %FINISH %RETURN; ! END BUTLAST ! ! SYSFUN(24):; ! WORD ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN WORD %RETURN; ! END WORD ! ! SYSFUN(25):; ! LIST ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN STACK(CONS(ARG1,CONS(ARG2,NIL))) %RETURN; ! ND LIST ! ! SYSFUN(26):; ! FIRSTPUT ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG2&LM=LM %THENSTART; ! ARG2 A LIST STACK(CONS(ARG1,ARG2)) %RETURN %FINISH WORD %RETURN; ! END FIRSTPUT ! ! SYSFUN(27):; ! LASTPUT ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN LASTPUT %RETURN; ! END LASTPUT ! ! SYSFUN(28):; ! JOIN ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&LM#LM %THENSTART ERROR(ERRMESS(10).WA(FN>>8).ERRMESS(19),ARG1,1,IN) %RETURN %FINISH %IF ARG2&LM#LM %THENSTART ERROR(ERRMESS(10).WA(FN>>8).ERRMESS(19),ARG2,1,IN) %RETURN %FINISH ARG3=NIL; ! ARG3 USED TEMP %WHILE ARG1#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN %FINISH ARG3=CONS(HD(ARG1),ARG3) ARG1=TL(ARG1) %REPEAT ! ARG3 NOW ARG1 REVERSED %WHILE ARG3#NIL %CYCLE ARG2=CONS(HD(ARG3),ARG2) ARG3=TL(ARG3) %REPEAT STACK(ARG2); ! LISTS APPENDED %RETURN; ! END JOIN ! ! SYSFUN(29):; ! COUNT ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1<0 %THENSTART ERROR(WA(FN>>8).ERRMESS(45),ARG1,1,IN) %RETURN %FINISH %IF ARG1&LM=LM %THENSTART ARG2=0 %WHILE ARG1#NIL %CYCLE %IF QUITFLAG=1 %THENSTART QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1 STACK(QUIT) %RETURN %FINISH %IF HOLDFLAG=1 %THENSTART ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN %FINISH ARG2=ARG2+1 ARG1=TL(ARG1) %REPEAT STACK(ARG2<<8!NM) %RETURN %FINISH %IF ARG1&NM=NM %THEN WSTR1=NUMTOSTR(ARG1) %ELSE WSTR1=WA(ARG1>>8) STACK(LENGTH(WSTR1)<<8!NM) %RETURN; ! END COUNT ! ! ! PREDICATES AND CONDITIONALS ! ! ! ! SYSFUN(30):; ! LESS THAN READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG1ARG2 %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; ! END GREATER THAN ! ! SYSFUN(33):; ! GREATER THAN OR EQUAL TO READYNUM %IF JUMPFLAG=1 %THENRETURN %IF ARG1>=ARG2 %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; ! END GREATER THAN OR EQUAL TO ! ! SYSFUN(34):; ! EQUAL TO ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG3=EQUAL(ARG1,ARG2) STACK(ARG3) %RETURN; ! END EQUAL TO ! ! SYSFUN(35):; !ZEROQ ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&NM=NM %AND ARG1>>8=0 %C %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; ! END ZEROQ ! ! SYSFUN(36):; ! NUMBERQ ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&NM=NM %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; ! END NUMBERQ ! ! SYSFUN(37):; ! WORDQ ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&WM=WM %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; ! END WORDQ ! ! SYSFUN(38):; !LISTQ ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&LM=LM %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; ! END LISTQ ! ! SYSFUN(39):; !EMPTYQ ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1=NIL %OR ARG1=EMPTY %C %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; !END EMPTYQ ! ! SYSFUN(40):; ! BOTH ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1=TRUE %AND ARG2=TRUE %C %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; ! END BOTH ! ! SYSFUN(41):; ! EITHER ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1=TRUE %OR ARG2=TRUE %C %THEN STACK(TRUE) %ELSE STACK(FALSE) %RETURN; ! END EITHER ! ! SYSFUN(42):; !NOT ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1=TRUE %THEN STACK(FALSE) %ELSE STACK(TRUE) %RETURN; ! END NOT ! ! ! SYSFUN(50):; ! TEST ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1=TRUE %THEN TSTFLG=1 %ELSESTART %IF ARG1=FALSE %THEN TSTFLG=0 %ELSESTART ERROR('BAD ARG FOR TEST - ',ARG1,1,IN) %RETURN %FINISH %FINISH STACK(NSR) %RETURN; ! END TEST ! ! SYSFUN(51):; ! IFTRUE %IF TSTFLG=1 %THENSTART EVAL(0,IN,EACHVAL,WALKFN) %IF JUMPFLAG=1 %THENRETURN %FINISHELSESTART IN=NIL STACK(NSR) %FINISH %RETURN; ! END IFTRUE ! ! SYSFUN(52):; ! IFFALSE %IF TSTFLG=0 %THENSTART EVAL(0,IN,EACHVAL,WALKFN) %IF JUMPFLAG=1 %THENRETURN %FINISHELSESTART IN=NIL STACK(NSR) %FINISH %RETURN; ! END IFFALSE ! ! SYSFUN(53):; ! IF IN=CONS(FN,IN); ! PUT BACK IF ARG1=NIL;ARG2=NIL;ARG3=NIL W1=EXTRACT(ARG1,ARG2,ARG3) %IF W1#EMPTY %THENSTART ERROR('MISSING ',W1,1,IN) %RETURN %FINISH ! ARG1 HAS IF COND REVERSED ! ARG2 HAS THEN THENCLAUSE REVERSED ! ARG3 HAS ELSE ELSECLAUSE REVERSED OR NIL ARG1=TL(REVERSE(ARG1)); ! REVERSE AND REMOVE LEADING IF ARG2=TL(REVERSE(ARG2)); ! REMOVE LEADING THEN %IF ARG3#NIL %THEN ARG3=TL(REVERSE(ARG3)) ! ARG1 NOW HAS COND,ARG2 THENCLAUSE AND ARG3 ELSECLAUSE ! ALL OR ANY MAY BE NIL %IF ARG1=NIL %THENSTART ERROR('NULL CONDITION',EMPTY,1,IN) %RETURN %FINISH STKSYS(ARG2);STKSYS(ARG3);STKSYS(IN) EVAL(0,ARG1,EACHVAL,WALKFN); ! EVAL CONDITION IN=UNSTKSYS;ARG3=UNSTKSYS;ARG2=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN W1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN; ! RESULT OF CONDITION %IF W1=TRUE %THENSTART; ! COND TRUE %IF ARG2=NIL %THENSTART ERROR('NULL THEN CLAUSE',EMPTY,1,IN) %RETURN %FINISHELSESTART STKSYS(ARG1);STKSYS(ARG3);STKSYS(IN) EVAL(0,ARG2,EACHVAL,WALKFN); ! EVAL THEN CLAUSE DUMLAB: IN=UNSTKSYS;ARG3=UNSTKSYS;ARG1=UNSTKSYS ! DUMLAB INSERTED TO AVOID COMPILER ERRROR RESULTING IN ! ADDRESS ERROR ON RETURN TO HERE. %IF JUMPFLAG=1 %THENRETURN W2=UNSTACK %FINISH %FINISHELSESTART; ! W1#TRUE %IF W1=FALSE %THENSTART %IF ARG3=NIL %THEN W2=NSR %ELSESTART STKSYS(ARG1);STKSYS(ARG2);STKSYS(IN) EVAL(0,ARG3,EACHVAL,WALKFN) IN=UNSTKSYS;ARG2=UNSTKSYS;ARG1=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN W2=UNSTACK %FINISH %FINISHELSESTART; ! W1#TRUE AND #FALSE ERROR('BAD CONDITION - ',W1,1,IN) %RETURN %FINISH %FINISH STACK(W2) %RETURN; ! END IF ! ! SYSFUN(54):; ! WHILE IN=CONS(FN,IN) ARG1=NIL;ARG2=NIL;ARG3=NIL W1=EXTRACT(ARG1,ARG2,ARG3) %IF W1#EMPTY %THENSTART ERROR('MISSING ',W1,1,IN) %RETURN %FINISH ! ARG1 HAS 'WHILE COND' REVERSED ! ARG2 HAS 'THEN THENCLAUSE' REVERSED ARG1=TL(REVERSE(ARG1)) ARG2=TL(REVERSE(ARG2)) ! ARG1 NOW HAS COND, ARG2 HAS THENCLAUSE ! ONE OR BOTH MAY BE NIL %IF ARG1=NIL %THENSTART ERROR('NULL CONDITION',EMPTY,1,IN) %RETURN %FINISH %IF ARG2=NIL %THENSTART ERROR('NULL THEN CLAUSE',EMPTY,1,IN) %RETURN %FINISH ARG3=NSR; ! RESULT IF COND FALSE FIRST TIME ROUTND %CYCLE W1=ARG1 STKSYS(ARG1);STKSYS(ARG2);STKSYS(IN) EVAL(0,W1,EACHVAL,WALKFN) IN=UNSTKSYS;ARG2=UNSTKSYS;ARG1=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN W2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF W2=TRUE %THENSTART W1=ARG2 STKSYS(ARG1);STKSYS(ARG2);STKSYS(IN) EVAL(0,W1,EACHVAL,WALKFN) IN=UNSTKSYS;ARG2=UNSTKSYS;ARG1=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN ARG3=UNSTACK; ! RESULT %FINISHELSESTART %IF W2=FALSE %THENEXIT %ELSESTART ERROR('BAD CONDITION - ',W2,1,IN) %RETURN %FINISH %FINISH %REPEAT STACK(ARG3) %RETURN; ! END WHILE ! ! SYSFUN(60):; ! DEFINE REDEF=0 %IF WALKFN#UNDEF %THENSTART ERROR('YOU CANNOT DEFINE A PROCEDURE WHILE IN STEPPING MODE',%C EMPTY,1,IN) %RETURN %FINISH %IF IN=NIL %THENSTART ERROR(ERRMESS(38),FN,1,IN) %RETURN %FINISH W1=REVQUOTE(IN); ! CHECKS FORMAT AS "WORD "WORD ETC %IF JUMPFLAG=1 %THENRETURN ARG1=HD(TL(IN)); ! PROC NAME ARG2=FNVAL(ARG1>>8); ! FUN SPEC IF ANY %IF ARG2=0 %THEN ->MAKESPEC %IF ARG2&USERPRE=USERPRE %THENSTART; ! GOT EXISTING USER DEF %IF DEVICE=TTY %THENSTART; ! THIS ONE NOT FROM FILE ERROR(ERRMESS(6),ARG1,1,IN) %RETURN %FINISHELSE REDEF=1 %FINISHELSESTART; ! NOT USERPRE. SO SYSTEM ERROR(ERRMESS(43),EMPTY,1,IN) %RETURN %FINISH MAKESPEC:W1=LISTLEN(W1)-1; ! NO OF PARAMS %IF W1>127 %THENSTART ERROR('TOO MANY INPUTS FOR ',ARG1,1,IN) %RETURN %FINISH ! SO ALL OK %IF REDEF=1 %THEN OLDFN(ARG1>>8)=ARG2 %ELSE DEFINED=CONS(ARG1,DEFINED) ARG3=CONS1(CONS1(FN,MOVE1(IN)),NIL); ! REBUILD LINE IN FNSPACE FNVAL(ARG1>>8)=USERPRE+ARG3&M16+W1; ! SPEC FROMLIST(NEWFN,ARG1) %UNLESS NEWFN=NIL EDIT(ARG3); ! FOR REST OF DEFN %IF JUMPFLAG=1 %THENRETURN %IF DEVICE=TTY %THEN NEWFN=CONS(ARG1,NEWFN) DEVICE=TTY %IF REDEF=1 %THENSTART DPRINTSTRING(ERRMESS(58).WA(ARG1>>8).ERRMESS(59)) %FINISHELSESTART PRINTEL(ARG1) PRSTRING(' DEFINED') %FINISH IN=NIL NOOLINE(1) STACK(NSR) %RETURN ! ! SYSFUN(61):; ! CHANGE ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF WALKFN#UNDEF %THENSTART ERROR('YOU CANNOT CHANGE A PROCEDURE WHILE IN STEPPING MODE', %C EMPTY,1,IN) %RETURN %FINISH %IF ARG1&WM#WM %THENSTART ERROR(WA(FN>>8).ERRMESS(26),ARG1,1,IN) %RETURN %FINISH ARG2=FNVAL(ARG1>>8); ! GET SPEC %IF ARG2=0 %THENSTART ERROR(ERRMESS(21).WA(ARG1>>8).ERRMESS(23),FN,1,IN) %RETURN %FINISH %IF ARG2&USERPRE#USERPRE %THENSTART ERROR(WA(FN>>8).ERRMESS(25),ARG1,1,IN) %RETURN %FINISH ARG2=ARG2&M16!LM; ! POINTER TO LIST DEF EDIT(ARG2) %IF JUMPFLAG=1 %THENRETURN FROMLIST(NEWFN,ARG1) %UNLESS NEWFN=NIL NEWFN=CONS(ARG1,NEWFN) NOOLINE(1) PRINTEL(ARG1) PRSTRING(' CHANGED') NOOLINE(1) STACK(NSR) %RETURN; ! END EDIT ! ! SYSFUN(62):; ! MAKE ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&WM#WM %THENSTART ERROR(ERRMESS(53),ARG1,1,IN) %RETURN %FINISH %IF ARG1=EMPTY %THENSTART ERROR('YOU CANNOT USE THE EMPTY WORD AS A NAME',EMPTY,1,IN) %RETURN %FINISH SETVAL(ARG1,ARG2,ENVIR) STACK(NSR) %RETURN; ! END MAKE ! ! SYSFUN(63):; ! NEW ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1=EMPTY %THENSTART ERROR('YOU CANNOT USE THE EMPTY WORD AS A NAME',EMPTY,1,IN) %RETURN %FINISH %IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL) %ELSE CHKLIST(ARG1) %IF JUMPFLAG=1 %THENRETURN ARG2=LISTLEN(ARG1) %IF ARG2=0 %THEN STACK(NSR) %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(NSR) %RETURN; ! END NEW ! ! SYSFUN(64):; ! GO ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&NM#NM %THENSTART ERROR('GO NEEDS A NUMBER AS INPUT. IT WAS GIVEN ',ARG1,1,IN) %RETURN %FINISH ARG2=FUN; ! USER FUN CURRENT %WHILE TL(ARG2)#NIL %CYCLE %IF HD(HD(TL(ARG2)))=ARG1 %THENSTART CURFUN=ARG2; ! ONE LINE BEFORE REQUESTED LINE STACK(NSR) %RETURN %FINISH ARG2=TL(ARG2) %REPEAT ERROR('THERE IS NO LINE NUMBERED ',ARG1,1,IN) %RETURN; ! END GO ! ! ! SYSFUN(65):; ! STOP %IF FUN=NIL %THENSTART ERROR('STOP CAN ONLY BE USED INSIDE A PROCEDURE',EMPTY,1,IN) %RETURN %FINISH CURFUN=CONS(NIL,NIL); ! APPLYUSR STOPS WHEN A SINGLE LINE LEFT STACK(NSR) %RETURN; ! END STOP ! ! SYSFUN(66):; ! RESULT (OUTPUT) %IF FUN=NIL %THENSTART ERROR('RESULT CAN ONLY BE USED INSIDE A PROCEDURE',EMPTY,1,IN) %RETURN %FINISH CURFUN=CONS(NIL,NIL) STACK(CONS(QQRESULT,CONS(UNSTACK,NIL))); ! [??RESULT VALUE] %RETURN; ! END RESULT ! ! SYSFUN(67):; ! RENUMBER ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&WM#WM %THENSTART ERROR(WA(FN>>8).ERRMESS(26),ARG1,1,IN) %RETURN %FINISH ARG2=FNVAL(ARG1>>8); ! GET SPEC %IF ARG2=0 %THENSTART ERROR(ERRMESS(21).WA(ARG1>>8).ERRMESS(23),FN,1,IN) %RETURN %FINISH %IF ARG2&USERPRE#USERPRE %THENSTART ERROR(WA(FN>>8).ERRMESS(25),ARG1,1,IN) %RETURN %FINISH ARG2=ARG2&M16!LM; ! LIST DEF POINTER ARG3=10 ARG2=TL(ARG2); ! DEF STARTING AT FIRST NUMBERED LINE %WHILE ARG2#NIL %CYCLE REPHEAD(HD(ARG2),ARG3<<8!NM) ARG3=ARG3+10 ARG2=TL(ARG2) %REPEAT NOOLINE(1) PRINTEL(ARG1) PRSTRING(' RENUMBERED') NOOLINE(1) STACK(NSR) %RETURN; ! END RENUMBER ! ! SYSFUN(68):; ! DELETE RETITILE END UNDO UNDOS AT COMMAND LEVEL ERROR(WA(FN>>8).ERRMESS(34),EMPTY,1,IN) %RETURN; ! END ! ! ! ! ! SYSFUN(70):; ! SHOW ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1=NIL %THEN ->SH2 %IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL) %IF ARG1&LM#LM %THENSTART ERROR(WA(FN>>8).ERRMESS(24),ARG1,1,IN) %RETURN %FINISH %WHILE ARG1#NIL %CYCLE ARG2=HD(ARG1) ARG1=TL(ARG1) NOOLINE(1) %IF ARG2&WM#WM %THENSTART ERROR1(WA(FN>>8).ERRMESS(24),CONS(ARG2,ARG1)) ->SH1 %FINISH ARG3=FNVAL(ARG2>>8); ! GET SPEC %IF ARG3=0 %THENSTART ERROR1(ERRMESS(21).WA(ARG2>>8).ERRMESS(23),FN) ->SH1 %FINISH %IF ARG3&USERPRE#USERPRE %THENSTART ERROR1(WA(FN>>8).ERRMESS(25),ARG2) ->SH1 %FINISH ARG3=ARG3&M16!LM; ! DEFINITION %WHILE ARG3#NIL %CYCLE PRINTLINE(HD(ARG3)) ARG3=TL(ARG3) %REPEAT PRINTEL(END) NOOLINE(1) SH1:%REPEAT SH2:STACK(NSR) %RETURN; ! END SHOW ! ! ! SYSFUN(72):; ! DEFINED STACK(DEFINED) %RETURN; ! END DEFINED ! ! SYSFUN(73):; ! TEMPORARY STACK(NEWFN) %RETURN; ! END TEMPORARY ! ! SYSFUN(74):; ! OLDDEF ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&WM#WM %THENSTART ERROR(ERRMESS(26),ARG1,1,IN) %RETURN;%FINISH %IF OLDFN(ARG1>>8)=0 %THENSTART ERROR(ERRMESS(28),ARG1,1,IN) %RETURN;%FINISH ARG2=FNVAL(ARG1>>8) FNVAL(ARG1>>8)=OLDFN(ARG1>>8) OLDFN(ARG1>>8)=ARG2 PRSTRING( 'ORIGINAL DEFINITION OF ');PRSTRING(WA(ARG1>>8).' RESTORED') NOOLINE(1);STACK(NSR) %RETURN; ! END OLDDEF ! ! SYSFUN(75):; ! UNDEFINE ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL) %IF ARG1&LM#LM %THENSTART ERROR(WA(FN>>8).ERRMESS(24),ARG1,1,IN) %RETURN %FINISH %WHILE ARG1#NIL %CYCLE ARG2=HD(ARG1);ARG1=TL(ARG1) %IF ARG2&WM#WM %THENSTART ERROR(WA(FN>>8).ERRMESS(24),ARG2,1,IN) %RETURN %FINISH ARG3=FNVAL(ARG2>>8) %IF ARG3=0 %THENSTART ERROR(ERRMESS(21).WA(ARG2>>8).ERRMESS(23),FN,1,IN) %RETURN %FINISH %IF ARG3&USERPRE#USERPRE %THENSTART ERROR(WA(FN>>8).ERRMESS(25),ARG2,1,IN) %RETURN %FINISH ! SO OK FNVAL(ARG2>>8)=0 OLDFN(ARG2>>8)=0 FROMLIST(NEWFN,ARG2) %UNLESS NEWFN=NIL FROMLIST(DEFINED,ARG2) PRSTRING(WA(ARG2>>8).' UNDEFINED');NOOLINE(1) %REPEAT STACK(NSR) %RETURN; ! END UNDEFINE ! ! SYSFUN(76):; ! RECALL ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1=NIL %THEN ->LD5 %IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL) %IF ARG1&LM#LM %THENSTART ERROR(WA(FN>>8).ERRMESS(24),ARG1,1,IN) %RETURN %FINISH %IF BORROWFLAG=1 %THENSTART %IF SHAREFILE#0 %THENRETURN; ! FILE BEING WRITTEN TO BORROWLOAD=1 %FINISH %IF DIRNUM=0 %THENSTART PRSTRING('THERE ARE NO PROCEDURES IN THIS PERMANENT MEMORY') NOOLINE(1) ->LD4 %FINISH %WHILE ARG1#NIL %CYCLE ARG2=HD(ARG1) ARG1=TL(ARG1) %IF ARG2&WM#WM %THENSTART ERROR1(WA(FN>>8).ERRMESS(24),CONS(ARG2,ARG1)) ->LD3;%FINISH WSTR1=WA(ARG2>>8) ARG3=SEARCHDIR(WSTR1) %IF ARG3=0 %THENSTART; ! NOT FOUND PRSTRING(ERRMESS(22).WSTR1) NOOLINE(1) ->LD3 %FINISH CURTEXT=DIR(ARG3)_TEXTINDEX; ! START INDEX FOR THIS PROC DEVICE=DISC ARG3=READLINE STKSYS(ARG1); STKSYS(IN) EVAL(0,ARG3,EACHVAL,WALKFN) IN=UNSTKSYS; ARG1=UNSTKSYS %IF JUMPFLAG=1 %THENEXIT; ! USER INT ONLY ARG3=UNSTACK LD3:%REPEAT DEVICE=TTY LD4:%IF BORROWFLAG=1 %THEN DISCONBFILE %AND BORROWLOAD=0 LD5:STACK(NSR) %RETURN; ! END RECALL ! ! SYSFUN(77):; ! REMEMBER ARG3=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG3=NIL %THEN ->SAVE2 %IF BORROWFLAG=1 %THENSTART ERROR(ERRMESS(15),EMPTY,1,IN) %RETURN %FINISH %IF ARG3&WM=WM %THEN ARG3=CONS(ARG3,NIL) %IF ARG3&LM#LM %THENSTART ERROR(WA(FN>>8).ERRMESS(24),ARG3,1,IN) %RETURN %FINISH %IF STATUS(OWNFILE,0)>1 %THENSTART; ! BORROWED OR TWO USERS SAME NAME DPRINTSTRING(ERRMESS(54).WA(FN>>8).ERRMESS(55)) DPRINTSTRING(WA(FN>>8).ERRMESS(56).ERRMESS(61)) DNEWLINE JUMPFLAG=1 IN=NIL ->SAVE2 %FINISH WRITINGFILE=1; ! TO TELL WOULD BE BPRROWERS DEVICE=DISC %WHILE ARG3#NIL %CYCLE ARG1=HD(ARG3) ARG3=TL(ARG3) %IF ARG1&WM#WM %THEN%START ERROR1(WA(FN>>8).ERRMESS(24),CONS(ARG1,ARG3)) ->SAVEREP;%FINISH ARG2=FNVAL(ARG1>>8) %IF ARG2=0 %THEN%START ERROR1(ERRMESS(21).WA(ARG1>>8).ERRMESS(23),FN) ->SAVEREP;%FINISH %IF ARG2&USERPRE#USERPRE %THEN%START ERROR1(WA(FN>>8).ERRMESS(25),ARG1) ->SAVEREP;%FINISH W1=ARG2&M16!LM; ! DEF AS LIST SAVE3:ARG2=W1 W2=NFTEXT %WHILE ARG2#NIL %CYCLE PRINTLINE(HD(ARG2)); ARG2=TL(ARG2) %REPEAT PRINTEL(END) LGPRNT STR(STERMIN) %IF FULLFLAG=0 %THENSTART; ! TEXT ALL IN OK WSTR1=WA(ARG1>>8) WRITEDIR(WSTR1,W2); ! UPDATE DIR %IF FULLFLAG=0 %THEN ->SAVE4; ! SO DIR UPDATED OK %FINISH ! SO FULLFLAG=1 EITHER BECAUSE TEXT NOT ALL IN, OR NO ROOM FOR ! NEW DIR ENTRY. IN EITHER CASE, ONLY NFTEXT HAS BEEN ALTERED. ! W2 CONTAINS ORIGINAL VALUE. FULLFLAG=0 %IF UNTIDY=1 %THENSTART; ! TRY A TIDY TIDYFILE ->SAVE3; ! AND TRY WHOLE THING OVER AGAIN %FINISH; ! PICKING UP NEW VALUE OF NFTEXT ! FILE NOT UNTIDY, SO ABORT NFTEXT=W2; ! RESET TO BEFORE ATTEMPT PRSTRING('NOT ENOUGH SPACE LEFT IN YOUR PERMANENT MEMORY') NOOLINE(1) %EXIT; ! FROM PROC CYCLE ! SAVE4:; ! NORMAL WHEN SPACE IN FILE OK FROMLIST(NEWFN,ARG1) %UNLESS NEWFN=NIL PRSTRING(WSTR1.' REMEMBERED'); NOOLINE(1) SAVEREP:%REPEAT DEVICE=TTY WRITINGFILE=0 SAVE2:STACK(NSR) %RETURN; ! END SAVE ! ! ! SYSFUN(79):; ! FORGET ARG1 ARG2 ETC ARG3=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG3=NIL %THEN ->FG5 %IF BORROWFLAG=1 %THENSTART ERROR(ERRMESS(27),EMPTY,1,IN) %RETURN %FINISH %IF ARG3&WM=WM %THEN ARG3=CONS(ARG3,NIL) %IF ARG3&LM#LM %THENSTART ERROR(WA(FN>>8).ERRMESS(24),ARG3,1,IN) %RETURN %FINISH %IF DIRNUM=0 %THENSTART PRSTRING('THERE ARE NO PROCEDURES IN THIS PERMANENT MEMORY') NOOLINE(1) ->FG5 %FINISH %IF STATUS(OWNFILE,0)>1 %THENSTART; ! BORROWED OR TWO USERS SAME NAME DPRINTSTRING(ERRMESS(54).WA(FN>>8).ERRMESS(55)) DPRINTSTRING(WA(FN>>8).ERRMESS(56).ERRMESS(61)) DNEWLINE JUMPFLAG=1 IN=NIL ->FG5 %FINISH WRITINGFILE=1 %WHILE ARG3#NIL %CYCLE ARG1=HD(ARG3) ARG3=TL(ARG3) %IF ARG1&WM#WM %THENSTART ERROR1(WA(FN>>8).ERRMESS(24),CONS(ARG1,ARG3)) ->FG3;%FINISH WSTR1=WA(ARG1>>8) ARG2=SEARCHDIR(WSTR1) %IF ARG2=0 %THENSTART PRSTRING(ERRMESS(22).WSTR1) NOOLINE(1) ->FG3 %FINISH DIR(ARG2)_PROCNAME='' UNTIDY=1 %IF FNVAL(ARG1>>8)#0 %THENSTART; ! DEFINED FROMLIST(NEWFN,ARG1) %UNLESS NEWFN=NIL NEWFN=CONS(ARG1,NEWFN) %FINISH PRSTRING(WSTR1.' FORGOTTEN') NOOLINE(1) FG3:%REPEAT WRITINGFILE=0 FG5:STACK(NSR) %RETURN; ! END FORGET ! ! SYSFUN(80):; ! REMEMBERED %IF BORROWFLAG=1 %AND SHAREFILE#0 %THENRETURN ARG1=NIL %IF DIRNUM#0 %THENSTART %CYCLE ARG2=1,1,DIRNUM WSTR1=DIR(ARG2)_PROCNAME %IF WSTR1#'' %THEN ARG1=CONS(HASH(WSTR1),ARG1) %REPEAT %FINISH %IF BORROWFLAG=1 %THEN DISCONBFILE STACK(ARG1) %RETURN; ! END REMEMBERED ! ! SYSFUN(81):; ! LISTERRORS NOOLINE(2) PRSTRING('ERROR FILE CONTENTS') NOOLINE(1) %CYCLE ARG1=1,1,100 WSTR1=ERRMESS(ARG1) %IF WSTR1#'?' %THENSTART WRITE(ARG1,4);SPACE DPRINTSTRING(WSTR1) DNEWLINE %FINISH %REPEAT STACK(NSR) %RETURN; ! END LISTERRORS ! ! SYSFUN(82):; ! EDITERRORS %IF EMASUSER.'.'=MASNUM %AND USER=MASNAME %THENSTART %IF STATUS('ELOGOO',0)>1 %THENSTART ERROR(ERRMESS(29),EMPTY,1,IN) %RETURN %FINISH CLOSESM(5);DISCONNECT('LOGERRS') PERMITFILE('LOGERRS,ECMI50,ALL') ERRMESS==ARRAY(SMADDR(5,FLENGTH),SFORM2) ERRL0:DPROMPT('ERR NUM:') READ(ARG1) %IF ARG1=0 %THEN ->ERRL1 DPROMPT('ERR MESS:') ERRL2:READSTRING(WSTR1) %IF LENGTH(WSTR1)>255 %THENSTART PRSTRING('MESSAGE TOO LONG');NOOLINE(1) ->ERRL2 %FINISHELSE ERRMESS(ARG1)=WSTR1 ->ERRL0 ERRL1:DPROMPT(PROMP) CLOSESM(5);DISCONNECT('LOGERRS') PERMITFILE('LOGERRS,ECMI50,RS') ERRMESS==ARRAY(SMADDR(5,FLENGTH),SFORM2) STACK(NSR) %RETURN %FINISH; ! FINISH ALLOWED USER ! PRSTRING('YOU MAY NOT');NOOLINE(1); STACK(NSR) %RETURN; ! END EDITERRORS ! ! SYSFUN(83):; ! LISTMASTER MAPMASTER %CYCLE ARG1=1,1,MASENTS WRITE(ARG1,5);SPACES(2);PRSTRING(USERIDS(ARG1)) NOOLINE(1) %REPEAT DISCONMASTER STACK(NSR) %RETURN; ! END LISTMASTER ! ! SYSFUN(84):; ! EDITMASTER %IF EMASUSER.'.'=MASNUM %AND USER=MASNAME %THENSTART %IF STATUS('ELOGOO',0)>1 %THENSTART ERROR(ERRMESS(29),EMPTY,1,IN) %RETURN %FINISH PERMITFILE('LOGMASTR,ECMI50,ALL') MAPMASTER WSTR1=PROMP PROMP='E:' DPROMPT(PROMP) EMLOOP:ARG1=READLINE %IF ARG1=NIL %OR ARG1&LM#LM %THENSTART PRSTRING('INCORRECT FORMAT - ') PRINTEL(ARG1);NOOLINE(1) ->EMLOOP %FINISH ARG2=HD(ARG1);ARG1=TL(ARG1) %IF ARG2=INSERT %THENSTART WSTR2=CHECKID(ARG1) %IF WSTR2='' %THENSTART PRSTRING('WRONGLY FORMATTED IDENTIFIER - ') PRINTEL(ARG1);NOOLINE(1) ->WHOLP %FINISH %CYCLE ARG3=1,1,MASENTS %IF WSTR2=USERIDS(ARG3) %THENSTART PRSTRING(WSTR2.'ALREADY IN DIRECTORY');NOOLINE(1) ->EMLOOP %FINISH %REPEAT ! SO NOT ALREADY THERE %CYCLE ARG3=1,1,MASENTS %IF USERIDS(ARG3)='DESTROYED' %THEN ->EML2; ! FREE SLOT %REPEAT ! SO NO FREE SLOT. PUT IT ON THE END %IF MASENTS=99 %THENSTART PRSTRING('MASTER DIRECTORY FULL');NOOLINE(1) ->EMLOOP %FINISH MASENTS=MASENTS+1 ARG3=MASENTS EML2:USERIDS(ARG3)=WSTR2 WSTR3='LOGO'.NUMTOSTR(ARG3<<8) NEWSMFILE(WSTR3.',40960') DEFINE('SM12,'.WSTR3) ARG3=SMADDR(12,W1) SHORTINTEGER(ARG3)=0; ! DIRNUM SHORTINTEGER(ARG3+2)=1; ! DIRPAGES SHORTINTEGER(ARG3+4)=0; ! WRITINGFILE SHORTINTEGER(ARG3+6)=0; ! UNTIDY INTEGER(ARG3+8)=1; ! NFTEXT CLOSESM(12) CLEAR('SM12') DISCONNECT(WSTR3) PERMITFILE(WSTR3.','.EMASUSER.',WS') PERMITFILE(WSTR3.',,WS') CHERISH(WSTR3) PRSTRING('FILE '.WSTR3.' CREATED FOR '.WSTR2);NOOLINE(1) ->EMLOOP %FINISH %IF ARG2=DELETE %THENSTART %IF HD(ARG1)&NM=NM %THENSTART ARG3=HD(ARG1)>>8 %IF ARG3>MASENTS %THENSTART PRSTRING('INDEX TOO LARGE');NOOLINE(1) ->EMLOOP %FINISH WSTR2=USERIDS(ARG3) ->EML1 %FINISH WSTR2=CHECKID(ARG1) %IF WSTR2='' %THENSTART PRSTRING('WRONGLY FORMATTED IDENTIFIER - ') PRINTEL(ARG1);NOOLINE(1) ->EMLOOP %FINISH %CYCLE ARG3=1,1,MASENTS %IF WSTR2=USERIDS(ARG3) %THEN ->EML1 %REPEAT ! NOT FOUND PRSTRING(WSTR2.'NOT IN DIRECTORY');NOOLINE(1) ->EMLOOP EML1:; ! GET HERE WITH NAME IN WSTR2 AND INDEX IN ARG3 USERIDS(ARG3)='DESTROYED' WSTR3='LOGO'.NUMTOSTR(ARG3<<8) DESTROY(WSTR3) PRSTRING('USER '.WSTR2.'DELETED. FILE '.WSTR3.' DESTROYED') NOOLINE(1) ->EMLOOP %FINISH %IF ARG2=END %THENSTART DISCONMASTER PERMITFILE('LOGMASTR,ECMI50,RS') PROMP=WSTR1 DPROMPT(PROMP) STACK(NSR) %RETURN %FINISH ! PRSTRING('BAD EDIT COMMAND');NOOLINE(1) ->EMLOOP %FINISH; ! FINISH ALLOWED USER ! PRSTRING('YOU MAY NOT');NOOLINE(1) STACK(NSR) %RETURN; ! END EDITMASTER ! ! SYSFUN(85):; ! BORROW ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN BORROW(ARG1,FN) STACK(NSR) %UNLESS JUMPFLAG=1 %RETURN; ! END BORROW ! ! SYSFUN(86):; ! LIBRARY ARG1=UNSTACKINPUT;%IF JUMPFLAG=1 %THENRETURN ARG2=UNSTACKINPUT;%IF JUMPFLAG=1 %THENRETURN %IF ARG1&WM#WM %THENSTART ERROR('LIBRARY MUST HAVE A PROCEDURE NAME AS ITS SECOND INPUT.' %C .' IT WAS GIVEN ',ARG1,1,IN) %RETURN %FINISH BORROW(ARG2,FN) %IF JUMPFLAG=1 %THENRETURN %IF BORROWFLAG=1 %THENSTART %IF SHAREFILE#0 %THEN ->BERR2 %FINISH %IF DIRNUM=0 %THENSTART ERROR('THERE ARE NO PROCEDURES IN THIS PERMANENT MEMORY',EMPTY,1,IN) ->BERR1 %FINISH WSTR1=WA(ARG1>>8) ARG3=SEARCHDIR(WSTR1) %IF ARG3=0 %THENSTART ERROR('THERE IS NO PROCEDURE IN THIS PERMANENT MEMORY NAMED ',%C ARG1,1,IN) ->BERR1 %FINISH BORROWLOAD=1 CURTEXT=DIR(ARG3)_TEXTINDEX DEVICE=DISC ARG3=READLINE STKSYS(IN) EVAL(0,ARG3,EACHVAL,WALKFN) IN=UNSTKSYS DEVICE=TTY;BORROWLOAD=0 %IF BORROWFLAG=1 %THEN DISCONBFILE %IF JUMPFLAG=1 %THEN ->BERR2 ARG3=UNSTACK ARG3=CONS(ARG1,NIL) EVAL(0,ARG3,EACHVAL,WALKFN) %IF BORROWFLAG=1 %THENSTART BORROWFLAG=0 MAPFILE(OWNFADDR) PRSTRING('YOUR OWN MEMORY IS AVAILABLE AGAIN') NOOLINE(1) %FINISH STACK(NSR) %UNLESS JUMPFLAG=1 %RETURN !HERE FOR ERRORS BERR1:%IF BORROWFLAG=1 %THEN DISCONBFILE BERR2:%IF BORROWFLAG=1 %THENSTART MAPFILE(OWNFADDR) PRSTRING('YOUR OWN MEMORY IS AVAILABLE AGAIN') NOOLINE(1) BORROWFLAG=0 %FINISH %RETURN; ! END LIBRARY ! ! SYSFUN(87):; ! RETURN (BORROWED FILE) %IF BORROWFLAG=0 %THENSTART ERROR('YOU ARE NOT BORROWING AT THE MOMENT',EMPTY,1,IN) %RETURN %FINISH PRSTRING(ERRMESS(16));NOOLINE(1) BORROWFLAG=0 MAPFILE(OWNFADDR) STACK(NSR) %RETURN; ! END RETURN ! ! SYSFUN(88):; ! SHOWFILE %IF BORROWFLAG=1 %THENSTART %IF SHAREFILE#0 %THENRETURN WSTR1=BFILE WSTR2=BORROWEE %FINISHELSE WSTR1=OWNFILE %AND WSTR2=USER DEFINE('ST13,.LP') SELECTOUTPUT(13) PRINTSTRING('FILE '.WSTR1.' BELONGING TO '.WSTR2) NEWLINES(2) PRINTSTRING('DIRNUM=');WRITE(DIRNUM,5);NEWLINE PRINTSTRING('DIRPAGES=');WRITE(DIRPAGES,5);NEWLINE PRINTSTRING('WRITINGFILE=');WRITE(WRITINGFILE,5);NEWLINE PRINTSTRING('UNTIDY=');WRITE(UNTIDY,5);NEWLINE PRINTSTRING('NFTEXT=');WRITE(NFTEXT,5);NEWLINES(2) %IF DIRNUM=0 %THEN ->SHFL PRINTSTRING('DIRECTORY ENTRIES:-');NEWLINE %CYCLE ARG1=1,1,DIRNUM PRINTSTRING(DIR(ARG1)_PROCNAME);WRITE(DIR(ARG1)_TEXTINDEX,5); NEWLINE %REPEAT NEWLINE PRINTSTRING('TEXT:-');NEWLINE %CYCLE ARG1=1,1,NFTEXT-1 PRINTSYMBOL(TEXT(ARG1)) %REPEAT NEWLINE SHFL:SELECTOUTPUT(0) CLOSESTREAM(13) CLEAR('ST13') STACK(NSR) %RETURN; ! END SHOWFILE ! ! SYSFUN(89):; ! GOTOFILE SELECTINPUT(3) SETMARGINS(3,1,120) STACK(NSR) %RETURN; ! END GOTOFILE ! ! ! SYSFUN(91):; ! ABORT ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&NM#NM %OR ARG1<0 %THENSTART ERROR('NON-POSITIVE ARG FOR ABORT - ',ARG1,1,IN) %RETURN %FINISH JUMPFLAG=1 JUMPOUT=ARG1>>8 STACK(NSR) %RETURN; ! END ABORT ! ! SYSFUN(92):; ! QUIT JUMPFLAG=1 JUMPOUT=100 %IF TDEV#0 %THEN CLESET; ! CLEAR DEVICE Q IN H316 STACK(NSR) %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(NSR) %RETURN; ! END CONTINUE ! ! SYSFUN(94):; ! SENDBACK ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN; ! VALUE TO BE SENT ARG2=GETNEXT(IN); ! FN TO BE SENT TO OR NUMBER OF FNS TO BE EXITED %IF JUMPFLAG=1 %THENRETURN %IF ARG2&NM=NM %THENSTART %IF ARG2<0 %THENSTART ERROR('NEGATIVE SECOND ARG FOR SENDBACK - ',EMPTY,1,IN) %RETURN %FINISH SENDFLAG=ARG2>>8; ! NO OF RETURNS JUMPFLAG=1 STACK(ARG1) %RETURN %FINISH %IF ARG2&WM#WM %THENSTART ERROR('SENDBACK TO WHERE? ',ARG2,1,IN) %RETURN %FINISH W1=ENVIR; ! CURRENT ENVIR TOP ARG3=0 %WHILE W1>BASENVIR %CYCLE %WHILE BNAME(W1)#0 %CYCLE;W1=W1-1;%REPEAT W2=BVALUE(W1); ! FN ENTERED W1=W1-1; ! NEXT ENVIR TOP %IF W2=ARG2 %THENSTART; ! FOUND IT SENDFLAG=ARG3+1; ! NO OF RETURNS TO BE MADE TO GET THERE JUMPFLAG=1 STACK(ARG1) %RETURN %FINISHELSESTART; ! NOT THE RIGHT FN %IF W2#LOGONAME %THEN ARG3=ARG3+1; ! SO INC NO OF RETURNS, UNLESS LOGO %FINISH %REPEAT ! GETS HERE IF FN NOT FOUND AT CURRENT LEVEL ERROR('FN FOR SENDBACK NOT OUTSTANDING - ',%C ARG2,1,IN) %RETURN; ! END SENDBACK ! ! SYSFUN(95):; ! BREAK ARG1=IN NOOLINE(1) %IF ARG1=NIL %THEN PRINTEL(BREAK) %WHILE ARG1#NIL %CYCLE PRINTEL(HD(ARG1)) SPACE ARG1=TL(ARG1) %REPEAT ERROR('',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN; ! ABORT OR QUIT STACK(BREAK); ! RESULT FOR CONTINUE %RETURN; ! FROM CONTINUE. END BREAK ! ! SYSFUN(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 DPROMPT('RESULT:') BLEVEL=1 FILL LINE BUFFER ARG1=READLIST(BLEVEL) %IF ARG1=ERR %THEN ->RL107 STKSYS(IN) EVAL(0,ARG1,EACHVAL,WALKFN) IN=UNSTKSYS %IF JUMPFLAG=1 %THENSTART; ! SPECIAL FOR RETRY JUMPFLAG=0 JUMPOUT=0 STKPNT=ARG3 ->RL107 %FINISH DPROMPT(PROMP) ! STACK(UNSTACK) %RETURN; ! END CALLUSER ! ! SYSFUN(97):; ! FNCALLS ARG1=ENVIR NOOLINE(1) %WHILE ARG1>1022 %CYCLE %IF BNAME(ARG1)=0 %THENSTART PRINTEL(BVALUE(ARG1)) NOOLINE(1) %FINISH ARG1=ARG1-1 %REPEAT PRINTEL(LOGONAME) NOOLINE(1) STACK(NSR) %RETURN; ! END FNCALLS ! ! SYSFUN(98):; ! FNVALS ARG1=ENVIR NOOLINE(1) %WHILE ARG1>1022 %CYCLE ARG2=ARG1 %WHILE BNAME(ARG2)#0 %CYCLE ARG2=ARG2-1 %REPEAT; ! ARG2 POINTS TO CURRENT BOTTOM PRINTEL(BVALUE(ARG2)); ! FUNCTION NAME PRSTRING(':-') NOOLINE(1) ARG3=ARG2+1 %WHILE ARG3<=ARG1 %CYCLE SPACES(4) PRINTEL(BNAME(ARG3)) SPACE PRINTEL(BVALUE(ARG3)) NOOLINE(1) ARG3=ARG3+1 %REPEAT NOOLINE(1) ARG1=ARG2-1 %REPEAT PRINTEL(LOGONAME) NOOLINE(1) STACK(NSR) %RETURN; ! END FNVALS ! ! SYSFUN(99):; ! ABBREV REDEF=0 ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&WM#WM %OR ARG2&WM#WM %THENSTART ERROR('ABBREV REQUIRES TWO WORDS AS INPUTS. IT WAS GIVEN ',%C CONS(ARG1,CONS(ARG2,NIL)),1,IN) %RETURN %FINISH %IF FNVAL(ARG1>>8)=0 %THENSTART ERROR(WA(ARG1>>8).' IS NOT DEFINED',EMPTY,1,IN) %RETURN %FINISH ! SO ARG1 OK ARG3=FNVAL(ARG2>>8); ! GET SPEC FOR ABBREVIATION %IF ARG3=0 %THEN -> TRANSPEC; ! UNDEFINED SO OK %IF ARG3&USERPRE=USERPRE %THENSTART REDEF=1 ->TRANSPEC %FINISH; ! ALREADY DEFINED BY USER ERROR('YOU CANNOT USE ELOGO''S OWN PROCEDURE NAME '.WA(ARG2>>8).%C ' AS AN ABBREVIATION',EMPTY,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(NSR) %RETURN; ! END ABBREV ! ! SYSFUN(100):; ! MFIRST ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&LM#LM %OR ARG1=NIL %THENSTART ERROR('BAD FIRST ARG FOR MFIRST - ',CONS(ARG1,CONS(ARG2,NIL)),1,IN) %RETURN %FINISH %IF (ARG1>>8)>=LAFNB %THENSTART; ! LIST EMBEDDED IN FN DEFN ERROR('LIST EMBEDDED IN FN DEFN CANNOT BE UPDATED - ',ARG1,1,IN) %RETURN %FINISH REPHEAD(ARG1,ARG2) STACK(NSR) %RETURN; ! END MFIRST ! ! SYSFUN(101):; ! MBUTFIRST ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&LM#LM %OR ARG1=NIL %THENSTART ERROR('BAD FIRST ARG FOR MBUTFIRST - ',CONS(ARG1,CONS(ARG2,NIL)),1,IN) %RETURN %FINISH %IF (ARG1>>8)>=LAFNB %THENSTART ERROR('LIST EMBEDDED IN FN DEFN CANNOT BE UPDATED - ',ARG1,1,IN) %RETURN %FINISH %IF ARG2&LM#LM %THENSTART ERROR('BAD SECOND ARG FOR MBUTFIRST - ',%C CONS(ARG1,CONS(ARG2,NIL)),1,IN) %RETURN %FINISH REPTAIL(ARG1,ARG2) STACK(NSR) %RETURN; ! END MBUTFIRST ! ! SYSFUN(105):; ! GOODBYE SYSFUN(106):; ! EXIT %IF BORROWFLAG=1 %THEN BORROWFLAG=0 %AND MAPFILE(OWNFADDR) %IF UNTIDY=1 %AND STATUS(OWNFILE,0)=1 %THEN TIDYFILE %AND WRITINGFILE=0 ! TIDY IF NO OTHER USERS ELSE LEAVE UNTIDY TILL NEXT SESSION %IF TDEV#0 %THEN FREEDEVICE; ! FREE TURTLE DEVICE IF ANY CLOSESTREAM(1) CLEAR('ST01') CLOSESM(6);CLEAR('SM06') DESTROY('LOGOSTK') CLOSESM(5);CLEAR('SM05');DISCONNECT(MASNUM.'LOGERRS') DISCONOWNFILE USER->USER.(' ').WSTR1 PRSTRING('GOODBYE '.USER) NOOLINE(1) PRSTRING(DATE.' '.TIME);NOOLINE(11) %IF SW=105 %THENSTART DEFINE('ST01,.LP') SELECTOUTPUT(1) %CYCLE ARG1=1,1,DPNT PRINTSYMBOL(DFILE(ARG1)) %REPEAT SELECTOUTPUT(0) CLOSESTREAM(1) CLEAR('ST01') %FINISH CLOSESM(11) CLEAR('SM11') DESTROY('LOGODRIB') %STOP; ! END EXIT,GOODBYE ! ! 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(111):; ! VALUE ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&WM#WM %THENSTART ERROR(ERRMESS(57),ARG1,1,IN) %RETURN %FINISH ARG2=GETVAL(ARG1,ENVIR) %IF ARG2=UNDEF %THENSTART ERROR(ERRMESS(3),ARG1,1,IN) %RETURN %FINISH STACK(ARG2) %RETURN; ! END VALUE ! ! SYSFUN(112):; ! REPEAT ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&NM#NM %OR ARG1<0 %THENSTART ERROR(ERRMESS(35),ARG1,1,IN) %RETURN %FINISH %IF ARG1>>8=0 %THENSTART IN=NIL STACK(NSR) %RETURN %FINISH %IF IN=NIL %THENSTART ERROR(ERRMESS(36).NUMTOSTR(ARG1).ERRMESS(37),EMPTY,1,IN) %RETURN %FINISH %CYCLE ARG2=1,1,ARG1>>8 ARG3=IN; ! SAVE IN TO REUSE FOR REOEATS STKSYS(IN) EVAL(0,ARG3,EACHVAL,WALKFN) IN=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN W1=UNSTACK; ! LAST VALUE %REPEAT IN=ARG3 STACK(W1) %RETURN; ! END REPEAT ! ! SYSFUN(113):; ! RESET LOGOTIME=TIME100 STACK(NSR) %RETURN; ! END RESET ! ! SYSFUN(114):; ! TIME STACK((TIME100-LOGOTIME)<<8!NM) %RETURN; ! END TIME ! ! ! SYSFUN(116):; ! RANDOM ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&NM#NM %THENSTART ERROR('NON-NUMERIC ARG FOR RANDOM - ',ARG1,1,IN) %RETURN %FINISH %IF ARG1<0 %THENSTART ARG2=-1 ARG1=-(ARG1>>8!T8)+1; ! POSITIVE BINARY +1 %FINISHELSESTART ARG2=1 ARG1=ARG1>>8+1 %FINISH STACK((INTPT(RANDOM(RANSEED,1)*ARG1)*ARG2)<<8!NM) %RETURN; ! END RANDOM ! ! SYSFUN(117):; ! APPLY ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN IN=CONS(ARG1,IN) EVAL(0,IN,EACHVAL,WALKFN) ! STACK(UNSTACK) %RETURN; ! END APPLY ! ! SYSFUN(118):; ! ALERT LIST(MASNUM.'LOGALERT') STACK(NSR) %RETURN; ! END ALERT ! ! SYSFUN(119):; ! EXERCISE %IF STATUS(MASNUM.'ELOGOO',0)>1 %THENSTART ERROR(ERRMESS(29),EMPTY,1,IN) %RETURN %FINISH MAPMASTER %CYCLE ARG1=1,1,MASENTS %IF USERIDS(ARG1)#'DESTROYED' %THENSTART WSTR1='LOGO'.NUMTOSTR(ARG1<<8) %IF STATUS(MASNUM.WSTR1,1)<0 %THENSTART PRSTRING(WSTR1.' NEEDS RESTORED FOR USER '.USERIDS(ARG1)) NOOLINE(1) %FINISHELSE DISCONNECT(MASNUM.WSTR1) %FINISH %REPEAT DISCONMASTER %CYCLE ARG1=1,1,8 %IF STATUS('ECMI50.'.TDEVNAMES(ARG1),1)<0 %THENSTART PRSTRING('SYSTEM FILE '.TDEVNAMES(ARG1).' NEEDS RESTORING.') NOOLINE(1) PRSTRING('SET PERMIT TO R ALL ROUND AFTER RESTORE.');NOOLINE(1) %FINISHELSE DISCONNECT('ECMI50.'.TDEVNAMES(ARG1)) %REPEAT %CYCLE ARG1=1,1,4 %IF STATUS(MASNUM.SYSFILES(ARG1),1)<0 %THENSTART PRSTRING('SYSTEM FILE '.SYSFILES(ARG1).' NEEDS RESTORING.') NOOLINE(1) PRSTRING('SET PERMIT TO RS ALL ROUND AFTER RESTORE.') NOOLINE(1) %FINISHELSE DISCONNECT(MASNUM.SYSFILES(ARG1)) %REPEAT STACK(NSR) %RETURN; ! END EXERCISE ! ! SYSFUN(120):; ! DUMP DUMP('USER REQUEST') STACK(NSR); %RETURN; ! END DUMP ! ! SYSFUN(121):; ! GETID MAPMASTER WSTR3=PROMP PROMP='WHO ARE YOU:' DPROMPT(PROMP) WHOLP:ARG1=READLINE %IF ARG1=NIL %THEN ->WHOLP USER=CHECKID(ARG1) %IF USER='' %THENSTART; ! INVALID OR NULL RESPONSE PRSTRING('WRONGLY FORMATTED IDENTIFIER ') PRINTEL(ARG1); NOOLINE(1) ->WHOLP %FINISH %CYCLE ARG1=1,1,MASENTS %IF USER=USERIDS(ARG1) %THEN ->WHOOK %REPEAT ! NOT FOUND PRSTRING('LOGO DOES NOT KNOW '.USER) NOOLINE(1) ->WHOLP ! WHOOK:OWNFILE=MASNUM.'LOGO'.NUMTOSTR(ARG1<<8) CONOWNFILE DISCONMASTER PROMP=WSTR3 DPROMPT(PROMP) STACK(NSR) %RETURN; ! END GETID ! ! SYSFUN(122):; ! GETTY SELECTINPUT(0) CLOSESTREAM(3) CLEAR('ST03') DESTROY('LOGOTEMP') PRSTRING('TEMPORARY FILE DESTROYED');NOOLINE(1) PRSTRING('LOADED AND READY');NOOLINE(3) STACK(NSR) %RETURN; ! END GETTY ! ! SYSFUN(123):; ! TRUE STACK(TRUE) %RETURN; ! END TRUE ! ! SYSFUN(124):; ! FALSE STACK(FALSE) %RETURN; ! END FALSE ! ! SYSFUN(125):; !SPACE PRINTEL(SPACE1) STACK(NSR) %RETURN; ! END SPACE ! ! SYSFUN(126):; ! TAB PRINTEL(TAB) STACK(NSR) %RETURN; ! END TAB ! ! SYSFUN(127):; ! NL, CARRIAGE NOOLINE(1) STACK(NSR) %RETURN; ! END NL ! ! SYSFUN(128):; ! EMPTY STACK(EMPTY) %RETURN; ! END EMPTY ! ! SYSFUN(129):; ! SYSTEM STACK(OWNFUNS) %RETURN; ! END SYSTEM ! ! SYSFUN(130):; ! SETULIM ARG1=UNSTACKINPUT;%IF JUMPFLAG=1 %THENRETURN %IF ARG1&NM#NM %OR ARG1<0 %THENSTART ERROR('SETULIM NEEDS A NON-NEGATIVE NUMBER - ',ARG1,1,IN) %RETURN %FINISH APPULIM=ARG1>>8 STACK(NSR) %RETURN; ! END SETULIM ! ! SYSFUN(131):; ! SETELIM ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&NM#NM %OR ARG1<0 %THENSTART ERROR('SETELIM NEEDS A POSITIVE NUMBER - ',ARG1,1,IN) %RETURN %FINISH EVALIMIT=ARG1>>8 STACK(NSR) %RETURN; ! END SETELIM ! ! SYSFUN(132):; ! SETCFLG CLECTFLG=1 STACK(NSR) %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(NSR) %RETURN; ! END HASHINFO ! ! SYSFUN(134):; ! MAKEASSOC ARG3=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN; ! VALUE ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN; ! ATTRIBUTE ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN; ! OBJECT %IF ARG1&WM#WM %THENSTART ERROR('INVALID FIRST ARG FOR MAKEASSOC - ',ARG1,1,IN) %RETURN %FINISH ARG1=ARG1>>8; ! WA INDEX STACK(NSR) 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 ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN; ! ATT ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN; ! OB %IF ARG1&WM#WM %THENSTART ERROR('INVALID FIRST ARG FOR GETASSOC - ',ARG1,1,IN) %RETURN %FINISH ARG3=FINDASS(ASSOCWA(ARG1>>8),ARG2) %IF ARG3#NIL %THEN ARG3=HD(TL(HD(ARG3))); ! VALUE STACK(ARG3) %RETURN; ! END GETASSOC ! ! SYSFUN(136):; ! REMASSOC ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&WM#WM %THENSTART ERROR('INVALID FIRST ARG FOR REMASSOC - ',ARG1,1,IN) %RETURN %FINISH ARG1=ARG1>>8 ARG3=FINDASS(ASSOCWA(ARG1),ARG2) %IF ARG3#NIL %THENSTART; ! ASSOC EXISTS %IF W1=W2 %THEN ASSOCWA(ARG1)=TL(W2) %ELSE REPTAIL(W1,TL(W2)) %FINISH STACK(NSR) %RETURN; ! END REMASSOC ! ! SYSFUN(137):; ! CLEARASSOC ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&WM#WM %THENSTART ERROR('INVALID ARG FOR CLEARASSOC - ',ARG1,1,IN) %RETURN %FINISH ASSOCWA(ARG1>>8)=NIL STACK(NSR) %RETURN; ! END CLEARASSOC ! ! SYSFUN(138):; ! CLEARALLASSOC %CYCLE ARG1=0,1,1022 ASSOCWA(ARG1)=NIL %REPEAT STACK(NSR) %RETURN; ! END CLEARALLASSOC ! ! ! ! SYSFUN(141):; ! WALK ARG1=UNSTACKINPUT;%IF JUMPFLAG=1 %THENRETURN %IF WALKFN#UNDEF %THENSTART ERROR('YOU CAN ONLY WALK THROUGH ONE PROCEDURE AT A TIME',%C EMPTY,1,IN) %RETURN %FINISH %IF ARG1&WM#WM %THENSTART ERROR('PROCEDURE WALK MUST HAVE A PROCEDURE NAME AS INPUT.'%C .' IT WAS GIVEN ',ARG1,1,IN) %RETURN %FINISH ARG2=FNVAL(ARG1>>8) %IF ARG2=0 %THENSTART ERROR('THERE IS NO PROCEDURE IN WORKING MEMORY TO WALK THROUGH' %C .' NAMED ',ARG1,1,IN) %RETURN %FINISH %IF ARG2&B4#USERPRE %THENSTART ERROR('YOU CAN ONLY WALK THROUGH ONE OF YOUR OWN PROCEDURES', %C EMPTY,1,IN) %RETURN %FINISH IN=CONS(ARG1,IN) NXTSTP=1 ARG2=ARG2&M16!LM EVAL(0,IN,EACHVAL,ARG2) NXTSTP=NUMTOP !STACK(UNSTACK) %RETURN; ! END WALK ! ! SYSFUN(142):; ! STEP ARG1=UNSTACKINPUT;%IF JUMPFLAG=1 %THENRETURN %IF WALKFN=UNDEF %THENSTART ERROR('YOU ARE NOT IN STEPPING MODE',EMPTY,1,IN) %RETURN %FINISH %IF WALKFN#FUN %THENSTART ERROR('YOU CAN ONLY STEP THROUGH ONE PROCEDURE AT A TIME',EMPTY,1,IN) %RETURN %FINISH %IF ARG1&NM#NM %THENSTART ERROR('PROCEDURE STEP MUST HAVE A NUMBER AS INPUT.'%C .' IT WAS GIVEN ',ARG1,1,IN) %RETURN %FINISH %IF ARG1<0 %THENSTART ERROR('PROCEDURE STEP MUST HAVE A POSITIVE NUMBER AS INPUT.' %C .' IT WAS GIVEN ',ARG1,1,IN) %RETURN %FINISH NXTSTP=NXTSTP+(ARG1>>8) STACK(NSR) %RETURN; ! END STEP ! ! SYSFUN(143):; ! FINISH %IF WALKFN=UNDEF %THENSTART ERROR('YOU ARE NOT IN STEPPING MODE',EMPTY,1,IN) %RETURN %FINISH %IF WALKFN#FUN %THENSTART ERROR('YOU ARE NOT STEPPING THROUGH THIS PROCEDURE',EMPTY,1,IN) %RETURN %FINISH NXTSTP=NUMTOP STACK(NSR) %RETURN; !END FINISH ! ! SYSFUN(144):; ! HALFTRACE (TRACE) ARG3=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=TRACE(TRACE1,ARG3,FN) %IF JUMPFLAG=1 %THENRETURN %IF ARG1#NIL %THENSTART %IF ARG1=OWNFUNS %THEN PRSTRING('ALL OF LOGOS PROCEDURES') %C %ELSESTART PRSTRING('PROCEDURES ') PRINTEL(REVERSE(ARG1)) %FINISH PRSTRING(' HAVE BEEN MARKED FOR TRACING') NOOLINE(1) %FINISH STACK(NSR) %RETURN; ! END HALFTRACE ! ! SYSFUN(145):; ! TRACE (FULLTRACE) ARG3=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=TRACE(TRACE2,ARG3,FN) %IF JUMPFLAG=1 %THENRETURN %IF ARG1#NIL %THENSTART %IF ARG1=OWNFUNS %THEN PRSTRING('ALL OF LOGOS PROCEDURES') %C %ELSESTART PRSTRING('PROCEDURES ') PRINTEL(REVERSE(ARG1)) %FINISH PRSTRING(' HAVE BEEN MARKED FOR FULL TRACING') NOOLINE(1) %FINISH STACK(NSR) %RETURN; ! END FULLTRACE ! ! SYSFUN(146):; ! PARSE ARG3=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=TRACE(PARSE,ARG3,FN) %IF JUMPFLAG=1 %THENRETURN %IF ARG1#NIL %THENSTART %IF ARG1=OWNFUNS %THEN PRSTRING('ALL OF LOGOS PROCEDURES') %C %ELSESTART PRSTRING('PROCEDURES ') PRINTEL(REVERSE(ARG1)) %FINISH PRSTRING(' HAVE BEEN MARKED FOR PARSING') NOOLINE(1) %FINISH STACK(NSR) %RETURN; !END PARSE ! ! SYSFUN(147):; ! UNTRACE ARG3=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN NOOLINE(1) %IF ARG3=OWNFUNS %THEN W1=SYSTRACE(0,FN) %AND ->UNTR2 %IF ARG3&WM=WM %THEN ARG3=CONS(ARG3,NIL) %IF ARG3&LM#LM %THENSTART ERROR(WA(FN>>8).ERRMESS(24),ARG3,1,IN) %RETURN %FINISH W1=NIL %WHILE ARG3#NIL %CYCLE ARG1=HD(ARG3) ARG3=TL(ARG3) %IF ARG1&WM#WM %THENSTART ERROR1(WA(FN>>8).ERRMESS(24),CONS(ARG1,ARG3)) ->UNTR1 %FINISH ARG2=FNVAL(ARG1>>8) %IF ARG2=0 %THENSTART ERROR1(ERRMESS(21).WA(ARG1>>8).ERRMESS(23),FN) ->UNTR1 %FINISH FNVAL(ARG1>>8)=ARG2&UNMASK; ! REMOVE TRACE FLAG. IF SYSFUN NO EFFECT W1=CONS(ARG1,W1) UNTR1:%REPEAT UNTR2:%IF W1#NIL %THENSTART %IF W1=OWNFUNS %THEN PRSTRING('ALL OF LOGOS PROCEDURES') %C %ELSESTART PRSTRING('PROCEDURES ') PRINTEL(REVERSE(W1)) %FINISH PRSTRING(' WILL NO LONGER BE ') %IF FN=UNPARSE %THEN PRSTRING('PARSED.') %ELSE PRSTRING('TRACED.') NOOLINE(1) %FINISH STACK(NSR) %RETURN; ! END UNTRACE ! ! SYSFUN(148):; ! MAPLIST ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&LM#LM %THENSTART ERROR('NON-LIST ARG FOR MAPLIST - ',ARG1,1,IN) %RETURN %FINISH ARG3=NIL %IF ARG2&WM=WM %THENSTART %WHILE ARG1#NIL %CYCLE W2=HD(ARG1) %IF W2&WM=WM %THEN W2=CONS(QUOTE,CONS(W2,NIL)) %C %ELSE W2=CONS(W2,NIL) W1=CONS(ARG2,W2) ARG1=TL(ARG1) STKSYS(IN);STKSYS(ARG1);STKSYS(ARG3) EVAL(0,W1,EACHVAL,WALKFN) ARG3=UNSTKSYS;ARG1=UNSTKSYS;IN=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN ARG3=CONS(UNSTACK,ARG3) %REPEAT %FINISHELSESTART %IF ARG2&LM#LM %THENSTART ERROR('INVALID 2ND ARG FOR MAPLIST - ',ARG2,1,IN) %RETURN %FINISH %WHILE ARG1#NIL %CYCLE W1=HD(ARG1) ARG1=TL(ARG1) STKSYS(IN);STKSYS(ARG1);STKSYS(ARG2);STKSYS(ARG3) EVAL(0,ARG2,W1,WALKFN) ARG3=UNSTKSYS;ARG2=UNSTKSYS;ARG1=UNSTKSYS;IN=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN ARG3=CONS(UNSTACK,ARG3) %REPEAT %FINISH %WHILE ARG3#NIL %CYCLE ARG1=CONS(HD(ARG3),ARG1) ARG3=TL(ARG3) %REPEAT STACK(ARG1) %RETURN; ! END MAPLIST ! ! SYSFUN(149):; ! APPLIST ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&LM#LM %THENSTART ERROR('NON-LIST ARG FOR APPLIST - ',ARG1,1,IN) %RETURN %FINISH ARG3=NIL %IF ARG2&WM=WM %THENSTART %WHILE ARG1#NIL %CYCLE W1=HD(ARG1) %IF W1&WM=WM %THEN W1=CONS(QUOTE,CONS(W1,NIL)) %C %ELSE W1=CONS(W1,NIL) ARG3=CONS(ARG2,W1) ARG1=TL(ARG1) STKSYS(IN);STKSYS(ARG1) EVAL(0,ARG3,EACHVAL,WALKFN) ARG1=UNSTKSYS;IN=UNSTKSYS %IF JUMPFLAG =1 %THENRETURN ARG3=UNSTACK %REPEAT %FINISHELSESTART %IF ARG2&LM#LM %THENSTART ERROR('INVALID 2ND ARG FOR APPLIST - ',ARG2,1,IN) %RETURN %FINISH %WHILE ARG1#NIL %CYCLE W1=HD(ARG1) ARG1=TL(ARG1) STKSYS(IN);STKSYS(ARG1);STKSYS(ARG2) EVAL(0,ARG2,W1,WALKFN) ARG2=UNSTKSYS;ARG1=UNSTKSYS;IN=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN ARG3=UNSTACK %REPEAT %FINISH STACK(NSR) %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(NSR) %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(NSR) %RETURN; ! END ASSERT ! ! SYSFUN(153):; ! AMONGQ ARG2=UNSTACK ARG1=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 STACK(DEDUCEQ(ARG1,0)) %RETURN; ! END ISQ ! ! SYSFUN(155):; !FINDANY ARG2=UNSTACK ARG1=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=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 ARG2=UNSTACK ARG1=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 ARG1=ERR %THENRETURN ->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 BINARG1=0 BINARG2=4 SENDBIN(0,2); ! PENDOWN %FINISH BINARG1=2 BINARG2=INTPT(DX+FRACPT(XTURTLE))<<5 BINARG3=INTPT(DY+FRACPT(YTURTLE))<<5 SENDBIN(0,3); ! OUTLINV(DX,DY) %IF PENTURTLE=DOWN %THENSTART BINARG1=0 BINARG2=0 SENDBIN(0,2); ! PENUP %FINISH XTURTLE=XTURTLE+DX; YTURTLE=YTURTLE+DY STACK(NSR); ! 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 BINARG2=INTPT(DX+FRACPT(XTURTLE))<<5 BINARG3=INTPT(DY+FRACPT(YTURTLE))<<5 %IF PENTURTLE=DOWN %THEN BINARG1=9 %ELSE BINARG1=5 SENDBIN(0,3); ! DLINEV(DX,DY) OR DSETV(DX,DY) XTURTLE=XTURTLE+DX YTURTLE=YTURTLE+DY STACK(NSR) %RETURN ! FDSW(4):; ! TURTLE %IF ARG1=0 %THEN STACK(NSR) %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(NSR) %RETURN ! FDSW(5):FDSW(6):FDSW(7):; ! PUNCH,MUXIC,MECCANO ERROR(ERRMESS(33),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(NSR) %RETURN; ! END FORWARD ! ! SYSFUN(161):; ! BACKWARD ARG1=CHDEVARG %IF ARG1=ERR %THENRETURN ->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(ERRMESS(33),FN,1,IN) %RETURN ! BDSW(8): ;! GT42 DISPLAA ARG1 = -ARG1 -> FDSW(8); ! END BACKWARD ! SYSFUN(162):; ! LEFT ARG1=CHDEVARG %IF ARG1=ERR %THENRETURN ->LEFTSW(TDEV) LEFTSW(1):LEFTSW(2):; ! PLOTTERS %IF ARG1=0 %THEN STACK(NSR) %ANDRETURN HDTURTLE=MOD360(HDTURTLE+ARG1) %IF ARG1<0 %THEN PINDSEND(0,-ARG1) %ELSE PINDSEND(PINDLBIT,ARG1) %IF JUMPFLAG=1 %THENRETURN STACK(NSR) %RETURN ! LEFTSW(3):; ! DIPLAYS HDTURTLE=MOD360(HDTURTLE+ARG1) STACK(NSR) %RETURN ! LEFTSW(4):; ! TURTLE %IF ARG1=0 %THEN STACK(NSR) %ANDRETURN HDTURTLE=MOD360(HDTURTLE+ARG1) %IF ARG1<0 %THEN TSEND(RTBITS,TANGLE(-ARG1)) %ELSEC TSEND(LTBITS,TANGLE(ARG1)) %IF JUMPFLAG=1 %THENRETURN STACK(NSR) %RETURN ! LEFTSW(5):LEFTSW(6):LEFTSW(7):; ! PUNCH,MUSIC,MECCANO ERROR(ERRMESS(33),FN,1,IN) %RETURN ! LEFTSW(8): ;! GT42 DISPLAY HDTURTLE=MOD360(HDTURTLE+ARG1) CALC TURTLE STACK(NSR) %RETURN; ! END LEFT ! SYSFUN(163):; ! RIGHT ARG1=CHDEVARG %IF ARG1=ERR %THENRETURN ->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(ERRMESS(33),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(NSR) %RETURN ! LIFTSW(4):; ! TURTLE PENTURTLE=UP TSEND1(32) STACK(NSR) %RETURN ! LIFTSW(5):LIFTSW(6):LIFTSW(7):; ! PUNCH,MUSIC,MECCANO ERROR(ERRMESS(33),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(NSR) %RETURN ! DROPSW(4):; ! TURTLE PENTURTLE=DOWN TSEND1(32) STACK(NSR) %RETURN ! DROPSW(5):DROPSW(6):DROPSW(7):; ! PUNCH,MUSIC,MECCANO ERROR(ERRMESS(33),FN,1,IN) %RETURN; ! END DROP ! ! SYSFUN(166):; ! HOOT ->HOOTSW(TDEV) ! HOOTSW(1):HOOTSW(2):HOOTSW(3):HOOTSW(5):HOOTSW(6):HOOTSW(7): ! PLOTTERS,DISPLAY,PUNCH,MUSIC,MECCANO ERROR(ERRMESS(33),FN,1,IN) %RETURN ! HOOTSW(4):; ! TURTLE TSEND1(HOOTBIT) STACK(NSR) %RETURN ! HOOTSW(8): ;! GT42 DISPLAY SET42(CHPIC) CH3(BLEEP) STACK(NSR) %RETURN; ! END HOOT ! ! SYSFUN(167):; ! CENTRE ->CENSW(TDEV) ! CENSW(1):CENSW(2):; ! PLOTTERS XTURTLE=0 YTURTLE=0 HDTURTLE=0 PENTURTLE=DOWN BINARG1=1 BINARG2=0 BINARG3=0 SENDBIN(0,3); ! OUTLIN(0,0) PINDSEND(PINDRBIT+PINDLBIT,360); ! RESET IND ANTICLOCK %IF JUMPFLAG=1 %THENRETURN STACK(NSR) %RETURN ! CENSW(3):; ! DISPLAY XTURTLE=0 YTURTLE=0 HDTURTLE=0 PENTURTLE=DOWN BINARG1=6 BINARG2=0 BINARG3=0 SENDBIN(0,3); ! DPOINT(0,0) STACK(NSR) %RETURN ! CENSW(4):; ! TURTLE ARG2=0 ARG3=0 W1=0 W2=DOWN ->POSW(4); ! SETTURTLE ! CENSW(5):CENSW(6):CENSW(7):; ! PUNCH,MUSIC,MECCANO ERROR(ERRMESS(33),FN,1,IN) %RETURN ! CENSW(8): ;! GT42 DISPLAY XTURTLE=0 YTURTLE=0 HDTURTLE=0 PENTURTLE=DOWN POINT(512,512) CALC TURTLE STACK(NSR) %RETURN; ! END CENTRE ! ! SYSFUN(168):; ! CLEAR ->CLSW(TDEV) ! CLSW(1):CLSW(2):CLSW(4):; ! PLOTTERS,TURTLE NULL STACK(NSR) %RETURN ! CLSW(5):CLSW(6):CLSW(7):; ! PUNCH,MUSIC,MECCANO ERROR(ERRMESS(33),FN,1,IN) %RETURN ! CLSW(3):; ! DISPLAY BINARG1=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 BINARG1=0 BINARG2=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)) BINARG1=2 BINARG2=ARG3<<5 BINARG3=ARG2<<5 SENDBIN(0,3); ! OUTLINV(DX,DY) BINARG2=-BINARG2 BINARG3=-BINARG3 SENDBIN(0,3); ! OUTLINV(-DX,-DY) %REPEAT BINARG1=0 BINARG2=0 SENDBIN(0,2); ! PENUP STACK(NSR) %RETURN ! WHSW(3):; ! DISPLAY RW1=SIN(HDTURTLE/57.3) RW2=COS(HDTURTLE/57.3) BINARG1=12 BINARG2=INT(-1300.0*(0.9659*RW2+0.2588*RW1)) BINARG3=INT(-1300.0*(0.9659*RW1-0.2588*RW2)) BINARG4=INT(0.5176*1300.0*RW1) BINARG5=INT(-0.5176*1300.0*RW2) SENDBIN(0,5); ! DRAWTURT STACK(NSR) %RETURN ! WHSW(4):WHSW(5):WHSW(6):WHSW(7):; ! TURTLE,PUNCH,MUSIC,MECCANO ERROR(ERRMESS(33),FN,1,IN) %RETURN ! WHSW(8): ;! GT42 DISPLAY SHOW TURTLE 42 = 1 CALC TURTLE STACK(NSR) %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(ERRMESS(33),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(ERRMESS(33),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(ERRMESS(33),FN,1,IN) %RETURN; ! END YCOR ! ! 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(ERRMESS(33),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(ERRMESS(33),FN,1,IN) %RETURN; ! END PEN ! ! SYSFUN(175):; ! SETX ARG1=CHDEVARG %IF ARG1=ERR %THENRETURN ->SETXSW(TDEV) ! SETXSW(1):SETXSW(2):; ! PLOTTERS COORDOK(ARG1);%IF JUMPFLAG=1 %THENRETURN XTURTLE=ARG1 BINARG1=1 BINARG2=ARG1<<5 BINARG3=INTPT(YTURTLE)<<5 SENDBIN(0,3); ! OUTLIN(X,Y) STACK(NSR) %RETURN ! SETXSW(3):; ! DISPLAY COORDOK(ARG1);%IF JUMPFLAG=1 %THENRETURN XTURTLE=ARG1 %IF PENTURTLE=DOWN %THEN BINARG1=6 %ELSE BINARG1=4 ! EITHER DPOINT(X,Y) OR DSET(X,Y) BINARG2=ARG1<<5 BINARG3=INTPT(YTURTLE)<<5 SENDBIN(0,3) STACK(NSR) %RETURN ! SETXSW(4):; ! TURTLE SETUP(ARG1-INTPT(XTURTLE),HDTURTLE) %IF JUMPFLAG=1 %THENRETURN XTURTLE=ARG1 STACK(NSR) %RETURN ! SETXSW(5):SETXSW(6):SETXSW(7):; ! PUNCH,MUSIC,MECCANO ERROR(ERRMESS(33),FN,1,IN) %RETURN ! SETXSW(8): ;! GT42 DISPLAY COORDOK(ARG1);%IF JUMPFLAG=1 %THENRETURN XTURTLE=ARG1 POINT(XTURTLE+512,YTURTLE+512) STACK(NSR) %RETURN; ! END SETX ! SYSFUN(176):; ! SETY ARG1=CHDEVARG %IF ARG1=ERR %THENRETURN ->SETYSW(TDEV) ! SETYSW(1):SETYSW(2):; ! PLOTTERS COORDOK(ARG1);%IF JUMPFLAG=1 %THENRETURN YTURTLE=ARG1 BINARG1=1 BINARG2=INTPT(XTURTLE)<<5 BINARG3=ARG1<<5 SENDBIN(0,3); ! OUTLIN,X,Y) STACK(NSR) %RETURN ! SETYSW(3):; ! DISPLAY COORDOK(ARG1);%IF JUMPFLAG=1 %THENRETURN YTURTLE=ARG1 %IF PENTURTLE=DOWN %THEN BINARG1=6 %ELSE BINARG1=4 BINARG2=INTPT(XTURTLE)<<5 BINARG3=ARG1<<5 SENDBIN(0,3) STACK(NSR) %RETURN ! SETYSW(4):; ! TURTLE SETUP(ARG1-INTPT(YTURTLE),HDTURTLE-90) %IF JUMPFLAG=1 %THENRETURN YTURTLE=ARG1 STACK(NSR) %RETURN ! SETYSW(5):SETYSW(6):SETYSW(7):; ! PUNCH,MUSIC,MECCANO ERROR(ERRMESS(33),FN,1,IN) %RETURN ! SETYSW(8): ;! GT42 DISPLAY COORDOK(ARG1);%IF JUMPFLAG=1 %THENRETURN YTURTLE=ARG1 POINT(XTURTLE+512,YTURTLE+512) STACK(NSR) %RETURN; ! END SETY ! ! SYSFUN(177):; ! SETHEADING ARG1=CHDEVARG %IF ARG1=ERR %THENRETURN ->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(NSR) %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(ERRMESS(33),FN,1,IN) %RETURN ! SETHSW(8): ;! GT42 DISPLAY HDTURTLE=MOD360(ARG1) CALC TURTLE STACK(NSR) %RETURN; ! END SETHEADING ! SYSFUN(178):SYSFUN(190):; ! POSITION,LINE ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN %IF ARG1&LM=0 %THENSTART ERROR('LIST INPUT REQUIRED FOR ',FN,1,IN) %RETURN %FINISH %IF SW=190 %THENSTART %IF LISTLEN(ARG1)#2 %THEN ->POS1 %FINISHELSESTART %IF LISTLEN(ARG1)#4 %THEN ->POS1 %FINISH ARG2=HD(ARG1);ARG1=TL(ARG1); ! X ARG3=HD(ARG1);ARG1=TL(ARG1); ! Y %IF SW=190 %THENSTART W1=HDTURTLE<<8!NM W2=PENTURTLE %FINISHELSESTART W1=HD(ARG1);ARG1=TL(ARG1); ! HEADING W2=HD(ARG1); ! PEN %FINISH %IF ARG2&NM=0 %OR ARG3&NM=0 %OR W1&NM=0 %ORC (W2#UP %AND W2#DOWN) %THEN ->POS1 ARG2=IMPNUM(ARG2) ARG3=IMPNUM(ARG3) W1=IMPNUM(W1) ->POSW(TDEV) ! POSW(1):POSW(2):; ! PLOTTERS COORDOK(ARG2);%IF JUMPFLAG=1 %THENRETURN COORDOK(ARG3);%IF JUMPFLAG=1 %THENRETURN XTURTLE=ARG2 YTURTLE=ARG3 PENTURTLE=W2 %IF SW=190 %AND PENTURTLE=DOWN %THENSTART BINARG1=0 BINARG2=4 SENDBIN(0,2) %FINISH BINARG1=1 BINARG2=ARG2<<5 BINARG3=ARG3<<5 SENDBIN(0,3); ! OUTLIN(X,Y) ARG1=W1 %IF SW=190 %AND PENTURTLE=DOWN %THENSTART BINARG1=0 BINARG2=0 SENDBIN(0,2) %FINISH ->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(W1) PENTURTLE=W2 %IF PENTURTLE=DOWN %THENSTART %IF SW=190 %THEN BINARG1=8 %ELSE BINARG1=6 %FINISHELSE BINARG1=4 BINARG2=ARG2<<5 BINARG3=ARG3<<5 SENDBIN(0,3) STACK(NSR) %RETURN ! POSW(4):; ! TURTLE %IF SW=190 %THEN ERROR(ERRMESS(33),FN,1,IN) %ANDRETURN 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 ARG1=MOD360(W1-HDTURTLE) HDTURTLE=MOD360(W1) %IF ARG1>180 %THEN ARG1=ARG1-360 %IF ARG1#0 %THENSTART %IF ARG1<0 %THEN TSEND(RTBITS,TANGLE(-ARG1)) %ELSEC TSEND(LTBITS,TANGLE(ARG1)) %IF JUMPFLAG=1 %THENRETURN %FINISH PENTURTLE=W2 TSEND1(32) STACK(NSR) %RETURN ! POSW(5):POSW(6):POSW(7):; ! PUNCH,MUSIC,MECCANO ERROR(ERRMESS(33),FN,1,IN) %RETURN ! POSW(8): ;! GT42 DISPLAY COORDOK(ARG2); %IF JUMPFLAG=1 %THEN %RETURN COORDOK(ARG3); %IF JUMPFLAG=1 %THEN %RETURN %IF SW=190 %THENSTART DX=ARG2-XTURTLE DY=ARG3-YTURTLE VECTOR(DX,DY) XTURTLE=ARG2 YTURTLE=ARG3 STACK(NSR) %RETURN %FINISH XTURTLE=ARG2 YTURTLE=ARG3 HDTURTLE= MOD360(W1) PENTURTLE=W2 POINT(XTURTLE+512,YTURTLE+512) CALC TURTLE STACK(NSR) %RETURN; ! END POSITION ! ! SYSFUN(179):; ! ARCLEFT ARG1=CHDEVARG %IF ARG1=ERR %THENRETURN ARG2=CHDEVARG %IF ARG2=ERR %THENRETURN ARG3=0 ; ! TO INDICATE LEFT ! ARG1=ANG,ARG2=RAD ->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 BINARG1=0 BINARG2=4 SENDBIN(0,2); ! PENDOWN %FINISH %IF W1#0 %THENSTART BINARG1=4 BINARG2=XC BINARG3=YC BINARG4=W1 SENDBIN(0,4); ! OUTCRCLV(XC,YC,W1) %FINISH XTURTLE=XTURTLE+DX YTURTLE=YTURTLE+DY BINARG1=1 BINARG2=INTPT(XTURTLE)<<5 BINARG3=INTPT(YTURTLE)<<5; ! OUTLIN(X,Y) TO FINISH SENDBIN(0,3) %IF PENTURTLE=DOWN %THENSTART BINARG1=0 BINARG2=0 SENDBIN(0,2) %FINISH ->LEFTSW(1); ! TO DO HDTURTLE AND INDICATOR ARCL1:STACK(NSR) %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 BINARG1=11 BINARG2=XC BINARG3=YC BINARG4=W1 SENDBIN(0,4); ! DCIRCLV(XC,YX,W1) %FINISHELSESTART BINARG1=5 BINARG2=INTPT(DX+FRACPT(XTURTLE))<<5 BINARG3=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 BINARG1=6 %ELSE BINARG1=4 BINARG2=INTPT(XTURTLE)<<5 BINARG3=INTPT(YTURTLE)<<5 SENDBIN(0,3); ! DPOINT OR DSET TO FINISH STACK(NSR) %RETURN ! ARCLSW(4):; ! TURTLE %IF ARG1=0 %THEN STACK(NSR) %ANDRETURN %IF ARG2=0 %THEN ->LEFTSW(4) TARCLEFT(ARG2,ARG1) %IF JUMPFLAG=1 %THENRETURN STACK(NSR) %RETURN ! ARCLSW(5):ARCLSW(6):ARCLSW(7):; ! PINCH,MUSIC,MECCANO ERROR(ERRMESS(33),FN,1,IN) %RETURN ! ARCLSW(8): ;! GT42 %IF ARG1=0 %THEN STACK(NSR) %ANDRETURN %IF ARG2=0 %THEN ->LEFTSW(8) GTARCLEFT(ARG2,ARG1) %IF JUMPFLAG=1 %THENRETURN STACK(NSR) %RETURN; ! END ARCLEFT ! ! SYSFUN(180):; ! ARCRIGHT ARG1=CHDEVARG %IF ARG1=ERR %THENRETURN ARG2=CHDEVARG %IF ARG2=ERR %THENRETURN ARG3=1 ; ! TO INDICATE RIGHT ! ARG1=ANG,ARG2=RAD ->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(ERRMESS(33),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(ERRMESS(33),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 BINARG1=0 BINARG2=ARG1 SENDBIN(0,2); ! PUNCH(ARG1) STACK(NSR) %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(ERRMESS(33),FN,1,IN) %RETURN ! RNSW(5):; ! PUNCH BINARG1=1 SENDBIN(0,1); ! RUNOUT STACK(NSR) %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(ERRMESS(33),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 BINARG1=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(NSR) %RETURN; ! END TURTLE ! ! SYSFUN(187):; ! TAPE CLAIMDEVICE(5) %IF JUMPFLAG=1 %THENRETURN ->RNSW(5); ! END TAPE ! ! SYSFUN(188):; ! FREE %IF TDEV=0 %THENSTART ERROR(ERRMESS(51),EMPTY,1,IN) %RETURN %FINISH WSTR1=TDEVNAMES(TDEV) %IF TDEV=8 %THEN DISCONNECT(MASNUM.'EXEC26') FREEDEVICE PRSTRING(WSTR1.' DISCONNECTED');NOOLINE(1) STACK(NSR) %RETURN; ! END FREE ! ! SYSFUN(189):; ! CLESET %IF TDEV=0 %THENSTART ERROR(ERRMESS(33),FN,1,IN) %RETURN %FINISH CLESET STACK(NSR) %RETURN; ! END CLESET ! ! ! SYSFUN(191):; ! MUSIC CLAIMDEVICE(6) %IF JUMPFLAG=1 %THENRETURN STACK(NSR) %RETURN; ! END MUSIC ! ! SYSFUN(192):; ! MECCANO CLAIMDEVICE(7) %IF JUMPFLAG=1 %THENRETURN XTURTLE=0;YTURTLE=0;HDTURTLE=0;PENTURTLE=DOWN STACK(NSR) %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(NSR) %RETURN; ! END GT42 ! ! SYSFUN(201):; ! HIDE (HIDETURTLE FOR GT42???) %IF TDEV#8 %THEN ERROR (ERRMESS(33),FN,1,IN) %ANDRETURN HIDE TURTLE STACK(NSR) %RETURN; ! END HIDE ! ! ! ! SYSFUN(210): ;! PICTURE / PIC %IF TDEV#8 %THEN ERROR (%C ERRMESS(33),FN,1,IN) %ANDRETURN ARG1=UNSTACKINPUT; %RETURNIF JUMPFLAG=1 %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 EVAL(0,IN,EACHVAL,WALKFN) ;! AND EXECUTE DRAWING FN %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(NSR) ;!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=UNSTACKINPUT ;! GET NAME AND CHECK IT %RETURNIF JUMPFLAG=1 %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(NSR) %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:' DPROMPT(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(NSR) %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; DPROMPT(PROMP) STACK(NSR) %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(NSR) PROMP = SAVE PROMP; DPROMPT (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 (ERRMESS(33),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(NSR) %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(ERRMESS(33),FN,1,IN) %ANDRETURN ARG1=UNSTACKINPUT %RETURNIF JUMPFLAG=1 ;! CHECK FOR NUMERIC ARG %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+!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(NSR) %RETURN SYSFUN(216): ;! CRANEBACKWARD %IF TDEV#8 %THEN ERROR (ERRMESS(33),FN,1,IN) %ANDRETURN ARG1=UNSTACKINPUT %RETURNIF JUMPFLAG=1 %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 (ERRMESS(33),FN,1,IN) %ANDRETURN ARG1=UNSTACKINPUT %RETURNIF JUMPFLAG=1 %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(NSR) %RETURN SYSFUN(218): ;! CRANE RIGHT/ CRIGHT %IF TDEV#8 %THEN ERROR (ERRMESS(33),FN,1,IN) %AND %RETURN ARG1=UNSTACKINPUT %RETURNIF JUMPFLAG=1 %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(NSR) %RETURN SYSFUN(219): ;! NEWMOVIE %IF TDEV#8 %THEN ERROR(ERRMESS(33),FN,1,IN) %ANDRETURN CURMOVIE=NIL ;! INITIALISES CURRENT MOVIE LIST PROMP=SAVE PROMP %UNLESS FRAMEFLAG=0 FRAMEFLAG=0 ;!MAKE SURE NOT IN FRAME DPROMPT(PROMP) ;!AND RESTORE DPROMPT GRABLIST=NIL STACK(NSR) %RETURN SYSFUN(220): ;! GRAB (VERSION 2) %IF TDEV#8 %THEN ERROR(ERRMESS(33),FN,1,IN) %ANDRETURN ARG1=UNSTACKINPUT %RETURNIF JUMPFLAG=1 ;! CHECK ARGUMENT %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 (NSR) %RETURN SYSFUN(221): ;! RELEASE (VERSION2) %IF TDEV#8 %THEN ERROR(ERRMESS(33),FN,1,IN) %ANDRETURN ARG1=UNSTACKINPUT %RETURNIF JUMPFLAG=1 ;! CHECK ARGUMET %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 (NSR) %RETURN SYSFUN(222): ;!SET CRANE/ SETC %IF TDEV#8 %THEN ERROR (ERRMESS(33),FN,1,IN) %ANDRETURN ARG1=UNSTACKINPUT %RETURNIF JUMPFLAG=1 ;! GET ARG LIST %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(NSR) %RETURN ! SYSFUN(223): ;!OMIT %IF TDEV#8 %THEN ERROR(ERRMESS(33),FN,1,IN) %ANDRETURN ARG1=UNSTACKINPUT ;! GET PICTURE NAME %RETURNIF JUMPFLAG=1 %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(NSR) %RETURN ! %RETURN SYSFUN(224): ;! GRABLIST %IF TDEV#8 %THEN ERROR(ERRMESS(33),FN,1,IN) %ANDRETURN STACK(GRABLIST) %RETURN %RETURN SYSFUN(228): ;! CRANEHERE %IF TDEV#8 %THEN ERROR(ERRMESS(33),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(ERRMESS(33),FN,1,IN) %ANDRETURN CAPFLAG=1 ARG1=UNSTACKINPUT %RETURNIF JUMPFLAG=1 PRINTEL(ARG1) CAPFLAG=0 STACK(NSR) %RETURN ! %RETURN SYSFUN(226): ;! FRAMESPEED N %IF TDEV#8 %THEN ERROR(ERRMESS(33),FN,1,IN) %ANDRETURN ARG1=UNSTACKINPUT %RETURNIF JUMPFLAG=1 %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(NSR) %RETURN ! SYSFUN(227): ;! KILL FRAME %IF TDEV# 8 %THEN ERROR (ERRMESS(33),FN,1,IN) %ANDRETURN %IF FRAMEFLAG=0 %THEN ERROR (%C 'KILLFRAME FAILS - NO FRAME CURRENT',EMPTY,1,IN) %C %AND %RETURN FRAMEFLAG=0 DPROMPT(SAVEPROMP) PRSTRING('*** FRAME KILLED '.TIME.' ***') NOOLINE(1) STACK(NSR) %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(NSR) %RETURN ! ! ! 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(ERRMESS(33),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 BINARG1=1 BINARG2=(ARG1<<8)!(ARG2-1) SENDBIN(0,2) STACK(NSR) %RETURN ! ! ! SYSFUN(231):; ! PLAY ->PLAYSW(TDEV) ! PLAYSW(1):PLAYSW(2):PLAYSW(3):PLAYSW(4):PLAYSW(5):PLAYSW(7):PLAYSW(8): ! ALL BUT MUSIC ERROR(ERRMESS(33),FN,1,IN) %RETURN ! PLAYSW(6):; ! MUSIC BINARG1=0 SENDBIN(0,1) STACK(NSR) %RETURN ! ! ! SYSFUN(232):; ! REST STACK(NM) %RETURN ! SYSFUN(233):; ! A0 STACK(1<<8!NM) %RETURN ! SYSFUN(234):; ! AS0 STACK(2<<8!NM) %RETURN ! SYSFUN(235):; ! B0 STACK(3<<8!NM) %RETURN ! SYSFUN(236):; ! C0 STACK(4<<8!NM) %RETURN ! SYSFUN(237):; ! CS0 STACK(5<<8!NM) %RETURN ! SYSFUN(238):; ! D0 STACK(6<<8!NM) %RETURN ! SYSFUN(239):; ! DS0 STACK(7<<8!NM) %RETURN ! SYSFUN(240):; ! E0 STACK(8<<8!NM) %RETURN ! SYSFUN(241):; ! F0 STACK(9<<8!NM) %RETURN ! SYSFUN(242):; ! FS0 STACK(10<<8!NM) %RETURN ! SYSFUN(243):; ! G0 STACK(11<<8!NM) %RETURN ! SYSFUN(244):; ! GS0 STACK(12<<8!NM) %RETURN ! SYSFUN(245):; ! A1 STACK(13<<8!NM) %RETURN ! SYSFUN(246):; ! AS1 STACK(14<<8!NM) %RETURN ! SYSFUN(247):; ! B1 STACK(15<<8!NM) %RETURN ! SYSFUN(248):; ! C1 STACK(16<<8!NM) %RETURN ! SYSFUN(249):; ! CS1 STACK(17<<8!NM) %RETURN ! SYSFUN(250):; ! D1 STACK(18<<8!NM) %RETURN ! SYSFUN(251):; ! DS1 STACK(19<<8!NM) %RETURN ! SYSFUN(252):; ! E1 STACK(20<<8!NM) %RETURN ! SYSFUN(253):; ! F1 STACK(21<<8!NM) %RETURN ! SYSFUN(254):; ! FS1 STACK(22<<8!NM) %RETURN ! SYSFUN(255):; ! G1 STACK(23<<8!NM) %RETURN ! SYSFUN(256):; ! GS1 STACK(24<<8!NM) %RETURN ! SYSFUN(257):; ! A2 STACK(25<<8!NM) %RETURN ! SYSFUN(258):; ! AS2 STACK(26<<8!NM) %RETURN ! SYSFUN(259):; ! B2 STACK(27<<8!NM) %RETURN ! SYSFUN(260):; ! C2 STACK(28<<8!NM) %RETURN ! SYSFUN(261):; ! CS2 STACK(29<<8!NM) %RETURN ! SYSFUN(262):; ! D2 STACK(30<<8!NM) %RETURN ! SYSFUN(263):; ! DS2 STACK(31<<8!NM) %RETURN ! SYSFUN(264):; ! E2 STACK(32<<8!NM) %RETURN ! SYSFUN(265):; ! F2 STACK(33<<8!NM) %RETURN ! SYSFUN(266):; ! FS2 STACK(34<<8!NM) %RETURN ! SYSFUN(267):; ! G2 STACK(35<<8!NM) %RETURN ! SYSFUN(268):; ! GS2 STACK(36<<8!NM) %RETURN ! SYSFUN(269):; ! A3 STACK(37<<8!NM) %RETURN ! SYSFUN(270):; ! AS3 STACK(38<<8!NM) %RETURN ! SYSFUN(271):; ! B3 STACK(39<<8!NM) %RETURN ! SYSFUN(272):; ! C3 STACK(40<<8!NM) %RETURN ! SYSFUN(273):; ! CS3 STACK(41<<8!NM) %RETURN ! SYSFUN(274):; ! D3 STACK(42<<8!NM) %RETURN ! SYSFUN(275):; ! DS3 STACK(43<<8!NM) %RETURN ! SYSFUN(276):; ! E3 STACK(44<<8!NM) %RETURN ! SYSFUN(277):; ! F3 STACK(45<<8!NM) %RETURN ! SYSFUN(278):; ! FS3 STACK(46<<8!NM) %RETURN ! SYSFUN(279):; ! G3 STACK(47<<8!NM) %RETURN ! SYSFUN(280):; ! GS3 STACK(48<<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(ERRMESS(33),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(ERRMESS(33),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(ERRMESS(33),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(ERRMESS(33),FN,1,IN) %RETURN ! PAIRSW(7):; ! MECCANO ->LEFTSW(4); ! TURTLE LEFT FOR NOW ! ! ! %END; ! END APPLYSYS ! %ROUTINE EVAL(%INTEGER PREC,%INTEGERNAME IN,EACHVAL,WALKFN) %INTEGER FN,FUNSPEC,TYPE,ARGNO,PARMLIST,NEXTPREC,FUNLIST %INTEGER WORK1,WORK2,TRACE %SWITCH SYSTR(0:3),USRTR(0:3),OUTR(0:3),INFTR(0:3),INFOUTR(0:3) %IF QUITFLAG=1 %THENSTART; ! USER INT Q QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1 %IF TDEV#0 %THEN CLESET ; ! CLEAR AND RESET TURTLE DEVICE IF ANY STACK(CONS(QQPROC,CONS(QUIT,NSRTAIL))) %RETURN %FINISH %IF HOLDFLAG=1 %AND BORROWLOAD=0 %THENSTART HOLDFLAG=0 %IF FUN#NIL %THENSTART ERROR('USER INTERRUPT',EMPTY,0,IN) %IF JUMPFLAG=1 %THENRETURN %FINISH %FINISH ! IF USER INTERRUPT HAS HAPPENED SERVICE IT %IF CLECTFLG=1 %THENSTART; ! GARBAGE COLLECT NEEDED STKSYS(IN);STKSYS(VAL); COLLECT(ENVIR) VAL=UNSTKSYS;IN=UNSTKSYS %FINISH EVALCNT=EVALCNT+1 %IF EVALCNT>=EVALIMIT %THENSTART ERROR('EVALIMIT EXCEEDED',EMPTY,1,IN) %RETURN %FINISH LP:%IF IN=NIL %THENSTART;STACK(CONS(QQPROC,CONS(NULL,NSRTAIL))); %RETURN;%FINISH FN=HD(IN) IN=TL(IN) %IF FN=COMMA %THEN ->LP; ! SEPARATOR TOP:%IF FN&NM=NM %OR FN&LM=LM %THENSTART; ! NUMBER OR LIST STACK(FN) %FINISHELSESTART; ! START 1 %IF FN=QUOTE %THENSTART; ! DATA WORD FOLLOWS STACK(HD(IN)) IN=TL(IN) %FINISHELSESTART; ! START 2 %IF FN=DOTS %THENSTART; ! DATA NAME FOLLOWS %IF IN=NIL %THENSTART ERROR('NAME MISSING AFTER :',EMPTY,1,IN) %RETURN %FINISH FN=HD(IN) IN=TL(IN) %IF FN&WM=WM %THENSTART TOP1:WORK1=GETVAL(FN,ENVIR) %IF WORK1=UNDEF %THENSTART ERROR(ERRMESS(3),FN,0,IN) %IF JUMPFLAG=1 %THENRETURN ->TOP1 %FINISHELSE STACK(WORK1) %FINISHELSESTART ERROR(ERRMESS(4),FN,1,IN) %RETURN %FINISH %FINISHELSESTART; ! START 3 %IF FN=LPAR %THENSTART EVAL(4,IN,EACHVAL,WALKFN) %IF JUMPFLAG=1 %THENRETURN IN=CONS(LPAR,IN); ! PUT BACK LPAR FOR GETMATCH WORK1=NIL WORK1=GETMATCH(WORK1,IN); ! DISCARD UP TO MATCHING ) %IF WORK1#EMPTY %THENSTART ERROR('MISSING )',EMPTY,1,IN) %RETURN %FINISH %FINISHELSESTART; ! START 4 %IF FN=LANGBRKS %THENSTART; ! < WORK1=NIL %WHILE IN#NIL %AND HD(IN)#RANGBRKS %CYCLE STKSYS(WORK1); ! IN CASE OF A COLLECT EVAL(0,IN,EACHVAL,WALKFN) WORK1=UNSTKSYS %IF JUMPFLAG=1 %THENRETURN WORK1=CONS(UNSTACK,WORK1) %REPEAT %IF IN=NIL %THENSTART ERROR('MISSING >',EMPTY,1,IN) %RETURN %FINISH IN=TL(IN) STACK(REVERSE(WORK1)) %FINISHELSESTART; ! START 5 %IF FN=RPAR %OR FN=RANGBRKS %THENSTART ERROR(ERRMESS(49),FN,1,IN) %RETURN %FINISH FUNSPEC=FNVAL(FN>>8); ! GET FUNCTION SPEC %IF FUNSPEC=0 %THENSTART; ! UNDEFINED ERROR(ERRMESS(5),FN,0,IN) %IF JUMPFLAG=1 %THENRETURN ->TOP %FINISH TYPE=FUNSPEC&B4; ! GET FUNCTION TYPE %IF TYPE=SYSPRE %OR TYPE=USERPRE %THENSTART; ! PREFIX FUN %IF TYPE=SYSPRE %THEN ARGNO=(FUNSPEC&B3B)>>16 %ELSEC ARGNO=FUNSPEC&X'FF'; ! GET NUMBER OF ARGS TRACE=(FUNSPEC&TRACEFLG)>>30 %IF TRACE=3 %THENSTART STRTRACE(FN,' .') DPRINTSTRING(' LOOKING FOR '.TOSTRING(ARGNO+48). %C ' INPUTS') NOOLINE(1) %FINISH WORK1=ARGNO %WHILE WORK1>0 %CYCLE; ! GATHER ARGS AND LEAVE ON STACK %IF IN=NIL %THENSTART ERROR(ERRMESS(2),FN,1,IN) %IF TRACE=3 %THEN INDENT=INDENT-2 %ANDC BYTEINTEGER(ADDR(PARSPR))=INDENT %RETURN %FINISH EVAL(10,IN,EACHVAL,WALKFN) %IF JUMPFLAG=1 %THENSTART %IF TRACE=3 %THEN INDENT=INDENT-2 %ANDC BYTEINTEGER(ADDR(PARSPR))=INDENT %RETURN %FINISH WORK1=WORK1-1 %REPEAT %IF TYPE=SYSPRE %THENSTART ->SYSTR(TRACE) SYSTR(3):INDENT=INDENT-2; BYTEINTEGER(ADDR(PARSPR))=INDENT SYSTR(2):STRTRACE(FN,' >') %IF ARGNO#0 %THENSTART DPRINTSTRING(' HAS ') %CYCLE WORK1=1,1,ARGNO DPRINTSTRING('INPUT'.TOSTRING(WORK1+48).' = ') PRINTEL(STK(STKPNT+WORK1-ARGNO)) DPRINTSTRING(', ') %REPEAT %FINISH NOOLINE(1) ->SYSTR(0) SYSTR(1):STRTRACE(FN,' >') NOOLINE(1) SYSTR(0):APPLYSYS(FUNSPEC&B2,FN,IN,EACHVAL) %IF JUMPFLAG=1 %THENSTART %IF TRACE>0 %THEN INDENT=INDENT-2 %ANDC BYTEINTEGER(ADDR(PARSPR))=INDENT %RETURN %FINISH %FINISHELSESTART FUNLIST=FUNSPEC&M16!LM; ! FUN NOW HAS USER DEF AS LIST PARMLIST=TL(TL(TL(HD(FUNLIST)))); ! PARAMETRS PARMLIST=REVQUOTE(PARMLIST) %UNLESS PARMLIST=NIL; ! REVERSE ORDER %IF JUMPFLAG=1 %THENSTART %IF TRACE=3 %THEN INDENT=INDENT-2 %ANDC BYTEINTEGER(ADDR(PARSPR))=INDENT %RETURN %FINISH %IF FUNLIST=WALKFN %AND TRACE#3 %THEN ->USRTR(2) ->USRTR(TRACE) USRTR(3):INDENT=INDENT-2 BYTEINTEGER(ADDR(PARSPR))=INDENT USRTR(2):STRTRACE(FN,' >') %IF ARGNO#0 %THENSTART DPRINTSTRING(' HAS ');WORK1=PARMLIST; WORK2=NIL %WHILE WORK1#NIL %CYCLE WORK2=CONS(HD(WORK1),WORK2) WORK1=TL(WORK1) %REPEAT %WHILE ARGNO#0 %CYCLE PRINTEL(HD(WORK2));DPRINTSTRING(' = ') PRINTEL(STK(STKPNT+1-ARGNO));DPRINTSTRING(', ') WORK2=TL(WORK2); ARGNO=ARGNO-1 %REPEAT %FINISH NOOLINE(1) ->USRTR(0) USRTR(1):STRTRACE(FN,' >'); NOOLINE(1) USRTR(0):STKSYS(IN);STKSYS(VAL); %IF APPUCNT=APPULIM %THENSTART ERROR(ERRMESS(32),APPULIM<<8!NM,1,IN) %IF TRACE>0 %THEN INDENT=INDENT-2 %ANDC BYTEINTEGER(ADDR(PARSPR))=INDENT %RETURN %FINISH APPLYUSR(MAKEBIND(PARMLIST,ENVIR,FN),FUNLIST,TSTFLG,VAL,SEVERITY, %C WALKFN) VAL=UNSTKSYS;IN=UNSTKSYS %IF JUMPFLAG=1 %THENSTART %IF TRACE>0 %OR FUNLIST=WALKFN %THEN INDENT=INDENT-2 %ANDC BYTEINTEGER(ADDR(PARSPR))=INDENT %RETURN %FINISH %IF FUNLIST=WALKFN %THEN ->OUTR(2) %FINISH ->OUTR(TRACE) OUTR(2):OUTR(3):ENDTRACE(FN) WORK1=STK(STKPNT) DPRINTSTRING(' WITH ') %IF WORK1&LM=LM %AND WORK1#NIL %AND HD(WORK1)=QQPROC %THENC DPRINTSTRING('NO RESULT') %ELSESTART DPRINTSTRING('RESULT = ') PRINTEL(WORK1) %FINISH NOOLINE(1) ->OUTR(0) OUTR(1):ENDTRACE(FN); NOOLINE(1) OUTR(0): %FINISHELSESTART; ! FINISH PREFIX. START 6 %IF TYPE=INTERP %THENSTART APPLYSYS(FUNSPEC&B2,FN,IN,EACHVAL) %IF JUMPFLAG=1 %THENRETURN %FINISHELSESTART; ! START 7 %IF TYPE=INFIX %THENSTART; ! MISPLACED INFIX ERROR(ERRMESS(49),FN,1,IN) %RETURN %FINISHELSESTART ERROR('ERROR IN FN TYPE FOR EVAL',EMPTY,1,IN) %RETURN %FINISH %FINISH; ! FINISH 7 %FINISH; ! FINISH 6 %FINISH; ! FINISH 5 %FINISH; ! FINISH 4 %FINISH; ! FINISH 3 %FINISH; ! FINISH 2 %FINISH; ! FINISH 1 ! ! ! INFIX LOOP INLP:%IF IN=NIL %THENRETURN; ! LINE EMPTY FN=HD(IN) %IF FN&WM#WM %THENRETURN; ! NOT A WORD-IE NUMBER OR LIST FUNSPEC=FNVAL(FN>>8); ! GET FUNCTION DEF %IF FUNSPEC=0 %THENRETURN; ! NOT DEFINED AS A FUNCTION TYPE=FUNSPEC&B4; ! FUNCTION DEFINED-GET TYPE %IF TYPE#INFIX %THENRETURN; ! TYPE NOT INFIX NEXTPREC=(FUNSPEC&B3B)>>16; ! INFIX FUN-GET PRECEDENCE %IF NEXTPREC<=PREC %THENRETURN; ! NEXT PRECECENCE LOWER THAN CURRENT IN=TL(IN) %IF IN=NIL %THENSTART ERROR(ERRMESS(18),FN,1,IN) %RETURN %FINISH TRACE=(FUNSPEC&TRACEFLG)>>30 %IF TRACE=3 %THENSTART STRTRACE(FN,' .') DPRINTSTRING(' LOOKING FOR SECOND INPUT') NOOLINE(1) %FINISH EVAL(NEXTPREC,IN,EACHVAL,WALKFN) %IF JUMPFLAG=1 %THENSTART %IF TRACE=3 %THEN INDENT=INDENT-2 %ANDC BYTEINTEGER(ADDR(PARSPR))=INDENT %RETURN %FINISH ->INFTR(TRACE) INFTR(3):INDENT=INDENT-2;BYTEINTEGER(ADDR(PARSPR))=INDENT INFTR(2):STRTRACE(FN,' >') DPRINTSTRING(' INPUT1 = ');PRINTEL(STK(STKPNT-1)) DPRINTSTRING(', INPUT2 = ');PRINTEL(STK(STKPNT)) NOOLINE(1); ->INFTR(0) INFTR(1):STRTRACE(FN,' >');NOOLINE(1) INFTR(0):APPLYSYS(FUNSPEC&B2,FN,IN,EACHVAL) %IF JUMPFLAG=1 %THENSTART %IF TRACE>0 %THEN INDENT=INDENT-2 %ANDC BYTEINTEGER(ADDR(PARSPR))=INDENT %RETURN %FINISH ->INFOUTR(TRACE) INFOUTR(3):INFOUTR(2):ENDTRACE(FN) DPRINTSTRING(' WITH RESULT = ') PRINTEL(STK(STKPNT));NOOLINE(1);->INLP INFOUTR(1):ENDTRACE(FN);NOOLINE(1) INFOUTR(0): ->INLP %END; ! END EVAL ! %INTEGER V EVAL(PREC,IN,UNDEF,WALKFN) V=UNSTACK %IF V&LM=LM %AND V#NIL %ANDC (HD(V)=QQPROC %OR HD(V)=QQRESULT) %THEN STACK(V) %ELSEC ERROR2(V) %ANDRETURN %IF JUMPFLAG=1 %THENRETURN %IF IN#NIL %THEN ERROR(ERRMESS(1),IN,1,IN) %END; ! END EVALAPPL ! ! %ROUTINE APPLYUSR(%INTEGER ENVIR,FUN,TSTFLG,VAL, %C %INTEGERNAME SEVERITY,WALKFN) %INTEGER IN,CURFUN,SAVESTK,STEP,TYPEIN APPUCNT=APPUCNT+1 SAVESTK=STKPNT CURFUN=FUN STEP=1 %WHILE TL(CURFUN)#NIL %CYCLE %IF STEP=NXTSTP %AND WALKFN=FUN %THENSTART DPROMPT(' S:') TYPEIN=READLINE STKSYS(CURFUN); CURFUN=CONS(TYPEIN,NIL) EVALAPPL(0,ENVIR,FUN,CURFUN,TYPEIN,TSTFLG,VAL,SEVERITY,WALKFN) CURFUN=UNSTKSYS %FINISHELSESTART CURFUN=TL(CURFUN) IN=TL(HD(CURFUN)); ! NEXT LINE WITHOUT NUMBER STEP=STEP+1 EVALAPPL(0,ENVIR,FUN,CURFUN,IN,TSTFLG,VAL,SEVERITY,WALKFN) %IF WALKFN=FUN %AND JUMPFLAG#1 %THENC SPACES(INDENT) %AND PRINTLINE(HD(CURFUN)) %FINISH %IF JUMPFLAG=1 %THENSTART; ! RETURN FROM USERINT OR ERROR %IF SENDFLAG>1 %THENSTART SENDFLAG=SENDFLAG-1 APPUCNT=APPUCNT-1 %RETURN %FINISHELSESTART %IF SENDFLAG=1 %THENSTART SENDFLAG=0 JUMPFLAG=0 VAL=UNSTACK; ! VALUE SENT BACK STKPNT=SAVESTK; ! RESET STACK STACK(VAL) APPUCNT=APPUCNT-1 %RETURN %FINISH; ! SENDFLAG=1 %FINISH; ! SENDFLAG NOT >1 APPUCNT=APPUCNT-1 %RETURN; ! SENDFLAG=0 %FINISH; ! JUMPFLAG=1 VAL=UNSTACK %REPEAT %IF VAL&LM=LM %AND HD(VAL)=QQPROC %THENC STACK(CONS(QQPROC,CONS(HD(TL(TL(HD(FUN)))),NSRTAIL))) %ELSEC STACK(HD(TL(VAL))); ! [??RESULT VALUE] FROM RESULT OR OUTPUT APPUCNT=APPUCNT-1 %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 %PRINTTEXT'WORD AREA';NEWLINE %PRINTTEXT' INDEX WORD BASE VALUE ' %PRINTTEXT'FNTYPE FNSWITCH FNARGNO/PREC LIST INDEX'; NEWLINE %CYCLE I=0,1,1022 %IF WA(I)='?' %THEN ->REP %ELSESTART WRITE(I,5);SPACES(2) PRINTSTRING(WA(I));SPACES(9-LENGTH(WA(I)));DUMPITEM(BVALUE(I)) SYSVAL=FNVAL(I) WRITE(TYPE,10) %IF TYPE#8 %THENSTART WRITE(SWITCH,10) %IF TYPE#4 %THEN WRITE(ARGNO,14) %FINISHELSESTART SPACES(11) WRITE(SYSVAL&X'FF',14) SPACES(2) PRINTSTRING('L') WRITE(SYSVAL<<8>>16,4) %FINISH NEWLINE %FINISH REP:%REPEAT NEWLINE %PRINTTEXT'LIST AREA';NEWLINES(2) %PRINTTEXT'FUNCTION SPACE';NEWLINE %IF LPOINT1=LISTOP %THENSTART;%PRINTTEXT'NO NEW FNSPACE';NEWLINE ->SEMISP;%FINISH %CYCLE I=LISTOP,1,LPOINT1-1 WRITE(I,5);SPACES(2) DUMPITEM(LA(I)) NEWLINE %REPEAT NEWLINE LISTOP=LPOINT1 SEMISP:%PRINTTEXT'CURRENT SEMISPACE';NEWLINE %IF LPOINT=LABASE %THENSTART;%PRINTTEXT'NO LIST SPACE';NEWLINE ->ENV;%FINISH %CYCLE I=LABASE,1,LPOINT-1 WRITE(I,5);SPACES(2) DUMPITEM(LA(I)) NEWLINE %REPEAT NEWLINE ENV:%PRINTTEXT'LOCAL ENVIRS';NEWLINE %IF TOPMARK=1022 %THENSTART %PRINTTEXT'NO LOCALS' ;NEWLINE %FINISHELSESTART %CYCLE I=1023,1,TOPMARK WRITE(BNAME(I)>>8,5);SPACES(2) DUMPITEM(BVALUE(I)) NEWLINE %REPEAT %FINISH NEWLINE %PRINTTEXT'USER STACK' NEWLINE %IF STKPNT=0 %THENSTART %PRINTTEXT'STACK EMPTY' NEWLINE %FINISHELSESTART %CYCLE I=STKPNT,-1,1 WRITE(I,5) SPACES(2) PRINTEL(STK(I)) NEWLINE %REPEAT %FINISH SELECTOUTPUT(0) PRSTRING('DUMPED');NOOLINE(1) %END; ! END DUMP ! ! %ROUTINE INITIALISE %INTEGER I %STRING(64) IN %ROUTINE GETFUNS %STRING(64) NAME %INTEGER SYSVAL %INTEGER FNAME %BYTEINTEGERNAME TYPE,ARGNO %SHORTINTEGERNAME SWITCH TYPE==BYTEINTEGER(ADDR(SYSVAL)) ARGNO==BYTEINTEGER(ADDR(SYSVAL)+1) SWITCH==SHORTINTEGER(ADDR(SYSVAL)+2) LP:READSTRING(NAME) %IF NAME='ENDPROCS' %THENRETURN SYSVAL=0 READ(TYPE) READ(SWITCH) %IF TYPE#4 %THEN READ(ARGNO) FNAME=HASH(NAME) OWNFUNS=CONS1(FNAME,OWNFUNS); ! LIST OF FNAMES IN PERM SPASE FNVAL(FNAME>>8)=SYSVAL ->LP %END; ! END GETFUNS ! ! EUNAD=COMREG(16); ! ADDRESS OF USER NAME START EUNBYTE(1)=6 %CYCLE I=2,1,7 EUNBYTE(I)=BYTEINTEGER(EUNAD+I-2) %REPEAT EMASUSER==STRING(ADDR(EUNBYTE(1))); ! USER NAME AS STRING %CYCLE I=0,1,1022 BVALUE(I)=0 FNVAL(I)=0 OLDFN(I)=0 WA(I)='?' %REPEAT SPACE4=' ' QUOTEON=0 HASHVAL==INTSTR(2) WORK1==STRING(ADDR(INTSTR(2))-1) LBRAK==SPECHAR(13) RBRAK==SPECHAR(14) TDEV=0 ADDRBINBUFF=ADDR(BINBUFF(1)) BINARG1==SHORTINTEGER(ADDRBINBUFF+3) BINARG2==SHORTINTEGER(ADDRBINBUFF+5) BINARG3==SHORTINTEGER(ADDRBINBUFF+7) BINARG4==SHORTINTEGER(ADDRBINBUFF+9) BINARG5==SHORTINTEGER(ADDRBINBUFF+11) DEVICE=TTY DFILE(1)=NL DPNT=1 CHAROUT=0 HASH1023=0 HASH1024=0 INDENT=1 PARSPR=' ' PRNUM=0 APPUCNT=0 APPULIM=200 STKPNT=0 STKTOP=0 SYSTKPNT=0 JUMPFLAG=0 JUMPOUT=0 SENDFLAG=0 QUITFLAG=0 HOLDFLAG=0 LPOINT=LA1B LABASE=LA1B LPOINT1=LAFNB LISTOP=LAFNB SEMISIZE=LA2B-LA1B CLECTFLG=0 TOPMARK=1022 BASENVIR=1022 NUMTOP=2**23-1 NUMBOT=-2**23+1 EVALIMIT=10000 BORROWLOAD=0 BORROWFLAG=0 ENUF=0 SEP='' FULLFLAG=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) RETITLE==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) QQPROC==NAMES(55) DEFINEWORD==NAMES(56) QQRESULT==NAMES(57) INSERT==NAMES(58) NULL==NAMES(59) UNPARSE==NAMES(60) 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 NSRTAIL=CONS1(NAMES(61),NIL) GETID=CONS1(NAMES(62),NIL) %CYCLE I=0,1,1022 ASSOCWA(I)=NIL %REPEAT OWNFUNS=NIL GETFUNS %CYCLE I=1,2,15 SETVAL(NAMES(I),NAMES(I+1),BASENVIR); ! INITVALS %REPEAT INITINF SETVAL(THINKALOUD,TRUE,BASENVIR) NEWFN=NIL DEFINED=NIL LOGOTIME=TIME100 NXTSTP=NUMTOP SELECTINPUT(0) CLOSESTREAM(2);CLEAR('ST02') ! !******* 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,FLAG) %INTEGER VAL,IN,FUN,CURFUN,TSTFLG VAL=UNDEF CURMODE = NORMAL IN=NIL FUN=NIL CURFUN=NIL TSTFLG=0 PRNUM=PRNUM+1 ! PROMPT A NUMBER WHEN REENTERING OF LOGO RECURSIVELY ! NOT IMPLEMENTED IN THIS VERSION ! PROMP=NUMTOSTR(PRNUM<<8).':' PROMP='W: ' DPROMPT(PROMP) %IF FLAG=1 %THENSTART IN=GETID ->LP1 %FINISH LP: %IF TDEV = 8 %THEN SET42(CHTXT) IN=READLINE LP1:EVALCNT=0 EVALAPPL(0,ENVIR,FUN,CURFUN,IN,TSTFLG,VAL,SEVERITY,UNDEF) %IF SENDFLAG>0 %THENSTART; ! GO BACK TO APPLYUSR %IF PRNUM>1 %THENSTART; ! NOT AT BASE LEVEL PRNUM=PRNUM-1 PROMP=NUMTOSTR(PRNUM<<8).':' DPROMPT(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).':' DPROMPT(PROMP) %RETURN %FINISH %IF JUMPOUT>0 %THENSTART; ! USER ABORT OR QUIT JUMPOUT=JUMPOUT-1 STACK(VAL) PRNUM=PRNUM-1 PROMP=NUMTOSTR(PRNUM<<8).':' DPROMPT(PROMP) %RETURN %FINISH %FINISH; ! FINISH PRNUM#1 JUMPFLAG=0; ! EITHER PRNUM=1 OR PRNUM#1 AND JUMPOUT=0 JUMPOUT=0 %FINISH; ! FINISH JUMPFLAG=1 ->LP %END; ! END LOGO ! ! ! %BEGIN I=ADDR(RR(4)); ! ADDR OF RECOVERY INFO SAVE AREA K=ADDR(SAVE(1)); ! ADDR OF USER DUMP SAVE AREA *L_1,I *STM_ 4,14,0(1); ! SAVE ENVIR IN RECOVERY AREA *LA_2,; ! ADDR OF ENTRY POINT ON CONTINGENCY *ST_2,44(1); ! INTO RECOVERY AREA *MVI_44(1),8; ! SET PROGRAM MASK FOR INTEGER OFLOW SIGNAL(0,I,0,FLAG); ! STACK RECOVERY INFO *LA_11,2048(11); ! INC STACK POINTER TO LEAVE HOLE TO BE ! USED ON CONTINGENCY ! ! MAIN PROG STARTS ! %IF STATUS('LOGODRIB',0)>=0 %THEN CRASHDRI; ! DRIBBLE FROM CRASH NEWSMFILE('LOGODRIB,50008') DEFINE('SM11,LOGODRIB') FSTART=SMADDR(11,FLENGTH) DPNT==INTEGER(FSTART) DFILE==ARRAY(FSTART+8,DF) NEWSMFILE('LOGOSTK,376831') DEFINE('SM06,LOGOSTK') FSTART=SMADDR(6,FLENGTH) FNVAL==ARRAY(FSTART,INTFORM1); ! INTEGERARRAY(0:1022) OLDFN==ARRAY(FSTART+4092,INTFORM1) SYSTK==ARRAY(FSTART+8184,INTFORM2); ! INTEGERARRAY(1:2000) LA==ARRAY(FSTART+16184,INTFORM3);! INTEGERARRAY (1:65536) BNAME==ARRAY(FSTART+278328,INTFORM4); ! INTEGERARRAY(1023:3000) BVALUE==ARRAY(FSTART+286240,INTFORM5); ! INTEGERARRAY(0:3000) ASSOCWA==ARRAY(FSTART+298244,INTFORM1) STK==ARRAY(FSTART+302336,INTFORM2) WA==ARRAY(FSTART+310336,SFORM1); ! STRING(64)ARRAY (0:1022) DEFINE('SM05,'.MASNUM.'LOGERRS') FSTART=SMADDR(5,FLENGTH) ERRMESS==ARRAY(FSTART,SFORM2); ! STRING(255)ARRAY(1:150) DEFINE('ST02,'.MASNUM.'ELGNAM30') INITIALISE DEFINE('ST01,DUMPFILE') DNEWLINE DNEWLINE DPRINTSTRING('ELOGO - VERSION 3.0 '.DATE.' '.TIME) LIST(MASNUM.'LOGINTRO') DNEWLINE DNEWLINE LOGO(STKTOP,BASENVIR,0,1) ! ! RECOVERY ENTRY ERROR: *ST_1,ADUMP; ! USER DUMP ADDRESS *ST_2,WT; ! WEIGHT OF INTERRUPT *ST_3,R3 MOVE(104,ADUMP,K); !SAVE USER DUMP AREA IN CASE OF ANOTHER INT %IF WT=128 %THENSTART; ! CONSOLE INT INTCHAR==STRING(ADDR(R3)) %IF INTCHAR='Q' %THENSTART DRIBBLE(INTQ) QUITFLAG=1 ->RESUME %FINISH %IF INTCHAR='H' %THENSTART DRIBBLE(INTH) HOLDFLAG=1 ->RESUME %FINISH SIGNAL(4,I,0,FLAG); ! PASS TO OUTER LEVEL %FINISH %IF WT=132 %THENSTART; ! TIME EXCEEDED GETTIM(TIMELIM); ! REQUEST ANOTHER ALLOACTION %IF TIMELIM=0 %THENSTART; ! RATE EXCEEDED. NO MORE TIME DPRINTSTRING(ERRMESS(52)) NOOLINE(2) QUITFLAG=1; ! SIMULATE INT Q %FINISH %FINISHELSE SIGNAL(4,I,0,FLAG) RESUME:I=ADDR(RR(4)) *L_1,I *STM_4,14,0(1) *LA_2, *ST_2,44(1) *MVI_44(1),8 SIGNAL(0,I,0,FLAG); ! RESTACK RECOVERY INFO SIGNAL(5,K,0,FLAG); ! GO BACK TO USER ENVIR %END %ENDOFPROGRAM