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