%BEGIN
!
! CHANNEL USAGE
! ST01 - DUMPFILE AND DRIBBLE AT GOODBYE
! ST02 - ELGNAM
! SM04 - OWNFILE
! SM05 - LOGERRS
! SM06 - LOGOSTK
! SM07 - LOGOMON
! SM08 - BFILE
! SM09 - LOGMASTR
! SM10 - LOGOTEMP
! SM11 - LOGODRIB
! SM12 - NEW LOGON IN EDITMASTER
! ST13 - SHOWFILE?
!
!*****************************************
! GRAPHICS LINKAGE
!*****************************************
!
%EXTERNALINTEGERFNSPEC CONV (%INTEGER X)
%EXTERNALROUTINESPEC VECORPOINT (%INTEGER I,J,K,L)
%EXTERNALROUTINESPEC PAUSE
%EXTERNALROUTINESPEC LOAD42 (%STRING(63) FILE)
%EXTERNALROUTINESPEC SET42 (%INTEGER NM)
%EXTERNALROUTINESPEC CLEAR 42
%EXTERNALROUTINESPEC CH3 (%INTEGER CHAR)
%EXTERNALROUTINESPEC MODE42 (%INTEGER N)
%EXTERNALROUTINESPEC LBR
%EXTERNALROUTINESPEC RBR ;! PARENTHESIS
%CONSTINTEGER INIT GRAPHP = X'202E' ;! START OF DISPLAY SPACE
!
%EXTRINSICINTEGER GRAPHP42
%EXTRINSICINTEGER CUR42 MODE
%EXTRINSICINTEGER DDATA,DSTART,DLAST,GRAPHP ;!POINTERS TO GT42 CORE
%EXTRINSICINTEGER VECTORM,POINTM,CHARM ;!EMAS GT42 EXEC INSTRUCTIONS
%EXTRINSICINTEGER BLEEP,CHTXT,CHPIC,GRADV,ADD2,SET,ADD1, %C
SETN,WAIT,PMOV,CLR,ACK
;!GT42 EXEC INSTRUCTIONS
!
%OWNINTEGER PEN = X'4000', NORMAL= X'9E54',DJUMP=X'E000',FRAMETIME=50
%CONSTINTEGER CORE BOTTOM = X'3FF0'
%CONSTINTEGER CALL=0, POSNAT=X'C000',LINETO=X'8000'
%INTEGER TEXTFLAG,GMODE,CURPIC,CURMOVIE,CURFRAME,DEF PICTURE, %C
CURMODE,FRAMEFLAG,GRABLIST,PICTURE POINTER
%CONSTINTEGER TURTLE START=X'201A'
%CONSTSTRING (17) GT42 EXEC = 'ESAV01.EXEC26'
%OWN %INTEGER SHOW TURTLE 42 = 1
!
! MOVIE AREA
!
%RECORDFORMAT PICDIR(%INTEGER PTR,PTR42,X,Y,FADDR,MOVED %C
,MODE,LAST MOVE TIME)
%OWNRECORDARRAY INDEX42( 0:1022) (PIC DIR)
%STRING(10) SAVE PROMP
%OWNINTEGER CAPFLAG = 0 ;! USED TO GENERATE CAPTIONS
!
!
!
%INTEGER XCRANE, YCRANE, HDCRANE
%CONSTINTEGER CRANE MARK = X'000F0000', CRANE MASK = X'FFFF0000'
!***************************************************
%EXTERNALROUTINESPEC OBEYFILE(%STRING(63) S)
%EXTERNALROUTINESPEC DISCONNECT(%STRING(63) S)
%EXTERNALROUTINESPEC CLOSESM(%INTEGER CH)
%SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N)
%SYSTEMROUTINESPEC FINFO(%STRING(15) S,%INTEGER LEV,%C
%RECORDNAME R, %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC MOVE(%INTEGER LENGTH,FROM,TO)
%EXTERNALSTRINGFNSPEC DATE
%EXTERNALROUTINESPEC LIST(%STRING(63) S)
%EXTERNALROUTINESPEC SEND(%STRING(63) S)
%EXTERNALSTRINGFNSPEC TIME
%EXTERNALLONGREALFNSPEC CPUTIME
%EXTERNALINTEGERFNSPEC SMADDR(%INTEGER CHANN,%INTEGERNAME LENGTH)
%EXTERNALROUTINESPEC DEFINE(%STRING (65) S)
%EXTERNALROUTINESPEC PERMIT FILE(%STRING (65) S)
%EXTERNALROUTINESPEC NEWSMFILE(%STRING (63) S)
%EXTERNALROUTINESPEC CHERISH(%STRING (63) S)
%EXTERNALROUTINESPEC PROMPT(%STRING(15) M)
%EXTERNALROUTINESPEC DESTROY(%STRING(65) S)
%EXTERNALROUTINESPEC CLOSESTREAM(%INTEGER CH)
%EXTERNALREALFNSPEC RANDOM (%INTEGERNAME I,%INTEGER J)
%EXTERNALINTEGERFNSPEC TESTINT(%INTEGER C,%STRING(15) INT)
%EXTERNALROUTINESPEC CLEAR(%STRING(65) S)
%EXTERNALROUTINESPEC CRASHDRI
%ROUTINESPEC BADERROR(%STRING(80) ERRMESS,%INTEGER CULPRIT)
%ROUTINESPEC APPLYUSR(%INTEGER ENVIR,FUN,TSTFLG,VAL,%C
%INTEGERNAME SEVERITY,WALKFN)
%ROUTINESPEC NOOLINE(%INTEGER N)
%ROUTINESPEC PRSTRING(%STRING(255) WORD)
%INTEGERFNSPEC UNSTACK
%ROUTINESPEC PRINTLIST(%INTEGER LIST)
%ROUTINESPEC PRINTEL(%INTEGER I)
%INTEGERFNSPEC HD(%INTEGER LIST)
%INTEGERFNSPEC TL(%INTEGER LIST)
%ROUTINESPEC PRINTLINE(%INTEGER LINE)
%INTEGERFNSPEC READLINE
%ROUTINESPEC LOGO(%INTEGER STKTOP,ENVIR,SEVERITY,FLAG)
%ROUTINESPEC DUMP(%STRING(80) ERRMESS)
%INTEGER FLENGTH,FSTART; ! FOR WORKSPACE MAPPING
%INTEGER EUNAD; ! FOR ADDTESS OF EMAS USER NAME
%BYTEINTEGERARRAY EUNBYTE(1:7); ! USERNAME
%STRING(6) %NAME EMASUSER; ! AS A STRING
!
!
!
! THE FOLLOWING DECLARATIONS ARE CONCERNED WITH TRAPPING TIME EXCEEDED
! AND RESETTING THE LOCAL TIME LIMIT, AND DEALING WITH CONSOLE INTS
%EXTERNALROUTINESPEC GETTIM(%INTEGERNAME I)
%SYSTEMROUTINESPEC SIGNAL(%INTEGER EP,PARM,EXTRA,%INTEGERNAME FLAG)
%SYSTEMROUTINESPEC SVC(%RECORDNAME P)
%RECORDFORMAT PARM(%SHORTINTEGER DEST,DUM1,%INTEGER DUM2,%C
DUM3,ARG1,ARG2,ARG3,ARG4)
%RECORD P(PARM)
%STRINGNAME INTCHAR
%OWNINTEGERARRAY SAVE(1:26)
%OWNINTEGERARRAY RR(4:15)
%OWNINTEGER I,K,FLAG,WT,ADUMP,TIMELIM,R3
!
! ERROR MESSAGE MAP
!
%STRINGARRAYNAME ERRMESS
%STRING(255)%ARRAYFORMAT SFORM2(1:150)
!
!
! WORD AREA AND NUMBER DECLARATIONS
!
%STRINGARRAYNAME WA
%STRING(64)%ARRAYFORMAT SFORM1(0:1022); ! WORD TABLE
%OWNINTEGER WM=1,NM=4; ! WORD MARKER,NUMBER MARKER
%OWNINTEGER T8=X'FF000000'
%INTEGER NUMTOP,NUMBOT; ! NUMBER RANGE DELIMITERS
%OWNINTEGER MAXINT=X'7FFFFFFF'
%OWNINTEGER RANSEED=50003
%STRING(64) %NAME WORK1
%INTEGER LOGOTIME
%INTEGERARRAY INTSTR(1:20)
%STRING(4) SPACE4
%INTEGERNAME HASHVAL,LBRAK,RBRAK,DOTS,EMPTY,UNDEF, %C
COMMA,QUOTE,LPAR,RPAR,MINUS,IF,THEN,ELSE,CLOSE,WHILE,%C
TRUE,FALSE,END,DELETE,UNDO,UNDOS,TO,DO,ERR,LOGONAME,%C
LANGBRKS,RANGBRKS,QUIT,BREAK,SPACE1,TAB,ENEL,QQPROC,RETITLE,%C
QQRESULT,DEFINEWORD,INSERT,NULL,UNPARSE
%INTEGER NSRTAIL; ! NO SPECIAL RESULT TEXT AS LIST
%INTEGER OWNFUNS; ! LIST OF OWN PROCS
%INTEGER GETID; ! WHO ARE YOU TRIGGER LIST
%INTEGERARRAY NAMES(1:100); ! CONTAINS HASHED VALUES OF
! SPECHARS AND RESERVED NAMES
%OWNINTEGERARRAY SPECHAR(1:14)=':','<','>','"','(',')','*',
'+',',','-','/','=','[',']'
%INTEGER PRNUM
%STRING(23) PROMP
%STRING(15) DPROMP
%INTEGER EVALIMIT,EVALCNT,APPUCNT,APPULIM
!
! FUNCTION SPEC INFO IS HELD IN ARRAY FNVAL WHICH IS
! PARALLEL TO WA AND IS ACCESSED DIRECTLY USING
! WORD INDEX.
! EACH ENTRY IN FNVAL WILL BE ONE OF THE FOLLOWING....
!
! FNVAL ENTRY
! FUNCTION TYPE B4 B3 B2 B1
! 1) SYSTEM PREFIX TRACEFLAG/1 ARGNO SWITCH........
! 2) SYSTEM INFIX TRACEFLAG/2 PREC SWITCH........
! 3) SYSTEM INTERP 4 - SWITCH........
! 4) USER PREFIX TRACEFLAG/8 LA(INDEX) ARGNO
! 5) UNDEFINED 0 0 0 0
!
!
! FUNCTION SPEC AREA DECLARATIONS
!
%INTEGERARRAYNAME FNVAL,OLDFN,ASSOCWA
%INTEGERARRAYFORMAT INTFORM1 (0:1022)
! OLDFN HAS OLD FNVAL ENTRY WHEN FN REDEFINED.
! ASSOCWA HAS OBJECT ASSOCIATION POINTER INTO LIST SPACE.
! ASSOCWA USED ONLY BY MAKEASSOC,GETASSOC,AND REMASSOC
%OWNINTEGER SYSPRE=X'1000000',INFIX=X'2000000',INTERP=X'4000000',%C
USERPRE=X'8000000'
%INTEGER NEWFN,DEFINED
%OWNINTEGER B3B=X'7F0000',B2=X'FFFF',B4=X'3F000000',M16=X'FFFF00'
%OWNINTEGER TRACEFLG=X'C0000000',UNMASK=X'3FFFFFFF'
%OWNINTEGER TRACE1=X'40000000',TRACE2=X'80000000',PARSE=X'C0000000'
%INTEGER INDENT,NXTSTP
%STRING(255) PARSPR
!
! USER STACK DECLARATIONS
%INTEGERARRAYNAME STK
%INTEGER STKTOP,STKPNT
!
!
! SYSTEM STACK DECLARATONS
%INTEGERARRAYNAME SYSTK
%INTEGERARRAYFORMAT INTFORM2(1:2000)
%INTEGER SYSTKPNT
!
!
!
!
! LIST AREA DECLARATIONS
!
%INTEGERARRAYNAME LA
%INTEGERARRAYFORMAT INTFORM3(1:65536)
! ALL LIST STRUCTURE IS CONSTRUCED IN LA.
! LA IS DIVIDED INTO THREE PARTS. THE FIRST AND SECOND PARTS ARE
! USED AS THE TWO SEMISPACES FOR LISTS GENERATED BY THE USER AND BY
! THE INPUT READER. ONLY ONE SEMISPACE IS ACTIVE AT ONE TIME, THE
! COLLECTOR COPYING FROM ONE TO THE OTHER.
! THE THIRD PART IS USED FOR FUNCTION DEFINITIONS AND IS NEVER
! COLLECTED.
%OWNINTEGER LA1B=1,LA1T=24576,LA2B=24577,LA2T=49152,LAFNB=49153, %C
LAFNT=65536
! TOP AND BOTTOM VALUES OF VARIOUS LIST SPACES
%INTEGER CLECTFLG; ! GARBAGE COLLECT FLAG
%INTEGER LISTOP,LPOINT,LPOINT1,LABASE,SEMISIZE
! LPOINT IS FREE POINTER TO COLLECTABLE LIST AREA
! LPOINT1 IS FREE POINTER TO UNCOLLECTABLE AREA
! LABASE IS BASE OF CURRENT SEMISPACE
! SEMISIZE IS SIZE OF SEMISPACE
!
%REAL CFRACT; ! GARBAGE COLLECT WHEN CFRACT OF SPACE USED
%INTEGER QUOTEON,BLEVEL; ! USED BY LIST READER
%INTEGERNAME NIL
%STRING(1) SEP; ! USED BY PRINTER
%OWNSTRING(1) STERMIN='
'; ! NL ASSSTRING
%OWNINTEGER TERMIN='
'; ! NL AS SYMBOL
%INTEGER CHAROUT
%INTEGER ENUF
%OWNINTEGER LM=2
!
!
! ENVIRONMENT DECLARATIONS
!
%INTEGERARRAYNAME BNAME,BVALUE
%INTEGERARRAYFORMAT INTFORM4(1023:3000)
%INTEGERARRAYFORMAT INTFORM5(0:3000)
%INTEGER BASENVIR,TOPMARK
!
!
!
! INFERENCE SYSTEM DECLARATIONS
!
%INTEGERNAME FACTKEYS, INFKEYS, IMPKEYS, FACT, IMPLIES, TOINFER
%INTEGERNAME DATABASE,IMPRULES,INFRULES
!DATABASE,IMPRULES AND INFRULES ARE LOGO WORDS WHOSE
! BVALUES HOLD A LIST OF THE ASSERTED FACTS, IMPLIED RULES
! AND INFERRED RULES RESPECTIVELY.
! ALL INFERENCE RULES ARE ALSO HELD IN ASSOCIATIONS.
! FACTKEYS,IMPKEYS AND INFKEYS ARE LOGO WORDS WHOSE
! BVALUES HOLD LISTS OF THE NAMES OF ASSOCIATION
! SETS FOR FACTS, IMPLIED RULES AND INFERRED RULES RESPECTIVELY
! FACT, IMPLIES AND TOINFER ARE ATTRIBUTES WITHIN EACH
! ASSOCIATION SET
%INTEGERNAME THINKALOUD, NEW, VBL, NOT
! THINKALOUD IS A LOGO VARIABLE SET TO TRUE OR FALSE BY THE USER
%INTEGER GENOS
%INTEGERARRAY DBASE, IMPLINKS, INFLINKS(1:3)
! THE FIRST ELEMENT OF DBASE, IMPLINKS AND INFLINKS HOLDS
! THE LOGO WORD DATABASE, IMPRULES AND INFRULES RESPCTIVELY.
! THE 2ND ELEMENT CONTAINS THE LOGO WORD FACT, IMPLIES
! AND TOINFER RESPECTIVELY.
! THE 3RD ELEMENT HOLDS THE LOGO WORD FACTKEYS,IMPKEYS AND
! INFKEYS RESPECTIVELY.
!
!
!
! ERROR AND USER INTERUPPT RECOVERY
!
! ERROR RECOVERY IS CONTROLLED BY THREE FLAGS - JUMPFLAG,JUMPOUT
! AND SENDFLAG.
! JUMPFLAG=1 WITH SENDFLAG=0 TRIGGERS A SEQUENCE OF RETURNS FROM THE
! ERROR ROUTINE TO THE LAST ACTIVATION OF LOGO.
! RETURNS THRU LOGO TO EARLIER ACTIVATIONS IS CONTROLLED BY JUMPOUT
! IF JUMPOUT =0 NO RETURN PAST THE LAST ACTIVATION OCCURS. THIS IS THE
! CASE FOR SIMPLE ERRORS (IE OUTSIDE USER FUNS).
! IF JUMPOUT=-1 A NORMAL RETURN THRU THE LAST LOGO IS OBTAINED. THIS
! CAUSES THE LAST SUSPENDED PROCESS TO BE CONTINUED. JUMPOUT IS SET
! TO -1 BY LOGO FUN CONTINUE.
! IF JUMPOUT>0 ,THAT MANY LOGOS ARE RETURNED FROM. JUMPOUT IS SET
! TO N BY ABORT N, AND TO 100 BY QUIT.
! WHENEVER BASE LEVEL IS REACHED (WHEN PROMPT NUMBER IS 1), THE SETTING
! OF JUMPOUT IS IGNORED.
!
! JUMPFLAG=1 WITH SENDFLAG>0 TRIGGERS A SERIES OF RETURNS FROM THE
! ERROR ROUTINE TO THE LAST ACTIVATION OF APPLYUSR.
! RETURNS THRU APPLYUSR ARE CONTROLLED BY THE ACTUAL VALUE
! OF SENDFLAG, THAT MANY RETURNS BEING MADE. THIS IS USED TO SEND BACK
! A USER SUPPLIED VALUE AS THE RESULT OF A NAMED USERFN IN THE
! CURRENT NEST. SENDFLAG IS SET BY SENDBACK IN APPLYSYS.
!
!
%INTEGER JUMPFLAG,JUMPOUT,SENDFLAG
%INTEGER QUITFLAG,HOLDFLAG; ! USER INT FLAGS
!
!
! WORD AREA
!
!
! WORDS (EXCLUDING NUMBERS) ARE HELD UNIQUELY IN STRING ARRAY WA
! AND ARE REPRESENTED BY AN INTEGER CARRYING THE WORD MARKER AND THE
! INDEX IN WA.
! NUMBERS ARE REPRESENTED BY AN INTEGER CARRYING THE
! BINARY VALUE OF THE NUMBER IN THE TOP THREE BYTES AND THE
! NUMBER MARKER IN THE BOTTOM BYTE.
! FUNCTION PUT IS USED TO TRANSFORM WORDS INCLUDING NUMBERS
! TO INTERNAL FORM. IF THE WORD IS A NUMBER IT IS CONVERTED TO
! BINARY OTHERWISE IT IS HASHED.
! FUNCTION HASH PLACES A WORD INTO WA. AN OPEN HASH IS USED STARTING
! WITH A KEY GENERATD BY FUNCTION HASHFUN. THE KEY IS INCREMENTED
! WHEN NECESSARY BY 1, IN ORDER TO KEEP THE SEARCH AREA TO A PAGE
! OR SO.
!
!
!
!
! FILING SYTEM VARS
!
!
%RECORDFORMAT D (%STRING(63)PROCNAME,%INTEGER TEXTINDEX)
%RECORDARRAYFORMAT DIRFORM(1:603) (D)
%RECORDARRAYNAME DIR(D); ! DIRECTORY
%BYTEINTEGERARRAYFORMAT TEXTFORM(0:36864); ! 9 PAGESS WORTH
%BYTEINTEGERARRAYNAME TEXT
%SHORTINTEGERNAME DIRNUM,UNTIDY; ! NO OF DIRENTRIES AD UNTIDY FLAG
%SHORTINTEGERNAME WRITINGFILE,DIRPAGES; ! WRITEFLAG AND NO OF DIRPAGES
%INTEGERNAME NFTEXT; ! NEXT FREE TEXT INDEX
%INTEGER OWNFLENGTH,OWNFADDR; ! OWN FILE LENGTH AND START ADDRESS
%INTEGER BFLENGTH,BFADDR; ! DITTO BORROWED FILE
%STRING(15) OWNFILE,BFILE; ! FILE NAME OWN AND BORROWED
%INTEGER BORROWFLAG,BORROWLOAD,FULLFLAG
%OWNINTEGER PAGES=10; ! SIZE OF FILES
%OWNINTEGERARRAY PAGENTRIES(1:10)=60,120,180,240,300,361,421,481,
541,602; ! NO OF COMPLETE DIR ENTRIES IN 1,2,3 PAGES ETC
%INTEGER DEVICE,CURTEXT
%OWNINTEGER DISC=1,TTY=0
%STRING(64) USER,BORROWEE
!
%STRING(64)%ARRAYFORMAT USERFORM(1:99)
%INTEGERNAME MASENTS; ! NO OF MASTER DIR ENTRIES
%STRINGARRAYNAME USERIDS
!
%OWNSTRING(7) MASNUM='ESAV01.'
%OWNSTRING(20) MASNAME='MASTER '
%OWNSTRING(8)%ARRAY SYSFILES(1:4)='CRASHDRO','LOGALERT','LOGRECAL',
'EXEC26'
!
!
! SPECIAL OUTPUT DEVICE VARS
!
%INTEGER TDEV; ! DEVICE NUMBER ALLOCATED ELSE 0
%OWNSTRING(10)%ARRAY TDEVNAMES(1:8)='PLOTTERA','PLOTTERB','DISPLAY',%C
'TURTLE','TAPE','MUSIC','MECCANO','GT42'
%REAL XTURTLE,YTURTLE
%INTEGER HDTURTLE,PENTURTLE; ! TURTLE STATE
%OWNINTEGER HOOTBIT=X'8080',PENBIT=X'4000',FDBITS=X'2800',%C
BDBITS=X'1800',RTBITS=X'3800',LTBITS=X'800',PINDLBIT=X'1000',%C
PINDRBIT=X'4000'
%INTEGERNAME UP,DOWN; ! UP DOWN AS LOGO WORDS TO SET PENTURTLE
%BYTEINTEGERARRAY BINBUFF(0:13); ! BUFFER FOR BINARY OUTPUT
%SHORTINTEGERNAME BINARG1,BINARG2,BINARG3,BINARG4,BINARG5
! EQUIVALENCED TO BINBUFF(4,6,8,ETC)
%INTEGER ADDRBINBUFF; ! ADDRESS PF BINBUFF(1)
!
! CODE INSERTED TO MONITOR HASHFN
! LOGO COMMAND HASHINFO
!
%SHORTINTEGERARRAY HASHINFO(0:1022)
%INTEGER HASH1023,HASH1024
!
! HASHINFO IS PARALLEL TO WA
! HASH1023 HOLDS TOTAL NO OF ACCESSES OF WA
! HASH1024 HOLDS TOTAL NO OF WORDS HASHED
!
%INTEGERFN HASH(%STRING(64) WORD)
%INTEGER WPOINT,FULLMARK,HASH
%STRING(64) W
!
%INTEGERFN HASHFUN
WORK1=SPACE4; ! FIRST FOUR CHARS OF WORD USED. FILL WITH SPACES
WORK1=WORD; ! IN CASE ACTUAL WORD LESS THAN FOUR
%RESULT=HASHVAL-1023*(HASHVAL//1023)
! HASHVAL IS EQUIVALENCED TO FIRST FOUR CHARS OF WORK1 IN INITIALISE
%END; ! END HASHFUN
!
FULLMARK=0; ! USED TO TELL IF TABLE FULL
WPOINT=HASHFUN; ! GENERATE KEY
HASH=WPOINT
LP:W=WA(WPOINT); ! RETRIEVE WORD AT KEY
HASH1023=HASH1023+1
%IF W='?' %THENSTART; ! NOT YET USED SO
WA(WPOINT)=WORD; ! PLACE WORD
HASHINFO(WPOINT)=HASH
HASH1024=HASH1024+1
%RESULT=WPOINT<<8!WM; ! AND RETURN INDEX
%FINISH
%IF W=WORD %THENSTART
HASH1024=HASH1024+1
%RESULT=WPOINT<<8!WM; ! ALREADY ENTERED
%FINISH
WPOINT=WPOINT+1; ! NOT AT KEY POSITION SO INCREMENT
%IF WPOINT>1022 %THENSTART; ! TAKE MODULO AND CHECK FOR WA FUL
%IF FULLMARK=1 %THEN BADERROR('WORD AREA OVERFLOW',EMPTY) %C
%ELSESTART;
FULLMARK=1
WPOINT=0
%FINISH
%FINISH
->LP
%END; ! END HASH
!
!
%INTEGERFN PUT(%STRING(64) WORD)
! WORD IS A STRING OF ALPHANUMERIC CHARS ONLY
! IF THEY ARE ALL NUMERIC,THE STRING IS CONVERTED TO A NUMBER
! OTHERWISE THE WORD IS HASHED.
! A NEGATIVE NUMBER IN STRING FORM SHOULD NOT EXIST IN THE
! SYSTEM, BUT IN ANY CASE WOULD NOT BE CONVERTED TO A NUMBER HERE.
%INTEGER NUM,I,J,CHAR,TOOLONG
%BYTEINTEGERARRAY STRBYTE(0:64)
STRING(ADDR(STRBYTE(0)))=WORD
I=STRBYTE(0)
%IF I>7 %THEN TOOLONG=1 %ELSE TOOLONG=0
NUM=0; J=1
%IF WORD='' %THENRESULT=HASH(WORD);
%WHILE I>0 %CYCLE
CHAR=STRBYTE(I)
%IF 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 %THENRESULT=ERR
%RESULT=NUM<<8!NM
%END; ! END PUT
!
! SERVICE ROUTINES
!
!
!
%STRING(64)%FN NUMTOSTR(%INTEGER NUM)
! NUM WILL ALWAYS BE POSITIVE NUMBER IN STANDARD FORM AND IN
! RANGE. IT IS CONVERTED TO A STRING BUT IS NOT HASHED SICE
! THIS CONVERSION WILL ONLY BE CARRIED OUT BY CHAR FUNS PRIOR
! TO A CHAR MANIPULATION WHOSE RESULT WILL BE HASHED
%OWNINTEGERARRAY TENS(1:7)=1000000,100000,10000,1000,100,10,1
%INTEGER I,J,K,L,WIND,MARK
%BYTEINTEGERARRAY WORD(0:64)
WIND=1
MARK=0
NUM=NUM>>8
%CYCLE I=1,1,7
J=TENS(I)
K=J
L=0
%WHILE NUM>=K %CYCLE
K=K+J
L=L+1
MARK=1
%REPEAT
NUM=NUM-K+J
%IF MARK=1 %THENSTART
WORD(WIND)=L+48
WIND=WIND+1
%FINISH
%REPEAT
%IF WIND=1 %THENSTART; ! NUMBER WAS ZERO
WORD(WIND)=48
WIND=2
%FINISH
WORD(0)=WIND-1
%RESULT=STRING(ADDR(WORD(0)))
%END; ! END NUMTOSTR
!
%INTEGERFN STATUS(%STRING(15) FILENAME,%INTEGER LEVEL)
! FINDS CONNECT STATUS OF FILENAME
%RECORDFORMAT F(%INTEGER AD,SIZE,%BYTEINTEGER RUP,%C
EEP,MODE,CONS,ARCH,%STRING(6) TRANS,%SHORTINTEGER TYPE,%C
NPERMS,%INTEGER DST,DEND,PTR)
%RECORD R(F)
%INTEGER FLAG
FINFO('NOFILE',0,R,FLAG)
FINFO(FILENAME,LEVEL,R,FLAG)
%IF FLAG>0 %THEN %RESULT=-FLAG
%RESULT=R_CONS
%END; ! END STATUS
!
!
%ROUTINE BADERROR(%STRING(80) ERRMESS,%INTEGER CULPRIT)
%IF TDEV = 8 %THEN SET42(CHTXT)
NOOLINE(1)
PRSTRING(ERRMESS)
SPACE;PRINTEL(CULPRIT)
NOOLINE(1)
DUMP(ERRMESS)
%MONITORSTOP
%END; ! END BADERROR
!
%INTEGERFN TIME100
%LONGREAL X
X=CPUTIME
%RESULT=INT(CPUTIME*100)
%END; ! END TIME100
!
!
!
!
!
!
! LIST AREA AND LISTPRO PRIMITIVES
!
! LIST STRUCTURE IS HELD IN INTEGER ARRAY LA. A LIST IS REPRESENTED
! BY TWO ADJACENT ELEMENTS OF LA - THE FIRST POINTING TO THE HEAD
! THE SECOND POINTING TO THE TAIL. EACH ELEMENT CARRIES A MARKER
! IDENTIFYING IT AS A LIST ,A WORD OR A NUMBER.
! THE NULL LIST IS REPRESENTED BY A POINTER TO THE WORD 'NIL'
! IN THE WORD AREA.
! ABSOLUTE POINTERS ARE USED IN LA AND ARE THUS ALWAYS POSITIVE,
! A LIST IS ADDRESSED BY AN INTEGER CARRYING A LIST MARKER AND A
! POINTER TO ITS FIRST LA ELEMENT - I.E. ITS HEAD.
!
!
!
%INTEGERFN HD(%INTEGER LIST); ! RETRIIEVES HEAD OF LIST
%IF LIST&LM=0 %OR LIST=NIL %THEN BADERROR('NON-LIST ARG FOR HEAD - ',%C
LIST)
%RESULT=LA(LIST>>8)
%END; ! END HD
!
!
%ROUTINE REPHEAD(%INTEGER LIST,NEWHEAD); ! UPDATES HEAD OF LIST
%IF LIST&LM=0 %OR LIST=NIL%THEN BADERROR('NON-LIST ARG FOR REPHEAD',%C
LIST)
LA(LIST>>8)=NEWHEAD
%END; ! END REPHEAD
!
!
%INTEGERFN TL(%INTEGER LIST); ! RETRIEVES TAIL OF LIST
%IF LIST&LM=0 %OR LIST=NIL %THENC
BADERROR('NON-LIST ARG FOR TAIL - ',LIST)
%RESULT=LA(LIST>>8+1)
%END; ! END TL
%ROUTINE REPTAIL(%INTEGER LIST,NEWTAIL)
%IF LIST&LM=0 %OR LIST=NIL %THENC
BADERROR('NONLIST FIRST ARG FOR REPTAIL - ',LIST)
%IF NEWTAIL&LM=0 %THENC
BADERROR('NON-LIST SECOND ARG FOR REPTAIL - ',NEWTAIL)
LA(LIST>>8+1)=NEWTAIL
%END; ! END REPTAIL
!
!
%INTEGERFN CONS(%INTEGER X,LIST); ! CONSTRUCTS LIST WITH HEAD X
%INTEGER I; ! AND TAIL LIST
I=LPOINT
%IF LIST&LM=0 %THEN BADERROR('NON-LIST SECOND ARG FOR CONS - ',LIST)
LA(LPOINT)=X
LA(LPOINT+1)=LIST
LPOINT=LPOINT+2
%IF (LPOINT-LABASE)>CFRACT*SEMISIZE %THEN CLECTFLG=1
! SET COLLECT FLAG
%RESULT=I<<8!LM
%END; ! END CONS
!
%INTEGERFN CONS1(%INTEGER X,LIST)
! CONS1 COSTRUCTS LIST WITH HEAD X AND TAIL LIST IN UNCOLLECTABLE SPACE
! I.E. FUNCTION SPACE. IT IS IDENTICAL TO CONS EXCEPT THAT
! IT USES LPOINT1 INSTEAD OF LPOINT AS THE FREE POINTER
%INTEGER I
I=LPOINT1
%IF LPOINT1>=(LAFNT-1) %THEN BADERROR('FNSPACE OVERFLOW',EMPTY)
%IF LIST&LM=0 %THEN BADERROR('NON-LIST SECOND ARG FOR CONS1 - ',LIST)
LA(LPOINT1)=X
LA(LPOINT1+1)=LIST
LPOINT1=LPOINT1+2
%RESULT=I<<8!LM
%END; ! END CONS1
!
%INTEGERFN CONSG (%INTEGER X,LIST)
! PATCH ROUTINE FOR ADDING STANDARD
! EMAS NUMBERS TO LISTS
!
%RESULT=CONS(X<<8!NM,LIST)
%END
!
%INTEGERFN WITHOUT (%INTEGER ITEM,LIST)
! REMOVES 'ITEM' FROM 'LIST'
!
!
%RESULT=NIL %IF LIST=NIL
%RESULT=CONS(HD(LIST),WITHOUT(ITEM,TL(LIST))) %IF ITEM#HD(LIST)
%RESULT=WITHOUT(ITEM,TL(LIST)) ;! REMOVE ITEM
%END
%INTEGERFN AMONGQ (%INTEGER ITEM,LIST)
%RESULT=0 %IF LIST=NIL
%RESULT=1 %IF ITEM=HD(LIST)
%RESULT=AMONGQ(ITEM,TL(LIST))
%END
!
%INTEGERFN APPENDL (%INTEGER L1,L2)
! APPENDS L1 - L2
! SIMILAR TO
! *1: SENTENCE :L1 :L2
! WHERE L1 AND L2 ARE LISTS
!
! USED IN PICTURE FUNCTION 'CUT'
!
%INTEGER L3
L3 = NIL ;! CLEAR WORKSPACE
L3 = CONS(HD(L1),L3) %AND L1 = TL(L1) %WHILE L1 # NIL
;! REVERSE COPY L1 INTO L3
L2 = CONS(HD(L3),L2) %AND L3=TL(L3) %WHILE L3 # NIL
;! AND STICK ON FRONT OF L2
%RESULT = L2
%END
! GARBAGE COLLECTOR
!
! COLLECTION IS CARRIED OUT IF REQUIRED ON ENTRY TO EVAL
! WHEN MOST USER LIST STRUCTURE IS REFERENCED FROM THE USER STACK OR
! FROM THE ENVIRONMENT. WHERE NECESSARY, LIST REFERENCES FROM LOCAL
! IMP VARIABLES ARE TRANSFERRED TO THE SYSTEM STACK.
! COLLECTION INVOLVES ALTERING LABASE TO POINT TO THE BASE OF THE NEW
! SEMISPACEAND COPYING ALL ACTIVE LIST STRUCTURE TO THAT SEMISPACE.
!
%ROUTINE COLLECT(%INTEGER ENVIR)
%INTEGERNAME FREEPOINTER
%INTEGER STADDR,LEN
%INTEGER I,ITEM,USEDBEFORE,USEDAFTER,COLLECTED
!
%INTEGERFN GENCOPY(%INTEGER LIST)
! COPIES LIST STRUCTURE AS IS,INCLUDING CIRCULAR/BLAM LISTS.
! IT ALTERS THE STRUCTURE IT IS COPYING FROM AND SO MAY ONLY BE
! USED WITHIN THE GARBAGE COLLECTOR .
%INTEGER NEWLIST,HEAD,TAIL
%IF LIST&LM#LM %OR LIST=NIL %OR (LIST>>8)>=LAFNB %THENRESULT=LIST
! WORD,NUMBER OR LIST IN UNCOLLECTABLE SPACE
%IF HD(LIST)=-1 %THENRESULT=TL(LIST); ! ALREADY COPIED
HEAD=HD(LIST)
TAIL=TL(LIST)
NEWLIST=CONS(NIL,NIL); ! SPACE FOR COPY IN NEW SEMISPACE
REPHEAD(LIST,-1); ! INSERT COPY MARKER
REPTAIL(LIST,NEWLIST); ! INSERT ADDR OF COPY IN TAIL
REPTAIL(NEWLIST,GENCOPY(TAIL))
REPHEAD(NEWLIST,GENCOPY(HEAD))
%RESULT=NEWLIST
%END; ! END GENCOPY
!
!
USEDBEFORE=LPOINT-LABASE
%IF LABASE=LA1B %THEN LABASE=LA2B %ELSE LABASE=LA1B; ! FLIP SEMISPACE
LPOINT=LABASE; ! CONS NOW WORKS IN NEW SEMISPACE
%CYCLE I=0,1,BASENVIR
ITEM=BVALUE(I)
%IF ITEM#0 %THEN BVALUE(I)=GENCOPY(ITEM)
ITEM=ASSOCWA(I)
%IF ITEM#NIL %THEN ASSOCWA(I)=GENCOPY(ITEM)
%REPEAT
%IF ENVIR>BASENVIR %THENSTART
%CYCLE I=BASENVIR,1,ENVIR
BVALUE(I)=GENCOPY(BVALUE(I))
%REPEAT
%FINISH
%IF STKPNT>0 %THENSTART
%CYCLE I=1,1,STKPNT
STK(I)=GENCOPY(STK(I))
%REPEAT
%FINISH
%IF SYSTKPNT>0 %THENSTART
%CYCLE I=1,1,SYSTKPNT
SYSTK(I)=GENCOPY(SYSTK(I))
%REPEAT
%FINISH
NEWFN=GENCOPY(NEWFN)
DEFINED=GENCOPY(DEFINED)
!
! COLLECT PICTURE LIST AREA NOW
%CYCLE I = 0,1,1022
%IF INDEX42(I)_PTR # 0 %THEN INDEX42(I)_PTR=GENCOPY(INDEX42(I)_PTR)
%REPEAT
CURPIC = GENCOPY(CURPIC)
CURFRAME=GENCOPY(CURFRAME)
CURMOVIE=GENCOPY(CURMOVIE)
!
USEDAFTER=LPOINT-LABASE
%IF STATUS(MASNUM.'LOGOMON',0)>=0 %THENSTART
DEFINE('SM07,'.MASNUM.'LOGOMON')
STADDR=SMADDR(7,LEN)
FREEPOINTER==INTEGER(STADDR)
%IF FREEPOINTER+48>LEN %THEN ->CLOSE
STADDR=STADDR+FREEPOINTER
FREEPOINTER=FREEPOINTER+48
STRING(STADDR)=TIME.DATE
STRING(STADDR+19)=EMASUSER
INTEGER(STADDR+28)=USEDBEFORE
INTEGER(STADDR+32)=ENVIR-BASENVIR
INTEGER(STADDR+36)=STKPNT
INTEGER(STADDR+40)=SYSTKPNT
INTEGER(STADDR+44)=USEDAFTER
CLOSE:CLOSESM(7);CLEAR('SM07')
DISCONNECT(MASNUM.'LOGOMON')
%FINISH
CLECTFLG=0
COLLECTED=USEDBEFORE-USEDAFTER
%IF COLLECTED<100 %THEN BADERROR('TOO FEW LIST CELLS COLLECTED',%C
COLLECTED<<8!NM)
%END; ! END COLLECT
!
!
!
%INTEGERFN MOVE1(%INTEGER LIST)
! MOVE1 IS USED TO COPY LIST STRUCTURE CREATED BY THE READER IN
! COLLECTABLE SPACE TO UNCOLLECTABLE SPACE. NO CIRCULAR/BLAM LISTS
!
%INTEGERFN COPY(%INTEGER LIST)
%IF LIST&LM#LM %OR LIST=NIL %THENRESULT=LIST
%RESULT=CONS1(COPY(HD(LIST)),COPY(TL(LIST)))
%END; ! END COPY
!
%IF LIST&LM#LM %THEN BADERROR('NON-LIST ARG FOR MOVE1 - ',LIST)
%IF (LIST>>8)>=LAFNB %THENRESULT=LIST; ! ALREADY IN FNSPACE
%RESULT=COPY(LIST)
%END; ! END MOVE
!
%INTEGERFN REVERSE(%INTEGER LIST)
%INTEGER LIST1
LIST1=NIL
%WHILE LIST#NIL %CYCLE
LIST1=CONS(HD(LIST),LIST1)
LIST=TL(LIST)
%REPEAT
%RESULT=LIST1
%END; ! END REVERSE
!
!
!
!
!
!
! ENVIRONMENT
!
! VARIABLE BINDINGS ARE HELD AS (NAME,VALUE) PAIRS IN ARRAYS
! BNAME AND BVALUE. THE CURRENT ENVIRONMENT IS DEFINED BY ENVIR
! WHICH POINTS TO THE TOP OF THE LAST ENVIRONMEBT CREATED,
! OR IS EQUAL TO 1022 IF ONLY THE BASE ENVIRONMENT EXISTS.
! WHENEVER A LOGO FUN IS APPLIED, THE PARAMETER NAMES AND LOCAL
! NAMES ARE INSERTED IN A NEWLY CREATED ENVIRONMENT TOGETHER WITH
! A SINGLE DIAGNOSTIC RECORD (THE FIRST) WHICH HAS 0 AS ITS NAME
! COMPONENT.
! SUCH LOCAL ENVIRONMENTS ARE CREATED UPWARDS FROM 1023.
! BVALUE(0-1022) IS USED FOR THE BASE ENVIRONMENT VALUES.
! THIS PART OF BVALUE IS PARALLEL TO WA AND IS ACCESSED
! BY DIRECT APPLICATION OF THE WORD INDEX.
! BASENVIR IS USED TO REFER TO THE BASE ENVIR
! VARIABLE UNDEF CONTAINS A POINTER TO THE WORD 'UNDEF' IN THE WORD
! AREA.
! FUNCTION UNSTACK RETREIVES THE TOP ELEMENT FROM THE LOGO STACK.
! VARIABLE NIL POINTS TO THE EMPTY LIST-THE WORD 'NIL'.
! VARIABLE DOTS POINTS TO THE WORD ':'.
!
!
!
!
%INTEGERFN FINDBIND(%INTEGER NAME,ENVIR)
! FINDS A BINDING IN AN ENVIRONMENT. IF CALLED WITH ENVIR<=1022,ONLY
! THE GLOBAL ENVIRONMENT IS INTERROGATED.
LOCAL:%WHILE ENVIR>1022 %CYCLE
%IF BNAME(ENVIR)=0 %THENSTART; ! SKIP DIAGNOSTIC RECORD AT START
ENVIR=ENVIR-1
->LOCAL
%FINISH
%IF BNAME(ENVIR)=NAME %THENRESULT=ENVIR; ! FOUND IT
ENVIR=ENVIR-1
%REPEAT
NAME=NAME>>8; ! NOT LOCAL SO TRY GLOBAL
%IF BVALUE(NAME)=0 %THENRESULT=UNDEF %ELSERESULT=NAME
%END; ! END FINDBIND
!
!
%ROUTINE SETVAL(%INTEGER NAME,VALUE,ENVIR)
! UPDATES A BINDING IF ONE EXISTS,OTHERWISE CREATES A NEW GLOBAL BINDING
%INTEGER BINDING
BINDING=FINDBIND(NAME,ENVIR)
%IF BINDING=UNDEF %THENSTART; ! NOT YET DEFINED
BVALUE(NAME>>8)=VALUE; ! SO CREATE IT GLOBALLY
%FINISHELSE BVALUE(BINDING)=VALUE; ! ALREADY DEFINED SO UPDATE IT
%END; ! END SETVAL
!
!
%INTEGERFN GETVAL(%INTEGER NAME,ENVIR); ! RETRIEVES A BINDING
%INTEGER BINDING
BINDING=FINDBIND(NAME,ENVIR)
%IF BINDING=UNDEF %THENRESULT=UNDEF %ELSERESULT=BVALUE(BINDING)
%END; ! END GETVAL
!
!
%INTEGERFN SETBIND(%INTEGER PARMLIST,ENVIR)
! BINDS PARMATER NAMES AND ARGS IN NEW ENVIRONMENT
! PARAMETER NAMES ARE IN PARMLIST IN REVERSE ORDER.
! ARG VALUES ARE ON STACK
%WHILE PARMLIST#NIL %CYCLE
%IF ENVIR=3000 %THEN BADERROR('ENVIRONMENT OVERFLOW',EMPTY)
ENVIR=ENVIR+1
BNAME(ENVIR)=HD(PARMLIST)
BVALUE(ENVIR)=UNSTACK
PARMLIST=TL(PARMLIST)
%REPEAT
%IF ENVIR>TOPMARK %THEN TOPMARK=ENVIR; ! TOPMARK USED BY DUMP
%RESULT=ENVIR
%END; ! END SETBIND
!
%INTEGERFN MAKEBIND(%INTEGER PARMLIST,ENVIR,FNAME)
! MAKEBIND CREATES NEW LOCAL ENVIRONMENT INSERTING DIAGNOSTIC
! RECORD AND BINDING PARAMETERS
%IF ENVIR=3000 %THEN BADERROR('ENVIRONMENT OVERFLOW',EMPTY)
ENVIR=ENVIR+1
BNAME(ENVIR)=0; ! DIAGNOSTIC RECORD
BVALUE(ENVIR)=FNAME
%RESULT=SETBIND(PARMLIST,ENVIR)
%END; ! END MAKEBIND
!
!
!
! USER STACK MANIPULATION
!
%INTEGERFN UNSTACK
%IF STKPNT=0 %THEN BADERROR('STACK UNDERFLOW',EMPTY)
STKPNT=STKPNT-1
%RESULT=STK(STKPNT+1)
%END; ! END UNSTACK
!
%ROUTINE STACK(%INTEGER I)
%IF STKPNT=2000 %THEN BADERROR('STACK OVERFLOW',EMPTY)
STKPNT=STKPNT+1
STK(STKPNT)=I
%END; ! END STACK;
!
!
! SYSTEM STACK
! USED TO MAKE REFS TO COLLECTABLE LIST STRUCTURE FROM IMP LOCALS
! AVAILABLE TO THE COLLECTOR.
!
%INTEGERFN UNSTKSYS
%IF SYSTKPNT=0 %THEN BADERROR('SYSTACK UNDERFLOW',EMPTY)
SYSTKPNT=SYSTKPNT-1
%RESULT=SYSTK(SYSTKPNT+1)
%END; ! END UNSTKSYS
!
%ROUTINE STKSYS(%INTEGER I)
%IF SYSTKPNT=2000 %THEN BADERROR('SYSTACK OVERFLOW',EMPTY)
SYSTKPNT=SYSTKPNT+1
SYSTK(SYSTKPNT)=I
%END; ! END STKSYS
!
!
!
! SYSTEM INPUT/OUTPUT
!
! ALL SYSTEM INPUT IS IN THE FORM OF A LIST WITH OUTERMOST
! BRACKETS IMPLICIT. SPACES AND NOOLINE AT START OF INPUT ARE
! DISCARDED OTHERWISE THEY SERVE TO DELIMIT WORDS. THE LIST IS
! TERMINATED WITH A SEMI COLON
! AT LEVEL 1 (IE USER LEVEL ZERO),THE MINUS CHAR IS LEFT
! AS A SEPARATE WORD. AT ANY OTHER LEVEL IT IS ASSUMED TO BE
! THE UNARY MINUS AND MUST BE FOLLOWED BY A NUMBER. THE NUMBER
! IS THEN CONVERTED TO BINARY AND NEGATED.
!
!
!
!
%ROUTINE CAPTION (%STRING (255) WORD)
!
! *** USED TO SEND TEXT AS PART OF A PICTURE TO THE GT42
! *** PROCESOR
%CONSTINTEGER LETTER WIDTH = 14
%BYTEINTEGERMAP MSB (%INTEGER I)
%RESULT== BYTEINTEGER(ADDR(WORD)+I+1)
%END
%BYTEINTEGERMAP LSB (%INTEGER I)
%RESULT == BYTEINTEGER(ADDR(WORD)+I)
%END
!
%INTEGER I, L;
%IF DEF PICTURE = 0 %THENSTART ;! IMMEDIATE EXECUTION
SET42(CHPIC)
MODE42(CHARM)
%FINISH %ELSE %START
CURPIC = CONSG(X'8000',CURPIC)
CUR42MODE = CHAR M
%FINISH
L = LENGTH(WORD)
GRAPHP = GRAPHP + L + (L&1)<<1
!UPDAA?E TURTLE COORDS
!
XTURTLE=XTURTLE+ LETTER WIDTH * L
I = 1
%CYCLE
%IF DEF PICTURE = 0 %THENSTART
%IF L=0 %THENRETURN
CH3(ADD1)
%IF L = 1 %THEN CH3(LSB(I)) %ANDRETURN
CH3 (MSB(I)<< 8 ! LSB(I))
%FINISHELSESTART
%IF L = 0 %THENEXIT
%IF L = 1 %THEN CURPIC = CONSG(LSB(I),CURPIC) %ANDEXIT
CURPIC = CONSG(MSB(I)<<8!LSB(I), CURPIC)
%FINISH
L = L - 2
I = I + 2
%REPEAT
GMODE = 3
!
%END
!
! DRIBBLE FILE BITS AND OIECES
!
%CONSTSTRING(10) INTQ='
INT:Q
',INTH='
INT:H
'
%BYTEINTEGERARRAYFORMAT DF(1:50000)
%BYTEINTEGERARRAYNAME DFILE
%INTEGERNAME DPNT
%BYTEINTEGERARRAY LINE BUFFER(1:80)
%INTEGER BPNT
!
%INTEGERFN ETIME
%BYTEINTEGERARRAY BT(0:8)
STRING(ADDR(BT(0)))=TIME
BT(1)=BT(1)-'0'
BT(2)=BT(2)-'0'
BT(4)=BT(4)-'0'
BT(5)=BT(5)-'0'
BT(7)=BT(7)-'0'
BT(8)=BT(8)-'0'
%RESULT=((BT(1)*10+BT(2))*60+BT(4)*10+BT(5))*60+BT(7)*10+BT(8)
%END; ! END ETIME
!
%ROUTINE DRIBBLE(%STRING(255) S)
%BYTEINTEGER SAVE
SAVE=DFILE(DPNT)
STRING(ADDR(DFILE(DPNT)))=S
DFILE(DPNT)=SAVE
DPNT=DPNT+LENGTH(S)
%END; ! END DRIBBLE
!
%ROUTINE DPRINTSTRING(%STRING(255) S)
DRIBBLE(S)
PRINTSTRING(S)
%END; ! END DPRINTSTRING
!
%ROUTINE DNEWLINE
DPNT=DPNT+1
DFILE(DPNT)=NL
NEWLINE
%END; ! END DNEWLINE
!
%ROUTINE DPROMPT(%STRING(15) S)
DPROMP=S
PROMPT(S)
%END; ! END DPROMPT
!
%ROUTINE FILL LINE BUFFER
%INTEGER N,T
T=ETIME
DRIBBLE(DPROMP)
BPNT=0
%UNTIL N=NL %CYCLE
READSYMBOL(N)
%IF N#NL %THENSTART
DPNT=DPNT+1
DFILE(DPNT)=N
%FINISH
BPNT=BPNT+1
LINE BUFFER(BPNT)=N
%REPEAT
T=(ETIME-T)<<8
%CYCLE N=1,1,80-BPNT-LENGTH(DPROMP)
DPNT=DPNT+1
DFILE(DPNT)='.'
%REPEAT
DRIBBLE(NUMTOSTR(T))
DPNT=DPNT+1
DFILE(DPNT)=NL
BPNT=1
%END; ! END FILL LINE BUFFER
!
%ROUTINE LGREADSYM(%INTEGERNAME SYM)
%IF DEVICE=TTY %THENSTART
SYM=LINE BUFFER(BPNT)
BPNT=BPNT+1
%FINISHELSESTART
SYM=TEXT(CURTEXT)
CURTEXT=CURTEXT+1
%FINISH
%END; ! END LGREADSYM
!
!
%INTEGERFN LGNEXTSYM
%IF DEVICE=TTY %THENRESULT=LINE BUFFER(BPNT)
%RESULT=TEXT(CURTEXT)
%END; ! END LGNEXTSYM
!
!
%ROUTINE LGSKIPSYM
%IF DEVICE=TTY %THEN BPNT=BPNT+1 %ELSE CURTEXT=CURTEXT+1
%END; ! END LGSKIPSYM
!
!
%ROUTINE LGREADITEM(%STRINGNAME ITEM)
%IF DEVICE=TTY %THENSTART
ITEM=TOSTRING(LINE BUFFER(BPNT))
BPNT=BPNT+1
%FINISHELSESTART
ITEM=TOSTRING(TEXT(CURTEXT))
CURTEXT=CURTEXT+1
%FINISH
%END; ! END LGREADITEM
!
!
!
!
%INTEGERFN READLIST(%INTEGER LEVEL)
!
%INTEGERFN GETITEM
%INTEGER SYM,N,RES
%STRING(2) ITEM
%STRING(64) WORD
%INTEGER SYMCOUNT
SYMCOUNT=0;WORD=''
N=LGNEXT SYM
%IF QUOTEON=1 %AND (N<45 %OR 57<N<65 %OR N>90) %THENRESULT=EMPTY
LP:N=LGNEXT SYM
%IF N=' ' %THENSTART
LGSKIP SYM
%IF SYMCOUNT=0 %THEN ->LP %ELSESTART
SYMCOUNT=0
RES=PUT(WORD)
%IF RES=ERR %THEN DPRINTSTRING('NUMBER TOO LARGE.') %AND ->ERR1
%RESULT=RES
%FINISH
%FINISH
%IF N='+' %THENSTART
%IF SYMCOUNT=0 %THENSTART
LGREADSYM(N) %UNTIL N=NL
DPROMPT(' C:')
FILL LINE BUFFER %IF DEVICE=TTY
->LP
%FINISHELSESTART
SYMCOUNT=0
RES=PUT(WORD)
%IF RES=ERR %THEN DPRINTSTRING('NUMBER TOO LARGE.') %AND ->ERR1
%RESULT=RES
%FINISH
%FINISH
%IF N=TERMIN %THENSTART;DPROMPT(PROMP)
%IF SYMCOUNT=0 %THENSTART
%IF LEVEL>BLEVEL %THENSTART
DPRINTSTRING('MISSING RIGHT BRACKET.')
->ERR1
%FINISH
LGSKIP SYM
%RESULT=RBRAK
%FINISHELSESTART
SYMCOUNT=0
RES=PUT(WORD)
%IF RES=ERR %THEN DPRINTSTRING('NUMBER TOO LARGE.') %AND ->ERR1
%RESULT=RES
%FINISH
%FINISH
%IF N=LBRAK %OR N=RBRAK %THENSTART
%IF SYMCOUNT=0 %THENSTART;LGREAD SYM(SYM);%RESULT=SYM
%FINISHELSESTART
SYMCOUNT=0
RES=PUT(WORD)
%IF RES=ERR %THEN DPRINTSTRING('NUMBER TOO LARGE.') %AND ->ERR1
%RESULT=RES
%FINISH
%FINISH
%IF N='-' %THENSTART
%IF SYMCOUNT=0 %THENSTART
LGSKIP SYM
N=LGNEXT SYM
SYM=GETITEM
%IF SYM=ERR %THENRESULT=ERR
%IF SYM=LBRAK %OR SYM=RBRAK %OR SYM&NM=0 %THENSTART
DPRINTSTRING('INVALID ''-''.')
->ERR1
%FINISHELSERESULT=(-SYM>>8)<<8!NM
%FINISHELSESTART
SYMCOUNT=0
RES=PUT(WORD)
%IF RES=ERR %THEN DPRINTSTRING('NUMBER TOO LARGE.') %AND ->ERR1
%RESULT=RES
%FINISH
%FINISH
%IF N<48 %OR (N>57 %AND N <65) %OR N>90 %THENSTART
%IF SYMCOUNT=0 %THENSTART
LGREAD ITEM(ITEM)
%RESULT=PUT(ITEM)
%FINISHELSESTART
SYMCOUNT=0
RES=PUT(WORD)
%IF RES=ERR %THEN DPRINTSTRING('NUMBER TOO LARGE.') %AND ->ERR1
%RESULT=RES
%FINISH
%FINISH
LGREAD ITEM(ITEM);
%IF SYMCOUNT=64 %THENSTART
DPRINTSTRING('TOO MANY CHARACTERS IN WORD.')
->ERR1
%FINISHELSESTART
WORD=WORD.ITEM;SYMCOUNT=SYMCOUNT+1
%FINISH
->LP
ERR1:%WHILE N#NL %THEN LGREAD SYM(N)
DPRINTSTRING(' LINE DISCARDED.')
DNEWLINE
%RESULT=ERR
%END; ! END GETITEM
!
%INTEGER THISPOINT,ITEM
THISPOINT=LPOINT
ITEM=GETITEM
%IF ITEM=ERR %THENRESULT=ERR
%IF ITEM=QUOTE %THEN QUOTEON=1 %ELSE QUOTEON=0
%IF ITEM=RBRAK %THENSTART
%RESULT=NIL
%FINISHELSESTART
LPOINT=LPOINT+2
%IF (LPOINT-LABASE)>CFRACT*SEMISIZE %THEN CLECTFLG=1
! SET FLAG FOR COLLECT
%IF ITEM=LBRAK %THENSTART
ITEM=READLIST(LEVEL+1)
%IF ITEM=ERR %THENRESULT=ERR
%FINISH
LA(THISPOINT)=ITEM
ITEM=READLIST(LEVEL)
%IF ITEM=ERR %THENRESULT=ERR
LA(THISPOINT+1)=ITEM
%RESULT=THISPOINT<<8!LM
%FINISH
%END; ! END READLIST
!
!
!
%INTEGERFN READLINE
%INTEGER RES
LP:BLEVEL=1
%IF DEVICE=TTY %THEN FILL LINE BUFFER
RES=READLIST(BLEVEL)
%IF RES=ERR %THEN ->LP
%RESULT=RES
%END; ! END READLINE
!
%ROUTINE NOOLINE(%INTEGER N)
%WHILE N>0 %CYCLE
DNEWLINE
N=N-1
%REPEAT
CHAROUT=0
%END; ! END NOOLINE
!
%ROUTINE PRSTRING(%STRING(255) WORD)
%INTEGER N
%IF CAPFLAG=1 %THEN CAPTION(WORD) %ANDRETURN
N=LENGTH(WORD)
%IF (CHAROUT+N)>72 %THENSTART
DNEWLINE
%IF WORD->(' ').WORD %THEN N=N-1
DPRINTSTRING(' ')
DPRINTSTRING(WORD)
CHAROUT=N+3
%FINISHELSESTART
DPRINTSTRING(WORD)
CHAROUT=CHAROUT+N
%FINISH
%END; ! END PRSTRING
!
%ROUTINE LGPRNTSTR(%STRING(65) WORD)
%BYTEINTEGER SAVE
%INTEGER L
%IF DEVICE=TTY %THEN PRSTRING(WORD) %ANDRETURN
%IF FULLFLAG=1 %THENRETURN
L=LENGTH(WORD)
%IF (OWNFLENGTH-DIRPAGES*4096-NFTEXT+1)<L %THENSTART; ! NOT ROOM
FULLFLAG=1
%RETURN
%FINISH
SAVE=TEXT(NFTEXT-1)
STRING(ADDR(TEXT(NFTEXT-1)))=WORD
TEXT(NFTEXT-1)=SAVE
NFTEXT=NFTEXT+L
%END; ! END LGPRNTSTR
!
!
%ROUTINE LGNEWLINE
%IF DEVICE=TTY %THEN NOOLINE(1) %ELSE LGPRNT STR(STERMIN)
%END; ! END LGNEWLINE
!
!
!
%ROUTINE PRINTWORD(%STRING(64) WORD)
%IF WORD=']' %OR WORD=')' %OR WORD='>' %THENSTART
LGPRNT STR(WORD)
SEP=' '
%RETURN
%FINISH
%IF WORD='(' %OR WORD='[' %OR WORD='"' %OR WORD=':' %OR WORD='<' %C
%THENSTART
LGPRNT STR(SEP.WORD)
SEP=''
%RETURN
%FINISH
%IF WORD=',' %THENSTART
LGPRNT STR(WORD)
SEP=''
%RETURN
%FINISH
LGPRNT STR(SEP.WORD)
SEP=' '
%RETURN
%END; ! END PRINTWORD
!
!
%ROUTINE PRINTWN(%INTEGER I)
%STRING(64) WORD
%IF I&NM=NM %THENSTART
%IF I<0 %THEN WORD='-'.NUMTOSTR(\I+256) %ELSE WORD=' '.NUMTOSTR(I)
%FINISHELSE WORD=WA(I>>8)
PRINTWORD(WORD)
%END; ! END PRINTWN
!
%ROUTINE PRINTLCON(%INTEGER LIST)
%INTEGER I
LP:%IF ENUF=1 %OR (TESTINT(0,'ENUF')#0 %AND DEVICE=TTY) %THENSTART
ENUF=1
%RETURN
%FINISH
%IF LIST=NIL %THENRETURN
I=HD(LIST)
%IF I&LM=LM %THEN PRINTLIST(I) %ELSE PRINTWN(I)
LIST=TL(LIST)
->LP
%END; ! END PRINTLCON
!
%ROUTINE PRINTLIST(%INTEGER LIST)
PRINTWORD('[')
PRINTLCON(LIST)
PRINTWORD(']')
%END; ! END PRINTLIST
!
!
%ROUTINE PRINTEL(%INTEGER I)
ENUF=0
SEP=''
%IF I&LM=LM %THEN PRINTLIST(I) %ELSE PRINTWN(I)
%END; ! END PRINTEL
!
!
%ROUTINE PRINTEL1(%INTEGER I)
ENUF=0
SEP=''
%IF I&LM=LM %THEN PRINTLCON(I) %ELSE PRINTWN(I)
%END; ! END PRINTEL1
!
!
%ROUTINE PRINTLINE(%INTEGER LINE)
%INTEGER HEAD
SEP=''
%IF LINE=NIL %THENSTART
ENUF=0
PRINTLIST(NIL)
%FINISH
%WHILE LINE#NIL %CYCLE
HEAD=HD(LINE)
%IF HEAD&LM=LM %THENSTART
ENUF=0
PRINTLIST(HEAD)
%FINISHELSE PRINTWN(HEAD)
LINE=TL(LINE)
%REPEAT
LGNEWLINE
%END; ! END PRINTLINE
!
!
!
! INFERENCE SYSTEM
!
%ROUTINE SETUPINF
BVALUE(DATABASE>>8)=NIL;BVALUE(FACTKEYS>>8)=NIL
BVALUE(IMPRULES>>8)=NIL;BVALUE(IMPKEYS>>8)=NIL
BVALUE(INFRULES>>8)=NIL;BVALUE(INFKEYS>>8)=NIL
GENOS=0
%END; ! END SETUPINF
!
%ROUTINE INITINF
DBASE(1)=DATABASE;IMPLINKS(1)=IMPRULES;INFLINKS(1)=INFRULES
DBASE(2)=FACT;IMPLINKS(2)=IMPLIES;INFLINKS(2)=TOINFER
DBASE(3)=FACTKEYS;IMPLINKS(3)=IMPKEYS;INFLINKS(3)=INFKEYS
SETUPINF
%END; ! END INITINF
!
!
!
!
!
! EVAL AND APPLY
!
%ROUTINE EVALAPPL(%INTEGER PREC,%INTEGERNAME ENVIR,FUN,CURFUN,%C
IN,TSTFLG,VAL,SEVERITY,WALKFN)
!
! ENVIR IS THE CURRENT ENVIRONMENT POINTER - 1022 IF OUTSIDE A USER
! FUN AND ONLY BASE ENVIR EXISTS.
! FUN IS THE USER FUN WE ARE CURRENTLY IN - NIL IF OUTSIDE USER
! FUN
! CURFUN IS THE REST OF THE USER FUN WE ARE CURRENTLY IN - NIL
! IF OUTSIDE USER FUN
! IN CONTAINS THE LINE WE ARE CURRENTLY EVALUATING EITHER FROM
! A USER FUN OR FROM THE TTY
! TSTFLG IS THE CURRENT TEST LOCATION USED BY TEST IFTRUE,ETC
! VAL IS THE LAST VALUE
! SEVERITY IS USED IN APPLYSYS TO TELL IF A CONTINUE
! IS POSSIBLE
! WALKFN IS USED TO TELL IF A USER FUNCTION IS BEING EXECUTED
! IN STEPPING MODE
!
! THESE PARAMETES ARE CREATED BY LOGO AT BASE LEVEL AND ARE
! RECREATED BY APPLYUSR ON EACH ENTRY TO USER FUN.
! THEY ARE USED FREE BY ROUTINE ERROR FOR DIAGNOSTIC PURPOSES
! AND BY APPLYSYS AND EVAL
!
%ROUTINESPEC EVAL(%INTEGER PREC,%INTEGERNAME IN,EACHVAL,WALKFN)
!
!
!
%ROUTINE ERROR(%STRING(255) ERRMESS,%INTEGER CULPRIT,SEVERITY,%C
%INTEGERNAME IN)
%INTEGER SAVEDEV
%IF TDEV = 8 %THEN SET42(CHTXT)
SAVEDEV=DEVICE
DEVICE=TTY
NOOLINE(1)
%IF FUN=NIL %THENC
PRSTRING('LOGO CANNOT FULLY EXECUTE THAT COMMAND, BECAUSE') %ELSESTART
PRSTRING('LOGO CANNOT FULLY EXECUTE THIS COMMAND:-');NOOLINE(1)
PRSTRING(' ');PRINTLINE(HD(CURFUN))
PRSTRING('IN PROCEDURE ');PRINTEL(HD(TL(TL(HD(FUN)))));
PRSTRING(', BECAUSE')
%FINISH
NOOLINE(1)
DPRINTSTRING(ERRMESS);PRINTEL1(CULPRIT);NOOLINE(3)
JUMPFLAG=1; ! TRIGGERS A RETURN TO LOGO
IN=NIL
STACK(CONS(QQPROC,CONS(ERR,NSRTAIL)))
DEVICE=SAVEDEV
%RETURN
! FOLLOWING USED TO REENTER LOGO RECURSIVELY, SUSPENDING
! CURRENT PROCESS. NOT IMPLEMENTED IN THIS VERSION.
!
! STKSYS(IN)
! STKSYS(VAL);
! LOGO(STKPNT,MAKEBIND(NIL,ENVIR,LOGONAME),SEVERITY,0)
! VAL=UNSTKSYS
! IN=UNSTKSYS
! DEVICE=SAVEDEV
! %RETURN
%END; ! END ERROR
!
%ROUTINE ERROR1(%STRING(255) ERRMESS,%INTEGER CULPRIT)
%INTEGER SAVEDEV
SAVEDEV=DEVICE
DEVICE=TTY
DPRINTSTRING(ERRMESS);PRINTEL(CULPRIT);NOOLINE(1)
DEVICE=SAVEDEV
%END; ! END ERROR1
!
!
%ROUTINE ERROR2(%INTEGER CULPRIT)
%INTEGER SAVEDEV
SAVEDEV=DEVICE
DEVICE=TTY
NOOLINE(1)
%IF FUN=NIL %THENSTART
DPRINTSTRING %C
('THAT LINE IS NOT A COMMAND BECAUSE YOU DID NOT SAY WHAT TO DO WITH ')
%FINISHELSESTART
DPRINTSTRING('THIS LINE - ');PRINTEL(HD(CURFUN));NOOLINE(1)
DPRINTSTRING('IN PROCEDURE ');PRINTEL(HD(TL(TL(HD(FUN)))))
DPRINTSTRING(' IS NOT A COMMAND BECAUSE YOU DID NOT
SAY WHAT TO DO WITH ')
%FINISH
%IF CULPRIT&WM=WM %THEN PRINTEL(QUOTE)
PRINTEL(CULPRIT);NOOLINE(3)
JUMPFLAG=1
IN=NIL
STACK(CONS(QQPROC,CONS(ERR,NSRTAIL)))
%RETURN
%END; ! END ERROR2
!
!
!
!
%INTEGERFN REVQUOTE(%INTEGER LIST)
! REVERSES LIST AND REMOVES QUOTES
%INTEGER LIST1,WORD
%IF LIST=NIL %THEN ->RQ1
LIST1=NIL
%WHILE LIST#NIL %CYCLE
%IF HD(LIST)=QUOTE %THEN LIST=TL(LIST) %ELSE ->RQ1
%IF LIST=NIL %THEN ->RQ1
WORD=HD(LIST)
%IF WORD&WM#WM %OR WORD=EMPTY %THEN ->RQ1
LIST1=CONS(WORD,LIST1)
LIST=TL(LIST)
%REPEAT
%RESULT=LIST1
RQ1:ERROR('INCORRECT FORMAT FOR PROCEDURE TITLE LINE',EMPTY,1,IN)
%RESULT=ERR
%END; ! END REVQUOTE
!
!
%ROUTINE CHKLIST(%INTEGER LIST)
%INTEGER WORD
%IF LIST&LM#LM %THENSTART
ERROR(ERRMESS(53),LIST,1,IN)
%RETURN
%FINISH
%WHILE LIST#NIL %CYCLE
WORD=HD(LIST)
%IF WORD&WM#WM %THENSTART
ERROR(ERRMESS(53),WORD,1,IN)
%RETURN
%FINISH
LIST=TL(LIST)
%REPEAT
%END; ! END CHKLIST
!
!
%INTEGERFN LISTLEN(%INTEGER LIST); ! RETURNS LENGTH OF LIST
%INTEGER LEN
LEN=0
%WHILE LIST#NIL %CYCLE
LEN=LEN+1
LIST=TL(LIST)
%REPEAT
%RESULT=LEN
%END; ! END LISTLEN
!
%INTEGERFN GETMATCH(%INTEGERNAME CLAUSE,IN)
! PLACES ELEMENTS FROM IN INTO CLAUSE UP TO AND INCLUDING MATCHING RPAR
! ENTER WITH LPAR AS HD(IN)
%INTEGER HEAD,RES
CLAUSE=CONS(LPAR,CLAUSE)
IN=TL(IN)
%WHILE IN#NIL %CYCLE
HEAD=HD(IN)
%IF HEAD=RPAR %THENSTART
IN=TL(IN)
CLAUSE=CONS(HEAD,CLAUSE)
%RESULT=EMPTY
%FINISH
%IF HEAD=LPAR %THENSTART
RES=GETMATCH(CLAUSE,IN)
%IF RES#EMPTY %THENRESULT=RES; ! PASS ERROR OUT
%FINISHELSESTART; ! NEITHER LPAR NOR RPAR SO CONTINUE
IN=TL(IN)
CLAUSE=CONS(HEAD,CLAUSE)
%FINISH
%REPEAT
%RESULT=RPAR; ! NO RPAR BEFORE END
%END; ! END GETMATCH
!
!
%ROUTINE STRTRACE(%INTEGER FN,%STRING(2) S)
! USED TO PRINT FN. NAME ETC WHEN ENTERING A TRACED/PARSED FN
INDENT=INDENT+2
PARSPR=PARSPR.S
DPRINTSTRING(PARSPR)
PRINTEL(FN)
%END
!
!
%INTEGERFN SYSTRACE(%INTEGER TRBIT,FN)
%INTEGER TRLIST, TRFN, TRWD
TRLIST=OWNFUNS
%WHILE TRLIST#NIL %CYCLE
TRWD=HD(TRLIST);TRLIST=TL(TRLIST)
TRFN=FNVAL(TRWD>>8)
%IF TRFN&INTERP=INTERP %THENSTART
ERROR1(WA(TRWD>>8).' IS A SPECIAL PROCEDURE OF LOGO'. %C
' WHICH CANNOT BE '.WA(FN>>8).'D',EMPTY)
->TR1
%FINISH
FNVAL(TRWD>>8)=(TRFN&UNMASK)!TRBIT
TR1:%REPEAT
%RESULT=OWNFUNS
%END; ! END SYSTRACE
!
!
%INTEGERFN TRACE(%INTEGER TRBIT,ARG,FN)
%INTEGER TRLIST,TRFN,TRWD
%IF ARG=OWNFUNS %THENRESULT=SYSTRACE(TRBIT,FN)
%IF ARG&WM=WM %THEN ARG=CONS(ARG,NIL)
%IF ARG&LM#LM %THENSTART
ERROR(WA(FN>>8).ERRMESS(24),ARG,1,IN)
%RESULT=ERR
%FINISH
TRLIST=NIL
%WHILE ARG#NIL %CYCLE
TRWD=HD(ARG)
ARG=TL(ARG)
%IF TRWD&WM#WM %THENSTART
ERROR1(WA(FN>>8).ERRMESS(24),CONS(TRWD,ARG))
->TR2
%FINISH
TRFN=FNVAL(TRWD>>8)
%IF TRFN=0 %THENSTART
ERROR1(ERRMESS(21).WA(TRWD>>8).ERRMESS(23),FN)
->TR2
%FINISH
%IF TRFN&INTERP=INTERP %THENSTART
ERROR1(WA(TRWD>>8).' IS A SPECIAL PROCEDURE OF LOGO'. %C
' WHICH CANNOT BE '.WA(FN>>8).'D',EMPTY)
->TR2
%FINISH
FNVAL(TRWD>>8)=(TRFN&UNMASK)!TRBIT ; ! INSERT TRACE FLAG
TRLIST=CONS(TRWD,TRLIST)
TR2:%REPEAT
%RESULT=TRLIST
%END; ! END TRACE
!
!
%ROUTINE ENDTRACE(%INTEGER FN)
! USED TO PRINT FN NAME ETC. WHEN EXITING A TRACED/PARSED FN
INDENT=INDENT-2
BYTEINTEGER(ADDR(PARSPR))=INDENT
DPRINTSTRING(PARSPR);DPRINTSTRING(' <')
PRINTEL(FN)
%END
!
%ROUTINE SENDBIN(%BYTEINTEGER TYPE,N)
! IF TYPE=0, N 16 BIT ARGS ALREADY SET UP IN BINARG1,2,ETC
! IF TYPE=1 N IS IRRELEVANT
N=2*N
BINBUFF(1)=TDEV-1
BINBUFF(2)=TYPE
%IF TYPE=0 %THENSTART
BINBUFF(3)=N
P_ARG3=N+3
%FINISHELSE P_ARG3=2
P_DEST=208; ! SVC PUT OUTPUT
P_ARG1=16; ! CHANNEL 0 WITH BINARY NIT
P_ARG2=ADDRBINBUFF
DOSVC:SVC(P)
%IF P_ARG1<0 %THENSTART; ! ABORTED
P_ARG1=P_ARG2
P_ARG2=P_ARG3
P_ARG3=P_ARG4
P_DEST=208
->DOSVC
%FINISH
%END; ! END SENDBIN
!
%ROUTINE CLESET
! CLEARS AND RSETS TURTLE DEVICE (IE CLEARS H316 Q)
%IF TDEV=8 %THEN CLEAR42
SENDBIN(1,0)
XTURTLE=0;YTURTLE=0;HDTURTLE=0;PENTURTLE=DOWN
%END; ! END CLESET
!
!
!
%ROUTINE APPLYSYS(%INTEGER SW,%INTEGERNAME FN,IN,EACHVAL)
!
%ROUTINESPEC ADDFACT(%INTEGER FACT,INDENT)
%INTEGERFNSPEC DEDUCEQ(%INTEGER PATTERN,INDENT)
%INTEGERFNSPEC TRYINFQ(%INTEGER PAT,INDENT)
!
%SWITCH SYSFUN(1:300)
%SWITCH FDSW,BDSW,LEFTSW,RIGHTSW,LIFTSW,DROPSW,HOOTSW,CENSW,%C
CLSW,WHSW,HERESW,XCORSW,YCORSW,HDSW,PENSW,SETXSW,SETYSW,SETHSW,%C
POSW,ARCLSW,ARCRSW,PNSW,RNSW,NOTESW,PLAYSW,MOTASW,MOTBSW,ROTSW,%C
PAIRSW(0:8)
%REAL RW1,RW2
%REAL DX,DY
%INTEGER XC,YC; ! TURTLE WORKSPACE
%INTEGER ARG1,ARG2,ARG3,W1,W2,W3,W4
%REALARRAY TSTOR (1:2) ;! USED IN "PICTURE" TO HOLD TURTLE COORDS
%INTEGERARRAY TSTORI(3:4)
%INTEGERARRAY MOVIE RECORD (1:FRAME TIME)
%INTEGER CURRENT MOVIE TIME
%INTEGERNAME WPTR1
%INTEGER REDEF; ! USED BY EDIT
%STRING(255) WSTR1,WSTR2,WSTR3
%ROUTINESPEC VECTOR(%REAL X,Y)
%ROUTINESPEC CALC TURTLE
!
!
%INTEGERFN EXTRACT(%INTEGERNAME COND,THENC,ELSEC)
! USED BY IF AND WHILE TO EXTRACT CLAUSES.
! RESULT IS EMPTY IF SYNTAX OK
! RESULT IS CULPRIT IF SOMETHING MISPLACED OR MISSING
%INTEGER HEAD,RES,FN
FN=HD(IN)
COND=CONS(HD(IN),COND); ! INITIAL IF INTO COND
IN=TL(IN)
%WHILE IN#NIL %CYCLE
! LOOK FOR THEN BEFORE ELSE OR TERMIN
HEAD=HD(IN)
%IF HEAD=LPAR %THENSTART; ! LEFT PARENTHESES
RES=GETMATCH(COND,IN); ! EXTRACT UP TO MATCHING RPAR
%IF RES#EMPTY %THENRESULT=RES; ! PASS OUT ERROR
%FINISHELSESTART
%IF HEAD=THEN %THEN ->THENL; ! FOUND THEN
%IF HEAD=ELSE %OR HEAD=RPAR %THENRESULT=THEN; ! ERROR - THEN MISSING
%IF HEAD=IF %OR HEAD=WHILE %THENSTART
RES=EXTRACT(COND,COND,COND)
%IF RES#EMPTY %THENRESULT=RES; ! ERROR PASSED OUT
%FINISHELSESTART
COND=CONS(HEAD,COND)
IN=TL(IN)
%FINISH
%FINISH
%REPEAT
%RESULT=THEN; ! ERROR - THEN NOT FOUND BEFORE END
!
THENL:THENC=CONS(HD(IN),THENC)
IN=TL(IN)
%WHILE IN#NIL %CYCLE
! LOOK FOR ELSE OR ANOTHER THEN
HEAD=HD(IN)
%IF HEAD=LPAR %THENSTART
RES=GETMATCH(THENC,IN)
%IF RES#EMPTY %THENRESULT=RES
%FINISHELSESTART
%IF HEAD=ELSE %THEN ->ELSEL
%IF HEAD=THEN %OR HEAD=RPAR %THENRESULT=EMPTY; ! END OF THIS IF
%IF HEAD=IF %OR HEAD=WHILE %THENSTART
RES=EXTRACT(THENC,THENC,THENC)
%IF RES#EMPTY %THENRESULT=RES
%FINISHELSESTART
THENC=CONS(HEAD,THENC)
IN=TL(IN)
%FINISH
%FINISH
%REPEAT
%RESULT=EMPTY; ! END OF THIS IF
!
ELSEL:%IF FN=WHILE %THENRESULT=EMPTY; ! END OF WHILE
ELSEC=CONS(HD(IN),ELSEC)
IN=TL(IN)
%WHILE IN#NIL %CYCLE
HEAD=HD(IN)
%IF HEAD=LPAR %THENSTART
RES=GETMATCH(ELSEC,IN)
%IF RES#EMPTY %THENRESULT=RES
%FINISHELSESTART
%IF HEAD=THEN %OR HEAD=ELSE %OR HEAD=RPAR %THENRESULT=EMPTY
%IF HEAD=IF %OR HEAD=WHILE %THENSTART
RES=EXTRACT(ELSEC,ELSEC,ELSEC)
%IF RES#EMPTY %THENRESULT=RES
%FINISHELSESTART
ELSEC=CONS(HEAD,ELSEC)
IN=TL(IN)
%FINISH
%FINISH
%REPEAT
%RESULT=EMPTY
%END; ! END EXTRACT
!
!
%INTEGERFN FINDASS(%INTEGER LIST,ATT)
! FINDS AN ASSOCIATION IN LIST WITH ATTRIBUTE ATT. USES W1 AND W2
! FREE. IF ASSOC FOUND, W2 POINTS TO LIST STARTING WITH ASSOC AND
! W1 POINTS TO ONE BEFORE, UNLESS ASSOC IS FIRST IN LIST WHEN W1=W2
! IN EITHER CASE W2 ALSO RETURNED VIA RESULT.
! IF NO ASSOC FOUND, NIL RETURNED.
W1=LIST
W2=LIST
%WHILE W2#NIL %CYCLE
%IF HD(HD(W2))#ATT %THENSTART
W1=W2
W2=TL(W2)
%FINISHELSERESULT=W2
%REPEAT
%RESULT=NIL
%END; ! END FINDASS
!
!
!
%INTEGERFN UNSTACKINPUT
%INTEGER ARG
%STRING(63) STR
ARG=UNSTACK
%IF ARG&LM=LM %AND ARG#NIL %THENSTART
%IF HD(ARG)=QQPROC %THEN STR=WA(HD(TL(ARG))>>8) %ELSESTART
%IF HD(ARG)=QQRESULT %THEN STR='RESULT' %ELSERESULT=ARG
%FINISH
ERROR('PROCEDURE '.STR.' DID NOT PRODUCE A RESULT
AS INPUT FOR PROCEDURE ',FN,1,IN)
%FINISH
%RESULT=ARG
%END; ! END UNSTACKINPUT
!
!
%ROUTINE CHECKNUM
%IF ARG1&NM#NM %OR ARG2&NM#NM %THEN %C
ERROR(ERRMESS(10).WA(FN>>8).ERRMESS(11),%C
CONS(ARG1,CONS(ARG2,NIL)),1,IN)
%RETURN
%END; ! END CHECKNUM
!
%INTEGERFN CHECKSIZE(%INTEGER I)
%IF I>NUMTOP %OR I<NUMBOT %THENSTART
ERROR(ERRMESS(30).WA(FN>>8).ERRMESS(31),EMPTY,1,IN)
%RESULT=ERR
%FINISH
%RESULT=I
%END; ! END CHECKSIZE
!
%ROUTINE READYNUM
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
CHECKNUM
%IF JUMPFLAG=1 %THENRETURN
%IF ARG1<0 %THEN ARG1=ARG1>>8!T8 %ELSE ARG1=ARG1>>8
%IF ARG2<0 %THEN ARG2=ARG2>>8!T8 %ELSE ARG2=ARG2>>8
%END; ! END READYNUM
!
!
%ROUTINE CHECKSUM(%INTEGER ARG1,ARG2)
! CHECKS THAT ARG1+ARG2 DOES NOT EXCEED IMP LIMIT
! BOTH POSITIVE
%IF MAXINT-ARG1<ARG2 %THEN ERROR(ERRMESS(30).WA(FN>>8).ERRMESS(31),%C
EMPTY,1,IN)
%RETURN
%END ; ! END CHECKSUM
!
!
%ROUTINE CHECKPROD(%INTEGER ARG1,ARG2)
! AS CHECKSUM FOR PRODUCT
%IF MAXINT/ARG1<ARG2 %THEN ERROR(ERRMESS(30).WA(FN>>8).ERRMESS(31),%C
EMPTY,1,IN)
%RETURN
%END; ! END CHECKPROD
!
!
%ROUTINE WORD
%INTEGER I
%IF ARG1&LM=LM %OR ARG2&LM=LM %OR ARG1<0 %OR ARG2<0 %THENSTART
ERROR(WA(FN>>8).ERRMESS(47),CONS(ARG1,CONS(ARG2,NIL)),1,IN)
%RETURN
%FINISH
%IF ARG1&NM=NM %THEN WSTR1=NUMTOSTR(ARG1) %ELSEC
WSTR1=WA(ARG1>>8)
%IF ARG2&NM=NM %THEN WSTR2=NUMTOSTR(ARG2) %ELSEC
WSTR2=WA(ARG2>>8)
%IF LENGTH(WSTR1)+LENGTH(WSTR2)>64 %THEN ->ERR1
I=PUT(WSTR1.WSTR2)
%IF I=ERR %THEN ->ERR1
STACK(I)
%RETURN
ERR1:ERROR(ERRMESS(30).WA(FN>>8).ERRMESS(31).ERRMESS(48),%C
CONS(ARG1,CONS(ARG2,NIL)),1,IN)
%RETURN
%END; ! END WORD
!
!
%ROUTINE LASTPUT
%IF ARG2&LM=LM %THENSTART; ! ARG2 A LIST
ARG3=NIL
%WHILE ARG2#NIL %CYCLE
%IF QUITFLAG=1 %THENSTART
QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1
STACK(QUIT);%RETURN
%FINISH
%IF HOLDFLAG=1 %THENSTART
STKSYS(ARG3);STKSYS(ARG2)
ERROR('USER INTERRUPT',EMPTY,0,IN)
ARG2=UNSTKSYS;ARG3=UNSTKSYS
%IF JUMPFLAG=1 %THENRETURN
%FINISH
ARG3=CONS(HD(ARG2),ARG3)
ARG2=TL(ARG2)
%REPEAT
! ARG3 NOW ARG2 REVERSED
ARG2=CONS(ARG1,NIL)
%WHILE ARG3#NIL %CYCLE
ARG2=CONS(HD(ARG3),ARG2)
ARG3=TL(ARG3)
%REPEAT
STACK(ARG2)
%RETURN
%FINISH
! ARG2 NOT A LIST SO WE WANT WORD ARG2,ARG1
ARG3=ARG1
ARG1=ARG2
ARG2=ARG3; !ARG1 AND ARG2 INTERCHANGED
WORD
%RETURN
%END; ! END LASTPUT
!
!
!
!
%INTEGERFN EQUAL(%INTEGER LIST1,LIST2)
%IF QUITFLAG=1 %THENSTART
QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1
%RESULT=QUIT
%FINISH
%IF HOLDFLAG=1 %THENSTART
STKSYS(LIST1);STKSYS(LIST2)
ERROR('USER INTERRUPT',EMPTY,0,IN)
LIST2=UNSTKSYS;LIST1=UNSTKSYS
%IF JUMPFLAG=1 %THENRESULT=UNSTACK
%FINISH
%IF LIST1=LIST2 %THENRESULT=TRUE; ! WORD
%IF LIST1&LM=0 %OR LIST2&LM=0 %OR LIST1=NIL %OR LIST2=NIL %C
%THENRESULT=FALSE
%IF EQUAL(HD(LIST1),HD(LIST2))=TRUE %C
%THENRESULT=EQUAL(TL(LIST1),TL(LIST2))
%RESULT=FALSE
%END; ! END EQUAL
!
!
%INTEGERFN GETNEXT(%INTEGERNAME IN)
%INTEGER NEXT
%IF IN=NIL %THENSTART
ERROR('SOMETHING MISSING',EMPTY,1,IN)
%RESULT=ERR
%FINISH
NEXT=HD(IN)
IN=TL(IN)
%RESULT=NEXT
%END; ! END GETNEXT
!
!
!
!
%ROUTINE FROMLIST(%INTEGERNAME LIST,%INTEGER ITEM)
%INTEGER ARG
%IF HD(LIST)=ITEM %THENSTART
LIST=TL(LIST); ! MATCH LATEST ENTRY
%RETURN;%FINISH
ARG=LIST
%WHILE TL(ARG)#NIL %CYCLE
%IF HD(TL(ARG))=ITEM %THENSTART
!
REPTAIL(ARG,TL(TL(ARG))); ! ALTERS NEWFN LIST
!
%RETURN;%FINISH
ARG=TL(ARG)
%REPEAT
%END; ! END FROMLIST
!
!
%ROUTINE EDIT(%INTEGER USERFUN)
%INTEGER LINE,LESSLINE,REST,DELLIST,SAVESTK
%STRING(10) SAVEPROM
!
%ROUTINE FINDLINE(%INTEGER NUM)
! SETS REST TO FUN STARTING AT LINE>=NUM, AND SETS LESSLINE
! TO FUN STARTING ONE LINE BEFORE
LESSLINE=USERFUN
REST=TL(USERFUN)
%WHILE REST#NIL %AND HD(HD(REST))<NUM %CYCLE
LESSLINE=REST
REST=TL(REST)
%REPEAT
%END; ! END FINDLINE
!
%ROUTINE EDITLINE; ! DOES A SINGLE EDIT COMMAND
%INTEGER ITEM
TOP:ITEM=HD(LINE); ! EDIT COMMANF IN LINE (NON-NIL)
%IF ITEM=RETITLE %THENSTART; ! REPLACE TITLE LINE
LINE=TL(LINE); ! DISCARD RETITLE
%IF LINE=NIL %THENSTART
DPRINTSTRING(ERRMESS(39).ERRMESS(40));NOOLINE(1)
%RETURN
%FINISH
W1=REVQUOTE(LINE); ! CHECK FORMAT
%IF JUMPFLAG=1 %THEN JUMPFLAG=0 %ANDRETURN
W1=LISTLEN(W1)-1; ! NUMBER OF PARAMS
%IF W1>127 %THENSTART
PRSTRING('TOO MANY INPUTS');NOOLINE(1)
%RETURN
%FINISH
ITEM=HD(TL(LINE)); ! PROC NAME
%IF ITEM#ARG1 %THENSTART; ! NEW NAME DIFF FROM OLD
ARG2=FNVAL(ITEM>>8); ! FUNSPEC FOR NEW NAME
%IF ARG2&USERPRE=USERPRE %THENSTART; ! ALREADT DEFINED
PRSTRING('PROCEDURE ALREADY DEFINED - ')
PRINTEL(ITEM);NOOLINE(1)
%RETURN
%FINISH
%IF ARG2#0 %THENSTART; ! SYSTEM PROC
PRSTRING('YOU CANNOT REDEFINE ONE OF ELOGO''S OWN PROCEDURES')
NOOLINE(1)
%RETURN
%FINISH
FNVAL(ARG1>>8)=0; ! UNDEFINE OLD NAME
OLDFN(ARG1>>8)=0; ! AND STANDBY
FROMLIST(NEWFN,ARG1) %UNLESS NEWFN=NIL
FROMLIST(DEFINED,ARG1); ! DEFINED MUST HAVE ARG1
PRSTRING('PROCEDURE ');PRINTEL(ARG1)
PRSTRING(' WILL FROM NOW ON BE NAMED ')
PRINTEL(ITEM);NOOLINE(1)
ARG1=ITEM
NEWFN=CONS(ARG1,NEWFN)
DEFINED=CONS(ARG1,DEFINED)
%FINISH; ! FINISH ITEM#ARG1
ARG3=CONS1(DEFINEWORD,MOVE1(LINE)); ! REBUILD LINE
REPHEAD(USERFUN,ARG3); ! REPLACE TITLE LINE IN DEF
FNVAL(ARG1>>8)=USERPRE+USERFUN&M16+W1; ! NEW SPEC
%FINISHELSESTART; ! FINISH ITEM=RETITLE
%IF ITEM=DO %THENSTART; ! LINE FOR IMMEDIATE EVAL
LINE=TL(LINE)
STKSYS(DELLIST)
STKSYS(IN)
EVAL(0,LINE,EACHVAL,WALKFN)
IN=UNSTKSYS
DELLIST=UNSTKSYS
VAL=UNSTACK
%FINISHELSESTART; ! FINISH DO
%IF ITEM&NM=NM %THENSTART; ! A NUMBERED LINE TO INSERT OR
! OR REPLACE EXISTING LINE
FINDLINE(ITEM)
%IF REST#NIL %AND HD(HD(REST))=ITEM %THENSTART; ! A LINE TP REPLACE
DELLIST=CONS(HD(REST),DELLIST); ! SAVE REPLACED LINE
REPHEAD(REST,MOVE1(LINE)); ! AND REPLACE LINE
%FINISHELSE REPTAIL(LESSLINE,CONS1(MOVE1(LINE),REST)); ! INSERT
%FINISHELSESTART; ! FINISH ITEM=NUMBER
%IF ITEM=DELETE %THENSTART
LINE=TL(LINE); ! DISCARD DELETE
ITEM=GETNEXT(LINE); ! GET LINE NUMBER
%IF JUMPFLAG=1 %THENRETURN
%IF ITEM&NM#NM %THENSTART
PRSTRING('DELETE NEEDS A NUMBER')
NOOLINE(1)
%RETURN
%FINISH
FINDLINE(ITEM)
%IF REST=NIL %OR HD(HD(REST))>ITEM %THENSTART;
PRSTRING('NO SUCH LINE')
NOOLINE(1)
%RETURN
%FINISHELSESTART
DELLIST=CONS(HD(REST),DELLIST)
REPTAIL(LESSLINE,TL(REST))
%FINISH
%FINISHELSESTART; ! FINISH ITEM=DELETE
%IF ITEM=UNDO %THENSTART;
%IF DELLIST=NIL %THENSTART
PRSTRING('NONE SAVED')
NOOLINE(1)
%RETURN
%FINISH
LINE=HD(DELLIST)
DELLIST=TL(DELLIST)
->TOP
%FINISHELSESTART; ! FINISH UNDO
%IF ITEM=UNDOS %THENSTART
ITEM=DELLIST
%IF ITEM=NIL %THENSTART
PRSTRING('NONE SAVED')
NOOLINE(1)
%RETURN
%FINISH
%WHILE ITEM#NIL %CYCLE
PRINTLINE(HD(ITEM))
ITEM=TL(ITEM)
%REPEAT
%FINISHELSESTART; ! FINISH UNDOS
DPRINTSTRING(ERRMESS(60))
PRINTLCON(LINE)
DPRINTSTRING(ERRMESS(60))
DPRINTSTRING(ERRMESS(12))
DNEWLINE
%RETURN
%FINISH
%FINISH
%FINISH
%FINISH
%FINISH
%FINISH
%END; ! END EDITLINE
!
DELLIST=NIL
SAVESTK=STKPNT
LP1:SAVEPROM=PROMP
PROMP=' D: '
DPROMPT(PROMP)
LP:LINE=READLINE
%IF LINE=NIL %THEN ->LP
%IF HD(LINE)=END %THENSTART;
PROMP=SAVEPROM
DPROMPT(PROMP);%RETURN;%FINISH
EDITLINE
%IF JUMPFLAG=1 %THENSTART; ! RETURN FROM USERINT OR ERROR
STKPNT=SAVESTK; ! RESTORE STACK TO EDIT ENTRY
%IF JUMPOUT>0 %THENSTART
JUMPOUT=JUMPOUT-1
STACK(VAL)
%RETURN
%FINISH
! JUMPOUT=0
JUMPFLAG=0;
->LP
%FINISH; ! NOTE THAT AN EDIT ENTRY COUNTS TOWARDS AN ABORT N
->LP
%END; ! END EDIT
!
!
!
! FILING SYSTEM SUPPORT ROUTINES
!
!
%ROUTINE MAPFILE(%INTEGER STADDR)
DIRNUM==SHORTINTEGER(STADDR)
DIRPAGES==SHORTINTEGER(STADDR+2)
WRITINGFILE==SHORTINTEGER(STADDR+4)
UNTIDY==SHORTINTEGER(STADDR+6)
NFTEXT==INTEGER(STADDR+8)
DIR==ARRAY(STADDR+16,DIRFORM)
TEXT==ARRAY(STADDR+4096*DIRPAGES-1,TEXTFORM)
! TEXT(0) OVERLAPS DIR. IT IS NOT USED FOR TEXT. SEE LGPRNTSTR
%END; ! END MAPFILE
!
!
%ROUTINE CONOWNFILE
! CONNECT OWN FILE
DEFINE('SM04,'.OWNFILE)
OWNFADDR=SMADDR(4,OWNFLENGTH)
MAPFILE(OWNFADDR)
%END; ! END CONOWNFILE
!
!
%ROUTINE DISCONOWNFILE
CLOSESM(4)
CLEAR('SM04')
DISCONNECT(OWNFILE)
%END; ! END DISCONOWNFILE
!
!
%ROUTINE CONBFILE
! CONNECT BORROWED FILE
DEFINE('SM08,'.BFILE)
BFADDR=SMADDR(8,BFLENGTH)
MAPFILE(BFADDR)
%END; ! END CONBFILE
!
!
%ROUTINE DISCONBFILE
CLOSESM(8)
CLEAR('SM08')
DISCONNECT(BFILE)
%END; ! END DISCONBFILE
!
!
%ROUTINE MAPMASTER
! CONNECT MASTER DIRECTORY
%INTEGER FL,STADDR
DEFINE('SM09,'.MASNUM.'LOGMASTR')
STADDR=SMADDR(9,FL)
MASENTS==INTEGER(STADDR)
USERIDS==ARRAY(STADDR+4,USERFORM)
%END; ! END MAPMASTER
!
!
%ROUTINE DISCONMASTER
CLOSESM(9)
CLEAR('SM09')
DISCONNECT(MASNUM.'LOGMASTR')
%END; ! END DISCONMASTER
!
!
%INTEGERFN SHAREFILE
! CONNECTS TO BORROWED FILE AFTER CHECKING THAT IT IS NOT
! BEING WRITTEN TO BY OWNER
CONBFILE
%IF WRITINGFILE#0 %THENSTART
DISCONBFILE
ERROR('THE OWNER OF THE MEMORY YOU ARE BORROWING IS REMEMBERING A' %C
.' PROCEDURE IN IT. TRY LATER.',EMPTY,1,IN)
%RESULT=1
%FINISH
%RESULT=0
%END; ! END SHAREFILE
!
!
%INTEGERFN SEARCHDIR(%STRING(63) PROC)
! SEARCHES DIR FOR ENTRY WITH NAME PROC
! RETURNS DIR INDEX IF FOUND ELSE 0
%INTEGER I
%IF DIRNUM=0 %THENRESULT=0
%CYCLE I=1,1,DIRNUM
%IF DIR(I)_PROCNAME=PROC %THENRESULT=I
%REPEAT
%RESULT=0
%END; ! ENS SEARCHDIR
!
!
%ROUTINE WRITEDIR(%STRING(63) PROC,%INTEGER TEXTSTART)
! UPDATES DIR WITH ENTRY FOR PROC NAMED PROC WHOSE TEXT STARTS
! AT TEXTSTART
!
%ROUTINE ROLLDOWN
! MOVES TEXT DOWN ONE PAGE OVERALL TO CCLEAR A NEW DIR PAGE
%INTEGER I,J,K
I=(NFTEXT-1)//4096
%IF (NFTEXT-1-I*4096)#0 %THEN I=I+1; ! TOTAL TEXT BEARING PAGES
%CYCLE J=I,-1,1
K=OWNFADDR+(DIRPAGES+J-1)*4096; ! PAGE START ADDRESSES
MOVE(4096,K,K+4096)
%REPEAT
%END; ! END ROLLDOWN
!
%INTEGER I
I=SEARCHDIR(PROC)
%IF I#0 %THENSTART; ! ALREADY THERE
DIR(I)_TEXTINDEX=TEXTSTART
UNTIDY=1
%RETURN
%FINISH
%CYCLE I=1,1,PAGES
%IF DIRNUM<PAGENTRIES(I) %THENEXIT
%IF DIRNUM=PAGENTRIES(I) %THENSTART; ! NEW PAGE REQUIRED FOR THIS ONE
%IF (OWNFLENGTH-DIRPAGES*4096-NFTEXT)<4095 %THENSTART
! NOT A FULL PAGE LEFT IN FILE
FULLFLAG=1
%RETURN
%FINISH
ROLLDOWN; ! PAGE AVAILABLE. MOVE TEXT DOWN 1 PAGE
DIRPAGES=DIRPAGES+1; ! AND ALLOCATE FREED PAGE TO DIR
TEXT==ARRAY(OWNFADDR+4096*DIRPAGES-1,TEXTFORM); ! REMAP TEXT ARRAY
%EXIT; ! FROM CYCLE
%FINISH
%REPEAT
! THIS CYCLE SHOULD NEVER BE COMPLETED.
! EXIT TO HERE WITH DIRNUM IN MIDDLE PF A PAGE, OR AT END OF
! A PAGE, THE NEXT ADJOINING PAGE HAVING BEEN ALLOCATED IN THE
! CYCLE
DIRNUM=DIRNUM+1
DIR(DIRNUM)_PROCNAME=PROC
DIR(DIRNUM)_TEXTINDEX=TEXTSTART
%END; ! END WRITEDIR
!
!
%ROUTINE TIDYFILE
%INTEGER I,PROCNUM,OLDINDEX,CHAR,NEXTCHAR
%STRING(63) WSTR
%RECORDARRAYNAME TDIR (D)
%BYTEINTEGERARRAYNAME TTEXT
%SHORTINTEGERNAME TDIRNUM,TUNTIDY
%SHORTINTEGERNAME TWRITE,TDIRPAGES
%INTEGERNAME TNFTEXT
%INTEGER TFLENGTH,TFADDR
!
PROCNUM=0
%CYCLE I=1,1,DIRNUM
%IF DIR(I)_PROCNAME#'' %THEN PROCNUM=PROCNUM+1
%REPEAT
! PROCNUM HAS NUMBER OF ENTRIES FOR NEW DIR
%CYCLE I=1,1,PAGES
%IF PROCNUM<=PAGENTRIES(I) %THENEXIT
%REPEAT
! EXIT WITH I= NUMBER OF PAGES REQUIRED FOR NEW DIR
! NOW CREATE NEW FILE
NEWSMFILE('LOGOTEMP,40960')
DEFINE('SM10,LOGOTEMP')
TFADDR=SMADDR(10,TFLENGTH)
TDIRNUM==SHORTINTEGER(TFADDR)
TDIRPAGES==SHORTINTEGER(TFADDR+2)
TWRITE==SHORTINTEGER(TFADDR+4)
TUNTIDY==SHORTINTEGER(TFADDR+6)
TNFTEXT==INTEGER(TFADDR+8)
TDIR==ARRAY(TFADDR+16,DIRFORM)
TTEXT==ARRAY(TFADDR+I*4096-1,TEXTFORM)
TDIRPAGES=I
TWRITE=1
TUNTIDY=0
TNFTEXT=1
TDIRNUM=0
%CYCLE I=1,1,DIRNUM
WSTR=DIR(I)_PROCNAME
%IF WSTR='' %THEN ->REP
TDIRNUM=TDIRNUM+1
TDIR(TDIRNUM)_PROCNAME=WSTR
TDIR(TDIRNUM)_TEXTINDEX=TNFTEXT
OLDINDEX=DIR(I)_TEXTINDEX
CHAR=TEXT(OLDINDEX)
%CYCLE
TTEXT(TNFTEXT)=CHAR
OLDINDEX=OLDINDEX+1
TNFTEXT=TNFTEXT+1
%IF OLDINDEX=NFTEXT %THENEXIT
NEXTCHAR=TEXT(OLDINDEX)
%IF CHAR=NL %AND (NEXTCHAR='D' %OR NEXTCHAR='T') %THENEXIT
CHAR=NEXTCHAR
%REPEAT
REP:%REPEAT
! SO THATS IT ALL COPIED. NOW MOVE IT BACK TO ORIGINAL FILE
MOVE(TDIRPAGES*4096+TNFTEXT-1,TFADDR,OWNFADDR)
CLOSESM(10)
CLEAR('SM10')
DESTROY('LOGOTEMP')
TEXT==ARRAY(OWNFADDR+4096*DIRPAGES-1,TEXTFORM)
%END; ! END TIDYFILE
!
!
!
!
!
! TURTLE DEVICE SERVICE ROUTINES
%ROUTINESPEC TSEND(%INTEGER MOTORS,PULSES)
%ROUTINESPEC TSEND1(%INTEGER ARG)
%INTEGERFNSPEC TSCALE(%INTEGER N)
%INTEGERFNSPEC TANGLE(%INTEGER N)
!
%INTEGERFN INTREM(%INTEGER I,J)
%RESULT=I-(I//J)*J
%END; ! END INTREM
!
%INTEGERFN MOD360(%INTEGER I)
I=INTREM(I,360)
%IF I<0 %THENRESULT=I+360 %ELSERESULT=I
%END; ! END MOD360
!
%ROUTINE COORDOK(%INTEGER COORD)
%STRING(80) ERRM
%IF COORD<(-501) %OR COORD>501 %THENSTART
%IF TDEV=3 %OR TDEV=8 %THEN ERRM=ERRMESS(42).'SCREEN' %ELSEC
ERRM=ERRMESS(42).'PAPER'
ERROR(ERRM,EMPTY,1,IN)
%FINISH
%END; ! END COORDOK
!
%INTEGERFN TSTATE
%RESULT=CONS(INTPT(XTURTLE)<<8!NM,CONS(INTPT(YTURTLE)<<8!NM,%C
CONS(HDTURTLE<<8!NM,CONS(PENTURTLE,NIL))))
%END; ! END TSTATE
!
%INTEGERFN IMPNUM(%INTEGER I)
%IF I<0 %THENRESULT=I>>8!T8 %ELSERESULT=I>>8
%END; ! END IMPNUM
!
%INTEGERFN NSR
! NO SPECIAL RESULT
%RESULT=CONS(QQPROC,CONS(FN,NSRTAIL))
%END; ! END NSR
!
%ROUTINE CIRCLETEST(%INTEGER FLAG,RAD,ANG)
%SWITCH SW(0:1)
COORDOK(INTPT(XTURTLE+DX));%IF JUMPFLAG=1 %THENRETURN
COORDOK(INTPT(YTURTLE+DY));%IF JUMPFLAG=1 %THENRETURN
%IF RAD<0 %THEN RAD=-RAD
%IF ANG<0 %THEN ANG=-ANG
->SW(FLAG)
SW(0):; ! LEFT
%IF ANG>=MOD360(360-HDTURTLE) %THENSTART
COORDOK((YC//32)+INTPT(YTURTLE)-RAD);%IF JUMPFLAG=1 %THENRETURN
%FINISH
%IF ANG>=MOD360(270-HDTURTLE) %THENSTART
COORDOK((XC//32)+INTPT(XTURTLE)-RAD);%IF JUMPFLAG=1 %THENRETURN
%FINISH
%IF ANG>=MOD360(180-HDTURTLE) %THENSTART
COORDOK((YC//32)+INTPT(YTURTLE)+RAD);%IF JUMPFLAG=1 %THENRETURN
%FINISH
%IF ANG>=MOD360(90-HDTURTLE) %THENSTART
COORDOK((XC//32)+INTPT(XTURTLE)+RAD);%IF JUMPFLAG=1 %THENRETURN
%FINISH
%RETURN
!
SW(1):; ! RIGHT
%IF ANG>=HDTURTLE %THENSTART
COORDOK((YC//32)+INTPT(YTURTLE)+RAD)
%IF JUMPFLAG=1 %THENRETURN
%FINISH
%IF ANG>=MOD360(HDTURTLE+90) %THENSTART
COORDOK((XC//32)+INTPT(XTURTLE)+RAD);%IF JUMPFLAG=1 %THENRETURN
%FINISH
%IF ANG>=MOD360(HDTURTLE+180) %THENSTART
COORDOK((YC//32)+INTPT(YTURTLE)-RAD);%IF JUMPFLAG=1 %THENRETURN
%FINISH
%IF ANG>=MOD360(HDTURTLE+270) %THENSTART
COORDOK((XC//32)+INTPT(XTURTLE)-RAD);%IF JUMPFLAG=1 %THENRETURN
%FINISH
%RETURN
%END; ! END CIRCLETEST
!
%INTEGERFN CHDEVARG
%INTEGER ARG
ARG=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRESULT=ERR
%IF ARG&NM=0 %THENSTART
ERROR(ERRMESS(10).WA(FN>>8).ERRMESS(20),ARG,1,IN)
%RESULT=ERR
%FINISH
%RESULT=IMPNUM(ARG)
%END; ! END CHDEVARG
!
%ROUTINE SETUP(%INTEGER N,A)
%INTEGER H
%IF N=0 %THENRETURN
H=0
%IF A>180 %THEN A=A-360
%IF PENTURTLE=DOWN %THENSTART
PENTURTLE=UP
TSEND1(32)
H=1
%FINISH
%IF A#0 %THENSTART
%IF A<0 %THEN TSEND(LTBITS,TANGLE(-A)) %ELSE TSEND(RTBITS,TANGLE(A))
%IF JUMPFLAG=1 %THENRETURN
! RIGHT (A)
%FINISH
%IF N<0 %THEN TSEND(BDBITS,TSCALE(-N)) %ELSE TSEND(FDBITS,TSCALE(N))
%IF JUMPFLAG=1 %THENRETURN
! FORWARD(N)
%IF A#0 %THENSTART
%IF A<0 %THEN TSEND(RTBITS,TANGLE(-A)) %ELSE TSEND(LTBITS,TANGLE(A))
%IF JUMPFLAG=1 %THENRETURN
! LEFT(A)
%FINISH
%IF H=1 %THENSTART
PENTURTLE=DOWN
TSEND1(32)
%FINISH
%END; ! END SETUP
!
%ROUTINE TSEND1(%INTEGER ARG)
%IF ARG=0 %THENRETURN
%IF PENTURTLE=UP %THEN BINARG1<-ARG+PENBIT %ELSE BINARG1<-ARG
! JAM TRANSFER ONLY REQUIREDD FOR HOOTBIT
SENDBIN(0,1)
%END; ! END TSEND1
!
%ROUTINE TSEND(%INTEGER MOTORS,PULSES)
%WHILE PULSES>1500 %CYCLE; ! 500 MOVE UNITS OR 375 ROTATE UNITS
%IF QUITFLAG=1 %THENSTART
QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1
CLESET; ! THIS IS THE POINT OF IT. TO BREAK A CLOG IN H316
STACK(CONS(QQPROC,CONS(QUIT,NSRTAIL)))
%RETURN
%FINISH
TSEND1(MOTORS+1500)
PULSES=PULSES-1500
%REPEAT
TSEND1(MOTORS+PULSES)
%END; ! END TSEND
!
%ROUTINE PINDSEND(%INTEGER DIRECTION,ANGLE)
! SENDS FOR PLOTTER INDICATOR
BINARG1=5
%WHILE ANGLE>360 %CYCLE
%IF QUITFLAG=1 %THENSTART; ! AS FOR TSEND
QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1
CLESET
STACK(CONS(QQPROC,CONS(QUIT,NSRTAIL)))
%RETURN
%FINISH
BINARG2=360+DIRECTION
SENDBIN(0,2)
ANGLE=ANGLE-360
%REPEAT
BINARG2=ANGLE+DIRECTION
SENDBIN(0,2)
%END; ! END PINDSEND
!
%INTEGERFN TSCALE(%INTEGER M)
! FOR 75 MM WHEEEL, ONE PULSE GIVES 0.06814 CM TRAVEL
! WITH GEAR RATIO 5:36 AT 48 PULSES TO ONE REV
%RESULT=M*3
%END; ! END TSCALE
!
%INTEGERFN TANGLE(%INTEGER A)
! TRACK 312.5 MM, WHEEL 75 MM DIA, RATIO 5:36,
! THUS 4 PULSES TO ONE DEGREE TURN
%RESULT=4*A
%END; ! END TANGLE
!
%ROUTINE GTARCLEFT(%INTEGER R,A)
%INTEGER P,Q,N,TH,C,D,E
%REAL RV1,B, DX,DY
!
%ROUTINE ARCAUX(%INTEGER M,A)
%IF A=0 %THENRETURN
%IF M=0 %THENSTART
HDTURTLE=HDTURTLE-A
%FINISHELSESTART
HDTURTLE=HDTURTLE+A
%FINISH
CALC TURTLE
%END; ! END ARCAUX
!
C=-1;D=0;TH=2
%IF A<0 %THENSTART
HDTURTLE=MOD360(HDTURTLE-180)
CALC TURTLE
R=-R;A=-A
%FINISH
%IF R<0 %THENSTART
C=0;D=-1;R=-R
%FINISH
LOOP:RV1=2.0*R*SIN(TH*3.14159/1440.0)
N=INT(RV1)
%IF A>(TH+1) %AND R>N %AND (N<1 %ORC
(N-RV1)>0.1 %OR (N-RV1)<(-0.1)) %THENSTART
TH=TH+1
->LOOP
%FINISH
P=A//TH
Q=INTREM(A,TH)
E=INTPT(TH/2.0)
ARCAUX(C,E)
%WHILE P#0 %OR Q#0 %CYCLE
B=HDTURTLE*3.14159/180.0
DX=N*COS(B)
DY=N*SIN(B)
VECTOR(DX,DY)
XTURTLE=XTURTLE+DX
YTURTLE=YTURTLE+DY
ARCAUX(C,TH)
P=P-1
%IF P=0 %AND Q#0 %THENSTART
N=INT(2.0*R*SIN(Q*3.14159/1440.0))
TH=Q
P=1
Q=0
%FINISH
%REPEAT
ARCAUX(D,E)
%END; ! END TARCLEFT
!
%ROUTINE TARCLEFT(%INTEGER R,A)
%INTEGER P,Q,N,TH,C,D,E,TTTXCOR,TTTYCOR,TTHEAD
%REAL RV1,B
!
%ROUTINE ARCAUX(%INTEGER M,A)
%IF A=0 %THENRETURN
%IF M=0 %THENSTART
TSEND(RTBITS,A)
%IF JUMPFLAG=1 %THENRETURN
TTHEAD=TTHEAD-A
%FINISHELSESTART
TSEND(LTBITS,A)
%IF JUMPFLAG=1 %THENRETURN
TTHEAD=TTHEAD+A
%FINISH
%END; ! END ARCAUX
!
R=3*R;TTTXCOR=3*INTPT(XTURTLE);TTTYCOR=3*INTPT(YTURTLE);
A=4*A;C=-1;D=0;TH=2
%IF A<0 %THENSTART
HDTURTLE=MOD360(HDTURTLE-180)
TSEND(RTBITS,720); ! RIGHT(180)
%IF JUMPFLAG=1 %THENRETURN
R=-R;A=-A
%FINISH
TTHEAD=4*HDTURTLE
%IF R<0 %THENSTART
C=0;D=-1;R=-R
%FINISH
LOOP:RV1=2.0*R*SIN(TH*3.14159/1440.0)
N=INT(RV1)
%IF A>(TH+1) %AND R>N %AND (N<1 %ORC
(N-RV1)>0.1 %OR (N-RV1)<(-0.1)) %THENSTART
TH=TH+1
->LOOP
%FINISH
P=A//TH
Q=INTREM(A,TH)
E=INTPT(TH/2.0)
ARCAUX(C,E)
%IF JUMPFLAG=1 %THENRETURN
%WHILE P#0 %OR Q#0 %CYCLE
B=TTHEAD*3.14159/720.0
TTTXCOR=TTTXCOR+INT(N*COS(B))
TTTYCOR=TTTYCOR+INT(N*SIN(B))
TSEND(FDBITS,N)
%IF JUMPFLAG=1 %THENRETURN
ARCAUX(C,TH)
%IF JUMPFLAG=1 %THENRETURN
P=P-1
%IF P=0 %AND Q#0 %THENSTART
N=INT(2.0*R*SIN(Q*3.14159/1440.0))
TH=Q
P=1
Q=0
%FINISH
%REPEAT
ARCAUX(D,E)
%IF JUMPFLAG=1 %THENRETURN
XTURTLE=TTTXCOR/3.0
YTURTLE=TTTYCOR/3.0
HDTURTLE=MOD360(INT(TTHEAD/4.0))
%END; ! END TARCLEFT
!
%ROUTINE CLAIMDEVICE(%INTEGER N)
%IF TDEV#0 %THENSTART; ! ALREADY GOR A DEVICE
%IF TDEV=N %THEN ERROR('YOU ALREADY HAVE IT',EMPTY,1,IN) %ELSEC
ERROR(ERRMESS(41),EMPTY,1,IN)
%RETURN
%FINISH
! SO NOT GOT A DEVICE
%IF STATUS('ECMI50.'.TDEVNAMES(N),1)<0 %THENC
ERROR(ERRMESS(8).TDEVNAMES(N).ERRMESS(9),EMPTY,1,IN) %ANDRETURN
! STATUS WITH LEVEL=1 FORCES CONNECTION IF POSSIBLE
! RESULT<0 INDICATES CONNECTION NOT POSSIBLE, IE DEVICE IN USE
!
! SO NOW GOT DEVICE
TDEV=N
PRSTRING(TDEVNAMES(N).' CONNECTED');NOOLINE(1)
%END; ! END CLAIMDEVOCE
!
%ROUTINE FREEDEVICE
! ONLY IF TDEV#0
CLESET %UNLESS TDEV = 8 ; !CLEAR AND RESET TO HONEY AS APRROPRIATE
DISCONNECT('ECMI50.'.TDEVNAMES(TDEV))
TDEV=0
%END; ! END FREEDEVICE
!
%STRING(63)%FN CHECKID(%INTEGER IDLIST)
! ENTERED AT START OF SESSION TO CHECK USER ID, AND IF OK
! RETURNS STRING OF CONCATENATED ID ELEMENTS.
! ALSO USED BY EDITMASTER, BORROW & LIBRARY
%INTEGER HEAD,ID
%STRING(63) RES,W
%IF IDLIST=NIL %THENRESULT=''
ID=IDLIST;RES=''
%WHILE ID#NIL %CYCLE
HEAD=HD(ID);ID=TL(ID)
%IF HEAD&WM=0 %THENRESULT=''; ! NOT A WORD
W=WA(HEAD>>8)
%IF (LENGTH(RES)+LENGTH(W)+1)>63 %THENSTART
PRSTRING('IDENTIFIER TOO LONG - ')
PRINTEL(IDLIST);NOOLINE(1)
%RESULT=''
%FINISH
RES=RES.W.' '
%REPEAT
%RESULT=RES
%END; ! END CHECKID
!
%ROUTINE BORROW(%INTEGER ARG1,FN)
%IF BORROWFLAG=1 %THENSTART
ERROR('YOU ARE ALREADY BORROWING FROM '.BORROWEE,EMPTY,1,IN)
%RETURN
%FINISH
%IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL)
%IF ARG1&LM#LM %THENSTART
ERROR(WA(FN>>8).' MUST HAVE A WORD OR LIST AS SECOND INPUT.' %C
.'
IT WAS GIVEN ',ARG1,1,IN)
%RETURN
%FINISH
BORROWEE=CHECKID(ARG1)
%IF BORROWEE='' %THENSTART
ERROR('WRONGLY FORMATTED IDENTIFIER - ',ARG1,1,IN)
%RETURN
%FINISH
MAPMASTER
%CYCLE ARG1=1,1,MASENTS
%IF BORROWEE=USERIDS(ARG1) %THEN ->BR1
%REPEAT
!NOT FOUND
DISCONMASTER
ERROR(BORROWEE.ERRMESS(17),EMPTY,1,IN)
%RETURN
!ARG1=MN, SO WE WANT 'LOGOMN'
BR1:%IF BORROWEE=USER %THENSTART
PRSTRING('YOU NEED NOT BORROW FROM YOURSELF.')
NOOLINE(1)
%FINISHELSESTART
BFILE=MASNUM.'LOGO'.NUMTOSTR(ARG1<<8)
BORROWFLAG=1
BORROWEE->WSTR1.(' ')
PRSTRING('YOU ARE NOW CONNECTED TO '.WSTR1.'''S PERMANENT MEMORY')
NOOLINE(1)
%FINISH
DISCONMASTER
%END; ! END BORROW
!
!
!
!
%ROUTINE GCOMPILE (%REAL X,Y, %INTEGER MODE)
!COMPILES A VECTOR DEFINITION INTO GT42 CODE
%EXTRINSIC %INTEGER %ARRAY MODE TABLE (0:2)
!
%INTEGER PENV
%IF PENTURTLE=DOWN %THEN PENV=PEN %ELSE PENV=0
%IF MODE # GMODE %THEN %C
CURPIC= CONSG(MODETABLE(MODE),CURPIC) %AND GMODE=MODE
CURPIC=CONSG((CONV(INT(Y))),CONSG(PENV!(CONV(INT(X))),CURPIC))
%END
!
%INTEGERFN GETNUMB (%INTEGERNAME LIST,%STRING(64) FUNC)
!
! POPS A NUMBER FROM THE HEAD OF LIST, REPLACING LIST BY
! TAIL OF LIST. FUNC IS ONLY USED IF LIST IS EMPTY (=NIL)
! WHEN AN ERROR DIAGNOSTIC IS OUTPUT
!
%INTEGER W1
%IF LIST=NIL %THEN ERROR (FUNC.' NEEDS A LONGER LIST ',ARG2,1,IN) %C
%AND %RESULT=-100000; ! CHECK THAT LIST NON-EMPTY
W1 = HD(LIST)
LIST=TL(LIST)
%IF W1&NM #NM %THEN ERROR (FUNC.' NEEDS A NUMBER ',W1,1,IN) %C
%AND %RESULT=-100000; !CHECK THAT YOU HAVE A NUMBER
%RESULT = W1 >> 8; !AND RETURN ITS VALUE
%END
%INTEGERFN CHECKXY (%INTEGER N)
!
! CHECKS THAT GIVEN COORDINATE IS WITHIN THE SCREEN
! BOUNDARY (-512 -> 512)
!
%WHILE N > 512 %THEN N=N-1024
%WHILE N < -512 %THEN N=N+1024
%RESULT=N
%END;
!
!
%ROUTINE VECTOR (%REAL X,Y)
%INTEGER T
%IF DEFPICTURE = 1 %THEN GCOMPILE(X,Y,VECTORM) %ANDRETURN
%IF PENTURTLE=DOWN %AND SHOW TURTLE 42 = 1 %THENSTART
T = INT PT(SQRT(X**2 + Y**2)/5)
%IF T=0 %THEN T=1 ;! ZERO TIME WILL BUGGER EXEK
SET42(CHPIC) ;! SET 42 TO PICTURE MODE
MODE42(VECTORM)
CH3(GRADV) ;!AND SEND A GRADUAL VECTOR
CH3(T) ;! DURATION
CH3(INT(X))
CH3(INT(Y))
GRAPHP=GRAPHP+4
%RETURN
%FINISH
%IF PENTURTLE = DOWN %THEN VECORPOINT(INT(X),INT(Y),PEN,VECTORM) %C
%ELSE VECORPOINT(INT(X),INT(Y),0,VECTORM)
%END
!
!
%ROUTINE POINT (%REAL ATX,ATY)
! SENDS A DARK POINT INSTRUCTION TO DISPLAY
!
! ONLY USED FROM SETX SETY SETTURTLE AND INITIALISATION
!
!
%INTEGER SAVE GP
%IF DEF PICTURE = 1 %THEN GCOMPILE(ATX,ATY,POINTM)
SAVE GP = GRAPHP
VECORPOINT(INT(ATX),INT(ATY),0,POINTM)
GRAPHP = SAVE GP
%END
!
!
%ROUTINE MODIFY EXEC
!
!*** 'HACK' DP1 EXEC FOR LOGO USE
!*** TO GIVE IMPROVED STATIC/DYNAMIC PICTURE
!*** CAPABILITIES
!
%CONSTINTEGERARRAY NEW HEADER (1:15)= %C
X'E000', X'3FF0', X'F700' ,X'0000', %C
X'2028', X'2028', X'8F5C', X'404A', %C
X'4F8A', X'6F8A', X'404A', X'E000', %C
X'2012', X'E000', X'201A'
%CONSTINTEGERARRAY NEW TAIL (1:5) = %C
X'9354', 512, 512, X'E000', X'2028'
%CONSTINTEGER REF1=X'1016'
%CONSTINTEGER REF2=X'145E'
%CONSTINTEGER STADDR= X'200E'
%INTEGER I
!
SET42(CHPIC)
GRAPHP = INIT GRAPHP
LBR
CH3(SETN)
CH3(STADDR)
CH3(15)
%CYCLE I=1,1,15
CH3(NEW HEADER(I))
%REPEAT
CH3(SETN)
CH3(CORE BOTTOM)
CH3(5)
%CYCLE I=1,1,5
CH3(NEW TAIL(I))
%REPEAT
CH3(SET)
CH3(REF1)
CH3(TURTLE START) ;!**IMPORTANT** MOD TO 'CLEAR'
;! INSTR IN GT42 EXEC
CH3(SET)
CH3(REF2)
CH3(TURTLE START)
RBR
%END
!
!
%ROUTINE CALC TURTLE
%INTEGER I
!
! THIS ROUTINE SENDS A VECTOR DESCRIPTION OF THE
! TURTLE TO THE GT42 - ASSUMING THAT THE TURTLE
! IS CURRENTLY BEING SHOWN
!
%INTEGERFN VEC (%INTEGER DX,DY)
!CONVERTS DX,DY INTO A GT42 SHORT VECTOR
!
%IF DX<0 %THEN DX=X'40'+((0-DX)&X'3F') %ELSEC
DX= DX&X'3F'
%IF DY<0 %THEN DY=X'40'+((0-DY)&X'3F') %ELSEC
DY=DY&X'3F'
%RESULT = X'4000'!(DX<<7)!DY
%END
%CONSTINTEGERARRAY X(1:4)= 0,31, -31, 0
%CONSTINTEGERARRAY Y(1:4)= -10,10,10,-10
!*** FUNCTIONS TO CALCULATE NEW X AND Y DISPLACEMENTS ***
!*** (DONE LIKE THIS FOR EASE OF MODIFICATION ) ***
%INTEGERFN NEWX
%RESULT=INT(X(I)*COS(HDTURTLE/57.3)-SIN(HDTURTLE/57.3) %C
*Y(I))
%END
%INTEGERFN NEWY
%RESULT= INT(Y(I)*COS(HDTURTLE/57.3)+X(I)*SIN %C
(HDTURTLE/57.3))
%END
%CONSTINTEGER TURTLE MODE=X'8F5C'
%RETURN %IF SHOW TURTLE 42 = 0
%RETURN %IF DEF PICTURE = 1 ;! DON'T BOTHER WITH TURTLE IN DEF MODE
SET42(CHPIC)
LBR;CH3(SETN);CH3(TURTLE START);CH3(5)
CH3(TURTLE MODE) ;! SEND DESCRIPTION
%CYCLE I=1,1,4
CH3(VEC(NEWX,NEWY))
%REPEAT
RBR
%RETURN
!
!OTHERWISE PART OF PICTURE DEFINITION
! SO IGNORE THE BLOODY THING
!
%END
%ROUTINE SHOW TURTLE
SHOW TURTLE 42 = 1
CALC TURTLE
%END
%ROUTINE HIDE TURTLE
!
! *** SENDS CODE TO THE GT42 TO PREVENT TURTLE BEING DRAWN
! *** (ACTUALLY DUMPS A DJMP INST{UCTION ROUND THE TURTLE BLOCK)
!
SET42(CHPIC) ;! SET GRAPHICS MODE
LBR
CH3(SETN) ; CH3(TURTLE START) ; CH3(2)
CH3(DJUMP) ;! JUMP INSTRUCTION
CH3(DLAST) ;! TO END OF DISPLAY FILE
RBR
SHOW TURTLE 42 = 0
%END
!
%ROUTINE SET CORE POINTER (%INTEGER TO VAL)
! USED TO ASSIGN TO END OF CORE POINTER IN GT42
!
! ALSO UPDATES EMAS LOCAL VARIABLE PICTURE POINTER
!
%CONSTINTEGER CORE POINTER= X'2010' ;! ADDRESS IN GT42
!
PICTURE POINTER = TO VAL ;! UPDATE EMAS POINTER
SET42(CHPIC)
CH3(SET) ;! AND GT42 POINTER
CH3(CORE POINTER)
CH3(PICTURE POINTER) ;! NEW VALUE
%END
%ROUTINE INC (%INTEGER W1)
! *** ROUTINE TO SEND A PICTURE DEFINITION
! *** TO THE GT42 -- CALLED FROM 'INCLUDE' AND 'PUT'
!
%INTEGER W2,W3,W4
SET42(CHPIC) ;! SET GT42 MODE
W2=LISTLEN(INDEX42(W1)_PTR) ;! LENGTH OF PICTURE
INDEX42(W1)_FADDR = PICTURE POINTER
PICTURE POINTER = PICTURE POINTER - W2 -W2 -2
LBR; CH3(SETN); CH3(PICTURE POINTER); CH3(W2)
;! HEADER !!
W3=CONSG(DJUMP,CONSG(INDEX42(W1)_FADDR, %C
TL(TL(INDEX42(W1)_PTR))))
%UNTIL W3=NIL %THEN CH3(HD(W3)>>8) %AND W3=TL(W3)
RBR ;! DELIMITER
INDEX42(W1)_PTR42=PICTURE POINTER;! START ADDR IN 42
SET CORE POINTER (PICTURE POINTER)
%IF PICTURE POINTER < GRAPHP %THEN ERROR ( %C
'GT42 DISPLAY FILE CORRUPTED :-
TOO MUCH DISPLAY DATA',EMPTY,1,IN) %AND %RETURN
%END
!
!
!
! INFERENCE SERVICE ROUTINES
!
%ROUTINE SAYL(%STRING(20) MESS, %INTEGER RULE,INDENT)
%IF GETVAL(THINKALOUD,ENVIR)=TRUE %THENSTART
PRINTSTRING('*');SPACES(INDENT);CHAROUT=CHAROUT+1+INDENT;
PRSTRING(MESS);PRINTEL(RULE)
NOOLINE(1)
%FINISH
%END; ! END SAYL
!
%INTEGERFN FITSQ(%INTEGER FACT,PAT)
%INTEGER VAL
%IF FACT=NIL %THENSTART
%IF PAT=NIL %THEN %RESULT=TRUE
%RESULT=FALSE
%FINISH
%IF PAT=NIL %THEN %RESULT=FALSE
%IF HD(PAT)=QUOTE %THEN SETVAL(HD(TL(PAT)),HD(FACT),ENVIR) %C
%ELSESTART
%IF HD(PAT)=DOTS %THENSTART
VAL=GETVAL(HD(TL(PAT)),ENVIR)
%IF VAL =UNDEF %THENSTART
ERROR('NO VALUE HAS BEEN GIVEN TO VARIABLE -',%C
HD(TL(PAT)),1,IN)
%RESULT=UNSTACK
%FINISH
%IF VAL#HD(FACT) %THEN %RESULT=FALSE
%FINISHELSESTART
%IF HD(PAT)#HD(FACT) %THEN %RESULT=FALSE
%RESULT=FITSQ(TL(FACT),TL(PAT))
%FINISH
%FINISH
%RESULT=FITSQ(TL(FACT),TL(TL(PAT)))
%END; ! END FITSQ
!
%ROUTINE SETVBLS(%INTEGER VBLS)
%INTEGER I,L
VBLS=HD(TL(VBLS));L=LISTLEN(VBLS)
%IF ENVIR=BASENVIR %THENSTART
%CYCLE I=1,1,L
SETVAL(HD(VBLS),NIL,ENVIR)
VBLS=TL(VBLS)
%REPEAT
%FINISHELSESTART
%CYCLE I=1,1,L
STACK(NIL)
%REPEAT
ENVIR=SETBIND(VBLS,ENVIR)
%FINISH
%END; ! END SETVBLS
!
%ROUTINE TRYIMPRULE(%INTEGER RULE,FACT,KEYED,INDENT)
%INTEGER VBLS,PRED
VBLS=HD(RULE);RULE=TL(RULE)
%IF VBLS#NIL %THEN SETVBLS(VBLS)
%IF KEYED=TRUE %THEN PRED=FITSQ(TL(FACT),TL(HD(RULE))) %C
%ELSE PRED=FITSQ(FACT,HD(RULE))
%IF JUMPFLAG=1 %THEN STACK(PRED) %ANDRETURN
%IF PRED=TRUE %THENSTART
SAYL('USING RULE ',CONS(IMPLIES,RULE),INDENT)
ADDFACT(HD(TL(RULE)),INDENT+3)
%FINISH
%END; ! END TRYIMPRULE
!
%INTEGERFN VBLSIN(%INTEGER TERMS)
%INTEGER TERM,VBLS, RULE, FIRST
VBLS=NIL; RULE=HD(TERMS); TERMS=TL(TERMS)
FIRST=TRUE
%WHILE TERMS#NIL %CYCLE
TERM=HD(TERMS)
%IF TERM&LM#LM %OR TERM=NIL %THEN ->VBLERR
%IF HD(TERM)&LM=LM %THEN ->VBLERR
%WHILE TERM#NIL %CYCLE
%IF QUITFLAG=1 %THENSTART
QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0
%RESULT=QUIT
%FINISH
%IF HOLDFLAG=1 %THENSTART
HOLDFLAG=0;STKSYS(TERM);STKSYS(TERMS);STKSYS(VBLS)
ERROR('USER INTERRUPT',EMPTY,0,IN)
VBLS=UNSTKSYS;TERMS=UNSTKSYS;TERM=UNSTKSYS
%IF JUMPFLAG=1 %THEN %RESULT=UNSTACK
%FINISH
%IF HD(TERM)=QUOTE %THENSTART
TERM=TL(TERM)
%IF TERM=NIL %OR HD(TERM)&WM#WM %THEN ->VBLERR
VBLS=CONS(HD(TERM),VBLS)
%FINISHELSESTART
%IF HD(TERM)=DOTS %THENSTART
%IF RULE=TOINFER %AND FIRST=TRUE %THEN ->VBLERR
TERM=TL(TERM)
%IF TERM=NIL %OR HD(TERM)&WM#WM %THEN ->VBLERR
%FINISH
%FINISH
TERM=TL(TERM)
%REPEAT
TERMS=TL(TERMS); FIRST=FALSE
%REPEAT
%IF VBLS#NIL %THEN VBLS=CONS(NEW,CONS(VBLS,NIL))
%RESULT=VBLS
VBLERR:ERROR('INVALID PATTERN FOR IMPLIES/TOINFER RULE -',TERMS,1,IN)
%RESULT=UNSTACK
%END; ! END VBLSIN
!
%INTEGERFN INSTANCE(%INTEGER ITEM)
%INTEGER VAL
%IF ITEM=NIL %THEN %RESULT=NIL
%IF QUITFLAG=1 %THENSTART
QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0
%RESULT=QUIT
%FINISH
%IF HOLDFLAG=1 %THENSTART
HOLDFLAG=0;STKSYS(ITEM)
ERROR('USER INTERRUPT',EMPTY,0,IN)
ITEM=UNSTKSYS
%IF JUMPFLAG=1 %THEN %RESULT=UNSTACK
%FINISH
VAL=HD(ITEM)
%IF VAL=DOTS %THENSTART
ITEM=TL(ITEM)
%IF ITEM=NIL %OR HD(ITEM)&WM#WM %THEN ->INSTERR
VAL=GETVAL(HD(ITEM),ENVIR)
%IF VAL=UNDEF %THEN %C
ERROR('NO VALUE HAS BEEN GIVEN TO VARIABLE - ',HD(ITEM),1,IN) %C
%AND %RESULT=UNSTACK
%FINISHELSESTART
%IF VAL=QUOTE %THENSTART
%IF TL(ITEM)=NIL %OR HD(TL(ITEM))&WM#WM %THEN ->INSTERR
%FINISH
%FINISH
%RESULT=CONS(VAL,INSTANCE(TL(ITEM)))
INSTERR:ERROR('INVALID PATTERN FOR FACT -',ITEM,1,IN)
%RESULT=UNSTACK
%END; ! END INSTANCE
!
%ROUTINE ADDLINK(%INTEGER ITEM,KEY, %INTEGERARRAYNAME LINKS)
%INTEGER VAL,IND
%IF KEY&WM#WM %THENSTART
%IF LINKS(2)#FACT %THEN ITEM=CONS(LINKS(2),TL(ITEM))
ERROR('INVALID PATTERN FOR ASSERT - ',ITEM,1,IN)
%RETURN
%FINISH
BVALUE(LINKS(1)>>8)=CONS(ITEM,BVALUE(LINKS(1)>>8))
IND=KEY>>8
VAL=FINDASS(ASSOCWA(IND),LINKS(2))
%IF VAL#NIL %THENSTART
VAL=TL(HD(VAL))
REPHEAD(VAL,CONS(ITEM,HD(VAL)))
%FINISHELSESTART
BVALUE(LINKS(3)>>8)=CONS(KEY,BVALUE(LINKS(3)>>8))
ASSOCWA(IND)=CONS(CONS(LINKS(2),CONS(CONS(ITEM,NIL),NIL)), %C
ASSOCWA(IND))
%FINISH
%END; ! END ADDLINK
!
%ROUTINE ADDRULE(%INTEGER RULE,INDENT,%INTEGERARRAYNAME LINKS)
%INTEGER VBLS
%IF TL(RULE)=NIL %THENSTART
ERROR('INVALID PATTERN FOR IMPLIES/TOINFER RULE -',TL(RULE),1,IN)
%RETURN
%FINISH
STKSYS(RULE)
VBLS=VBLSIN(RULE)
RULE=UNSTKSYS
%IF JUMPFLAG=1 %THEN STACK(VBLS) %ANDRETURN
VBLS=CONS(VBLS,TL(RULE))
ADDLINK(VBLS,HD(HD(TL(RULE))),LINKS)
%IF JUMPFLAG=1 %THENRETURN
SAYL('ADDED RULE ',RULE,INDENT)
%END; ! END ADDRULE
!
%ROUTINE ADDFACT(%INTEGER FACT,INDENT)
%INTEGER KEY,VAL
FACT=INSTANCE(FACT)
%IF JUMPFLAG=1 %THEN STACK(FACT) %ANDRETURN
KEY=HD(FACT)
ADDLINK(FACT,KEY,DBASE)
%IF JUMPFLAG=1 %THENRETURN
SAYL('ADDED FACT ',FACT,INDENT)
VAL=FINDASS(ASSOCWA(KEY>>8),IMPLIES)
%IF VAL#NIL %THENSTART
VAL=HD(TL(HD(VAL)))
%WHILE VAL#NIL %CYCLE
%IF QUITFLAG=1 %THENSTART
QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0
STACK(QUIT)
%RETURN
%FINISH
%IF HOLDFLAG=1 %THENSTART
HOLDFLAG=0;STKSYS(VAL);STKSYS(FACT)
ERROR('USER INTERRUPT',EMPTY,0,IN)
FACT=UNSTKSYS;VAL=UNSTKSYS
%IF JUMPFLAG=1 %THEN %RETURN
%FINISH
STKSYS(VAL);STKSYS(FACT)
TRYIMPRULE(HD(VAL),FACT,TRUE,INDENT)
FACT=UNSTKSYS;VAL=UNSTKSYS
%IF JUMPFLAG=1 %THENRETURN
VAL=TL(VAL)
%REPEAT
%FINISH
VAL=FINDASS(ASSOCWA(QUOTE>>8),IMPLIES)
%IF VAL#NIL %THENSTART
VAL=HD(TL(HD(VAL)))
%WHILE VAL#NIL %CYCLE
%IF QUITFLAG=1 %THENSTART
QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0
STACK(QUIT)
%RETURN
%FINISH
%IF HOLDFLAG=1 %THENSTART
HOLDFLAG=0;STKSYS(VAL);STKSYS(FACT)
ERROR('USER INTERRUPT',EMPTY,0,IN)
FACT=UNSTKSYS;VAL=UNSTKSYS
%IF JUMPFLAG=1 %THEN %RETURN
%FINISH
STKSYS(VAL);STKSYS(FACT)
TRYIMPRULE(HD(VAL),FACT,FALSE,INDENT)
FACT=UNSTKSYS;VAL=UNSTKSYS
%IF JUMPFLAG=1 %THENRETURN
VAL=TL(VAL)
%REPEAT
%FINISH
%END; ! END ADDFACT
!
%INTEGERFN TRYBEST(%INTEGERARRAYNAME LINKS,%INTEGERNAME EPAT,KEYED,%C
%INTEGER IPAT)
%INTEGER IT
%IF HD(IPAT)=QUOTE %THENSTART
EPAT=IPAT;KEYED=FALSE
%RESULT=BVALUE(LINKS(1)>>8)
%FINISH
KEYED=TRUE
%IF HD(IPAT)=DOTS %THENSTART
EPAT=TL(TL(IPAT))
IT=GETVAL(HD(TL(IPAT)),ENVIR)
%IF IT=UNDEF %THENSTART
ERROR('NO VALUE HAS BEEN GIVEN TO VARIABLE - ',HD(TL(IPAT)),1,IN)
%RESULT=UNSTACK
%FINISH
%FINISHELSESTART
EPAT=TL(IPAT);IT=HD(IPAT)
%FINISH
%IF IT&WM#WM %THENSTART
ERROR('INVALID PATTERN - ',IPAT,1,IN)
%RESULT=UNSTACK
%FINISH
IT=FINDASS(ASSOCWA(IT>>8),LINKS(2))
%IF IT#NIL %THEN %RESULT=HD(TL(HD(IT)))
%RESULT=NIL
%END; ! END TRYBEST
!
%INTEGERFN INFINSTANCE(%INTEGER TERM)
%INTEGER VF,IT
%STRING(10) STR1,STR2
%IF TERM=NIL %THEN %RESULT=NIL
%IF QUITFLAG=1 %THENSTART
QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0
%RESULT=QUIT
%FINISH
%IF HOLDFLAG=1 %THENSTART
HOLDFLAG=0;STKSYS(TERM);STKSYS(ARG1);STKSYS(ARG3)
ERROR('USER INTERRUPT',EMPTY,0,IN)
ARG3=UNSTKSYS;ARG1=UNSTKSYS;TERM=UNSTKSYS
%IF JUMPFLAG=1 %THEN %RESULT=UNSTACK
%FINISH
%IF HD(TERM)=DOTS %THENSTART
VF=GETVAL(HD(TL(TERM)),ENVIR)
%IF VF=UNDEF %THENSTART
ERROR('NO VALUE HAS BEEN GIVEN TO VARIABLE - ',HD(TL(TERM)),1,IN)
%RESULT=UNSTACK
%FINISH
%IF VF&LM#LM %THEN %RESULT=CONS(VF,INFINSTANCE(TL(TL(TERM))))
%IF HD(VF)=QUOTE %THENSTART
REPHEAD(VF,DOTS)
%RESULT=CONS(QUOTE,CONS(HD(TL(VF)),INFINSTANCE(TL(TL(TERM)))))
%FINISH
%IF HD(VF)#DOTS %THEN %RESULT=CONS(VF,INFINSTANCE(TL(TL(TERM))))
%RESULT=CONS(DOTS,CONS(HD(TL(VF)),INFINSTANCE(TL(TL(TERM)))))
%FINISH
%IF HD(TERM)#QUOTE %THEN %RESULT=CONS(HD(TERM),INFINSTANCE(TL(TERM)))
GENOS=GENOS+1
STR1=WA(VBL>>8)
STR2=NUMTOSTR(GENOS)
IT=PUT(STR1.STR2)
SETVAL(HD(TL(TERM)),CONS(DOTS,IT),ENVIR)
%RESULT=CONS(QUOTE,CONS(IT,INFINSTANCE(TL(TL(TERM)))))
%END; ! END INFINSTANCE
!
%INTEGERFN INFFITSQ(%INTEGER PAT,RPAT)
%INTEGER P1,RP1
INFF1:%IF PAT=NIL %THENSTART
%IF RPAT=NIL %THEN %RESULT=TRUE
%RESULT=FALSE
%FINISH
%IF RPAT=NIL %THEN %RESULT=FALSE
P1=HD(PAT);PAT=TL(PAT)
RP1=HD(RPAT);RPAT=TL(RPAT)
%IF P1=DOTS %THENSTART
P1=GETVAL(HD(PAT),ENVIR)
%IF P1=UNDEF %THENSTART
ERROR('NO VALUE HAS BEEN GIVEN TO VARIABLE - ',HD(PAT),1,IN)
%RESULT=UNSTACK
%FINISH
PAT=TL(PAT)
%FINISHELSESTART
%IF P1=QUOTE %THENSTART
P1=HD(PAT);PAT=TL(PAT)
%IF RP1=QUOTE %THENSTART
SETVAL(HD(RPAT),CONS(QUOTE,CONS(P1,NIL)),ENVIR)
RPAT=TL(RPAT)
%FINISHELSE SETVAL(P1,RP1,ENVIR)
->INFF1
%FINISH
%FINISH
%IF RP1=QUOTE %THENSTART
SETVAL(HD(RPAT),P1,ENVIR)
RPAT=TL(RPAT)
->INFF1
%FINISH
%IF P1=RP1 %THEN ->INFF1
%RESULT=FALSE
%END; ! END INFFITSQ
!
%INTEGERFN TRYINFRULE(%INTEGER RULE,EPAT,PAT,KEYED,INDENT)
%INTEGER VBLS,PRED,LIST,SAVLIST,TEMP
VBLS=HD(RULE);RULE=TL(RULE)
%IF VBLS#NIL %THEN SETVBLS(VBLS)
%IF KEYED=TRUE %THEN PRED=INFFITSQ(EPAT,TL(HD(RULE))) %C
%ELSE PRED=INFFITSQ(EPAT,HD(RULE))
%IF JUMPFLAG=1 %THEN %RESULT=PRED
%IF PRED=TRUE %THENSTART
SAYL('USING RULE ',CONS(TOINFER,RULE),INDENT)
LIST=CONS(NIL,NIL)
SAVLIST=LIST
%WHILE TL(RULE)#NIL %CYCLE
STKSYS(RULE);STKSYS(LIST);STKSYS(SAVLIST);STKSYS(PAT)
TEMP=INFINSTANCE(HD(TL(RULE)))
PAT=UNSTKSYS;SAVLIST=UNSTKSYS;LIST=UNSTKSYS;RULE=UNSTKSYS
%IF JUMPFLAG=1 %THEN %RESULT=TEMP
REPTAIL(LIST,CONS(TEMP,NIL))
RULE=TL(RULE);LIST=TL(LIST)
%REPEAT
REPTAIL(LIST,TL(PAT))
LIST=TL(SAVLIST)
%RESULT=TRYINFQ(LIST,INDENT+3)
%FINISH
%RESULT=FALSE
%END; !END TRYINFRULE
!
%INTEGERFN BINDINGS(%INTEGER VLIST)
%INTEGER VAL
%IF VLIST=NIL %THEN %RESULT=NIL
VAL=GETVAL(HD(VLIST),ENVIR)
%IF VAL=UNDEF %THENSTART
ERROR('NO VALUE HAS BEEN GIVEN TO VARIABLE - ',HD(VLIST),1,IN)
%RESULT=UNSTACK
%FINISH
%RESULT=CONS(VAL,BINDINGS(TL(VLIST)))
%END; ! END BINDINGS
!
%INTEGERFN TRYINFQ(%INTEGER PAT,INDENT)
%INTEGER IPAT,EPAT,KEYED,IT,FACT,RES,TEMP
%IF PAT=NIL %THENSTART
%IF SW=156 %THENSTART
FACT=BINDINGS(ARG1);
%IF JUMPFLAG=1 %THEN %RESULT=FACT
IT=ARG3
%WHILE IT#NIL %CYCLE
STKSYS(IT);STKSYS(FACT)
RES=EQUAL(HD(IT),FACT)
FACT=UNSTKSYS;IT=UNSTKSYS
%IF JUMPFLAG=1 %THEN %RESULT=RES
%IF RES=TRUE %THEN %RESULT=TRUE
IT=TL(IT)
%REPEAT
ARG3=CONS(FACT,ARG3)
%FINISH
%RESULT=TRUE
%FINISH
IPAT=HD(PAT)
%IF IPAT&LM#LM %OR IPAT=NIL %THEN ->TRYINFERR
IT=IPAT
%WHILE IT#NIL %CYCLE
%IF QUITFLAG=1 %THENSTART
QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0
%RESULT=QUIT
%FINISH
%IF HOLDFLAG=1 %THENSTART
HOLDFLAG=0;STKSYS(IT);STKSYS(IPAT);STKSYS(PAT)
STKSYS(ARG1);STKSYS(ARG3)
ERROR('USER INTERRUPT',EMPTY,0,IN)
ARG3=UNSTKSYS;ARG1=UNSTKSYS
PAT=UNSTKSYS;IPAT=UNSTKSYS;IT=UNSTKSYS
%IF JUMPFLAG=1 %THEN %RESULT=UNSTACK
%FINISH
%IF HD(IT)=DOTS %OR HD(IT)=QUOTE %THENSTART
IT=TL(IT)
%IF IT=NIL %THEN ->TRYINFERR
%FINISH
IT=TL(IT)
%REPEAT
SAYL('LOOK FOR ',IPAT,INDENT)
%IF HD(IPAT)=NOT %THENSTART
%IF TL(IPAT)=NIL %THEN ->TRYINFERR
IPAT=TL(IPAT)
STACK(SW);SW=154
STKSYS(PAT);STKSYS(IPAT)
RES=DEDUCEQ(IPAT,INDENT+3)
SW=UNSTACK;IPAT=UNSTKSYS;PAT=UNSTKSYS
%IF JUMPFLAG=1 %THEN %RESULT=RES
%IF RES=TRUE %THEN %RESULT=FALSE
SAYL('SUCCEED WITH - ',CONS(NOT,IPAT),INDENT)
%RESULT=TRYINFQ(TL(PAT),INDENT+3)
%FINISH
IT=TRYBEST(DBASE,EPAT,KEYED,IPAT)
%IF JUMPFLAG=1 %THEN %RESULT=IT
%WHILE IT#NIL %CYCLE
%IF QUITFLAG=1 %THENSTART
QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0
%RESULT=QUIT
%FINISH
%IF HOLDFLAG=1 %THENSTART
HOLDFLAG=0;STKSYS(IT);STKSYS(IPAT);STKSYS(PAT)
STKSYS(EPAT);STKSYS(ARG1);STKSYS(ARG3)
ERROR('USER INTERRUPT',EMPTY,0,IN)
ARG3=UNSTKSYS;ARG1=UNSTKSYS;EPAT=UNSTKSYS
PAT=UNSTKSYS;IPAT=UNSTKSYS;IT=UNSTKSYS
%IF JUMPFLAG=1 %THEN %RESULT=UNSTACK
%FINISH
%IF KEYED=TRUE %THEN FACT=TL(HD(IT)) %ELSE FACT=HD(IT)
TEMP=FITSQ(FACT,EPAT)
%IF JUMPFLAG=1 %THEN %RESULT=TEMP
%IF TEMP=TRUE %THENSTART
SAYL('SUCCEED WITH ',HD(IT),INDENT)
STKSYS(IT);STKSYS(PAT);STKSYS(IPAT)
RES=TRYINFQ(TL(PAT),INDENT+3)
IPAT=UNSTKSYS;PAT=UNSTKSYS;IT=UNSTKSYS
%IF JUMPFLAG=1 %THEN %RESULT=RES
%IF RES=TRUE %AND (SW=154 %OR SW=155) %THEN %RESULT=TRUE
%FINISH
IT=TL(IT)
%REPEAT
IT=TRYBEST(INFLINKS,EPAT,KEYED,IPAT)
%IF JUMPFLAG=1 %THEN %RESULT=IT
%WHILE IT#NIL %CYCLE
%IF QUITFLAG=1 %THENSTART
QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0
%RESULT=QUIT
%FINISH
%IF HOLDFLAG=1 %THENSTART
HOLDFLAG=0;STKSYS(IT);STKSYS(IPAT);STKSYS(PAT)
STKSYS(EPAT);STKSYS(ARG1);STKSYS(ARG3)
ERROR('USER INTERRUPT',EMPTY,0,IN)
ARG3=UNSTKSYS;ARG1=UNSTKSYS;EPAT=UNSTKSYS
PAT=UNSTKSYS;IPAT=UNSTKSYS;IT=UNSTKSYS
%IF JUMPFLAG=1 %THEN %RESULT=UNSTACK
%FINISH
STKSYS(IT);STKSYS(PAT);STKSYS(EPAT);STKSYS(IPAT)
RES=TRYINFRULE(HD(IT),EPAT,PAT,KEYED,INDENT)
IPAT=UNSTKSYS;EPAT=UNSTKSYS;PAT=UNSTKSYS;IT=UNSTKSYS
%IF JUMPFLAG=1 %THEN %RESULT=RES
%IF RES=TRUE %AND (SW=154 %OR SW=155) %THEN %RESULT=TRUE
IT=TL(IT)
%REPEAT
%IF KEYED=TRUE %THENSTART
KEYED=FALSE; EPAT=IPAT
IT=FINDASS(ASSOCWA(QUOTE>>8),TOINFER)
%IF IT#NIL %THEN IT=HD(TL(HD(IT)))
%WHILE IT#NIL %CYCLE
%IF QUITFLAG=1 %THENSTART
QUITFLAG=0;JUMPFLAG=1;JUMPOUT=0
%RESULT=QUIT
%FINISH
%IF HOLDFLAG=1 %THENSTART
HOLDFLAG=0;STKSYS(IT);STKSYS(PAT);STKSYS(EPAT);
STKSYS(ARG1);STKSYS(ARG3)
ERROR('USER INTERRUPT',EMPTY,0,IN)
ARG3=UNSTKSYS;ARG1=UNSTKSYS;EPAT=UNSTKSYS
PAT=UNSTKSYS;IT=UNSTKSYS
%IF JUMPFLAG=1 %THEN %RESULT=UNSTACK
%FINISH
STKSYS(IT);STKSYS(PAT);STKSYS(EPAT)
RES=TRYINFRULE(HD(IT),EPAT,PAT,KEYED,INDENT)
EPAT=UNSTKSYS;PAT=UNSTKSYS;IT=UNSTKSYS
%IF JUMPFLAG=1 %THEN %RESULT=RES
%IF RES=TRUE %AND (SW=154 %OR SW=155) %THEN %RESULT=TRUE
IT=TL(IT)
%REPEAT
%FINISH
SAYL('FAILED',EMPTY,INDENT)
%RESULT=FALSE
TRYINFERR:ERROR('INVALID PATTERN -',IPAT,1,IN)
%RESULT=UNSTACK
%END; ! END TRYINFQ
!
%INTEGERFN DEDUCEQ(%INTEGER PATTERN,INDENT)
%IF HD(PATTERN)&LM#LM %THEN PATTERN=CONS(PATTERN,NIL)
%RESULT=TRYINFQ(PATTERN,INDENT)
%END; ! END DEDUCEQ
!
!
-> SYSFUN(SW)
!
! INPUT OUTPUT
SYSFUN(1):; ! PRINT
%IF TDEV = 8 %THEN SET42(CHTXT)
ARG1=UNSTACKINPUT
%IF JUMPFLAG=1 %THENRETURN
%IF ARG1=ENEL %THEN NOOLINE(1) %ELSE PRINTEL(ARG1)
NOOLINE(1)
STACK(NSR)
%RETURN
!
!
SYSFUN(2):SYSFUN(6):; ! TYPE TYPESET
%IF TDEV = 8 %THEN SET42(CHTXT)
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1=ENEL %THEN NOOLINE(1) %ELSE PRINTEL(ARG1)
%IF SW=6 %THEN PRINTEL(SPACE1)
STACK(NSR)
%RETURN; ! END TYPE
!
!
SYSFUN(3):; ! REPLY
%IF TDEV = 8 %THEN SET42(CHTXT)
BLEVEL=2
DPROMPT('REPLY: ')
FILL LINE BUFFER
ARG1=READLIST(BLEVEL)
%IF ARG1=ERR %THEN ->SYSFUN(3)
STACK(ARG1)
DPROMPT(PROMP)
%RETURN; ! END REPLY
!
!
SYSFUN(4):; ! GETWORD
BLEVEL=2
%IF TDEV = 8 %THEN SET42(CHTXT)
DPROMPT('WORD: ')
FILL LINE BUFFER
ARG1=READLIST(BLEVEL)
%IF ARG1=ERR %THEN ->SYSFUN(4)
%IF ARG1=NIL %THEN STACK(EMPTY) %ELSESTART
ARG1=HD(ARG1)
%IF ARG1&LM=LM %THENSTART;PRSTRING('NOT A WORD');NOOLINE(1);
->SYSFUN(4)
%FINISH
STACK(ARG1)
%FINISH
DPROMPT(PROMP)
%RETURN; ! END GETWORD
!
!
SYSFUN(5):; ! SAY
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1=ENEL %THEN NOOLINE(1) %ELSESTART
ENUF=0;SEP=''
%IF ARG1&LM=LM %THEN PRINTLCON(ARG1) %ELSE PRINTWN(ARG1)
%FINISH
NOOLINE(1)
STACK(NSR)
%RETURN; ! END SAY
!
!
! ARITHMETIC
SYSFUN(10):; ! + OR SUM
READYNUM
%IF JUMPFLAG=1 %THENRETURN
%IF ARG1<0 %THENSTART
%IF ARG2<0 %THEN CHECKSUM(-ARG1,-ARG2)
%FINISHELSESTART; ! ARG1>=0
%IF ARG2>0 %THEN CHECKSUM(ARG1,ARG2)
%FINISH
%IF JUMPFLAG=1 %THENRETURN
ARG3=CHECKSIZE(ARG1+ARG2)
%IF JUMPFLAG=1 %THENRETURN
STACK(ARG3<<8!NM)
%RETURN; ! END SUM
!
!
!
SYSFUN(11):; ! - OR DIFFERENCE
READYNUM
%IF JUMPFLAG=1 %THENRETURN
%IF ARG1<0 %THENSTART
%IF ARG2>0 %THEN CHECKSUM(-ARG1,ARG2)
%FINISHELSESTART; ! ARG1>=0
%IF ARG2<0 %THEN CHECKSUM(ARG1,-ARG2)
%FINISH
%IF JUMPFLAG=1 %THENRETURN
ARG3=CHECKSIZE(ARG1-ARG2)
%IF JUMPFLAG=1 %THENRETURN
STACK(ARG3<<8!NM)
%RETURN; ! END DIFFEREBCE
!
!
SYSFUN(12):; ! * OR TIMES
READYNUM
%IF JUMPFLAG=1 %THENRETURN
%IF ARG1=0 %OR ARG2=0 %THEN STACK(NM) %ANDRETURN
%IF ARG1<0 %THENSTART
%IF ARG2<0 %THEN CHECKPROD(-ARG1,-ARG2) %ELSE CHECKPROD(-ARG1,ARG2)
%FINISHELSESTART; ! ARG1>=0
%IF ARG2<0 %THEN CHECKPROD(ARG1,-ARG2) %ELSE CHECKPROD(ARG1,ARG2)
%FINISH
%IF JUMPFLAG=1 %THENRETURN
ARG3=CHECKSIZE(ARG1*ARG2);%IF JUMPFLAG=1 %THENRETURN
STACK(ARG3<<8!NM)
%RETURN; ! END TIMES
!
!
SYSFUN(13):; ! / OR QUOTIENT
READYNUM
%IF JUMPFLAG=1 %THENRETURN
%IF ARG2=0 %THENSTART
ERROR(ERRMESS(62),EMPTY,1,IN)
%RETURN
%FINISH
STACK((ARG1//ARG2)<<8!NM)
%RETURN; ! END QUOTIENT
!
!
SYSFUN(14):; ! REMAINDER
READYNUM
%IF JUMPFLAG=1 %THENRETURN
%IF ARG2=0 %THENSTART
ERROR(ERRMESS(62),EMPTY,1,IN)
%RETURN
%FINISH
STACK((ARG1-(ARG1//ARG2)*ARG2)<<8!NM)
%RETURN; ! END REMAINDER
!
!
SYSFUN(15):; ! DIVISION
READYNUM
%IF JUMPFLAG=1 %THENRETURN
%IF ARG2=0 %THENSTART
ERROR(ERRMESS(62),EMPTY,1,IN)
%RETURN
%FINISH
ARG3=ARG1//ARG2; ! ARG3 USED TEMP
STACK(CONS(ARG3<<8!NM,CONS((ARG1-ARG3*ARG2)<<8! NM,NIL)))
%RETURN; ! END DIVISION
!
!
SYSFUN(16):; ! MAXIMUM
READYNUM
%IF JUMPFLAG=1 %THENRETURN
%IF ARG1>=ARG2 %THEN STACK(ARG1<<8!NM) %ELSE STACK(ARG2<<8!NM)
%RETURN; ! END MAXIMUM
!
!
SYSFUN(17):; ! MINIMUM
READYNUM
%IF JUMPFLAG=1 %THENRETURN
%IF ARG1<=ARG2 %THEN STACK(ARG1<<8!NM) %ELSE STACK(ARG2<<8!NM)
%RETURN; ! END MIMIMUM
!
!
!
! CHARACTER AND LIST MANIPULATION
!
SYSFUN(20):; ! FIRST
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1<0 %THENSTART
ERROR(WA(FN>>8).ERRMESS(45),ARG1,1,IN)
%RETURN
%FINISH
%IF ARG1=EMPTY %THENSTART
ERROR(WA(FN>>8).ERRMESS(44),EMPTY,1,IN)
%RETURN
%FINISH
%IF ARG1=NIL %THENSTART
ERROR(WA(FN>>8).ERRMESS(46),EMPTY,1,IN)
%RETURN
%FINISH
%IF ARG1&LM=LM %THEN STACK(HD(ARG1)) %ANDRETURN
%IF ARG1&NM=NM %THEN WSTR1=NUMTOSTR(ARG1) %ELSE WSTR1=WA(ARG1>>8)
STACK(PUT(FROMSTRING(WSTR1,1,1)))
%RETURN; ! END FIRST
!
!
SYSFUN(21):; ! LAST
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1<0 %THENSTART
ERROR(WA(FN>>8).ERRMESS(45),ARG1,1,IN)
%RETURN
%FINISH
%IF ARG1=EMPTY %THENSTART
ERROR(WA(FN>>8).ERRMESS(44),EMPTY,1,IN)
%RETURN
%FINISH
%IF ARG1=NIL %THENSTART
ERROR(WA(FN>>8).ERRMESS(46),EMPTY,1,IN)
%RETURN
%FINISH
%IF ARG1&LM=LM %THENSTART
%WHILE TL(ARG1)#NIL %CYCLE
%IF QUITFLAG=1 %THENSTART
QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1
STACK(QUIT)
%RETURN
%FINISH
%IF HOLDFLAG=1 %THENSTART
ERROR('USER INTERRUPT',EMPTY,0,IN)
%IF JUMPFLAG=1 %THENRETURN
%FINISH
ARG1=TL(ARG1)
%REPEAT
STACK(HD(ARG1))
%RETURN;
%FINISH
%IF ARG1&NM=NM %THEN WSTR1=NUMTOSTR(ARG1) %ELSE WSTR1=WA(ARG1>>8)
ARG2=LENGTH(WSTR1)
STACK(PUT(FROMSTRING(WSTR1,ARG2,ARG2)))
%RETURN; ! END LAST
!
!
SYSFUN(22):; ! REST
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1<0 %THENSTART
ERROR(WA(FN>>8).ERRMESS(45),ARG1,1,IN)
%RETURN
%FINISH
%IF ARG1=EMPTY %THENSTART
ERROR(WA(FN>>8).ERRMESS(44),EMPTY,1,IN)
%RETURN
%FINISH
%IF ARG1=NIL %THENSTART
ERROR(WA(FN>>8).ERRMESS(46),EMPTY,1,IN)
%RETURN
%FINISH
%IF ARG1&LM=LM %THEN STACK(TL(ARG1)) %ANDRETURN
%IF ARG1&NM=NM %THEN WSTR1=NUMTOSTR(ARG1) %ELSE WSTR1=WA(ARG1>>8)
ARG2=LENGTH(WSTR1)
%IF ARG2=1 %THEN STACK(EMPTY) %ELSESTART
ARG3=PUT(FROMSTRING(WSTR1,2,ARG2))
%IF ARG3=ERR %THENSTART; ! NUMBER TOO LRAGE
ERROR(ERRMESS(30).WA(FN>>8).ERRMESS(31).ERRMESS(63),ARG1,1,IN)
%RETURN
%FINISH
STACK(ARG3)
%FINISH
%RETURN; ! EN REST
!
!
SYSFUN(23):; ! BUTLAST
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1<0 %THENSTART
ERROR(WA(FN>>8).ERRMESS(45),ARG1,1,IN)
%RETURN
%FINISH
%IF ARG1=EMPTY %THENSTART
ERROR(WA(FN>>8).ERRMESS(44),EMPTY,1,IN)
%RETURN
%FINISH
%IF ARG1=NIL %THENSTART
ERROR(WA(FN>>8).ERRMESS(46),EMPTY,1,IN)
%RETURN
%FINISH
%IF ARG1&LM=LM %THENSTART
ARG2=NIL; ! ARG2 USED TEMP
%WHILE TL(ARG1)#NIL %CYCLE
%IF QUITFLAG=1 %THENSTART
QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1
STACK(QUIT)
%RETURN
%FINISH
%IF HOLDFLAG=1 %THENSTART
ERROR('USER INTERRUPT',EMPTY,0,IN)
%IF JUMPFLAG=1 %THENRETURN
%FINISH
ARG2=CONS(HD(ARG1),ARG2)
ARG1=TL(ARG1)
%REPEAT
! ARG2 NOW HAS ARG1 LESS LAST ELEMENT REVERSED
ARG1=NIL
%WHILE ARG2#NIL %CYCLE
ARG1=CONS(HD(ARG2),ARG1)
ARG2=TL(ARG2)
%REPEAT
STACK(ARG1)
%RETURN;
%FINISH
%IF ARG1&NM=NM %THEN WSTR1=NUMTOSTR(ARG1) %ELSE WSTR1=WA(ARG1>>8)
ARG2=LENGTH(WSTR1)
%IF ARG2=1 %THEN STACK(EMPTY) %ELSESTART
ARG3=PUT(FROMSTRING(WSTR1,1,ARG2-1))
%IF ARG3=ERR %THENSTART; ! NUMBER TOO LARGE
ERROR(ERRMESS(30).WA(FN>>8).ERRMESS(31).ERRMESS(63),ARG1,1,IN)
%RETURN
%FINISH
STACK(ARG3)
%FINISH
%RETURN; ! END BUTLAST
!
!
SYSFUN(24):; ! WORD
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
WORD
%RETURN; ! END WORD
!
!
SYSFUN(25):; ! LIST
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
STACK(CONS(ARG1,CONS(ARG2,NIL)))
%RETURN; ! ND LIST
!
!
SYSFUN(26):; ! FIRSTPUT
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG2&LM=LM %THENSTART; ! ARG2 A LIST
STACK(CONS(ARG1,ARG2))
%RETURN
%FINISH
WORD
%RETURN; ! END FIRSTPUT
!
!
SYSFUN(27):; ! LASTPUT
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
LASTPUT
%RETURN; ! END LASTPUT
!
!
SYSFUN(28):; ! JOIN
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&LM#LM %THENSTART
ERROR(ERRMESS(10).WA(FN>>8).ERRMESS(19),ARG1,1,IN)
%RETURN
%FINISH
%IF ARG2&LM#LM %THENSTART
ERROR(ERRMESS(10).WA(FN>>8).ERRMESS(19),ARG2,1,IN)
%RETURN
%FINISH
ARG3=NIL; ! ARG3 USED TEMP
%WHILE ARG1#NIL %CYCLE
%IF QUITFLAG=1 %THENSTART
QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1
STACK(QUIT)
%RETURN
%FINISH
%IF HOLDFLAG=1 %THENSTART
ERROR('USER INTERRUPT',EMPTY,0,IN)
%IF JUMPFLAG=1 %THENRETURN
%FINISH
ARG3=CONS(HD(ARG1),ARG3)
ARG1=TL(ARG1)
%REPEAT
! ARG3 NOW ARG1 REVERSED
%WHILE ARG3#NIL %CYCLE
ARG2=CONS(HD(ARG3),ARG2)
ARG3=TL(ARG3)
%REPEAT
STACK(ARG2); ! LISTS APPENDED
%RETURN; ! END JOIN
!
!
SYSFUN(29):; ! COUNT
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1<0 %THENSTART
ERROR(WA(FN>>8).ERRMESS(45),ARG1,1,IN)
%RETURN
%FINISH
%IF ARG1&LM=LM %THENSTART
ARG2=0
%WHILE ARG1#NIL %CYCLE
%IF QUITFLAG=1 %THENSTART
QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1
STACK(QUIT)
%RETURN
%FINISH
%IF HOLDFLAG=1 %THENSTART
ERROR('USER INTERRUPT',EMPTY,0,IN)
%IF JUMPFLAG=1 %THENRETURN
%FINISH
ARG2=ARG2+1
ARG1=TL(ARG1)
%REPEAT
STACK(ARG2<<8!NM)
%RETURN
%FINISH
%IF ARG1&NM=NM %THEN WSTR1=NUMTOSTR(ARG1) %ELSE WSTR1=WA(ARG1>>8)
STACK(LENGTH(WSTR1)<<8!NM)
%RETURN; ! END COUNT
!
!
! PREDICATES AND CONDITIONALS
!
!
!
!
SYSFUN(30):; ! LESS THAN
READYNUM
%IF JUMPFLAG=1 %THENRETURN
%IF 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
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG3=EQUAL(ARG1,ARG2)
STACK(ARG3)
%RETURN; ! END EQUAL TO
!
!
SYSFUN(35):; !ZEROQ
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&NM=NM %AND ARG1>>8=0 %C
%THEN STACK(TRUE) %ELSE STACK(FALSE)
%RETURN; ! END ZEROQ
!
!
SYSFUN(36):; ! NUMBERQ
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&NM=NM %THEN STACK(TRUE) %ELSE STACK(FALSE)
%RETURN; ! END NUMBERQ
!
!
SYSFUN(37):; ! WORDQ
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&WM=WM %THEN STACK(TRUE) %ELSE STACK(FALSE)
%RETURN; ! END WORDQ
!
!
SYSFUN(38):; !LISTQ
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&LM=LM %THEN STACK(TRUE) %ELSE STACK(FALSE)
%RETURN; ! END LISTQ
!
!
SYSFUN(39):; !EMPTYQ
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1=NIL %OR ARG1=EMPTY %C
%THEN STACK(TRUE) %ELSE STACK(FALSE)
%RETURN; !END EMPTYQ
!
!
SYSFUN(40):; ! BOTH
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1=TRUE %AND ARG2=TRUE %C
%THEN STACK(TRUE) %ELSE STACK(FALSE)
%RETURN; ! END BOTH
!
!
SYSFUN(41):; ! EITHER
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1=TRUE %OR ARG2=TRUE %C
%THEN STACK(TRUE) %ELSE STACK(FALSE)
%RETURN; ! END EITHER
!
!
SYSFUN(42):; !NOT
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1=TRUE %THEN STACK(FALSE) %ELSE STACK(TRUE)
%RETURN; ! END NOT
!
!
!
SYSFUN(50):; ! TEST
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1=TRUE %THEN TSTFLG=1 %ELSESTART
%IF ARG1=FALSE %THEN TSTFLG=0 %ELSESTART
ERROR('BAD ARG FOR TEST - ',ARG1,1,IN)
%RETURN
%FINISH
%FINISH
STACK(NSR)
%RETURN; ! END TEST
!
!
SYSFUN(51):; ! IFTRUE
%IF TSTFLG=1 %THENSTART
EVAL(0,IN,EACHVAL,WALKFN)
%IF JUMPFLAG=1 %THENRETURN
%FINISHELSESTART
IN=NIL
STACK(NSR)
%FINISH
%RETURN; ! END IFTRUE
!
!
SYSFUN(52):; ! IFFALSE
%IF TSTFLG=0 %THENSTART
EVAL(0,IN,EACHVAL,WALKFN)
%IF JUMPFLAG=1 %THENRETURN
%FINISHELSESTART
IN=NIL
STACK(NSR)
%FINISH
%RETURN; ! END IFFALSE
!
!
SYSFUN(53):; ! IF
IN=CONS(FN,IN); ! PUT BACK IF
ARG1=NIL;ARG2=NIL;ARG3=NIL
W1=EXTRACT(ARG1,ARG2,ARG3)
%IF W1#EMPTY %THENSTART
ERROR('MISSING ',W1,1,IN)
%RETURN
%FINISH
! ARG1 HAS IF COND REVERSED
! ARG2 HAS THEN THENCLAUSE REVERSED
! ARG3 HAS ELSE ELSECLAUSE REVERSED OR NIL
ARG1=TL(REVERSE(ARG1)); ! REVERSE AND REMOVE LEADING IF
ARG2=TL(REVERSE(ARG2)); ! REMOVE LEADING THEN
%IF ARG3#NIL %THEN ARG3=TL(REVERSE(ARG3))
! ARG1 NOW HAS COND,ARG2 THENCLAUSE AND ARG3 ELSECLAUSE
! ALL OR ANY MAY BE NIL
%IF ARG1=NIL %THENSTART
ERROR('NULL CONDITION',EMPTY,1,IN)
%RETURN
%FINISH
STKSYS(ARG2);STKSYS(ARG3);STKSYS(IN)
EVAL(0,ARG1,EACHVAL,WALKFN); ! EVAL CONDITION
IN=UNSTKSYS;ARG3=UNSTKSYS;ARG2=UNSTKSYS
%IF JUMPFLAG=1 %THENRETURN
W1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN; ! RESULT OF CONDITION
%IF W1=TRUE %THENSTART; ! COND TRUE
%IF ARG2=NIL %THENSTART
ERROR('NULL THEN CLAUSE',EMPTY,1,IN)
%RETURN
%FINISHELSESTART
STKSYS(ARG1);STKSYS(ARG3);STKSYS(IN)
EVAL(0,ARG2,EACHVAL,WALKFN); ! EVAL THEN CLAUSE
DUMLAB: IN=UNSTKSYS;ARG3=UNSTKSYS;ARG1=UNSTKSYS
! DUMLAB INSERTED TO AVOID COMPILER ERRROR RESULTING IN
! ADDRESS ERROR ON RETURN TO HERE.
%IF JUMPFLAG=1 %THENRETURN
W2=UNSTACK
%FINISH
%FINISHELSESTART; ! W1#TRUE
%IF W1=FALSE %THENSTART
%IF ARG3=NIL %THEN W2=NSR %ELSESTART
STKSYS(ARG1);STKSYS(ARG2);STKSYS(IN)
EVAL(0,ARG3,EACHVAL,WALKFN)
IN=UNSTKSYS;ARG2=UNSTKSYS;ARG1=UNSTKSYS
%IF JUMPFLAG=1 %THENRETURN
W2=UNSTACK
%FINISH
%FINISHELSESTART; ! W1#TRUE AND #FALSE
ERROR('BAD CONDITION - ',W1,1,IN)
%RETURN
%FINISH
%FINISH
STACK(W2)
%RETURN; ! END IF
!
!
SYSFUN(54):; ! WHILE
IN=CONS(FN,IN)
ARG1=NIL;ARG2=NIL;ARG3=NIL
W1=EXTRACT(ARG1,ARG2,ARG3)
%IF W1#EMPTY %THENSTART
ERROR('MISSING ',W1,1,IN)
%RETURN
%FINISH
! ARG1 HAS 'WHILE COND' REVERSED
! ARG2 HAS 'THEN THENCLAUSE' REVERSED
ARG1=TL(REVERSE(ARG1))
ARG2=TL(REVERSE(ARG2))
! ARG1 NOW HAS COND, ARG2 HAS THENCLAUSE
! ONE OR BOTH MAY BE NIL
%IF ARG1=NIL %THENSTART
ERROR('NULL CONDITION',EMPTY,1,IN)
%RETURN
%FINISH
%IF ARG2=NIL %THENSTART
ERROR('NULL THEN CLAUSE',EMPTY,1,IN)
%RETURN
%FINISH
ARG3=NSR; ! RESULT IF COND FALSE FIRST TIME ROUTND
%CYCLE
W1=ARG1
STKSYS(ARG1);STKSYS(ARG2);STKSYS(IN)
EVAL(0,W1,EACHVAL,WALKFN)
IN=UNSTKSYS;ARG2=UNSTKSYS;ARG1=UNSTKSYS
%IF JUMPFLAG=1 %THENRETURN
W2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF W2=TRUE %THENSTART
W1=ARG2
STKSYS(ARG1);STKSYS(ARG2);STKSYS(IN)
EVAL(0,W1,EACHVAL,WALKFN)
IN=UNSTKSYS;ARG2=UNSTKSYS;ARG1=UNSTKSYS
%IF JUMPFLAG=1 %THENRETURN
ARG3=UNSTACK; ! RESULT
%FINISHELSESTART
%IF W2=FALSE %THENEXIT %ELSESTART
ERROR('BAD CONDITION - ',W2,1,IN)
%RETURN
%FINISH
%FINISH
%REPEAT
STACK(ARG3)
%RETURN; ! END WHILE
!
!
SYSFUN(60):; ! DEFINE
REDEF=0
%IF WALKFN#UNDEF %THENSTART
ERROR('YOU CANNOT DEFINE A PROCEDURE WHILE IN STEPPING MODE',%C
EMPTY,1,IN)
%RETURN
%FINISH
%IF IN=NIL %THENSTART
ERROR(ERRMESS(38),FN,1,IN)
%RETURN
%FINISH
W1=REVQUOTE(IN); ! CHECKS FORMAT AS "WORD "WORD ETC
%IF JUMPFLAG=1 %THENRETURN
ARG1=HD(TL(IN)); ! PROC NAME
ARG2=FNVAL(ARG1>>8); ! FUN SPEC IF ANY
%IF ARG2=0 %THEN ->MAKESPEC
%IF ARG2&USERPRE=USERPRE %THENSTART; ! GOT EXISTING USER DEF
%IF DEVICE=TTY %THENSTART; ! THIS ONE NOT FROM FILE
ERROR(ERRMESS(6),ARG1,1,IN)
%RETURN
%FINISHELSE REDEF=1
%FINISHELSESTART; ! NOT USERPRE. SO SYSTEM
ERROR(ERRMESS(43),EMPTY,1,IN)
%RETURN
%FINISH
MAKESPEC:W1=LISTLEN(W1)-1; ! NO OF PARAMS
%IF W1>127 %THENSTART
ERROR('TOO MANY INPUTS FOR ',ARG1,1,IN)
%RETURN
%FINISH
! SO ALL OK
%IF REDEF=1 %THEN OLDFN(ARG1>>8)=ARG2 %ELSE DEFINED=CONS(ARG1,DEFINED)
ARG3=CONS1(CONS1(FN,MOVE1(IN)),NIL); ! REBUILD LINE IN FNSPACE
FNVAL(ARG1>>8)=USERPRE+ARG3&M16+W1; ! SPEC
FROMLIST(NEWFN,ARG1) %UNLESS NEWFN=NIL
EDIT(ARG3); ! FOR REST OF DEFN
%IF JUMPFLAG=1 %THENRETURN
%IF DEVICE=TTY %THEN NEWFN=CONS(ARG1,NEWFN)
DEVICE=TTY
%IF REDEF=1 %THENSTART
DPRINTSTRING(ERRMESS(58).WA(ARG1>>8).ERRMESS(59))
%FINISHELSESTART
PRINTEL(ARG1)
PRSTRING(' DEFINED')
%FINISH
IN=NIL
NOOLINE(1)
STACK(NSR)
%RETURN
!
!
SYSFUN(61):; ! CHANGE
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF WALKFN#UNDEF %THENSTART
ERROR('YOU CANNOT CHANGE A PROCEDURE WHILE IN STEPPING MODE', %C
EMPTY,1,IN)
%RETURN
%FINISH
%IF ARG1&WM#WM %THENSTART
ERROR(WA(FN>>8).ERRMESS(26),ARG1,1,IN)
%RETURN
%FINISH
ARG2=FNVAL(ARG1>>8); ! GET SPEC
%IF ARG2=0 %THENSTART
ERROR(ERRMESS(21).WA(ARG1>>8).ERRMESS(23),FN,1,IN)
%RETURN
%FINISH
%IF ARG2&USERPRE#USERPRE %THENSTART
ERROR(WA(FN>>8).ERRMESS(25),ARG1,1,IN)
%RETURN
%FINISH
ARG2=ARG2&M16!LM; ! POINTER TO LIST DEF
EDIT(ARG2)
%IF JUMPFLAG=1 %THENRETURN
FROMLIST(NEWFN,ARG1) %UNLESS NEWFN=NIL
NEWFN=CONS(ARG1,NEWFN)
NOOLINE(1)
PRINTEL(ARG1)
PRSTRING(' CHANGED')
NOOLINE(1)
STACK(NSR)
%RETURN; ! END EDIT
!
!
SYSFUN(62):; ! MAKE
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&WM#WM %THENSTART
ERROR(ERRMESS(53),ARG1,1,IN)
%RETURN
%FINISH
%IF ARG1=EMPTY %THENSTART
ERROR('YOU CANNOT USE THE EMPTY WORD AS A NAME',EMPTY,1,IN)
%RETURN
%FINISH
SETVAL(ARG1,ARG2,ENVIR)
STACK(NSR)
%RETURN; ! END MAKE
!
!
SYSFUN(63):; ! NEW
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1=EMPTY %THENSTART
ERROR('YOU CANNOT USE THE EMPTY WORD AS A NAME',EMPTY,1,IN)
%RETURN
%FINISH
%IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL) %ELSE CHKLIST(ARG1)
%IF JUMPFLAG=1 %THENRETURN
ARG2=LISTLEN(ARG1)
%IF ARG2=0 %THEN STACK(NSR) %ANDRETURN
%IF ENVIR=BASENVIR %THENSTART; ! CREATE GLOBALS
%CYCLE ARG3=1,1,ARG2
SETVAL(HD(ARG1),NIL,ENVIR)
ARG1=TL(ARG1)
%REPEAT
%FINISHELSESTART; ! CREATE LOCALS
%CYCLE ARG3=1,1,ARG2
STACK(NIL); ! VALUES ONTO STACK
%REPEAT
ENVIR=SETBIND(ARG1,ENVIR)
%FINISH
STACK(NSR)
%RETURN; ! END NEW
!
!
SYSFUN(64):; ! GO
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&NM#NM %THENSTART
ERROR('GO NEEDS A NUMBER AS INPUT. IT WAS GIVEN ',ARG1,1,IN)
%RETURN
%FINISH
ARG2=FUN; ! USER FUN CURRENT
%WHILE TL(ARG2)#NIL %CYCLE
%IF HD(HD(TL(ARG2)))=ARG1 %THENSTART
CURFUN=ARG2; ! ONE LINE BEFORE REQUESTED LINE
STACK(NSR)
%RETURN
%FINISH
ARG2=TL(ARG2)
%REPEAT
ERROR('THERE IS NO LINE NUMBERED ',ARG1,1,IN)
%RETURN; ! END GO
!
!
!
SYSFUN(65):; ! STOP
%IF FUN=NIL %THENSTART
ERROR('STOP CAN ONLY BE USED INSIDE A PROCEDURE',EMPTY,1,IN)
%RETURN
%FINISH
CURFUN=CONS(NIL,NIL); ! APPLYUSR STOPS WHEN A SINGLE LINE LEFT
STACK(NSR)
%RETURN; ! END STOP
!
!
SYSFUN(66):; ! RESULT (OUTPUT)
%IF FUN=NIL %THENSTART
ERROR('RESULT CAN ONLY BE USED INSIDE A PROCEDURE',EMPTY,1,IN)
%RETURN
%FINISH
CURFUN=CONS(NIL,NIL)
STACK(CONS(QQRESULT,CONS(UNSTACK,NIL))); ! [??RESULT VALUE]
%RETURN; ! END RESULT
!
!
SYSFUN(67):; ! RENUMBER
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&WM#WM %THENSTART
ERROR(WA(FN>>8).ERRMESS(26),ARG1,1,IN)
%RETURN
%FINISH
ARG2=FNVAL(ARG1>>8); ! GET SPEC
%IF ARG2=0 %THENSTART
ERROR(ERRMESS(21).WA(ARG1>>8).ERRMESS(23),FN,1,IN)
%RETURN
%FINISH
%IF ARG2&USERPRE#USERPRE %THENSTART
ERROR(WA(FN>>8).ERRMESS(25),ARG1,1,IN)
%RETURN
%FINISH
ARG2=ARG2&M16!LM; ! LIST DEF POINTER
ARG3=10
ARG2=TL(ARG2); ! DEF STARTING AT FIRST NUMBERED LINE
%WHILE ARG2#NIL %CYCLE
REPHEAD(HD(ARG2),ARG3<<8!NM)
ARG3=ARG3+10
ARG2=TL(ARG2)
%REPEAT
NOOLINE(1)
PRINTEL(ARG1)
PRSTRING(' RENUMBERED')
NOOLINE(1)
STACK(NSR)
%RETURN; ! END RENUMBER
!
!
SYSFUN(68):; ! DELETE RETITILE END UNDO UNDOS AT COMMAND LEVEL
ERROR(WA(FN>>8).ERRMESS(34),EMPTY,1,IN)
%RETURN; ! END
!
!
!
!
!
SYSFUN(70):; ! SHOW
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1=NIL %THEN ->SH2
%IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL)
%IF ARG1&LM#LM %THENSTART
ERROR(WA(FN>>8).ERRMESS(24),ARG1,1,IN)
%RETURN
%FINISH
%WHILE ARG1#NIL %CYCLE
ARG2=HD(ARG1)
ARG1=TL(ARG1)
NOOLINE(1)
%IF ARG2&WM#WM %THENSTART
ERROR1(WA(FN>>8).ERRMESS(24),CONS(ARG2,ARG1))
->SH1
%FINISH
ARG3=FNVAL(ARG2>>8); ! GET SPEC
%IF ARG3=0 %THENSTART
ERROR1(ERRMESS(21).WA(ARG2>>8).ERRMESS(23),FN)
->SH1
%FINISH
%IF ARG3&USERPRE#USERPRE %THENSTART
ERROR1(WA(FN>>8).ERRMESS(25),ARG2)
->SH1
%FINISH
ARG3=ARG3&M16!LM; ! DEFINITION
%WHILE ARG3#NIL %CYCLE
PRINTLINE(HD(ARG3))
ARG3=TL(ARG3)
%REPEAT
PRINTEL(END)
NOOLINE(1)
SH1:%REPEAT
SH2:STACK(NSR)
%RETURN; ! END SHOW
!
!
!
SYSFUN(72):; ! DEFINED
STACK(DEFINED)
%RETURN; ! END DEFINED
!
!
SYSFUN(73):; ! TEMPORARY
STACK(NEWFN)
%RETURN; ! END TEMPORARY
!
!
SYSFUN(74):; ! OLDDEF
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&WM#WM %THENSTART
ERROR(ERRMESS(26),ARG1,1,IN)
%RETURN;%FINISH
%IF OLDFN(ARG1>>8)=0 %THENSTART
ERROR(ERRMESS(28),ARG1,1,IN)
%RETURN;%FINISH
ARG2=FNVAL(ARG1>>8)
FNVAL(ARG1>>8)=OLDFN(ARG1>>8)
OLDFN(ARG1>>8)=ARG2
PRSTRING( 'ORIGINAL DEFINITION OF ');PRSTRING(WA(ARG1>>8).' RESTORED')
NOOLINE(1);STACK(NSR)
%RETURN; ! END OLDDEF
!
!
SYSFUN(75):; ! UNDEFINE
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL)
%IF ARG1&LM#LM %THENSTART
ERROR(WA(FN>>8).ERRMESS(24),ARG1,1,IN)
%RETURN
%FINISH
%WHILE ARG1#NIL %CYCLE
ARG2=HD(ARG1);ARG1=TL(ARG1)
%IF ARG2&WM#WM %THENSTART
ERROR(WA(FN>>8).ERRMESS(24),ARG2,1,IN)
%RETURN
%FINISH
ARG3=FNVAL(ARG2>>8)
%IF ARG3=0 %THENSTART
ERROR(ERRMESS(21).WA(ARG2>>8).ERRMESS(23),FN,1,IN)
%RETURN
%FINISH
%IF ARG3&USERPRE#USERPRE %THENSTART
ERROR(WA(FN>>8).ERRMESS(25),ARG2,1,IN)
%RETURN
%FINISH
! SO OK
FNVAL(ARG2>>8)=0
OLDFN(ARG2>>8)=0
FROMLIST(NEWFN,ARG2) %UNLESS NEWFN=NIL
FROMLIST(DEFINED,ARG2)
PRSTRING(WA(ARG2>>8).' UNDEFINED');NOOLINE(1)
%REPEAT
STACK(NSR)
%RETURN; ! END UNDEFINE
!
!
SYSFUN(76):; ! RECALL
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1=NIL %THEN ->LD5
%IF ARG1&WM=WM %THEN ARG1=CONS(ARG1,NIL)
%IF ARG1&LM#LM %THENSTART
ERROR(WA(FN>>8).ERRMESS(24),ARG1,1,IN)
%RETURN
%FINISH
%IF BORROWFLAG=1 %THENSTART
%IF SHAREFILE#0 %THENRETURN; ! FILE BEING WRITTEN TO
BORROWLOAD=1
%FINISH
%IF DIRNUM=0 %THENSTART
PRSTRING('THERE ARE NO PROCEDURES IN THIS PERMANENT MEMORY')
NOOLINE(1)
->LD4
%FINISH
%WHILE ARG1#NIL %CYCLE
ARG2=HD(ARG1)
ARG1=TL(ARG1)
%IF ARG2&WM#WM %THENSTART
ERROR1(WA(FN>>8).ERRMESS(24),CONS(ARG2,ARG1))
->LD3;%FINISH
WSTR1=WA(ARG2>>8)
ARG3=SEARCHDIR(WSTR1)
%IF ARG3=0 %THENSTART; ! NOT FOUND
PRSTRING(ERRMESS(22).WSTR1)
NOOLINE(1)
->LD3
%FINISH
CURTEXT=DIR(ARG3)_TEXTINDEX; ! START INDEX FOR THIS PROC
DEVICE=DISC
ARG3=READLINE
STKSYS(ARG1); STKSYS(IN)
EVAL(0,ARG3,EACHVAL,WALKFN)
IN=UNSTKSYS; ARG1=UNSTKSYS
%IF JUMPFLAG=1 %THENEXIT; ! USER INT ONLY
ARG3=UNSTACK
LD3:%REPEAT
DEVICE=TTY
LD4:%IF BORROWFLAG=1 %THEN DISCONBFILE %AND BORROWLOAD=0
LD5:STACK(NSR)
%RETURN; ! END RECALL
!
!
SYSFUN(77):; ! REMEMBER
ARG3=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG3=NIL %THEN ->SAVE2
%IF BORROWFLAG=1 %THENSTART
ERROR(ERRMESS(15),EMPTY,1,IN)
%RETURN
%FINISH
%IF ARG3&WM=WM %THEN ARG3=CONS(ARG3,NIL)
%IF ARG3&LM#LM %THENSTART
ERROR(WA(FN>>8).ERRMESS(24),ARG3,1,IN)
%RETURN
%FINISH
%IF STATUS(OWNFILE,0)>1 %THENSTART; ! BORROWED OR TWO USERS SAME NAME
DPRINTSTRING(ERRMESS(54).WA(FN>>8).ERRMESS(55))
DPRINTSTRING(WA(FN>>8).ERRMESS(56).ERRMESS(61))
DNEWLINE
JUMPFLAG=1
IN=NIL
->SAVE2
%FINISH
WRITINGFILE=1; ! TO TELL WOULD BE BPRROWERS
DEVICE=DISC
%WHILE ARG3#NIL %CYCLE
ARG1=HD(ARG3)
ARG3=TL(ARG3)
%IF ARG1&WM#WM %THEN%START
ERROR1(WA(FN>>8).ERRMESS(24),CONS(ARG1,ARG3))
->SAVEREP;%FINISH
ARG2=FNVAL(ARG1>>8)
%IF ARG2=0 %THEN%START
ERROR1(ERRMESS(21).WA(ARG1>>8).ERRMESS(23),FN)
->SAVEREP;%FINISH
%IF ARG2&USERPRE#USERPRE %THEN%START
ERROR1(WA(FN>>8).ERRMESS(25),ARG1)
->SAVEREP;%FINISH
W1=ARG2&M16!LM; ! DEF AS LIST
SAVE3:ARG2=W1
W2=NFTEXT
%WHILE ARG2#NIL %CYCLE
PRINTLINE(HD(ARG2));
ARG2=TL(ARG2)
%REPEAT
PRINTEL(END)
LGPRNT STR(STERMIN)
%IF FULLFLAG=0 %THENSTART; ! TEXT ALL IN OK
WSTR1=WA(ARG1>>8)
WRITEDIR(WSTR1,W2); ! UPDATE DIR
%IF FULLFLAG=0 %THEN ->SAVE4; ! SO DIR UPDATED OK
%FINISH
! SO FULLFLAG=1 EITHER BECAUSE TEXT NOT ALL IN, OR NO ROOM FOR
! NEW DIR ENTRY. IN EITHER CASE, ONLY NFTEXT HAS BEEN ALTERED.
! W2 CONTAINS ORIGINAL VALUE.
FULLFLAG=0
%IF UNTIDY=1 %THENSTART; ! TRY A TIDY
TIDYFILE
->SAVE3; ! AND TRY WHOLE THING OVER AGAIN
%FINISH; ! PICKING UP NEW VALUE OF NFTEXT
! FILE NOT UNTIDY, SO ABORT
NFTEXT=W2; ! RESET TO BEFORE ATTEMPT
PRSTRING('NOT ENOUGH SPACE LEFT IN YOUR PERMANENT MEMORY')
NOOLINE(1)
%EXIT; ! FROM PROC CYCLE
!
SAVE4:; ! NORMAL WHEN SPACE IN FILE OK
FROMLIST(NEWFN,ARG1) %UNLESS NEWFN=NIL
PRSTRING(WSTR1.' REMEMBERED');
NOOLINE(1)
SAVEREP:%REPEAT
DEVICE=TTY
WRITINGFILE=0
SAVE2:STACK(NSR)
%RETURN; ! END SAVE
!
!
!
SYSFUN(79):; ! FORGET ARG1 ARG2 ETC
ARG3=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG3=NIL %THEN ->FG5
%IF BORROWFLAG=1 %THENSTART
ERROR(ERRMESS(27),EMPTY,1,IN)
%RETURN
%FINISH
%IF ARG3&WM=WM %THEN ARG3=CONS(ARG3,NIL)
%IF ARG3&LM#LM %THENSTART
ERROR(WA(FN>>8).ERRMESS(24),ARG3,1,IN)
%RETURN
%FINISH
%IF DIRNUM=0 %THENSTART
PRSTRING('THERE ARE NO PROCEDURES IN THIS PERMANENT MEMORY')
NOOLINE(1)
->FG5
%FINISH
%IF STATUS(OWNFILE,0)>1 %THENSTART; ! BORROWED OR TWO USERS SAME NAME
DPRINTSTRING(ERRMESS(54).WA(FN>>8).ERRMESS(55))
DPRINTSTRING(WA(FN>>8).ERRMESS(56).ERRMESS(61))
DNEWLINE
JUMPFLAG=1
IN=NIL
->FG5
%FINISH
WRITINGFILE=1
%WHILE ARG3#NIL %CYCLE
ARG1=HD(ARG3)
ARG3=TL(ARG3)
%IF ARG1&WM#WM %THENSTART
ERROR1(WA(FN>>8).ERRMESS(24),CONS(ARG1,ARG3))
->FG3;%FINISH
WSTR1=WA(ARG1>>8)
ARG2=SEARCHDIR(WSTR1)
%IF ARG2=0 %THENSTART
PRSTRING(ERRMESS(22).WSTR1)
NOOLINE(1)
->FG3
%FINISH
DIR(ARG2)_PROCNAME=''
UNTIDY=1
%IF FNVAL(ARG1>>8)#0 %THENSTART; ! DEFINED
FROMLIST(NEWFN,ARG1) %UNLESS NEWFN=NIL
NEWFN=CONS(ARG1,NEWFN)
%FINISH
PRSTRING(WSTR1.' FORGOTTEN')
NOOLINE(1)
FG3:%REPEAT
WRITINGFILE=0
FG5:STACK(NSR)
%RETURN; ! END FORGET
!
!
SYSFUN(80):; ! REMEMBERED
%IF BORROWFLAG=1 %AND SHAREFILE#0 %THENRETURN
ARG1=NIL
%IF DIRNUM#0 %THENSTART
%CYCLE ARG2=1,1,DIRNUM
WSTR1=DIR(ARG2)_PROCNAME
%IF WSTR1#'' %THEN ARG1=CONS(HASH(WSTR1),ARG1)
%REPEAT
%FINISH
%IF BORROWFLAG=1 %THEN DISCONBFILE
STACK(ARG1)
%RETURN; ! END REMEMBERED
!
!
SYSFUN(81):; ! LISTERRORS
NOOLINE(2)
PRSTRING('ERROR FILE CONTENTS')
NOOLINE(1)
%CYCLE ARG1=1,1,100
WSTR1=ERRMESS(ARG1)
%IF WSTR1#'?' %THENSTART
WRITE(ARG1,4);SPACE
DPRINTSTRING(WSTR1)
DNEWLINE
%FINISH
%REPEAT
STACK(NSR)
%RETURN; ! END LISTERRORS
!
!
SYSFUN(82):; ! EDITERRORS
%IF EMASUSER.'.'=MASNUM %AND USER=MASNAME %THENSTART
%IF STATUS('ELOGOO',0)>1 %THENSTART
ERROR(ERRMESS(29),EMPTY,1,IN)
%RETURN
%FINISH
CLOSESM(5);DISCONNECT('LOGERRS')
PERMITFILE('LOGERRS,ESAV01,ALL')
ERRMESS==ARRAY(SMADDR(5,FLENGTH),SFORM2)
ERRL0:DPROMPT('ERR NUM:')
READ(ARG1)
%IF ARG1=0 %THEN ->ERRL1
DPROMPT('ERR MESS:')
ERRL2:READSTRING(WSTR1)
%IF LENGTH(WSTR1)>255 %THENSTART
PRSTRING('MESSAGE TOO LONG');NOOLINE(1)
->ERRL2
%FINISHELSE ERRMESS(ARG1)=WSTR1
->ERRL0
ERRL1:DPROMPT(PROMP)
CLOSESM(5);DISCONNECT('LOGERRS')
PERMITFILE('LOGERRS,ESAV01,RS')
ERRMESS==ARRAY(SMADDR(5,FLENGTH),SFORM2)
STACK(NSR)
%RETURN
%FINISH; ! FINISH ALLOWED USER
!
PRSTRING('YOU MAY NOT');NOOLINE(1);
STACK(NSR)
%RETURN; ! END EDITERRORS
!
!
SYSFUN(83):; ! LISTMASTER
MAPMASTER
%CYCLE ARG1=1,1,MASENTS
WRITE(ARG1,5);SPACES(2);PRSTRING(USERIDS(ARG1))
NOOLINE(1)
%REPEAT
DISCONMASTER
STACK(NSR)
%RETURN; ! END LISTMASTER
!
!
SYSFUN(84):; ! EDITMASTER
%IF EMASUSER.'.'=MASNUM %AND USER=MASNAME %THENSTART
%IF STATUS('ELOGOO',0)>1 %THENSTART
ERROR(ERRMESS(29),EMPTY,1,IN)
%RETURN
%FINISH
PERMITFILE('LOGMASTR,ESAV01,ALL')
MAPMASTER
WSTR1=PROMP
PROMP='E:'
DPROMPT(PROMP)
EMLOOP:ARG1=READLINE
%IF ARG1=NIL %OR ARG1&LM#LM %THENSTART
PRSTRING('INCORRECT FORMAT - ')
PRINTEL(ARG1);NOOLINE(1)
->EMLOOP
%FINISH
ARG2=HD(ARG1);ARG1=TL(ARG1)
%IF ARG2=INSERT %THENSTART
WSTR2=CHECKID(ARG1)
%IF WSTR2='' %THENSTART
PRSTRING('WRONGLY FORMATTED IDENTIFIER - ')
PRINTEL(ARG1);NOOLINE(1)
->WHOLP
%FINISH
%CYCLE ARG3=1,1,MASENTS
%IF WSTR2=USERIDS(ARG3) %THENSTART
PRSTRING(WSTR2.'ALREADY IN DIRECTORY');NOOLINE(1)
->EMLOOP
%FINISH
%REPEAT
! SO NOT ALREADY THERE
%CYCLE ARG3=1,1,MASENTS
%IF USERIDS(ARG3)='DESTROYED' %THEN ->EML2; ! FREE SLOT
%REPEAT
! SO NO FREE SLOT. PUT IT ON THE END
%IF MASENTS=99 %THENSTART
PRSTRING('MASTER DIRECTORY FULL');NOOLINE(1)
->EMLOOP
%FINISH
MASENTS=MASENTS+1
ARG3=MASENTS
EML2:USERIDS(ARG3)=WSTR2
WSTR3='LOGO'.NUMTOSTR(ARG3<<8)
NEWSMFILE(WSTR3.',40960')
DEFINE('SM12,'.WSTR3)
ARG3=SMADDR(12,W1)
SHORTINTEGER(ARG3)=0; ! DIRNUM
SHORTINTEGER(ARG3+2)=1; ! DIRPAGES
SHORTINTEGER(ARG3+4)=0; ! WRITINGFILE
SHORTINTEGER(ARG3+6)=0; ! UNTIDY
INTEGER(ARG3+8)=1; ! NFTEXT
CLOSESM(12)
CLEAR('SM12')
DISCONNECT(WSTR3)
PERMITFILE(WSTR3.','.EMASUSER.',WS')
PERMITFILE(WSTR3.',,WS')
CHERISH(WSTR3)
PRSTRING('FILE '.WSTR3.' CREATED FOR '.WSTR2);NOOLINE(1)
->EMLOOP
%FINISH
%IF ARG2=DELETE %THENSTART
%IF HD(ARG1)&NM=NM %THENSTART
ARG3=HD(ARG1)>>8
%IF ARG3>MASENTS %THENSTART
PRSTRING('INDEX TOO LARGE');NOOLINE(1)
->EMLOOP
%FINISH
WSTR2=USERIDS(ARG3)
->EML1
%FINISH
WSTR2=CHECKID(ARG1)
%IF WSTR2='' %THENSTART
PRSTRING('WRONGLY FORMATTED IDENTIFIER - ')
PRINTEL(ARG1);NOOLINE(1)
->EMLOOP
%FINISH
%CYCLE ARG3=1,1,MASENTS
%IF WSTR2=USERIDS(ARG3) %THEN ->EML1
%REPEAT
! NOT FOUND
PRSTRING(WSTR2.'NOT IN DIRECTORY');NOOLINE(1)
->EMLOOP
EML1:; ! GET HERE WITH NAME IN WSTR2 AND INDEX IN ARG3
USERIDS(ARG3)='DESTROYED'
WSTR3='LOGO'.NUMTOSTR(ARG3<<8)
DESTROY(WSTR3)
PRSTRING('USER '.WSTR2.'DELETED. FILE '.WSTR3.' DESTROYED')
NOOLINE(1)
->EMLOOP
%FINISH
%IF ARG2=END %THENSTART
DISCONMASTER
PERMITFILE('LOGMASTR,ESAV01,RS')
PROMP=WSTR1
DPROMPT(PROMP)
STACK(NSR)
%RETURN
%FINISH
!
PRSTRING('BAD EDIT COMMAND');NOOLINE(1)
->EMLOOP
%FINISH; ! FINISH ALLOWED USER
!
PRSTRING('YOU MAY NOT');NOOLINE(1)
STACK(NSR)
%RETURN; ! END EDITMASTER
!
!
SYSFUN(85):; ! BORROW
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
BORROW(ARG1,FN)
STACK(NSR) %UNLESS JUMPFLAG=1
%RETURN; ! END BORROW
!
!
SYSFUN(86):; ! LIBRARY
ARG1=UNSTACKINPUT;%IF JUMPFLAG=1 %THENRETURN
ARG2=UNSTACKINPUT;%IF JUMPFLAG=1 %THENRETURN
%IF ARG1&WM#WM %THENSTART
ERROR('LIBRARY MUST HAVE A PROCEDURE NAME AS ITS SECOND INPUT.' %C
.'
IT WAS GIVEN ',ARG1,1,IN)
%RETURN
%FINISH
BORROW(ARG2,FN)
%IF JUMPFLAG=1 %THENRETURN
%IF BORROWFLAG=1 %THENSTART
%IF SHAREFILE#0 %THEN ->BERR2
%FINISH
%IF DIRNUM=0 %THENSTART
ERROR('THERE ARE NO PROCEDURES IN THIS PERMANENT MEMORY',EMPTY,1,IN)
->BERR1
%FINISH
WSTR1=WA(ARG1>>8)
ARG3=SEARCHDIR(WSTR1)
%IF ARG3=0 %THENSTART
ERROR('THERE IS NO PROCEDURE IN THIS PERMANENT MEMORY NAMED ',%C
ARG1,1,IN)
->BERR1
%FINISH
BORROWLOAD=1
CURTEXT=DIR(ARG3)_TEXTINDEX
DEVICE=DISC
ARG3=READLINE
STKSYS(IN)
EVAL(0,ARG3,EACHVAL,WALKFN)
IN=UNSTKSYS
DEVICE=TTY;BORROWLOAD=0
%IF BORROWFLAG=1 %THEN DISCONBFILE
%IF JUMPFLAG=1 %THEN ->BERR2
ARG3=UNSTACK
ARG3=CONS(ARG1,NIL)
EVAL(0,ARG3,EACHVAL,WALKFN)
%IF BORROWFLAG=1 %THENSTART
BORROWFLAG=0
MAPFILE(OWNFADDR)
PRSTRING('YOUR OWN MEMORY IS AVAILABLE AGAIN')
NOOLINE(1)
%FINISH
STACK(NSR) %UNLESS JUMPFLAG=1
%RETURN
!HERE FOR ERRORS
BERR1:%IF BORROWFLAG=1 %THEN DISCONBFILE
BERR2:%IF BORROWFLAG=1 %THENSTART
MAPFILE(OWNFADDR)
PRSTRING('YOUR OWN MEMORY IS AVAILABLE AGAIN')
NOOLINE(1)
BORROWFLAG=0
%FINISH
%RETURN; ! END LIBRARY
!
!
SYSFUN(87):; ! RETURN (BORROWED FILE)
%IF BORROWFLAG=0 %THENSTART
ERROR('YOU ARE NOT BORROWING AT THE MOMENT',EMPTY,1,IN)
%RETURN
%FINISH
PRSTRING(ERRMESS(16));NOOLINE(1)
BORROWFLAG=0
MAPFILE(OWNFADDR)
STACK(NSR)
%RETURN; ! END RETURN
!
!
SYSFUN(88):; ! SHOWFILE
%IF BORROWFLAG=1 %THENSTART
%IF SHAREFILE#0 %THENRETURN
WSTR1=BFILE
WSTR2=BORROWEE
%FINISHELSE WSTR1=OWNFILE %AND WSTR2=USER
DEFINE('ST13,.LP')
SELECTOUTPUT(13)
PRINTSTRING('FILE '.WSTR1.' BELONGING TO '.WSTR2)
NEWLINES(2)
PRINTSTRING('DIRNUM=');WRITE(DIRNUM,5);NEWLINE
PRINTSTRING('DIRPAGES=');WRITE(DIRPAGES,5);NEWLINE
PRINTSTRING('WRITINGFILE=');WRITE(WRITINGFILE,5);NEWLINE
PRINTSTRING('UNTIDY=');WRITE(UNTIDY,5);NEWLINE
PRINTSTRING('NFTEXT=');WRITE(NFTEXT,5);NEWLINES(2)
%IF DIRNUM=0 %THEN ->SHFL
PRINTSTRING('DIRECTORY ENTRIES:-');NEWLINE
%CYCLE ARG1=1,1,DIRNUM
PRINTSTRING(DIR(ARG1)_PROCNAME);WRITE(DIR(ARG1)_TEXTINDEX,5);
NEWLINE
%REPEAT
NEWLINE
PRINTSTRING('TEXT:-');NEWLINE
%CYCLE ARG1=1,1,NFTEXT-1
PRINTSYMBOL(TEXT(ARG1))
%REPEAT
NEWLINE
SHFL:SELECTOUTPUT(0)
CLOSESTREAM(13)
CLEAR('ST13')
STACK(NSR)
%RETURN; ! END SHOWFILE
!
!
SYSFUN(89):; ! GOTOFILE
SELECTINPUT(3)
SETMARGINS(3,1,120)
STACK(NSR)
%RETURN; ! END GOTOFILE
!
!
!
SYSFUN(91):; ! ABORT
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&NM#NM %OR ARG1<0 %THENSTART
ERROR('NON-POSITIVE ARG FOR ABORT - ',ARG1,1,IN)
%RETURN
%FINISH
JUMPFLAG=1
JUMPOUT=ARG1>>8
STACK(NSR)
%RETURN; ! END ABORT
!
!
SYSFUN(92):; ! QUIT
JUMPFLAG=1
JUMPOUT=100
%IF TDEV#0 %THEN CLESET; ! CLEAR DEVICE Q IN H316
STACK(NSR)
%RETURN; ! END QUIT
!
!
SYSFUN(93):; ! CONTINUE
%IF SEVERITY=1 %THENSTART
ERROR('CANNOT CONTINUE FROM LAST ERROR',EMPTY,1,IN)
%RETURN
%FINISH
JUMPFLAG=1
JUMPOUT=-1
STACK(NSR)
%RETURN; ! END CONTINUE
!
!
SYSFUN(94):; ! SENDBACK
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN; ! VALUE TO BE SENT
ARG2=GETNEXT(IN); ! FN TO BE SENT TO OR NUMBER OF FNS TO BE EXITED
%IF JUMPFLAG=1 %THENRETURN
%IF ARG2&NM=NM %THENSTART
%IF ARG2<0 %THENSTART
ERROR('NEGATIVE SECOND ARG FOR SENDBACK - ',EMPTY,1,IN)
%RETURN
%FINISH
SENDFLAG=ARG2>>8; ! NO OF RETURNS
JUMPFLAG=1
STACK(ARG1)
%RETURN
%FINISH
%IF ARG2&WM#WM %THENSTART
ERROR('SENDBACK TO WHERE? ',ARG2,1,IN)
%RETURN
%FINISH
W1=ENVIR; ! CURRENT ENVIR TOP
ARG3=0
%WHILE W1>BASENVIR %CYCLE
%WHILE BNAME(W1)#0 %CYCLE;W1=W1-1;%REPEAT
W2=BVALUE(W1); ! FN ENTERED
W1=W1-1; ! NEXT ENVIR TOP
%IF W2=ARG2 %THENSTART; ! FOUND IT
SENDFLAG=ARG3+1; ! NO OF RETURNS TO BE MADE TO GET THERE
JUMPFLAG=1
STACK(ARG1)
%RETURN
%FINISHELSESTART; ! NOT THE RIGHT FN
%IF W2#LOGONAME %THEN ARG3=ARG3+1; ! SO INC NO OF RETURNS, UNLESS LOGO
%FINISH
%REPEAT
! GETS HERE IF FN NOT FOUND AT CURRENT LEVEL
ERROR('FN FOR SENDBACK NOT OUTSTANDING - ',%C
ARG2,1,IN)
%RETURN; ! END SENDBACK
!
!
SYSFUN(95):; ! BREAK
ARG1=IN
NOOLINE(1)
%IF ARG1=NIL %THEN PRINTEL(BREAK)
%WHILE ARG1#NIL %CYCLE
PRINTEL(HD(ARG1))
SPACE
ARG1=TL(ARG1)
%REPEAT
ERROR('',EMPTY,0,IN)
%IF JUMPFLAG=1 %THENRETURN; ! ABORT OR QUIT
STACK(BREAK); ! RESULT FOR CONTINUE
%RETURN; ! FROM CONTINUE. END BREAK
!
!
SYSFUN(96):; ! CALLUSER
ARG1=ENVIR
NOOLINE(1)
PRSTRING('CALLUSER CALLED FROM:-')
%IF ARG1=BASENVIR %THENSTART
PRINTEL(LOGONAME)
NOOLINE(1)
%FINISHELSESTART
ARG2=ARG1
%WHILE BNAME(ARG2)#0 %THEN ARG2=ARG2-1
PRINTEL(BVALUE(ARG2)); ! FN NAME
NOOLINE(1)
%IF ARG2=ARG1 %THENSTART
PRSTRING('NO LOCALS')
NOOLINE(1)
%FINISHELSESTART
ARG2=ARG2+1
%WHILE ARG2<=ARG1 %CYCLE
SPACES(2);PRINTEL(BNAME(ARG2))
PRSTRING(':-');PRINTEL(BVALUE(ARG2))
NOOLINE(1)
ARG2=ARG2+1
%REPEAT
%FINISH
%FINISH
RL107:ARG3=STKPNT; ! SAVV STACK
DPROMPT('RESULT:')
BLEVEL=1
FILL LINE BUFFER
ARG1=READLIST(BLEVEL)
%IF ARG1=ERR %THEN ->RL107
STKSYS(IN)
EVAL(0,ARG1,EACHVAL,WALKFN)
IN=UNSTKSYS
%IF JUMPFLAG=1 %THENSTART; ! SPECIAL FOR RETRY
JUMPFLAG=0
JUMPOUT=0
STKPNT=ARG3
->RL107
%FINISH
DPROMPT(PROMP)
! STACK(UNSTACK)
%RETURN; ! END CALLUSER
!
!
SYSFUN(97):; ! FNCALLS
ARG1=ENVIR
NOOLINE(1)
%WHILE ARG1>1022 %CYCLE
%IF BNAME(ARG1)=0 %THENSTART
PRINTEL(BVALUE(ARG1))
NOOLINE(1)
%FINISH
ARG1=ARG1-1
%REPEAT
PRINTEL(LOGONAME)
NOOLINE(1)
STACK(NSR)
%RETURN; ! END FNCALLS
!
!
SYSFUN(98):; ! FNVALS
ARG1=ENVIR
NOOLINE(1)
%WHILE ARG1>1022 %CYCLE
ARG2=ARG1
%WHILE BNAME(ARG2)#0 %CYCLE
ARG2=ARG2-1
%REPEAT; ! ARG2 POINTS TO CURRENT BOTTOM
PRINTEL(BVALUE(ARG2)); ! FUNCTION NAME
PRSTRING(':-')
NOOLINE(1)
ARG3=ARG2+1
%WHILE ARG3<=ARG1 %CYCLE
SPACES(4)
PRINTEL(BNAME(ARG3))
SPACE
PRINTEL(BVALUE(ARG3))
NOOLINE(1)
ARG3=ARG3+1
%REPEAT
NOOLINE(1)
ARG1=ARG2-1
%REPEAT
PRINTEL(LOGONAME)
NOOLINE(1)
STACK(NSR)
%RETURN; ! END FNVALS
!
!
SYSFUN(99):; ! ABBREV
REDEF=0
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&WM#WM %OR ARG2&WM#WM %THENSTART
ERROR('ABBREV REQUIRES TWO WORDS AS INPUTS. IT WAS GIVEN ',%C
CONS(ARG1,CONS(ARG2,NIL)),1,IN)
%RETURN
%FINISH
%IF FNVAL(ARG1>>8)=0 %THENSTART
ERROR(WA(ARG1>>8).' IS NOT DEFINED',EMPTY,1,IN)
%RETURN
%FINISH
! SO ARG1 OK
ARG3=FNVAL(ARG2>>8); ! GET SPEC FOR ABBREVIATION
%IF ARG3=0 %THEN -> TRANSPEC; ! UNDEFINED SO OK
%IF ARG3&USERPRE=USERPRE %THENSTART
REDEF=1
->TRANSPEC
%FINISH; ! ALREADY DEFINED BY USER
ERROR('YOU CANNOT USE ELOGO''S OWN PROCEDURE NAME '.WA(ARG2>>8).%C
' AS AN ABBREVIATION',EMPTY,1,IN)
%RETURN
TRANSPEC:FNVAL(ARG2>>8)=FNVAL(ARG1>>8)
PRINTEL(ARG2)
PRSTRING(' IS')
%IF REDEF=1 %THEN PRSTRING(' REDEFINED') %ELSEC
PRSTRING(' DEFINED')
PRSTRING(' AS AN ABBREVIATION FOR ')
PRINTEL(ARG1)
NOOLINE(1)
STACK(NSR)
%RETURN; ! END ABBREV
!
!
SYSFUN(100):; ! MFIRST
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&LM#LM %OR ARG1=NIL %THENSTART
ERROR('BAD FIRST ARG FOR MFIRST - ',CONS(ARG1,CONS(ARG2,NIL)),1,IN)
%RETURN
%FINISH
%IF (ARG1>>8)>=LAFNB %THENSTART; ! LIST EMBEDDED IN FN DEFN
ERROR('LIST EMBEDDED IN FN DEFN CANNOT BE UPDATED - ',ARG1,1,IN)
%RETURN
%FINISH
REPHEAD(ARG1,ARG2)
STACK(NSR)
%RETURN; ! END MFIRST
!
!
SYSFUN(101):; ! MBUTFIRST
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&LM#LM %OR ARG1=NIL %THENSTART
ERROR('BAD FIRST ARG FOR MBUTFIRST - ',CONS(ARG1,CONS(ARG2,NIL)),1,IN)
%RETURN
%FINISH
%IF (ARG1>>8)>=LAFNB %THENSTART
ERROR('LIST EMBEDDED IN FN DEFN CANNOT BE UPDATED - ',ARG1,1,IN)
%RETURN
%FINISH
%IF ARG2&LM#LM %THENSTART
ERROR('BAD SECOND ARG FOR MBUTFIRST - ',%C
CONS(ARG1,CONS(ARG2,NIL)),1,IN)
%RETURN
%FINISH
REPTAIL(ARG1,ARG2)
STACK(NSR)
%RETURN; ! END MBUTFIRST
!
!
SYSFUN(105):; ! GOODBYE
SYSFUN(106):; ! EXIT
%IF BORROWFLAG=1 %THEN BORROWFLAG=0 %AND MAPFILE(OWNFADDR)
%IF UNTIDY=1 %AND STATUS(OWNFILE,0)=1 %THEN TIDYFILE %AND WRITINGFILE=0
! TIDY IF NO OTHER USERS ELSE LEAVE UNTIDY TILL NEXT SESSION
%IF TDEV#0 %THEN FREEDEVICE; ! FREE TURTLE DEVICE IF ANY
CLOSESTREAM(1)
CLEAR('ST01')
CLOSESM(6);CLEAR('SM06')
DESTROY('LOGOSTK')
CLOSESM(5);CLEAR('SM05');DISCONNECT(MASNUM.'LOGERRS')
DISCONOWNFILE
USER->USER.(' ').WSTR1
PRSTRING('GOODBYE '.USER)
NOOLINE(1)
PRSTRING(DATE.' '.TIME);NOOLINE(11)
%IF SW=105 %THENSTART
DEFINE('ST01,.LP')
SELECTOUTPUT(1)
%CYCLE ARG1=1,1,DPNT
PRINTSYMBOL(DFILE(ARG1))
%REPEAT
SELECTOUTPUT(0)
CLOSESTREAM(1)
CLEAR('ST01')
%FINISH
CLOSESM(11)
CLEAR('SM11')
DESTROY('LOGODRIB')
%STOP; ! END EXIT,GOODBYE
!
!
SYSFUN(107):; ! AND
ARG2=UNSTACK
ARG1=UNSTACK
STACK(ARG2); ! DISCARD FIRST ARG
%RETURN; ! END AND
!
!
SYSFUN(108):; ! QUOTE
STACK(QUOTE)
%RETURN; ! END QUOTE
!
!
SYSFUN(109):; ! DOTS
STACK(DOTS)
%RETURN; ! END DOTS
!
!
!
SYSFUN(111):; ! VALUE
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&WM#WM %THENSTART
ERROR(ERRMESS(57),ARG1,1,IN)
%RETURN
%FINISH
ARG2=GETVAL(ARG1,ENVIR)
%IF ARG2=UNDEF %THENSTART
ERROR(ERRMESS(3),ARG1,1,IN)
%RETURN
%FINISH
STACK(ARG2)
%RETURN; ! END VALUE
!
!
SYSFUN(112):; ! REPEAT
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&NM#NM %OR ARG1<0 %THENSTART
ERROR(ERRMESS(35),ARG1,1,IN)
%RETURN
%FINISH
%IF ARG1>>8=0 %THENSTART
IN=NIL
STACK(NSR)
%RETURN
%FINISH
%IF IN=NIL %THENSTART
ERROR(ERRMESS(36).NUMTOSTR(ARG1).ERRMESS(37),EMPTY,1,IN)
%RETURN
%FINISH
%CYCLE ARG2=1,1,ARG1>>8
ARG3=IN; ! SAVE IN TO REUSE FOR REOEATS
STKSYS(IN)
EVAL(0,ARG3,EACHVAL,WALKFN)
IN=UNSTKSYS
%IF JUMPFLAG=1 %THENRETURN
W1=UNSTACK; ! LAST VALUE
%REPEAT
IN=ARG3
STACK(W1)
%RETURN; ! END REPEAT
!
!
SYSFUN(113):; ! RESET
LOGOTIME=TIME100
STACK(NSR)
%RETURN; ! END RESET
!
!
SYSFUN(114):; ! TIME
STACK((TIME100-LOGOTIME)<<8!NM)
%RETURN; ! END TIME
!
!
!
SYSFUN(116):; ! RANDOM
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&NM#NM %THENSTART
ERROR('NON-NUMERIC ARG FOR RANDOM - ',ARG1,1,IN)
%RETURN
%FINISH
%IF ARG1<0 %THENSTART
ARG2=-1
ARG1=-(ARG1>>8!T8)+1; ! POSITIVE BINARY +1
%FINISHELSESTART
ARG2=1
ARG1=ARG1>>8+1
%FINISH
STACK((INTPT(RANDOM(RANSEED,1)*ARG1)*ARG2)<<8!NM)
%RETURN; ! END RANDOM
!
!
SYSFUN(117):; ! APPLY
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
IN=CONS(ARG1,IN)
EVAL(0,IN,EACHVAL,WALKFN)
! STACK(UNSTACK)
%RETURN; ! END APPLY
!
!
SYSFUN(118):; ! ALERT
LIST(MASNUM.'LOGALERT')
STACK(NSR)
%RETURN; ! END ALERT
!
!
SYSFUN(119):; ! EXERCISE
%IF STATUS(MASNUM.'ELOGOO',0)>1 %THENSTART
ERROR(ERRMESS(29),EMPTY,1,IN)
%RETURN
%FINISH
MAPMASTER
%CYCLE ARG1=1,1,MASENTS
%IF USERIDS(ARG1)#'DESTROYED' %THENSTART
WSTR1='LOGO'.NUMTOSTR(ARG1<<8)
%IF STATUS(MASNUM.WSTR1,1)<0 %THENSTART
PRSTRING(WSTR1.' NEEDS RESTORED FOR USER '.USERIDS(ARG1))
NOOLINE(1)
%FINISHELSE DISCONNECT(MASNUM.WSTR1)
%FINISH
%REPEAT
DISCONMASTER
%CYCLE ARG1=1,1,8
%IF STATUS('ECMI50.'.TDEVNAMES(ARG1),1)<0 %THENSTART
PRSTRING('SYSTEM FILE '.TDEVNAMES(ARG1).' NEEDS RESTORING.')
NOOLINE(1)
PRSTRING('SET PERMIT TO R ALL ROUND AFTER RESTORE.');NOOLINE(1)
%FINISHELSE DISCONNECT('ECMI50.'.TDEVNAMES(ARG1))
%REPEAT
%CYCLE ARG1=1,1,4
%IF STATUS(MASNUM.SYSFILES(ARG1),1)<0 %THENSTART
PRSTRING('SYSTEM FILE '.SYSFILES(ARG1).' NEEDS RESTORING.')
NOOLINE(1)
PRSTRING('SET PERMIT TO RS ALL ROUND AFTER RESTORE.')
NOOLINE(1)
%FINISHELSE DISCONNECT(MASNUM.SYSFILES(ARG1))
%REPEAT
STACK(NSR)
%RETURN; ! END EXERCISE
!
!
SYSFUN(120):; ! DUMP
DUMP('USER REQUEST')
STACK(NSR);
%RETURN; ! END DUMP
!
!
SYSFUN(121):; ! GETID
MAPMASTER
WSTR3=PROMP
PROMP='WHO ARE YOU:'
DPROMPT(PROMP)
WHOLP:ARG1=READLINE
%IF ARG1=NIL %THEN ->WHOLP
USER=CHECKID(ARG1)
%IF USER='' %THENSTART; ! INVALID OR NULL RESPONSE
PRSTRING('WRONGLY FORMATTED IDENTIFIER ')
PRINTEL(ARG1); NOOLINE(1)
->WHOLP
%FINISH
%CYCLE ARG1=1,1,MASENTS
%IF USER=USERIDS(ARG1) %THEN ->WHOOK
%REPEAT
! NOT FOUND
PRSTRING('LOGO DOES NOT KNOW '.USER)
NOOLINE(1)
->WHOLP
!
WHOOK:OWNFILE=MASNUM.'LOGO'.NUMTOSTR(ARG1<<8)
CONOWNFILE
DISCONMASTER
PROMP=WSTR3
DPROMPT(PROMP)
STACK(NSR)
%RETURN; ! END GETID
!
!
SYSFUN(122):; ! GETTY
SELECTINPUT(0)
CLOSESTREAM(3)
CLEAR('ST03')
DESTROY('LOGOTEMP')
PRSTRING('TEMPORARY FILE DESTROYED');NOOLINE(1)
PRSTRING('LOADED AND READY');NOOLINE(3)
STACK(NSR)
%RETURN; ! END GETTY
!
!
SYSFUN(123):; ! TRUE
STACK(TRUE)
%RETURN; ! END TRUE
!
!
SYSFUN(124):; ! FALSE
STACK(FALSE)
%RETURN; ! END FALSE
!
!
SYSFUN(125):; !SPACE
PRINTEL(SPACE1)
STACK(NSR)
%RETURN; ! END SPACE
!
!
SYSFUN(126):; ! TAB
PRINTEL(TAB)
STACK(NSR)
%RETURN; ! END TAB
!
!
SYSFUN(127):; ! NL, CARRIAGE
NOOLINE(1)
STACK(NSR)
%RETURN; ! END NL
!
!
SYSFUN(128):; ! EMPTY
STACK(EMPTY)
%RETURN; ! END EMPTY
!
!
SYSFUN(129):; ! SYSTEM
STACK(OWNFUNS)
%RETURN; ! END SYSTEM
!
!
SYSFUN(130):; ! SETULIM
ARG1=UNSTACKINPUT;%IF JUMPFLAG=1 %THENRETURN
%IF ARG1&NM#NM %OR ARG1<0 %THENSTART
ERROR('SETULIM NEEDS A NON-NEGATIVE NUMBER - ',ARG1,1,IN)
%RETURN
%FINISH
APPULIM=ARG1>>8
STACK(NSR)
%RETURN; ! END SETULIM
!
!
SYSFUN(131):; ! SETELIM
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&NM#NM %OR ARG1<0 %THENSTART
ERROR('SETELIM NEEDS A POSITIVE NUMBER - ',ARG1,1,IN)
%RETURN
%FINISH
EVALIMIT=ARG1>>8
STACK(NSR)
%RETURN; ! END SETELIM
!
!
SYSFUN(132):; ! SETCFLG
CLECTFLG=1
STACK(NSR)
%RETURN; ! END SETCFLG
!
!
SYSFUN(133):; ! HASHINFO
ARG1=HASH1023//HASH1024
PRSTRING( ' AVERAGE NO OF ACCESSES OF WA= ');WRITE(ARG1,6)
NOOLINE(1);PRSTRING( ' WHERE NO OF WORDS HASHED= ')
WRITE(HASH1024,8);NOOLINE(1)
PRSTRING( ' AND TOTAL NO OF ACCESSES OF WA= ')
WRITE(HASH1023,8)
NOOLINE(1)
PRSTRING( ' DUMPING INFO TO FILE HASHINFO');NOOLINE(1)
SELECT OUTPUT(1)
%CYCLE ARG1=0,1,1022
%UNLESS WA(ARG1)='?' %THENSTART
NOOLINE(1);PRSTRING( ' ORIG HASH VALUE=')
WRITE(HASHINFO(ARG1),5)
PRSTRING( ' ACHIEVED ENTRY KEY=');WRITE(ARG1,5)
PRSTRING( ' WORD= ');PRSTRING(WA(ARG1))
%FINISH
%REPEAT
SELECT OUTPUT(0);PRSTRING( ' FILE HASH INFO WRITTEN');NOOLINE(1)
STACK(NSR)
%RETURN; ! END HASHINFO
!
!
SYSFUN(134):; ! MAKEASSOC
ARG3=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN; ! VALUE
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN; ! ATTRIBUTE
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN; ! OBJECT
%IF ARG1&WM#WM %THENSTART
ERROR('INVALID FIRST ARG FOR MAKEASSOC - ',ARG1,1,IN)
%RETURN
%FINISH
ARG1=ARG1>>8; ! WA INDEX
STACK(NSR)
ARG3=CONS(ARG2,CONS(ARG3,NIL)); ! [ATT VAL]
%IF FINDASS(ASSOCWA(ARG1),ARG2)=NIL %THENSTART; ! NO EXISTING ASSOC
ASSOCWA(ARG1)=CONS(ARG3,ASSOCWA(ARG1))
! INSERT [ATT VAL] AS FIRST ELEMENT IN ASSLIST FOR THIS OBJECT
%FINISHELSESTART; ! ASSOC ALREADY EXISTS. W2 POINTS TO LIST
! WHOSE HEAD IS ASSOC
REPHEAD(W2,ARG3)
%FINISH
%RETURN; ! END MAKEASSOC
!
!
SYSFUN(135):; ! GETASSOC
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN; ! ATT
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN; ! OB
%IF ARG1&WM#WM %THENSTART
ERROR('INVALID FIRST ARG FOR GETASSOC - ',ARG1,1,IN)
%RETURN
%FINISH
ARG3=FINDASS(ASSOCWA(ARG1>>8),ARG2)
%IF ARG3#NIL %THEN ARG3=HD(TL(HD(ARG3))); ! VALUE
STACK(ARG3)
%RETURN; ! END GETASSOC
!
!
SYSFUN(136):; ! REMASSOC
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&WM#WM %THENSTART
ERROR('INVALID FIRST ARG FOR REMASSOC - ',ARG1,1,IN)
%RETURN
%FINISH
ARG1=ARG1>>8
ARG3=FINDASS(ASSOCWA(ARG1),ARG2)
%IF ARG3#NIL %THENSTART; ! ASSOC EXISTS
%IF W1=W2 %THEN ASSOCWA(ARG1)=TL(W2) %ELSE REPTAIL(W1,TL(W2))
%FINISH
STACK(NSR)
%RETURN; ! END REMASSOC
!
!
SYSFUN(137):; ! CLEARASSOC
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&WM#WM %THENSTART
ERROR('INVALID ARG FOR CLEARASSOC - ',ARG1,1,IN)
%RETURN
%FINISH
ASSOCWA(ARG1>>8)=NIL
STACK(NSR)
%RETURN; ! END CLEARASSOC
!
!
SYSFUN(138):; ! CLEARALLASSOC
%CYCLE ARG1=0,1,1022
ASSOCWA(ARG1)=NIL
%REPEAT
STACK(NSR)
%RETURN; ! END CLEARALLASSOC
!
!
!
!
SYSFUN(141):; ! WALK
ARG1=UNSTACKINPUT;%IF JUMPFLAG=1 %THENRETURN
%IF WALKFN#UNDEF %THENSTART
ERROR('YOU CAN ONLY WALK THROUGH ONE PROCEDURE AT A TIME',%C
EMPTY,1,IN)
%RETURN
%FINISH
%IF ARG1&WM#WM %THENSTART
ERROR('PROCEDURE WALK MUST HAVE A PROCEDURE NAME AS INPUT.'%C
.'
IT WAS GIVEN ',ARG1,1,IN)
%RETURN
%FINISH
ARG2=FNVAL(ARG1>>8)
%IF ARG2=0 %THENSTART
ERROR('THERE IS NO PROCEDURE IN WORKING MEMORY TO WALK THROUGH' %C
.' NAMED ',ARG1,1,IN)
%RETURN
%FINISH
%IF ARG2&B4#USERPRE %THENSTART
ERROR('YOU CAN ONLY WALK THROUGH ONE OF YOUR OWN PROCEDURES', %C
EMPTY,1,IN)
%RETURN
%FINISH
IN=CONS(ARG1,IN)
NXTSTP=1
ARG2=ARG2&M16!LM
EVAL(0,IN,EACHVAL,ARG2)
NXTSTP=NUMTOP
!STACK(UNSTACK)
%RETURN; ! END WALK
!
!
SYSFUN(142):; ! STEP
ARG1=UNSTACKINPUT;%IF JUMPFLAG=1 %THENRETURN
%IF WALKFN=UNDEF %THENSTART
ERROR('YOU ARE NOT IN STEPPING MODE',EMPTY,1,IN)
%RETURN
%FINISH
%IF WALKFN#FUN %THENSTART
ERROR('YOU CAN ONLY STEP THROUGH ONE PROCEDURE AT A TIME',EMPTY,1,IN)
%RETURN
%FINISH
%IF ARG1&NM#NM %THENSTART
ERROR('PROCEDURE STEP MUST HAVE A NUMBER AS INPUT.'%C
.'
IT WAS GIVEN ',ARG1,1,IN)
%RETURN
%FINISH
%IF ARG1<0 %THENSTART
ERROR('PROCEDURE STEP MUST HAVE A POSITIVE NUMBER AS INPUT.' %C
.'
IT WAS GIVEN ',ARG1,1,IN)
%RETURN
%FINISH
NXTSTP=NXTSTP+(ARG1>>8)
STACK(NSR)
%RETURN; ! END STEP
!
!
SYSFUN(143):; ! FINISH
%IF WALKFN=UNDEF %THENSTART
ERROR('YOU ARE NOT IN STEPPING MODE',EMPTY,1,IN)
%RETURN
%FINISH
%IF WALKFN#FUN %THENSTART
ERROR('YOU ARE NOT STEPPING THROUGH THIS PROCEDURE',EMPTY,1,IN)
%RETURN
%FINISH
NXTSTP=NUMTOP
STACK(NSR)
%RETURN; !END FINISH
!
!
SYSFUN(144):; ! HALFTRACE (TRACE)
ARG3=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=TRACE(TRACE1,ARG3,FN)
%IF JUMPFLAG=1 %THENRETURN
%IF ARG1#NIL %THENSTART
%IF ARG1=OWNFUNS %THEN PRSTRING('ALL OF LOGOS PROCEDURES') %C
%ELSESTART
PRSTRING('PROCEDURES ')
PRINTEL(REVERSE(ARG1))
%FINISH
PRSTRING(' HAVE BEEN MARKED FOR TRACING')
NOOLINE(1)
%FINISH
STACK(NSR)
%RETURN; ! END HALFTRACE
!
!
SYSFUN(145):; ! TRACE (FULLTRACE)
ARG3=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=TRACE(TRACE2,ARG3,FN)
%IF JUMPFLAG=1 %THENRETURN
%IF ARG1#NIL %THENSTART
%IF ARG1=OWNFUNS %THEN PRSTRING('ALL OF LOGOS PROCEDURES') %C
%ELSESTART
PRSTRING('PROCEDURES ')
PRINTEL(REVERSE(ARG1))
%FINISH
PRSTRING(' HAVE BEEN MARKED FOR FULL TRACING')
NOOLINE(1)
%FINISH
STACK(NSR)
%RETURN; ! END FULLTRACE
!
!
SYSFUN(146):; ! PARSE
ARG3=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=TRACE(PARSE,ARG3,FN)
%IF JUMPFLAG=1 %THENRETURN
%IF ARG1#NIL %THENSTART
%IF ARG1=OWNFUNS %THEN PRSTRING('ALL OF LOGOS PROCEDURES') %C
%ELSESTART
PRSTRING('PROCEDURES ')
PRINTEL(REVERSE(ARG1))
%FINISH
PRSTRING(' HAVE BEEN MARKED FOR PARSING')
NOOLINE(1)
%FINISH
STACK(NSR)
%RETURN; !END PARSE
!
!
SYSFUN(147):; ! UNTRACE
ARG3=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
NOOLINE(1)
%IF ARG3=OWNFUNS %THEN W1=SYSTRACE(0,FN) %AND ->UNTR2
%IF ARG3&WM=WM %THEN ARG3=CONS(ARG3,NIL)
%IF ARG3&LM#LM %THENSTART
ERROR(WA(FN>>8).ERRMESS(24),ARG3,1,IN)
%RETURN
%FINISH
W1=NIL
%WHILE ARG3#NIL %CYCLE
ARG1=HD(ARG3)
ARG3=TL(ARG3)
%IF ARG1&WM#WM %THENSTART
ERROR1(WA(FN>>8).ERRMESS(24),CONS(ARG1,ARG3))
->UNTR1
%FINISH
ARG2=FNVAL(ARG1>>8)
%IF ARG2=0 %THENSTART
ERROR1(ERRMESS(21).WA(ARG1>>8).ERRMESS(23),FN)
->UNTR1
%FINISH
FNVAL(ARG1>>8)=ARG2&UNMASK; ! REMOVE TRACE FLAG. IF SYSFUN NO EFFECT
W1=CONS(ARG1,W1)
UNTR1:%REPEAT
UNTR2:%IF W1#NIL %THENSTART
%IF W1=OWNFUNS %THEN PRSTRING('ALL OF LOGOS PROCEDURES') %C
%ELSESTART
PRSTRING('PROCEDURES ')
PRINTEL(REVERSE(W1))
%FINISH
PRSTRING(' WILL NO LONGER BE ')
%IF FN=UNPARSE %THEN PRSTRING('PARSED.') %ELSE PRSTRING('TRACED.')
NOOLINE(1)
%FINISH
STACK(NSR)
%RETURN; ! END UNTRACE
!
!
SYSFUN(148):; ! MAPLIST
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&LM#LM %THENSTART
ERROR('NON-LIST ARG FOR MAPLIST - ',ARG1,1,IN)
%RETURN
%FINISH
ARG3=NIL
%IF ARG2&WM=WM %THENSTART
%WHILE ARG1#NIL %CYCLE
W2=HD(ARG1)
%IF W2&WM=WM %THEN W2=CONS(QUOTE,CONS(W2,NIL)) %C
%ELSE W2=CONS(W2,NIL)
W1=CONS(ARG2,W2)
ARG1=TL(ARG1)
STKSYS(IN);STKSYS(ARG1);STKSYS(ARG3)
EVAL(0,W1,EACHVAL,WALKFN)
ARG3=UNSTKSYS;ARG1=UNSTKSYS;IN=UNSTKSYS
%IF JUMPFLAG=1 %THENRETURN
ARG3=CONS(UNSTACK,ARG3)
%REPEAT
%FINISHELSESTART
%IF ARG2&LM#LM %THENSTART
ERROR('INVALID 2ND ARG FOR MAPLIST - ',ARG2,1,IN)
%RETURN
%FINISH
%WHILE ARG1#NIL %CYCLE
W1=HD(ARG1)
ARG1=TL(ARG1)
STKSYS(IN);STKSYS(ARG1);STKSYS(ARG2);STKSYS(ARG3)
EVAL(0,ARG2,W1,WALKFN)
ARG3=UNSTKSYS;ARG2=UNSTKSYS;ARG1=UNSTKSYS;IN=UNSTKSYS
%IF JUMPFLAG=1 %THENRETURN
ARG3=CONS(UNSTACK,ARG3)
%REPEAT
%FINISH
%WHILE ARG3#NIL %CYCLE
ARG1=CONS(HD(ARG3),ARG1)
ARG3=TL(ARG3)
%REPEAT
STACK(ARG1)
%RETURN; ! END MAPLIST
!
!
SYSFUN(149):; ! APPLIST
ARG2=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&LM#LM %THENSTART
ERROR('NON-LIST ARG FOR APPLIST - ',ARG1,1,IN)
%RETURN
%FINISH
ARG3=NIL
%IF ARG2&WM=WM %THENSTART
%WHILE ARG1#NIL %CYCLE
W1=HD(ARG1)
%IF W1&WM=WM %THEN W1=CONS(QUOTE,CONS(W1,NIL)) %C
%ELSE W1=CONS(W1,NIL)
ARG3=CONS(ARG2,W1)
ARG1=TL(ARG1)
STKSYS(IN);STKSYS(ARG1)
EVAL(0,ARG3,EACHVAL,WALKFN)
ARG1=UNSTKSYS;IN=UNSTKSYS
%IF JUMPFLAG =1 %THENRETURN
ARG3=UNSTACK
%REPEAT
%FINISHELSESTART
%IF ARG2&LM#LM %THENSTART
ERROR('INVALID 2ND ARG FOR APPLIST - ',ARG2,1,IN)
%RETURN
%FINISH
%WHILE ARG1#NIL %CYCLE
W1=HD(ARG1)
ARG1=TL(ARG1)
STKSYS(IN);STKSYS(ARG1);STKSYS(ARG2)
EVAL(0,ARG2,W1,WALKFN)
ARG2=UNSTKSYS;ARG1=UNSTKSYS;IN=UNSTKSYS
%IF JUMPFLAG=1 %THENRETURN
ARG3=UNSTACK
%REPEAT
%FINISH
STACK(NSR)
%RETURN; ! END APPLIST
!
!
SYSFUN(150):; ! EACH
%IF EACHVAL=UNDEF %THEN ERROR('EACH USED OUT OF CONTEXT',EMPTY,1,IN) %C
%ELSE STACK(EACHVAL)
%RETURN; ! END EACH
!
!
SYSFUN(151):; ! CLEARDATABASE
ARG3=BVALUE(FACTKEYS>>8)
%WHILE ARG3#NIL %CYCLE
ARG1=HD(ARG3)>>8
ARG3=TL(ARG3)
ARG2=FINDASS(ASSOCWA(ARG1),FACT)
%IF ARG2#NIL %THENSTART
%IF W1=W2 %THEN ASSOCWA(ARG1)=TL(W2) %ELSE REPTAIL(W1,TL(W2))
%FINISH
%REPEAT
ARG3=BVALUE(IMPKEYS>>8)
%WHILE ARG3#NIL %CYCLE
ARG1=HD(ARG3)>>8
ARG3=TL(ARG3)
ARG2=FINDASS(ASSOCWA(ARG1),IMPLIES)
%IF ARG2#NIL %THENSTART
%IF W1=W2 %THEN ASSOCWA(ARG1)=TL(W2) %ELSE REPTAIL(W1,TL(W2))
%FINISH
%REPEAT
ARG3=BVALUE(INFKEYS>>8)
%WHILE ARG3#NIL %CYCLE
ARG1=HD(ARG3)>>8
ARG3=TL(ARG3)
ARG2=FINDASS(ASSOCWA(ARG1),TOINFER)
%IF ARG2#NIL %THENSTART
%IF W1=W2 %THEN ASSOCWA(ARG1)=TL(W2) %ELSE REPTAIL(W1,TL(W2))
%FINISH
%REPEAT
SETUPINF
STACK(NSR)
%RETURN; ! END CLEARDATABASE
!
!
SYSFUN(152):; ! ASSERT
ARG1=UNSTACK
%IF ARG1&LM#LM %OR ARG1=NIL %THENSTART
ERROR('INVALID ARG FOR ASSERT -',ARG1,1,IN)
%RETURN
%FINISH
%IF HD(ARG1)=IMPLIES %THEN ADDRULE(ARG1,0,IMPLINKS) %ELSESTART
%IF HD(ARG1)=TOINFER %THEN ADDRULE(ARG1,0,INFLINKS) %C
%ELSE ADDFACT(ARG1,0)
%FINISH
%IF JUMPFLAG=1 %THENRETURN
STACK(NSR)
%RETURN; ! END ASSERT
!
!
SYSFUN(153):; ! AMONGQ
ARG2=UNSTACK
ARG1=UNSTACK
%IF ARG2&LM#LM %THENSTART
ERROR('INVALID 2ND ARG FOR AMONGQ -',ARG2,1,IN)
%RETURN
%FINISH
%WHILE ARG2#NIL %CYCLE
ARG3=EQUAL(HD(ARG2),ARG1)
%IF JUMPFLAG=1 %THEN STACK(ARG3) %AND %RETURN
%IF ARG3=TRUE %THEN STACK(TRUE) %AND %RETURN
ARG2=TL(ARG2)
%REPEAT
STACK(FALSE)
%RETURN; ! END AMONGQ
!
!
SYSFUN(154):; !ISQ
ARG1=UNSTACK
%IF ARG1&LM#LM %OR ARG1=NIL %THENSTART
ERROR('INVALID ARG FOR ISQ -',ARG1,1,IN)
%RETURN
%FINISH
STACK(DEDUCEQ(ARG1,0))
%RETURN; ! END ISQ
!
!
SYSFUN(155):; !FINDANY
ARG2=UNSTACK
ARG1=UNSTACK
%IF ARG1&LM#LM %OR ARG1=NIL %THENSTART
ERROR('INVALID 1ST ARG FOR FINDANY -',ARG1,1,IN)
%RETURN
%FINISH
%IF ARG2&LM#LM %OR ARG2=NIL %THENSTART
ERROR('INVALID 2ND ARG FOR FINDANY -',ARG2,1,IN)
%RETURN
%FINISH
ARG3=DEDUCEQ(ARG2,0)
%IF JUMPFLAG=1 %THEN STACK(ARG2) %ANDRETURN
%IF ARG3=TRUE %THEN STACK(BINDINGS(ARG1)) %ELSE STACK(NIL)
%RETURN; ! END FINDANY
!
!
SYSFUN(156):; ! FINDALL
ARG2=UNSTACK
ARG1=UNSTACK
%IF ARG1&LM#LM %OR ARG1=NIL %THENSTART
ERROR('INVALID 1ST ARG FOR FINDALL -',ARG1,1,IN)
%RETURN
%FINISH
%IF ARG2&LM#LM %OR ARG2=NIL %THENSTART
ERROR('INVALID 2ND ARG FOR FINDALL -',ARG2,1,IN)
%RETURN
%FINISH
ARG3=NIL
ARG2=DEDUCEQ(ARG2,0)
%IF JUMPFLAG=1 %THEN STACK(ARG2) %ELSE STACK(ARG3)
%RETURN; !END FINDALL
!
!
!
!
SYSFUN(160):; ! FORWARD
ARG1=CHDEVARG
%IF ARG1=ERR %THENRETURN
->FDSW(TDEV)
!
FDSW(1):FDSW(2): ! PLOTTERS
DY=ARG1*SIN(HDTURTLE/57.3)
DX=ARG1*COS(HDTURTLE/57.3)
COORDOK(INTPT(XTURTLE+DX));%IF JUMPFLAG=1 %THENRETURN
COORDOK(INTPT(YTURTLE+DY));%IF JUMPFLAG=1 %THENRETURN
%IF PENTURTLE=DOWN %THENSTART
BINARG1=0
BINARG2=4
SENDBIN(0,2); ! PENDOWN
%FINISH
BINARG1=2
BINARG2=INTPT(DX+FRACPT(XTURTLE))<<5
BINARG3=INTPT(DY+FRACPT(YTURTLE))<<5
SENDBIN(0,3); ! OUTLINV(DX,DY)
%IF PENTURTLE=DOWN %THENSTART
BINARG1=0
BINARG2=0
SENDBIN(0,2); ! PENUP
%FINISH
XTURTLE=XTURTLE+DX; YTURTLE=YTURTLE+DY
STACK(NSR); ! NO SPECIAL RESULT
%RETURN
!
FDSW(3):; ! DISPLAY
DY=ARG1*SIN(HDTURTLE/57.3)
DX=ARG1*COS(HDTURTLE/57.3)
COORDOK(INTPT(XTURTLE+DX));%IF JUMPFLAG=1 %THENRETURN
COORDOK(INTPT(YTURTLE+DY));%IF JUMPFLAG=1 %THENRETURN
BINARG2=INTPT(DX+FRACPT(XTURTLE))<<5
BINARG3=INTPT(DY+FRACPT(YTURTLE))<<5
%IF PENTURTLE=DOWN %THEN BINARG1=9 %ELSE BINARG1=5
SENDBIN(0,3); ! DLINEV(DX,DY) OR DSETV(DX,DY)
XTURTLE=XTURTLE+DX
YTURTLE=YTURTLE+DY
STACK(NSR)
%RETURN
!
FDSW(4):; ! TURTLE
%IF ARG1=0 %THEN STACK(NSR) %ANDRETURN
DY=ARG1*SIN(HDTURTLE/57.3)
DX=ARG1*COS(HDTURTLE/57.3)
%IF ARG1<0 %THEN TSEND(BDBITS,TSCALE(-ARG1)) %ELSEC
TSEND(FDBITS,TSCALE(ARG1))
%IF JUMPFLAG=1 %THENRETURN
XTURTLE=XTURTLE+DX;YTURTLE=YTURTLE+DY
STACK(NSR)
%RETURN
!
FDSW(5):FDSW(6):FDSW(7):; ! PUNCH,MUXIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
FDSW(8): ;! GT42 DISPLAY
DX=ARG1*COS(HDTURTLE/57.3)
DY=ARG1*SIN(HDTURTLE/57.3)
COORDOK(INTPT(XTURTLE+DX));%IF JUMPFLAG=1 %THENRETURN
COORDOK(INTPT(YTURTLE+DY));%IF JUMPFLAG=1 %THENRETURN
! *** CHECK FOR COMPILING A PICTURE (LATER VERSION)
VECTOR(DX,DY)
XTURTLE=XTURTLE+DX
YTURTLE=YTURTLE+DY
STACK(NSR)
%RETURN; ! END FORWARD
!
!
SYSFUN(161):; ! BACKWARD
ARG1=CHDEVARG
%IF ARG1=ERR %THENRETURN
->BDSW(TDEV)
!
BDSW(1):BDSW(2):; ! PLOTTERS
ARG1=-ARG1
->FDSW(1)
!
BDSW(3):; ! DISPLAY
ARG1=-ARG1
->FDSW(3)
!
BDSW(4):; ! TURTLE
ARG1=-ARG1
->FDSW(4)
!
BDSW(5):BDSW(6):BDSW(7):; ! PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
BDSW(8): ;! GT42 DISPLAA
ARG1 = -ARG1
-> FDSW(8); ! END BACKWARD
!
SYSFUN(162):; ! LEFT
ARG1=CHDEVARG
%IF ARG1=ERR %THENRETURN
->LEFTSW(TDEV)
LEFTSW(1):LEFTSW(2):; ! PLOTTERS
%IF ARG1=0 %THEN STACK(NSR) %ANDRETURN
HDTURTLE=MOD360(HDTURTLE+ARG1)
%IF ARG1<0 %THEN PINDSEND(0,-ARG1) %ELSE PINDSEND(PINDLBIT,ARG1)
%IF JUMPFLAG=1 %THENRETURN
STACK(NSR)
%RETURN
!
LEFTSW(3):; ! DIPLAYS
HDTURTLE=MOD360(HDTURTLE+ARG1)
STACK(NSR)
%RETURN
!
LEFTSW(4):; ! TURTLE
%IF ARG1=0 %THEN STACK(NSR) %ANDRETURN
HDTURTLE=MOD360(HDTURTLE+ARG1)
%IF ARG1<0 %THEN TSEND(RTBITS,TANGLE(-ARG1)) %ELSEC
TSEND(LTBITS,TANGLE(ARG1))
%IF JUMPFLAG=1 %THENRETURN
STACK(NSR)
%RETURN
!
LEFTSW(5):LEFTSW(6):LEFTSW(7):; ! PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
LEFTSW(8): ;! GT42 DISPLAY
HDTURTLE=MOD360(HDTURTLE+ARG1)
CALC TURTLE
STACK(NSR)
%RETURN; ! END LEFT
!
SYSFUN(163):; ! RIGHT
ARG1=CHDEVARG
%IF ARG1=ERR %THENRETURN
->RIGHTSW(TDEV)
!
RIGHTSW(1):RIGHTSW(2):; ! PLOTTERS
ARG1=-ARG1
->LEFTSW(1)
!
RIGHTSW(3):; ! DISPLAY
ARG1=-ARG1
->LEFTSW(3)
!
RIGHTSW(4):; ! TURTLE
ARG1=-ARG1
->LEFTSW(4)
!
RIGHTSW(5):RIGHTSW(6):RIGHTSW(7):; ! PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
RIGHTSW(8): ;! GT42 DISPLAA
ARG1=-ARG1
-> LEFTSW(8); ! END RIGHT
!
SYSFUN(164):; ! LIFT PEN
->LIFTSW(TDEV)
!
LIFTSW(1):LIFTSW(2):LIFTSW(3):LIFTSW(8):; ! PLOTTERS AND DISPLAYS
PENTURTLE=UP
STACK(NSR)
%RETURN
!
LIFTSW(4):; ! TURTLE
PENTURTLE=UP
TSEND1(32)
STACK(NSR)
%RETURN
!
LIFTSW(5):LIFTSW(6):LIFTSW(7):; ! PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN; !END LIFT
!
!
SYSFUN(165):; ! DROP PEN
->DROPSW(TDEV)
!
DROPSW(1):DROPSW(2):DROPSW(3):DROPSW(8):; ! PLOTTERS AND DISPLAYS
PENTURTLE=DOWN
STACK(NSR)
%RETURN
!
DROPSW(4):; ! TURTLE
PENTURTLE=DOWN
TSEND1(32)
STACK(NSR)
%RETURN
!
DROPSW(5):DROPSW(6):DROPSW(7):; ! PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN; ! END DROP
!
!
SYSFUN(166):; ! HOOT
->HOOTSW(TDEV)
!
HOOTSW(1):HOOTSW(2):HOOTSW(3):HOOTSW(5):HOOTSW(6):HOOTSW(7):
! PLOTTERS,DISPLAY,PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
HOOTSW(4):; ! TURTLE
TSEND1(HOOTBIT)
STACK(NSR)
%RETURN
!
HOOTSW(8): ;! GT42 DISPLAY
SET42(CHPIC)
CH3(BLEEP)
STACK(NSR)
%RETURN; ! END HOOT
!
!
SYSFUN(167):; ! CENTRE
->CENSW(TDEV)
!
CENSW(1):CENSW(2):; ! PLOTTERS
XTURTLE=0
YTURTLE=0
HDTURTLE=0
PENTURTLE=DOWN
BINARG1=1
BINARG2=0
BINARG3=0
SENDBIN(0,3); ! OUTLIN(0,0)
PINDSEND(PINDRBIT+PINDLBIT,360); ! RESET IND ANTICLOCK
%IF JUMPFLAG=1 %THENRETURN
STACK(NSR)
%RETURN
!
CENSW(3):; ! DISPLAY
XTURTLE=0
YTURTLE=0
HDTURTLE=0
PENTURTLE=DOWN
BINARG1=6
BINARG2=0
BINARG3=0
SENDBIN(0,3); ! DPOINT(0,0)
STACK(NSR)
%RETURN
!
CENSW(4):; ! TURTLE
ARG2=0
ARG3=0
W1=0
W2=DOWN
->POSW(4); ! SETTURTLE
!
CENSW(5):CENSW(6):CENSW(7):; ! PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
CENSW(8): ;! GT42 DISPLAY
XTURTLE=0
YTURTLE=0
HDTURTLE=0
PENTURTLE=DOWN
POINT(512,512)
CALC TURTLE
STACK(NSR)
%RETURN; ! END CENTRE
!
!
SYSFUN(168):; ! CLEAR
->CLSW(TDEV)
!
CLSW(1):CLSW(2):CLSW(4):; ! PLOTTERS,TURTLE NULL
STACK(NSR)
%RETURN
!
CLSW(5):CLSW(6):CLSW(7):; ! PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
CLSW(3):; ! DISPLAY
BINARG1=0
SENDBIN(0,1); ! CLEARDIS
->WHSW(3)
CLSW(8): ;! GT42 DISPLAY
SET42(CHPIC)
CLEAR42
XTURTLE=0
YTURTLE=0
HDTURTLE=0
PENTURTLE=DOWN
POINT(512,512)
-> WHSW(8); ! END CLEAR
!
!
SYSFUN(169):; ! WHERE
->WHSW(TDEV)
!
WHSW(1):WHSW(2):; ! PLOTTERS
ARG1=HDTURTLE+90
BINARG1=0
BINARG2=4
SENDBIN(0,2); ! PENDOWN
%CYCLE W1=1,1,2
ARG1=MOD360(ARG1+60)
ARG2=INT(10.0*SIN(ARG1/57.3))
ARG3=INT(10.0*COS(ARG1/57.3))
BINARG1=2
BINARG2=ARG3<<5
BINARG3=ARG2<<5
SENDBIN(0,3); ! OUTLINV(DX,DY)
BINARG2=-BINARG2
BINARG3=-BINARG3
SENDBIN(0,3); ! OUTLINV(-DX,-DY)
%REPEAT
BINARG1=0
BINARG2=0
SENDBIN(0,2); ! PENUP
STACK(NSR)
%RETURN
!
WHSW(3):; ! DISPLAY
RW1=SIN(HDTURTLE/57.3)
RW2=COS(HDTURTLE/57.3)
BINARG1=12
BINARG2=INT(-1300.0*(0.9659*RW2+0.2588*RW1))
BINARG3=INT(-1300.0*(0.9659*RW1-0.2588*RW2))
BINARG4=INT(0.5176*1300.0*RW1)
BINARG5=INT(-0.5176*1300.0*RW2)
SENDBIN(0,5); ! DRAWTURT
STACK(NSR)
%RETURN
!
WHSW(4):WHSW(5):WHSW(6):WHSW(7):; ! TURTLE,PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
WHSW(8): ;! GT42 DISPLAY
SHOW TURTLE 42 = 1
CALC TURTLE
STACK(NSR)
%RETURN; ! END WHERE
!
!
SYSFUN(170):; ! HERE
->HERESW(TDEV)
!
HERESW(1):HERESW(2):HERESW(3):HERESW(4):HERESW(8):; ! PLOTTERS,DISPLAY,TURTLE
STACK(TSTATE)
%RETURN
!
HERESW(5):HERESW(6):HERESW(7):; ! PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN; ! END HERE
!
!
SYSFUN(171):; ! XCOR
->XCORSW(TDEV)
!
XCORSW(1):XCORSW(2):XCORSW(3):XCORSW(4):XCORSW(8):; ! PLOTTERS,DISPLAY,TURTLE
STACK(INTPT(XTURTLE)<<8!NM)
%RETURN
!
XCORSW(5):XCORSW(6):XCORSW(7):; ! PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN; ! END XCOR
!
!
SYSFUN(172):; ! YCOR
->YCORSW(TDEV)
!
YCORSW(1):YCORSW(2):YCORSW(3):YCORSW(4):YCORSW(8):; ! PLOTTERS,DISPLAY,TURTLE
STACK(INTPT(YTURTLE)<<8!NM)
%RETURN
!
YCORSW(5):YCORSW(6):YCORSW(7):; ! PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN; ! END YCOR
!
!
SYSFUN(173):; ! HEADING
->HDSW(TDEV)
!
HDSW(1):HDSW(2):HDSW(3):HDSW(4):HDSW(8):; ! PLOTTERS,DISPLAY,TURTLE
STACK(HDTURTLE<<8!NM)
%RETURN
!
HDSW(5):HDSW(6):HDSW(7):; ! PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN; ! END HEADING
!
!
SYSFUN(174):; ! PEN
->PENSW(TDEV)
!
PENSW(1):PENSW(2):PENSW(3):PENSW(4):PENSW(8):; ! PLOTTERS,DISPLAY,TURTLE
STACK(PENTURTLE)
%RETURN
!
PENSW(5):PENSW(6):PENSW(7):; ! PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN; ! END PEN
!
!
SYSFUN(175):; ! SETX
ARG1=CHDEVARG
%IF ARG1=ERR %THENRETURN
->SETXSW(TDEV)
!
SETXSW(1):SETXSW(2):; ! PLOTTERS
COORDOK(ARG1);%IF JUMPFLAG=1 %THENRETURN
XTURTLE=ARG1
BINARG1=1
BINARG2=ARG1<<5
BINARG3=INTPT(YTURTLE)<<5
SENDBIN(0,3); ! OUTLIN(X,Y)
STACK(NSR)
%RETURN
!
SETXSW(3):; ! DISPLAY
COORDOK(ARG1);%IF JUMPFLAG=1 %THENRETURN
XTURTLE=ARG1
%IF PENTURTLE=DOWN %THEN BINARG1=6 %ELSE BINARG1=4
! EITHER DPOINT(X,Y) OR DSET(X,Y)
BINARG2=ARG1<<5
BINARG3=INTPT(YTURTLE)<<5
SENDBIN(0,3)
STACK(NSR)
%RETURN
!
SETXSW(4):; ! TURTLE
SETUP(ARG1-INTPT(XTURTLE),HDTURTLE)
%IF JUMPFLAG=1 %THENRETURN
XTURTLE=ARG1
STACK(NSR)
%RETURN
!
SETXSW(5):SETXSW(6):SETXSW(7):; ! PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
SETXSW(8): ;! GT42 DISPLAY
COORDOK(ARG1);%IF JUMPFLAG=1 %THENRETURN
XTURTLE=ARG1
POINT(XTURTLE+512,YTURTLE+512)
STACK(NSR)
%RETURN; ! END SETX
!
SYSFUN(176):; ! SETY
ARG1=CHDEVARG
%IF ARG1=ERR %THENRETURN
->SETYSW(TDEV)
!
SETYSW(1):SETYSW(2):; ! PLOTTERS
COORDOK(ARG1);%IF JUMPFLAG=1 %THENRETURN
YTURTLE=ARG1
BINARG1=1
BINARG2=INTPT(XTURTLE)<<5
BINARG3=ARG1<<5
SENDBIN(0,3); ! OUTLIN,X,Y)
STACK(NSR)
%RETURN
!
SETYSW(3):; ! DISPLAY
COORDOK(ARG1);%IF JUMPFLAG=1 %THENRETURN
YTURTLE=ARG1
%IF PENTURTLE=DOWN %THEN BINARG1=6 %ELSE BINARG1=4
BINARG2=INTPT(XTURTLE)<<5
BINARG3=ARG1<<5
SENDBIN(0,3)
STACK(NSR)
%RETURN
!
SETYSW(4):; ! TURTLE
SETUP(ARG1-INTPT(YTURTLE),HDTURTLE-90)
%IF JUMPFLAG=1 %THENRETURN
YTURTLE=ARG1
STACK(NSR)
%RETURN
!
SETYSW(5):SETYSW(6):SETYSW(7):; ! PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
SETYSW(8): ;! GT42 DISPLAY
COORDOK(ARG1);%IF JUMPFLAG=1 %THENRETURN
YTURTLE=ARG1
POINT(XTURTLE+512,YTURTLE+512)
STACK(NSR)
%RETURN; ! END SETY
!
!
SYSFUN(177):; ! SETHEADING
ARG1=CHDEVARG
%IF ARG1=ERR %THENRETURN
->SETHSW(TDEV)
!
SETHSW(1):SETHSW(2):; ! PLOTTERS
ARG1=MOD360(ARG1-HDTURTLE)
%IF ARG1>180 %THEN ARG1=ARG1-360
->LEFTSW(1)
!
SETHSW(3):; ! DISPLAY
HDTURTLE=MOD360(ARG1)
STACK(NSR)
%RETURN
!
SETHSW(4):; ! TURTLE
ARG1=MOD360(ARG1-HDTURTLE)
%IF ARG1>180 %THEN ARG1=ARG1-360
->LEFTSW(4)
!
SETHSW(5):SETHSW(6):SETHSW(7):; ! PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
SETHSW(8): ;! GT42 DISPLAY
HDTURTLE=MOD360(ARG1)
CALC TURTLE
STACK(NSR)
%RETURN; ! END SETHEADING
!
SYSFUN(178):SYSFUN(190):; ! POSITION,LINE
ARG1=UNSTACKINPUT; %IF JUMPFLAG=1 %THENRETURN
%IF ARG1&LM=0 %THENSTART
ERROR('LIST INPUT REQUIRED FOR ',FN,1,IN)
%RETURN
%FINISH
%IF SW=190 %THENSTART
%IF LISTLEN(ARG1)#2 %THEN ->POS1
%FINISHELSESTART
%IF LISTLEN(ARG1)#4 %THEN ->POS1
%FINISH
ARG2=HD(ARG1);ARG1=TL(ARG1); ! X
ARG3=HD(ARG1);ARG1=TL(ARG1); ! Y
%IF SW=190 %THENSTART
W1=HDTURTLE<<8!NM
W2=PENTURTLE
%FINISHELSESTART
W1=HD(ARG1);ARG1=TL(ARG1); ! HEADING
W2=HD(ARG1); ! PEN
%FINISH
%IF ARG2&NM=0 %OR ARG3&NM=0 %OR W1&NM=0 %ORC
(W2#UP %AND W2#DOWN) %THEN ->POS1
ARG2=IMPNUM(ARG2)
ARG3=IMPNUM(ARG3)
W1=IMPNUM(W1)
->POSW(TDEV)
!
POSW(1):POSW(2):; ! PLOTTERS
COORDOK(ARG2);%IF JUMPFLAG=1 %THENRETURN
COORDOK(ARG3);%IF JUMPFLAG=1 %THENRETURN
XTURTLE=ARG2
YTURTLE=ARG3
PENTURTLE=W2
%IF SW=190 %AND PENTURTLE=DOWN %THENSTART
BINARG1=0
BINARG2=4
SENDBIN(0,2)
%FINISH
BINARG1=1
BINARG2=ARG2<<5
BINARG3=ARG3<<5
SENDBIN(0,3); ! OUTLIN(X,Y)
ARG1=W1
%IF SW=190 %AND PENTURTLE=DOWN %THENSTART
BINARG1=0
BINARG2=0
SENDBIN(0,2)
%FINISH
->SETHSW(1)
POS1:ERROR('WRONGLY FORMATTED LIST FOR ',FN,1,IN)
%RETURN
!
POSW(3):; ! DISPLAY
COORDOK(ARG2);%IF JUMPFLAG=1 %THENRETURN
COORDOK(ARG3);%IF JUMPFLAG=1 %THENRETURN
XTURTLE=ARG2
YTURTLE=ARG3
HDTURTLE=MOD360(W1)
PENTURTLE=W2
%IF PENTURTLE=DOWN %THENSTART
%IF SW=190 %THEN BINARG1=8 %ELSE BINARG1=6
%FINISHELSE BINARG1=4
BINARG2=ARG2<<5
BINARG3=ARG3<<5
SENDBIN(0,3)
STACK(NSR)
%RETURN
!
POSW(4):; ! TURTLE
%IF SW=190 %THEN ERROR(ERRMESS(33),FN,1,IN) %ANDRETURN
PENTURTLE=UP
TSEND1(32); ! PENUP
SETUP(ARG2-INTPT(XTURTLE),HDTURTLE)
%IF JUMPFLAG=1 %THENRETURN
SETUP(ARG3-INTPT(YTURTLE),HDTURTLE-90)
%IF JUMPFLAG=1 %THENRETURN
XTURTLE=ARG2
YTURTLE=ARG3
ARG1=MOD360(W1-HDTURTLE)
HDTURTLE=MOD360(W1)
%IF ARG1>180 %THEN ARG1=ARG1-360
%IF ARG1#0 %THENSTART
%IF ARG1<0 %THEN TSEND(RTBITS,TANGLE(-ARG1)) %ELSEC
TSEND(LTBITS,TANGLE(ARG1))
%IF JUMPFLAG=1 %THENRETURN
%FINISH
PENTURTLE=W2
TSEND1(32)
STACK(NSR)
%RETURN
!
POSW(5):POSW(6):POSW(7):; ! PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
POSW(8): ;! GT42 DISPLAY
COORDOK(ARG2); %IF JUMPFLAG=1 %THEN %RETURN
COORDOK(ARG3); %IF JUMPFLAG=1 %THEN %RETURN
%IF SW=190 %THENSTART
DX=ARG2-XTURTLE
DY=ARG3-YTURTLE
VECTOR(DX,DY)
XTURTLE=ARG2
YTURTLE=ARG3
STACK(NSR)
%RETURN
%FINISH
XTURTLE=ARG2
YTURTLE=ARG3
HDTURTLE= MOD360(W1)
PENTURTLE=W2
POINT(XTURTLE+512,YTURTLE+512)
CALC TURTLE
STACK(NSR)
%RETURN; ! END POSITION
!
!
SYSFUN(179):; ! ARCLEFT
ARG1=CHDEVARG
%IF ARG1=ERR %THENRETURN
ARG2=CHDEVARG
%IF ARG2=ERR %THENRETURN
ARG3=0 ; ! TO INDICATE LEFT
! ARG1=ANG,ARG2=RAD
->ARCLSW(TDEV)
!
ARCLSW(1):ARCLSW(2):; ! PLOTTERS
%IF ARG1=0 %THEN ->ARCL1
%IF ARG2=0 %THEN ->LEFTSW(1); ! ZERO RAD. DO LEFT(ANG)
XC=INT(-ARG2*SIN(HDTURTLE/57.3)*32)
YC=INT(ARG2*COS(HDTURTLE/57.3)*32)
RW1=2.0*ARG2*SIN(ARG1/114.6)
DX=RW1*COS((HDTURTLE+ARG1/2.0)/57.3)
DY=RW1*SIN((HDTURTLE+ARG1/2.0)/57.3)
CIRCLETEST(ARG3,ARG2,ARG1)
%IF JUMPFLAG=1 %THENRETURN
W1=INT(0.5*MOD(ARG2)*ARG1/360.0*32)
%IF PENTURTLE=DOWN %THENSTART
BINARG1=0
BINARG2=4
SENDBIN(0,2); ! PENDOWN
%FINISH
%IF W1#0 %THENSTART
BINARG1=4
BINARG2=XC
BINARG3=YC
BINARG4=W1
SENDBIN(0,4); ! OUTCRCLV(XC,YC,W1)
%FINISH
XTURTLE=XTURTLE+DX
YTURTLE=YTURTLE+DY
BINARG1=1
BINARG2=INTPT(XTURTLE)<<5
BINARG3=INTPT(YTURTLE)<<5; ! OUTLIN(X,Y) TO FINISH
SENDBIN(0,3)
%IF PENTURTLE=DOWN %THENSTART
BINARG1=0
BINARG2=0
SENDBIN(0,2)
%FINISH
->LEFTSW(1); ! TO DO HDTURTLE AND INDICATOR
ARCL1:STACK(NSR)
%RETURN
!
ARCLSW(3):; ! DISPLAY
%IF ARG1=0 %THEN ->ARCL2
%IF ARG2=0 %THEN ->LEFTSW(3)
XC=INT(-ARG2*SIN(HDTURTLE/57.3)*32)
YC=INT(ARG2*COS(HDTURTLE/57.3)*32)
RW1=2.0*ARG2*SIN(ARG1/114.6)
DX=RW1*COS((HDTURTLE+ARG1/2.0)/57.3)
DY=RW1*SIN((HDTURTLE+ARG1/2.0)/57.3)
CIRCLETEST(ARG3,ARG2,ARG1)
%IF JUMPFLAG=1 %THENRETURN
W1=INT(0.5*MOD(ARG2)*ARG1/360.0*32)
%IF PENTURTLE=DOWN %AND W1#0 %THENSTART
BINARG1=11
BINARG2=XC
BINARG3=YC
BINARG4=W1
SENDBIN(0,4); ! DCIRCLV(XC,YX,W1)
%FINISHELSESTART
BINARG1=5
BINARG2=INTPT(DX+FRACPT(XTURTLE))<<5
BINARG3=INTPT(DY+FRACPT(YTURTLE))<<5
SENDBIN(0,3); ! DSETV(DX,DY)
%FINISH
XTURTLE=XTURTLE+DX
YTURTLE=YTURTLE+DY
HDTURTLE=MOD360(HDTURTLE+ARG1)
ARCL2:%IF PENTURTLE=DOWN %THEN BINARG1=6 %ELSE BINARG1=4
BINARG2=INTPT(XTURTLE)<<5
BINARG3=INTPT(YTURTLE)<<5
SENDBIN(0,3); ! DPOINT OR DSET TO FINISH
STACK(NSR)
%RETURN
!
ARCLSW(4):; ! TURTLE
%IF ARG1=0 %THEN STACK(NSR) %ANDRETURN
%IF ARG2=0 %THEN ->LEFTSW(4)
TARCLEFT(ARG2,ARG1)
%IF JUMPFLAG=1 %THENRETURN
STACK(NSR)
%RETURN
!
ARCLSW(5):ARCLSW(6):ARCLSW(7):; ! PINCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
ARCLSW(8): ;! GT42
%IF ARG1=0 %THEN STACK(NSR) %ANDRETURN
%IF ARG2=0 %THEN ->LEFTSW(8)
GTARCLEFT(ARG2,ARG1)
%IF JUMPFLAG=1 %THENRETURN
STACK(NSR)
%RETURN; ! END ARCLEFT
!
!
SYSFUN(180):; ! ARCRIGHT
ARG1=CHDEVARG
%IF ARG1=ERR %THENRETURN
ARG2=CHDEVARG
%IF ARG2=ERR %THENRETURN
ARG3=1 ; ! TO INDICATE RIGHT
! ARG1=ANG,ARG2=RAD
->ARCRSW(TDEV)
!
ARCRSW(1):ARCRSW(2):; ! PLOTTERS
ARG2=-ARG2
ARG1=-ARG1
->ARCLSW(1)
!
ARCRSW(3):; ! DISPLAY
ARG2=-ARG2
ARG1=-ARG1
->ARCLSW(3)
!
ARCRSW(4):; ! TURTLE
ARG2=-ARG2
->ARCLSW(4)
!
ARCRSW(5):ARCRSW(6):ARCRSW(7):; ! PUNCH,MUSIC,MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
ARCRSW(8): ;! GT42
ARG2=-ARG2
-> ARCLSW(8); ! END ARCRIGHT
!
!
SYSFUN(181):; ! PUNCH
->PNSW(TDEV)
!
PNSW(1):PNSW(2):PNSW(3):PNSW(4):PNSW(6):PNSW(7):PNSW(8):
! ALL BUT PUNCH
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
PNSW(5):; ! PUNCH
ARG1=CHDEVARG
%IF ARG1=ERR %THENRETURN
%IF ARG1>255 %THENSTART
ERROR('NUMBER TOO BIG TO BE PUNCHED',EMPTY,1,IN)
%RETURN
%FINISH
%IF ARG1<0 %THENSTART
ERROR('NEGATIVE NUMBERS CANNOT BE PUNCHED',EMPTY,1,IN)
%RETURN
%FINISH
BINARG1=0
BINARG2=ARG1
SENDBIN(0,2); ! PUNCH(ARG1)
STACK(NSR)
%RETURN; ! END PUNCH
!
!
SYSFUN(182):; ! RUNOUT
->RNSW(TDEV)
!
RNSW(1):RNSW(2):RNSW(3):RNSW(4):RNSW(6):RNSW(7):RNSW(8):
! ALL BUT PUNCH
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
RNSW(5):; ! PUNCH
BINARG1=1
SENDBIN(0,1); ! RUNOUT
STACK(NSR)
%RETURN; ! END RUNOUT
!
!
FDSW(0):BDSW(0):LEFTSW(0):RIGHTSW(0):LIFTSW(0):DROPSW(0):HOOTSW(0):
CENSW(0):CLSW(0):WHSW(0):HERESW(0):XCORSW(0):YCORSW(0):HDSW(0):PENSW(0):
SETXSW(0):SETYSW(0):SETHSW(0):POSW(0):ARCLSW(0):ARCRSW(0):PNSW(0):
RNSW(0):NOTESW(0):PLAYSW(0):MOTASW(0):MOTBSW(0):ROTSW(0):PAIRSW(0):
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
!
SYSFUN(183):; ! PLOTTERA
CLAIMDEVICE(1)
%IF JUMPFLAG=1 %THENRETURN
->CENSW(1); ! END PLOTTERA
!
!
SYSFUN(184):; ! PLOTTERB
CLAIMDEVICE(2)
%IF JUMPFLAG=1 %THENRETURN
->CENSW(2); ! END PLOTTERB
!
!
SYSFUN(185):; ! DISPLAY
CLAIMDEVICE(3)
%IF JUMPFLAG=1 %THENRETURN
BINARG1=0;SENDBIN(0,1); ! CLEARDIS
->CENSW(3); ! END DISPLAY
!
!
SYSFUN(186):; ! TURTLE
CLAIMDEVICE(4)
%IF JUMPFLAG=1 %THENRETURN
XTURTLE=0;YTURTLE=0;HDTURTLE=0;PENTURTLE=DOWN
TSEND1(32); ! PUT PEN DOWN
STACK(NSR)
%RETURN; ! END TURTLE
!
!
SYSFUN(187):; ! TAPE
CLAIMDEVICE(5)
%IF JUMPFLAG=1 %THENRETURN
->RNSW(5); ! END TAPE
!
!
SYSFUN(188):; ! FREE
%IF TDEV=0 %THENSTART
ERROR(ERRMESS(51),EMPTY,1,IN)
%RETURN
%FINISH
WSTR1=TDEVNAMES(TDEV)
%IF TDEV=8 %THEN DISCONNECT(MASNUM.'EXEC26')
FREEDEVICE
PRSTRING(WSTR1.' DISCONNECTED');NOOLINE(1)
STACK(NSR)
%RETURN; ! END FREE
!
!
SYSFUN(189):; ! CLESET
%IF TDEV=0 %THENSTART
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
%FINISH
CLESET
STACK(NSR)
%RETURN; ! END CLESET
!
!
!
SYSFUN(191):; ! MUSIC
CLAIMDEVICE(6)
%IF JUMPFLAG=1 %THENRETURN
STACK(NSR)
%RETURN; ! END MUSIC
!
!
SYSFUN(192):; ! MECCANO
CLAIMDEVICE(7)
%IF JUMPFLAG=1 %THENRETURN
XTURTLE=0;YTURTLE=0;HDTURTLE=0;PENTURTLE=DOWN
STACK(NSR)
%RETURN; ! END MECCANO
!
!
!
!
SYSFUN(200): ;! GT42
CLAIMDEVICE(8)
%IF JUMPFLAG=1 %THENRETURN
LOAD42(GT42 EXEC)
MODIFY EXEC
CLEAR 42
POINT(512,512)
GRAPHP = INIT GRAPHP
PICTURE POINTER = CORE BOTTOM
SET42(CHTXT)
HDTURTLE=0
XTURTLE=0
YTURTLE=0
PENTURTLE=DOWN
STACK(NSR)
%RETURN; ! END GT42
!
!
SYSFUN(201):; ! HIDE (HIDETURTLE FOR GT42???)
%IF TDEV#8 %THEN ERROR (ERRMESS(33),FN,1,IN) %ANDRETURN
HIDE TURTLE
STACK(NSR)
%RETURN; ! END HIDE
!
!
!
!
SYSFUN(210): ;! PICTURE / PIC
%IF TDEV#8 %THEN ERROR (%C
ERRMESS(33),FN,1,IN) %ANDRETURN
ARG1=UNSTACKINPUT; %RETURNIF JUMPFLAG=1
%IF ARG1&WM#WM %THEN ERROR ( %C
'PICTURE NEEDS A WORD FOR FIRST ARG-',ARG1,1,IN) %C
%AND %RETURN
W1=ARG1>>8 ;! GET INDEX FROM ARG
TSTOR(1)=XTURTLE
TSTOR(2)=YTURTLE
TSTORI(3)=HDTURTLE
TSTORI(4)=PENTURTLE
CURPIC=CONSG(INT(YTURTLE)+512,CONSG(INT(XTURTLE)+512 %C
,CONSG(CURMODE,NIL)))
GMODE=0
DEF PICTURE=1 ;! SET COMPILE FLAG
EVAL(0,IN,EACHVAL,WALKFN) ;! AND EXECUTE DRAWING FN
%IF JUMPFLAG = 1 %THEN DEF PICTURE=0 %ANDRETURN
INDEX42(W1)_PTR=REVERSE(CURPIC) ;! AND DEF PICTUREE PICTURE DEFINITION
INDEX42(W1)_PTR42=0 ;! SET PICTURE FLAG
XTURTLE=TSTOR(1)
YTURTLE=TSTOR(2)
HDTURTLE=TSTORI(3)
PENTURTLE=TSTORI(4)
DEF PICTURE=0 ;! RESET MARKER
STACK(NSR) ;!RETURN PIC NAME AS RESULT
%RETURN
!
!
!
!
!
%RETURN
SYSFUN(211): ;! INCLUDE / INC
%IF TDEV#8 %THEN ERROR (%C
'YOU NEED THE GT42 TO RUN MOVIES ',EMPTY,1,IN) %ANDRETURN
%IF FRAMEFLAG=0 %THEN ERROR (%C
'YOU ARE NOT INSIDE A FRAME ',EMPTY,1,IN) %ANDRETURN
ARG1=UNSTACKINPUT ;! GET NAME AND CHECK IT
%RETURNIF JUMPFLAG=1
%IF ARG1&WM#WM %THEN ERROR ( %C
'INCLUDE NEEDS A WORD ARGUMENT-',ARG1,1,IN) %AND %RETURN
W1=ARG1>>8
%IF INDEX42(W1)_PTR=0 %THEN ERROR ( %C
'PICTURE DOES NOT EXIST-',ARG1,1,IN) %AND %RETURN
%IF INDEX42(W1)_PTR42=0 %THEN INC (W1)
;! PICTURE NOT ALREADY IN
!DUMP CODE TO INCLUDE PICTURE AT CURRENT CRANE COORDS
!*** WHEN MOVIE IS RUN
INDEX42(W1)_MODE=CURMODE
CURFRAME=CONSG(YCRANE,CONSG(XCRANE,CONSG(CURMODE,CONSG(3, %C
CONSG(INDEX42(W1)_PTR42,CONSG(SETN,CURFRAME))))))
INDEX42(W1)_X=XCRANE ;! RECORD CURRENT COORDS
INDEX42(W1)_Y = YCRANE
STACK(NSR)
%RETURN ;! END-- INCLUDE
SYSFUN(212): ;! ACTION
%IF TDEV#8 %THEN ERROR ( %C
'YOU NEED THE GT42 TO RUN MOVIES',EMPTY,1,IN )%ANDRETURN
%IF FRAMEFLAG# 0 %THEN ERROR ( %C
'ACTION INSIDE FRAME INVALID',EMPTY,1,IN) %AND%RETURN
FRAMEFLAG=1 ;! SET FRAME FLAG
CURFRAME=NIL ;! AND INITIALISE FRAMELIST
SAVE PROMP=PROMP
PROMP='A:'
DPROMPT(PROMP)
%IF GRABLIST=NIL %START ;! CRANE ONLY INITIALISED
;!TO CENTRE WHEN NOTHING
;! IS CURRENTLY GRABBED
XCRANE=512
YCRANE=512
%FINISH
HDCRANE=0 ;!**CRANE HEADING 0 ON ENTRY
%CYCLE W1=1,1,1022 ;! CLEAR MOVE CTRS
INDEX42(W1)_MOVED=0
INDEX42(W1)_LAST MOVE TIME = FRAME TIME
%REPEAT
STACK(NSR)
%RETURN
!
SYSFUN(213): ;! CUT
%IF TDEV#8 %THEN ERROR ( %C
'YOU NEED THE GT42 TO RUN MOVIES' ,EMPTY,1,IN) %ANDRETURN
%IF FRAMEFLAG=0 %THEN ERROR ( %C
'CUT OUTSIDE FRAME INVALID',EMPTY,1,IN) %AND %RETURN
FRAMEFLAG=0 ;! END OF FRAME
%IF CURFRAME=NIL %THENSTART ;! SPECIAL CASE --
;! NULL FRAME DECLARED SO PAD
;! FOR "FRAMETIME" TIME UNITS
W2=CONSG(WAIT,CONSG(FRAME TIME,NIL))
CURMOVIE = CONS(W2,CURMOVIE)
PROMP=SAVE PROMP; DPROMPT(PROMP)
STACK(NSR)
%RETURN
%FINISH
%CYCLE W1 = 1,1,FRAME TIME ;! RESET MOVIE RECORD
;! 'MOVIE RECORD' IS A
;!A TABLE OF LISTS
MOVIE RECORD(W1) = NIL
%REPEAT
!
CURRENT MOVIE TIME = 1
W1=CURFRAME
%WHILE W1#NIL %CYCLE
ARG1=HD(W1)//256
%IF ARG1>0 %AND ARG1&CRANE MASK=CRANE MARK %START
;! MOVE GROUP FOUND, EG
;! [MARK DY DX PTR TO INDEX ---]
W1=TL(W1) ;! 'POP' MARK
W2 = HD(TL(TL(W1))) >> 8
;! AND GET PTR TO INDEX
%IF HD(W1)>>8 = CRANE MARK %THEN %C
W4=INT(HD(TL(W1))/INDEX42(W2)_MOVED * FRAME TIME) %C
%ELSESTART ;! COULD BE A 'HOLD' MARK
RW1 = SQRT((HD(W1)/256.0)**2 + (HD(TL(W1))/256.0)**2)
W4 = INT(RW1/INDEX42(W2)_MOVED * FRAME TIME)
;! CALCULATE TIME THIS MOVE
;! WILL TAKE. ( = FRACTION OF
;! OF TOTAL DISTANCE MOVED *
;! TIME TAKEN FOR FRAME )
%FINISH
W4 = 1 %IF W4 <= 0
W4 = FRAME TIME %IF W4 > FRAME TIME
WPTR1 == INDEX42(W2)_LAST MOVE TIME
WPTR1 = WPTR1 - W4
WPTR1 = 1 %IF WPTR1 <= 0
WPTR1 = FRAME TIME %IF WPTR1 > FRAME TIME
;! WPTR1 NOW POINTS TO THE
;! THE APPROPRIATE MOVIE
;! RECORD
%IF HD(W1)>>8 # CRANE MARK %THEN %C
MOVIE RECORD (WPTR1) = %C
CONS(HD(W1),CONS(HD(TL(W1)),CONSG(W4, CONSG ( %C
INDEX42(W2)_PTR42+2,CONSG(PMOV,MOVIE RECORD (WPTR1))))))
;! ADD CELL TO LIST !
CURRENT MOVIE TIME = WPTR1 ;! UPDATE CURRENT MOVIE
;! CLOCK SO THAT ANY INCLUSIONS
;! OR OMMISIONS
;! CAN BE ADDED TO
;! THE APPROPRIATE MOVIE
;! RECORD
W1 = TL(TL(TL(W1))) ;! POP CELL FROM LIST
%FINISH %ELSE %START
ARG1 = HD(W1)
ARG2 = MOVIE RECORD(CURRENT MOVIE TIME)
LASTPUT
MOVIE RECORD (CURRENT MOVIE TIME)= UNSTACK
W1 = TL(W1)
%FINISH
%REPEAT
!
!*** FRAME NOW DISSSEMBLED INTO TIME SLICES ON MOVIE
!*** RECORD ARRAY.
!
!*** NOW REASSEMBLE INTO CURFRAME (BACKWARDS, OF COURSE)
!*** AND DUMP APPROPRIATE 'WAIT' INSTRUCTIONS
!
CURFRAME = NIL
W1 = FRAME TIME +1
%CYCLE
W2 = 0 ;! NO OF OUTSTANDING TIME
;! INNCREMENTS
W1=W1-1 %AND W2=W2+1 %UNTIL W1 = 0 %C
%OR MOVIE RECORD(W1) # NIL ;! FIND LENGTH OF NEXT WAIT
%IF W1=0 %THENSTART ;! END OF FRAME
CURMOVIE=CONS(REVERSE(CURFRAME),CURMOVIE)
;! ADD TO MOVIE LIST
STACK(NSR)
PROMP = SAVE PROMP; DPROMPT (PROMP)
%RETURN
%FINISH
ARG2=CONSG (W2, CONSG(WAIT, MOVIE RECORD(W1)))
;! CURRENT TIME SLICE OF
;! FRAME
ARG1=CURFRAME ;! ARGS LIKE THIS FOR LPUT
CURFRAME = APPENDL(ARG1,ARG2) ;! FUNCTION
!
! *** LOTS OF LIST SPACE BEING CLAIMED/FREED, SO CHECK FOR
! *** POSSIBLE GARBAGE COLLECTS
!
%IF CLECTFLG = 1 %THENSTART ;! GARBAGE COLLECT NEEDED
%CYCLE W4=1,1,W1 ;! PUT REMAINING MOVIE RECORD
;!INTO COLLECTABLE SPACE
STACK(MOVIE RECORD(W4))
%REPEAT
STKSYS(IN) ; STKSYS(VAL) ;! SYSTEM SPACE
COLLECT (ENVIR)
VAL=UNSTKSYS ; IN=UNSTKSYS ;! RESTORE
%CYCLE W4 = W1,-1,1
MOVIE RECORD(W4)=UNSTACK
%REPEAT
%FINISH
%REPEAT
!
!
!
!
SYSFUN(214): ;! ROLLMOVIE / ROLL
%IF TDEV#8 %THEN ERROR (ERRMESS(33),FN,1,IN) %C
%ANDRETURN
%IF FRAMEFLAG#0 %THEN ERROR (%C
'CANNOT ROLL MOVIE INSIDE A FRAME',EMPTY,1,IN) %AND%RETURN
SET42(CHPIC)
! *** TUURTLE IS SWITCHED OFF FOR DURATION OF MOVIE
!
W4 = SHOW TURTLE 42 ;! SAVE CURRENT SHOWN STATE
%IF W4 = 1 %THEN HIDE TURTLE
LBR ;! NEST COMMAND GROUP
%CYCLE W1=0,1,1022 ;! OMIT ANY CURRENTLY
%IF INDEX42(W1)_PTR42#0 %START ;!INCLUDED PICTURES
CH3(SETN); CH3(INDEX42(W1)_PTR42)
CH3(2); CH3(DJUMP); CH3(INDEX42(W1)_FADDR) ;! OMIT GROUP
%FINISH
%REPEAT
RBR ;! AND CLOSE GROUP
W1=REVERSE(CURMOVIE)
STACK(NSR)
%CYCLE
%IF W1 = NIL %START ;! END OF MOVIE
SHOW TURTLE %IF W4 = 1 ;! RESTORE ORIGINAL TURTLE STATE
%RETURN
%FINISH
W3=HD(W1) ;! NEXT FRAME
W1=TL(W1)
LBR ;! DEFER EXECUTION OF FRAMES
%WHILE W3#NIL %THEN %CYCLE
CH3(HD(W3)//256)
W3=TL(W3)
%REPEAT
RBR
%REPEAT
%RETURN
SYSFUN(215): ;! CRANE FORWARD (VERSION 2
%IF TDEV#8 %THEN ERROR(ERRMESS(33),FN,1,IN) %ANDRETURN
ARG1=UNSTACKINPUT
%RETURNIF JUMPFLAG=1 ;! CHECK FOR NUMERIC ARG
%IF ARG1&NM#NM %THEN ERROR (%C
'CRANEFORWARD NEEDS A NUMBER-',ARG1,1,IN) %ANDRETURN
%IF FRAMEFLAG= 0 %THEN ERROR (%C
'CRANE MOVEMENT OUTSIDE FRAME INVALID',EMPTY,1,IN) %ANDRETURN
W1=ARG1//256 ;! CONVERT TO ORDINARY NUM
CFD: W2=INTPT(W1*COS(HDCRANE/57.3)) ;!NEW COORDS
W3=INTPT(W1*SIN(HDCRANE/57.3)) ;! W2=DX : W3=DY
XCRANE=XCRANE+W2
YCRANE=YCRANE+W3
ARG2=GRABLIST ;! NOW MOVE ANY PICTURES
%WHILE ARG2#NIL %CYCLE ;! CURRENTLY 'GRABBED'
W4=HD(ARG2)>>8
INDEX42(W4)_MOVED=INDEX42(W4)_MOVED+!W1!
CURFRAME = CONSG(CRANE MARK, CONSG(W3, CONSG(W2, %C
CONSG(W4, CURFRAME)))) ;! ADD CELL TO FRAMELIST
INDEX42(W4)_X=INDEX42(W4)_X+W2
INDEX42(W4)_Y=INDEX42(W4)_Y + W3
ARG2=TL(ARG2)
%REPEAT
STACK(NSR)
%RETURN
SYSFUN(216): ;! CRANEBACKWARD
%IF TDEV#8 %THEN ERROR (ERRMESS(33),FN,1,IN) %ANDRETURN
ARG1=UNSTACKINPUT
%RETURNIF JUMPFLAG=1
%IF ARG1&NM#NM %THEN ERROR (%C
'CRANEBACKWARD NEEDS A NUMBER-',ARG1,1,IN) %ANDRETURN
%IF FRAMEFLAG=0 %THEN ERROR (%C
'CRANE MOVEMENT OUTSIDE FRAME INVALID',EMPTY,1,IN) %ANDRETURN
W1=-(ARG1//256)
-> CFD
SYSFUN(217): ;! CRANE LEFT / CLEFT
%IF TDEV#8 %THEN ERROR (ERRMESS(33),FN,1,IN) %ANDRETURN
ARG1=UNSTACKINPUT
%RETURNIF JUMPFLAG=1
%IF ARG1&NM#NM %THEN ERROR (%C
'CRANELEFT NEEDS A NUMBER-',ARG1,1,IN) %ANDRETURN
%IF FRAMEFLAG=0 %THEN ERROR (%C
'CRANE MOVEMENT OUTSIDE FRAME INVALID',EMPTY,1,IN) %C
%ANDRETURN
HDCRANE=MOD360(ARG1>>8+HDCRANE)
STACK(NSR)
%RETURN
SYSFUN(218): ;! CRANE RIGHT/ CRIGHT
%IF TDEV#8 %THEN ERROR (ERRMESS(33),FN,1,IN) %AND %RETURN
ARG1=UNSTACKINPUT
%RETURNIF JUMPFLAG=1
%IF ARG1&NM#NM %THEN ERROR (%C
'CRANERIGHT NEEDS A NUMBER',ARG1,1,IN) %ANDRETURN
%IF FRAMEFLAG=0 %THEN ERROR (%C
'CRANE MOVEMENT OUTSIDE FRAME INVALID',EMPTY,1,IN) %C
%AND %RETURN
HDCRANE=MOD360(HDCRANE-ARG1>>8)
STACK(NSR)
%RETURN
SYSFUN(219): ;! NEWMOVIE
%IF TDEV#8 %THEN ERROR(ERRMESS(33),FN,1,IN) %ANDRETURN
CURMOVIE=NIL ;! INITIALISES CURRENT MOVIE LIST
PROMP=SAVE PROMP %UNLESS FRAMEFLAG=0
FRAMEFLAG=0 ;!MAKE SURE NOT IN FRAME
DPROMPT(PROMP) ;!AND RESTORE DPROMPT
GRABLIST=NIL
STACK(NSR)
%RETURN
SYSFUN(220): ;! GRAB (VERSION 2)
%IF TDEV#8 %THEN ERROR(ERRMESS(33),FN,1,IN) %ANDRETURN
ARG1=UNSTACKINPUT
%RETURNIF JUMPFLAG=1 ;! CHECK ARGUMENT
%IF ARG1&WM#WM %THEN ERROR (%C
'I CAN''T GRAB ',ARG1,1,IN) %ANDRETURN
%IF FRAMEFLAG=0 %THEN ERROR (%C
'GRAB NOT VALID OUTSIDE FRAME',EMPTY,1,IN) %ANDRETURN
W1=ARG1>>8
%IF INDEX42(W1)_PTR42=0 %THEN ERROR (%C
'GRAB FAILS - PICTURE NOT IN GT42 -',ARG1,1,IN) %C
%ANDRETURN
%IF AMONGQ(ARG1,GRABLIST)=1 %THEN ERROR ( %C
'I HAVE ALREADY GRABBED ',ARG1,1,IN) %ANDRETURN
GRABLIST=CONS(ARG1,GRABLIST)
XCRANE=INDEX42(W1)_X ;! MOVE CRANE TO PICTURE
YCRANE=INDEX42(W1)_Y ;! COORDINATES
STACK (NSR)
%RETURN
SYSFUN(221): ;! RELEASE (VERSION2)
%IF TDEV#8 %THEN ERROR(ERRMESS(33),FN,1,IN) %ANDRETURN
ARG1=UNSTACKINPUT
%RETURNIF JUMPFLAG=1 ;! CHECK ARGUMET
%IF ARG1&WM#WM %THEN ERROR (%C
'I CAN''T RELEASE ',ARG1,1,IN) %ANDRETURN
%IF FRAMEFLAG=0 %THEN ERROR (%C
'RELEASE NOT VALID OUTSIDE FRAME',EMPTY,1,IN) %ANDRETURN
%IF AMONGQ(ARG1,GRABLIST)=0 %THEN ERROR ( %C
'I HAVE NOT GRABBED ',ARG1,1,IN) %ANDRETURN
GRABLIST=WITHOUT(ARG1,GRABLIST)
STACK (NSR)
%RETURN
SYSFUN(222): ;!SET CRANE/ SETC
%IF TDEV#8 %THEN ERROR (ERRMESS(33),FN,1,IN) %ANDRETURN
ARG1=UNSTACKINPUT
%RETURNIF JUMPFLAG=1 ;! GET ARG LIST
%IF FRAMEFLAG=0 %THEN ERROR (%C
'CRANE MOVEMENT OUTSDIE FRAME INVALID',EMPTY,1,IN) %C
%AND %RETURN
%IF ARG1&LM#LM %THEN ERROR ( %C
'SETCRANE NEEDS A LIST-',ARG1,1,IN) %AND %RETURN
ARG2=ARG1 ;! SAVE ARGUMENT
W1=GETNUMB(ARG1,'SETCRANE') ;! CHECK ALL CRANE
%IF W1=-100000 %THENRETURN
W2=GETNUMB(ARG1,'SETCRANE') ;!COORDS BEFORE
%RETURNIF W2=-100000
W3=GETNUMB(ARG1,'SETCRANE') ;!ALTERING POSITION
%RETURNIF W3 =-100000
XCRANE=CHECKXY(W1)+512
YCRANE=CHECKXY(W2)+512
HDCRANE=MOD360(W3)
STACK(NSR)
%RETURN
!
SYSFUN(223): ;!OMIT
%IF TDEV#8 %THEN ERROR(ERRMESS(33),FN,1,IN) %ANDRETURN
ARG1=UNSTACKINPUT ;! GET PICTURE NAME
%RETURNIF JUMPFLAG=1
%IF ARG1&WM#WM %THEN ERROR ( %C
'OMIT NEEDS A WORD-',ARG1,1,IN) %AND %RETURN
%IF FRAMEFLAG=0 %THEN ERROR ( %C
'OMIT OUTSIDE FRAME INVALID',EMPTY,1,IN) %AND %RETURN
W1=ARG1>>8
%IF INDEX42(W1)_PTR42=0 %THEN ERROR ( %C
'OMIT FAILS - PICTURE NOT IN GT42 -',ARG1,1,IN) %C
%ANDRETURN
GRABLIST=WITHOUT(ARG1,GRABLIST)
CURFRAME=CONSG(INDEX42(W1)_FADDR,CONSG(DJUMP,CONSG %C
(2,CONSG(INDEX42(W1)_PTR42,CONSG(SETN,CURFRAME)))))
STACK(NSR)
%RETURN
!
%RETURN
SYSFUN(224): ;! GRABLIST
%IF TDEV#8 %THEN ERROR(ERRMESS(33),FN,1,IN) %ANDRETURN
STACK(GRABLIST)
%RETURN
%RETURN
SYSFUN(228): ;! CRANEHERE
%IF TDEV#8 %THEN ERROR(ERRMESS(33),FN,1,IN) %ANDRETURN
%IF FRAMEFLAG=0 %THEN ERROR ( %C
'CRANE COMMAND OUTSIDE FRAME NOT VALID',EMPTY,1,IN) %C
%ANDRETURN
W2=XCRANE-512
W3=YCRANE-512
W1=CONSG(XCRANE,CONSG(YCRANE,CONSG(HDCRANE,NIL)))
STACK(W1)
%RETURN
!
%RETURN
SYSFUN(225): ;! CAPTION
%IF TDEV#8 %THEN ERROR(ERRMESS(33),FN,1,IN) %ANDRETURN
CAPFLAG=1
ARG1=UNSTACKINPUT
%RETURNIF JUMPFLAG=1
PRINTEL(ARG1)
CAPFLAG=0
STACK(NSR)
%RETURN
!
%RETURN
SYSFUN(226): ;! FRAMESPEED N
%IF TDEV#8 %THEN ERROR(ERRMESS(33),FN,1,IN) %ANDRETURN
ARG1=UNSTACKINPUT
%RETURNIF JUMPFLAG=1
%IF ARG1 & NM # NM %THEN ERROR ( %C
'FRAME SPEED NEEDS A NUMBER',ARG1,1,IN) %ANDRETURN
%IF FRAMEFLAG=1 %THEN ERROR (%C
'CANNOT ADJUST FRAMESPEED WITHIN A FRAME',EMPTY,1,IN) %C
%ANDRETURN
%IF ARG1< 0 %THEN ERROR (%C
'FRAMESPEED NEEDS A +VE NUMBER',ARG1,1,IN) %ANDRETURN
FRAMETIME=ARG1>>8
STACK(NSR)
%RETURN
!
SYSFUN(227): ;! KILL FRAME
%IF TDEV# 8 %THEN ERROR (ERRMESS(33),FN,1,IN) %ANDRETURN
%IF FRAMEFLAG=0 %THEN ERROR (%C
'KILLFRAME FAILS - NO FRAME CURRENT',EMPTY,1,IN) %C
%AND %RETURN
FRAMEFLAG=0
DPROMPT(SAVEPROMP)
PRSTRING('*** FRAME KILLED '.TIME.' ***')
NOOLINE(1)
STACK(NSR)
%RETURN
!
SYSFUN(229): ;! WIPE (CLEARS DYNAMIC DISPLAY SPACE)
!
SET CORE POINTER (CORE BOTTOM)
%CYCLE W1 = 0 , 1, 1022
INDEX42(W1)_PTR42 = 0
%REPEAT
CURMOVIE = NIL ;! RESET MOVIE LIST
STACK(NSR)
%RETURN
!
!
!
SYSFUN(230):; ! NOTE (FOR MUSIC BOX)
->NOTESW(TDEV)
!
NOTESW(1):NOTESW(2):NOTESW(3):NOTESW(4):NOTESW(5):NOTESW(7):NOTESW(8):
! ALL BUT MUSIC
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
NOTESW(6):; ! MUSIC
READYNUM;%IF JUMPFLAG=1 %THENRETURN
%UNLESS 0<=ARG1<=48 %THENSTART
ERROR('THE FIRST INPUT FOR NOTE MUST LIE BETWEEN 0 AND 48.
IT WAS GIVEN ', ARG1<<8!NM,1,IN)
%RETURN
%FINISH
%UNLESS 1<=ARG2<=256 %THENSTART
ERROR('THE SECOND INPUT FOR NOTE MUST LIE BETWEEN 1 AND 256.
IT WAS GIVEN ', ARG2<<8!NM,1,IN)
%RETURN
%FINISH
BINARG1=1
BINARG2=(ARG1<<8)!(ARG2-1)
SENDBIN(0,2)
STACK(NSR)
%RETURN
!
!
!
SYSFUN(231):; ! PLAY
->PLAYSW(TDEV)
!
PLAYSW(1):PLAYSW(2):PLAYSW(3):PLAYSW(4):PLAYSW(5):PLAYSW(7):PLAYSW(8):
! ALL BUT MUSIC
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
PLAYSW(6):; ! MUSIC
BINARG1=0
SENDBIN(0,1)
STACK(NSR)
%RETURN
!
!
!
SYSFUN(232):; ! REST
STACK(NM)
%RETURN
!
SYSFUN(233):; ! A0
STACK(1<<8!NM)
%RETURN
!
SYSFUN(234):; ! AS0
STACK(2<<8!NM)
%RETURN
!
SYSFUN(235):; ! B0
STACK(3<<8!NM)
%RETURN
!
SYSFUN(236):; ! C0
STACK(4<<8!NM)
%RETURN
!
SYSFUN(237):; ! CS0
STACK(5<<8!NM)
%RETURN
!
SYSFUN(238):; ! D0
STACK(6<<8!NM)
%RETURN
!
SYSFUN(239):; ! DS0
STACK(7<<8!NM)
%RETURN
!
SYSFUN(240):; ! E0
STACK(8<<8!NM)
%RETURN
!
SYSFUN(241):; ! F0
STACK(9<<8!NM)
%RETURN
!
SYSFUN(242):; ! FS0
STACK(10<<8!NM)
%RETURN
!
SYSFUN(243):; ! G0
STACK(11<<8!NM)
%RETURN
!
SYSFUN(244):; ! GS0
STACK(12<<8!NM)
%RETURN
!
SYSFUN(245):; ! A1
STACK(13<<8!NM)
%RETURN
!
SYSFUN(246):; ! AS1
STACK(14<<8!NM)
%RETURN
!
SYSFUN(247):; ! B1
STACK(15<<8!NM)
%RETURN
!
SYSFUN(248):; ! C1
STACK(16<<8!NM)
%RETURN
!
SYSFUN(249):; ! CS1
STACK(17<<8!NM)
%RETURN
!
SYSFUN(250):; ! D1
STACK(18<<8!NM)
%RETURN
!
SYSFUN(251):; ! DS1
STACK(19<<8!NM)
%RETURN
!
SYSFUN(252):; ! E1
STACK(20<<8!NM)
%RETURN
!
SYSFUN(253):; ! F1
STACK(21<<8!NM)
%RETURN
!
SYSFUN(254):; ! FS1
STACK(22<<8!NM)
%RETURN
!
SYSFUN(255):; ! G1
STACK(23<<8!NM)
%RETURN
!
SYSFUN(256):; ! GS1
STACK(24<<8!NM)
%RETURN
!
SYSFUN(257):; ! A2
STACK(25<<8!NM)
%RETURN
!
SYSFUN(258):; ! AS2
STACK(26<<8!NM)
%RETURN
!
SYSFUN(259):; ! B2
STACK(27<<8!NM)
%RETURN
!
SYSFUN(260):; ! C2
STACK(28<<8!NM)
%RETURN
!
SYSFUN(261):; ! CS2
STACK(29<<8!NM)
%RETURN
!
SYSFUN(262):; ! D2
STACK(30<<8!NM)
%RETURN
!
SYSFUN(263):; ! DS2
STACK(31<<8!NM)
%RETURN
!
SYSFUN(264):; ! E2
STACK(32<<8!NM)
%RETURN
!
SYSFUN(265):; ! F2
STACK(33<<8!NM)
%RETURN
!
SYSFUN(266):; ! FS2
STACK(34<<8!NM)
%RETURN
!
SYSFUN(267):; ! G2
STACK(35<<8!NM)
%RETURN
!
SYSFUN(268):; ! GS2
STACK(36<<8!NM)
%RETURN
!
SYSFUN(269):; ! A3
STACK(37<<8!NM)
%RETURN
!
SYSFUN(270):; ! AS3
STACK(38<<8!NM)
%RETURN
!
SYSFUN(271):; ! B3
STACK(39<<8!NM)
%RETURN
!
SYSFUN(272):; ! C3
STACK(40<<8!NM)
%RETURN
!
SYSFUN(273):; ! CS3
STACK(41<<8!NM)
%RETURN
!
SYSFUN(274):; ! D3
STACK(42<<8!NM)
%RETURN
!
SYSFUN(275):; ! DS3
STACK(43<<8!NM)
%RETURN
!
SYSFUN(276):; ! E3
STACK(44<<8!NM)
%RETURN
!
SYSFUN(277):; ! F3
STACK(45<<8!NM)
%RETURN
!
SYSFUN(278):; ! FS3
STACK(46<<8!NM)
%RETURN
!
SYSFUN(279):; ! G3
STACK(47<<8!NM)
%RETURN
!
SYSFUN(280):; ! GS3
STACK(48<<8!NM)
%RETURN
!
!
!
!
!
SYSFUN(281):; !MOTORA
->MOTASW(TDEV)
!
MOTASW(1):MOTASW(2):MOTASW(3):MOTASW(4):MOTASW(5):MOTASW(6):MOTASW(8):
! ALL BUT MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
MOTASW(7):; ! MECCANO
->DROPSW(4); ! TURTLE DROP FOR NOW
!
!
!
SYSFUN(282):; ! MOTORB
->MOTBSW(TDEV)
!
MOTBSW(1):MOTBSW(2):MOTBSW(3):MOTBSW(4):MOTBSW(5):MOTBSW(6):MOTBSW(8):
! ALL BUT MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
MOTBSW(7):; ! MECCANO
->LIFTSW(4); ! TURTLE LIFT FOR NOW
!
!
!
SYSFUN(283):; ! ROTATE
ARG1=CHDEVARG
%IF ARG1=ERR %THENRETURN
->ROTSW(TDEV)
!
ROTSW(1):ROTSW(2):ROTSW(3):ROTSW(4):ROTSW(5):ROTSW(6):ROTSW(8):
! ALL BUT MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
ROTSW(7):; ! MECCANO
->FDSW(4); ! TURTLE FORWARD FOR NOW
!
!
!
SYSFUN(284):; ! PAIR
ARG1=CHDEVARG
%IF ARG1=ERR %THENRETURN
->PAIRSW(TDEV)
!
PAIRSW(1):PAIRSW(2):PAIRSW(3):PAIRSW(4):PAIRSW(5):PAIRSW(6):PAIRSW(8):
! ALL BUT MECCANO
ERROR(ERRMESS(33),FN,1,IN)
%RETURN
!
PAIRSW(7):; ! MECCANO
->LEFTSW(4); ! TURTLE LEFT FOR NOW
!
!
!
%END; ! END APPLYSYS
!
%ROUTINE EVAL(%INTEGER PREC,%INTEGERNAME IN,EACHVAL,WALKFN)
%INTEGER FN,FUNSPEC,TYPE,ARGNO,PARMLIST,NEXTPREC,FUNLIST
%INTEGER WORK1,WORK2,TRACE
%SWITCH SYSTR(0:3),USRTR(0:3),OUTR(0:3),INFTR(0:3),INFOUTR(0:3)
%IF QUITFLAG=1 %THENSTART; ! USER INT Q
QUITFLAG=0;HOLDFLAG=0;JUMPOUT=0;JUMPFLAG=1
%IF TDEV#0 %THEN CLESET ; ! CLEAR AND RESET TURTLE DEVICE IF ANY
STACK(CONS(QQPROC,CONS(QUIT,NSRTAIL)))
%RETURN
%FINISH
%IF HOLDFLAG=1 %AND BORROWLOAD=0 %THENSTART
HOLDFLAG=0
%IF FUN#NIL %THENSTART
ERROR('USER INTERRUPT',EMPTY,0,IN)
%IF JUMPFLAG=1 %THENRETURN
%FINISH
%FINISH
! IF USER INTERRUPT HAS HAPPENED SERVICE IT
%IF CLECTFLG=1 %THENSTART; ! GARBAGE COLLECT NEEDED
STKSYS(IN);STKSYS(VAL);
COLLECT(ENVIR)
VAL=UNSTKSYS;IN=UNSTKSYS
%FINISH
EVALCNT=EVALCNT+1
%IF EVALCNT>=EVALIMIT %THENSTART
ERROR('EVALIMIT EXCEEDED',EMPTY,1,IN)
%RETURN
%FINISH
LP:%IF IN=NIL %THENSTART;STACK(CONS(QQPROC,CONS(NULL,NSRTAIL)));
%RETURN;%FINISH
FN=HD(IN)
IN=TL(IN)
%IF FN=COMMA %THEN ->LP; ! SEPARATOR
TOP:%IF FN&NM=NM %OR FN&LM=LM %THENSTART; ! NUMBER OR LIST
STACK(FN)
%FINISHELSESTART; ! START 1
%IF FN=QUOTE %THENSTART; ! DATA WORD FOLLOWS
STACK(HD(IN))
IN=TL(IN)
%FINISHELSESTART; ! START 2
%IF FN=DOTS %THENSTART; ! DATA NAME FOLLOWS
%IF IN=NIL %THENSTART
ERROR('NAME MISSING AFTER :',EMPTY,1,IN)
%RETURN
%FINISH
FN=HD(IN)
IN=TL(IN)
%IF FN&WM=WM %THENSTART
TOP1:WORK1=GETVAL(FN,ENVIR)
%IF WORK1=UNDEF %THENSTART
ERROR(ERRMESS(3),FN,0,IN)
%IF JUMPFLAG=1 %THENRETURN
->TOP1
%FINISHELSE STACK(WORK1)
%FINISHELSESTART
ERROR(ERRMESS(4),FN,1,IN)
%RETURN
%FINISH
%FINISHELSESTART; ! START 3
%IF FN=LPAR %THENSTART
EVAL(4,IN,EACHVAL,WALKFN)
%IF JUMPFLAG=1 %THENRETURN
IN=CONS(LPAR,IN); ! PUT BACK LPAR FOR GETMATCH
WORK1=NIL
WORK1=GETMATCH(WORK1,IN); ! DISCARD UP TO MATCHING )
%IF WORK1#EMPTY %THENSTART
ERROR('MISSING )',EMPTY,1,IN)
%RETURN
%FINISH
%FINISHELSESTART; ! START 4
%IF FN=LANGBRKS %THENSTART; ! <
WORK1=NIL
%WHILE IN#NIL %AND HD(IN)#RANGBRKS %CYCLE
STKSYS(WORK1); ! IN CASE OF A COLLECT
EVAL(0,IN,EACHVAL,WALKFN)
WORK1=UNSTKSYS
%IF JUMPFLAG=1 %THENRETURN
WORK1=CONS(UNSTACK,WORK1)
%REPEAT
%IF IN=NIL %THENSTART
ERROR('MISSING >',EMPTY,1,IN)
%RETURN
%FINISH
IN=TL(IN)
STACK(REVERSE(WORK1))
%FINISHELSESTART; ! START 5
%IF FN=RPAR %OR FN=RANGBRKS %THENSTART
ERROR(ERRMESS(49),FN,1,IN)
%RETURN
%FINISH
FUNSPEC=FNVAL(FN>>8); ! GET FUNCTION SPEC
%IF FUNSPEC=0 %THENSTART; ! UNDEFINED
ERROR(ERRMESS(5),FN,0,IN)
%IF JUMPFLAG=1 %THENRETURN
->TOP
%FINISH
TYPE=FUNSPEC&B4; ! GET FUNCTION TYPE
%IF TYPE=SYSPRE %OR TYPE=USERPRE %THENSTART; ! PREFIX FUN
%IF TYPE=SYSPRE %THEN ARGNO=(FUNSPEC&B3B)>>16 %ELSEC
ARGNO=FUNSPEC&X'FF'; ! GET NUMBER OF ARGS
TRACE=(FUNSPEC&TRACEFLG)>>30
%IF TRACE=3 %THENSTART
STRTRACE(FN,' .')
DPRINTSTRING(' LOOKING FOR '.TOSTRING(ARGNO+48). %C
' INPUTS')
NOOLINE(1)
%FINISH
WORK1=ARGNO
%WHILE WORK1>0 %CYCLE; ! GATHER ARGS AND LEAVE ON STACK
%IF IN=NIL %THENSTART
ERROR(ERRMESS(2),FN,1,IN)
%IF TRACE=3 %THEN INDENT=INDENT-2 %ANDC
BYTEINTEGER(ADDR(PARSPR))=INDENT
%RETURN
%FINISH
EVAL(10,IN,EACHVAL,WALKFN)
%IF JUMPFLAG=1 %THENSTART
%IF TRACE=3 %THEN INDENT=INDENT-2 %ANDC
BYTEINTEGER(ADDR(PARSPR))=INDENT
%RETURN
%FINISH
WORK1=WORK1-1
%REPEAT
%IF TYPE=SYSPRE %THENSTART
->SYSTR(TRACE)
SYSTR(3):INDENT=INDENT-2; BYTEINTEGER(ADDR(PARSPR))=INDENT
SYSTR(2):STRTRACE(FN,' >')
%IF ARGNO#0 %THENSTART
DPRINTSTRING(' HAS ')
%CYCLE WORK1=1,1,ARGNO
DPRINTSTRING('INPUT'.TOSTRING(WORK1+48).' = ')
PRINTEL(STK(STKPNT+WORK1-ARGNO))
DPRINTSTRING(', ')
%REPEAT
%FINISH
NOOLINE(1)
->SYSTR(0)
SYSTR(1):STRTRACE(FN,' >')
NOOLINE(1)
SYSTR(0):APPLYSYS(FUNSPEC&B2,FN,IN,EACHVAL)
%IF JUMPFLAG=1 %THENSTART
%IF TRACE>0 %THEN INDENT=INDENT-2 %ANDC
BYTEINTEGER(ADDR(PARSPR))=INDENT
%RETURN
%FINISH
%FINISHELSESTART
FUNLIST=FUNSPEC&M16!LM; ! FUN NOW HAS USER DEF AS LIST
PARMLIST=TL(TL(TL(HD(FUNLIST)))); ! PARAMETRS
PARMLIST=REVQUOTE(PARMLIST) %UNLESS PARMLIST=NIL; ! REVERSE ORDER
%IF JUMPFLAG=1 %THENSTART
%IF TRACE=3 %THEN INDENT=INDENT-2 %ANDC
BYTEINTEGER(ADDR(PARSPR))=INDENT
%RETURN
%FINISH
%IF FUNLIST=WALKFN %AND TRACE#3 %THEN ->USRTR(2)
->USRTR(TRACE)
USRTR(3):INDENT=INDENT-2
BYTEINTEGER(ADDR(PARSPR))=INDENT
USRTR(2):STRTRACE(FN,' >')
%IF ARGNO#0 %THENSTART
DPRINTSTRING(' HAS ');WORK1=PARMLIST; WORK2=NIL
%WHILE WORK1#NIL %CYCLE
WORK2=CONS(HD(WORK1),WORK2)
WORK1=TL(WORK1)
%REPEAT
%WHILE ARGNO#0 %CYCLE
PRINTEL(HD(WORK2));DPRINTSTRING(' = ')
PRINTEL(STK(STKPNT+1-ARGNO));DPRINTSTRING(', ')
WORK2=TL(WORK2); ARGNO=ARGNO-1
%REPEAT
%FINISH
NOOLINE(1)
->USRTR(0)
USRTR(1):STRTRACE(FN,' >'); NOOLINE(1)
USRTR(0):STKSYS(IN);STKSYS(VAL);
%IF APPUCNT=APPULIM %THENSTART
ERROR(ERRMESS(32),APPULIM<<8!NM,1,IN)
%IF TRACE>0 %THEN INDENT=INDENT-2 %ANDC
BYTEINTEGER(ADDR(PARSPR))=INDENT
%RETURN
%FINISH
APPLYUSR(MAKEBIND(PARMLIST,ENVIR,FN),FUNLIST,TSTFLG,VAL,SEVERITY, %C
WALKFN)
VAL=UNSTKSYS;IN=UNSTKSYS
%IF JUMPFLAG=1 %THENSTART
%IF TRACE>0 %OR FUNLIST=WALKFN %THEN INDENT=INDENT-2 %ANDC
BYTEINTEGER(ADDR(PARSPR))=INDENT
%RETURN
%FINISH
%IF FUNLIST=WALKFN %THEN ->OUTR(2)
%FINISH
->OUTR(TRACE)
OUTR(2):OUTR(3):ENDTRACE(FN)
WORK1=STK(STKPNT)
DPRINTSTRING(' WITH ')
%IF WORK1&LM=LM %AND WORK1#NIL %AND HD(WORK1)=QQPROC %THENC
DPRINTSTRING('NO RESULT') %ELSESTART
DPRINTSTRING('RESULT = ')
PRINTEL(WORK1)
%FINISH
NOOLINE(1)
->OUTR(0)
OUTR(1):ENDTRACE(FN); NOOLINE(1)
OUTR(0):
%FINISHELSESTART; ! FINISH PREFIX. START 6
%IF TYPE=INTERP %THENSTART
APPLYSYS(FUNSPEC&B2,FN,IN,EACHVAL)
%IF JUMPFLAG=1 %THENRETURN
%FINISHELSESTART; ! START 7
%IF TYPE=INFIX %THENSTART; ! MISPLACED INFIX
ERROR(ERRMESS(49),FN,1,IN)
%RETURN
%FINISHELSESTART
ERROR('ERROR IN FN TYPE FOR EVAL',EMPTY,1,IN)
%RETURN
%FINISH
%FINISH; ! FINISH 7
%FINISH; ! FINISH 6
%FINISH; ! FINISH 5
%FINISH; ! FINISH 4
%FINISH; ! FINISH 3
%FINISH; ! FINISH 2
%FINISH; ! FINISH 1
!
!
! INFIX LOOP
INLP:%IF IN=NIL %THENRETURN; ! LINE EMPTY
FN=HD(IN)
%IF FN&WM#WM %THENRETURN; ! NOT A WORD-IE NUMBER OR LIST
FUNSPEC=FNVAL(FN>>8); ! GET FUNCTION DEF
%IF FUNSPEC=0 %THENRETURN; ! NOT DEFINED AS A FUNCTION
TYPE=FUNSPEC&B4; ! FUNCTION DEFINED-GET TYPE
%IF TYPE#INFIX %THENRETURN; ! TYPE NOT INFIX
NEXTPREC=(FUNSPEC&B3B)>>16; ! INFIX FUN-GET PRECEDENCE
%IF NEXTPREC<=PREC %THENRETURN; ! NEXT PRECECENCE LOWER THAN CURRENT
IN=TL(IN)
%IF IN=NIL %THENSTART
ERROR(ERRMESS(18),FN,1,IN)
%RETURN
%FINISH
TRACE=(FUNSPEC&TRACEFLG)>>30
%IF TRACE=3 %THENSTART
STRTRACE(FN,' .')
DPRINTSTRING(' LOOKING FOR SECOND INPUT')
NOOLINE(1)
%FINISH
EVAL(NEXTPREC,IN,EACHVAL,WALKFN)
%IF JUMPFLAG=1 %THENSTART
%IF TRACE=3 %THEN INDENT=INDENT-2 %ANDC
BYTEINTEGER(ADDR(PARSPR))=INDENT
%RETURN
%FINISH
->INFTR(TRACE)
INFTR(3):INDENT=INDENT-2;BYTEINTEGER(ADDR(PARSPR))=INDENT
INFTR(2):STRTRACE(FN,' >')
DPRINTSTRING(' INPUT1 = ');PRINTEL(STK(STKPNT-1))
DPRINTSTRING(', INPUT2 = ');PRINTEL(STK(STKPNT))
NOOLINE(1); ->INFTR(0)
INFTR(1):STRTRACE(FN,' >');NOOLINE(1)
INFTR(0):APPLYSYS(FUNSPEC&B2,FN,IN,EACHVAL)
%IF JUMPFLAG=1 %THENSTART
%IF TRACE>0 %THEN INDENT=INDENT-2 %ANDC
BYTEINTEGER(ADDR(PARSPR))=INDENT
%RETURN
%FINISH
->INFOUTR(TRACE)
INFOUTR(3):INFOUTR(2):ENDTRACE(FN)
DPRINTSTRING(' WITH RESULT = ')
PRINTEL(STK(STKPNT));NOOLINE(1);->INLP
INFOUTR(1):ENDTRACE(FN);NOOLINE(1)
INFOUTR(0):
->INLP
%END; ! END EVAL
!
%INTEGER V
EVAL(PREC,IN,UNDEF,WALKFN)
V=UNSTACK
%IF V&LM=LM %AND V#NIL %ANDC
(HD(V)=QQPROC %OR HD(V)=QQRESULT) %THEN STACK(V) %ELSEC
ERROR2(V) %ANDRETURN
%IF JUMPFLAG=1 %THENRETURN
%IF IN#NIL %THEN ERROR(ERRMESS(1),IN,1,IN)
%END; ! END EVALAPPL
!
!
%ROUTINE APPLYUSR(%INTEGER ENVIR,FUN,TSTFLG,VAL, %C
%INTEGERNAME SEVERITY,WALKFN)
%INTEGER IN,CURFUN,SAVESTK,STEP,TYPEIN
APPUCNT=APPUCNT+1
SAVESTK=STKPNT
CURFUN=FUN
STEP=1
%WHILE TL(CURFUN)#NIL %CYCLE
%IF STEP=NXTSTP %AND WALKFN=FUN %THENSTART
DPROMPT(' S:')
TYPEIN=READLINE
STKSYS(CURFUN); CURFUN=CONS(TYPEIN,NIL)
EVALAPPL(0,ENVIR,FUN,CURFUN,TYPEIN,TSTFLG,VAL,SEVERITY,WALKFN)
CURFUN=UNSTKSYS
%FINISHELSESTART
CURFUN=TL(CURFUN)
IN=TL(HD(CURFUN)); ! NEXT LINE WITHOUT NUMBER
STEP=STEP+1
EVALAPPL(0,ENVIR,FUN,CURFUN,IN,TSTFLG,VAL,SEVERITY,WALKFN)
%IF WALKFN=FUN %AND JUMPFLAG#1 %THENC
SPACES(INDENT) %AND PRINTLINE(HD(CURFUN))
%FINISH
%IF JUMPFLAG=1 %THENSTART; ! RETURN FROM USERINT OR ERROR
%IF SENDFLAG>1 %THENSTART
SENDFLAG=SENDFLAG-1
APPUCNT=APPUCNT-1
%RETURN
%FINISHELSESTART
%IF SENDFLAG=1 %THENSTART
SENDFLAG=0
JUMPFLAG=0
VAL=UNSTACK; ! VALUE SENT BACK
STKPNT=SAVESTK; ! RESET STACK
STACK(VAL)
APPUCNT=APPUCNT-1
%RETURN
%FINISH; ! SENDFLAG=1
%FINISH; ! SENDFLAG NOT >1
APPUCNT=APPUCNT-1
%RETURN; ! SENDFLAG=0
%FINISH; ! JUMPFLAG=1
VAL=UNSTACK
%REPEAT
%IF VAL&LM=LM %AND HD(VAL)=QQPROC %THENC
STACK(CONS(QQPROC,CONS(HD(TL(TL(HD(FUN)))),NSRTAIL))) %ELSEC
STACK(HD(TL(VAL))); ! [??RESULT VALUE] FROM RESULT OR OUTPUT
APPUCNT=APPUCNT-1
%END; ! END APPLYUSR
!
!
!
!
!
!
%ROUTINE DUMP(%STRING(80) ERRMESS)
%INTEGER I
%INTEGER SYSVAL
%BYTEINTEGERNAME TYPE,ARGNO
%SHORTINTEGERNAME SWITCH
TYPE==BYTEINTEGER(ADDR(SYSVAL))
SWITCH==SHORTINTEGER(ADDR(SYSVAL)+2)
ARGNO==BYTEINTEGER(ADDR(SYSVAL)+1)
!
%ROUTINE DUMPITEM(%INTEGER I)
%IF I&WM=WM %THENSTART
PRINTSTRING('W');WRITE(I>>8,5)
%RETURN
%FINISH
%IF I&LM=LM %THENSTART
PRINTSTRING('L');WRITE(I>>8,5)
%RETURN
%FINISH
%IF I&NM=NM %THENSTART
PRINTSTRING('N');SPACES(3)
%IF I<0 %THEN WRITE(I>>8!T8,0) %ELSE WRITE(I>>8,0)
%RETURN
%FINISH
PRINTSTRING('UNDEF')
%END; ! END DUMPITEM
NOOLINE(1)
PRSTRING('DUMPING');NOOLINE(1)
SELECTOUTPUT(1)
NEWLINES(5)
PRINTSTRING('********* DUMP STARTS **********'.DATE.' '.TIME)
NEWLINE;PRINTSTRING('ERROR - '.ERRMESS);NEWLINE
NEWLINE
%PRINTTEXT'WORD AREA';NEWLINE
%PRINTTEXT' INDEX WORD BASE VALUE '
%PRINTTEXT'FNTYPE FNSWITCH FNARGNO/PREC LIST INDEX';
NEWLINE
%CYCLE I=0,1,1022
%IF WA(I)='?' %THEN ->REP %ELSESTART
WRITE(I,5);SPACES(2)
PRINTSTRING(WA(I));SPACES(9-LENGTH(WA(I)));DUMPITEM(BVALUE(I))
SYSVAL=FNVAL(I)
WRITE(TYPE,10)
%IF TYPE#8 %THENSTART
WRITE(SWITCH,10)
%IF TYPE#4 %THEN WRITE(ARGNO,14)
%FINISHELSESTART
SPACES(11)
WRITE(SYSVAL&X'FF',14)
SPACES(2)
PRINTSTRING('L')
WRITE(SYSVAL<<8>>16,4)
%FINISH
NEWLINE
%FINISH
REP:%REPEAT
NEWLINE
%PRINTTEXT'LIST AREA';NEWLINES(2)
%PRINTTEXT'FUNCTION SPACE';NEWLINE
%IF LPOINT1=LISTOP %THENSTART;%PRINTTEXT'NO NEW FNSPACE';NEWLINE
->SEMISP;%FINISH
%CYCLE I=LISTOP,1,LPOINT1-1
WRITE(I,5);SPACES(2)
DUMPITEM(LA(I))
NEWLINE
%REPEAT
NEWLINE
LISTOP=LPOINT1
SEMISP:%PRINTTEXT'CURRENT SEMISPACE';NEWLINE
%IF LPOINT=LABASE %THENSTART;%PRINTTEXT'NO LIST SPACE';NEWLINE
->ENV;%FINISH
%CYCLE I=LABASE,1,LPOINT-1
WRITE(I,5);SPACES(2)
DUMPITEM(LA(I))
NEWLINE
%REPEAT
NEWLINE
ENV:%PRINTTEXT'LOCAL ENVIRS';NEWLINE
%IF TOPMARK=1022 %THENSTART
%PRINTTEXT'NO LOCALS' ;NEWLINE
%FINISHELSESTART
%CYCLE I=1023,1,TOPMARK
WRITE(BNAME(I)>>8,5);SPACES(2)
DUMPITEM(BVALUE(I))
NEWLINE
%REPEAT
%FINISH
NEWLINE
%PRINTTEXT'USER STACK'
NEWLINE
%IF STKPNT=0 %THENSTART
%PRINTTEXT'STACK EMPTY'
NEWLINE
%FINISHELSESTART
%CYCLE I=STKPNT,-1,1
WRITE(I,5)
SPACES(2)
PRINTEL(STK(I))
NEWLINE
%REPEAT
%FINISH
SELECTOUTPUT(0)
PRSTRING('DUMPED');NOOLINE(1)
%END; ! END DUMP
!
!
%ROUTINE INITIALISE
%INTEGER I
%STRING(64) IN
%ROUTINE GETFUNS
%STRING(64) NAME
%INTEGER SYSVAL
%INTEGER FNAME
%BYTEINTEGERNAME TYPE,ARGNO
%SHORTINTEGERNAME SWITCH
TYPE==BYTEINTEGER(ADDR(SYSVAL))
ARGNO==BYTEINTEGER(ADDR(SYSVAL)+1)
SWITCH==SHORTINTEGER(ADDR(SYSVAL)+2)
LP:READSTRING(NAME)
%IF NAME='ENDPROCS' %THENRETURN
SYSVAL=0
READ(TYPE)
READ(SWITCH)
%IF TYPE#4 %THEN READ(ARGNO)
FNAME=HASH(NAME)
OWNFUNS=CONS1(FNAME,OWNFUNS); ! LIST OF FNAMES IN PERM SPASE
FNVAL(FNAME>>8)=SYSVAL
->LP
%END; ! END GETFUNS
!
!
EUNAD=COMREG(16); ! ADDRESS OF USER NAME START
EUNBYTE(1)=6
%CYCLE I=2,1,7
EUNBYTE(I)=BYTEINTEGER(EUNAD+I-2)
%REPEAT
EMASUSER==STRING(ADDR(EUNBYTE(1))); ! USER NAME AS STRING
%CYCLE I=0,1,1022
BVALUE(I)=0
FNVAL(I)=0
OLDFN(I)=0
WA(I)='?'
%REPEAT
SPACE4=' '
QUOTEON=0
HASHVAL==INTSTR(2)
WORK1==STRING(ADDR(INTSTR(2))-1)
LBRAK==SPECHAR(13)
RBRAK==SPECHAR(14)
TDEV=0
ADDRBINBUFF=ADDR(BINBUFF(1))
BINARG1==SHORTINTEGER(ADDRBINBUFF+3)
BINARG2==SHORTINTEGER(ADDRBINBUFF+5)
BINARG3==SHORTINTEGER(ADDRBINBUFF+7)
BINARG4==SHORTINTEGER(ADDRBINBUFF+9)
BINARG5==SHORTINTEGER(ADDRBINBUFF+11)
DEVICE=TTY
DFILE(1)=NL
DPNT=1
CHAROUT=0
HASH1023=0
HASH1024=0
INDENT=1
PARSPR=' '
PRNUM=0
APPUCNT=0
APPULIM=200
STKPNT=0
STKTOP=0
SYSTKPNT=0
JUMPFLAG=0
JUMPOUT=0
SENDFLAG=0
QUITFLAG=0
HOLDFLAG=0
LPOINT=LA1B
LABASE=LA1B
LPOINT1=LAFNB
LISTOP=LAFNB
SEMISIZE=LA2B-LA1B
CLECTFLG=0
TOPMARK=1022
BASENVIR=1022
NUMTOP=2**23-1
NUMBOT=-2**23+1
EVALIMIT=10000
BORROWLOAD=0
BORROWFLAG=0
ENUF=0
SEP=''
FULLFLAG=0
EMPTY==NAMES(2)
SPACE1==NAMES(4)
ENEL==NAMES(6)
TAB==NAMES(8)
TRUE==NAMES(9)
FALSE==NAMES(11)
QUOTE==NAMES(14)
DOTS==NAMES(16)
LPAR==NAMES(17)
RPAR==NAMES(18)
COMMA==NAMES(19)
NIL==NAMES(20)
UNDEF==NAMES(21)
THEN==NAMES(22)
ELSE==NAMES(23)
END==NAMES(24)
DELETE==NAMES(25)
UNDO==NAMES(26)
UNDOS==NAMES(27)
RETITLE==NAMES(28)
DO==NAMES(29)
ERR==NAMES(30)
LOGONAME==NAMES(31)
QUIT==NAMES(32)
BREAK==NAMES(33)
IF==NAMES(34)
CLOSE==NAMES(35)
WHILE==NAMES(36)
THINKALOUD==NAMES(37)
FACT==NAMES(38)
IMPLIES==NAMES(39)
TOINFER==NAMES(40)
NEW==NAMES(41)
VBL==NAMES(42)
NOT==NAMES(43)
DATABASE==NAMES(44)
IMPRULES==NAMES(45)
INFRULES==NAMES(46)
FACTKEYS==NAMES(47)
IMPKEYS==NAMES(48)
INFKEYS==NAMES(49)
UP==NAMES(50)
DOWN==NAMES(51)
LANGBRKS==NAMES(52)
RANGBRKS==NAMES(53)
MINUS==NAMES(54)
QQPROC==NAMES(55)
DEFINEWORD==NAMES(56)
QQRESULT==NAMES(57)
INSERT==NAMES(58)
NULL==NAMES(59)
UNPARSE==NAMES(60)
SELECTINPUT(2)
READ(CFRACT)
I=1
LP:READSTRING(IN)
%IF IN#'ENDUP' %THENSTART
NAMES(I)=HASH(IN)
I=I+1
->LP
%FINISHELSESTART
NIL=NIL>>8<<8!LM; ! CHANGE MARKER ON NIL FROM WM TO LM
NSRTAIL=CONS1(NAMES(61),NIL)
GETID=CONS1(NAMES(62),NIL)
%CYCLE I=0,1,1022
ASSOCWA(I)=NIL
%REPEAT
OWNFUNS=NIL
GETFUNS
%CYCLE I=1,2,15
SETVAL(NAMES(I),NAMES(I+1),BASENVIR); ! INITVALS
%REPEAT
INITINF
SETVAL(THINKALOUD,TRUE,BASENVIR)
NEWFN=NIL
DEFINED=NIL
LOGOTIME=TIME100
NXTSTP=NUMTOP
SELECTINPUT(0)
CLOSESTREAM(2);CLEAR('ST02')
!
!******* GRAPHICS INITIALISATION
CURPIC=NIL
DEF PICTURE = 0
FRAMEFLAG=0 ;! NOT WITHIN FRAME
CURMOVIE=NIL ;! NO CURRENT MOVIE
CURFRAME=NIL
GRABLIST=NIL
%RETURN
%FINISH
%END; ! END INITIALISE
!
!
%ROUTINE LOGO(%INTEGER STKTOP,ENVIR,SEVERITY,FLAG)
%INTEGER VAL,IN,FUN,CURFUN,TSTFLG
VAL=UNDEF
CURMODE = NORMAL
IN=NIL
FUN=NIL
CURFUN=NIL
TSTFLG=0
PRNUM=PRNUM+1
! PROMPT A NUMBER WHEN REENTERING OF LOGO RECURSIVELY
! NOT IMPLEMENTED IN THIS VERSION
! PROMP=NUMTOSTR(PRNUM<<8).':'
PROMP='W: '
DPROMPT(PROMP)
%IF FLAG=1 %THENSTART
IN=GETID
->LP1
%FINISH
LP: %IF TDEV = 8 %THEN SET42(CHTXT)
IN=READLINE
LP1:EVALCNT=0
EVALAPPL(0,ENVIR,FUN,CURFUN,IN,TSTFLG,VAL,SEVERITY,UNDEF)
%IF SENDFLAG>0 %THENSTART; ! GO BACK TO APPLYUSR
%IF PRNUM>1 %THENSTART; ! NOT AT BASE LEVEL
PRNUM=PRNUM-1
PROMP=NUMTOSTR(PRNUM<<8).':'
DPROMPT(PROMP)
%RETURN
%FINISHELSESTART; ! AT BASE LEVEL
SENDFLAG=0;JUMPFLAG=0
%FINISH
%FINISH
VAL=UNSTACK
%IF JUMPFLAG=1 %THENSTART; ! ERROR RETURN OR USER HAS DONE
! CONTINUE, ABORT OR QUIT
STKPNT=STKTOP; ! RESET STACK - DISCARD EXCESS LEFT BY ERROR EXIT
%IF PRNUM#1 %THENSTART; ! NOT AT BASE LEVEL
%IF JUMPOUT=-1 %THENSTART; ! USER CONTINUE
JUMPOUT=0
JUMPFLAG=0
PRNUM=PRNUM-1
PROMP=NUMTOSTR(PRNUM<<8).':'
DPROMPT(PROMP)
%RETURN
%FINISH
%IF JUMPOUT>0 %THENSTART; ! USER ABORT OR QUIT
JUMPOUT=JUMPOUT-1
STACK(VAL)
PRNUM=PRNUM-1
PROMP=NUMTOSTR(PRNUM<<8).':'
DPROMPT(PROMP)
%RETURN
%FINISH
%FINISH; ! FINISH PRNUM#1
JUMPFLAG=0; ! EITHER PRNUM=1 OR PRNUM#1 AND JUMPOUT=0
JUMPOUT=0
%FINISH; ! FINISH JUMPFLAG=1
->LP
%END; ! END LOGO
!
!
!
%BEGIN
I=ADDR(RR(4)); ! ADDR OF RECOVERY INFO SAVE AREA
K=ADDR(SAVE(1)); ! ADDR OF USER DUMP SAVE AREA
*L_1,I
*STM_ 4,14,0(1); ! SAVE ENVIR IN RECOVERY AREA
*LA_2,<ERROR>; ! ADDR OF ENTRY POINT ON CONTINGENCY
*ST_2,44(1); ! INTO RECOVERY AREA
*MVI_44(1),8; ! SET PROGRAM MASK FOR INTEGER OFLOW
SIGNAL(0,I,0,FLAG); ! STACK RECOVERY INFO
*LA_11,2048(11); ! INC STACK POINTER TO LEAVE HOLE TO BE
! USED ON CONTINGENCY
!
! MAIN PROG STARTS
!
%IF STATUS('LOGODRIB',0)>=0 %THEN CRASHDRI; ! DRIBBLE FROM CRASH
NEWSMFILE('LOGODRIB,50008')
DEFINE('SM11,LOGODRIB')
FSTART=SMADDR(11,FLENGTH)
DPNT==INTEGER(FSTART)
DFILE==ARRAY(FSTART+8,DF)
NEWSMFILE('LOGOSTK,376831')
DEFINE('SM06,LOGOSTK')
FSTART=SMADDR(6,FLENGTH)
FNVAL==ARRAY(FSTART,INTFORM1); ! INTEGERARRAY(0:1022)
OLDFN==ARRAY(FSTART+4092,INTFORM1)
SYSTK==ARRAY(FSTART+8184,INTFORM2); ! INTEGERARRAY(1:2000)
LA==ARRAY(FSTART+16184,INTFORM3);! INTEGERARRAY (1:65536)
BNAME==ARRAY(FSTART+278328,INTFORM4); ! INTEGERARRAY(1023:3000)
BVALUE==ARRAY(FSTART+286240,INTFORM5); ! INTEGERARRAY(0:3000)
ASSOCWA==ARRAY(FSTART+298244,INTFORM1)
STK==ARRAY(FSTART+302336,INTFORM2)
WA==ARRAY(FSTART+310336,SFORM1); ! STRING(64)ARRAY (0:1022)
DEFINE('SM05,'.MASNUM.'LOGERRS')
FSTART=SMADDR(5,FLENGTH)
ERRMESS==ARRAY(FSTART,SFORM2); ! STRING(255)ARRAY(1:150)
DEFINE('ST02,'.MASNUM.'LNGNAM30')
INITIALISE
DEFINE('ST01,DUMPFILE')
DNEWLINE
DNEWLINE
DPRINTSTRING('LINGO - VERSION 3.0 '.DATE.' '.TIME)
LIST(MASNUM.'LOGINTRO')
DNEWLINE
DNEWLINE
LOGO(STKTOP,BASENVIR,0,1)
!
! RECOVERY ENTRY
ERROR:
*ST_1,ADUMP; ! USER DUMP ADDRESS
*ST_2,WT; ! WEIGHT OF INTERRUPT
*ST_3,R3
MOVE(104,ADUMP,K); !SAVE USER DUMP AREA IN CASE OF ANOTHER INT
%IF WT=128 %THENSTART; ! CONSOLE INT
INTCHAR==STRING(ADDR(R3))
%IF INTCHAR='Q' %THENSTART
DRIBBLE(INTQ)
QUITFLAG=1
->RESUME
%FINISH
%IF INTCHAR='H' %THENSTART
DRIBBLE(INTH)
HOLDFLAG=1
->RESUME
%FINISH
SIGNAL(4,I,0,FLAG); ! PASS TO OUTER LEVEL
%FINISH
%IF WT=132 %THENSTART; ! TIME EXCEEDED
GETTIM(TIMELIM); ! REQUEST ANOTHER ALLOACTION
%IF TIMELIM=0 %THENSTART; ! RATE EXCEEDED. NO MORE TIME
DPRINTSTRING(ERRMESS(52))
NOOLINE(2)
QUITFLAG=1; ! SIMULATE INT Q
%FINISH
%FINISHELSE SIGNAL(4,I,0,FLAG)
RESUME:I=ADDR(RR(4))
*L_1,I
*STM_4,14,0(1)
*LA_2,<ERROR>
*ST_2,44(1)
*MVI_44(1),8
SIGNAL(0,I,0,FLAG); ! RESTACK RECOVERY INFO
SIGNAL(5,K,0,FLAG); ! GO BACK TO USER ENVIR
%END
%ENDOFPROGRAM